1 module Mate.Tests.MockRefs where
4 import Mate.MemoryManager
7 import Foreign.Marshal.Alloc
8 import Foreign.Marshal.Array
9 import Foreign.Storable
12 import System.IO.Unsafe(unsafePerformIO)
15 import Control.Monad.State
17 import Test.QuickCheck
18 import Test.QuickCheck.Monadic
20 instance RefObj (Ptr a) where
21 payload = return . ptrToIntPtr
22 size a = fmap ((+ fieldsOff) . length) (refs a)
23 refs = unpackRefs . castPtr
25 mark = markRef (0x1::Int32)
26 unmark = markRef (0x0::Int32)
27 setNewRef = setNewRefPtr
28 patchRefs = patchRefsPtr
30 getNewRef ptr = peekByteOff ptr newRefOff
32 instance PrintableRef (Ptr a) where
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]
47 markedRef :: Ptr a -> IO Bool
48 markedRef ptr = liftM ((/=0) . fromIntegral) (peekByteOff ptr markedOff :: IO Int32)
50 markRef :: Int32 -> Ptr a -> IO ()
51 markRef val ptr = pokeByteOff ptr markedOff val
53 setNewRefPtr :: Ptr a -> Ptr a -> IO ()
54 setNewRefPtr ptr = pokeByteOff ptr newRefOff
56 patchRefsPtr :: Ptr a -> [Ptr a] -> IO ()
57 patchRefsPtr ptr = pokeArray (ptr `plusPtr` fieldsOff)
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)
68 printChildren :: Ptr a -> IO ()
69 printChildren ptr = do children <- refs ptr
70 putStrLn $ "children" ++ show children
73 printTree :: Ptr a -> IO ()
74 printTree = traverseIO printRef'
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]
82 twoRefs = do mem <- mallocBytes 0x18
83 -- idOfObj; numberofObj; marked waste memory Int32
84 pokeArray mem [0::Int32,2,0,0]
87 pokeByteOff mem 0x10 obj1
88 pokeByteOff mem 0x14 obj2
91 cyclR = do mem <- mallocBytes 0x1C
92 pokeArray mem [0::Int32,3,0,0]
95 pokeByteOff mem 0x10 obj1
96 pokeByteOff mem 0x14 obj2
97 pokeByteOff mem 0x18 mem
100 test objr = do twoRefs <- objr
101 putStrLn "initial:\n"
103 lifeRefs <- markTree'' marked mark [] twoRefs
104 putStrLn "life refs: \n"
106 --forM lifeRefs printRef'
107 putStrLn "after marking\n"
109 markTree'' (liftM not . marked) unmark [] twoRefs
110 putStrLn "after unmarking\n"
114 patchAllRefs :: (RefObj a) => a -> IO a
115 patchAllRefs obj = do markTree'' patchAndCheckMark unmark [] obj
117 where patchAndCheckMark :: a -> IO Bool
118 patchAndCheckMark a = undefined
121 testEvacuation objr = do ref <- objr
122 lifeRefs <- markTree'' marked mark [] ref
123 putStrLn "initial objectTree"
125 memoryManager <- initTwoSpace 0x10000
126 evacuateList lifeRefs memoryManager
128 putStrLn "oldObjectTree: "
130 patchAllRefs lifeRefs
131 newRef <- getNewRef ref
132 putStrLn "resulting objectTree"
136 createMemoryManager :: Property
137 createMemoryManager = monadicIO $ run f >>= (assert . (==0))
139 f = do twoSpace <- initTwoSpace 0x10000
140 evalStateT heapSize twoSpace
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])
150 data ObjectTree = Node [ObjectTree] deriving Show
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] ] )
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])
168 testObjectTree :: ObjectTree -> Property
169 testObjectTree objTree = monadicIO $ run f >>= (assert . (==0))
171 f = do root <- createObjects objTree
172 twoSpace <- initTwoSpace 0x1000
173 let collection = performCollection [root]
174 runStateT collection twoSpace
175 evalStateT heapSize twoSpace