1 /* -----------------------------------------------------------------------------
2 * $Id: RetainerProfile.c,v 1.4 2001/12/19 15:20:27 simonmar Exp $
4 * (c) The GHC Team, 2001
9 * ---------------------------------------------------------------------------*/
15 #include "RetainerProfile.h"
16 #include "RetainerSet.h"
20 #include "StoragePriv.h"
24 #include "StablePriv.h"
25 #include "Profiling.h"
27 #include "BlockAlloc.h"
29 #include "Proftimer.h"
33 Note: what to change in order to plug-in a new retainer profiling scheme?
34 (1) type retainer in ../includes/StgRetainerProf.h
35 (2) retainer function R(), i.e., getRetainerFrom()
36 (3) the two hashing functions, hashKeySingleton() and hashKeyAddElement(),
37 in RetainerSet.h, if needed.
38 (4) printRetainer() and printRetainerSetShort() in RetainerSet.c.
41 /* -----------------------------------------------------------------------------
43 * -------------------------------------------------------------------------- */
45 static nat retainerGeneration; // generation
47 static nat numObjectVisited; // total number of objects visited
48 static nat timesAnyObjectVisited; // number of times any objects are visited
51 The rs field in the profile header of any object points to its retainer
52 set in an indirect way: if flip is 0, it points to the retainer set;
53 if flip is 1, it points to the next byte after the retainer set (even
54 for NULL pointers). Therefore, with flip 1, (rs ^ 1) is the actual
55 pointer. See retainerSetOf().
58 StgWord flip = 0; // flip bit
59 // must be 0 if DEBUG_RETAINER is on (for static closures)
61 #define setRetainerSetToNull(c) \
62 (c)->header.prof.hp.rs = (RetainerSet *)((StgWord)NULL | flip)
64 static void retainStack(StgClosure *, retainer, StgClosure *, StgPtr, StgPtr);
65 static void retainClosure(StgClosure *, StgClosure *, retainer);
67 static void belongToHeap(StgPtr p);
72 cStackSize records how many times retainStack() has been invoked recursively,
73 that is, the number of activation records for retainStack() on the C stack.
74 maxCStackSize records its max value.
76 cStackSize <= maxCStackSize
78 static nat cStackSize, maxCStackSize;
80 static nat sumOfNewCost; // sum of the cost of each object, computed
81 // when the object is first visited
82 static nat sumOfNewCostExtra; // for those objects not visited during
83 // retainer profiling, e.g., MUT_VAR
84 static nat costArray[N_CLOSURE_TYPES];
86 nat sumOfCostLinear; // sum of the costs of all object, computed
87 // when linearly traversing the heap after
89 nat costArrayLinear[N_CLOSURE_TYPES];
92 /* -----------------------------------------------------------------------------
93 * Retainer stack - header
95 * Although the retainer stack implementation could be separated *
96 * from the retainer profiling engine, there does not seem to be
97 * any advantage in doing that; retainer stack is an integral part
98 * of retainer profiling engine and cannot be use elsewhere at
100 * -------------------------------------------------------------------------- */
109 // fixed layout or layout specified by a field in the closure
114 // See StgClosureInfo in InfoTables.h
115 #if SIZEOF_VOID_P == 8
128 StgClosure **srt_end;
145 firstStack points to the first block group.
146 currentStack points to the block group currently being used.
147 currentStack->free == stackLimit.
148 stackTop points to the topmost byte in the stack of currentStack.
149 Unless the whole stack is empty, stackTop must point to the topmost
150 object (or byte) in the whole stack. Thus, it is only when the whole stack
151 is empty that stackTop == stackLimit (not during the execution of push()
153 stackBottom == currentStack->start.
154 stackLimit == currentStack->start + BLOCK_SIZE_W * currentStack->blocks.
156 When a current stack becomes empty, stackTop is set to point to
157 the topmost element on the previous block group so as to satisfy
158 the invariants described above.
160 bdescr *firstStack = NULL;
161 static bdescr *currentStack;
162 static stackElement *stackBottom, *stackTop, *stackLimit;
165 currentStackBoundary is used to mark the current stack chunk.
166 If stackTop == currentStackBoundary, it means that the current stack chunk
167 is empty. It is the responsibility of the user to keep currentStackBoundary
168 valid all the time if it is to be employed.
170 static stackElement *currentStackBoundary;
173 stackSize records the current size of the stack.
174 maxStackSize records its high water mark.
176 stackSize <= maxStackSize
178 stackSize is just an estimate measure of the depth of the graph. The reason
179 is that some heap objects have only a single child and may not result
180 in a new element being pushed onto the stack. Therefore, at the end of
181 retainer profiling, maxStackSize + maxCStackSize is some value no greater
182 than the actual depth of the graph.
184 #ifdef DEBUG_RETAINER
185 static int stackSize, maxStackSize;
188 // number of blocks allocated for one stack
189 #define BLOCKS_IN_STACK 1
191 /* -----------------------------------------------------------------------------
192 * Add a new block group to the stack.
194 * currentStack->link == s.
195 * -------------------------------------------------------------------------- */
197 newStackBlock( bdescr *bd )
200 stackTop = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
201 stackBottom = (stackElement *)bd->start;
202 stackLimit = (stackElement *)stackTop;
203 bd->free = (StgPtr)stackLimit;
206 /* -----------------------------------------------------------------------------
207 * Return to the previous block group.
209 * s->link == currentStack.
210 * -------------------------------------------------------------------------- */
212 returnToOldStack( bdescr *bd )
215 stackTop = (stackElement *)bd->free;
216 stackBottom = (stackElement *)bd->start;
217 stackLimit = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
218 bd->free = (StgPtr)stackLimit;
221 /* -----------------------------------------------------------------------------
222 * Initializes the traverse stack.
223 * -------------------------------------------------------------------------- */
225 initializeTraverseStack( void )
227 if (firstStack != NULL) {
228 freeChain(firstStack);
231 firstStack = allocGroup(BLOCKS_IN_STACK);
232 firstStack->link = NULL;
233 firstStack->u.back = NULL;
235 newStackBlock(firstStack);
238 /* -----------------------------------------------------------------------------
239 * Frees all the block groups in the traverse stack.
242 * -------------------------------------------------------------------------- */
244 closeTraverseStack( void )
246 freeChain(firstStack);
250 /* -----------------------------------------------------------------------------
251 * Returns rtsTrue if the whole stack is empty.
252 * -------------------------------------------------------------------------- */
253 static inline rtsBool
254 isEmptyRetainerStack( void )
256 return (firstStack == currentStack) && stackTop == stackLimit;
259 /* -----------------------------------------------------------------------------
260 * Returns rtsTrue if stackTop is at the stack boundary of the current stack,
261 * i.e., if the current stack chunk is empty.
262 * -------------------------------------------------------------------------- */
263 static inline rtsBool
266 return stackTop == currentStackBoundary;
269 /* -----------------------------------------------------------------------------
270 * Initializes *info from ptrs and payload.
272 * payload[] begins with ptrs pointers followed by non-pointers.
273 * -------------------------------------------------------------------------- */
275 init_ptrs( stackPos *info, nat ptrs, StgPtr payload )
277 info->type = posTypePtrs;
278 info->next.ptrs.pos = 0;
279 info->next.ptrs.ptrs = ptrs;
280 info->next.ptrs.payload = payload;
283 /* -----------------------------------------------------------------------------
284 * Find the next object from *info.
285 * -------------------------------------------------------------------------- */
286 static inline StgClosure *
287 find_ptrs( stackPos *info )
289 if (info->next.ptrs.pos < info->next.ptrs.ptrs) {
290 return (StgClosure *)info->next.ptrs.payload[info->next.ptrs.pos++];
296 /* -----------------------------------------------------------------------------
297 * Initializes *info from SRT information stored in *infoTable.
298 * -------------------------------------------------------------------------- */
300 init_srt( stackPos *info, StgInfoTable *infoTable )
302 info->type = posTypeSRT;
303 info->next.srt.srt = (StgClosure **)(infoTable->srt);
304 info->next.srt.srt_end = info->next.srt.srt + infoTable->srt_len;
307 /* -----------------------------------------------------------------------------
308 * Find the next object from *info.
309 * -------------------------------------------------------------------------- */
310 static inline StgClosure *
311 find_srt( stackPos *info )
315 if (info->next.srt.srt < info->next.srt.srt_end) {
316 // See scavenge_srt() in GC.c for details.
317 #ifdef ENABLE_WIN32_DLL_SUPPORT
318 if ((unsigned long)(*(info->next.srt.srt)) & 0x1)
319 c = (* (StgClosure **)((unsigned long)*(info->next.srt.srt)) & ~0x1);
321 c = *(info->next.srt.srt);
323 c = *(info->next.srt.srt);
325 info->next.srt.srt++;
332 /* -----------------------------------------------------------------------------
333 * push() pushes a stackElement representing the next child of *c
334 * onto the traverse stack. If *c has no child, *first_child is set
335 * to NULL and nothing is pushed onto the stack. If *c has only one
336 * child, *c_chlid is set to that child and nothing is pushed onto
337 * the stack. If *c has more than two children, *first_child is set
338 * to the first child and a stackElement representing the second
339 * child is pushed onto the stack.
342 * *c_child_r is the most recent retainer of *c's children.
343 * *c is not any of TSO, PAP, or AP_UPD, which means that
344 * there cannot be any stack objects.
345 * Note: SRTs are considered to be children as well.
346 * -------------------------------------------------------------------------- */
348 push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
351 bdescr *nbd; // Next Block Descriptor
353 #ifdef DEBUG_RETAINER
354 // fprintf(stderr, "push(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
357 ASSERT(get_itbl(c)->type != TSO);
358 ASSERT(get_itbl(c)->type != PAP);
359 ASSERT(get_itbl(c)->type != AP_UPD);
366 se.c_child_r = c_child_r;
369 switch (get_itbl(c)->type) {
376 case SE_CAF_BLACKHOLE:
381 // one child (fixed), no SRT
384 *first_child = ((StgMutVar *)c)->var;
387 // blocking_queue must be TSO and the head of a linked list of TSOs.
388 // Shoule it be a child? Seems to be yes.
389 *first_child = (StgClosure *)((StgBlockingQueue *)c)->blocking_queue;
392 *first_child = ((StgSelector *)c)->selectee;
395 case IND_OLDGEN_PERM:
397 *first_child = ((StgIndOldGen *)c)->indirectee;
401 *first_child = c->payload[0];
404 // For CONSTR_2_0 and MVAR, we use se.info.step to record the position
405 // of the next child. We do not write a separate initialization code.
406 // Also we do not have to initialize info.type;
408 // two children (fixed), no SRT
409 // need to push a stackElement, but nothing to store in se.info
411 *first_child = c->payload[0]; // return the first pointer
412 // se.info.type = posTypeStep;
413 // se.info.next.step = 2; // 2 = second
416 // three children (fixed), no SRT
417 // need to push a stackElement
419 // head must be TSO and the head of a linked list of TSOs.
420 // Shoule it be a child? Seems to be yes.
421 *first_child = (StgClosure *)((StgMVar *)c)->head;
422 // se.info.type = posTypeStep;
423 se.info.next.step = 2; // 2 = second
426 // three children (fixed), no SRT
428 *first_child = ((StgWeak *)c)->key;
429 // se.info.type = posTypeStep;
430 se.info.next.step = 2;
433 // layout.payload.ptrs, no SRT
439 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
441 *first_child = find_ptrs(&se.info);
442 if (*first_child == NULL)
446 // StgMutArrPtr.ptrs, no SRT
448 case MUT_ARR_PTRS_FROZEN:
449 init_ptrs(&se.info, ((StgMutArrPtrs *)c)->ptrs,
450 (StgPtr)(((StgMutArrPtrs *)c)->payload));
451 *first_child = find_ptrs(&se.info);
452 if (*first_child == NULL)
456 // layout.payload.ptrs, SRT
457 case FUN: // *c is a heap object.
461 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
462 *first_child = find_ptrs(&se.info);
463 if (*first_child == NULL)
464 // no child from ptrs, so check SRT
468 // 1 fixed child, SRT
473 *first_child = c->payload[0];
474 ASSERT(*first_child != NULL);
475 init_srt(&se.info, get_itbl(c));
480 case FUN_STATIC: // *c is a heap object.
481 ASSERT(get_itbl(c)->srt_len != 0);
487 init_srt(&se.info, get_itbl(c));
488 *first_child = find_srt(&se.info);
489 if (*first_child == NULL)
499 case CONSTR_CHARLIKE:
500 case CONSTR_NOCAF_STATIC:
522 barf("Invalid object *c in push()");
526 if (stackTop - 1 < stackBottom) {
527 #ifdef DEBUG_RETAINER
528 // fprintf(stderr, "push() to the next stack.\n");
530 // currentStack->free is updated when the active stack is switched
531 // to the next stack.
532 currentStack->free = (StgPtr)stackTop;
534 if (currentStack->link == NULL) {
535 nbd = allocGroup(BLOCKS_IN_STACK);
537 nbd->u.back = currentStack;
538 currentStack->link = nbd;
540 nbd = currentStack->link;
545 // adjust stackTop (acutal push)
547 // If the size of stackElement was huge, we would better replace the
548 // following statement by either a memcpy() call or a switch statement
549 // on the type of the element. Currently, the size of stackElement is
550 // small enough (5 words) that this direct assignment seems to be enough.
553 #ifdef DEBUG_RETAINER
555 if (stackSize > maxStackSize) maxStackSize = stackSize;
556 // ASSERT(stackSize >= 0);
557 // fprintf(stderr, "stackSize = %d\n", stackSize);
561 /* -----------------------------------------------------------------------------
562 * popOff() and popOffReal(): Pop a stackElement off the traverse stack.
564 * stackTop cannot be equal to stackLimit unless the whole stack is
565 * empty, in which case popOff() is not allowed.
567 * You can think of popOffReal() as a part of popOff() which is
568 * executed at the end of popOff() in necessary. Since popOff() is
569 * likely to be executed quite often while popOffReal() is not, we
570 * separate popOffReal() from popOff(), which is declared as an
571 * inline function (for the sake of execution speed). popOffReal()
572 * is called only within popOff() and nowhere else.
573 * -------------------------------------------------------------------------- */
577 bdescr *pbd; // Previous Block Descriptor
579 #ifdef DEBUG_RETAINER
580 // fprintf(stderr, "pop() to the previous stack.\n");
583 ASSERT(stackTop + 1 == stackLimit);
584 ASSERT(stackBottom == (stackElement *)currentStack->start);
586 if (firstStack == currentStack) {
587 // The stack is completely empty.
589 ASSERT(stackTop == stackLimit);
590 #ifdef DEBUG_RETAINER
592 if (stackSize > maxStackSize) maxStackSize = stackSize;
594 ASSERT(stackSize >= 0);
595 fprintf(stderr, "stackSize = %d\n", stackSize);
601 // currentStack->free is updated when the active stack is switched back
602 // to the previous stack.
603 currentStack->free = (StgPtr)stackLimit;
605 // find the previous block descriptor
606 pbd = currentStack->u.back;
609 returnToOldStack(pbd);
611 #ifdef DEBUG_RETAINER
613 if (stackSize > maxStackSize) maxStackSize = stackSize;
615 ASSERT(stackSize >= 0);
616 fprintf(stderr, "stackSize = %d\n", stackSize);
623 #ifdef DEBUG_RETAINER
624 // fprintf(stderr, "\tpopOff(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
627 ASSERT(stackTop != stackLimit);
628 ASSERT(!isEmptyRetainerStack());
630 // <= (instead of <) is wrong!
631 if (stackTop + 1 < stackLimit) {
633 #ifdef DEBUG_RETAINER
635 if (stackSize > maxStackSize) maxStackSize = stackSize;
637 ASSERT(stackSize >= 0);
638 fprintf(stderr, "stackSize = %d\n", stackSize);
647 /* -----------------------------------------------------------------------------
648 * Finds the next object to be considered for retainer profiling and store
650 * Test if the topmost stack element indicates that more objects are left,
651 * and if so, retrieve the first object and store its pointer to *c. Also,
652 * set *cp and *r appropriately, both of which are stored in the stack element.
653 * The topmost stack element then is overwritten so as for it to now denote
655 * If the topmost stack element indicates no more objects are left, pop
656 * off the stack element until either an object can be retrieved or
657 * the current stack chunk becomes empty, indicated by rtsTrue returned by
658 * isOnBoundary(), in which case *c is set to NULL.
660 * It is okay to call this function even when the current stack chunk
662 * -------------------------------------------------------------------------- */
664 pop( StgClosure **c, StgClosure **cp, retainer *r )
668 #ifdef DEBUG_RETAINER
669 // fprintf(stderr, "pop(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
673 if (isOnBoundary()) { // if the current stack chunk is depleted
680 switch (get_itbl(se->c)->type) {
681 // two children (fixed), no SRT
682 // nothing in se.info
684 *c = se->c->payload[1];
690 // three children (fixed), no SRT
691 // need to push a stackElement
693 if (se->info.next.step == 2) {
694 *c = (StgClosure *)((StgMVar *)se->c)->tail;
695 se->info.next.step++; // move to the next step
698 *c = ((StgMVar *)se->c)->value;
705 // three children (fixed), no SRT
707 if (se->info.next.step == 2) {
708 *c = ((StgWeak *)se->c)->value;
709 se->info.next.step++;
712 *c = ((StgWeak *)se->c)->finalizer;
724 // StgMutArrPtr.ptrs, no SRT
726 case MUT_ARR_PTRS_FROZEN:
727 *c = find_ptrs(&se->info);
736 // layout.payload.ptrs, SRT
737 case FUN: // always a heap object
741 if (se->info.type == posTypePtrs) {
742 *c = find_ptrs(&se->info);
748 init_srt(&se->info, get_itbl(se->c));
763 *c = find_srt(&se->info);
772 // no child (fixed), no SRT
778 case SE_CAF_BLACKHOLE:
780 // one child (fixed), no SRT
786 case IND_OLDGEN_PERM:
795 case CONSTR_CHARLIKE:
796 case CONSTR_NOCAF_STATIC:
818 barf("Invalid object *c in pop()");
824 /* -----------------------------------------------------------------------------
825 * RETAINER PROFILING ENGINE
826 * -------------------------------------------------------------------------- */
829 initRetainerProfiling( void )
831 initializeAllRetainerSet();
832 retainerGeneration = 0;
835 /* -----------------------------------------------------------------------------
836 * This function must be called before f-closing prof_file.
837 * -------------------------------------------------------------------------- */
839 endRetainerProfiling( void )
841 #ifdef SECOND_APPROACH
842 outputAllRetainerSet(prof_file);
846 /* -----------------------------------------------------------------------------
847 * Returns the actual pointer to the retainer set of the closure *c.
848 * It may adjust RSET(c) subject to flip.
850 * RSET(c) is initialized to NULL if its current value does not
853 * Even though this function has side effects, they CAN be ignored because
854 * subsequent calls to retainerSetOf() always result in the same return value
855 * and retainerSetOf() is the only way to retrieve retainerSet of a given
857 * We have to perform an XOR (^) operation each time a closure is examined.
858 * The reason is that we do not know when a closure is visited last.
859 * -------------------------------------------------------------------------- */
861 maybeInitRetainerSet( StgClosure *c )
863 if (!isRetainerSetFieldValid(c)) {
864 setRetainerSetToNull(c);
868 /* -----------------------------------------------------------------------------
869 * Returns rtsTrue if *c is a retainer.
870 * -------------------------------------------------------------------------- */
871 static inline rtsBool
872 isRetainer( StgClosure *c )
874 switch (get_itbl(c)->type) {
878 // TSOs MUST be retainers: they constitute the set of roots.
886 case MUT_ARR_PTRS_FROZEN:
888 // thunks are retainers.
898 // Static thunks, or CAFS, are obviously retainers.
901 // WEAK objects are roots; there is separate code in which traversing
902 // begins from WEAK objects.
924 // partial applications
930 case SE_CAF_BLACKHOLE:
934 case IND_OLDGEN_PERM:
949 // IND_STATIC cannot be *c, *cp, *r in the retainer profiling loop.
951 // CONSTR_INTLIKE, CONSTR_CHARLIKE, and CONSTR_NOCAF_STATIC
952 // cannot be *c, *cp, *r in the retainer profiling loop.
954 case CONSTR_CHARLIKE:
955 case CONSTR_NOCAF_STATIC:
956 // Stack objects are invalid because they are never treated as
957 // legal objects during retainer profiling.
978 barf("Invalid object in isRetainer(): %d", get_itbl(c)->type);
983 /* -----------------------------------------------------------------------------
984 * Returns the retainer function value for the closure *c, i.e., R(*c).
985 * This function does NOT return the retainer(s) of *c.
987 * *c must be a retainer.
989 * Depending on the definition of this function, the maintenance of retainer
990 * sets can be made easier. If most retainer sets are likely to be created
991 * again across garbage collections, refreshAllRetainerSet() in
992 * RetainerSet.c can simply do nothing.
993 * If this is not the case, we can free all the retainer sets and
994 * re-initialize the hash table.
995 * See refreshAllRetainerSet() in RetainerSet.c.
996 * -------------------------------------------------------------------------- */
997 static inline retainer
998 getRetainerFrom( StgClosure *c )
1000 ASSERT(isRetainer(c));
1002 #if defined(RETAINER_SCHEME_INFO)
1003 // Retainer scheme 1: retainer = info table
1005 #elif defined(RETAINER_SCHEME_CCS)
1006 // Retainer scheme 2: retainer = cost centre stack
1007 return c->header.prof.ccs;
1008 #elif defined(RETAINER_SCHEME_CC)
1009 // Retainer scheme 3: retainer = cost centre
1010 return c->header.prof.ccs->cc;
1014 /* -----------------------------------------------------------------------------
1015 * Associates the retainer set *s with the closure *c, that is, *s becomes
1016 * the retainer set of *c.
1020 * -------------------------------------------------------------------------- */
1022 associate( StgClosure *c, RetainerSet *s )
1024 // StgWord has the same size as pointers, so the following type
1026 RSET(c) = (RetainerSet *)((StgWord)s | flip);
1029 /* -----------------------------------------------------------------------------
1030 * Process all the objects in the stack chunk from stackStart to stackEnd
1031 * with *c and *c_child_r being their parent and their most recent retainer,
1032 * respectively. Treat stackOptionalFun as another child of *c if it is
1035 * *c is one of the following: TSO, PAP, and AP_UPD.
1036 * If *c is AP_UPD or PAP, stackOptionalFun is not NULL. Otherwise,
1038 * If *c is TSO, c == c_child_r.
1039 * stackStart < stackEnd.
1040 * RSET(c) and RSET(c_child_r) are valid, i.e., their
1041 * interpretation conforms to the current value of flip (even when they
1042 * are interpreted to be NULL).
1043 * If *c is TSO, its state is not any of ThreadRelocated, ThreadComplete,
1044 * or ThreadKilled, which means that its stack is ready to process.
1046 * This code was almost plagiarzied from GC.c! For each pointer,
1047 * retainClosure() is invoked instead of evacuate().
1048 * -------------------------------------------------------------------------- */
1050 retainStack( StgClosure *c, retainer c_child_r,
1051 StgClosure *stackOptionalFun, StgPtr stackStart,
1054 stackElement *oldStackBoundary;
1059 #ifdef DEBUG_RETAINER
1061 if (cStackSize > maxCStackSize) maxCStackSize = cStackSize;
1065 Each invocation of retainStack() creates a new virtual
1066 stack. Since all such stacks share a single common stack, we
1067 record the current currentStackBoundary, which will be restored
1070 oldStackBoundary = currentStackBoundary;
1071 currentStackBoundary = stackTop;
1073 #ifdef DEBUG_RETAINER
1074 // fprintf(stderr, "retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
1077 if (stackOptionalFun != NULL) {
1078 ASSERT(get_itbl(c)->type == AP_UPD || get_itbl(c)->type == PAP);
1079 retainClosure(stackOptionalFun, c, c_child_r);
1081 ASSERT(get_itbl(c)->type == TSO);
1082 ASSERT(((StgTSO *)c)->what_next != ThreadRelocated &&
1083 ((StgTSO *)c)->what_next != ThreadComplete &&
1084 ((StgTSO *)c)->what_next != ThreadKilled);
1088 while (p < stackEnd) {
1093 // The correctness of retainer profiling is subject to the
1094 // correctness of the two macros IS_ARG_TAG() and
1095 // LOOKS_LIKE_GHC_INFO(). Since LOOKS_LIKE_GHC_INFO() is a bit
1096 // precarious macro, so I believe that the current
1097 // implementation may not be quite safe. Also, scavenge_stack()
1098 // in GC.c also exploits this macro in order to identify shallow
1099 // pointers. I am not sure whether scavenge_stack() takes
1100 // further measurements to discern real shallow pointers.
1102 // I think this can be a serious problem if a stack chunk
1103 // contains some word which looks like a pointer but is
1104 // actually, say, a word constituting a floating number.
1107 // skip tagged words
1108 if (IS_ARG_TAG((StgWord)q)) {
1109 p += 1 + ARG_SIZE(q);
1113 // check if *p is a shallow closure pointer
1114 if (!LOOKS_LIKE_GHC_INFO(q)) {
1115 retainClosure((StgClosure *)q, c, c_child_r);
1120 // regular stack objects
1121 info = get_itbl((StgClosure *)p);
1122 switch(info->type) {
1124 bitmap = ((StgRetDyn *)p)->liveness;
1125 p = ((StgRetDyn *)p)->payload;
1128 // FUN and FUN_STATIC keep only their info pointer.
1135 retainClosure(((StgUpdateFrame *)p)->updatee, c, c_child_r);
1136 p += sizeofW(StgUpdateFrame);
1145 bitmap = info->layout.bitmap;
1148 while (bitmap != 0) {
1149 if ((bitmap & 1) == 0)
1150 retainClosure((StgClosure *)*p, c, c_child_r);
1152 bitmap = bitmap >> 1;
1156 StgClosure **srt, **srt_end;
1158 srt = (StgClosure **)(info->srt);
1159 srt_end = srt + info->srt_len;
1160 for (; srt < srt_end; srt++) {
1161 // See scavenge_srt() in GC.c for details.
1162 #ifdef ENABLE_WIN32_DLL_SUPPORT
1163 if ((unsigned long)(*srt) & 0x1)
1164 retainClosure(*(StgClosure **)(((unsigned long)*srt & ~0x1)), c, c_child_r);
1166 retainClosure(*srt, c, c_child_r);
1168 retainClosure(*srt, c, c_child_r);
1178 StgLargeBitmap *large_bitmap;
1181 large_bitmap = info->layout.large_bitmap;
1184 for (i = 0; i < large_bitmap->size; i++) {
1185 bitmap = large_bitmap->bitmap[i];
1186 q = p + sizeofW(StgWord) * 8;
1187 while (bitmap != 0) {
1188 if ((bitmap & 1) == 0)
1189 retainClosure((StgClosure *)*p, c, c_child_r);
1191 bitmap = bitmap >> 1;
1193 if (i + 1 < large_bitmap->size) {
1195 retainClosure((StgClosure *)*p, c, c_child_r);
1203 barf("Invalid object found in retainStack(): %d",
1208 // restore currentStackBoundary
1209 currentStackBoundary = oldStackBoundary;
1210 #ifdef DEBUG_RETAINER
1211 // fprintf(stderr, "retainStack() finished: currentStackBoundary = 0x%x\n", currentStackBoundary);
1214 #ifdef DEBUG_RETAINER
1219 /* -----------------------------------------------------------------------------
1220 * Compute the retainer set of *c0 and all its desecents by traversing.
1221 * *cp0 is the parent of *c0, and *r0 is the most recent retainer of *c0.
1223 * c0 = cp0 = r0 holds only for root objects.
1224 * RSET(cp0) and RSET(r0) are valid, i.e., their
1225 * interpretation conforms to the current value of flip (even when they
1226 * are interpreted to be NULL).
1227 * However, RSET(c0) may be corrupt, i.e., it may not conform to
1228 * the current value of flip. If it does not, during the execution
1229 * of this function, RSET(c0) must be initialized as well as all
1232 * stackTop must be the same at the beginning and the exit of this function.
1233 * *c0 can be TSO (as well as PAP and AP_UPD).
1234 * -------------------------------------------------------------------------- */
1236 retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
1238 // c = Current closure
1239 // cp = Current closure's Parent
1240 // r = current closures' most recent Retainer
1241 // c_child_r = current closure's children's most recent retainer
1242 // first_child = first child of c
1243 StgClosure *c, *cp, *first_child;
1244 RetainerSet *s, *retainerSetOfc;
1245 retainer r, c_child_r;
1248 #ifdef DEBUG_RETAINER
1249 // StgPtr oldStackTop;
1252 #ifdef DEBUG_RETAINER
1253 // oldStackTop = stackTop;
1254 // fprintf(stderr, "retainClosure() called: c0 = 0x%x, cp0 = 0x%x, r0 = 0x%x\n", c0, cp0, r0);
1257 // (c, cp, r) = (c0, cp0, r0)
1264 //fprintf(stderr, "loop");
1265 // pop to (c, cp, r);
1269 #ifdef DEBUG_RETAINER
1270 // fprintf(stderr, "retainClosure() ends: oldStackTop = 0x%x, stackTop = 0x%x\n", oldStackTop, stackTop);
1275 //fprintf(stderr, "inner_loop");
1278 // c = current closure under consideration,
1279 // cp = current closure's parent,
1280 // r = current closure's most recent retainer
1282 // Loop invariants (on the meaning of c, cp, r, and their retainer sets):
1283 // RSET(cp) and RSET(r) are valid.
1284 // RSET(c) is valid only if c has been visited before.
1286 // Loop invariants (on the relation between c, cp, and r)
1287 // if cp is not a retainer, r belongs to RSET(cp).
1288 // if cp is a retainer, r == cp.
1290 typeOfc = get_itbl(c)->type;
1292 #ifdef DEBUG_RETAINER
1295 case CONSTR_INTLIKE:
1296 case CONSTR_CHARLIKE:
1297 case CONSTR_NOCAF_STATIC:
1303 if (retainerSetOf(c) == NULL) { // first visit?
1304 costArray[typeOfc] += cost(c);
1305 sumOfNewCost += cost(c);
1314 if (((StgTSO *)c)->what_next == ThreadComplete ||
1315 ((StgTSO *)c)->what_next == ThreadKilled) {
1316 #ifdef DEBUG_RETAINER
1317 fprintf(stderr, "ThreadComplete or ThreadKilled encountered in retainClosure()\n");
1321 if (((StgTSO *)c)->what_next == ThreadRelocated) {
1322 #ifdef DEBUG_RETAINER
1323 fprintf(stderr, "ThreadRelocated encountered in retainClosure()\n");
1325 c = (StgClosure *)((StgTSO *)c)->link;
1331 // We just skip IND_STATIC, so its retainer set is never computed.
1332 c = ((StgIndStatic *)c)->indirectee;
1334 case CONSTR_INTLIKE:
1335 case CONSTR_CHARLIKE:
1336 // static objects with no pointers out, so goto loop.
1337 case CONSTR_NOCAF_STATIC:
1338 // It is not just enough not to compute the retainer set for *c; it is
1339 // mandatory because CONSTR_NOCAF_STATIC are not reachable from
1340 // scavenged_static_objects, the list from which is assumed to traverse
1341 // all static objects after major garbage collections.
1345 if (get_itbl(c)->srt_len == 0) {
1346 // No need to compute the retainer set; no dynamic objects
1347 // are reachable from *c.
1349 // Static objects: if we traverse all the live closures,
1350 // including static closures, during each heap census then
1351 // we will observe that some static closures appear and
1352 // disappear. eg. a closure may contain a pointer to a
1353 // static function 'f' which is not otherwise reachable
1354 // (it doesn't indirectly point to any CAFs, so it doesn't
1355 // appear in any SRTs), so we would find 'f' during
1356 // traversal. However on the next sweep there may be no
1357 // closures pointing to 'f'.
1359 // We must therefore ignore static closures whose SRT is
1360 // empty, because these are exactly the closures that may
1361 // "appear". A closure with a non-empty SRT, and which is
1362 // still required, will always be reachable.
1364 // But what about CONSTR_STATIC? Surely these may be able
1365 // to appear, and they don't have SRTs, so we can't
1366 // check. So for now, we're calling
1367 // resetStaticObjectForRetainerProfiling() from the
1368 // garbage collector to reset the retainer sets in all the
1369 // reachable static objects.
1376 // The above objects are ignored in computing the average number of times
1377 // an object is visited.
1378 timesAnyObjectVisited++;
1380 // If this is the first visit to c, initialize its retainer set.
1381 maybeInitRetainerSet(c);
1382 retainerSetOfc = retainerSetOf(c);
1385 // isRetainer(cp) == rtsTrue => s == NULL
1386 // isRetainer(cp) == rtsFalse => s == cp.retainer
1390 s = retainerSetOf(cp);
1392 // (c, cp, r, s) is available.
1394 // (c, cp, r, s, R_r) is available, so compute the retainer set for *c.
1395 if (retainerSetOfc == NULL) {
1396 // This is the first visit to *c.
1400 associate(c, singleton(r));
1402 // s is actually the retainer set of *c!
1405 // compute c_child_r
1406 c_child_r = isRetainer(c) ? getRetainerFrom(c) : r;
1408 // This is not the first visit to *c.
1409 if (isMember(r, retainerSetOfc))
1410 goto loop; // no need to process child
1413 associate(c, addElement(r, retainerSetOfc));
1415 // s is not NULL and cp is not a retainer. This means that
1416 // each time *cp is visited, so is *c. Thus, if s has
1417 // exactly one more element in its retainer set than c, s
1418 // is also the new retainer set for *c.
1419 if (s->num == retainerSetOfc->num + 1) {
1422 // Otherwise, just add R_r to the current retainer set of *c.
1424 associate(c, addElement(r, retainerSetOfc));
1429 goto loop; // no need to process child
1431 // compute c_child_r
1435 // now, RSET() of all of *c, *cp, and *r is valid.
1436 // (c, c_child_r) are available.
1440 if (typeOfc == TSO) {
1441 retainStack(c, c_child_r,
1444 ((StgTSO *)c)->stack + ((StgTSO *)c)->stack_size);
1447 } else if (typeOfc == PAP) {
1448 retainStack(c, c_child_r,
1450 (StgPtr)((StgPAP *)c)->payload,
1451 (StgPtr)((StgPAP *)c)->payload + ((StgPAP *)c)->n_args);
1454 } else if (typeOfc == AP_UPD) {
1455 retainStack(c, c_child_r,
1456 ((StgAP_UPD *)c)->fun,
1457 (StgPtr)((StgAP_UPD *)c)->payload,
1458 (StgPtr)((StgAP_UPD *)c)->payload +
1459 ((StgAP_UPD *)c)->n_args);
1464 push(c, c_child_r, &first_child);
1466 // If first_child is null, c has no child.
1467 // If first_child is not null, the top stack element points to the next
1468 // object. push() may or may not push a stackElement on the stack.
1469 if (first_child == NULL)
1472 // (c, cp, r) = (first_child, c, c_child_r)
1479 /* -----------------------------------------------------------------------------
1480 * Compute the retainer set for every object reachable from *tl.
1481 * -------------------------------------------------------------------------- */
1483 retainRoot( StgClosure **tl )
1485 // We no longer assume that only TSOs and WEAKs are roots; any closure can
1488 ASSERT(isEmptyRetainerStack());
1489 currentStackBoundary = stackTop;
1491 if (isRetainer(*tl)) {
1492 retainClosure(*tl, *tl, getRetainerFrom(*tl));
1494 retainClosure(*tl, *tl, CCS_SYSTEM);
1497 // NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl)));
1498 // *tl might be a TSO which is ThreadComplete, in which
1499 // case we ignore it for the purposes of retainer profiling.
1502 /* -----------------------------------------------------------------------------
1503 * Compute the retainer set for each of the objects in the heap.
1504 * -------------------------------------------------------------------------- */
1506 computeRetainerSet( void )
1512 #ifdef DEBUG_RETAINER
1513 RetainerSet tmpRetainerSet;
1516 GetRoots(retainRoot); // for scheduler roots
1518 // This function is called after a major GC, when key, value, and finalizer
1519 // all are guaranteed to be valid, or reachable.
1521 // The following code assumes that WEAK objects are considered to be roots
1522 // for retainer profilng.
1523 for (weak = weak_ptr_list; weak != NULL; weak = weak->link)
1524 // retainRoot((StgClosure *)weak);
1525 retainRoot((StgClosure **)&weak);
1527 // Consider roots from the stable ptr table.
1528 markStablePtrTable(retainRoot);
1530 // The following code resets the rs field of each unvisited mutable
1531 // object (computing sumOfNewCostExtra and updating costArray[] when
1532 // debugging retainer profiler).
1533 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1535 (generations[g].mut_list == END_MUT_LIST &&
1536 generations[g].mut_once_list == END_MUT_LIST));
1539 // I think traversing through mut_list is unnecessary.
1540 // Think about removing this part.
1541 for (ml = generations[g].mut_list; ml != END_MUT_LIST;
1542 ml = ml->mut_link) {
1544 maybeInitRetainerSet((StgClosure *)ml);
1545 rtl = retainerSetOf((StgClosure *)ml);
1547 #ifdef DEBUG_RETAINER
1549 // first visit to *ml
1550 // This is a violation of the interface rule!
1551 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1553 switch (get_itbl((StgClosure *)ml)->type) {
1557 case CONSTR_INTLIKE:
1558 case CONSTR_CHARLIKE:
1559 case CONSTR_NOCAF_STATIC:
1563 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1567 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1568 sumOfNewCostExtra += cost((StgClosure *)ml);
1575 // Traversing through mut_once_list is, in contrast, necessary
1576 // because we can find MUT_VAR objects which have not been
1577 // visited during retainer profiling.
1578 for (ml = generations[g].mut_once_list; ml != END_MUT_LIST;
1579 ml = ml->mut_link) {
1581 maybeInitRetainerSet((StgClosure *)ml);
1582 rtl = retainerSetOf((StgClosure *)ml);
1583 #ifdef DEBUG_RETAINER
1585 // first visit to *ml
1586 // This is a violation of the interface rule!
1587 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1589 switch (get_itbl((StgClosure *)ml)->type) {
1593 case CONSTR_INTLIKE:
1594 case CONSTR_CHARLIKE:
1595 case CONSTR_NOCAF_STATIC:
1599 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1603 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1604 sumOfNewCostExtra += cost((StgClosure *)ml);
1613 /* -----------------------------------------------------------------------------
1614 * Traverse all static objects for which we compute retainer sets,
1615 * and reset their rs fields to NULL, which is accomplished by
1616 * invoking maybeInitRetainerSet(). This function must be called
1617 * before zeroing all objects reachable from scavenged_static_objects
1618 * in the case of major gabage collections. See GarbageCollect() in
1621 * The mut_once_list of the oldest generation must also be traversed?
1622 * Why? Because if the evacuation of an object pointed to by a static
1623 * indirection object fails, it is put back to the mut_once_list of
1624 * the oldest generation.
1625 * However, this is not necessary because any static indirection objects
1626 * are just traversed through to reach dynamic objects. In other words,
1627 * they are not taken into consideration in computing retainer sets.
1628 * -------------------------------------------------------------------------- */
1630 resetStaticObjectForRetainerProfiling( void )
1632 #ifdef DEBUG_RETAINER
1637 #ifdef DEBUG_RETAINER
1640 p = scavenged_static_objects;
1641 while (p != END_OF_STATIC_LIST) {
1642 #ifdef DEBUG_RETAINER
1645 switch (get_itbl(p)->type) {
1647 // Since we do not compute the retainer set of any
1648 // IND_STATIC object, we don't have to reset its retainer
1650 p = IND_STATIC_LINK(p);
1653 maybeInitRetainerSet(p);
1654 p = THUNK_STATIC_LINK(p);
1657 maybeInitRetainerSet(p);
1658 p = FUN_STATIC_LINK(p);
1661 maybeInitRetainerSet(p);
1662 p = STATIC_LINK(get_itbl(p), p);
1665 barf("resetStaticObjectForRetainerProfiling: %p (%s)",
1666 p, get_itbl(p)->type);
1670 #ifdef DEBUG_RETAINER
1671 // fprintf(stderr, "count in scavenged_static_objects = %d\n", count);
1675 /* -----------------------------------------------------------------------------
1676 * Perform retainer profiling.
1677 * N is the oldest generation being profilied, where the generations are
1678 * numbered starting at 0.
1681 * This function should be called only immediately after major garbage
1683 * ------------------------------------------------------------------------- */
1685 retainerProfile(void)
1687 #ifdef DEBUG_RETAINER
1689 nat totalHeapSize; // total raw heap size (computed by linear scanning)
1692 #ifdef DEBUG_RETAINER
1693 fprintf(stderr, " < retainerProfile() invoked : %d>\n", retainerGeneration);
1698 // We haven't flipped the bit yet.
1699 #ifdef DEBUG_RETAINER
1700 fprintf(stderr, "Before traversing:\n");
1701 sumOfCostLinear = 0;
1702 for (i = 0;i < N_CLOSURE_TYPES; i++)
1703 costArrayLinear[i] = 0;
1704 totalHeapSize = checkHeapSanityForRetainerProfiling();
1706 fprintf(stderr, "\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1708 fprintf(stderr, "costArrayLinear[] = ");
1709 for (i = 0;i < N_CLOSURE_TYPES; i++)
1710 fprintf(stderr, "[%u:%u] ", i, costArrayLinear[i]);
1711 fprintf(stderr, "\n");
1714 ASSERT(sumOfCostLinear == totalHeapSize);
1717 #define pcostArrayLinear(index) \
1718 if (costArrayLinear[index] > 0) \
1719 fprintf(stderr, "costArrayLinear[" #index "] = %u\n", costArrayLinear[index])
1720 pcostArrayLinear(THUNK_STATIC);
1721 pcostArrayLinear(FUN_STATIC);
1722 pcostArrayLinear(CONSTR_STATIC);
1723 pcostArrayLinear(CONSTR_NOCAF_STATIC);
1724 pcostArrayLinear(CONSTR_INTLIKE);
1725 pcostArrayLinear(CONSTR_CHARLIKE);
1729 // Now we flips flip.
1732 #ifdef DEBUG_RETAINER
1738 numObjectVisited = 0;
1739 timesAnyObjectVisited = 0;
1741 #ifdef DEBUG_RETAINER
1742 fprintf(stderr, "During traversing:\n");
1744 sumOfNewCostExtra = 0;
1745 for (i = 0;i < N_CLOSURE_TYPES; i++)
1750 We initialize the traverse stack each time the retainer profiling is
1751 performed (because the traverse stack size varies on each retainer profiling
1752 and this operation is not costly anyhow). However, we just refresh the
1755 initializeTraverseStack();
1756 #ifdef DEBUG_RETAINER
1757 initializeAllRetainerSet();
1759 refreshAllRetainerSet();
1761 computeRetainerSet();
1763 #ifdef DEBUG_RETAINER
1764 fprintf(stderr, "After traversing:\n");
1765 sumOfCostLinear = 0;
1766 for (i = 0;i < N_CLOSURE_TYPES; i++)
1767 costArrayLinear[i] = 0;
1768 totalHeapSize = checkHeapSanityForRetainerProfiling();
1770 fprintf(stderr, "\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1771 ASSERT(sumOfCostLinear == totalHeapSize);
1773 // now, compare the two results
1776 costArray[] must be exactly the same as costArrayLinear[].
1778 1) Dead weak pointers, whose type is CONSTR. These objects are not
1779 reachable from any roots.
1781 fprintf(stderr, "Comparison:\n");
1782 fprintf(stderr, "\tcostArrayLinear[] (must be empty) = ");
1783 for (i = 0;i < N_CLOSURE_TYPES; i++)
1784 if (costArray[i] != costArrayLinear[i])
1785 // nothing should be printed except MUT_VAR after major GCs
1786 fprintf(stderr, "[%u:%u] ", i, costArrayLinear[i]);
1787 fprintf(stderr, "\n");
1789 fprintf(stderr, "\tsumOfNewCost = %u\n", sumOfNewCost);
1790 fprintf(stderr, "\tsumOfNewCostExtra = %u\n", sumOfNewCostExtra);
1791 fprintf(stderr, "\tcostArray[] (must be empty) = ");
1792 for (i = 0;i < N_CLOSURE_TYPES; i++)
1793 if (costArray[i] != costArrayLinear[i])
1794 // nothing should be printed except MUT_VAR after major GCs
1795 fprintf(stderr, "[%u:%u] ", i, costArray[i]);
1796 fprintf(stderr, "\n");
1798 // only for major garbage collection
1799 ASSERT(sumOfNewCost + sumOfNewCostExtra == sumOfCostLinear);
1803 closeTraverseStack();
1804 #ifdef DEBUG_RETAINER
1805 closeAllRetainerSet();
1807 // Note that there is no post-processing for the retainer sets.
1809 retainerGeneration++;
1812 retainerGeneration - 1, // retainerGeneration has just been incremented!
1813 #ifdef DEBUG_RETAINER
1814 maxCStackSize, maxStackSize,
1816 (double)timesAnyObjectVisited / numObjectVisited);
1819 /* -----------------------------------------------------------------------------
1821 * -------------------------------------------------------------------------- */
1823 #ifdef DEBUG_RETAINER
1825 #define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
1826 ((HEAP_ALLOCED(r) && Bdescr((P_)r)->free != (void *)-1))) && \
1827 ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa))
1830 sanityCheckHeapClosure( StgClosure *c )
1834 ASSERT(LOOKS_LIKE_GHC_INFO(c->header.info));
1835 ASSERT(!closure_STATIC(c));
1836 ASSERT(LOOKS_LIKE_PTR(c));
1838 if ((((StgWord)RSET(c) & 1) ^ flip) != 0) {
1839 if (get_itbl(c)->type == CONSTR &&
1840 !strcmp(get_itbl(c)->prof.closure_type, "DEAD_WEAK") &&
1841 !strcmp(get_itbl(c)->prof.closure_desc, "DEAD_WEAK")) {
1842 fprintf(stderr, "\tUnvisited dead weak pointer object found: c = %p\n", c);
1843 costArray[get_itbl(c)->type] += cost(c);
1844 sumOfNewCost += cost(c);
1847 "Unvisited object: flip = %d, c = %p(%d, %s, %s), rs = %p\n",
1848 flip, c, get_itbl(c)->type,
1849 get_itbl(c)->prof.closure_type, get_itbl(c)->prof.closure_desc,
1852 // fprintf(stderr, "sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c));
1856 switch (info->type) {
1858 return tso_sizeW((StgTSO *)c);
1866 return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE);
1869 return sizeofW(StgMVar);
1872 case MUT_ARR_PTRS_FROZEN:
1873 return mut_arr_ptrs_sizeW((StgMutArrPtrs *)c);
1877 return pap_sizeW((StgPAP *)c);
1880 return arr_words_sizeW((StgArrWords *)c);
1900 case SE_CAF_BLACKHOLE:
1904 case IND_OLDGEN_PERM:
1908 return sizeW_fromITBL(info);
1910 case THUNK_SELECTOR:
1911 return sizeofW(StgHeader) + MIN_UPD_SIZE;
1920 case CONSTR_INTLIKE:
1921 case CONSTR_CHARLIKE:
1922 case CONSTR_NOCAF_STATIC:
1940 case INVALID_OBJECT:
1942 barf("Invalid object in sanityCheckHeapClosure(): %d",
1949 heapCheck( bdescr *bd )
1952 static nat costSum, size;
1955 while (bd != NULL) {
1957 while (p < bd->free) {
1958 size = sanityCheckHeapClosure((StgClosure *)p);
1959 sumOfCostLinear += size;
1960 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
1962 // no need for slop check; I think slops are not used currently.
1964 ASSERT(p == bd->free);
1965 costSum += bd->free - bd->start;
1973 smallObjectPoolCheck(void)
1977 static nat costSum, size;
1979 bd = small_alloc_list;
1987 while (p < alloc_Hp) {
1988 size = sanityCheckHeapClosure((StgClosure *)p);
1989 sumOfCostLinear += size;
1990 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
1993 ASSERT(p == alloc_Hp);
1994 costSum += alloc_Hp - bd->start;
1997 while (bd != NULL) {
1999 while (p < bd->free) {
2000 size = sanityCheckHeapClosure((StgClosure *)p);
2001 sumOfCostLinear += size;
2002 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2005 ASSERT(p == bd->free);
2006 costSum += bd->free - bd->start;
2014 chainCheck(bdescr *bd)
2019 while (bd != NULL) {
2020 // bd->free - bd->start is not an accurate measurement of the
2021 // object size. Actually it is always zero, so we compute its
2023 size = sanityCheckHeapClosure((StgClosure *)bd->start);
2024 sumOfCostLinear += size;
2025 costArrayLinear[get_itbl((StgClosure *)bd->start)->type] += size;
2034 checkHeapSanityForRetainerProfiling( void )
2039 fprintf(stderr, "START: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2040 if (RtsFlags.GcFlags.generations == 1) {
2041 costSum += heapCheck(g0s0->to_blocks);
2042 fprintf(stderr, "heapCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2043 costSum += chainCheck(g0s0->large_objects);
2044 fprintf(stderr, "chainCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2046 for (g = 0; g < RtsFlags.GcFlags.generations; g++)
2047 for (s = 0; s < generations[g].n_steps; s++) {
2049 After all live objects have been scavenged, the garbage
2050 collector may create some objects in
2051 scheduleFinalizers(). These objects are created throught
2052 allocate(), so the small object pool or the large object
2053 pool of the g0s0 may not be empty.
2055 if (g == 0 && s == 0) {
2056 costSum += smallObjectPoolCheck();
2057 fprintf(stderr, "smallObjectPoolCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2058 costSum += chainCheck(generations[g].steps[s].large_objects);
2059 fprintf(stderr, "chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2061 costSum += heapCheck(generations[g].steps[s].blocks);
2062 fprintf(stderr, "heapCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2063 costSum += chainCheck(generations[g].steps[s].large_objects);
2064 fprintf(stderr, "chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2073 findPointer(StgPtr p)
2079 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2080 for (s = 0; s < generations[g].n_steps; s++) {
2081 // if (g == 0 && s == 0) continue;
2082 bd = generations[g].steps[s].blocks;
2083 for (; bd; bd = bd->link) {
2084 for (q = bd->start; q < bd->free; q++) {
2085 if (*q == (StgWord)p) {
2087 while (!LOOKS_LIKE_GHC_INFO(*r)) r--;
2088 fprintf(stderr, "Found in gen[%d], step[%d]: q = %p, r = %p\n", g, s, q, r);
2093 bd = generations[g].steps[s].large_objects;
2094 for (; bd; bd = bd->link) {
2095 e = bd->start + cost((StgClosure *)bd->start);
2096 for (q = bd->start; q < e; q++) {
2097 if (*q == (StgWord)p) {
2099 while (*r == 0 || !LOOKS_LIKE_GHC_INFO(*r)) r--;
2100 fprintf(stderr, "Found in gen[%d], large_objects: %p\n", g, r);
2110 belongToHeap(StgPtr p)
2115 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2116 for (s = 0; s < generations[g].n_steps; s++) {
2117 // if (g == 0 && s == 0) continue;
2118 bd = generations[g].steps[s].blocks;
2119 for (; bd; bd = bd->link) {
2120 if (bd->start <= p && p < bd->free) {
2121 fprintf(stderr, "Belongs to gen[%d], step[%d]", g, s);
2125 bd = generations[g].steps[s].large_objects;
2126 for (; bd; bd = bd->link) {
2127 if (bd->start <= p && p < bd->start + getHeapClosureSize((StgClosure *)bd->start)) {
2128 fprintf(stderr, "Found in gen[%d], large_objects: %p\n", g, bd->start);
2135 #endif // DEBUG_RETAINER
2137 #endif /* PROFILING */