Commit b61f70ce authored by tharris's avatar tharris

[project @ 2004-11-18 09:56:07 by tharris]

Support for atomic memory transactions and associated regression tests conc041-048
parent ff845ab5
......@@ -486,6 +486,7 @@ translateOp SameMutVarOp = Just mo_wordEq
translateOp SameMVarOp = Just mo_wordEq
translateOp SameMutableArrayOp = Just mo_wordEq
translateOp SameMutableByteArrayOp = Just mo_wordEq
translateOp SameTVarOp = Just mo_wordEq
translateOp EqForeignObj = Just mo_wordEq
translateOp EqStablePtrOp = Just mo_wordEq
......
......@@ -789,6 +789,7 @@ threadIdPrimTyConKey = mkPreludeTyConUnique 72
bcoPrimTyConKey = mkPreludeTyConUnique 73
ptrTyConKey = mkPreludeTyConUnique 74
funPtrTyConKey = mkPreludeTyConUnique 75
tVarPrimTyConKey = mkPreludeTyConUnique 76
-- Generic Type Constructors
crossTyConKey = mkPreludeTyConUnique 79
......
......@@ -28,6 +28,7 @@ module TysPrim(
mutVarPrimTyCon, mkMutVarPrimTy,
mVarPrimTyCon, mkMVarPrimTy,
tVarPrimTyCon, mkTVarPrimTy,
stablePtrPrimTyCon, mkStablePtrPrimTy,
stableNamePrimTyCon, mkStableNamePrimTy,
bcoPrimTyCon, bcoPrimTy,
......@@ -87,6 +88,7 @@ primTyCons
, mutableArrayPrimTyCon
, mutableByteArrayPrimTyCon
, mVarPrimTyCon
, tVarPrimTyCon
, mutVarPrimTyCon
, realWorldTyCon
, stablePtrPrimTyCon
......@@ -124,6 +126,7 @@ mutableArrayPrimTyConName = mkPrimTc FSLIT("MutableArray#") mutableArrayPrim
mutableByteArrayPrimTyConName = mkPrimTc FSLIT("MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon
mutVarPrimTyConName = mkPrimTc FSLIT("MutVar#") mutVarPrimTyConKey mutVarPrimTyCon
mVarPrimTyConName = mkPrimTc FSLIT("MVar#") mVarPrimTyConKey mVarPrimTyCon
tVarPrimTyConName = mkPrimTc FSLIT("TVar#") tVarPrimTyConKey tVarPrimTyCon
stablePtrPrimTyConName = mkPrimTc FSLIT("StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon
stableNamePrimTyConName = mkPrimTc FSLIT("StableName#") stableNamePrimTyConKey stableNamePrimTyCon
foreignObjPrimTyConName = mkPrimTc FSLIT("ForeignObj#") foreignObjPrimTyConKey foreignObjPrimTyCon
......@@ -312,6 +315,18 @@ mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName vrcsZP PtrRep
mkMVarPrimTy s elt = mkTyConApp mVarPrimTyCon [s, elt]
\end{code}
%************************************************************************
%* *
\subsection[TysPrim-stm-var]{The transactional variable type}
%* *
%************************************************************************
\begin{code}
tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName vrcsZP PtrRep
mkTVarPrimTy s elt = mkTyConApp tVarPrimTyCon [s, elt]
\end{code}
%************************************************************************
%* *
\subsection[TysPrim-stable-ptrs]{The stable-pointer type}
......
-----------------------------------------------------------------------
-- $Id: primops.txt.pp,v 1.30 2003/10/01 10:57:39 wolfgang Exp $
-- $Id: primops.txt.pp,v 1.31 2004/11/18 09:56:15 tharris Exp $
--
-- Primitive Operations
--
......@@ -1333,6 +1333,66 @@ primop UnblockAsyncExceptionsOp "unblockAsyncExceptions#" GenPrimOp
with
out_of_line = True
------------------------------------------------------------------------
section "STM-accessible Mutable Variables"
------------------------------------------------------------------------
primop AtomicallyOp "atomically#" GenPrimOp
(State# RealWorld -> (# State# RealWorld, a #) )
-> State# RealWorld -> (# State# RealWorld, a #)
with
out_of_line = True
has_side_effects = True
primop RetryOp "retry#" GenPrimOp
State# RealWorld -> (# State# RealWorld, a #)
with
out_of_line = True
has_side_effects = True
primop CatchRetryOp "catchRetry#" GenPrimOp
(State# RealWorld -> (# State# RealWorld, a #) )
-> (State# RealWorld -> (# State# RealWorld, a #) )
-> (State# RealWorld -> (# State# RealWorld, a #) )
with
out_of_line = True
has_side_effects = True
primop CatchSTMOp "catchSTM#" GenPrimOp
(State# RealWorld -> (# State# RealWorld, a #) )
-> (b -> State# RealWorld -> (# State# RealWorld, a #) )
-> (State# RealWorld -> (# State# RealWorld, a #) )
with
out_of_line = True
has_side_effects = True
primop NewTVarOp "newTVar#" GenPrimOp
a
-> State# s -> (# State# s, TVar# s a #)
{Create a new Tar\# holding a specified initial value.}
with
out_of_line = True
primop ReadTVarOp "readTVar#" GenPrimOp
TVar# s a
-> State# s -> (# State# s, a #)
{Read contents of TVar\#. Result is not yet evaluated.}
with
out_of_line = True
primop WriteTVarOp "writeTVar#" GenPrimOp
TVar# s a
-> a
-> State# s -> State# s
{Write contents of TVar\#.}
with
out_of_line = True
has_side_effects = True
primop SameTVarOp "sameTVar#" GenPrimOp
TVar# s a -> TVar# s a -> Bool
------------------------------------------------------------------------
section "Synchronized Mutable Variables"
{Operations on MVar\#s, which are shared mutable variables
......
/* ----------------------------------------------------------------------------
* $Id: ClosureTypes.h,v 1.18 2002/12/11 15:36:37 simonmar Exp $
* $Id: ClosureTypes.h,v 1.19 2004/11/18 09:56:17 tharris Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -79,6 +79,13 @@
#define RBH 63
#define EVACUATED 64
#define REMOTE_REF 65
#define N_CLOSURE_TYPES 66
#define TVAR_WAIT_QUEUE 66
#define TVAR 67
#define TREC_CHUNK 68
#define TREC_HEADER 69
#define ATOMICALLY_FRAME 70
#define CATCH_RETRY_FRAME 71
#define CATCH_STM_FRAME 72
#define N_CLOSURE_TYPES 73
#endif /* CLOSURETYPES_H */
......@@ -308,6 +308,93 @@ typedef struct {
StgClosure* value;
} StgMVar;
/* STM data structures
*
* StgTVar defines the only type that can be updated through the STM
* interface.
*
* Note that various optimisations may be possible in order to use less
* space for these data structures at the cost of more complexity in the
* implementation:
*
* - In StgTVar, current_value and first_wait_queue_entry could be held in
* the same field: if any thread is waiting then its expected_value for
* the tvar is the current value.
*
* - In StgTRecHeader, it might be worthwhile having separate chunks
* of read-only and read-write locations. This would save a
* new_value field in the read-only locations.
*/
typedef struct StgTVarWaitQueue_ {
StgHeader header;
struct StgTSO_ *waiting_tso;
StgMutClosure *mut_link;
struct StgTVarWaitQueue_ *next_queue_entry;
struct StgTVarWaitQueue_ *prev_queue_entry;
} StgTVarWaitQueue;
typedef struct {
StgHeader header;
StgClosure *current_value;
StgMutClosure *mut_link;
StgTVarWaitQueue *first_wait_queue_entry;
} StgTVar;
// new_value == expected_value for read-only accesses
// new_value is a StgTVarWaitQueue entry when trec in state TREC_WAITING
typedef struct {
StgTVar *tvar;
StgClosure *expected_value;
StgClosure *new_value;
} TRecEntry;
#define TREC_CHUNK_NUM_ENTRIES 256
typedef struct StgTRecChunk_ {
StgHeader header;
struct StgTRecChunk_ *prev_chunk;
StgMutClosure *mut_link;
StgWord next_entry_idx;
TRecEntry entries[TREC_CHUNK_NUM_ENTRIES];
} StgTRecChunk;
typedef enum {
TREC_ACTIVE, // Transaction in progress, outcome undecided
TREC_CANNOT_COMMIT, // Transaction in progress, inconsistent writes performed
TREC_MUST_ABORT, // Transaction in progress, inconsistent / out of date reads
TREC_COMMITTED, // Transaction has committed, now updating tvars
TREC_ABORTED, // Transaction has aborted, now reverting tvars
TREC_WAITING, // Transaction currently waiting
} TRecState;
typedef struct StgTRecHeader_ {
StgHeader header;
TRecState state;
StgMutClosure *mut_link;
struct StgTRecHeader_ *enclosing_trec;
StgTRecChunk *current_chunk;
} StgTRecHeader;
typedef struct {
StgHeader header;
StgBool waiting;
StgClosure *code;
} StgAtomicallyFrame;
typedef struct {
StgHeader header;
StgClosure *handler;
} StgCatchSTMFrame;
typedef struct {
StgHeader header;
StgBool running_alt_code;
StgClosure *first_code;
StgClosure *alt_code;
StgTRecHeader *first_code_trec;
} StgCatchRetryFrame;
#if defined(PAR) || defined(GRAN)
/*
StgBlockingQueueElement is a ``collective type'' representing the types
......
/* ----------------------------------------------------------------------------
* $Id: Constants.h,v 1.26 2004/08/13 13:09:13 simonmar Exp $
* $Id: Constants.h,v 1.27 2004/11/18 09:56:19 tharris Exp $
*
* (c) The GHC Team, 1998-2002
*
......@@ -222,18 +222,19 @@
#define BlockedOnRead 4
#define BlockedOnWrite 5
#define BlockedOnDelay 6
#define BlockedOnSTM 7
/* Win32 only: */
#define BlockedOnDoProc 7
#define BlockedOnDoProc 8
/* Only relevant for PAR: */
/* blocked on a remote closure represented by a Global Address: */
#define BlockedOnGA 8
#define BlockedOnGA 9
/* same as above but without sending a Fetch message */
#define BlockedOnGA_NoSend 9
#define BlockedOnGA_NoSend 10
/* Only relevant for RTS_SUPPORTS_THREADS: */
#define BlockedOnCCall 10
#define BlockedOnCCall_NoUnblockExc 11
#define BlockedOnCCall 11
#define BlockedOnCCall_NoUnblockExc 12
/* same as above but don't unblock async exceptions in resumeThread() */
/*
......
/* -----------------------------------------------------------------------------
* $Id: RtsFlags.h,v 1.46 2004/08/13 13:09:29 simonmar Exp $
* $Id: RtsFlags.h,v 1.47 2004/11/18 09:56:20 tharris Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -60,6 +60,7 @@ struct DEBUG_FLAGS {
rtsBool par; // 'P'
rtsBool linker; // 'l' the object linker
rtsBool apply; // 'a'
rtsBool stm; // 'm'
};
struct COST_CENTRE_FLAGS {
......
/*----------------------------------------------------------------------
*
* (c) The GHC Team, 1998-2004
*
* STM interface definition
*
*----------------------------------------------------------------------
STM.h defines the C-level interface to the STM.
The interface is designed so that all of the operations return
directly: if the specified StgTSO should block then the Haskell
scheduler's data structures are updated within the STM
implementation, rather than blocking the native thread.
This interface can be supported by many different implementations,
in particular it is left unspecified:
- Whether nested transactions are fully supported.
A simple implementation would count the number of
stmStartTransaction operations that a thread invokes and only
attempt to really commit it to the heap when the corresponding
number of stmCommitTransaction calls have been made. This
prevents enclosed transactions from being aborted without also
aborting all of the outer ones.
The current implementation does support proper nesting.
- Whether stmWait and stmReWait are blocking.
A simple implementation would always return 'false' from these
operations, signalling that the calling thread should immediately
retry its transaction.
A fuller implementation would block the thread and return 'True'
when it is safe for the thread to block.
The current implementation does provide stmWait and stmReWait
operations which can block the caller's TSO.
- Whether the transactional read, write, commit and validate
operations are blocking or non-blocking.
A simple implementation would use an internal lock to prevent
concurrent execution of any STM operations. (This does not
prevent multiple threads having concurrent transactions, merely
the concurrent execution of say stmCommitTransaction by two
threads at the same time).
A fuller implementation would offer obstruction-free or lock-free
progress guarantees, as in our OOPSLA 2003 paper.
The current implementation is lock-free for simple uncontended
operations, but uses an internal lock on SMP systems in some
cases. This aims to provide good performance on uniprocessors:
it substantially streamlines the design, when compared with the
OOPSLA paper, and on a uniprocessor we can be sure that threads
are never pre-empted within STM operations.
*/
#ifndef STM_H
#define STM_H
#ifdef __cplusplus
extern "C" {
#endif
/*----------------------------------------------------------------------
Start of day
------------
*/
extern void initSTM(void);
extern void stmPreGCHook(void);
/*----------------------------------------------------------------------
Transaction context management
------------------------------
*/
// Create and enter a new transaction context
extern StgTRecHeader *stmStartTransaction(StgTRecHeader *outer);
// Exit the current transaction context, abandoning any read/write
// operations performed within it and removing the thread from any
// tvar wait queues if it was waitin. Note that if nested transactions
// are not fully supported then this may leave the enclosing
// transaction contexts doomed to abort.
extern void stmAbortTransaction(StgTRecHeader *trec);
// Return the trec within which the specified trec was created (not
// valid if trec==NO_TREC).
extern StgTRecHeader *stmGetEnclosingTRec(StgTRecHeader *trec);
/*----------------------------------------------------------------------
Validate/commit/wait/rewait operations
--------------------------------------
These four operations return boolean results which should be interpreted
as follows:
true => The transaction context was definitely valid
false => The transaction context may not have been valid
The user of the STM should ensure that it is always safe to assume that a
transaction context is not valid when in fact it is (i.e. to return false in
place of true, with side-effects as defined below). This may cause
needless retries of transactions (in the case of validate and commit), or it
may cause needless spinning instead of blocking (in the case of wait and
rewait).
In defining the behaviour of wait and rewait we distinguish between two
different aspects of a thread's runnability:
- We say that a thread is "blocked" when it is not running or
runnable as far as the scheduler is concerned.
- We say that a thread is "waiting" when its StgTRecHeader is linked on an
tvar's wait queue.
Considering only STM operations, (blocked) => (waiting). The user of the STM
should ensure that they are prepared for threads to be unblocked spuriously
and for wait/reWait to return false even when the previous transaction context
is actually still valid.
*/
// Test whether the current transaction context is valid, i.e. whether
// it is still possible for it to commit successfully. Note: we assume that
// once stmValidateTransaction has returned FALSE for a given transaction then
// that transaction will never again be valid -- we rely on this in Schedule.c when
// kicking invalid threads at GC (in case they are stuck looping)
extern StgBool stmValidateTransaction(StgTRecHeader *trec);
// Test whether the current transaction context is valid and, if so,
// commit its memory accesses to the heap. stmCommitTransaction must
// unblock any threads which are waiting on tvars that updates have
// been committed to.
extern StgBool stmCommitTransaction(StgTRecHeader *trec);
// Test whether the current transaction context is valid and, if so,
// start the thread waiting for updates to any of the tvars it has
// ready from and mark it as blocked. It is an error to call stmWait
// if the thread is already waiting.
extern StgBool stmWait(StgTSO *tso, StgTRecHeader *trec);
// Test whether the current transaction context is valid and, if so,
// leave the thread waiting and mark it as blocked again. If the
// transaction context is no longer valid then stop the thread waiting
// and leave it as unblocked. It is an error to call stmReWait if the
// thread is not waiting.
extern StgBool stmReWait(StgTRecHeader *trec);
// Merge the accesses made so far in the second trec into the first trec.
// Note that the resulting trec is only intended to be used in wait operations.
// This avoids defining what happens if "trec" and "other" contain conflicting
// updates.
extern StgBool stmMergeForWaiting(StgTRecHeader *trec, StgTRecHeader *other);
/*----------------------------------------------------------------------
Data access operations
----------------------
*/
// Return the logical contents of 'tvar' within the context of the
// thread's current transaction.
extern StgClosure *stmReadTVar(StgTRecHeader *trec,
StgTVar *tvar);
// Update the logical contents of 'tvar' within the context of the
// thread's current transaction.
extern void stmWriteTVar(StgTRecHeader *trec,
StgTVar *tvar,
StgClosure *new_value);
/*----------------------------------------------------------------------*/
// NULLs
#define END_STM_WAIT_QUEUE ((StgTVarWaitQueue *)(void *)&stg_END_STM_WAIT_QUEUE_closure)
#define END_STM_CHUNK_LIST ((StgTRecChunk *)(void *)&stg_END_STM_CHUNK_LIST_closure)
#define NO_TREC ((StgTRecHeader *)(void *)&stg_NO_TREC_closure)
/*----------------------------------------------------------------------*/
#ifdef __cplusplus
}
#endif
#endif /* STM_H */
......@@ -129,6 +129,13 @@ RTS_INFO(stg_AP_info);
RTS_INFO(stg_AP_STACK_info);
RTS_INFO(stg_dummy_ret_info);
RTS_INFO(stg_raise_info);
RTS_INFO(stg_TVAR_WAIT_QUEUE_info);
RTS_INFO(stg_TVAR_info);
RTS_INFO(stg_TREC_CHUNK_info);
RTS_INFO(stg_TREC_HEADER_info);
RTS_INFO(stg_END_STM_WAIT_QUEUE_info);
RTS_INFO(stg_END_STM_CHUNK_LIST_info);
RTS_INFO(stg_NO_TREC_info);
RTS_ENTRY(stg_IND_entry);
RTS_ENTRY(stg_IND_direct_entry);
......@@ -182,6 +189,9 @@ RTS_ENTRY(stg_AP_entry);
RTS_ENTRY(stg_AP_STACK_entry);
RTS_ENTRY(stg_dummy_ret_entry);
RTS_ENTRY(stg_raise_entry);
RTS_ENTRY(stg_END_STM_WAIT_QUEUE_entry);
RTS_ENTRY(stg_END_STM_CHUNK_LIST_entry);
RTS_ENTRY(stg_NO_TREC_entry);
RTS_ENTRY(stg_unblockAsyncExceptionszh_ret_ret);
......@@ -198,6 +208,10 @@ RTS_CLOSURE(stg_NO_FINALIZER_closure);
RTS_CLOSURE(stg_dummy_ret_closure);
RTS_CLOSURE(stg_forceIO_closure);
RTS_CLOSURE(stg_END_STM_WAIT_QUEUE_closure);
RTS_CLOSURE(stg_END_STM_CHUNK_LIST_closure);
RTS_CLOSURE(stg_NO_TREC_closure);
RTS_ENTRY(stg_NO_FINALIZER_entry);
RTS_ENTRY(stg_END_EXCEPTION_LIST_entry);
RTS_ENTRY(stg_EXCEPTION_CONS_entry);
......@@ -544,4 +558,12 @@ RTS_FUN(mkForeignObjzh_fast);
RTS_FUN(newBCOzh_fast);
RTS_FUN(mkApUpd0zh_fast);
RTS_FUN(retryzh_fast);
RTS_FUN(catchRetryzh_fast);
RTS_FUN(catchSTMzh_fast);
RTS_FUN(atomicallyzh_fast);
RTS_FUN(newTVarzh_fast);
RTS_FUN(readTVarzh_fast);
RTS_FUN(writeTVarzh_fast);
#endif /* STGMISCCLOSURES_H */
/* -----------------------------------------------------------------------------
* $Id: TSO.h,v 1.38 2004/11/10 02:13:12 wolfgang Exp $
* $Id: TSO.h,v 1.39 2004/11/18 09:56:22 tharris Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -136,6 +136,7 @@ typedef struct StgTSO_ {
StgThreadID id;
int saved_errno;
struct StgMainThread_* main;
struct StgTRecHeader_ *trec; // STM transaction record
#ifdef TICKY_TICKY
// TICKY-specific stuff would go here.
......@@ -183,6 +184,8 @@ typedef struct StgTSO_ {
BlockedOnBlackHole the BLACKHOLE_BQ the BLACKHOLE_BQ's queue
BlockedOnMVar the MVAR the MVAR's queue
BlockedOnSTM END_TSO_QUEUE STM wait queue(s)
BlockedOnException the TSO TSO->blocked_exception
......
......@@ -253,6 +253,7 @@ main(int argc, char *argv[])
closure_field(StgTSO, blocked_exceptions);
closure_field(StgTSO, id);
closure_field(StgTSO, saved_errno);
closure_field(StgTSO, trec);
closure_field_("StgTSO_CCCS", StgTSO, prof.CCCS);
tso_field(StgTSO, sp);
tso_offset(StgTSO, stack);
......@@ -298,6 +299,19 @@ main(int argc, char *argv[])
closure_size(StgMutVar);
closure_field(StgMutVar, var);
closure_size(StgAtomicallyFrame);
closure_field(StgAtomicallyFrame, waiting);
closure_field(StgAtomicallyFrame, code);
closure_size(StgCatchSTMFrame);
closure_field(StgCatchSTMFrame, handler);
closure_size(StgCatchRetryFrame);
closure_field(StgCatchRetryFrame, running_alt_code);
closure_field(StgCatchRetryFrame, first_code);
closure_field(StgCatchRetryFrame, alt_code);
closure_field(StgCatchRetryFrame, first_code_trec);
closure_size(StgForeignObj);
closure_field(StgForeignObj,data);
......@@ -315,6 +329,10 @@ main(int argc, char *argv[])
closure_field(StgMVar,tail);
closure_field(StgMVar,value);
closure_size(StgTVar);
closure_field(StgTVar,current_value);
closure_field(StgTVar,first_wait_queue_entry);
closure_size(StgBCO);
closure_field(StgBCO, instrs);
closure_field(StgBCO, literals);
......
......@@ -92,5 +92,12 @@ StgWord16 closure_flags[] = {
/* RBH = */ ( _NS| _MUT|_UPT ),
/* EVACUATED = */ ( 0 ),
/* REMOTE_REF = */ (_HNF| _NS| _UPT ),
/* TVAR_WAIT_QUEUE = */ ( _NS| _MUT|_UPT ),
/* TVAR = */ (_HNF| _NS| _MUT|_UPT ),
/* TREC_CHUNK = */ ( _NS| _MUT|_UPT ),
/* TREC_HEADER = */ ( _NS| _MUT|_UPT ),
/* ATOMICALLY_FRAME = */ ( _BTM ),
/* CATCH_RETRY_FRAME = */ ( _BTM ),
/* CATCH_STM_FRAME = */ ( _BTM ),
/* STACK = */ (_HNF| _NS| _MUT )
};
......@@ -335,9 +335,34 @@ raisezh_fast
}
#endif
retry_pop_stack:
StgTSO_sp(CurrentTSO) = Sp;
frame_type = foreign "C" raiseExceptionHelper(CurrentTSO "ptr", R1 "ptr");
Sp = StgTSO_sp(CurrentTSO);
if (frame_type == ATOMICALLY_FRAME) {
/* The exception has reached the edge of a memory transaction. Check that
* the transaction is valid. If not then perhaps the exception should
* not have been thrown: re-run the transaction */
W_ trec;
W_ r;
trec = StgTSO_trec(CurrentTSO);
r = foreign "C" stmValidateTransaction(trec "ptr");
foreign "C" stmAbortTransaction(trec "ptr");
StgTSO_trec(CurrentTSO) = NO_TREC;
if (r) {
// Transaction was valid: continue searching for a catch frame
Sp = Sp + SIZEOF_StgAtomicallyFrame;
goto retry_pop_stack;
} else {
// Transaction was not valid: we retry the exception (otherwise continue
// with a further call to raiseExceptionHelper)
"ptr" trec = foreign "C" stmStartTransaction(NO_TREC "ptr");
StgTSO_trec(CurrentTSO) = trec;
R1 = StgAtomicallyFrame_code(Sp);
Sp_adj(-1);
jump RET_LBL(stg_ap_v);
}
}
if (frame_type == STOP_FRAME) {
/* We've stripped the entire stack, the thread is now dead. */
......@@ -350,10 +375,14 @@ raisezh_fast
jump StgReturn;
}
/* Ok, Sp points to the enclosing CATCH_FRAME. Pop everything down to
* and including this frame, update Su, push R1, and enter the handler.
/* Ok, Sp points to the enclosing CATCH_FRAME or CATCH_STM_FRAME. Pop everything
* down to and including this frame, update Su, push R1, and enter the handler.
*/
handler = StgCatchFrame_handler(Sp);
if (frame_type == CATCH_FRAME) {
handler = StgCatchFrame_handler(Sp);
} else {
handler = StgCatchSTMFrame_handler(Sp);
}
/* Restore the blocked/unblocked state for asynchronous exceptions
* at the CATCH_FRAME.
......@@ -364,11 +393,14 @@ raisezh_fast
*/
W_ frame;
frame = Sp;
Sp = Sp + SIZEOF_StgCatchFrame;
if (StgCatchFrame_exceptions_blocked(frame) == 0) {
Sp_adj(-1);
Sp(0) = stg_unblockAsyncExceptionszh_ret_info;
if (frame_type == CATCH_FRAME) {
Sp = Sp + SIZEOF_StgCatchFrame;
if (StgCatchFrame_exceptions_blocked(frame) == 0) {
Sp_adj(-1);
Sp(0) = stg_unblockAsyncExceptionszh_ret_info;
}
} else {
Sp = Sp + SIZEOF_StgCatchSTMFrame;
}
/* Ensure that async excpetions are blocked when running the handler.
......
......@@ -26,6 +26,7 @@
#include "ParTicky.h" // ToDo: move into Rts.h
#include "GCCompact.h"
#include "Signals.h"
#include "STM.h"
#if defined(GRAN) || defined(PAR)
# include "GranSimRts.h"
# include "ParallelRts.h"
......@@ -314,6 +315,9 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
blockUserSignals();
#endif
// tell the STM to discard any cached closures its hoping to re-use
stmPreGCHook();
// tell the stats department that we've started a GC
stat_startGC();
......@@ -1881,6 +1885,9 @@ loop:
case UPDATE_FRAME:
case STOP_FRAME:
case CATCH_FRAME:
case CATCH_STM_FRAME:
case CATCH_RETRY_FRAME:
case ATOMICALLY_FRAME:
// shouldn't see these
barf("evacuate: stack frame at %p\n", q);
......@@ -1989,6 +1996,18 @@ loop:
return to;
#endif
case TREC_HEADER:
return copy(q,sizeofW(StgTRecHeader),stp);
case TVAR_WAIT_QUEUE:
return copy(q,sizeofW(StgTVarWaitQueue),stp);
case TVAR:
return copy(q,sizeofW(StgTVar),stp);
case TREC_CHUNK:
return copy(q,sizeofW(StgTRecChunk),stp);
default:
barf("evacuate: strange closure type %d", (int)(info->type));
}
......@@ -2348,6 +2367,9 @@ scavengeTSO (StgTSO *tso)
(StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
}
// scavange current transaction record
(StgClosure *)tso->trec = evacuate((StgClosure *)tso->trec);