fixed linker problems (currently not portable due to absolute paths etc);

[hs-boehmgc.git] / src / Mate / GC / Boehm.hs

diff --git a/src/Mate/GC/Boehm.hs b/src/Mate/GC/Boehm.hs
index eb5711b169a9ef871aae58e411c5fe9e977c9287..1e3ff5c4022c453d543f09d7bf7cb6927383e723 100644 (file)
--- a/src/Mate/GC/Boehm.hs
+++ b/src/Mate/GC/Boehm.hs
@@ -1,8 +1,11 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
 {-# LANGUAGE CPP #-}
 module Mate.GC.Boehm (
      mallocBytesGC,
      unsafeFreeGC,
      getHeapSize,
+     initGC,
+     addRootGC,
   ) where
 
 #define DEBUG
@@ -11,6 +14,22 @@ import Foreign.Marshal.Alloc
 import Foreign.Ptr
 import Data.IORef
 import System.IO.Unsafe
+import Foreign.C.Types
+import Control.Monad
+
+foreign import ccall "gc/gc.h GC_malloc"
+   mallocGC :: CSize -> IO (Ptr a) 
+
+foreign import ccall "gc/gc.h GC_get_heap_size"
+   heapSizeGC :: IO CSize
+
+
+foreign import ccall "gc/gc.h GC_init"
+   initGC :: IO ()
+
+
+foreign import ccall "gc/gc.h GC_add_roots"
+   addRootGCInternal :: Ptr a -> Ptr a -> IO ()
 
 -- counts allocated memory in heap
 {-# NOINLINE globalBytesAllocated #-}
@@ -20,11 +39,17 @@ globalBytesAllocated = unsafePerformIO (newIORef 0)
 #ifdef DEBUG
 -- |Allocates size bytes in managed memory
 mallocBytesGC :: Int -> IO (Ptr a)
-mallocBytesGC size = modifyIORef globalBytesAllocated (+ size) >> mallocBytes size
+mallocBytesGC size = do
+  --print "trying alloc"
+  ptr <- modifyIORef globalBytesAllocated (+ size) >> mallocGC (fromIntegral size)
+  if ptr == nullPtr 
+   then error "alloc 0"
+   else return ptr
+
 #else
 -- |Allocates size bytes in managed memory
 mallocBytesGC :: Int -> IO (Ptr a)
-mallocBytesGC = mallocBytes
+mallocBytesGC = mallocGC . fromIntegral
 #endif
 
 -- |Explicitely deallocate an object. Not required and dangerous.
@@ -33,4 +58,7 @@ unsafeFreeGC _ = print "not implemented"
 
 -- |Returns currently allocated memory in bytes
 getHeapSize :: IO Int
-getHeapSize = readIORef globalBytesAllocated
+getHeapSize = liftM fromIntegral heapSizeGC 
+
+addRootGC :: Ptr a -> Ptr a -> IO ()
+addRootGC = addRootGCInternal