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