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

9
#include "PosixSource.h"
10
#include "Rts.h"
11
#include "Printer.h"
12
#include "RtsUtils.h"
13

14 15 16
#ifdef DEBUG

#include "RtsFlags.h"
17 18
#include "MBlock.h"
#include "Storage.h"
19 20
#include "Bytecodes.h"  /* for InstrPtr */
#include "Disassembler.h"
sof's avatar
sof committed
21
#include "Apply.h"
22

23 24
#include <stdlib.h>
#include <string.h>
25

26
#if defined(GRAN) || defined(PAR)
27
// HWL: explicit fixed header size to make debugging easier
28
int fixed_hs = sizeof(StgHeader), itbl_sz = sizeofW(StgInfoTable), 
29
    uf_sz=sizeofW(StgUpdateFrame); 
30
#endif
31

32 33 34 35
/* --------------------------------------------------------------------------
 * local function decls
 * ------------------------------------------------------------------------*/

36
static void    printStdObjPayload( StgClosure *obj );
sof's avatar
sof committed
37
#ifdef USING_LIBBFD
38 39
static void    reset_table   ( int size );
static void    prepare_table ( void );
40
static void    insert        ( StgWord value, const char *name );
sof's avatar
sof committed
41
#endif
42
#if 0 /* unused but might be useful sometime */
43
static rtsBool lookup_name   ( char *name, StgWord *result );
44 45 46
static void    enZcode       ( char *in, char *out );
#endif
static char    unZcode       ( char ch );
47
const char *   lookupGHCName ( void *addr );
48 49 50 51 52 53
static void    printZcoded   ( const char *raw );

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

54
void printPtr( StgPtr p )
55 56
{
    const char *raw;
57 58
    raw = lookupGHCName(p);
    if (raw != NULL) {
59 60
        printZcoded(raw);
    } else {
61
        debugBelch("%p", p);
62 63 64 65 66
    }
}
  
void printObj( StgClosure *obj )
{
67
    debugBelch("Object "); printPtr((StgPtr)obj); debugBelch(" = ");
68 69 70
    printClosure(obj);
}

sof's avatar
sof committed
71
STATIC_INLINE void
72
printStdObjHdr( StgClosure *obj, char* tag )
73
{
74
    debugBelch("%s(",tag);
75
    printPtr((StgPtr)obj->header.info);
76
#ifdef PROFILING
77
    debugBelch(", %s", obj->header.prof.ccs->cc->label);
78
#endif
79 80 81
}

static void
82
printStdObjPayload( StgClosure *obj )
83 84 85 86 87
{
    StgWord i, j;
    const StgInfoTable* info;

    info = get_itbl(obj);
88
    for (i = 0; i < info->layout.payload.ptrs; ++i) {
89
        debugBelch(", ");
90
        printPtr((StgPtr)obj->payload[i]);
91 92
    }
    for (j = 0; j < info->layout.payload.nptrs; ++j) {
93
        debugBelch(", %pd#",obj->payload[i+j]);
94
    }
95
    debugBelch(")\n");
96 97
}

98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121
static void
printThunkPayload( StgThunk *obj )
{
    StgWord i, j;
    const StgInfoTable* info;

    info = get_itbl(obj);
    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 );
}

