GitLab

Ben Gamari pushed to branch wip/loop-backtrace at Glasgow Haskell Compiler / GHC

Commits:

8fbf9c06

by Ben Gamari at 2026-06-21T08:23:11-04:00

compiler/ipe: Prefer source ticks in current module for return frames

Previously we would simply attribute return frames to the nearest
enclosing tick in the calling frame. However, this will very frequently
produce unhelpful results (e.g. pointing to `(>>)` rather than the
calling function).

abd9dc0e
by Ben Gamari at 2026-06-21T11:20:56-04:00
```
testsuite: Add LoopBacktrace test
```

4010d192

by Ben Gamari at 2026-06-21T11:20:56-04:00

Throw nontermination exceptions via `throw`

This ensures that the exception that results gets the usual backtrace
annotations.

16 changed files:

compiler/GHC/Driver/GenerateCgIPEStub.hs
compiler/GHC/Driver/Main/Compile.hs
libraries/base/src/Control/Exception/Base.hs
libraries/ghc-internal/include/RtsIfaceSymbols.h
libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.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
+ testsuite/tests/rts/ipe/T27408.hs
+ testsuite/tests/rts/ipe/T27408.stdout
testsuite/tests/rts/ipe/all.T

Changes:

compiler/GHC/Driver/GenerateCgIPEStub.hs

  module GHC.Driver.GenerateCgIPEStub (generateCgIPEStub, lookupEstimatedTicks) where
 +import Control.Applicative ((<|>))
  import Data.Map.Strict (Map)
  import qualified Data.Map.Strict as Map
 +import Data.Maybe (listToMaybe)
  import Data.Semigroup ((<>))
  import GHC.Cmm
  import GHC.Cmm.CLabel (CLabel, mkAsmTempLabel)
@@ -10,6 +12,7 @@ import GHC.Cmm.Dataflow.Block (blockSplit, blockToList)
  import GHC.Cmm.Dataflow.Label
  import GHC.Cmm.Info.Build (emptySRT)
  import GHC.Cmm.Pipeline (cmmPipeline)
 +import GHC.Data.FastString (FastString, mkFastString)
  import GHC.Data.Stream (liftIO, liftEff)
  import qualified GHC.Data.Stream as Stream
  import GHC.Driver.Env (hsc_dflags, hsc_logger)
@@ -28,9 +31,10 @@ import GHC.StgToCmm.Utils
  import GHC.StgToCmm.CgUtils (CgStream)
  import GHC.Types.IPE (InfoTableProvMap (provInfoTables), IpeSourceLocation)
  import GHC.Types.Name.Set (NonCaffySet)
 +import GHC.Types.SrcLoc (srcSpanFile)
  import GHC.Types.Tickish (GenTickish (SourceNote))
  import GHC.Unit.Types (Module, moduleName)
 -import GHC.Unit.Module (moduleNameString)
 +import GHC.Unit.Module (moduleNameString, ModLocation, ml_hs_file)
  import qualified GHC.Utils.Logger as Logger
  import GHC.Utils.Outputable (ppr)
  import GHC.Types.Unique.DSM
