path: root/rts/Profiling.c

/* -----------------------------------------------------------------------------
 *
 * (c) The GHC Team, 1998-2000
 *
 * Support for profiling
 *
 * ---------------------------------------------------------------------------*/

#ifdef PROFILING

#include "PosixSource.h"
#include "Rts.h"

#include "RtsUtils.h"
#include "Profiling.h"
#include "Proftimer.h"
#include "ProfHeap.h"
#include "Arena.h"
#include "RetainerProfile.h"

#include <string.h>

#ifdef DEBUG
#include "Trace.h"
#endif

/*
 * Profiling allocation arena.
 */
Arena *prof_arena;

/*
 * Global variables used to assign unique IDs to cc's, ccs's, and 
 * closure_cats
 */

unsigned int CC_ID  = 1;
unsigned int CCS_ID = 1;

/* figures for the profiling report.
 */
static StgWord64 total_alloc;
static lnat      total_prof_ticks;

/* Globals for opening the profiling log file(s)
 */
static char *prof_filename; /* prof report file name = <program>.prof */
FILE *prof_file;

static char *hp_filename;	/* heap profile (hp2ps style) log file */
FILE *hp_file;

/* The Current Cost Centre Stack (for attributing costs)
 */
CostCentreStack *CCCS;

/* Linked lists to keep track of CCs and CCSs that haven't
 * been declared in the log file yet
 */
CostCentre      *CC_LIST  = NULL;
CostCentreStack *CCS_LIST = NULL;

/*
 * Built-in cost centres and cost-centre stacks:
 *
 *    MAIN   is the root of the cost-centre stack tree.  If there are
 *           no _scc_s in the program, all costs will be attributed
 *           to MAIN.
 *
 *    SYSTEM is the RTS in general (scheduler, etc.).  All costs for
 *           RTS operations apart from garbage collection are attributed
 *           to SYSTEM.
 *
 *    GC     is the storage manager / garbage collector.
 *
 *    OVERHEAD gets all costs generated by the profiling system
 *           itself.  These are costs that would not be incurred
 *           during non-profiled execution of the program.
 *
 *    DONT_CARE is a placeholder cost-centre we assign to static
 *           constructors.  It should *never* accumulate any costs.
 */

CC_DECLARE(CC_MAIN,      "MAIN", 	"MAIN",      );
CC_DECLARE(CC_SYSTEM,    "SYSTEM",   	"MAIN",      );
CC_DECLARE(CC_GC,        "GC",   	"GC",        );
CC_DECLARE(CC_OVERHEAD,  "OVERHEAD_of", "PROFILING", );
CC_DECLARE(CC_DONT_CARE, "DONT_CARE",   "MAIN",      );

CCS_DECLARE(CCS_MAIN, 	    CC_MAIN,       );
CCS_DECLARE(CCS_SYSTEM,	    CC_SYSTEM,     );
CCS_DECLARE(CCS_GC,         CC_GC,         );
CCS_DECLARE(CCS_OVERHEAD,   CC_OVERHEAD,   );
CCS_DECLARE(CCS_DONT_CARE,  CC_DONT_CARE,  );

/* 
 * Uniques for the XML log-file format
 */
#define CC_UQ         1
#define CCS_UQ        2
#define TC_UQ         3
#define HEAP_OBJ_UQ   4
#define TIME_UPD_UQ   5
#define HEAP_UPD_UQ   6

/* 
 * Static Functions
 */

static  CostCentreStack * actualPush_     ( CostCentreStack *ccs, CostCentre *cc,
                                            CostCentreStack *new_ccs );
static  rtsBool           ignoreCCS       ( CostCentreStack *ccs );
static  void              countTickss     ( CostCentreStack *ccs );
static  void              inheritCosts    ( CostCentreStack *ccs );
static  void              findCCSMaxLens  ( CostCentreStack *ccs,
                                            nat indent,
                                            nat *max_label_len,
                                            nat *max_module_len );
static  void              logCCS          ( CostCentreStack *ccs,
                                            nat indent,
                                            nat max_label_len,
                                            nat max_module_len );
static  void              reportCCS       ( CostCentreStack *ccs );
static  void              decCCS          ( CostCentreStack *ccs );
static  void              decBackEdge     ( CostCentreStack *ccs,
					    CostCentreStack *oldccs );
static  CostCentreStack * checkLoop       ( CostCentreStack *ccs,
                                            CostCentre *cc );
