rts/RetainerProfile.c

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