ghc/rts/RetainerProfile.c

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