static  CostCentreStack * pruneCCSTree    ( CostCentreStack *ccs );
static  CostCentreStack * actualPush      ( CostCentreStack *, CostCentre * );
static  CostCentreStack * isInIndexTable  ( IndexTable *, CostCentre * );
static  IndexTable *      addToIndexTable ( IndexTable *, CostCentreStack *,
					    CostCentre *, unsigned int );
static  void              ccsSetSelected  ( CostCentreStack *ccs );

static  void              initTimeProfiling    ( void );
static  void              initProfilingLogFile ( void );

static  void              reportCCSXML    ( CostCentreStack *ccs );

/* -----------------------------------------------------------------------------
   Initialise the profiling environment
   -------------------------------------------------------------------------- */

void
initProfiling1 (void)
{
    // initialise our arena
    prof_arena = newArena();

    /* for the benefit of allocate()... */
    CCCS = CCS_SYSTEM;
}

void
freeProfiling (void)
{
    arenaFree(prof_arena);
}

void
initProfiling2 (void)
{
    CostCentreStack *ccs, *next;

    CCCS = CCS_SYSTEM;

    /* Set up the log file, and dump the header and cost centre
     * information into it.
     */
    initProfilingLogFile();

    /* Register all the cost centres / stacks in the program
     * CC_MAIN gets link = 0, all others have non-zero link.
     */
    REGISTER_CC(CC_MAIN);
    REGISTER_CC(CC_SYSTEM);
    REGISTER_CC(CC_GC);
    REGISTER_CC(CC_OVERHEAD);
    REGISTER_CC(CC_DONT_CARE);

    REGISTER_CCS(CCS_SYSTEM);
    REGISTER_CCS(CCS_GC);
    REGISTER_CCS(CCS_OVERHEAD);
    REGISTER_CCS(CCS_DONT_CARE);
    REGISTER_CCS(CCS_MAIN);

    /* find all the registered cost centre stacks, and make them
     * children of CCS_MAIN.
     */
    ASSERT(CCS_LIST == CCS_MAIN);
    CCS_LIST = CCS_LIST->prevStack;
    CCS_MAIN->prevStack = NULL;
    ccsSetSelected(CCS_MAIN);
    decCCS(CCS_MAIN);

    for (ccs = CCS_LIST; ccs != NULL; ) {
        next = ccs->prevStack;
        ccs->prevStack = NULL;
        actualPush_(CCS_MAIN,ccs->cc,ccs);
        ccs = next;
    }

    if (RtsFlags.CcFlags.doCostCentres) {
        initTimeProfiling();
    }

    if (RtsFlags.ProfFlags.doHeapProfile) {
        initHeapProfiling();
    }
}


static void
initProfilingLogFile(void)
{
    char *prog;

    prog = arenaAlloc(prof_arena, strlen(prog_name) + 1);
    strcpy(prog, prog_name);
#ifdef mingw32_HOST_OS
    // on Windows, drop the .exe suffix if there is one
    {
        char *suff;
        suff = strrchr(prog,'.');
        if (suff != NULL && !strcmp(suff,".exe")) {
            *suff = '\0';
        }
    }
#endif

    if (RtsFlags.CcFlags.doCostCentres == 0 && 
        RtsFlags.ProfFlags.doHeapProfile != HEAP_BY_RETAINER)
    {
        /* No need for the <prog>.prof file */
        prof_filename = NULL;
        prof_file = NULL;
    }
    else
    {
        /* Initialise the log file name */
        prof_filename = arenaAlloc(prof_arena, strlen(prog) + 6);
        sprintf(prof_filename, "%s.prof", prog);

        /* open the log file */
        if ((prof_file = fopen(prof_filename, "w")) == NULL) {
            debugBelch("Can't open profiling report file %s\n", prof_filename);
            RtsFlags.CcFlags.doCostCentres = 0;
            // The following line was added by Sung; retainer/LDV profiling may need
            // two output files, i.e., <program>.prof/hp.
            if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_RETAINER)
                RtsFlags.ProfFlags.doHeapProfile = 0;
            return;
        }

        if (RtsFlags.CcFlags.doCostCentres == COST_CENTRES_XML) {
            /* dump the time, and the profiling interval */
            fprintf(prof_file, "\"%s\"\n", time_str());
            fprintf(prof_file, "\"%d ms\"\n", RtsFlags.MiscFlags.tickInterval);
            
            /* declare all the cost centres */
            {
                CostCentre *cc;
                for (cc = CC_LIST; cc != NULL; cc = cc->link) {
                    fprintf(prof_file, "%d %ld \"%s\" \"%s\"\n",
                            CC_UQ, cc->ccID, cc->label, cc->module);
                }
            }
        }
    }
    
    if (RtsFlags.ProfFlags.doHeapProfile) {
	/* Initialise the log file name */
	hp_filename = arenaAlloc(prof_arena, strlen(prog) + 6);
	sprintf(hp_filename, "%s.hp", prog);

	/* open the log file */
	if ((hp_file = fopen(hp_filename, "w")) == NULL) {
	    debugBelch("Can't open profiling report file %s\n", 
		    hp_filename);
	    RtsFlags.ProfFlags.doHeapProfile = 0;
	    return;
	}
    }
}

