ghc/rts/Printer.c

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