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
468 *first_child = ((StgMutVar *)c)->var;
471 // blocking_queue must be TSO and the head of a linked list of TSOs.
472 // Shoule it be a child? Seems to be yes.
473 *first_child = (StgClosure *)((StgBlockingQueue *)c)->blocking_queue;
476 *first_child = ((StgSelector *)c)->selectee;
479 case IND_OLDGEN_PERM:
481 *first_child = ((StgIndOldGen *)c)->indirectee;
485 *first_child = c->payload[0];
488 // For CONSTR_2_0 and MVAR, we use se.info.step to record the position
489 // of the next child. We do not write a separate initialization code.
490 // Also we do not have to initialize info.type;
492 // two children (fixed), no SRT
493 // need to push a stackElement, but nothing to store in se.info
495 *first_child = c->payload[0]; // return the first pointer
496 // se.info.type = posTypeStep;
497 // se.info.next.step = 2; // 2 = second
500 // three children (fixed), no SRT
501 // need to push a stackElement
503 // head must be TSO and the head of a linked list of TSOs.
504 // Shoule it be a child? Seems to be yes.
505 *first_child = (StgClosure *)((StgMVar *)c)->head;
506 // se.info.type = posTypeStep;
507 se.info.next.step = 2; // 2 = second
510 // three children (fixed), no SRT
512 *first_child = ((StgWeak *)c)->key;
513 // se.info.type = posTypeStep;
514 se.info.next.step = 2;
517 // layout.payload.ptrs, no SRT
523 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
525 *first_child = find_ptrs(&se.info);
526 if (*first_child == NULL)
530 // StgMutArrPtr.ptrs, no SRT
532 case MUT_ARR_PTRS_FROZEN:
533 init_ptrs(&se.info, ((StgMutArrPtrs *)c)->ptrs,
534 (StgPtr)(((StgMutArrPtrs *)c)->payload));
535 *first_child = find_ptrs(&se.info);
536 if (*first_child == NULL)
540 // layout.payload.ptrs, SRT
541 case FUN: // *c is a heap object.
543 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
544 *first_child = find_ptrs(&se.info);
545 if (*first_child == NULL)
546 // no child from ptrs, so check SRT
552 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
553 *first_child = find_ptrs(&se.info);
554 if (*first_child == NULL)
555 // no child from ptrs, so check SRT
559 // 1 fixed child, SRT
562 *first_child = c->payload[0];
563 ASSERT(*first_child != NULL);
564 init_srt_fun(&se.info, get_fun_itbl(c));
569 *first_child = c->payload[0];
570 ASSERT(*first_child != NULL);
571 init_srt_thunk(&se.info, get_thunk_itbl(c));
574 case FUN_STATIC: // *c is a heap object.
575 ASSERT(get_itbl(c)->srt_bitmap != 0);
579 init_srt_fun(&se.info, get_fun_itbl(c));
580 *first_child = find_srt(&se.info);
581 if (*first_child == NULL)
587 ASSERT(get_itbl(c)->srt_bitmap != 0);
591 init_srt_thunk(&se.info, get_thunk_itbl(c));
592 *first_child = find_srt(&se.info);
593 if (*first_child == NULL)
604 case CONSTR_CHARLIKE:
605 case CONSTR_NOCAF_STATIC:
626 barf("Invalid object *c in push()");
630 if (stackTop - 1 < stackBottom) {
631 #ifdef DEBUG_RETAINER
632 // debugBelch("push() to the next stack.\n");
634 // currentStack->free is updated when the active stack is switched
635 // to the next stack.
636 currentStack->free = (StgPtr)stackTop;
638 if (currentStack->link == NULL) {
639 nbd = allocGroup(BLOCKS_IN_STACK);
641 nbd->u.back = currentStack;
642 currentStack->link = nbd;
644 nbd = currentStack->link;
649 // adjust stackTop (acutal push)
651 // If the size of stackElement was huge, we would better replace the
652 // following statement by either a memcpy() call or a switch statement
653 // on the type of the element. Currently, the size of stackElement is
654 // small enough (5 words) that this direct assignment seems to be enough.
657 #ifdef DEBUG_RETAINER
659 if (stackSize > maxStackSize) maxStackSize = stackSize;
660 // ASSERT(stackSize >= 0);
661 // debugBelch("stackSize = %d\n", stackSize);
665 /* -----------------------------------------------------------------------------
666 * popOff() and popOffReal(): Pop a stackElement off the traverse stack.
668 * stackTop cannot be equal to stackLimit unless the whole stack is
669 * empty, in which case popOff() is not allowed.
671 * You can think of popOffReal() as a part of popOff() which is
672 * executed at the end of popOff() in necessary. Since popOff() is
673 * likely to be executed quite often while popOffReal() is not, we
674 * separate popOffReal() from popOff(), which is declared as an
675 * INLINE function (for the sake of execution speed). popOffReal()
676 * is called only within popOff() and nowhere else.
677 * -------------------------------------------------------------------------- */
681 bdescr *pbd; // Previous Block Descriptor
683 #ifdef DEBUG_RETAINER
684 // debugBelch("pop() to the previous stack.\n");
687 ASSERT(stackTop + 1 == stackLimit);
688 ASSERT(stackBottom == (stackElement *)currentStack->start);
690 if (firstStack == currentStack) {
691 // The stack is completely empty.
693 ASSERT(stackTop == stackLimit);
694 #ifdef DEBUG_RETAINER
696 if (stackSize > maxStackSize) maxStackSize = stackSize;
698 ASSERT(stackSize >= 0);
699 debugBelch("stackSize = %d\n", stackSize);
705 // currentStack->free is updated when the active stack is switched back
706 // to the previous stack.
707 currentStack->free = (StgPtr)stackLimit;
709 // find the previous block descriptor
710 pbd = currentStack->u.back;
713 returnToOldStack(pbd);
715 #ifdef DEBUG_RETAINER
717 if (stackSize > maxStackSize) maxStackSize = stackSize;
719 ASSERT(stackSize >= 0);
720 debugBelch("stackSize = %d\n", stackSize);
727 #ifdef DEBUG_RETAINER
728 // debugBelch("\tpopOff(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
731 ASSERT(stackTop != stackLimit);
732 ASSERT(!isEmptyRetainerStack());
734 // <= (instead of <) is wrong!
735 if (stackTop + 1 < stackLimit) {
737 #ifdef DEBUG_RETAINER
739 if (stackSize > maxStackSize) maxStackSize = stackSize;
741 ASSERT(stackSize >= 0);
742 debugBelch("stackSize = %d\n", stackSize);
751 /* -----------------------------------------------------------------------------
752 * Finds the next object to be considered for retainer profiling and store
754 * Test if the topmost stack element indicates that more objects are left,
755 * and if so, retrieve the first object and store its pointer to *c. Also,
756 * set *cp and *r appropriately, both of which are stored in the stack element.
757 * The topmost stack element then is overwritten so as for it to now denote
759 * If the topmost stack element indicates no more objects are left, pop
760 * off the stack element until either an object can be retrieved or
761 * the current stack chunk becomes empty, indicated by rtsTrue returned by
762 * isOnBoundary(), in which case *c is set to NULL.
764 * It is okay to call this function even when the current stack chunk
766 * -------------------------------------------------------------------------- */
768 pop( StgClosure **c, StgClosure **cp, retainer *r )
772 #ifdef DEBUG_RETAINER
773 // debugBelch("pop(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
777 if (isOnBoundary()) { // if the current stack chunk is depleted
784 switch (get_itbl(se->c)->type) {
785 // two children (fixed), no SRT
786 // nothing in se.info
788 *c = se->c->payload[1];
794 // three children (fixed), no SRT
795 // need to push a stackElement
797 if (se->info.next.step == 2) {
798 *c = (StgClosure *)((StgMVar *)se->c)->tail;
799 se->info.next.step++; // move to the next step
802 *c = ((StgMVar *)se->c)->value;
809 // three children (fixed), no SRT
811 if (se->info.next.step == 2) {
812 *c = ((StgWeak *)se->c)->value;
813 se->info.next.step++;
816 *c = ((StgWeak *)se->c)->finalizer;
828 // StgMutArrPtr.ptrs, no SRT
830 case MUT_ARR_PTRS_FROZEN:
831 *c = find_ptrs(&se->info);
840 // layout.payload.ptrs, SRT
841 case FUN: // always a heap object
843 if (se->info.type == posTypePtrs) {
844 *c = find_ptrs(&se->info);
850 init_srt_fun(&se->info, get_fun_itbl(se->c));
856 if (se->info.type == posTypePtrs) {
857 *c = find_ptrs(&se->info);
863 init_srt_thunk(&se->info, get_thunk_itbl(se->c));
879 *c = find_srt(&se->info);
888 // no child (fixed), no SRT
894 case SE_CAF_BLACKHOLE:
896 // one child (fixed), no SRT
902 case IND_OLDGEN_PERM:
912 case CONSTR_CHARLIKE:
913 case CONSTR_NOCAF_STATIC:
934 barf("Invalid object *c in pop()");
940 /* -----------------------------------------------------------------------------
941 * RETAINER PROFILING ENGINE
942 * -------------------------------------------------------------------------- */
945 initRetainerProfiling( void )
947 initializeAllRetainerSet();
948 retainerGeneration = 0;
951 /* -----------------------------------------------------------------------------
952 * This function must be called before f-closing prof_file.
953 * -------------------------------------------------------------------------- */
955 endRetainerProfiling( void )
957 #ifdef SECOND_APPROACH
958 outputAllRetainerSet(prof_file);
962 /* -----------------------------------------------------------------------------
963 * Returns the actual pointer to the retainer set of the closure *c.
964 * It may adjust RSET(c) subject to flip.
966 * RSET(c) is initialized to NULL if its current value does not
969 * Even though this function has side effects, they CAN be ignored because
970 * subsequent calls to retainerSetOf() always result in the same return value
971 * and retainerSetOf() is the only way to retrieve retainerSet of a given
973 * We have to perform an XOR (^) operation each time a closure is examined.
974 * The reason is that we do not know when a closure is visited last.
975 * -------------------------------------------------------------------------- */
977 maybeInitRetainerSet( StgClosure *c )
979 if (!isRetainerSetFieldValid(c)) {
980 setRetainerSetToNull(c);
984 /* -----------------------------------------------------------------------------
985 * Returns rtsTrue if *c is a retainer.
986 * -------------------------------------------------------------------------- */
987 static INLINE rtsBool
988 isRetainer( StgClosure *c )
990 switch (get_itbl(c)->type) {
994 // TSOs MUST be retainers: they constitute the set of roots.
1002 case MUT_ARR_PTRS_FROZEN:
1004 // thunks are retainers.
1011 case THUNK_SELECTOR:
1015 // Static thunks, or CAFS, are obviously retainers.
1018 // WEAK objects are roots; there is separate code in which traversing
1019 // begins from WEAK objects.
1041 // partial applications
1047 case SE_CAF_BLACKHOLE:
1051 case IND_OLDGEN_PERM:
1066 // IND_STATIC cannot be *c, *cp, *r in the retainer profiling loop.
1068 // CONSTR_INTLIKE, CONSTR_CHARLIKE, and CONSTR_NOCAF_STATIC
1069 // cannot be *c, *cp, *r in the retainer profiling loop.
1070 case CONSTR_INTLIKE:
1071 case CONSTR_CHARLIKE:
1072 case CONSTR_NOCAF_STATIC:
1073 // Stack objects are invalid because they are never treated as
1074 // legal objects during retainer profiling.
1092 case INVALID_OBJECT:
1094 barf("Invalid object in isRetainer(): %d", get_itbl(c)->type);
1099 /* -----------------------------------------------------------------------------
1100 * Returns the retainer function value for the closure *c, i.e., R(*c).
1101 * This function does NOT return the retainer(s) of *c.
1103 * *c must be a retainer.
1105 * Depending on the definition of this function, the maintenance of retainer
1106 * sets can be made easier. If most retainer sets are likely to be created
1107 * again across garbage collections, refreshAllRetainerSet() in
1108 * RetainerSet.c can simply do nothing.
1109 * If this is not the case, we can free all the retainer sets and
1110 * re-initialize the hash table.
1111 * See refreshAllRetainerSet() in RetainerSet.c.
1112 * -------------------------------------------------------------------------- */
1113 static INLINE retainer
1114 getRetainerFrom( StgClosure *c )
1116 ASSERT(isRetainer(c));
1118 #if defined(RETAINER_SCHEME_INFO)
1119 // Retainer scheme 1: retainer = info table
1121 #elif defined(RETAINER_SCHEME_CCS)
1122 // Retainer scheme 2: retainer = cost centre stack
1123 return c->header.prof.ccs;
1124 #elif defined(RETAINER_SCHEME_CC)
1125 // Retainer scheme 3: retainer = cost centre
1126 return c->header.prof.ccs->cc;
1130 /* -----------------------------------------------------------------------------
1131 * Associates the retainer set *s with the closure *c, that is, *s becomes
1132 * the retainer set of *c.
1136 * -------------------------------------------------------------------------- */
1138 associate( StgClosure *c, RetainerSet *s )
1140 // StgWord has the same size as pointers, so the following type
1142 RSET(c) = (RetainerSet *)((StgWord)s | flip);
1145 /* -----------------------------------------------------------------------------
1146 Call retainClosure for each of the closures covered by a large bitmap.
1147 -------------------------------------------------------------------------- */
1150 retain_large_bitmap (StgPtr p, StgLargeBitmap *large_bitmap, nat size,
1151 StgClosure *c, retainer c_child_r)
1157 bitmap = large_bitmap->bitmap[b];
1158 for (i = 0; i < size; ) {
1159 if ((bitmap & 1) == 0) {
1160 retainClosure((StgClosure *)*p, c, c_child_r);
1164 if (i % BITS_IN(W_) == 0) {
1166 bitmap = large_bitmap->bitmap[b];
1168 bitmap = bitmap >> 1;
1173 static INLINE StgPtr
1174 retain_small_bitmap (StgPtr p, nat size, StgWord bitmap,
1175 StgClosure *c, retainer c_child_r)
1178 if ((bitmap & 1) == 0) {
1179 retainClosure((StgClosure *)*p, c, c_child_r);
1182 bitmap = bitmap >> 1;
1188 /* -----------------------------------------------------------------------------
1189 * Call retainClosure for each of the closures in an SRT.
1190 * ------------------------------------------------------------------------- */
1193 retain_large_srt_bitmap (StgLargeSRT *srt, StgClosure *c, retainer c_child_r)
1200 p = (StgClosure **)srt->srt;
1202 bitmap = srt->l.bitmap[b];
1203 for (i = 0; i < size; ) {
1204 if ((bitmap & 1) != 0) {
1205 retainClosure((StgClosure *)*p, c, c_child_r);
1209 if (i % BITS_IN(W_) == 0) {
1211 bitmap = srt->l.bitmap[b];
1213 bitmap = bitmap >> 1;
1219 retainSRT (StgClosure **srt, nat srt_bitmap, StgClosure *c, retainer c_child_r)
1224 bitmap = srt_bitmap;
1227 if (bitmap == (StgHalfWord)(-1)) {
1228 retain_large_srt_bitmap( (StgLargeSRT *)srt, c, c_child_r );
1232 while (bitmap != 0) {
1233 if ((bitmap & 1) != 0) {
1234 #ifdef ENABLE_WIN32_DLL_SUPPORT
1235 if ( (unsigned long)(*srt) & 0x1 ) {
1236 retainClosure(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)),
1239 retainClosure(*srt,c,c_child_r);
1242 retainClosure(*srt,c,c_child_r);
1246 bitmap = bitmap >> 1;
1250 /* -----------------------------------------------------------------------------
1251 * Process all the objects in the stack chunk from stackStart to stackEnd
1252 * with *c and *c_child_r being their parent and their most recent retainer,
1253 * respectively. Treat stackOptionalFun as another child of *c if it is
1256 * *c is one of the following: TSO, AP_STACK.
1257 * If *c is TSO, c == c_child_r.
1258 * stackStart < stackEnd.
1259 * RSET(c) and RSET(c_child_r) are valid, i.e., their
1260 * interpretation conforms to the current value of flip (even when they
1261 * are interpreted to be NULL).
1262 * If *c is TSO, its state is not any of ThreadRelocated, ThreadComplete,
1263 * or ThreadKilled, which means that its stack is ready to process.
1265 * This code was almost plagiarzied from GC.c! For each pointer,
1266 * retainClosure() is invoked instead of evacuate().
1267 * -------------------------------------------------------------------------- */
1269 retainStack( StgClosure *c, retainer c_child_r,
1270 StgPtr stackStart, StgPtr stackEnd )
1272 stackElement *oldStackBoundary;
1274 StgRetInfoTable *info;
1278 #ifdef DEBUG_RETAINER
1280 if (cStackSize > maxCStackSize) maxCStackSize = cStackSize;
1284 Each invocation of retainStack() creates a new virtual
1285 stack. Since all such stacks share a single common stack, we
1286 record the current currentStackBoundary, which will be restored
1289 oldStackBoundary = currentStackBoundary;
1290 currentStackBoundary = stackTop;
1292 #ifdef DEBUG_RETAINER
1293 // debugBelch("retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
1296 ASSERT(get_itbl(c)->type != TSO ||
1297 (((StgTSO *)c)->what_next != ThreadRelocated &&
1298 ((StgTSO *)c)->what_next != ThreadComplete &&
1299 ((StgTSO *)c)->what_next != ThreadKilled));
1302 while (p < stackEnd) {
1303 info = get_ret_itbl((StgClosure *)p);
1305 switch(info->i.type) {
1308 retainClosure(((StgUpdateFrame *)p)->updatee, c, c_child_r);
1309 p += sizeofW(StgUpdateFrame);
1316 bitmap = BITMAP_BITS(info->i.layout.bitmap);
1317 size = BITMAP_SIZE(info->i.layout.bitmap);
1319 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1322 retainSRT((StgClosure **)GET_SRT(info), info->i.srt_bitmap, c, c_child_r);
1329 retainClosure((StgClosure *)*p, c, c_child_r);
1332 size = BCO_BITMAP_SIZE(bco);
1333 retain_large_bitmap(p, BCO_BITMAP(bco), size, c, c_child_r);
1338 // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
1341 size = GET_LARGE_BITMAP(&info->i)->size;
1343 retain_large_bitmap(p, GET_LARGE_BITMAP(&info->i),
1344 size, c, c_child_r);
1346 // and don't forget to follow the SRT
1349 // Dynamic bitmap: the mask is stored on the stack
1352 dyn = ((StgRetDyn *)p)->liveness;
1354 // traverse the bitmap first
1355 bitmap = RET_DYN_LIVENESS(dyn);
1356 p = (P_)&((StgRetDyn *)p)->payload[0];
1357 size = RET_DYN_BITMAP_SIZE;
1358 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1360 // skip over the non-ptr words
1361 p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
1363 // follow the ptr words
1364 for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
1365 retainClosure((StgClosure *)*p, c, c_child_r);
1372 StgRetFun *ret_fun = (StgRetFun *)p;
1373 StgFunInfoTable *fun_info;
1375 retainClosure(ret_fun->fun, c, c_child_r);
1376 fun_info = get_fun_itbl(ret_fun->fun);
1378 p = (P_)&ret_fun->payload;
1379 switch (fun_info->f.fun_type) {
1381 bitmap = BITMAP_BITS(fun_info->f.bitmap);
1382 size = BITMAP_SIZE(fun_info->f.bitmap);
1383 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1386 size = GET_FUN_LARGE_BITMAP(fun_info)->size;
1387 retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
1388 size, c, c_child_r);
1392 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1393 size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
1394 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1401 barf("Invalid object found in retainStack(): %d",
1402 (int)(info->i.type));
1406 // restore currentStackBoundary
1407 currentStackBoundary = oldStackBoundary;
1408 #ifdef DEBUG_RETAINER
1409 // debugBelch("retainStack() finished: currentStackBoundary = 0x%x\n", currentStackBoundary);
1412 #ifdef DEBUG_RETAINER
1417 /* ----------------------------------------------------------------------------
1418 * Call retainClosure for each of the children of a PAP/AP
1419 * ------------------------------------------------------------------------- */
1421 static INLINE StgPtr
1422 retain_PAP (StgPAP *pap, retainer c_child_r)
1425 StgWord bitmap, size;
1426 StgFunInfoTable *fun_info;
1428 retainClosure(pap->fun, (StgClosure *)pap, c_child_r);
1429 fun_info = get_fun_itbl(pap->fun);
1430 ASSERT(fun_info->i.type != PAP);
1432 p = (StgPtr)pap->payload;
1435 switch (fun_info->f.fun_type) {
1437 bitmap = BITMAP_BITS(fun_info->f.bitmap);
1438 p = retain_small_bitmap(p, pap->n_args, bitmap,
1439 (StgClosure *)pap, c_child_r);
1442 retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
1443 size, (StgClosure *)pap, c_child_r);
1447 retain_large_bitmap((StgPtr)pap->payload, BCO_BITMAP(pap->fun),
1448 size, (StgClosure *)pap, c_child_r);
1452 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1453 p = retain_small_bitmap(p, pap->n_args, bitmap,
1454 (StgClosure *)pap, c_child_r);
1460 /* -----------------------------------------------------------------------------
1461 * Compute the retainer set of *c0 and all its desecents by traversing.
1462 * *cp0 is the parent of *c0, and *r0 is the most recent retainer of *c0.
1464 * c0 = cp0 = r0 holds only for root objects.
1465 * RSET(cp0) and RSET(r0) are valid, i.e., their
1466 * interpretation conforms to the current value of flip (even when they
1467 * are interpreted to be NULL).
1468 * However, RSET(c0) may be corrupt, i.e., it may not conform to
1469 * the current value of flip. If it does not, during the execution
1470 * of this function, RSET(c0) must be initialized as well as all
1473 * stackTop must be the same at the beginning and the exit of this function.
1474 * *c0 can be TSO (as well as AP_STACK).
1475 * -------------------------------------------------------------------------- */
1477 retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
1479 // c = Current closure
1480 // cp = Current closure's Parent
1481 // r = current closures' most recent Retainer
1482 // c_child_r = current closure's children's most recent retainer
1483 // first_child = first child of c
1484 StgClosure *c, *cp, *first_child;
1485 RetainerSet *s, *retainerSetOfc;
1486 retainer r, c_child_r;
1489 #ifdef DEBUG_RETAINER
1490 // StgPtr oldStackTop;
1493 #ifdef DEBUG_RETAINER
1494 // oldStackTop = stackTop;
1495 // debugBelch("retainClosure() called: c0 = 0x%x, cp0 = 0x%x, r0 = 0x%x\n", c0, cp0, r0);
1498 // (c, cp, r) = (c0, cp0, r0)
1505 //debugBelch("loop");
1506 // pop to (c, cp, r);
1510 #ifdef DEBUG_RETAINER
1511 // debugBelch("retainClosure() ends: oldStackTop = 0x%x, stackTop = 0x%x\n", oldStackTop, stackTop);
1516 //debugBelch("inner_loop");
1519 // c = current closure under consideration,
1520 // cp = current closure's parent,
1521 // r = current closure's most recent retainer
1523 // Loop invariants (on the meaning of c, cp, r, and their retainer sets):
1524 // RSET(cp) and RSET(r) are valid.
1525 // RSET(c) is valid only if c has been visited before.
1527 // Loop invariants (on the relation between c, cp, and r)
1528 // if cp is not a retainer, r belongs to RSET(cp).
1529 // if cp is a retainer, r == cp.
1531 typeOfc = get_itbl(c)->type;
1533 #ifdef DEBUG_RETAINER
1536 case CONSTR_INTLIKE:
1537 case CONSTR_CHARLIKE:
1538 case CONSTR_NOCAF_STATIC:
1544 if (retainerSetOf(c) == NULL) { // first visit?
1545 costArray[typeOfc] += cost(c);
1546 sumOfNewCost += cost(c);
1555 if (((StgTSO *)c)->what_next == ThreadComplete ||
1556 ((StgTSO *)c)->what_next == ThreadKilled) {
1557 #ifdef DEBUG_RETAINER
1558 debugBelch("ThreadComplete or ThreadKilled encountered in retainClosure()\n");
1562 if (((StgTSO *)c)->what_next == ThreadRelocated) {
1563 #ifdef DEBUG_RETAINER
1564 debugBelch("ThreadRelocated encountered in retainClosure()\n");
1566 c = (StgClosure *)((StgTSO *)c)->link;
1572 // We just skip IND_STATIC, so its retainer set is never computed.
1573 c = ((StgIndStatic *)c)->indirectee;
1575 case CONSTR_INTLIKE:
1576 case CONSTR_CHARLIKE:
1577 // static objects with no pointers out, so goto loop.
1578 case CONSTR_NOCAF_STATIC:
1579 // It is not just enough not to compute the retainer set for *c; it is
1580 // mandatory because CONSTR_NOCAF_STATIC are not reachable from
1581 // scavenged_static_objects, the list from which is assumed to traverse
1582 // all static objects after major garbage collections.
1586 if (get_itbl(c)->srt_bitmap == 0) {
1587 // No need to compute the retainer set; no dynamic objects
1588 // are reachable from *c.
1590 // Static objects: if we traverse all the live closures,
1591 // including static closures, during each heap census then
1592 // we will observe that some static closures appear and
1593 // disappear. eg. a closure may contain a pointer to a
1594 // static function 'f' which is not otherwise reachable
1595 // (it doesn't indirectly point to any CAFs, so it doesn't
1596 // appear in any SRTs), so we would find 'f' during
1597 // traversal. However on the next sweep there may be no
1598 // closures pointing to 'f'.
1600 // We must therefore ignore static closures whose SRT is
1601 // empty, because these are exactly the closures that may
1602 // "appear". A closure with a non-empty SRT, and which is
1603 // still required, will always be reachable.
1605 // But what about CONSTR_STATIC? Surely these may be able
1606 // to appear, and they don't have SRTs, so we can't
1607 // check. So for now, we're calling
1608 // resetStaticObjectForRetainerProfiling() from the
1609 // garbage collector to reset the retainer sets in all the
1610 // reachable static objects.
1617 // The above objects are ignored in computing the average number of times
1618 // an object is visited.
1619 timesAnyObjectVisited++;
1621 // If this is the first visit to c, initialize its retainer set.
1622 maybeInitRetainerSet(c);
1623 retainerSetOfc = retainerSetOf(c);
1626 // isRetainer(cp) == rtsTrue => s == NULL
1627 // isRetainer(cp) == rtsFalse => s == cp.retainer
1631 s = retainerSetOf(cp);
1633 // (c, cp, r, s) is available.
1635 // (c, cp, r, s, R_r) is available, so compute the retainer set for *c.
1636 if (retainerSetOfc == NULL) {
1637 // This is the first visit to *c.
1641 associate(c, singleton(r));
1643 // s is actually the retainer set of *c!
1646 // compute c_child_r
1647 c_child_r = isRetainer(c) ? getRetainerFrom(c) : r;
1649 // This is not the first visit to *c.
1650 if (isMember(r, retainerSetOfc))
1651 goto loop; // no need to process child
1654 associate(c, addElement(r, retainerSetOfc));
1656 // s is not NULL and cp is not a retainer. This means that
1657 // each time *cp is visited, so is *c. Thus, if s has
1658 // exactly one more element in its retainer set than c, s
1659 // is also the new retainer set for *c.
1660 if (s->num == retainerSetOfc->num + 1) {
1663 // Otherwise, just add R_r to the current retainer set of *c.
1665 associate(c, addElement(r, retainerSetOfc));
1670 goto loop; // no need to process child
1672 // compute c_child_r
1676 // now, RSET() of all of *c, *cp, and *r is valid.
1677 // (c, c_child_r) are available.
1681 // Special case closures: we process these all in one go rather
1682 // than attempting to save the current position, because doing so
1686 retainStack(c, c_child_r,
1688 ((StgTSO *)c)->stack + ((StgTSO *)c)->stack_size);
1693 retain_PAP((StgPAP *)c, c_child_r);
1697 retainClosure(((StgAP_STACK *)c)->fun, c, c_child_r);
1698 retainStack(c, c_child_r,
1699 (StgPtr)((StgAP_STACK *)c)->payload,
1700 (StgPtr)((StgAP_STACK *)c)->payload +
1701 ((StgAP_STACK *)c)->size);
1705 push(c, c_child_r, &first_child);
1707 // If first_child is null, c has no child.
1708 // If first_child is not null, the top stack element points to the next
1709 // object. push() may or may not push a stackElement on the stack.
1710 if (first_child == NULL)
1713 // (c, cp, r) = (first_child, c, c_child_r)
1720 /* -----------------------------------------------------------------------------
1721 * Compute the retainer set for every object reachable from *tl.
1722 * -------------------------------------------------------------------------- */
1724 retainRoot( StgClosure **tl )
1726 // We no longer assume that only TSOs and WEAKs are roots; any closure can
1729 ASSERT(isEmptyRetainerStack());
1730 currentStackBoundary = stackTop;
1732 if (isRetainer(*tl)) {
1733 retainClosure(*tl, *tl, getRetainerFrom(*tl));
1735 retainClosure(*tl, *tl, CCS_SYSTEM);
1738 // NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl)));
1739 // *tl might be a TSO which is ThreadComplete, in which
1740 // case we ignore it for the purposes of retainer profiling.
1743 /* -----------------------------------------------------------------------------
1744 * Compute the retainer set for each of the objects in the heap.
1745 * -------------------------------------------------------------------------- */
1747 computeRetainerSet( void )
1753 #ifdef DEBUG_RETAINER
1754 RetainerSet tmpRetainerSet;
1757 GetRoots(retainRoot); // for scheduler roots
1759 // This function is called after a major GC, when key, value, and finalizer
1760 // all are guaranteed to be valid, or reachable.
1762 // The following code assumes that WEAK objects are considered to be roots
1763 // for retainer profilng.
1764 for (weak = weak_ptr_list; weak != NULL; weak = weak->link)
1765 // retainRoot((StgClosure *)weak);
1766 retainRoot((StgClosure **)&weak);
1768 // Consider roots from the stable ptr table.
1769 markStablePtrTable(retainRoot);
1771 // The following code resets the rs field of each unvisited mutable
1772 // object (computing sumOfNewCostExtra and updating costArray[] when
1773 // debugging retainer profiler).
1774 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1776 (generations[g].mut_list == END_MUT_LIST &&
1777 generations[g].mut_once_list == END_MUT_LIST));
1780 // I think traversing through mut_list is unnecessary.
1781 // Think about removing this part.
1782 for (ml = generations[g].mut_list; ml != END_MUT_LIST;
1783 ml = ml->mut_link) {
1785 maybeInitRetainerSet((StgClosure *)ml);
1786 rtl = retainerSetOf((StgClosure *)ml);
1788 #ifdef DEBUG_RETAINER
1790 // first visit to *ml
1791 // This is a violation of the interface rule!
1792 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1794 switch (get_itbl((StgClosure *)ml)->type) {
1798 case CONSTR_INTLIKE:
1799 case CONSTR_CHARLIKE:
1800 case CONSTR_NOCAF_STATIC:
1804 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1808 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1809 sumOfNewCostExtra += cost((StgClosure *)ml);
1816 // Traversing through mut_once_list is, in contrast, necessary
1817 // because we can find MUT_VAR objects which have not been
1818 // visited during retainer profiling.
1819 for (ml = generations[g].mut_once_list; ml != END_MUT_LIST;
1820 ml = ml->mut_link) {
1822 maybeInitRetainerSet((StgClosure *)ml);
1823 rtl = retainerSetOf((StgClosure *)ml);
1824 #ifdef DEBUG_RETAINER
1826 // first visit to *ml
1827 // This is a violation of the interface rule!
1828 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1830 switch (get_itbl((StgClosure *)ml)->type) {
1834 case CONSTR_INTLIKE:
1835 case CONSTR_CHARLIKE:
1836 case CONSTR_NOCAF_STATIC:
1840 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1844 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1845 sumOfNewCostExtra += cost((StgClosure *)ml);
1854 /* -----------------------------------------------------------------------------
1855 * Traverse all static objects for which we compute retainer sets,
1856 * and reset their rs fields to NULL, which is accomplished by
1857 * invoking maybeInitRetainerSet(). This function must be called
1858 * before zeroing all objects reachable from scavenged_static_objects
1859 * in the case of major gabage collections. See GarbageCollect() in
1862 * The mut_once_list of the oldest generation must also be traversed?
1863 * Why? Because if the evacuation of an object pointed to by a static
1864 * indirection object fails, it is put back to the mut_once_list of
1865 * the oldest generation.
1866 * However, this is not necessary because any static indirection objects
1867 * are just traversed through to reach dynamic objects. In other words,
1868 * they are not taken into consideration in computing retainer sets.
1869 * -------------------------------------------------------------------------- */
1871 resetStaticObjectForRetainerProfiling( void )
1873 #ifdef DEBUG_RETAINER
1878 #ifdef DEBUG_RETAINER
1881 p = scavenged_static_objects;
1882 while (p != END_OF_STATIC_LIST) {
1883 #ifdef DEBUG_RETAINER
1886 switch (get_itbl(p)->type) {
1888 // Since we do not compute the retainer set of any
1889 // IND_STATIC object, we don't have to reset its retainer
1891 p = IND_STATIC_LINK(p);
1894 maybeInitRetainerSet(p);
1895 p = THUNK_STATIC_LINK(p);
1898 maybeInitRetainerSet(p);
1899 p = FUN_STATIC_LINK(p);
1902 maybeInitRetainerSet(p);
1903 p = STATIC_LINK(get_itbl(p), p);
1906 barf("resetStaticObjectForRetainerProfiling: %p (%s)",
1907 p, get_itbl(p)->type);
1911 #ifdef DEBUG_RETAINER
1912 // debugBelch("count in scavenged_static_objects = %d\n", count);
1916 /* -----------------------------------------------------------------------------
1917 * Perform retainer profiling.
1918 * N is the oldest generation being profilied, where the generations are
1919 * numbered starting at 0.
1922 * This function should be called only immediately after major garbage
1924 * ------------------------------------------------------------------------- */
1926 retainerProfile(void)
1928 #ifdef DEBUG_RETAINER
1930 nat totalHeapSize; // total raw heap size (computed by linear scanning)
1933 #ifdef DEBUG_RETAINER
1934 debugBelch(" < retainerProfile() invoked : %d>\n", retainerGeneration);
1939 // We haven't flipped the bit yet.
1940 #ifdef DEBUG_RETAINER
1941 debugBelch("Before traversing:\n");
1942 sumOfCostLinear = 0;
1943 for (i = 0;i < N_CLOSURE_TYPES; i++)
1944 costArrayLinear[i] = 0;
1945 totalHeapSize = checkHeapSanityForRetainerProfiling();
1947 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1949 debugBelch("costArrayLinear[] = ");
1950 for (i = 0;i < N_CLOSURE_TYPES; i++)
1951 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
1955 ASSERT(sumOfCostLinear == totalHeapSize);
1958 #define pcostArrayLinear(index) \
1959 if (costArrayLinear[index] > 0) \
1960 debugBelch("costArrayLinear[" #index "] = %u\n", costArrayLinear[index])
1961 pcostArrayLinear(THUNK_STATIC);
1962 pcostArrayLinear(FUN_STATIC);
1963 pcostArrayLinear(CONSTR_STATIC);
1964 pcostArrayLinear(CONSTR_NOCAF_STATIC);
1965 pcostArrayLinear(CONSTR_INTLIKE);
1966 pcostArrayLinear(CONSTR_CHARLIKE);
1970 // Now we flips flip.
1973 #ifdef DEBUG_RETAINER
1979 numObjectVisited = 0;
1980 timesAnyObjectVisited = 0;
1982 #ifdef DEBUG_RETAINER
1983 debugBelch("During traversing:\n");
1985 sumOfNewCostExtra = 0;
1986 for (i = 0;i < N_CLOSURE_TYPES; i++)
1991 We initialize the traverse stack each time the retainer profiling is
1992 performed (because the traverse stack size varies on each retainer profiling
1993 and this operation is not costly anyhow). However, we just refresh the
1996 initializeTraverseStack();
1997 #ifdef DEBUG_RETAINER
1998 initializeAllRetainerSet();
2000 refreshAllRetainerSet();
2002 computeRetainerSet();
2004 #ifdef DEBUG_RETAINER
2005 debugBelch("After traversing:\n");
2006 sumOfCostLinear = 0;
2007 for (i = 0;i < N_CLOSURE_TYPES; i++)
2008 costArrayLinear[i] = 0;
2009 totalHeapSize = checkHeapSanityForRetainerProfiling();
2011 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
2012 ASSERT(sumOfCostLinear == totalHeapSize);
2014 // now, compare the two results
2017 costArray[] must be exactly the same as costArrayLinear[].
2019 1) Dead weak pointers, whose type is CONSTR. These objects are not
2020 reachable from any roots.
2022 debugBelch("Comparison:\n");
2023 debugBelch("\tcostArrayLinear[] (must be empty) = ");
2024 for (i = 0;i < N_CLOSURE_TYPES; i++)
2025 if (costArray[i] != costArrayLinear[i])
2026 // nothing should be printed except MUT_VAR after major GCs
2027 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
2030 debugBelch("\tsumOfNewCost = %u\n", sumOfNewCost);
2031 debugBelch("\tsumOfNewCostExtra = %u\n", sumOfNewCostExtra);
2032 debugBelch("\tcostArray[] (must be empty) = ");
2033 for (i = 0;i < N_CLOSURE_TYPES; i++)
2034 if (costArray[i] != costArrayLinear[i])
2035 // nothing should be printed except MUT_VAR after major GCs
2036 debugBelch("[%u:%u] ", i, costArray[i]);
2039 // only for major garbage collection
2040 ASSERT(sumOfNewCost + sumOfNewCostExtra == sumOfCostLinear);
2044 closeTraverseStack();
2045 #ifdef DEBUG_RETAINER
2046 closeAllRetainerSet();
2048 // Note that there is no post-processing for the retainer sets.
2050 retainerGeneration++;
2053 retainerGeneration - 1, // retainerGeneration has just been incremented!
2054 #ifdef DEBUG_RETAINER
2055 maxCStackSize, maxStackSize,
2057 (double)timesAnyObjectVisited / numObjectVisited);
2060 /* -----------------------------------------------------------------------------
2062 * -------------------------------------------------------------------------- */
2064 #ifdef DEBUG_RETAINER
2066 #define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
2067 ((HEAP_ALLOCED(r) && Bdescr((P_)r)->free != (void *)-1))) && \
2068 ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa))
2071 sanityCheckHeapClosure( StgClosure *c )
2075 ASSERT(LOOKS_LIKE_GHC_INFO(c->header.info));
2076 ASSERT(!closure_STATIC(c));
2077 ASSERT(LOOKS_LIKE_PTR(c));
2079 if ((((StgWord)RSET(c) & 1) ^ flip) != 0) {
2080 if (get_itbl(c)->type == CONSTR &&
2081 !strcmp(get_itbl(c)->prof.closure_type, "DEAD_WEAK") &&
2082 !strcmp(get_itbl(c)->prof.closure_desc, "DEAD_WEAK")) {
2083 debugBelch("\tUnvisited dead weak pointer object found: c = %p\n", c);
2084 costArray[get_itbl(c)->type] += cost(c);
2085 sumOfNewCost += cost(c);
2088 "Unvisited object: flip = %d, c = %p(%d, %s, %s), rs = %p\n",
2089 flip, c, get_itbl(c)->type,
2090 get_itbl(c)->prof.closure_type, get_itbl(c)->prof.closure_desc,
2093 // debugBelch("sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c));
2097 switch (info->type) {
2099 return tso_sizeW((StgTSO *)c);
2107 return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE);
2110 return sizeofW(StgMVar);
2113 case MUT_ARR_PTRS_FROZEN:
2114 return mut_arr_ptrs_sizeW((StgMutArrPtrs *)c);
2118 return pap_sizeW((StgPAP *)c);
2121 return ap_stack_sizeW((StgAP_STACK *)c);
2124 return arr_words_sizeW((StgArrWords *)c);
2144 case SE_CAF_BLACKHOLE:
2148 case IND_OLDGEN_PERM:
2152 return sizeW_fromITBL(info);
2154 case THUNK_SELECTOR:
2155 return sizeofW(StgHeader) + MIN_UPD_SIZE;
2164 case CONSTR_INTLIKE:
2165 case CONSTR_CHARLIKE:
2166 case CONSTR_NOCAF_STATIC:
2183 case INVALID_OBJECT:
2185 barf("Invalid object in sanityCheckHeapClosure(): %d",
2192 heapCheck( bdescr *bd )
2195 static nat costSum, size;
2198 while (bd != NULL) {
2200 while (p < bd->free) {
2201 size = sanityCheckHeapClosure((StgClosure *)p);
2202 sumOfCostLinear += size;
2203 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2205 // no need for slop check; I think slops are not used currently.
2207 ASSERT(p == bd->free);
2208 costSum += bd->free - bd->start;
2216 smallObjectPoolCheck(void)
2220 static nat costSum, size;
2222 bd = small_alloc_list;
2230 while (p < alloc_Hp) {
2231 size = sanityCheckHeapClosure((StgClosure *)p);
2232 sumOfCostLinear += size;
2233 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2236 ASSERT(p == alloc_Hp);
2237 costSum += alloc_Hp - bd->start;
2240 while (bd != NULL) {
2242 while (p < bd->free) {
2243 size = sanityCheckHeapClosure((StgClosure *)p);
2244 sumOfCostLinear += size;
2245 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2248 ASSERT(p == bd->free);
2249 costSum += bd->free - bd->start;
2257 chainCheck(bdescr *bd)
2262 while (bd != NULL) {
2263 // bd->free - bd->start is not an accurate measurement of the
2264 // object size. Actually it is always zero, so we compute its
2266 size = sanityCheckHeapClosure((StgClosure *)bd->start);
2267 sumOfCostLinear += size;
2268 costArrayLinear[get_itbl((StgClosure *)bd->start)->type] += size;
2277 checkHeapSanityForRetainerProfiling( void )
2282 debugBelch("START: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2283 if (RtsFlags.GcFlags.generations == 1) {
2284 costSum += heapCheck(g0s0->to_blocks);
2285 debugBelch("heapCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2286 costSum += chainCheck(g0s0->large_objects);
2287 debugBelch("chainCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2289 for (g = 0; g < RtsFlags.GcFlags.generations; g++)
2290 for (s = 0; s < generations[g].n_steps; s++) {
2292 After all live objects have been scavenged, the garbage
2293 collector may create some objects in
2294 scheduleFinalizers(). These objects are created throught
2295 allocate(), so the small object pool or the large object
2296 pool of the g0s0 may not be empty.
2298 if (g == 0 && s == 0) {
2299 costSum += smallObjectPoolCheck();
2300 debugBelch("smallObjectPoolCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2301 costSum += chainCheck(generations[g].steps[s].large_objects);
2302 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2304 costSum += heapCheck(generations[g].steps[s].blocks);
2305 debugBelch("heapCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2306 costSum += chainCheck(generations[g].steps[s].large_objects);
2307 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2316 findPointer(StgPtr p)
2322 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2323 for (s = 0; s < generations[g].n_steps; s++) {
2324 // if (g == 0 && s == 0) continue;
2325 bd = generations[g].steps[s].blocks;
2326 for (; bd; bd = bd->link) {
2327 for (q = bd->start; q < bd->free; q++) {
2328 if (*q == (StgWord)p) {
2330 while (!LOOKS_LIKE_GHC_INFO(*r)) r--;
2331 debugBelch("Found in gen[%d], step[%d]: q = %p, r = %p\n", g, s, q, r);
2336 bd = generations[g].steps[s].large_objects;
2337 for (; bd; bd = bd->link) {
2338 e = bd->start + cost((StgClosure *)bd->start);
2339 for (q = bd->start; q < e; q++) {
2340 if (*q == (StgWord)p) {
2342 while (*r == 0 || !LOOKS_LIKE_GHC_INFO(*r)) r--;
2343 debugBelch("Found in gen[%d], large_objects: %p\n", g, r);
2353 belongToHeap(StgPtr p)
2358 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2359 for (s = 0; s < generations[g].n_steps; s++) {
2360 // if (g == 0 && s == 0) continue;
2361 bd = generations[g].steps[s].blocks;
2362 for (; bd; bd = bd->link) {
2363 if (bd->start <= p && p < bd->free) {
2364 debugBelch("Belongs to gen[%d], step[%d]", g, s);
2368 bd = generations[g].steps[s].large_objects;
2369 for (; bd; bd = bd->link) {
2370 if (bd->start <= p && p < bd->start + getHeapClosureSize((StgClosure *)bd->start)) {
2371 debugBelch("Found in gen[%d], large_objects: %p\n", g, bd->start);
2378 #endif // DEBUG_RETAINER
2380 #endif /* PROFILING */