Only have cost centres etc if @PROFILING@ defined

\begin{code}
/* 
   Some of the code in here is pretty hairy for the compiler to deal
   with after we've swiped all of the useful registers.  I don't believe
   any STG registers are live here, but I'm not completely certain.  

   Any specific routines that require the preservation of caller-saves
   STG registers should be pulled out into another file and compiled
   with the the appropriate register map.  (Presumably one of the GC
   register mappings?) --JSM
 */

#define NULL_REG_MAP
#include "../storage/SMinternal.h" /* for ???? */

#if defined (PROFILING)
\end{code}

%************************************************************************
%*									*
\subsection[heap-profiling]{Heap Profiling}
%*									*
%************************************************************************

The heap profiling reports the amount of heap space occupied by live
closures pressent in the heap during a garbage collection. This
profile may be broken down in a number of ways:
\begin{itemize}
\item {\bf Cost Centre:} The cost centres responsible for building the
various closures in the heap.
\item {\bf Module:} Aggregation of all the cost centres declared in a module.
\item {\bf Group:}  Aggregation of all the cost centres declared in a group.
\item {\bf Closure Description:} The heap occupied by closures with a particular description (normally the data constructor).
\item {\bf Type Description:} The heap occupied by closures with a particular type (normally the type constructor).
\item {\bf Production time stamp:} The heap occupied by closures of produced during a particular time interval.
\end{itemize}

Relevant closures may be selected by the Cost Centre (label, module
and group), by Closure Category (description, type, and kind) and/or
by age.  A cost centre will be selected if its label, module or group
is selected (default is all). A closure category will be selected if
its description, type or kind is selected (default is all).  A closure
will be selected if both its cost centre, closure category and age are
selected.

When recording the size of the heap objects the additional profiling
etc words are disregarded. The profiling itself is considered an
idealised process which should not affect the statistics gathered.

\begin{code}
#define MAX_SELECT 10

static char heap_profiling_char[] /* indexed by RTSflags.ProfFlags.doHeapProfile */
    = {'?', CCchar, MODchar, GRPchar, DESCRchar, TYPEchar, TIMEchar};

static I_  cc_select = 0;                  /* are we selecting on Cost Centre */
static I_  clcat_select = 0;               /* are we selecting on Closure Category*/

static I_   cc_select_no = 0;
static char *cc_select_strs[MAX_SELECT];
static char *ccmod_select_strs[MAX_SELECT];

static I_   mod_select_no = 0;
static char *mod_select_strs[MAX_SELECT];
static I_   grp_select_no = 0;
static char *grp_select_strs[MAX_SELECT];

static I_   descr_select_no = 0;
static char *descr_select_strs[MAX_SELECT];
static I_   type_select_no = 0;
static char *type_select_strs[MAX_SELECT];
static I_   kind_select_no = 0;
static I_   kind_selected[]    = {0, 0, 0, 0, 0, 0};
static char *kind_select_strs[] = {"","CON","FN","PAP","THK","BH",0};

I_ *resid = 0;	/* residencies indexed by hashed feature */

/* For production times we have a resid table of time_intervals */
/* And a seperate resid counter stuff produced earlier & later  */

I_ resid_earlier = 0;
I_ resid_later = 0;
I_ resid_max = 0;            /* Max residency -- used for aux file */

I_ earlier_ticks = 0;     /* No of earlier ticks grouped together */
hash_t time_intervals = 18;   /* No of time_intervals, also earlier & later */

static hash_t earlier_intervals;     /* No of earlier intervals grouped together + 1*/

hash_t
dummy_index_time(STG_NO_ARGS)
{
    return time_intervals;
}

hash_t (* init_index_fns[])() = {
    0,
    init_index_cc,
    init_index_mod,
    init_index_grp,
    init_index_descr,
    init_index_type,
    dummy_index_time
};

static char heap_filename[STATS_FILENAME_MAXLEN]; /* heap log file name = <program>.hp */
static FILE *heap_file = NULL;

