[Git][ghc/ghc][wip/clc-430] base: Introduce ThrownFrom ExceptionAnnotation

29 Jun 2026

Ben Gamari pushed to branch wip/clc-430 at Glasgow Haskell Compiler / GHC


Commits:
04e8e9c4 by Ben Gamari at 2026-06-29T11:25:15-04:00
base: Introduce ThrownFrom ExceptionAnnotation

CLC Proposal: https://github.com/haskell/core-libraries-committee/issues/430

- - - - -


9 changed files:

- + changelog.d/T27453
- libraries/base/changelog.md
- libraries/base/src/Control/Exception.hs
- + libraries/base/tests/T27453.hs
- libraries/base/tests/all.T
- libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs
- libraries/ghc-internal/src/GHC/Internal/Control/Exception.hs
- libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs-boot
- libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs


Changes:

=====================================
changelog.d/T27453
=====================================
@@ -0,0 +1,7 @@
+section: base
+synopsis: Introduce `ThrownFrom` `ExceptionAnnotation`
+issues: #27453
+mrs: !16273
+description: {
+  Introduce new ``ExceptionAnnotation``, ``Control.Exception.ThrownFrom``, to record a backtrace of the site from which an asynchronous exception was thrown. ``Control.Exception.throwTo`` now attaches such an annotation when throwing exceptions for which ``backtraceDesired=True``. :ref:`CLC Proposal #430 https://github.com/haskell/core-libraries-committee/issues/430`).
+}


