1 {-# LANGUAGE ScopedTypeVariables #-}
3 ({- dont export generic versions for high performance ;-) -}) where
7 --import Data.Foldable hiding (mapM_)
10 import Foreign.Marshal.Alloc
11 import Foreign.Marshal.Array
12 import Foreign.Storable
15 import qualified Data.Set as S
18 class (Eq a, Ord a) => RefObj a where
19 payload :: a -> IO IntPtr
21 marked :: a -> IO Bool
25 -- TODO hs: wtf? i am failing to create a printable class with superclass refobj??
26 --class RefObj a => PrintableRefObj a where
27 -- printRef :: a -> IO ()
29 class PrintableRef a where
30 printRef :: a -> IO ()
32 instance RefObj (Ptr a) where
33 payload = return . ptrToIntPtr
34 refs = unpackRefs . castPtr
36 mark = markRef (0x1::Int32)
37 unmark = markRef (0x0::Int32)
39 instance PrintableRef (Ptr a) where
48 unpackRefs :: Ptr Int32 -> IO [Ptr b]
49 unpackRefs ptr = do --dereference number of objs; mark field skipped via fieldsOffset
50 numberOfObjs <- peekByteOff ptr numberOfObjsOff :: IO Int32
51 mapM (peekElemOff (ptr `plusPtr` fieldsOff)) [0..fromIntegral $ numberOfObjs-1]
53 markedRef :: Ptr a -> IO Bool
54 markedRef ptr = liftM ((/=0) . fromIntegral) (peekByteOff ptr markedOff :: IO Int32)
56 markRef :: Int32 -> Ptr a -> IO ()
57 markRef val ptr = pokeByteOff ptr markedOff val
59 printRef' :: Ptr a -> IO ()
60 printRef' ptr = do printf "obj 0x%08x\n" =<< (peekByteOff ptr idOff :: IO Int32)
61 printf "children 0x%08x\n" =<< (peekByteOff ptr numberOfObjsOff :: IO Int32)
62 printf "marked 0x%08x\n\n" =<< (peekByteOff ptr markedOff :: IO Int32)
64 -- | Generically marks a graph (can be used to set mark bit and reset mark bit at the same time
65 -- using customized loopcheck and marker funcs (i.e. to set the bit check on ==1 and on ==0 otherwise)
66 -- Furthermore it produces a list of visited nodes (this can be all live one (or dead on respectively)
67 markTree'' :: RefObj a => (a -> IO Bool) -> (a -> IO ()) -> [a] -> a -> IO [a]
68 markTree'' loopcheck marker ws root = do loop <- loopcheck root
69 if loop then return ws else liftM (root :) continue
70 where continue = marker root >> refs root >>= foldM (markTree'' loopcheck marker) ws
72 -- | For debugging only (implements custom loop check with Data.Set!)
73 traverseIO :: RefObj o => (o -> IO ()) -> o -> IO ()
74 traverseIO f = void . traverseIO' f S.empty
76 traverseIO' :: RefObj a => (a -> IO ()) -> S.Set a -> a -> IO (S.Set a)
77 traverseIO' f ws root = if S.member root ws then f root >> return ws
78 else f root >> refs root >>= cont
79 where cont = foldM (\ws x -> do let ws' = S.insert x ws
80 traverseIO' f ws' x) ws'
81 ws' = S.insert root ws
83 markTree :: RefObj a => a -> IO ()
84 markTree root = marked root >>= (`unless` continue)
85 where continue = mark root >> refs root >>= mapM_ markTree
87 printTree :: Ptr a -> IO ()
88 printTree = traverseIO printRef'
91 emptyObj id = do mem <- mallocBytes 0xC
92 pokeArray mem [id,0,0::Int32]
95 twoRefs = do mem <- mallocBytes 0x14
96 -- idOfObj; numberofObj; marked waste memory Int32
97 pokeArray mem [0::Int32,2,0]
100 pokeByteOff mem 0xC obj1
101 pokeByteOff mem 0x10 obj2
104 cyclR = do mem <- mallocBytes 0x18
105 pokeArray mem [0::Int32,3,0]
108 pokeByteOff mem 0xC obj1
109 pokeByteOff mem 0x10 obj2
110 pokeByteOff mem 0x14 mem
113 test objr = do twoRefs <- objr
114 putStrLn "initial:\n"
116 lifeRefs <- markTree'' marked mark [] twoRefs
117 putStrLn "life refs: \n"
119 --forM lifeRefs printRef'
120 putStrLn "after marking\n"
122 markTree'' (liftM not . marked) unmark [] twoRefs
123 putStrLn "after unmarking\n"