From: Evgenii Akentev <hi@ak3n.com>
Date: Sat, 14 Sep 2024 19:05:51 +0000 (+0400)
Subject: Refactor marksweep a bit
X-Git-Url: https://git.ak3n.com/?a=commitdiff_plain;h=2d5d6bb38430cab79ab873e21ebba22a9f65b3d5;p=gcs.git

Refactor marksweep a bit
---

diff --git a/.gitignore b/.gitignore
index cba7efc..c576973 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1 +1,25 @@
 a.out
+
+dist
+dist-*
+cabal-dev
+*.o
+*.hi
+*.hie
+*.chi
+*.chs.h
+*.dyn_o
+*.dyn_hi
+.hpc
+.hsenv
+.cabal-sandbox/
+cabal.sandbox.config
+*.prof
+*.aux
+*.hp
+*.eventlog
+.stack-work/
+cabal.project.local
+cabal.project.local~
+.HTF/
+.ghc.environment.*
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..e20cce1
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,29 @@
+Copyright (c) 2024, Evgenii Akentev
+
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of the copyright holder nor the names of its
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/gcs.cabal b/gcs.cabal
new file mode 100644
index 0000000..a5c3a1a
--- /dev/null
+++ b/gcs.cabal
@@ -0,0 +1,25 @@
+cabal-version:      3.0
+name:               gcs
+version:            0.1.0.0
+-- synopsis:
+-- description:
+license:            BSD-3-Clause
+license-file:       LICENSE
+author:             Evgenii Akentev
+maintainer:         hi@ak3n.com
+-- copyright:
+build-type:         Simple
+extra-doc-files:    CHANGELOG.md
+-- extra-source-files:
+
+common warnings
+    ghc-options: -Wall
+
+library
+    import:           warnings
+    exposed-modules:  MarkSweep.Basic, Mutator
+    -- other-modules:
+    -- other-extensions:
+    build-depends:    base ^>=4.18.2.1, mtl
+    hs-source-dirs:   src
+    default-language: Haskell2010
diff --git a/mark-sweep/MarkSweep.hs b/mark-sweep/MarkSweep.hs
deleted file mode 100644
index 0bb07f0..0000000
--- a/mark-sweep/MarkSweep.hs
+++ /dev/null
@@ -1,116 +0,0 @@
-module MarkSweep where
-
-import Debug.Trace
-
--- run as ghci MarkSweep.hs -package unordered-containers
-
-data Value = IntVal Int
-  deriving (Eq, Show)
-
-data Object = Object {
-  val :: Value,
-  fields :: [ObjectPtr],
-  marked :: Bool
-} deriving (Eq, Show)
-
-data ObjectPtr = ObjectPtr Int | NullPtr
-  deriving (Eq, Show)
-
-increment :: ObjectPtr -> ObjectPtr
-increment (ObjectPtr p) = ObjectPtr $ p + 1
-increment NullPtr = NullPtr
-
-newtype Heap = Heap { heapObjects :: [Maybe Object] }
-  deriving (Eq, Show)
-
-newHeap :: Heap
-newHeap = Heap [Nothing | x <- [1..8]]
-
-isMarked :: ObjectPtr -> Heap -> Bool
-isMarked NullPtr _ = False
-isMarked (ObjectPtr p) h = Just True == (marked <$> (heapObjects h !! p))
-
-setMarked :: ObjectPtr -> Heap -> Heap
-setMarked NullPtr h = h
-setMarked (ObjectPtr p) (Heap hs) = Heap $ reverse $ foldl step [] $ zip [0..] hs
-  where
-    step res (idx, Nothing) = Nothing : res
-    step res (idx, Just obj)
-      | p == idx = (Just $ obj { marked = True }) : res
-      | otherwise = (Just obj) : res
-
-newtype Roots = Roots { rootsObjects :: [ObjectPtr]}
-  deriving (Eq, Show)
-
-data MarkSweepGC = MarkSweepGC {
-  roots :: Roots,
-  heap :: Heap
-} deriving (Eq, Show)
-
-allocate :: Value -> Heap -> Either String (ObjectPtr, Heap) 
-allocate v (Heap objs) = case foldl step (False, -1, []) objs of
-  (True, idx, res) -> Right $ (ObjectPtr idx, Heap $ reverse res)
-  _ -> Left "Out of memory"
-  where
-    step (True, idx, res) obj = (True, idx, obj : res)
-    step (_, idx, res) Nothing = (True, idx + 1, (Just $ Object v [] False) : res) 
-    step (ok, idx, res) obj = (ok, idx + 1, obj : res)
-
-mark :: [ObjectPtr] -> Heap -> Heap
-mark [] h = h
-mark ((ObjectPtr p):rest) h = case heapObjects h !! p of
-  Just obj ->
-    let
-      step acc NullPtr = acc
-      step (wl, heap) child
-        | not (isMarked child h) = (child : wl, setMarked child heap)
-      step acc _ = acc
-      
-      (workList, newH) = foldl step ([], h) $ fields obj
-    in mark (workList ++ rest) newH
-  Nothing -> mark rest h
-
-markFromRoots :: Heap -> Roots -> (Heap, Roots)
-markFromRoots h rs =
-  let newHeap = foldl step h $ rootsObjects rs
-  in (newHeap, rs)
-  where
-    step heap ptr
-      | not (isMarked ptr heap) =
-        let newH = setMarked ptr heap
-        in mark [ptr] newH
-    step heap ptr = heap
-
-collect :: Heap -> Roots -> (Heap, Roots)
-collect h r =
-  let (h', r') = markFromRoots h r
-  in (sweep h', r')
-
-sweep :: Heap -> Heap
-sweep (Heap hs) = Heap $ map step hs
-  where
-    step Nothing = Nothing
-    step (Just o) = if marked o then Just (o { marked = False }) else Nothing
-
-newObject :: Value -> MarkSweepGC -> Either String (ObjectPtr, MarkSweepGC)
-newObject v (MarkSweepGC roots heap) =
-  case allocate v heap of 
-    Right (ptr, heap') -> Right (ptr, MarkSweepGC roots heap') 
-    Left s ->
-      let (heap', roots') = collect heap roots
-      in case allocate v heap' of
-        Right (ptr, heap'') -> Right (ptr, MarkSweepGC roots' heap'')
-        Left s -> Left s
-
-main :: IO ()
-main = do
-  let gc = MarkSweepGC (Roots []) newHeap 
-  let
-    res = do
-        (ptr, gc') <- newObject (IntVal 3) gc
-        (ptr2, MarkSweepGC (Roots roots) h) <- newObject (IntVal 5) gc'
-
-        let (r'', h'') = collect h (Roots $ ptr2 : roots)
-        let newGc = MarkSweepGC h'' r''
-        return ([ptr, ptr2], newGc)
-  print res
diff --git a/mark-sweep/basic.c b/mark_sweep.c
similarity index 100%
rename from mark-sweep/basic.c
rename to mark_sweep.c
diff --git a/src/MarkSweep/Basic.hs b/src/MarkSweep/Basic.hs
new file mode 100644
index 0000000..a608a36
--- /dev/null
+++ b/src/MarkSweep/Basic.hs
@@ -0,0 +1,162 @@
+{-# language ImportQualifiedPost, InstanceSigs, DuplicateRecordFields
+ , LambdaCase, RecordWildCards, NamedFieldPuns, TypeSynonymInstances
+ , DerivingStrategies, GeneralizedNewtypeDeriving #-}
+
+module MarkSweep.Basic where
+
+import Control.Monad.State
+import Control.Monad.Identity
+import Mutator 
+
+instance Mutator GcM where
+  new :: Value -> GcM ObjectPtr
+  new v = do
+    allocate v >>= \case
+      Right ptr -> pure ptr 
+      _ -> do
+        collect
+        allocate v >>= \case
+          Right ptr -> pure ptr
+          Left s -> error s
+
+  readFromRoots :: Int -> GcM ObjectPtr
+  readFromRoots i = do
+    GCState{roots} <- get
+    return $ roots !! i
+ 
+  readFromObject :: ObjectPtr -> GcM Value
+  readFromObject (ObjectPtr i) = do
+   GCState{heap} <- get
+   case heap !! i of
+    Just o -> pure $ val o
+    Nothing -> error "Incorrect pointer"
+
+  readFromField :: Int -> ObjectPtr -> GcM ObjectPtr
+  readFromField f (ObjectPtr i) = do
+   GCState{heap} <- get
+   case heap !! i of
+    Just o -> pure $ (fields o) !! f
+    Nothing -> error "Incorrect pointer"
+
+  writeToRoots :: Int -> ObjectPtr -> GcM ()
+  writeToRoots i ptr = do
+    s@GCState{roots} <- get
+    case splitAt i roots of
+      ([], []) -> put $ s { roots = [ptr] } 
+      (before, _:after) -> put $ s { roots = before ++ [ptr] ++ after  }
+
+  writeToObject :: Value -> ObjectPtr -> GcM ()
+  writeToObject v (ObjectPtr i) = do
+   s@GCState{heap} <- get
+   let (before, o:after) = splitAt i heap 
+   case o of
+    Nothing -> error "Object is null"
+    Just obj ->
+     put $ s { heap = before ++ [Just $ obj { val = v } ] ++ after  }
+
+  writeToField :: Int -> ObjectPtr -> ObjectPtr -> GcM ()
+  writeToField i ptr (ObjectPtr p) = do
+    s@GCState{heap} <- get
+    let (before, o:after) = splitAt p heap
+    case o of
+      Nothing -> error "Object is null"
+      Just obj -> do
+        let (fBefore, _:fAfter) = splitAt i $ fields obj
+        put $ s { heap = (before ++ [Just $ obj { fields = fBefore ++ [ptr] ++ fAfter } ] ++ after)  }
+
+data Object = Object {
+  val :: Value,
+  fields :: [ObjectPtr],
+  marked :: Bool
+} deriving (Eq, Show)
+
+data GCState = GCState {
+  roots :: [ObjectPtr],
+  heap :: Heap
+} deriving (Eq,Show)
+
+type Heap = [Maybe Object]
+
+initState :: GCState
+initState = GCState [] [Nothing  | _ <- [1 :: Int ..8]]
+
+newtype GcM a = GcM { unGcM :: StateT GCState Identity a }
+  deriving (Functor, Applicative, Monad, MonadState GCState)
+
+isMarked :: ObjectPtr -> Heap -> Bool
+isMarked NullPtr _ = False
+isMarked (ObjectPtr p) h = Just True == (marked <$> (h !! p))
+
+setMarked :: ObjectPtr -> Heap -> Heap
+setMarked NullPtr h = h
+setMarked (ObjectPtr p) hs = reverse $ foldl step [] $ zip [0..] hs
+  where
+    step res (_, Nothing) = Nothing : res
+    step res (idx, Just obj)
+      | p == idx = (Just $ obj { marked = True }) : res
+      | otherwise = (Just obj) : res
+
+allocate :: Value -> GcM (Either String ObjectPtr) 
+allocate v = do
+  s@GCState{heap} <- get
+  case foldl step (False, -1, []) heap of
+    (True, idx, res) -> do
+      put $ s { heap = reverse res} 
+      pure $ Right $ ObjectPtr idx
+    _ -> pure $ Left "Out of memory"
+    where
+      step (True, idx, res) obj = (True, idx, obj : res)
+      step (_, idx, res) Nothing = (True, idx + 1, (Just $ Object v [] False) : res) 
+      step (ok, idx, res) obj = (ok, idx + 1, obj : res)
+
+mark :: [ObjectPtr] -> Heap -> Heap
+mark [] h = h
+mark ((ObjectPtr p):rest) h = case h !! p of
+  Just obj ->
+    let
+      step acc NullPtr = acc
+      step (wl, heap) child
+        | not (isMarked child h) = (child : wl, setMarked child heap)
+      step acc _ = acc
+      
+      (workList, newH) = foldl step ([], h) $ fields obj
+    in mark (workList ++ rest) newH
+  Nothing -> mark rest h
+
+markFromRoots :: GcM ()
+markFromRoots = do
+  GCState{..} <- get
+  let newHeap = foldl step heap roots
+  put $ GCState roots newHeap
+  where
+    step heap ptr
+      | not (isMarked ptr heap) =
+        let newH = setMarked ptr heap
+        in mark [ptr] newH
+    step heap _ = heap
+
+collect :: GcM ()
+collect = do
+  markFromRoots
+  sweep
+
+sweep :: GcM ()
+sweep = do
+  s@GCState{heap} <- get
+  put $ s { heap = map step heap }
+  where
+    step Nothing = Nothing
+    step (Just o) = if marked o then Just (o { marked = False }) else Nothing
+
+main :: IO ()
+main = do
+  let
+    res = flip runState initState $ unGcM $ do
+        ptr <- new (IntVal 3)
+        ptr2 <- new (IntVal 5) 
+
+        writeToRoots 0 ptr 
+
+        collect
+        return [ptr, ptr2]
+  print res
diff --git a/src/Mutator.hs b/src/Mutator.hs
new file mode 100644
index 0000000..ad0bdb0
--- /dev/null
+++ b/src/Mutator.hs
@@ -0,0 +1,22 @@
+{-# language MultiParamTypeClasses #-}
+
+module Mutator where
+
+data Value = IntVal Int | PtrVal ObjectPtr
+  deriving (Eq, Show)
+
+data ObjectPtr = ObjectPtr Int | NullPtr
+  deriving (Eq, Show)
+
+class Monad m => Mutator m where
+  new :: Value -> m ObjectPtr
+
+  readFromRoots :: Int -> m ObjectPtr
+  readFromObject :: ObjectPtr -> m Value
+  readFromField :: Int -> ObjectPtr -> m ObjectPtr 
+
+  writeToRoots :: Int -> ObjectPtr -> m ()
+  writeToObject :: Value -> ObjectPtr -> m ()
+  writeToField :: Int -> ObjectPtr -> ObjectPtr -> m ()
+
+