Rodrigo Mesquita pushed to branch wip/romes/set-break-flags at Glasgow Haskell Compiler / GHC Commits: 9d607bdd by Rodrigo Mesquita at 2026-11-03T18:26:11+00:00 interp: Set per-thread break flags outside withBreakAction Currently, the per-thread flags are: - Single-step: Stop at the immediate next breakpoint in this thread - Step-out: Stop at the next continuation with a breakpoint this thread returns to. - Break-on-exception: Stop the next time a synchronous exception is raised in this thread. Originally, these flags were all set globally across all threads. More recently, these flags are set per-thread when `resume`ing that thread, but globally when starting the evaluation of a new expression (`evalStmt`). With this commit, we now use per-TSO flags in both scenarios evaluating expressions in the interpreter (`evalStmt` and `resumeStmt`). - In `resumeStmt` we set the `EvalOpts` specifically in the `ThreadId` being resumed. - In `evalStmt`, we set the `EvalOpts` exclusively on the sandbox thread we fork to evaluate the given expression - When not using the sandbox thread (i.e. -fno-ghci-sandbox), we don't support the debugger anyway, so the break flags are irrelevant. This slightly changes the behavior of evaluating a new expression in the debugger (resuming a thread behaves the same as before). Namely, `:step <expr>`, where <expr> forks a thread, will stop at the immediate next breakpoint in the <expr> main thread, not on a breakpoint of any forked thread. NB: the forked thread may still stop at breakpoint, if it is enabled by index specifically, and then :step-ing from that thread's breakpoint will toggle per-thread stepping for that forked thread. We will want to control stepping in "all threads, regardless of whether we control them or if they were spawned by the debuggee" separately from the commands which trigger evaluation of just an expression. Namely, we'll likely want a "break at the next immediate breakpoint hit on ANY thread" command that the user can execute before launching a debuggee which is multi-threaded. This may even be the default for GHCi. Towards #26064 Fixes #28080 - - - - - 5 changed files: - libraries/ghci/GHCi/Run.hs - testsuite/tests/ghci.debugger/scripts/all.T - + testsuite/tests/ghci.debugger/scripts/break037.hs - + testsuite/tests/ghci.debugger/scripts/break037.script - + testsuite/tests/ghci.debugger/scripts/break037.stdout Changes: ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -204,7 +204,8 @@ doSeq ref = do resumeSeq :: RemoteRef (ResumeContext ()) -> IO (EvalStatus ()) resumeSeq hvref = do ResumeContext{..} <- localRef hvref - withBreakAction evalOptsSeq resumeBreakMVar resumeStatusMVar (Just resumeThreadId) $ + setBreakFlags evalOptsSeq resumeThreadId + withBreakAction resumeBreakMVar resumeStatusMVar $ mask_ $ do putMVar resumeBreakMVar () -- this awakens the stopped thread... redirectInterrupts resumeThreadId $ takeMVar resumeStatusMVar @@ -233,15 +234,23 @@ sandboxIO opts io = do -- We are running in uninterruptibleMask breakMVar <- newEmptyMVar statusMVar <- newEmptyMVar - withBreakAction opts breakMVar statusMVar Nothing $ do + withBreakAction breakMVar statusMVar $ do let runIt = measureAlloc $ tryEval $ rethrow opts $ clearCCS io if useSandboxThread opts then do + wait <- newEmptyMVar tid <- forkIO $ do + + takeMVar wait -- don't run anything in this thread before + -- `setBreakFlags` sets up. + tid <- myThreadId labelThread tid "GHCi sandbox" unsafeUnmask runIt >>= putMVar statusMVar -- empty: can't block + + setBreakFlags opts tid -- set flags on the sandbox thread + putMVar wait () redirectInterrupts tid $ unsafeUnmask $ takeMVar statusMVar else -- GLUT on OS X needs to run on the main thread. If you @@ -328,34 +337,19 @@ tryEval io = do Right a -> return (EvalSuccess a) -- This function sets up the interpreter for catching breakpoints, and --- resets everything when the computation has stopped running. This --- is a not-very-good way to ensure that only the interactive +-- resets the breakpoint action when the computation has stopped running. +-- This is a not-very-good way to ensure that only the interactive -- evaluation should generate breakpoints. -withBreakAction :: EvalOpts -> MVar () +withBreakAction :: MVar () -> MVar (EvalStatus b) - -> Maybe ThreadId -- ^ If resuming, the current threadId -> IO a -> IO a -withBreakAction opts breakMVar statusMVar mtid act +withBreakAction breakMVar statusMVar act = bracket setBreakAction resetBreakAction (\_ -> act) where setBreakAction = do stablePtr <- newStablePtr onBreak poke breakPointIOAction stablePtr - when (breakOnException opts) $ do - case mtid of - Nothing -> rts_enableStopOnExceptionAll - Just (ThreadId tid) -> do - rts_enableStopOnException tid - when (singleStep opts) rts_enableStopNextBreakpointAll - when (stepOut opts) $ do - case mtid of - Nothing -> rts_enableStopNextBreakpointAll -- just enable single-step when no thread is stopped - Just (ThreadId tid) -> do - rts_enableStopAfterReturn tid return stablePtr - -- Breaking on exceptions is not enabled by default, since it - -- might be a bit surprising. The exception flag is turned off - -- as soon as it is hit, or in resetBreakAction below. onBreak :: BreakpointCallback onBreak info_mod# info_mod_uid# infox# is_exception apStack = do @@ -387,21 +381,56 @@ withBreakAction opts breakMVar statusMVar mtid act resetBreakAction stablePtr = do poke breakPointIOAction noBreakStablePtr - case mtid of - Just (ThreadId tid) -> rts_disableStopOnException tid - _ -> rts_disableStopOnExceptionAll - rts_disableStopNextBreakpointAll - case mtid of - Just (ThreadId tid) -> rts_disableStopAfterReturn tid - _ -> pure () freeStablePtr stablePtr +-- | Set the single-step, step-out, and break-on-exception flags on the target +-- thread based on the given 'EvalOpts'. +-- +-- Breaking on exceptions is not enabled by default, since it might be a +-- bit surprising. The exception flag is turned off as soon as it is hit. +-- +-- See Note [Always setBreakFlags on running thread] +setBreakFlags :: EvalOpts -> ThreadId -> IO () +setBreakFlags opts (ThreadId tid#) = do + setFlag# breakOnException rts_enableStopOnException rts_disableStopOnException + setFlag# singleStep rts_enableStopNextBreakpoint rts_disableStopNextBreakpoint + setFlag# stepOut rts_enableStopAfterReturn rts_disableStopAfterReturn + where + setFlag# pred on off = if pred opts then on tid# else off tid# + +{- +Note [Always setBreakFlags on running thread] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Whenever we run a expression in the interpreter or unblock a paused thread we +must make sure all breakpoint-flags for that thread are set according to the +given options. There are three scenarios in which we set something running: + +- `evalStmt`, forks a thread to evaluate the given expression +- `resumeStmt`, unblocks a given thread to resume execution +- `abandonStmt`, kills a given thread to terminate execution (but the thread +- will resume to handle the exception) + +In these three cases, if we musn't forget to set all breakpoint flags, +since otherwise we'd resume execution with whatever stale state we had of the +previous run command. A trivial example would be: + +1. `evalStmt` with { singleStep = True, breakOnError = True } would e.g. stop on + an exception and clear TSO_STOP_ON_EXCEPTION, but TSO_STOP_NEXT_BREAKPOINT + would still be active. +2. `abandonStmt` if we didn't setBreakFlags again would kill the thread but + hit the next breakpoint bc TSO_STOP_NEXT_BREAKPOINT would still be active. + +Likewise for other interactions between eval/resume/abandon. +TL;DR: always `setBreakFlags` when running/resuming a thread +-} + resumeStmt :: EvalOpts -> RemoteRef (ResumeContext [HValueRef]) -> IO (EvalStatus [HValueRef]) resumeStmt opts hvref = do ResumeContext{..} <- localRef hvref - withBreakAction opts resumeBreakMVar resumeStatusMVar (Just resumeThreadId) $ + setBreakFlags opts resumeThreadId + withBreakAction resumeBreakMVar resumeStatusMVar $ mask_ $ do putMVar resumeBreakMVar () -- this awakens the stopped thread... redirectInterrupts resumeThreadId $ takeMVar resumeStatusMVar @@ -421,10 +450,20 @@ resumeStmt opts hvref = do abandonStmt :: RemoteRef (ResumeContext [HValueRef]) -> IO () abandonStmt hvref = do ResumeContext{..} <- localRef hvref + setBreakFlags evalOptsAbandon resumeThreadId killThread resumeThreadId putMVar resumeBreakMVar () _ <- takeMVar resumeStatusMVar return () + where + -- Don't stop anywhere on abandon + evalOptsAbandon = EvalOpts + { useSandboxThread = True + , singleStep = False + , stepOut = False + , breakOnException = False + , breakOnError = False + } noBreakStablePtr :: StablePtr BreakpointCallback noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction ===================================== testsuite/tests/ghci.debugger/scripts/all.T ===================================== @@ -157,3 +157,4 @@ test('T26042g', extra_files(['T26042g.hs']), ghci_script, ['T26042g.script']) test('T27633c', extra_files(['T27633c_obj.hs']), ghci_script, ['T27633c.script']) test('RttiSharedTyVar', extra_files(['RttiSharedTyVar.hs']), ghci_script, ['RttiSharedTyVar.script']) +test('break037', extra_files(['break037.hs']), ghci_script, ['break037.script']) ===================================== testsuite/tests/ghci.debugger/scripts/break037.hs ===================================== @@ -0,0 +1,12 @@ +module Main where + +import Control.Exception + +f :: () -> IO () +f () = throwIO (ErrorCall "boom") `finally` g () + +g :: () -> IO () +g () = putStrLn "cleanup" + +main :: IO () +main = f () ===================================== testsuite/tests/ghci.debugger/scripts/break037.script ===================================== @@ -0,0 +1,9 @@ +:l break037 +:set -fbreak-on-exception +:step f () +:step +-- Stepping into throwIO stops on the exception rather than at a breakpoint +:step +-- Running the cleanup in g while abandoning must not hit a breakpoint +:abandon +putStrLn "after abandon" ===================================== testsuite/tests/ghci.debugger/scripts/break037.stdout ===================================== @@ -0,0 +1,8 @@ +Stopped in Main.f, break037.hs:6:8-48 +_result :: IO () = _ +Stopped in Main.f, break037.hs:6:8-33 +_result :: IO () = _ +Stopped in <exception thrown>, <unknown> +_exception :: e = _ +cleanup +after abandon View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9d607bdd938fdc84b3817fff8d86c202... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9d607bdd938fdc84b3817fff8d86c202... 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