From: Harald Steinlechner <haraldsteinlechner@gmail.com>
Date: Sat, 1 Sep 2012 18:33:58 +0000 (+0200)
Subject: GC: implemented basic GC memory swapping; some refactoring
X-Git-Url: http://wien.tomnetworks.com/gitweb/?p=mate.git;a=commitdiff_plain;h=03c895449bd4374e3210cf446c91504de258f3cf

GC: implemented basic GC memory swapping; some refactoring
---

diff --git a/Mate/GC.hs b/Mate/GC.hs
index 687197b..eb1f2f7 100644
--- a/Mate/GC.hs
+++ b/Mate/GC.hs
@@ -16,7 +16,7 @@ class (Eq a, Ord a, Show a) => RefObj a where
  
   refs      :: a -> IO [a]
   patchRefs :: a -> [a] -> IO ()
-  newRef    :: a -> a -> IO ()
+  setNewRef :: a -> a -> IO ()
   getNewRef :: a -> IO a
   
   marked  :: a -> IO Bool
diff --git a/Mate/MemoryManager.hs b/Mate/MemoryManager.hs
index 3944f82..c55fb37 100644
--- a/Mate/MemoryManager.hs
+++ b/Mate/MemoryManager.hs
@@ -14,7 +14,12 @@ import Control.Applicative
 import Mate.GC
 
 class AllocationManager a where
+  
+  -- | allocates n bytes in current space to space (may be to space or gen0 space)
   mallocBytes :: Int -> StateT a IO (Ptr b)
+  
+  -- | performs full gc and which is reflected in mem managers state
+  performCollection :: (RefObj b) => [b] ->  StateT a IO ()
 
 data TwoSpace = TwoSpace { fromBase :: IntPtr, 
                            toBase   :: IntPtr, 
@@ -25,6 +30,30 @@ data TwoSpace = TwoSpace { fromBase :: IntPtr,
 
 instance AllocationManager TwoSpace where
   mallocBytes = mallocBytes'
+  performCollection = performCollection'
+
+
+performCollection' :: (RefObj a) => [a] -> StateT TwoSpace IO ()
+performCollection' roots = do oldState <- get
+                              modify switchSpaces
+                              newState <- get
+                              lift (performCollectionIO newState roots)
+                              -- [todo hs]: patch gc roots
+                         
+-- [todo hs] this is slow. merge phases to eliminate list with refs
+performCollectionIO :: (AllocationManager b, RefObj a) => b -> [a] -> IO ()
+performCollectionIO manager refs = do lifeRefs <- liftM concat $ mapM (markTree'' marked mark []) refs
+                                      evacuateList lifeRefs manager
+                                      patchAllRefs lifeRefs                       
+
+switchSpaces :: TwoSpace -> TwoSpace
+switchSpaces old = old { fromHeap = toHeap old,
+                         toHeap = fromBase old, 
+                         fromBase = toBase old,
+                         toBase = fromBase old,
+                         fromExtreme = toExtreme old,
+                         toExtreme = fromExtreme old }
+
 
 mallocBytes' :: Int -> StateT TwoSpace IO (Ptr b)
 mallocBytes' bytes = do state <- get
@@ -41,7 +70,7 @@ mallocBytes' bytes = do state <- get
 
 
 evacuate' :: (RefObj a, AllocationManager b) => [a] -> StateT b IO ()
-evacuate' = foldr (\x evac -> evac >> evacuate'' x) (liftIO (return ())) 
+evacuate' =  mapM_ evacuate'' 
 
 evacuate'' :: (RefObj a, AllocationManager b) => a -> StateT b IO ()
 evacuate'' obj = do (size,payload) <- liftIO ((,) <$> size obj <*> payload obj)
@@ -50,7 +79,7 @@ evacuate'' obj = do (size,payload) <- liftIO ((,) <$> size obj <*> payload obj)
                     liftIO (putStrLn ("evacuating: " ++ show obj ++ " and set: " ++ show newPtr))
                     -- copy data over and leave notice
                     liftIO (copyBytes newPtr (intPtrToPtr payload) size >> 
-                            newRef obj (cast newPtr))
+                            setNewRef obj (cast newPtr))
 
 evacuateList :: (RefObj a, AllocationManager b) => [a] -> b -> IO ()
 evacuateList objs manager = evalStateT (evacuate' objs) manager
diff --git a/Mate/Tests/MockRefs.hs b/Mate/Tests/MockRefs.hs
index f87d593..b137260 100644
--- a/Mate/Tests/MockRefs.hs
+++ b/Mate/Tests/MockRefs.hs
@@ -19,7 +19,7 @@ instance RefObj (Ptr a) where
   marked      = markedRef
   mark        = markRef (0x1::Int32)
   unmark      = markRef (0x0::Int32)
-  newRef      = newRefPtr
+  setNewRef   = setNewRefPtr
   patchRefs   = patchRefsPtr
   cast = castPtr
   getNewRef ptr = peekByteOff ptr newRefOff
@@ -45,8 +45,8 @@ markedRef ptr = liftM ((/=0) . fromIntegral) (peekByteOff ptr markedOff :: IO In
 markRef :: Int32 -> Ptr a -> IO ()
 markRef val ptr = pokeByteOff ptr markedOff val
 
-newRefPtr :: Ptr a -> Ptr a -> IO ()
-newRefPtr ptr newPtr = pokeByteOff ptr newRefOff newPtr
+setNewRefPtr :: Ptr a -> Ptr a -> IO ()
+setNewRefPtr ptr newPtr = pokeByteOff ptr newRefOff newPtr
 
 patchRefsPtr :: Ptr a -> [Ptr a] -> IO ()
 patchRefsPtr ptr xs = pokeArray (ptr `plusPtr` fieldsOff) xs