From c8c44fd91b509b9eb644c826497ed5268e89363a Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Sat, 31 Oct 2015 17:38:34 +0000 Subject: Maintain cost-centre stacks in the interpreter Summary: Breakpoints become SCCs, so we have detailed call-stack info for interpreted code. Currently this only works when GHC is compiled with -prof, but D1562 (Remote GHCi) removes this constraint so that in the future call stacks will be available without building your own GHCi. How can you get a stack trace? * programmatically: GHC.Stack.currentCallStack * I've added an experimental :where command that shows the stack when stopped at a breakpoint * `error` attaches a call stack automatically, although since calls to `error` are often lifted out to the top level, this is less useful than it might be (ImplicitParams still works though). * Later we might attach call stacks to all exceptions Other related changes in this diff: * I reduced the number of places that get ticks attached for breakpoints. In particular there was a breakpoint around the whole declaration, which was often redundant because it bound no variables. This reduces clutter in the stack traces and speeds up compilation. * I tidied up some RealSrcSpan stuff in InteractiveUI, and made a few other small cleanups Test Plan: validate Reviewers: ezyang, bgamari, austin, hvr Subscribers: thomie Differential Revision: https://phabricator.haskell.org/D1595 GHC Trac Issues: #11047 --- ghc/GhciMonad.hs | 2 +- ghc/InteractiveUI.hs | 166 ++++++++++++++++++++++++++++++++------------------- 2 files changed, 104 insertions(+), 64 deletions(-) (limited to 'ghc') diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index 0b22d1e29d..993a758d3e 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -118,7 +118,7 @@ data GHCiState = GHCiState noBuffering :: ForeignHValue } -type TickArray = Array Int [(BreakIndex,SrcSpan)] +type TickArray = Array Int [(BreakIndex,RealSrcSpan)] -- | A GHCi command data Command diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 1742253332..9e2256010b 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -58,6 +58,7 @@ import PrelNames import RdrName ( RdrName, getGRE_NameQualifier_maybes, getRdrName ) import SrcLoc import qualified Lexer +import ByteCodeTypes (BreakInfo(..)) import StringBuffer import Outputable hiding ( printForUser, printForUserPartWay, bold ) @@ -97,6 +98,7 @@ import qualified Data.Map as M import Exception hiding (catch) import Foreign +import GHC.Stack hiding (SrcLoc(..)) import System.Directory import System.Environment @@ -197,7 +199,8 @@ ghciCommands = map mkCmd [ ("type", keepGoing' typeOfExpr, completeExpression), ("trace", keepGoing traceCmd, completeExpression), ("undef", keepGoing undefineMacro, completeMacro), - ("unset", keepGoing unsetOptions, completeSetOptions) + ("unset", keepGoing unsetOptions, completeSetOptions), + ("where", keepGoing whereCmd, noCompletion) ] ++ map mkCmdHidden [ -- hidden commands ("all-types", keepGoing' allTypesCmd), ("complete", keepGoing completeCmd), @@ -1017,8 +1020,7 @@ toBreakIdAndLocation (Just inf) = do printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi () printStoppedAtBreakInfo res names = do - printForUser $ ptext (sLit "Stopped at") <+> - ppr (GHC.resumeSpan res) + printForUser $ pprStopped res -- printTypeOfNames session names let namesSorted = sortBy compareNames names tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted @@ -1118,6 +1120,15 @@ getCurrentBreakSpan = do pan <- GHC.getHistorySpan hist return (Just pan) +getCallStackAtCurrentBreakpoint :: GHCi (Maybe [String]) +getCallStackAtCurrentBreakpoint = do + resumes <- GHC.getResumeContext + case resumes of + [] -> return Nothing + (r:_) -> do + hsc_env <- GHC.getSession + Just <$> liftIO (costCentreStackInfo hsc_env (GHC.resumeCCS r)) + getCurrentBreakModule :: GHCi (Maybe Module) getCurrentBreakModule = do resumes <- GHC.getResumeContext @@ -2623,7 +2634,18 @@ showContext = do where pp_resume res = ptext (sLit "--> ") <> text (GHC.resumeStmt res) - $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan res)) + $$ nest 2 (pprStopped res) + +pprStopped :: GHC.Resume -> SDoc +pprStopped res = + ptext (sLit "Stopped in") + <+> ((case mb_mod_name of + Nothing -> empty + Just mod_name -> text (moduleNameString mod_name) <> char '.') + <> text (GHC.resumeDecl res)) + <> char ',' <+> ppr (GHC.resumeSpan res) + where + mb_mod_name = moduleName <$> breakInfo_module <$> GHC.resumeBreakInfo res showPackages :: GHCi () showPackages = do @@ -2875,7 +2897,7 @@ stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg Just loc -> do Just md <- getCurrentBreakModule current_toplevel_decl <- enclosingTickSpan md loc - doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep + doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep stepModuleCmd :: String -> GHCi () stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg @@ -2891,17 +2913,22 @@ stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg doContinue f GHC.SingleStep -- | Returns the span of the largest tick containing the srcspan given -enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan +enclosingTickSpan :: Module -> SrcSpan -> GHCi RealSrcSpan enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan" enclosingTickSpan md (RealSrcSpan src) = do ticks <- getTickArray md let line = srcSpanStartLine src ASSERT(inRange (bounds ticks) line) do - let toRealSrcSpan (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan" - toRealSrcSpan (RealSrcSpan s) = s - enclosing_spans = [ pan | (_,pan) <- ticks ! line - , realSrcSpanEnd (toRealSrcSpan pan) >= realSrcSpanEnd src] - return . head . sortBy leftmost_largest $ enclosing_spans + let enclosing_spans = [ pan | (_,pan) <- ticks ! line + , realSrcSpanEnd pan >= realSrcSpanEnd src] + return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans + where + +leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering +leftmostLargestRealSrcSpan a b = + (realSrcSpanStart a `compare` realSrcSpanStart b) + `thenCmp` + (realSrcSpanEnd b `compare` realSrcSpanEnd a) traceCmd :: String -> GHCi () traceCmd arg @@ -2980,7 +3007,7 @@ backCmd arg | otherwise = liftIO $ putStrLn "Syntax: :back [num]" where back num = withSandboxOnly ":back" $ do - (names, _, pan) <- GHC.back num + (names, _, pan, _) <- GHC.back num printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan printTypeOfNames names -- run the command set with ":set stop " @@ -2994,7 +3021,7 @@ forwardCmd arg | otherwise = liftIO $ putStrLn "Syntax: :back [num]" where forward num = withSandboxOnly ":forward" $ do - (names, ix, pan) <- GHC.forward num + (names, ix, pan, _) <- GHC.forward num printForUser $ (if (ix == 0) then ptext (sLit "Stopped at") else ptext (sLit "Logged breakpoint at")) <+> ppr pan @@ -3024,16 +3051,13 @@ breakSwitch (arg1:rest) liftIO $ putStrLn "No modules are loaded with debugging support." | otherwise = do -- try parsing it as an identifier wantNameFromInterpretedModule noCanDo arg1 $ \name -> do - let loc = GHC.srcSpanStart (GHC.nameSrcSpan name) - case loc of - RealSrcLoc l -> + maybe_info <- GHC.getModuleInfo (GHC.nameModule name) + case maybe_info of + Nothing -> noCanDo name (ptext (sLit "cannot get module info")) + Just minf -> ASSERT( isExternalName name ) findBreakAndSet (GHC.nameModule name) $ - findBreakByCoord (Just (GHC.srcLocFile l)) - (GHC.srcLocLine l, - GHC.srcLocCol l) - UnhelpfulLoc _ -> - noCanDo name $ text "can't find its location: " <> ppr loc + findBreakForBind name (GHC.modInfoModBreaks minf) where noCanDo n why = printForUser $ text "cannot set breakpoint on " <> ppr n <> text ": " <> why @@ -3047,29 +3071,30 @@ breakByModule _ _ breakByModuleLine :: Module -> Int -> [String] -> GHCi () breakByModuleLine md line args - | [] <- args = findBreakAndSet md $ findBreakByLine line + | [] <- args = findBreakAndSet md $ maybeToList . findBreakByLine line | [col] <- args, all isDigit col = - findBreakAndSet md $ findBreakByCoord Nothing (line, read col) + findBreakAndSet md $ maybeToList . findBreakByCoord Nothing (line, read col) | otherwise = breakSyntax breakSyntax :: a breakSyntax = throwGhcException (CmdLineError "Syntax: :break [] []") -findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi () +findBreakAndSet :: Module -> (TickArray -> [(Int, RealSrcSpan)]) -> GHCi () findBreakAndSet md lookupTickTree = do - dflags <- getDynFlags tickArray <- getTickArray md (breakArray, _) <- getModBreak md case lookupTickTree tickArray of - Nothing -> liftIO $ putStrLn $ "No breakpoints found at that location." - Just (tick, pan) -> do - success <- liftIO $ setBreakFlag dflags True breakArray tick + [] -> liftIO $ putStrLn $ "No breakpoints found at that location." + some -> mapM_ (breakAt breakArray) some + where + breakAt breakArray (tick, pan) = do + success <- liftIO $ setBreakFlag True breakArray tick if success then do (alreadySet, nm) <- recordBreak $ BreakLocation { breakModule = md - , breakLoc = pan + , breakLoc = RealSrcSpan pan , breakTick = tick , onBreakCmd = "" } @@ -3088,49 +3113,61 @@ findBreakAndSet md lookupTickTree = do -- - the leftmost subexpression starting on the specified line, or -- - the rightmost subexpression enclosing the specified line -- -findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan) +findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,RealSrcSpan) findBreakByLine line arr | not (inRange (bounds arr) line) = Nothing | otherwise = - listToMaybe (sortBy (leftmost_largest `on` snd) comp) `mplus` - listToMaybe (sortBy (leftmost_smallest `on` snd) incomp) `mplus` - listToMaybe (sortBy (rightmost `on` snd) ticks) + listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd) comp) `mplus` + listToMaybe (sortBy (compare `on` snd) incomp) `mplus` + listToMaybe (sortBy (flip compare `on` snd) ticks) where ticks = arr ! line - starts_here = [ tick | tick@(_,pan) <- ticks, - GHC.srcSpanStartLine (toRealSpan pan) == line ] + starts_here = [ (ix,pan) | (ix, pan) <- ticks, + GHC.srcSpanStartLine pan == line ] (comp, incomp) = partition ends_here starts_here - where ends_here (_,pan) = GHC.srcSpanEndLine (toRealSpan pan) == line - toRealSpan (RealSrcSpan pan) = pan - toRealSpan (UnhelpfulSpan _) = panic "findBreakByLine UnhelpfulSpan" + where ends_here (_,pan) = GHC.srcSpanEndLine pan == line + +-- The aim is to find the breakpionts for all the RHSs of the +-- equations corresponding to a binding. So we find all breakpoints +-- for +-- (a) this binder only (not a nested declaration) +-- (b) that do not have an enclosing breakpoint +findBreakForBind :: Name -> GHC.ModBreaks -> TickArray + -> [(BreakIndex,RealSrcSpan)] +findBreakForBind name modbreaks _ = filter (not . enclosed) ticks + where + ticks = [ (index, span) + | (index, [n]) <- assocs (GHC.modBreaks_decls modbreaks), + n == occNameString (nameOccName name), + RealSrcSpan span <- [GHC.modBreaks_locs modbreaks ! index] ] + enclosed (_,sp0) = any subspan ticks + where subspan (_,sp) = sp /= sp0 && + realSrcSpanStart sp <= realSrcSpanStart sp0 && + realSrcSpanEnd sp0 <= realSrcSpanEnd sp findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray - -> Maybe (BreakIndex,SrcSpan) + -> Maybe (BreakIndex,RealSrcSpan) findBreakByCoord mb_file (line, col) arr | not (inRange (bounds arr) line) = Nothing | otherwise = - listToMaybe (sortBy (rightmost `on` snd) contains ++ - sortBy (leftmost_smallest `on` snd) after_here) + listToMaybe (sortBy (flip compare `on` snd) contains ++ + sortBy (compare `on` snd) after_here) where ticks = arr ! line -- the ticks that span this coordinate - contains = [ tick | tick@(_,pan) <- ticks, pan `spans` (line,col), + contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan `spans` (line,col), is_correct_file pan ] is_correct_file pan - | Just f <- mb_file = GHC.srcSpanFile (toRealSpan pan) == f + | Just f <- mb_file = GHC.srcSpanFile pan == f | otherwise = True after_here = [ tick | tick@(_,pan) <- ticks, - let pan' = toRealSpan pan, - GHC.srcSpanStartLine pan' == line, - GHC.srcSpanStartCol pan' >= col ] - - toRealSpan (RealSrcSpan pan) = pan - toRealSpan (UnhelpfulSpan _) = panic "findBreakByCoord UnhelpfulSpan" + GHC.srcSpanStartLine pan == line, + GHC.srcSpanStartCol pan >= col ] -- For now, use ANSI bold on terminals that we know support it. -- Otherwise, we add a line of carets under the active expression instead. @@ -3147,6 +3184,15 @@ start_bold = "\ESC[1m" end_bold :: String end_bold = "\ESC[0m" +----------------------------------------------------------------------------- +-- :where + +whereCmd :: String -> GHCi () +whereCmd = noArgs $ do + mstrs <- getCallStackAtCurrentBreakpoint + case mstrs of + Nothing -> return () + Just strs -> liftIO $ putStrLn (renderStack strs) ----------------------------------------------------------------------------- -- :list @@ -3199,8 +3245,7 @@ list2 [arg] = do tickArray case mb_span of Nothing -> listAround (realSrcLocSpan l) False - Just (_, UnhelpfulSpan _) -> panic "list2 UnhelpfulSpan" - Just (_, RealSrcSpan pan) -> listAround pan False + Just (_, pan) -> listAround pan False UnhelpfulLoc _ -> noCanDo name $ text "can't find its location: " <> ppr loc @@ -3315,14 +3360,10 @@ discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv}) mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray mkTickArray ticks = accumArray (flip (:)) [] (1, max_line) - [ (line, (nm,pan)) | (nm,pan) <- ticks, - let pan' = toRealSpan pan, - line <- srcSpanLines pan' ] + [ (line, (nm,pan)) | (nm,RealSrcSpan pan) <- ticks, line <- srcSpanLines pan ] where - max_line = foldr max 0 (map (GHC.srcSpanEndLine . toRealSpan . snd) ticks) + max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp) <- ticks ] srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ] - toRealSpan (RealSrcSpan pan) = pan - toRealSpan (UnhelpfulSpan _) = panic "mkTickArray UnhelpfulSpan" -- don't reset the counter back to zero? discardActiveBreakPoints :: GHCi () @@ -3345,9 +3386,8 @@ deleteBreak identity = do turnOffBreak :: BreakLocation -> GHCi Bool turnOffBreak loc = do - dflags <- getDynFlags (arr, _) <- getModBreak (breakModule loc) - liftIO $ setBreakFlag dflags False arr (breakTick loc) + liftIO $ setBreakFlag False arr (breakTick loc) getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan) getModBreak m = do @@ -3357,10 +3397,10 @@ getModBreak m = do let ticks = GHC.modBreaks_locs modBreaks return (arr, ticks) -setBreakFlag :: DynFlags -> Bool -> GHC.BreakArray -> Int -> IO Bool -setBreakFlag dflags toggle arr i - | toggle = GHC.setBreakOn dflags arr i - | otherwise = GHC.setBreakOff dflags arr i +setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool +setBreakFlag toggle arr i + | toggle = GHC.setBreakOn arr i + | otherwise = GHC.setBreakOff arr i -- --------------------------------------------------------------------------- -- cgit v1.2.1