ghc/rts/Printer.c

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