Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Release 0.0.95

  • Loading branch information...
commit 6630c5abf7231aca80afb1c77e87a099274d0093 1 parent fc1e41d
@kfish authored
View
354 src/GHC/Vacuum.hs
@@ -33,17 +33,20 @@
> }
-}
+
module GHC.Vacuum (
HNodeId
,HNode(..)
,emptyHNode
- ,vacuum,vacuumTo,vacuumLazy
+ ,summary
+ ,vacuum,vacuumTo,vacuumLazy,vacuumStream,vacuumDebug
,dump,dumpTo,dumpLazy
- ,toAdjList
+ ,toAdjList,toAdjPair
,nameGraph
,ShowHNode(..)
,showHNodes
- ,ppHs,ppDot
+ --,ppHs
+ ,ppDot
,Draw(..),G(..)
,draw,printDraw,split
,Closure(..)
@@ -56,39 +59,54 @@ module GHC.Vacuum (
,nodePkg,nodeMod
,nodeName,itabName
,HValue
+ --,module GHC.Vacuum.Q
) where
-import Prelude hiding(catch)
-import GHC.Vacuum.Dot as Dot
+
+import GHC.Vacuum.Q
+import GHC.Vacuum.Util
+import GHC.Vacuum.Types
+import GHC.Vacuum.Pretty
import GHC.Vacuum.ClosureType
import GHC.Vacuum.Internal as GHC
+
+import Data.List
import Data.Char
import Data.Word
-import Data.List
+import Data.Bits
import Data.Map(Map)
import Data.IntMap(IntMap)
import qualified Data.IntMap as IM
import qualified Data.Map as M
import Data.Monoid(Monoid(..))
-import Data.Array.IArray
+import Data.Array.IArray hiding ((!))
+import qualified Data.Array.IArray as A
import System.IO.Unsafe
import Control.Monad
-import Data.Bits
-import Text.PrettyPrint(Doc,text)
-import Language.Haskell.Meta.Utils(pretty)
import Control.Applicative
import Control.Exception
+import Prelude hiding(catch)
+import Control.Concurrent
import Foreign
import GHC.Arr(Array(..))
import GHC.Exts
+import System.Mem.StableName
+
-----------------------------------------------------------------------------
-- | Suck up @a@.
vacuum :: a -> IntMap HNode
vacuum a = unsafePerformIO (dump a)
+-- | Returns nodes as it encounters them.
+vacuumStream :: a -> [(HNodeId, HNode)]
+vacuumStream a = unsafePerformIO (dumpStream a)
+
+vacuumDebug :: a -> IntMap [(StableName HValue, HNodeId)]
+vacuumDebug a = unsafePerformIO (dumpDebug a)
+
-- | Stop after a given depth.
vacuumTo :: Int -> a -> IntMap HNode
vacuumTo n a = unsafePerformIO (dumpTo n a)
@@ -104,6 +122,12 @@ vacuumLazy a = unsafePerformIO (dumpLazy a)
dump :: a -> IO (IntMap HNode)
dump a = execH (dumpH a)
+dumpStream :: a -> IO [(HNodeId, HNode)]
+dumpStream a = streamH (dumpStreamH a)
+
+dumpDebug :: a -> IO (IntMap [(StableName HValue, HNodeId)])
+dumpDebug a = debugH (dumpH a)
+
dumpTo :: Int -> a -> IO (IntMap HNode)
dumpTo n a = execH (dumpToH n a)
@@ -112,135 +136,6 @@ dumpLazy a = execH (dumpLazyH a)
-----------------------------------------------------------------------------
-toAdjList :: IntMap HNode -> [(Int, [Int])]
-toAdjList = fmap (mapsnd nodePtrs) . IM.toList
-
-nameGraph :: IntMap HNode -> [(String, [String])]
-nameGraph m = let g = toAdjList m
- pp i = maybe "..."
- (\n -> nodeName n ++ "|" ++ show i)
- (IM.lookup i m)
- in fmap (\(x,xs) -> (pp x, fmap pp xs)) g
-
-data ShowHNode = ShowHNode
- {showHNode :: Int -> HNode -> String
- ,externHNode :: Int -> String}
-
-showHNodes :: ShowHNode -> IntMap HNode -> [(String, [String])]
-showHNodes (ShowHNode showN externN) m
- = let g = toAdjList m
- pp i = maybe (externN i) (showN i) (IM.lookup i m)
- in fmap (\(x,xs) -> (pp x, fmap pp xs)) g
-
------------------------------------------------------------------------------
-
-ppHs :: (Show a) => a -> Doc
-ppHs = text . pretty
-
-ppDot :: [(String, [String])] -> Doc
-ppDot = Dot.graphToDot id
-
------------------------------------------------------------------------------
-
-type HNodeId = Int
-
-data HNode = HNode
- {nodePtrs :: [HNodeId]
- ,nodeLits :: [Word]
- ,nodeInfo :: InfoTab}
- deriving(Eq,Ord,Read,Show)
-
-data InfoTab
- = ConInfo {itabPkg :: String
- ,itabMod :: String
- ,itabCon :: String
- ,itabPtrs :: Word
- ,itabLits :: Word
- ,itabType :: ClosureType
- ,itabSrtLen :: Word
- ,itabCode :: [Word]}
- | OtherInfo {itabPtrs :: Word
- ,itabLits :: Word
- ,itabType :: ClosureType
- ,itabSrtLen :: Word
- ,itabCode :: [Word]}
- deriving(Eq,Ord,Read,Show)
-
-data Closure = Closure
- {closPtrs :: [HValue]
- ,closLits :: [Word]
- ,closITab :: InfoTab}
- deriving(Show)
-
--- So we can derive Show for Closure
-instance Show HValue where show _ = "(HValue)"
-
-------------------------------------------------
-
--- | To assist in \"rendering\"
--- the graph to some source.
-data Draw e v m a = Draw
- {mkV :: Int -> a -> m v
- ,mkE :: v -> v -> m e
- ,succs :: a -> [Int]}
-
-newtype G e v = G {unG :: IntMap (v, IntMap e)}
- deriving(Eq,Ord,Read,Show)
-
-draw :: (Monad m) => Draw e v m a -> IntMap a -> m (G e v)
-draw (Draw mkV mkE succs) g = do
- vs <- IM.fromList `liftM` forM (IM.toList g)
- (\(i,a) -> do v <- mkV i a
- return (i,(v,succs a)))
- (G . IM.fromList) `liftM` forM (IM.toList vs)
- (\(i,(v,ps)) -> do let us = fmap (vs IM.!) ps
- es <- IM.fromList `liftM` forM ps
- (\p -> do e <- mkE v (fst (vs IM.! p))
- return (p,e))
- return (i,(v,es)))
-
--- | An example @Draw@
-printDraw :: Draw (Int,Int) Int IO HNode
-printDraw = Draw
- {mkV = \i _ -> print i >> return i
- ,mkE = \u v -> print (u,v) >> return (u,v)
- ,succs = nodePtrs}
-
--- | Build a map to @(preds,succs)@
-split :: (a -> [Int]) -> IntMap a -> IntMap ([Int],[Int])
-split f = flip IM.foldWithKey mempty (\i a m ->
- let ps = f a
- in foldl' (\m p -> IM.insertWith mappend p ([i],[]) m)
- (IM.insertWith mappend i ([],ps) m)
- ps)
-
-------------------------------------------------
-
-emptyHNode :: ClosureType -> HNode
-emptyHNode ct = HNode
- {nodePtrs = []
- ,nodeLits = []
- ,nodeInfo = if isCon ct
- then ConInfo [] [] [] 0 0 ct 0 []
- else OtherInfo 0 0 ct 0 []}
-
-nodePkg :: HNode -> String
-nodeMod :: HNode -> String
-nodeName :: HNode -> String
-nodePkg = fst3 . itabName . nodeInfo
-nodeMod = snd3 . itabName . nodeInfo
-nodeName = trd3 . itabName . nodeInfo
-
-fst3 (x,_,_) = x
-snd3 (_,x,_) = x
-trd3 (_,_,x) = x
-
-itabName :: InfoTab -> (String, String, String)
-itabName i@(ConInfo{}) = (itabPkg i, itabMod i, itabCon i)
-itabName _ = ([], [], [])
-
-------------------------------------------------
-
getInfoPtr :: a -> Ptr StgInfoTable
getInfoPtr a = let b = a `seq` Box a
in b `seq` case unpackClosure# a of
@@ -268,11 +163,6 @@ getClosure_ a =
,nptrs #) -> do
let iptr' | ghciTablesNextToCode = Ptr iptr
| otherwise = Ptr iptr `plusPtr` negate wORD_SIZE
- -- the info pointer we get back from unpackClosure#
- -- is to the beginning of the standard info table,
- -- but the Storable instance for info tables takes
- -- into account the extra entry pointer when
- -- !ghciTablesNextToCode, so we must adjust here.
itab <- peekInfoTab iptr'
let elems = fromIntegral (itabPtrs itab)
ptrs0 = if elems < 1
@@ -294,14 +184,8 @@ getInfoTab a =
,_ #) -> do
let iptr' | ghciTablesNextToCode = Ptr iptr
| otherwise = Ptr iptr `plusPtr` negate wORD_SIZE
- -- the info pointer we get back from unpackClosure#
- -- is to the beginning of the standard info table,
- -- but the Storable instance for info tables takes
- -- into account the extra entry pointer when
- -- !ghciTablesNextToCode, so we must adjust here.
peekInfoTab iptr'
-
peekInfoTab :: Ptr StgInfoTable -> IO InfoTab
peekInfoTab p = do
stg <- peek p
@@ -351,18 +235,26 @@ runH m = do
(a, s) <- runS m emptyEnv
return (a, graph s)
-data Env = Env
- {uniq :: HNodeId
- ,seen :: [(HValue, HNodeId)]
- ,hvals :: IntMap HValue
- ,graph :: IntMap HNode}
+runH_ :: H a -> IO ()
+runH_ m = do
+ _ <- runS m emptyEnv
+ return ()
+
+debugH :: H a -> IO (IntMap [(StableName HValue,HNodeId)])
+debugH m = (seen . snd) <$> runS m emptyEnv
-emptyEnv :: Env
-emptyEnv = Env
- {uniq = 0
- ,seen = []
- ,hvals = mempty
- ,graph = mempty}
+streamH :: (Q (Maybe a) -> H b) -> IO [a]
+streamH m = do
+ q <- newQ
+ tid <- forkIO (runH_ (m q) `finally` putQ q Nothing)
+ fmap fromJust <$> takeWhileQ isJust q
+
+fromJust :: Maybe a -> a
+fromJust (Just a) = a
+
+isJust :: Maybe a -> Bool
+isJust (Just{}) = True
+isJust _ = False
------------------------------------------------
@@ -388,6 +280,16 @@ dumpToH n a = go (n-1) =<< rootH a
[] -> return ()
_ -> mapM_ (go (n-1)) =<< mapM getHVal ids
+dumpStreamH :: a -> Q (Maybe (HNodeId,HNode)) -> H ()
+dumpStreamH a q = do
+ go =<< rootH a
+ where go :: HValue -> H ()
+ go a = do
+ ids <- nodeStreamH q a
+ case ids of
+ [] -> return ()
+ _ -> mapM_ go =<< mapM getHVal ids
+
dumpLazyH :: a -> H ()
dumpLazyH !a = go =<< rootH a
where go :: HValue -> H ()
@@ -416,9 +318,10 @@ rootH a = do
-- return the @HNodeId@'s of these newly-seen nodes
-- (which we've added to the graph in @H@'s state).
-- CURRENTLY GHC COERCES UNPOINTED CLOSURES TO
--- @HVALUE@, which is a bug in the sense that
--- unpointed closures cannot be entered, which HValues
--- can.
+-- @HVALUE@, which means that if we enter (==force/eval)
+-- such a closure we'll crash. Also, there's no way
+-- to know if the closure we're about to enter is
+-- such a closure.
nodeH :: HValue -> H [HNodeId]
nodeH a = do
clos <- io (getClosure $! a)
@@ -437,6 +340,25 @@ nodeH a = do
insertG i n
return news
+nodeStreamH :: Q (Maybe (HNodeId, HNode)) -> HValue -> H [HNodeId]
+nodeStreamH q a = do
+ clos <- io (getClosure $! a)
+ (i, _) <- getId a
+ let itab = closITab clos
+ ptrs = closPtrs clos
+ ptrs' <- case itabType itab of
+ t | isCon t -> return (avoid (itabCon itab) ptrs)
+ | otherwise -> return ptrs
+ ptrs'' <- io (mapM defined ptrs')
+ xs <- mapM getId ptrs''
+ let news = (fmap fst . fst . partition snd) xs
+ n = HNode (fmap fst xs)
+ (closLits clos)
+ (closITab clos)
+ --insertG i n
+ io (putQ q (Just (i,n)))
+ return news
+
nodeLazyH :: HValue -> H [HNodeId]
nodeLazyH a = do
clos <- io (getClosure a)
@@ -445,8 +367,8 @@ nodeLazyH a = do
ptrs = closPtrs clos
ptrs' <- case itabType itab of
t | isCon t -> return (avoid (itabCon itab) ptrs)
- -- IMPORTANT: Following either (or both) of
- -- the pointer inside a @THUNK@ results in a segfault.
+ -- IMPORTANT: Following any of the pointer(s)
+ -- inside a @THUNK@ results in the chop (aka segfault).
| isThunk t -> return []
| otherwise -> return ptrs
xs <- mapM getIdLazy ptrs'
@@ -481,37 +403,6 @@ criminals = IM.fromList . fmap (mapfst hash) $
--,("", id)
]
-hash :: String -> Int
-hash [] = 0
-hash s = go 0 (fmap ord s)
- where go !h [] = h
- go !h (n:ns) =
- let a = (h `shiftL` 4)
- b = a + n
- c = b .&. 0xf0000000
- !d = case c==0 of
- False -> let !e = c `shiftR` 24
- in b `xor` e
- True -> b
- !e = complement c
- !f = d `xor` e
- in go f ns
-
-{-
-unsigned long
-elfhash(const char *s)
-{
- unsigned long h=0, g;
- while (*s){
- h = (h << 4) + *s++;
- if((g = h & 0xf0000000))
- h ^= g >> 24;
- h &= ~g;
- }
- return h;
-}
--}
-
------------------------------------------------
getHVal :: HNodeId -> H HValue
@@ -530,87 +421,34 @@ newId = do
getId :: HValue -> H (HNodeId, Bool)
getId hval = hval `seq` do
+ sn <- io (makeStableName hval)
+ let h = hashStableName sn
s <- gets seen
- case look hval s of
+ case lookup sn =<< IM.lookup h s of
Just i -> return (i, False)
Nothing -> do
i <- newId
vs <- gets hvals
- modify (\e->e{seen=(hval,i):s
+ modify (\e->e{seen= IM.insertWith (++) h [(sn,i)] s
,hvals= IM.insert i hval vs})
return (i, True)
getIdLazy :: HValue -> H (HNodeId, Bool)
getIdLazy hval = do
+ sn <- io (makeStableName hval)
+ let h = hashStableName sn
s <- gets seen
- case lookLazy hval s of
+ case lookup sn =<< IM.lookup h s of
Just i -> return (i, False)
Nothing -> do
i <- newId
vs <- gets hvals
- modify (\e->e{seen=(hval,i):s
+ modify (\e->e{seen= IM.insertWith (++) h [(sn,i)] s
,hvals= IM.insert i hval vs})
return (i, True)
------------------------------------------------
-look :: HValue -> [(HValue, a)] -> Maybe a
-look _ [] = Nothing
-look hval ((x,i):xs)
- | hval .==. x = Just i
- | otherwise = look hval xs
-
-(.==.) :: HValue -> HValue -> Bool
-a .==. b = a `seq` b `seq`
- (0 /= I# (reallyUnsafePtrEquality# a b))
-
-lookLazy :: HValue -> [(HValue, a)] -> Maybe a
-lookLazy _ [] = Nothing
-lookLazy hval ((x,i):xs)
- | hval =.= x = Just i
- | otherwise = lookLazy hval xs
-
-(=.=) :: HValue -> HValue -> Bool
-a =.= b = (0 /= I# (reallyUnsafePtrEquality# a b))
-
-dumpArray :: Array Int a -> [a]
-dumpArray a = let (m,n) = bounds a
- in fmap (a!) [m..n]
-
-mapfst f = \(a,b) -> (f a,b)
-mapsnd f = \(a,b) -> (a,f b)
-f *** g = \(a, b) -> (f a, g b)
-
-p2i :: Ptr a -> Int
-i2p :: Int -> Ptr a
-p2i (Ptr a#) = I# (addr2Int# a#)
-i2p (I# n#) = Ptr (int2Addr# n#)
-
-------------------------------------------------
-
-{-
-newtype S s a = S {unS :: forall o. s -> (s -> a -> IO o) -> IO o}
-instance Functor (S s) where
- fmap f (S g) = S (\s k -> g s (\s a -> k s (f a)))
-instance Monad (S s) where
- return a = S (\s k -> k s a)
- S g >>= f = S (\s k -> g s (\s a -> unS (f a) s k))
-get :: S s s
-get = S (\s k -> k s s)
-gets :: (s -> a) -> S s a
-gets f = S (\s k -> k s (f s))
-set :: s -> S s ()
-set s = S (\_ k -> k s ())
-io :: IO a -> S s a
-io m = S (\s k -> k s =<< m)
-modify :: (s -> s) -> S s ()
-modify f = S (\s k -> k (f s) ())
-runS :: S s a -> s -> IO (a, s)
-runS (S g) s = g s (\s a -> return (a, s))
--}
-
-------------------------------------------------
-
{-
rts/StgMiscClosures.cmm
View
108 src/GHC/Vacuum/Pretty.hs
@@ -0,0 +1,108 @@
+
+
+
+module GHC.Vacuum.Pretty (
+ module GHC.Vacuum.Pretty
+ ,module GHC.Vacuum.Pretty.Dot
+) where
+
+import Data.List
+import Data.IntMap(IntMap)
+import Data.Monoid(Monoid(..))
+import qualified Data.IntMap as IM
+import Text.PrettyPrint(Doc,text,render)
+--import Language.Haskell.Meta.Utils(pretty)
+import Control.Monad
+
+import GHC.Vacuum.Util
+import GHC.Vacuum.Types
+import GHC.Vacuum.Pretty.Dot
+
+-----------------------------------------------------------------------------
+
+
+toAdjPair :: (HNodeId, HNode) -> (Int, [Int])
+toAdjPair = mapsnd nodePtrs
+
+toAdjList :: IntMap HNode -> [(Int, [Int])]
+toAdjList = fmap toAdjPair . IM.toList
+
+nameGraph :: IntMap HNode -> [(String, [String])]
+nameGraph m = let g = toAdjList m
+ pp i = maybe "..."
+ (\n -> nodeName n ++ "|" ++ show i)
+ (IM.lookup i m)
+ in fmap (\(x,xs) -> (pp x, fmap pp xs)) g
+
+data ShowHNode = ShowHNode
+ {showHNode :: Int -> HNode -> String
+ ,externHNode :: Int -> String}
+
+showHNodes :: ShowHNode -> IntMap HNode -> [(String, [String])]
+showHNodes (ShowHNode showN externN) m
+ = let g = toAdjList m
+ pp i = maybe (externN i) (showN i) (IM.lookup i m)
+ in fmap (\(x,xs) -> (pp x, fmap pp xs)) g
+
+-----------------------------------------------------------------------------
+
+--ppHs :: (Show a) => a -> Doc
+--ppHs = text . pretty
+
+ppDot :: [(String, [String])] -> Doc
+ppDot = graphToDot id
+
+renderDot :: [(String, [String])] -> String
+renderDot = render . ppDot
+
+-----------------------------------------------------------------------------
+
+-- | To assist in \"rendering\"
+-- the graph to some source.
+data Draw e v m a = Draw
+ {mkV :: Int -> a -> m v
+ ,mkE :: v -> v -> m e
+ ,succs :: a -> [Int]}
+
+newtype G e v = G {unG :: IntMap (v, IntMap e)}
+ deriving(Eq,Ord,Read,Show)
+
+draw :: (Monad m) => Draw e v m a -> IntMap a -> m (G e v)
+draw (Draw mkV mkE succs) g = do
+ vs <- IM.fromList `liftM` forM (IM.toList g)
+ (\(i,a) -> do v <- mkV i a
+ return (i,(v,succs a)))
+ (G . IM.fromList) `liftM` forM (IM.toList vs)
+ (\(i,(v,ps)) -> do let us = fmap (vs IM.!) ps
+ es <- IM.fromList `liftM` forM ps
+ (\p -> do e <- mkE v (fst (vs IM.! p))
+ return (p,e))
+ return (i,(v,es)))
+
+-- | An example @Draw@
+printDraw :: Draw (Int,Int) Int IO HNode
+printDraw = Draw
+ {mkV = \i _ -> print i >> return i
+ ,mkE = \u v -> print (u,v) >> return (u,v)
+ ,succs = nodePtrs}
+
+-- | Build a map to @(preds,succs)@
+split :: (a -> [Int]) -> IntMap a -> IntMap ([Int],[Int])
+split f = flip IM.foldWithKey mempty (\i a m ->
+ let ps = f a
+ in foldl' (\m p -> IM.insertWith mappend p ([i],[]) m)
+ (IM.insertWith mappend i ([],ps) m)
+ ps)
+
+-----------------------------------------------------------------------------
+
+
+
+
+
+
+
+
+
+
+
View
2  src/GHC/Vacuum/Dot.hs → src/GHC/Vacuum/Pretty/Dot.hs
@@ -1,5 +1,5 @@
-module GHC.Vacuum.Dot (
+module GHC.Vacuum.Pretty.Dot (
graphToDot
,ppGraph,ppEdge,gStyle
-- ,Doc,text,render
View
118 src/GHC/Vacuum/Q.hs
@@ -0,0 +1,118 @@
+{-# LANGUAGE BangPatterns, PostfixOperators #-}
+
+module GHC.Vacuum.Q (
+ Ref,ref,(!),(.=),(!=)
+ ,Q,isEmptyQ,newQ,putQ,takeQ,tryTakeQ
+ ,drainQ,getQContents,takeWhileQ
+) where
+
+import Data.IORef
+import Control.Monad
+import Control.Concurrent
+import Control.Applicative
+import System.IO.Unsafe(unsafeInterleaveIO)
+
+------------------------------------------------
+
+newtype Ref a = Ref
+ {unRef :: IORef a}
+
+ref :: a -> IO (Ref a)
+ref a = Ref <$> newIORef a
+
+(!) :: Ref a -> IO a
+(!) (Ref r) = readIORef r
+
+(.=) :: Ref a -> a -> IO ()
+Ref r .= x = writeIORef r x
+
+(!=) :: Ref a -> (a -> (a, b)) -> IO b
+Ref r != f = atomicModifyIORef r f
+
+------------------------------------------------
+
+data Q a = Q (MVar (Tail a))
+ (MVar (Tail a))
+
+newtype Tail a = Tail (Ref (Maybe (a, Tail a)))
+
+emptyTail :: IO (Tail a)
+emptyTail = Tail <$> ref Nothing
+
+isEmptyTail :: Tail a -> IO Bool
+isEmptyTail (Tail r) = maybe True (const False) <$> (r!)
+
+isEmptyQ :: Q a -> IO Bool
+isEmptyQ (Q rd _) = isEmptyMVar rd
+
+newQ :: IO (Q a)
+newQ = do
+ hole <- emptyTail
+ readVar <- newEmptyMVar
+ writeVar <- newMVar hole
+ return (Q readVar writeVar)
+
+putQ :: Q a -> a -> IO ()
+putQ (Q rd wr) val = do
+ Tail old <- takeMVar wr
+ new <- emptyTail
+ old .= Just (val, new)
+ first <- isEmptyMVar rd
+ when first (putMVar rd (Tail old))
+ putMVar wr new
+
+takeQ :: Q a -> IO a
+takeQ q@(Q rd _) = do
+ Tail end <- takeMVar rd
+ m <- (end!)
+ case m of
+ Nothing -> takeQ q
+ Just (a, new) -> do last <- isEmptyTail new
+ when (not last) (putMVar rd new)
+ return a
+
+tryTakeQ :: Q a -> IO (Maybe a)
+tryTakeQ q@(Q rd _) = do
+ o <- tryTakeMVar rd
+ case o of
+ Nothing -> return Nothing
+ Just (Tail end) -> do
+ m <- (end!)
+ case m of
+ Nothing -> error "impossible!"
+ Just (a, new) -> do last <- isEmptyTail new
+ when (not last) (putMVar rd new)
+ return (Just a)
+
+drainQ :: Q a -> IO [a]
+drainQ q = do
+ a <- tryTakeQ q
+ case a of
+ Nothing -> return []
+ Just a -> do as <- unsafeInterleaveIO (drainQ q)
+ return (a:as)
+
+getQContents :: Q a -> IO [a]
+getQContents q = do
+ a <- takeQ q
+ as <- unsafeInterleaveIO (getQContents q)
+ return (a:as)
+
+
+takeWhileQ :: (a -> Bool) -> Q a -> IO [a]
+takeWhileQ p q = do
+ a <- takeQ q
+ case p a of
+ False -> return []
+ True -> do
+ as <- unsafeInterleaveIO (takeWhileQ p q)
+ return (a:as)
+
+
+
+
+
+------------------------------------------------
+
+
+
View
97 src/GHC/Vacuum/Types.hs
@@ -0,0 +1,97 @@
+
+
+
+module GHC.Vacuum.Types (
+ module GHC.Vacuum.Types
+) where
+
+import GHC.Vacuum.ClosureType
+import GHC.Vacuum.Internal(HValue)
+
+import Data.List
+import Data.Word
+import Data.IntMap(IntMap)
+import Data.Monoid(Monoid(..))
+import qualified Data.IntMap as IM
+import System.Mem.StableName
+
+------------------------------------------------
+
+type HNodeId = Int
+
+data HNode = HNode
+ {nodePtrs :: [HNodeId]
+ ,nodeLits :: [Word]
+ ,nodeInfo :: InfoTab}
+ deriving(Eq,Ord,Read,Show)
+
+emptyHNode :: ClosureType -> HNode
+emptyHNode ct = HNode
+ {nodePtrs = []
+ ,nodeLits = []
+ ,nodeInfo = if isCon ct
+ then ConInfo [] [] [] 0 0 ct 0 []
+ else OtherInfo 0 0 ct 0 []}
+
+nodePkg :: HNode -> String
+nodeMod :: HNode -> String
+nodeName :: HNode -> String
+nodePkg = fst3 . itabName . nodeInfo
+nodeMod = snd3 . itabName . nodeInfo
+nodeName = trd3 . itabName . nodeInfo
+
+fst3 (x,_,_) = x
+snd3 (_,x,_) = x
+trd3 (_,_,x) = x
+
+itabName :: InfoTab -> (String, String, String)
+itabName i@(ConInfo{}) = (itabPkg i, itabMod i, itabCon i)
+itabName _ = ([], [], [])
+
+summary :: HNode -> ([String],[HNodeId],[Word])
+summary (HNode ps ls info) = case itabName info of
+ (a,b,c) -> ([a,b,c],ps,ls)
+
+data InfoTab
+ = ConInfo {itabPkg :: String
+ ,itabMod :: String
+ ,itabCon :: String
+ ,itabPtrs :: Word
+ ,itabLits :: Word
+ ,itabType :: ClosureType
+ ,itabSrtLen :: Word
+ ,itabCode :: [Word]}
+ | OtherInfo {itabPtrs :: Word
+ ,itabLits :: Word
+ ,itabType :: ClosureType
+ ,itabSrtLen :: Word
+ ,itabCode :: [Word]}
+ deriving(Eq,Ord,Read,Show)
+
+data Closure = Closure
+ {closPtrs :: [HValue]
+ ,closLits :: [Word]
+ ,closITab :: InfoTab}
+ deriving(Show)
+
+-- So we can derive Show for Closure
+instance Show HValue where show _ = "(HValue)"
+
+------------------------------------------------
+
+data Env = Env
+ {uniq :: HNodeId
+ -- the keys are hashes of StableNames
+ ,seen :: IntMap [(StableName HValue,HNodeId)]
+ ,hvals :: IntMap HValue
+ ,graph :: IntMap HNode}
+
+emptyEnv :: Env
+emptyEnv = Env
+ {uniq = 0
+ ,seen = mempty
+ ,hvals = mempty
+ ,graph = mempty}
+
+------------------------------------------------
+
View
85 src/GHC/Vacuum/Util.hs
@@ -0,0 +1,85 @@
+
+
+
+module GHC.Vacuum.Util (
+ module GHC.Vacuum.Util
+) where
+
+import Data.List
+import Data.Char
+import Data.Bits
+import Data.Array.IArray hiding ((!))
+import qualified Data.Array.IArray as A
+
+hash :: String -> Int
+hash [] = 0
+hash s = go 0 (fmap ord s)
+ where go !h [] = h
+ go !h (n:ns) =
+ let a = (h `shiftL` 4)
+ b = a + n
+ c = b .&. 0xf0000000
+ !d = case c==0 of
+ False -> let !e = c `shiftR` 24
+ in b `xor` e
+ True -> b
+ !e = complement c
+ !f = d .&. e
+ in go f ns
+
+{-
+unsigned long
+elfhash(const char *s)
+{
+ unsigned long h=0, g;
+ while (*s){
+ h = (h << 4) + *s++;
+ if((g = h & 0xf0000000))
+ h ^= g >> 24;
+ h &= ~g;
+ }
+ return h;
+}
+-}
+
+------------------------------------------------
+{-
+look :: HValue -> [(HValue, a)] -> Maybe a
+look _ [] = Nothing
+look hval ((x,i):xs)
+ | hval .==. x = Just i
+ | otherwise = look hval xs
+
+(.==.) :: HValue -> HValue -> Bool
+a .==. b = a `seq` b `seq`
+ (0 /= I# (reallyUnsafePtrEquality# a b))
+
+lookLazy :: HValue -> [(HValue, a)] -> Maybe a
+lookLazy _ [] = Nothing
+lookLazy hval ((x,i):xs)
+ | hval =.= x = Just i
+ | otherwise = lookLazy hval xs
+
+(=.=) :: HValue -> HValue -> Bool
+a =.= b = (0 /= I# (reallyUnsafePtrEquality# a b))
+-}
+
+dumpArray :: Array Int a -> [a]
+dumpArray a = let (m,n) = bounds a
+ in fmap (a A.!) [m..n]
+
+mapfst f = \(a,b) -> (f a,b)
+mapsnd f = \(a,b) -> (a,f b)
+f *** g = \(a, b) -> (f a, g b)
+
+{-
+p2i :: Ptr a -> Int
+i2p :: Int -> Ptr a
+p2i (Ptr a#) = I# (addr2Int# a#)
+i2p (I# n#) = Ptr (int2Addr# n#)
+-}
+
+------------------------------------------------
+
+
+
View
16 vacuum.cabal
@@ -1,5 +1,5 @@
name: vacuum
-version: 0.0.94
+version: 0.0.95
cabal-version: >= 1.6
build-type: Simple
license: LGPL
@@ -18,9 +18,15 @@ library
ghc-options: -O2 -fglasgow-exts -funbox-strict-fields
extensions: CPP, BangPatterns
includes: ghcautoconf.h
+ build-depends: base==4.*, ghc-prim, array,
+ containers, pretty
+ -- haskell-src-meta
+
exposed-modules: GHC.Vacuum,
- GHC.Vacuum.Dot,
GHC.Vacuum.ClosureType,
- GHC.Vacuum.Internal
- build-depends: base==4.*, ghc-prim, array,
- containers, pretty, haskell-src-meta
+ GHC.Vacuum.Internal,
+ GHC.Vacuum.Q,
+ GHC.Vacuum.Types,
+ GHC.Vacuum.Util,
+ GHC.Vacuum.Pretty,
+ GHC.Vacuum.Pretty.Dot
Please sign in to comment.
Something went wrong with that request. Please try again.