Mate/MemoryManager.hs

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