From: Harald Steinlechner Date: Mon, 27 Aug 2012 17:43:18 +0000 (+0200) Subject: moved GC/MemoryManager into Mate (more comfortable with packages etc - integration... X-Git-Url: http://wien.tomnetworks.com/gitweb/?p=mate.git;a=commitdiff_plain;h=718a98e9457c0ec7b23531b23fa309e270e6cbf7 moved GC/MemoryManager into Mate (more comfortable with packages etc - integration approaches ;-)) --- diff --git a/Mate/GC.hs b/Mate/GC.hs new file mode 100644 index 0000000..9781d20 --- /dev/null +++ b/Mate/GC.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module GC + ({- dont export generic versions for high performance ;-) -}) where + +import Control.Monad + +--import Data.Foldable hiding (mapM_) + +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 + +class (Eq a, Ord a) => RefObj a where + payload :: a -> IO IntPtr + refs :: a -> IO [a] + marked :: a -> IO Bool + mark :: a -> IO () + unmark :: a -> IO () + +-- TODO hs: wtf? i am failing to create a printable class with superclass refobj?? +--class RefObj a => PrintableRefObj a where +-- printRef :: a -> IO () + +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) + +instance PrintableRef (Ptr a) where + printRef = printRef' + + +idOff = 0x0 +numberOfObjsOff = 0x4 +fieldsOff = 0xC +markedOff = 0x8 + +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 + +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\n" =<< (peekByteOff ptr markedOff :: 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) +markTree'' :: RefObj a => (a -> IO Bool) -> (a -> IO ()) -> [a] -> a -> IO [a] +markTree'' loopcheck marker ws root = do loop <- loopcheck root + if loop then return ws else liftM (root :) continue + where continue = marker root >> refs root >>= foldM (markTree'' loopcheck marker) ws + +-- | For debugging only (implements custom loop check with Data.Set!) +traverseIO :: RefObj o => (o -> IO ()) -> o -> IO () +traverseIO f = void . traverseIO' f S.empty + +traverseIO' :: RefObj a => (a -> IO ()) -> S.Set a -> a -> IO (S.Set a) +traverseIO' f ws root = if S.member root ws then f root >> return ws + else f root >> refs root >>= cont + where cont = foldM (\ws x -> do let ws' = S.insert x ws + traverseIO' f ws' x) ws' + ws' = S.insert root ws + +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 0xC + pokeArray mem [id,0,0::Int32] + return mem + +twoRefs = do mem <- mallocBytes 0x14 + -- idOfObj; numberofObj; marked waste memory Int32 + pokeArray mem [0::Int32,2,0] + obj1 <- emptyObj 1 + obj2 <- emptyObj 2 + pokeByteOff mem 0xC obj1 + pokeByteOff mem 0x10 obj2 + return mem + +cyclR = do mem <- mallocBytes 0x18 + pokeArray mem [0::Int32,3,0] + obj1 <- emptyObj 1 + obj2 <- emptyObj 2 + pokeByteOff mem 0xC obj1 + pokeByteOff mem 0x10 obj2 + pokeByteOff mem 0x14 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 new file mode 100644 index 0000000..8ddde1d --- /dev/null +++ b/Mate/MemoryManager.hs @@ -0,0 +1,31 @@ +module MemoryManager ( ) where + +import qualified Foreign.Marshal.Alloc as Alloc +import Foreign.Ptr +import Foreign.Storable + +import Control.Monad.State + +--import GC + +class AllocationManager a where + mallocBytes :: a -> Int -> (a,Ptr b) + +data TwoSpace = TwoSpace { fromBase :: IntPtr, + toBase :: IntPtr, + fromHeap :: IntPtr, + toHeap :: IntPtr, + fromExtreme :: IntPtr, + toExtreme :: IntPtr } + +mallocBytes' :: Int -> State TwoSpace (Ptr b) +mallocBytes' bytes = do state <- get + let end = (toHeap state) + (ptrToIntPtr $ nullPtr `plusPtr` bytes) -- not really? FUUU + -- actually i would like to use an existential within TwoSpace but this requires + -- pattern matchingt at call site http://stackoverflow.com/questions/10192663/why-cant-existential-types-use-record-syntax which is i think even slower. + if end <= toExtreme state then alloc state end else fail + where alloc :: TwoSpace -> IntPtr -> State TwoSpace (Ptr b) + alloc state end = do let ptr = toHeap state + put $ state { toHeap = end } + return $ intPtrToPtr ptr + fail = error "no space left in two space (mallocBytes')" diff --git a/scratch/GC.hs b/scratch/GC.hs deleted file mode 100644 index 9781d20..0000000 --- a/scratch/GC.hs +++ /dev/null @@ -1,124 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module GC - ({- dont export generic versions for high performance ;-) -}) where - -import Control.Monad - ---import Data.Foldable hiding (mapM_) - -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 - -class (Eq a, Ord a) => RefObj a where - payload :: a -> IO IntPtr - refs :: a -> IO [a] - marked :: a -> IO Bool - mark :: a -> IO () - unmark :: a -> IO () - --- TODO hs: wtf? i am failing to create a printable class with superclass refobj?? ---class RefObj a => PrintableRefObj a where --- printRef :: a -> IO () - -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) - -instance PrintableRef (Ptr a) where - printRef = printRef' - - -idOff = 0x0 -numberOfObjsOff = 0x4 -fieldsOff = 0xC -markedOff = 0x8 - -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 - -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\n" =<< (peekByteOff ptr markedOff :: 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) -markTree'' :: RefObj a => (a -> IO Bool) -> (a -> IO ()) -> [a] -> a -> IO [a] -markTree'' loopcheck marker ws root = do loop <- loopcheck root - if loop then return ws else liftM (root :) continue - where continue = marker root >> refs root >>= foldM (markTree'' loopcheck marker) ws - --- | For debugging only (implements custom loop check with Data.Set!) -traverseIO :: RefObj o => (o -> IO ()) -> o -> IO () -traverseIO f = void . traverseIO' f S.empty - -traverseIO' :: RefObj a => (a -> IO ()) -> S.Set a -> a -> IO (S.Set a) -traverseIO' f ws root = if S.member root ws then f root >> return ws - else f root >> refs root >>= cont - where cont = foldM (\ws x -> do let ws' = S.insert x ws - traverseIO' f ws' x) ws' - ws' = S.insert root ws - -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 0xC - pokeArray mem [id,0,0::Int32] - return mem - -twoRefs = do mem <- mallocBytes 0x14 - -- idOfObj; numberofObj; marked waste memory Int32 - pokeArray mem [0::Int32,2,0] - obj1 <- emptyObj 1 - obj2 <- emptyObj 2 - pokeByteOff mem 0xC obj1 - pokeByteOff mem 0x10 obj2 - return mem - -cyclR = do mem <- mallocBytes 0x18 - pokeArray mem [0::Int32,3,0] - obj1 <- emptyObj 1 - obj2 <- emptyObj 2 - pokeByteOff mem 0xC obj1 - pokeByteOff mem 0x10 obj2 - pokeByteOff mem 0x14 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/MemoryManager.hs b/scratch/MemoryManager.hs deleted file mode 100644 index 8ddde1d..0000000 --- a/scratch/MemoryManager.hs +++ /dev/null @@ -1,31 +0,0 @@ -module MemoryManager ( ) where - -import qualified Foreign.Marshal.Alloc as Alloc -import Foreign.Ptr -import Foreign.Storable - -import Control.Monad.State - ---import GC - -class AllocationManager a where - mallocBytes :: a -> Int -> (a,Ptr b) - -data TwoSpace = TwoSpace { fromBase :: IntPtr, - toBase :: IntPtr, - fromHeap :: IntPtr, - toHeap :: IntPtr, - fromExtreme :: IntPtr, - toExtreme :: IntPtr } - -mallocBytes' :: Int -> State TwoSpace (Ptr b) -mallocBytes' bytes = do state <- get - let end = (toHeap state) + (ptrToIntPtr $ nullPtr `plusPtr` bytes) -- not really? FUUU - -- actually i would like to use an existential within TwoSpace but this requires - -- pattern matchingt at call site http://stackoverflow.com/questions/10192663/why-cant-existential-types-use-record-syntax which is i think even slower. - if end <= toExtreme state then alloc state end else fail - where alloc :: TwoSpace -> IntPtr -> State TwoSpace (Ptr b) - alloc state end = do let ptr = toHeap state - put $ state { toHeap = end } - return $ intPtrToPtr ptr - fail = error "no space left in two space (mallocBytes')"