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 */