ghc/rts/Printer.c

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