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