{-# LANGUAGE ScopedTypeVariables #-}
-module GC
- ({- dont export generic versions for high performance ;-) -}) where
+module Mate.GC
+ ( RefObj(..), PrintableRef(..), traverseIO, markTree'', patchAllRefs
+ {- dont export generic versions for high performance -> remove for production -}) where
import Control.Monad
-
---import Data.Foldable hiding (mapM_)
-
-import Foreign.Ptr
-import Foreign.Marshal.Alloc
-import Foreign.Marshal.Array
-import Foreign.Storable
-import GHC.Int
-
import qualified Data.Set as S
-import Text.Printf
-class (Eq a, Ord a) => RefObj a where
+import Foreign.Ptr (IntPtr, Ptr)
+
+class (Eq a, Ord a, Show a) => RefObj a where
+
payload :: a -> IO IntPtr
- refs :: a -> IO [a]
+ size :: a -> IO Int
+ cast :: Ptr b -> a
+
+ refs :: a -> IO [a]
+ patchRefs :: a -> [a] -> IO ()
+ newRef :: a -> a -> IO ()
+ getNewRef :: a -> IO a
+
marked :: a -> IO Bool
mark :: a -> IO ()
unmark :: a -> IO ()
-
--- TODO hs: wtf? i am failing to create a printable class with superclass refobj??
---class RefObj a => PrintableRefObj a where
--- printRef :: a -> IO ()
+
class PrintableRef a where
printRef :: a -> IO ()
-instance RefObj (Ptr a) where
- payload = return . ptrToIntPtr
- refs = unpackRefs . castPtr
- marked = markedRef
- mark = markRef (0x1::Int32)
- unmark = markRef (0x0::Int32)
-
-instance PrintableRef (Ptr a) where
- printRef = printRef'
-
-
-idOff = 0x0
-numberOfObjsOff = 0x4
-fieldsOff = 0xC
-markedOff = 0x8
-
-unpackRefs :: Ptr Int32 -> IO [Ptr b]
-unpackRefs ptr = do --dereference number of objs; mark field skipped via fieldsOffset
- numberOfObjs <- peekByteOff ptr numberOfObjsOff :: IO Int32
- mapM (peekElemOff (ptr `plusPtr` fieldsOff)) [0..fromIntegral $ numberOfObjs-1]
-
-markedRef :: Ptr a -> IO Bool
-markedRef ptr = liftM ((/=0) . fromIntegral) (peekByteOff ptr markedOff :: IO Int32)
-
-markRef :: Int32 -> Ptr a -> IO ()
-markRef val ptr = pokeByteOff ptr markedOff val
-
-printRef' :: Ptr a -> IO ()
-printRef' ptr = do printf "obj 0x%08x\n" =<< (peekByteOff ptr idOff :: IO Int32)
- printf "children 0x%08x\n" =<< (peekByteOff ptr numberOfObjsOff :: IO Int32)
- printf "marked 0x%08x\n\n" =<< (peekByteOff ptr markedOff :: IO Int32)
-
-- | Generically marks a graph (can be used to set mark bit and reset mark bit at the same time
-- using customized loopcheck and marker funcs (i.e. to set the bit check on ==1 and on ==0 otherwise)
-- Furthermore it produces a list of visited nodes (this can be all live one (or dead on respectively)
markTree root = marked root >>= (`unless` continue)
where continue = mark root >> refs root >>= mapM_ markTree
-printTree :: Ptr a -> IO ()
-printTree = traverseIO printRef'
-
-emptyObj id = do mem <- mallocBytes 0xC
- pokeArray mem [id,0,0::Int32]
- return mem
+-- | This object is alive. so its children are alive. patch child references to point
+-- to childrens new references
+patchRefsObj :: (RefObj a) => a -> IO ()
+patchRefsObj obj = do obj' <- getNewRef obj
+ fields <- refs obj
+ newRefs <- mapM getNewRef fields
+ print newRefs
+ patchRefs obj' newRefs
-twoRefs = do mem <- mallocBytes 0x14
- -- idOfObj; numberofObj; marked waste memory Int32
- pokeArray mem [0::Int32,2,0]
- obj1 <- emptyObj 1
- obj2 <- emptyObj 2
- pokeByteOff mem 0xC obj1
- pokeByteOff mem 0x10 obj2
- return mem
+patchAllRefs :: (RefObj a) => [a] -> IO ()
+patchAllRefs = mapM_ patchRefsObj
-cyclR = do mem <- mallocBytes 0x18
- pokeArray mem [0::Int32,3,0]
- obj1 <- emptyObj 1
- obj2 <- emptyObj 2
- pokeByteOff mem 0xC obj1
- pokeByteOff mem 0x10 obj2
- pokeByteOff mem 0x14 mem
- return mem
-test objr = do twoRefs <- objr
- putStrLn "initial:\n"
- printTree twoRefs
- lifeRefs <- markTree'' marked mark [] twoRefs
- putStrLn "life refs: \n"
- print lifeRefs
- --forM lifeRefs printRef'
- putStrLn "after marking\n"
- printTree twoRefs
- markTree'' (liftM not . marked) unmark [] twoRefs
- putStrLn "after unmarking\n"
- printTree twoRefs