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
   8 import Text.Printf
   9 import Control.Monad.State
  10
  11 import Mate.GC
  12
  13 class AllocationManager a where
  14   mallocBytes :: a -> Int -> (a,Ptr b)
  15
  16 data TwoSpace = TwoSpace { fromBase :: IntPtr,
  17                            toBase   :: IntPtr,
  18                            fromHeap :: IntPtr,
  19                            toHeap   :: IntPtr,
  20                            fromExtreme :: IntPtr,
  21                            toExtreme   :: IntPtr }
  22
  23 mallocBytes' :: Int -> State TwoSpace (Ptr b)
  24 mallocBytes' bytes = do state <- get
  25                         let end = (toHeap state) + (ptrToIntPtr $ nullPtr `plusPtr` bytes) -- not really? FUUU
  26                         -- actually i would like to use an existential within TwoSpace but this requires
  27                         -- pattern matchingt at call site http://stackoverflow.com/questions/10192663/why-cant-existential-types-use-record-syntax which is i think even slower.
  28                         if end <= toExtreme state then alloc state end else fail
  29   where alloc :: TwoSpace -> IntPtr -> State TwoSpace (Ptr b)
  30         alloc state end = do let ptr = toHeap state
  31                              put $ state { toHeap = end }
  32                              return $ intPtrToPtr ptr
  33         fail = error "no space left in two space (mallocBytes')"
  34
  35 type Action = IO ()
  36
  37 evacuate :: RefObj a => [a] -> State TwoSpace Action
  38 evacuate = undefined
  39
  40 evacuate' :: RefObj a => a -> State TwoSpace Action
  41 evacuate' = undefined
  42
  43
  44 initTwoSpace :: Int -> IO TwoSpace
  45 initTwoSpace size =  do printf "initializing TwoSpace memory manager with %d bytes." size
  46                         fromSpace <- Alloc.mallocBytes size
  47                         toSpace   <- Alloc.mallocBytes size
  48                         if fromSpace /= nullPtr && toSpace /= nullPtr
  49                            then return $ buildToSpace fromSpace toSpace
  50                            else error "Could not initialize TwoSpace memory manager (malloc returned null ptr)"
  51    where buildToSpace from to = let fromBase' = ptrToIntPtr from
  52                                     toBase' = ptrToIntPtr to
  53                                     fromExtreme' = ptrToIntPtr $ from `plusPtr` size
  54                                     toExtreme' = ptrToIntPtr $ to `plusPtr` size
  55                                 in TwoSpace { fromBase = fromBase', toBase = toBase',
  56                                               fromHeap = fromBase', toHeap = toBase',
  57                                               fromExtreme = fromExtreme', toExtreme = toExtreme' }
  58