1 /* -----------------------------------------------------------------------------
3 * (c) The GHC Team, 2001
8 * ---------------------------------------------------------------------------*/
12 // Turn off inlining when debugging - it obfuscates things
21 #include "RetainerProfile.h"
22 #include "RetainerSet.h"
29 #include "Profiling.h"
31 #include "BlockAlloc.h"
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 #ifdef ENABLE_WIN32_DLL_SUPPORT
371 if ((unsigned long)(*(info->next.srt.srt)) & 0x1)
372 c = (* (StgClosure **)((unsigned long)*(info->next.srt.srt)) & ~0x1);
374 c = *(info->next.srt.srt);
376 c = *(info->next.srt.srt);
378 bitmap = bitmap >> 1;
379 info->next.srt.srt++;
380 info->next.srt.srt_bitmap = bitmap;
383 bitmap = bitmap >> 1;
384 info->next.srt.srt++;
386 // bitmap is now zero...
391 nat i = info->next.large_srt.offset;
394 // Follow the pattern from GC.c:scavenge_large_srt_bitmap().
395 bitmap = info->next.large_srt.srt->l.bitmap[i / BITS_IN(W_)];
396 bitmap = bitmap >> (i % BITS_IN(StgWord));
397 while (i < info->next.large_srt.srt->l.size) {
398 if ((bitmap & 1) != 0) {
399 c = ((StgClosure **)info->next.large_srt.srt->srt)[i];
401 info->next.large_srt.offset = i;
405 if (i % BITS_IN(W_) == 0) {
406 bitmap = info->next.large_srt.srt->l.bitmap[i / BITS_IN(W_)];
408 bitmap = bitmap >> 1;
411 // reached the end of this bitmap.
412 info->next.large_srt.offset = i;
417 /* -----------------------------------------------------------------------------
418 * push() pushes a stackElement representing the next child of *c
419 * onto the traverse stack. If *c has no child, *first_child is set
420 * to NULL and nothing is pushed onto the stack. If *c has only one
421 * child, *c_chlid is set to that child and nothing is pushed onto
422 * the stack. If *c has more than two children, *first_child is set
423 * to the first child and a stackElement representing the second
424 * child is pushed onto the stack.
427 * *c_child_r is the most recent retainer of *c's children.
428 * *c is not any of TSO, AP, PAP, AP_STACK, which means that
429 * there cannot be any stack objects.
430 * Note: SRTs are considered to be children as well.
431 * -------------------------------------------------------------------------- */
433 push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
436 bdescr *nbd; // Next Block Descriptor
438 #ifdef DEBUG_RETAINER
439 // debugBelch("push(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
442 ASSERT(get_itbl(c)->type != TSO);
443 ASSERT(get_itbl(c)->type != AP_STACK);
450 se.c_child_r = c_child_r;
453 switch (get_itbl(c)->type) {
460 case SE_CAF_BLACKHOLE:
465 // one child (fixed), no SRT
467 *first_child = ((StgMutVar *)c)->var;
470 *first_child = ((StgSelector *)c)->selectee;
473 case IND_OLDGEN_PERM:
475 *first_child = ((StgInd *)c)->indirectee;
479 *first_child = c->payload[0];
482 // For CONSTR_2_0 and MVAR, we use se.info.step to record the position
483 // of the next child. We do not write a separate initialization code.
484 // Also we do not have to initialize info.type;
486 // two children (fixed), no SRT
487 // need to push a stackElement, but nothing to store in se.info
489 *first_child = c->payload[0]; // return the first pointer
490 // se.info.type = posTypeStep;
491 // se.info.next.step = 2; // 2 = second
494 // three children (fixed), no SRT
495 // need to push a stackElement
497 // head must be TSO and the head of a linked list of TSOs.
498 // Shoule it be a child? Seems to be yes.
499 *first_child = (StgClosure *)((StgMVar *)c)->head;
500 // se.info.type = posTypeStep;
501 se.info.next.step = 2; // 2 = second
504 // three children (fixed), no SRT
506 *first_child = ((StgWeak *)c)->key;
507 // se.info.type = posTypeStep;
508 se.info.next.step = 2;
511 // 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)
600 case CONSTR_CHARLIKE:
601 case CONSTR_NOCAF_STATIC:
622 barf("Invalid object *c in push()");
626 if (stackTop - 1 < stackBottom) {
627 #ifdef DEBUG_RETAINER
628 // debugBelch("push() to the next stack.\n");
630 // currentStack->free is updated when the active stack is switched
631 // to the next stack.
632 currentStack->free = (StgPtr)stackTop;
634 if (currentStack->link == NULL) {
635 nbd = allocGroup(BLOCKS_IN_STACK);
637 nbd->u.back = currentStack;
638 currentStack->link = nbd;
640 nbd = currentStack->link;
645 // adjust stackTop (acutal push)
647 // If the size of stackElement was huge, we would better replace the
648 // following statement by either a memcpy() call or a switch statement
649 // on the type of the element. Currently, the size of stackElement is
650 // small enough (5 words) that this direct assignment seems to be enough.
653 #ifdef DEBUG_RETAINER
655 if (stackSize > maxStackSize) maxStackSize = stackSize;
656 // ASSERT(stackSize >= 0);
657 // debugBelch("stackSize = %d\n", stackSize);
661 /* -----------------------------------------------------------------------------
662 * popOff() and popOffReal(): Pop a stackElement off the traverse stack.
664 * stackTop cannot be equal to stackLimit unless the whole stack is
665 * empty, in which case popOff() is not allowed.
667 * You can think of popOffReal() as a part of popOff() which is
668 * executed at the end of popOff() in necessary. Since popOff() is
669 * likely to be executed quite often while popOffReal() is not, we
670 * separate popOffReal() from popOff(), which is declared as an
671 * INLINE function (for the sake of execution speed). popOffReal()
672 * is called only within popOff() and nowhere else.
673 * -------------------------------------------------------------------------- */
677 bdescr *pbd; // Previous Block Descriptor
679 #ifdef DEBUG_RETAINER
680 // debugBelch("pop() to the previous stack.\n");
683 ASSERT(stackTop + 1 == stackLimit);
684 ASSERT(stackBottom == (stackElement *)currentStack->start);
686 if (firstStack == currentStack) {
687 // The stack is completely empty.
689 ASSERT(stackTop == stackLimit);
690 #ifdef DEBUG_RETAINER
692 if (stackSize > maxStackSize) maxStackSize = stackSize;
694 ASSERT(stackSize >= 0);
695 debugBelch("stackSize = %d\n", stackSize);
701 // currentStack->free is updated when the active stack is switched back
702 // to the previous stack.
703 currentStack->free = (StgPtr)stackLimit;
705 // find the previous block descriptor
706 pbd = currentStack->u.back;
709 returnToOldStack(pbd);
711 #ifdef DEBUG_RETAINER
713 if (stackSize > maxStackSize) maxStackSize = stackSize;
715 ASSERT(stackSize >= 0);
716 debugBelch("stackSize = %d\n", stackSize);
723 #ifdef DEBUG_RETAINER
724 // debugBelch("\tpopOff(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
727 ASSERT(stackTop != stackLimit);
728 ASSERT(!isEmptyRetainerStack());
730 // <= (instead of <) is wrong!
731 if (stackTop + 1 < stackLimit) {
733 #ifdef DEBUG_RETAINER
735 if (stackSize > maxStackSize) maxStackSize = stackSize;
737 ASSERT(stackSize >= 0);
738 debugBelch("stackSize = %d\n", stackSize);
747 /* -----------------------------------------------------------------------------
748 * Finds the next object to be considered for retainer profiling and store
750 * Test if the topmost stack element indicates that more objects are left,
751 * and if so, retrieve the first object and store its pointer to *c. Also,
752 * set *cp and *r appropriately, both of which are stored in the stack element.
753 * The topmost stack element then is overwritten so as for it to now denote
755 * If the topmost stack element indicates no more objects are left, pop
756 * off the stack element until either an object can be retrieved or
757 * the current stack chunk becomes empty, indicated by rtsTrue returned by
758 * isOnBoundary(), in which case *c is set to NULL.
760 * It is okay to call this function even when the current stack chunk
762 * -------------------------------------------------------------------------- */
764 pop( StgClosure **c, StgClosure **cp, retainer *r )
768 #ifdef DEBUG_RETAINER
769 // debugBelch("pop(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
773 if (isOnBoundary()) { // if the current stack chunk is depleted
780 switch (get_itbl(se->c)->type) {
781 // two children (fixed), no SRT
782 // nothing in se.info
784 *c = se->c->payload[1];
790 // three children (fixed), no SRT
791 // need to push a stackElement
793 if (se->info.next.step == 2) {
794 *c = (StgClosure *)((StgMVar *)se->c)->tail;
795 se->info.next.step++; // move to the next step
798 *c = ((StgMVar *)se->c)->value;
805 // three children (fixed), no SRT
807 if (se->info.next.step == 2) {
808 *c = ((StgWeak *)se->c)->value;
809 se->info.next.step++;
812 *c = ((StgWeak *)se->c)->finalizer;
823 // StgMutArrPtr.ptrs, no SRT
824 case MUT_ARR_PTRS_CLEAN:
825 case MUT_ARR_PTRS_DIRTY:
826 case MUT_ARR_PTRS_FROZEN:
827 case MUT_ARR_PTRS_FROZEN0:
828 *c = find_ptrs(&se->info);
837 // layout.payload.ptrs, SRT
838 case FUN: // always a heap object
840 if (se->info.type == posTypePtrs) {
841 *c = find_ptrs(&se->info);
847 init_srt_fun(&se->info, get_fun_itbl(se->c));
853 if (se->info.type == posTypePtrs) {
854 *c = find_ptrs(&se->info);
860 init_srt_thunk(&se->info, get_thunk_itbl(se->c));
876 *c = find_srt(&se->info);
885 // no child (fixed), no SRT
891 case SE_CAF_BLACKHOLE:
893 // one child (fixed), no SRT
897 case IND_OLDGEN_PERM:
907 case CONSTR_CHARLIKE:
908 case CONSTR_NOCAF_STATIC:
929 barf("Invalid object *c in pop()");
935 /* -----------------------------------------------------------------------------
936 * RETAINER PROFILING ENGINE
937 * -------------------------------------------------------------------------- */
940 initRetainerProfiling( void )
942 initializeAllRetainerSet();
943 retainerGeneration = 0;
946 /* -----------------------------------------------------------------------------
947 * This function must be called before f-closing prof_file.
948 * -------------------------------------------------------------------------- */
950 endRetainerProfiling( void )
952 #ifdef SECOND_APPROACH
953 outputAllRetainerSet(prof_file);
957 /* -----------------------------------------------------------------------------
958 * Returns the actual pointer to the retainer set of the closure *c.
959 * It may adjust RSET(c) subject to flip.
961 * RSET(c) is initialized to NULL if its current value does not
964 * Even though this function has side effects, they CAN be ignored because
965 * subsequent calls to retainerSetOf() always result in the same return value
966 * and retainerSetOf() is the only way to retrieve retainerSet of a given
968 * We have to perform an XOR (^) operation each time a closure is examined.
969 * The reason is that we do not know when a closure is visited last.
970 * -------------------------------------------------------------------------- */
972 maybeInitRetainerSet( StgClosure *c )
974 if (!isRetainerSetFieldValid(c)) {
975 setRetainerSetToNull(c);
979 /* -----------------------------------------------------------------------------
980 * Returns rtsTrue if *c is a retainer.
981 * -------------------------------------------------------------------------- */
982 static INLINE rtsBool
983 isRetainer( StgClosure *c )
985 switch (get_itbl(c)->type) {
989 // TSOs MUST be retainers: they constitute the set of roots.
995 case MUT_ARR_PTRS_CLEAN:
996 case MUT_ARR_PTRS_DIRTY:
997 case MUT_ARR_PTRS_FROZEN:
998 case MUT_ARR_PTRS_FROZEN0:
1000 // thunks are retainers.
1007 case THUNK_SELECTOR:
1011 // Static thunks, or CAFS, are obviously retainers.
1014 // WEAK objects are roots; there is separate code in which traversing
1015 // begins from WEAK objects.
1037 // partial applications
1043 case SE_CAF_BLACKHOLE:
1046 case IND_OLDGEN_PERM:
1060 // IND_STATIC cannot be *c, *cp, *r in the retainer profiling loop.
1062 // CONSTR_INTLIKE, CONSTR_CHARLIKE, and CONSTR_NOCAF_STATIC
1063 // cannot be *c, *cp, *r in the retainer profiling loop.
1064 case CONSTR_INTLIKE:
1065 case CONSTR_CHARLIKE:
1066 case CONSTR_NOCAF_STATIC:
1067 // Stack objects are invalid because they are never treated as
1068 // legal objects during retainer profiling.
1086 case INVALID_OBJECT:
1088 barf("Invalid object in isRetainer(): %d", get_itbl(c)->type);
1093 /* -----------------------------------------------------------------------------
1094 * Returns the retainer function value for the closure *c, i.e., R(*c).
1095 * This function does NOT return the retainer(s) of *c.
1097 * *c must be a retainer.
1099 * Depending on the definition of this function, the maintenance of retainer
1100 * sets can be made easier. If most retainer sets are likely to be created
1101 * again across garbage collections, refreshAllRetainerSet() in
1102 * RetainerSet.c can simply do nothing.
1103 * If this is not the case, we can free all the retainer sets and
1104 * re-initialize the hash table.
1105 * See refreshAllRetainerSet() in RetainerSet.c.
1106 * -------------------------------------------------------------------------- */
1107 static INLINE retainer
1108 getRetainerFrom( StgClosure *c )
1110 ASSERT(isRetainer(c));
1112 #if defined(RETAINER_SCHEME_INFO)
1113 // Retainer scheme 1: retainer = info table
1115 #elif defined(RETAINER_SCHEME_CCS)
1116 // Retainer scheme 2: retainer = cost centre stack
1117 return c->header.prof.ccs;
1118 #elif defined(RETAINER_SCHEME_CC)
1119 // Retainer scheme 3: retainer = cost centre
1120 return c->header.prof.ccs->cc;
1124 /* -----------------------------------------------------------------------------
1125 * Associates the retainer set *s with the closure *c, that is, *s becomes
1126 * the retainer set of *c.
1130 * -------------------------------------------------------------------------- */
1132 associate( StgClosure *c, RetainerSet *s )
1134 // StgWord has the same size as pointers, so the following type
1136 RSET(c) = (RetainerSet *)((StgWord)s | flip);
1139 /* -----------------------------------------------------------------------------
1140 Call retainClosure for each of the closures covered by a large bitmap.
1141 -------------------------------------------------------------------------- */
1144 retain_large_bitmap (StgPtr p, StgLargeBitmap *large_bitmap, nat size,
1145 StgClosure *c, retainer c_child_r)
1151 bitmap = large_bitmap->bitmap[b];
1152 for (i = 0; i < size; ) {
1153 if ((bitmap & 1) == 0) {
1154 retainClosure((StgClosure *)*p, c, c_child_r);
1158 if (i % BITS_IN(W_) == 0) {
1160 bitmap = large_bitmap->bitmap[b];
1162 bitmap = bitmap >> 1;
1167 static INLINE StgPtr
1168 retain_small_bitmap (StgPtr p, nat size, StgWord bitmap,
1169 StgClosure *c, retainer c_child_r)
1172 if ((bitmap & 1) == 0) {
1173 retainClosure((StgClosure *)*p, c, c_child_r);
1176 bitmap = bitmap >> 1;
1182 /* -----------------------------------------------------------------------------
1183 * Call retainClosure for each of the closures in an SRT.
1184 * ------------------------------------------------------------------------- */
1187 retain_large_srt_bitmap (StgLargeSRT *srt, StgClosure *c, retainer c_child_r)
1194 p = (StgClosure **)srt->srt;
1196 bitmap = srt->l.bitmap[b];
1197 for (i = 0; i < size; ) {
1198 if ((bitmap & 1) != 0) {
1199 retainClosure((StgClosure *)*p, c, c_child_r);
1203 if (i % BITS_IN(W_) == 0) {
1205 bitmap = srt->l.bitmap[b];
1207 bitmap = bitmap >> 1;
1213 retainSRT (StgClosure **srt, nat srt_bitmap, StgClosure *c, retainer c_child_r)
1218 bitmap = srt_bitmap;
1221 if (bitmap == (StgHalfWord)(-1)) {
1222 retain_large_srt_bitmap( (StgLargeSRT *)srt, c, c_child_r );
1226 while (bitmap != 0) {
1227 if ((bitmap & 1) != 0) {
1228 #ifdef ENABLE_WIN32_DLL_SUPPORT
1229 if ( (unsigned long)(*srt) & 0x1 ) {
1230 retainClosure(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)),
1233 retainClosure(*srt,c,c_child_r);
1236 retainClosure(*srt,c,c_child_r);
1240 bitmap = bitmap >> 1;
1244 /* -----------------------------------------------------------------------------
1245 * Process all the objects in the stack chunk from stackStart to stackEnd
1246 * with *c and *c_child_r being their parent and their most recent retainer,
1247 * respectively. Treat stackOptionalFun as another child of *c if it is
1250 * *c is one of the following: TSO, AP_STACK.
1251 * If *c is TSO, c == c_child_r.
1252 * stackStart < stackEnd.
1253 * RSET(c) and RSET(c_child_r) are valid, i.e., their
1254 * interpretation conforms to the current value of flip (even when they
1255 * are interpreted to be NULL).
1256 * If *c is TSO, its state is not any of ThreadRelocated, ThreadComplete,
1257 * or ThreadKilled, which means that its stack is ready to process.
1259 * This code was almost plagiarzied from GC.c! For each pointer,
1260 * retainClosure() is invoked instead of evacuate().
1261 * -------------------------------------------------------------------------- */
1263 retainStack( StgClosure *c, retainer c_child_r,
1264 StgPtr stackStart, StgPtr stackEnd )
1266 stackElement *oldStackBoundary;
1268 StgRetInfoTable *info;
1272 #ifdef DEBUG_RETAINER
1274 if (cStackSize > maxCStackSize) maxCStackSize = cStackSize;
1278 Each invocation of retainStack() creates a new virtual
1279 stack. Since all such stacks share a single common stack, we
1280 record the current currentStackBoundary, which will be restored
1283 oldStackBoundary = currentStackBoundary;
1284 currentStackBoundary = stackTop;
1286 #ifdef DEBUG_RETAINER
1287 // debugBelch("retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
1290 ASSERT(get_itbl(c)->type != TSO ||
1291 (((StgTSO *)c)->what_next != ThreadRelocated &&
1292 ((StgTSO *)c)->what_next != ThreadComplete &&
1293 ((StgTSO *)c)->what_next != ThreadKilled));
1296 while (p < stackEnd) {
1297 info = get_ret_itbl((StgClosure *)p);
1299 switch(info->i.type) {
1302 retainClosure(((StgUpdateFrame *)p)->updatee, c, c_child_r);
1303 p += sizeofW(StgUpdateFrame);
1310 bitmap = BITMAP_BITS(info->i.layout.bitmap);
1311 size = BITMAP_SIZE(info->i.layout.bitmap);
1313 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1316 retainSRT((StgClosure **)GET_SRT(info), info->i.srt_bitmap, c, c_child_r);
1323 retainClosure((StgClosure *)*p, c, c_child_r);
1326 size = BCO_BITMAP_SIZE(bco);
1327 retain_large_bitmap(p, BCO_BITMAP(bco), size, c, c_child_r);
1332 // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
1335 size = GET_LARGE_BITMAP(&info->i)->size;
1337 retain_large_bitmap(p, GET_LARGE_BITMAP(&info->i),
1338 size, c, c_child_r);
1340 // and don't forget to follow the SRT
1343 // Dynamic bitmap: the mask is stored on the stack
1346 dyn = ((StgRetDyn *)p)->liveness;
1348 // traverse the bitmap first
1349 bitmap = RET_DYN_LIVENESS(dyn);
1350 p = (P_)&((StgRetDyn *)p)->payload[0];
1351 size = RET_DYN_BITMAP_SIZE;
1352 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1354 // skip over the non-ptr words
1355 p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
1357 // follow the ptr words
1358 for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
1359 retainClosure((StgClosure *)*p, c, c_child_r);
1366 StgRetFun *ret_fun = (StgRetFun *)p;
1367 StgFunInfoTable *fun_info;
1369 retainClosure(ret_fun->fun, c, c_child_r);
1370 fun_info = get_fun_itbl(ret_fun->fun);
1372 p = (P_)&ret_fun->payload;
1373 switch (fun_info->f.fun_type) {
1375 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
1376 size = BITMAP_SIZE(fun_info->f.b.bitmap);
1377 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1380 size = GET_FUN_LARGE_BITMAP(fun_info)->size;
1381 retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
1382 size, c, c_child_r);
1386 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1387 size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
1388 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1395 barf("Invalid object found in retainStack(): %d",
1396 (int)(info->i.type));
1400 // restore currentStackBoundary
1401 currentStackBoundary = oldStackBoundary;
1402 #ifdef DEBUG_RETAINER
1403 // debugBelch("retainStack() finished: currentStackBoundary = 0x%x\n", currentStackBoundary);
1406 #ifdef DEBUG_RETAINER
1411 /* ----------------------------------------------------------------------------
1412 * Call retainClosure for each of the children of a PAP/AP
1413 * ------------------------------------------------------------------------- */
1415 static INLINE StgPtr
1416 retain_PAP_payload (StgClosure *pap, retainer c_child_r, StgClosure *fun,
1417 StgClosure** payload, StgWord n_args)
1421 StgFunInfoTable *fun_info;
1423 retainClosure(fun, pap, c_child_r);
1424 fun_info = get_fun_itbl(fun);
1425 ASSERT(fun_info->i.type != PAP);
1427 p = (StgPtr)payload;
1429 switch (fun_info->f.fun_type) {
1431 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
1432 p = retain_small_bitmap(p, n_args, bitmap,
1436 retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
1437 n_args, pap, c_child_r);
1441 retain_large_bitmap((StgPtr)payload, BCO_BITMAP(fun),
1442 n_args, pap, c_child_r);
1446 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1447 p = retain_small_bitmap(p, n_args, bitmap, pap, c_child_r);
1453 /* -----------------------------------------------------------------------------
1454 * Compute the retainer set of *c0 and all its desecents by traversing.
1455 * *cp0 is the parent of *c0, and *r0 is the most recent retainer of *c0.
1457 * c0 = cp0 = r0 holds only for root objects.
1458 * RSET(cp0) and RSET(r0) are valid, i.e., their
1459 * interpretation conforms to the current value of flip (even when they
1460 * are interpreted to be NULL).
1461 * However, RSET(c0) may be corrupt, i.e., it may not conform to
1462 * the current value of flip. If it does not, during the execution
1463 * of this function, RSET(c0) must be initialized as well as all
1466 * stackTop must be the same at the beginning and the exit of this function.
1467 * *c0 can be TSO (as well as AP_STACK).
1468 * -------------------------------------------------------------------------- */
1470 retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
1472 // c = Current closure
1473 // cp = Current closure's Parent
1474 // r = current closures' most recent Retainer
1475 // c_child_r = current closure's children's most recent retainer
1476 // first_child = first child of c
1477 StgClosure *c, *cp, *first_child;
1478 RetainerSet *s, *retainerSetOfc;
1479 retainer r, c_child_r;
1482 #ifdef DEBUG_RETAINER
1483 // StgPtr oldStackTop;
1486 #ifdef DEBUG_RETAINER
1487 // oldStackTop = stackTop;
1488 // debugBelch("retainClosure() called: c0 = 0x%x, cp0 = 0x%x, r0 = 0x%x\n", c0, cp0, r0);
1491 // (c, cp, r) = (c0, cp0, r0)
1498 //debugBelch("loop");
1499 // pop to (c, cp, r);
1503 #ifdef DEBUG_RETAINER
1504 // debugBelch("retainClosure() ends: oldStackTop = 0x%x, stackTop = 0x%x\n", oldStackTop, stackTop);
1509 //debugBelch("inner_loop");
1512 // c = current closure under consideration,
1513 // cp = current closure's parent,
1514 // r = current closure's most recent retainer
1516 // Loop invariants (on the meaning of c, cp, r, and their retainer sets):
1517 // RSET(cp) and RSET(r) are valid.
1518 // RSET(c) is valid only if c has been visited before.
1520 // Loop invariants (on the relation between c, cp, and r)
1521 // if cp is not a retainer, r belongs to RSET(cp).
1522 // if cp is a retainer, r == cp.
1524 typeOfc = get_itbl(c)->type;
1526 #ifdef DEBUG_RETAINER
1529 case CONSTR_INTLIKE:
1530 case CONSTR_CHARLIKE:
1531 case CONSTR_NOCAF_STATIC:
1537 if (retainerSetOf(c) == NULL) { // first visit?
1538 costArray[typeOfc] += cost(c);
1539 sumOfNewCost += cost(c);
1548 if (((StgTSO *)c)->what_next == ThreadComplete ||
1549 ((StgTSO *)c)->what_next == ThreadKilled) {
1550 #ifdef DEBUG_RETAINER
1551 debugBelch("ThreadComplete or ThreadKilled encountered in retainClosure()\n");
1555 if (((StgTSO *)c)->what_next == ThreadRelocated) {
1556 #ifdef DEBUG_RETAINER
1557 debugBelch("ThreadRelocated encountered in retainClosure()\n");
1559 c = (StgClosure *)((StgTSO *)c)->link;
1565 // We just skip IND_STATIC, so its retainer set is never computed.
1566 c = ((StgIndStatic *)c)->indirectee;
1568 case CONSTR_INTLIKE:
1569 case CONSTR_CHARLIKE:
1570 // static objects with no pointers out, so goto loop.
1571 case CONSTR_NOCAF_STATIC:
1572 // It is not just enough not to compute the retainer set for *c; it is
1573 // mandatory because CONSTR_NOCAF_STATIC are not reachable from
1574 // scavenged_static_objects, the list from which is assumed to traverse
1575 // all static objects after major garbage collections.
1579 if (get_itbl(c)->srt_bitmap == 0) {
1580 // No need to compute the retainer set; no dynamic objects
1581 // are reachable from *c.
1583 // Static objects: if we traverse all the live closures,
1584 // including static closures, during each heap census then
1585 // we will observe that some static closures appear and
1586 // disappear. eg. a closure may contain a pointer to a
1587 // static function 'f' which is not otherwise reachable
1588 // (it doesn't indirectly point to any CAFs, so it doesn't
1589 // appear in any SRTs), so we would find 'f' during
1590 // traversal. However on the next sweep there may be no
1591 // closures pointing to 'f'.
1593 // We must therefore ignore static closures whose SRT is
1594 // empty, because these are exactly the closures that may
1595 // "appear". A closure with a non-empty SRT, and which is
1596 // still required, will always be reachable.
1598 // But what about CONSTR_STATIC? Surely these may be able
1599 // to appear, and they don't have SRTs, so we can't
1600 // check. So for now, we're calling
1601 // resetStaticObjectForRetainerProfiling() from the
1602 // garbage collector to reset the retainer sets in all the
1603 // reachable static objects.
1610 // The above objects are ignored in computing the average number of times
1611 // an object is visited.
1612 timesAnyObjectVisited++;
1614 // If this is the first visit to c, initialize its retainer set.
1615 maybeInitRetainerSet(c);
1616 retainerSetOfc = retainerSetOf(c);
1619 // isRetainer(cp) == rtsTrue => s == NULL
1620 // isRetainer(cp) == rtsFalse => s == cp.retainer
1624 s = retainerSetOf(cp);
1626 // (c, cp, r, s) is available.
1628 // (c, cp, r, s, R_r) is available, so compute the retainer set for *c.
1629 if (retainerSetOfc == NULL) {
1630 // This is the first visit to *c.
1634 associate(c, singleton(r));
1636 // s is actually the retainer set of *c!
1639 // compute c_child_r
1640 c_child_r = isRetainer(c) ? getRetainerFrom(c) : r;
1642 // This is not the first visit to *c.
1643 if (isMember(r, retainerSetOfc))
1644 goto loop; // no need to process child
1647 associate(c, addElement(r, retainerSetOfc));
1649 // s is not NULL and cp is not a retainer. This means that
1650 // each time *cp is visited, so is *c. Thus, if s has
1651 // exactly one more element in its retainer set than c, s
1652 // is also the new retainer set for *c.
1653 if (s->num == retainerSetOfc->num + 1) {
1656 // Otherwise, just add R_r to the current retainer set of *c.
1658 associate(c, addElement(r, retainerSetOfc));
1663 goto loop; // no need to process child
1665 // compute c_child_r
1669 // now, RSET() of all of *c, *cp, and *r is valid.
1670 // (c, c_child_r) are available.
1674 // Special case closures: we process these all in one go rather
1675 // than attempting to save the current position, because doing so
1679 retainStack(c, c_child_r,
1681 ((StgTSO *)c)->stack + ((StgTSO *)c)->stack_size);
1686 StgPAP *pap = (StgPAP *)c;
1687 retain_PAP_payload(c, c_child_r, pap->fun, pap->payload, pap->n_args);
1693 StgAP *ap = (StgAP *)c;
1694 retain_PAP_payload(c, c_child_r, ap->fun, ap->payload, ap->n_args);
1699 retainClosure(((StgAP_STACK *)c)->fun, c, c_child_r);
1700 retainStack(c, c_child_r,
1701 (StgPtr)((StgAP_STACK *)c)->payload,
1702 (StgPtr)((StgAP_STACK *)c)->payload +
1703 ((StgAP_STACK *)c)->size);
1707 push(c, c_child_r, &first_child);
1709 // If first_child is null, c has no child.
1710 // If first_child is not null, the top stack element points to the next
1711 // object. push() may or may not push a stackElement on the stack.
1712 if (first_child == NULL)
1715 // (c, cp, r) = (first_child, c, c_child_r)
1722 /* -----------------------------------------------------------------------------
1723 * Compute the retainer set for every object reachable from *tl.
1724 * -------------------------------------------------------------------------- */
1726 retainRoot( StgClosure **tl )
1728 // We no longer assume that only TSOs and WEAKs are roots; any closure can
1731 ASSERT(isEmptyRetainerStack());
1732 currentStackBoundary = stackTop;
1734 if (isRetainer(*tl)) {
1735 retainClosure(*tl, *tl, getRetainerFrom(*tl));
1737 retainClosure(*tl, *tl, CCS_SYSTEM);
1740 // NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl)));
1741 // *tl might be a TSO which is ThreadComplete, in which
1742 // case we ignore it for the purposes of retainer profiling.
1745 /* -----------------------------------------------------------------------------
1746 * Compute the retainer set for each of the objects in the heap.
1747 * -------------------------------------------------------------------------- */
1749 computeRetainerSet( void )
1756 #ifdef DEBUG_RETAINER
1757 RetainerSet tmpRetainerSet;
1760 GetRoots(retainRoot); // for scheduler roots
1762 // This function is called after a major GC, when key, value, and finalizer
1763 // all are guaranteed to be valid, or reachable.
1765 // The following code assumes that WEAK objects are considered to be roots
1766 // for retainer profilng.
1767 for (weak = weak_ptr_list; weak != NULL; weak = weak->link)
1768 // retainRoot((StgClosure *)weak);
1769 retainRoot((StgClosure **)&weak);
1771 // Consider roots from the stable ptr table.
1772 markStablePtrTable(retainRoot);
1774 // The following code resets the rs field of each unvisited mutable
1775 // object (computing sumOfNewCostExtra and updating costArray[] when
1776 // debugging retainer profiler).
1777 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1778 ASSERT(g != 0 || (generations[g].mut_list == NULL));
1780 // Traversing through mut_list is necessary
1781 // because we can find MUT_VAR objects which have not been
1782 // visited during retainer profiling.
1783 for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
1784 for (ml = bd->start; ml < bd->free; ml++) {
1786 maybeInitRetainerSet((StgClosure *)*ml);
1787 rtl = retainerSetOf((StgClosure *)*ml);
1789 #ifdef DEBUG_RETAINER
1791 // first visit to *ml
1792 // This is a violation of the interface rule!
1793 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1795 switch (get_itbl((StgClosure *)ml)->type) {
1799 case CONSTR_INTLIKE:
1800 case CONSTR_CHARLIKE:
1801 case CONSTR_NOCAF_STATIC:
1805 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1809 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1810 sumOfNewCostExtra += cost((StgClosure *)ml);
1820 /* -----------------------------------------------------------------------------
1821 * Traverse all static objects for which we compute retainer sets,
1822 * and reset their rs fields to NULL, which is accomplished by
1823 * invoking maybeInitRetainerSet(). This function must be called
1824 * before zeroing all objects reachable from scavenged_static_objects
1825 * in the case of major gabage collections. See GarbageCollect() in
1828 * The mut_once_list of the oldest generation must also be traversed?
1829 * Why? Because if the evacuation of an object pointed to by a static
1830 * indirection object fails, it is put back to the mut_once_list of
1831 * the oldest generation.
1832 * However, this is not necessary because any static indirection objects
1833 * are just traversed through to reach dynamic objects. In other words,
1834 * they are not taken into consideration in computing retainer sets.
1835 * -------------------------------------------------------------------------- */
1837 resetStaticObjectForRetainerProfiling( void )
1839 #ifdef DEBUG_RETAINER
1844 #ifdef DEBUG_RETAINER
1847 p = scavenged_static_objects;
1848 while (p != END_OF_STATIC_LIST) {
1849 #ifdef DEBUG_RETAINER
1852 switch (get_itbl(p)->type) {
1854 // Since we do not compute the retainer set of any
1855 // IND_STATIC object, we don't have to reset its retainer
1857 p = (StgClosure*)*IND_STATIC_LINK(p);
1860 maybeInitRetainerSet(p);
1861 p = (StgClosure*)*THUNK_STATIC_LINK(p);
1864 maybeInitRetainerSet(p);
1865 p = (StgClosure*)*FUN_STATIC_LINK(p);
1868 maybeInitRetainerSet(p);
1869 p = (StgClosure*)*STATIC_LINK(get_itbl(p), p);
1872 barf("resetStaticObjectForRetainerProfiling: %p (%s)",
1873 p, get_itbl(p)->type);
1877 #ifdef DEBUG_RETAINER
1878 // debugBelch("count in scavenged_static_objects = %d\n", count);
1882 /* -----------------------------------------------------------------------------
1883 * Perform retainer profiling.
1884 * N is the oldest generation being profilied, where the generations are
1885 * numbered starting at 0.
1888 * This function should be called only immediately after major garbage
1890 * ------------------------------------------------------------------------- */
1892 retainerProfile(void)
1894 #ifdef DEBUG_RETAINER
1896 nat totalHeapSize; // total raw heap size (computed by linear scanning)
1899 #ifdef DEBUG_RETAINER
1900 debugBelch(" < retainerProfile() invoked : %d>\n", retainerGeneration);
1905 // We haven't flipped the bit yet.
1906 #ifdef DEBUG_RETAINER
1907 debugBelch("Before traversing:\n");
1908 sumOfCostLinear = 0;
1909 for (i = 0;i < N_CLOSURE_TYPES; i++)
1910 costArrayLinear[i] = 0;
1911 totalHeapSize = checkHeapSanityForRetainerProfiling();
1913 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1915 debugBelch("costArrayLinear[] = ");
1916 for (i = 0;i < N_CLOSURE_TYPES; i++)
1917 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
1921 ASSERT(sumOfCostLinear == totalHeapSize);
1924 #define pcostArrayLinear(index) \
1925 if (costArrayLinear[index] > 0) \
1926 debugBelch("costArrayLinear[" #index "] = %u\n", costArrayLinear[index])
1927 pcostArrayLinear(THUNK_STATIC);
1928 pcostArrayLinear(FUN_STATIC);
1929 pcostArrayLinear(CONSTR_STATIC);
1930 pcostArrayLinear(CONSTR_NOCAF_STATIC);
1931 pcostArrayLinear(CONSTR_INTLIKE);
1932 pcostArrayLinear(CONSTR_CHARLIKE);
1936 // Now we flips flip.
1939 #ifdef DEBUG_RETAINER
1945 numObjectVisited = 0;
1946 timesAnyObjectVisited = 0;
1948 #ifdef DEBUG_RETAINER
1949 debugBelch("During traversing:\n");
1951 sumOfNewCostExtra = 0;
1952 for (i = 0;i < N_CLOSURE_TYPES; i++)
1957 We initialize the traverse stack each time the retainer profiling is
1958 performed (because the traverse stack size varies on each retainer profiling
1959 and this operation is not costly anyhow). However, we just refresh the
1962 initializeTraverseStack();
1963 #ifdef DEBUG_RETAINER
1964 initializeAllRetainerSet();
1966 refreshAllRetainerSet();
1968 computeRetainerSet();
1970 #ifdef DEBUG_RETAINER
1971 debugBelch("After traversing:\n");
1972 sumOfCostLinear = 0;
1973 for (i = 0;i < N_CLOSURE_TYPES; i++)
1974 costArrayLinear[i] = 0;
1975 totalHeapSize = checkHeapSanityForRetainerProfiling();
1977 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1978 ASSERT(sumOfCostLinear == totalHeapSize);
1980 // now, compare the two results
1983 costArray[] must be exactly the same as costArrayLinear[].
1985 1) Dead weak pointers, whose type is CONSTR. These objects are not
1986 reachable from any roots.
1988 debugBelch("Comparison:\n");
1989 debugBelch("\tcostArrayLinear[] (must be empty) = ");
1990 for (i = 0;i < N_CLOSURE_TYPES; i++)
1991 if (costArray[i] != costArrayLinear[i])
1992 // nothing should be printed except MUT_VAR after major GCs
1993 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
1996 debugBelch("\tsumOfNewCost = %u\n", sumOfNewCost);
1997 debugBelch("\tsumOfNewCostExtra = %u\n", sumOfNewCostExtra);
1998 debugBelch("\tcostArray[] (must be empty) = ");
1999 for (i = 0;i < N_CLOSURE_TYPES; i++)
2000 if (costArray[i] != costArrayLinear[i])
2001 // nothing should be printed except MUT_VAR after major GCs
2002 debugBelch("[%u:%u] ", i, costArray[i]);
2005 // only for major garbage collection
2006 ASSERT(sumOfNewCost + sumOfNewCostExtra == sumOfCostLinear);
2010 closeTraverseStack();
2011 #ifdef DEBUG_RETAINER
2012 closeAllRetainerSet();
2014 // Note that there is no post-processing for the retainer sets.
2016 retainerGeneration++;
2019 retainerGeneration - 1, // retainerGeneration has just been incremented!
2020 #ifdef DEBUG_RETAINER
2021 maxCStackSize, maxStackSize,
2023 (double)timesAnyObjectVisited / numObjectVisited);
2026 /* -----------------------------------------------------------------------------
2028 * -------------------------------------------------------------------------- */
2030 #ifdef DEBUG_RETAINER
2032 #define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
2033 ((HEAP_ALLOCED(r) && ((Bdescr((P_)r)->flags & BF_FREE) == 0)))) && \
2034 ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa))
2037 sanityCheckHeapClosure( StgClosure *c )
2041 ASSERT(LOOKS_LIKE_GHC_INFO(c->header.info));
2042 ASSERT(!closure_STATIC(c));
2043 ASSERT(LOOKS_LIKE_PTR(c));
2045 if ((((StgWord)RSET(c) & 1) ^ flip) != 0) {
2046 if (get_itbl(c)->type == CONSTR &&
2047 !strcmp(get_itbl(c)->prof.closure_type, "DEAD_WEAK") &&
2048 !strcmp(get_itbl(c)->prof.closure_desc, "DEAD_WEAK")) {
2049 debugBelch("\tUnvisited dead weak pointer object found: c = %p\n", c);
2050 costArray[get_itbl(c)->type] += cost(c);
2051 sumOfNewCost += cost(c);
2054 "Unvisited object: flip = %d, c = %p(%d, %s, %s), rs = %p\n",
2055 flip, c, get_itbl(c)->type,
2056 get_itbl(c)->prof.closure_type, get_itbl(c)->prof.closure_desc,
2059 // debugBelch("sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c));
2063 switch (info->type) {
2065 return tso_sizeW((StgTSO *)c);
2073 return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE);
2076 return sizeofW(StgMVar);
2078 case MUT_ARR_PTRS_CLEAN:
2079 case MUT_ARR_PTRS_DIRTY:
2080 case MUT_ARR_PTRS_FROZEN:
2081 case MUT_ARR_PTRS_FROZEN0:
2082 return mut_arr_ptrs_sizeW((StgMutArrPtrs *)c);
2086 return pap_sizeW((StgPAP *)c);
2089 return ap_stack_sizeW((StgAP_STACK *)c);
2092 return arr_words_sizeW((StgArrWords *)c);
2111 case SE_CAF_BLACKHOLE:
2114 case IND_OLDGEN_PERM:
2117 return sizeW_fromITBL(info);
2119 case THUNK_SELECTOR:
2120 return sizeofW(StgHeader) + MIN_UPD_SIZE;
2129 case CONSTR_INTLIKE:
2130 case CONSTR_CHARLIKE:
2131 case CONSTR_NOCAF_STATIC:
2148 case INVALID_OBJECT:
2150 barf("Invalid object in sanityCheckHeapClosure(): %d",
2157 heapCheck( bdescr *bd )
2160 static nat costSum, size;
2163 while (bd != NULL) {
2165 while (p < bd->free) {
2166 size = sanityCheckHeapClosure((StgClosure *)p);
2167 sumOfCostLinear += size;
2168 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2170 // no need for slop check; I think slops are not used currently.
2172 ASSERT(p == bd->free);
2173 costSum += bd->free - bd->start;
2181 smallObjectPoolCheck(void)
2185 static nat costSum, size;
2187 bd = small_alloc_list;
2195 while (p < alloc_Hp) {
2196 size = sanityCheckHeapClosure((StgClosure *)p);
2197 sumOfCostLinear += size;
2198 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2201 ASSERT(p == alloc_Hp);
2202 costSum += alloc_Hp - bd->start;
2205 while (bd != NULL) {
2207 while (p < bd->free) {
2208 size = sanityCheckHeapClosure((StgClosure *)p);
2209 sumOfCostLinear += size;
2210 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2213 ASSERT(p == bd->free);
2214 costSum += bd->free - bd->start;
2222 chainCheck(bdescr *bd)
2227 while (bd != NULL) {
2228 // bd->free - bd->start is not an accurate measurement of the
2229 // object size. Actually it is always zero, so we compute its
2231 size = sanityCheckHeapClosure((StgClosure *)bd->start);
2232 sumOfCostLinear += size;
2233 costArrayLinear[get_itbl((StgClosure *)bd->start)->type] += size;
2242 checkHeapSanityForRetainerProfiling( void )
2247 debugBelch("START: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2248 if (RtsFlags.GcFlags.generations == 1) {
2249 costSum += heapCheck(g0s0->to_blocks);
2250 debugBelch("heapCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2251 costSum += chainCheck(g0s0->large_objects);
2252 debugBelch("chainCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2254 for (g = 0; g < RtsFlags.GcFlags.generations; g++)
2255 for (s = 0; s < generations[g].n_steps; s++) {
2257 After all live objects have been scavenged, the garbage
2258 collector may create some objects in
2259 scheduleFinalizers(). These objects are created throught
2260 allocate(), so the small object pool or the large object
2261 pool of the g0s0 may not be empty.
2263 if (g == 0 && s == 0) {
2264 costSum += smallObjectPoolCheck();
2265 debugBelch("smallObjectPoolCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2266 costSum += chainCheck(generations[g].steps[s].large_objects);
2267 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2269 costSum += heapCheck(generations[g].steps[s].blocks);
2270 debugBelch("heapCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2271 costSum += chainCheck(generations[g].steps[s].large_objects);
2272 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2281 findPointer(StgPtr p)
2287 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2288 for (s = 0; s < generations[g].n_steps; s++) {
2289 // if (g == 0 && s == 0) continue;
2290 bd = generations[g].steps[s].blocks;
2291 for (; bd; bd = bd->link) {
2292 for (q = bd->start; q < bd->free; q++) {
2293 if (*q == (StgWord)p) {
2295 while (!LOOKS_LIKE_GHC_INFO(*r)) r--;
2296 debugBelch("Found in gen[%d], step[%d]: q = %p, r = %p\n", g, s, q, r);
2301 bd = generations[g].steps[s].large_objects;
2302 for (; bd; bd = bd->link) {
2303 e = bd->start + cost((StgClosure *)bd->start);
2304 for (q = bd->start; q < e; q++) {
2305 if (*q == (StgWord)p) {
2307 while (*r == 0 || !LOOKS_LIKE_GHC_INFO(*r)) r--;
2308 debugBelch("Found in gen[%d], large_objects: %p\n", g, r);
2318 belongToHeap(StgPtr p)
2323 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2324 for (s = 0; s < generations[g].n_steps; s++) {
2325 // if (g == 0 && s == 0) continue;
2326 bd = generations[g].steps[s].blocks;
2327 for (; bd; bd = bd->link) {
2328 if (bd->start <= p && p < bd->free) {
2329 debugBelch("Belongs to gen[%d], step[%d]", g, s);
2333 bd = generations[g].steps[s].large_objects;
2334 for (; bd; bd = bd->link) {
2335 if (bd->start <= p && p < bd->start + getHeapClosureSize((StgClosure *)bd->start)) {
2336 debugBelch("Found in gen[%d], large_objects: %p\n", g, bd->start);
2343 #endif /* DEBUG_RETAINER */
2345 #endif /* PROFILING */