122 123
void
printClosure( StgClosure *obj )
124
{
125 126 127 128 129
    StgInfoTable *info;
    
    info = get_itbl(obj);

    switch ( info->type ) {
130 131
    case INVALID_OBJECT:
            barf("Invalid object");
132

sof's avatar
sof committed
133 134 135 136 137
    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:
138
        {
sof's avatar
sof committed
139 140
            StgWord i, j;
#ifdef PROFILING
141 142
	    debugBelch("%s(", info->prof.closure_desc);
	    debugBelch("%s", obj->header.prof.ccs->cc->label);
sof's avatar
sof committed
143
#else
144
            debugBelch("CONSTR(");
sof's avatar
sof committed
145
            printPtr((StgPtr)obj->header.info);
146
            debugBelch("(tag=%d)",info->srt_bitmap);
sof's avatar
sof committed
147 148
#endif
            for (i = 0; i < info->layout.payload.ptrs; ++i) {
149
		debugBelch(", ");
sof's avatar
sof committed
150 151 152
                printPtr((StgPtr)obj->payload[i]);
            }
            for (j = 0; j < info->layout.payload.nptrs; ++j) {
153
                debugBelch(", %p#", obj->payload[i+j]);
154
            }
155
            debugBelch(")\n");
156 157 158
            break;
        }

sof's avatar
sof committed
159 160 161 162
    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:
163
	debugBelch("FUN/%d(",itbl_to_fun_itbl(info)->f.arity);
sof's avatar
sof committed
164 165
	printPtr((StgPtr)obj->header.info);
#ifdef PROFILING
166
	debugBelch(", %s", obj->header.prof.ccs->cc->label);
sof's avatar
sof committed
167 168 169 170 171 172 173 174 175 176
#endif
	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
177
	    printThunkObject((StgThunk *)obj,info->prof.closure_desc);
sof's avatar
sof committed
178
#else
179
            printThunkObject((StgThunk *)obj,"THUNK");
sof's avatar
sof committed
180 181 182 183 184
#endif
            break;

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

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

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

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

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

232
    case IND:
233
            debugBelch("IND("); 
234
            printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
235
            debugBelch(")\n"); 
236 237
            break;

sof's avatar
sof committed
238
    case IND_OLDGEN:
239
            debugBelch("IND_OLDGEN("); 
sof's avatar
sof committed
240
            printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
241
            debugBelch(")\n"); 
sof's avatar
sof committed
242 243
            break;

244
    case IND_PERM:
245
            debugBelch("IND("); 
246
            printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
247
            debugBelch(")\n"); 
248
            break;
249

sof's avatar
sof committed
250
    case IND_OLDGEN_PERM:
251
            debugBelch("IND_OLDGEN_PERM("); 
sof's avatar
sof committed
252
            printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
253
            debugBelch(")\n"); 
sof's avatar
sof committed
254 255
            break;

256
    case IND_STATIC:
257
            debugBelch("IND_STATIC("); 
258
            printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
259
            debugBelch(")\n"); 
260 261
            break;

sof's avatar
sof committed
262 263 264 265 266 267 268 269 270 271 272 273 274
    /* Cannot happen -- use default case.
    case RET_BCO:
    case RET_SMALL:
    case RET_VEC_SMALL:
    case RET_BIG:
    case RET_VEC_BIG:
    case RET_DYN:
    case RET_FUN:
    */

    case UPDATE_FRAME:
        {
            StgUpdateFrame* u = stgCast(StgUpdateFrame*,obj);
275
            debugBelch("UPDATE_FRAME(");
sof's avatar
sof committed
276
            printPtr((StgPtr)GET_INFO(u));
277
            debugBelch(",");
sof's avatar
sof committed
278
            printPtr((StgPtr)u->updatee);
279
            debugBelch(")\n"); 
280
            break;
sof's avatar
sof committed
281 282 283 284 285
        }

    case CATCH_FRAME:
        {
            StgCatchFrame* u = stgCast(StgCatchFrame*,obj);
286
            debugBelch("CATCH_FRAME(");
sof's avatar
sof committed
287
            printPtr((StgPtr)GET_INFO(u));
288
            debugBelch(",");
sof's avatar
sof committed
289
            printPtr((StgPtr)u->handler);
290
            debugBelch(")\n"); 
sof's avatar
sof committed
291 292 293 294 295 296
            break;
        }

    case STOP_FRAME:
        {
            StgStopFrame* u = stgCast(StgStopFrame*,obj);
297
            debugBelch("STOP_FRAME(");
sof's avatar
sof committed
298
            printPtr((StgPtr)GET_INFO(u));
299
            debugBelch(")\n"); 
sof's avatar
sof committed
300 301
            break;
        }
302

303
    case CAF_BLACKHOLE:
304
            debugBelch("CAF_BH"); 
305
            break;
306

sof's avatar
sof committed
307
    case BLACKHOLE:
308
            debugBelch("BH\n"); 
sof's avatar
sof committed
309 310
            break;

311
    case SE_BLACKHOLE:
312
            debugBelch("SE_BH\n"); 
313 314 315
            break;

    case SE_CAF_BLACKHOLE:
316
            debugBelch("SE_CAF_BH\n"); 
317 318
            break;

sof's avatar
sof committed
319 320 321
    case ARR_WORDS:
        {
            StgWord i;
322
            debugBelch("ARR_WORDS(\"");
sof's avatar
sof committed
323 324 325 326 327
            /* ToDo: we can't safely assume that this is a string! 
            for (i = 0; arrWordsGetChar(obj,i); ++i) {
                putchar(arrWordsGetChar(obj,i));
		} */
	    for (i=0; i<((StgArrWords *)obj)->words; i++)
328
	      debugBelch("%lu", (lnat)((StgArrWords *)obj)->payload[i]);
329
            debugBelch("\")\n");
330
            break;
sof's avatar
sof committed
331
        }
332

333 334 335 336 337 338
    case MUT_ARR_PTRS_CLEAN:
	debugBelch("MUT_ARR_PTRS_CLEAN(size=%lu)\n", (lnat)((StgMutArrPtrs *)obj)->ptrs);
	break;

    case MUT_ARR_PTRS_DIRTY:
	debugBelch("MUT_ARR_PTRS_DIRTY(size=%lu)\n", (lnat)((StgMutArrPtrs *)obj)->ptrs);
sof's avatar
sof committed
339 340 341
	break;

    case MUT_ARR_PTRS_FROZEN:
342
	debugBelch("MUT_ARR_PTRS_FROZEN(size=%lu)\n", (lnat)((StgMutArrPtrs *)obj)->ptrs);
sof's avatar
sof committed
343 344
	break;

sof's avatar
sof committed
345 346 347
    case MVAR:
        {
	  StgMVar* mv = (StgMVar*)obj;
348
	  debugBelch("MVAR(head=%p, tail=%p, value=%p)\n", mv->head, mv->tail, mv->value);
sof's avatar
sof committed
349 350 351
          break;
        }

352
    case MUT_VAR_CLEAN:
sof's avatar
sof committed
353 354
        {
	  StgMutVar* mv = (StgMutVar*)obj;
355 356 357 358 359 360 361 362
	  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);
sof's avatar
sof committed
363 364 365 366
          break;
        }

    case WEAK:
367 368
            debugBelch("WEAK("); 
	    debugBelch(" key=%p value=%p finalizer=%p", 
sof's avatar
sof committed
369 370 371
		    (StgPtr)(((StgWeak*)obj)->key),
		    (StgPtr)(((StgWeak*)obj)->value),
		    (StgPtr)(((StgWeak*)obj)->finalizer));
372
            debugBelch(")\n"); 
sof's avatar
sof committed
373 374 375 376
	    /* ToDo: chase 'link' ? */
            break;

    case STABLE_NAME:
377
            debugBelch("STABLE_NAME(%lu)\n", (lnat)((StgStableName*)obj)->sn); 
378
            break;
379

380
    case TSO:
381
      debugBelch("TSO("); 
382
      debugBelch("%lu (%p)",(unsigned long)(((StgTSO*)obj)->id), (StgTSO*)obj);
383
      debugBelch(")\n"); 
384 385 386 387
      break;

#if defined(PAR)
    case BLOCKED_FETCH:
388
      debugBelch("BLOCKED_FETCH("); 
389 390
      printGA(&(stgCast(StgBlockedFetch*,obj)->ga));
      printPtr((StgPtr)(stgCast(StgBlockedFetch*,obj)->node));
391
      debugBelch(")\n"); 
392 393 394
      break;

    case FETCH_ME:
395
      debugBelch("FETCH_ME("); 
396
      printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
397
      debugBelch(")\n"); 
398 399 400
      break;

    case FETCH_ME_BQ:
401
      debugBelch("FETCH_ME_BQ("); 
402 403
      // printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
      printPtr((StgPtr)stgCast(StgFetchMeBlockingQueue*,obj)->blocking_queue);
404
      debugBelch(")\n"); 
405 406
      break;
#endif
sof's avatar
sof committed
407

408 409
#if defined(GRAN) || defined(PAR)
    case RBH:
410
      debugBelch("RBH("); 
411
      printPtr((StgPtr)stgCast(StgRBH*,obj)->blocking_queue);
412
      debugBelch(")\n"); 
413
      break;
414

415 416
#endif

sof's avatar
sof committed
417 418 419
#if 0
      /* Symptomatic of a problem elsewhere, have it fall-through & fail */
    case EVACUATED:
420
      debugBelch("EVACUATED("); 
sof's avatar
sof committed
421
      printClosure((StgEvacuated*)obj->evacuee);
422
      debugBelch(")\n"); 
sof's avatar
sof committed
423
      break;
424
#endif
425

sof's avatar
sof committed
426 427
#if defined(PAR) && defined(DIST)
    case REMOTE_REF:
428
      debugBelch("REMOTE_REF("); 
sof's avatar
sof committed
429
      printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
430
      debugBelch(")\n"); 
sof's avatar
sof committed
431
      break;
432
#endif
433

434
    default:
435
            //barf("printClosure %d",get_itbl(obj)->type);
436
            debugBelch("*** printClosure: unknown type %d ****\n",
437
                    get_itbl(obj)->type );
438
            barf("printClosure %d",get_itbl(obj)->type);
439 440 441 442
            return;
    }
}

