diff --git a/cbits/HeapViewPrim.cmm b/cbits/HeapViewPrim.cmm --- a/cbits/HeapViewPrim.cmm +++ b/cbits/HeapViewPrim.cmm @@ -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); diff --git a/ghc-heap-view.cabal b/ghc-heap-view.cabal --- a/ghc-heap-view.cabal +++ b/ghc-heap-view.cabal @@ -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/ diff --git a/ghci b/ghci --- a/ghci +++ b/ghci @@ -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 diff --git a/src/GHC/AssertNF.hs b/src/GHC/AssertNF.hs --- a/src/GHC/AssertNF.hs +++ b/src/GHC/AssertNF.hs @@ -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 diff --git a/src/GHC/Disassembler.hs b/src/GHC/Disassembler.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Disassembler.hs @@ -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 diff --git a/src/GHC/HeapView.hs b/src/GHC/HeapView.hs --- a/src/GHC/HeapView.hs +++ b/src/GHC/HeapView.hs @@ -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 @@ 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 ++ "}" diff --git a/src/GHC/HeapView/Debug.hs b/src/GHC/HeapView/Debug.hs new file mode 100644 --- /dev/null +++ b/src/GHC/HeapView/Debug.hs @@ -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