Rodrigo Mesquita pushed to branch wip/romes/per-thread-break-on-exception at Glasgow Haskell Compiler / GHC Commits: d7da0b79 by Rodrigo Mesquita at 2026-11-02T16:36:08+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 - - - - - 11 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 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 * ------------------------------------------------------------------------ */ @@ -473,7 +471,40 @@ 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 + * ------------------------------------------------------------------------ */ + +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 ===================================== @@ -21,3 +21,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 ===================================== @@ -950,6 +950,10 @@ extern char **environ; 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 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d7da0b79bdf97e95da3f343ff202df9d... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d7da0b79bdf97e95da3f343ff202df9d... 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