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