ghc/rts/Printer.c

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