Merge remote branch 'origin/master' into type-nats
[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_HOST_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 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 CONSTR:
509 case PRIM:
510 case MUT_PRIM:
511 case BCO:
512 case CONSTR_STATIC:
513 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
514 (StgPtr)c->payload);
515 *first_child = find_ptrs(&se.info);
516 if (*first_child == NULL)
517 return; // no child
518 break;
519
520 // StgMutArrPtr.ptrs, no SRT
521 case MUT_ARR_PTRS_CLEAN:
522 case MUT_ARR_PTRS_DIRTY:
523 case MUT_ARR_PTRS_FROZEN:
524 case MUT_ARR_PTRS_FROZEN0:
525 init_ptrs(&se.info, ((StgMutArrPtrs *)c)->ptrs,
526 (StgPtr)(((StgMutArrPtrs *)c)->payload));
527 *first_child = find_ptrs(&se.info);
528 if (*first_child == NULL)
529 return;
530 break;
531
532 // layout.payload.ptrs, SRT
533 case FUN: // *c is a heap object.
534 case FUN_2_0:
535 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
536 *first_child = find_ptrs(&se.info);
537 if (*first_child == NULL)
538 // no child from ptrs, so check SRT
539 goto fun_srt_only;
540 break;
541
542 case THUNK:
543 case THUNK_2_0:
544 init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
545 (StgPtr)((StgThunk *)c)->payload);
546 *first_child = find_ptrs(&se.info);
547 if (*first_child == NULL)
548 // no child from ptrs, so check SRT
549 goto thunk_srt_only;
550 break;
551
552 // 1 fixed child, SRT
553 case FUN_1_0:
554 case FUN_1_1:
555 *first_child = c->payload[0];
556 ASSERT(*first_child != NULL);
557 init_srt_fun(&se.info, get_fun_itbl(c));
558 break;
559
560 case THUNK_1_0:
561 case THUNK_1_1:
562 *first_child = ((StgThunk *)c)->payload[0];
563 ASSERT(*first_child != NULL);
564 init_srt_thunk(&se.info, get_thunk_itbl(c));
565 break;
566
567 case FUN_STATIC: // *c is a heap object.
568 ASSERT(get_itbl(c)->srt_bitmap != 0);
569 case FUN_0_1:
570 case FUN_0_2:
571 fun_srt_only:
572 init_srt_fun(&se.info, get_fun_itbl(c));
573 *first_child = find_srt(&se.info);
574 if (*first_child == NULL)
575 return; // no child
576 break;
577
578 // SRT only
579 case THUNK_STATIC:
580 ASSERT(get_itbl(c)->srt_bitmap != 0);
581 case THUNK_0_1:
582 case THUNK_0_2:
583 thunk_srt_only:
584 init_srt_thunk(&se.info, get_thunk_itbl(c));
585 *first_child = find_srt(&se.info);
586 if (*first_child == NULL)
587 return; // no child
588 break;
589
590 case TREC_CHUNK:
591 *first_child = (StgClosure *)((StgTRecChunk *)c)->prev_chunk;
592 se.info.next.step = 0; // entry no.
593 break;
594
595 // cannot appear
596 case PAP:
597 case AP:
598 case AP_STACK:
599 case TSO:
600 case STACK:
601 case IND_STATIC:
602 case CONSTR_NOCAF_STATIC:
603 // stack objects
604 case UPDATE_FRAME:
605 case CATCH_FRAME:
606 case UNDERFLOW_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 CONSTR_1_1:
925 // cannot appear
926 case PAP:
927 case AP:
928 case AP_STACK:
929 case TSO:
930 case STACK:
931 case IND_STATIC:
932 case CONSTR_NOCAF_STATIC:
933 // stack objects
934 case RET_DYN:
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 MUT_VAR_CLEAN:
1015 case MUT_VAR_DIRTY:
1016 case MUT_ARR_PTRS_CLEAN:
1017 case MUT_ARR_PTRS_DIRTY:
1018 case MUT_ARR_PTRS_FROZEN:
1019 case MUT_ARR_PTRS_FROZEN0:
1020
1021 // thunks are retainers.
1022 case THUNK:
1023 case THUNK_1_0:
1024 case THUNK_0_1:
1025 case THUNK_2_0:
1026 case THUNK_1_1:
1027 case THUNK_0_2:
1028 case THUNK_SELECTOR:
1029 case AP:
1030 case AP_STACK:
1031
1032 // Static thunks, or CAFS, are obviously retainers.
1033 case THUNK_STATIC:
1034
1035 // WEAK objects are roots; there is separate code in which traversing
1036 // begins from WEAK objects.
1037 case WEAK:
1038 return rtsTrue;
1039
1040 //
1041 // False case
1042 //
1043
1044 // constructors
1045 case CONSTR:
1046 case CONSTR_1_0:
1047 case CONSTR_0_1:
1048 case CONSTR_2_0:
1049 case CONSTR_1_1:
1050 case CONSTR_0_2:
1051 // functions
1052 case FUN:
1053 case FUN_1_0:
1054 case FUN_0_1:
1055 case FUN_2_0:
1056 case FUN_1_1:
1057 case FUN_0_2:
1058 // partial applications
1059 case PAP:
1060 // indirection
1061 case IND_PERM:
1062 // IND_STATIC used to be an error, but at the moment it can happen
1063 // as isAlive doesn't look through IND_STATIC as it ignores static
1064 // closures. See trac #3956 for a program that hit this error.
1065 case IND_STATIC:
1066 case BLACKHOLE:
1067 // static objects
1068 case CONSTR_STATIC:
1069 case FUN_STATIC:
1070 // misc
1071 case PRIM:
1072 case BCO:
1073 case ARR_WORDS:
1074 // STM
1075 case TREC_CHUNK:
1076 return rtsFalse;
1077
1078 //
1079 // Error case
1080 //
1081 // CONSTR_NOCAF_STATIC
1082 // cannot be *c, *cp, *r in the retainer profiling loop.
1083 case CONSTR_NOCAF_STATIC:
1084 // Stack objects are invalid because they are never treated as
1085 // legal objects during retainer profiling.
1086 case UPDATE_FRAME:
1087 case CATCH_FRAME:
1088 case UNDERFLOW_FRAME:
1089 case STOP_FRAME:
1090 case RET_DYN:
1091 case RET_BCO:
1092 case RET_SMALL:
1093 case RET_BIG:
1094 // other cases
1095 case IND:
1096 case INVALID_OBJECT:
1097 default:
1098 barf("Invalid object in isRetainer(): %d", get_itbl(c)->type);
1099 return rtsFalse;
1100 }
1101 }
1102
1103 /* -----------------------------------------------------------------------------
1104 * Returns the retainer function value for the closure *c, i.e., R(*c).
1105 * This function does NOT return the retainer(s) of *c.
1106 * Invariants:
1107 * *c must be a retainer.
1108 * Note:
1109 * Depending on the definition of this function, the maintenance of retainer
1110 * sets can be made easier. If most retainer sets are likely to be created
1111 * again across garbage collections, refreshAllRetainerSet() in
1112 * RetainerSet.c can simply do nothing.
1113 * If this is not the case, we can free all the retainer sets and
1114 * re-initialize the hash table.
1115 * See refreshAllRetainerSet() in RetainerSet.c.
1116 * -------------------------------------------------------------------------- */
1117 static INLINE retainer
1118 getRetainerFrom( StgClosure *c )
1119 {
1120 ASSERT(isRetainer(c));
1121
1122 #if defined(RETAINER_SCHEME_INFO)
1123 // Retainer scheme 1: retainer = info table
1124 return get_itbl(c);
1125 #elif defined(RETAINER_SCHEME_CCS)
1126 // Retainer scheme 2: retainer = cost centre stack
1127 return c->header.prof.ccs;
1128 #elif defined(RETAINER_SCHEME_CC)
1129 // Retainer scheme 3: retainer = cost centre
1130 return c->header.prof.ccs->cc;
1131 #endif
1132 }
1133
1134 /* -----------------------------------------------------------------------------
1135 * Associates the retainer set *s with the closure *c, that is, *s becomes
1136 * the retainer set of *c.
1137 * Invariants:
1138 * c != NULL
1139 * s != NULL
1140 * -------------------------------------------------------------------------- */
1141 static INLINE void
1142 associate( StgClosure *c, RetainerSet *s )
1143 {
1144 // StgWord has the same size as pointers, so the following type
1145 // casting is okay.
1146 RSET(c) = (RetainerSet *)((StgWord)s | flip);
1147 }
1148
1149 /* -----------------------------------------------------------------------------
1150 Call retainClosure for each of the closures covered by a large bitmap.
1151 -------------------------------------------------------------------------- */
1152
1153 static void
1154 retain_large_bitmap (StgPtr p, StgLargeBitmap *large_bitmap, nat size,
1155 StgClosure *c, retainer c_child_r)
1156 {
1157 nat i, b;
1158 StgWord bitmap;
1159
1160 b = 0;
1161 bitmap = large_bitmap->bitmap[b];
1162 for (i = 0; i < size; ) {
1163 if ((bitmap & 1) == 0) {
1164 retainClosure((StgClosure *)*p, c, c_child_r);
1165 }
1166 i++;
1167 p++;
1168 if (i % BITS_IN(W_) == 0) {
1169 b++;
1170 bitmap = large_bitmap->bitmap[b];
1171 } else {
1172 bitmap = bitmap >> 1;
1173 }
1174 }
1175 }
1176
1177 static INLINE StgPtr
1178 retain_small_bitmap (StgPtr p, nat size, StgWord bitmap,
1179 StgClosure *c, retainer c_child_r)
1180 {
1181 while (size > 0) {
1182 if ((bitmap & 1) == 0) {
1183 retainClosure((StgClosure *)*p, c, c_child_r);
1184 }
1185 p++;
1186 bitmap = bitmap >> 1;
1187 size--;
1188 }
1189 return p;
1190 }
1191
1192 /* -----------------------------------------------------------------------------
1193 * Call retainClosure for each of the closures in an SRT.
1194 * ------------------------------------------------------------------------- */
1195
1196 static void
1197 retain_large_srt_bitmap (StgLargeSRT *srt, StgClosure *c, retainer c_child_r)
1198 {
1199 nat i, b, size;
1200 StgWord bitmap;
1201 StgClosure **p;
1202
1203 b = 0;
1204 p = (StgClosure **)srt->srt;
1205 size = srt->l.size;
1206 bitmap = srt->l.bitmap[b];
1207 for (i = 0; i < size; ) {
1208 if ((bitmap & 1) != 0) {
1209 retainClosure((StgClosure *)*p, c, c_child_r);
1210 }
1211 i++;
1212 p++;
1213 if (i % BITS_IN(W_) == 0) {
1214 b++;
1215 bitmap = srt->l.bitmap[b];
1216 } else {
1217 bitmap = bitmap >> 1;
1218 }
1219 }
1220 }
1221
1222 static INLINE void
1223 retainSRT (StgClosure **srt, nat srt_bitmap, StgClosure *c, retainer c_child_r)
1224 {
1225 nat bitmap;
1226 StgClosure **p;
1227
1228 bitmap = srt_bitmap;
1229 p = srt;
1230
1231 if (bitmap == (StgHalfWord)(-1)) {
1232 retain_large_srt_bitmap( (StgLargeSRT *)srt, c, c_child_r );
1233 return;
1234 }
1235
1236 while (bitmap != 0) {
1237 if ((bitmap & 1) != 0) {
1238 #if defined(__PIC__) && defined(mingw32_HOST_OS)
1239 if ( (unsigned long)(*srt) & 0x1 ) {
1240 retainClosure(* (StgClosure**) ((unsigned long) (*srt) & ~0x1),
1241 c, c_child_r);
1242 } else {
1243 retainClosure(*srt,c,c_child_r);
1244 }
1245 #else
1246 retainClosure(*srt,c,c_child_r);
1247 #endif
1248 }
1249 p++;
1250 bitmap = bitmap >> 1;
1251 }
1252 }
1253
1254 /* -----------------------------------------------------------------------------
1255 * Process all the objects in the stack chunk from stackStart to stackEnd
1256 * with *c and *c_child_r being their parent and their most recent retainer,
1257 * respectively. Treat stackOptionalFun as another child of *c if it is
1258 * not NULL.
1259 * Invariants:
1260 * *c is one of the following: TSO, AP_STACK.
1261 * If *c is TSO, c == c_child_r.
1262 * stackStart < stackEnd.
1263 * RSET(c) and RSET(c_child_r) are valid, i.e., their
1264 * interpretation conforms to the current value of flip (even when they
1265 * are interpreted to be NULL).
1266 * If *c is TSO, its state is not ThreadComplete,or ThreadKilled,
1267 * which means that its stack is ready to process.
1268 * Note:
1269 * This code was almost plagiarzied from GC.c! For each pointer,
1270 * retainClosure() is invoked instead of evacuate().
1271 * -------------------------------------------------------------------------- */
1272 static void
1273 retainStack( StgClosure *c, retainer c_child_r,
1274 StgPtr stackStart, StgPtr stackEnd )
1275 {
1276 stackElement *oldStackBoundary;
1277 StgPtr p;
1278 StgRetInfoTable *info;
1279 StgWord bitmap;
1280 nat size;
1281
1282 #ifdef DEBUG_RETAINER
1283 cStackSize++;
1284 if (cStackSize > maxCStackSize) maxCStackSize = cStackSize;
1285 #endif
1286
1287 /*
1288 Each invocation of retainStack() creates a new virtual
1289 stack. Since all such stacks share a single common stack, we
1290 record the current currentStackBoundary, which will be restored
1291 at the exit.
1292 */
1293 oldStackBoundary = currentStackBoundary;
1294 currentStackBoundary = stackTop;
1295
1296 #ifdef DEBUG_RETAINER
1297 // debugBelch("retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
1298 #endif
1299
1300 ASSERT(get_itbl(c)->type == STACK);
1301
1302 p = stackStart;
1303 while (p < stackEnd) {
1304 info = get_ret_itbl((StgClosure *)p);
1305
1306 switch(info->i.type) {
1307
1308 case UPDATE_FRAME:
1309 retainClosure(((StgUpdateFrame *)p)->updatee, c, c_child_r);
1310 p += sizeofW(StgUpdateFrame);
1311 continue;
1312
1313 case UNDERFLOW_FRAME:
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 break;
1568
1569 case IND_STATIC:
1570 // We just skip IND_STATIC, so its retainer set is never computed.
1571 c = ((StgIndStatic *)c)->indirectee;
1572 goto inner_loop;
1573 // static objects with no pointers out, so goto loop.
1574 case CONSTR_NOCAF_STATIC:
1575 // It is not just enough not to compute the retainer set for *c; it is
1576 // mandatory because CONSTR_NOCAF_STATIC are not reachable from
1577 // scavenged_static_objects, the list from which is assumed to traverse
1578 // all static objects after major garbage collections.
1579 goto loop;
1580 case THUNK_STATIC:
1581 case FUN_STATIC:
1582 if (get_itbl(c)->srt_bitmap == 0) {
1583 // No need to compute the retainer set; no dynamic objects
1584 // are reachable from *c.
1585 //
1586 // Static objects: if we traverse all the live closures,
1587 // including static closures, during each heap census then
1588 // we will observe that some static closures appear and
1589 // disappear. eg. a closure may contain a pointer to a
1590 // static function 'f' which is not otherwise reachable
1591 // (it doesn't indirectly point to any CAFs, so it doesn't
1592 // appear in any SRTs), so we would find 'f' during
1593 // traversal. However on the next sweep there may be no
1594 // closures pointing to 'f'.
1595 //
1596 // We must therefore ignore static closures whose SRT is
1597 // empty, because these are exactly the closures that may
1598 // "appear". A closure with a non-empty SRT, and which is
1599 // still required, will always be reachable.
1600 //
1601 // But what about CONSTR_STATIC? Surely these may be able
1602 // to appear, and they don't have SRTs, so we can't
1603 // check. So for now, we're calling
1604 // resetStaticObjectForRetainerProfiling() from the
1605 // garbage collector to reset the retainer sets in all the
1606 // reachable static objects.
1607 goto loop;
1608 }
1609 default:
1610 break;
1611 }
1612
1613 // The above objects are ignored in computing the average number of times
1614 // an object is visited.
1615 timesAnyObjectVisited++;
1616
1617 // If this is the first visit to c, initialize its retainer set.
1618 maybeInitRetainerSet(c);
1619 retainerSetOfc = retainerSetOf(c);
1620
1621 // Now compute s:
1622 // isRetainer(cp) == rtsTrue => s == NULL
1623 // isRetainer(cp) == rtsFalse => s == cp.retainer
1624 if (isRetainer(cp))
1625 s = NULL;
1626 else
1627 s = retainerSetOf(cp);
1628
1629 // (c, cp, r, s) is available.
1630
1631 // (c, cp, r, s, R_r) is available, so compute the retainer set for *c.
1632 if (retainerSetOfc == NULL) {
1633 // This is the first visit to *c.
1634 numObjectVisited++;
1635
1636 if (s == NULL)
1637 associate(c, singleton(r));
1638 else
1639 // s is actually the retainer set of *c!
1640 associate(c, s);
1641
1642 // compute c_child_r
1643 c_child_r = isRetainer(c) ? getRetainerFrom(c) : r;
1644 } else {
1645 // This is not the first visit to *c.
1646 if (isMember(r, retainerSetOfc))
1647 goto loop; // no need to process child
1648
1649 if (s == NULL)
1650 associate(c, addElement(r, retainerSetOfc));
1651 else {
1652 // s is not NULL and cp is not a retainer. This means that
1653 // each time *cp is visited, so is *c. Thus, if s has
1654 // exactly one more element in its retainer set than c, s
1655 // is also the new retainer set for *c.
1656 if (s->num == retainerSetOfc->num + 1) {
1657 associate(c, s);
1658 }
1659 // Otherwise, just add R_r to the current retainer set of *c.
1660 else {
1661 associate(c, addElement(r, retainerSetOfc));
1662 }
1663 }
1664
1665 if (isRetainer(c))
1666 goto loop; // no need to process child
1667
1668 // compute c_child_r
1669 c_child_r = r;
1670 }
1671
1672 // now, RSET() of all of *c, *cp, and *r is valid.
1673 // (c, c_child_r) are available.
1674
1675 // process child
1676
1677 // Special case closures: we process these all in one go rather
1678 // than attempting to save the current position, because doing so
1679 // would be hard.
1680 switch (typeOfc) {
1681 case STACK:
1682 retainStack(c, c_child_r,
1683 ((StgStack *)c)->sp,
1684 ((StgStack *)c)->stack + ((StgStack *)c)->stack_size);
1685 goto loop;
1686
1687 case TSO:
1688 {
1689 StgTSO *tso = (StgTSO *)c;
1690
1691 retainClosure(tso->stackobj, c, c_child_r);
1692 retainClosure(tso->blocked_exceptions, c, c_child_r);
1693 retainClosure(tso->bq, c, c_child_r);
1694 retainClosure(tso->trec, c, c_child_r);
1695 if ( tso->why_blocked == BlockedOnMVar
1696 || tso->why_blocked == BlockedOnBlackHole
1697 || tso->why_blocked == BlockedOnMsgThrowTo
1698 ) {
1699 retainClosure(tso->block_info.closure, c, c_child_r);
1700 }
1701 goto loop;
1702 }
1703
1704 case PAP:
1705 {
1706 StgPAP *pap = (StgPAP *)c;
1707 retain_PAP_payload(c, c_child_r, pap->fun, pap->payload, pap->n_args);
1708 goto loop;
1709 }
1710
1711 case AP:
1712 {
1713 StgAP *ap = (StgAP *)c;
1714 retain_PAP_payload(c, c_child_r, ap->fun, ap->payload, ap->n_args);
1715 goto loop;
1716 }
1717
1718 case AP_STACK:
1719 retainClosure(((StgAP_STACK *)c)->fun, c, c_child_r);
1720 retainStack(c, c_child_r,
1721 (StgPtr)((StgAP_STACK *)c)->payload,
1722 (StgPtr)((StgAP_STACK *)c)->payload +
1723 ((StgAP_STACK *)c)->size);
1724 goto loop;
1725 }
1726
1727 push(c, c_child_r, &first_child);
1728
1729 // If first_child is null, c has no child.
1730 // If first_child is not null, the top stack element points to the next
1731 // object. push() may or may not push a stackElement on the stack.
1732 if (first_child == NULL)
1733 goto loop;
1734
1735 // (c, cp, r) = (first_child, c, c_child_r)
1736 r = c_child_r;
1737 cp = c;
1738 c = first_child;
1739 goto inner_loop;
1740 }
1741
1742 /* -----------------------------------------------------------------------------
1743 * Compute the retainer set for every object reachable from *tl.
1744 * -------------------------------------------------------------------------- */
1745 static void
1746 retainRoot(void *user STG_UNUSED, StgClosure **tl)
1747 {
1748 StgClosure *c;
1749
1750 // We no longer assume that only TSOs and WEAKs are roots; any closure can
1751 // be a root.
1752
1753 ASSERT(isEmptyRetainerStack());
1754 currentStackBoundary = stackTop;
1755
1756 c = UNTAG_CLOSURE(*tl);
1757 if (c != &stg_END_TSO_QUEUE_closure && isRetainer(c)) {
1758 retainClosure(c, c, getRetainerFrom(c));
1759 } else {
1760 retainClosure(c, c, CCS_SYSTEM);
1761 }
1762
1763 // NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl)));
1764 // *tl might be a TSO which is ThreadComplete, in which
1765 // case we ignore it for the purposes of retainer profiling.
1766 }
1767
1768 /* -----------------------------------------------------------------------------
1769 * Compute the retainer set for each of the objects in the heap.
1770 * -------------------------------------------------------------------------- */
1771 static void
1772 computeRetainerSet( void )
1773 {
1774 StgWeak *weak;
1775 RetainerSet *rtl;
1776 nat g, n;
1777 StgPtr ml;
1778 bdescr *bd;
1779 #ifdef DEBUG_RETAINER
1780 RetainerSet tmpRetainerSet;
1781 #endif
1782
1783 markCapabilities(retainRoot, NULL); // for scheduler roots
1784
1785 // This function is called after a major GC, when key, value, and finalizer
1786 // all are guaranteed to be valid, or reachable.
1787 //
1788 // The following code assumes that WEAK objects are considered to be roots
1789 // for retainer profilng.
1790 for (weak = weak_ptr_list; weak != NULL; weak = weak->link)
1791 // retainRoot((StgClosure *)weak);
1792 retainRoot(NULL, (StgClosure **)&weak);
1793
1794 // Consider roots from the stable ptr table.
1795 markStablePtrTable(retainRoot, NULL);
1796
1797 // The following code resets the rs field of each unvisited mutable
1798 // object (computing sumOfNewCostExtra and updating costArray[] when
1799 // debugging retainer profiler).
1800 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1801 // NOT TRUE: even G0 has a block on its mutable list
1802 // ASSERT(g != 0 || (generations[g].mut_list == NULL));
1803
1804 // Traversing through mut_list is necessary
1805 // because we can find MUT_VAR objects which have not been
1806 // visited during retainer profiling.
1807 for (n = 0; n < n_capabilities; n++) {
1808 for (bd = capabilities[n].mut_lists[g]; bd != NULL; bd = bd->link) {
1809 for (ml = bd->start; ml < bd->free; ml++) {
1810
1811 maybeInitRetainerSet((StgClosure *)*ml);
1812 rtl = retainerSetOf((StgClosure *)*ml);
1813
1814 #ifdef DEBUG_RETAINER
1815 if (rtl == NULL) {
1816 // first visit to *ml
1817 // This is a violation of the interface rule!
1818 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1819
1820 switch (get_itbl((StgClosure *)ml)->type) {
1821 case IND_STATIC:
1822 // no cost involved
1823 break;
1824 case CONSTR_NOCAF_STATIC:
1825 case CONSTR_STATIC:
1826 case THUNK_STATIC:
1827 case FUN_STATIC:
1828 barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1829 break;
1830 default:
1831 // dynamic objects
1832 costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1833 sumOfNewCostExtra += cost((StgClosure *)ml);
1834 break;
1835 }
1836 }
1837 #endif
1838 }
1839 }
1840 }
1841 }
1842 }
1843
1844 /* -----------------------------------------------------------------------------
1845 * Traverse all static objects for which we compute retainer sets,
1846 * and reset their rs fields to NULL, which is accomplished by
1847 * invoking maybeInitRetainerSet(). This function must be called
1848 * before zeroing all objects reachable from scavenged_static_objects
1849 * in the case of major gabage collections. See GarbageCollect() in
1850 * GC.c.
1851 * Note:
1852 * The mut_once_list of the oldest generation must also be traversed?
1853 * Why? Because if the evacuation of an object pointed to by a static
1854 * indirection object fails, it is put back to the mut_once_list of
1855 * the oldest generation.
1856 * However, this is not necessary because any static indirection objects
1857 * are just traversed through to reach dynamic objects. In other words,
1858 * they are not taken into consideration in computing retainer sets.
1859 * -------------------------------------------------------------------------- */
1860 void
1861 resetStaticObjectForRetainerProfiling( StgClosure *static_objects )
1862 {
1863 #ifdef DEBUG_RETAINER
1864 nat count;
1865 #endif
1866 StgClosure *p;
1867
1868 #ifdef DEBUG_RETAINER
1869 count = 0;
1870 #endif
1871 p = static_objects;
1872 while (p != END_OF_STATIC_LIST) {
1873 #ifdef DEBUG_RETAINER
1874 count++;
1875 #endif
1876 switch (get_itbl(p)->type) {
1877 case IND_STATIC:
1878 // Since we do not compute the retainer set of any
1879 // IND_STATIC object, we don't have to reset its retainer
1880 // field.
1881 p = (StgClosure*)*IND_STATIC_LINK(p);
1882 break;
1883 case THUNK_STATIC:
1884 maybeInitRetainerSet(p);
1885 p = (StgClosure*)*THUNK_STATIC_LINK(p);
1886 break;
1887 case FUN_STATIC:
1888 maybeInitRetainerSet(p);
1889 p = (StgClosure*)*FUN_STATIC_LINK(p);
1890 break;
1891 case CONSTR_STATIC:
1892 maybeInitRetainerSet(p);
1893 p = (StgClosure*)*STATIC_LINK(get_itbl(p), p);
1894 break;
1895 default:
1896 barf("resetStaticObjectForRetainerProfiling: %p (%s)",
1897 p, get_itbl(p)->type);
1898 break;
1899 }
1900 }
1901 #ifdef DEBUG_RETAINER
1902 // debugBelch("count in scavenged_static_objects = %d\n", count);
1903 #endif
1904 }
1905
1906 /* -----------------------------------------------------------------------------
1907 * Perform retainer profiling.
1908 * N is the oldest generation being profilied, where the generations are
1909 * numbered starting at 0.
1910 * Invariants:
1911 * Note:
1912 * This function should be called only immediately after major garbage
1913 * collection.
1914 * ------------------------------------------------------------------------- */
1915 void
1916 retainerProfile(void)
1917 {
1918 #ifdef DEBUG_RETAINER
1919 nat i;
1920 nat totalHeapSize; // total raw heap size (computed by linear scanning)
1921 #endif
1922
1923 #ifdef DEBUG_RETAINER
1924 debugBelch(" < retainerProfile() invoked : %d>\n", retainerGeneration);
1925 #endif
1926
1927 stat_startRP();
1928
1929 // We haven't flipped the bit yet.
1930 #ifdef DEBUG_RETAINER
1931 debugBelch("Before traversing:\n");
1932 sumOfCostLinear = 0;
1933 for (i = 0;i < N_CLOSURE_TYPES; i++)
1934 costArrayLinear[i] = 0;
1935 totalHeapSize = checkHeapSanityForRetainerProfiling();
1936
1937 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1938 /*
1939 debugBelch("costArrayLinear[] = ");
1940 for (i = 0;i < N_CLOSURE_TYPES; i++)
1941 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
1942 debugBelch("\n");
1943 */
1944
1945 ASSERT(sumOfCostLinear == totalHeapSize);
1946
1947 /*
1948 #define pcostArrayLinear(index) \
1949 if (costArrayLinear[index] > 0) \
1950 debugBelch("costArrayLinear[" #index "] = %u\n", costArrayLinear[index])
1951 pcostArrayLinear(THUNK_STATIC);
1952 pcostArrayLinear(FUN_STATIC);
1953 pcostArrayLinear(CONSTR_STATIC);
1954 pcostArrayLinear(CONSTR_NOCAF_STATIC);
1955 */
1956 #endif
1957
1958 // Now we flips flip.
1959 flip = flip ^ 1;
1960
1961 #ifdef DEBUG_RETAINER
1962 stackSize = 0;
1963 maxStackSize = 0;
1964 cStackSize = 0;
1965 maxCStackSize = 0;
1966 #endif
1967 numObjectVisited = 0;
1968 timesAnyObjectVisited = 0;
1969
1970 #ifdef DEBUG_RETAINER
1971 debugBelch("During traversing:\n");
1972 sumOfNewCost = 0;
1973 sumOfNewCostExtra = 0;
1974 for (i = 0;i < N_CLOSURE_TYPES; i++)
1975 costArray[i] = 0;
1976 #endif
1977
1978 /*
1979 We initialize the traverse stack each time the retainer profiling is
1980 performed (because the traverse stack size varies on each retainer profiling
1981 and this operation is not costly anyhow). However, we just refresh the
1982 retainer sets.
1983 */
1984 initializeTraverseStack();
1985 #ifdef DEBUG_RETAINER
1986 initializeAllRetainerSet();
1987 #else
1988 refreshAllRetainerSet();
1989 #endif
1990 computeRetainerSet();
1991
1992 #ifdef DEBUG_RETAINER
1993 debugBelch("After traversing:\n");
1994 sumOfCostLinear = 0;
1995 for (i = 0;i < N_CLOSURE_TYPES; i++)
1996 costArrayLinear[i] = 0;
1997 totalHeapSize = checkHeapSanityForRetainerProfiling();
1998
1999 debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
2000 ASSERT(sumOfCostLinear == totalHeapSize);
2001
2002 // now, compare the two results
2003 /*
2004 Note:
2005 costArray[] must be exactly the same as costArrayLinear[].
2006 Known exceptions:
2007 1) Dead weak pointers, whose type is CONSTR. These objects are not
2008 reachable from any roots.
2009 */
2010 debugBelch("Comparison:\n");
2011 debugBelch("\tcostArrayLinear[] (must be empty) = ");
2012 for (i = 0;i < N_CLOSURE_TYPES; i++)
2013 if (costArray[i] != costArrayLinear[i])
2014 // nothing should be printed except MUT_VAR after major GCs
2015 debugBelch("[%u:%u] ", i, costArrayLinear[i]);
2016 debugBelch("\n");
2017
2018 debugBelch("\tsumOfNewCost = %u\n", sumOfNewCost);
2019 debugBelch("\tsumOfNewCostExtra = %u\n", sumOfNewCostExtra);
2020 debugBelch("\tcostArray[] (must be empty) = ");
2021 for (i = 0;i < N_CLOSURE_TYPES; i++)
2022 if (costArray[i] != costArrayLinear[i])
2023 // nothing should be printed except MUT_VAR after major GCs
2024 debugBelch("[%u:%u] ", i, costArray[i]);
2025 debugBelch("\n");
2026
2027 // only for major garbage collection
2028 ASSERT(sumOfNewCost + sumOfNewCostExtra == sumOfCostLinear);
2029 #endif
2030
2031 // post-processing
2032 closeTraverseStack();
2033 #ifdef DEBUG_RETAINER
2034 closeAllRetainerSet();
2035 #else
2036 // Note that there is no post-processing for the retainer sets.
2037 #endif
2038 retainerGeneration++;
2039
2040 stat_endRP(
2041 retainerGeneration - 1, // retainerGeneration has just been incremented!
2042 #ifdef DEBUG_RETAINER
2043 maxCStackSize, maxStackSize,
2044 #endif
2045 (double)timesAnyObjectVisited / numObjectVisited);
2046 }
2047
2048 /* -----------------------------------------------------------------------------
2049 * DEBUGGING CODE
2050 * -------------------------------------------------------------------------- */
2051
2052 #ifdef DEBUG_RETAINER
2053
2054 #define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
2055 ((HEAP_ALLOCED(r) && ((Bdescr((P_)r)->flags & BF_FREE) == 0)))) && \
2056 ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa))
2057
2058 static nat
2059 sanityCheckHeapClosure( StgClosure *c )
2060 {
2061 StgInfoTable *info;
2062
2063 ASSERT(LOOKS_LIKE_GHC_INFO(c->header.info));
2064 ASSERT(!closure_STATIC(c));
2065 ASSERT(LOOKS_LIKE_PTR(c));
2066
2067 if ((((StgWord)RSET(c) & 1) ^ flip) != 0) {
2068 if (get_itbl(c)->type == CONSTR &&
2069 !strcmp(GET_PROF_TYPE(get_itbl(c)), "DEAD_WEAK") &&
2070 !strcmp(GET_PROF_DESC(get_itbl(c)), "DEAD_WEAK")) {
2071 debugBelch("\tUnvisited dead weak pointer object found: c = %p\n", c);
2072 costArray[get_itbl(c)->type] += cost(c);
2073 sumOfNewCost += cost(c);
2074 } else
2075 debugBelch(
2076 "Unvisited object: flip = %d, c = %p(%d, %s, %s), rs = %p\n",
2077 flip, c, get_itbl(c)->type,
2078 get_itbl(c)->prof.closure_type, GET_PROF_DESC(get_itbl(c)),
2079 RSET(c));
2080 } else {
2081 // debugBelch("sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c));
2082 }
2083
2084 return closure_sizeW(c);
2085 }
2086
2087 static nat
2088 heapCheck( bdescr *bd )
2089 {
2090 StgPtr p;
2091 static nat costSum, size;
2092
2093 costSum = 0;
2094 while (bd != NULL) {
2095 p = bd->start;
2096 while (p < bd->free) {
2097 size = sanityCheckHeapClosure((StgClosure *)p);
2098 sumOfCostLinear += size;
2099 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2100 p += size;
2101 // no need for slop check; I think slops are not used currently.
2102 }
2103 ASSERT(p == bd->free);
2104 costSum += bd->free - bd->start;
2105 bd = bd->link;
2106 }
2107
2108 return costSum;
2109 }
2110
2111 static nat
2112 smallObjectPoolCheck(void)
2113 {
2114 bdescr *bd;
2115 StgPtr p;
2116 static nat costSum, size;
2117
2118 bd = g0s0->blocks;
2119 costSum = 0;
2120
2121 // first block
2122 if (bd == NULL)
2123 return costSum;
2124
2125 p = bd->start;
2126 while (p < alloc_Hp) {
2127 size = sanityCheckHeapClosure((StgClosure *)p);
2128 sumOfCostLinear += size;
2129 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2130 p += size;
2131 }
2132 ASSERT(p == alloc_Hp);
2133 costSum += alloc_Hp - bd->start;
2134
2135 bd = bd->link;
2136 while (bd != NULL) {
2137 p = bd->start;
2138 while (p < bd->free) {
2139 size = sanityCheckHeapClosure((StgClosure *)p);
2140 sumOfCostLinear += size;
2141 costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2142 p += size;
2143 }
2144 ASSERT(p == bd->free);
2145 costSum += bd->free - bd->start;
2146 bd = bd->link;
2147 }
2148
2149 return costSum;
2150 }
2151
2152 static nat
2153 chainCheck(bdescr *bd)
2154 {
2155 nat costSum, size;
2156
2157 costSum = 0;
2158 while (bd != NULL) {
2159 // bd->free - bd->start is not an accurate measurement of the
2160 // object size. Actually it is always zero, so we compute its
2161 // size explicitly.
2162 size = sanityCheckHeapClosure((StgClosure *)bd->start);
2163 sumOfCostLinear += size;
2164 costArrayLinear[get_itbl((StgClosure *)bd->start)->type] += size;
2165 costSum += size;
2166 bd = bd->link;
2167 }
2168
2169 return costSum;
2170 }
2171
2172 static nat
2173 checkHeapSanityForRetainerProfiling( void )
2174 {
2175 nat costSum, g, s;
2176
2177 costSum = 0;
2178 debugBelch("START: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2179 if (RtsFlags.GcFlags.generations == 1) {
2180 costSum += heapCheck(g0s0->to_blocks);
2181 debugBelch("heapCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2182 costSum += chainCheck(g0s0->large_objects);
2183 debugBelch("chainCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2184 } else {
2185 for (g = 0; g < RtsFlags.GcFlags.generations; g++)
2186 for (s = 0; s < generations[g].n_steps; s++) {
2187 /*
2188 After all live objects have been scavenged, the garbage
2189 collector may create some objects in
2190 scheduleFinalizers(). These objects are created throught
2191 allocate(), so the small object pool or the large object
2192 pool of the g0s0 may not be empty.
2193 */
2194 if (g == 0 && s == 0) {
2195 costSum += smallObjectPoolCheck();
2196 debugBelch("smallObjectPoolCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2197 costSum += chainCheck(generations[g].steps[s].large_objects);
2198 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2199 } else {
2200 costSum += heapCheck(generations[g].steps[s].blocks);
2201 debugBelch("heapCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2202 costSum += chainCheck(generations[g].steps[s].large_objects);
2203 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2204 }
2205 }
2206 }
2207
2208 return costSum;
2209 }
2210
2211 void
2212 findPointer(StgPtr p)
2213 {
2214 StgPtr q, r, e;
2215 bdescr *bd;
2216 nat g, s;
2217
2218 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2219 for (s = 0; s < generations[g].n_steps; s++) {
2220 // if (g == 0 && s == 0) continue;
2221 bd = generations[g].steps[s].blocks;
2222 for (; bd; bd = bd->link) {
2223 for (q = bd->start; q < bd->free; q++) {
2224 if (*q == (StgWord)p) {
2225 r = q;
2226 while (!LOOKS_LIKE_GHC_INFO(*r)) r--;
2227 debugBelch("Found in gen[%d], step[%d]: q = %p, r = %p\n", g, s, q, r);
2228 // return;
2229 }
2230 }
2231 }
2232 bd = generations[g].steps[s].large_objects;
2233 for (; bd; bd = bd->link) {
2234 e = bd->start + cost((StgClosure *)bd->start);
2235 for (q = bd->start; q < e; q++) {
2236 if (*q == (StgWord)p) {
2237 r = q;
2238 while (*r == 0 || !LOOKS_LIKE_GHC_INFO(*r)) r--;
2239 debugBelch("Found in gen[%d], large_objects: %p\n", g, r);
2240 // return;
2241 }
2242 }
2243 }
2244 }
2245 }
2246 }
2247
2248 static void
2249 belongToHeap(StgPtr p)
2250 {
2251 bdescr *bd;
2252 nat g, s;
2253
2254 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2255 for (s = 0; s < generations[g].n_steps; s++) {
2256 // if (g == 0 && s == 0) continue;
2257 bd = generations[g].steps[s].blocks;
2258 for (; bd; bd = bd->link) {
2259 if (bd->start <= p && p < bd->free) {
2260 debugBelch("Belongs to gen[%d], step[%d]", g, s);
2261 return;
2262 }
2263 }
2264 bd = generations[g].steps[s].large_objects;
2265 for (; bd; bd = bd->link) {
2266 if (bd->start <= p && p < bd->start + getHeapClosureSize((StgClosure *)bd->start)) {
2267 debugBelch("Found in gen[%d], large_objects: %p\n", g, bd->start);
2268 return;
2269 }
2270 }
2271 }
2272 }
2273 }
2274 #endif /* DEBUG_RETAINER */
2275
2276 #endif /* PROFILING */