ghc/rts/RetainerProfile.c

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