ghc/rts/Printer.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Printer.c,v 1.23 2000/03/31 03:09:36 hwloidl Exp $
   3  *
   4  * (c) The GHC Team, 1994-2000.
   5  *
   6  * Heap printer
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 #include "Rts.h"
  11 #include "Printer.h"
  12
  13 #ifdef DEBUG
  14
  15 #include "RtsUtils.h"
  16 #include "RtsFlags.h"
  17 #include "Bytecodes.h"  /* for InstrPtr */
  18 #include "Disassembler.h"
  19
  20 #include "Printer.h"
  21
  22 // HWL: explicit fixed header size to make debugging easier
  23 int fixed_hs = FIXED_HS, itbl_sz = sizeofW(StgInfoTable),
  24     uf_sz=sizeofW(StgUpdateFrame), sf_sz=sizeofW(StgSeqFrame);
  25
  26 /* --------------------------------------------------------------------------
  27  * local function decls
  28  * ------------------------------------------------------------------------*/
  29
  30 static void    printStdObject( StgClosure *obj, char* tag );
  31 static void    reset_table   ( int size );
  32 static void    prepare_table ( void );
  33 static void    insert        ( unsigned value, const char *name );
  34 #if 0 /* unused but might be useful sometime */
  35 static rtsBool lookup_name   ( char *name, unsigned *result );
  36 static void    enZcode       ( char *in, char *out );
  37 #endif
  38 static char    unZcode       ( char ch );
  39 rtsBool lookupGHCName ( StgPtr addr, const char **result );
  40 static void    printZcoded   ( const char *raw );
  41
  42 /* --------------------------------------------------------------------------
  43  * Printer
  44  * ------------------------------------------------------------------------*/
  45
  46
  47 #ifdef INTERPRETER
  48 extern void* itblNames[];
  49 extern int   nItblNames;
  50 char* lookupHugsItblName ( void* v )
  51 {
  52    int i;
  53    for (i = 0; i < nItblNames; i += 2)
  54       if (itblNames[i] == v) return itblNames[i+1];
  55    return NULL;
  56 }
  57 #endif
  58
  59 void printPtr( StgPtr p )
  60 {
  61 #ifdef INTERPRETER
  62     char* str;
  63 #endif
  64     const char *raw;
  65     if (lookupGHCName( p, &raw )) {
  66         printZcoded(raw);
  67 #ifdef INTERPRETER
  68     } else if ((raw = lookupHugsName(p)) != 0) {
  69         fprintf(stderr, "%s", raw);
  70     } else if ((str = lookupHugsItblName(p)) != 0) {
  71         fprintf(stderr, "%p=%s", p, str);
  72 #endif
  73     } else {
  74         fprintf(stderr, "%p", p);
  75     }
  76 }
  77
  78 void printObj( StgClosure *obj )
  79 {
  80     fprintf(stderr,"Object "); printPtr((StgPtr)obj); fprintf(stderr," = ");
  81     printClosure(obj);
  82 }
  83
  84 static void printStdObject( StgClosure *obj, char* tag )
  85 {
  86     StgWord i, j;
  87     const StgInfoTable* info = get_itbl(obj);
  88     fprintf(stderr,"%s(",tag);
  89     printPtr((StgPtr)obj->header.info);
  90     for (i = 0; i < info->layout.payload.ptrs; ++i) {
  91         fprintf(stderr,", ");
  92         printPtr((StgPtr)obj->payload[i]);
  93     }
  94     for (j = 0; j < info->layout.payload.nptrs; ++j) {
  95         fprintf(stderr,", %pd#",obj->payload[i+j]);
  96     }
  97     fprintf(stderr,")\n");
  98 }
  99
 100 void printClosure( StgClosure *obj )
 101 {
 102     switch ( get_itbl(obj)->type ) {
 103     case INVALID_OBJECT:
 104             barf("Invalid object");
 105 #ifdef INTERPRETER
 106     case BCO:
 107             fprintf(stderr,"BCO\n");
 108             disassemble(stgCast(StgBCO*,obj),"\t");
 109             break;
 110 #endif
 111
 112     case AP_UPD:
 113         {
 114             StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
 115             StgWord i;
 116             fprintf(stderr,"AP_UPD("); printPtr((StgPtr)ap->fun);
 117             for (i = 0; i < ap->n_args; ++i) {
 118                 fprintf(stderr,", ");
 119                 printPtr(ap->payload[i]);
 120             }
 121             fprintf(stderr,")\n");
 122             break;
 123         }
 124
 125     case PAP:
 126         {
 127             StgPAP* pap = stgCast(StgPAP*,obj);
 128             StgWord i;
 129             fprintf(stderr,"PAP("); printPtr((StgPtr)pap->fun);
 130             for (i = 0; i < pap->n_args; ++i) {
 131                 fprintf(stderr,", ");
 132                 printPtr((StgPtr)pap->payload[i]);
 133             }
 134             fprintf(stderr,")\n");
 135             break;
 136         }
 137
 138     case IND:
 139             fprintf(stderr,"IND(");
 140             printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
 141             fprintf(stderr,")\n");
 142             break;
 143
 144     case IND_STATIC:
 145             fprintf(stderr,"IND_STATIC(");
 146             printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
 147             fprintf(stderr,")\n");
 148             break;
 149
 150     case IND_OLDGEN:
 151             fprintf(stderr,"IND_OLDGEN(");
 152             printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
 153             fprintf(stderr,")\n");
 154             break;
 155
 156     case CAF_UNENTERED:
 157         {
 158             StgCAF* caf = stgCast(StgCAF*,obj);
 159             fprintf(stderr,"CAF_UNENTERED(");
 160             printPtr((StgPtr)caf->body);
 161             fprintf(stderr,", ");
 162             printPtr((StgPtr)caf->value); /* should be null */
 163             fprintf(stderr,", ");
 164             printPtr((StgPtr)caf->link);  /* should be null */
 165             fprintf(stderr,")\n");
 166             break;
 167         }
 168
 169     case CAF_ENTERED:
 170         {
 171             StgCAF* caf = stgCast(StgCAF*,obj);
 172             fprintf(stderr,"CAF_ENTERED(");
 173             printPtr((StgPtr)caf->body);
 174             fprintf(stderr,", ");
 175             printPtr((StgPtr)caf->value);
 176             fprintf(stderr,", ");
 177             printPtr((StgPtr)caf->link);
 178             fprintf(stderr,")\n");
 179             break;
 180         }
 181
 182     case CAF_BLACKHOLE:
 183             fprintf(stderr,"CAF_BH(");
 184             printPtr((StgPtr)stgCast(StgBlockingQueue*,obj)->blocking_queue);
 185             fprintf(stderr,")\n");
 186             break;
 187
 188     case SE_BLACKHOLE:
 189             fprintf(stderr,"SE_BH\n");
 190             break;
 191
 192     case SE_CAF_BLACKHOLE:
 193             fprintf(stderr,"SE_CAF_BH\n");
 194             break;
 195
 196     case BLACKHOLE:
 197             fprintf(stderr,"BH\n");
 198             break;
 199
 200     case BLACKHOLE_BQ:
 201             fprintf(stderr,"BQ(");
 202             printPtr((StgPtr)stgCast(StgBlockingQueue*,obj)->blocking_queue);
 203             fprintf(stderr,")\n");
 204             break;
 205
 206     case TSO:
 207       fprintf(stderr,"TSO(");
 208       fprintf(stderr,"%d (%x)",
 209               stgCast(StgTSO*,obj)->id, stgCast(StgTSO*,obj));
 210       fprintf(stderr,")\n");
 211       break;
 212
 213 #if defined(PAR)
 214     case BLOCKED_FETCH:
 215       fprintf(stderr,"BLOCKED_FETCH(");
 216       printGA(&(stgCast(StgBlockedFetch*,obj)->ga));
 217       printPtr((StgPtr)(stgCast(StgBlockedFetch*,obj)->node));
 218       fprintf(stderr,")\n");
 219       break;
 220
 221     case FETCH_ME:
 222       fprintf(stderr,"FETCH_ME(");
 223       printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
 224       fprintf(stderr,")\n");
 225       break;
 226
 227     case FETCH_ME_BQ:
 228       fprintf(stderr,"FETCH_ME_BQ(");
 229       // printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
 230       printPtr((StgPtr)stgCast(StgFetchMeBlockingQueue*,obj)->blocking_queue);
 231       fprintf(stderr,")\n");
 232       break;
 233 #endif
 234 #if defined(GRAN) || defined(PAR)
 235     case RBH:
 236       fprintf(stderr,"RBH(");
 237       printPtr((StgPtr)stgCast(StgRBH*,obj)->blocking_queue);
 238       fprintf(stderr,")\n");
 239       break;
 240
 241 #endif
 242
 243     case CONSTR:
 244     case CONSTR_1_0: case CONSTR_0_1:
 245     case CONSTR_1_1: case CONSTR_0_2: case CONSTR_2_0:
 246     case CONSTR_INTLIKE:
 247     case CONSTR_CHARLIKE:
 248     case CONSTR_STATIC:
 249     case CONSTR_NOCAF_STATIC:
 250         {
 251             /* We can't use printStdObject because we want to print the
 252              * tag as well.
 253              */
 254             StgWord i, j;
 255             const StgInfoTable* info = get_itbl(obj);
 256             fprintf(stderr,"PACK(");
 257             printPtr((StgPtr)obj->header.info);
 258             fprintf(stderr,"(tag=%d)",info->srt_len);
 259             for (i = 0; i < info->layout.payload.ptrs; ++i) {
 260                 fprintf(stderr,", ");
 261                 printPtr((StgPtr)obj->payload[i]);
 262             }
 263             for (j = 0; j < info->layout.payload.nptrs; ++j) {
 264                 fprintf(stderr,", %p#", obj->payload[i+j]);
 265             }
 266             fprintf(stderr,")\n");
 267             break;
 268         }
 269
 270     case FUN:
 271     case FUN_1_0: case FUN_0_1:
 272     case FUN_1_1: case FUN_0_2: case FUN_2_0:
 273     case FUN_STATIC:
 274             printStdObject(obj,"FUN");
 275             break;
 276
 277     case THUNK:
 278     case THUNK_1_0: case THUNK_0_1:
 279     case THUNK_1_1: case THUNK_0_2: case THUNK_2_0:
 280     case THUNK_STATIC:
 281             /* ToDo: will this work for THUNK_STATIC too? */
 282             printStdObject(obj,"THUNK");
 283             break;
 284
 285     case THUNK_SELECTOR:
 286             printStdObject(obj,"THUNK_SELECTOR");
 287             break;
 288
 289     case ARR_WORDS:
 290         {
 291             StgWord i;
 292             fprintf(stderr,"ARR_WORDS(\"");
 293             /* ToDo: we can't safely assume that this is a string!
 294             for (i = 0; arrWordsGetChar(obj,i); ++i) {
 295                 putchar(arrWordsGetChar(obj,i));
 296                 } */
 297             for (i=0; i<((StgArrWords *)obj)->words; i++)
 298               fprintf(stderr, "%d", ((StgArrWords *)obj)->payload[i]);
 299             fprintf(stderr,"\")\n");
 300             break;
 301         }
 302
 303     case UPDATE_FRAME:
 304         {
 305             StgUpdateFrame* u = stgCast(StgUpdateFrame*,obj);
 306             fprintf(stderr,"UpdateFrame(");
 307             printPtr((StgPtr)GET_INFO(u));
 308             fprintf(stderr,",");
 309             printPtr((StgPtr)u->updatee);
 310             fprintf(stderr,",");
 311             printPtr((StgPtr)u->link);
 312             fprintf(stderr,")\n");
 313             break;
 314         }
 315
 316     case CATCH_FRAME:
 317         {
 318             StgCatchFrame* u = stgCast(StgCatchFrame*,obj);
 319             fprintf(stderr,"CatchFrame(");
 320             printPtr((StgPtr)GET_INFO(u));
 321             fprintf(stderr,",");
 322             printPtr((StgPtr)u->handler);
 323             fprintf(stderr,",");
 324             printPtr((StgPtr)u->link);
 325             fprintf(stderr,")\n");
 326             break;
 327         }
 328
 329     case SEQ_FRAME:
 330         {
 331             StgSeqFrame* u = stgCast(StgSeqFrame*,obj);
 332             fprintf(stderr,"SeqFrame(");
 333             printPtr((StgPtr)GET_INFO(u));
 334             fprintf(stderr,",");
 335             printPtr((StgPtr)u->link);
 336             fprintf(stderr,")\n");
 337             break;
 338         }
 339
 340     case STOP_FRAME:
 341         {
 342             StgStopFrame* u = stgCast(StgStopFrame*,obj);
 343             fprintf(stderr,"StopFrame(");
 344             printPtr((StgPtr)GET_INFO(u));
 345             fprintf(stderr,")\n");
 346             break;
 347         }
 348     default:
 349             //barf("printClosure %d",get_itbl(obj)->type);
 350             fprintf(stderr, "*** printClosure: unknown type %d ****\n",
 351                     get_itbl(obj)->type );
 352             return;
 353     }
 354 }
 355
 356 /*
 357 void printGraph( StgClosure *obj )
 358 {
 359  printClosure(obj);
 360 }
 361 */
 362
 363 StgPtr printStackObj( StgPtr sp )
 364 {
 365     /*fprintf(stderr,"Stack[%d] = ", &stgStack[STACK_SIZE] - sp); */
 366
 367     if (IS_ARG_TAG(*sp)) {
 368         nat i;
 369         StgWord tag = *sp++;
 370         fprintf(stderr,"Tagged{");
 371         for (i = 0; i < tag; i++) {
 372             fprintf(stderr,"0x%x#", (unsigned)(*sp++));
 373             if (i < tag-1) fprintf(stderr, ", ");
 374         }
 375         fprintf(stderr, "}\n");
 376     } else {
 377         StgClosure* c = (StgClosure*)(*sp);
 378         printPtr((StgPtr)*sp);
 379 #ifdef INTERPRETER
 380         if (c == &ret_bco_info) {
 381            fprintf(stderr, "\t\t");
 382            fprintf(stderr, "ret_bco_info\n" );
 383         } else
 384         if (IS_HUGS_CONSTR_INFO(GET_INFO(c))) {
 385            fprintf(stderr, "\t\t\t");
 386            fprintf(stderr, "ConstrInfoTable\n" );
 387         } else
 388 #endif
 389         if (get_itbl(c)->type == BCO) {
 390            fprintf(stderr, "\t\t\t");
 391            fprintf(stderr, "BCO(...)\n");
 392         }
 393         else {
 394            fprintf(stderr, "\t\t\t");
 395            printClosure ( (StgClosure*)(*sp));
 396         }
 397         sp += 1;
 398     }
 399     return sp;
 400
 401 }
 402
 403 void printStackChunk( StgPtr sp, StgPtr spBottom )
 404 {
 405     StgWord32 bitmap;
 406     const StgInfoTable *info;
 407
 408     ASSERT(sp <= spBottom);
 409     while (sp < spBottom) {
 410       if (!IS_ARG_TAG(*sp) && LOOKS_LIKE_GHC_INFO(*sp)) {
 411         info = get_itbl((StgClosure *)sp);
 412         switch (info->type) {
 413
 414         case UPDATE_FRAME:
 415             printObj( stgCast(StgClosure*,sp) );
 416             sp += sizeofW(StgUpdateFrame);
 417             continue;
 418
 419         case SEQ_FRAME:
 420             printObj( stgCast(StgClosure*,sp) );
 421             sp += sizeofW(StgSeqFrame);
 422             continue;
 423
 424         case CATCH_FRAME:
 425             printObj( stgCast(StgClosure*,sp) );
 426             sp += sizeofW(StgCatchFrame);
 427             continue;
 428
 429         case STOP_FRAME:
 430             /* not quite: ASSERT(stgCast(StgPtr,su) == spBottom); */
 431             printObj( stgCast(StgClosure*,sp) );
 432             continue;
 433
 434         case RET_DYN:
 435           fprintf(stderr, "RET_DYN (%p)\n", sp);
 436           bitmap = *++sp;
 437           ++sp;
 438           fprintf(stderr, "Bitmap: 0x%x\n", bitmap);
 439           goto small_bitmap;
 440
 441         case RET_SMALL:
 442         case RET_VEC_SMALL:
 443           fprintf(stderr, "RET_SMALL (%p)\n", sp);
 444           bitmap = info->layout.bitmap;
 445           sp++;
 446         small_bitmap:
 447           while (bitmap != 0) {
 448             fprintf(stderr,"   stk[%d] (%p) = ", spBottom-sp, sp);
 449             if ((bitmap & 1) == 0) {
 450               printPtr((P_)*sp);
 451               fprintf(stderr,"\n");
 452             } else {
 453               fprintf(stderr,"Word# %d\n", *sp++);
 454             }
 455             sp++;
 456             bitmap = bitmap >> 1;
 457             }
 458           continue;
 459
 460         case RET_BIG:
 461         case RET_VEC_BIG:
 462           barf("todo");
 463
 464         default:
 465           break;
 466         }
 467       }
 468       fprintf(stderr,"Stack[%d] (%p) = ", spBottom-sp, sp);
 469       sp = printStackObj(sp);
 470     }
 471 }
 472
 473 void printStack( StgPtr sp, StgPtr spBottom, StgUpdateFrame* su )
 474 {
 475     /* check everything down to the first update frame */
 476     printStackChunk( sp, stgCast(StgPtr,su) );
 477     while ( stgCast(StgPtr,su) < spBottom) {
 478         sp = stgCast(StgPtr,su);
 479         switch (get_itbl(su)->type) {
 480         case UPDATE_FRAME:
 481                 printObj( stgCast(StgClosure*,su) );
 482                 sp += sizeofW(StgUpdateFrame);
 483                 su = su->link;
 484                 break;
 485         case SEQ_FRAME:
 486                 printObj( stgCast(StgClosure*,su) );
 487                 sp += sizeofW(StgSeqFrame);
 488                 su = stgCast(StgSeqFrame*,su)->link;
 489                 break;
 490         case CATCH_FRAME:
 491                 printObj( stgCast(StgClosure*,su) );
 492                 sp += sizeofW(StgCatchFrame);
 493                 su = stgCast(StgCatchFrame*,su)->link;
 494                 break;
 495         case STOP_FRAME:
 496                 /* not quite: ASSERT(stgCast(StgPtr,su) == spBottom); */
 497                 printObj( stgCast(StgClosure*,su) );
 498                 return;
 499         default:
 500                 barf("printStack: weird record found on update frame list.");
 501         }
 502         printStackChunk( sp, stgCast(StgPtr,su) );
 503     }
 504     ASSERT(stgCast(StgPtr,su) == spBottom);
 505 }
 506
 507 void printTSO( StgTSO *tso )
 508 {
 509     printStack( tso->sp, tso->stack+tso->stack_size,tso->su);
 510     /* printStackChunk( tso->sp, tso->stack+tso->stack_size); */
 511 }
 512
 513 /* -----------------------------------------------------------------------------
 514    Closure types
 515
 516    NOTE: must be kept in sync with the closure types in includes/ClosureTypes.h
 517    -------------------------------------------------------------------------- */
 518
 519 static char *closure_type_names[] = {
 520   "INVALID_OBJECT",             /* 0  */
 521   "CONSTR",                     /* 1  */
 522   "CONSTR_1_0",                 /* 2  */
 523   "CONSTR_0_1",                 /* 3  */
 524   "CONSTR_2_0",                 /* 4  */
 525   "CONSTR_1_1",                 /* 5  */
 526   "CONSTR_0_2",                 /* 6  */
 527   "CONSTR_INTLIKE",             /* 7  */
 528   "CONSTR_CHARLIKE",            /* 8  */
 529   "CONSTR_STATIC",              /* 9  */
 530   "CONSTR_NOCAF_STATIC",        /* 10 */
 531   "FUN",                        /* 11 */
 532   "FUN_1_0",                    /* 12 */
 533   "FUN_0_1",                    /* 13 */
 534   "FUN_2_0",                    /* 14 */
 535   "FUN_1_1",                    /* 15 */
 536   "FUN_0_2",                    /* 16 */
 537   "FUN_STATIC",                 /* 17 */
 538   "THUNK",                      /* 18 */
 539   "THUNK_1_0",                  /* 19 */
 540   "THUNK_0_1",                  /* 20 */
 541   "THUNK_2_0",                  /* 21 */
 542   "THUNK_1_1",                  /* 22 */
 543   "THUNK_0_2",                  /* 23 */
 544   "THUNK_STATIC",               /* 24 */
 545   "THUNK_SELECTOR",             /* 25 */
 546   "BCO",                        /* 26 */
 547   "AP_UPD",                     /* 27 */
 548   "PAP",                        /* 28 */
 549   "IND",                        /* 29 */
 550   "IND_OLDGEN",                 /* 30 */
 551   "IND_PERM",                   /* 31 */
 552   "IND_OLDGEN_PERM",            /* 32 */
 553   "IND_STATIC",                 /* 33 */
 554   "CAF_UNENTERED",              /* 34 */
 555   "CAF_ENTERED",                /* 35 */
 556   "CAF_BLACKHOLE",              /* 36 */
 557   "RET_BCO",                    /* 37 */
 558   "RET_SMALL",                  /* 38 */
 559   "RET_VEC_SMALL",              /* 39 */
 560   "RET_BIG",                    /* 40 */
 561   "RET_VEC_BIG",                /* 41 */
 562   "RET_DYN",                    /* 42 */
 563   "UPDATE_FRAME",               /* 43 */
 564   "CATCH_FRAME",                /* 44 */
 565   "STOP_FRAME",                 /* 45 */
 566   "SEQ_FRAME",                  /* 46 */
 567   "BLACKHOLE",                  /* 47 */
 568   "BLACKHOLE_BQ",               /* 48 */
 569   "SE_BLACKHOLE",               /* 49 */
 570   "SE_CAF_BLACKHOLE",           /* 50 */
 571   "MVAR",                       /* 51 */
 572   "ARR_WORDS",                  /* 52 */
 573   "MUT_ARR_PTRS",               /* 53 */
 574   "MUT_ARR_PTRS_FROZEN",        /* 54 */
 575   "MUT_VAR",                    /* 55 */
 576   "WEAK",                       /* 56 */
 577   "FOREIGN",                    /* 57 */
 578   "STABLE_NAME",                /* 58 */
 579   "TSO",                        /* 59 */
 580   "BLOCKED_FETCH",              /* 60 */
 581   "FETCH_ME",                   /* 61 */
 582   "FETCH_ME_BQ",                /* 62 */
 583   "RBH",                        /* 63 */
 584   "EVACUATED",                  /* 64 */
 585   "N_CLOSURE_TYPES"             /* 65 */
 586 };
 587
 588 char *
 589 info_type(StgClosure *closure){
 590   return closure_type_names[get_itbl(closure)->type];
 591 }
 592
 593 char *
 594 info_type_by_ip(StgInfoTable *ip){
 595   return closure_type_names[ip->type];
 596 }
 597
 598 void
 599 info_hdr_type(StgClosure *closure, char *res){
 600   strcpy(res,closure_type_names[get_itbl(closure)->type]);
 601 }
 602
 603 /* --------------------------------------------------------------------------
 604  * Address printing code
 605  *
 606  * Uses symbol table in (unstripped executable)
 607  * ------------------------------------------------------------------------*/
 608
 609 /* --------------------------------------------------------------------------
 610  * Simple lookup table
 611  *
 612  * Current implementation is pretty dumb!
 613  * ------------------------------------------------------------------------*/
 614
 615 struct entry {
 616     nat value;
 617     const char *name;
 618 };
 619
 620 static nat max_table_size;
 621 static nat table_size;
 622 static struct entry* table;
 623
 624 static void reset_table( int size )
 625 {
 626     max_table_size = size;
 627     table_size = 0;
 628     table = (struct entry *) malloc(size * sizeof(struct entry));
 629 }
 630
 631 static void prepare_table( void )
 632 {
 633     /* Could sort it...  */
 634 }
 635
 636 static void insert( unsigned value, const char *name )
 637 {
 638     if ( table_size >= max_table_size ) {
 639         barf( "Symbol table overflow\n" );
 640     }
 641     table[table_size].value = value;
 642     table[table_size].name = name;
 643     table_size = table_size + 1;
 644 }
 645
 646
 647 #if 0
 648 static rtsBool lookup_name( char *name, unsigned *result )
 649 {
 650     int i;
 651     for( i = 0; i < table_size && strcmp(name,table[i].name) != 0; ++i ) {
 652     }
 653     if (i < table_size) {
 654         *result = table[i].value;
 655         return rtsTrue;
 656     } else {
 657         return rtsFalse;
 658     }
 659 }
 660 #endif
 661
 662 /* Code from somewhere inside GHC (circa 1994)
 663  * * Z-escapes:
 664  *     "std"++xs -> "Zstd"++xs
 665  *     char_to_c 'Z'  = "ZZ"
 666  *     char_to_c '&'  = "Za"
 667  *     char_to_c '|'  = "Zb"
 668  *     char_to_c ':'  = "Zc"
 669  *     char_to_c '/'  = "Zd"
 670  *     char_to_c '='  = "Ze"
 671  *     char_to_c '>'  = "Zg"
 672  *     char_to_c '#'  = "Zh"
 673  *     char_to_c '<'  = "Zl"
 674  *     char_to_c '-'  = "Zm"
 675  *     char_to_c '!'  = "Zn"
 676  *     char_to_c '.'  = "Zo"
 677  *     char_to_c '+'  = "Zp"
 678  *     char_to_c '\'' = "Zq"
 679  *     char_to_c '*'  = "Zt"
 680  *     char_to_c '_'  = "Zu"
 681  *     char_to_c c    = "Z" ++ show (ord c)
 682  */
 683 static char unZcode( char ch )
 684 {
 685     switch (ch) {
 686     case 'a'  : return ('&');
 687     case 'b'  : return ('|');
 688     case 'c'  : return (':');
 689     case 'd'  : return ('/');
 690     case 'e'  : return ('=');
 691     case 'g'  : return ('>');
 692     case 'h'  : return ('#');
 693     case 'l'  : return ('<');
 694     case 'm'  : return ('-');
 695     case 'n'  : return ('!');
 696     case 'o'  : return ('.');
 697     case 'p'  : return ('+');
 698     case 'q'  : return ('\'');
 699     case 't'  : return ('*');
 700     case 'u'  : return ('_');
 701     case 'Z'  :
 702     case '\0' : return ('Z');
 703     default   : return (ch);
 704     }
 705 }
 706
 707 #if 0
 708 /* Precondition: out big enough to handle output (about twice length of in) */
 709 static void enZcode( char *in, char *out )
 710 {
 711     int i, j;
 712
 713     j = 0;
 714     out[ j++ ] = '_';
 715     for( i = 0; in[i] != '\0'; ++i ) {
 716         switch (in[i]) {
 717         case 'Z'  :
 718                 out[j++] = 'Z';
 719                 out[j++] = 'Z';
 720                 break;
 721         case '&'  :
 722                 out[j++] = 'Z';
 723                 out[j++] = 'a';
 724                 break;
 725         case '|'  :
 726                 out[j++] = 'Z';
 727                 out[j++] = 'b';
 728                 break;
 729         case ':'  :
 730                 out[j++] = 'Z';
 731                 out[j++] = 'c';
 732                 break;
 733         case '/'  :
 734                 out[j++] = 'Z';
 735                 out[j++] = 'd';
 736                 break;
 737         case '='  :
 738                 out[j++] = 'Z';
 739                 out[j++] = 'e';
 740                 break;
 741         case '>'  :
 742                 out[j++] = 'Z';
 743                 out[j++] = 'g';
 744                 break;
 745         case '#'  :
 746                 out[j++] = 'Z';
 747                 out[j++] = 'h';
 748                 break;
 749         case '<'  :
 750                 out[j++] = 'Z';
 751                 out[j++] = 'l';
 752                 break;
 753         case '-'  :
 754                 out[j++] = 'Z';
 755                 out[j++] = 'm';
 756                 break;
 757         case '!'  :
 758                 out[j++] = 'Z';
 759                 out[j++] = 'n';
 760                 break;
 761         case '.'  :
 762                 out[j++] = 'Z';
 763                 out[j++] = 'o';
 764                 break;
 765         case '+'  :
 766                 out[j++] = 'Z';
 767                 out[j++] = 'p';
 768                 break;
 769         case '\'' :
 770                 out[j++] = 'Z';
 771                 out[j++] = 'q';
 772                 break;
 773         case '*'  :
 774                 out[j++] = 'Z';
 775                 out[j++] = 't';
 776                 break;
 777         case '_'  :
 778                 out[j++] = 'Z';
 779                 out[j++] = 'u';
 780                 break;
 781         default :
 782                 out[j++] = in[i];
 783                 break;
 784         }
 785     }
 786     out[j] = '\0';
 787 }
 788 #endif
 789
 790 rtsBool lookupGHCName( StgPtr addr, const char **result )
 791 {
 792     nat i;
 793     for( i = 0; i < table_size && table[i].value != (unsigned) addr; ++i ) {
 794     }
 795     if (i < table_size) {
 796         *result = table[i].name;
 797         return rtsTrue;
 798     } else {
 799         return rtsFalse;
 800     }
 801 }
 802
 803 static void printZcoded( const char *raw )
 804 {
 805     nat j = 0;
 806
 807     while ( raw[j] != '\0' ) {
 808         if (raw[j] == 'Z') {
 809             fputc(unZcode(raw[j+1]),stderr);
 810             j = j + 2;
 811         } else {
 812             fputc(raw[j],stderr);
 813             j = j + 1;
 814         }
 815     }
 816 }
 817
 818 /* --------------------------------------------------------------------------
 819  * Symbol table loading
 820  * ------------------------------------------------------------------------*/
 821
 822 /* Causing linking trouble on Win32 plats, so I'm
 823    disabling this for now.
 824 */
 825 /* For now, BFD support is unconditionally disabled -- HWL */
 826 #if 0 /* HWL */ && defined(HAVE_BFD_H) && !defined(_WIN32)
 827
 828 #include <bfd.h>
 829
 830 /* Fairly ad-hoc piece of code that seems to filter out a lot of
 831  * rubbish like the obj-splitting symbols
 832  */
 833
 834 static rtsBool isReal( flagword flags, const char *name )
 835 {
 836 #if 0
 837     /* ToDo: make this work on BFD */
 838     int tp = type & N_TYPE;
 839     if (tp == N_TEXT || tp == N_DATA) {
 840         return (name[0] == '_' && name[1] != '_');
 841     } else {
 842         return rtsFalse;
 843     }
 844 #else
 845     (void)flags;   /* keep gcc -Wall happy */
 846     if (*name == '\0'  ||
 847         (name[0] == 'g' && name[1] == 'c' && name[2] == 'c') ||
 848         (name[0] == 'c' && name[1] == 'c' && name[2] == '.')) {
 849         return rtsFalse;
 850     }
 851     return rtsTrue;
 852 #endif
 853 }
 854
 855 extern void DEBUG_LoadSymbols( char *name )
 856 {
 857     bfd* abfd;
 858     char **matching;
 859
 860     bfd_init();
 861     abfd = bfd_openr(name, "default");
 862     if (abfd == NULL) {
 863         barf("can't open executable %s to get symbol table", name);
 864     }
 865     if (!bfd_check_format_matches (abfd, bfd_object, &matching)) {
 866         barf("mismatch");
 867     }
 868
 869     {
 870         long storage_needed;
 871         asymbol **symbol_table;
 872         long number_of_symbols;
 873         long num_real_syms = 0;
 874         long i;
 875
 876         storage_needed = bfd_get_symtab_upper_bound (abfd);
 877
 878         if (storage_needed < 0) {
 879             barf("can't read symbol table");
 880         }
 881 #if 0
 882         if (storage_needed == 0) {
 883             belch("no storage needed");
 884         }
 885 #endif
 886         symbol_table = (asymbol **) stgMallocBytes(storage_needed,"DEBUG_LoadSymbols");
 887
 888         number_of_symbols = bfd_canonicalize_symtab (abfd, symbol_table);
 889
 890         if (number_of_symbols < 0) {
 891             barf("can't canonicalise symbol table");
 892         }
 893
 894         for( i = 0; i != number_of_symbols; ++i ) {
 895             symbol_info info;
 896             bfd_get_symbol_info(abfd,symbol_table[i],&info);
 897             /*fprintf(stderr,"\t%c\t0x%x      \t%s\n",info.type,(nat)info.value,info.name); */
 898             if (isReal(info.type, info.name)) {
 899                 num_real_syms += 1;
 900             }
 901         }
 902
 903         IF_DEBUG(evaluator,
 904                  fprintf(stderr,"Loaded %ld symbols. Of which %ld are real symbols\n",
 905                          number_of_symbols, num_real_syms)
 906                  );
 907
 908         reset_table( num_real_syms );
 909
 910         for( i = 0; i != number_of_symbols; ++i ) {
 911             symbol_info info;
 912             bfd_get_symbol_info(abfd,symbol_table[i],&info);
 913             if (isReal(info.type, info.name)) {
 914                 insert( info.value, info.name );
 915             }
 916         }
 917
 918         free(symbol_table);
 919     }
 920     prepare_table();
 921 }
 922
 923 #else /* HAVE_BFD_H */
 924
 925 extern void DEBUG_LoadSymbols( char *name STG_UNUSED )
 926 {
 927   /* nothing, yet */
 928 }
 929
 930 #endif /* HAVE_BFD_H */
 931
 932 #include "StoragePriv.h"
 933
 934 void
 935 findPtr(P_ p)
 936 {
 937   nat s, g;
 938   P_ q;
 939   bdescr *bd;
 940
 941   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 942     for (s = 0; s < generations[g].n_steps; s++) {
 943       for (bd = generations[g].steps[s].blocks; bd; bd = bd->link) {
 944         for (q = bd->start; q < bd->free; q++) {
 945           if (*q == (W_)p) {
 946             printf("%p\n", q);
 947           }
 948         }
 949       }
 950     }
 951   }
 952 }
 953
 954 #else /* DEBUG */
 955 void printPtr( StgPtr p )
 956 {
 957     fprintf(stderr, "ptr 0x%p (enable -DDEBUG for more info) " , p );
 958 }
 959
 960 void printObj( StgClosure *obj )
 961 {
 962     fprintf(stderr, "obj 0x%p (enable -DDEBUG for more info) " , obj );
 963 }
 964 #endif /* DEBUG */