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