ghc/rts/RetainerProfile.c

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