GitLab

Rodrigo Mesquita pushed to branch wip/romes/per-thread-break-on-exception at Glasgow Haskell Compiler / GHC

Commits:

2103dc2f

by Rodrigo Mesquita at 2026-11-03T13:58:37+00:00

Per-thread break-on exception (TSO_STOP_ON_EXCEPTION)

The `-fbreak-on-exception` flag allows the interactive interpreter to stop
when a synchronous exception is raised.

However, this is a global toggle backed by a global variable in the RTS
(rts_stop_on_exception) which is not compatible with a multi-threaded
debugger where we may want to stop if some threads raise a synchronous
exception but not other.

This commit makes -break-on-exception similar to step-next and step-out
where there is a per-thread toggle on each TSO (TSO_STOP_ON_EXCEPTION),
and that break-on-exception set in EvalOpts when resuming a statement
only affect the thread being resumed.

Fixes #28068

12 changed files:

libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc
libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc
libraries/ghc-heap/tests/parse_tso_flags.hs
libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs
libraries/ghci/GHCi/Debugger.hs
libraries/ghci/GHCi/Run.hs
rts/Exception.cmm
rts/Interpreter.c
rts/Interpreter.h
rts/RtsSymbols.c
rts/include/rts/Constants.h
rts/include/stg/MiscClosures.h

Changes:

libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc

