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

Commits:

7 changed files:

Changes:

  • changelog.d/T27657
    1 
    +section: base
    2 
    +issues: #27657
    3 
    +synopsis:
    4 
    +  Fix ``retry`` and async exception delivery inside a ``catchSTM`` handler
    5 
    +description:
    6 
    +  ``catchSTM``\'s ``WhileHandling`` annotation used ``catch#``, leaving an IO
    7 
    +  ``CATCH_FRAME`` inside the transaction. Use ``catchSTM#``, which is the
    8 
    +  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)
    34 34 
     import GHC.Internal.Exception.Type (WhileHandling(..))
    35 35 
     import GHC.Internal.Maybe (Maybe(..))
    36 36 
     import GHC.Internal.Prim (
    37 
    -    RealWorld, State#, TVar#, atomically#, catch#, catchRetry#, catchSTM#,
    37 
    +    RealWorld, State#, TVar#, atomically#, catchRetry#, catchSTM#,
    38 38 
         newTVar#, raiseIO#, readTVar#, readTVarIO#, retry#, writeTVar#,
    39 39 
       )
    40 40 
     import GHC.Internal.Prim.PtrEq (sameTVar#)
    ... ... @@ -217,7 +217,7 @@ catchSTM (STM m) handler = STM $ catchSTM# m handler'
    217 217 
     -- | Execute an 'STM' action, adding the given 'ExceptionContext'
    218 218 
     -- to any thrown synchronous exceptions.
    219 219 
     annotateSTM :: forall e a. ExceptionAnnotation e => e -> STM a -> STM a
    220 
    -annotateSTM ann (STM io) = STM (catch# io handler)
    220 
    +annotateSTM ann (STM io) = STM (catchSTM# io handler) -- not catch#, see #27657
    221 221 
       where
    222 222 
         handler se = raiseIO# (addExceptionContext ann se)
    223 223

  • testsuite/tests/concurrent/should_run/T27657a.hs
    1 
    +{-# LANGUAGE ScopedTypeVariables #-}
    2 
    +
    3 
    +-- A `retry` escaping a `catchSTM` handler must reach the enclosing `orElse`.
    4 
    +-- `annotateSTM` wraps the handler, so if it uses the IO `catch#` there is a
    5 
    +-- CATCH_FRAME inside the transaction and `findRetryFrameHelper` trips
    6 
    +-- ASSERT(info->i.type != CATCH_FRAME) on a debug RTS.
    7 
    +
    8 
    +import Control.Exception
    9 
    +import GHC.Conc
    10 
    +
    11 
    +main :: IO ()
    12 
    +main = do
    13 
    +  r <- atomically $
    14 
    +         catchSTM (throwSTM (ErrorCall "boom"))
    15 
    +                  (\(_ :: SomeException) -> retry)
    16 
    +           `orElse` pure "T27657a: completed"
    17 
    +  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. If `annotateSTM` wraps the handler in an IO `catch#` then
    5 
    +-- `raiseAsync` stops at that CATCH_FRAME instead of the ATOMICALLY_FRAME and
    6 
    +-- re-raises synchronously; the enclosing transaction then fails validation,
    7 
    +-- is restarted, and the exception is swallowed.
    8 
    +--
    9 
    +-- The target parks on an MVar inside the handler so that the exception is
    10 
    +-- delivered from the killer's context: the target is not scheduled between the
    11 
    +-- write to `tv` and the delivery, so `schedulePostRunThread` cannot restart the
    12 
    +-- transaction on its own and the outcome is deterministic.
    13 
    +
    14 
    +import Control.Concurrent.MVar
    15 
    +import Control.Exception
    16 
    +import GHC.Conc
    17 
    +
    18 
    +waitParked :: ThreadId -> IO ()
    19 
    +waitParked t = do
    20 
    +  s <- threadStatus t
    21 
    +  case s of
    22 
    +    ThreadBlocked BlockedOnMVar -> pure ()
    23 
    +    _                           -> threadDelay 1000 >> waitParked t
    24 
    +
    25 
    +main :: IO ()
    26 
    +main = do
    27 
    +  tv     <- newTVarIO (0 :: Int)
    28 
    +  park   <- newEmptyMVar
    29 
    +  result <- newEmptyMVar
    30 
    +  t <- forkIO $ do
    31 
    +    r <- try $ atomically $ do
    32 
    +      v <- readTVar tv                  -- puts tv in the outer read set
    33 
    +      catchSTM (throwSTM (ErrorCall "boom"))
    34 
    +               (\(_ :: SomeException) ->
    35 
    +                  if v == 0
    36 
    +                    then do unsafeIOToSTM (takeMVar park)
    37 
    +                            pure "handler resumed"
    38 
    +                    else pure "transaction restarted, exception dropped")
    39 
    +    putMVar result (r :: Either SomeException String)
    40 
    +  waitParked t                  -- t is now parked inside the handler
    41 
    +  atomically (writeTVar tv 1)   -- invalidate t's transaction
    42 
    +  killThread t
    43 
    +  r <- takeMVar result
    44 
    +  putStrLn $ case r of
    45 
    +    Left e | Just ThreadKilled <- fromException e -> "T27657b: killThread delivered"
    46 
    +           | otherwise -> "T27657b: unexpected exception: " ++ displayException e
    47 
    +    Right s -> "T27657b: FAILED, " ++ s

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

  • testsuite/tests/concurrent/should_run/all.T
    ... ... @@ -338,3 +338,8 @@ test('T27105_fail',
    338 338 
           extra_run_opts('+RTS -C0.2 -RTS'), expect_fail,
    339 339 
           run_timeout_multiplier(0.05)],
    340 340 
          multimod_compile_and_run, ['T27105.hs', ''])
    341 
    +
    342 
    +# Frames pushed inside an STM transaction by catchSTM's WhileHandling
    343 
    +# annotation must be STM frames, not IO catch frames (#27657)
    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/828156370e4efadcc556b47d52c33e682ad801a2 at 1786530651