From: Evgenii Akentev Date: Tue, 17 Sep 2024 18:16:13 +0000 (+0400) Subject: TwoFinger works X-Git-Url: https://git.ak3n.com/?a=commitdiff_plain;h=435c3a5607489a44d6482253ac577dec5ab1706c;p=gcs.git TwoFinger works --- 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)