MessageThrowTo *
throwTo (Capability *cap, // the Capability we hold
StgTSO *source, // the TSO sending the exception (or NULL)
StgTSO *target, // the TSO receiving the exception
StgClosure *exception) // the exception closure
{
MessageThrowTo *msg;
msg = (MessageThrowTo *) allocate(cap, sizeofW(MessageThrowTo));
// the message starts locked; see below
SET_HDR(msg, &stg_WHITEHOLE_info, CCS_SYSTEM);
msg->source = source;
msg->target = target;
msg->exception = exception;
switch (throwToMsg(cap, msg))
{
case THROWTO_SUCCESS:
// unlock the message now, otherwise we leave a WHITEHOLE in
// the heap (#6103)
SET_HDR(msg, &stg_MSG_THROWTO_info, CCS_SYSTEM);
return NULL;
case THROWTO_BLOCKED:
default:
// the caller will unlock the message when it is ready. We
// cannot unlock it yet, because the calling thread will need
// to tidy up its state first.
return msg;
}
}
static StgCompactNFDataBlock *
compactAppendBlock (Capability *cap,
StgCompactNFData *str,
StgWord aligned_size)
{
StgCompactNFDataBlock *block;
bdescr *bd;
block = compactAllocateBlockInternal(cap, aligned_size,
compactGetFirstBlock(str),
ALLOCATE_APPEND);
block->owner = str;
block->next = NULL;
ASSERT(str->last->next == NULL);
str->last->next = block;
str->last = block;
bd = Bdescr((P_)block);
bd->free = (StgPtr)((W_)block + sizeof(StgCompactNFDataBlock));
ASSERT(bd->free == (StgPtr)block + sizeofW(StgCompactNFDataBlock));
str->totalW += bd->blocks * BLOCK_SIZE_W;
return block;
}
STATIC_INLINE StgPtr
thread_AP_STACK (StgAP_STACK *ap)
{
thread(&ap->fun);
thread_stack((P_)ap->payload, (P_)ap->payload + ap->size);
return (P_)ap + sizeofW(StgAP_STACK) + ap->size;
}
void
LDV_recordDead( StgClosure *c, nat size )
{
void *id;
nat t;
counter *ctr;
if (era > 0 && closureSatisfiesConstraints(c)) {
size -= sizeofW(StgProfHeader);
ASSERT(LDVW(c) != 0);
if ((LDVW((c)) & LDV_STATE_MASK) == LDV_STATE_CREATE) {
t = (LDVW((c)) & LDV_CREATE_MASK) >> LDV_SHIFT;
if (t < era) {
if (RtsFlags.ProfFlags.bioSelector == NULL) {
censuses[t].void_total += (long)size;
censuses[era].void_total -= (long)size;
ASSERT(censuses[t].void_total < censuses[t].not_used);
} else {
id = closureIdentity(c);
ctr = lookupHashTable(censuses[t].hash, (StgWord)id);
ASSERT( ctr != NULL );
ctr->c.ldv.void_total += (long)size;
ctr = lookupHashTable(censuses[era].hash, (StgWord)id);
if (ctr == NULL) {
ctr = arenaAlloc(censuses[era].arena, sizeof(counter));
initLDVCtr(ctr);
insertHashTable(censuses[era].hash, (StgWord)id, ctr);
ctr->identity = id;
ctr->next = censuses[era].ctrs;
censuses[era].ctrs = ctr;
}
ctr->c.ldv.void_total -= (long)size;
}
}
} else {
HaskellObj
rts_mkDouble (Capability *cap, HsDouble d)
{
StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,sizeofW(StgDouble)));
SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
ASSIGN_DBL((P_)p->payload, (StgDouble)d);
return p;
}
HaskellObj
rts_mkFunPtr (Capability *cap, HsFunPtr a)
{
StgClosure *p = (StgClosure *)allocate(cap,sizeofW(StgHeader)+1);
SET_HDR(p, FunPtr_con_info, CCS_SYSTEM);
p->payload[0] = (StgClosure *)a;
return p;
}
void
evacuate_BLACKHOLE(StgClosure **p)
{
bdescr *bd;
uint32_t gen_no;
StgClosure *q;
const StgInfoTable *info;
q = *p;
// closure is required to be a heap-allocated BLACKHOLE
ASSERT(HEAP_ALLOCED_GC(q));
ASSERT(GET_CLOSURE_TAG(q) == 0);
bd = Bdescr((P_)q);
// blackholes can't be in a compact
ASSERT((bd->flags & BF_COMPACT) == 0);
// blackholes *can* be in a large object: when raiseAsync() creates an
// AP_STACK the payload might be large enough to create a large object.
// See #14497.
if (bd->flags & BF_LARGE) {
evacuate_large((P_)q);
return;
}
if (bd->flags & BF_EVACUATED) {
if (bd->gen_no < gct->evac_gen_no) {
gct->failed_to_evac = true;
TICK_GC_FAILED_PROMOTION();
}
return;
}
if (bd->flags & BF_MARKED) {
if (!is_marked((P_)q,bd)) {
mark((P_)q,bd);
push_mark_stack((P_)q);
}
return;
}
gen_no = bd->dest_no;
info = q->header.info;
if (IS_FORWARDING_PTR(info))
{
StgClosure *e = (StgClosure*)UN_FORWARDING_PTR(info);
*p = e;
if (gen_no < gct->evac_gen_no) { // optimisation
if (Bdescr((P_)e)->gen_no < gct->evac_gen_no) {
gct->failed_to_evac = true;
TICK_GC_FAILED_PROMOTION();
}
}
return;
}
ASSERT(INFO_PTR_TO_STRUCT(info)->type == BLACKHOLE);
copy(p,info,q,sizeofW(StgInd),gen_no);
}
void
checkHeapChunk(StgPtr start, StgPtr end)
{
StgPtr p;
nat size;
for (p=start; p<end; p+=size) {
ASSERT(LOOKS_LIKE_INFO_PTR(*p));
size = checkClosure((StgClosure *)p);
/* This is the smallest size of closure that can live in the heap. */
ASSERT( size >= MIN_PAYLOAD_SIZE + sizeofW(StgHeader) );
}
}
static struct stack_gap *
updateAdjacentFrames (Capability *cap, StgTSO *tso, StgUpdateFrame *upd,
uint32_t count, struct stack_gap *next)
{
StgClosure *updatee;
struct stack_gap *gap;
uint32_t i;
// The first one (highest address) is the frame we take the
// "master" updatee from; all the others will be made indirections
// to this one. It is essential that we do it this way around: we
// used to make the lowest-addressed frame the "master" frame and
// shuffle it down, but a bad case cropped up (#5505) where this
// happened repeatedly, generating a chain of indirections which
// the GC repeatedly traversed (indirection chains longer than one
// are not supposed to happen). So now after identifying a block
// of adjacent update frames we walk downwards again updating them
// all to point to the highest one, before squeezing out all but
// the highest one.
updatee = upd->updatee;
count--;
upd--;
gap = (struct stack_gap*)upd;
for (i = count; i > 0; i--, upd--) {
/*
* Check two things: that the two update frames
* don't point to the same object, and that the
* updatee_bypass isn't already an indirection.
* Both of these cases only happen when we're in a
* block hole-style loop (and there are multiple
* update frames on the stack pointing to the same
* closure), but they can both screw us up if we
* don't check.
*/
if (upd->updatee != updatee && !closure_IND(upd->updatee)) {
updateThunk(cap, tso, upd->updatee, updatee);
}
}
gap->gap_size = count * sizeofW(StgUpdateFrame);
gap->next_gap = next;
return gap;
}
STATIC_INLINE StgInd *
lockCAF (StgRegTable *reg, StgIndStatic *caf)
{
const StgInfoTable *orig_info;
Capability *cap = regTableToCapability(reg);
StgInd *bh;
orig_info = caf->header.info;
#ifdef THREADED_RTS
const StgInfoTable *cur_info;
if (orig_info == &stg_IND_STATIC_info ||
orig_info == &stg_WHITEHOLE_info) {
// already claimed by another thread; re-enter the CAF
return NULL;
}
cur_info = (const StgInfoTable *)
cas((StgVolatilePtr)&caf->header.info,
(StgWord)orig_info,
(StgWord)&stg_WHITEHOLE_info);
if (cur_info != orig_info) {
// already claimed by another thread; re-enter the CAF
return NULL;
}
// successfully claimed by us; overwrite with IND_STATIC
#endif
// For the benefit of revertCAFs(), save the original info pointer
caf->saved_info = orig_info;
// Allocate the blackhole indirection closure
bh = (StgInd *)allocate(cap, sizeofW(*bh));
SET_HDR(bh, &stg_CAF_BLACKHOLE_info, caf->header.prof.ccs);
bh->indirectee = (StgClosure *)cap->r.rCurrentTSO;
caf->indirectee = (StgClosure *)bh;
write_barrier();
SET_INFO((StgClosure*)caf,&stg_IND_STATIC_info);
return bh;
}
void checkHeapChain (bdescr *bd)
{
StgPtr p;
for (; bd != NULL; bd = bd->link) {
if(!(bd->flags & BF_SWEPT)) {
p = bd->start;
while (p < bd->free) {
nat size = checkClosure((StgClosure *)p);
/* This is the smallest size of closure that can live in the heap */
ASSERT( size >= MIN_PAYLOAD_SIZE + sizeofW(StgHeader) );
p += size;
/* skip over slop */
while (p < bd->free &&
(*p < 0x1000 || !LOOKS_LIKE_INFO_PTR(*p))) { p++; }
}
}
}
}
static void *
stgAllocStable(size_t size_in_bytes, StgStablePtr *stable)
{
StgArrWords* arr;
nat data_size_in_words, total_size_in_words;
/* round up to a whole number of words */
data_size_in_words = ROUNDUP_BYTES_TO_WDS(size_in_bytes);
total_size_in_words = sizeofW(StgArrWords) + data_size_in_words;
/* allocate and fill it in */
arr = (StgArrWords *)allocate(total_size_in_words);
SET_ARR_HDR(arr, &stg_ARR_WORDS_info, CCCS, size_in_bytes);
/* obtain a stable ptr */
*stable = getStablePtr((StgPtr)arr);
/* and return a ptr to the goods inside the array */
return(&(arr->payload));
}
/*
Check that all TSOs have been evacuated.
Optionally also check the sanity of the TSOs.
*/
void
checkGlobalTSOList (rtsBool checkTSOs)
{
StgTSO *tso;
nat g;
for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
for (tso=generations[g].threads; tso != END_TSO_QUEUE;
tso = tso->global_link) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso));
ASSERT(get_itbl((StgClosure *)tso)->type == TSO);
if (checkTSOs)
checkTSO(tso);
// If this TSO is dirty and in an old generation, it better
// be on the mutable list.
if (tso->dirty) {
ASSERT(Bdescr((P_)tso)->gen_no == 0 || (tso->flags & TSO_MARKED));
tso->flags &= ~TSO_MARKED;
}
{
StgStack *stack;
StgUnderflowFrame *frame;
stack = tso->stackobj;
while (1) {
if (stack->dirty & 1) {
ASSERT(Bdescr((P_)stack)->gen_no == 0 || (stack->dirty & TSO_MARKED));
stack->dirty &= ~TSO_MARKED;
}
frame = (StgUnderflowFrame*) (stack->stack + stack->stack_size
- sizeofW(StgUnderflowFrame));
if (frame->info != &stg_stack_underflow_frame_info
|| frame->next_chunk == (StgStack*)END_TSO_QUEUE) break;
stack = frame->next_chunk;
}
}
}
}
}
static void searchHeapBlocks (HashTable *addrs, bdescr *bd)
{
StgPtr p;
StgInfoTable *info;
nat size;
rtsBool prim;
for (; bd != NULL; bd = bd->link) {
if (bd->flags & BF_PINNED) {
// Assume that objects in PINNED blocks cannot refer to
continue;
}
p = bd->start;
while (p < bd->free) {
info = get_itbl((StgClosure *)p);
prim = rtsFalse;
switch (info->type) {
case THUNK:
size = thunk_sizeW_fromITBL(info);
break;
case THUNK_1_1:
case THUNK_0_2:
case THUNK_2_0:
size = sizeofW(StgThunkHeader) + 2;
break;
case THUNK_1_0:
case THUNK_0_1:
case THUNK_SELECTOR:
size = sizeofW(StgThunkHeader) + 1;
break;
case CONSTR:
case FUN:
case FUN_1_0:
case FUN_0_1:
case FUN_1_1:
case FUN_0_2:
case FUN_2_0:
case CONSTR_1_0:
case CONSTR_0_1:
case CONSTR_1_1:
case CONSTR_0_2:
case CONSTR_2_0:
size = sizeW_fromITBL(info);
break;
case BLACKHOLE:
case BLOCKING_QUEUE:
prim = rtsTrue;
size = sizeW_fromITBL(info);
break;
case IND:
// Special case/Delicate Hack: INDs don't normally
// appear, since we're doing this heap census right
// after GC. However, GarbageCollect() also does
// resurrectThreads(), which can update some
// blackholes when it calls raiseAsync() on the
// resurrected threads. So we know that any IND will
// be the size of a BLACKHOLE.
prim = rtsTrue;
size = BLACKHOLE_sizeW();
break;
case BCO:
prim = rtsTrue;
size = bco_sizeW((StgBCO *)p);
break;
case MVAR_CLEAN:
case MVAR_DIRTY:
case TVAR:
case WEAK:
case PRIM:
case MUT_PRIM:
case MUT_VAR_CLEAN:
case MUT_VAR_DIRTY:
prim = rtsTrue;
size = sizeW_fromITBL(info);
break;
case AP:
prim = rtsTrue;
size = ap_sizeW((StgAP *)p);
break;
case PAP:
prim = rtsTrue;
size = pap_sizeW((StgPAP *)p);
break;
case AP_STACK:
{
StgAP_STACK *ap = (StgAP_STACK *)p;
prim = rtsTrue;
size = ap_stack_sizeW(ap);
searchStackChunk(addrs, (StgPtr)ap->payload,
(StgPtr)ap->payload + ap->size);
break;
}
case ARR_WORDS:
prim = rtsTrue;
size = arr_words_sizeW((StgArrBytes*)p);
break;
case MUT_ARR_PTRS_CLEAN:
case MUT_ARR_PTRS_DIRTY:
case MUT_ARR_PTRS_FROZEN:
case MUT_ARR_PTRS_FROZEN0:
prim = rtsTrue;
size = mut_arr_ptrs_sizeW((StgMutArrPtrs *)p);
break;
case SMALL_MUT_ARR_PTRS_CLEAN:
case SMALL_MUT_ARR_PTRS_DIRTY:
case SMALL_MUT_ARR_PTRS_FROZEN:
case SMALL_MUT_ARR_PTRS_FROZEN0:
prim = rtsTrue;
size = small_mut_arr_ptrs_sizeW((StgSmallMutArrPtrs *)p);
break;
case TSO:
prim = rtsTrue;
size = sizeofW(StgTSO);
break;
case STACK: {
StgStack *stack = (StgStack*)p;
prim = rtsTrue;
searchStackChunk(addrs, stack->sp,
stack->stack + stack->stack_size);
size = stack_sizeW(stack);
break;
}
case TREC_CHUNK:
prim = rtsTrue;
size = sizeofW(StgTRecChunk);
break;
default:
barf("heapCensus, unknown object: %d", info->type);
}
if (!prim) {
checkAddress(addrs,info);
}
p += size;
}
}
}
int
main(int argc, char *argv[])
{
#ifndef GEN_HASKELL
printf("/* This file is created automatically. Do not edit by hand.*/\n\n");
printf("#define STD_HDR_SIZE %" FMT_SizeT "\n", (size_t)sizeofW(StgHeader) - sizeofW(StgProfHeader));
/* grrr.. PROFILING is on so we need to subtract sizeofW(StgProfHeader) */
printf("#define PROF_HDR_SIZE %" FMT_SizeT "\n", (size_t)sizeofW(StgProfHeader));
printf("#define BLOCK_SIZE %u\n", BLOCK_SIZE);
printf("#define MBLOCK_SIZE %u\n", MBLOCK_SIZE);
printf("#define BLOCKS_PER_MBLOCK %" FMT_SizeT "\n", (lnat)BLOCKS_PER_MBLOCK);
// could be derived, but better to save doing the calculation twice
printf("\n\n");
#endif
field_offset(StgRegTable, rR1);
field_offset(StgRegTable, rR2);
field_offset(StgRegTable, rR3);
field_offset(StgRegTable, rR4);
field_offset(StgRegTable, rR5);
field_offset(StgRegTable, rR6);
field_offset(StgRegTable, rR7);
field_offset(StgRegTable, rR8);
field_offset(StgRegTable, rR9);
field_offset(StgRegTable, rR10);
field_offset(StgRegTable, rF1);
field_offset(StgRegTable, rF2);
field_offset(StgRegTable, rF3);
field_offset(StgRegTable, rF4);
field_offset(StgRegTable, rD1);
field_offset(StgRegTable, rD2);
field_offset(StgRegTable, rL1);
field_offset(StgRegTable, rSp);
field_offset(StgRegTable, rSpLim);
field_offset(StgRegTable, rHp);
field_offset(StgRegTable, rHpLim);
field_offset(StgRegTable, rCCCS);
field_offset(StgRegTable, rCurrentTSO);
field_offset(StgRegTable, rCurrentNursery);
field_offset(StgRegTable, rHpAlloc);
struct_field(StgRegTable, rRet);
struct_field(StgRegTable, rNursery);
def_offset("stgEagerBlackholeInfo", FUN_OFFSET(stgEagerBlackholeInfo));
def_offset("stgGCEnter1", FUN_OFFSET(stgGCEnter1));
def_offset("stgGCFun", FUN_OFFSET(stgGCFun));
field_offset(Capability, r);
field_offset(Capability, lock);
struct_field(Capability, no);
struct_field(Capability, mut_lists);
struct_field(Capability, context_switch);
struct_field(Capability, interrupt);
struct_field(Capability, sparks);
struct_field(bdescr, start);
struct_field(bdescr, free);
struct_field(bdescr, blocks);
struct_field(bdescr, gen_no);
struct_field(bdescr, link);
struct_size(generation);
struct_field(generation, n_new_large_words);
struct_size(CostCentreStack);
struct_field(CostCentreStack, ccsID);
struct_field(CostCentreStack, mem_alloc);
struct_field(CostCentreStack, scc_count);
struct_field(CostCentreStack, prevStack);
struct_field(CostCentre, ccID);
struct_field(CostCentre, link);
struct_field(StgHeader, info);
struct_field_("StgHeader_ccs", StgHeader, prof.ccs);
struct_field_("StgHeader_ldvw", StgHeader, prof.hp.ldvw);
struct_size(StgSMPThunkHeader);
closure_payload(StgClosure,payload);
struct_field(StgEntCounter, allocs);
struct_field(StgEntCounter, registeredp);
struct_field(StgEntCounter, link);
struct_field(StgEntCounter, entry_count);
closure_size(StgUpdateFrame);
closure_size(StgCatchFrame);
closure_size(StgStopFrame);
closure_size(StgMutArrPtrs);
closure_field(StgMutArrPtrs, ptrs);
closure_field(StgMutArrPtrs, size);
closure_size(StgArrWords);
closure_field(StgArrWords, bytes);
closure_payload(StgArrWords, payload);
closure_field(StgTSO, _link);
closure_field(StgTSO, global_link);
closure_field(StgTSO, what_next);
closure_field(StgTSO, why_blocked);
closure_field(StgTSO, block_info);
closure_field(StgTSO, blocked_exceptions);
closure_field(StgTSO, id);
closure_field(StgTSO, cap);
closure_field(StgTSO, saved_errno);
closure_field(StgTSO, trec);
closure_field(StgTSO, flags);
closure_field(StgTSO, dirty);
closure_field(StgTSO, bq);
closure_field_("StgTSO_cccs", StgTSO, prof.cccs);
closure_field(StgTSO, stackobj);
closure_field(StgStack, sp);
closure_field_offset(StgStack, stack);
closure_field(StgStack, stack_size);
closure_field(StgStack, dirty);
struct_size(StgTSOProfInfo);
opt_struct_size(StgTSOProfInfo,PROFILING);
closure_field(StgUpdateFrame, updatee);
closure_field(StgCatchFrame, handler);
closure_field(StgCatchFrame, exceptions_blocked);
closure_size(StgPAP);
closure_field(StgPAP, n_args);
closure_field_gcptr(StgPAP, fun);
closure_field(StgPAP, arity);
closure_payload(StgPAP, payload);
thunk_size(StgAP);
closure_field(StgAP, n_args);
closure_field_gcptr(StgAP, fun);
closure_payload(StgAP, payload);
thunk_size(StgAP_STACK);
closure_field(StgAP_STACK, size);
closure_field_gcptr(StgAP_STACK, fun);
closure_payload(StgAP_STACK, payload);
thunk_size(StgSelector);
closure_field_gcptr(StgInd, indirectee);
closure_size(StgMutVar);
closure_field(StgMutVar, var);
closure_size(StgAtomicallyFrame);
closure_field(StgAtomicallyFrame, code);
closure_field(StgAtomicallyFrame, next_invariant_to_check);
closure_field(StgAtomicallyFrame, result);
closure_field(StgInvariantCheckQueue, invariant);
closure_field(StgInvariantCheckQueue, my_execution);
closure_field(StgInvariantCheckQueue, next_queue_entry);
closure_field(StgAtomicInvariant, code);
closure_field(StgTRecHeader, enclosing_trec);
closure_size(StgCatchSTMFrame);
closure_field(StgCatchSTMFrame, handler);
closure_field(StgCatchSTMFrame, code);
closure_size(StgCatchRetryFrame);
closure_field(StgCatchRetryFrame, running_alt_code);
closure_field(StgCatchRetryFrame, first_code);
closure_field(StgCatchRetryFrame, alt_code);
closure_field(StgTVarWatchQueue, closure);
closure_field(StgTVarWatchQueue, next_queue_entry);
closure_field(StgTVarWatchQueue, prev_queue_entry);
closure_field(StgTVar, current_value);
closure_size(StgWeak);
closure_field(StgWeak,link);
closure_field(StgWeak,key);
closure_field(StgWeak,value);
closure_field(StgWeak,finalizer);
closure_field(StgWeak,cfinalizer);
closure_size(StgDeadWeak);
closure_field(StgDeadWeak,link);
closure_size(StgMVar);
closure_field(StgMVar,head);
closure_field(StgMVar,tail);
closure_field(StgMVar,value);
closure_size(StgMVarTSOQueue);
closure_field(StgMVarTSOQueue, link);
closure_field(StgMVarTSOQueue, tso);
closure_size(StgBCO);
closure_field(StgBCO, instrs);
closure_field(StgBCO, literals);
closure_field(StgBCO, ptrs);
closure_field(StgBCO, arity);
closure_field(StgBCO, size);
closure_payload(StgBCO, bitmap);
closure_size(StgStableName);
closure_field(StgStableName,sn);
closure_size(StgBlockingQueue);
closure_field(StgBlockingQueue, bh);
closure_field(StgBlockingQueue, owner);
closure_field(StgBlockingQueue, queue);
closure_field(StgBlockingQueue, link);
closure_size(MessageBlackHole);
closure_field(MessageBlackHole, link);
closure_field(MessageBlackHole, tso);
closure_field(MessageBlackHole, bh);
struct_field_("RtsFlags_ProfFlags_showCCSOnException",
RTS_FLAGS, ProfFlags.showCCSOnException);
struct_field_("RtsFlags_DebugFlags_apply",
RTS_FLAGS, DebugFlags.apply);
struct_field_("RtsFlags_DebugFlags_sanity",
RTS_FLAGS, DebugFlags.sanity);
struct_field_("RtsFlags_DebugFlags_weak",
RTS_FLAGS, DebugFlags.weak);
struct_field_("RtsFlags_GcFlags_initialStkSize",
RTS_FLAGS, GcFlags.initialStkSize);
struct_field_("RtsFlags_MiscFlags_tickInterval",
RTS_FLAGS, MiscFlags.tickInterval);
struct_size(StgFunInfoExtraFwd);
struct_field(StgFunInfoExtraFwd, slow_apply);
struct_field(StgFunInfoExtraFwd, fun_type);
struct_field(StgFunInfoExtraFwd, arity);
struct_field_("StgFunInfoExtraFwd_bitmap", StgFunInfoExtraFwd, b.bitmap);
struct_size(StgFunInfoExtraRev);
struct_field(StgFunInfoExtraRev, slow_apply_offset);
struct_field(StgFunInfoExtraRev, fun_type);
struct_field(StgFunInfoExtraRev, arity);
struct_field_("StgFunInfoExtraRev_bitmap", StgFunInfoExtraRev, b.bitmap);
struct_field(StgLargeBitmap, size);
field_offset(StgLargeBitmap, bitmap);
struct_size(snEntry);
struct_field(snEntry,sn_obj);
struct_field(snEntry,addr);
#ifdef mingw32_HOST_OS
struct_size(StgAsyncIOResult);
struct_field(StgAsyncIOResult, reqID);
struct_field(StgAsyncIOResult, len);
struct_field(StgAsyncIOResult, errCode);
#endif
return 0;
}
static void
scavenge_stack(StgPtr p, StgPtr stack_end)
{
const StgRetInfoTable* info;
StgWord bitmap;
nat size;
/*
* Each time around this loop, we are looking at a chunk of stack
* that starts with an activation record.
*/
while (p < stack_end) {
info = get_ret_itbl((StgClosure *)p);
switch (info->i.type) {
case UPDATE_FRAME:
// In SMP, we can get update frames that point to indirections
// when two threads evaluate the same thunk. We do attempt to
// discover this situation in threadPaused(), but it's
// possible that the following sequence occurs:
//
// A B
// enter T
// enter T
// blackhole T
// update T
// GC
//
// Now T is an indirection, and the update frame is already
// marked on A's stack, so we won't traverse it again in
// threadPaused(). We could traverse the whole stack again
// before GC, but that seems like overkill.
//
// Scavenging this update frame as normal would be disastrous;
// the updatee would end up pointing to the value. So we
// check whether the value after evacuation is a BLACKHOLE,
// and if not, we change the update frame to an stg_enter
// frame that simply returns the value. Hence, blackholing is
// compulsory (otherwise we would have to check for thunks
// too).
//
// Note [upd-black-hole]
// One slight hiccup is that the THUNK_SELECTOR machinery can
// overwrite the updatee with an IND. In parallel GC, this
// could even be happening concurrently, so we can't check for
// the IND. Fortunately if we assume that blackholing is
// happening (either lazy or eager), then we can be sure that
// the updatee is never a THUNK_SELECTOR and we're ok.
// NB. this is a new invariant: blackholing is not optional.
{
StgUpdateFrame *frame = (StgUpdateFrame *)p;
StgClosure *v;
evacuate(&frame->updatee);
v = frame->updatee;
if (GET_CLOSURE_TAG(v) != 0 ||
(get_itbl(v)->type != BLACKHOLE)) {
// blackholing is compulsory, see above.
frame->header.info = (const StgInfoTable*)&stg_enter_checkbh_info;
}
ASSERT(v->header.info != &stg_TSO_info);
p += sizeofW(StgUpdateFrame);
continue;
}
// small bitmap (< 32 entries, or 64 on a 64-bit machine)
case CATCH_STM_FRAME:
case CATCH_RETRY_FRAME:
case ATOMICALLY_FRAME:
case UNDERFLOW_FRAME:
case STOP_FRAME:
case CATCH_FRAME:
case RET_SMALL:
bitmap = BITMAP_BITS(info->i.layout.bitmap);
size = BITMAP_SIZE(info->i.layout.bitmap);
// NOTE: the payload starts immediately after the info-ptr, we
// don't have an StgHeader in the same sense as a heap closure.
p++;
p = scavenge_small_bitmap(p, size, bitmap);
follow_srt:
if (major_gc)
scavenge_srt((StgClosure **)GET_SRT(info), info->i.srt_bitmap);
continue;
case RET_BCO: {
StgBCO *bco;
nat size;
p++;
evacuate((StgClosure **)p);
bco = (StgBCO *)*p;
p++;
size = BCO_BITMAP_SIZE(bco);
scavenge_large_bitmap(p, BCO_BITMAP(bco), size);
p += size;
continue;
}
// large bitmap (> 32 entries, or > 64 on a 64-bit machine)
case RET_BIG:
{
nat size;
size = GET_LARGE_BITMAP(&info->i)->size;
p++;
scavenge_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
p += size;
// and don't forget to follow the SRT
goto follow_srt;
}
// Dynamic bitmap: the mask is stored on the stack, and
// there are a number of non-pointers followed by a number
// of pointers above the bitmapped area. (see StgMacros.h,
// HEAP_CHK_GEN).
case RET_DYN:
{
StgWord dyn;
dyn = ((StgRetDyn *)p)->liveness;
// traverse the bitmap first
bitmap = RET_DYN_LIVENESS(dyn);
p = (P_)&((StgRetDyn *)p)->payload[0];
size = RET_DYN_BITMAP_SIZE;
p = scavenge_small_bitmap(p, size, bitmap);
// skip over the non-ptr words
p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
// follow the ptr words
for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
evacuate((StgClosure **)p);
p++;
}
continue;
}
case RET_FUN:
{
StgRetFun *ret_fun = (StgRetFun *)p;
StgFunInfoTable *fun_info;
evacuate(&ret_fun->fun);
fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
p = scavenge_arg_block(fun_info, ret_fun->payload);
goto follow_srt;
}
default:
barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->i.type));
}
}
}
// check an individual stack object
StgOffset
checkStackFrame( StgPtr c )
{
nat size;
const StgRetInfoTable* info;
info = get_ret_itbl((StgClosure *)c);
/* All activation records have 'bitmap' style layout info. */
switch (info->i.type) {
case RET_DYN: /* Dynamic bitmap: the mask is stored on the stack */
{
StgWord dyn;
StgPtr p;
StgRetDyn* r;
r = (StgRetDyn *)c;
dyn = r->liveness;
p = (P_)(r->payload);
checkSmallBitmap(p,RET_DYN_LIVENESS(r->liveness),RET_DYN_BITMAP_SIZE);
p += RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE;
// skip over the non-pointers
p += RET_DYN_NONPTRS(dyn);
// follow the ptr words
for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
checkClosureShallow((StgClosure *)*p);
p++;
}
return sizeofW(StgRetDyn) + RET_DYN_BITMAP_SIZE +
RET_DYN_NONPTR_REGS_SIZE +
RET_DYN_NONPTRS(dyn) + RET_DYN_PTRS(dyn);
}
case UPDATE_FRAME:
ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgUpdateFrame*)c)->updatee));
case ATOMICALLY_FRAME:
case CATCH_RETRY_FRAME:
case CATCH_STM_FRAME:
case CATCH_FRAME:
// small bitmap cases (<= 32 entries)
case UNDERFLOW_FRAME:
case STOP_FRAME:
case RET_SMALL:
size = BITMAP_SIZE(info->i.layout.bitmap);
checkSmallBitmap((StgPtr)c + 1,
BITMAP_BITS(info->i.layout.bitmap), size);
return 1 + size;
case RET_BCO: {
StgBCO *bco;
nat size;
bco = (StgBCO *)*(c+1);
size = BCO_BITMAP_SIZE(bco);
checkLargeBitmap((StgPtr)c + 2, BCO_BITMAP(bco), size);
return 2 + size;
}
case RET_BIG: // large bitmap (> 32 entries)
size = GET_LARGE_BITMAP(&info->i)->size;
checkLargeBitmap((StgPtr)c + 1, GET_LARGE_BITMAP(&info->i), size);
return 1 + size;
case RET_FUN:
{
StgFunInfoTable *fun_info;
StgRetFun *ret_fun;
ret_fun = (StgRetFun *)c;
fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
size = ret_fun->size;
switch (fun_info->f.fun_type) {
case ARG_GEN:
checkSmallBitmap((StgPtr)ret_fun->payload,
BITMAP_BITS(fun_info->f.b.bitmap), size);
break;
case ARG_GEN_BIG:
checkLargeBitmap((StgPtr)ret_fun->payload,
GET_FUN_LARGE_BITMAP(fun_info), size);
break;
default:
checkSmallBitmap((StgPtr)ret_fun->payload,
BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
size);
break;
}
return sizeofW(StgRetFun) + size;
}
default:
barf("checkStackFrame: weird activation record found on stack (%p %d).",c,info->i.type);
}
}
static void
verify_consistency_block (StgCompactNFData *str, StgCompactNFDataBlock *block)
{
bdescr *bd;
StgPtr p;
const StgInfoTable *info;
StgClosure *q;
p = (P_)firstBlockGetCompact(block);
bd = Bdescr((P_)block);
while (p < bd->free) {
q = (StgClosure*)p;
ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
info = get_itbl(q);
switch (info->type) {
case CONSTR_1_0:
check_object_in_compact(str, UNTAG_CLOSURE(q->payload[0]));
/* fallthrough */
case CONSTR_0_1:
p += sizeofW(StgClosure) + 1;
break;
case CONSTR_2_0:
check_object_in_compact(str, UNTAG_CLOSURE(q->payload[1]));
/* fallthrough */
case CONSTR_1_1:
check_object_in_compact(str, UNTAG_CLOSURE(q->payload[0]));
/* fallthrough */
case CONSTR_0_2:
p += sizeofW(StgClosure) + 2;
break;
case CONSTR:
case PRIM:
case CONSTR_NOCAF:
{
uint32_t i;
for (i = 0; i < info->layout.payload.ptrs; i++) {
check_object_in_compact(str, UNTAG_CLOSURE(q->payload[i]));
}
p += sizeofW(StgClosure) + info->layout.payload.ptrs +
info->layout.payload.nptrs;
break;
}
case ARR_WORDS:
p += arr_words_sizeW((StgArrBytes*)p);
break;
case MUT_ARR_PTRS_FROZEN_CLEAN:
case MUT_ARR_PTRS_FROZEN_DIRTY:
verify_mut_arr_ptrs(str, (StgMutArrPtrs*)p);
p += mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
break;
case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:
{
uint32_t i;
StgSmallMutArrPtrs *arr = (StgSmallMutArrPtrs*)p;
for (i = 0; i < arr->ptrs; i++)
check_object_in_compact(str, UNTAG_CLOSURE(arr->payload[i]));
p += sizeofW(StgSmallMutArrPtrs) + arr->ptrs;
break;
}
case COMPACT_NFDATA:
p += sizeofW(StgCompactNFData);
break;
default:
barf("verify_consistency_block");
}
}
return;
}
static GNUC_ATTR_HOT void
scavenge_block (bdescr *bd)
{
StgPtr p, q;
StgInfoTable *info;
rtsBool saved_eager_promotion;
gen_workspace *ws;
debugTrace(DEBUG_gc, "scavenging block %p (gen %d) @ %p",
bd->start, bd->gen_no, bd->u.scan);
gct->scan_bd = bd;
gct->evac_gen_no = bd->gen_no;
saved_eager_promotion = gct->eager_promotion;
gct->failed_to_evac = rtsFalse;
ws = &gct->gens[bd->gen->no];
p = bd->u.scan;
// we might be evacuating into the very object that we're
// scavenging, so we have to check the real bd->free pointer each
// time around the loop.
while (p < bd->free || (bd == ws->todo_bd && p < ws->todo_free)) {
ASSERT(bd->link == NULL);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
info = get_itbl((StgClosure *)p);
ASSERT(gct->thunk_selector_depth == 0);
q = p;
switch (info->type) {
case MVAR_CLEAN:
case MVAR_DIRTY:
{
StgMVar *mvar = ((StgMVar *)p);
gct->eager_promotion = rtsFalse;
evacuate((StgClosure **)&mvar->head);
evacuate((StgClosure **)&mvar->tail);
evacuate((StgClosure **)&mvar->value);
gct->eager_promotion = saved_eager_promotion;
if (gct->failed_to_evac) {
mvar->header.info = &stg_MVAR_DIRTY_info;
} else {
mvar->header.info = &stg_MVAR_CLEAN_info;
}
p += sizeofW(StgMVar);
break;
}
case FUN_2_0:
scavenge_fun_srt(info);
evacuate(&((StgClosure *)p)->payload[1]);
evacuate(&((StgClosure *)p)->payload[0]);
p += sizeofW(StgHeader) + 2;
break;
case THUNK_2_0:
scavenge_thunk_srt(info);
evacuate(&((StgThunk *)p)->payload[1]);
evacuate(&((StgThunk *)p)->payload[0]);
p += sizeofW(StgThunk) + 2;
break;
case CONSTR_2_0:
evacuate(&((StgClosure *)p)->payload[1]);
evacuate(&((StgClosure *)p)->payload[0]);
p += sizeofW(StgHeader) + 2;
break;
case THUNK_1_0:
scavenge_thunk_srt(info);
evacuate(&((StgThunk *)p)->payload[0]);
p += sizeofW(StgThunk) + 1;
break;
case FUN_1_0:
scavenge_fun_srt(info);
case CONSTR_1_0:
evacuate(&((StgClosure *)p)->payload[0]);
p += sizeofW(StgHeader) + 1;
break;
case THUNK_0_1:
scavenge_thunk_srt(info);
p += sizeofW(StgThunk) + 1;
break;
case FUN_0_1:
scavenge_fun_srt(info);
case CONSTR_0_1:
p += sizeofW(StgHeader) + 1;
break;
case THUNK_0_2:
scavenge_thunk_srt(info);
p += sizeofW(StgThunk) + 2;
break;
case FUN_0_2:
scavenge_fun_srt(info);
case CONSTR_0_2:
p += sizeofW(StgHeader) + 2;
break;
case THUNK_1_1:
scavenge_thunk_srt(info);
evacuate(&((StgThunk *)p)->payload[0]);
p += sizeofW(StgThunk) + 2;
break;
case FUN_1_1:
scavenge_fun_srt(info);
case CONSTR_1_1:
evacuate(&((StgClosure *)p)->payload[0]);
p += sizeofW(StgHeader) + 2;
break;
case FUN:
scavenge_fun_srt(info);
goto gen_obj;
case THUNK:
{
StgPtr end;
scavenge_thunk_srt(info);
end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
evacuate((StgClosure **)p);
}
p += info->layout.payload.nptrs;
break;
}
gen_obj:
case CONSTR:
case WEAK:
case PRIM:
{
StgPtr end;
end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
evacuate((StgClosure **)p);
}
p += info->layout.payload.nptrs;
break;
}
case BCO: {
StgBCO *bco = (StgBCO *)p;
evacuate((StgClosure **)&bco->instrs);
evacuate((StgClosure **)&bco->literals);
evacuate((StgClosure **)&bco->ptrs);
p += bco_sizeW(bco);
break;
}
case IND_PERM:
case BLACKHOLE:
evacuate(&((StgInd *)p)->indirectee);
p += sizeofW(StgInd);
break;
case MUT_VAR_CLEAN:
case MUT_VAR_DIRTY:
gct->eager_promotion = rtsFalse;
evacuate(&((StgMutVar *)p)->var);
gct->eager_promotion = saved_eager_promotion;
if (gct->failed_to_evac) {
((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
} else {
((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
}
p += sizeofW(StgMutVar);
break;
case BLOCKING_QUEUE:
{
StgBlockingQueue *bq = (StgBlockingQueue *)p;
gct->eager_promotion = rtsFalse;
evacuate(&bq->bh);
evacuate((StgClosure**)&bq->owner);
evacuate((StgClosure**)&bq->queue);
evacuate((StgClosure**)&bq->link);
gct->eager_promotion = saved_eager_promotion;
if (gct->failed_to_evac) {
bq->header.info = &stg_BLOCKING_QUEUE_DIRTY_info;
} else {
bq->header.info = &stg_BLOCKING_QUEUE_CLEAN_info;
}
p += sizeofW(StgBlockingQueue);
break;
}
case THUNK_SELECTOR:
{
StgSelector *s = (StgSelector *)p;
evacuate(&s->selectee);
p += THUNK_SELECTOR_sizeW();
break;
}
// A chunk of stack saved in a heap object
case AP_STACK:
{
StgAP_STACK *ap = (StgAP_STACK *)p;
evacuate(&ap->fun);
scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
p = (StgPtr)ap->payload + ap->size;
break;
}
case PAP:
p = scavenge_PAP((StgPAP *)p);
break;
case AP:
p = scavenge_AP((StgAP *)p);
break;
case ARR_WORDS:
// nothing to follow
p += arr_words_sizeW((StgArrWords *)p);
break;
case MUT_ARR_PTRS_CLEAN:
case MUT_ARR_PTRS_DIRTY:
{
// We don't eagerly promote objects pointed to by a mutable
// array, but if we find the array only points to objects in
// the same or an older generation, we mark it "clean" and
// avoid traversing it during minor GCs.
gct->eager_promotion = rtsFalse;
p = scavenge_mut_arr_ptrs((StgMutArrPtrs*)p);
if (gct->failed_to_evac) {
((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
} else {
((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
}
gct->eager_promotion = saved_eager_promotion;
gct->failed_to_evac = rtsTrue; // always put it on the mutable list.
break;
}
case MUT_ARR_PTRS_FROZEN:
case MUT_ARR_PTRS_FROZEN0:
// follow everything
{
p = scavenge_mut_arr_ptrs((StgMutArrPtrs*)p);
// If we're going to put this object on the mutable list, then
// set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
if (gct->failed_to_evac) {
((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
} else {
((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
}
break;
}
case TSO:
{
scavengeTSO((StgTSO *)p);
p += sizeofW(StgTSO);
break;
}
case STACK:
{
StgStack *stack = (StgStack*)p;
gct->eager_promotion = rtsFalse;
scavenge_stack(stack->sp, stack->stack + stack->stack_size);
stack->dirty = gct->failed_to_evac;
p += stack_sizeW(stack);
gct->eager_promotion = saved_eager_promotion;
break;
}
case MUT_PRIM:
{
StgPtr end;
gct->eager_promotion = rtsFalse;
end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
evacuate((StgClosure **)p);
}
p += info->layout.payload.nptrs;
gct->eager_promotion = saved_eager_promotion;
gct->failed_to_evac = rtsTrue; // mutable
break;
}
case TREC_CHUNK:
{
StgWord i;
StgTRecChunk *tc = ((StgTRecChunk *) p);
TRecEntry *e = &(tc -> entries[0]);
gct->eager_promotion = rtsFalse;
evacuate((StgClosure **)&tc->prev_chunk);
for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
evacuate((StgClosure **)&e->tvar);
evacuate((StgClosure **)&e->expected_value);
evacuate((StgClosure **)&e->new_value);
}
gct->eager_promotion = saved_eager_promotion;
gct->failed_to_evac = rtsTrue; // mutable
p += sizeofW(StgTRecChunk);
break;
}
default:
barf("scavenge: unimplemented/strange closure type %d @ %p",
info->type, p);
}
/*
* We need to record the current object on the mutable list if
* (a) It is actually mutable, or
* (b) It contains pointers to a younger generation.
* Case (b) arises if we didn't manage to promote everything that
* the current object points to into the current generation.
*/
if (gct->failed_to_evac) {
gct->failed_to_evac = rtsFalse;
if (bd->gen_no > 0) {
recordMutableGen_GC((StgClosure *)q, bd->gen_no);
}
}
}
if (p > bd->free) {
gct->copied += ws->todo_free - bd->free;
bd->free = p;
}
debugTrace(DEBUG_gc, " scavenged %ld bytes",
(unsigned long)((bd->free - bd->u.scan) * sizeof(W_)));
// update stats: this is a block that has been scavenged
gct->scanned += bd->free - bd->u.scan;
bd->u.scan = bd->free;
if (bd != ws->todo_bd) {
// we're not going to evac any more objects into
// this block, so push it now.
push_scanned_block(bd, ws);
}
gct->scan_bd = NULL;
}
int
main(int argc, char *argv[])
{
printf("-- This file is created automatically. Do not edit by hand.\n\n");
printf("#define STD_HDR_SIZE %d\n", sizeofW(StgHeader));
printf("#define PROF_HDR_SIZE %d\n", sizeofW(StgProfHeader));
printf("#define GRAN_HDR_SIZE %d\n", sizeofW(StgGranHeader));
printf("#define ARR_WORDS_HDR_SIZE %d\n",
sizeofW(StgArrWords) - sizeofW(StgHeader));
printf("#define ARR_PTRS_HDR_SIZE %d\n",
sizeofW(StgMutArrPtrs) - sizeofW(StgHeader));
printf("#define STD_ITBL_SIZE %d\n", sizeofW(StgInfoTable));
printf("#define RET_ITBL_SIZE %d\n", sizeofW(StgRetInfoTable) - sizeofW(StgInfoTable));
printf("#define PROF_ITBL_SIZE %d\n", sizeofW(StgProfInfo));
printf("#define GRAN_ITBL_SIZE %d\n", 0);
printf("#define TICKY_ITBL_SIZE %d\n", sizeofW(StgTickyInfo));
printf("#define STD_UF_SIZE %d\n", sizeofW(StgUpdateFrame));
printf("#define GRAN_UF_SIZE %d\n",
sizeofW(StgUpdateFrame) + sizeofW(StgGranHeader));
printf("#define PROF_UF_SIZE %d\n",
sizeofW(StgUpdateFrame) + sizeofW(StgProfHeader));
printf("#define UF_RET %d\n",
OFFSET(StgUpdateFrame,header.info));
printf("#define UF_UPDATEE %d\n",
OFFSET(StgUpdateFrame,updatee) / sizeof(W_));
printf("#define BLOCK_SIZE %d\n", BLOCK_SIZE);
printf("#define MBLOCK_SIZE %d\n", MBLOCK_SIZE);
return 0;
}
static void
stackSqueeze(Capability *cap, StgTSO *tso, StgPtr bottom)
{
StgPtr frame;
uint32_t adjacent_update_frames;
struct stack_gap *gap;
// Stage 1:
// Traverse the stack upwards, replacing adjacent update frames
// with a single update frame and a "stack gap". A stack gap
// contains two values: the size of the gap, and the distance
// to the next gap (or the stack top).
frame = tso->stackobj->sp;
ASSERT(frame < bottom);
adjacent_update_frames = 0;
gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame));
while (frame <= bottom)
{
switch (get_ret_itbl((StgClosure *)frame)->i.type) {
case UPDATE_FRAME:
{
if (adjacent_update_frames > 0) {
TICK_UPD_SQUEEZED();
}
adjacent_update_frames++;
frame += sizeofW(StgUpdateFrame);
continue;
}
default:
// we're not in a gap... check whether this is the end of a gap
// (an update frame can't be the end of a gap).
if (adjacent_update_frames > 1) {
gap = updateAdjacentFrames(cap, tso,
(StgUpdateFrame*)(frame - sizeofW(StgUpdateFrame)),
adjacent_update_frames, gap);
}
adjacent_update_frames = 0;
frame += stack_frame_sizeW((StgClosure *)frame);
continue;
}
}
if (adjacent_update_frames > 1) {
gap = updateAdjacentFrames(cap, tso,
(StgUpdateFrame*)(frame - sizeofW(StgUpdateFrame)),
adjacent_update_frames, gap);
}
// Now we have a stack with gap-structs in it, and we have to walk down
// shoving the stack up to fill in the gaps. A diagram might
// help:
//
// +| ********* |
// | ********* | <- sp
// | |
// | | <- gap_start
// | ......... | |
// | stack_gap | <- gap | chunk_size
// | ......... | |
// | ......... | <- gap_end v
// | ********* |
// | ********* |
// | ********* |
// -| ********* |
//
// 'sp' points the the current top-of-stack
// 'gap' points to the stack_gap structure inside the gap
// ***** indicates real stack data
// ..... indicates gap
// <empty> indicates unused
//
{
StgWord8 *sp;
StgWord8 *gap_start, *next_gap_start, *gap_end;
uint32_t chunk_size;
next_gap_start = (StgWord8*)gap + sizeof(StgUpdateFrame);
sp = next_gap_start;
while ((StgPtr)gap > tso->stackobj->sp) {
// we're working in *bytes* now...
gap_start = next_gap_start;
gap_end = gap_start - gap->gap_size * sizeof(W_);
gap = gap->next_gap;
next_gap_start = (StgWord8*)gap + sizeof(StgUpdateFrame);
chunk_size = gap_end - next_gap_start;
sp -= chunk_size;
memmove(sp, next_gap_start, chunk_size);
}
tso->stackobj->sp = (StgPtr)sp;
}
}
STATIC_INLINE StgPtr
allocate_NONUPD (Capability *cap, int n_words)
{
return allocate(cap, stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words));
}
REGPARM1 GNUC_ATTR_HOT void
evacuate(StgClosure **p)
{
bdescr *bd = NULL;
nat gen_no;
StgClosure *q;
const StgInfoTable *info;
StgWord tag;
q = *p;
loop:
/* The tag and the pointer are split, to be merged after evacing */
tag = GET_CLOSURE_TAG(q);
q = UNTAG_CLOSURE(q);
ASSERTM(LOOKS_LIKE_CLOSURE_PTR(q), "invalid closure, info=%p", q->header.info);
if (!HEAP_ALLOCED_GC(q)) {
if (!major_gc) return;
info = get_itbl(q);
switch (info->type) {
case THUNK_STATIC:
if (info->srt_bitmap != 0) {
evacuate_static_object(THUNK_STATIC_LINK((StgClosure *)q), q);
}
return;
case FUN_STATIC:
if (info->srt_bitmap != 0) {
evacuate_static_object(FUN_STATIC_LINK((StgClosure *)q), q);
}
return;
case IND_STATIC:
/* If q->saved_info != NULL, then it's a revertible CAF - it'll be
* on the CAF list, so don't do anything with it here (we'll
* scavenge it later).
*/
evacuate_static_object(IND_STATIC_LINK((StgClosure *)q), q);
return;
case CONSTR_STATIC:
evacuate_static_object(STATIC_LINK(info,(StgClosure *)q), q);
return;
case CONSTR_NOCAF_STATIC:
/* no need to put these on the static linked list, they don't need
* to be scavenged.
*/
return;
default:
barf("evacuate(static): strange closure type %d", (int)(info->type));
}
}
bd = Bdescr((P_)q);
if ((bd->flags & (BF_LARGE | BF_MARKED | BF_EVACUATED)) != 0) {
// pointer into to-space: just return it. It might be a pointer
// into a generation that we aren't collecting (> N), or it
// might just be a pointer into to-space. The latter doesn't
// happen often, but allowing it makes certain things a bit
// easier; e.g. scavenging an object is idempotent, so it's OK to
// have an object on the mutable list multiple times.
if (bd->flags & BF_EVACUATED) {
// We aren't copying this object, so we have to check
// whether it is already in the target generation. (this is
// the write barrier).
if (bd->gen_no < gct->evac_gen_no) {
gct->failed_to_evac = rtsTrue;
TICK_GC_FAILED_PROMOTION();
}
return;
}
/* evacuate large objects by re-linking them onto a different list.
*/
if (bd->flags & BF_LARGE) {
evacuate_large((P_)q);
return;
}
/* If the object is in a gen that we're compacting, then we
* need to use an alternative evacuate procedure.
*/
if (!is_marked((P_)q,bd)) {
mark((P_)q,bd);
push_mark_stack((P_)q);
}
return;
}
gen_no = bd->dest_no;
info = q->header.info;
if (IS_FORWARDING_PTR(info))
{
/* Already evacuated, just return the forwarding address.
* HOWEVER: if the requested destination generation (gct->evac_gen) is
* older than the actual generation (because the object was
* already evacuated to a younger generation) then we have to
* set the gct->failed_to_evac flag to indicate that we couldn't
* manage to promote the object to the desired generation.
*/
/*
* Optimisation: the check is fairly expensive, but we can often
* shortcut it if either the required generation is 0, or the
* current object (the EVACUATED) is in a high enough generation.
* We know that an EVACUATED always points to an object in the
* same or an older generation. gen is the lowest generation that the
* current object would be evacuated to, so we only do the full
* check if gen is too low.
*/
StgClosure *e = (StgClosure*)UN_FORWARDING_PTR(info);
*p = TAG_CLOSURE(tag,e);
if (gen_no < gct->evac_gen_no) { // optimisation
if (Bdescr((P_)e)->gen_no < gct->evac_gen_no) {
gct->failed_to_evac = rtsTrue;
TICK_GC_FAILED_PROMOTION();
}
}
return;
}
switch (INFO_PTR_TO_STRUCT(info)->type) {
case WHITEHOLE:
goto loop;
// For ints and chars of low value, save space by replacing references to
// these with closures with references to common, shared ones in the RTS.
//
// * Except when compiling into Windows DLLs which don't support cross-package
// data references very well.
//
case CONSTR_0_1:
{
#if defined(COMPILING_WINDOWS_DLL)
copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,gen_no,tag);
#else
StgWord w = (StgWord)q->payload[0];
if (info == Czh_con_info &&
// unsigned, so always true: (StgChar)w >= MIN_CHARLIKE &&
(StgChar)w <= MAX_CHARLIKE) {
*p = TAG_CLOSURE(tag,
(StgClosure *)CHARLIKE_CLOSURE((StgChar)w)
);
}
else if (info == Izh_con_info &&
(StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) {
*p = TAG_CLOSURE(tag,
(StgClosure *)INTLIKE_CLOSURE((StgInt)w)
);
}
else {
copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,gen_no,tag);
}
#endif
return;
}
case FUN_0_1:
case FUN_1_0:
case CONSTR_1_0:
copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,gen_no,tag);
return;
case THUNK_1_0:
case THUNK_0_1:
copy(p,info,q,sizeofW(StgThunk)+1,gen_no);
return;
case THUNK_1_1:
case THUNK_2_0:
case THUNK_0_2:
#ifdef NO_PROMOTE_THUNKS
#error bitrotted
#endif
copy(p,info,q,sizeofW(StgThunk)+2,gen_no);
return;
case FUN_1_1:
case FUN_2_0:
case FUN_0_2:
case CONSTR_1_1:
case CONSTR_2_0:
copy_tag_nolock(p,info,q,sizeofW(StgHeader)+2,gen_no,tag);
return;
case CONSTR_0_2:
copy_tag_nolock(p,info,q,sizeofW(StgHeader)+2,gen_no,tag);
return;
case THUNK:
copy(p,info,q,thunk_sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no);
return;
case FUN:
case CONSTR:
copy_tag_nolock(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no,tag);
return;
case BLACKHOLE:
{
StgClosure *r;
const StgInfoTable *i;
r = ((StgInd*)q)->indirectee;
if (GET_CLOSURE_TAG(r) == 0) {
i = r->header.info;
if (IS_FORWARDING_PTR(i)) {
r = (StgClosure *)UN_FORWARDING_PTR(i);
i = r->header.info;
}
if (i == &stg_TSO_info
|| i == &stg_WHITEHOLE_info
|| i == &stg_BLOCKING_QUEUE_CLEAN_info
|| i == &stg_BLOCKING_QUEUE_DIRTY_info) {
copy(p,info,q,sizeofW(StgInd),gen_no);
return;
}
ASSERT(i != &stg_IND_info);
}
q = r;
*p = r;
goto loop;
}
case MUT_VAR_CLEAN:
case MUT_VAR_DIRTY:
case MVAR_CLEAN:
case MVAR_DIRTY:
case TVAR:
case BLOCKING_QUEUE:
case WEAK:
case PRIM:
case MUT_PRIM:
copy(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no);
return;
case BCO:
copy(p,info,q,bco_sizeW((StgBCO *)q),gen_no);
return;
case THUNK_SELECTOR:
eval_thunk_selector(p, (StgSelector *)q, rtsTrue);
return;
case IND:
// follow chains of indirections, don't evacuate them
q = ((StgInd*)q)->indirectee;
*p = q;
goto loop;
case RET_BCO:
case RET_SMALL:
case RET_BIG:
case UPDATE_FRAME:
case UNDERFLOW_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);
case PAP:
copy(p,info,q,pap_sizeW((StgPAP*)q),gen_no);
return;
case AP:
copy(p,info,q,ap_sizeW((StgAP*)q),gen_no);
return;
case AP_STACK:
copy(p,info,q,ap_stack_sizeW((StgAP_STACK*)q),gen_no);
return;
case ARR_WORDS:
// just copy the block
copy(p,info,q,arr_words_sizeW((StgArrBytes *)q),gen_no);
return;
case MUT_ARR_PTRS_CLEAN:
case MUT_ARR_PTRS_DIRTY:
case MUT_ARR_PTRS_FROZEN:
case MUT_ARR_PTRS_FROZEN0:
// just copy the block
copy(p,info,q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),gen_no);
return;
case SMALL_MUT_ARR_PTRS_CLEAN:
case SMALL_MUT_ARR_PTRS_DIRTY:
case SMALL_MUT_ARR_PTRS_FROZEN:
case SMALL_MUT_ARR_PTRS_FROZEN0:
// just copy the block
copy(p,info,q,small_mut_arr_ptrs_sizeW((StgSmallMutArrPtrs *)q),gen_no);
return;
case TSO:
copy(p,info,q,sizeofW(StgTSO),gen_no);
return;
case STACK:
{
StgStack *stack = (StgStack *)q;
/* To evacuate a small STACK, we need to adjust the stack pointer
*/
{
StgStack *new_stack;
StgPtr r, s;
rtsBool mine;
mine = copyPart(p,(StgClosure *)stack, stack_sizeW(stack),
sizeofW(StgStack), gen_no);
if (mine) {
new_stack = (StgStack *)*p;
move_STACK(stack, new_stack);
for (r = stack->sp, s = new_stack->sp;
r < stack->stack + stack->stack_size;) {
*s++ = *r++;
}
}
return;
}
}
case TREC_CHUNK:
copy(p,info,q,sizeofW(StgTRecChunk),gen_no);
return;
default:
barf("evacuate: strange closure type %d", (int)(INFO_PTR_TO_STRUCT(info)->type));
}
barf("evacuate");
}
StgOffset
checkClosure( StgClosure* p )
{
const StgInfoTable *info;
ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
p = UNTAG_CLOSURE(p);
/* Is it a static closure (i.e. in the data segment)? */
if (!HEAP_ALLOCED(p)) {
ASSERT(closure_STATIC(p));
} else {
ASSERT(!closure_STATIC(p));
}
info = p->header.info;
if (IS_FORWARDING_PTR(info)) {
barf("checkClosure: found EVACUATED closure %d", info->type);
}
info = INFO_PTR_TO_STRUCT(info);
switch (info->type) {
case MVAR_CLEAN:
case MVAR_DIRTY:
{
StgMVar *mvar = (StgMVar *)p;
ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->head));
ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->tail));
ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->value));
return sizeofW(StgMVar);
}
case THUNK:
case THUNK_1_0:
case THUNK_0_1:
case THUNK_1_1:
case THUNK_0_2:
case THUNK_2_0:
{
nat i;
for (i = 0; i < info->layout.payload.ptrs; i++) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgThunk *)p)->payload[i]));
}
return thunk_sizeW_fromITBL(info);
}
case FUN:
case FUN_1_0:
case FUN_0_1:
case FUN_1_1:
case FUN_0_2:
case FUN_2_0:
case CONSTR:
case CONSTR_1_0:
case CONSTR_0_1:
case CONSTR_1_1:
case CONSTR_0_2:
case CONSTR_2_0:
case IND_PERM:
case BLACKHOLE:
case PRIM:
case MUT_PRIM:
case MUT_VAR_CLEAN:
case MUT_VAR_DIRTY:
case CONSTR_STATIC:
case CONSTR_NOCAF_STATIC:
case THUNK_STATIC:
case FUN_STATIC:
{
nat i;
for (i = 0; i < info->layout.payload.ptrs; i++) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(p->payload[i]));
}
return sizeW_fromITBL(info);
}
case BLOCKING_QUEUE:
{
StgBlockingQueue *bq = (StgBlockingQueue *)p;
// NO: the BH might have been updated now
// ASSERT(get_itbl(bq->bh)->type == BLACKHOLE);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(bq->bh));
ASSERT(get_itbl((StgClosure *)(bq->owner))->type == TSO);
ASSERT(bq->queue == (MessageBlackHole*)END_TSO_QUEUE
|| bq->queue->header.info == &stg_MSG_BLACKHOLE_info);
ASSERT(bq->link == (StgBlockingQueue*)END_TSO_QUEUE ||
get_itbl((StgClosure *)(bq->link))->type == IND ||
get_itbl((StgClosure *)(bq->link))->type == BLOCKING_QUEUE);
return sizeofW(StgBlockingQueue);
}
case BCO: {
StgBCO *bco = (StgBCO *)p;
ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->instrs));
ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->literals));
ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->ptrs));
return bco_sizeW(bco);
}
case IND_STATIC: /* (1, 0) closure */
ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgIndStatic*)p)->indirectee));
return sizeW_fromITBL(info);
case WEAK:
/* deal with these specially - the info table isn't
* representative of the actual layout.
*/
{ StgWeak *w = (StgWeak *)p;
ASSERT(LOOKS_LIKE_CLOSURE_PTR(w->key));
ASSERT(LOOKS_LIKE_CLOSURE_PTR(w->value));
ASSERT(LOOKS_LIKE_CLOSURE_PTR(w->finalizer));
if (w->link) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(w->link));
}
return sizeW_fromITBL(info);
}
case THUNK_SELECTOR:
ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgSelector *)p)->selectee));
return THUNK_SELECTOR_sizeW();
case IND:
{
/* we don't expect to see any of these after GC
* but they might appear during execution
*/
StgInd *ind = (StgInd *)p;
ASSERT(LOOKS_LIKE_CLOSURE_PTR(ind->indirectee));
return sizeofW(StgInd);
}
case RET_BCO:
case RET_SMALL:
case RET_BIG:
case RET_DYN:
case UPDATE_FRAME:
case UNDERFLOW_FRAME:
case STOP_FRAME:
case CATCH_FRAME:
case ATOMICALLY_FRAME:
case CATCH_RETRY_FRAME:
case CATCH_STM_FRAME:
barf("checkClosure: stack frame");
case AP:
{
StgAP* ap = (StgAP *)p;
checkPAP (ap->fun, ap->payload, ap->n_args);
return ap_sizeW(ap);
}
case PAP:
{
StgPAP* pap = (StgPAP *)p;
checkPAP (pap->fun, pap->payload, pap->n_args);
return pap_sizeW(pap);
}
case AP_STACK:
{
StgAP_STACK *ap = (StgAP_STACK *)p;
ASSERT(LOOKS_LIKE_CLOSURE_PTR(ap->fun));
checkStackChunk((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
return ap_stack_sizeW(ap);
}
case ARR_WORDS:
return arr_words_sizeW((StgArrWords *)p);
case MUT_ARR_PTRS_CLEAN:
case MUT_ARR_PTRS_DIRTY:
case MUT_ARR_PTRS_FROZEN:
case MUT_ARR_PTRS_FROZEN0:
{
StgMutArrPtrs* a = (StgMutArrPtrs *)p;
nat i;
for (i = 0; i < a->ptrs; i++) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(a->payload[i]));
}
return mut_arr_ptrs_sizeW(a);
}
case TSO:
checkTSO((StgTSO *)p);
return sizeofW(StgTSO);
case STACK:
checkSTACK((StgStack*)p);
return stack_sizeW((StgStack*)p);
case TREC_CHUNK:
{
nat i;
StgTRecChunk *tc = (StgTRecChunk *)p;
ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->prev_chunk));
for (i = 0; i < tc -> next_entry_idx; i ++) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->entries[i].tvar));
ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->entries[i].expected_value));
ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->entries[i].new_value));
}
return sizeofW(StgTRecChunk);
}
default:
barf("checkClosure (closure type %d)", info->type);
}
}
void
scheduleFinalizers(Capability *cap, StgWeak *list)
{
StgWeak *w;
StgTSO *t;
StgMutArrPtrs *arr;
StgWord size;
nat n, i;
Task *task;
task = myTask();
if (task != NULL) {
task->running_finalizers = rtsTrue;
}
// count number of finalizers, and kill all the weak pointers first...
n = 0;
for (w = list; w; w = w->link) {
StgArrWords *farr;
// Better not be a DEAD_WEAK at this stage; the garbage
// collector removes DEAD_WEAKs from the weak pointer list.
ASSERT(w->header.info != &stg_DEAD_WEAK_info);
if (w->finalizer != &stg_NO_FINALIZER_closure) {
n++;
}
farr = (StgArrWords *)UNTAG_CLOSURE(w->cfinalizer);
if ((StgClosure *)farr != &stg_NO_FINALIZER_closure)
runCFinalizer((void *)farr->payload[0],
(void *)farr->payload[1],
(void *)farr->payload[2],
farr->payload[3]);
#ifdef PROFILING
// A weak pointer is inherently used, so we do not need to call
// LDV_recordDead().
//
// Furthermore, when PROFILING is turned on, dead weak
// pointers are exactly as large as weak pointers, so there is
// no need to fill the slop, either. See stg_DEAD_WEAK_info
// in StgMiscClosures.hc.
#endif
SET_HDR(w, &stg_DEAD_WEAK_info, w->header.prof.ccs);
}
if (task != NULL) {
task->running_finalizers = rtsFalse;
}
// No finalizers to run?
if (n == 0) return;
debugTrace(DEBUG_weak, "weak: batching %d finalizers", n);
size = n + mutArrPtrsCardTableSize(n);
arr = (StgMutArrPtrs *)allocate(cap, sizeofW(StgMutArrPtrs) + size);
TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), n, 0);
SET_HDR(arr, &stg_MUT_ARR_PTRS_FROZEN_info, CCS_SYSTEM);
arr->ptrs = n;
arr->size = size;
n = 0;
for (w = list; w; w = w->link) {
if (w->finalizer != &stg_NO_FINALIZER_closure) {
arr->payload[n] = w->finalizer;
n++;
}
}
// set all the cards to 1
for (i = n; i < size; i++) {
arr->payload[i] = (StgClosure *)(W_)(-1);
}
t = createIOThread(cap,
RtsFlags.GcFlags.initialStkSize,
rts_apply(cap,
rts_apply(cap,
(StgClosure *)runFinalizerBatch_closure,
rts_mkInt(cap,n)),
(StgClosure *)arr)
);
scheduleThread(cap,t);
}
/* ---------------------------------------------------------------------------
Create a new thread.
The new thread starts with the given stack size. Before the
scheduler can run, however, this thread needs to have a closure
(and possibly some arguments) pushed on its stack. See
pushClosure() in Schedule.h.
createGenThread() and createIOThread() (in SchedAPI.h) are
convenient packaged versions of this function.
------------------------------------------------------------------------ */
StgTSO *
createThread(Capability *cap, W_ size)
{
StgTSO *tso;
StgStack *stack;
nat stack_size;
/* sched_mutex is *not* required */
/* catch ridiculously small stack sizes */
if (size < MIN_STACK_WORDS + sizeofW(StgStack) + sizeofW(StgTSO)) {
size = MIN_STACK_WORDS + sizeofW(StgStack) + sizeofW(StgTSO);
}
/* The size argument we are given includes all the per-thread
* overheads:
*
* - The TSO structure
* - The STACK header
*
* This is so that we can use a nice round power of 2 for the
* default stack size (e.g. 1k), and if we're allocating lots of
* threads back-to-back they'll fit nicely in a block. It's a bit
* of a benchmark hack, but it doesn't do any harm.
*/
stack_size = round_to_mblocks(size - sizeofW(StgTSO));
stack = (StgStack *)allocate(cap, stack_size);
TICK_ALLOC_STACK(stack_size);
SET_HDR(stack, &stg_STACK_info, cap->r.rCCCS);
stack->stack_size = stack_size - sizeofW(StgStack);
stack->sp = stack->stack + stack->stack_size;
stack->dirty = 1;
tso = (StgTSO *)allocate(cap, sizeofW(StgTSO));
TICK_ALLOC_TSO();
SET_HDR(tso, &stg_TSO_info, CCS_SYSTEM);
// Always start with the compiled code evaluator
tso->what_next = ThreadRunGHC;
tso->why_blocked = NotBlocked;
tso->block_info.closure = (StgClosure *)END_TSO_QUEUE;
tso->blocked_exceptions = END_BLOCKED_EXCEPTIONS_QUEUE;
tso->bq = (StgBlockingQueue *)END_TSO_QUEUE;
tso->flags = 0;
tso->dirty = 1;
tso->_link = END_TSO_QUEUE;
tso->saved_errno = 0;
tso->bound = NULL;
tso->cap = cap;
tso->stackobj = stack;
tso->tot_stack_size = stack->stack_size;
ASSIGN_Int64((W_*)&(tso->alloc_limit), 0);
tso->trec = NO_TREC;
#ifdef PROFILING
tso->prof.cccs = CCS_MAIN;
#endif
// put a stop frame on the stack
stack->sp -= sizeofW(StgStopFrame);
SET_HDR((StgClosure*)stack->sp,
(StgInfoTable *)&stg_stop_thread_info,CCS_SYSTEM);
/* Link the new thread on the global thread list.
*/
ACQUIRE_LOCK(&sched_mutex);
tso->id = next_thread_id++; // while we have the mutex
tso->global_link = g0->threads;
g0->threads = tso;
RELEASE_LOCK(&sched_mutex);
// ToDo: report the stack size in the event?
traceEventCreateThread(cap, tso);
return tso;
}
void
tryWakeupThread (Capability *cap, StgTSO *tso)
{
traceEventThreadWakeup (cap, tso, tso->cap->no);
#ifdef THREADED_RTS
if (tso->cap != cap)
{
MessageWakeup *msg;
msg = (MessageWakeup *)allocate(cap,sizeofW(MessageWakeup));
SET_HDR(msg, &stg_MSG_TRY_WAKEUP_info, CCS_SYSTEM);
msg->tso = tso;
sendMessage(cap, tso->cap, (Message*)msg);
debugTraceCap(DEBUG_sched, cap, "message: try wakeup thread %ld on cap %d",
(W_)tso->id, tso->cap->no);
return;
}
#endif
switch (tso->why_blocked)
{
case BlockedOnMVar:
case BlockedOnMVarRead:
{
if (tso->_link == END_TSO_QUEUE) {
tso->block_info.closure = (StgClosure*)END_TSO_QUEUE;
goto unblock;
} else {
return;
}
}
case BlockedOnMsgThrowTo:
{
const StgInfoTable *i;
i = lockClosure(tso->block_info.closure);
unlockClosure(tso->block_info.closure, i);
if (i != &stg_MSG_NULL_info) {
debugTraceCap(DEBUG_sched, cap, "thread %ld still blocked on throwto (%p)",
(W_)tso->id, tso->block_info.throwto->header.info);
return;
}
// remove the block frame from the stack
ASSERT(tso->stackobj->sp[0] == (StgWord)&stg_block_throwto_info);
tso->stackobj->sp += 3;
goto unblock;
}
case BlockedOnBlackHole:
case BlockedOnSTM:
case ThreadMigrating:
goto unblock;
default:
// otherwise, do nothing
return;
}
unblock:
// just run the thread now, if the BH is not really available,
// we'll block again.
tso->why_blocked = NotBlocked;
appendToRunQueue(cap,tso);
// We used to set the context switch flag here, which would
// trigger a context switch a short time in the future (at the end
// of the current nursery block). The idea is that we have just
// woken up a thread, so we may need to load-balance and migrate
// threads to other CPUs. On the other hand, setting the context
// switch flag here unfairly penalises the current thread by
// yielding its time slice too early.
//
// The synthetic benchmark nofib/smp/chan can be used to show the
// difference quite clearly.
// cap->context_switch = 1;
}
// ToDo: too big to inline
static /* STATIC_INLINE */ StgPtr
thread_obj (StgInfoTable *info, StgPtr p)
{
switch (info->type) {
case THUNK_0_1:
return p + sizeofW(StgThunk) + 1;
case FUN_0_1:
case CONSTR_0_1:
return p + sizeofW(StgHeader) + 1;
case FUN_1_0:
case CONSTR_1_0:
thread(&((StgClosure *)p)->payload[0]);
return p + sizeofW(StgHeader) + 1;
case THUNK_1_0:
thread(&((StgThunk *)p)->payload[0]);
return p + sizeofW(StgThunk) + 1;
case THUNK_0_2:
return p + sizeofW(StgThunk) + 2;
case FUN_0_2:
case CONSTR_0_2:
return p + sizeofW(StgHeader) + 2;
case THUNK_1_1:
thread(&((StgThunk *)p)->payload[0]);
return p + sizeofW(StgThunk) + 2;
case FUN_1_1:
case CONSTR_1_1:
thread(&((StgClosure *)p)->payload[0]);
return p + sizeofW(StgHeader) + 2;
case THUNK_2_0:
thread(&((StgThunk *)p)->payload[0]);
thread(&((StgThunk *)p)->payload[1]);
return p + sizeofW(StgThunk) + 2;
case FUN_2_0:
case CONSTR_2_0:
thread(&((StgClosure *)p)->payload[0]);
thread(&((StgClosure *)p)->payload[1]);
return p + sizeofW(StgHeader) + 2;
#ifdef ALLOW_INTERPRETER
case BCO: {
StgBCO *bco = (StgBCO *)p;
thread_(&bco->instrs);
thread_(&bco->literals);
thread_(&bco->ptrs);
return p + bco_sizeW(bco);
}
#endif // ALLOW_INTERPRETER
case THUNK:
{
StgPtr end;
end = (P_)((StgThunk *)p)->payload +
info->layout.payload.ptrs;
for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
thread((StgClosure **)p);
}
return p + info->layout.payload.nptrs;
}
case FUN:
case CONSTR:
case STABLE_NAME:
case IND_PERM:
case MUT_VAR_CLEAN:
case MUT_VAR_DIRTY:
case CAF_BLACKHOLE:
case SE_CAF_BLACKHOLE:
case SE_BLACKHOLE:
case BLACKHOLE:
{
StgPtr end;
end = (P_)((StgClosure *)p)->payload +
info->layout.payload.ptrs;
for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
thread((StgClosure **)p);
}
return p + info->layout.payload.nptrs;
}
case WEAK:
{
StgWeak *w = (StgWeak *)p;
thread(&w->key);
thread(&w->value);
thread(&w->finalizer);
if (w->link != NULL) {
thread_(&w->link);
}
return p + sizeofW(StgWeak);
}
case IND_OLDGEN:
case IND_OLDGEN_PERM:
thread(&((StgInd *)p)->indirectee);
return p + sizeofW(StgInd);
case THUNK_SELECTOR:
{
StgSelector *s = (StgSelector *)p;
thread(&s->selectee);
return p + THUNK_SELECTOR_sizeW();
}
case AP_STACK:
return thread_AP_STACK((StgAP_STACK *)p);
case PAP:
return thread_PAP((StgPAP *)p);
case AP:
return thread_AP((StgAP *)p);
case ARR_WORDS:
return p + arr_words_sizeW((StgArrWords *)p);
case MUT_ARR_PTRS_CLEAN:
case MUT_ARR_PTRS_DIRTY:
case MUT_ARR_PTRS_FROZEN:
case MUT_ARR_PTRS_FROZEN0:
// follow everything
{
StgPtr next;
next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
thread((StgClosure **)p);
}
return p;
}
case TSO:
return thread_TSO((StgTSO *)p);
default:
barf("update_fwd: unknown/strange object %d", (int)(info->type));
return NULL;
}
}
nat messageBlackHole(Capability *cap, MessageBlackHole *msg)
{
const StgInfoTable *info;
StgClosure *p;
StgBlockingQueue *bq;
StgClosure *bh = UNTAG_CLOSURE(msg->bh);
StgTSO *owner;
debugTraceCap(DEBUG_sched, cap, "message: thread %d blocking on blackhole %p",
(lnat)msg->tso->id, msg->bh);
info = bh->header.info;
// If we got this message in our inbox, it might be that the
// BLACKHOLE has already been updated, and GC has shorted out the
// indirection, so the pointer no longer points to a BLACKHOLE at
// all.
if (info != &stg_BLACKHOLE_info &&
info != &stg_CAF_BLACKHOLE_info &&
info != &__stg_EAGER_BLACKHOLE_info &&
info != &stg_WHITEHOLE_info) {
// if it is a WHITEHOLE, then a thread is in the process of
// trying to BLACKHOLE it. But we know that it was once a
// BLACKHOLE, so there is at least a valid pointer in the
// payload, so we can carry on.
return 0;
}
// The blackhole must indirect to a TSO, a BLOCKING_QUEUE, an IND,
// or a value.
loop:
// NB. VOLATILE_LOAD(), because otherwise gcc hoists the load
// and turns this into an infinite loop.
p = UNTAG_CLOSURE((StgClosure*)VOLATILE_LOAD(&((StgInd*)bh)->indirectee));
info = p->header.info;
if (info == &stg_IND_info)
{
// This could happen, if e.g. we got a BLOCKING_QUEUE that has
// just been replaced with an IND by another thread in
// updateThunk(). In which case, if we read the indirectee
// again we should get the value.
goto loop;
}
else if (info == &stg_TSO_info)
{
owner = (StgTSO*)p;
#ifdef THREADED_RTS
if (owner->cap != cap) {
sendMessage(cap, owner->cap, (Message*)msg);
debugTraceCap(DEBUG_sched, cap, "forwarding message to cap %d", owner->cap->no);
return 1;
}
#endif
// owner is the owner of the BLACKHOLE, and resides on this
// Capability. msg->tso is the first thread to block on this
// BLACKHOLE, so we first create a BLOCKING_QUEUE object.
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;
msg->link = (MessageBlackHole*)END_TSO_QUEUE;
// All BLOCKING_QUEUES are linked in a list on owner->bq, so
// that we can search through them in the event that there is
// a collision to update a BLACKHOLE and a BLOCKING_QUEUE
// becomes orphaned (see updateThunk()).
bq->link = owner->bq;
owner->bq = bq;
dirty_TSO(cap, owner); // we modified owner->bq
// If the owner of the blackhole is currently runnable, then
// bump it to the front of the run queue. This gives the
// blocked-on thread a little boost which should help unblock
// this thread, and may avoid a pile-up of other threads
// becoming blocked on the same BLACKHOLE (#3838).
//
// NB. we check to make sure that the owner is not the same as
// the current thread, since in that case it will not be on
// the run queue.
if (owner->why_blocked == NotBlocked && owner->id != msg->tso->id) {
removeFromRunQueue(cap, owner);
pushOnRunQueue(cap,owner);
}
// point to the BLOCKING_QUEUE from the BLACKHOLE
write_barrier(); // make the BQ visible
((StgInd*)bh)->indirectee = (StgClosure *)bq;
recordClosureMutated(cap,bh); // bh was mutated
debugTraceCap(DEBUG_sched, cap, "thread %d blocked on thread %d",
(lnat)msg->tso->id, (lnat)owner->id);
return 1; // blocked
}
else if (info == &stg_BLOCKING_QUEUE_CLEAN_info ||
info == &stg_BLOCKING_QUEUE_DIRTY_info)
{
StgBlockingQueue *bq = (StgBlockingQueue *)p;
ASSERT(bq->bh == bh);
owner = bq->owner;
ASSERT(owner != END_TSO_QUEUE);
#ifdef THREADED_RTS
if (owner->cap != cap) {
sendMessage(cap, owner->cap, (Message*)msg);
debugTraceCap(DEBUG_sched, cap, "forwarding message to cap %d", owner->cap->no);
return 1;
}
#endif
msg->link = bq->queue;
bq->queue = msg;
recordClosureMutated(cap,(StgClosure*)msg);
if (info == &stg_BLOCKING_QUEUE_CLEAN_info) {
bq->header.info = &stg_BLOCKING_QUEUE_DIRTY_info;
recordClosureMutated(cap,(StgClosure*)bq);
}
debugTraceCap(DEBUG_sched, cap, "thread %d blocked on thread %d",
(lnat)msg->tso->id, (lnat)owner->id);
// See above, #3838
if (owner->why_blocked == NotBlocked && owner->id != msg->tso->id) {
removeFromRunQueue(cap, owner);
pushOnRunQueue(cap,owner);
}
return 1; // blocked
}
return 0; // not blocked
}
/* -----------------------------------------------------------------------------
* Pausing a thread
*
* We have to prepare for GC - this means doing lazy black holing
* here. We also take the opportunity to do stack squeezing if it's
* turned on.
* -------------------------------------------------------------------------- */
void
threadPaused(Capability *cap, StgTSO *tso)
{
StgClosure *frame;
const StgRetInfoTable *info;
const StgInfoTable *bh_info;
const StgInfoTable *cur_bh_info USED_IF_THREADS;
StgClosure *bh;
StgPtr stack_end;
uint32_t words_to_squeeze = 0;
uint32_t weight = 0;
uint32_t weight_pending = 0;
bool prev_was_update_frame = false;
StgWord heuristic_says_squeeze;
// Check to see whether we have threads waiting to raise
// exceptions, and we're not blocking exceptions, or are blocked
// interruptibly. This is important; if a thread is running with
// TSO_BLOCKEX and becomes blocked interruptibly, this is the only
// place we ensure that the blocked_exceptions get a chance.
maybePerformBlockedException (cap, tso);
if (tso->what_next == ThreadKilled) { return; }
// NB. Updatable thunks *must* be blackholed, either by eager blackholing or
// lazy blackholing. See Note [upd-black-hole] in sm/Scav.c.
stack_end = tso->stackobj->stack + tso->stackobj->stack_size;
frame = (StgClosure *)tso->stackobj->sp;
while ((P_)frame < stack_end) {
info = get_ret_itbl(frame);
switch (info->i.type) {
case UPDATE_FRAME:
// If we've already marked this frame, then stop here.
if (frame->header.info == (StgInfoTable *)&stg_marked_upd_frame_info) {
if (prev_was_update_frame) {
words_to_squeeze += sizeofW(StgUpdateFrame);
weight += weight_pending;
weight_pending = 0;
}
goto end;
}
SET_INFO(frame, (StgInfoTable *)&stg_marked_upd_frame_info);
bh = ((StgUpdateFrame *)frame)->updatee;
bh_info = bh->header.info;
#if defined(THREADED_RTS)
retry:
#endif
// Note [suspend duplicate work]
//
// If the info table is a WHITEHOLE or a BLACKHOLE, then
// another thread has claimed it (via the SET_INFO()
// below), or is in the process of doing so. In that case
// we want to suspend the work that the current thread has
// done on this thunk and wait until the other thread has
// finished.
//
// If eager blackholing is taking place, it could be the
// case that the blackhole points to the current
// TSO. e.g.:
//
// this thread other thread
// --------------------------------------------------------
// c->indirectee = other_tso;
// c->header.info = EAGER_BH
// threadPaused():
// c->header.info = WHITEHOLE
// c->indirectee = other_tso
// c->indirectee = this_tso;
// c->header.info = EAGER_BH
// c->header.info = BLACKHOLE
// threadPaused()
// *** c->header.info is now BLACKHOLE,
// c->indirectee points to this_tso
//
// So in this case do *not* suspend the work of the
// current thread, because the current thread will become
// deadlocked on itself. See #5226 for an instance of
// this bug.
//
// Note that great care is required when entering computations
// suspended by this mechanism. See Note [AP_STACKs must be eagerly
// blackholed] for details.
if (((bh_info == &stg_BLACKHOLE_info)
&& ((StgInd*)bh)->indirectee != (StgClosure*)tso)
|| (bh_info == &stg_WHITEHOLE_info))
{
debugTrace(DEBUG_squeeze,
"suspending duplicate work: %ld words of stack",
(long)((StgPtr)frame - tso->stackobj->sp));
// If this closure is already an indirection, then
// suspend the computation up to this point.
// NB. check raiseAsync() to see what happens when
// we're in a loop (#2783).
suspendComputation(cap,tso,(StgUpdateFrame*)frame);
// Now drop the update frame, and arrange to return
// the value to the frame underneath:
tso->stackobj->sp = (StgPtr)frame + sizeofW(StgUpdateFrame) - 2;
tso->stackobj->sp[1] = (StgWord)bh;
ASSERT(bh->header.info != &stg_TSO_info);
tso->stackobj->sp[0] = (W_)&stg_enter_info;
// And continue with threadPaused; there might be
// yet more computation to suspend.
frame = (StgClosure *)(tso->stackobj->sp + 2);
prev_was_update_frame = false;
continue;
}
// We should never have made it here in the event of blackholes that
// we already own; they should have been marked when we blackholed
// them and consequently we should have stopped our stack walk
// above.
ASSERT(!((bh_info == &stg_BLACKHOLE_info)
&& (((StgInd*)bh)->indirectee == (StgClosure*)tso)));
// zero out the slop so that the sanity checker can tell
// where the next closure is.
OVERWRITING_CLOSURE(bh);
// an EAGER_BLACKHOLE or CAF_BLACKHOLE gets turned into a
// BLACKHOLE here.
#if defined(THREADED_RTS)
// first we turn it into a WHITEHOLE to claim it, and if
// successful we write our TSO and then the BLACKHOLE info pointer.
cur_bh_info = (const StgInfoTable *)
cas((StgVolatilePtr)&bh->header.info,
(StgWord)bh_info,
(StgWord)&stg_WHITEHOLE_info);
if (cur_bh_info != bh_info) {
bh_info = cur_bh_info;
goto retry;
}
#endif
// The payload of the BLACKHOLE points to the TSO
((StgInd *)bh)->indirectee = (StgClosure *)tso;
write_barrier();
SET_INFO(bh,&stg_BLACKHOLE_info);
// .. and we need a write barrier, since we just mutated the closure:
recordClosureMutated(cap,bh);
// We pretend that bh has just been created.
LDV_RECORD_CREATE(bh);
frame = (StgClosure *) ((StgUpdateFrame *)frame + 1);
if (prev_was_update_frame) {
words_to_squeeze += sizeofW(StgUpdateFrame);
weight += weight_pending;
weight_pending = 0;
}
prev_was_update_frame = true;
break;
case UNDERFLOW_FRAME:
case STOP_FRAME:
goto end;
// normal stack frames; do nothing except advance the pointer
default:
{
uint32_t frame_size = stack_frame_sizeW(frame);
weight_pending += frame_size;
frame = (StgClosure *)((StgPtr)frame + frame_size);
prev_was_update_frame = false;
}
}
}
end:
// Should we squeeze or not? Arbitrary heuristic: we squeeze if
// the number of words we have to shift down is less than the
// number of stack words we squeeze away by doing so.
// The threshold was bumped from 5 to 8 as a result of #2797
heuristic_says_squeeze = ((weight <= 8 && words_to_squeeze > 0)
|| weight < words_to_squeeze);
debugTrace(DEBUG_squeeze,
"words_to_squeeze: %d, weight: %d, squeeze: %s",
words_to_squeeze, weight,
heuristic_says_squeeze ? "YES" : "NO");
if (RtsFlags.GcFlags.squeezeUpdFrames == true &&
heuristic_says_squeeze) {
stackSqueeze(cap, tso, (StgPtr)frame);
tso->flags |= TSO_SQUEEZED;
// This flag tells threadStackOverflow() that the stack was
// squeezed, because it may not need to be expanded.
} else {
tso->flags &= ~TSO_SQUEEZED;
}
}
