Mate/Tests/MockRefs.hs

   1 module Mate.Tests.MockRefs where
   2
   3 import Mate.GC
   4
   5 import Foreign.Ptr
   6 import Foreign.Marshal.Alloc
   7 import Foreign.Marshal.Array
   8 import Foreign.Storable
   9 import GHC.Int
  10 import Text.Printf
  11
  12 import Control.Monad
  13
  14 instance RefObj (Ptr a) where
  15   payload     = return . ptrToIntPtr
  16   refs        = unpackRefs . castPtr
  17   marked      = markedRef
  18   mark        = markRef (0x1::Int32)
  19   unmark      = markRef (0x0::Int32)
  20   newRef      = newRefPtr
  21   patchRefs   = undefined
  22   copy = undefined
  23
  24 instance PrintableRef (Ptr a) where
  25   printRef    = printRef'
  26
  27
  28 idOff           = 0x0
  29 numberOfObjsOff = 0x4
  30 markedOff = 0x8
  31 newRefOff = 0xC
  32 fieldsOff = 0x10
  33
  34 unpackRefs :: Ptr Int32 -> IO [Ptr b]
  35 unpackRefs ptr = do  --dereference number of objs; mark field skipped via fieldsOffset
  36                     numberOfObjs <- peekByteOff ptr numberOfObjsOff :: IO Int32
  37                     mapM (peekElemOff (ptr `plusPtr` fieldsOff)) [0..fromIntegral $ numberOfObjs-1]
  38
  39 markedRef :: Ptr a -> IO Bool
  40 markedRef ptr = liftM ((/=0) . fromIntegral) (peekByteOff ptr markedOff :: IO Int32)
  41
  42 markRef :: Int32 -> Ptr a -> IO ()
  43 markRef val ptr = pokeByteOff ptr markedOff val
  44
  45 newRefPtr :: Ptr a -> Ptr a -> IO ()
  46 newRefPtr ptr newRef = pokeByteOff ptr newRefOff newRef
  47
  48 printRef' :: Ptr a -> IO ()
  49 printRef' ptr = do printf "obj 0x%08x\n" =<< (peekByteOff ptr idOff :: IO Int32)
  50                    printf "children 0x%08x\n" =<< (peekByteOff ptr numberOfObjsOff :: IO Int32)
  51                    printf "marked 0x%08x\n" =<< (peekByteOff ptr markedOff :: IO Int32)
  52                    printf "newRef 0x%08x\n\n" =<< (peekByteOff ptr newRefOff :: IO Int32)
  53
  54 printTree :: Ptr a -> IO ()
  55 printTree = traverseIO printRef'
  56
  57 emptyObj id  = do mem <- mallocBytes 0x10
  58                   pokeArray mem [id,0,0::Int32,0]
  59                   return mem
  60
  61 twoRefs = do mem <- mallocBytes 0x18
  62              -- idOfObj; numberofObj; marked waste memory Int32
  63              pokeArray mem [0::Int32,2,0,0]
  64              obj1 <- emptyObj 1
  65              obj2 <- emptyObj 2
  66              pokeByteOff mem 0x10 obj1
  67              pokeByteOff mem 0x14 obj2
  68              return mem
  69
  70 cyclR = do mem <- mallocBytes 0x1C
  71            pokeArray mem [0::Int32,3,0,0]
  72            obj1 <- emptyObj 1
  73            obj2 <- emptyObj 2
  74            pokeByteOff mem 0x10 obj1
  75            pokeByteOff mem 0x14 obj2
  76            pokeByteOff mem 0x18 mem
  77            return mem
  78
  79 test objr = do twoRefs <- objr
  80                putStrLn "initial:\n"
  81                printTree twoRefs
  82                lifeRefs <- markTree'' marked mark [] twoRefs
  83                putStrLn "life refs: \n"
  84                print lifeRefs
  85                --forM lifeRefs printRef'
  86                putStrLn "after marking\n"
  87                printTree twoRefs
  88                markTree'' (liftM not . marked) unmark [] twoRefs
  89                putStrLn "after unmarking\n"
  90                printTree twoRefs