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