rts/RetainerProfile.c

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