1 {-# LANGUAGE ScopedTypeVariables #-}
3 ( RefObj(..), PrintableRef(..), traverseIO, markTree'', patchAllRefs
4 {- dont export generic versions for high performance -> remove for production -}) where
7 import qualified Data.Set as S
9 import Foreign.Ptr (IntPtr, Ptr)
11 class (Eq a, Ord a, Show a) => RefObj a where
13 payload :: a -> IO IntPtr
18 patchRefs :: a -> [a] -> IO ()
19 setNewRef :: a -> a -> IO ()
20 getNewRef :: a -> IO a
22 marked :: a -> IO Bool
27 class PrintableRef a where
28 printRef :: a -> IO ()
30 -- | Generically marks a graph (can be used to set mark bit and reset mark bit at the same time
31 -- using customized loopcheck and marker funcs (i.e. to set the bit check on ==1 and on ==0 otherwise)
32 -- Furthermore it produces a list of visited nodes (this can be all live one (or dead on respectively)
33 markTree'' :: RefObj a => (a -> IO Bool) -> (a -> IO ()) -> [a] -> a -> IO [a]
34 markTree'' loopcheck marker ws root = do loop <- loopcheck root
35 if loop then return ws else liftM (root :) continue
36 where continue = marker root >> refs root >>= foldM (markTree'' loopcheck marker) ws
38 -- | For debugging only (implements custom loop check with Data.Set!)
39 traverseIO :: RefObj o => (o -> IO ()) -> o -> IO ()
40 traverseIO f = void . traverseIO' f S.empty
42 traverseIO' :: RefObj a => (a -> IO ()) -> S.Set a -> a -> IO (S.Set a)
43 traverseIO' f ws root = if S.member root ws then f root >> return ws
44 else f root >> refs root >>= cont
45 where cont = foldM (\ws x -> do let ws' = S.insert x ws
46 traverseIO' f ws' x) ws'
47 ws' = S.insert root ws
49 markTree :: RefObj a => a -> IO ()
50 markTree root = marked root >>= (`unless` continue)
51 where continue = mark root >> refs root >>= mapM_ markTree
54 -- | This object is alive. so its children are alive. patch child references to point
55 -- to childrens new references
56 patchRefsObj :: (RefObj a) => a -> IO ()
57 patchRefsObj obj = do obj' <- getNewRef obj
59 newRefs <- mapM getNewRef fields
61 patchRefs obj' newRefs
63 patchAllRefs :: (RefObj a) => [a] -> IO ()
64 patchAllRefs = mapM_ patchRefsObj