From: Harald Steinlechner <haraldsteinlechner@gmail.com>
Date: Sat, 1 Sep 2012 14:35:49 +0000 (+0200)
Subject: GC/MemoryManager: implemented evacuate
X-Git-Url: http://wien.tomnetworks.com/gitweb/?p=mate.git;a=commitdiff_plain;h=23d1abdb070795c9052cc13b40f2287041b63a41

GC/MemoryManager: implemented evacuate
---

diff --git a/Mate/GC.hs b/Mate/GC.hs
index 5ddd6e2..b22af7a 100644
--- a/Mate/GC.hs
+++ b/Mate/GC.hs
@@ -6,12 +6,14 @@ module Mate.GC
 import Control.Monad
 import qualified Data.Set as S
 
-import Foreign.Ptr (IntPtr)
+import Foreign.Ptr (IntPtr, Ptr)
 
 class (Eq a, Ord a) => RefObj a where
   
   payload :: a -> IO IntPtr
-
+  size    :: a -> IO Int
+  cast    :: Ptr b -> a
+ 
   refs      :: a -> IO [a]
   patchRefs :: a -> [a] -> IO ()
   newRef    :: a -> a -> IO ()
@@ -20,7 +22,6 @@ class (Eq a, Ord a) => RefObj a where
   mark    :: a -> IO ()
   unmark  :: a -> IO ()
   
-  copy :: a -> IO a
 
 class PrintableRef a where
   printRef :: a -> IO ()
diff --git a/Mate/MemoryManager.hs b/Mate/MemoryManager.hs
index a58a1a9..7502be9 100644
--- a/Mate/MemoryManager.hs
+++ b/Mate/MemoryManager.hs
@@ -4,14 +4,16 @@ module Mate.MemoryManager ( ) where
 import qualified Foreign.Marshal.Alloc as Alloc
 import Foreign.Ptr
 import Foreign.Storable
+import Foreign.Marshal.Utils
 
 import Text.Printf
 import Control.Monad.State
+import Control.Applicative
 
 import Mate.GC
 
 class AllocationManager a where
-  mallocBytes :: a -> Int -> (a,Ptr b)
+  mallocBytes :: Int -> StateT a IO (Ptr b)
 
 data TwoSpace = TwoSpace { fromBase :: IntPtr, 
                            toBase   :: IntPtr, 
@@ -20,25 +22,35 @@ data TwoSpace = TwoSpace { fromBase :: IntPtr,
                            fromExtreme :: IntPtr,
                            toExtreme   :: IntPtr }
 
-mallocBytes' :: Int -> State TwoSpace (Ptr b)
+instance AllocationManager TwoSpace where
+  mallocBytes = mallocBytes'
+
+mallocBytes' :: Int -> StateT TwoSpace IO (Ptr b)
 mallocBytes' bytes = do state <- get
-                        let end = (toHeap state) + (ptrToIntPtr $ nullPtr `plusPtr` bytes) -- not really? FUUU
+                        let end = toHeap state + ptrToIntPtr (nullPtr `plusPtr` bytes) -- not really? FUUU
                         -- actually i would like to use an existential within TwoSpace but this requires
                         -- pattern matchingt at call site http://stackoverflow.com/questions/10192663/why-cant-existential-types-use-record-syntax which is i think even slower. 
                         if end <= toExtreme state then alloc state end else fail
-  where alloc :: TwoSpace -> IntPtr -> State TwoSpace (Ptr b)
+  where alloc :: TwoSpace -> IntPtr -> StateT TwoSpace IO (Ptr b)
         alloc state end = do let ptr = toHeap state
                              put $ state { toHeap = end } 
-                             return $ intPtrToPtr ptr
+                             liftIO (return $ intPtrToPtr ptr)
         fail = error "no space left in two space (mallocBytes')"
 
-type Action = IO ()
 
-evacuate :: RefObj a => [a] -> State TwoSpace Action
-evacuate = undefined
+evacuate' :: (RefObj a, AllocationManager b) => [a] -> StateT b IO ()
+evacuate' = foldr (\x evac -> evac >> evacuate'' x) (liftIO (return ())) 
+
+evacuate'' :: (RefObj a, AllocationManager b) => a -> StateT b IO ()
+evacuate'' obj = do (size,payload) <- liftIO ((,) <$> size obj <*> payload obj)
+                    -- malloc in TwoSpace
+                    newPtr <- mallocBytes size
+                    -- copy data over and leave notice
+                    liftIO (copyBytes newPtr (intPtrToPtr payload) size >> 
+                            newRef obj (cast newPtr))
 
-evacuate' :: RefObj a => a -> State TwoSpace Action
-evacuate' = undefined
+evacuate :: (RefObj a, AllocationManager b) => [a] -> b -> IO ()
+evacuate objs manager = evalStateT (evacuate' objs) manager
 
 
 initTwoSpace :: Int -> IO TwoSpace
diff --git a/Mate/Tests/MockRefs.hs b/Mate/Tests/MockRefs.hs
index 783852a..d58a0fa 100644
--- a/Mate/Tests/MockRefs.hs
+++ b/Mate/Tests/MockRefs.hs
@@ -13,13 +13,14 @@ import Control.Monad
 
 instance RefObj (Ptr a) where
   payload     = return . ptrToIntPtr
+  size a      = fmap ((+ 0x10) . length) (refs a)
   refs        = unpackRefs . castPtr
   marked      = markedRef
   mark        = markRef (0x1::Int32)
   unmark      = markRef (0x0::Int32)
   newRef      = newRefPtr
   patchRefs   = undefined
-  copy = undefined
+  cast = castPtr
 
 instance PrintableRef (Ptr a) where
   printRef    = printRef'
@@ -43,7 +44,7 @@ markRef :: Int32 -> Ptr a -> IO ()
 markRef val ptr = pokeByteOff ptr markedOff val
 
 newRefPtr :: Ptr a -> Ptr a -> IO ()
-newRefPtr ptr newRef = pokeByteOff ptr newRefOff newRef
+newRefPtr ptr = pokeByteOff ptr newRefOff
 
 printRef' :: Ptr a -> IO ()
 printRef' ptr = do printf "obj 0x%08x\n" =<< (peekByteOff ptr idOff :: IO Int32)