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