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