1 {-# LANGUAGE ScopedTypeVariables #-}
4 {- dont export generic versions for high performance -> remove for production -}) where
9 import Foreign.Marshal.Alloc
10 import Foreign.Marshal.Array
11 import Foreign.Storable
14 import qualified Data.Set as S
17 class (Eq a, Ord a) => RefObj a where
19 payload :: a -> IO IntPtr
22 patchRefs :: a -> [a] -> IO ()
23 newRef :: a -> a -> IO ()
25 marked :: a -> IO Bool
31 class PrintableRef a where
32 printRef :: a -> IO ()
34 instance RefObj (Ptr a) where
35 payload = return . ptrToIntPtr
36 refs = unpackRefs . castPtr
38 mark = markRef (0x1::Int32)
39 unmark = markRef (0x0::Int32)
44 instance PrintableRef (Ptr a) where
54 unpackRefs :: Ptr Int32 -> IO [Ptr b]
55 unpackRefs ptr = do --dereference number of objs; mark field skipped via fieldsOffset
56 numberOfObjs <- peekByteOff ptr numberOfObjsOff :: IO Int32
57 mapM (peekElemOff (ptr `plusPtr` fieldsOff)) [0..fromIntegral $ numberOfObjs-1]
59 markedRef :: Ptr a -> IO Bool
60 markedRef ptr = liftM ((/=0) . fromIntegral) (peekByteOff ptr markedOff :: IO Int32)
62 markRef :: Int32 -> Ptr a -> IO ()
63 markRef val ptr = pokeByteOff ptr markedOff val
65 newRefPtr :: Ptr a -> Ptr a -> IO ()
66 newRefPtr ptr newRef = pokeByteOff ptr newRefOff newRef
68 printRef' :: Ptr a -> IO ()
69 printRef' ptr = do printf "obj 0x%08x\n" =<< (peekByteOff ptr idOff :: IO Int32)
70 printf "children 0x%08x\n" =<< (peekByteOff ptr numberOfObjsOff :: IO Int32)
71 printf "marked 0x%08x\n" =<< (peekByteOff ptr markedOff :: IO Int32)
72 printf "newRef 0x%08x\n\n" =<< (peekByteOff ptr newRefOff :: IO Int32)
74 -- | Generically marks a graph (can be used to set mark bit and reset mark bit at the same time
75 -- using customized loopcheck and marker funcs (i.e. to set the bit check on ==1 and on ==0 otherwise)
76 -- Furthermore it produces a list of visited nodes (this can be all live one (or dead on respectively)
77 markTree'' :: RefObj a => (a -> IO Bool) -> (a -> IO ()) -> [a] -> a -> IO [a]
78 markTree'' loopcheck marker ws root = do loop <- loopcheck root
79 if loop then return ws else liftM (root :) continue
80 where continue = marker root >> refs root >>= foldM (markTree'' loopcheck marker) ws
82 -- | For debugging only (implements custom loop check with Data.Set!)
83 traverseIO :: RefObj o => (o -> IO ()) -> o -> IO ()
84 traverseIO f = void . traverseIO' f S.empty
86 traverseIO' :: RefObj a => (a -> IO ()) -> S.Set a -> a -> IO (S.Set a)
87 traverseIO' f ws root = if S.member root ws then f root >> return ws
88 else f root >> refs root >>= cont
89 where cont = foldM (\ws x -> do let ws' = S.insert x ws
90 traverseIO' f ws' x) ws'
91 ws' = S.insert root ws
93 markTree :: RefObj a => a -> IO ()
94 markTree root = marked root >>= (`unless` continue)
95 where continue = mark root >> refs root >>= mapM_ markTree
97 printTree :: Ptr a -> IO ()
98 printTree = traverseIO printRef'
101 emptyObj id = do mem <- mallocBytes 0x10
102 pokeArray mem [id,0,0::Int32,0]
105 twoRefs = do mem <- mallocBytes 0x18
106 -- idOfObj; numberofObj; marked waste memory Int32
107 pokeArray mem [0::Int32,2,0,0]
110 pokeByteOff mem 0x10 obj1
111 pokeByteOff mem 0x14 obj2
114 cyclR = do mem <- mallocBytes 0x1C
115 pokeArray mem [0::Int32,3,0,0]
118 pokeByteOff mem 0x10 obj1
119 pokeByteOff mem 0x14 obj2
120 pokeByteOff mem 0x18 mem
123 test objr = do twoRefs <- objr
124 putStrLn "initial:\n"
126 lifeRefs <- markTree'' marked mark [] twoRefs
127 putStrLn "life refs: \n"
129 --forM lifeRefs printRef'
130 putStrLn "after marking\n"
132 markTree'' (liftM not . marked) unmark [] twoRefs
133 putStrLn "after unmarking\n"