rts/Printer.c

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