Mate/Tests/MockRefs.hs

   1 module Mate.Tests.MockRefs where
   2
   3 import Mate.GC
   4 import Mate.MemoryManager
   5
   6 import Foreign.Ptr
   7 import Foreign.Marshal.Alloc
   8 import Foreign.Marshal.Array
   9 import Foreign.Storable
  10 import GHC.Int
  11 import Text.Printf
  12
  13 import Control.Monad
  14
  15 instance RefObj (Ptr a) where
  16   payload     = return . ptrToIntPtr
  17   size a      = fmap ((+ fieldsOff) . length) (refs a)
  18   refs        = unpackRefs . castPtr
  19   marked      = markedRef
  20   mark        = markRef (0x1::Int32)
  21   unmark      = markRef (0x0::Int32)
  22   newRef      = newRefPtr
  23   patchRefs   = patchRefsPtr
  24   cast = castPtr
  25   getNewRef ptr = peekByteOff ptr newRefOff
  26
  27 instance PrintableRef (Ptr a) where
  28   printRef    = printRef'
  29
  30
  31 idOff           = 0x0
  32 numberOfObjsOff = 0x4
  33 markedOff = 0x8
  34 newRefOff = 0xC
  35 fieldsOff = 0x10
  36
  37 unpackRefs :: Ptr Int32 -> IO [Ptr b]
  38 unpackRefs ptr = do  --dereference number of objs; mark field skipped via fieldsOffset
  39                     numberOfObjs <- peekByteOff ptr numberOfObjsOff :: IO Int32
  40                     mapM (peekElemOff (ptr `plusPtr` fieldsOff)) [0..fromIntegral $ numberOfObjs-1]
  41
  42 markedRef :: Ptr a -> IO Bool
  43 markedRef ptr = liftM ((/=0) . fromIntegral) (peekByteOff ptr markedOff :: IO Int32)
  44
  45 markRef :: Int32 -> Ptr a -> IO ()
  46 markRef val ptr = pokeByteOff ptr markedOff val
  47
  48 newRefPtr :: Ptr a -> Ptr a -> IO ()
  49 newRefPtr ptr newPtr = pokeByteOff ptr newRefOff newPtr
  50
  51 patchRefsPtr :: Ptr a -> [Ptr a] -> IO ()
  52 patchRefsPtr ptr xs = pokeArray (ptr `plusPtr` fieldsOff) xs
  53
  54 printRef' :: Ptr a -> IO ()
  55 printRef' ptr = do printf "obj 0x%08x\n" =<< (peekByteOff ptr idOff :: IO Int32)
  56                    printf "children 0x%08x\n" =<< (peekByteOff ptr numberOfObjsOff :: IO Int32)
  57                    printf "marked 0x%08x\n" =<< (peekByteOff ptr markedOff :: IO Int32)
  58                    printf "payload 0x%08x\n" =<< ((liftM fromIntegral (payload ptr)) :: IO Int32)
  59                    printf "newRef 0x%08x\n" =<< (peekByteOff ptr newRefOff :: IO Int32)
  60                    printChildren ptr
  61                    putStrLn ""
  62
  63 printChildren :: Ptr a -> IO ()
  64 printChildren ptr = do children <- refs ptr
  65                        putStrLn $ "children" ++ (show children)
  66
  67
  68 printTree :: Ptr a -> IO ()
  69 printTree = traverseIO printRef'
  70
  71 emptyObj id  = do mem <- mallocBytes 0x10
  72                   putStrLn $ "my memory: "  ++ show mem
  73                   let self = fromIntegral (ptrToIntPtr mem)
  74                   pokeArray mem [0,0,0::Int32,0]
  75                   return mem
  76
  77 twoRefs = do mem <- mallocBytes 0x18
  78              -- idOfObj; numberofObj; marked waste memory Int32
  79              pokeArray mem [0::Int32,2,0,0]
  80              obj1 <- emptyObj 1
  81              obj2 <- emptyObj 2
  82              pokeByteOff mem 0x10 obj1
  83              pokeByteOff mem 0x14 obj2
  84              return mem
  85
  86 cyclR = do mem <- mallocBytes 0x1C
  87            pokeArray mem [0::Int32,3,0,0]
  88            obj1 <- emptyObj 1
  89            obj2 <- emptyObj 2
  90            pokeByteOff mem 0x10 obj1
  91            pokeByteOff mem 0x14 obj2
  92            pokeByteOff mem 0x18 mem
  93            return mem
  94
  95 test objr = do twoRefs <- objr
  96                putStrLn "initial:\n"
  97                printTree twoRefs
  98                lifeRefs <- markTree'' marked mark [] twoRefs
  99                putStrLn "life refs: \n"
 100                print lifeRefs
 101                --forM lifeRefs printRef'
 102                putStrLn "after marking\n"
 103                printTree twoRefs
 104                markTree'' (liftM not . marked) unmark [] twoRefs
 105                putStrLn "after unmarking\n"
 106                printTree twoRefs
 107
 108 {-
 109 patchAllRefs :: (RefObj a) => a -> IO a
 110 patchAllRefs obj = do markTree'' patchAndCheckMark unmark [] obj
 111                       getNewRef obj
 112  where patchAndCheckMark :: a -> IO Bool
 113        patchAndCheckMark a = undefined
 114 -}
 115
 116 testEvacuation objr = do ref <- objr
 117                          lifeRefs <- markTree'' marked mark [] ref
 118                          putStrLn "initial objectTree"
 119                          printTree ref
 120                          memoryManager <- initTwoSpace 0x10000
 121                          evacuateList lifeRefs memoryManager
 122                          print lifeRefs
 123                          putStrLn "oldObjectTree: "
 124                          printTree ref
 125                          patchAllRefs lifeRefs
 126                          newRef <- getNewRef ref
 127                          putStrLn "resulting objectTree"
 128                          printTree newRef
 129
 130