[Git][ghc/ghc][wip/27657] ghc-internal: annotateSTM should use catchSTM# rather than catch#

12 Aug 2026


      Zubin pushed to branch wip/27657 at Glasgow Haskell Compiler / GHC


Commits:
3abee4bc by Zubin Duggal at 2026-08-12T16:03:46+05:30
ghc-internal: annotateSTM should use catchSTM# rather than catch#

A catch# frame inside a transaction breaks retry and async exception
delivery.

Fixes #27657

- - - - -


7 changed files:

- + changelog.d/T27657
- libraries/ghc-internal/src/GHC/Internal/STM.hs
- + testsuite/tests/concurrent/should_run/T27657a.hs
- + testsuite/tests/concurrent/should_run/T27657a.stdout
- + testsuite/tests/concurrent/should_run/T27657b.hs
- + testsuite/tests/concurrent/should_run/T27657b.stdout
- testsuite/tests/concurrent/should_run/all.T


Changes:

=====================================
changelog.d/T27657
=====================================
@@ -0,0 +1,8 @@
+section: base
+issues: #27657
+synopsis:
+  Fix ``retry`` and async exception delivery inside a ``catchSTM`` handler
+description:
+  ``catchSTM``\'s ``WhileHandling`` annotation used ``catch#``, leaving an IO
+  ``CATCH_FRAME`` inside the transaction. Use ``catchSTM#``, which is the
+  correct way to catch exceptions inside STM.


=====================================
libraries/ghc-internal/src/GHC/Internal/STM.hs
=====================================
@@ -34,7 +34,7 @@ import GHC.Internal.Exception.Context (ExceptionAnnotation)
 import GHC.Internal.Exception.Type (WhileHandling(..))
 import GHC.Internal.Maybe (Maybe(..))
 import GHC.Internal.Prim (
-    RealWorld, State#, TVar#, atomically#, catch#, catchRetry#, catchSTM#,
+    RealWorld, State#, TVar#, atomically#, catchRetry#, catchSTM#,
     newTVar#, raiseIO#, readTVar#, readTVarIO#, retry#, writeTVar#,
   )
 import GHC.Internal.Prim.PtrEq (sameTVar#)
@@ -217,7 +217,7 @@ catchSTM (STM m) handler = STM $ catchSTM# m handler'
 -- | 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)
+annotateSTM ann (STM io) = STM (catchSTM# io handler) -- not catch#, see #27657
   where
     handler se = raiseIO# (addExceptionContext ann se)
 


=====================================
testsuite/tests/concurrent/should_run/T27657a.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- A retry escaping a catchSTM handler must reach the enclosing orElse. An IO
+-- CATCH_FRAME in the way trips an assertion in findRetryFrameHelper.
+
+import Control.Exception
+import GHC.Conc
+
+main :: IO ()
+main = do
+  r <- atomically $
+         catchSTM (throwSTM (ErrorCall "boom"))
+                  (\(_ :: SomeException) -> retry)
+           `orElse` pure "T27657a: completed"
+  putStrLn r


=====================================
testsuite/tests/concurrent/should_run/T27657a.stdout
=====================================
@@ -0,0 +1 @@
+T27657a: completed


=====================================
testsuite/tests/concurrent/should_run/T27657b.hs
=====================================
@@ -0,0 +1,40 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- An async exception delivered while a catchSTM handler runs must abort the
+-- transaction, not be swallowed by a restart of the invalidated one.
+
+import Control.Concurrent.MVar
+import Control.Exception
+import GHC.Conc
+
+waitParked :: ThreadId -> IO ()
+waitParked t = do
+  s <- threadStatus t
+  case s of
+    ThreadBlocked BlockedOnMVar -> pure ()
+    _                           -> threadDelay 1000 >> waitParked t
+
+main :: IO ()
+main = do
+  tv     <- newTVarIO (0 :: Int)
+  park   <- newEmptyMVar
+  result <- newEmptyMVar
+  t <- forkIO $ do
+    r <- try $ atomically $ do
+      v <- readTVar tv
+      catchSTM (throwSTM (ErrorCall "boom"))
+               (\(_ :: SomeException) ->
+                  if v == 0
+                    then do unsafeIOToSTM (takeMVar park)
+                            pure "handler resumed"
+                    else pure "transaction restarted, exception dropped")
+    putMVar result (r :: Either SomeException String)
+  -- parked in the handler, so t cannot revalidate its trec before delivery
+  waitParked t
+  atomically (writeTVar tv 1)
+  killThread t
+  r <- takeMVar result
+  putStrLn $ case r of
+    Left e | Just ThreadKilled <- fromException e -> "T27657b: killThread delivered"
+           | otherwise -> "T27657b: unexpected exception: " ++ displayException e
+    Right s -> "T27657b: FAILED, " ++ s


=====================================
testsuite/tests/concurrent/should_run/T27657b.stdout
=====================================
@@ -0,0 +1 @@
+T27657b: killThread delivered


=====================================
testsuite/tests/concurrent/should_run/all.T
=====================================
@@ -338,3 +338,6 @@ test('T27105_fail',
       extra_run_opts('+RTS -C0.2 -RTS'), expect_fail,
       run_timeout_multiplier(0.05)],
      multimod_compile_and_run, ['T27105.hs', ''])
+
+test('T27657a', normal, compile_and_run, [''])
+test('T27657b', normal, compile_and_run, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3abee4bc8a56ceecb13405983f189794...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3abee4bc8a56ceecb13405983f189794...
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

    

Zubin (＠wz1000)

tags

participants (1)