GC: implemented QuickCheck magic to test GC of huge object trees

diff --git a/Mate/MemoryManager.hs b/Mate/MemoryManager.hs
index c55fb373a289ea75d47b0529abed788e519ea299..1665d20f1fefe7a2a5efabac12e2da67b7f4c962 100644 (file)
--- a/Mate/MemoryManager.hs
+++ b/Mate/MemoryManager.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE ExistentialQuantification #-}
-module Mate.MemoryManager (evacuateList, AllocationManager, 
+module Mate.MemoryManager (evacuateList, AllocationManager(heapSize, performCollection), 
                            TwoSpace, initTwoSpace) where
 
 import qualified Foreign.Marshal.Alloc as Alloc
@@ -21,6 +21,8 @@ class AllocationManager a where
   -- | performs full gc and which is reflected in mem managers state
   performCollection :: (RefObj b) => [b] ->  StateT a IO ()
 
+  heapSize :: StateT a IO Int
+
 data TwoSpace = TwoSpace { fromBase :: IntPtr, 
                            toBase   :: IntPtr, 
                            fromHeap :: IntPtr, 
@@ -31,6 +33,9 @@ data TwoSpace = TwoSpace { fromBase :: IntPtr,
 instance AllocationManager TwoSpace where
   mallocBytes = mallocBytes'
   performCollection = performCollection'
+  
+  heapSize = do space <- get
+                return $ fromIntegral $ toHeap space - fromIntegral (toBase space)
 
 
 performCollection' :: (RefObj a) => [a] -> StateT TwoSpace IO ()
@@ -64,7 +69,7 @@ mallocBytes' bytes = do state <- get
   where alloc :: TwoSpace -> IntPtr -> StateT TwoSpace IO (Ptr b)
         alloc state end = do let ptr = toHeap state
                              put $ state { toHeap = end } 
-                             liftIO (putStrLn $ "Allocated obj: " ++ (show ptr))
+                             liftIO (putStrLn $ "Allocated obj: " ++ show ptr)
                              liftIO (return $ intPtrToPtr ptr)
         fail = error "no space left in two space (mallocBytes')"
 
@@ -82,7 +87,7 @@ evacuate'' obj = do (size,payload) <- liftIO ((,) <$> size obj <*> payload obj)
                             setNewRef obj (cast newPtr))
 
 evacuateList :: (RefObj a, AllocationManager b) => [a] -> b -> IO ()
-evacuateList objs manager = evalStateT (evacuate' objs) manager
+evacuateList objs = evalStateT (evacuate' objs) 
 
 
 initTwoSpace :: Int -> IO TwoSpace

diff --git a/Mate/Tests/MockRefs.hs b/Mate/Tests/MockRefs.hs
index b1372606894d8bd18b1d36cc3524313fc85da8a7..855a7b675e3ca19216452ec577bbcde212848033 100644 (file)
--- a/Mate/Tests/MockRefs.hs
+++ b/Mate/Tests/MockRefs.hs
@@ -9,8 +9,13 @@ import Foreign.Marshal.Array
 import Foreign.Storable
 import GHC.Int
 import Text.Printf
+import System.IO.Unsafe(unsafePerformIO)
 
 import Control.Monad
+import Control.Monad.State
+
+import Test.QuickCheck 
+import Test.QuickCheck.Monadic 
 
 instance RefObj (Ptr a) where
   payload     = return . ptrToIntPtr
@@ -46,23 +51,23 @@ markRef :: Int32 -> Ptr a -> IO ()
 markRef val ptr = pokeByteOff ptr markedOff val
 
 setNewRefPtr :: Ptr a -> Ptr a -> IO ()
-setNewRefPtr ptr newPtr = pokeByteOff ptr newRefOff newPtr
+setNewRefPtr ptr = pokeByteOff ptr newRefOff 
 
 patchRefsPtr :: Ptr a -> [Ptr a] -> IO ()
-patchRefsPtr ptr xs = pokeArray (ptr `plusPtr` fieldsOff) xs
+patchRefsPtr ptr = pokeArray (ptr `plusPtr` fieldsOff) 
 
 printRef' :: Ptr a -> IO ()
 printRef' ptr = do printf "obj 0x%08x\n" =<< (peekByteOff ptr idOff :: IO Int32)
                    printf "children 0x%08x\n" =<< (peekByteOff ptr numberOfObjsOff :: IO Int32)                  
                    printf "marked 0x%08x\n" =<< (peekByteOff ptr markedOff :: IO Int32) 
-                   printf "payload 0x%08x\n" =<< ((liftM fromIntegral (payload ptr)) :: IO Int32)
+                   printf "payload 0x%08x\n" =<< (liftM fromIntegral (payload ptr) :: IO Int32)
                    printf "newRef 0x%08x\n" =<< (peekByteOff ptr newRefOff :: IO Int32)
                    printChildren ptr
                    putStrLn ""
 
 printChildren :: Ptr a -> IO ()
 printChildren ptr = do children <- refs ptr
-                       putStrLn $ "children" ++ (show children)
+                       putStrLn $ "children" ++ show children
 
 
 printTree :: Ptr a -> IO ()
@@ -127,4 +132,44 @@ testEvacuation objr = do ref <- objr
                          putStrLn "resulting objectTree"
                          printTree newRef
                          
-                         
+
+createMemoryManager :: Property
+createMemoryManager = monadicIO $ run f >>= (assert . (==0))
+  where f :: IO Int
+        f = do twoSpace <- initTwoSpace 0x10000
+               evalStateT heapSize twoSpace
+
+
+createObject :: Int -> IO (Ptr a)
+createObject children = do mem <- mallocBytes (0x10 + 0x4 * children)
+                           pokeArray mem [0,fromIntegral children,0::Int32,0]
+                           fields <- replicateM children (createObject 0)
+                           pokeArray (mem `plusPtr` fieldsOff) (fields :: [Ptr Int32])
+                           return $ cast mem 
+
+data ObjectTree = Node [ObjectTree] deriving Show
+
+instance Arbitrary ObjectTree where
+  arbitrary = resize 8 ( sized $ \n ->
+                                     do empty <- choose (0,100) :: Gen Int-- [True,False]
+                                        if empty < 80 then return $ Node []
+                                         else do k <- choose (0,n)
+                                                 liftM Node $ sequence [ arbitrary | _ <- [1..k] ] )
+
+createObjects :: ObjectTree -> IO (Ptr a)
+createObjects (Node xs)  = do let children = length xs
+                              mem <- mallocBytes (0x10 + 0x4 * children)
+                              pokeArray mem [0,fromIntegral children,0::Int32,0]
+                              fields <- mapM createObjects xs
+                              pokeArray (mem `plusPtr` fieldsOff) (fields :: [Ptr Int32])
+                              return $ cast mem 
+
+
+testObjectTree :: ObjectTree -> Property
+testObjectTree objTree = monadicIO $ run f >>= (assert . (==0))
+  where f :: IO Int
+        f = do root <- createObjects objTree
+               twoSpace <- initTwoSpace 0x1000
+               let collection = performCollection [root]
+               runStateT collection twoSpace
+               evalStateT heapSize twoSpace