repos / gcs.git

commit

2d5d6bb

parent

62230c5

author

Evgenii Akentev

date

2024-09-14 23:05:51 +0400 +04

Refactor marksweep a bit

 1@@ -1 +1,25 @@
 2 a.out
 3+
 4+dist
 5+dist-*
 6+cabal-dev
 7+*.o
 8+*.hi
 9+*.hie
10+*.chi
11+*.chs.h
12+*.dyn_o
13+*.dyn_hi
14+.hpc
15+.hsenv
16+.cabal-sandbox/
17+cabal.sandbox.config
18+*.prof
19+*.aux
20+*.hp
21+*.eventlog
22+.stack-work/
23+cabal.project.local
24+cabal.project.local~
25+.HTF/
26+.ghc.environment.*

 1@@ -0,0 +1,29 @@
 2+Copyright (c) 2024, Evgenii Akentev
 3+
 4+
 5+Redistribution and use in source and binary forms, with or without
 6+modification, are permitted provided that the following conditions are met:
 7+
 8+    * Redistributions of source code must retain the above copyright
 9+      notice, this list of conditions and the following disclaimer.
10+
11+    * Redistributions in binary form must reproduce the above
12+      copyright notice, this list of conditions and the following
13+      disclaimer in the documentation and/or other materials provided
14+      with the distribution.
15+
16+    * Neither the name of the copyright holder nor the names of its
17+      contributors may be used to endorse or promote products derived
18+      from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

 1@@ -0,0 +1,25 @@
 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+    -- other-modules:
23+    -- other-extensions:
24+    build-depends:    base ^>=4.18.2.1, mtl
25+    hs-source-dirs:   src
26+    default-language: Haskell2010

  1@@ -1,116 +0,0 @@
  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

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

 1@@ -0,0 +1,22 @@
 2+{-# language MultiParamTypeClasses #-}
 3+
 4+module Mutator where
 5+
 6+data Value = IntVal Int | PtrVal ObjectPtr
 7+  deriving (Eq, Show)
 8+
 9+data ObjectPtr = ObjectPtr Int | NullPtr
10+  deriving (Eq, Show)
11+
12+class Monad m => Mutator m where
13+  new :: Value -> m ObjectPtr
14+
15+  readFromRoots :: Int -> m ObjectPtr
16+  readFromObject :: ObjectPtr -> m Value
17+  readFromField :: Int -> ObjectPtr -> m ObjectPtr 
18+
19+  writeToRoots :: Int -> ObjectPtr -> m ()
20+  writeToObject :: Value -> ObjectPtr -> m ()
21+  writeToField :: Int -> ObjectPtr -> ObjectPtr -> m ()
22+
23+