/*-----------------------------------------------------------------*-C-*---
 * File:    handc/runtime/entry.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.23
 * File mod date:    1997.11.29 23:10:49
 * System build:     v0.7.2, 97.12.21
 *
 * Purpose:          Provide main entry points into RScheme runtime system
 *------------------------------------------------------------------------*/

#include <stdarg.h>
#include <stdlib.h>
#include <setjmp.h>
#include <rscheme/runtime.h>
#include <rscheme/vinsns.h>
#include <rscheme/intrs.h>
#include <rscheme/osglue.h>
#include <rscheme/rsmodule.h>
#include <rscheme/scheme.h>
#include <rscheme/allocns.h>

/* #define PROFILE_MONOTONES */

jmp_buf *restart_run = NULL;
static unsigned run( obj cont );
static jump_addr last_addr;

#ifdef GNU_VINSNS
static void *restart_run_addr;
static int restart_run_value;
#endif

/* TIMEPOINT is a profiling mechanism used by FASL */

#ifdef TIMEPOINT
extern void timepoint( int id );
#endif 

#if defined(STEP_DUMP) || defined(TIMEPOINT)
unsigned insn_count = 0;
#endif

#ifdef TIMER_IS_MONOTONE_COUNTER
UINT_32 system_timeout = 0;
#endif

/* Defining STEP_DUMP and turning on do_step_dump
   causes a dump before the execution of
   every monotone, thereby slowing down executing slighly :-/
*/

#ifdef STEP_DUMP
int do_step_dump = 0;  /* most main()'s accept "-stepdump" to set this */
FILE *step_dump_file = NULL;
const char *step_dump_filename = NULL;
#endif /* STEP_DUMP */

/*  Manufacture a continuation which, when resumed,
    has the effect of calling the function with the
    given arguments
*/

static void vpush_call_continuation( obj closure, 
				     unsigned num_args, 
				     va_list the_args )
{
unsigned i;
jump_addr addr;

    arg_count_reg = num_args;
    /* can't really signal a scheme error here, 
     * because we haven't started up the system yet!
     */
    assert( FUNCTION_P(closure) );
    addr = apply( closure );
    {
	PUSH_PARTCONT_ADDR( addr, arg_count_reg );
	
	for (i=0; i<arg_count_reg; i++)
	    SET_PARTCONT_REG( i, va_arg( the_args, obj ) );
    }
}

static void push_call_continuation( obj closure, unsigned num_args, ... )
{
va_list x;

    va_start( x, num_args );
    vpush_call_continuation( closure, num_args, x );
    va_end( x );
}

_rs_volatile void done_w_call_scheme( void )
{
unsigned i;

    if (!arg_count_reg)
      temp_space[0] = NOVALUE_OBJ;
    else
      for (i=0; i<arg_count_reg; i++)
	temp_space[i] = reg_ref(i);

    longjmp( *restart_run, arg_count_reg + 2 );
}

obj call_scheme( obj closure, unsigned num_args, ... )
{
#ifdef DEBUG_0
obj t;
struct function_descr *fn;
#endif
va_list ap;
int n;
struct function_descr *finish_run;

    switch_hw_regs_into_scheme();
    assert( FUNCTION_P(closure) );

#ifdef DEBUG_0
    t = gvec_read( closure, SLOT(0) );
    fn = (struct function_descr *)VAL(gvec_read( t, SLOT(1) ));
    printf( "Calling " );
    fflush( stdout );
    printf( "%s\n", fn->name );
#endif /* DEBUG_0 */

    /* manufacture a continuation which, when resumed,
	terminates the current run.  */

    literals_reg = return_from_call_scheme_template;
    template_unstub( literals_reg );
    finish_run = (struct function_descr *)
      OBJ_TO_RAW_PTR(gvec_read( literals_reg, SLOT(1) ));

    envt_reg = NIL_OBJ;

    /*
    dynamic_state_reg = NIL_OBJ;
    continuation_reg = FALSE_OBJ;
    */
    push_cont( finish_run->monotones[1], 0 );
    
    gvec_read( literals_reg, SLOT(1) );

    va_start( ap, num_args );
    vpush_call_continuation( closure, num_args, ap );
    va_end( ap );

    n = run(continuation_reg);
#ifdef DEBUG_0
    for (i=0; i<n; i++)
    {
	printf( "Return value [%d] = ", i );
	fprinto( stdout, temp_space[i] );
	putchar( '\n' );
    }
#endif /* DEBUG_0 */
    switch_hw_regs_back_to_os();
    return temp_space[0];
}