443 444 445 446 447 448 449
/*
void printGraph( StgClosure *obj )
{
 printClosure(obj);
}
*/

450 451
StgPtr
printStackObj( StgPtr sp )
452
{
453
    /*debugBelch("Stack[%d] = ", &stgStack[STACK_SIZE] - sp); */
454

455
        StgClosure* c = (StgClosure*)(*sp);
456
        printPtr((StgPtr)*sp);
457
        if (c == (StgClosure*)&stg_ctoi_R1p_info) {
458
           debugBelch("\t\t\tstg_ctoi_ret_R1p_info\n" );
459
	} else
460
        if (c == (StgClosure*)&stg_ctoi_R1n_info) {
461
           debugBelch("\t\t\tstg_ctoi_ret_R1n_info\n" );
462
	} else
463
        if (c == (StgClosure*)&stg_ctoi_F1_info) {
464
           debugBelch("\t\t\tstg_ctoi_ret_F1_info\n" );
465
	} else
466
        if (c == (StgClosure*)&stg_ctoi_D1_info) {
467
           debugBelch("\t\t\tstg_ctoi_ret_D1_info\n" );
468
	} else
469
        if (c == (StgClosure*)&stg_ctoi_V_info) {
470
           debugBelch("\t\t\tstg_ctoi_ret_V_info\n" );
471
	} else
472
        if (get_itbl(c)->type == BCO) {
473 474
           debugBelch("\t\t\t");
           debugBelch("BCO(...)\n"); 
475 476
        }
        else {
477
           debugBelch("\t\t\t");
478 479
           printClosure ( (StgClosure*)(*sp));
        }
480
        sp += 1;
481

482 483 484 485
    return sp;
    
}

