ghc/rts/Printer.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Printer.c,v 1.55 2002/12/19 18:00:42 panne Exp $
   3  *
   4  * (c) The GHC Team, 1994-2000.
   5  *
   6  * Heap printer
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 #include "PosixSource.h"
  11 #include "Rts.h"
  12 #include "Printer.h"
  13
  14 #include <stdio.h>
  15
  16 #ifdef DEBUG
  17
  18 #include "RtsUtils.h"
  19 #include "RtsFlags.h"
  20 #include "MBlock.h"
  21 #include "Storage.h"
  22 #include "Bytecodes.h"  /* for InstrPtr */
  23 #include "Disassembler.h"
  24
  25 #include <stdlib.h>
  26 #include <string.h>
  27
  28 #if defined(GRAN) || defined(PAR)
  29 // HWL: explicit fixed header size to make debugging easier
  30 int fixed_hs = FIXED_HS, itbl_sz = sizeofW(StgInfoTable),
  31     uf_sz=sizeofW(StgUpdateFrame);
  32 #endif
  33
  34 /* --------------------------------------------------------------------------
  35  * local function decls
  36  * ------------------------------------------------------------------------*/
  37
  38 static void    printStdObject( StgClosure *obj, char* tag );
  39 static void    printStdObjPayload( StgClosure *obj );
  40 static void    reset_table   ( int size );
  41 static void    prepare_table ( void );
  42 static void    insert        ( unsigned value, const char *name );
  43 #if 0 /* unused but might be useful sometime */
  44 static rtsBool lookup_name   ( char *name, unsigned *result );
  45 static void    enZcode       ( char *in, char *out );
  46 #endif
  47 static char    unZcode       ( char ch );
  48 const char *   lookupGHCName ( void *addr );
  49 static void    printZcoded   ( const char *raw );
  50
  51 /* --------------------------------------------------------------------------
  52  * Printer
  53  * ------------------------------------------------------------------------*/
  54
  55 void printPtr( StgPtr p )
  56 {
  57     const char *raw;
  58     raw = lookupGHCName(p);
  59     if (raw != NULL) {
  60         printZcoded(raw);
  61     } else {
  62         fprintf(stderr, "%p", p);
  63     }
  64 }
  65
  66 void printObj( StgClosure *obj )
  67 {
  68     fprintf(stderr,"Object "); printPtr((StgPtr)obj); fprintf(stderr," = ");
  69     printClosure(obj);
  70 }
  71
  72 static inline void
  73 printStdObjHdr( StgClosure *obj, char* tag )
  74 {
  75     fprintf(stderr,"%s(",tag);
  76     printPtr((StgPtr)obj->header.info);
  77 #ifdef PROFILING
  78     fprintf(stderr,", %s", obj->header.prof.ccs->cc->label);
  79 #endif
  80 }
  81
  82 static void
  83 printStdObjPayload( StgClosure *obj )
  84 {
  85     StgWord i, j;
  86     const StgInfoTable* info;
  87
  88     info = get_itbl(obj);
  89     for (i = 0; i < info->layout.payload.ptrs; ++i) {
  90         fprintf(stderr,", ");
  91         printPtr((StgPtr)obj->payload[i]);
  92     }
  93     for (j = 0; j < info->layout.payload.nptrs; ++j) {
  94         fprintf(stderr,", %pd#",obj->payload[i+j]);
  95     }
  96     fprintf(stderr,")\n");
  97 }
  98
  99 static void
 100 printStdObject( StgClosure *obj, char* tag )
 101 {
 102     printStdObjHdr( obj, tag );
 103     printStdObjPayload( obj );
 104 }
 105
 106 void
 107 printClosure( StgClosure *obj )
 108 {
 109     StgInfoTable *info;
 110
 111     info = get_itbl(obj);
 112
 113     switch ( info->type ) {
 114     case INVALID_OBJECT:
 115             barf("Invalid object");
 116     case BCO:
 117             disassemble( (StgBCO*)obj );
 118             break;
 119
 120     case MUT_VAR:
 121         {
 122           StgMutVar* mv = (StgMutVar*)obj;
 123           fprintf(stderr,"MUT_VAR(var=%p, link=%p)\n", mv->var, mv->mut_link);
 124           break;
 125         }
 126
 127     case AP_STACK:
 128         {
 129             StgAP_STACK* ap = stgCast(StgAP_STACK*,obj);
 130             StgWord i;
 131             fprintf(stderr,"AP_STACK("); printPtr((StgPtr)ap->fun);
 132             for (i = 0; i < ap->size; ++i) {
 133                 fprintf(stderr,", ");
 134                 printPtr((P_)ap->payload[i]);
 135             }
 136             fprintf(stderr,")\n");
 137             break;
 138         }
 139
 140     case AP:
 141         {
 142             StgPAP* ap = stgCast(StgPAP*,obj);
 143             StgWord i;
 144             fprintf(stderr,"AP("); printPtr((StgPtr)ap->fun);
 145             for (i = 0; i < ap->n_args; ++i) {
 146                 fprintf(stderr,", ");
 147                 printPtr((P_)ap->payload[i]);
 148             }
 149             fprintf(stderr,")\n");
 150             break;
 151         }
 152
 153     case PAP:
 154         {
 155             StgPAP* pap = stgCast(StgPAP*,obj);
 156             StgWord i;
 157             fprintf(stderr,"PAP/%d(",pap->arity);
 158             printPtr((StgPtr)pap->fun);
 159             for (i = 0; i < pap->n_args; ++i) {
 160                 fprintf(stderr,", ");
 161                 printPtr((StgPtr)pap->payload[i]);
 162             }
 163             fprintf(stderr,")\n");
 164             break;
 165         }
 166
 167     case FOREIGN:
 168             fprintf(stderr,"FOREIGN(");
 169             printPtr((StgPtr)( ((StgForeignObj*)obj)->data ));
 170             fprintf(stderr,")\n");
 171             break;
 172
 173     case IND:
 174             fprintf(stderr,"IND(");
 175             printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
 176             fprintf(stderr,")\n");
 177             break;
 178
 179     case IND_PERM:
 180             fprintf(stderr,"IND(");
 181             printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
 182             fprintf(stderr,")\n");
 183             break;
 184
 185     case IND_STATIC:
 186             fprintf(stderr,"IND_STATIC(");
 187             printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
 188             fprintf(stderr,")\n");
 189             break;
 190
 191     case IND_OLDGEN:
 192             fprintf(stderr,"IND_OLDGEN(");
 193             printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
 194             fprintf(stderr,")\n");
 195             break;
 196
 197     case CAF_BLACKHOLE:
 198             fprintf(stderr,"CAF_BH(");
 199             printPtr((StgPtr)stgCast(StgBlockingQueue*,obj)->blocking_queue);
 200             fprintf(stderr,")\n");
 201             break;
 202
 203     case SE_BLACKHOLE:
 204             fprintf(stderr,"SE_BH\n");
 205             break;
 206
 207     case SE_CAF_BLACKHOLE:
 208             fprintf(stderr,"SE_CAF_BH\n");
 209             break;
 210
 211     case BLACKHOLE:
 212             fprintf(stderr,"BH\n");
 213             break;
 214
 215     case BLACKHOLE_BQ:
 216             fprintf(stderr,"BQ(");
 217             printPtr((StgPtr)stgCast(StgBlockingQueue*,obj)->blocking_queue);
 218             fprintf(stderr,")\n");
 219             break;
 220
 221     case TSO:
 222       fprintf(stderr,"TSO(");
 223       fprintf(stderr,"%d (%p)",((StgTSO*)obj)->id, (StgTSO*)obj);
 224       fprintf(stderr,")\n");
 225       break;
 226
 227 #if defined(PAR)
 228     case BLOCKED_FETCH:
 229       fprintf(stderr,"BLOCKED_FETCH(");
 230       printGA(&(stgCast(StgBlockedFetch*,obj)->ga));
 231       printPtr((StgPtr)(stgCast(StgBlockedFetch*,obj)->node));
 232       fprintf(stderr,")\n");
 233       break;
 234
 235     case FETCH_ME:
 236       fprintf(stderr,"FETCH_ME(");
 237       printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
 238       fprintf(stderr,")\n");
 239       break;
 240
 241 #ifdef DIST
 242     case REMOTE_REF:
 243       fprintf(stderr,"REMOTE_REF(");
 244       printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
 245       fprintf(stderr,")\n");
 246       break;
 247 #endif
 248
 249     case FETCH_ME_BQ:
 250       fprintf(stderr,"FETCH_ME_BQ(");
 251       // printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
 252       printPtr((StgPtr)stgCast(StgFetchMeBlockingQueue*,obj)->blocking_queue);
 253       fprintf(stderr,")\n");
 254       break;
 255 #endif
 256 #if defined(GRAN) || defined(PAR)
 257     case RBH:
 258       fprintf(stderr,"RBH(");
 259       printPtr((StgPtr)stgCast(StgRBH*,obj)->blocking_queue);
 260       fprintf(stderr,")\n");
 261       break;
 262
 263 #endif
 264
 265     case CONSTR:
 266     case CONSTR_1_0: case CONSTR_0_1:
 267     case CONSTR_1_1: case CONSTR_0_2: case CONSTR_2_0:
 268     case CONSTR_INTLIKE:
 269     case CONSTR_CHARLIKE:
 270     case CONSTR_STATIC:
 271     case CONSTR_NOCAF_STATIC:
 272         {
 273             /* We can't use printStdObject because we want to print the
 274              * tag as well.
 275              */
 276             StgWord i, j;
 277 #ifdef PROFILING
 278             fprintf(stderr,"%s(", info->prof.closure_desc);
 279             fprintf(stderr,"%s", obj->header.prof.ccs->cc->label);
 280 #else
 281             fprintf(stderr,"CONSTR(");
 282             printPtr((StgPtr)obj->header.info);
 283             fprintf(stderr,"(tag=%d)",info->srt_len);
 284 #endif
 285             for (i = 0; i < info->layout.payload.ptrs; ++i) {
 286                 fprintf(stderr,", ");
 287                 printPtr((StgPtr)obj->payload[i]);
 288             }
 289             for (j = 0; j < info->layout.payload.nptrs; ++j) {
 290                 fprintf(stderr,", %p#", obj->payload[i+j]);
 291             }
 292             fprintf(stderr,")\n");
 293             break;
 294         }
 295
 296 #ifdef XMLAMBDA
 297 /* rows are mutarrays in xmlambda, maybe we should make a new type: ROW */
 298     case MUT_ARR_PTRS_FROZEN:
 299           {
 300             StgWord i;
 301             StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,obj);
 302
 303             fprintf(stderr,"Row<%i>(",p->ptrs);
 304             for (i = 0; i < p->ptrs; ++i) {
 305                 if (i > 0) fprintf(stderr,", ");
 306                 printPtr((StgPtr)(p->payload[i]));
 307             }
 308             fprintf(stderr,")\n");
 309             break;
 310           }
 311 #endif
 312
 313     case FUN:
 314     case FUN_1_0: case FUN_0_1:
 315     case FUN_1_1: case FUN_0_2: case FUN_2_0:
 316     case FUN_STATIC:
 317         fprintf(stderr,"FUN/%d(",itbl_to_fun_itbl(info)->arity);
 318         printPtr((StgPtr)obj->header.info);
 319 #ifdef PROFILING
 320         fprintf(stderr,", %s", obj->header.prof.ccs->cc->label);
 321 #endif
 322         printStdObjPayload(obj);
 323         break;
 324
 325     case THUNK:
 326     case THUNK_1_0: case THUNK_0_1:
 327     case THUNK_1_1: case THUNK_0_2: case THUNK_2_0:
 328     case THUNK_STATIC:
 329             /* ToDo: will this work for THUNK_STATIC too? */
 330 #ifdef PROFILING
 331             printStdObject(obj,info->prof.closure_desc);
 332 #else
 333             printStdObject(obj,"THUNK");
 334 #endif
 335             break;
 336
 337     case THUNK_SELECTOR:
 338         printStdObjHdr(obj, "THUNK_SELECTOR");
 339         fprintf(stderr, ", %p)\n", ((StgSelector *)obj)->selectee);
 340         break;
 341
 342     case MUT_ARR_PTRS:
 343         fprintf(stderr,"MUT_ARR_PTRS(size=%d)\n", ((StgMutArrPtrs *)obj)->ptrs);
 344         break;
 345     case MUT_ARR_PTRS_FROZEN:
 346         fprintf(stderr,"MUT_ARR_PTRS_FROZEN(size=%d)\n", ((StgMutArrPtrs *)obj)->ptrs);
 347         break;
 348
 349     case ARR_WORDS:
 350         {
 351             StgWord i;
 352             fprintf(stderr,"ARR_WORDS(\"");
 353             /* ToDo: we can't safely assume that this is a string!
 354             for (i = 0; arrWordsGetChar(obj,i); ++i) {
 355                 putchar(arrWordsGetChar(obj,i));
 356                 } */
 357             for (i=0; i<((StgArrWords *)obj)->words; i++)
 358               fprintf(stderr, "%u", ((StgArrWords *)obj)->payload[i]);
 359             fprintf(stderr,"\")\n");
 360             break;
 361         }
 362
 363     case UPDATE_FRAME:
 364         {
 365             StgUpdateFrame* u = stgCast(StgUpdateFrame*,obj);
 366             fprintf(stderr,"UPDATE_FRAME(");
 367             printPtr((StgPtr)GET_INFO(u));
 368             fprintf(stderr,",");
 369             printPtr((StgPtr)u->updatee);
 370             fprintf(stderr,")\n");
 371             break;
 372         }
 373
 374     case CATCH_FRAME:
 375         {
 376             StgCatchFrame* u = stgCast(StgCatchFrame*,obj);
 377             fprintf(stderr,"CATCH_FRAME(");
 378             printPtr((StgPtr)GET_INFO(u));
 379             fprintf(stderr,",");
 380             printPtr((StgPtr)u->handler);
 381             fprintf(stderr,")\n");
 382             break;
 383         }
 384
 385     case STOP_FRAME:
 386         {
 387             StgStopFrame* u = stgCast(StgStopFrame*,obj);
 388             fprintf(stderr,"STOP_FRAME(");
 389             printPtr((StgPtr)GET_INFO(u));
 390             fprintf(stderr,")\n");
 391             break;
 392         }
 393     default:
 394             //barf("printClosure %d",get_itbl(obj)->type);
 395             fprintf(stderr, "*** printClosure: unknown type %d ****\n",
 396                     get_itbl(obj)->type );
 397             barf("printClosure %d",get_itbl(obj)->type);
 398             return;
 399     }
 400 }
 401
 402 /*
 403 void printGraph( StgClosure *obj )
 404 {
 405  printClosure(obj);
 406 }
 407 */
 408
 409 StgPtr
 410 printStackObj( StgPtr sp )
 411 {
 412     /*fprintf(stderr,"Stack[%d] = ", &stgStack[STACK_SIZE] - sp); */
 413
 414         StgClosure* c = (StgClosure*)(*sp);
 415         printPtr((StgPtr)*sp);
 416         if (c == (StgClosure*)&stg_ctoi_ret_R1p_info) {
 417            fprintf(stderr, "\t\t\tstg_ctoi_ret_R1p_info\n" );
 418         } else
 419         if (c == (StgClosure*)&stg_ctoi_ret_R1n_info) {
 420            fprintf(stderr, "\t\t\tstg_ctoi_ret_R1n_info\n" );
 421         } else
 422         if (c == (StgClosure*)&stg_ctoi_ret_F1_info) {
 423            fprintf(stderr, "\t\t\tstg_ctoi_ret_F1_info\n" );
 424         } else
 425         if (c == (StgClosure*)&stg_ctoi_ret_D1_info) {
 426            fprintf(stderr, "\t\t\tstg_ctoi_ret_D1_info\n" );
 427         } else
 428         if (c == (StgClosure*)&stg_ctoi_ret_V_info) {
 429            fprintf(stderr, "\t\t\tstg_ctoi_ret_V_info\n" );
 430         } else
 431         if (get_itbl(c)->type == BCO) {
 432            fprintf(stderr, "\t\t\t");
 433            fprintf(stderr, "BCO(...)\n");
 434         }
 435         else {
 436            fprintf(stderr, "\t\t\t");
 437            printClosure ( (StgClosure*)(*sp));
 438         }
 439         sp += 1;
 440
 441     return sp;
 442
 443 }
 444
 445 static void
 446 printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap, nat size )
 447 {
 448     StgPtr p;
 449     nat i;
 450
 451     p = payload;
 452     for(i = 0; i < size; i++, bitmap >>= 1 ) {
 453         fprintf(stderr,"   stk[%d] (%p) = ", spBottom-(payload+i), payload+i);
 454         if ((bitmap & 1) == 0) {
 455             printPtr((P_)payload[i]);
 456             fprintf(stderr,"\n");
 457         } else {
 458             fprintf(stderr,"Word# %d\n", payload[i]);
 459         }
 460     }
 461 }
 462
 463 static void
 464 printLargeBitmap( StgPtr spBottom, StgPtr payload, StgLargeBitmap* large_bitmap, nat size )
 465 {
 466     StgWord bmp;
 467     nat i, j;
 468
 469     i = 0;
 470     for (bmp=0; i < size; bmp++) {
 471         StgWord bitmap = large_bitmap->bitmap[bmp];
 472         j = 0;
 473         for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) {
 474             fprintf(stderr,"   stk[%d] (%p) = ", spBottom-(payload+i), payload+i);
 475             if ((bitmap & 1) == 0) {
 476                 printPtr((P_)payload[i]);
 477                 fprintf(stderr,"\n");
 478             } else {
 479                 fprintf(stderr,"Word# %d\n", payload[i]);
 480             }
 481         }
 482     }
 483 }
 484
 485 void
 486 printStackChunk( StgPtr sp, StgPtr spBottom )
 487 {
 488     StgWord bitmap;
 489     const StgInfoTable *info;
 490
 491     ASSERT(sp <= spBottom);
 492     for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) {
 493
 494         info = get_itbl((StgClosure *)sp);
 495
 496         switch (info->type) {
 497
 498         case UPDATE_FRAME:
 499         case CATCH_FRAME:
 500         case STOP_FRAME:
 501             printObj((StgClosure*)sp);
 502             continue;
 503
 504         case RET_DYN:
 505         {
 506             StgRetDyn* r;
 507             StgPtr p;
 508             StgWord dyn;
 509             nat size;
 510
 511             r = (StgRetDyn *)sp;
 512             dyn = r->liveness;
 513             fprintf(stderr, "RET_DYN (%p)\n", r);
 514
 515             p = (P_)(r->payload);
 516             printSmallBitmap(spBottom, sp,
 517                              GET_LIVENESS(r->liveness), RET_DYN_SIZE);
 518             p += RET_DYN_SIZE;
 519
 520             for (size = GET_NONPTRS(dyn); size > 0; size--) {
 521                 fprintf(stderr,"   stk[%ld] (%p) = ", spBottom-p, p);
 522                 fprintf(stderr,"Word# %ld\n", *p);
 523                 p++;
 524             }
 525
 526             for (size = GET_PTRS(dyn); size > 0; size--) {
 527                 fprintf(stderr,"   stk[%ld] (%p) = ", spBottom-p, p);
 528                 printPtr(p);
 529                 p++;
 530             }
 531             continue;
 532         }
 533
 534         case RET_SMALL:
 535         case RET_VEC_SMALL:
 536             fprintf(stderr, "RET_SMALL (%p)\n", sp);
 537             bitmap = info->layout.bitmap;
 538             printSmallBitmap(spBottom, sp+1,
 539                              BITMAP_BITS(bitmap), BITMAP_SIZE(bitmap));
 540             continue;
 541
 542         case RET_BCO: {
 543             StgBCO *bco;
 544
 545             bco = ((StgBCO *)sp[1]);
 546
 547             fprintf(stderr, "RET_BCO (%p)\n", sp);
 548             printLargeBitmap(spBottom, sp+2,
 549                              BCO_BITMAP(bco), BCO_BITMAP_SIZE(bco));
 550             continue;
 551         }
 552
 553         case RET_BIG:
 554         case RET_VEC_BIG:
 555             barf("todo");
 556
 557         default:
 558             barf("printStackChunk");
 559         }
 560     }
 561 }
 562
 563 void printTSO( StgTSO *tso )
 564 {
 565     printStackChunk( tso->sp, tso->stack+tso->stack_size);
 566 }
 567
 568 /* -----------------------------------------------------------------------------
 569    Closure types
 570
 571    NOTE: must be kept in sync with the closure types in includes/ClosureTypes.h
 572    -------------------------------------------------------------------------- */
 573
 574 static char *closure_type_names[] = {
 575     "INVALID_OBJECT",
 576     "CONSTR",
 577     "CONSTR_1",
 578     "CONSTR_0",
 579     "CONSTR_2",
 580     "CONSTR_1",
 581     "CONSTR_0",
 582     "CONSTR_INTLIKE",
 583     "CONSTR_CHARLIKE",
 584     "CONSTR_STATIC",
 585     "CONSTR_NOCAF_STATIC",
 586     "FUN",
 587     "FUN_1_0",
 588     "FUN_0_1",
 589     "FUN_2_0",
 590     "FUN_1_1",
 591     "FUN_0",
 592     "FUN_STATIC",
 593     "THUNK",
 594     "THUNK_1_0",
 595     "THUNK_0_1",
 596     "THUNK_2_0",
 597     "THUNK_1_1",
 598     "THUNK_0",
 599     "THUNK_STATIC",
 600     "THUNK_SELECTOR",
 601     "BCO",
 602     "AP_UPD",
 603     "PAP",
 604     "IND",
 605     "IND_OLDGEN",
 606     "IND_PERM",
 607     "IND_OLDGEN_PERM",
 608     "IND_STATIC",
 609     "RET_BCO",
 610     "RET_SMALL",
 611     "RET_VEC_SMALL",
 612     "RET_BIG",
 613     "RET_VEC_BIG",
 614     "RET_DYN",
 615     "RET_FUN",
 616     "UPDATE_FRAME",
 617     "CATCH_FRAME",
 618     "STOP_FRAME",
 619     "CAF_BLACKHOLE",
 620     "BLACKHOLE",
 621     "BLACKHOLE_BQ",
 622     "SE_BLACKHOLE",
 623     "SE_CAF_BLACKHOLE",
 624     "MVAR",
 625     "ARR_WORDS",
 626     "MUT_ARR_PTRS",
 627     "MUT_ARR_PTRS_FROZEN",
 628     "MUT_VAR",
 629     "MUT_CONS",
 630     "WEAK",
 631     "FOREIGN",
 632     "STABLE_NAME",
 633     "TSO",
 634     "BLOCKED_FETCH",
 635     "FETCH_ME",
 636     "FETCH_ME_BQ",
 637     "RBH",
 638     "EVACUATED",
 639     "REMOTE_REF"
 640 };
 641
 642
 643 char *
 644 info_type(StgClosure *closure){
 645   return closure_type_names[get_itbl(closure)->type];
 646 }
 647
 648 char *
 649 info_type_by_ip(StgInfoTable *ip){
 650   return closure_type_names[ip->type];
 651 }
 652
 653 void
 654 info_hdr_type(StgClosure *closure, char *res){
 655   strcpy(res,closure_type_names[get_itbl(closure)->type]);
 656 }
 657
 658 /* --------------------------------------------------------------------------
 659  * Address printing code
 660  *
 661  * Uses symbol table in (unstripped executable)
 662  * ------------------------------------------------------------------------*/
 663
 664 /* --------------------------------------------------------------------------
 665  * Simple lookup table
 666  *
 667  * Current implementation is pretty dumb!
 668  * ------------------------------------------------------------------------*/
 669
 670 struct entry {
 671     nat value;
 672     const char *name;
 673 };
 674
 675 static nat max_table_size;
 676 static nat table_size;
 677 static struct entry* table;
 678
 679 static void reset_table( int size )
 680 {
 681     max_table_size = size;
 682     table_size = 0;
 683     table = (struct entry *) malloc(size * sizeof(struct entry));
 684 }
 685
 686 static void prepare_table( void )
 687 {
 688     /* Could sort it...  */
 689 }
 690
 691 static void insert( unsigned value, const char *name )
 692 {
 693     if ( table_size >= max_table_size ) {
 694         barf( "Symbol table overflow\n" );
 695     }
 696     table[table_size].value = value;
 697     table[table_size].name = name;
 698     table_size = table_size + 1;
 699 }
 700
 701
 702 #if 0
 703 static rtsBool lookup_name( char *name, unsigned *result )
 704 {
 705     int i;
 706     for( i = 0; i < table_size && strcmp(name,table[i].name) != 0; ++i ) {
 707     }
 708     if (i < table_size) {
 709         *result = table[i].value;
 710         return rtsTrue;
 711     } else {
 712         return rtsFalse;
 713     }
 714 }
 715 #endif
 716
 717 /* Code from somewhere inside GHC (circa 1994)
 718  * * Z-escapes:
 719  *     "std"++xs -> "Zstd"++xs
 720  *     char_to_c 'Z'  = "ZZ"
 721  *     char_to_c '&'  = "Za"
 722  *     char_to_c '|'  = "Zb"
 723  *     char_to_c ':'  = "Zc"
 724  *     char_to_c '/'  = "Zd"
 725  *     char_to_c '='  = "Ze"
 726  *     char_to_c '>'  = "Zg"
 727  *     char_to_c '#'  = "Zh"
 728  *     char_to_c '<'  = "Zl"
 729  *     char_to_c '-'  = "Zm"
 730  *     char_to_c '!'  = "Zn"
 731  *     char_to_c '.'  = "Zo"
 732  *     char_to_c '+'  = "Zp"
 733  *     char_to_c '\'' = "Zq"
 734  *     char_to_c '*'  = "Zt"
 735  *     char_to_c '_'  = "Zu"
 736  *     char_to_c c    = "Z" ++ show (ord c)
 737  */
 738 static char unZcode( char ch )
 739 {
 740     switch (ch) {
 741     case 'a'  : return ('&');
 742     case 'b'  : return ('|');
 743     case 'c'  : return (':');
 744     case 'd'  : return ('/');
 745     case 'e'  : return ('=');
 746     case 'g'  : return ('>');
 747     case 'h'  : return ('#');
 748     case 'l'  : return ('<');
 749     case 'm'  : return ('-');
 750     case 'n'  : return ('!');
 751     case 'o'  : return ('.');
 752     case 'p'  : return ('+');
 753     case 'q'  : return ('\'');
 754     case 't'  : return ('*');
 755     case 'u'  : return ('_');
 756     case 'Z'  :
 757     case '\0' : return ('Z');
 758     default   : return (ch);
 759     }
 760 }
 761
 762 #if 0
 763 /* Precondition: out big enough to handle output (about twice length of in) */
 764 static void enZcode( char *in, char *out )
 765 {
 766     int i, j;
 767
 768     j = 0;
 769     out[ j++ ] = '_';
 770     for( i = 0; in[i] != '\0'; ++i ) {
 771         switch (in[i]) {
 772         case 'Z'  :
 773                 out[j++] = 'Z';
 774                 out[j++] = 'Z';
 775                 break;
 776         case '&'  :
 777                 out[j++] = 'Z';
 778                 out[j++] = 'a';
 779                 break;
 780         case '|'  :
 781                 out[j++] = 'Z';
 782                 out[j++] = 'b';
 783                 break;
 784         case ':'  :
 785                 out[j++] = 'Z';
 786                 out[j++] = 'c';
 787                 break;
 788         case '/'  :
 789                 out[j++] = 'Z';
 790                 out[j++] = 'd';
 791                 break;
 792         case '='  :
 793                 out[j++] = 'Z';
 794                 out[j++] = 'e';
 795                 break;
 796         case '>'  :
 797                 out[j++] = 'Z';
 798                 out[j++] = 'g';
 799                 break;
 800         case '#'  :
 801                 out[j++] = 'Z';
 802                 out[j++] = 'h';
 803                 break;
 804         case '<'  :
 805                 out[j++] = 'Z';
 806                 out[j++] = 'l';
 807                 break;
 808         case '-'  :
 809                 out[j++] = 'Z';
 810                 out[j++] = 'm';
 811                 break;
 812         case '!'  :
 813                 out[j++] = 'Z';
 814                 out[j++] = 'n';
 815                 break;
 816         case '.'  :
 817                 out[j++] = 'Z';
 818                 out[j++] = 'o';
 819                 break;
 820         case '+'  :
 821                 out[j++] = 'Z';
 822                 out[j++] = 'p';
 823                 break;
 824         case '\'' :
 825                 out[j++] = 'Z';
 826                 out[j++] = 'q';
 827                 break;
 828         case '*'  :
 829                 out[j++] = 'Z';
 830                 out[j++] = 't';
 831                 break;
 832         case '_'  :
 833                 out[j++] = 'Z';
 834                 out[j++] = 'u';
 835                 break;
 836         default :
 837                 out[j++] = in[i];
 838                 break;
 839         }
 840     }
 841     out[j] = '\0';
 842 }
 843 #endif
 844
 845 const char *lookupGHCName( void *addr )
 846 {
 847     nat i;
 848     for( i = 0; i < table_size && table[i].value != (unsigned) addr; ++i ) {
 849     }
 850     if (i < table_size) {
 851         return table[i].name;
 852     } else {
 853         return NULL;
 854     }
 855 }
 856
 857 static void printZcoded( const char *raw )
 858 {
 859     nat j = 0;
 860
 861     while ( raw[j] != '\0' ) {
 862         if (raw[j] == 'Z') {
 863             fputc(unZcode(raw[j+1]),stderr);
 864             j = j + 2;
 865         } else {
 866             fputc(raw[j],stderr);
 867             j = j + 1;
 868         }
 869     }
 870 }
 871
 872 /* --------------------------------------------------------------------------
 873  * Symbol table loading
 874  * ------------------------------------------------------------------------*/
 875
 876 /* Causing linking trouble on Win32 plats, so I'm
 877    disabling this for now.
 878 */
 879 #ifdef USING_LIBBFD
 880
 881 #include <bfd.h>
 882
 883 /* Fairly ad-hoc piece of code that seems to filter out a lot of
 884  * rubbish like the obj-splitting symbols
 885  */
 886
 887 static rtsBool isReal( flagword flags STG_UNUSED, const char *name )
 888 {
 889 #if 0
 890     /* ToDo: make this work on BFD */
 891     int tp = type & N_TYPE;
 892     if (tp == N_TEXT || tp == N_DATA) {
 893         return (name[0] == '_' && name[1] != '_');
 894     } else {
 895         return rtsFalse;
 896     }
 897 #else
 898     if (*name == '\0'  ||
 899         (name[0] == 'g' && name[1] == 'c' && name[2] == 'c') ||
 900         (name[0] == 'c' && name[1] == 'c' && name[2] == '.')) {
 901         return rtsFalse;
 902     }
 903     return rtsTrue;
 904 #endif
 905 }
 906
 907 extern void DEBUG_LoadSymbols( char *name )
 908 {
 909     bfd* abfd;
 910     char **matching;
 911
 912     bfd_init();
 913     abfd = bfd_openr(name, "default");
 914     if (abfd == NULL) {
 915         barf("can't open executable %s to get symbol table", name);
 916     }
 917     if (!bfd_check_format_matches (abfd, bfd_object, &matching)) {
 918         barf("mismatch");
 919     }
 920
 921     {
 922         long storage_needed;
 923         asymbol **symbol_table;
 924         long number_of_symbols;
 925         long num_real_syms = 0;
 926         long i;
 927
 928         storage_needed = bfd_get_symtab_upper_bound (abfd);
 929
 930         if (storage_needed < 0) {
 931             barf("can't read symbol table");
 932         }
 933 #if 0
 934         if (storage_needed == 0) {
 935             belch("no storage needed");
 936         }
 937 #endif
 938         symbol_table = (asymbol **) stgMallocBytes(storage_needed,"DEBUG_LoadSymbols");
 939
 940         number_of_symbols = bfd_canonicalize_symtab (abfd, symbol_table);
 941
 942         if (number_of_symbols < 0) {
 943             barf("can't canonicalise symbol table");
 944         }
 945
 946         for( i = 0; i != number_of_symbols; ++i ) {
 947             symbol_info info;
 948             bfd_get_symbol_info(abfd,symbol_table[i],&info);
 949             /*fprintf(stderr,"\t%c\t0x%x      \t%s\n",info.type,(nat)info.value,info.name); */
 950             if (isReal(info.type, info.name)) {
 951                 num_real_syms += 1;
 952             }
 953         }
 954
 955         IF_DEBUG(interpreter,
 956                  fprintf(stderr,"Loaded %ld symbols. Of which %ld are real symbols\n",
 957                          number_of_symbols, num_real_syms)
 958                  );
 959
 960         reset_table( num_real_syms );
 961
 962         for( i = 0; i != number_of_symbols; ++i ) {
 963             symbol_info info;
 964             bfd_get_symbol_info(abfd,symbol_table[i],&info);
 965             if (isReal(info.type, info.name)) {
 966                 insert( info.value, info.name );
 967             }
 968         }
 969
 970         free(symbol_table);
 971     }
 972     prepare_table();
 973 }
 974
 975 #else /* HAVE_BFD_H */
 976
 977 extern void DEBUG_LoadSymbols( char *name STG_UNUSED )
 978 {
 979   /* nothing, yet */
 980 }
 981
 982 #endif /* HAVE_BFD_H */
 983
 984 #include "StoragePriv.h"
 985
 986 void findPtr(P_ p, int);                /* keep gcc -Wall happy */
 987
 988 void
 989 findPtr(P_ p, int follow)
 990 {
 991   nat s, g;
 992   P_ q, r;
 993   bdescr *bd;
 994   const int arr_size = 1024;
 995   StgPtr arr[arr_size];
 996   int i = 0;
 997
 998   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 999       for (s = 0; s < generations[g].n_steps; s++) {
1000           if (RtsFlags.GcFlags.generations == 1) {
1001               bd = generations[g].steps[s].to_blocks;
1002           } else {
1003               bd = generations[g].steps[s].blocks;
1004           }
1005           for (; bd; bd = bd->link) {
1006               for (q = bd->start; q < bd->free; q++) {
1007                   if (*q == (W_)p) {
1008                       if (i < arr_size) {
1009                           r = q;
1010                           while (!LOOKS_LIKE_INFO_PTR(*r) || (P_)*r == NULL) {
1011                               r--;
1012                           }
1013                           fprintf(stderr, "%p = ", r);
1014                           printClosure((StgClosure *)r);
1015                           arr[i++] = r;
1016                       } else {
1017                           return;
1018                       }
1019                   }
1020               }
1021           }
1022       }
1023   }
1024   if (follow && i == 1) {
1025       fprintf(stderr, "-->\n");
1026       findPtr(arr[0], 1);
1027   }
1028 }
1029
1030 #else /* DEBUG */
1031 void printPtr( StgPtr p )
1032 {
1033     fprintf(stderr, "ptr 0x%p (enable -DDEBUG for more info) " , p );
1034 }
1035
1036 void printObj( StgClosure *obj )
1037 {
1038     fprintf(stderr, "obj 0x%p (enable -DDEBUG for more info) " , obj );
1039 }
1040 #endif /* DEBUG */