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