[Git][ghc/ghc][wip/T25365] 2 commits: base: Capture backtrace from throwSTM

[Ben Gamari (@bgamari)]

Ben Gamari pushed to branch wip/T25365 at Glasgow Haskell Compiler / GHC


Commits:
743b1d3d by Ben Gamari at 2024-10-10T17:32:33-04:00
base: Capture backtrace from throwSTM

Fixes #25365.

- - - - -
e3818c71 by Ben Gamari at 2024-10-10T17:33:09-04:00
base: Annotate rethrown exceptions in catcHSTM with WhileHandling

- - - - -


2 changed files:

- libraries/base/changelog.md
- libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs


Changes:

=====================================
libraries/base/changelog.md
=====================================
@@ -4,6 +4,8 @@
   * Restrict `Data.List.NonEmpty.unzip` to `NonEmpty (a, b) -> (NonEmpty a, NonEmpty b)`. ([CLC proposal #86](https://github.com/haskell/core-libraries-committee/issues/86))
   * Modify the implementation of `Control.Exception.throw` to avoid call-sites being inferred as diverging via precise exception.
     ([GHC #25066](https://gitlab.haskell.org/ghc/ghc/-/issues/25066), [CLC proposal #290](https://github.com/haskell/core-libraries-committee/issues/290))
+  * `GHC.Conc.throwSTM` and `GHC.Conc.Sync.throwSTM` now attach a `Backtrace` annotation to the thrown exception. ([GHC #25365](https://gitlab.haskell.org/ghc/ghc/-/issues/25365))
+  * `GHC.Conc.catchSTM` and `GHC.Conc.Sync.catchSTM` now attach `WhileHandling` annotation to exceptions thrown from the handler. ([GHC #25365](https://gitlab.haskell.org/ghc/ghc/-/issues/25365))
 
 ## 4.21.0.0 *TBA*
   * `GHC.Desugar` has been deprecated and should be removed in GHC 9.14. ([CLC proposal #216](https://github.com/haskell/core-libraries-committee/issues/216))


=====================================
libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs
=====================================
@@ -117,11 +117,14 @@ import GHC.Internal.Int
 import GHC.Internal.IO
 import GHC.Internal.IO.Exception
 import GHC.Internal.Exception
+import GHC.Internal.Exception.Context ( ExceptionAnnotation )
+import GHC.Internal.Exception.Type ( WhileHandling(..) )
 import GHC.Internal.IORef
 import GHC.Internal.MVar
 import GHC.Internal.Ptr
 import GHC.Internal.Real         ( fromIntegral )
 import GHC.Internal.Show         ( Show(..), showParen, showString )
+import GHC.Internal.Stack ( HasCallStack )
 import GHC.Internal.Weak
 import GHC.Internal.Word
 
@@ -821,8 +824,13 @@ orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s
 -- raise an exception within the 'STM' monad because it guarantees
 -- ordering with respect to other 'STM' operations, whereas 'throw'
 -- does not.
-throwSTM :: Exception e => e -> STM a
-throwSTM e = STM $ raiseIO# (toException e)
+throwSTM :: HasCallStack => Exception e => e -> STM a
+throwSTM e = do
+    -- N.B. Typically use of unsafeIOToSTM is very much frowned upon as this
+    -- is an easy way to end up with nested transactions. However, we can be
+    -- certain that toExceptionWithBacktrace will not initiate a transaction.
+    se <- unsafeIOToSTM (toExceptionWithBacktrace e)
+    STM $ raiseIO# se
 
 -- | Exception handling within STM actions.
 --
@@ -834,9 +842,16 @@ catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a
 catchSTM (STM m) handler = STM $ catchSTM# m handler'
     where
       handler' e = case fromException e of
-                     Just e' -> unSTM (handler e')
+                     Just e' -> unSTM (annotateSTM (WhileHandling e) (handler e'))
                      Nothing -> raiseIO# e
 
+-- | Execute an 'STM' action, adding the given 'ExceptionContext'
+-- to any thrown synchronous exceptions.
+annotateSTM :: forall e a. ExceptionAnnotation e => e -> STM a -> STM a
+annotateSTM ann (STM io) = STM (catch# io handler)
+  where
+    handler se = raiseIO# (addExceptionContext ann se)
+
 -- |Shared memory locations that support atomic memory transactions.
 data TVar a = TVar (TVar# RealWorld a)
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/aa61b3a25a8ae49e5f64500da3de5f555a85030e...e3818c7189531f4d398a35fe370f971a85207c40

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/aa61b3a25a8ae49e5f64500da3de5f555a85030e...e3818c7189531f4d398a35fe370f971a85207c40
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241010/43b1ea48/attachment-0001.html>