Mate/GC.hs

   1 {-# LANGUAGE ScopedTypeVariables #-}
   2 module Mate.GC
   3   ( RefObj
   4     {- dont export generic versions for high performance -> remove for production -}) where
   5
   6 import Control.Monad
   7
   8 import Foreign.Ptr
   9 import Foreign.Marshal.Alloc
  10 import Foreign.Marshal.Array
  11 import Foreign.Storable
  12 import GHC.Int
  13
  14 import qualified Data.Set as S
  15 import Text.Printf
  16
  17 class (Eq a, Ord a) => RefObj a where
  18
  19   payload :: a -> IO IntPtr
  20
  21   refs      :: a -> IO [a]
  22   patchRefs :: a -> [a] -> IO ()
  23   newRef    :: a -> a -> IO ()
  24
  25   marked  :: a -> IO Bool
  26   mark    :: a -> IO ()
  27   unmark  :: a -> IO ()
  28
  29   copy :: a -> IO a
  30
  31 class PrintableRef a where
  32   printRef :: a -> IO ()
  33
  34 instance RefObj (Ptr a) where
  35   payload     = return . ptrToIntPtr
  36   refs        = unpackRefs . castPtr
  37   marked      = markedRef
  38   mark        = markRef (0x1::Int32)
  39   unmark      = markRef (0x0::Int32)
  40   newRef      = newRefPtr
  41   patchRefs   = undefined
  42   copy = undefined
  43
  44 instance PrintableRef (Ptr a) where
  45   printRef    = printRef'
  46
  47
  48 idOff           = 0x0
  49 numberOfObjsOff = 0x4
  50 markedOff = 0x8
  51 newRefOff = 0xC
  52 fieldsOff = 0x10
  53
  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]
  58
  59 markedRef :: Ptr a -> IO Bool
  60 markedRef ptr = liftM ((/=0) . fromIntegral) (peekByteOff ptr markedOff :: IO Int32)
  61
  62 markRef :: Int32 -> Ptr a -> IO ()
  63 markRef val ptr = pokeByteOff ptr markedOff val
  64
  65 newRefPtr :: Ptr a -> Ptr a -> IO ()
  66 newRefPtr ptr newRef = pokeByteOff ptr newRefOff newRef
  67
  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)
  73
  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
  81
  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
  85
  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
  92
  93 markTree :: RefObj a => a -> IO ()
  94 markTree root = marked root >>= (`unless` continue)
  95   where continue = mark root >> refs root >>= mapM_  markTree
  96
  97 printTree :: Ptr a -> IO ()
  98 printTree = traverseIO printRef'
  99
 100
 101 emptyObj id  = do mem <- mallocBytes 0x10
 102                   pokeArray mem [id,0,0::Int32,0]
 103                   return mem
 104
 105 twoRefs = do mem <- mallocBytes 0x18
 106              -- idOfObj; numberofObj; marked waste memory Int32
 107              pokeArray mem [0::Int32,2,0,0]
 108              obj1 <- emptyObj 1
 109              obj2 <- emptyObj 2
 110              pokeByteOff mem 0x10 obj1
 111              pokeByteOff mem 0x14 obj2
 112              return mem
 113
 114 cyclR = do mem <- mallocBytes 0x1C
 115            pokeArray mem [0::Int32,3,0,0]
 116            obj1 <- emptyObj 1
 117            obj2 <- emptyObj 2
 118            pokeByteOff mem 0x10 obj1
 119            pokeByteOff mem 0x14 obj2
 120            pokeByteOff mem 0x18 mem
 121            return mem
 122
 123 test objr = do twoRefs <- objr
 124                putStrLn "initial:\n"
 125                printTree twoRefs
 126                lifeRefs <- markTree'' marked mark [] twoRefs
 127                putStrLn "life refs: \n"
 128                print lifeRefs
 129                --forM lifeRefs printRef'
 130                putStrLn "after marking\n"
 131                printTree twoRefs
 132                markTree'' (liftM not . marked) unmark [] twoRefs
 133                putStrLn "after unmarking\n"
 134                printTree twoRefs