1 /* -----------------------------------------------------------------------------
2 * $Id: RetainerProfile.c,v 1.3 2001/12/12 14:25:03 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 if (get_itbl(c)->prof.closure_desc != NULL && !strcmp(get_itbl(c)->prof.closure_desc,"PCS")) { return rtsTrue; }
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 */