Use Data.Array

diff --git a/gcs.cabal b/gcs.cabal
index a5c3a1a09f492d22125f3e905520596b780cf72f..e594ef4e37a86ac910a0f39a5ba3d230db7ac080 100644 (file)
--- a/gcs.cabal
+++ b/gcs.cabal
@@ -18,8 +18,6 @@ common warnings
 library
     import:           warnings
     exposed-modules:  MarkSweep.Basic, Mutator
-    -- other-modules:
-    -- other-extensions:
-    build-depends:    base ^>=4.18.2.1, mtl
+    build-depends:    base ^>=4.18.2.1, mtl, array
     hs-source-dirs:   src
     default-language: Haskell2010

diff --git a/src/MarkSweep/Basic.hs b/src/MarkSweep/Basic.hs
index a608a36f91b43638a628e406d5c5deb9575050f3..260345fe42d586d8ab4698029830dbc1f4972c7e 100644 (file)
--- a/src/MarkSweep/Basic.hs
+++ b/src/MarkSweep/Basic.hs
@@ -4,6 +4,8 @@
 
 module MarkSweep.Basic where
 
+
+import Data.Array
 import Control.Monad.State
 import Control.Monad.Identity
 import Mutator 
@@ -22,97 +24,96 @@ instance Mutator GcM where
   readFromRoots :: Int -> GcM ObjectPtr
   readFromRoots i = do
     GCState{roots} <- get
-    return $ roots !! i
+    return $ roots ! i
  
   readFromObject :: ObjectPtr -> GcM Value
+  readFromObject NullPtr = error "Null pointer"
   readFromObject (ObjectPtr i) = do
    GCState{heap} <- get
-   case heap !! i of
+   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
+   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  }
+    put $ s { roots = roots // [(i, ptr)] }
 
   writeToObject :: Value -> ObjectPtr -> GcM ()
+  writeToObject _ NullPtr = error "Null pointer"
   writeToObject v (ObjectPtr i) = do
    s@GCState{heap} <- get
-   let (before, o:after) = splitAt i heap 
-   case o of
+   case heap ! i of
     Nothing -> error "Object is null"
     Just obj ->
-     put $ s { heap = before ++ [Just $ obj { val = v } ] ++ after  }
+     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
-    let (before, o:after) = splitAt p heap
-    case o of
+    case heap ! p 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)  }
+        put $ s { heap = heap // [(p, Just $ obj { fields = fields obj // [(i, ptr)] })]  }
 
 data Object = Object {
   val :: Value,
-  fields :: [ObjectPtr],
+  fields :: Array Int ObjectPtr,
   marked :: Bool
 } deriving (Eq, Show)
 
 data GCState = GCState {
-  roots :: [ObjectPtr],
+  roots :: Array Int ObjectPtr,
   heap :: Heap
 } deriving (Eq,Show)
 
-type Heap = [Maybe Object]
+type Heap = Array Int (Maybe Object)
 
 initState :: GCState
-initState = GCState [] [Nothing  | _ <- [1 :: Int ..8]]
+initState = GCState
+  { roots = array (1, 8) [(i, NullPtr) | i <- [1..8]]
+  , heap = array (1, 8) [(i, Nothing) | i <- [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))
+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
+setMarked (ObjectPtr p) hs = hs // [(p, (\o -> o { marked = True }) <$> (hs ! p)) ]
 
 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)
+  case findIndexWithNothing heap of
+    Just p -> do
+      put $ s { heap = heap // [(p, Just $ Object v (array (1,8) [(i, NullPtr) | i <- [1..8]]) False)] }
+      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 -> Heap
 mark [] h = h
-mark ((ObjectPtr p):rest) h = case h !! p of
-  Just obj ->
+mark (ptr:rest) h
+  | (ObjectPtr p) <- ptr
+  , Just obj <- h ! p
+  =
     let
       step acc NullPtr = acc
       step (wl, heap) child
@@ -121,7 +122,7 @@ mark ((ObjectPtr p):rest) h = case h !! p of
       
       (workList, newH) = foldl step ([], h) $ fields obj
     in mark (workList ++ rest) newH
-  Nothing -> mark rest h
+  | otherwise = mark rest h
 
 markFromRoots :: GcM ()
 markFromRoots = do
@@ -130,7 +131,7 @@ markFromRoots = do
   put $ GCState roots newHeap
   where
     step heap ptr
-      | not (isMarked ptr heap) =
+      | ptr /= NullPtr && not (isMarked ptr heap) =
         let newH = setMarked ptr heap
         in mark [ptr] newH
     step heap _ = heap
@@ -143,7 +144,7 @@ collect = do
 sweep :: GcM ()
 sweep = do
   s@GCState{heap} <- get
-  put $ s { heap = map step heap }
+  put $ s { heap = fmap step heap }
   where
     step Nothing = Nothing
     step (Just o) = if marked o then Just (o { marked = False }) else Nothing
@@ -155,7 +156,7 @@ main = do
         ptr <- new (IntVal 3)
         ptr2 <- new (IntVal 5) 
 
-        writeToRoots 0 ptr 
+        writeToRoots 1 ptr 
 
         collect
         return [ptr, ptr2]