StgPtr
printStackObj( StgPtr sp )
{
/*debugBelch("Stack[%d] = ", &stgStack[STACK_SIZE] - sp); */
StgClosure* c = (StgClosure*)(*sp);
printPtr((StgPtr)*sp);
if (c == (StgClosure*)&stg_ctoi_R1p_info) {
debugBelch("\t\t\tstg_ctoi_ret_R1p_info\n" );
} else
if (c == (StgClosure*)&stg_ctoi_R1n_info) {
debugBelch("\t\t\tstg_ctoi_ret_R1n_info\n" );
} else
if (c == (StgClosure*)&stg_ctoi_F1_info) {
debugBelch("\t\t\tstg_ctoi_ret_F1_info\n" );
} else
if (c == (StgClosure*)&stg_ctoi_D1_info) {
debugBelch("\t\t\tstg_ctoi_ret_D1_info\n" );
} else
if (c == (StgClosure*)&stg_ctoi_V_info) {
debugBelch("\t\t\tstg_ctoi_ret_V_info\n" );
} else
if (get_itbl(c)->type == BCO) {
debugBelch("\t\t\t");
debugBelch("BCO(...)\n");
}
else {
debugBelch("\t\t\t");
printClosure ( (StgClosure*)(*sp));
}
sp += 1;
return sp;
}
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 printObj( StgClosure *obj )
{
debugBelch("Object "); printPtr((StgPtr)obj); debugBelch(" = ");
printClosure(obj);
}
void
printStackChunk( StgPtr sp, StgPtr spBottom )
{
StgWord bitmap;
const StgInfoTable *info;
ASSERT(sp <= spBottom);
for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) {
info = get_itbl((StgClosure *)sp);
switch (info->type) {
case UPDATE_FRAME:
case CATCH_FRAME:
case UNDERFLOW_FRAME:
case STOP_FRAME:
printClosure((StgClosure*)sp);
continue;
case RET_SMALL: {
StgWord c = *sp;
if (c == (StgWord)&stg_ctoi_R1p_info) {
debugBelch("tstg_ctoi_ret_R1p_info\n" );
} else if (c == (StgWord)&stg_ctoi_R1n_info) {
debugBelch("stg_ctoi_ret_R1n_info\n" );
} else if (c == (StgWord)&stg_ctoi_F1_info) {
debugBelch("stg_ctoi_ret_F1_info\n" );
} else if (c == (StgWord)&stg_ctoi_D1_info) {
debugBelch("stg_ctoi_ret_D1_info\n" );
} else if (c == (StgWord)&stg_ctoi_V_info) {
debugBelch("stg_ctoi_ret_V_info\n" );
} else if (c == (StgWord)&stg_ap_v_info) {
debugBelch("stg_ap_v_info\n" );
} else if (c == (StgWord)&stg_ap_f_info) {
debugBelch("stg_ap_f_info\n" );
} else if (c == (StgWord)&stg_ap_d_info) {
debugBelch("stg_ap_d_info\n" );
} else if (c == (StgWord)&stg_ap_l_info) {
debugBelch("stg_ap_l_info\n" );
} else if (c == (StgWord)&stg_ap_n_info) {
debugBelch("stg_ap_n_info\n" );
} else if (c == (StgWord)&stg_ap_p_info) {
debugBelch("stg_ap_p_info\n" );
} else if (c == (StgWord)&stg_ap_pp_info) {
debugBelch("stg_ap_pp_info\n" );
} else if (c == (StgWord)&stg_ap_ppp_info) {
debugBelch("stg_ap_ppp_info\n" );
} else if (c == (StgWord)&stg_ap_pppp_info) {
debugBelch("stg_ap_pppp_info\n" );
} else if (c == (StgWord)&stg_ap_ppppp_info) {
debugBelch("stg_ap_ppppp_info\n" );
} else if (c == (StgWord)&stg_ap_pppppp_info) {
debugBelch("stg_ap_pppppp_info\n" );
#ifdef PROFILING
} else if (c == (StgWord)&stg_restore_cccs_info) {
debugBelch("stg_restore_cccs_info\n" );
fprintCCS(stderr, (CostCentreStack*)sp[1]);
debugBelch("\n" );
continue;
#endif
} else {
debugBelch("RET_SMALL (%p)\n", info);
}
bitmap = info->layout.bitmap;
printSmallBitmap(spBottom, sp+1,
BITMAP_BITS(bitmap), BITMAP_SIZE(bitmap));
continue;
}
case RET_BCO: {
StgBCO *bco;
bco = ((StgBCO *)sp[1]);
debugBelch("RET_BCO (%p)\n", sp);
printLargeBitmap(spBottom, sp+2,
BCO_BITMAP(bco), BCO_BITMAP_SIZE(bco));
continue;
}
case RET_BIG:
barf("todo");
case RET_FUN:
{
const StgFunInfoTable *fun_info;
StgRetFun *ret_fun;
ret_fun = (StgRetFun *)sp;
fun_info = get_fun_itbl(ret_fun->fun);
debugBelch("RET_FUN (%p) (type=%d)\n", ret_fun->fun, (int)fun_info->f.fun_type);
switch (fun_info->f.fun_type) {
case ARG_GEN:
printSmallBitmap(spBottom, sp+2,
BITMAP_BITS(fun_info->f.b.bitmap),
BITMAP_SIZE(fun_info->f.b.bitmap));
break;
case ARG_GEN_BIG:
printLargeBitmap(spBottom, sp+2,
GET_FUN_LARGE_BITMAP(fun_info),
GET_FUN_LARGE_BITMAP(fun_info)->size);
break;
default:
printSmallBitmap(spBottom, sp+2,
BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]));
break;
}
continue;
}
default:
debugBelch("unknown object %d\n", (int)info->type);
barf("printStackChunk");
}
}
}
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;
}
}
void
printClosure1(void *unused, const char *const name, Closure *cl)
{
fprintf(stderr, "%s: [%p]: ", name, cl);
printClosure(cl);
}
