From 82d8d96c221c1f590f35cb8a9b61f4102ec75107 Mon Sep 17 00:00:00 2001 From: Evgenii Akentev Date: Mon, 16 Sep 2024 19:24:55 +0400 Subject: [PATCH] Add MarkSweep.Bitmap --- gcs.cabal | 6 +- src/MarkSweep/Bitmap.hs | 171 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 172 insertions(+), 5 deletions(-) create mode 100644 src/MarkSweep/Bitmap.hs diff --git a/gcs.cabal b/gcs.cabal index e594ef4..dfa9fc4 100644 --- a/gcs.cabal +++ b/gcs.cabal @@ -1,23 +1,19 @@ cabal-version: 3.0 name: gcs version: 0.1.0.0 --- synopsis: --- description: license: BSD-3-Clause license-file: LICENSE author: Evgenii Akentev maintainer: hi@ak3n.com --- copyright: build-type: Simple extra-doc-files: CHANGELOG.md --- extra-source-files: common warnings ghc-options: -Wall library import: warnings - exposed-modules: MarkSweep.Basic, Mutator + exposed-modules: MarkSweep.Basic, MarkSweep.Bitmap, Mutator build-depends: base ^>=4.18.2.1, mtl, array hs-source-dirs: src default-language: Haskell2010 diff --git a/src/MarkSweep/Bitmap.hs b/src/MarkSweep/Bitmap.hs new file mode 100644 index 0000000..3a56037 --- /dev/null +++ b/src/MarkSweep/Bitmap.hs @@ -0,0 +1,171 @@ +{-# language ImportQualifiedPost, InstanceSigs, DuplicateRecordFields + , LambdaCase, RecordWildCards, NamedFieldPuns, TypeSynonymInstances + , DerivingStrategies, GeneralizedNewtypeDeriving #-} + +module MarkSweep.Bitmap where + + +import Data.Array +import Control.Monad.State +import Control.Monad.Identity +import Mutator + +instance Mutator GcM where + new :: Value -> GcM ObjectPtr + new v = do + allocate v >>= \case + Right ptr -> pure ptr + _ -> do + collect + allocate v >>= \case + Right ptr -> pure ptr + Left s -> error s + + readFromRoots :: Int -> GcM ObjectPtr + readFromRoots i = do + GCState{roots} <- get + return $ roots ! i + + readFromObject :: ObjectPtr -> GcM Value + readFromObject NullPtr = error "Null pointer" + readFromObject (ObjectPtr i) = do + GCState{heap} <- get + 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 + Nothing -> error "Incorrect pointer" + + writeToRoots :: Int -> ObjectPtr -> GcM () + writeToRoots i ptr = do + s@GCState{roots} <- get + put $ s { roots = roots // [(i, ptr)] } + + writeToObject :: Value -> ObjectPtr -> GcM () + writeToObject _ NullPtr = error "Null pointer" + writeToObject v (ObjectPtr i) = do + s@GCState{heap} <- get + case heap ! i of + Nothing -> error "Object is null" + Just obj -> + 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 + case heap ! p of + Nothing -> error "Object is null" + Just obj -> do + put $ s { heap = heap // [(p, Just $ obj { fields = fields obj // [(i, ptr)] })] } + +data Object = Object { + val :: Value, + fields :: Array Int ObjectPtr +} deriving (Eq, Show) + +data GCState = GCState { + roots :: Array Int ObjectPtr, + heap :: Heap, + bitmap :: Bitmap +} deriving (Eq,Show) + +type Heap = Array Int (Maybe Object) +type Bitmap = Array Int Bool + +emptyBM :: Bitmap +emptyBM = array (1, 8) [(i, False) | i <- [1..8]] + +initState :: GCState +initState = GCState + { roots = array (1, 8) [(i, NullPtr) | i <- [1..8]] + , heap = array (1, 8) [(i, Nothing) | i <- [1..8]] + , bitmap = emptyBM + } + +newtype GcM a = GcM { unGcM :: StateT GCState Identity a } + deriving (Functor, Applicative, Monad, MonadState GCState) + +isMarked :: ObjectPtr -> Bitmap -> Bool +isMarked NullPtr _ = False +isMarked (ObjectPtr p) bm = bm ! p + +setMarked :: ObjectPtr -> Bitmap -> Bitmap +setMarked NullPtr h = h +setMarked (ObjectPtr p) bm = bm // [(p, True) ] + +allocate :: Value -> GcM (Either String ObjectPtr) +allocate v = do + s@GCState{heap} <- get + case findIndexWithNothing heap of + Just p -> do + put $ s { heap = heap // [(p, Just $ Object v (array (1,8) [(i, NullPtr) | i <- [1..8]]))] } + 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 -> Bitmap -> Bitmap +mark [] _ bm = bm +mark (ptr:rest) h bm + | (ObjectPtr p) <- ptr + , Just obj <- h ! p + = + let + step acc NullPtr = acc + step (wl, bm') child + | not (isMarked child bm') = (child : wl, setMarked child bm') + step acc _ = acc + + (workList, newBm) = foldl step ([], bm) $ fields obj + in mark (workList ++ rest) h newBm + | otherwise = mark rest h bm + +markFromRoots :: GcM () +markFromRoots = do + GCState{..} <- get + let newBm = foldl (step heap) bitmap roots + put $ GCState roots heap newBm + where + step heap bm ptr + | ptr /= NullPtr && not (isMarked ptr bm) = + let newBm = setMarked ptr bm + in mark [ptr] heap newBm + step _ bm _ = bm + +collect :: GcM () +collect = do + markFromRoots + sweep + +sweep :: GcM () +sweep = do + s@GCState{heap, bitmap} <- get + put $ s + { heap = array (1,8) $ foldl (step bitmap) [] $ assocs heap + , bitmap = emptyBM + } + where + step _ acc (i, Nothing) = (i, Nothing) : acc + step bm acc (i, Just o) = (i, if isMarked (ObjectPtr i) bm then Just o else Nothing) : acc + +main :: IO () +main = do + let + res = flip runState initState $ unGcM $ do + ptr <- new (IntVal 3) + ptr2 <- new (IntVal 5) + + writeToRoots 1 ptr + + collect + return [ptr, ptr2] + print res -- 2.34.1