I_
heap_profile_init(argv) 
  char *argv[];
{
    char *cc_select_str	    = RTSflags.ProfFlags.ccSelector;
    char *mod_select_str    = RTSflags.ProfFlags.modSelector;
    char *grp_select_str    = RTSflags.ProfFlags.grpSelector;
    char *descr_select_str  = RTSflags.ProfFlags.descrSelector;
    char *type_select_str   = RTSflags.ProfFlags.typeSelector;
    char *kind_select_str   = RTSflags.ProfFlags.kindSelector;

    hash_t count, max, first;
    W_ heap_prof_style;

    if (! RTSflags.ProfFlags.doHeapProfile)
	return 0;

    /* for now, if using a generational collector and trying
	to heap-profile, just force the GC to be used in two-space mode.
	WDP 94/07
    */
#if defined(GCap) || defined(GCgn)
    RTSflags.GcFlags.force2s = rtsTrue;
#endif

    heap_prof_style = RTSflags.ProfFlags.doHeapProfile;

    /* process select strings -- will break them into bits */
    
    if (cc_select_str) {
	char *comma, *colon;
	while (cc_select_str && cc_select_no < MAX_SELECT) {
            if ((comma = strchr(cc_select_str, ',')) != 0) {
		*comma = '\0';
	    }
            if ((colon = strchr(cc_select_str, ':')) != 0) {
                *colon = '\0';
	        ccmod_select_strs[cc_select_no] = cc_select_str;
	        cc_select_strs[cc_select_no++]  = colon + 1;
	    } else {
                ccmod_select_strs[cc_select_no] = (char *)0;
	        cc_select_strs[cc_select_no++]  = cc_select_str;
	    }
	    if (comma) {
		cc_select_str = comma + 1;
	    } else {
		cc_select_str = (char *)0;
	    }
	}
	if (cc_select_str && cc_select_no >= MAX_SELECT) {
	    fprintf(stderr, "heap_profile_init: Too many Cost Centres selected\n   %ld used %s remaining\n",
		    cc_select_no, cc_select_str);
	    return 1;
	}
	cc_select |= cc_select_no > 0;
    }
    if (mod_select_str) {
	char *comma;
	while ((comma = strchr(mod_select_str, ',')) && mod_select_no < MAX_SELECT) {
	    mod_select_strs[mod_select_no++] = mod_select_str;
	    *comma = '\0';
	    mod_select_str = comma + 1;
	}
	if (mod_select_no < MAX_SELECT) {
	    mod_select_strs[mod_select_no++] = mod_select_str;
	} else {
	    fprintf(stderr, "heap_profile_init: Too many Modules selected\n   %ld used %s remaining\n",
		    mod_select_no, mod_select_str);
	    return 1;
	}
	cc_select |= mod_select_no > 0;
    }
    if (grp_select_str) {
	char *comma;
	while ((comma = strchr(grp_select_str, ',')) && grp_select_no < MAX_SELECT) {
	    grp_select_strs[grp_select_no++] = grp_select_str;
	    *comma = '\0';
	    grp_select_str = comma + 1;
	}
	if (grp_select_no < MAX_SELECT) {
	    grp_select_strs[grp_select_no++] = grp_select_str;
	} else {
	    fprintf(stderr, "heap_profile_init: Too many Groups selected\n   %ld used %s remaining\n",
		    grp_select_no, grp_select_str);
	    return 1;
	}
	cc_select |= grp_select_no > 0;
    }
    
    if (descr_select_str) {
	char *comma;
	while ((comma = strchr(descr_select_str, ',')) && descr_select_no < MAX_SELECT) {
	    descr_select_strs[descr_select_no++] = descr_select_str;
	    *comma = '\0';
	    descr_select_str = comma + 1;
	}
	if (descr_select_no < MAX_SELECT) {
	    descr_select_strs[descr_select_no++] = descr_select_str;
	} else {
	    fprintf(stderr, "heap_profile_init: Too many Closure Descriptions selected\n   %ld used %s remaining\n",
		    descr_select_no, descr_select_str);
	    return 1;
	}
	clcat_select |= descr_select_no > 0;
    }
    if (type_select_str) {
	char *comma;
	while ((comma = strchr(type_select_str, ',')) && type_select_no < MAX_SELECT) {
	    type_select_strs[type_select_no++] = type_select_str;
	    *comma = '\0';
	    type_select_str = comma + 1;
	}
	if (type_select_no < MAX_SELECT) {
	    type_select_strs[type_select_no++] = type_select_str;
	} else {
	    fprintf(stderr, "heap_profile_init: Too many Closure Types selected\n   %ld used %s remaining\n",
		    type_select_no, type_select_str);
	    return 1;
	}
	clcat_select |= type_select_no > 0;
    }
    if (kind_select_str) {
	char *comma;
	while ((comma = strchr(kind_select_str, ',')) != 0) {
	    *comma = '\0';
	    for (count = 1; kind_select_strs[count]; count++) {
		if (strcmp(kind_select_strs[count],kind_select_str) == 0) {
		    kind_selected[count] = 1;
		    kind_select_no++;
		    break;
		}
	    }
	    if (! kind_select_strs[count]) {
		fprintf(stderr, "heap_profile_init: Invalid Kind: %s\n", kind_select_str);
		return 1;
	    }
	    kind_select_str = comma + 1;
	}
	for (count = 1; kind_select_strs[count]; count++) {
	    if (strcmp(kind_select_strs[count],kind_select_str) == 0) {
		kind_selected[count] = 1;
		kind_select_no++;
		break;
	    }
	}
	if (! kind_select_strs[count]) {
	    fprintf(stderr, "heap_profile_init: Invalid Kind: %s\n", kind_select_str);
	    return 1;
	}
	clcat_select |= kind_select_no > 0;
    }
    
    /* open heap profiling log file */
    
    sprintf(heap_filename, HP_FILENAME_FMT, argv[0]);
    if ( (heap_file = fopen(heap_filename,"w")) == NULL ) {
	fprintf(stderr, "Can't open heap log file %s\n", heap_filename);
	return 1;
    }
    
    /* write start of log file */
    
    fprintf(heap_file, "JOB \"%s", argv[0]);
    fprintf(heap_file, " +RTS -h%c", heap_profiling_char[heap_prof_style]);
    if (heap_prof_style == HEAP_BY_TIME) {
	fprintf(heap_file, "%ld", time_intervals);
	if (earlier_ticks) {
	    fprintf(heap_file, ",%3.1f",
		    earlier_ticks / (StgFloat)TICK_FREQUENCY);
	}
    }
    if (cc_select_no) {
	fprintf(heap_file, " -c{%s:%s",
		ccmod_select_strs[0], 
		cc_select_strs[0]);
	for (count = 1; count < cc_select_no; count++) {
	    fprintf(heap_file, ",%s:%s",
		    ccmod_select_strs[count],
		    cc_select_strs[count]);
	}
	fprintf(heap_file, "}");
    }
    if (mod_select_no) {
	fprintf(heap_file, " -m{%s", mod_select_strs[0]);
	for (count = 1; count < mod_select_no; count++)
	    fprintf(heap_file, ",%s", mod_select_strs[count]);
	fprintf(heap_file, "}");
    }
    if (grp_select_no) {
	fprintf(heap_file, " -g{%s", grp_select_strs[0]);
	for (count = 1; count < grp_select_no; count++)
	    fprintf(heap_file, ",%s", grp_select_strs[count]);
	fprintf(heap_file, "}");
    }
    if (descr_select_no) {
	fprintf(heap_file, " -d{%s", descr_select_strs[0]);
	for (count = 1; count < descr_select_no; count++)
	    fprintf(heap_file, ",%s", descr_select_strs[count]);
	fprintf(heap_file, "}");
    }
    if (type_select_no) {
	fprintf(heap_file, " -y{%s", type_select_strs[0]);
	for (count = 1; count < type_select_no; count++)
	    fprintf(heap_file, ",%s", type_select_strs[count]);
	fprintf(heap_file, "}");
    }
    if (kind_select_no) {
	fprintf(heap_file, " -k{");
	for (count = 1, first = 1; kind_select_strs[count]; count++)
	    if (kind_selected[count]) {
		fprintf(heap_file, "%s%s", first?"":",", kind_select_strs[count]);
		first = 0;
	    }
	fprintf(heap_file, "}");
    }

    fprintf(heap_file, " -i%4.2f -RTS", interval_ticks/(StgFloat)TICK_FREQUENCY);
    for(count = 1; argv[count]; count++)
	fprintf(heap_file, " %s", argv[count]);
    fprintf(heap_file, "\"\n");

    fprintf(heap_file, "DATE \"%s\"\n", time_str());
    
    fprintf(heap_file, "SAMPLE_UNIT \"seconds\"\n");
    fprintf(heap_file, "VALUE_UNIT \"bytes\"\n");
    
    fprintf(heap_file, "BEGIN_SAMPLE 0.00\n");
    fprintf(heap_file, "END_SAMPLE 0.00\n");

    
    /* initialise required heap profiling data structures & hashing */
    
    earlier_intervals = (earlier_ticks / interval_ticks) + 1;
    max = (* init_index_fns[heap_prof_style])();
    resid = (I_ *) stgMallocBytes(max * sizeof(I_), "heap_profile_init");

    for (count = 0; count < max; count++)
	resid[count] = 0;
    
    return 0;
}
\end{code}

