1 /* -----------------------------------------------------------------------------
3 * (c) The GHC Team, 2001
8 * ---------------------------------------------------------------------------*/
12 // Turn off inlining when debugging - it obfuscates things
19 #include "PosixSource.h"
23 #include "RetainerProfile.h"
24 #include "RetainerSet.h"
28 #include "sm/Sanity.h"
29 #include "Profiling.h"
33 #include "sm/Storage.h" // for END_OF_STATIC_LIST
36 Note: what to change in order to plug-in a new retainer profiling scheme?
37 (1) type retainer in ../includes/StgRetainerProf.h
38 (2) retainer function R(), i.e., getRetainerFrom()
39 (3) the two hashing functions, hashKeySingleton() and hashKeyAddElement(),
40 in RetainerSet.h, if needed.
41 (4) printRetainer() and printRetainerSetShort() in RetainerSet.c.
44 /* -----------------------------------------------------------------------------
46 * -------------------------------------------------------------------------- */
48 static nat retainerGeneration; // generation
50 static nat numObjectVisited; // total number of objects visited
51 static nat timesAnyObjectVisited; // number of times any objects are visited
54 The rs field in the profile header of any object points to its retainer
55 set in an indirect way: if flip is 0, it points to the retainer set;
56 if flip is 1, it points to the next byte after the retainer set (even
57 for NULL pointers). Therefore, with flip 1, (rs ^ 1) is the actual
58 pointer. See retainerSetOf().
61 StgWord flip = 0; // flip bit
62 // must be 0 if DEBUG_RETAINER is on (for static closures)
64 #define setRetainerSetToNull(c) \
65 (c)->header.prof.hp.rs = (RetainerSet *)((StgWord)NULL | flip)
67 static void retainStack(StgClosure *, retainer, StgPtr, StgPtr);
68 static void retainClosure(StgClosure *, StgClosure *, retainer);
70 static void belongToHeap(StgPtr p);
75 cStackSize records how many times retainStack() has been invoked recursively,
76 that is, the number of activation records for retainStack() on the C stack.
77 maxCStackSize records its max value.
79 cStackSize <= maxCStackSize
81 static nat cStackSize, maxCStackSize;
83 static nat sumOfNewCost; // sum of the cost of each object, computed
84 // when the object is first visited
85 static nat sumOfNewCostExtra; // for those objects not visited during
86 // retainer profiling, e.g., MUT_VAR
87 static nat costArray[N_CLOSURE_TYPES];
89 nat sumOfCostLinear; // sum of the costs of all object, computed
90 // when linearly traversing the heap after
92 nat costArrayLinear[N_CLOSURE_TYPES];
95 /* -----------------------------------------------------------------------------
96 * Retainer stack - header
98 * Although the retainer stack implementation could be separated *
99 * from the retainer profiling engine, there does not seem to be
100 * any advantage in doing that; retainer stack is an integral part
101 * of retainer profiling engine and cannot be use elsewhere at
103 * -------------------------------------------------------------------------- */
113 // fixed layout or layout specified by a field in the closure
118 // See StgClosureInfo in InfoTables.h
119 #if SIZEOF_VOID_P == 8
156 firstStack points to the first block group.
157 currentStack points to the block group currently being used.
158 currentStack->free == stackLimit.
159 stackTop points to the topmost byte in the stack of currentStack.
160 Unless the whole stack is empty, stackTop must point to the topmost
161 object (or byte) in the whole stack. Thus, it is only when the whole stack
162 is empty that stackTop == stackLimit (not during the execution of push()
164 stackBottom == currentStack->start.
165 stackLimit == currentStack->start + BLOCK_SIZE_W * currentStack->blocks.
167 When a current stack becomes empty, stackTop is set to point to
168 the topmost element on the previous block group so as to satisfy
169 the invariants described above.
171 static bdescr *firstStack = NULL;
172 static bdescr *currentStack;
173 static stackElement *stackBottom, *stackTop, *stackLimit;
176 currentStackBoundary is used to mark the current stack chunk.
177 If stackTop == currentStackBoundary, it means that the current stack chunk
178 is empty. It is the responsibility of the user to keep currentStackBoundary
179 valid all the time if it is to be employed.
181 static stackElement *currentStackBoundary;
184 stackSize records the current size of the stack.
185 maxStackSize records its high water mark.
187 stackSize <= maxStackSize
189 stackSize is just an estimate measure of the depth of the graph. The reason
190 is that some heap objects have only a single child and may not result
191 in a new element being pushed onto the stack. Therefore, at the end of
192 retainer profiling, maxStackSize + maxCStackSize is some value no greater
193 than the actual depth of the graph.
195 #ifdef DEBUG_RETAINER
196 static int stackSize, maxStackSize;
199 // number of blocks allocated for one stack
200 #define BLOCKS_IN_STACK 1
202 /* -----------------------------------------------------------------------------
203 * Add a new block group to the stack.
205 * currentStack->link == s.
206 * -------------------------------------------------------------------------- */
208 newStackBlock( bdescr *bd )
211 stackTop = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
212 stackBottom = (stackElement *)bd->start;
213 stackLimit = (stackElement *)stackTop;
214 bd->free = (StgPtr)stackLimit;
217 /* -----------------------------------------------------------------------------
218 * Return to the previous block group.
220 * s->link == currentStack.
221 * -------------------------------------------------------------------------- */
223 returnToOldStack( bdescr *bd )
226 stackTop = (stackElement *)bd->free;
227 stackBottom = (stackElement *)bd->start;
228 stackLimit = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
229 bd->free = (StgPtr)stackLimit;
232 /* -----------------------------------------------------------------------------
233 * Initializes the traverse stack.
234 * -------------------------------------------------------------------------- */
236 initializeTraverseStack( void )
238 if (firstStack != NULL) {
239 freeChain(firstStack);
242 firstStack = allocGroup(BLOCKS_IN_STACK);
243 firstStack->link = NULL;
244 firstStack->u.back = NULL;
246 newStackBlock(firstStack);
249 /* -----------------------------------------------------------------------------
250 * Frees all the block groups in the traverse stack.
253 * -------------------------------------------------------------------------- */
255 closeTraverseStack( void )
257 freeChain(firstStack);
261 /* -----------------------------------------------------------------------------
262 * Returns rtsTrue if the whole stack is empty.
263 * -------------------------------------------------------------------------- */
264 static INLINE rtsBool
265 isEmptyRetainerStack( void )
267 return (firstStack == currentStack) && stackTop == stackLimit;
270 /* -----------------------------------------------------------------------------
271 * Returns size of stack
272 * -------------------------------------------------------------------------- */
275 retainerStackBlocks( void )
280 for (bd = firstStack; bd != NULL; bd = bd->link)
287 /* -----------------------------------------------------------------------------
288 * Returns rtsTrue if stackTop is at the stack boundary of the current stack,
289 * i.e., if the current stack chunk is empty.
290 * -------------------------------------------------------------------------- */
291 static INLINE rtsBool
294 return stackTop == currentStackBoundary;
297 /* -----------------------------------------------------------------------------
298 * Initializes *info from ptrs and payload.
300 * payload[] begins with ptrs pointers followed by non-pointers.
301 * -------------------------------------------------------------------------- */
303 init_ptrs( stackPos *info, nat ptrs, StgPtr payload )
305 info->type = posTypePtrs;
306 info->next.ptrs.pos = 0;
307 info->next.ptrs.ptrs = ptrs;
308 info->next.ptrs.payload = payload;
311 /* -----------------------------------------------------------------------------
312 * Find the next object from *info.
313 * -------------------------------------------------------------------------- */
314 static INLINE StgClosure *
315 find_ptrs( stackPos *info )
317 if (info->next.ptrs.pos < info->next.ptrs.ptrs) {
318 return (StgClosure *)info->next.ptrs.payload[info->next.ptrs.pos++];
324 /* -----------------------------------------------------------------------------
325 * Initializes *info from SRT information stored in *infoTable.
326 * -------------------------------------------------------------------------- */
328 init_srt_fun( stackPos *info, StgFunInfoTable *infoTable )
330 if (infoTable->i.srt_bitmap == (StgHalfWord)(-1)) {
331 info->type = posTypeLargeSRT;
332 info->next.large_srt.srt = (StgLargeSRT *)GET_FUN_SRT(infoTable);
333 info->next.large_srt.offset = 0;
335 info->type = posTypeSRT;
336 info->next.srt.srt = (StgClosure **)GET_FUN_SRT(infoTable);
337 info->next.srt.srt_bitmap = infoTable->i.srt_bitmap;
342 init_srt_thunk( stackPos *info, StgThunkInfoTable *infoTable )
344 if (infoTable->i.srt_bitmap == (StgHalfWord)(-1)) {
345 info->type = posTypeLargeSRT;
346 info->next.large_srt.srt = (StgLargeSRT *)GET_SRT(infoTable);
347 info->next.large_srt.offset = 0;
349 info->type = posTypeSRT;
350 info->next.srt.srt = (StgClosure **)GET_SRT(infoTable);
351 info->next.srt.srt_bitmap = infoTable->i.srt_bitmap;
355 /* -----------------------------------------------------------------------------
356 * Find the next object from *info.
357 * -------------------------------------------------------------------------- */
358 static INLINE StgClosure *
359 find_srt( stackPos *info )
364 if (info->type == posTypeSRT) {
366 bitmap = info->next.srt.srt_bitmap;
367 while (bitmap != 0) {
368 if ((bitmap & 1) != 0) {
369 #if defined(__PIC__) && defined(mingw32_TARGET_OS)
370 if ((unsigned long)(*(info->next.srt.srt)) & 0x1)
371 c = (* (StgClosure **)((unsigned long)*(info->next.srt.srt)) & ~0x1);
373 c = *(info->next.srt.srt);
375 c = *(info->next.srt.srt);
377 bitmap = bitmap >> 1;
378 info->next.srt.srt++;
379 info->next.srt.srt_bitmap = bitmap;
382 bitmap = bitmap >> 1;
383 info->next.srt.srt++;
385 // bitmap is now zero...
390 nat i = info->next.large_srt.offset;
393 // Follow the pattern from GC.c:scavenge_large_srt_bitmap().
394 bitmap = info->next.large_srt.srt->l.bitmap[i / BITS_IN(W_)];
395 bitmap = bitmap >> (i % BITS_IN(StgWord));
396 while (i < info->next.large_srt.srt->l.size) {
397 if ((bitmap & 1) != 0) {
398 c = ((StgClosure **)info->next.large_srt.srt->srt)[i];
400 info->next.large_srt.offset = i;
404 if (i % BITS_IN(W_) == 0) {
405 bitmap = info->next.large_srt.srt->l.bitmap[i / BITS_IN(W_)];
407 bitmap = bitmap >> 1;
410 // reached the end of this bitmap.
411 info->next.large_srt.offset = i;
416 /* -----------------------------------------------------------------------------
417 * push() pushes a stackElement representing the next child of *c
418 * onto the traverse stack. If *c has no child, *first_child is set
419 * to NULL and nothing is pushed onto the stack. If *c has only one
420 * child, *c_chlid is set to that child and nothing is pushed onto
421 * the stack. If *c has more than two children, *first_child is set
422 * to the first child and a stackElement representing the second
423 * child is pushed onto the stack.
426 * *c_child_r is the most recent retainer of *c's children.
427 * *c is not any of TSO, AP, PAP, AP_STACK, which means that
428 * there cannot be any stack objects.
429 * Note: SRTs are considered to be children as well.
430 * -------------------------------------------------------------------------- */
432 push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
435 bdescr *nbd; // Next Block Descriptor
437 #ifdef DEBUG_RETAINER
438 // debugBelch("push(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
441 ASSERT(get_itbl(c)->type != TSO);
442 ASSERT(get_itbl(c)->type != AP_STACK);
449 se.c_child_r = c_child_r;
452 switch (get_itbl(c)->type) {
462 // one child (fixed), no SRT
465 *first_child = ((StgMutVar *)c)->var;
468 *first_child = ((StgSelector *)c)->selectee;
471 case IND_OLDGEN_PERM:
473 *first_child = ((StgInd *)c)->indirectee;
477 *first_child = c->payload[0];
480 // For CONSTR_2_0 and MVAR, we use se.info.step to record the position
481 // of the next child. We do not write a separate initialization code.
482 // Also we do not have to initialize info.type;
484 // two children (fixed), no SRT
485 // need to push a stackElement, but nothing to store in se.info
487 *first_child = c->payload[0]; // return the first pointer
488 // se.info.type = posTypeStep;
489 // se.info.next.step = 2; // 2 = second
492 // three children (fixed), no SRT
493 // need to push a stackElement
496 // head must be TSO and the head of a linked list of TSOs.
497 // Shoule it be a child? Seems to be yes.
498 *first_child = (StgClosure *)((StgMVar *)c)->head;
499 // se.info.type = posTypeStep;
500 se.info.next.step = 2; // 2 = second
503 // three children (fixed), no SRT
505 *first_child = ((StgWeak *)c)->key;
506 // se.info.type = posTypeStep;
507 se.info.next.step = 2;
510 // layout.payload.ptrs, no SRT
516 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
518 *first_child = find_ptrs(&se.info);
519 if (*first_child == NULL)
523 // StgMutArrPtr.ptrs, no SRT
524 case MUT_ARR_PTRS_CLEAN:
525 case MUT_ARR_PTRS_DIRTY:
526 case MUT_ARR_PTRS_FROZEN:
527 case MUT_ARR_PTRS_FROZEN0:
528 init_ptrs(&se.info, ((StgMutArrPtrs *)c)->ptrs,
529 (StgPtr)(((StgMutArrPtrs *)c)->payload));
530 *first_child = find_ptrs(&se.info);
531 if (*first_child == NULL)
535 // layout.payload.ptrs, SRT
536 case FUN: // *c is a heap object.
538 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
539 *first_child = find_ptrs(&se.info);
540 if (*first_child == NULL)
541 // no child from ptrs, so check SRT
547 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
548 (StgPtr)((StgThunk *)c)->payload);
549 *first_child = find_ptrs(&se.info);
550 if (*first_child == NULL)
551 // no child from ptrs, so check SRT
555 // 1 fixed child, SRT
558 *first_child = c->payload[0];
559 ASSERT(*first_child != NULL);
560 init_srt_fun(&se.info, get_fun_itbl(c));
565 *first_child = ((StgThunk *)c)->payload[0];
566 ASSERT(*first_child != NULL);
567 init_srt_thunk(&se.info, get_thunk_itbl(c));
570 case FUN_STATIC: // *c is a heap object.
571 ASSERT(get_itbl(c)->srt_bitmap != 0);
575 init_srt_fun(&se.info, get_fun_itbl(c));
576 *first_child = find_srt(&se.info);
577 if (*first_child == NULL)
583 ASSERT(get_itbl(c)->srt_bitmap != 0);
587 init_srt_thunk(&se.info, get_thunk_itbl(c));
588 *first_child = find_srt(&se.info);
589 if (*first_child == NULL)
594 *first_child = (StgClosure *)((StgTRecChunk *)c)->prev_chunk;
595 se.info.next.step = 0; // entry no.
604 case CONSTR_NOCAF_STATIC:
617 barf("Invalid object *c in push()");
621 if (stackTop - 1 < stackBottom) {
622 #ifdef DEBUG_RETAINER
623 // debugBelch("push() to the next stack.\n");
625 // currentStack->free is updated when the active stack is switched
626 // to the next stack.
627 currentStack->free = (StgPtr)stackTop;
629 if (currentStack->link == NULL) {
630 nbd = allocGroup(BLOCKS_IN_STACK);
632 nbd->u.back = currentStack;
633 currentStack->link = nbd;
635 nbd = currentStack->link;
640 // adjust stackTop (acutal push)
642 // If the size of stackElement was huge, we would better replace the
643 // following statement by either a memcpy() call or a switch statement
644 // on the type of the element. Currently, the size of stackElement is
645 // small enough (5 words) that this direct assignment seems to be enough.
647 // ToDo: The line below leads to the warning:
648 // warning: 'se.info.type' may be used uninitialized in this function
649 // This is caused by the fact that there are execution paths through the
650 // large switch statement above where some cases do not initialize this
651 // field. Is this really harmless? Can we avoid the warning?
654 #ifdef DEBUG_RETAINER
656 if (stackSize > maxStackSize) maxStackSize = stackSize;
657 // ASSERT(stackSize >= 0);
658 // debugBelch("stackSize = %d\n", stackSize);
662 /* -----------------------------------------------------------------------------
663 * popOff() and popOffReal(): Pop a stackElement off the traverse stack.
665 * stackTop cannot be equal to stackLimit unless the whole stack is
666 * empty, in which case popOff() is not allowed.
668 * You can think of popOffReal() as a part of popOff() which is
669 * executed at the end of popOff() in necessary. Since popOff() is
670 * likely to be executed quite often while popOffReal() is not, we
671 * separate popOffReal() from popOff(), which is declared as an
672 * INLINE function (for the sake of execution speed). popOffReal()
673 * is called only within popOff() and nowhere else.
674 * -------------------------------------------------------------------------- */
678 bdescr *pbd; // Previous Block Descriptor
680 #ifdef DEBUG_RETAINER
681 // debugBelch("pop() to the previous stack.\n");
684 ASSERT(stackTop + 1 == stackLimit);
685 ASSERT(stackBottom == (stackElement *)currentStack->start);
687 if (firstStack == currentStack) {
688 // The stack is completely empty.
690 ASSERT(stackTop == stackLimit);
691 #ifdef DEBUG_RETAINER
693 if (stackSize > maxStackSize) maxStackSize = stackSize;
695 ASSERT(stackSize >= 0);
696 debugBelch("stackSize = %d\n", stackSize);
702 // currentStack->free is updated when the active stack is switched back
703 // to the previous stack.
704 currentStack->free = (StgPtr)stackLimit;
706 // find the previous block descriptor
707 pbd = currentStack->u.back;
710 returnToOldStack(pbd);
712 #ifdef DEBUG_RETAINER
714 if (stackSize > maxStackSize) maxStackSize = stackSize;
716 ASSERT(stackSize >= 0);
717 debugBelch("stackSize = %d\n", stackSize);
724 #ifdef DEBUG_RETAINER
725 // debugBelch("\tpopOff(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
728 ASSERT(stackTop != stackLimit);
729 ASSERT(!isEmptyRetainerStack());
731 // <= (instead of <) is wrong!
732 if (stackTop + 1 < stackLimit) {
734 #ifdef DEBUG_RETAINER
736 if (stackSize > maxStackSize) maxStackSize = stackSize;
738 ASSERT(stackSize >= 0);
739 debugBelch("stackSize = %d\n", stackSize);
748 /* -----------------------------------------------------------------------------
749 * Finds the next object to be considered for retainer profiling and store
751 * Test if the topmost stack element indicates that more objects are left,
752 * and if so, retrieve the first object and store its pointer to *c. Also,
753 * set *cp and *r appropriately, both of which are stored in the stack element.
754 * The topmost stack element then is overwritten so as for it to now denote
756 * If the topmost stack element indicates no more objects are left, pop
757 * off the stack element until either an object can be retrieved or
758 * the current stack chunk becomes empty, indicated by rtsTrue returned by
759 * isOnBoundary(), in which case *c is set to NULL.
761 * It is okay to call this function even when the current stack chunk
763 * -------------------------------------------------------------------------- */
765 pop( StgClosure **c, StgClosure **cp, retainer *r )
769 #ifdef DEBUG_RETAINER
770 // debugBelch("pop(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
774 if (isOnBoundary()) { // if the current stack chunk is depleted
781 switch (get_itbl(se->c)->type) {
782 // two children (fixed), no SRT
783 // nothing in se.info
785 *c = se->c->payload[1];
791 // three children (fixed), no SRT
792 // need to push a stackElement
795 if (se->info.next.step == 2) {
796 *c = (StgClosure *)((StgMVar *)se->c)->tail;
797 se->info.next.step++; // move to the next step
800 *c = ((StgMVar *)se->c)->value;
807 // three children (fixed), no SRT
809 if (se->info.next.step == 2) {
810 *c = ((StgWeak *)se->c)->value;
811 se->info.next.step++;
814 *c = ((StgWeak *)se->c)->finalizer;
822 // These are pretty complicated: we have N entries, each
823 // of which contains 3 fields that we want to follow. So
824 // we divide the step counter: the 2 low bits indicate
825 // which field, and the rest of the bits indicate the
826 // entry number (starting from zero).
828 nat entry_no = se->info.next.step >> 2;
829 nat field_no = se->info.next.step & 3;
830 if (entry_no == ((StgTRecChunk *)se->c)->next_entry_idx) {
835 entry = &((StgTRecChunk *)se->c)->entries[entry_no];
837 *c = (StgClosure *)entry->tvar;
838 } else if (field_no == 1) {
839 *c = entry->expected_value;
841 *c = entry->new_value;
845 se->info.next.step++;
854 // StgMutArrPtr.ptrs, no SRT
855 case MUT_ARR_PTRS_CLEAN:
856 case MUT_ARR_PTRS_DIRTY:
857 case MUT_ARR_PTRS_FROZEN:
858 case MUT_ARR_PTRS_FROZEN0:
859 *c = find_ptrs(&se->info);
868 // layout.payload.ptrs, SRT
869 case FUN: // always a heap object
871 if (se->info.type == posTypePtrs) {
872 *c = find_ptrs(&se->info);
878 init_srt_fun(&se->info, get_fun_itbl(se->c));
884 if (se->info.type == posTypePtrs) {
885 *c = find_ptrs(&se->info);
891 init_srt_thunk(&se->info, get_thunk_itbl(se->c));
907 *c = find_srt(&se->info);
916 // no child (fixed), no SRT
922 // one child (fixed), no SRT
927 case IND_OLDGEN_PERM:
936 case CONSTR_NOCAF_STATIC:
949 barf("Invalid object *c in pop()");
955 /* -----------------------------------------------------------------------------
956 * RETAINER PROFILING ENGINE
957 * -------------------------------------------------------------------------- */
960 initRetainerProfiling( void )
962 initializeAllRetainerSet();
963 retainerGeneration = 0;
966 /* -----------------------------------------------------------------------------
967 * This function must be called before f-closing prof_file.
968 * -------------------------------------------------------------------------- */
970 endRetainerProfiling( void )
972 #ifdef SECOND_APPROACH
973 outputAllRetainerSet(prof_file);
977 /* -----------------------------------------------------------------------------
978 * Returns the actual pointer to the retainer set of the closure *c.
979 * It may adjust RSET(c) subject to flip.
981 * RSET(c) is initialized to NULL if its current value does not
984 * Even though this function has side effects, they CAN be ignored because
985 * subsequent calls to retainerSetOf() always result in the same return value
986 * and retainerSetOf() is the only way to retrieve retainerSet of a given
988 * We have to perform an XOR (^) operation each time a closure is examined.
989 * The reason is that we do not know when a closure is visited last.
990 * -------------------------------------------------------------------------- */
992 maybeInitRetainerSet( StgClosure *c )
994 if (!isRetainerSetFieldValid(c)) {
995 setRetainerSetToNull(c);
999 /* -----------------------------------------------------------------------------
1000 * Returns rtsTrue if *c is a retainer.
1001 * -------------------------------------------------------------------------- */
1002 static INLINE rtsBool
1003 isRetainer( StgClosure *c )
1005 switch (get_itbl(c)->type) {
1009 // TSOs MUST be retainers: they constitute the set of roots.
1018 case MUT_ARR_PTRS_CLEAN:
1019 case MUT_ARR_PTRS_DIRTY:
1020 case MUT_ARR_PTRS_FROZEN:
1021 case MUT_ARR_PTRS_FROZEN0:
1023 // thunks are retainers.
1030 case THUNK_SELECTOR:
1034 // Static thunks, or CAFS, are obviously retainers.
1037 // WEAK objects are roots; there is separate code in which traversing
1038 // begins from WEAK objects.
1060 // partial applications
1067 case IND_OLDGEN_PERM:
1083 // IND_STATIC cannot be *c, *cp, *r in the retainer profiling loop.
1085 // CONSTR_NOCAF_STATIC
1086 // cannot be *c, *cp, *r in the retainer profiling loop.
1087 case CONSTR_NOCAF_STATIC:
1088 // Stack objects are invalid because they are never treated as
1089 // legal objects during retainer profiling.
1099 case INVALID_OBJECT:
1101 barf("Invalid object in isRetainer(): %d", get_itbl(c)->type);
1106 /* -----------------------------------------------------------------------------
1107 * Returns the retainer function value for the closure *c, i.e., R(*c).
1108 * This function does NOT return the retainer(s) of *c.
1110 * *c must be a retainer.
1112 * Depending on the definition of this function, the maintenance of retainer
1113 * sets can be made easier. If most retainer sets are likely to be created
1114 * again across garbage collections, refreshAllRetainerSet() in
1115 * RetainerSet.c can simply do nothing.
1116 * If this is not the case, we can free all the retainer sets and
1117 * re-initialize the hash table.
1118 * See refreshAllRetainerSet() in RetainerSet.c.
1119 * -------------------------------------------------------------------------- */
1120 static INLINE retainer
1121 getRetainerFrom( StgClosure *c )
1123 ASSERT(isRetainer(c));
1125 #if defined(RETAINER_SCHEME_INFO)
1126 // Retainer scheme 1: retainer = info table
1128 #elif defined(RETAINER_SCHEME_CCS)
1129 // Retainer scheme 2: retainer = cost centre stack
1130 return c->header.prof.ccs;
1131 #elif defined(RETAINER_SCHEME_CC)
1132 // Retainer scheme 3: retainer = cost centre
1133 return c->header.prof.ccs->cc;
1137 /* -----------------------------------------------------------------------------
1138 * Associates the retainer set *s with the closure *c, that is, *s becomes
1139 * the retainer set of *c.
1143 * -------------------------------------------------------------------------- */
1145 associate( StgClosure *c, RetainerSet *s )
1147 // StgWord has the same size as pointers, so the following type
1149 RSET(c) = (RetainerSet *)((StgWord)s | flip);
1152 /* -----------------------------------------------------------------------------
1153 Call retainClosure for each of the closures covered by a large bitmap.
1154 -------------------------------------------------------------------------- */
1157 retain_large_bitmap (StgPtr p, StgLargeBitmap *large_bitmap, nat size,
1158 StgClosure *c, retainer c_child_r)
1164 bitmap = large_bitmap->bitmap[b];
1165 for (i = 0; i < size; ) {
1166 if ((bitmap & 1) == 0) {
1167 retainClosure((StgClosure *)*p, c, c_child_r);
1171 if (i % BITS_IN(W_) == 0) {
1173 bitmap = large_bitmap->bitmap[b];
1175 bitmap = bitmap >> 1;
1180 static INLINE StgPtr
1181 retain_small_bitmap (StgPtr p, nat size, StgWord bitmap,
1182 StgClosure *c, retainer c_child_r)
1185 if ((bitmap & 1) == 0) {
1186 retainClosure((StgClosure *)*p, c, c_child_r);
1189 bitmap = bitmap >> 1;
1195 /* -----------------------------------------------------------------------------
1196 * Call retainClosure for each of the closures in an SRT.
1197 * ------------------------------------------------------------------------- */
1200 retain_large_srt_bitmap (StgLargeSRT *srt, StgClosure *c, retainer c_child_r)
1207 p = (StgClosure **)srt->srt;
1209 bitmap = srt->l.bitmap[b];
1210 for (i = 0; i < size; ) {
1211 if ((bitmap & 1) != 0) {
1212 retainClosure((StgClosure *)*p, c, c_child_r);
1216 if (i % BITS_IN(W_) == 0) {
1218 bitmap = srt->l.bitmap[b];
1220 bitmap = bitmap >> 1;
1226 retainSRT (StgClosure **srt, nat srt_bitmap, StgClosure *c, retainer c_child_r)
1231 bitmap = srt_bitmap;
1234 if (bitmap == (StgHalfWord)(-1)) {
1235 retain_large_srt_bitmap( (StgLargeSRT *)srt, c, c_child_r );
1239 while (bitmap != 0) {
1240 if ((bitmap & 1) != 0) {
1241 #if defined(__PIC__) && defined(mingw32_TARGET_OS)
1242 if ( (unsigned long)(*srt) & 0x1 ) {
1243 retainClosure(* (StgClosure**) ((unsigned long) (*srt) & ~0x1),
1246 retainClosure(*srt,c,c_child_r);
1249 retainClosure(*srt,c,c_child_r);
1253 bitmap = bitmap >> 1;
1257 /* -----------------------------------------------------------------------------
1258 * Process all the objects in the stack chunk from stackStart to stackEnd
1259 * with *c and *c_child_r being their parent and their most recent retainer,
1260 * respectively. Treat stackOptionalFun as another child of *c if it is
1263 * *c is one of the following: TSO, AP_STACK.
1264 * If *c is TSO, c == c_child_r.
1265 * stackStart < stackEnd.
1266 * RSET(c) and RSET(c_child_r) are valid, i.e., their
1267 * interpretation conforms to the current value of flip (even when they
1268 * are interpreted to be NULL).
1269 * If *c is TSO, its state is not any of ThreadRelocated, ThreadComplete,
1270 * or ThreadKilled, which means that its stack is ready to process.
1272 * This code was almost plagiarzied from GC.c! For each pointer,
1273 * retainClosure() is invoked instead of evacuate().
1274 * -------------------------------------------------------------------------- */
1276 retainStack( StgClosure *c, retainer c_child_r,
1277 StgPtr stackStart, StgPtr stackEnd )
1279 stackElement *oldStackBoundary;
1281 StgRetInfoTable *info;
1285 #ifdef DEBUG_RETAINER
1287 if (cStackSize > maxCStackSize) maxCStackSize = cStackSize;
1291 Each invocation of retainStack() creates a new virtual
1292 stack. Since all such stacks share a single common stack, we
1293 record the current currentStackBoundary, which will be restored
1296 oldStackBoundary = currentStackBoundary;
1297 currentStackBoundary = stackTop;
1299 #ifdef DEBUG_RETAINER
1300 // debugBelch("retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
1303 ASSERT(get_itbl(c)->type != TSO ||
1304 (((StgTSO *)c)->what_next != ThreadRelocated &&
1305 ((StgTSO *)c)->what_next != ThreadComplete &&
1306 ((StgTSO *)c)->what_next != ThreadKilled));
1309 while (p < stackEnd) {
1310 info = get_ret_itbl((StgClosure *)p);
1312 switch(info->i.type) {
1315 retainClosure(((StgUpdateFrame *)p)->updatee, c, c_child_r);
1316 p += sizeofW(StgUpdateFrame);
1321 case CATCH_STM_FRAME:
1322 case CATCH_RETRY_FRAME:
1323 case ATOMICALLY_FRAME:
1325 bitmap = BITMAP_BITS(info->i.layout.bitmap);
1326 size = BITMAP_SIZE(info->i.layout.bitmap);
1328 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1331 retainSRT((StgClosure **)GET_SRT(info), info->i.srt_bitmap, c, c_child_r);
1338 retainClosure((StgClosure *)*p, c, c_child_r);
1341 size = BCO_BITMAP_SIZE(bco);
1342 retain_large_bitmap(p, BCO_BITMAP(bco), size, c, c_child_r);
1347 // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
1349 size = GET_LARGE_BITMAP(&info->i)->size;
1351 retain_large_bitmap(p, GET_LARGE_BITMAP(&info->i),
1352 size, c, c_child_r);
1354 // and don't forget to follow the SRT
1357 // Dynamic bitmap: the mask is stored on the stack
1360 dyn = ((StgRetDyn *)p)->liveness;
1362 // traverse the bitmap first
1363 bitmap = RET_DYN_LIVENESS(dyn);
1364 p = (P_)&((StgRetDyn *)p)->payload[0];
1365 size = RET_DYN_BITMAP_SIZE;
1366 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1368 // skip over the non-ptr words
1369 p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
1371 // follow the ptr words
1372 for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
1373 retainClosure((StgClosure *)*p, c, c_child_r);
1380 StgRetFun *ret_fun = (StgRetFun *)p;
1381 StgFunInfoTable *fun_info;
1383 retainClosure(ret_fun->fun, c, c_child_r);
1384 fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
1386 p = (P_)&ret_fun->payload;
1387 switch (fun_info->f.fun_type) {
1389 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
1390 size = BITMAP_SIZE(fun_info->f.b.bitmap);
1391 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1394 size = GET_FUN_LARGE_BITMAP(fun_info)->size;
1395 retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
1396 size, c, c_child_r);
1400 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1401 size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
1402 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1409 barf("Invalid object found in retainStack(): %d",
1410 (int)(info->i.type));
1414 // restore currentStackBoundary
1415 currentStackBoundary = oldStackBoundary;
1416 #ifdef DEBUG_RETAINER
1417 // debugBelch("retainStack() finished: currentStackBoundary = 0x%x\n", currentStackBoundary);
1420 #ifdef DEBUG_RETAINER
1425 /* ----------------------------------------------------------------------------
1426 * Call retainClosure for each of the children of a PAP/AP
1427 * ------------------------------------------------------------------------- */
1429 static INLINE StgPtr
1430 retain_PAP_payload (StgClosure *pap, /* NOT tagged */
1431 retainer c_child_r, /* NOT tagged */
1432 StgClosure *fun, /* tagged */
1433 StgClosure** payload, StgWord n_args)
1437 StgFunInfoTable *fun_info;
1439 retainClosure(fun, pap, c_child_r);
1440 fun = UNTAG_CLOSURE(fun);
1441 fun_info = get_fun_itbl(fun);
1442 ASSERT(fun_info->i.type != PAP);
1444 p = (StgPtr)payload;
1446 switch (fun_info->f.fun_type) {
1448 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
1449 p = retain_small_bitmap(p, n_args, bitmap,
1453 retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
1454 n_args, pap, c_child_r);
1458 retain_large_bitmap((StgPtr)payload, BCO_BITMAP(fun),
1459 n_args, pap, c_child_r);
1463 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1464 p = retain_small_bitmap(p, n_args, bitmap, pap, c_child_r);
1470 /* -----------------------------------------------------------------------------
1471 * Compute the retainer set of *c0 and all its desecents by traversing.
1472 * *cp0 is the parent of *c0, and *r0 is the most recent retainer of *c0.
1474 * c0 = cp0 = r0 holds only for root objects.
1475 * RSET(cp0) and RSET(r0) are valid, i.e., their
1476 * interpretation conforms to the current value of flip (even when they
1477 * are interpreted to be NULL).
1478 * However, RSET(c0) may be corrupt, i.e., it may not conform to
1479 * the current value of flip. If it does not, during the execution
1480 * of this function, RSET(c0) must be initialized as well as all
1483 * stackTop must be the same at the beginning and the exit of this function.
1484 * *c0 can be TSO (as well as AP_STACK).
1485 * -------------------------------------------------------------------------- */
1487 retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
1489 // c = Current closure (possibly tagged)
1490 // cp = Current closure's Parent (NOT tagged)
1491 // r = current closures' most recent Retainer (NOT tagged)
1492 // c_child_r = current closure's children's most recent retainer
1493 // first_child = first child of c
1494 StgClosure *c, *cp, *first_child;
1495 RetainerSet *s, *retainerSetOfc;
1496 retainer r, c_child_r;
1499 #ifdef DEBUG_RETAINER
1500 // StgPtr oldStackTop;
1503 #ifdef DEBUG_RETAINER
1504 // oldStackTop = stackTop;
1505 // debugBelch("retainClosure() called: c0 = 0x%x, cp0 = 0x%x, r0 = 0x%x\n", c0, cp0, r0);
1508 // (c, cp, r) = (c0, cp0, r0)
1515 //debugBelch("loop");
1516 // pop to (c, cp, r);
1520 #ifdef DEBUG_RETAINER
1521 // debugBelch("retainClosure() ends: oldStackTop = 0x%x, stackTop = 0x%x\n", oldStackTop, stackTop);
1526 //debugBelch("inner_loop");
1529 c = UNTAG_CLOSURE(c);
1531 // c = current closure under consideration,
1532 // cp = current closure's parent,
1533 // r = current closure's most recent retainer
1535 // Loop invariants (on the meaning of c, cp, r, and their retainer sets):
1536 // RSET(cp) and RSET(r) are valid.
1537 // RSET(c) is valid only if c has been visited before.
1539 // Loop invariants (on the relation between c, cp, and r)
1540 // if cp is not a retainer, r belongs to RSET(cp).
1541 // if cp is a retainer, r == cp.
1543 typeOfc = get_itbl(c)->type;
1545 #ifdef DEBUG_RETAINER
1548 case CONSTR_NOCAF_STATIC:
1554 if (retainerSetOf(c) == NULL) { // first visit?
1555 costArray[typeOfc] += cost(c);
1556 sumOfNewCost += cost(c);
1565 if (((StgTSO *)c)->what_next == ThreadComplete ||
1566 ((StgTSO *)c)->what_next == ThreadKilled) {
1567 #ifdef DEBUG_RETAINER
1568 debugBelch("ThreadComplete or ThreadKilled encountered in retainClosure()\n");
1572 if (((StgTSO *)c)->what_next == ThreadRelocated) {
1573 #ifdef DEBUG_RETAINER
1574 debugBelch("ThreadRelocated encountered in retainClosure()\n");
1576 c = (StgClosure *)((StgTSO *)c)->_link;
1582 // We just skip IND_STATIC, so its retainer set is never computed.
1583 c = ((StgIndStatic *)c)->indirectee;
1585 // static objects with no pointers out, so goto loop.
1586 case CONSTR_NOCAF_STATIC:
1587 // It is not just enough not to compute the retainer set for *c; it is
1588 // mandatory because CONSTR_NOCAF_STATIC are not reachable from
1589 // scavenged_static_objects, the list from which is assumed to traverse
1590 // all static objects after major garbage collections.
1594 if (get_itbl(c)->srt_bitmap == 0) {
1595 // No need to compute the retainer set; no dynamic objects
1596 // are reachable from *c.
1598 // Static objects: if we traverse all the live closures,
1599 // including static closures, during each heap census then
1600 // we will observe that some static closures appear and
1601 // disappear. eg. a closure may contain a pointer to a
1602 // static function 'f' which is not otherwise reachable
1603 // (it doesn't indirectly point to any CAFs, so it doesn't
1604 // appear in any SRTs), so we would find 'f' during
1605 // traversal. However on the next sweep there may be no
1606 // closures pointing to 'f'.
1608 // We must therefore ignore static closures whose SRT is
1609 // empty, because these are exactly the closures that may
1610 // "appear". A closure with a non-empty SRT, and which is
1611 // still required, will always be reachable.
1613 // But what about CONSTR_STATIC? Surely these may be able
1614 // to appear, and they don't have SRTs, so we can't
1615 // check. So for now, we're calling
1616 // resetStaticObjectForRetainerProfiling() from the
1617 // garbage collector to reset the retainer sets in all the
1618 // reachable static objects.
1625 // The above objects are ignored in computing the average number of times
1626 // an object is visited.
1627 timesAnyObjectVisited++;
1629 // If this is the first visit to c, initialize its retainer set.
1630 maybeInitRetainerSet(c);
1631 retainerSetOfc = retainerSetOf(c);
1634 // isRetainer(cp) == rtsTrue => s == NULL
1635 // isRetainer(cp) == rtsFalse => s == cp.retainer
1639 s = retainerSetOf(cp);
1641 // (c, cp, r, s) is available.
1643 // (c, cp, r, s, R_r) is available, so compute the retainer set for *c.
1644 if (retainerSetOfc == NULL) {
1645 // This is the first visit to *c.
1649 associate(c, singleton(r));
1651 // s is actually the retainer set of *c!
1654 // compute c_child_r
1655 c_child_r = isRetainer(c) ? getRetainerFrom(c) : r;
1657 // This is not the first visit to *c.
1658 if (isMember(r, retainerSetOfc))
1659 goto loop; // no need to process child
1662 associate(c, addElement(r, retainerSetOfc));
1664 // s is not NULL and cp is not a retainer. This means that
1665 // each time *cp is visited, so is *c. Thus, if s has
1666 // exactly one more element in its retainer set than c, s
1667 // is also the new retainer set for *c.
1668 if (s->num == retainerSetOfc->num + 1) {
1671 // Otherwise, just add R_r to the current retainer set of *c.
1673 associate(c, addElement(r, retainerSetOfc));
1678 goto loop; // no need to process child
1680 // compute c_child_r
1684 // now, RSET() of all of *c, *cp, and *r is valid.
1685 // (c, c_child_r) are available.
1689 // Special case closures: we process these all in one go rather
1690 // than attempting to save the current position, because doing so
1694 retainStack(c, c_child_r,
1696 ((StgTSO *)c)->stack + ((StgTSO *)c)->stack_size);
1701 StgPAP *pap = (StgPAP *)c;
1702 retain_PAP_payload(c, c_child_r, pap->fun, pap->payload, pap->n_args);
1708 StgAP *ap = (StgAP *)c;
1709 retain_PAP_payload(c, c_child_r, ap->fun, ap->payload, ap->n_args);
1714 retainClosure(((StgAP_STACK *)c)->fun, c, c_child_r);
1715 retainStack(c, c_child_r,
1716 (StgPtr)((StgAP_STACK *)c)->payload,
1717 (StgPtr)((StgAP_STACK *)c)->payload +
1718 ((StgAP_STACK *)c)->size);
1722 push(c, c_child_r, &first_child);
1724 // If first_child is null, c has no child.
1725 // If first_child is not null, the top stack element points to the next
1726 // object. push() may or may not push a stackElement on the stack.
1727 if (first_child == NULL)
1730 // (c, cp, r) = (first_child, c, c_child_r)
1737 /* -----------------------------------------------------------------------------
1738 * Compute the retainer set for every object reachable from *tl.
1739 * -------------------------------------------------------------------------- */
1741 retainRoot(void *user STG_UNUSED, StgClosure **tl)
1745 // We no longer assume that only TSOs and WEAKs are roots; any closure can
1748 ASSERT(isEmptyRetainerStack());
1749 currentStackBoundary = stackTop;
1751 c = UNTAG_CLOSURE(*tl);
1752 if (c != &stg_END_TSO_QUEUE_closure && isRetainer(c)) {
1753 retainClosure(c, c, getRetainerFrom(c));
1755 retainClosure(c, c, CCS_SYSTEM);
1758 // NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl)));
1759 // *tl might be a TSO which is ThreadComplete, in which
1760 // case we ignore it for the purposes of retainer profiling.
1763 /* -----------------------------------------------------------------------------
1764 * Compute the retainer set for each of the objects in the heap.
1765 * -------------------------------------------------------------------------- */
1767 computeRetainerSet( void )
1774 #ifdef DEBUG_RETAINER
1775 RetainerSet tmpRetainerSet;
1778 markCapabilities(retainRoot, NULL); // for scheduler roots
1780 // This function is called after a major GC, when key, value, and finalizer
1781 // all are guaranteed to be valid, or reachable.
1783 // The following code assumes that WEAK objects are considered to be roots
1784 // for retainer profilng.
1785 for (weak = weak_ptr_list; weak != NULL; weak = weak->link)
1786 // retainRoot((StgClosure *)weak);
1787 retainRoot(NULL, (StgClosure **)&weak);
1789 // Consider roots from the stable ptr table.
1790 markStablePtrTable(retainRoot, NULL);
1792 // The following code resets the rs field of each unvisited mutable
1793 // object (computing sumOfNewCostExtra and updating costArray[] when
1794 // debugging retainer profiler).
1795 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1796 // NOT TRUE: even G0 has a block on its mutable list
1797 // ASSERT(g != 0 || (generations[g].mut_list == NULL));
1799 // Traversing through mut_list is necessary
1800 // because we can find MUT_VAR objects which have not been
1801 // visited during retainer profiling.
1802 for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
1803 for (ml = bd->start; ml < bd->free; ml++) {
1805 maybeInitRetainerSet((StgClosure *)*ml);
1806 rtl = retainerSetOf((StgClosure *)*ml);
1808 #ifdef DEBUG_RETAINER
1810 // first visit to *ml
1811 // This is a violation of the interface rule!
1812 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1814 switch (get_itbl((StgClosure *)ml)->type) {
1818 case CONSTR_NOCAF_STATIC:
1822 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1826 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1827 sumOfNewCostExtra += cost((StgClosure *)ml);
1837 /* -----------------------------------------------------------------------------
1838 * Traverse all static objects for which we compute retainer sets,
1839 * and reset their rs fields to NULL, which is accomplished by
1840 * invoking maybeInitRetainerSet(). This function must be called
1841 * before zeroing all objects reachable from scavenged_static_objects
1842 * in the case of major gabage collections. See GarbageCollect() in
1845 * The mut_once_list of the oldest generation must also be traversed?
1846 * Why? Because if the evacuation of an object pointed to by a static
1847 * indirection object fails, it is put back to the mut_once_list of
1848 * the oldest generation.
1849 * However, this is not necessary because any static indirection objects
1850 * are just traversed through to reach dynamic objects. In other words,
1851 * they are not taken into consideration in computing retainer sets.
1852 * -------------------------------------------------------------------------- */
1854 resetStaticObjectForRetainerProfiling( StgClosure *static_objects )
1856 #ifdef DEBUG_RETAINER
1861 #ifdef DEBUG_RETAINER
1865 while (p != END_OF_STATIC_LIST) {
1866 #ifdef DEBUG_RETAINER
1869 switch (get_itbl(p)->type) {
1871 // Since we do not compute the retainer set of any
1872 // IND_STATIC object, we don't have to reset its retainer
1874 p = (StgClosure*)*IND_STATIC_LINK(p);
1877 maybeInitRetainerSet(p);
1878 p = (StgClosure*)*THUNK_STATIC_LINK(p);
1881 maybeInitRetainerSet(p);
1882 p = (StgClosure*)*FUN_STATIC_LINK(p);
1885 maybeInitRetainerSet(p);
1886 p = (StgClosure*)*STATIC_LINK(get_itbl(p), p);
1889 barf("resetStaticObjectForRetainerProfiling: %p (%s)",
1890 p, get_itbl(p)->type);
1894 #ifdef DEBUG_RETAINER
1895 // debugBelch("count in scavenged_static_objects = %d\n", count);
1899 /* -----------------------------------------------------------------------------
1900 * Perform retainer profiling.
1901 * N is the oldest generation being profilied, where the generations are
1902 * numbered starting at 0.
1905 * This function should be called only immediately after major garbage
1907 * ------------------------------------------------------------------------- */
1909 retainerProfile(void)
1911 #ifdef DEBUG_RETAINER
1913 nat totalHeapSize; // total raw heap size (computed by linear scanning)
1916 #ifdef DEBUG_RETAINER
1917 debugBelch(" < retainerProfile() invoked : %d>\n", retainerGeneration);
1922 // We haven't flipped the bit yet.
1923 #ifdef DEBUG_RETAINER
1924 debugBelch("Before traversing:\n");
1925 sumOfCostLinear = 0;
1926 for (i = 0;i < N_CLOSURE_TYPES; i++)
1927 costArrayLinear[i] = 0;
1928 totalHeapSize = checkHeapSanityForRetainerProfiling();
1930 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1932 debugBelch("costArrayLinear[] = ");
1933 for (i = 0;i < N_CLOSURE_TYPES; i++)
1934 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
1938 ASSERT(sumOfCostLinear == totalHeapSize);
1941 #define pcostArrayLinear(index) \
1942 if (costArrayLinear[index] > 0) \
1943 debugBelch("costArrayLinear[" #index "] = %u\n", costArrayLinear[index])
1944 pcostArrayLinear(THUNK_STATIC);
1945 pcostArrayLinear(FUN_STATIC);
1946 pcostArrayLinear(CONSTR_STATIC);
1947 pcostArrayLinear(CONSTR_NOCAF_STATIC);
1951 // Now we flips flip.
1954 #ifdef DEBUG_RETAINER
1960 numObjectVisited = 0;
1961 timesAnyObjectVisited = 0;
1963 #ifdef DEBUG_RETAINER
1964 debugBelch("During traversing:\n");
1966 sumOfNewCostExtra = 0;
1967 for (i = 0;i < N_CLOSURE_TYPES; i++)
1972 We initialize the traverse stack each time the retainer profiling is
1973 performed (because the traverse stack size varies on each retainer profiling
1974 and this operation is not costly anyhow). However, we just refresh the
1977 initializeTraverseStack();
1978 #ifdef DEBUG_RETAINER
1979 initializeAllRetainerSet();
1981 refreshAllRetainerSet();
1983 computeRetainerSet();
1985 #ifdef DEBUG_RETAINER
1986 debugBelch("After traversing:\n");
1987 sumOfCostLinear = 0;
1988 for (i = 0;i < N_CLOSURE_TYPES; i++)
1989 costArrayLinear[i] = 0;
1990 totalHeapSize = checkHeapSanityForRetainerProfiling();
1992 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1993 ASSERT(sumOfCostLinear == totalHeapSize);
1995 // now, compare the two results
1998 costArray[] must be exactly the same as costArrayLinear[].
2000 1) Dead weak pointers, whose type is CONSTR. These objects are not
2001 reachable from any roots.
2003 debugBelch("Comparison:\n");
2004 debugBelch("\tcostArrayLinear[] (must be empty) = ");
2005 for (i = 0;i < N_CLOSURE_TYPES; i++)
2006 if (costArray[i] != costArrayLinear[i])
2007 // nothing should be printed except MUT_VAR after major GCs
2008 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
2011 debugBelch("\tsumOfNewCost = %u\n", sumOfNewCost);
2012 debugBelch("\tsumOfNewCostExtra = %u\n", sumOfNewCostExtra);
2013 debugBelch("\tcostArray[] (must be empty) = ");
2014 for (i = 0;i < N_CLOSURE_TYPES; i++)
2015 if (costArray[i] != costArrayLinear[i])
2016 // nothing should be printed except MUT_VAR after major GCs
2017 debugBelch("[%u:%u] ", i, costArray[i]);
2020 // only for major garbage collection
2021 ASSERT(sumOfNewCost + sumOfNewCostExtra == sumOfCostLinear);
2025 closeTraverseStack();
2026 #ifdef DEBUG_RETAINER
2027 closeAllRetainerSet();
2029 // Note that there is no post-processing for the retainer sets.
2031 retainerGeneration++;
2034 retainerGeneration - 1, // retainerGeneration has just been incremented!
2035 #ifdef DEBUG_RETAINER
2036 maxCStackSize, maxStackSize,
2038 (double)timesAnyObjectVisited / numObjectVisited);
2041 /* -----------------------------------------------------------------------------
2043 * -------------------------------------------------------------------------- */
2045 #ifdef DEBUG_RETAINER
2047 #define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
2048 ((HEAP_ALLOCED(r) && ((Bdescr((P_)r)->flags & BF_FREE) == 0)))) && \
2049 ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa))
2052 sanityCheckHeapClosure( StgClosure *c )
2056 ASSERT(LOOKS_LIKE_GHC_INFO(c->header.info));
2057 ASSERT(!closure_STATIC(c));
2058 ASSERT(LOOKS_LIKE_PTR(c));
2060 if ((((StgWord)RSET(c) & 1) ^ flip) != 0) {
2061 if (get_itbl(c)->type == CONSTR &&
2062 !strcmp(GET_PROF_TYPE(get_itbl(c)), "DEAD_WEAK") &&
2063 !strcmp(GET_PROF_DESC(get_itbl(c)), "DEAD_WEAK")) {
2064 debugBelch("\tUnvisited dead weak pointer object found: c = %p\n", c);
2065 costArray[get_itbl(c)->type] += cost(c);
2066 sumOfNewCost += cost(c);
2069 "Unvisited object: flip = %d, c = %p(%d, %s, %s), rs = %p\n",
2070 flip, c, get_itbl(c)->type,
2071 get_itbl(c)->prof.closure_type, GET_PROF_DESC(get_itbl(c)),
2074 // debugBelch("sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c));
2077 return closure_sizeW(c);
2081 heapCheck( bdescr *bd )
2084 static nat costSum, size;
2087 while (bd != NULL) {
2089 while (p < bd->free) {
2090 size = sanityCheckHeapClosure((StgClosure *)p);
2091 sumOfCostLinear += size;
2092 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2094 // no need for slop check; I think slops are not used currently.
2096 ASSERT(p == bd->free);
2097 costSum += bd->free - bd->start;
2105 smallObjectPoolCheck(void)
2109 static nat costSum, size;
2119 while (p < alloc_Hp) {
2120 size = sanityCheckHeapClosure((StgClosure *)p);
2121 sumOfCostLinear += size;
2122 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2125 ASSERT(p == alloc_Hp);
2126 costSum += alloc_Hp - bd->start;
2129 while (bd != NULL) {
2131 while (p < bd->free) {
2132 size = sanityCheckHeapClosure((StgClosure *)p);
2133 sumOfCostLinear += size;
2134 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2137 ASSERT(p == bd->free);
2138 costSum += bd->free - bd->start;
2146 chainCheck(bdescr *bd)
2151 while (bd != NULL) {
2152 // bd->free - bd->start is not an accurate measurement of the
2153 // object size. Actually it is always zero, so we compute its
2155 size = sanityCheckHeapClosure((StgClosure *)bd->start);
2156 sumOfCostLinear += size;
2157 costArrayLinear[get_itbl((StgClosure *)bd->start)->type] += size;
2166 checkHeapSanityForRetainerProfiling( void )
2171 debugBelch("START: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2172 if (RtsFlags.GcFlags.generations == 1) {
2173 costSum += heapCheck(g0s0->to_blocks);
2174 debugBelch("heapCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2175 costSum += chainCheck(g0s0->large_objects);
2176 debugBelch("chainCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2178 for (g = 0; g < RtsFlags.GcFlags.generations; g++)
2179 for (s = 0; s < generations[g].n_steps; s++) {
2181 After all live objects have been scavenged, the garbage
2182 collector may create some objects in
2183 scheduleFinalizers(). These objects are created throught
2184 allocate(), so the small object pool or the large object
2185 pool of the g0s0 may not be empty.
2187 if (g == 0 && s == 0) {
2188 costSum += smallObjectPoolCheck();
2189 debugBelch("smallObjectPoolCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2190 costSum += chainCheck(generations[g].steps[s].large_objects);
2191 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2193 costSum += heapCheck(generations[g].steps[s].blocks);
2194 debugBelch("heapCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2195 costSum += chainCheck(generations[g].steps[s].large_objects);
2196 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2205 findPointer(StgPtr p)
2211 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2212 for (s = 0; s < generations[g].n_steps; s++) {
2213 // if (g == 0 && s == 0) continue;
2214 bd = generations[g].steps[s].blocks;
2215 for (; bd; bd = bd->link) {
2216 for (q = bd->start; q < bd->free; q++) {
2217 if (*q == (StgWord)p) {
2219 while (!LOOKS_LIKE_GHC_INFO(*r)) r--;
2220 debugBelch("Found in gen[%d], step[%d]: q = %p, r = %p\n", g, s, q, r);
2225 bd = generations[g].steps[s].large_objects;
2226 for (; bd; bd = bd->link) {
2227 e = bd->start + cost((StgClosure *)bd->start);
2228 for (q = bd->start; q < e; q++) {
2229 if (*q == (StgWord)p) {
2231 while (*r == 0 || !LOOKS_LIKE_GHC_INFO(*r)) r--;
2232 debugBelch("Found in gen[%d], large_objects: %p\n", g, r);
2242 belongToHeap(StgPtr p)
2247 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2248 for (s = 0; s < generations[g].n_steps; s++) {
2249 // if (g == 0 && s == 0) continue;
2250 bd = generations[g].steps[s].blocks;
2251 for (; bd; bd = bd->link) {
2252 if (bd->start <= p && p < bd->free) {
2253 debugBelch("Belongs to gen[%d], step[%d]", g, s);
2257 bd = generations[g].steps[s].large_objects;
2258 for (; bd; bd = bd->link) {
2259 if (bd->start <= p && p < bd->start + getHeapClosureSize((StgClosure *)bd->start)) {
2260 debugBelch("Found in gen[%d], large_objects: %p\n", g, bd->start);
2267 #endif /* DEBUG_RETAINER */
2269 #endif /* PROFILING */