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