Update docu for ppHeapTree
[ghc-heap-view.git] / src / GHC / HeapView.hs
index b460be9..7b03017 100644 (file)
@@ -18,13 +18,24 @@ module GHC.HeapView (
     ClosureType(..),
     StgInfoTable(..),
     HalfWord,
-    -- * Pretty printing
-    prettyPrintClosure,
-    prettyDeeplyPrintClosure,
     -- * Reading from the heap
     getClosureData,
     getBoxedClosureData,
     getClosureRaw,
+    -- * Pretty printing
+    ppPrintClosure,
+    -- * Heap maps
+    -- $heapmap
+    HeapTree(..),
+    buildHeapTree,
+    ppHeapTree,
+    HeapGraphEntry(..),
+    HeapGraphIndex,
+    HeapGraph(..),
+    lookupHeapGraph,
+    heapGraphRoot,
+    buildHeapGraph,
+    ppHeapGraph,
     -- * Boxes
     Box(..),
     asBox,
@@ -55,9 +66,17 @@ import Data.Char
 import Data.List        ( intersperse, intercalate )
 import Data.Maybe       ( isJust )
 import System.Mem.Weak
+import Data.Functor
 import Data.Foldable    ( Foldable )
 import Data.Traversable ( Traversable )
 import qualified Data.Traversable as T
+import qualified Data.IntMap as M
+import Control.Monad
+import Control.Monad.Trans.State
+import Control.Monad.Trans.Class
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Writer.Strict
+import Control.Arrow    ( first, second )
 
 #include "ghcautoconf.h"
 
@@ -142,7 +161,7 @@ instance Storable StgInfoTable where
       = error "Storable StgInfoTable is read-only"
 
    peek a0
-      = runState (castPtr a0)
+      = flip (evalStateT) (castPtr a0)
       $ do
            ptrs'   <- load
            nptrs'  <- load
@@ -163,34 +182,17 @@ load :: Storable a => PtrIO a
 load = do addr <- advance
           lift (peek addr)
 
-type PtrIO = State (Ptr Word8) IO
+type PtrIO = StateT (Ptr Word8) IO
 
 advance :: Storable a => PtrIO (Ptr a)
-advance = State adv where
+advance = StateT adv where
     adv addr = case castPtr addr of { addrCast -> return
-        (addr `plusPtr` sizeOfPointee addrCast, addrCast) }
+        (addrCast, addr `plusPtr` sizeOfPointee addrCast) }
 
 sizeOfPointee :: (Storable a) => Ptr a -> Int
 sizeOfPointee addr = sizeOf (typeHack addr)
     where typeHack = undefined :: Ptr a -> a
 
