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