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