ghc/rts/Printer.c

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