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