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