void
checkTSO(StgTSO *tso)
{
if (tso->what_next == ThreadKilled) {
/* The garbage collector doesn't bother following any pointers
* from dead threads, so don't check sanity here.
*/
return;
}
ASSERT(tso->_link == END_TSO_QUEUE ||
tso->_link->header.info == &stg_MVAR_TSO_QUEUE_info ||
tso->_link->header.info == &stg_TSO_info);
if ( tso->why_blocked == BlockedOnMVar
|| tso->why_blocked == BlockedOnBlackHole
|| tso->why_blocked == BlockedOnMsgThrowTo
|| tso->why_blocked == NotBlocked
) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->block_info.closure));
}
ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->bq));
ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->blocked_exceptions));
ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->stackobj));
// XXX are we checking the stack twice?
checkSTACK(tso->stackobj);
}
static void
checkPAP (StgClosure *tagged_fun, StgClosure** payload, StgWord n_args)
{
StgClosure *fun;
StgFunInfoTable *fun_info;
fun = UNTAG_CLOSURE(tagged_fun);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(fun));
fun_info = get_fun_itbl(fun);
switch (fun_info->f.fun_type) {
case ARG_GEN:
checkSmallBitmap( (StgPtr)payload,
BITMAP_BITS(fun_info->f.b.bitmap), n_args );
break;
case ARG_GEN_BIG:
checkLargeBitmap( (StgPtr)payload,
GET_FUN_LARGE_BITMAP(fun_info),
n_args );
break;
case ARG_BCO:
checkLargeBitmap( (StgPtr)payload,
BCO_BITMAP(fun),
n_args );
break;
default:
checkSmallBitmap( (StgPtr)payload,
BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
n_args );
break;
}
ASSERT(fun_info->f.arity > TAG_MASK ? GET_CLOSURE_TAG(tagged_fun) == 0
: GET_CLOSURE_TAG(tagged_fun) == fun_info->f.arity);
}
static void
checkClosureShallow( const StgClosure* p )
{
const StgClosure *q;
q = UNTAG_CONST_CLOSURE(p);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
}
static void
checkClosureShallow( StgClosure* p )
{
StgClosure *q;
q = UNTAG_CLOSURE(p);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
/* Is it a static closure? */
if (!HEAP_ALLOCED(q)) {
ASSERT(closure_STATIC(q));
} else {
ASSERT(!closure_STATIC(q));
}
}
/*
Check the static objects list.
*/
void
checkStaticObjects ( StgClosure* static_objects )
{
StgClosure *p = static_objects;
const StgInfoTable *info;
while (p != END_OF_STATIC_OBJECT_LIST) {
p = UNTAG_STATIC_LIST_PTR(p);
checkClosure(p);
info = get_itbl(p);
switch (info->type) {
case IND_STATIC:
{
const StgClosure *indirectee;
indirectee = UNTAG_CONST_CLOSURE(((StgIndStatic *)p)->indirectee);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(indirectee));
ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)indirectee->header.info));
p = *IND_STATIC_LINK((StgClosure *)p);
break;
}
case THUNK_STATIC:
p = *THUNK_STATIC_LINK((StgClosure *)p);
break;
case FUN_STATIC:
p = *STATIC_LINK(info,(StgClosure *)p);
break;
case CONSTR:
case CONSTR_NOCAF:
case CONSTR_1_0:
case CONSTR_2_0:
case CONSTR_1_1:
p = *STATIC_LINK(info,(StgClosure *)p);
break;
default:
barf("checkStaticObjetcs: strange closure %p (%s)",
p, info_type(p));
}
}
}
/*
Check the static objects list.
*/
void
checkStaticObjects ( StgClosure* static_objects )
{
StgClosure *p = static_objects;
StgInfoTable *info;
while (p != END_OF_STATIC_LIST) {
checkClosure(p);
info = get_itbl(p);
switch (info->type) {
case IND_STATIC:
{
StgClosure *indirectee = UNTAG_CLOSURE(((StgIndStatic *)p)->indirectee);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(indirectee));
ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)indirectee->header.info));
p = *IND_STATIC_LINK((StgClosure *)p);
break;
}
case THUNK_STATIC:
p = *THUNK_STATIC_LINK((StgClosure *)p);
break;
case FUN_STATIC:
p = *FUN_STATIC_LINK((StgClosure *)p);
break;
case CONSTR_STATIC:
p = *STATIC_LINK(info,(StgClosure *)p);
break;
default:
barf("checkStaticObjetcs: strange closure %p (%s)", p,
#ifndef HaLVM_TARGET_OS
info_type(p)
#else
"[HaLVM has no info_type()]"
#endif
);
}
}
}
/*
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
update_fwd( bdescr *blocks )
{
StgPtr p;
bdescr *bd;
StgInfoTable *info;
bd = blocks;
// cycle through all the blocks in the step
for (; bd != NULL; bd = bd->link) {
p = bd->start;
// linearly scan the objects in this block
while (p < bd->free) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
info = get_itbl((StgClosure *)p);
p = thread_obj(info, p);
}
}
}
static int
findPtrBlocks (StgPtr p, bdescr *bd, StgPtr arr[], int arr_size, int i)
{
StgPtr q, r, end;
for (; bd; bd = bd->link) {
searched++;
for (q = bd->start; q < bd->free; q++) {
if (UNTAG_CONST_CLOSURE((StgClosure*)*q) == (const StgClosure *)p) {
if (i < arr_size) {
for (r = bd->start; r < bd->free; r = end) {
// skip over zeroed-out slop
while (*r == 0) r++;
if (!LOOKS_LIKE_CLOSURE_PTR(r)) {
debugBelch("%p found at %p, no closure at %p\n",
p, q, r);
break;
}
end = r + closure_sizeW((StgClosure*)r);
if (q < end) {
debugBelch("%p = ", r);
printClosure((StgClosure *)r);
arr[i++] = r;
break;
}
}
if (r >= bd->free) {
debugBelch("%p found at %p, closure?", p, q);
}
} else {
return i;
}
}
}
}
return i;
}
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;
}
// 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);
}
}
void
initStorage( void )
{
nat g, n;
if (generations != NULL) {
// multi-init protection
return;
}
initMBlocks();
/* Sanity check to make sure the LOOKS_LIKE_ macros appear to be
* doing something reasonable.
*/
/* We use the NOT_NULL variant or gcc warns that the test is always true */
ASSERT(LOOKS_LIKE_INFO_PTR_NOT_NULL((StgWord)&stg_BLOCKING_QUEUE_CLEAN_info));
ASSERT(LOOKS_LIKE_CLOSURE_PTR(&stg_dummy_ret_closure));
ASSERT(!HEAP_ALLOCED(&stg_dummy_ret_closure));
if (RtsFlags.GcFlags.maxHeapSize != 0 &&
RtsFlags.GcFlags.heapSizeSuggestion >
RtsFlags.GcFlags.maxHeapSize) {
RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion;
}
if (RtsFlags.GcFlags.maxHeapSize != 0 &&
RtsFlags.GcFlags.minAllocAreaSize >
RtsFlags.GcFlags.maxHeapSize) {
errorBelch("maximum heap size (-M) is smaller than minimum alloc area size (-A)");
RtsFlags.GcFlags.minAllocAreaSize = RtsFlags.GcFlags.maxHeapSize;
}
initBlockAllocator();
#if defined(THREADED_RTS)
initMutex(&sm_mutex);
#endif
ACQUIRE_SM_LOCK;
/* allocate generation info array */
generations = (generation *)stgMallocBytes(RtsFlags.GcFlags.generations
* sizeof(struct generation_),
"initStorage: gens");
/* Initialise all generations */
for(g = 0; g < RtsFlags.GcFlags.generations; g++) {
initGeneration(&generations[g], g);
}
/* A couple of convenience pointers */
g0 = &generations[0];
oldest_gen = &generations[RtsFlags.GcFlags.generations-1];
nurseries = stgMallocBytes(n_capabilities * sizeof(struct nursery_),
"initStorage: nurseries");
/* Set up the destination pointers in each younger gen. step */
for (g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
generations[g].to = &generations[g+1];
}
oldest_gen->to = oldest_gen;
/* The oldest generation has one step. */
if (RtsFlags.GcFlags.compact || RtsFlags.GcFlags.sweep) {
if (RtsFlags.GcFlags.generations == 1) {
errorBelch("WARNING: compact/sweep is incompatible with -G1; disabled");
} else {
oldest_gen->mark = 1;
if (RtsFlags.GcFlags.compact)
oldest_gen->compact = 1;
}
}
generations[0].max_blocks = 0;
/* The allocation area. Policy: keep the allocation area
* small to begin with, even if we have a large suggested heap
* size. Reason: we're going to do a major collection first, and we
* don't want it to be a big one. This vague idea is borne out by
* rigorous experimental evidence.
*/
allocNurseries();
weak_ptr_list = NULL;
caf_list = END_OF_STATIC_LIST;
revertible_caf_list = END_OF_STATIC_LIST;
/* initialise the allocate() interface */
large_alloc_lim = RtsFlags.GcFlags.minAllocAreaSize * BLOCK_SIZE_W;
exec_block = NULL;
#ifdef THREADED_RTS
initSpinLock(&gc_alloc_block_sync);
whitehole_spin = 0;
#endif
N = 0;
// allocate a block for each mut list
for (n = 0; n < n_capabilities; n++) {
for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
capabilities[n].mut_lists[g] = allocBlock();
}
}
initGcThreads();
IF_DEBUG(gc, statDescribeGens());
RELEASE_SM_LOCK;
}
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");
}
StgMutArrPtrs *gtc_heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
StgWord size = gtc_heap_view_closureSize(closure);
StgWord nptrs = 0;
StgWord i;
// First collect all pointers here, with the comfortable memory bound
// of the whole closure. Afterwards we know how many pointers are in
// the closure and then we can allocate space on the heap and copy them
// there
StgClosure *ptrs[size];
StgClosure **end;
StgClosure **ptr;
StgInfoTable *info = get_itbl(closure);
StgThunkInfoTable *thunk_info;
StgFunInfoTable *fun_info;
switch (info->type) {
case INVALID_OBJECT:
barf("Invalid Object");
break;
// No pointers
case ARR_WORDS:
break;
// Default layout
case CONSTR_1_0:
case CONSTR_0_1:
case CONSTR_2_0:
case CONSTR_1_1:
case CONSTR_0_2:
case CONSTR:
case CONSTR_STATIC:
case CONSTR_NOCAF_STATIC:
case PRIM:
case FUN:
case FUN_1_0:
case FUN_0_1:
case FUN_1_1:
case FUN_2_0:
case FUN_0_2:
case FUN_STATIC:
end = closure->payload + info->layout.payload.ptrs;
for (ptr = closure->payload; ptr < end; ptr++) {
ptrs[nptrs++] = *ptr;
}
break;
case THUNK:
case THUNK_1_0:
case THUNK_0_1:
case THUNK_1_1:
case THUNK_2_0:
case THUNK_0_2:
case THUNK_STATIC:
end = ((StgThunk *)closure)->payload + info->layout.payload.ptrs;
for (ptr = ((StgThunk *)closure)->payload; ptr < end; ptr++) {
ptrs[nptrs++] = *ptr;
}
break;
case THUNK_SELECTOR:
ptrs[nptrs++] = ((StgSelector *)closure)->selectee;
break;
case AP:
ptrs[nptrs++] = ((StgAP *)closure)->fun;
gtc_heap_view_closure_ptrs_in_pap_payload(ptrs, &nptrs,
((StgAP *)closure)->fun,
((StgAP *)closure)->payload,
((StgAP *)closure)->n_args);
break;
case PAP:
ptrs[nptrs++] = ((StgPAP *)closure)->fun;
gtc_heap_view_closure_ptrs_in_pap_payload(ptrs, &nptrs,
((StgPAP *)closure)->fun,
((StgPAP *)closure)->payload,
((StgPAP *)closure)->n_args);
break;
case AP_STACK:
ptrs[nptrs++] = ((StgAP_STACK *)closure)->fun;
for (i = 0; i < ((StgAP_STACK *)closure)->size; ++i) {
ptrs[nptrs++] = ((StgAP_STACK *)closure)->payload[i];
}
break;
case BCO:
ptrs[nptrs++] = (StgClosure *)((StgBCO *)closure)->instrs;
ptrs[nptrs++] = (StgClosure *)((StgBCO *)closure)->literals;
ptrs[nptrs++] = (StgClosure *)((StgBCO *)closure)->ptrs;
break;
case IND:
case IND_PERM:
case IND_STATIC:
case BLACKHOLE:
ptrs[nptrs++] = (StgClosure *)(((StgInd *)closure)->indirectee);
break;
case MUT_ARR_PTRS_CLEAN:
case MUT_ARR_PTRS_DIRTY:
case MUT_ARR_PTRS_FROZEN:
case MUT_ARR_PTRS_FROZEN0:
for (i = 0; i < ((StgMutArrPtrs *)closure)->ptrs; ++i) {
ptrs[nptrs++] = ((StgMutArrPtrs *)closure)->payload[i];
}
break;
case MUT_VAR_CLEAN:
ptrs[nptrs++] = ((StgMutVar *)closure)->var;
break;
case MVAR_DIRTY:
case MVAR_CLEAN:
ptrs[nptrs++] = (StgClosure *)((StgMVar *)closure)->head;
ptrs[nptrs++] = (StgClosure *)((StgMVar *)closure)->tail;
ptrs[nptrs++] = ((StgMVar *)closure)->value;
break;
default:
//fprintf(stderr,"closurePtrs: Cannot handle type %s yet\n", gtc_heap_view_closure_type_names[info->type]);
break;
}
size = nptrs + mutArrPtrsCardTableSize(nptrs);
StgMutArrPtrs *arr =
(StgMutArrPtrs *)allocate(cap, sizeofW(StgMutArrPtrs) + size);
TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), nptrs, 0);
SET_HDR(arr, &stg_MUT_ARR_PTRS_FROZEN_info, CCCS);
arr->ptrs = nptrs;
arr->size = size;
for (i = 0; i<nptrs; i++) {
arr->payload[i] = ptrs[i];
}
return arr;
}
static void
scavenge_mark_stack(void)
{
StgPtr p, q;
StgInfoTable *info;
rtsBool saved_eager_promotion;
gct->evac_gen_no = oldest_gen->no;
saved_eager_promotion = gct->eager_promotion;
while ((p = pop_mark_stack())) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
info = get_itbl((StgClosure *)p);
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;
}
break;
}
case FUN_2_0:
scavenge_fun_srt(info);
evacuate(&((StgClosure *)p)->payload[1]);
evacuate(&((StgClosure *)p)->payload[0]);
break;
case THUNK_2_0:
scavenge_thunk_srt(info);
evacuate(&((StgThunk *)p)->payload[1]);
evacuate(&((StgThunk *)p)->payload[0]);
break;
case CONSTR_2_0:
evacuate(&((StgClosure *)p)->payload[1]);
evacuate(&((StgClosure *)p)->payload[0]);
break;
case FUN_1_0:
case FUN_1_1:
scavenge_fun_srt(info);
evacuate(&((StgClosure *)p)->payload[0]);
break;
case THUNK_1_0:
case THUNK_1_1:
scavenge_thunk_srt(info);
evacuate(&((StgThunk *)p)->payload[0]);
break;
case CONSTR_1_0:
case CONSTR_1_1:
evacuate(&((StgClosure *)p)->payload[0]);
break;
case FUN_0_1:
case FUN_0_2:
scavenge_fun_srt(info);
break;
case THUNK_0_1:
case THUNK_0_2:
scavenge_thunk_srt(info);
break;
case CONSTR_0_1:
case CONSTR_0_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);
}
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);
}
break;
}
case BCO: {
StgBCO *bco = (StgBCO *)p;
evacuate((StgClosure **)&bco->instrs);
evacuate((StgClosure **)&bco->literals);
evacuate((StgClosure **)&bco->ptrs);
break;
}
case IND_PERM:
// don't need to do anything here: the only possible case
// is that we're in a 1-space compacting collector, with
// no "old" generation.
break;
case IND:
case BLACKHOLE:
evacuate(&((StgInd *)p)->indirectee);
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;
}
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;
}
break;
}
case ARR_WORDS:
break;
case THUNK_SELECTOR:
{
StgSelector *s = (StgSelector *)p;
evacuate(&s->selectee);
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);
break;
}
case PAP:
scavenge_PAP((StgPAP *)p);
break;
case AP:
scavenge_AP((StgAP *)p);
break;
case MUT_ARR_PTRS_CLEAN:
case MUT_ARR_PTRS_DIRTY:
// follow everything
{
// 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;
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; // mutable anyhow.
break;
}
case MUT_ARR_PTRS_FROZEN:
case MUT_ARR_PTRS_FROZEN0:
// follow everything
{
StgPtr q = 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);
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;
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);
}
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
break;
}
default:
barf("scavenge_mark_stack: unimplemented/strange closure type %d @ %p",
info->type, p);
}
if (gct->failed_to_evac) {
gct->failed_to_evac = rtsFalse;
if (gct->evac_gen_no) {
recordMutableGen_GC((StgClosure *)q, gct->evac_gen_no);
}
}
} // while (p = pop_mark_stack())
}
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;
}
static void
scavenge_static(void)
{
StgClosure* p;
const StgInfoTable *info;
debugTrace(DEBUG_gc, "scavenging static objects");
/* Always evacuate straight to the oldest generation for static
* objects */
gct->evac_gen_no = oldest_gen->no;
/* keep going until we've scavenged all the objects on the linked
list... */
while (1) {
/* get the next static object from the list. Remember, there might
* be more stuff on this list after each evacuation...
* (static_objects is a global)
*/
p = gct->static_objects;
if (p == END_OF_STATIC_LIST) {
break;
}
ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
info = get_itbl(p);
/*
if (info->type==RBH)
info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
*/
// make sure the info pointer is into text space
/* Take this object *off* the static_objects list,
* and put it on the scavenged_static_objects list.
*/
gct->static_objects = *STATIC_LINK(info,p);
*STATIC_LINK(info,p) = gct->scavenged_static_objects;
gct->scavenged_static_objects = p;
switch (info -> type) {
case IND_STATIC:
{
StgInd *ind = (StgInd *)p;
evacuate(&ind->indirectee);
/* might fail to evacuate it, in which case we have to pop it
* back on the mutable list of the oldest generation. We
* leave it *on* the scavenged_static_objects list, though,
* in case we visit this object again.
*/
if (gct->failed_to_evac) {
gct->failed_to_evac = rtsFalse;
recordMutableGen_GC((StgClosure *)p,oldest_gen->no);
}
break;
}
case THUNK_STATIC:
scavenge_thunk_srt(info);
break;
case FUN_STATIC:
scavenge_fun_srt(info);
break;
case CONSTR_STATIC:
{
StgPtr q, next;
next = (P_)p->payload + info->layout.payload.ptrs;
// evacuate the pointers
for (q = (P_)p->payload; q < next; q++) {
evacuate((StgClosure **)q);
}
break;
}
default:
barf("scavenge_static: strange closure %d", (int)(info->type));
}
ASSERT(gct->failed_to_evac == rtsFalse);
}
}
void
scavenge_mutable_list(bdescr *bd, generation *gen)
{
StgPtr p, q;
nat gen_no;
gen_no = gen->no;
gct->evac_gen_no = gen_no;
for (; bd != NULL; bd = bd->link) {
for (q = bd->start; q < bd->free; q++) {
p = (StgPtr)*q;
ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
#ifdef DEBUG
switch (get_itbl((StgClosure *)p)->type) {
case MUT_VAR_CLEAN:
// can happen due to concurrent writeMutVars
case MUT_VAR_DIRTY:
mutlist_MUTVARS++; break;
case MUT_ARR_PTRS_CLEAN:
case MUT_ARR_PTRS_DIRTY:
case MUT_ARR_PTRS_FROZEN:
case MUT_ARR_PTRS_FROZEN0:
mutlist_MUTARRS++; break;
case MVAR_CLEAN:
barf("MVAR_CLEAN on mutable list");
case MVAR_DIRTY:
mutlist_MVARS++; break;
default:
mutlist_OTHERS++; break;
}
#endif
// Check whether this object is "clean", that is it
// definitely doesn't point into a young generation.
// Clean objects don't need to be scavenged. Some clean
// objects (MUT_VAR_CLEAN) are not kept on the mutable
// list at all; others, such as TSO
// are always on the mutable list.
//
switch (get_itbl((StgClosure *)p)->type) {
case MUT_ARR_PTRS_CLEAN:
recordMutableGen_GC((StgClosure *)p,gen_no);
continue;
case MUT_ARR_PTRS_DIRTY:
{
rtsBool saved_eager_promotion;
saved_eager_promotion = gct->eager_promotion;
gct->eager_promotion = rtsFalse;
scavenge_mut_arr_ptrs_marked((StgMutArrPtrs *)p);
if (gct->failed_to_evac) {
((StgClosure *)p)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
} else {
((StgClosure *)p)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
}
gct->eager_promotion = saved_eager_promotion;
gct->failed_to_evac = rtsFalse;
recordMutableGen_GC((StgClosure *)p,gen_no);
continue;
}
default:
;
}
if (scavenge_one(p)) {
// didn't manage to promote everything, so put the
// object back on the list.
recordMutableGen_GC((StgClosure *)p,gen_no);
}
}
}
}
static rtsBool
scavenge_one(StgPtr p)
{
const StgInfoTable *info;
rtsBool no_luck;
rtsBool saved_eager_promotion;
saved_eager_promotion = gct->eager_promotion;
ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
info = get_itbl((StgClosure *)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;
}
break;
}
case THUNK:
case THUNK_1_0:
case THUNK_0_1:
case THUNK_1_1:
case THUNK_0_2:
case THUNK_2_0:
{
StgPtr q, end;
end = (StgPtr)((StgThunk *)p)->payload + info->layout.payload.ptrs;
for (q = (StgPtr)((StgThunk *)p)->payload; q < end; q++) {
evacuate((StgClosure **)q);
}
break;
}
case FUN:
case FUN_1_0: // hardly worth specialising these guys
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 WEAK:
case PRIM:
case IND_PERM:
{
StgPtr q, end;
end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
for (q = (StgPtr)((StgClosure *)p)->payload; q < end; q++) {
evacuate((StgClosure **)q);
}
break;
}
case MUT_VAR_CLEAN:
case MUT_VAR_DIRTY: {
StgPtr q = p;
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;
}
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;
}
break;
}
case THUNK_SELECTOR:
{
StgSelector *s = (StgSelector *)p;
evacuate(&s->selectee);
break;
}
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
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;
scavenge_mut_arr_ptrs((StgMutArrPtrs *)p);
if (gct->failed_to_evac) {
((StgClosure *)p)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
} else {
((StgClosure *)p)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
}
gct->eager_promotion = saved_eager_promotion;
gct->failed_to_evac = rtsTrue;
break;
}
case MUT_ARR_PTRS_FROZEN:
case MUT_ARR_PTRS_FROZEN0:
{
// follow everything
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 *)p)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
} else {
((StgClosure *)p)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
}
break;
}
case TSO:
{
scavengeTSO((StgTSO*)p);
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;
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);
}
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
break;
}
case IND:
// IND can happen, for example, when the interpreter allocates
// a gigantic AP closure (more than one block), which ends up
// on the large-object list and then gets updated. See #3424.
case BLACKHOLE:
case IND_STATIC:
evacuate(&((StgInd *)p)->indirectee);
#if 0 && defined(DEBUG)
if (RtsFlags.DebugFlags.gc)
/* Debugging code to print out the size of the thing we just
* promoted
*/
{
StgPtr start = gen->scan;
bdescr *start_bd = gen->scan_bd;
nat size = 0;
scavenge(&gen);
if (start_bd != gen->scan_bd) {
size += (P_)BLOCK_ROUND_UP(start) - start;
start_bd = start_bd->link;
while (start_bd != gen->scan_bd) {
size += BLOCK_SIZE_W;
start_bd = start_bd->link;
}
size += gen->scan -
(P_)BLOCK_ROUND_DOWN(gen->scan);
} else {
size = gen->scan - start;
}
debugBelch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_));
}
#endif
break;
default:
barf("scavenge_one: strange object %d", (int)(info->type));
}
no_luck = gct->failed_to_evac;
gct->failed_to_evac = rtsFalse;
return (no_luck);
}
void
initStorage (void)
{
nat g;
if (generations != NULL) {
// multi-init protection
return;
}
initMBlocks();
/* Sanity check to make sure the LOOKS_LIKE_ macros appear to be
* doing something reasonable.
*/
/* We use the NOT_NULL variant or gcc warns that the test is always true */
ASSERT(LOOKS_LIKE_INFO_PTR_NOT_NULL((StgWord)&stg_BLOCKING_QUEUE_CLEAN_info));
ASSERT(LOOKS_LIKE_CLOSURE_PTR(&stg_dummy_ret_closure));
ASSERT(!HEAP_ALLOCED(&stg_dummy_ret_closure));
if (RtsFlags.GcFlags.maxHeapSize != 0 &&
RtsFlags.GcFlags.heapSizeSuggestion >
RtsFlags.GcFlags.maxHeapSize) {
RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion;
}
if (RtsFlags.GcFlags.maxHeapSize != 0 &&
RtsFlags.GcFlags.minAllocAreaSize >
RtsFlags.GcFlags.maxHeapSize) {
errorBelch("maximum heap size (-M) is smaller than minimum alloc area size (-A)");
RtsFlags.GcFlags.minAllocAreaSize = RtsFlags.GcFlags.maxHeapSize;
}
initBlockAllocator();
#if defined(THREADED_RTS)
initMutex(&sm_mutex);
#endif
ACQUIRE_SM_LOCK;
/* allocate generation info array */
generations = (generation *)stgMallocBytes(RtsFlags.GcFlags.generations
* sizeof(struct generation_),
"initStorage: gens");
/* Initialise all generations */
for(g = 0; g < RtsFlags.GcFlags.generations; g++) {
initGeneration(&generations[g], g);
}
/* A couple of convenience pointers */
g0 = &generations[0];
oldest_gen = &generations[RtsFlags.GcFlags.generations-1];
/* Set up the destination pointers in each younger gen. step */
for (g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
generations[g].to = &generations[g+1];
}
oldest_gen->to = oldest_gen;
/* The oldest generation has one step. */
if (RtsFlags.GcFlags.compact || RtsFlags.GcFlags.sweep) {
if (RtsFlags.GcFlags.generations == 1) {
errorBelch("WARNING: compact/sweep is incompatible with -G1; disabled");
} else {
oldest_gen->mark = 1;
if (RtsFlags.GcFlags.compact)
oldest_gen->compact = 1;
}
}
generations[0].max_blocks = 0;
dyn_caf_list = (StgIndStatic*)END_OF_CAF_LIST;
debug_caf_list = (StgIndStatic*)END_OF_CAF_LIST;
revertible_caf_list = (StgIndStatic*)END_OF_CAF_LIST;
/* initialise the allocate() interface */
large_alloc_lim = RtsFlags.GcFlags.minAllocAreaSize * BLOCK_SIZE_W;
exec_block = NULL;
#ifdef THREADED_RTS
initSpinLock(&gc_alloc_block_sync);
#ifdef PROF_SPIN
whitehole_spin = 0;
#endif
#endif
N = 0;
next_nursery = 0;
storageAddCapabilities(0, n_capabilities);
IF_DEBUG(gc, statDescribeGens());
RELEASE_SM_LOCK;
traceEventHeapInfo(CAPSET_HEAP_DEFAULT,
RtsFlags.GcFlags.generations,
RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE_W * sizeof(W_),
RtsFlags.GcFlags.minAllocAreaSize * BLOCK_SIZE_W * sizeof(W_),
MBLOCK_SIZE_W * sizeof(W_),
BLOCK_SIZE_W * sizeof(W_));
}
StgClosure *
isAlive(StgClosure *p)
{
const StgInfoTable *info;
bdescr *bd;
StgWord tag;
StgClosure *q;
while (1) {
/* The tag and the pointer are split, to be merged later when needed. */
tag = GET_CLOSURE_TAG(p);
q = UNTAG_CLOSURE(p);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
// ignore static closures
//
// ToDo: This means we never look through IND_STATIC, which means
// isRetainer needs to handle the IND_STATIC case rather than
// raising an error.
//
// ToDo: for static closures, check the static link field.
// Problem here is that we sometimes don't set the link field, eg.
// for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
//
if (!HEAP_ALLOCED_GC(q)) {
return p;
}
// ignore closures in generations that we're not collecting.
bd = Bdescr((P_)q);
// if it's a pointer into to-space, then we're done
if (bd->flags & BF_EVACUATED) {
return p;
}
// large objects use the evacuated flag
if (bd->flags & BF_LARGE) {
return NULL;
}
// check the mark bit for compacted steps
if ((bd->flags & BF_MARKED) && is_marked((P_)q,bd)) {
return p;
}
info = q->header.info;
if (IS_FORWARDING_PTR(info)) {
// alive!
return TAG_CLOSURE(tag,(StgClosure*)UN_FORWARDING_PTR(info));
}
info = INFO_PTR_TO_STRUCT(info);
switch (info->type) {
case IND:
case IND_STATIC:
case IND_PERM:
// follow indirections
p = ((StgInd *)q)->indirectee;
continue;
case BLACKHOLE:
p = ((StgInd*)q)->indirectee;
if (GET_CLOSURE_TAG(p) != 0) {
continue;
} else {
return NULL;
}
default:
// dead.
return NULL;
}
}
}
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);
}
}
// 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 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);
}
}
StgWord gtc_heap_view_closureSize(StgClosure *closure) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
return closure_sizeW(closure);
}
