GitLab

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