GitLab

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

 +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>`).
 +}

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

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

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

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

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