Example #1
0
/* ----------------------------------------------------------------------------
 * Find the "closure identity", which is a unique pointer representing
 * the band to which this closure's heap space is attributed in the
 * heap profile.
 * ------------------------------------------------------------------------- */
static void *
closureIdentity( StgClosure *p )
{
    switch (RtsFlags.ProfFlags.doHeapProfile) {

#ifdef PROFILING
    case HEAP_BY_CCS:
        return p->header.prof.ccs;
    case HEAP_BY_MOD:
        return p->header.prof.ccs->cc->module;
    case HEAP_BY_DESCR:
        return GET_PROF_DESC(get_itbl(p));
    case HEAP_BY_TYPE:
        return GET_PROF_TYPE(get_itbl(p));
    case HEAP_BY_RETAINER:
        // AFAIK, the only closures in the heap which might not have a
        // valid retainer set are DEAD_WEAK closures.
        if (isRetainerSetFieldValid(p))
            return retainerSetOf(p);
        else
            return NULL;

#else
    case HEAP_BY_CLOSURE_TYPE:
    {
        StgInfoTable *info;
        info = get_itbl(p);
        switch (info->type) {
        case CONSTR:
        case CONSTR_1_0:
        case CONSTR_0_1:
        case CONSTR_2_0:
        case CONSTR_1_1:
        case CONSTR_0_2:
        case CONSTR_STATIC:
        case CONSTR_NOCAF_STATIC:
            return GET_CON_DESC(itbl_to_con_itbl(info));
        default:
            return closure_type_names[info->type];
        }
    }

#endif
    default:
        barf("closureIdentity");
    }
}
Example #2
0
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;
    }
}
Example #3
0
void prettyPrintClosure_ (StgClosure *obj)
{
    StgInfoTable *info;
    StgConInfoTable *con_info;

    /* collapse any indirections */
    unsigned int type;
    type = get_itbl(obj)->type;
           
    while (type == IND ||
           type == IND_STATIC ||
           type == IND_PERM)
    {
      obj = ((StgInd *)obj)->indirectee;
      type = get_itbl(obj)->type;
    }

    /* find the info table for this object */
    info = get_itbl(obj);

    /* determine what kind of object we have */
    switch (info->type) 
    {
        /* full applications of data constructors */
        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: 
        {
           nat i; 
           char *descriptor;

           /* find the con_info for the constructor */
           con_info = get_con_itbl (obj);

           /* obtain the name of the constructor */
           descriptor = GET_CON_DESC(con_info);

           debugBelch ("(%s", descriptor);

           /* process the payload of the closure */
           /* we don't handle non pointers at the moment */
           for (i = 0; i < info->layout.payload.ptrs; i++)
           {
              debugBelch (" ");
              prettyPrintClosure_ ((StgClosure *) obj->payload[i]);
           }
           debugBelch (")");
           break;
        }

        /* if it isn't a constructor then just print the closure type */
        default:
        {
           debugBelch ("<%s>", info_type(obj));
           break;
        }
    }
}