1 /* -----------------------------------------------------------------------------
3 * (c) The GHC Team, 1994-2000.
7 * ---------------------------------------------------------------------------*/
9 #include "PosixSource.h"
19 #include "Bytecodes.h" /* for InstrPtr */
20 #include "Disassembler.h"
26 #if defined(GRAN) || defined(PAR)
27 // HWL: explicit fixed header size to make debugging easier
28 int fixed_hs = sizeof(StgHeader), itbl_sz = sizeofW(StgInfoTable),
29 uf_sz=sizeofW(StgUpdateFrame);
32 /* --------------------------------------------------------------------------
33 * local function decls
34 * ------------------------------------------------------------------------*/
36 static void printStdObject( StgClosure *obj, char* tag );
37 static void printStdObjPayload( StgClosure *obj );
39 static void reset_table ( int size );
40 static void prepare_table ( void );
41 static void insert ( unsigned value, const char *name );
43 #if 0 /* unused but might be useful sometime */
44 static rtsBool lookup_name ( char *name, unsigned *result );
45 static void enZcode ( char *in, char *out );
47 static char unZcode ( char ch );
48 const char * lookupGHCName ( void *addr );
49 static void printZcoded ( const char *raw );
51 /* --------------------------------------------------------------------------
53 * ------------------------------------------------------------------------*/
55 void printPtr( StgPtr p )
58 raw = lookupGHCName(p);
66 void printObj( StgClosure *obj )
68 debugBelch("Object "); printPtr((StgPtr)obj); debugBelch(" = ");
73 printStdObjHdr( StgClosure *obj, char* tag )
75 debugBelch("%s(",tag);
76 printPtr((StgPtr)obj->header.info);
78 debugBelch(", %s", obj->header.prof.ccs->cc->label);
83 printStdObjPayload( StgClosure *obj )
86 const StgInfoTable* info;
89 for (i = 0; i < info->layout.payload.ptrs; ++i) {
91 printPtr((StgPtr)obj->payload[i]);
93 for (j = 0; j < info->layout.payload.nptrs; ++j) {
94 debugBelch(", %pd#",obj->payload[i+j]);
100 printThunkPayload( StgThunk *obj )
103 const StgInfoTable* info;
105 info = get_itbl(obj);
106 for (i = 0; i < info->layout.payload.ptrs; ++i) {
108 printPtr((StgPtr)obj->payload[i]);
110 for (j = 0; j < info->layout.payload.nptrs; ++j) {
111 debugBelch(", %pd#",obj->payload[i+j]);
117 printStdObject( StgClosure *obj, char* tag )
119 printStdObjHdr( obj, tag );
120 printStdObjPayload( obj );
124 printThunkObject( StgThunk *obj, char* tag )
126 printStdObjHdr( (StgClosure *)obj, tag );
127 printThunkPayload( obj );
131 printClosure( StgClosure *obj )
135 info = get_itbl(obj);
137 switch ( info->type ) {
139 barf("Invalid object");
142 case CONSTR_1_0: case CONSTR_0_1:
143 case CONSTR_1_1: case CONSTR_0_2: case CONSTR_2_0:
145 case CONSTR_CHARLIKE:
147 case CONSTR_NOCAF_STATIC:
149 /* We can't use printStdObject because we want to print the
154 debugBelch("%s(", info->prof.closure_desc);
155 debugBelch("%s", obj->header.prof.ccs->cc->label);
157 debugBelch("CONSTR(");
158 printPtr((StgPtr)obj->header.info);
159 debugBelch("(tag=%d)",info->srt_bitmap);
161 for (i = 0; i < info->layout.payload.ptrs; ++i) {
163 printPtr((StgPtr)obj->payload[i]);
165 for (j = 0; j < info->layout.payload.nptrs; ++j) {
166 debugBelch(", %p#", obj->payload[i+j]);
173 case FUN_1_0: case FUN_0_1:
174 case FUN_1_1: case FUN_0_2: case FUN_2_0:
176 debugBelch("FUN/%d(",itbl_to_fun_itbl(info)->f.arity);
177 printPtr((StgPtr)obj->header.info);
179 debugBelch(", %s", obj->header.prof.ccs->cc->label);
181 printStdObjPayload(obj);
185 case THUNK_1_0: case THUNK_0_1:
186 case THUNK_1_1: case THUNK_0_2: case THUNK_2_0:
188 /* ToDo: will this work for THUNK_STATIC too? */
190 printThunkObject((StgThunk *)obj,info->prof.closure_desc);
192 printThunkObject((StgThunk *)obj,"THUNK");
197 printStdObjHdr(obj, "THUNK_SELECTOR");
198 debugBelch(", %p)\n", ((StgSelector *)obj)->selectee);
202 disassemble( (StgBCO*)obj );
207 StgAP* ap = stgCast(StgAP*,obj);
209 debugBelch("AP("); printPtr((StgPtr)ap->fun);
210 for (i = 0; i < ap->n_args; ++i) {
212 printPtr((P_)ap->payload[i]);
220 StgPAP* pap = stgCast(StgPAP*,obj);
222 debugBelch("PAP/%d(",pap->arity);
223 printPtr((StgPtr)pap->fun);
224 for (i = 0; i < pap->n_args; ++i) {
226 printPtr((StgPtr)pap->payload[i]);
234 StgAP_STACK* ap = stgCast(StgAP_STACK*,obj);
236 debugBelch("AP_STACK("); printPtr((StgPtr)ap->fun);
237 for (i = 0; i < ap->size; ++i) {
239 printPtr((P_)ap->payload[i]);
247 printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
252 debugBelch("IND_OLDGEN(");
253 printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
259 printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
263 case IND_OLDGEN_PERM:
264 debugBelch("IND_OLDGEN_PERM(");
265 printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
270 debugBelch("IND_STATIC(");
271 printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
275 /* Cannot happen -- use default case.
287 StgUpdateFrame* u = stgCast(StgUpdateFrame*,obj);
288 debugBelch("UPDATE_FRAME(");
289 printPtr((StgPtr)GET_INFO(u));
291 printPtr((StgPtr)u->updatee);
298 StgCatchFrame* u = stgCast(StgCatchFrame*,obj);
299 debugBelch("CATCH_FRAME(");
300 printPtr((StgPtr)GET_INFO(u));
302 printPtr((StgPtr)u->handler);
309 StgStopFrame* u = stgCast(StgStopFrame*,obj);
310 debugBelch("STOP_FRAME(");
311 printPtr((StgPtr)GET_INFO(u));
317 debugBelch("CAF_BH");
325 debugBelch("SE_BH\n");
328 case SE_CAF_BLACKHOLE:
329 debugBelch("SE_CAF_BH\n");
335 debugBelch("ARR_WORDS(\"");
336 /* ToDo: we can't safely assume that this is a string!
337 for (i = 0; arrWordsGetChar(obj,i); ++i) {
338 putchar(arrWordsGetChar(obj,i));
340 for (i=0; i<((StgArrWords *)obj)->words; i++)
341 debugBelch("%lu", ((StgArrWords *)obj)->payload[i]);
347 debugBelch("MUT_ARR_PTRS(size=%ld)\n", ((StgMutArrPtrs *)obj)->ptrs);
350 case MUT_ARR_PTRS_FROZEN:
351 #if !defined(XMLAMBDA)
352 debugBelch("MUT_ARR_PTRS_FROZEN(size=%ld)\n", ((StgMutArrPtrs *)obj)->ptrs);
356 /* rows are mutarrays in xmlambda, maybe we should make a new type: ROW */
358 StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,obj);
360 debugBelch("Row<%i>(",p->ptrs);
361 for (i = 0; i < p->ptrs; ++i) {
362 if (i > 0) debugBelch(", ");
363 printPtr((StgPtr)(p->payload[i]));
372 StgMVar* mv = (StgMVar*)obj;
373 debugBelch("MVAR(head=%p, tail=%p, value=%p)\n", mv->head, mv->tail, mv->value);
379 StgMutVar* mv = (StgMutVar*)obj;
380 debugBelch("MUT_VAR(var=%p)\n", mv->var);
386 debugBelch(" key=%p value=%p finalizer=%p",
387 (StgPtr)(((StgWeak*)obj)->key),
388 (StgPtr)(((StgWeak*)obj)->value),
389 (StgPtr)(((StgWeak*)obj)->finalizer));
391 /* ToDo: chase 'link' ? */
395 debugBelch("FOREIGN(");
396 printPtr((StgPtr)( ((StgForeignObj*)obj)->data ));
401 debugBelch("STABLE_NAME(%ld)\n", ((StgStableName*)obj)->sn);
406 debugBelch("%d (%p)",((StgTSO*)obj)->id, (StgTSO*)obj);
412 debugBelch("BLOCKED_FETCH(");
413 printGA(&(stgCast(StgBlockedFetch*,obj)->ga));
414 printPtr((StgPtr)(stgCast(StgBlockedFetch*,obj)->node));
419 debugBelch("FETCH_ME(");
420 printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
425 debugBelch("FETCH_ME_BQ(");
426 // printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
427 printPtr((StgPtr)stgCast(StgFetchMeBlockingQueue*,obj)->blocking_queue);
432 #if defined(GRAN) || defined(PAR)
435 printPtr((StgPtr)stgCast(StgRBH*,obj)->blocking_queue);
442 /* Symptomatic of a problem elsewhere, have it fall-through & fail */
444 debugBelch("EVACUATED(");
445 printClosure((StgEvacuated*)obj->evacuee);
450 #if defined(PAR) && defined(DIST)
452 debugBelch("REMOTE_REF(");
453 printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
459 //barf("printClosure %d",get_itbl(obj)->type);
460 debugBelch("*** printClosure: unknown type %d ****\n",
461 get_itbl(obj)->type );
462 barf("printClosure %d",get_itbl(obj)->type);
468 void printGraph( StgClosure *obj )
475 printStackObj( StgPtr sp )
477 /*debugBelch("Stack[%d] = ", &stgStack[STACK_SIZE] - sp); */
479 StgClosure* c = (StgClosure*)(*sp);
480 printPtr((StgPtr)*sp);
481 if (c == (StgClosure*)&stg_ctoi_R1p_info) {
482 debugBelch("\t\t\tstg_ctoi_ret_R1p_info\n" );
484 if (c == (StgClosure*)&stg_ctoi_R1n_info) {
485 debugBelch("\t\t\tstg_ctoi_ret_R1n_info\n" );
487 if (c == (StgClosure*)&stg_ctoi_F1_info) {
488 debugBelch("\t\t\tstg_ctoi_ret_F1_info\n" );
490 if (c == (StgClosure*)&stg_ctoi_D1_info) {
491 debugBelch("\t\t\tstg_ctoi_ret_D1_info\n" );
493 if (c == (StgClosure*)&stg_ctoi_V_info) {
494 debugBelch("\t\t\tstg_ctoi_ret_V_info\n" );
496 if (get_itbl(c)->type == BCO) {
497 debugBelch("\t\t\t");
498 debugBelch("BCO(...)\n");
501 debugBelch("\t\t\t");
502 printClosure ( (StgClosure*)(*sp));
511 printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap, nat size )
517 for(i = 0; i < size; i++, bitmap >>= 1 ) {
518 debugBelch(" stk[%ld] (%p) = ", spBottom-(payload+i), payload+i);
519 if ((bitmap & 1) == 0) {
520 printPtr((P_)payload[i]);
523 debugBelch("Word# %ld\n", payload[i]);
529 printLargeBitmap( StgPtr spBottom, StgPtr payload, StgLargeBitmap* large_bitmap, nat size )
535 for (bmp=0; i < size; bmp++) {
536 StgWord bitmap = large_bitmap->bitmap[bmp];
538 for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) {
539 debugBelch(" stk[%ld] (%p) = ", spBottom-(payload+i), payload+i);
540 if ((bitmap & 1) == 0) {
541 printPtr((P_)payload[i]);
544 debugBelch("Word# %ld\n", payload[i]);
551 printStackChunk( StgPtr sp, StgPtr spBottom )
554 const StgInfoTable *info;
556 ASSERT(sp <= spBottom);
557 for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) {
559 info = get_itbl((StgClosure *)sp);
561 switch (info->type) {
566 printObj((StgClosure*)sp);
578 debugBelch("RET_DYN (%p)\n", r);
580 p = (P_)(r->payload);
581 printSmallBitmap(spBottom, sp,
582 RET_DYN_LIVENESS(r->liveness),
583 RET_DYN_BITMAP_SIZE);
584 p += RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE;
586 for (size = RET_DYN_NONPTRS(dyn); size > 0; size--) {
587 debugBelch(" stk[%ld] (%p) = ", (long)(spBottom-p), p);
588 debugBelch("Word# %ld\n", (long)*p);
592 for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
593 debugBelch(" stk[%ld] (%p) = ", (long)(spBottom-p), p);
602 debugBelch("RET_SMALL (%p)\n", sp);
603 bitmap = info->layout.bitmap;
604 printSmallBitmap(spBottom, sp+1,
605 BITMAP_BITS(bitmap), BITMAP_SIZE(bitmap));
611 bco = ((StgBCO *)sp[1]);
613 debugBelch("RET_BCO (%p)\n", sp);
614 printLargeBitmap(spBottom, sp+2,
615 BCO_BITMAP(bco), BCO_BITMAP_SIZE(bco));
625 StgFunInfoTable *fun_info;
629 ret_fun = (StgRetFun *)sp;
630 fun_info = get_fun_itbl(ret_fun->fun);
631 size = ret_fun->size;
632 debugBelch("RET_FUN (%p) (type=%d)\n", ret_fun, fun_info->f.fun_type);
633 switch (fun_info->f.fun_type) {
635 printSmallBitmap(spBottom, sp+1,
636 BITMAP_BITS(fun_info->f.b.bitmap),
637 BITMAP_SIZE(fun_info->f.b.bitmap));
640 printLargeBitmap(spBottom, sp+2,
641 GET_FUN_LARGE_BITMAP(fun_info),
642 GET_FUN_LARGE_BITMAP(fun_info)->size);
645 printSmallBitmap(spBottom, sp+1,
646 BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
647 BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]));
654 debugBelch("unknown object %d\n", info->type);
655 barf("printStackChunk");
660 void printTSO( StgTSO *tso )
662 printStackChunk( tso->sp, tso->stack+tso->stack_size);
665 /* -----------------------------------------------------------------------------
668 NOTE: must be kept in sync with the closure types in includes/ClosureTypes.h
669 -------------------------------------------------------------------------- */
671 static char *closure_type_names[] = {
682 "CONSTR_NOCAF_STATIC",
725 "MUT_ARR_PTRS_FROZEN",
748 info_type(StgClosure *closure){
749 return closure_type_names[get_itbl(closure)->type];
753 info_type_by_ip(StgInfoTable *ip){
754 return closure_type_names[ip->type];
758 info_hdr_type(StgClosure *closure, char *res){
759 strcpy(res,closure_type_names[get_itbl(closure)->type]);
762 /* --------------------------------------------------------------------------
763 * Address printing code
765 * Uses symbol table in (unstripped executable)
766 * ------------------------------------------------------------------------*/
768 /* --------------------------------------------------------------------------
769 * Simple lookup table
771 * Current implementation is pretty dumb!
772 * ------------------------------------------------------------------------*/
779 static nat table_size;
780 static struct entry* table;
783 static nat max_table_size;
785 static void reset_table( int size )
787 max_table_size = size;
789 table = (struct entry *)stgMallocBytes(size * sizeof(struct entry), "Printer.c:reset_table()");
792 static void prepare_table( void )
794 /* Could sort it... */
797 static void insert( unsigned value, const char *name )
799 if ( table_size >= max_table_size ) {
800 barf( "Symbol table overflow\n" );
802 table[table_size].value = value;
803 table[table_size].name = name;
804 table_size = table_size + 1;
809 static rtsBool lookup_name( char *name, unsigned *result )
812 for( i = 0; i < table_size && strcmp(name,table[i].name) != 0; ++i ) {
814 if (i < table_size) {
815 *result = table[i].value;
823 /* Code from somewhere inside GHC (circa 1994)
825 * "std"++xs -> "Zstd"++xs
826 * char_to_c 'Z' = "ZZ"
827 * char_to_c '&' = "Za"
828 * char_to_c '|' = "Zb"
829 * char_to_c ':' = "Zc"
830 * char_to_c '/' = "Zd"
831 * char_to_c '=' = "Ze"
832 * char_to_c '>' = "Zg"
833 * char_to_c '#' = "Zh"
834 * char_to_c '<' = "Zl"
835 * char_to_c '-' = "Zm"
836 * char_to_c '!' = "Zn"
837 * char_to_c '.' = "Zo"
838 * char_to_c '+' = "Zp"
839 * char_to_c '\'' = "Zq"
840 * char_to_c '*' = "Zt"
841 * char_to_c '_' = "Zu"
842 * char_to_c c = "Z" ++ show (ord c)
844 static char unZcode( char ch )
847 case 'a' : return ('&');
848 case 'b' : return ('|');
849 case 'c' : return (':');
850 case 'd' : return ('/');
851 case 'e' : return ('=');
852 case 'g' : return ('>');
853 case 'h' : return ('#');
854 case 'l' : return ('<');
855 case 'm' : return ('-');
856 case 'n' : return ('!');
857 case 'o' : return ('.');
858 case 'p' : return ('+');
859 case 'q' : return ('\'');
860 case 't' : return ('*');
861 case 'u' : return ('_');
863 case '\0' : return ('Z');
864 default : return (ch);
869 /* Precondition: out big enough to handle output (about twice length of in) */
870 static void enZcode( char *in, char *out )
876 for( i = 0; in[i] != '\0'; ++i ) {
951 const char *lookupGHCName( void *addr )
954 for( i = 0; i < table_size && table[i].value != (unsigned) addr; ++i ) {
956 if (i < table_size) {
957 return table[i].name;
963 static void printZcoded( const char *raw )
967 while ( raw[j] != '\0' ) {
969 debugBelch("%c", unZcode(raw[j+1]));
972 debugBelch("%c", unZcode(raw[j+1]));
978 /* --------------------------------------------------------------------------
979 * Symbol table loading
980 * ------------------------------------------------------------------------*/
982 /* Causing linking trouble on Win32 plats, so I'm
983 disabling this for now.
989 /* Fairly ad-hoc piece of code that seems to filter out a lot of
990 * rubbish like the obj-splitting symbols
993 static rtsBool isReal( flagword flags STG_UNUSED, const char *name )
996 /* ToDo: make this work on BFD */
997 int tp = type & N_TYPE;
998 if (tp == N_TEXT || tp == N_DATA) {
999 return (name[0] == '_' && name[1] != '_');
1004 if (*name == '\0' ||
1005 (name[0] == 'g' && name[1] == 'c' && name[2] == 'c') ||
1006 (name[0] == 'c' && name[1] == 'c' && name[2] == '.')) {
1013 extern void DEBUG_LoadSymbols( char *name )
1019 abfd = bfd_openr(name, "default");
1021 barf("can't open executable %s to get symbol table", name);
1023 if (!bfd_check_format_matches (abfd, bfd_object, &matching)) {
1028 long storage_needed;
1029 asymbol **symbol_table;
1030 long number_of_symbols;
1031 long num_real_syms = 0;
1034 storage_needed = bfd_get_symtab_upper_bound (abfd);
1036 if (storage_needed < 0) {
1037 barf("can't read symbol table");
1040 if (storage_needed == 0) {
1041 debugBelch("no storage needed");
1044 symbol_table = (asymbol **) stgMallocBytes(storage_needed,"DEBUG_LoadSymbols");
1046 number_of_symbols = bfd_canonicalize_symtab (abfd, symbol_table);
1048 if (number_of_symbols < 0) {
1049 barf("can't canonicalise symbol table");
1052 for( i = 0; i != number_of_symbols; ++i ) {
1054 bfd_get_symbol_info(abfd,symbol_table[i],&info);
1055 /*debugBelch("\t%c\t0x%x \t%s\n",info.type,(nat)info.value,info.name); */
1056 if (isReal(info.type, info.name)) {
1061 IF_DEBUG(interpreter,
1062 debugBelch("Loaded %ld symbols. Of which %ld are real symbols\n",
1063 number_of_symbols, num_real_syms)
1066 reset_table( num_real_syms );
1068 for( i = 0; i != number_of_symbols; ++i ) {
1070 bfd_get_symbol_info(abfd,symbol_table[i],&info);
1071 if (isReal(info.type, info.name)) {
1072 insert( info.value, info.name );
1076 stgFree(symbol_table);
1081 #else /* HAVE_BFD_H */
1083 extern void DEBUG_LoadSymbols( char *name STG_UNUSED )
1088 #endif /* HAVE_BFD_H */
1090 void findPtr(P_ p, int); /* keep gcc -Wall happy */
1093 findPtr(P_ p, int follow)
1098 #if defined(__GNUC__)
1099 const int arr_size = 1024;
1101 #define arr_size 1024
1103 StgPtr arr[arr_size];
1106 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1107 for (s = 0; s < generations[g].n_steps; s++) {
1108 if (RtsFlags.GcFlags.generations == 1) {
1109 bd = generations[g].steps[s].to_blocks;
1111 bd = generations[g].steps[s].blocks;
1113 for (; bd; bd = bd->link) {
1114 for (q = bd->start; q < bd->free; q++) {
1118 while (!LOOKS_LIKE_INFO_PTR(*r) || (P_)*r == NULL) {
1121 debugBelch("%p = ", r);
1122 printClosure((StgClosure *)r);
1132 if (follow && i == 1) {
1133 debugBelch("-->\n");
1139 void printPtr( StgPtr p )
1141 debugBelch("ptr 0x%p (enable -DDEBUG for more info) " , p );
1144 void printObj( StgClosure *obj )
1146 debugBelch("obj 0x%p (enable -DDEBUG for more info) " , obj );