Printer.c 28 KB
Newer Older
1 2
/* -----------------------------------------------------------------------------
 *
3
 * (c) The GHC Team, 1994-2000.
4 5
 *
 * Heap printer
6
 *
7 8
 * ---------------------------------------------------------------------------*/

9
#include "PosixSource.h"
10
#include "Rts.h"
Simon Marlow's avatar
Simon Marlow committed
11 12
#include "rts/Bytecodes.h"  /* for InstrPtr */

13
#include "sm/Storage.h"
14
#include "Printer.h"
15
#include "RtsUtils.h"
16

17 18
#include <string.h>

19 20 21
#ifdef DEBUG

#include "Disassembler.h"
sof's avatar
sof committed
22
#include "Apply.h"
23 24 25 26 27

/* --------------------------------------------------------------------------
 * local function decls
 * ------------------------------------------------------------------------*/

28
static void    printStdObjPayload( StgClosure *obj );
sof's avatar
sof committed
29
#ifdef USING_LIBBFD
30 31
static void    reset_table   ( int size );
static void    prepare_table ( void );
32
static void    insert        ( StgWord value, const char *name );
sof's avatar
sof committed
33
#endif
34
#if 0 /* unused but might be useful sometime */
35
static rtsBool lookup_name   ( char *name, StgWord *result );
36 37 38 39 40 41
#endif

/* --------------------------------------------------------------------------
 * Printer
 * ------------------------------------------------------------------------*/

42
void printPtr( StgPtr p )
43 44
{
    const char *raw;
45 46
    raw = lookupGHCName(p);
    if (raw != NULL) {
47 48
        debugBelch("<%s>", raw);
        debugBelch("[%p]", p);
49
    } else {
50
        debugBelch("%p", p);
51 52
    }
}
53

54 55
void printObj( StgClosure *obj )
{
56
    debugBelch("Object "); printPtr((StgPtr)obj); debugBelch(" = ");
57 58 59
    printClosure(obj);
}

sof's avatar
sof committed
60
STATIC_INLINE void
61
printStdObjHdr( StgClosure *obj, char* tag )
62
{
63
    debugBelch("%s(",tag);
64
    printPtr((StgPtr)obj->header.info);
65
#ifdef PROFILING
66
    debugBelch(", %s", obj->header.prof.ccs->cc->label);
67
#endif
68 69 70
}

static void
71
printStdObjPayload( StgClosure *obj )
72 73 74 75 76
{
    StgWord i, j;
    const StgInfoTable* info;

    info = get_itbl(obj);
77
    for (i = 0; i < info->layout.payload.ptrs; ++i) {
78
        debugBelch(", ");
79
        printPtr((StgPtr)obj->payload[i]);
80 81
    }
    for (j = 0; j < info->layout.payload.nptrs; ++j) {
82
        debugBelch(", %pd#",obj->payload[i+j]);
83
    }
84
    debugBelch(")\n");
85 86
}

87 88 89 90 91 92
static void
printThunkPayload( StgThunk *obj )
{
    StgWord i, j;
    const StgInfoTable* info;

93
    info = get_itbl((StgClosure *)obj);
94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110
    for (i = 0; i < info->layout.payload.ptrs; ++i) {
        debugBelch(", ");
        printPtr((StgPtr)obj->payload[i]);
    }
    for (j = 0; j < info->layout.payload.nptrs; ++j) {
        debugBelch(", %pd#",obj->payload[i+j]);
    }
    debugBelch(")\n");
}

static void
printThunkObject( StgThunk *obj, char* tag )
{
    printStdObjHdr( (StgClosure *)obj, tag );
    printThunkPayload( obj );
}

