From: Harald Steinlechner Date: Sat, 1 Sep 2012 17:17:23 +0000 (+0200) Subject: GC: TwoSpace copy evacuation basically works X-Git-Url: http://wien.tomnetworks.com/gitweb/?p=mate.git;a=commitdiff_plain;h=3c586be8ee0075882c7538b63ac91d129eab2d12 GC: TwoSpace copy evacuation basically works --- diff --git a/Mate/GC.hs b/Mate/GC.hs index b22af7a..687197b 100644 --- a/Mate/GC.hs +++ b/Mate/GC.hs @@ -1,6 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} module Mate.GC - ( RefObj(..), PrintableRef(..), traverseIO, markTree'' + ( RefObj(..), PrintableRef(..), traverseIO, markTree'', patchAllRefs {- dont export generic versions for high performance -> remove for production -}) where import Control.Monad @@ -8,7 +8,7 @@ import qualified Data.Set as S import Foreign.Ptr (IntPtr, Ptr) -class (Eq a, Ord a) => RefObj a where +class (Eq a, Ord a, Show a) => RefObj a where payload :: a -> IO IntPtr size :: a -> IO Int @@ -17,6 +17,7 @@ class (Eq a, Ord a) => RefObj a where refs :: a -> IO [a] patchRefs :: a -> [a] -> IO () newRef :: a -> a -> IO () + getNewRef :: a -> IO a marked :: a -> IO Bool mark :: a -> IO () @@ -49,3 +50,17 @@ markTree :: RefObj a => a -> IO () markTree root = marked root >>= (`unless` continue) where continue = mark root >> refs root >>= mapM_ markTree + +-- | This object is alive. so its children are alive. patch child references to point +-- to childrens new references +patchRefsObj :: (RefObj a) => a -> IO () +patchRefsObj obj = do obj' <- getNewRef obj + fields <- refs obj + newRefs <- mapM getNewRef fields + print newRefs + patchRefs obj' newRefs + +patchAllRefs :: (RefObj a) => [a] -> IO () +patchAllRefs = mapM_ patchRefsObj + + diff --git a/Mate/MemoryManager.hs b/Mate/MemoryManager.hs index 7502be9..3944f82 100644 --- a/Mate/MemoryManager.hs +++ b/Mate/MemoryManager.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} -module Mate.MemoryManager ( ) where +module Mate.MemoryManager (evacuateList, AllocationManager, + TwoSpace, initTwoSpace) where import qualified Foreign.Marshal.Alloc as Alloc import Foreign.Ptr @@ -34,6 +35,7 @@ mallocBytes' bytes = do state <- get where alloc :: TwoSpace -> IntPtr -> StateT TwoSpace IO (Ptr b) alloc state end = do let ptr = toHeap state put $ state { toHeap = end } + liftIO (putStrLn $ "Allocated obj: " ++ (show ptr)) liftIO (return $ intPtrToPtr ptr) fail = error "no space left in two space (mallocBytes')" @@ -45,21 +47,22 @@ 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, AllocationManager b) => [a] -> b -> IO () -evacuate objs manager = evalStateT (evacuate' objs) manager +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 diff --git a/Mate/Tests/MockRefs.hs b/Mate/Tests/MockRefs.hs index d58a0fa..f87d593 100644 --- a/Mate/Tests/MockRefs.hs +++ b/Mate/Tests/MockRefs.hs @@ -1,6 +1,7 @@ module Mate.Tests.MockRefs where import Mate.GC +import Mate.MemoryManager import Foreign.Ptr import Foreign.Marshal.Alloc @@ -13,14 +14,15 @@ import Control.Monad instance RefObj (Ptr a) where payload = return . ptrToIntPtr - size a = fmap ((+ 0x10) . length) (refs a) + size a = fmap ((+ fieldsOff) . length) (refs a) refs = unpackRefs . castPtr marked = markedRef mark = markRef (0x1::Int32) unmark = markRef (0x0::Int32) newRef = newRefPtr - patchRefs = undefined + patchRefs = patchRefsPtr cast = castPtr + getNewRef ptr = peekByteOff ptr newRefOff instance PrintableRef (Ptr a) where printRef = printRef' @@ -44,19 +46,32 @@ markRef :: Int32 -> Ptr a -> IO () markRef val ptr = pokeByteOff ptr markedOff val newRefPtr :: Ptr a -> Ptr a -> IO () -newRefPtr ptr = pokeByteOff ptr newRefOff +newRefPtr ptr newPtr = pokeByteOff ptr newRefOff newPtr + +patchRefsPtr :: Ptr a -> [Ptr a] -> IO () +patchRefsPtr ptr xs = pokeArray (ptr `plusPtr` fieldsOff) xs printRef' :: Ptr a -> IO () printRef' ptr = do printf "obj 0x%08x\n" =<< (peekByteOff ptr idOff :: IO Int32) printf "children 0x%08x\n" =<< (peekByteOff ptr numberOfObjsOff :: IO Int32) - printf "marked 0x%08x\n" =<< (peekByteOff ptr markedOff :: IO Int32) - printf "newRef 0x%08x\n\n" =<< (peekByteOff ptr newRefOff :: IO Int32) + printf "marked 0x%08x\n" =<< (peekByteOff ptr markedOff :: IO Int32) + printf "payload 0x%08x\n" =<< ((liftM fromIntegral (payload ptr)) :: IO Int32) + printf "newRef 0x%08x\n" =<< (peekByteOff ptr newRefOff :: IO Int32) + printChildren ptr + putStrLn "" + +printChildren :: Ptr a -> IO () +printChildren ptr = do children <- refs ptr + putStrLn $ "children" ++ (show children) + printTree :: Ptr a -> IO () printTree = traverseIO printRef' emptyObj id = do mem <- mallocBytes 0x10 - pokeArray mem [id,0,0::Int32,0] + putStrLn $ "my memory: " ++ show mem + let self = fromIntegral (ptrToIntPtr mem) + pokeArray mem [0,0,0::Int32,0] return mem twoRefs = do mem <- mallocBytes 0x18 @@ -89,3 +104,27 @@ test objr = do twoRefs <- objr markTree'' (liftM not . marked) unmark [] twoRefs putStrLn "after unmarking\n" printTree twoRefs + +{- +patchAllRefs :: (RefObj a) => a -> IO a +patchAllRefs obj = do markTree'' patchAndCheckMark unmark [] obj + getNewRef obj + where patchAndCheckMark :: a -> IO Bool + patchAndCheckMark a = undefined +-} + +testEvacuation objr = do ref <- objr + lifeRefs <- markTree'' marked mark [] ref + putStrLn "initial objectTree" + printTree ref + memoryManager <- initTwoSpace 0x10000 + evacuateList lifeRefs memoryManager + print lifeRefs + putStrLn "oldObjectTree: " + printTree ref + patchAllRefs lifeRefs + newRef <- getNewRef ref + putStrLn "resulting objectTree" + printTree newRef + +