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.