ghc/rts/RetainerProfile.c

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