import Control.Monad
import qualified Data.Set as S
-import Foreign.Ptr (IntPtr)
+import Foreign.Ptr (IntPtr, Ptr)
class (Eq a, Ord a) => RefObj a where
payload :: a -> IO IntPtr
-
+ size :: a -> IO Int
+ cast :: Ptr b -> a
+
refs :: a -> IO [a]
patchRefs :: a -> [a] -> IO ()
newRef :: a -> a -> IO ()
mark :: a -> IO ()
unmark :: a -> IO ()
- copy :: a -> IO a
class PrintableRef a where
printRef :: a -> IO ()
import qualified Foreign.Marshal.Alloc as Alloc
import Foreign.Ptr
import Foreign.Storable
+import Foreign.Marshal.Utils
import Text.Printf
import Control.Monad.State
+import Control.Applicative
import Mate.GC
class AllocationManager a where
- mallocBytes :: a -> Int -> (a,Ptr b)
+ mallocBytes :: Int -> StateT a IO (Ptr b)
data TwoSpace = TwoSpace { fromBase :: IntPtr,
toBase :: IntPtr,
fromExtreme :: IntPtr,
toExtreme :: IntPtr }
-mallocBytes' :: Int -> State TwoSpace (Ptr b)
+instance AllocationManager TwoSpace where
+ mallocBytes = mallocBytes'
+
+mallocBytes' :: Int -> StateT TwoSpace IO (Ptr b)
mallocBytes' bytes = do state <- get
- let end = (toHeap state) + (ptrToIntPtr $ nullPtr `plusPtr` bytes) -- not really? FUUU
+ let end = toHeap state + ptrToIntPtr (nullPtr `plusPtr` bytes) -- not really? FUUU
-- actually i would like to use an existential within TwoSpace but this requires
-- pattern matchingt at call site http://stackoverflow.com/questions/10192663/why-cant-existential-types-use-record-syntax which is i think even slower.
if end <= toExtreme state then alloc state end else fail
- where alloc :: TwoSpace -> IntPtr -> State TwoSpace (Ptr b)
+ where alloc :: TwoSpace -> IntPtr -> StateT TwoSpace IO (Ptr b)
alloc state end = do let ptr = toHeap state
put $ state { toHeap = end }
- return $ intPtrToPtr ptr
+ liftIO (return $ intPtrToPtr ptr)
fail = error "no space left in two space (mallocBytes')"
-type Action = IO ()
-evacuate :: RefObj a => [a] -> State TwoSpace Action
-evacuate = undefined
+evacuate' :: (RefObj a, AllocationManager b) => [a] -> StateT b IO ()
+evacuate' = foldr (\x evac -> evac >> evacuate'' x) (liftIO (return ()))
+
+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
+ -- copy data over and leave notice
+ liftIO (copyBytes newPtr (intPtrToPtr payload) size >>
+ newRef obj (cast newPtr))
-evacuate' :: RefObj a => a -> State TwoSpace Action
-evacuate' = undefined
+evacuate :: (RefObj a, AllocationManager b) => [a] -> b -> IO ()
+evacuate objs manager = evalStateT (evacuate' objs) manager
initTwoSpace :: Int -> IO TwoSpace
instance RefObj (Ptr a) where
payload = return . ptrToIntPtr
+ size a = fmap ((+ 0x10) . length) (refs a)
refs = unpackRefs . castPtr
marked = markedRef
mark = markRef (0x1::Int32)
unmark = markRef (0x0::Int32)
newRef = newRefPtr
patchRefs = undefined
- copy = undefined
+ cast = castPtr
instance PrintableRef (Ptr a) where
printRef = printRef'
markRef val ptr = pokeByteOff ptr markedOff val
newRefPtr :: Ptr a -> Ptr a -> IO ()
-newRefPtr ptr newRef = pokeByteOff ptr newRefOff newRef
+newRefPtr ptr = pokeByteOff ptr newRefOff
printRef' :: Ptr a -> IO ()
printRef' ptr = do printf "obj 0x%08x\n" =<< (peekByteOff ptr idOff :: IO Int32)