GitLab

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

Commits:

0a583689

by Sylvain Henry at 2025-07-24T16:20:26-04:00

STM: don't create a transaction in the rhs of catchRetry# (#26028)

We don't need to create a transaction for the rhs of (catchRetry#)
because contrary to the lhs we don't need to abort it on retry. Moreover
it is particularly harmful if we have code such as (#26028):

  let cN = readTVar vN >> retry
      tree = c1 `orElse` (c2 `orElse` (c3 `orElse` ...))
  atomically tree

Because it will stack transactions for the rhss and the read-sets of all
the transactions will be iteratively merged in O(n^2) after the
execution of the most nested retry.

6 changed files:

rts/PrimOps.cmm
rts/RaiseAsync.c
rts/STM.c
+ testsuite/tests/lib/stm/T26028.hs
+ testsuite/tests/lib/stm/T26028.stdout
+ testsuite/tests/lib/stm/all.T

Changes:

rts/PrimOps.cmm

@@ -1211,16 +1211,27 @@ INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME,
      gcptr trec, outer, arg;
      trec = StgTSO_trec(CurrentTSO);
 -    outer  = StgTRecHeader_enclosing_trec(trec);
 -    (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr");
 -    if (r != 0) {
 -        // Succeeded (either first branch or second branch)
 -        StgTSO_trec(CurrentTSO) = outer;
 -        return (ret);
 -    } else {
 -        // Did not commit: abort and restart.
 -        StgTSO_trec(CurrentTSO) = outer;
 -        jump stg_abort();
 +    if (running_alt_code != 1) {
 +      // When exiting the lhs code of catchRetry# lhs rhs, we need to cleanup
 +      // the nested transaction.
 +      // See Note [catchRetry# implementation]
 +      outer  = StgTRecHeader_enclosing_trec(trec);
 +      (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr");
 +      if (r != 0) {
 +          // Succeeded in first branch
 +          StgTSO_trec(CurrentTSO) = outer;
 +          return (ret);
 +      } else {
 +          // Did not commit: abort and restart.
 +          StgTSO_trec(CurrentTSO) = outer;
 +          jump stg_abort();
 +      }
 +    }
 +    else {
 +      // nothing to do in the rhs code of catchRetry# lhs rhs, it's already
 +      // using the parent transaction (not a nested one).
 +      // See Note [catchRetry# implementation]
 +      return (ret);
+     }
+ }
@@ -1453,21 +1464,26 @@ retry_pop_stack:
      outer  = StgTRecHeader_enclosing_trec(trec);
      if (frame_type == CATCH_RETRY_FRAME) {
 -        // The retry reaches a CATCH_RETRY_FRAME before the atomic frame
 -        ASSERT(outer != NO_TREC);
 -        // Abort the transaction attempting the current branch
 -        ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
 -        ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr");
 +        // The retry reaches a CATCH_RETRY_FRAME before the ATOMICALLY_FRAME
++
          if (!StgCatchRetryFrame_running_alt_code(frame) != 0) {
 -            // Retry in the first branch: try the alternative
 -            ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr");
 -            StgTSO_trec(CurrentTSO) = trec;
 +            // Retrying in the lhs of catchRetry# lhs rhs, i.e. in a nested
 +            // transaction. See Note [catchRetry# implementation]
++
 +            // check that we have a parent transaction
 +            ASSERT(outer != NO_TREC);
++
 +            // Abort the nested transaction
 +            ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
 +            ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr");
++
 +            // As we are retrying in the lhs code, we must now try the rhs code
 +            StgTSO_trec(CurrentTSO) = outer;
              StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true;
              R1 = StgCatchRetryFrame_alt_code(frame);
              jump stg_ap_v_fast [R1];
          } else {
 -            // Retry in the alternative code: propagate the retry
 -            StgTSO_trec(CurrentTSO) = outer;
 +            // Retry in the rhs code: propagate the retry
              Sp = Sp + SIZEOF_StgCatchRetryFrame;
              goto retry_pop_stack;
+         }

rts/RaiseAsync.c

@@ -1043,8 +1043,7 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
+             }
          case CATCH_STM_FRAME:
 -        case CATCH_RETRY_FRAME:
 -            // CATCH frames within an atomically block: abort the
 +            // CATCH_STM frame within an atomically block: abort the
              // inner transaction and continue.  Eventually we will
              // hit the outer transaction that will get frozen (see
              // above).
@@ -1056,14 +1055,40 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
+         {
              StgTRecHeader *trec = tso -> trec;
              StgTRecHeader *outer = trec -> enclosing_trec;
 -            debugTraceCap(DEBUG_stm, cap,
 -                          "found atomically block delivering async exception");
 +            debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_STM frame");
              stmAbortTransaction(cap, trec);
              stmFreeAbortedTRec(cap, trec);
              tso -> trec = outer;
              break;
          };
 +        case CATCH_RETRY_FRAME:
 +            // CATCH_RETY frame within an atomically block: if we're executing
 +            // the lhs code, abort the inner transaction and continue; if we're
 +            // executing thr rhs, continue (no nested transaction to abort. See
 +            // Note [catchRetry# implementation]). Eventually we will hit the
 +            // outer transaction that will get frozen (see above).
 +            //
 +            // As for the CATCH_STM_FRAME case above, we do not care
 +            // whether the transaction is valid or not because its
 +            // possible validity cannot have caused the exception
 +            // and will not be visible after the abort.
 +        {
 +            if (!((StgCatchRetryFrame *)frame) -> running_alt_code) {
 +                debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_RETRY frame (lhs)");
 +                StgTRecHeader *trec = tso -> trec;
 +                StgTRecHeader *outer = trec -> enclosing_trec;
 +                stmAbortTransaction(cap, trec);
 +                stmFreeAbortedTRec(cap, trec);
 +                tso -> trec = outer;
 +            }
 +            else
 +            {
 +                debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_RETRY frame (rhs)");
 +            }
 +            break;
 +        };
++
          default:
              // see Note [Update async masking state on unwind] in Schedule.c
              if (*frame == (W_)&stg_unmaskAsyncExceptionszh_ret_info) {

rts/STM.c

@@ -1505,3 +1505,30 @@ void stmWriteTVar(Capability *cap,
+ }
  /*......................................................................*/
++
++
++
 +/*
++
 +Note [catchRetry# implementation]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +catchRetry# creates a nested transaction for its lhs:
 +- if the lhs transaction succeeds:
 +    - the lhs transaction is committed
 +    - its read-variables are merged with those of the parent transaction
 +    - the rhs code is ignored
 +- if the lhs transaction retries:
 +    - the lhs transaction is aborted
 +    - its read-variables are merged with those of the parent transaction
 +    - the rhs code is executed directly in the parent transaction (see #26028).
++
 +So note that:
 +- lhs code uses a nested transaction
 +- rhs code doesn't use a nested transaction
++
 +We have to take which case we're in into account (using the running_alt_code
 +field of the catchRetry frame) in catchRetry's entry code, in retry#
 +implementation, and also when an async exception is received (to cleanup the
 +right number of transactions).
++
 +*/

testsuite/tests/lib/stm/T26028.hs

 +module Main where
++
 +import GHC.Conc
++
 +forever :: IO String
 +forever = delay 10 >> forever
++
 +terminates :: IO String
 +terminates = delay 1 >> pure "terminates"
++
 +delay s = threadDelay (1000000 * s)
++
 +async :: IO a -> IO (STM a)
 +async a = do
 +  var <- atomically (newTVar Nothing)
 +  forkIO (a >>= atomically . writeTVar var . Just)
 +  pure (readTVar var >>= maybe retry pure)
++
 +main :: IO ()
 +main = do
 +  x <- mapM async $ terminates : replicate 50000 forever
 +  r <- atomically (foldr1 orElse x)
 +  print r

testsuite/tests/lib/stm/T26028.stdout

+"terminates"

testsuite/tests/lib/stm/all.T

+test('T26028', only_ways(['threaded1']), compile_and_run, ['-O2'])