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