=====================================
libraries/base/changelog.md
=====================================
@@ -35,6 +35,7 @@
   * Change `hIsReadable` and `hIsWritable` such that they always throw a respective exception when encountering a closed or semi-closed handle, not just in the case of a file handle. ([CLC proposal #371](github.com/haskell/core-libraries-committee/issues/371))
   * Annotate `onException` continuation with `WhileHandling`. ([CLC Proposal #397](https://github.com/haskell/core-libraries-committee/issues/397))
   * Improve error message for `Data.Char.chr`. ([CLC Proposal #384](https://github.com/haskell/core-libraries-committee/issues/384))
+  * Introduce new `ExceptionAnnotation`, `Control.Exception.ThrownFrom`, to record a backtrace of the site from which an asynchronous exception was thrown. `Control.Exception.throwTo` now attaches such an annotation when throwing exceptions for which `backtraceDesired=True`. ([CLC Proposal #430](https://github.com/haskell/core-libraries-committee/issues/430)).
 
 ## 4.22.0.0 *TBA*
   * Shipped with GHC 9.14.1


=====================================
libraries/base/src/Control/Exception.hs
=====================================
@@ -40,6 +40,7 @@ module Control.Exception
      NoBacktrace(..),
      ExceptionWithContext(..),
      WhileHandling(..),
+     ThrownFrom(..),
 
      -- * Concrete exception types
      IOException,


=====================================
libraries/base/tests/T27453.hs
=====================================
@@ -0,0 +1,19 @@
+module Main where
+
+import Control.Exception
+
+data WorldExploded = WorldExploded
+  deriving (Show)
+
+instance Exception WorldExploded
+
+main :: IO ()
+main = do
+  tid <- fork $ catch handler $ threadDelay 1000*1000*1000
+  throwTo WorldExploded tid
+
+handler :: ExceptionWithContext WorldExploded -> IO ()
+handler (ExceptionWithContext ann WorldExploded) = do
+  putStrLn "killed from"
+  print ann
+


=====================================
libraries/base/tests/all.T
=====================================
@@ -322,3 +322,4 @@ test('T23697',
 test('stimesEndo', normal, compile_and_run, [''])
 test('T24807', exit_code(1), compile_and_run, [''])
 test('T25066', [only_ways(['optasm']), grep_errmsg('T25066.g')], compile, ['-ddump-dmd-signatures'])
+test('T27453', normal, compile_and_run, [''])


=====================================
libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs
=====================================
@@ -105,6 +105,8 @@ import GHC.Internal.Int
 import GHC.Internal.IO
 import GHC.Internal.IO.Exception
 import GHC.Internal.Exception
+import GHC.Internal.Exception.Type (ThrownFrom(..))
+import {-# SOURCE #-} GHC.Internal.Exception.Backtrace (collectBacktraces)
 import GHC.Internal.IORef
 import GHC.Internal.Magic ( lazy )
 import GHC.Internal.Maybe ( Maybe(..) )
@@ -478,8 +480,16 @@ target, the exception will be thrown even if the thread is currently
 inside 'mask' or 'uninterruptibleMask'.
   -}
 throwTo :: Exception e => ThreadId -> e -> IO ()
-throwTo (ThreadId tid) ex = IO $ \ s ->
-   case (killThread# tid (toException ex) s) of s1 -> (# s1, () #)
+throwTo tid ex
+  | backtraceDesired ex = do
+    bts <- collectBacktraces
+    throwTo_ tid $ addExceptionContext (ThrownFrom bts) (toException ex)
+  | otherwise =
+    throwTo_ tid $ toException ex
+
+throwTo_ :: Exception e => ThreadId -> e -> IO ()
+throwTo_ (ThreadId tid) ex = IO $ \ s ->
+   case (killThread# tid ex s) of s1 -> (# s1, () #)
 
 -- | Returns the 'ThreadId' of the calling thread (GHC only).
 myThreadId :: IO ThreadId


=====================================
libraries/ghc-internal/src/GHC/Internal/Control/Exception.hs
=====================================
@@ -115,11 +115,12 @@ module GHC.Internal.Control.Exception (
         ExceptionContext(..),
         annotateIO,
         WhileHandling(..),
+        ThrownFrom(..),
 
   ) where
 
 import GHC.Internal.Control.Exception.Base
-import GHC.Internal.Exception.Type (ExceptionWithContext(..), whileHandling)
+import GHC.Internal.Exception.Type (ExceptionWithContext(..), whileHandling, ThrownFrom(..))
 
 import GHC.Internal.Base (Functor(..), foldr, return, ($), (.))
 import GHC.Internal.IO (IO, interruptible)


=====================================
libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs-boot
=====================================
@@ -1,11 +1,19 @@
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ImplicitParams #-}
 {-# LANGUAGE RoleAnnotations #-}
 
 module GHC.Internal.Exception.Backtrace where
 
 import GHC.Internal.Stack.Types (HasCallStack)
 import GHC.Internal.Types (IO)
-import GHC.Internal.Exception.Context (SomeExceptionAnnotation)
+import GHC.Internal.Exception.Context (ExceptionAnnotation, SomeExceptionAnnotation)

--- For GHC.Exception
+data Backtraces
+
+instance ExceptionAnnotation Backtraces
+
+-- For GHC.Internal.Conc.Sync
+collectBacktraces :: HasCallStack => IO Backtraces
+
+-- For GHC.Internal.Exception
 collectExceptionAnnotation :: HasCallStack => IO SomeExceptionAnnotation


=====================================
libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs
=====================================
@@ -43,6 +43,8 @@ module GHC.Internal.Exception.Type
          -- * Exception propagation
        , WhileHandling(..)
        , whileHandling
+         -- * Asynchronous exception provenance
+       , ThrownFrom(..)
          -- * Arithmetic exceptions
        , ArithException(..)
        , divZeroException, overflowException, ratioZeroDenomException
@@ -59,6 +61,7 @@ import GHC.Internal.Base (String, Void, fmap, return, ($), (.), (++))
 import GHC.Internal.Show
 import GHC.Internal.Types (Bool(..))
 import GHC.Internal.Exception.Context
+import {-# SOURCE #-} GHC.Internal.Exception.Backtrace
 
 {- |
 A constraint used to propagate 'ExceptionContext's.
@@ -298,6 +301,19 @@ instance Exception a => Exception (ExceptionWithContext a) where
     backtraceDesired (ExceptionWithContext _ e) = backtraceDesired e
     displayException = displayException . toException
 
+-- | 'ThrownBy' records the site from which an asynchronous exception was thrown (e.g. the call-site of @throwTo@).
+--
+-- @since 4.23.0.0
+newtype ThrownFrom = ThrownFrom Backtraces
+
+instance ExceptionAnnotation ThrownFrom where
+  displayExceptionAnnotation (ThrownFrom e) =
+    "Thrown asynchronously by " ++ case lines $ displayExceptionAnnotation e of
+      [] -> ""
+      (l1:ls) ->
+        unlines $ l1:[if null l then "  |" else "  | " ++ l | l <- ls]
+
+
 -- |Arithmetic exceptions.
 data ArithException
   = Overflow



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/04e8e9c42a696d72613c3c00ac63d145...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/04e8e9c42a696d72613c3c00ac63d145...
You're receiving this email because of your account on gitlab.haskell.org.

    

Ben Gamari (＠bgamari)

tags

participants (1)