diff --git a/src/GHC/Vacuum.hs b/src/GHC/Vacuum.hs
--- a/src/GHC/Vacuum.hs
+++ b/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 @@
   ,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 @@
 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 @@
 
 -----------------------------------------------------------------------------
 
-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 @@
         ,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 @@
       ,_ #) -> 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,19 +235,27 @@
   (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 ()
 
-emptyEnv :: Env
-emptyEnv = Env
-  {uniq = 0
-  ,seen = []
-  ,hvals = mempty
-  ,graph = mempty}
+debugH :: H a -> IO (IntMap [(StableName HValue,HNodeId)])
+debugH m = (seen . snd) <$> runS m emptyEnv
 
+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
+
 ------------------------------------------------
 
 -- | Walk the reachable heap (sub)graph rooted at @a@,
@@ -388,6 +280,16 @@
             [] -> 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 @@
 --  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 @@
   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 @@
       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 @@
   --,("",                 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,84 +421,31 @@
 
 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))
--}
 
 ------------------------------------------------
 
diff --git a/src/GHC/Vacuum/Dot.hs b/src/GHC/Vacuum/Dot.hs
deleted file mode 100644
--- a/src/GHC/Vacuum/Dot.hs
+++ /dev/null
@@ -1,66 +0,0 @@
-
-module GHC.Vacuum.Dot (
-   graphToDot
-  ,ppGraph,ppEdge,gStyle
---   ,Doc,text,render
-) where
-
-import Text.PrettyPrint
-
-------------------------------------------------
-
--- | .
-graphToDot :: (a -> String) -> [(a, [a])] -> Doc
-graphToDot f = ppGraph . fmap (f *** fmap f)
-  where f *** g = \(a, b)->(f a, g b)
-
-------------------------------------------------
-
-gStyle :: String
-gStyle = unlines
-  ["  graph [rankdir=LR, splines=true];"
-  ,"  node [label=\"\\N\", shape=none, fontcolor=blue, fontname=courier];"
-  ,"  edge [color=black, style=dotted, fontname=courier, arrowname=onormal];"]
-
-ppGraph :: [(String, [String])] -> Doc
-ppGraph xs = (text "digraph g" <+> text "{")
-              $+$ text gStyle
-                $+$ nest indent (vcat . fmap ppEdge $ xs)
-                    $+$ text "}"
-                        where indent = 2
-
-ppEdge :: (String, [String]) -> Doc
-ppEdge (x,xs) = (dQText x) <+> (text "->")
-                    <+> (braces . hcat . punctuate semi
-                        . fmap dQText $ xs)
-
-dQText :: String -> Doc
-dQText = doubleQuotes . text
-
-{-
-import System.Cmd
-import System.Exit
-graphToDotPng :: FilePath -> [(String,[String])] -> IO Bool
-graphToDotPng fpre g = do
-  let [dot,png] = fmap (fpre++) [".dot",".png"]
-  writeFile dot
-    . render . ppGraph
-      -- . fmap (show***fmap show)
-        $ g
-  ((==ExitSuccess) `fmap`) .system . intercalate " " $
-    -- ["cat",dot,"|","dot -Tpng",">",png,"2>/dev/null;","gliv",png,"&"]
-    ["cat",dot,"|","dot -Tpng",">",png,"2>/dev/null;","display",png,"&"]
-
-graphToDotPdf :: FilePath -> [(String,[String])] -> IO Bool
-graphToDotPdf fpre g = do
-  let [dot,png] = fmap (fpre++) [".dot",".pdf"]
-  writeFile dot
-    . render . ppGraph
-      -- . fmap (show***fmap show)
-        $ g
-  ((==ExitSuccess) `fmap`) .system . intercalate " " $
-    -- ["cat",dot,"|","dot -Tpng",">",png,"2>/dev/null;","gliv",png,"&"]
-    ["cat",dot,"tred","|","dot -Tpdf",">",png,"2>/dev/null;","evince",png,"&"]
--}
-
-------------------------------------------------
diff --git a/src/GHC/Vacuum/Pretty.hs b/src/GHC/Vacuum/Pretty.hs
new file mode 100644
--- /dev/null
+++ b/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)
+
+-----------------------------------------------------------------------------
+
+
+
+
+
+
+
+
+
+
+
diff --git a/src/GHC/Vacuum/Pretty/Dot.hs b/src/GHC/Vacuum/Pretty/Dot.hs
new file mode 100644
--- /dev/null
+++ b/src/GHC/Vacuum/Pretty/Dot.hs
@@ -0,0 +1,66 @@
+
+module GHC.Vacuum.Pretty.Dot (
+   graphToDot
+  ,ppGraph,ppEdge,gStyle
+--   ,Doc,text,render
+) where
+
+import Text.PrettyPrint
+
+------------------------------------------------
+
+-- | .
+graphToDot :: (a -> String) -> [(a, [a])] -> Doc
+graphToDot f = ppGraph . fmap (f *** fmap f)
+  where f *** g = \(a, b)->(f a, g b)
+
+------------------------------------------------
+
+gStyle :: String
+gStyle = unlines
+  ["  graph [rankdir=LR, splines=true];"
+  ,"  node [label=\"\\N\", shape=none, fontcolor=blue, fontname=courier];"
+  ,"  edge [color=black, style=dotted, fontname=courier, arrowname=onormal];"]
+
+ppGraph :: [(String, [String])] -> Doc
+ppGraph xs = (text "digraph g" <+> text "{")
+              $+$ text gStyle
+                $+$ nest indent (vcat . fmap ppEdge $ xs)
+                    $+$ text "}"
+                        where indent = 2
+
+ppEdge :: (String, [String]) -> Doc
+ppEdge (x,xs) = (dQText x) <+> (text "->")
+                    <+> (braces . hcat . punctuate semi
+                        . fmap dQText $ xs)
+
+dQText :: String -> Doc
+dQText = doubleQuotes . text
+
+{-
+import System.Cmd
+import System.Exit
+graphToDotPng :: FilePath -> [(String,[String])] -> IO Bool
+graphToDotPng fpre g = do
+  let [dot,png] = fmap (fpre++) [".dot",".png"]
+  writeFile dot
+    . render . ppGraph
+      -- . fmap (show***fmap show)
+        $ g
+  ((==ExitSuccess) `fmap`) .system . intercalate " " $
+    -- ["cat",dot,"|","dot -Tpng",">",png,"2>/dev/null;","gliv",png,"&"]
+    ["cat",dot,"|","dot -Tpng",">",png,"2>/dev/null;","display",png,"&"]
+
+graphToDotPdf :: FilePath -> [(String,[String])] -> IO Bool
+graphToDotPdf fpre g = do
+  let [dot,png] = fmap (fpre++) [".dot",".pdf"]
+  writeFile dot
+    . render . ppGraph
+      -- . fmap (show***fmap show)
+        $ g
+  ((==ExitSuccess) `fmap`) .system . intercalate " " $
+    -- ["cat",dot,"|","dot -Tpng",">",png,"2>/dev/null;","gliv",png,"&"]
+    ["cat",dot,"tred","|","dot -Tpdf",">",png,"2>/dev/null;","evince",png,"&"]
+-}
+
+------------------------------------------------
diff --git a/src/GHC/Vacuum/Q.hs b/src/GHC/Vacuum/Q.hs
new file mode 100644
--- /dev/null
+++ b/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)
+
+
+
+
+
+------------------------------------------------
+
+
+
diff --git a/src/GHC/Vacuum/Types.hs b/src/GHC/Vacuum/Types.hs
new file mode 100644
--- /dev/null
+++ b/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}
+
+------------------------------------------------
+
diff --git a/src/GHC/Vacuum/Util.hs b/src/GHC/Vacuum/Util.hs
new file mode 100644
--- /dev/null
+++ b/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#)
+-}
+
+------------------------------------------------
+
+
+
diff --git a/vacuum.cabal b/vacuum.cabal
--- a/vacuum.cabal
+++ b/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 @@
   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