1 /* -----------------------------------------------------------------------------
2 * $Id: RetainerProfile.c,v 1.8 2003/03/21 16:18:37 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 static 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 size of stack
262 * -------------------------------------------------------------------------- */
264 retainerStackBlocks()
269 for (bd = firstStack; bd != NULL; bd = bd->link)
275 /* -----------------------------------------------------------------------------
276 * Returns rtsTrue if stackTop is at the stack boundary of the current stack,
277 * i.e., if the current stack chunk is empty.
278 * -------------------------------------------------------------------------- */
279 static inline rtsBool
282 return stackTop == currentStackBoundary;
285 /* -----------------------------------------------------------------------------
286 * Initializes *info from ptrs and payload.
288 * payload[] begins with ptrs pointers followed by non-pointers.
289 * -------------------------------------------------------------------------- */
291 init_ptrs( stackPos *info, nat ptrs, StgPtr payload )
293 info->type = posTypePtrs;
294 info->next.ptrs.pos = 0;
295 info->next.ptrs.ptrs = ptrs;
296 info->next.ptrs.payload = payload;
299 /* -----------------------------------------------------------------------------
300 * Find the next object from *info.
301 * -------------------------------------------------------------------------- */
302 static inline StgClosure *
303 find_ptrs( stackPos *info )
305 if (info->next.ptrs.pos < info->next.ptrs.ptrs) {
306 return (StgClosure *)info->next.ptrs.payload[info->next.ptrs.pos++];
312 /* -----------------------------------------------------------------------------
313 * Initializes *info from SRT information stored in *infoTable.
314 * -------------------------------------------------------------------------- */
316 init_srt_fun( stackPos *info, StgFunInfoTable *infoTable )
318 info->type = posTypeSRT;
319 info->next.srt.srt = (StgClosure **)(infoTable->srt);
320 info->next.srt.srt_end = info->next.srt.srt + infoTable->i.srt_len;
324 init_srt_thunk( stackPos *info, StgThunkInfoTable *infoTable )
326 info->type = posTypeSRT;
327 info->next.srt.srt = (StgClosure **)(infoTable->srt);
328 info->next.srt.srt_end = info->next.srt.srt + infoTable->i.srt_len;
331 /* -----------------------------------------------------------------------------
332 * Find the next object from *info.
333 * -------------------------------------------------------------------------- */
334 static inline StgClosure *
335 find_srt( stackPos *info )
339 if (info->next.srt.srt < info->next.srt.srt_end) {
340 // See scavenge_srt() in GC.c for details.
341 #ifdef ENABLE_WIN32_DLL_SUPPORT
342 if ((unsigned long)(*(info->next.srt.srt)) & 0x1)
343 c = (* (StgClosure **)((unsigned long)*(info->next.srt.srt)) & ~0x1);
345 c = *(info->next.srt.srt);
347 c = *(info->next.srt.srt);
349 info->next.srt.srt++;
356 /* -----------------------------------------------------------------------------
357 * push() pushes a stackElement representing the next child of *c
358 * onto the traverse stack. If *c has no child, *first_child is set
359 * to NULL and nothing is pushed onto the stack. If *c has only one
360 * child, *c_chlid is set to that child and nothing is pushed onto
361 * the stack. If *c has more than two children, *first_child is set
362 * to the first child and a stackElement representing the second
363 * child is pushed onto the stack.
366 * *c_child_r is the most recent retainer of *c's children.
367 * *c is not any of TSO, AP, PAP, AP_STACK, which means that
368 * there cannot be any stack objects.
369 * Note: SRTs are considered to be children as well.
370 * -------------------------------------------------------------------------- */
372 push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
375 bdescr *nbd; // Next Block Descriptor
377 #ifdef DEBUG_RETAINER
378 // fprintf(stderr, "push(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
381 ASSERT(get_itbl(c)->type != TSO);
382 ASSERT(get_itbl(c)->type != AP_STACK);
389 se.c_child_r = c_child_r;
392 switch (get_itbl(c)->type) {
399 case SE_CAF_BLACKHOLE:
404 // one child (fixed), no SRT
407 *first_child = ((StgMutVar *)c)->var;
410 // blocking_queue must be TSO and the head of a linked list of TSOs.
411 // Shoule it be a child? Seems to be yes.
412 *first_child = (StgClosure *)((StgBlockingQueue *)c)->blocking_queue;
415 *first_child = ((StgSelector *)c)->selectee;
418 case IND_OLDGEN_PERM:
420 *first_child = ((StgIndOldGen *)c)->indirectee;
424 *first_child = c->payload[0];
427 // For CONSTR_2_0 and MVAR, we use se.info.step to record the position
428 // of the next child. We do not write a separate initialization code.
429 // Also we do not have to initialize info.type;
431 // two children (fixed), no SRT
432 // need to push a stackElement, but nothing to store in se.info
434 *first_child = c->payload[0]; // return the first pointer
435 // se.info.type = posTypeStep;
436 // se.info.next.step = 2; // 2 = second
439 // three children (fixed), no SRT
440 // need to push a stackElement
442 // head must be TSO and the head of a linked list of TSOs.
443 // Shoule it be a child? Seems to be yes.
444 *first_child = (StgClosure *)((StgMVar *)c)->head;
445 // se.info.type = posTypeStep;
446 se.info.next.step = 2; // 2 = second
449 // three children (fixed), no SRT
451 *first_child = ((StgWeak *)c)->key;
452 // se.info.type = posTypeStep;
453 se.info.next.step = 2;
456 // layout.payload.ptrs, no SRT
462 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
464 *first_child = find_ptrs(&se.info);
465 if (*first_child == NULL)
469 // StgMutArrPtr.ptrs, no SRT
471 case MUT_ARR_PTRS_FROZEN:
472 init_ptrs(&se.info, ((StgMutArrPtrs *)c)->ptrs,
473 (StgPtr)(((StgMutArrPtrs *)c)->payload));
474 *first_child = find_ptrs(&se.info);
475 if (*first_child == NULL)
479 // layout.payload.ptrs, SRT
480 case FUN: // *c is a heap object.
482 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
483 *first_child = find_ptrs(&se.info);
484 if (*first_child == NULL)
485 // no child from ptrs, so check SRT
491 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
492 *first_child = find_ptrs(&se.info);
493 if (*first_child == NULL)
494 // no child from ptrs, so check SRT
498 // 1 fixed child, SRT
501 *first_child = c->payload[0];
502 ASSERT(*first_child != NULL);
503 init_srt_fun(&se.info, get_fun_itbl(c));
508 *first_child = c->payload[0];
509 ASSERT(*first_child != NULL);
510 init_srt_thunk(&se.info, get_thunk_itbl(c));
513 case FUN_STATIC: // *c is a heap object.
514 ASSERT(get_itbl(c)->srt_len != 0);
518 init_srt_fun(&se.info, get_fun_itbl(c));
519 *first_child = find_srt(&se.info);
520 if (*first_child == NULL)
526 ASSERT(get_itbl(c)->srt_len != 0);
530 init_srt_thunk(&se.info, get_thunk_itbl(c));
531 *first_child = find_srt(&se.info);
532 if (*first_child == NULL)
543 case CONSTR_CHARLIKE:
544 case CONSTR_NOCAF_STATIC:
565 barf("Invalid object *c in push()");
569 if (stackTop - 1 < stackBottom) {
570 #ifdef DEBUG_RETAINER
571 // fprintf(stderr, "push() to the next stack.\n");
573 // currentStack->free is updated when the active stack is switched
574 // to the next stack.
575 currentStack->free = (StgPtr)stackTop;
577 if (currentStack->link == NULL) {
578 nbd = allocGroup(BLOCKS_IN_STACK);
580 nbd->u.back = currentStack;
581 currentStack->link = nbd;
583 nbd = currentStack->link;
588 // adjust stackTop (acutal push)
590 // If the size of stackElement was huge, we would better replace the
591 // following statement by either a memcpy() call or a switch statement
592 // on the type of the element. Currently, the size of stackElement is
593 // small enough (5 words) that this direct assignment seems to be enough.
596 #ifdef DEBUG_RETAINER
598 if (stackSize > maxStackSize) maxStackSize = stackSize;
599 // ASSERT(stackSize >= 0);
600 // fprintf(stderr, "stackSize = %d\n", stackSize);
604 /* -----------------------------------------------------------------------------
605 * popOff() and popOffReal(): Pop a stackElement off the traverse stack.
607 * stackTop cannot be equal to stackLimit unless the whole stack is
608 * empty, in which case popOff() is not allowed.
610 * You can think of popOffReal() as a part of popOff() which is
611 * executed at the end of popOff() in necessary. Since popOff() is
612 * likely to be executed quite often while popOffReal() is not, we
613 * separate popOffReal() from popOff(), which is declared as an
614 * inline function (for the sake of execution speed). popOffReal()
615 * is called only within popOff() and nowhere else.
616 * -------------------------------------------------------------------------- */
620 bdescr *pbd; // Previous Block Descriptor
622 #ifdef DEBUG_RETAINER
623 // fprintf(stderr, "pop() to the previous stack.\n");
626 ASSERT(stackTop + 1 == stackLimit);
627 ASSERT(stackBottom == (stackElement *)currentStack->start);
629 if (firstStack == currentStack) {
630 // The stack is completely empty.
632 ASSERT(stackTop == stackLimit);
633 #ifdef DEBUG_RETAINER
635 if (stackSize > maxStackSize) maxStackSize = stackSize;
637 ASSERT(stackSize >= 0);
638 fprintf(stderr, "stackSize = %d\n", stackSize);
644 // currentStack->free is updated when the active stack is switched back
645 // to the previous stack.
646 currentStack->free = (StgPtr)stackLimit;
648 // find the previous block descriptor
649 pbd = currentStack->u.back;
652 returnToOldStack(pbd);
654 #ifdef DEBUG_RETAINER
656 if (stackSize > maxStackSize) maxStackSize = stackSize;
658 ASSERT(stackSize >= 0);
659 fprintf(stderr, "stackSize = %d\n", stackSize);
666 #ifdef DEBUG_RETAINER
667 // fprintf(stderr, "\tpopOff(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
670 ASSERT(stackTop != stackLimit);
671 ASSERT(!isEmptyRetainerStack());
673 // <= (instead of <) is wrong!
674 if (stackTop + 1 < stackLimit) {
676 #ifdef DEBUG_RETAINER
678 if (stackSize > maxStackSize) maxStackSize = stackSize;
680 ASSERT(stackSize >= 0);
681 fprintf(stderr, "stackSize = %d\n", stackSize);
690 /* -----------------------------------------------------------------------------
691 * Finds the next object to be considered for retainer profiling and store
693 * Test if the topmost stack element indicates that more objects are left,
694 * and if so, retrieve the first object and store its pointer to *c. Also,
695 * set *cp and *r appropriately, both of which are stored in the stack element.
696 * The topmost stack element then is overwritten so as for it to now denote
698 * If the topmost stack element indicates no more objects are left, pop
699 * off the stack element until either an object can be retrieved or
700 * the current stack chunk becomes empty, indicated by rtsTrue returned by
701 * isOnBoundary(), in which case *c is set to NULL.
703 * It is okay to call this function even when the current stack chunk
705 * -------------------------------------------------------------------------- */
707 pop( StgClosure **c, StgClosure **cp, retainer *r )
711 #ifdef DEBUG_RETAINER
712 // fprintf(stderr, "pop(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
716 if (isOnBoundary()) { // if the current stack chunk is depleted
723 switch (get_itbl(se->c)->type) {
724 // two children (fixed), no SRT
725 // nothing in se.info
727 *c = se->c->payload[1];
733 // three children (fixed), no SRT
734 // need to push a stackElement
736 if (se->info.next.step == 2) {
737 *c = (StgClosure *)((StgMVar *)se->c)->tail;
738 se->info.next.step++; // move to the next step
741 *c = ((StgMVar *)se->c)->value;
748 // three children (fixed), no SRT
750 if (se->info.next.step == 2) {
751 *c = ((StgWeak *)se->c)->value;
752 se->info.next.step++;
755 *c = ((StgWeak *)se->c)->finalizer;
767 // StgMutArrPtr.ptrs, no SRT
769 case MUT_ARR_PTRS_FROZEN:
770 *c = find_ptrs(&se->info);
779 // layout.payload.ptrs, SRT
780 case FUN: // always a heap object
782 if (se->info.type == posTypePtrs) {
783 *c = find_ptrs(&se->info);
789 init_srt_fun(&se->info, get_fun_itbl(se->c));
795 if (se->info.type == posTypePtrs) {
796 *c = find_ptrs(&se->info);
802 init_srt_thunk(&se->info, get_thunk_itbl(se->c));
818 *c = find_srt(&se->info);
827 // no child (fixed), no SRT
833 case SE_CAF_BLACKHOLE:
835 // one child (fixed), no SRT
841 case IND_OLDGEN_PERM:
851 case CONSTR_CHARLIKE:
852 case CONSTR_NOCAF_STATIC:
873 barf("Invalid object *c in pop()");
879 /* -----------------------------------------------------------------------------
880 * RETAINER PROFILING ENGINE
881 * -------------------------------------------------------------------------- */
884 initRetainerProfiling( void )
886 initializeAllRetainerSet();
887 retainerGeneration = 0;
890 /* -----------------------------------------------------------------------------
891 * This function must be called before f-closing prof_file.
892 * -------------------------------------------------------------------------- */
894 endRetainerProfiling( void )
896 #ifdef SECOND_APPROACH
897 outputAllRetainerSet(prof_file);
901 /* -----------------------------------------------------------------------------
902 * Returns the actual pointer to the retainer set of the closure *c.
903 * It may adjust RSET(c) subject to flip.
905 * RSET(c) is initialized to NULL if its current value does not
908 * Even though this function has side effects, they CAN be ignored because
909 * subsequent calls to retainerSetOf() always result in the same return value
910 * and retainerSetOf() is the only way to retrieve retainerSet of a given
912 * We have to perform an XOR (^) operation each time a closure is examined.
913 * The reason is that we do not know when a closure is visited last.
914 * -------------------------------------------------------------------------- */
916 maybeInitRetainerSet( StgClosure *c )
918 if (!isRetainerSetFieldValid(c)) {
919 setRetainerSetToNull(c);
923 /* -----------------------------------------------------------------------------
924 * Returns rtsTrue if *c is a retainer.
925 * -------------------------------------------------------------------------- */
926 static inline rtsBool
927 isRetainer( StgClosure *c )
929 switch (get_itbl(c)->type) {
933 // TSOs MUST be retainers: they constitute the set of roots.
941 case MUT_ARR_PTRS_FROZEN:
943 // thunks are retainers.
954 // Static thunks, or CAFS, are obviously retainers.
957 // WEAK objects are roots; there is separate code in which traversing
958 // begins from WEAK objects.
980 // partial applications
986 case SE_CAF_BLACKHOLE:
990 case IND_OLDGEN_PERM:
1005 // IND_STATIC cannot be *c, *cp, *r in the retainer profiling loop.
1007 // CONSTR_INTLIKE, CONSTR_CHARLIKE, and CONSTR_NOCAF_STATIC
1008 // cannot be *c, *cp, *r in the retainer profiling loop.
1009 case CONSTR_INTLIKE:
1010 case CONSTR_CHARLIKE:
1011 case CONSTR_NOCAF_STATIC:
1012 // Stack objects are invalid because they are never treated as
1013 // legal objects during retainer profiling.
1031 case INVALID_OBJECT:
1033 barf("Invalid object in isRetainer(): %d", get_itbl(c)->type);
1038 /* -----------------------------------------------------------------------------
1039 * Returns the retainer function value for the closure *c, i.e., R(*c).
1040 * This function does NOT return the retainer(s) of *c.
1042 * *c must be a retainer.
1044 * Depending on the definition of this function, the maintenance of retainer
1045 * sets can be made easier. If most retainer sets are likely to be created
1046 * again across garbage collections, refreshAllRetainerSet() in
1047 * RetainerSet.c can simply do nothing.
1048 * If this is not the case, we can free all the retainer sets and
1049 * re-initialize the hash table.
1050 * See refreshAllRetainerSet() in RetainerSet.c.
1051 * -------------------------------------------------------------------------- */
1052 static inline retainer
1053 getRetainerFrom( StgClosure *c )
1055 ASSERT(isRetainer(c));
1057 #if defined(RETAINER_SCHEME_INFO)
1058 // Retainer scheme 1: retainer = info table
1060 #elif defined(RETAINER_SCHEME_CCS)
1061 // Retainer scheme 2: retainer = cost centre stack
1062 return c->header.prof.ccs;
1063 #elif defined(RETAINER_SCHEME_CC)
1064 // Retainer scheme 3: retainer = cost centre
1065 return c->header.prof.ccs->cc;
1069 /* -----------------------------------------------------------------------------
1070 * Associates the retainer set *s with the closure *c, that is, *s becomes
1071 * the retainer set of *c.
1075 * -------------------------------------------------------------------------- */
1077 associate( StgClosure *c, RetainerSet *s )
1079 // StgWord has the same size as pointers, so the following type
1081 RSET(c) = (RetainerSet *)((StgWord)s | flip);
1084 /* -----------------------------------------------------------------------------
1085 * Call retainClosure for each of the closures in an SRT.
1086 * ------------------------------------------------------------------------- */
1089 retainSRT (StgClosure **srt, nat srt_len, StgClosure *c, retainer c_child_r)
1091 StgClosure **srt_end;
1093 srt_end = srt + srt_len;
1095 for (; srt < srt_end; srt++) {
1096 /* Special-case to handle references to closures hiding out in DLLs, since
1097 double indirections required to get at those. The code generator knows
1098 which is which when generating the SRT, so it stores the (indirect)
1099 reference to the DLL closure in the table by first adding one to it.
1100 We check for this here, and undo the addition before evacuating it.
1102 If the SRT entry hasn't got bit 0 set, the SRT entry points to a
1103 closure that's fixed at link-time, and no extra magic is required.
1105 #ifdef ENABLE_WIN32_DLL_SUPPORT
1106 if ( (unsigned long)(*srt) & 0x1 ) {
1107 retainClosure(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)),
1110 retainClosure(*srt,c,c_child_r);
1113 retainClosure(*srt,c,c_child_r);
1118 /* -----------------------------------------------------------------------------
1119 Call retainClosure for each of the closures covered by a large bitmap.
1120 -------------------------------------------------------------------------- */
1123 retain_large_bitmap (StgPtr p, StgLargeBitmap *large_bitmap, nat size,
1124 StgClosure *c, retainer c_child_r)
1130 bitmap = large_bitmap->bitmap[b];
1131 for (i = 0; i < size; ) {
1132 if ((bitmap & 1) == 0) {
1133 retainClosure((StgClosure *)*p, c, c_child_r);
1137 if (i % BITS_IN(W_) == 0) {
1139 bitmap = large_bitmap->bitmap[b];
1141 bitmap = bitmap >> 1;
1146 static inline StgPtr
1147 retain_small_bitmap (StgPtr p, nat size, StgWord bitmap,
1148 StgClosure *c, retainer c_child_r)
1151 if ((bitmap & 1) == 0) {
1152 retainClosure((StgClosure *)*p, c, c_child_r);
1155 bitmap = bitmap >> 1;
1161 /* -----------------------------------------------------------------------------
1162 * Process all the objects in the stack chunk from stackStart to stackEnd
1163 * with *c and *c_child_r being their parent and their most recent retainer,
1164 * respectively. Treat stackOptionalFun as another child of *c if it is
1167 * *c is one of the following: TSO, AP_STACK.
1168 * If *c is TSO, c == c_child_r.
1169 * stackStart < stackEnd.
1170 * RSET(c) and RSET(c_child_r) are valid, i.e., their
1171 * interpretation conforms to the current value of flip (even when they
1172 * are interpreted to be NULL).
1173 * If *c is TSO, its state is not any of ThreadRelocated, ThreadComplete,
1174 * or ThreadKilled, which means that its stack is ready to process.
1176 * This code was almost plagiarzied from GC.c! For each pointer,
1177 * retainClosure() is invoked instead of evacuate().
1178 * -------------------------------------------------------------------------- */
1180 retainStack( StgClosure *c, retainer c_child_r,
1181 StgPtr stackStart, StgPtr stackEnd )
1183 stackElement *oldStackBoundary;
1185 StgRetInfoTable *info;
1189 #ifdef DEBUG_RETAINER
1191 if (cStackSize > maxCStackSize) maxCStackSize = cStackSize;
1195 Each invocation of retainStack() creates a new virtual
1196 stack. Since all such stacks share a single common stack, we
1197 record the current currentStackBoundary, which will be restored
1200 oldStackBoundary = currentStackBoundary;
1201 currentStackBoundary = stackTop;
1203 #ifdef DEBUG_RETAINER
1204 // fprintf(stderr, "retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
1207 ASSERT(get_itbl(c)->type != TSO ||
1208 (((StgTSO *)c)->what_next != ThreadRelocated &&
1209 ((StgTSO *)c)->what_next != ThreadComplete &&
1210 ((StgTSO *)c)->what_next != ThreadKilled));
1213 while (p < stackEnd) {
1214 info = get_ret_itbl((StgClosure *)p);
1216 switch(info->i.type) {
1219 retainClosure(((StgUpdateFrame *)p)->updatee, c, c_child_r);
1220 p += sizeofW(StgUpdateFrame);
1227 bitmap = BITMAP_BITS(info->i.layout.bitmap);
1228 size = BITMAP_SIZE(info->i.layout.bitmap);
1230 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1233 retainSRT((StgClosure **)info->srt, info->i.srt_len, c, c_child_r);
1240 retainClosure((StgClosure *)*p, c, c_child_r);
1243 size = BCO_BITMAP_SIZE(bco);
1244 retain_large_bitmap(p, BCO_BITMAP(bco), size, c, c_child_r);
1249 // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
1252 size = info->i.layout.large_bitmap->size;
1254 retain_large_bitmap(p, info->i.layout.large_bitmap,
1255 size, c, c_child_r);
1257 // and don't forget to follow the SRT
1260 // Dynamic bitmap: the mask is stored on the stack
1263 dyn = ((StgRetDyn *)p)->liveness;
1265 // traverse the bitmap first
1266 bitmap = GET_LIVENESS(dyn);
1267 p = (P_)&((StgRetDyn *)p)->payload[0];
1268 size = RET_DYN_SIZE;
1269 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1271 // skip over the non-ptr words
1272 p += GET_NONPTRS(dyn);
1274 // follow the ptr words
1275 for (size = GET_PTRS(dyn); size > 0; size--) {
1276 retainClosure((StgClosure *)*p, c, c_child_r);
1283 StgRetFun *ret_fun = (StgRetFun *)p;
1284 StgFunInfoTable *fun_info;
1286 retainClosure(ret_fun->fun, c, c_child_r);
1287 fun_info = get_fun_itbl(ret_fun->fun);
1289 p = (P_)&ret_fun->payload;
1290 switch (fun_info->fun_type) {
1292 bitmap = BITMAP_BITS(fun_info->bitmap);
1293 size = BITMAP_SIZE(fun_info->bitmap);
1294 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1297 size = ((StgLargeBitmap *)fun_info->bitmap)->size;
1298 retain_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap,
1299 size, c, c_child_r);
1303 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
1304 size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->fun_type]);
1305 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1312 barf("Invalid object found in retainStack(): %d",
1313 (int)(info->i.type));
1317 // restore currentStackBoundary
1318 currentStackBoundary = oldStackBoundary;
1319 #ifdef DEBUG_RETAINER
1320 // fprintf(stderr, "retainStack() finished: currentStackBoundary = 0x%x\n", currentStackBoundary);
1323 #ifdef DEBUG_RETAINER
1328 /* ----------------------------------------------------------------------------
1329 * Call retainClosure for each of the children of a PAP/AP
1330 * ------------------------------------------------------------------------- */
1332 static inline StgPtr
1333 retain_PAP (StgPAP *pap, retainer c_child_r)
1336 StgWord bitmap, size;
1337 StgFunInfoTable *fun_info;
1339 retainClosure(pap->fun, (StgClosure *)pap, c_child_r);
1340 fun_info = get_fun_itbl(pap->fun);
1341 ASSERT(fun_info->i.type != PAP);
1343 p = (StgPtr)pap->payload;
1346 switch (fun_info->fun_type) {
1348 bitmap = BITMAP_BITS(fun_info->bitmap);
1349 p = retain_small_bitmap(p, pap->n_args, bitmap,
1350 (StgClosure *)pap, c_child_r);
1353 retain_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap,
1354 size, (StgClosure *)pap, c_child_r);
1358 retain_large_bitmap((StgPtr)pap->payload, BCO_BITMAP(pap->fun),
1359 size, (StgClosure *)pap, c_child_r);
1363 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
1364 p = retain_small_bitmap(p, pap->n_args, bitmap,
1365 (StgClosure *)pap, c_child_r);
1371 /* -----------------------------------------------------------------------------
1372 * Compute the retainer set of *c0 and all its desecents by traversing.
1373 * *cp0 is the parent of *c0, and *r0 is the most recent retainer of *c0.
1375 * c0 = cp0 = r0 holds only for root objects.
1376 * RSET(cp0) and RSET(r0) are valid, i.e., their
1377 * interpretation conforms to the current value of flip (even when they
1378 * are interpreted to be NULL).
1379 * However, RSET(c0) may be corrupt, i.e., it may not conform to
1380 * the current value of flip. If it does not, during the execution
1381 * of this function, RSET(c0) must be initialized as well as all
1384 * stackTop must be the same at the beginning and the exit of this function.
1385 * *c0 can be TSO (as well as AP_STACK).
1386 * -------------------------------------------------------------------------- */
1388 retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
1390 // c = Current closure
1391 // cp = Current closure's Parent
1392 // r = current closures' most recent Retainer
1393 // c_child_r = current closure's children's most recent retainer
1394 // first_child = first child of c
1395 StgClosure *c, *cp, *first_child;
1396 RetainerSet *s, *retainerSetOfc;
1397 retainer r, c_child_r;
1400 #ifdef DEBUG_RETAINER
1401 // StgPtr oldStackTop;
1404 #ifdef DEBUG_RETAINER
1405 // oldStackTop = stackTop;
1406 // fprintf(stderr, "retainClosure() called: c0 = 0x%x, cp0 = 0x%x, r0 = 0x%x\n", c0, cp0, r0);
1409 // (c, cp, r) = (c0, cp0, r0)
1416 //fprintf(stderr, "loop");
1417 // pop to (c, cp, r);
1421 #ifdef DEBUG_RETAINER
1422 // fprintf(stderr, "retainClosure() ends: oldStackTop = 0x%x, stackTop = 0x%x\n", oldStackTop, stackTop);
1427 //fprintf(stderr, "inner_loop");
1430 // c = current closure under consideration,
1431 // cp = current closure's parent,
1432 // r = current closure's most recent retainer
1434 // Loop invariants (on the meaning of c, cp, r, and their retainer sets):
1435 // RSET(cp) and RSET(r) are valid.
1436 // RSET(c) is valid only if c has been visited before.
1438 // Loop invariants (on the relation between c, cp, and r)
1439 // if cp is not a retainer, r belongs to RSET(cp).
1440 // if cp is a retainer, r == cp.
1442 typeOfc = get_itbl(c)->type;
1444 #ifdef DEBUG_RETAINER
1447 case CONSTR_INTLIKE:
1448 case CONSTR_CHARLIKE:
1449 case CONSTR_NOCAF_STATIC:
1455 if (retainerSetOf(c) == NULL) { // first visit?
1456 costArray[typeOfc] += cost(c);
1457 sumOfNewCost += cost(c);
1466 if (((StgTSO *)c)->what_next == ThreadComplete ||
1467 ((StgTSO *)c)->what_next == ThreadKilled) {
1468 #ifdef DEBUG_RETAINER
1469 fprintf(stderr, "ThreadComplete or ThreadKilled encountered in retainClosure()\n");
1473 if (((StgTSO *)c)->what_next == ThreadRelocated) {
1474 #ifdef DEBUG_RETAINER
1475 fprintf(stderr, "ThreadRelocated encountered in retainClosure()\n");
1477 c = (StgClosure *)((StgTSO *)c)->link;
1483 // We just skip IND_STATIC, so its retainer set is never computed.
1484 c = ((StgIndStatic *)c)->indirectee;
1486 case CONSTR_INTLIKE:
1487 case CONSTR_CHARLIKE:
1488 // static objects with no pointers out, so goto loop.
1489 case CONSTR_NOCAF_STATIC:
1490 // It is not just enough not to compute the retainer set for *c; it is
1491 // mandatory because CONSTR_NOCAF_STATIC are not reachable from
1492 // scavenged_static_objects, the list from which is assumed to traverse
1493 // all static objects after major garbage collections.
1497 if (get_itbl(c)->srt_len == 0) {
1498 // No need to compute the retainer set; no dynamic objects
1499 // are reachable from *c.
1501 // Static objects: if we traverse all the live closures,
1502 // including static closures, during each heap census then
1503 // we will observe that some static closures appear and
1504 // disappear. eg. a closure may contain a pointer to a
1505 // static function 'f' which is not otherwise reachable
1506 // (it doesn't indirectly point to any CAFs, so it doesn't
1507 // appear in any SRTs), so we would find 'f' during
1508 // traversal. However on the next sweep there may be no
1509 // closures pointing to 'f'.
1511 // We must therefore ignore static closures whose SRT is
1512 // empty, because these are exactly the closures that may
1513 // "appear". A closure with a non-empty SRT, and which is
1514 // still required, will always be reachable.
1516 // But what about CONSTR_STATIC? Surely these may be able
1517 // to appear, and they don't have SRTs, so we can't
1518 // check. So for now, we're calling
1519 // resetStaticObjectForRetainerProfiling() from the
1520 // garbage collector to reset the retainer sets in all the
1521 // reachable static objects.
1528 // The above objects are ignored in computing the average number of times
1529 // an object is visited.
1530 timesAnyObjectVisited++;
1532 // If this is the first visit to c, initialize its retainer set.
1533 maybeInitRetainerSet(c);
1534 retainerSetOfc = retainerSetOf(c);
1537 // isRetainer(cp) == rtsTrue => s == NULL
1538 // isRetainer(cp) == rtsFalse => s == cp.retainer
1542 s = retainerSetOf(cp);
1544 // (c, cp, r, s) is available.
1546 // (c, cp, r, s, R_r) is available, so compute the retainer set for *c.
1547 if (retainerSetOfc == NULL) {
1548 // This is the first visit to *c.
1552 associate(c, singleton(r));
1554 // s is actually the retainer set of *c!
1557 // compute c_child_r
1558 c_child_r = isRetainer(c) ? getRetainerFrom(c) : r;
1560 // This is not the first visit to *c.
1561 if (isMember(r, retainerSetOfc))
1562 goto loop; // no need to process child
1565 associate(c, addElement(r, retainerSetOfc));
1567 // s is not NULL and cp is not a retainer. This means that
1568 // each time *cp is visited, so is *c. Thus, if s has
1569 // exactly one more element in its retainer set than c, s
1570 // is also the new retainer set for *c.
1571 if (s->num == retainerSetOfc->num + 1) {
1574 // Otherwise, just add R_r to the current retainer set of *c.
1576 associate(c, addElement(r, retainerSetOfc));
1581 goto loop; // no need to process child
1583 // compute c_child_r
1587 // now, RSET() of all of *c, *cp, and *r is valid.
1588 // (c, c_child_r) are available.
1592 // Special case closures: we process these all in one go rather
1593 // than attempting to save the current position, because doing so
1597 retainStack(c, c_child_r,
1599 ((StgTSO *)c)->stack + ((StgTSO *)c)->stack_size);
1604 retain_PAP((StgPAP *)c, c_child_r);
1608 retainClosure(((StgAP_STACK *)c)->fun, c, c_child_r);
1609 retainStack(c, c_child_r,
1610 (StgPtr)((StgAP_STACK *)c)->payload,
1611 (StgPtr)((StgAP_STACK *)c)->payload +
1612 ((StgAP_STACK *)c)->size);
1616 push(c, c_child_r, &first_child);
1618 // If first_child is null, c has no child.
1619 // If first_child is not null, the top stack element points to the next
1620 // object. push() may or may not push a stackElement on the stack.
1621 if (first_child == NULL)
1624 // (c, cp, r) = (first_child, c, c_child_r)
1631 /* -----------------------------------------------------------------------------
1632 * Compute the retainer set for every object reachable from *tl.
1633 * -------------------------------------------------------------------------- */
1635 retainRoot( StgClosure **tl )
1637 // We no longer assume that only TSOs and WEAKs are roots; any closure can
1640 ASSERT(isEmptyRetainerStack());
1641 currentStackBoundary = stackTop;
1643 if (isRetainer(*tl)) {
1644 retainClosure(*tl, *tl, getRetainerFrom(*tl));
1646 retainClosure(*tl, *tl, CCS_SYSTEM);
1649 // NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl)));
1650 // *tl might be a TSO which is ThreadComplete, in which
1651 // case we ignore it for the purposes of retainer profiling.
1654 /* -----------------------------------------------------------------------------
1655 * Compute the retainer set for each of the objects in the heap.
1656 * -------------------------------------------------------------------------- */
1658 computeRetainerSet( void )
1664 #ifdef DEBUG_RETAINER
1665 RetainerSet tmpRetainerSet;
1668 GetRoots(retainRoot); // for scheduler roots
1670 // This function is called after a major GC, when key, value, and finalizer
1671 // all are guaranteed to be valid, or reachable.
1673 // The following code assumes that WEAK objects are considered to be roots
1674 // for retainer profilng.
1675 for (weak = weak_ptr_list; weak != NULL; weak = weak->link)
1676 // retainRoot((StgClosure *)weak);
1677 retainRoot((StgClosure **)&weak);
1679 // Consider roots from the stable ptr table.
1680 markStablePtrTable(retainRoot);
1682 // The following code resets the rs field of each unvisited mutable
1683 // object (computing sumOfNewCostExtra and updating costArray[] when
1684 // debugging retainer profiler).
1685 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1687 (generations[g].mut_list == END_MUT_LIST &&
1688 generations[g].mut_once_list == END_MUT_LIST));
1691 // I think traversing through mut_list is unnecessary.
1692 // Think about removing this part.
1693 for (ml = generations[g].mut_list; ml != END_MUT_LIST;
1694 ml = ml->mut_link) {
1696 maybeInitRetainerSet((StgClosure *)ml);
1697 rtl = retainerSetOf((StgClosure *)ml);
1699 #ifdef DEBUG_RETAINER
1701 // first visit to *ml
1702 // This is a violation of the interface rule!
1703 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1705 switch (get_itbl((StgClosure *)ml)->type) {
1709 case CONSTR_INTLIKE:
1710 case CONSTR_CHARLIKE:
1711 case CONSTR_NOCAF_STATIC:
1715 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1719 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1720 sumOfNewCostExtra += cost((StgClosure *)ml);
1727 // Traversing through mut_once_list is, in contrast, necessary
1728 // because we can find MUT_VAR objects which have not been
1729 // visited during retainer profiling.
1730 for (ml = generations[g].mut_once_list; ml != END_MUT_LIST;
1731 ml = ml->mut_link) {
1733 maybeInitRetainerSet((StgClosure *)ml);
1734 rtl = retainerSetOf((StgClosure *)ml);
1735 #ifdef DEBUG_RETAINER
1737 // first visit to *ml
1738 // This is a violation of the interface rule!
1739 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1741 switch (get_itbl((StgClosure *)ml)->type) {
1745 case CONSTR_INTLIKE:
1746 case CONSTR_CHARLIKE:
1747 case CONSTR_NOCAF_STATIC:
1751 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1755 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1756 sumOfNewCostExtra += cost((StgClosure *)ml);
1765 /* -----------------------------------------------------------------------------
1766 * Traverse all static objects for which we compute retainer sets,
1767 * and reset their rs fields to NULL, which is accomplished by
1768 * invoking maybeInitRetainerSet(). This function must be called
1769 * before zeroing all objects reachable from scavenged_static_objects
1770 * in the case of major gabage collections. See GarbageCollect() in
1773 * The mut_once_list of the oldest generation must also be traversed?
1774 * Why? Because if the evacuation of an object pointed to by a static
1775 * indirection object fails, it is put back to the mut_once_list of
1776 * the oldest generation.
1777 * However, this is not necessary because any static indirection objects
1778 * are just traversed through to reach dynamic objects. In other words,
1779 * they are not taken into consideration in computing retainer sets.
1780 * -------------------------------------------------------------------------- */
1782 resetStaticObjectForRetainerProfiling( void )
1784 #ifdef DEBUG_RETAINER
1789 #ifdef DEBUG_RETAINER
1792 p = scavenged_static_objects;
1793 while (p != END_OF_STATIC_LIST) {
1794 #ifdef DEBUG_RETAINER
1797 switch (get_itbl(p)->type) {
1799 // Since we do not compute the retainer set of any
1800 // IND_STATIC object, we don't have to reset its retainer
1802 p = IND_STATIC_LINK(p);
1805 maybeInitRetainerSet(p);
1806 p = THUNK_STATIC_LINK(p);
1809 maybeInitRetainerSet(p);
1810 p = FUN_STATIC_LINK(p);
1813 maybeInitRetainerSet(p);
1814 p = STATIC_LINK(get_itbl(p), p);
1817 barf("resetStaticObjectForRetainerProfiling: %p (%s)",
1818 p, get_itbl(p)->type);
1822 #ifdef DEBUG_RETAINER
1823 // fprintf(stderr, "count in scavenged_static_objects = %d\n", count);
1827 /* -----------------------------------------------------------------------------
1828 * Perform retainer profiling.
1829 * N is the oldest generation being profilied, where the generations are
1830 * numbered starting at 0.
1833 * This function should be called only immediately after major garbage
1835 * ------------------------------------------------------------------------- */
1837 retainerProfile(void)
1839 #ifdef DEBUG_RETAINER
1841 nat totalHeapSize; // total raw heap size (computed by linear scanning)
1844 #ifdef DEBUG_RETAINER
1845 fprintf(stderr, " < retainerProfile() invoked : %d>\n", retainerGeneration);
1850 // We haven't flipped the bit yet.
1851 #ifdef DEBUG_RETAINER
1852 fprintf(stderr, "Before traversing:\n");
1853 sumOfCostLinear = 0;
1854 for (i = 0;i < N_CLOSURE_TYPES; i++)
1855 costArrayLinear[i] = 0;
1856 totalHeapSize = checkHeapSanityForRetainerProfiling();
1858 fprintf(stderr, "\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1860 fprintf(stderr, "costArrayLinear[] = ");
1861 for (i = 0;i < N_CLOSURE_TYPES; i++)
1862 fprintf(stderr, "[%u:%u] ", i, costArrayLinear[i]);
1863 fprintf(stderr, "\n");
1866 ASSERT(sumOfCostLinear == totalHeapSize);
1869 #define pcostArrayLinear(index) \
1870 if (costArrayLinear[index] > 0) \
1871 fprintf(stderr, "costArrayLinear[" #index "] = %u\n", costArrayLinear[index])
1872 pcostArrayLinear(THUNK_STATIC);
1873 pcostArrayLinear(FUN_STATIC);
1874 pcostArrayLinear(CONSTR_STATIC);
1875 pcostArrayLinear(CONSTR_NOCAF_STATIC);
1876 pcostArrayLinear(CONSTR_INTLIKE);
1877 pcostArrayLinear(CONSTR_CHARLIKE);
1881 // Now we flips flip.
1884 #ifdef DEBUG_RETAINER
1890 numObjectVisited = 0;
1891 timesAnyObjectVisited = 0;
1893 #ifdef DEBUG_RETAINER
1894 fprintf(stderr, "During traversing:\n");
1896 sumOfNewCostExtra = 0;
1897 for (i = 0;i < N_CLOSURE_TYPES; i++)
1902 We initialize the traverse stack each time the retainer profiling is
1903 performed (because the traverse stack size varies on each retainer profiling
1904 and this operation is not costly anyhow). However, we just refresh the
1907 initializeTraverseStack();
1908 #ifdef DEBUG_RETAINER
1909 initializeAllRetainerSet();
1911 refreshAllRetainerSet();
1913 computeRetainerSet();
1915 #ifdef DEBUG_RETAINER
1916 fprintf(stderr, "After traversing:\n");
1917 sumOfCostLinear = 0;
1918 for (i = 0;i < N_CLOSURE_TYPES; i++)
1919 costArrayLinear[i] = 0;
1920 totalHeapSize = checkHeapSanityForRetainerProfiling();
1922 fprintf(stderr, "\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1923 ASSERT(sumOfCostLinear == totalHeapSize);
1925 // now, compare the two results
1928 costArray[] must be exactly the same as costArrayLinear[].
1930 1) Dead weak pointers, whose type is CONSTR. These objects are not
1931 reachable from any roots.
1933 fprintf(stderr, "Comparison:\n");
1934 fprintf(stderr, "\tcostArrayLinear[] (must be empty) = ");
1935 for (i = 0;i < N_CLOSURE_TYPES; i++)
1936 if (costArray[i] != costArrayLinear[i])
1937 // nothing should be printed except MUT_VAR after major GCs
1938 fprintf(stderr, "[%u:%u] ", i, costArrayLinear[i]);
1939 fprintf(stderr, "\n");
1941 fprintf(stderr, "\tsumOfNewCost = %u\n", sumOfNewCost);
1942 fprintf(stderr, "\tsumOfNewCostExtra = %u\n", sumOfNewCostExtra);
1943 fprintf(stderr, "\tcostArray[] (must be empty) = ");
1944 for (i = 0;i < N_CLOSURE_TYPES; i++)
1945 if (costArray[i] != costArrayLinear[i])
1946 // nothing should be printed except MUT_VAR after major GCs
1947 fprintf(stderr, "[%u:%u] ", i, costArray[i]);
1948 fprintf(stderr, "\n");
1950 // only for major garbage collection
1951 ASSERT(sumOfNewCost + sumOfNewCostExtra == sumOfCostLinear);
1955 closeTraverseStack();
1956 #ifdef DEBUG_RETAINER
1957 closeAllRetainerSet();
1959 // Note that there is no post-processing for the retainer sets.
1961 retainerGeneration++;
1964 retainerGeneration - 1, // retainerGeneration has just been incremented!
1965 #ifdef DEBUG_RETAINER
1966 maxCStackSize, maxStackSize,
1968 (double)timesAnyObjectVisited / numObjectVisited);
1971 /* -----------------------------------------------------------------------------
1973 * -------------------------------------------------------------------------- */
1975 #ifdef DEBUG_RETAINER
1977 #define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
1978 ((HEAP_ALLOCED(r) && Bdescr((P_)r)->free != (void *)-1))) && \
1979 ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa))
1982 sanityCheckHeapClosure( StgClosure *c )
1986 ASSERT(LOOKS_LIKE_GHC_INFO(c->header.info));
1987 ASSERT(!closure_STATIC(c));
1988 ASSERT(LOOKS_LIKE_PTR(c));
1990 if ((((StgWord)RSET(c) & 1) ^ flip) != 0) {
1991 if (get_itbl(c)->type == CONSTR &&
1992 !strcmp(get_itbl(c)->prof.closure_type, "DEAD_WEAK") &&
1993 !strcmp(get_itbl(c)->prof.closure_desc, "DEAD_WEAK")) {
1994 fprintf(stderr, "\tUnvisited dead weak pointer object found: c = %p\n", c);
1995 costArray[get_itbl(c)->type] += cost(c);
1996 sumOfNewCost += cost(c);
1999 "Unvisited object: flip = %d, c = %p(%d, %s, %s), rs = %p\n",
2000 flip, c, get_itbl(c)->type,
2001 get_itbl(c)->prof.closure_type, get_itbl(c)->prof.closure_desc,
2004 // fprintf(stderr, "sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c));
2008 switch (info->type) {
2010 return tso_sizeW((StgTSO *)c);
2018 return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE);
2021 return sizeofW(StgMVar);
2024 case MUT_ARR_PTRS_FROZEN:
2025 return mut_arr_ptrs_sizeW((StgMutArrPtrs *)c);
2029 return pap_sizeW((StgPAP *)c);
2032 return ap_stack_sizeW((StgAP_STACK *)c);
2035 return arr_words_sizeW((StgArrWords *)c);
2055 case SE_CAF_BLACKHOLE:
2059 case IND_OLDGEN_PERM:
2063 return sizeW_fromITBL(info);
2065 case THUNK_SELECTOR:
2066 return sizeofW(StgHeader) + MIN_UPD_SIZE;
2075 case CONSTR_INTLIKE:
2076 case CONSTR_CHARLIKE:
2077 case CONSTR_NOCAF_STATIC:
2094 case INVALID_OBJECT:
2096 barf("Invalid object in sanityCheckHeapClosure(): %d",
2103 heapCheck( bdescr *bd )
2106 static nat costSum, size;
2109 while (bd != NULL) {
2111 while (p < bd->free) {
2112 size = sanityCheckHeapClosure((StgClosure *)p);
2113 sumOfCostLinear += size;
2114 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2116 // no need for slop check; I think slops are not used currently.
2118 ASSERT(p == bd->free);
2119 costSum += bd->free - bd->start;
2127 smallObjectPoolCheck(void)
2131 static nat costSum, size;
2133 bd = small_alloc_list;
2141 while (p < alloc_Hp) {
2142 size = sanityCheckHeapClosure((StgClosure *)p);
2143 sumOfCostLinear += size;
2144 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2147 ASSERT(p == alloc_Hp);
2148 costSum += alloc_Hp - bd->start;
2151 while (bd != NULL) {
2153 while (p < bd->free) {
2154 size = sanityCheckHeapClosure((StgClosure *)p);
2155 sumOfCostLinear += size;
2156 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2159 ASSERT(p == bd->free);
2160 costSum += bd->free - bd->start;
2168 chainCheck(bdescr *bd)
2173 while (bd != NULL) {
2174 // bd->free - bd->start is not an accurate measurement of the
2175 // object size. Actually it is always zero, so we compute its
2177 size = sanityCheckHeapClosure((StgClosure *)bd->start);
2178 sumOfCostLinear += size;
2179 costArrayLinear[get_itbl((StgClosure *)bd->start)->type] += size;
2188 checkHeapSanityForRetainerProfiling( void )
2193 fprintf(stderr, "START: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2194 if (RtsFlags.GcFlags.generations == 1) {
2195 costSum += heapCheck(g0s0->to_blocks);
2196 fprintf(stderr, "heapCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2197 costSum += chainCheck(g0s0->large_objects);
2198 fprintf(stderr, "chainCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2200 for (g = 0; g < RtsFlags.GcFlags.generations; g++)
2201 for (s = 0; s < generations[g].n_steps; s++) {
2203 After all live objects have been scavenged, the garbage
2204 collector may create some objects in
2205 scheduleFinalizers(). These objects are created throught
2206 allocate(), so the small object pool or the large object
2207 pool of the g0s0 may not be empty.
2209 if (g == 0 && s == 0) {
2210 costSum += smallObjectPoolCheck();
2211 fprintf(stderr, "smallObjectPoolCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2212 costSum += chainCheck(generations[g].steps[s].large_objects);
2213 fprintf(stderr, "chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2215 costSum += heapCheck(generations[g].steps[s].blocks);
2216 fprintf(stderr, "heapCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2217 costSum += chainCheck(generations[g].steps[s].large_objects);
2218 fprintf(stderr, "chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2227 findPointer(StgPtr p)
2233 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2234 for (s = 0; s < generations[g].n_steps; s++) {
2235 // if (g == 0 && s == 0) continue;
2236 bd = generations[g].steps[s].blocks;
2237 for (; bd; bd = bd->link) {
2238 for (q = bd->start; q < bd->free; q++) {
2239 if (*q == (StgWord)p) {
2241 while (!LOOKS_LIKE_GHC_INFO(*r)) r--;
2242 fprintf(stderr, "Found in gen[%d], step[%d]: q = %p, r = %p\n", g, s, q, r);
2247 bd = generations[g].steps[s].large_objects;
2248 for (; bd; bd = bd->link) {
2249 e = bd->start + cost((StgClosure *)bd->start);
2250 for (q = bd->start; q < e; q++) {
2251 if (*q == (StgWord)p) {
2253 while (*r == 0 || !LOOKS_LIKE_GHC_INFO(*r)) r--;
2254 fprintf(stderr, "Found in gen[%d], large_objects: %p\n", g, r);
2264 belongToHeap(StgPtr p)
2269 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2270 for (s = 0; s < generations[g].n_steps; s++) {
2271 // if (g == 0 && s == 0) continue;
2272 bd = generations[g].steps[s].blocks;
2273 for (; bd; bd = bd->link) {
2274 if (bd->start <= p && p < bd->free) {
2275 fprintf(stderr, "Belongs to gen[%d], step[%d]", g, s);
2279 bd = generations[g].steps[s].large_objects;
2280 for (; bd; bd = bd->link) {
2281 if (bd->start <= p && p < bd->start + getHeapClosureSize((StgClosure *)bd->start)) {
2282 fprintf(stderr, "Found in gen[%d], large_objects: %p\n", g, bd->start);
2289 #endif // DEBUG_RETAINER
2291 #endif /* PROFILING */