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