Mate/MemoryManager.hs

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