rts/RetainerProfile.c

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