src/Mate/GC/Boehm.hs

   1 {-# LANGUAGE ForeignFunctionInterface #-}
   2 {-# LANGUAGE CPP #-}
   3 module Mate.GC.Boehm (
   4      mallocBytesGC,
   5      unsafeFreeGC,
   6      getHeapSize,
   7      initGC,
   8      addRootGC,
   9   ) where
  10
  11 #define DEBUG
  12
  13 import Foreign.Marshal.Alloc
  14 import Foreign.Ptr
  15 import Data.IORef
  16 import System.IO.Unsafe
  17 import Foreign.C.Types
  18 import Control.Monad
  19
  20 foreign import ccall "gc/gc.h GC_malloc"
  21    mallocGC :: CSize -> IO (Ptr a)
  22
  23 foreign import ccall "gc/gc.h GC_get_heap_size"
  24    heapSizeGC :: IO CSize
  25
  26
  27 foreign import ccall "gc/gc.h GC_init"
  28    initGC :: IO ()
  29
  30
  31 foreign import ccall "gc/gc.h GC_add_roots"
  32    addRootGCInternal :: Ptr a -> Ptr a -> IO ()
  33
  34 -- counts allocated memory in heap
  35 {-# NOINLINE globalBytesAllocated #-}
  36 globalBytesAllocated :: IORef Int
  37 globalBytesAllocated = unsafePerformIO (newIORef 0)
  38
  39 #ifdef DEBUG
  40 -- |Allocates size bytes in managed memory
  41 mallocBytesGC :: Int -> IO (Ptr a)
  42 mallocBytesGC size = do
  43   --print "trying alloc"
  44   ptr <- modifyIORef globalBytesAllocated (+ size) >> mallocGC (fromIntegral size)
  45   if ptr == nullPtr
  46    then error "alloc 0"
  47    else return ptr
  48
  49 #else
  50 -- |Allocates size bytes in managed memory
  51 mallocBytesGC :: Int -> IO (Ptr a)
  52 mallocBytesGC = mallocGC . fromIntegral
  53 #endif
  54
  55 -- |Explicitely deallocate an object. Not required and dangerous.
  56 unsafeFreeGC :: Ptr a -> IO ()
  57 unsafeFreeGC _ = print "not implemented"
  58
  59 -- |Returns currently allocated memory in bytes
  60 getHeapSize :: IO Int
  61 getHeapSize = liftM fromIntegral heapSizeGC
  62
  63 addRootGC :: Ptr a -> Ptr a -> IO ()
  64 addRootGC = addRootGCInternal