repos / gcs.git

commit

82d8d96

parent

f53af09

author

Evgenii Akentev

date

2024-09-16 19:24:55 +0400 +04

Add MarkSweep.Bitmap

 1@@ -1,23 +1,19 @@
 2 cabal-version:      3.0
 3 name:               gcs
 4 version:            0.1.0.0
 5--- synopsis:
 6--- description:
 7 license:            BSD-3-Clause
 8 license-file:       LICENSE
 9 author:             Evgenii Akentev
10 maintainer:         hi@ak3n.com
11--- copyright:
12 build-type:         Simple
13 extra-doc-files:    CHANGELOG.md
14--- extra-source-files:
15 
16 common warnings
17     ghc-options: -Wall
18 
19 library
20     import:           warnings
21-    exposed-modules:  MarkSweep.Basic, Mutator
22+    exposed-modules:  MarkSweep.Basic, MarkSweep.Bitmap, Mutator
23     build-depends:    base ^>=4.18.2.1, mtl, array
24     hs-source-dirs:   src
25     default-language: Haskell2010

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