1 {-# LANGUAGE ExistentialQuantification #-}
2 module Mate.MemoryManager (evacuateList, AllocationManager,
3 TwoSpace, initTwoSpace) where
5 import qualified Foreign.Marshal.Alloc as Alloc
7 import Foreign.Storable
8 import Foreign.Marshal.Utils
11 import Control.Monad.State
12 import Control.Applicative
16 class AllocationManager a where
18 -- | allocates n bytes in current space to space (may be to space or gen0 space)
19 mallocBytes :: Int -> StateT a IO (Ptr b)
21 -- | performs full gc and which is reflected in mem managers state
22 performCollection :: (RefObj b) => [b] -> StateT a IO ()
24 data TwoSpace = TwoSpace { fromBase :: IntPtr,
28 fromExtreme :: IntPtr,
31 instance AllocationManager TwoSpace where
32 mallocBytes = mallocBytes'
33 performCollection = performCollection'
36 performCollection' :: (RefObj a) => [a] -> StateT TwoSpace IO ()
37 performCollection' roots = do oldState <- get
40 lift (performCollectionIO newState roots)
41 -- [todo hs]: patch gc roots
43 -- [todo hs] this is slow. merge phases to eliminate list with refs
44 performCollectionIO :: (AllocationManager b, RefObj a) => b -> [a] -> IO ()
45 performCollectionIO manager refs = do lifeRefs <- liftM concat $ mapM (markTree'' marked mark []) refs
46 evacuateList lifeRefs manager
49 switchSpaces :: TwoSpace -> TwoSpace
50 switchSpaces old = old { fromHeap = toHeap old,
51 toHeap = fromBase old,
52 fromBase = toBase old,
53 toBase = fromBase old,
54 fromExtreme = toExtreme old,
55 toExtreme = fromExtreme old }
58 mallocBytes' :: Int -> StateT TwoSpace IO (Ptr b)
59 mallocBytes' bytes = do state <- get
60 let end = toHeap state + ptrToIntPtr (nullPtr `plusPtr` bytes) -- not really? FUUU
61 -- actually i would like to use an existential within TwoSpace but this requires
62 -- pattern matchingt at call site http://stackoverflow.com/questions/10192663/why-cant-existential-types-use-record-syntax which is i think even slower.
63 if end <= toExtreme state then alloc state end else fail
64 where alloc :: TwoSpace -> IntPtr -> StateT TwoSpace IO (Ptr b)
65 alloc state end = do let ptr = toHeap state
66 put $ state { toHeap = end }
67 liftIO (putStrLn $ "Allocated obj: " ++ (show ptr))
68 liftIO (return $ intPtrToPtr ptr)
69 fail = error "no space left in two space (mallocBytes')"
72 evacuate' :: (RefObj a, AllocationManager b) => [a] -> StateT b IO ()
73 evacuate' = mapM_ evacuate''
75 evacuate'' :: (RefObj a, AllocationManager b) => a -> StateT b IO ()
76 evacuate'' obj = do (size,payload) <- liftIO ((,) <$> size obj <*> payload obj)
78 newPtr <- mallocBytes size
79 liftIO (putStrLn ("evacuating: " ++ show obj ++ " and set: " ++ show newPtr))
80 -- copy data over and leave notice
81 liftIO (copyBytes newPtr (intPtrToPtr payload) size >>
82 setNewRef obj (cast newPtr))
84 evacuateList :: (RefObj a, AllocationManager b) => [a] -> b -> IO ()
85 evacuateList objs manager = evalStateT (evacuate' objs) manager
88 initTwoSpace :: Int -> IO TwoSpace
89 initTwoSpace size = do printf "initializing TwoSpace memory manager with %d bytes.\n" size
90 fromSpace <- Alloc.mallocBytes size
91 toSpace <- Alloc.mallocBytes size
92 if fromSpace /= nullPtr && toSpace /= nullPtr
93 then return $ buildToSpace fromSpace toSpace
94 else error "Could not initialize TwoSpace memory manager (malloc returned null ptr)\n"
95 where buildToSpace from to = let fromBase' = ptrToIntPtr from
96 toBase' = ptrToIntPtr to
97 fromExtreme' = ptrToIntPtr $ from `plusPtr` size
98 toExtreme' = ptrToIntPtr $ to `plusPtr` size
99 in TwoSpace { fromBase = fromBase', toBase = toBase',
100 fromHeap = fromBase', toHeap = toBase',
101 fromExtreme = fromExtreme', toExtreme = toExtreme' }