@@ -257,11 +261,12 @@ generateCgIPEStub hsc_env this_mod denv (nonCaffySet, moduleLFInfos, infoTablesW
  -- performance suffered considerably as a result (see #23103).
  lookupEstimatedTicks
    :: HscEnv
 +  -> ModLocation -- ^ location of the module being compiled, for IPE provenance
    -> Map CmmInfoTable (Maybe IpeSourceLocation)
    -> IPEStats
    -> CmmGroupSRTs
    -> IO (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats)
 -lookupEstimatedTicks hsc_env ipes stats cmm_group_srts =
 +lookupEstimatedTicks hsc_env mod_location ipes stats cmm_group_srts =
      -- Pass 2: Create an entry in the IPE map for every info table listed in
      -- this CmmGroupSRTs. If the info table is a stack info table and
      -- -finfo-table-map-with-stack is enabled, look up its estimated source
@@ -276,19 +281,24 @@ lookupEstimatedTicks hsc_env ipes stats cmm_group_srts =
      dflags = hsc_dflags hsc_env
      platform = targetPlatform dflags
 -    -- Pass 1: Map every label meeting the conditions described in Note
 -    -- [Stacktraces from Info Table Provenance Entries (IPE based stack
 -    -- unwinding)] to the estimated source location (also as described in the
 -    -- aformentioned note)
 +    -- Source file of the module being compiled, used to prefer current-module
 +    -- source ticks for return frames. See Note [Prefer current-module source
 +    -- ticks for return frames].
 +    mb_src_file = mkFastString <$> ml_hs_file mod_location
++
 +    -- Pass 1: Map every label meeting the conditions described in
 +    -- Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]
 +    -- to the estimated source location (also as described in the aformentioned
 +    -- note).
      --
      -- Note: It's important that this remains a thunk so we do not compute this
      -- map if -fno-info-table-with-stack is given
      labelsToSources :: Map CLabel IpeSourceLocation
      labelsToSources =
        if platformTablesNextToCode platform then
 -        foldl' labelsToSourcesWithTNTC Map.empty cmm_group_srts
 +        foldl' (labelsToSourcesWithTNTC mb_src_file) Map.empty cmm_group_srts
        else
 -        foldl' labelsToSourcesSansTNTC Map.empty cmm_group_srts
 +        foldl' (labelsToSourcesSansTNTC mb_src_file) Map.empty cmm_group_srts
      collectInfoTables
        :: (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats)
@@ -331,15 +341,16 @@ lookupEstimatedTicks hsc_env ipes stats cmm_group_srts =
  -- | See Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]
  labelsToSourcesWithTNTC
 -  :: Map CLabel IpeSourceLocation
 +  :: Maybe FastString -- ^ source file of the module being compiled
 +  -> Map CLabel IpeSourceLocation
    -> GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph
    -> Map CLabel IpeSourceLocation
 -labelsToSourcesWithTNTC acc (CmmProc _ _ _ cmm_graph) =
 +labelsToSourcesWithTNTC mb_src_file acc (CmmProc _ _ _ cmm_graph) =
      foldl' go acc (toBlockList cmm_graph)
    where
      go :: Map CLabel IpeSourceLocation -> CmmBlock -> Map CLabel IpeSourceLocation
      go acc block =
 -        case (,) <$> returnFrameLabel <*> lastTickInBlock of
 +        case (,) <$> returnFrameLabel <*> bestTickInBlock of
            Just (clabel, src_loc) -> Map.insert clabel src_loc acc
            Nothing -> acc
        where
@@ -351,36 +362,135 @@ labelsToSourcesWithTNTC acc (CmmProc _ _ _ cmm_graph) =
              (CmmCall _ (Just l) _ _ _ _) -> Just $ mkAsmTempLabel l
              _ -> Nothing
 -        lastTickInBlock = foldr maybeTick Nothing (blockToList middleBlock)
 +        -- All SourceNotes in the block, in block order.
 +        -- See Note [Prefer current-module source ticks for return frames].
 +        bestTickInBlock = preferThisFile mb_src_file procFallback (blockToList middleBlock)
++
 +    -- Enclosing current-module note for the whole proc (its function's own
 +    -- span), used when a return frame's own block has no current-module tick.
 +    procFallback = enclosingThisFileTick mb_src_file (toBlockList cmm_graph)
 +labelsToSourcesWithTNTC _ acc _ = acc
