ghc/rts/RetainerProfile.c

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