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