From: Harald Steinlechner Date: Sat, 1 Sep 2012 13:08:01 +0000 (+0200) Subject: GC: refactored Ptr specific test implementation into Mate/Tests/MockRefs; X-Git-Url: http://wien.tomnetworks.com/gitweb/?p=mate.git;a=commitdiff_plain;h=3b65fdd337b571a3f22df4722fb79027a5aad060 GC: refactored Ptr specific test implementation into Mate/Tests/MockRefs; --- diff --git a/Mate/GC.hs b/Mate/GC.hs index 582fb01..5ddd6e2 100644 --- a/Mate/GC.hs +++ b/Mate/GC.hs @@ -1,18 +1,12 @@ {-# LANGUAGE ScopedTypeVariables #-} module Mate.GC - ( RefObj + ( RefObj(..), PrintableRef(..), traverseIO, markTree'' {- dont export generic versions for high performance -> remove for production -}) where import Control.Monad - -import Foreign.Ptr -import Foreign.Marshal.Alloc -import Foreign.Marshal.Array -import Foreign.Storable -import GHC.Int - import qualified Data.Set as S -import Text.Printf + +import Foreign.Ptr (IntPtr) class (Eq a, Ord a) => RefObj a where @@ -31,46 +25,6 @@ class (Eq a, Ord a) => RefObj a where class PrintableRef a where printRef :: a -> IO () -instance RefObj (Ptr a) where - payload = return . ptrToIntPtr - refs = unpackRefs . castPtr - marked = markedRef - mark = markRef (0x1::Int32) - unmark = markRef (0x0::Int32) - newRef = newRefPtr - patchRefs = undefined - copy = undefined - -instance PrintableRef (Ptr a) where - printRef = printRef' - - -idOff = 0x0 -numberOfObjsOff = 0x4 -markedOff = 0x8 -newRefOff = 0xC -fieldsOff = 0x10 - -unpackRefs :: Ptr Int32 -> IO [Ptr b] -unpackRefs ptr = do --dereference number of objs; mark field skipped via fieldsOffset - numberOfObjs <- peekByteOff ptr numberOfObjsOff :: IO Int32 - mapM (peekElemOff (ptr `plusPtr` fieldsOff)) [0..fromIntegral $ numberOfObjs-1] - -markedRef :: Ptr a -> IO Bool -markedRef ptr = liftM ((/=0) . fromIntegral) (peekByteOff ptr markedOff :: IO Int32) - -markRef :: Int32 -> Ptr a -> IO () -markRef val ptr = pokeByteOff ptr markedOff val - -newRefPtr :: Ptr a -> Ptr a -> IO () -newRefPtr ptr newRef = pokeByteOff ptr newRefOff newRef - -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 "newRef 0x%08x\n\n" =<< (peekByteOff ptr newRefOff :: IO Int32) - -- | Generically marks a graph (can be used to set mark bit and reset mark bit at the same time -- using customized loopcheck and marker funcs (i.e. to set the bit check on ==1 and on ==0 otherwise) -- Furthermore it produces a list of visited nodes (this can be all live one (or dead on respectively) @@ -94,41 +48,3 @@ markTree :: RefObj a => a -> IO () markTree root = marked root >>= (`unless` continue) where continue = mark root >> refs root >>= mapM_ markTree -printTree :: Ptr a -> IO () -printTree = traverseIO printRef' - - -emptyObj id = do mem <- mallocBytes 0x10 - pokeArray mem [id,0,0::Int32,0] - return mem - -twoRefs = do mem <- mallocBytes 0x18 - -- idOfObj; numberofObj; marked waste memory Int32 - pokeArray mem [0::Int32,2,0,0] - obj1 <- emptyObj 1 - obj2 <- emptyObj 2 - pokeByteOff mem 0x10 obj1 - pokeByteOff mem 0x14 obj2 - return mem - -cyclR = do mem <- mallocBytes 0x1C - pokeArray mem [0::Int32,3,0,0] - obj1 <- emptyObj 1 - obj2 <- emptyObj 2 - pokeByteOff mem 0x10 obj1 - pokeByteOff mem 0x14 obj2 - pokeByteOff mem 0x18 mem - return mem - -test objr = do twoRefs <- objr - putStrLn "initial:\n" - printTree twoRefs - lifeRefs <- markTree'' marked mark [] twoRefs - putStrLn "life refs: \n" - print lifeRefs - --forM lifeRefs printRef' - putStrLn "after marking\n" - printTree twoRefs - markTree'' (liftM not . marked) unmark [] twoRefs - putStrLn "after unmarking\n" - printTree twoRefs diff --git a/Mate/MemoryManager.hs b/Mate/MemoryManager.hs index 988c360..a58a1a9 100644 --- a/Mate/MemoryManager.hs +++ b/Mate/MemoryManager.hs @@ -5,8 +5,6 @@ import qualified Foreign.Marshal.Alloc as Alloc import Foreign.Ptr import Foreign.Storable -import Data.HashTable - import Text.Printf import Control.Monad.State diff --git a/Mate/Tests/MockRefs.hs b/Mate/Tests/MockRefs.hs new file mode 100644 index 0000000..783852a --- /dev/null +++ b/Mate/Tests/MockRefs.hs @@ -0,0 +1,90 @@ +module Mate.Tests.MockRefs where + +import Mate.GC + +import Foreign.Ptr +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array +import Foreign.Storable +import GHC.Int +import Text.Printf + +import Control.Monad + +instance RefObj (Ptr a) where + payload = return . ptrToIntPtr + refs = unpackRefs . castPtr + marked = markedRef + mark = markRef (0x1::Int32) + unmark = markRef (0x0::Int32) + newRef = newRefPtr + patchRefs = undefined + copy = undefined + +instance PrintableRef (Ptr a) where + printRef = printRef' + + +idOff = 0x0 +numberOfObjsOff = 0x4 +markedOff = 0x8 +newRefOff = 0xC +fieldsOff = 0x10 + +unpackRefs :: Ptr Int32 -> IO [Ptr b] +unpackRefs ptr = do --dereference number of objs; mark field skipped via fieldsOffset + numberOfObjs <- peekByteOff ptr numberOfObjsOff :: IO Int32 + mapM (peekElemOff (ptr `plusPtr` fieldsOff)) [0..fromIntegral $ numberOfObjs-1] + +markedRef :: Ptr a -> IO Bool +markedRef ptr = liftM ((/=0) . fromIntegral) (peekByteOff ptr markedOff :: IO Int32) + +markRef :: Int32 -> Ptr a -> IO () +markRef val ptr = pokeByteOff ptr markedOff val + +newRefPtr :: Ptr a -> Ptr a -> IO () +newRefPtr ptr newRef = pokeByteOff ptr newRefOff newRef + +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 "newRef 0x%08x\n\n" =<< (peekByteOff ptr newRefOff :: IO Int32) + +printTree :: Ptr a -> IO () +printTree = traverseIO printRef' + +emptyObj id = do mem <- mallocBytes 0x10 + pokeArray mem [id,0,0::Int32,0] + return mem + +twoRefs = do mem <- mallocBytes 0x18 + -- idOfObj; numberofObj; marked waste memory Int32 + pokeArray mem [0::Int32,2,0,0] + obj1 <- emptyObj 1 + obj2 <- emptyObj 2 + pokeByteOff mem 0x10 obj1 + pokeByteOff mem 0x14 obj2 + return mem + +cyclR = do mem <- mallocBytes 0x1C + pokeArray mem [0::Int32,3,0,0] + obj1 <- emptyObj 1 + obj2 <- emptyObj 2 + pokeByteOff mem 0x10 obj1 + pokeByteOff mem 0x14 obj2 + pokeByteOff mem 0x18 mem + return mem + +test objr = do twoRefs <- objr + putStrLn "initial:\n" + printTree twoRefs + lifeRefs <- markTree'' marked mark [] twoRefs + putStrLn "life refs: \n" + print lifeRefs + --forM lifeRefs printRef' + putStrLn "after marking\n" + printTree twoRefs + markTree'' (liftM not . marked) unmark [] twoRefs + putStrLn "after unmarking\n" + printTree twoRefs diff --git a/scratch/Analysis.hs b/scratch/Analysis.hs index fb50ea1..df60ed0 100644 --- a/scratch/Analysis.hs +++ b/scratch/Analysis.hs @@ -1,10 +1,12 @@ +{-# LANGUAGE GADTs #-} module Analysis where +import Compiler.Hoopl import Control.Monad.State type Addr = Int -data StackIL = Dup | Ld Addr Type | Add Type | Store Addr Type +data StackIL = Dup | Ld Addr Type | Add Type | Store Addr Type deriving Show type Target = (Int,Type) type Source = (Int,Type) @@ -21,7 +23,7 @@ type StackElem = (Int,Type) type Stack = [StackElem] dup :: State Stack () -dup = modify (\(top@(i,t):x) -> (i+1,t) : top : xs) +dup = modify (\(top@(i,t):xs) -> (i+1,t) : top : xs) push :: Type -> State Stack Int push t = do tos <- get @@ -57,4 +59,26 @@ generateRegisterIR :: [StackIL] -> [RegIL] generateRegisterIR = (`evalState` []) . aInterpret --data StackIL = Dup | Ld Addr Type | Add Type | Store Addr Type -testCase1 = [ Ld 0 Int, Ld 1 Int, Dup , Add Int, Add Int, Store 0 Int] +testCase1 = [ Ld 0 Int, Ld 1 Int, Dup , Add Int, Add Int, Store 0 Int] + +bench = concat . replicate 100000 + +type TLabel = Int +type Var = String +data Expr = VarE Var | AddE Var Var | Lit Int | CLe Expr Expr + +data Node e x where + Label :: TLabel -> Node C O + Assign :: Var -> Expr -> Node O O + If :: Expr -> TLabel -> TLabel -> Node O C + Ret :: Node O C + Nop :: Node O O + Branch :: TLabel -> Node C C + +{-testProgram = [ Assign "x" (Lit 3), + Assign "y" (Lit 5), + If (CLe (VarE "x") (VarE "y")) 1 2, + Assign "x" (VarE "y") + ] -} + + diff --git a/scratch/AnalysisTest.hs b/scratch/AnalysisTest.hs new file mode 100644 index 0000000..6f799ce --- /dev/null +++ b/scratch/AnalysisTest.hs @@ -0,0 +1,5 @@ +module Main where + +import Analysis + +main = print $ (bench testCase1)