scratch/GC: progress with data structures and traversals

diff --git a/scratch/GC.hs b/scratch/GC.hs
index d2bece279834a70f20f694239f18de856bcdb1cd..9781d207183332f517a3cea430aaf871d9cf6c83 100644 (file)
--- a/scratch/GC.hs
+++ b/scratch/GC.hs
@@ -4,7 +4,7 @@ module GC
 
 import Control.Monad
 
-import Data.Foldable hiding (mapM_)
+--import Data.Foldable hiding (mapM_)
 
 import Foreign.Ptr
 import Foreign.Marshal.Alloc
@@ -12,19 +12,32 @@ import Foreign.Marshal.Array
 import Foreign.Storable
 import GHC.Int
 
+import qualified Data.Set as S
+import Text.Printf
 
-class RefObj a where
+class (Eq a, Ord a) => RefObj a where
   payload :: a -> IO IntPtr
   refs    :: 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
+  mark        = markRef (0x1::Int32)
+  unmark      = markRef (0x0::Int32)
+
+instance PrintableRef (Ptr a) where
+  printRef    = printRef'
 
 
 idOff           = 0x0
@@ -40,13 +53,40 @@ unpackRefs ptr = do  --dereference number of objs; mark field skipped via fields
 markedRef :: Ptr a -> IO Bool
 markedRef ptr = liftM ((/=0) . fromIntegral) (peekByteOff ptr markedOff :: IO Int32)
 
-markRef :: Ptr a -> IO ()
-markRef ptr = pokeByteOff ptr markedOff (1::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'' :: RefObj a => (a -> IO Bool) -> (a -> IO ()) -> [a] -> a -> IO [a]
+markTree'' loopcheck marker ws root = do loop <- loopcheck root
+                                         if loop then return ws else liftM (root :) continue
+    where continue = marker root >> refs root >>= foldM (markTree'' loopcheck marker) ws
+
+-- | For debugging only (implements custom loop check with Data.Set!)
+traverseIO :: RefObj o => (o -> IO ()) -> o -> IO ()
+traverseIO f = void . traverseIO' f S.empty
+
+traverseIO' ::  RefObj a => (a -> IO ()) -> S.Set a -> a -> IO (S.Set a)
+traverseIO' f ws root = if S.member root ws then f root >> return ws
+                           else f root >> refs root >>= cont
+  where cont = foldM (\ws x -> do let ws' = S.insert x ws
+                                  traverseIO' f ws' x) ws'
+        ws' = S.insert root ws
 
 markTree :: RefObj a => a -> IO ()
-markTree root = marked root >>= (`when` continue) . not
+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]
@@ -58,7 +98,27 @@ twoRefs = do mem <- mallocBytes 0x14
              obj1 <- emptyObj 1
              obj2 <- emptyObj 2
              pokeByteOff mem 0xC obj1
-             pokeByteOff mem (0xC+0x4) obj2
+             pokeByteOff mem 0x10 obj2
              return mem
 
-
+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

diff --git a/scratch/MemoryManager.hs b/scratch/MemoryManager.hs
new file mode 100644 (file)
index 0000000..05e69d0
--- /dev/null
+++ b/scratch/MemoryManager.hs
@@ -0,0 +1,16 @@
+module MemoryManager ( ) where
+
+import qualified Foreign.Marshal.Alloc as Alloc
+import Foreign.Ptr
+import Foreign.Storable
+
+class AllocationManager a where
+  mallocBytes :: a -> Int -> (a,Ptr b)
+
+data TwoSpace = TwoSpace { basePtrA :: IntPtr, basePtrB :: IntPtr, heapPtrA :: IntPtr, heapPtrB :: IntPtr }
+
+instance AllocationManager TwoSpace where
+  mallocBytes = mallocBytes'
+
+mallocBytes' :: TwoSpace -> Int -> (TwoSpace, Ptr a)
+mallocBytes' = undefined