/*-----------------------------------------------------------------*-C-*---
 * File:    handc/runtime/profile.c
 *
 *          Copyright (C)1997 Donovan Kolbly <d.kolbly@rscheme.org>
 *          as part of the RScheme project, licensed for free use.
 *          See <http://www.rscheme.org/> for the latest information.
 *
 * File version:     1.7
 * File mod date:    1997.11.29 23:10:51
 * System build:     v0.7.2, 97.12.21
 *
 * Purpose:          User-level profiling support
 *------------------------------------------------------------------------*/

#include <string.h>
#include <rscheme/runtime.h>
#include <rscheme/vinsns.h>
#include <rscheme/hashmain.h>
#include <rscheme/osglue.h>

#if ACCUM_GF_CACHE_HISTOGRAM
int gf_cache_hit_depth[100];

obj collect_gf_cache_histogram( rs_bool reset_q )
{
  obj v = alloc( SLOT(100), vector_class );
  unsigned i;

  for (i=0; i<100; i++)
    gvec_write_init_non_ptr( v, SLOT(i), int2fx(gf_cache_hit_depth[i]) );

  if (reset_q)
    for (i=0; i<100; i++)
      gf_cache_hit_depth[i] = 0;

  return v;
}
#else
obj collect_gf_cache_histogram( rs_bool reset_q )
{
  return make0(vector_class);
}
#endif

#if !PROFILING_HOOKS

void rsprof_start( const char *path, rs_bool append_q )
{
  scheme_error( "profiling not enabled", 0 );
}

rs_bool rsprof_stop( void )
{
  rsprof_start(NULL,NO);
  return NO;
}

void rsprof_collect_objects( obj setup, obj otbl )
{
  rsprof_start(NULL,NO);
}

void rsprof_app_defn_rec( obj key, obj val )
{
  rsprof_start(NULL,NO);
}

#else

int rsprof_active = 0;
static FILE *proff = NULL;

static char *myprof_buff, *myprof_buff_ptr, *myprof_buff_lim;
#define MYPROF_BUFF_SIZE (1024*1024)

static void rsprof_cal_start( void );
static void rsprof_cal_stop( void );
static void rsprof_cal_realtime( void );
static void futz_around( int n );
static void bflush( void );
static int scan_profile_file( const char *path, 
			      int (*proc)( struct RS_pr_header *rec, 
					   void *info ),
			      void *info );

/* control items */

void rsprof_start( const char *path, rs_bool append_q )
{
  if (proff)
    fclose(proff);
  rsprof_active = 0;

  proff = fopen( path, append_q ? "a" : "w" );
  if (!proff)
    os_error( "fopen", 1, make_string(path) );

  if (!append_q)
    rsprof_active = 1;
  
  myprof_buff = malloc( MYPROF_BUFF_SIZE + 128 );
  myprof_buff_ptr = myprof_buff;
  myprof_buff_lim = myprof_buff + MYPROF_BUFF_SIZE;
  if (rsprof_active)
    {
      rsprof_cal_realtime();
      futz_around(10);
      rsprof_cal_realtime();
      futz_around(10);
      rsprof_cal_realtime();
      rsprof_cal_start();
      rsprof_cal_stop();
    }
}

rs_bool rsprof_stop( void )
{
  if (proff)
    {
      if (rsprof_active)
	{
	  rsprof_cal_start();
	  rsprof_cal_stop();
	}
      bflush();
      rsprof_active = 0;

      if (fclose( proff ) != 0)
	os_error( "fclose", 0 );
      proff = NULL;
      return YES;
    }
  else
    return NO;
}


/*
 *  scans a file, looking for objects that it would be nice to have
 *  named in the output.  In particular, <<class>> and <template> objects.
 *
 *  Note that it is up to the user to guarantee that any classes and
 *  templates used during the tracing run are still around!
 */

