Building GHC with hadrian on FreeBSD
[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 "sm/GCThread.h"
17 #include "Hash.h"
18 #include "Printer.h"
19 #include "RtsUtils.h"
20
21 #if defined(PROFILING)
22 #include "Profiling.h"
23 #endif
24
25 #include <string.h>
26
27 void findPtr(P_ p, int follow);
28
29 #if defined(DEBUG)
30
31 #include "Disassembler.h"
32 #include "Apply.h"
33
34 /* --------------------------------------------------------------------------
35 * local function decls
36 * ------------------------------------------------------------------------*/
37
38 static void printStdObjPayload( const StgClosure *obj );
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( const StgClosure *obj, char* tag )
64 {
65 debugBelch("%s(",tag);
66 printPtr((StgPtr)obj->header.info);
67 #if defined(PROFILING)
68 debugBelch(", %s", obj->header.prof.ccs->cc->label);
69 #endif
70 }
71
72 static void
73 printStdObjPayload( const 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( const StgClosure *obj )
115 {
116 const StgInfoTable *info;
117
118 obj = UNTAG_CONST_CLOSURE(obj);
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_NOCAF:
129 {
130 StgWord i, j;
131 const StgConInfoTable *con_info = get_con_itbl (obj);
132
133 debugBelch("%s(", GET_CON_DESC(con_info));
134 for (i = 0; i < info->layout.payload.ptrs; ++i) {
135 if (i != 0) debugBelch(", ");
136 printPtr((StgPtr)obj->payload[i]);
137 }
138 for (j = 0; j < info->layout.payload.nptrs; ++j) {
139 if (i != 0 || j != 0) debugBelch(", ");
140 debugBelch("%p#", obj->payload[i+j]);
141 }
142 debugBelch(")\n");
143 break;
144 }
145
146 case FUN:
147 case FUN_1_0: case FUN_0_1:
148 case FUN_1_1: case FUN_0_2: case FUN_2_0:
149 case FUN_STATIC:
150 debugBelch("FUN/%d(",(int)itbl_to_fun_itbl(info)->f.arity);
151 printPtr((StgPtr)obj->header.info);
152 #if defined(PROFILING)
153 debugBelch(", %s", obj->header.prof.ccs->cc->label);
154 #endif
155 printStdObjPayload(obj);
156 break;
157
158 case PRIM:
159 debugBelch("PRIM(");
160 printPtr((StgPtr)obj->header.info);
161 printStdObjPayload(obj);
162 break;
163
164 case MUT_PRIM:
165 debugBelch("MUT_PRIM(");
166 printPtr((StgPtr)obj->header.info);
167 printStdObjPayload(obj);
168 break;
169
170 case THUNK:
171 case THUNK_1_0: case THUNK_0_1:
172 case THUNK_1_1: case THUNK_0_2: case THUNK_2_0:
173 case THUNK_STATIC:
174 /* ToDo: will this work for THUNK_STATIC too? */
175 #if defined(PROFILING)
176 printThunkObject((StgThunk *)obj,GET_PROF_DESC(info));
177 #else
178 printThunkObject((StgThunk *)obj,"THUNK");
179 #endif
180 break;
181
182 case THUNK_SELECTOR:
183 printStdObjHdr(obj, "THUNK_SELECTOR");
184 debugBelch(", %p)\n", ((StgSelector *)obj)->selectee);
185 break;
186
187 case BCO:
188 disassemble( (StgBCO*)obj );
189 break;
190
191 case AP:
192 {
193 StgAP* ap = (StgAP*)obj;
194 StgWord i;
195 debugBelch("AP("); printPtr((StgPtr)ap->fun);
196 for (i = 0; i < ap->n_args; ++i) {
197 debugBelch(", ");
198 printPtr((P_)ap->payload[i]);
199 }
200 debugBelch(")\n");
201 break;
202 }
203
204 case PAP:
205 {
206 StgPAP* pap = (StgPAP*)obj;
207 StgWord i;
208 debugBelch("PAP/%d(",(int)pap->arity);
209 printPtr((StgPtr)pap->fun);
210 for (i = 0; i < pap->n_args; ++i) {
211 debugBelch(", ");
212 printPtr((StgPtr)pap->payload[i]);
213 }
214 debugBelch(")\n");
215 break;
216 }
217
218 case AP_STACK:
219 {
220 StgAP_STACK* ap = (StgAP_STACK*)obj;
221 StgWord i;
222 debugBelch("AP_STACK("); printPtr((StgPtr)ap->fun);
223 for (i = 0; i < ap->size; ++i) {
224 debugBelch(", ");
225 printPtr((P_)ap->payload[i]);
226 }
227 debugBelch(")\n");
228 break;
229 }
230
231 case IND:
232 debugBelch("IND(");
233 printPtr((StgPtr)((StgInd*)obj)->indirectee);
234 debugBelch(")\n");
235 break;
236
237 case IND_STATIC:
238 debugBelch("IND_STATIC(");
239 printPtr((StgPtr)((StgInd*)obj)->indirectee);
240 debugBelch(")\n");
241 break;
242
243 case BLACKHOLE:
244 debugBelch("BLACKHOLE(");
245 printPtr((StgPtr)((StgInd*)obj)->indirectee);
246 debugBelch(")\n");
247 break;
248
249 /* Cannot happen -- use default case.
250 case RET_BCO:
251 case RET_SMALL:
252 case RET_BIG:
253 case RET_FUN:
254 */
255
256 case UPDATE_FRAME:
257 {
258 StgUpdateFrame* u = (StgUpdateFrame*)obj;
259 debugBelch("%s(", info_update_frame(obj));
260 printPtr((StgPtr)GET_INFO((StgClosure *)u));
261 debugBelch(",");
262 printPtr((StgPtr)u->updatee);
263 debugBelch(")\n");
264 break;
265 }
266
267 case CATCH_FRAME:
268 {
269 StgCatchFrame* u = (StgCatchFrame*)obj;
270 debugBelch("CATCH_FRAME(");
271 printPtr((StgPtr)GET_INFO((StgClosure *)u));
272 debugBelch(",");
273 printPtr((StgPtr)u->handler);
274 debugBelch(")\n");
275 break;
276 }
277
278 case UNDERFLOW_FRAME:
279 {
280 StgUnderflowFrame* u = (StgUnderflowFrame*)obj;
281 debugBelch("UNDERFLOW_FRAME(");
282 printPtr((StgPtr)u->next_chunk);
283 debugBelch(")\n");
284 break;
285 }
286
287 case STOP_FRAME:
288 {
289 StgStopFrame* u = (StgStopFrame*)obj;
290 debugBelch("STOP_FRAME(");
291 printPtr((StgPtr)GET_INFO((StgClosure *)u));
292 debugBelch(")\n");
293 break;
294 }
295
296 case ARR_WORDS:
297 {
298 StgWord i;
299 debugBelch("ARR_WORDS(\"");
300 for (i=0; i<arr_words_words((StgArrBytes *)obj); i++)
301 debugBelch("%" FMT_Word, (W_)((StgArrBytes *)obj)->payload[i]);
302 debugBelch("\")\n");
303 break;
304 }
305
306 case MUT_ARR_PTRS_CLEAN:
307 debugBelch("MUT_ARR_PTRS_CLEAN(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
308 break;
309
310 case MUT_ARR_PTRS_DIRTY:
311 debugBelch("MUT_ARR_PTRS_DIRTY(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
312 break;
313
314 case MUT_ARR_PTRS_FROZEN_CLEAN:
315 debugBelch("MUT_ARR_PTRS_FROZEN_CLEAN(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
316 break;
317
318 case SMALL_MUT_ARR_PTRS_CLEAN:
319 debugBelch("SMALL_MUT_ARR_PTRS_CLEAN(size=%" FMT_Word ")\n",
320 (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
321 break;
322
323 case SMALL_MUT_ARR_PTRS_DIRTY:
324 debugBelch("SMALL_MUT_ARR_PTRS_DIRTY(size=%" FMT_Word ")\n",
325 (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
326 break;
327
328 case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
329 debugBelch("SMALL_MUT_ARR_PTRS_FROZEN_CLEAN(size=%" FMT_Word ")\n",
330 (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
331 break;
332
333 case MVAR_CLEAN:
334 case MVAR_DIRTY:
335 {
336 StgMVar* mv = (StgMVar*)obj;
337
338 debugBelch("MVAR(head=");
339 if ((StgClosure*)mv->head == &stg_END_TSO_QUEUE_closure) {
340 debugBelch("END_TSO_QUEUE");
341 } else {
342 debugBelch("%p", mv->head);
343 }
344
345 debugBelch(", tail=");
346 if ((StgClosure*)mv->tail == &stg_END_TSO_QUEUE_closure) {
347 debugBelch("END_TSO_QUEUE");
348 } else {
349 debugBelch("%p", mv->tail);
350 }
351
352 debugBelch(", value=");
353 if ((StgClosure*)mv->value == &stg_END_TSO_QUEUE_closure) {
354 debugBelch("END_TSO_QUEUE");
355 } else {
356 debugBelch("%p", mv->value);
357 }
358 debugBelch(")\n");
359
360 break;
361 }
362
363 case TVAR:
364 {
365 StgTVar* tv = (StgTVar*)obj;
366 debugBelch("TVAR(value=%p, wq=%p, num_updates=%" FMT_Word ")\n", tv->current_value, tv->first_watch_queue_entry, tv->num_updates);
367 break;
368 }
369
370 case MUT_VAR_CLEAN:
371 {
372 StgMutVar* mv = (StgMutVar*)obj;
373 debugBelch("MUT_VAR_CLEAN(var=%p)\n", mv->var);
374 break;
375 }
376
377 case MUT_VAR_DIRTY:
378 {
379 StgMutVar* mv = (StgMutVar*)obj;
380 debugBelch("MUT_VAR_DIRTY(var=%p)\n", mv->var);
381 break;
382 }
383
384 case WEAK:
385 debugBelch("WEAK(");
386 debugBelch("key=%p value=%p finalizer=%p",
387 (StgPtr)(((StgWeak*)obj)->key),
388 (StgPtr)(((StgWeak*)obj)->value),
389 (StgPtr)(((StgWeak*)obj)->finalizer));
390 debugBelch(")\n");
391 /* ToDo: chase 'link' ? */
392 break;
393
394 case TSO:
395 debugBelch("TSO(");
396 debugBelch("%lu (%p)",(unsigned long)(((StgTSO*)obj)->id), (StgTSO*)obj);
397 debugBelch(")\n");
398 break;
399
400 case STACK:
401 debugBelch("STACK\n");
402 break;
403
404 #if 0
405 /* Symptomatic of a problem elsewhere, have it fall-through & fail */
406 case EVACUATED:
407 debugBelch("EVACUATED(");
408 printClosure((StgEvacuated*)obj->evacuee);
409 debugBelch(")\n");
410 break;
411 #endif
412
413 case COMPACT_NFDATA:
414 debugBelch("COMPACT_NFDATA(size=%" FMT_Word ")\n",
415 (W_)((StgCompactNFData *)obj)->totalW * (W_)sizeof(W_));
416 break;
417
418 case TREC_CHUNK:
419 debugBelch("TREC_CHUNK\n");
420 break;
421
422 default:
423 //barf("printClosure %d",get_itbl(obj)->type);
424 debugBelch("*** printClosure: unknown type %d ****\n",
425 (int)get_itbl(obj)->type );
426 barf("printClosure %d",get_itbl(obj)->type);
427 return;
428 }
429 }
430
431 void
432 printMutableList(bdescr *bd)
433 {
434 StgPtr p;
435
436 debugBelch("mutable list %p: ", bd);
437
438 for (; bd != NULL; bd = bd->link) {
439 for (p = bd->start; p < bd->free; p++) {
440 debugBelch("%p (%s), ", (void *)*p, info_type((StgClosure *)*p));
441 }
442 }
443 debugBelch("\n");
444 }
445
446 // If you know you have an UPDATE_FRAME, but want to know exactly which.
447 const char *info_update_frame(const StgClosure *closure)
448 {
449 // Note: We intentionally don't take the info table pointer as
450 // an argument. As it will be confusing whether one should pass
451 // it pointing to the code or struct members when compiling with
452 // TABLES_NEXT_TO_CODE.
453 const StgInfoTable *info = closure->header.info;
454 if (info == &stg_upd_frame_info) {
455 return "NORMAL_UPDATE_FRAME";
456 } else if (info == &stg_bh_upd_frame_info) {
457 return "BH_UPDATE_FRAME";
458 } else if (info == &stg_marked_upd_frame_info) {
459 return "MARKED_UPDATE_FRAME";
460 } else {
461 return "ERROR: Not an update frame!!!";
462 }
463 }
464
465 static void
466 printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap,
467 uint32_t size )
468 {
469 uint32_t i;
470
471 for(i = 0; i < size; i++, bitmap >>= 1 ) {
472 debugBelch(" stk[%ld] (%p) = ", (long)(spBottom-(payload+i)), payload+i);
473 if ((bitmap & 1) == 0) {
474 printPtr((P_)payload[i]);
475 debugBelch("\n");
476 } else {
477 debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]);
478 }
479 }
480 }
481
482 static void
483 printLargeBitmap( StgPtr spBottom, StgPtr payload, StgLargeBitmap* large_bitmap,
484 uint32_t size )
485 {
486 StgWord bmp;
487 uint32_t i, j;
488
489 i = 0;
490 for (bmp=0; i < size; bmp++) {
491 StgWord bitmap = large_bitmap->bitmap[bmp];
492 j = 0;
493 for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) {
494 debugBelch(" stk[%" FMT_Word "] (%p) = ", (W_)(spBottom-(payload+i)), payload+i);
495 if ((bitmap & 1) == 0) {
496 printPtr((P_)payload[i]);
497 debugBelch("\n");
498 } else {
499 debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]);
500 }
501 }
502 }
503 }
504
505 void
506 printStackChunk( StgPtr sp, StgPtr spBottom )
507 {
508 StgWord bitmap;
509 const StgInfoTable *info;
510
511 ASSERT(sp <= spBottom);
512 for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) {
513
514 info = get_itbl((StgClosure *)sp);
515
516 switch (info->type) {
517
518 case UPDATE_FRAME:
519 case CATCH_FRAME:
520 case UNDERFLOW_FRAME:
521 case STOP_FRAME:
522 printClosure((StgClosure*)sp);
523 continue;
524
525 case RET_SMALL: {
526 StgWord c = *sp;
527 if (c == (StgWord)&stg_ctoi_R1p_info) {
528 debugBelch("tstg_ctoi_ret_R1p_info\n" );
529 } else if (c == (StgWord)&stg_ctoi_R1n_info) {
530 debugBelch("stg_ctoi_ret_R1n_info\n" );
531 } else if (c == (StgWord)&stg_ctoi_F1_info) {
532 debugBelch("stg_ctoi_ret_F1_info\n" );
533 } else if (c == (StgWord)&stg_ctoi_D1_info) {
534 debugBelch("stg_ctoi_ret_D1_info\n" );
535 } else if (c == (StgWord)&stg_ctoi_V_info) {
536 debugBelch("stg_ctoi_ret_V_info\n" );
537 } else if (c == (StgWord)&stg_ap_v_info) {
538 debugBelch("stg_ap_v_info\n" );
539 } else if (c == (StgWord)&stg_ap_f_info) {
540 debugBelch("stg_ap_f_info\n" );
541 } else if (c == (StgWord)&stg_ap_d_info) {
542 debugBelch("stg_ap_d_info\n" );
543 } else if (c == (StgWord)&stg_ap_l_info) {
544 debugBelch("stg_ap_l_info\n" );
545 } else if (c == (StgWord)&stg_ap_n_info) {
546 debugBelch("stg_ap_n_info\n" );
547 } else if (c == (StgWord)&stg_ap_p_info) {
548 debugBelch("stg_ap_p_info\n" );
549 } else if (c == (StgWord)&stg_ap_pp_info) {
550 debugBelch("stg_ap_pp_info\n" );
551 } else if (c == (StgWord)&stg_ap_ppp_info) {
552 debugBelch("stg_ap_ppp_info\n" );
553 } else if (c == (StgWord)&stg_ap_pppp_info) {
554 debugBelch("stg_ap_pppp_info\n" );
555 } else if (c == (StgWord)&stg_ap_ppppp_info) {
556 debugBelch("stg_ap_ppppp_info\n" );
557 } else if (c == (StgWord)&stg_ap_pppppp_info) {
558 debugBelch("stg_ap_pppppp_info\n" );
559 } else if (c == (StgWord)&stg_ret_v_info) {
560 debugBelch("stg_ret_v_info\n" );
561 } else if (c == (StgWord)&stg_ret_p_info) {
562 debugBelch("stg_ret_p_info\n" );
563 } else if (c == (StgWord)&stg_ret_n_info) {
564 debugBelch("stg_ret_n_info\n" );
565 } else if (c == (StgWord)&stg_ret_f_info) {
566 debugBelch("stg_ret_f_info\n" );
567 } else if (c == (StgWord)&stg_ret_d_info) {
568 debugBelch("stg_ret_d_info\n" );
569 } else if (c == (StgWord)&stg_ret_l_info) {
570 debugBelch("stg_ret_l_info\n" );
571 #if defined(PROFILING)
572 } else if (c == (StgWord)&stg_restore_cccs_info) {
573 debugBelch("stg_restore_cccs_info\n" );
574 fprintCCS(stderr, (CostCentreStack*)sp[1]);
575 debugBelch("\n" );
576 continue;
577 } else if (c == (StgWord)&stg_restore_cccs_eval_info) {
578 debugBelch("stg_restore_cccs_eval_info\n" );
579 fprintCCS(stderr, (CostCentreStack*)sp[1]);
580 debugBelch("\n" );
581 continue;
582 #endif
583 } else {
584 debugBelch("RET_SMALL (%p)\n", info);
585 }
586 bitmap = info->layout.bitmap;
587 printSmallBitmap(spBottom, sp+1,
588 BITMAP_BITS(bitmap), BITMAP_SIZE(bitmap));
589 continue;
590 }
591
592 case RET_BCO: {
593 StgBCO *bco;
594
595 bco = ((StgBCO *)sp[1]);
596
597 debugBelch("RET_BCO (%p)\n", sp);
598 printLargeBitmap(spBottom, sp+2,
599 BCO_BITMAP(bco), BCO_BITMAP_SIZE(bco));
600 continue;
601 }
602
603 case RET_BIG:
604 barf("todo");
605
606 case RET_FUN:
607 {
608 const StgFunInfoTable *fun_info;
609 StgRetFun *ret_fun;
610
611 ret_fun = (StgRetFun *)sp;
612 fun_info = get_fun_itbl(ret_fun->fun);
613 debugBelch("RET_FUN (%p) (type=%d)\n", ret_fun->fun, (int)fun_info->f.fun_type);
614 switch (fun_info->f.fun_type) {
615 case ARG_GEN:
616 printSmallBitmap(spBottom, sp+2,
617 BITMAP_BITS(fun_info->f.b.bitmap),
618 BITMAP_SIZE(fun_info->f.b.bitmap));
619 break;
620 case ARG_GEN_BIG:
621 printLargeBitmap(spBottom, sp+2,
622 GET_FUN_LARGE_BITMAP(fun_info),
623 GET_FUN_LARGE_BITMAP(fun_info)->size);
624 break;
625 default:
626 printSmallBitmap(spBottom, sp+2,
627 BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
628 BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]));
629 break;
630 }
631 continue;
632 }
633
634 default:
635 debugBelch("unknown object %d\n", (int)info->type);
636 barf("printStackChunk");
637 }
638 }
639 }
640
641 static void printStack( StgStack *stack )
642 {
643 printStackChunk( stack->sp, stack->stack + stack->stack_size );
644 }
645
646 void printTSO( StgTSO *tso )
647 {
648 printStack( tso->stackobj );
649 }
650
651 /* --------------------------------------------------------------------------
652 * Address printing code
653 *
654 * Uses symbol table in (unstripped executable)
655 * ------------------------------------------------------------------------*/
656
657 /* --------------------------------------------------------------------------
658 * Simple lookup table
659 * address -> function name
660 * ------------------------------------------------------------------------*/
661
662 static HashTable * add_to_fname_table = NULL;
663
664 const char *lookupGHCName( void *addr )
665 {
666 if (add_to_fname_table == NULL)
667 return NULL;
668
669 return lookupHashTable(add_to_fname_table, (StgWord)addr);
670 }
671
672 /* --------------------------------------------------------------------------
673 * Symbol table loading
674 * ------------------------------------------------------------------------*/
675
676 /* Causing linking trouble on Win32 plats, so I'm
677 disabling this for now.
678 */
679 #if defined(USING_LIBBFD)
680 # define PACKAGE 1
681 # define PACKAGE_VERSION 1
682 /* Those PACKAGE_* defines are workarounds for bfd:
683 * https://sourceware.org/bugzilla/show_bug.cgi?id=14243
684 * ghc's build system filter PACKAGE_* values out specifically to avoid clashes
685 * with user's autoconf-based Cabal packages.
686 * It's a shame <bfd.h> checks for unrelated fields instead of actually used
687 * macros.
688 */
689 # include <bfd.h>
690
691 /* Fairly ad-hoc piece of code that seems to filter out a lot of
692 * rubbish like the obj-splitting symbols
693 */
694
695 static bool isReal( flagword flags STG_UNUSED, const char *name )
696 {
697 #if 0
698 /* ToDo: make this work on BFD */
699 int tp = type & N_TYPE;
700 if (tp == N_TEXT || tp == N_DATA) {
701 return (name[0] == '_' && name[1] != '_');
702 } else {
703 return false;
704 }
705 #else
706 if (*name == '\0' ||
707 (name[0] == 'g' && name[1] == 'c' && name[2] == 'c') ||
708 (name[0] == 'c' && name[1] == 'c' && name[2] == '.')) {
709 return false;
710 }
711 return true;
712 #endif
713 }
714
715 extern void DEBUG_LoadSymbols( const char *name )
716 {
717 bfd* abfd;
718 char **matching;
719
720 bfd_init();
721 abfd = bfd_openr(name, "default");
722 if (abfd == NULL) {
723 barf("can't open executable %s to get symbol table", name);
724 }
725 if (!bfd_check_format_matches (abfd, bfd_object, &matching)) {
726 barf("mismatch");
727 }
728
729 {
730 long storage_needed;
731 asymbol **symbol_table;
732 long number_of_symbols;
733 long num_real_syms = 0;
734 long i;
735
736 storage_needed = bfd_get_symtab_upper_bound (abfd);
737
738 if (storage_needed < 0) {
739 barf("can't read symbol table");
740 }
741 symbol_table = (asymbol **) stgMallocBytes(storage_needed,"DEBUG_LoadSymbols");
742
743 number_of_symbols = bfd_canonicalize_symtab (abfd, symbol_table);
744
745 if (number_of_symbols < 0) {
746 barf("can't canonicalise symbol table");
747 }
748
749 if (add_to_fname_table == NULL)
750 add_to_fname_table = allocHashTable();
751
752 for( i = 0; i != number_of_symbols; ++i ) {
753 symbol_info info;
754 bfd_get_symbol_info(abfd,symbol_table[i],&info);
755 if (isReal(info.type, info.name)) {
756 insertHashTable(add_to_fname_table,
757 info.value, (void*)info.name);
758 num_real_syms += 1;
759 }
760 }
761
762 IF_DEBUG(interpreter,
763 debugBelch("Loaded %ld symbols. Of which %ld are real symbols\n",
764 number_of_symbols, num_real_syms)
765 );
766
767 stgFree(symbol_table);
768 }
769 }
770
771 #else /* USING_LIBBFD */
772
773 extern void DEBUG_LoadSymbols( const char *name STG_UNUSED )
774 {
775 /* nothing, yet */
776 }
777
778 #endif /* USING_LIBBFD */
779
780 int searched = 0;
781
782 static int
783 findPtrBlocks (StgPtr p, bdescr *bd, StgPtr arr[], int arr_size, int i)
784 {
785 StgPtr q, r, end;
786 for (; bd; bd = bd->link) {
787 searched++;
788 for (q = bd->start; q < bd->free; q++) {
789 if (UNTAG_CONST_CLOSURE((StgClosure*)*q) == (const StgClosure *)p) {
790 if (i < arr_size) {
791 for (r = bd->start; r < bd->free; r = end) {
792 // skip over zeroed-out slop
793 while (*r == 0) r++;
794 if (!LOOKS_LIKE_CLOSURE_PTR(r)) {
795 debugBelch("%p found at %p, no closure at %p\n",
796 p, q, r);
797 break;
798 }
799 end = r + closure_sizeW((StgClosure*)r);
800 if (q < end) {
801 debugBelch("%p = ", r);
802 printClosure((StgClosure *)r);
803 arr[i++] = r;
804 break;
805 }
806 }
807 if (r >= bd->free) {
808 debugBelch("%p found at %p, closure?", p, q);
809 }
810 } else {
811 return i;
812 }
813 }
814 }
815 }
816 return i;
817 }
818
819 void
820 findPtr(P_ p, int follow)
821 {
822 uint32_t g, n;
823 bdescr *bd;
824 const int arr_size = 1024;
825 StgPtr arr[arr_size];
826 int i = 0;
827 searched = 0;
828
829 #if 0
830 // We can't search the nursery, because we don't know which blocks contain
831 // valid data, because the bd->free pointers in the nursery are only reset
832 // just before a block is used.
833 for (n = 0; n < n_capabilities; n++) {
834 bd = nurseries[i].blocks;
835 i = findPtrBlocks(p,bd,arr,arr_size,i);
836 if (i >= arr_size) return;
837 }
838 #endif
839
840 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
841 bd = generations[g].blocks;
842 i = findPtrBlocks(p,bd,arr,arr_size,i);
843 bd = generations[g].large_objects;
844 i = findPtrBlocks(p,bd,arr,arr_size,i);
845 if (i >= arr_size) return;
846 for (n = 0; n < n_capabilities; n++) {
847 i = findPtrBlocks(p, gc_threads[n]->gens[g].part_list,
848 arr, arr_size, i);
849 i = findPtrBlocks(p, gc_threads[n]->gens[g].todo_bd,
850 arr, arr_size, i);
851 }
852 if (i >= arr_size) return;
853 }
854 if (follow && i == 1) {
855 debugBelch("-->\n");
856 findPtr(arr[0], 1);
857 }
858 }
859
860 const char *what_next_strs[] = {
861 [0] = "(unknown)",
862 [ThreadRunGHC] = "ThreadRunGHC",
863 [ThreadInterpret] = "ThreadInterpret",
864 [ThreadKilled] = "ThreadKilled",
865 [ThreadComplete] = "ThreadComplete"
866 };
867
868 #else /* DEBUG */
869 void printPtr( StgPtr p )
870 {
871 debugBelch("ptr 0x%p (enable -DDEBUG for more info) " , p );
872 }
873
874 void printObj( StgClosure *obj )
875 {
876 debugBelch("obj 0x%p (enable -DDEBUG for more info) " , obj );
877 }
878
879 void findPtr(P_ p, int follow)
880 {
881 // we're printing the arguments just to silence the unused parameter warning
882 debugBelch("recompile your program with -debug in order to run ");
883 debugBelch("findPtr(0x%p, %d)\n", p, follow);
884 }
885 #endif /* DEBUG */
886
887 /* -----------------------------------------------------------------------------
888 Closure types
889
890 NOTE: must be kept in sync with the closure types in
891 includes/rts/storage/ClosureTypes.h
892 -------------------------------------------------------------------------- */
893
894 const char *closure_type_names[] = {
895 [INVALID_OBJECT] = "INVALID_OBJECT",
896 [CONSTR] = "CONSTR",
897 [CONSTR_1_0] = "CONSTR_1_0",
898 [CONSTR_0_1] = "CONSTR_0_1",
899 [CONSTR_2_0] = "CONSTR_2_0",
900 [CONSTR_1_1] = "CONSTR_1_1",
901 [CONSTR_0_2] = "CONSTR_0_2",
902 [CONSTR_NOCAF] = "CONSTR_NOCAF",
903 [FUN] = "FUN",
904 [FUN_1_0] = "FUN_1_0",
905 [FUN_0_1] = "FUN_0_1",
906 [FUN_2_0] = "FUN_2_0",
907 [FUN_1_1] = "FUN_1_1",
908 [FUN_0_2] = "FUN_0_2",
909 [FUN_STATIC] = "FUN_STATIC",
910 [THUNK] = "THUNK",
911 [THUNK_1_0] = "THUNK_1_0",
912 [THUNK_0_1] = "THUNK_0_1",
913 [THUNK_2_0] = "THUNK_2_0",
914 [THUNK_1_1] = "THUNK_1_1",
915 [THUNK_0_2] = "THUNK_0_2",
916 [THUNK_STATIC] = "THUNK_STATIC",
917 [THUNK_SELECTOR] = "THUNK_SELECTOR",
918 [BCO] = "BCO",
919 [AP] = "AP",
920 [PAP] = "PAP",
921 [AP_STACK] = "AP_STACK",
922 [IND] = "IND",
923 [IND_STATIC] = "IND_STATIC",
924 [RET_BCO] = "RET_BCO",
925 [RET_SMALL] = "RET_SMALL",
926 [RET_BIG] = "RET_BIG",
927 [RET_FUN] = "RET_FUN",
928 [UPDATE_FRAME] = "UPDATE_FRAME",
929 [CATCH_FRAME] = "CATCH_FRAME",
930 [UNDERFLOW_FRAME] = "UNDERFLOW_FRAME",
931 [STOP_FRAME] = "STOP_FRAME",
932 [BLOCKING_QUEUE] = "BLOCKING_QUEUE",
933 [BLACKHOLE] = "BLACKHOLE",
934 [MVAR_CLEAN] = "MVAR_CLEAN",
935 [MVAR_DIRTY] = "MVAR_DIRTY",
936 [TVAR] = "TVAR",
937 [ARR_WORDS] = "ARR_WORDS",
938 [MUT_ARR_PTRS_CLEAN] = "MUT_ARR_PTRS_CLEAN",
939 [MUT_ARR_PTRS_DIRTY] = "MUT_ARR_PTRS_DIRTY",
940 [MUT_ARR_PTRS_FROZEN_DIRTY] = "MUT_ARR_PTRS_FROZEN_DIRTY",
941 [MUT_ARR_PTRS_FROZEN_CLEAN] = "MUT_ARR_PTRS_FROZEN_CLEAN",
942 [MUT_VAR_CLEAN] = "MUT_VAR_CLEAN",
943 [MUT_VAR_DIRTY] = "MUT_VAR_DIRTY",
944 [WEAK] = "WEAK",
945 [PRIM] = "PRIM",
946 [MUT_PRIM] = "MUT_PRIM",
947 [TSO] = "TSO",
948 [STACK] = "STACK",
949 [TREC_CHUNK] = "TREC_CHUNK",
950 [ATOMICALLY_FRAME] = "ATOMICALLY_FRAME",
951 [CATCH_RETRY_FRAME] = "CATCH_RETRY_FRAME",
952 [CATCH_STM_FRAME] = "CATCH_STM_FRAME",
953 [WHITEHOLE] = "WHITEHOLE",
954 [SMALL_MUT_ARR_PTRS_CLEAN] = "SMALL_MUT_ARR_PTRS_CLEAN",
955 [SMALL_MUT_ARR_PTRS_DIRTY] = "SMALL_MUT_ARR_PTRS_DIRTY",
956 [SMALL_MUT_ARR_PTRS_FROZEN_DIRTY] = "SMALL_MUT_ARR_PTRS_FROZEN_DIRTY",
957 [SMALL_MUT_ARR_PTRS_FROZEN_CLEAN] = "SMALL_MUT_ARR_PTRS_FROZEN_CLEAN",
958 [COMPACT_NFDATA] = "COMPACT_NFDATA"
959 };
960
961 #if N_CLOSURE_TYPES != 64
962 #error Closure types changed: update Printer.c!
963 #endif
964
965 const char *
966 info_type(const StgClosure *closure){
967 return closure_type_names[get_itbl(closure)->type];
968 }
969
970 const char *
971 info_type_by_ip(const StgInfoTable *ip){
972 return closure_type_names[ip->type];
973 }
974
975 void
976 info_hdr_type(const StgClosure *closure, char *res){
977 strcpy(res,closure_type_names[get_itbl(closure)->type]);
978 }