rts/RetainerProfile.c

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