1 /* -----------------------------------------------------------------------------
2 * $Id: RetainerProfile.c,v 1.5 2002/07/18 09:12:35 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"
35 Note: what to change in order to plug-in a new retainer profiling scheme?
36 (1) type retainer in ../includes/StgRetainerProf.h
37 (2) retainer function R(), i.e., getRetainerFrom()
38 (3) the two hashing functions, hashKeySingleton() and hashKeyAddElement(),
39 in RetainerSet.h, if needed.
40 (4) printRetainer() and printRetainerSetShort() in RetainerSet.c.
43 /* -----------------------------------------------------------------------------
45 * -------------------------------------------------------------------------- */
47 static nat retainerGeneration; // generation
49 static nat numObjectVisited; // total number of objects visited
50 static nat timesAnyObjectVisited; // number of times any objects are visited
53 The rs field in the profile header of any object points to its retainer
54 set in an indirect way: if flip is 0, it points to the retainer set;
55 if flip is 1, it points to the next byte after the retainer set (even
56 for NULL pointers). Therefore, with flip 1, (rs ^ 1) is the actual
57 pointer. See retainerSetOf().
60 StgWord flip = 0; // flip bit
61 // must be 0 if DEBUG_RETAINER is on (for static closures)
63 #define setRetainerSetToNull(c) \
64 (c)->header.prof.hp.rs = (RetainerSet *)((StgWord)NULL | flip)
66 static void retainStack(StgClosure *, retainer, StgClosure *, StgPtr, StgPtr);
67 static void retainClosure(StgClosure *, StgClosure *, retainer);
69 static void belongToHeap(StgPtr p);
74 cStackSize records how many times retainStack() has been invoked recursively,
75 that is, the number of activation records for retainStack() on the C stack.
76 maxCStackSize records its max value.
78 cStackSize <= maxCStackSize
80 static nat cStackSize, maxCStackSize;
82 static nat sumOfNewCost; // sum of the cost of each object, computed
83 // when the object is first visited
84 static nat sumOfNewCostExtra; // for those objects not visited during
85 // retainer profiling, e.g., MUT_VAR
86 static nat costArray[N_CLOSURE_TYPES];
88 nat sumOfCostLinear; // sum of the costs of all object, computed
89 // when linearly traversing the heap after
91 nat costArrayLinear[N_CLOSURE_TYPES];
94 /* -----------------------------------------------------------------------------
95 * Retainer stack - header
97 * Although the retainer stack implementation could be separated *
98 * from the retainer profiling engine, there does not seem to be
99 * any advantage in doing that; retainer stack is an integral part
100 * of retainer profiling engine and cannot be use elsewhere at
102 * -------------------------------------------------------------------------- */
111 // fixed layout or layout specified by a field in the closure
116 // See StgClosureInfo in InfoTables.h
117 #if SIZEOF_VOID_P == 8
130 StgClosure **srt_end;
147 firstStack points to the first block group.
148 currentStack points to the block group currently being used.
149 currentStack->free == stackLimit.
150 stackTop points to the topmost byte in the stack of currentStack.
151 Unless the whole stack is empty, stackTop must point to the topmost
152 object (or byte) in the whole stack. Thus, it is only when the whole stack
153 is empty that stackTop == stackLimit (not during the execution of push()
155 stackBottom == currentStack->start.
156 stackLimit == currentStack->start + BLOCK_SIZE_W * currentStack->blocks.
158 When a current stack becomes empty, stackTop is set to point to
159 the topmost element on the previous block group so as to satisfy
160 the invariants described above.
162 bdescr *firstStack = NULL;
163 static bdescr *currentStack;
164 static stackElement *stackBottom, *stackTop, *stackLimit;
167 currentStackBoundary is used to mark the current stack chunk.
168 If stackTop == currentStackBoundary, it means that the current stack chunk
169 is empty. It is the responsibility of the user to keep currentStackBoundary
170 valid all the time if it is to be employed.
172 static stackElement *currentStackBoundary;
175 stackSize records the current size of the stack.
176 maxStackSize records its high water mark.
178 stackSize <= maxStackSize
180 stackSize is just an estimate measure of the depth of the graph. The reason
181 is that some heap objects have only a single child and may not result
182 in a new element being pushed onto the stack. Therefore, at the end of
183 retainer profiling, maxStackSize + maxCStackSize is some value no greater
184 than the actual depth of the graph.
186 #ifdef DEBUG_RETAINER
187 static int stackSize, maxStackSize;
190 // number of blocks allocated for one stack
191 #define BLOCKS_IN_STACK 1
193 /* -----------------------------------------------------------------------------
194 * Add a new block group to the stack.
196 * currentStack->link == s.
197 * -------------------------------------------------------------------------- */
199 newStackBlock( bdescr *bd )
202 stackTop = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
203 stackBottom = (stackElement *)bd->start;
204 stackLimit = (stackElement *)stackTop;
205 bd->free = (StgPtr)stackLimit;
208 /* -----------------------------------------------------------------------------
209 * Return to the previous block group.
211 * s->link == currentStack.
212 * -------------------------------------------------------------------------- */
214 returnToOldStack( bdescr *bd )
217 stackTop = (stackElement *)bd->free;
218 stackBottom = (stackElement *)bd->start;
219 stackLimit = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
220 bd->free = (StgPtr)stackLimit;
223 /* -----------------------------------------------------------------------------
224 * Initializes the traverse stack.
225 * -------------------------------------------------------------------------- */
227 initializeTraverseStack( void )
229 if (firstStack != NULL) {
230 freeChain(firstStack);
233 firstStack = allocGroup(BLOCKS_IN_STACK);
234 firstStack->link = NULL;
235 firstStack->u.back = NULL;
237 newStackBlock(firstStack);
240 /* -----------------------------------------------------------------------------
241 * Frees all the block groups in the traverse stack.
244 * -------------------------------------------------------------------------- */
246 closeTraverseStack( void )
248 freeChain(firstStack);
252 /* -----------------------------------------------------------------------------
253 * Returns rtsTrue if the whole stack is empty.
254 * -------------------------------------------------------------------------- */
255 static inline rtsBool
256 isEmptyRetainerStack( void )
258 return (firstStack == currentStack) && stackTop == stackLimit;
261 /* -----------------------------------------------------------------------------
262 * Returns rtsTrue if stackTop is at the stack boundary of the current stack,
263 * i.e., if the current stack chunk is empty.
264 * -------------------------------------------------------------------------- */
265 static inline rtsBool
268 return stackTop == currentStackBoundary;
271 /* -----------------------------------------------------------------------------
272 * Initializes *info from ptrs and payload.
274 * payload[] begins with ptrs pointers followed by non-pointers.
275 * -------------------------------------------------------------------------- */
277 init_ptrs( stackPos *info, nat ptrs, StgPtr payload )
279 info->type = posTypePtrs;
280 info->next.ptrs.pos = 0;
281 info->next.ptrs.ptrs = ptrs;
282 info->next.ptrs.payload = payload;
285 /* -----------------------------------------------------------------------------
286 * Find the next object from *info.
287 * -------------------------------------------------------------------------- */
288 static inline StgClosure *
289 find_ptrs( stackPos *info )
291 if (info->next.ptrs.pos < info->next.ptrs.ptrs) {
292 return (StgClosure *)info->next.ptrs.payload[info->next.ptrs.pos++];
298 /* -----------------------------------------------------------------------------
299 * Initializes *info from SRT information stored in *infoTable.
300 * -------------------------------------------------------------------------- */
302 init_srt( stackPos *info, StgInfoTable *infoTable )
304 info->type = posTypeSRT;
305 info->next.srt.srt = (StgClosure **)(infoTable->srt);
306 info->next.srt.srt_end = info->next.srt.srt + infoTable->srt_len;
309 /* -----------------------------------------------------------------------------
310 * Find the next object from *info.
311 * -------------------------------------------------------------------------- */
312 static inline StgClosure *
313 find_srt( stackPos *info )
317 if (info->next.srt.srt < info->next.srt.srt_end) {
318 // See scavenge_srt() in GC.c for details.
319 #ifdef ENABLE_WIN32_DLL_SUPPORT
320 if ((unsigned long)(*(info->next.srt.srt)) & 0x1)
321 c = (* (StgClosure **)((unsigned long)*(info->next.srt.srt)) & ~0x1);
323 c = *(info->next.srt.srt);
325 c = *(info->next.srt.srt);
327 info->next.srt.srt++;
334 /* -----------------------------------------------------------------------------
335 * push() pushes a stackElement representing the next child of *c
336 * onto the traverse stack. If *c has no child, *first_child is set
337 * to NULL and nothing is pushed onto the stack. If *c has only one
338 * child, *c_chlid is set to that child and nothing is pushed onto
339 * the stack. If *c has more than two children, *first_child is set
340 * to the first child and a stackElement representing the second
341 * child is pushed onto the stack.
344 * *c_child_r is the most recent retainer of *c's children.
345 * *c is not any of TSO, PAP, or AP_UPD, which means that
346 * there cannot be any stack objects.
347 * Note: SRTs are considered to be children as well.
348 * -------------------------------------------------------------------------- */
350 push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
353 bdescr *nbd; // Next Block Descriptor
355 #ifdef DEBUG_RETAINER
356 // fprintf(stderr, "push(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
359 ASSERT(get_itbl(c)->type != TSO);
360 ASSERT(get_itbl(c)->type != PAP);
361 ASSERT(get_itbl(c)->type != AP_UPD);
368 se.c_child_r = c_child_r;
371 switch (get_itbl(c)->type) {
378 case SE_CAF_BLACKHOLE:
383 // one child (fixed), no SRT
386 *first_child = ((StgMutVar *)c)->var;
389 // blocking_queue must be TSO and the head of a linked list of TSOs.
390 // Shoule it be a child? Seems to be yes.
391 *first_child = (StgClosure *)((StgBlockingQueue *)c)->blocking_queue;
394 *first_child = ((StgSelector *)c)->selectee;
397 case IND_OLDGEN_PERM:
399 *first_child = ((StgIndOldGen *)c)->indirectee;
403 *first_child = c->payload[0];
406 // For CONSTR_2_0 and MVAR, we use se.info.step to record the position
407 // of the next child. We do not write a separate initialization code.
408 // Also we do not have to initialize info.type;
410 // two children (fixed), no SRT
411 // need to push a stackElement, but nothing to store in se.info
413 *first_child = c->payload[0]; // return the first pointer
414 // se.info.type = posTypeStep;
415 // se.info.next.step = 2; // 2 = second
418 // three children (fixed), no SRT
419 // need to push a stackElement
421 // head must be TSO and the head of a linked list of TSOs.
422 // Shoule it be a child? Seems to be yes.
423 *first_child = (StgClosure *)((StgMVar *)c)->head;
424 // se.info.type = posTypeStep;
425 se.info.next.step = 2; // 2 = second
428 // three children (fixed), no SRT
430 *first_child = ((StgWeak *)c)->key;
431 // se.info.type = posTypeStep;
432 se.info.next.step = 2;
435 // layout.payload.ptrs, no SRT
441 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
443 *first_child = find_ptrs(&se.info);
444 if (*first_child == NULL)
448 // StgMutArrPtr.ptrs, no SRT
450 case MUT_ARR_PTRS_FROZEN:
451 init_ptrs(&se.info, ((StgMutArrPtrs *)c)->ptrs,
452 (StgPtr)(((StgMutArrPtrs *)c)->payload));
453 *first_child = find_ptrs(&se.info);
454 if (*first_child == NULL)
458 // layout.payload.ptrs, SRT
459 case FUN: // *c is a heap object.
463 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
464 *first_child = find_ptrs(&se.info);
465 if (*first_child == NULL)
466 // no child from ptrs, so check SRT
470 // 1 fixed child, SRT
475 *first_child = c->payload[0];
476 ASSERT(*first_child != NULL);
477 init_srt(&se.info, get_itbl(c));
482 case FUN_STATIC: // *c is a heap object.
483 ASSERT(get_itbl(c)->srt_len != 0);
489 init_srt(&se.info, get_itbl(c));
490 *first_child = find_srt(&se.info);
491 if (*first_child == NULL)
501 case CONSTR_CHARLIKE:
502 case CONSTR_NOCAF_STATIC:
524 barf("Invalid object *c in push()");
528 if (stackTop - 1 < stackBottom) {
529 #ifdef DEBUG_RETAINER
530 // fprintf(stderr, "push() to the next stack.\n");
532 // currentStack->free is updated when the active stack is switched
533 // to the next stack.
534 currentStack->free = (StgPtr)stackTop;
536 if (currentStack->link == NULL) {
537 nbd = allocGroup(BLOCKS_IN_STACK);
539 nbd->u.back = currentStack;
540 currentStack->link = nbd;
542 nbd = currentStack->link;
547 // adjust stackTop (acutal push)
549 // If the size of stackElement was huge, we would better replace the
550 // following statement by either a memcpy() call or a switch statement
551 // on the type of the element. Currently, the size of stackElement is
552 // small enough (5 words) that this direct assignment seems to be enough.
555 #ifdef DEBUG_RETAINER
557 if (stackSize > maxStackSize) maxStackSize = stackSize;
558 // ASSERT(stackSize >= 0);
559 // fprintf(stderr, "stackSize = %d\n", stackSize);
563 /* -----------------------------------------------------------------------------
564 * popOff() and popOffReal(): Pop a stackElement off the traverse stack.
566 * stackTop cannot be equal to stackLimit unless the whole stack is
567 * empty, in which case popOff() is not allowed.
569 * You can think of popOffReal() as a part of popOff() which is
570 * executed at the end of popOff() in necessary. Since popOff() is
571 * likely to be executed quite often while popOffReal() is not, we
572 * separate popOffReal() from popOff(), which is declared as an
573 * inline function (for the sake of execution speed). popOffReal()
574 * is called only within popOff() and nowhere else.
575 * -------------------------------------------------------------------------- */
579 bdescr *pbd; // Previous Block Descriptor
581 #ifdef DEBUG_RETAINER
582 // fprintf(stderr, "pop() to the previous stack.\n");
585 ASSERT(stackTop + 1 == stackLimit);
586 ASSERT(stackBottom == (stackElement *)currentStack->start);
588 if (firstStack == currentStack) {
589 // The stack is completely empty.
591 ASSERT(stackTop == stackLimit);
592 #ifdef DEBUG_RETAINER
594 if (stackSize > maxStackSize) maxStackSize = stackSize;
596 ASSERT(stackSize >= 0);
597 fprintf(stderr, "stackSize = %d\n", stackSize);
603 // currentStack->free is updated when the active stack is switched back
604 // to the previous stack.
605 currentStack->free = (StgPtr)stackLimit;
607 // find the previous block descriptor
608 pbd = currentStack->u.back;
611 returnToOldStack(pbd);
613 #ifdef DEBUG_RETAINER
615 if (stackSize > maxStackSize) maxStackSize = stackSize;
617 ASSERT(stackSize >= 0);
618 fprintf(stderr, "stackSize = %d\n", stackSize);
625 #ifdef DEBUG_RETAINER
626 // fprintf(stderr, "\tpopOff(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
629 ASSERT(stackTop != stackLimit);
630 ASSERT(!isEmptyRetainerStack());
632 // <= (instead of <) is wrong!
633 if (stackTop + 1 < stackLimit) {
635 #ifdef DEBUG_RETAINER
637 if (stackSize > maxStackSize) maxStackSize = stackSize;
639 ASSERT(stackSize >= 0);
640 fprintf(stderr, "stackSize = %d\n", stackSize);
649 /* -----------------------------------------------------------------------------
650 * Finds the next object to be considered for retainer profiling and store
652 * Test if the topmost stack element indicates that more objects are left,
653 * and if so, retrieve the first object and store its pointer to *c. Also,
654 * set *cp and *r appropriately, both of which are stored in the stack element.
655 * The topmost stack element then is overwritten so as for it to now denote
657 * If the topmost stack element indicates no more objects are left, pop
658 * off the stack element until either an object can be retrieved or
659 * the current stack chunk becomes empty, indicated by rtsTrue returned by
660 * isOnBoundary(), in which case *c is set to NULL.
662 * It is okay to call this function even when the current stack chunk
664 * -------------------------------------------------------------------------- */
666 pop( StgClosure **c, StgClosure **cp, retainer *r )
670 #ifdef DEBUG_RETAINER
671 // fprintf(stderr, "pop(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
675 if (isOnBoundary()) { // if the current stack chunk is depleted
682 switch (get_itbl(se->c)->type) {
683 // two children (fixed), no SRT
684 // nothing in se.info
686 *c = se->c->payload[1];
692 // three children (fixed), no SRT
693 // need to push a stackElement
695 if (se->info.next.step == 2) {
696 *c = (StgClosure *)((StgMVar *)se->c)->tail;
697 se->info.next.step++; // move to the next step
700 *c = ((StgMVar *)se->c)->value;
707 // three children (fixed), no SRT
709 if (se->info.next.step == 2) {
710 *c = ((StgWeak *)se->c)->value;
711 se->info.next.step++;
714 *c = ((StgWeak *)se->c)->finalizer;
726 // StgMutArrPtr.ptrs, no SRT
728 case MUT_ARR_PTRS_FROZEN:
729 *c = find_ptrs(&se->info);
738 // layout.payload.ptrs, SRT
739 case FUN: // always a heap object
743 if (se->info.type == posTypePtrs) {
744 *c = find_ptrs(&se->info);
750 init_srt(&se->info, get_itbl(se->c));
765 *c = find_srt(&se->info);
774 // no child (fixed), no SRT
780 case SE_CAF_BLACKHOLE:
782 // one child (fixed), no SRT
788 case IND_OLDGEN_PERM:
797 case CONSTR_CHARLIKE:
798 case CONSTR_NOCAF_STATIC:
820 barf("Invalid object *c in pop()");
826 /* -----------------------------------------------------------------------------
827 * RETAINER PROFILING ENGINE
828 * -------------------------------------------------------------------------- */
831 initRetainerProfiling( void )
833 initializeAllRetainerSet();
834 retainerGeneration = 0;
837 /* -----------------------------------------------------------------------------
838 * This function must be called before f-closing prof_file.
839 * -------------------------------------------------------------------------- */
841 endRetainerProfiling( void )
843 #ifdef SECOND_APPROACH
844 outputAllRetainerSet(prof_file);
848 /* -----------------------------------------------------------------------------
849 * Returns the actual pointer to the retainer set of the closure *c.
850 * It may adjust RSET(c) subject to flip.
852 * RSET(c) is initialized to NULL if its current value does not
855 * Even though this function has side effects, they CAN be ignored because
856 * subsequent calls to retainerSetOf() always result in the same return value
857 * and retainerSetOf() is the only way to retrieve retainerSet of a given
859 * We have to perform an XOR (^) operation each time a closure is examined.
860 * The reason is that we do not know when a closure is visited last.
861 * -------------------------------------------------------------------------- */
863 maybeInitRetainerSet( StgClosure *c )
865 if (!isRetainerSetFieldValid(c)) {
866 setRetainerSetToNull(c);
870 /* -----------------------------------------------------------------------------
871 * Returns rtsTrue if *c is a retainer.
872 * -------------------------------------------------------------------------- */
873 static inline rtsBool
874 isRetainer( StgClosure *c )
876 switch (get_itbl(c)->type) {
880 // TSOs MUST be retainers: they constitute the set of roots.
888 case MUT_ARR_PTRS_FROZEN:
890 // thunks are retainers.
900 // Static thunks, or CAFS, are obviously retainers.
903 // WEAK objects are roots; there is separate code in which traversing
904 // begins from WEAK objects.
926 // partial applications
932 case SE_CAF_BLACKHOLE:
936 case IND_OLDGEN_PERM:
951 // IND_STATIC cannot be *c, *cp, *r in the retainer profiling loop.
953 // CONSTR_INTLIKE, CONSTR_CHARLIKE, and CONSTR_NOCAF_STATIC
954 // cannot be *c, *cp, *r in the retainer profiling loop.
956 case CONSTR_CHARLIKE:
957 case CONSTR_NOCAF_STATIC:
958 // Stack objects are invalid because they are never treated as
959 // legal objects during retainer profiling.
980 barf("Invalid object in isRetainer(): %d", get_itbl(c)->type);
985 /* -----------------------------------------------------------------------------
986 * Returns the retainer function value for the closure *c, i.e., R(*c).
987 * This function does NOT return the retainer(s) of *c.
989 * *c must be a retainer.
991 * Depending on the definition of this function, the maintenance of retainer
992 * sets can be made easier. If most retainer sets are likely to be created
993 * again across garbage collections, refreshAllRetainerSet() in
994 * RetainerSet.c can simply do nothing.
995 * If this is not the case, we can free all the retainer sets and
996 * re-initialize the hash table.
997 * See refreshAllRetainerSet() in RetainerSet.c.
998 * -------------------------------------------------------------------------- */
999 static inline retainer
1000 getRetainerFrom( StgClosure *c )
1002 ASSERT(isRetainer(c));
1004 #if defined(RETAINER_SCHEME_INFO)
1005 // Retainer scheme 1: retainer = info table
1007 #elif defined(RETAINER_SCHEME_CCS)
1008 // Retainer scheme 2: retainer = cost centre stack
1009 return c->header.prof.ccs;
1010 #elif defined(RETAINER_SCHEME_CC)
1011 // Retainer scheme 3: retainer = cost centre
1012 return c->header.prof.ccs->cc;
1016 /* -----------------------------------------------------------------------------
1017 * Associates the retainer set *s with the closure *c, that is, *s becomes
1018 * the retainer set of *c.
1022 * -------------------------------------------------------------------------- */
1024 associate( StgClosure *c, RetainerSet *s )
1026 // StgWord has the same size as pointers, so the following type
1028 RSET(c) = (RetainerSet *)((StgWord)s | flip);
1031 /* -----------------------------------------------------------------------------
1032 * Process all the objects in the stack chunk from stackStart to stackEnd
1033 * with *c and *c_child_r being their parent and their most recent retainer,
1034 * respectively. Treat stackOptionalFun as another child of *c if it is
1037 * *c is one of the following: TSO, PAP, and AP_UPD.
1038 * If *c is AP_UPD or PAP, stackOptionalFun is not NULL. Otherwise,
1040 * If *c is TSO, c == c_child_r.
1041 * stackStart < stackEnd.
1042 * RSET(c) and RSET(c_child_r) are valid, i.e., their
1043 * interpretation conforms to the current value of flip (even when they
1044 * are interpreted to be NULL).
1045 * If *c is TSO, its state is not any of ThreadRelocated, ThreadComplete,
1046 * or ThreadKilled, which means that its stack is ready to process.
1048 * This code was almost plagiarzied from GC.c! For each pointer,
1049 * retainClosure() is invoked instead of evacuate().
1050 * -------------------------------------------------------------------------- */
1052 retainStack( StgClosure *c, retainer c_child_r,
1053 StgClosure *stackOptionalFun, StgPtr stackStart,
1056 stackElement *oldStackBoundary;
1061 #ifdef DEBUG_RETAINER
1063 if (cStackSize > maxCStackSize) maxCStackSize = cStackSize;
1067 Each invocation of retainStack() creates a new virtual
1068 stack. Since all such stacks share a single common stack, we
1069 record the current currentStackBoundary, which will be restored
1072 oldStackBoundary = currentStackBoundary;
1073 currentStackBoundary = stackTop;
1075 #ifdef DEBUG_RETAINER
1076 // fprintf(stderr, "retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
1079 if (stackOptionalFun != NULL) {
1080 ASSERT(get_itbl(c)->type == AP_UPD || get_itbl(c)->type == PAP);
1081 retainClosure(stackOptionalFun, c, c_child_r);
1083 ASSERT(get_itbl(c)->type == TSO);
1084 ASSERT(((StgTSO *)c)->what_next != ThreadRelocated &&
1085 ((StgTSO *)c)->what_next != ThreadComplete &&
1086 ((StgTSO *)c)->what_next != ThreadKilled);
1090 while (p < stackEnd) {
1095 // The correctness of retainer profiling is subject to the
1096 // correctness of the two macros IS_ARG_TAG() and
1097 // LOOKS_LIKE_GHC_INFO(). Since LOOKS_LIKE_GHC_INFO() is a bit
1098 // precarious macro, so I believe that the current
1099 // implementation may not be quite safe. Also, scavenge_stack()
1100 // in GC.c also exploits this macro in order to identify shallow
1101 // pointers. I am not sure whether scavenge_stack() takes
1102 // further measurements to discern real shallow pointers.
1104 // I think this can be a serious problem if a stack chunk
1105 // contains some word which looks like a pointer but is
1106 // actually, say, a word constituting a floating number.
1109 // skip tagged words
1110 if (IS_ARG_TAG((StgWord)q)) {
1111 p += 1 + ARG_SIZE(q);
1115 // check if *p is a shallow closure pointer
1116 if (!LOOKS_LIKE_GHC_INFO(q)) {
1117 retainClosure((StgClosure *)q, c, c_child_r);
1122 // regular stack objects
1123 info = get_itbl((StgClosure *)p);
1124 switch(info->type) {
1126 bitmap = ((StgRetDyn *)p)->liveness;
1127 p = ((StgRetDyn *)p)->payload;
1130 // FUN and FUN_STATIC keep only their info pointer.
1137 retainClosure(((StgUpdateFrame *)p)->updatee, c, c_child_r);
1138 p += sizeofW(StgUpdateFrame);
1147 bitmap = info->layout.bitmap;
1150 while (bitmap != 0) {
1151 if ((bitmap & 1) == 0)
1152 retainClosure((StgClosure *)*p, c, c_child_r);
1154 bitmap = bitmap >> 1;
1158 StgClosure **srt, **srt_end;
1160 srt = (StgClosure **)(info->srt);
1161 srt_end = srt + info->srt_len;
1162 for (; srt < srt_end; srt++) {
1163 // See scavenge_srt() in GC.c for details.
1164 #ifdef ENABLE_WIN32_DLL_SUPPORT
1165 if ((unsigned long)(*srt) & 0x1)
1166 retainClosure(*(StgClosure **)(((unsigned long)*srt & ~0x1)), c, c_child_r);
1168 retainClosure(*srt, c, c_child_r);
1170 retainClosure(*srt, c, c_child_r);
1180 StgLargeBitmap *large_bitmap;
1183 large_bitmap = info->layout.large_bitmap;
1186 for (i = 0; i < large_bitmap->size; i++) {
1187 bitmap = large_bitmap->bitmap[i];
1188 q = p + sizeofW(StgWord) * 8;
1189 while (bitmap != 0) {
1190 if ((bitmap & 1) == 0)
1191 retainClosure((StgClosure *)*p, c, c_child_r);
1193 bitmap = bitmap >> 1;
1195 if (i + 1 < large_bitmap->size) {
1197 retainClosure((StgClosure *)*p, c, c_child_r);
1205 barf("Invalid object found in retainStack(): %d",
1210 // restore currentStackBoundary
1211 currentStackBoundary = oldStackBoundary;
1212 #ifdef DEBUG_RETAINER
1213 // fprintf(stderr, "retainStack() finished: currentStackBoundary = 0x%x\n", currentStackBoundary);
1216 #ifdef DEBUG_RETAINER
1221 /* -----------------------------------------------------------------------------
1222 * Compute the retainer set of *c0 and all its desecents by traversing.
1223 * *cp0 is the parent of *c0, and *r0 is the most recent retainer of *c0.
1225 * c0 = cp0 = r0 holds only for root objects.
1226 * RSET(cp0) and RSET(r0) are valid, i.e., their
1227 * interpretation conforms to the current value of flip (even when they
1228 * are interpreted to be NULL).
1229 * However, RSET(c0) may be corrupt, i.e., it may not conform to
1230 * the current value of flip. If it does not, during the execution
1231 * of this function, RSET(c0) must be initialized as well as all
1234 * stackTop must be the same at the beginning and the exit of this function.
1235 * *c0 can be TSO (as well as PAP and AP_UPD).
1236 * -------------------------------------------------------------------------- */
1238 retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
1240 // c = Current closure
1241 // cp = Current closure's Parent
1242 // r = current closures' most recent Retainer
1243 // c_child_r = current closure's children's most recent retainer
1244 // first_child = first child of c
1245 StgClosure *c, *cp, *first_child;
1246 RetainerSet *s, *retainerSetOfc;
1247 retainer r, c_child_r;
1250 #ifdef DEBUG_RETAINER
1251 // StgPtr oldStackTop;
1254 #ifdef DEBUG_RETAINER
1255 // oldStackTop = stackTop;
1256 // fprintf(stderr, "retainClosure() called: c0 = 0x%x, cp0 = 0x%x, r0 = 0x%x\n", c0, cp0, r0);
1259 // (c, cp, r) = (c0, cp0, r0)
1266 //fprintf(stderr, "loop");
1267 // pop to (c, cp, r);
1271 #ifdef DEBUG_RETAINER
1272 // fprintf(stderr, "retainClosure() ends: oldStackTop = 0x%x, stackTop = 0x%x\n", oldStackTop, stackTop);
1277 //fprintf(stderr, "inner_loop");
1280 // c = current closure under consideration,
1281 // cp = current closure's parent,
1282 // r = current closure's most recent retainer
1284 // Loop invariants (on the meaning of c, cp, r, and their retainer sets):
1285 // RSET(cp) and RSET(r) are valid.
1286 // RSET(c) is valid only if c has been visited before.
1288 // Loop invariants (on the relation between c, cp, and r)
1289 // if cp is not a retainer, r belongs to RSET(cp).
1290 // if cp is a retainer, r == cp.
1292 typeOfc = get_itbl(c)->type;
1294 #ifdef DEBUG_RETAINER
1297 case CONSTR_INTLIKE:
1298 case CONSTR_CHARLIKE:
1299 case CONSTR_NOCAF_STATIC:
1305 if (retainerSetOf(c) == NULL) { // first visit?
1306 costArray[typeOfc] += cost(c);
1307 sumOfNewCost += cost(c);
1316 if (((StgTSO *)c)->what_next == ThreadComplete ||
1317 ((StgTSO *)c)->what_next == ThreadKilled) {
1318 #ifdef DEBUG_RETAINER
1319 fprintf(stderr, "ThreadComplete or ThreadKilled encountered in retainClosure()\n");
1323 if (((StgTSO *)c)->what_next == ThreadRelocated) {
1324 #ifdef DEBUG_RETAINER
1325 fprintf(stderr, "ThreadRelocated encountered in retainClosure()\n");
1327 c = (StgClosure *)((StgTSO *)c)->link;
1333 // We just skip IND_STATIC, so its retainer set is never computed.
1334 c = ((StgIndStatic *)c)->indirectee;
1336 case CONSTR_INTLIKE:
1337 case CONSTR_CHARLIKE:
1338 // static objects with no pointers out, so goto loop.
1339 case CONSTR_NOCAF_STATIC:
1340 // It is not just enough not to compute the retainer set for *c; it is
1341 // mandatory because CONSTR_NOCAF_STATIC are not reachable from
1342 // scavenged_static_objects, the list from which is assumed to traverse
1343 // all static objects after major garbage collections.
1347 if (get_itbl(c)->srt_len == 0) {
1348 // No need to compute the retainer set; no dynamic objects
1349 // are reachable from *c.
1351 // Static objects: if we traverse all the live closures,
1352 // including static closures, during each heap census then
1353 // we will observe that some static closures appear and
1354 // disappear. eg. a closure may contain a pointer to a
1355 // static function 'f' which is not otherwise reachable
1356 // (it doesn't indirectly point to any CAFs, so it doesn't
1357 // appear in any SRTs), so we would find 'f' during
1358 // traversal. However on the next sweep there may be no
1359 // closures pointing to 'f'.
1361 // We must therefore ignore static closures whose SRT is
1362 // empty, because these are exactly the closures that may
1363 // "appear". A closure with a non-empty SRT, and which is
1364 // still required, will always be reachable.
1366 // But what about CONSTR_STATIC? Surely these may be able
1367 // to appear, and they don't have SRTs, so we can't
1368 // check. So for now, we're calling
1369 // resetStaticObjectForRetainerProfiling() from the
1370 // garbage collector to reset the retainer sets in all the
1371 // reachable static objects.
1378 // The above objects are ignored in computing the average number of times
1379 // an object is visited.
1380 timesAnyObjectVisited++;
1382 // If this is the first visit to c, initialize its retainer set.
1383 maybeInitRetainerSet(c);
1384 retainerSetOfc = retainerSetOf(c);
1387 // isRetainer(cp) == rtsTrue => s == NULL
1388 // isRetainer(cp) == rtsFalse => s == cp.retainer
1392 s = retainerSetOf(cp);
1394 // (c, cp, r, s) is available.
1396 // (c, cp, r, s, R_r) is available, so compute the retainer set for *c.
1397 if (retainerSetOfc == NULL) {
1398 // This is the first visit to *c.
1402 associate(c, singleton(r));
1404 // s is actually the retainer set of *c!
1407 // compute c_child_r
1408 c_child_r = isRetainer(c) ? getRetainerFrom(c) : r;
1410 // This is not the first visit to *c.
1411 if (isMember(r, retainerSetOfc))
1412 goto loop; // no need to process child
1415 associate(c, addElement(r, retainerSetOfc));
1417 // s is not NULL and cp is not a retainer. This means that
1418 // each time *cp is visited, so is *c. Thus, if s has
1419 // exactly one more element in its retainer set than c, s
1420 // is also the new retainer set for *c.
1421 if (s->num == retainerSetOfc->num + 1) {
1424 // Otherwise, just add R_r to the current retainer set of *c.
1426 associate(c, addElement(r, retainerSetOfc));
1431 goto loop; // no need to process child
1433 // compute c_child_r
1437 // now, RSET() of all of *c, *cp, and *r is valid.
1438 // (c, c_child_r) are available.
1442 if (typeOfc == TSO) {
1443 retainStack(c, c_child_r,
1446 ((StgTSO *)c)->stack + ((StgTSO *)c)->stack_size);
1449 } else if (typeOfc == PAP) {
1450 retainStack(c, c_child_r,
1452 (StgPtr)((StgPAP *)c)->payload,
1453 (StgPtr)((StgPAP *)c)->payload + ((StgPAP *)c)->n_args);
1456 } else if (typeOfc == AP_UPD) {
1457 retainStack(c, c_child_r,
1458 ((StgAP_UPD *)c)->fun,
1459 (StgPtr)((StgAP_UPD *)c)->payload,
1460 (StgPtr)((StgAP_UPD *)c)->payload +
1461 ((StgAP_UPD *)c)->n_args);
1466 push(c, c_child_r, &first_child);
1468 // If first_child is null, c has no child.
1469 // If first_child is not null, the top stack element points to the next
1470 // object. push() may or may not push a stackElement on the stack.
1471 if (first_child == NULL)
1474 // (c, cp, r) = (first_child, c, c_child_r)
1481 /* -----------------------------------------------------------------------------
1482 * Compute the retainer set for every object reachable from *tl.
1483 * -------------------------------------------------------------------------- */
1485 retainRoot( StgClosure **tl )
1487 // We no longer assume that only TSOs and WEAKs are roots; any closure can
1490 ASSERT(isEmptyRetainerStack());
1491 currentStackBoundary = stackTop;
1493 if (isRetainer(*tl)) {
1494 retainClosure(*tl, *tl, getRetainerFrom(*tl));
1496 retainClosure(*tl, *tl, CCS_SYSTEM);
1499 // NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl)));
1500 // *tl might be a TSO which is ThreadComplete, in which
1501 // case we ignore it for the purposes of retainer profiling.
1504 /* -----------------------------------------------------------------------------
1505 * Compute the retainer set for each of the objects in the heap.
1506 * -------------------------------------------------------------------------- */
1508 computeRetainerSet( void )
1514 #ifdef DEBUG_RETAINER
1515 RetainerSet tmpRetainerSet;
1518 GetRoots(retainRoot); // for scheduler roots
1520 // This function is called after a major GC, when key, value, and finalizer
1521 // all are guaranteed to be valid, or reachable.
1523 // The following code assumes that WEAK objects are considered to be roots
1524 // for retainer profilng.
1525 for (weak = weak_ptr_list; weak != NULL; weak = weak->link)
1526 // retainRoot((StgClosure *)weak);
1527 retainRoot((StgClosure **)&weak);
1529 // Consider roots from the stable ptr table.
1530 markStablePtrTable(retainRoot);
1532 // The following code resets the rs field of each unvisited mutable
1533 // object (computing sumOfNewCostExtra and updating costArray[] when
1534 // debugging retainer profiler).
1535 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1537 (generations[g].mut_list == END_MUT_LIST &&
1538 generations[g].mut_once_list == END_MUT_LIST));
1541 // I think traversing through mut_list is unnecessary.
1542 // Think about removing this part.
1543 for (ml = generations[g].mut_list; ml != END_MUT_LIST;
1544 ml = ml->mut_link) {
1546 maybeInitRetainerSet((StgClosure *)ml);
1547 rtl = retainerSetOf((StgClosure *)ml);
1549 #ifdef DEBUG_RETAINER
1551 // first visit to *ml
1552 // This is a violation of the interface rule!
1553 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1555 switch (get_itbl((StgClosure *)ml)->type) {
1559 case CONSTR_INTLIKE:
1560 case CONSTR_CHARLIKE:
1561 case CONSTR_NOCAF_STATIC:
1565 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1569 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1570 sumOfNewCostExtra += cost((StgClosure *)ml);
1577 // Traversing through mut_once_list is, in contrast, necessary
1578 // because we can find MUT_VAR objects which have not been
1579 // visited during retainer profiling.
1580 for (ml = generations[g].mut_once_list; ml != END_MUT_LIST;
1581 ml = ml->mut_link) {
1583 maybeInitRetainerSet((StgClosure *)ml);
1584 rtl = retainerSetOf((StgClosure *)ml);
1585 #ifdef DEBUG_RETAINER
1587 // first visit to *ml
1588 // This is a violation of the interface rule!
1589 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1591 switch (get_itbl((StgClosure *)ml)->type) {
1595 case CONSTR_INTLIKE:
1596 case CONSTR_CHARLIKE:
1597 case CONSTR_NOCAF_STATIC:
1601 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1605 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1606 sumOfNewCostExtra += cost((StgClosure *)ml);
1615 /* -----------------------------------------------------------------------------
1616 * Traverse all static objects for which we compute retainer sets,
1617 * and reset their rs fields to NULL, which is accomplished by
1618 * invoking maybeInitRetainerSet(). This function must be called
1619 * before zeroing all objects reachable from scavenged_static_objects
1620 * in the case of major gabage collections. See GarbageCollect() in
1623 * The mut_once_list of the oldest generation must also be traversed?
1624 * Why? Because if the evacuation of an object pointed to by a static
1625 * indirection object fails, it is put back to the mut_once_list of
1626 * the oldest generation.
1627 * However, this is not necessary because any static indirection objects
1628 * are just traversed through to reach dynamic objects. In other words,
1629 * they are not taken into consideration in computing retainer sets.
1630 * -------------------------------------------------------------------------- */
1632 resetStaticObjectForRetainerProfiling( void )
1634 #ifdef DEBUG_RETAINER
1639 #ifdef DEBUG_RETAINER
1642 p = scavenged_static_objects;
1643 while (p != END_OF_STATIC_LIST) {
1644 #ifdef DEBUG_RETAINER
1647 switch (get_itbl(p)->type) {
1649 // Since we do not compute the retainer set of any
1650 // IND_STATIC object, we don't have to reset its retainer
1652 p = IND_STATIC_LINK(p);
1655 maybeInitRetainerSet(p);
1656 p = THUNK_STATIC_LINK(p);
1659 maybeInitRetainerSet(p);
1660 p = FUN_STATIC_LINK(p);
1663 maybeInitRetainerSet(p);
1664 p = STATIC_LINK(get_itbl(p), p);
1667 barf("resetStaticObjectForRetainerProfiling: %p (%s)",
1668 p, get_itbl(p)->type);
1672 #ifdef DEBUG_RETAINER
1673 // fprintf(stderr, "count in scavenged_static_objects = %d\n", count);
1677 /* -----------------------------------------------------------------------------
1678 * Perform retainer profiling.
1679 * N is the oldest generation being profilied, where the generations are
1680 * numbered starting at 0.
1683 * This function should be called only immediately after major garbage
1685 * ------------------------------------------------------------------------- */
1687 retainerProfile(void)
1689 #ifdef DEBUG_RETAINER
1691 nat totalHeapSize; // total raw heap size (computed by linear scanning)
1694 #ifdef DEBUG_RETAINER
1695 fprintf(stderr, " < retainerProfile() invoked : %d>\n", retainerGeneration);
1700 // We haven't flipped the bit yet.
1701 #ifdef DEBUG_RETAINER
1702 fprintf(stderr, "Before traversing:\n");
1703 sumOfCostLinear = 0;
1704 for (i = 0;i < N_CLOSURE_TYPES; i++)
1705 costArrayLinear[i] = 0;
1706 totalHeapSize = checkHeapSanityForRetainerProfiling();
1708 fprintf(stderr, "\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1710 fprintf(stderr, "costArrayLinear[] = ");
1711 for (i = 0;i < N_CLOSURE_TYPES; i++)
1712 fprintf(stderr, "[%u:%u] ", i, costArrayLinear[i]);
1713 fprintf(stderr, "\n");
1716 ASSERT(sumOfCostLinear == totalHeapSize);
1719 #define pcostArrayLinear(index) \
1720 if (costArrayLinear[index] > 0) \
1721 fprintf(stderr, "costArrayLinear[" #index "] = %u\n", costArrayLinear[index])
1722 pcostArrayLinear(THUNK_STATIC);
1723 pcostArrayLinear(FUN_STATIC);
1724 pcostArrayLinear(CONSTR_STATIC);
1725 pcostArrayLinear(CONSTR_NOCAF_STATIC);
1726 pcostArrayLinear(CONSTR_INTLIKE);
1727 pcostArrayLinear(CONSTR_CHARLIKE);
1731 // Now we flips flip.
1734 #ifdef DEBUG_RETAINER
1740 numObjectVisited = 0;
1741 timesAnyObjectVisited = 0;
1743 #ifdef DEBUG_RETAINER
1744 fprintf(stderr, "During traversing:\n");
1746 sumOfNewCostExtra = 0;
1747 for (i = 0;i < N_CLOSURE_TYPES; i++)
1752 We initialize the traverse stack each time the retainer profiling is
1753 performed (because the traverse stack size varies on each retainer profiling
1754 and this operation is not costly anyhow). However, we just refresh the
1757 initializeTraverseStack();
1758 #ifdef DEBUG_RETAINER
1759 initializeAllRetainerSet();
1761 refreshAllRetainerSet();
1763 computeRetainerSet();
1765 #ifdef DEBUG_RETAINER
1766 fprintf(stderr, "After traversing:\n");
1767 sumOfCostLinear = 0;
1768 for (i = 0;i < N_CLOSURE_TYPES; i++)
1769 costArrayLinear[i] = 0;
1770 totalHeapSize = checkHeapSanityForRetainerProfiling();
1772 fprintf(stderr, "\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1773 ASSERT(sumOfCostLinear == totalHeapSize);
1775 // now, compare the two results
1778 costArray[] must be exactly the same as costArrayLinear[].
1780 1) Dead weak pointers, whose type is CONSTR. These objects are not
1781 reachable from any roots.
1783 fprintf(stderr, "Comparison:\n");
1784 fprintf(stderr, "\tcostArrayLinear[] (must be empty) = ");
1785 for (i = 0;i < N_CLOSURE_TYPES; i++)
1786 if (costArray[i] != costArrayLinear[i])
1787 // nothing should be printed except MUT_VAR after major GCs
1788 fprintf(stderr, "[%u:%u] ", i, costArrayLinear[i]);
1789 fprintf(stderr, "\n");
1791 fprintf(stderr, "\tsumOfNewCost = %u\n", sumOfNewCost);
1792 fprintf(stderr, "\tsumOfNewCostExtra = %u\n", sumOfNewCostExtra);
1793 fprintf(stderr, "\tcostArray[] (must be empty) = ");
1794 for (i = 0;i < N_CLOSURE_TYPES; i++)
1795 if (costArray[i] != costArrayLinear[i])
1796 // nothing should be printed except MUT_VAR after major GCs
1797 fprintf(stderr, "[%u:%u] ", i, costArray[i]);
1798 fprintf(stderr, "\n");
1800 // only for major garbage collection
1801 ASSERT(sumOfNewCost + sumOfNewCostExtra == sumOfCostLinear);
1805 closeTraverseStack();
1806 #ifdef DEBUG_RETAINER
1807 closeAllRetainerSet();
1809 // Note that there is no post-processing for the retainer sets.
1811 retainerGeneration++;
1814 retainerGeneration - 1, // retainerGeneration has just been incremented!
1815 #ifdef DEBUG_RETAINER
1816 maxCStackSize, maxStackSize,
1818 (double)timesAnyObjectVisited / numObjectVisited);
1821 /* -----------------------------------------------------------------------------
1823 * -------------------------------------------------------------------------- */
1825 #ifdef DEBUG_RETAINER
1827 #define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
1828 ((HEAP_ALLOCED(r) && Bdescr((P_)r)->free != (void *)-1))) && \
1829 ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa))
1832 sanityCheckHeapClosure( StgClosure *c )
1836 ASSERT(LOOKS_LIKE_GHC_INFO(c->header.info));
1837 ASSERT(!closure_STATIC(c));
1838 ASSERT(LOOKS_LIKE_PTR(c));
1840 if ((((StgWord)RSET(c) & 1) ^ flip) != 0) {
1841 if (get_itbl(c)->type == CONSTR &&
1842 !strcmp(get_itbl(c)->prof.closure_type, "DEAD_WEAK") &&
1843 !strcmp(get_itbl(c)->prof.closure_desc, "DEAD_WEAK")) {
1844 fprintf(stderr, "\tUnvisited dead weak pointer object found: c = %p\n", c);
1845 costArray[get_itbl(c)->type] += cost(c);
1846 sumOfNewCost += cost(c);
1849 "Unvisited object: flip = %d, c = %p(%d, %s, %s), rs = %p\n",
1850 flip, c, get_itbl(c)->type,
1851 get_itbl(c)->prof.closure_type, get_itbl(c)->prof.closure_desc,
1854 // fprintf(stderr, "sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c));
1858 switch (info->type) {
1860 return tso_sizeW((StgTSO *)c);
1868 return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE);
1871 return sizeofW(StgMVar);
1874 case MUT_ARR_PTRS_FROZEN:
1875 return mut_arr_ptrs_sizeW((StgMutArrPtrs *)c);
1879 return pap_sizeW((StgPAP *)c);
1882 return arr_words_sizeW((StgArrWords *)c);
1902 case SE_CAF_BLACKHOLE:
1906 case IND_OLDGEN_PERM:
1910 return sizeW_fromITBL(info);
1912 case THUNK_SELECTOR:
1913 return sizeofW(StgHeader) + MIN_UPD_SIZE;
1922 case CONSTR_INTLIKE:
1923 case CONSTR_CHARLIKE:
1924 case CONSTR_NOCAF_STATIC:
1942 case INVALID_OBJECT:
1944 barf("Invalid object in sanityCheckHeapClosure(): %d",
1951 heapCheck( bdescr *bd )
1954 static nat costSum, size;
1957 while (bd != NULL) {
1959 while (p < bd->free) {
1960 size = sanityCheckHeapClosure((StgClosure *)p);
1961 sumOfCostLinear += size;
1962 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
1964 // no need for slop check; I think slops are not used currently.
1966 ASSERT(p == bd->free);
1967 costSum += bd->free - bd->start;
1975 smallObjectPoolCheck(void)
1979 static nat costSum, size;
1981 bd = small_alloc_list;
1989 while (p < alloc_Hp) {
1990 size = sanityCheckHeapClosure((StgClosure *)p);
1991 sumOfCostLinear += size;
1992 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
1995 ASSERT(p == alloc_Hp);
1996 costSum += alloc_Hp - bd->start;
1999 while (bd != NULL) {
2001 while (p < bd->free) {
2002 size = sanityCheckHeapClosure((StgClosure *)p);
2003 sumOfCostLinear += size;
2004 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2007 ASSERT(p == bd->free);
2008 costSum += bd->free - bd->start;
2016 chainCheck(bdescr *bd)
2021 while (bd != NULL) {
2022 // bd->free - bd->start is not an accurate measurement of the
2023 // object size. Actually it is always zero, so we compute its
2025 size = sanityCheckHeapClosure((StgClosure *)bd->start);
2026 sumOfCostLinear += size;
2027 costArrayLinear[get_itbl((StgClosure *)bd->start)->type] += size;
2036 checkHeapSanityForRetainerProfiling( void )
2041 fprintf(stderr, "START: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2042 if (RtsFlags.GcFlags.generations == 1) {
2043 costSum += heapCheck(g0s0->to_blocks);
2044 fprintf(stderr, "heapCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2045 costSum += chainCheck(g0s0->large_objects);
2046 fprintf(stderr, "chainCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2048 for (g = 0; g < RtsFlags.GcFlags.generations; g++)
2049 for (s = 0; s < generations[g].n_steps; s++) {
2051 After all live objects have been scavenged, the garbage
2052 collector may create some objects in
2053 scheduleFinalizers(). These objects are created throught
2054 allocate(), so the small object pool or the large object
2055 pool of the g0s0 may not be empty.
2057 if (g == 0 && s == 0) {
2058 costSum += smallObjectPoolCheck();
2059 fprintf(stderr, "smallObjectPoolCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2060 costSum += chainCheck(generations[g].steps[s].large_objects);
2061 fprintf(stderr, "chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2063 costSum += heapCheck(generations[g].steps[s].blocks);
2064 fprintf(stderr, "heapCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2065 costSum += chainCheck(generations[g].steps[s].large_objects);
2066 fprintf(stderr, "chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2075 findPointer(StgPtr p)
2081 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2082 for (s = 0; s < generations[g].n_steps; s++) {
2083 // if (g == 0 && s == 0) continue;
2084 bd = generations[g].steps[s].blocks;
2085 for (; bd; bd = bd->link) {
2086 for (q = bd->start; q < bd->free; q++) {
2087 if (*q == (StgWord)p) {
2089 while (!LOOKS_LIKE_GHC_INFO(*r)) r--;
2090 fprintf(stderr, "Found in gen[%d], step[%d]: q = %p, r = %p\n", g, s, q, r);
2095 bd = generations[g].steps[s].large_objects;
2096 for (; bd; bd = bd->link) {
2097 e = bd->start + cost((StgClosure *)bd->start);
2098 for (q = bd->start; q < e; q++) {
2099 if (*q == (StgWord)p) {
2101 while (*r == 0 || !LOOKS_LIKE_GHC_INFO(*r)) r--;
2102 fprintf(stderr, "Found in gen[%d], large_objects: %p\n", g, r);
2112 belongToHeap(StgPtr p)
2117 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2118 for (s = 0; s < generations[g].n_steps; s++) {
2119 // if (g == 0 && s == 0) continue;
2120 bd = generations[g].steps[s].blocks;
2121 for (; bd; bd = bd->link) {
2122 if (bd->start <= p && p < bd->free) {
2123 fprintf(stderr, "Belongs to gen[%d], step[%d]", g, s);
2127 bd = generations[g].steps[s].large_objects;
2128 for (; bd; bd = bd->link) {
2129 if (bd->start <= p && p < bd->start + getHeapClosureSize((StgClosure *)bd->start)) {
2130 fprintf(stderr, "Found in gen[%d], large_objects: %p\n", g, bd->start);
2137 #endif // DEBUG_RETAINER
2139 #endif /* PROFILING */