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