ghc/rts/RetainerProfile.c

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