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 import System.IO.Unsafe(unsafePerformIO)
  13
  14 import Control.Monad
  15 import Control.Monad.State
  16
  17 import Test.QuickCheck
  18 import Test.QuickCheck.Monadic
  19
  20 instance RefObj (Ptr a) where
  21   payload     = return . ptrToIntPtr
  22   size a      = fmap ((+ fieldsOff) . length) (refs a)
  23   refs        = unpackRefs . castPtr
  24   marked      = markedRef
  25   mark        = markRef (0x1::Int32)
  26   unmark      = markRef (0x0::Int32)
  27   setNewRef   = setNewRefPtr
  28   patchRefs   = patchRefsPtr
  29   cast = castPtr
  30   getNewRef ptr = peekByteOff ptr newRefOff
  31
  32 instance PrintableRef (Ptr a) where
  33   printRef    = printRef'
  34
  35
  36 idOff           = 0x0
  37 numberOfObjsOff = 0x4
  38 markedOff = 0x8
  39 newRefOff = 0xC
  40 fieldsOff = 0x10
  41
  42 unpackRefs :: Ptr Int32 -> IO [Ptr b]
  43 unpackRefs ptr = do  --dereference number of objs; mark field skipped via fieldsOffset
  44                     numberOfObjs <- peekByteOff ptr numberOfObjsOff :: IO Int32
  45                     mapM (peekElemOff (ptr `plusPtr` fieldsOff)) [0..fromIntegral $ numberOfObjs-1]
  46
  47 markedRef :: Ptr a -> IO Bool
  48 markedRef ptr = liftM ((/=0) . fromIntegral) (peekByteOff ptr markedOff :: IO Int32)
  49
  50 markRef :: Int32 -> Ptr a -> IO ()
  51 markRef val ptr = pokeByteOff ptr markedOff val
  52
  53 setNewRefPtr :: Ptr a -> Ptr a -> IO ()
  54 setNewRefPtr ptr = pokeByteOff ptr newRefOff
  55
  56 patchRefsPtr :: Ptr a -> [Ptr a] -> IO ()
  57 patchRefsPtr ptr = pokeArray (ptr `plusPtr` fieldsOff)
  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" =<< (peekByteOff ptr markedOff :: IO Int32)
  63                    printf "payload 0x%08x\n" =<< (liftM fromIntegral (payload ptr) :: IO Int32)
  64                    printf "newRef 0x%08x\n" =<< (peekByteOff ptr newRefOff :: IO Int32)
  65                    printChildren ptr
  66                    putStrLn ""
  67
  68 printChildren :: Ptr a -> IO ()
  69 printChildren ptr = do children <- refs ptr
  70                        putStrLn $ "children" ++ show children
  71
  72
  73 printTree :: Ptr a -> IO ()
  74 printTree = traverseIO printRef'
  75
  76 emptyObj id  = do mem <- mallocBytes 0x10
  77                   putStrLn $ "my memory: "  ++ show mem
  78                   let self = fromIntegral (ptrToIntPtr mem)
  79                   pokeArray mem [0,0,0::Int32,0]
  80                   return mem
  81
  82 twoRefs = do mem <- mallocBytes 0x18
  83              -- idOfObj; numberofObj; marked waste memory Int32
  84              pokeArray mem [0::Int32,2,0,0]
  85              obj1 <- emptyObj 1
  86              obj2 <- emptyObj 2
  87              pokeByteOff mem 0x10 obj1
  88              pokeByteOff mem 0x14 obj2
  89              return mem
  90
  91 cyclR = do mem <- mallocBytes 0x1C
  92            pokeArray mem [0::Int32,3,0,0]
  93            obj1 <- emptyObj 1
  94            obj2 <- emptyObj 2
  95            pokeByteOff mem 0x10 obj1
  96            pokeByteOff mem 0x14 obj2
  97            pokeByteOff mem 0x18 mem
  98            return mem
  99
 100 test objr = do twoRefs <- objr
 101                putStrLn "initial:\n"
 102                printTree twoRefs
 103                lifeRefs <- markTree'' marked mark [] twoRefs
 104                putStrLn "life refs: \n"
 105                print lifeRefs
 106                --forM lifeRefs printRef'
 107                putStrLn "after marking\n"
 108                printTree twoRefs
 109                markTree'' (liftM not . marked) unmark [] twoRefs
 110                putStrLn "after unmarking\n"
 111                printTree twoRefs
 112
 113 {-
 114 patchAllRefs :: (RefObj a) => a -> IO a
 115 patchAllRefs obj = do markTree'' patchAndCheckMark unmark [] obj
 116                       getNewRef obj
 117  where patchAndCheckMark :: a -> IO Bool
 118        patchAndCheckMark a = undefined
 119 -}
 120
 121 testEvacuation objr = do ref <- objr
 122                          lifeRefs <- markTree'' marked mark [] ref
 123                          putStrLn "initial objectTree"
 124                          printTree ref
 125                          memoryManager <- initTwoSpace 0x10000
 126                          evacuateList lifeRefs memoryManager
 127                          print lifeRefs
 128                          putStrLn "oldObjectTree: "
 129                          printTree ref
 130                          patchAllRefs lifeRefs
 131                          newRef <- getNewRef ref
 132                          putStrLn "resulting objectTree"
 133                          printTree newRef
 134
 135
 136 createMemoryManager :: Property
 137 createMemoryManager = monadicIO $ run f >>= (assert . (==0))
 138   where f :: IO Int
 139         f = do twoSpace <- initTwoSpace 0x10000
 140                evalStateT heapSize twoSpace
 141
 142
 143 createObject :: Int -> IO (Ptr a)
 144 createObject children = do mem <- mallocBytes (0x10 + 0x4 * children)
 145                            pokeArray mem [0,fromIntegral children,0::Int32,0]
 146                            fields <- replicateM children (createObject 0)
 147                            pokeArray (mem `plusPtr` fieldsOff) (fields :: [Ptr Int32])
 148                            return $ cast mem
 149
 150 data ObjectTree = Node [ObjectTree] deriving Show
 151
 152 instance Arbitrary ObjectTree where
 153   arbitrary = resize 8 ( sized $ \n ->
 154                                      do empty <- choose (0,100) :: Gen Int-- [True,False]
 155                                         if empty < 80 then return $ Node []
 156                                          else do k <- choose (0,n)
 157                                                  liftM Node $ sequence [ arbitrary | _ <- [1..k] ] )
 158
 159 createObjects :: ObjectTree -> IO (Ptr a)
 160 createObjects (Node xs)  = do let children = length xs
 161                               mem <- mallocBytes (0x10 + 0x4 * children)
 162                               pokeArray mem [0,fromIntegral children,0::Int32,0]
 163                               fields <- mapM createObjects xs
 164                               pokeArray (mem `plusPtr` fieldsOff) (fields :: [Ptr Int32])
 165                               return $ cast mem
 166
 167
 168 testObjectTree :: ObjectTree -> Property
 169 testObjectTree objTree = monadicIO $ run f >>= (assert . (==0))
 170   where f :: IO Int
 171         f = do root <- createObjects objTree
 172                twoSpace <- initTwoSpace 0x1000
 173                let collection = performCollection [root]
 174                runStateT collection twoSpace
 175                evalStateT heapSize twoSpace