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