ghc/rts/Printer.c

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