ghc/rts/Printer.c

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