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
495 // head must be TSO and the head of a linked list of TSOs.
496 // Shoule it be a child? Seems to be yes.
497 *first_child = (StgClosure *)((StgMVar *)c)->head;
498 // se.info.type = posTypeStep;
499 se.info.next.step = 2; // 2 = second
502 // three children (fixed), no SRT
504 *first_child = ((StgWeak *)c)->key;
505 // se.info.type = posTypeStep;
506 se.info.next.step = 2;
509 // layout.payload.ptrs, no SRT
514 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
516 *first_child = find_ptrs(&se.info);
517 if (*first_child == NULL)
521 // StgMutArrPtr.ptrs, no SRT
522 case MUT_ARR_PTRS_CLEAN:
523 case MUT_ARR_PTRS_DIRTY:
524 case MUT_ARR_PTRS_FROZEN:
525 case MUT_ARR_PTRS_FROZEN0:
526 init_ptrs(&se.info, ((StgMutArrPtrs *)c)->ptrs,
527 (StgPtr)(((StgMutArrPtrs *)c)->payload));
528 *first_child = find_ptrs(&se.info);
529 if (*first_child == NULL)
533 // layout.payload.ptrs, SRT
534 case FUN: // *c is a heap object.
536 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
537 *first_child = find_ptrs(&se.info);
538 if (*first_child == NULL)
539 // no child from ptrs, so check SRT
545 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
546 (StgPtr)((StgThunk *)c)->payload);
547 *first_child = find_ptrs(&se.info);
548 if (*first_child == NULL)
549 // no child from ptrs, so check SRT
553 // 1 fixed child, SRT
556 *first_child = c->payload[0];
557 ASSERT(*first_child != NULL);
558 init_srt_fun(&se.info, get_fun_itbl(c));
563 *first_child = ((StgThunk *)c)->payload[0];
564 ASSERT(*first_child != NULL);
565 init_srt_thunk(&se.info, get_thunk_itbl(c));
568 case FUN_STATIC: // *c is a heap object.
569 ASSERT(get_itbl(c)->srt_bitmap != 0);
573 init_srt_fun(&se.info, get_fun_itbl(c));
574 *first_child = find_srt(&se.info);
575 if (*first_child == NULL)
581 ASSERT(get_itbl(c)->srt_bitmap != 0);
585 init_srt_thunk(&se.info, get_thunk_itbl(c));
586 *first_child = find_srt(&se.info);
587 if (*first_child == NULL)
591 case TVAR_WATCH_QUEUE:
592 *first_child = (StgClosure *)((StgTVarWatchQueue *)c)->closure;
593 se.info.next.step = 2; // 2 = second
596 *first_child = (StgClosure *)((StgTVar *)c)->current_value;
599 *first_child = (StgClosure *)((StgTRecHeader *)c)->enclosing_trec;
602 *first_child = (StgClosure *)((StgTRecChunk *)c)->prev_chunk;
603 se.info.next.step = 0; // entry no.
612 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
808 if (se->info.next.step == 2) {
809 *c = (StgClosure *)((StgMVar *)se->c)->tail;
810 se->info.next.step++; // move to the next step
813 *c = ((StgMVar *)se->c)->value;
820 // three children (fixed), no SRT
822 if (se->info.next.step == 2) {
823 *c = ((StgWeak *)se->c)->value;
824 se->info.next.step++;
827 *c = ((StgWeak *)se->c)->finalizer;
834 case TVAR_WATCH_QUEUE:
835 if (se->info.next.step == 2) {
836 *c = (StgClosure *)((StgTVarWatchQueue *)se->c)->next_queue_entry;
837 se->info.next.step++; // move to the next step
840 *c = (StgClosure *)((StgTVarWatchQueue *)se->c)->prev_queue_entry;
848 *c = (StgClosure *)((StgTVar *)se->c)->first_watch_queue_entry;
855 *c = (StgClosure *)((StgTRecHeader *)se->c)->current_chunk;
862 // These are pretty complicated: we have N entries, each
863 // of which contains 3 fields that we want to follow. So
864 // we divide the step counter: the 2 low bits indicate
865 // which field, and the rest of the bits indicate the
866 // entry number (starting from zero).
867 nat entry_no = se->info.next.step >> 2;
868 nat field_no = se->info.next.step & 3;
869 if (entry_no == ((StgTRecChunk *)se->c)->next_entry_idx) {
874 TRecEntry *entry = &((StgTRecChunk *)se->c)->entries[entry_no];
876 *c = (StgClosure *)entry->tvar;
877 } else if (field_no == 1) {
878 *c = entry->expected_value;
880 *c = entry->new_value;
884 se->info.next.step++;
892 // StgMutArrPtr.ptrs, no SRT
893 case MUT_ARR_PTRS_CLEAN:
894 case MUT_ARR_PTRS_DIRTY:
895 case MUT_ARR_PTRS_FROZEN:
896 case MUT_ARR_PTRS_FROZEN0:
897 *c = find_ptrs(&se->info);
906 // layout.payload.ptrs, SRT
907 case FUN: // always a heap object
909 if (se->info.type == posTypePtrs) {
910 *c = find_ptrs(&se->info);
916 init_srt_fun(&se->info, get_fun_itbl(se->c));
922 if (se->info.type == posTypePtrs) {
923 *c = find_ptrs(&se->info);
929 init_srt_thunk(&se->info, get_thunk_itbl(se->c));
945 *c = find_srt(&se->info);
954 // no child (fixed), no SRT
960 case SE_CAF_BLACKHOLE:
962 // one child (fixed), no SRT
967 case IND_OLDGEN_PERM:
976 case CONSTR_NOCAF_STATIC:
995 barf("Invalid object *c in pop()");
1001 /* -----------------------------------------------------------------------------
1002 * RETAINER PROFILING ENGINE
1003 * -------------------------------------------------------------------------- */
1006 initRetainerProfiling( void )
1008 initializeAllRetainerSet();
1009 retainerGeneration = 0;
1012 /* -----------------------------------------------------------------------------
1013 * This function must be called before f-closing prof_file.
1014 * -------------------------------------------------------------------------- */
1016 endRetainerProfiling( void )
1018 #ifdef SECOND_APPROACH
1019 outputAllRetainerSet(prof_file);
1023 /* -----------------------------------------------------------------------------
1024 * Returns the actual pointer to the retainer set of the closure *c.
1025 * It may adjust RSET(c) subject to flip.
1027 * RSET(c) is initialized to NULL if its current value does not
1030 * Even though this function has side effects, they CAN be ignored because
1031 * subsequent calls to retainerSetOf() always result in the same return value
1032 * and retainerSetOf() is the only way to retrieve retainerSet of a given
1034 * We have to perform an XOR (^) operation each time a closure is examined.
1035 * The reason is that we do not know when a closure is visited last.
1036 * -------------------------------------------------------------------------- */
1038 maybeInitRetainerSet( StgClosure *c )
1040 if (!isRetainerSetFieldValid(c)) {
1041 setRetainerSetToNull(c);
1045 /* -----------------------------------------------------------------------------
1046 * Returns rtsTrue if *c is a retainer.
1047 * -------------------------------------------------------------------------- */
1048 static INLINE rtsBool
1049 isRetainer( StgClosure *c )
1051 switch (get_itbl(c)->type) {
1055 // TSOs MUST be retainers: they constitute the set of roots.
1062 case MUT_ARR_PTRS_CLEAN:
1063 case MUT_ARR_PTRS_DIRTY:
1064 case MUT_ARR_PTRS_FROZEN:
1065 case MUT_ARR_PTRS_FROZEN0:
1067 // thunks are retainers.
1074 case THUNK_SELECTOR:
1078 // Static thunks, or CAFS, are obviously retainers.
1081 // WEAK objects are roots; there is separate code in which traversing
1082 // begins from WEAK objects.
1085 // Since the other mutvar-type things are retainers, seems
1086 // like the right thing to do:
1108 // partial applications
1114 case SE_CAF_BLACKHOLE:
1117 case IND_OLDGEN_PERM:
1127 case TVAR_WATCH_QUEUE:
1135 // IND_STATIC cannot be *c, *cp, *r in the retainer profiling loop.
1137 // CONSTR_NOCAF_STATIC
1138 // cannot be *c, *cp, *r in the retainer profiling loop.
1139 case CONSTR_NOCAF_STATIC:
1140 // Stack objects are invalid because they are never treated as
1141 // legal objects during retainer profiling.
1157 case INVALID_OBJECT:
1159 barf("Invalid object in isRetainer(): %d", get_itbl(c)->type);
1164 /* -----------------------------------------------------------------------------
1165 * Returns the retainer function value for the closure *c, i.e., R(*c).
1166 * This function does NOT return the retainer(s) of *c.
1168 * *c must be a retainer.
1170 * Depending on the definition of this function, the maintenance of retainer
1171 * sets can be made easier. If most retainer sets are likely to be created
1172 * again across garbage collections, refreshAllRetainerSet() in
1173 * RetainerSet.c can simply do nothing.
1174 * If this is not the case, we can free all the retainer sets and
1175 * re-initialize the hash table.
1176 * See refreshAllRetainerSet() in RetainerSet.c.
1177 * -------------------------------------------------------------------------- */
1178 static INLINE retainer
1179 getRetainerFrom( StgClosure *c )
1181 ASSERT(isRetainer(c));
1183 #if defined(RETAINER_SCHEME_INFO)
1184 // Retainer scheme 1: retainer = info table
1186 #elif defined(RETAINER_SCHEME_CCS)
1187 // Retainer scheme 2: retainer = cost centre stack
1188 return c->header.prof.ccs;
1189 #elif defined(RETAINER_SCHEME_CC)
1190 // Retainer scheme 3: retainer = cost centre
1191 return c->header.prof.ccs->cc;
1195 /* -----------------------------------------------------------------------------
1196 * Associates the retainer set *s with the closure *c, that is, *s becomes
1197 * the retainer set of *c.
1201 * -------------------------------------------------------------------------- */
1203 associate( StgClosure *c, RetainerSet *s )
1205 // StgWord has the same size as pointers, so the following type
1207 RSET(c) = (RetainerSet *)((StgWord)s | flip);
1210 /* -----------------------------------------------------------------------------
1211 Call retainClosure for each of the closures covered by a large bitmap.
1212 -------------------------------------------------------------------------- */
1215 retain_large_bitmap (StgPtr p, StgLargeBitmap *large_bitmap, nat size,
1216 StgClosure *c, retainer c_child_r)
1222 bitmap = large_bitmap->bitmap[b];
1223 for (i = 0; i < size; ) {
1224 if ((bitmap & 1) == 0) {
1225 retainClosure((StgClosure *)*p, c, c_child_r);
1229 if (i % BITS_IN(W_) == 0) {
1231 bitmap = large_bitmap->bitmap[b];
1233 bitmap = bitmap >> 1;
1238 static INLINE StgPtr
1239 retain_small_bitmap (StgPtr p, nat size, StgWord bitmap,
1240 StgClosure *c, retainer c_child_r)
1243 if ((bitmap & 1) == 0) {
1244 retainClosure((StgClosure *)*p, c, c_child_r);
1247 bitmap = bitmap >> 1;
1253 /* -----------------------------------------------------------------------------
1254 * Call retainClosure for each of the closures in an SRT.
1255 * ------------------------------------------------------------------------- */
1258 retain_large_srt_bitmap (StgLargeSRT *srt, StgClosure *c, retainer c_child_r)
1265 p = (StgClosure **)srt->srt;
1267 bitmap = srt->l.bitmap[b];
1268 for (i = 0; i < size; ) {
1269 if ((bitmap & 1) != 0) {
1270 retainClosure((StgClosure *)*p, c, c_child_r);
1274 if (i % BITS_IN(W_) == 0) {
1276 bitmap = srt->l.bitmap[b];
1278 bitmap = bitmap >> 1;
1284 retainSRT (StgClosure **srt, nat srt_bitmap, StgClosure *c, retainer c_child_r)
1289 bitmap = srt_bitmap;
1292 if (bitmap == (StgHalfWord)(-1)) {
1293 retain_large_srt_bitmap( (StgLargeSRT *)srt, c, c_child_r );
1297 while (bitmap != 0) {
1298 if ((bitmap & 1) != 0) {
1299 #ifdef ENABLE_WIN32_DLL_SUPPORT
1300 if ( (unsigned long)(*srt) & 0x1 ) {
1301 retainClosure(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)),
1304 retainClosure(*srt,c,c_child_r);
1307 retainClosure(*srt,c,c_child_r);
1311 bitmap = bitmap >> 1;
1315 /* -----------------------------------------------------------------------------
1316 * Process all the objects in the stack chunk from stackStart to stackEnd
1317 * with *c and *c_child_r being their parent and their most recent retainer,
1318 * respectively. Treat stackOptionalFun as another child of *c if it is
1321 * *c is one of the following: TSO, AP_STACK.
1322 * If *c is TSO, c == c_child_r.
1323 * stackStart < stackEnd.
1324 * RSET(c) and RSET(c_child_r) are valid, i.e., their
1325 * interpretation conforms to the current value of flip (even when they
1326 * are interpreted to be NULL).
1327 * If *c is TSO, its state is not any of ThreadRelocated, ThreadComplete,
1328 * or ThreadKilled, which means that its stack is ready to process.
1330 * This code was almost plagiarzied from GC.c! For each pointer,
1331 * retainClosure() is invoked instead of evacuate().
1332 * -------------------------------------------------------------------------- */
1334 retainStack( StgClosure *c, retainer c_child_r,
1335 StgPtr stackStart, StgPtr stackEnd )
1337 stackElement *oldStackBoundary;
1339 StgRetInfoTable *info;
1343 #ifdef DEBUG_RETAINER
1345 if (cStackSize > maxCStackSize) maxCStackSize = cStackSize;
1349 Each invocation of retainStack() creates a new virtual
1350 stack. Since all such stacks share a single common stack, we
1351 record the current currentStackBoundary, which will be restored
1354 oldStackBoundary = currentStackBoundary;
1355 currentStackBoundary = stackTop;
1357 #ifdef DEBUG_RETAINER
1358 // debugBelch("retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
1361 ASSERT(get_itbl(c)->type != TSO ||
1362 (((StgTSO *)c)->what_next != ThreadRelocated &&
1363 ((StgTSO *)c)->what_next != ThreadComplete &&
1364 ((StgTSO *)c)->what_next != ThreadKilled));
1367 while (p < stackEnd) {
1368 info = get_ret_itbl((StgClosure *)p);
1370 switch(info->i.type) {
1373 retainClosure(((StgUpdateFrame *)p)->updatee, c, c_child_r);
1374 p += sizeofW(StgUpdateFrame);
1379 case CATCH_STM_FRAME:
1380 case CATCH_RETRY_FRAME:
1381 case ATOMICALLY_FRAME:
1383 bitmap = BITMAP_BITS(info->i.layout.bitmap);
1384 size = BITMAP_SIZE(info->i.layout.bitmap);
1386 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1389 retainSRT((StgClosure **)GET_SRT(info), info->i.srt_bitmap, c, c_child_r);
1396 retainClosure((StgClosure *)*p, c, c_child_r);
1399 size = BCO_BITMAP_SIZE(bco);
1400 retain_large_bitmap(p, BCO_BITMAP(bco), size, c, c_child_r);
1405 // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
1407 size = GET_LARGE_BITMAP(&info->i)->size;
1409 retain_large_bitmap(p, GET_LARGE_BITMAP(&info->i),
1410 size, c, c_child_r);
1412 // and don't forget to follow the SRT
1415 // Dynamic bitmap: the mask is stored on the stack
1418 dyn = ((StgRetDyn *)p)->liveness;
1420 // traverse the bitmap first
1421 bitmap = RET_DYN_LIVENESS(dyn);
1422 p = (P_)&((StgRetDyn *)p)->payload[0];
1423 size = RET_DYN_BITMAP_SIZE;
1424 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1426 // skip over the non-ptr words
1427 p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
1429 // follow the ptr words
1430 for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
1431 retainClosure((StgClosure *)*p, c, c_child_r);
1438 StgRetFun *ret_fun = (StgRetFun *)p;
1439 StgFunInfoTable *fun_info;
1441 retainClosure(ret_fun->fun, c, c_child_r);
1442 fun_info = get_fun_itbl(ret_fun->fun);
1444 p = (P_)&ret_fun->payload;
1445 switch (fun_info->f.fun_type) {
1447 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
1448 size = BITMAP_SIZE(fun_info->f.b.bitmap);
1449 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1452 size = GET_FUN_LARGE_BITMAP(fun_info)->size;
1453 retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
1454 size, c, c_child_r);
1458 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1459 size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
1460 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1467 barf("Invalid object found in retainStack(): %d",
1468 (int)(info->i.type));
1472 // restore currentStackBoundary
1473 currentStackBoundary = oldStackBoundary;
1474 #ifdef DEBUG_RETAINER
1475 // debugBelch("retainStack() finished: currentStackBoundary = 0x%x\n", currentStackBoundary);
1478 #ifdef DEBUG_RETAINER
1483 /* ----------------------------------------------------------------------------
1484 * Call retainClosure for each of the children of a PAP/AP
1485 * ------------------------------------------------------------------------- */
1487 static INLINE StgPtr
1488 retain_PAP_payload (StgClosure *pap, /* NOT tagged */
1489 retainer c_child_r, /* NOT tagged */
1490 StgClosure *fun, /* tagged */
1491 StgClosure** payload, StgWord n_args)
1495 StgFunInfoTable *fun_info;
1497 retainClosure(fun, pap, c_child_r);
1498 fun = UNTAG_CLOSURE(fun);
1499 fun_info = get_fun_itbl(fun);
1500 ASSERT(fun_info->i.type != PAP);
1502 p = (StgPtr)payload;
1504 switch (fun_info->f.fun_type) {
1506 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
1507 p = retain_small_bitmap(p, n_args, bitmap,
1511 retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
1512 n_args, pap, c_child_r);
1516 retain_large_bitmap((StgPtr)payload, BCO_BITMAP(fun),
1517 n_args, pap, c_child_r);
1521 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1522 p = retain_small_bitmap(p, n_args, bitmap, pap, c_child_r);
1528 /* -----------------------------------------------------------------------------
1529 * Compute the retainer set of *c0 and all its desecents by traversing.
1530 * *cp0 is the parent of *c0, and *r0 is the most recent retainer of *c0.
1532 * c0 = cp0 = r0 holds only for root objects.
1533 * RSET(cp0) and RSET(r0) are valid, i.e., their
1534 * interpretation conforms to the current value of flip (even when they
1535 * are interpreted to be NULL).
1536 * However, RSET(c0) may be corrupt, i.e., it may not conform to
1537 * the current value of flip. If it does not, during the execution
1538 * of this function, RSET(c0) must be initialized as well as all
1541 * stackTop must be the same at the beginning and the exit of this function.
1542 * *c0 can be TSO (as well as AP_STACK).
1543 * -------------------------------------------------------------------------- */
1545 retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
1547 // c = Current closure (possibly tagged)
1548 // cp = Current closure's Parent (NOT tagged)
1549 // r = current closures' most recent Retainer (NOT tagged)
1550 // c_child_r = current closure's children's most recent retainer
1551 // first_child = first child of c
1552 StgClosure *c, *cp, *first_child;
1553 RetainerSet *s, *retainerSetOfc;
1554 retainer r, c_child_r;
1557 #ifdef DEBUG_RETAINER
1558 // StgPtr oldStackTop;
1561 #ifdef DEBUG_RETAINER
1562 // oldStackTop = stackTop;
1563 // debugBelch("retainClosure() called: c0 = 0x%x, cp0 = 0x%x, r0 = 0x%x\n", c0, cp0, r0);
1566 // (c, cp, r) = (c0, cp0, r0)
1573 //debugBelch("loop");
1574 // pop to (c, cp, r);
1578 #ifdef DEBUG_RETAINER
1579 // debugBelch("retainClosure() ends: oldStackTop = 0x%x, stackTop = 0x%x\n", oldStackTop, stackTop);
1584 //debugBelch("inner_loop");
1587 c = UNTAG_CLOSURE(c);
1589 // c = current closure under consideration,
1590 // cp = current closure's parent,
1591 // r = current closure's most recent retainer
1593 // Loop invariants (on the meaning of c, cp, r, and their retainer sets):
1594 // RSET(cp) and RSET(r) are valid.
1595 // RSET(c) is valid only if c has been visited before.
1597 // Loop invariants (on the relation between c, cp, and r)
1598 // if cp is not a retainer, r belongs to RSET(cp).
1599 // if cp is a retainer, r == cp.
1601 typeOfc = get_itbl(c)->type;
1603 #ifdef DEBUG_RETAINER
1606 case CONSTR_NOCAF_STATIC:
1612 if (retainerSetOf(c) == NULL) { // first visit?
1613 costArray[typeOfc] += cost(c);
1614 sumOfNewCost += cost(c);
1623 if (((StgTSO *)c)->what_next == ThreadComplete ||
1624 ((StgTSO *)c)->what_next == ThreadKilled) {
1625 #ifdef DEBUG_RETAINER
1626 debugBelch("ThreadComplete or ThreadKilled encountered in retainClosure()\n");
1630 if (((StgTSO *)c)->what_next == ThreadRelocated) {
1631 #ifdef DEBUG_RETAINER
1632 debugBelch("ThreadRelocated encountered in retainClosure()\n");
1634 c = (StgClosure *)((StgTSO *)c)->link;
1640 // We just skip IND_STATIC, so its retainer set is never computed.
1641 c = ((StgIndStatic *)c)->indirectee;
1643 // static objects with no pointers out, so goto loop.
1644 case CONSTR_NOCAF_STATIC:
1645 // It is not just enough not to compute the retainer set for *c; it is
1646 // mandatory because CONSTR_NOCAF_STATIC are not reachable from
1647 // scavenged_static_objects, the list from which is assumed to traverse
1648 // all static objects after major garbage collections.
1652 if (get_itbl(c)->srt_bitmap == 0) {
1653 // No need to compute the retainer set; no dynamic objects
1654 // are reachable from *c.
1656 // Static objects: if we traverse all the live closures,
1657 // including static closures, during each heap census then
1658 // we will observe that some static closures appear and
1659 // disappear. eg. a closure may contain a pointer to a
1660 // static function 'f' which is not otherwise reachable
1661 // (it doesn't indirectly point to any CAFs, so it doesn't
1662 // appear in any SRTs), so we would find 'f' during
1663 // traversal. However on the next sweep there may be no
1664 // closures pointing to 'f'.
1666 // We must therefore ignore static closures whose SRT is
1667 // empty, because these are exactly the closures that may
1668 // "appear". A closure with a non-empty SRT, and which is
1669 // still required, will always be reachable.
1671 // But what about CONSTR_STATIC? Surely these may be able
1672 // to appear, and they don't have SRTs, so we can't
1673 // check. So for now, we're calling
1674 // resetStaticObjectForRetainerProfiling() from the
1675 // garbage collector to reset the retainer sets in all the
1676 // reachable static objects.
1683 // The above objects are ignored in computing the average number of times
1684 // an object is visited.
1685 timesAnyObjectVisited++;
1687 // If this is the first visit to c, initialize its retainer set.
1688 maybeInitRetainerSet(c);
1689 retainerSetOfc = retainerSetOf(c);
1692 // isRetainer(cp) == rtsTrue => s == NULL
1693 // isRetainer(cp) == rtsFalse => s == cp.retainer
1697 s = retainerSetOf(cp);
1699 // (c, cp, r, s) is available.
1701 // (c, cp, r, s, R_r) is available, so compute the retainer set for *c.
1702 if (retainerSetOfc == NULL) {
1703 // This is the first visit to *c.
1707 associate(c, singleton(r));
1709 // s is actually the retainer set of *c!
1712 // compute c_child_r
1713 c_child_r = isRetainer(c) ? getRetainerFrom(c) : r;
1715 // This is not the first visit to *c.
1716 if (isMember(r, retainerSetOfc))
1717 goto loop; // no need to process child
1720 associate(c, addElement(r, retainerSetOfc));
1722 // s is not NULL and cp is not a retainer. This means that
1723 // each time *cp is visited, so is *c. Thus, if s has
1724 // exactly one more element in its retainer set than c, s
1725 // is also the new retainer set for *c.
1726 if (s->num == retainerSetOfc->num + 1) {
1729 // Otherwise, just add R_r to the current retainer set of *c.
1731 associate(c, addElement(r, retainerSetOfc));
1736 goto loop; // no need to process child
1738 // compute c_child_r
1742 // now, RSET() of all of *c, *cp, and *r is valid.
1743 // (c, c_child_r) are available.
1747 // Special case closures: we process these all in one go rather
1748 // than attempting to save the current position, because doing so
1752 retainStack(c, c_child_r,
1754 ((StgTSO *)c)->stack + ((StgTSO *)c)->stack_size);
1759 StgPAP *pap = (StgPAP *)c;
1760 retain_PAP_payload(c, c_child_r, pap->fun, pap->payload, pap->n_args);
1766 StgAP *ap = (StgAP *)c;
1767 retain_PAP_payload(c, c_child_r, ap->fun, ap->payload, ap->n_args);
1772 retainClosure(((StgAP_STACK *)c)->fun, c, c_child_r);
1773 retainStack(c, c_child_r,
1774 (StgPtr)((StgAP_STACK *)c)->payload,
1775 (StgPtr)((StgAP_STACK *)c)->payload +
1776 ((StgAP_STACK *)c)->size);
1780 push(c, c_child_r, &first_child);
1782 // If first_child is null, c has no child.
1783 // If first_child is not null, the top stack element points to the next
1784 // object. push() may or may not push a stackElement on the stack.
1785 if (first_child == NULL)
1788 // (c, cp, r) = (first_child, c, c_child_r)
1795 /* -----------------------------------------------------------------------------
1796 * Compute the retainer set for every object reachable from *tl.
1797 * -------------------------------------------------------------------------- */
1799 retainRoot( StgClosure **tl )
1803 // We no longer assume that only TSOs and WEAKs are roots; any closure can
1806 ASSERT(isEmptyRetainerStack());
1807 currentStackBoundary = stackTop;
1809 c = UNTAG_CLOSURE(*tl);
1810 if (c != &stg_END_TSO_QUEUE_closure && isRetainer(c)) {
1811 retainClosure(c, c, getRetainerFrom(c));
1813 retainClosure(c, c, CCS_SYSTEM);
1816 // NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl)));
1817 // *tl might be a TSO which is ThreadComplete, in which
1818 // case we ignore it for the purposes of retainer profiling.
1821 /* -----------------------------------------------------------------------------
1822 * Compute the retainer set for each of the objects in the heap.
1823 * -------------------------------------------------------------------------- */
1825 computeRetainerSet( void )
1832 #ifdef DEBUG_RETAINER
1833 RetainerSet tmpRetainerSet;
1836 GetRoots(retainRoot); // for scheduler roots
1838 // This function is called after a major GC, when key, value, and finalizer
1839 // all are guaranteed to be valid, or reachable.
1841 // The following code assumes that WEAK objects are considered to be roots
1842 // for retainer profilng.
1843 for (weak = weak_ptr_list; weak != NULL; weak = weak->link)
1844 // retainRoot((StgClosure *)weak);
1845 retainRoot((StgClosure **)&weak);
1847 // Consider roots from the stable ptr table.
1848 markStablePtrTable(retainRoot);
1850 // The following code resets the rs field of each unvisited mutable
1851 // object (computing sumOfNewCostExtra and updating costArray[] when
1852 // debugging retainer profiler).
1853 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1854 // NOT TRUE: even G0 has a block on its mutable list
1855 // ASSERT(g != 0 || (generations[g].mut_list == NULL));
1857 // Traversing through mut_list is necessary
1858 // because we can find MUT_VAR objects which have not been
1859 // visited during retainer profiling.
1860 for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
1861 for (ml = bd->start; ml < bd->free; ml++) {
1863 maybeInitRetainerSet((StgClosure *)*ml);
1864 rtl = retainerSetOf((StgClosure *)*ml);
1866 #ifdef DEBUG_RETAINER
1868 // first visit to *ml
1869 // This is a violation of the interface rule!
1870 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1872 switch (get_itbl((StgClosure *)ml)->type) {
1876 case CONSTR_NOCAF_STATIC:
1880 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1884 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1885 sumOfNewCostExtra += cost((StgClosure *)ml);
1895 /* -----------------------------------------------------------------------------
1896 * Traverse all static objects for which we compute retainer sets,
1897 * and reset their rs fields to NULL, which is accomplished by
1898 * invoking maybeInitRetainerSet(). This function must be called
1899 * before zeroing all objects reachable from scavenged_static_objects
1900 * in the case of major gabage collections. See GarbageCollect() in
1903 * The mut_once_list of the oldest generation must also be traversed?
1904 * Why? Because if the evacuation of an object pointed to by a static
1905 * indirection object fails, it is put back to the mut_once_list of
1906 * the oldest generation.
1907 * However, this is not necessary because any static indirection objects
1908 * are just traversed through to reach dynamic objects. In other words,
1909 * they are not taken into consideration in computing retainer sets.
1910 * -------------------------------------------------------------------------- */
1912 resetStaticObjectForRetainerProfiling( void )
1914 #ifdef DEBUG_RETAINER
1919 #ifdef DEBUG_RETAINER
1922 p = scavenged_static_objects;
1923 while (p != END_OF_STATIC_LIST) {
1924 #ifdef DEBUG_RETAINER
1927 switch (get_itbl(p)->type) {
1929 // Since we do not compute the retainer set of any
1930 // IND_STATIC object, we don't have to reset its retainer
1932 p = (StgClosure*)*IND_STATIC_LINK(p);
1935 maybeInitRetainerSet(p);
1936 p = (StgClosure*)*THUNK_STATIC_LINK(p);
1939 maybeInitRetainerSet(p);
1940 p = (StgClosure*)*FUN_STATIC_LINK(p);
1943 maybeInitRetainerSet(p);
1944 p = (StgClosure*)*STATIC_LINK(get_itbl(p), p);
1947 barf("resetStaticObjectForRetainerProfiling: %p (%s)",
1948 p, get_itbl(p)->type);
1952 #ifdef DEBUG_RETAINER
1953 // debugBelch("count in scavenged_static_objects = %d\n", count);
1957 /* -----------------------------------------------------------------------------
1958 * Perform retainer profiling.
1959 * N is the oldest generation being profilied, where the generations are
1960 * numbered starting at 0.
1963 * This function should be called only immediately after major garbage
1965 * ------------------------------------------------------------------------- */
1967 retainerProfile(void)
1969 #ifdef DEBUG_RETAINER
1971 nat totalHeapSize; // total raw heap size (computed by linear scanning)
1974 #ifdef DEBUG_RETAINER
1975 debugBelch(" < retainerProfile() invoked : %d>\n", retainerGeneration);
1980 // We haven't flipped the bit yet.
1981 #ifdef DEBUG_RETAINER
1982 debugBelch("Before traversing:\n");
1983 sumOfCostLinear = 0;
1984 for (i = 0;i < N_CLOSURE_TYPES; i++)
1985 costArrayLinear[i] = 0;
1986 totalHeapSize = checkHeapSanityForRetainerProfiling();
1988 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1990 debugBelch("costArrayLinear[] = ");
1991 for (i = 0;i < N_CLOSURE_TYPES; i++)
1992 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
1996 ASSERT(sumOfCostLinear == totalHeapSize);
1999 #define pcostArrayLinear(index) \
2000 if (costArrayLinear[index] > 0) \
2001 debugBelch("costArrayLinear[" #index "] = %u\n", costArrayLinear[index])
2002 pcostArrayLinear(THUNK_STATIC);
2003 pcostArrayLinear(FUN_STATIC);
2004 pcostArrayLinear(CONSTR_STATIC);
2005 pcostArrayLinear(CONSTR_NOCAF_STATIC);
2009 // Now we flips flip.
2012 #ifdef DEBUG_RETAINER
2018 numObjectVisited = 0;
2019 timesAnyObjectVisited = 0;
2021 #ifdef DEBUG_RETAINER
2022 debugBelch("During traversing:\n");
2024 sumOfNewCostExtra = 0;
2025 for (i = 0;i < N_CLOSURE_TYPES; i++)
2030 We initialize the traverse stack each time the retainer profiling is
2031 performed (because the traverse stack size varies on each retainer profiling
2032 and this operation is not costly anyhow). However, we just refresh the
2035 initializeTraverseStack();
2036 #ifdef DEBUG_RETAINER
2037 initializeAllRetainerSet();
2039 refreshAllRetainerSet();
2041 computeRetainerSet();
2043 #ifdef DEBUG_RETAINER
2044 debugBelch("After traversing:\n");
2045 sumOfCostLinear = 0;
2046 for (i = 0;i < N_CLOSURE_TYPES; i++)
2047 costArrayLinear[i] = 0;
2048 totalHeapSize = checkHeapSanityForRetainerProfiling();
2050 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
2051 ASSERT(sumOfCostLinear == totalHeapSize);
2053 // now, compare the two results
2056 costArray[] must be exactly the same as costArrayLinear[].
2058 1) Dead weak pointers, whose type is CONSTR. These objects are not
2059 reachable from any roots.
2061 debugBelch("Comparison:\n");
2062 debugBelch("\tcostArrayLinear[] (must be empty) = ");
2063 for (i = 0;i < N_CLOSURE_TYPES; i++)
2064 if (costArray[i] != costArrayLinear[i])
2065 // nothing should be printed except MUT_VAR after major GCs
2066 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
2069 debugBelch("\tsumOfNewCost = %u\n", sumOfNewCost);
2070 debugBelch("\tsumOfNewCostExtra = %u\n", sumOfNewCostExtra);
2071 debugBelch("\tcostArray[] (must be empty) = ");
2072 for (i = 0;i < N_CLOSURE_TYPES; i++)
2073 if (costArray[i] != costArrayLinear[i])
2074 // nothing should be printed except MUT_VAR after major GCs
2075 debugBelch("[%u:%u] ", i, costArray[i]);
2078 // only for major garbage collection
2079 ASSERT(sumOfNewCost + sumOfNewCostExtra == sumOfCostLinear);
2083 closeTraverseStack();
2084 #ifdef DEBUG_RETAINER
2085 closeAllRetainerSet();
2087 // Note that there is no post-processing for the retainer sets.
2089 retainerGeneration++;
2092 retainerGeneration - 1, // retainerGeneration has just been incremented!
2093 #ifdef DEBUG_RETAINER
2094 maxCStackSize, maxStackSize,
2096 (double)timesAnyObjectVisited / numObjectVisited);
2099 /* -----------------------------------------------------------------------------
2101 * -------------------------------------------------------------------------- */
2103 #ifdef DEBUG_RETAINER
2105 #define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
2106 ((HEAP_ALLOCED(r) && ((Bdescr((P_)r)->flags & BF_FREE) == 0)))) && \
2107 ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa))
2110 sanityCheckHeapClosure( StgClosure *c )
2114 ASSERT(LOOKS_LIKE_GHC_INFO(c->header.info));
2115 ASSERT(!closure_STATIC(c));
2116 ASSERT(LOOKS_LIKE_PTR(c));
2118 if ((((StgWord)RSET(c) & 1) ^ flip) != 0) {
2119 if (get_itbl(c)->type == CONSTR &&
2120 !strcmp(GET_PROF_TYPE(get_itbl(c)), "DEAD_WEAK") &&
2121 !strcmp(GET_PROF_DESC(get_itbl(c)), "DEAD_WEAK")) {
2122 debugBelch("\tUnvisited dead weak pointer object found: c = %p\n", c);
2123 costArray[get_itbl(c)->type] += cost(c);
2124 sumOfNewCost += cost(c);
2127 "Unvisited object: flip = %d, c = %p(%d, %s, %s), rs = %p\n",
2128 flip, c, get_itbl(c)->type,
2129 get_itbl(c)->prof.closure_type, GET_PROF_DESC(get_itbl(c)),
2132 // debugBelch("sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c));
2135 return closure_sizeW(c);
2139 heapCheck( bdescr *bd )
2142 static nat costSum, size;
2145 while (bd != NULL) {
2147 while (p < bd->free) {
2148 size = sanityCheckHeapClosure((StgClosure *)p);
2149 sumOfCostLinear += size;
2150 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2152 // no need for slop check; I think slops are not used currently.
2154 ASSERT(p == bd->free);
2155 costSum += bd->free - bd->start;
2163 smallObjectPoolCheck(void)
2167 static nat costSum, size;
2169 bd = small_alloc_list;
2177 while (p < alloc_Hp) {
2178 size = sanityCheckHeapClosure((StgClosure *)p);
2179 sumOfCostLinear += size;
2180 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2183 ASSERT(p == alloc_Hp);
2184 costSum += alloc_Hp - bd->start;
2187 while (bd != NULL) {
2189 while (p < bd->free) {
2190 size = sanityCheckHeapClosure((StgClosure *)p);
2191 sumOfCostLinear += size;
2192 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2195 ASSERT(p == bd->free);
2196 costSum += bd->free - bd->start;
2204 chainCheck(bdescr *bd)
2209 while (bd != NULL) {
2210 // bd->free - bd->start is not an accurate measurement of the
2211 // object size. Actually it is always zero, so we compute its
2213 size = sanityCheckHeapClosure((StgClosure *)bd->start);
2214 sumOfCostLinear += size;
2215 costArrayLinear[get_itbl((StgClosure *)bd->start)->type] += size;
2224 checkHeapSanityForRetainerProfiling( void )
2229 debugBelch("START: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2230 if (RtsFlags.GcFlags.generations == 1) {
2231 costSum += heapCheck(g0s0->to_blocks);
2232 debugBelch("heapCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2233 costSum += chainCheck(g0s0->large_objects);
2234 debugBelch("chainCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2236 for (g = 0; g < RtsFlags.GcFlags.generations; g++)
2237 for (s = 0; s < generations[g].n_steps; s++) {
2239 After all live objects have been scavenged, the garbage
2240 collector may create some objects in
2241 scheduleFinalizers(). These objects are created throught
2242 allocate(), so the small object pool or the large object
2243 pool of the g0s0 may not be empty.
2245 if (g == 0 && s == 0) {
2246 costSum += smallObjectPoolCheck();
2247 debugBelch("smallObjectPoolCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2248 costSum += chainCheck(generations[g].steps[s].large_objects);
2249 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2251 costSum += heapCheck(generations[g].steps[s].blocks);
2252 debugBelch("heapCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2253 costSum += chainCheck(generations[g].steps[s].large_objects);
2254 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2263 findPointer(StgPtr p)
2269 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2270 for (s = 0; s < generations[g].n_steps; s++) {
2271 // if (g == 0 && s == 0) continue;
2272 bd = generations[g].steps[s].blocks;
2273 for (; bd; bd = bd->link) {
2274 for (q = bd->start; q < bd->free; q++) {
2275 if (*q == (StgWord)p) {
2277 while (!LOOKS_LIKE_GHC_INFO(*r)) r--;
2278 debugBelch("Found in gen[%d], step[%d]: q = %p, r = %p\n", g, s, q, r);
2283 bd = generations[g].steps[s].large_objects;
2284 for (; bd; bd = bd->link) {
2285 e = bd->start + cost((StgClosure *)bd->start);
2286 for (q = bd->start; q < e; q++) {
2287 if (*q == (StgWord)p) {
2289 while (*r == 0 || !LOOKS_LIKE_GHC_INFO(*r)) r--;
2290 debugBelch("Found in gen[%d], large_objects: %p\n", g, r);
2300 belongToHeap(StgPtr p)
2305 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2306 for (s = 0; s < generations[g].n_steps; s++) {
2307 // if (g == 0 && s == 0) continue;
2308 bd = generations[g].steps[s].blocks;
2309 for (; bd; bd = bd->link) {
2310 if (bd->start <= p && p < bd->free) {
2311 debugBelch("Belongs to gen[%d], step[%d]", g, s);
2315 bd = generations[g].steps[s].large_objects;
2316 for (; bd; bd = bd->link) {
2317 if (bd->start <= p && p < bd->start + getHeapClosureSize((StgClosure *)bd->start)) {
2318 debugBelch("Found in gen[%d], large_objects: %p\n", g, bd->start);
2325 #endif /* DEBUG_RETAINER */
2327 #endif /* PROFILING */