ghc/rts/Printer.c

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