void
initTimeProfiling(void)
{
    /* Start ticking */
    startProfTimer();
};

void 
endProfiling ( void )
{
    if (RtsFlags.CcFlags.doCostCentres) {
        stopProfTimer();
    }
    if (RtsFlags.ProfFlags.doHeapProfile) {
        endHeapProfiling();
    }
}

/* -----------------------------------------------------------------------------
   Decide whether closures with this CCS should contribute to the heap
   profile.
   -------------------------------------------------------------------------- */

static void
ccsSetSelected (CostCentreStack *ccs)
{
    if (RtsFlags.ProfFlags.modSelector) {
        if (! strMatchesSelector (ccs->cc->module,
                                  RtsFlags.ProfFlags.modSelector) ) {
	    ccs->selected = 0;
            return;
        }
    }
    if (RtsFlags.ProfFlags.ccSelector) {
        if (! strMatchesSelector (ccs->cc->label,
                                  RtsFlags.ProfFlags.ccSelector) ) {
	    ccs->selected = 0;
            return;
        }
    }
    if (RtsFlags.ProfFlags.ccsSelector) {
	CostCentreStack *c;
        for (c = ccs; c != NULL; c = c->prevStack)
        {
            if ( strMatchesSelector (c->cc->label,
                                     RtsFlags.ProfFlags.ccsSelector) ) {
		break; 
	    }
	}
        if (c == NULL) {
            ccs->selected = 0;
            return;
        }
    }

    ccs->selected = 1;
    return;
}

/* -----------------------------------------------------------------------------
   Cost-centre stack manipulation
   -------------------------------------------------------------------------- */

#ifdef DEBUG
CostCentreStack * _pushCostCentre ( CostCentreStack *ccs, CostCentre *cc );
CostCentreStack *
pushCostCentre ( CostCentreStack *ccs, CostCentre *cc )
#define pushCostCentre _pushCostCentre
{
    IF_DEBUG(prof,
	     traceBegin("pushing %s on ", cc->label);
	     debugCCS(ccs);
	     traceEnd(););
	     
    return pushCostCentre(ccs,cc);
}
#endif

// Pick one:
#define RECURSION_DROPS
// #define RECURSION_TRUNCATES

CostCentreStack *
pushCostCentre (CostCentreStack *ccs, CostCentre *cc)
{
    CostCentreStack *temp_ccs;
  
    if (ccs == EMPTY_STACK)
        return actualPush(ccs,cc);
    else {
        if (ccs->cc == cc)
            return ccs;
        else {
            // check if we've already memoized this stack
            temp_ccs = isInIndexTable(ccs->indexTable,cc);
      
            if (temp_ccs != EMPTY_STACK)
                return temp_ccs;
            else {
                temp_ccs = checkLoop(ccs,cc);
                if (temp_ccs != NULL) {
                    // This CC is already in the stack somewhere.
                    // This could be recursion, or just calling
                    // another function with the same CC.
                    // A number of policies are possible at this
                    // point, we implement two here:
                    //   - truncate the stack to the previous instance
                    //     of this CC
                    //   - ignore this push, return the same stack.
                    //
                    CostCentreStack *new_ccs;
#if defined(RECURSION_TRUNCATES)
                    new_ccs = temp_ccs;
#else // defined(RECURSION_DROPS)
                    new_ccs = ccs;
#endif
                    ccs->indexTable = addToIndexTable (ccs->indexTable,
                                                       new_ccs, cc, 1);
                    decBackEdge(new_ccs,ccs);
                    return new_ccs;
                } else {
                    return actualPush (ccs,cc);
                }
            }
        }
    }
}

