ghc/rts/ProfHeap.c

   1 /* -----------------------------------------------------------------------------
   2  *
   3  * (c) The GHC Team, 1998-2003
   4  *
   5  * Support for heap profiling
   6  *
   7  * ---------------------------------------------------------------------------*/
   8
   9 #if defined(DEBUG) && !defined(PROFILING)
  10 #define DEBUG_HEAP_PROF
  11 #else
  12 #undef DEBUG_HEAP_PROF
  13 #endif
  14
  15 #if defined(PROFILING) || defined(DEBUG_HEAP_PROF)
  16
  17 #include "PosixSource.h"
  18 #include "Rts.h"
  19 #include "RtsUtils.h"
  20 #include "RtsFlags.h"
  21 #include "Profiling.h"
  22 #include "Storage.h"
  23 #include "ProfHeap.h"
  24 #include "Stats.h"
  25 #include "Hash.h"
  26 #include "StrHash.h"
  27 #include "RetainerProfile.h"
  28 #include "LdvProfile.h"
  29 #include "Arena.h"
  30 #include "Printer.h"
  31
  32 #include <string.h>
  33 #include <stdlib.h>
  34 #include <math.h>
  35
  36 /* -----------------------------------------------------------------------------
  37  * era stores the current time period.  It is the same as the
  38  * number of censuses that have been performed.
  39  *
  40  * RESTRICTION:
  41  *   era must be no longer than LDV_SHIFT (15 or 30) bits.
  42  * Invariants:
  43  *   era is initialized to 1 in initHeapProfiling().
  44  *
  45  * max_era is initialized to 2^LDV_SHIFT in initHeapProfiling().
  46  * When era reaches max_era, the profiling stops because a closure can
  47  * store only up to (max_era - 1) as its creation or last use time.
  48  * -------------------------------------------------------------------------- */
  49 unsigned int era;
  50 static nat max_era;
  51
  52 /* -----------------------------------------------------------------------------
  53  * Counters
  54  *
  55  * For most heap profiles each closure identity gets a simple count
  56  * of live words in the heap at each census.  However, if we're
  57  * selecting by biography, then we have to keep the various
  58  * lag/drag/void counters for each identity.
  59  * -------------------------------------------------------------------------- */
  60 typedef struct _counter {
  61     void *identity;
  62     union {
  63         nat resid;
  64         struct {
  65             int prim;     // total size of 'inherently used' closures
  66             int not_used; // total size of 'never used' closures
  67             int used;     // total size of 'used at least once' closures
  68             int void_total;  // current total size of 'destroyed without being used' closures
  69             int drag_total;  // current total size of 'used at least once and waiting to die'
  70         } ldv;
  71     } c;
  72     struct _counter *next;
  73 } counter;
  74
  75 STATIC_INLINE void
  76 initLDVCtr( counter *ctr )
  77 {
  78     ctr->c.ldv.prim = 0;
  79     ctr->c.ldv.not_used = 0;
  80     ctr->c.ldv.used = 0;
  81     ctr->c.ldv.void_total = 0;
  82     ctr->c.ldv.drag_total = 0;
  83 }
  84
  85 typedef struct {
  86     double      time;    // the time in MUT time when the census is made
  87     HashTable * hash;
  88     counter   * ctrs;
  89     Arena     * arena;
  90
  91     // for LDV profiling, when just displaying by LDV
  92     int       prim;
  93     int       not_used;
  94     int       used;
  95     int       void_total;
  96     int       drag_total;
  97 } Census;
  98
  99 static Census *censuses = NULL;
 100 static nat n_censuses = 0;
 101
 102 #ifdef PROFILING
 103 static void aggregateCensusInfo( void );
 104 #endif
 105
 106 static void dumpCensus( Census *census );
 107
 108 /* -----------------------------------------------------------------------------
 109    Closure Type Profiling;
 110
 111    PROBABLY TOTALLY OUT OF DATE -- ToDo (SDM)
 112    -------------------------------------------------------------------------- */
 113
 114 #ifdef DEBUG_HEAP_PROF
 115 static char *type_names[] = {
 116       "INVALID_OBJECT"
 117     , "CONSTR"
 118     , "CONSTR_INTLIKE"
 119     , "CONSTR_CHARLIKE"
 120     , "CONSTR_STATIC"
 121     , "CONSTR_NOCAF_STATIC"
 122
 123     , "FUN"
 124     , "FUN_STATIC"
 125
 126     , "THUNK"
 127     , "THUNK_STATIC"
 128     , "THUNK_SELECTOR"
 129
 130     , "BCO"
 131     , "AP_STACK"
 132     , "AP"
 133
 134     , "PAP"
 135
 136     , "IND"
 137     , "IND_OLDGEN"
 138     , "IND_PERM"
 139     , "IND_OLDGEN_PERM"
 140     , "IND_STATIC"
 141
 142     , "RET_BCO"
 143     , "RET_SMALL"
 144     , "RET_VEC_SMALL"
 145     , "RET_BIG"
 146     , "RET_VEC_BIG"
 147     , "RET_DYN"
 148     , "UPDATE_FRAME"
 149     , "CATCH_FRAME"
 150     , "STOP_FRAME"
 151
 152     , "BLACKHOLE"
 153     , "BLACKHOLE_BQ"
 154     , "MVAR"
 155
 156     , "ARR_WORDS"
 157
 158     , "MUT_ARR_PTRS"
 159     , "MUT_ARR_PTRS_FROZEN"
 160     , "MUT_VAR"
 161
 162     , "WEAK"
 163     , "FOREIGN"
 164
 165     , "TSO"
 166
 167     , "BLOCKED_FETCH"
 168     , "FETCH_ME"
 169
 170     , "EVACUATED"
 171 };
 172
 173 #endif /* DEBUG_HEAP_PROF */
 174
 175 /* -----------------------------------------------------------------------------
 176  * Find the "closure identity", which is a unique pointer reresenting
 177  * the band to which this closure's heap space is attributed in the
 178  * heap profile.
 179  * ------------------------------------------------------------------------- */
 180 STATIC_INLINE void *
 181 closureIdentity( StgClosure *p )
 182 {
 183     switch (RtsFlags.ProfFlags.doHeapProfile) {
 184
 185 #ifdef PROFILING
 186     case HEAP_BY_CCS:
 187         return p->header.prof.ccs;
 188     case HEAP_BY_MOD:
 189         return p->header.prof.ccs->cc->module;
 190     case HEAP_BY_DESCR:
 191         return get_itbl(p)->prof.closure_desc;
 192     case HEAP_BY_TYPE:
 193         return get_itbl(p)->prof.closure_type;
 194     case HEAP_BY_RETAINER:
 195         // AFAIK, the only closures in the heap which might not have a
 196         // valid retainer set are DEAD_WEAK closures.
 197         if (isRetainerSetFieldValid(p))
 198             return retainerSetOf(p);
 199         else
 200             return NULL;
 201
 202 #else // DEBUG
 203     case HEAP_BY_INFOPTR:
 204         return (void *)((StgClosure *)p)->header.info;
 205     case HEAP_BY_CLOSURE_TYPE:
 206         return type_names[get_itbl(p)->type];
 207
 208 #endif
 209     default:
 210         barf("closureIdentity");
 211     }
 212 }
 213
 214 /* --------------------------------------------------------------------------
 215  * Profiling type predicates
 216  * ----------------------------------------------------------------------- */
 217 #ifdef PROFILING
 218 STATIC_INLINE rtsBool
 219 doingLDVProfiling( void )
 220 {
 221     return (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV
 222             || RtsFlags.ProfFlags.bioSelector != NULL);
 223 }
 224
 225 STATIC_INLINE rtsBool
 226 doingRetainerProfiling( void )
 227 {
 228     return (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_RETAINER
 229             || RtsFlags.ProfFlags.retainerSelector != NULL);
 230 }
 231 #endif // PROFILING
 232
 233 // Precesses a closure 'c' being destroyed whose size is 'size'.
 234 // Make sure that LDV_recordDead() is not invoked on 'inherently used' closures
 235 // such as TSO; they should not be involved in computing dragNew or voidNew.
 236 //
 237 // Even though era is checked in both LdvCensusForDead() and
 238 // LdvCensusKillAll(), we still need to make sure that era is > 0 because
 239 // LDV_recordDead() may be called from elsewhere in the runtime system. E.g.,
 240 // when a thunk is replaced by an indirection object.
 241
 242 #ifdef PROFILING
 243 void
 244 LDV_recordDead( StgClosure *c, nat size )
 245 {
 246     void *id;
 247     nat t;
 248     counter *ctr;
 249
 250     if (era > 0 && closureSatisfiesConstraints(c)) {
 251         size -= sizeofW(StgProfHeader);
 252         ASSERT(LDVW(c) != 0);
 253         if ((LDVW((c)) & LDV_STATE_MASK) == LDV_STATE_CREATE) {
 254             t = (LDVW((c)) & LDV_CREATE_MASK) >> LDV_SHIFT;
 255             if (t < era) {
 256                 if (RtsFlags.ProfFlags.bioSelector == NULL) {
 257                     censuses[t].void_total   += (int)size;
 258                     censuses[era].void_total -= (int)size;
 259                 } else {
 260                     id = closureIdentity(c);
 261                     ctr = lookupHashTable(censuses[t].hash, (StgWord)id);
 262                     ASSERT( ctr != NULL );
 263                     ctr->c.ldv.void_total += (int)size;
 264                     ctr = lookupHashTable(censuses[era].hash, (StgWord)id);
 265                     if (ctr == NULL) {
 266                         ctr = arenaAlloc(censuses[era].arena, sizeof(counter));
 267                         initLDVCtr(ctr);
 268                         insertHashTable(censuses[era].hash, (StgWord)id, ctr);
 269                         ctr->identity = id;
 270                         ctr->next = censuses[era].ctrs;
 271                         censuses[era].ctrs = ctr;
 272                     }
 273                     ctr->c.ldv.void_total -= (int)size;
 274                 }
 275             }
 276         } else {
 277             t = LDVW((c)) & LDV_LAST_MASK;
 278             if (t + 1 < era) {
 279                 if (RtsFlags.ProfFlags.bioSelector == NULL) {
 280                     censuses[t+1].drag_total += size;
 281                     censuses[era].drag_total -= size;
 282                 } else {
 283                     void *id;
 284                     id = closureIdentity(c);
 285                     ctr = lookupHashTable(censuses[t+1].hash, (StgWord)id);
 286                     ASSERT( ctr != NULL );
 287                     ctr->c.ldv.drag_total += (int)size;
 288                     ctr = lookupHashTable(censuses[era].hash, (StgWord)id);
 289                     if (ctr == NULL) {
 290                         ctr = arenaAlloc(censuses[era].arena, sizeof(counter));
 291                         initLDVCtr(ctr);
 292                         insertHashTable(censuses[era].hash, (StgWord)id, ctr);
 293                         ctr->identity = id;
 294                         ctr->next = censuses[era].ctrs;
 295                         censuses[era].ctrs = ctr;
 296                     }
 297                     ctr->c.ldv.drag_total -= (int)size;
 298                 }
 299             }
 300         }
 301     }
 302 }
 303 #endif
 304
 305 /* --------------------------------------------------------------------------
 306  * Initialize censuses[era];
 307  * ----------------------------------------------------------------------- */
 308 STATIC_INLINE void
 309 initEra(Census *census)
 310 {
 311     census->hash  = allocHashTable();
 312     census->ctrs  = NULL;
 313     census->arena = newArena();
 314
 315     census->not_used   = 0;
 316     census->used       = 0;
 317     census->prim       = 0;
 318     census->void_total = 0;
 319     census->drag_total = 0;
 320 }
 321
 322 /* --------------------------------------------------------------------------
 323  * Increases era by 1 and initialize census[era].
 324  * Reallocates gi[] and increases its size if needed.
 325  * ----------------------------------------------------------------------- */
 326 static void
 327 nextEra( void )
 328 {
 329 #ifdef PROFILING
 330     if (doingLDVProfiling()) {
 331         era++;
 332
 333         if (era == max_era) {
 334             errorBelch("maximum number of censuses reached; use +RTS -i to reduce");
 335             stg_exit(EXIT_FAILURE);
 336         }
 337
 338         if (era == n_censuses) {
 339             n_censuses *= 2;
 340             censuses = stgReallocBytes(censuses, sizeof(Census) * n_censuses,
 341                                        "nextEra");
 342         }
 343     }
 344 #endif // PROFILING
 345
 346     initEra( &censuses[era] );
 347 }
 348
 349 /* -----------------------------------------------------------------------------
 350  * DEBUG heap profiling, by info table
 351  * -------------------------------------------------------------------------- */
 352
 353 #ifdef DEBUG_HEAP_PROF
 354 FILE *hp_file;
 355 static char *hp_filename;
 356
 357 void initProfiling1( void )
 358 {
 359 }
 360
 361 void initProfiling2( void )
 362 {
 363   if (RtsFlags.ProfFlags.doHeapProfile) {
 364     /* Initialise the log file name */
 365     hp_filename = stgMallocBytes(strlen(prog_name) + 6, "hpFileName");
 366     sprintf(hp_filename, "%s.hp", prog_name);
 367
 368     /* open the log file */
 369     if ((hp_file = fopen(hp_filename, "w")) == NULL) {
 370       debugBelch("Can't open profiling report file %s\n",
 371               hp_filename);
 372       RtsFlags.ProfFlags.doHeapProfile = 0;
 373       return;
 374     }
 375   }
 376
 377   initHeapProfiling();
 378 }
 379
 380 void endProfiling( void )
 381 {
 382   endHeapProfiling();
 383 }
 384 #endif /* DEBUG_HEAP_PROF */
 385
 386 static void
 387 printSample(rtsBool beginSample, StgDouble sampleValue)
 388 {
 389     StgDouble fractionalPart, integralPart;
 390     fractionalPart = modf(sampleValue, &integralPart);
 391     fprintf(hp_file, "%s %d.%02d\n",
 392             (beginSample ? "BEGIN_SAMPLE" : "END_SAMPLE"),
 393             (int)integralPart, (int)(fractionalPart * 100 + 0.5));
 394 }
 395
 396 /* --------------------------------------------------------------------------
 397  * Initialize the heap profilier
 398  * ----------------------------------------------------------------------- */
 399 nat
 400 initHeapProfiling(void)
 401 {
 402     if (! RtsFlags.ProfFlags.doHeapProfile) {
 403         return 0;
 404     }
 405
 406 #ifdef PROFILING
 407     if (doingLDVProfiling() && doingRetainerProfiling()) {
 408         errorBelch("cannot mix -hb and -hr");
 409         stg_exit(1);
 410     }
 411 #endif
 412
 413     // we only count eras if we're doing LDV profiling.  Otherwise era
 414     // is fixed at zero.
 415 #ifdef PROFILING
 416     if (doingLDVProfiling()) {
 417         era = 1;
 418     } else
 419 #endif
 420     {
 421         era = 0;
 422     }
 423
 424     {   // max_era = 2^LDV_SHIFT
 425         nat p;
 426         max_era = 1;
 427         for (p = 0; p < LDV_SHIFT; p++)
 428             max_era *= 2;
 429     }
 430
 431     n_censuses = 32;
 432     censuses = stgMallocBytes(sizeof(Census) * n_censuses, "initHeapProfiling");
 433
 434     initEra( &censuses[era] );
 435
 436     /* initProfilingLogFile(); */
 437     fprintf(hp_file, "JOB \"%s", prog_name);
 438
 439 #ifdef PROFILING
 440     {
 441         int count;
 442         for(count = 1; count < prog_argc; count++)
 443             fprintf(hp_file, " %s", prog_argv[count]);
 444         fprintf(hp_file, " +RTS");
 445         for(count = 0; count < rts_argc; count++)
 446             fprintf(hp_file, " %s", rts_argv[count]);
 447     }
 448 #endif /* PROFILING */
 449
 450     fprintf(hp_file, "\"\n" );
 451
 452     fprintf(hp_file, "DATE \"%s\"\n", time_str());
 453
 454     fprintf(hp_file, "SAMPLE_UNIT \"seconds\"\n");
 455     fprintf(hp_file, "VALUE_UNIT \"bytes\"\n");
 456
 457     printSample(rtsTrue, 0);
 458     printSample(rtsFalse, 0);
 459
 460 #ifdef DEBUG_HEAP_PROF
 461     DEBUG_LoadSymbols(prog_name);
 462 #endif
 463
 464 #ifdef PROFILING
 465     if (doingRetainerProfiling()) {
 466         initRetainerProfiling();
 467     }
 468 #endif
 469
 470     return 0;
 471 }
 472
 473 void
 474 endHeapProfiling(void)
 475 {
 476     StgDouble seconds;
 477
 478     if (! RtsFlags.ProfFlags.doHeapProfile) {
 479         return;
 480     }
 481
 482 #ifdef PROFILING
 483     if (doingRetainerProfiling()) {
 484         endRetainerProfiling();
 485     }
 486 #endif
 487
 488 #ifdef PROFILING
 489     if (doingLDVProfiling()) {
 490         nat t;
 491         LdvCensusKillAll();
 492         aggregateCensusInfo();
 493         for (t = 1; t < era; t++) {
 494             dumpCensus( &censuses[t] );
 495         }
 496     }
 497 #endif
 498
 499     seconds = mut_user_time();
 500     printSample(rtsTrue, seconds);
 501     printSample(rtsFalse, seconds);
 502     fclose(hp_file);
 503 }
 504
 505
 506
 507 #ifdef PROFILING
 508 static size_t
 509 buf_append(char *p, const char *q, char *end)
 510 {
 511     int m;
 512
 513     for (m = 0; p < end; p++, q++, m++) {
 514         *p = *q;
 515         if (*q == '\0') { break; }
 516     }
 517     return m;
 518 }
 519
 520 static void
 521 fprint_ccs(FILE *fp, CostCentreStack *ccs, nat max_length)
 522 {
 523     char buf[max_length+1], *p, *buf_end;
 524     nat next_offset = 0;
 525     nat written;
 526
 527     // MAIN on its own gets printed as "MAIN", otherwise we ignore MAIN.
 528     if (ccs == CCS_MAIN) {
 529         fprintf(fp, "MAIN");
 530         return;
 531     }
 532
 533     fprintf(fp, "(%d)", ccs->ccsID);
 534
 535     p = buf;
 536     buf_end = buf + max_length + 1;
 537
 538     // keep printing components of the stack until we run out of space
 539     // in the buffer.  If we run out of space, end with "...".
 540     for (; ccs != NULL && ccs != CCS_MAIN; ccs = ccs->prevStack) {
 541
 542         // CAF cost centres print as M.CAF, but we leave the module
 543         // name out of all the others to save space.
 544         if (!strcmp(ccs->cc->label,"CAF")) {
 545             p += buf_append(p, ccs->cc->module, buf_end);
 546             p += buf_append(p, ".CAF", buf_end);
 547         } else {
 548             if (ccs->prevStack != NULL && ccs->prevStack != CCS_MAIN) {
 549                 p += buf_append(p, "/", buf_end);
 550             }
 551             p += buf_append(p, ccs->cc->label, buf_end);
 552         }
 553
 554         if (p >= buf_end) {
 555             sprintf(buf+max_length-4, "...");
 556             break;
 557         } else {
 558             next_offset += written;
 559         }
 560     }
 561     fprintf(fp, "%s", buf);
 562 }
 563 #endif // PROFILING
 564
 565 rtsBool
 566 strMatchesSelector( char* str, char* sel )
 567 {
 568    char* p;
 569    // debugBelch("str_matches_selector %s %s\n", str, sel);
 570    while (1) {
 571        // Compare str against wherever we've got to in sel.
 572        p = str;
 573        while (*p != '\0' && *sel != ',' && *sel != '\0' && *p == *sel) {
 574            p++; sel++;
 575        }
 576        // Match if all of str used and have reached the end of a sel fragment.
 577        if (*p == '\0' && (*sel == ',' || *sel == '\0'))
 578            return rtsTrue;
 579
 580        // No match.  Advance sel to the start of the next elem.
 581        while (*sel != ',' && *sel != '\0') sel++;
 582        if (*sel == ',') sel++;
 583
 584        /* Run out of sel ?? */
 585        if (*sel == '\0') return rtsFalse;
 586    }
 587 }
 588
 589 /* -----------------------------------------------------------------------------
 590  * Figure out whether a closure should be counted in this census, by
 591  * testing against all the specified constraints.
 592  * -------------------------------------------------------------------------- */
 593 rtsBool
 594 closureSatisfiesConstraints( StgClosure* p )
 595 {
 596 #ifdef DEBUG_HEAP_PROF
 597     (void)p;   /* keep gcc -Wall happy */
 598     return rtsTrue;
 599 #else
 600    rtsBool b;
 601
 602    // The CCS has a selected field to indicate whether this closure is
 603    // deselected by not being mentioned in the module, CC, or CCS
 604    // selectors.
 605    if (!p->header.prof.ccs->selected) {
 606        return rtsFalse;
 607    }
 608
 609    if (RtsFlags.ProfFlags.descrSelector) {
 610        b = strMatchesSelector( (get_itbl((StgClosure *)p))->prof.closure_desc,
 611                                  RtsFlags.ProfFlags.descrSelector );
 612        if (!b) return rtsFalse;
 613    }
 614    if (RtsFlags.ProfFlags.typeSelector) {
 615        b = strMatchesSelector( (get_itbl((StgClosure *)p))->prof.closure_type,
 616                                 RtsFlags.ProfFlags.typeSelector );
 617        if (!b) return rtsFalse;
 618    }
 619    if (RtsFlags.ProfFlags.retainerSelector) {
 620        RetainerSet *rs;
 621        nat i;
 622        // We must check that the retainer set is valid here.  One
 623        // reason it might not be valid is if this closure is a
 624        // a newly deceased weak pointer (i.e. a DEAD_WEAK), since
 625        // these aren't reached by the retainer profiler's traversal.
 626        if (isRetainerSetFieldValid((StgClosure *)p)) {
 627            rs = retainerSetOf((StgClosure *)p);
 628            if (rs != NULL) {
 629                for (i = 0; i < rs->num; i++) {
 630                    b = strMatchesSelector( rs->element[i]->cc->label,
 631                                            RtsFlags.ProfFlags.retainerSelector );
 632                    if (b) return rtsTrue;
 633                }
 634            }
 635        }
 636        return rtsFalse;
 637    }
 638    return rtsTrue;
 639 #endif /* PROFILING */
 640 }
 641
 642 /* -----------------------------------------------------------------------------
 643  * Aggregate the heap census info for biographical profiling
 644  * -------------------------------------------------------------------------- */
 645 #ifdef PROFILING
 646 static void
 647 aggregateCensusInfo( void )
 648 {
 649     HashTable *acc;
 650     nat t;
 651     counter *c, *d, *ctrs;
 652     Arena *arena;
 653
 654     if (!doingLDVProfiling()) return;
 655
 656     // Aggregate the LDV counters when displaying by biography.
 657     if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV) {
 658         int void_total, drag_total;
 659
 660         // Now we compute void_total and drag_total for each census
 661         void_total = 0;
 662         drag_total = 0;
 663         for (t = 1; t < era; t++) { // note: start at 1, not 0
 664             void_total += censuses[t].void_total;
 665             drag_total += censuses[t].drag_total;
 666             censuses[t].void_total = void_total;
 667             censuses[t].drag_total = drag_total;
 668             ASSERT( censuses[t].void_total <= censuses[t].not_used );
 669             ASSERT( censuses[t].drag_total <= censuses[t].used );
 670         }
 671
 672         return;
 673     }
 674
 675     // otherwise... we're doing a heap profile that is restricted to
 676     // some combination of lag, drag, void or use.  We've kept all the
 677     // census info for all censuses so far, but we still need to
 678     // aggregate the counters forwards.
 679
 680     arena = newArena();
 681     acc = allocHashTable();
 682     ctrs = NULL;
 683
 684     for (t = 1; t < era; t++) {
 685
 686         // first look through all the counters we're aggregating
 687         for (c = ctrs; c != NULL; c = c->next) {
 688             // if one of the totals is non-zero, then this closure
 689             // type must be present in the heap at this census time...
 690             d = lookupHashTable(censuses[t].hash, (StgWord)c->identity);
 691
 692             if (d == NULL) {
 693                 // if this closure identity isn't present in the
 694                 // census for this time period, then our running
 695                 // totals *must* be zero.
 696                 ASSERT(c->c.ldv.void_total == 0 && c->c.ldv.drag_total == 0);
 697
 698                 // debugCCS(c->identity);
 699                 // debugBelch(" census=%d void_total=%d drag_total=%d\n",
 700                 //         t, c->c.ldv.void_total, c->c.ldv.drag_total);
 701             } else {
 702                 d->c.ldv.void_total += c->c.ldv.void_total;
 703                 d->c.ldv.drag_total += c->c.ldv.drag_total;
 704                 c->c.ldv.void_total =  d->c.ldv.void_total;
 705                 c->c.ldv.drag_total =  d->c.ldv.drag_total;
 706
 707                 ASSERT( c->c.ldv.void_total >= 0 );
 708                 ASSERT( c->c.ldv.drag_total >= 0 );
 709             }
 710         }
 711
 712         // now look through the counters in this census to find new ones
 713         for (c = censuses[t].ctrs; c != NULL; c = c->next) {
 714             d = lookupHashTable(acc, (StgWord)c->identity);
 715             if (d == NULL) {
 716                 d = arenaAlloc( arena, sizeof(counter) );
 717                 initLDVCtr(d);
 718                 insertHashTable( acc, (StgWord)c->identity, d );
 719                 d->identity = c->identity;
 720                 d->next = ctrs;
 721                 ctrs = d;
 722                 d->c.ldv.void_total = c->c.ldv.void_total;
 723                 d->c.ldv.drag_total = c->c.ldv.drag_total;
 724             }
 725             ASSERT( c->c.ldv.void_total >= 0 );
 726             ASSERT( c->c.ldv.drag_total >= 0 );
 727         }
 728     }
 729
 730     freeHashTable(acc, NULL);
 731     arenaFree(arena);
 732 }
 733 #endif
 734
 735 /* -----------------------------------------------------------------------------
 736  * Print out the results of a heap census.
 737  * -------------------------------------------------------------------------- */
 738 static void
 739 dumpCensus( Census *census )
 740 {
 741     counter *ctr;
 742     int count;
 743
 744     printSample(rtsTrue, census->time);
 745
 746 #ifdef PROFILING
 747     if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV) {
 748         fprintf(hp_file, "VOID\t%u\n", census->void_total * sizeof(W_));
 749         fprintf(hp_file, "LAG\t%u\n",
 750                 (census->not_used - census->void_total) * sizeof(W_));
 751         fprintf(hp_file, "USE\t%u\n",
 752                 (census->used - census->drag_total) * sizeof(W_));
 753         fprintf(hp_file, "INHERENT_USE\t%u\n",
 754                 census->prim * sizeof(W_));
 755         fprintf(hp_file, "DRAG\t%u\n", census->drag_total *
 756                 sizeof(W_));
 757         printSample(rtsFalse, census->time);
 758         return;
 759     }
 760 #endif
 761
 762     for (ctr = census->ctrs; ctr != NULL; ctr = ctr->next) {
 763
 764 #ifdef PROFILING
 765         if (RtsFlags.ProfFlags.bioSelector != NULL) {
 766             count = 0;
 767             if (strMatchesSelector("lag", RtsFlags.ProfFlags.bioSelector))
 768                 count += ctr->c.ldv.not_used - ctr->c.ldv.void_total;
 769             if (strMatchesSelector("drag", RtsFlags.ProfFlags.bioSelector))
 770                 count += ctr->c.ldv.drag_total;
 771             if (strMatchesSelector("void", RtsFlags.ProfFlags.bioSelector))
 772                 count += ctr->c.ldv.void_total;
 773             if (strMatchesSelector("use", RtsFlags.ProfFlags.bioSelector))
 774                 count += ctr->c.ldv.used - ctr->c.ldv.drag_total;
 775         } else
 776 #endif
 777         {
 778             count = ctr->c.resid;
 779         }
 780
 781         ASSERT( count >= 0 );
 782
 783         if (count == 0) continue;
 784
 785 #ifdef DEBUG_HEAP_PROF
 786         switch (RtsFlags.ProfFlags.doHeapProfile) {
 787         case HEAP_BY_INFOPTR:
 788             fprintf(hp_file, "%s", lookupGHCName(ctr->identity));
 789             break;
 790         case HEAP_BY_CLOSURE_TYPE:
 791             fprintf(hp_file, "%s", (char *)ctr->identity);
 792             break;
 793         }
 794 #endif
 795
 796 #ifdef PROFILING
 797         switch (RtsFlags.ProfFlags.doHeapProfile) {
 798         case HEAP_BY_CCS:
 799             fprint_ccs(hp_file, (CostCentreStack *)ctr->identity, 25);
 800             break;
 801         case HEAP_BY_MOD:
 802         case HEAP_BY_DESCR:
 803         case HEAP_BY_TYPE:
 804             fprintf(hp_file, "%s", (char *)ctr->identity);
 805             break;
 806         case HEAP_BY_RETAINER:
 807         {
 808             RetainerSet *rs = (RetainerSet *)ctr->identity;
 809
 810             // it might be the distinguished retainer set rs_MANY:
 811             if (rs == &rs_MANY) {
 812                 fprintf(hp_file, "MANY");
 813                 break;
 814             }
 815
 816             // Mark this retainer set by negating its id, because it
 817             // has appeared in at least one census.  We print the
 818             // values of all such retainer sets into the log file at
 819             // the end.  A retainer set may exist but not feature in
 820             // any censuses if it arose as the intermediate retainer
 821             // set for some closure during retainer set calculation.
 822             if (rs->id > 0)
 823                 rs->id = -(rs->id);
 824
 825             // report in the unit of bytes: * sizeof(StgWord)
 826             printRetainerSetShort(hp_file, rs);
 827             break;
 828         }
 829         default:
 830             barf("dumpCensus; doHeapProfile");
 831         }
 832 #endif
 833
 834         fprintf(hp_file, "\t%d\n", count * sizeof(W_));
 835     }
 836
 837     printSample(rtsFalse, census->time);
 838 }
 839
 840 /* -----------------------------------------------------------------------------
 841  * Code to perform a heap census.
 842  * -------------------------------------------------------------------------- */
 843 static void
 844 heapCensusChain( Census *census, bdescr *bd )
 845 {
 846     StgPtr p;
 847     StgInfoTable *info;
 848     void *identity;
 849     nat size;
 850     counter *ctr;
 851     nat real_size;
 852     rtsBool prim;
 853
 854     for (; bd != NULL; bd = bd->link) {
 855
 856         // HACK: ignore pinned blocks, because they contain gaps.
 857         // It's not clear exactly what we'd like to do here, since we
 858         // can't tell which objects in the block are actually alive.
 859         // Perhaps the whole block should be counted as SYSTEM memory.
 860         if (bd->flags & BF_PINNED) {
 861             continue;
 862         }
 863
 864         p = bd->start;
 865         while (p < bd->free) {
 866             info = get_itbl((StgClosure *)p);
 867             prim = rtsFalse;
 868
 869             switch (info->type) {
 870
 871             case CONSTR:
 872             case FUN:
 873             case THUNK:
 874             case IND_PERM:
 875             case IND_OLDGEN:
 876             case IND_OLDGEN_PERM:
 877             case CAF_BLACKHOLE:
 878             case SE_CAF_BLACKHOLE:
 879             case SE_BLACKHOLE:
 880             case BLACKHOLE:
 881             case BLACKHOLE_BQ:
 882             case CONSTR_INTLIKE:
 883             case CONSTR_CHARLIKE:
 884             case FUN_1_0:
 885             case FUN_0_1:
 886             case FUN_1_1:
 887             case FUN_0_2:
 888             case FUN_2_0:
 889             case THUNK_1_1:
 890             case THUNK_0_2:
 891             case THUNK_2_0:
 892             case CONSTR_1_0:
 893             case CONSTR_0_1:
 894             case CONSTR_1_1:
 895             case CONSTR_0_2:
 896             case CONSTR_2_0:
 897                 size = sizeW_fromITBL(info);
 898                 break;
 899
 900             case BCO:
 901                 prim = rtsTrue;
 902                 size = bco_sizeW((StgBCO *)p);
 903                 break;
 904
 905             case MVAR:
 906             case WEAK:
 907             case FOREIGN:
 908             case STABLE_NAME:
 909             case MUT_VAR:
 910             case MUT_CONS:
 911                 prim = rtsTrue;
 912                 size = sizeW_fromITBL(info);
 913                 break;
 914
 915             case THUNK_1_0:             /* ToDo - shouldn't be here */
 916             case THUNK_0_1:             /* "  ditto  " */
 917             case THUNK_SELECTOR:
 918                 size = sizeofW(StgHeader) + MIN_UPD_SIZE;
 919                 break;
 920
 921             case AP:
 922             case PAP:
 923                 size = pap_sizeW((StgPAP *)p);
 924                 break;
 925
 926             case AP_STACK:
 927                 size = ap_stack_sizeW((StgAP_STACK *)p);
 928                 break;
 929
 930             case ARR_WORDS:
 931                 prim = rtsTrue;
 932                 size = arr_words_sizeW(stgCast(StgArrWords*,p));
 933                 break;
 934
 935             case MUT_ARR_PTRS:
 936             case MUT_ARR_PTRS_FROZEN:
 937                 prim = rtsTrue;
 938                 size = mut_arr_ptrs_sizeW((StgMutArrPtrs *)p);
 939                 break;
 940
 941             case TSO:
 942                 prim = rtsTrue;
 943 #ifdef DEBUG_HEAP_PROF
 944                 size = tso_sizeW((StgTSO *)p);
 945                 break;
 946 #else
 947                 if (RtsFlags.ProfFlags.includeTSOs) {
 948                     size = tso_sizeW((StgTSO *)p);
 949                     break;
 950                 } else {
 951                     // Skip this TSO and move on to the next object
 952                     p += tso_sizeW((StgTSO *)p);
 953                     continue;
 954                 }
 955 #endif
 956
 957             default:
 958                 barf("heapCensus");
 959             }
 960
 961             identity = NULL;
 962
 963 #ifdef DEBUG_HEAP_PROF
 964             real_size = size;
 965 #else
 966             // subtract the profiling overhead
 967             real_size = size - sizeofW(StgProfHeader);
 968 #endif
 969
 970             if (closureSatisfiesConstraints((StgClosure*)p)) {
 971 #ifdef PROFILING
 972                 if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV) {
 973                     if (prim)
 974                         census->prim += real_size;
 975                     else if ((LDVW(p) & LDV_STATE_MASK) == LDV_STATE_CREATE)
 976                         census->not_used += real_size;
 977                     else
 978                         census->used += real_size;
 979                 } else
 980 #endif
 981                 {
 982                     identity = closureIdentity((StgClosure *)p);
 983
 984                     if (identity != NULL) {
 985                         ctr = lookupHashTable( census->hash, (StgWord)identity );
 986                         if (ctr != NULL) {
 987 #ifdef PROFILING
 988                             if (RtsFlags.ProfFlags.bioSelector != NULL) {
 989                                 if (prim)
 990                                     ctr->c.ldv.prim += real_size;
 991                                 else if ((LDVW(p) & LDV_STATE_MASK) == LDV_STATE_CREATE)
 992                                     ctr->c.ldv.not_used += real_size;
 993                                 else
 994                                     ctr->c.ldv.used += real_size;
 995                             } else
 996 #endif
 997                             {
 998                                 ctr->c.resid += real_size;
 999                             }
1000                         } else {
1001                             ctr = arenaAlloc( census->arena, sizeof(counter) );
1002                             initLDVCtr(ctr);
1003                             insertHashTable( census->hash, (StgWord)identity, ctr );
1004                             ctr->identity = identity;
1005                             ctr->next = census->ctrs;
1006                             census->ctrs = ctr;
1007
1008 #ifdef PROFILING
1009                             if (RtsFlags.ProfFlags.bioSelector != NULL) {
1010                                 if (prim)
1011                                     ctr->c.ldv.prim = real_size;
1012                                 else if ((LDVW(p) & LDV_STATE_MASK) == LDV_STATE_CREATE)
1013                                     ctr->c.ldv.not_used = real_size;
1014                                 else
1015                                     ctr->c.ldv.used = real_size;
1016                             } else
1017 #endif
1018                             {
1019                                 ctr->c.resid = real_size;
1020                             }
1021                         }
1022                     }
1023                 }
1024             }
1025
1026             p += size;
1027         }
1028     }
1029 }
1030
1031 void
1032 heapCensus( void )
1033 {
1034   nat g, s;
1035   Census *census;
1036
1037   census = &censuses[era];
1038   census->time  = mut_user_time();
1039
1040   // calculate retainer sets if necessary
1041 #ifdef PROFILING
1042   if (doingRetainerProfiling()) {
1043       retainerProfile();
1044   }
1045 #endif
1046
1047 #ifdef PROFILING
1048   stat_startHeapCensus();
1049 #endif
1050
1051   // Traverse the heap, collecting the census info
1052
1053   // First the small_alloc_list: we have to fix the free pointer at
1054   // the end by calling tidyAllocatedLists() first.
1055   tidyAllocateLists();
1056   heapCensusChain( census, small_alloc_list );
1057
1058   // Now traverse the heap in each generation/step.
1059   if (RtsFlags.GcFlags.generations == 1) {
1060       heapCensusChain( census, g0s0->to_blocks );
1061   } else {
1062       for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1063           for (s = 0; s < generations[g].n_steps; s++) {
1064               heapCensusChain( census, generations[g].steps[s].blocks );
1065               // Are we interested in large objects?  might be
1066               // confusing to include the stack in a heap profile.
1067               heapCensusChain( census, generations[g].steps[s].large_objects );
1068           }
1069       }
1070   }
1071
1072   // dump out the census info
1073 #ifdef PROFILING
1074     // We can't generate any info for LDV profiling until
1075     // the end of the run...
1076     if (!doingLDVProfiling())
1077         dumpCensus( census );
1078 #else
1079     dumpCensus( census );
1080 #endif
1081
1082
1083   // free our storage, unless we're keeping all the census info for
1084   // future restriction by biography.
1085 #ifdef PROFILING
1086   if (RtsFlags.ProfFlags.bioSelector == NULL)
1087 #endif
1088   {
1089       freeHashTable( census->hash, NULL/* don't free the elements */ );
1090       arenaFree( census->arena );
1091       census->hash = NULL;
1092       census->arena = NULL;
1093   }
1094
1095   // we're into the next time period now
1096   nextEra();
1097
1098 #ifdef PROFILING
1099   stat_endHeapCensus();
1100 #endif
1101 }
1102
1103 #endif /* PROFILING || DEBUG_HEAP_PROF */
1104