Comments on equality types and classes
[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 "Hash.h"
17 #include "Printer.h"
18 #include "RtsUtils.h"
19
20 #include <string.h>
21
22 #ifdef DEBUG
23
24 #include "Disassembler.h"
25 #include "Apply.h"
26
27 /* --------------------------------------------------------------------------
28 * local function decls
29 * ------------------------------------------------------------------------*/
30
31 static void printStdObjPayload( StgClosure *obj );
32
33 /* --------------------------------------------------------------------------
34 * Printer
35 * ------------------------------------------------------------------------*/
36
37 void printPtr( StgPtr p )
38 {
39 const char *raw;
40 raw = lookupGHCName(p);
41 if (raw != NULL) {
42 debugBelch("<%s>", raw);
43 debugBelch("[%p]", p);
44 } else {
45 debugBelch("%p", p);
46 }
47 }
48
49 void printObj( StgClosure *obj )
50 {
51 debugBelch("Object "); printPtr((StgPtr)obj); debugBelch(" = ");
52 printClosure(obj);
53 }
54
55 STATIC_INLINE void
56 printStdObjHdr( StgClosure *obj, char* tag )
57 {
58 debugBelch("%s(",tag);
59 printPtr((StgPtr)obj->header.info);
60 #ifdef PROFILING
61 debugBelch(", %s", obj->header.prof.ccs->cc->label);
62 #endif
63 }
64
65 static void
66 printStdObjPayload( StgClosure *obj )
67 {
68 StgWord i, j;
69 const StgInfoTable* info;
70
71 info = get_itbl(obj);
72 for (i = 0; i < info->layout.payload.ptrs; ++i) {
73 debugBelch(", ");
74 printPtr((StgPtr)obj->payload[i]);
75 }
76 for (j = 0; j < info->layout.payload.nptrs; ++j) {
77 debugBelch(", %pd#",obj->payload[i+j]);
78 }
79 debugBelch(")\n");
80 }
81
82 static void
83 printThunkPayload( StgThunk *obj )
84 {
85 StgWord i, j;
86 const StgInfoTable* info;
87
88 info = get_itbl((StgClosure *)obj);
89 for (i = 0; i < info->layout.payload.ptrs; ++i) {
90 debugBelch(", ");
91 printPtr((StgPtr)obj->payload[i]);
92 }
93 for (j = 0; j < info->layout.payload.nptrs; ++j) {
94 debugBelch(", %pd#",obj->payload[i+j]);
95 }
96 debugBelch(")\n");
97 }
98
99 static void
100 printThunkObject( StgThunk *obj, char* tag )
101 {
102 printStdObjHdr( (StgClosure *)obj, tag );
103 printThunkPayload( obj );
104 }
105
106 void
107 printClosure( StgClosure *obj )
108 {
109 obj = UNTAG_CLOSURE(obj);
110
111 StgInfoTable *info;
112 info = get_itbl(obj);
113
114 switch ( info->type ) {
115 case INVALID_OBJECT:
116 barf("Invalid object");
117
118 case CONSTR:
119 case CONSTR_1_0: case CONSTR_0_1:
120 case CONSTR_1_1: case CONSTR_0_2: case CONSTR_2_0:
121 case CONSTR_STATIC:
122 case CONSTR_NOCAF_STATIC:
123 {
124 StgWord i, j;
125 StgConInfoTable *con_info = get_con_itbl (obj);
126
127 debugBelch("%s(", GET_CON_DESC(con_info));
128 for (i = 0; i < info->layout.payload.ptrs; ++i) {
129 if (i != 0) debugBelch(", ");
130 printPtr((StgPtr)obj->payload[i]);
131 }
132 for (j = 0; j < info->layout.payload.nptrs; ++j) {
133 if (i != 0 || j != 0) debugBelch(", ");
134 debugBelch("%p#", obj->payload[i+j]);
135 }
136 debugBelch(")\n");
137 break;
138 }
139
140 case FUN:
141 case FUN_1_0: case FUN_0_1:
142 case FUN_1_1: case FUN_0_2: case FUN_2_0:
143 case FUN_STATIC:
144 debugBelch("FUN/%d(",(int)itbl_to_fun_itbl(info)->f.arity);
145 printPtr((StgPtr)obj->header.info);
146 #ifdef PROFILING
147 debugBelch(", %s", obj->header.prof.ccs->cc->label);
148 #endif
149 printStdObjPayload(obj);
150 break;
151
152 case PRIM:
153 debugBelch("PRIM(");
154 printPtr((StgPtr)obj->header.info);
155 printStdObjPayload(obj);
156 break;
157
158 case MUT_PRIM:
159 debugBelch("MUT_PRIM(");
160 printPtr((StgPtr)obj->header.info);
161 printStdObjPayload(obj);
162 break;
163
164 case THUNK:
165 case THUNK_1_0: case THUNK_0_1:
166 case THUNK_1_1: case THUNK_0_2: case THUNK_2_0:
167 case THUNK_STATIC:
168 /* ToDo: will this work for THUNK_STATIC too? */
169 #ifdef PROFILING
170 printThunkObject((StgThunk *)obj,GET_PROF_DESC(info));
171 #else
172 printThunkObject((StgThunk *)obj,"THUNK");
173 #endif
174 break;
175
176 case THUNK_SELECTOR:
177 printStdObjHdr(obj, "THUNK_SELECTOR");
178 debugBelch(", %p)\n", ((StgSelector *)obj)->selectee);
179 break;
180
181 case BCO:
182 disassemble( (StgBCO*)obj );
183 break;
184
185 case AP:
186 {
187 StgAP* ap = (StgAP*)obj;
188 StgWord i;
189 debugBelch("AP("); printPtr((StgPtr)ap->fun);
190 for (i = 0; i < ap->n_args; ++i) {
191 debugBelch(", ");
192 printPtr((P_)ap->payload[i]);
193 }
194 debugBelch(")\n");
195 break;
196 }
197
198 case PAP:
199 {
200 StgPAP* pap = (StgPAP*)obj;
201 StgWord i;
202 debugBelch("PAP/%d(",(int)pap->arity);
203 printPtr((StgPtr)pap->fun);
204 for (i = 0; i < pap->n_args; ++i) {
205 debugBelch(", ");
206 printPtr((StgPtr)pap->payload[i]);
207 }
208 debugBelch(")\n");
209 break;
210 }
211
212 case AP_STACK:
213 {
214 StgAP_STACK* ap = (StgAP_STACK*)obj;
215 StgWord i;
216 debugBelch("AP_STACK("); printPtr((StgPtr)ap->fun);
217 for (i = 0; i < ap->size; ++i) {
218 debugBelch(", ");
219 printPtr((P_)ap->payload[i]);
220 }
221 debugBelch(")\n");
222 break;
223 }
224
225 case IND:
226 debugBelch("IND(");
227 printPtr((StgPtr)((StgInd*)obj)->indirectee);
228 debugBelch(")\n");
229 break;
230
231 case IND_PERM:
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:
315 debugBelch("MUT_ARR_PTRS_FROZEN(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:
329 debugBelch("SMALL_MUT_ARR_PTRS_FROZEN(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 debugBelch("MVAR(head=%p, tail=%p, value=%p)\n", mv->head, mv->tail, mv->value);
338 break;
339 }
340
341 case TVAR:
342 {
343 StgTVar* tv = (StgTVar*)obj;
344 debugBelch("TVAR(value=%p, wq=%p, num_updates=%" FMT_Word ")\n", tv->current_value, tv->first_watch_queue_entry, tv->num_updates);
345 break;
346 }
347
348 case MUT_VAR_CLEAN:
349 {
350 StgMutVar* mv = (StgMutVar*)obj;
351 debugBelch("MUT_VAR_CLEAN(var=%p)\n", mv->var);
352 break;
353 }
354
355 case MUT_VAR_DIRTY:
356 {
357 StgMutVar* mv = (StgMutVar*)obj;
358 debugBelch("MUT_VAR_DIRTY(var=%p)\n", mv->var);
359 break;
360 }
361
362 case WEAK:
363 debugBelch("WEAK(");
364 debugBelch(" key=%p value=%p finalizer=%p",
365 (StgPtr)(((StgWeak*)obj)->key),
366 (StgPtr)(((StgWeak*)obj)->value),
367 (StgPtr)(((StgWeak*)obj)->finalizer));
368 debugBelch(")\n");
369 /* ToDo: chase 'link' ? */
370 break;
371
372 case TSO:
373 debugBelch("TSO(");
374 debugBelch("%lu (%p)",(unsigned long)(((StgTSO*)obj)->id), (StgTSO*)obj);
375 debugBelch(")\n");
376 break;
377
378 case STACK:
379 debugBelch("STACK");
380 break;
381
382 #if 0
383 /* Symptomatic of a problem elsewhere, have it fall-through & fail */
384 case EVACUATED:
385 debugBelch("EVACUATED(");
386 printClosure((StgEvacuated*)obj->evacuee);
387 debugBelch(")\n");
388 break;
389 #endif
390
391 default:
392 //barf("printClosure %d",get_itbl(obj)->type);
393 debugBelch("*** printClosure: unknown type %d ****\n",
394 (int)get_itbl(obj)->type );
395 barf("printClosure %d",get_itbl(obj)->type);
396 return;
397 }
398 }
399
400 // If you know you have an UPDATE_FRAME, but want to know exactly which.
401 char *info_update_frame(StgClosure *closure) {
402 // Note: We intentionally don't take the info table pointer as
403 // an argument. As it will be confusing whether one should pass
404 // it pointing to the code or struct members when compiling with
405 // TABLES_NEXT_TO_CODE.
406 const StgInfoTable *info = closure->header.info;
407 if (info == &stg_upd_frame_info) {
408 return "NORMAL_UPDATE_FRAME";
409 } else if (info == &stg_bh_upd_frame_info) {
410 return "BH_UPDATE_FRAME";
411 } else if (info == &stg_marked_upd_frame_info) {
412 return "MARKED_UPDATE_FRAME";
413 } else {
414 return "ERROR: Not an update frame!!!";
415 }
416 }
417
418 /*
419 void printGraph( StgClosure *obj )
420 {
421 printClosure(obj);
422 }
423 */
424
425 StgPtr
426 printStackObj( StgPtr sp )
427 {
428 /*debugBelch("Stack[%d] = ", &stgStack[STACK_SIZE] - sp); */
429
430 StgClosure* c = (StgClosure*)(*sp);
431 printPtr((StgPtr)*sp);
432 if (c == (StgClosure*)&stg_ctoi_R1p_info) {
433 debugBelch("\t\t\tstg_ctoi_ret_R1p_info\n" );
434 } else
435 if (c == (StgClosure*)&stg_ctoi_R1n_info) {
436 debugBelch("\t\t\tstg_ctoi_ret_R1n_info\n" );
437 } else
438 if (c == (StgClosure*)&stg_ctoi_F1_info) {
439 debugBelch("\t\t\tstg_ctoi_ret_F1_info\n" );
440 } else
441 if (c == (StgClosure*)&stg_ctoi_D1_info) {
442 debugBelch("\t\t\tstg_ctoi_ret_D1_info\n" );
443 } else
444 if (c == (StgClosure*)&stg_ctoi_V_info) {
445 debugBelch("\t\t\tstg_ctoi_ret_V_info\n" );
446 } else
447 if (get_itbl(c)->type == BCO) {
448 debugBelch("\t\t\t");
449 debugBelch("BCO(...)\n");
450 }
451 else {
452 debugBelch("\t\t\t");
453 printClosure ( (StgClosure*)(*sp));
454 }
455 sp += 1;
456
457 return sp;
458
459 }
460
461 static void
462 printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap, nat size )
463 {
464 nat i;
465
466 for(i = 0; i < size; i++, bitmap >>= 1 ) {
467 debugBelch(" stk[%ld] (%p) = ", (long)(spBottom-(payload+i)), payload+i);
468 if ((bitmap & 1) == 0) {
469 printPtr((P_)payload[i]);
470 debugBelch("\n");
471 } else {
472 debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]);
473 }
474 }
475 }
476
477 static void
478 printLargeBitmap( StgPtr spBottom, StgPtr payload, StgLargeBitmap* large_bitmap, nat size )
479 {
480 StgWord bmp;
481 nat i, j;
482
483 i = 0;
484 for (bmp=0; i < size; bmp++) {
485 StgWord bitmap = large_bitmap->bitmap[bmp];
486 j = 0;
487 for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) {
488 debugBelch(" stk[%" FMT_Word "] (%p) = ", (W_)(spBottom-(payload+i)), payload+i);
489 if ((bitmap & 1) == 0) {
490 printPtr((P_)payload[i]);
491 debugBelch("\n");
492 } else {
493 debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]);
494 }
495 }
496 }
497 }
498
499 void
500 printStackChunk( StgPtr sp, StgPtr spBottom )
501 {
502 StgWord bitmap;
503 const StgInfoTable *info;
504
505 ASSERT(sp <= spBottom);
506 for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) {
507
508 info = get_itbl((StgClosure *)sp);
509
510 switch (info->type) {
511
512 case UPDATE_FRAME:
513 case CATCH_FRAME:
514 case UNDERFLOW_FRAME:
515 case STOP_FRAME:
516 printObj((StgClosure*)sp);
517 continue;
518
519 case RET_SMALL:
520 debugBelch("RET_SMALL (%p)\n", info);
521 bitmap = info->layout.bitmap;
522 printSmallBitmap(spBottom, sp+1,
523 BITMAP_BITS(bitmap), BITMAP_SIZE(bitmap));
524 continue;
525
526 case RET_BCO: {
527 StgBCO *bco;
528
529 bco = ((StgBCO *)sp[1]);
530
531 debugBelch("RET_BCO (%p)\n", sp);
532 printLargeBitmap(spBottom, sp+2,
533 BCO_BITMAP(bco), BCO_BITMAP_SIZE(bco));
534 continue;
535 }
536
537 case RET_BIG:
538 barf("todo");
539
540 case RET_FUN:
541 {
542 StgFunInfoTable *fun_info;
543 StgRetFun *ret_fun;
544
545 ret_fun = (StgRetFun *)sp;
546 fun_info = get_fun_itbl(ret_fun->fun);
547 debugBelch("RET_FUN (%p) (type=%d)\n", ret_fun->fun, (int)fun_info->f.fun_type);
548 switch (fun_info->f.fun_type) {
549 case ARG_GEN:
550 printSmallBitmap(spBottom, sp+2,
551 BITMAP_BITS(fun_info->f.b.bitmap),
552 BITMAP_SIZE(fun_info->f.b.bitmap));
553 break;
554 case ARG_GEN_BIG:
555 printLargeBitmap(spBottom, sp+2,
556 GET_FUN_LARGE_BITMAP(fun_info),
557 GET_FUN_LARGE_BITMAP(fun_info)->size);
558 break;
559 default:
560 printSmallBitmap(spBottom, sp+2,
561 BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
562 BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]));
563 break;
564 }
565 continue;
566 }
567
568 default:
569 debugBelch("unknown object %d\n", (int)info->type);
570 barf("printStackChunk");
571 }
572 }
573 }
574
575 void printTSO( StgTSO *tso )
576 {
577 printStackChunk( tso->stackobj->sp,
578 tso->stackobj->stack+tso->stackobj->stack_size);
579 }
580
581 /* --------------------------------------------------------------------------
582 * Address printing code
583 *
584 * Uses symbol table in (unstripped executable)
585 * ------------------------------------------------------------------------*/
586
587 /* --------------------------------------------------------------------------
588 * Simple lookup table
589 * address -> function name
590 * ------------------------------------------------------------------------*/
591
592 static HashTable * add_to_fname_table = NULL;
593
594 const char *lookupGHCName( void *addr )
595 {
596 if (add_to_fname_table == NULL)
597 return NULL;
598
599 return lookupHashTable(add_to_fname_table, (StgWord)addr);
600 }
601
602 /* --------------------------------------------------------------------------
603 * Symbol table loading
604 * ------------------------------------------------------------------------*/
605
606 /* Causing linking trouble on Win32 plats, so I'm
607 disabling this for now.
608 */
609 #ifdef USING_LIBBFD
610 # define PACKAGE 1
611 # define PACKAGE_VERSION 1
612 /* Those PACKAGE_* defines are workarounds for bfd:
613 * https://sourceware.org/bugzilla/show_bug.cgi?id=14243
614 * ghc's build system filter PACKAGE_* values out specifically to avoid clashes
615 * with user's autoconf-based Cabal packages.
616 * It's a shame <bfd.h> checks for unrelated fields instead of actually used
617 * macros.
618 */
619 # include <bfd.h>
620
621 /* Fairly ad-hoc piece of code that seems to filter out a lot of
622 * rubbish like the obj-splitting symbols
623 */
624
625 static rtsBool isReal( flagword flags STG_UNUSED, const char *name )
626 {
627 #if 0
628 /* ToDo: make this work on BFD */
629 int tp = type & N_TYPE;
630 if (tp == N_TEXT || tp == N_DATA) {
631 return (name[0] == '_' && name[1] != '_');
632 } else {
633 return rtsFalse;
634 }
635 #else
636 if (*name == '\0' ||
637 (name[0] == 'g' && name[1] == 'c' && name[2] == 'c') ||
638 (name[0] == 'c' && name[1] == 'c' && name[2] == '.')) {
639 return rtsFalse;
640 }
641 return rtsTrue;
642 #endif
643 }
644
645 extern void DEBUG_LoadSymbols( char *name )
646 {
647 bfd* abfd;
648 char **matching;
649
650 bfd_init();
651 abfd = bfd_openr(name, "default");
652 if (abfd == NULL) {
653 barf("can't open executable %s to get symbol table", name);
654 }
655 if (!bfd_check_format_matches (abfd, bfd_object, &matching)) {
656 barf("mismatch");
657 }
658
659 {
660 long storage_needed;
661 asymbol **symbol_table;
662 long number_of_symbols;
663 long num_real_syms = 0;
664 long i;
665
666 storage_needed = bfd_get_symtab_upper_bound (abfd);
667
668 if (storage_needed < 0) {
669 barf("can't read symbol table");
670 }
671 symbol_table = (asymbol **) stgMallocBytes(storage_needed,"DEBUG_LoadSymbols");
672
673 number_of_symbols = bfd_canonicalize_symtab (abfd, symbol_table);
674
675 if (number_of_symbols < 0) {
676 barf("can't canonicalise symbol table");
677 }
678
679 if (add_to_fname_table == NULL)
680 add_to_fname_table = allocHashTable();
681
682 for( i = 0; i != number_of_symbols; ++i ) {
683 symbol_info info;
684 bfd_get_symbol_info(abfd,symbol_table[i],&info);
685 if (isReal(info.type, info.name)) {
686 insertHashTable(add_to_fname_table,
687 info.value, (void*)info.name);
688 num_real_syms += 1;
689 }
690 }
691
692 IF_DEBUG(interpreter,
693 debugBelch("Loaded %ld symbols. Of which %ld are real symbols\n",
694 number_of_symbols, num_real_syms)
695 );
696
697 stgFree(symbol_table);
698 }
699 }
700
701 #else /* USING_LIBBFD */
702
703 extern void DEBUG_LoadSymbols( char *name STG_UNUSED )
704 {
705 /* nothing, yet */
706 }
707
708 #endif /* USING_LIBBFD */
709
710 void findPtr(P_ p, int); /* keep gcc -Wall happy */
711
712 int searched = 0;
713
714 static int
715 findPtrBlocks (StgPtr p, bdescr *bd, StgPtr arr[], int arr_size, int i)
716 {
717 StgPtr q, r, end;
718 for (; bd; bd = bd->link) {
719 searched++;
720 for (q = bd->start; q < bd->free; q++) {
721 if (UNTAG_CLOSURE((StgClosure*)*q) == (StgClosure *)p) {
722 if (i < arr_size) {
723 for (r = bd->start; r < bd->free; r = end) {
724 // skip over zeroed-out slop
725 while (*r == 0) r++;
726 if (!LOOKS_LIKE_CLOSURE_PTR(r)) {
727 debugBelch("%p found at %p, no closure at %p\n",
728 p, q, r);
729 break;
730 }
731 end = r + closure_sizeW((StgClosure*)r);
732 if (q < end) {
733 debugBelch("%p = ", r);
734 printClosure((StgClosure *)r);
735 arr[i++] = r;
736 break;
737 }
738 }
739 if (r >= bd->free) {
740 debugBelch("%p found at %p, closure?", p, q);
741 }
742 } else {
743 return i;
744 }
745 }
746 }
747 }
748 return i;
749 }
750
751 void
752 findPtr(P_ p, int follow)
753 {
754 nat g, n;
755 bdescr *bd;
756 const int arr_size = 1024;
757 StgPtr arr[arr_size];
758 int i = 0;
759 searched = 0;
760
761 for (n = 0; n < n_capabilities; n++) {
762 bd = nurseries[i].blocks;
763 i = findPtrBlocks(p,bd,arr,arr_size,i);
764 if (i >= arr_size) return;
765 }
766
767 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
768 bd = generations[g].blocks;
769 i = findPtrBlocks(p,bd,arr,arr_size,i);
770 bd = generations[g].large_objects;
771 i = findPtrBlocks(p,bd,arr,arr_size,i);
772 if (i >= arr_size) return;
773 }
774 if (follow && i == 1) {
775 debugBelch("-->\n");
776 findPtr(arr[0], 1);
777 }
778 }
779
780 /* prettyPrintClosure() is for printing out a closure using the data constructor
781 names found in the info tables. Closures are printed in a fashion that resembles
782 their Haskell representation. Useful during debugging.
783
784 Todo: support for more closure types, and support for non pointer fields in the
785 payload.
786 */
787
788 void prettyPrintClosure_ (StgClosure *);
789
790 void prettyPrintClosure (StgClosure *obj)
791 {
792 prettyPrintClosure_ (obj);
793 debugBelch ("\n");
794 }
795
796 void prettyPrintClosure_ (StgClosure *obj)
797 {
798 StgInfoTable *info;
799 StgConInfoTable *con_info;
800
801 /* collapse any indirections */
802 unsigned int type;
803 type = get_itbl(obj)->type;
804
805 while (type == IND ||
806 type == IND_STATIC ||
807 type == IND_PERM)
808 {
809 obj = ((StgInd *)obj)->indirectee;
810 type = get_itbl(obj)->type;
811 }
812
813 /* find the info table for this object */
814 info = get_itbl(obj);
815
816 /* determine what kind of object we have */
817 switch (info->type)
818 {
819 /* full applications of data constructors */
820 case CONSTR:
821 case CONSTR_1_0:
822 case CONSTR_0_1:
823 case CONSTR_1_1:
824 case CONSTR_0_2:
825 case CONSTR_2_0:
826 case CONSTR_STATIC:
827 case CONSTR_NOCAF_STATIC:
828 {
829 nat i;
830 char *descriptor;
831
832 /* find the con_info for the constructor */
833 con_info = get_con_itbl (obj);
834
835 /* obtain the name of the constructor */
836 descriptor = GET_CON_DESC(con_info);
837
838 debugBelch ("(%s", descriptor);
839
840 /* process the payload of the closure */
841 /* we don't handle non pointers at the moment */
842 for (i = 0; i < info->layout.payload.ptrs; i++)
843 {
844 debugBelch (" ");
845 prettyPrintClosure_ ((StgClosure *) obj->payload[i]);
846 }
847 debugBelch (")");
848 break;
849 }
850
851 /* if it isn't a constructor then just print the closure type */
852 default:
853 {
854 debugBelch ("<%s>", info_type(obj));
855 break;
856 }
857 }
858 }
859
860 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
880 #endif /* DEBUG */
881
882 /* -----------------------------------------------------------------------------
883 Closure types
884
885 NOTE: must be kept in sync with the closure types in includes/ClosureTypes.h
886 -------------------------------------------------------------------------- */
887
888 char *closure_type_names[] = {
889 [INVALID_OBJECT] = "INVALID_OBJECT",
890 [CONSTR] = "CONSTR",
891 [CONSTR_1_0] = "CONSTR_1_0",
892 [CONSTR_0_1] = "CONSTR_0_1",
893 [CONSTR_2_0] = "CONSTR_2_0",
894 [CONSTR_1_1] = "CONSTR_1_1",
895 [CONSTR_0_2] = "CONSTR_0_2",
896 [CONSTR_STATIC] = "CONSTR_STATIC",
897 [CONSTR_NOCAF_STATIC] = "CONSTR_NOCAF_STATIC",
898 [FUN] = "FUN",
899 [FUN_1_0] = "FUN_1_0",
900 [FUN_0_1] = "FUN_0_1",
901 [FUN_2_0] = "FUN_2_0",
902 [FUN_1_1] = "FUN_1_1",
903 [FUN_0_2] = "FUN_0_2",
904 [FUN_STATIC] = "FUN_STATIC",
905 [THUNK] = "THUNK",
906 [THUNK_1_0] = "THUNK_1_0",
907 [THUNK_0_1] = "THUNK_0_1",
908 [THUNK_2_0] = "THUNK_2_0",
909 [THUNK_1_1] = "THUNK_1_1",
910 [THUNK_0_2] = "THUNK_0_2",
911 [THUNK_STATIC] = "THUNK_STATIC",
912 [THUNK_SELECTOR] = "THUNK_SELECTOR",
913 [BCO] = "BCO",
914 [AP] = "AP",
915 [PAP] = "PAP",
916 [AP_STACK] = "AP_STACK",
917 [IND] = "IND",
918 [IND_PERM] = "IND_PERM",
919 [IND_STATIC] = "IND_STATIC",
920 [RET_BCO] = "RET_BCO",
921 [RET_SMALL] = "RET_SMALL",
922 [RET_BIG] = "RET_BIG",
923 [RET_FUN] = "RET_FUN",
924 [UPDATE_FRAME] = "UPDATE_FRAME",
925 [CATCH_FRAME] = "CATCH_FRAME",
926 [UNDERFLOW_FRAME] = "UNDERFLOW_FRAME",
927 [STOP_FRAME] = "STOP_FRAME",
928 [BLOCKING_QUEUE] = "BLOCKING_QUEUE",
929 [BLACKHOLE] = "BLACKHOLE",
930 [MVAR_CLEAN] = "MVAR_CLEAN",
931 [MVAR_DIRTY] = "MVAR_DIRTY",
932 [TVAR] = "TVAR",
933 [ARR_WORDS] = "ARR_WORDS",
934 [MUT_ARR_PTRS_CLEAN] = "MUT_ARR_PTRS_CLEAN",
935 [MUT_ARR_PTRS_DIRTY] = "MUT_ARR_PTRS_DIRTY",
936 [MUT_ARR_PTRS_FROZEN0] = "MUT_ARR_PTRS_FROZEN0",
937 [MUT_ARR_PTRS_FROZEN] = "MUT_ARR_PTRS_FROZEN",
938 [MUT_VAR_CLEAN] = "MUT_VAR_CLEAN",
939 [MUT_VAR_DIRTY] = "MUT_VAR_DIRTY",
940 [WEAK] = "WEAK",
941 [PRIM] = "PRIM",
942 [MUT_PRIM] = "MUT_PRIM",
943 [TSO] = "TSO",
944 [STACK] = "STACK",
945 [TREC_CHUNK] = "TREC_CHUNK",
946 [ATOMICALLY_FRAME] = "ATOMICALLY_FRAME",
947 [CATCH_RETRY_FRAME] = "CATCH_RETRY_FRAME",
948 [CATCH_STM_FRAME] = "CATCH_STM_FRAME",
949 [WHITEHOLE] = "WHITEHOLE"
950 };
951
952 char *
953 info_type(StgClosure *closure){
954 return closure_type_names[get_itbl(closure)->type];
955 }
956
957 char *
958 info_type_by_ip(StgInfoTable *ip){
959 return closure_type_names[ip->type];
960 }
961
962 void
963 info_hdr_type(StgClosure *closure, char *res){
964 strcpy(res,closure_type_names[get_itbl(closure)->type]);
965 }
966