static int collect_named_objects( struct RS_pr_header *rec, void *info )
{
  obj tmp_o, otbl;
  otbl = *(obj *)info;

  switch (rec->code)
    {
    case RSPROF_MT_RETURNS:
    case RSPROF_MT_BJUMPS:
    case RSPROF_MT_JUMPS:
    case RSPROF_MT_FAILS:
    case RSPROF_MT_INTR:
    case RSPROF_MT_DONE:
    case RSPROF_GC_WORK:
    case RSPROF_RESTORED:
    case RSPROF_CAPTURED:
    case RSPROF_OBJ_DIED:
    case RSPROF_SAVES:
    case RSPROF_DECL_NAME:
    case RSPROF_NOP:
    case RSPROF_CAL_START:
    case RSPROF_CAL_STOP:
    case RSPROF_CAL_REALTIME:
      break;
      
    case RSPROF_MT_CALLS:
      tmp_o = ((struct RS_pr_MT_CALLS *)rec)->tmpl;
      objecttable_insert( otbl, obj_hash(tmp_o), tmp_o, tmp_o );
      break;
      
    case RSPROF_MT_START:
      tmp_o = ((struct RS_pr_MT_START *)rec)->tmpl;
      objecttable_insert( otbl, obj_hash(tmp_o), tmp_o, tmp_o );
      break;
      
    case RSPROF_OBJ_ALLOCED:
      tmp_o = ((struct RS_pr_OBJ_ALLOCED *)rec)->item_class;
      objecttable_insert( otbl, obj_hash(tmp_o), tmp_o, tmp_o );
      break;
    }
  return 0;
}

void rsprof_collect_objects( obj setup, obj otbl )
{
  if (STRING_P(setup))
    {
      scan_profile_file( string_text( setup ), 
			 collect_named_objects,
			 &otbl );
    }
  else
    scheme_error( "rsprof_collect_templates: "
		  "argument ~s not a pathname string", 1, setup );
}

#define SCAN_BUF_SIZE (8192)

static int scan_profile_file( const char *path, 
			      int (*proc)( struct RS_pr_header *rec, 
					   void *info ),
			      void *info )
{
  FILE *f;
  char *p, *lim, *pre_lim, temp[SCAN_BUF_SIZE];
  obj tmp_o;
  int n, rc;

  f = fopen( path, "r" );
  if (!f)
    os_error( "fopen", 1, make_string(path) );
  p = pre_lim = temp;

  n = fread( temp, 1, SCAN_BUF_SIZE, f );

  if (n < 0)
    n = 0;
  lim = p + n;
  pre_lim = lim - 300;
  if (pre_lim < p)
    pre_lim = p;

  rc = 0;

  while ((rc == 0) && (p < lim))
    {
      if (p >= pre_lim)
	{
	  memmove( temp, p, lim - p );
	  lim = temp + (lim - p);
	  p = temp;
	  n = fread( lim, 1, SCAN_BUF_SIZE - (lim - p), f );
	  if (n > 0)
	    {
	      lim += n;
	      pre_lim = lim - 300;
	      if (pre_lim < p)
		pre_lim = lim;
	    }
	  else
	    pre_lim = lim;
	}
      /*printf( "scanning a type-%d record (%u bytes)\n", 
	      ((struct RS_pr_header *)p)->code,
	      ((struct RS_pr_header *)p)->rec_bytes );*/
      rc = proc( (struct RS_pr_header *)p, info );
      p += ((struct RS_pr_header *)p)->rec_bytes;
    }
  
  fclose(f);
  return rc;
}

static void bflush( void )
{
  size_t n = myprof_buff_ptr - myprof_buff;
  if (n != fwrite( myprof_buff, 1, n, proff ))
    os_error( "fwrite", 0 );
  myprof_buff_ptr = myprof_buff;
}


