1 /* -----------------------------------------------------------------------------
3 * (c) The GHC Team, 2001
8 * ---------------------------------------------------------------------------*/
12 // Turn off inlining when debugging - it obfuscates things
19 #include "PosixSource.h"
23 #include "RetainerProfile.h"
24 #include "RetainerSet.h"
29 #include "Profiling.h"
35 Note: what to change in order to plug-in a new retainer profiling scheme?
36 (1) type retainer in ../includes/StgRetainerProf.h
37 (2) retainer function R(), i.e., getRetainerFrom()
38 (3) the two hashing functions, hashKeySingleton() and hashKeyAddElement(),
39 in RetainerSet.h, if needed.
40 (4) printRetainer() and printRetainerSetShort() in RetainerSet.c.
43 /* -----------------------------------------------------------------------------
45 * -------------------------------------------------------------------------- */
47 static nat retainerGeneration; // generation
49 static nat numObjectVisited; // total number of objects visited
50 static nat timesAnyObjectVisited; // number of times any objects are visited
53 The rs field in the profile header of any object points to its retainer
54 set in an indirect way: if flip is 0, it points to the retainer set;
55 if flip is 1, it points to the next byte after the retainer set (even
56 for NULL pointers). Therefore, with flip 1, (rs ^ 1) is the actual
57 pointer. See retainerSetOf().
60 StgWord flip = 0; // flip bit
61 // must be 0 if DEBUG_RETAINER is on (for static closures)
63 #define setRetainerSetToNull(c) \
64 (c)->header.prof.hp.rs = (RetainerSet *)((StgWord)NULL | flip)
66 static void retainStack(StgClosure *, retainer, StgPtr, StgPtr);
67 static void retainClosure(StgClosure *, StgClosure *, retainer);
69 static void belongToHeap(StgPtr p);
74 cStackSize records how many times retainStack() has been invoked recursively,
75 that is, the number of activation records for retainStack() on the C stack.
76 maxCStackSize records its max value.
78 cStackSize <= maxCStackSize
80 static nat cStackSize, maxCStackSize;
82 static nat sumOfNewCost; // sum of the cost of each object, computed
83 // when the object is first visited
84 static nat sumOfNewCostExtra; // for those objects not visited during
85 // retainer profiling, e.g., MUT_VAR
86 static nat costArray[N_CLOSURE_TYPES];
88 nat sumOfCostLinear; // sum of the costs of all object, computed
89 // when linearly traversing the heap after
91 nat costArrayLinear[N_CLOSURE_TYPES];
94 /* -----------------------------------------------------------------------------
95 * Retainer stack - header
97 * Although the retainer stack implementation could be separated *
98 * from the retainer profiling engine, there does not seem to be
99 * any advantage in doing that; retainer stack is an integral part
100 * of retainer profiling engine and cannot be use elsewhere at
102 * -------------------------------------------------------------------------- */
112 // fixed layout or layout specified by a field in the closure
117 // See StgClosureInfo in InfoTables.h
118 #if SIZEOF_VOID_P == 8
155 firstStack points to the first block group.
156 currentStack points to the block group currently being used.
157 currentStack->free == stackLimit.
158 stackTop points to the topmost byte in the stack of currentStack.
159 Unless the whole stack is empty, stackTop must point to the topmost
160 object (or byte) in the whole stack. Thus, it is only when the whole stack
161 is empty that stackTop == stackLimit (not during the execution of push()
163 stackBottom == currentStack->start.
164 stackLimit == currentStack->start + BLOCK_SIZE_W * currentStack->blocks.
166 When a current stack becomes empty, stackTop is set to point to
167 the topmost element on the previous block group so as to satisfy
168 the invariants described above.
170 static bdescr *firstStack = NULL;
171 static bdescr *currentStack;
172 static stackElement *stackBottom, *stackTop, *stackLimit;
175 currentStackBoundary is used to mark the current stack chunk.
176 If stackTop == currentStackBoundary, it means that the current stack chunk
177 is empty. It is the responsibility of the user to keep currentStackBoundary
178 valid all the time if it is to be employed.
180 static stackElement *currentStackBoundary;
183 stackSize records the current size of the stack.
184 maxStackSize records its high water mark.
186 stackSize <= maxStackSize
188 stackSize is just an estimate measure of the depth of the graph. The reason
189 is that some heap objects have only a single child and may not result
190 in a new element being pushed onto the stack. Therefore, at the end of
191 retainer profiling, maxStackSize + maxCStackSize is some value no greater
192 than the actual depth of the graph.
194 #ifdef DEBUG_RETAINER
195 static int stackSize, maxStackSize;
198 // number of blocks allocated for one stack
199 #define BLOCKS_IN_STACK 1
201 /* -----------------------------------------------------------------------------
202 * Add a new block group to the stack.
204 * currentStack->link == s.
205 * -------------------------------------------------------------------------- */
207 newStackBlock( bdescr *bd )
210 stackTop = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
211 stackBottom = (stackElement *)bd->start;
212 stackLimit = (stackElement *)stackTop;
213 bd->free = (StgPtr)stackLimit;
216 /* -----------------------------------------------------------------------------
217 * Return to the previous block group.
219 * s->link == currentStack.
220 * -------------------------------------------------------------------------- */
222 returnToOldStack( bdescr *bd )
225 stackTop = (stackElement *)bd->free;
226 stackBottom = (stackElement *)bd->start;
227 stackLimit = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
228 bd->free = (StgPtr)stackLimit;
231 /* -----------------------------------------------------------------------------
232 * Initializes the traverse stack.
233 * -------------------------------------------------------------------------- */
235 initializeTraverseStack( void )
237 if (firstStack != NULL) {
238 freeChain(firstStack);
241 firstStack = allocGroup(BLOCKS_IN_STACK);
242 firstStack->link = NULL;
243 firstStack->u.back = NULL;
245 newStackBlock(firstStack);
248 /* -----------------------------------------------------------------------------
249 * Frees all the block groups in the traverse stack.
252 * -------------------------------------------------------------------------- */
254 closeTraverseStack( void )
256 freeChain(firstStack);
260 /* -----------------------------------------------------------------------------
261 * Returns rtsTrue if the whole stack is empty.
262 * -------------------------------------------------------------------------- */
263 static INLINE rtsBool
264 isEmptyRetainerStack( void )
266 return (firstStack == currentStack) && stackTop == stackLimit;
269 /* -----------------------------------------------------------------------------
270 * Returns size of stack
271 * -------------------------------------------------------------------------- */
274 retainerStackBlocks( void )
279 for (bd = firstStack; bd != NULL; bd = bd->link)
286 /* -----------------------------------------------------------------------------
287 * Returns rtsTrue if stackTop is at the stack boundary of the current stack,
288 * i.e., if the current stack chunk is empty.
289 * -------------------------------------------------------------------------- */
290 static INLINE rtsBool
293 return stackTop == currentStackBoundary;
296 /* -----------------------------------------------------------------------------
297 * Initializes *info from ptrs and payload.
299 * payload[] begins with ptrs pointers followed by non-pointers.
300 * -------------------------------------------------------------------------- */
302 init_ptrs( stackPos *info, nat ptrs, StgPtr payload )
304 info->type = posTypePtrs;
305 info->next.ptrs.pos = 0;
306 info->next.ptrs.ptrs = ptrs;
307 info->next.ptrs.payload = payload;
310 /* -----------------------------------------------------------------------------
311 * Find the next object from *info.
312 * -------------------------------------------------------------------------- */
313 static INLINE StgClosure *
314 find_ptrs( stackPos *info )
316 if (info->next.ptrs.pos < info->next.ptrs.ptrs) {
317 return (StgClosure *)info->next.ptrs.payload[info->next.ptrs.pos++];
323 /* -----------------------------------------------------------------------------
324 * Initializes *info from SRT information stored in *infoTable.
325 * -------------------------------------------------------------------------- */
327 init_srt_fun( stackPos *info, StgFunInfoTable *infoTable )
329 if (infoTable->i.srt_bitmap == (StgHalfWord)(-1)) {
330 info->type = posTypeLargeSRT;
331 info->next.large_srt.srt = (StgLargeSRT *)GET_FUN_SRT(infoTable);
332 info->next.large_srt.offset = 0;
334 info->type = posTypeSRT;
335 info->next.srt.srt = (StgClosure **)GET_FUN_SRT(infoTable);
336 info->next.srt.srt_bitmap = infoTable->i.srt_bitmap;
341 init_srt_thunk( stackPos *info, StgThunkInfoTable *infoTable )
343 if (infoTable->i.srt_bitmap == (StgHalfWord)(-1)) {
344 info->type = posTypeLargeSRT;
345 info->next.large_srt.srt = (StgLargeSRT *)GET_SRT(infoTable);
346 info->next.large_srt.offset = 0;
348 info->type = posTypeSRT;
349 info->next.srt.srt = (StgClosure **)GET_SRT(infoTable);
350 info->next.srt.srt_bitmap = infoTable->i.srt_bitmap;
354 /* -----------------------------------------------------------------------------
355 * Find the next object from *info.
356 * -------------------------------------------------------------------------- */
357 static INLINE StgClosure *
358 find_srt( stackPos *info )
363 if (info->type == posTypeSRT) {
365 bitmap = info->next.srt.srt_bitmap;
366 while (bitmap != 0) {
367 if ((bitmap & 1) != 0) {
368 #if defined(__PIC__) && defined(mingw32_TARGET_OS)
369 if ((unsigned long)(*(info->next.srt.srt)) & 0x1)
370 c = (* (StgClosure **)((unsigned long)*(info->next.srt.srt)) & ~0x1);
372 c = *(info->next.srt.srt);
374 c = *(info->next.srt.srt);
376 bitmap = bitmap >> 1;
377 info->next.srt.srt++;
378 info->next.srt.srt_bitmap = bitmap;
381 bitmap = bitmap >> 1;
382 info->next.srt.srt++;
384 // bitmap is now zero...
389 nat i = info->next.large_srt.offset;
392 // Follow the pattern from GC.c:scavenge_large_srt_bitmap().
393 bitmap = info->next.large_srt.srt->l.bitmap[i / BITS_IN(W_)];
394 bitmap = bitmap >> (i % BITS_IN(StgWord));
395 while (i < info->next.large_srt.srt->l.size) {
396 if ((bitmap & 1) != 0) {
397 c = ((StgClosure **)info->next.large_srt.srt->srt)[i];
399 info->next.large_srt.offset = i;
403 if (i % BITS_IN(W_) == 0) {
404 bitmap = info->next.large_srt.srt->l.bitmap[i / BITS_IN(W_)];
406 bitmap = bitmap >> 1;
409 // reached the end of this bitmap.
410 info->next.large_srt.offset = i;
415 /* -----------------------------------------------------------------------------
416 * push() pushes a stackElement representing the next child of *c
417 * onto the traverse stack. If *c has no child, *first_child is set
418 * to NULL and nothing is pushed onto the stack. If *c has only one
419 * child, *c_chlid is set to that child and nothing is pushed onto
420 * the stack. If *c has more than two children, *first_child is set
421 * to the first child and a stackElement representing the second
422 * child is pushed onto the stack.
425 * *c_child_r is the most recent retainer of *c's children.
426 * *c is not any of TSO, AP, PAP, AP_STACK, which means that
427 * there cannot be any stack objects.
428 * Note: SRTs are considered to be children as well.
429 * -------------------------------------------------------------------------- */
431 push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
434 bdescr *nbd; // Next Block Descriptor
436 #ifdef DEBUG_RETAINER
437 // debugBelch("push(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
440 ASSERT(get_itbl(c)->type != TSO);
441 ASSERT(get_itbl(c)->type != AP_STACK);
448 se.c_child_r = c_child_r;
451 switch (get_itbl(c)->type) {
461 // one child (fixed), no SRT
464 *first_child = ((StgMutVar *)c)->var;
467 *first_child = ((StgSelector *)c)->selectee;
470 case IND_OLDGEN_PERM:
472 *first_child = ((StgInd *)c)->indirectee;
476 *first_child = c->payload[0];
479 // For CONSTR_2_0 and MVAR, we use se.info.step to record the position
480 // of the next child. We do not write a separate initialization code.
481 // Also we do not have to initialize info.type;
483 // two children (fixed), no SRT
484 // need to push a stackElement, but nothing to store in se.info
486 *first_child = c->payload[0]; // return the first pointer
487 // se.info.type = posTypeStep;
488 // se.info.next.step = 2; // 2 = second
491 // three children (fixed), no SRT
492 // 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:
625 barf("Invalid object *c in push()");
629 if (stackTop - 1 < stackBottom) {
630 #ifdef DEBUG_RETAINER
631 // debugBelch("push() to the next stack.\n");
633 // currentStack->free is updated when the active stack is switched
634 // to the next stack.
635 currentStack->free = (StgPtr)stackTop;
637 if (currentStack->link == NULL) {
638 nbd = allocGroup(BLOCKS_IN_STACK);
640 nbd->u.back = currentStack;
641 currentStack->link = nbd;
643 nbd = currentStack->link;
648 // adjust stackTop (acutal push)
650 // If the size of stackElement was huge, we would better replace the
651 // following statement by either a memcpy() call or a switch statement
652 // on the type of the element. Currently, the size of stackElement is
653 // small enough (5 words) that this direct assignment seems to be enough.
655 // ToDo: The line below leads to the warning:
656 // warning: 'se.info.type' may be used uninitialized in this function
657 // This is caused by the fact that there are execution paths through the
658 // large switch statement above where some cases do not initialize this
659 // field. Is this really harmless? Can we avoid the warning?
662 #ifdef DEBUG_RETAINER
664 if (stackSize > maxStackSize) maxStackSize = stackSize;
665 // ASSERT(stackSize >= 0);
666 // debugBelch("stackSize = %d\n", stackSize);
670 /* -----------------------------------------------------------------------------
671 * popOff() and popOffReal(): Pop a stackElement off the traverse stack.
673 * stackTop cannot be equal to stackLimit unless the whole stack is
674 * empty, in which case popOff() is not allowed.
676 * You can think of popOffReal() as a part of popOff() which is
677 * executed at the end of popOff() in necessary. Since popOff() is
678 * likely to be executed quite often while popOffReal() is not, we
679 * separate popOffReal() from popOff(), which is declared as an
680 * INLINE function (for the sake of execution speed). popOffReal()
681 * is called only within popOff() and nowhere else.
682 * -------------------------------------------------------------------------- */
686 bdescr *pbd; // Previous Block Descriptor
688 #ifdef DEBUG_RETAINER
689 // debugBelch("pop() to the previous stack.\n");
692 ASSERT(stackTop + 1 == stackLimit);
693 ASSERT(stackBottom == (stackElement *)currentStack->start);
695 if (firstStack == currentStack) {
696 // The stack is completely empty.
698 ASSERT(stackTop == stackLimit);
699 #ifdef DEBUG_RETAINER
701 if (stackSize > maxStackSize) maxStackSize = stackSize;
703 ASSERT(stackSize >= 0);
704 debugBelch("stackSize = %d\n", stackSize);
710 // currentStack->free is updated when the active stack is switched back
711 // to the previous stack.
712 currentStack->free = (StgPtr)stackLimit;
714 // find the previous block descriptor
715 pbd = currentStack->u.back;
718 returnToOldStack(pbd);
720 #ifdef DEBUG_RETAINER
722 if (stackSize > maxStackSize) maxStackSize = stackSize;
724 ASSERT(stackSize >= 0);
725 debugBelch("stackSize = %d\n", stackSize);
732 #ifdef DEBUG_RETAINER
733 // debugBelch("\tpopOff(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
736 ASSERT(stackTop != stackLimit);
737 ASSERT(!isEmptyRetainerStack());
739 // <= (instead of <) is wrong!
740 if (stackTop + 1 < stackLimit) {
742 #ifdef DEBUG_RETAINER
744 if (stackSize > maxStackSize) maxStackSize = stackSize;
746 ASSERT(stackSize >= 0);
747 debugBelch("stackSize = %d\n", stackSize);
756 /* -----------------------------------------------------------------------------
757 * Finds the next object to be considered for retainer profiling and store
759 * Test if the topmost stack element indicates that more objects are left,
760 * and if so, retrieve the first object and store its pointer to *c. Also,
761 * set *cp and *r appropriately, both of which are stored in the stack element.
762 * The topmost stack element then is overwritten so as for it to now denote
764 * If the topmost stack element indicates no more objects are left, pop
765 * off the stack element until either an object can be retrieved or
766 * the current stack chunk becomes empty, indicated by rtsTrue returned by
767 * isOnBoundary(), in which case *c is set to NULL.
769 * It is okay to call this function even when the current stack chunk
771 * -------------------------------------------------------------------------- */
773 pop( StgClosure **c, StgClosure **cp, retainer *r )
777 #ifdef DEBUG_RETAINER
778 // debugBelch("pop(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
782 if (isOnBoundary()) { // if the current stack chunk is depleted
789 switch (get_itbl(se->c)->type) {
790 // two children (fixed), no SRT
791 // nothing in se.info
793 *c = se->c->payload[1];
799 // three children (fixed), no SRT
800 // need to push a stackElement
803 if (se->info.next.step == 2) {
804 *c = (StgClosure *)((StgMVar *)se->c)->tail;
805 se->info.next.step++; // move to the next step
808 *c = ((StgMVar *)se->c)->value;
815 // three children (fixed), no SRT
817 if (se->info.next.step == 2) {
818 *c = ((StgWeak *)se->c)->value;
819 se->info.next.step++;
822 *c = ((StgWeak *)se->c)->finalizer;
829 case TVAR_WATCH_QUEUE:
830 if (se->info.next.step == 2) {
831 *c = (StgClosure *)((StgTVarWatchQueue *)se->c)->next_queue_entry;
832 se->info.next.step++; // move to the next step
835 *c = (StgClosure *)((StgTVarWatchQueue *)se->c)->prev_queue_entry;
843 *c = (StgClosure *)((StgTVar *)se->c)->first_watch_queue_entry;
850 *c = (StgClosure *)((StgTRecHeader *)se->c)->current_chunk;
857 // These are pretty complicated: we have N entries, each
858 // of which contains 3 fields that we want to follow. So
859 // we divide the step counter: the 2 low bits indicate
860 // which field, and the rest of the bits indicate the
861 // entry number (starting from zero).
863 nat entry_no = se->info.next.step >> 2;
864 nat field_no = se->info.next.step & 3;
865 if (entry_no == ((StgTRecChunk *)se->c)->next_entry_idx) {
870 entry = &((StgTRecChunk *)se->c)->entries[entry_no];
872 *c = (StgClosure *)entry->tvar;
873 } else if (field_no == 1) {
874 *c = entry->expected_value;
876 *c = entry->new_value;
880 se->info.next.step++;
888 // StgMutArrPtr.ptrs, no SRT
889 case MUT_ARR_PTRS_CLEAN:
890 case MUT_ARR_PTRS_DIRTY:
891 case MUT_ARR_PTRS_FROZEN:
892 case MUT_ARR_PTRS_FROZEN0:
893 *c = find_ptrs(&se->info);
902 // layout.payload.ptrs, SRT
903 case FUN: // always a heap object
905 if (se->info.type == posTypePtrs) {
906 *c = find_ptrs(&se->info);
912 init_srt_fun(&se->info, get_fun_itbl(se->c));
918 if (se->info.type == posTypePtrs) {
919 *c = find_ptrs(&se->info);
925 init_srt_thunk(&se->info, get_thunk_itbl(se->c));
941 *c = find_srt(&se->info);
950 // no child (fixed), no SRT
956 // one child (fixed), no SRT
961 case IND_OLDGEN_PERM:
970 case CONSTR_NOCAF_STATIC:
983 barf("Invalid object *c in pop()");
989 /* -----------------------------------------------------------------------------
990 * RETAINER PROFILING ENGINE
991 * -------------------------------------------------------------------------- */
994 initRetainerProfiling( void )
996 initializeAllRetainerSet();
997 retainerGeneration = 0;
1000 /* -----------------------------------------------------------------------------
1001 * This function must be called before f-closing prof_file.
1002 * -------------------------------------------------------------------------- */
1004 endRetainerProfiling( void )
1006 #ifdef SECOND_APPROACH
1007 outputAllRetainerSet(prof_file);
1011 /* -----------------------------------------------------------------------------
1012 * Returns the actual pointer to the retainer set of the closure *c.
1013 * It may adjust RSET(c) subject to flip.
1015 * RSET(c) is initialized to NULL if its current value does not
1018 * Even though this function has side effects, they CAN be ignored because
1019 * subsequent calls to retainerSetOf() always result in the same return value
1020 * and retainerSetOf() is the only way to retrieve retainerSet of a given
1022 * We have to perform an XOR (^) operation each time a closure is examined.
1023 * The reason is that we do not know when a closure is visited last.
1024 * -------------------------------------------------------------------------- */
1026 maybeInitRetainerSet( StgClosure *c )
1028 if (!isRetainerSetFieldValid(c)) {
1029 setRetainerSetToNull(c);
1033 /* -----------------------------------------------------------------------------
1034 * Returns rtsTrue if *c is a retainer.
1035 * -------------------------------------------------------------------------- */
1036 static INLINE rtsBool
1037 isRetainer( StgClosure *c )
1039 switch (get_itbl(c)->type) {
1043 // TSOs MUST be retainers: they constitute the set of roots.
1051 case MUT_ARR_PTRS_CLEAN:
1052 case MUT_ARR_PTRS_DIRTY:
1053 case MUT_ARR_PTRS_FROZEN:
1054 case MUT_ARR_PTRS_FROZEN0:
1056 // thunks are retainers.
1063 case THUNK_SELECTOR:
1067 // Static thunks, or CAFS, are obviously retainers.
1070 // WEAK objects are roots; there is separate code in which traversing
1071 // begins from WEAK objects.
1074 // Since the other mutvar-type things are retainers, seems
1075 // like the right thing to do:
1097 // partial applications
1104 case IND_OLDGEN_PERM:
1114 case TVAR_WATCH_QUEUE:
1122 // IND_STATIC cannot be *c, *cp, *r in the retainer profiling loop.
1124 // CONSTR_NOCAF_STATIC
1125 // cannot be *c, *cp, *r in the retainer profiling loop.
1126 case CONSTR_NOCAF_STATIC:
1127 // Stack objects are invalid because they are never treated as
1128 // legal objects during retainer profiling.
1138 case INVALID_OBJECT:
1140 barf("Invalid object in isRetainer(): %d", get_itbl(c)->type);
1145 /* -----------------------------------------------------------------------------
1146 * Returns the retainer function value for the closure *c, i.e., R(*c).
1147 * This function does NOT return the retainer(s) of *c.
1149 * *c must be a retainer.
1151 * Depending on the definition of this function, the maintenance of retainer
1152 * sets can be made easier. If most retainer sets are likely to be created
1153 * again across garbage collections, refreshAllRetainerSet() in
1154 * RetainerSet.c can simply do nothing.
1155 * If this is not the case, we can free all the retainer sets and
1156 * re-initialize the hash table.
1157 * See refreshAllRetainerSet() in RetainerSet.c.
1158 * -------------------------------------------------------------------------- */
1159 static INLINE retainer
1160 getRetainerFrom( StgClosure *c )
1162 ASSERT(isRetainer(c));
1164 #if defined(RETAINER_SCHEME_INFO)
1165 // Retainer scheme 1: retainer = info table
1167 #elif defined(RETAINER_SCHEME_CCS)
1168 // Retainer scheme 2: retainer = cost centre stack
1169 return c->header.prof.ccs;
1170 #elif defined(RETAINER_SCHEME_CC)
1171 // Retainer scheme 3: retainer = cost centre
1172 return c->header.prof.ccs->cc;
1176 /* -----------------------------------------------------------------------------
1177 * Associates the retainer set *s with the closure *c, that is, *s becomes
1178 * the retainer set of *c.
1182 * -------------------------------------------------------------------------- */
1184 associate( StgClosure *c, RetainerSet *s )
1186 // StgWord has the same size as pointers, so the following type
1188 RSET(c) = (RetainerSet *)((StgWord)s | flip);
1191 /* -----------------------------------------------------------------------------
1192 Call retainClosure for each of the closures covered by a large bitmap.
1193 -------------------------------------------------------------------------- */
1196 retain_large_bitmap (StgPtr p, StgLargeBitmap *large_bitmap, nat size,
1197 StgClosure *c, retainer c_child_r)
1203 bitmap = large_bitmap->bitmap[b];
1204 for (i = 0; i < size; ) {
1205 if ((bitmap & 1) == 0) {
1206 retainClosure((StgClosure *)*p, c, c_child_r);
1210 if (i % BITS_IN(W_) == 0) {
1212 bitmap = large_bitmap->bitmap[b];
1214 bitmap = bitmap >> 1;
1219 static INLINE StgPtr
1220 retain_small_bitmap (StgPtr p, nat size, StgWord bitmap,
1221 StgClosure *c, retainer c_child_r)
1224 if ((bitmap & 1) == 0) {
1225 retainClosure((StgClosure *)*p, c, c_child_r);
1228 bitmap = bitmap >> 1;
1234 /* -----------------------------------------------------------------------------
1235 * Call retainClosure for each of the closures in an SRT.
1236 * ------------------------------------------------------------------------- */
1239 retain_large_srt_bitmap (StgLargeSRT *srt, StgClosure *c, retainer c_child_r)
1246 p = (StgClosure **)srt->srt;
1248 bitmap = srt->l.bitmap[b];
1249 for (i = 0; i < size; ) {
1250 if ((bitmap & 1) != 0) {
1251 retainClosure((StgClosure *)*p, c, c_child_r);
1255 if (i % BITS_IN(W_) == 0) {
1257 bitmap = srt->l.bitmap[b];
1259 bitmap = bitmap >> 1;
1265 retainSRT (StgClosure **srt, nat srt_bitmap, StgClosure *c, retainer c_child_r)
1270 bitmap = srt_bitmap;
1273 if (bitmap == (StgHalfWord)(-1)) {
1274 retain_large_srt_bitmap( (StgLargeSRT *)srt, c, c_child_r );
1278 while (bitmap != 0) {
1279 if ((bitmap & 1) != 0) {
1280 #ifdef ENABLE_WIN32_DLL_SUPPORT
1281 if ( (unsigned long)(*srt) & 0x1 ) {
1282 retainClosure(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)),
1285 retainClosure(*srt,c,c_child_r);
1288 retainClosure(*srt,c,c_child_r);
1292 bitmap = bitmap >> 1;
1296 /* -----------------------------------------------------------------------------
1297 * Process all the objects in the stack chunk from stackStart to stackEnd
1298 * with *c and *c_child_r being their parent and their most recent retainer,
1299 * respectively. Treat stackOptionalFun as another child of *c if it is
1302 * *c is one of the following: TSO, AP_STACK.
1303 * If *c is TSO, c == c_child_r.
1304 * stackStart < stackEnd.
1305 * RSET(c) and RSET(c_child_r) are valid, i.e., their
1306 * interpretation conforms to the current value of flip (even when they
1307 * are interpreted to be NULL).
1308 * If *c is TSO, its state is not any of ThreadRelocated, ThreadComplete,
1309 * or ThreadKilled, which means that its stack is ready to process.
1311 * This code was almost plagiarzied from GC.c! For each pointer,
1312 * retainClosure() is invoked instead of evacuate().
1313 * -------------------------------------------------------------------------- */
1315 retainStack( StgClosure *c, retainer c_child_r,
1316 StgPtr stackStart, StgPtr stackEnd )
1318 stackElement *oldStackBoundary;
1320 StgRetInfoTable *info;
1324 #ifdef DEBUG_RETAINER
1326 if (cStackSize > maxCStackSize) maxCStackSize = cStackSize;
1330 Each invocation of retainStack() creates a new virtual
1331 stack. Since all such stacks share a single common stack, we
1332 record the current currentStackBoundary, which will be restored
1335 oldStackBoundary = currentStackBoundary;
1336 currentStackBoundary = stackTop;
1338 #ifdef DEBUG_RETAINER
1339 // debugBelch("retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
1342 ASSERT(get_itbl(c)->type != TSO ||
1343 (((StgTSO *)c)->what_next != ThreadRelocated &&
1344 ((StgTSO *)c)->what_next != ThreadComplete &&
1345 ((StgTSO *)c)->what_next != ThreadKilled));
1348 while (p < stackEnd) {
1349 info = get_ret_itbl((StgClosure *)p);
1351 switch(info->i.type) {
1354 retainClosure(((StgUpdateFrame *)p)->updatee, c, c_child_r);
1355 p += sizeofW(StgUpdateFrame);
1360 case CATCH_STM_FRAME:
1361 case CATCH_RETRY_FRAME:
1362 case ATOMICALLY_FRAME:
1364 bitmap = BITMAP_BITS(info->i.layout.bitmap);
1365 size = BITMAP_SIZE(info->i.layout.bitmap);
1367 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1370 retainSRT((StgClosure **)GET_SRT(info), info->i.srt_bitmap, c, c_child_r);
1377 retainClosure((StgClosure *)*p, c, c_child_r);
1380 size = BCO_BITMAP_SIZE(bco);
1381 retain_large_bitmap(p, BCO_BITMAP(bco), size, c, c_child_r);
1386 // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
1388 size = GET_LARGE_BITMAP(&info->i)->size;
1390 retain_large_bitmap(p, GET_LARGE_BITMAP(&info->i),
1391 size, c, c_child_r);
1393 // and don't forget to follow the SRT
1396 // Dynamic bitmap: the mask is stored on the stack
1399 dyn = ((StgRetDyn *)p)->liveness;
1401 // traverse the bitmap first
1402 bitmap = RET_DYN_LIVENESS(dyn);
1403 p = (P_)&((StgRetDyn *)p)->payload[0];
1404 size = RET_DYN_BITMAP_SIZE;
1405 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1407 // skip over the non-ptr words
1408 p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
1410 // follow the ptr words
1411 for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
1412 retainClosure((StgClosure *)*p, c, c_child_r);
1419 StgRetFun *ret_fun = (StgRetFun *)p;
1420 StgFunInfoTable *fun_info;
1422 retainClosure(ret_fun->fun, c, c_child_r);
1423 fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
1425 p = (P_)&ret_fun->payload;
1426 switch (fun_info->f.fun_type) {
1428 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
1429 size = BITMAP_SIZE(fun_info->f.b.bitmap);
1430 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1433 size = GET_FUN_LARGE_BITMAP(fun_info)->size;
1434 retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
1435 size, c, c_child_r);
1439 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1440 size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
1441 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1448 barf("Invalid object found in retainStack(): %d",
1449 (int)(info->i.type));
1453 // restore currentStackBoundary
1454 currentStackBoundary = oldStackBoundary;
1455 #ifdef DEBUG_RETAINER
1456 // debugBelch("retainStack() finished: currentStackBoundary = 0x%x\n", currentStackBoundary);
1459 #ifdef DEBUG_RETAINER
1464 /* ----------------------------------------------------------------------------
1465 * Call retainClosure for each of the children of a PAP/AP
1466 * ------------------------------------------------------------------------- */
1468 static INLINE StgPtr
1469 retain_PAP_payload (StgClosure *pap, /* NOT tagged */
1470 retainer c_child_r, /* NOT tagged */
1471 StgClosure *fun, /* tagged */
1472 StgClosure** payload, StgWord n_args)
1476 StgFunInfoTable *fun_info;
1478 retainClosure(fun, pap, c_child_r);
1479 fun = UNTAG_CLOSURE(fun);
1480 fun_info = get_fun_itbl(fun);
1481 ASSERT(fun_info->i.type != PAP);
1483 p = (StgPtr)payload;
1485 switch (fun_info->f.fun_type) {
1487 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
1488 p = retain_small_bitmap(p, n_args, bitmap,
1492 retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
1493 n_args, pap, c_child_r);
1497 retain_large_bitmap((StgPtr)payload, BCO_BITMAP(fun),
1498 n_args, pap, c_child_r);
1502 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1503 p = retain_small_bitmap(p, n_args, bitmap, pap, c_child_r);
1509 /* -----------------------------------------------------------------------------
1510 * Compute the retainer set of *c0 and all its desecents by traversing.
1511 * *cp0 is the parent of *c0, and *r0 is the most recent retainer of *c0.
1513 * c0 = cp0 = r0 holds only for root objects.
1514 * RSET(cp0) and RSET(r0) are valid, i.e., their
1515 * interpretation conforms to the current value of flip (even when they
1516 * are interpreted to be NULL).
1517 * However, RSET(c0) may be corrupt, i.e., it may not conform to
1518 * the current value of flip. If it does not, during the execution
1519 * of this function, RSET(c0) must be initialized as well as all
1522 * stackTop must be the same at the beginning and the exit of this function.
1523 * *c0 can be TSO (as well as AP_STACK).
1524 * -------------------------------------------------------------------------- */
1526 retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
1528 // c = Current closure (possibly tagged)
1529 // cp = Current closure's Parent (NOT tagged)
1530 // r = current closures' most recent Retainer (NOT tagged)
1531 // c_child_r = current closure's children's most recent retainer
1532 // first_child = first child of c
1533 StgClosure *c, *cp, *first_child;
1534 RetainerSet *s, *retainerSetOfc;
1535 retainer r, c_child_r;
1538 #ifdef DEBUG_RETAINER
1539 // StgPtr oldStackTop;
1542 #ifdef DEBUG_RETAINER
1543 // oldStackTop = stackTop;
1544 // debugBelch("retainClosure() called: c0 = 0x%x, cp0 = 0x%x, r0 = 0x%x\n", c0, cp0, r0);
1547 // (c, cp, r) = (c0, cp0, r0)
1554 //debugBelch("loop");
1555 // pop to (c, cp, r);
1559 #ifdef DEBUG_RETAINER
1560 // debugBelch("retainClosure() ends: oldStackTop = 0x%x, stackTop = 0x%x\n", oldStackTop, stackTop);
1565 //debugBelch("inner_loop");
1568 c = UNTAG_CLOSURE(c);
1570 // c = current closure under consideration,
1571 // cp = current closure's parent,
1572 // r = current closure's most recent retainer
1574 // Loop invariants (on the meaning of c, cp, r, and their retainer sets):
1575 // RSET(cp) and RSET(r) are valid.
1576 // RSET(c) is valid only if c has been visited before.
1578 // Loop invariants (on the relation between c, cp, and r)
1579 // if cp is not a retainer, r belongs to RSET(cp).
1580 // if cp is a retainer, r == cp.
1582 typeOfc = get_itbl(c)->type;
1584 #ifdef DEBUG_RETAINER
1587 case CONSTR_NOCAF_STATIC:
1593 if (retainerSetOf(c) == NULL) { // first visit?
1594 costArray[typeOfc] += cost(c);
1595 sumOfNewCost += cost(c);
1604 if (((StgTSO *)c)->what_next == ThreadComplete ||
1605 ((StgTSO *)c)->what_next == ThreadKilled) {
1606 #ifdef DEBUG_RETAINER
1607 debugBelch("ThreadComplete or ThreadKilled encountered in retainClosure()\n");
1611 if (((StgTSO *)c)->what_next == ThreadRelocated) {
1612 #ifdef DEBUG_RETAINER
1613 debugBelch("ThreadRelocated encountered in retainClosure()\n");
1615 c = (StgClosure *)((StgTSO *)c)->_link;
1621 // We just skip IND_STATIC, so its retainer set is never computed.
1622 c = ((StgIndStatic *)c)->indirectee;
1624 // static objects with no pointers out, so goto loop.
1625 case CONSTR_NOCAF_STATIC:
1626 // It is not just enough not to compute the retainer set for *c; it is
1627 // mandatory because CONSTR_NOCAF_STATIC are not reachable from
1628 // scavenged_static_objects, the list from which is assumed to traverse
1629 // all static objects after major garbage collections.
1633 if (get_itbl(c)->srt_bitmap == 0) {
1634 // No need to compute the retainer set; no dynamic objects
1635 // are reachable from *c.
1637 // Static objects: if we traverse all the live closures,
1638 // including static closures, during each heap census then
1639 // we will observe that some static closures appear and
1640 // disappear. eg. a closure may contain a pointer to a
1641 // static function 'f' which is not otherwise reachable
1642 // (it doesn't indirectly point to any CAFs, so it doesn't
1643 // appear in any SRTs), so we would find 'f' during
1644 // traversal. However on the next sweep there may be no
1645 // closures pointing to 'f'.
1647 // We must therefore ignore static closures whose SRT is
1648 // empty, because these are exactly the closures that may
1649 // "appear". A closure with a non-empty SRT, and which is
1650 // still required, will always be reachable.
1652 // But what about CONSTR_STATIC? Surely these may be able
1653 // to appear, and they don't have SRTs, so we can't
1654 // check. So for now, we're calling
1655 // resetStaticObjectForRetainerProfiling() from the
1656 // garbage collector to reset the retainer sets in all the
1657 // reachable static objects.
1664 // The above objects are ignored in computing the average number of times
1665 // an object is visited.
1666 timesAnyObjectVisited++;
1668 // If this is the first visit to c, initialize its retainer set.
1669 maybeInitRetainerSet(c);
1670 retainerSetOfc = retainerSetOf(c);
1673 // isRetainer(cp) == rtsTrue => s == NULL
1674 // isRetainer(cp) == rtsFalse => s == cp.retainer
1678 s = retainerSetOf(cp);
1680 // (c, cp, r, s) is available.
1682 // (c, cp, r, s, R_r) is available, so compute the retainer set for *c.
1683 if (retainerSetOfc == NULL) {
1684 // This is the first visit to *c.
1688 associate(c, singleton(r));
1690 // s is actually the retainer set of *c!
1693 // compute c_child_r
1694 c_child_r = isRetainer(c) ? getRetainerFrom(c) : r;
1696 // This is not the first visit to *c.
1697 if (isMember(r, retainerSetOfc))
1698 goto loop; // no need to process child
1701 associate(c, addElement(r, retainerSetOfc));
1703 // s is not NULL and cp is not a retainer. This means that
1704 // each time *cp is visited, so is *c. Thus, if s has
1705 // exactly one more element in its retainer set than c, s
1706 // is also the new retainer set for *c.
1707 if (s->num == retainerSetOfc->num + 1) {
1710 // Otherwise, just add R_r to the current retainer set of *c.
1712 associate(c, addElement(r, retainerSetOfc));
1717 goto loop; // no need to process child
1719 // compute c_child_r
1723 // now, RSET() of all of *c, *cp, and *r is valid.
1724 // (c, c_child_r) are available.
1728 // Special case closures: we process these all in one go rather
1729 // than attempting to save the current position, because doing so
1733 retainStack(c, c_child_r,
1735 ((StgTSO *)c)->stack + ((StgTSO *)c)->stack_size);
1740 StgPAP *pap = (StgPAP *)c;
1741 retain_PAP_payload(c, c_child_r, pap->fun, pap->payload, pap->n_args);
1747 StgAP *ap = (StgAP *)c;
1748 retain_PAP_payload(c, c_child_r, ap->fun, ap->payload, ap->n_args);
1753 retainClosure(((StgAP_STACK *)c)->fun, c, c_child_r);
1754 retainStack(c, c_child_r,
1755 (StgPtr)((StgAP_STACK *)c)->payload,
1756 (StgPtr)((StgAP_STACK *)c)->payload +
1757 ((StgAP_STACK *)c)->size);
1761 push(c, c_child_r, &first_child);
1763 // If first_child is null, c has no child.
1764 // If first_child is not null, the top stack element points to the next
1765 // object. push() may or may not push a stackElement on the stack.
1766 if (first_child == NULL)
1769 // (c, cp, r) = (first_child, c, c_child_r)
1776 /* -----------------------------------------------------------------------------
1777 * Compute the retainer set for every object reachable from *tl.
1778 * -------------------------------------------------------------------------- */
1780 retainRoot(void *user STG_UNUSED, StgClosure **tl)
1784 // We no longer assume that only TSOs and WEAKs are roots; any closure can
1787 ASSERT(isEmptyRetainerStack());
1788 currentStackBoundary = stackTop;
1790 c = UNTAG_CLOSURE(*tl);
1791 if (c != &stg_END_TSO_QUEUE_closure && isRetainer(c)) {
1792 retainClosure(c, c, getRetainerFrom(c));
1794 retainClosure(c, c, CCS_SYSTEM);
1797 // NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl)));
1798 // *tl might be a TSO which is ThreadComplete, in which
1799 // case we ignore it for the purposes of retainer profiling.
1802 /* -----------------------------------------------------------------------------
1803 * Compute the retainer set for each of the objects in the heap.
1804 * -------------------------------------------------------------------------- */
1806 computeRetainerSet( void )
1813 #ifdef DEBUG_RETAINER
1814 RetainerSet tmpRetainerSet;
1817 markCapabilities(retainRoot, NULL); // for scheduler roots
1819 // This function is called after a major GC, when key, value, and finalizer
1820 // all are guaranteed to be valid, or reachable.
1822 // The following code assumes that WEAK objects are considered to be roots
1823 // for retainer profilng.
1824 for (weak = weak_ptr_list; weak != NULL; weak = weak->link)
1825 // retainRoot((StgClosure *)weak);
1826 retainRoot(NULL, (StgClosure **)&weak);
1828 // Consider roots from the stable ptr table.
1829 markStablePtrTable(retainRoot, NULL);
1831 // The following code resets the rs field of each unvisited mutable
1832 // object (computing sumOfNewCostExtra and updating costArray[] when
1833 // debugging retainer profiler).
1834 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1835 // NOT TRUE: even G0 has a block on its mutable list
1836 // ASSERT(g != 0 || (generations[g].mut_list == NULL));
1838 // Traversing through mut_list is necessary
1839 // because we can find MUT_VAR objects which have not been
1840 // visited during retainer profiling.
1841 for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
1842 for (ml = bd->start; ml < bd->free; ml++) {
1844 maybeInitRetainerSet((StgClosure *)*ml);
1845 rtl = retainerSetOf((StgClosure *)*ml);
1847 #ifdef DEBUG_RETAINER
1849 // first visit to *ml
1850 // This is a violation of the interface rule!
1851 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1853 switch (get_itbl((StgClosure *)ml)->type) {
1857 case CONSTR_NOCAF_STATIC:
1861 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1865 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1866 sumOfNewCostExtra += cost((StgClosure *)ml);
1876 /* -----------------------------------------------------------------------------
1877 * Traverse all static objects for which we compute retainer sets,
1878 * and reset their rs fields to NULL, which is accomplished by
1879 * invoking maybeInitRetainerSet(). This function must be called
1880 * before zeroing all objects reachable from scavenged_static_objects
1881 * in the case of major gabage collections. See GarbageCollect() in
1884 * The mut_once_list of the oldest generation must also be traversed?
1885 * Why? Because if the evacuation of an object pointed to by a static
1886 * indirection object fails, it is put back to the mut_once_list of
1887 * the oldest generation.
1888 * However, this is not necessary because any static indirection objects
1889 * are just traversed through to reach dynamic objects. In other words,
1890 * they are not taken into consideration in computing retainer sets.
1891 * -------------------------------------------------------------------------- */
1893 resetStaticObjectForRetainerProfiling( StgClosure *static_objects )
1895 #ifdef DEBUG_RETAINER
1900 #ifdef DEBUG_RETAINER
1904 while (p != END_OF_STATIC_LIST) {
1905 #ifdef DEBUG_RETAINER
1908 switch (get_itbl(p)->type) {
1910 // Since we do not compute the retainer set of any
1911 // IND_STATIC object, we don't have to reset its retainer
1913 p = (StgClosure*)*IND_STATIC_LINK(p);
1916 maybeInitRetainerSet(p);
1917 p = (StgClosure*)*THUNK_STATIC_LINK(p);
1920 maybeInitRetainerSet(p);
1921 p = (StgClosure*)*FUN_STATIC_LINK(p);
1924 maybeInitRetainerSet(p);
1925 p = (StgClosure*)*STATIC_LINK(get_itbl(p), p);
1928 barf("resetStaticObjectForRetainerProfiling: %p (%s)",
1929 p, get_itbl(p)->type);
1933 #ifdef DEBUG_RETAINER
1934 // debugBelch("count in scavenged_static_objects = %d\n", count);
1938 /* -----------------------------------------------------------------------------
1939 * Perform retainer profiling.
1940 * N is the oldest generation being profilied, where the generations are
1941 * numbered starting at 0.
1944 * This function should be called only immediately after major garbage
1946 * ------------------------------------------------------------------------- */
1948 retainerProfile(void)
1950 #ifdef DEBUG_RETAINER
1952 nat totalHeapSize; // total raw heap size (computed by linear scanning)
1955 #ifdef DEBUG_RETAINER
1956 debugBelch(" < retainerProfile() invoked : %d>\n", retainerGeneration);
1961 // We haven't flipped the bit yet.
1962 #ifdef DEBUG_RETAINER
1963 debugBelch("Before traversing:\n");
1964 sumOfCostLinear = 0;
1965 for (i = 0;i < N_CLOSURE_TYPES; i++)
1966 costArrayLinear[i] = 0;
1967 totalHeapSize = checkHeapSanityForRetainerProfiling();
1969 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1971 debugBelch("costArrayLinear[] = ");
1972 for (i = 0;i < N_CLOSURE_TYPES; i++)
1973 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
1977 ASSERT(sumOfCostLinear == totalHeapSize);
1980 #define pcostArrayLinear(index) \
1981 if (costArrayLinear[index] > 0) \
1982 debugBelch("costArrayLinear[" #index "] = %u\n", costArrayLinear[index])
1983 pcostArrayLinear(THUNK_STATIC);
1984 pcostArrayLinear(FUN_STATIC);
1985 pcostArrayLinear(CONSTR_STATIC);
1986 pcostArrayLinear(CONSTR_NOCAF_STATIC);
1990 // Now we flips flip.
1993 #ifdef DEBUG_RETAINER
1999 numObjectVisited = 0;
2000 timesAnyObjectVisited = 0;
2002 #ifdef DEBUG_RETAINER
2003 debugBelch("During traversing:\n");
2005 sumOfNewCostExtra = 0;
2006 for (i = 0;i < N_CLOSURE_TYPES; i++)
2011 We initialize the traverse stack each time the retainer profiling is
2012 performed (because the traverse stack size varies on each retainer profiling
2013 and this operation is not costly anyhow). However, we just refresh the
2016 initializeTraverseStack();
2017 #ifdef DEBUG_RETAINER
2018 initializeAllRetainerSet();
2020 refreshAllRetainerSet();
2022 computeRetainerSet();
2024 #ifdef DEBUG_RETAINER
2025 debugBelch("After traversing:\n");
2026 sumOfCostLinear = 0;
2027 for (i = 0;i < N_CLOSURE_TYPES; i++)
2028 costArrayLinear[i] = 0;
2029 totalHeapSize = checkHeapSanityForRetainerProfiling();
2031 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
2032 ASSERT(sumOfCostLinear == totalHeapSize);
2034 // now, compare the two results
2037 costArray[] must be exactly the same as costArrayLinear[].
2039 1) Dead weak pointers, whose type is CONSTR. These objects are not
2040 reachable from any roots.
2042 debugBelch("Comparison:\n");
2043 debugBelch("\tcostArrayLinear[] (must be empty) = ");
2044 for (i = 0;i < N_CLOSURE_TYPES; i++)
2045 if (costArray[i] != costArrayLinear[i])
2046 // nothing should be printed except MUT_VAR after major GCs
2047 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
2050 debugBelch("\tsumOfNewCost = %u\n", sumOfNewCost);
2051 debugBelch("\tsumOfNewCostExtra = %u\n", sumOfNewCostExtra);
2052 debugBelch("\tcostArray[] (must be empty) = ");
2053 for (i = 0;i < N_CLOSURE_TYPES; i++)
2054 if (costArray[i] != costArrayLinear[i])
2055 // nothing should be printed except MUT_VAR after major GCs
2056 debugBelch("[%u:%u] ", i, costArray[i]);
2059 // only for major garbage collection
2060 ASSERT(sumOfNewCost + sumOfNewCostExtra == sumOfCostLinear);
2064 closeTraverseStack();
2065 #ifdef DEBUG_RETAINER
2066 closeAllRetainerSet();
2068 // Note that there is no post-processing for the retainer sets.
2070 retainerGeneration++;
2073 retainerGeneration - 1, // retainerGeneration has just been incremented!
2074 #ifdef DEBUG_RETAINER
2075 maxCStackSize, maxStackSize,
2077 (double)timesAnyObjectVisited / numObjectVisited);
2080 /* -----------------------------------------------------------------------------
2082 * -------------------------------------------------------------------------- */
2084 #ifdef DEBUG_RETAINER
2086 #define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
2087 ((HEAP_ALLOCED(r) && ((Bdescr((P_)r)->flags & BF_FREE) == 0)))) && \
2088 ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa))
2091 sanityCheckHeapClosure( StgClosure *c )
2095 ASSERT(LOOKS_LIKE_GHC_INFO(c->header.info));
2096 ASSERT(!closure_STATIC(c));
2097 ASSERT(LOOKS_LIKE_PTR(c));
2099 if ((((StgWord)RSET(c) & 1) ^ flip) != 0) {
2100 if (get_itbl(c)->type == CONSTR &&
2101 !strcmp(GET_PROF_TYPE(get_itbl(c)), "DEAD_WEAK") &&
2102 !strcmp(GET_PROF_DESC(get_itbl(c)), "DEAD_WEAK")) {
2103 debugBelch("\tUnvisited dead weak pointer object found: c = %p\n", c);
2104 costArray[get_itbl(c)->type] += cost(c);
2105 sumOfNewCost += cost(c);
2108 "Unvisited object: flip = %d, c = %p(%d, %s, %s), rs = %p\n",
2109 flip, c, get_itbl(c)->type,
2110 get_itbl(c)->prof.closure_type, GET_PROF_DESC(get_itbl(c)),
2113 // debugBelch("sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c));
2116 return closure_sizeW(c);
2120 heapCheck( bdescr *bd )
2123 static nat costSum, size;
2126 while (bd != NULL) {
2128 while (p < bd->free) {
2129 size = sanityCheckHeapClosure((StgClosure *)p);
2130 sumOfCostLinear += size;
2131 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2133 // no need for slop check; I think slops are not used currently.
2135 ASSERT(p == bd->free);
2136 costSum += bd->free - bd->start;
2144 smallObjectPoolCheck(void)
2148 static nat costSum, size;
2158 while (p < alloc_Hp) {
2159 size = sanityCheckHeapClosure((StgClosure *)p);
2160 sumOfCostLinear += size;
2161 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2164 ASSERT(p == alloc_Hp);
2165 costSum += alloc_Hp - bd->start;
2168 while (bd != NULL) {
2170 while (p < bd->free) {
2171 size = sanityCheckHeapClosure((StgClosure *)p);
2172 sumOfCostLinear += size;
2173 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2176 ASSERT(p == bd->free);
2177 costSum += bd->free - bd->start;
2185 chainCheck(bdescr *bd)
2190 while (bd != NULL) {
2191 // bd->free - bd->start is not an accurate measurement of the
2192 // object size. Actually it is always zero, so we compute its
2194 size = sanityCheckHeapClosure((StgClosure *)bd->start);
2195 sumOfCostLinear += size;
2196 costArrayLinear[get_itbl((StgClosure *)bd->start)->type] += size;
2205 checkHeapSanityForRetainerProfiling( void )
2210 debugBelch("START: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2211 if (RtsFlags.GcFlags.generations == 1) {
2212 costSum += heapCheck(g0s0->to_blocks);
2213 debugBelch("heapCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2214 costSum += chainCheck(g0s0->large_objects);
2215 debugBelch("chainCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2217 for (g = 0; g < RtsFlags.GcFlags.generations; g++)
2218 for (s = 0; s < generations[g].n_steps; s++) {
2220 After all live objects have been scavenged, the garbage
2221 collector may create some objects in
2222 scheduleFinalizers(). These objects are created throught
2223 allocate(), so the small object pool or the large object
2224 pool of the g0s0 may not be empty.
2226 if (g == 0 && s == 0) {
2227 costSum += smallObjectPoolCheck();
2228 debugBelch("smallObjectPoolCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2229 costSum += chainCheck(generations[g].steps[s].large_objects);
2230 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2232 costSum += heapCheck(generations[g].steps[s].blocks);
2233 debugBelch("heapCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2234 costSum += chainCheck(generations[g].steps[s].large_objects);
2235 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2244 findPointer(StgPtr p)
2250 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2251 for (s = 0; s < generations[g].n_steps; s++) {
2252 // if (g == 0 && s == 0) continue;
2253 bd = generations[g].steps[s].blocks;
2254 for (; bd; bd = bd->link) {
2255 for (q = bd->start; q < bd->free; q++) {
2256 if (*q == (StgWord)p) {
2258 while (!LOOKS_LIKE_GHC_INFO(*r)) r--;
2259 debugBelch("Found in gen[%d], step[%d]: q = %p, r = %p\n", g, s, q, r);
2264 bd = generations[g].steps[s].large_objects;
2265 for (; bd; bd = bd->link) {
2266 e = bd->start + cost((StgClosure *)bd->start);
2267 for (q = bd->start; q < e; q++) {
2268 if (*q == (StgWord)p) {
2270 while (*r == 0 || !LOOKS_LIKE_GHC_INFO(*r)) r--;
2271 debugBelch("Found in gen[%d], large_objects: %p\n", g, r);
2281 belongToHeap(StgPtr p)
2286 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2287 for (s = 0; s < generations[g].n_steps; s++) {
2288 // if (g == 0 && s == 0) continue;
2289 bd = generations[g].steps[s].blocks;
2290 for (; bd; bd = bd->link) {
2291 if (bd->start <= p && p < bd->free) {
2292 debugBelch("Belongs to gen[%d], step[%d]", g, s);
2296 bd = generations[g].steps[s].large_objects;
2297 for (; bd; bd = bd->link) {
2298 if (bd->start <= p && p < bd->start + getHeapClosureSize((StgClosure *)bd->start)) {
2299 debugBelch("Found in gen[%d], large_objects: %p\n", g, bd->start);
2306 #endif /* DEBUG_RETAINER */
2308 #endif /* PROFILING */