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