111 112
void
printClosure( StgClosure *obj )
113
{
114 115
    obj = UNTAG_CLOSURE(obj);

116 117 118 119
    StgInfoTable *info;
    info = get_itbl(obj);

    switch ( info->type ) {
120 121
    case INVALID_OBJECT:
            barf("Invalid object");
122

sof's avatar
sof committed
123 124 125 126 127
    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:
128
        {
sof's avatar
sof committed
129
            StgWord i, j;
130
            StgConInfoTable *con_info = get_con_itbl (obj);
131

132
            debugBelch("%s(", GET_CON_DESC(con_info));
sof's avatar
sof committed
133
            for (i = 0; i < info->layout.payload.ptrs; ++i) {
134
                if (i != 0) debugBelch(", ");
sof's avatar
sof committed
135 136 137
                printPtr((StgPtr)obj->payload[i]);
            }
            for (j = 0; j < info->layout.payload.nptrs; ++j) {
138
                if (i != 0 || j != 0) debugBelch(", ");
139
                debugBelch("%p#", obj->payload[i+j]);
140
            }
141
            debugBelch(")\n");
142 143 144
            break;
        }

sof's avatar
sof committed
145
    case FUN:
146
    case FUN_1_0: case FUN_0_1:
sof's avatar
sof committed
147 148
    case FUN_1_1: case FUN_0_2: case FUN_2_0:
    case FUN_STATIC:
149 150
        debugBelch("FUN/%d(",(int)itbl_to_fun_itbl(info)->f.arity);
        printPtr((StgPtr)obj->header.info);
sof's avatar
sof committed
151
#ifdef PROFILING
152
        debugBelch(", %s", obj->header.prof.ccs->cc->label);
sof's avatar
sof committed
153
#endif
154 155
        printStdObjPayload(obj);
        break;
sof's avatar
sof committed
156

157
    case PRIM:
158 159 160 161
        debugBelch("PRIM(");
        printPtr((StgPtr)obj->header.info);
        printStdObjPayload(obj);
        break;
162

163 164
    case MUT_PRIM:
        debugBelch("MUT_PRIM(");
165 166 167
        printPtr((StgPtr)obj->header.info);
        printStdObjPayload(obj);
        break;
168

sof's avatar
sof committed
169 170 171 172 173 174
    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
Simon Marlow's avatar
Simon Marlow committed
175
            printThunkObject((StgThunk *)obj,GET_PROF_DESC(info));
sof's avatar
sof committed
176
#else
177
            printThunkObject((StgThunk *)obj,"THUNK");
sof's avatar
sof committed
178 179 180 181
#endif
            break;

    case THUNK_SELECTOR:
182 183 184
        printStdObjHdr(obj, "THUNK_SELECTOR");
        debugBelch(", %p)\n", ((StgSelector *)obj)->selectee);
        break;
sof's avatar
sof committed
185 186 187 188 189

    case BCO:
            disassemble( (StgBCO*)obj );
            break;

190
    case AP:
191
        {
192
            StgAP* ap = (StgAP*)obj;
193
            StgWord i;
194
            debugBelch("AP("); printPtr((StgPtr)ap->fun);
195
            for (i = 0; i < ap->n_args; ++i) {
196
                debugBelch(", ");
197
                printPtr((P_)ap->payload[i]);
198
            }
199
            debugBelch(")\n");
200 201
            break;
        }
202

203 204
    case PAP:
        {
205
            StgPAP* pap = (StgPAP*)obj;
206
            StgWord i;
207 208
            debugBelch("PAP/%d(",(int)pap->arity);
            printPtr((StgPtr)pap->fun);
209
            for (i = 0; i < pap->n_args; ++i) {
210
                debugBelch(", ");
211
                printPtr((StgPtr)pap->payload[i]);
212
            }
213
            debugBelch(")\n");
214 215
            break;
        }
216

sof's avatar
sof committed
217 218
    case AP_STACK:
        {
219
            StgAP_STACK* ap = (StgAP_STACK*)obj;
sof's avatar
sof committed
220
            StgWord i;
221
            debugBelch("AP_STACK("); printPtr((StgPtr)ap->fun);
sof's avatar
sof committed
222
            for (i = 0; i < ap->size; ++i) {
223
                debugBelch(", ");
sof's avatar
sof committed
224 225
                printPtr((P_)ap->payload[i]);
            }
226
            debugBelch(")\n");
227
            break;
sof's avatar
sof committed
228
        }
229

230
    case IND:
231
            debugBelch("IND(");
Simon Marlow's avatar
Simon Marlow committed
232
            printPtr((StgPtr)((StgInd*)obj)->indirectee);
233
            debugBelch(")\n");
234 235 236
            break;

    case IND_PERM:
237
            debugBelch("IND(");
Simon Marlow's avatar
Simon Marlow committed
238
            printPtr((StgPtr)((StgInd*)obj)->indirectee);
239
            debugBelch(")\n");
240
            break;
241 242

    case IND_STATIC:
243
            debugBelch("IND_STATIC(");
Simon Marlow's avatar
Simon Marlow committed
244
            printPtr((StgPtr)((StgInd*)obj)->indirectee);
245
            debugBelch(")\n");
246 247
            break;

248
    case BLACKHOLE:
249
            debugBelch("BLACKHOLE(");
250
            printPtr((StgPtr)((StgInd*)obj)->indirectee);
251
            debugBelch(")\n");
252 253
            break;

sof's avatar
sof committed
254 255 256 257 258 259 260 261 262
    /* Cannot happen -- use default case.
    case RET_BCO:
    case RET_SMALL:
    case RET_BIG:
    case RET_FUN:
    */

    case UPDATE_FRAME:
        {
Simon Marlow's avatar
Simon Marlow committed
263
            StgUpdateFrame* u = (StgUpdateFrame*)obj;
264
            debugBelch("%s(", info_update_frame(obj));
265
            printPtr((StgPtr)GET_INFO((StgClosure *)u));
266
            debugBelch(",");
sof's avatar
sof committed
267
            printPtr((StgPtr)u->updatee);
268
            debugBelch(")\n");
269
            break;
sof's avatar
sof committed
270 271 272 273
        }

    case CATCH_FRAME:
        {
Simon Marlow's avatar
Simon Marlow committed
274
            StgCatchFrame* u = (StgCatchFrame*)obj;
275
            debugBelch("CATCH_FRAME(");
276
            printPtr((StgPtr)GET_INFO((StgClosure *)u));
277
            debugBelch(",");
sof's avatar
sof committed
278
            printPtr((StgPtr)u->handler);
279
            debugBelch(")\n");
sof's avatar
sof committed
280 281 282
            break;
        }

283 284 285 286 287
    case UNDERFLOW_FRAME:
        {
            StgUnderflowFrame* u = (StgUnderflowFrame*)obj;
            debugBelch("UNDERFLOW_FRAME(");
            printPtr((StgPtr)u->next_chunk);
288
            debugBelch(")\n");
289 290 291
            break;
        }

sof's avatar
sof committed
292 293
    case STOP_FRAME:
        {
Simon Marlow's avatar
Simon Marlow committed
294
            StgStopFrame* u = (StgStopFrame*)obj;
295
            debugBelch("STOP_FRAME(");
296
            printPtr((StgPtr)GET_INFO((StgClosure *)u));
297
            debugBelch(")\n");
sof's avatar
sof committed
298 299
            break;
        }
300

sof's avatar
sof committed
301 302 303
    case ARR_WORDS:
        {
            StgWord i;
304
            debugBelch("ARR_WORDS(\"");
305 306
            for (i=0; i<arr_words_words((StgArrWords *)obj); i++)
              debugBelch("%" FMT_Word, (W_)((StgArrWords *)obj)->payload[i]);
307
            debugBelch("\")\n");
308
            break;
sof's avatar
sof committed
309
        }
310

311
    case MUT_ARR_PTRS_CLEAN:
312 313
        debugBelch("MUT_ARR_PTRS_CLEAN(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
        break;
314 315

    case MUT_ARR_PTRS_DIRTY:
316 317
        debugBelch("MUT_ARR_PTRS_DIRTY(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
        break;
sof's avatar
sof committed
318 319

    case MUT_ARR_PTRS_FROZEN:
320 321
        debugBelch("MUT_ARR_PTRS_FROZEN(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
        break;
sof's avatar
sof committed
322

323
    case SMALL_MUT_ARR_PTRS_CLEAN:
324
        debugBelch("SMALL_MUT_ARR_PTRS_CLEAN(size=%" FMT_Word ")\n",
325
                   (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
326
        break;
327 328

    case SMALL_MUT_ARR_PTRS_DIRTY:
329
        debugBelch("SMALL_MUT_ARR_PTRS_DIRTY(size=%" FMT_Word ")\n",
330
                   (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
331
        break;
332 333

    case SMALL_MUT_ARR_PTRS_FROZEN:
334
        debugBelch("SMALL_MUT_ARR_PTRS_FROZEN(size=%" FMT_Word ")\n",
335
                   (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
336
        break;
337

338 339
    case MVAR_CLEAN:
    case MVAR_DIRTY:
sof's avatar
sof committed
340
        {
341 342
          StgMVar* mv = (StgMVar*)obj;
          debugBelch("MVAR(head=%p, tail=%p, value=%p)\n", mv->head, mv->tail, mv->value);
sof's avatar
sof committed
343 344 345
          break;
        }

346 347 348 349 350 351 352
    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;
        }

353
    case MUT_VAR_CLEAN:
sof's avatar
sof committed
354
        {
355 356
          StgMutVar* mv = (StgMutVar*)obj;
          debugBelch("MUT_VAR_CLEAN(var=%p)\n", mv->var);
357 358 359 360 361
          break;
        }

    case MUT_VAR_DIRTY:
        {
362 363
          StgMutVar* mv = (StgMutVar*)obj;
          debugBelch("MUT_VAR_DIRTY(var=%p)\n", mv->var);
sof's avatar
sof committed
364 365 366 367
          break;
        }

    case WEAK:
368 369 370 371 372 373 374
            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' ? */
sof's avatar
sof committed
375 376
            break;

377
    case TSO:
378
      debugBelch("TSO(");
379
      debugBelch("%lu (%p)",(unsigned long)(((StgTSO*)obj)->id), (StgTSO*)obj);
380
      debugBelch(")\n");
381 382
      break;

383 384 385 386
    case STACK:
      debugBelch("STACK");
      break;

sof's avatar
sof committed
387 388 389
#if 0
      /* Symptomatic of a problem elsewhere, have it fall-through & fail */
    case EVACUATED:
390
      debugBelch("EVACUATED(");
sof's avatar
sof committed
391
      printClosure((StgEvacuated*)obj->evacuee);
392
      debugBelch(")\n");
sof's avatar
sof committed
393
      break;
394
#endif
395

396
    default:
397
            //barf("printClosure %d",get_itbl(obj)->type);
398
            debugBelch("*** printClosure: unknown type %d ****\n",
Ian Lynagh's avatar
Ian Lynagh committed
399
                    (int)get_itbl(obj)->type );
400
            barf("printClosure %d",get_itbl(obj)->type);
401 402 403 404
            return;
    }
}

405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422
// If you know you have an UPDATE_FRAME, but want to know exactly which.
char *info_update_frame(StgClosure *closure) {
    // Note: We intentionally don't take the info table pointer as
    // an argument. As it will be confusing whether one should pass
    // it pointing to the code or struct members when compiling with
    // TABLES_NEXT_TO_CODE.
    const StgInfoTable *info = closure->header.info;
    if (info == &stg_upd_frame_info) {
        return "NORMAL_UPDATE_FRAME";
    } else if (info == &stg_bh_upd_frame_info) {
        return "BH_UPDATE_FRAME";
    } else if (info == &stg_marked_upd_frame_info) {
        return "MARKED_UPDATE_FRAME";
    } else {
        return "ERROR: Not an update frame!!!";
    }
}

423 424 425 426 427 428 429
/*
void printGraph( StgClosure *obj )
{
 printClosure(obj);
}
*/

430 431
StgPtr
printStackObj( StgPtr sp )
432
{
433
    /*debugBelch("Stack[%d] = ", &stgStack[STACK_SIZE] - sp); */
434

435
        StgClosure* c = (StgClosure*)(*sp);
436
        printPtr((StgPtr)*sp);
437
        if (c == (StgClosure*)&stg_ctoi_R1p_info) {
438
           debugBelch("\t\t\tstg_ctoi_ret_R1p_info\n" );
439
        } else
440
        if (c == (StgClosure*)&stg_ctoi_R1n_info) {
441
           debugBelch("\t\t\tstg_ctoi_ret_R1n_info\n" );
442
        } else
443
        if (c == (StgClosure*)&stg_ctoi_F1_info) {
444
           debugBelch("\t\t\tstg_ctoi_ret_F1_info\n" );
445
        } else
446
        if (c == (StgClosure*)&stg_ctoi_D1_info) {
447
           debugBelch("\t\t\tstg_ctoi_ret_D1_info\n" );
448
        } else
449
        if (c == (StgClosure*)&stg_ctoi_V_info) {
450
           debugBelch("\t\t\tstg_ctoi_ret_V_info\n" );
451
        } else
452
        if (get_itbl(c)->type == BCO) {
453
           debugBelch("\t\t\t");
454
           debugBelch("BCO(...)\n");
455 456
        }
        else {
457
           debugBelch("\t\t\t");
458 459
           printClosure ( (StgClosure*)(*sp));
        }
460
        sp += 1;
461

462
    return sp;
463

464 465
}

466 467 468 469 470 471
static void
printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap, nat size )
{
    nat i;

    for(i = 0; i < size; i++, bitmap >>= 1 ) {
472 473 474 475 476 477 478
        debugBelch("   stk[%ld] (%p) = ", (long)(spBottom-(payload+i)), payload+i);
        if ((bitmap & 1) == 0) {
            printPtr((P_)payload[i]);
            debugBelch("\n");
        } else {
            debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]);
        }
479 480 481 482 483 484 485 486 487 488 489
    }
}

static void
printLargeBitmap( StgPtr spBottom, StgPtr payload, StgLargeBitmap* large_bitmap, nat size )
{
    StgWord bmp;
    nat i, j;

    i = 0;
    for (bmp=0; i < size; bmp++) {
490 491 492 493 494 495 496 497 498 499 500
        StgWord bitmap = large_bitmap->bitmap[bmp];
        j = 0;
        for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) {
            debugBelch("   stk[%" FMT_Word "] (%p) = ", (W_)(spBottom-(payload+i)), payload+i);
            if ((bitmap & 1) == 0) {
                printPtr((P_)payload[i]);
                debugBelch("\n");
            } else {
                debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]);
            }
        }
501 502 503 504 505
    }
}

void
printStackChunk( StgPtr sp, StgPtr spBottom )
506
{
ken's avatar
ken committed
507
    StgWord bitmap;
508 509 510
    const StgInfoTable *info;

    ASSERT(sp <= spBottom);
511 512
    for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) {

513 514 515
        info = get_itbl((StgClosure *)sp);

        switch (info->type) {
516

517 518
        case UPDATE_FRAME:
        case CATCH_FRAME:
519 520 521
        case UNDERFLOW_FRAME:
        case STOP_FRAME:
            printObj((StgClosure*)sp);
522
            continue;
523

524
        case RET_SMALL:
525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576
            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:
        {
            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");
        }
577 578 579 580 581
    }
}

void printTSO( StgTSO *tso )
{
582 583
    printStackChunk( tso->stackobj->sp,
                     tso->stackobj->stack+tso->stackobj->stack_size);
584 585 586 587 588 589 590 591 592 593 594 595 596 597 598
}

/* --------------------------------------------------------------------------
 * Address printing code
 *
 * Uses symbol table in (unstripped executable)
 * ------------------------------------------------------------------------*/

/* --------------------------------------------------------------------------
 * Simple lookup table
 *
 * Current implementation is pretty dumb!
 * ------------------------------------------------------------------------*/

struct entry {
599
    StgWord value;
600 601 602 603 604 605
    const char *name;
};

static nat table_size;
static struct entry* table;

sof's avatar
sof committed
606 607 608
#ifdef USING_LIBBFD
static nat max_table_size;

609 610 611 612
static void reset_table( int size )
{
    max_table_size = size;
    table_size = 0;
sof's avatar
sof committed
613
    table = (struct entry *)stgMallocBytes(size * sizeof(struct entry), "Printer.c:reset_table()");
614 615 616 617 618 619 620
}

static void prepare_table( void )
{
    /* Could sort it...  */
}

621
static void insert( StgWord value, const char *name )
622 623 624 625 626 627 628 629
{
    if ( table_size >= max_table_size ) {
        barf( "Symbol table overflow\n" );
    }
    table[table_size].value = value;
    table[table_size].name = name;
    table_size = table_size + 1;
}
sof's avatar
sof committed
630
#endif
631 632

#if 0
633
static rtsBool lookup_name( char *name, StgWord *result )
634
{
635
    nat i;
636 637 638 639 640 641 642 643 644 645 646
    for( i = 0; i < table_size && strcmp(name,table[i].name) != 0; ++i ) {
    }
    if (i < table_size) {
        *result = table[i].value;
        return rtsTrue;
    } else {
        return rtsFalse;
    }
}
#endif

647
const char *lookupGHCName( void *addr )
648 649
{
    nat i;
650
    for( i = 0; i < table_size && table[i].value != (StgWord) addr; ++i ) {
651 652
    }
    if (i < table_size) {
653
        return table[i].name;
654
    } else {
655
        return NULL;
656 657 658 659 660 661 662
    }
}

/* --------------------------------------------------------------------------
 * Symbol table loading
 * ------------------------------------------------------------------------*/

sof's avatar
sof committed
663
/* Causing linking trouble on Win32 plats, so I'm
664
   disabling this for now.
sof's avatar
sof committed
665
*/
ken's avatar
ken committed
666
#ifdef USING_LIBBFD
667 668 669 670 671 672 673

#include <bfd.h>

/* Fairly ad-hoc piece of code that seems to filter out a lot of
 * rubbish like the obj-splitting symbols
 */

674
static rtsBool isReal( flagword flags STG_UNUSED, const char *name )
675 676 677
{
#if 0
    /* ToDo: make this work on BFD */
678
    int tp = type & N_TYPE;
679 680 681 682 683 684
    if (tp == N_TEXT || tp == N_DATA) {
        return (name[0] == '_' && name[1] != '_');
    } else {
        return rtsFalse;
    }
#else
685 686 687 688
    if (*name == '\0'  ||
        (name[0] == 'g' && name[1] == 'c' && name[2] == 'c') ||
        (name[0] == 'c' && name[1] == 'c' && name[2] == '.')) {
        return rtsFalse;
689 690 691 692 693 694 695 696 697 698 699 700 701
    }
    return rtsTrue;
#endif
}

extern void DEBUG_LoadSymbols( char *name )
{
    bfd* abfd;
    char **matching;

    bfd_init();
    abfd = bfd_openr(name, "default");
    if (abfd == NULL) {
702
        barf("can't open executable %s to get symbol table", name);
703 704
    }
    if (!bfd_check_format_matches (abfd, bfd_object, &matching)) {
705
        barf("mismatch");
706 707 708
    }

    {
709 710 711
        long storage_needed;
        asymbol **symbol_table;
        long number_of_symbols;
712
        long num_real_syms = 0;
713 714 715 716 717 718 719
        long i;

        storage_needed = bfd_get_symtab_upper_bound (abfd);

        if (storage_needed < 0) {
            barf("can't read symbol table");
        }
720
#if 0
721 722 723
        if (storage_needed == 0) {
            debugBelch("no storage needed");
        }
724
#endif
725
        symbol_table = (asymbol **) stgMallocBytes(storage_needed,"DEBUG_LoadSymbols");
726

727 728 729 730 731
        number_of_symbols = bfd_canonicalize_symtab (abfd, symbol_table);

        if (number_of_symbols < 0) {
            barf("can't canonicalise symbol table");
        }
732 733 734 735

        for( i = 0; i != number_of_symbols; ++i ) {
            symbol_info info;
            bfd_get_symbol_info(abfd,symbol_table[i],&info);
736
            /*debugBelch("\t%c\t0x%x      \t%s\n",info.type,(nat)info.value,info.name); */
737 738 739 740
            if (isReal(info.type, info.name)) {
                num_real_syms += 1;
            }
        }
741

742
        IF_DEBUG(interpreter,
743
                 debugBelch("Loaded %ld symbols. Of which %ld are real symbols\n",
744 745 746 747
                         number_of_symbols, num_real_syms)
                 );

        reset_table( num_real_syms );
748

749 750 751 752 753 754 755
        for( i = 0; i != number_of_symbols; ++i ) {
            symbol_info info;
            bfd_get_symbol_info(abfd,symbol_table[i],&info);
            if (isReal(info.type, info.name)) {
                insert( info.value, info.name );
            }
        }
756

sof's avatar
sof committed
757
        stgFree(symbol_table);
758 759 760 761
    }
    prepare_table();
}

762
#else /* USING_LIBBFD */
763

764
extern void DEBUG_LoadSymbols( char *name STG_UNUSED )
765
{
rrt's avatar
rrt committed
766
  /* nothing, yet */
767 768
}

769
#endif /* USING_LIBBFD */
770

771
void findPtr(P_ p, int);                /* keep gcc -Wall happy */
772

773 774 775 776 777
int searched = 0;

static int
findPtrBlocks (StgPtr p, bdescr *bd, StgPtr arr[], int arr_size, int i)
{
778
    StgPtr q, r, end;
779 780 781 782 783
    for (; bd; bd = bd->link) {
        searched++;
        for (q = bd->start; q < bd->free; q++) {
            if (UNTAG_CLOSURE((StgClosure*)*q) == (StgClosure *)p) {
                if (i < arr_size) {
784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801
                    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);
802 803 804 805 806 807 808 809 810 811
                    }
                } else {
                    return i;
                }
            }
        }
    }
    return i;
}