Cost centre selection is set up before a heap profile by running
through the list of registered cost centres and memoising the
selection in the cost centre record. It is only necessary to memoise
the cost centre selection if a selection profiling function is
being called.

Category selection is determined when each closure is encountered. It
is memoised within the category record. We always have to check that
the memoisation has been done as we do not have a list of categories
we can process before hand.

Age selection is done for every closure -- not memoised.

\begin{code}
void
set_selected_ccs(STG_NO_ARGS)	/* set selection before we profile heap */
{
    I_ x;
    CostCentre cc;

    if (cc_select) {
	for (cc = Registered_CC; cc != REGISTERED_END; cc = cc->registered) {
	    for (x = 0; ! cc->selected && x < cc_select_no; x++)
		cc->selected = (strcmp(cc->label, cc_select_strs[x]) == 0) &&
		               (strcmp(cc->module, ccmod_select_strs[x]) == 0);
	    for (x = 0; ! cc->selected && x < mod_select_no; x++)
		cc->selected = (strcmp(cc->module, mod_select_strs[x]) == 0);
	    for (x = 0; ! cc->selected && x < grp_select_no; x++)
		cc->selected = (strcmp(cc->group, grp_select_strs[x]) == 0);
	}
    } else {
	for (cc = Registered_CC; cc != REGISTERED_END; cc = cc->registered)
	    cc->selected = 1;      /* true if ! cc_select */
    }
}


