ghc/rts/Printer.c

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