1 /* -----------------------------------------------------------------------------
2 * $Id: RetainerProfile.c,v 1.12 2004/09/03 15:28:38 simonmar Exp $
4 * (c) The GHC Team, 2001
9 * ---------------------------------------------------------------------------*/
13 // Turn off inlining when debugging - it obfuscates things
22 #include "RetainerProfile.h"
23 #include "RetainerSet.h"
30 #include "Profiling.h"
32 #include "BlockAlloc.h"
37 Note: what to change in order to plug-in a new retainer profiling scheme?
38 (1) type retainer in ../includes/StgRetainerProf.h
39 (2) retainer function R(), i.e., getRetainerFrom()
40 (3) the two hashing functions, hashKeySingleton() and hashKeyAddElement(),
41 in RetainerSet.h, if needed.
42 (4) printRetainer() and printRetainerSetShort() in RetainerSet.c.
45 /* -----------------------------------------------------------------------------
47 * -------------------------------------------------------------------------- */
49 static nat retainerGeneration; // generation
51 static nat numObjectVisited; // total number of objects visited
52 static nat timesAnyObjectVisited; // number of times any objects are visited
55 The rs field in the profile header of any object points to its retainer
56 set in an indirect way: if flip is 0, it points to the retainer set;
57 if flip is 1, it points to the next byte after the retainer set (even
58 for NULL pointers). Therefore, with flip 1, (rs ^ 1) is the actual
59 pointer. See retainerSetOf().
62 StgWord flip = 0; // flip bit
63 // must be 0 if DEBUG_RETAINER is on (for static closures)
65 #define setRetainerSetToNull(c) \
66 (c)->header.prof.hp.rs = (RetainerSet *)((StgWord)NULL | flip)
68 static void retainStack(StgClosure *, retainer, StgPtr, StgPtr);
69 static void retainClosure(StgClosure *, StgClosure *, retainer);
71 static void belongToHeap(StgPtr p);
76 cStackSize records how many times retainStack() has been invoked recursively,
77 that is, the number of activation records for retainStack() on the C stack.
78 maxCStackSize records its max value.
80 cStackSize <= maxCStackSize
82 static nat cStackSize, maxCStackSize;
84 static nat sumOfNewCost; // sum of the cost of each object, computed
85 // when the object is first visited
86 static nat sumOfNewCostExtra; // for those objects not visited during
87 // retainer profiling, e.g., MUT_VAR
88 static nat costArray[N_CLOSURE_TYPES];
90 nat sumOfCostLinear; // sum of the costs of all object, computed
91 // when linearly traversing the heap after
93 nat costArrayLinear[N_CLOSURE_TYPES];
96 /* -----------------------------------------------------------------------------
97 * Retainer stack - header
99 * Although the retainer stack implementation could be separated *
100 * from the retainer profiling engine, there does not seem to be
101 * any advantage in doing that; retainer stack is an integral part
102 * of retainer profiling engine and cannot be use elsewhere at
104 * -------------------------------------------------------------------------- */
114 // fixed layout or layout specified by a field in the closure
119 // See StgClosureInfo in InfoTables.h
120 #if SIZEOF_VOID_P == 8
157 firstStack points to the first block group.
158 currentStack points to the block group currently being used.
159 currentStack->free == stackLimit.
160 stackTop points to the topmost byte in the stack of currentStack.
161 Unless the whole stack is empty, stackTop must point to the topmost
162 object (or byte) in the whole stack. Thus, it is only when the whole stack
163 is empty that stackTop == stackLimit (not during the execution of push()
165 stackBottom == currentStack->start.
166 stackLimit == currentStack->start + BLOCK_SIZE_W * currentStack->blocks.
168 When a current stack becomes empty, stackTop is set to point to
169 the topmost element on the previous block group so as to satisfy
170 the invariants described above.
172 static bdescr *firstStack = NULL;
173 static bdescr *currentStack;
174 static stackElement *stackBottom, *stackTop, *stackLimit;
177 currentStackBoundary is used to mark the current stack chunk.
178 If stackTop == currentStackBoundary, it means that the current stack chunk
179 is empty. It is the responsibility of the user to keep currentStackBoundary
180 valid all the time if it is to be employed.
182 static stackElement *currentStackBoundary;
185 stackSize records the current size of the stack.
186 maxStackSize records its high water mark.
188 stackSize <= maxStackSize
190 stackSize is just an estimate measure of the depth of the graph. The reason
191 is that some heap objects have only a single child and may not result
192 in a new element being pushed onto the stack. Therefore, at the end of
193 retainer profiling, maxStackSize + maxCStackSize is some value no greater
194 than the actual depth of the graph.
196 #ifdef DEBUG_RETAINER
197 static int stackSize, maxStackSize;
200 // number of blocks allocated for one stack
201 #define BLOCKS_IN_STACK 1
203 /* -----------------------------------------------------------------------------
204 * Add a new block group to the stack.
206 * currentStack->link == s.
207 * -------------------------------------------------------------------------- */
209 newStackBlock( bdescr *bd )
212 stackTop = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
213 stackBottom = (stackElement *)bd->start;
214 stackLimit = (stackElement *)stackTop;
215 bd->free = (StgPtr)stackLimit;
218 /* -----------------------------------------------------------------------------
219 * Return to the previous block group.
221 * s->link == currentStack.
222 * -------------------------------------------------------------------------- */
224 returnToOldStack( bdescr *bd )
227 stackTop = (stackElement *)bd->free;
228 stackBottom = (stackElement *)bd->start;
229 stackLimit = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
230 bd->free = (StgPtr)stackLimit;
233 /* -----------------------------------------------------------------------------
234 * Initializes the traverse stack.
235 * -------------------------------------------------------------------------- */
237 initializeTraverseStack( void )
239 if (firstStack != NULL) {
240 freeChain(firstStack);
243 firstStack = allocGroup(BLOCKS_IN_STACK);
244 firstStack->link = NULL;
245 firstStack->u.back = NULL;
247 newStackBlock(firstStack);
250 /* -----------------------------------------------------------------------------
251 * Frees all the block groups in the traverse stack.
254 * -------------------------------------------------------------------------- */
256 closeTraverseStack( void )
258 freeChain(firstStack);
262 /* -----------------------------------------------------------------------------
263 * Returns rtsTrue if the whole stack is empty.
264 * -------------------------------------------------------------------------- */
265 static INLINE rtsBool
266 isEmptyRetainerStack( void )
268 return (firstStack == currentStack) && stackTop == stackLimit;
271 /* -----------------------------------------------------------------------------
272 * Returns size of stack
273 * -------------------------------------------------------------------------- */
276 retainerStackBlocks( void )
281 for (bd = firstStack; bd != NULL; bd = bd->link)
288 /* -----------------------------------------------------------------------------
289 * Returns rtsTrue if stackTop is at the stack boundary of the current stack,
290 * i.e., if the current stack chunk is empty.
291 * -------------------------------------------------------------------------- */
292 static INLINE rtsBool
295 return stackTop == currentStackBoundary;
298 /* -----------------------------------------------------------------------------
299 * Initializes *info from ptrs and payload.
301 * payload[] begins with ptrs pointers followed by non-pointers.
302 * -------------------------------------------------------------------------- */
304 init_ptrs( stackPos *info, nat ptrs, StgPtr payload )
306 info->type = posTypePtrs;
307 info->next.ptrs.pos = 0;
308 info->next.ptrs.ptrs = ptrs;
309 info->next.ptrs.payload = payload;
312 /* -----------------------------------------------------------------------------
313 * Find the next object from *info.
314 * -------------------------------------------------------------------------- */
315 static INLINE StgClosure *
316 find_ptrs( stackPos *info )
318 if (info->next.ptrs.pos < info->next.ptrs.ptrs) {
319 return (StgClosure *)info->next.ptrs.payload[info->next.ptrs.pos++];
325 /* -----------------------------------------------------------------------------
326 * Initializes *info from SRT information stored in *infoTable.
327 * -------------------------------------------------------------------------- */
329 init_srt_fun( stackPos *info, StgFunInfoTable *infoTable )
331 if (infoTable->i.srt_bitmap == (StgHalfWord)(-1)) {
332 info->type = posTypeLargeSRT;
333 info->next.large_srt.srt = (StgLargeSRT *)infoTable->f.srt;
334 info->next.large_srt.offset = 0;
336 info->type = posTypeSRT;
337 info->next.srt.srt = (StgClosure **)(infoTable->f.srt);
338 info->next.srt.srt_bitmap = infoTable->i.srt_bitmap;
343 init_srt_thunk( stackPos *info, StgThunkInfoTable *infoTable )
345 if (infoTable->i.srt_bitmap == (StgHalfWord)(-1)) {
346 info->type = posTypeLargeSRT;
347 info->next.large_srt.srt = (StgLargeSRT *)infoTable->srt;
348 info->next.large_srt.offset = 0;
350 info->type = posTypeSRT;
351 info->next.srt.srt = (StgClosure **)(infoTable->srt);
352 info->next.srt.srt_bitmap = infoTable->i.srt_bitmap;
356 /* -----------------------------------------------------------------------------
357 * Find the next object from *info.
358 * -------------------------------------------------------------------------- */
359 static INLINE StgClosure *
360 find_srt( stackPos *info )
365 if (info->type == posTypeSRT) {
367 bitmap = info->next.srt.srt_bitmap;
368 while (bitmap != 0) {
369 if ((bitmap & 1) != 0) {
370 #ifdef ENABLE_WIN32_DLL_SUPPORT
372 if ((unsigned long)(*(info->next.srt.srt)) & 0x1)
373 c = (* (StgClosure **)((unsigned long)*(info->next.srt.srt)) & ~0x1);
375 c = *(info->next.srt.srt);
377 c = *(info->next.srt.srt);
379 bitmap = bitmap >> 1;
380 info->next.srt.srt++;
381 info->next.srt.srt_bitmap = bitmap;
384 bitmap = bitmap >> 1;
385 info->next.srt.srt++;
387 // bitmap is now zero...
392 nat i = info->next.large_srt.offset;
395 // Follow the pattern from GC.c:scavenge_large_srt_bitmap().
396 bitmap = info->next.large_srt.srt->l.bitmap[i / BITS_IN(W_)];
397 bitmap = bitmap >> (i % BITS_IN(StgWord));
398 while (i < info->next.large_srt.srt->l.size) {
399 if ((bitmap & 1) != 0) {
400 c = ((StgClosure **)info->next.large_srt.srt->srt)[i];
402 info->next.large_srt.offset = i;
406 if (i % BITS_IN(W_) == 0) {
407 bitmap = info->next.large_srt.srt->l.bitmap[i / BITS_IN(W_)];
409 bitmap = bitmap >> 1;
412 // reached the end of this bitmap.
413 info->next.large_srt.offset = i;
418 /* -----------------------------------------------------------------------------
419 * push() pushes a stackElement representing the next child of *c
420 * onto the traverse stack. If *c has no child, *first_child is set
421 * to NULL and nothing is pushed onto the stack. If *c has only one
422 * child, *c_chlid is set to that child and nothing is pushed onto
423 * the stack. If *c has more than two children, *first_child is set
424 * to the first child and a stackElement representing the second
425 * child is pushed onto the stack.
428 * *c_child_r is the most recent retainer of *c's children.
429 * *c is not any of TSO, AP, PAP, AP_STACK, which means that
430 * there cannot be any stack objects.
431 * Note: SRTs are considered to be children as well.
432 * -------------------------------------------------------------------------- */
434 push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
437 bdescr *nbd; // Next Block Descriptor
439 #ifdef DEBUG_RETAINER
440 // debugBelch("push(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
443 ASSERT(get_itbl(c)->type != TSO);
444 ASSERT(get_itbl(c)->type != AP_STACK);
451 se.c_child_r = c_child_r;
454 switch (get_itbl(c)->type) {
461 case SE_CAF_BLACKHOLE:
466 // one child (fixed), no SRT
469 *first_child = ((StgMutVar *)c)->var;
472 // blocking_queue must be TSO and the head of a linked list of TSOs.
473 // Shoule it be a child? Seems to be yes.
474 *first_child = (StgClosure *)((StgBlockingQueue *)c)->blocking_queue;
477 *first_child = ((StgSelector *)c)->selectee;
480 case IND_OLDGEN_PERM:
482 *first_child = ((StgIndOldGen *)c)->indirectee;
486 *first_child = c->payload[0];
489 // For CONSTR_2_0 and MVAR, we use se.info.step to record the position
490 // of the next child. We do not write a separate initialization code.
491 // Also we do not have to initialize info.type;
493 // two children (fixed), no SRT
494 // need to push a stackElement, but nothing to store in se.info
496 *first_child = c->payload[0]; // return the first pointer
497 // se.info.type = posTypeStep;
498 // se.info.next.step = 2; // 2 = second
501 // three children (fixed), no SRT
502 // need to push a stackElement
504 // head must be TSO and the head of a linked list of TSOs.
505 // Shoule it be a child? Seems to be yes.
506 *first_child = (StgClosure *)((StgMVar *)c)->head;
507 // se.info.type = posTypeStep;
508 se.info.next.step = 2; // 2 = second
511 // three children (fixed), no SRT
513 *first_child = ((StgWeak *)c)->key;
514 // se.info.type = posTypeStep;
515 se.info.next.step = 2;
518 // layout.payload.ptrs, no SRT
524 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
526 *first_child = find_ptrs(&se.info);
527 if (*first_child == NULL)
531 // StgMutArrPtr.ptrs, no SRT
533 case MUT_ARR_PTRS_FROZEN:
534 init_ptrs(&se.info, ((StgMutArrPtrs *)c)->ptrs,
535 (StgPtr)(((StgMutArrPtrs *)c)->payload));
536 *first_child = find_ptrs(&se.info);
537 if (*first_child == NULL)
541 // layout.payload.ptrs, SRT
542 case FUN: // *c is a heap object.
544 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
545 *first_child = find_ptrs(&se.info);
546 if (*first_child == NULL)
547 // no child from ptrs, so check SRT
553 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
554 *first_child = find_ptrs(&se.info);
555 if (*first_child == NULL)
556 // no child from ptrs, so check SRT
560 // 1 fixed child, SRT
563 *first_child = c->payload[0];
564 ASSERT(*first_child != NULL);
565 init_srt_fun(&se.info, get_fun_itbl(c));
570 *first_child = c->payload[0];
571 ASSERT(*first_child != NULL);
572 init_srt_thunk(&se.info, get_thunk_itbl(c));
575 case FUN_STATIC: // *c is a heap object.
576 ASSERT(get_itbl(c)->srt_bitmap != 0);
580 init_srt_fun(&se.info, get_fun_itbl(c));
581 *first_child = find_srt(&se.info);
582 if (*first_child == NULL)
588 ASSERT(get_itbl(c)->srt_bitmap != 0);
592 init_srt_thunk(&se.info, get_thunk_itbl(c));
593 *first_child = find_srt(&se.info);
594 if (*first_child == NULL)
605 case CONSTR_CHARLIKE:
606 case CONSTR_NOCAF_STATIC:
627 barf("Invalid object *c in push()");
631 if (stackTop - 1 < stackBottom) {
632 #ifdef DEBUG_RETAINER
633 // debugBelch("push() to the next stack.\n");
635 // currentStack->free is updated when the active stack is switched
636 // to the next stack.
637 currentStack->free = (StgPtr)stackTop;
639 if (currentStack->link == NULL) {
640 nbd = allocGroup(BLOCKS_IN_STACK);
642 nbd->u.back = currentStack;
643 currentStack->link = nbd;
645 nbd = currentStack->link;
650 // adjust stackTop (acutal push)
652 // If the size of stackElement was huge, we would better replace the
653 // following statement by either a memcpy() call or a switch statement
654 // on the type of the element. Currently, the size of stackElement is
655 // small enough (5 words) that this direct assignment seems to be enough.
658 #ifdef DEBUG_RETAINER
660 if (stackSize > maxStackSize) maxStackSize = stackSize;
661 // ASSERT(stackSize >= 0);
662 // debugBelch("stackSize = %d\n", stackSize);
666 /* -----------------------------------------------------------------------------
667 * popOff() and popOffReal(): Pop a stackElement off the traverse stack.
669 * stackTop cannot be equal to stackLimit unless the whole stack is
670 * empty, in which case popOff() is not allowed.
672 * You can think of popOffReal() as a part of popOff() which is
673 * executed at the end of popOff() in necessary. Since popOff() is
674 * likely to be executed quite often while popOffReal() is not, we
675 * separate popOffReal() from popOff(), which is declared as an
676 * INLINE function (for the sake of execution speed). popOffReal()
677 * is called only within popOff() and nowhere else.
678 * -------------------------------------------------------------------------- */
682 bdescr *pbd; // Previous Block Descriptor
684 #ifdef DEBUG_RETAINER
685 // debugBelch("pop() to the previous stack.\n");
688 ASSERT(stackTop + 1 == stackLimit);
689 ASSERT(stackBottom == (stackElement *)currentStack->start);
691 if (firstStack == currentStack) {
692 // The stack is completely empty.
694 ASSERT(stackTop == stackLimit);
695 #ifdef DEBUG_RETAINER
697 if (stackSize > maxStackSize) maxStackSize = stackSize;
699 ASSERT(stackSize >= 0);
700 debugBelch("stackSize = %d\n", stackSize);
706 // currentStack->free is updated when the active stack is switched back
707 // to the previous stack.
708 currentStack->free = (StgPtr)stackLimit;
710 // find the previous block descriptor
711 pbd = currentStack->u.back;
714 returnToOldStack(pbd);
716 #ifdef DEBUG_RETAINER
718 if (stackSize > maxStackSize) maxStackSize = stackSize;
720 ASSERT(stackSize >= 0);
721 debugBelch("stackSize = %d\n", stackSize);
728 #ifdef DEBUG_RETAINER
729 // debugBelch("\tpopOff(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
732 ASSERT(stackTop != stackLimit);
733 ASSERT(!isEmptyRetainerStack());
735 // <= (instead of <) is wrong!
736 if (stackTop + 1 < stackLimit) {
738 #ifdef DEBUG_RETAINER
740 if (stackSize > maxStackSize) maxStackSize = stackSize;
742 ASSERT(stackSize >= 0);
743 debugBelch("stackSize = %d\n", stackSize);
752 /* -----------------------------------------------------------------------------
753 * Finds the next object to be considered for retainer profiling and store
755 * Test if the topmost stack element indicates that more objects are left,
756 * and if so, retrieve the first object and store its pointer to *c. Also,
757 * set *cp and *r appropriately, both of which are stored in the stack element.
758 * The topmost stack element then is overwritten so as for it to now denote
760 * If the topmost stack element indicates no more objects are left, pop
761 * off the stack element until either an object can be retrieved or
762 * the current stack chunk becomes empty, indicated by rtsTrue returned by
763 * isOnBoundary(), in which case *c is set to NULL.
765 * It is okay to call this function even when the current stack chunk
767 * -------------------------------------------------------------------------- */
769 pop( StgClosure **c, StgClosure **cp, retainer *r )
773 #ifdef DEBUG_RETAINER
774 // debugBelch("pop(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
778 if (isOnBoundary()) { // if the current stack chunk is depleted
785 switch (get_itbl(se->c)->type) {
786 // two children (fixed), no SRT
787 // nothing in se.info
789 *c = se->c->payload[1];
795 // three children (fixed), no SRT
796 // need to push a stackElement
798 if (se->info.next.step == 2) {
799 *c = (StgClosure *)((StgMVar *)se->c)->tail;
800 se->info.next.step++; // move to the next step
803 *c = ((StgMVar *)se->c)->value;
810 // three children (fixed), no SRT
812 if (se->info.next.step == 2) {
813 *c = ((StgWeak *)se->c)->value;
814 se->info.next.step++;
817 *c = ((StgWeak *)se->c)->finalizer;
829 // StgMutArrPtr.ptrs, no SRT
831 case MUT_ARR_PTRS_FROZEN:
832 *c = find_ptrs(&se->info);
841 // layout.payload.ptrs, SRT
842 case FUN: // always a heap object
844 if (se->info.type == posTypePtrs) {
845 *c = find_ptrs(&se->info);
851 init_srt_fun(&se->info, get_fun_itbl(se->c));
857 if (se->info.type == posTypePtrs) {
858 *c = find_ptrs(&se->info);
864 init_srt_thunk(&se->info, get_thunk_itbl(se->c));
880 *c = find_srt(&se->info);
889 // no child (fixed), no SRT
895 case SE_CAF_BLACKHOLE:
897 // one child (fixed), no SRT
903 case IND_OLDGEN_PERM:
913 case CONSTR_CHARLIKE:
914 case CONSTR_NOCAF_STATIC:
935 barf("Invalid object *c in pop()");
941 /* -----------------------------------------------------------------------------
942 * RETAINER PROFILING ENGINE
943 * -------------------------------------------------------------------------- */
946 initRetainerProfiling( void )
948 initializeAllRetainerSet();
949 retainerGeneration = 0;
952 /* -----------------------------------------------------------------------------
953 * This function must be called before f-closing prof_file.
954 * -------------------------------------------------------------------------- */
956 endRetainerProfiling( void )
958 #ifdef SECOND_APPROACH
959 outputAllRetainerSet(prof_file);
963 /* -----------------------------------------------------------------------------
964 * Returns the actual pointer to the retainer set of the closure *c.
965 * It may adjust RSET(c) subject to flip.
967 * RSET(c) is initialized to NULL if its current value does not
970 * Even though this function has side effects, they CAN be ignored because
971 * subsequent calls to retainerSetOf() always result in the same return value
972 * and retainerSetOf() is the only way to retrieve retainerSet of a given
974 * We have to perform an XOR (^) operation each time a closure is examined.
975 * The reason is that we do not know when a closure is visited last.
976 * -------------------------------------------------------------------------- */
978 maybeInitRetainerSet( StgClosure *c )
980 if (!isRetainerSetFieldValid(c)) {
981 setRetainerSetToNull(c);
985 /* -----------------------------------------------------------------------------
986 * Returns rtsTrue if *c is a retainer.
987 * -------------------------------------------------------------------------- */
988 static INLINE rtsBool
989 isRetainer( StgClosure *c )
991 switch (get_itbl(c)->type) {
995 // TSOs MUST be retainers: they constitute the set of roots.
1003 case MUT_ARR_PTRS_FROZEN:
1005 // thunks are retainers.
1012 case THUNK_SELECTOR:
1016 // Static thunks, or CAFS, are obviously retainers.
1019 // WEAK objects are roots; there is separate code in which traversing
1020 // begins from WEAK objects.
1042 // partial applications
1048 case SE_CAF_BLACKHOLE:
1052 case IND_OLDGEN_PERM:
1067 // IND_STATIC cannot be *c, *cp, *r in the retainer profiling loop.
1069 // CONSTR_INTLIKE, CONSTR_CHARLIKE, and CONSTR_NOCAF_STATIC
1070 // cannot be *c, *cp, *r in the retainer profiling loop.
1071 case CONSTR_INTLIKE:
1072 case CONSTR_CHARLIKE:
1073 case CONSTR_NOCAF_STATIC:
1074 // Stack objects are invalid because they are never treated as
1075 // legal objects during retainer profiling.
1093 case INVALID_OBJECT:
1095 barf("Invalid object in isRetainer(): %d", get_itbl(c)->type);
1100 /* -----------------------------------------------------------------------------
1101 * Returns the retainer function value for the closure *c, i.e., R(*c).
1102 * This function does NOT return the retainer(s) of *c.
1104 * *c must be a retainer.
1106 * Depending on the definition of this function, the maintenance of retainer
1107 * sets can be made easier. If most retainer sets are likely to be created
1108 * again across garbage collections, refreshAllRetainerSet() in
1109 * RetainerSet.c can simply do nothing.
1110 * If this is not the case, we can free all the retainer sets and
1111 * re-initialize the hash table.
1112 * See refreshAllRetainerSet() in RetainerSet.c.
1113 * -------------------------------------------------------------------------- */
1114 static INLINE retainer
1115 getRetainerFrom( StgClosure *c )
1117 ASSERT(isRetainer(c));
1119 #if defined(RETAINER_SCHEME_INFO)
1120 // Retainer scheme 1: retainer = info table
1122 #elif defined(RETAINER_SCHEME_CCS)
1123 // Retainer scheme 2: retainer = cost centre stack
1124 return c->header.prof.ccs;
1125 #elif defined(RETAINER_SCHEME_CC)
1126 // Retainer scheme 3: retainer = cost centre
1127 return c->header.prof.ccs->cc;
1131 /* -----------------------------------------------------------------------------
1132 * Associates the retainer set *s with the closure *c, that is, *s becomes
1133 * the retainer set of *c.
1137 * -------------------------------------------------------------------------- */
1139 associate( StgClosure *c, RetainerSet *s )
1141 // StgWord has the same size as pointers, so the following type
1143 RSET(c) = (RetainerSet *)((StgWord)s | flip);
1146 /* -----------------------------------------------------------------------------
1147 Call retainClosure for each of the closures covered by a large bitmap.
1148 -------------------------------------------------------------------------- */
1151 retain_large_bitmap (StgPtr p, StgLargeBitmap *large_bitmap, nat size,
1152 StgClosure *c, retainer c_child_r)
1158 bitmap = large_bitmap->bitmap[b];
1159 for (i = 0; i < size; ) {
1160 if ((bitmap & 1) == 0) {
1161 retainClosure((StgClosure *)*p, c, c_child_r);
1165 if (i % BITS_IN(W_) == 0) {
1167 bitmap = large_bitmap->bitmap[b];
1169 bitmap = bitmap >> 1;
1174 static INLINE StgPtr
1175 retain_small_bitmap (StgPtr p, nat size, StgWord bitmap,
1176 StgClosure *c, retainer c_child_r)
1179 if ((bitmap & 1) == 0) {
1180 retainClosure((StgClosure *)*p, c, c_child_r);
1183 bitmap = bitmap >> 1;
1189 /* -----------------------------------------------------------------------------
1190 * Call retainClosure for each of the closures in an SRT.
1191 * ------------------------------------------------------------------------- */
1194 retain_large_srt_bitmap (StgLargeSRT *srt, StgClosure *c, retainer c_child_r)
1201 p = (StgClosure **)srt->srt;
1203 bitmap = srt->l.bitmap[b];
1204 for (i = 0; i < size; ) {
1205 if ((bitmap & 1) != 0) {
1206 retainClosure((StgClosure *)*p, c, c_child_r);
1210 if (i % BITS_IN(W_) == 0) {
1212 bitmap = srt->l.bitmap[b];
1214 bitmap = bitmap >> 1;
1220 retainSRT (StgClosure **srt, nat srt_bitmap, StgClosure *c, retainer c_child_r)
1225 bitmap = srt_bitmap;
1228 if (bitmap == (StgHalfWord)(-1)) {
1229 retain_large_srt_bitmap( (StgLargeSRT *)srt, c, c_child_r );
1233 while (bitmap != 0) {
1234 if ((bitmap & 1) != 0) {
1235 #ifdef ENABLE_WIN32_DLL_SUPPORT
1236 if ( (unsigned long)(*srt) & 0x1 ) {
1237 retainClosure(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)),
1240 retainClosure(*srt,c,c_child_r);
1243 retainClosure(*srt,c,c_child_r);
1247 bitmap = bitmap >> 1;
1251 /* -----------------------------------------------------------------------------
1252 * Process all the objects in the stack chunk from stackStart to stackEnd
1253 * with *c and *c_child_r being their parent and their most recent retainer,
1254 * respectively. Treat stackOptionalFun as another child of *c if it is
1257 * *c is one of the following: TSO, AP_STACK.
1258 * If *c is TSO, c == c_child_r.
1259 * stackStart < stackEnd.
1260 * RSET(c) and RSET(c_child_r) are valid, i.e., their
1261 * interpretation conforms to the current value of flip (even when they
1262 * are interpreted to be NULL).
1263 * If *c is TSO, its state is not any of ThreadRelocated, ThreadComplete,
1264 * or ThreadKilled, which means that its stack is ready to process.
1266 * This code was almost plagiarzied from GC.c! For each pointer,
1267 * retainClosure() is invoked instead of evacuate().
1268 * -------------------------------------------------------------------------- */
1270 retainStack( StgClosure *c, retainer c_child_r,
1271 StgPtr stackStart, StgPtr stackEnd )
1273 stackElement *oldStackBoundary;
1275 StgRetInfoTable *info;
1279 #ifdef DEBUG_RETAINER
1281 if (cStackSize > maxCStackSize) maxCStackSize = cStackSize;
1285 Each invocation of retainStack() creates a new virtual
1286 stack. Since all such stacks share a single common stack, we
1287 record the current currentStackBoundary, which will be restored
1290 oldStackBoundary = currentStackBoundary;
1291 currentStackBoundary = stackTop;
1293 #ifdef DEBUG_RETAINER
1294 // debugBelch("retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
1297 ASSERT(get_itbl(c)->type != TSO ||
1298 (((StgTSO *)c)->what_next != ThreadRelocated &&
1299 ((StgTSO *)c)->what_next != ThreadComplete &&
1300 ((StgTSO *)c)->what_next != ThreadKilled));
1303 while (p < stackEnd) {
1304 info = get_ret_itbl((StgClosure *)p);
1306 switch(info->i.type) {
1309 retainClosure(((StgUpdateFrame *)p)->updatee, c, c_child_r);
1310 p += sizeofW(StgUpdateFrame);
1317 bitmap = BITMAP_BITS(info->i.layout.bitmap);
1318 size = BITMAP_SIZE(info->i.layout.bitmap);
1320 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1323 retainSRT((StgClosure **)info->srt, info->i.srt_bitmap, c, c_child_r);
1330 retainClosure((StgClosure *)*p, c, c_child_r);
1333 size = BCO_BITMAP_SIZE(bco);
1334 retain_large_bitmap(p, BCO_BITMAP(bco), size, c, c_child_r);
1339 // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
1342 size = info->i.layout.large_bitmap->size;
1344 retain_large_bitmap(p, info->i.layout.large_bitmap,
1345 size, c, c_child_r);
1347 // and don't forget to follow the SRT
1350 // Dynamic bitmap: the mask is stored on the stack
1353 dyn = ((StgRetDyn *)p)->liveness;
1355 // traverse the bitmap first
1356 bitmap = RET_DYN_LIVENESS(dyn);
1357 p = (P_)&((StgRetDyn *)p)->payload[0];
1358 size = RET_DYN_BITMAP_SIZE;
1359 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1361 // skip over the non-ptr words
1362 p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
1364 // follow the ptr words
1365 for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
1366 retainClosure((StgClosure *)*p, c, c_child_r);
1373 StgRetFun *ret_fun = (StgRetFun *)p;
1374 StgFunInfoTable *fun_info;
1376 retainClosure(ret_fun->fun, c, c_child_r);
1377 fun_info = get_fun_itbl(ret_fun->fun);
1379 p = (P_)&ret_fun->payload;
1380 switch (fun_info->f.fun_type) {
1382 bitmap = BITMAP_BITS(fun_info->f.bitmap);
1383 size = BITMAP_SIZE(fun_info->f.bitmap);
1384 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1387 size = ((StgLargeBitmap *)fun_info->f.bitmap)->size;
1388 retain_large_bitmap(p, (StgLargeBitmap *)fun_info->f.bitmap,
1389 size, c, c_child_r);
1393 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1394 size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
1395 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1402 barf("Invalid object found in retainStack(): %d",
1403 (int)(info->i.type));
1407 // restore currentStackBoundary
1408 currentStackBoundary = oldStackBoundary;
1409 #ifdef DEBUG_RETAINER
1410 // debugBelch("retainStack() finished: currentStackBoundary = 0x%x\n", currentStackBoundary);
1413 #ifdef DEBUG_RETAINER
1418 /* ----------------------------------------------------------------------------
1419 * Call retainClosure for each of the children of a PAP/AP
1420 * ------------------------------------------------------------------------- */
1422 static INLINE StgPtr
1423 retain_PAP (StgPAP *pap, retainer c_child_r)
1426 StgWord bitmap, size;
1427 StgFunInfoTable *fun_info;
1429 retainClosure(pap->fun, (StgClosure *)pap, c_child_r);
1430 fun_info = get_fun_itbl(pap->fun);
1431 ASSERT(fun_info->i.type != PAP);
1433 p = (StgPtr)pap->payload;
1436 switch (fun_info->f.fun_type) {
1438 bitmap = BITMAP_BITS(fun_info->f.bitmap);
1439 p = retain_small_bitmap(p, pap->n_args, bitmap,
1440 (StgClosure *)pap, c_child_r);
1443 retain_large_bitmap(p, (StgLargeBitmap *)fun_info->f.bitmap,
1444 size, (StgClosure *)pap, c_child_r);
1448 retain_large_bitmap((StgPtr)pap->payload, BCO_BITMAP(pap->fun),
1449 size, (StgClosure *)pap, c_child_r);
1453 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1454 p = retain_small_bitmap(p, pap->n_args, bitmap,
1455 (StgClosure *)pap, c_child_r);
1461 /* -----------------------------------------------------------------------------
1462 * Compute the retainer set of *c0 and all its desecents by traversing.
1463 * *cp0 is the parent of *c0, and *r0 is the most recent retainer of *c0.
1465 * c0 = cp0 = r0 holds only for root objects.
1466 * RSET(cp0) and RSET(r0) are valid, i.e., their
1467 * interpretation conforms to the current value of flip (even when they
1468 * are interpreted to be NULL).
1469 * However, RSET(c0) may be corrupt, i.e., it may not conform to
1470 * the current value of flip. If it does not, during the execution
1471 * of this function, RSET(c0) must be initialized as well as all
1474 * stackTop must be the same at the beginning and the exit of this function.
1475 * *c0 can be TSO (as well as AP_STACK).
1476 * -------------------------------------------------------------------------- */
1478 retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
1480 // c = Current closure
1481 // cp = Current closure's Parent
1482 // r = current closures' most recent Retainer
1483 // c_child_r = current closure's children's most recent retainer
1484 // first_child = first child of c
1485 StgClosure *c, *cp, *first_child;
1486 RetainerSet *s, *retainerSetOfc;
1487 retainer r, c_child_r;
1490 #ifdef DEBUG_RETAINER
1491 // StgPtr oldStackTop;
1494 #ifdef DEBUG_RETAINER
1495 // oldStackTop = stackTop;
1496 // debugBelch("retainClosure() called: c0 = 0x%x, cp0 = 0x%x, r0 = 0x%x\n", c0, cp0, r0);
1499 // (c, cp, r) = (c0, cp0, r0)
1506 //debugBelch("loop");
1507 // pop to (c, cp, r);
1511 #ifdef DEBUG_RETAINER
1512 // debugBelch("retainClosure() ends: oldStackTop = 0x%x, stackTop = 0x%x\n", oldStackTop, stackTop);
1517 //debugBelch("inner_loop");
1520 // c = current closure under consideration,
1521 // cp = current closure's parent,
1522 // r = current closure's most recent retainer
1524 // Loop invariants (on the meaning of c, cp, r, and their retainer sets):
1525 // RSET(cp) and RSET(r) are valid.
1526 // RSET(c) is valid only if c has been visited before.
1528 // Loop invariants (on the relation between c, cp, and r)
1529 // if cp is not a retainer, r belongs to RSET(cp).
1530 // if cp is a retainer, r == cp.
1532 typeOfc = get_itbl(c)->type;
1534 #ifdef DEBUG_RETAINER
1537 case CONSTR_INTLIKE:
1538 case CONSTR_CHARLIKE:
1539 case CONSTR_NOCAF_STATIC:
1545 if (retainerSetOf(c) == NULL) { // first visit?
1546 costArray[typeOfc] += cost(c);
1547 sumOfNewCost += cost(c);
1556 if (((StgTSO *)c)->what_next == ThreadComplete ||
1557 ((StgTSO *)c)->what_next == ThreadKilled) {
1558 #ifdef DEBUG_RETAINER
1559 debugBelch("ThreadComplete or ThreadKilled encountered in retainClosure()\n");
1563 if (((StgTSO *)c)->what_next == ThreadRelocated) {
1564 #ifdef DEBUG_RETAINER
1565 debugBelch("ThreadRelocated encountered in retainClosure()\n");
1567 c = (StgClosure *)((StgTSO *)c)->link;
1573 // We just skip IND_STATIC, so its retainer set is never computed.
1574 c = ((StgIndStatic *)c)->indirectee;
1576 case CONSTR_INTLIKE:
1577 case CONSTR_CHARLIKE:
1578 // static objects with no pointers out, so goto loop.
1579 case CONSTR_NOCAF_STATIC:
1580 // It is not just enough not to compute the retainer set for *c; it is
1581 // mandatory because CONSTR_NOCAF_STATIC are not reachable from
1582 // scavenged_static_objects, the list from which is assumed to traverse
1583 // all static objects after major garbage collections.
1587 if (get_itbl(c)->srt_bitmap == 0) {
1588 // No need to compute the retainer set; no dynamic objects
1589 // are reachable from *c.
1591 // Static objects: if we traverse all the live closures,
1592 // including static closures, during each heap census then
1593 // we will observe that some static closures appear and
1594 // disappear. eg. a closure may contain a pointer to a
1595 // static function 'f' which is not otherwise reachable
1596 // (it doesn't indirectly point to any CAFs, so it doesn't
1597 // appear in any SRTs), so we would find 'f' during
1598 // traversal. However on the next sweep there may be no
1599 // closures pointing to 'f'.
1601 // We must therefore ignore static closures whose SRT is
1602 // empty, because these are exactly the closures that may
1603 // "appear". A closure with a non-empty SRT, and which is
1604 // still required, will always be reachable.
1606 // But what about CONSTR_STATIC? Surely these may be able
1607 // to appear, and they don't have SRTs, so we can't
1608 // check. So for now, we're calling
1609 // resetStaticObjectForRetainerProfiling() from the
1610 // garbage collector to reset the retainer sets in all the
1611 // reachable static objects.
1618 // The above objects are ignored in computing the average number of times
1619 // an object is visited.
1620 timesAnyObjectVisited++;
1622 // If this is the first visit to c, initialize its retainer set.
1623 maybeInitRetainerSet(c);
1624 retainerSetOfc = retainerSetOf(c);
1627 // isRetainer(cp) == rtsTrue => s == NULL
1628 // isRetainer(cp) == rtsFalse => s == cp.retainer
1632 s = retainerSetOf(cp);
1634 // (c, cp, r, s) is available.
1636 // (c, cp, r, s, R_r) is available, so compute the retainer set for *c.
1637 if (retainerSetOfc == NULL) {
1638 // This is the first visit to *c.
1642 associate(c, singleton(r));
1644 // s is actually the retainer set of *c!
1647 // compute c_child_r
1648 c_child_r = isRetainer(c) ? getRetainerFrom(c) : r;
1650 // This is not the first visit to *c.
1651 if (isMember(r, retainerSetOfc))
1652 goto loop; // no need to process child
1655 associate(c, addElement(r, retainerSetOfc));
1657 // s is not NULL and cp is not a retainer. This means that
1658 // each time *cp is visited, so is *c. Thus, if s has
1659 // exactly one more element in its retainer set than c, s
1660 // is also the new retainer set for *c.
1661 if (s->num == retainerSetOfc->num + 1) {
1664 // Otherwise, just add R_r to the current retainer set of *c.
1666 associate(c, addElement(r, retainerSetOfc));
1671 goto loop; // no need to process child
1673 // compute c_child_r
1677 // now, RSET() of all of *c, *cp, and *r is valid.
1678 // (c, c_child_r) are available.
1682 // Special case closures: we process these all in one go rather
1683 // than attempting to save the current position, because doing so
1687 retainStack(c, c_child_r,
1689 ((StgTSO *)c)->stack + ((StgTSO *)c)->stack_size);
1694 retain_PAP((StgPAP *)c, c_child_r);
1698 retainClosure(((StgAP_STACK *)c)->fun, c, c_child_r);
1699 retainStack(c, c_child_r,
1700 (StgPtr)((StgAP_STACK *)c)->payload,
1701 (StgPtr)((StgAP_STACK *)c)->payload +
1702 ((StgAP_STACK *)c)->size);
1706 push(c, c_child_r, &first_child);
1708 // If first_child is null, c has no child.
1709 // If first_child is not null, the top stack element points to the next
1710 // object. push() may or may not push a stackElement on the stack.
1711 if (first_child == NULL)
1714 // (c, cp, r) = (first_child, c, c_child_r)
1721 /* -----------------------------------------------------------------------------
1722 * Compute the retainer set for every object reachable from *tl.
1723 * -------------------------------------------------------------------------- */
1725 retainRoot( StgClosure **tl )
1727 // We no longer assume that only TSOs and WEAKs are roots; any closure can
1730 ASSERT(isEmptyRetainerStack());
1731 currentStackBoundary = stackTop;
1733 if (isRetainer(*tl)) {
1734 retainClosure(*tl, *tl, getRetainerFrom(*tl));
1736 retainClosure(*tl, *tl, CCS_SYSTEM);
1739 // NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl)));
1740 // *tl might be a TSO which is ThreadComplete, in which
1741 // case we ignore it for the purposes of retainer profiling.
1744 /* -----------------------------------------------------------------------------
1745 * Compute the retainer set for each of the objects in the heap.
1746 * -------------------------------------------------------------------------- */
1748 computeRetainerSet( void )
1754 #ifdef DEBUG_RETAINER
1755 RetainerSet tmpRetainerSet;
1758 GetRoots(retainRoot); // for scheduler roots
1760 // This function is called after a major GC, when key, value, and finalizer
1761 // all are guaranteed to be valid, or reachable.
1763 // The following code assumes that WEAK objects are considered to be roots
1764 // for retainer profilng.
1765 for (weak = weak_ptr_list; weak != NULL; weak = weak->link)
1766 // retainRoot((StgClosure *)weak);
1767 retainRoot((StgClosure **)&weak);
1769 // Consider roots from the stable ptr table.
1770 markStablePtrTable(retainRoot);
1772 // The following code resets the rs field of each unvisited mutable
1773 // object (computing sumOfNewCostExtra and updating costArray[] when
1774 // debugging retainer profiler).
1775 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1777 (generations[g].mut_list == END_MUT_LIST &&
1778 generations[g].mut_once_list == END_MUT_LIST));
1781 // I think traversing through mut_list is unnecessary.
1782 // Think about removing this part.
1783 for (ml = generations[g].mut_list; ml != END_MUT_LIST;
1784 ml = ml->mut_link) {
1786 maybeInitRetainerSet((StgClosure *)ml);
1787 rtl = retainerSetOf((StgClosure *)ml);
1789 #ifdef DEBUG_RETAINER
1791 // first visit to *ml
1792 // This is a violation of the interface rule!
1793 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1795 switch (get_itbl((StgClosure *)ml)->type) {
1799 case CONSTR_INTLIKE:
1800 case CONSTR_CHARLIKE:
1801 case CONSTR_NOCAF_STATIC:
1805 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1809 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1810 sumOfNewCostExtra += cost((StgClosure *)ml);
1817 // Traversing through mut_once_list is, in contrast, necessary
1818 // because we can find MUT_VAR objects which have not been
1819 // visited during retainer profiling.
1820 for (ml = generations[g].mut_once_list; ml != END_MUT_LIST;
1821 ml = ml->mut_link) {
1823 maybeInitRetainerSet((StgClosure *)ml);
1824 rtl = retainerSetOf((StgClosure *)ml);
1825 #ifdef DEBUG_RETAINER
1827 // first visit to *ml
1828 // This is a violation of the interface rule!
1829 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1831 switch (get_itbl((StgClosure *)ml)->type) {
1835 case CONSTR_INTLIKE:
1836 case CONSTR_CHARLIKE:
1837 case CONSTR_NOCAF_STATIC:
1841 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1845 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1846 sumOfNewCostExtra += cost((StgClosure *)ml);
1855 /* -----------------------------------------------------------------------------
1856 * Traverse all static objects for which we compute retainer sets,
1857 * and reset their rs fields to NULL, which is accomplished by
1858 * invoking maybeInitRetainerSet(). This function must be called
1859 * before zeroing all objects reachable from scavenged_static_objects
1860 * in the case of major gabage collections. See GarbageCollect() in
1863 * The mut_once_list of the oldest generation must also be traversed?
1864 * Why? Because if the evacuation of an object pointed to by a static
1865 * indirection object fails, it is put back to the mut_once_list of
1866 * the oldest generation.
1867 * However, this is not necessary because any static indirection objects
1868 * are just traversed through to reach dynamic objects. In other words,
1869 * they are not taken into consideration in computing retainer sets.
1870 * -------------------------------------------------------------------------- */
1872 resetStaticObjectForRetainerProfiling( void )
1874 #ifdef DEBUG_RETAINER
1879 #ifdef DEBUG_RETAINER
1882 p = scavenged_static_objects;
1883 while (p != END_OF_STATIC_LIST) {
1884 #ifdef DEBUG_RETAINER
1887 switch (get_itbl(p)->type) {
1889 // Since we do not compute the retainer set of any
1890 // IND_STATIC object, we don't have to reset its retainer
1892 p = IND_STATIC_LINK(p);
1895 maybeInitRetainerSet(p);
1896 p = THUNK_STATIC_LINK(p);
1899 maybeInitRetainerSet(p);
1900 p = FUN_STATIC_LINK(p);
1903 maybeInitRetainerSet(p);
1904 p = STATIC_LINK(get_itbl(p), p);
1907 barf("resetStaticObjectForRetainerProfiling: %p (%s)",
1908 p, get_itbl(p)->type);
1912 #ifdef DEBUG_RETAINER
1913 // debugBelch("count in scavenged_static_objects = %d\n", count);
1917 /* -----------------------------------------------------------------------------
1918 * Perform retainer profiling.
1919 * N is the oldest generation being profilied, where the generations are
1920 * numbered starting at 0.
1923 * This function should be called only immediately after major garbage
1925 * ------------------------------------------------------------------------- */
1927 retainerProfile(void)
1929 #ifdef DEBUG_RETAINER
1931 nat totalHeapSize; // total raw heap size (computed by linear scanning)
1934 #ifdef DEBUG_RETAINER
1935 debugBelch(" < retainerProfile() invoked : %d>\n", retainerGeneration);
1940 // We haven't flipped the bit yet.
1941 #ifdef DEBUG_RETAINER
1942 debugBelch("Before traversing:\n");
1943 sumOfCostLinear = 0;
1944 for (i = 0;i < N_CLOSURE_TYPES; i++)
1945 costArrayLinear[i] = 0;
1946 totalHeapSize = checkHeapSanityForRetainerProfiling();
1948 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1950 debugBelch("costArrayLinear[] = ");
1951 for (i = 0;i < N_CLOSURE_TYPES; i++)
1952 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
1956 ASSERT(sumOfCostLinear == totalHeapSize);
1959 #define pcostArrayLinear(index) \
1960 if (costArrayLinear[index] > 0) \
1961 debugBelch("costArrayLinear[" #index "] = %u\n", costArrayLinear[index])
1962 pcostArrayLinear(THUNK_STATIC);
1963 pcostArrayLinear(FUN_STATIC);
1964 pcostArrayLinear(CONSTR_STATIC);
1965 pcostArrayLinear(CONSTR_NOCAF_STATIC);
1966 pcostArrayLinear(CONSTR_INTLIKE);
1967 pcostArrayLinear(CONSTR_CHARLIKE);
1971 // Now we flips flip.
1974 #ifdef DEBUG_RETAINER
1980 numObjectVisited = 0;
1981 timesAnyObjectVisited = 0;
1983 #ifdef DEBUG_RETAINER
1984 debugBelch("During traversing:\n");
1986 sumOfNewCostExtra = 0;
1987 for (i = 0;i < N_CLOSURE_TYPES; i++)
1992 We initialize the traverse stack each time the retainer profiling is
1993 performed (because the traverse stack size varies on each retainer profiling
1994 and this operation is not costly anyhow). However, we just refresh the
1997 initializeTraverseStack();
1998 #ifdef DEBUG_RETAINER
1999 initializeAllRetainerSet();
2001 refreshAllRetainerSet();
2003 computeRetainerSet();
2005 #ifdef DEBUG_RETAINER
2006 debugBelch("After traversing:\n");
2007 sumOfCostLinear = 0;
2008 for (i = 0;i < N_CLOSURE_TYPES; i++)
2009 costArrayLinear[i] = 0;
2010 totalHeapSize = checkHeapSanityForRetainerProfiling();
2012 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
2013 ASSERT(sumOfCostLinear == totalHeapSize);
2015 // now, compare the two results
2018 costArray[] must be exactly the same as costArrayLinear[].
2020 1) Dead weak pointers, whose type is CONSTR. These objects are not
2021 reachable from any roots.
2023 debugBelch("Comparison:\n");
2024 debugBelch("\tcostArrayLinear[] (must be empty) = ");
2025 for (i = 0;i < N_CLOSURE_TYPES; i++)
2026 if (costArray[i] != costArrayLinear[i])
2027 // nothing should be printed except MUT_VAR after major GCs
2028 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
2031 debugBelch("\tsumOfNewCost = %u\n", sumOfNewCost);
2032 debugBelch("\tsumOfNewCostExtra = %u\n", sumOfNewCostExtra);
2033 debugBelch("\tcostArray[] (must be empty) = ");
2034 for (i = 0;i < N_CLOSURE_TYPES; i++)
2035 if (costArray[i] != costArrayLinear[i])
2036 // nothing should be printed except MUT_VAR after major GCs
2037 debugBelch("[%u:%u] ", i, costArray[i]);
2040 // only for major garbage collection
2041 ASSERT(sumOfNewCost + sumOfNewCostExtra == sumOfCostLinear);
2045 closeTraverseStack();
2046 #ifdef DEBUG_RETAINER
2047 closeAllRetainerSet();
2049 // Note that there is no post-processing for the retainer sets.
2051 retainerGeneration++;
2054 retainerGeneration - 1, // retainerGeneration has just been incremented!
2055 #ifdef DEBUG_RETAINER
2056 maxCStackSize, maxStackSize,
2058 (double)timesAnyObjectVisited / numObjectVisited);
2061 /* -----------------------------------------------------------------------------
2063 * -------------------------------------------------------------------------- */
2065 #ifdef DEBUG_RETAINER
2067 #define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
2068 ((HEAP_ALLOCED(r) && Bdescr((P_)r)->free != (void *)-1))) && \
2069 ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa))
2072 sanityCheckHeapClosure( StgClosure *c )
2076 ASSERT(LOOKS_LIKE_GHC_INFO(c->header.info));
2077 ASSERT(!closure_STATIC(c));
2078 ASSERT(LOOKS_LIKE_PTR(c));
2080 if ((((StgWord)RSET(c) & 1) ^ flip) != 0) {
2081 if (get_itbl(c)->type == CONSTR &&
2082 !strcmp(get_itbl(c)->prof.closure_type, "DEAD_WEAK") &&
2083 !strcmp(get_itbl(c)->prof.closure_desc, "DEAD_WEAK")) {
2084 debugBelch("\tUnvisited dead weak pointer object found: c = %p\n", c);
2085 costArray[get_itbl(c)->type] += cost(c);
2086 sumOfNewCost += cost(c);
2089 "Unvisited object: flip = %d, c = %p(%d, %s, %s), rs = %p\n",
2090 flip, c, get_itbl(c)->type,
2091 get_itbl(c)->prof.closure_type, get_itbl(c)->prof.closure_desc,
2094 // debugBelch("sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c));
2098 switch (info->type) {
2100 return tso_sizeW((StgTSO *)c);
2108 return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE);
2111 return sizeofW(StgMVar);
2114 case MUT_ARR_PTRS_FROZEN:
2115 return mut_arr_ptrs_sizeW((StgMutArrPtrs *)c);
2119 return pap_sizeW((StgPAP *)c);
2122 return ap_stack_sizeW((StgAP_STACK *)c);
2125 return arr_words_sizeW((StgArrWords *)c);
2145 case SE_CAF_BLACKHOLE:
2149 case IND_OLDGEN_PERM:
2153 return sizeW_fromITBL(info);
2155 case THUNK_SELECTOR:
2156 return sizeofW(StgHeader) + MIN_UPD_SIZE;
2165 case CONSTR_INTLIKE:
2166 case CONSTR_CHARLIKE:
2167 case CONSTR_NOCAF_STATIC:
2184 case INVALID_OBJECT:
2186 barf("Invalid object in sanityCheckHeapClosure(): %d",
2193 heapCheck( bdescr *bd )
2196 static nat costSum, size;
2199 while (bd != NULL) {
2201 while (p < bd->free) {
2202 size = sanityCheckHeapClosure((StgClosure *)p);
2203 sumOfCostLinear += size;
2204 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2206 // no need for slop check; I think slops are not used currently.
2208 ASSERT(p == bd->free);
2209 costSum += bd->free - bd->start;
2217 smallObjectPoolCheck(void)
2221 static nat costSum, size;
2223 bd = small_alloc_list;
2231 while (p < alloc_Hp) {
2232 size = sanityCheckHeapClosure((StgClosure *)p);
2233 sumOfCostLinear += size;
2234 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2237 ASSERT(p == alloc_Hp);
2238 costSum += alloc_Hp - bd->start;
2241 while (bd != NULL) {
2243 while (p < bd->free) {
2244 size = sanityCheckHeapClosure((StgClosure *)p);
2245 sumOfCostLinear += size;
2246 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2249 ASSERT(p == bd->free);
2250 costSum += bd->free - bd->start;
2258 chainCheck(bdescr *bd)
2263 while (bd != NULL) {
2264 // bd->free - bd->start is not an accurate measurement of the
2265 // object size. Actually it is always zero, so we compute its
2267 size = sanityCheckHeapClosure((StgClosure *)bd->start);
2268 sumOfCostLinear += size;
2269 costArrayLinear[get_itbl((StgClosure *)bd->start)->type] += size;
2278 checkHeapSanityForRetainerProfiling( void )
2283 debugBelch("START: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2284 if (RtsFlags.GcFlags.generations == 1) {
2285 costSum += heapCheck(g0s0->to_blocks);
2286 debugBelch("heapCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2287 costSum += chainCheck(g0s0->large_objects);
2288 debugBelch("chainCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2290 for (g = 0; g < RtsFlags.GcFlags.generations; g++)
2291 for (s = 0; s < generations[g].n_steps; s++) {
2293 After all live objects have been scavenged, the garbage
2294 collector may create some objects in
2295 scheduleFinalizers(). These objects are created throught
2296 allocate(), so the small object pool or the large object
2297 pool of the g0s0 may not be empty.
2299 if (g == 0 && s == 0) {
2300 costSum += smallObjectPoolCheck();
2301 debugBelch("smallObjectPoolCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2302 costSum += chainCheck(generations[g].steps[s].large_objects);
2303 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2305 costSum += heapCheck(generations[g].steps[s].blocks);
2306 debugBelch("heapCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2307 costSum += chainCheck(generations[g].steps[s].large_objects);
2308 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2317 findPointer(StgPtr p)
2323 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2324 for (s = 0; s < generations[g].n_steps; s++) {
2325 // if (g == 0 && s == 0) continue;
2326 bd = generations[g].steps[s].blocks;
2327 for (; bd; bd = bd->link) {
2328 for (q = bd->start; q < bd->free; q++) {
2329 if (*q == (StgWord)p) {
2331 while (!LOOKS_LIKE_GHC_INFO(*r)) r--;
2332 debugBelch("Found in gen[%d], step[%d]: q = %p, r = %p\n", g, s, q, r);
2337 bd = generations[g].steps[s].large_objects;
2338 for (; bd; bd = bd->link) {
2339 e = bd->start + cost((StgClosure *)bd->start);
2340 for (q = bd->start; q < e; q++) {
2341 if (*q == (StgWord)p) {
2343 while (*r == 0 || !LOOKS_LIKE_GHC_INFO(*r)) r--;
2344 debugBelch("Found in gen[%d], large_objects: %p\n", g, r);
2354 belongToHeap(StgPtr p)
2359 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2360 for (s = 0; s < generations[g].n_steps; s++) {
2361 // if (g == 0 && s == 0) continue;
2362 bd = generations[g].steps[s].blocks;
2363 for (; bd; bd = bd->link) {
2364 if (bd->start <= p && p < bd->free) {
2365 debugBelch("Belongs to gen[%d], step[%d]", g, s);
2369 bd = generations[g].steps[s].large_objects;
2370 for (; bd; bd = bd->link) {
2371 if (bd->start <= p && p < bd->start + getHeapClosureSize((StgClosure *)bd->start)) {
2372 debugBelch("Found in gen[%d], large_objects: %p\n", g, bd->start);
2379 #endif // DEBUG_RETAINER
2381 #endif /* PROFILING */