486 487 488 489 490 491 492 493
static void
printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap, nat size )
{
    StgPtr p;
    nat i;

    p = payload;
    for(i = 0; i < size; i++, bitmap >>= 1 ) {
494
	debugBelch("   stk[%ld] (%p) = ", (long)(spBottom-(payload+i)), payload+i);
495 496
	if ((bitmap & 1) == 0) {
	    printPtr((P_)payload[i]);
497
	    debugBelch("\n");
498
	} else {
499
	    debugBelch("Word# %lu\n", (lnat)payload[i]);
500 501 502 503 504 505 506 507 508 509 510 511 512 513 514
	}
    }
}

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++) {
	StgWord bitmap = large_bitmap->bitmap[bmp];
	j = 0;
	for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) {
515
	    debugBelch("   stk[%lu] (%p) = ", (lnat)(spBottom-(payload+i)), payload+i);
516 517
	    if ((bitmap & 1) == 0) {
		printPtr((P_)payload[i]);
518
		debugBelch("\n");
519
	    } else {
520
		debugBelch("Word# %lu\n", (lnat)payload[i]);
521 522 523 524 525 526 527
	    }
	}
    }
}

void
printStackChunk( StgPtr sp, StgPtr spBottom )
528
{
ken's avatar
ken committed
529
    StgWord bitmap;
530 531 532
    const StgInfoTable *info;

    ASSERT(sp <= spBottom);
533 534
    for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) {

535 536
	info = get_itbl((StgClosure *)sp);

537 538
	switch (info->type) {
	    
539 540
	case UPDATE_FRAME:
	case CATCH_FRAME:
541
	    printObj((StgClosure*)sp);
542 543
	    continue;

544 545 546 547
	case STOP_FRAME:
	    printObj((StgClosure*)sp);
	    return;

548
	case RET_DYN:
549 550 551 552 553 554 555 556
	{ 
	    StgRetDyn* r;
	    StgPtr p;
	    StgWord dyn;
	    nat size;

	    r = (StgRetDyn *)sp;
	    dyn = r->liveness;
557
	    debugBelch("RET_DYN (%p)\n", r);
558 559 560

	    p = (P_)(r->payload);
	    printSmallBitmap(spBottom, sp,
561 562
			     RET_DYN_LIVENESS(r->liveness), 
			     RET_DYN_BITMAP_SIZE);
563
	    p += RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE;
564

565
	    for (size = RET_DYN_NONPTRS(dyn); size > 0; size--) {
566 567
		debugBelch("   stk[%ld] (%p) = ", (long)(spBottom-p), p);
		debugBelch("Word# %ld\n", (long)*p);
568 569 570
		p++;
	    }
	
571
	    for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
572
		debugBelch("   stk[%ld] (%p) = ", (long)(spBottom-p), p);
573 574 575 576 577
		printPtr(p);
		p++;
	    }
	    continue;
	}
578 579 580

	case RET_SMALL:
	case RET_VEC_SMALL:
581
	    debugBelch("RET_SMALL (%p)\n", info);
582 583 584 585
	    bitmap = info->layout.bitmap;
	    printSmallBitmap(spBottom, sp+1, 
			     BITMAP_BITS(bitmap), BITMAP_SIZE(bitmap));
	    continue;
586

587 588 589 590
	case RET_BCO: {
	    StgBCO *bco;
	    
	    bco = ((StgBCO *)sp[1]);
591

592
	    debugBelch("RET_BCO (%p)\n", sp);
593 594 595
	    printLargeBitmap(spBottom, sp+2,
			     BCO_BITMAP(bco), BCO_BITMAP_SIZE(bco));
	    continue;
596 597
	}

598 599 600 601
	case RET_BIG:
	case RET_VEC_BIG:
	    barf("todo");

sof's avatar
sof committed
602 603 604 605 606 607 608 609 610
	case RET_FUN:
	{
	    StgFunInfoTable *fun_info;
	    StgRetFun *ret_fun;
	    nat size;

	    ret_fun = (StgRetFun *)sp;
	    fun_info = get_fun_itbl(ret_fun->fun);
	    size = ret_fun->size;
611
	    debugBelch("RET_FUN (%p) (type=%d)\n", ret_fun->fun, fun_info->f.fun_type);
612
	    switch (fun_info->f.fun_type) {
sof's avatar
sof committed
613
	    case ARG_GEN:
614
		printSmallBitmap(spBottom, sp+2,
615 616
				 BITMAP_BITS(fun_info->f.b.bitmap),
				 BITMAP_SIZE(fun_info->f.b.bitmap));
sof's avatar
sof committed
617 618 619
		break;
	    case ARG_GEN_BIG:
		printLargeBitmap(spBottom, sp+2,
620 621
				 GET_FUN_LARGE_BITMAP(fun_info),
				 GET_FUN_LARGE_BITMAP(fun_info)->size);
sof's avatar
sof committed
622 623
		break;
	    default:
624
		printSmallBitmap(spBottom, sp+2,
625 626
				 BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
				 BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]));
sof's avatar
sof committed
627 628 629 630 631
		break;
	    }
	    continue;
	}
	   
