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