diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/ghc-debug-brick.cabal b/ghc-debug-brick.cabal --- a/ghc-debug-brick.cabal +++ b/ghc-debug-brick.cabal @@ -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" diff --git a/src/Common.hs b/src/Common.hs --- a/src/Common.hs +++ b/src/Common.hs @@ -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 () diff --git a/src/IOTree.hs b/src/IOTree.hs --- a/src/IOTree.hs +++ b/src/IOTree.hs @@ -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 diff --git a/src/Lib.hs b/src/Lib.hs --- a/src/Lib.hs +++ b/src/Lib.hs @@ -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)] -- diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/Model.hs b/src/Model.hs --- a/src/Model.hs +++ b/src/Model.hs @@ -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 (/-): " +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 diff --git a/src/Namespace.hs b/src/Namespace.hs --- a/src/Namespace.hs +++ b/src/Namespace.hs @@ -13,6 +13,7 @@ | Connected_Paused_ClosureDetails | Connected_Paused_ClosureTree | CommandPicker_List + | FilterPicker_List | Overlay | Footer deriving (Eq, Ord, Show)