ghc/rts/RetainerProfile.c

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