From 0cf561fe462233144bfec93c11c3564340e46844 Mon Sep 17 00:00:00 2001 From: Evgenii Akentev Date: Tue, 17 Sep 2024 19:19:08 +0400 Subject: [PATCH] Add MarkCompact.TwoFinger --- gcs.cabal | 4 +- src/MarkCompact/TwoFinger.hs | 234 +++++++++++++++++++++++++++++++++++ src/MarkSweep/Bitmap.hs | 4 +- 3 files changed, 240 insertions(+), 2 deletions(-) create mode 100644 src/MarkCompact/TwoFinger.hs diff --git a/gcs.cabal b/gcs.cabal index dfa9fc4..19d44b3 100644 --- a/gcs.cabal +++ b/gcs.cabal @@ -13,7 +13,9 @@ common warnings library import: warnings - exposed-modules: MarkSweep.Basic, MarkSweep.Bitmap, Mutator + exposed-modules: MarkSweep.Basic, MarkSweep.Bitmap + , MarkCompact.TwoFinger + , Mutator build-depends: base ^>=4.18.2.1, mtl, array hs-source-dirs: src default-language: Haskell2010 diff --git a/src/MarkCompact/TwoFinger.hs b/src/MarkCompact/TwoFinger.hs new file mode 100644 index 0000000..50f4204 --- /dev/null +++ b/src/MarkCompact/TwoFinger.hs @@ -0,0 +1,234 @@ +{-# language ImportQualifiedPost, InstanceSigs, DuplicateRecordFields + , LambdaCase, RecordWildCards, NamedFieldPuns, TypeSynonymInstances + , DerivingStrategies, GeneralizedNewtypeDeriving #-} + +module MarkCompact.TwoFinger where + +import Data.List (sortBy) +import Data.Function (on) +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, + forwardAddress :: Maybe Int, + 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 Nothing (array (1,8) [(i, NullPtr) | i <- [1..8]]))] } + pure $ Right $ ObjectPtr p + Nothing -> pure $ Left "Out of memory" + where + findIndexWithNothing h = foldl step Nothing $ sortBy (flip compare `on` fst) $ 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 + compact + +compact :: GcM () +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) ] } + +-- slotSize == 1 +relocate :: Int -> Int -> GcM Int +relocate start end = go start end + where + go :: Int -> Int -> GcM Int + go free scan + | free < scan = do + gc <- get + let bm = bitmap gc + let indicesToUnmark = fmap fst $ takeWhile (\(_, marked) -> marked) $ assocs bm + free' = if indicesToUnmark == [] then free else maximum indicesToUnmark + bm' = bm // [(i, False) | i <- indicesToUnmark] + put $ gc { bitmap = bm' } + + let + findIndexStep marked (ok, idx) + | not marked && idx > free' = (ok, idx - 1) + | otherwise = (True, idx) + scan' = snd $ foldr findIndexStep (False, scan) bm + + if scan' > free' then do + put $ gc { bitmap = bm' // [(scan', False)]} + + move scan' free' + + let obj = (heap gc) ! scan' + put $ gc { heap = heap gc // [ (scan', (\o -> o { forwardAddress = Just free' } ) <$> obj ) ] } + + go (free' + 1) (scan' - 1) + else go free' scan' + | otherwise = pure free + +-- slotSize == 1 +updateReferences :: Int -> Int -> GcM () +updateReferences start end = do + s@GCState{heap, roots} <- get + + let + step NullPtr = NullPtr + step ptr@(ObjectPtr 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) } + +main :: IO () +main = do + let + res = flip runState initState $ unGcM $ do + ptr <- new (IntVal 1) + ptr2 <- new (IntVal 2) + ptr3 <- new (IntVal 3) + ptr4 <- new (IntVal 4) + ptr5 <- new (IntVal 5) + ptr6 <- new (IntVal 6) + ptr7 <- new (IntVal 7) + ptr8 <- new (IntVal 8) + + writeToRoots 1 ptr + + collect + + + return [ptr, ptr2] + print res diff --git a/src/MarkSweep/Bitmap.hs b/src/MarkSweep/Bitmap.hs index 3a56037..e37151b 100644 --- a/src/MarkSweep/Bitmap.hs +++ b/src/MarkSweep/Bitmap.hs @@ -5,6 +5,8 @@ module MarkSweep.Bitmap where +import Data.List +import Data.Function (on) import Data.Array import Control.Monad.State import Control.Monad.Identity @@ -109,7 +111,7 @@ allocate v = do pure $ Right $ ObjectPtr p Nothing -> pure $ Left "Out of memory" where - findIndexWithNothing h = foldl step Nothing $ assocs h + findIndexWithNothing h = foldl step Nothing $ sortBy (flip compare `on` fst) $ assocs h step _ (i, Nothing) = Just i step acc _ = acc -- 2.34.1