diff --git a/client/src/GHC/Debug/Client/Monad/Simple.hs b/client/src/GHC/Debug/Client/Monad/Simple.hs index 6171fa659ae4efef082f380073617cadf1459c42..0c3cbb84ffb5850ea1382684cbd2b356f8296772 100644 --- a/client/src/GHC/Debug/Client/Monad/Simple.hs +++ b/client/src/GHC/Debug/Client/Monad/Simple.hs @@ -174,7 +174,10 @@ simpleReq req = do Nothing -> do mh <- asks debuggeeHandle case mh of - Nothing -> error ("Cache Miss:" ++ show req) + Nothing -> + case req of + RequestSRT _ -> return Nothing + _ -> error ("Cache Miss:" ++ show req) Just h -> do res <- liftIO $ doRequest h req liftIO $ modifyMVar_ rc_var (return . cacheReq req res) diff --git a/ghc-debug-brick/ghc-debug-brick.cabal b/ghc-debug-brick/ghc-debug-brick.cabal index 2c0c6b96286192fb12e8ba0f4b3f71611e02045d..273d7fa901f0e2305c2dac7949fac62230757549 100644 --- a/ghc-debug-brick/ghc-debug-brick.cabal +++ b/ghc-debug-brick/ghc-debug-brick.cabal @@ -36,6 +36,7 @@ executable ghc-debug-brick , unordered-containers , exceptions , contra-tracer + , bytestring hs-source-dirs: src default-language: Haskell2010 ghc-options: -threaded -Wall diff --git a/ghc-debug-brick/src/Lib.hs b/ghc-debug-brick/src/Lib.hs index af8a66e9fbd745ef708ad454a88384ec7753cc50..2571b4dc79f6e22ed64b98444917bf09a8df1c32 100644 --- a/ghc-debug-brick/src/Lib.hs +++ b/ghc-debug-brick/src/Lib.hs @@ -38,10 +38,10 @@ module Lib , DebugClosure(..) , closureShowAddress , closureExclusiveSize - , closureRetainerSize , closureSourceLocation , SourceInformation(..) , closureReferences + , closureReferences' , closurePretty , fillConstrDesc , InfoTablePtr @@ -53,10 +53,6 @@ module Lib , initialTraversal , HG.HeapGraph(..) -- * Dominator Tree - , dominatorRootClosures - , closureDominatees - , runAnalysis - , Analysis(..) , Size(..) , RetainerSize(..) -- * Reverse Edge Map @@ -74,6 +70,9 @@ module Lib , retainersOfArrWords , retainersOfInfoTable + -- * Counting + , arrWordsAnalysis + -- * Snapshot , snapshot @@ -97,8 +96,7 @@ module Lib ) 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) @@ -108,24 +106,17 @@ 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.Snapshot as GD +import qualified GHC.Debug.Strings 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 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 initialTraversal :: Debuggee -> IO (HG.HeapGraph Size) initialTraversal e = run e $ do @@ -142,6 +133,7 @@ initialTraversal e = run e $ do 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))] @@ -168,6 +160,7 @@ runAnalysis e hg = run e $ do [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. @@ -272,6 +265,13 @@ retainersOfInfoTable n mroots dbg info_ptr = do stack <- GD.findRetainersOfInfoTable n roots info_ptr traverse (\cs -> zipWith Closure cs <$> (GD.dereferenceClosures cs)) stack +arrWordsAnalysis :: Maybe [ClosurePtr] -> Debuggee -> IO (Map.Map BS.ByteString (Set.Set ClosurePtr)) +arrWordsAnalysis mroots dbg = do + run dbg $ do + roots <- maybe GD.gcRoots return mroots + arr_words <- GD.arrWordsAnalysis roots + return arr_words + -- -- | Request the description for an info table. -- -- The `InfoTablePtr` is just used for the equality -- requestConstrDesc :: Debuggee -> PayloadWithKey InfoTablePtr ClosurePtr -> IO ConstrDesc @@ -323,18 +323,6 @@ closureExclusiveSize :: DebugClosure 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 _ (Stack _ _) = return Nothing closureSourceLocation e (Closure _ c) = run e $ do @@ -369,9 +357,18 @@ closureReferences e (Stack _ stack) = run e $ do lblAndPtrs closures -} -closureReferences e (Closure _ closure) = run e $ do - closure' <- quintraverse GD.dereferenceSRT GD.dereferencePapPayload pure pure pure closure - let refPtrs = closureReferencesAndLabels (unDCS closure') +closureReferences e (Closure _ closure) = do + ps <- run e $ do + closure' <- quintraverse GD.dereferenceSRT GD.dereferencePapPayload pure pure pure closure + return $ closureReferencesAndLabels (unDCS closure') + closureReferences' e ps + + +closureReferences' :: Traversable t => Debuggee + -> t (a, Either ClosurePtr StackCont) + -> IO + (t (a, ListItem SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr)) +closureReferences' e refPtrs = run e $ do forM refPtrs $ \(label, ptr) -> case ptr of Left cPtr -> do refClosure' <- GD.dereferenceClosure cPtr @@ -422,38 +419,6 @@ closurePretty dbg (Closure _ closure) = run dbg $ do 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 -- diff --git a/ghc-debug-brick/src/Main.hs b/ghc-debug-brick/src/Main.hs index 914a6494c59c04e6f774a3d05d7f603281390a1f..75fe80b3d963d39b0a2fb0fe13c65a9874ce2f21 100644 --- a/ghc-debug-brick/src/Main.hs +++ b/ghc-debug-brick/src/Main.hs @@ -39,6 +39,7 @@ import Data.Text (Text, pack) import qualified Data.Text as T import qualified Data.Map as M import qualified Data.ByteString.Lazy as BS +import qualified Data.Set as S import Data.Maybe import qualified Data.Foldable as F import Text.Read (readMaybe) @@ -48,6 +49,7 @@ import qualified GHC.Debug.Types.Closures as Debug import IOTree import Lib as GD import Model +import Data.ByteString.Lazy (ByteString) drawSetup :: Text -> Text -> GenericList Name Seq.Seq SocketInfo -> Widget Name @@ -96,16 +98,16 @@ myAppDraw (AppState majorState' _) = [ -- Current closure details joinBorders $ borderWithLabel (txt "Closure Details") $ vLimit 9 $ - pauseModeTree (renderClosureDetails . ioTreeSelection) os + pauseModeTree (\r io -> maybe emptyWidget r (ioTreeSelection io)) os <=> fill ' ' , -- Tree joinBorders $ borderWithLabel (txt $ case treeMode' of - SavedAndGCRoots -> "Root Closures" + SavedAndGCRoots {} -> "Root Closures" Retainer {} -> "Retainers" Searched {} -> "Search Results" ) - (pauseModeTree renderIOTree os) + (pauseModeTree (\_ -> renderIOTree) os) , footer (osSize os) (_resultSize os) fmode ]] @@ -130,12 +132,12 @@ myAppDraw (AppState majorState' _) = 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]))] ++ [(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) @@ -156,50 +158,51 @@ myAppDraw (AppState majorState' _) = renderCommand 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') - -- TODO these aren't actually implemented yet - -- , txt $ "Type " - -- <> fromMaybe "" (_closureType =<< cd) - -- , txt $ "Constructor " - -- <> fromMaybe "" (_constructor =<< cd) - - 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 lbl w = - hLimit 17 (txtLabel lbl <+> vLimit 1 (fill ' ')) <+> w <+> vLimit 1 (fill ' ') +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) + +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 lbl w = + hLimit 17 (txtLabel lbl <+> vLimit 1 (fill ' ')) <+> w <+> vLimit 1 (fill ' ') + + +renderClosureDetails :: ClosureDetails -> Widget Name +renderClosureDetails (cd@(ClosureDetails {})) = + vLimit 8 $ + -- viewport Connected_Paused_ClosureDetails Both $ + vBox $ + renderInfoInfo (_info cd) + ++ + [ hBox [ + txtLabel $ "Exclusive Size " + <> maybe "" (pack . show @Int . GD.getSize) (Just $ _excSize cd) <> " bytes" + ] + ] +renderClosureDetails ((LabelNode n)) = txt n +renderClosureDetails ((InfoDetails info')) = vLimit 8 $ vBox $ renderInfoInfo info' footer :: Int -> Maybe Int -> FooterMode -> Widget Name footer n m mode = vLimit 1 $ @@ -308,11 +311,11 @@ myAppHandleEvent brickEvent = do -- Pause the debuggee VtyEvent (Vty.EvKey (KChar 'p') []) -> do liftIO $ pause debuggee' - (rootsTree, initRoots) <- liftIO $ mkSavedAndGCRootsIOTree Nothing + (rootsTree, initRoots) <- liftIO $ mkSavedAndGCRootsIOTree put (appState & majorState . mode .~ PausedMode (OperationalState Nothing - SavedAndGCRoots + savedAndGCRoots NoOverlay FooterInfo (DefaultRoots initRoots) @@ -350,22 +353,23 @@ myAppHandleEvent brickEvent = do 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 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 _ _ = return [] fillListItem :: Debuggee -> ListItem SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr @@ -374,25 +378,18 @@ fillListItem _ (ListOnlyInfo x) = return $ ListOnlyInfo x fillListItem d(ListFullClosure cd) = ListFullClosure <$> fillConstrDesc d cd fillListItem _ ListData = return ListData - 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 getChildren 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 <$> getChildren debuggee' c +-- cDets <- mapM (\(lbl, child) -> getClosureDetails debuggee' manalysis (pack lbl) child) children +-- return (sort cDets) ) -- rendering the row (\state selected ctx depth closureDesc -> @@ -400,7 +397,7 @@ mkIOTree debuggee' manalysis cs getChildren sort = ioTree Connected_Paused_Closu body = (if selected then visible . highlighted else id) $ hBox $ - renderInlineClosureDesc closureDesc + renderNode closureDesc in vdecorate state ctx depth body -- body (T.concat context) ) @@ -490,27 +487,24 @@ renderInlineClosureDesc closureDesc = <> " " <> _pretty (_info closureDesc) ] -completeClosureDetails :: Debuggee -> Maybe Analysis - -> (Text, DebugClosure SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr) +completeClosureDetails :: Debuggee -> (Text, DebugClosure 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 -> 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 _ 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 @@ -523,7 +517,6 @@ getClosureDetails debuggee' manalysis label' (ListFullClosure c) = do , _constructor = Nothing } , _excSize = excSize' - , _retainerSize = retSize' } getInfoInfo :: Debuggee -> Text -> InfoTablePtr -> IO InfoInfo @@ -594,7 +587,7 @@ handleMain dbg e = do case listSelectedElement cmd_list of Just (_, cmd) -> do modify $ keybindingsMode .~ NoOverlay - dispatchCommand cmd + dispatchCommand cmd dbg Nothing -> return () _ -> do form' <- handle_form @@ -614,62 +607,69 @@ commandPickerMode = (list CommandPicker_List commandList 1) +savedAndGCRoots :: TreeMode +savedAndGCRoots = SavedAndGCRoots renderClosureDetails + -- 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 '?') []) + [ mkCommand "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]) + , mkCommand "Saved/GC Roots" (Vty.EvKey (KChar 's') [Vty.MCtrl]) + (modify $ treeMode .~ savedAndGCRoots) + , mkCommand "Find Closures (Exact)" (Vty.EvKey (KChar 'c') [Vty.MCtrl]) (modify $ footerMode .~ footerInput FSearch) - , Command "Find Address" (Vty.EvKey (KChar 'a') [Vty.MCtrl]) + , mkCommand "Find Address" (Vty.EvKey (KChar 'a') [Vty.MCtrl]) (modify $ footerMode .~ footerInput FAddress) - , Command "Find Info Table" (Vty.EvKey (KChar 'i') [Vty.MCtrl]) + , mkCommand "Find Info Table" (Vty.EvKey (KChar 'i') [Vty.MCtrl]) (modify $ footerMode .~ footerInput FInfoTable) - , Command "Write Profile" (Vty.EvKey (KChar 'w') [Vty.MCtrl]) + , mkCommand "Write Profile" (Vty.EvKey (KChar 'w') [Vty.MCtrl]) (modify $ footerMode .~ footerInput FProfile) - , Command "Find Retainers" (Vty.EvKey (KChar 'f') [Vty.MCtrl]) + , mkCommand "Find Retainers" (Vty.EvKey (KChar 'f') [Vty.MCtrl]) (modify $ footerMode .~ footerInput FRetainer) - , Command "Find Retainers (Exact)" (Vty.EvKey (KChar 'e') [Vty.MCtrl]) + , mkCommand "Find Retainers (Exact)" (Vty.EvKey (KChar 'e') [Vty.MCtrl]) (modify $ footerMode .~ footerInput FRetainerExact) - , Command "Find Retainers of large ARR_WORDS" (Vty.EvKey (KChar 'g') [Vty.MCtrl]) + , mkCommand "Find Retainers of large ARR_WORDS" (Vty.EvKey (KChar 'g') [Vty.MCtrl]) (modify $ footerMode .~ footerInput FRetainerArrWords) - , Command "Dump ARR_WORDS payload" (Vty.EvKey (KChar 'd') [Vty.MCtrl]) + , mkCommand "Dump ARR_WORDS payload" (Vty.EvKey (KChar 'd') [Vty.MCtrl]) (modify $ footerMode .~ footerInput FDumpArrWords) - , Command "Set search limit (default 100)" (Vty.EvKey (KChar 'l') [Vty.MCtrl]) + , mkCommand "Set search limit (default 100)" (Vty.EvKey (KChar 'l') [Vty.MCtrl]) (modify $ footerMode .~ footerInput FSetResultSize) - , Command "Take Snapshot" (Vty.EvKey (KChar 'x') [Vty.MCtrl]) - (modify $ footerMode .~ footerInput FSnapshot) ] + , mkCommand "Take Snapshot" (Vty.EvKey (KChar 'x') [Vty.MCtrl]) + (modify $ footerMode .~ footerInput FSnapshot) + , Command "Find Retainers (Address)" Nothing + (\_ -> modify $ footerMode .~ footerInput FRetainerAddress) + , Command "ARR_WORDS Count" Nothing arrWordsAction + ] 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 handleMainWindowEvent :: Debuggee -> Handler () OperationalState -handleMainWindowEvent _dbg brickEvent = do +handleMainWindowEvent dbg brickEvent = do os@(OperationalState _ treeMode' _kbMode _footerMode _curRoots rootsTree _ _) <- 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 -> 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 () @@ -686,6 +686,38 @@ inputFooterHandler dbg m form _k re@(VtyEvent e) = zoom (lens (const form) (\ os form' -> set footerMode (FooterInput m form') os)) (handleFormEvent re) inputFooterHandler _ _ _ k re = k re + +data ArrWordsLine = CountLine ByteString Int | FieldLine ClosureDetails + +renderArrWordsLines :: ArrWordsLine -> [Widget n] +renderArrWordsLines (CountLine k n) = [txtLabel (T.pack (show n)), txtWrap (T.pack (show k))] +renderArrWordsLines (FieldLine cd) = renderInlineClosureDesc cd + +arrWordsAction :: Debuggee -> EventM n OperationalState () +arrWordsAction dbg = do + os <- get + -- TODO: Does not honour search limit at all + asyncAction "Counting ARR_WORDS" os (arrWordsAnalysis Nothing dbg) $ \res -> do + let sorted_res = take 100 $ Prelude.reverse [(k, S.toList v ) | (k, v) <- (List.sortBy (comparing (S.size . snd)) (M.toList res))] + + top_closure = [CountLine k (length v) | (k, v) <- sorted_res] + + g_children d (CountLine b _) = do + let Just cs = M.lookup b res + cs' <- closureReferences' d (zipWith (\n c -> (show n, Left c)) [0..] (S.toList cs)) + children' <- traverse (traverse (fillListItem d)) cs' + mapM (\(lbl, child) -> FieldLine <$> getClosureDetails d (pack lbl) child) children' + g_children d (FieldLine c) = map FieldLine <$> getChildren d c + + renderHeaderPane (CountLine b k) = txtWrap (T.pack (show b)) + renderHeaderPane (FieldLine c) = renderClosureDetails c + + tree = mkIOTree dbg top_closure g_children renderArrWordsLines id + put (os & resetFooter + & treeMode .~ Searched renderHeaderPane tree + ) + + -- | What happens when we press enter in footer input mode dispatchFooterInput :: Debuggee -> FooterInputMode @@ -695,10 +727,10 @@ dispatchFooterInput dbg FSearch form = do os <- get asyncAction "Searching for closures" os (map head <$> (liftIO $ retainersOfConstructor (_resultSize os) 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 + res <- liftIO $ mapM (completeClosureDetails dbg) cps' + let tree = mkIOTree dbg res getChildren renderInlineClosureDesc id put (os & resetFooter - & treeMode .~ Searched tree + & treeMode .~ Searched renderClosureDetails tree ) dispatchFooterInput dbg FAddress form = do os <- get @@ -707,10 +739,10 @@ dispatchFooterInput dbg FAddress form = do Just cp -> do asyncAction "Finding address" os (map head <$> (liftIO $ retainersOfAddress (_resultSize os) 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 + res <- liftIO $ mapM (completeClosureDetails dbg) cps' + let tree = mkIOTree dbg res getChildren renderInlineClosureDesc id put (os & resetFooter - & treeMode .~ Searched tree + & treeMode .~ Searched renderClosureDetails tree ) Nothing -> put (os & resetFooter) @@ -722,10 +754,10 @@ dispatchFooterInput dbg FInfoTable form = 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 (_resultSize os) 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 + res <- liftIO $ mapM (completeClosureDetails dbg) cps' + let tree = mkIOTree dbg res getChildren renderInlineClosureDesc id put (os & resetFooter - & treeMode .~ Searched tree + & treeMode .~ Searched renderClosureDetails tree ) Nothing -> put (os & resetFooter) @@ -739,36 +771,41 @@ dispatchFooterInput dbg FRetainer form = do go (SP _) = Nothing asyncAction "Finding retainers" os (retainersOfConstructor (_resultSize os) (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' + res <- liftIO $ mapM (mapM (completeClosureDetails dbg)) cps' let tree = mkRetainerTree dbg res put (os & resetFooter - & treeMode .~ Retainer tree) + & treeMode .~ Retainer renderClosureDetails tree) dispatchFooterInput dbg FRetainerExact form = do os <- get asyncAction "Finding exact retainers" os (retainersOfConstructorExact (_resultSize os) 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' + res <- liftIO $ mapM (mapM (completeClosureDetails dbg)) cps' let tree = mkRetainerTree dbg res put (os & resetFooter - & treeMode .~ Retainer tree) + & treeMode .~ Retainer renderClosureDetails tree) dispatchFooterInput dbg FRetainerArrWords form = do os <- get case readMaybe $ T.unpack (formState form) of Nothing -> pure () Just size -> asyncAction "Finding ArrWords retainers" os (retainersOfArrWords (_resultSize os) dbg size) $ \cps -> do let cps' = map (zipWith (\n cp -> (T.pack (show n),cp)) [0 :: Int ..]) cps - res <- liftIO $ mapM (mapM (completeClosureDetails dbg Nothing)) cps' + res <- liftIO $ mapM (mapM (completeClosureDetails dbg)) cps' let tree = mkRetainerTree dbg res put (os & resetFooter - & treeMode .~ Retainer tree) + & treeMode .~ Retainer renderClosureDetails tree) dispatchFooterInput _ FDumpArrWords form = do os <- get - let node = pauseModeTree ioTreeSelection os - asyncAction_ "dumping ARR_WORDS payload" os $ - case node of - Just ClosureDetails{_closure = Closure{_closureSized = Debug.unDCS -> Debug.ArrWordsClosure{..}}} -> - BS.writeFile (T.unpack $ formState form) $ arrWordsBS (take (fromIntegral bytes) arrWords) - _ -> pure () + let act node = asyncAction_ "dumping ARR_WORDS payload" os $ + case node of + Just ClosureDetails{_closure = Closure{_closureSized = Debug.unDCS -> Debug.ArrWordsClosure{..}}} -> + 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 os <- get asyncAction "setting result size" os (pure ()) $ \() -> case readMaybe $ T.unpack (formState form) of @@ -776,6 +813,18 @@ dispatchFooterInput _ FSetResultSize form = do | n <= 0 -> put (os & resultSize .~ Nothing) | otherwise -> put (os & resultSize .~ (Just n)) Nothing -> pure () +dispatchFooterInput dbg FRetainerAddress form = do + os <- get + let address = T.unpack (formState form) + case readClosurePtr address of + Just cp -> do + asyncAction "Finding address retainers" os (retainersOfAddress (view resultSize os) Nothing dbg [cp]) $ \cps -> do + 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) + Nothing -> put (os & resetFooter) dispatchFooterInput dbg FSnapshot form = do os <- get asyncAction_ "Taking snapshot" os $ snapshot dbg (T.unpack (formState form)) @@ -801,18 +850,20 @@ mkRetainerTree :: Debuggee -> [[ClosureDetails]] -> IOTree ClosureDetails Name 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 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') + lookup_c _ _ = return [] - mkIOTree dbg Nothing roots lookup_c id + mkIOTree dbg roots lookup_c renderInlineClosureDesc id resetFooter :: OperationalState -> OperationalState resetFooter l = (set footerMode FooterInfo l) diff --git a/ghc-debug-brick/src/Model.hs b/ghc-debug-brick/src/Model.hs index 8521053e1b65c488fc442579e5b1e74aa34a75c0..f8923f83189b1794fe76dd0b498672e8dae92429 100644 --- a/ghc-debug-brick/src/Model.hs +++ b/ghc-debug-brick/src/Model.hs @@ -5,6 +5,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} module Model ( module Model @@ -22,7 +23,7 @@ import Data.Text(Text, pack) import Brick.Forms import Brick.BChan -import Brick (EventM) +import Brick (EventM, Widget) import Brick.Widgets.List import Namespace @@ -107,21 +108,20 @@ data InfoInfo = InfoInfo data ClosureDetails = ClosureDetails { _closure :: DebugClosure SrtCont PayloadCont ConstrDesc StackCont ClosurePtr - , _retainerSize :: Maybe RetainerSize , _excSize :: Size , _info :: InfoInfo } | InfoDetails { _info :: InfoInfo } | LabelNode { _label :: Text } -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 +treeLength (SavedAndGCRoots {}) = Nothing +treeLength (Retainer _ tree) = Just $ Prelude.length $ getIOTreeRoots tree +treeLength (Searched _ tree) = Just $ Prelude.length $ getIOTreeRoots tree data FooterMode = FooterInfo | FooterMessage Text @@ -141,12 +141,16 @@ data FooterInputMode = FAddress | FRetainerArrWords | FDumpArrWords | FSetResultSize + | FRetainerAddress data Command = Command { commandDescription :: Text - , commandKey :: Vty.Event - , dispatchCommand :: EventM Name OperationalState () + , commandKey :: Maybe Vty.Event + , dispatchCommand :: Debuggee -> EventM Name OperationalState () } +mkCommand :: Text -> Vty.Event -> EventM Name OperationalState () -> Command +mkCommand desc key dispatch = Command desc (Just key) (\_ -> dispatch) + data OverlayMode = KeybindingsShown -- TODO: Abstract the "CommandPicker" into it's own module | CommandPicker (Form Text () Name) (GenericList Name Seq Command) @@ -163,6 +167,7 @@ formatFooterMode FRetainerExact = "closure name: " formatFooterMode FRetainerArrWords = "size (bytes): " formatFooterMode FDumpArrWords = "dump payload to file: " formatFooterMode FSetResultSize = "search result limit (0 for infinity): " +formatFooterMode FRetainerAddress = "address (0x..): " formatFooterMode FSnapshot = "snapshot name: " data ConnectedMode @@ -194,11 +199,11 @@ data OperationalState = OperationalState osSize :: OperationalState -> Int osSize os = fromMaybe (Prelude.length (getIOTreeRoots $ _treeSavedAndGCRoots os)) $ treeLength (_treeMode os) -pauseModeTree :: (IOTree ClosureDetails Name -> r) -> OperationalState -> r +pauseModeTree :: (forall a . (a -> Widget Name) -> IOTree a 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 + SavedAndGCRoots render -> k render roots + Retainer render r -> k render r + Searched render r -> k render r makeLenses ''AppState makeLenses ''MajorState