Mate/GC.hs

   1 {-# LANGUAGE ScopedTypeVariables #-}
   2 module Mate.GC
   3   ( RefObj(..), PrintableRef(..), traverseIO, markTree'', patchAllRefs
   4     {- dont export generic versions for high performance -> remove for production -}) where
   5
   6 import Control.Monad
   7 import qualified Data.Set as S
   8
   9 import Foreign.Ptr (IntPtr, Ptr)
  10
  11 class (Eq a, Ord a, Show a) => RefObj a where
  12
  13   payload :: a -> IO IntPtr
  14   size    :: a -> IO Int
  15   cast    :: Ptr b -> a
  16
  17   refs      :: a -> IO [a]
  18   patchRefs :: a -> [a] -> IO ()
  19   newRef    :: a -> a -> IO ()
  20   getNewRef :: a -> IO a
  21
  22   marked  :: a -> IO Bool
  23   mark    :: a -> IO ()
  24   unmark  :: a -> IO ()
  25
  26
  27 class PrintableRef a where
  28   printRef :: a -> IO ()
  29
  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
  37
  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
  41
  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
  48
  49 markTree :: RefObj a => a -> IO ()
  50 markTree root = marked root >>= (`unless` continue)
  51   where continue = mark root >> refs root >>= mapM_  markTree
  52
  53
  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
  58                       fields <- refs obj
  59                       newRefs <- mapM getNewRef fields
  60                       print newRefs
  61                       patchRefs obj' newRefs
  62
  63 patchAllRefs :: (RefObj a) => [a] -> IO ()
  64 patchAllRefs = mapM_ patchRefsObj
  65
  66