static CostCentreStack *
checkLoop (CostCentreStack *ccs, CostCentre *cc)
{
    while (ccs != EMPTY_STACK) {
        if (ccs->cc == cc)
            return ccs;
        ccs = ccs->prevStack;
    }
    return NULL;
}

static CostCentreStack *
actualPush (CostCentreStack *ccs, CostCentre *cc)
{
    CostCentreStack *new_ccs;

    // allocate space for a new CostCentreStack
    new_ccs = (CostCentreStack *) arenaAlloc(prof_arena, sizeof(CostCentreStack));

    return actualPush_(ccs, cc, new_ccs);
}

static CostCentreStack *
actualPush_ (CostCentreStack *ccs, CostCentre *cc, CostCentreStack *new_ccs)
{
    /* assign values to each member of the structure */
    new_ccs->ccsID = CCS_ID++;
    new_ccs->cc = cc;
    new_ccs->prevStack = ccs;

    new_ccs->indexTable = EMPTY_TABLE;

    /* Initialise the various _scc_ counters to zero
     */
    new_ccs->scc_count        = 0;

    /* Initialize all other stats here.  There should be a quick way
     * that's easily used elsewhere too
     */
    new_ccs->time_ticks = 0;
    new_ccs->mem_alloc = 0;
    new_ccs->inherited_ticks = 0;
    new_ccs->inherited_alloc = 0;

    // Set the selected field.
    ccsSetSelected(new_ccs);

    /* update the memoization table for the parent stack */
    if (ccs != EMPTY_STACK) {
        ccs->indexTable = addToIndexTable(ccs->indexTable, new_ccs, cc,
                                          0/*not a back edge*/);
    }

    /* make sure this CC is declared at the next heap/time sample */
    decCCS(new_ccs);

    /* return a pointer to the new stack */
    return new_ccs;
}


static CostCentreStack *
isInIndexTable(IndexTable *it, CostCentre *cc)
{
    while (it!=EMPTY_TABLE)
    {
        if (it->cc == cc)
            return it->ccs;
        else
            it = it->next;
    }
  
    /* otherwise we never found it so return EMPTY_TABLE */
    return EMPTY_TABLE;
}


static IndexTable *
addToIndexTable (IndexTable *it, CostCentreStack *new_ccs,
                 CostCentre *cc, unsigned int back_edge)
{
    IndexTable *new_it;

    new_it = arenaAlloc(prof_arena, sizeof(IndexTable));

    new_it->cc = cc;
    new_it->ccs = new_ccs;
    new_it->next = it;
    new_it->back_edge = back_edge;
    return new_it;
}


static void
decCCS(CostCentreStack *ccs)
{
    if (prof_file && RtsFlags.CcFlags.doCostCentres == COST_CENTRES_XML) {
        if (ccs->prevStack == EMPTY_STACK)
            fprintf(prof_file, "%d %ld 1 %ld\n", CCS_UQ,
                    ccs->ccsID, ccs->cc->ccID);
        else
            fprintf(prof_file, "%d %ld 2 %ld %ld\n", CCS_UQ,
                    ccs->ccsID, ccs->cc->ccID, ccs->prevStack->ccsID);
    }
}

static void
decBackEdge( CostCentreStack *ccs, CostCentreStack *oldccs )
{
    if (prof_file && RtsFlags.CcFlags.doCostCentres == COST_CENTRES_XML) {
        if (ccs->prevStack == EMPTY_STACK)
            fprintf(prof_file, "%d %ld 1 %ld\n", CCS_UQ,
                    ccs->ccsID, ccs->cc->ccID);
        else
            fprintf(prof_file, "%d %ld 2 %ld %ld\n", CCS_UQ,
                    ccs->ccsID, ccs->cc->ccID, oldccs->ccsID);
    }
}

/* -----------------------------------------------------------------------------
   Generating a time & allocation profiling report.
   -------------------------------------------------------------------------- */

/* We omit certain system-related CCs and CCSs from the default
 * reports, so as not to cause confusion.
 */
static rtsBool
ignoreCC (CostCentre *cc)
{
    if (RtsFlags.CcFlags.doCostCentres < COST_CENTRES_ALL &&
        (   cc == CC_OVERHEAD
	 || cc == CC_DONT_CARE
	 || cc == CC_GC 
         || cc == CC_SYSTEM)) {
	return rtsTrue;
    } else {
	return rtsFalse;
    }
}