632
	default:
633
	    debugBelch("unknown object %d\n", info->type);
634
	    barf("printStackChunk");
635 636 637 638 639 640
	}
    }
}

void printTSO( StgTSO *tso )
{
641
    printStackChunk( tso->sp, tso->stack+tso->stack_size);
642 643
}

644 645 646 647 648 649 650
/* -----------------------------------------------------------------------------
   Closure types
   
   NOTE: must be kept in sync with the closure types in includes/ClosureTypes.h
   -------------------------------------------------------------------------- */

static char *closure_type_names[] = {
651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677
    "INVALID_OBJECT",
    "CONSTR",
    "CONSTR_1",
    "CONSTR_0",
    "CONSTR_2",
    "CONSTR_1",
    "CONSTR_0",
    "CONSTR_STATIC",
    "CONSTR_NOCAF_STATIC",
    "FUN",
    "FUN_1_0",
    "FUN_0_1",
    "FUN_2_0",
    "FUN_1_1",
    "FUN_0",
    "FUN_STATIC",
    "THUNK",
    "THUNK_1_0",
    "THUNK_0_1",
    "THUNK_2_0",
    "THUNK_1_1",
    "THUNK_0",
    "THUNK_STATIC",
    "THUNK_SELECTOR",
    "BCO",
    "AP_UPD",
    "PAP",
sof's avatar
sof committed
678
    "AP_STACK",
679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700
    "IND",
    "IND_OLDGEN",
    "IND_PERM",
    "IND_OLDGEN_PERM",
    "IND_STATIC",
    "RET_BCO",
    "RET_SMALL",
    "RET_VEC_SMALL",
    "RET_BIG",
    "RET_VEC_BIG",
    "RET_DYN",
    "RET_FUN",
    "UPDATE_FRAME",
    "CATCH_FRAME",
    "STOP_FRAME",
    "CAF_BLACKHOLE",
    "BLACKHOLE",
    "BLACKHOLE_BQ",
    "SE_BLACKHOLE",
    "SE_CAF_BLACKHOLE",
    "MVAR",
    "ARR_WORDS",
701 702
    "MUT_ARR_PTRS_CLEAN",
    "MUT_ARR_PTRS_DIRTY",
703
    "MUT_ARR_PTRS_FROZEN",
704 705
    "MUT_VAR_CLEAN",
    "MUT_VAR_DIRTY",
706 707 708 709 710 711 712 713 714 715
    "MUT_CONS",
    "WEAK",
    "FOREIGN",
    "STABLE_NAME",
    "TSO",
    "BLOCKED_FETCH",
    "FETCH_ME",
    "FETCH_ME_BQ",
    "RBH",
    "EVACUATED",
716
    "REMOTE_REF",
tharris@microsoft.com's avatar
tharris@microsoft.com committed
717 718 719
    "TVAR_WATCH_QUEUE",
    "INVARIANT_CHECK_QUEUE",
    "ATOMIC_INVARIANT",
720 721 722 723 724
    "TVAR",
    "TREC_CHUNK",
    "TREC_HEADER",
    "ATOMICALLY_FRAME",
    "CATCH_RETRY_FRAME"
725 726
};

