1 /* -----------------------------------------------------------------------------
2 * $Id: RetainerProfile.c,v 1.2 2001/11/26 16:54:21 simonmar Exp $
4 * (c) The GHC Team, 2001
9 * ---------------------------------------------------------------------------*/
15 #include "RetainerProfile.h"
16 #include "RetainerSet.h"
20 #include "StoragePriv.h"
24 #include "Profiling.h"
26 #include "BlockAlloc.h"
28 #include "Proftimer.h"
32 Note: what to change in order to plug-in a new retainer profiling scheme?
33 (1) type retainer in ../includes/StgRetainerProf.h
34 (2) retainer function R(), i.e., getRetainerFrom()
35 (3) the two hashing functions, hashKeySingleton() and hashKeyAddElement(),
36 in RetainerSet.h, if needed.
37 (4) printRetainer() and printRetainerSetShort() in RetainerSet.c.
40 /* -----------------------------------------------------------------------------
42 * -------------------------------------------------------------------------- */
44 static nat retainerGeneration; // generation
46 static nat numObjectVisited; // total number of objects visited
47 static nat timesAnyObjectVisited; // number of times any objects are visited
50 The rs field in the profile header of any object points to its retainer
51 set in an indirect way: if flip is 0, it points to the retainer set;
52 if flip is 1, it points to the next byte after the retainer set (even
53 for NULL pointers). Therefore, with flip 1, (rs ^ 1) is the actual
54 pointer. See retainerSetOf().
57 StgWord flip = 0; // flip bit
58 // must be 0 if DEBUG_RETAINER is on (for static closures)
60 #define setRetainerSetToNull(c) \
61 (c)->header.prof.hp.rs = (RetainerSet *)((StgWord)NULL | flip)
63 static void retainStack(StgClosure *, StgClosure *, StgClosure *, StgPtr, StgPtr);
64 static void retainClosure(StgClosure *, StgClosure *, StgClosure *);
66 static void belongToHeap(StgPtr p);
71 cStackSize records how many times retainStack() has been invoked recursively,
72 that is, the number of activation records for retainStack() on the C stack.
73 maxCStackSize records its max value.
75 cStackSize <= maxCStackSize
77 static nat cStackSize, maxCStackSize;
79 static nat sumOfNewCost; // sum of the cost of each object, computed
80 // when the object is first visited
81 static nat sumOfNewCostExtra; // for those objects not visited during
82 // retainer profiling, e.g., MUT_VAR
83 static nat costArray[N_CLOSURE_TYPES];
85 nat sumOfCostLinear; // sum of the costs of all object, computed
86 // when linearly traversing the heap after
88 nat costArrayLinear[N_CLOSURE_TYPES];
91 /* -----------------------------------------------------------------------------
92 * Retainer stack - header
94 * Although the retainer stack implementation could be separated *
95 * from the retainer profiling engine, there does not seem to be
96 * any advantage in doing that; retainer stack is an integral part
97 * of retainer profiling engine and cannot be use elsewhere at
99 * -------------------------------------------------------------------------- */
108 // fixed layout or layout specified by a field in the closure
113 // See StgClosureInfo in InfoTables.h
114 #if SIZEOF_VOID_P == 8
127 StgClosure **srt_end;
138 StgClosure *c_child_r;
144 firstStack points to the first block group.
145 currentStack points to the block group currently being used.
146 currentStack->free == stackLimit.
147 stackTop points to the topmost byte in the stack of currentStack.
148 Unless the whole stack is empty, stackTop must point to the topmost
149 object (or byte) in the whole stack. Thus, it is only when the whole stack
150 is empty that stackTop == stackLimit (not during the execution of push()
152 stackBottom == currentStack->start.
153 stackLimit == currentStack->start + BLOCK_SIZE_W * currentStack->blocks.
155 When a current stack becomes empty, stackTop is set to point to
156 the topmost element on the previous block group so as to satisfy
157 the invariants described above.
159 bdescr *firstStack = NULL;
160 static bdescr *currentStack;
161 static stackElement *stackBottom, *stackTop, *stackLimit;
164 currentStackBoundary is used to mark the current stack chunk.
165 If stackTop == currentStackBoundary, it means that the current stack chunk
166 is empty. It is the responsibility of the user to keep currentStackBoundary
167 valid all the time if it is to be employed.
169 static stackElement *currentStackBoundary;
172 stackSize records the current size of the stack.
173 maxStackSize records its high water mark.
175 stackSize <= maxStackSize
177 stackSize is just an estimate measure of the depth of the graph. The reason
178 is that some heap objects have only a single child and may not result
179 in a new element being pushed onto the stack. Therefore, at the end of
180 retainer profiling, maxStackSize + maxCStackSize is some value no greater
181 than the actual depth of the graph.
183 #ifdef DEBUG_RETAINER
184 static int stackSize, maxStackSize;
187 // number of blocks allocated for one stack
188 #define BLOCKS_IN_STACK 1
190 /* -----------------------------------------------------------------------------
191 * Add a new block group to the stack.
193 * currentStack->link == s.
194 * -------------------------------------------------------------------------- */
196 newStackBlock( bdescr *bd )
199 stackTop = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
200 stackBottom = (stackElement *)bd->start;
201 stackLimit = (stackElement *)stackTop;
202 bd->free = (StgPtr)stackLimit;
205 /* -----------------------------------------------------------------------------
206 * Return to the previous block group.
208 * s->link == currentStack.
209 * -------------------------------------------------------------------------- */
211 returnToOldStack( bdescr *bd )
214 stackTop = (stackElement *)bd->free;
215 stackBottom = (stackElement *)bd->start;
216 stackLimit = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
217 bd->free = (StgPtr)stackLimit;
220 /* -----------------------------------------------------------------------------
221 * Initializes the traverse stack.
222 * -------------------------------------------------------------------------- */
224 initializeTraverseStack( void )
226 if (firstStack != NULL) {
227 freeChain(firstStack);
230 firstStack = allocGroup(BLOCKS_IN_STACK);
231 firstStack->link = NULL;
232 firstStack->u.back = NULL;
234 newStackBlock(firstStack);
237 /* -----------------------------------------------------------------------------
238 * Frees all the block groups in the traverse stack.
241 * -------------------------------------------------------------------------- */
243 closeTraverseStack( void )
245 freeChain(firstStack);
249 /* -----------------------------------------------------------------------------
250 * Returns rtsTrue if the whole stack is empty.
251 * -------------------------------------------------------------------------- */
252 static inline rtsBool
253 isEmptyRetainerStack( void )
255 return (firstStack == currentStack) && stackTop == stackLimit;
258 /* -----------------------------------------------------------------------------
259 * Returns rtsTrue if stackTop is at the stack boundary of the current stack,
260 * i.e., if the current stack chunk is empty.
261 * -------------------------------------------------------------------------- */
262 static inline rtsBool
265 return stackTop == currentStackBoundary;
268 /* -----------------------------------------------------------------------------
269 * Initializes *info from ptrs and payload.
271 * payload[] begins with ptrs pointers followed by non-pointers.
272 * -------------------------------------------------------------------------- */
274 init_ptrs( stackPos *info, nat ptrs, StgPtr payload )
276 info->type = posTypePtrs;
277 info->next.ptrs.pos = 0;
278 info->next.ptrs.ptrs = ptrs;
279 info->next.ptrs.payload = payload;
282 /* -----------------------------------------------------------------------------
283 * Find the next object from *info.
284 * -------------------------------------------------------------------------- */
285 static inline StgClosure *
286 find_ptrs( stackPos *info )
288 if (info->next.ptrs.pos < info->next.ptrs.ptrs) {
289 return (StgClosure *)info->next.ptrs.payload[info->next.ptrs.pos++];
295 /* -----------------------------------------------------------------------------
296 * Initializes *info from SRT information stored in *infoTable.
297 * -------------------------------------------------------------------------- */
299 init_srt( stackPos *info, StgInfoTable *infoTable )
301 info->type = posTypeSRT;
302 info->next.srt.srt = (StgClosure **)(infoTable->srt);
303 info->next.srt.srt_end = info->next.srt.srt + infoTable->srt_len;
306 /* -----------------------------------------------------------------------------
307 * Find the next object from *info.
308 * -------------------------------------------------------------------------- */
309 static inline StgClosure *
310 find_srt( stackPos *info )
314 if (info->next.srt.srt < info->next.srt.srt_end) {
315 // See scavenge_srt() in GC.c for details.
316 #ifdef ENABLE_WIN32_DLL_SUPPORT
317 if ((unsigned long)(*(info->next.srt.srt)) & 0x1)
318 c = (* (StgClosure **)((unsigned long)*(info->next.srt.srt)) & ~0x1);
320 c = *(info->next.srt.srt);
322 c = *(info->next.srt.srt);
324 info->next.srt.srt++;
331 /* -----------------------------------------------------------------------------
332 * push() pushes a stackElement representing the next child of *c
333 * onto the traverse stack. If *c has no child, *first_child is set
334 * to NULL and nothing is pushed onto the stack. If *c has only one
335 * child, *c_chlid is set to that child and nothing is pushed onto
336 * the stack. If *c has more than two children, *first_child is set
337 * to the first child and a stackElement representing the second
338 * child is pushed onto the stack.
341 * *c_child_r is the most recent retainer of *c's children.
342 * *c is not any of TSO, PAP, or AP_UPD, which means that
343 * there cannot be any stack objects.
344 * Note: SRTs are considered to be children as well.
345 * -------------------------------------------------------------------------- */
347 push( StgClosure *c, StgClosure *c_child_r, StgClosure **first_child )
350 bdescr *nbd; // Next Block Descriptor
352 #ifdef DEBUG_RETAINER
353 // fprintf(stderr, "push(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
356 ASSERT(get_itbl(c)->type != TSO);
357 ASSERT(get_itbl(c)->type != PAP);
358 ASSERT(get_itbl(c)->type != AP_UPD);
365 se.c_child_r = c_child_r;
368 switch (get_itbl(c)->type) {
375 case SE_CAF_BLACKHOLE:
380 // one child (fixed), no SRT
383 *first_child = ((StgMutVar *)c)->var;
386 // blocking_queue must be TSO and the head of a linked list of TSOs.
387 // Shoule it be a child? Seems to be yes.
388 *first_child = (StgClosure *)((StgBlockingQueue *)c)->blocking_queue;
391 *first_child = ((StgSelector *)c)->selectee;
394 case IND_OLDGEN_PERM:
396 *first_child = ((StgIndOldGen *)c)->indirectee;
400 *first_child = c->payload[0];
403 // For CONSTR_2_0 and MVAR, we use se.info.step to record the position
404 // of the next child. We do not write a separate initialization code.
405 // Also we do not have to initialize info.type;
407 // two children (fixed), no SRT
408 // need to push a stackElement, but nothing to store in se.info
410 *first_child = c->payload[0]; // return the first pointer
411 // se.info.type = posTypeStep;
412 // se.info.next.step = 2; // 2 = second
415 // three children (fixed), no SRT
416 // need to push a stackElement
418 // head must be TSO and the head of a linked list of TSOs.
419 // Shoule it be a child? Seems to be yes.
420 *first_child = (StgClosure *)((StgMVar *)c)->head;
421 // se.info.type = posTypeStep;
422 se.info.next.step = 2; // 2 = second
425 // three children (fixed), no SRT
427 *first_child = ((StgWeak *)c)->key;
428 // se.info.type = posTypeStep;
429 se.info.next.step = 2;
432 // layout.payload.ptrs, no SRT
438 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
440 *first_child = find_ptrs(&se.info);
441 if (*first_child == NULL)
445 // StgMutArrPtr.ptrs, no SRT
447 case MUT_ARR_PTRS_FROZEN:
448 init_ptrs(&se.info, ((StgMutArrPtrs *)c)->ptrs,
449 (StgPtr)(((StgMutArrPtrs *)c)->payload));
450 *first_child = find_ptrs(&se.info);
451 if (*first_child == NULL)
455 // layout.payload.ptrs, SRT
456 case FUN: // *c is a heap object.
460 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
461 *first_child = find_ptrs(&se.info);
462 if (*first_child == NULL)
463 // no child from ptrs, so check SRT
467 // 1 fixed child, SRT
472 *first_child = c->payload[0];
473 ASSERT(*first_child != NULL);
474 init_srt(&se.info, get_itbl(c));
479 case FUN_STATIC: // *c is a heap object.
480 ASSERT(get_itbl(c)->srt_len != 0);
486 init_srt(&se.info, get_itbl(c));
487 *first_child = find_srt(&se.info);
488 if (*first_child == NULL)
498 case CONSTR_CHARLIKE:
499 case CONSTR_NOCAF_STATIC:
521 barf("Invalid object *c in push()");
525 if (stackTop - 1 < stackBottom) {
526 #ifdef DEBUG_RETAINER
527 // fprintf(stderr, "push() to the next stack.\n");
529 // currentStack->free is updated when the active stack is switched
530 // to the next stack.
531 currentStack->free = (StgPtr)stackTop;
533 if (currentStack->link == NULL) {
534 nbd = allocGroup(BLOCKS_IN_STACK);
536 nbd->u.back = currentStack;
537 currentStack->link = nbd;
539 nbd = currentStack->link;
544 // adjust stackTop (acutal push)
546 // If the size of stackElement was huge, we would better replace the
547 // following statement by either a memcpy() call or a switch statement
548 // on the type of the element. Currently, the size of stackElement is
549 // small enough (5 words) that this direct assignment seems to be enough.
552 #ifdef DEBUG_RETAINER
554 if (stackSize > maxStackSize) maxStackSize = stackSize;
555 // ASSERT(stackSize >= 0);
556 // fprintf(stderr, "stackSize = %d\n", stackSize);
560 /* -----------------------------------------------------------------------------
561 * popOff() and popOffReal(): Pop a stackElement off the traverse stack.
563 * stackTop cannot be equal to stackLimit unless the whole stack is
564 * empty, in which case popOff() is not allowed.
566 * You can think of popOffReal() as a part of popOff() which is
567 * executed at the end of popOff() in necessary. Since popOff() is
568 * likely to be executed quite often while popOffReal() is not, we
569 * separate popOffReal() from popOff(), which is declared as an
570 * inline function (for the sake of execution speed). popOffReal()
571 * is called only within popOff() and nowhere else.
572 * -------------------------------------------------------------------------- */
576 bdescr *pbd; // Previous Block Descriptor
578 #ifdef DEBUG_RETAINER
579 // fprintf(stderr, "pop() to the previous stack.\n");
582 ASSERT(stackTop + 1 == stackLimit);
583 ASSERT(stackBottom == (stackElement *)currentStack->start);
585 if (firstStack == currentStack) {
586 // The stack is completely empty.
588 ASSERT(stackTop == stackLimit);
589 #ifdef DEBUG_RETAINER
591 if (stackSize > maxStackSize) maxStackSize = stackSize;
593 ASSERT(stackSize >= 0);
594 fprintf(stderr, "stackSize = %d\n", stackSize);
600 // currentStack->free is updated when the active stack is switched back
601 // to the previous stack.
602 currentStack->free = (StgPtr)stackLimit;
604 // find the previous block descriptor
605 pbd = currentStack->u.back;
608 returnToOldStack(pbd);
610 #ifdef DEBUG_RETAINER
612 if (stackSize > maxStackSize) maxStackSize = stackSize;
614 ASSERT(stackSize >= 0);
615 fprintf(stderr, "stackSize = %d\n", stackSize);
622 #ifdef DEBUG_RETAINER
623 // fprintf(stderr, "\tpopOff(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
626 ASSERT(stackTop != stackLimit);
627 ASSERT(!isEmptyRetainerStack());
629 // <= (instead of <) is wrong!
630 if (stackTop + 1 < stackLimit) {
632 #ifdef DEBUG_RETAINER
634 if (stackSize > maxStackSize) maxStackSize = stackSize;
636 ASSERT(stackSize >= 0);
637 fprintf(stderr, "stackSize = %d\n", stackSize);
646 /* -----------------------------------------------------------------------------
647 * Finds the next object to be considered for retainer profiling and store
649 * Test if the topmost stack element indicates that more objects are left,
650 * and if so, retrieve the first object and store its pointer to *c. Also,
651 * set *cp and *r appropriately, both of which are stored in the stack element.
652 * The topmost stack element then is overwritten so as for it to now denote
654 * If the topmost stack element indicates no more objects are left, pop
655 * off the stack element until either an object can be retrieved or
656 * the current stack chunk becomes empty, indicated by rtsTrue returned by
657 * isOnBoundary(), in which case *c is set to NULL.
659 * It is okay to call this function even when the current stack chunk
661 * -------------------------------------------------------------------------- */
663 pop( StgClosure **c, StgClosure **cp, StgClosure **r )
667 #ifdef DEBUG_RETAINER
668 // fprintf(stderr, "pop(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
672 if (isOnBoundary()) { // if the current stack chunk is depleted
679 switch (get_itbl(se->c)->type) {
680 // two children (fixed), no SRT
681 // nothing in se.info
683 *c = se->c->payload[1];
689 // three children (fixed), no SRT
690 // need to push a stackElement
692 if (se->info.next.step == 2) {
693 *c = (StgClosure *)((StgMVar *)se->c)->tail;
694 se->info.next.step++; // move to the next step
697 *c = ((StgMVar *)se->c)->value;
704 // three children (fixed), no SRT
706 if (se->info.next.step == 2) {
707 *c = ((StgWeak *)se->c)->value;
708 se->info.next.step++;
711 *c = ((StgWeak *)se->c)->finalizer;
723 // StgMutArrPtr.ptrs, no SRT
725 case MUT_ARR_PTRS_FROZEN:
726 *c = find_ptrs(&se->info);
735 // layout.payload.ptrs, SRT
736 case FUN: // always a heap object
740 if (se->info.type == posTypePtrs) {
741 *c = find_ptrs(&se->info);
747 init_srt(&se->info, get_itbl(se->c));
762 *c = find_srt(&se->info);
771 // no child (fixed), no SRT
777 case SE_CAF_BLACKHOLE:
779 // one child (fixed), no SRT
785 case IND_OLDGEN_PERM:
794 case CONSTR_CHARLIKE:
795 case CONSTR_NOCAF_STATIC:
817 barf("Invalid object *c in pop()");
823 /* -----------------------------------------------------------------------------
824 * RETAINER PROFILING ENGINE
825 * -------------------------------------------------------------------------- */
828 initRetainerProfiling( void )
830 initializeAllRetainerSet();
831 retainerGeneration = 0;
834 /* -----------------------------------------------------------------------------
835 * This function must be called before f-closing prof_file.
836 * -------------------------------------------------------------------------- */
838 endRetainerProfiling( void )
840 #ifdef SECOND_APPROACH
841 outputAllRetainerSet(prof_file);
845 /* -----------------------------------------------------------------------------
846 * Returns the actual pointer to the retainer set of the closure *c.
847 * It may adjust RSET(c) subject to flip.
849 * RSET(c) is initialized to NULL if its current value does not
852 * Even though this function has side effects, they CAN be ignored because
853 * subsequent calls to retainerSetOf() always result in the same return value
854 * and retainerSetOf() is the only way to retrieve retainerSet of a given
856 * We have to perform an XOR (^) operation each time a closure is examined.
857 * The reason is that we do not know when a closure is visited last.
858 * -------------------------------------------------------------------------- */
860 maybeInitRetainerSet( StgClosure *c )
862 if (!isRetainerSetFieldValid(c)) {
863 setRetainerSetToNull(c);
867 /* -----------------------------------------------------------------------------
868 * Returns rtsTrue if *c is a retainer.
869 * -------------------------------------------------------------------------- */
870 static inline rtsBool
871 isRetainer( StgClosure *c )
873 if (get_itbl(c)->prof.closure_desc != NULL && !strcmp(get_itbl(c)->prof.closure_desc,"PCS")) { return rtsTrue; }
875 switch (get_itbl(c)->type) {
879 // TSOs MUST be retainers: they constitute the set of roots.
887 case MUT_ARR_PTRS_FROZEN:
889 // thunks are retainers.
899 // Static thunks, or CAFS, are obviously retainers.
902 // WEAK objects are roots; there is separate code in which traversing
903 // begins from WEAK objects.
925 // partial applications
931 case SE_CAF_BLACKHOLE:
935 case IND_OLDGEN_PERM:
950 // IND_STATIC cannot be *c, *cp, *r in the retainer profiling loop.
952 // CONSTR_INTLIKE, CONSTR_CHARLIKE, and CONSTR_NOCAF_STATIC
953 // cannot be *c, *cp, *r in the retainer profiling loop.
955 case CONSTR_CHARLIKE:
956 case CONSTR_NOCAF_STATIC:
957 // Stack objects are invalid because they are never treated as
958 // legal objects during retainer profiling.
979 barf("Invalid object in isRetainer(): %d", get_itbl(c)->type);
984 /* -----------------------------------------------------------------------------
985 * Returns the retainer function value for the closure *c, i.e., R(*c).
986 * This function does NOT return the retainer(s) of *c.
988 * *c must be a retainer.
990 * Depending on the definition of this function, the maintenance of retainer
991 * sets can be made easier. If most retainer sets are likely to be created
992 * again across garbage collections, refreshAllRetainerSet() in
993 * RetainerSet.c can simply do nothing.
994 * If this is not the case, we can free all the retainer sets and
995 * re-initialize the hash table.
996 * See refreshAllRetainerSet() in RetainerSet.c.
997 * -------------------------------------------------------------------------- */
998 static inline retainer
999 getRetainerFrom( StgClosure *c )
1001 ASSERT(isRetainer(c));
1003 #if defined(RETAINER_SCHEME_INFO)
1004 // Retainer scheme 1: retainer = info table
1006 #elif defined(RETAINER_SCHEME_CCS)
1007 // Retainer scheme 2: retainer = cost centre stack
1008 return c->header.prof.ccs;
1009 #elif defined(RETAINER_SCHEME_CC)
1010 // Retainer scheme 3: retainer = cost centre
1011 return c->header.prof.ccs->cc;
1015 /* -----------------------------------------------------------------------------
1016 * Associates the retainer set *s with the closure *c, that is, *s becomes
1017 * the retainer set of *c.
1021 * -------------------------------------------------------------------------- */
1023 associate( StgClosure *c, RetainerSet *s )
1025 // StgWord has the same size as pointers, so the following type
1027 RSET(c) = (RetainerSet *)((StgWord)s | flip);
1030 /* -----------------------------------------------------------------------------
1031 * Process all the objects in the stack chunk from stackStart to stackEnd
1032 * with *c and *c_child_r being their parent and their most recent retainer,
1033 * respectively. Treat stackOptionalFun as another child of *c if it is
1036 * *c is one of the following: TSO, PAP, and AP_UPD.
1037 * If *c is AP_UPD or PAP, stackOptionalFun is not NULL. Otherwise,
1039 * If *c is TSO, c == c_child_r.
1040 * stackStart < stackEnd.
1041 * RSET(c) and RSET(c_child_r) are valid, i.e., their
1042 * interpretation conforms to the current value of flip (even when they
1043 * are interpreted to be NULL).
1044 * If *c is TSO, its state is not any of ThreadRelocated, ThreadComplete,
1045 * or ThreadKilled, which means that its stack is ready to process.
1047 * This code was almost plagiarzied from GC.c! For each pointer,
1048 * retainClosure() is invoked instead of evacuate().
1049 * -------------------------------------------------------------------------- */
1051 retainStack( StgClosure *c, StgClosure *c_child_r,
1052 StgClosure *stackOptionalFun, StgPtr stackStart,
1055 stackElement *oldStackBoundary;
1060 #ifdef DEBUG_RETAINER
1062 if (cStackSize > maxCStackSize) maxCStackSize = cStackSize;
1066 Each invocation of retainStack() creates a new virtual
1067 stack. Since all such stacks share a single common stack, we
1068 record the current currentStackBoundary, which will be restored
1071 oldStackBoundary = currentStackBoundary;
1072 currentStackBoundary = stackTop;
1074 #ifdef DEBUG_RETAINER
1075 // fprintf(stderr, "retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
1078 if (stackOptionalFun != NULL) {
1079 ASSERT(get_itbl(c)->type == AP_UPD || get_itbl(c)->type == PAP);
1080 retainClosure(stackOptionalFun, c, c_child_r);
1082 ASSERT(get_itbl(c)->type == TSO);
1083 ASSERT(((StgTSO *)c)->what_next != ThreadRelocated &&
1084 ((StgTSO *)c)->what_next != ThreadComplete &&
1085 ((StgTSO *)c)->what_next != ThreadKilled);
1089 while (p < stackEnd) {
1094 // The correctness of retainer profiling is subject to the
1095 // correctness of the two macros IS_ARG_TAG() and
1096 // LOOKS_LIKE_GHC_INFO(). Since LOOKS_LIKE_GHC_INFO() is a bit
1097 // precarious macro, so I believe that the current
1098 // implementation may not be quite safe. Also, scavenge_stack()
1099 // in GC.c also exploits this macro in order to identify shallow
1100 // pointers. I am not sure whether scavenge_stack() takes
1101 // further measurements to discern real shallow pointers.
1103 // I think this can be a serious problem if a stack chunk
1104 // contains some word which looks like a pointer but is
1105 // actually, say, a word constituting a floating number.
1108 // skip tagged words
1109 if (IS_ARG_TAG((StgWord)q)) {
1110 p += 1 + ARG_SIZE(q);
1114 // check if *p is a shallow closure pointer
1115 if (!LOOKS_LIKE_GHC_INFO(q)) {
1116 retainClosure((StgClosure *)q, c, c_child_r);
1121 // regular stack objects
1122 info = get_itbl((StgClosure *)p);
1123 switch(info->type) {
1125 bitmap = ((StgRetDyn *)p)->liveness;
1126 p = ((StgRetDyn *)p)->payload;
1129 // FUN and FUN_STATIC keep only their info pointer.
1136 retainClosure(((StgUpdateFrame *)p)->updatee, c, c_child_r);
1137 p += sizeofW(StgUpdateFrame);
1146 bitmap = info->layout.bitmap;
1149 while (bitmap != 0) {
1150 if ((bitmap & 1) == 0)
1151 retainClosure((StgClosure *)*p, c, c_child_r);
1153 bitmap = bitmap >> 1;
1157 StgClosure **srt, **srt_end;
1159 srt = (StgClosure **)(info->srt);
1160 srt_end = srt + info->srt_len;
1161 for (; srt < srt_end; srt++) {
1162 // See scavenge_srt() in GC.c for details.
1163 #ifdef ENABLE_WIN32_DLL_SUPPORT
1164 if ((unsigned long)(*srt) & 0x1)
1165 retainClosure(*(StgClosure **)(((unsigned long)*srt & ~0x1)), c, c_child_r);
1167 retainClosure(*srt, c, c_child_r);
1169 retainClosure(*srt, c, c_child_r);
1179 StgLargeBitmap *large_bitmap;
1182 large_bitmap = info->layout.large_bitmap;
1185 for (i = 0; i < large_bitmap->size; i++) {
1186 bitmap = large_bitmap->bitmap[i];
1187 q = p + sizeofW(StgWord) * 8;
1188 while (bitmap != 0) {
1189 if ((bitmap & 1) == 0)
1190 retainClosure((StgClosure *)*p, c, c_child_r);
1192 bitmap = bitmap >> 1;
1194 if (i + 1 < large_bitmap->size) {
1196 retainClosure((StgClosure *)*p, c, c_child_r);
1204 barf("Invalid object found in retainStack(): %d",
1209 // restore currentStackBoundary
1210 currentStackBoundary = oldStackBoundary;
1211 #ifdef DEBUG_RETAINER
1212 // fprintf(stderr, "retainStack() finished: currentStackBoundary = 0x%x\n", currentStackBoundary);
1215 #ifdef DEBUG_RETAINER
1220 /* -----------------------------------------------------------------------------
1221 * Compute the retainer set of *c0 and all its desecents by traversing.
1222 * *cp0 is the parent of *c0, and *r0 is the most recent retainer of *c0.
1224 * c0 = cp0 = r0 holds only for root objects.
1225 * RSET(cp0) and RSET(r0) are valid, i.e., their
1226 * interpretation conforms to the current value of flip (even when they
1227 * are interpreted to be NULL).
1228 * However, RSET(c0) may be corrupt, i.e., it may not conform to
1229 * the current value of flip. If it does not, during the execution
1230 * of this function, RSET(c0) must be initialized as well as all
1233 * stackTop must be the same at the beginning and the exit of this function.
1234 * *c0 can be TSO (as well as PAP and AP_UPD).
1235 * -------------------------------------------------------------------------- */
1237 retainClosure( StgClosure *c0, StgClosure *cp0, StgClosure *r0 )
1239 // c = Current closure
1240 // cp = Current closure's Parent
1241 // r = current closures' most recent Retainer
1242 // c_child_r = current closure's children's most recent retainer
1243 // first_child = first child of c
1244 StgClosure *c, *cp, *r, *c_child_r, *first_child;
1245 RetainerSet *s, *retainerSetOfc;
1249 #ifdef DEBUG_RETAINER
1250 // StgPtr oldStackTop;
1253 #ifdef DEBUG_RETAINER
1254 // oldStackTop = stackTop;
1255 // fprintf(stderr, "retainClosure() called: c0 = 0x%x, cp0 = 0x%x, r0 = 0x%x\n", c0, cp0, r0);
1258 // (c, cp, r) = (c0, cp0, r0)
1265 //fprintf(stderr, "loop");
1266 // pop to (c, cp, r);
1270 #ifdef DEBUG_RETAINER
1271 // fprintf(stderr, "retainClosure() ends: oldStackTop = 0x%x, stackTop = 0x%x\n", oldStackTop, stackTop);
1276 //fprintf(stderr, "inner_loop");
1279 // c = current closure under consideration,
1280 // cp = current closure's parent,
1281 // r = current closure's most recent retainer
1283 // Loop invariants (on the meaning of c, cp, r, and their retainer sets):
1284 // RSET(cp) and RSET(r) are valid.
1285 // RSET(c) is valid only if c has been visited before.
1287 // Loop invariants (on the relation between c, cp, and r)
1288 // if cp is not a retainer, r belongs to RSET(cp).
1289 // if cp is a retainer, r == cp.
1291 typeOfc = get_itbl(c)->type;
1293 #ifdef DEBUG_RETAINER
1296 case CONSTR_INTLIKE:
1297 case CONSTR_CHARLIKE:
1298 case CONSTR_NOCAF_STATIC:
1304 if (retainerSetOf(c) == NULL) { // first visit?
1305 costArray[typeOfc] += cost(c);
1306 sumOfNewCost += cost(c);
1315 if (((StgTSO *)c)->what_next == ThreadComplete ||
1316 ((StgTSO *)c)->what_next == ThreadKilled) {
1317 #ifdef DEBUG_RETAINER
1318 fprintf(stderr, "ThreadComplete or ThreadKilled encountered in retainClosure()\n");
1322 if (((StgTSO *)c)->what_next == ThreadRelocated) {
1323 #ifdef DEBUG_RETAINER
1324 fprintf(stderr, "ThreadRelocated encountered in retainClosure()\n");
1326 c = (StgClosure *)((StgTSO *)c)->link;
1332 // We just skip IND_STATIC, so its retainer set is never computed.
1333 c = ((StgIndStatic *)c)->indirectee;
1335 case CONSTR_INTLIKE:
1336 case CONSTR_CHARLIKE:
1337 // static objects with no pointers out, so goto loop.
1338 case CONSTR_NOCAF_STATIC:
1339 // It is not just enough not to compute the retainer set for *c; it is
1340 // mandatory because CONSTR_NOCAF_STATIC are not reachable from
1341 // scavenged_static_objects, the list from which is assumed to traverse
1342 // all static objects after major garbage collections.
1346 if (get_itbl(c)->srt_len == 0) {
1347 // No need to compute the retainer set; no dynamic objects
1348 // are reachable from *c.
1350 // Static objects: if we traverse all the live closures,
1351 // including static closures, during each heap census then
1352 // we will observe that some static closures appear and
1353 // disappear. eg. a closure may contain a pointer to a
1354 // static function 'f' which is not otherwise reachable
1355 // (it doesn't indirectly point to any CAFs, so it doesn't
1356 // appear in any SRTs), so we would find 'f' during
1357 // traversal. However on the next sweep there may be no
1358 // closures pointing to 'f'.
1360 // We must therefore ignore static closures whose SRT is
1361 // empty, because these are exactly the closures that may
1362 // "appear". A closure with a non-empty SRT, and which is
1363 // still required, will always be reachable.
1365 // But what about CONSTR_STATIC? Surely these may be able
1366 // to appear, and they don't have SRTs, so we can't
1367 // check. So for now, we're calling
1368 // resetStaticObjectForRetainerProfiling() from the
1369 // garbage collector to reset the retainer sets in all the
1370 // reachable static objects.
1377 // The above objects are ignored in computing the average number of times
1378 // an object is visited.
1379 timesAnyObjectVisited++;
1381 // If this is the first visit to c, initialize its retainer set.
1382 maybeInitRetainerSet(c);
1383 retainerSetOfc = retainerSetOf(c);
1386 // isRetainer(cp) == rtsTrue => s == NULL
1387 // isRetainer(cp) == rtsFalse => s == cp.retainer
1391 s = retainerSetOf(cp);
1393 // (c, cp, r, s) is available.
1394 R_r = getRetainerFrom(r);
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_r));
1404 // s is actually the retainer set of *c!
1407 // compute c_child_r
1408 c_child_r = isRetainer(c) ? c : r;
1410 // This is not the first visit to *c.
1411 if (isMember(R_r, retainerSetOfc))
1412 goto loop; // no need to process child
1415 associate(c, addElement(R_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_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 retainClosure(*tl, *tl, *tl);
1495 // NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl)));
1496 // *tl might be a TSO which is ThreadComplete, in which
1497 // case we ignore it for the purposes of retainer profiling.
1500 /* -----------------------------------------------------------------------------
1501 * Compute the retainer set for each of the objects in the heap.
1502 * -------------------------------------------------------------------------- */
1504 computeRetainerSet( void )
1510 #ifdef DEBUG_RETAINER
1511 RetainerSet tmpRetainerSet;
1514 GetRoots(retainRoot); // for scheduler roots
1516 // This function is called after a major GC, when key, value, and finalizer
1517 // all are guaranteed to be valid, or reachable.
1519 // The following code assumes that WEAK objects are considered to be roots
1520 // for retainer profilng.
1521 for (weak = weak_ptr_list; weak != NULL; weak = weak->link)
1522 // retainRoot((StgClosure *)weak);
1523 retainRoot((StgClosure **)&weak);
1525 // The following code resets the rs field of each unvisited mutable
1526 // object (computing sumOfNewCostExtra and updating costArray[] when
1527 // debugging retainer profiler).
1528 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1530 (generations[g].mut_list == END_MUT_LIST &&
1531 generations[g].mut_once_list == END_MUT_LIST));
1534 // I think traversing through mut_list is unnecessary.
1535 // Think about removing this part.
1536 for (ml = generations[g].mut_list; ml != END_MUT_LIST;
1537 ml = ml->mut_link) {
1539 maybeInitRetainerSet((StgClosure *)ml);
1540 rtl = retainerSetOf((StgClosure *)ml);
1542 #ifdef DEBUG_RETAINER
1544 // first visit to *ml
1545 // This is a violation of the interface rule!
1546 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1548 switch (get_itbl((StgClosure *)ml)->type) {
1552 case CONSTR_INTLIKE:
1553 case CONSTR_CHARLIKE:
1554 case CONSTR_NOCAF_STATIC:
1558 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1562 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1563 sumOfNewCostExtra += cost((StgClosure *)ml);
1570 // Traversing through mut_once_list is, in contrast, necessary
1571 // because we can find MUT_VAR objects which have not been
1572 // visited during retainer profiling.
1573 for (ml = generations[g].mut_once_list; ml != END_MUT_LIST;
1574 ml = ml->mut_link) {
1576 maybeInitRetainerSet((StgClosure *)ml);
1577 rtl = retainerSetOf((StgClosure *)ml);
1578 #ifdef DEBUG_RETAINER
1580 // first visit to *ml
1581 // This is a violation of the interface rule!
1582 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1584 switch (get_itbl((StgClosure *)ml)->type) {
1588 case CONSTR_INTLIKE:
1589 case CONSTR_CHARLIKE:
1590 case CONSTR_NOCAF_STATIC:
1594 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1598 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1599 sumOfNewCostExtra += cost((StgClosure *)ml);
1608 /* -----------------------------------------------------------------------------
1609 * Traverse all static objects for which we compute retainer sets,
1610 * and reset their rs fields to NULL, which is accomplished by
1611 * invoking maybeInitRetainerSet(). This function must be called
1612 * before zeroing all objects reachable from scavenged_static_objects
1613 * in the case of major gabage collections. See GarbageCollect() in
1616 * The mut_once_list of the oldest generation must also be traversed?
1617 * Why? Because if the evacuation of an object pointed to by a static
1618 * indirection object fails, it is put back to the mut_once_list of
1619 * the oldest generation.
1620 * However, this is not necessary because any static indirection objects
1621 * are just traversed through to reach dynamic objects. In other words,
1622 * they are not taken into consideration in computing retainer sets.
1623 * -------------------------------------------------------------------------- */
1625 resetStaticObjectForRetainerProfiling( void )
1627 #ifdef DEBUG_RETAINER
1632 #ifdef DEBUG_RETAINER
1635 p = scavenged_static_objects;
1636 while (p != END_OF_STATIC_LIST) {
1637 #ifdef DEBUG_RETAINER
1640 switch (get_itbl(p)->type) {
1642 // Since we do not compute the retainer set of any
1643 // IND_STATIC object, we don't have to reset its retainer
1645 p = IND_STATIC_LINK(p);
1648 maybeInitRetainerSet(p);
1649 p = THUNK_STATIC_LINK(p);
1652 maybeInitRetainerSet(p);
1653 p = FUN_STATIC_LINK(p);
1656 maybeInitRetainerSet(p);
1657 p = STATIC_LINK(get_itbl(p), p);
1660 barf("resetStaticObjectForRetainerProfiling: %p (%s)",
1661 p, get_itbl(p)->type);
1665 #ifdef DEBUG_RETAINER
1666 // fprintf(stderr, "count in scavenged_static_objects = %d\n", count);
1670 /* -----------------------------------------------------------------------------
1671 * Perform retainer profiling.
1672 * N is the oldest generation being profilied, where the generations are
1673 * numbered starting at 0.
1676 * This function should be called only immediately after major garbage
1678 * ------------------------------------------------------------------------- */
1680 retainerProfile(void)
1682 #ifdef DEBUG_RETAINER
1684 nat totalHeapSize; // total raw heap size (computed by linear scanning)
1687 #ifdef DEBUG_RETAINER
1688 fprintf(stderr, " < retainerProfile() invoked : %d>\n", retainerGeneration);
1693 // We haven't flipped the bit yet.
1694 #ifdef DEBUG_RETAINER
1695 fprintf(stderr, "Before traversing:\n");
1696 sumOfCostLinear = 0;
1697 for (i = 0;i < N_CLOSURE_TYPES; i++)
1698 costArrayLinear[i] = 0;
1699 totalHeapSize = checkHeapSanityForRetainerProfiling();
1701 fprintf(stderr, "\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1703 fprintf(stderr, "costArrayLinear[] = ");
1704 for (i = 0;i < N_CLOSURE_TYPES; i++)
1705 fprintf(stderr, "[%u:%u] ", i, costArrayLinear[i]);
1706 fprintf(stderr, "\n");
1709 ASSERT(sumOfCostLinear == totalHeapSize);
1712 #define pcostArrayLinear(index) \
1713 if (costArrayLinear[index] > 0) \
1714 fprintf(stderr, "costArrayLinear[" #index "] = %u\n", costArrayLinear[index])
1715 pcostArrayLinear(THUNK_STATIC);
1716 pcostArrayLinear(FUN_STATIC);
1717 pcostArrayLinear(CONSTR_STATIC);
1718 pcostArrayLinear(CONSTR_NOCAF_STATIC);
1719 pcostArrayLinear(CONSTR_INTLIKE);
1720 pcostArrayLinear(CONSTR_CHARLIKE);
1724 // Now we flips flip.
1727 #ifdef DEBUG_RETAINER
1733 numObjectVisited = 0;
1734 timesAnyObjectVisited = 0;
1736 #ifdef DEBUG_RETAINER
1737 fprintf(stderr, "During traversing:\n");
1739 sumOfNewCostExtra = 0;
1740 for (i = 0;i < N_CLOSURE_TYPES; i++)
1745 We initialize the traverse stack each time the retainer profiling is
1746 performed (because the traverse stack size varies on each retainer profiling
1747 and this operation is not costly anyhow). However, we just refresh the
1750 initializeTraverseStack();
1751 #ifdef DEBUG_RETAINER
1752 initializeAllRetainerSet();
1754 refreshAllRetainerSet();
1756 computeRetainerSet();
1758 #ifdef DEBUG_RETAINER
1759 fprintf(stderr, "After traversing:\n");
1760 sumOfCostLinear = 0;
1761 for (i = 0;i < N_CLOSURE_TYPES; i++)
1762 costArrayLinear[i] = 0;
1763 totalHeapSize = checkHeapSanityForRetainerProfiling();
1765 fprintf(stderr, "\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1766 ASSERT(sumOfCostLinear == totalHeapSize);
1768 // now, compare the two results
1771 costArray[] must be exactly the same as costArrayLinear[].
1773 1) Dead weak pointers, whose type is CONSTR. These objects are not
1774 reachable from any roots.
1776 fprintf(stderr, "Comparison:\n");
1777 fprintf(stderr, "\tcostArrayLinear[] (must be empty) = ");
1778 for (i = 0;i < N_CLOSURE_TYPES; i++)
1779 if (costArray[i] != costArrayLinear[i])
1780 // nothing should be printed except MUT_VAR after major GCs
1781 fprintf(stderr, "[%u:%u] ", i, costArrayLinear[i]);
1782 fprintf(stderr, "\n");
1784 fprintf(stderr, "\tsumOfNewCost = %u\n", sumOfNewCost);
1785 fprintf(stderr, "\tsumOfNewCostExtra = %u\n", sumOfNewCostExtra);
1786 fprintf(stderr, "\tcostArray[] (must be empty) = ");
1787 for (i = 0;i < N_CLOSURE_TYPES; i++)
1788 if (costArray[i] != costArrayLinear[i])
1789 // nothing should be printed except MUT_VAR after major GCs
1790 fprintf(stderr, "[%u:%u] ", i, costArray[i]);
1791 fprintf(stderr, "\n");
1793 // only for major garbage collection
1794 ASSERT(sumOfNewCost + sumOfNewCostExtra == sumOfCostLinear);
1798 closeTraverseStack();
1799 #ifdef DEBUG_RETAINER
1800 closeAllRetainerSet();
1802 // Note that there is no post-processing for the retainer sets.
1804 retainerGeneration++;
1807 retainerGeneration - 1, // retainerGeneration has just been incremented!
1808 #ifdef DEBUG_RETAINER
1809 maxCStackSize, maxStackSize,
1811 (double)timesAnyObjectVisited / numObjectVisited);
1814 /* -----------------------------------------------------------------------------
1816 * -------------------------------------------------------------------------- */
1818 #ifdef DEBUG_RETAINER
1820 #define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
1821 ((HEAP_ALLOCED(r) && Bdescr((P_)r)->free != (void *)-1))) && \
1822 ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa))
1825 sanityCheckHeapClosure( StgClosure *c )
1829 ASSERT(LOOKS_LIKE_GHC_INFO(c->header.info));
1830 ASSERT(!closure_STATIC(c));
1831 ASSERT(LOOKS_LIKE_PTR(c));
1833 if ((((StgWord)RSET(c) & 1) ^ flip) != 0) {
1834 if (get_itbl(c)->type == CONSTR &&
1835 !strcmp(get_itbl(c)->prof.closure_type, "DEAD_WEAK") &&
1836 !strcmp(get_itbl(c)->prof.closure_desc, "DEAD_WEAK")) {
1837 fprintf(stderr, "\tUnvisited dead weak pointer object found: c = %p\n", c);
1838 costArray[get_itbl(c)->type] += cost(c);
1839 sumOfNewCost += cost(c);
1842 "Unvisited object: flip = %d, c = %p(%d, %s, %s), rs = %p\n",
1843 flip, c, get_itbl(c)->type,
1844 get_itbl(c)->prof.closure_type, get_itbl(c)->prof.closure_desc,
1847 // fprintf(stderr, "sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c));
1851 switch (info->type) {
1853 return tso_sizeW((StgTSO *)c);
1861 return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE);
1864 return sizeofW(StgMVar);
1867 case MUT_ARR_PTRS_FROZEN:
1868 return mut_arr_ptrs_sizeW((StgMutArrPtrs *)c);
1872 return pap_sizeW((StgPAP *)c);
1875 return arr_words_sizeW((StgArrWords *)c);
1895 case SE_CAF_BLACKHOLE:
1899 case IND_OLDGEN_PERM:
1903 return sizeW_fromITBL(info);
1905 case THUNK_SELECTOR:
1906 return sizeofW(StgHeader) + MIN_UPD_SIZE;
1915 case CONSTR_INTLIKE:
1916 case CONSTR_CHARLIKE:
1917 case CONSTR_NOCAF_STATIC:
1935 case INVALID_OBJECT:
1937 barf("Invalid object in sanityCheckHeapClosure(): %d",
1944 heapCheck( bdescr *bd )
1947 static nat costSum, size;
1950 while (bd != NULL) {
1952 while (p < bd->free) {
1953 size = sanityCheckHeapClosure((StgClosure *)p);
1954 sumOfCostLinear += size;
1955 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
1957 // no need for slop check; I think slops are not used currently.
1959 ASSERT(p == bd->free);
1960 costSum += bd->free - bd->start;
1968 smallObjectPoolCheck(void)
1972 static nat costSum, size;
1974 bd = small_alloc_list;
1982 while (p < alloc_Hp) {
1983 size = sanityCheckHeapClosure((StgClosure *)p);
1984 sumOfCostLinear += size;
1985 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
1988 ASSERT(p == alloc_Hp);
1989 costSum += alloc_Hp - bd->start;
1992 while (bd != NULL) {
1994 while (p < bd->free) {
1995 size = sanityCheckHeapClosure((StgClosure *)p);
1996 sumOfCostLinear += size;
1997 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2000 ASSERT(p == bd->free);
2001 costSum += bd->free - bd->start;
2009 chainCheck(bdescr *bd)
2014 while (bd != NULL) {
2015 // bd->free - bd->start is not an accurate measurement of the
2016 // object size. Actually it is always zero, so we compute its
2018 size = sanityCheckHeapClosure((StgClosure *)bd->start);
2019 sumOfCostLinear += size;
2020 costArrayLinear[get_itbl((StgClosure *)bd->start)->type] += size;
2029 checkHeapSanityForRetainerProfiling( void )
2034 fprintf(stderr, "START: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2035 if (RtsFlags.GcFlags.generations == 1) {
2036 costSum += heapCheck(g0s0->to_blocks);
2037 fprintf(stderr, "heapCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2038 costSum += chainCheck(g0s0->large_objects);
2039 fprintf(stderr, "chainCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2041 for (g = 0; g < RtsFlags.GcFlags.generations; g++)
2042 for (s = 0; s < generations[g].n_steps; s++) {
2044 After all live objects have been scavenged, the garbage
2045 collector may create some objects in
2046 scheduleFinalizers(). These objects are created throught
2047 allocate(), so the small object pool or the large object
2048 pool of the g0s0 may not be empty.
2050 if (g == 0 && s == 0) {
2051 costSum += smallObjectPoolCheck();
2052 fprintf(stderr, "smallObjectPoolCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2053 costSum += chainCheck(generations[g].steps[s].large_objects);
2054 fprintf(stderr, "chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2056 costSum += heapCheck(generations[g].steps[s].blocks);
2057 fprintf(stderr, "heapCheck(): 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);
2068 findPointer(StgPtr p)
2074 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2075 for (s = 0; s < generations[g].n_steps; s++) {
2076 // if (g == 0 && s == 0) continue;
2077 bd = generations[g].steps[s].blocks;
2078 for (; bd; bd = bd->link) {
2079 for (q = bd->start; q < bd->free; q++) {
2080 if (*q == (StgWord)p) {
2082 while (!LOOKS_LIKE_GHC_INFO(*r)) r--;
2083 fprintf(stderr, "Found in gen[%d], step[%d]: q = %p, r = %p\n", g, s, q, r);
2088 bd = generations[g].steps[s].large_objects;
2089 for (; bd; bd = bd->link) {
2090 e = bd->start + cost((StgClosure *)bd->start);
2091 for (q = bd->start; q < e; q++) {
2092 if (*q == (StgWord)p) {
2094 while (*r == 0 || !LOOKS_LIKE_GHC_INFO(*r)) r--;
2095 fprintf(stderr, "Found in gen[%d], large_objects: %p\n", g, r);
2105 belongToHeap(StgPtr p)
2110 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2111 for (s = 0; s < generations[g].n_steps; s++) {
2112 // if (g == 0 && s == 0) continue;
2113 bd = generations[g].steps[s].blocks;
2114 for (; bd; bd = bd->link) {
2115 if (bd->start <= p && p < bd->free) {
2116 fprintf(stderr, "Belongs to gen[%d], step[%d]", g, s);
2120 bd = generations[g].steps[s].large_objects;
2121 for (; bd; bd = bd->link) {
2122 if (bd->start <= p && p < bd->start + getHeapClosureSize((StgClosure *)bd->start)) {
2123 fprintf(stderr, "Found in gen[%d], large_objects: %p\n", g, bd->start);
2130 #endif // DEBUG_RETAINER
2132 #endif /* PROFILING */