1 /* -----------------------------------------------------------------------------
2 * $Id: RetainerProfile.c,v 1.6 2002/12/11 15:36:47 simonmar 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"
31 #include "Proftimer.h"
36 Note: what to change in order to plug-in a new retainer profiling scheme?
37 (1) type retainer in ../includes/StgRetainerProf.h
38 (2) retainer function R(), i.e., getRetainerFrom()
39 (3) the two hashing functions, hashKeySingleton() and hashKeyAddElement(),
40 in RetainerSet.h, if needed.
41 (4) printRetainer() and printRetainerSetShort() in RetainerSet.c.
44 /* -----------------------------------------------------------------------------
46 * -------------------------------------------------------------------------- */
48 static nat retainerGeneration; // generation
50 static nat numObjectVisited; // total number of objects visited
51 static nat timesAnyObjectVisited; // number of times any objects are visited
54 The rs field in the profile header of any object points to its retainer
55 set in an indirect way: if flip is 0, it points to the retainer set;
56 if flip is 1, it points to the next byte after the retainer set (even
57 for NULL pointers). Therefore, with flip 1, (rs ^ 1) is the actual
58 pointer. See retainerSetOf().
61 StgWord flip = 0; // flip bit
62 // must be 0 if DEBUG_RETAINER is on (for static closures)
64 #define setRetainerSetToNull(c) \
65 (c)->header.prof.hp.rs = (RetainerSet *)((StgWord)NULL | flip)
67 static void retainStack(StgClosure *, retainer, StgPtr, StgPtr);
68 static void retainClosure(StgClosure *, StgClosure *, retainer);
70 static void belongToHeap(StgPtr p);
75 cStackSize records how many times retainStack() has been invoked recursively,
76 that is, the number of activation records for retainStack() on the C stack.
77 maxCStackSize records its max value.
79 cStackSize <= maxCStackSize
81 static nat cStackSize, maxCStackSize;
83 static nat sumOfNewCost; // sum of the cost of each object, computed
84 // when the object is first visited
85 static nat sumOfNewCostExtra; // for those objects not visited during
86 // retainer profiling, e.g., MUT_VAR
87 static nat costArray[N_CLOSURE_TYPES];
89 nat sumOfCostLinear; // sum of the costs of all object, computed
90 // when linearly traversing the heap after
92 nat costArrayLinear[N_CLOSURE_TYPES];
95 /* -----------------------------------------------------------------------------
96 * Retainer stack - header
98 * Although the retainer stack implementation could be separated *
99 * from the retainer profiling engine, there does not seem to be
100 * any advantage in doing that; retainer stack is an integral part
101 * of retainer profiling engine and cannot be use elsewhere at
103 * -------------------------------------------------------------------------- */
112 // fixed layout or layout specified by a field in the closure
117 // See StgClosureInfo in InfoTables.h
118 #if SIZEOF_VOID_P == 8
131 StgClosure **srt_end;
148 firstStack points to the first block group.
149 currentStack points to the block group currently being used.
150 currentStack->free == stackLimit.
151 stackTop points to the topmost byte in the stack of currentStack.
152 Unless the whole stack is empty, stackTop must point to the topmost
153 object (or byte) in the whole stack. Thus, it is only when the whole stack
154 is empty that stackTop == stackLimit (not during the execution of push()
156 stackBottom == currentStack->start.
157 stackLimit == currentStack->start + BLOCK_SIZE_W * currentStack->blocks.
159 When a current stack becomes empty, stackTop is set to point to
160 the topmost element on the previous block group so as to satisfy
161 the invariants described above.
163 bdescr *firstStack = NULL;
164 static bdescr *currentStack;
165 static stackElement *stackBottom, *stackTop, *stackLimit;
168 currentStackBoundary is used to mark the current stack chunk.
169 If stackTop == currentStackBoundary, it means that the current stack chunk
170 is empty. It is the responsibility of the user to keep currentStackBoundary
171 valid all the time if it is to be employed.
173 static stackElement *currentStackBoundary;
176 stackSize records the current size of the stack.
177 maxStackSize records its high water mark.
179 stackSize <= maxStackSize
181 stackSize is just an estimate measure of the depth of the graph. The reason
182 is that some heap objects have only a single child and may not result
183 in a new element being pushed onto the stack. Therefore, at the end of
184 retainer profiling, maxStackSize + maxCStackSize is some value no greater
185 than the actual depth of the graph.
187 #ifdef DEBUG_RETAINER
188 static int stackSize, maxStackSize;
191 // number of blocks allocated for one stack
192 #define BLOCKS_IN_STACK 1
194 /* -----------------------------------------------------------------------------
195 * Add a new block group to the stack.
197 * currentStack->link == s.
198 * -------------------------------------------------------------------------- */
200 newStackBlock( bdescr *bd )
203 stackTop = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
204 stackBottom = (stackElement *)bd->start;
205 stackLimit = (stackElement *)stackTop;
206 bd->free = (StgPtr)stackLimit;
209 /* -----------------------------------------------------------------------------
210 * Return to the previous block group.
212 * s->link == currentStack.
213 * -------------------------------------------------------------------------- */
215 returnToOldStack( bdescr *bd )
218 stackTop = (stackElement *)bd->free;
219 stackBottom = (stackElement *)bd->start;
220 stackLimit = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
221 bd->free = (StgPtr)stackLimit;
224 /* -----------------------------------------------------------------------------
225 * Initializes the traverse stack.
226 * -------------------------------------------------------------------------- */
228 initializeTraverseStack( void )
230 if (firstStack != NULL) {
231 freeChain(firstStack);
234 firstStack = allocGroup(BLOCKS_IN_STACK);
235 firstStack->link = NULL;
236 firstStack->u.back = NULL;
238 newStackBlock(firstStack);
241 /* -----------------------------------------------------------------------------
242 * Frees all the block groups in the traverse stack.
245 * -------------------------------------------------------------------------- */
247 closeTraverseStack( void )
249 freeChain(firstStack);
253 /* -----------------------------------------------------------------------------
254 * Returns rtsTrue if the whole stack is empty.
255 * -------------------------------------------------------------------------- */
256 static inline rtsBool
257 isEmptyRetainerStack( void )
259 return (firstStack == currentStack) && stackTop == stackLimit;
262 /* -----------------------------------------------------------------------------
263 * Returns rtsTrue if stackTop is at the stack boundary of the current stack,
264 * i.e., if the current stack chunk is empty.
265 * -------------------------------------------------------------------------- */
266 static inline rtsBool
269 return stackTop == currentStackBoundary;
272 /* -----------------------------------------------------------------------------
273 * Initializes *info from ptrs and payload.
275 * payload[] begins with ptrs pointers followed by non-pointers.
276 * -------------------------------------------------------------------------- */
278 init_ptrs( stackPos *info, nat ptrs, StgPtr payload )
280 info->type = posTypePtrs;
281 info->next.ptrs.pos = 0;
282 info->next.ptrs.ptrs = ptrs;
283 info->next.ptrs.payload = payload;
286 /* -----------------------------------------------------------------------------
287 * Find the next object from *info.
288 * -------------------------------------------------------------------------- */
289 static inline StgClosure *
290 find_ptrs( stackPos *info )
292 if (info->next.ptrs.pos < info->next.ptrs.ptrs) {
293 return (StgClosure *)info->next.ptrs.payload[info->next.ptrs.pos++];
299 /* -----------------------------------------------------------------------------
300 * Initializes *info from SRT information stored in *infoTable.
301 * -------------------------------------------------------------------------- */
303 init_srt_fun( stackPos *info, StgFunInfoTable *infoTable )
305 info->type = posTypeSRT;
306 info->next.srt.srt = (StgClosure **)(infoTable->srt);
307 info->next.srt.srt_end = info->next.srt.srt + infoTable->i.srt_len;
311 init_srt_thunk( stackPos *info, StgThunkInfoTable *infoTable )
313 info->type = posTypeSRT;
314 info->next.srt.srt = (StgClosure **)(infoTable->srt);
315 info->next.srt.srt_end = info->next.srt.srt + infoTable->i.srt_len;
318 /* -----------------------------------------------------------------------------
319 * Find the next object from *info.
320 * -------------------------------------------------------------------------- */
321 static inline StgClosure *
322 find_srt( stackPos *info )
326 if (info->next.srt.srt < info->next.srt.srt_end) {
327 // See scavenge_srt() in GC.c for details.
328 #ifdef ENABLE_WIN32_DLL_SUPPORT
329 if ((unsigned long)(*(info->next.srt.srt)) & 0x1)
330 c = (* (StgClosure **)((unsigned long)*(info->next.srt.srt)) & ~0x1);
332 c = *(info->next.srt.srt);
334 c = *(info->next.srt.srt);
336 info->next.srt.srt++;
343 /* -----------------------------------------------------------------------------
344 * push() pushes a stackElement representing the next child of *c
345 * onto the traverse stack. If *c has no child, *first_child is set
346 * to NULL and nothing is pushed onto the stack. If *c has only one
347 * child, *c_chlid is set to that child and nothing is pushed onto
348 * the stack. If *c has more than two children, *first_child is set
349 * to the first child and a stackElement representing the second
350 * child is pushed onto the stack.
353 * *c_child_r is the most recent retainer of *c's children.
354 * *c is not any of TSO, AP, PAP, AP_STACK, which means that
355 * there cannot be any stack objects.
356 * Note: SRTs are considered to be children as well.
357 * -------------------------------------------------------------------------- */
359 push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
362 bdescr *nbd; // Next Block Descriptor
364 #ifdef DEBUG_RETAINER
365 // fprintf(stderr, "push(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
368 ASSERT(get_itbl(c)->type != TSO);
369 ASSERT(get_itbl(c)->type != AP_STACK);
376 se.c_child_r = c_child_r;
379 switch (get_itbl(c)->type) {
386 case SE_CAF_BLACKHOLE:
391 // one child (fixed), no SRT
394 *first_child = ((StgMutVar *)c)->var;
397 // blocking_queue must be TSO and the head of a linked list of TSOs.
398 // Shoule it be a child? Seems to be yes.
399 *first_child = (StgClosure *)((StgBlockingQueue *)c)->blocking_queue;
402 *first_child = ((StgSelector *)c)->selectee;
405 case IND_OLDGEN_PERM:
407 *first_child = ((StgIndOldGen *)c)->indirectee;
411 *first_child = c->payload[0];
414 // For CONSTR_2_0 and MVAR, we use se.info.step to record the position
415 // of the next child. We do not write a separate initialization code.
416 // Also we do not have to initialize info.type;
418 // two children (fixed), no SRT
419 // need to push a stackElement, but nothing to store in se.info
421 *first_child = c->payload[0]; // return the first pointer
422 // se.info.type = posTypeStep;
423 // se.info.next.step = 2; // 2 = second
426 // three children (fixed), no SRT
427 // need to push a stackElement
429 // head must be TSO and the head of a linked list of TSOs.
430 // Shoule it be a child? Seems to be yes.
431 *first_child = (StgClosure *)((StgMVar *)c)->head;
432 // se.info.type = posTypeStep;
433 se.info.next.step = 2; // 2 = second
436 // three children (fixed), no SRT
438 *first_child = ((StgWeak *)c)->key;
439 // se.info.type = posTypeStep;
440 se.info.next.step = 2;
443 // layout.payload.ptrs, no SRT
449 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
451 *first_child = find_ptrs(&se.info);
452 if (*first_child == NULL)
456 // StgMutArrPtr.ptrs, no SRT
458 case MUT_ARR_PTRS_FROZEN:
459 init_ptrs(&se.info, ((StgMutArrPtrs *)c)->ptrs,
460 (StgPtr)(((StgMutArrPtrs *)c)->payload));
461 *first_child = find_ptrs(&se.info);
462 if (*first_child == NULL)
466 // layout.payload.ptrs, SRT
467 case FUN: // *c is a heap object.
469 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
470 *first_child = find_ptrs(&se.info);
471 if (*first_child == NULL)
472 // no child from ptrs, so check SRT
478 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
479 *first_child = find_ptrs(&se.info);
480 if (*first_child == NULL)
481 // no child from ptrs, so check SRT
485 // 1 fixed child, SRT
488 *first_child = c->payload[0];
489 ASSERT(*first_child != NULL);
490 init_srt_fun(&se.info, get_fun_itbl(c));
495 *first_child = c->payload[0];
496 ASSERT(*first_child != NULL);
497 init_srt_thunk(&se.info, get_thunk_itbl(c));
500 case FUN_STATIC: // *c is a heap object.
501 ASSERT(get_itbl(c)->srt_len != 0);
505 init_srt_fun(&se.info, get_fun_itbl(c));
506 *first_child = find_srt(&se.info);
507 if (*first_child == NULL)
513 ASSERT(get_itbl(c)->srt_len != 0);
517 init_srt_thunk(&se.info, get_thunk_itbl(c));
518 *first_child = find_srt(&se.info);
519 if (*first_child == NULL)
530 case CONSTR_CHARLIKE:
531 case CONSTR_NOCAF_STATIC:
552 barf("Invalid object *c in push()");
556 if (stackTop - 1 < stackBottom) {
557 #ifdef DEBUG_RETAINER
558 // fprintf(stderr, "push() to the next stack.\n");
560 // currentStack->free is updated when the active stack is switched
561 // to the next stack.
562 currentStack->free = (StgPtr)stackTop;
564 if (currentStack->link == NULL) {
565 nbd = allocGroup(BLOCKS_IN_STACK);
567 nbd->u.back = currentStack;
568 currentStack->link = nbd;
570 nbd = currentStack->link;
575 // adjust stackTop (acutal push)
577 // If the size of stackElement was huge, we would better replace the
578 // following statement by either a memcpy() call or a switch statement
579 // on the type of the element. Currently, the size of stackElement is
580 // small enough (5 words) that this direct assignment seems to be enough.
583 #ifdef DEBUG_RETAINER
585 if (stackSize > maxStackSize) maxStackSize = stackSize;
586 // ASSERT(stackSize >= 0);
587 // fprintf(stderr, "stackSize = %d\n", stackSize);
591 /* -----------------------------------------------------------------------------
592 * popOff() and popOffReal(): Pop a stackElement off the traverse stack.
594 * stackTop cannot be equal to stackLimit unless the whole stack is
595 * empty, in which case popOff() is not allowed.
597 * You can think of popOffReal() as a part of popOff() which is
598 * executed at the end of popOff() in necessary. Since popOff() is
599 * likely to be executed quite often while popOffReal() is not, we
600 * separate popOffReal() from popOff(), which is declared as an
601 * inline function (for the sake of execution speed). popOffReal()
602 * is called only within popOff() and nowhere else.
603 * -------------------------------------------------------------------------- */
607 bdescr *pbd; // Previous Block Descriptor
609 #ifdef DEBUG_RETAINER
610 // fprintf(stderr, "pop() to the previous stack.\n");
613 ASSERT(stackTop + 1 == stackLimit);
614 ASSERT(stackBottom == (stackElement *)currentStack->start);
616 if (firstStack == currentStack) {
617 // The stack is completely empty.
619 ASSERT(stackTop == stackLimit);
620 #ifdef DEBUG_RETAINER
622 if (stackSize > maxStackSize) maxStackSize = stackSize;
624 ASSERT(stackSize >= 0);
625 fprintf(stderr, "stackSize = %d\n", stackSize);
631 // currentStack->free is updated when the active stack is switched back
632 // to the previous stack.
633 currentStack->free = (StgPtr)stackLimit;
635 // find the previous block descriptor
636 pbd = currentStack->u.back;
639 returnToOldStack(pbd);
641 #ifdef DEBUG_RETAINER
643 if (stackSize > maxStackSize) maxStackSize = stackSize;
645 ASSERT(stackSize >= 0);
646 fprintf(stderr, "stackSize = %d\n", stackSize);
653 #ifdef DEBUG_RETAINER
654 // fprintf(stderr, "\tpopOff(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
657 ASSERT(stackTop != stackLimit);
658 ASSERT(!isEmptyRetainerStack());
660 // <= (instead of <) is wrong!
661 if (stackTop + 1 < stackLimit) {
663 #ifdef DEBUG_RETAINER
665 if (stackSize > maxStackSize) maxStackSize = stackSize;
667 ASSERT(stackSize >= 0);
668 fprintf(stderr, "stackSize = %d\n", stackSize);
677 /* -----------------------------------------------------------------------------
678 * Finds the next object to be considered for retainer profiling and store
680 * Test if the topmost stack element indicates that more objects are left,
681 * and if so, retrieve the first object and store its pointer to *c. Also,
682 * set *cp and *r appropriately, both of which are stored in the stack element.
683 * The topmost stack element then is overwritten so as for it to now denote
685 * If the topmost stack element indicates no more objects are left, pop
686 * off the stack element until either an object can be retrieved or
687 * the current stack chunk becomes empty, indicated by rtsTrue returned by
688 * isOnBoundary(), in which case *c is set to NULL.
690 * It is okay to call this function even when the current stack chunk
692 * -------------------------------------------------------------------------- */
694 pop( StgClosure **c, StgClosure **cp, retainer *r )
698 #ifdef DEBUG_RETAINER
699 // fprintf(stderr, "pop(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
703 if (isOnBoundary()) { // if the current stack chunk is depleted
710 switch (get_itbl(se->c)->type) {
711 // two children (fixed), no SRT
712 // nothing in se.info
714 *c = se->c->payload[1];
720 // three children (fixed), no SRT
721 // need to push a stackElement
723 if (se->info.next.step == 2) {
724 *c = (StgClosure *)((StgMVar *)se->c)->tail;
725 se->info.next.step++; // move to the next step
728 *c = ((StgMVar *)se->c)->value;
735 // three children (fixed), no SRT
737 if (se->info.next.step == 2) {
738 *c = ((StgWeak *)se->c)->value;
739 se->info.next.step++;
742 *c = ((StgWeak *)se->c)->finalizer;
754 // StgMutArrPtr.ptrs, no SRT
756 case MUT_ARR_PTRS_FROZEN:
757 *c = find_ptrs(&se->info);
766 // layout.payload.ptrs, SRT
767 case FUN: // always a heap object
769 if (se->info.type == posTypePtrs) {
770 *c = find_ptrs(&se->info);
776 init_srt_fun(&se->info, get_fun_itbl(se->c));
782 if (se->info.type == posTypePtrs) {
783 *c = find_ptrs(&se->info);
789 init_srt_thunk(&se->info, get_thunk_itbl(se->c));
805 *c = find_srt(&se->info);
814 // no child (fixed), no SRT
820 case SE_CAF_BLACKHOLE:
822 // one child (fixed), no SRT
828 case IND_OLDGEN_PERM:
838 case CONSTR_CHARLIKE:
839 case CONSTR_NOCAF_STATIC:
860 barf("Invalid object *c in pop()");
866 /* -----------------------------------------------------------------------------
867 * RETAINER PROFILING ENGINE
868 * -------------------------------------------------------------------------- */
871 initRetainerProfiling( void )
873 initializeAllRetainerSet();
874 retainerGeneration = 0;
877 /* -----------------------------------------------------------------------------
878 * This function must be called before f-closing prof_file.
879 * -------------------------------------------------------------------------- */
881 endRetainerProfiling( void )
883 #ifdef SECOND_APPROACH
884 outputAllRetainerSet(prof_file);
888 /* -----------------------------------------------------------------------------
889 * Returns the actual pointer to the retainer set of the closure *c.
890 * It may adjust RSET(c) subject to flip.
892 * RSET(c) is initialized to NULL if its current value does not
895 * Even though this function has side effects, they CAN be ignored because
896 * subsequent calls to retainerSetOf() always result in the same return value
897 * and retainerSetOf() is the only way to retrieve retainerSet of a given
899 * We have to perform an XOR (^) operation each time a closure is examined.
900 * The reason is that we do not know when a closure is visited last.
901 * -------------------------------------------------------------------------- */
903 maybeInitRetainerSet( StgClosure *c )
905 if (!isRetainerSetFieldValid(c)) {
906 setRetainerSetToNull(c);
910 /* -----------------------------------------------------------------------------
911 * Returns rtsTrue if *c is a retainer.
912 * -------------------------------------------------------------------------- */
913 static inline rtsBool
914 isRetainer( StgClosure *c )
916 switch (get_itbl(c)->type) {
920 // TSOs MUST be retainers: they constitute the set of roots.
928 case MUT_ARR_PTRS_FROZEN:
930 // thunks are retainers.
941 // Static thunks, or CAFS, are obviously retainers.
944 // WEAK objects are roots; there is separate code in which traversing
945 // begins from WEAK objects.
967 // partial applications
973 case SE_CAF_BLACKHOLE:
977 case IND_OLDGEN_PERM:
992 // IND_STATIC cannot be *c, *cp, *r in the retainer profiling loop.
994 // CONSTR_INTLIKE, CONSTR_CHARLIKE, and CONSTR_NOCAF_STATIC
995 // cannot be *c, *cp, *r in the retainer profiling loop.
997 case CONSTR_CHARLIKE:
998 case CONSTR_NOCAF_STATIC:
999 // Stack objects are invalid because they are never treated as
1000 // legal objects during retainer profiling.
1018 case INVALID_OBJECT:
1020 barf("Invalid object in isRetainer(): %d", get_itbl(c)->type);
1025 /* -----------------------------------------------------------------------------
1026 * Returns the retainer function value for the closure *c, i.e., R(*c).
1027 * This function does NOT return the retainer(s) of *c.
1029 * *c must be a retainer.
1031 * Depending on the definition of this function, the maintenance of retainer
1032 * sets can be made easier. If most retainer sets are likely to be created
1033 * again across garbage collections, refreshAllRetainerSet() in
1034 * RetainerSet.c can simply do nothing.
1035 * If this is not the case, we can free all the retainer sets and
1036 * re-initialize the hash table.
1037 * See refreshAllRetainerSet() in RetainerSet.c.
1038 * -------------------------------------------------------------------------- */
1039 static inline retainer
1040 getRetainerFrom( StgClosure *c )
1042 ASSERT(isRetainer(c));
1044 #if defined(RETAINER_SCHEME_INFO)
1045 // Retainer scheme 1: retainer = info table
1047 #elif defined(RETAINER_SCHEME_CCS)
1048 // Retainer scheme 2: retainer = cost centre stack
1049 return c->header.prof.ccs;
1050 #elif defined(RETAINER_SCHEME_CC)
1051 // Retainer scheme 3: retainer = cost centre
1052 return c->header.prof.ccs->cc;
1056 /* -----------------------------------------------------------------------------
1057 * Associates the retainer set *s with the closure *c, that is, *s becomes
1058 * the retainer set of *c.
1062 * -------------------------------------------------------------------------- */
1064 associate( StgClosure *c, RetainerSet *s )
1066 // StgWord has the same size as pointers, so the following type
1068 RSET(c) = (RetainerSet *)((StgWord)s | flip);
1071 /* -----------------------------------------------------------------------------
1072 * Call retainClosure for each of the closures in an SRT.
1073 * ------------------------------------------------------------------------- */
1076 retainSRT (StgClosure **srt, nat srt_len, StgClosure *c, retainer c_child_r)
1078 StgClosure **srt_end;
1080 srt_end = srt + srt_len;
1082 for (; srt < srt_end; srt++) {
1083 /* Special-case to handle references to closures hiding out in DLLs, since
1084 double indirections required to get at those. The code generator knows
1085 which is which when generating the SRT, so it stores the (indirect)
1086 reference to the DLL closure in the table by first adding one to it.
1087 We check for this here, and undo the addition before evacuating it.
1089 If the SRT entry hasn't got bit 0 set, the SRT entry points to a
1090 closure that's fixed at link-time, and no extra magic is required.
1092 #ifdef ENABLE_WIN32_DLL_SUPPORT
1093 if ( (unsigned long)(*srt) & 0x1 ) {
1094 retainClosure(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)),
1097 retainClosure(*srt,c,c_child_r);
1100 retainClosure(*srt,c,c_child_r);
1105 /* -----------------------------------------------------------------------------
1106 Call retainClosure for each of the closures covered by a large bitmap.
1107 -------------------------------------------------------------------------- */
1110 retain_large_bitmap (StgPtr p, StgLargeBitmap *large_bitmap, nat size,
1111 StgClosure *c, retainer c_child_r)
1117 bitmap = large_bitmap->bitmap[b];
1118 for (i = 0; i < size; ) {
1119 if ((bitmap & 1) == 0) {
1120 retainClosure((StgClosure *)*p, c, c_child_r);
1124 if (i % BITS_IN(W_) == 0) {
1126 bitmap = large_bitmap->bitmap[b];
1128 bitmap = bitmap >> 1;
1133 static inline StgPtr
1134 retain_small_bitmap (StgPtr p, nat size, StgWord bitmap,
1135 StgClosure *c, retainer c_child_r)
1138 if ((bitmap & 1) == 0) {
1139 retainClosure((StgClosure *)*p, c, c_child_r);
1142 bitmap = bitmap >> 1;
1148 /* -----------------------------------------------------------------------------
1149 * Process all the objects in the stack chunk from stackStart to stackEnd
1150 * with *c and *c_child_r being their parent and their most recent retainer,
1151 * respectively. Treat stackOptionalFun as another child of *c if it is
1154 * *c is one of the following: TSO, AP_STACK.
1155 * If *c is TSO, c == c_child_r.
1156 * stackStart < stackEnd.
1157 * RSET(c) and RSET(c_child_r) are valid, i.e., their
1158 * interpretation conforms to the current value of flip (even when they
1159 * are interpreted to be NULL).
1160 * If *c is TSO, its state is not any of ThreadRelocated, ThreadComplete,
1161 * or ThreadKilled, which means that its stack is ready to process.
1163 * This code was almost plagiarzied from GC.c! For each pointer,
1164 * retainClosure() is invoked instead of evacuate().
1165 * -------------------------------------------------------------------------- */
1167 retainStack( StgClosure *c, retainer c_child_r,
1168 StgPtr stackStart, StgPtr stackEnd )
1170 stackElement *oldStackBoundary;
1172 StgRetInfoTable *info;
1176 #ifdef DEBUG_RETAINER
1178 if (cStackSize > maxCStackSize) maxCStackSize = cStackSize;
1182 Each invocation of retainStack() creates a new virtual
1183 stack. Since all such stacks share a single common stack, we
1184 record the current currentStackBoundary, which will be restored
1187 oldStackBoundary = currentStackBoundary;
1188 currentStackBoundary = stackTop;
1190 #ifdef DEBUG_RETAINER
1191 // fprintf(stderr, "retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
1194 ASSERT(get_itbl(c)->type != TSO ||
1195 (((StgTSO *)c)->what_next != ThreadRelocated &&
1196 ((StgTSO *)c)->what_next != ThreadComplete &&
1197 ((StgTSO *)c)->what_next != ThreadKilled));
1200 while (p < stackEnd) {
1201 info = get_ret_itbl((StgClosure *)p);
1203 switch(info->i.type) {
1206 retainClosure(((StgUpdateFrame *)p)->updatee, c, c_child_r);
1207 p += sizeofW(StgUpdateFrame);
1214 bitmap = BITMAP_BITS(info->i.layout.bitmap);
1215 size = BITMAP_SIZE(info->i.layout.bitmap);
1217 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1220 retainSRT((StgClosure **)info->srt, info->i.srt_len, c, c_child_r);
1227 retainClosure((StgClosure *)*p, c, c_child_r);
1230 size = BCO_BITMAP_SIZE(bco);
1231 retain_large_bitmap(p, BCO_BITMAP(bco), size, c, c_child_r);
1236 // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
1239 size = info->i.layout.large_bitmap->size;
1241 retain_large_bitmap(p, info->i.layout.large_bitmap,
1242 size, c, c_child_r);
1244 // and don't forget to follow the SRT
1247 // Dynamic bitmap: the mask is stored on the stack
1250 dyn = ((StgRetDyn *)p)->liveness;
1252 // traverse the bitmap first
1253 bitmap = GET_LIVENESS(dyn);
1254 p = (P_)&((StgRetDyn *)p)->payload[0];
1255 size = RET_DYN_SIZE;
1256 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1258 // skip over the non-ptr words
1259 p += GET_NONPTRS(dyn);
1261 // follow the ptr words
1262 for (size = GET_PTRS(dyn); size > 0; size--) {
1263 retainClosure((StgClosure *)*p, c, c_child_r);
1270 StgRetFun *ret_fun = (StgRetFun *)p;
1271 StgFunInfoTable *fun_info;
1273 retainClosure(ret_fun->fun, c, c_child_r);
1274 fun_info = get_fun_itbl(ret_fun->fun);
1276 p = (P_)&ret_fun->payload;
1277 switch (fun_info->fun_type) {
1279 bitmap = BITMAP_BITS(fun_info->bitmap);
1280 size = BITMAP_SIZE(fun_info->bitmap);
1281 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1284 size = ((StgLargeBitmap *)fun_info->bitmap)->size;
1285 retain_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap,
1286 size, c, c_child_r);
1290 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
1291 size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->fun_type]);
1292 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1299 barf("Invalid object found in retainStack(): %d",
1300 (int)(info->i.type));
1304 // restore currentStackBoundary
1305 currentStackBoundary = oldStackBoundary;
1306 #ifdef DEBUG_RETAINER
1307 // fprintf(stderr, "retainStack() finished: currentStackBoundary = 0x%x\n", currentStackBoundary);
1310 #ifdef DEBUG_RETAINER
1315 /* ----------------------------------------------------------------------------
1316 * Call retainClosure for each of the children of a PAP/AP
1317 * ------------------------------------------------------------------------- */
1319 static inline StgPtr
1320 retain_PAP (StgPAP *pap, retainer c_child_r)
1323 StgWord bitmap, size;
1324 StgFunInfoTable *fun_info;
1326 retainClosure(pap->fun, (StgClosure *)pap, c_child_r);
1327 fun_info = get_fun_itbl(pap->fun);
1328 ASSERT(fun_info->i.type != PAP);
1330 p = (StgPtr)pap->payload;
1333 switch (fun_info->fun_type) {
1335 bitmap = BITMAP_BITS(fun_info->bitmap);
1336 p = retain_small_bitmap(p, pap->n_args, bitmap,
1337 (StgClosure *)pap, c_child_r);
1340 retain_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap,
1341 size, (StgClosure *)pap, c_child_r);
1345 retain_large_bitmap((StgPtr)pap->payload, BCO_BITMAP(pap->fun),
1346 size, (StgClosure *)pap, c_child_r);
1350 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
1351 p = retain_small_bitmap(p, pap->n_args, bitmap,
1352 (StgClosure *)pap, c_child_r);
1358 /* -----------------------------------------------------------------------------
1359 * Compute the retainer set of *c0 and all its desecents by traversing.
1360 * *cp0 is the parent of *c0, and *r0 is the most recent retainer of *c0.
1362 * c0 = cp0 = r0 holds only for root objects.
1363 * RSET(cp0) and RSET(r0) are valid, i.e., their
1364 * interpretation conforms to the current value of flip (even when they
1365 * are interpreted to be NULL).
1366 * However, RSET(c0) may be corrupt, i.e., it may not conform to
1367 * the current value of flip. If it does not, during the execution
1368 * of this function, RSET(c0) must be initialized as well as all
1371 * stackTop must be the same at the beginning and the exit of this function.
1372 * *c0 can be TSO (as well as AP_STACK).
1373 * -------------------------------------------------------------------------- */
1375 retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
1377 // c = Current closure
1378 // cp = Current closure's Parent
1379 // r = current closures' most recent Retainer
1380 // c_child_r = current closure's children's most recent retainer
1381 // first_child = first child of c
1382 StgClosure *c, *cp, *first_child;
1383 RetainerSet *s, *retainerSetOfc;
1384 retainer r, c_child_r;
1387 #ifdef DEBUG_RETAINER
1388 // StgPtr oldStackTop;
1391 #ifdef DEBUG_RETAINER
1392 // oldStackTop = stackTop;
1393 // fprintf(stderr, "retainClosure() called: c0 = 0x%x, cp0 = 0x%x, r0 = 0x%x\n", c0, cp0, r0);
1396 // (c, cp, r) = (c0, cp0, r0)
1403 //fprintf(stderr, "loop");
1404 // pop to (c, cp, r);
1408 #ifdef DEBUG_RETAINER
1409 // fprintf(stderr, "retainClosure() ends: oldStackTop = 0x%x, stackTop = 0x%x\n", oldStackTop, stackTop);
1414 //fprintf(stderr, "inner_loop");
1417 // c = current closure under consideration,
1418 // cp = current closure's parent,
1419 // r = current closure's most recent retainer
1421 // Loop invariants (on the meaning of c, cp, r, and their retainer sets):
1422 // RSET(cp) and RSET(r) are valid.
1423 // RSET(c) is valid only if c has been visited before.
1425 // Loop invariants (on the relation between c, cp, and r)
1426 // if cp is not a retainer, r belongs to RSET(cp).
1427 // if cp is a retainer, r == cp.
1429 typeOfc = get_itbl(c)->type;
1431 #ifdef DEBUG_RETAINER
1434 case CONSTR_INTLIKE:
1435 case CONSTR_CHARLIKE:
1436 case CONSTR_NOCAF_STATIC:
1442 if (retainerSetOf(c) == NULL) { // first visit?
1443 costArray[typeOfc] += cost(c);
1444 sumOfNewCost += cost(c);
1453 if (((StgTSO *)c)->what_next == ThreadComplete ||
1454 ((StgTSO *)c)->what_next == ThreadKilled) {
1455 #ifdef DEBUG_RETAINER
1456 fprintf(stderr, "ThreadComplete or ThreadKilled encountered in retainClosure()\n");
1460 if (((StgTSO *)c)->what_next == ThreadRelocated) {
1461 #ifdef DEBUG_RETAINER
1462 fprintf(stderr, "ThreadRelocated encountered in retainClosure()\n");
1464 c = (StgClosure *)((StgTSO *)c)->link;
1470 // We just skip IND_STATIC, so its retainer set is never computed.
1471 c = ((StgIndStatic *)c)->indirectee;
1473 case CONSTR_INTLIKE:
1474 case CONSTR_CHARLIKE:
1475 // static objects with no pointers out, so goto loop.
1476 case CONSTR_NOCAF_STATIC:
1477 // It is not just enough not to compute the retainer set for *c; it is
1478 // mandatory because CONSTR_NOCAF_STATIC are not reachable from
1479 // scavenged_static_objects, the list from which is assumed to traverse
1480 // all static objects after major garbage collections.
1484 if (get_itbl(c)->srt_len == 0) {
1485 // No need to compute the retainer set; no dynamic objects
1486 // are reachable from *c.
1488 // Static objects: if we traverse all the live closures,
1489 // including static closures, during each heap census then
1490 // we will observe that some static closures appear and
1491 // disappear. eg. a closure may contain a pointer to a
1492 // static function 'f' which is not otherwise reachable
1493 // (it doesn't indirectly point to any CAFs, so it doesn't
1494 // appear in any SRTs), so we would find 'f' during
1495 // traversal. However on the next sweep there may be no
1496 // closures pointing to 'f'.
1498 // We must therefore ignore static closures whose SRT is
1499 // empty, because these are exactly the closures that may
1500 // "appear". A closure with a non-empty SRT, and which is
1501 // still required, will always be reachable.
1503 // But what about CONSTR_STATIC? Surely these may be able
1504 // to appear, and they don't have SRTs, so we can't
1505 // check. So for now, we're calling
1506 // resetStaticObjectForRetainerProfiling() from the
1507 // garbage collector to reset the retainer sets in all the
1508 // reachable static objects.
1515 // The above objects are ignored in computing the average number of times
1516 // an object is visited.
1517 timesAnyObjectVisited++;
1519 // If this is the first visit to c, initialize its retainer set.
1520 maybeInitRetainerSet(c);
1521 retainerSetOfc = retainerSetOf(c);
1524 // isRetainer(cp) == rtsTrue => s == NULL
1525 // isRetainer(cp) == rtsFalse => s == cp.retainer
1529 s = retainerSetOf(cp);
1531 // (c, cp, r, s) is available.
1533 // (c, cp, r, s, R_r) is available, so compute the retainer set for *c.
1534 if (retainerSetOfc == NULL) {
1535 // This is the first visit to *c.
1539 associate(c, singleton(r));
1541 // s is actually the retainer set of *c!
1544 // compute c_child_r
1545 c_child_r = isRetainer(c) ? getRetainerFrom(c) : r;
1547 // This is not the first visit to *c.
1548 if (isMember(r, retainerSetOfc))
1549 goto loop; // no need to process child
1552 associate(c, addElement(r, retainerSetOfc));
1554 // s is not NULL and cp is not a retainer. This means that
1555 // each time *cp is visited, so is *c. Thus, if s has
1556 // exactly one more element in its retainer set than c, s
1557 // is also the new retainer set for *c.
1558 if (s->num == retainerSetOfc->num + 1) {
1561 // Otherwise, just add R_r to the current retainer set of *c.
1563 associate(c, addElement(r, retainerSetOfc));
1568 goto loop; // no need to process child
1570 // compute c_child_r
1574 // now, RSET() of all of *c, *cp, and *r is valid.
1575 // (c, c_child_r) are available.
1579 // Special case closures: we process these all in one go rather
1580 // than attempting to save the current position, because doing so
1584 retainStack(c, c_child_r,
1586 ((StgTSO *)c)->stack + ((StgTSO *)c)->stack_size);
1591 retain_PAP((StgPAP *)c, c_child_r);
1595 retainClosure(((StgAP_STACK *)c)->fun, c, c_child_r);
1596 retainStack(c, c_child_r,
1597 (StgPtr)((StgAP_STACK *)c)->payload,
1598 (StgPtr)((StgAP_STACK *)c)->payload +
1599 ((StgAP_STACK *)c)->size);
1603 push(c, c_child_r, &first_child);
1605 // If first_child is null, c has no child.
1606 // If first_child is not null, the top stack element points to the next
1607 // object. push() may or may not push a stackElement on the stack.
1608 if (first_child == NULL)
1611 // (c, cp, r) = (first_child, c, c_child_r)
1618 /* -----------------------------------------------------------------------------
1619 * Compute the retainer set for every object reachable from *tl.
1620 * -------------------------------------------------------------------------- */
1622 retainRoot( StgClosure **tl )
1624 // We no longer assume that only TSOs and WEAKs are roots; any closure can
1627 ASSERT(isEmptyRetainerStack());
1628 currentStackBoundary = stackTop;
1630 if (isRetainer(*tl)) {
1631 retainClosure(*tl, *tl, getRetainerFrom(*tl));
1633 retainClosure(*tl, *tl, CCS_SYSTEM);
1636 // NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl)));
1637 // *tl might be a TSO which is ThreadComplete, in which
1638 // case we ignore it for the purposes of retainer profiling.
1641 /* -----------------------------------------------------------------------------
1642 * Compute the retainer set for each of the objects in the heap.
1643 * -------------------------------------------------------------------------- */
1645 computeRetainerSet( void )
1651 #ifdef DEBUG_RETAINER
1652 RetainerSet tmpRetainerSet;
1655 GetRoots(retainRoot); // for scheduler roots
1657 // This function is called after a major GC, when key, value, and finalizer
1658 // all are guaranteed to be valid, or reachable.
1660 // The following code assumes that WEAK objects are considered to be roots
1661 // for retainer profilng.
1662 for (weak = weak_ptr_list; weak != NULL; weak = weak->link)
1663 // retainRoot((StgClosure *)weak);
1664 retainRoot((StgClosure **)&weak);
1666 // Consider roots from the stable ptr table.
1667 markStablePtrTable(retainRoot);
1669 // The following code resets the rs field of each unvisited mutable
1670 // object (computing sumOfNewCostExtra and updating costArray[] when
1671 // debugging retainer profiler).
1672 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1674 (generations[g].mut_list == END_MUT_LIST &&
1675 generations[g].mut_once_list == END_MUT_LIST));
1678 // I think traversing through mut_list is unnecessary.
1679 // Think about removing this part.
1680 for (ml = generations[g].mut_list; ml != END_MUT_LIST;
1681 ml = ml->mut_link) {
1683 maybeInitRetainerSet((StgClosure *)ml);
1684 rtl = retainerSetOf((StgClosure *)ml);
1686 #ifdef DEBUG_RETAINER
1688 // first visit to *ml
1689 // This is a violation of the interface rule!
1690 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1692 switch (get_itbl((StgClosure *)ml)->type) {
1696 case CONSTR_INTLIKE:
1697 case CONSTR_CHARLIKE:
1698 case CONSTR_NOCAF_STATIC:
1702 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1706 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1707 sumOfNewCostExtra += cost((StgClosure *)ml);
1714 // Traversing through mut_once_list is, in contrast, necessary
1715 // because we can find MUT_VAR objects which have not been
1716 // visited during retainer profiling.
1717 for (ml = generations[g].mut_once_list; ml != END_MUT_LIST;
1718 ml = ml->mut_link) {
1720 maybeInitRetainerSet((StgClosure *)ml);
1721 rtl = retainerSetOf((StgClosure *)ml);
1722 #ifdef DEBUG_RETAINER
1724 // first visit to *ml
1725 // This is a violation of the interface rule!
1726 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1728 switch (get_itbl((StgClosure *)ml)->type) {
1732 case CONSTR_INTLIKE:
1733 case CONSTR_CHARLIKE:
1734 case CONSTR_NOCAF_STATIC:
1738 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1742 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1743 sumOfNewCostExtra += cost((StgClosure *)ml);
1752 /* -----------------------------------------------------------------------------
1753 * Traverse all static objects for which we compute retainer sets,
1754 * and reset their rs fields to NULL, which is accomplished by
1755 * invoking maybeInitRetainerSet(). This function must be called
1756 * before zeroing all objects reachable from scavenged_static_objects
1757 * in the case of major gabage collections. See GarbageCollect() in
1760 * The mut_once_list of the oldest generation must also be traversed?
1761 * Why? Because if the evacuation of an object pointed to by a static
1762 * indirection object fails, it is put back to the mut_once_list of
1763 * the oldest generation.
1764 * However, this is not necessary because any static indirection objects
1765 * are just traversed through to reach dynamic objects. In other words,
1766 * they are not taken into consideration in computing retainer sets.
1767 * -------------------------------------------------------------------------- */
1769 resetStaticObjectForRetainerProfiling( void )
1771 #ifdef DEBUG_RETAINER
1776 #ifdef DEBUG_RETAINER
1779 p = scavenged_static_objects;
1780 while (p != END_OF_STATIC_LIST) {
1781 #ifdef DEBUG_RETAINER
1784 switch (get_itbl(p)->type) {
1786 // Since we do not compute the retainer set of any
1787 // IND_STATIC object, we don't have to reset its retainer
1789 p = IND_STATIC_LINK(p);
1792 maybeInitRetainerSet(p);
1793 p = THUNK_STATIC_LINK(p);
1796 maybeInitRetainerSet(p);
1797 p = FUN_STATIC_LINK(p);
1800 maybeInitRetainerSet(p);
1801 p = STATIC_LINK(get_itbl(p), p);
1804 barf("resetStaticObjectForRetainerProfiling: %p (%s)",
1805 p, get_itbl(p)->type);
1809 #ifdef DEBUG_RETAINER
1810 // fprintf(stderr, "count in scavenged_static_objects = %d\n", count);
1814 /* -----------------------------------------------------------------------------
1815 * Perform retainer profiling.
1816 * N is the oldest generation being profilied, where the generations are
1817 * numbered starting at 0.
1820 * This function should be called only immediately after major garbage
1822 * ------------------------------------------------------------------------- */
1824 retainerProfile(void)
1826 #ifdef DEBUG_RETAINER
1828 nat totalHeapSize; // total raw heap size (computed by linear scanning)
1831 #ifdef DEBUG_RETAINER
1832 fprintf(stderr, " < retainerProfile() invoked : %d>\n", retainerGeneration);
1837 // We haven't flipped the bit yet.
1838 #ifdef DEBUG_RETAINER
1839 fprintf(stderr, "Before traversing:\n");
1840 sumOfCostLinear = 0;
1841 for (i = 0;i < N_CLOSURE_TYPES; i++)
1842 costArrayLinear[i] = 0;
1843 totalHeapSize = checkHeapSanityForRetainerProfiling();
1845 fprintf(stderr, "\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1847 fprintf(stderr, "costArrayLinear[] = ");
1848 for (i = 0;i < N_CLOSURE_TYPES; i++)
1849 fprintf(stderr, "[%u:%u] ", i, costArrayLinear[i]);
1850 fprintf(stderr, "\n");
1853 ASSERT(sumOfCostLinear == totalHeapSize);
1856 #define pcostArrayLinear(index) \
1857 if (costArrayLinear[index] > 0) \
1858 fprintf(stderr, "costArrayLinear[" #index "] = %u\n", costArrayLinear[index])
1859 pcostArrayLinear(THUNK_STATIC);
1860 pcostArrayLinear(FUN_STATIC);
1861 pcostArrayLinear(CONSTR_STATIC);
1862 pcostArrayLinear(CONSTR_NOCAF_STATIC);
1863 pcostArrayLinear(CONSTR_INTLIKE);
1864 pcostArrayLinear(CONSTR_CHARLIKE);
1868 // Now we flips flip.
1871 #ifdef DEBUG_RETAINER
1877 numObjectVisited = 0;
1878 timesAnyObjectVisited = 0;
1880 #ifdef DEBUG_RETAINER
1881 fprintf(stderr, "During traversing:\n");
1883 sumOfNewCostExtra = 0;
1884 for (i = 0;i < N_CLOSURE_TYPES; i++)
1889 We initialize the traverse stack each time the retainer profiling is
1890 performed (because the traverse stack size varies on each retainer profiling
1891 and this operation is not costly anyhow). However, we just refresh the
1894 initializeTraverseStack();
1895 #ifdef DEBUG_RETAINER
1896 initializeAllRetainerSet();
1898 refreshAllRetainerSet();
1900 computeRetainerSet();
1902 #ifdef DEBUG_RETAINER
1903 fprintf(stderr, "After traversing:\n");
1904 sumOfCostLinear = 0;
1905 for (i = 0;i < N_CLOSURE_TYPES; i++)
1906 costArrayLinear[i] = 0;
1907 totalHeapSize = checkHeapSanityForRetainerProfiling();
1909 fprintf(stderr, "\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1910 ASSERT(sumOfCostLinear == totalHeapSize);
1912 // now, compare the two results
1915 costArray[] must be exactly the same as costArrayLinear[].
1917 1) Dead weak pointers, whose type is CONSTR. These objects are not
1918 reachable from any roots.
1920 fprintf(stderr, "Comparison:\n");
1921 fprintf(stderr, "\tcostArrayLinear[] (must be empty) = ");
1922 for (i = 0;i < N_CLOSURE_TYPES; i++)
1923 if (costArray[i] != costArrayLinear[i])
1924 // nothing should be printed except MUT_VAR after major GCs
1925 fprintf(stderr, "[%u:%u] ", i, costArrayLinear[i]);
1926 fprintf(stderr, "\n");
1928 fprintf(stderr, "\tsumOfNewCost = %u\n", sumOfNewCost);
1929 fprintf(stderr, "\tsumOfNewCostExtra = %u\n", sumOfNewCostExtra);
1930 fprintf(stderr, "\tcostArray[] (must be empty) = ");
1931 for (i = 0;i < N_CLOSURE_TYPES; i++)
1932 if (costArray[i] != costArrayLinear[i])
1933 // nothing should be printed except MUT_VAR after major GCs
1934 fprintf(stderr, "[%u:%u] ", i, costArray[i]);
1935 fprintf(stderr, "\n");
1937 // only for major garbage collection
1938 ASSERT(sumOfNewCost + sumOfNewCostExtra == sumOfCostLinear);
1942 closeTraverseStack();
1943 #ifdef DEBUG_RETAINER
1944 closeAllRetainerSet();
1946 // Note that there is no post-processing for the retainer sets.
1948 retainerGeneration++;
1951 retainerGeneration - 1, // retainerGeneration has just been incremented!
1952 #ifdef DEBUG_RETAINER
1953 maxCStackSize, maxStackSize,
1955 (double)timesAnyObjectVisited / numObjectVisited);
1958 /* -----------------------------------------------------------------------------
1960 * -------------------------------------------------------------------------- */
1962 #ifdef DEBUG_RETAINER
1964 #define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
1965 ((HEAP_ALLOCED(r) && Bdescr((P_)r)->free != (void *)-1))) && \
1966 ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa))
1969 sanityCheckHeapClosure( StgClosure *c )
1973 ASSERT(LOOKS_LIKE_GHC_INFO(c->header.info));
1974 ASSERT(!closure_STATIC(c));
1975 ASSERT(LOOKS_LIKE_PTR(c));
1977 if ((((StgWord)RSET(c) & 1) ^ flip) != 0) {
1978 if (get_itbl(c)->type == CONSTR &&
1979 !strcmp(get_itbl(c)->prof.closure_type, "DEAD_WEAK") &&
1980 !strcmp(get_itbl(c)->prof.closure_desc, "DEAD_WEAK")) {
1981 fprintf(stderr, "\tUnvisited dead weak pointer object found: c = %p\n", c);
1982 costArray[get_itbl(c)->type] += cost(c);
1983 sumOfNewCost += cost(c);
1986 "Unvisited object: flip = %d, c = %p(%d, %s, %s), rs = %p\n",
1987 flip, c, get_itbl(c)->type,
1988 get_itbl(c)->prof.closure_type, get_itbl(c)->prof.closure_desc,
1991 // fprintf(stderr, "sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c));
1995 switch (info->type) {
1997 return tso_sizeW((StgTSO *)c);
2005 return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE);
2008 return sizeofW(StgMVar);
2011 case MUT_ARR_PTRS_FROZEN:
2012 return mut_arr_ptrs_sizeW((StgMutArrPtrs *)c);
2016 return pap_sizeW((StgPAP *)c);
2019 return ap_stack_sizeW((StgAP_STACK *)c);
2022 return arr_words_sizeW((StgArrWords *)c);
2042 case SE_CAF_BLACKHOLE:
2046 case IND_OLDGEN_PERM:
2050 return sizeW_fromITBL(info);
2052 case THUNK_SELECTOR:
2053 return sizeofW(StgHeader) + MIN_UPD_SIZE;
2062 case CONSTR_INTLIKE:
2063 case CONSTR_CHARLIKE:
2064 case CONSTR_NOCAF_STATIC:
2081 case INVALID_OBJECT:
2083 barf("Invalid object in sanityCheckHeapClosure(): %d",
2090 heapCheck( bdescr *bd )
2093 static nat costSum, size;
2096 while (bd != NULL) {
2098 while (p < bd->free) {
2099 size = sanityCheckHeapClosure((StgClosure *)p);
2100 sumOfCostLinear += size;
2101 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2103 // no need for slop check; I think slops are not used currently.
2105 ASSERT(p == bd->free);
2106 costSum += bd->free - bd->start;
2114 smallObjectPoolCheck(void)
2118 static nat costSum, size;
2120 bd = small_alloc_list;
2128 while (p < alloc_Hp) {
2129 size = sanityCheckHeapClosure((StgClosure *)p);
2130 sumOfCostLinear += size;
2131 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2134 ASSERT(p == alloc_Hp);
2135 costSum += alloc_Hp - bd->start;
2138 while (bd != NULL) {
2140 while (p < bd->free) {
2141 size = sanityCheckHeapClosure((StgClosure *)p);
2142 sumOfCostLinear += size;
2143 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2146 ASSERT(p == bd->free);
2147 costSum += bd->free - bd->start;
2155 chainCheck(bdescr *bd)
2160 while (bd != NULL) {
2161 // bd->free - bd->start is not an accurate measurement of the
2162 // object size. Actually it is always zero, so we compute its
2164 size = sanityCheckHeapClosure((StgClosure *)bd->start);
2165 sumOfCostLinear += size;
2166 costArrayLinear[get_itbl((StgClosure *)bd->start)->type] += size;
2175 checkHeapSanityForRetainerProfiling( void )
2180 fprintf(stderr, "START: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2181 if (RtsFlags.GcFlags.generations == 1) {
2182 costSum += heapCheck(g0s0->to_blocks);
2183 fprintf(stderr, "heapCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2184 costSum += chainCheck(g0s0->large_objects);
2185 fprintf(stderr, "chainCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2187 for (g = 0; g < RtsFlags.GcFlags.generations; g++)
2188 for (s = 0; s < generations[g].n_steps; s++) {
2190 After all live objects have been scavenged, the garbage
2191 collector may create some objects in
2192 scheduleFinalizers(). These objects are created throught
2193 allocate(), so the small object pool or the large object
2194 pool of the g0s0 may not be empty.
2196 if (g == 0 && s == 0) {
2197 costSum += smallObjectPoolCheck();
2198 fprintf(stderr, "smallObjectPoolCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2199 costSum += chainCheck(generations[g].steps[s].large_objects);
2200 fprintf(stderr, "chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2202 costSum += heapCheck(generations[g].steps[s].blocks);
2203 fprintf(stderr, "heapCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2204 costSum += chainCheck(generations[g].steps[s].large_objects);
2205 fprintf(stderr, "chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2214 findPointer(StgPtr p)
2220 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2221 for (s = 0; s < generations[g].n_steps; s++) {
2222 // if (g == 0 && s == 0) continue;
2223 bd = generations[g].steps[s].blocks;
2224 for (; bd; bd = bd->link) {
2225 for (q = bd->start; q < bd->free; q++) {
2226 if (*q == (StgWord)p) {
2228 while (!LOOKS_LIKE_GHC_INFO(*r)) r--;
2229 fprintf(stderr, "Found in gen[%d], step[%d]: q = %p, r = %p\n", g, s, q, r);
2234 bd = generations[g].steps[s].large_objects;
2235 for (; bd; bd = bd->link) {
2236 e = bd->start + cost((StgClosure *)bd->start);
2237 for (q = bd->start; q < e; q++) {
2238 if (*q == (StgWord)p) {
2240 while (*r == 0 || !LOOKS_LIKE_GHC_INFO(*r)) r--;
2241 fprintf(stderr, "Found in gen[%d], large_objects: %p\n", g, r);
2251 belongToHeap(StgPtr p)
2256 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2257 for (s = 0; s < generations[g].n_steps; s++) {
2258 // if (g == 0 && s == 0) continue;
2259 bd = generations[g].steps[s].blocks;
2260 for (; bd; bd = bd->link) {
2261 if (bd->start <= p && p < bd->free) {
2262 fprintf(stderr, "Belongs to gen[%d], step[%d]", g, s);
2266 bd = generations[g].steps[s].large_objects;
2267 for (; bd; bd = bd->link) {
2268 if (bd->start <= p && p < bd->start + getHeapClosureSize((StgClosure *)bd->start)) {
2269 fprintf(stderr, "Found in gen[%d], large_objects: %p\n", g, bd->start);
2276 #endif // DEBUG_RETAINER
2278 #endif /* PROFILING */