727

728 729 730 731 732 733 734 735 736 737 738 739 740 741
char *
info_type(StgClosure *closure){ 
  return closure_type_names[get_itbl(closure)->type];
}

char *
info_type_by_ip(StgInfoTable *ip){ 
  return closure_type_names[ip->type];
}

void
info_hdr_type(StgClosure *closure, char *res){ 
  strcpy(res,closure_type_names[get_itbl(closure)->type]);
}
742 743 744 745 746 747 748 749 750 751 752 753 754 755

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

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

struct entry {
756
    StgWord value;
757 758 759 760 761 762
    const char *name;
};

static nat table_size;
static struct entry* table;

sof's avatar
sof committed
763 764 765
#ifdef USING_LIBBFD
static nat max_table_size;

766 767 768 769
static void reset_table( int size )
{
    max_table_size = size;
    table_size = 0;
sof's avatar
sof committed
770
    table = (struct entry *)stgMallocBytes(size * sizeof(struct entry), "Printer.c:reset_table()");
771 772 773 774 775 776 777
}

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

778
static void insert( StgWord value, const char *name )
779 780 781 782 783 784 785 786
{
    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
787
#endif
788 789

#if 0
790
static rtsBool lookup_name( char *name, StgWord *result )
791
{
792
    nat i;
793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931
    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

/* Code from somewhere inside GHC (circa 1994)
 * * Z-escapes:
 *     "std"++xs -> "Zstd"++xs
 *     char_to_c 'Z'  = "ZZ"
 *     char_to_c '&'  = "Za"
 *     char_to_c '|'  = "Zb"
 *     char_to_c ':'  = "Zc"
 *     char_to_c '/'  = "Zd"
 *     char_to_c '='  = "Ze"
 *     char_to_c '>'  = "Zg"
 *     char_to_c '#'  = "Zh"
 *     char_to_c '<'  = "Zl"
 *     char_to_c '-'  = "Zm"
 *     char_to_c '!'  = "Zn"
 *     char_to_c '.'  = "Zo"
 *     char_to_c '+'  = "Zp"
 *     char_to_c '\'' = "Zq"
 *     char_to_c '*'  = "Zt"
 *     char_to_c '_'  = "Zu"
 *     char_to_c c    = "Z" ++ show (ord c)
 */
static char unZcode( char ch )
{
    switch (ch) {
    case 'a'  : return ('&');
    case 'b'  : return ('|');
    case 'c'  : return (':');
    case 'd'  : return ('/');
    case 'e'  : return ('=');
    case 'g'  : return ('>');
    case 'h'  : return ('#');
    case 'l'  : return ('<');
    case 'm'  : return ('-');
    case 'n'  : return ('!');
    case 'o'  : return ('.');
    case 'p'  : return ('+');
    case 'q'  : return ('\'');
    case 't'  : return ('*');
    case 'u'  : return ('_');
    case 'Z'  :
    case '\0' : return ('Z');
    default   : return (ch);
    }
}

#if 0
/* Precondition: out big enough to handle output (about twice length of in) */
static void enZcode( char *in, char *out )
{
    int i, j;

    j = 0;
    out[ j++ ] = '_';
    for( i = 0; in[i] != '\0'; ++i ) {
        switch (in[i]) {
        case 'Z'  : 
                out[j++] = 'Z';
                out[j++] = 'Z';
                break;
        case '&'  : 
                out[j++] = 'Z';
                out[j++] = 'a';
                break;
        case '|'  : 
                out[j++] = 'Z';
                out[j++] = 'b';
                break;
        case ':'  : 
                out[j++] = 'Z';
                out[j++] = 'c';
                break;
        case '/'  : 
                out[j++] = 'Z';
                out[j++] = 'd';
                break;
        case '='  : 
                out[j++] = 'Z';
                out[j++] = 'e';
                break;
        case '>'  : 
                out[j++] = 'Z';
                out[j++] = 'g';
                break;
        case '#'  : 
                out[j++] = 'Z';
                out[j++] = 'h';
                break;
        case '<'  : 
                out[j++] = 'Z';
                out[j++] = 'l';
                break;
        case '-'  : 
                out[j++] = 'Z';
                out[j++] = 'm';
                break;
        case '!'  : 
                out[j++] = 'Z';
                out[j++] = 'n';
                break;
        case '.'  : 
                out[j++] = 'Z';
                out[j++] = 'o';
                break;
        case '+'  : 
                out[j++] = 'Z';
                out[j++] = 'p';
                break;
        case '\'' : 
                out[j++] = 'Z';
                out[j++] = 'q';
                break;
        case '*'  : 
                out[j++] = 'Z';
                out[j++] = 't';
                break;
        case '_'  : 
                out[j++] = 'Z';
                out[j++] = 'u';
                break;
        default :
                out[j++] = in[i];
                break;
        }
    }
    out[j] = '\0';
}
#endif

932
const char *lookupGHCName( void *addr )
933 934
{
    nat i;
935
    for( i = 0; i < table_size && table[i].value != (StgWord) addr; ++i ) {
936 937
    }
    if (i < table_size) {
938
        return table[i].name;
939
    } else {
940
        return NULL;
941 942 943 944 945 946 947 948 949
    }
}

static void printZcoded( const char *raw )
{
    nat j = 0;
    
    while ( raw[j] != '\0' ) {
        if (raw[j] == 'Z') {
950
            debugBelch("%c", unZcode(raw[j+1]));
951 952
            j = j + 2;
        } else {
953
            debugBelch("%c", unZcode(raw[j+1]));
954 955 956 957 958 959 960 961 962
            j = j + 1;
        }
    }
}

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

sof's avatar
sof committed
963 964 965
/* Causing linking trouble on Win32 plats, so I'm
   disabling this for now. 
*/
ken's avatar
ken committed
966
#ifdef USING_LIBBFD
967 968 969 970 971 972 973

#include <bfd.h>

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

974
static rtsBool isReal( flagword flags STG_UNUSED, const char *name )
975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021
{
#if 0
    /* ToDo: make this work on BFD */
    int tp = type & N_TYPE;    
    if (tp == N_TEXT || tp == N_DATA) {
        return (name[0] == '_' && name[1] != '_');
    } else {
        return rtsFalse;
    }
#else
    if (*name == '\0'  || 
	(name[0] == 'g' && name[1] == 'c' && name[2] == 'c') ||
	(name[0] == 'c' && name[1] == 'c' && name[2] == '.')) {
	return rtsFalse;
    }
    return rtsTrue;
#endif
}

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

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

    {
	long storage_needed;
	asymbol **symbol_table;
	long number_of_symbols;
        long num_real_syms = 0;
	long i;
     
	storage_needed = bfd_get_symtab_upper_bound (abfd);
     
	if (storage_needed < 0) {
	    barf("can't read symbol table");
	}     
#if 0
	if (storage_needed == 0) {
1022
	    debugBelch("no storage needed");
1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035
	}
#endif
	symbol_table = (asymbol **) stgMallocBytes(storage_needed,"DEBUG_LoadSymbols");

	number_of_symbols = bfd_canonicalize_symtab (abfd, symbol_table);
     
	if (number_of_symbols < 0) {
	    barf("can't canonicalise symbol table");
	}

        for( i = 0; i != number_of_symbols; ++i ) {
            symbol_info info;
            bfd_get_symbol_info(abfd,symbol_table[i],&info);
1036
            /*debugBelch("\t%c\t0x%x      \t%s\n",info.type,(nat)info.value,info.name); */
1037 1038 1039 1040 1041
            if (isReal(info.type, info.name)) {
                num_real_syms += 1;
            }
        }
    
1042
        IF_DEBUG(interpreter,
1043
                 debugBelch("Loaded %ld symbols. Of which %ld are real symbols\n", 
1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055
                         number_of_symbols, num_real_syms)
                 );

        reset_table( num_real_syms );
    
        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 );
            }
        }
