Rodrigo Mesquita pushed to branch wip/romes/exec-break-has-resume at Glasgow Haskell Compiler / GHC Commits: 1957d4e6 by Rodrigo Mesquita at 2026-10-29T11:54:26+00:00 Move the interactive 'Resume' stack to GhciState The GHC interactive context kept track of a stack of stopped breakpoints (when a breakpoint was hit evaluating something while stopped at another breakpoint). This commit moves that breakpoint stack to GhciState, since it is only relevant to breakpoints as they are evaluated in GHCi. The interactive context should at most reflect the context under which interactive evaluation happens. Not necessarily the operational order in which breakpoints were hit or nested. A different client, such as the debugger, will want to manage breakpoints differently (especially in a multi-threaded context), so it is imperative that operations such as `execStmt` and `resumeStmt` don't modify or rely on this global interactive stack. - - - - - 6 changed files: - compiler/GHC.hs - compiler/GHC/Runtime/Context.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Eval.hs - ghc/GHCi/UI.hs - ghc/GHCi/UI/Monad.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -203,8 +203,7 @@ module GHC ( Resume(..), History(historyBreakpointId, historyEnclosingDecls), GHC.getHistorySpan, getHistoryModule, - abandon, abandonAll, - getResumeContext, + abandon, GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType, modInfoModBreaks, ModBreaks(..), BreakTickIndex, ===================================== compiler/GHC/Runtime/Context.hs ===================================== @@ -24,7 +24,7 @@ import GHC.Hs import GHC.Driver.DynFlags import {-# SOURCE #-} GHC.Driver.Plugins -import GHC.Runtime.Eval.Types ( IcGlobalRdrEnv(..), Resume ) +import GHC.Runtime.Eval.Types ( IcGlobalRdrEnv(..) ) import GHC.Unit import GHC.Unit.Env @@ -322,9 +322,6 @@ data InteractiveContext ic_default :: DefaultEnv, -- ^ The current default classes and types, set by 'default' declarations - ic_resume :: [Resume], - -- ^ The stack of breakpoint contexts - ic_monad :: ExactRdrName, -- ^ The monad that GHCi is executing in @@ -370,7 +367,6 @@ emptyInteractiveContext dflags ic_monad = ExactOcc ioTyConOcc, -- IO monad by default ic_int_print = ExactOcc printIdOcc, -- System.IO.print by default ic_default = emptyDefaultEnv, - ic_resume = [], ic_cwd = Nothing, ic_plugins = emptyPlugins } ===================================== compiler/GHC/Runtime/Debugger/Breakpoints.hs ===================================== @@ -266,32 +266,21 @@ mkBreakpointOccurrences = do -- Getting current breakpoint information -------------------------------------------------------------------------------- -getCurrentBreakSpan :: GhcMonad m => m (Maybe SrcSpan) -getCurrentBreakSpan = do +getResumeBreakSpan :: GhcMonad m => Resume -> m SrcSpan +getResumeBreakSpan r = do hug <- hsc_HUG <$> getSession - resumes <- getResumeContext - case resumes of - [] -> return Nothing - (r:_) -> do - let ix = resumeHistoryIx r - if ix == 0 - then return (Just (resumeSpan r)) - else do - let hist = resumeHistory r !! (ix-1) - pan <- liftIO $ getHistorySpan hug hist - return (Just pan) + case resumeHistoryIx r of + 0 -> return (resumeSpan r) + ix -> liftIO $ getHistorySpan hug (resumeHistory r !! (ix-1)) -getCurrentBreakModule :: GhcMonad m => m (Maybe Module) -getCurrentBreakModule = do - resumes <- getResumeContext +getResumeBreakModule :: GhcMonad m => Resume -> m (Maybe Module) +getResumeBreakModule r = do hug <- hsc_HUG <$> getSession - liftIO $ case resumes of - [] -> pure Nothing - (r:_) -> case resumeHistoryIx r of - 0 -> case resumeBreakpointId r of - Nothing -> pure Nothing - Just ibi -> do - brks <- readIModBreaks hug ibi - return $ Just $ getBreakSourceMod ibi brks - ix -> - Just <$> getHistoryModule hug (resumeHistory r !! (ix-1)) + liftIO $ case resumeHistoryIx r of + 0 -> case resumeBreakpointId r of + Nothing -> pure Nothing + Just ibi -> do + brks <- readIModBreaks hug ibi + return $ Just $ getBreakSourceMod ibi brks + ix -> + Just <$> getHistoryModule hug (resumeHistory r !! (ix-1)) ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -14,8 +14,7 @@ module GHC.Runtime.Eval ( execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..), resumeExec, runDecls, runDeclsWithLocation, runParsedDecls, parseImportDecl, SingleStep(..), - abandon, abandonAll, - getResumeContext, + abandon, getHistorySpan, getModBreaks, readIModBreaks, readIModModBreaks, getHistoryModule, @@ -140,9 +139,6 @@ import GHCi.BreakArray (BreakArray) -- ----------------------------------------------------------------------------- -- running a statement interactively -getResumeContext :: GhcMonad m => m [Resume] -getResumeContext = withSession (return . ic_resume . hsc_IC) - mkHistory :: HUG.HomeUnitGraph -> ForeignHValue -> InternalBreakpointId -> IO History mkHistory hug hval ibi = History hval ibi <$> findEnclosingDecls hug ibi @@ -341,9 +337,8 @@ handleRunStatus step expr bindings final_ids status history0 = do , resumeCCS = ccs , resumeHistoryIx = 0 } - hsc_env2 = pushResume hsc_env1 resume - setSession hsc_env2 + setSession hsc_env1 return (ExecBreak break_ids Nothing resume) -- EvalBreak (Just ...) case: the interpreter stopped at a breakpoint @@ -388,8 +383,7 @@ handleRunStatus step expr bindings final_ids status history0 = do , resumeCCS = ccs , resumeHistoryIx = 0 } - hsc_env2 = pushResume hsc_env1 resume - setSession hsc_env2 + setSession hsc_env1 return (ExecBreak break_ids (Just ibi) resume) else do -- resume with the same step type @@ -409,10 +403,6 @@ handleRunStatus step expr bindings final_ids status history0 = do -- -- The interactive things in scope are restored to the things available at the -- time this paused thread hit the breakpoint. --- --- This 'Resume' is not popped off the interactive `ic_resume` breakpoint --- stack, since there's no way to tell which of the breakpoints in the stack is --- the one we're resuming. resumeExec :: GhcMonad m => SingleStep -> Maybe Int @@ -495,58 +485,49 @@ getBreakArray interp InternalBreakpointId{ibi_info_mod} imbs = do ( ld_st' , ba ) -back :: GhcMonad m => Int -> m ([Id], Int, SrcSpan) + +back :: GhcMonad m => Int -> Resume -> m (Resume, [Id], SrcSpan) back n = moveHist (+n) -forward :: GhcMonad m => Int -> m ([Id], Int, SrcSpan) +forward :: GhcMonad m => Int -> Resume -> m (Resume, [Id], SrcSpan) forward n = moveHist (subtract n) -moveHist :: GhcMonad m => (Int -> Int) -> m ([Id], Int, SrcSpan) -moveHist fn = do +moveHist :: GhcMonad m => (Int -> Int) -> Resume -> m (Resume, [Id], SrcSpan) +moveHist fn r = do hsc_env <- getSession - case ic_resume (hsc_IC hsc_env) of - [] -> liftIO $ - throwGhcExceptionIO (ProgramError "not stopped at a breakpoint") - (r:rs) -> do - let ix = resumeHistoryIx r - history = resumeHistory r - new_ix = fn ix - -- - when (history `lengthLessThan` new_ix) $ liftIO $ - throwGhcExceptionIO (ProgramError "no more logged breakpoints") - when (new_ix < 0) $ liftIO $ - throwGhcExceptionIO (ProgramError "already at the beginning of the history") - - let - update_ic apStack mb_info = do - span <- case mb_info of - Nothing -> return $ mkGeneralSrcSpan (fsLit "<unknown>") - Just ibi -> liftIO $ do - let hug = hsc_HUG hsc_env - brks <- readIModBreaks hug ibi - getBreakLoc (readIModModBreaks hug) ibi brks - (hsc_env1, final_ids) <- - liftIO $ bindLocalsAtBreakpoint hsc_env apStack span mb_info - let ic = hsc_IC hsc_env1 - r' = r { resumeHistoryIx = new_ix } - ic' = ic { ic_resume = r':rs } - - setSession hsc_env1{ hsc_IC = ic' } - - return (final_ids, new_ix, span) - - -- careful: we want apStack to be the AP_STACK itself, not a thunk - -- around it, hence the cases are carefully constructed below to - -- make this the case. ToDo: this is v. fragile, do something better. - if new_ix == 0 - then case r of - Resume { resumeApStack = apStack, - resumeBreakpointId = mb_brkpt } -> - update_ic apStack mb_brkpt - else case history !! (new_ix - 1) of - History{..} -> - update_ic historyApStack (Just historyBreakpointId) + let ix = resumeHistoryIx r + history = resumeHistory r + new_ix = fn ix + -- + when (history `lengthLessThan` new_ix) $ liftIO $ + throwGhcExceptionIO (ProgramError "no more logged breakpoints") + when (new_ix < 0) $ liftIO $ + throwGhcExceptionIO (ProgramError "already at the beginning of the history") + let + update_ic apStack mb_info = do + span <- case mb_info of + Nothing -> return $ mkGeneralSrcSpan (fsLit "<unknown>") + Just ibi -> liftIO $ do + let hug = hsc_HUG hsc_env + brks <- readIModBreaks hug ibi + getBreakLoc (readIModModBreaks hug) ibi brks + (hsc_env1, final_ids) <- + liftIO $ bindLocalsAtBreakpoint hsc_env apStack span mb_info + setSession hsc_env1 + return (r { resumeHistoryIx = new_ix }, final_ids, span) + + -- careful: we want apStack to be the AP_STACK itself, not a thunk + -- around it, hence the cases are carefully constructed below to + -- make this the case. ToDo: this is v. fragile, do something better. + if new_ix == 0 + then case r of + Resume { resumeApStack = apStack, + resumeBreakpointId = mb_brkpt } -> + update_ic apStack mb_brkpt + else case history !! (new_ix - 1) of + History{..} -> + update_ic historyApStack (Just historyBreakpointId) -- ----------------------------------------------------------------------------- -- After stopping at a breakpoint, add free variables to the environment @@ -718,12 +699,6 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do let ic' = substInteractiveContext ic subst return (hsc_env{hsc_IC=ic'}, subst `composeTCvSubst` last_subst) -pushResume :: HscEnv -> Resume -> HscEnv -pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 } - where - ictxt0 = hsc_IC hsc_env - ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 } - {- Note [Syncing breakpoint info] @@ -756,31 +731,10 @@ pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 } -- ----------------------------------------------------------------------------- -- Abandoning a resume context -abandon :: GhcMonad m => m Bool -abandon = do - hsc_env <- getSession - let ic = hsc_IC hsc_env - resume = ic_resume ic - interp = hscInterp hsc_env - case resume of - [] -> return False - r:rs -> do - setSession hsc_env{ hsc_IC = ic { ic_resume = rs } } - liftIO $ abandonStmt interp (resumeContext r) - return True - -abandonAll :: GhcMonad m => m Bool -abandonAll = do - hsc_env <- getSession - let ic = hsc_IC hsc_env - resume = ic_resume ic - interp = hscInterp hsc_env - case resume of - [] -> return False - rs -> do - setSession hsc_env{ hsc_IC = ic { ic_resume = [] } } - liftIO $ mapM_ (abandonStmt interp. resumeContext) rs - return True +abandon :: GhcMonad m => Resume -> m () +abandon r = do + interp <- hscInterp <$> getSession + liftIO $ abandonStmt interp (resumeContext r) -- ----------------------------------------------------------------------------- -- Bounded list, optimised for repeated cons ===================================== ghc/GHCi/UI.hs ===================================== @@ -558,6 +558,7 @@ interactiveUI config baseDFlags srcs maybe_exprs = do line_number = 0, break_ctr = 0, breaks = IntMap.empty, + resume_stack = [], tickarrays = emptyModuleEnv, internalBreaks = emptyModuleEnv, ghci_commands = availableCommands config, @@ -1210,7 +1211,7 @@ getInfoForPrompt :: GhciMonad m => m (SDoc, [String], Int) getInfoForPrompt = do st <- getGHCiState imports <- GHC.getContext - resumes <- GHC.getResumeContext + resumes <- getResumeContext context_bit <- case resumes of @@ -1831,9 +1832,9 @@ isPrefixOptOf :: String -> String -> Bool isPrefixOptOf s x = let (body, opt) = break (== '!') s in (body `isPrefixOf` x) && (opt `isSuffixOf` x) -getCallStackAtCurrentBreakpoint :: GHC.GhcMonad m => m (Maybe [String]) +getCallStackAtCurrentBreakpoint :: GhciMonad m => m (Maybe [String]) getCallStackAtCurrentBreakpoint = do - resumes <- GHC.getResumeContext + resumes <- getResumeContext case resumes of [] -> return Nothing (r:_) -> do @@ -2355,7 +2356,7 @@ loadModule' loadTargets files = do let load_module = do -- unload first - _ <- GHC.abandonAll + abandonAll clearCaches GHC.setTargets targets @@ -3931,9 +3932,9 @@ showBkptTable = do st <- getGHCiState printForUser $ prettyLocations (breaks st) -showContext :: GHC.GhcMonad m => m () +showContext :: GhciMonad m => m () showContext = do - resumes <- GHC.getResumeContext + resumes <- getResumeContext docs <- mapM pp_resume (reverse resumes) printForUser $ vcat docs where @@ -4400,7 +4401,7 @@ doContinue' step mbCnt= do abandonCmd :: GhciMonad m => String -> m () abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do - b <- GHC.abandon -- the prompt will change to indicate the new context + b <- abandon -- the prompt will change to indicate the new context when (not b) $ liftIO $ putStrLn "There is no computation running." deleteCmd :: GhciMonad m => String -> m () @@ -4477,14 +4478,14 @@ enaDisaAllBreaks enaDisa = do st <- getGHCiState mapM_ (enaDisaAssoc enaDisa) $ IntMap.assocs $ breaks st -historyCmd :: GHC.GhcMonad m => String -> m () +historyCmd :: GhciMonad m => String -> m () historyCmd arg | null arg = history 20 | all isDigit arg = history (read arg) | otherwise = liftIO $ putStrLn "Syntax: :history [num]" where history num = do - resumes <- GHC.getResumeContext + resumes <- getResumeContext case resumes of [] -> liftIO $ putStrLn "Not stopped at a breakpoint" (r:_) -> do @@ -4546,7 +4547,7 @@ backCmd arg | otherwise = liftIO $ putStrLn "Syntax: :back [num]" where back num = withSandboxOnly ":back" $ do - (ids, _, pan) <- GHC.back num + (ids, _, pan) <- moveHist (GHC.back num) printForUser $ text "Logged breakpoint at" <+> ppr pan printTypeOfIds ids -- run the command set with ":set stop <cmd>" @@ -4560,7 +4561,7 @@ forwardCmd arg | otherwise = liftIO $ putStrLn "Syntax: :forward [num]" where forward num = withSandboxOnly ":forward" $ do - (ids, ix, pan) <- GHC.forward num + (ids, ix, pan) <- moveHist (GHC.forward num) printForUser $ (if (ix == 0) then text "Stopped at" else text "Logged breakpoint at") <+> ppr pan @@ -4677,7 +4678,7 @@ The names of nested functions are stored in `ModBreaks.modBreaks_decls`. ----------------------------------------------------------------------------- -- :where -whereCmd :: GHC.GhcMonad m => String -> m () +whereCmd :: GhciMonad m => String -> m () whereCmd = noArgs $ do mstrs <- getCallStackAtCurrentBreakpoint case mstrs of @@ -4696,7 +4697,7 @@ listCmd "" = do Just (RealSrcSpan pan _) -> listAround pan True Just pan@_ -> - do resumes <- GHC.getResumeContext + do resumes <- getResumeContext case resumes of [] -> panic "No resumes" (r:_) -> ===================================== ghc/GHCi/UI/Monad.hs ===================================== @@ -22,6 +22,8 @@ module GHCi.UI.Monad ( extractDynFlags, getDynFlags, runStmt, runDecls, runDecls', resume, recordBreak, revertCAFs, + getResumeContext, abandon, abandonAll, moveHist, + getCurrentBreakSpan, getCurrentBreakModule, ActionStats(..), runAndPrintStats, runWithStats, printStats, prettyLocations, @@ -97,6 +99,9 @@ data GHCiState = GHCiState line_number :: !Int, -- ^ input line break_ctr :: !Int, breaks :: !(IntMap.IntMap BreakLocation), + resume_stack :: [GHC.Resume], + -- ^ The stack of 'Resume's for nested breakpoints hit (hitting a + -- breakpoint while evaluating an expression at another breakpoint) tickarrays :: ModuleEnv TickArray, -- ^ 'tickarrays' caches the 'TickArray' for loaded modules, -- so that we don't rebuild it each time the user sets @@ -380,7 +385,9 @@ runStmt stmt stmt_text step = do , GHC.execSingleStep = step , GHC.execWrap = \fhv -> EvalApp (EvalThis (evalWrapper st)) (EvalThis fhv) } - Just <$> GHC.execStmt' stmt stmt_text opts + r <- GHC.execStmt' stmt stmt_text opts + pushResume r + return (Just r) runDecls :: GhciMonad m => String -> m (Maybe [GHC.TyThing]) runDecls decls = do @@ -413,12 +420,70 @@ resume step mbIgnoreCnt = do withProgName (progname st) $ withArgs (args st) $ reflectGHCi x $ do - GHC.getResumeContext >>= \case - [] -> liftIO $ - throwGhcExceptionIO (GHC.ProgramError "not stopped at a breakpoint") - (r:rs) -> do - modifySession $ \env -> env{hsc_IC = (hsc_IC env){ ic_resume = rs }} - GHC.resumeExec step mbIgnoreCnt r + r <- popResume >>= \case + Nothing -> liftIO $ + throwGhcExceptionIO (GHC.ProgramError "not stopped at a breakpoint") + Just r -> return r + res <- GHC.resumeExec step mbIgnoreCnt r + pushResume res + return res + +-- ----------------------------------------------------------------------------- +-- Resume helpers + +pushResume :: GhciMonad m => GHC.ExecResult -> m () +pushResume GHC.ExecBreak{GHC.breakResume = r} = + modifyGHCiState $ \st -> st{ resume_stack = r : resume_stack st } +pushResume _ = return () + +popResume :: GhciMonad m => m (Maybe GHC.Resume) +popResume = do + st <- getGHCiState + case resume_stack st of + [] -> return Nothing + r:rs -> do setGHCiState st{ resume_stack = rs } + return (Just r) + +abandon :: GhciMonad m => m Bool +abandon = popResume >>= \case + Nothing -> return False + Just r -> GHC.abandon r >> return True + +abandonAll :: GhciMonad m => m () +abandonAll = do + st <- getGHCiState + setGHCiState st{ resume_stack = [] } + mapM_ GHC.abandon (resume_stack st) + +moveHist :: GhciMonad m + => (GHC.Resume -> m (GHC.Resume, [GHC.Id], SrcSpan)) + -> m ([GHC.Id], Int, SrcSpan) +moveHist move = do + st <- getGHCiState + case resume_stack st of + [] -> liftIO $ + throwGhcExceptionIO (GHC.ProgramError "not stopped at a breakpoint") + r:rs -> do + (r', ids, pan) <- move r + setGHCiState st{ resume_stack = r' : rs } + return (ids, GHC.resumeHistoryIx r', pan) + +getResumeContext :: GhciMonad m => m [GHC.Resume] +getResumeContext = resume_stack <$> getGHCiState + +getCurrentBreakSpan :: GhciMonad m => m (Maybe SrcSpan) +getCurrentBreakSpan = do + resumes <- getResumeContext + case resumes of + [] -> return Nothing + r:_ -> Just <$> getResumeBreakSpan r + +getCurrentBreakModule :: GhciMonad m => m (Maybe Module) +getCurrentBreakModule = do + resumes <- getResumeContext + case resumes of + [] -> return Nothing + r:_ -> getResumeBreakModule r -- -------------------------------------------------------------------------- -- timing & statistics View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1957d4e6f115d88a98621d68a740b1b0... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1957d4e6f115d88a98621d68a740b1b0... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help