ghc-debug-brick 0.5.0.0 → 0.6.0.0
raw patch · 8 files changed
+1123/−440 lines, 8 filesdep +bytestringdep +byteunitsdep +vty-crossplatformdep ~ghc-debug-clientdep ~ghc-debug-commondep ~ghc-debug-convention
Dependencies added: bytestring, byteunits, vty-crossplatform
Dependency ranges changed: ghc-debug-client, ghc-debug-common, ghc-debug-convention, vty
Files
- CHANGELOG.md +16/−0
- ghc-debug-brick.cabal +10/−6
- src/Common.hs +2/−0
- src/IOTree.hs +89/−19
- src/Lib.hs +194/−165
- src/Main.hs +631/−225
- src/Model.hs +180/−25
- src/Namespace.hs +1/−0
CHANGELOG.md view
@@ -1,5 +1,21 @@ # Revision history for ghc-debug-brick +## 0.6.0.0 -- 2024-04-10++* Allow setting result size+* Add query for searching ArrWords over a given size+* Add support for displaying profiling info+* Add find retainer by address+* Add ArrWords analysis+* Add 2-level profile census+* Display results of profiles in window+* Add display for eras profiling+* Add new filter-based search workflow+* Fix performance of queries with large results+* Add filter by cost centre ID+* Compile with `-N` to enable parallelism+* Many more small tweaks, this is an important release!+ ## 0.5.0.0 -- 2023-06-06 * Add find closure by info table address
ghc-debug-brick.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghc-debug-brick-version: 0.5.0.0+version: 0.6.0.0 synopsis: A simple TUI using ghc-debug description: A simple TUI using ghc-debug bug-reports: https://gitlab.haskell.org/ghc/ghc-debug/-/issues@@ -20,21 +20,25 @@ , Lib build-depends: base >=4.16 && <5 , brick >= 1.3+ , bytestring , containers , directory , filepath , microlens-platform , text- , vty+ , vty-crossplatform+ , vty >= 6 , time , deepseq , microlens- , ghc-debug-client == 0.5.0.0- , ghc-debug-common == 0.5.0.0- , ghc-debug-convention == 0.5.0.0+ , ghc-debug-client == 0.6.0.0+ , ghc-debug-common == 0.6.0.0+ , ghc-debug-convention == 0.6.0.0 , unordered-containers , exceptions , contra-tracer+ , bytestring+ , byteunits hs-source-dirs: src default-language: Haskell2010- ghc-options: -threaded -Wall+ ghc-options: -threaded -Wall "-with-rtsopts=-N -qn1"
src/Common.hs view
@@ -7,6 +7,8 @@ import Lens.Micro import Namespace +data ProfileLevel = OneLevel | TwoLevel deriving Show+ type Handler e s = T.BrickEvent Name e -> T.EventM Name s ()
src/IOTree.hs view
@@ -40,6 +40,7 @@ import GHC.Stack import qualified Graphics.Vty.Input.Events as Vty import Graphics.Vty.Input.Events (Key(..))+import Lens.Micro ((^.)) -- A tree style list where items can be expanded and collapsed@@ -113,26 +114,95 @@ nodeToTreeNode k n = IOTreeNode n (Left (fmap (nodeToTreeNode k) <$> k n)) renderIOTree :: (Show name, Ord name) => IOTree node name -> Widget name-renderIOTree (IOTree widgetName rs _ renderRow pathTop)- = viewport widgetName Vertical $ vBox $ renderTree 0 [] rs pathTop+renderIOTree iotree+ = drawTreeElements iotree++data TreeNodeWithRenderContext node = TreeNodeWithRenderContext+ { _nodeDepth :: Int+ , _nodeState :: RowState+ , _nodeSelected :: Bool+ , _nodeLast :: RowCtx+ , _nodeParentLast :: [RowCtx]+ , _nodeContent :: node+ }++renderTreeNodeWithContext ::+ (RowState -> Bool -> RowCtx -> [RowCtx] -> node -> Widget name) ->+ TreeNodeWithRenderContext node -> Widget name+renderTreeNodeWithContext rowRenderer ctx =+ rowRenderer (_nodeState ctx) (_nodeSelected ctx) (_nodeLast ctx) (_nodeParentLast ctx) (_nodeContent ctx)++drawTreeElements :: (Ord n, Show n) => IOTree node n -> Widget n+drawTreeElements (IOTree widgetName treeNodes _ renderRow pathTop) =+ -- This function takes inspiration from 'Brick.Widget.List.drawListElements'+ Widget Greedy Greedy $ do+ c <- getContext++ -- Take (numPerHeight * 2) elements, or whatever is left+ let+ rs = flattenTree 0 [] treeNodes pathTop+ es = take (numPerHeight * 2) $ drop start rs++ idx = fromMaybe 0 (List.findIndex (_nodeSelected) rs)++ start = max 0 $ idx - numPerHeight + 1++ -- We hardcode the height of each element to be expected as 1 row.+ -- Perhaps we could greedily compute the number of elements based on+ -- their dynamic height for a perfect result,+ -- but it currently feels like overkill.+ itemHeight = 1++ -- The number of items to show is the available height+ -- divided by the item height...+ initialNumPerHeight = (c^.availHeightL) `div` itemHeight+ -- ... but if the available height leaves a remainder of+ -- an item height then we need to ensure that we render an+ -- extra item to show a partial item at the top or bottom to+ -- give the expected result when an item is more than one+ -- row high. (Example: 5 rows available with item height+ -- of 3 yields two items: one fully rendered, the other+ -- rendered with only its top 2 or bottom 2 rows visible,+ -- depending on how the viewport state changes.)+ numPerHeight = initialNumPerHeight ++ if initialNumPerHeight * itemHeight == c^.availHeightL+ then 0+ else 1++ off = start * itemHeight++ render $ viewport widgetName Vertical $+ translateBy (Location (0, off)) $+ vBox $ (map (renderTreeNodeWithContext renderRow) es) where- -- Render the tree of nodes- renderTree _ _ [] _ = []- renderTree minorIx depth (IOTreeNode node' csE : ns) path = case csE of- -- Collapsed- Left _ -> row Collapsed : rowsRest- -- Expanded- Right cs -> row (Expanded (null cs))- : renderTree 0 (rowCtx : depth) cs (if childIsSelected then drop 1 path else [])- ++ rowsRest- where- childIsSelected = case path of- x:_ -> x == minorIx- _ -> False- selected = path == [minorIx]- rowCtx = if null ns then LastRow else NotLastRow- row state = (if selected then visible else id) $ renderRow state selected rowCtx depth node'- rowsRest = renderTree (minorIx + 1) depth ns path+ -- Compute metadata for each row we may display.+ -- This is a logical representation of each row that can+ -- be split and filtered later.+ -- Each 'TreeNodeWithRenderContext' can be individually rendered without+ -- further issue.+ flattenTree _ _ [] _ = []+ flattenTree minorIx depth (IOTreeNode node' csE : ns) path = case csE of+ -- Collapsed+ Left _ -> row Collapsed : rowsRest+ -- Expanded+ Right cs -> row (Expanded (null cs))+ : flattenTree 0 (rowCtx : depth) cs (if childIsSelected then drop 1 path else [])+ ++ rowsRest+ where+ childIsSelected = case path of+ x:_ -> x == minorIx+ _ -> False+ selected = path == [minorIx]+ rowCtx = if null ns then LastRow else NotLastRow+ row state = TreeNodeWithRenderContext+ { _nodeDepth = length depth+ , _nodeState = state+ , _nodeSelected = selected+ , _nodeLast = rowCtx+ , _nodeParentLast = depth+ , _nodeContent = node'+ }+ rowsRest = flattenTree (minorIx + 1) depth ns path handleIOTreeEvent :: Vty.Event -> IOTree node name -> EventM name s (IOTree node name) handleIOTreeEvent e tree
src/Lib.hs view
@@ -10,7 +10,9 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE NamedFieldPuns #-} module Lib ( -- * Running/Connecting to a debuggee Debuggee@@ -32,13 +34,16 @@ -- * Querying the paused debuggee , rootClosures , savedClosures+ , version+ , profilingMode+ , GD.Version -- * Closures , Closure+ , ClosureType , DebugClosure(..) , closureShowAddress , closureExclusiveSize- , closureRetainerSize , closureSourceLocation , SourceInformation(..) , closureReferences@@ -48,15 +53,14 @@ , ListItem(..) , closureInfoPtr , infoSourceLocation+ , GD.dereferenceClosure+ , run+ , ccsReferences -- * Common initialisation , initialTraversal , HG.HeapGraph(..) -- * Dominator Tree- , dominatorRootClosures- , closureDominatees- , runAnalysis- , Analysis(..) , Size(..) , RetainerSize(..) -- * Reverse Edge Map@@ -66,18 +70,25 @@ -- * Profiling , profile+ , thunkAnalysis+ , GD.CensusStats(..) -- * Retainers- , retainersOfConstructor- , retainersOfAddress- , retainersOfConstructorExact- , retainersOfInfoTable+ , retainersOf+ , findAllChildrenOfCCs + -- * Counting+ , arrWordsAnalysis+ , stringsAnalysis+ -- * Snapshot , snapshot -- * Types , Ptr(..)+ , CCSPtr+ , CCPayload+ , GenCCSPayload , toPtr , dereferencePtr , ConstrDesc(..)@@ -88,16 +99,23 @@ , SrtCont , ClosurePtr , readClosurePtr+ , CCPtr+ , readCCPtr , HG.StackHI , HG.PapHI , HG.SrtHI , HG.HeapGraphIndex+ , ProfHeaderWord --+ , EraRange(..)+ , GD.profHeaderInEraRange+ , tipe+ , ClosureFilter(..)+ , GD.profHeaderReferencesCCS ) where import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.Graph as G-import Data.Maybe (fromMaybe, mapMaybe)+import Data.Maybe (mapMaybe) import qualified GHC.Debug.Types as GD import GHC.Debug.Types hiding (Closure, DebugClosure) import GHC.Debug.Convention (socketDirectory, snapshotDirectory)@@ -106,25 +124,25 @@ import qualified GHC.Debug.Client.Query as GD import qualified GHC.Debug.Profile as GD import qualified GHC.Debug.Retainers as GD+import qualified GHC.Debug.CostCentres as GD+import GHC.Debug.Retainers (EraRange(..), ClosureFilter(..)) import qualified GHC.Debug.Snapshot as GD+import qualified GHC.Debug.Strings as GD+import qualified GHC.Debug.Types.Version as GD import qualified GHC.Debug.Types.Graph as HG-import qualified GHC.Debug.Dominators as HG-import qualified Data.HashMap.Strict as HM-import Data.Tree+import qualified GHC.Debug.Thunks as GD import Control.Monad import System.FilePath import System.Directory import Control.Tracer import Data.Bitraversable import Data.Text (Text, pack)--data Analysis = Analysis- { analysisDominatorRoots :: ![ClosurePtr]- , analysisDominatees :: !(ClosurePtr -> [ClosurePtr])- -- ^ Unsorted dominatees of a closure- , analysisSizes :: !(ClosurePtr -> (Size, RetainerSize))- -- ^ Size and retainer size (via dominator tree) of closures- }+import qualified Data.Map as Map+import qualified Data.ByteString.Lazy as BS+import qualified Data.Set as Set+import Data.Int+import GHC.Debug.Client.Monad (DebugM)+import Common initialTraversal :: Debuggee -> IO (HG.HeapGraph Size) initialTraversal e = run e $ do@@ -134,13 +152,14 @@ rs <- request RequestRoots let derefFuncM cPtr = do c <- GD.dereferenceClosure cPtr- quintraverse GD.dereferenceSRT GD.dereferencePapPayload GD.dereferenceConDesc (bitraverse GD.dereferenceSRT pure <=< GD.dereferenceStack) pure c+ hextraverse pure GD.dereferenceSRT GD.dereferencePapPayload GD.dereferenceConDesc (bitraverse GD.dereferenceSRT pure <=< GD.dereferenceStack) pure c hg <- case rs of [] -> error "Empty roots" (x:xs) -> HG.multiBuildHeapGraph derefFuncM Nothing (x :| xs) return hg -- This function is very very very slow, it needs to be optimised.+{- runAnalysis :: Debuggee -> HG.HeapGraph Size -> IO Analysis runAnalysis e hg = run e $ do let drs :: [G.Tree (ClosurePtr, (Size, RetainerSize))]@@ -167,6 +186,7 @@ [drPtr | G.Node (drPtr, _) _ <- drs] ((\(_,x) -> x) . cPtrToData) ((\(x,_) -> x) . cPtrToData)+ -} -- | Bracketed version of @debuggeeRun@. Runs a debuggee, connects to it, runs -- the action, kills the process, then closes the debuggee.@@ -213,6 +233,12 @@ | closure <- closures ] +version :: Debuggee -> IO GD.Version+version e = run e GD.version++profilingMode :: GD.Version -> Maybe GD.ProfilingMode+profilingMode = GD.v_profiling+ -- | A client can save objects by calling a special RTS method -- This function returns the closures it saved. savedClosures :: Debuggee -> IO [Closure]@@ -223,46 +249,57 @@ closurePtrs closures -profile :: Debuggee -> FilePath -> IO ()-profile dbg fp = do+profile :: Debuggee -> ProfileLevel -> FilePath -> IO GD.CensusByClosureType+profile dbg lvl fp = do c <- run dbg $ do roots <- GD.gcRoots- GD.censusClosureType roots+ case lvl of+ OneLevel -> GD.censusClosureType roots+ TwoLevel -> GD.census2LevelClosureType roots GD.writeCensusByClosureType fp c+ return c +thunkAnalysis :: Debuggee -> IO (Map.Map (Maybe SourceInformation) GD.Count)+thunkAnalysis dbg = do+ c <- run dbg $ do+ roots <- GD.gcRoots+ GD.thunkAnalysis roots+ return c+++ snapshot :: Debuggee -> FilePath -> IO () snapshot dbg fp = do dir <- snapshotDirectory createDirectoryIfMissing True dir GD.run dbg $ GD.snapshot (dir </> fp) -retainersOfAddress :: Maybe [ClosurePtr] -> Debuggee -> [ClosurePtr] -> IO [[Closure]]-retainersOfAddress mroots dbg address = do+retainersOf :: Maybe Int -> DebugM ClosureFilter -> Maybe [ClosurePtr] -> Debuggee -> IO [[Closure]]+retainersOf n retainer_filter mroots dbg = do run dbg $ do roots <- maybe GD.gcRoots return mroots- stack <- GD.findRetainersOf (Just 100) roots address+ closfilter <- retainer_filter+ stack <- GD.findRetainers n closfilter roots traverse (\cs -> zipWith Closure cs <$> (GD.dereferenceClosures cs)) stack -retainersOfConstructor :: Maybe [ClosurePtr] -> Debuggee -> String -> IO [[Closure]]-retainersOfConstructor mroots dbg con_name = do+findAllChildrenOfCCs :: Int64 -> Debuggee -> IO (Set.Set CCSPtr)+findAllChildrenOfCCs ccId dbg = do run dbg $ do- roots <- maybe GD.gcRoots return mroots- stack <- GD.findRetainersOfConstructor (Just 100) roots con_name- traverse (\cs -> zipWith Closure cs <$> (GD.dereferenceClosures cs)) stack+ GD.findAllChildrenOfCC ((ccId ==) . ccID) -retainersOfConstructorExact :: Debuggee -> String -> IO [[Closure]]-retainersOfConstructorExact dbg con_name = do+arrWordsAnalysis :: Maybe [ClosurePtr] -> Debuggee -> IO (Map.Map BS.ByteString (Set.Set ClosurePtr))+arrWordsAnalysis mroots dbg = do run dbg $ do- roots <- GD.gcRoots- stack <- GD.findRetainersOfConstructorExact (Just 100) roots con_name- traverse (\cs -> zipWith Closure cs <$> (GD.dereferenceClosures cs)) stack+ roots <- maybe GD.gcRoots return mroots+ arr_words <- GD.arrWordsAnalysis roots+ return arr_words -retainersOfInfoTable :: Maybe [ClosurePtr] -> Debuggee -> InfoTablePtr -> IO [[Closure]]-retainersOfInfoTable mroots dbg info_ptr = do+stringsAnalysis :: Maybe [ClosurePtr] -> Debuggee -> IO (Map.Map String (Set.Set ClosurePtr))+stringsAnalysis mroots dbg = do run dbg $ do roots <- maybe GD.gcRoots return mroots- stack <- GD.findRetainersOfInfoTable (Just 100) roots info_ptr- traverse (\cs -> zipWith Closure cs <$> (GD.dereferenceClosures cs)) stack+ arr_words <- GD.stringAnalysis roots+ return arr_words -- -- | Request the description for an info table. -- -- The `InfoTablePtr` is just used for the equality@@ -277,62 +314,56 @@ -- requestClosures :: Debuggee -> [ClosurePtr] -> IO [RawClosure] -- requestClosures (Debuggee e _) = run e $ request RequestClosures -type Closure = DebugClosure SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr+type Closure = DebugClosure CCSPtr SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr -data ListItem srt a b c d = ListData | ListOnlyInfo InfoTablePtr | ListFullClosure (DebugClosure srt a b c d)+data ListItem ccs srt a b c d+ = ListData+ | ListOnlyInfo InfoTablePtr+ | ListCCS CCSPtr (GenCCSPayload CCSPtr CCPayload)+ | ListCC CCPayload+ | ListFullClosure (DebugClosure ccs srt a b c d) -data DebugClosure srt p cd s c+data DebugClosure ccs srt p cd s c = Closure { _closurePtr :: ClosurePtr- , _closureSized :: DebugClosureWithSize srt p cd s c+ , _closureSized :: DebugClosureWithSize ccs srt p cd s c } | Stack { _stackPtr :: StackCont , _stackStack :: GD.GenStackFrames srt c }+ deriving Show -toPtr :: DebugClosure srt p cd s c -> Ptr+toPtr :: DebugClosure ccs srt p cd s c -> Ptr toPtr (Closure cp _) = CP cp toPtr (Stack sc _) = SP sc data Ptr = CP ClosurePtr | SP StackCont deriving (Eq, Ord) -dereferencePtr :: Debuggee -> Ptr -> IO (DebugClosure SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr)+dereferencePtr :: Debuggee -> Ptr -> IO (DebugClosure CCSPtr SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr) dereferencePtr dbg (CP cp) = run dbg (Closure <$> pure cp <*> GD.dereferenceClosure cp) dereferencePtr dbg (SP sc) = run dbg (Stack <$> pure sc <*> GD.dereferenceStack sc) -instance Quintraversable DebugClosure where- quintraverse p f g h i (Closure cp c) = Closure cp <$> quintraverse p f g h i c- quintraverse p _ _ _ h (Stack sp s) = Stack sp <$> bitraverse p h s+instance Hextraversable DebugClosure where+ hextraverse p f g h i j (Closure cp c) = Closure cp <$> hextraverse p f g h i j c+ hextraverse _ p _ _ _ h (Stack sp s) = Stack sp <$> bitraverse p h s -closureShowAddress :: DebugClosure srt p cd s c -> String+closureShowAddress :: DebugClosure ccs srt p cd s c -> String closureShowAddress (Closure c _) = show c closureShowAddress (Stack (StackCont s _) _) = show s -- | Get the exclusive size (not including any referenced closures) of a closure.-closureExclusiveSize :: DebugClosure srt p cd s c -> Size+closureExclusiveSize :: DebugClosure ccs srt p cd s c -> Size closureExclusiveSize (Stack{}) = Size (-1) closureExclusiveSize (Closure _ c) = (GD.dcSize c) --- | Get the retained size (including all dominated closures) of a closure.-closureRetainerSize :: Analysis -> DebugClosure srt p cd s c -> RetainerSize-closureRetainerSize analysis c = snd (closureExcAndRetainerSizes analysis c)--closureExcAndRetainerSizes :: Analysis -> DebugClosure srt p cd s c -> (Size, RetainerSize)-closureExcAndRetainerSizes _ Stack{} = (Size (-1), RetainerSize (-1))- -- ^ TODO How should we handle stack size? only used space on the stack?- -- Include underflow frames? Return Maybe?-closureExcAndRetainerSizes analysis (Closure cPtr _) =- let getSizes = analysisSizes analysis- in getSizes cPtr--closureSourceLocation :: Debuggee -> DebugClosure srt p cd s c -> IO (Maybe SourceInformation)+closureSourceLocation :: Debuggee -> DebugClosure ccs srt p cd s c -> IO (Maybe SourceInformation) closureSourceLocation _ (Stack _ _) = return Nothing closureSourceLocation e (Closure _ c) = run e $ do request (RequestSourceInfo (tableId (info (noSize c)))) -closureInfoPtr :: DebugClosure srt p cd s c -> Maybe InfoTablePtr+closureInfoPtr :: DebugClosure ccs srt p cd s c -> Maybe InfoTablePtr closureInfoPtr (Stack {}) = Nothing closureInfoPtr (Closure _ c) = Just (tableId (info (noSize c))) @@ -340,43 +371,72 @@ infoSourceLocation e ip = run e $ request (RequestSourceInfo ip) -- | Get the directly referenced closures (with a label) of a closure.-closureReferences :: Debuggee -> DebugClosure SrtCont PayloadCont ConstrDesc StackCont ClosurePtr -> IO [(String, ListItem SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr)]+closureReferences :: Debuggee -> DebugClosure CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr -> IO [(String, ListItem CCSPtr SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr)] closureReferences e (Stack _ stack) = run e $ do stack' <- bitraverse GD.dereferenceSRT pure stack let action (GD.SPtr ptr) = ("Pointer", ListFullClosure . Closure ptr <$> GD.dereferenceClosure ptr) action (GD.SNonPtr dat) = ("Data:" ++ show dat, return ListData) - frame_items frame = ("Info: " ++ show (tableId (frame_info frame)), return (ListOnlyInfo (tableId (frame_info frame)))) :- [ ("SRT: ", ListFullClosure . Closure srt <$> GD.dereferenceClosure srt) | Just srt <- [getSrt (frame_srt frame)]]- ++ map action (GD.values frame)+-- frame_items :: DebugStackFrame+-- (GenSrtPayload ClosurePtr) ClosurePtr -> GD.DebugM [(String, _)]+ frame_items frame = do+ info <- GD.getSourceInfo (tableId (frame_info frame))+ case info of+ Just (SourceInformation {infoName = "stg_orig_thunk_info_frame_info"}) ->+ let [GD.SNonPtr dat] = GD.values frame+ in return [("Blackhole arising from thunk:", (ListOnlyInfo (InfoTablePtr dat)))]+ _ -> traverse sequenceA $ + ("Info: " ++ show (tableId (frame_info frame)), return (ListOnlyInfo (tableId (frame_info frame)))) :+ [ ("SRT: ", ListFullClosure . Closure srt <$> GD.dereferenceClosure srt) | Just srt <- [getSrt (frame_srt frame)]]+ ++ map action (GD.values frame)+ add_frame_ix ix (lbl, x) = ("Frame " ++ show ix ++ " " ++ lbl, x)- let lblAndPtrs = [ map (add_frame_ix frameIx) (frame_items frame)- | (frameIx, frame) <- zip [(0::Int)..] (GD.getFrames stack')- ]--- traverse GD.dereferenceClosures (snd <$> lblAndPtrs)- traverse (traverse id) (concat lblAndPtrs)+ lblAndPtrs <- sequence [ map (add_frame_ix frameIx) <$> (frame_items frame)+ | (frameIx, frame) <- zip [(0::Int)..] (GD.getFrames stack')+ ]+ return (concat lblAndPtrs) {- return $ zipWith (\(lbl,ptr) c -> (lbl, Closure ptr c)) lblAndPtrs closures -} closureReferences e (Closure _ closure) = run e $ do- closure' <- quintraverse GD.dereferenceSRT GD.dereferencePapPayload pure pure pure closure- let refPtrs = closureReferencesAndLabels (unDCS closure')- forM refPtrs $ \(label, ptr) -> case ptr of- Left cPtr -> do- refClosure' <- GD.dereferenceClosure cPtr- return (label, ListFullClosure $ Closure cPtr refClosure')- Right sPtr -> do- refStack' <- GD.dereferenceStack sPtr- return (label, ListFullClosure $ Stack sPtr refStack')+ closure' <- hextraverse pure GD.dereferenceSRT GD.dereferencePapPayload pure pure pure closure+ let wrapClosure cPtr = do+ refClosure' <- GD.dereferenceClosure cPtr+ return $ ListFullClosure $ Closure cPtr refClosure'+ wrapStack sPtr = do+ refStack' <- GD.dereferenceStack sPtr+ return $ ListFullClosure $ Stack sPtr refStack'+ wrapCCS ccsPtr = do+ refCCS <- do+ GD.dereferenceCCS ccsPtr >>= \ccs ->+ bitraverse pure GD.dereferenceCC ccs+ return $ ListCCS ccsPtr refCCS+ closureReferencesAndLabels wrapClosure+ wrapStack+ wrapCCS+ (unDCS closure') +ccsReferences :: Debuggee -> GenCCSPayload CCSPtr CCPayload -> IO [ListItem ccs srt a b c d]+ccsReferences e initialCcs = run e $ (ListCC (ccsCc initialCcs) :) <$> go initialCcs+ where+ go ccs = do+ case ccsPrevStack ccs of+ Nothing -> pure [ListCC (ccsCc ccs)]+ Just ccsPtr -> do+ child <- GD.dereferenceCCS ccsPtr+ child' <- bitraverse pure GD.dereferenceCC child+ children <- go child'+ return (ListCC (ccsCc child') : children)+ reverseClosureReferences :: HG.HeapGraph Size -> HG.ReverseGraph -> Debuggee- -> DebugClosure HG.SrtHI HG.PapHI ConstrDesc HG.StackHI (Maybe HG.HeapGraphIndex)+ -> DebugClosure CCSPtr HG.SrtHI HG.PapHI ConstrDesc HG.StackHI (Maybe HG.HeapGraphIndex) -> IO [(String, DebugClosure+ CCSPtr HG.SrtHI HG.PapHI ConstrDesc HG.StackHI@@ -392,121 +452,90 @@ (DCS (HG.hgeData hge) (HG.hgeClosure hge) )) | (n, hge) <- zip [0 :: Int ..] revs] -lookupHeapGraph :: HG.HeapGraph Size -> ClosurePtr -> Maybe (DebugClosure HG.SrtHI HG.PapHI ConstrDesc HG.StackHI (Maybe HG.HeapGraphIndex))+lookupHeapGraph :: HG.HeapGraph Size -> ClosurePtr -> Maybe (DebugClosure CCSPtr HG.SrtHI HG.PapHI ConstrDesc HG.StackHI (Maybe HG.HeapGraphIndex)) lookupHeapGraph hg cp = case HG.lookupHeapGraph cp hg of Just (HG.HeapGraphEntry ptr d s) -> Just (Closure ptr (DCS s d)) Nothing -> Nothing fillConstrDesc :: Debuggee- -> DebugClosure srt pap ConstrDescCont s c- -> IO (DebugClosure srt pap ConstrDesc s c)+ -> DebugClosure ccs srt pap ConstrDescCont s c+ -> IO (DebugClosure ccs srt pap ConstrDesc s c) fillConstrDesc e closure = do- run e $ GD.quintraverse pure pure GD.dereferenceConDesc pure pure closure+ run e $ GD.hextraverse pure pure pure GD.dereferenceConDesc pure pure closure -- | Pretty print a closure-closurePretty :: Debuggee -> DebugClosure InfoTablePtr PayloadCont ConstrDesc s ClosurePtr -> IO String+closurePretty :: Debuggee -> DebugClosure CCSPtr InfoTablePtr PayloadCont ConstrDesc s ClosurePtr -> IO String closurePretty _ (Stack _ frames) = return $ (show (length frames) ++ " frames") closurePretty dbg (Closure _ closure) = run dbg $ do- closure' <- quintraverse GD.dereferenceSRT GD.dereferencePapPayload pure pure pure closure+ closure' <- hextraverse pure GD.dereferenceSRT GD.dereferencePapPayload pure pure pure closure return $ HG.ppClosure (\_ refPtr -> show refPtr) 0 (unDCS closure') --- $dominatorTree------ Closure `a` dominates closure `b` if all paths from GC roots to `b` pass--- through `a`. This means that if `a` is GCed then all dominated closures can--- be GCed. The relationship is transitive. Transitive edges are omitted in the--- "dominator tree".------ see http://kohlerm.blogspot.com/2009/02/memory-leaks-are-easy-to-find.html---- | The roots of the dominator tree.-dominatorRootClosures :: Debuggee -> Analysis -> IO [Closure]-dominatorRootClosures e analysis = run e $ do- let domRoots = analysisDominatorRoots analysis- closures <- GD.dereferenceClosures domRoots- return [ Closure closurePtr' closure- | closurePtr' <- domRoots- | closure <- closures- ]---- | Get the dominatess of a closure i.e. the children in the dominator tree.-closureDominatees :: Debuggee -> Analysis -> DebugClosure srt p cd s ClosurePtr -> IO [Closure]-closureDominatees _ _ (Stack{}) = error "TODO dominator tree does not yet support STACKs"-closureDominatees e analysis (Closure cPtr _) = run e $ do- let cPtrToDominatees = analysisDominatees analysis- cPtrs = cPtrToDominatees cPtr- closures <- GD.dereferenceClosures cPtrs- return [ Closure closurePtr' closure- | closurePtr' <- cPtrs- | closure <- closures- ]---- -- Internal Stuff -- -closureReferencesAndLabels :: GD.DebugClosure (GenSrtPayload pointer) PapPayload string stack pointer -> [(String, Either pointer stack)]-closureReferencesAndLabels closure = case closure of+closureReferencesAndLabels :: Monad m => (pointer -> m a) -> (stack -> m a) -> (ccs -> m a) -> GD.DebugClosure ccs (GenSrtPayload pointer) PapPayload string stack pointer -> m [(String, a)]+closureReferencesAndLabels pointer stack fccs closure = sequence . map sequence $ [("CCS", fccs (ccs ph)) | Just ph <- pure (profHeader closure)] ++ case closure of TSOClosure {..} ->- [ ("Thread label", Left lbl) | Just lbl <- pure threadLabel ] ++- [ ("Stack", Left tsoStack)- , ("Link", Left _link)- , ("Global Link", Left global_link)- , ("TRec", Left trec)- , ("Blocked Exceptions", Left blocked_exceptions)- , ("Blocking Queue", Left bq)+ [ ("Thread label", pointer lbl) | Just lbl <- pure threadLabel ] +++ [ ("Stack", pointer tsoStack)+ , ("Link", pointer _link)+ , ("Global Link", pointer global_link)+ , ("TRec", pointer trec)+ , ("Blocked Exceptions", pointer blocked_exceptions)+ , ("Blocking Queue", pointer bq) ]- StackClosure{..} -> [("Frames", Right frames )]- WeakClosure {..} -> [ ("Key", Left key)- , ("Value", Left value)- , ("C Finalizers", Left cfinalizers)- , ("Finalizer", Left finalizer)+ StackClosure{..} -> [("Frames", stack frames )]+ WeakClosure {..} -> [ ("Key", pointer key)+ , ("Value", pointer value)+ , ("C Finalizers", pointer cfinalizers)+ , ("Finalizer", pointer finalizer) ] ++- [ ("Link", Left link)+ [ ("Link", pointer link) | Just link <- [mlink] -- TODO do we want to show NULL pointers some how? ]- TVarClosure {..} -> [("val", Left current_value)]+ TVarClosure {..} -> [("val", pointer current_value)] MutPrimClosure {..} -> withArgLables ptrArgs+ PrimClosure{..} -> withArgLables ptrArgs ConstrClosure {..} -> withFieldLables ptrArgs- ThunkClosure {..} -> [ ("SRT", Left cp) | Just cp <- [getSrt srt]]- ++ withArgLables ptrArgs- SelectorClosure {..} -> [("Selectee", Left selectee)]- IndClosure {..} -> [("Indirectee", Left indirectee)]- BlackholeClosure {..} -> [("Indirectee", Left indirectee)]- APClosure {..} -> ("Function", Left fun) : [] -- TODO withBitmapLables ap_payload- PAPClosure {..} -> ("Function", Left fun) : [] -- TODO: withBitmapLables pap_payload- APStackClosure {..} -> ("Function", Left fun) : ("Frames", Right payload) : []- BCOClosure {..} -> [ ("Instructions", Left instrs)- , ("Literals", Left literals)- , ("Byte Code Objects", Left bcoptrs)+ ThunkClosure {..} -> [("SRT", pointer cp) | Just cp <- [getSrt srt]]+ ++ withArgLables ptrArgs+ SelectorClosure {..} -> [("Selectee", pointer selectee)]+ IndClosure {..} -> [("Indirectee", pointer indirectee)]+ BlackholeClosure {..} -> [("Indirectee", pointer indirectee)]+ APClosure {..} -> ("Function", pointer fun) : [] -- TODO withBitmapLables ap_payload+ PAPClosure {..} -> ("Function", pointer fun) : [] -- TODO: withBitmapLables pap_payload+ APStackClosure {..} -> ("Function", pointer fun) : ("Frames", stack payload) : []+ BCOClosure {..} -> [ ("Instructions", pointer instrs)+ , ("Literals", pointer literals)+ , ("Byte Code Objects", pointer bcoptrs) ] ArrWordsClosure {} -> [] MutArrClosure {..} -> withIxLables mccPayload SmallMutArrClosure {..} -> withIxLables mccPayload- MutVarClosure {..} -> [("Value", Left var)]- MVarClosure {..} -> [ ("Queue Head", Left queueHead)- , ("Queue Tail", Left queueTail)- , ("Value", Left value)+ MutVarClosure {..} -> [("Value", pointer var)]+ MVarClosure {..} -> [ ("Queue Head", pointer queueHead)+ , ("Queue Tail", pointer queueTail)+ , ("Value", pointer value) ] FunClosure {..} ->- [ ("SRT", Left cp) | Just cp <- [getSrt srt]]+ [ ("SRT", pointer cp) | Just cp <- [getSrt srt]] ++ withArgLables ptrArgs- BlockingQueueClosure {..} -> [ ("Link", Left link)- , ("Black Hole", Left blackHole)- , ("Owner", Left owner)- , ("Queue", Left queue)+ BlockingQueueClosure {..} -> [ ("Link", pointer link)+ , ("Black Hole", pointer blackHole)+ , ("Owner", pointer owner)+ , ("Queue", pointer queue) ]- OtherClosure {..} -> ("",) . Left <$> hvalues+ OtherClosure {..} -> ("",) . pointer <$> hvalues TRecChunkClosure{} -> [] --TODO UnsupportedClosure {} -> [] where- withIxLables elements = [("[" <> show i <> "]" , Left x) | (i, x) <- zip [(0::Int)..] elements]- withArgLables ptrArgs = [("Argument " <> show i, Left x) | (i, x) <- zip [(0::Int)..] ptrArgs]- withFieldLables ptrArgs = [("Field " <> show i , Left x) | (i, x) <- zip [(0::Int)..] ptrArgs]+ withIxLables elements = [("[" <> show i <> "]" , pointer x) | (i, x) <- zip [(0::Int)..] elements]+ withArgLables ptrArgs = [("Argument " <> show i, pointer x) | (i, x) <- zip [(0::Int)..] ptrArgs]+ withFieldLables ptrArgs = [("Field " <> show i , pointer x) | (i, x) <- zip [(0::Int)..] ptrArgs] -- withBitmapLables pap = [("Argument " <> show i , Left x) | (i, SPtr x) <- zip [(0::Int)..] (getValues pap)] --
src/Main.hs view
@@ -11,6 +11,9 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE FlexibleContexts #-} module Main where @@ -21,7 +24,7 @@ import Brick.Widgets.Center (centerLayer, hCenter) import Brick.Widgets.List import Control.Applicative-import Control.Monad (forever)+import Control.Monad (forever, forM) import Control.Monad.IO.Class import Control.Monad.Catch (bracket) import Control.Concurrent@@ -30,20 +33,33 @@ import qualified Data.Ord as Ord import qualified Data.Sequence as Seq import qualified Graphics.Vty as Vty+import qualified Graphics.Vty.CrossPlatform as Vty import Graphics.Vty.Input.Events (Key(..)) import Lens.Micro.Platform import System.Directory import System.FilePath+import Data.Bool import Data.Text (Text, pack) import qualified Data.Text as T import qualified Data.Map as M-import Data.Maybe+import qualified Data.ByteString.Lazy as BS+import qualified Data.Set as S import qualified Data.Foldable as F+import Text.Read (readMaybe) -import GHC.Debug.Types.Ptr(readInfoTablePtr)+import qualified GHC.Debug.Profile as GDP+import GHC.Debug.Profile.Types+import Data.Semigroup++import GHC.Debug.Types.Ptr(readInfoTablePtr, arrWordsBS)+import qualified GHC.Debug.Types.Closures as Debug import IOTree import Lib as GD import Model+import Data.ByteUnits+import Data.Time.Format+import Data.Time.Clock+import qualified Numeric drawSetup :: Text -> Text -> GenericList Name Seq.Seq SocketInfo -> Widget Name@@ -79,45 +95,55 @@ Snapshot -> [drawSetup "snapshot" "processes" snaps] - Connected _socket _debuggee mode' -> case mode' of+ Connected socket _debuggee mode' -> case mode' of - RunningMode -> [mainBorder "ghc-debug - Running" $ vBox+ RunningMode -> [mainBorder ("ghc-debug - Running - " <> socketName socket) $ vBox [ txtWrap "There is nothing you can do until the process is paused by pressing (p) ..." , fill ' ' , withAttr menuAttr $ vLimit 1 $ hBox [txt "(p): Pause | (ESC): Exit", fill ' '] ]] - (PausedMode os@(OperationalState _ treeMode' kbmode fmode _ _ _)) -> let- in kbOverlay kbmode $ [mainBorder "ghc-debug - Paused" $ vBox+ (PausedMode os@(OperationalState _ last_task treeMode' kbmode fmode _ _ _ _ rfilters debuggeeVersion)) -> let+ last_task_string =+ case last_task of+ Nothing -> ""+ Just (d,t) -> " - " <> d <> " (" <> T.pack (formatTime defaultTimeLocale "%2Es" t) <> "s)"++ in kbOverlay kbmode debuggeeVersion+ $ [mainBorder ("ghc-debug - Paused - " <> socketName socket <> last_task_string) $ vBox [ -- Current closure details- joinBorders $ borderWithLabel (txt "Closure Details") $- vLimit 9 $- pauseModeTree (renderClosureDetails . ioTreeSelection) os- <=> fill ' '+ joinBorders $ (borderWithLabel (txt "Closure Details") $+ (vLimit 9 $+ pauseModeTree (\r io -> maybe emptyWidget r (ioTreeSelection io)) os+ <=> fill ' '))+ <+> (filterWindow rfilters) , -- Tree joinBorders $ borderWithLabel (txt $ case treeMode' of- SavedAndGCRoots -> "Root Closures"+ SavedAndGCRoots {} -> "Root Closures" Retainer {} -> "Retainers" Searched {} -> "Search Results" )- (pauseModeTree renderIOTree os)- , footer fmode+ (pauseModeTree (\_ -> renderIOTree) os)+ , footer (osSize os) (_resultSize os) fmode ]] where - kbOverlay :: OverlayMode -> [Widget Name] -> [Widget Name]- kbOverlay KeybindingsShown ws = centerLayer kbWindow : ws- kbOverlay (CommandPicker inp cmd_list) ws = centerLayer (cpWindow inp cmd_list) : ws- kbOverlay NoOverlay ws = ws+ kbOverlay :: OverlayMode -> GD.Version -> [Widget Name] -> [Widget Name]+ kbOverlay KeybindingsShown _ ws = centerLayer kbWindow : ws+ kbOverlay (CommandPicker inp cmd_list _) debuggeeVersion ws = centerLayer (cpWindow debuggeeVersion inp cmd_list) : ws+ kbOverlay NoOverlay _ ws = ws - cpWindow :: Form Text () Name -> GenericList Name Seq.Seq Command -> Widget Name- cpWindow input cmd_list = hLimit (actual_width + 2) $ vLimit (length commandList + 4) $+ filterWindow [] = emptyWidget+ filterWindow xs = borderWithLabel (txt "Filters") $ hLimit 50 $ vBox $ map renderUIFilter xs++ cpWindow :: GD.Version -> Form Text () Name -> GenericList Name Seq.Seq Command -> Widget Name+ cpWindow debuggeeVersion input cmd_list = hLimit (actual_width + 2) $ vLimit (length commandList + 4) $ withAttr menuAttr $ borderWithLabel (txt "Command Picker") $ vBox $ [ renderForm input- , renderList (\elIsSelected -> if elIsSelected then highlighted . renderCommand else renderCommand) False cmd_list]+ , renderList (\elIsSelected -> if elIsSelected then highlighted . renderCommand debuggeeVersion else renderCommand debuggeeVersion) False cmd_list] kbWindow :: Widget Name kbWindow =@@ -126,12 +152,13 @@ map renderCommandDesc all_keys all_keys =- [ ("Resume", Vty.EvKey (Vty.KChar 'r') [Vty.MCtrl])- , ("Parent", Vty.EvKey KLeft [])- , ("Child", Vty.EvKey KRight [])- , ("Command Picker", Vty.EvKey (Vty.KChar 'p') [Vty.MCtrl]) ]+ [ ("Resume", Just (Vty.EvKey (Vty.KChar 'r') [Vty.MCtrl]))+ , ("Parent", Just (Vty.EvKey KLeft []))+ , ("Child", Just (Vty.EvKey KRight []))+ , ("Command Picker", Just (Vty.EvKey (Vty.KChar 'p') [Vty.MCtrl]))+ , ("Invert Filter", Just invertFilterEvent)] ++ [(commandDescription cmd, commandKey cmd) | cmd <- F.toList commandList ]- ++ [ ("Exit", Vty.EvKey KEsc []) ]+ ++ [ ("Exit", Just (Vty.EvKey KEsc [])) ] maximum_size = maximum (map (T.length . fst) all_keys) @@ -139,6 +166,7 @@ + 1 -- 1, at least one padding renderKey :: Vty.Event -> Text+ renderKey (Vty.EvKey (KFun n) []) = "(F" <> T.pack (show n) <> ")" renderKey (Vty.EvKey k [Vty.MCtrl]) = "(^" <> renderNormalKey k <> ")" renderKey (Vty.EvKey k []) = "(" <> renderNormalKey k <> ")" renderKey _k = "()"@@ -149,59 +177,119 @@ renderNormalKey KRight = "→" renderNormalKey _k = "�" - renderCommand cmd = renderCommandDesc (commandDescription cmd, commandKey cmd)+ mayDisableMenuItem debuggeeVersion cmd+ | isCmdDisabled debuggeeVersion cmd = disabledMenuItem+ | otherwise = id + renderCommand debuggeeVersion cmd =+ mayDisableMenuItem debuggeeVersion cmd $+ renderCommandDesc (commandDescription cmd, commandKey cmd) - renderCommandDesc :: (Text, Vty.Event) -> Widget Name- renderCommandDesc (desc, k) = txt (desc <> T.replicate padding " " <> renderKey k)+ renderCommandDesc :: (Text, Maybe Vty.Event) -> Widget Name+ renderCommandDesc (desc, k) = txt (desc <> T.replicate padding " " <> key) where- key = renderKey k+ key = maybe mempty renderKey k padding = (actual_width - T.length desc - T.length key) - renderClosureDetails :: Maybe ClosureDetails -> Widget Name- renderClosureDetails (Just cd@(ClosureDetails {})) =- vLimit 9 $- -- viewport Connected_Paused_ClosureDetails Both $- vBox $- renderInfoInfo (_info cd)- ++- [ hBox [- txtLabel $ "Exclusive Size "- <> maybe "" (pack . show @Int . GD.getSize) (Just $ _excSize cd) <> " bytes"- ]- ]- renderClosureDetails Nothing = emptyWidget- renderClosureDetails (Just (LabelNode n)) = txt n- renderClosureDetails (Just (InfoDetails info')) = vLimit 9 $ vBox $ renderInfoInfo info'+renderInfoInfo :: InfoInfo -> [Widget Name]+renderInfoInfo info' =+ maybe [] renderSourceInformation (_sourceLocation info')+ ++ profHeaderInfo+ -- TODO these aren't actually implemented yet+ -- , txt $ "Type "+ -- <> fromMaybe "" (_closureType =<< cd)+ -- , txt $ "Constructor "+ -- <> fromMaybe "" (_constructor =<< cd)+ where+ profHeaderInfo = case _profHeaderInfo info' of+ Just x ->+ let plabel = case x of+ Debug.RetainerHeader{} -> "Retainer info"+ Debug.LDVWord{} -> "LDV info"+ Debug.EraWord{} -> "Era"+ Debug.OtherHeader{} -> "Other"+ in [labelled plabel $ vLimit 1 (txt $ renderProfHeaderInline x)]+ Nothing -> [] - renderInfoInfo :: InfoInfo -> [Widget Name]- renderInfoInfo info' =- maybe [] renderSourceInformation (_sourceLocation info')- -- TODO these aren't actually implemented yet- -- , txt $ "Type "- -- <> fromMaybe "" (_closureType =<< cd)- -- , txt $ "Constructor "- -- <> fromMaybe "" (_constructor =<< cd)+ renderProfHeaderInline :: ProfHeaderWord -> Text+ renderProfHeaderInline pinfo =+ case pinfo of+ Debug.RetainerHeader {} -> pack (show pinfo) -- This should never be visible+ Debug.LDVWord {state, creationTime, lastUseTime} ->+ (if state then "✓" else "✘") <> " created: " <> pack (show creationTime) <> (if state then " last used: " <> pack (show lastUseTime) else "")+ Debug.EraWord era -> pack (show era)+ Debug.OtherHeader other -> "Not supported: " <> pack (show other) - renderSourceInformation :: SourceInformation -> [Widget Name]- renderSourceInformation (SourceInformation name cty ty label' modu loc) =- [ labelled "Name" $ vLimit 1 (str name)- , labelled "Closure type" $ vLimit 1 (str (show cty))- , labelled "Type" $ vLimit 3 (str ty)- , labelled "Label" $ vLimit 1 (str label')- , labelled "Module" $ vLimit 1 (str modu)- , labelled "Location" $ vLimit 1 (str loc)+renderSourceInformation :: SourceInformation -> [Widget Name]+renderSourceInformation (SourceInformation name cty ty label' modu loc) =+ [ labelled "Name" $ vLimit 1 (str name)+ , labelled "Closure type" $ vLimit 1 (str (show cty))+ , labelled "Type" $ vLimit 3 (str ty)+ , labelled "Label" $ vLimit 1 (str label')+ , labelled "Module" $ vLimit 1 (str modu)+ , labelled "Location" $ vLimit 1 (str loc)+ ]++labelled :: Text -> Widget Name -> Widget Name+labelled = labelled' 20++labelled' :: Int -> Text -> Widget Name -> Widget Name+labelled' leftSize lbl w =+ hLimit leftSize (txtLabel lbl <+> vLimit 1 (fill ' ')) <+> w <+> vLimit 1 (fill ' ')++renderUIFilter :: UIFilter -> Widget Name+renderUIFilter (UIAddressFilter invert x) = labelled (bool "" "!" invert <> "Closure address") (str (show x))+renderUIFilter (UIInfoAddressFilter invert x) = labelled (bool "" "!" invert <> "Info table address") (str (show x))+renderUIFilter (UIConstructorFilter invert x) = labelled (bool "" "!" invert <> "Constructor name") (str x)+renderUIFilter (UIInfoNameFilter invert x) = labelled (bool "" "!" invert <> "Constructor name (exact)") (str x)+renderUIFilter (UIEraFilter invert x) = labelled (bool "" "!" invert <> "Era range") (str (showEraRange x))+renderUIFilter (UISizeFilter invert x) = labelled (bool "" "!" invert <> "Size (lower bound)") (str (show $ getSize x))+renderUIFilter (UIClosureTypeFilter invert x) = labelled (bool "" "!" invert <> "Closure type") (str (show x))+renderUIFilter (UICcId invert x) = labelled (bool "" "!" invert <> "CC Id") (str (show x))+++renderClosureDetails :: ClosureDetails -> Widget Name+renderClosureDetails (cd@(ClosureDetails {})) =+ vLimit 8 $+ -- viewport Connected_Paused_ClosureDetails Both $+ vBox $+ renderInfoInfo (_info cd)+ +++ [ hBox+ [ txtLabel "Exclusive Size" <+> vSpace <+> renderBytes (GD.getSize $ _excSize cd) ]+ ]+renderClosureDetails ((LabelNode n)) = txt n+renderClosureDetails ((InfoDetails info')) = vLimit 8 $ vBox $ renderInfoInfo info'+renderClosureDetails (CCSDetails _ _ptr (Debug.CCSPayload{..})) = vLimit 8 $ vBox $+ [ labelled "ID" $ vLimit 1 (str $ show ccsID)+ ] ++ renderCCPayload ccsCc+renderClosureDetails (CCDetails _ c) = vLimit 8 $ vBox $ renderCCPayload c - labelled :: Text -> Widget Name -> Widget Name- labelled lbl w =- hLimit 17 (txtLabel lbl <+> vLimit 1 (fill ' ')) <+> w <+> vLimit 1 (fill ' ')+renderCCPayload :: CCPayload -> [Widget Name]+renderCCPayload Debug.CCPayload{..} =+ [ labelled "Label" $ vLimit 1 (str ccLabel)+ , labelled "CC ID" $ vLimit 1 (str $ show ccID)+ , labelled "Module" $ vLimit 1 (str ccMod)+ , labelled "Location" $ vLimit 1 (str ccLoc)+ , labelled "Allocation" $ vLimit 1 (str $ show ccMemAlloc)+ , labelled "Time Ticks" $ vLimit 1 (str $ show ccTimeTicks)+ , labelled "Is CAF" $ vLimit 1 (str $ show ccIsCaf)+ ] -footer :: FooterMode -> Widget Name-footer m = vLimit 1 $- case m of+renderBytes :: Real a => a -> Widget n+renderBytes n =+ str (getShortHand (getAppropriateUnits (ByteValue (realToFrac n) Bytes)))++++footer :: Int -> Maybe Int -> FooterMode -> Widget Name+footer n m fmode = vLimit 1 $+ case fmode of FooterMessage t -> withAttr menuAttr $ hBox [txt t, fill ' ']- FooterInfo -> withAttr menuAttr $ hBox [txt "(↑↓): select item | (→): expand | (←): collapse | (^p): command picker | (?): full keybindings", fill ' ']+ FooterInfo -> withAttr menuAttr $ hBox $ [padRight Brick.Max $ txt "(↑↓): select item | (→): expand | (←): collapse | (^p): command picker | (^g): invert filter | (?): full keybindings"]+ ++ [padLeft (Pad 1) $ str $+ (show n <> " items/" <> maybe "∞" show m <> " max")] FooterInput _im form -> renderForm form footerInput :: FooterInputMode -> FooterMode@@ -303,16 +391,21 @@ -- Pause the debuggee VtyEvent (Vty.EvKey (KChar 'p') []) -> do liftIO $ pause debuggee'- (rootsTree, initRoots) <- liftIO $ mkSavedAndGCRootsIOTree Nothing+ ver <- liftIO $ GD.version debuggee'+ (rootsTree, initRoots) <- liftIO $ mkSavedAndGCRootsIOTree put (appState & majorState . mode .~ PausedMode (OperationalState Nothing- SavedAndGCRoots+ Nothing+ savedAndGCRoots NoOverlay FooterInfo (DefaultRoots initRoots) rootsTree- eventChan ))+ eventChan+ (Just 100)+ []+ ver)) @@ -344,49 +437,50 @@ where - mkSavedAndGCRootsIOTree manalysis = do+ mkSavedAndGCRootsIOTree = do raw_roots <- take 1000 . map ("GC Roots",) <$> GD.rootClosures debuggee'- rootClosures' <- liftIO $ mapM (completeClosureDetails debuggee' manalysis) raw_roots+ rootClosures' <- liftIO $ mapM (completeClosureDetails debuggee') raw_roots raw_saved <- map ("Saved Object",) <$> GD.savedClosures debuggee'- savedClosures' <- liftIO $ mapM (completeClosureDetails debuggee' manalysis) raw_saved- return $ (mkIOTree debuggee' manalysis (savedClosures' ++ rootClosures') getChildren id+ savedClosures' <- liftIO $ mapM (completeClosureDetails debuggee') raw_saved+ return $ (mkIOTree debuggee' (savedClosures' ++ rootClosures') getChildren renderInlineClosureDesc id , fmap toPtr <$> (raw_roots ++ raw_saved))- where -getChildren :: Debuggee -> DebugClosure SrtCont PayloadCont ConstrDesc StackCont ClosurePtr- -> IO- [(String, ListItem SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)]-getChildren d c = do+getChildren :: Debuggee -> ClosureDetails+ -> IO [ClosureDetails]+getChildren _ LabelNode{} = return []+getChildren _ CCDetails {} = return []+getChildren _ InfoDetails {} = return []+getChildren d (ClosureDetails c _ _) = do children <- closureReferences d c- traverse (traverse (fillListItem d)) children+ children' <- traverse (traverse (fillListItem d)) children+ mapM (\(lbl, child) -> getClosureDetails d (pack lbl) child) children'+getChildren d (CCSDetails _ _ cp) = do+ references <- zip [0 :: Int ..] <$> ccsReferences d cp+ mapM (\(lbl, cc) -> getClosureDetails d (pack (show lbl)) cc) references + fillListItem :: Debuggee- -> ListItem SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr- -> IO (ListItem SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)+ -> ListItem CCSPtr SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr+ -> IO (ListItem CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr) fillListItem _ (ListOnlyInfo x) = return $ ListOnlyInfo x-fillListItem d(ListFullClosure cd) = ListFullClosure <$> fillConstrDesc d cd+fillListItem d (ListFullClosure cd) = ListFullClosure <$> fillConstrDesc d cd fillListItem _ ListData = return ListData-+fillListItem _ (ListCCS c1 c2) = return $ ListCCS c1 c2+fillListItem _ (ListCC c1) = return $ ListCC c1 mkIOTree :: Debuggee- -> Maybe Analysis- -> [ClosureDetails]- -> (Debuggee -> DebugClosure- SrtCont PayloadCont ConstrDesc StackCont ClosurePtr- -> IO [(String, ListItem SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)])- -> ([ClosureDetails] -> [ClosureDetails])- -> IOTree ClosureDetails Name-mkIOTree debuggee' manalysis cs getChildren sort = ioTree Connected_Paused_ClosureTree+ -> [a]+ -> (Debuggee -> a -> IO [a])+ -> (a -> [Widget Name])+-- -> IO [(String, ListItem SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)])+ -> ([a] -> [a])+ -> IOTree a Name+mkIOTree debuggee' cs getChildrenGen renderNode sort = ioTree Connected_Paused_ClosureTree (sort cs)- (\c -> do- case c of- LabelNode {} -> return []- InfoDetails {} -> return []- _ -> do- children <- getChildren debuggee' (_closure c)- cDets <- mapM (\(lbl, child) -> getClosureDetails debuggee' manalysis (pack lbl) child) children- return (sort cDets)+ (\c -> sort <$> getChildrenGen debuggee' c+-- cDets <- mapM (\(lbl, child) -> getClosureDetails debuggee' manalysis (pack lbl) child) children+-- return (sort cDets) ) -- rendering the row (\state selected ctx depth closureDesc ->@@ -394,11 +488,17 @@ body = (if selected then visible . highlighted else id) $ hBox $- renderInlineClosureDesc closureDesc+ renderNode closureDesc in vdecorate state ctx depth body -- body (T.concat context) ) +era_colors :: [Vty.Color]+era_colors = [Vty.Color240 n | n <- [17..230]]++grey :: Vty.Color+grey = Vty.rgbColor (158 :: Int) 158 158+ -- | Draw the tree structure around the row item. Inspired by the -- 'border' functions in brick. --@@ -475,36 +575,61 @@ renderInlineClosureDesc :: ClosureDetails -> [Widget n] renderInlineClosureDesc (LabelNode t) = [txtLabel t] renderInlineClosureDesc (InfoDetails info') =- [txtLabel (_labelInParent info'), txt " ", txt (_pretty info')]-renderInlineClosureDesc closureDesc =+ [txtLabel (_labelInParent info'), vSpace, txt (_pretty info')]+renderInlineClosureDesc (CCSDetails clabel _cptr ccspayload) =+ [ txtLabel clabel, vSpace, txt (prettyCCS ccspayload)]+renderInlineClosureDesc (CCDetails clabel cc) =+ [ txtLabel clabel, vSpace, txt (prettyCC cc)]+renderInlineClosureDesc closureDesc@(ClosureDetails{}) = [ txtLabel (_labelInParent (_info closureDesc))- , txt " "- , txtWrap $- pack (closureShowAddress (_closure closureDesc))- <> " "- <> _pretty (_info closureDesc)+ , colorBar+ , txt $ pack (closureShowAddress (_closure closureDesc))+ , vSpace+ , txtWrap $ _pretty (_info closureDesc) ]-completeClosureDetails :: Debuggee -> Maybe Analysis- -> (Text, DebugClosure SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr)+ where+ colorBar =+ case colorId of+ Just {} -> padLeftRight 1 (colorEra (txt " "))+ Nothing -> vSpace++ colorId = _profHeaderInfo $ _info closureDesc+ colorEra = case colorId of+ Just (Debug.EraWord i) -> modifyDefAttr (flip Vty.withBackColor (era_colors !! (1 + (fromIntegral $ abs i) `mod` (length era_colors - 1))))+ Just (Debug.LDVWord {state}) -> case state of+ -- Used+ True -> modifyDefAttr (flip Vty.withBackColor Vty.green)+ -- Unused+ False -> id+ _ -> id++prettyCCS :: GenCCSPayload CCSPtr CCPayload -> Text+prettyCCS Debug.CCSPayload{ccsCc = cc} = prettyCC cc++prettyCC :: CCPayload -> Text+prettyCC Debug.CCPayload{..} =+ T.pack ccLabel <> " " <> T.pack ccMod <> " " <> T.pack ccLoc++completeClosureDetails :: Debuggee -> (Text, DebugClosure CCSPtr SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr) -> IO ClosureDetails -completeClosureDetails dbg manalysis (label', clos) =- getClosureDetails dbg manalysis label' . ListFullClosure =<< fillConstrDesc dbg clos+completeClosureDetails dbg (label', clos) =+ getClosureDetails dbg label' . ListFullClosure =<< fillConstrDesc dbg clos getClosureDetails :: Debuggee- -> Maybe Analysis -> Text- -> ListItem SrtCont PayloadCont ConstrDesc StackCont ClosurePtr+ -> ListItem CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr -> IO ClosureDetails-getClosureDetails debuggee' _ t (ListOnlyInfo info_ptr) = do+getClosureDetails debuggee' t (ListOnlyInfo info_ptr) = do info' <- getInfoInfo debuggee' t info_ptr return $ InfoDetails info'-getClosureDetails _ _ t ListData = return $ LabelNode t-getClosureDetails debuggee' manalysis label' (ListFullClosure c) = do+getClosureDetails _ plabel (ListCCS ccs payload) = return $ CCSDetails plabel ccs payload+getClosureDetails _ plabel (ListCC cc) = return $ CCDetails plabel cc+getClosureDetails _ t ListData = return $ LabelNode t+getClosureDetails debuggee' label' (ListFullClosure c) = do let excSize' = closureExclusiveSize c- retSize' = closureRetainerSize <$> manalysis <*> pure c sourceLoc <- maybe (return Nothing) (infoSourceLocation debuggee') (closureInfoPtr c) pretty' <- closurePretty debuggee' c return ClosureDetails@@ -513,11 +638,13 @@ _pretty = pack pretty' , _labelInParent = label' , _sourceLocation = sourceLoc- , _closureType = Nothing+ , _closureType = Just (T.pack $ show c) , _constructor = Nothing+ , _profHeaderInfo = case c of+ Closure{_closureSized=c1} -> Debug.hp <$> Debug.profHeader (Debug.unDCS c1)+ _ -> Nothing } , _excSize = excSize'- , _retainerSize = retSize' } getInfoInfo :: Debuggee -> Text -> InfoTablePtr -> IO InfoInfo@@ -533,6 +660,7 @@ , _sourceLocation = sourceLoc , _closureType = Nothing , _constructor = Nothing+ , _profHeaderInfo = Nothing } @@ -546,10 +674,11 @@ PollTick -> return () ProgressMessage t -> do put $ footerMessage t os- ProgressFinished ->+ ProgressFinished desc runtime -> put $ os & running_task .~ Nothing- & resetFooter+ & last_run_time .~ Just (desc, runtime)+ & footerMode .~ FooterInfo AsyncFinished action -> action _ | Nothing <- view running_task os -> case view keybindingsMode os of@@ -557,7 +686,7 @@ case e of VtyEvent (Vty.EvKey _ _) -> put $ os & keybindingsMode .~ NoOverlay _ -> put os- CommandPicker form cmd_list -> do+ CommandPicker form cmd_list orig_cmds -> do -- Overlapping commands are up/down so handle those just via list, otherwise both let handle_form = nestEventM' form (handleFormEvent (() <$ e)) handle_list =@@ -567,12 +696,13 @@ k form' cmd_list' = if (formState form /= formState form') then do let filter_string = formState form'- new_elems = Seq.filter (\cmd -> T.toLower filter_string `T.isInfixOf` T.toLower (commandDescription cmd )) commandList- cmd_list'' = cmd_list' & listElementsL .~ new_elems- & listSelectedL .~ if Seq.null new_elems then Nothing else Just 0- modify $ keybindingsMode .~ (CommandPicker form' cmd_list'')+ new_elems = Seq.filter (\cmd -> T.toLower filter_string `T.isInfixOf` T.toLower (commandDescription cmd )) orig_cmds+ cmd_list'' = cmd_list'+ & listElementsL .~ new_elems+ & listSelectedL .~ if Seq.null new_elems then Nothing else Just 0+ modify $ keybindingsMode .~ CommandPicker form' cmd_list'' orig_cmds else- modify $ keybindingsMode .~ (CommandPicker form' cmd_list')+ modify $ keybindingsMode .~ CommandPicker form' cmd_list' orig_cmds case e of@@ -586,9 +716,12 @@ put $ os & keybindingsMode .~ NoOverlay VtyEvent (Vty.EvKey Vty.KEnter _) -> do case listSelectedElement cmd_list of- Just (_, cmd) -> do- modify $ keybindingsMode .~ NoOverlay- dispatchCommand cmd+ Just (_, cmd)+ | isCmdDisabled (_version os) cmd ->+ return () -- If the command is disabled, just ignore the key press+ | otherwise -> do+ modify $ keybindingsMode .~ NoOverlay+ dispatchCommand cmd dbg Nothing -> return () _ -> do form' <- handle_form@@ -606,58 +739,105 @@ CommandPicker (newForm [(\w -> forceAttr inputAttr w) @@= editTextField id Overlay (Just 1)] "") (list CommandPicker_List commandList 1)+ commandList +savedAndGCRoots :: TreeMode+savedAndGCRoots = SavedAndGCRoots renderClosureDetails +-- ----------------------------------------------------------------------------+-- Commands and Shortcut constants+-- ----------------------------------------------------------------------------++invertFilterEvent :: Vty.Event+invertFilterEvent = Vty.EvKey (KChar 'g') [Vty.MCtrl]++isInvertFilterEvent :: Vty.Event -> Bool+isInvertFilterEvent = (invertFilterEvent ==)+ -- All the commands which we support, these show up in keybindings and also the command picker commandList :: Seq.Seq Command commandList =- [ Command "Show key bindings" (Vty.EvKey (KChar '?') [])- (modify $ keybindingsMode .~ KeybindingsShown)- , Command "Saved/GC Roots" (Vty.EvKey (KChar 's') [Vty.MCtrl])- (modify $ treeMode .~ SavedAndGCRoots)- , Command "Find Closures (Exact)" (Vty.EvKey (KChar 'c') [Vty.MCtrl])- (modify $ footerMode .~ footerInput FSearch)- , Command "Find Address" (Vty.EvKey (KChar 'a') [Vty.MCtrl])- (modify $ footerMode .~ footerInput FAddress)- , Command "Find Info Table" (Vty.EvKey (KChar 'i') [Vty.MCtrl])- (modify $ footerMode .~ footerInput FInfoTable)- , Command "Write Profile" (Vty.EvKey (KChar 'w') [Vty.MCtrl])- (modify $ footerMode .~ footerInput FProfile)- , Command "Find Retainers" (Vty.EvKey (KChar 'f') [Vty.MCtrl])- (modify $ footerMode .~ footerInput FRetainer)- , Command "Find Retainers (Exact)" (Vty.EvKey (KChar 'e') [Vty.MCtrl])- (modify $ footerMode .~ footerInput FRetainerExact)- , Command "Take Snapshot" (Vty.EvKey (KChar 'x') [Vty.MCtrl])- (modify $ footerMode .~ footerInput FSnapshot) ]+ [ mkCommand "Show key bindings" (Vty.EvKey (KChar '?') []) (modify $ keybindingsMode .~ KeybindingsShown)+ , mkCommand "Clear filters" (withCtrlKey 'w') (modify $ clearFilters)+ , Command "Search with current filters" (Just $ withCtrlKey 'f') searchWithCurrentFilters NoReq+ , mkCommand "Set search limit (default 100)" (withCtrlKey 'l') (setFooterInputMode FSetResultSize)+ , mkCommand "Saved/GC Roots" (withCtrlKey 's') (modify $ treeMode .~ savedAndGCRoots)+ , mkCommand "Find Address" (withCtrlKey 'a') (setFooterInputMode (FClosureAddress True False))+ , mkCommand "Find Info Table" (withCtrlKey 't') (setFooterInputMode (FInfoTableAddress True False))+ , mkCommand "Find Retainers" (withCtrlKey 'e') (setFooterInputMode (FConstructorName True False))+ , mkCommand' "Find Retainers (Exact)" (setFooterInputMode (FClosureName True False))+ , mkFilterCmd "Find closures by era" (withCtrlKey 'v') (setFooterInputMode (FFilterEras True False)) ReqErasProfiling+ , mkCommand "Find Retainers of large ARR_WORDS" (withCtrlKey 'u') (setFooterInputMode FArrWordsSize)+ , mkCommand "Dump ARR_WORDS payload" (withCtrlKey 'j') (setFooterInputMode FDumpArrWords)+ , mkCommand "Write Profile" (withCtrlKey 'b') (setFooterInputMode (FProfile OneLevel))+ , mkCommand' "Write Profile (2 level)" (setFooterInputMode (FProfile TwoLevel))+ , Command "Thunk Analysis" Nothing thunkAnalysisAction NoReq+ , mkCommand "Take Snapshot" (withCtrlKey 'x') (setFooterInputMode FSnapshot)+ , Command "ARR_WORDS Count" Nothing arrWordsAction NoReq+ , Command "Strings Count" Nothing stringsAction NoReq+ ] <> addFilterCommands+ where+ setFooterInputMode m = modify $ footerMode .~ footerInput m + addFilterCommands :: Seq.Seq Command+ addFilterCommands =+ [ mkCommand' "Add filter for address" (setFooterInputMode (FClosureAddress False False))+ , mkCommand' "Add filter for info table ptr" (setFooterInputMode (FInfoTableAddress False False))+ , mkCommand' "Add filter for constructor name" (setFooterInputMode (FConstructorName False False))+ , mkCommand' "Add filter for closure name" (setFooterInputMode (FClosureName False False))+ , mkFilterCmd' "Add filter for era" (setFooterInputMode (FFilterEras False False)) ReqErasProfiling+ , mkFilterCmd' "Add filter for cost centre id" (setFooterInputMode (FFilterCcId False False)) ReqSomeProfiling+ , mkCommand' "Add filter for closure size" (setFooterInputMode (FFilterClosureSize False))+ , mkCommand' "Add filter for closure type" (setFooterInputMode (FFilterClosureType False))+ , mkCommand' "Add exclusion for address" (setFooterInputMode (FClosureAddress False True))+ , mkCommand' "Add exclusion for info table ptr" (setFooterInputMode (FInfoTableAddress False True))+ , mkCommand' "Add exclusion for constructor name" (setFooterInputMode (FConstructorName False True))+ , mkCommand' "Add exclusion for closure name" (setFooterInputMode (FClosureName False True))+ , mkFilterCmd' "Add exclusion for era" (setFooterInputMode (FFilterEras False True)) ReqErasProfiling+ , mkFilterCmd' "Add exclusion for cost centre id" (setFooterInputMode (FFilterCcId False True)) ReqSomeProfiling+ , mkCommand' "Add exclusion for closure size" (setFooterInputMode (FFilterClosureSize True))+ , mkCommand' "Add exclusion for closure type" (setFooterInputMode (FFilterClosureType True))+ ] + withCtrlKey char = Vty.EvKey (KChar char) [Vty.MCtrl]+ findCommand :: Vty.Event -> Maybe Command findCommand event = do- i <- Seq.findIndexL (\cmd -> commandKey cmd == event) commandList+ i <- Seq.findIndexL (\cmd -> commandKey cmd == Just event) commandList Seq.lookup i commandList ++-- ----------------------------------------------------------------------------+-- Window Management+-- ----------------------------------------------------------------------------+ handleMainWindowEvent :: Debuggee -> Handler () OperationalState-handleMainWindowEvent _dbg brickEvent = do- os@(OperationalState _ treeMode' _kbMode _footerMode _curRoots rootsTree _) <- get+handleMainWindowEvent dbg brickEvent = do+ os@(OperationalState _ _ treeMode' _kbMode _footerMode _curRoots rootsTree _ _ _ debuggeeVersion) <- get case brickEvent of VtyEvent (Vty.EvKey (KChar 'p') [Vty.MCtrl]) -> put $ os & keybindingsMode .~ commandPickerMode -- A generic event- VtyEvent event | Just cmd <- findCommand event -> dispatchCommand cmd+ VtyEvent event+ | Just cmd <- findCommand event ->+ if isCmdDisabled debuggeeVersion cmd+ then return () -- Command is disabled, don't dispatch the command+ else dispatchCommand cmd dbg+ -- Navigate the tree of closures VtyEvent event -> case treeMode' of- SavedAndGCRoots -> do+ SavedAndGCRoots {} -> do newTree <- handleIOTreeEvent event rootsTree put (os & treeSavedAndGCRoots .~ newTree)- Retainer t -> do+ Retainer r t -> do newTree <- handleIOTreeEvent event t- put (os & treeMode .~ Retainer newTree)+ put (os & treeMode .~ Retainer r newTree) - Searched t -> do+ Searched r t -> do newTree <- handleIOTreeEvent event t- put (os & treeMode .~ Searched newTree)+ put (os & treeMode .~ Searched r newTree) _ -> return () @@ -670,75 +850,286 @@ case e of Vty.EvKey KEsc [] -> modify resetFooter Vty.EvKey KEnter [] -> dispatchFooterInput dbg m form- _ -> do- zoom (lens (const form) (\ os form' -> set footerMode (FooterInput m form') os)) (handleFormEvent re)+ _+ | isInvertFilterEvent e ->+ let m' = invertInput m in+ modify (footerMode .~ (FooterInput m' (updateFormState (formState form) $ footerInputForm m')))+ | otherwise -> do+ zoom (lens (const form) (\ os form' -> set footerMode (FooterInput m form') os)) (handleFormEvent re) inputFooterHandler _ _ _ k re = k re +stringsAction :: Debuggee -> EventM n OperationalState ()+stringsAction dbg = do+ outside_os <- get+ -- TODO: Does not honour search limit at all+ asyncAction "Counting strings" outside_os (stringsAnalysis Nothing dbg) $ \res -> do+ os <- get+ let cmp (k, v) = length k * (S.size v)+ let sorted_res = maybe id take (_resultSize os) $ Prelude.reverse [(k, S.toList v ) | (k, v) <- (List.sortBy (comparing (S.size . snd)) (M.toList res))]++ top_closure = [CountLine k (length k) (length v) | (k, v) <- sorted_res]++ g_children d (CountLine b _ _) = do+ let Just cs = M.lookup b res+ cs' <- run dbg $ forM (S.toList cs) $ \c -> do+ c' <- GD.dereferenceClosure c+ return $ ListFullClosure $ Closure c c'+ children' <- traverse (traverse (fillListItem d)) $ zipWith (\n c -> (show @Int n, c)) [0..] cs'+ mapM (\(lbl, child) -> FieldLine <$> getClosureDetails d (pack lbl) child) children'+ g_children d (FieldLine c) = map FieldLine <$> getChildren d c++ renderHeaderPane (CountLine k l n) = vBox+ [ labelled "Count " $ vLimit 1 $ str (show n)+ , labelled "Size " $ vLimit 1 $ renderBytes l+ , labelled "Total Size" $ vLimit 1 $ renderBytes (n * l)+ , strWrap (take 100 $ show k)+ ]+ renderHeaderPane (FieldLine c) = renderClosureDetails c++ tree = mkIOTree dbg top_closure g_children renderArrWordsLines id+ put (os & resetFooter+ & treeMode .~ Searched renderHeaderPane tree+ )+++data ArrWordsLine k = CountLine k Int Int | FieldLine ClosureDetails++++renderArrWordsLines :: Show a => ArrWordsLine a -> [Widget n]+renderArrWordsLines (CountLine k l n) = [strLabel (show n), vSpace, renderBytes l, vSpace, strWrap (take 100 $ show k)]+renderArrWordsLines (FieldLine cd) = renderInlineClosureDesc cd++-- | Render a histogram with n lines which displays the number of elements in each bucket,+-- and how much they contribute to the total size.+histogram :: Int -> [GD.Size] -> Widget Name+histogram boxes m =+ vBox $ map displayLine (bin 0 (map calcPercentage (List.sort m )))+ where+ Size maxSize = maximum m++ calcPercentage (Size tot) =+ (tot, (fromIntegral tot/ fromIntegral maxSize) * 100 :: Double)++ displayLine (l, h, n, tot) =+ str (show l) <+> txt "%-" <+> str (show h) <+> str "%: " <+> str (show n) <+> str " " <+> renderBytes tot++ step = fromIntegral (ceiling @Double @Int (100 / fromIntegral boxes))++ bin _ [] = []+ bin k xs = case now of+ [] -> bin (k + step) later+ _ -> (k, k+step, length now, sum (map fst now)) : bin (k + step) later+ where+ (now, later) = span ((<= k + step) . snd) xs++-- | Vertical space used to separate elements on the same line.+--+-- This is standardised for a consistent UI.+vSpace :: Widget n+vSpace = txt " "++arrWordsAction :: Debuggee -> EventM n OperationalState ()+arrWordsAction dbg = do+ outside_os <- get+ asyncAction "Counting ARR_WORDS" outside_os (arrWordsAnalysis Nothing dbg) $ \res -> do+ os <- get+ let all_res = Prelude.reverse [(k, S.toList v ) | (k, v) <- (List.sortBy (comparing (\(k, v) -> fromIntegral (BS.length k) * S.size v)) (M.toList res))]++ display_res = maybe id take (_resultSize os) all_res++ top_closure = [CountLine k (fromIntegral (BS.length k)) (length v) | (k, v) <- display_res]++ !words_histogram = histogram 8 (concatMap (\(k, bs) -> let sz = BS.length k in replicate (length bs) (Size (fromIntegral sz))) all_res)++ g_children d (CountLine b _ _) = do+ let Just cs = M.lookup b res+ cs' <- run dbg $ forM (S.toList cs) $ \c -> do+ c' <- GD.dereferenceClosure c+ return $ ListFullClosure $ Closure c c'+ children' <- traverse (traverse (fillListItem d)) $ zipWith (\n c -> (show @Int n, c)) [0..] cs'+ mapM (\(lbl, child) -> FieldLine <$> getClosureDetails d (pack lbl) child) children'+ g_children d (FieldLine c) = map FieldLine <$> getChildren d c++ renderHeaderPane (CountLine b l n) = vBox+ [ labelled "Count" $ vLimit 1 $ str (show n)+ , labelled "Size" $ vLimit 1 $ renderBytes l+ , labelled "Total Size" $ vLimit 1 $ renderBytes (n * l)+ , strWrap (take 100 $ show b)+ ]+ renderHeaderPane (FieldLine c) = renderClosureDetails c++ renderWithHistogram c = joinBorders (renderHeaderPane c <+>+ (padRight (Pad 1) $ (padLeft Brick.Max $ borderWithLabel (txt "Histogram") $ hLimit 100 $ words_histogram)))++ tree = mkIOTree dbg top_closure g_children renderArrWordsLines id+ put (outside_os & resetFooter+ & treeMode .~ Searched renderWithHistogram tree+ )++data ThunkLine = ThunkLine (Maybe SourceInformation) Count++thunkAnalysisAction :: Debuggee -> EventM n OperationalState ()+thunkAnalysisAction dbg = do+ outside_os <- get+ -- TODO: Does not honour search limit at all+ asyncAction "Counting thunks" outside_os (thunkAnalysis dbg) $ \res -> do+ os <- get+ let top_closure = Prelude.reverse [ ThunkLine k v | (k, v) <- (List.sortBy (comparing (getCount . snd)) (M.toList res))]++ g_children _ (ThunkLine {}) = pure []++ renderHeaderPane (ThunkLine sc c) = vBox $+ maybe [txt "NoLoc"] renderSourceInformation sc+ ++ [ strWrap ("Count: " ++ show (getCount c)) ]++ renderInline (ThunkLine msc (Count c)) =+ [(case msc of+ Just sc -> strLabel (infoPosition sc)+ Nothing -> txtLabel "NoLoc"), txt " ", str (show c) ]+++ tree = mkIOTree dbg top_closure g_children renderInline id+ put (os & resetFooter+ & treeMode .~ Searched renderHeaderPane tree+ )+++searchWithCurrentFilters :: Debuggee -> EventM n OperationalState ()+searchWithCurrentFilters dbg = do+ outside_os <- get+ let mClosFilter = uiFiltersToFilter (_filters outside_os)+ asyncAction "Searching for closures" outside_os (liftIO $ retainersOf (_resultSize outside_os) mClosFilter Nothing dbg) $ \cps -> do+ os <- get+ let cps' = map (zipWith (\n cp -> (T.pack (show n),cp)) [0 :: Int ..]) cps+ res <- liftIO $ mapM (mapM (completeClosureDetails dbg)) cps'+ let tree = mkRetainerTree dbg res+ put (os & resetFooter+ & treeMode .~ Retainer renderClosureDetails tree+ )++filterOrRun :: Debuggee -> Form Text () Name -> Bool -> (String -> Maybe a) -> (a -> [UIFilter]) -> EventM n OperationalState ()+filterOrRun dbg form doRun parse createFilter =+ filterOrRunM dbg form doRun parse (pure . createFilter)++filterOrRunM :: Debuggee -> Form Text () Name -> Bool -> (String -> Maybe a) -> (a -> EventM n OperationalState [UIFilter]) -> EventM n OperationalState ()+filterOrRunM dbg form doRun parse createFilterM = do+ case parse (T.unpack (formState form)) of+ Just x+ | doRun -> do+ newFilter <- createFilterM x+ modify $ setFilters newFilter+ searchWithCurrentFilters dbg+ | otherwise -> do+ newFilter <- createFilterM x+ modify $ (resetFooter . addFilters newFilter)+ Nothing -> modify resetFooter++data ProfileLine = ProfileLine GDP.ProfileKey GDP.ProfileKeyArgs CensusStats | ClosureLine ClosureDetails++renderProfileLine :: ProfileLine -> [Widget Name]+renderProfileLine (ClosureLine c) = renderInlineClosureDesc c+renderProfileLine (ProfileLine k kargs c) =+ [txt (GDP.prettyShortProfileKey k <> GDP.prettyShortProfileKeyArgs kargs), txt " ", showLine c]+ where+ showLine :: CensusStats -> Widget Name+ showLine (CS (Count n) (Size s) (Data.Semigroup.Max (Size mn)) _) =+ hBox+ [ withFontColor totalSizeColor $ str (show s), vSpace+ , withFontColor countColor $ str (show n), vSpace+ , withFontColor sizeColor $ str (show mn), vSpace+ , withFontColor avgSizeColor $ str (Numeric.showFFloat @Double (Just 1) (fromIntegral s / fromIntegral n) "")+ ]++ withFontColor color = modifyDefAttr (flip Vty.withForeColor color)++ totalSizeColor = Vty.RGBColor 0x26 0x83 0xDE+ countColor = Vty.RGBColor 0xDE 0x66 0x26+ sizeColor = Vty.RGBColor 0x26 0xDE 0xD7+ avgSizeColor = Vty.RGBColor 0xAB 0x4D 0xE0++ -- | What happens when we press enter in footer input mode dispatchFooterInput :: Debuggee -> FooterInputMode -> Form Text () Name -> EventM n OperationalState ()-dispatchFooterInput dbg FSearch form = do- os <- get- asyncAction "Searching for closures" os (map head <$> (liftIO $ retainersOfConstructor Nothing dbg (T.unpack (formState form)))) $ \cps -> do- let cps' = (zipWith (\n cp -> (T.pack (show n),cp)) [0 :: Int ..]) cps- res <- liftIO $ mapM (completeClosureDetails dbg Nothing) cps'- let tree = mkIOTree dbg Nothing res getChildren id- put (os & resetFooter- & treeMode .~ Searched tree- )-dispatchFooterInput dbg FAddress form = do- os <- get- let address = T.unpack (formState form)- case readClosurePtr address of- Just cp -> do- asyncAction "Finding address" os (map head <$> (liftIO $ retainersOfAddress Nothing dbg [cp])) $ \cps -> do- let cps' = (zipWith (\n cp' -> (T.pack (show n),cp')) [0 :: Int ..]) cps- res <- liftIO $ mapM (completeClosureDetails dbg Nothing) cps'- let tree = mkIOTree dbg Nothing res getChildren id- put (os & resetFooter- & treeMode .~ Searched tree- )- Nothing -> put (os & resetFooter)+dispatchFooterInput dbg (FClosureAddress runf invert) form = filterOrRun dbg form runf readClosurePtr (pure . UIAddressFilter invert)+dispatchFooterInput dbg (FInfoTableAddress runf invert) form = filterOrRun dbg form runf readInfoTablePtr (pure . UIInfoAddressFilter invert)+dispatchFooterInput dbg (FConstructorName runf invert) form = filterOrRun dbg form runf Just (pure . UIConstructorFilter invert)+dispatchFooterInput dbg (FClosureName runf invert) form = filterOrRun dbg form runf Just (pure . UIInfoNameFilter invert)+dispatchFooterInput dbg FArrWordsSize form = filterOrRun dbg form True readMaybe (\size -> [UIClosureTypeFilter False Debug.ARR_WORDS, UISizeFilter False size])+dispatchFooterInput dbg (FFilterEras runf invert) form = filterOrRun dbg form runf (parseEraRange . T.pack) (pure . UIEraFilter invert)+dispatchFooterInput dbg (FFilterClosureSize invert) form = filterOrRun dbg form False readMaybe (pure . UISizeFilter invert)+dispatchFooterInput dbg (FFilterClosureType invert) form = filterOrRun dbg form False readMaybe (pure . UIClosureTypeFilter invert)+dispatchFooterInput dbg (FFilterCcId runf invert) form = filterOrRun dbg form runf readMaybe (pure . UICcId invert)+dispatchFooterInput dbg (FProfile lvl) form = do+ outside_os <- get -dispatchFooterInput dbg FInfoTable form = do- os <- get- let address = T.unpack (formState form)- case readInfoTablePtr address of- Just info_ptr -> do- mb_src <- liftIO $ infoSourceLocation dbg info_ptr- asyncAction ("Finding info table " <> T.pack (show info_ptr ++ maybe "" ((" " ++) . show) mb_src)) os (map head <$> (liftIO $ retainersOfInfoTable Nothing dbg info_ptr)) $ \cps -> do- let cps' = (zipWith (\n cp' -> (T.pack (show n),cp')) [0 :: Int ..]) cps- res <- liftIO $ mapM (completeClosureDetails dbg Nothing) cps'- let tree = mkIOTree dbg Nothing res getChildren id- put (os & resetFooter- & treeMode .~ Searched tree- )- Nothing -> put (os & resetFooter)+ asyncAction "Writing profile" outside_os (profile dbg lvl (T.unpack (formState form))) $ \res -> do+ os <- get+ let top_closure = Prelude.reverse [ProfileLine k kargs v | ((k, kargs), v) <- (List.sortBy (comparing (cssize . snd)) (M.toList res))] -dispatchFooterInput dbg FProfile form = do- os <- get- asyncAction_ "Writing profile" os $ profile dbg (T.unpack (formState form))-dispatchFooterInput dbg FRetainer form = do- os <- get- let roots = mapMaybe go (map snd (currentRoots (view rootsFrom os)))- go (CP p) = Just p- go (SP _) = Nothing- asyncAction "Finding retainers" os (retainersOfConstructor (Just roots) dbg (T.unpack (formState form))) $ \cps -> do- let cps' = map (zipWith (\n cp -> (T.pack (show n),cp)) [0 :: Int ..]) cps- res <- liftIO $ mapM (mapM (completeClosureDetails dbg Nothing)) cps'- let tree = mkRetainerTree dbg res- put (os & resetFooter- & treeMode .~ Retainer tree)-dispatchFooterInput dbg FRetainerExact form = do- os <- get- asyncAction "Finding exact retainers" os (retainersOfConstructorExact dbg (T.unpack (formState form))) $ \cps -> do- let cps' = map (zipWith (\n cp -> (T.pack (show n),cp)) [0 :: Int ..]) cps- res <- liftIO $ mapM (mapM (completeClosureDetails dbg Nothing)) cps'- let tree = mkRetainerTree dbg res+ total_stats = foldMap snd (M.toList res)++ g_children d (ClosureLine c) = map ClosureLine <$> getChildren d c+ g_children d (ProfileLine _ _ stats) = do+ let cs = getSamples (sample stats)+ cs' <- run dbg $ forM cs $ \c -> do+ c' <- GD.dereferenceClosure c+ return $ ListFullClosure $ Closure c c'+ children' <- traverse (traverse (fillListItem d)) $ zipWith (\n c -> (show @Int n, c)) [0..] cs'+ mapM (\(lbl, child) -> ClosureLine <$> getClosureDetails d (pack lbl) child) children'++ renderHeaderPane (ClosureLine cs) = renderClosureDetails cs+ renderHeaderPane (ProfileLine k args (CS (Count n) (Size s) (Data.Semigroup.Max (Size mn)) _)) = vBox $+ [ txtLabel "Label " <+> vSpace <+> txt (GDP.prettyShortProfileKey k <> GDP.prettyShortProfileKeyArgs args)+ ]+ <>+ (case k of+ GDP.ProfileConstrDesc desc ->+ [ txtLabel "Package " <+> vSpace <+> (txt (GDP.pkgsText desc))+ , txtLabel "Module " <+> vSpace <+> (txt (GDP.modlText desc))+ , txtLabel "Constructor" <+> vSpace <+> (txt (GDP.nameText desc))+ ]+ _ -> []+ )+ <>+ [ txtLabel "Count " <+> vSpace <+> str (show n)+ , txtLabel "Size " <+> vSpace <+> renderBytes s+ , txtLabel "Max " <+> vSpace <+> renderBytes mn+ , txtLabel "Average " <+> vSpace <+> renderBytes @Double (fromIntegral s / fromIntegral n)+ ]++ renderWithStats l = joinBorders $ renderHeaderPane l <+>+ (padRight (Pad 1) $ (padLeft Brick.Max $ renderHeaderPane (ProfileLine (GDP.ProfileClosureDesc "Total") GDP.NoArgs total_stats)))+++ tree :: IOTree ProfileLine Name+ tree = mkIOTree dbg top_closure g_children renderProfileLine id put (os & resetFooter- & treeMode .~ Retainer tree)+ & treeMode .~ Searched renderWithStats tree+ )+dispatchFooterInput _ FDumpArrWords form = do+ os <- get+ let act node = asyncAction_ "dumping ARR_WORDS payload" os $+ case node of+ Just ClosureDetails{_closure = Closure{_closureSized = Debug.unDCS -> Debug.ArrWordsClosure{bytes, arrWords}}} ->+ BS.writeFile (T.unpack $ formState form) $ arrWordsBS (take (fromIntegral bytes) arrWords)+ _ -> pure ()+ case view treeMode os of+ Retainer _ iotree -> act (ioTreeSelection iotree)+ SavedAndGCRoots _ -> act (ioTreeSelection (view treeSavedAndGCRoots os))+ Searched {} -> put (os & footerMessage "Dump for search mode not implemented yet")+dispatchFooterInput _ FSetResultSize form = do+ outside_os <- get+ asyncAction "setting result size" outside_os (pure ()) $ \() -> do+ os <- get+ case readMaybe $ T.unpack (formState form) of+ Just n+ | n <= 0 -> put (os & resultSize .~ Nothing)+ | otherwise -> put (os & resultSize .~ (Just n))+ Nothing -> pure () dispatchFooterInput dbg FSnapshot form = do os <- get asyncAction_ "Taking snapshot" os $ snapshot dbg (T.unpack (formState form))@@ -750,9 +1141,11 @@ asyncAction desc os action final = do tid <- (liftIO $ forkIO $ do writeBChan eventChan (ProgressMessage desc)+ start <- getCurrentTime res <- action+ end <- getCurrentTime writeBChan eventChan (AsyncFinished (final res))- writeBChan eventChan ProgressFinished)+ writeBChan eventChan (ProgressFinished desc (end `diffUTCTime` start))) put $ os & running_task .~ Just tid & resetFooter where@@ -764,18 +1157,21 @@ mkRetainerTree dbg stacks = do let stack_map = [ (cp, rest) | stack <- stacks, Just (cp, rest) <- [List.uncons stack]] roots = map fst stack_map- info_map :: M.Map Ptr [(String, ListItem SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)]- info_map = M.fromList [(toPtr (_closure k), zipWith (\n cp -> ((show n), ListFullClosure (_closure cp))) [0 :: Int ..] v) | (k, v) <- stack_map]+ info_map :: M.Map Ptr [(Text, (DebugClosure CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr))]+ info_map = M.fromList [(toPtr (_closure k), zipWith (\n cp -> ((T.pack (show n)), (_closure cp))) [0 :: Int ..] v) | (k, v) <- stack_map] - lookup_c dbg' dc = do+ lookup_c dbg' dc'@(ClosureDetails dc _ _) = do let ptr = toPtr dc results = M.findWithDefault [] ptr info_map -- We are also looking up the children of the object we are retaining, -- and displaying them prior to the retainer stack- cs <- getChildren dbg' dc- return (cs ++ results)+ cs <- getChildren dbg' dc'+ results' <- liftIO $ mapM (\(l, c) -> getClosureDetails dbg' l (ListFullClosure c)) results+ return (cs ++ results')+ -- And if it's not a closure, just do the normal thing+ lookup_c dbg' dc' = getChildren dbg' dc' - mkIOTree dbg Nothing roots lookup_c id+ mkIOTree dbg roots lookup_c renderInlineClosureDesc id resetFooter :: OperationalState -> OperationalState resetFooter l = (set footerMode FooterInfo l)@@ -794,6 +1190,7 @@ , (labelAttr, Vty.withStyle (fg Vty.white) Vty.bold) , (highlightAttr, Vty.black `on` Vty.yellow) , (treeAttr, fg Vty.red)+ , (disabledMenuAttr, Vty.withStyle (grey `on` Vty.blue) Vty.bold) ] menuAttr :: AttrName@@ -811,11 +1208,20 @@ highlightAttr :: AttrName highlightAttr = attrName "highlighted" +disabledMenuAttr :: AttrName+disabledMenuAttr = attrName "disabledMenu"+ txtLabel :: Text -> Widget n txtLabel = withAttr labelAttr . txt +strLabel :: String -> Widget n+strLabel = withAttr labelAttr . str+ highlighted :: Widget n -> Widget n highlighted = forceAttr highlightAttr++disabledMenuItem :: Widget n -> Widget n+disabledMenuItem = forceAttr disabledMenuAttr main :: IO () main = do
src/Model.hs view
@@ -5,6 +5,9 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NamedFieldPuns #-} module Model ( module Model@@ -12,29 +15,39 @@ , module Common ) where +import Data.Maybe (fromMaybe) import Data.Sequence as Seq import Lens.Micro.Platform import Data.Time import System.Directory import System.FilePath import Data.Text(Text, pack)+import qualified Data.Text as T+import Text.Read import Brick.Forms import Brick.BChan-import Brick (EventM)+import Brick (EventM, Widget) import Brick.Widgets.List-import IOTree import Namespace import Common import Lib+import IOTree import Control.Concurrent import qualified Graphics.Vty as Vty+import Data.Int+import GHC.Debug.Client (ccID)+import GHC.Debug.Client.Monad (DebugM)+import GHC.Debug.CostCentres (findAllChildrenOfCC)+import qualified GHC.Debug.Types as GD+import qualified GHC.Debug.Types.Version as GD + data Event = PollTick -- Used to perform arbitrary polling based tasks e.g. looking for new debuggees | ProgressMessage Text- | ProgressFinished+ | ProgressFinished Text NominalDiffTime | AsyncFinished (EventM Name OperationalState ()) @@ -102,21 +115,29 @@ , _pretty :: Text , _sourceLocation :: Maybe SourceInformation , _closureType :: Maybe Text- , _constructor :: Maybe Text }+ , _constructor :: Maybe Text+ , _profHeaderInfo :: !(Maybe ProfHeaderWord)+ } deriving Show data ClosureDetails = ClosureDetails- { _closure :: DebugClosure SrtCont PayloadCont ConstrDesc StackCont ClosurePtr- , _retainerSize :: Maybe RetainerSize+ { _closure :: DebugClosure CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr , _excSize :: Size , _info :: InfoInfo } | InfoDetails { _info :: InfoInfo }- | LabelNode { _label :: Text }+ | CCSDetails Text CCSPtr (GenCCSPayload CCSPtr CCPayload)+ | CCDetails Text CCPayload+ | LabelNode { _label :: Text } deriving Show -data TreeMode = SavedAndGCRoots- | Retainer (IOTree (ClosureDetails) Name)- | Searched (IOTree (ClosureDetails) Name)+data TreeMode = SavedAndGCRoots (ClosureDetails -> Widget Name)+ | Retainer (ClosureDetails -> Widget Name) (IOTree (ClosureDetails) Name)+ | forall a . Searched (a -> Widget Name) (IOTree a Name) +treeLength :: TreeMode -> Maybe Int+treeLength (SavedAndGCRoots {}) = Nothing+treeLength (Retainer _ tree) = Just $ Prelude.length $ getIOTreeRoots tree+treeLength (Searched _ tree) = Just $ Prelude.length $ getIOTreeRoots tree+ data FooterMode = FooterInfo | FooterMessage Text | FooterInput FooterInputMode (Form Text () Name)@@ -125,27 +146,91 @@ isFocusedFooter (FooterInput {}) = True isFocusedFooter _ = False -data FooterInputMode = FAddress | FSearch | FInfoTable | FProfile | FRetainer | FRetainerExact | FSnapshot+data FooterInputMode = FClosureAddress {runNow :: Bool, invert :: Bool}+ | FInfoTableAddress {runNow :: Bool, invert :: Bool}+ | FConstructorName {runNow :: Bool, invert :: Bool}+ | FClosureName {runNow :: Bool, invert :: Bool}+ | FArrWordsSize+ | FFilterEras {runNow :: Bool, invert :: Bool}+ | FFilterClosureType {invert :: Bool}+ | FFilterClosureSize {invert :: Bool}+ | FFilterCcId {runNow :: Bool, invert :: Bool}+ | FProfile ProfileLevel+ | FSnapshot+ | FDumpArrWords+ | FSetResultSize+ deriving Show +-- | Profiling requirement for a command+data ProfilingReq+ = ReqSomeProfiling+ | ReqErasProfiling+ | NoReq+ data Command = Command { commandDescription :: Text- , commandKey :: Vty.Event- , dispatchCommand :: EventM Name OperationalState ()+ , commandKey :: Maybe Vty.Event+ , dispatchCommand :: Debuggee -> EventM Name OperationalState ()+ , commandRequiresProfMode :: ProfilingReq+ -- ^ The command requires that the debuggee is in a specific+ -- profiling mode.+ -- For example, we can only filter by eras if the program+ -- has era profiling enabled. } +mkCommand :: Text -> Vty.Event -> EventM Name OperationalState () -> Command+mkCommand desc ev dispatch = Command desc (Just ev) (\_ -> dispatch) NoReq++mkCommand' :: Text -> EventM Name OperationalState () -> Command+mkCommand' desc dispatch = Command desc Nothing (\_ -> dispatch) NoReq++mkFilterCmd :: Text -> Vty.Event -> EventM Name OperationalState () -> ProfilingReq -> Command+mkFilterCmd desc ev dispatch profMode = Command desc (Just ev) (\_ -> dispatch) profMode++mkFilterCmd' :: Text -> EventM Name OperationalState () -> ProfilingReq -> Command+mkFilterCmd' desc dispatch profMode = Command desc Nothing (\_ -> dispatch) profMode++isCmdEnabled :: GD.Version -> Command -> Bool+isCmdEnabled debuggeeVersion cmd = case commandRequiresProfMode cmd of+ NoReq -> True+ ReqErasProfiling ->+ Just GD.EraProfiling == GD.v_profiling debuggeeVersion+ ReqSomeProfiling ->+ GD.isProfiledRTS debuggeeVersion++isCmdDisabled :: GD.Version -> Command -> Bool+isCmdDisabled v cmd = not $ isCmdEnabled v cmd+ data OverlayMode = KeybindingsShown -- TODO: Abstract the "CommandPicker" into it's own module- | CommandPicker (Form Text () Name) (GenericList Name Seq Command)+ | CommandPicker (Form Text () Name) (GenericList Name Seq Command) (Seq Command) | NoOverlay +invertInput :: FooterInputMode -> FooterInputMode+invertInput x@FClosureAddress{invert} = x{invert = not invert}+invertInput x@FInfoTableAddress{invert} = x{invert = not invert}+invertInput x@FConstructorName{invert} = x{invert = not invert}+invertInput x@FClosureName{invert} = x{invert = not invert}+invertInput x@FFilterEras{invert} = x{invert = not invert}+invertInput x@FFilterClosureSize{invert} = x{invert = not invert}+invertInput x@FFilterClosureType{invert} = x{invert = not invert}+invertInput x@FFilterCcId{invert} = x{invert = not invert}+invertInput x = x+ formatFooterMode :: FooterInputMode -> Text-formatFooterMode FAddress = "address (0x..): "-formatFooterMode FSearch = "search: "-formatFooterMode FInfoTable = "info table pointer (0x..): "-formatFooterMode FProfile = "filename: "-formatFooterMode FRetainer = "constructor name: "-formatFooterMode FRetainerExact = "closure name: "+formatFooterMode FClosureAddress{invert} = (if invert then "!" else "") <> "address (0x..): "+formatFooterMode FInfoTableAddress{invert} = (if invert then "!" else "") <> "info table pointer (0x..): "+formatFooterMode FConstructorName{invert} = (if invert then "!" else "") <> "constructor name: "+formatFooterMode FClosureName{invert} = (if invert then "!" else "") <> "closure name: "+formatFooterMode FFilterEras{invert} = (if invert then "!" else "") <> "era range (<era>/<start-era>-<end-era>): "+formatFooterMode FFilterClosureSize{invert} = (if invert then "!" else "") <> "closure size (bytes): "+formatFooterMode FFilterClosureType{invert} = (if invert then "!" else "") <> "closure type: "+formatFooterMode FFilterCcId{invert} = (if invert then "!" else "") <> "CC Id: "+formatFooterMode FArrWordsSize = "size (bytes)>= "+formatFooterMode FDumpArrWords = "dump payload to file: "+formatFooterMode FSetResultSize = "search result limit (0 for infinity): " formatFooterMode FSnapshot = "snapshot name: "+formatFooterMode (FProfile {}) = "filename: " data ConnectedMode -- | Debuggee is running@@ -163,6 +248,7 @@ data OperationalState = OperationalState { _running_task :: Maybe ThreadId+ , _last_run_time :: Maybe (Text, NominalDiffTime) , _treeMode :: TreeMode , _keybindingsMode :: OverlayMode , _footerMode :: FooterMode@@ -170,13 +256,82 @@ , _treeSavedAndGCRoots :: IOTree (ClosureDetails) Name -- ^ Tree corresponding to SavedAndGCRoots mode , _event_chan :: BChan Event+ , _resultSize :: Maybe Int+ , _filters :: [UIFilter]+ , _version :: GD.Version } -pauseModeTree :: (IOTree ClosureDetails Name -> r) -> OperationalState -> r-pauseModeTree k (OperationalState _ mode _kb _footer _from roots _) = case mode of- SavedAndGCRoots -> k roots- Retainer r -> k r- Searched r -> k r+clearFilters :: OperationalState -> OperationalState+clearFilters os = os { _filters = [] }++setFilters :: [UIFilter] -> OperationalState -> OperationalState+setFilters fs os = os {_filters = fs}++addFilters :: [UIFilter] -> OperationalState -> OperationalState+addFilters fs os = os {_filters = fs ++ _filters os}++data UIFilter =+ UIAddressFilter Bool ClosurePtr+ | UIInfoAddressFilter Bool InfoTablePtr+ | UIConstructorFilter Bool String+ | UIInfoNameFilter Bool String+ | UIEraFilter Bool EraRange+ | UISizeFilter Bool Size+ | UIClosureTypeFilter Bool ClosureType+ | UICcId Bool Int64++uiFiltersToFilter :: [UIFilter] -> DebugM ClosureFilter+uiFiltersToFilter uifilters = do+ closFilters <- mapM uiFilterToFilter uifilters+ pure $ foldr AndFilter (PureFilter True) closFilters++uiFilterToFilter :: UIFilter -> DebugM ClosureFilter+uiFilterToFilter (UIAddressFilter invert x) = pure $ AddressFilter (xor invert . (== x))+uiFilterToFilter (UIInfoAddressFilter invert x) = pure $ InfoPtrFilter (xor invert . (== x))+uiFilterToFilter (UIConstructorFilter invert x) = pure $ ConstructorDescFilter (xor invert . (== x) . name)+uiFilterToFilter (UIInfoNameFilter invert x) = pure $ InfoSourceFilter (xor invert . (== x) . infoName)+uiFilterToFilter (UIEraFilter invert x) = pure $ ProfHeaderFilter (xor invert . (`profHeaderInEraRange` (Just x)))+uiFilterToFilter (UISizeFilter invert x) = pure $ SizeFilter (xor invert . (>= x))+uiFilterToFilter (UIClosureTypeFilter invert x) = pure $ InfoFilter (xor invert . (== x) . tipe)+uiFilterToFilter (UICcId invert x) = do+ ccsPtrs <- findAllChildrenOfCC ((x ==) . ccID)+ pure $ ProfHeaderFilter (xor invert . (`profHeaderReferencesCCS` ccsPtrs))++xor :: Bool -> Bool -> Bool+xor False False = False+xor True True = False+xor _ _ = True++parseEraRange :: Text -> Maybe EraRange+parseEraRange range = case T.splitOn "-" range of+ [nstr] -> case readMaybe (T.unpack nstr) of+ Just n -> Just $ EraRange n n+ Nothing -> Nothing+ [start,end] -> case (T.unpack start, T.unpack end) of+ ("", "") -> Just $ EraRange 0 maxBound+ ("", readMaybe -> Just e) -> Just $ EraRange 0 e+ (readMaybe -> Just s, "") -> Just $ EraRange s maxBound+ (readMaybe -> Just s, readMaybe -> Just e) -> Just $ EraRange s e+ _ -> Nothing+ _ -> Nothing++showEraRange :: EraRange -> String+showEraRange (EraRange s e)+ | s == e = show s+ | otherwise = "[" ++ show s ++ "," ++ go e+ where+ go n+ | n == maxBound = "∞)"+ | otherwise = show n ++ "]"++osSize :: OperationalState -> Int+osSize os = fromMaybe (Prelude.length (getIOTreeRoots $ _treeSavedAndGCRoots os)) $ treeLength (_treeMode os)++pauseModeTree :: (forall a . (a -> Widget Name) -> IOTree a Name -> r) -> OperationalState -> r+pauseModeTree k (OperationalState _ _ mode _kb _footer _from roots _ _ _ _) = case mode of+ SavedAndGCRoots render -> k render roots+ Retainer render r -> k render r+ Searched render r -> k render r makeLenses ''AppState makeLenses ''MajorState
src/Namespace.hs view
@@ -13,6 +13,7 @@ | Connected_Paused_ClosureDetails | Connected_Paused_ClosureTree | CommandPicker_List+ | FilterPicker_List | Overlay | Footer deriving (Eq, Ord, Show)