From: Evgenii Akentev <hi@ak3n.com>
Date: Wed, 18 Sep 2024 06:22:30 +0000 (+0400)
Subject: Add MarkCompact.Lisp2
X-Git-Url: https://git.ak3n.com/?a=commitdiff_plain;p=gcs.git

Add MarkCompact.Lisp2
---

diff --git a/gcs.cabal b/gcs.cabal
index 19d44b3..4626cef 100644
--- a/gcs.cabal
+++ b/gcs.cabal
@@ -14,7 +14,7 @@ common warnings
 library
     import:           warnings
     exposed-modules:  MarkSweep.Basic, MarkSweep.Bitmap
-                    , MarkCompact.TwoFinger
+                    , MarkCompact.TwoFinger, MarkCompact.Lisp2
                     , Mutator
     build-depends:    base ^>=4.18.2.1, mtl, array
     hs-source-dirs:   src
diff --git a/src/MarkCompact/Lisp2.hs b/src/MarkCompact/Lisp2.hs
new file mode 100644
index 0000000..498481e
--- /dev/null
+++ b/src/MarkCompact/Lisp2.hs
@@ -0,0 +1,238 @@
+{-# language ImportQualifiedPost, InstanceSigs, DuplicateRecordFields
+ , LambdaCase, RecordWildCards, NamedFieldPuns, TypeSynonymInstances
+ , DerivingStrategies, GeneralizedNewtypeDeriving #-}
+
+module MarkCompact.Lisp2 where
+
+import Debug.Trace 
+import Data.Ord (Down(..))
+import Data.List
+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 = ((+)1) <$> (elemIndex Nothing $ map snd $ sortBy (flip compare `on` Down . fst) $ assocs h)
+
+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
+  computeLocations 1 8 1
+  updateReferences 1 8
+  relocate 1 8
+
+computeLocations :: Int -> Int -> Int -> GcM ()
+computeLocations start end toRegion = go start toRegion end
+  where
+    go :: Int -> Int -> Int -> GcM ()
+    go scan free end 
+      | scan < end = do
+        s@GCState{..} <- get
+        newFree <- if isMarked (ObjectPtr scan) bitmap then do
+          put $ s { heap = heap // [ (scan, (\o -> o { forwardAddress = Just free } ) <$> (heap ! scan) ) ] }
+          pure (free + 1) 
+        else pure free 
+        go (scan + 1) newFree end
+      | otherwise = pure ()
+
+move :: Int -> Int -> Heap -> Heap
+move from to h =
+  let obj = h ! from
+  in h // [ (to, obj) ]
+
+-- slotSize == 1
+relocate :: Int -> Int -> GcM ()
+relocate start end = go start end
+  where
+    go :: Int -> Int -> GcM () 
+    go scan end
+      | scan < end = do
+        s@GCState{..} <- get
+        if isMarked (ObjectPtr scan) bitmap then do
+          case forwardAddress <$> (heap ! scan) of
+            Just (Just dest) -> do
+              put $ s { heap = move scan dest heap, bitmap = bitmap // [(dest, False)] }
+            Nothing -> pure ()
+        else pure ()
+        go (scan + 1) end
+      | otherwise = pure ()
+
+-- 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') -> ObjectPtr newPtr'
+        _ -> ptr
+
+  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 { roots = fmap step roots, heap = heap // (snd $ foldl updateStep (start, []) heap) }
+
+main :: IO ()
+main = do
+  let
+    res = flip runState initState $ unGcM $ do
+        ptr <- new (IntVal 1)
+
+        writeToRoots 1 ptr 
+
+        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 5 ptr6
+
+        collect
+
+--        ptr2' <- new (IntVal 2)
+ --       writeToRoots 2 ptr2'
+  --      collect
+        
+        return [ptr, ptr2]
+  putStrLn $ "RESULT:" ++ (show $ snd res)