Commit 3700addb authored by Travis Whitaker's avatar Travis Whitaker

Correct closure observation, construction, and mutation on weak memory machines.

Here the following changes are introduced:
    - A read barrier machine op is added to Cmm.
    - The order in which a closure's fields are read and written is changed.
    - Memory barriers are added to RTS code to ensure correctness on
      out-or-order machines with weak memory ordering.

Cmm has a new CallishMachOp called MO_ReadBarrier. On weak memory machines, this
is lowered to an instruction that ensures memory reads that occur after said
instruction in program order are not performed before reads coming before said
instruction in program order. On machines with strong memory ordering properties
(e.g. X86, SPARC in TSO mode) no such instruction is necessary, so
MO_ReadBarrier is simply erased. However, such an instruction is necessary on
weakly ordered machines, e.g. ARM and PowerPC.

Weam memory ordering has consequences for how closures are observed and mutated.
For example, consider a closure that needs to be updated to an indirection. In
order for the indirection to be safe for concurrent observers to enter, said
observers must read the indirection's info table before they read the
indirectee. Furthermore, the entering observer makes assumptions about the
closure based on its info table contents, e.g. an INFO_TYPE of IND imples the
closure has an indirectee pointer that is safe to follow.

When a closure is updated with an indirection, both its info table and its
indirectee must be written. With weak memory ordering, these two writes can be
arbitrarily reordered, and perhaps even interleaved with other threads' reads
and writes (in the absence of memory barrier instructions). Consider this
example of a bad reordering:

- An updater writes to a closure's info table (INFO_TYPE is now IND).
- A concurrent observer branches upon reading the closure's INFO_TYPE as IND.
- A concurrent observer reads the closure's indirectee and enters it. (!!!)
- An updater writes the closure's indirectee.

Here the update to the indirectee comes too late and the concurrent observer has
jumped off into the abyss. Speculative execution can also cause us issues,
consider:

- An observer is about to case on a value in closure's info table.
- The observer speculatively reads one or more of closure's fields.
- An updater writes to closure's info table.
- The observer takes a branch based on the new info table value, but with the
  old closure fields!
- The updater writes to the closure's other fields, but its too late.

Because of these effects, reads and writes to a closure's info table must be
ordered carefully with respect to reads and writes to the closure's other
fields, and memory barriers must be placed to ensure that reads and writes occur
in program order. Specifically, updates to a closure must follow the following
pattern:

- Update the closure's (non-info table) fields.
- Write barrier.
- Update the closure's info table.

Observing a closure's fields must follow the following pattern:

- Read the closure's info pointer.
- Read barrier.
- Read the closure's (non-info table) fields.

