src/Mate/GC/Boehm.hs

   1 {-# LANGUAGE ForeignFunctionInterface #-}
   2 {-# LANGUAGE CPP #-}
   3 module Mate.GC.Boehm (
   4      mallocBytesGC,
   5      unsafeFreeGC,
   6      getHeapSizeGC,
   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_c :: CSize -> IO (Ptr a)
  22
  23 foreign import ccall "gc/gc.h GC_get_heap_size"
  24    heapSizeGC_c :: IO CSize
  25
  26 foreign import ccall "gc/gc.h GC_init"
  27    initGC_c :: IO ()
  28
  29 foreign import ccall "gc/gc.h GC_add_roots"
  30    addRootGCInternal_c :: Ptr a -> Ptr a -> IO ()
  31
  32 -- counts allocated memory in heap
  33 {-# NOINLINE globalBytesAllocated #-}
  34 globalBytesAllocated :: IORef Int
  35 globalBytesAllocated = unsafePerformIO (newIORef 0)
  36
  37 -- |Initializs the GC. Should be called before mallocBytesGC
  38 initGC :: IO ()
  39 initGC = initGC_c
  40
  41 #ifdef DEBUG
  42 -- |Allocates size bytes in managed memory
  43 mallocBytesGC :: Int -> IO (Ptr a)
  44 mallocBytesGC size = do
  45   --print "trying alloc"
  46   ptr <- modifyIORef globalBytesAllocated (+ size) >> mallocGC_c (fromIntegral size)
  47   if ptr == nullPtr
  48    then error "mallocBytes asked memory management for memory but returned nullPtr. (see BoehmGC)"
  49    else return ptr
  50
  51 #else
  52 -- |Allocates size bytes in managed memory
  53 mallocBytesGC :: Int -> IO (Ptr a)
  54 mallocBytesGC = mallocGC_c . fromIntegral
  55 #endif
  56
  57 -- |Explicitely deallocate an object. Not required and dangerous.
  58 unsafeFreeGC :: Ptr a -> IO ()
  59 unsafeFreeGC _ = print "not implemented"
  60
  61 -- |Returns currently allocated memory in bytes
  62 getHeapSizeGC :: IO Int
  63 getHeapSizeGC = liftM fromIntegral heapSizeGC_c
  64
  65 -- |Adds a memory segment to be GC root
  66 addRootGC :: Ptr a -> Ptr a -> IO ()
  67 addRootGC = addRootGCInternal_c