static rtsBool
ignoreCCS (CostCentreStack *ccs)
{
    if (RtsFlags.CcFlags.doCostCentres < COST_CENTRES_ALL &&
        (   ccs == CCS_OVERHEAD
         || ccs == CCS_DONT_CARE
         || ccs == CCS_GC
         || ccs == CCS_SYSTEM)) {
        return rtsTrue;
    } else {
	return rtsFalse;
    }
}

/* -----------------------------------------------------------------------------
   Generating the aggregated per-cost-centre time/alloc report.
   -------------------------------------------------------------------------- */

static CostCentre *sorted_cc_list;

static void
aggregateCCCosts( CostCentreStack *ccs )
{
    IndexTable *i;

    ccs->cc->mem_alloc += ccs->mem_alloc;
    ccs->cc->time_ticks += ccs->time_ticks;

    for (i = ccs->indexTable; i != 0; i = i->next) {
        if (!i->back_edge) {
            aggregateCCCosts(i->ccs);
        }
    }
}

static void
insertCCInSortedList( CostCentre *new_cc )
{
    CostCentre **prev, *cc;

    prev = &sorted_cc_list;
    for (cc = sorted_cc_list; cc != NULL; cc = cc->link) {
        if (new_cc->time_ticks > cc->time_ticks) {
            new_cc->link = cc;
            *prev = new_cc;
            return;
        } else {
            prev = &(cc->link);
        }
    }
    new_cc->link = NULL;
    *prev = new_cc;
}

static void
reportPerCCCosts( void )
{
    CostCentre *cc, *next;
    nat max_label_len, max_module_len;

    aggregateCCCosts(CCS_MAIN);
    sorted_cc_list = NULL;

    max_label_len  = 11; // no shorter than the "COST CENTRE" header
    max_module_len = 7;  // no shorter than the "MODULE" header

    for (cc = CC_LIST; cc != NULL; cc = next) {
        next = cc->link;
        if (cc->time_ticks > total_prof_ticks/100
            || cc->mem_alloc > total_alloc/100
            || RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_ALL) {
            insertCCInSortedList(cc);

            max_label_len = stg_max(strlen(cc->label), max_label_len);
            max_module_len = stg_max(strlen(cc->module), max_module_len);
        }
    }

    fprintf(prof_file, "%-*s %-*s", max_label_len, "COST CENTRE", max_module_len, "MODULE");
    fprintf(prof_file, "%6s %6s", "%time", "%alloc");
    if (RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE) {
        fprintf(prof_file, "  %5s %9s", "ticks", "bytes");
    }
    fprintf(prof_file, "\n\n");

    for (cc = sorted_cc_list; cc != NULL; cc = cc->link) {
        if (ignoreCC(cc)) {
            continue;
        }
        fprintf(prof_file, "%-*s %-*s", max_label_len, cc->label, max_module_len, cc->module);
        fprintf(prof_file, "%6.1f %6.1f",
                total_prof_ticks == 0 ? 0.0 : (cc->time_ticks / (StgFloat) total_prof_ticks * 100),
                total_alloc == 0 ? 0.0 : (cc->mem_alloc / (StgFloat)
                                          total_alloc * 100)
            );

        if (RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE) {
            fprintf(prof_file, "  %5" FMT_Word64 " %9" FMT_Word64,
                    (StgWord64)(cc->time_ticks), cc->mem_alloc*sizeof(W_));
        }
        fprintf(prof_file, "\n");
    }

    fprintf(prof_file,"\n\n");
}

/* -----------------------------------------------------------------------------
   Generate the cost-centre-stack time/alloc report
   -------------------------------------------------------------------------- */

static void 
fprintHeader( nat max_label_len, nat max_module_len )
{
    fprintf(prof_file, "%-*s %-*s%6s %11s  %11s   %11s\n", max_label_len, "", max_module_len, "", "", "", "individual", "inherited");

    fprintf(prof_file, "%-*s %-*s", max_label_len, "COST CENTRE", max_module_len, "MODULE");
    fprintf(prof_file, "%6s %11s  %5s %5s   %5s %5s", "no.", "entries", "%time", "%alloc", "%time", "%alloc");

    if (RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE) {
        fprintf(prof_file, "  %5s %9s", "ticks", "bytes");
    }

    fprintf(prof_file, "\n\n");
}

