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