GitLab

87ed8632

by Ben Gamari at 2026-06-29T10:03:00-04:00

base: Introduce ThrownFrom ExceptionAnnotation

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

 +section: base
 +synopsis: Introduce `ThrownFrom` `ExceptionAnnotation`
 +issues: #27453
 +mrs: !16187
 +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>`).
 +}

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

@@ -40,6 +40,7 @@ module Control.Exception
       NoBacktrace(..),
       ExceptionWithContext(..),
       WhileHandling(..),
 +     ThrownFrom(..),
       -- * Concrete exception types
       IOException,

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

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

@@ -478,8 +478,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 (ThreadId tid) ex
 +  | backtraceDesired ex = do
 +    bts <- ThrownFrom <$> collectBacktraces
 +    throwTo_ $ addExceptionContext bts $ toException ex
 +  | otherwise =
 +    throwTo_ $ 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

@@ -115,6 +115,7 @@ module GHC.Internal.Control.Exception (
          ExceptionContext(..),
          annotateIO,
          WhileHandling(..),
 +        ThrownFrom(..),
    ) where

@@ -43,6 +43,8 @@ module GHC.Internal.Exception.Type
           -- * Exception propagation
         , WhileHandling(..)
         , whileHandling
 +         -- * Asynchronous exception provenance
 +       , ThrownFrom(..)
           -- * Arithmetic exceptions
         , ArithException(..)
         , divZeroException, overflowException, ratioZeroDenomException
@@ -298,6 +300,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 Backtrace
++
 +instance ExceptionAnnotation ThrownFrom where
 +  displayExceptionAnnotation (ThrownFrom e) =
 +    "Thrown asynchronously by " ++ case lines $ displayException e of
 +      [] -> ""
 +      (l1:ls) ->
 +        unlines $ l1:[if null l then "  |" else "  | " ++ l | l <- ls]
++
++
  -- |Arithmetic exceptions.
  data ArithException
    = Overflow