GC: TwoSpace copy evacuation basically works

[mate.git] / Mate / MemoryManager.hs

diff --git a/Mate/MemoryManager.hs b/Mate/MemoryManager.hs
index 988c3608bd4b1bf5558dc489812ceb7df86c420e..3944f8223833262f549389bb5d55295a9114cccb 100644 (file)
--- a/Mate/MemoryManager.hs
+++ b/Mate/MemoryManager.hs
@@ -1,19 +1,20 @@
 {-# LANGUAGE ExistentialQuantification #-}
-module Mate.MemoryManager ( ) where
+module Mate.MemoryManager (evacuateList, AllocationManager, 
+                           TwoSpace, initTwoSpace) where
 
 import qualified Foreign.Marshal.Alloc as Alloc
 import Foreign.Ptr
 import Foreign.Storable
-
-import Data.HashTable
+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, 
@@ -22,34 +23,46 @@ 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 (putStrLn $ "Allocated obj: " ++ (show 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
+                    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))
 
-evacuate' :: RefObj a => a -> State TwoSpace Action
-evacuate' = undefined
+evacuateList :: (RefObj a, AllocationManager b) => [a] -> b -> IO ()
+evacuateList objs manager = evalStateT (evacuate' objs) manager
 
 
 initTwoSpace :: Int -> IO TwoSpace
-initTwoSpace size =  do printf "initializing TwoSpace memory manager with %d bytes." size
+initTwoSpace size =  do printf "initializing TwoSpace memory manager with %d bytes.\n" size
                         fromSpace <- Alloc.mallocBytes size
                         toSpace   <- Alloc.mallocBytes size
                         if fromSpace /= nullPtr && toSpace /= nullPtr 
                            then return $ buildToSpace fromSpace toSpace
-                           else error "Could not initialize TwoSpace memory manager (malloc returned null ptr)"
+                           else error "Could not initialize TwoSpace memory manager (malloc returned null ptr)\n"
    where buildToSpace from to = let fromBase' = ptrToIntPtr from
                                     toBase' = ptrToIntPtr to
                                     fromExtreme' = ptrToIntPtr $ from `plusPtr` size