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