From 82d8d96c221c1f590f35cb8a9b61f4102ec75107 Mon Sep 17 00:00:00 2001
From: Evgenii Akentev <hi@ak3n.com>
Date: Mon, 16 Sep 2024 19:24:55 +0400
Subject: [PATCH] Add MarkSweep.Bitmap

---
 gcs.cabal               |   6 +-
 src/MarkSweep/Bitmap.hs | 171 ++++++++++++++++++++++++++++++++++++++++
 2 files changed, 172 insertions(+), 5 deletions(-)
 create mode 100644 src/MarkSweep/Bitmap.hs

diff --git a/gcs.cabal b/gcs.cabal
index e594ef4..dfa9fc4 100644
--- a/gcs.cabal
+++ b/gcs.cabal
@@ -1,23 +1,19 @@
 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
+    exposed-modules:  MarkSweep.Basic, MarkSweep.Bitmap, Mutator
     build-depends:    base ^>=4.18.2.1, mtl, array
     hs-source-dirs:   src
     default-language: Haskell2010
diff --git a/src/MarkSweep/Bitmap.hs b/src/MarkSweep/Bitmap.hs
new file mode 100644
index 0000000..3a56037
--- /dev/null
+++ b/src/MarkSweep/Bitmap.hs
@@ -0,0 +1,171 @@
+{-# language ImportQualifiedPost, InstanceSigs, DuplicateRecordFields
+ , LambdaCase, RecordWildCards, NamedFieldPuns, TypeSynonymInstances
+ , DerivingStrategies, GeneralizedNewtypeDeriving #-}
+
+module MarkSweep.Bitmap where
+
+
+import Data.Array
+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 NullPtr = error "Null pointer"
+  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 _ NullPtr = error "Null pointer"
+  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
+    put $ s { roots = roots // [(i, ptr)] }
+
+  writeToObject :: Value -> ObjectPtr -> GcM ()
+  writeToObject _ NullPtr = error "Null pointer"
+  writeToObject v (ObjectPtr i) = do
+   s@GCState{heap} <- get
+   case heap ! i of
+    Nothing -> error "Object is null"
+    Just obj ->
+     put $ s { heap = heap // [(i, Just $ obj { val = v })] }
+
+  writeToField :: Int -> ObjectPtr -> ObjectPtr -> GcM ()
+  writeToField _ _ NullPtr = error "Null pointer"
+  writeToField i ptr (ObjectPtr p) = do
+    s@GCState{heap} <- get
+    case heap ! p of 
+      Nothing -> error "Object is null"
+      Just obj -> do
+        put $ s { heap = heap // [(p, Just $ obj { fields = fields obj // [(i, ptr)] })]  }
+
+data Object = Object {
+  val :: Value,
+  fields :: Array Int ObjectPtr
+} deriving (Eq, Show)
+
+data GCState = GCState {
+  roots :: Array Int ObjectPtr,
+  heap :: Heap,
+  bitmap :: Bitmap 
+} deriving (Eq,Show)
+
+type Heap = Array Int (Maybe Object)
+type Bitmap = Array Int Bool
+
+emptyBM :: Bitmap
+emptyBM = array (1, 8) [(i, False) | i <- [1..8]]
+
+initState :: GCState
+initState = GCState
+  { roots = array (1, 8) [(i, NullPtr) | i <- [1..8]]
+  , heap = array (1, 8) [(i, Nothing) | i <- [1..8]]
+  , bitmap = emptyBM
+  }
+
+newtype GcM a = GcM { unGcM :: StateT GCState Identity a }
+  deriving (Functor, Applicative, Monad, MonadState GCState)
+
+isMarked :: ObjectPtr -> Bitmap -> Bool
+isMarked NullPtr _ = False
+isMarked (ObjectPtr p) bm = bm ! p
+
+setMarked :: ObjectPtr -> Bitmap -> Bitmap
+setMarked NullPtr h = h
+setMarked (ObjectPtr p) bm = bm // [(p, True) ]
+
+allocate :: Value -> GcM (Either String ObjectPtr) 
+allocate v = do
+  s@GCState{heap} <- get
+  case findIndexWithNothing heap of
+    Just p -> do
+      put $ s { heap = heap // [(p, Just $ Object v (array (1,8) [(i, NullPtr) | i <- [1..8]]))] }
+      pure $ Right $ ObjectPtr p
+    Nothing -> pure $ Left "Out of memory"
+  where
+      findIndexWithNothing h = foldl step Nothing $ assocs h
+      step _ (i, Nothing) = Just i
+      step acc _ = acc
+
+mark :: [ObjectPtr] -> Heap -> Bitmap -> Bitmap
+mark [] _ bm = bm
+mark (ptr:rest) h bm
+  | (ObjectPtr p) <- ptr
+  , Just obj <- h ! p
+  =
+    let
+      step acc NullPtr = acc
+      step (wl, bm') child
+        | not (isMarked child bm') = (child : wl, setMarked child bm')
+      step acc _ = acc
+      
+      (workList, newBm) = foldl step ([], bm) $ fields obj
+    in mark (workList ++ rest) h newBm
+  | otherwise = mark rest h bm
+
+markFromRoots :: GcM ()
+markFromRoots = do
+  GCState{..} <- get
+  let newBm = foldl (step heap) bitmap roots
+  put $ GCState roots heap newBm
+  where
+    step heap bm ptr
+      | ptr /= NullPtr && not (isMarked ptr bm) =
+        let newBm = setMarked ptr bm
+        in mark [ptr] heap newBm
+    step _ bm _ = bm
+
+collect :: GcM ()
+collect = do
+  markFromRoots
+  sweep
+
+sweep :: GcM ()
+sweep = do
+  s@GCState{heap, bitmap} <- get
+  put $ s
+    { heap = array (1,8) $ foldl (step bitmap) [] $ assocs heap
+    , bitmap = emptyBM
+    }
+  where
+    step _ acc (i, Nothing) = (i, Nothing) : acc
+    step bm acc (i, Just o) = (i, if isMarked (ObjectPtr i) bm then Just o else Nothing) : acc
+
+main :: IO ()
+main = do
+  let
+    res = flip runState initState $ unGcM $ do
+        ptr <- new (IntVal 3)
+        ptr2 <- new (IntVal 5) 
+
+        writeToRoots 1 ptr 
+
+        collect
+        return [ptr, ptr2]
+  print res
-- 
2.34.1