repos / gcs.git

commit

f8e1ec4

parent

435c3a5

author

Evgenii Akentev

date

2024-09-18 10:22:30 +0400 +04

Add MarkCompact.Lisp2

1@@ -14,7 +14,7 @@ common warnings
2 library
3     import:           warnings
4     exposed-modules:  MarkSweep.Basic, MarkSweep.Bitmap
5-                    , MarkCompact.TwoFinger
6+                    , MarkCompact.TwoFinger, MarkCompact.Lisp2
7                     , Mutator
8     build-depends:    base ^>=4.18.2.1, mtl, array
9     hs-source-dirs:   src

  1@@ -0,0 +1,238 @@
  2+{-# language ImportQualifiedPost, InstanceSigs, DuplicateRecordFields
  3+ , LambdaCase, RecordWildCards, NamedFieldPuns, TypeSynonymInstances
  4+ , DerivingStrategies, GeneralizedNewtypeDeriving #-}
  5+
  6+module MarkCompact.Lisp2 where
  7+
  8+import Debug.Trace 
  9+import Data.Ord (Down(..))
 10+import Data.List
 11+import Data.Function (on)
 12+import Data.Array
 13+import Control.Monad.State
 14+import Control.Monad.Identity
 15+import Mutator 
 16+
 17+instance Mutator GcM where
 18+  new :: Value -> GcM ObjectPtr
 19+  new v = do
 20+    allocate v >>= \case
 21+      Right ptr -> pure ptr 
 22+      _ -> do
 23+        collect
 24+        allocate v >>= \case
 25+          Right ptr -> pure ptr
 26+          Left s -> error s
 27+
 28+  readFromRoots :: Int -> GcM ObjectPtr
 29+  readFromRoots i = do
 30+    GCState{roots} <- get
 31+    return $ roots ! i
 32+ 
 33+  readFromObject :: ObjectPtr -> GcM Value
 34+  readFromObject NullPtr = error "Null pointer"
 35+  readFromObject (ObjectPtr i) = do
 36+   GCState{heap} <- get
 37+   case heap ! i of
 38+    Just o -> pure $ val o
 39+    Nothing -> error "Incorrect pointer"
 40+
 41+  readFromField :: Int -> ObjectPtr -> GcM ObjectPtr
 42+  readFromField _ NullPtr = error "Null pointer"
 43+  readFromField f (ObjectPtr i) = do
 44+   GCState{heap} <- get
 45+   case heap ! i of
 46+    Just o -> pure $ (fields o) ! f
 47+    Nothing -> error "Incorrect pointer"
 48+
 49+  writeToRoots :: Int -> ObjectPtr -> GcM ()
 50+  writeToRoots i ptr = do
 51+    s@GCState{roots} <- get
 52+    put $ s { roots = roots // [(i, ptr)] }
 53+
 54+  writeToObject :: Value -> ObjectPtr -> GcM ()
 55+  writeToObject _ NullPtr = error "Null pointer"
 56+  writeToObject v (ObjectPtr i) = do
 57+   s@GCState{heap} <- get
 58+   case heap ! i of
 59+    Nothing -> error "Object is null"
 60+    Just obj ->
 61+     put $ s { heap = heap // [(i, Just $ obj { val = v })] }
 62+
 63+  writeToField :: Int -> ObjectPtr -> ObjectPtr -> GcM ()
 64+  writeToField _ _ NullPtr = error "Null pointer"
 65+  writeToField i ptr (ObjectPtr p) = do
 66+    s@GCState{heap} <- get
 67+    case heap ! p of 
 68+      Nothing -> error "Object is null"
 69+      Just obj -> do
 70+        put $ s { heap = heap // [(p, Just $ obj { fields = fields obj // [(i, ptr)] })]  }
 71+
 72+data Object = Object {
 73+  val :: Value,
 74+  forwardAddress :: Maybe Int,
 75+  fields :: Array Int ObjectPtr
 76+} deriving (Eq, Show)
 77+
 78+data GCState = GCState {
 79+  roots :: Array Int ObjectPtr,
 80+  heap :: Heap,
 81+  bitmap :: Bitmap 
 82+} deriving (Eq,Show)
 83+
 84+type Heap = Array Int (Maybe Object)
 85+type Bitmap = Array Int Bool
 86+
 87+emptyBM :: Bitmap
 88+emptyBM = array (1, 8) [(i, False) | i <- [1..8]]
 89+
 90+initState :: GCState
 91+initState = GCState
 92+  { roots = array (1, 8) [(i, NullPtr) | i <- [1..8]]
 93+  , heap = array (1, 8) [(i, Nothing) | i <- [1..8]]
 94+  , bitmap = emptyBM
 95+  }
 96+
 97+newtype GcM a = GcM { unGcM :: StateT GCState Identity a }
 98+  deriving (Functor, Applicative, Monad, MonadState GCState)
 99+
100+isMarked :: ObjectPtr -> Bitmap -> Bool
101+isMarked NullPtr _ = False
102+isMarked (ObjectPtr p) bm = bm ! p
103+
104+setMarked :: ObjectPtr -> Bitmap -> Bitmap
105+setMarked NullPtr h = h
106+setMarked (ObjectPtr p) bm = bm // [(p, True) ]
107+
108+allocate :: Value -> GcM (Either String ObjectPtr) 
109+allocate v = do
110+  s@GCState{heap} <- get
111+  case findIndexWithNothing heap of
112+    Just p -> do
113+      put $ s { heap = heap // [(p, Just $ Object v Nothing (array (1,8) [(i, NullPtr) | i <- [1..8]]))] }
114+      pure $ Right $ ObjectPtr p
115+    Nothing -> pure $ Left "Out of memory"
116+  where
117+      findIndexWithNothing h = ((+)1) <$> (elemIndex Nothing $ map snd $ sortBy (flip compare `on` Down . fst) $ assocs h)
118+
119+mark :: [ObjectPtr] -> Heap -> Bitmap -> Bitmap
120+mark [] _ bm = bm
121+mark (ptr:rest) h bm
122+  | (ObjectPtr p) <- ptr
123+  , Just obj <- h ! p
124+  =
125+    let
126+      step acc NullPtr = acc
127+      step (wl, bm') child
128+        | not (isMarked child bm') = (child : wl, setMarked child bm')
129+      step acc _ = acc
130+      
131+      (workList, newBm) = foldl step ([], bm) $ fields obj
132+    in mark (workList ++ rest) h newBm
133+  | otherwise = mark rest h bm
134+
135+markFromRoots :: GcM ()
136+markFromRoots = do
137+  GCState{..} <- get
138+  let newBm = foldl (step heap) bitmap roots
139+  put $ GCState roots heap newBm
140+  where
141+    step heap bm ptr
142+      | ptr /= NullPtr && not (isMarked ptr bm) =
143+        let newBm = setMarked ptr bm
144+        in mark [ptr] heap newBm
145+    step _ bm _ = bm
146+
147+collect :: GcM ()
148+collect = do
149+  markFromRoots
150+  compact
151+
152+compact :: GcM ()
153+compact = do
154+  computeLocations 1 8 1
155+  updateReferences 1 8
156+  relocate 1 8
157+
158+computeLocations :: Int -> Int -> Int -> GcM ()
159+computeLocations start end toRegion = go start toRegion end
160+  where
161+    go :: Int -> Int -> Int -> GcM ()
162+    go scan free end 
163+      | scan < end = do
164+        s@GCState{..} <- get
165+        newFree <- if isMarked (ObjectPtr scan) bitmap then do
166+          put $ s { heap = heap // [ (scan, (\o -> o { forwardAddress = Just free } ) <$> (heap ! scan) ) ] }
167+          pure (free + 1) 
168+        else pure free 
169+        go (scan + 1) newFree end
170+      | otherwise = pure ()
171+
172+move :: Int -> Int -> Heap -> Heap
173+move from to h =
174+  let obj = h ! from
175+  in h // [ (to, obj) ]
176+
177+-- slotSize == 1
178+relocate :: Int -> Int -> GcM ()
179+relocate start end = go start end
180+  where
181+    go :: Int -> Int -> GcM () 
182+    go scan end
183+      | scan < end = do
184+        s@GCState{..} <- get
185+        if isMarked (ObjectPtr scan) bitmap then do
186+          case forwardAddress <$> (heap ! scan) of
187+            Just (Just dest) -> do
188+              put $ s { heap = move scan dest heap, bitmap = bitmap // [(dest, False)] }
189+            Nothing -> pure ()
190+        else pure ()
191+        go (scan + 1) end
192+      | otherwise = pure ()
193+
194+-- slotSize == 1
195+updateReferences :: Int -> Int -> GcM ()
196+updateReferences start end = do
197+  s@GCState{heap, roots} <- get
198+
199+  let
200+    step NullPtr = NullPtr
201+    step ptr@(ObjectPtr p) =
202+      let newPtr = forwardAddress <$> (heap ! p)
203+      in case newPtr of
204+        Just (Just newPtr') -> ObjectPtr newPtr'
205+        _ -> ptr
206+
207+  let
208+    updateStep (scan, res) item
209+      | scan < end, Just obj <- item = (scan + 1, (scan, Just $ obj { fields = fmap step $ fields obj }) : res)
210+      | otherwise = (scan + 1, res)
211+
212+  put $ s { roots = fmap step roots, heap = heap // (snd $ foldl updateStep (start, []) heap) }
213+
214+main :: IO ()
215+main = do
216+  let
217+    res = flip runState initState $ unGcM $ do
218+        ptr <- new (IntVal 1)
219+
220+        writeToRoots 1 ptr 
221+
222+        ptr2 <- new (IntVal 2) 
223+        ptr3 <- new (IntVal 3) 
224+        ptr4 <- new (IntVal 4) 
225+        ptr5 <- new (IntVal 5) 
226+        ptr6 <- new (IntVal 6) 
227+        ptr7 <- new (IntVal 7) 
228+        ptr8 <- new (IntVal 8) 
229+
230+        writeToRoots 5 ptr6
231+
232+        collect
233+
234+--        ptr2' <- new (IntVal 2)
235+ --       writeToRoots 2 ptr2'
236+  --      collect
237+        
238+        return [ptr, ptr2]
239+  putStrLn $ "RESULT:" ++ (show $ snd res)