From 60bc32f320d9db7fd10b0bdb91588dbeaf90f15b Mon Sep 17 00:00:00 2001 From: Ximin Luo Date: Sat, 13 Jun 2020 01:12:24 +0100 Subject: [PATCH 1/2] Implement a conversion to fgl Graph --- ghc-heap-view.cabal | 2 + src/GHC/HeapView.hs | 203 +++++++++++++++++++++----------------- src/GHC/HeapView/Debug.hs | 8 -- src/GHC/HeapView/Graph.hs | 103 +++++++++++++++++++ 4 files changed, 219 insertions(+), 97 deletions(-) create mode 100644 src/GHC/HeapView/Graph.hs diff --git a/ghc-heap-view.cabal b/ghc-heap-view.cabal index 64422c0..7c0da8f 100644 --- a/ghc-heap-view.cabal +++ b/ghc-heap-view.cabal @@ -70,8 +70,10 @@ Library GHC.AssertNF GHC.Disassembler GHC.HeapView.Debug + GHC.HeapView.Graph Build-depends: base >= 4.12 && < 4.15, + fgl, ghc-heap, containers, transformers, diff --git a/src/GHC/HeapView.hs b/src/GHC/HeapView.hs index 416e627..8d07993 100644 --- a/src/GHC/HeapView.hs +++ b/src/GHC/HeapView.hs @@ -26,6 +26,7 @@ module GHC.HeapView ( getClosureRaw, -- * Pretty printing ppClosure, + ppClosureF, -- * Heap maps -- $heapmap HeapTree(..), @@ -48,6 +49,9 @@ module GHC.HeapView ( areBoxesEqual, -- * Disassembler disassembleBCO, + -- * Internals + isNil, isCons, isChar, isListF, isStringF, + addBraces, boundMultipleTimes, allBindings, ppBindingMap ) where @@ -66,11 +70,14 @@ import Data.Char import Data.List import Data.Maybe ( catMaybes ) import Data.Functor +import Data.Functor.Identity import Data.Function import qualified Data.Foldable as F import qualified Data.Traversable as T import qualified Data.IntMap as M +import Control.Applicative import Control.Monad +import Control.Monad.Trans.Maybe import Control.Monad.Trans.State import Control.Monad.Trans.Class import Control.Monad.IO.Class @@ -198,69 +205,72 @@ isNil _ = False -- -- The parameter gives the precedendence, to avoid avoidable parenthesises. ppClosure :: (Int -> b -> String) -> Int -> GenClosure b -> String -ppClosure 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 +ppClosure f i c = runIdentity $ ppClosureF ((Identity .) . f) i c + +ppClosureF :: Applicative f => (Int -> b -> f String) -> Int -> GenClosure b -> f String +ppClosureF showBox prec c = case c of + _ | Just ch <- isChar c -> app <$> + pure ["C#", show ch] + _ | Just (h,t) <- isCons c -> addBraces (5 <= prec) <$> + liftA2 (\x y -> x ++ " : " ++ y) (showBox 5 h) (showBox 4 t) _ | Just vs <- isTup c -> - "(" ++ intercalate "," (map (showBox 0) vs) ++ ")" - ConstrClosure {..} -> 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", showBox 10 bcoptrs] - ArrWordsClosure {..} -> app - ["toArray", "("++show (length arrWords) ++ " words)", intercalate "," (shorten (map show arrWords)) ] - MutArrClosure {..} -> app + (\x -> "(" ++ intercalate "," x ++ ")") <$> (traverse (showBox 0) vs) + ConstrClosure {..} -> app <$> + (\x -> name : x ++ map show dataArgs) <$> (traverse (showBox 10) ptrArgs) + ThunkClosure {..} -> app <$> + (\x -> "_thunk" : x ++ map show dataArgs) <$> (traverse (showBox 10) ptrArgs) + SelectorClosure {..} -> app <$> + (\x -> ["_sel", x]) <$> showBox 10 selectee + IndClosure {..} -> app <$> + (\x -> ["_ind", x]) <$> showBox 10 indirectee + BlackholeClosure {..} -> app <$> + (\x -> ["_bh", x]) <$> showBox 10 indirectee + APClosure {..} -> app <$> traverse (showBox 10) + (fun : payload) + PAPClosure {..} -> app <$> traverse (showBox 10) + (fun : payload) + APStackClosure {..} -> app <$> traverse (showBox 10) + (fun : payload) + BCOClosure {..} -> app <$> + (\x -> ["_bco", x]) <$> showBox 10 bcoptrs + ArrWordsClosure {..} -> app <$> + pure ["toArray", "("++show (length arrWords) ++ " words)", intercalate "," (shorten (map show arrWords)) ] + MutArrClosure {..} -> app <$> --["toMutArray", "("++show (length mccPayload) ++ " ptrs)", intercalate "," (shorten (map (showBox 10) mccPayload))] - ["[", intercalate ", " (shorten (map (showBox 10) mccPayload)),"]"] - MutVarClosure {..} -> app $ - ["_mutVar", (showBox 10) var] - MVarClosure {..} -> app $ - ["MVar", (showBox 10) value] + (\x -> ["[", intercalate ", " (shorten x),"]"]) <$> traverse (showBox 10) mccPayload + MutVarClosure {..} -> app <$> + (\x -> ["_mutVar", x]) <$> showBox 10 var + MVarClosure {..} -> app <$> + (\x -> ["MVar", x]) <$> showBox 10 value FunClosure {..} -> - "_fun" ++ braceize (map (showBox 0) ptrArgs ++ map show dataArgs) + (\x -> "_fun" ++ braceize (x ++ map show dataArgs)) <$> traverse (showBox 0) ptrArgs BlockingQueueClosure {..} -> - "_blockingQueue" - IntClosure {..} -> app - ["Int", show intVal] - WordClosure {..} -> app - ["Word", show wordVal] - Int64Closure {..} -> app - ["Int64", show int64Val] - Word64Closure {..} -> app - ["Word64", show word64Val] - AddrClosure {..} -> app - ["Addr", show addrVal] - FloatClosure {..} -> app - ["Float", show floatVal] - DoubleClosure {..} -> app - ["Double", show doubleVal] + pure "_blockingQueue" + IntClosure {..} -> app <$> + pure ["Int", show intVal] + WordClosure {..} -> app <$> + pure ["Word", show wordVal] + Int64Closure {..} -> app <$> + pure ["Int64", show int64Val] + Word64Closure {..} -> app <$> + pure ["Word64", show word64Val] + AddrClosure {..} -> app <$> + pure ["Addr", show addrVal] + FloatClosure {..} -> app <$> + pure ["Float", show floatVal] + DoubleClosure {..} -> app <$> + pure ["Double", show doubleVal] OtherClosure {..} -> - "_other" + pure "_other" UnsupportedClosure {..} -> - "_unsupported" + pure "_unsupported" #if MIN_VERSION_ghc_heap(8,10,1) -- copy-pasta'd from MutArrClosure: - SmallMutArrClosure {..} -> app + SmallMutArrClosure {..} -> app <$> --["toMutArray", "("++show (length mccPayload) ++ " ptrs)", intercalate "," (shorten (map (showBox 10) mccPayload))] - ["[", intercalate ", " (shorten (map (showBox 10) mccPayload)),"]"] + (\x -> ["[", intercalate ", " (shorten x),"]"]) <$> traverse (showBox 10) mccPayload WeakClosure {..} -> - "_weak" + pure "_weak" #endif where app [a] = a ++ "()" @@ -500,23 +510,9 @@ ppHeapGraph (HeapGraph m) = letWrapper ++ ppRef 0 (Just heapGraphRoot) then "" else "let " ++ intercalate "\n " (map ppBinding bindings) ++ "\nin " - bindingLetter i = case hgeClosure (iToE i) of - ThunkClosure {..} -> 't' - SelectorClosure {..} -> 't' - APClosure {..} -> 't' - PAPClosure {..} -> 'f' - BCOClosure {..} -> 't' - FunClosure {..} -> 'f' - _ -> 'x' - - 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 = ppBindingMap M.! i + ppBindingMap' = ppBindingMap m bindings + + ppVar i = ppBindingMap' M.! i ppBinding i = ppVar i ++ " = " ++ ppEntry 0 (iToE i) ppEntry prec hge @@ -536,26 +532,49 @@ ppHeapGraph (HeapGraph m) = letWrapper ++ ppRef 0 (Just heapGraphRoot) iToUnboundE i = if i `elem` bindings then Nothing else M.lookup i m - isList :: HeapGraphEntry a -> Maybe ([Maybe HeapGraphIndex]) - isList hge = - if isNil (hgeClosure hge) - then return [] - else do - (h,t) <- isCons (hgeClosure hge) - ti <- t - e <- iToUnboundE ti - t' <- isList e - return $ (:) h t' - - 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 . hgeClosure <=< iToUnboundE <=< id) list + isList hge = runIdentity $ runMaybeT $ isListF (maybeT . iToUnboundE) hge + + isString e = runIdentity $ runMaybeT $ isStringF (maybeT . iToUnboundE) e + +maybeT :: Monad m => Maybe a -> MaybeT m a +maybeT = MaybeT . pure +isListF :: Monad m => (HeapGraphIndex -> MaybeT m (HeapGraphEntry a)) -> HeapGraphEntry a -> MaybeT m [Maybe HeapGraphIndex] +isListF iToUnboundE hge = + if isNil (hgeClosure hge) + then pure [] + else do + (h,t) <- maybeT $ isCons (hgeClosure hge) + ti <- maybeT $ t + e <- iToUnboundE ti + t' <- isListF iToUnboundE e + pure $ (:) h t' + +isStringF :: Monad m => (HeapGraphIndex -> MaybeT m (HeapGraphEntry a)) -> HeapGraphEntry a -> MaybeT m String +isStringF iToUnboundE e = do + list <- isListF iToUnboundE e + -- We do not want to print empty lists as "" as we do not know that they + -- are really strings. + if (null list) + then maybeT $ Nothing + else mapM (maybeT . isChar . hgeClosure <=< iToUnboundE <=< maybeT) list + +ppBindingMap :: M.IntMap (HeapGraphEntry a) -> [Int] -> M.IntMap String +ppBindingMap m bindings = 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 ] + where + bindingLetter i = case hgeClosure (m M.! i) of + ThunkClosure {} -> 't' + SelectorClosure {} -> 't' + APClosure {} -> 't' + PAPClosure {} -> 'f' + BCOClosure {} -> 't' + FunClosure {} -> 'f' + _ -> 'x' -- | In the given HeapMap, list all indices that are used more than once. The -- second parameter adds external references, commonly @[heapGraphRoot]@. @@ -563,6 +582,12 @@ boundMultipleTimes :: HeapGraph a -> [HeapGraphIndex] -> [HeapGraphIndex] boundMultipleTimes (HeapGraph m) roots = map head $ filter (not.null) $ map tail $ group $ sort $ roots ++ concatMap (catMaybes . allClosures . hgeClosure) (M.elems m) +-- | In the given HeapMap, list all indices. The second parameter adds external +-- references, commonly @[heapGraphRoot]@. +allBindings :: HeapGraph a -> [HeapGraphIndex] -> [HeapGraphIndex] +allBindings (HeapGraph m) roots = map head $ group $ sort $ + roots ++ concatMap (catMaybes . allClosures . hgeClosure) (M.elems m) + -- | This function integrates the disassembler in "GHC.Disassembler". The first -- argument should a function that dereferences the pointer in the closure to a -- closure. diff --git a/src/GHC/HeapView/Debug.hs b/src/GHC/HeapView/Debug.hs index 35d1a91..05aea37 100644 --- a/src/GHC/HeapView/Debug.hs +++ b/src/GHC/HeapView/Debug.hs @@ -58,11 +58,3 @@ findM p (x:xs) = do 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 (ConstrClosure { name = ":", dataArgs = [], ptrArgs = [h,t]}) = Just (h,t) -isCons _ = Nothing - -isChar :: GenClosure b -> Maybe Char -isChar (ConstrClosure { name = "C#", dataArgs = [ch], ptrArgs = []}) = Just (chr (fromIntegral ch)) -isChar _ = Nothing diff --git a/src/GHC/HeapView/Graph.hs b/src/GHC/HeapView/Graph.hs new file mode 100644 index 0000000..8157987 --- /dev/null +++ b/src/GHC/HeapView/Graph.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE LambdaCase, RecordWildCards #-} +{- | Conversions between 'HeapGraph' and 'Graph'. + +You may also be interested in the @graphviz@ package which has conversions +between 'Graph' and the DOT format, which can be visualised by other tools. + +>>> import GHC.HeapView +>>> import GHC.HeapView.Graph +>>> import qualified Data.GraphViz as GV +>>> import qualified Data.GraphViz.Printing as GV +>>> import Data.Text.Lazy (unpack) +>>> hg <- buildHeapGraph 50 ["root"] $ asBox yourRoot +>>> putStrLn $ ppHeapGraph hg +>>> let dg = GV.graphToDot GV.quickParams $ asStrGraph hg +>>> putStrLn $ unpack $ GV.renderDot $ GV.toDot dg +-} +module GHC.HeapView.Graph where + +import GHC.HeapView +import Data.Graph.Inductive.Graph +import Data.Graph.Inductive.PatriciaTree (Gr) + +import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Writer.CPS +import qualified Data.IntMap as M +import qualified Data.Foldable as F +import Data.List + +{- | Convert a 'HeapGraph' to a 'Graph', most general form. + +The first parameter creates a node label and is called for each node. It takes +the 'HeapGraph' user data, the 'HeapGraphEntry' of that node, a string name for +the node, and a string description of the node's contents. + +The second parameter creates an edge label and is called for each edge. It +takes the source node label, the 'HeapGraphEntry' of the target node, and a +string name for the target node. +-} +asGraph + :: DynGraph gr + => (a -> HeapGraphEntry a -> String -> String -> v) + -> (v -> HeapGraphEntry a -> String -> e) + -> HeapGraph a + -> gr v e +asGraph mkNodeLabel mkEdgeLabel (HeapGraph m) = M.foldrWithKey build empty m + where + build k e g = + let (r, kk) = runWriter $ ppEntry e + v = mkNodeLabel (hgeData e) e (ppVar k) r + g1 = insNode (k, v) g + g2 = foldr (\k' g' -> insEdge (k, k', mkEdgeLabel v (m M.! k') (ppVar k')) g') g1 kk + in g2 + + bindings = allBindings (HeapGraph m) [heapGraphRoot] + ppBindingMap' = ppBindingMap m bindings + ppVar i = ppBindingMap' M.! i + + ppEntry hge = do + runMaybeT (isString hge) >>= \case + Just s -> pure $ show s + Nothing -> runMaybeT (isList hge) >>= \case + Just l -> (\x -> "[" ++ intercalate "," x ++ "]") <$> traverse ppRef l + Nothing -> case disassembleBCO (fmap (hgeClosure . (m M.!))) (hgeClosure hge) of + Just bc -> app <$> ("_bco" :) <$> traverse ppRef (concatMap F.toList bc) + Nothing -> ppClosureF (const ppRef) 0 (hgeClosure hge) + where + app [a] = a ++ "()" + app xs = intercalate " " xs + + ppRef Nothing = pure "..." + ppRef (Just i) = do + tell [i] + pure (ppVar i) + + iToUnboundEF i = if i `elem` bindings + then MaybeT . pure $ Nothing + else do + lift $ tell [i] + MaybeT . pure $ M.lookup i m + + isList hge = isListF iToUnboundEF hge + + isString e = isStringF iToUnboundEF e + +-- | 'asGraph' specialised to 'Gr' a concrete graph. +-- For convenience for people unfamiliar with @fgl@. +asAGraph + :: (a -> HeapGraphEntry a -> String -> String -> b) + -> (b -> HeapGraphEntry a -> String -> e) + -> HeapGraph a + -> Gr b e +asAGraph = asGraph + +-- | 'asGraph' with default values for @mkNodeLabel@ and @mkEdgeLabel@ +asStrGraph :: Show a => HeapGraph [a] -> Gr String String +asStrGraph = asGraph mkNode mkEdge + where + mkNode d _ k v = maybeShow d <> k <> " =\n" <> fmap trSp v + mkEdge _ _ k' = k' + maybeShow d = if null d then "" else show d <> " // " + trSp ' ' = '\n' + trSp c = c From 3014aa98376915dca1c3713cc0ee34c1408cc33b Mon Sep 17 00:00:00 2001 From: Ximin Luo Date: Sat, 13 Jun 2020 01:45:06 +0100 Subject: [PATCH 2/2] compat for old transformers --- src/GHC/HeapView/Graph.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/GHC/HeapView/Graph.hs b/src/GHC/HeapView/Graph.hs index 8157987..40c2244 100644 --- a/src/GHC/HeapView/Graph.hs +++ b/src/GHC/HeapView/Graph.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase, RecordWildCards #-} +{-# LANGUAGE CPP, LambdaCase, RecordWildCards #-} {- | Conversions between 'HeapGraph' and 'Graph'. You may also be interested in the @graphviz@ package which has conversions @@ -22,7 +22,11 @@ import Data.Graph.Inductive.PatriciaTree (Gr) import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe +#if MIN_VERSION_transformers(0,5,6) import Control.Monad.Trans.Writer.CPS +#else +import Control.Monad.Trans.Writer.Strict +#endif import qualified Data.IntMap as M import qualified Data.Foldable as F import Data.List