ghc/rts/RetainerProfile.c

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