ghc/rts/Printer.c

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