Update docu for ppHeapTree
[ghc-heap-view.git] / src / GHC / HeapView.hs
index 2d114e2..7b03017 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash, UnboxedTuples, CPP, ForeignFunctionInterface, GHCForeignImportPrim, UnliftedFFITypes, BangPatterns, RecordWildCards, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
 {-|
 Module      :  GHC.HeapView
 Copyright   :  (c) 2012 Joachim Breitner
@@ -9,11 +9,11 @@ With this module, you can investigate the heap representation of Haskell
 values, i.e. to investigate sharing and lazy evaluation.
 -}
 
-{-# LANGUAGE MagicHash, UnboxedTuples, CPP, ForeignFunctionInterface, GHCForeignImportPrim, UnliftedFFITypes, BangPatterns, RecordWildCards #-}
 
 module GHC.HeapView (
     -- * Heap data types
-    Closure(..),
+    GenClosure(..),
+    Closure,
     allPtrs,
     ClosureType(..),
     StgInfoTable(..),
@@ -22,21 +22,61 @@ module GHC.HeapView (
     getClosureData,
     getBoxedClosureData,
     getClosureRaw,
+    -- * Pretty printing
+    ppPrintClosure,
+    -- * Heap maps
+    -- $heapmap
+    HeapTree(..),
+    buildHeapTree,
+    ppHeapTree,
+    HeapGraphEntry(..),
+    HeapGraphIndex,
+    HeapGraph(..),
+    lookupHeapGraph,
+    heapGraphRoot,
+    buildHeapGraph,
+    ppHeapGraph,
     -- * Boxes
     Box(..),
     asBox,
+    -- * Weak boxes
+    WeakBox,
+    weakBox,
+    isAlive,
+    derefWeakBox,
+    WeakClosure,
+    weakenClosure,
     )
     where
 
-import GHC.Exts
-import GHC.Arr (Array(..))
+import GHC.Exts         ( Any,
+                          Ptr(..), Addr#, Int(..), Word(..), Word#, Int#,
+                          ByteArray#, Array#, sizeofByteArray#, sizeofArray#, indexArray#, indexWordArray#,
+                          unsafeCoerce# )
 
-import GHC.Constants ( wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS )
+import GHC.Arr          (Array(..))
 
-import Foreign
+import GHC.Constants    ( wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS )
+
+import System.IO.Unsafe ( unsafePerformIO )
+
+import Foreign          hiding ( unsafePerformIO )
 import Numeric          ( showHex )
 import Data.Char
-import Data.List        ( intersperse )
+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"
 
@@ -66,9 +106,9 @@ instance Show Box where
           '0':'x':(replicate (2*wORD_SIZE - length ls) '0') ++ ls
 
 instance Eq Box where
-  Box a == Box b = case reallyUnsafePtrEquality# a b of
-    1# -> True
-    _  -> False
+  Box a == Box b = case reallyUnsafePtrEqualityUpToTag# a b of
+    0# -> False
+    _  -> True
 
 {-|
   This takes an arbitrary value and puts it into a box. Note that calls like
@@ -121,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
@@ -142,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
  -}
@@ -246,11 +269,15 @@ data ClosureType =
 {-| This is the main data type of this module, representing a Haskell value on
   the heap. This reflects
   <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/Closures.h>
+
+  The data type is parametrized by the type to store references in, which
+  should be either 'Box' or 'WeakBox', with appropriate type synonyms 'Closure'
+  and 'WeakClosure'.
  -}
-data Closure =
+data GenClosure b =
     ConsClosure {
         info         :: StgInfoTable 
-        , ptrArgs    :: [Box]
+        , ptrArgs    :: [b]
         , dataArgs   :: [Word]
         , pkg        :: String
         , modl       :: String
@@ -258,40 +285,45 @@ data Closure =
     } |
     ThunkClosure {
         info         :: StgInfoTable 
-        , ptrArgs    :: [Box]
+        , ptrArgs    :: [b]
         , dataArgs   :: [Word]
     } |
     SelectorClosure {
         info         :: StgInfoTable 
-        , selectee   :: Box
+        , selectee   :: b
     } |
     IndClosure {
         info         :: StgInfoTable 
-        , indirectee   :: Box
+        , indirectee   :: b
     } |
     BlackholeClosure {
         info         :: StgInfoTable 
-        , indirectee   :: Box
+        , indirectee   :: b
     } |
     APClosure {
         info         :: StgInfoTable 
         , arity      :: HalfWord
         , n_args     :: HalfWord
-        , fun        :: Box
-        , payload    :: [Box]
+        , fun        :: b
+        , payload    :: [b]
     } |
     PAPClosure {
         info         :: StgInfoTable 
         , arity      :: HalfWord
         , n_args     :: HalfWord
-        , fun        :: Box
-        , payload    :: [Box]
+        , fun        :: b
+        , payload    :: [b]
+    } |
+    APStackClosure {
+        info         :: StgInfoTable 
+        , fun        :: b
+        , payload    :: [b]
     } |
     BCOClosure {
         info         :: StgInfoTable 
-        , instrs     :: Box
-        , literals   :: Box
-        , bcoptrs    :: Box
+        , instrs     :: b
+        , literals   :: b
+        , bcoptrs    :: b
         , arity      :: HalfWord
         , size       :: HalfWord
         , bitmap     :: Word
@@ -305,43 +337,46 @@ data Closure =
         info         :: StgInfoTable 
         , mccPtrs    :: Word
         , mccSize    :: Word
-        , mccPayload :: [Box]
+        , mccPayload :: [b]
         -- Card table ignored
     } |
     MutVarClosure {
         info         :: StgInfoTable 
-        , var        :: Box
+        , var        :: b
     } |
     MVarClosure {
         info         :: StgInfoTable 
-        , queueHead  :: Box
-        , queueTail  :: Box
-        , value      :: Box
+        , queueHead  :: b
+        , queueTail  :: b
+        , value      :: b
     } |
     FunClosure {
         info         :: StgInfoTable 
-        , ptrArgs    :: [Box]
+        , ptrArgs    :: [b]
         , dataArgs   :: [Word]
     } |
     BlockingQueueClosure {
         info         :: StgInfoTable 
-        , link       :: Box
-        , blackHole  :: Box
-        , owner      :: Box
-        , queue      :: Box
+        , link       :: b
+        , blackHole  :: b
+        , owner      :: b
+        , queue      :: b
     } |
     OtherClosure {
         info         :: StgInfoTable 
-        , hvalues    :: [Box]
+        , hvalues    :: [b]
         , rawWords   :: [Word]
     } |
     UnsupportedClosure {
         info         :: StgInfoTable 
     }
- deriving (Show)
+ deriving (Show, Functor, Foldable, Traversable)
+
+
+type Closure = GenClosure Box
 
 -- | For generic code, this function returns all referenced closures. 
-allPtrs :: Closure -> [Box]
+allPtrs :: GenClosure b -> [b]
 allPtrs (ConsClosure {..}) = ptrArgs
 allPtrs (ThunkClosure {..}) = ptrArgs
 allPtrs (SelectorClosure {..}) = [selectee]
@@ -349,6 +384,7 @@ allPtrs (IndClosure {..}) = [indirectee]
 allPtrs (BlackholeClosure {..}) = [indirectee]
 allPtrs (APClosure {..}) = fun:payload
 allPtrs (PAPClosure {..}) = fun:payload
+allPtrs (APStackClosure {..}) = fun:payload
 allPtrs (BCOClosure {..}) = [instrs,literals,bcoptrs]
 allPtrs (ArrWordsClosure {..}) = []
 allPtrs (MutArrClosure {..}) = mccPayload
@@ -364,6 +400,7 @@ allPtrs (UnsupportedClosure {..}) = []
 #ifdef PRIM_SUPPORTS_ANY
 foreign import prim "aToWordzh" aToWord# :: Any -> Word#
 foreign import prim "slurpClosurezh" slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)
+foreign import prim "reallyUnsafePtrEqualityUpToTag" reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
 #else
 -- Workd-around code until http://hackage.haskell.org/trac/ghc/ticket/5931 was
 -- accepted
@@ -371,6 +408,8 @@ foreign import prim "slurpClosurezh" slurpClosure# :: Any -> (# Addr#, ByteArray
 -- foreign import prim "aToWordzh" aToWord'# :: Addr# -> Word#
 foreign import prim "slurpClosurezh" slurpClosure'# :: Word#  -> (# Addr#, ByteArray#, Array# b #)
 
+foreign import prim "reallyUnsafePtrEqualityUpToTag" reallyUnsafePtrEqualityUpToTag'# :: Word# -> Word# -> Int#
+
 -- This is a datatype that has the same layout as Ptr, so that by
 -- unsafeCoerce'ing, we obtain the Addr of the wrapped value
 data Ptr' a = Ptr' a
@@ -380,6 +419,9 @@ aToWord# a = case Ptr' a of mb@(Ptr' _) -> case unsafeCoerce# mb :: Word of W# a
 
 slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)
 slurpClosure# a = slurpClosure'# (aToWord# a)
+
+reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
+reallyUnsafePtrEqualityUpToTag# a b = reallyUnsafePtrEqualityUpToTag'# (aToWord# a) (aToWord# b)
 #endif
 
 --pClosure x = do
@@ -508,6 +550,9 @@ getClosureData x = do
                 (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
                 (head ptrs) (tail ptrs)
 
+        AP_STACK ->
+            return $ APStackClosure itbl (head ptrs) (tail ptrs)
+
         THUNK_SELECTOR ->
             return $ SelectorClosure itbl (head ptrs)
 
@@ -550,3 +595,221 @@ getClosureData x = do
 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.
+newtype WeakBox = WeakBox (Weak Box)
+
+
+type WeakClosure = GenClosure WeakBox
+
+instance Show WeakBox where
+    showsPrec p (WeakBox w) rs = case unsafePerformIO (deRefWeak w) of
+        Nothing -> let txt = "(freed)" in
+                   replicate (2*wORD_SIZE - length txt) ' ' ++ txt ++ rs
+        Just b -> showsPrec p b rs
+
+{-|
+  Turns a 'Box' into a 'WeakBox', allowing the referenced value to be garbage
+  collected.
+-}
+weakBox :: Box -> IO WeakBox
+weakBox b@(Box a) = WeakBox `fmap` mkWeak a b Nothing
+
+{-|
+  Checks whether the value referenced by a weak box is still alive
+-}
+isAlive :: WeakBox -> IO Bool
+isAlive (WeakBox w) = isJust `fmap` deRefWeak w
+
+{-|
+  Dereferences the weak box
+-}
+derefWeakBox :: WeakBox -> IO (Maybe Box)
+derefWeakBox (WeakBox w) = deRefWeak w
+
+weakenClosure :: Closure -> IO WeakClosure
+weakenClosure = T.mapM weakBox