diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,1 +1,11 @@ # Revision history for ghc-debug-brick + +## 0.2.0.0 -- 2021-12-06 + +* Second release + +## 0.1.0.0 -- 2021-06-14 + +* First release + + 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.1.0.0 +version: 0.2.0.0 synopsis: A simple TUI using ghc-debug description: A simple TUI using ghc-debug -- bug-reports: @@ -28,15 +28,16 @@ , containers , directory , filepath - , ghc-debug-client , microlens-platform , text , vty , time , microlens - , ghc-debug-common - , ghc-debug-convention + , ghc-debug-client == 0.2.0.0 + , ghc-debug-common == 0.2.0.0 + , ghc-debug-convention == 0.2.0.0 , unordered-containers + , exceptions hs-source-dirs: src default-language: Haskell2010 ghc-options: -threaded -Wall diff --git a/src/Common.hs b/src/Common.hs --- a/src/Common.hs +++ b/src/Common.hs @@ -1,5 +1,6 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveFunctor #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Common where import qualified Brick.Types as T diff --git a/src/Lib.hs b/src/Lib.hs --- a/src/Lib.hs +++ b/src/Lib.hs @@ -9,15 +9,19 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Lib ( -- * Running/Connecting to a debuggee Debuggee , debuggeeRun , debuggeeConnect + , snapshotConnect , debuggeeClose , withDebuggeeRun , withDebuggeeConnect , socketDirectory + , snapshotDirectory -- * Pause/Resume , GD.pause @@ -40,6 +44,10 @@ , closureReferences , closurePretty , fillConstrDesc + , InfoTablePtr + , ListItem(..) + , closureInfoPtr + , infoSourceLocation -- * Common initialisation , initialTraversal @@ -56,6 +64,16 @@ , reverseClosureReferences , lookupHeapGraph + -- * Profiling + , profile + + -- * Retainers + , retainersOfConstructor + , retainersOfConstructorExact + + -- * Snapshot + , snapshot + -- * Types , Ptr(..) , toPtr @@ -77,16 +95,20 @@ import Data.Maybe (fromMaybe, mapMaybe) import qualified GHC.Debug.Types as GD import GHC.Debug.Types hiding (Closure, DebugClosure) -import GHC.Debug.Convention (socketDirectory) +import GHC.Debug.Convention (socketDirectory, snapshotDirectory) import GHC.Debug.Client.Monad (request, run, Debuggee) import qualified GHC.Debug.Client.Monad as GD 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.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 data Analysis = Analysis { analysisDominatorRoots :: ![ClosurePtr] @@ -164,6 +186,9 @@ -> IO Debuggee debuggeeConnect socketName = GD.debuggeeConnect socketName +snapshotConnect :: FilePath -> IO Debuggee +snapshotConnect snapshotName = GD.snapshotInit snapshotName + -- | Close the connection to the debuggee. debuggeeClose :: Debuggee -> IO () debuggeeClose = GD.debuggeeClose @@ -188,6 +213,33 @@ closurePtrs closures +profile :: Debuggee -> FilePath -> IO () +profile dbg fp = do + c <- run dbg $ do + roots <- GD.gcRoots + GD.censusClosureType roots + GD.writeCensusByClosureType fp c + +snapshot :: Debuggee -> FilePath -> IO () +snapshot dbg fp = do + dir <- snapshotDirectory + createDirectoryIfMissing True dir + GD.makeSnapshot dbg (dir fp) + +retainersOfConstructor :: Debuggee -> String -> IO [[Closure]] +retainersOfConstructor dbg con_name = do + run dbg $ do + roots <- GD.gcRoots + stack <- GD.findRetainersOfConstructor (Just 100) roots con_name + traverse (\cs -> zipWith Closure cs <$> (GD.dereferenceClosures cs)) stack + +retainersOfConstructorExact :: Debuggee -> String -> IO [[Closure]] +retainersOfConstructorExact dbg con_name = do + run dbg $ do + roots <- GD.gcRoots + stack <- GD.findRetainersOfConstructorExact (Just 100) roots con_name + traverse (\cs -> zipWith Closure cs <$> (GD.dereferenceClosures cs)) stack + -- -- | Request the description for an info table. -- -- The `InfoTablePtr` is just used for the equality -- requestConstrDesc :: Debuggee -> PayloadWithKey InfoTablePtr ClosurePtr -> IO ConstrDesc @@ -203,6 +255,8 @@ type Closure = DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr +data ListItem a b c d = ListData | ListOnlyInfo InfoTablePtr | ListFullClosure (DebugClosure a b c d) + data DebugClosure p cd s c = Closure { _closurePtr :: ClosurePtr @@ -217,8 +271,11 @@ toPtr (Closure cp _) = CP cp toPtr (Stack sc _) = SP sc -data Ptr = CP ClosurePtr | SP StackCont +data Ptr = CP ClosurePtr | SP StackCont deriving (Eq, Ord) +deriving instance Eq StackCont +deriving instance Ord StackCont + dereferencePtr :: Debuggee -> Ptr -> IO (DebugClosure 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) @@ -253,28 +310,42 @@ closureSourceLocation e (Closure _ c) = run e $ do request (RequestSourceInfo (tableId (info (noSize c)))) +closureInfoPtr :: DebugClosure p cd s c -> Maybe InfoTablePtr +closureInfoPtr (Stack {}) = Nothing +closureInfoPtr (Closure _ c) = Just (tableId (info (noSize c))) + +infoSourceLocation :: Debuggee -> InfoTablePtr -> IO (Maybe SourceInformation) +infoSourceLocation e ip = run e $ request (RequestSourceInfo ip) + -- | Get the directly referenced closures (with a label) of a closure. -closureReferences :: Debuggee -> DebugClosure PayloadCont ConstrDesc StackCont ClosurePtr -> IO [(String, Closure)] +closureReferences :: Debuggee -> DebugClosure PayloadCont ConstrDesc StackCont ClosurePtr -> IO [(String, ListItem PayloadCont ConstrDescCont StackCont ClosurePtr)] closureReferences e (Stack _ stack) = run e $ do - let lblAndPtrs = [ ( "Frame " ++ show frameIx ++ " Pointer " ++ show ptrIx - , ptr - ) + 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)))) : + 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) - , (ptrIx , ptr ) <- zip [(0::Int)..] [ptr | GD.SPtr ptr <- GD.values frame] ] - closures <- GD.dereferenceClosures (snd <$> lblAndPtrs) +-- traverse GD.dereferenceClosures (snd <$> lblAndPtrs) + traverse (traverse id) (concat lblAndPtrs) + {- return $ zipWith (\(lbl,ptr) c -> (lbl, Closure ptr c)) lblAndPtrs closures + -} closureReferences e (Closure _ closure) = run e $ do let refPtrs = closureReferencesAndLabels (unDCS closure) forM refPtrs $ \(label, ptr) -> case ptr of Left cPtr -> do refClosure' <- GD.dereferenceClosure cPtr - return (label, Closure cPtr refClosure') + return (label, ListFullClosure $ Closure cPtr refClosure') Right sPtr -> do refStack' <- GD.dereferenceStack sPtr - return (label, Stack sPtr refStack') + return (label, ListFullClosure $ Stack sPtr refStack') reverseClosureReferences :: HG.HeapGraph Size -> HG.ReverseGraph diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -8,14 +8,17 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE TypeFamilies #-} module Main where import Control.Applicative -import Control.Monad (forever, (<=<)) +import Control.Monad (forever) import Control.Monad.IO.Class +import Control.Monad.Catch (bracket) import Control.Concurrent import qualified Data.List as List -import Data.Maybe (fromJust) import Data.Ord (comparing) import qualified Data.Ord as Ord import qualified Data.Sequence as Seq @@ -27,6 +30,7 @@ import System.FilePath import Data.Text (Text, pack) import qualified Data.Text as T +import qualified Data.Map as M import IOTree import TextCursor @@ -46,14 +50,14 @@ | ReverseAnalysisReady ReverseAnalysis | HeapGraphReady (HeapGraph GD.Size) -myAppDraw :: AppState -> [Widget Name] -myAppDraw (AppState majorState') = - [ case majorState' of - Setup knownDebuggees' -> let - nKnownDebuggees = Seq.length $ majorState'^.knownDebuggees.listElementsL +drawSetup :: Text -> Text -> GenericList Name Seq.Seq SocketInfo -> Widget Name +drawSetup herald other_herald vals = + + let nKnownDebuggees = Seq.length $ (vals ^. listElementsL) in mainBorder "ghc-debug" $ vBox - [ txt $ "Select a process to debug (" <> pack (show nKnownDebuggees) <> " found):" + [ txt $ "Select a " <> herald <> " to debug (" <> pack (show nKnownDebuggees) <> " found):" + , txt $ "Select " <> other_herald <> " with " , renderList (\elIsSelected socketPath -> hBox [ txt $ if elIsSelected then "*" else " " @@ -64,29 +68,42 @@ ] ) True - knownDebuggees' + vals ] +mainBorder :: Text -> Widget a -> Widget a +mainBorder title = borderWithLabel (txt title) . padAll 1 + +myAppDraw :: AppState -> [Widget Name] +myAppDraw (AppState majorState') = + [ case majorState' of + + Setup setupKind' dbgs snaps -> + case setupKind' of + Socket -> drawSetup "process" "snapshot" dbgs + Snapshot -> drawSetup "snapshot" "process" snaps + + Connected _socket _debuggee mode' -> case mode' of RunningMode -> mainBorder "ghc-debug - Running" $ vBox [ txt "Pause (p)" ] - (PausedMode os@(OperationalState treeMode' fmode _ro dtree _ reverseTree hg)) -> let + (PausedMode os@(OperationalState treeMode' fmode _ro _dtree _ _reverseTree _hg)) -> let in mainBorder "ghc-debug - Paused" $ vBox [ hBox [ border $ vBox ([ txt "Resume (F12)" + , txt "Tree (F1)" , txt "Parent (<-)" , txt "Child (->)" , txt "Saved/GC Roots (F1)" - ] ++ - [ txt "Dominator Tree (F2)" | Just {} <- [dtree] ] - ++ - [ txt "Reverse Analysis (F3)" | Just {} <- [reverseTree] ] - ++ - [ txt "Search for Constructor (F8)" | Just {} <- [hg] ] ) + , txt "Write Profile (F3)" + , txt "Find Retainers (F4)" + , txt "Find Retainers (Exact) (F6)" + , txt "Take Snapshot (F5)" + ]) , -- Current closure details borderWithLabel (txt "Closure Details") $ pauseModeTree (renderClosureDetails . ioTreeSelection) os ] @@ -96,6 +113,7 @@ Dominator -> "Dominator Tree" SavedAndGCRoots -> "Root Closures" Reverse -> "Reverse Edges" + Retainer {} -> "Retainers" ) (pauseModeTree renderIOTree os) , hBorder @@ -103,26 +121,35 @@ ] ] where - mainBorder title = borderWithLabel (txt title) . padAll 1 renderClosureDetails :: Maybe (ClosureDetails pap s c) -> Widget Name - renderClosureDetails cd = vLimit 9 $ vBox $ + renderClosureDetails (Just cd@(ClosureDetails {})) = + vLimit 9 $ vBox $ + renderInfoInfo (_info cd) + ++ + [ txt $ "Exclusive Size " + <> maybe "" (pack . show @Int . GD.getSize) (Just $ _excSize cd) <> " bytes" + , txt $ "Retained Size " + <> maybe "" (pack . show @Int . GD.getRetainerSize) (_retainerSize cd) <> " bytes" + , fill ' ' + ] + renderClosureDetails Nothing = emptyWidget + renderClosureDetails (Just (LabelNode n)) = txt n + renderClosureDetails (Just (InfoDetails info')) = vLimit 9 $ vBox $ renderInfoInfo info' + + renderInfoInfo info' = [ txt "SourceLocation " - <+> txt (maybe "" renderSourceInformation (_sourceLocation =<< cd)) + <+> txt (maybe "" renderSourceInformation (_sourceLocation info')) -- TODO these aren't actually implemented yet -- , txt $ "Type " -- <> fromMaybe "" (_closureType =<< cd) -- , txt $ "Constructor " -- <> fromMaybe "" (_constructor =<< cd) - , txt $ "Exclusive Size " - <> maybe "" (pack . show @Int . GD.getSize) (_excSize <$> cd) <> " bytes" - , txt $ "Retained Size " - <> maybe "" (pack . show @Int . GD.getRetainerSize) (_retainerSize =<< cd) <> " bytes" - , fill ' ' ] + renderSourceInformation :: SourceInformation -> T.Text - renderSourceInformation (SourceInformation name cty ty label modu loc) = - T.pack $ unlines [name, show cty, ty, label, modu, loc] + renderSourceInformation (SourceInformation name cty ty label' modu loc) = + T.pack $ unlines [name, show cty, ty, label', modu, loc] footer :: FooterMode -> Widget Name footer m = vLimit 1 $ @@ -131,35 +158,12 @@ FooterInfo -> txt "" FooterInput im t -> txt (formatFooterMode im) <+> drawTextCursor t - -myAppHandleEvent :: BChan Event -> AppState -> BrickEvent Name Event -> EventM Name (Next AppState) -myAppHandleEvent eventChan appState@(AppState majorState') brickEvent = case brickEvent of - VtyEvent (Vty.EvKey KEsc []) -> halt appState - _ -> case majorState' of - Setup knownDebuggees' -> case brickEvent of - - VtyEvent event -> case event of - -- Connect to the selected debuggee - Vty.EvKey KEnter _ - | Just (_debuggeeIx, socket) <- listSelectedElement knownDebuggees' - -> do - debuggee' <- liftIO $ debuggeeConnect (view socketLocation socket) - continue $ appState & majorState .~ Connected - { _debuggeeSocket = socket - , _debuggee = debuggee' - , _mode = RunningMode -- TODO should we query the debuggee for this? - } - - -- Navigate through the list. - _ -> do - newOptions <- handleListEventVi handleListEvent event knownDebuggees' - continue $ appState & majorState . knownDebuggees .~ newOptions - - AppEvent event -> case event of - PollTick -> do - -- Poll for debuggees - knownDebuggees'' <- liftIO $ do - dir :: FilePath <- socketDirectory +updateListFrom :: MonadIO m => + IO FilePath + -> GenericList n Seq.Seq SocketInfo + -> m (GenericList n Seq.Seq SocketInfo) +updateListFrom dirIO llist = liftIO $ do + dir :: FilePath <- dirIO debuggeeSocketFiles :: [FilePath] <- listDirectory dir <|> return [] -- Sort the sockets by the time they have been created, newest @@ -168,7 +172,7 @@ <$> mapM (mkSocketInfo . (dir )) debuggeeSocketFiles let currentSelectedPathMay :: Maybe SocketInfo - currentSelectedPathMay = fmap snd (listSelectedElement knownDebuggees') + currentSelectedPathMay = fmap snd (listSelectedElement llist) newSelection :: Maybe Int newSelection = do @@ -178,9 +182,61 @@ return $ listReplace (Seq.fromList debuggeeSockets) (newSelection <|> (if Prelude.null debuggeeSockets then Nothing else Just 0)) - knownDebuggees' + llist + +myAppHandleEvent :: BChan Event -> AppState -> BrickEvent Name Event -> EventM Name (Next AppState) +myAppHandleEvent eventChan appState@(AppState majorState') brickEvent = case brickEvent of + _ -> case majorState' of + Setup st knownDebuggees' knownSnapshots' -> case brickEvent of + + VtyEvent (Vty.EvKey KEsc []) -> halt appState + VtyEvent event -> case event of + -- Connect to the selected debuggee + Vty.EvKey (KChar '\t') [] -> do + continue $ appState & majorState . setupKind %~ toggleSetup + Vty.EvKey KEnter _ -> + case st of + Snapshot + | Just (_debuggeeIx, socket) <- listSelectedElement knownSnapshots' + -> do + debuggee' <- liftIO $ snapshotConnect (view socketLocation socket) + continue $ appState & majorState .~ Connected + { _debuggeeSocket = socket + , _debuggee = debuggee' + , _mode = RunningMode -- TODO should we query the debuggee for this? + } + Socket + | Just (_debuggeeIx, socket) <- listSelectedElement knownDebuggees' + -> do + bracket + (liftIO $ debuggeeConnect (view socketLocation socket)) + (\debuggee' -> liftIO $ resume debuggee') + (\debuggee' -> + continue $ appState & majorState .~ Connected + { _debuggeeSocket = socket + , _debuggee = debuggee' + , _mode = RunningMode -- TODO should we query the debuggee for this? + }) + _ -> continue appState + + -- Navigate through the list. + _ -> do + case st of + Snapshot -> do + newOptions <- handleListEventVi handleListEvent event knownSnapshots' + continue $ appState & majorState . knownSnapshots .~ newOptions + Socket -> do + newOptions <- handleListEventVi handleListEvent event knownDebuggees' + continue $ appState & majorState . knownDebuggees .~ newOptions + + AppEvent event -> case event of + PollTick -> do + -- Poll for debuggees + knownDebuggees'' <- updateListFrom socketDirectory knownDebuggees' + knownSnapshots'' <- updateListFrom snapshotDirectory knownSnapshots' continue $ appState & majorState . knownDebuggees .~ knownDebuggees'' + & majorState . knownSnapshots .~ knownSnapshots'' DominatorTreeReady {} -> continue appState ReverseAnalysisReady {} -> continue appState HeapGraphReady {} -> continue appState @@ -190,6 +246,8 @@ RunningMode -> case brickEvent of -- Pause the debuggee + VtyEvent (Vty.EvKey KEsc []) -> + halt appState VtyEvent (Vty.EvKey (KChar 'p') []) -> do liftIO $ pause debuggee' -- _ <- liftIO $ initialiseViews @@ -227,6 +285,10 @@ liftIO $ resume debuggee' continue (appState & majorState . mode .~ RunningMode) + VtyEvent (Vty.EvKey KEsc []) -> do + liftIO $ resume debuggee' + continue $ initialAppState + _ -> liftHandler (majorState . mode) os PausedMode (handleMain debuggee') appState (() <$ brickEvent) @@ -234,15 +296,16 @@ where - initialiseViews = forkIO $ do + _initialiseViews = forkIO $ do !hg <- initialTraversal debuggee' writeBChan eventChan (HeapGraphReady hg) - _ <- mkDominatorTreeIO hg - _ <- mkReversalTreeIO hg +-- _ <- mkDominatorTreeIO hg +-- _ <- mkReversalTreeIO hg return () -- This is really slow on big heaps, needs to be made more efficient -- or some progress/timeout indicator + {- mkDominatorTreeIO hg = forkIO $ do !analysis <- runAnalysis debuggee' hg !rootClosures' <- liftIO $ mapM (getClosureDetails debuggee' (Just analysis) "" <=< fillConstrDesc debuggee') =<< GD.dominatorRootClosures debuggee' analysis @@ -255,12 +318,13 @@ getChildren analysis _dbg c = do cs <- closureDominatees debuggee' analysis c fmap (("",)) <$> mapM (fillConstrDesc debuggee') cs + -} - mkReversalTreeIO hg = forkIO $ do - let !revg = mkReverseGraph hg - let revIoTree = mkIOTree Nothing [] (reverseClosureReferences hg revg) id - writeBChan eventChan (ReverseAnalysisReady (ReverseAnalysis revIoTree (lookupHeapGraph hg))) +-- mkReversalTreeIO hg = forkIO $ do +-- let !revg = mkReverseGraph hg +-- let revIoTree = mkIOTree Nothing [] (reverseClosureReferences hg revg) id +-- writeBChan eventChan (ReverseAnalysisReady (ReverseAnalysis revIoTree (lookupHeapGraph hg))) mkSavedAndGCRootsIOTree manalysis = do @@ -268,68 +332,114 @@ rootClosures' <- liftIO $ mapM (completeClosureDetails debuggee' manalysis) raw_roots raw_saved <- map ("Saved Object",) <$> GD.savedClosures debuggee' savedClosures' <- liftIO $ mapM (completeClosureDetails debuggee' manalysis) raw_saved - return $ (mkIOTree manalysis (savedClosures' ++ rootClosures') getChildren id + return $ (mkIOTree debuggee' manalysis (savedClosures' ++ rootClosures') getChildren id , fmap toPtr <$> (raw_roots ++ raw_saved)) where + getChildren :: Debuggee -> DebugClosure PayloadCont ConstrDesc StackCont ClosurePtr + -> IO + [(String, ListItem PayloadCont ConstrDesc StackCont ClosurePtr)] getChildren d c = do children <- closureReferences d c - mapM (mapM (fillConstrDesc d)) children + traverse (traverse (fillListItem d)) children + fillListItem :: Debuggee + -> ListItem PayloadCont ConstrDescCont StackCont ClosurePtr + -> IO (ListItem PayloadCont ConstrDesc StackCont ClosurePtr) + fillListItem _ (ListOnlyInfo x) = return $ ListOnlyInfo x + fillListItem d(ListFullClosure cd) = ListFullClosure <$> fillConstrDesc d cd + fillListItem _ ListData = return ListData - mkIOTree :: Show c => Maybe Analysis -> [ClosureDetails pap s c] -> (Debuggee -> DebugClosure pap ConstrDesc s c -> IO [(String, DebugClosure pap ConstrDesc s c)]) -> ([ClosureDetails pap s c] -> [ClosureDetails pap s c]) -> IOTree (ClosureDetails pap s c) Name - mkIOTree manalysis cs getChildren sort = ioTree Connected_Paused_ClosureTree + +mkIOTree :: Show c => Debuggee + -> Maybe Analysis + -> [ClosureDetails pap s c] + -> (Debuggee -> DebugClosure pap ConstrDesc s c -> IO [(String, ListItem pap ConstrDesc s c)]) + -> ([ClosureDetails pap s c] -> [ClosureDetails pap s c]) + -> IOTree (ClosureDetails pap s c) Name +mkIOTree debuggee' manalysis cs getChildren sort = ioTree Connected_Paused_ClosureTree (sort cs) (\c -> do - children <- getChildren debuggee' (_closure c) - cDets <- mapM (\(lbl, child) -> getClosureDetails debuggee' manalysis (pack lbl) child) children - return (sort cDets) + 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) ) (\selected depth closureDesc -> hBox [ txt (T.replicate depth " ") , (if selected then visible . txt else txt) $ (if selected then "* " else " ") - <> _labelInParent closureDesc - <> " " - <> pack (closureShowAddress (_closure closureDesc)) - <> " " - <> _pretty closureDesc + <> renderInlineClosureDesc closureDesc ] ) (\depth _closureDesc children -> if List.null children then txt $ T.replicate (depth + 2) " " <> "" - else emptyWidget - ) + else emptyWidget) + +renderInlineClosureDesc :: ClosureDetails pap s c -> Text +renderInlineClosureDesc (LabelNode t) = t +renderInlineClosureDesc (InfoDetails info') = + _labelInParent info' <> " " <> _pretty info' +renderInlineClosureDesc closureDesc = + _labelInParent (_info closureDesc) + <> " " + <> pack (closureShowAddress (_closure closureDesc)) + <> " " + <> _pretty (_info closureDesc) completeClosureDetails :: Show c => Debuggee -> Maybe Analysis -> (Text, DebugClosure pap ConstrDescCont s c) -> IO (ClosureDetails pap s c) -completeClosureDetails dbg manalysis (label, clos) = - getClosureDetails dbg manalysis label =<< fillConstrDesc dbg clos +completeClosureDetails dbg manalysis (label', clos) = + getClosureDetails dbg manalysis label' . ListFullClosure =<< fillConstrDesc dbg clos getClosureDetails :: Show c => Debuggee -> Maybe Analysis -> Text - -> DebugClosure pap ConstrDesc s c + -> ListItem pap ConstrDesc s c -> IO (ClosureDetails pap s c) -getClosureDetails debuggee' manalysis label c = 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 let excSize' = closureExclusiveSize c retSize' = closureRetainerSize <$> manalysis <*> pure c - sourceLoc <- closureSourceLocation debuggee' c + sourceLoc <- maybe (return Nothing) (infoSourceLocation debuggee') (closureInfoPtr c) let pretty' = closurePretty c return ClosureDetails { _closure = c - , _pretty = pack pretty' - , _labelInParent = label - , _sourceLocation = sourceLoc - , _closureType = Nothing - , _constructor = Nothing + , _info = InfoInfo { + _pretty = pack pretty' + , _labelInParent = label' + , _sourceLocation = sourceLoc + , _closureType = Nothing + , _constructor = Nothing + } , _excSize = excSize' , _retainerSize = retSize' } +getInfoInfo :: Debuggee -> Text -> InfoTablePtr -> IO InfoInfo +getInfoInfo debuggee' label' infoPtr = do + sourceLoc <- infoSourceLocation debuggee' infoPtr + let pretty' = case sourceLoc of + Just loc -> pack (infoPosition loc) + Nothing -> "" + return $ InfoInfo { + _pretty = pretty' + , _labelInParent = label' + , _sourceLocation = sourceLoc + , _closureType = Nothing + , _constructor = Nothing + } + + -- Event handling when the main window has focus handleMain :: Debuggee -> Handler OperationalState @@ -349,7 +459,7 @@ VtyEvent (Vty.EvKey (KFun 2) _) -- Only switch if the dominator view is ready | Just {} <- domTree -> continue $ os & treeMode .~ Dominator - VtyEvent (Vty.EvKey (KFun 3) _) +{- VtyEvent (Vty.EvKey (KFun 3) _) -- Only switch if the reverse view is ready | Just ra <- reverseA -> do -- Get roots from rootTree and use those for the reverse view @@ -359,9 +469,22 @@ rs' = map convert rs continue $ os & treeMode .~ Reverse & treeReverse . _Just . reverseIOTree %~ setIOTreeRoots rs' - VtyEvent (Vty.EvKey (KFun 8) _) -> - continue $ os & footerMode .~ (FooterInput FSearch emptyTextCursor) + -} +-- VtyEvent (Vty.EvKey (KFun 8) _) -> +-- continue $ os & footerMode .~ (FooterInput FSearch emptyTextCursor) + VtyEvent (Vty.EvKey (KFun 3) _) -> + continue $ os & footerMode .~ (FooterInput FProfile emptyTextCursor) + + VtyEvent (Vty.EvKey (KFun 4) _) -> + continue $ os & footerMode .~ (FooterInput FRetainer emptyTextCursor) + + VtyEvent (Vty.EvKey (KFun 6) _) -> + continue $ os & footerMode .~ (FooterInput FRetainerExact emptyTextCursor) + + VtyEvent (Vty.EvKey (KFun 5) _) -> + continue $ os & footerMode .~ (FooterInput FSnapshot emptyTextCursor) + -- Navigate the tree of closures VtyEvent event -> case treeMode' of Dominator -> do @@ -373,6 +496,11 @@ Reverse -> do newTree <- traverseOf (_Just . reverseIOTree) (handleIOTreeEvent event) reverseA continue (os & treeReverse .~ newTree) + + Retainer t -> do + newTree <- handleIOTreeEvent event t + continue (os & treeMode .~ Retainer newTree) + _ -> continue os inputFooterHandler :: Debuggee @@ -412,6 +540,39 @@ & treeSavedAndGCRoots %~ setIOTreeRoots root_details) -- Should never happen Nothing -> continue os +dispatchFooterInput dbg FProfile tc os = do + liftIO $ profile dbg (T.unpack (rebuildTextCursor tc)) + continue (os & resetFooter) +dispatchFooterInput dbg FRetainer tc os = do + cps <- liftIO $ retainersOfConstructor dbg (T.unpack (rebuildTextCursor tc)) + 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 + continue (os & resetFooter + & treeMode .~ Retainer tree) +dispatchFooterInput dbg FRetainerExact tc os = do + cps <- liftIO $ retainersOfConstructorExact dbg (T.unpack (rebuildTextCursor tc)) + 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 + continue (os & resetFooter + & treeMode .~ Retainer tree) +dispatchFooterInput dbg FSnapshot tc os = do + liftIO $ snapshot dbg (T.unpack (rebuildTextCursor tc)) + continue (os & resetFooter) + +mkRetainerTree :: Debuggee -> [[ClosureDetails PayloadCont StackCont ClosurePtr]] -> IOTree (ClosureDetails PayloadCont StackCont ClosurePtr) 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.fromList [(toPtr (_closure k), zipWith (\n cp -> ((show n), ListFullClosure (_closure cp))) [0 :: Int ..] v) | (k, v) <- stack_map] + + lookup_c _dbg dc = let ptr = toPtr dc + in case M.lookup ptr info_map of + Nothing -> return [] + Just ss -> return ss + + mkIOTree dbg Nothing roots lookup_c id resetFooter :: OperationalState -> OperationalState resetFooter l = (set footerMode FooterInfo l) diff --git a/src/Model.hs b/src/Model.hs --- a/src/Model.hs +++ b/src/Model.hs @@ -31,7 +31,9 @@ initialAppState :: AppState initialAppState = AppState { _majorState = Setup - { _knownDebuggees = list Setup_KnownDebuggeesList [] 1 + { _setupKind = Socket + , _knownDebuggees = list Setup_KnownDebuggeesList [] 1 + , _knownSnapshots = list Setup_KnownSnapshotsList [] 1 } } @@ -58,10 +60,20 @@ -- Compare time first compare t1 t2 <> compare s1 s2 +type SnapshotInfo = SocketInfo + +data SetupKind = Socket | Snapshot + +toggleSetup :: SetupKind -> SetupKind +toggleSetup Socket = Snapshot +toggleSetup Snapshot = Socket + data MajorState -- | We have not yet connected to a debuggee. = Setup - { _knownDebuggees :: GenericList Name Seq SocketInfo + { _setupKind :: SetupKind + , _knownDebuggees :: GenericList Name Seq SocketInfo + , _knownSnapshots :: GenericList Name Seq SnapshotInfo } -- | Connected to a debuggee @@ -71,28 +83,38 @@ , _mode :: ConnectedMode } -data ClosureDetails pap s c = ClosureDetails - { _closure :: DebugClosure pap ConstrDesc s c - , _labelInParent :: Text -- ^ A label describing the relationship to the parent +data InfoInfo = InfoInfo + { + _labelInParent :: Text -- ^ A label describing the relationship to the parent -- Stuff that requires IO to calculate , _pretty :: Text , _sourceLocation :: Maybe SourceInformation , _closureType :: Maybe Text - , _constructor :: Maybe Text - , _excSize :: Size + , _constructor :: Maybe Text } + +data ClosureDetails pap s c = ClosureDetails + { _closure :: DebugClosure pap ConstrDesc s c , _retainerSize :: Maybe RetainerSize + , _excSize :: Size + , _info :: InfoInfo } + | InfoDetails { _info :: InfoInfo } + | LabelNode { _label :: Text } -data TreeMode = Dominator | SavedAndGCRoots | Reverse +data TreeMode = Dominator | SavedAndGCRoots | Reverse | Retainer (IOTree (ClosureDetails PayloadCont StackCont ClosurePtr) Name) data FooterMode = FooterInfo | FooterMessage Text | FooterInput FooterInputMode TextCursor -data FooterInputMode = FSearch +data FooterInputMode = FSearch | FProfile | FRetainer | FRetainerExact | FSnapshot formatFooterMode :: FooterInputMode -> Text formatFooterMode FSearch = "search: " +formatFooterMode FProfile = "filename: " +formatFooterMode FRetainer = "constructor name: " +formatFooterMode FRetainerExact = "closure name: " +formatFooterMode FSnapshot = "snapshot name: " data ConnectedMode -- | Debuggee is running @@ -135,6 +157,7 @@ Dominator -> k $ maybe (error "DOMINATOR-DavidE is not ready") _getDominatorTree dom SavedAndGCRoots -> k roots Reverse -> k $ maybe (error "bop it, flip, reverse it, DavidE") _reverseIOTree reverseA + Retainer r -> k r makeLenses ''AppState makeLenses ''MajorState diff --git a/src/Namespace.hs b/src/Namespace.hs --- a/src/Namespace.hs +++ b/src/Namespace.hs @@ -9,6 +9,7 @@ data Name = Setup_KnownDebuggeesList + | Setup_KnownSnapshotsList | Connected_Paused_ClosureTree | Footer deriving (Eq, Ord, Show) diff --git a/src/TextCursor.hs b/src/TextCursor.hs --- a/src/TextCursor.hs +++ b/src/TextCursor.hs @@ -8,7 +8,6 @@ import Brick hiding (continue, halt) import qualified Graphics.Vty as V -import Brick.Types ( Widget ) import Namespace