#define EMIT_RECORD_HR(v,t,hr) struct RS_pr_ ## t *v; \
                               do { \
                                 if ((myprof_buff_ptr+(hr))>=myprof_buff_lim)\
                                    bflush(); \
                                 v = (struct RS_pr_ ## t *) myprof_buff_ptr; \
				 myprof_buff_ptr+=sizeof(struct RS_pr_ ## t);\
				 v->hdr.code = RSPROF_ ## t; \
				 v->hdr.var_len = 0; \
				 v->hdr.rec_bytes=sizeof(struct RS_pr_ ## t);\
                               } while (0)
#define EMIT_RECORD(v,t) EMIT_RECORD_HR(v,t,0)

/* hooks to indicate how the current monotone is being exited... */

void rsprof_mt_calls( obj proc, obj tmpl )
{
  EMIT_RECORD(r, MT_CALLS);
  r->tmpl = tmpl;
  r->argc = arg_count_reg;
}

void rsprof_mt_returns( void )
{
  EMIT_RECORD(r, MT_RETURNS);
}

void rsprof_mt_bjumps( void )
{
  EMIT_RECORD(r, MT_BJUMPS);
}

void rsprof_mt_jumps( void )
{
  EMIT_RECORD(r, MT_JUMPS);
}

void rsprof_mt_fails( void )
{
  EMIT_RECORD(r, MT_FAILS);
}

/* hooks to keep track of the stack state */

void rsprof_saves( void )
{
  EMIT_RECORD(r, SAVES);
}

void rsprof_contn_captured( obj contn )
{
  EMIT_RECORD(r, CAPTURED);
  r->contn = contn;
}

void rsprof_contn_restored( obj contn )
{
  EMIT_RECORD(r, RESTORED);
  r->contn = contn;
}

void rsprof_mt_intr( void )
{
  EMIT_RECORD(r, MT_INTR);
}

void rsprof_mt_start( jump_addr entry_pt )
{
  EMIT_RECORD_HR(r, MT_START, 120);
  r->tstamp = rsprof_time();
  r->tmpl = literals_reg;
}

#define tstamped(op) EMIT_RECORD(r,op); r->tstamp = rsprof_time()

static void rsprof_cal_start( void )
{
  tstamped( CAL_START );
}

static void rsprof_cal_stop( void )
{
  tstamped( CAL_STOP );
}

static void rsprof_cal_realtime( void )
{
  tstamped( CAL_REALTIME );
  gettimeofday( &r->systime, NULL );
}

void rsprof_mt_done( void )
{
  tstamped( MT_DONE );
}

void rsprof_gc_work( void )
{
  tstamped( GC_WORK );
}

void rsprof_obj_alloced( obj item, obj obj_class, UINT_32 bytes )
{
  EMIT_RECORD(r,OBJ_ALLOCED);
  r->item = item;
  r->item_class = obj_class;
  r->bytes = bytes;
}

void rsprof_obj_died( obj item )
{
  EMIT_RECORD(r,OBJ_DIED);
  r->item = item;
}

void rsprof_app_defn_rec( obj key, obj val )
{
  int len, bytes;

  if (!proff)
    return;

  len = string_length(val);
  if (len > 250)
    len = 250;
  bytes = (len + 3) & ~3;

  {
    EMIT_RECORD_HR(r,DECL_NAME,300);
    r->hdr.rec_bytes = sizeof( struct RS_pr_DECL_NAME ) - 4 + bytes;
    r->item = key;
    r->hdr.var_len = len;
    memcpy( r->name, string_text(val), bytes );
    myprof_buff_ptr = ((char *)r) + r->hdr.rec_bytes;
  }
}

#define M  (256)

static int cmp_int( const void *pa, const void *pb )
{
  int a = *(const int *)pa;
  int b = *(const int *)pb;

  if (a < b)
    return -1;
  else if (a == b)
    return 0;
  else
    return 1;
}

static void futz_around( int n )
{
  int i, temp[M];

  while (n > 0)
    {
      for (i=0; i<M; i++)
	temp[i] = rand();
      qsort( temp, M, sizeof(int), cmp_int );
      n--;
    }
}

#endif