++
 +{-
 +Note [Prefer current-module source ticks for return frames]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +A return frame's source location is taken from the `SourceNote`s of the block
 +that *ends* in the frame's call (see
 +Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding]
 +above and `labelsToSourcesWithTNTC`). At `-O`, inlining means such a
 +block frequently carries `SourceNote`s for inlined library glue (`>>`, `>>=`,
 +`threadDelay`, ...) and the *nearest* note — the one historically chosen — is
 +often a library note rather than the user's code. The resulting IPE entry then
 +points at the library (its file and label; see `toCgIPE` in
 +GHC.StgToCmm.InfoTableProv, which takes the file from the note's own span), so a
 +backtrace of a thread blocked in such a primop shows no user frames.
++
 +For a concrete example, compile (at -O1)
++
 +    -- Scan.hs
 +    f3 :: IO ()
 +    f3 = threadDelay 1000000 >> putStrLn "done"
++
 +The body of `f3` reaches the inlined `threadDelay`'s internal `delay#` in a
 +block whose notes are *all* from `Conc.IO`/`Base` — the user's `Scan.hs` tick
 +for `f3` sits only in the proc's entry block:
++
 +    entry:                                    -- the proc's entry block
 +        //tick src<.../Base.hs:2306:5-18>
 +        //tick src<Scan.hs:13:1-43>           -- the enclosing `f3` span
 +        //tick src<.../Conc/IO.hs:(223,1)-(235,10)>
 +        ...
 +    delayBlk:                                 -- no Scan.hs note here:
 +        //tick src<.../Conc/IO.hs:232:5-13>
 +        //tick src<.../Base.hs:2268:1-9>
 +        //tick src<.../Conc/IO.hs:(232,25)-(235,10)>   -- nearest note
 +        call stg_delay#(R1) returns to delayCont, args: 8, res: 8, upd: 8;
++
 +Naively taking the nearest note attributes `delayCont` to `Conc/IO.hs:232`,
 +i.e. an internal of `threadDelay`, rather than `f3`.
++
 +To fix this we attribute a return frame's source location in the following
 +preference order:
++
 +  1. the nearest tick in the frame's block whose file is that of the module
 +     being compiled - the precise user call site. (When the user makes a
 +     blocking call directly, e.g. `f v = takeMVar v`, such a note is present in
 +     the call's block and this rule suffices; the `delayBlk` above has none.)
 +  2. failing that, the proc's *enclosing* current-module note (the outermost
 +     current-module `SourceNote` in the proc, i.e. its function's own span).
 +     For `f3` this is `src<Scan.hs:13:1-43>`, so `delayCont` is attributed to
 +     `f3` rather than to `threadDelay`'s internals.
 +  3. failing that, the nearest note of any module (the historical behaviour).
++
 +This mirrors the same-file preference the DWARF path uses in
 +`GHC.Cmm.DebugBlock.bestSrcTick` and that `GHC.Stg.Debug.quickSourcePos` uses
 +for closures.
 +-}
 -        maybeTick :: CmmNode O O -> Maybe IpeSourceLocation -> Maybe IpeSourceLocation
 -        maybeTick _ s@(Just _) = s
 -        maybeTick (CmmTick (SourceNote span name)) Nothing = Just (span, name)
 -        maybeTick _ _ = Nothing
 -labelsToSourcesWithTNTC acc _ = acc
 +-- | Pick the 'IpeSourceLocation' to attribute to a return frame from the
 +-- source-note-bearing nodes of its block (in block order).
 +--
 +-- See Note [Prefer current-module source ticks for return frames].
 +preferThisFile :: Maybe FastString -> Maybe IpeSourceLocation -> [CmmNode O O] -> Maybe IpeSourceLocation
 +preferThisFile mb_src_file procFallback nodes =
 +    nearest fromThisFile <|> procFallback <|> nearest sourceNotes
 +  where
 +    sourceNotes = [ (span, name) | CmmTick (SourceNote span name) <- nodes ]
 +    fromThisFile = case mb_src_file of
 +      Just f  -> filter ((== f) . srcSpanFile . fst) sourceNotes
 +      Nothing -> []
 +    nearest = listToMaybe . reverse
++
 +-- | The outermost 'SourceNote' from the module being compiled across a proc's
 +-- blocks (in 'toBlockList' order, so the entry block's note — the function's own
 +-- span — comes first). Used as a fallback so inlined cross-module code is still
 +-- labelled with the enclosing user function. 'Nothing' when the proc has no
 +-- current-module note (e.g. when compiling the library itself).
 +enclosingThisFileTick :: Maybe FastString -> [CmmBlock] -> Maybe IpeSourceLocation
 +enclosingThisFileTick mb_src_file blocks =
 +    listToMaybe
 +      [ (span, name)
 +      | b <- blocks
 +      , let (_, mid, _) = blockSplit b
 +      , CmmTick (SourceNote span name) <- blockToList mid
 +      , Just (srcSpanFile span) == mb_src_file ]
  -- | See Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]
  labelsToSourcesSansTNTC
 -  :: Map CLabel IpeSourceLocation
 +  :: Maybe FastString -- ^ source file of the module being compiled
 +  -> Map CLabel IpeSourceLocation
    -> GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph
    -> Map CLabel IpeSourceLocation
 -labelsToSourcesSansTNTC acc (CmmProc _ _ _ cmm_graph) =
 +labelsToSourcesSansTNTC mb_src_file acc (CmmProc _ _ _ cmm_graph) =
      foldl' go acc (toBlockList cmm_graph)
    where
 +    -- See 'enclosingThisFileTick'.
 +    procFallback = enclosingThisFileTick mb_src_file (toBlockList cmm_graph)