#ifdef STEP_DUMP

static struct function_descr *get_function_descr( obj tmpl )
{
    return (struct function_descr *) 
    		OBJ_TO_RAW_PTR( gvec_read( tmpl, SLOT(1) ) );
}

void touch_step_dump_file( void )
{
    if (!step_dump_file)
	step_dump_file = os_fopen( step_dump_filename, "w" );
}

void step_dump( jump_addr f )
{
    touch_step_dump_file();
#ifdef TIMER_IS_MONOTONE_COUNTER
    fprintf( step_dump_file, "%u (timer %u) ==> ", 
    		insn_count, 
		system_timeout );
#else
    fprintf( step_dump_file, "%u ==> ", insn_count );
#endif
    if (EQ(literals_reg,FALSE_OBJ))
    {
        fprintf( step_dump_file, "*FINISH-RUN*\n" );
    }
    else
    {
    struct function_descr *fn = get_function_descr( literals_reg );
    unsigned i;
    
	i = 0;
	while (fn->monotones[i] != f)
	{
	    assert( fn->monotones[i] );
	    i++;
	}
        fprintf( step_dump_file, "%s", fn->name );
	if (i)
	    fprintf( step_dump_file, " [%d]", i );
        fprintf( step_dump_file, "  (%d args:", arg_count_reg );
	for (i=0; i<arg_count_reg; i++)
	{
	    fprintf( step_dump_file, " REG%d=", i );
	    fprinto( step_dump_file, reg_ref(i) );
	}
	fprintf( step_dump_file, ")\n" );
    }
    fflush( step_dump_file );
}

#endif /* STEP_DUMP */

#ifdef PROFILE_MONOTONES
#include <fcntl.h>
#include <sys/time.h>

struct mrecord {
  struct timeval startt;
  struct timeval endt;
  jump_addr addr;
  obj tmpl;
};

static int mfile = -1;
static FILE *oobfile = NULL;

static struct mrecord *mrec_ptr, mrec_buf[1000];
static obj oobed[1024];  /* cache */

void profile_monotone_init( void )
{
unsigned i;

  mfile = open( "mon.prof", O_CREAT|O_APPEND|O_WRONLY, 0666 );
  mrec_ptr = mrec_buf;
  oobfile = fopen( "mon.oob", "wb" );
  for (i=0; i<1024; i++)
    oobed[i] = FALSE_OBJ;
}

void mrec_flush( void )
{
  if (mfile >= 0)
    {
      UINT_32 n = (char *)mrec_ptr - (char *)&mrec_buf[0];

      printf( "mrec_flush( %u entries, %u bytes )\n",
	     mrec_ptr - mrec_buf, n );
      write( mfile, mrec_buf,  n );
    }
  fflush( oobfile );
  mrec_ptr = mrec_buf;
}

static void write_oobed( obj tmpl )
{
  struct function_descr *fp = NULL;
  obj x;
  UINT_32 num_mon;

  fwrite( &tmpl, 1, sizeof(obj), oobfile );

  x = gvec_read( tmpl, SLOT(1) );
  if (OBJ_ISA_FIXNUM(x))
    {
      fp = (struct function_descr *)OBJ_TO_RAW_PTR( x );
      for (num_mon = 0; fp->monotones[num_mon]; num_mon++);
    }
  else
    num_mon = 0;
  
  fwrite( &num_mon, 1, sizeof(UINT_32), oobfile );
  if (num_mon)
    fwrite( fp->monotones, num_mon, sizeof(jump_addr), oobfile );

  fputc( '\n', oobfile );
  fprinto( oobfile, gvec_read( tmpl, SLOT(2) ) );
  fputc( '\n', oobfile );
}

static void profile_monotone_start( jump_addr m, obj tmpl )
{
UINT_32 oht, oht2;

  /* check to see if tmpl is in oobed table */
  oht = ((VAL(tmpl) >> 3) + (VAL(tmpl) >> 13)) & 1023;
  if (!EQ(oobed[oht],tmpl))
    {
      /* rehash & check again */

      oht2 = (oht + (VAL(tmpl) >> 5)) & 1023;
      if (!EQ(oobed[oht2],tmpl))
	{
	  write_oobed( tmpl );
	  if (EQ(oobed[oht],FALSE_OBJ))
	    oobed[oht] = tmpl;
	  else if (EQ(oobed[oht2],FALSE_OBJ))
	    oobed[oht2] = tmpl;
	  else
	    {
	      oobed[oht2] = oobed[oht];
	      oobed[oht] = tmpl;
	    }
	}
    }

  if (mrec_ptr >= &mrec_buf[1000])
    mrec_flush();
  gettimeofday( &mrec_ptr->startt, NULL );
  mrec_ptr->addr = m;
  mrec_ptr->tmpl = tmpl;
}

