[Git][ghc/ghc][wip/annotate-frame] Implement annotateIO and annotateSTM via stack annotations instead of catch and rethrow

11 Aug 2026


      Zubin pushed to branch wip/annotate-frame at Glasgow Haskell Compiler / GHC


Commits:
8229e600 by Zubin Duggal at 2026-08-11T13:39:51+05:30
Implement annotateIO and annotateSTM via stack annotations instead of catch and rethrow

Fixes #26368
Fixes #27657

- - - - -


7 changed files:

- libraries/ghc-internal/src/GHC/Internal/Exception.hs
- libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
- libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs-boot
- libraries/ghc-internal/src/GHC/Internal/IO.hs
- libraries/ghc-internal/src/GHC/Internal/STM.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs


Changes:

=====================================
libraries/ghc-internal/src/GHC/Internal/Exception.hs
=====================================
@@ -75,7 +75,7 @@ import GHC.Internal.Stack.Types
 import GHC.Internal.Types (IO, RuntimeRep)
 import GHC.Internal.IO.Unsafe
 import {-# SOURCE #-} GHC.Internal.Stack (prettyCallStackLines, prettyCallStack, prettySrcLoc, withFrozenCallStack)
-import {-# SOURCE #-} GHC.Internal.Exception.Backtrace (collectExceptionAnnotation)
+import {-# SOURCE #-} GHC.Internal.Exception.Backtrace (collectExceptionContext)
 import GHC.Internal.Exception.Context (SomeExceptionAnnotation(..))
 import GHC.Internal.Exception.Type
 
@@ -175,11 +175,13 @@ throw e =
 --  @since base-4.20.0.0
 toExceptionWithBacktrace :: (HasCallStack, Exception e)
                          => e -> IO SomeException
-toExceptionWithBacktrace e
-  | backtraceDesired e = do
-      SomeExceptionAnnotation ea <- collectExceptionAnnotation
-      return (addExceptionContext ea (toException e))
-  | otherwise = return (toException e)
+toExceptionWithBacktrace e = do
+    anns <- collectExceptionContext (backtraceDesired e)
+    return (applyAnns anns (toException e))
+  where
+    applyAnns [] se = se
+    applyAnns (SomeExceptionAnnotation a : rest) se =
+      applyAnns rest (addExceptionContext a se)
 
 -- | This is thrown when the user calls 'error'. The @String@ is the
 -- argument given to 'error'.


=====================================
libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
=====================================
@@ -16,6 +16,8 @@ import GHC.Internal.Maybe (Maybe(..))
 import GHC.Internal.Ptr
 import GHC.Internal.Data.Maybe (fromMaybe, mapMaybe)
 import GHC.Internal.Stack.Types as GHC.Stack (CallStack, HasCallStack)
+import GHC.Internal.Stack.Annotation (SomeStackAnnotation(..))
+import GHC.Internal.Data.Typeable (cast)
 import qualified GHC.Internal.Stack as HCS
 import qualified GHC.Internal.ExecutionStack.Internal as ExecStack
 import qualified GHC.Internal.Stack.CloneStack as CloneStack
@@ -94,12 +96,12 @@ setBacktraceMechanismState bm enabled = do
 -- | How to collect 'ExceptionAnnotation's on throwing 'Exception's.
 --
 data CollectExceptionAnnotationMechanism = CollectExceptionAnnotationMechanism
-  { ceaCollectExceptionAnnotationMechanism :: HasCallStack => IO SomeExceptionAnnotation
+  { ceaCollectExceptionAnnotationMechanism :: HasCallStack => CloneStack.StackSnapshot -> IO SomeExceptionAnnotation
   }
 
 defaultCollectExceptionAnnotationMechanism :: CollectExceptionAnnotationMechanism
 defaultCollectExceptionAnnotationMechanism = CollectExceptionAnnotationMechanism
-  { ceaCollectExceptionAnnotationMechanism = SomeExceptionAnnotation `fmap` collectBacktraces
+  { ceaCollectExceptionAnnotationMechanism = \snapshot -> SomeExceptionAnnotation `fmap` collectBacktracesFrom snapshot
   }
 
 collectExceptionAnnotationMechanismRef :: IORef CollectExceptionAnnotationMechanism
@@ -117,7 +119,7 @@ getCollectExceptionAnnotationMechanism = readIORef collectExceptionAnnotationMec
 setCollectExceptionAnnotation :: ExceptionAnnotation a => (HasCallStack => IO a) -> IO ()
 setCollectExceptionAnnotation collector = do
   let cea = CollectExceptionAnnotationMechanism
-        { ceaCollectExceptionAnnotationMechanism = fmap SomeExceptionAnnotation collector
+        { ceaCollectExceptionAnnotationMechanism = \_ -> fmap SomeExceptionAnnotation collector
         }
   _ <- atomicModifyIORef'_ collectExceptionAnnotationMechanismRef (const cea)
   return ()
@@ -165,18 +167,42 @@ instance ExceptionAnnotation Backtraces where
 --
 collectExceptionAnnotation :: HasCallStack => IO SomeExceptionAnnotation
 collectExceptionAnnotation = HCS.withFrozenCallStack $ do
+  snapshot <- CloneStack.cloneMyStack
   cea <- getCollectExceptionAnnotationMechanism
-  ceaCollectExceptionAnnotationMechanism cea
+  ceaCollectExceptionAnnotationMechanism cea snapshot
+
+stackAnnotationsFrom :: CloneStack.StackSnapshot -> IO [SomeExceptionAnnotation]
+stackAnnotationsFrom snapshot = do
+  anns <- CloneStack.decodeStackAnnotations snapshot
+  return (mapMaybe (\(SomeStackAnnotation a) -> cast a) anns)
+
+collectExceptionContext :: HasCallStack => Bool -> IO [SomeExceptionAnnotation]
+collectExceptionContext backtrace_desired = HCS.withFrozenCallStack $ do
+  snapshot <- CloneStack.cloneMyStack
+  bt <- if backtrace_desired
+    then do
+      cea <- getCollectExceptionAnnotationMechanism
+      ann <- ceaCollectExceptionAnnotationMechanism cea snapshot
+      return [ann]
+    else return []
+  anns <- stackAnnotationsFrom snapshot
+  return (bt ++ anns)
 
 -- | Collect a set of 'Backtraces'.
 collectBacktraces :: (?callStack :: CallStack) => IO Backtraces
-collectBacktraces = HCS.withFrozenCallStack $ do
-    getEnabledBacktraceMechanisms >>= collectBacktraces'
+collectBacktraces = HCS.withFrozenCallStack $
+    CloneStack.cloneMyStack >>= collectBacktracesFrom
+
+collectBacktracesFrom
+    :: (?callStack :: CallStack)
+    => CloneStack.StackSnapshot -> IO Backtraces
+collectBacktracesFrom snapshot = HCS.withFrozenCallStack $ do
+    getEnabledBacktraceMechanisms >>= collectBacktraces' snapshot
 
 collectBacktraces'
     :: (?callStack :: CallStack)
-    => EnabledBacktraceMechanisms -> IO Backtraces
-collectBacktraces' enabled = HCS.withFrozenCallStack $ do
+    => CloneStack.StackSnapshot -> EnabledBacktraceMechanisms -> IO Backtraces
+collectBacktraces' snapshot enabled = HCS.withFrozenCallStack $ do
     let collect :: BacktraceMechanism -> IO (Maybe a) -> IO (Maybe a)
         collect mech f
           | backtraceMechanismEnabled mech enabled = f
@@ -189,8 +215,7 @@ collectBacktraces' enabled = HCS.withFrozenCallStack $ do
         ExecStack.collectStackTrace
 
     ipe <- collect IPEBacktrace $ do
-        stack <- CloneStack.cloneMyStack
-        return (Just stack)
+        return (Just snapshot)
 
     hcs <- collect HasCallStackBacktrace $ do
         return (Just ?callStack)


=====================================
libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs-boot
=====================================
@@ -4,8 +4,8 @@
 module GHC.Internal.Exception.Backtrace where
 
 import GHC.Internal.Stack.Types (HasCallStack)
-import GHC.Internal.Types (IO)
+import GHC.Internal.Types (Bool, IO)
 import GHC.Internal.Exception.Context (SomeExceptionAnnotation)
 
 -- For GHC.Exception
-collectExceptionAnnotation :: HasCallStack => IO SomeExceptionAnnotation
+collectExceptionContext :: HasCallStack => Bool -> IO [SomeExceptionAnnotation]


=====================================
libraries/ghc-internal/src/GHC/Internal/IO.hs
=====================================
@@ -54,8 +54,9 @@ import GHC.Internal.Classes ( Eq )
 import GHC.Internal.Magic ( lazy )
 import GHC.Internal.Maybe ( Maybe(..) )
 import GHC.Internal.Prim (
-    RealWorld, State#, catch#, getMaskingState#, maskAsyncExceptions#,
-    maskUninterruptible#, raiseIO#, unmaskAsyncExceptions#,
+    RealWorld, State#, annotateStack#, catch#, getMaskingState#,
+    maskAsyncExceptions#, maskUninterruptible#, raiseIO#,
+    unmaskAsyncExceptions#,
   )
 import GHC.Internal.ST
 import GHC.Internal.Types ( Char, IO(..) )
@@ -65,7 +66,8 @@ import GHC.Internal.Show
 import GHC.Internal.IO.Unsafe
 import GHC.Internal.Unsafe.Coerce ( unsafeCoerce )
 
-import GHC.Internal.Exception.Context ( ExceptionAnnotation )
+import GHC.Internal.Exception.Context ( ExceptionAnnotation, SomeExceptionAnnotation(..) )
+import GHC.Internal.Stack.Annotation ( SomeStackAnnotation(..) )
 import GHC.Internal.Stack.Types ( HasCallStack )
 import {-# SOURCE #-} GHC.Internal.Stack ( withFrozenCallStack )
 import {-# SOURCE #-} GHC.Internal.IO.Exception ( userError, IOError )
@@ -245,9 +247,8 @@ catchAny !(IO io) handler = IO $ catch# io handler'
 --
 -- @since base-4.20.0.0
 annotateIO :: forall e a. ExceptionAnnotation e => e -> IO a -> IO a
-annotateIO ann (IO io) = IO (catch# io handler)
-  where
-    handler se = raiseIO# (addExceptionContext ann se)
+annotateIO ann (IO io) =
+  IO (annotateStack# (SomeStackAnnotation (SomeExceptionAnnotation ann)) io)
 
 -- Using catchException here means that if `m` throws an
 -- 'IOError' /as an imprecise exception/, we will not catch


=====================================
libraries/ghc-internal/src/GHC/Internal/STM.hs
=====================================
@@ -29,16 +29,17 @@ import GHC.Internal.Base (
     Monoid(..), Semigroup(..), ap, liftM2, ($), (.),
   )
 import GHC.Internal.Classes (Eq(..))
-import GHC.Internal.Exception (Exception, toExceptionWithBacktrace, fromException, addExceptionContext)
-import GHC.Internal.Exception.Context (ExceptionAnnotation)
+import GHC.Internal.Exception (Exception, toExceptionWithBacktrace, fromException)
+import GHC.Internal.Exception.Context (ExceptionAnnotation, SomeExceptionAnnotation(..))
 import GHC.Internal.Exception.Type (WhileHandling(..))
 import GHC.Internal.Maybe (Maybe(..))
 import GHC.Internal.Prim (
-    RealWorld, State#, TVar#, atomically#, catch#, catchRetry#, catchSTM#,
-    newTVar#, raiseIO#, readTVar#, readTVarIO#, retry#, writeTVar#,
+    RealWorld, State#, TVar#, annotateStack#, atomically#, catchRetry#,
+    catchSTM#, newTVar#, raiseIO#, readTVar#, readTVarIO#, retry#, writeTVar#,
   )
 import GHC.Internal.Prim.PtrEq (sameTVar#)
 import GHC.Internal.Stack (HasCallStack, withFrozenCallStack)
+import GHC.Internal.Stack.Annotation (SomeStackAnnotation(..))
 import GHC.Internal.Types (IO(..), isTrue#)
 
 -- TVars are shared memory locations which support atomic memory
@@ -217,9 +218,8 @@ catchSTM (STM m) handler = STM $ catchSTM# m handler'
 -- | Execute an 'STM' action, adding the given 'ExceptionContext'
 -- to any thrown synchronous exceptions.
 annotateSTM :: forall e a. ExceptionAnnotation e => e -> STM a -> STM a
-annotateSTM ann (STM io) = STM (catch# io handler)
-  where
-    handler se = raiseIO# (addExceptionContext ann se)
+annotateSTM ann (STM io) =
+  STM (annotateStack# (SomeStackAnnotation (SomeExceptionAnnotation ann)) io)
 
 -- |Shared memory locations that support atomic memory transactions.
 data TVar a = TVar (TVar# RealWorld a)


=====================================
libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs
=====================================
@@ -4,8 +4,10 @@ module GHC.Internal.Stack.Annotation where
 
 import GHC.Internal.Base (String, (++))
 import GHC.Internal.Data.Typeable
+import GHC.Internal.Exception.Context (SomeExceptionAnnotation(..), ExceptionAnnotation(..))
 import GHC.Internal.Maybe (Maybe(..))
-import GHC.Internal.Stack (SrcLoc, prettySrcLoc)
+import GHC.Internal.Stack.Types (SrcLoc)
+import {-# SOURCE #-} GHC.Internal.Stack (prettySrcLoc)
 
 -- ----------------------------------------------------------------------------
 -- StackAnnotation
@@ -68,3 +70,7 @@ instance StackAnnotation SomeStackAnnotation where
 
   displayStackAnnotationShort (SomeStackAnnotation a) =
     displayStackAnnotationShort a
+
+instance StackAnnotation SomeExceptionAnnotation where
+  displayStackAnnotationShort (SomeExceptionAnnotation a) =
+    displayExceptionAnnotation a


=====================================
libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
=====================================
@@ -19,6 +19,7 @@ module GHC.Internal.Stack.Decode (
   decode,
   decodeStack,
   decodeStackWithIpe,
+  decodeStackAnnotations,
   -- * Stack decoder helpers
   decodeStackWithFrameUnpack,
   -- * StackEntry
@@ -553,6 +554,26 @@ decodeStackWithIpe :: StackSnapshot -> IO [(StackFrame, Maybe InfoProv)]
 decodeStackWithIpe snapshot =
   concat . snd <$> decodeStackWithFrameUnpack unpackStackFrameWithIpe snapshot
 
+stackFrameInfoTable :: StackSnapshot# -> WordOffset -> IO StgInfoTable
+stackFrameInfoTable stackSnapshot# index =
+  case getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index) of
+    (# itbl#, _ #) -> peekItbl (Ptr itbl#)
+
+decodeStackAnnotations :: StackSnapshot -> IO [SomeStackAnnotation]
+decodeStackAnnotations snapshot =
+  concat . snd <$> decodeStackWithFrameUnpack unpackAnnotationFrame snapshot
+
+unpackAnnotationFrame :: StackFrameLocation -> IO [SomeStackAnnotation]
+unpackAnnotationFrame (StackSnapshot stackSnapshot#, index) = do
+  itbl <- stackFrameInfoTable stackSnapshot# index
+  case tipe itbl of
+    ANN_FRAME ->
+      case getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn) of
+        Box ann -> pure [unsafeCoerce ann]
+    UNDERFLOW_FRAME ->
+      decodeStackAnnotations (getUnderflowFrameNextChunk stackSnapshot# index)
+    _ -> pure []
+
 -- ----------------------------------------------------------------------------
 -- Write your own stack decoder!
 -- ----------------------------------------------------------------------------



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8229e600861665aa4e15023f38fdb94f...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8229e600861665aa4e15023f38fdb94f...
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

    

Zubin (＠wz1000)

tags

participants (1)