From 60f458ed740ecb9011dbb4d6caf607b55253d52c Mon Sep 17 00:00:00 2001 From: Harald Steinlechner Date: Sat, 1 Sep 2012 23:42:43 +0200 Subject: [PATCH] GC: implemented QuickCheck magic to test GC of huge object trees --- Mate/MemoryManager.hs | 11 ++++++--- Mate/Tests/MockRefs.hs | 55 ++++++++++++++++++++++++++++++++++++++---- 2 files changed, 58 insertions(+), 8 deletions(-) diff --git a/Mate/MemoryManager.hs b/Mate/MemoryManager.hs index c55fb37..1665d20 100644 --- 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 b137260..855a7b6 100644 --- 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 -- 2.25.1