rts/Printer.c

   1 /* -----------------------------------------------------------------------------
   2  *
   3  * (c) The GHC Team, 1994-2000.
   4  *
   5  * Heap printer
   6  *
   7  * ---------------------------------------------------------------------------*/
   8
   9 #include "PosixSource.h"
  10 #include "Rts.h"
  11 #include "rts/Bytecodes.h"  /* for InstrPtr */
  12
  13 #include "Printer.h"
  14 #include "RtsUtils.h"
  15
  16 #ifdef DEBUG
  17
  18 #include "Disassembler.h"
  19 #include "Apply.h"
  20
  21 #include <string.h>
  22
  23 /* --------------------------------------------------------------------------
  24  * local function decls
  25  * ------------------------------------------------------------------------*/
  26
  27 static void    printStdObjPayload( StgClosure *obj );
  28 #ifdef USING_LIBBFD
  29 static void    reset_table   ( int size );
  30 static void    prepare_table ( void );
  31 static void    insert        ( StgWord value, const char *name );
  32 #endif
  33 #if 0 /* unused but might be useful sometime */
  34 static rtsBool lookup_name   ( char *name, StgWord *result );
  35 static void    enZcode       ( char *in, char *out );
  36 #endif
  37 static char    unZcode       ( char ch );
  38 static void    printZcoded   ( const char *raw );
  39
  40 /* --------------------------------------------------------------------------
  41  * Printer
  42  * ------------------------------------------------------------------------*/
  43
  44 void printPtr( StgPtr p )
  45 {
  46     const char *raw;
  47     raw = lookupGHCName(p);
  48     if (raw != NULL) {
  49         printZcoded(raw);
  50     } else {
  51         debugBelch("%p", p);
  52     }
  53 }
  54
  55 void printObj( StgClosure *obj )
  56 {
  57     debugBelch("Object "); printPtr((StgPtr)obj); debugBelch(" = ");
  58     printClosure(obj);
  59 }
  60
  61 STATIC_INLINE void
  62 printStdObjHdr( StgClosure *obj, char* tag )
  63 {
  64     debugBelch("%s(",tag);
  65     printPtr((StgPtr)obj->header.info);
  66 #ifdef PROFILING
  67     debugBelch(", %s", obj->header.prof.ccs->cc->label);
  68 #endif
  69 }
  70
  71 static void
  72 printStdObjPayload( StgClosure *obj )
  73 {
  74     StgWord i, j;
  75     const StgInfoTable* info;
  76
  77     info = get_itbl(obj);
  78     for (i = 0; i < info->layout.payload.ptrs; ++i) {
  79         debugBelch(", ");
  80         printPtr((StgPtr)obj->payload[i]);
  81     }
  82     for (j = 0; j < info->layout.payload.nptrs; ++j) {
  83         debugBelch(", %pd#",obj->payload[i+j]);
  84     }
  85     debugBelch(")\n");
  86 }
  87
  88 static void
  89 printThunkPayload( StgThunk *obj )
  90 {
  91     StgWord i, j;
  92     const StgInfoTable* info;
  93
  94     info = get_itbl(obj);
  95     for (i = 0; i < info->layout.payload.ptrs; ++i) {
  96         debugBelch(", ");
  97         printPtr((StgPtr)obj->payload[i]);
  98     }
  99     for (j = 0; j < info->layout.payload.nptrs; ++j) {
 100         debugBelch(", %pd#",obj->payload[i+j]);
 101     }
 102     debugBelch(")\n");
 103 }
 104
 105 static void
 106 printThunkObject( StgThunk *obj, char* tag )
 107 {
 108     printStdObjHdr( (StgClosure *)obj, tag );
 109     printThunkPayload( obj );
 110 }
 111
 112 void
 113 printClosure( StgClosure *obj )
 114 {
 115     obj = UNTAG_CLOSURE(obj);
 116
 117     StgInfoTable *info;
 118     info = get_itbl(obj);
 119
 120     switch ( info->type ) {
 121     case INVALID_OBJECT:
 122             barf("Invalid object");
 123
 124     case CONSTR:
 125     case CONSTR_1_0: case CONSTR_0_1:
 126     case CONSTR_1_1: case CONSTR_0_2: case CONSTR_2_0:
 127     case CONSTR_STATIC:
 128     case CONSTR_NOCAF_STATIC:
 129         {
 130             StgWord i, j;
 131
 132 #ifdef PROFILING
 133             debugBelch("%s(", GET_PROF_DESC(info));
 134             debugBelch("%s", obj->header.prof.ccs->cc->label);
 135 #else
 136             debugBelch("CONSTR(");
 137             printPtr((StgPtr)obj->header.info);
 138             debugBelch("(tag=%d)",info->srt_bitmap);
 139 #endif
 140             for (i = 0; i < info->layout.payload.ptrs; ++i) {
 141                 debugBelch(", ");
 142                 printPtr((StgPtr)obj->payload[i]);
 143             }
 144             for (j = 0; j < info->layout.payload.nptrs; ++j) {
 145                 debugBelch(", %p#", obj->payload[i+j]);
 146             }
 147             debugBelch(")\n");
 148             break;
 149         }
 150
 151     case FUN:
 152     case FUN_1_0: case FUN_0_1:
 153     case FUN_1_1: case FUN_0_2: case FUN_2_0:
 154     case FUN_STATIC:
 155         debugBelch("FUN/%d(",itbl_to_fun_itbl(info)->f.arity);
 156         printPtr((StgPtr)obj->header.info);
 157 #ifdef PROFILING
 158         debugBelch(", %s", obj->header.prof.ccs->cc->label);
 159 #endif
 160         printStdObjPayload(obj);
 161         break;
 162
 163     case THUNK:
 164     case THUNK_1_0: case THUNK_0_1:
 165     case THUNK_1_1: case THUNK_0_2: case THUNK_2_0:
 166     case THUNK_STATIC:
 167             /* ToDo: will this work for THUNK_STATIC too? */
 168 #ifdef PROFILING
 169             printThunkObject((StgThunk *)obj,GET_PROF_DESC(info));
 170 #else
 171             printThunkObject((StgThunk *)obj,"THUNK");
 172 #endif
 173             break;
 174
 175     case THUNK_SELECTOR:
 176         printStdObjHdr(obj, "THUNK_SELECTOR");
 177         debugBelch(", %p)\n", ((StgSelector *)obj)->selectee);
 178         break;
 179
 180     case BCO:
 181             disassemble( (StgBCO*)obj );
 182             break;
 183
 184     case AP:
 185         {
 186             StgAP* ap = (StgAP*)obj;
 187             StgWord i;
 188             debugBelch("AP("); printPtr((StgPtr)ap->fun);
 189             for (i = 0; i < ap->n_args; ++i) {
 190                 debugBelch(", ");
 191                 printPtr((P_)ap->payload[i]);
 192             }
 193             debugBelch(")\n");
 194             break;
 195         }
 196
 197     case PAP:
 198         {
 199             StgPAP* pap = (StgPAP*)obj;
 200             StgWord i;
 201             debugBelch("PAP/%d(",pap->arity);
 202             printPtr((StgPtr)pap->fun);
 203             for (i = 0; i < pap->n_args; ++i) {
 204                 debugBelch(", ");
 205                 printPtr((StgPtr)pap->payload[i]);
 206             }
 207             debugBelch(")\n");
 208             break;
 209         }
 210
 211     case AP_STACK:
 212         {
 213             StgAP_STACK* ap = (StgAP_STACK*)obj;
 214             StgWord i;
 215             debugBelch("AP_STACK("); printPtr((StgPtr)ap->fun);
 216             for (i = 0; i < ap->size; ++i) {
 217                 debugBelch(", ");
 218                 printPtr((P_)ap->payload[i]);
 219             }
 220             debugBelch(")\n");
 221             break;
 222         }
 223
 224     case IND:
 225             debugBelch("IND(");
 226             printPtr((StgPtr)((StgInd*)obj)->indirectee);
 227             debugBelch(")\n");
 228             break;
 229
 230     case IND_OLDGEN:
 231             debugBelch("IND_OLDGEN(");
 232             printPtr((StgPtr)((StgInd*)obj)->indirectee);
 233             debugBelch(")\n");
 234             break;
 235
 236     case IND_PERM:
 237             debugBelch("IND(");
 238             printPtr((StgPtr)((StgInd*)obj)->indirectee);
 239             debugBelch(")\n");
 240             break;
 241
 242     case IND_OLDGEN_PERM:
 243             debugBelch("IND_OLDGEN_PERM(");
 244             printPtr((StgPtr)((StgInd*)obj)->indirectee);
 245             debugBelch(")\n");
 246             break;
 247
 248     case IND_STATIC:
 249             debugBelch("IND_STATIC(");
 250             printPtr((StgPtr)((StgInd*)obj)->indirectee);
 251             debugBelch(")\n");
 252             break;
 253
 254     /* Cannot happen -- use default case.
 255     case RET_BCO:
 256     case RET_SMALL:
 257     case RET_BIG:
 258     case RET_DYN:
 259     case RET_FUN:
 260     */
 261
 262     case UPDATE_FRAME:
 263         {
 264             StgUpdateFrame* u = (StgUpdateFrame*)obj;
 265             debugBelch("UPDATE_FRAME(");
 266             printPtr((StgPtr)GET_INFO(u));
 267             debugBelch(",");
 268             printPtr((StgPtr)u->updatee);
 269             debugBelch(")\n");
 270             break;
 271         }
 272
 273     case CATCH_FRAME:
 274         {
 275             StgCatchFrame* u = (StgCatchFrame*)obj;
 276             debugBelch("CATCH_FRAME(");
 277             printPtr((StgPtr)GET_INFO(u));
 278             debugBelch(",");
 279             printPtr((StgPtr)u->handler);
 280             debugBelch(")\n");
 281             break;
 282         }
 283
 284     case STOP_FRAME:
 285         {
 286             StgStopFrame* u = (StgStopFrame*)obj;
 287             debugBelch("STOP_FRAME(");
 288             printPtr((StgPtr)GET_INFO(u));
 289             debugBelch(")\n");
 290             break;
 291         }
 292
 293     case CAF_BLACKHOLE:
 294             debugBelch("CAF_BH");
 295             break;
 296
 297     case BLACKHOLE:
 298             debugBelch("BH\n");
 299             break;
 300
 301     case ARR_WORDS:
 302         {
 303             StgWord i;
 304             debugBelch("ARR_WORDS(\"");
 305             /* ToDo: we can't safely assume that this is a string!
 306             for (i = 0; arrWordsGetChar(obj,i); ++i) {
 307                 putchar(arrWordsGetChar(obj,i));
 308                 } */
 309             for (i=0; i<((StgArrWords *)obj)->words; i++)
 310               debugBelch("%lu", (lnat)((StgArrWords *)obj)->payload[i]);
 311             debugBelch("\")\n");
 312             break;
 313         }
 314
 315     case MUT_ARR_PTRS_CLEAN:
 316         debugBelch("MUT_ARR_PTRS_CLEAN(size=%lu)\n", (lnat)((StgMutArrPtrs *)obj)->ptrs);
 317         break;
 318
 319     case MUT_ARR_PTRS_DIRTY:
 320         debugBelch("MUT_ARR_PTRS_DIRTY(size=%lu)\n", (lnat)((StgMutArrPtrs *)obj)->ptrs);
 321         break;
 322
 323     case MUT_ARR_PTRS_FROZEN:
 324         debugBelch("MUT_ARR_PTRS_FROZEN(size=%lu)\n", (lnat)((StgMutArrPtrs *)obj)->ptrs);
 325         break;
 326
 327     case MVAR_CLEAN:
 328     case MVAR_DIRTY:
 329         {
 330           StgMVar* mv = (StgMVar*)obj;
 331           debugBelch("MVAR(head=%p, tail=%p, value=%p)\n", mv->head, mv->tail, mv->value);
 332           break;
 333         }
 334
 335     case MUT_VAR_CLEAN:
 336         {
 337           StgMutVar* mv = (StgMutVar*)obj;
 338           debugBelch("MUT_VAR_CLEAN(var=%p)\n", mv->var);
 339           break;
 340         }
 341
 342     case MUT_VAR_DIRTY:
 343         {
 344           StgMutVar* mv = (StgMutVar*)obj;
 345           debugBelch("MUT_VAR_DIRTY(var=%p)\n", mv->var);
 346           break;
 347         }
 348
 349     case WEAK:
 350             debugBelch("WEAK(");
 351             debugBelch(" key=%p value=%p finalizer=%p",
 352                     (StgPtr)(((StgWeak*)obj)->key),
 353                     (StgPtr)(((StgWeak*)obj)->value),
 354                     (StgPtr)(((StgWeak*)obj)->finalizer));
 355             debugBelch(")\n");
 356             /* ToDo: chase 'link' ? */
 357             break;
 358
 359     case STABLE_NAME:
 360             debugBelch("STABLE_NAME(%lu)\n", (lnat)((StgStableName*)obj)->sn);
 361             break;
 362
 363     case TSO:
 364       debugBelch("TSO(");
 365       debugBelch("%lu (%p)",(unsigned long)(((StgTSO*)obj)->id), (StgTSO*)obj);
 366       debugBelch(")\n");
 367       break;
 368
 369 #if 0
 370       /* Symptomatic of a problem elsewhere, have it fall-through & fail */
 371     case EVACUATED:
 372       debugBelch("EVACUATED(");
 373       printClosure((StgEvacuated*)obj->evacuee);
 374       debugBelch(")\n");
 375       break;
 376 #endif
 377
 378     default:
 379             //barf("printClosure %d",get_itbl(obj)->type);
 380             debugBelch("*** printClosure: unknown type %d ****\n",
 381                     get_itbl(obj)->type );
 382             barf("printClosure %d",get_itbl(obj)->type);
 383             return;
 384     }
 385 }
 386
 387 /*
 388 void printGraph( StgClosure *obj )
 389 {
 390  printClosure(obj);
 391 }
 392 */
 393
 394 StgPtr
 395 printStackObj( StgPtr sp )
 396 {
 397     /*debugBelch("Stack[%d] = ", &stgStack[STACK_SIZE] - sp); */
 398
 399         StgClosure* c = (StgClosure*)(*sp);
 400         printPtr((StgPtr)*sp);
 401         if (c == (StgClosure*)&stg_ctoi_R1p_info) {
 402            debugBelch("\t\t\tstg_ctoi_ret_R1p_info\n" );
 403         } else
 404         if (c == (StgClosure*)&stg_ctoi_R1n_info) {
 405            debugBelch("\t\t\tstg_ctoi_ret_R1n_info\n" );
 406         } else
 407         if (c == (StgClosure*)&stg_ctoi_F1_info) {
 408            debugBelch("\t\t\tstg_ctoi_ret_F1_info\n" );
 409         } else
 410         if (c == (StgClosure*)&stg_ctoi_D1_info) {
 411            debugBelch("\t\t\tstg_ctoi_ret_D1_info\n" );
 412         } else
 413         if (c == (StgClosure*)&stg_ctoi_V_info) {
 414            debugBelch("\t\t\tstg_ctoi_ret_V_info\n" );
 415         } else
 416         if (get_itbl(c)->type == BCO) {
 417            debugBelch("\t\t\t");
 418            debugBelch("BCO(...)\n");
 419         }
 420         else {
 421            debugBelch("\t\t\t");
 422            printClosure ( (StgClosure*)(*sp));
 423         }
 424         sp += 1;
 425
 426     return sp;
 427
 428 }
 429
 430 static void
 431 printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap, nat size )
 432 {
 433     StgPtr p;
 434     nat i;
 435
 436     p = payload;
 437     for(i = 0; i < size; i++, bitmap >>= 1 ) {
 438         debugBelch("   stk[%ld] (%p) = ", (long)(spBottom-(payload+i)), payload+i);
 439         if ((bitmap & 1) == 0) {
 440             printPtr((P_)payload[i]);
 441             debugBelch("\n");
 442         } else {
 443             debugBelch("Word# %lu\n", (lnat)payload[i]);
 444         }
 445     }
 446 }
 447
 448 static void
 449 printLargeBitmap( StgPtr spBottom, StgPtr payload, StgLargeBitmap* large_bitmap, nat size )
 450 {
 451     StgWord bmp;
 452     nat i, j;
 453
 454     i = 0;
 455     for (bmp=0; i < size; bmp++) {
 456         StgWord bitmap = large_bitmap->bitmap[bmp];
 457         j = 0;
 458         for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) {
 459             debugBelch("   stk[%lu] (%p) = ", (lnat)(spBottom-(payload+i)), payload+i);
 460             if ((bitmap & 1) == 0) {
 461                 printPtr((P_)payload[i]);
 462                 debugBelch("\n");
 463             } else {
 464                 debugBelch("Word# %lu\n", (lnat)payload[i]);
 465             }
 466         }
 467     }
 468 }
 469
 470 void
 471 printStackChunk( StgPtr sp, StgPtr spBottom )
 472 {
 473     StgWord bitmap;
 474     const StgInfoTable *info;
 475
 476     ASSERT(sp <= spBottom);
 477     for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) {
 478
 479         info = get_itbl((StgClosure *)sp);
 480
 481         switch (info->type) {
 482
 483         case UPDATE_FRAME:
 484         case CATCH_FRAME:
 485             printObj((StgClosure*)sp);
 486             continue;
 487
 488         case STOP_FRAME:
 489             printObj((StgClosure*)sp);
 490             return;
 491
 492         case RET_DYN:
 493         {
 494             StgRetDyn* r;
 495             StgPtr p;
 496             StgWord dyn;
 497             nat size;
 498
 499             r = (StgRetDyn *)sp;
 500             dyn = r->liveness;
 501             debugBelch("RET_DYN (%p)\n", r);
 502
 503             p = (P_)(r->payload);
 504             printSmallBitmap(spBottom, sp,
 505                              RET_DYN_LIVENESS(r->liveness),
 506                              RET_DYN_BITMAP_SIZE);
 507             p += RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE;
 508
 509             for (size = RET_DYN_NONPTRS(dyn); size > 0; size--) {
 510                 debugBelch("   stk[%ld] (%p) = ", (long)(spBottom-p), p);
 511                 debugBelch("Word# %ld\n", (long)*p);
 512                 p++;
 513             }
 514
 515             for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
 516                 debugBelch("   stk[%ld] (%p) = ", (long)(spBottom-p), p);
 517                 printPtr(p);
 518                 p++;
 519             }
 520             continue;
 521         }
 522
 523         case RET_SMALL:
 524             debugBelch("RET_SMALL (%p)\n", info);
 525             bitmap = info->layout.bitmap;
 526             printSmallBitmap(spBottom, sp+1,
 527                              BITMAP_BITS(bitmap), BITMAP_SIZE(bitmap));
 528             continue;
 529
 530         case RET_BCO: {
 531             StgBCO *bco;
 532
 533             bco = ((StgBCO *)sp[1]);
 534
 535             debugBelch("RET_BCO (%p)\n", sp);
 536             printLargeBitmap(spBottom, sp+2,
 537                              BCO_BITMAP(bco), BCO_BITMAP_SIZE(bco));
 538             continue;
 539         }
 540
 541         case RET_BIG:
 542             barf("todo");
 543
 544         case RET_FUN:
 545         {
 546             StgFunInfoTable *fun_info;
 547             StgRetFun *ret_fun;
 548             nat size;
 549
 550             ret_fun = (StgRetFun *)sp;
 551             fun_info = get_fun_itbl(ret_fun->fun);
 552             size = ret_fun->size;
 553             debugBelch("RET_FUN (%p) (type=%d)\n", ret_fun->fun, fun_info->f.fun_type);
 554             switch (fun_info->f.fun_type) {
 555             case ARG_GEN:
 556                 printSmallBitmap(spBottom, sp+2,
 557                                  BITMAP_BITS(fun_info->f.b.bitmap),
 558                                  BITMAP_SIZE(fun_info->f.b.bitmap));
 559                 break;
 560             case ARG_GEN_BIG:
 561                 printLargeBitmap(spBottom, sp+2,
 562                                  GET_FUN_LARGE_BITMAP(fun_info),
 563                                  GET_FUN_LARGE_BITMAP(fun_info)->size);
 564                 break;
 565             default:
 566                 printSmallBitmap(spBottom, sp+2,
 567                                  BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
 568                                  BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]));
 569                 break;
 570             }
 571             continue;
 572         }
 573
 574         default:
 575             debugBelch("unknown object %d\n", info->type);
 576             barf("printStackChunk");
 577         }
 578     }
 579 }
 580
 581 void printTSO( StgTSO *tso )
 582 {
 583     printStackChunk( tso->sp, tso->stack+tso->stack_size);
 584 }
 585
 586 /* -----------------------------------------------------------------------------
 587    Closure types
 588
 589    NOTE: must be kept in sync with the closure types in includes/ClosureTypes.h
 590    -------------------------------------------------------------------------- */
 591
 592 static char *closure_type_names[] = {
 593     "INVALID_OBJECT",
 594     "CONSTR",
 595     "CONSTR_1",
 596     "CONSTR_0",
 597     "CONSTR_2",
 598     "CONSTR_1",
 599     "CONSTR_0",
 600     "CONSTR_STATIC",
 601     "CONSTR_NOCAF_STATIC",
 602     "FUN",
 603     "FUN_1_0",
 604     "FUN_0_1",
 605     "FUN_2_0",
 606     "FUN_1_1",
 607     "FUN_0",
 608     "FUN_STATIC",
 609     "THUNK",
 610     "THUNK_1_0",
 611     "THUNK_0_1",
 612     "THUNK_2_0",
 613     "THUNK_1_1",
 614     "THUNK_0",
 615     "THUNK_STATIC",
 616     "THUNK_SELECTOR",
 617     "BCO",
 618     "AP_UPD",
 619     "PAP",
 620     "AP_STACK",
 621     "IND",
 622     "IND_OLDGEN",
 623     "IND_PERM",
 624     "IND_OLDGEN_PERM",
 625     "IND_STATIC",
 626     "RET_BCO",
 627     "RET_SMALL",
 628     "RET_BIG",
 629     "RET_DYN",
 630     "RET_FUN",
 631     "UPDATE_FRAME",
 632     "CATCH_FRAME",
 633     "STOP_FRAME",
 634     "CAF_BLACKHOLE",
 635     "BLACKHOLE",
 636     "BLACKHOLE_BQ",
 637     "SE_BLACKHOLE",
 638     "SE_CAF_BLACKHOLE",
 639     "MVAR",
 640     "ARR_WORDS",
 641     "MUT_ARR_PTRS_CLEAN",
 642     "MUT_ARR_PTRS_DIRTY",
 643     "MUT_ARR_PTRS_FROZEN",
 644     "MUT_VAR_CLEAN",
 645     "MUT_VAR_DIRTY",
 646     "MUT_CONS",
 647     "WEAK",
 648     "FOREIGN",
 649     "STABLE_NAME",
 650     "TSO",
 651     "BLOCKED_FETCH",
 652     "FETCH_ME",
 653     "FETCH_ME_BQ",
 654     "RBH",
 655     "EVACUATED",
 656     "REMOTE_REF",
 657     "TVAR_WATCH_QUEUE",
 658     "INVARIANT_CHECK_QUEUE",
 659     "ATOMIC_INVARIANT",
 660     "TVAR",
 661     "TREC_CHUNK",
 662     "TREC_HEADER",
 663     "ATOMICALLY_FRAME",
 664     "CATCH_RETRY_FRAME"
 665 };
 666
 667
 668 char *
 669 info_type(StgClosure *closure){
 670   return closure_type_names[get_itbl(closure)->type];
 671 }
 672
 673 char *
 674 info_type_by_ip(StgInfoTable *ip){
 675   return closure_type_names[ip->type];
 676 }
 677
 678 void
 679 info_hdr_type(StgClosure *closure, char *res){
 680   strcpy(res,closure_type_names[get_itbl(closure)->type]);
 681 }
 682
 683 /* --------------------------------------------------------------------------
 684  * Address printing code
 685  *
 686  * Uses symbol table in (unstripped executable)
 687  * ------------------------------------------------------------------------*/
 688
 689 /* --------------------------------------------------------------------------
 690  * Simple lookup table
 691  *
 692  * Current implementation is pretty dumb!
 693  * ------------------------------------------------------------------------*/
 694
 695 struct entry {
 696     StgWord value;
 697     const char *name;
 698 };
 699
 700 static nat table_size;
 701 static struct entry* table;
 702
 703 #ifdef USING_LIBBFD
 704 static nat max_table_size;
 705
 706 static void reset_table( int size )
 707 {
 708     max_table_size = size;
 709     table_size = 0;
 710     table = (struct entry *)stgMallocBytes(size * sizeof(struct entry), "Printer.c:reset_table()");
 711 }
 712
 713 static void prepare_table( void )
 714 {
 715     /* Could sort it...  */
 716 }
 717
 718 static void insert( StgWord value, const char *name )
 719 {
 720     if ( table_size >= max_table_size ) {
 721         barf( "Symbol table overflow\n" );
 722     }
 723     table[table_size].value = value;
 724     table[table_size].name = name;
 725     table_size = table_size + 1;
 726 }
 727 #endif
 728
 729 #if 0
 730 static rtsBool lookup_name( char *name, StgWord *result )
 731 {
 732     nat i;
 733     for( i = 0; i < table_size && strcmp(name,table[i].name) != 0; ++i ) {
 734     }
 735     if (i < table_size) {
 736         *result = table[i].value;
 737         return rtsTrue;
 738     } else {
 739         return rtsFalse;
 740     }
 741 }
 742 #endif
 743
 744 /* Code from somewhere inside GHC (circa 1994)
 745  * * Z-escapes:
 746  *     "std"++xs -> "Zstd"++xs
 747  *     char_to_c 'Z'  = "ZZ"
 748  *     char_to_c '&'  = "Za"
 749  *     char_to_c '|'  = "Zb"
 750  *     char_to_c ':'  = "Zc"
 751  *     char_to_c '/'  = "Zd"
 752  *     char_to_c '='  = "Ze"
 753  *     char_to_c '>'  = "Zg"
 754  *     char_to_c '#'  = "Zh"
 755  *     char_to_c '<'  = "Zl"
 756  *     char_to_c '-'  = "Zm"
 757  *     char_to_c '!'  = "Zn"
 758  *     char_to_c '.'  = "Zo"
 759  *     char_to_c '+'  = "Zp"
 760  *     char_to_c '\'' = "Zq"
 761  *     char_to_c '*'  = "Zt"
 762  *     char_to_c '_'  = "Zu"
 763  *     char_to_c c    = "Z" ++ show (ord c)
 764  */
 765 static char unZcode( char ch )
 766 {
 767     switch (ch) {
 768     case 'a'  : return ('&');
 769     case 'b'  : return ('|');
 770     case 'c'  : return (':');
 771     case 'd'  : return ('/');
 772     case 'e'  : return ('=');
 773     case 'g'  : return ('>');
 774     case 'h'  : return ('#');
 775     case 'l'  : return ('<');
 776     case 'm'  : return ('-');
 777     case 'n'  : return ('!');
 778     case 'o'  : return ('.');
 779     case 'p'  : return ('+');
 780     case 'q'  : return ('\'');
 781     case 't'  : return ('*');
 782     case 'u'  : return ('_');
 783     case 'Z'  :
 784     case '\0' : return ('Z');
 785     default   : return (ch);
 786     }
 787 }
 788
 789 #if 0
 790 /* Precondition: out big enough to handle output (about twice length of in) */
 791 static void enZcode( char *in, char *out )
 792 {
 793     int i, j;
 794
 795     j = 0;
 796     out[ j++ ] = '_';
 797     for( i = 0; in[i] != '\0'; ++i ) {
 798         switch (in[i]) {
 799         case 'Z'  :
 800                 out[j++] = 'Z';
 801                 out[j++] = 'Z';
 802                 break;
 803         case '&'  :
 804                 out[j++] = 'Z';
 805                 out[j++] = 'a';
 806                 break;
 807         case '|'  :
 808                 out[j++] = 'Z';
 809                 out[j++] = 'b';
 810                 break;
 811         case ':'  :
 812                 out[j++] = 'Z';
 813                 out[j++] = 'c';
 814                 break;
 815         case '/'  :
 816                 out[j++] = 'Z';
 817                 out[j++] = 'd';
 818                 break;
 819         case '='  :
 820                 out[j++] = 'Z';
 821                 out[j++] = 'e';
 822                 break;
 823         case '>'  :
 824                 out[j++] = 'Z';
 825                 out[j++] = 'g';
 826                 break;
 827         case '#'  :
 828                 out[j++] = 'Z';
 829                 out[j++] = 'h';
 830                 break;
 831         case '<'  :
 832                 out[j++] = 'Z';
 833                 out[j++] = 'l';
 834                 break;
 835         case '-'  :
 836                 out[j++] = 'Z';
 837                 out[j++] = 'm';
 838                 break;
 839         case '!'  :
 840                 out[j++] = 'Z';
 841                 out[j++] = 'n';
 842                 break;
 843         case '.'  :
 844                 out[j++] = 'Z';
 845                 out[j++] = 'o';
 846                 break;
 847         case '+'  :
 848                 out[j++] = 'Z';
 849                 out[j++] = 'p';
 850                 break;
 851         case '\'' :
 852                 out[j++] = 'Z';
 853                 out[j++] = 'q';
 854                 break;
 855         case '*'  :
 856                 out[j++] = 'Z';
 857                 out[j++] = 't';
 858                 break;
 859         case '_'  :
 860                 out[j++] = 'Z';
 861                 out[j++] = 'u';
 862                 break;
 863         default :
 864                 out[j++] = in[i];
 865                 break;
 866         }
 867     }
 868     out[j] = '\0';
 869 }
 870 #endif
 871
 872 const char *lookupGHCName( void *addr )
 873 {
 874     nat i;
 875     for( i = 0; i < table_size && table[i].value != (StgWord) addr; ++i ) {
 876     }
 877     if (i < table_size) {
 878         return table[i].name;
 879     } else {
 880         return NULL;
 881     }
 882 }
 883
 884 static void printZcoded( const char *raw )
 885 {
 886     nat j = 0;
 887
 888     while ( raw[j] != '\0' ) {
 889         if (raw[j] == 'Z') {
 890             debugBelch("%c", unZcode(raw[j+1]));
 891             j = j + 2;
 892         } else {
 893             debugBelch("%c", unZcode(raw[j+1]));
 894             j = j + 1;
 895         }
 896     }
 897 }
 898
 899 /* --------------------------------------------------------------------------
 900  * Symbol table loading
 901  * ------------------------------------------------------------------------*/
 902
 903 /* Causing linking trouble on Win32 plats, so I'm
 904    disabling this for now.
 905 */
 906 #ifdef USING_LIBBFD
 907
 908 #include <bfd.h>
 909
 910 /* Fairly ad-hoc piece of code that seems to filter out a lot of
 911  * rubbish like the obj-splitting symbols
 912  */
 913
 914 static rtsBool isReal( flagword flags STG_UNUSED, const char *name )
 915 {
 916 #if 0
 917     /* ToDo: make this work on BFD */
 918     int tp = type & N_TYPE;
 919     if (tp == N_TEXT || tp == N_DATA) {
 920         return (name[0] == '_' && name[1] != '_');
 921     } else {
 922         return rtsFalse;
 923     }
 924 #else
 925     if (*name == '\0'  ||
 926         (name[0] == 'g' && name[1] == 'c' && name[2] == 'c') ||
 927         (name[0] == 'c' && name[1] == 'c' && name[2] == '.')) {
 928         return rtsFalse;
 929     }
 930     return rtsTrue;
 931 #endif
 932 }
 933
 934 extern void DEBUG_LoadSymbols( char *name )
 935 {
 936     bfd* abfd;
 937     char **matching;
 938
 939     bfd_init();
 940     abfd = bfd_openr(name, "default");
 941     if (abfd == NULL) {
 942         barf("can't open executable %s to get symbol table", name);
 943     }
 944     if (!bfd_check_format_matches (abfd, bfd_object, &matching)) {
 945         barf("mismatch");
 946     }
 947
 948     {
 949         long storage_needed;
 950         asymbol **symbol_table;
 951         long number_of_symbols;
 952         long num_real_syms = 0;
 953         long i;
 954
 955         storage_needed = bfd_get_symtab_upper_bound (abfd);
 956
 957         if (storage_needed < 0) {
 958             barf("can't read symbol table");
 959         }
 960 #if 0
 961         if (storage_needed == 0) {
 962             debugBelch("no storage needed");
 963         }
 964 #endif
 965         symbol_table = (asymbol **) stgMallocBytes(storage_needed,"DEBUG_LoadSymbols");
 966
 967         number_of_symbols = bfd_canonicalize_symtab (abfd, symbol_table);
 968
 969         if (number_of_symbols < 0) {
 970             barf("can't canonicalise symbol table");
 971         }
 972
 973         for( i = 0; i != number_of_symbols; ++i ) {
 974             symbol_info info;
 975             bfd_get_symbol_info(abfd,symbol_table[i],&info);
 976             /*debugBelch("\t%c\t0x%x      \t%s\n",info.type,(nat)info.value,info.name); */
 977             if (isReal(info.type, info.name)) {
 978                 num_real_syms += 1;
 979             }
 980         }
 981
 982         IF_DEBUG(interpreter,
 983                  debugBelch("Loaded %ld symbols. Of which %ld are real symbols\n",
 984                          number_of_symbols, num_real_syms)
 985                  );
 986
 987         reset_table( num_real_syms );
 988
 989         for( i = 0; i != number_of_symbols; ++i ) {
 990             symbol_info info;
 991             bfd_get_symbol_info(abfd,symbol_table[i],&info);
 992             if (isReal(info.type, info.name)) {
 993                 insert( info.value, info.name );
 994             }
 995         }
 996
 997         stgFree(symbol_table);
 998     }
 999     prepare_table();
1000 }
1001
1002 #else /* HAVE_BFD_H */
1003
1004 extern void DEBUG_LoadSymbols( char *name STG_UNUSED )
1005 {
1006   /* nothing, yet */
1007 }
1008
1009 #endif /* HAVE_BFD_H */
1010
1011 void findPtr(P_ p, int);                /* keep gcc -Wall happy */
1012
1013 int searched = 0;
1014
1015 static int
1016 findPtrBlocks (StgPtr p, bdescr *bd, StgPtr arr[], int arr_size, int i)
1017 {
1018     StgPtr q, r;
1019     for (; bd; bd = bd->link) {
1020         searched++;
1021         for (q = bd->start; q < bd->free; q++) {
1022             if (UNTAG_CLOSURE((StgClosure*)*q) == (StgClosure *)p) {
1023                 if (i < arr_size) {
1024                     r = q;
1025                     while (HEAP_ALLOCED((StgPtr)*r) || !LOOKS_LIKE_INFO_PTR(*r) || (P_)*r == NULL) {
1026                         r--;
1027                     }
1028                     debugBelch("%p = ", r);
1029                     printClosure((StgClosure *)r);
1030                     arr[i++] = r;
1031                 } else {
1032                     return i;
1033                 }
1034             }
1035         }
1036     }
1037     return i;
1038 }
1039
1040 void
1041 findPtr(P_ p, int follow)
1042 {
1043   nat s, g;
1044   bdescr *bd;
1045 #if defined(__GNUC__)
1046   const int arr_size = 1024;
1047 #else
1048 #define arr_size 1024
1049 #endif
1050   StgPtr arr[arr_size];
1051   int i = 0;
1052   searched = 0;
1053
1054   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1055       for (s = 0; s < generations[g].n_steps; s++) {
1056           bd = generations[g].steps[s].blocks;
1057           i = findPtrBlocks(p,bd,arr,arr_size,i);
1058           bd = generations[g].steps[s].large_objects;
1059           i = findPtrBlocks(p,bd,arr,arr_size,i);
1060           if (i >= arr_size) return;
1061       }
1062   }
1063   if (follow && i == 1) {
1064       debugBelch("-->\n");
1065       findPtr(arr[0], 1);
1066   }
1067 }
1068
1069 /* prettyPrintClosure() is for printing out a closure using the data constructor
1070    names found in the info tables. Closures are printed in a fashion that resembles
1071    their Haskell representation. Useful during debugging.
1072
1073    Todo: support for more closure types, and support for non pointer fields in the
1074    payload.
1075 */
1076
1077 void prettyPrintClosure_ (StgClosure *);
1078
1079 void prettyPrintClosure (StgClosure *obj)
1080 {
1081    prettyPrintClosure_ (obj);
1082    debugBelch ("\n");
1083 }
1084
1085 void prettyPrintClosure_ (StgClosure *obj)
1086 {
1087     StgInfoTable *info;
1088     StgConInfoTable *con_info;
1089
1090     /* collapse any indirections */
1091     unsigned int type;
1092     type = get_itbl(obj)->type;
1093
1094     while (type == IND ||
1095            type == IND_STATIC ||
1096            type == IND_OLDGEN ||
1097            type == IND_PERM ||
1098            type == IND_OLDGEN_PERM)
1099     {
1100       obj = ((StgInd *)obj)->indirectee;
1101       type = get_itbl(obj)->type;
1102     }
1103
1104     /* find the info table for this object */
1105     info = get_itbl(obj);
1106
1107     /* determine what kind of object we have */
1108     switch (info->type)
1109     {
1110         /* full applications of data constructors */
1111         case CONSTR:
1112         case CONSTR_1_0:
1113         case CONSTR_0_1:
1114         case CONSTR_1_1:
1115         case CONSTR_0_2:
1116         case CONSTR_2_0:
1117         case CONSTR_STATIC:
1118         case CONSTR_NOCAF_STATIC:
1119         {
1120            nat i;
1121            char *descriptor;
1122
1123            /* find the con_info for the constructor */
1124            con_info = get_con_itbl (obj);
1125
1126            /* obtain the name of the constructor */
1127            descriptor = GET_CON_DESC(con_info);
1128
1129            debugBelch ("(%s", descriptor);
1130
1131            /* process the payload of the closure */
1132            /* we don't handle non pointers at the moment */
1133            for (i = 0; i < info->layout.payload.ptrs; i++)
1134            {
1135               debugBelch (" ");
1136               prettyPrintClosure_ ((StgClosure *) obj->payload[i]);
1137            }
1138            debugBelch (")");
1139            break;
1140         }
1141
1142         /* if it isn't a constructor then just print the closure type */
1143         default:
1144         {
1145            debugBelch ("<%s>", info_type(obj));
1146            break;
1147         }
1148     }
1149 }
1150
1151 #else /* DEBUG */
1152 void printPtr( StgPtr p )
1153 {
1154     debugBelch("ptr 0x%p (enable -DDEBUG for more info) " , p );
1155 }
1156
1157 void printObj( StgClosure *obj )
1158 {
1159     debugBelch("obj 0x%p (enable -DDEBUG for more info) " , obj );
1160 }
1161
1162
1163 #endif /* DEBUG */