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