ghc/rts/Printer.c

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