scratch/GC.hs

   1 {-# LANGUAGE ScopedTypeVariables #-}
   2 module GC
   3   ({- dont export generic versions for high performance ;-) -}) where
   4
   5 import Control.Monad
   6
   7 --import Data.Foldable hiding (mapM_)
   8
   9 import Foreign.Ptr
  10 import Foreign.Marshal.Alloc
  11 import Foreign.Marshal.Array
  12 import Foreign.Storable
  13 import GHC.Int
  14
  15 import qualified Data.Set as S
  16 import Text.Printf
  17
  18 class (Eq a, Ord a) => RefObj a where
  19   payload :: a -> IO IntPtr
  20   refs    :: a -> IO [a]
  21   marked  :: a -> IO Bool
  22   mark    :: a -> IO ()
  23   unmark  :: a -> IO ()
  24
  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 ()
  28
  29 class PrintableRef a where
  30   printRef :: a -> IO ()
  31
  32 instance RefObj (Ptr a) where
  33   payload     = return . ptrToIntPtr
  34   refs        = unpackRefs . castPtr
  35   marked      = markedRef
  36   mark        = markRef (0x1::Int32)
  37   unmark      = markRef (0x0::Int32)
  38
  39 instance PrintableRef (Ptr a) where
  40   printRef    = printRef'
  41
  42
  43 idOff           = 0x0
  44 numberOfObjsOff = 0x4
  45 fieldsOff = 0xC
  46 markedOff = 0x8
  47
  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]
  52
  53 markedRef :: Ptr a -> IO Bool
  54 markedRef ptr = liftM ((/=0) . fromIntegral) (peekByteOff ptr markedOff :: IO Int32)
  55
  56 markRef :: Int32 -> Ptr a -> IO ()
  57 markRef val ptr = pokeByteOff ptr markedOff val
  58
  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)
  63
  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
  71
  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
  75
  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
  82
  83 markTree :: RefObj a => a -> IO ()
  84 markTree root = marked root >>= (`unless` continue)
  85   where continue = mark root >> refs root >>= mapM_  markTree
  86
  87 printTree :: Ptr a -> IO ()
  88 printTree = traverseIO printRef'
  89
  90
  91 emptyObj id  = do mem <- mallocBytes 0xC
  92                   pokeArray mem [id,0,0::Int32]
  93                   return mem
  94
  95 twoRefs = do mem <- mallocBytes 0x14
  96              -- idOfObj; numberofObj; marked waste memory Int32
  97              pokeArray mem [0::Int32,2,0]
  98              obj1 <- emptyObj 1
  99              obj2 <- emptyObj 2
 100              pokeByteOff mem 0xC obj1
 101              pokeByteOff mem 0x10 obj2
 102              return mem
 103
 104 cyclR = do mem <- mallocBytes 0x18
 105            pokeArray mem [0::Int32,3,0]
 106            obj1 <- emptyObj 1
 107            obj2 <- emptyObj 2
 108            pokeByteOff mem 0xC obj1
 109            pokeByteOff mem 0x10 obj2
 110            pokeByteOff mem 0x14 mem
 111            return mem
 112
 113 test objr = do twoRefs <- objr
 114                putStrLn "initial:\n"
 115                printTree twoRefs
 116                lifeRefs <- markTree'' marked mark [] twoRefs
 117                putStrLn "life refs: \n"
 118                print lifeRefs
 119                --forM lifeRefs printRef'
 120                putStrLn "after marking\n"
 121                printTree twoRefs
 122                markTree'' (liftM not . marked) unmark [] twoRefs
 123                putStrLn "after unmarking\n"
 124                printTree twoRefs