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