ghc/rts/Printer.c

   1 /* -----------------------------------------------------------------------------
   2  *
   3  * (c) The GHC Team, 1994-2000.
   4  *
   5  * Heap printer
   6  *
   7  * ---------------------------------------------------------------------------*/
   8
   9 #include "PosixSource.h"
  10 #include "Rts.h"
  11 #include "Printer.h"
  12 #include "RtsUtils.h"
  13
  14 #ifdef DEBUG
  15
  16 #include "RtsFlags.h"
  17 #include "MBlock.h"
  18 #include "Storage.h"
  19 #include "Bytecodes.h"  /* for InstrPtr */
  20 #include "Disassembler.h"
  21 #include "Apply.h"
  22
  23 #include <stdlib.h>
  24 #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  * local function decls
  34  * ------------------------------------------------------------------------*/
  35
  36 static void    printStdObject( StgClosure *obj, char* tag );
  37 static void    printStdObjPayload( StgClosure *obj );
  38 #ifdef USING_LIBBFD
  39 static void    reset_table   ( int size );
  40 static void    prepare_table ( void );
  41 static void    insert        ( unsigned value, const char *name );
  42 #endif
  43 #if 0 /* unused but might be useful sometime */
  44 static rtsBool lookup_name   ( char *name, unsigned *result );
  45 static void    enZcode       ( char *in, char *out );
  46 #endif
  47 static char    unZcode       ( char ch );
  48 const char *   lookupGHCName ( void *addr );
  49 static void    printZcoded   ( const char *raw );
  50
  51 /* --------------------------------------------------------------------------
  52  * Printer
  53  * ------------------------------------------------------------------------*/
  54
  55 void printPtr( StgPtr p )
  56 {
  57     const char *raw;
  58     raw = lookupGHCName(p);
  59     if (raw != NULL) {
  60         printZcoded(raw);
  61     } else {
  62         debugBelch("%p", p);
  63     }
  64 }
  65
  66 void printObj( StgClosure *obj )
  67 {
  68     debugBelch("Object "); printPtr((StgPtr)obj); debugBelch(" = ");
  69     printClosure(obj);
  70 }
  71
  72 STATIC_INLINE void
  73 printStdObjHdr( StgClosure *obj, char* tag )
  74 {
  75     debugBelch("%s(",tag);
  76     printPtr((StgPtr)obj->header.info);
  77 #ifdef PROFILING
  78     debugBelch(", %s", obj->header.prof.ccs->cc->label);
  79 #endif
  80 }
  81
  82 static void
  83 printStdObjPayload( StgClosure *obj )
  84 {
  85     StgWord i, j;
  86     const StgInfoTable* info;
  87
  88     info = get_itbl(obj);
  89     for (i = 0; i < info->layout.payload.ptrs; ++i) {
  90         debugBelch(", ");
  91         printPtr((StgPtr)obj->payload[i]);
  92     }
  93     for (j = 0; j < info->layout.payload.nptrs; ++j) {
  94         debugBelch(", %pd#",obj->payload[i+j]);
  95     }
  96     debugBelch(")\n");
  97 }
  98
  99 static void
 100 printThunkPayload( StgThunk *obj )
 101 {
 102     StgWord i, j;
 103     const StgInfoTable* info;
 104
 105     info = get_itbl(obj);
 106     for (i = 0; i < info->layout.payload.ptrs; ++i) {
 107         debugBelch(", ");
 108         printPtr((StgPtr)obj->payload[i]);
 109     }
 110     for (j = 0; j < info->layout.payload.nptrs; ++j) {
 111         debugBelch(", %pd#",obj->payload[i+j]);
 112     }
 113     debugBelch(")\n");
 114 }
 115
 116 static void
 117 printStdObject( StgClosure *obj, char* tag )
 118 {
 119     printStdObjHdr( obj, tag );
 120     printStdObjPayload( obj );
 121 }
 122
 123 static void
 124 printThunkObject( StgThunk *obj, char* tag )
 125 {
 126     printStdObjHdr( (StgClosure *)obj, tag );
 127     printThunkPayload( obj );
 128 }
 129
 130 void
 131 printClosure( StgClosure *obj )
 132 {
 133     StgInfoTable *info;
 134
 135     info = get_itbl(obj);
 136
 137     switch ( info->type ) {
 138     case INVALID_OBJECT:
 139             barf("Invalid object");
 140
 141     case CONSTR:
 142     case CONSTR_1_0: case CONSTR_0_1:
 143     case CONSTR_1_1: case CONSTR_0_2: case CONSTR_2_0:
 144     case CONSTR_INTLIKE:
 145     case CONSTR_CHARLIKE:
 146     case CONSTR_STATIC:
 147     case CONSTR_NOCAF_STATIC:
 148         {
 149             /* We can't use printStdObject because we want to print the
 150              * tag as well.
 151              */
 152             StgWord i, j;
 153 #ifdef PROFILING
 154             debugBelch("%s(", info->prof.closure_desc);
 155             debugBelch("%s", obj->header.prof.ccs->cc->label);
 156 #else
 157             debugBelch("CONSTR(");
 158             printPtr((StgPtr)obj->header.info);
 159             debugBelch("(tag=%d)",info->srt_bitmap);
 160 #endif
 161             for (i = 0; i < info->layout.payload.ptrs; ++i) {
 162                 debugBelch(", ");
 163                 printPtr((StgPtr)obj->payload[i]);
 164             }
 165             for (j = 0; j < info->layout.payload.nptrs; ++j) {
 166                 debugBelch(", %p#", obj->payload[i+j]);
 167             }
 168             debugBelch(")\n");
 169             break;
 170         }
 171
 172     case FUN:
 173     case FUN_1_0: case FUN_0_1:
 174     case FUN_1_1: case FUN_0_2: case FUN_2_0:
 175     case FUN_STATIC:
 176         debugBelch("FUN/%d(",itbl_to_fun_itbl(info)->f.arity);
 177         printPtr((StgPtr)obj->header.info);
 178 #ifdef PROFILING
 179         debugBelch(", %s", obj->header.prof.ccs->cc->label);
 180 #endif
 181         printStdObjPayload(obj);
 182         break;
 183
 184     case THUNK:
 185     case THUNK_1_0: case THUNK_0_1:
 186     case THUNK_1_1: case THUNK_0_2: case THUNK_2_0:
 187     case THUNK_STATIC:
 188             /* ToDo: will this work for THUNK_STATIC too? */
 189 #ifdef PROFILING
 190             printThunkObject((StgThunk *)obj,info->prof.closure_desc);
 191 #else
 192             printThunkObject((StgThunk *)obj,"THUNK");
 193 #endif
 194             break;
 195
 196     case THUNK_SELECTOR:
 197         printStdObjHdr(obj, "THUNK_SELECTOR");
 198         debugBelch(", %p)\n", ((StgSelector *)obj)->selectee);
 199         break;
 200
 201     case BCO:
 202             disassemble( (StgBCO*)obj );
 203             break;
 204
 205     case AP:
 206         {
 207             StgAP* ap = stgCast(StgAP*,obj);
 208             StgWord i;
 209             debugBelch("AP("); printPtr((StgPtr)ap->fun);
 210             for (i = 0; i < ap->n_args; ++i) {
 211                 debugBelch(", ");
 212                 printPtr((P_)ap->payload[i]);
 213             }
 214             debugBelch(")\n");
 215             break;
 216         }
 217
 218     case PAP:
 219         {
 220             StgPAP* pap = stgCast(StgPAP*,obj);
 221             StgWord i;
 222             debugBelch("PAP/%d(",pap->arity);
 223             printPtr((StgPtr)pap->fun);
 224             for (i = 0; i < pap->n_args; ++i) {
 225                 debugBelch(", ");
 226                 printPtr((StgPtr)pap->payload[i]);
 227             }
 228             debugBelch(")\n");
 229             break;
 230         }
 231
 232     case AP_STACK:
 233         {
 234             StgAP_STACK* ap = stgCast(StgAP_STACK*,obj);
 235             StgWord i;
 236             debugBelch("AP_STACK("); printPtr((StgPtr)ap->fun);
 237             for (i = 0; i < ap->size; ++i) {
 238                 debugBelch(", ");
 239                 printPtr((P_)ap->payload[i]);
 240             }
 241             debugBelch(")\n");
 242             break;
 243         }
 244
 245     case IND:
 246             debugBelch("IND(");
 247             printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
 248             debugBelch(")\n");
 249             break;
 250
 251     case IND_OLDGEN:
 252             debugBelch("IND_OLDGEN(");
 253             printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
 254             debugBelch(")\n");
 255             break;
 256
 257     case IND_PERM:
 258             debugBelch("IND(");
 259             printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
 260             debugBelch(")\n");
 261             break;
 262
 263     case IND_OLDGEN_PERM:
 264             debugBelch("IND_OLDGEN_PERM(");
 265             printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
 266             debugBelch(")\n");
 267             break;
 268
 269     case IND_STATIC:
 270             debugBelch("IND_STATIC(");
 271             printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
 272             debugBelch(")\n");
 273             break;
 274
 275     /* Cannot happen -- use default case.
 276     case RET_BCO:
 277     case RET_SMALL:
 278     case RET_VEC_SMALL:
 279     case RET_BIG:
 280     case RET_VEC_BIG:
 281     case RET_DYN:
 282     case RET_FUN:
 283     */
 284
 285     case UPDATE_FRAME:
 286         {
 287             StgUpdateFrame* u = stgCast(StgUpdateFrame*,obj);
 288             debugBelch("UPDATE_FRAME(");
 289             printPtr((StgPtr)GET_INFO(u));
 290             debugBelch(",");
 291             printPtr((StgPtr)u->updatee);
 292             debugBelch(")\n");
 293             break;
 294         }
 295
 296     case CATCH_FRAME:
 297         {
 298             StgCatchFrame* u = stgCast(StgCatchFrame*,obj);
 299             debugBelch("CATCH_FRAME(");
 300             printPtr((StgPtr)GET_INFO(u));
 301             debugBelch(",");
 302             printPtr((StgPtr)u->handler);
 303             debugBelch(")\n");
 304             break;
 305         }
 306
 307     case STOP_FRAME:
 308         {
 309             StgStopFrame* u = stgCast(StgStopFrame*,obj);
 310             debugBelch("STOP_FRAME(");
 311             printPtr((StgPtr)GET_INFO(u));
 312             debugBelch(")\n");
 313             break;
 314         }
 315
 316     case CAF_BLACKHOLE:
 317             debugBelch("CAF_BH");
 318             break;
 319
 320     case BLACKHOLE:
 321             debugBelch("BH\n");
 322             break;
 323
 324     case SE_BLACKHOLE:
 325             debugBelch("SE_BH\n");
 326             break;
 327
 328     case SE_CAF_BLACKHOLE:
 329             debugBelch("SE_CAF_BH\n");
 330             break;
 331
 332     case ARR_WORDS:
 333         {
 334             StgWord i;
 335             debugBelch("ARR_WORDS(\"");
 336             /* ToDo: we can't safely assume that this is a string!
 337             for (i = 0; arrWordsGetChar(obj,i); ++i) {
 338                 putchar(arrWordsGetChar(obj,i));
 339                 } */
 340             for (i=0; i<((StgArrWords *)obj)->words; i++)
 341               debugBelch("%lu", ((StgArrWords *)obj)->payload[i]);
 342             debugBelch("\")\n");
 343             break;
 344         }
 345
 346     case MUT_ARR_PTRS:
 347         debugBelch("MUT_ARR_PTRS(size=%ld)\n", ((StgMutArrPtrs *)obj)->ptrs);
 348         break;
 349
 350     case MUT_ARR_PTRS_FROZEN:
 351 #if !defined(XMLAMBDA)
 352         debugBelch("MUT_ARR_PTRS_FROZEN(size=%ld)\n", ((StgMutArrPtrs *)obj)->ptrs);
 353         break;
 354 #else
 355           {
 356             /* rows are mutarrays in xmlambda, maybe we should make a new type: ROW */
 357             StgWord i;
 358             StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,obj);
 359
 360             debugBelch("Row<%i>(",p->ptrs);
 361             for (i = 0; i < p->ptrs; ++i) {
 362                 if (i > 0) debugBelch(", ");
 363                 printPtr((StgPtr)(p->payload[i]));
 364             }
 365             debugBelch(")\n");
 366             break;
 367           }
 368 #endif
 369
 370     case MVAR:
 371         {
 372           StgMVar* mv = (StgMVar*)obj;
 373           debugBelch("MVAR(head=%p, tail=%p, value=%p)\n", mv->head, mv->tail, mv->value);
 374           break;
 375         }
 376
 377     case MUT_VAR:
 378         {
 379           StgMutVar* mv = (StgMutVar*)obj;
 380           debugBelch("MUT_VAR(var=%p)\n", mv->var);
 381           break;
 382         }
 383
 384     case WEAK:
 385             debugBelch("WEAK(");
 386             debugBelch(" key=%p value=%p finalizer=%p",
 387                     (StgPtr)(((StgWeak*)obj)->key),
 388                     (StgPtr)(((StgWeak*)obj)->value),
 389                     (StgPtr)(((StgWeak*)obj)->finalizer));
 390             debugBelch(")\n");
 391             /* ToDo: chase 'link' ? */
 392             break;
 393
 394     case FOREIGN:
 395             debugBelch("FOREIGN(");
 396             printPtr((StgPtr)( ((StgForeignObj*)obj)->data ));
 397             debugBelch(")\n");
 398             break;
 399
 400     case STABLE_NAME:
 401             debugBelch("STABLE_NAME(%ld)\n", ((StgStableName*)obj)->sn);
 402             break;
 403
 404     case TSO:
 405       debugBelch("TSO(");
 406       debugBelch("%d (%p)",((StgTSO*)obj)->id, (StgTSO*)obj);
 407       debugBelch(")\n");
 408       break;
 409
 410 #if defined(PAR)
 411     case BLOCKED_FETCH:
 412       debugBelch("BLOCKED_FETCH(");
 413       printGA(&(stgCast(StgBlockedFetch*,obj)->ga));
 414       printPtr((StgPtr)(stgCast(StgBlockedFetch*,obj)->node));
 415       debugBelch(")\n");
 416       break;
 417
 418     case FETCH_ME:
 419       debugBelch("FETCH_ME(");
 420       printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
 421       debugBelch(")\n");
 422       break;
 423
 424     case FETCH_ME_BQ:
 425       debugBelch("FETCH_ME_BQ(");
 426       // printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
 427       printPtr((StgPtr)stgCast(StgFetchMeBlockingQueue*,obj)->blocking_queue);
 428       debugBelch(")\n");
 429       break;
 430 #endif
 431
 432 #if defined(GRAN) || defined(PAR)
 433     case RBH:
 434       debugBelch("RBH(");
 435       printPtr((StgPtr)stgCast(StgRBH*,obj)->blocking_queue);
 436       debugBelch(")\n");
 437       break;
 438
 439 #endif
 440
 441 #if 0
 442       /* Symptomatic of a problem elsewhere, have it fall-through & fail */
 443     case EVACUATED:
 444       debugBelch("EVACUATED(");
 445       printClosure((StgEvacuated*)obj->evacuee);
 446       debugBelch(")\n");
 447       break;
 448 #endif
 449
 450 #if defined(PAR) && defined(DIST)
 451     case REMOTE_REF:
 452       debugBelch("REMOTE_REF(");
 453       printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
 454       debugBelch(")\n");
 455       break;
 456 #endif
 457
 458     default:
 459             //barf("printClosure %d",get_itbl(obj)->type);
 460             debugBelch("*** printClosure: unknown type %d ****\n",
 461                     get_itbl(obj)->type );
 462             barf("printClosure %d",get_itbl(obj)->type);
 463             return;
 464     }
 465 }
 466
 467 /*
 468 void printGraph( StgClosure *obj )
 469 {
 470  printClosure(obj);
 471 }
 472 */
 473
 474 StgPtr
 475 printStackObj( StgPtr sp )
 476 {
 477     /*debugBelch("Stack[%d] = ", &stgStack[STACK_SIZE] - sp); */
 478
 479         StgClosure* c = (StgClosure*)(*sp);
 480         printPtr((StgPtr)*sp);
 481         if (c == (StgClosure*)&stg_ctoi_R1p_info) {
 482            debugBelch("\t\t\tstg_ctoi_ret_R1p_info\n" );
 483         } else
 484         if (c == (StgClosure*)&stg_ctoi_R1n_info) {
 485            debugBelch("\t\t\tstg_ctoi_ret_R1n_info\n" );
 486         } else
 487         if (c == (StgClosure*)&stg_ctoi_F1_info) {
 488            debugBelch("\t\t\tstg_ctoi_ret_F1_info\n" );
 489         } else
 490         if (c == (StgClosure*)&stg_ctoi_D1_info) {
 491            debugBelch("\t\t\tstg_ctoi_ret_D1_info\n" );
 492         } else
 493         if (c == (StgClosure*)&stg_ctoi_V_info) {
 494            debugBelch("\t\t\tstg_ctoi_ret_V_info\n" );
 495         } else
 496         if (get_itbl(c)->type == BCO) {
 497            debugBelch("\t\t\t");
 498            debugBelch("BCO(...)\n");
 499         }
 500         else {
 501            debugBelch("\t\t\t");
 502            printClosure ( (StgClosure*)(*sp));
 503         }
 504         sp += 1;
 505
 506     return sp;
 507
 508 }
 509
 510 static void
 511 printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap, nat size )
 512 {
 513     StgPtr p;
 514     nat i;
 515
 516     p = payload;
 517     for(i = 0; i < size; i++, bitmap >>= 1 ) {
 518         debugBelch("   stk[%ld] (%p) = ", spBottom-(payload+i), payload+i);
 519         if ((bitmap & 1) == 0) {
 520             printPtr((P_)payload[i]);
 521             debugBelch("\n");
 522         } else {
 523             debugBelch("Word# %ld\n", payload[i]);
 524         }
 525     }
 526 }
 527
 528 static void
 529 printLargeBitmap( StgPtr spBottom, StgPtr payload, StgLargeBitmap* large_bitmap, nat size )
 530 {
 531     StgWord bmp;
 532     nat i, j;
 533
 534     i = 0;
 535     for (bmp=0; i < size; bmp++) {
 536         StgWord bitmap = large_bitmap->bitmap[bmp];
 537         j = 0;
 538         for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) {
 539             debugBelch("   stk[%ld] (%p) = ", spBottom-(payload+i), payload+i);
 540             if ((bitmap & 1) == 0) {
 541                 printPtr((P_)payload[i]);
 542                 debugBelch("\n");
 543             } else {
 544                 debugBelch("Word# %ld\n", payload[i]);
 545             }
 546         }
 547     }
 548 }
 549
 550 void
 551 printStackChunk( StgPtr sp, StgPtr spBottom )
 552 {
 553     StgWord bitmap;
 554     const StgInfoTable *info;
 555
 556     ASSERT(sp <= spBottom);
 557     for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) {
 558
 559         info = get_itbl((StgClosure *)sp);
 560
 561         switch (info->type) {
 562
 563         case UPDATE_FRAME:
 564         case CATCH_FRAME:
 565         case STOP_FRAME:
 566             printObj((StgClosure*)sp);
 567             continue;
 568
 569         case RET_DYN:
 570         {
 571             StgRetDyn* r;
 572             StgPtr p;
 573             StgWord dyn;
 574             nat size;
 575
 576             r = (StgRetDyn *)sp;
 577             dyn = r->liveness;
 578             debugBelch("RET_DYN (%p)\n", r);
 579
 580             p = (P_)(r->payload);
 581             printSmallBitmap(spBottom, sp,
 582                              RET_DYN_LIVENESS(r->liveness),
 583                              RET_DYN_BITMAP_SIZE);
 584             p += RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE;
 585
 586             for (size = RET_DYN_NONPTRS(dyn); size > 0; size--) {
 587                 debugBelch("   stk[%ld] (%p) = ", (long)(spBottom-p), p);
 588                 debugBelch("Word# %ld\n", (long)*p);
 589                 p++;
 590             }
 591
 592             for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
 593                 debugBelch("   stk[%ld] (%p) = ", (long)(spBottom-p), p);
 594                 printPtr(p);
 595                 p++;
 596             }
 597             continue;
 598         }
 599
 600         case RET_SMALL:
 601         case RET_VEC_SMALL:
 602             debugBelch("RET_SMALL (%p)\n", sp);
 603             bitmap = info->layout.bitmap;
 604             printSmallBitmap(spBottom, sp+1,
 605                              BITMAP_BITS(bitmap), BITMAP_SIZE(bitmap));
 606             continue;
 607
 608         case RET_BCO: {
 609             StgBCO *bco;
 610
 611             bco = ((StgBCO *)sp[1]);
 612
 613             debugBelch("RET_BCO (%p)\n", sp);
 614             printLargeBitmap(spBottom, sp+2,
 615                              BCO_BITMAP(bco), BCO_BITMAP_SIZE(bco));
 616             continue;
 617         }
 618
 619         case RET_BIG:
 620         case RET_VEC_BIG:
 621             barf("todo");
 622
 623         case RET_FUN:
 624         {
 625             StgFunInfoTable *fun_info;
 626             StgRetFun *ret_fun;
 627             nat size;
 628
 629             ret_fun = (StgRetFun *)sp;
 630             fun_info = get_fun_itbl(ret_fun->fun);
 631             size = ret_fun->size;
 632             debugBelch("RET_FUN (%p) (type=%d)\n", ret_fun, fun_info->f.fun_type);
 633             switch (fun_info->f.fun_type) {
 634             case ARG_GEN:
 635                 printSmallBitmap(spBottom, sp+1,
 636                                  BITMAP_BITS(fun_info->f.b.bitmap),
 637                                  BITMAP_SIZE(fun_info->f.b.bitmap));
 638                 break;
 639             case ARG_GEN_BIG:
 640                 printLargeBitmap(spBottom, sp+2,
 641                                  GET_FUN_LARGE_BITMAP(fun_info),
 642                                  GET_FUN_LARGE_BITMAP(fun_info)->size);
 643                 break;
 644             default:
 645                 printSmallBitmap(spBottom, sp+1,
 646                                  BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
 647                                  BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]));
 648                 break;
 649             }
 650             continue;
 651         }
 652
 653         default:
 654             debugBelch("unknown object %d\n", info->type);
 655             barf("printStackChunk");
 656         }
 657     }
 658 }
 659
 660 void printTSO( StgTSO *tso )
 661 {
 662     printStackChunk( tso->sp, tso->stack+tso->stack_size);
 663 }
 664
 665 /* -----------------------------------------------------------------------------
 666    Closure types
 667
 668    NOTE: must be kept in sync with the closure types in includes/ClosureTypes.h
 669    -------------------------------------------------------------------------- */
 670
 671 static char *closure_type_names[] = {
 672     "INVALID_OBJECT",
 673     "CONSTR",
 674     "CONSTR_1",
 675     "CONSTR_0",
 676     "CONSTR_2",
 677     "CONSTR_1",
 678     "CONSTR_0",
 679     "CONSTR_INTLIKE",
 680     "CONSTR_CHARLIKE",
 681     "CONSTR_STATIC",
 682     "CONSTR_NOCAF_STATIC",
 683     "FUN",
 684     "FUN_1_0",
 685     "FUN_0_1",
 686     "FUN_2_0",
 687     "FUN_1_1",
 688     "FUN_0",
 689     "FUN_STATIC",
 690     "THUNK",
 691     "THUNK_1_0",
 692     "THUNK_0_1",
 693     "THUNK_2_0",
 694     "THUNK_1_1",
 695     "THUNK_0",
 696     "THUNK_STATIC",
 697     "THUNK_SELECTOR",
 698     "BCO",
 699     "AP_UPD",
 700     "PAP",
 701     "AP_STACK",
 702     "IND",
 703     "IND_OLDGEN",
 704     "IND_PERM",
 705     "IND_OLDGEN_PERM",
 706     "IND_STATIC",
 707     "RET_BCO",
 708     "RET_SMALL",
 709     "RET_VEC_SMALL",
 710     "RET_BIG",
 711     "RET_VEC_BIG",
 712     "RET_DYN",
 713     "RET_FUN",
 714     "UPDATE_FRAME",
 715     "CATCH_FRAME",
 716     "STOP_FRAME",
 717     "CAF_BLACKHOLE",
 718     "BLACKHOLE",
 719     "BLACKHOLE_BQ",
 720     "SE_BLACKHOLE",
 721     "SE_CAF_BLACKHOLE",
 722     "MVAR",
 723     "ARR_WORDS",
 724     "MUT_ARR_PTRS",
 725     "MUT_ARR_PTRS_FROZEN",
 726     "MUT_VAR",
 727     "MUT_CONS",
 728     "WEAK",
 729     "FOREIGN",
 730     "STABLE_NAME",
 731     "TSO",
 732     "BLOCKED_FETCH",
 733     "FETCH_ME",
 734     "FETCH_ME_BQ",
 735     "RBH",
 736     "EVACUATED",
 737     "REMOTE_REF",
 738     "TVAR_WAIT_QUEUE",
 739     "TVAR",
 740     "TREC_CHUNK",
 741     "TREC_HEADER",
 742     "ATOMICALLY_FRAME",
 743     "CATCH_RETRY_FRAME"
 744 };
 745
 746
 747 char *
 748 info_type(StgClosure *closure){
 749   return closure_type_names[get_itbl(closure)->type];
 750 }
 751
 752 char *
 753 info_type_by_ip(StgInfoTable *ip){
 754   return closure_type_names[ip->type];
 755 }
 756
 757 void
 758 info_hdr_type(StgClosure *closure, char *res){
 759   strcpy(res,closure_type_names[get_itbl(closure)->type]);
 760 }
 761
 762 /* --------------------------------------------------------------------------
 763  * Address printing code
 764  *
 765  * Uses symbol table in (unstripped executable)
 766  * ------------------------------------------------------------------------*/
 767
 768 /* --------------------------------------------------------------------------
 769  * Simple lookup table
 770  *
 771  * Current implementation is pretty dumb!
 772  * ------------------------------------------------------------------------*/
 773
 774 struct entry {
 775     nat value;
 776     const char *name;
 777 };
 778
 779 static nat table_size;
 780 static struct entry* table;
 781
 782 #ifdef USING_LIBBFD
 783 static nat max_table_size;
 784
 785 static void reset_table( int size )
 786 {
 787     max_table_size = size;
 788     table_size = 0;
 789     table = (struct entry *)stgMallocBytes(size * sizeof(struct entry), "Printer.c:reset_table()");
 790 }
 791
 792 static void prepare_table( void )
 793 {
 794     /* Could sort it...  */
 795 }
 796
 797 static void insert( unsigned value, const char *name )
 798 {
 799     if ( table_size >= max_table_size ) {
 800         barf( "Symbol table overflow\n" );
 801     }
 802     table[table_size].value = value;
 803     table[table_size].name = name;
 804     table_size = table_size + 1;
 805 }
 806 #endif
 807
 808 #if 0
 809 static rtsBool lookup_name( char *name, unsigned *result )
 810 {
 811     int i;
 812     for( i = 0; i < table_size && strcmp(name,table[i].name) != 0; ++i ) {
 813     }
 814     if (i < table_size) {
 815         *result = table[i].value;
 816         return rtsTrue;
 817     } else {
 818         return rtsFalse;
 819     }
 820 }
 821 #endif
 822
 823 /* Code from somewhere inside GHC (circa 1994)
 824  * * Z-escapes:
 825  *     "std"++xs -> "Zstd"++xs
 826  *     char_to_c 'Z'  = "ZZ"
 827  *     char_to_c '&'  = "Za"
 828  *     char_to_c '|'  = "Zb"
 829  *     char_to_c ':'  = "Zc"
 830  *     char_to_c '/'  = "Zd"
 831  *     char_to_c '='  = "Ze"
 832  *     char_to_c '>'  = "Zg"
 833  *     char_to_c '#'  = "Zh"
 834  *     char_to_c '<'  = "Zl"
 835  *     char_to_c '-'  = "Zm"
 836  *     char_to_c '!'  = "Zn"
 837  *     char_to_c '.'  = "Zo"
 838  *     char_to_c '+'  = "Zp"
 839  *     char_to_c '\'' = "Zq"
 840  *     char_to_c '*'  = "Zt"
 841  *     char_to_c '_'  = "Zu"
 842  *     char_to_c c    = "Z" ++ show (ord c)
 843  */
 844 static char unZcode( char ch )
 845 {
 846     switch (ch) {
 847     case 'a'  : return ('&');
 848     case 'b'  : return ('|');
 849     case 'c'  : return (':');
 850     case 'd'  : return ('/');
 851     case 'e'  : return ('=');
 852     case 'g'  : return ('>');
 853     case 'h'  : return ('#');
 854     case 'l'  : return ('<');
 855     case 'm'  : return ('-');
 856     case 'n'  : return ('!');
 857     case 'o'  : return ('.');
 858     case 'p'  : return ('+');
 859     case 'q'  : return ('\'');
 860     case 't'  : return ('*');
 861     case 'u'  : return ('_');
 862     case 'Z'  :
 863     case '\0' : return ('Z');
 864     default   : return (ch);
 865     }
 866 }
 867
 868 #if 0
 869 /* Precondition: out big enough to handle output (about twice length of in) */
 870 static void enZcode( char *in, char *out )
 871 {
 872     int i, j;
 873
 874     j = 0;
 875     out[ j++ ] = '_';
 876     for( i = 0; in[i] != '\0'; ++i ) {
 877         switch (in[i]) {
 878         case 'Z'  :
 879                 out[j++] = 'Z';
 880                 out[j++] = 'Z';
 881                 break;
 882         case '&'  :
 883                 out[j++] = 'Z';
 884                 out[j++] = 'a';
 885                 break;
 886         case '|'  :
 887                 out[j++] = 'Z';
 888                 out[j++] = 'b';
 889                 break;
 890         case ':'  :
 891                 out[j++] = 'Z';
 892                 out[j++] = 'c';
 893                 break;
 894         case '/'  :
 895                 out[j++] = 'Z';
 896                 out[j++] = 'd';
 897                 break;
 898         case '='  :
 899                 out[j++] = 'Z';
 900                 out[j++] = 'e';
 901                 break;
 902         case '>'  :
 903                 out[j++] = 'Z';
 904                 out[j++] = 'g';
 905                 break;
 906         case '#'  :
 907                 out[j++] = 'Z';
 908                 out[j++] = 'h';
 909                 break;
 910         case '<'  :
 911                 out[j++] = 'Z';
 912                 out[j++] = 'l';
 913                 break;
 914         case '-'  :
 915                 out[j++] = 'Z';
 916                 out[j++] = 'm';
 917                 break;
 918         case '!'  :
 919                 out[j++] = 'Z';
 920                 out[j++] = 'n';
 921                 break;
 922         case '.'  :
 923                 out[j++] = 'Z';
 924                 out[j++] = 'o';
 925                 break;
 926         case '+'  :
 927                 out[j++] = 'Z';
 928                 out[j++] = 'p';
 929                 break;
 930         case '\'' :
 931                 out[j++] = 'Z';
 932                 out[j++] = 'q';
 933                 break;
 934         case '*'  :
 935                 out[j++] = 'Z';
 936                 out[j++] = 't';
 937                 break;
 938         case '_'  :
 939                 out[j++] = 'Z';
 940                 out[j++] = 'u';
 941                 break;
 942         default :
 943                 out[j++] = in[i];
 944                 break;
 945         }
 946     }
 947     out[j] = '\0';
 948 }
 949 #endif
 950
 951 const char *lookupGHCName( void *addr )
 952 {
 953     nat i;
 954     for( i = 0; i < table_size && table[i].value != (unsigned) addr; ++i ) {
 955     }
 956     if (i < table_size) {
 957         return table[i].name;
 958     } else {
 959         return NULL;
 960     }
 961 }
 962
 963 static void printZcoded( const char *raw )
 964 {
 965     nat j = 0;
 966
 967     while ( raw[j] != '\0' ) {
 968         if (raw[j] == 'Z') {
 969             debugBelch("%c", unZcode(raw[j+1]));
 970             j = j + 2;
 971         } else {
 972             debugBelch("%c", unZcode(raw[j+1]));
 973             j = j + 1;
 974         }
 975     }
 976 }
 977
 978 /* --------------------------------------------------------------------------
 979  * Symbol table loading
 980  * ------------------------------------------------------------------------*/
 981
 982 /* Causing linking trouble on Win32 plats, so I'm
 983    disabling this for now.
 984 */
 985 #ifdef USING_LIBBFD
 986
 987 #include <bfd.h>
 988
 989 /* Fairly ad-hoc piece of code that seems to filter out a lot of
 990  * rubbish like the obj-splitting symbols
 991  */
 992
 993 static rtsBool isReal( flagword flags STG_UNUSED, const char *name )
 994 {
 995 #if 0
 996     /* ToDo: make this work on BFD */
 997     int tp = type & N_TYPE;
 998     if (tp == N_TEXT || tp == N_DATA) {
 999         return (name[0] == '_' && name[1] != '_');
1000     } else {
1001         return rtsFalse;
1002     }
1003 #else
1004     if (*name == '\0'  ||
1005         (name[0] == 'g' && name[1] == 'c' && name[2] == 'c') ||
1006         (name[0] == 'c' && name[1] == 'c' && name[2] == '.')) {
1007         return rtsFalse;
1008     }
1009     return rtsTrue;
1010 #endif
1011 }
1012
1013 extern void DEBUG_LoadSymbols( char *name )
1014 {
1015     bfd* abfd;
1016     char **matching;
1017
1018     bfd_init();
1019     abfd = bfd_openr(name, "default");
1020     if (abfd == NULL) {
1021         barf("can't open executable %s to get symbol table", name);
1022     }
1023     if (!bfd_check_format_matches (abfd, bfd_object, &matching)) {
1024         barf("mismatch");
1025     }
1026
1027     {
1028         long storage_needed;
1029         asymbol **symbol_table;
1030         long number_of_symbols;
1031         long num_real_syms = 0;
1032         long i;
1033
1034         storage_needed = bfd_get_symtab_upper_bound (abfd);
1035
1036         if (storage_needed < 0) {
1037             barf("can't read symbol table");
1038         }
1039 #if 0
1040         if (storage_needed == 0) {
1041             debugBelch("no storage needed");
1042         }
1043 #endif
1044         symbol_table = (asymbol **) stgMallocBytes(storage_needed,"DEBUG_LoadSymbols");
1045
1046         number_of_symbols = bfd_canonicalize_symtab (abfd, symbol_table);
1047
1048         if (number_of_symbols < 0) {
1049             barf("can't canonicalise symbol table");
1050         }
1051
1052         for( i = 0; i != number_of_symbols; ++i ) {
1053             symbol_info info;
1054             bfd_get_symbol_info(abfd,symbol_table[i],&info);
1055             /*debugBelch("\t%c\t0x%x      \t%s\n",info.type,(nat)info.value,info.name); */
1056             if (isReal(info.type, info.name)) {
1057                 num_real_syms += 1;
1058             }
1059         }
1060
1061         IF_DEBUG(interpreter,
1062                  debugBelch("Loaded %ld symbols. Of which %ld are real symbols\n",
1063                          number_of_symbols, num_real_syms)
1064                  );
1065
1066         reset_table( num_real_syms );
1067
1068         for( i = 0; i != number_of_symbols; ++i ) {
1069             symbol_info info;
1070             bfd_get_symbol_info(abfd,symbol_table[i],&info);
1071             if (isReal(info.type, info.name)) {
1072                 insert( info.value, info.name );
1073             }
1074         }
1075
1076         stgFree(symbol_table);
1077     }
1078     prepare_table();
1079 }
1080
1081 #else /* HAVE_BFD_H */
1082
1083 extern void DEBUG_LoadSymbols( char *name STG_UNUSED )
1084 {
1085   /* nothing, yet */
1086 }
1087
1088 #endif /* HAVE_BFD_H */
1089
1090 void findPtr(P_ p, int);                /* keep gcc -Wall happy */
1091
1092 void
1093 findPtr(P_ p, int follow)
1094 {
1095   nat s, g;
1096   P_ q, r;
1097   bdescr *bd;
1098 #if defined(__GNUC__)
1099   const int arr_size = 1024;
1100 #else
1101 #define arr_size 1024
1102 #endif
1103   StgPtr arr[arr_size];
1104   int i = 0;
1105
1106   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1107       for (s = 0; s < generations[g].n_steps; s++) {
1108           if (RtsFlags.GcFlags.generations == 1) {
1109               bd = generations[g].steps[s].to_blocks;
1110           } else {
1111               bd = generations[g].steps[s].blocks;
1112           }
1113           for (; bd; bd = bd->link) {
1114               for (q = bd->start; q < bd->free; q++) {
1115                   if (*q == (W_)p) {
1116                       if (i < arr_size) {
1117                           r = q;
1118                           while (!LOOKS_LIKE_INFO_PTR(*r) || (P_)*r == NULL) {
1119                               r--;
1120                           }
1121                           debugBelch("%p = ", r);
1122                           printClosure((StgClosure *)r);
1123                           arr[i++] = r;
1124                       } else {
1125                           return;
1126                       }
1127                   }
1128               }
1129           }
1130       }
1131   }
1132   if (follow && i == 1) {
1133       debugBelch("-->\n");
1134       findPtr(arr[0], 1);
1135   }
1136 }
1137
1138 #else /* DEBUG */
1139 void printPtr( StgPtr p )
1140 {
1141     debugBelch("ptr 0x%p (enable -DDEBUG for more info) " , p );
1142 }
1143
1144 void printObj( StgClosure *obj )
1145 {
1146     debugBelch("obj 0x%p (enable -DDEBUG for more info) " , obj );
1147 }
1148 #endif /* DEBUG */