1 /* -----------------------------------------------------------------------------
2 * $Id: RetainerProfile.c,v 1.7 2003/02/22 04:51:52 sof Exp $
4 * (c) The GHC Team, 2001
9 * ---------------------------------------------------------------------------*/
17 #include "RetainerProfile.h"
18 #include "RetainerSet.h"
22 #include "StoragePriv.h"
26 #include "StablePriv.h"
27 #include "Profiling.h"
29 #include "BlockAlloc.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 * -------------------------------------------------------------------------- */
110 // fixed layout or layout specified by a field in the closure
115 // See StgClosureInfo in InfoTables.h
116 #if SIZEOF_VOID_P == 8
129 StgClosure **srt_end;
146 firstStack points to the first block group.
147 currentStack points to the block group currently being used.
148 currentStack->free == stackLimit.
149 stackTop points to the topmost byte in the stack of currentStack.
150 Unless the whole stack is empty, stackTop must point to the topmost
151 object (or byte) in the whole stack. Thus, it is only when the whole stack
152 is empty that stackTop == stackLimit (not during the execution of push()
154 stackBottom == currentStack->start.
155 stackLimit == currentStack->start + BLOCK_SIZE_W * currentStack->blocks.
157 When a current stack becomes empty, stackTop is set to point to
158 the topmost element on the previous block group so as to satisfy
159 the invariants described above.
161 bdescr *firstStack = NULL;
162 static bdescr *currentStack;
163 static stackElement *stackBottom, *stackTop, *stackLimit;
166 currentStackBoundary is used to mark the current stack chunk.
167 If stackTop == currentStackBoundary, it means that the current stack chunk
168 is empty. It is the responsibility of the user to keep currentStackBoundary
169 valid all the time if it is to be employed.
171 static stackElement *currentStackBoundary;
174 stackSize records the current size of the stack.
175 maxStackSize records its high water mark.
177 stackSize <= maxStackSize
179 stackSize is just an estimate measure of the depth of the graph. The reason
180 is that some heap objects have only a single child and may not result
181 in a new element being pushed onto the stack. Therefore, at the end of
182 retainer profiling, maxStackSize + maxCStackSize is some value no greater
183 than the actual depth of the graph.
185 #ifdef DEBUG_RETAINER
186 static int stackSize, maxStackSize;
189 // number of blocks allocated for one stack
190 #define BLOCKS_IN_STACK 1
192 /* -----------------------------------------------------------------------------
193 * Add a new block group to the stack.
195 * currentStack->link == s.
196 * -------------------------------------------------------------------------- */
198 newStackBlock( bdescr *bd )
201 stackTop = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
202 stackBottom = (stackElement *)bd->start;
203 stackLimit = (stackElement *)stackTop;
204 bd->free = (StgPtr)stackLimit;
207 /* -----------------------------------------------------------------------------
208 * Return to the previous block group.
210 * s->link == currentStack.
211 * -------------------------------------------------------------------------- */
213 returnToOldStack( bdescr *bd )
216 stackTop = (stackElement *)bd->free;
217 stackBottom = (stackElement *)bd->start;
218 stackLimit = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
219 bd->free = (StgPtr)stackLimit;
222 /* -----------------------------------------------------------------------------
223 * Initializes the traverse stack.
224 * -------------------------------------------------------------------------- */
226 initializeTraverseStack( void )
228 if (firstStack != NULL) {
229 freeChain(firstStack);
232 firstStack = allocGroup(BLOCKS_IN_STACK);
233 firstStack->link = NULL;
234 firstStack->u.back = NULL;
236 newStackBlock(firstStack);
239 /* -----------------------------------------------------------------------------
240 * Frees all the block groups in the traverse stack.
243 * -------------------------------------------------------------------------- */
245 closeTraverseStack( void )
247 freeChain(firstStack);
251 /* -----------------------------------------------------------------------------
252 * Returns rtsTrue if the whole stack is empty.
253 * -------------------------------------------------------------------------- */
254 static inline rtsBool
255 isEmptyRetainerStack( void )
257 return (firstStack == currentStack) && stackTop == stackLimit;
260 /* -----------------------------------------------------------------------------
261 * Returns rtsTrue if stackTop is at the stack boundary of the current stack,
262 * i.e., if the current stack chunk is empty.
263 * -------------------------------------------------------------------------- */
264 static inline rtsBool
267 return stackTop == currentStackBoundary;
270 /* -----------------------------------------------------------------------------
271 * Initializes *info from ptrs and payload.
273 * payload[] begins with ptrs pointers followed by non-pointers.
274 * -------------------------------------------------------------------------- */
276 init_ptrs( stackPos *info, nat ptrs, StgPtr payload )
278 info->type = posTypePtrs;
279 info->next.ptrs.pos = 0;
280 info->next.ptrs.ptrs = ptrs;
281 info->next.ptrs.payload = payload;
284 /* -----------------------------------------------------------------------------
285 * Find the next object from *info.
286 * -------------------------------------------------------------------------- */
287 static inline StgClosure *
288 find_ptrs( stackPos *info )
290 if (info->next.ptrs.pos < info->next.ptrs.ptrs) {
291 return (StgClosure *)info->next.ptrs.payload[info->next.ptrs.pos++];
297 /* -----------------------------------------------------------------------------
298 * Initializes *info from SRT information stored in *infoTable.
299 * -------------------------------------------------------------------------- */
301 init_srt_fun( stackPos *info, StgFunInfoTable *infoTable )
303 info->type = posTypeSRT;
304 info->next.srt.srt = (StgClosure **)(infoTable->srt);
305 info->next.srt.srt_end = info->next.srt.srt + infoTable->i.srt_len;
309 init_srt_thunk( stackPos *info, StgThunkInfoTable *infoTable )
311 info->type = posTypeSRT;
312 info->next.srt.srt = (StgClosure **)(infoTable->srt);
313 info->next.srt.srt_end = info->next.srt.srt + infoTable->i.srt_len;
316 /* -----------------------------------------------------------------------------
317 * Find the next object from *info.
318 * -------------------------------------------------------------------------- */
319 static inline StgClosure *
320 find_srt( stackPos *info )
324 if (info->next.srt.srt < info->next.srt.srt_end) {
325 // See scavenge_srt() in GC.c for details.
326 #ifdef ENABLE_WIN32_DLL_SUPPORT
327 if ((unsigned long)(*(info->next.srt.srt)) & 0x1)
328 c = (* (StgClosure **)((unsigned long)*(info->next.srt.srt)) & ~0x1);
330 c = *(info->next.srt.srt);
332 c = *(info->next.srt.srt);
334 info->next.srt.srt++;
341 /* -----------------------------------------------------------------------------
342 * push() pushes a stackElement representing the next child of *c
343 * onto the traverse stack. If *c has no child, *first_child is set
344 * to NULL and nothing is pushed onto the stack. If *c has only one
345 * child, *c_chlid is set to that child and nothing is pushed onto
346 * the stack. If *c has more than two children, *first_child is set
347 * to the first child and a stackElement representing the second
348 * child is pushed onto the stack.
351 * *c_child_r is the most recent retainer of *c's children.
352 * *c is not any of TSO, AP, PAP, AP_STACK, which means that
353 * there cannot be any stack objects.
354 * Note: SRTs are considered to be children as well.
355 * -------------------------------------------------------------------------- */
357 push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
360 bdescr *nbd; // Next Block Descriptor
362 #ifdef DEBUG_RETAINER
363 // fprintf(stderr, "push(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
366 ASSERT(get_itbl(c)->type != TSO);
367 ASSERT(get_itbl(c)->type != AP_STACK);
374 se.c_child_r = c_child_r;
377 switch (get_itbl(c)->type) {
384 case SE_CAF_BLACKHOLE:
389 // one child (fixed), no SRT
392 *first_child = ((StgMutVar *)c)->var;
395 // blocking_queue must be TSO and the head of a linked list of TSOs.
396 // Shoule it be a child? Seems to be yes.
397 *first_child = (StgClosure *)((StgBlockingQueue *)c)->blocking_queue;
400 *first_child = ((StgSelector *)c)->selectee;
403 case IND_OLDGEN_PERM:
405 *first_child = ((StgIndOldGen *)c)->indirectee;
409 *first_child = c->payload[0];
412 // For CONSTR_2_0 and MVAR, we use se.info.step to record the position
413 // of the next child. We do not write a separate initialization code.
414 // Also we do not have to initialize info.type;
416 // two children (fixed), no SRT
417 // need to push a stackElement, but nothing to store in se.info
419 *first_child = c->payload[0]; // return the first pointer
420 // se.info.type = posTypeStep;
421 // se.info.next.step = 2; // 2 = second
424 // three children (fixed), no SRT
425 // need to push a stackElement
427 // head must be TSO and the head of a linked list of TSOs.
428 // Shoule it be a child? Seems to be yes.
429 *first_child = (StgClosure *)((StgMVar *)c)->head;
430 // se.info.type = posTypeStep;
431 se.info.next.step = 2; // 2 = second
434 // three children (fixed), no SRT
436 *first_child = ((StgWeak *)c)->key;
437 // se.info.type = posTypeStep;
438 se.info.next.step = 2;
441 // layout.payload.ptrs, no SRT
447 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
449 *first_child = find_ptrs(&se.info);
450 if (*first_child == NULL)
454 // StgMutArrPtr.ptrs, no SRT
456 case MUT_ARR_PTRS_FROZEN:
457 init_ptrs(&se.info, ((StgMutArrPtrs *)c)->ptrs,
458 (StgPtr)(((StgMutArrPtrs *)c)->payload));
459 *first_child = find_ptrs(&se.info);
460 if (*first_child == NULL)
464 // layout.payload.ptrs, SRT
465 case FUN: // *c is a heap object.
467 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
468 *first_child = find_ptrs(&se.info);
469 if (*first_child == NULL)
470 // no child from ptrs, so check SRT
476 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
477 *first_child = find_ptrs(&se.info);
478 if (*first_child == NULL)
479 // no child from ptrs, so check SRT
483 // 1 fixed child, SRT
486 *first_child = c->payload[0];
487 ASSERT(*first_child != NULL);
488 init_srt_fun(&se.info, get_fun_itbl(c));
493 *first_child = c->payload[0];
494 ASSERT(*first_child != NULL);
495 init_srt_thunk(&se.info, get_thunk_itbl(c));
498 case FUN_STATIC: // *c is a heap object.
499 ASSERT(get_itbl(c)->srt_len != 0);
503 init_srt_fun(&se.info, get_fun_itbl(c));
504 *first_child = find_srt(&se.info);
505 if (*first_child == NULL)
511 ASSERT(get_itbl(c)->srt_len != 0);
515 init_srt_thunk(&se.info, get_thunk_itbl(c));
516 *first_child = find_srt(&se.info);
517 if (*first_child == NULL)
528 case CONSTR_CHARLIKE:
529 case CONSTR_NOCAF_STATIC:
550 barf("Invalid object *c in push()");
554 if (stackTop - 1 < stackBottom) {
555 #ifdef DEBUG_RETAINER
556 // fprintf(stderr, "push() to the next stack.\n");
558 // currentStack->free is updated when the active stack is switched
559 // to the next stack.
560 currentStack->free = (StgPtr)stackTop;
562 if (currentStack->link == NULL) {
563 nbd = allocGroup(BLOCKS_IN_STACK);
565 nbd->u.back = currentStack;
566 currentStack->link = nbd;
568 nbd = currentStack->link;
573 // adjust stackTop (acutal push)
575 // If the size of stackElement was huge, we would better replace the
576 // following statement by either a memcpy() call or a switch statement
577 // on the type of the element. Currently, the size of stackElement is
578 // small enough (5 words) that this direct assignment seems to be enough.
581 #ifdef DEBUG_RETAINER
583 if (stackSize > maxStackSize) maxStackSize = stackSize;
584 // ASSERT(stackSize >= 0);
585 // fprintf(stderr, "stackSize = %d\n", stackSize);
589 /* -----------------------------------------------------------------------------
590 * popOff() and popOffReal(): Pop a stackElement off the traverse stack.
592 * stackTop cannot be equal to stackLimit unless the whole stack is
593 * empty, in which case popOff() is not allowed.
595 * You can think of popOffReal() as a part of popOff() which is
596 * executed at the end of popOff() in necessary. Since popOff() is
597 * likely to be executed quite often while popOffReal() is not, we
598 * separate popOffReal() from popOff(), which is declared as an
599 * inline function (for the sake of execution speed). popOffReal()
600 * is called only within popOff() and nowhere else.
601 * -------------------------------------------------------------------------- */
605 bdescr *pbd; // Previous Block Descriptor
607 #ifdef DEBUG_RETAINER
608 // fprintf(stderr, "pop() to the previous stack.\n");
611 ASSERT(stackTop + 1 == stackLimit);
612 ASSERT(stackBottom == (stackElement *)currentStack->start);
614 if (firstStack == currentStack) {
615 // The stack is completely empty.
617 ASSERT(stackTop == stackLimit);
618 #ifdef DEBUG_RETAINER
620 if (stackSize > maxStackSize) maxStackSize = stackSize;
622 ASSERT(stackSize >= 0);
623 fprintf(stderr, "stackSize = %d\n", stackSize);
629 // currentStack->free is updated when the active stack is switched back
630 // to the previous stack.
631 currentStack->free = (StgPtr)stackLimit;
633 // find the previous block descriptor
634 pbd = currentStack->u.back;
637 returnToOldStack(pbd);
639 #ifdef DEBUG_RETAINER
641 if (stackSize > maxStackSize) maxStackSize = stackSize;
643 ASSERT(stackSize >= 0);
644 fprintf(stderr, "stackSize = %d\n", stackSize);
651 #ifdef DEBUG_RETAINER
652 // fprintf(stderr, "\tpopOff(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
655 ASSERT(stackTop != stackLimit);
656 ASSERT(!isEmptyRetainerStack());
658 // <= (instead of <) is wrong!
659 if (stackTop + 1 < stackLimit) {
661 #ifdef DEBUG_RETAINER
663 if (stackSize > maxStackSize) maxStackSize = stackSize;
665 ASSERT(stackSize >= 0);
666 fprintf(stderr, "stackSize = %d\n", stackSize);
675 /* -----------------------------------------------------------------------------
676 * Finds the next object to be considered for retainer profiling and store
678 * Test if the topmost stack element indicates that more objects are left,
679 * and if so, retrieve the first object and store its pointer to *c. Also,
680 * set *cp and *r appropriately, both of which are stored in the stack element.
681 * The topmost stack element then is overwritten so as for it to now denote
683 * If the topmost stack element indicates no more objects are left, pop
684 * off the stack element until either an object can be retrieved or
685 * the current stack chunk becomes empty, indicated by rtsTrue returned by
686 * isOnBoundary(), in which case *c is set to NULL.
688 * It is okay to call this function even when the current stack chunk
690 * -------------------------------------------------------------------------- */
692 pop( StgClosure **c, StgClosure **cp, retainer *r )
696 #ifdef DEBUG_RETAINER
697 // fprintf(stderr, "pop(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
701 if (isOnBoundary()) { // if the current stack chunk is depleted
708 switch (get_itbl(se->c)->type) {
709 // two children (fixed), no SRT
710 // nothing in se.info
712 *c = se->c->payload[1];
718 // three children (fixed), no SRT
719 // need to push a stackElement
721 if (se->info.next.step == 2) {
722 *c = (StgClosure *)((StgMVar *)se->c)->tail;
723 se->info.next.step++; // move to the next step
726 *c = ((StgMVar *)se->c)->value;
733 // three children (fixed), no SRT
735 if (se->info.next.step == 2) {
736 *c = ((StgWeak *)se->c)->value;
737 se->info.next.step++;
740 *c = ((StgWeak *)se->c)->finalizer;
752 // StgMutArrPtr.ptrs, no SRT
754 case MUT_ARR_PTRS_FROZEN:
755 *c = find_ptrs(&se->info);
764 // layout.payload.ptrs, SRT
765 case FUN: // always a heap object
767 if (se->info.type == posTypePtrs) {
768 *c = find_ptrs(&se->info);
774 init_srt_fun(&se->info, get_fun_itbl(se->c));
780 if (se->info.type == posTypePtrs) {
781 *c = find_ptrs(&se->info);
787 init_srt_thunk(&se->info, get_thunk_itbl(se->c));
803 *c = find_srt(&se->info);
812 // no child (fixed), no SRT
818 case SE_CAF_BLACKHOLE:
820 // one child (fixed), no SRT
826 case IND_OLDGEN_PERM:
836 case CONSTR_CHARLIKE:
837 case CONSTR_NOCAF_STATIC:
858 barf("Invalid object *c in pop()");
864 /* -----------------------------------------------------------------------------
865 * RETAINER PROFILING ENGINE
866 * -------------------------------------------------------------------------- */
869 initRetainerProfiling( void )
871 initializeAllRetainerSet();
872 retainerGeneration = 0;
875 /* -----------------------------------------------------------------------------
876 * This function must be called before f-closing prof_file.
877 * -------------------------------------------------------------------------- */
879 endRetainerProfiling( void )
881 #ifdef SECOND_APPROACH
882 outputAllRetainerSet(prof_file);
886 /* -----------------------------------------------------------------------------
887 * Returns the actual pointer to the retainer set of the closure *c.
888 * It may adjust RSET(c) subject to flip.
890 * RSET(c) is initialized to NULL if its current value does not
893 * Even though this function has side effects, they CAN be ignored because
894 * subsequent calls to retainerSetOf() always result in the same return value
895 * and retainerSetOf() is the only way to retrieve retainerSet of a given
897 * We have to perform an XOR (^) operation each time a closure is examined.
898 * The reason is that we do not know when a closure is visited last.
899 * -------------------------------------------------------------------------- */
901 maybeInitRetainerSet( StgClosure *c )
903 if (!isRetainerSetFieldValid(c)) {
904 setRetainerSetToNull(c);
908 /* -----------------------------------------------------------------------------
909 * Returns rtsTrue if *c is a retainer.
910 * -------------------------------------------------------------------------- */
911 static inline rtsBool
912 isRetainer( StgClosure *c )
914 switch (get_itbl(c)->type) {
918 // TSOs MUST be retainers: they constitute the set of roots.
926 case MUT_ARR_PTRS_FROZEN:
928 // thunks are retainers.
939 // Static thunks, or CAFS, are obviously retainers.
942 // WEAK objects are roots; there is separate code in which traversing
943 // begins from WEAK objects.
965 // partial applications
971 case SE_CAF_BLACKHOLE:
975 case IND_OLDGEN_PERM:
990 // IND_STATIC cannot be *c, *cp, *r in the retainer profiling loop.
992 // CONSTR_INTLIKE, CONSTR_CHARLIKE, and CONSTR_NOCAF_STATIC
993 // cannot be *c, *cp, *r in the retainer profiling loop.
995 case CONSTR_CHARLIKE:
996 case CONSTR_NOCAF_STATIC:
997 // Stack objects are invalid because they are never treated as
998 // legal objects during retainer profiling.
1016 case INVALID_OBJECT:
1018 barf("Invalid object in isRetainer(): %d", get_itbl(c)->type);
1023 /* -----------------------------------------------------------------------------
1024 * Returns the retainer function value for the closure *c, i.e., R(*c).
1025 * This function does NOT return the retainer(s) of *c.
1027 * *c must be a retainer.
1029 * Depending on the definition of this function, the maintenance of retainer
1030 * sets can be made easier. If most retainer sets are likely to be created
1031 * again across garbage collections, refreshAllRetainerSet() in
1032 * RetainerSet.c can simply do nothing.
1033 * If this is not the case, we can free all the retainer sets and
1034 * re-initialize the hash table.
1035 * See refreshAllRetainerSet() in RetainerSet.c.
1036 * -------------------------------------------------------------------------- */
1037 static inline retainer
1038 getRetainerFrom( StgClosure *c )
1040 ASSERT(isRetainer(c));
1042 #if defined(RETAINER_SCHEME_INFO)
1043 // Retainer scheme 1: retainer = info table
1045 #elif defined(RETAINER_SCHEME_CCS)
1046 // Retainer scheme 2: retainer = cost centre stack
1047 return c->header.prof.ccs;
1048 #elif defined(RETAINER_SCHEME_CC)
1049 // Retainer scheme 3: retainer = cost centre
1050 return c->header.prof.ccs->cc;
1054 /* -----------------------------------------------------------------------------
1055 * Associates the retainer set *s with the closure *c, that is, *s becomes
1056 * the retainer set of *c.
1060 * -------------------------------------------------------------------------- */
1062 associate( StgClosure *c, RetainerSet *s )
1064 // StgWord has the same size as pointers, so the following type
1066 RSET(c) = (RetainerSet *)((StgWord)s | flip);
1069 /* -----------------------------------------------------------------------------
1070 * Call retainClosure for each of the closures in an SRT.
1071 * ------------------------------------------------------------------------- */
1074 retainSRT (StgClosure **srt, nat srt_len, StgClosure *c, retainer c_child_r)
1076 StgClosure **srt_end;
1078 srt_end = srt + srt_len;
1080 for (; srt < srt_end; srt++) {
1081 /* Special-case to handle references to closures hiding out in DLLs, since
1082 double indirections required to get at those. The code generator knows
1083 which is which when generating the SRT, so it stores the (indirect)
1084 reference to the DLL closure in the table by first adding one to it.
1085 We check for this here, and undo the addition before evacuating it.
1087 If the SRT entry hasn't got bit 0 set, the SRT entry points to a
1088 closure that's fixed at link-time, and no extra magic is required.
1090 #ifdef ENABLE_WIN32_DLL_SUPPORT
1091 if ( (unsigned long)(*srt) & 0x1 ) {
1092 retainClosure(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)),
1095 retainClosure(*srt,c,c_child_r);
1098 retainClosure(*srt,c,c_child_r);
1103 /* -----------------------------------------------------------------------------
1104 Call retainClosure for each of the closures covered by a large bitmap.
1105 -------------------------------------------------------------------------- */
1108 retain_large_bitmap (StgPtr p, StgLargeBitmap *large_bitmap, nat size,
1109 StgClosure *c, retainer c_child_r)
1115 bitmap = large_bitmap->bitmap[b];
1116 for (i = 0; i < size; ) {
1117 if ((bitmap & 1) == 0) {
1118 retainClosure((StgClosure *)*p, c, c_child_r);
1122 if (i % BITS_IN(W_) == 0) {
1124 bitmap = large_bitmap->bitmap[b];
1126 bitmap = bitmap >> 1;
1131 static inline StgPtr
1132 retain_small_bitmap (StgPtr p, nat size, StgWord bitmap,
1133 StgClosure *c, retainer c_child_r)
1136 if ((bitmap & 1) == 0) {
1137 retainClosure((StgClosure *)*p, c, c_child_r);
1140 bitmap = bitmap >> 1;
1146 /* -----------------------------------------------------------------------------
1147 * Process all the objects in the stack chunk from stackStart to stackEnd
1148 * with *c and *c_child_r being their parent and their most recent retainer,
1149 * respectively. Treat stackOptionalFun as another child of *c if it is
1152 * *c is one of the following: TSO, AP_STACK.
1153 * If *c is TSO, c == c_child_r.
1154 * stackStart < stackEnd.
1155 * RSET(c) and RSET(c_child_r) are valid, i.e., their
1156 * interpretation conforms to the current value of flip (even when they
1157 * are interpreted to be NULL).
1158 * If *c is TSO, its state is not any of ThreadRelocated, ThreadComplete,
1159 * or ThreadKilled, which means that its stack is ready to process.
1161 * This code was almost plagiarzied from GC.c! For each pointer,
1162 * retainClosure() is invoked instead of evacuate().
1163 * -------------------------------------------------------------------------- */
1165 retainStack( StgClosure *c, retainer c_child_r,
1166 StgPtr stackStart, StgPtr stackEnd )
1168 stackElement *oldStackBoundary;
1170 StgRetInfoTable *info;
1174 #ifdef DEBUG_RETAINER
1176 if (cStackSize > maxCStackSize) maxCStackSize = cStackSize;
1180 Each invocation of retainStack() creates a new virtual
1181 stack. Since all such stacks share a single common stack, we
1182 record the current currentStackBoundary, which will be restored
1185 oldStackBoundary = currentStackBoundary;
1186 currentStackBoundary = stackTop;
1188 #ifdef DEBUG_RETAINER
1189 // fprintf(stderr, "retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
1192 ASSERT(get_itbl(c)->type != TSO ||
1193 (((StgTSO *)c)->what_next != ThreadRelocated &&
1194 ((StgTSO *)c)->what_next != ThreadComplete &&
1195 ((StgTSO *)c)->what_next != ThreadKilled));
1198 while (p < stackEnd) {
1199 info = get_ret_itbl((StgClosure *)p);
1201 switch(info->i.type) {
1204 retainClosure(((StgUpdateFrame *)p)->updatee, c, c_child_r);
1205 p += sizeofW(StgUpdateFrame);
1212 bitmap = BITMAP_BITS(info->i.layout.bitmap);
1213 size = BITMAP_SIZE(info->i.layout.bitmap);
1215 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1218 retainSRT((StgClosure **)info->srt, info->i.srt_len, c, c_child_r);
1225 retainClosure((StgClosure *)*p, c, c_child_r);
1228 size = BCO_BITMAP_SIZE(bco);
1229 retain_large_bitmap(p, BCO_BITMAP(bco), size, c, c_child_r);
1234 // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
1237 size = info->i.layout.large_bitmap->size;
1239 retain_large_bitmap(p, info->i.layout.large_bitmap,
1240 size, c, c_child_r);
1242 // and don't forget to follow the SRT
1245 // Dynamic bitmap: the mask is stored on the stack
1248 dyn = ((StgRetDyn *)p)->liveness;
1250 // traverse the bitmap first
1251 bitmap = GET_LIVENESS(dyn);
1252 p = (P_)&((StgRetDyn *)p)->payload[0];
1253 size = RET_DYN_SIZE;
1254 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1256 // skip over the non-ptr words
1257 p += GET_NONPTRS(dyn);
1259 // follow the ptr words
1260 for (size = GET_PTRS(dyn); size > 0; size--) {
1261 retainClosure((StgClosure *)*p, c, c_child_r);
1268 StgRetFun *ret_fun = (StgRetFun *)p;
1269 StgFunInfoTable *fun_info;
1271 retainClosure(ret_fun->fun, c, c_child_r);
1272 fun_info = get_fun_itbl(ret_fun->fun);
1274 p = (P_)&ret_fun->payload;
1275 switch (fun_info->fun_type) {
1277 bitmap = BITMAP_BITS(fun_info->bitmap);
1278 size = BITMAP_SIZE(fun_info->bitmap);
1279 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1282 size = ((StgLargeBitmap *)fun_info->bitmap)->size;
1283 retain_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap,
1284 size, c, c_child_r);
1288 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
1289 size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->fun_type]);
1290 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1297 barf("Invalid object found in retainStack(): %d",
1298 (int)(info->i.type));
1302 // restore currentStackBoundary
1303 currentStackBoundary = oldStackBoundary;
1304 #ifdef DEBUG_RETAINER
1305 // fprintf(stderr, "retainStack() finished: currentStackBoundary = 0x%x\n", currentStackBoundary);
1308 #ifdef DEBUG_RETAINER
1313 /* ----------------------------------------------------------------------------
1314 * Call retainClosure for each of the children of a PAP/AP
1315 * ------------------------------------------------------------------------- */
1317 static inline StgPtr
1318 retain_PAP (StgPAP *pap, retainer c_child_r)
1321 StgWord bitmap, size;
1322 StgFunInfoTable *fun_info;
1324 retainClosure(pap->fun, (StgClosure *)pap, c_child_r);
1325 fun_info = get_fun_itbl(pap->fun);
1326 ASSERT(fun_info->i.type != PAP);
1328 p = (StgPtr)pap->payload;
1331 switch (fun_info->fun_type) {
1333 bitmap = BITMAP_BITS(fun_info->bitmap);
1334 p = retain_small_bitmap(p, pap->n_args, bitmap,
1335 (StgClosure *)pap, c_child_r);
1338 retain_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap,
1339 size, (StgClosure *)pap, c_child_r);
1343 retain_large_bitmap((StgPtr)pap->payload, BCO_BITMAP(pap->fun),
1344 size, (StgClosure *)pap, c_child_r);
1348 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
1349 p = retain_small_bitmap(p, pap->n_args, bitmap,
1350 (StgClosure *)pap, c_child_r);
1356 /* -----------------------------------------------------------------------------
1357 * Compute the retainer set of *c0 and all its desecents by traversing.
1358 * *cp0 is the parent of *c0, and *r0 is the most recent retainer of *c0.
1360 * c0 = cp0 = r0 holds only for root objects.
1361 * RSET(cp0) and RSET(r0) are valid, i.e., their
1362 * interpretation conforms to the current value of flip (even when they
1363 * are interpreted to be NULL).
1364 * However, RSET(c0) may be corrupt, i.e., it may not conform to
1365 * the current value of flip. If it does not, during the execution
1366 * of this function, RSET(c0) must be initialized as well as all
1369 * stackTop must be the same at the beginning and the exit of this function.
1370 * *c0 can be TSO (as well as AP_STACK).
1371 * -------------------------------------------------------------------------- */
1373 retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
1375 // c = Current closure
1376 // cp = Current closure's Parent
1377 // r = current closures' most recent Retainer
1378 // c_child_r = current closure's children's most recent retainer
1379 // first_child = first child of c
1380 StgClosure *c, *cp, *first_child;
1381 RetainerSet *s, *retainerSetOfc;
1382 retainer r, c_child_r;
1385 #ifdef DEBUG_RETAINER
1386 // StgPtr oldStackTop;
1389 #ifdef DEBUG_RETAINER
1390 // oldStackTop = stackTop;
1391 // fprintf(stderr, "retainClosure() called: c0 = 0x%x, cp0 = 0x%x, r0 = 0x%x\n", c0, cp0, r0);
1394 // (c, cp, r) = (c0, cp0, r0)
1401 //fprintf(stderr, "loop");
1402 // pop to (c, cp, r);
1406 #ifdef DEBUG_RETAINER
1407 // fprintf(stderr, "retainClosure() ends: oldStackTop = 0x%x, stackTop = 0x%x\n", oldStackTop, stackTop);
1412 //fprintf(stderr, "inner_loop");
1415 // c = current closure under consideration,
1416 // cp = current closure's parent,
1417 // r = current closure's most recent retainer
1419 // Loop invariants (on the meaning of c, cp, r, and their retainer sets):
1420 // RSET(cp) and RSET(r) are valid.
1421 // RSET(c) is valid only if c has been visited before.
1423 // Loop invariants (on the relation between c, cp, and r)
1424 // if cp is not a retainer, r belongs to RSET(cp).
1425 // if cp is a retainer, r == cp.
1427 typeOfc = get_itbl(c)->type;
1429 #ifdef DEBUG_RETAINER
1432 case CONSTR_INTLIKE:
1433 case CONSTR_CHARLIKE:
1434 case CONSTR_NOCAF_STATIC:
1440 if (retainerSetOf(c) == NULL) { // first visit?
1441 costArray[typeOfc] += cost(c);
1442 sumOfNewCost += cost(c);
1451 if (((StgTSO *)c)->what_next == ThreadComplete ||
1452 ((StgTSO *)c)->what_next == ThreadKilled) {
1453 #ifdef DEBUG_RETAINER
1454 fprintf(stderr, "ThreadComplete or ThreadKilled encountered in retainClosure()\n");
1458 if (((StgTSO *)c)->what_next == ThreadRelocated) {
1459 #ifdef DEBUG_RETAINER
1460 fprintf(stderr, "ThreadRelocated encountered in retainClosure()\n");
1462 c = (StgClosure *)((StgTSO *)c)->link;
1468 // We just skip IND_STATIC, so its retainer set is never computed.
1469 c = ((StgIndStatic *)c)->indirectee;
1471 case CONSTR_INTLIKE:
1472 case CONSTR_CHARLIKE:
1473 // static objects with no pointers out, so goto loop.
1474 case CONSTR_NOCAF_STATIC:
1475 // It is not just enough not to compute the retainer set for *c; it is
1476 // mandatory because CONSTR_NOCAF_STATIC are not reachable from
1477 // scavenged_static_objects, the list from which is assumed to traverse
1478 // all static objects after major garbage collections.
1482 if (get_itbl(c)->srt_len == 0) {
1483 // No need to compute the retainer set; no dynamic objects
1484 // are reachable from *c.
1486 // Static objects: if we traverse all the live closures,
1487 // including static closures, during each heap census then
1488 // we will observe that some static closures appear and
1489 // disappear. eg. a closure may contain a pointer to a
1490 // static function 'f' which is not otherwise reachable
1491 // (it doesn't indirectly point to any CAFs, so it doesn't
1492 // appear in any SRTs), so we would find 'f' during
1493 // traversal. However on the next sweep there may be no
1494 // closures pointing to 'f'.
1496 // We must therefore ignore static closures whose SRT is
1497 // empty, because these are exactly the closures that may
1498 // "appear". A closure with a non-empty SRT, and which is
1499 // still required, will always be reachable.
1501 // But what about CONSTR_STATIC? Surely these may be able
1502 // to appear, and they don't have SRTs, so we can't
1503 // check. So for now, we're calling
1504 // resetStaticObjectForRetainerProfiling() from the
1505 // garbage collector to reset the retainer sets in all the
1506 // reachable static objects.
1513 // The above objects are ignored in computing the average number of times
1514 // an object is visited.
1515 timesAnyObjectVisited++;
1517 // If this is the first visit to c, initialize its retainer set.
1518 maybeInitRetainerSet(c);
1519 retainerSetOfc = retainerSetOf(c);
1522 // isRetainer(cp) == rtsTrue => s == NULL
1523 // isRetainer(cp) == rtsFalse => s == cp.retainer
1527 s = retainerSetOf(cp);
1529 // (c, cp, r, s) is available.
1531 // (c, cp, r, s, R_r) is available, so compute the retainer set for *c.
1532 if (retainerSetOfc == NULL) {
1533 // This is the first visit to *c.
1537 associate(c, singleton(r));
1539 // s is actually the retainer set of *c!
1542 // compute c_child_r
1543 c_child_r = isRetainer(c) ? getRetainerFrom(c) : r;
1545 // This is not the first visit to *c.
1546 if (isMember(r, retainerSetOfc))
1547 goto loop; // no need to process child
1550 associate(c, addElement(r, retainerSetOfc));
1552 // s is not NULL and cp is not a retainer. This means that
1553 // each time *cp is visited, so is *c. Thus, if s has
1554 // exactly one more element in its retainer set than c, s
1555 // is also the new retainer set for *c.
1556 if (s->num == retainerSetOfc->num + 1) {
1559 // Otherwise, just add R_r to the current retainer set of *c.
1561 associate(c, addElement(r, retainerSetOfc));
1566 goto loop; // no need to process child
1568 // compute c_child_r
1572 // now, RSET() of all of *c, *cp, and *r is valid.
1573 // (c, c_child_r) are available.
1577 // Special case closures: we process these all in one go rather
1578 // than attempting to save the current position, because doing so
1582 retainStack(c, c_child_r,
1584 ((StgTSO *)c)->stack + ((StgTSO *)c)->stack_size);
1589 retain_PAP((StgPAP *)c, c_child_r);
1593 retainClosure(((StgAP_STACK *)c)->fun, c, c_child_r);
1594 retainStack(c, c_child_r,
1595 (StgPtr)((StgAP_STACK *)c)->payload,
1596 (StgPtr)((StgAP_STACK *)c)->payload +
1597 ((StgAP_STACK *)c)->size);
1601 push(c, c_child_r, &first_child);
1603 // If first_child is null, c has no child.
1604 // If first_child is not null, the top stack element points to the next
1605 // object. push() may or may not push a stackElement on the stack.
1606 if (first_child == NULL)
1609 // (c, cp, r) = (first_child, c, c_child_r)
1616 /* -----------------------------------------------------------------------------
1617 * Compute the retainer set for every object reachable from *tl.
1618 * -------------------------------------------------------------------------- */
1620 retainRoot( StgClosure **tl )
1622 // We no longer assume that only TSOs and WEAKs are roots; any closure can
1625 ASSERT(isEmptyRetainerStack());
1626 currentStackBoundary = stackTop;
1628 if (isRetainer(*tl)) {
1629 retainClosure(*tl, *tl, getRetainerFrom(*tl));
1631 retainClosure(*tl, *tl, CCS_SYSTEM);
1634 // NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl)));
1635 // *tl might be a TSO which is ThreadComplete, in which
1636 // case we ignore it for the purposes of retainer profiling.
1639 /* -----------------------------------------------------------------------------
1640 * Compute the retainer set for each of the objects in the heap.
1641 * -------------------------------------------------------------------------- */
1643 computeRetainerSet( void )
1649 #ifdef DEBUG_RETAINER
1650 RetainerSet tmpRetainerSet;
1653 GetRoots(retainRoot); // for scheduler roots
1655 // This function is called after a major GC, when key, value, and finalizer
1656 // all are guaranteed to be valid, or reachable.
1658 // The following code assumes that WEAK objects are considered to be roots
1659 // for retainer profilng.
1660 for (weak = weak_ptr_list; weak != NULL; weak = weak->link)
1661 // retainRoot((StgClosure *)weak);
1662 retainRoot((StgClosure **)&weak);
1664 // Consider roots from the stable ptr table.
1665 markStablePtrTable(retainRoot);
1667 // The following code resets the rs field of each unvisited mutable
1668 // object (computing sumOfNewCostExtra and updating costArray[] when
1669 // debugging retainer profiler).
1670 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1672 (generations[g].mut_list == END_MUT_LIST &&
1673 generations[g].mut_once_list == END_MUT_LIST));
1676 // I think traversing through mut_list is unnecessary.
1677 // Think about removing this part.
1678 for (ml = generations[g].mut_list; ml != END_MUT_LIST;
1679 ml = ml->mut_link) {
1681 maybeInitRetainerSet((StgClosure *)ml);
1682 rtl = retainerSetOf((StgClosure *)ml);
1684 #ifdef DEBUG_RETAINER
1686 // first visit to *ml
1687 // This is a violation of the interface rule!
1688 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1690 switch (get_itbl((StgClosure *)ml)->type) {
1694 case CONSTR_INTLIKE:
1695 case CONSTR_CHARLIKE:
1696 case CONSTR_NOCAF_STATIC:
1700 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1704 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1705 sumOfNewCostExtra += cost((StgClosure *)ml);
1712 // Traversing through mut_once_list is, in contrast, necessary
1713 // because we can find MUT_VAR objects which have not been
1714 // visited during retainer profiling.
1715 for (ml = generations[g].mut_once_list; ml != END_MUT_LIST;
1716 ml = ml->mut_link) {
1718 maybeInitRetainerSet((StgClosure *)ml);
1719 rtl = retainerSetOf((StgClosure *)ml);
1720 #ifdef DEBUG_RETAINER
1722 // first visit to *ml
1723 // This is a violation of the interface rule!
1724 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1726 switch (get_itbl((StgClosure *)ml)->type) {
1730 case CONSTR_INTLIKE:
1731 case CONSTR_CHARLIKE:
1732 case CONSTR_NOCAF_STATIC:
1736 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1740 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1741 sumOfNewCostExtra += cost((StgClosure *)ml);
1750 /* -----------------------------------------------------------------------------
1751 * Traverse all static objects for which we compute retainer sets,
1752 * and reset their rs fields to NULL, which is accomplished by
1753 * invoking maybeInitRetainerSet(). This function must be called
1754 * before zeroing all objects reachable from scavenged_static_objects
1755 * in the case of major gabage collections. See GarbageCollect() in
1758 * The mut_once_list of the oldest generation must also be traversed?
1759 * Why? Because if the evacuation of an object pointed to by a static
1760 * indirection object fails, it is put back to the mut_once_list of
1761 * the oldest generation.
1762 * However, this is not necessary because any static indirection objects
1763 * are just traversed through to reach dynamic objects. In other words,
1764 * they are not taken into consideration in computing retainer sets.
1765 * -------------------------------------------------------------------------- */
1767 resetStaticObjectForRetainerProfiling( void )
1769 #ifdef DEBUG_RETAINER
1774 #ifdef DEBUG_RETAINER
1777 p = scavenged_static_objects;
1778 while (p != END_OF_STATIC_LIST) {
1779 #ifdef DEBUG_RETAINER
1782 switch (get_itbl(p)->type) {
1784 // Since we do not compute the retainer set of any
1785 // IND_STATIC object, we don't have to reset its retainer
1787 p = IND_STATIC_LINK(p);
1790 maybeInitRetainerSet(p);
1791 p = THUNK_STATIC_LINK(p);
1794 maybeInitRetainerSet(p);
1795 p = FUN_STATIC_LINK(p);
1798 maybeInitRetainerSet(p);
1799 p = STATIC_LINK(get_itbl(p), p);
1802 barf("resetStaticObjectForRetainerProfiling: %p (%s)",
1803 p, get_itbl(p)->type);
1807 #ifdef DEBUG_RETAINER
1808 // fprintf(stderr, "count in scavenged_static_objects = %d\n", count);
1812 /* -----------------------------------------------------------------------------
1813 * Perform retainer profiling.
1814 * N is the oldest generation being profilied, where the generations are
1815 * numbered starting at 0.
1818 * This function should be called only immediately after major garbage
1820 * ------------------------------------------------------------------------- */
1822 retainerProfile(void)
1824 #ifdef DEBUG_RETAINER
1826 nat totalHeapSize; // total raw heap size (computed by linear scanning)
1829 #ifdef DEBUG_RETAINER
1830 fprintf(stderr, " < retainerProfile() invoked : %d>\n", retainerGeneration);
1835 // We haven't flipped the bit yet.
1836 #ifdef DEBUG_RETAINER
1837 fprintf(stderr, "Before traversing:\n");
1838 sumOfCostLinear = 0;
1839 for (i = 0;i < N_CLOSURE_TYPES; i++)
1840 costArrayLinear[i] = 0;
1841 totalHeapSize = checkHeapSanityForRetainerProfiling();
1843 fprintf(stderr, "\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1845 fprintf(stderr, "costArrayLinear[] = ");
1846 for (i = 0;i < N_CLOSURE_TYPES; i++)
1847 fprintf(stderr, "[%u:%u] ", i, costArrayLinear[i]);
1848 fprintf(stderr, "\n");
1851 ASSERT(sumOfCostLinear == totalHeapSize);
1854 #define pcostArrayLinear(index) \
1855 if (costArrayLinear[index] > 0) \
1856 fprintf(stderr, "costArrayLinear[" #index "] = %u\n", costArrayLinear[index])
1857 pcostArrayLinear(THUNK_STATIC);
1858 pcostArrayLinear(FUN_STATIC);
1859 pcostArrayLinear(CONSTR_STATIC);
1860 pcostArrayLinear(CONSTR_NOCAF_STATIC);
1861 pcostArrayLinear(CONSTR_INTLIKE);
1862 pcostArrayLinear(CONSTR_CHARLIKE);
1866 // Now we flips flip.
1869 #ifdef DEBUG_RETAINER
1875 numObjectVisited = 0;
1876 timesAnyObjectVisited = 0;
1878 #ifdef DEBUG_RETAINER
1879 fprintf(stderr, "During traversing:\n");
1881 sumOfNewCostExtra = 0;
1882 for (i = 0;i < N_CLOSURE_TYPES; i++)
1887 We initialize the traverse stack each time the retainer profiling is
1888 performed (because the traverse stack size varies on each retainer profiling
1889 and this operation is not costly anyhow). However, we just refresh the
1892 initializeTraverseStack();
1893 #ifdef DEBUG_RETAINER
1894 initializeAllRetainerSet();
1896 refreshAllRetainerSet();
1898 computeRetainerSet();
1900 #ifdef DEBUG_RETAINER
1901 fprintf(stderr, "After traversing:\n");
1902 sumOfCostLinear = 0;
1903 for (i = 0;i < N_CLOSURE_TYPES; i++)
1904 costArrayLinear[i] = 0;
1905 totalHeapSize = checkHeapSanityForRetainerProfiling();
1907 fprintf(stderr, "\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1908 ASSERT(sumOfCostLinear == totalHeapSize);
1910 // now, compare the two results
1913 costArray[] must be exactly the same as costArrayLinear[].
1915 1) Dead weak pointers, whose type is CONSTR. These objects are not
1916 reachable from any roots.
1918 fprintf(stderr, "Comparison:\n");
1919 fprintf(stderr, "\tcostArrayLinear[] (must be empty) = ");
1920 for (i = 0;i < N_CLOSURE_TYPES; i++)
1921 if (costArray[i] != costArrayLinear[i])
1922 // nothing should be printed except MUT_VAR after major GCs
1923 fprintf(stderr, "[%u:%u] ", i, costArrayLinear[i]);
1924 fprintf(stderr, "\n");
1926 fprintf(stderr, "\tsumOfNewCost = %u\n", sumOfNewCost);
1927 fprintf(stderr, "\tsumOfNewCostExtra = %u\n", sumOfNewCostExtra);
1928 fprintf(stderr, "\tcostArray[] (must be empty) = ");
1929 for (i = 0;i < N_CLOSURE_TYPES; i++)
1930 if (costArray[i] != costArrayLinear[i])
1931 // nothing should be printed except MUT_VAR after major GCs
1932 fprintf(stderr, "[%u:%u] ", i, costArray[i]);
1933 fprintf(stderr, "\n");
1935 // only for major garbage collection
1936 ASSERT(sumOfNewCost + sumOfNewCostExtra == sumOfCostLinear);
1940 closeTraverseStack();
1941 #ifdef DEBUG_RETAINER
1942 closeAllRetainerSet();
1944 // Note that there is no post-processing for the retainer sets.
1946 retainerGeneration++;
1949 retainerGeneration - 1, // retainerGeneration has just been incremented!
1950 #ifdef DEBUG_RETAINER
1951 maxCStackSize, maxStackSize,
1953 (double)timesAnyObjectVisited / numObjectVisited);
1956 /* -----------------------------------------------------------------------------
1958 * -------------------------------------------------------------------------- */
1960 #ifdef DEBUG_RETAINER
1962 #define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
1963 ((HEAP_ALLOCED(r) && Bdescr((P_)r)->free != (void *)-1))) && \
1964 ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa))
1967 sanityCheckHeapClosure( StgClosure *c )
1971 ASSERT(LOOKS_LIKE_GHC_INFO(c->header.info));
1972 ASSERT(!closure_STATIC(c));
1973 ASSERT(LOOKS_LIKE_PTR(c));
1975 if ((((StgWord)RSET(c) & 1) ^ flip) != 0) {
1976 if (get_itbl(c)->type == CONSTR &&
1977 !strcmp(get_itbl(c)->prof.closure_type, "DEAD_WEAK") &&
1978 !strcmp(get_itbl(c)->prof.closure_desc, "DEAD_WEAK")) {
1979 fprintf(stderr, "\tUnvisited dead weak pointer object found: c = %p\n", c);
1980 costArray[get_itbl(c)->type] += cost(c);
1981 sumOfNewCost += cost(c);
1984 "Unvisited object: flip = %d, c = %p(%d, %s, %s), rs = %p\n",
1985 flip, c, get_itbl(c)->type,
1986 get_itbl(c)->prof.closure_type, get_itbl(c)->prof.closure_desc,
1989 // fprintf(stderr, "sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c));
1993 switch (info->type) {
1995 return tso_sizeW((StgTSO *)c);
2003 return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE);
2006 return sizeofW(StgMVar);
2009 case MUT_ARR_PTRS_FROZEN:
2010 return mut_arr_ptrs_sizeW((StgMutArrPtrs *)c);
2014 return pap_sizeW((StgPAP *)c);
2017 return ap_stack_sizeW((StgAP_STACK *)c);
2020 return arr_words_sizeW((StgArrWords *)c);
2040 case SE_CAF_BLACKHOLE:
2044 case IND_OLDGEN_PERM:
2048 return sizeW_fromITBL(info);
2050 case THUNK_SELECTOR:
2051 return sizeofW(StgHeader) + MIN_UPD_SIZE;
2060 case CONSTR_INTLIKE:
2061 case CONSTR_CHARLIKE:
2062 case CONSTR_NOCAF_STATIC:
2079 case INVALID_OBJECT:
2081 barf("Invalid object in sanityCheckHeapClosure(): %d",
2088 heapCheck( bdescr *bd )
2091 static nat costSum, size;
2094 while (bd != NULL) {
2096 while (p < bd->free) {
2097 size = sanityCheckHeapClosure((StgClosure *)p);
2098 sumOfCostLinear += size;
2099 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2101 // no need for slop check; I think slops are not used currently.
2103 ASSERT(p == bd->free);
2104 costSum += bd->free - bd->start;
2112 smallObjectPoolCheck(void)
2116 static nat costSum, size;
2118 bd = small_alloc_list;
2126 while (p < alloc_Hp) {
2127 size = sanityCheckHeapClosure((StgClosure *)p);
2128 sumOfCostLinear += size;
2129 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2132 ASSERT(p == alloc_Hp);
2133 costSum += alloc_Hp - bd->start;
2136 while (bd != NULL) {
2138 while (p < bd->free) {
2139 size = sanityCheckHeapClosure((StgClosure *)p);
2140 sumOfCostLinear += size;
2141 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2144 ASSERT(p == bd->free);
2145 costSum += bd->free - bd->start;
2153 chainCheck(bdescr *bd)
2158 while (bd != NULL) {
2159 // bd->free - bd->start is not an accurate measurement of the
2160 // object size. Actually it is always zero, so we compute its
2162 size = sanityCheckHeapClosure((StgClosure *)bd->start);
2163 sumOfCostLinear += size;
2164 costArrayLinear[get_itbl((StgClosure *)bd->start)->type] += size;
2173 checkHeapSanityForRetainerProfiling( void )
2178 fprintf(stderr, "START: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2179 if (RtsFlags.GcFlags.generations == 1) {
2180 costSum += heapCheck(g0s0->to_blocks);
2181 fprintf(stderr, "heapCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2182 costSum += chainCheck(g0s0->large_objects);
2183 fprintf(stderr, "chainCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2185 for (g = 0; g < RtsFlags.GcFlags.generations; g++)
2186 for (s = 0; s < generations[g].n_steps; s++) {
2188 After all live objects have been scavenged, the garbage
2189 collector may create some objects in
2190 scheduleFinalizers(). These objects are created throught
2191 allocate(), so the small object pool or the large object
2192 pool of the g0s0 may not be empty.
2194 if (g == 0 && s == 0) {
2195 costSum += smallObjectPoolCheck();
2196 fprintf(stderr, "smallObjectPoolCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2197 costSum += chainCheck(generations[g].steps[s].large_objects);
2198 fprintf(stderr, "chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2200 costSum += heapCheck(generations[g].steps[s].blocks);
2201 fprintf(stderr, "heapCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2202 costSum += chainCheck(generations[g].steps[s].large_objects);
2203 fprintf(stderr, "chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2212 findPointer(StgPtr p)
2218 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2219 for (s = 0; s < generations[g].n_steps; s++) {
2220 // if (g == 0 && s == 0) continue;
2221 bd = generations[g].steps[s].blocks;
2222 for (; bd; bd = bd->link) {
2223 for (q = bd->start; q < bd->free; q++) {
2224 if (*q == (StgWord)p) {
2226 while (!LOOKS_LIKE_GHC_INFO(*r)) r--;
2227 fprintf(stderr, "Found in gen[%d], step[%d]: q = %p, r = %p\n", g, s, q, r);
2232 bd = generations[g].steps[s].large_objects;
2233 for (; bd; bd = bd->link) {
2234 e = bd->start + cost((StgClosure *)bd->start);
2235 for (q = bd->start; q < e; q++) {
2236 if (*q == (StgWord)p) {
2238 while (*r == 0 || !LOOKS_LIKE_GHC_INFO(*r)) r--;
2239 fprintf(stderr, "Found in gen[%d], large_objects: %p\n", g, r);
2249 belongToHeap(StgPtr p)
2254 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2255 for (s = 0; s < generations[g].n_steps; s++) {
2256 // if (g == 0 && s == 0) continue;
2257 bd = generations[g].steps[s].blocks;
2258 for (; bd; bd = bd->link) {
2259 if (bd->start <= p && p < bd->free) {
2260 fprintf(stderr, "Belongs to gen[%d], step[%d]", g, s);
2264 bd = generations[g].steps[s].large_objects;
2265 for (; bd; bd = bd->link) {
2266 if (bd->start <= p && p < bd->start + getHeapClosureSize((StgClosure *)bd->start)) {
2267 fprintf(stderr, "Found in gen[%d], large_objects: %p\n", g, bd->start);
2274 #endif // DEBUG_RETAINER
2276 #endif /* PROFILING */