ghc-heap-view 0.4.2.0 → 0.5

raw patch · 7 files changed

+610/−123 lines, 7 filesdep +binarydep +bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: binary, bytestring

API changes (from Hackage documentation)

Files

• cbits/HeapViewPrim.cmm +2/−2
• ghc-heap-view.cabal +6/−2
• ghci +2/−2
• src/GHC/AssertNF.hs +3/−3
• src/GHC/Disassembler.hs +304/−0
• src/GHC/HeapView.hs +224/−114
• src/GHC/HeapView/Debug.hs +69/−0

@@ -7,10 +7,10 @@     	RET_N(clos); } +// Taken from stg_unpackClosurezh in rts/PrimOps.cmm slurpClosurezh { /* args: R1 = closure to analyze */-// TODO: Consider the absence of ptrs or nonptrs as a special case ?      W_ clos, len;     clos = UNTAG(R1);@@ -18,7 +18,7 @@     W_ info;     info = %GET_STD_INFO(clos); -    (len) = foreign "C" gtc_heap_view_closureSize(clos "ptr") [];+    (len) = foreign "C" gtc_heap_view_closureSize(clos "ptr") [R1];      W_ data_arr_sz;     data_arr_sz = SIZEOF_StgArrWords  + WDS(len);

@@ -1,5 +1,5 @@ Name:                ghc-heap-view-Version:             0.4.2.0+Version:             0.5 Synopsis:            Extract the heap representation of Haskell values and thunks Description:   This library provides functions to introspect the Haskell heap, for example@@ -54,15 +54,19 @@     Default: False  Library+  Default-Language:    Haskell2010   Exposed-modules:     GHC.HeapView      GHC.AssertNF -  Default-Language:    Haskell2010+    GHC.Disassembler+    GHC.HeapView.Debug   Build-depends:     base >= 4.5 && < 4.7,     containers,     transformers,     template-haskell,+    bytestring,+    binary,     ghc   C-Sources: cbits/HeapView.c cbits/HeapViewPrim.cmm   Hs-source-dirs: src/

@@ -1,3 +1,3 @@-:def setPrintHeapDepth \x -> return $ ":def! printHeap \\x -> return $ \"GHC.HeapView.buildHeapGraph (" ++ x ++ ") (GHC.HeapView.asBox (\" ++ x ++ \")) >>= putStrLn . GHC.HeapView.ppHeapGraph\""+:def! setPrintHeapDepth \x -> return $ ":def! printHeap \\x -> return $ \"GHC.HeapView.buildHeapGraph (" ++ x ++ ") () (GHC.HeapView.asBox (\" ++ x ++ \")) >>= putStrLn . GHC.HeapView.ppHeapGraph\"" -:def printHeap \x -> return $ "GHC.HeapView.buildHeapGraph 1000 (GHC.HeapView.asBox (" ++ x ++ ")) >>= putStrLn . GHC.HeapView.ppHeapGraph"+:setPrintHeapDepth 1000

@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns, DoAndIfThenElse #-}  {-| Module      :  GHC.AssertNF@@ -100,8 +100,8 @@     when en $ do          depths <- assertNFBoxed 0 (asBox x)         unless (null depths) $ do-            g <- buildHeapGraph (maximum depths + 3) (asBox x)-                -- +3 for good mesure; application don't look good otherwise+            g <- buildHeapGraph (maximum depths + 3) () (asBox x)+                -- +3 for good mesure; applications don't look good otherwise             traceIO $ str ++ ": " ++ show (length depths) ++ " thunks found:\n" ++                 ppHeapGraph g 