void
reportCCSProfiling( void )
{
    nat count;
    char temp[128]; /* sigh: magic constant */
    
    stopProfTimer();

    total_prof_ticks = 0;
    total_alloc = 0;
    countTickss(CCS_MAIN);
    
    switch (RtsFlags.CcFlags.doCostCentres) {
    case 0:
      return;
    case COST_CENTRES_XML:
      genXMLLogfile();
      return;
    default:
      break;
    }

    fprintf(prof_file, "\t%s Time and Allocation Profiling Report  (%s)\n", 
	    time_str(), "Final");

    fprintf(prof_file, "\n\t  ");
    fprintf(prof_file, " %s", prog_name);
    fprintf(prof_file, " +RTS");
    for (count = 0; rts_argv[count]; count++)
	fprintf(prof_file, " %s", rts_argv[count]);
    fprintf(prof_file, " -RTS");
    for (count = 1; prog_argv[count]; count++)
	fprintf(prof_file, " %s", prog_argv[count]);
    fprintf(prof_file, "\n\n");

    fprintf(prof_file, "\ttotal time  = %11.2f secs   (%lu ticks @ %d ms)\n",
	    (double) total_prof_ticks *
        (double) RtsFlags.MiscFlags.tickInterval / 1000,
	    (unsigned long) total_prof_ticks,
        (int) RtsFlags.MiscFlags.tickInterval);

    fprintf(prof_file, "\ttotal alloc = %11s bytes",
	    showStgWord64(total_alloc * sizeof(W_),
				 temp, rtsTrue/*commas*/));

    fprintf(prof_file, "  (excludes profiling overheads)\n\n");

    reportPerCCCosts();

    inheritCosts(CCS_MAIN);

    reportCCS(pruneCCSTree(CCS_MAIN));
}

static void 
findCCSMaxLens(CostCentreStack *ccs, nat indent, nat *max_label_len, nat *max_module_len) {
    CostCentre *cc;
    IndexTable *i;

    cc = ccs->cc;

    *max_label_len = stg_max(*max_label_len, indent + strlen(cc->label));
    *max_module_len = stg_max(*max_module_len, strlen(cc->module));

    for (i = ccs->indexTable; i != 0; i = i->next) {
        if (!i->back_edge) {
            findCCSMaxLens(i->ccs, indent+1, max_label_len, max_module_len);
        }
    }
}

static void 
logCCS(CostCentreStack *ccs, nat indent, nat max_label_len, nat max_module_len)
{
    CostCentre *cc;
    IndexTable *i;

    cc = ccs->cc;

    /* Only print cost centres with non 0 data ! */

    if (!ignoreCCS(ccs))
        /* force printing of *all* cost centres if -Pa */
    {

        fprintf(prof_file, "%-*s%-*s %-*s",
                indent, "", max_label_len-indent, cc->label, max_module_len, cc->module);

        fprintf(prof_file, "%6ld %11d  %5.1f  %5.1f   %5.1f  %5.1f",
            ccs->ccsID, ccs->scc_count,
                total_prof_ticks == 0 ? 0.0 : ((double)ccs->time_ticks / (double)total_prof_ticks * 100.0),
                total_alloc == 0 ? 0.0 : ((double)ccs->mem_alloc / (double)total_alloc * 100.0),
                total_prof_ticks == 0 ? 0.0 : ((double)ccs->inherited_ticks / (double)total_prof_ticks * 100.0),
                total_alloc == 0 ? 0.0 : ((double)ccs->inherited_alloc / (double)total_alloc * 100.0)
	    );

        if (RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE) {
            fprintf(prof_file, "  %5" FMT_Word64 " %9" FMT_Word64,
                    (StgWord64)(ccs->time_ticks), ccs->mem_alloc*sizeof(W_));
        }
        fprintf(prof_file, "\n");
    }

    for (i = ccs->indexTable; i != 0; i = i->next) {
        if (!i->back_edge) {
            logCCS(i->ccs, indent+1, max_label_len, max_module_len);
        }
    }
}

