ghc/rts/RetainerProfile.c

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