++
      go :: Map CLabel IpeSourceLocation -> CmmBlock -> Map CLabel IpeSourceLocation
 -    go acc block = fst $ foldl' collectLabels (acc, Nothing) (blockToList middleBlock)
 +    go acc block = fst $ foldl' collectLabels (acc, (Nothing, Nothing)) (blockToList middleBlock)
        where
          (_, middleBlock, _) = blockSplit block
 +        -- We track the nearest preceding SourceNote from the module being
 +        -- compiled and the nearest of any module, and prefer the former (then
 +        -- the proc's enclosing current-module note) when attributing a return
 +        -- frame. See Note [Prefer current-module source ticks for return frames].
          collectLabels
 -          :: (Map CLabel IpeSourceLocation, Maybe IpeSourceLocation)
 +          :: (Map CLabel IpeSourceLocation, (Maybe IpeSourceLocation, Maybe IpeSourceLocation))
            -> CmmNode O O
 -          -> (Map CLabel IpeSourceLocation, Maybe IpeSourceLocation)
 -        collectLabels (!acc, lastTick) b =
 -          case (b, lastTick) of
 -            (CmmStore _ (CmmLit (CmmLabel l)) _, Just src_loc) ->
 -              (Map.insert l src_loc acc, Nothing)
 -            (CmmTick (SourceNote span name), _) ->
 -              (acc, Just (span, name))
 -            _ -> (acc, lastTick)
 -labelsToSourcesSansTNTC acc _ = acc
 +          -> (Map CLabel IpeSourceLocation, (Maybe IpeSourceLocation, Maybe IpeSourceLocation))
 +        collectLabels (!acc, st@(lastThis, lastAny)) b =
 +          case b of
 +            CmmStore _ (CmmLit (CmmLabel l)) _ ->
 +              case lastThis <|> procFallback <|> lastAny of
 +                Just src_loc -> (Map.insert l src_loc acc, (Nothing, Nothing))
 +                Nothing      -> (acc, st)
 +            CmmTick (SourceNote span name) ->
 +              let tick = (span, name)
 +                  lastThis'
 +                    | Just (srcSpanFile span) == mb_src_file = Just tick
 +                    | otherwise                              = lastThis
 +              in (acc, (lastThis', Just tick))
 +            _ -> (acc, st)
 +labelsToSourcesSansTNTC _ acc _ = acc

compiler/GHC/Driver/Main/Compile.hs

@@ -699,7 +699,7 @@ hscGenHardCode hsc_env cgguts mod_loc output_filename = do
              _          ->
                do
                cmms <- {-# SCC "StgToCmm" #-}
 -                doCodeGen hsc_env this_mod denv tycons
 +                doCodeGen hsc_env this_mod mod_loc denv tycons
                  cost_centre_info
                  stg_binds
@@ -956,14 +956,17 @@ This reduces residency towards the end of the CodeGen phase significantly
  (5-10%).
  -}
 -doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]
 +doCodeGen :: HscEnv -> Module
 +          -> ModLocation -- ^ location of the module being compiled, used to
 +                         -- prefer current-module IPE source locations
 +          -> InfoTableProvMap -> [TyCon]
            -> CollectedCCs
            -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs
            -> IO (CgStream CmmGroupSRTs CmmCgInfos)
           -- Note we produce a 'Stream' of CmmGroups, so that the
           -- backend can be run incrementally.  Otherwise it generates all
           -- the C-- up front, which has a significant space cost.
 -doCodeGen hsc_env this_mod denv tycons
 +doCodeGen hsc_env this_mod mod_location denv tycons
                cost_centre_info stg_binds_w_fvs = do
      let dflags     = hsc_dflags hsc_env
          logger     = hsc_logger hsc_env
@@ -1032,7 +1035,7 @@ doCodeGen hsc_env this_mod denv tycons
            -- Positions] in GHC.Stg.Debug.
            (ipes', stats') <-
              if (gopt Opt_InfoTableMap dflags) then
 -              liftIO $ lookupEstimatedTicks hsc_env ipes stats cmm_srts
 +              liftIO $ lookupEstimatedTicks hsc_env mod_location ipes stats cmm_srts
              else
                return (ipes, stats)

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/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

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

 +{-# 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

 +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

+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, [''])

testsuite/tests/rts/ipe/T27408.hs

 +module Main where
++
 +import GHC.Stack.CloneStack (StackEntry(..), cloneMyStack, decode)
++
 +userFunction :: IO [StackEntry]
 +userFunction = do
 +  putStr ""
 +  stk <- cloneMyStack
 +  putStr ""
 +  es <- decode stk
 +  putStr ""
 +  return es
++
 +main :: IO ()
 +main = do
 +  entries <- userFunction
 +  let ours = filter ((== "Main") . moduleName) entries
 +  mapM_ (\e -> putStrLn (moduleName e ++ "\t" ++ functionName e)) ours

testsuite/tests/rts/ipe/T27408.stdout

 +Main
 +Main	main
 +Main	userFunction

testsuite/tests/rts/ipe/all.T

@@ -4,6 +4,16 @@ def noCapabilityOutputFilter(s):
  test('ipeMap', [extra_files(['ipe_lib.c', 'ipe_lib.h']), c_src, omit_ghci], compile_and_run, ['ipe_lib.c'])
 +# Return frames whose Cmm block is dominated by inlined library ticks (e.g. the
 +# (>>)/(>>=) of a user do-block at -O) should still be attributed to the user's
 +# module. See Note [Prefer current-module source ticks for return frames] in
 +# GHC.Driver.GenerateCgIPEStub.
 +test('T27408',
 +     [ omit_ghci          # cloneMyStack# is not available in ghci
 +     , js_broken(22261)   # cloneMyStack# not yet implemented in the JS backend
 +     ],
 +     compile_and_run, ['-O1 -finfo-table-map -g3'])
++
  # Manually create IPE entries and dump them to event log (stderr).
  test('ipeEventLog',
       [ c_src,