Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

7 changed files:

Changes:

  • changelog.d/T27657
    1 
    +section: base
    2 
    +issues: #27657
    3 
    +mrs: !16508
    4 
    +synopsis:
    5 
    +  Fix ``retry`` and async exception delivery inside a ``catchSTM`` handler
    6 
    +description:
    7 
    +  ``catchSTM``\'s ``WhileHandling`` annotation used ``catch#``, leaving an IO
    8 
    +  ``CATCH_FRAME`` inside the transaction. Use ``catchSTM#``, which is the
    9 
    +  correct way to catch exceptions inside STM.

  • libraries/ghc-internal/src/GHC/Internal/STM.hs
    ... ... @@ -31,7 +31,7 @@ import GHC.Internal.Exception.Context (ExceptionAnnotation)
    31 31 
     import GHC.Internal.Exception.Type (WhileHandling(..))
    32 32 
     import GHC.Internal.Maybe (Maybe(..))
    33 33 
     import GHC.Internal.Prim (
    34 
    -    RealWorld, State#, TVar#, atomically#, catch#, catchRetry#, catchSTM#,
    34 
    +    RealWorld, State#, TVar#, atomically#, catchRetry#, catchSTM#,
    35 35 
         newTVar#, raiseIO#, readTVar#, readTVarIO#, retry#, writeTVar#,
    36 36 
       )
    37 37 
     import GHC.Internal.Prim.PtrEq (sameTVar#)
    ... ... @@ -213,7 +213,7 @@ catchSTM (STM m) handler = STM $ catchSTM# m handler'
    213 213 
     -- | Execute an 'STM' action, adding the given 'ExceptionContext'
    214 214 
     -- to any thrown synchronous exceptions.
    215 215 
     annotateSTM :: forall e a. ExceptionAnnotation e => e -> STM a -> STM a
    216 
    -annotateSTM ann (STM io) = STM (catch# io handler)
    216 
    +annotateSTM ann (STM io) = STM (catchSTM# io handler) -- not catch#, see #27657
    217 217 
       where
    218 218 
         handler se = raiseIO# (addExceptionContext ann se)
    219 219

  • testsuite/tests/concurrent/should_run/T27657a.hs
    1 
    +{-# LANGUAGE ScopedTypeVariables #-}
    2 
    +
    3 
    +-- A retry escaping a catchSTM handler must reach the enclosing orElse. An IO
    4 
    +-- CATCH_FRAME in the way trips an assertion in findRetryFrameHelper.
    5 
    +
    6 
    +import Control.Exception
    7 
    +import GHC.Conc
    8 
    +
    9 
    +main :: IO ()
    10 
    +main = do
    11 
    +  r <- atomically $
    12 
    +         catchSTM (throwSTM (ErrorCall "boom"))
    13 
    +                  (\(_ :: SomeException) -> retry)
    14 
    +           `orElse` pure "T27657a: completed"
    15 
    +  putStrLn r

  • testsuite/tests/concurrent/should_run/T27657a.stdout
    1 
    +T27657a: completed

  • testsuite/tests/concurrent/should_run/T27657b.hs
    1 
    +{-# LANGUAGE ScopedTypeVariables #-}
    2 
    +
    3 
    +-- An async exception delivered while a catchSTM handler runs must abort the
    4 
    +-- transaction, not be swallowed by a restart of the invalidated one.
    5 
    +
    6 
    +import Control.Concurrent.MVar
    7 
    +import Control.Exception
    8 
    +import GHC.Conc
    9 
    +
    10 
    +waitParked :: ThreadId -> IO ()
    11 
    +waitParked t = do
    12 
    +  s <- threadStatus t
    13 
    +  case s of
    14 
    +    ThreadBlocked BlockedOnMVar -> pure ()
    15 
    +    _                           -> threadDelay 1000 >> waitParked t
    16 
    +
    17 
    +main :: IO ()
    18 
    +main = do
    19 
    +  tv     <- newTVarIO (0 :: Int)
    20 
    +  park   <- newEmptyMVar
    21 
    +  result <- newEmptyMVar
    22 
    +  t <- forkIO $ do
    23 
    +    r <- try $ atomically $ do
    24 
    +      v <- readTVar tv
    25 
    +      catchSTM (throwSTM (ErrorCall "boom"))
    26 
    +               (\(_ :: SomeException) ->
    27 
    +                  if v == 0
    28 
    +                    then do unsafeIOToSTM (takeMVar park)
    29 
    +                            pure "handler resumed"
    30 
    +                    else pure "transaction restarted, exception dropped")
    31 
    +    putMVar result (r :: Either SomeException String)
    32 
    +  -- parked in the handler, so t cannot revalidate its trec before delivery
    33 
    +  waitParked t
    34 
    +  atomically (writeTVar tv 1)
    35 
    +  killThread t
    36 
    +  r <- takeMVar result
    37 
    +  putStrLn $ case r of
    38 
    +    Left e | Just ThreadKilled <- fromException e -> "T27657b: killThread delivered"
    39 
    +           | otherwise -> "T27657b: unexpected exception: " ++ displayException e
    40 
    +    Right s -> "T27657b: FAILED, " ++ s

  • testsuite/tests/concurrent/should_run/T27657b.stdout
    1 
    +T27657b: killThread delivered

  • testsuite/tests/concurrent/should_run/all.T
    ... ... @@ -340,3 +340,6 @@ test('T27105_fail',
    340 340 
           extra_run_opts('+RTS -C0.2 -RTS'), expect_fail,
    341 341 
           run_timeout_multiplier(0.05)],
    342 342 
          multimod_compile_and_run, ['T27105.hs', ''])
    343 
    +
    344 
    +test('T27657a', normal, compile_and_run, [''])
    345 
    +test('T27657b', normal, compile_and_run, [''])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/commit/fd22f71ee92595f4634206455d8eab111488d836 at 1787771448