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 ===================================== @@ -0,0 +1,23 @@ +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 ===================================== @@ -0,0 +1 @@ +"terminates" ===================================== testsuite/tests/lib/stm/all.T ===================================== @@ -0,0 +1 @@ +test('T26028', only_ways(['threaded1']), compile_and_run, ['-O2']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0a5836891ca29836a24c306d2a364c2e... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0a5836891ca29836a24c306d2a364c2e... You're receiving this email because of your account on gitlab.haskell.org.