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