Ben Gamari pushed to branch wip/clc-430 at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 8 changed files: - + changelog.d/clc-430 - 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/Type.hs Changes: ===================================== changelog.d/clc-430 ===================================== @@ -0,0 +1,7 @@ +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>`). +} ===================================== 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 ===================================== @@ -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 ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Exception.hs ===================================== @@ -115,6 +115,7 @@ module GHC.Internal.Control.Exception ( ExceptionContext(..), annotateIO, WhileHandling(..), + ThrownFrom(..), ) where ===================================== 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 @@ -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 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/87ed863221b175cc4e9a64a2ff3af3db... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/87ed863221b175cc4e9a64a2ff3af3db... You're receiving this email because of your account on gitlab.haskell.org.