From 435c3a5607489a44d6482253ac577dec5ab1706c Mon Sep 17 00:00:00 2001
From: Evgenii Akentev <hi@ak3n.com>
Date: Tue, 17 Sep 2024 22:16:13 +0400
Subject: [PATCH] TwoFinger works

---
 src/MarkCompact/TwoFinger.hs | 49 ++++++++++++++++++++----------------
 1 file changed, 27 insertions(+), 22 deletions(-)

diff --git a/src/MarkCompact/TwoFinger.hs b/src/MarkCompact/TwoFinger.hs
index 9667e13..7062cee 100644
--- a/src/MarkCompact/TwoFinger.hs
+++ b/src/MarkCompact/TwoFinger.hs
@@ -153,11 +153,10 @@ compact = do
   free <- relocate 1 8
   updateReferences 1 free
 
-move :: Int -> Int -> GcM ()
-move from to = do
-  s@GCState{heap} <- get
-  let obj = heap ! from
-  put $ s { heap = heap // [ (to, obj), (from, Nothing) ] }
+move :: Int -> Int -> Heap -> Heap
+move from to h =
+  let obj = h ! from
+  in h // [ (to, obj) ]
 
 -- slotSize == 1
 relocate :: Int -> Int -> GcM Int
@@ -169,27 +168,33 @@ relocate start end = go start end
         gc <- get
         let bm = bitmap gc
         let indicesToUnmark = fmap fst $ takeWhile (\(_, marked) -> marked) $ sortBy (flip compare `on` Down . fst) $ assocs bm 
-            free' = if indicesToUnmark == [] then free else maximum indicesToUnmark
+            free' = if indicesToUnmark == [] then 1 + free else 1 + maximum indicesToUnmark
             bm' = bm // [(i, False) | i <- indicesToUnmark] 
-        put $ gc { bitmap = traceShow (free', indicesToUnmark) bm', heap = heap gc // [(i, Nothing) | (i, x) <- assocs bm, x == False]  }
 
         let
-          findIndexStep (_, marked) idx
-            | not marked && idx > free' = idx - 1
-            | otherwise = idx 
-          scan' = traceShowId $ foldr findIndexStep scan $ traceShowId $ take scan $ sortBy (flip compare `on` Down . fst) $ assocs bm'
+          findIndexStep (_, marked) acc@(found, idx)
+            | found = acc
+            | not marked && idx > free' = (False, idx - 1)
+            | otherwise = (True, idx) 
+          scan' = snd $ foldr findIndexStep (False, scan) $ take scan $ sortBy (flip compare `on` Down . fst) $ assocs bm'
        
-        if scan' > free' then do
-          put $ gc { bitmap = bm' // [(scan', False)]}
+        let newH = if indicesToUnmark == [] then heap gc else heap gc // [(i, Nothing) | (i, x) <- assocs bm, x == False] 
+        put $ gc { bitmap = bm' -- traceShow ("updating bitmap", free', indicesToUnmark, newH, bm') bm'
+          , heap = newH }      
 
-          move scan' free'
+        
+        if (scan' > free') then do
 
-          let obj = (heap gc) ! scan'
-          put $ gc { heap = heap gc // [ (scan', (\o -> o { forwardAddress = Just free' } ) <$> obj ) ] }
+          let newHeap = move scan' free' newH
+          let obj = newHeap ! scan'
+          let newnewHeap = newHeap // [ (scan', (\o -> o { forwardAddress = Just free' } ) <$> obj ) ] 
+          put $ gc { bitmap = bm' // [(scan', False)], heap = newnewHeap }
 
           go (free' + 1) (scan' - 1)
         else go free' scan'
-      | otherwise = pure free
+      | otherwise = do
+        GCState{heap, bitmap} <- get
+        pure free -- traceShow (" leaving", free, scan, heap, bitmap) free
 
 -- slotSize == 1
 updateReferences :: Int -> Int -> GcM ()
@@ -199,18 +204,17 @@ updateReferences start end = do
   let
     step NullPtr = NullPtr
     step ptr@(ObjectPtr p) =
-      let newPtr = forwardAddress <$> heap ! p
+      let newPtr = forwardAddress <$> (heap ! p)
       in case newPtr of
         Just (Just newPtr') | p >= end -> ObjectPtr newPtr'
         _ -> ptr
-  put $ s { roots = fmap step roots }
 
   let
     updateStep (scan, res) item
       | scan < end, Just obj <- item = (scan + 1, (scan, Just $ obj { fields = fmap step $ fields obj }) : res)
       | otherwise = (scan + 1, res)
 
-  put $ s { heap = heap // (snd $ foldl updateStep (start, []) heap) }
+  put $ s { roots = fmap step roots, heap = heap // (snd $ foldl updateStep (start, []) heap) }
 
 main :: IO ()
 main = do
@@ -233,7 +237,8 @@ main = do
         collect
 
         ptr2' <- new (IntVal 2)
+        writeToRoots 2 ptr2'
         collect
         
-        return [ptr, ptr2, ptr2']
-  print res
+        return [ptr, ptr2]
+  putStrLn $ "RESULT:" ++ (show $ snd res)
-- 
2.34.1