path: root/ghc/rts/Profiling.c

/* -----------------------------------------------------------------------------
 * $Id: Profiling.c,v 1.2 1998/12/02 13:28:35 simonm Exp $
 *
 * (c) The GHC Team, 1998
 *
 * Support for profiling
 *
 * ---------------------------------------------------------------------------*/

#ifdef PROFILING

#include "Rts.h"
#include "RtsUtils.h"
#include "RtsFlags.h"
#include "ProfRts.h"
#include "StgRun.h"
#include "StgStartup.h"
#include "Storage.h"
#include "Proftimer.h"
#include "Itimer.h"

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

unsigned int CC_ID;
unsigned int CCS_ID;
unsigned int HP_ID;

/* Table sizes from old profiling system.  Not sure if we'll need
 * these.
 */
nat time_intervals = 0;
nat earlier_ticks  = 0;
nat max_cc_no      = 0;
nat max_mod_no     = 0;
nat max_grp_no     = 0;
nat max_descr_no   = 0;
nat max_type_no    = 0;

/* Are we time-profiling?
 */
rtsBool time_profiling = rtsFalse;

/* figures for the profiling report.
 */
static lnat total_alloc, total_ticks;

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

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

/* Linked lists to keep track of cc's and ccs's that haven't
 * been declared in the log file yet
 */
CostCentre *CC_LIST;
CostCentreStack *CCS_LIST;
CCSDecList *New_CCS_LIST;

/*
 * 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.
 *
 *    SUBSUMED is the one-and-only CCS placed on top-level functions. 
 *           It indicates that all costs are to be attributed to the
 *           enclosing cost centre stack.  SUBSUMED never accumulates
 *           any costs.
 *
 *    DONT_CARE is a placeholder cost-centre we assign to static
 *           constructors.  It should *never* accumulate any costs.
 */

CC_DECLARE(CC_MAIN,      "MAIN", 	"MAIN",      "MAIN",  CC_IS_BORING,);
CC_DECLARE(CC_SYSTEM,    "SYSTEM",   	"MAIN",      "MAIN",  CC_IS_BORING,);
CC_DECLARE(CC_GC,        "GC",   	"GC",        "GC",    CC_IS_BORING,);
CC_DECLARE(CC_OVERHEAD,  "OVERHEAD_of", "PROFILING", "PROFILING", CC_IS_CAF,);
CC_DECLARE(CC_SUBSUMED,  "SUBSUMED",    "MAIN",      "MAIN",  CC_IS_SUBSUMED,);
CC_DECLARE(CC_DONTZuCARE,"DONT_CARE",   "MAIN",      "MAIN",  CC_IS_BORING,);

CCS_DECLARE(CCS_MAIN, 	    CC_MAIN,       CC_IS_BORING,   );
CCS_DECLARE(CCS_SYSTEM,	    CC_SYSTEM,     CC_IS_BORING,   );
CCS_DECLARE(CCS_GC,         CC_GC,         CC_IS_BORING,   );
CCS_DECLARE(CCS_OVERHEAD,   CC_OVERHEAD,   CC_IS_CAF,      );
CCS_DECLARE(CCS_SUBSUMED,   CC_SUBSUMED,   CC_IS_SUBSUMED, );
CCS_DECLARE(CCS_DONTZuCARE, CC_DONTZuCARE, CC_IS_BORING,   );

/* 
 * Static Functions
 */

static CostCentreStack * ActualPush_ ( CostCentreStack *ccs, CostCentre *cc, 
				       CostCentreStack *new_ccs );

static    void registerCostCentres ( void );
static rtsBool ccs_to_ignore       ( CostCentreStack *ccs );
static    void count_ticks         ( CostCentreStack *ccs );
static    void reportCCS           ( CostCentreStack *ccs, nat indent );
static    void DecCCS              ( CostCentreStack *ccs );

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

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

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

  if (!RtsFlags.CcFlags.doCostCentres)
    return;
  
  time_profiling = rtsTrue;

  /* Initialise the log file name */
  prof_filename = stgMallocBytes(strlen(prog_argv[0]) + 6, "initProfiling");
  sprintf(prof_filename, "%s.prof", prog_argv[0]);

  /* Initialize counters for IDs */
  CC_ID  = 0;
  CCS_ID = 0;
  HP_ID  = 0;
  
  /* Initialize Declaration lists to NULL */
  CC_LIST  = NULL;
  CCS_LIST = NULL;

  /* 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_SUBSUMED);
  REGISTER_CC(CC_DONTZuCARE);
  REGISTER_CCS(CCS_MAIN);
  REGISTER_CCS(CCS_SYSTEM);
  REGISTER_CCS(CCS_GC);
  REGISTER_CCS(CCS_OVERHEAD);
  REGISTER_CCS(CCS_SUBSUMED);
  REGISTER_CCS(CCS_DONTZuCARE);

  CCCS = CCS_OVERHEAD;
  registerCostCentres();

  /* find all the "special" cost centre stacks, and make them children
   * of CCS_MAIN.
   */
  ASSERT(CCS_MAIN->prevStack == 0);
  for (ccs = CCS_LIST; ccs != CCS_MAIN; ) {
    next = ccs->prevStack;
    ccs->prevStack = 0;
    ActualPush_(CCS_MAIN,ccs->cc,ccs);
    ccs = next;
  }
  
  /* profiling is the only client of the VTALRM system at the moment,
   * so just install the profiling tick handler. */
  install_vtalrm_handler(handleProfTick);
  startProfTimer();
};

