static void
checkPAP (StgClosure *tagged_fun, StgClosure** payload, StgWord n_args)
{
const StgClosure *fun;
const StgFunInfoTable *fun_info;
fun = UNTAG_CONST_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));
}
/*
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));
}
}
}
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;
}
void
printClosure( const StgClosure *obj )
{
const StgInfoTable *info;
obj = UNTAG_CONST_CLOSURE(obj);
info = get_itbl(obj);
switch ( info->type ) {
case INVALID_OBJECT:
barf("Invalid object");
case CONSTR:
case CONSTR_1_0: case CONSTR_0_1:
case CONSTR_1_1: case CONSTR_0_2: case CONSTR_2_0:
case CONSTR_STATIC:
case CONSTR_NOCAF_STATIC:
{
StgWord i, j;
const StgConInfoTable *con_info = get_con_itbl (obj);
debugBelch("%s(", GET_CON_DESC(con_info));
for (i = 0; i < info->layout.payload.ptrs; ++i) {
if (i != 0) debugBelch(", ");
printPtr((StgPtr)obj->payload[i]);
}
for (j = 0; j < info->layout.payload.nptrs; ++j) {
if (i != 0 || j != 0) debugBelch(", ");
debugBelch("%p#", obj->payload[i+j]);
}
debugBelch(")\n");
break;
}
case FUN:
case FUN_1_0: case FUN_0_1:
case FUN_1_1: case FUN_0_2: case FUN_2_0:
case FUN_STATIC:
debugBelch("FUN/%d(",(int)itbl_to_fun_itbl(info)->f.arity);
printPtr((StgPtr)obj->header.info);
#ifdef PROFILING
debugBelch(", %s", obj->header.prof.ccs->cc->label);
#endif
printStdObjPayload(obj);
break;
case PRIM:
debugBelch("PRIM(");
printPtr((StgPtr)obj->header.info);
printStdObjPayload(obj);
break;
case MUT_PRIM:
debugBelch("MUT_PRIM(");
printPtr((StgPtr)obj->header.info);
printStdObjPayload(obj);
break;
case THUNK:
case THUNK_1_0: case THUNK_0_1:
case THUNK_1_1: case THUNK_0_2: case THUNK_2_0:
case THUNK_STATIC:
/* ToDo: will this work for THUNK_STATIC too? */
#ifdef PROFILING
printThunkObject((StgThunk *)obj,GET_PROF_DESC(info));
#else
printThunkObject((StgThunk *)obj,"THUNK");
#endif
break;
case THUNK_SELECTOR:
printStdObjHdr(obj, "THUNK_SELECTOR");
debugBelch(", %p)\n", ((StgSelector *)obj)->selectee);
break;
case BCO:
disassemble( (StgBCO*)obj );
break;
case AP:
{
StgAP* ap = (StgAP*)obj;
StgWord i;
debugBelch("AP("); printPtr((StgPtr)ap->fun);
for (i = 0; i < ap->n_args; ++i) {
debugBelch(", ");
printPtr((P_)ap->payload[i]);
}
debugBelch(")\n");
break;
}
case PAP:
{
StgPAP* pap = (StgPAP*)obj;
StgWord i;
debugBelch("PAP/%d(",(int)pap->arity);
printPtr((StgPtr)pap->fun);
for (i = 0; i < pap->n_args; ++i) {
debugBelch(", ");
printPtr((StgPtr)pap->payload[i]);
}
debugBelch(")\n");
break;
}
case AP_STACK:
{
StgAP_STACK* ap = (StgAP_STACK*)obj;
StgWord i;
debugBelch("AP_STACK("); printPtr((StgPtr)ap->fun);
for (i = 0; i < ap->size; ++i) {
debugBelch(", ");
printPtr((P_)ap->payload[i]);
}
debugBelch(")\n");
break;
}
case IND:
debugBelch("IND(");
printPtr((StgPtr)((StgInd*)obj)->indirectee);
debugBelch(")\n");
break;
case IND_STATIC:
debugBelch("IND_STATIC(");
printPtr((StgPtr)((StgInd*)obj)->indirectee);
debugBelch(")\n");
break;
case BLACKHOLE:
debugBelch("BLACKHOLE(");
printPtr((StgPtr)((StgInd*)obj)->indirectee);
debugBelch(")\n");
break;
/* Cannot happen -- use default case.
case RET_BCO:
case RET_SMALL:
case RET_BIG:
case RET_FUN:
*/
case UPDATE_FRAME:
{
StgUpdateFrame* u = (StgUpdateFrame*)obj;
debugBelch("%s(", info_update_frame(obj));
printPtr((StgPtr)GET_INFO((StgClosure *)u));
debugBelch(",");
printPtr((StgPtr)u->updatee);
debugBelch(")\n");
break;
}
case CATCH_FRAME:
{
StgCatchFrame* u = (StgCatchFrame*)obj;
debugBelch("CATCH_FRAME(");
printPtr((StgPtr)GET_INFO((StgClosure *)u));
debugBelch(",");
printPtr((StgPtr)u->handler);
debugBelch(")\n");
break;
}
case UNDERFLOW_FRAME:
{
StgUnderflowFrame* u = (StgUnderflowFrame*)obj;
debugBelch("UNDERFLOW_FRAME(");
printPtr((StgPtr)u->next_chunk);
debugBelch(")\n");
break;
}
case STOP_FRAME:
{
StgStopFrame* u = (StgStopFrame*)obj;
debugBelch("STOP_FRAME(");
printPtr((StgPtr)GET_INFO((StgClosure *)u));
debugBelch(")\n");
break;
}
case ARR_WORDS:
{
StgWord i;
debugBelch("ARR_WORDS(\"");
for (i=0; i<arr_words_words((StgArrBytes *)obj); i++)
debugBelch("%" FMT_Word, (W_)((StgArrBytes *)obj)->payload[i]);
debugBelch("\")\n");
break;
}
case MUT_ARR_PTRS_CLEAN:
debugBelch("MUT_ARR_PTRS_CLEAN(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
break;
case MUT_ARR_PTRS_DIRTY:
debugBelch("MUT_ARR_PTRS_DIRTY(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
break;
case MUT_ARR_PTRS_FROZEN:
debugBelch("MUT_ARR_PTRS_FROZEN(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
break;
case SMALL_MUT_ARR_PTRS_CLEAN:
debugBelch("SMALL_MUT_ARR_PTRS_CLEAN(size=%" FMT_Word ")\n",
(W_)((StgSmallMutArrPtrs *)obj)->ptrs);
break;
case SMALL_MUT_ARR_PTRS_DIRTY:
debugBelch("SMALL_MUT_ARR_PTRS_DIRTY(size=%" FMT_Word ")\n",
(W_)((StgSmallMutArrPtrs *)obj)->ptrs);
break;
case SMALL_MUT_ARR_PTRS_FROZEN:
debugBelch("SMALL_MUT_ARR_PTRS_FROZEN(size=%" FMT_Word ")\n",
(W_)((StgSmallMutArrPtrs *)obj)->ptrs);
break;
case MVAR_CLEAN:
case MVAR_DIRTY:
{
StgMVar* mv = (StgMVar*)obj;
debugBelch("MVAR(head=%p, tail=%p, value=%p)\n", mv->head, mv->tail, mv->value);
break;
}
case TVAR:
{
StgTVar* tv = (StgTVar*)obj;
debugBelch("TVAR(value=%p, wq=%p, num_updates=%" FMT_Word ")\n", tv->current_value, tv->first_watch_queue_entry, tv->num_updates);
break;
}
case MUT_VAR_CLEAN:
{
StgMutVar* mv = (StgMutVar*)obj;
debugBelch("MUT_VAR_CLEAN(var=%p)\n", mv->var);
break;
}
case MUT_VAR_DIRTY:
{
StgMutVar* mv = (StgMutVar*)obj;
debugBelch("MUT_VAR_DIRTY(var=%p)\n", mv->var);
break;
}
case WEAK:
debugBelch("WEAK(");
debugBelch(" key=%p value=%p finalizer=%p",
(StgPtr)(((StgWeak*)obj)->key),
(StgPtr)(((StgWeak*)obj)->value),
(StgPtr)(((StgWeak*)obj)->finalizer));
debugBelch(")\n");
/* ToDo: chase 'link' ? */
break;
case TSO:
debugBelch("TSO(");
debugBelch("%lu (%p)",(unsigned long)(((StgTSO*)obj)->id), (StgTSO*)obj);
debugBelch(")\n");
break;
case STACK:
debugBelch("STACK");
break;
#if 0
/* Symptomatic of a problem elsewhere, have it fall-through & fail */
case EVACUATED:
debugBelch("EVACUATED(");
printClosure((StgEvacuated*)obj->evacuee);
debugBelch(")\n");
break;
#endif
case COMPACT_NFDATA:
debugBelch("COMPACT_NFDATA(size=%" FMT_Word ")\n",
(W_)((StgCompactNFData *)obj)->totalDataW * sizeof(W_));
break;
default:
//barf("printClosure %d",get_itbl(obj)->type);
debugBelch("*** printClosure: unknown type %d ****\n",
(int)get_itbl(obj)->type );
barf("printClosure %d",get_itbl(obj)->type);
return;
}
}
// check an individual stack object
StgOffset
checkStackFrame( StgPtr c )
{
uint32_t 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));
/* fallthrough */
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;
uint32_t 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:
{
const StgFunInfoTable *fun_info;
StgRetFun *ret_fun;
ret_fun = (StgRetFun *)c;
fun_info = get_fun_itbl(UNTAG_CONST_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);
}
}
StgOffset
checkClosure( const StgClosure* p )
{
const StgInfoTable *info;
ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
p = UNTAG_CONST_CLOSURE(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:
{
uint32_t 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_NOCAF:
case CONSTR_1_0:
case CONSTR_0_1:
case CONSTR_1_1:
case CONSTR_0_2:
case CONSTR_2_0:
case BLACKHOLE:
case PRIM:
case MUT_PRIM:
case MUT_VAR_CLEAN:
case MUT_VAR_DIRTY:
case TVAR:
case THUNK_STATIC:
case FUN_STATIC:
case COMPACT_NFDATA:
{
uint32_t 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 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((StgArrBytes *)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;
uint32_t 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:
{
uint32_t 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);
}
}