I_
selected_clcat(ClCategory clcat)
{
    I_ x;

    if (clcat->selected == -1) {     /* if not memoised check selection */
	if (clcat_select) {
	    clcat->selected = 0;
	    for (x = 0; ! clcat->selected && x < descr_select_no; x++)
		clcat->selected = (strcmp(clcat->descr, descr_select_strs[x]) == 0);
	    for (x = 0; ! clcat->selected && x < type_select_no; x++)
		clcat->selected = (strcmp(clcat->type, type_select_strs[x]) == 0);
	    if (kind_select_no) clcat->selected |= kind_selected[clcat->kind];
	} else {
	    clcat->selected = 1;
	}
    }
    return clcat->selected;          /* return memoised selection */
} 
\end{code}


Profiling functions called for each closure. The appropriate function
is stored in @heap_profile_fn@ by @heap_profile_setup@.
@heap_profile_fn@ is called for each live closure by the macros
embedded in the garbage collector. They increment the appropriate
resident space counter by the size of the closure (less any profiling
words).

\begin{code}
#define NON_PROF_HS (FIXED_HS - PROF_FIXED_HDR - TICKY_FIXED_HDR)

void
profile_closure_cc(P_ closure, I_ size)
{
    CostCentre cc = (CostCentre) CC_HDR(closure);
    resid[index_cc(cc)] += size + NON_PROF_HS;
    return;
}

