ghc/runtime/profiling/HeapProfile.lc

   1 Only have cost centres etc if @USE_COST_CENTRES@ defined
   2
   3 \begin{code}
   4 /*
   5    Some of the code in here is pretty hairy for the compiler to deal
   6    with after we've swiped all of the useful registers.  I don't believe
   7    any STG registers are live here, but I'm not completely certain.
   8
   9    Any specific routines that require the preservation of caller-saves
  10    STG registers should be pulled out into another file and compiled
  11    with the the appropriate register map.  (Presumably one of the GC
  12    register mappings?) --JSM
  13  */
  14
  15 #define NULL_REG_MAP
  16 #include "../storage/SMinternal.h"  /* for xmalloc */
  17
  18 #if defined (USE_COST_CENTRES)
  19 \end{code}
  20
  21 %************************************************************************
  22 %*                                                                      *
  23 \subsection[heap-profiling]{Heap Profiling}
  24 %*                                                                      *
  25 %************************************************************************
  26
  27 The heap profiling reports the amount of heap space occupied by live
  28 closures pressent in the heap during a garbage collection. This
  29 profile may be broken down in a number of ways:
  30 \begin{itemize}
  31 \item {\bf Cost Centre:} The cost centres responsible for building the
  32 various closures in the heap.
  33 \item {\bf Module:} Aggregation of all the cost centres declared in a module.
  34 \item {\bf Group:}  Aggregation of all the cost centres declared in a group.
  35 \item {\bf Closure Description:} The heap occupied by closures with a particular description (normally the data constructor).
  36 \item {\bf Type Description:} The heap occupied by closures with a particular type (normally the type constructor).
  37 \item {\bf Production time stamp:} The heap occupied by closures of produced during a particular time interval.
  38 \end{itemize}
  39
  40 Relevant closures may be selected by the Cost Centre (label, module
  41 and group), by Closure Category (description, type, and kind) and/or
  42 by age.  A cost centre will be selected if its label, module or group
  43 is selected (default is all). A closure category will be selected if
  44 its description, type or kind is selected (default is all).  A closure
  45 will be selected if both its cost centre, closure category and age are
  46 selected.
  47
  48 When recording the size of the heap objects the additional profiling
  49 etc words are disregarded. The profiling itself is considered an
  50 idealised process which should not affect the statistics gathered.
  51
  52 \begin{code}
  53
  54 #define MAX_SELECT 10
  55
  56 I_ heap_profiling_req
  57     = HEAP_NO_PROFILING; /* type of heap profiling */
  58
  59 static char heap_profiling_char[]           /* indexed by heap_profiling_req */
  60     = {'?', CCchar, MODchar, GRPchar, DESCRchar, TYPEchar, TIMEchar};
  61
  62 static I_  cc_select = 0;                  /* are we selecting on Cost Centre */
  63 static I_  clcat_select = 0;               /* are we selecting on Closure Category*/
  64
  65 static I_   cc_select_no = 0;
  66 static char *cc_select_strs[MAX_SELECT];
  67 static char *ccmod_select_strs[MAX_SELECT];
  68
  69 static I_   mod_select_no = 0;
  70 static char *mod_select_strs[MAX_SELECT];
  71 static I_   grp_select_no = 0;
  72 static char *grp_select_strs[MAX_SELECT];
  73
  74 static I_   descr_select_no = 0;
  75 static char *descr_select_strs[MAX_SELECT];
  76 static I_   type_select_no = 0;
  77 static char *type_select_strs[MAX_SELECT];
  78 static I_   kind_select_no = 0;
  79 static I_   kind_selected[]    = {0, 0, 0, 0, 0, 0};
  80 static char *kind_select_strs[] = {"","CON","FN","PAP","THK","BH",0};
  81
  82 static I_   age_select = 0;       /* select ages greater than this */
  83                                   /* 0 indicates survived to the end of alloced interval */
  84
  85 I_ *resid = 0;                    /* residencies indexed by hashed feature */
  86
  87 /* For production times we have a resid table of time_intervals */
  88 /* And a seperate resid counter stuff produced earlier & later  */
  89
  90 I_ resid_earlier = 0;
  91 I_ resid_later = 0;
  92 I_ resid_max = 0;            /* Max residency -- used for aux file */
  93
  94 I_ earlier_ticks = 0;     /* No of earlier ticks grouped together */
  95 hash_t time_intervals = 18;   /* No of time_intervals, also earlier & later */
  96
  97 static hash_t earlier_intervals;     /* No of earlier intervals grouped together + 1*/
  98
  99 hash_t dummy_index_time()
 100 {
 101     return time_intervals;
 102 }
 103
 104 hash_t (* init_index_fns[])() = {
 105     0,
 106     init_index_cc,
 107     init_index_mod,
 108     init_index_grp,
 109     init_index_descr,
 110     init_index_type,
 111     dummy_index_time
 112 };
 113
 114 static char heap_filename[STATS_FILENAME_MAXLEN]; /* heap log file name = <program>.hp */
 115 static FILE *heap_file = NULL;
 116
 117 extern I_ SM_force_gc; /* Set here if we force 2-space GC */
 118
 119 I_
 120 heap_profile_init(prof, cc_select_str, mod_select_str, grp_select_str,
 121                   descr_select_str, type_select_str, kind_select_str,
 122                   select_age, argv)
 123     I_ prof;
 124     char *cc_select_str;
 125     char *mod_select_str;
 126     char *grp_select_str;
 127     char *descr_select_str;
 128     char *type_select_str;
 129     char *kind_select_str;
 130     I_  select_age;
 131     char *argv[];
 132 {
 133     hash_t count, max, first;
 134
 135     heap_profiling_req = prof;
 136
 137     if (heap_profiling_req == HEAP_NO_PROFILING)
 138         return 0;
 139
 140     /* for now, if using a generational collector and trying
 141         to heap-profile, just force the GC to be used in two-space mode.
 142         WDP 94/07
 143     */
 144 #if defined(GCap) || defined(GCgn)
 145     SM_force_gc = USE_2s;
 146 #endif
 147
 148 #if ! defined(HEAP_PROF_WITH_AGE)
 149     if (heap_profiling_req == HEAP_BY_TIME || select_age) {
 150         fprintf(stderr, "heap_profile_init: Heap Profiling not built with AGE field in closures\n");
 151         return 1;
 152     }
 153 #endif /* ! HEAP_PROF_WITH_AGE */
 154
 155     /* process select strings -- will break them into bits */
 156
 157     if (cc_select_str) {
 158         char *comma, *colon;
 159         while (cc_select_str && cc_select_no < MAX_SELECT) {
 160             if ((comma = strchr(cc_select_str, ',')) != 0) {
 161                 *comma = '\0';
 162             }
 163             if ((colon = strchr(cc_select_str, ':')) != 0) {
 164                 *colon = '\0';
 165                 ccmod_select_strs[cc_select_no] = cc_select_str;
 166                 cc_select_strs[cc_select_no++]  = colon + 1;
 167             } else {
 168                 ccmod_select_strs[cc_select_no] = (char *)0;
 169                 cc_select_strs[cc_select_no++]  = cc_select_str;
 170             }
 171             if (comma) {
 172                 cc_select_str = comma + 1;
 173             } else {
 174                 cc_select_str = (char *)0;
 175             }
 176         }
 177         if (cc_select_str && cc_select_no >= MAX_SELECT) {
 178             fprintf(stderr, "heap_profile_init: Too many Cost Centres selected\n   %ld used %s remaining\n",
 179                     cc_select_no, cc_select_str);
 180             return 1;
 181         }
 182         cc_select |= cc_select_no > 0;
 183     }
 184     if (mod_select_str) {
 185         char *comma;
 186         while ((comma = strchr(mod_select_str, ',')) && mod_select_no < MAX_SELECT) {
 187             mod_select_strs[mod_select_no++] = mod_select_str;
 188             *comma = '\0';
 189             mod_select_str = comma + 1;
 190         }
 191         if (mod_select_no < MAX_SELECT) {
 192             mod_select_strs[mod_select_no++] = mod_select_str;
 193         } else {
 194             fprintf(stderr, "heap_profile_init: Too many Modules selected\n   %ld used %s remaining\n",
 195                     mod_select_no, mod_select_str);
 196             return 1;
 197         }
 198         cc_select |= mod_select_no > 0;
 199     }
 200     if (grp_select_str) {
 201         char *comma;
 202         while ((comma = strchr(grp_select_str, ',')) && grp_select_no < MAX_SELECT) {
 203             grp_select_strs[grp_select_no++] = grp_select_str;
 204             *comma = '\0';
 205             grp_select_str = comma + 1;
 206         }
 207         if (grp_select_no < MAX_SELECT) {
 208             grp_select_strs[grp_select_no++] = grp_select_str;
 209         } else {
 210             fprintf(stderr, "heap_profile_init: Too many Groups selected\n   %ld used %s remaining\n",
 211                     grp_select_no, grp_select_str);
 212             return 1;
 213         }
 214         cc_select |= grp_select_no > 0;
 215     }
 216
 217     if (descr_select_str) {
 218         char *comma;
 219         while ((comma = strchr(descr_select_str, ',')) && descr_select_no < MAX_SELECT) {
 220             descr_select_strs[descr_select_no++] = descr_select_str;
 221             *comma = '\0';
 222             descr_select_str = comma + 1;
 223         }
 224         if (descr_select_no < MAX_SELECT) {
 225             descr_select_strs[descr_select_no++] = descr_select_str;
 226         } else {
 227             fprintf(stderr, "heap_profile_init: Too many Closure Descriptions selected\n   %ld used %s remaining\n",
 228                     descr_select_no, descr_select_str);
 229             return 1;
 230         }
 231         clcat_select |= descr_select_no > 0;
 232     }
 233     if (type_select_str) {
 234         char *comma;
 235         while ((comma = strchr(type_select_str, ',')) && type_select_no < MAX_SELECT) {
 236             type_select_strs[type_select_no++] = type_select_str;
 237             *comma = '\0';
 238             type_select_str = comma + 1;
 239         }
 240         if (type_select_no < MAX_SELECT) {
 241             type_select_strs[type_select_no++] = type_select_str;
 242         } else {
 243             fprintf(stderr, "heap_profile_init: Too many Closure Types selected\n   %ld used %s remaining\n",
 244                     type_select_no, type_select_str);
 245             return 1;
 246         }
 247         clcat_select |= type_select_no > 0;
 248     }
 249     if (kind_select_str) {
 250         char *comma;
 251         while ((comma = strchr(kind_select_str, ',')) != 0) {
 252             *comma = '\0';
 253             for (count = 1; kind_select_strs[count]; count++) {
 254                 if (strcmp(kind_select_strs[count],kind_select_str) == 0) {
 255                     kind_selected[count] = 1;
 256                     kind_select_no++;
 257                     break;
 258                 }
 259             }
 260             if (! kind_select_strs[count]) {
 261                 fprintf(stderr, "heap_profile_init: Invalid Kind: %s\n", kind_select_str);
 262                 return 1;
 263             }
 264             kind_select_str = comma + 1;
 265         }
 266         for (count = 1; kind_select_strs[count]; count++) {
 267             if (strcmp(kind_select_strs[count],kind_select_str) == 0) {
 268                 kind_selected[count] = 1;
 269                 kind_select_no++;
 270                 break;
 271             }
 272         }
 273         if (! kind_select_strs[count]) {
 274             fprintf(stderr, "heap_profile_init: Invalid Kind: %s\n", kind_select_str);
 275             return 1;
 276         }
 277         clcat_select |= kind_select_no > 0;
 278     }
 279     age_select = select_age;
 280
 281
 282     /* open heap profiling log file */
 283
 284     sprintf(heap_filename, HP_FILENAME_FMT, argv[0]);
 285     if ( (heap_file = fopen(heap_filename,"w")) == NULL ) {
 286         fprintf(stderr, "Can't open heap log file %s\n", heap_filename);
 287         return 1;
 288     }
 289
 290     /* write start of log file */
 291
 292     fprintf(heap_file, "JOB \"%s", argv[0]);
 293     fprintf(heap_file, " +RTS -h%c", heap_profiling_char[heap_profiling_req]);
 294     if (heap_profiling_req == HEAP_BY_TIME) {
 295         fprintf(heap_file, "%ld", time_intervals);
 296         if (earlier_ticks) {
 297             fprintf(heap_file, ",%3.1f",
 298                     earlier_ticks / (StgFloat)TICK_FREQUENCY);
 299         }
 300     }
 301     if (cc_select_no) {
 302         fprintf(heap_file, " -c{%s:%s",
 303                 ccmod_select_strs[0],
 304                 cc_select_strs[0]);
 305         for (count = 1; count < cc_select_no; count++) {
 306             fprintf(heap_file, ",%s:%s",
 307                     ccmod_select_strs[count],
 308                     cc_select_strs[count]);
 309         }
 310         fprintf(heap_file, "}");
 311     }
 312     if (mod_select_no) {
 313         fprintf(heap_file, " -m{%s", mod_select_strs[0]);
 314         for (count = 1; count < mod_select_no; count++)
 315             fprintf(heap_file, ",%s", mod_select_strs[count]);
 316         fprintf(heap_file, "}");
 317     }
 318     if (grp_select_no) {
 319         fprintf(heap_file, " -g{%s", grp_select_strs[0]);
 320         for (count = 1; count < grp_select_no; count++)
 321             fprintf(heap_file, ",%s", grp_select_strs[count]);
 322         fprintf(heap_file, "}");
 323     }
 324     if (descr_select_no) {
 325         fprintf(heap_file, " -d{%s", descr_select_strs[0]);
 326         for (count = 1; count < descr_select_no; count++)
 327             fprintf(heap_file, ",%s", descr_select_strs[count]);
 328         fprintf(heap_file, "}");
 329     }
 330     if (type_select_no) {
 331         fprintf(heap_file, " -t{%s", type_select_strs[0]);
 332         for (count = 1; count < type_select_no; count++)
 333             fprintf(heap_file, ",%s", type_select_strs[count]);
 334         fprintf(heap_file, "}");
 335     }
 336     if (kind_select_no) {
 337         fprintf(heap_file, " -k{");
 338         for (count = 1, first = 1; kind_select_strs[count]; count++)
 339             if (kind_selected[count]) {
 340                 fprintf(heap_file, "%s%s", first?"":",", kind_select_strs[count]);
 341                 first = 0;
 342             }
 343         fprintf(heap_file, "}");
 344     }
 345     if (select_age) {
 346         fprintf(heap_file, " -a%ld", age_select);
 347     }
 348     fprintf(heap_file, " -i%4.2f -RTS", interval_ticks/(StgFloat)TICK_FREQUENCY);
 349     for(count = 1; argv[count]; count++)
 350         fprintf(heap_file, " %s", argv[count]);
 351     fprintf(heap_file, "\"\n");
 352
 353     fprintf(heap_file, "DATE \"%s\"\n", time_str());
 354
 355     fprintf(heap_file, "SAMPLE_UNIT \"seconds\"\n");
 356     fprintf(heap_file, "VALUE_UNIT \"bytes\"\n");
 357
 358     fprintf(heap_file, "BEGIN_SAMPLE 0.00\n");
 359     fprintf(heap_file, "END_SAMPLE 0.00\n");
 360
 361
 362     /* initialise required heap profiling data structures & hashing */
 363
 364     earlier_intervals = (earlier_ticks / interval_ticks) + 1;
 365     max = (* init_index_fns[heap_profiling_req])();
 366     resid = (I_ *) xmalloc(max * sizeof(I_));
 367     for (count = 0; count < max; count++) resid[count] = 0;
 368
 369     return 0;
 370 }
 371 \end{code}
 372
 373 Cost centre selection is set up before a heap profile by running
 374 through the list of registered cost centres and memoising the
 375 selection in the cost centre record. It is only necessary to memoise
 376 the cost centre selection if a selection profiling function is
 377 being called.
 378
 379 Category selection is determined when each closure is encountered. It
 380 is memoised within the category record. We always have to check that
 381 the memoisation has been done as we do not have a list of categories
 382 we can process before hand.
 383
 384 Age selection is done for every closure -- not memoised.
 385
 386 \begin{code}
 387 void
 388 set_selected_ccs()            /* set selection before we profile heap */
 389 {
 390     I_ x;
 391     CostCentre cc;
 392
 393     if (cc_select) {
 394         for (cc = Registered_CC; cc != REGISTERED_END; cc = cc->registered) {
 395             for (x = 0; ! cc->selected && x < cc_select_no; x++)
 396                 cc->selected = (strcmp(cc->label, cc_select_strs[x]) == 0) &&
 397                                (strcmp(cc->module, ccmod_select_strs[x]) == 0);
 398             for (x = 0; ! cc->selected && x < mod_select_no; x++)
 399                 cc->selected = (strcmp(cc->module, mod_select_strs[x]) == 0);
 400             for (x = 0; ! cc->selected && x < grp_select_no; x++)
 401                 cc->selected = (strcmp(cc->group, grp_select_strs[x]) == 0);
 402         }
 403     } else {
 404         for (cc = Registered_CC; cc != REGISTERED_END; cc = cc->registered)
 405             cc->selected = 1;      /* true if ! cc_select */
 406     }
 407 }
 408
 409
 410 I_
 411 selected_clcat(clcat)
 412     ClCategory clcat;
 413 {
 414     I_ x;
 415
 416     if (clcat->selected == -1) {     /* if not memoised check selection */
 417         if (clcat_select) {
 418             clcat->selected = 0;
 419             for (x = 0; ! clcat->selected && x < descr_select_no; x++)
 420                 clcat->selected = (strcmp(clcat->descr, descr_select_strs[x]) == 0);
 421             for (x = 0; ! clcat->selected && x < type_select_no; x++)
 422                 clcat->selected = (strcmp(clcat->type, type_select_strs[x]) == 0);
 423             if (kind_select_no) clcat->selected |= kind_selected[clcat->kind];
 424         } else {
 425             clcat->selected = 1;
 426         }
 427     }
 428     return clcat->selected;          /* return memoised selection */
 429 }
 430 \end{code}
 431
 432
 433 Profiling functions called for each closure. The appropriate function
 434 is stored in @heap_profile_fn@ by @heap_profile_setup@.
 435 @heap_profile_fn@ is called for each live closure by the macros
 436 embedded in the garbage collector. They increment the appropriate
 437 resident space counter by the size of the closure (less any profiling
 438 words).
 439
 440 \begin{code}
 441 #define NON_PROF_HS (FIXED_HS - PROF_FIXED_HDR - AGE_FIXED_HDR)
 442
 443 void
 444 profile_closure_none(closure,size)
 445   P_ closure;
 446   I_ size;
 447 {
 448     return;
 449 }
 450
 451 void
 452 profile_closure_cc(closure,size)
 453   P_ closure;
 454   I_ size;
 455 {
 456     CostCentre cc = (CostCentre) CC_HDR(closure);
 457     resid[index_cc(cc)] += size + NON_PROF_HS;
 458     return;
 459 }
 460
 461 void
 462 profile_closure_cc_select(closure,size)
 463   P_ closure;
 464   I_ size;
 465 {
 466     CostCentre cc; ClCategory clcat;
 467
 468     cc = (CostCentre) CC_HDR(closure);
 469     if (! cc->selected)                   /* selection determined before profile */
 470         return;                           /* all selected if ! cc_select         */
 471
 472     clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
 473     if (clcat_select && ! selected_clcat(clcat))    /* selection memoised during profile */
 474         return;
 475
 476 #if defined(HEAP_PROF_WITH_AGE)
 477     if (age_select) {
 478         I_ age, ts = AGE_HDR(closure);
 479
 480         if (ts == 0) { /* Set to 0 when alloced -- now set to current interval */
 481             AGE_HDR(closure) = (W_)current_interval;
 482             age = - age_select;
 483         }
 484         else {
 485             age = current_interval - ts - age_select;
 486         }
 487         if (age < 0) return;
 488     }
 489 #endif /* HEAP_PROF_WITH_AGE */
 490
 491     resid[index_cc(cc)] += size + NON_PROF_HS;
 492     return;
 493 }
 494
 495 void
 496 profile_closure_mod(closure,size)
 497   P_ closure;
 498   I_ size;
 499 {
 500     CostCentre cc = (CostCentre) CC_HDR(closure);
 501     resid[index_mod(cc)] += size + NON_PROF_HS;
 502     return;
 503 }
 504
 505 void
 506 profile_closure_mod_select(closure,size)
 507   P_ closure;
 508   I_ size;
 509 {
 510     CostCentre cc; ClCategory clcat;
 511
 512     cc = (CostCentre) CC_HDR(closure);
 513     if (! cc->selected)                       /* selection determined before profile */
 514         return;
 515
 516     clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
 517     if (clcat_select && ! selected_clcat(clcat))    /* selection memoised during profile */
 518         return;
 519
 520 #if defined(HEAP_PROF_WITH_AGE)
 521     if (age_select) {
 522         I_ age, ts = AGE_HDR(closure);
 523
 524         if (ts == 0) { /* Set to 0 when alloced -- now set to current interval */
 525             AGE_HDR(closure) = (W_)current_interval;
 526             age = - age_select;
 527         }
 528         else {
 529             age = current_interval - ts - age_select;
 530         }
 531         if (age < 0) return;
 532     }
 533 #endif /* HEAP_PROF_WITH_AGE */
 534
 535     resid[index_mod(cc)] += size + NON_PROF_HS;
 536     return;
 537 }
 538
 539 void
 540 profile_closure_grp(closure,size)
 541   P_ closure;
 542   I_ size;
 543 {
 544     CostCentre cc = (CostCentre) CC_HDR(closure);
 545     resid[index_grp(cc)] += size + NON_PROF_HS;
 546     return;
 547 }
 548 void
 549 profile_closure_grp_select(closure,size)
 550   P_ closure;
 551   I_ size;
 552 {
 553     CostCentre cc; ClCategory clcat;
 554
 555     cc = (CostCentre) CC_HDR(closure);
 556     if (! cc->selected)                       /* selection determined before profile */
 557         return;
 558
 559     clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
 560     if (clcat_select && ! selected_clcat(clcat))    /* selection memoised during profile */
 561         return;
 562
 563 #if defined(HEAP_PROF_WITH_AGE)
 564     if (age_select) {
 565         I_ age, ts = AGE_HDR(closure);
 566
 567         if (ts == 0) { /* Set to 0 when alloced -- now set to current interval */
 568             AGE_HDR(closure) = (W_)current_interval;
 569             age = - age_select;
 570         }
 571         else {
 572             age = current_interval - ts - age_select;
 573         }
 574         if (age < 0) return;
 575     }
 576 #endif /* HEAP_PROF_WITH_AGE */
 577
 578     resid[index_grp(cc)] += size + NON_PROF_HS;
 579     return;
 580 }
 581
 582 void
 583 profile_closure_descr(closure,size)
 584   P_ closure;
 585   I_ size;
 586 {
 587     ClCategory clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
 588     resid[index_descr(clcat)] += size + NON_PROF_HS;
 589     return;
 590 }
 591
 592 void
 593 profile_closure_descr_select(closure,size)
 594   P_ closure;
 595   I_ size;
 596 {
 597     CostCentre cc; ClCategory clcat;
 598
 599     cc = (CostCentre) CC_HDR(closure);
 600     if (! cc->selected)                     /* selection determined before profile */
 601         return;                             /* all selected if ! cc_select         */
 602
 603     clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
 604     if (clcat_select && ! selected_clcat(clcat))  /* selection memoised during profile */
 605         return;
 606
 607 #if defined(HEAP_PROF_WITH_AGE)
 608     if (age_select) {
 609         I_ age, ts = AGE_HDR(closure);
 610
 611         if (ts == 0) { /* Set to 0 when alloced -- now set to current interval */
 612             AGE_HDR(closure) = (W_)current_interval;
 613             age = - age_select;
 614         }
 615         else {
 616             age = current_interval - ts - age_select;
 617         }
 618         if (age < 0) return;
 619     }
 620 #endif /* HEAP_PROF_WITH_AGE */
 621
 622     resid[index_descr(clcat)] += size + NON_PROF_HS;
 623     return;
 624 }
 625
 626 void
 627 profile_closure_type(closure,size)
 628   P_ closure;
 629   I_ size;
 630 {
 631     ClCategory clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
 632     resid[index_type(clcat)] += size + NON_PROF_HS;
 633     return;
 634 }
 635
 636 void
 637 profile_closure_type_select(closure,size)
 638   P_ closure;
 639   I_ size;
 640 {
 641     CostCentre cc; ClCategory clcat;
 642
 643     cc = (CostCentre) CC_HDR(closure);
 644     if (! cc->selected)                     /* selection determined before profile */
 645         return;                             /* all selected if ! cc_select         */
 646
 647     clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
 648     if (clcat_select && ! selected_clcat(clcat))  /* selection memoised during profile */
 649         return;
 650
 651 #if defined(HEAP_PROF_WITH_AGE)
 652     if (age_select) {
 653         I_ age, ts = AGE_HDR(closure);
 654
 655         if (ts == 0) { /* Set to 0 when alloced -- now set to current interval */
 656             AGE_HDR(closure) = (W_)current_interval;
 657             age = - age_select;
 658         }
 659         else {
 660             age = current_interval - ts - age_select;
 661         }
 662         if (age < 0) return;
 663     }
 664 #endif /* HEAP_PROF_WITH_AGE */
 665
 666     resid[index_type(clcat)] += size + NON_PROF_HS;
 667     return;
 668 }
 669
 670 void
 671 profile_closure_time(closure,size)
 672   P_ closure;
 673   I_ size;
 674 {
 675 #if defined(HEAP_PROF_WITH_AGE)
 676     I_ ts = AGE_HDR(closure);
 677
 678     if (ts == 0) { /* Set to 0 when alloced -- now set to current interval */
 679         AGE_HDR(closure) = (W_)current_interval;
 680         ts = current_interval;
 681     }
 682
 683     ts -= earlier_intervals;
 684
 685     if (ts < 0) {
 686         resid_earlier +=  size + NON_PROF_HS;
 687     }
 688     else if (ts < time_intervals) {
 689         resid[ts] +=  size + NON_PROF_HS;
 690     }
 691     else {
 692         resid_later +=  size + NON_PROF_HS;
 693     }
 694 #endif /* HEAP_PROF_WITH_AGE */
 695
 696     return;
 697 }
 698
 699 void
 700 profile_closure_time_select(closure,size)
 701   P_ closure;
 702   I_ size;
 703 {
 704 #if defined(HEAP_PROF_WITH_AGE)
 705     CostCentre cc; ClCategory clcat; I_ age, ts;
 706
 707     cc = (CostCentre) CC_HDR(closure);
 708     if (! cc->selected)                     /* selection determined before profile */
 709         return;                             /* all selected if ! cc_select         */
 710
 711     clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
 712     if (clcat_select && ! selected_clcat(clcat))  /* selection memoised during profile */
 713         return;
 714
 715     ts = AGE_HDR(closure);
 716     if (ts == 0) { /* Set to 0 when alloced -- now set to current interval */
 717         AGE_HDR(closure) = (W_)current_interval;
 718         ts = current_interval;
 719         age = - age_select;
 720     }
 721     else {
 722         age = current_interval - ts - age_select;
 723     }
 724     if (age < 0)
 725         return;
 726
 727     ts -= earlier_intervals;
 728
 729     if (ts < 0) {
 730         resid_earlier +=  size + NON_PROF_HS;
 731     }
 732     else if (ts < time_intervals) {
 733         resid[ts] +=  size + NON_PROF_HS;
 734     }
 735     else {
 736         resid_later +=  size + NON_PROF_HS;
 737     }
 738 #endif /* HEAP_PROF_WITH_AGE */
 739
 740     return;
 741 }
 742 \end{code}
 743
 744 @heap_profile_setup@ is called before garbage collection to initialise
 745 for the profile. It assigns the appropriate closure profiling function
 746 to @heap_profile_fn@ and memoises any cost centre selection. If no
 747 profile is required @profile_closure_none@ is assigned.
 748
 749 On completion of garbage collection @heap_profile_done@ is called. It
 750 produces a heap profile report and resets the residency counts to 0.
 751
 752 \begin{code}
 753
 754 void (* heap_profile_fn) PROTO((P_,I_)) = profile_closure_none;
 755
 756 void (* profiling_fns_select[]) PROTO((P_,I_)) = {
 757     profile_closure_none,
 758     profile_closure_cc_select,
 759     profile_closure_mod_select,
 760     profile_closure_grp_select,
 761     profile_closure_descr_select,
 762     profile_closure_type_select,
 763     profile_closure_time_select
 764 };
 765
 766 void (* profiling_fns[]) PROTO((P_,I_)) = {
 767     profile_closure_none,
 768     profile_closure_cc,
 769     profile_closure_mod,
 770     profile_closure_grp,
 771     profile_closure_descr,
 772     profile_closure_type,
 773     profile_closure_time
 774 };
 775
 776 void
 777 heap_profile_setup(STG_NO_ARGS)      /* called at start of heap profile */
 778 {
 779     if (heap_profiling_req == HEAP_NO_PROFILING)
 780         return;
 781
 782     if (cc_select || clcat_select || age_select) {
 783         set_selected_ccs();               /* memoise cc selection */
 784         heap_profile_fn = profiling_fns_select[heap_profiling_req];
 785     } else {
 786         heap_profile_fn = profiling_fns[heap_profiling_req];
 787     }
 788 }
 789
 790 void
 791 heap_profile_done(STG_NO_ARGS)    /* called at end of heap profile */
 792 {
 793     CostCentre cc; ClCategory clcat; hash_t ind, max;
 794     StgFloat seconds;
 795
 796     if (heap_profiling_req == HEAP_NO_PROFILING)
 797         return;
 798
 799     heap_profile_fn = profile_closure_none;
 800
 801     seconds = (previous_ticks + current_ticks) / (StgFloat)TICK_FREQUENCY;
 802     fprintf(heap_file, "BEGIN_SAMPLE %0.2f\n", seconds);
 803
 804     max = (* init_index_fns[heap_profiling_req])();
 805
 806     switch (heap_profiling_req) {
 807       case HEAP_BY_CC:
 808         for (ind = 0; ind < max; ind++) {
 809             if ((cc = index_cc_table[ind]) != 0) {
 810                 fprintf(heap_file, "  %0.11s:%0.16s %ld\n", cc->module, cc->label, resid[ind] * sizeof(W_));
 811             }
 812             resid[ind] = 0;
 813         }
 814         break;
 815
 816       case HEAP_BY_MOD:
 817         for (ind = 0; ind < max; ind++) {
 818             if ((cc = index_mod_table[ind]) != 0) {
 819                 fprintf(heap_file, "  %0.11s %ld\n", cc->module, resid[ind] * sizeof(W_));
 820             }
 821             resid[ind] = 0;
 822         }
 823         break;
 824
 825       case HEAP_BY_GRP:
 826         for (ind = 0; ind < max; ind++) {
 827             if ((cc = index_grp_table[ind]) != 0) {
 828                 fprintf(heap_file, "  %0.11s %ld\n", cc->group, resid[ind] * sizeof(W_));
 829             }
 830             resid[ind] = 0;
 831         }
 832         break;
 833
 834       case HEAP_BY_DESCR:
 835         for (ind = 0; ind < max; ind++) {
 836             if ((clcat = index_descr_table[ind]) != 0) {
 837                 fprintf(heap_file, "  %0.28s %ld\n", clcat->descr, resid[ind] * sizeof(W_));
 838             }
 839             resid[ind] = 0;
 840         }
 841         break;
 842
 843       case HEAP_BY_TYPE:
 844         for (ind = 0; ind < max; ind++) {
 845             if ((clcat = index_type_table[ind]) != 0) {
 846                 fprintf(heap_file, "  %0.28s %ld\n", clcat->type, resid[ind] * sizeof(W_));
 847             }
 848             resid[ind] = 0;
 849         }
 850         break;
 851
 852 #if defined(HEAP_PROF_WITH_AGE)
 853       case HEAP_BY_TIME:
 854         { I_ resid_tot = 0;
 855           if (resid_earlier) {
 856               resid_tot += resid_earlier;
 857               fprintf(heap_file, "  before_%4.2fs %ld\n",
 858                       (earlier_intervals-1)*interval_ticks/(StgFloat)TICK_FREQUENCY,
 859                       resid_earlier * sizeof(StgWord));
 860               resid_earlier = 0;
 861           }
 862           for (ind = 0; ind < max; ind++) {
 863               if (resid[ind]) {
 864                   resid_tot +=  resid[ind];
 865                   fprintf(heap_file, "  before_%4.2fs %ld\n",
 866                           (ind+earlier_intervals)*interval_ticks/(StgFloat)TICK_FREQUENCY,
 867                           resid[ind] * sizeof(StgWord));
 868                   resid[ind] = 0;
 869               }
 870           }
 871           if (resid_later) {
 872               resid_tot += resid_later;
 873               fprintf(heap_file, "  later %ld\n", resid_later * sizeof(StgWord));
 874               resid_later = 0;
 875           }
 876
 877           if (resid_max < resid_tot) resid_max = resid_tot;
 878           break;
 879         }
 880 #endif /* HEAP_PROF_WITH_AGE */
 881     }
 882
 883     fprintf(heap_file, "END_SAMPLE %0.2f\n", seconds);
 884     fflush(heap_file);
 885 }
 886
 887 void
 888 heap_profile_finish(STG_NO_ARGS)     /* called at end of execution */
 889 {
 890     StgFloat seconds;
 891
 892     if (heap_profiling_req == HEAP_NO_PROFILING)
 893         return;
 894
 895     seconds = (previous_ticks + current_ticks) / (StgFloat)TICK_FREQUENCY;
 896     fprintf(heap_file, "BEGIN_SAMPLE %0.2f\n", seconds);
 897     fprintf(heap_file, "END_SAMPLE %0.2f\n", seconds);
 898     fclose(heap_file);
 899
 900     return;
 901 }
 902 \end{code}
 903
 904 \begin{code}
 905 #endif /* USE_COST_CENTRES */
 906 \end{code}