New implementation of BLACKHOLEs
[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 lnat
275 retainerStackBlocks( void )
276 {
277 bdescr* bd;
278 lnat 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(__PIC__) && defined(mingw32_TARGET_OS)
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 IND_OLDGEN_PERM:
470 case IND_OLDGEN:
471 case BLACKHOLE:
472 *first_child = ((StgInd *)c)->indirectee;
473 return;
474 case CONSTR_1_0:
475 case CONSTR_1_1:
476 *first_child = c->payload[0];
477 return;
478
479 // For CONSTR_2_0 and MVAR, we use se.info.step to record the position
480 // of the next child. We do not write a separate initialization code.
481 // Also we do not have to initialize info.type;
482
483 // two children (fixed), no SRT
484 // need to push a stackElement, but nothing to store in se.info
485 case CONSTR_2_0:
486 *first_child = c->payload[0]; // return the first pointer
487 // se.info.type = posTypeStep;
488 // se.info.next.step = 2; // 2 = second
489 break;
490
491 // three children (fixed), no SRT
492 // need to push a stackElement
493 case MVAR_CLEAN:
494 case MVAR_DIRTY:
495 // head must be TSO and the head of a linked list of TSOs.
496 // Shoule it be a child? Seems to be yes.
497 *first_child = (StgClosure *)((StgMVar *)c)->head;
498 // se.info.type = posTypeStep;
499 se.info.next.step = 2; // 2 = second
500 break;
501
502 // three children (fixed), no SRT
503 case WEAK:
504 *first_child = ((StgWeak *)c)->key;
505 // se.info.type = posTypeStep;
506 se.info.next.step = 2;
507 break;
508
509 // layout.payload.ptrs, no SRT
510 case CONSTR:
511 case PRIM:
512 case MUT_PRIM:
513 case BCO:
514 case CONSTR_STATIC:
515 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
516 (StgPtr)c->payload);
517 *first_child = find_ptrs(&se.info);
518 if (*first_child == NULL)
519 return; // no child
520 break;
521
522 // StgMutArrPtr.ptrs, no SRT
523 case MUT_ARR_PTRS_CLEAN:
524 case MUT_ARR_PTRS_DIRTY:
525 case MUT_ARR_PTRS_FROZEN:
526 case MUT_ARR_PTRS_FROZEN0:
527 init_ptrs(&se.info, ((StgMutArrPtrs *)c)->ptrs,
528 (StgPtr)(((StgMutArrPtrs *)c)->payload));
529 *first_child = find_ptrs(&se.info);
530 if (*first_child == NULL)
531 return;
532 break;
533
534 // layout.payload.ptrs, SRT
535 case FUN: // *c is a heap object.
536 case FUN_2_0:
537 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
538 *first_child = find_ptrs(&se.info);
539 if (*first_child == NULL)
540 // no child from ptrs, so check SRT
541 goto fun_srt_only;
542 break;
543
544 case THUNK:
545 case THUNK_2_0:
546 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
547 (StgPtr)((StgThunk *)c)->payload);
548 *first_child = find_ptrs(&se.info);
549 if (*first_child == NULL)
550 // no child from ptrs, so check SRT
551 goto thunk_srt_only;
552 break;
553
554 // 1 fixed child, SRT
555 case FUN_1_0:
556 case FUN_1_1:
557 *first_child = c->payload[0];
558 ASSERT(*first_child != NULL);
559 init_srt_fun(&se.info, get_fun_itbl(c));
560 break;
561
562 case THUNK_1_0:
563 case THUNK_1_1:
564 *first_child = ((StgThunk *)c)->payload[0];
565 ASSERT(*first_child != NULL);
566 init_srt_thunk(&se.info, get_thunk_itbl(c));
567 break;
568
569 case FUN_STATIC: // *c is a heap object.
570 ASSERT(get_itbl(c)->srt_bitmap != 0);
571 case FUN_0_1:
572 case FUN_0_2:
573 fun_srt_only:
574 init_srt_fun(&se.info, get_fun_itbl(c));
575 *first_child = find_srt(&se.info);
576 if (*first_child == NULL)
577 return; // no child
578 break;
579
580 // SRT only
581 case THUNK_STATIC:
582 ASSERT(get_itbl(c)->srt_bitmap != 0);
583 case THUNK_0_1:
584 case THUNK_0_2:
585 thunk_srt_only:
586 init_srt_thunk(&se.info, get_thunk_itbl(c));
587 *first_child = find_srt(&se.info);
588 if (*first_child == NULL)
589 return; // no child
590 break;
591
592 case TREC_CHUNK:
593 *first_child = (StgClosure *)((StgTRecChunk *)c)->prev_chunk;
594 se.info.next.step = 0; // entry no.
595 break;
596
597 // cannot appear
598 case PAP:
599 case AP:
600 case AP_STACK:
601 case TSO:
602 case IND_STATIC:
603 case CONSTR_NOCAF_STATIC:
604 // stack objects
605 case UPDATE_FRAME:
606 case CATCH_FRAME:
607 case STOP_FRAME:
608 case RET_DYN:
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 CONSTR:
849 case PRIM:
850 case MUT_PRIM:
851 case BCO:
852 case CONSTR_STATIC:
853 // StgMutArrPtr.ptrs, no SRT
854 case MUT_ARR_PTRS_CLEAN:
855 case MUT_ARR_PTRS_DIRTY:
856 case MUT_ARR_PTRS_FROZEN:
857 case MUT_ARR_PTRS_FROZEN0:
858 *c = find_ptrs(&se->info);
859 if (*c == NULL) {
860 popOff();
861 break;
862 }
863 *cp = se->c;
864 *r = se->c_child_r;
865 return;
866
867 // layout.payload.ptrs, SRT
868 case FUN: // always a heap object
869 case FUN_2_0:
870 if (se->info.type == posTypePtrs) {
871 *c = find_ptrs(&se->info);
872 if (*c != NULL) {
873 *cp = se->c;
874 *r = se->c_child_r;
875 return;
876 }
877 init_srt_fun(&se->info, get_fun_itbl(se->c));
878 }
879 goto do_srt;
880
881 case THUNK:
882 case THUNK_2_0:
883 if (se->info.type == posTypePtrs) {
884 *c = find_ptrs(&se->info);
885 if (*c != NULL) {
886 *cp = se->c;
887 *r = se->c_child_r;
888 return;
889 }
890 init_srt_thunk(&se->info, get_thunk_itbl(se->c));
891 }
892 goto do_srt;
893
894 // SRT
895 do_srt:
896 case THUNK_STATIC:
897 case FUN_STATIC:
898 case FUN_0_1:
899 case FUN_0_2:
900 case THUNK_0_1:
901 case THUNK_0_2:
902 case FUN_1_0:
903 case FUN_1_1:
904 case THUNK_1_0:
905 case THUNK_1_1:
906 *c = find_srt(&se->info);
907 if (*c != NULL) {
908 *cp = se->c;
909 *r = se->c_child_r;
910 return;
911 }
912 popOff();
913 break;
914
915 // no child (fixed), no SRT
916 case CONSTR_0_1:
917 case CONSTR_0_2:
918 case ARR_WORDS:
919 // one child (fixed), no SRT
920 case MUT_VAR_CLEAN:
921 case MUT_VAR_DIRTY:
922 case THUNK_SELECTOR:
923 case IND_PERM:
924 case IND_OLDGEN_PERM:
925 case IND_OLDGEN:
926 case CONSTR_1_1:
927 // cannot appear
928 case PAP:
929 case AP:
930 case AP_STACK:
931 case TSO:
932 case IND_STATIC:
933 case CONSTR_NOCAF_STATIC:
934 // stack objects
935 case RET_DYN:
936 case UPDATE_FRAME:
937 case CATCH_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
1009 // mutable objects
1010 case MUT_PRIM:
1011 case MVAR_CLEAN:
1012 case MVAR_DIRTY:
1013 case MUT_VAR_CLEAN:
1014 case MUT_VAR_DIRTY:
1015 case MUT_ARR_PTRS_CLEAN:
1016 case MUT_ARR_PTRS_DIRTY:
1017 case MUT_ARR_PTRS_FROZEN:
1018 case MUT_ARR_PTRS_FROZEN0:
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 case IND_OLDGEN_PERM:
1062 case IND_OLDGEN:
1063 case BLACKHOLE:
1064 // static objects
1065 case CONSTR_STATIC:
1066 case FUN_STATIC:
1067 // misc
1068 case PRIM:
1069 case BCO:
1070 case ARR_WORDS:
1071 // STM
1072 case TREC_CHUNK:
1073 return rtsFalse;
1074
1075 //
1076 // Error case
1077 //
1078 // IND_STATIC cannot be *c, *cp, *r in the retainer profiling loop.
1079 case IND_STATIC:
1080 // CONSTR_NOCAF_STATIC
1081 // cannot be *c, *cp, *r in the retainer profiling loop.
1082 case CONSTR_NOCAF_STATIC:
1083 // Stack objects are invalid because they are never treated as
1084 // legal objects during retainer profiling.
1085 case UPDATE_FRAME:
1086 case CATCH_FRAME:
1087 case STOP_FRAME:
1088 case RET_DYN:
1089 case RET_BCO:
1090 case RET_SMALL:
1091 case RET_BIG:
1092 // other cases
1093 case IND:
1094 case INVALID_OBJECT:
1095 default:
1096 barf("Invalid object in isRetainer(): %d", get_itbl(c)->type);
1097 return rtsFalse;
1098 }
1099 }
1100
1101 /* -----------------------------------------------------------------------------
1102 * Returns the retainer function value for the closure *c, i.e., R(*c).
1103 * This function does NOT return the retainer(s) of *c.
1104 * Invariants:
1105 * *c must be a retainer.
1106 * Note:
1107 * Depending on the definition of this function, the maintenance of retainer
1108 * sets can be made easier. If most retainer sets are likely to be created
1109 * again across garbage collections, refreshAllRetainerSet() in
1110 * RetainerSet.c can simply do nothing.
1111 * If this is not the case, we can free all the retainer sets and
1112 * re-initialize the hash table.
1113 * See refreshAllRetainerSet() in RetainerSet.c.
1114 * -------------------------------------------------------------------------- */
1115 static INLINE retainer
1116 getRetainerFrom( StgClosure *c )
1117 {
1118 ASSERT(isRetainer(c));
1119
1120 #if defined(RETAINER_SCHEME_INFO)
1121 // Retainer scheme 1: retainer = info table
1122 return get_itbl(c);
1123 #elif defined(RETAINER_SCHEME_CCS)
1124 // Retainer scheme 2: retainer = cost centre stack
1125 return c->header.prof.ccs;
1126 #elif defined(RETAINER_SCHEME_CC)
1127 // Retainer scheme 3: retainer = cost centre
1128 return c->header.prof.ccs->cc;
1129 #endif
1130 }
1131
1132 /* -----------------------------------------------------------------------------
1133 * Associates the retainer set *s with the closure *c, that is, *s becomes
1134 * the retainer set of *c.
1135 * Invariants:
1136 * c != NULL
1137 * s != NULL
1138 * -------------------------------------------------------------------------- */
1139 static INLINE void
1140 associate( StgClosure *c, RetainerSet *s )
1141 {
1142 // StgWord has the same size as pointers, so the following type
1143 // casting is okay.
1144 RSET(c) = (RetainerSet *)((StgWord)s | flip);
1145 }
1146
1147 /* -----------------------------------------------------------------------------
1148 Call retainClosure for each of the closures covered by a large bitmap.
1149 -------------------------------------------------------------------------- */
1150
1151 static void
1152 retain_large_bitmap (StgPtr p, StgLargeBitmap *large_bitmap, nat size,
1153 StgClosure *c, retainer c_child_r)
1154 {
1155 nat i, b;
1156 StgWord bitmap;
1157
1158 b = 0;
1159 bitmap = large_bitmap->bitmap[b];
1160 for (i = 0; i < size; ) {
1161 if ((bitmap & 1) == 0) {
1162 retainClosure((StgClosure *)*p, c, c_child_r);
1163 }
1164 i++;
1165 p++;
1166 if (i % BITS_IN(W_) == 0) {
1167 b++;
1168 bitmap = large_bitmap->bitmap[b];
1169 } else {
1170 bitmap = bitmap >> 1;
1171 }
1172 }
1173 }
1174
1175 static INLINE StgPtr
1176 retain_small_bitmap (StgPtr p, nat size, StgWord bitmap,
1177 StgClosure *c, retainer c_child_r)
1178 {
1179 while (size > 0) {
1180 if ((bitmap & 1) == 0) {
1181 retainClosure((StgClosure *)*p, c, c_child_r);
1182 }
1183 p++;
1184 bitmap = bitmap >> 1;
1185 size--;
1186 }
1187 return p;
1188 }
1189
1190 /* -----------------------------------------------------------------------------
1191 * Call retainClosure for each of the closures in an SRT.
1192 * ------------------------------------------------------------------------- */
1193
1194 static void
1195 retain_large_srt_bitmap (StgLargeSRT *srt, StgClosure *c, retainer c_child_r)
1196 {
1197 nat i, b, size;
1198 StgWord bitmap;
1199 StgClosure **p;
1200
1201 b = 0;
1202 p = (StgClosure **)srt->srt;
1203 size = srt->l.size;
1204 bitmap = srt->l.bitmap[b];
1205 for (i = 0; i < size; ) {
1206 if ((bitmap & 1) != 0) {
1207 retainClosure((StgClosure *)*p, c, c_child_r);
1208 }
1209 i++;
1210 p++;
1211 if (i % BITS_IN(W_) == 0) {
1212 b++;
1213 bitmap = srt->l.bitmap[b];
1214 } else {
1215 bitmap = bitmap >> 1;
1216 }
1217 }
1218 }
1219
1220 static INLINE void
1221 retainSRT (StgClosure **srt, nat srt_bitmap, StgClosure *c, retainer c_child_r)
1222 {
1223 nat bitmap;
1224 StgClosure **p;
1225
1226 bitmap = srt_bitmap;
1227 p = srt;
1228
1229 if (bitmap == (StgHalfWord)(-1)) {
1230 retain_large_srt_bitmap( (StgLargeSRT *)srt, c, c_child_r );
1231 return;
1232 }
1233
1234 while (bitmap != 0) {
1235 if ((bitmap & 1) != 0) {
1236 #if defined(__PIC__) && defined(mingw32_TARGET_OS)
1237 if ( (unsigned long)(*srt) & 0x1 ) {
1238 retainClosure(* (StgClosure**) ((unsigned long) (*srt) & ~0x1),
1239 c, c_child_r);
1240 } else {
1241 retainClosure(*srt,c,c_child_r);
1242 }
1243 #else
1244 retainClosure(*srt,c,c_child_r);
1245 #endif
1246 }
1247 p++;
1248 bitmap = bitmap >> 1;
1249 }
1250 }
1251
1252 /* -----------------------------------------------------------------------------
1253 * Process all the objects in the stack chunk from stackStart to stackEnd
1254 * with *c and *c_child_r being their parent and their most recent retainer,
1255 * respectively. Treat stackOptionalFun as another child of *c if it is
1256 * not NULL.
1257 * Invariants:
1258 * *c is one of the following: TSO, AP_STACK.
1259 * If *c is TSO, c == c_child_r.
1260 * stackStart < stackEnd.
1261 * RSET(c) and RSET(c_child_r) are valid, i.e., their
1262 * interpretation conforms to the current value of flip (even when they
1263 * are interpreted to be NULL).
1264 * If *c is TSO, its state is not any of ThreadRelocated, ThreadComplete,
1265 * or ThreadKilled, which means that its stack is ready to process.
1266 * Note:
1267 * This code was almost plagiarzied from GC.c! For each pointer,
1268 * retainClosure() is invoked instead of evacuate().
1269 * -------------------------------------------------------------------------- */
1270 static void
1271 retainStack( StgClosure *c, retainer c_child_r,
1272 StgPtr stackStart, StgPtr stackEnd )
1273 {
1274 stackElement *oldStackBoundary;
1275 StgPtr p;
1276 StgRetInfoTable *info;
1277 StgWord32 bitmap;
1278 nat size;
1279
1280 #ifdef DEBUG_RETAINER
1281 cStackSize++;
1282 if (cStackSize > maxCStackSize) maxCStackSize = cStackSize;
1283 #endif
1284
1285 /*
1286 Each invocation of retainStack() creates a new virtual
1287 stack. Since all such stacks share a single common stack, we
1288 record the current currentStackBoundary, which will be restored
1289 at the exit.
1290 */
1291 oldStackBoundary = currentStackBoundary;
1292 currentStackBoundary = stackTop;
1293
1294 #ifdef DEBUG_RETAINER
1295 // debugBelch("retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
1296 #endif
1297
1298 ASSERT(get_itbl(c)->type != TSO ||
1299 (((StgTSO *)c)->what_next != ThreadRelocated &&
1300 ((StgTSO *)c)->what_next != ThreadComplete &&
1301 ((StgTSO *)c)->what_next != ThreadKilled));
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 STOP_FRAME:
1315 case CATCH_FRAME:
1316 case CATCH_STM_FRAME:
1317 case CATCH_RETRY_FRAME:
1318 case ATOMICALLY_FRAME:
1319 case RET_SMALL:
1320 bitmap = BITMAP_BITS(info->i.layout.bitmap);
1321 size = BITMAP_SIZE(info->i.layout.bitmap);
1322 p++;
1323 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1324
1325 follow_srt:
1326 retainSRT((StgClosure **)GET_SRT(info), info->i.srt_bitmap, c, c_child_r);
1327 continue;
1328
1329 case RET_BCO: {
1330 StgBCO *bco;
1331
1332 p++;
1333 retainClosure((StgClosure *)*p, c, c_child_r);
1334 bco = (StgBCO *)*p;
1335 p++;
1336 size = BCO_BITMAP_SIZE(bco);
1337 retain_large_bitmap(p, BCO_BITMAP(bco), size, c, c_child_r);
1338 p += size;
1339 continue;
1340 }
1341
1342 // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
1343 case RET_BIG:
1344 size = GET_LARGE_BITMAP(&info->i)->size;
1345 p++;
1346 retain_large_bitmap(p, GET_LARGE_BITMAP(&info->i),
1347 size, c, c_child_r);
1348 p += size;
1349 // and don't forget to follow the SRT
1350 goto follow_srt;
1351
1352 // Dynamic bitmap: the mask is stored on the stack
1353 case RET_DYN: {
1354 StgWord dyn;
1355 dyn = ((StgRetDyn *)p)->liveness;
1356
1357 // traverse the bitmap first
1358 bitmap = RET_DYN_LIVENESS(dyn);
1359 p = (P_)&((StgRetDyn *)p)->payload[0];
1360 size = RET_DYN_BITMAP_SIZE;
1361 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1362
1363 // skip over the non-ptr words
1364 p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
1365
1366 // follow the ptr words
1367 for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
1368 retainClosure((StgClosure *)*p, c, c_child_r);
1369 p++;
1370 }
1371 continue;
1372 }
1373
1374 case RET_FUN: {
1375 StgRetFun *ret_fun = (StgRetFun *)p;
1376 StgFunInfoTable *fun_info;
1377
1378 retainClosure(ret_fun->fun, c, c_child_r);
1379 fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
1380
1381 p = (P_)&ret_fun->payload;
1382 switch (fun_info->f.fun_type) {
1383 case ARG_GEN:
1384 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
1385 size = BITMAP_SIZE(fun_info->f.b.bitmap);
1386 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1387 break;
1388 case ARG_GEN_BIG:
1389 size = GET_FUN_LARGE_BITMAP(fun_info)->size;
1390 retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
1391 size, c, c_child_r);
1392 p += size;
1393 break;
1394 default:
1395 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1396 size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
1397 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1398 break;
1399 }
1400 goto follow_srt;
1401 }
1402
1403 default:
1404 barf("Invalid object found in retainStack(): %d",
1405 (int)(info->i.type));
1406 }
1407 }
1408
1409 // restore currentStackBoundary
1410 currentStackBoundary = oldStackBoundary;
1411 #ifdef DEBUG_RETAINER
1412 // debugBelch("retainStack() finished: currentStackBoundary = 0x%x\n", currentStackBoundary);
1413 #endif
1414
1415 #ifdef DEBUG_RETAINER
1416 cStackSize--;
1417 #endif
1418 }
1419
1420 /* ----------------------------------------------------------------------------
1421 * Call retainClosure for each of the children of a PAP/AP
1422 * ------------------------------------------------------------------------- */
1423
1424 static INLINE StgPtr
1425 retain_PAP_payload (StgClosure *pap, /* NOT tagged */
1426 retainer c_child_r, /* NOT tagged */
1427 StgClosure *fun, /* tagged */
1428 StgClosure** payload, StgWord n_args)
1429 {
1430 StgPtr p;
1431 StgWord bitmap;
1432 StgFunInfoTable *fun_info;
1433
1434 retainClosure(fun, pap, c_child_r);
1435 fun = UNTAG_CLOSURE(fun);
1436 fun_info = get_fun_itbl(fun);
1437 ASSERT(fun_info->i.type != PAP);
1438
1439 p = (StgPtr)payload;
1440
1441 switch (fun_info->f.fun_type) {
1442 case ARG_GEN:
1443 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
1444 p = retain_small_bitmap(p, n_args, bitmap,
1445 pap, c_child_r);
1446 break;
1447 case ARG_GEN_BIG:
1448 retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
1449 n_args, pap, c_child_r);
1450 p += n_args;
1451 break;
1452 case ARG_BCO:
1453 retain_large_bitmap((StgPtr)payload, BCO_BITMAP(fun),
1454 n_args, pap, c_child_r);
1455 p += n_args;
1456 break;
1457 default:
1458 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1459 p = retain_small_bitmap(p, n_args, bitmap, pap, c_child_r);
1460 break;
1461 }
1462 return p;
1463 }
1464
1465 /* -----------------------------------------------------------------------------
1466 * Compute the retainer set of *c0 and all its desecents by traversing.
1467 * *cp0 is the parent of *c0, and *r0 is the most recent retainer of *c0.
1468 * Invariants:
1469 * c0 = cp0 = r0 holds only for root objects.
1470 * RSET(cp0) and RSET(r0) are valid, i.e., their
1471 * interpretation conforms to the current value of flip (even when they
1472 * are interpreted to be NULL).
1473 * However, RSET(c0) may be corrupt, i.e., it may not conform to
1474 * the current value of flip. If it does not, during the execution
1475 * of this function, RSET(c0) must be initialized as well as all
1476 * its descendants.
1477 * Note:
1478 * stackTop must be the same at the beginning and the exit of this function.
1479 * *c0 can be TSO (as well as AP_STACK).
1480 * -------------------------------------------------------------------------- */
1481 static void
1482 retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
1483 {
1484 // c = Current closure (possibly tagged)
1485 // cp = Current closure's Parent (NOT tagged)
1486 // r = current closures' most recent Retainer (NOT tagged)
1487 // c_child_r = current closure's children's most recent retainer
1488 // first_child = first child of c
1489 StgClosure *c, *cp, *first_child;
1490 RetainerSet *s, *retainerSetOfc;
1491 retainer r, c_child_r;
1492 StgWord typeOfc;
1493
1494 #ifdef DEBUG_RETAINER
1495 // StgPtr oldStackTop;
1496 #endif
1497
1498 #ifdef DEBUG_RETAINER
1499 // oldStackTop = stackTop;
1500 // debugBelch("retainClosure() called: c0 = 0x%x, cp0 = 0x%x, r0 = 0x%x\n", c0, cp0, r0);
1501 #endif
1502
1503 // (c, cp, r) = (c0, cp0, r0)
1504 c = c0;
1505 cp = cp0;
1506 r = r0;
1507 goto inner_loop;
1508
1509 loop:
1510 //debugBelch("loop");
1511 // pop to (c, cp, r);
1512 pop(&c, &cp, &r);
1513
1514 if (c == NULL) {
1515 #ifdef DEBUG_RETAINER
1516 // debugBelch("retainClosure() ends: oldStackTop = 0x%x, stackTop = 0x%x\n", oldStackTop, stackTop);
1517 #endif
1518 return;
1519 }
1520
1521 //debugBelch("inner_loop");
1522
1523 inner_loop:
1524 c = UNTAG_CLOSURE(c);
1525
1526 // c = current closure under consideration,
1527 // cp = current closure's parent,
1528 // r = current closure's most recent retainer
1529 //
1530 // Loop invariants (on the meaning of c, cp, r, and their retainer sets):
1531 // RSET(cp) and RSET(r) are valid.
1532 // RSET(c) is valid only if c has been visited before.
1533 //
1534 // Loop invariants (on the relation between c, cp, and r)
1535 // if cp is not a retainer, r belongs to RSET(cp).
1536 // if cp is a retainer, r == cp.
1537
1538 typeOfc = get_itbl(c)->type;
1539
1540 #ifdef DEBUG_RETAINER
1541 switch (typeOfc) {
1542 case IND_STATIC:
1543 case CONSTR_NOCAF_STATIC:
1544 case CONSTR_STATIC:
1545 case THUNK_STATIC:
1546 case FUN_STATIC:
1547 break;
1548 default:
1549 if (retainerSetOf(c) == NULL) { // first visit?
1550 costArray[typeOfc] += cost(c);
1551 sumOfNewCost += cost(c);
1552 }
1553 break;
1554 }
1555 #endif
1556
1557 // special cases
1558 switch (typeOfc) {
1559 case TSO:
1560 if (((StgTSO *)c)->what_next == ThreadComplete ||
1561 ((StgTSO *)c)->what_next == ThreadKilled) {
1562 #ifdef DEBUG_RETAINER
1563 debugBelch("ThreadComplete or ThreadKilled encountered in retainClosure()\n");
1564 #endif
1565 goto loop;
1566 }
1567 if (((StgTSO *)c)->what_next == ThreadRelocated) {
1568 #ifdef DEBUG_RETAINER
1569 debugBelch("ThreadRelocated encountered in retainClosure()\n");
1570 #endif
1571 c = (StgClosure *)((StgTSO *)c)->_link;
1572 goto inner_loop;
1573 }
1574 break;
1575
1576 case IND_STATIC:
1577 // We just skip IND_STATIC, so its retainer set is never computed.
1578 c = ((StgIndStatic *)c)->indirectee;
1579 goto inner_loop;
1580 // static objects with no pointers out, so goto loop.
1581 case CONSTR_NOCAF_STATIC:
1582 // It is not just enough not to compute the retainer set for *c; it is
1583 // mandatory because CONSTR_NOCAF_STATIC are not reachable from
1584 // scavenged_static_objects, the list from which is assumed to traverse
1585 // all static objects after major garbage collections.
1586 goto loop;
1587 case THUNK_STATIC:
1588 case FUN_STATIC:
1589 if (get_itbl(c)->srt_bitmap == 0) {
1590 // No need to compute the retainer set; no dynamic objects
1591 // are reachable from *c.
1592 //
1593 // Static objects: if we traverse all the live closures,
1594 // including static closures, during each heap census then
1595 // we will observe that some static closures appear and
1596 // disappear. eg. a closure may contain a pointer to a
1597 // static function 'f' which is not otherwise reachable
1598 // (it doesn't indirectly point to any CAFs, so it doesn't
1599 // appear in any SRTs), so we would find 'f' during
1600 // traversal. However on the next sweep there may be no
1601 // closures pointing to 'f'.
1602 //
1603 // We must therefore ignore static closures whose SRT is
1604 // empty, because these are exactly the closures that may
1605 // "appear". A closure with a non-empty SRT, and which is
1606 // still required, will always be reachable.
1607 //
1608 // But what about CONSTR_STATIC? Surely these may be able
1609 // to appear, and they don't have SRTs, so we can't
1610 // check. So for now, we're calling
1611 // resetStaticObjectForRetainerProfiling() from the
1612 // garbage collector to reset the retainer sets in all the
1613 // reachable static objects.
1614 goto loop;
1615 }
1616 default:
1617 break;
1618 }
1619
1620 // The above objects are ignored in computing the average number of times
1621 // an object is visited.
1622 timesAnyObjectVisited++;
1623
1624 // If this is the first visit to c, initialize its retainer set.
1625 maybeInitRetainerSet(c);
1626 retainerSetOfc = retainerSetOf(c);
1627
1628 // Now compute s:
1629 // isRetainer(cp) == rtsTrue => s == NULL
1630 // isRetainer(cp) == rtsFalse => s == cp.retainer
1631 if (isRetainer(cp))
1632 s = NULL;
1633 else
1634 s = retainerSetOf(cp);
1635
1636 // (c, cp, r, s) is available.
1637
1638 // (c, cp, r, s, R_r) is available, so compute the retainer set for *c.
1639 if (retainerSetOfc == NULL) {
1640 // This is the first visit to *c.
1641 numObjectVisited++;
1642
1643 if (s == NULL)
1644 associate(c, singleton(r));
1645 else
1646 // s is actually the retainer set of *c!
1647 associate(c, s);
1648
1649 // compute c_child_r
1650 c_child_r = isRetainer(c) ? getRetainerFrom(c) : r;
1651 } else {
1652 // This is not the first visit to *c.
1653 if (isMember(r, retainerSetOfc))
1654 goto loop; // no need to process child
1655
1656 if (s == NULL)
1657 associate(c, addElement(r, retainerSetOfc));
1658 else {
1659 // s is not NULL and cp is not a retainer. This means that
1660 // each time *cp is visited, so is *c. Thus, if s has
1661 // exactly one more element in its retainer set than c, s
1662 // is also the new retainer set for *c.
1663 if (s->num == retainerSetOfc->num + 1) {
1664 associate(c, s);
1665 }
1666 // Otherwise, just add R_r to the current retainer set of *c.
1667 else {
1668 associate(c, addElement(r, retainerSetOfc));
1669 }
1670 }
1671
1672 if (isRetainer(c))
1673 goto loop; // no need to process child
1674
1675 // compute c_child_r
1676 c_child_r = r;
1677 }
1678
1679 // now, RSET() of all of *c, *cp, and *r is valid.
1680 // (c, c_child_r) are available.
1681
1682 // process child
1683
1684 // Special case closures: we process these all in one go rather
1685 // than attempting to save the current position, because doing so
1686 // would be hard.
1687 switch (typeOfc) {
1688 case TSO:
1689 retainStack(c, c_child_r,
1690 ((StgTSO *)c)->sp,
1691 ((StgTSO *)c)->stack + ((StgTSO *)c)->stack_size);
1692 goto loop;
1693
1694 case PAP:
1695 {
1696 StgPAP *pap = (StgPAP *)c;
1697 retain_PAP_payload(c, c_child_r, pap->fun, pap->payload, pap->n_args);
1698 goto loop;
1699 }
1700
1701 case AP:
1702 {
1703 StgAP *ap = (StgAP *)c;
1704 retain_PAP_payload(c, c_child_r, ap->fun, ap->payload, ap->n_args);
1705 goto loop;
1706 }
1707
1708 case AP_STACK:
1709 retainClosure(((StgAP_STACK *)c)->fun, c, c_child_r);
1710 retainStack(c, c_child_r,
1711 (StgPtr)((StgAP_STACK *)c)->payload,
1712 (StgPtr)((StgAP_STACK *)c)->payload +
1713 ((StgAP_STACK *)c)->size);
1714 goto loop;
1715 }
1716
1717 push(c, c_child_r, &first_child);
1718
1719 // If first_child is null, c has no child.
1720 // If first_child is not null, the top stack element points to the next
1721 // object. push() may or may not push a stackElement on the stack.
1722 if (first_child == NULL)
1723 goto loop;
1724
1725 // (c, cp, r) = (first_child, c, c_child_r)
1726 r = c_child_r;
1727 cp = c;
1728 c = first_child;
1729 goto inner_loop;
1730 }
1731
1732 /* -----------------------------------------------------------------------------
1733 * Compute the retainer set for every object reachable from *tl.
1734 * -------------------------------------------------------------------------- */
1735 static void
1736 retainRoot(void *user STG_UNUSED, StgClosure **tl)
1737 {
1738 StgClosure *c;
1739
1740 // We no longer assume that only TSOs and WEAKs are roots; any closure can
1741 // be a root.
1742
1743 ASSERT(isEmptyRetainerStack());
1744 currentStackBoundary = stackTop;
1745
1746 c = UNTAG_CLOSURE(*tl);
1747 if (c != &stg_END_TSO_QUEUE_closure && isRetainer(c)) {
1748 retainClosure(c, c, getRetainerFrom(c));
1749 } else {
1750 retainClosure(c, c, CCS_SYSTEM);
1751 }
1752
1753 // NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl)));
1754 // *tl might be a TSO which is ThreadComplete, in which
1755 // case we ignore it for the purposes of retainer profiling.
1756 }
1757
1758 /* -----------------------------------------------------------------------------
1759 * Compute the retainer set for each of the objects in the heap.
1760 * -------------------------------------------------------------------------- */
1761 static void
1762 computeRetainerSet( void )
1763 {
1764 StgWeak *weak;
1765 RetainerSet *rtl;
1766 nat g;
1767 StgPtr ml;
1768 bdescr *bd;
1769 #ifdef DEBUG_RETAINER
1770 RetainerSet tmpRetainerSet;
1771 #endif
1772
1773 markCapabilities(retainRoot, NULL); // for scheduler roots
1774
1775 // This function is called after a major GC, when key, value, and finalizer
1776 // all are guaranteed to be valid, or reachable.
1777 //
1778 // The following code assumes that WEAK objects are considered to be roots
1779 // for retainer profilng.
1780 for (weak = weak_ptr_list; weak != NULL; weak = weak->link)
1781 // retainRoot((StgClosure *)weak);
1782 retainRoot(NULL, (StgClosure **)&weak);
1783
1784 // Consider roots from the stable ptr table.
1785 markStablePtrTable(retainRoot, NULL);
1786
1787 // The following code resets the rs field of each unvisited mutable
1788 // object (computing sumOfNewCostExtra and updating costArray[] when
1789 // debugging retainer profiler).
1790 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1791 // NOT TRUE: even G0 has a block on its mutable list
1792 // ASSERT(g != 0 || (generations[g].mut_list == NULL));
1793
1794 // Traversing through mut_list is necessary
1795 // because we can find MUT_VAR objects which have not been
1796 // visited during retainer profiling.
1797 for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
1798 for (ml = bd->start; ml < bd->free; ml++) {
1799
1800 maybeInitRetainerSet((StgClosure *)*ml);
1801 rtl = retainerSetOf((StgClosure *)*ml);
1802
1803 #ifdef DEBUG_RETAINER
1804 if (rtl == NULL) {
1805 // first visit to *ml
1806 // This is a violation of the interface rule!
1807 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1808
1809 switch (get_itbl((StgClosure *)ml)->type) {
1810 case IND_STATIC:
1811 // no cost involved
1812 break;
1813 case CONSTR_NOCAF_STATIC:
1814 case CONSTR_STATIC:
1815 case THUNK_STATIC:
1816 case FUN_STATIC:
1817 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1818 break;
1819 default:
1820 // dynamic objects
1821 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1822 sumOfNewCostExtra += cost((StgClosure *)ml);
1823 break;
1824 }
1825 }
1826 #endif
1827 }
1828 }
1829 }
1830 }
1831
1832 /* -----------------------------------------------------------------------------
1833 * Traverse all static objects for which we compute retainer sets,
1834 * and reset their rs fields to NULL, which is accomplished by
1835 * invoking maybeInitRetainerSet(). This function must be called
1836 * before zeroing all objects reachable from scavenged_static_objects
1837 * in the case of major gabage collections. See GarbageCollect() in
1838 * GC.c.
1839 * Note:
1840 * The mut_once_list of the oldest generation must also be traversed?
1841 * Why? Because if the evacuation of an object pointed to by a static
1842 * indirection object fails, it is put back to the mut_once_list of
1843 * the oldest generation.
1844 * However, this is not necessary because any static indirection objects
1845 * are just traversed through to reach dynamic objects. In other words,
1846 * they are not taken into consideration in computing retainer sets.
1847 * -------------------------------------------------------------------------- */
1848 void
1849 resetStaticObjectForRetainerProfiling( StgClosure *static_objects )
1850 {
1851 #ifdef DEBUG_RETAINER
1852 nat count;
1853 #endif
1854 StgClosure *p;
1855
1856 #ifdef DEBUG_RETAINER
1857 count = 0;
1858 #endif
1859 p = static_objects;
1860 while (p != END_OF_STATIC_LIST) {
1861 #ifdef DEBUG_RETAINER
1862 count++;
1863 #endif
1864 switch (get_itbl(p)->type) {
1865 case IND_STATIC:
1866 // Since we do not compute the retainer set of any
1867 // IND_STATIC object, we don't have to reset its retainer
1868 // field.
1869 p = (StgClosure*)*IND_STATIC_LINK(p);
1870 break;
1871 case THUNK_STATIC:
1872 maybeInitRetainerSet(p);
1873 p = (StgClosure*)*THUNK_STATIC_LINK(p);
1874 break;
1875 case FUN_STATIC:
1876 maybeInitRetainerSet(p);
1877 p = (StgClosure*)*FUN_STATIC_LINK(p);
1878 break;
1879 case CONSTR_STATIC:
1880 maybeInitRetainerSet(p);
1881 p = (StgClosure*)*STATIC_LINK(get_itbl(p), p);
1882 break;
1883 default:
1884 barf("resetStaticObjectForRetainerProfiling: %p (%s)",
1885 p, get_itbl(p)->type);
1886 break;
1887 }
1888 }
1889 #ifdef DEBUG_RETAINER
1890 // debugBelch("count in scavenged_static_objects = %d\n", count);
1891 #endif
1892 }
1893
1894 /* -----------------------------------------------------------------------------
1895 * Perform retainer profiling.
1896 * N is the oldest generation being profilied, where the generations are
1897 * numbered starting at 0.
1898 * Invariants:
1899 * Note:
1900 * This function should be called only immediately after major garbage
1901 * collection.
1902 * ------------------------------------------------------------------------- */
1903 void
1904 retainerProfile(void)
1905 {
1906 #ifdef DEBUG_RETAINER
1907 nat i;
1908 nat totalHeapSize; // total raw heap size (computed by linear scanning)
1909 #endif
1910
1911 #ifdef DEBUG_RETAINER
1912 debugBelch(" < retainerProfile() invoked : %d>\n", retainerGeneration);
1913 #endif
1914
1915 stat_startRP();
1916
1917 // We haven't flipped the bit yet.
1918 #ifdef DEBUG_RETAINER
1919 debugBelch("Before traversing:\n");
1920 sumOfCostLinear = 0;
1921 for (i = 0;i < N_CLOSURE_TYPES; i++)
1922 costArrayLinear[i] = 0;
1923 totalHeapSize = checkHeapSanityForRetainerProfiling();
1924
1925 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1926 /*
1927 debugBelch("costArrayLinear[] = ");
1928 for (i = 0;i < N_CLOSURE_TYPES; i++)
1929 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
1930 debugBelch("\n");
1931 */
1932
1933 ASSERT(sumOfCostLinear == totalHeapSize);
1934
1935 /*
1936 #define pcostArrayLinear(index) \
1937 if (costArrayLinear[index] > 0) \
1938 debugBelch("costArrayLinear[" #index "] = %u\n", costArrayLinear[index])
1939 pcostArrayLinear(THUNK_STATIC);
1940 pcostArrayLinear(FUN_STATIC);
1941 pcostArrayLinear(CONSTR_STATIC);
1942 pcostArrayLinear(CONSTR_NOCAF_STATIC);
1943 */
1944 #endif
1945
1946 // Now we flips flip.
1947 flip = flip ^ 1;
1948
1949 #ifdef DEBUG_RETAINER
1950 stackSize = 0;
1951 maxStackSize = 0;
1952 cStackSize = 0;
1953 maxCStackSize = 0;
1954 #endif
1955 numObjectVisited = 0;
1956 timesAnyObjectVisited = 0;
1957
1958 #ifdef DEBUG_RETAINER
1959 debugBelch("During traversing:\n");
1960 sumOfNewCost = 0;
1961 sumOfNewCostExtra = 0;
1962 for (i = 0;i < N_CLOSURE_TYPES; i++)
1963 costArray[i] = 0;
1964 #endif
1965
1966 /*
1967 We initialize the traverse stack each time the retainer profiling is
1968 performed (because the traverse stack size varies on each retainer profiling
1969 and this operation is not costly anyhow). However, we just refresh the
1970 retainer sets.
1971 */
1972 initializeTraverseStack();
1973 #ifdef DEBUG_RETAINER
1974 initializeAllRetainerSet();
1975 #else
1976 refreshAllRetainerSet();
1977 #endif
1978 computeRetainerSet();
1979
1980 #ifdef DEBUG_RETAINER
1981 debugBelch("After traversing:\n");
1982 sumOfCostLinear = 0;
1983 for (i = 0;i < N_CLOSURE_TYPES; i++)
1984 costArrayLinear[i] = 0;
1985 totalHeapSize = checkHeapSanityForRetainerProfiling();
1986
1987 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1988 ASSERT(sumOfCostLinear == totalHeapSize);
1989
1990 // now, compare the two results
1991 /*
1992 Note:
1993 costArray[] must be exactly the same as costArrayLinear[].
1994 Known exceptions:
1995 1) Dead weak pointers, whose type is CONSTR. These objects are not
1996 reachable from any roots.
1997 */
1998 debugBelch("Comparison:\n");
1999 debugBelch("\tcostArrayLinear[] (must be empty) = ");
2000 for (i = 0;i < N_CLOSURE_TYPES; i++)
2001 if (costArray[i] != costArrayLinear[i])
2002 // nothing should be printed except MUT_VAR after major GCs
2003 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
2004 debugBelch("\n");
2005
2006 debugBelch("\tsumOfNewCost = %u\n", sumOfNewCost);
2007 debugBelch("\tsumOfNewCostExtra = %u\n", sumOfNewCostExtra);
2008 debugBelch("\tcostArray[] (must be empty) = ");
2009 for (i = 0;i < N_CLOSURE_TYPES; i++)
2010 if (costArray[i] != costArrayLinear[i])
2011 // nothing should be printed except MUT_VAR after major GCs
2012 debugBelch("[%u:%u] ", i, costArray[i]);
2013 debugBelch("\n");
2014
2015 // only for major garbage collection
2016 ASSERT(sumOfNewCost + sumOfNewCostExtra == sumOfCostLinear);
2017 #endif
2018
2019 // post-processing
2020 closeTraverseStack();
2021 #ifdef DEBUG_RETAINER
2022 closeAllRetainerSet();
2023 #else
2024 // Note that there is no post-processing for the retainer sets.
2025 #endif
2026 retainerGeneration++;
2027
2028 stat_endRP(
2029 retainerGeneration - 1, // retainerGeneration has just been incremented!
2030 #ifdef DEBUG_RETAINER
2031 maxCStackSize, maxStackSize,
2032 #endif
2033 (double)timesAnyObjectVisited / numObjectVisited);
2034 }
2035
2036 /* -----------------------------------------------------------------------------
2037 * DEBUGGING CODE
2038 * -------------------------------------------------------------------------- */
2039
2040 #ifdef DEBUG_RETAINER
2041
2042 #define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
2043 ((HEAP_ALLOCED(r) && ((Bdescr((P_)r)->flags & BF_FREE) == 0)))) && \
2044 ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa))
2045
2046 static nat
2047 sanityCheckHeapClosure( StgClosure *c )
2048 {
2049 StgInfoTable *info;
2050
2051 ASSERT(LOOKS_LIKE_GHC_INFO(c->header.info));
2052 ASSERT(!closure_STATIC(c));
2053 ASSERT(LOOKS_LIKE_PTR(c));
2054
2055 if ((((StgWord)RSET(c) & 1) ^ flip) != 0) {
2056 if (get_itbl(c)->type == CONSTR &&
2057 !strcmp(GET_PROF_TYPE(get_itbl(c)), "DEAD_WEAK") &&
2058 !strcmp(GET_PROF_DESC(get_itbl(c)), "DEAD_WEAK")) {
2059 debugBelch("\tUnvisited dead weak pointer object found: c = %p\n", c);
2060 costArray[get_itbl(c)->type] += cost(c);
2061 sumOfNewCost += cost(c);
2062 } else
2063 debugBelch(
2064 "Unvisited object: flip = %d, c = %p(%d, %s, %s), rs = %p\n",
2065 flip, c, get_itbl(c)->type,
2066 get_itbl(c)->prof.closure_type, GET_PROF_DESC(get_itbl(c)),
2067 RSET(c));
2068 } else {
2069 // debugBelch("sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c));
2070 }
2071
2072 return closure_sizeW(c);
2073 }
2074
2075 static nat
2076 heapCheck( bdescr *bd )
2077 {
2078 StgPtr p;
2079 static nat costSum, size;
2080
2081 costSum = 0;
2082 while (bd != NULL) {
2083 p = bd->start;
2084 while (p < bd->free) {
2085 size = sanityCheckHeapClosure((StgClosure *)p);
2086 sumOfCostLinear += size;
2087 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2088 p += size;
2089 // no need for slop check; I think slops are not used currently.
2090 }
2091 ASSERT(p == bd->free);
2092 costSum += bd->free - bd->start;
2093 bd = bd->link;
2094 }
2095
2096 return costSum;
2097 }
2098
2099 static nat
2100 smallObjectPoolCheck(void)
2101 {
2102 bdescr *bd;
2103 StgPtr p;
2104 static nat costSum, size;
2105
2106 bd = g0s0->blocks;
2107 costSum = 0;
2108
2109 // first block
2110 if (bd == NULL)
2111 return costSum;
2112
2113 p = bd->start;
2114 while (p < alloc_Hp) {
2115 size = sanityCheckHeapClosure((StgClosure *)p);
2116 sumOfCostLinear += size;
2117 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2118 p += size;
2119 }
2120 ASSERT(p == alloc_Hp);
2121 costSum += alloc_Hp - bd->start;
2122
2123 bd = bd->link;
2124 while (bd != NULL) {
2125 p = bd->start;
2126 while (p < bd->free) {
2127 size = sanityCheckHeapClosure((StgClosure *)p);
2128 sumOfCostLinear += size;
2129 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2130 p += size;
2131 }
2132 ASSERT(p == bd->free);
2133 costSum += bd->free - bd->start;
2134 bd = bd->link;
2135 }
2136
2137 return costSum;
2138 }
2139
2140 static nat
2141 chainCheck(bdescr *bd)
2142 {
2143 nat costSum, size;
2144
2145 costSum = 0;
2146 while (bd != NULL) {
2147 // bd->free - bd->start is not an accurate measurement of the
2148 // object size. Actually it is always zero, so we compute its
2149 // size explicitly.
2150 size = sanityCheckHeapClosure((StgClosure *)bd->start);
2151 sumOfCostLinear += size;
2152 costArrayLinear[get_itbl((StgClosure *)bd->start)->type] += size;
2153 costSum += size;
2154 bd = bd->link;
2155 }
2156
2157 return costSum;
2158 }
2159
2160 static nat
2161 checkHeapSanityForRetainerProfiling( void )
2162 {
2163 nat costSum, g, s;
2164
2165 costSum = 0;
2166 debugBelch("START: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2167 if (RtsFlags.GcFlags.generations == 1) {
2168 costSum += heapCheck(g0s0->to_blocks);
2169 debugBelch("heapCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2170 costSum += chainCheck(g0s0->large_objects);
2171 debugBelch("chainCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2172 } else {
2173 for (g = 0; g < RtsFlags.GcFlags.generations; g++)
2174 for (s = 0; s < generations[g].n_steps; s++) {
2175 /*
2176 After all live objects have been scavenged, the garbage
2177 collector may create some objects in
2178 scheduleFinalizers(). These objects are created throught
2179 allocate(), so the small object pool or the large object
2180 pool of the g0s0 may not be empty.
2181 */
2182 if (g == 0 && s == 0) {
2183 costSum += smallObjectPoolCheck();
2184 debugBelch("smallObjectPoolCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2185 costSum += chainCheck(generations[g].steps[s].large_objects);
2186 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2187 } else {
2188 costSum += heapCheck(generations[g].steps[s].blocks);
2189 debugBelch("heapCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2190 costSum += chainCheck(generations[g].steps[s].large_objects);
2191 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2192 }
2193 }
2194 }
2195
2196 return costSum;
2197 }
2198
2199 void
2200 findPointer(StgPtr p)
2201 {
2202 StgPtr q, r, e;
2203 bdescr *bd;
2204 nat g, s;
2205
2206 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2207 for (s = 0; s < generations[g].n_steps; s++) {
2208 // if (g == 0 && s == 0) continue;
2209 bd = generations[g].steps[s].blocks;
2210 for (; bd; bd = bd->link) {
2211 for (q = bd->start; q < bd->free; q++) {
2212 if (*q == (StgWord)p) {
2213 r = q;
2214 while (!LOOKS_LIKE_GHC_INFO(*r)) r--;
2215 debugBelch("Found in gen[%d], step[%d]: q = %p, r = %p\n", g, s, q, r);
2216 // return;
2217 }
2218 }
2219 }
2220 bd = generations[g].steps[s].large_objects;
2221 for (; bd; bd = bd->link) {
2222 e = bd->start + cost((StgClosure *)bd->start);
2223 for (q = bd->start; q < e; q++) {
2224 if (*q == (StgWord)p) {
2225 r = q;
2226 while (*r == 0 || !LOOKS_LIKE_GHC_INFO(*r)) r--;
2227 debugBelch("Found in gen[%d], large_objects: %p\n", g, r);
2228 // return;
2229 }
2230 }
2231 }
2232 }
2233 }
2234 }
2235
2236 static void
2237 belongToHeap(StgPtr p)
2238 {
2239 bdescr *bd;
2240 nat g, s;
2241
2242 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2243 for (s = 0; s < generations[g].n_steps; s++) {
2244 // if (g == 0 && s == 0) continue;
2245 bd = generations[g].steps[s].blocks;
2246 for (; bd; bd = bd->link) {
2247 if (bd->start <= p && p < bd->free) {
2248 debugBelch("Belongs to gen[%d], step[%d]", g, s);
2249 return;
2250 }
2251 }
2252 bd = generations[g].steps[s].large_objects;
2253 for (; bd; bd = bd->link) {
2254 if (bd->start <= p && p < bd->start + getHeapClosureSize((StgClosure *)bd->start)) {
2255 debugBelch("Found in gen[%d], large_objects: %p\n", g, bd->start);
2256 return;
2257 }
2258 }
2259 }
2260 }
2261 }
2262 #endif /* DEBUG_RETAINER */
2263
2264 #endif /* PROFILING */