repos / gcs.git

commit

62230c5

parent

60f2e3f

author

Evgenii Akentev

date

2024-09-12 16:42:26 +0400 +04

Add mark sweep in hs

  1@@ -0,0 +1,116 @@
  2+module MarkSweep where
  3+
  4+import Debug.Trace
  5+
  6+-- run as ghci MarkSweep.hs -package unordered-containers
  7+
  8+data Value = IntVal Int
  9+  deriving (Eq, Show)
 10+
 11+data Object = Object {
 12+  val :: Value,
 13+  fields :: [ObjectPtr],
 14+  marked :: Bool
 15+} deriving (Eq, Show)
 16+
 17+data ObjectPtr = ObjectPtr Int | NullPtr
 18+  deriving (Eq, Show)
 19+
 20+increment :: ObjectPtr -> ObjectPtr
 21+increment (ObjectPtr p) = ObjectPtr $ p + 1
 22+increment NullPtr = NullPtr
 23+
 24+newtype Heap = Heap { heapObjects :: [Maybe Object] }
 25+  deriving (Eq, Show)
 26+
 27+newHeap :: Heap
 28+newHeap = Heap [Nothing | x <- [1..8]]
 29+
 30+isMarked :: ObjectPtr -> Heap -> Bool
 31+isMarked NullPtr _ = False
 32+isMarked (ObjectPtr p) h = Just True == (marked <$> (heapObjects h !! p))
 33+
 34+setMarked :: ObjectPtr -> Heap -> Heap
 35+setMarked NullPtr h = h
 36+setMarked (ObjectPtr p) (Heap hs) = Heap $ reverse $ foldl step [] $ zip [0..] hs
 37+  where
 38+    step res (idx, Nothing) = Nothing : res
 39+    step res (idx, Just obj)
 40+      | p == idx = (Just $ obj { marked = True }) : res
 41+      | otherwise = (Just obj) : res
 42+
 43+newtype Roots = Roots { rootsObjects :: [ObjectPtr]}
 44+  deriving (Eq, Show)
 45+
 46+data MarkSweepGC = MarkSweepGC {
 47+  roots :: Roots,
 48+  heap :: Heap
 49+} deriving (Eq, Show)
 50+
 51+allocate :: Value -> Heap -> Either String (ObjectPtr, Heap) 
 52+allocate v (Heap objs) = case foldl step (False, -1, []) objs of
 53+  (True, idx, res) -> Right $ (ObjectPtr idx, Heap $ reverse res)
 54+  _ -> Left "Out of memory"
 55+  where
 56+    step (True, idx, res) obj = (True, idx, obj : res)
 57+    step (_, idx, res) Nothing = (True, idx + 1, (Just $ Object v [] False) : res) 
 58+    step (ok, idx, res) obj = (ok, idx + 1, obj : res)
 59+
 60+mark :: [ObjectPtr] -> Heap -> Heap
 61+mark [] h = h
 62+mark ((ObjectPtr p):rest) h = case heapObjects h !! p of
 63+  Just obj ->
 64+    let
 65+      step acc NullPtr = acc
 66+      step (wl, heap) child
 67+        | not (isMarked child h) = (child : wl, setMarked child heap)
 68+      step acc _ = acc
 69+      
 70+      (workList, newH) = foldl step ([], h) $ fields obj
 71+    in mark (workList ++ rest) newH
 72+  Nothing -> mark rest h
 73+
 74+markFromRoots :: Heap -> Roots -> (Heap, Roots)
 75+markFromRoots h rs =
 76+  let newHeap = foldl step h $ rootsObjects rs
 77+  in (newHeap, rs)
 78+  where
 79+    step heap ptr
 80+      | not (isMarked ptr heap) =
 81+        let newH = setMarked ptr heap
 82+        in mark [ptr] newH
 83+    step heap ptr = heap
 84+
 85+collect :: Heap -> Roots -> (Heap, Roots)
 86+collect h r =
 87+  let (h', r') = markFromRoots h r
 88+  in (sweep h', r')
 89+
 90+sweep :: Heap -> Heap
 91+sweep (Heap hs) = Heap $ map step hs
 92+  where
 93+    step Nothing = Nothing
 94+    step (Just o) = if marked o then Just (o { marked = False }) else Nothing
 95+
 96+newObject :: Value -> MarkSweepGC -> Either String (ObjectPtr, MarkSweepGC)
 97+newObject v (MarkSweepGC roots heap) =
 98+  case allocate v heap of 
 99+    Right (ptr, heap') -> Right (ptr, MarkSweepGC roots heap') 
100+    Left s ->
101+      let (heap', roots') = collect heap roots
102+      in case allocate v heap' of
103+        Right (ptr, heap'') -> Right (ptr, MarkSweepGC roots' heap'')
104+        Left s -> Left s
105+
106+main :: IO ()
107+main = do
108+  let gc = MarkSweepGC (Roots []) newHeap 
109+  let
110+    res = do
111+        (ptr, gc') <- newObject (IntVal 3) gc
112+        (ptr2, MarkSweepGC (Roots roots) h) <- newObject (IntVal 5) gc'
113+
114+        let (r'', h'') = collect h (Roots $ ptr2 : roots)
115+        let newGc = MarkSweepGC h'' r''
116+        return ([ptr, ptr2], newGc)
117+  print res