--- /dev/null
+{-# 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
projects / gcs.git / commitdiff