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