@@ -0,0 +1,304 @@+{-# LANGUAGE CPP, ScopedTypeVariables, DoAndIfThenElse, NondecreasingIndentation, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+-- | A disassembler for ByteCode objects as used by GHCi.+module GHC.Disassembler (+    toBytes,+    disassemble,+    BCI(..) ) where++import qualified Data.ByteString.Lazy as BS+import Data.ByteString.Lazy (ByteString)+import Data.ByteString.Lazy.Builder+import Data.ByteString.Lazy.Builder.Extras+import Data.Binary.Get+import Data.Word+import Data.Int+import Data.Monoid+import Data.Bits+import Data.Functor+import Data.Foldable    ( Foldable )+import Data.Traversable ( Traversable )++#include "ghcautoconf.h"+#include "rts/Bytecodes.h"++-- | Converts the first @n@ bytes of this list of Words to a ByteString.+toBytes :: Word -> [Word] -> ByteString+toBytes n =+    BS.take (fromIntegral n) .+    toLazyByteString .+    mconcat .+    map (wordHost . fromIntegral)++-- | Given a list of pointers, a list of literals and a ByteString containing+-- byte code instructions, disassembles them into a list of byte code instructions.+disassemble :: forall box. [box] -> [Word] -> ByteString -> [BCI box]+disassemble ptrs lits = runGet $ do+    -- Ignore length tag. Needs to be skipped with GHC versions with+    -- http://hackage.haskell.org/trac/ghc/ticket/7518 included+    _ <- getWord16host+#if SIZEOF_VOID_P == 8+    _ <- getWord16host+    _ <- getWord16host+#endif+    _n <- getWord16host+    nextInst+  where+    getLiteral :: Get Word+    getLiteral = ((!!) lits) . fromIntegral <$> getWord16host++    getLiterals = do+        p <- fromIntegral <$> getWord16host+        n <- fromIntegral <$> getWord16host+        return $ take n (drop p lits)++    getAddr :: Int -> box+    getAddr p = ptrs !! p++    getPtr :: Get box+    getPtr = getAddr . fromIntegral <$> getWord16host++    nextInst :: Get [BCI box]+    nextInst = do+        e <- isEmpty+        if e then return [] else do+        w <- getWord16host+        let large = 0 /= w .&. 0x8000++        let getLarge = if large then getWordhost else fromIntegral `fmap` getWord16host+        let getLargeInt = if large then getInthost else fromIntegral `fmap` getInt16host++        i <- case w .&. 0xff of+            bci_STKCHECK -> do+                n <- getLarge+                return $ BCISTKCHECK (n + 1)+            bci_PUSH_L -> do+                o1 <- getWord16host+                return $ BCIPUSH_L o1+            bci_PUSH_LL -> do+                o1 <- getWord16host+                o2 <- getWord16host+                return $ BCIPUSH_LL o1 o2+            bci_PUSH_LLL -> do+                o1 <- getWord16host+                o2 <- getWord16host+                o3 <- getWord16host+                return $ BCIPUSH_LLL o1 o2 o3+            bci_PUSH_G -> do+                p <- getPtr+                return $ BCIPUSH_G p+            bci_PUSH_ALTS -> do+                p <- getPtr+                return $ BCIPUSH_ALTS p+            bci_PUSH_ALTS_P -> do+                p <- getPtr+                return $ BCIPUSH_ALTS_P p+            bci_PUSH_ALTS_N -> do+                p <- getPtr+                return $ BCIPUSH_ALTS_N p+            bci_PUSH_ALTS_F -> do+                p <- getPtr+                return $ BCIPUSH_ALTS_F p+            bci_PUSH_ALTS_D -> do+                p <- getPtr+                return $ BCIPUSH_ALTS_D p+            bci_PUSH_ALTS_L -> do+                p <- getPtr+                return $ BCIPUSH_ALTS_L p+            bci_PUSH_ALTS_V -> do+                p <- getPtr+                return $ BCIPUSH_ALTS_V p+            bci_PUSH_UBX -> do+                ubx_lits <- getLiterals+                return $ BCIPUSH_UBX ubx_lits+            bci_PUSH_APPLY_N -> do+                return BCIPUSH_APPLY_N+            bci_PUSH_APPLY_F -> do+                return BCIPUSH_APPLY_F+            bci_PUSH_APPLY_D -> do+                return BCIPUSH_APPLY_D+            bci_PUSH_APPLY_L -> do+                return BCIPUSH_APPLY_L+            bci_PUSH_APPLY_V -> do+                return BCIPUSH_APPLY_V+            bci_PUSH_APPLY_P -> do+                return BCIPUSH_APPLY_P+            bci_PUSH_APPLY_PP -> do+                return BCIPUSH_APPLY_PP+            bci_PUSH_APPLY_PPP -> do+                return BCIPUSH_APPLY_PPP+            bci_PUSH_APPLY_PPPP -> do+                return BCIPUSH_APPLY_PPPP+            bci_PUSH_APPLY_PPPPP -> do+                return BCIPUSH_APPLY_PPPPP+            bci_PUSH_APPLY_PPPPPP -> do+                return BCIPUSH_APPLY_PPPPPP+            bci_SLIDE -> do+                p <- getWord16host+                n <- getWord16host+                return $ BCISLIDE p n+            bci_ALLOC_AP -> do+                n <- getWord16host+                return $ BCIALLOC_AP n+            bci_ALLOC_AP_NOUPD -> do+                n <- getWord16host+                return $ BCIALLOC_AP_NOUPD n+            bci_ALLOC_PAP -> do+                a <- getWord16host+                n <- getWord16host+                return $ BCIALLOC_PAP a n+            bci_MKAP -> do+                n <- getWord16host+                s <- getWord16host+                return $ BCIMKAP n s+            bci_MKPAP -> do+                n <- getWord16host+                s <- getWord16host+                return $ BCIMKPAP n s+            bci_UNPACK -> do+                n <- getWord16host+                return $ BCIUNPACK n+            bci_PACK -> do+                p <- getLiteral+                n <- getWord16host+                return $ BCIPACK p n+            bci_TESTLT_I -> do+                d <- getLargeInt+                t <- getLargeInt+                return $ BCITESTLT_I d t+            bci_TESTEQ_I -> do+                d <- getLargeInt+                t <- getLargeInt+                return $ BCITESTEQ_I d t+            bci_TESTLT_W -> do+                d <- getLarge+                t <- getLargeInt+                return $ BCITESTLT_W d t+            bci_TESTEQ_W -> do+                d <- getLarge+                t <- getLargeInt+                return $ BCITESTEQ_W d t+            bci_TESTLT_F -> do+                d <- getLarge+                t <- getLargeInt+                return $ BCITESTLT_F d t+            bci_TESTEQ_F -> do+                d <- getLarge+                t <- getLargeInt+                return $ BCITESTEQ_F d t+            bci_TESTLT_D -> do+                d <- getLarge+                t <- getLargeInt+                return $ BCITESTLT_D d t+            bci_TESTEQ_D -> do+                d <- getLarge+                t <- getLargeInt+                return $ BCITESTEQ_D d t+            bci_TESTLT_P -> do+                d <- getWord16host+                t <- getLargeInt+                return $ BCITESTLT_P d t+            bci_TESTEQ_P -> do+                d <- getWord16host+                t <- getLargeInt+                return $ BCITESTEQ_P d t+            bci_CASEFAIL -> do+                return BCICASEFAIL+            bci_JMP -> do+                return BCIJMP+            bci_CCALL -> do+                p <- getLiteral+                return $ BCICCALL p+            bci_SWIZZLE -> do+                p <- getWord16host+                n <- getInt16host+                return $ BCISWIZZLE p n+            bci_ENTER -> do+                return BCIENTER+            bci_RETURN -> do+                return BCIRETURN+            bci_RETURN_P -> do+                return BCIRETURN_P+            bci_RETURN_N -> do+                return BCIRETURN_N+            bci_RETURN_F -> do+                return BCIRETURN_F+            bci_RETURN_D -> do+                return BCIRETURN_D+            bci_RETURN_L -> do+                return BCIRETURN_L+            bci_RETURN_V -> do+                return BCIRETURN_V+            bci_BRK_FUN -> do+                _ <- getWord16host+                _ <- getWord16host+                _ <- getWord16host+                return BCIBRK_FUN+            x -> error $ "Unknown opcode " ++ show x+        (i :) `fmap` nextInst+            ++-- | The various byte code instructions that GHCi supports.+data BCI box+    = BCISTKCHECK Word+    | BCIPUSH_L Word16+    | BCIPUSH_LL Word16 Word16 +    | BCIPUSH_LLL Word16 Word16 Word16+    | BCIPUSH_G box+    | BCIPUSH_ALTS box+    | BCIPUSH_ALTS_P box+    | BCIPUSH_ALTS_N box+    | BCIPUSH_ALTS_F box+    | BCIPUSH_ALTS_D box+    | BCIPUSH_ALTS_L box+    | BCIPUSH_ALTS_V box+    | BCIPUSH_UBX [Word]+    | BCIPUSH_APPLY_N+    | BCIPUSH_APPLY_F+    | BCIPUSH_APPLY_D+    | BCIPUSH_APPLY_L+    | BCIPUSH_APPLY_V+    | BCIPUSH_APPLY_P+    | BCIPUSH_APPLY_PP+    | BCIPUSH_APPLY_PPP+    | BCIPUSH_APPLY_PPPP+    | BCIPUSH_APPLY_PPPPP+    | BCIPUSH_APPLY_PPPPPP+/*     | BCIPUSH_APPLY_PPPPPPP */+    | BCISLIDE Word16 Word16+    | BCIALLOC_AP Word16+    | BCIALLOC_AP_NOUPD Word16+    | BCIALLOC_PAP Word16 Word16+    | BCIMKAP Word16 Word16+    | BCIMKPAP Word16 Word16+    | BCIUNPACK Word16+    | BCIPACK Word Word16+    | BCITESTLT_I Int Int+    | BCITESTEQ_I Int Int+    | BCITESTLT_F Word Int+    | BCITESTEQ_F Word Int+    | BCITESTLT_D Word Int+    | BCITESTEQ_D Word Int+    | BCITESTLT_P Word16 Int+    | BCITESTEQ_P Word16 Int+    | BCICASEFAIL+    | BCIJMP+    | BCICCALL Word+    | BCISWIZZLE Word16 Int16+    | BCIENTER+    | BCIRETURN+    | BCIRETURN_P+    | BCIRETURN_N+    | BCIRETURN_F+    | BCIRETURN_D+    | BCIRETURN_L+    | BCIRETURN_V+    | BCIBRK_FUN -- ^ We do not parse this opcode's arguments+    | BCITESTLT_W Word Int+    | BCITESTEQ_W Word Int+    deriving (Show, Functor, Traversable, Foldable)++getInthost :: Get Int+getInthost = fromIntegral <$> getWordhost++getInt16host :: Get Int16+getInt16host = fromIntegral <$> getWord16host

@@ -1,4 +1,4 @@-{-# LANGUAGE MagicHash, UnboxedTuples, CPP, ForeignFunctionInterface, GHCForeignImportPrim, UnliftedFFITypes, BangPatterns, RecordWildCards, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+{-# LANGUAGE MagicHash, UnboxedTuples, CPP, ForeignFunctionInterface, GHCForeignImportPrim, UnliftedFFITypes, BangPatterns, RecordWildCards, DeriveFunctor, DeriveFoldable, DeriveTraversable, PatternGuards #-} {-| Module      :  GHC.HeapView Copyright   :  (c) 2012 Joachim Breitner@@ -35,17 +35,17 @@     lookupHeapGraph,     heapGraphRoot,     buildHeapGraph,+    multiBuildHeapGraph,+    addHeapGraph,+    annotateHeapGraph,+    updateHeapGraph,     ppHeapGraph,     -- * Boxes     Box(..),     asBox,-    -- * Weak boxes-    WeakBox,-    weakBox,-    isAlive,-    derefWeakBox,-    WeakClosure,-    weakenClosure,+    areBoxesEqual,+    -- * Disassembler+    disassembleBCO,     )     where @@ -58,17 +58,16 @@  import GHC.Constants    ( wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS ) -import System.IO.Unsafe ( unsafePerformIO )--import Foreign          hiding ( unsafePerformIO )+import Foreign          hiding ( unsafePerformIO, void ) import Numeric          ( showHex ) import Data.Char import Data.List-import Data.Maybe       ( isJust, catMaybes )-import System.Mem.Weak+import Data.Maybe       ( catMaybes )+import Data.Monoid      ( Monoid, (<>), mempty ) import Data.Functor import Data.Function import Data.Foldable    ( Foldable )+import qualified Data.Foldable as F import Data.Traversable ( Traversable ) import qualified Data.Traversable as T import qualified Data.IntMap as M@@ -77,8 +76,10 @@ import Control.Monad.Trans.Class import Control.Monad.IO.Class import Control.Monad.Trans.Writer.Strict-import Control.Arrow    ( first, second )+import Control.Exception.Base (evaluate) +import GHC.Disassembler+ #include "ghcautoconf.h"  -- | An arbitrarily Haskell value in a safe Box. The point is that even@@ -106,11 +107,14 @@        pad_out ls =            '0':'x':(replicate (2*wORD_SIZE - length ls) '0') ++ ls -instance Eq Box where-  Box a == Box b = case reallyUnsafePtrEqualityUpToTag# a b of-    0# -> False-    _  -> True+-- | Boxes can be compared, but this is not pure, as different heap objects can,+-- after garbage collection, become the same object.+areBoxesEqual :: Box -> Box -> IO Bool+areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of+    0# -> return False+    _  -> return True + {-|   This takes an arbitrary value and puts it into a box. Note that calls like @@ -272,8 +276,7 @@   <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'.+  is usually a 'Box' with appropriate type synonym 'Closure'.  -} data GenClosure b =     ConsClosure {@@ -401,7 +404,6 @@ allPtrs (UnsupportedClosure {..}) = []  - #ifdef PRIM_SUPPORTS_ANY foreign import prim "aToWordzh" aToWord# :: Any -> Word# foreign import prim "slurpClosurezh" slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)@@ -445,7 +447,13 @@                 rawWords = [W# (indexWordArray# dat i) | I# i <- [0.. fromIntegral nelems -1] ]                 pelems = I# (sizeofArray# ptrs)                  ptrList = amap' Box $ Array 0 (pelems - 1) pelems ptrs-            ptrList `seq` rawWords `seq` return (Ptr iptr, rawWords, ptrList)+            -- This is just for good measure, and seems to be not important.+            mapM_ evaluate ptrList+            -- This seems to be required to avoid crashes as well+            void $ evaluate nelems+            -- The following deep evaluation is crucial to avoid crashes (but why)?+            mapM_ evaluate rawWords+            return (Ptr iptr, rawWords, ptrList)  -- From compiler/ghci/RtClosureInspect.hs amap' :: (t -> b) -> Array Int t -> [b]@@ -535,7 +543,9 @@     case tipe itbl of          t | t >= CONSTR && t <= CONSTR_NOCAF_STATIC -> do             (pkg, modl, name) <- dataConInfoPtrToNames iptr-            return $ ConsClosure itbl ptrs (drop (length ptrs + 1) wds) pkg modl name+            if modl == "ByteCodeInstr" && name == "BreakInfo"+              then return $ UnsupportedClosure itbl+              else return $ ConsClosure itbl ptrs (drop (length ptrs + 1) wds) pkg modl name          t | t >= THUNK && t <= THUNK_STATIC -> do             return $ ThunkClosure itbl ptrs (drop (length ptrs + 2) wds)@@ -654,9 +664,9 @@     BCOClosure {..} -> app         ["_bco"]     ArrWordsClosure {..} -> app-        ["toArray", intercalate "," (map show arrWords) ]-    MutArrClosure {..} -> app-        ["toMutArray", intercalate "," (map (showBox 10) mccPayload)]+        ["toArray", "("++show (length arrWords) ++ " words)", intercalate "," (shorten (map show arrWords)) ]+    MutArrClosure {..} -> app +        ["toMutArray", "("++show (length mccPayload) ++ " ptrs)",  intercalate "," (shorten (map (showBox 10) mccPayload))]     MutVarClosure {..} -> app $         ["_mutVar", (showBox 10) var]     MVarClosure {..} -> app $@@ -670,21 +680,26 @@     UnsupportedClosure {..} ->         "_unsupported"   where-    addBraces True t = "(" ++ t ++ ")"-    addBraces False t = t-    app [] = "()"-    app [a] = a +    app [a] = a  ++ "()"     app xs = addBraces (10 <= prec) (intercalate " " xs)-    braceize [] = ""-    braceize xs = "{" ++ intercalate "," xs ++ "}"++    shorten xs = if length xs > 20 then take 20 xs ++ ["(and more)"] else 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.+{- $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.++   The entries of a 'HeapGraph' can be annotated with arbitrary values. Most+   operations expect this to be in the 'Monoid' class: They use 'mempty' to+   annotate closures added because the passed values reference them, and they+   use 'mappend' to combine the annotations when two values conincide, e.g. +   during 'updateHeapGraph'.+-}+ -- | Heap maps as tree, i.e. no sharing, no cycles.-data HeapTree = HeapTree WeakBox (GenClosure HeapTree) | EndOfHeapTree+data HeapTree = HeapTree Box (GenClosure HeapTree) | EndOfHeapTree  heapTreeClosure :: HeapTree -> Maybe (GenClosure HeapTree) heapTreeClosure (HeapTree _ c) = Just c@@ -697,10 +712,9 @@ 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'+    return $ HeapTree b c'  -- | Pretty-Printing a heap Tree -- @@ -715,7 +729,12 @@     go prec t@(HeapTree _ c')         | Just s <- isHeapTreeString t = show s         | Just l <- isHeapTreeList t   = "[" ++ intercalate "," (map ppHeapTree l) ++ "]"-        | otherwise                    =  ppClosure go prec c'+        | Just bc <- disassembleBCO heapTreeClosure c'+                                       = app ("_bco" : map (go 10) (concatMap F.toList bc))+        | otherwise                    = ppClosure go prec c'+      where +        app [a] = a ++ "()"+        app xs = addBraces (10 <= prec) (intercalate " " xs)  isHeapTreeList :: HeapTree -> Maybe ([HeapTree]) isHeapTreeList tree = do@@ -740,17 +759,25 @@ -- 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)+--+-- Besides a pointer to the stored value and the closure representation we+-- also keep track of whether the value was still alive at the last update of the +-- heap graph. In addition we have a slot for arbitrary data, for the user's convenience.+data HeapGraphEntry a = HeapGraphEntry {+        hgeBox :: Box,+        hgeClosure :: GenClosure (Maybe HeapGraphIndex),+        hgeLive :: Bool,+        hgeData :: a}+    deriving (Show, Functor) 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)+newtype HeapGraph a = HeapGraph (M.IntMap (HeapGraphEntry a))     deriving (Show) -lookupHeapGraph :: HeapGraphIndex -> HeapGraph -> Maybe HeapGraphEntry+lookupHeapGraph :: HeapGraphIndex -> (HeapGraph a) -> Maybe (HeapGraphEntry a) lookupHeapGraph i (HeapGraph m) = M.lookup i m  heapGraphRoot :: HeapGraphIndex@@ -758,42 +785,128 @@  -- | 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 _ | limit <= 0 = error "buildHeapGraph: First argument has to be positive"-buildHeapGraph limit initialBox = do-    let initialState = ([], [0..])-    HeapGraph <$> execWriterT (runStateT (add limit initialBox) initialState)+buildHeapGraph+   :: Monoid a+   => Int -- ^ Search limit+   -> a -- ^ Data value for the root+   -> Box -- ^ The value to start with+   -> IO (HeapGraph a)+buildHeapGraph limit rootD initialBox =+    fst <$> multiBuildHeapGraph limit [(rootD, initialBox)]++-- | Creates a 'HeapGraph' for the values in multiple boxes, but not recursing+--   further than the given limit.+--+--   Returns the 'HeapGraph' and the indices of initial values. The arbitrary+--   type @a@ can be used to make the connection between the input and the+--   resulting list of indices, and to store additional data.+multiBuildHeapGraph+    :: Monoid a+    => Int -- ^ Search limit+    -> [(a, Box)] -- ^ Starting values with associated data entry+    -> IO (HeapGraph a, [(a, HeapGraphIndex)])+multiBuildHeapGraph limit = generalBuildHeapGraph limit (HeapGraph M.empty)++-- | Adds an entry to an existing 'HeapGraph'.+--+--   Returns the updated 'HeapGraph' and the index of the added value.+addHeapGraph+    :: Monoid a +    => Int -- ^ Search limit+    -> a -- ^ Data to be stored with the added value+    -> Box -- ^ Value to add to the graph+    -> HeapGraph a -- ^ Graph to extend+    -> IO (HeapGraphIndex, HeapGraph a)+addHeapGraph limit d box hg = do+    (hg', [(_,i)]) <- generalBuildHeapGraph limit hg [(d,box)]+    return (i, hg')++-- | Adds the given annotation to the entry at the given index, using the+-- 'mappend' operation of its 'Monoid' instance.+annotateHeapGraph :: Monoid a => a -> HeapGraphIndex -> HeapGraph a -> HeapGraph a+annotateHeapGraph d i (HeapGraph hg) = HeapGraph $ M.update go i hg   where-    add 0 _ = return Nothing+    go hge = Just $ hge { hgeData = hgeData hge <> d }++generalBuildHeapGraph +    :: Monoid a+    => Int+    -> HeapGraph a+    -> [(a,Box)]+    -> IO (HeapGraph a, [(a, HeapGraphIndex)])+generalBuildHeapGraph limit _ _ | limit <= 0 = error "buildHeapGraph: limit has to be positive"+generalBuildHeapGraph limit (HeapGraph hg) addBoxes = do+    -- First collect all boxes from the existing heap graph+    let boxList = [ (hgeBox hge, i) | (i, hge) <- M.toList hg ]+        indices | M.null hg = [0..]+                | otherwise = [1 + fst (M.findMax hg)..]+        +        initialState = (boxList, indices, [])+    -- It is ok to use the Monoid (IntMap a) instance here, because+    -- we will, besides the first time, use 'tell' only to add singletons not+    -- already there+    (is, hg') <- runWriterT (evalStateT run initialState)+    -- Now add the annotations of the root values+    let hg'' = foldl' (flip (uncurry annotateHeapGraph)) (HeapGraph hg') is+    return (hg'', is)+  where+    run = do+        lift $ tell hg -- Start with the initial map+        forM addBoxes $ \(d, b) -> do+            -- Cannot fail, as limit is not zero here+            Just i <- add limit b+            return (d, i)++    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+        (existing,_,_) <- get+        mbI <- liftIO $ findM (areBoxesEqual b . fst) existing+        case mbI of+            Just (_,i) -> return $ Just i             Nothing -> do                 -- Otherwise, allocate a new index                 i <- nextI                 -- And register it-                modify (first ((b,i):))+                modify (\(x,y,z) -> ((b,i):x, y, z))+                -- Look up the closure                 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'))+                lift $ tell (M.singleton i (HeapGraphEntry b c' True mempty))                 return $ Just i     nextI = do-        i <- gets (head . snd)-        modify (second tail)+        i <- gets (head . (\(_,b,_) -> b))+        modify (\(a,b,c) -> (a, tail b, c))         return i +-- | This function updates a heap graph to reflect the current state of+-- closures on the heap, conforming to the following specification.+--+--  * Every entry whose value has been garbage collected by now is marked as+--    dead by setting 'hgeLive' to @False@+--  * Every entry whose value is still live gets the 'hgeClosure' field updated+--    and newly referenced closures are, up to the given depth, added to the graph.+--  * A map mapping previous indicies to the corresponding new indicies is returned as well.+--  * The closure at 'heapGraphRoot' stays at 'heapGraphRoot'+updateHeapGraph :: Monoid a => Int -> HeapGraph a -> IO (HeapGraph a, HeapGraphIndex -> HeapGraphIndex)+updateHeapGraph limit (HeapGraph startHG) = do+    (hg', indexMap) <- runWriterT $ foldM go (HeapGraph M.empty) (M.toList startHG)+    return (hg', (M.!) indexMap)+  where+    go hg (i, hge) = do+        (j, hg') <- liftIO $ addHeapGraph limit (hgeData hge) (hgeBox hge) hg+        tell (M.singleton i j)+        return hg'+                 -- | Pretty-prints a HeapGraph. The resulting string contains newlines. Example--- for @let s = "Ki" in (s, s, cycle "Ho")@:+-- for @let s = \"Ki\" in (s, s, cycle \"Ho\")@: -- -- >let x1 = "Ki" -- >    x6 = C# 'H' : C# 'o' : x6 -- >in (x1,x1,x6)-ppHeapGraph :: HeapGraph -> String+ppHeapGraph :: HeapGraph a -> String ppHeapGraph (HeapGraph m) = letWrapper ++ ppRef 0 (Just heapGraphRoot)   where     -- All variables occuring more than once@@ -804,30 +917,34 @@         then ""         else "let " ++ intercalate "\n    " (map ppBinding bindings) ++ "\nin " -    bindingLetter i = case iToE i of-        HeapGraphEntry _ c -> case c of -            ThunkClosure {..} -> 't'-            SelectorClosure {..} -> 't'-            APClosure {..} -> 't'-            PAPClosure {..} -> 'f'-            BCOClosure {..} -> 't'-            FunClosure {..} -> 'f'-            _ -> 'x'+    bindingLetter i = case hgeClosure (iToE i) of+        ThunkClosure {..} -> 't'+        SelectorClosure {..} -> 't'+        APClosure {..} -> 't'+        PAPClosure {..} -> 'f'+        BCOClosure {..} -> 't'+        FunClosure {..} -> 'f'+        _ -> 'x' -    ppBinbingMap = M.fromList $+    ppBindingMap = M.fromList $         concat $         map (zipWith (\j (i,c) -> (i, [c] ++ show j)) [(1::Int)..]) $         groupBy ((==) `on` snd) $          sortBy (compare `on` snd)         [ (i, bindingLetter i) | i <- bindings ] -    ppVar i = ppBinbingMap M.! i+    ppVar i = ppBindingMap M.! i     ppBinding i = ppVar i ++ " = " ++ ppEntry 0 (iToE i) -    ppEntry prec e@(HeapGraphEntry _ c)-        | Just s <- isString e = show s-        | Just l <- isList e = "[" ++ intercalate "," (map (ppRef 0) l) ++ "]"-        | otherwise = ppClosure ppRef prec c+    ppEntry prec hge+        | Just s <- isString hge = show s+        | Just l <- isList hge   = "[" ++ intercalate "," (map (ppRef 0) l) ++ "]"+        | Just bc <- disassembleBCO (fmap (hgeClosure . iToE)) (hgeClosure hge)+                                       = app ("_bco" : map (ppRef 10) (concatMap F.toList bc))+        | otherwise = ppClosure ppRef prec (hgeClosure hge)+      where+        app [a] = a  ++ "()"+        app xs = addBraces (10 <= prec) (intercalate " " xs)      ppRef _ Nothing = "..."     ppRef prec (Just i) | i `elem` bindings = ppVar i@@ -836,65 +953,58 @@      iToUnboundE i = if i `elem` bindings then Nothing else M.lookup i m -    isList :: HeapGraphEntry -> Maybe ([Maybe HeapGraphIndex])-    isList (HeapGraphEntry _ c) = -        if isNil c+    isList :: HeapGraphEntry a -> Maybe ([Maybe HeapGraphIndex])+    isList hge = +        if isNil (hgeClosure hge)           then return []           else do-            (h,t) <- isCons c+            (h,t) <- isCons (hgeClosure hge)             ti <- t             e <- iToUnboundE ti             t' <- isList e             return $ (:) h t' -    isString :: HeapGraphEntry -> Maybe String+    isString :: HeapGraphEntry a -> Maybe String     isString e = do         list <- isList e         -- We do not want to print empty lists as "" as we do not know that they         -- are really strings.         if (null list)             then Nothing-            else mapM (isChar . (\(HeapGraphEntry _ c) -> c) <=< iToUnboundE <=< id) list+            else mapM (isChar . hgeClosure <=< iToUnboundE <=< id) list   -- | In the given HeapMap, list all indices that are used more than once. The -- second parameter adds external references, commonly @[heapGraphRoot]@.-boundMultipleTimes :: HeapGraph -> [HeapGraphIndex] -> [HeapGraphIndex]+boundMultipleTimes :: HeapGraph a -> [HeapGraphIndex] -> [HeapGraphIndex] boundMultipleTimes (HeapGraph m) roots = map head $ filter (not.null) $ map tail $ group $ sort $-     roots ++ concatMap (\(HeapGraphEntry _ c) -> catMaybes (allPtrs c)) (M.elems m)---- | 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+     roots ++ concatMap (catMaybes . allPtrs . hgeClosure) (M.elems m) -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+-- | This function integrates the disassembler in "GHC.Disassembler". The first+-- argument should a function that dereferences the pointer in the closure to a+-- closure.+--+-- If any of these return 'Nothing', then 'disassembleBCO' returns Nothing+disassembleBCO :: (a -> Maybe (GenClosure b)) -> GenClosure a -> Maybe [BCI b]+disassembleBCO deref (BCOClosure {..}) = do+    opsC <- deref instrs+    litsC <- deref literals+    ptrsC  <- deref bcoptrs+    return $ disassemble (mccPayload ptrsC) (arrWords litsC) (toBytes (bytes opsC) (arrWords opsC))+disassembleBCO _ _ = Nothing -{-|-  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+-- Utilities -{-|-  Checks whether the value referenced by a weak box is still alive--}-isAlive :: WeakBox -> IO Bool-isAlive (WeakBox w) = isJust `fmap` deRefWeak w+findM :: (a -> IO Bool) -> [a] -> IO (Maybe a)+findM _p [] = return Nothing+findM p (x:xs) = do+    b <- p x+    if b then return (Just x) else findM p xs -{-|-  Dereferences the weak box--}-derefWeakBox :: WeakBox -> IO (Maybe Box)-derefWeakBox (WeakBox w) = deRefWeak w+addBraces :: Bool -> String -> String+addBraces True t = "(" ++ t ++ ")"+addBraces False t = t -weakenClosure :: Closure -> IO WeakClosure-weakenClosure = T.mapM weakBox+braceize :: [String] -> String+braceize [] = ""+braceize xs = "{" ++ intercalate "," xs ++ "}"

@@ -0,0 +1,69 @@+-- | Utilities to debug "GHC.HeapView".+module GHC.HeapView.Debug where++import GHC.HeapView+import Text.Printf+import System.IO+import Control.Monad+import System.Mem+import Data.Maybe+import Data.Functor+import Data.Char+import Data.IORef++-- | This functions walks the heap referenced by the argument, printing the+-- \"path\", i.e. the pointer indices from the initial to the current closure+-- and the closure itself. When the runtime crashes, the problem is likely+-- related to one of the earlier steps.+walkHeap+    :: Bool -- ^ Whether to check for cycles +    -> Bool -- ^ Whethter to GC in every step+    -> Box -- ^ The closure to investigate+    -> IO ()+walkHeap slow check x = do+    seenRef <- newIORef []+    go seenRef [] x+ where+    go seenRef prefix b = do+        _ <- printf "At %s:\n" (show prefix)+        seen <- readIORef seenRef+        previous <- if check then findM (areBoxesEqual b . fst) seen else return Nothing+        case previous of+            Just (_,p') -> printf "Seen at %s.\n" (show p')+            Nothing -> do+                hFlush stdout+                c <- getBoxedClosureData b+                putStrLn (ppClosure (\_ box -> show box) 0 c)+                when slow performGC+                isCC <- isCharCons c+                unless isCC $ do+                    modifyIORef seenRef ((b,prefix):)+                    forM_ (zip [(0::Int)..] (allPtrs c)) $ \(n,box) ->+                        go seenRef (prefix ++ [n]) box++walkPrefix :: [Int] -> a -> IO Box+walkPrefix is v = go is (asBox v)+  where+    go [] a = return a+    go (x:xs) a = do+        c <- getBoxedClosureData a+        walkPrefix xs (allPtrs c !! x)+++findM :: (a -> IO Bool) -> [a] -> IO (Maybe a)+findM _p [] = return Nothing+findM p (x:xs) = do+    b <- p x+    if b then return (Just x) else findM p xs++isCharCons :: GenClosure Box -> IO Bool+isCharCons c | Just (h,_) <- isCons c = (isJust . isChar) <$> getBoxedClosureData h+isCharCons _ = return False ++isCons :: GenClosure b -> Maybe (b, b)+isCons (ConsClosure { name = ":", dataArgs = [], ptrArgs = [h,t]}) = Just (h,t)+isCons _ = Nothing++isChar :: GenClosure b -> Maybe Char+isChar (ConsClosure { name = "C#", dataArgs = [ch], ptrArgs = []}) = Just (chr (fromIntegral ch))+isChar _ = Nothing