Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/014f1e1feee4c85a82f787ef8f01b44072051172 >--------------------------------------------------------------- commit 014f1e1feee4c85a82f787ef8f01b44072051172 Author: Simon Marlow <[email protected]> Date: Mon Feb 27 14:32:44 2012 +0000 raiseAsync: cope with ATOMICALLY_FRAMES inside UPDATE_FRAMES (#5866) >--------------------------------------------------------------- includes/stg/MiscClosures.h | 1 + rts/PrimOps.cmm | 10 +++++++ rts/RaiseAsync.c | 63 ++++++++++++++++++++++++++++++++++++------ 3 files changed, 65 insertions(+), 9 deletions(-) diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h index da3b07b..4fed346 100644 --- a/includes/stg/MiscClosures.h +++ b/includes/stg/MiscClosures.h @@ -126,6 +126,7 @@ RTS_ENTRY(stg_AP_STACK_NOUPD); RTS_ENTRY(stg_dummy_ret); RTS_ENTRY(stg_raise); RTS_ENTRY(stg_raise_ret); +RTS_ENTRY(stg_atomically); RTS_ENTRY(stg_TVAR_WATCH_QUEUE); RTS_ENTRY(stg_INVARIANT_CHECK_QUEUE); RTS_ENTRY(stg_ATOMIC_INVARIANT); diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 7811af1..4cb3b8d 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -932,6 +932,16 @@ stg_atomicallyzh jump stg_ap_v_fast; } +// A closure representing "atomically x". This is used when a thread +// inside a transaction receives an asynchronous exception; see #5866. +// It is somewhat similar to the stg_raise closure. +// +INFO_TABLE(stg_atomically,1,0,THUNK_1_0,"atomically","atomically") +{ + R1 = StgThunk_payload(R1,0); + jump stg_atomicallyzh; +} + stg_catchSTMzh { diff --git a/rts/RaiseAsync.c b/rts/RaiseAsync.c index 7b7fef1..c14b411 100644 --- a/rts/RaiseAsync.c +++ b/rts/RaiseAsync.c @@ -957,19 +957,64 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception, tso->what_next = ThreadRunGHC; goto done; } - // Not stop_at_atomically... fall through and abort the - // transaction. + else + { + // Freezing an STM transaction. Just aborting the + // transaction would be wrong; this is what we used to + // do, and it goes wrong if the ATOMICALLY_FRAME ever + // gets back onto the stack again, which it will do if + // the transaction is inside unsafePerformIO or + // unsafeInterleaveIO and hence inside an UPDATE_FRAME. + // + // So we want to make it so that if the enclosing + // computation is resumed, we will re-execute the + // transaction. We therefore: + // + // 1. abort the current transaction + // 3. replace the stack up to and including the + // atomically frame with a closure representing + // a call to "atomically x", where x is the code + // of the transaction. + // 4. continue stripping the stack + // + StgTRecHeader *trec = tso->trec; + StgTRecHeader *outer = trec->enclosing_trec; + + StgThunk *atomically; + StgAtomicallyFrame *af = (StgAtomicallyFrame*)frame; + + debugTraceCap(DEBUG_stm, cap, + "raiseAsync: freezing atomically frame") + stmAbortTransaction(cap, trec); + stmFreeAbortedTRec(cap, trec); + tso->trec = outer; + + atomically = (StgThunk*)allocate(cap,sizeofW(StgThunk)+1); + TICK_ALLOC_SE_THK(1,0); + SET_HDR(atomically,&stg_atomically_info,af->header.prof.ccs); + atomically->payload[0] = af->code; + + // discard stack up to and including the ATOMICALLY_FRAME + frame += sizeofW(StgAtomicallyFrame); + sp = frame - 1; + + // replace the ATOMICALLY_FRAME with call to atomically# + sp[0] = (W_)atomically; + continue; + } - case CATCH_STM_FRAME: + case CATCH_STM_FRAME: case CATCH_RETRY_FRAME: - // IF we find an ATOMICALLY_FRAME then we abort the - // current transaction and propagate the exception. In - // this case (unlike ordinary exceptions) we do not care + // CATCH frames within an atomically block: abort the + // inner transaction and continue. Eventually we will + // hit the outer transaction that will get frozen (see + // above). + // + // In this case (unlike ordinary exceptions) 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. - - { + { StgTRecHeader *trec = tso -> trec; StgTRecHeader *outer = trec -> enclosing_trec; debugTraceCap(DEBUG_stm, cap, @@ -978,7 +1023,7 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception, stmFreeAbortedTRec(cap, trec); tso -> trec = outer; break; - }; + }; default: break; _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