void 
endProfiling ( void )
{
  stopProfTimer();
}

void
heapCensus ( bdescr *bd )
{
  /* nothing yet */
}

/* -----------------------------------------------------------------------------
   Register Cost Centres

   At the moment, this process just supplies a unique integer to each
   statically declared cost centre and cost centre stack in the
   program.

   The code generator inserts a small function "reg<moddule>" in each
   module which registers any cost centres from that module and calls
   the registration functions in each of the modules it imports.  So,
   if we call "regMain", each reachable module in the program will be
   registered. 

   The reg* functions are compiled in the same way as STG code,
   i.e. without normal C call/return conventions.  Hence we must use
   StgRun to call this stuff.
   -------------------------------------------------------------------------- */

/* The registration functions use an explicit stack... 
 */
#define REGISTER_STACK_SIZE  (BLOCK_SIZE * 4)
F_ *register_stack;

static void
registerCostCentres ( void )
{
  /* this storage will be reclaimed by the garbage collector,
   * as a large block.
   */
  register_stack = (F_ *)allocate(REGISTER_STACK_SIZE / sizeof(W_));

  StgRun((StgFunPtr)stg_register);
}


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

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 {
	/* remove the CC to avoid loops */
	ccs = RemoveCC(ccs,cc);
	/* have a different stack now, need to check the memo table again */
	temp_ccs = IsInIndexTable(ccs->indexTable,cc);
	if (temp_ccs != EMPTY_STACK)
	  return temp_ccs;
	else
	  return ActualPush(ccs,cc);
      }
    }
  }
}


CostCentreStack *
ActualPush ( CostCentreStack *ccs, CostCentre *cc )
{
  CostCentreStack *new_ccs;
  
  /* allocate space for a new CostCentreStack */
  new_ccs = (CostCentreStack *) stgMallocBytes(sizeof(CostCentreStack), "Error allocating space for 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 */
  ASSIGN_CCS_ID(new_ccs->ccsID);
  
  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;
  new_ccs->sub_scc_count    = 0;
  new_ccs->sub_cafcc_count  = 0;
  new_ccs->sub_dictcc_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;
  
  /* stacks are subsumed only if their top CostCentres are subsumed */
  new_ccs->is_subsumed = cc->is_subsumed;
  
  /* update the memoization table for the parent stack */
  if (ccs != EMPTY_STACK)
    ccs->indexTable = AddToIndexTable(ccs->indexTable, new_ccs, cc);
  
  /* make sure this CC is decalred at the next heap/time sample */
  DecCCS(new_ccs);
  
  /* return a pointer to the new stack */
  return new_ccs;
}


CostCentreStack *
RemoveCC(CostCentreStack *ccs, CostCentre *cc)
{
  CostCentreStack *del_ccs;
  
  if (ccs == EMPTY_STACK) {
    return EMPTY_STACK;
  } else {
    if (ccs->cc == cc) {
      return ccs->prevStack;
    } else {
      {
	del_ccs = RemoveCC(ccs->prevStack, cc);	
	
	if (del_ccs == EMPTY_STACK)
	  return ccs;
	else
	  return PushCostCentre(del_ccs,ccs->cc);
      }
    }
  }
}


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;
}


IndexTable *
AddToIndexTable(IndexTable *it, CostCentreStack *new_ccs, CostCentre *cc)
{
  IndexTable *new_it;
  
  new_it = stgMallocBytes(sizeof(IndexTable), "AddToIndexTable");
  
  new_it->cc = cc;
  new_it->ccs = new_ccs;
  new_it->next = it;
  return new_it;
}


void
print_ccs (FILE *fp, CostCentreStack *ccs)
{
  if (ccs == CCCS) {
    fprintf(fp, "Cost-Centre Stack: ");
  }
  
  if (ccs != CCS_MAIN)
    {
      print_ccs(fp, ccs->prevStack);
      fprintf(fp, "->[%s,%s,%s]", 
	      ccs->cc->label, ccs->cc->module, ccs->cc->group);
    } else {
      fprintf(fp, "[%s,%s,%s]", 
	      ccs->cc->label, ccs->cc->module, ccs->cc->group);
    }
      
  if (ccs == CCCS) {
    fprintf(fp, "\n");
  }
}


static void
DecCCS(CostCentreStack *ccs)
{
   CCSDecList *temp_list;
	
   temp_list = 
     (CCSDecList *) stgMallocBytes(sizeof(CCSDecList), 
				   "Error allocating space for CCSDecList");
   temp_list->ccs = ccs;
   temp_list->nextList = New_CCS_LIST;
   
   New_CCS_LIST = temp_list;
}

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

static FILE *prof_file;

