ghc/rts/Printer.c

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