ghc/rts/Printer.c

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