812
void
813
findPtr(P_ p, int follow)
814
{
815
  nat g, n;
816
  bdescr *bd;
817 818 819
  const int arr_size = 1024;
  StgPtr arr[arr_size];
  int i = 0;
820
  searched = 0;
821

822 823 824 825 826 827
  for (n = 0; n < n_capabilities; n++) {
      bd = nurseries[i].blocks;
      i = findPtrBlocks(p,bd,arr,arr_size,i);
      if (i >= arr_size) return;
  }

828
  for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
Simon Marlow's avatar
Simon Marlow committed
829 830 831 832 833
      bd = generations[g].blocks;
      i = findPtrBlocks(p,bd,arr,arr_size,i);
      bd = generations[g].large_objects;
      i = findPtrBlocks(p,bd,arr,arr_size,i);
      if (i >= arr_size) return;
834 835
  }
  if (follow && i == 1) {
836
      debugBelch("-->\n");
837
      findPtr(arr[0], 1);
838 839 840
  }
}

841 842 843 844 845 846
/* prettyPrintClosure() is for printing out a closure using the data constructor
   names found in the info tables. Closures are printed in a fashion that resembles
   their Haskell representation. Useful during debugging.

   Todo: support for more closure types, and support for non pointer fields in the
   payload.
847
*/
848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864

void prettyPrintClosure_ (StgClosure *);

void prettyPrintClosure (StgClosure *obj)
{
   prettyPrintClosure_ (obj);
   debugBelch ("\n");
}

void prettyPrintClosure_ (StgClosure *obj)
{
    StgInfoTable *info;
    StgConInfoTable *con_info;

    /* collapse any indirections */
    unsigned int type;
    type = get_itbl(obj)->type;
865

866 867
    while (type == IND ||
           type == IND_STATIC ||
868
           type == IND_PERM)
869 870 871 872 873 874 875 876 877
    {
      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 */
878
    switch (info->type)
879 880 881
    {
        /* full applications of data constructors */
        case CONSTR:
882
        case CONSTR_1_0:
883
        case CONSTR_0_1:
884 885
        case CONSTR_1_1:
        case CONSTR_0_2:
886 887
        case CONSTR_2_0:
        case CONSTR_STATIC:
888
        case CONSTR_NOCAF_STATIC:
889
        {
890
           nat i;
891 892 893