[Git][ghc/ghc][wip/loop-backtrace] 3 commits: testsuite: Add LoopBacktrace test

19 Jun 2026


      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.

    

Ben Gamari (＠bgamari)

tags

participants (1)