ghc/rts/Printer.c

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