rts/RetainerProfile.c

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