-{-
-   Embedded StateT, also from ByteCodeItbls
- -}
-
-newtype State s m a = State (s -> m (s, a))
-
-instance Monad m => Monad (State s m) where
-  return a      = State (\s -> return (s, a))
-  State m >>= k = State (\s -> m s >>= \(s', a) -> case k a of State n -> n s')
-  fail str      = State (\_ -> fail str)
-
-lift :: Monad m => m a -> State s m a
-lift m = State (\s -> m >>= \a -> return (s, a))
-
-runState :: (Monad m) => s -> State s m a -> m a
-runState s (State m) = m s >>= return . snd
-
 {-
    Data Type representing Closures
  -}
@@ -394,71 +396,6 @@ allPtrs (OtherClosure {..}) = hvalues
 allPtrs (UnsupportedClosure {..}) = []
 
 
--- | A pretty-printer that tries to generate valid Haskell for evalutated data.
--- It assumes that for the included boxes, you already replaced them by Strings
--- using 'Data.Foldable.map' or, if you need to do IO, 'Data.Foldable.mapM'.
---
--- The boolean parameter indicates whether braces should be added when the
--- result is an application, e.g. a non-nullary constructor.
-prettyPrintClosure :: Bool -> GenClosure String -> String
-prettyPrintClosure ab c = case c of
-    ConsClosure {..} -> addParens $
-        name : ptrArgs ++ map show dataArgs
-    ThunkClosure {..} -> addParens $
-        "_thunk" : ptrArgs ++ map show dataArgs
-    SelectorClosure {..} -> addParens
-        ["_sel", selectee]
-    IndClosure {..} -> addParens
-        ["_ind", indirectee]
-    BlackholeClosure {..} -> addParens
-        ["_bh", indirectee]
-    APClosure {..} -> addParens $
-        fun : payload
-    PAPClosure {..} -> addParens $
-        fun : payload
-    APStackClosure {..} -> addParens $
-        fun : payload
-    BCOClosure {..} -> addParens
-        ["_bco"]
-    ArrWordsClosure {..} -> addParens
-        ["toArray", intercalate "," (map show arrWords) ]
-    MutArrClosure {..} -> addParens
-        ["toMutArray", intercalate "," mccPayload]
-    MutVarClosure {..} -> addParens $
-        ["_mutVar", var]
-    MVarClosure {..} -> addParens $
-        ["MVar", value]
-    FunClosure {..} -> 
-        "_fun" ++ bracketize (ptrArgs ++ map show dataArgs)
-    BlockingQueueClosure {..} -> 
-        "_blockingQueue"
-    OtherClosure {..} ->
-        "_other"
-    UnsupportedClosure {..} ->
-        "_unsupported"
-  where
-    addParens [] = "()" -- not used
-    addParens [a] = a 
-    addParens xs = if ab
-                   then "(" ++ intercalate " " xs ++ ")"
-                   else intercalate " " xs 
-    bracketize [] = ""
-    bracketize xs = "[" ++ intercalate "," xs ++ "]"
-    
--- | Using 'prettyPrintClosure', prints a closure recursively. Will diverge for
--- cyclic or infinite input.
--- 
--- Example output for @[Just 4, Nothing]@:
---
--- > : (Just (I# 4)) (: Nothing [])
-prettyDeeplyPrintClosure :: Closure -> IO String
-prettyDeeplyPrintClosure c = prettyPrintClosure False `fmap` T.mapM printBox c
-  where
-    printBox b = do
-        c' <- getBoxedClosureData b
-        c'' <- T.mapM printBox c'
-        return $ prettyPrintClosure True c''
-
 
 #ifdef PRIM_SUPPORTS_ANY
 foreign import prim "aToWordzh" aToWord# :: Any -> Word#
@@ -659,6 +596,188 @@ getBoxedClosureData :: Box -> IO Closure
 getBoxedClosureData (Box a) = getClosureData a
 
 
+isChar :: GenClosure b -> Maybe Char
+isChar (ConsClosure { name = "C#", dataArgs = [ch], ptrArgs = []}) = Just (chr (fromIntegral ch))
+isChar _ = Nothing
+
+isCons :: GenClosure b -> Maybe (b, b)
+isCons (ConsClosure { name = ":", dataArgs = [], ptrArgs = [h,t]}) = Just (h,t)
+isCons _ = Nothing
+
+isNil :: GenClosure b -> Bool
+isNil (ConsClosure { name = "[]", dataArgs = [], ptrArgs = []}) = True
+isNil _ = False
+
+-- | A pretty-printer that tries to generate valid Haskell for evalutated data.
+-- It assumes that for the included boxes, you already replaced them by Strings
+-- using 'Data.Foldable.map' or, if you need to do IO, 'Data.Foldable.mapM'.
+--
+-- The parameter gives the precedendence, to avoid avoidable parenthesises.
+ppPrintClosure :: (Int -> b -> String) -> Int -> GenClosure b -> String
+ppPrintClosure showBox prec c = case c of
+    _ | Just ch <- isChar c -> app $
+        ["C#", show ch]
+    _ | Just (h,t) <- isCons c -> addBraces (5 <= prec) $
+        showBox 5 h ++ " : " ++ showBox 4 t
+    ConsClosure {..} -> app $
+        name : map (showBox 10) ptrArgs ++ map show dataArgs
+    ThunkClosure {..} -> app $
+        "_thunk" : map (showBox 10) ptrArgs ++ map show dataArgs
+    SelectorClosure {..} -> app
+        ["_sel", showBox 10 selectee]
+    IndClosure {..} -> app
+        ["_ind", showBox 10 indirectee]
+    BlackholeClosure {..} -> app
+        ["_bh",  showBox 10 indirectee]
+    APClosure {..} -> app $ map (showBox 10) $
+        fun : payload
+    PAPClosure {..} -> app $ map (showBox 10) $
+        fun : payload
+    APStackClosure {..} -> app $ map (showBox 10) $
+        fun : payload
+    BCOClosure {..} -> app
+        ["_bco"]
+    ArrWordsClosure {..} -> app
+        ["toArray", intercalate "," (map show arrWords) ]
+    MutArrClosure {..} -> app
+        ["toMutArray", intercalate "," (map (showBox 10) mccPayload)]
+    MutVarClosure {..} -> app $
+        ["_mutVar", (showBox 10) var]
+    MVarClosure {..} -> app $
+        ["MVar", (showBox 10) value]
+    FunClosure {..} -> 
+        "_fun" ++ braceize (map (showBox 0) ptrArgs ++ map show dataArgs)
+    BlockingQueueClosure {..} -> 
+        "_blockingQueue"
+    OtherClosure {..} ->
+        "_other"
+    UnsupportedClosure {..} ->
+        "_unsupported"
+  where
+    addBraces True t = "(" ++ t ++ ")"
+    addBraces False t = t
+    app [] = "()"
+    app [a] = a 
+    app xs = addBraces (10 <= prec) (intercalate " " xs)
+    braceize [] = ""
+    braceize xs = "{" ++ intercalate "," xs ++ "}"
+    
+-- $heapmap
+-- For more global views of the heap, you can use heap maps. These come in
+-- variations, either a trees or as graphs, depending on
+-- whether you want to detect cycles and sharing or not.
+
+-- | Heap maps as tree, i.e. no sharing, no cycles.
+data HeapTree = HeapTree WeakBox (GenClosure HeapTree) | EndOfHeapTree
+
+heapTreeClosure :: HeapTree -> Maybe (GenClosure HeapTree)
+heapTreeClosure (HeapTree _ c) = Just c
+heapTreeClosure EndOfHeapTree = Nothing
+
+-- | Constructing an 'HeapTree' from a boxed value. It takes a depth parameter
+-- that prevents it from running ad infinitum for cyclic or infinite
+-- structures.
+buildHeapTree :: Int -> Box -> IO HeapTree
+buildHeapTree 0 _ = do
+    return $ EndOfHeapTree
+buildHeapTree n b = do
+    w <- weakBox b
+    c <- getBoxedClosureData b
+    c' <- T.mapM (buildHeapTree (n-1)) c
+    return $ HeapTree w c'
+
+-- | Pretty-Printing a heap Tree
+-- 
+-- Example output for @[Just 4, Nothing, *something*]@, where *something* is an
+-- unevaluated expression depending on the command line argument.
+--
+-- >[Just (I# 4),Nothing,Just (_thunk ["arg1","arg2"])]
+ppHeapTree :: HeapTree -> String
+ppHeapTree = go 0
+  where
+    go _ EndOfHeapTree = "..."
+    go prec t@(HeapTree _ c')
+        | Just s <- isHeapTreeString t = show s
+        | Just l <- isHeapTreeList t   = "[" ++ intercalate "," (map ppHeapTree l) ++ "]"
+        | otherwise                    =  ppPrintClosure go prec c'
+
+isHeapTreeList :: HeapTree -> Maybe ([HeapTree])
+isHeapTreeList tree = do
+    c <- heapTreeClosure tree
+    if isNil c
+      then return []
+      else do
+        (h,t) <- isCons c
+        t' <- isHeapTreeList t
+        return $ (:) h t'
+
+isHeapTreeString :: HeapTree -> Maybe String
+isHeapTreeString = mapM (isChar <=< heapTreeClosure) <=< isHeapTreeList
+
+-- | For heap graphs, i.e. data structures that also represent sharing and
+-- cyclic structures, these are the entries. If the referenced value is
+-- @Nothing@, then we do not have that value in the map, most likely due to
+-- exceeding the recursion bound passed to 'buildHeapGraph'.
+data HeapGraphEntry = HeapGraphEntry WeakBox (GenClosure (Maybe HeapGraphIndex))
+    deriving (Show)
+type HeapGraphIndex = Int
+
+-- | The whole graph. The suggested interface is to only use 'lookupHeapGraph',
+-- as the internal representation may change. Nevertheless, we export it here:
+-- Sometimes the user knows better what he needs than we do.
+newtype HeapGraph = HeapGraph (M.IntMap HeapGraphEntry)
+    deriving (Show)
+
+lookupHeapGraph :: HeapGraphIndex -> HeapGraph -> Maybe HeapGraphEntry
+lookupHeapGraph i (HeapGraph m) = M.lookup i m
+
+heapGraphRoot :: HeapGraphIndex
+heapGraphRoot = 0
+
+-- | Creates a 'HeapGraph' for the value in the box, but not recursing further
+-- than the given limit. The initial value has index 'heapGraphRoot'.
+buildHeapGraph :: Int -> Box -> IO HeapGraph
+buildHeapGraph limit initialBox = do
+    let initialState = ([], [0..])
+    HeapGraph <$> execWriterT (runStateT (add limit initialBox) initialState)
+  where
+    add 0 _ = return Nothing
+    add n b = do
+        -- If the box is in the map, return the index
+        (existing,_) <- get
+        case lookup b existing of
+            Just i -> return $ Just i
+            Nothing -> do
+                -- Otherwise, allocate a new index
+                i <- nextI
+                -- And register it
+                modify (first ((b,i):))
+                c <- liftIO $ getBoxedClosureData b
+                -- Find indicies for all boxes contained in the map
+                c' <- T.mapM (add (n-1)) c
+                w <- liftIO $ weakBox b
+                -- Add add the resulting closure to the map
+                lift $ tell (M.singleton i (HeapGraphEntry w c'))
+                return $ Just i
+    nextI = do
+        i <- gets (head . snd)
+        modify (second tail)
+        return i
+
+-- | Pretty-prints a HeapGraph. The resulting string contains newlines. Example for @repeat "Ho"@:
+--
+-- >let x0 = x1 : x2
+-- >    x1 = C# 'H'
+-- >    x2 = x3 : x0
+-- >    x3 = C# 'o'
+-- >in x0
+ppHeapGraph :: HeapGraph -> String
+ppHeapGraph (HeapGraph m) = "let " ++ intercalate "\n    " (map ppEntry (M.assocs m)) ++ "\nin x0"
+  where
+    ppEntry (i,HeapGraphEntry _ c) = "x" ++ show i ++ " = " ++ ppPrintClosure go 0 c
+    go _ Nothing = "..."
+    go _ (Just i) = "x" ++ show i
+
 -- | An a variant of 'Box' that does not keep the value alive.
 -- 
 -- Like 'Box', its 'Show' instance is highly unsafe.