Building GHC with hadrian on FreeBSD
[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 "StablePtr.h" /* markStablePtrTable */
34 #include "StableName.h" /* rememberOldStableNameAddresses */
35 #include "sm/Storage.h" // for END_OF_STATIC_LIST
36
37 /* Note [What is a retainer?]
38 ~~~~~~~~~~~~~~~~~~~~~~~~~~
39 The definition of what sorts of things are counted as retainers is a bit hard to
40 pin down. Intuitively, we want to identify closures which will help the user
41 identify memory leaks due to thunks. In practice we also end up lumping mutable
42 objects in this group for reasons that have been lost to time.
43
44 The definition of retainer is implemented in isRetainer(), defined later in this
45 file.
46 */
47
48
49 /*
50 Note: what to change in order to plug-in a new retainer profiling scheme?
51 (1) type retainer in ../includes/StgRetainerProf.h
52 (2) retainer function R(), i.e., getRetainerFrom()
53 (3) the two hashing functions, hashKeySingleton() and hashKeyAddElement(),
54 in RetainerSet.h, if needed.
55 (4) printRetainer() and printRetainerSetShort() in RetainerSet.c.
56 */
57
58 /* -----------------------------------------------------------------------------
59 * Declarations...
60 * -------------------------------------------------------------------------- */
61
62 static uint32_t retainerGeneration; // generation
63
64 static uint32_t numObjectVisited; // total number of objects visited
65 static uint32_t timesAnyObjectVisited; // number of times any objects are
66 // visited
67
68 /*
69 The rs field in the profile header of any object points to its retainer
70 set in an indirect way: if flip is 0, it points to the retainer set;
71 if flip is 1, it points to the next byte after the retainer set (even
72 for NULL pointers). Therefore, with flip 1, (rs ^ 1) is the actual
73 pointer. See retainerSetOf().
74 */
75
76 StgWord flip = 0; // flip bit
77 // must be 0 if DEBUG_RETAINER is on (for static closures)
78
79 #define setRetainerSetToNull(c) \
80 (c)->header.prof.hp.rs = (RetainerSet *)((StgWord)NULL | flip)
81
82 static void retainStack(StgClosure *, retainer, StgPtr, StgPtr);
83 static void retainClosure(StgClosure *, StgClosure *, retainer);
84 #if defined(DEBUG_RETAINER)
85 static void belongToHeap(StgPtr p);
86 #endif
87
88 #if defined(DEBUG_RETAINER)
89 /*
90 cStackSize records how many times retainStack() has been invoked recursively,
91 that is, the number of activation records for retainStack() on the C stack.
92 maxCStackSize records its max value.
93 Invariants:
94 cStackSize <= maxCStackSize
95 */
96 static uint32_t cStackSize, maxCStackSize;
97
98 static uint32_t sumOfNewCost; // sum of the cost of each object, computed
99 // when the object is first visited
100 static uint32_t sumOfNewCostExtra; // for those objects not visited during
101 // retainer profiling, e.g., MUT_VAR
102 static uint32_t costArray[N_CLOSURE_TYPES];
103
104 uint32_t sumOfCostLinear; // sum of the costs of all object, computed
105 // when linearly traversing the heap after
106 // retainer profiling
107 uint32_t costArrayLinear[N_CLOSURE_TYPES];
108 #endif
109
110 /* -----------------------------------------------------------------------------
111 * Retainer stack - header
112 * Note:
113 * Although the retainer stack implementation could be separated *
114 * from the retainer profiling engine, there does not seem to be
115 * any advantage in doing that; retainer stack is an integral part
116 * of retainer profiling engine and cannot be use elsewhere at
117 * all.
118 * -------------------------------------------------------------------------- */
119
120 typedef enum {
121 posTypeStep,
122 posTypePtrs,
123 posTypeSRT,
124 } nextPosType;
125
126 typedef union {
127 // fixed layout or layout specified by a field in the closure
128 StgWord step;
129
130 // layout.payload
131 struct {
132 // See StgClosureInfo in InfoTables.h
133 StgHalfWord pos;
134 StgHalfWord ptrs;
135 StgPtr payload;
136 } ptrs;
137
138 // SRT
139 struct {
140 StgClosure *srt;
141 } srt;
142 } nextPos;
143
144 typedef struct {
145 nextPosType type;
146 nextPos next;
147 } stackPos;
148
149 typedef struct {
150 StgClosure *c;
151 retainer c_child_r;
152 stackPos info;
153 } stackElement;
154
155 /*
156 Invariants:
157 firstStack points to the first block group.
158 currentStack points to the block group currently being used.
159 currentStack->free == stackLimit.
160 stackTop points to the topmost byte in the stack of currentStack.
161 Unless the whole stack is empty, stackTop must point to the topmost
162 object (or byte) in the whole stack. Thus, it is only when the whole stack
163 is empty that stackTop == stackLimit (not during the execution of push()
164 and pop()).
165 stackBottom == currentStack->start.
166 stackLimit == currentStack->start + BLOCK_SIZE_W * currentStack->blocks.
167 Note:
168 When a current stack becomes empty, stackTop is set to point to
169 the topmost element on the previous block group so as to satisfy
170 the invariants described above.
171 */
172 static bdescr *firstStack = NULL;
173 static bdescr *currentStack;
174 static stackElement *stackBottom, *stackTop, *stackLimit;
175
176 /*
177 currentStackBoundary is used to mark the current stack chunk.
178 If stackTop == currentStackBoundary, it means that the current stack chunk
179 is empty. It is the responsibility of the user to keep currentStackBoundary
180 valid all the time if it is to be employed.
181 */
182 static stackElement *currentStackBoundary;
183
184 /*
185 stackSize records the current size of the stack.
186 maxStackSize records its high water mark.
187 Invariants:
188 stackSize <= maxStackSize
189 Note:
190 stackSize is just an estimate measure of the depth of the graph. The reason
191 is that some heap objects have only a single child and may not result
192 in a new element being pushed onto the stack. Therefore, at the end of
193 retainer profiling, maxStackSize + maxCStackSize is some value no greater
194 than the actual depth of the graph.
195 */
196 #if defined(DEBUG_RETAINER)
197 static int stackSize, maxStackSize;
198 #endif
199
200 // number of blocks allocated for one stack
201 #define BLOCKS_IN_STACK 1
202
203 /* -----------------------------------------------------------------------------
204 * Add a new block group to the stack.
205 * Invariants:
206 * currentStack->link == s.
207 * -------------------------------------------------------------------------- */
208 static INLINE void
209 newStackBlock( bdescr *bd )
210 {
211 currentStack = bd;
212 stackTop = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
213 stackBottom = (stackElement *)bd->start;
214 stackLimit = (stackElement *)stackTop;
215 bd->free = (StgPtr)stackLimit;
216 }
217
218 /* -----------------------------------------------------------------------------
219 * Return to the previous block group.
220 * Invariants:
221 * s->link == currentStack.
222 * -------------------------------------------------------------------------- */
223 static INLINE void
224 returnToOldStack( bdescr *bd )
225 {
226 currentStack = bd;
227 stackTop = (stackElement *)bd->free;
228 stackBottom = (stackElement *)bd->start;
229 stackLimit = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
230 bd->free = (StgPtr)stackLimit;
231 }
232
233 /* -----------------------------------------------------------------------------
234 * Initializes the traverse stack.
235 * -------------------------------------------------------------------------- */
236 static void
237 initializeTraverseStack( void )
238 {
239 if (firstStack != NULL) {
240 freeChain(firstStack);
241 }
242
243 firstStack = allocGroup(BLOCKS_IN_STACK);
244 firstStack->link = NULL;
245 firstStack->u.back = NULL;
246
247 newStackBlock(firstStack);
248 }
249
250 /* -----------------------------------------------------------------------------
251 * Frees all the block groups in the traverse stack.
252 * Invariants:
253 * firstStack != NULL
254 * -------------------------------------------------------------------------- */
255 static void
256 closeTraverseStack( void )
257 {
258 freeChain(firstStack);
259 firstStack = NULL;
260 }
261
262 /* -----------------------------------------------------------------------------
263 * Returns true if the whole stack is empty.
264 * -------------------------------------------------------------------------- */
265 static INLINE bool
266 isEmptyRetainerStack( void )
267 {
268 return (firstStack == currentStack) && stackTop == stackLimit;
269 }
270
271 /* -----------------------------------------------------------------------------
272 * Returns size of stack
273 * -------------------------------------------------------------------------- */
274 W_
275 retainerStackBlocks( void )
276 {
277 bdescr* bd;
278 W_ res = 0;
279
280 for (bd = firstStack; bd != NULL; bd = bd->link)
281 res += bd->blocks;
282
283 return res;
284 }
285
286 /* -----------------------------------------------------------------------------
287 * Returns true if stackTop is at the stack boundary of the current stack,
288 * i.e., if the current stack chunk is empty.
289 * -------------------------------------------------------------------------- */
290 static INLINE bool
291 isOnBoundary( void )
292 {
293 return stackTop == currentStackBoundary;
294 }
295
296 /* -----------------------------------------------------------------------------
297 * Initializes *info from ptrs and payload.
298 * Invariants:
299 * payload[] begins with ptrs pointers followed by non-pointers.
300 * -------------------------------------------------------------------------- */
301 static INLINE void
302 init_ptrs( stackPos *info, uint32_t ptrs, StgPtr payload )
303 {
304 info->type = posTypePtrs;
305 info->next.ptrs.pos = 0;
306 info->next.ptrs.ptrs = ptrs;
307 info->next.ptrs.payload = payload;
308 }
309
310 /* -----------------------------------------------------------------------------
311 * Find the next object from *info.
312 * -------------------------------------------------------------------------- */
313 static INLINE StgClosure *
314 find_ptrs( stackPos *info )
315 {
316 if (info->next.ptrs.pos < info->next.ptrs.ptrs) {
317 return (StgClosure *)info->next.ptrs.payload[info->next.ptrs.pos++];
318 } else {
319 return NULL;
320 }
321 }
322
323 /* -----------------------------------------------------------------------------
324 * Initializes *info from SRT information stored in *infoTable.
325 * -------------------------------------------------------------------------- */
326 static INLINE void
327 init_srt_fun( stackPos *info, const StgFunInfoTable *infoTable )
328 {
329 info->type = posTypeSRT;
330 if (infoTable->i.srt) {
331 info->next.srt.srt = (StgClosure*)GET_FUN_SRT(infoTable);
332 } else {
333 info->next.srt.srt = NULL;
334 }
335 }
336
337 static INLINE void
338 init_srt_thunk( stackPos *info, const StgThunkInfoTable *infoTable )
339 {
340 info->type = posTypeSRT;
341 if (infoTable->i.srt) {
342 info->next.srt.srt = (StgClosure*)GET_SRT(infoTable);
343 } else {
344 info->next.srt.srt = NULL;
345 }
346 }
347
348 /* -----------------------------------------------------------------------------
349 * Find the next object from *info.
350 * -------------------------------------------------------------------------- */
351 static INLINE StgClosure *
352 find_srt( stackPos *info )
353 {
354 StgClosure *c;
355 if (info->type == posTypeSRT) {
356 c = info->next.srt.srt;
357 info->next.srt.srt = NULL;
358 return c;
359 }
360 }
361
362 /* -----------------------------------------------------------------------------
363 * push() pushes a stackElement representing the next child of *c
364 * onto the traverse stack. If *c has no child, *first_child is set
365 * to NULL and nothing is pushed onto the stack. If *c has only one
366 * child, *c_child is set to that child and nothing is pushed onto
367 * the stack. If *c has more than two children, *first_child is set
368 * to the first child and a stackElement representing the second
369 * child is pushed onto the stack.
370
371 * Invariants:
372 * *c_child_r is the most recent retainer of *c's children.
373 * *c is not any of TSO, AP, PAP, AP_STACK, which means that
374 * there cannot be any stack objects.
375 * Note: SRTs are considered to be children as well.
376 * -------------------------------------------------------------------------- */
377 static INLINE void
378 push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
379 {
380 stackElement se;
381 bdescr *nbd; // Next Block Descriptor
382
383 #if defined(DEBUG_RETAINER)
384 // debugBelch("push(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
385 #endif
386
387 ASSERT(get_itbl(c)->type != TSO);
388 ASSERT(get_itbl(c)->type != AP_STACK);
389
390 //
391 // fill in se
392 //
393
394 se.c = c;
395 se.c_child_r = c_child_r;
396
397 // fill in se.info
398 switch (get_itbl(c)->type) {
399 // no child, no SRT
400 case CONSTR_0_1:
401 case CONSTR_0_2:
402 case ARR_WORDS:
403 case COMPACT_NFDATA:
404 *first_child = NULL;
405 return;
406
407 // one child (fixed), no SRT
408 case MUT_VAR_CLEAN:
409 case MUT_VAR_DIRTY:
410 *first_child = ((StgMutVar *)c)->var;
411 return;
412 case THUNK_SELECTOR:
413 *first_child = ((StgSelector *)c)->selectee;
414 return;
415 case BLACKHOLE:
416 *first_child = ((StgInd *)c)->indirectee;
417 return;
418 case CONSTR_1_0:
419 case CONSTR_1_1:
420 *first_child = c->payload[0];
421 return;
422
423 // For CONSTR_2_0 and MVAR, we use se.info.step to record the position
424 // of the next child. We do not write a separate initialization code.
425 // Also we do not have to initialize info.type;
426
427 // two children (fixed), no SRT
428 // need to push a stackElement, but nothing to store in se.info
429 case CONSTR_2_0:
430 *first_child = c->payload[0]; // return the first pointer
431 // se.info.type = posTypeStep;
432 // se.info.next.step = 2; // 2 = second
433 break;
434
435 // three children (fixed), no SRT
436 // need to push a stackElement
437 case MVAR_CLEAN:
438 case MVAR_DIRTY:
439 // head must be TSO and the head of a linked list of TSOs.
440 // Shoule it be a child? Seems to be yes.
441 *first_child = (StgClosure *)((StgMVar *)c)->head;
442 // se.info.type = posTypeStep;
443 se.info.next.step = 2; // 2 = second
444 break;
445
446 // three children (fixed), no SRT
447 case WEAK:
448 *first_child = ((StgWeak *)c)->key;
449 // se.info.type = posTypeStep;
450 se.info.next.step = 2;
451 break;
452
453 // layout.payload.ptrs, no SRT
454 case TVAR:
455 case CONSTR:
456 case CONSTR_NOCAF:
457 case PRIM:
458 case MUT_PRIM:
459 case BCO:
460 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
461 (StgPtr)c->payload);
462 *first_child = find_ptrs(&se.info);
463 if (*first_child == NULL)
464 return; // no child
465 break;
466
467 // StgMutArrPtr.ptrs, no SRT
468 case MUT_ARR_PTRS_CLEAN:
469 case MUT_ARR_PTRS_DIRTY:
470 case MUT_ARR_PTRS_FROZEN_CLEAN:
471 case MUT_ARR_PTRS_FROZEN_DIRTY:
472 init_ptrs(&se.info, ((StgMutArrPtrs *)c)->ptrs,
473 (StgPtr)(((StgMutArrPtrs *)c)->payload));
474 *first_child = find_ptrs(&se.info);
475 if (*first_child == NULL)
476 return;
477 break;
478
479 // StgMutArrPtr.ptrs, no SRT
480 case SMALL_MUT_ARR_PTRS_CLEAN:
481 case SMALL_MUT_ARR_PTRS_DIRTY:
482 case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
483 case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:
484 init_ptrs(&se.info, ((StgSmallMutArrPtrs *)c)->ptrs,
485 (StgPtr)(((StgSmallMutArrPtrs *)c)->payload));
486 *first_child = find_ptrs(&se.info);
487 if (*first_child == NULL)
488 return;
489 break;
490
491 // layout.payload.ptrs, SRT
492 case FUN_STATIC:
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 markStablePtrTable(retainRoot, NULL);
1697 // Remember old stable name addresses.
1698 rememberOldStableNameAddresses ();
1699
1700 // The following code resets the rs field of each unvisited mutable
1701 // object (computing sumOfNewCostExtra and updating costArray[] when
1702 // debugging retainer profiler).
1703 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1704 // NOT true: even G0 has a block on its mutable list
1705 // ASSERT(g != 0 || (generations[g].mut_list == NULL));
1706
1707 // Traversing through mut_list is necessary
1708 // because we can find MUT_VAR objects which have not been
1709 // visited during retainer profiling.
1710 for (n = 0; n < n_capabilities; n++) {
1711 for (bd = capabilities[n]->mut_lists[g]; bd != NULL; bd = bd->link) {
1712 for (ml = bd->start; ml < bd->free; ml++) {
1713
1714 maybeInitRetainerSet((StgClosure *)*ml);
1715
1716 #if defined(DEBUG_RETAINER)
1717 rtl = retainerSetOf((StgClosure *)*ml);
1718 if (rtl == NULL) {
1719 // first visit to *ml
1720 // This is a violation of the interface rule!
1721 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1722
1723 switch (get_itbl((StgClosure *)ml)->type) {
1724 case IND_STATIC:
1725 // no cost involved
1726 break;
1727 case CONSTR_NOCAF:
1728 case THUNK_STATIC:
1729 case FUN_STATIC:
1730 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1731 break;
1732 default:
1733 // dynamic objects
1734 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1735 sumOfNewCostExtra += cost((StgClosure *)ml);
1736 break;
1737 }
1738 }
1739 #endif
1740 }
1741 }
1742 }
1743 }
1744 }
1745
1746 /* -----------------------------------------------------------------------------
1747 * Traverse all static objects for which we compute retainer sets,
1748 * and reset their rs fields to NULL, which is accomplished by
1749 * invoking maybeInitRetainerSet(). This function must be called
1750 * before zeroing all objects reachable from scavenged_static_objects
1751 * in the case of major garbage collections. See GarbageCollect() in
1752 * GC.c.
1753 * Note:
1754 * The mut_once_list of the oldest generation must also be traversed?
1755 * Why? Because if the evacuation of an object pointed to by a static
1756 * indirection object fails, it is put back to the mut_once_list of
1757 * the oldest generation.
1758 * However, this is not necessary because any static indirection objects
1759 * are just traversed through to reach dynamic objects. In other words,
1760 * they are not taken into consideration in computing retainer sets.
1761 *
1762 * SDM (20/7/2011): I don't think this is doing anything sensible,
1763 * because it happens before retainerProfile() and at the beginning of
1764 * retainerProfil() we change the sense of 'flip'. So all of the
1765 * calls to maybeInitRetainerSet() here are initialising retainer sets
1766 * with the wrong flip. Also, I don't see why this is necessary. I
1767 * added a maybeInitRetainerSet() call to retainRoot(), and that seems
1768 * to have fixed the assertion failure in retainerSetOf() I was
1769 * encountering.
1770 * -------------------------------------------------------------------------- */
1771 void
1772 resetStaticObjectForRetainerProfiling( StgClosure *static_objects )
1773 {
1774 #if defined(DEBUG_RETAINER)
1775 uint32_t count;
1776 #endif
1777 StgClosure *p;
1778
1779 #if defined(DEBUG_RETAINER)
1780 count = 0;
1781 #endif
1782 p = static_objects;
1783 while (p != END_OF_STATIC_OBJECT_LIST) {
1784 p = UNTAG_STATIC_LIST_PTR(p);
1785 #if defined(DEBUG_RETAINER)
1786 count++;
1787 #endif
1788 switch (get_itbl(p)->type) {
1789 case IND_STATIC:
1790 // Since we do not compute the retainer set of any
1791 // IND_STATIC object, we don't have to reset its retainer
1792 // field.
1793 p = (StgClosure*)*IND_STATIC_LINK(p);
1794 break;
1795 case THUNK_STATIC:
1796 maybeInitRetainerSet(p);
1797 p = (StgClosure*)*THUNK_STATIC_LINK(p);
1798 break;
1799 case FUN_STATIC:
1800 case CONSTR:
1801 case CONSTR_1_0:
1802 case CONSTR_2_0:
1803 case CONSTR_1_1:
1804 case CONSTR_NOCAF:
1805 maybeInitRetainerSet(p);
1806 p = (StgClosure*)*STATIC_LINK(get_itbl(p), p);
1807 break;
1808 default:
1809 barf("resetStaticObjectForRetainerProfiling: %p (%s)",
1810 p, get_itbl(p)->type);
1811 break;
1812 }
1813 }
1814 #if defined(DEBUG_RETAINER)
1815 // debugBelch("count in scavenged_static_objects = %d\n", count);
1816 #endif
1817 }
1818
1819 /* -----------------------------------------------------------------------------
1820 * Perform retainer profiling.
1821 * N is the oldest generation being profilied, where the generations are
1822 * numbered starting at 0.
1823 * Invariants:
1824 * Note:
1825 * This function should be called only immediately after major garbage
1826 * collection.
1827 * ------------------------------------------------------------------------- */
1828 void
1829 retainerProfile(void)
1830 {
1831 #if defined(DEBUG_RETAINER)
1832 uint32_t i;
1833 uint32_t totalHeapSize; // total raw heap size (computed by linear scanning)
1834 #endif
1835
1836 #if defined(DEBUG_RETAINER)
1837 debugBelch(" < retainerProfile() invoked : %d>\n", retainerGeneration);
1838 #endif
1839
1840 stat_startRP();
1841
1842 // We haven't flipped the bit yet.
1843 #if defined(DEBUG_RETAINER)
1844 debugBelch("Before traversing:\n");
1845 sumOfCostLinear = 0;
1846 for (i = 0;i < N_CLOSURE_TYPES; i++)
1847 costArrayLinear[i] = 0;
1848 totalHeapSize = checkHeapSanityForRetainerProfiling();
1849
1850 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1851 /*
1852 debugBelch("costArrayLinear[] = ");
1853 for (i = 0;i < N_CLOSURE_TYPES; i++)
1854 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
1855 debugBelch("\n");
1856 */
1857
1858 ASSERT(sumOfCostLinear == totalHeapSize);
1859
1860 /*
1861 #define pcostArrayLinear(index) \
1862 if (costArrayLinear[index] > 0) \
1863 debugBelch("costArrayLinear[" #index "] = %u\n", costArrayLinear[index])
1864 pcostArrayLinear(THUNK_STATIC);
1865 pcostArrayLinear(FUN_STATIC);
1866 pcostArrayLinear(CONSTR_NOCAF);
1867 */
1868 #endif
1869
1870 // Now we flips flip.
1871 flip = flip ^ 1;
1872
1873 #if defined(DEBUG_RETAINER)
1874 stackSize = 0;
1875 maxStackSize = 0;
1876 cStackSize = 0;
1877 maxCStackSize = 0;
1878 #endif
1879 numObjectVisited = 0;
1880 timesAnyObjectVisited = 0;
1881
1882 #if defined(DEBUG_RETAINER)
1883 debugBelch("During traversing:\n");
1884 sumOfNewCost = 0;
1885 sumOfNewCostExtra = 0;
1886 for (i = 0;i < N_CLOSURE_TYPES; i++)
1887 costArray[i] = 0;
1888 #endif
1889
1890 /*
1891 We initialize the traverse stack each time the retainer profiling is
1892 performed (because the traverse stack size varies on each retainer profiling
1893 and this operation is not costly anyhow). However, we just refresh the
1894 retainer sets.
1895 */
1896 initializeTraverseStack();
1897 #if defined(DEBUG_RETAINER)
1898 initializeAllRetainerSet();
1899 #else
1900 refreshAllRetainerSet();
1901 #endif
1902 computeRetainerSet();
1903
1904 #if defined(DEBUG_RETAINER)
1905 debugBelch("After traversing:\n");
1906 sumOfCostLinear = 0;
1907 for (i = 0;i < N_CLOSURE_TYPES; i++)
1908 costArrayLinear[i] = 0;
1909 totalHeapSize = checkHeapSanityForRetainerProfiling();
1910
1911 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1912 ASSERT(sumOfCostLinear == totalHeapSize);
1913
1914 // now, compare the two results
1915 /*
1916 Note:
1917 costArray[] must be exactly the same as costArrayLinear[].
1918 Known exceptions:
1919 1) Dead weak pointers, whose type is CONSTR. These objects are not
1920 reachable from any roots.
1921 */
1922 debugBelch("Comparison:\n");
1923 debugBelch("\tcostArrayLinear[] (must be empty) = ");
1924 for (i = 0;i < N_CLOSURE_TYPES; i++)
1925 if (costArray[i] != costArrayLinear[i])
1926 // nothing should be printed except MUT_VAR after major GCs
1927 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
1928 debugBelch("\n");
1929
1930 debugBelch("\tsumOfNewCost = %u\n", sumOfNewCost);
1931 debugBelch("\tsumOfNewCostExtra = %u\n", sumOfNewCostExtra);
1932 debugBelch("\tcostArray[] (must be empty) = ");
1933 for (i = 0;i < N_CLOSURE_TYPES; i++)
1934 if (costArray[i] != costArrayLinear[i])
1935 // nothing should be printed except MUT_VAR after major GCs
1936 debugBelch("[%u:%u] ", i, costArray[i]);
1937 debugBelch("\n");
1938
1939 // only for major garbage collection
1940 ASSERT(sumOfNewCost + sumOfNewCostExtra == sumOfCostLinear);
1941 #endif
1942
1943 // post-processing
1944 closeTraverseStack();
1945 #if defined(DEBUG_RETAINER)
1946 closeAllRetainerSet();
1947 #else
1948 // Note that there is no post-processing for the retainer sets.
1949 #endif
1950 retainerGeneration++;
1951
1952 stat_endRP(
1953 retainerGeneration - 1, // retainerGeneration has just been incremented!
1954 #if defined(DEBUG_RETAINER)
1955 maxCStackSize, maxStackSize,
1956 #endif
1957 (double)timesAnyObjectVisited / numObjectVisited);
1958 }
1959
1960 /* -----------------------------------------------------------------------------
1961 * DEBUGGING CODE
1962 * -------------------------------------------------------------------------- */
1963
1964 #if defined(DEBUG_RETAINER)
1965
1966 #define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
1967 (HEAP_ALLOCED(r))) && \
1968 ((StgWord)(*(StgPtr)r)!=(StgWord)0xaaaaaaaaaaaaaaaaULL))
1969
1970 static uint32_t
1971 sanityCheckHeapClosure( StgClosure *c )
1972 {
1973 ASSERT(LOOKS_LIKE_GHC_INFO(c->header.info));
1974 ASSERT(LOOKS_LIKE_PTR(c));
1975
1976 if ((((StgWord)RSET(c) & 1) ^ flip) != 0) {
1977 if (get_itbl(c)->type == CONSTR &&
1978 !strcmp(GET_PROF_TYPE(get_itbl(c)), "DEAD_WEAK") &&
1979 !strcmp(GET_PROF_DESC(get_itbl(c)), "DEAD_WEAK")) {
1980 debugBelch("\tUnvisited dead weak pointer object found: c = %p\n", c);
1981 costArray[get_itbl(c)->type] += cost(c);
1982 sumOfNewCost += cost(c);
1983 } else
1984 debugBelch(
1985 "Unvisited object: flip = %d, c = %p(%d, %s, %s), rs = %p\n",
1986 flip, c, get_itbl(c)->type,
1987 get_itbl(c)->prof.closure_type, GET_PROF_DESC(get_itbl(c)),
1988 RSET(c));
1989 } else {
1990 // debugBelch("sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c));
1991 }
1992
1993 return closure_sizeW(c);
1994 }
1995
1996 static uint32_t
1997 heapCheck( bdescr *bd )
1998 {
1999 StgPtr p;
2000 static uint32_t costSum, size;
2001
2002 costSum = 0;
2003 while (bd != NULL) {
2004 p = bd->start;
2005 while (p < bd->free) {
2006 size = sanityCheckHeapClosure((StgClosure *)p);
2007 sumOfCostLinear += size;
2008 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2009 p += size;
2010 // no need for slop check; I think slops are not used currently.
2011 }
2012 ASSERT(p == bd->free);
2013 costSum += bd->free - bd->start;
2014 bd = bd->link;
2015 }
2016
2017 return costSum;
2018 }
2019
2020 static uint32_t
2021 smallObjectPoolCheck(void)
2022 {
2023 bdescr *bd;
2024 StgPtr p;
2025 static uint32_t costSum, size;
2026
2027 bd = g0s0->blocks;
2028 costSum = 0;
2029
2030 // first block
2031 if (bd == NULL)
2032 return costSum;
2033
2034 p = bd->start;
2035 while (p < alloc_Hp) {
2036 size = sanityCheckHeapClosure((StgClosure *)p);
2037 sumOfCostLinear += size;
2038 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2039 p += size;
2040 }
2041 ASSERT(p == alloc_Hp);
2042 costSum += alloc_Hp - bd->start;
2043
2044 bd = bd->link;
2045 while (bd != NULL) {
2046 p = bd->start;
2047 while (p < bd->free) {
2048 size = sanityCheckHeapClosure((StgClosure *)p);
2049 sumOfCostLinear += size;
2050 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2051 p += size;
2052 }
2053 ASSERT(p == bd->free);
2054 costSum += bd->free - bd->start;
2055 bd = bd->link;
2056 }
2057
2058 return costSum;
2059 }
2060
2061 static uint32_t
2062 chainCheck(bdescr *bd)
2063 {
2064 uint32_t costSum, size;
2065
2066 costSum = 0;
2067 while (bd != NULL) {
2068 // bd->free - bd->start is not an accurate measurement of the
2069 // object size. Actually it is always zero, so we compute its
2070 // size explicitly.
2071 size = sanityCheckHeapClosure((StgClosure *)bd->start);
2072 sumOfCostLinear += size;
2073 costArrayLinear[get_itbl((StgClosure *)bd->start)->type] += size;
2074 costSum += size;
2075 bd = bd->link;
2076 }
2077
2078 return costSum;
2079 }
2080
2081 static uint32_t
2082 checkHeapSanityForRetainerProfiling( void )
2083 {
2084 uint32_t costSum, g, s;
2085
2086 costSum = 0;
2087 debugBelch("START: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2088 if (RtsFlags.GcFlags.generations == 1) {
2089 costSum += heapCheck(g0s0->to_blocks);
2090 debugBelch("heapCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2091 costSum += chainCheck(g0s0->large_objects);
2092 debugBelch("chainCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2093 } else {
2094 for (g = 0; g < RtsFlags.GcFlags.generations; g++)
2095 for (s = 0; s < generations[g].n_steps; s++) {
2096 /*
2097 After all live objects have been scavenged, the garbage
2098 collector may create some objects in
2099 scheduleFinalizers(). These objects are created through
2100 allocate(), so the small object pool or the large object
2101 pool of the g0s0 may not be empty.
2102 */
2103 if (g == 0 && s == 0) {
2104 costSum += smallObjectPoolCheck();
2105 debugBelch("smallObjectPoolCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2106 costSum += chainCheck(generations[g].steps[s].large_objects);
2107 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2108 } else {
2109 costSum += heapCheck(generations[g].steps[s].blocks);
2110 debugBelch("heapCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2111 costSum += chainCheck(generations[g].steps[s].large_objects);
2112 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2113 }
2114 }
2115 }
2116
2117 return costSum;
2118 }
2119
2120 void
2121 findPointer(StgPtr p)
2122 {
2123 StgPtr q, r, e;
2124 bdescr *bd;
2125 uint32_t g, s;
2126
2127 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2128 for (s = 0; s < generations[g].n_steps; s++) {
2129 // if (g == 0 && s == 0) continue;
2130 bd = generations[g].steps[s].blocks;
2131 for (; bd; bd = bd->link) {
2132 for (q = bd->start; q < bd->free; q++) {
2133 if (*q == (StgWord)p) {
2134 r = q;
2135 while (!LOOKS_LIKE_GHC_INFO(*r)) r--;
2136 debugBelch("Found in gen[%d], step[%d]: q = %p, r = %p\n", g, s, q, r);
2137 // return;
2138 }
2139 }
2140 }
2141 bd = generations[g].steps[s].large_objects;
2142 for (; bd; bd = bd->link) {
2143 e = bd->start + cost((StgClosure *)bd->start);
2144 for (q = bd->start; q < e; q++) {
2145 if (*q == (StgWord)p) {
2146 r = q;
2147 while (*r == 0 || !LOOKS_LIKE_GHC_INFO(*r)) r--;
2148 debugBelch("Found in gen[%d], large_objects: %p\n", g, r);
2149 // return;
2150 }
2151 }
2152 }
2153 }
2154 }
2155 }
2156
2157 static void
2158 belongToHeap(StgPtr p)
2159 {
2160 bdescr *bd;
2161 uint32_t g, s;
2162
2163 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2164 for (s = 0; s < generations[g].n_steps; s++) {
2165 // if (g == 0 && s == 0) continue;
2166 bd = generations[g].steps[s].blocks;
2167 for (; bd; bd = bd->link) {
2168 if (bd->start <= p && p < bd->free) {
2169 debugBelch("Belongs to gen[%d], step[%d]", g, s);
2170 return;
2171 }
2172 }
2173 bd = generations[g].steps[s].large_objects;
2174 for (; bd; bd = bd->link) {
2175 if (bd->start <= p && p < bd->start + getHeapClosureSize((StgClosure *)bd->start)) {
2176 debugBelch("Found in gen[%d], large_objects: %p\n", g, bd->start);
2177 return;
2178 }
2179 }
2180 }
2181 }
2182 }
2183 #endif /* DEBUG_RETAINER */
2184
2185 #endif /* PROFILING */