codegen: handle exceptions of a method

[mate.git] / Mate / MemoryManager.hs

diff --git a/Mate/MemoryManager.hs b/Mate/MemoryManager.hs
index 7502be9b210d741c89888b7fe8cc71a89268837b..1665d20f1fefe7a2a5efabac12e2da67b7f4c962 100644 (file)
--- a/Mate/MemoryManager.hs
+++ b/Mate/MemoryManager.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE ExistentialQuantification #-}
-module Mate.MemoryManager ( ) where
+module Mate.MemoryManager (evacuateList, AllocationManager(heapSize, performCollection), 
+                           TwoSpace, initTwoSpace) where
 
 import qualified Foreign.Marshal.Alloc as Alloc
 import Foreign.Ptr
@@ -13,7 +14,14 @@ import Control.Applicative
 import Mate.GC
 
 class AllocationManager a where
+  
+  -- | allocates n bytes in current space to space (may be to space or gen0 space)
   mallocBytes :: Int -> StateT a IO (Ptr b)
+  
+  -- | performs full gc and which is reflected in mem managers state
+  performCollection :: (RefObj b) => [b] ->  StateT a IO ()
+
+  heapSize :: StateT a IO Int
 
 data TwoSpace = TwoSpace { fromBase :: IntPtr, 
                            toBase   :: IntPtr, 
@@ -24,6 +32,33 @@ data TwoSpace = TwoSpace { fromBase :: IntPtr,
 
 instance AllocationManager TwoSpace where
   mallocBytes = mallocBytes'
+  performCollection = performCollection'
+  
+  heapSize = do space <- get
+                return $ fromIntegral $ toHeap space - fromIntegral (toBase space)
+
+
+performCollection' :: (RefObj a) => [a] -> StateT TwoSpace IO ()
+performCollection' roots = do oldState <- get
+                              modify switchSpaces
+                              newState <- get
+                              lift (performCollectionIO newState roots)
+                              -- [todo hs]: patch gc roots
+                         
+-- [todo hs] this is slow. merge phases to eliminate list with refs
+performCollectionIO :: (AllocationManager b, RefObj a) => b -> [a] -> IO ()
+performCollectionIO manager refs = do lifeRefs <- liftM concat $ mapM (markTree'' marked mark []) refs
+                                      evacuateList lifeRefs manager
+                                      patchAllRefs lifeRefs                       
+
+switchSpaces :: TwoSpace -> TwoSpace
+switchSpaces old = old { fromHeap = toHeap old,
+                         toHeap = fromBase old, 
+                         fromBase = toBase old,
+                         toBase = fromBase old,
+                         fromExtreme = toExtreme old,
+                         toExtreme = fromExtreme old }
+
 
 mallocBytes' :: Int -> StateT TwoSpace IO (Ptr b)
 mallocBytes' bytes = do state <- get
@@ -34,32 +69,34 @@ mallocBytes' bytes = do state <- get
   where alloc :: TwoSpace -> IntPtr -> StateT TwoSpace IO (Ptr b)
         alloc state end = do let ptr = toHeap state
                              put $ state { toHeap = end } 
+                             liftIO (putStrLn $ "Allocated obj: " ++ show ptr)
                              liftIO (return $ intPtrToPtr ptr)
         fail = error "no space left in two space (mallocBytes')"
 
 
 evacuate' :: (RefObj a, AllocationManager b) => [a] -> StateT b IO ()
-evacuate' = foldr (\x evac -> evac >> evacuate'' x) (liftIO (return ())) 
+evacuate' =  mapM_ evacuate'' 
 
 evacuate'' :: (RefObj a, AllocationManager b) => a -> StateT b IO ()
 evacuate'' obj = do (size,payload) <- liftIO ((,) <$> size obj <*> payload obj)
                     -- malloc in TwoSpace
                     newPtr <- mallocBytes size
+                    liftIO (putStrLn ("evacuating: " ++ show obj ++ " and set: " ++ show newPtr))
                     -- copy data over and leave notice
                     liftIO (copyBytes newPtr (intPtrToPtr payload) size >> 
-                            newRef obj (cast newPtr))
+                            setNewRef obj (cast newPtr))
 
-evacuate :: (RefObj a, AllocationManager b) => [a] -> b -> IO ()
-evacuate objs manager = evalStateT (evacuate' objs) manager
+evacuateList :: (RefObj a, AllocationManager b) => [a] -> b -> IO ()
+evacuateList objs = evalStateT (evacuate' objs) 
 
 
 initTwoSpace :: Int -> IO TwoSpace
-initTwoSpace size =  do printf "initializing TwoSpace memory manager with %d bytes." size
+initTwoSpace size =  do printf "initializing TwoSpace memory manager with %d bytes.\n" size
                         fromSpace <- Alloc.mallocBytes size
                         toSpace   <- Alloc.mallocBytes size
                         if fromSpace /= nullPtr && toSpace /= nullPtr 
                            then return $ buildToSpace fromSpace toSpace
-                           else error "Could not initialize TwoSpace memory manager (malloc returned null ptr)"
+                           else error "Could not initialize TwoSpace memory manager (malloc returned null ptr)\n"
    where buildToSpace from to = let fromBase' = ptrToIntPtr from
                                     toBase' = ptrToIntPtr to
                                     fromExtreme' = ptrToIntPtr $ from `plusPtr` size