static void
reportCCS(CostCentreStack *ccs)
{
    nat max_label_len, max_module_len;

    max_label_len = 11; // no shorter than "COST CENTRE" header
    max_module_len = 7; // no shorter than "MODULE" header

    findCCSMaxLens(ccs, 0, &max_label_len, &max_module_len);

    fprintHeader(max_label_len, max_module_len);
    logCCS(ccs, 0, max_label_len, max_module_len);
}


/* Traverse the cost centre stack tree and accumulate
 * ticks/allocations.
 */
static void
countTickss(CostCentreStack *ccs)
{
    IndexTable *i;

    if (!ignoreCCS(ccs)) {
        total_alloc += ccs->mem_alloc;
        total_prof_ticks += ccs->time_ticks;
    }
    for (i = ccs->indexTable; i != NULL; i = i->next)
        if (!i->back_edge) {
            countTickss(i->ccs);
        }
}

/* Traverse the cost centre stack tree and inherit ticks & allocs.
 */
static void
inheritCosts(CostCentreStack *ccs)
{
    IndexTable *i;

    if (ignoreCCS(ccs)) { return; }

    ccs->inherited_ticks += ccs->time_ticks;
    ccs->inherited_alloc += ccs->mem_alloc;

    for (i = ccs->indexTable; i != NULL; i = i->next)
        if (!i->back_edge) {
            inheritCosts(i->ccs);
            ccs->inherited_ticks += i->ccs->inherited_ticks;
            ccs->inherited_alloc += i->ccs->inherited_alloc;
        }

    return;
}

//
// Prune CCSs with zero entries, zero ticks or zero allocation from
// the tree, unless COST_CENTRES_ALL is on.
//
static CostCentreStack *
pruneCCSTree (CostCentreStack *ccs)
{
    CostCentreStack *ccs1;
    IndexTable *i, **prev;

    prev = &ccs->indexTable;
    for (i = ccs->indexTable; i != 0; i = i->next) {
        if (i->back_edge) { continue; }

        ccs1 = pruneCCSTree(i->ccs);
        if (ccs1 == NULL) {
            *prev = i->next;
        } else {
            prev = &(i->next);
        }
    }

    if ( (RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_ALL
          /* force printing of *all* cost centres if -P -P */ )

         || ( ccs->indexTable != 0 )
         || ( ccs->scc_count || ccs->time_ticks || ccs->mem_alloc )
        ) {
        return ccs;
    } else {
        return NULL;
    }
}

/* -----------------------------------------------------------------------------
   Generate the XML time/allocation profile
   -------------------------------------------------------------------------- */

void
genXMLLogfile( void )
{
    fprintf(prof_file, "%d %lu", TIME_UPD_UQ, total_prof_ticks);

    reportCCSXML(pruneCCSTree(CCS_MAIN));

    fprintf(prof_file, " 0\n");
}

static void 
reportCCSXML(CostCentreStack *ccs)
{
    CostCentre *cc;
    IndexTable *i;

    if (ignoreCCS(ccs)) { return; }

    cc = ccs->cc;

    fprintf(prof_file, " 1 %ld %" FMT_Word64 " %" FMT_Word64 " %" FMT_Word64,
            ccs->ccsID, ccs->scc_count, (StgWord64)(ccs->time_ticks), ccs->mem_alloc);

    for (i = ccs->indexTable; i != 0; i = i->next) {
        if (!i->back_edge) {
            reportCCSXML(i->ccs);
        }
    }
}

void
fprintCCS( FILE *f, CostCentreStack *ccs )
{
    fprintf(f,"<");
    for (; ccs && ccs != CCS_MAIN; ccs = ccs->prevStack ) {
        fprintf(f,"%s.%s", ccs->cc->module, ccs->cc->label);
        if (ccs->prevStack && ccs->prevStack != CCS_MAIN) {
            fprintf(f,",");
        }
    }
    fprintf(f,">");
}

/* For calling from .cmm code, where we can't reliably refer to stderr */
void
fprintCCS_stderr( CostCentreStack *ccs )
{
    fprintCCS(stderr, ccs);
}

#ifdef DEBUG
void
debugCCS( CostCentreStack *ccs )
{
    debugBelch("<");
    for (; ccs && ccs != CCS_MAIN; ccs = ccs->prevStack ) {
        debugBelch("%s.%s", ccs->cc->module, ccs->cc->label);
        if (ccs->prevStack && ccs->prevStack != CCS_MAIN) {
            debugBelch(",");
        }
    }
    debugBelch(">");
}
#endif /* DEBUG */

#endif /* PROFILING */