{-# 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
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
refs :: a -> IO [a]
patchRefs :: a -> [a] -> IO ()
newRef :: a -> a -> IO ()
+ getNewRef :: a -> IO a
marked :: a -> IO Bool
mark :: 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
+
+
{-# LANGUAGE ExistentialQuantification #-}
-module Mate.MemoryManager ( ) where
+module Mate.MemoryManager (evacuateList, AllocationManager,
+ TwoSpace, initTwoSpace) where
import qualified Foreign.Marshal.Alloc as Alloc
import Foreign.Ptr
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')"
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
module Mate.Tests.MockRefs where
import Mate.GC
+import Mate.MemoryManager
import Foreign.Ptr
import Foreign.Marshal.Alloc
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'
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
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
+
+
projects / mate.git / commitdiff