This patch updates RTS code to obey this pattern. This should fix long-standing
SMP bugs on ARM (specifically newer aarch64 microarchitectures supporting
out-of-order execution) and PowerPC. This fixesd issue #15449.
parent 6113d0d4
Pipeline #4620 failed with stages
in 196 minutes and 8 seconds
......@@ -589,6 +589,7 @@ data CallishMachOp
| MO_SubIntC Width
| MO_U_Mul2 Width
| MO_ReadBarrier
| MO_WriteBarrier
| MO_Touch -- Keep variables live (when using interior pointers)
......
......@@ -999,6 +999,7 @@ machOps = listToUFM $
callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr]))
callishMachOps = listToUFM $
map (\(x, y) -> (mkFastString x, y)) [
( "read_barrier", (,) MO_ReadBarrier ),
( "write_barrier", (,) MO_WriteBarrier ),
( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),
( "memset", memcpyLikeTweakArgs MO_Memset ),
......
......@@ -808,6 +808,7 @@ pprCallishMachOp_for_C mop
MO_F32_Exp -> text "expf"
MO_F32_Sqrt -> text "sqrtf"
MO_F32_Fabs -> text "fabsf"
MO_ReadBarrier -> text "read_barrier"
MO_WriteBarrier -> text "write_barrier"
MO_Memcpy _ -> text "memcpy"
MO_Memset _ -> text "memset"
......
......@@ -169,17 +169,25 @@ barrier = do
let s = Fence False SyncSeqCst
return (unitOL s, [])
-- | Insert a 'barrier', unless the target platform is in the provided list of
-- exceptions (where no code will be emitted instead).
barrierUnless :: [Arch] -> LlvmM StmtData
barrierUnless exs = do
platform <- getLlvmPlatform
if platformArch platform `elem` exs
then return (nilOL, [])
else barrier
-- | Foreign Calls
genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual]
-> LlvmM StmtData
-- Write barrier needs to be handled specially as it is implemented as an LLVM
-- intrinsic function.
-- Barriers need to be handled specially as they are implemented as LLVM
-- intrinsic functions.
genCall (PrimTarget MO_ReadBarrier) _ _ =
barrierUnless [ArchX86, ArchX86_64, ArchSPARC]
genCall (PrimTarget MO_WriteBarrier) _ _ = do
platform <- getLlvmPlatform
if platformArch platform `elem` [ArchX86, ArchX86_64, ArchSPARC]
then return (nilOL, [])
else barrier
barrierUnless [ArchX86, ArchX86_64, ArchSPARC]
genCall (PrimTarget MO_Touch) _ _
= return (nilOL, [])
......@@ -824,6 +832,7 @@ cmmPrimOpFunctions mop = do
-- We support MO_U_Mul2 through ordinary LLVM mul instruction, see the
-- appropriate case of genCall.
MO_U_Mul2 {} -> unsupported
MO_ReadBarrier -> unsupported
MO_WriteBarrier -> unsupported
MO_Touch -> unsupported
MO_UF_Conv _ -> unsupported
......
......@@ -1122,6 +1122,8 @@ genCCall :: ForeignTarget -- function to call
-> [CmmFormal] -- where to put the result
-> [CmmActual] -- arguments (of mixed type)
-> NatM InstrBlock
genCCall (PrimTarget MO_ReadBarrier) _ _
= return $ unitOL LWSYNC
genCCall (PrimTarget MO_WriteBarrier) _ _
= return $ unitOL LWSYNC
......@@ -2026,6 +2028,7 @@ genCCall' dflags gcp target dest_regs args
MO_AddIntC {} -> unsupported
MO_SubIntC {} -> unsupported
MO_U_Mul2 {} -> unsupported
MO_ReadBarrier -> unsupported
MO_WriteBarrier -> unsupported
MO_Touch -> unsupported
MO_Prefetch_Data _ -> unsupported
......
......@@ -401,6 +401,8 @@ genCCall
--
-- In the SPARC case we don't need a barrier.
--
genCCall (PrimTarget MO_ReadBarrier) _ _
= return $ nilOL
genCCall (PrimTarget MO_WriteBarrier) _ _
= return $ nilOL
......@@ -686,6 +688,7 @@ outOfLineMachOp_table mop
MO_AddIntC {} -> unsupported
MO_SubIntC {} -> unsupported
MO_U_Mul2 {} -> unsupported
MO_ReadBarrier -> unsupported
MO_WriteBarrier -> unsupported
MO_Touch -> unsupported
(MO_Prefetch_Data _) -> unsupported
......
......@@ -1888,8 +1888,9 @@ genCCall dflags _ (PrimTarget (MO_Memset align)) _
dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone
(ImmInteger (n - i))
genCCall _ _ (PrimTarget MO_ReadBarrier) _ _ _ = return nilOL
genCCall _ _ (PrimTarget MO_WriteBarrier) _ _ _ = return nilOL
-- write barrier compiles to no code on x86/x86-64;
-- barriers compile to no code on x86/x86-64;
-- we keep it this long in order to prevent earlier optimisations.
genCCall _ _ (PrimTarget MO_Touch) _ _ _ = return nilOL
......@@ -2958,6 +2959,7 @@ outOfLineCmmOp bid mop res args
MO_AddWordC {} -> unsupported
MO_SubWordC {} -> unsupported
MO_U_Mul2 {} -> unsupported
MO_ReadBarrier -> unsupported
MO_WriteBarrier -> unsupported
MO_Touch -> unsupported
(MO_Prefetch_Data _ ) -> unsupported
......
......@@ -303,7 +303,8 @@
#define ENTER_(ret,x) \
again: \
W_ info; \
LOAD_INFO(ret,x) \
LOAD_INFO(ret,x) \
prim_read_barrier; \
switch [INVALID_OBJECT .. N_CLOSURE_TYPES] \
(TO_W_( %INFO_TYPE(%STD_INFO(info)) )) { \
case \
......@@ -626,6 +627,11 @@
#define OVERWRITING_CLOSURE_OFS(c,n) /* nothing */
#endif
#if defined(THREADED_RTS)
#define prim_read_barrier prim %read_barrier()
#else
#define prim_read_barrier /* nothing */
#endif
#if defined(THREADED_RTS)
#define prim_write_barrier prim %write_barrier()
#else
......
......@@ -80,31 +80,43 @@ INLINE_HEADER StgThunkInfoTable *itbl_to_thunk_itbl(const StgInfoTable *i) {retu
INLINE_HEADER StgConInfoTable *itbl_to_con_itbl(const StgInfoTable *i) {return (StgConInfoTable *)i;}
#endif
// There should always be a load-load barrier between reading an info table and
// reading any other part of a closure, so these macros include such a barrier.
EXTERN_INLINE const StgInfoTable *get_itbl(const StgClosure *c);
EXTERN_INLINE const StgInfoTable *get_itbl(const StgClosure *c)
{
return INFO_PTR_TO_STRUCT(c->header.info);
const StgInfoTable *x = INFO_PTR_TO_STRUCT(c->header.info);
load_load_barrier();
return x;
}
EXTERN_INLINE const StgRetInfoTable *get_ret_itbl(const StgClosure *c);
EXTERN_INLINE const StgRetInfoTable *get_ret_itbl(const StgClosure *c)
{
return RET_INFO_PTR_TO_STRUCT(c->header.info);
const StgRetInfoTable *x = RET_INFO_PTR_TO_STRUCT(c->header.info);
load_load_barrier();
return x;
}
INLINE_HEADER const StgFunInfoTable *get_fun_itbl(const StgClosure *c)
{
return FUN_INFO_PTR_TO_STRUCT(c->header.info);
const StgFunInfoTable *x = FUN_INFO_PTR_TO_STRUCT(c->header.info);
load_load_barrier();
return x;
}
INLINE_HEADER const StgThunkInfoTable *get_thunk_itbl(const StgClosure *c)
{
return THUNK_INFO_PTR_TO_STRUCT(c->header.info);
const StgThunkInfoTable *x = THUNK_INFO_PTR_TO_STRUCT(c->header.info);
load_load_barrier();
return x;
}
INLINE_HEADER const StgConInfoTable *get_con_itbl(const StgClosure *c)
{
return CON_INFO_PTR_TO_STRUCT((c)->header.info);
const StgConInfoTable *x = CON_INFO_PTR_TO_STRUCT((c)->header.info);
load_load_barrier();
return x;
}
INLINE_HEADER StgHalfWord GET_TAG(const StgClosure *con)
......
......@@ -64,6 +64,7 @@ again:
W_ arity;
untaggedfun = UNTAG(fun);
info = %INFO_PTR(untaggedfun);
prim_read_barrier;
switch [INVALID_OBJECT .. N_CLOSURE_TYPES]
(TO_W_( %INFO_TYPE(%STD_INFO(info)) )) {
case
......@@ -104,7 +105,6 @@ again:
CCS_ALLOC(BYTES_TO_WDS(SIZEOF_StgPAP), CCS_OVERHEAD);
P_ pap;
pap = Hp - SIZEOF_StgPAP + WDS(1);
SET_HDR(pap, stg_PAP_info, CCCS);
StgPAP_arity(pap) = arity;
if (arity <= TAG_MASK) {
// TODO: Shouldn't this already be tagged? If not why did we
......@@ -113,6 +113,8 @@ again:
}
StgPAP_fun(pap) = fun;
StgPAP_n_args(pap) = 0;
prim_write_barrier;
SET_HDR(pap, stg_PAP_info, CCCS);
return (pap);
}
}
......@@ -132,7 +134,6 @@ again:
pap = Hp - size + WDS(1);
// We'll lose the original PAP, so we should enter its CCS
ccall enterFunCCS(BaseReg "ptr", StgHeader_ccs(untaggedfun) "ptr");
SET_HDR(pap, stg_PAP_info, CCCS);
StgPAP_arity(pap) = StgPAP_arity(untaggedfun);
StgPAP_n_args(pap) = StgPAP_n_args(untaggedfun);
StgPAP_fun(pap) = StgPAP_fun(fun);
......@@ -140,6 +141,8 @@ again:
i = TO_W_(StgPAP_n_args(untaggedfun));
loop:
if (i == 0) {
prim_write_barrier;
SET_HDR(pap, stg_PAP_info, CCCS);
return (pap);
}
i = i - 1;
......@@ -176,6 +179,7 @@ again:
// pointer now.
untaggedfun = UNTAG(fun);
info = %INFO_PTR(untaggedfun);
prim_read_barrier;
jump %ENTRY_CODE(info)
(stg_restore_cccs_eval_info, CCCS)
......@@ -282,6 +286,7 @@ for:
info = %GET_FUN_INFO(UNTAG(R1));
W_ type;
type = TO_W_(StgFunInfoExtra_fun_type(info));
prim_read_barrier;
if (type == ARG_GEN) {
jump StgFunInfoExtra_slow_apply(info) [R1];
}
......@@ -360,6 +365,7 @@ for:
info = %GET_FUN_INFO(UNTAG(R1));
W_ type;
type = TO_W_(StgFunInfoExtra_fun_type(info));
prim_read_barrier;
if (type == ARG_GEN) {
jump StgFunInfoExtra_slow_apply(info) [R1];
}
......@@ -424,12 +430,14 @@ for:
TICK_ENT_VIA_NODE();
#if defined(NO_ARG_REGS)
prim_read_barrier;
jump %GET_ENTRY(UNTAG(R1)) [R1];
#else
W_ info;
info = %GET_FUN_INFO(UNTAG(R1));
W_ type;
type = TO_W_(StgFunInfoExtra_fun_type(info));
prim_read_barrier;
if (type == ARG_GEN) {
jump StgFunInfoExtra_slow_apply(info) [R1];
}
......@@ -648,6 +656,7 @@ INFO_TABLE(stg_AP_STACK,/*special layout*/0,0,AP_STACK,"AP_STACK","AP_STACK")
*/
W_ old_info;
(old_info) = prim %cmpxchgW(ap, stg_AP_STACK_info, stg_WHITEHOLE_info);
prim_read_barrier;
if (old_info != stg_AP_STACK_info) {
/* someone else beat us to it */
jump ENTRY_LBL(stg_WHITEHOLE) (ap);
......
......@@ -69,6 +69,7 @@ eval:
tag = GETTAG(p);
p = UNTAG(p);
info = %INFO_PTR(p);
prim_read_barrier;
type = TO_W_(%INFO_TYPE(%STD_INFO(info)));
switch [0 .. N_CLOSURE_TYPES] type {
......@@ -168,7 +169,6 @@ eval:
cards = SIZEOF_StgMutArrPtrs + WDS(ptrs);
ALLOCATE(compact, BYTES_TO_WDS(size), p, to, tag);
P_[pp] = tag | to;
SET_HDR(to, StgHeader_info(p), StgHeader_ccs(p));
StgMutArrPtrs_ptrs(to) = ptrs;
StgMutArrPtrs_size(to) = StgMutArrPtrs_size(p);
prim %memcpy(to + cards, p + cards , size - cards, 1);
......@@ -182,6 +182,8 @@ eval:
i = i + 1;
goto loop0;
}
prim_write_barrier;
SET_HDR(to, StgHeader_info(p), StgHeader_ccs(p));
return();
}
......@@ -198,7 +200,6 @@ eval:
ptrs = StgSmallMutArrPtrs_ptrs(p);
ALLOCATE(compact, BYTES_TO_WDS(SIZEOF_StgSmallMutArrPtrs) + ptrs, p, to, tag);
P_[pp] = tag | to;
SET_HDR(to, StgHeader_info(p), StgHeader_ccs(p));
StgSmallMutArrPtrs_ptrs(to) = ptrs;
i = 0;
loop1:
......@@ -210,6 +211,8 @@ eval:
i = i + 1;
goto loop1;
}
prim_write_barrier;
SET_HDR(to, StgHeader_info(p), StgHeader_ccs(p));
return();
}
......@@ -235,7 +238,6 @@ eval:
ALLOCATE(compact, size, p, to, tag);
P_[pp] = tag | to;
SET_HDR(to, StgHeader_info(p), StgHeader_ccs(p));
// First, copy the non-pointers
if (nptrs > 0) {
......@@ -245,6 +247,8 @@ eval:
i = i + 1;
if (i < ptrs + nptrs) ( likely: True ) goto loop2;
}
prim_write_barrier;
SET_HDR(to, StgHeader_info(p), StgHeader_ccs(p));
// Next, recursively compact and copy the pointers
if (ptrs == 0) { return(); }
......
......@@ -249,10 +249,11 @@ StgClosure * newEmptyPAP (Capability *cap,
uint32_t arity)
{
StgPAP *pap = (StgPAP *)allocate(cap, sizeofW(StgPAP));
SET_HDR(pap, &stg_PAP_info, cap->r.rCCCS);
pap->arity = arity;
pap->n_args = 0;
pap->fun = tagged_obj;
write_barrier();
SET_HDR(pap, &stg_PAP_info, cap->r.rCCCS);
return (StgClosure *)pap;
}
......@@ -266,7 +267,6 @@ StgClosure * copyPAP (Capability *cap, StgPAP *oldpap)
uint32_t size = PAP_sizeW(oldpap->n_args);
StgPAP *pap = (StgPAP *)allocate(cap, size);
enterFunCCS(&cap->r, oldpap->header.prof.ccs);
SET_HDR(pap, &stg_PAP_info, cap->r.rCCCS);
pap->arity = oldpap->arity;
pap->n_args = oldpap->n_args;
pap->fun = oldpap->fun;
......@@ -274,6 +274,8 @@ StgClosure * copyPAP (Capability *cap, StgPAP *oldpap)
for (i = 0; i < ((StgPAP *)pap)->n_args; i++) {
pap->payload[i] = oldpap->payload[i];
}
write_barrier();
SET_HDR(pap, &stg_PAP_info, cap->r.rCCCS);
return (StgClosure *)pap;
}
......@@ -481,8 +483,9 @@ eval_obj:
{
StgUpdateFrame *__frame;
__frame = (StgUpdateFrame *)Sp;
SET_INFO((StgClosure *)__frame, (StgInfoTable *)&stg_upd_frame_info);
__frame->updatee = (StgClosure *)(ap);
write_barrier();
SET_INFO((StgClosure *)__frame, (StgInfoTable *)&stg_upd_frame_info);
}
ENTER_CCS_THUNK(cap,ap);
......@@ -799,7 +802,6 @@ do_apply:
// build a new PAP and return it.
StgPAP *new_pap;
new_pap = (StgPAP *)allocate(cap, PAP_sizeW(pap->n_args + m));
SET_HDR(new_pap,&stg_PAP_info,cap->r.rCCCS);
new_pap->arity = pap->arity - n;
new_pap->n_args = pap->n_args + m;
new_pap->fun = pap->fun;
......@@ -809,6 +811,8 @@ do_apply:
for (i = 0; i < m; i++) {
new_pap->payload[pap->n_args + i] = (StgClosure *)SpW(i);
}
write_barrier();
SET_HDR(new_pap,&stg_PAP_info,cap->r.rCCCS);
tagged_obj = (StgClosure *)new_pap;
Sp_addW(m);
goto do_return;
......@@ -844,13 +848,14 @@ do_apply:
StgPAP *pap;
uint32_t i;
pap = (StgPAP *)allocate(cap, PAP_sizeW(m));
SET_HDR(pap, &stg_PAP_info,cap->r.rCCCS);
pap->arity = arity - n;
pap->fun = obj;
pap->n_args = m;
for (i = 0; i < m; i++) {
pap->payload[i] = (StgClosure *)SpW(i);
}
write_barrier();
SET_HDR(pap, &stg_PAP_info,cap->r.rCCCS);
tagged_obj = (StgClosure *)pap;
Sp_addW(m);
goto do_return;
......@@ -1081,7 +1086,6 @@ run_BCO:
// the BCO
size_words = BCO_BITMAP_SIZE(obj) + 2;
new_aps = (StgAP_STACK *) allocate(cap, AP_STACK_sizeW(size_words));
SET_HDR(new_aps,&stg_AP_STACK_info,cap->r.rCCCS);
new_aps->size = size_words;
new_aps->fun = &stg_dummy_ret_closure;
......@@ -1095,6 +1099,9 @@ run_BCO:
new_aps->payload[i] = (StgClosure *)SpW(i-2);
}
write_barrier();
SET_HDR(new_aps,&stg_AP_STACK_info,cap->r.rCCCS);
// Arrange the stack to call the breakpoint IO action, and
// continue execution of this BCO when the IO action returns.
//
......@@ -1421,9 +1428,10 @@ run_BCO:
StgAP* ap;
int n_payload = BCO_NEXT;
ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
SpW(-1) = (W_)ap;
ap->n_args = n_payload;
write_barrier();
SET_HDR(ap, &stg_AP_info, cap->r.rCCCS)
SpW(-1) = (W_)ap;
Sp_subW(1);
goto nextInsn;
}
......@@ -1432,9 +1440,10 @@ run_BCO:
StgAP* ap;
int n_payload = BCO_NEXT;
ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
SpW(-1) = (W_)ap;
ap->n_args = n_payload;
SET_HDR(ap, &stg_AP_NOUPD_info, cap->r.rCCCS)
write_barrier();
SpW(-1) = (W_)ap;
Sp_subW(1);
goto nextInsn;
}
......@@ -1444,10 +1453,11 @@ run_BCO:
int arity = BCO_NEXT;
int n_payload = BCO_NEXT;
pap = (StgPAP*)allocate(cap, PAP_sizeW(n_payload));
SpW(-1) = (W_)pap;
pap->n_args = n_payload;
pap->arity = arity;
write_barrier();
SET_HDR(pap, &stg_PAP_info, cap->r.rCCCS)
SpW(-1) = (W_)pap;
Sp_subW(1);
goto nextInsn;
}
......@@ -1518,16 +1528,18 @@ run_BCO:
int o_itbl = BCO_GET_LARGE_ARG;
int n_words = BCO_NEXT;
StgInfoTable* itbl = INFO_PTR_TO_STRUCT((StgInfoTable *)BCO_LIT(o_itbl));
load_load_barrier();
int request = CONSTR_sizeW( itbl->layout.payload.ptrs,
itbl->layout.payload.nptrs );
StgClosure* con = (StgClosure*)allocate_NONUPD(cap,request);
ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), cap->r.rCCCS);
for (i = 0; i < n_words; i++) {
con->payload[i] = (StgClosure*)SpW(i);
}
Sp_addW(n_words);
Sp_subW(1);
write_barrier();
SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), cap->r.rCCCS);
SpW(0) = (W_)con;
IF_DEBUG(interpreter,
debugBelch("\tBuilt ");
......
......@@ -28,6 +28,7 @@ void sendMessage(Capability *from_cap, Capability *to_cap, Message *msg)
#if defined(DEBUG)
{
const StgInfoTable *i = msg->header.info;
load_load_barrier();
if (i != &stg_MSG_THROWTO_info &&
i != &stg_MSG_BLACKHOLE_info &&
i != &stg_MSG_TRY_WAKEUP_info &&
......@@ -70,6 +71,7 @@ executeMessage (Capability *cap, Message *m)
loop:
write_barrier(); // allow m->header to be modified by another thread
i = m->header.info;
load_load_barrier();
if (i == &stg_MSG_TRY_WAKEUP_info)
{
StgTSO *tso = ((MessageWakeup *)m)->tso;
......@@ -173,6 +175,7 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg)
"blackhole %p", (W_)msg->tso->id, msg->bh);
info = bh->header.info;
load_load_barrier();
// If we got this message in our inbox, it might be that the
// BLACKHOLE has already been updated, and GC has shorted out the
......@@ -194,8 +197,10 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg)
loop:
// NB. VOLATILE_LOAD(), because otherwise gcc hoists the load
// and turns this into an infinite loop.
write_barrier();
p = UNTAG_CLOSURE((StgClosure*)VOLATILE_LOAD(&((StgInd*)bh)->indirectee));
info = p->header.info;
load_load_barrier();
if (info == &stg_IND_info)
{
......@@ -226,7 +231,6 @@ loop:
bq = (StgBlockingQueue*)allocate(cap, sizeofW(StgBlockingQueue));
// initialise the BLOCKING_QUEUE object
SET_HDR(bq, &stg_BLOCKING_QUEUE_DIRTY_info, CCS_SYSTEM);
bq->bh = bh;
bq->queue = msg;
bq->owner = owner;
......@@ -238,6 +242,8 @@ loop:
// a collision to update a BLACKHOLE and a BLOCKING_QUEUE
// becomes orphaned (see updateThunk()).
bq->link = owner->bq;
write_barrier();
SET_HDR(bq, &stg_BLOCKING_QUEUE_DIRTY_info, CCS_SYSTEM);
owner->bq = bq;
dirty_TSO(cap, owner); // we modified owner->bq
......@@ -289,6 +295,7 @@ loop:
recordClosureMutated(cap,(StgClosure*)msg);
if (info == &stg_BLOCKING_QUEUE_CLEAN_info) {
write_barrier();
bq->header.info = &stg_BLOCKING_QUEUE_DIRTY_info;
recordClosureMutated(cap,(StgClosure*)bq);
}
......@@ -319,6 +326,7 @@ StgTSO * blackHoleOwner (StgClosure *bh)
StgClosure *p;
info = bh->header.info;
load_load_barrier();
if (info != &stg_BLACKHOLE_info &&
info != &stg_CAF_BLACKHOLE_info &&
......@@ -332,8 +340,10 @@ StgTSO * blackHoleOwner (StgClosure *bh)
loop:
// NB. VOLATILE_LOAD(), because otherwise gcc hoists the load
// and turns this into an infinite loop.
write_barrier();
p = UNTAG_CLOSURE((StgClosure*)VOLATILE_LOAD(&((StgInd*)bh)->indirectee));
info = p->header.info;
load_load_barrier();
if (info == &stg_IND_info) goto loop;
......
This diff is collapsed.
......@@ -870,6 +870,7 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
ap->payload[i] = (StgClosure *)*sp++;
}
write_barrier();
SET_HDR(ap,&stg_AP_STACK_info,
((StgClosure *)frame)->header.prof.ccs /* ToDo */);
TICK_ALLOC_UP_THK(WDS(words+1),0);
......@@ -921,6 +922,7 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
ap->payload[i] = (StgClosure *)*sp++;
}
write_barrier();
SET_HDR(ap,&stg_AP_STACK_NOUPD_info,stack->header.prof.ccs);
TICK_ALLOC_SE_THK(WDS(words+1),0);
......@@ -959,6 +961,7 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
//
raise = (StgThunk *)allocate(cap,sizeofW(StgThunk)+1);
TICK_ALLOC_SE_THK(WDS(1),0);
write_barrier();
SET_HDR(raise,&stg_raise_info,cf->header.prof.ccs);
raise->payload[0] = exception;
......@@ -1039,8 +1042,9 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
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;
write_barrier();
SET_HDR(atomically,&stg_atomically_info,af->header.prof.ccs);
// discard stack up to and including the ATOMICALLY_FRAME
frame += sizeofW(StgAtomicallyFrame);
......
......@@ -30,8 +30,9 @@ HaskellObj
rts_mkChar (Capability *cap, HsChar c)
{
StgClosure *p = (StgClosure *)allocate(cap, CONSTR_sizeW(0,1));
SET_HDR(p, Czh_con_info, CCS_SYSTEM);
p->payload[0] = (StgClosure *)(StgWord)(StgChar)c;
write_barrier();
SET_HDR(p, Czh_con_info, CCS_SYSTEM);
return p;
}
......@@ -39,8 +40,9 @@ HaskellObj
rts_mkInt (Capability *cap, HsInt i)
{
StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
SET_HDR(p, Izh_con_info, CCS_SYSTEM);
p->payload[0] = (StgClosure *)(StgInt)i;
write_barrier();
SET_HDR(p, Izh_con_info, CCS_SYSTEM);
return p;
}
......@@ -48,9 +50,10 @@ HaskellObj
rts_mkInt8 (Capability *cap, HsInt8 i)
{
StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
/* Make sure we mask out the bits above the lowest 8 */
p->payload[0] = (StgClosure *)(StgInt)i;
write_barrier();
SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
return p;
}
......@@ -58,9 +61,10 @@ HaskellObj
rts_mkInt16 (Capability *cap, HsInt16 i)
{
StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
/* Make sure we mask out the relevant bits */
p->payload[0] = (StgClosure *)(StgInt)i;
write_barrier();
SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
return p;
}
......@@ -68,8 +72,9 @@ HaskellObj
rts_mkInt32 (Capability *cap, HsInt32 i)
{
StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
p->payload[0] = (StgClosure *)(StgInt)i;
write_barrier();
SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
return p;
}
......@@ -77,8 +82,9 @@ HaskellObj
rts_mkInt64 (Capability *cap, HsInt64 i)
{
StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,2));
SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
ASSIGN_Int64((P_)&(p->payload[0]), i);
write_barrier();
SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
return p;
}
......@@ -86,8 +92,9 @@ HaskellObj
rts_mkWord (Capability *cap, HsWord i)
{
StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
p->payload[0] = (StgClosure *)(StgWord)i;
write_barrier();
SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
return p;
}
......@@ -96,8 +103,9 @@ rts_mkWord8 (Capability *cap, HsWord8 w)
{
/* see rts_mkInt* comments */
StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
write_barrier();
SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
return p;
}
......@@ -106,8 +114,9 @@ rts_mkWord16 (Capability *cap, HsWord16 w)
{
/* see rts_mkInt* comments */
StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
write_barrier();
SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
return p;
}
......@@ -116,8 +125,9 @@ rts_mkWord32 (Capability *cap, HsWord32 w)
{
/* see rts_mkInt* comments */
StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
p->payload[0] = (StgClosure *)(StgWord)(w & 0xffffffff);
write_barrier();
SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
return p;
}
......@@ -126,8 +136,9 @@ rts_mkWord64 (Capability *cap, HsWord64 w)
{
StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,2));
/* see mk_Int8 comment */
SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
ASSIGN_Word64((P_)&(p->payload[0]), w);
write_barrier();
SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
return p;
}
......@@ -136,8 +147,9 @@ HaskellObj
rts_mkFloat (Capability *cap, HsFloat f)
{
StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
ASSIGN_FLT((P_)