static void profile_monotone_end( void )
{
  gettimeofday( &mrec_ptr->endt, NULL );
  mrec_ptr++;
}
#endif

static unsigned run( obj cont )
{
int i;
jump_addr f;
jmp_buf *prev_jmp_buf, current_jmp_buf;

#ifdef GNU_VINSNS
obj temp[1000];

    temp[0] = cont;
#endif

    temp_space[0] = cont;
    prev_jmp_buf = restart_run;
    restart_run = &current_jmp_buf;

    /* set up exception handler */
    while ((i = setjmp(current_jmp_buf)) == 1)
    { 
      /* nothing */
    }
    					/* this is where we start;
    					   on an exception, we come back
					   to here and reload the jump buffer
					*/
#ifdef GNU_VINSNS
    restart_run_value = 0;
restart:
    i = restart_run_value;
#endif

    if (i >= 2) /* finish_run was invoked */
    {
        restart_run = prev_jmp_buf;
	return i-2;
    }
    
    /* resume the continuation indicated by cross-over buffer */
    
    continuation_reg = temp_space[0];
    f = half_restore();
    arg_count_reg = restore_arb();

    quasi_interp_spin(f);
    return 0; /* never reached */
}


_rs_volatile void scheme_error( const char *msg, unsigned num_args, ... )
{
va_list x;
int i;
obj the_args;
extern int bci_trace_flag;

    if (bci_trace_flag > 0)
      {
	printf( "\n***\nscheme_error( \"%s\", %d, ... )\n", msg, num_args );
	printf( "in: [%#x] ", VAL(literals_reg) );
	fprinto( stdout, gvec_read(literals_reg,SLOT(2)) );
	printf( "\n" );
	va_start( x, num_args );
	for (i=0; i<num_args; i++)
	  {
	    printf( "   arg[%d] ::= ", i );
	    fprinto( stdout, va_arg( x, obj ) );
	    printf( "\n" );
	  }
	fflush( stdout );
	va_end( x );
      }
  
    /* collect the args into a list */

    va_start( x, num_args );
    for (i=0; i<num_args; i++)
	temp_space[i] = va_arg( x, obj );
    va_end( x );

    the_args = NIL_OBJ;
    while (i>0)
	the_args = cons( temp_space[--i], the_args );

    /* invoke the exception handler */
    raise_exception( 0, 5, 
		     literals_reg, 
		     last_addr,
		     envt_reg,
		     make_string(msg),
		     the_args );
}

_rs_volatile void raise_error( obj err_object )
{
  if (instance_p(err_object, condition_class))
    raise_exception( 7, 1, err_object );
  else
    scheme_error( "raise_error(): ~s not a condition object",
		  1, err_object );
}

static obj make_function_place( int fplace_code )
{
  return make2( function_place_class, 
		literals_reg,
		int2fx(fplace_code) );
}

_rs_volatile void type_check_error( obj thing, 
				    const char *class_name, 
				    int fplace_code )
{
  raise_error( make3( type_check_failed_class, 
		      intern( make_string(class_name) ),
		      thing,
		      make_function_place( fplace_code ) ) );
}

_rs_volatile void raise_exception( int type, int argc, ... )
{
  va_list args;
  unsigned i;
  jump_addr addr;

  if (rsprof_active)
    {
      /* this fragment is terminating abnormally... */
      rsprof_mt_fails();
    }

  if (EQ(exception_handler_proc,FALSE_OBJ))
    {
      fprintf( stderr, "** No exception handler in place **\n" );
      abort();
    }
  
  arg_count_reg = argc+1;

  REG0 = int2fx( type );
  va_start( args, argc );
  for (i=0; i<argc; i++)
    reg_set( i+1, va_arg( args, obj ) );
  va_end( args );
  
  /* note that signalling an error is pointless, because THIS
   * is the error handling code
   */

  assert( FUNCTION_P(exception_handler_proc) );
  addr = apply( exception_handler_proc );
  {
    PUSH_PARTCONT_ADDR( addr, arg_count_reg );
    
    for (i=0; i<arg_count_reg; i++)
      SET_PARTCONT_REG( i, reg_ref(i) );
  }

  temp_space[0] = continuation_reg;
  longjmp( *restart_run, 1 );
}