rts: Handle SMALL_MUT_ARR_PTRS in retainer profilter
[ghc.git] / rts / RetainerProfile.c
1 /* -----------------------------------------------------------------------------
2 *
3 * (c) The GHC Team, 2001
4 * Author: Sungwoo Park
5 *
6 * Retainer profiling.
7 *
8 * ---------------------------------------------------------------------------*/
9
10 #if defined(PROFILING)
11
12 // Turn off inlining when debugging - it obfuscates things
13 #if defined(DEBUG)
14 #define INLINE
15 #else
16 #define INLINE inline
17 #endif
18
19 #include "PosixSource.h"
20 #include "Rts.h"
21
22 #include "RtsUtils.h"
23 #include "RetainerProfile.h"
24 #include "RetainerSet.h"
25 #include "Schedule.h"
26 #include "Printer.h"
27 #include "Weak.h"
28 #include "sm/Sanity.h"
29 #include "Profiling.h"
30 #include "Stats.h"
31 #include "ProfHeap.h"
32 #include "Apply.h"
33 #include "Stable.h" /* markStableTables */
34 #include "sm/Storage.h" // for END_OF_STATIC_LIST
35
36 /* Note [What is a retainer?]
37 ~~~~~~~~~~~~~~~~~~~~~~~~~~
38 The definition of what sorts of things are counted as retainers is a bit hard to
39 pin down. Intuitively, we want to identify closures which will help the user
40 identify memory leaks due to thunks. In practice we also end up lumping mutable
41 objects in this group for reasons that have been lost to time.
42
43 The definition of retainer is implemented in isRetainer(), defined later in this
44 file.
45 */
46
47
48 /*
49 Note: what to change in order to plug-in a new retainer profiling scheme?
50 (1) type retainer in ../includes/StgRetainerProf.h
51 (2) retainer function R(), i.e., getRetainerFrom()
52 (3) the two hashing functions, hashKeySingleton() and hashKeyAddElement(),
53 in RetainerSet.h, if needed.
54 (4) printRetainer() and printRetainerSetShort() in RetainerSet.c.
55 */
56
57 /* -----------------------------------------------------------------------------
58 * Declarations...
59 * -------------------------------------------------------------------------- */
60
61 static uint32_t retainerGeneration; // generation
62
63 static uint32_t numObjectVisited; // total number of objects visited
64 static uint32_t timesAnyObjectVisited; // number of times any objects are
65 // visited
66
67 /*
68 The rs field in the profile header of any object points to its retainer
69 set in an indirect way: if flip is 0, it points to the retainer set;
70 if flip is 1, it points to the next byte after the retainer set (even
71 for NULL pointers). Therefore, with flip 1, (rs ^ 1) is the actual
72 pointer. See retainerSetOf().
73 */
74
75 StgWord flip = 0; // flip bit
76 // must be 0 if DEBUG_RETAINER is on (for static closures)
77
78 #define setRetainerSetToNull(c) \
79 (c)->header.prof.hp.rs = (RetainerSet *)((StgWord)NULL | flip)
80
81 static void retainStack(StgClosure *, retainer, StgPtr, StgPtr);
82 static void retainClosure(StgClosure *, StgClosure *, retainer);
83 #if defined(DEBUG_RETAINER)
84 static void belongToHeap(StgPtr p);
85 #endif
86
87 #if defined(DEBUG_RETAINER)
88 /*
89 cStackSize records how many times retainStack() has been invoked recursively,
90 that is, the number of activation records for retainStack() on the C stack.
91 maxCStackSize records its max value.
92 Invariants:
93 cStackSize <= maxCStackSize
94 */
95 static uint32_t cStackSize, maxCStackSize;
96
97 static uint32_t sumOfNewCost; // sum of the cost of each object, computed
98 // when the object is first visited
99 static uint32_t sumOfNewCostExtra; // for those objects not visited during
100 // retainer profiling, e.g., MUT_VAR
101 static uint32_t costArray[N_CLOSURE_TYPES];
102
103 uint32_t sumOfCostLinear; // sum of the costs of all object, computed
104 // when linearly traversing the heap after
105 // retainer profiling
106 uint32_t costArrayLinear[N_CLOSURE_TYPES];
107 #endif
108
109 /* -----------------------------------------------------------------------------
110 * Retainer stack - header
111 * Note:
112 * Although the retainer stack implementation could be separated *
113 * from the retainer profiling engine, there does not seem to be
114 * any advantage in doing that; retainer stack is an integral part
115 * of retainer profiling engine and cannot be use elsewhere at
116 * all.
117 * -------------------------------------------------------------------------- */
118
119 typedef enum {
120 posTypeStep,
121 posTypePtrs,
122 posTypeSRT,
123 } nextPosType;
124
125 typedef union {
126 // fixed layout or layout specified by a field in the closure
127 StgWord step;
128
129 // layout.payload
130 struct {
131 // See StgClosureInfo in InfoTables.h
132 StgHalfWord pos;
133 StgHalfWord ptrs;
134 StgPtr payload;
135 } ptrs;
136
137 // SRT
138 struct {
139 StgClosure *srt;
140 } srt;
141 } nextPos;
142
143 typedef struct {
144 nextPosType type;
145 nextPos next;
146 } stackPos;
147
148 typedef struct {
149 StgClosure *c;
150 retainer c_child_r;
151 stackPos info;
152 } stackElement;
153
154 /*
155 Invariants:
156 firstStack points to the first block group.
157 currentStack points to the block group currently being used.
158 currentStack->free == stackLimit.
159 stackTop points to the topmost byte in the stack of currentStack.
160 Unless the whole stack is empty, stackTop must point to the topmost
161 object (or byte) in the whole stack. Thus, it is only when the whole stack
162 is empty that stackTop == stackLimit (not during the execution of push()
163 and pop()).
164 stackBottom == currentStack->start.
165 stackLimit == currentStack->start + BLOCK_SIZE_W * currentStack->blocks.
166 Note:
167 When a current stack becomes empty, stackTop is set to point to
168 the topmost element on the previous block group so as to satisfy
169 the invariants described above.
170 */
171 static bdescr *firstStack = NULL;
172 static bdescr *currentStack;
173 static stackElement *stackBottom, *stackTop, *stackLimit;
174
175 /*
176 currentStackBoundary is used to mark the current stack chunk.
177 If stackTop == currentStackBoundary, it means that the current stack chunk
178 is empty. It is the responsibility of the user to keep currentStackBoundary
179 valid all the time if it is to be employed.
180 */
181 static stackElement *currentStackBoundary;
182
183 /*
184 stackSize records the current size of the stack.
185 maxStackSize records its high water mark.
186 Invariants:
187 stackSize <= maxStackSize
188 Note:
189 stackSize is just an estimate measure of the depth of the graph. The reason
190 is that some heap objects have only a single child and may not result
191 in a new element being pushed onto the stack. Therefore, at the end of
192 retainer profiling, maxStackSize + maxCStackSize is some value no greater
193 than the actual depth of the graph.
194 */
195 #if defined(DEBUG_RETAINER)
196 static int stackSize, maxStackSize;
197 #endif
198
199 // number of blocks allocated for one stack
200 #define BLOCKS_IN_STACK 1
201
202 /* -----------------------------------------------------------------------------
203 * Add a new block group to the stack.
204 * Invariants:
205 * currentStack->link == s.
206 * -------------------------------------------------------------------------- */
207 static INLINE void
208 newStackBlock( bdescr *bd )
209 {
210 currentStack = bd;
211 stackTop = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
212 stackBottom = (stackElement *)bd->start;
213 stackLimit = (stackElement *)stackTop;
214 bd->free = (StgPtr)stackLimit;
215 }
216
217 /* -----------------------------------------------------------------------------
218 * Return to the previous block group.
219 * Invariants:
220 * s->link == currentStack.
221 * -------------------------------------------------------------------------- */
222 static INLINE void
223 returnToOldStack( bdescr *bd )
224 {
225 currentStack = bd;
226 stackTop = (stackElement *)bd->free;
227 stackBottom = (stackElement *)bd->start;
228 stackLimit = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
229 bd->free = (StgPtr)stackLimit;
230 }
231
232 /* -----------------------------------------------------------------------------
233 * Initializes the traverse stack.
234 * -------------------------------------------------------------------------- */
235 static void
236 initializeTraverseStack( void )
237 {
238 if (firstStack != NULL) {
239 freeChain(firstStack);
240 }
241
242 firstStack = allocGroup(BLOCKS_IN_STACK);
243 firstStack->link = NULL;
244 firstStack->u.back = NULL;
245
246 newStackBlock(firstStack);
247 }
248
249 /* -----------------------------------------------------------------------------
250 * Frees all the block groups in the traverse stack.
251 * Invariants:
252 * firstStack != NULL
253 * -------------------------------------------------------------------------- */
254 static void
255 closeTraverseStack( void )
256 {
257 freeChain(firstStack);
258 firstStack = NULL;
259 }
260
261 /* -----------------------------------------------------------------------------
262 * Returns true if the whole stack is empty.
263 * -------------------------------------------------------------------------- */
264 static INLINE bool
265 isEmptyRetainerStack( void )
266 {
267 return (firstStack == currentStack) && stackTop == stackLimit;
268 }
269
270 /* -----------------------------------------------------------------------------
271 * Returns size of stack
272 * -------------------------------------------------------------------------- */
273 W_
274 retainerStackBlocks( void )
275 {
276 bdescr* bd;
277 W_ res = 0;
278
279 for (bd = firstStack; bd != NULL; bd = bd->link)
280 res += bd->blocks;
281
282 return res;
283 }
284
285 /* -----------------------------------------------------------------------------
286 * Returns true if stackTop is at the stack boundary of the current stack,
287 * i.e., if the current stack chunk is empty.
288 * -------------------------------------------------------------------------- */
289 static INLINE bool
290 isOnBoundary( void )
291 {
292 return stackTop == currentStackBoundary;
293 }
294
295 /* -----------------------------------------------------------------------------
296 * Initializes *info from ptrs and payload.
297 * Invariants:
298 * payload[] begins with ptrs pointers followed by non-pointers.
299 * -------------------------------------------------------------------------- */
300 static INLINE void
301 init_ptrs( stackPos *info, uint32_t ptrs, StgPtr payload )
302 {
303 info->type = posTypePtrs;
304 info->next.ptrs.pos = 0;
305 info->next.ptrs.ptrs = ptrs;
306 info->next.ptrs.payload = payload;
307 }
308
309 /* -----------------------------------------------------------------------------
310 * Find the next object from *info.
311 * -------------------------------------------------------------------------- */
312 static INLINE StgClosure *
313 find_ptrs( stackPos *info )
314 {
315 if (info->next.ptrs.pos < info->next.ptrs.ptrs) {
316 return (StgClosure *)info->next.ptrs.payload[info->next.ptrs.pos++];
317 } else {
318 return NULL;
319 }
320 }
321
322 /* -----------------------------------------------------------------------------
323 * Initializes *info from SRT information stored in *infoTable.
324 * -------------------------------------------------------------------------- */
325 static INLINE void
326 init_srt_fun( stackPos *info, const StgFunInfoTable *infoTable )
327 {
328 info->type = posTypeSRT;
329 if (infoTable->i.srt) {
330 info->next.srt.srt = (StgClosure*)GET_FUN_SRT(infoTable);
331 } else {
332 info->next.srt.srt = NULL;
333 }
334 }
335
336 static INLINE void
337 init_srt_thunk( stackPos *info, const StgThunkInfoTable *infoTable )
338 {
339 if (infoTable->i.srt) {
340 info->next.srt.srt = (StgClosure*)GET_SRT(infoTable);
341 } else {
342 info->next.srt.srt = NULL;
343 }
344 }
345
346 /* -----------------------------------------------------------------------------
347 * Find the next object from *info.
348 * -------------------------------------------------------------------------- */
349 static INLINE StgClosure *
350 find_srt( stackPos *info )
351 {
352 StgClosure *c;
353 if (info->type == posTypeSRT) {
354 c = info->next.srt.srt;
355 info->next.srt.srt = NULL;
356 return c;
357 }
358 }
359
360 /* -----------------------------------------------------------------------------
361 * push() pushes a stackElement representing the next child of *c
362 * onto the traverse stack. If *c has no child, *first_child is set
363 * to NULL and nothing is pushed onto the stack. If *c has only one
364 * child, *c_child is set to that child and nothing is pushed onto
365 * the stack. If *c has more than two children, *first_child is set
366 * to the first child and a stackElement representing the second
367 * child is pushed onto the stack.
368
369 * Invariants:
370 * *c_child_r is the most recent retainer of *c's children.
371 * *c is not any of TSO, AP, PAP, AP_STACK, which means that
372 * there cannot be any stack objects.
373 * Note: SRTs are considered to be children as well.
374 * -------------------------------------------------------------------------- */
375 static INLINE void
376 push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
377 {
378 stackElement se;
379 bdescr *nbd; // Next Block Descriptor
380
381 #if defined(DEBUG_RETAINER)
382 // debugBelch("push(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
383 #endif
384
385 ASSERT(get_itbl(c)->type != TSO);
386 ASSERT(get_itbl(c)->type != AP_STACK);
387
388 //
389 // fill in se
390 //
391
392 se.c = c;
393 se.c_child_r = c_child_r;
394
395 // fill in se.info
396 switch (get_itbl(c)->type) {
397 // no child, no SRT
398 case CONSTR_0_1:
399 case CONSTR_0_2:
400 case ARR_WORDS:
401 case COMPACT_NFDATA:
402 *first_child = NULL;
403 return;
404
405 // one child (fixed), no SRT
406 case MUT_VAR_CLEAN:
407 case MUT_VAR_DIRTY:
408 *first_child = ((StgMutVar *)c)->var;
409 return;
410 case THUNK_SELECTOR:
411 *first_child = ((StgSelector *)c)->selectee;
412 return;
413 case BLACKHOLE:
414 *first_child = ((StgInd *)c)->indirectee;
415 return;
416 case CONSTR_1_0:
417 case CONSTR_1_1:
418 *first_child = c->payload[0];
419 return;
420
421 // For CONSTR_2_0 and MVAR, we use se.info.step to record the position
422 // of the next child. We do not write a separate initialization code.
423 // Also we do not have to initialize info.type;
424
425 // two children (fixed), no SRT
426 // need to push a stackElement, but nothing to store in se.info
427 case CONSTR_2_0:
428 *first_child = c->payload[0]; // return the first pointer
429 // se.info.type = posTypeStep;
430 // se.info.next.step = 2; // 2 = second
431 break;
432
433 // three children (fixed), no SRT
434 // need to push a stackElement
435 case MVAR_CLEAN:
436 case MVAR_DIRTY:
437 // head must be TSO and the head of a linked list of TSOs.
438 // Shoule it be a child? Seems to be yes.
439 *first_child = (StgClosure *)((StgMVar *)c)->head;
440 // se.info.type = posTypeStep;
441 se.info.next.step = 2; // 2 = second
442 break;
443
444 // three children (fixed), no SRT
445 case WEAK:
446 *first_child = ((StgWeak *)c)->key;
447 // se.info.type = posTypeStep;
448 se.info.next.step = 2;
449 break;
450
451 // layout.payload.ptrs, no SRT
452 case TVAR:
453 case CONSTR:
454 case CONSTR_NOCAF:
455 case PRIM:
456 case MUT_PRIM:
457 case BCO:
458 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
459 (StgPtr)c->payload);
460 *first_child = find_ptrs(&se.info);
461 if (*first_child == NULL)
462 return; // no child
463 break;
464
465 // StgMutArrPtr.ptrs, no SRT
466 case MUT_ARR_PTRS_CLEAN:
467 case MUT_ARR_PTRS_DIRTY:
468 case MUT_ARR_PTRS_FROZEN_CLEAN:
469 case MUT_ARR_PTRS_FROZEN_DIRTY:
470 init_ptrs(&se.info, ((StgMutArrPtrs *)c)->ptrs,
471 (StgPtr)(((StgMutArrPtrs *)c)->payload));
472 *first_child = find_ptrs(&se.info);
473 if (*first_child == NULL)
474 return;
475 break;
476
477 // StgMutArrPtr.ptrs, no SRT
478 case SMALL_MUT_ARR_PTRS_CLEAN:
479 case SMALL_MUT_ARR_PTRS_DIRTY:
480 case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
481 case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:
482 init_ptrs(&se.info, ((StgSmallMutArrPtrs *)c)->ptrs,
483 (StgPtr)(((StgSmallMutArrPtrs *)c)->payload));
484 *first_child = find_ptrs(&se.info);
485 if (*first_child == NULL)
486 return;
487 break;
488
489 // layout.payload.ptrs, SRT
490 case FUN_STATIC:
491 ASSERT(get_itbl(c)->srt != 0);
492 /* fallthrough */
493 case FUN: // *c is a heap object.
494 case FUN_2_0:
495 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
496 *first_child = find_ptrs(&se.info);
497 if (*first_child == NULL)
498 // no child from ptrs, so check SRT
499 goto fun_srt_only;
500 break;
501
502 case THUNK:
503 case THUNK_2_0:
504 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
505 (StgPtr)((StgThunk *)c)->payload);
506 *first_child = find_ptrs(&se.info);
507 if (*first_child == NULL)
508 // no child from ptrs, so check SRT
509 goto thunk_srt_only;
510 break;
511
512 // 1 fixed child, SRT
513 case FUN_1_0:
514 case FUN_1_1:
515 *first_child = c->payload[0];
516 ASSERT(*first_child != NULL);
517 init_srt_fun(&se.info, get_fun_itbl(c));
518 break;
519
520 case THUNK_1_0:
521 case THUNK_1_1:
522 *first_child = ((StgThunk *)c)->payload[0];
523 ASSERT(*first_child != NULL);
524 init_srt_thunk(&se.info, get_thunk_itbl(c));
525 break;
526
527 case FUN_0_1: // *c is a heap object.
528 case FUN_0_2:
529 fun_srt_only:
530 init_srt_fun(&se.info, get_fun_itbl(c));
531 *first_child = find_srt(&se.info);
532 if (*first_child == NULL)
533 return; // no child
534 break;
535
536 // SRT only
537 case THUNK_STATIC:
538 ASSERT(get_itbl(c)->srt != 0);
539 case THUNK_0_1:
540 case THUNK_0_2:
541 thunk_srt_only:
542 init_srt_thunk(&se.info, get_thunk_itbl(c));
543 *first_child = find_srt(&se.info);
544 if (*first_child == NULL)
545 return; // no child
546 break;
547
548 case TREC_CHUNK:
549 *first_child = (StgClosure *)((StgTRecChunk *)c)->prev_chunk;
550 se.info.next.step = 0; // entry no.
551 break;
552
553 // cannot appear
554 case PAP:
555 case AP:
556 case AP_STACK:
557 case TSO:
558 case STACK:
559 case IND_STATIC:
560 // stack objects
561 case UPDATE_FRAME:
562 case CATCH_FRAME:
563 case UNDERFLOW_FRAME:
564 case STOP_FRAME:
565 case RET_BCO:
566 case RET_SMALL:
567 case RET_BIG:
568 // invalid objects
569 case IND:
570 case INVALID_OBJECT:
571 default:
572 barf("Invalid object *c in push(): %d", get_itbl(c)->type);
573 return;
574 }
575
576 if (stackTop - 1 < stackBottom) {
577 #if defined(DEBUG_RETAINER)
578 // debugBelch("push() to the next stack.\n");
579 #endif
580 // currentStack->free is updated when the active stack is switched
581 // to the next stack.
582 currentStack->free = (StgPtr)stackTop;
583
584 if (currentStack->link == NULL) {
585 nbd = allocGroup(BLOCKS_IN_STACK);
586 nbd->link = NULL;
587 nbd->u.back = currentStack;
588 currentStack->link = nbd;
589 } else
590 nbd = currentStack->link;
591
592 newStackBlock(nbd);
593 }
594
595 // adjust stackTop (acutal push)
596 stackTop--;
597 // If the size of stackElement was huge, we would better replace the
598 // following statement by either a memcpy() call or a switch statement
599 // on the type of the element. Currently, the size of stackElement is
600 // small enough (5 words) that this direct assignment seems to be enough.
601
602 // ToDo: The line below leads to the warning:
603 // warning: 'se.info.type' may be used uninitialized in this function
604 // This is caused by the fact that there are execution paths through the
605 // large switch statement above where some cases do not initialize this
606 // field. Is this really harmless? Can we avoid the warning?
607 *stackTop = se;
608
609 #if defined(DEBUG_RETAINER)
610 stackSize++;
611 if (stackSize > maxStackSize) maxStackSize = stackSize;
612 // ASSERT(stackSize >= 0);
613 // debugBelch("stackSize = %d\n", stackSize);
614 #endif
615 }
616
617 /* -----------------------------------------------------------------------------
618 * popOff() and popOffReal(): Pop a stackElement off the traverse stack.
619 * Invariants:
620 * stackTop cannot be equal to stackLimit unless the whole stack is
621 * empty, in which case popOff() is not allowed.
622 * Note:
623 * You can think of popOffReal() as a part of popOff() which is
624 * executed at the end of popOff() in necessary. Since popOff() is
625 * likely to be executed quite often while popOffReal() is not, we
626 * separate popOffReal() from popOff(), which is declared as an
627 * INLINE function (for the sake of execution speed). popOffReal()
628 * is called only within popOff() and nowhere else.
629 * -------------------------------------------------------------------------- */
630 static void
631 popOffReal(void)
632 {
633 bdescr *pbd; // Previous Block Descriptor
634
635 #if defined(DEBUG_RETAINER)
636 // debugBelch("pop() to the previous stack.\n");
637 #endif
638
639 ASSERT(stackTop + 1 == stackLimit);
640 ASSERT(stackBottom == (stackElement *)currentStack->start);
641
642 if (firstStack == currentStack) {
643 // The stack is completely empty.
644 stackTop++;
645 ASSERT(stackTop == stackLimit);
646 #if defined(DEBUG_RETAINER)
647 stackSize--;
648 if (stackSize > maxStackSize) maxStackSize = stackSize;
649 /*
650 ASSERT(stackSize >= 0);
651 debugBelch("stackSize = %d\n", stackSize);
652 */
653 #endif
654 return;
655 }
656
657 // currentStack->free is updated when the active stack is switched back
658 // to the previous stack.
659 currentStack->free = (StgPtr)stackLimit;
660
661 // find the previous block descriptor
662 pbd = currentStack->u.back;
663 ASSERT(pbd != NULL);
664
665 returnToOldStack(pbd);
666
667 #if defined(DEBUG_RETAINER)
668 stackSize--;
669 if (stackSize > maxStackSize) maxStackSize = stackSize;
670 /*
671 ASSERT(stackSize >= 0);
672 debugBelch("stackSize = %d\n", stackSize);
673 */
674 #endif
675 }
676
677 static INLINE void
678 popOff(void) {
679 #if defined(DEBUG_RETAINER)
680 // debugBelch("\tpopOff(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
681 #endif
682
683 ASSERT(stackTop != stackLimit);
684 ASSERT(!isEmptyRetainerStack());
685
686 // <= (instead of <) is wrong!
687 if (stackTop + 1 < stackLimit) {
688 stackTop++;
689 #if defined(DEBUG_RETAINER)
690 stackSize--;
691 if (stackSize > maxStackSize) maxStackSize = stackSize;
692 /*
693 ASSERT(stackSize >= 0);
694 debugBelch("stackSize = %d\n", stackSize);
695 */
696 #endif
697 return;
698 }
699
700 popOffReal();
701 }
702
703 /* -----------------------------------------------------------------------------
704 * Finds the next object to be considered for retainer profiling and store
705 * its pointer to *c.
706 * Test if the topmost stack element indicates that more objects are left,
707 * and if so, retrieve the first object and store its pointer to *c. Also,
708 * set *cp and *r appropriately, both of which are stored in the stack element.
709 * The topmost stack element then is overwritten so as for it to now denote
710 * the next object.
711 * If the topmost stack element indicates no more objects are left, pop
712 * off the stack element until either an object can be retrieved or
713 * the current stack chunk becomes empty, indicated by true returned by
714 * isOnBoundary(), in which case *c is set to NULL.
715 * Note:
716 * It is okay to call this function even when the current stack chunk
717 * is empty.
718 * -------------------------------------------------------------------------- */
719 static INLINE void
720 pop( StgClosure **c, StgClosure **cp, retainer *r )
721 {
722 stackElement *se;
723
724 #if defined(DEBUG_RETAINER)
725 // debugBelch("pop(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
726 #endif
727
728 do {
729 if (isOnBoundary()) { // if the current stack chunk is depleted
730 *c = NULL;
731 return;
732 }
733
734 se = stackTop;
735
736 switch (get_itbl(se->c)->type) {
737 // two children (fixed), no SRT
738 // nothing in se.info
739 case CONSTR_2_0:
740 *c = se->c->payload[1];
741 *cp = se->c;
742 *r = se->c_child_r;
743 popOff();
744 return;
745
746 // three children (fixed), no SRT
747 // need to push a stackElement
748 case MVAR_CLEAN:
749 case MVAR_DIRTY:
750 if (se->info.next.step == 2) {
751 *c = (StgClosure *)((StgMVar *)se->c)->tail;
752 se->info.next.step++; // move to the next step
753 // no popOff
754 } else {
755 *c = ((StgMVar *)se->c)->value;
756 popOff();
757 }
758 *cp = se->c;
759 *r = se->c_child_r;
760 return;
761
762 // three children (fixed), no SRT
763 case WEAK:
764 if (se->info.next.step == 2) {
765 *c = ((StgWeak *)se->c)->value;
766 se->info.next.step++;
767 // no popOff
768 } else {
769 *c = ((StgWeak *)se->c)->finalizer;
770 popOff();
771 }
772 *cp = se->c;
773 *r = se->c_child_r;
774 return;
775
776 case TREC_CHUNK: {
777 // These are pretty complicated: we have N entries, each
778 // of which contains 3 fields that we want to follow. So
779 // we divide the step counter: the 2 low bits indicate
780 // which field, and the rest of the bits indicate the
781 // entry number (starting from zero).
782 TRecEntry *entry;
783 uint32_t entry_no = se->info.next.step >> 2;
784 uint32_t field_no = se->info.next.step & 3;
785 if (entry_no == ((StgTRecChunk *)se->c)->next_entry_idx) {
786 *c = NULL;
787 popOff();
788 return;
789 }
790 entry = &((StgTRecChunk *)se->c)->entries[entry_no];
791 if (field_no == 0) {
792 *c = (StgClosure *)entry->tvar;
793 } else if (field_no == 1) {
794 *c = entry->expected_value;
795 } else {
796 *c = entry->new_value;
797 }
798 *cp = se->c;
799 *r = se->c_child_r;
800 se->info.next.step++;
801 return;
802 }
803
804 case TVAR:
805 case CONSTR:
806 case PRIM:
807 case MUT_PRIM:
808 case BCO:
809 // StgMutArrPtr.ptrs, no SRT
810 case MUT_ARR_PTRS_CLEAN:
811 case MUT_ARR_PTRS_DIRTY:
812 case MUT_ARR_PTRS_FROZEN_CLEAN:
813 case MUT_ARR_PTRS_FROZEN_DIRTY:
814 case SMALL_MUT_ARR_PTRS_CLEAN:
815 case SMALL_MUT_ARR_PTRS_DIRTY:
816 case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
817 case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:
818 *c = find_ptrs(&se->info);
819 if (*c == NULL) {
820 popOff();
821 break;
822 }
823 *cp = se->c;
824 *r = se->c_child_r;
825 return;
826
827 // layout.payload.ptrs, SRT
828 case FUN: // always a heap object
829 case FUN_STATIC:
830 case FUN_2_0:
831 if (se->info.type == posTypePtrs) {
832 *c = find_ptrs(&se->info);
833 if (*c != NULL) {
834 *cp = se->c;
835 *r = se->c_child_r;
836 return;
837 }
838 init_srt_fun(&se->info, get_fun_itbl(se->c));
839 }
840 goto do_srt;
841
842 case THUNK:
843 case THUNK_2_0:
844 if (se->info.type == posTypePtrs) {
845 *c = find_ptrs(&se->info);
846 if (*c != NULL) {
847 *cp = se->c;
848 *r = se->c_child_r;
849 return;
850 }
851 init_srt_thunk(&se->info, get_thunk_itbl(se->c));
852 }
853 goto do_srt;
854
855 // SRT
856 do_srt:
857 case THUNK_STATIC:
858 case FUN_0_1:
859 case FUN_0_2:
860 case THUNK_0_1:
861 case THUNK_0_2:
862 case FUN_1_0:
863 case FUN_1_1:
864 case THUNK_1_0:
865 case THUNK_1_1:
866 *c = find_srt(&se->info);
867 if (*c != NULL) {
868 *cp = se->c;
869 *r = se->c_child_r;
870 return;
871 }
872 popOff();
873 break;
874
875 // no child (fixed), no SRT
876 case CONSTR_0_1:
877 case CONSTR_0_2:
878 case ARR_WORDS:
879 // one child (fixed), no SRT
880 case MUT_VAR_CLEAN:
881 case MUT_VAR_DIRTY:
882 case THUNK_SELECTOR:
883 case CONSTR_1_1:
884 // cannot appear
885 case PAP:
886 case AP:
887 case AP_STACK:
888 case TSO:
889 case STACK:
890 case IND_STATIC:
891 case CONSTR_NOCAF:
892 // stack objects
893 case UPDATE_FRAME:
894 case CATCH_FRAME:
895 case UNDERFLOW_FRAME:
896 case STOP_FRAME:
897 case RET_BCO:
898 case RET_SMALL:
899 case RET_BIG:
900 // invalid objects
901 case IND:
902 case INVALID_OBJECT:
903 default:
904 barf("Invalid object *c in pop(): %d", get_itbl(se->c)->type);
905 return;
906 }
907 } while (true);
908 }
909
910 /* -----------------------------------------------------------------------------
911 * RETAINER PROFILING ENGINE
912 * -------------------------------------------------------------------------- */
913
914 void
915 initRetainerProfiling( void )
916 {
917 initializeAllRetainerSet();
918 retainerGeneration = 0;
919 }
920
921 /* -----------------------------------------------------------------------------
922 * This function must be called before f-closing prof_file.
923 * -------------------------------------------------------------------------- */
924 void
925 endRetainerProfiling( void )
926 {
927 #if defined(SECOND_APPROACH)
928 outputAllRetainerSet(prof_file);
929 #endif
930 }
931
932 /* -----------------------------------------------------------------------------
933 * Returns the actual pointer to the retainer set of the closure *c.
934 * It may adjust RSET(c) subject to flip.
935 * Side effects:
936 * RSET(c) is initialized to NULL if its current value does not
937 * conform to flip.
938 * Note:
939 * Even though this function has side effects, they CAN be ignored because
940 * subsequent calls to retainerSetOf() always result in the same return value
941 * and retainerSetOf() is the only way to retrieve retainerSet of a given
942 * closure.
943 * We have to perform an XOR (^) operation each time a closure is examined.
944 * The reason is that we do not know when a closure is visited last.
945 * -------------------------------------------------------------------------- */
946 static INLINE void
947 maybeInitRetainerSet( StgClosure *c )
948 {
949 if (!isRetainerSetFieldValid(c)) {
950 setRetainerSetToNull(c);
951 }
952 }
953
954 /* -----------------------------------------------------------------------------
955 * Returns true if *c is a retainer.
956 * -------------------------------------------------------------------------- */
957 static INLINE bool
958 isRetainer( StgClosure *c )
959 {
960 switch (get_itbl(c)->type) {
961 //
962 // True case
963 //
964 // TSOs MUST be retainers: they constitute the set of roots.
965 case TSO:
966 case STACK:
967
968 // mutable objects
969 case MUT_PRIM:
970 case MVAR_CLEAN:
971 case MVAR_DIRTY:
972 case TVAR:
973 case MUT_VAR_CLEAN:
974 case MUT_VAR_DIRTY:
975 case MUT_ARR_PTRS_CLEAN:
976 case MUT_ARR_PTRS_DIRTY:
977 case SMALL_MUT_ARR_PTRS_CLEAN:
978 case SMALL_MUT_ARR_PTRS_DIRTY:
979 case BLOCKING_QUEUE:
980
981 // thunks are retainers.
982 case THUNK:
983 case THUNK_1_0:
984 case THUNK_0_1:
985 case THUNK_2_0:
986 case THUNK_1_1:
987 case THUNK_0_2:
988 case THUNK_SELECTOR:
989 case AP:
990 case AP_STACK:
991
992 // Static thunks, or CAFS, are obviously retainers.
993 case THUNK_STATIC:
994
995 // WEAK objects are roots; there is separate code in which traversing
996 // begins from WEAK objects.
997 case WEAK:
998 return true;
999
1000 //
1001 // False case
1002 //
1003
1004 // constructors
1005 case CONSTR:
1006 case CONSTR_NOCAF:
1007 case CONSTR_1_0:
1008 case CONSTR_0_1:
1009 case CONSTR_2_0:
1010 case CONSTR_1_1:
1011 case CONSTR_0_2:
1012 // functions
1013 case FUN:
1014 case FUN_1_0:
1015 case FUN_0_1:
1016 case FUN_2_0:
1017 case FUN_1_1:
1018 case FUN_0_2:
1019 // partial applications
1020 case PAP:
1021 // indirection
1022 // IND_STATIC used to be an error, but at the moment it can happen
1023 // as isAlive doesn't look through IND_STATIC as it ignores static
1024 // closures. See trac #3956 for a program that hit this error.
1025 case IND_STATIC:
1026 case BLACKHOLE:
1027 case WHITEHOLE:
1028 // static objects
1029 case FUN_STATIC:
1030 // misc
1031 case PRIM:
1032 case BCO:
1033 case ARR_WORDS:
1034 case COMPACT_NFDATA:
1035 // STM
1036 case TREC_CHUNK:
1037 // immutable arrays
1038 case MUT_ARR_PTRS_FROZEN_CLEAN:
1039 case MUT_ARR_PTRS_FROZEN_DIRTY:
1040 case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
1041 case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:
1042 return false;
1043
1044 //
1045 // Error case
1046 //
1047 // Stack objects are invalid because they are never treated as
1048 // legal objects during retainer profiling.
1049 case UPDATE_FRAME:
1050 case CATCH_FRAME:
1051 case CATCH_RETRY_FRAME:
1052 case CATCH_STM_FRAME:
1053 case UNDERFLOW_FRAME:
1054 case ATOMICALLY_FRAME:
1055 case STOP_FRAME:
1056 case RET_BCO:
1057 case RET_SMALL:
1058 case RET_BIG:
1059 case RET_FUN:
1060 // other cases
1061 case IND:
1062 case INVALID_OBJECT:
1063 default:
1064 barf("Invalid object in isRetainer(): %d", get_itbl(c)->type);
1065 return false;
1066 }
1067 }
1068
1069 /* -----------------------------------------------------------------------------
1070 * Returns the retainer function value for the closure *c, i.e., R(*c).
1071 * This function does NOT return the retainer(s) of *c.
1072 * Invariants:
1073 * *c must be a retainer.
1074 * Note:
1075 * Depending on the definition of this function, the maintenance of retainer
1076 * sets can be made easier. If most retainer sets are likely to be created
1077 * again across garbage collections, refreshAllRetainerSet() in
1078 * RetainerSet.c can simply do nothing.
1079 * If this is not the case, we can free all the retainer sets and
1080 * re-initialize the hash table.
1081 * See refreshAllRetainerSet() in RetainerSet.c.
1082 * -------------------------------------------------------------------------- */
1083 static INLINE retainer
1084 getRetainerFrom( StgClosure *c )
1085 {
1086 ASSERT(isRetainer(c));
1087
1088 return c->header.prof.ccs;
1089 }
1090
1091 /* -----------------------------------------------------------------------------
1092 * Associates the retainer set *s with the closure *c, that is, *s becomes
1093 * the retainer set of *c.
1094 * Invariants:
1095 * c != NULL
1096 * s != NULL
1097 * -------------------------------------------------------------------------- */
1098 static INLINE void
1099 associate( StgClosure *c, RetainerSet *s )
1100 {
1101 // StgWord has the same size as pointers, so the following type
1102 // casting is okay.
1103 RSET(c) = (RetainerSet *)((StgWord)s | flip);
1104 }
1105
1106 /* -----------------------------------------------------------------------------
1107 Call retainClosure for each of the closures covered by a large bitmap.
1108 -------------------------------------------------------------------------- */
1109
1110 static void
1111 retain_large_bitmap (StgPtr p, StgLargeBitmap *large_bitmap, uint32_t size,
1112 StgClosure *c, retainer c_child_r)
1113 {
1114 uint32_t i, b;
1115 StgWord bitmap;
1116
1117 b = 0;
1118 bitmap = large_bitmap->bitmap[b];
1119 for (i = 0; i < size; ) {
1120 if ((bitmap & 1) == 0) {
1121 retainClosure((StgClosure *)*p, c, c_child_r);
1122 }
1123 i++;
1124 p++;
1125 if (i % BITS_IN(W_) == 0) {
1126 b++;
1127 bitmap = large_bitmap->bitmap[b];
1128 } else {
1129 bitmap = bitmap >> 1;
1130 }
1131 }
1132 }
1133
1134 static INLINE StgPtr
1135 retain_small_bitmap (StgPtr p, uint32_t size, StgWord bitmap,
1136 StgClosure *c, retainer c_child_r)
1137 {
1138 while (size > 0) {
1139 if ((bitmap & 1) == 0) {
1140 retainClosure((StgClosure *)*p, c, c_child_r);
1141 }
1142 p++;
1143 bitmap = bitmap >> 1;
1144 size--;
1145 }
1146 return p;
1147 }
1148
1149 /* -----------------------------------------------------------------------------
1150 * Process all the objects in the stack chunk from stackStart to stackEnd
1151 * with *c and *c_child_r being their parent and their most recent retainer,
1152 * respectively. Treat stackOptionalFun as another child of *c if it is
1153 * not NULL.
1154 * Invariants:
1155 * *c is one of the following: TSO, AP_STACK.
1156 * If *c is TSO, c == c_child_r.
1157 * stackStart < stackEnd.
1158 * RSET(c) and RSET(c_child_r) are valid, i.e., their
1159 * interpretation conforms to the current value of flip (even when they
1160 * are interpreted to be NULL).
1161 * If *c is TSO, its state is not ThreadComplete,or ThreadKilled,
1162 * which means that its stack is ready to process.
1163 * Note:
1164 * This code was almost plagiarzied from GC.c! For each pointer,
1165 * retainClosure() is invoked instead of evacuate().
1166 * -------------------------------------------------------------------------- */
1167 static void
1168 retainStack( StgClosure *c, retainer c_child_r,
1169 StgPtr stackStart, StgPtr stackEnd )
1170 {
1171 stackElement *oldStackBoundary;
1172 StgPtr p;
1173 const StgRetInfoTable *info;
1174 StgWord bitmap;
1175 uint32_t size;
1176
1177 #if defined(DEBUG_RETAINER)
1178 cStackSize++;
1179 if (cStackSize > maxCStackSize) maxCStackSize = cStackSize;
1180 #endif
1181
1182 /*
1183 Each invocation of retainStack() creates a new virtual
1184 stack. Since all such stacks share a single common stack, we
1185 record the current currentStackBoundary, which will be restored
1186 at the exit.
1187 */
1188 oldStackBoundary = currentStackBoundary;
1189 currentStackBoundary = stackTop;
1190
1191 #if defined(DEBUG_RETAINER)
1192 // debugBelch("retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
1193 #endif
1194
1195 ASSERT(get_itbl(c)->type == STACK);
1196
1197 p = stackStart;
1198 while (p < stackEnd) {
1199 info = get_ret_itbl((StgClosure *)p);
1200
1201 switch(info->i.type) {
1202
1203 case UPDATE_FRAME:
1204 retainClosure(((StgUpdateFrame *)p)->updatee, c, c_child_r);
1205 p += sizeofW(StgUpdateFrame);
1206 continue;
1207
1208 case UNDERFLOW_FRAME:
1209 case STOP_FRAME:
1210 case CATCH_FRAME:
1211 case CATCH_STM_FRAME:
1212 case CATCH_RETRY_FRAME:
1213 case ATOMICALLY_FRAME:
1214 case RET_SMALL:
1215 bitmap = BITMAP_BITS(info->i.layout.bitmap);
1216 size = BITMAP_SIZE(info->i.layout.bitmap);
1217 p++;
1218 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1219
1220 follow_srt:
1221 if (info->i.srt) {
1222 retainClosure(GET_SRT(info),c,c_child_r);
1223 }
1224 continue;
1225
1226 case RET_BCO: {
1227 StgBCO *bco;
1228
1229 p++;
1230 retainClosure((StgClosure *)*p, c, c_child_r);
1231 bco = (StgBCO *)*p;
1232 p++;
1233 size = BCO_BITMAP_SIZE(bco);
1234 retain_large_bitmap(p, BCO_BITMAP(bco), size, c, c_child_r);
1235 p += size;
1236 continue;
1237 }
1238
1239 // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
1240 case RET_BIG:
1241 size = GET_LARGE_BITMAP(&info->i)->size;
1242 p++;
1243 retain_large_bitmap(p, GET_LARGE_BITMAP(&info->i),
1244 size, c, c_child_r);
1245 p += size;
1246 // and don't forget to follow the SRT
1247 goto follow_srt;
1248
1249 case RET_FUN: {
1250 StgRetFun *ret_fun = (StgRetFun *)p;
1251 const StgFunInfoTable *fun_info;
1252
1253 retainClosure(ret_fun->fun, c, c_child_r);
1254 fun_info = get_fun_itbl(UNTAG_CONST_CLOSURE(ret_fun->fun));
1255
1256 p = (P_)&ret_fun->payload;
1257 switch (fun_info->f.fun_type) {
1258 case ARG_GEN:
1259 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
1260 size = BITMAP_SIZE(fun_info->f.b.bitmap);
1261 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1262 break;
1263 case ARG_GEN_BIG:
1264 size = GET_FUN_LARGE_BITMAP(fun_info)->size;
1265 retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
1266 size, c, c_child_r);
1267 p += size;
1268 break;
1269 default:
1270 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1271 size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
1272 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1273 break;
1274 }
1275 goto follow_srt;
1276 }
1277
1278 default:
1279 barf("Invalid object found in retainStack(): %d",
1280 (int)(info->i.type));
1281 }
1282 }
1283
1284 // restore currentStackBoundary
1285 currentStackBoundary = oldStackBoundary;
1286 #if defined(DEBUG_RETAINER)
1287 // debugBelch("retainStack() finished: currentStackBoundary = 0x%x\n", currentStackBoundary);
1288 #endif
1289
1290 #if defined(DEBUG_RETAINER)
1291 cStackSize--;
1292 #endif
1293 }
1294
1295 /* ----------------------------------------------------------------------------
1296 * Call retainClosure for each of the children of a PAP/AP
1297 * ------------------------------------------------------------------------- */
1298
1299 static INLINE StgPtr
1300 retain_PAP_payload (StgClosure *pap, /* NOT tagged */
1301 retainer c_child_r, /* NOT tagged */
1302 StgClosure *fun, /* tagged */
1303 StgClosure** payload, StgWord n_args)
1304 {
1305 StgPtr p;
1306 StgWord bitmap;
1307 const StgFunInfoTable *fun_info;
1308
1309 retainClosure(fun, pap, c_child_r);
1310 fun = UNTAG_CLOSURE(fun);
1311 fun_info = get_fun_itbl(fun);
1312 ASSERT(fun_info->i.type != PAP);
1313
1314 p = (StgPtr)payload;
1315
1316 switch (fun_info->f.fun_type) {
1317 case ARG_GEN:
1318 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
1319 p = retain_small_bitmap(p, n_args, bitmap,
1320 pap, c_child_r);
1321 break;
1322 case ARG_GEN_BIG:
1323 retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
1324 n_args, pap, c_child_r);
1325 p += n_args;
1326 break;
1327 case ARG_BCO:
1328 retain_large_bitmap((StgPtr)payload, BCO_BITMAP(fun),
1329 n_args, pap, c_child_r);
1330 p += n_args;
1331 break;
1332 default:
1333 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1334 p = retain_small_bitmap(p, n_args, bitmap, pap, c_child_r);
1335 break;
1336 }
1337 return p;
1338 }
1339
1340 /* -----------------------------------------------------------------------------
1341 * Compute the retainer set of *c0 and all its desecents by traversing.
1342 * *cp0 is the parent of *c0, and *r0 is the most recent retainer of *c0.
1343 * Invariants:
1344 * c0 = cp0 = r0 holds only for root objects.
1345 * RSET(cp0) and RSET(r0) are valid, i.e., their
1346 * interpretation conforms to the current value of flip (even when they
1347 * are interpreted to be NULL).
1348 * However, RSET(c0) may be corrupt, i.e., it may not conform to
1349 * the current value of flip. If it does not, during the execution
1350 * of this function, RSET(c0) must be initialized as well as all
1351 * its descendants.
1352 * Note:
1353 * stackTop must be the same at the beginning and the exit of this function.
1354 * *c0 can be TSO (as well as AP_STACK).
1355 * -------------------------------------------------------------------------- */
1356 static void
1357 retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
1358 {
1359 // c = Current closure (possibly tagged)
1360 // cp = Current closure's Parent (NOT tagged)
1361 // r = current closures' most recent Retainer (NOT tagged)
1362 // c_child_r = current closure's children's most recent retainer
1363 // first_child = first child of c
1364 StgClosure *c, *cp, *first_child;
1365 RetainerSet *s, *retainerSetOfc;
1366 retainer r, c_child_r;
1367 StgWord typeOfc;
1368
1369 #if defined(DEBUG_RETAINER)
1370 // StgPtr oldStackTop;
1371 #endif
1372
1373 #if defined(DEBUG_RETAINER)
1374 // oldStackTop = stackTop;
1375 // debugBelch("retainClosure() called: c0 = 0x%x, cp0 = 0x%x, r0 = 0x%x\n", c0, cp0, r0);
1376 #endif
1377
1378 // (c, cp, r) = (c0, cp0, r0)
1379 c = c0;
1380 cp = cp0;
1381 r = r0;
1382 goto inner_loop;
1383
1384 loop:
1385 //debugBelch("loop");
1386 // pop to (c, cp, r);
1387 pop(&c, &cp, &r);
1388
1389 if (c == NULL) {
1390 #if defined(DEBUG_RETAINER)
1391 // debugBelch("retainClosure() ends: oldStackTop = 0x%x, stackTop = 0x%x\n", oldStackTop, stackTop);
1392 #endif
1393 return;
1394 }
1395
1396 //debugBelch("inner_loop");
1397
1398 inner_loop:
1399 c = UNTAG_CLOSURE(c);
1400
1401 // c = current closure under consideration,
1402 // cp = current closure's parent,
1403 // r = current closure's most recent retainer
1404 //
1405 // Loop invariants (on the meaning of c, cp, r, and their retainer sets):
1406 // RSET(cp) and RSET(r) are valid.
1407 // RSET(c) is valid only if c has been visited before.
1408 //
1409 // Loop invariants (on the relation between c, cp, and r)
1410 // if cp is not a retainer, r belongs to RSET(cp).
1411 // if cp is a retainer, r == cp.
1412
1413 typeOfc = get_itbl(c)->type;
1414
1415 #if defined(DEBUG_RETAINER)
1416 switch (typeOfc) {
1417 case IND_STATIC:
1418 case CONSTR_NOCAF:
1419 case THUNK_STATIC:
1420 case FUN_STATIC:
1421 break;
1422 default:
1423 if (retainerSetOf(c) == NULL) { // first visit?
1424 costArray[typeOfc] += cost(c);
1425 sumOfNewCost += cost(c);
1426 }
1427 break;
1428 }
1429 #endif
1430
1431 // special cases
1432 switch (typeOfc) {
1433 case TSO:
1434 if (((StgTSO *)c)->what_next == ThreadComplete ||
1435 ((StgTSO *)c)->what_next == ThreadKilled) {
1436 #if defined(DEBUG_RETAINER)
1437 debugBelch("ThreadComplete or ThreadKilled encountered in retainClosure()\n");
1438 #endif
1439 goto loop;
1440 }
1441 break;
1442
1443 case IND_STATIC:
1444 // We just skip IND_STATIC, so its retainer set is never computed.
1445 c = ((StgIndStatic *)c)->indirectee;
1446 goto inner_loop;
1447 // static objects with no pointers out, so goto loop.
1448 case CONSTR_NOCAF:
1449 // It is not just enough not to compute the retainer set for *c; it is
1450 // mandatory because CONSTR_NOCAF are not reachable from
1451 // scavenged_static_objects, the list from which is assumed to traverse
1452 // all static objects after major garbage collections.
1453 goto loop;
1454 case THUNK_STATIC:
1455 if (get_itbl(c)->srt == 0) {
1456 // No need to compute the retainer set; no dynamic objects
1457 // are reachable from *c.
1458 //
1459 // Static objects: if we traverse all the live closures,
1460 // including static closures, during each heap census then
1461 // we will observe that some static closures appear and
1462 // disappear. eg. a closure may contain a pointer to a
1463 // static function 'f' which is not otherwise reachable
1464 // (it doesn't indirectly point to any CAFs, so it doesn't
1465 // appear in any SRTs), so we would find 'f' during
1466 // traversal. However on the next sweep there may be no
1467 // closures pointing to 'f'.
1468 //
1469 // We must therefore ignore static closures whose SRT is
1470 // empty, because these are exactly the closures that may
1471 // "appear". A closure with a non-empty SRT, and which is
1472 // still required, will always be reachable.
1473 //
1474 // But what about CONSTR? Surely these may be able
1475 // to appear, and they don't have SRTs, so we can't
1476 // check. So for now, we're calling
1477 // resetStaticObjectForRetainerProfiling() from the
1478 // garbage collector to reset the retainer sets in all the
1479 // reachable static objects.
1480 goto loop;
1481 }
1482 case FUN_STATIC: {
1483 StgInfoTable *info = get_itbl(c);
1484 if (info->srt == 0 && info->layout.payload.ptrs == 0) {
1485 goto loop;
1486 } else {
1487 break;
1488 }
1489 }
1490 default:
1491 break;
1492 }
1493
1494 // The above objects are ignored in computing the average number of times
1495 // an object is visited.
1496 timesAnyObjectVisited++;
1497
1498 // If this is the first visit to c, initialize its retainer set.
1499 maybeInitRetainerSet(c);
1500 retainerSetOfc = retainerSetOf(c);
1501
1502 // Now compute s:
1503 // isRetainer(cp) == true => s == NULL
1504 // isRetainer(cp) == false => s == cp.retainer
1505 if (isRetainer(cp))
1506 s = NULL;
1507 else
1508 s = retainerSetOf(cp);
1509
1510 // (c, cp, r, s) is available.
1511
1512 // (c, cp, r, s, R_r) is available, so compute the retainer set for *c.
1513 if (retainerSetOfc == NULL) {
1514 // This is the first visit to *c.
1515 numObjectVisited++;
1516
1517 if (s == NULL)
1518 associate(c, singleton(r));
1519 else
1520 // s is actually the retainer set of *c!
1521 associate(c, s);
1522
1523 // compute c_child_r
1524 c_child_r = isRetainer(c) ? getRetainerFrom(c) : r;
1525 } else {
1526 // This is not the first visit to *c.
1527 if (isMember(r, retainerSetOfc))
1528 goto loop; // no need to process child
1529
1530 if (s == NULL)
1531 associate(c, addElement(r, retainerSetOfc));
1532 else {
1533 // s is not NULL and cp is not a retainer. This means that
1534 // each time *cp is visited, so is *c. Thus, if s has
1535 // exactly one more element in its retainer set than c, s
1536 // is also the new retainer set for *c.
1537 if (s->num == retainerSetOfc->num + 1) {
1538 associate(c, s);
1539 }
1540 // Otherwise, just add R_r to the current retainer set of *c.
1541 else {
1542 associate(c, addElement(r, retainerSetOfc));
1543 }
1544 }
1545
1546 if (isRetainer(c))
1547 goto loop; // no need to process child
1548
1549 // compute c_child_r
1550 c_child_r = r;
1551 }
1552
1553 // now, RSET() of all of *c, *cp, and *r is valid.
1554 // (c, c_child_r) are available.
1555
1556 // process child
1557
1558 // Special case closures: we process these all in one go rather
1559 // than attempting to save the current position, because doing so
1560 // would be hard.
1561 switch (typeOfc) {
1562 case STACK:
1563 retainStack(c, c_child_r,
1564 ((StgStack *)c)->sp,
1565 ((StgStack *)c)->stack + ((StgStack *)c)->stack_size);
1566 goto loop;
1567
1568 case TSO:
1569 {
1570 StgTSO *tso = (StgTSO *)c;
1571
1572 retainClosure((StgClosure*) tso->stackobj, c, c_child_r);
1573 retainClosure((StgClosure*) tso->blocked_exceptions, c, c_child_r);
1574 retainClosure((StgClosure*) tso->bq, c, c_child_r);
1575 retainClosure((StgClosure*) tso->trec, c, c_child_r);
1576 if ( tso->why_blocked == BlockedOnMVar
1577 || tso->why_blocked == BlockedOnMVarRead
1578 || tso->why_blocked == BlockedOnBlackHole
1579 || tso->why_blocked == BlockedOnMsgThrowTo
1580 ) {
1581 retainClosure(tso->block_info.closure, c, c_child_r);
1582 }
1583 goto loop;
1584 }
1585
1586 case BLOCKING_QUEUE:
1587 {
1588 StgBlockingQueue *bq = (StgBlockingQueue *)c;
1589 retainClosure((StgClosure*) bq->link, c, c_child_r);
1590 retainClosure((StgClosure*) bq->bh, c, c_child_r);
1591 retainClosure((StgClosure*) bq->owner, c, c_child_r);
1592 goto loop;
1593 }
1594
1595 case PAP:
1596 {
1597 StgPAP *pap = (StgPAP *)c;
1598 retain_PAP_payload(c, c_child_r, pap->fun, pap->payload, pap->n_args);
1599 goto loop;
1600 }
1601
1602 case AP:
1603 {
1604 StgAP *ap = (StgAP *)c;
1605 retain_PAP_payload(c, c_child_r, ap->fun, ap->payload, ap->n_args);
1606 goto loop;
1607 }
1608
1609 case AP_STACK:
1610 retainClosure(((StgAP_STACK *)c)->fun, c, c_child_r);
1611 retainStack(c, c_child_r,
1612 (StgPtr)((StgAP_STACK *)c)->payload,
1613 (StgPtr)((StgAP_STACK *)c)->payload +
1614 ((StgAP_STACK *)c)->size);
1615 goto loop;
1616 }
1617
1618 push(c, c_child_r, &first_child);
1619
1620 // If first_child is null, c has no child.
1621 // If first_child is not null, the top stack element points to the next
1622 // object. push() may or may not push a stackElement on the stack.
1623 if (first_child == NULL)
1624 goto loop;
1625
1626 // (c, cp, r) = (first_child, c, c_child_r)
1627 r = c_child_r;
1628 cp = c;
1629 c = first_child;
1630 goto inner_loop;
1631 }
1632
1633 /* -----------------------------------------------------------------------------
1634 * Compute the retainer set for every object reachable from *tl.
1635 * -------------------------------------------------------------------------- */
1636 static void
1637 retainRoot(void *user STG_UNUSED, StgClosure **tl)
1638 {
1639 StgClosure *c;
1640
1641 // We no longer assume that only TSOs and WEAKs are roots; any closure can
1642 // be a root.
1643
1644 ASSERT(isEmptyRetainerStack());
1645 currentStackBoundary = stackTop;
1646
1647 c = UNTAG_CLOSURE(*tl);
1648 maybeInitRetainerSet(c);
1649 if (c != &stg_END_TSO_QUEUE_closure && isRetainer(c)) {
1650 retainClosure(c, c, getRetainerFrom(c));
1651 } else {
1652 retainClosure(c, c, CCS_SYSTEM);
1653 }
1654
1655 // NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl)));
1656 // *tl might be a TSO which is ThreadComplete, in which
1657 // case we ignore it for the purposes of retainer profiling.
1658 }
1659
1660 /* -----------------------------------------------------------------------------
1661 * Compute the retainer set for each of the objects in the heap.
1662 * -------------------------------------------------------------------------- */
1663 static void
1664 computeRetainerSet( void )
1665 {
1666 StgWeak *weak;
1667 uint32_t g, n;
1668 StgPtr ml;
1669 bdescr *bd;
1670 #if defined(DEBUG_RETAINER)
1671 RetainerSet *rtl;
1672 RetainerSet tmpRetainerSet;
1673 #endif
1674
1675 markCapabilities(retainRoot, NULL); // for scheduler roots
1676
1677 // This function is called after a major GC, when key, value, and finalizer
1678 // all are guaranteed to be valid, or reachable.
1679 //
1680 // The following code assumes that WEAK objects are considered to be roots
1681 // for retainer profilng.
1682 for (n = 0; n < n_capabilities; n++) {
1683 // NB: after a GC, all nursery weak_ptr_lists have been migrated
1684 // to the global lists living in the generations
1685 ASSERT(capabilities[n]->weak_ptr_list_hd == NULL);
1686 ASSERT(capabilities[n]->weak_ptr_list_tl == NULL);
1687 }
1688 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1689 for (weak = generations[g].weak_ptr_list; weak != NULL; weak = weak->link) {
1690 // retainRoot((StgClosure *)weak);
1691 retainRoot(NULL, (StgClosure **)&weak);
1692 }
1693 }
1694
1695 // Consider roots from the stable ptr table.
1696 markStableTables(retainRoot, NULL);
1697
1698 // The following code resets the rs field of each unvisited mutable
1699 // object (computing sumOfNewCostExtra and updating costArray[] when
1700 // debugging retainer profiler).
1701 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1702 // NOT true: even G0 has a block on its mutable list
1703 // ASSERT(g != 0 || (generations[g].mut_list == NULL));
1704
1705 // Traversing through mut_list is necessary
1706 // because we can find MUT_VAR objects which have not been
1707 // visited during retainer profiling.
1708 for (n = 0; n < n_capabilities; n++) {
1709 for (bd = capabilities[n]->mut_lists[g]; bd != NULL; bd = bd->link) {
1710 for (ml = bd->start; ml < bd->free; ml++) {
1711
1712 maybeInitRetainerSet((StgClosure *)*ml);
1713
1714 #if defined(DEBUG_RETAINER)
1715 rtl = retainerSetOf((StgClosure *)*ml);
1716 if (rtl == NULL) {
1717 // first visit to *ml
1718 // This is a violation of the interface rule!
1719 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1720
1721 switch (get_itbl((StgClosure *)ml)->type) {
1722 case IND_STATIC:
1723 // no cost involved
1724 break;
1725 case CONSTR_NOCAF:
1726 case THUNK_STATIC:
1727 case FUN_STATIC:
1728 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1729 break;
1730 default:
1731 // dynamic objects
1732 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1733 sumOfNewCostExtra += cost((StgClosure *)ml);
1734 break;
1735 }
1736 }
1737 #endif
1738 }
1739 }
1740 }
1741 }
1742 }
1743
1744 /* -----------------------------------------------------------------------------
1745 * Traverse all static objects for which we compute retainer sets,
1746 * and reset their rs fields to NULL, which is accomplished by
1747 * invoking maybeInitRetainerSet(). This function must be called
1748 * before zeroing all objects reachable from scavenged_static_objects
1749 * in the case of major garbage collections. See GarbageCollect() in
1750 * GC.c.
1751 * Note:
1752 * The mut_once_list of the oldest generation must also be traversed?
1753 * Why? Because if the evacuation of an object pointed to by a static
1754 * indirection object fails, it is put back to the mut_once_list of
1755 * the oldest generation.
1756 * However, this is not necessary because any static indirection objects
1757 * are just traversed through to reach dynamic objects. In other words,
1758 * they are not taken into consideration in computing retainer sets.
1759 *
1760 * SDM (20/7/2011): I don't think this is doing anything sensible,
1761 * because it happens before retainerProfile() and at the beginning of
1762 * retainerProfil() we change the sense of 'flip'. So all of the
1763 * calls to maybeInitRetainerSet() here are initialising retainer sets
1764 * with the wrong flip. Also, I don't see why this is necessary. I
1765 * added a maybeInitRetainerSet() call to retainRoot(), and that seems
1766 * to have fixed the assertion failure in retainerSetOf() I was
1767 * encountering.
1768 * -------------------------------------------------------------------------- */
1769 void
1770 resetStaticObjectForRetainerProfiling( StgClosure *static_objects )
1771 {
1772 #if defined(DEBUG_RETAINER)
1773 uint32_t count;
1774 #endif
1775 StgClosure *p;
1776
1777 #if defined(DEBUG_RETAINER)
1778 count = 0;
1779 #endif
1780 p = static_objects;
1781 while (p != END_OF_STATIC_OBJECT_LIST) {
1782 p = UNTAG_STATIC_LIST_PTR(p);
1783 #if defined(DEBUG_RETAINER)
1784 count++;
1785 #endif
1786 switch (get_itbl(p)->type) {
1787 case IND_STATIC:
1788 // Since we do not compute the retainer set of any
1789 // IND_STATIC object, we don't have to reset its retainer
1790 // field.
1791 p = (StgClosure*)*IND_STATIC_LINK(p);
1792 break;
1793 case THUNK_STATIC:
1794 maybeInitRetainerSet(p);
1795 p = (StgClosure*)*THUNK_STATIC_LINK(p);
1796 break;
1797 case FUN_STATIC:
1798 case CONSTR:
1799 case CONSTR_1_0:
1800 case CONSTR_2_0:
1801 case CONSTR_1_1:
1802 case CONSTR_NOCAF:
1803 maybeInitRetainerSet(p);
1804 p = (StgClosure*)*STATIC_LINK(get_itbl(p), p);
1805 break;
1806 default:
1807 barf("resetStaticObjectForRetainerProfiling: %p (%s)",
1808 p, get_itbl(p)->type);
1809 break;
1810 }
1811 }
1812 #if defined(DEBUG_RETAINER)
1813 // debugBelch("count in scavenged_static_objects = %d\n", count);
1814 #endif
1815 }
1816
1817 /* -----------------------------------------------------------------------------
1818 * Perform retainer profiling.
1819 * N is the oldest generation being profilied, where the generations are
1820 * numbered starting at 0.
1821 * Invariants:
1822 * Note:
1823 * This function should be called only immediately after major garbage
1824 * collection.
1825 * ------------------------------------------------------------------------- */
1826 void
1827 retainerProfile(void)
1828 {
1829 #if defined(DEBUG_RETAINER)
1830 uint32_t i;
1831 uint32_t totalHeapSize; // total raw heap size (computed by linear scanning)
1832 #endif
1833
1834 #if defined(DEBUG_RETAINER)
1835 debugBelch(" < retainerProfile() invoked : %d>\n", retainerGeneration);
1836 #endif
1837
1838 stat_startRP();
1839
1840 // We haven't flipped the bit yet.
1841 #if defined(DEBUG_RETAINER)
1842 debugBelch("Before traversing:\n");
1843 sumOfCostLinear = 0;
1844 for (i = 0;i < N_CLOSURE_TYPES; i++)
1845 costArrayLinear[i] = 0;
1846 totalHeapSize = checkHeapSanityForRetainerProfiling();
1847
1848 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1849 /*
1850 debugBelch("costArrayLinear[] = ");
1851 for (i = 0;i < N_CLOSURE_TYPES; i++)
1852 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
1853 debugBelch("\n");
1854 */
1855
1856 ASSERT(sumOfCostLinear == totalHeapSize);
1857
1858 /*
1859 #define pcostArrayLinear(index) \
1860 if (costArrayLinear[index] > 0) \
1861 debugBelch("costArrayLinear[" #index "] = %u\n", costArrayLinear[index])
1862 pcostArrayLinear(THUNK_STATIC);
1863 pcostArrayLinear(FUN_STATIC);
1864 pcostArrayLinear(CONSTR_NOCAF);
1865 */
1866 #endif
1867
1868 // Now we flips flip.
1869 flip = flip ^ 1;
1870
1871 #if defined(DEBUG_RETAINER)
1872 stackSize = 0;
1873 maxStackSize = 0;
1874 cStackSize = 0;
1875 maxCStackSize = 0;
1876 #endif
1877 numObjectVisited = 0;
1878 timesAnyObjectVisited = 0;
1879
1880 #if defined(DEBUG_RETAINER)
1881 debugBelch("During traversing:\n");
1882 sumOfNewCost = 0;
1883 sumOfNewCostExtra = 0;
1884 for (i = 0;i < N_CLOSURE_TYPES; i++)
1885 costArray[i] = 0;
1886 #endif
1887
1888 /*
1889 We initialize the traverse stack each time the retainer profiling is
1890 performed (because the traverse stack size varies on each retainer profiling
1891 and this operation is not costly anyhow). However, we just refresh the
1892 retainer sets.
1893 */
1894 initializeTraverseStack();
1895 #if defined(DEBUG_RETAINER)
1896 initializeAllRetainerSet();
1897 #else
1898 refreshAllRetainerSet();
1899 #endif
1900 computeRetainerSet();
1901
1902 #if defined(DEBUG_RETAINER)
1903 debugBelch("After traversing:\n");
1904 sumOfCostLinear = 0;
1905 for (i = 0;i < N_CLOSURE_TYPES; i++)
1906 costArrayLinear[i] = 0;
1907 totalHeapSize = checkHeapSanityForRetainerProfiling();
1908
1909 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1910 ASSERT(sumOfCostLinear == totalHeapSize);
1911
1912 // now, compare the two results
1913 /*
1914 Note:
1915 costArray[] must be exactly the same as costArrayLinear[].
1916 Known exceptions:
1917 1) Dead weak pointers, whose type is CONSTR. These objects are not
1918 reachable from any roots.
1919 */
1920 debugBelch("Comparison:\n");
1921 debugBelch("\tcostArrayLinear[] (must be empty) = ");
1922 for (i = 0;i < N_CLOSURE_TYPES; i++)
1923 if (costArray[i] != costArrayLinear[i])
1924 // nothing should be printed except MUT_VAR after major GCs
1925 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
1926 debugBelch("\n");
1927
1928 debugBelch("\tsumOfNewCost = %u\n", sumOfNewCost);
1929 debugBelch("\tsumOfNewCostExtra = %u\n", sumOfNewCostExtra);
1930 debugBelch("\tcostArray[] (must be empty) = ");
1931 for (i = 0;i < N_CLOSURE_TYPES; i++)
1932 if (costArray[i] != costArrayLinear[i])
1933 // nothing should be printed except MUT_VAR after major GCs
1934 debugBelch("[%u:%u] ", i, costArray[i]);
1935 debugBelch("\n");
1936
1937 // only for major garbage collection
1938 ASSERT(sumOfNewCost + sumOfNewCostExtra == sumOfCostLinear);
1939 #endif
1940
1941 // post-processing
1942 closeTraverseStack();
1943 #if defined(DEBUG_RETAINER)
1944 closeAllRetainerSet();
1945 #else
1946 // Note that there is no post-processing for the retainer sets.
1947 #endif
1948 retainerGeneration++;
1949
1950 stat_endRP(
1951 retainerGeneration - 1, // retainerGeneration has just been incremented!
1952 #if defined(DEBUG_RETAINER)
1953 maxCStackSize, maxStackSize,
1954 #endif
1955 (double)timesAnyObjectVisited / numObjectVisited);
1956 }
1957
1958 /* -----------------------------------------------------------------------------
1959 * DEBUGGING CODE
1960 * -------------------------------------------------------------------------- */
1961
1962 #if defined(DEBUG_RETAINER)
1963
1964 #define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
1965 (HEAP_ALLOCED(r))) && \
1966 ((StgWord)(*(StgPtr)r)!=(StgWord)0xaaaaaaaaaaaaaaaaULL))
1967
1968 static uint32_t
1969 sanityCheckHeapClosure( StgClosure *c )
1970 {
1971 ASSERT(LOOKS_LIKE_GHC_INFO(c->header.info));
1972 ASSERT(LOOKS_LIKE_PTR(c));
1973
1974 if ((((StgWord)RSET(c) & 1) ^ flip) != 0) {
1975 if (get_itbl(c)->type == CONSTR &&
1976 !strcmp(GET_PROF_TYPE(get_itbl(c)), "DEAD_WEAK") &&
1977 !strcmp(GET_PROF_DESC(get_itbl(c)), "DEAD_WEAK")) {
1978 debugBelch("\tUnvisited dead weak pointer object found: c = %p\n", c);
1979 costArray[get_itbl(c)->type] += cost(c);
1980 sumOfNewCost += cost(c);
1981 } else
1982 debugBelch(
1983 "Unvisited object: flip = %d, c = %p(%d, %s, %s), rs = %p\n",
1984 flip, c, get_itbl(c)->type,
1985 get_itbl(c)->prof.closure_type, GET_PROF_DESC(get_itbl(c)),
1986 RSET(c));
1987 } else {
1988 // debugBelch("sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c));
1989 }
1990
1991 return closure_sizeW(c);
1992 }
1993
1994 static uint32_t
1995 heapCheck( bdescr *bd )
1996 {
1997 StgPtr p;
1998 static uint32_t costSum, size;
1999
2000 costSum = 0;
2001 while (bd != NULL) {
2002 p = bd->start;
2003 while (p < bd->free) {
2004 size = sanityCheckHeapClosure((StgClosure *)p);
2005 sumOfCostLinear += size;
2006 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2007 p += size;
2008 // no need for slop check; I think slops are not used currently.
2009 }
2010 ASSERT(p == bd->free);
2011 costSum += bd->free - bd->start;
2012 bd = bd->link;
2013 }
2014
2015 return costSum;
2016 }
2017
2018 static uint32_t
2019 smallObjectPoolCheck(void)
2020 {
2021 bdescr *bd;
2022 StgPtr p;
2023 static uint32_t costSum, size;
2024
2025 bd = g0s0->blocks;
2026 costSum = 0;
2027
2028 // first block
2029 if (bd == NULL)
2030 return costSum;
2031
2032 p = bd->start;
2033 while (p < alloc_Hp) {
2034 size = sanityCheckHeapClosure((StgClosure *)p);
2035 sumOfCostLinear += size;
2036 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2037 p += size;
2038 }
2039 ASSERT(p == alloc_Hp);
2040 costSum += alloc_Hp - bd->start;
2041
2042 bd = bd->link;
2043 while (bd != NULL) {
2044 p = bd->start;
2045 while (p < bd->free) {
2046 size = sanityCheckHeapClosure((StgClosure *)p);
2047 sumOfCostLinear += size;
2048 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2049 p += size;
2050 }
2051 ASSERT(p == bd->free);
2052 costSum += bd->free - bd->start;
2053 bd = bd->link;
2054 }
2055
2056 return costSum;
2057 }
2058
2059 static uint32_t
2060 chainCheck(bdescr *bd)
2061 {
2062 uint32_t costSum, size;
2063
2064 costSum = 0;
2065 while (bd != NULL) {
2066 // bd->free - bd->start is not an accurate measurement of the
2067 // object size. Actually it is always zero, so we compute its
2068 // size explicitly.
2069 size = sanityCheckHeapClosure((StgClosure *)bd->start);
2070 sumOfCostLinear += size;
2071 costArrayLinear[get_itbl((StgClosure *)bd->start)->type] += size;
2072 costSum += size;
2073 bd = bd->link;
2074 }
2075
2076 return costSum;
2077 }
2078
2079 static uint32_t
2080 checkHeapSanityForRetainerProfiling( void )
2081 {
2082 uint32_t costSum, g, s;
2083
2084 costSum = 0;
2085 debugBelch("START: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2086 if (RtsFlags.GcFlags.generations == 1) {
2087 costSum += heapCheck(g0s0->to_blocks);
2088 debugBelch("heapCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2089 costSum += chainCheck(g0s0->large_objects);
2090 debugBelch("chainCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2091 } else {
2092 for (g = 0; g < RtsFlags.GcFlags.generations; g++)
2093 for (s = 0; s < generations[g].n_steps; s++) {
2094 /*
2095 After all live objects have been scavenged, the garbage
2096 collector may create some objects in
2097 scheduleFinalizers(). These objects are created through
2098 allocate(), so the small object pool or the large object
2099 pool of the g0s0 may not be empty.
2100 */
2101 if (g == 0 && s == 0) {
2102 costSum += smallObjectPoolCheck();
2103 debugBelch("smallObjectPoolCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2104 costSum += chainCheck(generations[g].steps[s].large_objects);
2105 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2106 } else {
2107 costSum += heapCheck(generations[g].steps[s].blocks);
2108 debugBelch("heapCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2109 costSum += chainCheck(generations[g].steps[s].large_objects);
2110 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2111 }
2112 }
2113 }
2114
2115 return costSum;
2116 }
2117
2118 void
2119 findPointer(StgPtr p)
2120 {
2121 StgPtr q, r, e;
2122 bdescr *bd;
2123 uint32_t g, s;
2124
2125 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2126 for (s = 0; s < generations[g].n_steps; s++) {
2127 // if (g == 0 && s == 0) continue;
2128 bd = generations[g].steps[s].blocks;
2129 for (; bd; bd = bd->link) {
2130 for (q = bd->start; q < bd->free; q++) {
2131 if (*q == (StgWord)p) {
2132 r = q;
2133 while (!LOOKS_LIKE_GHC_INFO(*r)) r--;
2134 debugBelch("Found in gen[%d], step[%d]: q = %p, r = %p\n", g, s, q, r);
2135 // return;
2136 }
2137 }
2138 }
2139 bd = generations[g].steps[s].large_objects;
2140 for (; bd; bd = bd->link) {
2141 e = bd->start + cost((StgClosure *)bd->start);
2142 for (q = bd->start; q < e; q++) {
2143 if (*q == (StgWord)p) {
2144 r = q;
2145 while (*r == 0 || !LOOKS_LIKE_GHC_INFO(*r)) r--;
2146 debugBelch("Found in gen[%d], large_objects: %p\n", g, r);
2147 // return;
2148 }
2149 }
2150 }
2151 }
2152 }
2153 }
2154
2155 static void
2156 belongToHeap(StgPtr p)
2157 {
2158 bdescr *bd;
2159 uint32_t g, s;
2160
2161 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2162 for (s = 0; s < generations[g].n_steps; s++) {
2163 // if (g == 0 && s == 0) continue;
2164 bd = generations[g].steps[s].blocks;
2165 for (; bd; bd = bd->link) {
2166 if (bd->start <= p && p < bd->free) {
2167 debugBelch("Belongs to gen[%d], step[%d]", g, s);
2168 return;
2169 }
2170 }
2171 bd = generations[g].steps[s].large_objects;
2172 for (; bd; bd = bd->link) {
2173 if (bd->start <= p && p < bd->start + getHeapClosureSize((StgClosure *)bd->start)) {
2174 debugBelch("Found in gen[%d], large_objects: %p\n", g, bd->start);
2175 return;
2176 }
2177 }
2178 }
2179 }
2180 }
2181 #endif /* DEBUG_RETAINER */
2182
2183 #endif /* PROFILING */