From: Evgenii Akentev <hi@ak3n.com>
Date: Tue, 17 Sep 2024 15:19:08 +0000 (+0400)
Subject: Add MarkCompact.TwoFinger
X-Git-Url: https://git.ak3n.com/?a=commitdiff_plain;h=0cf561fe462233144bfec93c11c3564340e46844;p=gcs.git

Add MarkCompact.TwoFinger
---

diff --git a/gcs.cabal b/gcs.cabal
index dfa9fc4..19d44b3 100644
--- a/gcs.cabal
+++ b/gcs.cabal
@@ -13,7 +13,9 @@ common warnings
 
 library
     import:           warnings
-    exposed-modules:  MarkSweep.Basic, MarkSweep.Bitmap, Mutator
+    exposed-modules:  MarkSweep.Basic, MarkSweep.Bitmap
+                    , MarkCompact.TwoFinger
+                    , Mutator
     build-depends:    base ^>=4.18.2.1, mtl, array
     hs-source-dirs:   src
     default-language: Haskell2010
diff --git a/src/MarkCompact/TwoFinger.hs b/src/MarkCompact/TwoFinger.hs
new file mode 100644
index 0000000..50f4204
--- /dev/null
+++ b/src/MarkCompact/TwoFinger.hs
@@ -0,0 +1,234 @@
+{-# language ImportQualifiedPost, InstanceSigs, DuplicateRecordFields
+ , LambdaCase, RecordWildCards, NamedFieldPuns, TypeSynonymInstances
+ , DerivingStrategies, GeneralizedNewtypeDeriving #-}
+
+module MarkCompact.TwoFinger where
+
+import Data.List (sortBy)
+import Data.Function (on)
+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,
+  forwardAddress :: Maybe Int,
+  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 Nothing (array (1,8) [(i, NullPtr) | i <- [1..8]]))] }
+      pure $ Right $ ObjectPtr p
+    Nothing -> pure $ Left "Out of memory"
+  where
+      findIndexWithNothing h = foldl step Nothing $ sortBy (flip compare `on` fst) $ 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
+  compact
+
+compact :: GcM ()
+compact = do
+  free <- relocate 1 8
+  updateReferences 1 free
+
+move :: Int -> Int -> GcM ()
+move from to = do
+  s@GCState{heap} <- get
+  let obj = heap ! from
+  put $ s { heap = heap // [ (to, obj), (from, Nothing) ] }
+
+-- slotSize == 1
+relocate :: Int -> Int -> GcM Int
+relocate start end = go start end
+  where
+    go :: Int -> Int -> GcM Int 
+    go free scan
+      | free < scan = do
+        gc <- get
+        let bm = bitmap gc
+        let indicesToUnmark = fmap fst $ takeWhile (\(_, marked) -> marked) $ assocs bm 
+            free' = if indicesToUnmark == [] then free else maximum indicesToUnmark
+            bm' = bm // [(i, False) | i <- indicesToUnmark] 
+        put $ gc { bitmap = bm' }
+
+        let
+          findIndexStep marked (ok, idx)
+            | not marked && idx > free' = (ok, idx - 1)
+            | otherwise = (True, idx) 
+          scan' = snd $ foldr findIndexStep (False, scan) bm
+    
+        if scan' > free' then do
+          put $ gc { bitmap = bm' // [(scan', False)]}
+
+          move scan' free'
+
+          let obj = (heap gc) ! scan'
+          put $ gc { heap = heap gc // [ (scan', (\o -> o { forwardAddress = Just free' } ) <$> obj ) ] }
+
+          go (free' + 1) (scan' - 1)
+        else go free' scan'
+      | otherwise = pure free
+
+-- slotSize == 1
+updateReferences :: Int -> Int -> GcM ()
+updateReferences start end = do
+  s@GCState{heap, roots} <- get
+
+  let
+    step NullPtr = NullPtr
+    step ptr@(ObjectPtr p) =
+      let newPtr = forwardAddress <$> heap ! p
+      in case newPtr of
+        Just (Just newPtr') | p >= end -> ObjectPtr newPtr'
+        _ -> ptr
+  put $ s { roots = fmap step roots }
+
+  let
+    updateStep (scan, res) item
+      | scan < end, Just obj <- item = (scan + 1, (scan, Just $ obj { fields = fmap step $ fields obj }) : res)
+      | otherwise = (scan + 1, res)
+
+  put $ s { heap = heap // (snd $ foldl updateStep (start, []) heap) }
+
+main :: IO ()
+main = do
+  let
+    res = flip runState initState $ unGcM $ do
+        ptr <- new (IntVal 1)
+        ptr2 <- new (IntVal 2) 
+        ptr3 <- new (IntVal 3) 
+        ptr4 <- new (IntVal 4) 
+        ptr5 <- new (IntVal 5) 
+        ptr6 <- new (IntVal 6) 
+        ptr7 <- new (IntVal 7) 
+        ptr8 <- new (IntVal 8) 
+
+        writeToRoots 1 ptr 
+
+        collect
+
+
+        return [ptr, ptr2]
+  print res
diff --git a/src/MarkSweep/Bitmap.hs b/src/MarkSweep/Bitmap.hs
index 3a56037..e37151b 100644
--- a/src/MarkSweep/Bitmap.hs
+++ b/src/MarkSweep/Bitmap.hs
@@ -5,6 +5,8 @@
 module MarkSweep.Bitmap where
 
 
+import Data.List
+import Data.Function (on)
 import Data.Array
 import Control.Monad.State
 import Control.Monad.Identity
@@ -109,7 +111,7 @@ allocate v = do
       pure $ Right $ ObjectPtr p
     Nothing -> pure $ Left "Out of memory"
   where
-      findIndexWithNothing h = foldl step Nothing $ assocs h
+      findIndexWithNothing h = foldl step Nothing $ sortBy (flip compare `on` fst) $ assocs h
       step _ (i, Nothing) = Just i
       step acc _ = acc