@@ -93,6 +93,7 @@ parseTsoFlags w | isSet (#const TSO_LOCKED) w = TsoLocked : parseTsoFlags (unset
  #if __GLASGOW_HASKELL__ >= 913
                  | isSet (#const TSO_STOP_NEXT_BREAKPOINT) w = TsoStopNextBreakpoint : parseTsoFlags (unset (#const TSO_STOP_NEXT_BREAKPOINT) w)
                  | isSet (#const TSO_STOP_AFTER_RETURN) w = TsoStopAfterReturn : parseTsoFlags (unset (#const TSO_STOP_AFTER_RETURN) w)
 +                | isSet (#const TSO_STOP_ON_EXCEPTION) w = TsoStopOnException : parseTsoFlags (unset (#const TSO_STOP_ON_EXCEPTION) w)
  #endif
  parseTsoFlags 0 = []
  parseTsoFlags w = [TsoFlagsUnknownValue w]

libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc

@@ -93,6 +93,7 @@ parseTsoFlags w | isSet (#const TSO_LOCKED) w = TsoLocked : parseTsoFlags (unset
  #if __GLASGOW_HASKELL__ >= 913
                  | isSet (#const TSO_STOP_NEXT_BREAKPOINT) w = TsoStopNextBreakpoint : parseTsoFlags (unset (#const TSO_STOP_NEXT_BREAKPOINT) w)
                  | isSet (#const TSO_STOP_AFTER_RETURN) w = TsoStopAfterReturn : parseTsoFlags (unset (#const TSO_STOP_AFTER_RETURN) w)
 +                | isSet (#const TSO_STOP_ON_EXCEPTION) w = TsoStopOnException : parseTsoFlags (unset (#const TSO_STOP_ON_EXCEPTION) w)
  #endif
  parseTsoFlags 0 = []
  parseTsoFlags w = [TsoFlagsUnknownValue w]

libraries/ghc-heap/tests/parse_tso_flags.hs

@@ -15,5 +15,6 @@ main = do
      assertEqual (parseTsoFlags 256) [TsoAllocLimit]
      assertEqual (parseTsoFlags 512) [TsoStopNextBreakpoint]
      assertEqual (parseTsoFlags 1024) [TsoStopAfterReturn]
 +    assertEqual (parseTsoFlags 2048) [TsoStopOnException]
      assertEqual (parseTsoFlags 6) [TsoLocked, TsoBlockx]

libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs

@@ -632,6 +632,7 @@ data TsoFlags
    | TsoAllocLimit
    | TsoStopNextBreakpoint
    | TsoStopAfterReturn
 +  | TsoStopOnException
    | TsoFlagsUnknownValue Word32 -- ^ Please report this as a bug
    deriving (Eq, Show, Generic, Ord)

libraries/ghci/GHCi/Debugger.hs

@@ -13,7 +13,10 @@ module GHCi.Debugger
    , rts_disableStopAfterReturn
    -- * Stop on exception
 -  , exceptionFlag
 +  , rts_enableStopOnException
 +  , rts_disableStopOnException
 +  , rts_enableStopOnExceptionAll
 +  , rts_disableStopOnExceptionAll
    -- * Breakpoint Callback
    , BreakpointCallback
@@ -23,7 +26,6 @@ module GHCi.Debugger
  import Prelude -- See note [Why do we import Prelude here?]
  import GHC.Base (ThreadId#, Addr#, Int#)
 -import Foreign.C (CInt)
  import Foreign (StablePtr, Ptr)
  import GHCi.RemoteTypes (HValue)
@@ -60,7 +62,19 @@ foreign import ccall unsafe "rts_disableStopAfterReturn"
  --------------------------------------------------------------------------------
 -foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt
 +-- | Make this thread break when an exception is hit
 +foreign import ccall unsafe "rts_enableStopOnException"  rts_enableStopOnException  :: ThreadId# -> IO ()
++
 +-- | No longer have this thread break when an exception is hit
 +foreign import ccall unsafe "rts_disableStopOnException" rts_disableStopOnException :: ThreadId# -> IO ()
++
 +-- | Enables global break-on-exception for all threads
 +foreign import ccall unsafe "rts_enableStopOnExceptionAll"  rts_enableStopOnExceptionAll :: IO ()
++
 +-- | Disables the global break-on-exception for all threads. Individual threads
 +-- with break-on-exception will still break on exception if the global flag is
 +-- disabled.
 +foreign import ccall unsafe "rts_disableStopOnExceptionAll" rts_disableStopOnExceptionAll :: IO ()
  --------------------------------------------------------------------------------

libraries/ghci/GHCi/Run.hs

@@ -269,14 +269,17 @@ rethrow EvalOpts{..} io =
    catchNoPropagate io $ \(ExceptionWithContext cx se) -> do
      -- If -fbreak-on-error, we break unconditionally,
      --  but with care of not breaking twice
 +    ThreadId mytid <- myThreadId
      if breakOnError && not breakOnException
 -       then poke exceptionFlag 1
 +       then rts_enableStopOnException mytid
         else case fromException se of
                 -- If it is a "UserInterrupt" exception, we allow
                 --  a possible break by way of -fbreak-on-exception
                 Just UserInterrupt -> return ()
                 -- In any other case, we don't want to break
 -               _ -> poke exceptionFlag 0
 +               _ -> do
 +                  rts_disableStopOnException mytid
 +                  rts_disableStopOnExceptionAll
      rethrowIO (ExceptionWithContext cx se)
  --
@@ -338,7 +341,11 @@ withBreakAction opts breakMVar statusMVar mtid act
     setBreakAction = do
       stablePtr <- newStablePtr onBreak
       poke breakPointIOAction stablePtr
 -     when (breakOnException opts) $ poke exceptionFlag 1
 +     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
@@ -380,7 +387,9 @@ withBreakAction opts breakMVar statusMVar mtid act
     resetBreakAction stablePtr = do
       poke breakPointIOAction noBreakStablePtr
 -     poke exceptionFlag 0
 +     case mtid of
 +      Just (ThreadId tid) -> rts_disableStopOnException tid
 +      _                   -> rts_disableStopOnExceptionAll
       rts_disableStopNextBreakpointAll
       case mtid of
        Just (ThreadId tid) -> rts_disableStopAfterReturn tid

rts/Exception.cmm

@@ -523,14 +523,16 @@ retry_pop_stack:
      if (W_[no_break_on_exception] != 0) {
          W_[no_break_on_exception] = 0;
      } else {
 -        if (TO_W_(CInt[rts_stop_on_exception]) != 0) {
 +        if (TO_W_(CInt[rts_stop_on_exception]) != 0 ||
 +            (TO_W_(StgTSO_flags(CurrentTSO)) & TSO_STOP_ON_EXCEPTION) != 0) {
              W_ ioAction;
              // we don't want any further exceptions to be caught,
              // until GHCi is ready to handle them.  This prevents
              // deadlock if an exception is raised in InteractiveUI,
 -            // for example.  Perhaps the stop_on_exception flag should
 -            // be per-thread.
 +            // for example.
              CInt[rts_stop_on_exception] = 0;
 +            StgTSO_flags(CurrentTSO) = %lobits32(
 +              TO_W_(StgTSO_flags(CurrentTSO)) & ~TSO_STOP_ON_EXCEPTION);
              ("ptr" ioAction) = ccall deRefStablePtr (W_[rts_breakpoint_io_action] "ptr");
              Sp = Sp - WDS(11);
              Sp(10) = exception;

rts/Interpreter.c

@@ -388,8 +388,6 @@ is_ret_bco_frame(const StgPtr frame_head) {
        );
+ }
 -int rts_stop_on_exception = 0;
+-
  /* ---------------------------------------------------------------------------
   * Enabling and disabling global single step mode
   * ------------------------------------------------------------------------ */
@@ -398,7 +396,7 @@ int rts_stop_on_exception = 0;
   * Unlike `TSO_STOP_NEXT_BREAKPOINT`, which sets single-step mode per-thread,
   * `rts_stop_next_breakpoint` globally enables single-step mode. If enabled, we
   * will stop at the immediate next breakpoint regardless of what thread it is in. */
 -int rts_stop_next_breakpoint = 0;
 +static int rts_stop_next_breakpoint = 0;
  void rts_enableStopNextBreakpointAll(void)
+ {
@@ -473,7 +471,50 @@ A limitation of this approach is that stepping-out of a function that was
  tail-called will skip its caller since no stack frame is pushed for a tail
  call (i.e. a tail call returns directly to its caller's first non-tail caller).
  */
 -/* -------------------------------------------------------------------------- */
++
 +/* ---------------------------------------------------------------------------
 + * Enabling and disabling global break-on-exception
 + * ------------------------------------------------------------------------ */
++
 +/* A global toggle for break-on-exception
++
 +   Unlike `TSO_STOP_ON_EXCEPTION`, which breaks when an exception is raised in
 +   this thread, the global toggle makes an exception raised in any thread yield
 +   a breakpoint in that thread.
++
 +   Currently, this is necessary if we ever want to break on an exception raised
 +   in thread forked by the main debuggee thead: we can only toggle TSO_STOP_ON_EXCEPTION
 +   on threads we control, and those forked by the debuggee we don't.
 + */
 +int rts_stop_on_exception = 0;
++
 +void rts_enableStopOnExceptionAll(void)
 +{
 +  rts_stop_on_exception = 1;
 +}
++
 +void rts_disableStopOnExceptionAll(void)
 +{
 +  rts_stop_on_exception = 0;
 +}
++
 +/* ---------------------------------------------------------------------------
 + * Enabling and disabling per-thread break-on-exception
 + * ------------------------------------------------------------------------ */
++
 +void rts_enableStopOnException(StgTSO* tso)
 +{
 +  Capability* cap = rts_unsafeGetMyCapability();
 +  setThreadFlag(cap, tso, TSO_STOP_ON_EXCEPTION);
 +}
++
 +void rts_disableStopOnException(StgTSO* tso)
 +{
 +  Capability* cap = rts_unsafeGetMyCapability();
 +  unsetThreadFlag(cap, tso, TSO_STOP_ON_EXCEPTION);
 +}
++
 +/* ------------------------------------------------------------------------ */
  #if defined(INTERP_STATS)

rts/Interpreter.h

@@ -12,6 +12,11 @@ RTS_PRIVATE Capability *interpretBCO (Capability* cap);
  void interp_startup ( void );
  void interp_shutdown ( void );
 +// The following debugger functions are exported from here, but not from the
 +// RTS public api (RtsApi.h). They are used by the `ghci` library to implement
 +// debugger commands on the interpreter like step-next, step-out, and
 +// break-on-exception.
++
  // Debugger single step
  void rts_enableStopNextBreakpointAll  ( void );
  void rts_disableStopNextBreakpointAll ( void );
@@ -21,3 +26,9 @@ void rts_disableStopNextBreakpoint    ( StgTSO* );
  // Debugger step out
  void rts_enableStopAfterReturn        ( StgTSO* );
  void rts_disableStopAfterReturn       ( StgTSO* );
++
 +// Debugger stop on exception
 +void rts_enableStopOnException        ( StgTSO* );
 +void rts_disableStopOnException       ( StgTSO* );
 +void rts_enableStopOnExceptionAll     ( void );
 +void rts_disableStopOnExceptionAll    ( void );

rts/RtsSymbols.c

@@ -942,14 +942,16 @@ extern char **environ;
        SymI_HasProto(revertCAFs)                                         \
        SymI_HasDataProto(RtsFlags)                                           \
        SymI_NeedsDataProto(rts_breakpoint_io_action)                     \
 -      SymI_NeedsDataProto(rts_stop_next_breakpoint)                     \
 -      SymI_NeedsDataProto(rts_stop_on_exception)                        \
        SymI_NeedsProto(rts_enableStopNextBreakpointAll)                  \
        SymI_NeedsProto(rts_disableStopNextBreakpointAll)                 \
        SymI_NeedsProto(rts_enableStopNextBreakpoint)                     \
        SymI_NeedsProto(rts_disableStopNextBreakpoint)                    \
        SymI_NeedsProto(rts_enableStopAfterReturn)                        \
        SymI_NeedsProto(rts_disableStopAfterReturn)                       \
 +      SymI_NeedsProto(rts_enableStopOnException)                        \
 +      SymI_NeedsProto(rts_disableStopOnException)                       \
 +      SymI_NeedsProto(rts_enableStopOnExceptionAll)                     \
 +      SymI_NeedsProto(rts_disableStopOnExceptionAll)                    \
        SymI_HasProto(stopTimer)                                          \
        SymI_HasDataProto(n_capabilities)                                     \
        SymI_HasDataProto(max_n_capabilities)                                 \

rts/include/rts/Constants.h

@@ -394,6 +394,11 @@
   */
  #define TSO_STOP_AFTER_RETURN 1024
 +/*
 + * Enables break-on-exception mode for this thread
 + */
 +#define TSO_STOP_ON_EXCEPTION 2048
++
  /*
   * The number of times we spin in a spin lock before yielding (see
   * #3758).  To tune this value, use the benchmark in #3758: run the

rts/include/stg/MiscClosures.h

@@ -583,7 +583,6 @@ RTS_FUN_DECL(stg_annotateStackzh);
  #if IN_STG_CODE && !IN_STGCRUN
  // Interpreter.c
 -extern StgWord rts_stop_next_breakpoint[];
  extern StgWord rts_stop_on_exception[];
  extern StgWord rts_breakpoint_io_action[];