repos / gcs.git

Basic.hs

  1{-# language ImportQualifiedPost, InstanceSigs, DuplicateRecordFields
  2 , LambdaCase, RecordWildCards, NamedFieldPuns, TypeSynonymInstances
  3 , DerivingStrategies, GeneralizedNewtypeDeriving #-}
  4
  5module MarkSweep.Basic where
  6
  7
  8import Data.Array
  9import Control.Monad.State
 10import Control.Monad.Identity
 11import Mutator 
 12
 13instance Mutator GcM where
 14  new :: Value -> GcM ObjectPtr
 15  new v = do
 16    allocate v >>= \case
 17      Right ptr -> pure ptr 
 18      _ -> do
 19        collect
 20        allocate v >>= \case
 21          Right ptr -> pure ptr
 22          Left s -> error s
 23
 24  readFromRoots :: Int -> GcM ObjectPtr
 25  readFromRoots i = do
 26    GCState{roots} <- get
 27    return $ roots ! i
 28 
 29  readFromObject :: ObjectPtr -> GcM Value
 30  readFromObject NullPtr = error "Null pointer"
 31  readFromObject (ObjectPtr i) = do
 32   GCState{heap} <- get
 33   case heap ! i of
 34    Just o -> pure $ val o
 35    Nothing -> error "Incorrect pointer"
 36
 37  readFromField :: Int -> ObjectPtr -> GcM ObjectPtr
 38  readFromField _ NullPtr = error "Null pointer"
 39  readFromField f (ObjectPtr i) = do
 40   GCState{heap} <- get
 41   case heap ! i of
 42    Just o -> pure $ (fields o) ! f
 43    Nothing -> error "Incorrect pointer"
 44
 45  writeToRoots :: Int -> ObjectPtr -> GcM ()
 46  writeToRoots i ptr = do
 47    s@GCState{roots} <- get
 48    put $ s { roots = roots // [(i, ptr)] }
 49
 50  writeToObject :: Value -> ObjectPtr -> GcM ()
 51  writeToObject _ NullPtr = error "Null pointer"
 52  writeToObject v (ObjectPtr i) = do
 53   s@GCState{heap} <- get
 54   case heap ! i of
 55    Nothing -> error "Object is null"
 56    Just obj ->
 57     put $ s { heap = heap // [(i, Just $ obj { val = v })] }
 58
 59  writeToField :: Int -> ObjectPtr -> ObjectPtr -> GcM ()
 60  writeToField _ _ NullPtr = error "Null pointer"
 61  writeToField i ptr (ObjectPtr p) = do
 62    s@GCState{heap} <- get
 63    case heap ! p of 
 64      Nothing -> error "Object is null"
 65      Just obj -> do
 66        put $ s { heap = heap // [(p, Just $ obj { fields = fields obj // [(i, ptr)] })]  }
 67
 68data Object = Object {
 69  val :: Value,
 70  fields :: Array Int ObjectPtr,
 71  marked :: Bool
 72} deriving (Eq, Show)
 73
 74data GCState = GCState {
 75  roots :: Array Int ObjectPtr,
 76  heap :: Heap
 77} deriving (Eq,Show)
 78
 79type Heap = Array Int (Maybe Object)
 80
 81initState :: GCState
 82initState = GCState
 83  { roots = array (1, 8) [(i, NullPtr) | i <- [1..8]]
 84  , heap = array (1, 8) [(i, Nothing) | i <- [1 :: Int ..8]]
 85  }
 86
 87newtype GcM a = GcM { unGcM :: StateT GCState Identity a }
 88  deriving (Functor, Applicative, Monad, MonadState GCState)
 89
 90isMarked :: ObjectPtr -> Heap -> Bool
 91isMarked NullPtr _ = False
 92isMarked (ObjectPtr p) h = Just True == (marked <$> (h ! p))
 93
 94setMarked :: ObjectPtr -> Heap -> Heap
 95setMarked NullPtr h = h
 96setMarked (ObjectPtr p) hs = hs // [(p, (\o -> o { marked = True }) <$> (hs ! p)) ]
 97
 98allocate :: Value -> GcM (Either String ObjectPtr) 
 99allocate v = do
100  s@GCState{heap} <- get
101  case findIndexWithNothing heap of
102    Just p -> do
103      put $ s { heap = heap // [(p, Just $ Object v (array (1,8) [(i, NullPtr) | i <- [1..8]]) False)] }
104      pure $ Right $ ObjectPtr p
105    Nothing -> pure $ Left "Out of memory"
106  where
107      findIndexWithNothing h = foldl step Nothing $ assocs h
108      step _ (i, Nothing) = Just i
109      step acc _ = acc
110
111mark :: [ObjectPtr] -> Heap -> Heap
112mark [] h = h
113mark (ptr:rest) h
114  | (ObjectPtr p) <- ptr
115  , Just obj <- h ! p
116  =
117    let
118      step acc NullPtr = acc
119      step (wl, heap) child
120        | not (isMarked child h) = (child : wl, setMarked child heap)
121      step acc _ = acc
122      
123      (workList, newH) = foldl step ([], h) $ fields obj
124    in mark (workList ++ rest) newH
125  | otherwise = mark rest h
126
127markFromRoots :: GcM ()
128markFromRoots = do
129  GCState{..} <- get
130  let newHeap = foldl step heap roots
131  put $ GCState roots newHeap
132  where
133    step heap ptr
134      | ptr /= NullPtr && not (isMarked ptr heap) =
135        let newH = setMarked ptr heap
136        in mark [ptr] newH
137    step heap _ = heap
138
139collect :: GcM ()
140collect = do
141  markFromRoots
142  sweep
143
144sweep :: GcM ()
145sweep = do
146  s@GCState{heap} <- get
147  put $ s { heap = fmap step heap }
148  where
149    step Nothing = Nothing
150    step (Just o) = if marked o then Just (o { marked = False }) else Nothing
151
152main :: IO ()
153main = do
154  let
155    res = flip runState initState $ unGcM $ do
156        ptr <- new (IntVal 3)
157        ptr2 <- new (IntVal 5) 
158
159        writeToRoots 1 ptr 
160
161        collect
162        return [ptr, ptr2]
163  print res