ghc/rts/Printer.c

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