From: Evgenii Akentev Date: Wed, 18 Sep 2024 06:22:30 +0000 (+0400) Subject: Add MarkCompact.Lisp2 X-Git-Url: https://git.ak3n.com/?a=commitdiff_plain;h=f8e1ec441c6293931e769dd8aef47bac9caa8689;p=gcs.git Add MarkCompact.Lisp2 --- diff --git a/gcs.cabal b/gcs.cabal index 19d44b3..4626cef 100644 --- a/gcs.cabal +++ b/gcs.cabal @@ -14,7 +14,7 @@ common warnings library import: warnings exposed-modules: MarkSweep.Basic, MarkSweep.Bitmap - , MarkCompact.TwoFinger + , MarkCompact.TwoFinger, MarkCompact.Lisp2 , Mutator build-depends: base ^>=4.18.2.1, mtl, array hs-source-dirs: src diff --git a/src/MarkCompact/Lisp2.hs b/src/MarkCompact/Lisp2.hs new file mode 100644 index 0000000..498481e --- /dev/null +++ b/src/MarkCompact/Lisp2.hs @@ -0,0 +1,238 @@ +{-# language ImportQualifiedPost, InstanceSigs, DuplicateRecordFields + , LambdaCase, RecordWildCards, NamedFieldPuns, TypeSynonymInstances + , DerivingStrategies, GeneralizedNewtypeDeriving #-} + +module MarkCompact.Lisp2 where + +import Debug.Trace +import Data.Ord (Down(..)) +import Data.List +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 = ((+)1) <$> (elemIndex Nothing $ map snd $ sortBy (flip compare `on` Down . fst) $ assocs h) + +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 + computeLocations 1 8 1 + updateReferences 1 8 + relocate 1 8 + +computeLocations :: Int -> Int -> Int -> GcM () +computeLocations start end toRegion = go start toRegion end + where + go :: Int -> Int -> Int -> GcM () + go scan free end + | scan < end = do + s@GCState{..} <- get + newFree <- if isMarked (ObjectPtr scan) bitmap then do + put $ s { heap = heap // [ (scan, (\o -> o { forwardAddress = Just free } ) <$> (heap ! scan) ) ] } + pure (free + 1) + else pure free + go (scan + 1) newFree end + | otherwise = pure () + +move :: Int -> Int -> Heap -> Heap +move from to h = + let obj = h ! from + in h // [ (to, obj) ] + +-- slotSize == 1 +relocate :: Int -> Int -> GcM () +relocate start end = go start end + where + go :: Int -> Int -> GcM () + go scan end + | scan < end = do + s@GCState{..} <- get + if isMarked (ObjectPtr scan) bitmap then do + case forwardAddress <$> (heap ! scan) of + Just (Just dest) -> do + put $ s { heap = move scan dest heap, bitmap = bitmap // [(dest, False)] } + Nothing -> pure () + else pure () + go (scan + 1) end + | otherwise = pure () + +-- 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') -> ObjectPtr newPtr' + _ -> ptr + + 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 { roots = fmap step roots, heap = heap // (snd $ foldl updateStep (start, []) heap) } + +main :: IO () +main = do + let + res = flip runState initState $ unGcM $ do + ptr <- new (IntVal 1) + + writeToRoots 1 ptr + + 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 5 ptr6 + + collect + +-- ptr2' <- new (IntVal 2) + -- writeToRoots 2 ptr2' + -- collect + + return [ptr, ptr2] + putStrLn $ "RESULT:" ++ (show $ snd res)