void
profile_closure_cc_select(P_ closure, I_ size)
{
    CostCentre cc; ClCategory clcat;

    cc = (CostCentre) CC_HDR(closure);
    if (! cc->selected)                   /* selection determined before profile */
	return;                           /* all selected if ! cc_select         */

    clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
    if (clcat_select && ! selected_clcat(clcat)) /* selection memoised during profile */
	return;

    resid[index_cc(cc)] += size + NON_PROF_HS;
    return;
}

void
profile_closure_mod(P_ closure, I_ size)
{
    CostCentre cc = (CostCentre) CC_HDR(closure);
    resid[index_mod(cc)] += size + NON_PROF_HS;
    return;
}

void
profile_closure_mod_select(P_ closure, I_ size)
{
    CostCentre cc; ClCategory clcat;

    cc = (CostCentre) CC_HDR(closure);
    if (! cc->selected)                       /* selection determined before profile */
	return;

    clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
    if (clcat_select && ! selected_clcat(clcat)) /* selection memoised during profile */
	return;

    resid[index_mod(cc)] += size + NON_PROF_HS;
    return;
}

void
profile_closure_grp(P_ closure, I_ size)
{
    CostCentre cc = (CostCentre) CC_HDR(closure);
    resid[index_grp(cc)] += size + NON_PROF_HS;
    return;
}

void
profile_closure_grp_select(P_ closure, I_ size)
{
    CostCentre cc; ClCategory clcat;

    cc = (CostCentre) CC_HDR(closure);
    if (! cc->selected)                       /* selection determined before profile */
	return;

    clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
    if (clcat_select && ! selected_clcat(clcat)) /* selection memoised during profile */
	return;

    resid[index_grp(cc)] += size + NON_PROF_HS;
    return;
}

void
profile_closure_descr(P_ closure, I_ size)
{
    ClCategory clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
    resid[index_descr(clcat)] += size + NON_PROF_HS;
    return;
}

void
profile_closure_descr_select(P_ closure, I_ size)
{
    CostCentre cc; ClCategory clcat;

    cc = (CostCentre) CC_HDR(closure);
    if (! cc->selected)                     /* selection determined before profile */
	return;                             /* all selected if ! cc_select         */

    clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
    if (clcat_select && ! selected_clcat(clcat)) /* selection memoised during profile */
	return;

    resid[index_descr(clcat)] += size + NON_PROF_HS;
    return;
}

void
profile_closure_type(P_ closure, I_ size)
{
    ClCategory clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
    resid[index_type(clcat)] += size + NON_PROF_HS;
    return;
}

void
profile_closure_type_select(P_ closure, I_ size)
{
    CostCentre cc; ClCategory clcat;

    cc = (CostCentre) CC_HDR(closure);
    if (! cc->selected)                     /* selection determined before profile */
	return;                             /* all selected if ! cc_select         */

    clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
    if (clcat_select && ! selected_clcat(clcat))  /* selection memoised during profile */
	return;

    resid[index_type(clcat)] += size + NON_PROF_HS;
    return;
}

void
profile_closure_time(P_ closure, I_ size)
{
    return;
}

void
profile_closure_time_select(P_ closure, I_ size)
{
    return;
}
\end{code}

@heap_profile_setup@ is called before garbage collection to initialise
for the profile. It assigns the appropriate closure profiling function
to @heap_profile_fn@ and memoises any cost centre selection. If no
profile is required @heap_profile_fn@ is assigned NULL.

On completion of garbage collection @heap_profile_done@ is called. It
produces a heap profile report and resets the residency counts to 0.

\begin{code}

void (* heap_profile_fn) PROTO((P_,I_)) = NULL;

void (* profiling_fns_select[]) PROTO((P_,I_)) = {
    NULL,
    profile_closure_cc_select,
    profile_closure_mod_select,
    profile_closure_grp_select,
    profile_closure_descr_select,
    profile_closure_type_select,
    profile_closure_time_select
};