void
report_ccs_profiling( void )
{
    nat count;
    char temp[128]; /* sigh: magic constant */
    rtsBool do_groups = rtsFalse;

    if (!RtsFlags.CcFlags.doCostCentres)
	return;

    stopProfTimer();

    total_ticks = 0;
    total_alloc = 0;
    count_ticks(CCS_MAIN);
    
    /* open profiling output file */
    if ((prof_file = fopen(prof_filename, "w")) == NULL) {
	fprintf(stderr, "Can't open profiling report file %s\n", prof_filename);
	return;
    }
    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_argv[0]);
    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",
	    total_ticks / (StgFloat) TICK_FREQUENCY, 
	    total_ticks, TICK_MILLISECS);

    fprintf(prof_file, "\ttotal alloc = %11s bytes",
	    ullong_format_string((ullong) total_alloc * sizeof(W_),
				 temp, rtsTrue/*commas*/));
    /* ToDo: 64-bit error! */

#if defined(PROFILING_DETAIL_COUNTS)
    fprintf(prof_file, "  (%lu closures)", total_allocs);
#endif
    fprintf(prof_file, "  (excludes profiling overheads)\n\n");

    fprintf(prof_file, "%-24s %-10s", "COST CENTRE", "MODULE");

#ifdef NOT_YET
    do_groups = have_interesting_groups(Registered_CC);
    if (do_groups) fprintf(prof_file, " %-11.11s", "GROUP");
#endif

    fprintf(prof_file, "%8s %5s %5s %8s %5s %5s", "scc", "%time", "%alloc", "inner", "cafs", "dicts");

    if (RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE) {
	fprintf(prof_file, "  %5s %9s", "ticks", "bytes");
#if defined(PROFILING_DETAIL_COUNTS)
	fprintf(prof_file, "  %8s %8s %8s %8s %8s %8s %8s",
		"closures", "thunks", "funcs", "PAPs", "subfuns", "subcafs", "cafssub");
#endif
    }
    fprintf(prof_file, "\n\n");

    reportCCS(CCS_MAIN, 0);

    fclose(prof_file);
}

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

  cc = ccs->cc;
  ASSERT(cc == CC_MAIN || cc->link != 0);
  
  /* Only print cost centres with non 0 data ! */
  
  if ( (RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_ALL
	/* force printing of *all* cost centres if -P -P */ )
       
       || ( ccs->indexTable != 0 )
       || ( ! ccs_to_ignore(ccs)
	    && (ccs->scc_count || ccs->sub_scc_count || 
		ccs->time_ticks || ccs->mem_alloc
	    || (RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE
		&& (ccs->sub_cafcc_count || ccs->sub_dictcc_count
#if defined(PROFILING_DETAIL_COUNTS)
		|| cc->thunk_count || cc->function_count || cc->pap_count
#endif
		    ))))) {
    fprintf(prof_file, "%-*s%-*s %-10s", 
	    indent, "", 24-indent, cc->label, cc->module);

#ifdef NOT_YET
    if (do_groups) fprintf(prof_file, " %-11.11s",cc->group);
#endif

    fprintf(prof_file, "%8ld  %4.1f  %4.1f %8ld %5ld %5ld",
	    ccs->scc_count, 
	    total_ticks == 0 ? 0.0 : (ccs->time_ticks / (StgFloat) total_ticks * 100),
	    total_alloc == 0 ? 0.0 : (ccs->mem_alloc / (StgFloat) total_alloc * 100),
	    ccs->sub_scc_count, ccs->sub_cafcc_count, ccs->sub_dictcc_count);
    
    if (RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE) {
      fprintf(prof_file, "  %5ld %9ld", ccs->time_ticks, ccs->mem_alloc*sizeof(W_));
#if defined(PROFILING_DETAIL_COUNTS)
      fprintf(prof_file, "  %8ld %8ld %8ld %8ld %8ld %8ld %8ld",
	      ccs->mem_allocs, ccs->thunk_count,
	      ccs->function_count, ccs->pap_count,
	      ccs->subsumed_fun_count,	ccs->subsumed_caf_count,
	      ccs->caffun_subsumed);
#endif
    }
    fprintf(prof_file, "\n");
  }

  for (i = ccs->indexTable; i != 0; i = i->next) {
    reportCCS(i->ccs, indent+1);
  }
}

/* Traverse the cost centre stack tree and accumulate
 * ticks/allocations.
 */
static void
count_ticks(CostCentreStack *ccs)
{
  IndexTable *i;
  
  if (!ccs_to_ignore(ccs)) {
    total_alloc += ccs->mem_alloc;
    total_ticks += ccs->time_ticks;
  }
  for (i = ccs->indexTable; i != NULL; i = i->next)
    count_ticks(i->ccs);
}

/* return rtsTrue if it is one of the ones that
 * should not be reported normally (because it confuses
 * the users)
 */
static rtsBool
ccs_to_ignore (CostCentreStack *ccs)
{
    if (    ccs == CCS_OVERHEAD 
	 || ccs == CCS_DONTZuCARE
	 || ccs == CCS_GC 
	 || ccs == CCS_SYSTEM) {
	return rtsTrue;
    } else {
	return rtsFalse;
    }
}

#endif /* PROFILING */