ghc/rts/Printer.c

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