Ben Gamari pushed to branch wip/loop-backtrace at Glasgow Haskell Compiler / GHC Commits: 0e661958 by Ben Gamari at 2026-06-19T17:16:44-04:00 testsuite: Add LoopBacktrace test - - - - - 030ac4b4 by Ben Gamari at 2026-06-19T17:16:44-04:00 Throw nontermination exceptions via `throw` This ensures that the exception that results gets the usual backtrace annotations. - - - - - 0d15e5c0 by Ben Gamari at 2026-06-19T17:16:44-04:00 ghc-heap: Decode OrigThunkInfo frames - - - - - 14 changed files: - libraries/base/src/Control/Exception/Base.hs - libraries/ghc-internal/cbits/Stack.cmm - libraries/ghc-internal/include/RtsIfaceSymbols.h - libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs - libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - rts/Prelude.h - rts/RtsStartup.c - rts/Schedule.c - rts/include/rts/RtsToHsIface.h - + testsuite/tests/rts/LoopBacktrace.hs - + testsuite/tests/rts/LoopBacktrace.stderr - + testsuite/tests/rts/LoopBacktrace.stdout - testsuite/tests/rts/all.T Changes: ===================================== libraries/base/src/Control/Exception/Base.hs ===================================== @@ -85,7 +85,6 @@ module Control.Exception.Base patError, noMethodBindingError, typeError, - nonTermination, nestedAtomically, noMatchingContinuationPrompt ) where ===================================== libraries/ghc-internal/cbits/Stack.cmm ===================================== @@ -3,6 +3,10 @@ #include "Cmm.h" +#if !defined(UnregisterisedCompiler) +import CLOSURE stg_orig_thunk_info_frame_info; +#endif + // StgStack_marking was not available in the Stage0 compiler at the time of // writing. Because, it has been added to derivedConstants when Stack.cmm was // developed. @@ -168,6 +172,18 @@ getStackInfoTableAddrzh(P_ stack) { return (info); } +// (StgInfoTable*) getOrigThunkInfoPtrzh(StgStack* stack, StgWord offsetWords) +getOrigThunkInfoPtrzh(P_ stack, W_ offsetWords) { + P_ p; + p = StgStack_sp(stack) + WDS(offsetWords); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(p)); + if (%INFO_PTR(UNTAG(p)) == stg_orig_thunk_info_frame_info) { + return (StgOrigThunkInfoFrame_info_ptr(UNTAG(p))); + } else { + return (NULL); + } +} + // (StgClosure*) getStackClosurezh(StgStack* stack, StgWord offsetWords) getStackClosurezh(P_ stack, W_ offsetWords) { P_ ptr; ===================================== libraries/ghc-internal/include/RtsIfaceSymbols.h ===================================== @@ -20,7 +20,7 @@ CLOSURE(GHCziInternalziIOziException, blockedIndefinitelyOnSTM_closure) CLOSURE(GHCziInternalziIOziException, cannotCompactFunction_closure) CLOSURE(GHCziInternalziIOziException, cannotCompactPinned_closure) CLOSURE(GHCziInternalziIOziException, cannotCompactMutable_closure) -CLOSURE(GHCziInternalziControlziExceptionziBase, nonTermination_closure) +CLOSURE(GHCziInternalziControlziExceptionziBase, nonTerminationError_closure) CLOSURE(GHCziInternalziControlziExceptionziBase, nestedAtomically_closure) CLOSURE(GHCziInternalziControlziExceptionziBase, noMatchingContinuationPrompt_closure) #if defined(mingw32_HOST_OS) ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs ===================================== @@ -108,7 +108,7 @@ module GHC.Internal.Control.Exception.Base ( impossibleError, impossibleConstraintError, nonExhaustiveGuardsError, patError, noMethodBindingError, typeError, - nonTermination, nestedAtomically, noMatchingContinuationPrompt, + nonTerminationError, nestedAtomically, noMatchingContinuationPrompt, ) where import GHC.Internal.Base ( @@ -448,8 +448,9 @@ impossibleConstraintError s = errorWithoutStackTrace (unpackCStringUtf8# s) -- GHC's RTS calls this -nonTermination :: SomeException -nonTermination = toException NonTermination +nonTerminationError :: IO () +nonTerminationError = throwIO NonTermination + -- GHC's RTS calls this nestedAtomically :: SomeException ===================================== libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs ===================================== @@ -568,6 +568,17 @@ data GenStackFrame b = , stack_payload :: ![GenStackField b] } + -- | An @stg_orig_thunk_info_frame@ pushed by @-forig-thunk-info@. It records + -- the original info table of the thunk being updated (in 'orig_info_tbl'), + -- which is otherwise lost when the thunk is blackholed. + -- See @Note [Original thunk info table frames]@ in "GHC.StgToCmm.Bind". + | OrigThunkInfo + { info_tbl :: !StgInfoTable + -- ^ the frame's own (RTS) info table + , orig_info_tbl :: !(Ptr StgInfoTable) + -- ^ the original info table of the thunk being updated + } + | RetFun { info_tbl :: !StgInfoTable , retFunSize :: !Word ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs ===================================== @@ -192,6 +192,16 @@ foreign import prim "getInfoTableAddrszh" getInfoTableAddrs# :: StackSnapshot# - foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr# +foreign import prim "getOrigThunkInfoPtrzh" getOrigThunkInfoPtr# :: StackSnapshot# -> Word# -> Addr# + +-- | @'Just' itbl@ if the frame at the given offset is an +-- @stg_orig_thunk_info_frame@ (where @itbl@ is the recorded original thunk info +-- table), otherwise 'Nothing'. See @Note [Decoding orig_thunk_info frames]@. +origThunkInfoFrame :: StackSnapshot# -> WordOffset -> Maybe (Ptr StgInfoTable) +origThunkInfoFrame stackSnapshot# index = + let p = Ptr (getOrigThunkInfoPtr# stackSnapshot# (wordOffsetToWord# index)) + in if p == nullPtr then Nothing else Just p + -- | Get the 'StgInfoTable' of the stack frame. -- Additionally, provides 'InfoProv' for the 'StgInfoTable' if there is any. getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Maybe InfoProv) @@ -380,6 +390,15 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi bco = bco', bcoArgs = bcoArgs' } + RET_SMALL + | Just orig_itbl <- origThunkInfoFrame stackSnapshot# index -> do + orig_info_prov <- lookupIPE (castPtr orig_itbl) + finaliseStackFrame + OrigThunkInfo + { info_tbl = info, + orig_info_tbl = orig_itbl + } + orig_info_prov RET_SMALL -> let payload' = decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload in ===================================== rts/Prelude.h ===================================== @@ -58,7 +58,7 @@ extern StgClosure ZCMain_main_closure; #define cannotCompactFunction_closure ghc_hs_iface->cannotCompactFunction_closure #define cannotCompactPinned_closure ghc_hs_iface->cannotCompactPinned_closure #define cannotCompactMutable_closure ghc_hs_iface->cannotCompactMutable_closure -#define nonTermination_closure ghc_hs_iface->nonTermination_closure +#define nonTerminationError_closure ghc_hs_iface->nonTerminationError_closure #define nestedAtomically_closure ghc_hs_iface->nestedAtomically_closure #define absentSumFieldError_closure ghc_hs_iface->absentSumFieldError_closure #define underflowException_closure ghc_hs_iface->underflowException_closure ===================================== rts/RtsStartup.c ===================================== @@ -193,7 +193,7 @@ static void initBuiltinGcRoots(void) getStablePtr((StgPtr)heapOverflow_closure); getStablePtr((StgPtr)unpackCString_closure); getStablePtr((StgPtr)blockedIndefinitelyOnMVar_closure); - getStablePtr((StgPtr)nonTermination_closure); + getStablePtr((StgPtr)nonTerminationError_closure); getStablePtr((StgPtr)blockedIndefinitelyOnSTM_closure); getStablePtr((StgPtr)allocationLimitExceeded_closure); getStablePtr((StgPtr)cannotCompactFunction_closure); ===================================== rts/Schedule.c ===================================== @@ -3276,6 +3276,17 @@ findAtomicallyFrameHelper (Capability *cap, StgTSO *tso) } } +static void throwNontermination(Capability *cap, StgTSO *tso) { + StgStack *stack = tso->stackobj; + stack->sp -= 3; + stack->sp[0] = (W_)&stg_enter_info; + stack->sp[1] = (W_)nonTerminationError_closure; + stack->sp[2] = (W_)&stg_ap_v_info; + tso->why_blocked = NotBlocked; + appendToRunQueue(cap,tso); +} + + /* ----------------------------------------------------------------------------- resurrectThreads is called after garbage collection on the list of threads found to be garbage. Each of these threads will be woken @@ -3313,8 +3324,7 @@ resurrectThreads (StgTSO *threads) (StgClosure *)blockedIndefinitelyOnMVar_closure); break; case BlockedOnBlackHole: - throwToSingleThreaded(cap, tso, - (StgClosure *)nonTermination_closure); + throwNontermination(cap, tso); break; case BlockedOnSTM: throwToSingleThreaded(cap, tso, ===================================== rts/include/rts/RtsToHsIface.h ===================================== @@ -25,7 +25,7 @@ typedef struct { StgClosure *cannotCompactFunction_closure; // GHC.Internal.IO.Exception.cannotCompactFunction_closure StgClosure *cannotCompactPinned_closure; // GHC.Internal.IO.Exception.cannotCompactPinned_closure StgClosure *cannotCompactMutable_closure; // GHC.Internal.IO.Exception.cannotCompactMutable_closure - StgClosure *nonTermination_closure; // GHC.Internal.Control.Exception.Base.nonTermination_closure + StgClosure *nonTerminationError_closure; // GHC.Internal.Control.Exception.Base.nonTerminationError_closure StgClosure *nestedAtomically_closure; // GHC.Internal.Control.Exception.Base.nestedAtomically_closure StgClosure *noMatchingContinuationPrompt_closure; // GHC.Internal.Control.Exception.Base.noMatchingContinuationPrompt_closure StgClosure *blockedOnBadFD_closure; // GHC.Internal.Event.Thread.blockedOnBadFD_closure ===================================== testsuite/tests/rts/LoopBacktrace.hs ===================================== @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -finfo-table-map -forig-thunk-info #-} + +import GHC.Exception.Backtrace.Experimental + +x :: Integer +x = x + 1 + +testing :: IO () +testing = do + putStrLn "hello" + print x + putStrLn "world" + +main :: IO () +main = do + setBacktraceMechanismState IPEBacktrace True + testing ===================================== testsuite/tests/rts/LoopBacktrace.stderr ===================================== @@ -0,0 +1,21 @@ +LoopBacktrace: Uncaught exception ghc-internal:GHC.Internal.Control.Exception.Base.NonTermination: + +<<loop>> + +IPE backtrace: + GHC.Internal.Exception.Backtrace.collectBacktraces' (libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs:(179,1)-(202,25)) + GHC.Internal.Exception.Backtrace.collectBacktraces (libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs:174:39-56) + GHC.Internal.Exception.toExceptionWithBacktrace (libraries/ghc-internal/src/GHC/Internal/Exception.hs:(179,26)-(181,53)) + GHC.Internal.IO.throwIO (libraries/ghc-internal/src/GHC/Internal/IO.hs:293:36) + Cmm$rts/HeapStackCheck.cmm. (:) + GHC.Internal.Bignum.Integer.integerAdd (libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs:(547,1)-(571,52)) + Cmm$rts/Updates.cmm. (:) + Main.x (LoopBacktrace.hs:6:1-9) + GHC.Internal.Show.show (libraries/ghc-internal/src/GHC/Internal/Show.hs:497:10-21) + GHC.Internal.IO.Handle.Text.hPutStr' (libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs:667:29-37) + GHC.Internal.Base.thenIO (libraries/ghc-internal/src/GHC/Internal/Base.hs:2337:1-72) + Cmm$rts/Exception.cmm. (:) + Cmm$rts/StgStartup.cmm. (:) +HasCallStack backtrace: + throwIO, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:452:23 in ghc-internal:GHC.Internal.Control.Exception.Base + ===================================== testsuite/tests/rts/LoopBacktrace.stdout ===================================== @@ -0,0 +1 @@ +hello ===================================== testsuite/tests/rts/all.T ===================================== @@ -687,3 +687,5 @@ test('ClosureTable', ['-debug -O0 ClosureTable_c.c -I{top}/../rts -I{top}/../rts/include']) test('resizeMutableByteArrayInPlace', [req_cmm, extra_ways(['optasm', 'sanity']), only_ways(['optasm', 'sanity'])], compile_and_run, ['']) + +test('LoopBacktrace', [exit_code(1)], compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4bffc3c883983cf9b02d33efabdd3f7... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4bffc3c883983cf9b02d33efabdd3f7... You're receiving this email because of your account on gitlab.haskell.org.