Mate/MemoryManager.hs

   1 {-# LANGUAGE ExistentialQuantification #-}
   2 module Mate.MemoryManager (evacuateList, AllocationManager,
   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   mallocBytes :: Int -> StateT a IO (Ptr b)
  18
  19 data TwoSpace = TwoSpace { fromBase :: IntPtr,
  20                            toBase   :: IntPtr,
  21                            fromHeap :: IntPtr,
  22                            toHeap   :: IntPtr,
  23                            fromExtreme :: IntPtr,
  24                            toExtreme   :: IntPtr }
  25
  26 instance AllocationManager TwoSpace where
  27   mallocBytes = mallocBytes'
  28
  29 mallocBytes' :: Int -> StateT TwoSpace IO (Ptr b)
  30 mallocBytes' bytes = do state <- get
  31                         let end = toHeap state + ptrToIntPtr (nullPtr `plusPtr` bytes) -- not really? FUUU
  32                         -- actually i would like to use an existential within TwoSpace but this requires
  33                         -- pattern matchingt at call site http://stackoverflow.com/questions/10192663/why-cant-existential-types-use-record-syntax which is i think even slower.
  34                         if end <= toExtreme state then alloc state end else fail
  35   where alloc :: TwoSpace -> IntPtr -> StateT TwoSpace IO (Ptr b)
  36         alloc state end = do let ptr = toHeap state
  37                              put $ state { toHeap = end }
  38                              liftIO (putStrLn $ "Allocated obj: " ++ (show ptr))
  39                              liftIO (return $ intPtrToPtr ptr)
  40         fail = error "no space left in two space (mallocBytes')"
  41
  42
  43 evacuate' :: (RefObj a, AllocationManager b) => [a] -> StateT b IO ()
  44 evacuate' = foldr (\x evac -> evac >> evacuate'' x) (liftIO (return ()))
  45
  46 evacuate'' :: (RefObj a, AllocationManager b) => a -> StateT b IO ()
  47 evacuate'' obj = do (size,payload) <- liftIO ((,) <$> size obj <*> payload obj)
  48                     -- malloc in TwoSpace
  49                     newPtr <- mallocBytes size
  50                     liftIO (putStrLn ("evacuating: " ++ show obj ++ " and set: " ++ show newPtr))
  51                     -- copy data over and leave notice
  52                     liftIO (copyBytes newPtr (intPtrToPtr payload) size >>
  53                             newRef obj (cast newPtr))
  54
  55 evacuateList :: (RefObj a, AllocationManager b) => [a] -> b -> IO ()
  56 evacuateList objs manager = evalStateT (evacuate' objs) manager
  57
  58
  59 initTwoSpace :: Int -> IO TwoSpace
  60 initTwoSpace size =  do printf "initializing TwoSpace memory manager with %d bytes.\n" size
  61                         fromSpace <- Alloc.mallocBytes size
  62                         toSpace   <- Alloc.mallocBytes size
  63                         if fromSpace /= nullPtr && toSpace /= nullPtr
  64                            then return $ buildToSpace fromSpace toSpace
  65                            else error "Could not initialize TwoSpace memory manager (malloc returned null ptr)\n"
  66    where buildToSpace from to = let fromBase' = ptrToIntPtr from
  67                                     toBase' = ptrToIntPtr to
  68                                     fromExtreme' = ptrToIntPtr $ from `plusPtr` size
  69                                     toExtreme' = ptrToIntPtr $ to `plusPtr` size
  70                                 in TwoSpace { fromBase = fromBase', toBase = toBase',
  71                                               fromHeap = fromBase', toHeap = toBase',
  72                                               fromExtreme = fromExtreme', toExtreme = toExtreme' }
  73