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"
28 #include "Profiling.h"
34 Note: what to change in order to plug-in a new retainer profiling scheme?
35 (1) type retainer in ../includes/StgRetainerProf.h
36 (2) retainer function R(), i.e., getRetainerFrom()
37 (3) the two hashing functions, hashKeySingleton() and hashKeyAddElement(),
38 in RetainerSet.h, if needed.
39 (4) printRetainer() and printRetainerSetShort() in RetainerSet.c.
42 /* -----------------------------------------------------------------------------
44 * -------------------------------------------------------------------------- */
46 static nat retainerGeneration; // generation
48 static nat numObjectVisited; // total number of objects visited
49 static nat timesAnyObjectVisited; // number of times any objects are visited
52 The rs field in the profile header of any object points to its retainer
53 set in an indirect way: if flip is 0, it points to the retainer set;
54 if flip is 1, it points to the next byte after the retainer set (even
55 for NULL pointers). Therefore, with flip 1, (rs ^ 1) is the actual
56 pointer. See retainerSetOf().
59 StgWord flip = 0; // flip bit
60 // must be 0 if DEBUG_RETAINER is on (for static closures)
62 #define setRetainerSetToNull(c) \
63 (c)->header.prof.hp.rs = (RetainerSet *)((StgWord)NULL | flip)
65 static void retainStack(StgClosure *, retainer, StgPtr, StgPtr);
66 static void retainClosure(StgClosure *, StgClosure *, retainer);
68 static void belongToHeap(StgPtr p);
73 cStackSize records how many times retainStack() has been invoked recursively,
74 that is, the number of activation records for retainStack() on the C stack.
75 maxCStackSize records its max value.
77 cStackSize <= maxCStackSize
79 static nat cStackSize, maxCStackSize;
81 static nat sumOfNewCost; // sum of the cost of each object, computed
82 // when the object is first visited
83 static nat sumOfNewCostExtra; // for those objects not visited during
84 // retainer profiling, e.g., MUT_VAR
85 static nat costArray[N_CLOSURE_TYPES];
87 nat sumOfCostLinear; // sum of the costs of all object, computed
88 // when linearly traversing the heap after
90 nat costArrayLinear[N_CLOSURE_TYPES];
93 /* -----------------------------------------------------------------------------
94 * Retainer stack - header
96 * Although the retainer stack implementation could be separated *
97 * from the retainer profiling engine, there does not seem to be
98 * any advantage in doing that; retainer stack is an integral part
99 * of retainer profiling engine and cannot be use elsewhere at
101 * -------------------------------------------------------------------------- */
111 // fixed layout or layout specified by a field in the closure
116 // See StgClosureInfo in InfoTables.h
117 #if SIZEOF_VOID_P == 8
154 firstStack points to the first block group.
155 currentStack points to the block group currently being used.
156 currentStack->free == stackLimit.
157 stackTop points to the topmost byte in the stack of currentStack.
158 Unless the whole stack is empty, stackTop must point to the topmost
159 object (or byte) in the whole stack. Thus, it is only when the whole stack
160 is empty that stackTop == stackLimit (not during the execution of push()
162 stackBottom == currentStack->start.
163 stackLimit == currentStack->start + BLOCK_SIZE_W * currentStack->blocks.
165 When a current stack becomes empty, stackTop is set to point to
166 the topmost element on the previous block group so as to satisfy
167 the invariants described above.
169 static bdescr *firstStack = NULL;
170 static bdescr *currentStack;
171 static stackElement *stackBottom, *stackTop, *stackLimit;
174 currentStackBoundary is used to mark the current stack chunk.
175 If stackTop == currentStackBoundary, it means that the current stack chunk
176 is empty. It is the responsibility of the user to keep currentStackBoundary
177 valid all the time if it is to be employed.
179 static stackElement *currentStackBoundary;
182 stackSize records the current size of the stack.
183 maxStackSize records its high water mark.
185 stackSize <= maxStackSize
187 stackSize is just an estimate measure of the depth of the graph. The reason
188 is that some heap objects have only a single child and may not result
189 in a new element being pushed onto the stack. Therefore, at the end of
190 retainer profiling, maxStackSize + maxCStackSize is some value no greater
191 than the actual depth of the graph.
193 #ifdef DEBUG_RETAINER
194 static int stackSize, maxStackSize;
197 // number of blocks allocated for one stack
198 #define BLOCKS_IN_STACK 1
200 /* -----------------------------------------------------------------------------
201 * Add a new block group to the stack.
203 * currentStack->link == s.
204 * -------------------------------------------------------------------------- */
206 newStackBlock( bdescr *bd )
209 stackTop = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
210 stackBottom = (stackElement *)bd->start;
211 stackLimit = (stackElement *)stackTop;
212 bd->free = (StgPtr)stackLimit;
215 /* -----------------------------------------------------------------------------
216 * Return to the previous block group.
218 * s->link == currentStack.
219 * -------------------------------------------------------------------------- */
221 returnToOldStack( bdescr *bd )
224 stackTop = (stackElement *)bd->free;
225 stackBottom = (stackElement *)bd->start;
226 stackLimit = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
227 bd->free = (StgPtr)stackLimit;
230 /* -----------------------------------------------------------------------------
231 * Initializes the traverse stack.
232 * -------------------------------------------------------------------------- */
234 initializeTraverseStack( void )
236 if (firstStack != NULL) {
237 freeChain(firstStack);
240 firstStack = allocGroup(BLOCKS_IN_STACK);
241 firstStack->link = NULL;
242 firstStack->u.back = NULL;
244 newStackBlock(firstStack);
247 /* -----------------------------------------------------------------------------
248 * Frees all the block groups in the traverse stack.
251 * -------------------------------------------------------------------------- */
253 closeTraverseStack( void )
255 freeChain(firstStack);
259 /* -----------------------------------------------------------------------------
260 * Returns rtsTrue if the whole stack is empty.
261 * -------------------------------------------------------------------------- */
262 static INLINE rtsBool
263 isEmptyRetainerStack( void )
265 return (firstStack == currentStack) && stackTop == stackLimit;
268 /* -----------------------------------------------------------------------------
269 * Returns size of stack
270 * -------------------------------------------------------------------------- */
273 retainerStackBlocks( void )
278 for (bd = firstStack; bd != NULL; bd = bd->link)
285 /* -----------------------------------------------------------------------------
286 * Returns rtsTrue if stackTop is at the stack boundary of the current stack,
287 * i.e., if the current stack chunk is empty.
288 * -------------------------------------------------------------------------- */
289 static INLINE rtsBool
292 return stackTop == currentStackBoundary;
295 /* -----------------------------------------------------------------------------
296 * Initializes *info from ptrs and payload.
298 * payload[] begins with ptrs pointers followed by non-pointers.
299 * -------------------------------------------------------------------------- */
301 init_ptrs( stackPos *info, nat ptrs, StgPtr payload )
303 info->type = posTypePtrs;
304 info->next.ptrs.pos = 0;
305 info->next.ptrs.ptrs = ptrs;
306 info->next.ptrs.payload = payload;
309 /* -----------------------------------------------------------------------------
310 * Find the next object from *info.
311 * -------------------------------------------------------------------------- */
312 static INLINE StgClosure *
313 find_ptrs( stackPos *info )
315 if (info->next.ptrs.pos < info->next.ptrs.ptrs) {
316 return (StgClosure *)info->next.ptrs.payload[info->next.ptrs.pos++];
322 /* -----------------------------------------------------------------------------
323 * Initializes *info from SRT information stored in *infoTable.
324 * -------------------------------------------------------------------------- */
326 init_srt_fun( stackPos *info, StgFunInfoTable *infoTable )
328 if (infoTable->i.srt_bitmap == (StgHalfWord)(-1)) {
329 info->type = posTypeLargeSRT;
330 info->next.large_srt.srt = (StgLargeSRT *)GET_FUN_SRT(infoTable);
331 info->next.large_srt.offset = 0;
333 info->type = posTypeSRT;
334 info->next.srt.srt = (StgClosure **)GET_FUN_SRT(infoTable);
335 info->next.srt.srt_bitmap = infoTable->i.srt_bitmap;
340 init_srt_thunk( stackPos *info, StgThunkInfoTable *infoTable )
342 if (infoTable->i.srt_bitmap == (StgHalfWord)(-1)) {
343 info->type = posTypeLargeSRT;
344 info->next.large_srt.srt = (StgLargeSRT *)GET_SRT(infoTable);
345 info->next.large_srt.offset = 0;
347 info->type = posTypeSRT;
348 info->next.srt.srt = (StgClosure **)GET_SRT(infoTable);
349 info->next.srt.srt_bitmap = infoTable->i.srt_bitmap;
353 /* -----------------------------------------------------------------------------
354 * Find the next object from *info.
355 * -------------------------------------------------------------------------- */
356 static INLINE StgClosure *
357 find_srt( stackPos *info )
362 if (info->type == posTypeSRT) {
364 bitmap = info->next.srt.srt_bitmap;
365 while (bitmap != 0) {
366 if ((bitmap & 1) != 0) {
367 #if defined(__PIC__) && defined(mingw32_TARGET_OS)
368 if ((unsigned long)(*(info->next.srt.srt)) & 0x1)
369 c = (* (StgClosure **)((unsigned long)*(info->next.srt.srt)) & ~0x1);
371 c = *(info->next.srt.srt);
373 c = *(info->next.srt.srt);
375 bitmap = bitmap >> 1;
376 info->next.srt.srt++;
377 info->next.srt.srt_bitmap = bitmap;
380 bitmap = bitmap >> 1;
381 info->next.srt.srt++;
383 // bitmap is now zero...
388 nat i = info->next.large_srt.offset;
391 // Follow the pattern from GC.c:scavenge_large_srt_bitmap().
392 bitmap = info->next.large_srt.srt->l.bitmap[i / BITS_IN(W_)];
393 bitmap = bitmap >> (i % BITS_IN(StgWord));
394 while (i < info->next.large_srt.srt->l.size) {
395 if ((bitmap & 1) != 0) {
396 c = ((StgClosure **)info->next.large_srt.srt->srt)[i];
398 info->next.large_srt.offset = i;
402 if (i % BITS_IN(W_) == 0) {
403 bitmap = info->next.large_srt.srt->l.bitmap[i / BITS_IN(W_)];
405 bitmap = bitmap >> 1;
408 // reached the end of this bitmap.
409 info->next.large_srt.offset = i;
414 /* -----------------------------------------------------------------------------
415 * push() pushes a stackElement representing the next child of *c
416 * onto the traverse stack. If *c has no child, *first_child is set
417 * to NULL and nothing is pushed onto the stack. If *c has only one
418 * child, *c_chlid is set to that child and nothing is pushed onto
419 * the stack. If *c has more than two children, *first_child is set
420 * to the first child and a stackElement representing the second
421 * child is pushed onto the stack.
424 * *c_child_r is the most recent retainer of *c's children.
425 * *c is not any of TSO, AP, PAP, AP_STACK, which means that
426 * there cannot be any stack objects.
427 * Note: SRTs are considered to be children as well.
428 * -------------------------------------------------------------------------- */
430 push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
433 bdescr *nbd; // Next Block Descriptor
435 #ifdef DEBUG_RETAINER
436 // debugBelch("push(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
439 ASSERT(get_itbl(c)->type != TSO);
440 ASSERT(get_itbl(c)->type != AP_STACK);
447 se.c_child_r = c_child_r;
450 switch (get_itbl(c)->type) {
457 case SE_CAF_BLACKHOLE:
462 // one child (fixed), no SRT
465 *first_child = ((StgMutVar *)c)->var;
468 *first_child = ((StgSelector *)c)->selectee;
471 case IND_OLDGEN_PERM:
473 *first_child = ((StgInd *)c)->indirectee;
477 *first_child = c->payload[0];
480 // For CONSTR_2_0 and MVAR, we use se.info.step to record the position
481 // of the next child. We do not write a separate initialization code.
482 // Also we do not have to initialize info.type;
484 // two children (fixed), no SRT
485 // need to push a stackElement, but nothing to store in se.info
487 *first_child = c->payload[0]; // return the first pointer
488 // se.info.type = posTypeStep;
489 // se.info.next.step = 2; // 2 = second
492 // three children (fixed), no SRT
493 // need to push a stackElement
496 // head must be TSO and the head of a linked list of TSOs.
497 // Shoule it be a child? Seems to be yes.
498 *first_child = (StgClosure *)((StgMVar *)c)->head;
499 // se.info.type = posTypeStep;
500 se.info.next.step = 2; // 2 = second
503 // three children (fixed), no SRT
505 *first_child = ((StgWeak *)c)->key;
506 // se.info.type = posTypeStep;
507 se.info.next.step = 2;
510 // layout.payload.ptrs, no SRT
515 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
517 *first_child = find_ptrs(&se.info);
518 if (*first_child == NULL)
522 // StgMutArrPtr.ptrs, no SRT
523 case MUT_ARR_PTRS_CLEAN:
524 case MUT_ARR_PTRS_DIRTY:
525 case MUT_ARR_PTRS_FROZEN:
526 case MUT_ARR_PTRS_FROZEN0:
527 init_ptrs(&se.info, ((StgMutArrPtrs *)c)->ptrs,
528 (StgPtr)(((StgMutArrPtrs *)c)->payload));
529 *first_child = find_ptrs(&se.info);
530 if (*first_child == NULL)
534 // layout.payload.ptrs, SRT
535 case FUN: // *c is a heap object.
537 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
538 *first_child = find_ptrs(&se.info);
539 if (*first_child == NULL)
540 // no child from ptrs, so check SRT
546 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
547 (StgPtr)((StgThunk *)c)->payload);
548 *first_child = find_ptrs(&se.info);
549 if (*first_child == NULL)
550 // no child from ptrs, so check SRT
554 // 1 fixed child, SRT
557 *first_child = c->payload[0];
558 ASSERT(*first_child != NULL);
559 init_srt_fun(&se.info, get_fun_itbl(c));
564 *first_child = ((StgThunk *)c)->payload[0];
565 ASSERT(*first_child != NULL);
566 init_srt_thunk(&se.info, get_thunk_itbl(c));
569 case FUN_STATIC: // *c is a heap object.
570 ASSERT(get_itbl(c)->srt_bitmap != 0);
574 init_srt_fun(&se.info, get_fun_itbl(c));
575 *first_child = find_srt(&se.info);
576 if (*first_child == NULL)
582 ASSERT(get_itbl(c)->srt_bitmap != 0);
586 init_srt_thunk(&se.info, get_thunk_itbl(c));
587 *first_child = find_srt(&se.info);
588 if (*first_child == NULL)
592 case TVAR_WATCH_QUEUE:
593 *first_child = (StgClosure *)((StgTVarWatchQueue *)c)->closure;
594 se.info.next.step = 2; // 2 = second
597 *first_child = (StgClosure *)((StgTVar *)c)->current_value;
600 *first_child = (StgClosure *)((StgTRecHeader *)c)->enclosing_trec;
603 *first_child = (StgClosure *)((StgTRecChunk *)c)->prev_chunk;
604 se.info.next.step = 0; // entry no.
613 case CONSTR_NOCAF_STATIC:
631 barf("Invalid object *c in push()");
635 if (stackTop - 1 < stackBottom) {
636 #ifdef DEBUG_RETAINER
637 // debugBelch("push() to the next stack.\n");
639 // currentStack->free is updated when the active stack is switched
640 // to the next stack.
641 currentStack->free = (StgPtr)stackTop;
643 if (currentStack->link == NULL) {
644 nbd = allocGroup(BLOCKS_IN_STACK);
646 nbd->u.back = currentStack;
647 currentStack->link = nbd;
649 nbd = currentStack->link;
654 // adjust stackTop (acutal push)
656 // If the size of stackElement was huge, we would better replace the
657 // following statement by either a memcpy() call or a switch statement
658 // on the type of the element. Currently, the size of stackElement is
659 // small enough (5 words) that this direct assignment seems to be enough.
661 // ToDo: The line below leads to the warning:
662 // warning: 'se.info.type' may be used uninitialized in this function
663 // This is caused by the fact that there are execution paths through the
664 // large switch statement above where some cases do not initialize this
665 // field. Is this really harmless? Can we avoid the warning?
668 #ifdef DEBUG_RETAINER
670 if (stackSize > maxStackSize) maxStackSize = stackSize;
671 // ASSERT(stackSize >= 0);
672 // debugBelch("stackSize = %d\n", stackSize);
676 /* -----------------------------------------------------------------------------
677 * popOff() and popOffReal(): Pop a stackElement off the traverse stack.
679 * stackTop cannot be equal to stackLimit unless the whole stack is
680 * empty, in which case popOff() is not allowed.
682 * You can think of popOffReal() as a part of popOff() which is
683 * executed at the end of popOff() in necessary. Since popOff() is
684 * likely to be executed quite often while popOffReal() is not, we
685 * separate popOffReal() from popOff(), which is declared as an
686 * INLINE function (for the sake of execution speed). popOffReal()
687 * is called only within popOff() and nowhere else.
688 * -------------------------------------------------------------------------- */
692 bdescr *pbd; // Previous Block Descriptor
694 #ifdef DEBUG_RETAINER
695 // debugBelch("pop() to the previous stack.\n");
698 ASSERT(stackTop + 1 == stackLimit);
699 ASSERT(stackBottom == (stackElement *)currentStack->start);
701 if (firstStack == currentStack) {
702 // The stack is completely empty.
704 ASSERT(stackTop == stackLimit);
705 #ifdef DEBUG_RETAINER
707 if (stackSize > maxStackSize) maxStackSize = stackSize;
709 ASSERT(stackSize >= 0);
710 debugBelch("stackSize = %d\n", stackSize);
716 // currentStack->free is updated when the active stack is switched back
717 // to the previous stack.
718 currentStack->free = (StgPtr)stackLimit;
720 // find the previous block descriptor
721 pbd = currentStack->u.back;
724 returnToOldStack(pbd);
726 #ifdef DEBUG_RETAINER
728 if (stackSize > maxStackSize) maxStackSize = stackSize;
730 ASSERT(stackSize >= 0);
731 debugBelch("stackSize = %d\n", stackSize);
738 #ifdef DEBUG_RETAINER
739 // debugBelch("\tpopOff(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
742 ASSERT(stackTop != stackLimit);
743 ASSERT(!isEmptyRetainerStack());
745 // <= (instead of <) is wrong!
746 if (stackTop + 1 < stackLimit) {
748 #ifdef DEBUG_RETAINER
750 if (stackSize > maxStackSize) maxStackSize = stackSize;
752 ASSERT(stackSize >= 0);
753 debugBelch("stackSize = %d\n", stackSize);
762 /* -----------------------------------------------------------------------------
763 * Finds the next object to be considered for retainer profiling and store
765 * Test if the topmost stack element indicates that more objects are left,
766 * and if so, retrieve the first object and store its pointer to *c. Also,
767 * set *cp and *r appropriately, both of which are stored in the stack element.
768 * The topmost stack element then is overwritten so as for it to now denote
770 * If the topmost stack element indicates no more objects are left, pop
771 * off the stack element until either an object can be retrieved or
772 * the current stack chunk becomes empty, indicated by rtsTrue returned by
773 * isOnBoundary(), in which case *c is set to NULL.
775 * It is okay to call this function even when the current stack chunk
777 * -------------------------------------------------------------------------- */
779 pop( StgClosure **c, StgClosure **cp, retainer *r )
783 #ifdef DEBUG_RETAINER
784 // debugBelch("pop(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
788 if (isOnBoundary()) { // if the current stack chunk is depleted
795 switch (get_itbl(se->c)->type) {
796 // two children (fixed), no SRT
797 // nothing in se.info
799 *c = se->c->payload[1];
805 // three children (fixed), no SRT
806 // need to push a stackElement
809 if (se->info.next.step == 2) {
810 *c = (StgClosure *)((StgMVar *)se->c)->tail;
811 se->info.next.step++; // move to the next step
814 *c = ((StgMVar *)se->c)->value;
821 // three children (fixed), no SRT
823 if (se->info.next.step == 2) {
824 *c = ((StgWeak *)se->c)->value;
825 se->info.next.step++;
828 *c = ((StgWeak *)se->c)->finalizer;
835 case TVAR_WATCH_QUEUE:
836 if (se->info.next.step == 2) {
837 *c = (StgClosure *)((StgTVarWatchQueue *)se->c)->next_queue_entry;
838 se->info.next.step++; // move to the next step
841 *c = (StgClosure *)((StgTVarWatchQueue *)se->c)->prev_queue_entry;
849 *c = (StgClosure *)((StgTVar *)se->c)->first_watch_queue_entry;
856 *c = (StgClosure *)((StgTRecHeader *)se->c)->current_chunk;
863 // These are pretty complicated: we have N entries, each
864 // of which contains 3 fields that we want to follow. So
865 // we divide the step counter: the 2 low bits indicate
866 // which field, and the rest of the bits indicate the
867 // entry number (starting from zero).
869 nat entry_no = se->info.next.step >> 2;
870 nat field_no = se->info.next.step & 3;
871 if (entry_no == ((StgTRecChunk *)se->c)->next_entry_idx) {
876 entry = &((StgTRecChunk *)se->c)->entries[entry_no];
878 *c = (StgClosure *)entry->tvar;
879 } else if (field_no == 1) {
880 *c = entry->expected_value;
882 *c = entry->new_value;
886 se->info.next.step++;
894 // StgMutArrPtr.ptrs, no SRT
895 case MUT_ARR_PTRS_CLEAN:
896 case MUT_ARR_PTRS_DIRTY:
897 case MUT_ARR_PTRS_FROZEN:
898 case MUT_ARR_PTRS_FROZEN0:
899 *c = find_ptrs(&se->info);
908 // layout.payload.ptrs, SRT
909 case FUN: // always a heap object
911 if (se->info.type == posTypePtrs) {
912 *c = find_ptrs(&se->info);
918 init_srt_fun(&se->info, get_fun_itbl(se->c));
924 if (se->info.type == posTypePtrs) {
925 *c = find_ptrs(&se->info);
931 init_srt_thunk(&se->info, get_thunk_itbl(se->c));
947 *c = find_srt(&se->info);
956 // no child (fixed), no SRT
962 case SE_CAF_BLACKHOLE:
964 // one child (fixed), no SRT
969 case IND_OLDGEN_PERM:
978 case CONSTR_NOCAF_STATIC:
996 barf("Invalid object *c in pop()");
1002 /* -----------------------------------------------------------------------------
1003 * RETAINER PROFILING ENGINE
1004 * -------------------------------------------------------------------------- */
1007 initRetainerProfiling( void )
1009 initializeAllRetainerSet();
1010 retainerGeneration = 0;
1013 /* -----------------------------------------------------------------------------
1014 * This function must be called before f-closing prof_file.
1015 * -------------------------------------------------------------------------- */
1017 endRetainerProfiling( void )
1019 #ifdef SECOND_APPROACH
1020 outputAllRetainerSet(prof_file);
1024 /* -----------------------------------------------------------------------------
1025 * Returns the actual pointer to the retainer set of the closure *c.
1026 * It may adjust RSET(c) subject to flip.
1028 * RSET(c) is initialized to NULL if its current value does not
1031 * Even though this function has side effects, they CAN be ignored because
1032 * subsequent calls to retainerSetOf() always result in the same return value
1033 * and retainerSetOf() is the only way to retrieve retainerSet of a given
1035 * We have to perform an XOR (^) operation each time a closure is examined.
1036 * The reason is that we do not know when a closure is visited last.
1037 * -------------------------------------------------------------------------- */
1039 maybeInitRetainerSet( StgClosure *c )
1041 if (!isRetainerSetFieldValid(c)) {
1042 setRetainerSetToNull(c);
1046 /* -----------------------------------------------------------------------------
1047 * Returns rtsTrue if *c is a retainer.
1048 * -------------------------------------------------------------------------- */
1049 static INLINE rtsBool
1050 isRetainer( StgClosure *c )
1052 switch (get_itbl(c)->type) {
1056 // TSOs MUST be retainers: they constitute the set of roots.
1064 case MUT_ARR_PTRS_CLEAN:
1065 case MUT_ARR_PTRS_DIRTY:
1066 case MUT_ARR_PTRS_FROZEN:
1067 case MUT_ARR_PTRS_FROZEN0:
1069 // thunks are retainers.
1076 case THUNK_SELECTOR:
1080 // Static thunks, or CAFS, are obviously retainers.
1083 // WEAK objects are roots; there is separate code in which traversing
1084 // begins from WEAK objects.
1087 // Since the other mutvar-type things are retainers, seems
1088 // like the right thing to do:
1110 // partial applications
1116 case SE_CAF_BLACKHOLE:
1119 case IND_OLDGEN_PERM:
1129 case TVAR_WATCH_QUEUE:
1137 // IND_STATIC cannot be *c, *cp, *r in the retainer profiling loop.
1139 // CONSTR_NOCAF_STATIC
1140 // cannot be *c, *cp, *r in the retainer profiling loop.
1141 case CONSTR_NOCAF_STATIC:
1142 // Stack objects are invalid because they are never treated as
1143 // legal objects during retainer profiling.
1158 case INVALID_OBJECT:
1160 barf("Invalid object in isRetainer(): %d", get_itbl(c)->type);
1165 /* -----------------------------------------------------------------------------
1166 * Returns the retainer function value for the closure *c, i.e., R(*c).
1167 * This function does NOT return the retainer(s) of *c.
1169 * *c must be a retainer.
1171 * Depending on the definition of this function, the maintenance of retainer
1172 * sets can be made easier. If most retainer sets are likely to be created
1173 * again across garbage collections, refreshAllRetainerSet() in
1174 * RetainerSet.c can simply do nothing.
1175 * If this is not the case, we can free all the retainer sets and
1176 * re-initialize the hash table.
1177 * See refreshAllRetainerSet() in RetainerSet.c.
1178 * -------------------------------------------------------------------------- */
1179 static INLINE retainer
1180 getRetainerFrom( StgClosure *c )
1182 ASSERT(isRetainer(c));
1184 #if defined(RETAINER_SCHEME_INFO)
1185 // Retainer scheme 1: retainer = info table
1187 #elif defined(RETAINER_SCHEME_CCS)
1188 // Retainer scheme 2: retainer = cost centre stack
1189 return c->header.prof.ccs;
1190 #elif defined(RETAINER_SCHEME_CC)
1191 // Retainer scheme 3: retainer = cost centre
1192 return c->header.prof.ccs->cc;
1196 /* -----------------------------------------------------------------------------
1197 * Associates the retainer set *s with the closure *c, that is, *s becomes
1198 * the retainer set of *c.
1202 * -------------------------------------------------------------------------- */
1204 associate( StgClosure *c, RetainerSet *s )
1206 // StgWord has the same size as pointers, so the following type
1208 RSET(c) = (RetainerSet *)((StgWord)s | flip);
1211 /* -----------------------------------------------------------------------------
1212 Call retainClosure for each of the closures covered by a large bitmap.
1213 -------------------------------------------------------------------------- */
1216 retain_large_bitmap (StgPtr p, StgLargeBitmap *large_bitmap, nat size,
1217 StgClosure *c, retainer c_child_r)
1223 bitmap = large_bitmap->bitmap[b];
1224 for (i = 0; i < size; ) {
1225 if ((bitmap & 1) == 0) {
1226 retainClosure((StgClosure *)*p, c, c_child_r);
1230 if (i % BITS_IN(W_) == 0) {
1232 bitmap = large_bitmap->bitmap[b];
1234 bitmap = bitmap >> 1;
1239 static INLINE StgPtr
1240 retain_small_bitmap (StgPtr p, nat size, StgWord bitmap,
1241 StgClosure *c, retainer c_child_r)
1244 if ((bitmap & 1) == 0) {
1245 retainClosure((StgClosure *)*p, c, c_child_r);
1248 bitmap = bitmap >> 1;
1254 /* -----------------------------------------------------------------------------
1255 * Call retainClosure for each of the closures in an SRT.
1256 * ------------------------------------------------------------------------- */
1259 retain_large_srt_bitmap (StgLargeSRT *srt, StgClosure *c, retainer c_child_r)
1266 p = (StgClosure **)srt->srt;
1268 bitmap = srt->l.bitmap[b];
1269 for (i = 0; i < size; ) {
1270 if ((bitmap & 1) != 0) {
1271 retainClosure((StgClosure *)*p, c, c_child_r);
1275 if (i % BITS_IN(W_) == 0) {
1277 bitmap = srt->l.bitmap[b];
1279 bitmap = bitmap >> 1;
1285 retainSRT (StgClosure **srt, nat srt_bitmap, StgClosure *c, retainer c_child_r)
1290 bitmap = srt_bitmap;
1293 if (bitmap == (StgHalfWord)(-1)) {
1294 retain_large_srt_bitmap( (StgLargeSRT *)srt, c, c_child_r );
1298 while (bitmap != 0) {
1299 if ((bitmap & 1) != 0) {
1300 #ifdef ENABLE_WIN32_DLL_SUPPORT
1301 if ( (unsigned long)(*srt) & 0x1 ) {
1302 retainClosure(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)),
1305 retainClosure(*srt,c,c_child_r);
1308 retainClosure(*srt,c,c_child_r);
1312 bitmap = bitmap >> 1;
1316 /* -----------------------------------------------------------------------------
1317 * Process all the objects in the stack chunk from stackStart to stackEnd
1318 * with *c and *c_child_r being their parent and their most recent retainer,
1319 * respectively. Treat stackOptionalFun as another child of *c if it is
1322 * *c is one of the following: TSO, AP_STACK.
1323 * If *c is TSO, c == c_child_r.
1324 * stackStart < stackEnd.
1325 * RSET(c) and RSET(c_child_r) are valid, i.e., their
1326 * interpretation conforms to the current value of flip (even when they
1327 * are interpreted to be NULL).
1328 * If *c is TSO, its state is not any of ThreadRelocated, ThreadComplete,
1329 * or ThreadKilled, which means that its stack is ready to process.
1331 * This code was almost plagiarzied from GC.c! For each pointer,
1332 * retainClosure() is invoked instead of evacuate().
1333 * -------------------------------------------------------------------------- */
1335 retainStack( StgClosure *c, retainer c_child_r,
1336 StgPtr stackStart, StgPtr stackEnd )
1338 stackElement *oldStackBoundary;
1340 StgRetInfoTable *info;
1344 #ifdef DEBUG_RETAINER
1346 if (cStackSize > maxCStackSize) maxCStackSize = cStackSize;
1350 Each invocation of retainStack() creates a new virtual
1351 stack. Since all such stacks share a single common stack, we
1352 record the current currentStackBoundary, which will be restored
1355 oldStackBoundary = currentStackBoundary;
1356 currentStackBoundary = stackTop;
1358 #ifdef DEBUG_RETAINER
1359 // debugBelch("retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
1362 ASSERT(get_itbl(c)->type != TSO ||
1363 (((StgTSO *)c)->what_next != ThreadRelocated &&
1364 ((StgTSO *)c)->what_next != ThreadComplete &&
1365 ((StgTSO *)c)->what_next != ThreadKilled));
1368 while (p < stackEnd) {
1369 info = get_ret_itbl((StgClosure *)p);
1371 switch(info->i.type) {
1374 retainClosure(((StgUpdateFrame *)p)->updatee, c, c_child_r);
1375 p += sizeofW(StgUpdateFrame);
1380 case CATCH_STM_FRAME:
1381 case CATCH_RETRY_FRAME:
1382 case ATOMICALLY_FRAME:
1384 bitmap = BITMAP_BITS(info->i.layout.bitmap);
1385 size = BITMAP_SIZE(info->i.layout.bitmap);
1387 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1390 retainSRT((StgClosure **)GET_SRT(info), info->i.srt_bitmap, c, c_child_r);
1397 retainClosure((StgClosure *)*p, c, c_child_r);
1400 size = BCO_BITMAP_SIZE(bco);
1401 retain_large_bitmap(p, BCO_BITMAP(bco), size, c, c_child_r);
1406 // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
1408 size = GET_LARGE_BITMAP(&info->i)->size;
1410 retain_large_bitmap(p, GET_LARGE_BITMAP(&info->i),
1411 size, c, c_child_r);
1413 // and don't forget to follow the SRT
1416 // Dynamic bitmap: the mask is stored on the stack
1419 dyn = ((StgRetDyn *)p)->liveness;
1421 // traverse the bitmap first
1422 bitmap = RET_DYN_LIVENESS(dyn);
1423 p = (P_)&((StgRetDyn *)p)->payload[0];
1424 size = RET_DYN_BITMAP_SIZE;
1425 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1427 // skip over the non-ptr words
1428 p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
1430 // follow the ptr words
1431 for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
1432 retainClosure((StgClosure *)*p, c, c_child_r);
1439 StgRetFun *ret_fun = (StgRetFun *)p;
1440 StgFunInfoTable *fun_info;
1442 retainClosure(ret_fun->fun, c, c_child_r);
1443 fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
1445 p = (P_)&ret_fun->payload;
1446 switch (fun_info->f.fun_type) {
1448 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
1449 size = BITMAP_SIZE(fun_info->f.b.bitmap);
1450 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1453 size = GET_FUN_LARGE_BITMAP(fun_info)->size;
1454 retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
1455 size, c, c_child_r);
1459 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1460 size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
1461 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1468 barf("Invalid object found in retainStack(): %d",
1469 (int)(info->i.type));
1473 // restore currentStackBoundary
1474 currentStackBoundary = oldStackBoundary;
1475 #ifdef DEBUG_RETAINER
1476 // debugBelch("retainStack() finished: currentStackBoundary = 0x%x\n", currentStackBoundary);
1479 #ifdef DEBUG_RETAINER
1484 /* ----------------------------------------------------------------------------
1485 * Call retainClosure for each of the children of a PAP/AP
1486 * ------------------------------------------------------------------------- */
1488 static INLINE StgPtr
1489 retain_PAP_payload (StgClosure *pap, /* NOT tagged */
1490 retainer c_child_r, /* NOT tagged */
1491 StgClosure *fun, /* tagged */
1492 StgClosure** payload, StgWord n_args)
1496 StgFunInfoTable *fun_info;
1498 retainClosure(fun, pap, c_child_r);
1499 fun = UNTAG_CLOSURE(fun);
1500 fun_info = get_fun_itbl(fun);
1501 ASSERT(fun_info->i.type != PAP);
1503 p = (StgPtr)payload;
1505 switch (fun_info->f.fun_type) {
1507 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
1508 p = retain_small_bitmap(p, n_args, bitmap,
1512 retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
1513 n_args, pap, c_child_r);
1517 retain_large_bitmap((StgPtr)payload, BCO_BITMAP(fun),
1518 n_args, pap, c_child_r);
1522 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1523 p = retain_small_bitmap(p, n_args, bitmap, pap, c_child_r);
1529 /* -----------------------------------------------------------------------------
1530 * Compute the retainer set of *c0 and all its desecents by traversing.
1531 * *cp0 is the parent of *c0, and *r0 is the most recent retainer of *c0.
1533 * c0 = cp0 = r0 holds only for root objects.
1534 * RSET(cp0) and RSET(r0) are valid, i.e., their
1535 * interpretation conforms to the current value of flip (even when they
1536 * are interpreted to be NULL).
1537 * However, RSET(c0) may be corrupt, i.e., it may not conform to
1538 * the current value of flip. If it does not, during the execution
1539 * of this function, RSET(c0) must be initialized as well as all
1542 * stackTop must be the same at the beginning and the exit of this function.
1543 * *c0 can be TSO (as well as AP_STACK).
1544 * -------------------------------------------------------------------------- */
1546 retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
1548 // c = Current closure (possibly tagged)
1549 // cp = Current closure's Parent (NOT tagged)
1550 // r = current closures' most recent Retainer (NOT tagged)
1551 // c_child_r = current closure's children's most recent retainer
1552 // first_child = first child of c
1553 StgClosure *c, *cp, *first_child;
1554 RetainerSet *s, *retainerSetOfc;
1555 retainer r, c_child_r;
1558 #ifdef DEBUG_RETAINER
1559 // StgPtr oldStackTop;
1562 #ifdef DEBUG_RETAINER
1563 // oldStackTop = stackTop;
1564 // debugBelch("retainClosure() called: c0 = 0x%x, cp0 = 0x%x, r0 = 0x%x\n", c0, cp0, r0);
1567 // (c, cp, r) = (c0, cp0, r0)
1574 //debugBelch("loop");
1575 // pop to (c, cp, r);
1579 #ifdef DEBUG_RETAINER
1580 // debugBelch("retainClosure() ends: oldStackTop = 0x%x, stackTop = 0x%x\n", oldStackTop, stackTop);
1585 //debugBelch("inner_loop");
1588 c = UNTAG_CLOSURE(c);
1590 // c = current closure under consideration,
1591 // cp = current closure's parent,
1592 // r = current closure's most recent retainer
1594 // Loop invariants (on the meaning of c, cp, r, and their retainer sets):
1595 // RSET(cp) and RSET(r) are valid.
1596 // RSET(c) is valid only if c has been visited before.
1598 // Loop invariants (on the relation between c, cp, and r)
1599 // if cp is not a retainer, r belongs to RSET(cp).
1600 // if cp is a retainer, r == cp.
1602 typeOfc = get_itbl(c)->type;
1604 #ifdef DEBUG_RETAINER
1607 case CONSTR_NOCAF_STATIC:
1613 if (retainerSetOf(c) == NULL) { // first visit?
1614 costArray[typeOfc] += cost(c);
1615 sumOfNewCost += cost(c);
1624 if (((StgTSO *)c)->what_next == ThreadComplete ||
1625 ((StgTSO *)c)->what_next == ThreadKilled) {
1626 #ifdef DEBUG_RETAINER
1627 debugBelch("ThreadComplete or ThreadKilled encountered in retainClosure()\n");
1631 if (((StgTSO *)c)->what_next == ThreadRelocated) {
1632 #ifdef DEBUG_RETAINER
1633 debugBelch("ThreadRelocated encountered in retainClosure()\n");
1635 c = (StgClosure *)((StgTSO *)c)->_link;
1641 // We just skip IND_STATIC, so its retainer set is never computed.
1642 c = ((StgIndStatic *)c)->indirectee;
1644 // static objects with no pointers out, so goto loop.
1645 case CONSTR_NOCAF_STATIC:
1646 // It is not just enough not to compute the retainer set for *c; it is
1647 // mandatory because CONSTR_NOCAF_STATIC are not reachable from
1648 // scavenged_static_objects, the list from which is assumed to traverse
1649 // all static objects after major garbage collections.
1653 if (get_itbl(c)->srt_bitmap == 0) {
1654 // No need to compute the retainer set; no dynamic objects
1655 // are reachable from *c.
1657 // Static objects: if we traverse all the live closures,
1658 // including static closures, during each heap census then
1659 // we will observe that some static closures appear and
1660 // disappear. eg. a closure may contain a pointer to a
1661 // static function 'f' which is not otherwise reachable
1662 // (it doesn't indirectly point to any CAFs, so it doesn't
1663 // appear in any SRTs), so we would find 'f' during
1664 // traversal. However on the next sweep there may be no
1665 // closures pointing to 'f'.
1667 // We must therefore ignore static closures whose SRT is
1668 // empty, because these are exactly the closures that may
1669 // "appear". A closure with a non-empty SRT, and which is
1670 // still required, will always be reachable.
1672 // But what about CONSTR_STATIC? Surely these may be able
1673 // to appear, and they don't have SRTs, so we can't
1674 // check. So for now, we're calling
1675 // resetStaticObjectForRetainerProfiling() from the
1676 // garbage collector to reset the retainer sets in all the
1677 // reachable static objects.
1684 // The above objects are ignored in computing the average number of times
1685 // an object is visited.
1686 timesAnyObjectVisited++;
1688 // If this is the first visit to c, initialize its retainer set.
1689 maybeInitRetainerSet(c);
1690 retainerSetOfc = retainerSetOf(c);
1693 // isRetainer(cp) == rtsTrue => s == NULL
1694 // isRetainer(cp) == rtsFalse => s == cp.retainer
1698 s = retainerSetOf(cp);
1700 // (c, cp, r, s) is available.
1702 // (c, cp, r, s, R_r) is available, so compute the retainer set for *c.
1703 if (retainerSetOfc == NULL) {
1704 // This is the first visit to *c.
1708 associate(c, singleton(r));
1710 // s is actually the retainer set of *c!
1713 // compute c_child_r
1714 c_child_r = isRetainer(c) ? getRetainerFrom(c) : r;
1716 // This is not the first visit to *c.
1717 if (isMember(r, retainerSetOfc))
1718 goto loop; // no need to process child
1721 associate(c, addElement(r, retainerSetOfc));
1723 // s is not NULL and cp is not a retainer. This means that
1724 // each time *cp is visited, so is *c. Thus, if s has
1725 // exactly one more element in its retainer set than c, s
1726 // is also the new retainer set for *c.
1727 if (s->num == retainerSetOfc->num + 1) {
1730 // Otherwise, just add R_r to the current retainer set of *c.
1732 associate(c, addElement(r, retainerSetOfc));
1737 goto loop; // no need to process child
1739 // compute c_child_r
1743 // now, RSET() of all of *c, *cp, and *r is valid.
1744 // (c, c_child_r) are available.
1748 // Special case closures: we process these all in one go rather
1749 // than attempting to save the current position, because doing so
1753 retainStack(c, c_child_r,
1755 ((StgTSO *)c)->stack + ((StgTSO *)c)->stack_size);
1760 StgPAP *pap = (StgPAP *)c;
1761 retain_PAP_payload(c, c_child_r, pap->fun, pap->payload, pap->n_args);
1767 StgAP *ap = (StgAP *)c;
1768 retain_PAP_payload(c, c_child_r, ap->fun, ap->payload, ap->n_args);
1773 retainClosure(((StgAP_STACK *)c)->fun, c, c_child_r);
1774 retainStack(c, c_child_r,
1775 (StgPtr)((StgAP_STACK *)c)->payload,
1776 (StgPtr)((StgAP_STACK *)c)->payload +
1777 ((StgAP_STACK *)c)->size);
1781 push(c, c_child_r, &first_child);
1783 // If first_child is null, c has no child.
1784 // If first_child is not null, the top stack element points to the next
1785 // object. push() may or may not push a stackElement on the stack.
1786 if (first_child == NULL)
1789 // (c, cp, r) = (first_child, c, c_child_r)
1796 /* -----------------------------------------------------------------------------
1797 * Compute the retainer set for every object reachable from *tl.
1798 * -------------------------------------------------------------------------- */
1800 retainRoot(void *user STG_UNUSED, StgClosure **tl)
1804 // We no longer assume that only TSOs and WEAKs are roots; any closure can
1807 ASSERT(isEmptyRetainerStack());
1808 currentStackBoundary = stackTop;
1810 c = UNTAG_CLOSURE(*tl);
1811 if (c != &stg_END_TSO_QUEUE_closure && isRetainer(c)) {
1812 retainClosure(c, c, getRetainerFrom(c));
1814 retainClosure(c, c, CCS_SYSTEM);
1817 // NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl)));
1818 // *tl might be a TSO which is ThreadComplete, in which
1819 // case we ignore it for the purposes of retainer profiling.
1822 /* -----------------------------------------------------------------------------
1823 * Compute the retainer set for each of the objects in the heap.
1824 * -------------------------------------------------------------------------- */
1826 computeRetainerSet( void )
1833 #ifdef DEBUG_RETAINER
1834 RetainerSet tmpRetainerSet;
1837 markCapabilities(retainRoot, NULL); // for scheduler roots
1839 // This function is called after a major GC, when key, value, and finalizer
1840 // all are guaranteed to be valid, or reachable.
1842 // The following code assumes that WEAK objects are considered to be roots
1843 // for retainer profilng.
1844 for (weak = weak_ptr_list; weak != NULL; weak = weak->link)
1845 // retainRoot((StgClosure *)weak);
1846 retainRoot((StgClosure **)&weak, NULL);
1848 // Consider roots from the stable ptr table.
1849 markStablePtrTable(retainRoot, NULL);
1851 // The following code resets the rs field of each unvisited mutable
1852 // object (computing sumOfNewCostExtra and updating costArray[] when
1853 // debugging retainer profiler).
1854 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1855 // NOT TRUE: even G0 has a block on its mutable list
1856 // ASSERT(g != 0 || (generations[g].mut_list == NULL));
1858 // Traversing through mut_list is necessary
1859 // because we can find MUT_VAR objects which have not been
1860 // visited during retainer profiling.
1861 for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
1862 for (ml = bd->start; ml < bd->free; ml++) {
1864 maybeInitRetainerSet((StgClosure *)*ml);
1865 rtl = retainerSetOf((StgClosure *)*ml);
1867 #ifdef DEBUG_RETAINER
1869 // first visit to *ml
1870 // This is a violation of the interface rule!
1871 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1873 switch (get_itbl((StgClosure *)ml)->type) {
1877 case CONSTR_NOCAF_STATIC:
1881 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1885 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1886 sumOfNewCostExtra += cost((StgClosure *)ml);
1896 /* -----------------------------------------------------------------------------
1897 * Traverse all static objects for which we compute retainer sets,
1898 * and reset their rs fields to NULL, which is accomplished by
1899 * invoking maybeInitRetainerSet(). This function must be called
1900 * before zeroing all objects reachable from scavenged_static_objects
1901 * in the case of major gabage collections. See GarbageCollect() in
1904 * The mut_once_list of the oldest generation must also be traversed?
1905 * Why? Because if the evacuation of an object pointed to by a static
1906 * indirection object fails, it is put back to the mut_once_list of
1907 * the oldest generation.
1908 * However, this is not necessary because any static indirection objects
1909 * are just traversed through to reach dynamic objects. In other words,
1910 * they are not taken into consideration in computing retainer sets.
1911 * -------------------------------------------------------------------------- */
1913 resetStaticObjectForRetainerProfiling( StgClosure *static_objects )
1915 #ifdef DEBUG_RETAINER
1920 #ifdef DEBUG_RETAINER
1924 while (p != END_OF_STATIC_LIST) {
1925 #ifdef DEBUG_RETAINER
1928 switch (get_itbl(p)->type) {
1930 // Since we do not compute the retainer set of any
1931 // IND_STATIC object, we don't have to reset its retainer
1933 p = (StgClosure*)*IND_STATIC_LINK(p);
1936 maybeInitRetainerSet(p);
1937 p = (StgClosure*)*THUNK_STATIC_LINK(p);
1940 maybeInitRetainerSet(p);
1941 p = (StgClosure*)*FUN_STATIC_LINK(p);
1944 maybeInitRetainerSet(p);
1945 p = (StgClosure*)*STATIC_LINK(get_itbl(p), p);
1948 barf("resetStaticObjectForRetainerProfiling: %p (%s)",
1949 p, get_itbl(p)->type);
1953 #ifdef DEBUG_RETAINER
1954 // debugBelch("count in scavenged_static_objects = %d\n", count);
1958 /* -----------------------------------------------------------------------------
1959 * Perform retainer profiling.
1960 * N is the oldest generation being profilied, where the generations are
1961 * numbered starting at 0.
1964 * This function should be called only immediately after major garbage
1966 * ------------------------------------------------------------------------- */
1968 retainerProfile(void)
1970 #ifdef DEBUG_RETAINER
1972 nat totalHeapSize; // total raw heap size (computed by linear scanning)
1975 #ifdef DEBUG_RETAINER
1976 debugBelch(" < retainerProfile() invoked : %d>\n", retainerGeneration);
1981 // We haven't flipped the bit yet.
1982 #ifdef DEBUG_RETAINER
1983 debugBelch("Before traversing:\n");
1984 sumOfCostLinear = 0;
1985 for (i = 0;i < N_CLOSURE_TYPES; i++)
1986 costArrayLinear[i] = 0;
1987 totalHeapSize = checkHeapSanityForRetainerProfiling();
1989 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1991 debugBelch("costArrayLinear[] = ");
1992 for (i = 0;i < N_CLOSURE_TYPES; i++)
1993 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
1997 ASSERT(sumOfCostLinear == totalHeapSize);
2000 #define pcostArrayLinear(index) \
2001 if (costArrayLinear[index] > 0) \
2002 debugBelch("costArrayLinear[" #index "] = %u\n", costArrayLinear[index])
2003 pcostArrayLinear(THUNK_STATIC);
2004 pcostArrayLinear(FUN_STATIC);
2005 pcostArrayLinear(CONSTR_STATIC);
2006 pcostArrayLinear(CONSTR_NOCAF_STATIC);
2010 // Now we flips flip.
2013 #ifdef DEBUG_RETAINER
2019 numObjectVisited = 0;
2020 timesAnyObjectVisited = 0;
2022 #ifdef DEBUG_RETAINER
2023 debugBelch("During traversing:\n");
2025 sumOfNewCostExtra = 0;
2026 for (i = 0;i < N_CLOSURE_TYPES; i++)
2031 We initialize the traverse stack each time the retainer profiling is
2032 performed (because the traverse stack size varies on each retainer profiling
2033 and this operation is not costly anyhow). However, we just refresh the
2036 initializeTraverseStack();
2037 #ifdef DEBUG_RETAINER
2038 initializeAllRetainerSet();
2040 refreshAllRetainerSet();
2042 computeRetainerSet();
2044 #ifdef DEBUG_RETAINER
2045 debugBelch("After traversing:\n");
2046 sumOfCostLinear = 0;
2047 for (i = 0;i < N_CLOSURE_TYPES; i++)
2048 costArrayLinear[i] = 0;
2049 totalHeapSize = checkHeapSanityForRetainerProfiling();
2051 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
2052 ASSERT(sumOfCostLinear == totalHeapSize);
2054 // now, compare the two results
2057 costArray[] must be exactly the same as costArrayLinear[].
2059 1) Dead weak pointers, whose type is CONSTR. These objects are not
2060 reachable from any roots.
2062 debugBelch("Comparison:\n");
2063 debugBelch("\tcostArrayLinear[] (must be empty) = ");
2064 for (i = 0;i < N_CLOSURE_TYPES; i++)
2065 if (costArray[i] != costArrayLinear[i])
2066 // nothing should be printed except MUT_VAR after major GCs
2067 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
2070 debugBelch("\tsumOfNewCost = %u\n", sumOfNewCost);
2071 debugBelch("\tsumOfNewCostExtra = %u\n", sumOfNewCostExtra);
2072 debugBelch("\tcostArray[] (must be empty) = ");
2073 for (i = 0;i < N_CLOSURE_TYPES; i++)
2074 if (costArray[i] != costArrayLinear[i])
2075 // nothing should be printed except MUT_VAR after major GCs
2076 debugBelch("[%u:%u] ", i, costArray[i]);
2079 // only for major garbage collection
2080 ASSERT(sumOfNewCost + sumOfNewCostExtra == sumOfCostLinear);
2084 closeTraverseStack();
2085 #ifdef DEBUG_RETAINER
2086 closeAllRetainerSet();
2088 // Note that there is no post-processing for the retainer sets.
2090 retainerGeneration++;
2093 retainerGeneration - 1, // retainerGeneration has just been incremented!
2094 #ifdef DEBUG_RETAINER
2095 maxCStackSize, maxStackSize,
2097 (double)timesAnyObjectVisited / numObjectVisited);
2100 /* -----------------------------------------------------------------------------
2102 * -------------------------------------------------------------------------- */
2104 #ifdef DEBUG_RETAINER
2106 #define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
2107 ((HEAP_ALLOCED(r) && ((Bdescr((P_)r)->flags & BF_FREE) == 0)))) && \
2108 ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa))
2111 sanityCheckHeapClosure( StgClosure *c )
2115 ASSERT(LOOKS_LIKE_GHC_INFO(c->header.info));
2116 ASSERT(!closure_STATIC(c));
2117 ASSERT(LOOKS_LIKE_PTR(c));
2119 if ((((StgWord)RSET(c) & 1) ^ flip) != 0) {
2120 if (get_itbl(c)->type == CONSTR &&
2121 !strcmp(GET_PROF_TYPE(get_itbl(c)), "DEAD_WEAK") &&
2122 !strcmp(GET_PROF_DESC(get_itbl(c)), "DEAD_WEAK")) {
2123 debugBelch("\tUnvisited dead weak pointer object found: c = %p\n", c);
2124 costArray[get_itbl(c)->type] += cost(c);
2125 sumOfNewCost += cost(c);
2128 "Unvisited object: flip = %d, c = %p(%d, %s, %s), rs = %p\n",
2129 flip, c, get_itbl(c)->type,
2130 get_itbl(c)->prof.closure_type, GET_PROF_DESC(get_itbl(c)),
2133 // debugBelch("sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c));
2136 return closure_sizeW(c);
2140 heapCheck( bdescr *bd )
2143 static nat costSum, size;
2146 while (bd != NULL) {
2148 while (p < bd->free) {
2149 size = sanityCheckHeapClosure((StgClosure *)p);
2150 sumOfCostLinear += size;
2151 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2153 // no need for slop check; I think slops are not used currently.
2155 ASSERT(p == bd->free);
2156 costSum += bd->free - bd->start;
2164 smallObjectPoolCheck(void)
2168 static nat costSum, size;
2178 while (p < alloc_Hp) {
2179 size = sanityCheckHeapClosure((StgClosure *)p);
2180 sumOfCostLinear += size;
2181 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2184 ASSERT(p == alloc_Hp);
2185 costSum += alloc_Hp - bd->start;
2188 while (bd != NULL) {
2190 while (p < bd->free) {
2191 size = sanityCheckHeapClosure((StgClosure *)p);
2192 sumOfCostLinear += size;
2193 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2196 ASSERT(p == bd->free);
2197 costSum += bd->free - bd->start;
2205 chainCheck(bdescr *bd)
2210 while (bd != NULL) {
2211 // bd->free - bd->start is not an accurate measurement of the
2212 // object size. Actually it is always zero, so we compute its
2214 size = sanityCheckHeapClosure((StgClosure *)bd->start);
2215 sumOfCostLinear += size;
2216 costArrayLinear[get_itbl((StgClosure *)bd->start)->type] += size;
2225 checkHeapSanityForRetainerProfiling( void )
2230 debugBelch("START: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2231 if (RtsFlags.GcFlags.generations == 1) {
2232 costSum += heapCheck(g0s0->to_blocks);
2233 debugBelch("heapCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2234 costSum += chainCheck(g0s0->large_objects);
2235 debugBelch("chainCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2237 for (g = 0; g < RtsFlags.GcFlags.generations; g++)
2238 for (s = 0; s < generations[g].n_steps; s++) {
2240 After all live objects have been scavenged, the garbage
2241 collector may create some objects in
2242 scheduleFinalizers(). These objects are created throught
2243 allocate(), so the small object pool or the large object
2244 pool of the g0s0 may not be empty.
2246 if (g == 0 && s == 0) {
2247 costSum += smallObjectPoolCheck();
2248 debugBelch("smallObjectPoolCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2249 costSum += chainCheck(generations[g].steps[s].large_objects);
2250 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2252 costSum += heapCheck(generations[g].steps[s].blocks);
2253 debugBelch("heapCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2254 costSum += chainCheck(generations[g].steps[s].large_objects);
2255 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2264 findPointer(StgPtr p)
2270 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2271 for (s = 0; s < generations[g].n_steps; s++) {
2272 // if (g == 0 && s == 0) continue;
2273 bd = generations[g].steps[s].blocks;
2274 for (; bd; bd = bd->link) {
2275 for (q = bd->start; q < bd->free; q++) {
2276 if (*q == (StgWord)p) {
2278 while (!LOOKS_LIKE_GHC_INFO(*r)) r--;
2279 debugBelch("Found in gen[%d], step[%d]: q = %p, r = %p\n", g, s, q, r);
2284 bd = generations[g].steps[s].large_objects;
2285 for (; bd; bd = bd->link) {
2286 e = bd->start + cost((StgClosure *)bd->start);
2287 for (q = bd->start; q < e; q++) {
2288 if (*q == (StgWord)p) {
2290 while (*r == 0 || !LOOKS_LIKE_GHC_INFO(*r)) r--;
2291 debugBelch("Found in gen[%d], large_objects: %p\n", g, r);
2301 belongToHeap(StgPtr p)
2306 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2307 for (s = 0; s < generations[g].n_steps; s++) {
2308 // if (g == 0 && s == 0) continue;
2309 bd = generations[g].steps[s].blocks;
2310 for (; bd; bd = bd->link) {
2311 if (bd->start <= p && p < bd->free) {
2312 debugBelch("Belongs to gen[%d], step[%d]", g, s);
2316 bd = generations[g].steps[s].large_objects;
2317 for (; bd; bd = bd->link) {
2318 if (bd->start <= p && p < bd->start + getHeapClosureSize((StgClosure *)bd->start)) {
2319 debugBelch("Found in gen[%d], large_objects: %p\n", g, bd->start);
2326 #endif /* DEBUG_RETAINER */
2328 #endif /* PROFILING */