ghc/rts/Printer.c

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