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