ghc/rts/Printer.c

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