Use snwprintf instead of swprintf in rts/Linker.c.
[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 "ghcconfig.h"
11
12 #include "Rts.h"
13 #include "rts/Bytecodes.h" /* for InstrPtr */
14
15 #include "sm/Storage.h"
16 #include "Printer.h"
17 #include "RtsUtils.h"
18
19 #include <string.h>
20
21 #ifdef DEBUG
22
23 #include "Disassembler.h"
24 #include "Apply.h"
25
26 /* --------------------------------------------------------------------------
27 * local function decls
28 * ------------------------------------------------------------------------*/
29
30 static void printStdObjPayload( StgClosure *obj );
31 #ifdef USING_LIBBFD
32 static void reset_table ( int size );
33 static void prepare_table ( void );
34 static void insert ( StgWord value, const char *name );
35 #endif
36 #if 0 /* unused but might be useful sometime */
37 static rtsBool lookup_name ( char *name, StgWord *result );
38 #endif
39
40 /* --------------------------------------------------------------------------
41 * Printer
42 * ------------------------------------------------------------------------*/
43
44 void printPtr( StgPtr p )
45 {
46 const char *raw;
47 raw = lookupGHCName(p);
48 if (raw != NULL) {
49 debugBelch("<%s>", raw);
50 debugBelch("[%p]", p);
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("%s(", info_update_frame(obj));
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 SMALL_MUT_ARR_PTRS_CLEAN:
326 debugBelch("SMALL_MUT_ARR_PTRS_CLEAN(size=%" FMT_Word ")\n",
327 (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
328 break;
329
330 case SMALL_MUT_ARR_PTRS_DIRTY:
331 debugBelch("SMALL_MUT_ARR_PTRS_DIRTY(size=%" FMT_Word ")\n",
332 (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
333 break;
334
335 case SMALL_MUT_ARR_PTRS_FROZEN:
336 debugBelch("SMALL_MUT_ARR_PTRS_FROZEN(size=%" FMT_Word ")\n",
337 (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
338 break;
339
340 case MVAR_CLEAN:
341 case MVAR_DIRTY:
342 {
343 StgMVar* mv = (StgMVar*)obj;
344 debugBelch("MVAR(head=%p, tail=%p, value=%p)\n", mv->head, mv->tail, mv->value);
345 break;
346 }
347
348 case TVAR:
349 {
350 StgTVar* tv = (StgTVar*)obj;
351 debugBelch("TVAR(value=%p, wq=%p, num_updates=%" FMT_Word ")\n", tv->current_value, tv->first_watch_queue_entry, tv->num_updates);
352 break;
353 }
354
355 case MUT_VAR_CLEAN:
356 {
357 StgMutVar* mv = (StgMutVar*)obj;
358 debugBelch("MUT_VAR_CLEAN(var=%p)\n", mv->var);
359 break;
360 }
361
362 case MUT_VAR_DIRTY:
363 {
364 StgMutVar* mv = (StgMutVar*)obj;
365 debugBelch("MUT_VAR_DIRTY(var=%p)\n", mv->var);
366 break;
367 }
368
369 case WEAK:
370 debugBelch("WEAK(");
371 debugBelch(" key=%p value=%p finalizer=%p",
372 (StgPtr)(((StgWeak*)obj)->key),
373 (StgPtr)(((StgWeak*)obj)->value),
374 (StgPtr)(((StgWeak*)obj)->finalizer));
375 debugBelch(")\n");
376 /* ToDo: chase 'link' ? */
377 break;
378
379 case TSO:
380 debugBelch("TSO(");
381 debugBelch("%lu (%p)",(unsigned long)(((StgTSO*)obj)->id), (StgTSO*)obj);
382 debugBelch(")\n");
383 break;
384
385 case STACK:
386 debugBelch("STACK");
387 break;
388
389 #if 0
390 /* Symptomatic of a problem elsewhere, have it fall-through & fail */
391 case EVACUATED:
392 debugBelch("EVACUATED(");
393 printClosure((StgEvacuated*)obj->evacuee);
394 debugBelch(")\n");
395 break;
396 #endif
397
398 default:
399 //barf("printClosure %d",get_itbl(obj)->type);
400 debugBelch("*** printClosure: unknown type %d ****\n",
401 (int)get_itbl(obj)->type );
402 barf("printClosure %d",get_itbl(obj)->type);
403 return;
404 }
405 }
406
407 // If you know you have an UPDATE_FRAME, but want to know exactly which.
408 char *info_update_frame(StgClosure *closure) {
409 // Note: We intentionally don't take the info table pointer as
410 // an argument. As it will be confusing whether one should pass
411 // it pointing to the code or struct members when compiling with
412 // TABLES_NEXT_TO_CODE.
413 const StgInfoTable *info = closure->header.info;
414 if (info == &stg_upd_frame_info) {
415 return "NORMAL_UPDATE_FRAME";
416 } else if (info == &stg_bh_upd_frame_info) {
417 return "BH_UPDATE_FRAME";
418 } else if (info == &stg_marked_upd_frame_info) {
419 return "MARKED_UPDATE_FRAME";
420 } else {
421 return "ERROR: Not an update frame!!!";
422 }
423 }
424
425 /*
426 void printGraph( StgClosure *obj )
427 {
428 printClosure(obj);
429 }
430 */
431
432 StgPtr
433 printStackObj( StgPtr sp )
434 {
435 /*debugBelch("Stack[%d] = ", &stgStack[STACK_SIZE] - sp); */
436
437 StgClosure* c = (StgClosure*)(*sp);
438 printPtr((StgPtr)*sp);
439 if (c == (StgClosure*)&stg_ctoi_R1p_info) {
440 debugBelch("\t\t\tstg_ctoi_ret_R1p_info\n" );
441 } else
442 if (c == (StgClosure*)&stg_ctoi_R1n_info) {
443 debugBelch("\t\t\tstg_ctoi_ret_R1n_info\n" );
444 } else
445 if (c == (StgClosure*)&stg_ctoi_F1_info) {
446 debugBelch("\t\t\tstg_ctoi_ret_F1_info\n" );
447 } else
448 if (c == (StgClosure*)&stg_ctoi_D1_info) {
449 debugBelch("\t\t\tstg_ctoi_ret_D1_info\n" );
450 } else
451 if (c == (StgClosure*)&stg_ctoi_V_info) {
452 debugBelch("\t\t\tstg_ctoi_ret_V_info\n" );
453 } else
454 if (get_itbl(c)->type == BCO) {
455 debugBelch("\t\t\t");
456 debugBelch("BCO(...)\n");
457 }
458 else {
459 debugBelch("\t\t\t");
460 printClosure ( (StgClosure*)(*sp));
461 }
462 sp += 1;
463
464 return sp;
465
466 }
467
468 static void
469 printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap, nat size )
470 {
471 nat i;
472
473 for(i = 0; i < size; i++, bitmap >>= 1 ) {
474 debugBelch(" stk[%ld] (%p) = ", (long)(spBottom-(payload+i)), payload+i);
475 if ((bitmap & 1) == 0) {
476 printPtr((P_)payload[i]);
477 debugBelch("\n");
478 } else {
479 debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]);
480 }
481 }
482 }
483
484 static void
485 printLargeBitmap( StgPtr spBottom, StgPtr payload, StgLargeBitmap* large_bitmap, nat size )
486 {
487 StgWord bmp;
488 nat i, j;
489
490 i = 0;
491 for (bmp=0; i < size; bmp++) {
492 StgWord bitmap = large_bitmap->bitmap[bmp];
493 j = 0;
494 for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) {
495 debugBelch(" stk[%" FMT_Word "] (%p) = ", (W_)(spBottom-(payload+i)), payload+i);
496 if ((bitmap & 1) == 0) {
497 printPtr((P_)payload[i]);
498 debugBelch("\n");
499 } else {
500 debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]);
501 }
502 }
503 }
504 }
505
506 void
507 printStackChunk( StgPtr sp, StgPtr spBottom )
508 {
509 StgWord bitmap;
510 const StgInfoTable *info;
511
512 ASSERT(sp <= spBottom);
513 for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) {
514
515 info = get_itbl((StgClosure *)sp);
516
517 switch (info->type) {
518
519 case UPDATE_FRAME:
520 case CATCH_FRAME:
521 case UNDERFLOW_FRAME:
522 case STOP_FRAME:
523 printObj((StgClosure*)sp);
524 continue;
525
526 case RET_SMALL:
527 debugBelch("RET_SMALL (%p)\n", info);
528 bitmap = info->layout.bitmap;
529 printSmallBitmap(spBottom, sp+1,
530 BITMAP_BITS(bitmap), BITMAP_SIZE(bitmap));
531 continue;
532
533 case RET_BCO: {
534 StgBCO *bco;
535
536 bco = ((StgBCO *)sp[1]);
537
538 debugBelch("RET_BCO (%p)\n", sp);
539 printLargeBitmap(spBottom, sp+2,
540 BCO_BITMAP(bco), BCO_BITMAP_SIZE(bco));
541 continue;
542 }
543
544 case RET_BIG:
545 barf("todo");
546
547 case RET_FUN:
548 {
549 StgFunInfoTable *fun_info;
550 StgRetFun *ret_fun;
551
552 ret_fun = (StgRetFun *)sp;
553 fun_info = get_fun_itbl(ret_fun->fun);
554 debugBelch("RET_FUN (%p) (type=%d)\n", ret_fun->fun, (int)fun_info->f.fun_type);
555 switch (fun_info->f.fun_type) {
556 case ARG_GEN:
557 printSmallBitmap(spBottom, sp+2,
558 BITMAP_BITS(fun_info->f.b.bitmap),
559 BITMAP_SIZE(fun_info->f.b.bitmap));
560 break;
561 case ARG_GEN_BIG:
562 printLargeBitmap(spBottom, sp+2,
563 GET_FUN_LARGE_BITMAP(fun_info),
564 GET_FUN_LARGE_BITMAP(fun_info)->size);
565 break;
566 default:
567 printSmallBitmap(spBottom, sp+2,
568 BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
569 BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]));
570 break;
571 }
572 continue;
573 }
574
575 default:
576 debugBelch("unknown object %d\n", (int)info->type);
577 barf("printStackChunk");
578 }
579 }
580 }
581
582 void printTSO( StgTSO *tso )
583 {
584 printStackChunk( tso->stackobj->sp,
585 tso->stackobj->stack+tso->stackobj->stack_size);
586 }
587
588 /* --------------------------------------------------------------------------
589 * Address printing code
590 *
591 * Uses symbol table in (unstripped executable)
592 * ------------------------------------------------------------------------*/
593
594 /* --------------------------------------------------------------------------
595 * Simple lookup table
596 *
597 * Current implementation is pretty dumb!
598 * ------------------------------------------------------------------------*/
599
600 struct entry {
601 StgWord value;
602 const char *name;
603 };
604
605 static nat table_size;
606 static struct entry* table;
607
608 #ifdef USING_LIBBFD
609 static nat max_table_size;
610
611 static void reset_table( int size )
612 {
613 max_table_size = size;
614 table_size = 0;
615 table = (struct entry *)stgMallocBytes(size * sizeof(struct entry), "Printer.c:reset_table()");
616 }
617
618 static void prepare_table( void )
619 {
620 /* Could sort it... */
621 }
622
623 static void insert( StgWord value, const char *name )
624 {
625 if ( table_size >= max_table_size ) {
626 barf( "Symbol table overflow\n" );
627 }
628 table[table_size].value = value;
629 table[table_size].name = name;
630 table_size = table_size + 1;
631 }
632 #endif
633
634 #if 0
635 static rtsBool lookup_name( char *name, StgWord *result )
636 {
637 nat i;
638 for( i = 0; i < table_size && strcmp(name,table[i].name) != 0; ++i ) {
639 }
640 if (i < table_size) {
641 *result = table[i].value;
642 return rtsTrue;
643 } else {
644 return rtsFalse;
645 }
646 }
647 #endif
648
649 const char *lookupGHCName( void *addr )
650 {
651 nat i;
652 for( i = 0; i < table_size && table[i].value != (StgWord) addr; ++i ) {
653 }
654 if (i < table_size) {
655 return table[i].name;
656 } else {
657 return NULL;
658 }
659 }
660
661 /* --------------------------------------------------------------------------
662 * Symbol table loading
663 * ------------------------------------------------------------------------*/
664
665 /* Causing linking trouble on Win32 plats, so I'm
666 disabling this for now.
667 */
668 #ifdef USING_LIBBFD
669 # define PACKAGE 1
670 # define PACKAGE_VERSION 1
671 /* Those PACKAGE_* defines are workarounds for bfd:
672 * https://sourceware.org/bugzilla/show_bug.cgi?id=14243
673 * ghc's build system filter PACKAGE_* values out specifically to avoid clashes
674 * with user's autoconf-based Cabal packages.
675 * It's a shame <bfd.h> checks for unrelated fields instead of actually used
676 * macros.
677 */
678 # include <bfd.h>
679
680 /* Fairly ad-hoc piece of code that seems to filter out a lot of
681 * rubbish like the obj-splitting symbols
682 */
683
684 static rtsBool isReal( flagword flags STG_UNUSED, const char *name )
685 {
686 #if 0
687 /* ToDo: make this work on BFD */
688 int tp = type & N_TYPE;
689 if (tp == N_TEXT || tp == N_DATA) {
690 return (name[0] == '_' && name[1] != '_');
691 } else {
692 return rtsFalse;
693 }
694 #else
695 if (*name == '\0' ||
696 (name[0] == 'g' && name[1] == 'c' && name[2] == 'c') ||
697 (name[0] == 'c' && name[1] == 'c' && name[2] == '.')) {
698 return rtsFalse;
699 }
700 return rtsTrue;
701 #endif
702 }
703
704 extern void DEBUG_LoadSymbols( char *name )
705 {
706 bfd* abfd;
707 char **matching;
708
709 bfd_init();
710 abfd = bfd_openr(name, "default");
711 if (abfd == NULL) {
712 barf("can't open executable %s to get symbol table", name);
713 }
714 if (!bfd_check_format_matches (abfd, bfd_object, &matching)) {
715 barf("mismatch");
716 }
717
718 {
719 long storage_needed;
720 asymbol **symbol_table;
721 long number_of_symbols;
722 long num_real_syms = 0;
723 long i;
724
725 storage_needed = bfd_get_symtab_upper_bound (abfd);
726
727 if (storage_needed < 0) {
728 barf("can't read symbol table");
729 }
730 #if 0
731 if (storage_needed == 0) {
732 debugBelch("no storage needed");
733 }
734 #endif
735 symbol_table = (asymbol **) stgMallocBytes(storage_needed,"DEBUG_LoadSymbols");
736
737 number_of_symbols = bfd_canonicalize_symtab (abfd, symbol_table);
738
739 if (number_of_symbols < 0) {
740 barf("can't canonicalise symbol table");
741 }
742
743 for( i = 0; i != number_of_symbols; ++i ) {
744 symbol_info info;
745 bfd_get_symbol_info(abfd,symbol_table[i],&info);
746 if (isReal(info.type, info.name)) {
747 num_real_syms += 1;
748 }
749 }
750
751 IF_DEBUG(interpreter,
752 debugBelch("Loaded %ld symbols. Of which %ld are real symbols\n",
753 number_of_symbols, num_real_syms)
754 );
755
756 reset_table( num_real_syms );
757
758 for( i = 0; i != number_of_symbols; ++i ) {
759 symbol_info info;
760 bfd_get_symbol_info(abfd,symbol_table[i],&info);
761 if (isReal(info.type, info.name)) {
762 insert( info.value, info.name );
763 }
764 }
765
766 stgFree(symbol_table);
767 }
768 prepare_table();
769 }
770
771 #else /* USING_LIBBFD */
772
773 extern void DEBUG_LoadSymbols( char *name STG_UNUSED )
774 {
775 /* nothing, yet */
776 }
777
778 #endif /* USING_LIBBFD */
779
780 void findPtr(P_ p, int); /* keep gcc -Wall happy */
781
782 int searched = 0;
783
784 static int
785 findPtrBlocks (StgPtr p, bdescr *bd, StgPtr arr[], int arr_size, int i)
786 {
787 StgPtr q, r, end;
788 for (; bd; bd = bd->link) {
789 searched++;
790 for (q = bd->start; q < bd->free; q++) {
791 if (UNTAG_CLOSURE((StgClosure*)*q) == (StgClosure *)p) {
792 if (i < arr_size) {
793 for (r = bd->start; r < bd->free; r = end) {
794 // skip over zeroed-out slop
795 while (*r == 0) r++;
796 if (!LOOKS_LIKE_CLOSURE_PTR(r)) {
797 debugBelch("%p found at %p, no closure at %p\n",
798 p, q, r);
799 break;
800 }
801 end = r + closure_sizeW((StgClosure*)r);
802 if (q < end) {
803 debugBelch("%p = ", r);
804 printClosure((StgClosure *)r);
805 arr[i++] = r;
806 break;
807 }
808 }
809 if (r >= bd->free) {
810 debugBelch("%p found at %p, closure?", p, q);
811 }
812 } else {
813 return i;
814 }
815 }
816 }
817 }
818 return i;
819 }
820
821 void
822 findPtr(P_ p, int follow)
823 {
824 nat g, n;
825 bdescr *bd;
826 const int arr_size = 1024;
827 StgPtr arr[arr_size];
828 int i = 0;
829 searched = 0;
830
831 for (n = 0; n < n_capabilities; n++) {
832 bd = nurseries[i].blocks;
833 i = findPtrBlocks(p,bd,arr,arr_size,i);
834 if (i >= arr_size) return;
835 }
836
837 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
838 bd = generations[g].blocks;
839 i = findPtrBlocks(p,bd,arr,arr_size,i);
840 bd = generations[g].large_objects;
841 i = findPtrBlocks(p,bd,arr,arr_size,i);
842 if (i >= arr_size) return;
843 }
844 if (follow && i == 1) {
845 debugBelch("-->\n");
846 findPtr(arr[0], 1);
847 }
848 }
849
850 /* prettyPrintClosure() is for printing out a closure using the data constructor
851 names found in the info tables. Closures are printed in a fashion that resembles
852 their Haskell representation. Useful during debugging.
853
854 Todo: support for more closure types, and support for non pointer fields in the
855 payload.
856 */
857
858 void prettyPrintClosure_ (StgClosure *);
859
860 void prettyPrintClosure (StgClosure *obj)
861 {
862 prettyPrintClosure_ (obj);
863 debugBelch ("\n");
864 }
865
866 void prettyPrintClosure_ (StgClosure *obj)
867 {
868 StgInfoTable *info;
869 StgConInfoTable *con_info;
870
871 /* collapse any indirections */
872 unsigned int type;
873 type = get_itbl(obj)->type;
874
875 while (type == IND ||
876 type == IND_STATIC ||
877 type == IND_PERM)
878 {
879 obj = ((StgInd *)obj)->indirectee;
880 type = get_itbl(obj)->type;
881 }
882
883 /* find the info table for this object */
884 info = get_itbl(obj);
885
886 /* determine what kind of object we have */
887 switch (info->type)
888 {
889 /* full applications of data constructors */
890 case CONSTR:
891 case CONSTR_1_0:
892 case CONSTR_0_1:
893 case CONSTR_1_1:
894 case CONSTR_0_2:
895 case CONSTR_2_0:
896 case CONSTR_STATIC:
897 case CONSTR_NOCAF_STATIC:
898 {
899 nat i;
900 char *descriptor;
901
902 /* find the con_info for the constructor */
903 con_info = get_con_itbl (obj);
904
905 /* obtain the name of the constructor */
906 descriptor = GET_CON_DESC(con_info);
907
908 debugBelch ("(%s", descriptor);
909
910 /* process the payload of the closure */
911 /* we don't handle non pointers at the moment */
912 for (i = 0; i < info->layout.payload.ptrs; i++)
913 {
914 debugBelch (" ");
915 prettyPrintClosure_ ((StgClosure *) obj->payload[i]);
916 }
917 debugBelch (")");
918 break;
919 }
920
921 /* if it isn't a constructor then just print the closure type */
922 default:
923 {
924 debugBelch ("<%s>", info_type(obj));
925 break;
926 }
927 }
928 }
929
930 char *what_next_strs[] = {
931 [0] = "(unknown)",
932 [ThreadRunGHC] = "ThreadRunGHC",
933 [ThreadInterpret] = "ThreadInterpret",
934 [ThreadKilled] = "ThreadKilled",
935 [ThreadComplete] = "ThreadComplete"
936 };
937
938 #else /* DEBUG */
939 void printPtr( StgPtr p )
940 {
941 debugBelch("ptr 0x%p (enable -DDEBUG for more info) " , p );
942 }
943
944 void printObj( StgClosure *obj )
945 {
946 debugBelch("obj 0x%p (enable -DDEBUG for more info) " , obj );
947 }
948
949
950 #endif /* DEBUG */
951
952 /* -----------------------------------------------------------------------------
953 Closure types
954
955 NOTE: must be kept in sync with the closure types in includes/ClosureTypes.h
956 -------------------------------------------------------------------------- */
957
958 char *closure_type_names[] = {
959 [INVALID_OBJECT] = "INVALID_OBJECT",
960 [CONSTR] = "CONSTR",
961 [CONSTR_1_0] = "CONSTR_1_0",
962 [CONSTR_0_1] = "CONSTR_0_1",
963 [CONSTR_2_0] = "CONSTR_2_0",
964 [CONSTR_1_1] = "CONSTR_1_1",
965 [CONSTR_0_2] = "CONSTR_0_2",
966 [CONSTR_STATIC] = "CONSTR_STATIC",
967 [CONSTR_NOCAF_STATIC] = "CONSTR_NOCAF_STATIC",
968 [FUN] = "FUN",
969 [FUN_1_0] = "FUN_1_0",
970 [FUN_0_1] = "FUN_0_1",
971 [FUN_2_0] = "FUN_2_0",
972 [FUN_1_1] = "FUN_1_1",
973 [FUN_0_2] = "FUN_0_2",
974 [FUN_STATIC] = "FUN_STATIC",
975 [THUNK] = "THUNK",
976 [THUNK_1_0] = "THUNK_1_0",
977 [THUNK_0_1] = "THUNK_0_1",
978 [THUNK_2_0] = "THUNK_2_0",
979 [THUNK_1_1] = "THUNK_1_1",
980 [THUNK_0_2] = "THUNK_0_2",
981 [THUNK_STATIC] = "THUNK_STATIC",
982 [THUNK_SELECTOR] = "THUNK_SELECTOR",
983 [BCO] = "BCO",
984 [AP] = "AP",
985 [PAP] = "PAP",
986 [AP_STACK] = "AP_STACK",
987 [IND] = "IND",
988 [IND_PERM] = "IND_PERM",
989 [IND_STATIC] = "IND_STATIC",
990 [RET_BCO] = "RET_BCO",
991 [RET_SMALL] = "RET_SMALL",
992 [RET_BIG] = "RET_BIG",
993 [RET_FUN] = "RET_FUN",
994 [UPDATE_FRAME] = "UPDATE_FRAME",
995 [CATCH_FRAME] = "CATCH_FRAME",
996 [UNDERFLOW_FRAME] = "UNDERFLOW_FRAME",
997 [STOP_FRAME] = "STOP_FRAME",
998 [BLOCKING_QUEUE] = "BLOCKING_QUEUE",
999 [BLACKHOLE] = "BLACKHOLE",
1000 [MVAR_CLEAN] = "MVAR_CLEAN",
1001 [MVAR_DIRTY] = "MVAR_DIRTY",
1002 [TVAR] = "TVAR",
1003 [ARR_WORDS] = "ARR_WORDS",
1004 [MUT_ARR_PTRS_CLEAN] = "MUT_ARR_PTRS_CLEAN",
1005 [MUT_ARR_PTRS_DIRTY] = "MUT_ARR_PTRS_DIRTY",
1006 [MUT_ARR_PTRS_FROZEN0] = "MUT_ARR_PTRS_FROZEN0",
1007 [MUT_ARR_PTRS_FROZEN] = "MUT_ARR_PTRS_FROZEN",
1008 [MUT_VAR_CLEAN] = "MUT_VAR_CLEAN",
1009 [MUT_VAR_DIRTY] = "MUT_VAR_DIRTY",
1010 [WEAK] = "WEAK",
1011 [PRIM] = "PRIM",
1012 [MUT_PRIM] = "MUT_PRIM",
1013 [TSO] = "TSO",
1014 [STACK] = "STACK",
1015 [TREC_CHUNK] = "TREC_CHUNK",
1016 [ATOMICALLY_FRAME] = "ATOMICALLY_FRAME",
1017 [CATCH_RETRY_FRAME] = "CATCH_RETRY_FRAME",
1018 [CATCH_STM_FRAME] = "CATCH_STM_FRAME",
1019 [WHITEHOLE] = "WHITEHOLE"
1020 };
1021
1022 char *
1023 info_type(StgClosure *closure){
1024 return closure_type_names[get_itbl(closure)->type];
1025 }
1026
1027 char *
1028 info_type_by_ip(StgInfoTable *ip){
1029 return closure_type_names[ip->type];
1030 }
1031
1032 void
1033 info_hdr_type(StgClosure *closure, char *res){
1034 strcpy(res,closure_type_names[get_itbl(closure)->type]);
1035 }
1036