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_TARGET_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     case BLACKHOLE:
1058         // static objects
1059     case CONSTR_STATIC:
1060     case FUN_STATIC:
1061         // misc
1062     case PRIM:
1063     case BCO:
1064     case ARR_WORDS:
1065         // STM
1066     case TREC_CHUNK:
1067         return rtsFalse;
1068
1069         //
1070         // Error case
1071         //
1072         // IND_STATIC cannot be *c, *cp, *r in the retainer profiling loop.
1073     case IND_STATIC:
1074         // CONSTR_NOCAF_STATIC
1075         // cannot be *c, *cp, *r in the retainer profiling loop.
1076     case CONSTR_NOCAF_STATIC:
1077         // Stack objects are invalid because they are never treated as
1078         // legal objects during retainer profiling.
1079     case UPDATE_FRAME:
1080     case CATCH_FRAME:
1081     case STOP_FRAME:
1082     case RET_DYN:
1083     case RET_BCO:
1084     case RET_SMALL:
1085     case RET_BIG:
1086         // other cases
1087     case IND:
1088     case INVALID_OBJECT:
1089     default:
1090         barf("Invalid object in isRetainer(): %d", get_itbl(c)->type);
1091         return rtsFalse;
1092     }
1093 }
1094
1095 /* -----------------------------------------------------------------------------
1096  *  Returns the retainer function value for the closure *c, i.e., R(*c).
1097  *  This function does NOT return the retainer(s) of *c.
1098  *  Invariants:
1099  *    *c must be a retainer.
1100  *  Note:
1101  *    Depending on the definition of this function, the maintenance of retainer
1102  *    sets can be made easier. If most retainer sets are likely to be created
1103  *    again across garbage collections, refreshAllRetainerSet() in
1104  *    RetainerSet.c can simply do nothing.
1105  *    If this is not the case, we can free all the retainer sets and
1106  *    re-initialize the hash table.
1107  *    See refreshAllRetainerSet() in RetainerSet.c.
1108  * -------------------------------------------------------------------------- */
1109 static INLINE retainer
1110 getRetainerFrom( StgClosure *c )
1111 {
1112     ASSERT(isRetainer(c));
1113
1114 #if defined(RETAINER_SCHEME_INFO)
1115     // Retainer scheme 1: retainer = info table
1116     return get_itbl(c);
1117 #elif defined(RETAINER_SCHEME_CCS)
1118     // Retainer scheme 2: retainer = cost centre stack
1119     return c->header.prof.ccs;
1120 #elif defined(RETAINER_SCHEME_CC)
1121     // Retainer scheme 3: retainer = cost centre
1122     return c->header.prof.ccs->cc;
1123 #endif
1124 }
1125
1126 /* -----------------------------------------------------------------------------
1127  *  Associates the retainer set *s with the closure *c, that is, *s becomes
1128  *  the retainer set of *c.
1129  *  Invariants:
1130  *    c != NULL
1131  *    s != NULL
1132  * -------------------------------------------------------------------------- */
1133 static INLINE void
1134 associate( StgClosure *c, RetainerSet *s )
1135 {
1136     // StgWord has the same size as pointers, so the following type
1137     // casting is okay.
1138     RSET(c) = (RetainerSet *)((StgWord)s | flip);
1139 }
1140
1141 /* -----------------------------------------------------------------------------
1142    Call retainClosure for each of the closures covered by a large bitmap.
1143    -------------------------------------------------------------------------- */
1144
1145 static void
1146 retain_large_bitmap (StgPtr p, StgLargeBitmap *large_bitmap, nat size,
1147                      StgClosure *c, retainer c_child_r)
1148 {
1149     nat i, b;
1150     StgWord bitmap;
1151
1152     b = 0;
1153     bitmap = large_bitmap->bitmap[b];
1154     for (i = 0; i < size; ) {
1155         if ((bitmap & 1) == 0) {
1156             retainClosure((StgClosure *)*p, c, c_child_r);
1157         }
1158         i++;
1159         p++;
1160         if (i % BITS_IN(W_) == 0) {
1161             b++;
1162             bitmap = large_bitmap->bitmap[b];
1163         } else {
1164             bitmap = bitmap >> 1;
1165         }
1166     }
1167 }
1168
1169 static INLINE StgPtr
1170 retain_small_bitmap (StgPtr p, nat size, StgWord bitmap,
1171                      StgClosure *c, retainer c_child_r)
1172 {
1173     while (size > 0) {
1174         if ((bitmap & 1) == 0) {
1175             retainClosure((StgClosure *)*p, c, c_child_r);
1176         }
1177         p++;
1178         bitmap = bitmap >> 1;
1179         size--;
1180     }
1181     return p;
1182 }
1183
1184 /* -----------------------------------------------------------------------------
1185  * Call retainClosure for each of the closures in an SRT.
1186  * ------------------------------------------------------------------------- */
1187
1188 static void
1189 retain_large_srt_bitmap (StgLargeSRT *srt, StgClosure *c, retainer c_child_r)
1190 {
1191     nat i, b, size;
1192     StgWord bitmap;
1193     StgClosure **p;
1194
1195     b = 0;
1196     p = (StgClosure **)srt->srt;
1197     size   = srt->l.size;
1198     bitmap = srt->l.bitmap[b];
1199     for (i = 0; i < size; ) {
1200         if ((bitmap & 1) != 0) {
1201             retainClosure((StgClosure *)*p, c, c_child_r);
1202         }
1203         i++;
1204         p++;
1205         if (i % BITS_IN(W_) == 0) {
1206             b++;
1207             bitmap = srt->l.bitmap[b];
1208         } else {
1209             bitmap = bitmap >> 1;
1210         }
1211     }
1212 }
1213
1214 static INLINE void
1215 retainSRT (StgClosure **srt, nat srt_bitmap, StgClosure *c, retainer c_child_r)
1216 {
1217   nat bitmap;
1218   StgClosure **p;
1219
1220   bitmap = srt_bitmap;
1221   p = srt;
1222
1223   if (bitmap == (StgHalfWord)(-1)) {
1224       retain_large_srt_bitmap( (StgLargeSRT *)srt, c, c_child_r );
1225       return;
1226   }
1227
1228   while (bitmap != 0) {
1229       if ((bitmap & 1) != 0) {
1230 #if defined(__PIC__) && defined(mingw32_TARGET_OS)
1231           if ( (unsigned long)(*srt) & 0x1 ) {
1232               retainClosure(* (StgClosure**) ((unsigned long) (*srt) & ~0x1),
1233                             c, c_child_r);
1234           } else {
1235               retainClosure(*srt,c,c_child_r);
1236           }
1237 #else
1238           retainClosure(*srt,c,c_child_r);
1239 #endif
1240       }
1241       p++;
1242       bitmap = bitmap >> 1;
1243   }
1244 }
1245
1246 /* -----------------------------------------------------------------------------
1247  *  Process all the objects in the stack chunk from stackStart to stackEnd
1248  *  with *c and *c_child_r being their parent and their most recent retainer,
1249  *  respectively. Treat stackOptionalFun as another child of *c if it is
1250  *  not NULL.
1251  *  Invariants:
1252  *    *c is one of the following: TSO, AP_STACK.
1253  *    If *c is TSO, c == c_child_r.
1254  *    stackStart < stackEnd.
1255  *    RSET(c) and RSET(c_child_r) are valid, i.e., their
1256  *    interpretation conforms to the current value of flip (even when they
1257  *    are interpreted to be NULL).
1258  *    If *c is TSO, its state is not any of ThreadRelocated, ThreadComplete,
1259  *    or ThreadKilled, which means that its stack is ready to process.
1260  *  Note:
1261  *    This code was almost plagiarzied from GC.c! For each pointer,
1262  *    retainClosure() is invoked instead of evacuate().
1263  * -------------------------------------------------------------------------- */
1264 static void
1265 retainStack( StgClosure *c, retainer c_child_r,
1266              StgPtr stackStart, StgPtr stackEnd )
1267 {
1268     stackElement *oldStackBoundary;
1269     StgPtr p;
1270     StgRetInfoTable *info;
1271     StgWord32 bitmap;
1272     nat size;
1273
1274 #ifdef DEBUG_RETAINER
1275     cStackSize++;
1276     if (cStackSize > maxCStackSize) maxCStackSize = cStackSize;
1277 #endif
1278
1279     /*
1280       Each invocation of retainStack() creates a new virtual
1281       stack. Since all such stacks share a single common stack, we
1282       record the current currentStackBoundary, which will be restored
1283       at the exit.
1284     */
1285     oldStackBoundary = currentStackBoundary;
1286     currentStackBoundary = stackTop;
1287
1288 #ifdef DEBUG_RETAINER
1289     // debugBelch("retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
1290 #endif
1291
1292     ASSERT(get_itbl(c)->type != TSO ||
1293            (((StgTSO *)c)->what_next != ThreadRelocated &&
1294             ((StgTSO *)c)->what_next != ThreadComplete &&
1295             ((StgTSO *)c)->what_next != ThreadKilled));
1296
1297     p = stackStart;
1298     while (p < stackEnd) {
1299         info = get_ret_itbl((StgClosure *)p);
1300
1301         switch(info->i.type) {
1302
1303         case UPDATE_FRAME:
1304             retainClosure(((StgUpdateFrame *)p)->updatee, c, c_child_r);
1305             p += sizeofW(StgUpdateFrame);
1306             continue;
1307
1308         case STOP_FRAME:
1309         case CATCH_FRAME:
1310         case CATCH_STM_FRAME:
1311         case CATCH_RETRY_FRAME:
1312         case ATOMICALLY_FRAME:
1313         case RET_SMALL:
1314             bitmap = BITMAP_BITS(info->i.layout.bitmap);
1315             size   = BITMAP_SIZE(info->i.layout.bitmap);
1316             p++;
1317             p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1318
1319         follow_srt:
1320             retainSRT((StgClosure **)GET_SRT(info), info->i.srt_bitmap, c, c_child_r);
1321             continue;
1322
1323         case RET_BCO: {
1324             StgBCO *bco;
1325
1326             p++;
1327             retainClosure((StgClosure *)*p, c, c_child_r);
1328             bco = (StgBCO *)*p;
1329             p++;
1330             size = BCO_BITMAP_SIZE(bco);
1331             retain_large_bitmap(p, BCO_BITMAP(bco), size, c, c_child_r);
1332             p += size;
1333             continue;
1334         }
1335
1336             // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
1337         case RET_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(UNTAG_CLOSURE(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,    /* NOT tagged */
1420                     retainer c_child_r, /* NOT tagged */
1421                     StgClosure *fun,    /* tagged */
1422                     StgClosure** payload, StgWord n_args)
1423 {
1424     StgPtr p;
1425     StgWord bitmap;
1426     StgFunInfoTable *fun_info;
1427
1428     retainClosure(fun, pap, c_child_r);
1429     fun = UNTAG_CLOSURE(fun);
1430     fun_info = get_fun_itbl(fun);
1431     ASSERT(fun_info->i.type != PAP);
1432
1433     p = (StgPtr)payload;
1434
1435     switch (fun_info->f.fun_type) {
1436     case ARG_GEN:
1437         bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
1438         p = retain_small_bitmap(p, n_args, bitmap,
1439                                 pap, c_child_r);
1440         break;
1441     case ARG_GEN_BIG:
1442         retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
1443                             n_args, pap, c_child_r);
1444         p += n_args;
1445         break;
1446     case ARG_BCO:
1447         retain_large_bitmap((StgPtr)payload, BCO_BITMAP(fun),
1448                             n_args, pap, c_child_r);
1449         p += n_args;
1450         break;
1451     default:
1452         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1453         p = retain_small_bitmap(p, n_args, bitmap, pap, c_child_r);
1454         break;
1455     }
1456     return p;
1457 }
1458
1459 /* -----------------------------------------------------------------------------
1460  *  Compute the retainer set of *c0 and all its desecents by traversing.
1461  *  *cp0 is the parent of *c0, and *r0 is the most recent retainer of *c0.
1462  *  Invariants:
1463  *    c0 = cp0 = r0 holds only for root objects.
1464  *    RSET(cp0) and RSET(r0) are valid, i.e., their
1465  *    interpretation conforms to the current value of flip (even when they
1466  *    are interpreted to be NULL).
1467  *    However, RSET(c0) may be corrupt, i.e., it may not conform to
1468  *    the current value of flip. If it does not, during the execution
1469  *    of this function, RSET(c0) must be initialized as well as all
1470  *    its descendants.
1471  *  Note:
1472  *    stackTop must be the same at the beginning and the exit of this function.
1473  *    *c0 can be TSO (as well as AP_STACK).
1474  * -------------------------------------------------------------------------- */
1475 static void
1476 retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
1477 {
1478     // c = Current closure                          (possibly tagged)
1479     // cp = Current closure's Parent                (NOT tagged)
1480     // r = current closures' most recent Retainer   (NOT tagged)
1481     // c_child_r = current closure's children's most recent retainer
1482     // first_child = first child of c
1483     StgClosure *c, *cp, *first_child;
1484     RetainerSet *s, *retainerSetOfc;
1485     retainer r, c_child_r;
1486     StgWord typeOfc;
1487
1488 #ifdef DEBUG_RETAINER
1489     // StgPtr oldStackTop;
1490 #endif
1491
1492 #ifdef DEBUG_RETAINER
1493     // oldStackTop = stackTop;
1494     // debugBelch("retainClosure() called: c0 = 0x%x, cp0 = 0x%x, r0 = 0x%x\n", c0, cp0, r0);
1495 #endif
1496
1497     // (c, cp, r) = (c0, cp0, r0)
1498     c = c0;
1499     cp = cp0;
1500     r = r0;
1501     goto inner_loop;
1502
1503 loop:
1504     //debugBelch("loop");
1505     // pop to (c, cp, r);
1506     pop(&c, &cp, &r);
1507
1508     if (c == NULL) {
1509 #ifdef DEBUG_RETAINER
1510         // debugBelch("retainClosure() ends: oldStackTop = 0x%x, stackTop = 0x%x\n", oldStackTop, stackTop);
1511 #endif
1512         return;
1513     }
1514
1515     //debugBelch("inner_loop");
1516
1517 inner_loop:
1518     c = UNTAG_CLOSURE(c);
1519
1520     // c  = current closure under consideration,
1521     // cp = current closure's parent,
1522     // r  = current closure's most recent retainer
1523     //
1524     // Loop invariants (on the meaning of c, cp, r, and their retainer sets):
1525     //   RSET(cp) and RSET(r) are valid.
1526     //   RSET(c) is valid only if c has been visited before.
1527     //
1528     // Loop invariants (on the relation between c, cp, and r)
1529     //   if cp is not a retainer, r belongs to RSET(cp).
1530     //   if cp is a retainer, r == cp.
1531
1532     typeOfc = get_itbl(c)->type;
1533
1534 #ifdef DEBUG_RETAINER
1535     switch (typeOfc) {
1536     case IND_STATIC:
1537     case CONSTR_NOCAF_STATIC:
1538     case CONSTR_STATIC:
1539     case THUNK_STATIC:
1540     case FUN_STATIC:
1541         break;
1542     default:
1543         if (retainerSetOf(c) == NULL) {   // first visit?
1544             costArray[typeOfc] += cost(c);
1545             sumOfNewCost += cost(c);
1546         }
1547         break;
1548     }
1549 #endif
1550
1551     // special cases
1552     switch (typeOfc) {
1553     case TSO:
1554         if (((StgTSO *)c)->what_next == ThreadComplete ||
1555             ((StgTSO *)c)->what_next == ThreadKilled) {
1556 #ifdef DEBUG_RETAINER
1557             debugBelch("ThreadComplete or ThreadKilled encountered in retainClosure()\n");
1558 #endif
1559             goto loop;
1560         }
1561         if (((StgTSO *)c)->what_next == ThreadRelocated) {
1562 #ifdef DEBUG_RETAINER
1563             debugBelch("ThreadRelocated encountered in retainClosure()\n");
1564 #endif
1565             c = (StgClosure *)((StgTSO *)c)->_link;
1566             goto inner_loop;
1567         }
1568         break;
1569
1570     case IND_STATIC:
1571         // We just skip IND_STATIC, so its retainer set is never computed.
1572         c = ((StgIndStatic *)c)->indirectee;
1573         goto inner_loop;
1574         // static objects with no pointers out, so goto loop.
1575     case CONSTR_NOCAF_STATIC:
1576         // It is not just enough not to compute the retainer set for *c; it is
1577         // mandatory because CONSTR_NOCAF_STATIC are not reachable from
1578         // scavenged_static_objects, the list from which is assumed to traverse
1579         // all static objects after major garbage collections.
1580         goto loop;
1581     case THUNK_STATIC:
1582     case FUN_STATIC:
1583         if (get_itbl(c)->srt_bitmap == 0) {
1584             // No need to compute the retainer set; no dynamic objects
1585             // are reachable from *c.
1586             //
1587             // Static objects: if we traverse all the live closures,
1588             // including static closures, during each heap census then
1589             // we will observe that some static closures appear and
1590             // disappear.  eg. a closure may contain a pointer to a
1591             // static function 'f' which is not otherwise reachable
1592             // (it doesn't indirectly point to any CAFs, so it doesn't
1593             // appear in any SRTs), so we would find 'f' during
1594             // traversal.  However on the next sweep there may be no
1595             // closures pointing to 'f'.
1596             //
1597             // We must therefore ignore static closures whose SRT is
1598             // empty, because these are exactly the closures that may
1599             // "appear".  A closure with a non-empty SRT, and which is
1600             // still required, will always be reachable.
1601             //
1602             // But what about CONSTR_STATIC?  Surely these may be able
1603             // to appear, and they don't have SRTs, so we can't
1604             // check.  So for now, we're calling
1605             // resetStaticObjectForRetainerProfiling() from the
1606             // garbage collector to reset the retainer sets in all the
1607             // reachable static objects.
1608             goto loop;
1609         }
1610     default:
1611         break;
1612     }
1613
1614     // The above objects are ignored in computing the average number of times
1615     // an object is visited.
1616     timesAnyObjectVisited++;
1617
1618     // If this is the first visit to c, initialize its retainer set.
1619     maybeInitRetainerSet(c);
1620     retainerSetOfc = retainerSetOf(c);
1621
1622     // Now compute s:
1623     //    isRetainer(cp) == rtsTrue => s == NULL
1624     //    isRetainer(cp) == rtsFalse => s == cp.retainer
1625     if (isRetainer(cp))
1626         s = NULL;
1627     else
1628         s = retainerSetOf(cp);
1629
1630     // (c, cp, r, s) is available.
1631
1632     // (c, cp, r, s, R_r) is available, so compute the retainer set for *c.
1633     if (retainerSetOfc == NULL) {
1634         // This is the first visit to *c.
1635         numObjectVisited++;
1636
1637         if (s == NULL)
1638             associate(c, singleton(r));
1639         else
1640             // s is actually the retainer set of *c!
1641             associate(c, s);
1642
1643         // compute c_child_r
1644         c_child_r = isRetainer(c) ? getRetainerFrom(c) : r;
1645     } else {
1646         // This is not the first visit to *c.
1647         if (isMember(r, retainerSetOfc))
1648             goto loop;          // no need to process child
1649
1650         if (s == NULL)
1651             associate(c, addElement(r, retainerSetOfc));
1652         else {
1653             // s is not NULL and cp is not a retainer. This means that
1654             // each time *cp is visited, so is *c. Thus, if s has
1655             // exactly one more element in its retainer set than c, s
1656             // is also the new retainer set for *c.
1657             if (s->num == retainerSetOfc->num + 1) {
1658                 associate(c, s);
1659             }
1660             // Otherwise, just add R_r to the current retainer set of *c.
1661             else {
1662                 associate(c, addElement(r, retainerSetOfc));
1663             }
1664         }
1665
1666         if (isRetainer(c))
1667             goto loop;          // no need to process child
1668
1669         // compute c_child_r
1670         c_child_r = r;
1671     }
1672
1673     // now, RSET() of all of *c, *cp, and *r is valid.
1674     // (c, c_child_r) are available.
1675
1676     // process child
1677
1678     // Special case closures: we process these all in one go rather
1679     // than attempting to save the current position, because doing so
1680     // would be hard.
1681     switch (typeOfc) {
1682     case TSO:
1683         retainStack(c, c_child_r,
1684                     ((StgTSO *)c)->sp,
1685                     ((StgTSO *)c)->stack + ((StgTSO *)c)->stack_size);
1686         goto loop;
1687
1688     case PAP:
1689     {
1690         StgPAP *pap = (StgPAP *)c;
1691         retain_PAP_payload(c, c_child_r, pap->fun, pap->payload, pap->n_args);
1692         goto loop;
1693     }
1694
1695     case AP:
1696     {
1697         StgAP *ap = (StgAP *)c;
1698         retain_PAP_payload(c, c_child_r, ap->fun, ap->payload, ap->n_args);
1699         goto loop;
1700     }
1701
1702     case AP_STACK:
1703         retainClosure(((StgAP_STACK *)c)->fun, c, c_child_r);
1704         retainStack(c, c_child_r,
1705                     (StgPtr)((StgAP_STACK *)c)->payload,
1706                     (StgPtr)((StgAP_STACK *)c)->payload +
1707                              ((StgAP_STACK *)c)->size);
1708         goto loop;
1709     }
1710
1711     push(c, c_child_r, &first_child);
1712
1713     // If first_child is null, c has no child.
1714     // If first_child is not null, the top stack element points to the next
1715     // object. push() may or may not push a stackElement on the stack.
1716     if (first_child == NULL)
1717         goto loop;
1718
1719     // (c, cp, r) = (first_child, c, c_child_r)
1720     r = c_child_r;
1721     cp = c;
1722     c = first_child;
1723     goto inner_loop;
1724 }
1725
1726 /* -----------------------------------------------------------------------------
1727  *  Compute the retainer set for every object reachable from *tl.
1728  * -------------------------------------------------------------------------- */
1729 static void
1730 retainRoot(void *user STG_UNUSED, StgClosure **tl)
1731 {
1732     StgClosure *c;
1733
1734     // We no longer assume that only TSOs and WEAKs are roots; any closure can
1735     // be a root.
1736
1737     ASSERT(isEmptyRetainerStack());
1738     currentStackBoundary = stackTop;
1739
1740     c = UNTAG_CLOSURE(*tl);
1741     if (c != &stg_END_TSO_QUEUE_closure && isRetainer(c)) {
1742         retainClosure(c, c, getRetainerFrom(c));
1743     } else {
1744         retainClosure(c, c, CCS_SYSTEM);
1745     }
1746
1747     // NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl)));
1748     // *tl might be a TSO which is ThreadComplete, in which
1749     // case we ignore it for the purposes of retainer profiling.
1750 }
1751
1752 /* -----------------------------------------------------------------------------
1753  *  Compute the retainer set for each of the objects in the heap.
1754  * -------------------------------------------------------------------------- */
1755 static void
1756 computeRetainerSet( void )
1757 {
1758     StgWeak *weak;
1759     RetainerSet *rtl;
1760     nat g;
1761     StgPtr ml;
1762     bdescr *bd;
1763 #ifdef DEBUG_RETAINER
1764     RetainerSet tmpRetainerSet;
1765 #endif
1766
1767     markCapabilities(retainRoot, NULL); // for scheduler roots
1768
1769     // This function is called after a major GC, when key, value, and finalizer
1770     // all are guaranteed to be valid, or reachable.
1771     //
1772     // The following code assumes that WEAK objects are considered to be roots
1773     // for retainer profilng.
1774     for (weak = weak_ptr_list; weak != NULL; weak = weak->link)
1775         // retainRoot((StgClosure *)weak);
1776         retainRoot(NULL, (StgClosure **)&weak);
1777
1778     // Consider roots from the stable ptr table.
1779     markStablePtrTable(retainRoot, NULL);
1780
1781     // The following code resets the rs field of each unvisited mutable
1782     // object (computing sumOfNewCostExtra and updating costArray[] when
1783     // debugging retainer profiler).
1784     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1785         // NOT TRUE: even G0 has a block on its mutable list
1786         // ASSERT(g != 0 || (generations[g].mut_list == NULL));
1787
1788         // Traversing through mut_list is necessary
1789         // because we can find MUT_VAR objects which have not been
1790         // visited during retainer profiling.
1791         for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
1792             for (ml = bd->start; ml < bd->free; ml++) {
1793
1794                 maybeInitRetainerSet((StgClosure *)*ml);
1795                 rtl = retainerSetOf((StgClosure *)*ml);
1796
1797 #ifdef DEBUG_RETAINER
1798                 if (rtl == NULL) {
1799                     // first visit to *ml
1800                     // This is a violation of the interface rule!
1801                     RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1802
1803                     switch (get_itbl((StgClosure *)ml)->type) {
1804                     case IND_STATIC:
1805                         // no cost involved
1806                         break;
1807                     case CONSTR_NOCAF_STATIC:
1808                     case CONSTR_STATIC:
1809                     case THUNK_STATIC:
1810                     case FUN_STATIC:
1811                         barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1812                         break;
1813                     default:
1814                         // dynamic objects
1815                         costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1816                         sumOfNewCostExtra += cost((StgClosure *)ml);
1817                         break;
1818                     }
1819                 }
1820 #endif
1821             }
1822         }
1823     }
1824 }
1825
1826 /* -----------------------------------------------------------------------------
1827  *  Traverse all static objects for which we compute retainer sets,
1828  *  and reset their rs fields to NULL, which is accomplished by
1829  *  invoking maybeInitRetainerSet(). This function must be called
1830  *  before zeroing all objects reachable from scavenged_static_objects
1831  *  in the case of major gabage collections. See GarbageCollect() in
1832  *  GC.c.
1833  *  Note:
1834  *    The mut_once_list of the oldest generation must also be traversed?
1835  *    Why? Because if the evacuation of an object pointed to by a static
1836  *    indirection object fails, it is put back to the mut_once_list of
1837  *    the oldest generation.
1838  *    However, this is not necessary because any static indirection objects
1839  *    are just traversed through to reach dynamic objects. In other words,
1840  *    they are not taken into consideration in computing retainer sets.
1841  * -------------------------------------------------------------------------- */
1842 void
1843 resetStaticObjectForRetainerProfiling( StgClosure *static_objects )
1844 {
1845 #ifdef DEBUG_RETAINER
1846     nat count;
1847 #endif
1848     StgClosure *p;
1849
1850 #ifdef DEBUG_RETAINER
1851     count = 0;
1852 #endif
1853     p = static_objects;
1854     while (p != END_OF_STATIC_LIST) {
1855 #ifdef DEBUG_RETAINER
1856         count++;
1857 #endif
1858         switch (get_itbl(p)->type) {
1859         case IND_STATIC:
1860             // Since we do not compute the retainer set of any
1861             // IND_STATIC object, we don't have to reset its retainer
1862             // field.
1863             p = (StgClosure*)*IND_STATIC_LINK(p);
1864             break;
1865         case THUNK_STATIC:
1866             maybeInitRetainerSet(p);
1867             p = (StgClosure*)*THUNK_STATIC_LINK(p);
1868             break;
1869         case FUN_STATIC:
1870             maybeInitRetainerSet(p);
1871             p = (StgClosure*)*FUN_STATIC_LINK(p);
1872             break;
1873         case CONSTR_STATIC:
1874             maybeInitRetainerSet(p);
1875             p = (StgClosure*)*STATIC_LINK(get_itbl(p), p);
1876             break;
1877         default:
1878             barf("resetStaticObjectForRetainerProfiling: %p (%s)",
1879                  p, get_itbl(p)->type);
1880             break;
1881         }
1882     }
1883 #ifdef DEBUG_RETAINER
1884     // debugBelch("count in scavenged_static_objects = %d\n", count);
1885 #endif
1886 }
1887
1888 /* -----------------------------------------------------------------------------
1889  * Perform retainer profiling.
1890  * N is the oldest generation being profilied, where the generations are
1891  * numbered starting at 0.
1892  * Invariants:
1893  * Note:
1894  *   This function should be called only immediately after major garbage
1895  *   collection.
1896  * ------------------------------------------------------------------------- */
1897 void
1898 retainerProfile(void)
1899 {
1900 #ifdef DEBUG_RETAINER
1901   nat i;
1902   nat totalHeapSize;        // total raw heap size (computed by linear scanning)
1903 #endif
1904
1905 #ifdef DEBUG_RETAINER
1906   debugBelch(" < retainerProfile() invoked : %d>\n", retainerGeneration);
1907 #endif
1908
1909   stat_startRP();
1910
1911   // We haven't flipped the bit yet.
1912 #ifdef DEBUG_RETAINER
1913   debugBelch("Before traversing:\n");
1914   sumOfCostLinear = 0;
1915   for (i = 0;i < N_CLOSURE_TYPES; i++)
1916     costArrayLinear[i] = 0;
1917   totalHeapSize = checkHeapSanityForRetainerProfiling();
1918
1919   debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1920   /*
1921   debugBelch("costArrayLinear[] = ");
1922   for (i = 0;i < N_CLOSURE_TYPES; i++)
1923     debugBelch("[%u:%u] ", i, costArrayLinear[i]);
1924   debugBelch("\n");
1925   */
1926
1927   ASSERT(sumOfCostLinear == totalHeapSize);
1928
1929 /*
1930 #define pcostArrayLinear(index) \
1931   if (costArrayLinear[index] > 0) \
1932     debugBelch("costArrayLinear[" #index "] = %u\n", costArrayLinear[index])
1933   pcostArrayLinear(THUNK_STATIC);
1934   pcostArrayLinear(FUN_STATIC);
1935   pcostArrayLinear(CONSTR_STATIC);
1936   pcostArrayLinear(CONSTR_NOCAF_STATIC);
1937 */
1938 #endif
1939
1940   // Now we flips flip.
1941   flip = flip ^ 1;
1942
1943 #ifdef DEBUG_RETAINER
1944   stackSize = 0;
1945   maxStackSize = 0;
1946   cStackSize = 0;
1947   maxCStackSize = 0;
1948 #endif
1949   numObjectVisited = 0;
1950   timesAnyObjectVisited = 0;
1951
1952 #ifdef DEBUG_RETAINER
1953   debugBelch("During traversing:\n");
1954   sumOfNewCost = 0;
1955   sumOfNewCostExtra = 0;
1956   for (i = 0;i < N_CLOSURE_TYPES; i++)
1957     costArray[i] = 0;
1958 #endif
1959
1960   /*
1961     We initialize the traverse stack each time the retainer profiling is
1962     performed (because the traverse stack size varies on each retainer profiling
1963     and this operation is not costly anyhow). However, we just refresh the
1964     retainer sets.
1965    */
1966   initializeTraverseStack();
1967 #ifdef DEBUG_RETAINER
1968   initializeAllRetainerSet();
1969 #else
1970   refreshAllRetainerSet();
1971 #endif
1972   computeRetainerSet();
1973
1974 #ifdef DEBUG_RETAINER
1975   debugBelch("After traversing:\n");
1976   sumOfCostLinear = 0;
1977   for (i = 0;i < N_CLOSURE_TYPES; i++)
1978     costArrayLinear[i] = 0;
1979   totalHeapSize = checkHeapSanityForRetainerProfiling();
1980
1981   debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1982   ASSERT(sumOfCostLinear == totalHeapSize);
1983
1984   // now, compare the two results
1985   /*
1986     Note:
1987       costArray[] must be exactly the same as costArrayLinear[].
1988       Known exceptions:
1989         1) Dead weak pointers, whose type is CONSTR. These objects are not
1990            reachable from any roots.
1991   */
1992   debugBelch("Comparison:\n");
1993   debugBelch("\tcostArrayLinear[] (must be empty) = ");
1994   for (i = 0;i < N_CLOSURE_TYPES; i++)
1995     if (costArray[i] != costArrayLinear[i])
1996       // nothing should be printed except MUT_VAR after major GCs
1997       debugBelch("[%u:%u] ", i, costArrayLinear[i]);
1998   debugBelch("\n");
1999
2000   debugBelch("\tsumOfNewCost = %u\n", sumOfNewCost);
2001   debugBelch("\tsumOfNewCostExtra = %u\n", sumOfNewCostExtra);
2002   debugBelch("\tcostArray[] (must be empty) = ");
2003   for (i = 0;i < N_CLOSURE_TYPES; i++)
2004     if (costArray[i] != costArrayLinear[i])
2005       // nothing should be printed except MUT_VAR after major GCs
2006       debugBelch("[%u:%u] ", i, costArray[i]);
2007   debugBelch("\n");
2008
2009   // only for major garbage collection
2010   ASSERT(sumOfNewCost + sumOfNewCostExtra == sumOfCostLinear);
2011 #endif
2012
2013   // post-processing
2014   closeTraverseStack();
2015 #ifdef DEBUG_RETAINER
2016   closeAllRetainerSet();
2017 #else
2018   // Note that there is no post-processing for the retainer sets.
2019 #endif
2020   retainerGeneration++;
2021
2022   stat_endRP(
2023     retainerGeneration - 1,   // retainerGeneration has just been incremented!
2024 #ifdef DEBUG_RETAINER
2025     maxCStackSize, maxStackSize,
2026 #endif
2027     (double)timesAnyObjectVisited / numObjectVisited);
2028 }
2029
2030 /* -----------------------------------------------------------------------------
2031  * DEBUGGING CODE
2032  * -------------------------------------------------------------------------- */
2033
2034 #ifdef DEBUG_RETAINER
2035
2036 #define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
2037         ((HEAP_ALLOCED(r) && ((Bdescr((P_)r)->flags & BF_FREE) == 0)))) && \
2038         ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa))
2039
2040 static nat
2041 sanityCheckHeapClosure( StgClosure *c )
2042 {
2043     StgInfoTable *info;
2044
2045     ASSERT(LOOKS_LIKE_GHC_INFO(c->header.info));
2046     ASSERT(!closure_STATIC(c));
2047     ASSERT(LOOKS_LIKE_PTR(c));
2048
2049     if ((((StgWord)RSET(c) & 1) ^ flip) != 0) {
2050         if (get_itbl(c)->type == CONSTR &&
2051             !strcmp(GET_PROF_TYPE(get_itbl(c)), "DEAD_WEAK") &&
2052             !strcmp(GET_PROF_DESC(get_itbl(c)), "DEAD_WEAK")) {
2053             debugBelch("\tUnvisited dead weak pointer object found: c = %p\n", c);
2054             costArray[get_itbl(c)->type] += cost(c);
2055             sumOfNewCost += cost(c);
2056         } else
2057             debugBelch(
2058                     "Unvisited object: flip = %d, c = %p(%d, %s, %s), rs = %p\n",
2059                     flip, c, get_itbl(c)->type,
2060                     get_itbl(c)->prof.closure_type, GET_PROF_DESC(get_itbl(c)),
2061                     RSET(c));
2062     } else {
2063         // debugBelch("sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c));
2064     }
2065
2066     return closure_sizeW(c);
2067 }
2068
2069 static nat
2070 heapCheck( bdescr *bd )
2071 {
2072     StgPtr p;
2073     static nat costSum, size;
2074
2075     costSum = 0;
2076     while (bd != NULL) {
2077         p = bd->start;
2078         while (p < bd->free) {
2079             size = sanityCheckHeapClosure((StgClosure *)p);
2080             sumOfCostLinear += size;
2081             costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2082             p += size;
2083             // no need for slop check; I think slops are not used currently.
2084         }
2085         ASSERT(p == bd->free);
2086         costSum += bd->free - bd->start;
2087         bd = bd->link;
2088     }
2089
2090     return costSum;
2091 }
2092
2093 static nat
2094 smallObjectPoolCheck(void)
2095 {
2096     bdescr *bd;
2097     StgPtr p;
2098     static nat costSum, size;
2099
2100     bd = g0s0->blocks;
2101     costSum = 0;
2102
2103     // first block
2104     if (bd == NULL)
2105         return costSum;
2106
2107     p = bd->start;
2108     while (p < alloc_Hp) {
2109         size = sanityCheckHeapClosure((StgClosure *)p);
2110         sumOfCostLinear += size;
2111         costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2112         p += size;
2113     }
2114     ASSERT(p == alloc_Hp);
2115     costSum += alloc_Hp - bd->start;
2116
2117     bd = bd->link;
2118     while (bd != NULL) {
2119         p = bd->start;
2120         while (p < bd->free) {
2121             size = sanityCheckHeapClosure((StgClosure *)p);
2122             sumOfCostLinear += size;
2123             costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2124             p += size;
2125         }
2126         ASSERT(p == bd->free);
2127         costSum += bd->free - bd->start;
2128         bd = bd->link;
2129     }
2130
2131     return costSum;
2132 }
2133
2134 static nat
2135 chainCheck(bdescr *bd)
2136 {
2137     nat costSum, size;
2138
2139     costSum = 0;
2140     while (bd != NULL) {
2141         // bd->free - bd->start is not an accurate measurement of the
2142         // object size.  Actually it is always zero, so we compute its
2143         // size explicitly.
2144         size = sanityCheckHeapClosure((StgClosure *)bd->start);
2145         sumOfCostLinear += size;
2146         costArrayLinear[get_itbl((StgClosure *)bd->start)->type] += size;
2147         costSum += size;
2148         bd = bd->link;
2149     }
2150
2151     return costSum;
2152 }
2153
2154 static nat
2155 checkHeapSanityForRetainerProfiling( void )
2156 {
2157     nat costSum, g, s;
2158
2159     costSum = 0;
2160     debugBelch("START: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2161     if (RtsFlags.GcFlags.generations == 1) {
2162         costSum += heapCheck(g0s0->to_blocks);
2163         debugBelch("heapCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2164         costSum += chainCheck(g0s0->large_objects);
2165         debugBelch("chainCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2166     } else {
2167         for (g = 0; g < RtsFlags.GcFlags.generations; g++)
2168         for (s = 0; s < generations[g].n_steps; s++) {
2169             /*
2170               After all live objects have been scavenged, the garbage
2171               collector may create some objects in
2172               scheduleFinalizers(). These objects are created throught
2173               allocate(), so the small object pool or the large object
2174               pool of the g0s0 may not be empty.
2175             */
2176             if (g == 0 && s == 0) {
2177                 costSum += smallObjectPoolCheck();
2178                 debugBelch("smallObjectPoolCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2179                 costSum += chainCheck(generations[g].steps[s].large_objects);
2180                 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2181             } else {
2182                 costSum += heapCheck(generations[g].steps[s].blocks);
2183                 debugBelch("heapCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2184                 costSum += chainCheck(generations[g].steps[s].large_objects);
2185                 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2186             }
2187         }
2188     }
2189
2190     return costSum;
2191 }
2192
2193 void
2194 findPointer(StgPtr p)
2195 {
2196     StgPtr q, r, e;
2197     bdescr *bd;
2198     nat g, s;
2199
2200     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2201         for (s = 0; s < generations[g].n_steps; s++) {
2202             // if (g == 0 && s == 0) continue;
2203             bd = generations[g].steps[s].blocks;
2204             for (; bd; bd = bd->link) {
2205                 for (q = bd->start; q < bd->free; q++) {
2206                     if (*q == (StgWord)p) {
2207                         r = q;
2208                         while (!LOOKS_LIKE_GHC_INFO(*r)) r--;
2209                         debugBelch("Found in gen[%d], step[%d]: q = %p, r = %p\n", g, s, q, r);
2210                         // return;
2211                     }
2212                 }
2213             }
2214             bd = generations[g].steps[s].large_objects;
2215             for (; bd; bd = bd->link) {
2216                 e = bd->start + cost((StgClosure *)bd->start);
2217                 for (q = bd->start; q < e; q++) {
2218                     if (*q == (StgWord)p) {
2219                         r = q;
2220                         while (*r == 0 || !LOOKS_LIKE_GHC_INFO(*r)) r--;
2221                         debugBelch("Found in gen[%d], large_objects: %p\n", g, r);
2222                         // return;
2223                     }
2224                 }
2225             }
2226         }
2227     }
2228 }
2229
2230 static void
2231 belongToHeap(StgPtr p)
2232 {
2233     bdescr *bd;
2234     nat g, s;
2235
2236     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2237         for (s = 0; s < generations[g].n_steps; s++) {
2238             // if (g == 0 && s == 0) continue;
2239             bd = generations[g].steps[s].blocks;
2240             for (; bd; bd = bd->link) {
2241                 if (bd->start <= p && p < bd->free) {
2242                     debugBelch("Belongs to gen[%d], step[%d]", g, s);
2243                     return;
2244                 }
2245             }
2246             bd = generations[g].steps[s].large_objects;
2247             for (; bd; bd = bd->link) {
2248                 if (bd->start <= p && p < bd->start + getHeapClosureSize((StgClosure *)bd->start)) {
2249                     debugBelch("Found in gen[%d], large_objects: %p\n", g, bd->start);
2250                     return;
2251                 }
2252             }
2253         }
2254     }
2255 }
2256 #endif /* DEBUG_RETAINER */
2257
2258 #endif /* PROFILING */