Kill Type pretty-printer
[ghc.git] / rts / RetainerProfile.c
1 /* -----------------------------------------------------------------------------
2 *
3 * (c) The GHC Team, 2001
4 * Author: Sungwoo Park
5 *
6 * Retainer profiling.
7 *
8 * ---------------------------------------------------------------------------*/
9
10 #ifdef PROFILING
11
12 // Turn off inlining when debugging - it obfuscates things
13 #ifdef DEBUG
14 #define INLINE
15 #else
16 #define INLINE inline
17 #endif
18
19 #include "PosixSource.h"
20 #include "Rts.h"
21
22 #include "RtsUtils.h"
23 #include "RetainerProfile.h"
24 #include "RetainerSet.h"
25 #include "Schedule.h"
26 #include "Printer.h"
27 #include "Weak.h"
28 #include "sm/Sanity.h"
29 #include "Profiling.h"
30 #include "Stats.h"
31 #include "ProfHeap.h"
32 #include "Apply.h"
33 #include "Stable.h" /* markStableTables */
34 #include "sm/Storage.h" // for END_OF_STATIC_LIST
35
36 /*
37 Note: what to change in order to plug-in a new retainer profiling scheme?
38 (1) type retainer in ../includes/StgRetainerProf.h
39 (2) retainer function R(), i.e., getRetainerFrom()
40 (3) the two hashing functions, hashKeySingleton() and hashKeyAddElement(),
41 in RetainerSet.h, if needed.
42 (4) printRetainer() and printRetainerSetShort() in RetainerSet.c.
43 */
44
45 /* -----------------------------------------------------------------------------
46 * Declarations...
47 * -------------------------------------------------------------------------- */
48
49 static uint32_t retainerGeneration; // generation
50
51 static uint32_t numObjectVisited; // total number of objects visited
52 static uint32_t timesAnyObjectVisited; // number of times any objects are
53 // visited
54
55 /*
56 The rs field in the profile header of any object points to its retainer
57 set in an indirect way: if flip is 0, it points to the retainer set;
58 if flip is 1, it points to the next byte after the retainer set (even
59 for NULL pointers). Therefore, with flip 1, (rs ^ 1) is the actual
60 pointer. See retainerSetOf().
61 */
62
63 StgWord flip = 0; // flip bit
64 // must be 0 if DEBUG_RETAINER is on (for static closures)
65
66 #define setRetainerSetToNull(c) \
67 (c)->header.prof.hp.rs = (RetainerSet *)((StgWord)NULL | flip)
68
69 static void retainStack(StgClosure *, retainer, StgPtr, StgPtr);
70 static void retainClosure(StgClosure *, StgClosure *, retainer);
71 #ifdef DEBUG_RETAINER
72 static void belongToHeap(StgPtr p);
73 #endif
74
75 #ifdef DEBUG_RETAINER
76 /*
77 cStackSize records how many times retainStack() has been invoked recursively,
78 that is, the number of activation records for retainStack() on the C stack.
79 maxCStackSize records its max value.
80 Invariants:
81 cStackSize <= maxCStackSize
82 */
83 static uint32_t cStackSize, maxCStackSize;
84
85 static uint32_t sumOfNewCost; // sum of the cost of each object, computed
86 // when the object is first visited
87 static uint32_t sumOfNewCostExtra; // for those objects not visited during
88 // retainer profiling, e.g., MUT_VAR
89 static uint32_t costArray[N_CLOSURE_TYPES];
90
91 uint32_t sumOfCostLinear; // sum of the costs of all object, computed
92 // when linearly traversing the heap after
93 // retainer profiling
94 uint32_t costArrayLinear[N_CLOSURE_TYPES];
95 #endif
96
97 /* -----------------------------------------------------------------------------
98 * Retainer stack - header
99 * Note:
100 * Although the retainer stack implementation could be separated *
101 * from the retainer profiling engine, there does not seem to be
102 * any advantage in doing that; retainer stack is an integral part
103 * of retainer profiling engine and cannot be use elsewhere at
104 * all.
105 * -------------------------------------------------------------------------- */
106
107 typedef enum {
108 posTypeStep,
109 posTypePtrs,
110 posTypeSRT,
111 posTypeLargeSRT,
112 } nextPosType;
113
114 typedef union {
115 // fixed layout or layout specified by a field in the closure
116 StgWord step;
117
118 // layout.payload
119 struct {
120 // See StgClosureInfo in InfoTables.h
121 StgHalfWord pos;
122 StgHalfWord ptrs;
123 StgPtr payload;
124 } ptrs;
125
126 // SRT
127 struct {
128 StgClosure **srt;
129 StgWord srt_bitmap;
130 } srt;
131
132 // Large SRT
133 struct {
134 StgLargeSRT *srt;
135 StgWord offset;
136 } large_srt;
137
138 } nextPos;
139
140 typedef struct {
141 nextPosType type;
142 nextPos next;
143 } stackPos;
144
145 typedef struct {
146 StgClosure *c;
147 retainer c_child_r;
148 stackPos info;
149 } stackElement;
150
151 /*
152 Invariants:
153 firstStack points to the first block group.
154 currentStack points to the block group currently being used.
155 currentStack->free == stackLimit.
156 stackTop points to the topmost byte in the stack of currentStack.
157 Unless the whole stack is empty, stackTop must point to the topmost
158 object (or byte) in the whole stack. Thus, it is only when the whole stack
159 is empty that stackTop == stackLimit (not during the execution of push()
160 and pop()).
161 stackBottom == currentStack->start.
162 stackLimit == currentStack->start + BLOCK_SIZE_W * currentStack->blocks.
163 Note:
164 When a current stack becomes empty, stackTop is set to point to
165 the topmost element on the previous block group so as to satisfy
166 the invariants described above.
167 */
168 static bdescr *firstStack = NULL;
169 static bdescr *currentStack;
170 static stackElement *stackBottom, *stackTop, *stackLimit;
171
172 /*
173 currentStackBoundary is used to mark the current stack chunk.
174 If stackTop == currentStackBoundary, it means that the current stack chunk
175 is empty. It is the responsibility of the user to keep currentStackBoundary
176 valid all the time if it is to be employed.
177 */
178 static stackElement *currentStackBoundary;
179
180 /*
181 stackSize records the current size of the stack.
182 maxStackSize records its high water mark.
183 Invariants:
184 stackSize <= maxStackSize
185 Note:
186 stackSize is just an estimate measure of the depth of the graph. The reason
187 is that some heap objects have only a single child and may not result
188 in a new element being pushed onto the stack. Therefore, at the end of
189 retainer profiling, maxStackSize + maxCStackSize is some value no greater
190 than the actual depth of the graph.
191 */
192 #ifdef DEBUG_RETAINER
193 static int stackSize, maxStackSize;
194 #endif
195
196 // number of blocks allocated for one stack
197 #define BLOCKS_IN_STACK 1
198
199 /* -----------------------------------------------------------------------------
200 * Add a new block group to the stack.
201 * Invariants:
202 * currentStack->link == s.
203 * -------------------------------------------------------------------------- */
204 static INLINE void
205 newStackBlock( bdescr *bd )
206 {
207 currentStack = bd;
208 stackTop = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
209 stackBottom = (stackElement *)bd->start;
210 stackLimit = (stackElement *)stackTop;
211 bd->free = (StgPtr)stackLimit;
212 }
213
214 /* -----------------------------------------------------------------------------
215 * Return to the previous block group.
216 * Invariants:
217 * s->link == currentStack.
218 * -------------------------------------------------------------------------- */
219 static INLINE void
220 returnToOldStack( bdescr *bd )
221 {
222 currentStack = bd;
223 stackTop = (stackElement *)bd->free;
224 stackBottom = (stackElement *)bd->start;
225 stackLimit = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
226 bd->free = (StgPtr)stackLimit;
227 }
228
229 /* -----------------------------------------------------------------------------
230 * Initializes the traverse stack.
231 * -------------------------------------------------------------------------- */
232 static void
233 initializeTraverseStack( void )
234 {
235 if (firstStack != NULL) {
236 freeChain(firstStack);
237 }
238
239 firstStack = allocGroup(BLOCKS_IN_STACK);
240 firstStack->link = NULL;
241 firstStack->u.back = NULL;
242
243 newStackBlock(firstStack);
244 }
245
246 /* -----------------------------------------------------------------------------
247 * Frees all the block groups in the traverse stack.
248 * Invariants:
249 * firstStack != NULL
250 * -------------------------------------------------------------------------- */
251 static void
252 closeTraverseStack( void )
253 {
254 freeChain(firstStack);
255 firstStack = NULL;
256 }
257
258 /* -----------------------------------------------------------------------------
259 * Returns rtsTrue if the whole stack is empty.
260 * -------------------------------------------------------------------------- */
261 static INLINE rtsBool
262 isEmptyRetainerStack( void )
263 {
264 return (firstStack == currentStack) && stackTop == stackLimit;
265 }
266
267 /* -----------------------------------------------------------------------------
268 * Returns size of stack
269 * -------------------------------------------------------------------------- */
270 #ifdef DEBUG
271 W_
272 retainerStackBlocks( void )
273 {
274 bdescr* bd;
275 W_ res = 0;
276
277 for (bd = firstStack; bd != NULL; bd = bd->link)
278 res += bd->blocks;
279
280 return res;
281 }
282 #endif
283
284 /* -----------------------------------------------------------------------------
285 * Returns rtsTrue if stackTop is at the stack boundary of the current stack,
286 * i.e., if the current stack chunk is empty.
287 * -------------------------------------------------------------------------- */
288 static INLINE rtsBool
289 isOnBoundary( void )
290 {
291 return stackTop == currentStackBoundary;
292 }
293
294 /* -----------------------------------------------------------------------------
295 * Initializes *info from ptrs and payload.
296 * Invariants:
297 * payload[] begins with ptrs pointers followed by non-pointers.
298 * -------------------------------------------------------------------------- */
299 static INLINE void
300 init_ptrs( stackPos *info, uint32_t ptrs, StgPtr payload )
301 {
302 info->type = posTypePtrs;
303 info->next.ptrs.pos = 0;
304 info->next.ptrs.ptrs = ptrs;
305 info->next.ptrs.payload = payload;
306 }
307
308 /* -----------------------------------------------------------------------------
309 * Find the next object from *info.
310 * -------------------------------------------------------------------------- */
311 static INLINE StgClosure *
312 find_ptrs( stackPos *info )
313 {
314 if (info->next.ptrs.pos < info->next.ptrs.ptrs) {
315 return (StgClosure *)info->next.ptrs.payload[info->next.ptrs.pos++];
316 } else {
317 return NULL;
318 }
319 }
320
321 /* -----------------------------------------------------------------------------
322 * Initializes *info from SRT information stored in *infoTable.
323 * -------------------------------------------------------------------------- */
324 static INLINE void
325 init_srt_fun( stackPos *info, StgFunInfoTable *infoTable )
326 {
327 if (infoTable->i.srt_bitmap == (StgHalfWord)(-1)) {
328 info->type = posTypeLargeSRT;
329 info->next.large_srt.srt = (StgLargeSRT *)GET_FUN_SRT(infoTable);
330 info->next.large_srt.offset = 0;
331 } else {
332 info->type = posTypeSRT;
333 info->next.srt.srt = (StgClosure **)GET_FUN_SRT(infoTable);
334 info->next.srt.srt_bitmap = infoTable->i.srt_bitmap;
335 }
336 }
337
338 static INLINE void
339 init_srt_thunk( stackPos *info, StgThunkInfoTable *infoTable )
340 {
341 if (infoTable->i.srt_bitmap == (StgHalfWord)(-1)) {
342 info->type = posTypeLargeSRT;
343 info->next.large_srt.srt = (StgLargeSRT *)GET_SRT(infoTable);
344 info->next.large_srt.offset = 0;
345 } else {
346 info->type = posTypeSRT;
347 info->next.srt.srt = (StgClosure **)GET_SRT(infoTable);
348 info->next.srt.srt_bitmap = infoTable->i.srt_bitmap;
349 }
350 }
351
352 /* -----------------------------------------------------------------------------
353 * Find the next object from *info.
354 * -------------------------------------------------------------------------- */
355 static INLINE StgClosure *
356 find_srt( stackPos *info )
357 {
358 StgClosure *c;
359 StgWord bitmap;
360
361 if (info->type == posTypeSRT) {
362 // Small SRT bitmap
363 bitmap = info->next.srt.srt_bitmap;
364 while (bitmap != 0) {
365 if ((bitmap & 1) != 0) {
366 #if defined(COMPILING_WINDOWS_DLL)
367 if ((unsigned long)(*(info->next.srt.srt)) & 0x1)
368 c = (* (StgClosure **)((unsigned long)*(info->next.srt.srt)) & ~0x1);
369 else
370 c = *(info->next.srt.srt);
371 #else
372 c = *(info->next.srt.srt);
373 #endif
374 bitmap = bitmap >> 1;
375 info->next.srt.srt++;
376 info->next.srt.srt_bitmap = bitmap;
377 return c;
378 }
379 bitmap = bitmap >> 1;
380 info->next.srt.srt++;
381 }
382 // bitmap is now zero...
383 return NULL;
384 }
385 else {
386 // Large SRT bitmap
387 uint32_t i = info->next.large_srt.offset;
388 StgWord bitmap;
389
390 // Follow the pattern from GC.c:scavenge_large_srt_bitmap().
391 bitmap = info->next.large_srt.srt->l.bitmap[i / BITS_IN(W_)];
392 bitmap = bitmap >> (i % BITS_IN(StgWord));
393 while (i < info->next.large_srt.srt->l.size) {
394 if ((bitmap & 1) != 0) {
395 c = ((StgClosure **)info->next.large_srt.srt->srt)[i];
396 i++;
397 info->next.large_srt.offset = i;
398 return c;
399 }
400 i++;
401 if (i % BITS_IN(W_) == 0) {
402 bitmap = info->next.large_srt.srt->l.bitmap[i / BITS_IN(W_)];
403 } else {
404 bitmap = bitmap >> 1;
405 }
406 }
407 // reached the end of this bitmap.
408 info->next.large_srt.offset = i;
409 return NULL;
410 }
411 }
412
413 /* -----------------------------------------------------------------------------
414 * push() pushes a stackElement representing the next child of *c
415 * onto the traverse stack. If *c has no child, *first_child is set
416 * to NULL and nothing is pushed onto the stack. If *c has only one
417 * child, *c_chlid is set to that child and nothing is pushed onto
418 * the stack. If *c has more than two children, *first_child is set
419 * to the first child and a stackElement representing the second
420 * child is pushed onto the stack.
421
422 * Invariants:
423 * *c_child_r is the most recent retainer of *c's children.
424 * *c is not any of TSO, AP, PAP, AP_STACK, which means that
425 * there cannot be any stack objects.
426 * Note: SRTs are considered to be children as well.
427 * -------------------------------------------------------------------------- */
428 static INLINE void
429 push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
430 {
431 stackElement se;
432 bdescr *nbd; // Next Block Descriptor
433
434 #ifdef DEBUG_RETAINER
435 // debugBelch("push(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
436 #endif
437
438 ASSERT(get_itbl(c)->type != TSO);
439 ASSERT(get_itbl(c)->type != AP_STACK);
440
441 //
442 // fill in se
443 //
444
445 se.c = c;
446 se.c_child_r = c_child_r;
447
448 // fill in se.info
449 switch (get_itbl(c)->type) {
450 // no child, no SRT
451 case CONSTR_0_1:
452 case CONSTR_0_2:
453 case ARR_WORDS:
454 case COMPACT_NFDATA:
455 *first_child = NULL;
456 return;
457
458 // one child (fixed), no SRT
459 case MUT_VAR_CLEAN:
460 case MUT_VAR_DIRTY:
461 *first_child = ((StgMutVar *)c)->var;
462 return;
463 case THUNK_SELECTOR:
464 *first_child = ((StgSelector *)c)->selectee;
465 return;
466 case BLACKHOLE:
467 *first_child = ((StgInd *)c)->indirectee;
468 return;
469 case CONSTR_1_0:
470 case CONSTR_1_1:
471 *first_child = c->payload[0];
472 return;
473
474 // For CONSTR_2_0 and MVAR, we use se.info.step to record the position
475 // of the next child. We do not write a separate initialization code.
476 // Also we do not have to initialize info.type;
477
478 // two children (fixed), no SRT
479 // need to push a stackElement, but nothing to store in se.info
480 case CONSTR_2_0:
481 *first_child = c->payload[0]; // return the first pointer
482 // se.info.type = posTypeStep;
483 // se.info.next.step = 2; // 2 = second
484 break;
485
486 // three children (fixed), no SRT
487 // need to push a stackElement
488 case MVAR_CLEAN:
489 case MVAR_DIRTY:
490 // head must be TSO and the head of a linked list of TSOs.
491 // Shoule it be a child? Seems to be yes.
492 *first_child = (StgClosure *)((StgMVar *)c)->head;
493 // se.info.type = posTypeStep;
494 se.info.next.step = 2; // 2 = second
495 break;
496
497 // three children (fixed), no SRT
498 case WEAK:
499 *first_child = ((StgWeak *)c)->key;
500 // se.info.type = posTypeStep;
501 se.info.next.step = 2;
502 break;
503
504 // layout.payload.ptrs, no SRT
505 case TVAR:
506 case CONSTR:
507 case PRIM:
508 case MUT_PRIM:
509 case BCO:
510 case CONSTR_STATIC:
511 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
512 (StgPtr)c->payload);
513 *first_child = find_ptrs(&se.info);
514 if (*first_child == NULL)
515 return; // no child
516 break;
517
518 // StgMutArrPtr.ptrs, no SRT
519 case MUT_ARR_PTRS_CLEAN:
520 case MUT_ARR_PTRS_DIRTY:
521 case MUT_ARR_PTRS_FROZEN:
522 case MUT_ARR_PTRS_FROZEN0:
523 init_ptrs(&se.info, ((StgMutArrPtrs *)c)->ptrs,
524 (StgPtr)(((StgMutArrPtrs *)c)->payload));
525 *first_child = find_ptrs(&se.info);
526 if (*first_child == NULL)
527 return;
528 break;
529
530 // StgMutArrPtr.ptrs, no SRT
531 case SMALL_MUT_ARR_PTRS_CLEAN:
532 case SMALL_MUT_ARR_PTRS_DIRTY:
533 case SMALL_MUT_ARR_PTRS_FROZEN:
534 case SMALL_MUT_ARR_PTRS_FROZEN0:
535 init_ptrs(&se.info, ((StgSmallMutArrPtrs *)c)->ptrs,
536 (StgPtr)(((StgSmallMutArrPtrs *)c)->payload));
537 *first_child = find_ptrs(&se.info);
538 if (*first_child == NULL)
539 return;
540 break;
541
542 // layout.payload.ptrs, SRT
543 case FUN: // *c is a heap object.
544 case FUN_2_0:
545 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
546 *first_child = find_ptrs(&se.info);
547 if (*first_child == NULL)
548 // no child from ptrs, so check SRT
549 goto fun_srt_only;
550 break;
551
552 case THUNK:
553 case THUNK_2_0:
554 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
555 (StgPtr)((StgThunk *)c)->payload);
556 *first_child = find_ptrs(&se.info);
557 if (*first_child == NULL)
558 // no child from ptrs, so check SRT
559 goto thunk_srt_only;
560 break;
561
562 // 1 fixed child, SRT
563 case FUN_1_0:
564 case FUN_1_1:
565 *first_child = c->payload[0];
566 ASSERT(*first_child != NULL);
567 init_srt_fun(&se.info, get_fun_itbl(c));
568 break;
569
570 case THUNK_1_0:
571 case THUNK_1_1:
572 *first_child = ((StgThunk *)c)->payload[0];
573 ASSERT(*first_child != NULL);
574 init_srt_thunk(&se.info, get_thunk_itbl(c));
575 break;
576
577 case FUN_STATIC: // *c is a heap object.
578 ASSERT(get_itbl(c)->srt_bitmap != 0);
579 case FUN_0_1:
580 case FUN_0_2:
581 fun_srt_only:
582 init_srt_fun(&se.info, get_fun_itbl(c));
583 *first_child = find_srt(&se.info);
584 if (*first_child == NULL)
585 return; // no child
586 break;
587
588 // SRT only
589 case THUNK_STATIC:
590 ASSERT(get_itbl(c)->srt_bitmap != 0);
591 case THUNK_0_1:
592 case THUNK_0_2:
593 thunk_srt_only:
594 init_srt_thunk(&se.info, get_thunk_itbl(c));
595 *first_child = find_srt(&se.info);
596 if (*first_child == NULL)
597 return; // no child
598 break;
599
600 case TREC_CHUNK:
601 *first_child = (StgClosure *)((StgTRecChunk *)c)->prev_chunk;
602 se.info.next.step = 0; // entry no.
603 break;
604
605 // cannot appear
606 case PAP:
607 case AP:
608 case AP_STACK:
609 case TSO:
610 case STACK:
611 case IND_STATIC:
612 case CONSTR_NOCAF_STATIC:
613 // stack objects
614 case UPDATE_FRAME:
615 case CATCH_FRAME:
616 case UNDERFLOW_FRAME:
617 case STOP_FRAME:
618 case RET_BCO:
619 case RET_SMALL:
620 case RET_BIG:
621 // invalid objects
622 case IND:
623 case INVALID_OBJECT:
624 default:
625 barf("Invalid object *c in push()");
626 return;
627 }
628
629 if (stackTop - 1 < stackBottom) {
630 #ifdef DEBUG_RETAINER
631 // debugBelch("push() to the next stack.\n");
632 #endif
633 // currentStack->free is updated when the active stack is switched
634 // to the next stack.
635 currentStack->free = (StgPtr)stackTop;
636
637 if (currentStack->link == NULL) {
638 nbd = allocGroup(BLOCKS_IN_STACK);
639 nbd->link = NULL;
640 nbd->u.back = currentStack;
641 currentStack->link = nbd;
642 } else
643 nbd = currentStack->link;
644
645 newStackBlock(nbd);
646 }
647
648 // adjust stackTop (acutal push)
649 stackTop--;
650 // If the size of stackElement was huge, we would better replace the
651 // following statement by either a memcpy() call or a switch statement
652 // on the type of the element. Currently, the size of stackElement is
653 // small enough (5 words) that this direct assignment seems to be enough.
654
655 // ToDo: The line below leads to the warning:
656 // warning: 'se.info.type' may be used uninitialized in this function
657 // This is caused by the fact that there are execution paths through the
658 // large switch statement above where some cases do not initialize this
659 // field. Is this really harmless? Can we avoid the warning?
660 *stackTop = se;
661
662 #ifdef DEBUG_RETAINER
663 stackSize++;
664 if (stackSize > maxStackSize) maxStackSize = stackSize;
665 // ASSERT(stackSize >= 0);
666 // debugBelch("stackSize = %d\n", stackSize);
667 #endif
668 }
669
670 /* -----------------------------------------------------------------------------
671 * popOff() and popOffReal(): Pop a stackElement off the traverse stack.
672 * Invariants:
673 * stackTop cannot be equal to stackLimit unless the whole stack is
674 * empty, in which case popOff() is not allowed.
675 * Note:
676 * You can think of popOffReal() as a part of popOff() which is
677 * executed at the end of popOff() in necessary. Since popOff() is
678 * likely to be executed quite often while popOffReal() is not, we
679 * separate popOffReal() from popOff(), which is declared as an
680 * INLINE function (for the sake of execution speed). popOffReal()
681 * is called only within popOff() and nowhere else.
682 * -------------------------------------------------------------------------- */
683 static void
684 popOffReal(void)
685 {
686 bdescr *pbd; // Previous Block Descriptor
687
688 #ifdef DEBUG_RETAINER
689 // debugBelch("pop() to the previous stack.\n");
690 #endif
691
692 ASSERT(stackTop + 1 == stackLimit);
693 ASSERT(stackBottom == (stackElement *)currentStack->start);
694
695 if (firstStack == currentStack) {
696 // The stack is completely empty.
697 stackTop++;
698 ASSERT(stackTop == stackLimit);
699 #ifdef DEBUG_RETAINER
700 stackSize--;
701 if (stackSize > maxStackSize) maxStackSize = stackSize;
702 /*
703 ASSERT(stackSize >= 0);
704 debugBelch("stackSize = %d\n", stackSize);
705 */
706 #endif
707 return;
708 }
709
710 // currentStack->free is updated when the active stack is switched back
711 // to the previous stack.
712 currentStack->free = (StgPtr)stackLimit;
713
714 // find the previous block descriptor
715 pbd = currentStack->u.back;
716 ASSERT(pbd != NULL);
717
718 returnToOldStack(pbd);
719
720 #ifdef DEBUG_RETAINER
721 stackSize--;
722 if (stackSize > maxStackSize) maxStackSize = stackSize;
723 /*
724 ASSERT(stackSize >= 0);
725 debugBelch("stackSize = %d\n", stackSize);
726 */
727 #endif
728 }
729
730 static INLINE void
731 popOff(void) {
732 #ifdef DEBUG_RETAINER
733 // debugBelch("\tpopOff(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
734 #endif
735
736 ASSERT(stackTop != stackLimit);
737 ASSERT(!isEmptyRetainerStack());
738
739 // <= (instead of <) is wrong!
740 if (stackTop + 1 < stackLimit) {
741 stackTop++;
742 #ifdef DEBUG_RETAINER
743 stackSize--;
744 if (stackSize > maxStackSize) maxStackSize = stackSize;
745 /*
746 ASSERT(stackSize >= 0);
747 debugBelch("stackSize = %d\n", stackSize);
748 */
749 #endif
750 return;
751 }
752
753 popOffReal();
754 }
755
756 /* -----------------------------------------------------------------------------
757 * Finds the next object to be considered for retainer profiling and store
758 * its pointer to *c.
759 * Test if the topmost stack element indicates that more objects are left,
760 * and if so, retrieve the first object and store its pointer to *c. Also,
761 * set *cp and *r appropriately, both of which are stored in the stack element.
762 * The topmost stack element then is overwritten so as for it to now denote
763 * the next object.
764 * If the topmost stack element indicates no more objects are left, pop
765 * off the stack element until either an object can be retrieved or
766 * the current stack chunk becomes empty, indicated by rtsTrue returned by
767 * isOnBoundary(), in which case *c is set to NULL.
768 * Note:
769 * It is okay to call this function even when the current stack chunk
770 * is empty.
771 * -------------------------------------------------------------------------- */
772 static INLINE void
773 pop( StgClosure **c, StgClosure **cp, retainer *r )
774 {
775 stackElement *se;
776
777 #ifdef DEBUG_RETAINER
778 // debugBelch("pop(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
779 #endif
780
781 do {
782 if (isOnBoundary()) { // if the current stack chunk is depleted
783 *c = NULL;
784 return;
785 }
786
787 se = stackTop;
788
789 switch (get_itbl(se->c)->type) {
790 // two children (fixed), no SRT
791 // nothing in se.info
792 case CONSTR_2_0:
793 *c = se->c->payload[1];
794 *cp = se->c;
795 *r = se->c_child_r;
796 popOff();
797 return;
798
799 // three children (fixed), no SRT
800 // need to push a stackElement
801 case MVAR_CLEAN:
802 case MVAR_DIRTY:
803 if (se->info.next.step == 2) {
804 *c = (StgClosure *)((StgMVar *)se->c)->tail;
805 se->info.next.step++; // move to the next step
806 // no popOff
807 } else {
808 *c = ((StgMVar *)se->c)->value;
809 popOff();
810 }
811 *cp = se->c;
812 *r = se->c_child_r;
813 return;
814
815 // three children (fixed), no SRT
816 case WEAK:
817 if (se->info.next.step == 2) {
818 *c = ((StgWeak *)se->c)->value;
819 se->info.next.step++;
820 // no popOff
821 } else {
822 *c = ((StgWeak *)se->c)->finalizer;
823 popOff();
824 }
825 *cp = se->c;
826 *r = se->c_child_r;
827 return;
828
829 case TREC_CHUNK: {
830 // These are pretty complicated: we have N entries, each
831 // of which contains 3 fields that we want to follow. So
832 // we divide the step counter: the 2 low bits indicate
833 // which field, and the rest of the bits indicate the
834 // entry number (starting from zero).
835 TRecEntry *entry;
836 uint32_t entry_no = se->info.next.step >> 2;
837 uint32_t field_no = se->info.next.step & 3;
838 if (entry_no == ((StgTRecChunk *)se->c)->next_entry_idx) {
839 *c = NULL;
840 popOff();
841 return;
842 }
843 entry = &((StgTRecChunk *)se->c)->entries[entry_no];
844 if (field_no == 0) {
845 *c = (StgClosure *)entry->tvar;
846 } else if (field_no == 1) {
847 *c = entry->expected_value;
848 } else {
849 *c = entry->new_value;
850 }
851 *cp = se->c;
852 *r = se->c_child_r;
853 se->info.next.step++;
854 return;
855 }
856
857 case TVAR:
858 case CONSTR:
859 case PRIM:
860 case MUT_PRIM:
861 case BCO:
862 case CONSTR_STATIC:
863 // StgMutArrPtr.ptrs, no SRT
864 case MUT_ARR_PTRS_CLEAN:
865 case MUT_ARR_PTRS_DIRTY:
866 case MUT_ARR_PTRS_FROZEN:
867 case MUT_ARR_PTRS_FROZEN0:
868 *c = find_ptrs(&se->info);
869 if (*c == NULL) {
870 popOff();
871 break;
872 }
873 *cp = se->c;
874 *r = se->c_child_r;
875 return;
876
877 // layout.payload.ptrs, SRT
878 case FUN: // always a heap object
879 case FUN_2_0:
880 if (se->info.type == posTypePtrs) {
881 *c = find_ptrs(&se->info);
882 if (*c != NULL) {
883 *cp = se->c;
884 *r = se->c_child_r;
885 return;
886 }
887 init_srt_fun(&se->info, get_fun_itbl(se->c));
888 }
889 goto do_srt;
890
891 case THUNK:
892 case THUNK_2_0:
893 if (se->info.type == posTypePtrs) {
894 *c = find_ptrs(&se->info);
895 if (*c != NULL) {
896 *cp = se->c;
897 *r = se->c_child_r;
898 return;
899 }
900 init_srt_thunk(&se->info, get_thunk_itbl(se->c));
901 }
902 goto do_srt;
903
904 // SRT
905 do_srt:
906 case THUNK_STATIC:
907 case FUN_STATIC:
908 case FUN_0_1:
909 case FUN_0_2:
910 case THUNK_0_1:
911 case THUNK_0_2:
912 case FUN_1_0:
913 case FUN_1_1:
914 case THUNK_1_0:
915 case THUNK_1_1:
916 *c = find_srt(&se->info);
917 if (*c != NULL) {
918 *cp = se->c;
919 *r = se->c_child_r;
920 return;
921 }
922 popOff();
923 break;
924
925 // no child (fixed), no SRT
926 case CONSTR_0_1:
927 case CONSTR_0_2:
928 case ARR_WORDS:
929 // one child (fixed), no SRT
930 case MUT_VAR_CLEAN:
931 case MUT_VAR_DIRTY:
932 case THUNK_SELECTOR:
933 case CONSTR_1_1:
934 // cannot appear
935 case PAP:
936 case AP:
937 case AP_STACK:
938 case TSO:
939 case STACK:
940 case IND_STATIC:
941 case CONSTR_NOCAF_STATIC:
942 // stack objects
943 case UPDATE_FRAME:
944 case CATCH_FRAME:
945 case UNDERFLOW_FRAME:
946 case STOP_FRAME:
947 case RET_BCO:
948 case RET_SMALL:
949 case RET_BIG:
950 // invalid objects
951 case IND:
952 case INVALID_OBJECT:
953 default:
954 barf("Invalid object *c in pop()");
955 return;
956 }
957 } while (rtsTrue);
958 }
959
960 /* -----------------------------------------------------------------------------
961 * RETAINER PROFILING ENGINE
962 * -------------------------------------------------------------------------- */
963
964 void
965 initRetainerProfiling( void )
966 {
967 initializeAllRetainerSet();
968 retainerGeneration = 0;
969 }
970
971 /* -----------------------------------------------------------------------------
972 * This function must be called before f-closing prof_file.
973 * -------------------------------------------------------------------------- */
974 void
975 endRetainerProfiling( void )
976 {
977 #ifdef SECOND_APPROACH
978 outputAllRetainerSet(prof_file);
979 #endif
980 }
981
982 /* -----------------------------------------------------------------------------
983 * Returns the actual pointer to the retainer set of the closure *c.
984 * It may adjust RSET(c) subject to flip.
985 * Side effects:
986 * RSET(c) is initialized to NULL if its current value does not
987 * conform to flip.
988 * Note:
989 * Even though this function has side effects, they CAN be ignored because
990 * subsequent calls to retainerSetOf() always result in the same return value
991 * and retainerSetOf() is the only way to retrieve retainerSet of a given
992 * closure.
993 * We have to perform an XOR (^) operation each time a closure is examined.
994 * The reason is that we do not know when a closure is visited last.
995 * -------------------------------------------------------------------------- */
996 static INLINE void
997 maybeInitRetainerSet( StgClosure *c )
998 {
999 if (!isRetainerSetFieldValid(c)) {
1000 setRetainerSetToNull(c);
1001 }
1002 }
1003
1004 /* -----------------------------------------------------------------------------
1005 * Returns rtsTrue if *c is a retainer.
1006 * -------------------------------------------------------------------------- */
1007 static INLINE rtsBool
1008 isRetainer( StgClosure *c )
1009 {
1010 switch (get_itbl(c)->type) {
1011 //
1012 // True case
1013 //
1014 // TSOs MUST be retainers: they constitute the set of roots.
1015 case TSO:
1016 case STACK:
1017
1018 // mutable objects
1019 case MUT_PRIM:
1020 case MVAR_CLEAN:
1021 case MVAR_DIRTY:
1022 case TVAR:
1023 case MUT_VAR_CLEAN:
1024 case MUT_VAR_DIRTY:
1025 case MUT_ARR_PTRS_CLEAN:
1026 case MUT_ARR_PTRS_DIRTY:
1027
1028 // thunks are retainers.
1029 case THUNK:
1030 case THUNK_1_0:
1031 case THUNK_0_1:
1032 case THUNK_2_0:
1033 case THUNK_1_1:
1034 case THUNK_0_2:
1035 case THUNK_SELECTOR:
1036 case AP:
1037 case AP_STACK:
1038
1039 // Static thunks, or CAFS, are obviously retainers.
1040 case THUNK_STATIC:
1041
1042 // WEAK objects are roots; there is separate code in which traversing
1043 // begins from WEAK objects.
1044 case WEAK:
1045 return rtsTrue;
1046
1047 //
1048 // False case
1049 //
1050
1051 // constructors
1052 case CONSTR:
1053 case CONSTR_1_0:
1054 case CONSTR_0_1:
1055 case CONSTR_2_0:
1056 case CONSTR_1_1:
1057 case CONSTR_0_2:
1058 // functions
1059 case FUN:
1060 case FUN_1_0:
1061 case FUN_0_1:
1062 case FUN_2_0:
1063 case FUN_1_1:
1064 case FUN_0_2:
1065 // partial applications
1066 case PAP:
1067 // indirection
1068 // IND_STATIC used to be an error, but at the moment it can happen
1069 // as isAlive doesn't look through IND_STATIC as it ignores static
1070 // closures. See trac #3956 for a program that hit this error.
1071 case IND_STATIC:
1072 case BLACKHOLE:
1073 // static objects
1074 case CONSTR_STATIC:
1075 case FUN_STATIC:
1076 // misc
1077 case PRIM:
1078 case BCO:
1079 case ARR_WORDS:
1080 // STM
1081 case TREC_CHUNK:
1082 // immutable arrays
1083 case MUT_ARR_PTRS_FROZEN:
1084 case MUT_ARR_PTRS_FROZEN0:
1085 return rtsFalse;
1086
1087 //
1088 // Error case
1089 //
1090 // CONSTR_NOCAF_STATIC
1091 // cannot be *c, *cp, *r in the retainer profiling loop.
1092 case CONSTR_NOCAF_STATIC:
1093 // Stack objects are invalid because they are never treated as
1094 // legal objects during retainer profiling.
1095 case UPDATE_FRAME:
1096 case CATCH_FRAME:
1097 case UNDERFLOW_FRAME:
1098 case STOP_FRAME:
1099 case RET_BCO:
1100 case RET_SMALL:
1101 case RET_BIG:
1102 // other cases
1103 case IND:
1104 case INVALID_OBJECT:
1105 default:
1106 barf("Invalid object in isRetainer(): %d", get_itbl(c)->type);
1107 return rtsFalse;
1108 }
1109 }
1110
1111 /* -----------------------------------------------------------------------------
1112 * Returns the retainer function value for the closure *c, i.e., R(*c).
1113 * This function does NOT return the retainer(s) of *c.
1114 * Invariants:
1115 * *c must be a retainer.
1116 * Note:
1117 * Depending on the definition of this function, the maintenance of retainer
1118 * sets can be made easier. If most retainer sets are likely to be created
1119 * again across garbage collections, refreshAllRetainerSet() in
1120 * RetainerSet.c can simply do nothing.
1121 * If this is not the case, we can free all the retainer sets and
1122 * re-initialize the hash table.
1123 * See refreshAllRetainerSet() in RetainerSet.c.
1124 * -------------------------------------------------------------------------- */
1125 static INLINE retainer
1126 getRetainerFrom( StgClosure *c )
1127 {
1128 ASSERT(isRetainer(c));
1129
1130 #if defined(RETAINER_SCHEME_INFO)
1131 // Retainer scheme 1: retainer = info table
1132 return get_itbl(c);
1133 #elif defined(RETAINER_SCHEME_CCS)
1134 // Retainer scheme 2: retainer = cost centre stack
1135 return c->header.prof.ccs;
1136 #elif defined(RETAINER_SCHEME_CC)
1137 // Retainer scheme 3: retainer = cost centre
1138 return c->header.prof.ccs->cc;
1139 #endif
1140 }
1141
1142 /* -----------------------------------------------------------------------------
1143 * Associates the retainer set *s with the closure *c, that is, *s becomes
1144 * the retainer set of *c.
1145 * Invariants:
1146 * c != NULL
1147 * s != NULL
1148 * -------------------------------------------------------------------------- */
1149 static INLINE void
1150 associate( StgClosure *c, RetainerSet *s )
1151 {
1152 // StgWord has the same size as pointers, so the following type
1153 // casting is okay.
1154 RSET(c) = (RetainerSet *)((StgWord)s | flip);
1155 }
1156
1157 /* -----------------------------------------------------------------------------
1158 Call retainClosure for each of the closures covered by a large bitmap.
1159 -------------------------------------------------------------------------- */
1160
1161 static void
1162 retain_large_bitmap (StgPtr p, StgLargeBitmap *large_bitmap, uint32_t size,
1163 StgClosure *c, retainer c_child_r)
1164 {
1165 uint32_t i, b;
1166 StgWord bitmap;
1167
1168 b = 0;
1169 bitmap = large_bitmap->bitmap[b];
1170 for (i = 0; i < size; ) {
1171 if ((bitmap & 1) == 0) {
1172 retainClosure((StgClosure *)*p, c, c_child_r);
1173 }
1174 i++;
1175 p++;
1176 if (i % BITS_IN(W_) == 0) {
1177 b++;
1178 bitmap = large_bitmap->bitmap[b];
1179 } else {
1180 bitmap = bitmap >> 1;
1181 }
1182 }
1183 }
1184
1185 static INLINE StgPtr
1186 retain_small_bitmap (StgPtr p, uint32_t size, StgWord bitmap,
1187 StgClosure *c, retainer c_child_r)
1188 {
1189 while (size > 0) {
1190 if ((bitmap & 1) == 0) {
1191 retainClosure((StgClosure *)*p, c, c_child_r);
1192 }
1193 p++;
1194 bitmap = bitmap >> 1;
1195 size--;
1196 }
1197 return p;
1198 }
1199
1200 /* -----------------------------------------------------------------------------
1201 * Call retainClosure for each of the closures in an SRT.
1202 * ------------------------------------------------------------------------- */
1203
1204 static void
1205 retain_large_srt_bitmap (StgLargeSRT *srt, StgClosure *c, retainer c_child_r)
1206 {
1207 uint32_t i, b, size;
1208 StgWord bitmap;
1209 StgClosure **p;
1210
1211 b = 0;
1212 p = (StgClosure **)srt->srt;
1213 size = srt->l.size;
1214 bitmap = srt->l.bitmap[b];
1215 for (i = 0; i < size; ) {
1216 if ((bitmap & 1) != 0) {
1217 retainClosure((StgClosure *)*p, c, c_child_r);
1218 }
1219 i++;
1220 p++;
1221 if (i % BITS_IN(W_) == 0) {
1222 b++;
1223 bitmap = srt->l.bitmap[b];
1224 } else {
1225 bitmap = bitmap >> 1;
1226 }
1227 }
1228 }
1229
1230 static INLINE void
1231 retainSRT (StgClosure **srt, uint32_t srt_bitmap, StgClosure *c,
1232 retainer c_child_r)
1233 {
1234 uint32_t bitmap;
1235 StgClosure **p;
1236
1237 bitmap = srt_bitmap;
1238 p = srt;
1239
1240 if (bitmap == (StgHalfWord)(-1)) {
1241 retain_large_srt_bitmap( (StgLargeSRT *)srt, c, c_child_r );
1242 return;
1243 }
1244
1245 while (bitmap != 0) {
1246 if ((bitmap & 1) != 0) {
1247 #if defined(COMPILING_WINDOWS_DLL)
1248 if ( (unsigned long)(*srt) & 0x1 ) {
1249 retainClosure(* (StgClosure**) ((unsigned long) (*srt) & ~0x1),
1250 c, c_child_r);
1251 } else {
1252 retainClosure(*srt,c,c_child_r);
1253 }
1254 #else
1255 retainClosure(*srt,c,c_child_r);
1256 #endif
1257 }
1258 p++;
1259 bitmap = bitmap >> 1;
1260 }
1261 }
1262
1263 /* -----------------------------------------------------------------------------
1264 * Process all the objects in the stack chunk from stackStart to stackEnd
1265 * with *c and *c_child_r being their parent and their most recent retainer,
1266 * respectively. Treat stackOptionalFun as another child of *c if it is
1267 * not NULL.
1268 * Invariants:
1269 * *c is one of the following: TSO, AP_STACK.
1270 * If *c is TSO, c == c_child_r.
1271 * stackStart < stackEnd.
1272 * RSET(c) and RSET(c_child_r) are valid, i.e., their
1273 * interpretation conforms to the current value of flip (even when they
1274 * are interpreted to be NULL).
1275 * If *c is TSO, its state is not ThreadComplete,or ThreadKilled,
1276 * which means that its stack is ready to process.
1277 * Note:
1278 * This code was almost plagiarzied from GC.c! For each pointer,
1279 * retainClosure() is invoked instead of evacuate().
1280 * -------------------------------------------------------------------------- */
1281 static void
1282 retainStack( StgClosure *c, retainer c_child_r,
1283 StgPtr stackStart, StgPtr stackEnd )
1284 {
1285 stackElement *oldStackBoundary;
1286 StgPtr p;
1287 StgRetInfoTable *info;
1288 StgWord bitmap;
1289 uint32_t size;
1290
1291 #ifdef DEBUG_RETAINER
1292 cStackSize++;
1293 if (cStackSize > maxCStackSize) maxCStackSize = cStackSize;
1294 #endif
1295
1296 /*
1297 Each invocation of retainStack() creates a new virtual
1298 stack. Since all such stacks share a single common stack, we
1299 record the current currentStackBoundary, which will be restored
1300 at the exit.
1301 */
1302 oldStackBoundary = currentStackBoundary;
1303 currentStackBoundary = stackTop;
1304
1305 #ifdef DEBUG_RETAINER
1306 // debugBelch("retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
1307 #endif
1308
1309 ASSERT(get_itbl(c)->type == STACK);
1310
1311 p = stackStart;
1312 while (p < stackEnd) {
1313 info = get_ret_itbl((StgClosure *)p);
1314
1315 switch(info->i.type) {
1316
1317 case UPDATE_FRAME:
1318 retainClosure(((StgUpdateFrame *)p)->updatee, c, c_child_r);
1319 p += sizeofW(StgUpdateFrame);
1320 continue;
1321
1322 case UNDERFLOW_FRAME:
1323 case STOP_FRAME:
1324 case CATCH_FRAME:
1325 case CATCH_STM_FRAME:
1326 case CATCH_RETRY_FRAME:
1327 case ATOMICALLY_FRAME:
1328 case RET_SMALL:
1329 bitmap = BITMAP_BITS(info->i.layout.bitmap);
1330 size = BITMAP_SIZE(info->i.layout.bitmap);
1331 p++;
1332 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1333
1334 follow_srt:
1335 retainSRT((StgClosure **)GET_SRT(info), info->i.srt_bitmap, c, c_child_r);
1336 continue;
1337
1338 case RET_BCO: {
1339 StgBCO *bco;
1340
1341 p++;
1342 retainClosure((StgClosure *)*p, c, c_child_r);
1343 bco = (StgBCO *)*p;
1344 p++;
1345 size = BCO_BITMAP_SIZE(bco);
1346 retain_large_bitmap(p, BCO_BITMAP(bco), size, c, c_child_r);
1347 p += size;
1348 continue;
1349 }
1350
1351 // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
1352 case RET_BIG:
1353 size = GET_LARGE_BITMAP(&info->i)->size;
1354 p++;
1355 retain_large_bitmap(p, GET_LARGE_BITMAP(&info->i),
1356 size, c, c_child_r);
1357 p += size;
1358 // and don't forget to follow the SRT
1359 goto follow_srt;
1360
1361 case RET_FUN: {
1362 StgRetFun *ret_fun = (StgRetFun *)p;
1363 StgFunInfoTable *fun_info;
1364
1365 retainClosure(ret_fun->fun, c, c_child_r);
1366 fun_info = get_fun_itbl(UNTAG_CONST_CLOSURE(ret_fun->fun));
1367
1368 p = (P_)&ret_fun->payload;
1369 switch (fun_info->f.fun_type) {
1370 case ARG_GEN:
1371 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
1372 size = BITMAP_SIZE(fun_info->f.b.bitmap);
1373 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1374 break;
1375 case ARG_GEN_BIG:
1376 size = GET_FUN_LARGE_BITMAP(fun_info)->size;
1377 retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
1378 size, c, c_child_r);
1379 p += size;
1380 break;
1381 default:
1382 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1383 size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
1384 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1385 break;
1386 }
1387 goto follow_srt;
1388 }
1389
1390 default:
1391 barf("Invalid object found in retainStack(): %d",
1392 (int)(info->i.type));
1393 }
1394 }
1395
1396 // restore currentStackBoundary
1397 currentStackBoundary = oldStackBoundary;
1398 #ifdef DEBUG_RETAINER
1399 // debugBelch("retainStack() finished: currentStackBoundary = 0x%x\n", currentStackBoundary);
1400 #endif
1401
1402 #ifdef DEBUG_RETAINER
1403 cStackSize--;
1404 #endif
1405 }
1406
1407 /* ----------------------------------------------------------------------------
1408 * Call retainClosure for each of the children of a PAP/AP
1409 * ------------------------------------------------------------------------- */
1410
1411 static INLINE StgPtr
1412 retain_PAP_payload (StgClosure *pap, /* NOT tagged */
1413 retainer c_child_r, /* NOT tagged */
1414 StgClosure *fun, /* tagged */
1415 StgClosure** payload, StgWord n_args)
1416 {
1417 StgPtr p;
1418 StgWord bitmap;
1419 StgFunInfoTable *fun_info;
1420
1421 retainClosure(fun, pap, c_child_r);
1422 fun = UNTAG_CLOSURE(fun);
1423 fun_info = get_fun_itbl(fun);
1424 ASSERT(fun_info->i.type != PAP);
1425
1426 p = (StgPtr)payload;
1427
1428 switch (fun_info->f.fun_type) {
1429 case ARG_GEN:
1430 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
1431 p = retain_small_bitmap(p, n_args, bitmap,
1432 pap, c_child_r);
1433 break;
1434 case ARG_GEN_BIG:
1435 retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
1436 n_args, pap, c_child_r);
1437 p += n_args;
1438 break;
1439 case ARG_BCO:
1440 retain_large_bitmap((StgPtr)payload, BCO_BITMAP(fun),
1441 n_args, pap, c_child_r);
1442 p += n_args;
1443 break;
1444 default:
1445 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1446 p = retain_small_bitmap(p, n_args, bitmap, pap, c_child_r);
1447 break;
1448 }
1449 return p;
1450 }
1451
1452 /* -----------------------------------------------------------------------------
1453 * Compute the retainer set of *c0 and all its desecents by traversing.
1454 * *cp0 is the parent of *c0, and *r0 is the most recent retainer of *c0.
1455 * Invariants:
1456 * c0 = cp0 = r0 holds only for root objects.
1457 * RSET(cp0) and RSET(r0) are valid, i.e., their
1458 * interpretation conforms to the current value of flip (even when they
1459 * are interpreted to be NULL).
1460 * However, RSET(c0) may be corrupt, i.e., it may not conform to
1461 * the current value of flip. If it does not, during the execution
1462 * of this function, RSET(c0) must be initialized as well as all
1463 * its descendants.
1464 * Note:
1465 * stackTop must be the same at the beginning and the exit of this function.
1466 * *c0 can be TSO (as well as AP_STACK).
1467 * -------------------------------------------------------------------------- */
1468 static void
1469 retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
1470 {
1471 // c = Current closure (possibly tagged)
1472 // cp = Current closure's Parent (NOT tagged)
1473 // r = current closures' most recent Retainer (NOT tagged)
1474 // c_child_r = current closure's children's most recent retainer
1475 // first_child = first child of c
1476 StgClosure *c, *cp, *first_child;
1477 RetainerSet *s, *retainerSetOfc;
1478 retainer r, c_child_r;
1479 StgWord typeOfc;
1480
1481 #ifdef DEBUG_RETAINER
1482 // StgPtr oldStackTop;
1483 #endif
1484
1485 #ifdef DEBUG_RETAINER
1486 // oldStackTop = stackTop;
1487 // debugBelch("retainClosure() called: c0 = 0x%x, cp0 = 0x%x, r0 = 0x%x\n", c0, cp0, r0);
1488 #endif
1489
1490 // (c, cp, r) = (c0, cp0, r0)
1491 c = c0;
1492 cp = cp0;
1493 r = r0;
1494 goto inner_loop;
1495
1496 loop:
1497 //debugBelch("loop");
1498 // pop to (c, cp, r);
1499 pop(&c, &cp, &r);
1500
1501 if (c == NULL) {
1502 #ifdef DEBUG_RETAINER
1503 // debugBelch("retainClosure() ends: oldStackTop = 0x%x, stackTop = 0x%x\n", oldStackTop, stackTop);
1504 #endif
1505 return;
1506 }
1507
1508 //debugBelch("inner_loop");
1509
1510 inner_loop:
1511 c = UNTAG_CLOSURE(c);
1512
1513 // c = current closure under consideration,
1514 // cp = current closure's parent,
1515 // r = current closure's most recent retainer
1516 //
1517 // Loop invariants (on the meaning of c, cp, r, and their retainer sets):
1518 // RSET(cp) and RSET(r) are valid.
1519 // RSET(c) is valid only if c has been visited before.
1520 //
1521 // Loop invariants (on the relation between c, cp, and r)
1522 // if cp is not a retainer, r belongs to RSET(cp).
1523 // if cp is a retainer, r == cp.
1524
1525 typeOfc = get_itbl(c)->type;
1526
1527 #ifdef DEBUG_RETAINER
1528 switch (typeOfc) {
1529 case IND_STATIC:
1530 case CONSTR_NOCAF_STATIC:
1531 case CONSTR_STATIC:
1532 case THUNK_STATIC:
1533 case FUN_STATIC:
1534 break;
1535 default:
1536 if (retainerSetOf(c) == NULL) { // first visit?
1537 costArray[typeOfc] += cost(c);
1538 sumOfNewCost += cost(c);
1539 }
1540 break;
1541 }
1542 #endif
1543
1544 // special cases
1545 switch (typeOfc) {
1546 case TSO:
1547 if (((StgTSO *)c)->what_next == ThreadComplete ||
1548 ((StgTSO *)c)->what_next == ThreadKilled) {
1549 #ifdef DEBUG_RETAINER
1550 debugBelch("ThreadComplete or ThreadKilled encountered in retainClosure()\n");
1551 #endif
1552 goto loop;
1553 }
1554 break;
1555
1556 case IND_STATIC:
1557 // We just skip IND_STATIC, so its retainer set is never computed.
1558 c = ((StgIndStatic *)c)->indirectee;
1559 goto inner_loop;
1560 // static objects with no pointers out, so goto loop.
1561 case CONSTR_NOCAF_STATIC:
1562 // It is not just enough not to compute the retainer set for *c; it is
1563 // mandatory because CONSTR_NOCAF_STATIC are not reachable from
1564 // scavenged_static_objects, the list from which is assumed to traverse
1565 // all static objects after major garbage collections.
1566 goto loop;
1567 case THUNK_STATIC:
1568 case FUN_STATIC:
1569 if (get_itbl(c)->srt_bitmap == 0) {
1570 // No need to compute the retainer set; no dynamic objects
1571 // are reachable from *c.
1572 //
1573 // Static objects: if we traverse all the live closures,
1574 // including static closures, during each heap census then
1575 // we will observe that some static closures appear and
1576 // disappear. eg. a closure may contain a pointer to a
1577 // static function 'f' which is not otherwise reachable
1578 // (it doesn't indirectly point to any CAFs, so it doesn't
1579 // appear in any SRTs), so we would find 'f' during
1580 // traversal. However on the next sweep there may be no
1581 // closures pointing to 'f'.
1582 //
1583 // We must therefore ignore static closures whose SRT is
1584 // empty, because these are exactly the closures that may
1585 // "appear". A closure with a non-empty SRT, and which is
1586 // still required, will always be reachable.
1587 //
1588 // But what about CONSTR_STATIC? Surely these may be able
1589 // to appear, and they don't have SRTs, so we can't
1590 // check. So for now, we're calling
1591 // resetStaticObjectForRetainerProfiling() from the
1592 // garbage collector to reset the retainer sets in all the
1593 // reachable static objects.
1594 goto loop;
1595 }
1596 default:
1597 break;
1598 }
1599
1600 // The above objects are ignored in computing the average number of times
1601 // an object is visited.
1602 timesAnyObjectVisited++;
1603
1604 // If this is the first visit to c, initialize its retainer set.
1605 maybeInitRetainerSet(c);
1606 retainerSetOfc = retainerSetOf(c);
1607
1608 // Now compute s:
1609 // isRetainer(cp) == rtsTrue => s == NULL
1610 // isRetainer(cp) == rtsFalse => s == cp.retainer
1611 if (isRetainer(cp))
1612 s = NULL;
1613 else
1614 s = retainerSetOf(cp);
1615
1616 // (c, cp, r, s) is available.
1617
1618 // (c, cp, r, s, R_r) is available, so compute the retainer set for *c.
1619 if (retainerSetOfc == NULL) {
1620 // This is the first visit to *c.
1621 numObjectVisited++;
1622
1623 if (s == NULL)
1624 associate(c, singleton(r));
1625 else
1626 // s is actually the retainer set of *c!
1627 associate(c, s);
1628
1629 // compute c_child_r
1630 c_child_r = isRetainer(c) ? getRetainerFrom(c) : r;
1631 } else {
1632 // This is not the first visit to *c.
1633 if (isMember(r, retainerSetOfc))
1634 goto loop; // no need to process child
1635
1636 if (s == NULL)
1637 associate(c, addElement(r, retainerSetOfc));
1638 else {
1639 // s is not NULL and cp is not a retainer. This means that
1640 // each time *cp is visited, so is *c. Thus, if s has
1641 // exactly one more element in its retainer set than c, s
1642 // is also the new retainer set for *c.
1643 if (s->num == retainerSetOfc->num + 1) {
1644 associate(c, s);
1645 }
1646 // Otherwise, just add R_r to the current retainer set of *c.
1647 else {
1648 associate(c, addElement(r, retainerSetOfc));
1649 }
1650 }
1651
1652 if (isRetainer(c))
1653 goto loop; // no need to process child
1654
1655 // compute c_child_r
1656 c_child_r = r;
1657 }
1658
1659 // now, RSET() of all of *c, *cp, and *r is valid.
1660 // (c, c_child_r) are available.
1661
1662 // process child
1663
1664 // Special case closures: we process these all in one go rather
1665 // than attempting to save the current position, because doing so
1666 // would be hard.
1667 switch (typeOfc) {
1668 case STACK:
1669 retainStack(c, c_child_r,
1670 ((StgStack *)c)->sp,
1671 ((StgStack *)c)->stack + ((StgStack *)c)->stack_size);
1672 goto loop;
1673
1674 case TSO:
1675 {
1676 StgTSO *tso = (StgTSO *)c;
1677
1678 retainClosure(tso->stackobj, c, c_child_r);
1679 retainClosure(tso->blocked_exceptions, c, c_child_r);
1680 retainClosure(tso->bq, c, c_child_r);
1681 retainClosure(tso->trec, c, c_child_r);
1682 if ( tso->why_blocked == BlockedOnMVar
1683 || tso->why_blocked == BlockedOnMVarRead
1684 || tso->why_blocked == BlockedOnBlackHole
1685 || tso->why_blocked == BlockedOnMsgThrowTo
1686 ) {
1687 retainClosure(tso->block_info.closure, c, c_child_r);
1688 }
1689 goto loop;
1690 }
1691
1692 case PAP:
1693 {
1694 StgPAP *pap = (StgPAP *)c;
1695 retain_PAP_payload(c, c_child_r, pap->fun, pap->payload, pap->n_args);
1696 goto loop;
1697 }
1698
1699 case AP:
1700 {
1701 StgAP *ap = (StgAP *)c;
1702 retain_PAP_payload(c, c_child_r, ap->fun, ap->payload, ap->n_args);
1703 goto loop;
1704 }
1705
1706 case AP_STACK:
1707 retainClosure(((StgAP_STACK *)c)->fun, c, c_child_r);
1708 retainStack(c, c_child_r,
1709 (StgPtr)((StgAP_STACK *)c)->payload,
1710 (StgPtr)((StgAP_STACK *)c)->payload +
1711 ((StgAP_STACK *)c)->size);
1712 goto loop;
1713 }
1714
1715 push(c, c_child_r, &first_child);
1716
1717 // If first_child is null, c has no child.
1718 // If first_child is not null, the top stack element points to the next
1719 // object. push() may or may not push a stackElement on the stack.
1720 if (first_child == NULL)
1721 goto loop;
1722
1723 // (c, cp, r) = (first_child, c, c_child_r)
1724 r = c_child_r;
1725 cp = c;
1726 c = first_child;
1727 goto inner_loop;
1728 }
1729
1730 /* -----------------------------------------------------------------------------
1731 * Compute the retainer set for every object reachable from *tl.
1732 * -------------------------------------------------------------------------- */
1733 static void
1734 retainRoot(void *user STG_UNUSED, StgClosure **tl)
1735 {
1736 StgClosure *c;
1737
1738 // We no longer assume that only TSOs and WEAKs are roots; any closure can
1739 // be a root.
1740
1741 ASSERT(isEmptyRetainerStack());
1742 currentStackBoundary = stackTop;
1743
1744 c = UNTAG_CLOSURE(*tl);
1745 maybeInitRetainerSet(c);
1746 if (c != &stg_END_TSO_QUEUE_closure && isRetainer(c)) {
1747 retainClosure(c, c, getRetainerFrom(c));
1748 } else {
1749 retainClosure(c, c, CCS_SYSTEM);
1750 }
1751
1752 // NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl)));
1753 // *tl might be a TSO which is ThreadComplete, in which
1754 // case we ignore it for the purposes of retainer profiling.
1755 }
1756
1757 /* -----------------------------------------------------------------------------
1758 * Compute the retainer set for each of the objects in the heap.
1759 * -------------------------------------------------------------------------- */
1760 static void
1761 computeRetainerSet( void )
1762 {
1763 StgWeak *weak;
1764 RetainerSet *rtl;
1765 uint32_t g, n;
1766 StgPtr ml;
1767 bdescr *bd;
1768 #ifdef DEBUG_RETAINER
1769 RetainerSet tmpRetainerSet;
1770 #endif
1771
1772 markCapabilities(retainRoot, NULL); // for scheduler roots
1773
1774 // This function is called after a major GC, when key, value, and finalizer
1775 // all are guaranteed to be valid, or reachable.
1776 //
1777 // The following code assumes that WEAK objects are considered to be roots
1778 // for retainer profilng.
1779 for (n = 0; n < n_capabilities; n++) {
1780 // NB: after a GC, all nursery weak_ptr_lists have been migrated
1781 // to the global lists living in the generations
1782 ASSERT(capabilities[n]->weak_ptr_list_hd == NULL);
1783 ASSERT(capabilities[n]->weak_ptr_list_tl == NULL);
1784 }
1785 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1786 for (weak = generations[g].weak_ptr_list; weak != NULL; weak = weak->link) {
1787 // retainRoot((StgClosure *)weak);
1788 retainRoot(NULL, (StgClosure **)&weak);
1789 }
1790 }
1791
1792 // Consider roots from the stable ptr table.
1793 markStableTables(retainRoot, NULL);
1794
1795 // The following code resets the rs field of each unvisited mutable
1796 // object (computing sumOfNewCostExtra and updating costArray[] when
1797 // debugging retainer profiler).
1798 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1799 // NOT TRUE: even G0 has a block on its mutable list
1800 // ASSERT(g != 0 || (generations[g].mut_list == NULL));
1801
1802 // Traversing through mut_list is necessary
1803 // because we can find MUT_VAR objects which have not been
1804 // visited during retainer profiling.
1805 for (n = 0; n < n_capabilities; n++) {
1806 for (bd = capabilities[n]->mut_lists[g]; bd != NULL; bd = bd->link) {
1807 for (ml = bd->start; ml < bd->free; ml++) {
1808
1809 maybeInitRetainerSet((StgClosure *)*ml);
1810 rtl = retainerSetOf((StgClosure *)*ml);
1811
1812 #ifdef DEBUG_RETAINER
1813 if (rtl == NULL) {
1814 // first visit to *ml
1815 // This is a violation of the interface rule!
1816 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1817
1818 switch (get_itbl((StgClosure *)ml)->type) {
1819 case IND_STATIC:
1820 // no cost involved
1821 break;
1822 case CONSTR_NOCAF_STATIC:
1823 case CONSTR_STATIC:
1824 case THUNK_STATIC:
1825 case FUN_STATIC:
1826 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1827 break;
1828 default:
1829 // dynamic objects
1830 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1831 sumOfNewCostExtra += cost((StgClosure *)ml);
1832 break;
1833 }
1834 }
1835 #endif
1836 }
1837 }
1838 }
1839 }
1840 }
1841
1842 /* -----------------------------------------------------------------------------
1843 * Traverse all static objects for which we compute retainer sets,
1844 * and reset their rs fields to NULL, which is accomplished by
1845 * invoking maybeInitRetainerSet(). This function must be called
1846 * before zeroing all objects reachable from scavenged_static_objects
1847 * in the case of major gabage collections. See GarbageCollect() in
1848 * GC.c.
1849 * Note:
1850 * The mut_once_list of the oldest generation must also be traversed?
1851 * Why? Because if the evacuation of an object pointed to by a static
1852 * indirection object fails, it is put back to the mut_once_list of
1853 * the oldest generation.
1854 * However, this is not necessary because any static indirection objects
1855 * are just traversed through to reach dynamic objects. In other words,
1856 * they are not taken into consideration in computing retainer sets.
1857 *
1858 * SDM (20/7/2011): I don't think this is doing anything sensible,
1859 * because it happens before retainerProfile() and at the beginning of
1860 * retainerProfil() we change the sense of 'flip'. So all of the
1861 * calls to maybeInitRetainerSet() here are initialising retainer sets
1862 * with the wrong flip. Also, I don't see why this is necessary. I
1863 * added a maybeInitRetainerSet() call to retainRoot(), and that seems
1864 * to have fixed the assertion failure in retainerSetOf() I was
1865 * encountering.
1866 * -------------------------------------------------------------------------- */
1867 void
1868 resetStaticObjectForRetainerProfiling( StgClosure *static_objects )
1869 {
1870 #ifdef DEBUG_RETAINER
1871 uint32_t count;
1872 #endif
1873 StgClosure *p;
1874
1875 #ifdef DEBUG_RETAINER
1876 count = 0;
1877 #endif
1878 p = static_objects;
1879 while (p != END_OF_STATIC_OBJECT_LIST) {
1880 p = UNTAG_STATIC_LIST_PTR(p);
1881 #ifdef DEBUG_RETAINER
1882 count++;
1883 #endif
1884 switch (get_itbl(p)->type) {
1885 case IND_STATIC:
1886 // Since we do not compute the retainer set of any
1887 // IND_STATIC object, we don't have to reset its retainer
1888 // field.
1889 p = (StgClosure*)*IND_STATIC_LINK(p);
1890 break;
1891 case THUNK_STATIC:
1892 maybeInitRetainerSet(p);
1893 p = (StgClosure*)*THUNK_STATIC_LINK(p);
1894 break;
1895 case FUN_STATIC:
1896 maybeInitRetainerSet(p);
1897 p = (StgClosure*)*FUN_STATIC_LINK(p);
1898 break;
1899 case CONSTR_STATIC:
1900 maybeInitRetainerSet(p);
1901 p = (StgClosure*)*STATIC_LINK(get_itbl(p), p);
1902 break;
1903 default:
1904 barf("resetStaticObjectForRetainerProfiling: %p (%s)",
1905 p, get_itbl(p)->type);
1906 break;
1907 }
1908 }
1909 #ifdef DEBUG_RETAINER
1910 // debugBelch("count in scavenged_static_objects = %d\n", count);
1911 #endif
1912 }
1913
1914 /* -----------------------------------------------------------------------------
1915 * Perform retainer profiling.
1916 * N is the oldest generation being profilied, where the generations are
1917 * numbered starting at 0.
1918 * Invariants:
1919 * Note:
1920 * This function should be called only immediately after major garbage
1921 * collection.
1922 * ------------------------------------------------------------------------- */
1923 void
1924 retainerProfile(void)
1925 {
1926 #ifdef DEBUG_RETAINER
1927 uint32_t i;
1928 uint32_t totalHeapSize; // total raw heap size (computed by linear scanning)
1929 #endif
1930
1931 #ifdef DEBUG_RETAINER
1932 debugBelch(" < retainerProfile() invoked : %d>\n", retainerGeneration);
1933 #endif
1934
1935 stat_startRP();
1936
1937 // We haven't flipped the bit yet.
1938 #ifdef DEBUG_RETAINER
1939 debugBelch("Before traversing:\n");
1940 sumOfCostLinear = 0;
1941 for (i = 0;i < N_CLOSURE_TYPES; i++)
1942 costArrayLinear[i] = 0;
1943 totalHeapSize = checkHeapSanityForRetainerProfiling();
1944
1945 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1946 /*
1947 debugBelch("costArrayLinear[] = ");
1948 for (i = 0;i < N_CLOSURE_TYPES; i++)
1949 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
1950 debugBelch("\n");
1951 */
1952
1953 ASSERT(sumOfCostLinear == totalHeapSize);
1954
1955 /*
1956 #define pcostArrayLinear(index) \
1957 if (costArrayLinear[index] > 0) \
1958 debugBelch("costArrayLinear[" #index "] = %u\n", costArrayLinear[index])
1959 pcostArrayLinear(THUNK_STATIC);
1960 pcostArrayLinear(FUN_STATIC);
1961 pcostArrayLinear(CONSTR_STATIC);
1962 pcostArrayLinear(CONSTR_NOCAF_STATIC);
1963 */
1964 #endif
1965
1966 // Now we flips flip.
1967 flip = flip ^ 1;
1968
1969 #ifdef DEBUG_RETAINER
1970 stackSize = 0;
1971 maxStackSize = 0;
1972 cStackSize = 0;
1973 maxCStackSize = 0;
1974 #endif
1975 numObjectVisited = 0;
1976 timesAnyObjectVisited = 0;
1977
1978 #ifdef DEBUG_RETAINER
1979 debugBelch("During traversing:\n");
1980 sumOfNewCost = 0;
1981 sumOfNewCostExtra = 0;
1982 for (i = 0;i < N_CLOSURE_TYPES; i++)
1983 costArray[i] = 0;
1984 #endif
1985
1986 /*
1987 We initialize the traverse stack each time the retainer profiling is
1988 performed (because the traverse stack size varies on each retainer profiling
1989 and this operation is not costly anyhow). However, we just refresh the
1990 retainer sets.
1991 */
1992 initializeTraverseStack();
1993 #ifdef DEBUG_RETAINER
1994 initializeAllRetainerSet();
1995 #else
1996 refreshAllRetainerSet();
1997 #endif
1998 computeRetainerSet();
1999
2000 #ifdef DEBUG_RETAINER
2001 debugBelch("After traversing:\n");
2002 sumOfCostLinear = 0;
2003 for (i = 0;i < N_CLOSURE_TYPES; i++)
2004 costArrayLinear[i] = 0;
2005 totalHeapSize = checkHeapSanityForRetainerProfiling();
2006
2007 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
2008 ASSERT(sumOfCostLinear == totalHeapSize);
2009
2010 // now, compare the two results
2011 /*
2012 Note:
2013 costArray[] must be exactly the same as costArrayLinear[].
2014 Known exceptions:
2015 1) Dead weak pointers, whose type is CONSTR. These objects are not
2016 reachable from any roots.
2017 */
2018 debugBelch("Comparison:\n");
2019 debugBelch("\tcostArrayLinear[] (must be empty) = ");
2020 for (i = 0;i < N_CLOSURE_TYPES; i++)
2021 if (costArray[i] != costArrayLinear[i])
2022 // nothing should be printed except MUT_VAR after major GCs
2023 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
2024 debugBelch("\n");
2025
2026 debugBelch("\tsumOfNewCost = %u\n", sumOfNewCost);
2027 debugBelch("\tsumOfNewCostExtra = %u\n", sumOfNewCostExtra);
2028 debugBelch("\tcostArray[] (must be empty) = ");
2029 for (i = 0;i < N_CLOSURE_TYPES; i++)
2030 if (costArray[i] != costArrayLinear[i])
2031 // nothing should be printed except MUT_VAR after major GCs
2032 debugBelch("[%u:%u] ", i, costArray[i]);
2033 debugBelch("\n");
2034
2035 // only for major garbage collection
2036 ASSERT(sumOfNewCost + sumOfNewCostExtra == sumOfCostLinear);
2037 #endif
2038
2039 // post-processing
2040 closeTraverseStack();
2041 #ifdef DEBUG_RETAINER
2042 closeAllRetainerSet();
2043 #else
2044 // Note that there is no post-processing for the retainer sets.
2045 #endif
2046 retainerGeneration++;
2047
2048 stat_endRP(
2049 retainerGeneration - 1, // retainerGeneration has just been incremented!
2050 #ifdef DEBUG_RETAINER
2051 maxCStackSize, maxStackSize,
2052 #endif
2053 (double)timesAnyObjectVisited / numObjectVisited);
2054 }
2055
2056 /* -----------------------------------------------------------------------------
2057 * DEBUGGING CODE
2058 * -------------------------------------------------------------------------- */
2059
2060 #ifdef DEBUG_RETAINER
2061
2062 #define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
2063 ((HEAP_ALLOCED(r) && ((Bdescr((P_)r)->flags & BF_FREE) == 0)))) && \
2064 ((StgWord)(*(StgPtr)r)!=(StgWord)0xaaaaaaaaaaaaaaaaULL))
2065
2066 static uint32_t
2067 sanityCheckHeapClosure( StgClosure *c )
2068 {
2069 ASSERT(LOOKS_LIKE_GHC_INFO(c->header.info));
2070 ASSERT(!closure_STATIC(c));
2071 ASSERT(LOOKS_LIKE_PTR(c));
2072
2073 if ((((StgWord)RSET(c) & 1) ^ flip) != 0) {
2074 if (get_itbl(c)->type == CONSTR &&
2075 !strcmp(GET_PROF_TYPE(get_itbl(c)), "DEAD_WEAK") &&
2076 !strcmp(GET_PROF_DESC(get_itbl(c)), "DEAD_WEAK")) {
2077 debugBelch("\tUnvisited dead weak pointer object found: c = %p\n", c);
2078 costArray[get_itbl(c)->type] += cost(c);
2079 sumOfNewCost += cost(c);
2080 } else
2081 debugBelch(
2082 "Unvisited object: flip = %d, c = %p(%d, %s, %s), rs = %p\n",
2083 flip, c, get_itbl(c)->type,
2084 get_itbl(c)->prof.closure_type, GET_PROF_DESC(get_itbl(c)),
2085 RSET(c));
2086 } else {
2087 // debugBelch("sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c));
2088 }
2089
2090 return closure_sizeW(c);
2091 }
2092
2093 static uint32_t
2094 heapCheck( bdescr *bd )
2095 {
2096 StgPtr p;
2097 static uint32_t costSum, size;
2098
2099 costSum = 0;
2100 while (bd != NULL) {
2101 p = bd->start;
2102 while (p < bd->free) {
2103 size = sanityCheckHeapClosure((StgClosure *)p);
2104 sumOfCostLinear += size;
2105 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2106 p += size;
2107 // no need for slop check; I think slops are not used currently.
2108 }
2109 ASSERT(p == bd->free);
2110 costSum += bd->free - bd->start;
2111 bd = bd->link;
2112 }
2113
2114 return costSum;
2115 }
2116
2117 static uint32_t
2118 smallObjectPoolCheck(void)
2119 {
2120 bdescr *bd;
2121 StgPtr p;
2122 static uint32_t costSum, size;
2123
2124 bd = g0s0->blocks;
2125 costSum = 0;
2126
2127 // first block
2128 if (bd == NULL)
2129 return costSum;
2130
2131 p = bd->start;
2132 while (p < alloc_Hp) {
2133 size = sanityCheckHeapClosure((StgClosure *)p);
2134 sumOfCostLinear += size;
2135 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2136 p += size;
2137 }
2138 ASSERT(p == alloc_Hp);
2139 costSum += alloc_Hp - bd->start;
2140
2141 bd = bd->link;
2142 while (bd != NULL) {
2143 p = bd->start;
2144 while (p < bd->free) {
2145 size = sanityCheckHeapClosure((StgClosure *)p);
2146 sumOfCostLinear += size;
2147 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2148 p += size;
2149 }
2150 ASSERT(p == bd->free);
2151 costSum += bd->free - bd->start;
2152 bd = bd->link;
2153 }
2154
2155 return costSum;
2156 }
2157
2158 static uint32_t
2159 chainCheck(bdescr *bd)
2160 {
2161 uint32_t costSum, size;
2162
2163 costSum = 0;
2164 while (bd != NULL) {
2165 // bd->free - bd->start is not an accurate measurement of the
2166 // object size. Actually it is always zero, so we compute its
2167 // size explicitly.
2168 size = sanityCheckHeapClosure((StgClosure *)bd->start);
2169 sumOfCostLinear += size;
2170 costArrayLinear[get_itbl((StgClosure *)bd->start)->type] += size;
2171 costSum += size;
2172 bd = bd->link;
2173 }
2174
2175 return costSum;
2176 }
2177
2178 static uint32_t
2179 checkHeapSanityForRetainerProfiling( void )
2180 {
2181 uint32_t costSum, g, s;
2182
2183 costSum = 0;
2184 debugBelch("START: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2185 if (RtsFlags.GcFlags.generations == 1) {
2186 costSum += heapCheck(g0s0->to_blocks);
2187 debugBelch("heapCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2188 costSum += chainCheck(g0s0->large_objects);
2189 debugBelch("chainCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2190 } else {
2191 for (g = 0; g < RtsFlags.GcFlags.generations; g++)
2192 for (s = 0; s < generations[g].n_steps; s++) {
2193 /*
2194 After all live objects have been scavenged, the garbage
2195 collector may create some objects in
2196 scheduleFinalizers(). These objects are created through
2197 allocate(), so the small object pool or the large object
2198 pool of the g0s0 may not be empty.
2199 */
2200 if (g == 0 && s == 0) {
2201 costSum += smallObjectPoolCheck();
2202 debugBelch("smallObjectPoolCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2203 costSum += chainCheck(generations[g].steps[s].large_objects);
2204 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2205 } else {
2206 costSum += heapCheck(generations[g].steps[s].blocks);
2207 debugBelch("heapCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2208 costSum += chainCheck(generations[g].steps[s].large_objects);
2209 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2210 }
2211 }
2212 }
2213
2214 return costSum;
2215 }
2216
2217 void
2218 findPointer(StgPtr p)
2219 {
2220 StgPtr q, r, e;
2221 bdescr *bd;
2222 uint32_t g, s;
2223
2224 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2225 for (s = 0; s < generations[g].n_steps; s++) {
2226 // if (g == 0 && s == 0) continue;
2227 bd = generations[g].steps[s].blocks;
2228 for (; bd; bd = bd->link) {
2229 for (q = bd->start; q < bd->free; q++) {
2230 if (*q == (StgWord)p) {
2231 r = q;
2232 while (!LOOKS_LIKE_GHC_INFO(*r)) r--;
2233 debugBelch("Found in gen[%d], step[%d]: q = %p, r = %p\n", g, s, q, r);
2234 // return;
2235 }
2236 }
2237 }
2238 bd = generations[g].steps[s].large_objects;
2239 for (; bd; bd = bd->link) {
2240 e = bd->start + cost((StgClosure *)bd->start);
2241 for (q = bd->start; q < e; q++) {
2242 if (*q == (StgWord)p) {
2243 r = q;
2244 while (*r == 0 || !LOOKS_LIKE_GHC_INFO(*r)) r--;
2245 debugBelch("Found in gen[%d], large_objects: %p\n", g, r);
2246 // return;
2247 }
2248 }
2249 }
2250 }
2251 }
2252 }
2253
2254 static void
2255 belongToHeap(StgPtr p)
2256 {
2257 bdescr *bd;
2258 uint32_t g, s;
2259
2260 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2261 for (s = 0; s < generations[g].n_steps; s++) {
2262 // if (g == 0 && s == 0) continue;
2263 bd = generations[g].steps[s].blocks;
2264 for (; bd; bd = bd->link) {
2265 if (bd->start <= p && p < bd->free) {
2266 debugBelch("Belongs to gen[%d], step[%d]", g, s);
2267 return;
2268 }
2269 }
2270 bd = generations[g].steps[s].large_objects;
2271 for (; bd; bd = bd->link) {
2272 if (bd->start <= p && p < bd->start + getHeapClosureSize((StgClosure *)bd->start)) {
2273 debugBelch("Found in gen[%d], large_objects: %p\n", g, bd->start);
2274 return;
2275 }
2276 }
2277 }
2278 }
2279 }
2280 #endif /* DEBUG_RETAINER */
2281
2282 #endif /* PROFILING */