From f53af093a456102ef5f8d1c1c1335e0a02b1cd84 Mon Sep 17 00:00:00 2001 From: Evgenii Akentev Date: Mon, 16 Sep 2024 19:04:13 +0400 Subject: [PATCH] Use Data.Array --- gcs.cabal | 4 +-- src/MarkSweep/Basic.hs | 81 +++++++++++++++++++++--------------------- 2 files changed, 42 insertions(+), 43 deletions(-) diff --git a/gcs.cabal b/gcs.cabal index a5c3a1a..e594ef4 100644 --- a/gcs.cabal +++ b/gcs.cabal @@ -18,8 +18,6 @@ common warnings library import: warnings exposed-modules: MarkSweep.Basic, Mutator - -- other-modules: - -- other-extensions: - build-depends: base ^>=4.18.2.1, mtl + build-depends: base ^>=4.18.2.1, mtl, array hs-source-dirs: src default-language: Haskell2010 diff --git a/src/MarkSweep/Basic.hs b/src/MarkSweep/Basic.hs index a608a36..260345f 100644 --- a/src/MarkSweep/Basic.hs +++ b/src/MarkSweep/Basic.hs @@ -4,6 +4,8 @@ module MarkSweep.Basic where + +import Data.Array import Control.Monad.State import Control.Monad.Identity import Mutator @@ -22,97 +24,96 @@ instance Mutator GcM where readFromRoots :: Int -> GcM ObjectPtr readFromRoots i = do GCState{roots} <- get - return $ roots !! i + return $ roots ! i readFromObject :: ObjectPtr -> GcM Value + readFromObject NullPtr = error "Null pointer" readFromObject (ObjectPtr i) = do GCState{heap} <- get - case heap !! i of + case heap ! i of Just o -> pure $ val o Nothing -> error "Incorrect pointer" readFromField :: Int -> ObjectPtr -> GcM ObjectPtr + readFromField _ NullPtr = error "Null pointer" readFromField f (ObjectPtr i) = do GCState{heap} <- get - case heap !! i of - Just o -> pure $ (fields o) !! f + case heap ! i of + Just o -> pure $ (fields o) ! f Nothing -> error "Incorrect pointer" writeToRoots :: Int -> ObjectPtr -> GcM () writeToRoots i ptr = do s@GCState{roots} <- get - case splitAt i roots of - ([], []) -> put $ s { roots = [ptr] } - (before, _:after) -> put $ s { roots = before ++ [ptr] ++ after } + put $ s { roots = roots // [(i, ptr)] } writeToObject :: Value -> ObjectPtr -> GcM () + writeToObject _ NullPtr = error "Null pointer" writeToObject v (ObjectPtr i) = do s@GCState{heap} <- get - let (before, o:after) = splitAt i heap - case o of + case heap ! i of Nothing -> error "Object is null" Just obj -> - put $ s { heap = before ++ [Just $ obj { val = v } ] ++ after } + put $ s { heap = heap // [(i, Just $ obj { val = v })] } writeToField :: Int -> ObjectPtr -> ObjectPtr -> GcM () + writeToField _ _ NullPtr = error "Null pointer" writeToField i ptr (ObjectPtr p) = do s@GCState{heap} <- get - let (before, o:after) = splitAt p heap - case o of + case heap ! p of Nothing -> error "Object is null" Just obj -> do - let (fBefore, _:fAfter) = splitAt i $ fields obj - put $ s { heap = (before ++ [Just $ obj { fields = fBefore ++ [ptr] ++ fAfter } ] ++ after) } + put $ s { heap = heap // [(p, Just $ obj { fields = fields obj // [(i, ptr)] })] } data Object = Object { val :: Value, - fields :: [ObjectPtr], + fields :: Array Int ObjectPtr, marked :: Bool } deriving (Eq, Show) data GCState = GCState { - roots :: [ObjectPtr], + roots :: Array Int ObjectPtr, heap :: Heap } deriving (Eq,Show) -type Heap = [Maybe Object] +type Heap = Array Int (Maybe Object) initState :: GCState -initState = GCState [] [Nothing | _ <- [1 :: Int ..8]] +initState = GCState + { roots = array (1, 8) [(i, NullPtr) | i <- [1..8]] + , heap = array (1, 8) [(i, Nothing) | i <- [1 :: Int ..8]] + } newtype GcM a = GcM { unGcM :: StateT GCState Identity a } deriving (Functor, Applicative, Monad, MonadState GCState) isMarked :: ObjectPtr -> Heap -> Bool isMarked NullPtr _ = False -isMarked (ObjectPtr p) h = Just True == (marked <$> (h !! p)) +isMarked (ObjectPtr p) h = Just True == (marked <$> (h ! p)) setMarked :: ObjectPtr -> Heap -> Heap setMarked NullPtr h = h -setMarked (ObjectPtr p) hs = reverse $ foldl step [] $ zip [0..] hs - where - step res (_, Nothing) = Nothing : res - step res (idx, Just obj) - | p == idx = (Just $ obj { marked = True }) : res - | otherwise = (Just obj) : res +setMarked (ObjectPtr p) hs = hs // [(p, (\o -> o { marked = True }) <$> (hs ! p)) ] allocate :: Value -> GcM (Either String ObjectPtr) allocate v = do s@GCState{heap} <- get - case foldl step (False, -1, []) heap of - (True, idx, res) -> do - put $ s { heap = reverse res} - pure $ Right $ ObjectPtr idx - _ -> pure $ Left "Out of memory" - where - step (True, idx, res) obj = (True, idx, obj : res) - step (_, idx, res) Nothing = (True, idx + 1, (Just $ Object v [] False) : res) - step (ok, idx, res) obj = (ok, idx + 1, obj : res) + case findIndexWithNothing heap of + Just p -> do + put $ s { heap = heap // [(p, Just $ Object v (array (1,8) [(i, NullPtr) | i <- [1..8]]) False)] } + pure $ Right $ ObjectPtr p + Nothing -> pure $ Left "Out of memory" + where + findIndexWithNothing h = foldl step Nothing $ assocs h + step _ (i, Nothing) = Just i + step acc _ = acc mark :: [ObjectPtr] -> Heap -> Heap mark [] h = h -mark ((ObjectPtr p):rest) h = case h !! p of - Just obj -> +mark (ptr:rest) h + | (ObjectPtr p) <- ptr + , Just obj <- h ! p + = let step acc NullPtr = acc step (wl, heap) child @@ -121,7 +122,7 @@ mark ((ObjectPtr p):rest) h = case h !! p of (workList, newH) = foldl step ([], h) $ fields obj in mark (workList ++ rest) newH - Nothing -> mark rest h + | otherwise = mark rest h markFromRoots :: GcM () markFromRoots = do @@ -130,7 +131,7 @@ markFromRoots = do put $ GCState roots newHeap where step heap ptr - | not (isMarked ptr heap) = + | ptr /= NullPtr && not (isMarked ptr heap) = let newH = setMarked ptr heap in mark [ptr] newH step heap _ = heap @@ -143,7 +144,7 @@ collect = do sweep :: GcM () sweep = do s@GCState{heap} <- get - put $ s { heap = map step heap } + put $ s { heap = fmap step heap } where step Nothing = Nothing step (Just o) = if marked o then Just (o { marked = False }) else Nothing @@ -155,7 +156,7 @@ main = do ptr <- new (IntVal 3) ptr2 <- new (IntVal 5) - writeToRoots 0 ptr + writeToRoots 1 ptr collect return [ptr, ptr2] -- 2.34.1