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 // blocking_queue must be TSO and the head of a linked list of TSOs.
471 // Shoule it be a child? Seems to be yes.
472 *first_child = (StgClosure *)((StgBlockingQueue *)c)->blocking_queue;
475 *first_child = ((StgSelector *)c)->selectee;
478 case IND_OLDGEN_PERM:
480 *first_child = ((StgInd *)c)->indirectee;
484 *first_child = c->payload[0];
487 // For CONSTR_2_0 and MVAR, we use se.info.step to record the position
488 // of the next child. We do not write a separate initialization code.
489 // Also we do not have to initialize info.type;
491 // two children (fixed), no SRT
492 // need to push a stackElement, but nothing to store in se.info
494 *first_child = c->payload[0]; // return the first pointer
495 // se.info.type = posTypeStep;
496 // se.info.next.step = 2; // 2 = second
499 // three children (fixed), no SRT
500 // need to push a stackElement
502 // head must be TSO and the head of a linked list of TSOs.
503 // Shoule it be a child? Seems to be yes.
504 *first_child = (StgClosure *)((StgMVar *)c)->head;
505 // se.info.type = posTypeStep;
506 se.info.next.step = 2; // 2 = second
509 // three children (fixed), no SRT
511 *first_child = ((StgWeak *)c)->key;
512 // se.info.type = posTypeStep;
513 se.info.next.step = 2;
516 // layout.payload.ptrs, no SRT
522 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
524 *first_child = find_ptrs(&se.info);
525 if (*first_child == NULL)
529 // StgMutArrPtr.ptrs, no SRT
531 case MUT_ARR_PTRS_FROZEN:
532 init_ptrs(&se.info, ((StgMutArrPtrs *)c)->ptrs,
533 (StgPtr)(((StgMutArrPtrs *)c)->payload));
534 *first_child = find_ptrs(&se.info);
535 if (*first_child == NULL)
539 // layout.payload.ptrs, SRT
540 case FUN: // *c is a heap object.
542 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
543 *first_child = find_ptrs(&se.info);
544 if (*first_child == NULL)
545 // no child from ptrs, so check SRT
551 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
552 *first_child = find_ptrs(&se.info);
553 if (*first_child == NULL)
554 // no child from ptrs, so check SRT
558 // 1 fixed child, SRT
561 *first_child = c->payload[0];
562 ASSERT(*first_child != NULL);
563 init_srt_fun(&se.info, get_fun_itbl(c));
568 *first_child = c->payload[0];
569 ASSERT(*first_child != NULL);
570 init_srt_thunk(&se.info, get_thunk_itbl(c));
573 case FUN_STATIC: // *c is a heap object.
574 ASSERT(get_itbl(c)->srt_bitmap != 0);
578 init_srt_fun(&se.info, get_fun_itbl(c));
579 *first_child = find_srt(&se.info);
580 if (*first_child == NULL)
586 ASSERT(get_itbl(c)->srt_bitmap != 0);
590 init_srt_thunk(&se.info, get_thunk_itbl(c));
591 *first_child = find_srt(&se.info);
592 if (*first_child == NULL)
603 case CONSTR_CHARLIKE:
604 case CONSTR_NOCAF_STATIC:
625 barf("Invalid object *c in push()");
629 if (stackTop - 1 < stackBottom) {
630 #ifdef DEBUG_RETAINER
631 // debugBelch("push() to the next stack.\n");
633 // currentStack->free is updated when the active stack is switched
634 // to the next stack.
635 currentStack->free = (StgPtr)stackTop;
637 if (currentStack->link == NULL) {
638 nbd = allocGroup(BLOCKS_IN_STACK);
640 nbd->u.back = currentStack;
641 currentStack->link = nbd;
643 nbd = currentStack->link;
648 // adjust stackTop (acutal push)
650 // If the size of stackElement was huge, we would better replace the
651 // following statement by either a memcpy() call or a switch statement
652 // on the type of the element. Currently, the size of stackElement is
653 // small enough (5 words) that this direct assignment seems to be enough.
656 #ifdef DEBUG_RETAINER
658 if (stackSize > maxStackSize) maxStackSize = stackSize;
659 // ASSERT(stackSize >= 0);
660 // debugBelch("stackSize = %d\n", stackSize);
664 /* -----------------------------------------------------------------------------
665 * popOff() and popOffReal(): Pop a stackElement off the traverse stack.
667 * stackTop cannot be equal to stackLimit unless the whole stack is
668 * empty, in which case popOff() is not allowed.
670 * You can think of popOffReal() as a part of popOff() which is
671 * executed at the end of popOff() in necessary. Since popOff() is
672 * likely to be executed quite often while popOffReal() is not, we
673 * separate popOffReal() from popOff(), which is declared as an
674 * INLINE function (for the sake of execution speed). popOffReal()
675 * is called only within popOff() and nowhere else.
676 * -------------------------------------------------------------------------- */
680 bdescr *pbd; // Previous Block Descriptor
682 #ifdef DEBUG_RETAINER
683 // debugBelch("pop() to the previous stack.\n");
686 ASSERT(stackTop + 1 == stackLimit);
687 ASSERT(stackBottom == (stackElement *)currentStack->start);
689 if (firstStack == currentStack) {
690 // The stack is completely empty.
692 ASSERT(stackTop == stackLimit);
693 #ifdef DEBUG_RETAINER
695 if (stackSize > maxStackSize) maxStackSize = stackSize;
697 ASSERT(stackSize >= 0);
698 debugBelch("stackSize = %d\n", stackSize);
704 // currentStack->free is updated when the active stack is switched back
705 // to the previous stack.
706 currentStack->free = (StgPtr)stackLimit;
708 // find the previous block descriptor
709 pbd = currentStack->u.back;
712 returnToOldStack(pbd);
714 #ifdef DEBUG_RETAINER
716 if (stackSize > maxStackSize) maxStackSize = stackSize;
718 ASSERT(stackSize >= 0);
719 debugBelch("stackSize = %d\n", stackSize);
726 #ifdef DEBUG_RETAINER
727 // debugBelch("\tpopOff(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
730 ASSERT(stackTop != stackLimit);
731 ASSERT(!isEmptyRetainerStack());
733 // <= (instead of <) is wrong!
734 if (stackTop + 1 < stackLimit) {
736 #ifdef DEBUG_RETAINER
738 if (stackSize > maxStackSize) maxStackSize = stackSize;
740 ASSERT(stackSize >= 0);
741 debugBelch("stackSize = %d\n", stackSize);
750 /* -----------------------------------------------------------------------------
751 * Finds the next object to be considered for retainer profiling and store
753 * Test if the topmost stack element indicates that more objects are left,
754 * and if so, retrieve the first object and store its pointer to *c. Also,
755 * set *cp and *r appropriately, both of which are stored in the stack element.
756 * The topmost stack element then is overwritten so as for it to now denote
758 * If the topmost stack element indicates no more objects are left, pop
759 * off the stack element until either an object can be retrieved or
760 * the current stack chunk becomes empty, indicated by rtsTrue returned by
761 * isOnBoundary(), in which case *c is set to NULL.
763 * It is okay to call this function even when the current stack chunk
765 * -------------------------------------------------------------------------- */
767 pop( StgClosure **c, StgClosure **cp, retainer *r )
771 #ifdef DEBUG_RETAINER
772 // debugBelch("pop(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
776 if (isOnBoundary()) { // if the current stack chunk is depleted
783 switch (get_itbl(se->c)->type) {
784 // two children (fixed), no SRT
785 // nothing in se.info
787 *c = se->c->payload[1];
793 // three children (fixed), no SRT
794 // need to push a stackElement
796 if (se->info.next.step == 2) {
797 *c = (StgClosure *)((StgMVar *)se->c)->tail;
798 se->info.next.step++; // move to the next step
801 *c = ((StgMVar *)se->c)->value;
808 // three children (fixed), no SRT
810 if (se->info.next.step == 2) {
811 *c = ((StgWeak *)se->c)->value;
812 se->info.next.step++;
815 *c = ((StgWeak *)se->c)->finalizer;
827 // StgMutArrPtr.ptrs, no SRT
829 case MUT_ARR_PTRS_FROZEN:
830 *c = find_ptrs(&se->info);
839 // layout.payload.ptrs, SRT
840 case FUN: // always a heap object
842 if (se->info.type == posTypePtrs) {
843 *c = find_ptrs(&se->info);
849 init_srt_fun(&se->info, get_fun_itbl(se->c));
855 if (se->info.type == posTypePtrs) {
856 *c = find_ptrs(&se->info);
862 init_srt_thunk(&se->info, get_thunk_itbl(se->c));
878 *c = find_srt(&se->info);
887 // no child (fixed), no SRT
893 case SE_CAF_BLACKHOLE:
895 // one child (fixed), no SRT
900 case IND_OLDGEN_PERM:
910 case CONSTR_CHARLIKE:
911 case CONSTR_NOCAF_STATIC:
932 barf("Invalid object *c in pop()");
938 /* -----------------------------------------------------------------------------
939 * RETAINER PROFILING ENGINE
940 * -------------------------------------------------------------------------- */
943 initRetainerProfiling( void )
945 initializeAllRetainerSet();
946 retainerGeneration = 0;
949 /* -----------------------------------------------------------------------------
950 * This function must be called before f-closing prof_file.
951 * -------------------------------------------------------------------------- */
953 endRetainerProfiling( void )
955 #ifdef SECOND_APPROACH
956 outputAllRetainerSet(prof_file);
960 /* -----------------------------------------------------------------------------
961 * Returns the actual pointer to the retainer set of the closure *c.
962 * It may adjust RSET(c) subject to flip.
964 * RSET(c) is initialized to NULL if its current value does not
967 * Even though this function has side effects, they CAN be ignored because
968 * subsequent calls to retainerSetOf() always result in the same return value
969 * and retainerSetOf() is the only way to retrieve retainerSet of a given
971 * We have to perform an XOR (^) operation each time a closure is examined.
972 * The reason is that we do not know when a closure is visited last.
973 * -------------------------------------------------------------------------- */
975 maybeInitRetainerSet( StgClosure *c )
977 if (!isRetainerSetFieldValid(c)) {
978 setRetainerSetToNull(c);
982 /* -----------------------------------------------------------------------------
983 * Returns rtsTrue if *c is a retainer.
984 * -------------------------------------------------------------------------- */
985 static INLINE rtsBool
986 isRetainer( StgClosure *c )
988 switch (get_itbl(c)->type) {
992 // TSOs MUST be retainers: they constitute the set of roots.
999 case MUT_ARR_PTRS_FROZEN:
1001 // thunks are retainers.
1008 case THUNK_SELECTOR:
1012 // Static thunks, or CAFS, are obviously retainers.
1015 // WEAK objects are roots; there is separate code in which traversing
1016 // begins from WEAK objects.
1038 // partial applications
1044 case SE_CAF_BLACKHOLE:
1048 case IND_OLDGEN_PERM:
1063 // IND_STATIC cannot be *c, *cp, *r in the retainer profiling loop.
1065 // CONSTR_INTLIKE, CONSTR_CHARLIKE, and CONSTR_NOCAF_STATIC
1066 // cannot be *c, *cp, *r in the retainer profiling loop.
1067 case CONSTR_INTLIKE:
1068 case CONSTR_CHARLIKE:
1069 case CONSTR_NOCAF_STATIC:
1070 // Stack objects are invalid because they are never treated as
1071 // legal objects during retainer profiling.
1089 case INVALID_OBJECT:
1091 barf("Invalid object in isRetainer(): %d", get_itbl(c)->type);
1096 /* -----------------------------------------------------------------------------
1097 * Returns the retainer function value for the closure *c, i.e., R(*c).
1098 * This function does NOT return the retainer(s) of *c.
1100 * *c must be a retainer.
1102 * Depending on the definition of this function, the maintenance of retainer
1103 * sets can be made easier. If most retainer sets are likely to be created
1104 * again across garbage collections, refreshAllRetainerSet() in
1105 * RetainerSet.c can simply do nothing.
1106 * If this is not the case, we can free all the retainer sets and
1107 * re-initialize the hash table.
1108 * See refreshAllRetainerSet() in RetainerSet.c.
1109 * -------------------------------------------------------------------------- */
1110 static INLINE retainer
1111 getRetainerFrom( StgClosure *c )
1113 ASSERT(isRetainer(c));
1115 #if defined(RETAINER_SCHEME_INFO)
1116 // Retainer scheme 1: retainer = info table
1118 #elif defined(RETAINER_SCHEME_CCS)
1119 // Retainer scheme 2: retainer = cost centre stack
1120 return c->header.prof.ccs;
1121 #elif defined(RETAINER_SCHEME_CC)
1122 // Retainer scheme 3: retainer = cost centre
1123 return c->header.prof.ccs->cc;
1127 /* -----------------------------------------------------------------------------
1128 * Associates the retainer set *s with the closure *c, that is, *s becomes
1129 * the retainer set of *c.
1133 * -------------------------------------------------------------------------- */
1135 associate( StgClosure *c, RetainerSet *s )
1137 // StgWord has the same size as pointers, so the following type
1139 RSET(c) = (RetainerSet *)((StgWord)s | flip);
1142 /* -----------------------------------------------------------------------------
1143 Call retainClosure for each of the closures covered by a large bitmap.
1144 -------------------------------------------------------------------------- */
1147 retain_large_bitmap (StgPtr p, StgLargeBitmap *large_bitmap, nat size,
1148 StgClosure *c, retainer c_child_r)
1154 bitmap = large_bitmap->bitmap[b];
1155 for (i = 0; i < size; ) {
1156 if ((bitmap & 1) == 0) {
1157 retainClosure((StgClosure *)*p, c, c_child_r);
1161 if (i % BITS_IN(W_) == 0) {
1163 bitmap = large_bitmap->bitmap[b];
1165 bitmap = bitmap >> 1;
1170 static INLINE StgPtr
1171 retain_small_bitmap (StgPtr p, nat size, StgWord bitmap,
1172 StgClosure *c, retainer c_child_r)
1175 if ((bitmap & 1) == 0) {
1176 retainClosure((StgClosure *)*p, c, c_child_r);
1179 bitmap = bitmap >> 1;
1185 /* -----------------------------------------------------------------------------
1186 * Call retainClosure for each of the closures in an SRT.
1187 * ------------------------------------------------------------------------- */
1190 retain_large_srt_bitmap (StgLargeSRT *srt, StgClosure *c, retainer c_child_r)
1197 p = (StgClosure **)srt->srt;
1199 bitmap = srt->l.bitmap[b];
1200 for (i = 0; i < size; ) {
1201 if ((bitmap & 1) != 0) {
1202 retainClosure((StgClosure *)*p, c, c_child_r);
1206 if (i % BITS_IN(W_) == 0) {
1208 bitmap = srt->l.bitmap[b];
1210 bitmap = bitmap >> 1;
1216 retainSRT (StgClosure **srt, nat srt_bitmap, StgClosure *c, retainer c_child_r)
1221 bitmap = srt_bitmap;
1224 if (bitmap == (StgHalfWord)(-1)) {
1225 retain_large_srt_bitmap( (StgLargeSRT *)srt, c, c_child_r );
1229 while (bitmap != 0) {
1230 if ((bitmap & 1) != 0) {
1231 #ifdef ENABLE_WIN32_DLL_SUPPORT
1232 if ( (unsigned long)(*srt) & 0x1 ) {
1233 retainClosure(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)),
1236 retainClosure(*srt,c,c_child_r);
1239 retainClosure(*srt,c,c_child_r);
1243 bitmap = bitmap >> 1;
1247 /* -----------------------------------------------------------------------------
1248 * Process all the objects in the stack chunk from stackStart to stackEnd
1249 * with *c and *c_child_r being their parent and their most recent retainer,
1250 * respectively. Treat stackOptionalFun as another child of *c if it is
1253 * *c is one of the following: TSO, AP_STACK.
1254 * If *c is TSO, c == c_child_r.
1255 * stackStart < stackEnd.
1256 * RSET(c) and RSET(c_child_r) are valid, i.e., their
1257 * interpretation conforms to the current value of flip (even when they
1258 * are interpreted to be NULL).
1259 * If *c is TSO, its state is not any of ThreadRelocated, ThreadComplete,
1260 * or ThreadKilled, which means that its stack is ready to process.
1262 * This code was almost plagiarzied from GC.c! For each pointer,
1263 * retainClosure() is invoked instead of evacuate().
1264 * -------------------------------------------------------------------------- */
1266 retainStack( StgClosure *c, retainer c_child_r,
1267 StgPtr stackStart, StgPtr stackEnd )
1269 stackElement *oldStackBoundary;
1271 StgRetInfoTable *info;
1275 #ifdef DEBUG_RETAINER
1277 if (cStackSize > maxCStackSize) maxCStackSize = cStackSize;
1281 Each invocation of retainStack() creates a new virtual
1282 stack. Since all such stacks share a single common stack, we
1283 record the current currentStackBoundary, which will be restored
1286 oldStackBoundary = currentStackBoundary;
1287 currentStackBoundary = stackTop;
1289 #ifdef DEBUG_RETAINER
1290 // debugBelch("retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
1293 ASSERT(get_itbl(c)->type != TSO ||
1294 (((StgTSO *)c)->what_next != ThreadRelocated &&
1295 ((StgTSO *)c)->what_next != ThreadComplete &&
1296 ((StgTSO *)c)->what_next != ThreadKilled));
1299 while (p < stackEnd) {
1300 info = get_ret_itbl((StgClosure *)p);
1302 switch(info->i.type) {
1305 retainClosure(((StgUpdateFrame *)p)->updatee, c, c_child_r);
1306 p += sizeofW(StgUpdateFrame);
1313 bitmap = BITMAP_BITS(info->i.layout.bitmap);
1314 size = BITMAP_SIZE(info->i.layout.bitmap);
1316 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1319 retainSRT((StgClosure **)GET_SRT(info), info->i.srt_bitmap, c, c_child_r);
1326 retainClosure((StgClosure *)*p, c, c_child_r);
1329 size = BCO_BITMAP_SIZE(bco);
1330 retain_large_bitmap(p, BCO_BITMAP(bco), size, c, c_child_r);
1335 // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
1338 size = GET_LARGE_BITMAP(&info->i)->size;
1340 retain_large_bitmap(p, GET_LARGE_BITMAP(&info->i),
1341 size, c, c_child_r);
1343 // and don't forget to follow the SRT
1346 // Dynamic bitmap: the mask is stored on the stack
1349 dyn = ((StgRetDyn *)p)->liveness;
1351 // traverse the bitmap first
1352 bitmap = RET_DYN_LIVENESS(dyn);
1353 p = (P_)&((StgRetDyn *)p)->payload[0];
1354 size = RET_DYN_BITMAP_SIZE;
1355 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1357 // skip over the non-ptr words
1358 p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
1360 // follow the ptr words
1361 for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
1362 retainClosure((StgClosure *)*p, c, c_child_r);
1369 StgRetFun *ret_fun = (StgRetFun *)p;
1370 StgFunInfoTable *fun_info;
1372 retainClosure(ret_fun->fun, c, c_child_r);
1373 fun_info = get_fun_itbl(ret_fun->fun);
1375 p = (P_)&ret_fun->payload;
1376 switch (fun_info->f.fun_type) {
1378 bitmap = BITMAP_BITS(fun_info->f.bitmap);
1379 size = BITMAP_SIZE(fun_info->f.bitmap);
1380 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1383 size = GET_FUN_LARGE_BITMAP(fun_info)->size;
1384 retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
1385 size, c, c_child_r);
1389 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1390 size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
1391 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1398 barf("Invalid object found in retainStack(): %d",
1399 (int)(info->i.type));
1403 // restore currentStackBoundary
1404 currentStackBoundary = oldStackBoundary;
1405 #ifdef DEBUG_RETAINER
1406 // debugBelch("retainStack() finished: currentStackBoundary = 0x%x\n", currentStackBoundary);
1409 #ifdef DEBUG_RETAINER
1414 /* ----------------------------------------------------------------------------
1415 * Call retainClosure for each of the children of a PAP/AP
1416 * ------------------------------------------------------------------------- */
1418 static INLINE StgPtr
1419 retain_PAP (StgPAP *pap, retainer c_child_r)
1422 StgWord bitmap, size;
1423 StgFunInfoTable *fun_info;
1425 retainClosure(pap->fun, (StgClosure *)pap, c_child_r);
1426 fun_info = get_fun_itbl(pap->fun);
1427 ASSERT(fun_info->i.type != PAP);
1429 p = (StgPtr)pap->payload;
1432 switch (fun_info->f.fun_type) {
1434 bitmap = BITMAP_BITS(fun_info->f.bitmap);
1435 p = retain_small_bitmap(p, pap->n_args, bitmap,
1436 (StgClosure *)pap, c_child_r);
1439 retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
1440 size, (StgClosure *)pap, c_child_r);
1444 retain_large_bitmap((StgPtr)pap->payload, BCO_BITMAP(pap->fun),
1445 size, (StgClosure *)pap, c_child_r);
1449 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1450 p = retain_small_bitmap(p, pap->n_args, bitmap,
1451 (StgClosure *)pap, c_child_r);
1457 /* -----------------------------------------------------------------------------
1458 * Compute the retainer set of *c0 and all its desecents by traversing.
1459 * *cp0 is the parent of *c0, and *r0 is the most recent retainer of *c0.
1461 * c0 = cp0 = r0 holds only for root objects.
1462 * RSET(cp0) and RSET(r0) are valid, i.e., their
1463 * interpretation conforms to the current value of flip (even when they
1464 * are interpreted to be NULL).
1465 * However, RSET(c0) may be corrupt, i.e., it may not conform to
1466 * the current value of flip. If it does not, during the execution
1467 * of this function, RSET(c0) must be initialized as well as all
1470 * stackTop must be the same at the beginning and the exit of this function.
1471 * *c0 can be TSO (as well as AP_STACK).
1472 * -------------------------------------------------------------------------- */
1474 retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
1476 // c = Current closure
1477 // cp = Current closure's Parent
1478 // r = current closures' most recent Retainer
1479 // c_child_r = current closure's children's most recent retainer
1480 // first_child = first child of c
1481 StgClosure *c, *cp, *first_child;
1482 RetainerSet *s, *retainerSetOfc;
1483 retainer r, c_child_r;
1486 #ifdef DEBUG_RETAINER
1487 // StgPtr oldStackTop;
1490 #ifdef DEBUG_RETAINER
1491 // oldStackTop = stackTop;
1492 // debugBelch("retainClosure() called: c0 = 0x%x, cp0 = 0x%x, r0 = 0x%x\n", c0, cp0, r0);
1495 // (c, cp, r) = (c0, cp0, r0)
1502 //debugBelch("loop");
1503 // pop to (c, cp, r);
1507 #ifdef DEBUG_RETAINER
1508 // debugBelch("retainClosure() ends: oldStackTop = 0x%x, stackTop = 0x%x\n", oldStackTop, stackTop);
1513 //debugBelch("inner_loop");
1516 // c = current closure under consideration,
1517 // cp = current closure's parent,
1518 // r = current closure's most recent retainer
1520 // Loop invariants (on the meaning of c, cp, r, and their retainer sets):
1521 // RSET(cp) and RSET(r) are valid.
1522 // RSET(c) is valid only if c has been visited before.
1524 // Loop invariants (on the relation between c, cp, and r)
1525 // if cp is not a retainer, r belongs to RSET(cp).
1526 // if cp is a retainer, r == cp.
1528 typeOfc = get_itbl(c)->type;
1530 #ifdef DEBUG_RETAINER
1533 case CONSTR_INTLIKE:
1534 case CONSTR_CHARLIKE:
1535 case CONSTR_NOCAF_STATIC:
1541 if (retainerSetOf(c) == NULL) { // first visit?
1542 costArray[typeOfc] += cost(c);
1543 sumOfNewCost += cost(c);
1552 if (((StgTSO *)c)->what_next == ThreadComplete ||
1553 ((StgTSO *)c)->what_next == ThreadKilled) {
1554 #ifdef DEBUG_RETAINER
1555 debugBelch("ThreadComplete or ThreadKilled encountered in retainClosure()\n");
1559 if (((StgTSO *)c)->what_next == ThreadRelocated) {
1560 #ifdef DEBUG_RETAINER
1561 debugBelch("ThreadRelocated encountered in retainClosure()\n");
1563 c = (StgClosure *)((StgTSO *)c)->link;
1569 // We just skip IND_STATIC, so its retainer set is never computed.
1570 c = ((StgIndStatic *)c)->indirectee;
1572 case CONSTR_INTLIKE:
1573 case CONSTR_CHARLIKE:
1574 // static objects with no pointers out, so goto loop.
1575 case CONSTR_NOCAF_STATIC:
1576 // It is not just enough not to compute the retainer set for *c; it is
1577 // mandatory because CONSTR_NOCAF_STATIC are not reachable from
1578 // scavenged_static_objects, the list from which is assumed to traverse
1579 // all static objects after major garbage collections.
1583 if (get_itbl(c)->srt_bitmap == 0) {
1584 // No need to compute the retainer set; no dynamic objects
1585 // are reachable from *c.
1587 // Static objects: if we traverse all the live closures,
1588 // including static closures, during each heap census then
1589 // we will observe that some static closures appear and
1590 // disappear. eg. a closure may contain a pointer to a
1591 // static function 'f' which is not otherwise reachable
1592 // (it doesn't indirectly point to any CAFs, so it doesn't
1593 // appear in any SRTs), so we would find 'f' during
1594 // traversal. However on the next sweep there may be no
1595 // closures pointing to 'f'.
1597 // We must therefore ignore static closures whose SRT is
1598 // empty, because these are exactly the closures that may
1599 // "appear". A closure with a non-empty SRT, and which is
1600 // still required, will always be reachable.
1602 // But what about CONSTR_STATIC? Surely these may be able
1603 // to appear, and they don't have SRTs, so we can't
1604 // check. So for now, we're calling
1605 // resetStaticObjectForRetainerProfiling() from the
1606 // garbage collector to reset the retainer sets in all the
1607 // reachable static objects.
1614 // The above objects are ignored in computing the average number of times
1615 // an object is visited.
1616 timesAnyObjectVisited++;
1618 // If this is the first visit to c, initialize its retainer set.
1619 maybeInitRetainerSet(c);
1620 retainerSetOfc = retainerSetOf(c);
1623 // isRetainer(cp) == rtsTrue => s == NULL
1624 // isRetainer(cp) == rtsFalse => s == cp.retainer
1628 s = retainerSetOf(cp);
1630 // (c, cp, r, s) is available.
1632 // (c, cp, r, s, R_r) is available, so compute the retainer set for *c.
1633 if (retainerSetOfc == NULL) {
1634 // This is the first visit to *c.
1638 associate(c, singleton(r));
1640 // s is actually the retainer set of *c!
1643 // compute c_child_r
1644 c_child_r = isRetainer(c) ? getRetainerFrom(c) : r;
1646 // This is not the first visit to *c.
1647 if (isMember(r, retainerSetOfc))
1648 goto loop; // no need to process child
1651 associate(c, addElement(r, retainerSetOfc));
1653 // s is not NULL and cp is not a retainer. This means that
1654 // each time *cp is visited, so is *c. Thus, if s has
1655 // exactly one more element in its retainer set than c, s
1656 // is also the new retainer set for *c.
1657 if (s->num == retainerSetOfc->num + 1) {
1660 // Otherwise, just add R_r to the current retainer set of *c.
1662 associate(c, addElement(r, retainerSetOfc));
1667 goto loop; // no need to process child
1669 // compute c_child_r
1673 // now, RSET() of all of *c, *cp, and *r is valid.
1674 // (c, c_child_r) are available.
1678 // Special case closures: we process these all in one go rather
1679 // than attempting to save the current position, because doing so
1683 retainStack(c, c_child_r,
1685 ((StgTSO *)c)->stack + ((StgTSO *)c)->stack_size);
1690 retain_PAP((StgPAP *)c, c_child_r);
1694 retainClosure(((StgAP_STACK *)c)->fun, c, c_child_r);
1695 retainStack(c, c_child_r,
1696 (StgPtr)((StgAP_STACK *)c)->payload,
1697 (StgPtr)((StgAP_STACK *)c)->payload +
1698 ((StgAP_STACK *)c)->size);
1702 push(c, c_child_r, &first_child);
1704 // If first_child is null, c has no child.
1705 // If first_child is not null, the top stack element points to the next
1706 // object. push() may or may not push a stackElement on the stack.
1707 if (first_child == NULL)
1710 // (c, cp, r) = (first_child, c, c_child_r)
1717 /* -----------------------------------------------------------------------------
1718 * Compute the retainer set for every object reachable from *tl.
1719 * -------------------------------------------------------------------------- */
1721 retainRoot( StgClosure **tl )
1723 // We no longer assume that only TSOs and WEAKs are roots; any closure can
1726 ASSERT(isEmptyRetainerStack());
1727 currentStackBoundary = stackTop;
1729 if (isRetainer(*tl)) {
1730 retainClosure(*tl, *tl, getRetainerFrom(*tl));
1732 retainClosure(*tl, *tl, CCS_SYSTEM);
1735 // NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl)));
1736 // *tl might be a TSO which is ThreadComplete, in which
1737 // case we ignore it for the purposes of retainer profiling.
1740 /* -----------------------------------------------------------------------------
1741 * Compute the retainer set for each of the objects in the heap.
1742 * -------------------------------------------------------------------------- */
1744 computeRetainerSet( void )
1751 #ifdef DEBUG_RETAINER
1752 RetainerSet tmpRetainerSet;
1755 GetRoots(retainRoot); // for scheduler roots
1757 // This function is called after a major GC, when key, value, and finalizer
1758 // all are guaranteed to be valid, or reachable.
1760 // The following code assumes that WEAK objects are considered to be roots
1761 // for retainer profilng.
1762 for (weak = weak_ptr_list; weak != NULL; weak = weak->link)
1763 // retainRoot((StgClosure *)weak);
1764 retainRoot((StgClosure **)&weak);
1766 // Consider roots from the stable ptr table.
1767 markStablePtrTable(retainRoot);
1769 // The following code resets the rs field of each unvisited mutable
1770 // object (computing sumOfNewCostExtra and updating costArray[] when
1771 // debugging retainer profiler).
1772 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1773 ASSERT(g != 0 || (generations[g].mut_list == NULL));
1775 // Traversing through mut_list is necessary
1776 // because we can find MUT_VAR objects which have not been
1777 // visited during retainer profiling.
1778 for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
1779 for (ml = bd->start; ml < bd->free; ml++) {
1781 maybeInitRetainerSet((StgClosure *)ml);
1782 rtl = retainerSetOf((StgClosure *)ml);
1784 #ifdef DEBUG_RETAINER
1786 // first visit to *ml
1787 // This is a violation of the interface rule!
1788 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1790 switch (get_itbl((StgClosure *)ml)->type) {
1794 case CONSTR_INTLIKE:
1795 case CONSTR_CHARLIKE:
1796 case CONSTR_NOCAF_STATIC:
1800 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1804 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1805 sumOfNewCostExtra += cost((StgClosure *)ml);
1815 /* -----------------------------------------------------------------------------
1816 * Traverse all static objects for which we compute retainer sets,
1817 * and reset their rs fields to NULL, which is accomplished by
1818 * invoking maybeInitRetainerSet(). This function must be called
1819 * before zeroing all objects reachable from scavenged_static_objects
1820 * in the case of major gabage collections. See GarbageCollect() in
1823 * The mut_once_list of the oldest generation must also be traversed?
1824 * Why? Because if the evacuation of an object pointed to by a static
1825 * indirection object fails, it is put back to the mut_once_list of
1826 * the oldest generation.
1827 * However, this is not necessary because any static indirection objects
1828 * are just traversed through to reach dynamic objects. In other words,
1829 * they are not taken into consideration in computing retainer sets.
1830 * -------------------------------------------------------------------------- */
1832 resetStaticObjectForRetainerProfiling( void )
1834 #ifdef DEBUG_RETAINER
1839 #ifdef DEBUG_RETAINER
1842 p = scavenged_static_objects;
1843 while (p != END_OF_STATIC_LIST) {
1844 #ifdef DEBUG_RETAINER
1847 switch (get_itbl(p)->type) {
1849 // Since we do not compute the retainer set of any
1850 // IND_STATIC object, we don't have to reset its retainer
1852 p = IND_STATIC_LINK(p);
1855 maybeInitRetainerSet(p);
1856 p = THUNK_STATIC_LINK(p);
1859 maybeInitRetainerSet(p);
1860 p = FUN_STATIC_LINK(p);
1863 maybeInitRetainerSet(p);
1864 p = STATIC_LINK(get_itbl(p), p);
1867 barf("resetStaticObjectForRetainerProfiling: %p (%s)",
1868 p, get_itbl(p)->type);
1872 #ifdef DEBUG_RETAINER
1873 // debugBelch("count in scavenged_static_objects = %d\n", count);
1877 /* -----------------------------------------------------------------------------
1878 * Perform retainer profiling.
1879 * N is the oldest generation being profilied, where the generations are
1880 * numbered starting at 0.
1883 * This function should be called only immediately after major garbage
1885 * ------------------------------------------------------------------------- */
1887 retainerProfile(void)
1889 #ifdef DEBUG_RETAINER
1891 nat totalHeapSize; // total raw heap size (computed by linear scanning)
1894 #ifdef DEBUG_RETAINER
1895 debugBelch(" < retainerProfile() invoked : %d>\n", retainerGeneration);
1900 // We haven't flipped the bit yet.
1901 #ifdef DEBUG_RETAINER
1902 debugBelch("Before traversing:\n");
1903 sumOfCostLinear = 0;
1904 for (i = 0;i < N_CLOSURE_TYPES; i++)
1905 costArrayLinear[i] = 0;
1906 totalHeapSize = checkHeapSanityForRetainerProfiling();
1908 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1910 debugBelch("costArrayLinear[] = ");
1911 for (i = 0;i < N_CLOSURE_TYPES; i++)
1912 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
1916 ASSERT(sumOfCostLinear == totalHeapSize);
1919 #define pcostArrayLinear(index) \
1920 if (costArrayLinear[index] > 0) \
1921 debugBelch("costArrayLinear[" #index "] = %u\n", costArrayLinear[index])
1922 pcostArrayLinear(THUNK_STATIC);
1923 pcostArrayLinear(FUN_STATIC);
1924 pcostArrayLinear(CONSTR_STATIC);
1925 pcostArrayLinear(CONSTR_NOCAF_STATIC);
1926 pcostArrayLinear(CONSTR_INTLIKE);
1927 pcostArrayLinear(CONSTR_CHARLIKE);
1931 // Now we flips flip.
1934 #ifdef DEBUG_RETAINER
1940 numObjectVisited = 0;
1941 timesAnyObjectVisited = 0;
1943 #ifdef DEBUG_RETAINER
1944 debugBelch("During traversing:\n");
1946 sumOfNewCostExtra = 0;
1947 for (i = 0;i < N_CLOSURE_TYPES; i++)
1952 We initialize the traverse stack each time the retainer profiling is
1953 performed (because the traverse stack size varies on each retainer profiling
1954 and this operation is not costly anyhow). However, we just refresh the
1957 initializeTraverseStack();
1958 #ifdef DEBUG_RETAINER
1959 initializeAllRetainerSet();
1961 refreshAllRetainerSet();
1963 computeRetainerSet();
1965 #ifdef DEBUG_RETAINER
1966 debugBelch("After traversing:\n");
1967 sumOfCostLinear = 0;
1968 for (i = 0;i < N_CLOSURE_TYPES; i++)
1969 costArrayLinear[i] = 0;
1970 totalHeapSize = checkHeapSanityForRetainerProfiling();
1972 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1973 ASSERT(sumOfCostLinear == totalHeapSize);
1975 // now, compare the two results
1978 costArray[] must be exactly the same as costArrayLinear[].
1980 1) Dead weak pointers, whose type is CONSTR. These objects are not
1981 reachable from any roots.
1983 debugBelch("Comparison:\n");
1984 debugBelch("\tcostArrayLinear[] (must be empty) = ");
1985 for (i = 0;i < N_CLOSURE_TYPES; i++)
1986 if (costArray[i] != costArrayLinear[i])
1987 // nothing should be printed except MUT_VAR after major GCs
1988 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
1991 debugBelch("\tsumOfNewCost = %u\n", sumOfNewCost);
1992 debugBelch("\tsumOfNewCostExtra = %u\n", sumOfNewCostExtra);
1993 debugBelch("\tcostArray[] (must be empty) = ");
1994 for (i = 0;i < N_CLOSURE_TYPES; i++)
1995 if (costArray[i] != costArrayLinear[i])
1996 // nothing should be printed except MUT_VAR after major GCs
1997 debugBelch("[%u:%u] ", i, costArray[i]);
2000 // only for major garbage collection
2001 ASSERT(sumOfNewCost + sumOfNewCostExtra == sumOfCostLinear);
2005 closeTraverseStack();
2006 #ifdef DEBUG_RETAINER
2007 closeAllRetainerSet();
2009 // Note that there is no post-processing for the retainer sets.
2011 retainerGeneration++;
2014 retainerGeneration - 1, // retainerGeneration has just been incremented!
2015 #ifdef DEBUG_RETAINER
2016 maxCStackSize, maxStackSize,
2018 (double)timesAnyObjectVisited / numObjectVisited);
2021 /* -----------------------------------------------------------------------------
2023 * -------------------------------------------------------------------------- */
2025 #ifdef DEBUG_RETAINER
2027 #define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
2028 ((HEAP_ALLOCED(r) && Bdescr((P_)r)->free != (void *)-1))) && \
2029 ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa))
2032 sanityCheckHeapClosure( StgClosure *c )
2036 ASSERT(LOOKS_LIKE_GHC_INFO(c->header.info));
2037 ASSERT(!closure_STATIC(c));
2038 ASSERT(LOOKS_LIKE_PTR(c));
2040 if ((((StgWord)RSET(c) & 1) ^ flip) != 0) {
2041 if (get_itbl(c)->type == CONSTR &&
2042 !strcmp(get_itbl(c)->prof.closure_type, "DEAD_WEAK") &&
2043 !strcmp(get_itbl(c)->prof.closure_desc, "DEAD_WEAK")) {
2044 debugBelch("\tUnvisited dead weak pointer object found: c = %p\n", c);
2045 costArray[get_itbl(c)->type] += cost(c);
2046 sumOfNewCost += cost(c);
2049 "Unvisited object: flip = %d, c = %p(%d, %s, %s), rs = %p\n",
2050 flip, c, get_itbl(c)->type,
2051 get_itbl(c)->prof.closure_type, get_itbl(c)->prof.closure_desc,
2054 // debugBelch("sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c));
2058 switch (info->type) {
2060 return tso_sizeW((StgTSO *)c);
2068 return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE);
2071 return sizeofW(StgMVar);
2074 case MUT_ARR_PTRS_FROZEN:
2075 return mut_arr_ptrs_sizeW((StgMutArrPtrs *)c);
2079 return pap_sizeW((StgPAP *)c);
2082 return ap_stack_sizeW((StgAP_STACK *)c);
2085 return arr_words_sizeW((StgArrWords *)c);
2104 case SE_CAF_BLACKHOLE:
2108 case IND_OLDGEN_PERM:
2112 return sizeW_fromITBL(info);
2114 case THUNK_SELECTOR:
2115 return sizeofW(StgHeader) + MIN_UPD_SIZE;
2124 case CONSTR_INTLIKE:
2125 case CONSTR_CHARLIKE:
2126 case CONSTR_NOCAF_STATIC:
2143 case INVALID_OBJECT:
2145 barf("Invalid object in sanityCheckHeapClosure(): %d",
2152 heapCheck( bdescr *bd )
2155 static nat costSum, size;
2158 while (bd != NULL) {
2160 while (p < bd->free) {
2161 size = sanityCheckHeapClosure((StgClosure *)p);
2162 sumOfCostLinear += size;
2163 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2165 // no need for slop check; I think slops are not used currently.
2167 ASSERT(p == bd->free);
2168 costSum += bd->free - bd->start;
2176 smallObjectPoolCheck(void)
2180 static nat costSum, size;
2182 bd = small_alloc_list;
2190 while (p < alloc_Hp) {
2191 size = sanityCheckHeapClosure((StgClosure *)p);
2192 sumOfCostLinear += size;
2193 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2196 ASSERT(p == alloc_Hp);
2197 costSum += alloc_Hp - bd->start;
2200 while (bd != NULL) {
2202 while (p < bd->free) {
2203 size = sanityCheckHeapClosure((StgClosure *)p);
2204 sumOfCostLinear += size;
2205 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2208 ASSERT(p == bd->free);
2209 costSum += bd->free - bd->start;
2217 chainCheck(bdescr *bd)
2222 while (bd != NULL) {
2223 // bd->free - bd->start is not an accurate measurement of the
2224 // object size. Actually it is always zero, so we compute its
2226 size = sanityCheckHeapClosure((StgClosure *)bd->start);
2227 sumOfCostLinear += size;
2228 costArrayLinear[get_itbl((StgClosure *)bd->start)->type] += size;
2237 checkHeapSanityForRetainerProfiling( void )
2242 debugBelch("START: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2243 if (RtsFlags.GcFlags.generations == 1) {
2244 costSum += heapCheck(g0s0->to_blocks);
2245 debugBelch("heapCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2246 costSum += chainCheck(g0s0->large_objects);
2247 debugBelch("chainCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2249 for (g = 0; g < RtsFlags.GcFlags.generations; g++)
2250 for (s = 0; s < generations[g].n_steps; s++) {
2252 After all live objects have been scavenged, the garbage
2253 collector may create some objects in
2254 scheduleFinalizers(). These objects are created throught
2255 allocate(), so the small object pool or the large object
2256 pool of the g0s0 may not be empty.
2258 if (g == 0 && s == 0) {
2259 costSum += smallObjectPoolCheck();
2260 debugBelch("smallObjectPoolCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2261 costSum += chainCheck(generations[g].steps[s].large_objects);
2262 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2264 costSum += heapCheck(generations[g].steps[s].blocks);
2265 debugBelch("heapCheck(): 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);
2276 findPointer(StgPtr p)
2282 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2283 for (s = 0; s < generations[g].n_steps; s++) {
2284 // if (g == 0 && s == 0) continue;
2285 bd = generations[g].steps[s].blocks;
2286 for (; bd; bd = bd->link) {
2287 for (q = bd->start; q < bd->free; q++) {
2288 if (*q == (StgWord)p) {
2290 while (!LOOKS_LIKE_GHC_INFO(*r)) r--;
2291 debugBelch("Found in gen[%d], step[%d]: q = %p, r = %p\n", g, s, q, r);
2296 bd = generations[g].steps[s].large_objects;
2297 for (; bd; bd = bd->link) {
2298 e = bd->start + cost((StgClosure *)bd->start);
2299 for (q = bd->start; q < e; q++) {
2300 if (*q == (StgWord)p) {
2302 while (*r == 0 || !LOOKS_LIKE_GHC_INFO(*r)) r--;
2303 debugBelch("Found in gen[%d], large_objects: %p\n", g, r);
2313 belongToHeap(StgPtr p)
2318 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2319 for (s = 0; s < generations[g].n_steps; s++) {
2320 // if (g == 0 && s == 0) continue;
2321 bd = generations[g].steps[s].blocks;
2322 for (; bd; bd = bd->link) {
2323 if (bd->start <= p && p < bd->free) {
2324 debugBelch("Belongs to gen[%d], step[%d]", g, s);
2328 bd = generations[g].steps[s].large_objects;
2329 for (; bd; bd = bd->link) {
2330 if (bd->start <= p && p < bd->start + getHeapClosureSize((StgClosure *)bd->start)) {
2331 debugBelch("Found in gen[%d], large_objects: %p\n", g, bd->start);
2338 #endif // DEBUG_RETAINER
2340 #endif /* PROFILING */