repos / gcs.git

Bitmap.hs

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