Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: f8de456f by Sylvain Henry at 2026-03-27T04:43:22-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. This is the second attempt at implementing this. The first attempt triggered segfaults (#26291) and has been reverted. Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com> - - - - - 12 changed files: - rts/PrimOps.cmm - rts/RaiseAsync.c - rts/STM.c - rts/STM.h - rts/Schedule.c - + testsuite/tests/lib/stm/T26028.hs - + testsuite/tests/lib/stm/T26028.stdout - + testsuite/tests/lib/stm/T26291a.hs - + testsuite/tests/lib/stm/T26291a.stdout - + testsuite/tests/lib/stm/T26291b.hs - + testsuite/tests/lib/stm/T26291b.stdout - + testsuite/tests/lib/stm/all.T Changes: ===================================== rts/PrimOps.cmm ===================================== @@ -1229,16 +1229,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); } } @@ -1471,21 +1482,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,30 @@ 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_RETRY frame within an atomically block: if we're executing + // the lhs code, abort the inner transaction and continue; if we're + // executing the 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. + { + debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_RETRY frame"); + stmAbortNestedCatchRetryTransaction(cap, tso, (StgCatchRetryFrame *)frame); + break; + }; + default: // see Note [Update async masking state on unwind] in Schedule.c if (*frame == (W_)&stg_unmaskAsyncExceptionszh_ret_info) { ===================================== rts/STM.c ===================================== @@ -961,6 +961,46 @@ void stmFreeAbortedTRec(Capability *cap, TRACE("%p : stmFreeAbortedTRec done", trec); } +/* +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). +*/ + +/* Called when unwinding past a CATCH_RETRY_FRAME. + * Only aborts the transaction if we're executing the lhs (running_alt_code=0), + * because rhs code uses the parent transaction directly with no nested trec. + * See Note [catchRetry# implementation]. + */ +void stmAbortNestedCatchRetryTransaction(Capability *cap, + StgTSO *tso, + StgCatchRetryFrame *frame) { + if (!frame->running_alt_code) { + StgTRecHeader *trec = tso->trec; + StgTRecHeader *outer = trec->enclosing_trec; + stmAbortTransaction(cap, trec); + stmFreeAbortedTRec(cap, trec); + tso->trec = outer; + } +} + /*......................................................................*/ void stmCondemnTransaction(Capability *cap, ===================================== rts/STM.h ===================================== @@ -67,6 +67,9 @@ StgTRecHeader *stmStartNestedTransaction(Capability *cap, StgTRecHeader *outer void stmAbortTransaction(Capability *cap, StgTRecHeader *trec); void stmFreeAbortedTRec(Capability *cap, StgTRecHeader *trec); +void stmAbortNestedCatchRetryTransaction(Capability *cap, + StgTSO *tso, + StgCatchRetryFrame *frame); /* * Ensure that a subsequent commit / validation will fail. We use this ===================================== rts/Schedule.c ===================================== @@ -3088,14 +3088,9 @@ raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception) return STOP_FRAME; case CATCH_RETRY_FRAME: { - StgTRecHeader *trec = tso -> trec; - StgTRecHeader *outer = trec -> enclosing_trec; debugTrace(DEBUG_stm, "found CATCH_RETRY_FRAME at %p during raise", p); - debugTrace(DEBUG_stm, "trec=%p outer=%p", trec, outer); - stmAbortTransaction(cap, trec); - stmFreeAbortedTRec(cap, trec); - tso -> trec = outer; + stmAbortNestedCatchRetryTransaction(cap, tso, (StgCatchRetryFrame *)p); p = next; continue; } @@ -3248,14 +3243,9 @@ findAtomicallyFrameHelper (Capability *cap, StgTSO *tso) return ATOMICALLY_FRAME; case CATCH_RETRY_FRAME: { - StgTRecHeader *trec = tso -> trec; - StgTRecHeader *outer = trec -> enclosing_trec; debugTrace(DEBUG_stm, "found CATCH_RETRY_FRAME at %p while aborting after orElse", p); - debugTrace(DEBUG_stm, "trec=%p outer=%p", trec, outer); - stmAbortTransaction(cap, trec); - stmFreeAbortedTRec(cap, trec); - tso -> trec = outer; + stmAbortNestedCatchRetryTransaction(cap, tso, (StgCatchRetryFrame *)p); p = next; continue; } ===================================== 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/T26291a.hs ===================================== @@ -0,0 +1,15 @@ +module Main where + +import Control.Concurrent.STM +import Control.Exception + +main :: IO () +main = do + result <- try @SomeException $ atomically $ + -- LHS retries → CATCH_RETRY_FRAME gets running_alt_code=1, RHS executes. + -- RHS throws → raiseExceptionHelper walks the stack, finds the + -- CATCH_RETRY_FRAME (running_alt_code=1), and must NOT abort tso->trec. + orElse retry (throwSTM (ErrorCall "test")) + case result of + Left _ -> putStrLn "OK" + Right _ -> putStrLn "impossible" ===================================== testsuite/tests/lib/stm/T26291a.stdout ===================================== @@ -0,0 +1 @@ +OK ===================================== testsuite/tests/lib/stm/T26291b.hs ===================================== @@ -0,0 +1,42 @@ +-- Test for the findAtomicallyFrameHelper crash when running_alt_code=1. +-- +-- findAtomicallyFrameHelper is called by stg_abort, which fires when a nested +-- transaction's stmCommitNestedTransaction fails (due to a concurrent TVar +-- write conflicting with the nested trec's read set). If the walk encounters +-- a CATCH_RETRY_FRAME with running_alt_code=1, the old code unconditionally +-- called stmAbortTransaction on tso->trec, which is the *parent* transaction +-- (no nested trec exists for the RHS). That freed the parent trec, leaving +-- tso->trec as garbage; stg_abort then dereferenced it and crashed. +-- +-- The structure that exercises this: +-- outer orElse: LHS retries → RHS runs (outer CATCH_RETRY_FRAME has running_alt_code=1) +-- inner orElse: LHS reads a TVar in a nested trec and tries to commit +-- → if a concurrent writer invalidates the read, stmCommitNestedTransaction fails +-- → stg_abort → findAtomicallyFrameHelper encounters the outer CATCH_RETRY_FRAME +-- (running_alt_code=1) → crash without the fix. +module Main where + +import Control.Concurrent +import Control.Concurrent.STM + +main :: IO () +main = do + tv <- newTVarIO (0 :: Int) + + -- Continuously modify tv to provoke nested-commit failures. + _ <- forkIO $ let loop = atomically (modifyTVar' tv (+1)) >> loop in loop + + -- Run the critical orElse pattern many times. Each iteration the inner LHS + -- reads tv (nested trec) and tries to commit; concurrent writes will + -- occasionally cause the commit to fail and trigger stg_abort. + let loop 0 = return () + loop n = do + _ <- atomically $ + orElse + retry -- outer LHS: always retries + (orElse (readTVar tv) (return 0)) -- outer RHS (running_alt_code=1): + -- inner LHS reads tv (nested trec) + loop (n - 1) + loop (100000 :: Int) + + putStrLn "OK" ===================================== testsuite/tests/lib/stm/T26291b.stdout ===================================== @@ -0,0 +1 @@ +OK ===================================== testsuite/tests/lib/stm/all.T ===================================== @@ -0,0 +1,3 @@ +test('T26028', only_ways(['threaded1']), compile_and_run, ['-O2']) +test('T26291a', normal, compile_and_run, ['-O2']) +test('T26291b', only_ways(['threaded1']), compile_and_run, ['-O2']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8de456fb914adfe7994af80f769b28a... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8de456fb914adfe7994af80f769b28a... You're receiving this email because of your account on gitlab.haskell.org.