1056

sof's avatar
sof committed
1057
        stgFree(symbol_table);
1058 1059 1060 1061 1062 1063
    }
    prepare_table();
}

#else /* HAVE_BFD_H */

1064
extern void DEBUG_LoadSymbols( char *name STG_UNUSED )
1065
{
rrt's avatar
rrt committed
1066
  /* nothing, yet */
1067 1068 1069 1070
}

#endif /* HAVE_BFD_H */

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

1073
void
1074
findPtr(P_ p, int follow)
1075 1076
{
  nat s, g;
1077
  P_ q, r;
1078
  bdescr *bd;
sof's avatar
sof committed
1079
#if defined(__GNUC__)
1080
  const int arr_size = 1024;
sof's avatar
sof committed
1081 1082 1083
#else
#define arr_size 1024
#endif
1084 1085
  StgPtr arr[arr_size];
  int i = 0;
1086 1087

  for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1088
      for (s = 0; s < generations[g].n_steps; s++) {
1089
	  bd = generations[g].steps[s].blocks;
1090 1091 1092 1093 1094
	  for (; bd; bd = bd->link) {
	      for (q = bd->start; q < bd->free; q++) {
		  if (*q == (W_)p) {
		      if (i < arr_size) {
			  r = q;
1095
			  while (!LOOKS_LIKE_INFO_PTR(*r) || (P_)*r == NULL) {
1096 1097
			      r--;
			  }
1098
			  debugBelch("%p = ", r);
1099 1100 1101 1102 1103 1104 1105
			  printClosure((StgClosure *)r);
			  arr[i++] = r;
		      } else {
			  return;
		      }
		  }
	      }
1106 1107
	  }
      }
1108 1109
  }
  if (follow && i == 1) {
1110
      debugBelch("-->\n");
1111
      findPtr(arr[0], 1);
1112 1113 1114
  }
}

1115 1116 1117
#else /* DEBUG */
void printPtr( StgPtr p )
{
1118
    debugBelch("ptr 0x%p (enable -DDEBUG for more info) " , p );
1119 1120 1121 1122
}
  
void printObj( StgClosure *obj )
{
1123
    debugBelch("obj 0x%p (enable -DDEBUG for more info) " , obj );
1124
}
1125
#endif /* DEBUG */