ghc/rts/Printer.c

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