ghc/rts/Printer.c

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