void (* profiling_fns[]) PROTO((P_,I_)) = {
    NULL,
    profile_closure_cc,
    profile_closure_mod,
    profile_closure_grp,
    profile_closure_descr,
    profile_closure_type,
    profile_closure_time
};

void
heap_profile_setup(STG_NO_ARGS)      /* called at start of heap profile */
{
    W_ heap_prof_style;

    if (! RTSflags.ProfFlags.doHeapProfile)
	return;

    heap_prof_style = RTSflags.ProfFlags.doHeapProfile;

    if (cc_select || clcat_select) {
	set_selected_ccs();               /* memoise cc selection */
	heap_profile_fn = profiling_fns_select[heap_prof_style];
    } else {
	heap_profile_fn = profiling_fns[heap_prof_style];
    }
}

void
heap_profile_done(STG_NO_ARGS)	  /* called at end of heap profile */
{
    CostCentre cc;
    ClCategory clcat;
    hash_t ind, max;
    StgFloat seconds;
    W_ heap_prof_style;

    if (! RTSflags.ProfFlags.doHeapProfile)
	return;

    heap_prof_style = RTSflags.ProfFlags.doHeapProfile;
    heap_profile_fn = NULL;

    seconds = (previous_ticks + current_ticks) / (StgFloat)TICK_FREQUENCY;
    fprintf(heap_file, "BEGIN_SAMPLE %0.2f\n", seconds);

    max = (* init_index_fns[heap_prof_style])();

    switch (heap_prof_style) {
      case HEAP_BY_CC:
	for (ind = 0; ind < max; ind++) {
	    if ((cc = index_cc_table[ind]) != 0 && ! cc_to_ignore(cc)) {
		fprintf(heap_file, "  %s:%s %ld\n", cc->module, cc->label, resid[ind] * sizeof(W_));
	    }
	    resid[ind] = 0;
	}
	break;

      case HEAP_BY_MOD:
	for (ind = 0; ind < max; ind++) {
	    if ((cc = index_mod_table[ind]) != 0 && ! cc_to_ignore(cc)) {
		fprintf(heap_file, "  %s %ld\n", cc->module, resid[ind] * sizeof(W_));
	    }
	    resid[ind] = 0;
	}
	break;

      case HEAP_BY_GRP:
	for (ind = 0; ind < max; ind++) {
	    if ((cc = index_grp_table[ind]) != 0 && ! cc_to_ignore(cc)) {
		fprintf(heap_file, "  %0.11s %ld\n", cc->group, resid[ind] * sizeof(W_));
	    }
	    resid[ind] = 0;
	}
	break;

      case HEAP_BY_DESCR:
	for (ind = 0; ind < max; ind++) {
	    if ((clcat = index_descr_table[ind]) != 0 && ! cc_to_ignore(cc)) {
		fprintf(heap_file, "  %0.28s %ld\n", clcat->descr, resid[ind] * sizeof(W_));
	    }
	    resid[ind] = 0;
	}
	break;

      case HEAP_BY_TYPE:
	for (ind = 0; ind < max; ind++) {
	    if ((clcat = index_type_table[ind]) != 0 && ! cc_to_ignore(cc)) {
		fprintf(heap_file, "  %0.28s %ld\n", clcat->type, resid[ind] * sizeof(W_));
	    }
	    resid[ind] = 0;
	}
	break;
    }

    fprintf(heap_file, "END_SAMPLE %0.2f\n", seconds);
    fflush(heap_file);
}

void
heap_profile_finish(STG_NO_ARGS)     /* called at end of execution */
{
    StgFloat seconds;

    if (! RTSflags.ProfFlags.doHeapProfile)
	return;

    seconds = (previous_ticks + current_ticks) / (StgFloat)TICK_FREQUENCY;
    fprintf(heap_file, "BEGIN_SAMPLE %0.2f\n", seconds);
    fprintf(heap_file, "END_SAMPLE %0.2f\n", seconds);
    fclose(heap_file);

    return;
}
\end{code}

\begin{code}
#endif /* PROFILING */
\end{code}