/* Runtime stuff */

#include "params.h"
#include "gambit.h"
#include "struct.h"
#include "os.h"
#include "mem.h"
#include "strings.h"
#include "opcodes.h"
#include "gc.h"
#include "stats.h"


/*---------------------------------------------------------------------------*/


long read_not_ready;    /* index of '##exception.read-not-ready' var  */
long write_not_ready;   /* index of '##exception.write-not-ready' var */
long gc_finalize;       /* index of '##exception.gc-finalize' var     */


/*---------------------------------------------------------------------------*/


void print_global_var( name )
char *name;
{ long index;
  if (alloc_global( name, &index )) { os_warn( "%s\n", (long)os_err ); os_quit(); }
  os_warn( "0x%x", sstate->globals[index].value );
  os_warn( " = %s\n", (long)name );
}


/*---------------------------------------------------------------------------*/


void if_prim( value, name, proc )
SCM_obj value;
SCM_obj name;
void (*proc)();
{ if ((SCM_type(value) == SCM_type_PROCEDURE) &&
      (SCM_header_procedure(SCM_header(value))))
    (*proc)( SCM_object_adr(value), SCM_procedure_length(SCM_header(value)), string_to_c_str(name) );
}


void for_each_glob_prim_proc( proc )
void (*proc)();
{ long i;
  SCM_obj st = sstate->globals[SYMBOL_TABLE].value;
  for (i=0; i<(long)SYMBOL_TABLE_LENGTH; i++)
  { SCM_obj probe = SCM_obj_to_vect(st)[i];
    while (probe != (long)SCM_null)
    { SCM_obj sym = *(SCM_obj *)(probe-SCM_type_PAIR+PAIR_CAR*sizeof(SCM_obj));
      SCM_obj name = SCM_obj_to_vect(sym)[SYMBOL_NAME];
      SCM_obj global = SCM_obj_to_vect(sym)[SYMBOL_GLOBAL];
      if (global != (long)SCM_false)
        if_prim( sstate->globals[SCM_obj_to_int(global)].value, name, proc );
      probe = *(SCM_obj *)(probe-SCM_type_PAIR+PAIR_CDR*sizeof(SCM_obj));
    }
  }
}


char *procedure_containing( pc )
long pc;
{ long i;
  SCM_obj st = sstate->globals[SYMBOL_TABLE].value;
  for (i=0; i<(long)SYMBOL_TABLE_LENGTH; i++)
  { SCM_obj probe = SCM_obj_to_vect(st)[i];
    while (probe != (long)SCM_null)
    { SCM_obj sym = *(SCM_obj *)(probe-SCM_type_PAIR+PAIR_CAR*sizeof(SCM_obj));
      SCM_obj name = SCM_obj_to_vect(sym)[SYMBOL_NAME];
      SCM_obj global = SCM_obj_to_vect(sym)[SYMBOL_GLOBAL];
      if (global != (long)SCM_false)
      { SCM_obj value = sstate->globals[SCM_obj_to_int(global)].value;
        if ((SCM_type(value) == SCM_type_PROCEDURE) &&
            (SCM_header_procedure(SCM_header(value))) &&
            (pc >= (long)SCM_object_adr(value)) &&
            (pc <  ((long)SCM_object_adr(value))+SCM_procedure_length(SCM_header(value))))
          return string_to_c_str( name );
      }
      probe = *(SCM_obj *)(probe-SCM_type_PAIR+PAIR_CDR*sizeof(SCM_obj));
    }
  }
  return NULL;
}


char *global_name( index )
long index;
{ long i;
  SCM_obj st = sstate->globals[SYMBOL_TABLE].value;
  for (i=0; i<(long)SYMBOL_TABLE_LENGTH; i++)
  { SCM_obj probe = SCM_obj_to_vect(st)[i];
    while (probe != (long)SCM_null)
    { SCM_obj sym = *(SCM_obj *)(probe-SCM_type_PAIR+PAIR_CAR*sizeof(SCM_obj));
      SCM_obj name = SCM_obj_to_vect(sym)[SYMBOL_NAME];
      SCM_obj global = SCM_obj_to_vect(sym)[SYMBOL_GLOBAL];
      if ((global != (long)SCM_false) && (SCM_obj_to_int( global ) == index))
        return string_to_c_str( name );
      probe = *(SCM_obj *)(probe-SCM_type_PAIR+PAIR_CDR*sizeof(SCM_obj));
    }
  }
  return NULL;
}


/*---------------------------------------------------------------------------*/

#define RAISE_OTHER_INTR(p,intr) { p->intr = 1; p->intr_other = 1; p->intr_flag = -1; }

#define WASTE_TIME() { register long count; for (count=10; count>0; count--) ; }


long broadcast( send, msg1, msg2 )
long send;
long *msg1, *msg2;
{ long n = SCM_obj_to_int(pstate->nb_processors);
  long id = SCM_obj_to_int(pstate->id);
  long x = id*2+1, y = id*2+2;
  long i;
  long m1 = *msg1, m2 = *msg2;
  if (send) i = id; else i = -1;
  if (x < n)
  { while (pstate->sync1 == -2) WASTE_TIME();
    if (i == -1)
    { i = pstate->sync1; m1 = pstate->sync1_msg1; m2 = pstate->sync1_msg2; }
    pstate->sync1 = -2;
    if (y < n)
    { while (pstate->sync2 == -2) WASTE_TIME();
      if (i == -1)
      { i = pstate->sync2; m1 = pstate->sync2_msg1; m2 = pstate->sync2_msg2; }
      pstate->sync2 = -2;
    }
  }
  if (id == 0)
  { pstate->sync0_msg1 = m1; pstate->sync0_msg2 = m2; pstate->sync0 = i; }
  else
  { PSTATE_PTR parent = pstate->ps[(id-1)/2];
    pstate->sync0 = -2;
    if (id & 1)
    { parent->sync1_msg1 = m1; parent->sync1_msg2 = m2; parent->sync1 = i; }
    else
    { parent->sync2_msg1 = m1; parent->sync2_msg2 = m2; parent->sync2 = i; }
    while (pstate->sync0 == -2) WASTE_TIME();
  }
  if (x < n)
  { PSTATE_PTR child1 = pstate->ps[x];
    child1->sync0_msg1 = pstate->sync0_msg1;
    child1->sync0_msg2 = pstate->sync0_msg2;
    child1->sync0      = pstate->sync0;
    if (y < n)
    { PSTATE_PTR child2 = pstate->ps[y];
      child2->sync0_msg1 = pstate->sync0_msg1;
      child2->sync0_msg2 = pstate->sync0_msg2;
      child2->sync0      = pstate->sync0;
    }
  }
  *msg1 = pstate->sync0_msg1;
  *msg2 = pstate->sync0_msg2;
  return pstate->sync0;
}


void barrier( name )
char *name;
{ long msg1, msg2;
  if (broadcast( 0L, &msg1, &msg2 ) >= 0)
  { os_warn( "Processors out of sync at barrier %s\n", (long)name ); os_quit(); }
}


void barrier_trigger()
{ long i;
  for (i=SCM_obj_to_int(pstate->nb_processors)-1; i>=0; i--)
  { PSTATE_PTR p = pstate->ps[i];
    if (p != pstate) RAISE_OTHER_INTR(p,intr_barrier);
  }
}


long barrier_call( proc, arg )
long (*proc)();
long arg;
{ long (*proc2)();
  long arg2;
  long result;
  long id;
  do
  {/*@@ proc2 = *proc; @@*/
    proc2 = proc; 
    arg2  = arg;
    barrier_trigger();
    id = broadcast( 1L, (long *)&proc2, &arg2 );
    pstate->intr_barrier = 0;
    barrier( "BARRIER_CALL" );
    result = proc2( id, arg2 );
  } while (id != SCM_obj_to_int(pstate->id) );
  return result;
}


long barrier_service()
{ long (*proc2)();
  long arg2;
  long id;
  id = broadcast( 0L, (long *)&proc2, &arg2 );
  if (id < 0)
  { os_warn( "Processors out of sync at a barrier\n", 0L ); os_quit(); }
  pstate->intr_barrier = 0;
  barrier( "BARRIER_SERVICE" );
  return proc2( id, arg2 );
}


/*---------------------------------------------------------------------------*/


long do_return( id, arg )
long id;
long arg;
{ return arg;
}


long do_cpu_times( id, arg )
long id;
long arg;
{ os_cpu_times( pstate->cpu_times );
  barrier( "DO_CPU_TIMES" );
  return 0;
}


long do_gc( id, arg )
long id;
long arg;
{ gc();
  os_flush_caches();
  return 0;
}


long do_load_ofile( id, filename )
long id;
char *filename;
{ SCM_obj result;
  if (SCM_obj_to_int(pstate->id) == id)
  { sstate->program_filename = filename;
    load_ofile( filename, &result );
  }
  else
    load_ofile( (char *)NULL, &result );
  barrier( "DO_LOAD_OFILE" );
  os_flush_caches();
  return result;
}


long do_set_timer_interval( id, arg )
long id;
long arg;
{ if (SCM_obj_to_int(pstate->id) == 0)
    os_set_timer_interval( arg );
  return 0;
}


/*---------------------------------------------------------------------------*/

/* Interrupt handling */


void user_intr_proc( pc, sp, kind )
long pc, sp;
char *kind;
{ RAISE_OTHER_INTR(pstate,intr_user);
}


void timer_intr_proc( pc, sp, kind )
long pc, sp;
long kind;
{ long i;
  for (i=SCM_obj_to_int(pstate->nb_processors)-1; i>=0; i--)
    RAISE_OTHER_INTR(pstate->ps[i],intr_timer);
}


void io_intr_proc( pc, sp, kind )
long pc, sp;
long kind;
{ RAISE_OTHER_INTR(pstate,intr_io);
}


void fatal_intr_proc( pc, sp, kind )
long pc, *sp;
char *kind;
{ char *name;
  os_warn( "Processor %d", SCM_obj_to_int(pstate->id) );
  os_warn( " raised signal %s ", (long)kind );
  if (pc != 0)
  { os_warn( "at PC=0x%x", pc );
    name = procedure_containing( pc );
    if (name != NULL) os_warn( " in %s", (long)name );
  }
  os_warn( "\n", 0L );
  if (sp != NULL)
  { int i;
    os_warn( "Stack dump:\n", 0L );
    for (i=0; i<16; i++)
    { long value = sp[i];
      os_warn( "  [0x%x] = ", (long)&sp[i] );
      os_warn( "0x%x", value );
      if (SCM_type(value) == SCM_type_PROCEDURE)
      { name = procedure_containing( value );
        if (name != NULL) os_warn( " in %s", (long)name );
      }
      os_warn( "\n", 0L );
    }
  }      
  os_quit();
}


/*---------------------------------------------------------------------------*/

/* Scheme procedures written in C */


SCM_obj X23X23gc()
{ barrier_call( do_gc, 0L );
  *(pstate->stack_ptr) = sstate->globals[gc_finalize].value;
  return (long)SCM_false;
}


SCM_obj X23X23barrier()
{ barrier_service();
  return (long)SCM_false;
}


SCM_obj X23X23quit( num )
SCM_obj num;
{ os_quit();
}


OS_FILE file[MAX_NB_OPEN_FILES];


SCM_obj X23X23osDfileDopenDinput( path )
SCM_obj path;
{ char *filename, *mark;
  SCM_obj result;
  long i;
  for (i=0; i<(long)MAX_NB_OPEN_FILES; i++) if (file[i] == -1) break;
  if (i == (long)MAX_NB_OPEN_FILES) return (long)SCM_false;
  mark = local_mark();
  filename = os_expand_filename( string_to_c_str(path) );
  if (filename == NULL)
    result = (long)SCM_false;
  else
  { OS_FILE f = os_file_open_input( filename );
    if (f == -1)
      result = (long)SCM_false;
    else
    { file[i] = f;
      result = SCM_int_to_obj(i);
    }
  }
  local_release( mark );
  return result;
}


SCM_obj X23X23osDfileDopenDoutput( path )
SCM_obj path;
{ char *filename, *mark;
  SCM_obj result;
  long i;
  for (i=0; i<(long)MAX_NB_OPEN_FILES; i++) if (file[i] == -1) break;
  if (i == (long)MAX_NB_OPEN_FILES) return (long)SCM_false;
  mark = local_mark();
  filename = os_expand_filename( string_to_c_str(path) );
  if (filename == NULL)
    result = (long)SCM_false;
  else
  { OS_FILE f = os_file_open_output( filename );
    if (f == -1)
      result = (long)SCM_false;
    else
    { file[i] = f;
      result = SCM_int_to_obj(i);
    }
  }
  local_release( mark );
  return result;
}


SCM_obj X23X23osDfileDopenDinputDoutput( path )
SCM_obj path;
{ char *filename, *mark;
  SCM_obj result;
  long i;
  for (i=0; i<(long)MAX_NB_OPEN_FILES; i++) if (file[i] == -1) break;
  if (i == (long)MAX_NB_OPEN_FILES) return (long)SCM_false;
  mark = local_mark();
  filename = os_expand_filename( string_to_c_str(path) );
  if (filename == NULL)
    result = (long)SCM_false;
  else
  { OS_FILE f = os_file_open_input_output( filename );
    if (f == -1)
      result = (long)SCM_false;
    else
    { file[i] = f;
      result = SCM_int_to_obj(i);
    }
  }
  local_release( mark );
  return result;
}


SCM_obj X23X23osDfileDclose( ind )
SCM_obj ind;
{ long i = SCM_obj_to_int(ind);
  if ((i>=3) && (i<(long)MAX_NB_OPEN_FILES))
  { OS_FILE f = file[i];
    file[i] = -1;
    if (f != -1)
    { os_file_close( f ); return (long)SCM_true; }
  }
  return (long)SCM_false;
}


SCM_obj X23X23osDfileDreadDready( ind )
SCM_obj ind;
{ long i = SCM_obj_to_int(ind);
  if ((i>=0) && (i<(long)MAX_NB_OPEN_FILES))
  { OS_FILE f = file[i];
    if ((f != -1) && os_file_read_ready( f ))
      return (long)SCM_true;
  }
  return (long)SCM_false;
}


SCM_obj X23X23osDfileDread( ind, buf, start, end  )
SCM_obj ind, buf, start, end;
{ long i = SCM_obj_to_int(ind);
  long s = SCM_obj_to_int(start);
  if ((i>=0) && (i<(long)MAX_NB_OPEN_FILES))
  { OS_FILE f = file[i];
    if (f != -1)
    { long result = os_file_read( f,
                                  SCM_obj_to_str(buf) + s,
                                  SCM_obj_to_int(end) - s );
      if (result >= 0)
        return SCM_int_to_obj( result );
      else if (result == -2) /* not ready? */
      { *(pstate->stack_ptr) = sstate->globals[read_not_ready].value;
        return ind;
      }
    }
  }
  return (long)SCM_false;
}


SCM_obj X23X23osDfileDwrite( ind, buf, start, end  )
SCM_obj ind, buf, start, end;
{ long i = SCM_obj_to_int(ind);
  long s = SCM_obj_to_int(start);
  if ((i>=0) && (i<(long)MAX_NB_OPEN_FILES))
  { OS_FILE f = file[i];
    if (f != -1)
    { long result = os_file_write( f,
                                    SCM_obj_to_str(buf) + s,
                                    SCM_obj_to_int(end) - s );
      if (result >= 0)
        return SCM_int_to_obj( result );
      else if (result == -2) /* not ready? */
      { *(pstate->stack_ptr) = sstate->globals[write_not_ready].value;
        return ind;
      }
    }
  }
  return (long)SCM_false;
}


SCM_obj X23X23osDfileDblockDread( ind )
SCM_obj ind;
{ long i = SCM_obj_to_int(ind);
  if ((i>=0) && (i<(long)MAX_NB_OPEN_FILES))
  { OS_FILE f = file[i];
    if (f != -1) os_file_block_read( f );
  }
  return (long)SCM_false;
}


SCM_obj X23X23osDfileDblockDwrite( ind )
SCM_obj ind;
{ long i = SCM_obj_to_int(ind);
  if ((i>=0) && (i<(long)MAX_NB_OPEN_FILES))
  { OS_FILE f = file[i];
    if (f != -1) os_file_block_write( f );
  }
  return (long)SCM_false;
}


SCM_obj X23X23osDsetDtimerDinterval( interval )
SCM_obj interval;
{ barrier_call( do_set_timer_interval, SCM_obj_to_int( interval ) );
  return (long)SCM_false;
}


SCM_obj X23X23osDgetDnextDevent()
{ long len = ceiling8(sizeof(SCM_obj)+OS_EVENT_SIZE);
  if ((pstate->heap_ptr - pstate->heap_lim) < len)
  { barrier_call( do_gc, 0L );
    *(pstate->stack_ptr) = sstate->globals[gc_finalize].value;
  }
  pstate->heap_ptr -= len;
  if (os_get_next_event( pstate->heap_ptr+sizeof(SCM_obj) ))
  { *(long *)(pstate->heap_ptr) = SCM_make_header( (long)OS_EVENT_SIZE, SCM_subtype_STRING );
    return (SCM_obj)(pstate->heap_ptr + SCM_type_SUBTYPED);
  }
  else
  { pstate->heap_ptr += len;
    return (long)SCM_false;
  }
}


SCM_obj X23X23osDhandleDevent( event )
SCM_obj event;
{ if (os_handle_event( event-SCM_type_SUBTYPED+sizeof(SCM_obj) ))
    return (long)SCM_true;
  else
    return (long)SCM_false;
}


SCM_obj X23X23cpuDtimes( buf )
SCM_obj buf;
{ long ucpu = 0, scpu = 0;
  long i;
  barrier_call( do_cpu_times, 0L );
  for (i=SCM_obj_to_int(pstate->nb_processors)-1; i>=0; i--)
  { PSTATE_PTR p = pstate->ps[i];
    ucpu += p->cpu_times[0];
    scpu += p->cpu_times[1];
  }
  SCM_obj_to_vect(buf)[0] = SCM_int_to_obj( ucpu / SCM_obj_to_int(pstate->nb_processors) );
  SCM_obj_to_vect(buf)[1] = SCM_int_to_obj( scpu / SCM_obj_to_int(pstate->nb_processors) );
  return buf;
}


SCM_obj X23X23realDtime()
{ return SCM_int_to_obj( os_clock_to_msec( os_clock() ) );
}


SCM_obj X23X23loadDobjectDfile( path )
SCM_obj path;
{ SCM_obj result;
  char *filename1 = os_expand_filename( string_to_c_str(path) );
  char *mark = local_mark();
  char *filename2 = string_append( filename1, ".O" );
  if (filename2 == NULL)
    result = (long)SCM_false;
  else
  { OS_FILE f = os_file_open_input( filename2 );
    if (f == -1)
      result = (long)SCM_false;
    else
    { long len = os_file_length( f );
      os_file_close( f );
      if (len < 0)
        result = (long)SCM_false;
      else
      { if ((pstate->heap_ptr - pstate->heap_lim) < 2*len)
        { barrier_call( do_gc, 0L );
          *(pstate->stack_ptr) = sstate->globals[gc_finalize].value;
        }
        result = barrier_call( do_load_ofile, (long)filename1 );
      }
    }
  }
  local_release( mark );
  return result;
}


long do_copy_constant( id, obj )
long id;
SCM_obj obj;
{ SCM_obj *p1 = SCM_object_adr( obj ), *p2;
  long obj_type = SCM_type( obj );
  if (obj_type == SCM_type_PAIR)
  { p2 = (SCM_obj *)sstate->const_tptr;
    p2[0] = p1[0];
    p2[1] = p1[1];
  }
  else
  { long len = ceiling8(SCM_length(obj)+sizeof(SCM_obj))/sizeof(SCM_obj);
    p2 = ((SCM_obj *)sstate->const_bptr) - len;
    os_block_copy( (char *)p1, (char *)p2, len*sizeof(SCM_obj) );
  }
  return SCM_add_type( p2, obj_type );
}


long do_local_copy( id, obj )
long id;
SCM_obj obj;
{ SCM_obj result;
  if (SCM_obj_to_int(pstate->id) == id)
  { long obj_type = SCM_type( obj );
    long len;
    if (obj_type == SCM_type_PAIR)
      len = 2;
    else
      len = ceiling8(SCM_length(obj)+sizeof(SCM_obj))/sizeof(SCM_obj);
    if ((len*sizeof(SCM_obj)) > (sstate->const_tptr-sstate->const_bptr))
      result = barrier_call( do_return, (long)SCM_false );
    else
    { if (obj_type == SCM_type_PAIR)
        sstate->const_tptr -= len*sizeof(SCM_obj);
      else
        sstate->const_bptr += len*sizeof(SCM_obj);
      result = barrier_call( do_copy_constant, (long)obj );
    }
  }
  else
    result = barrier_service();
  return result;
}


SCM_obj X23X23localDcopy( obj )
SCM_obj obj;
{ long obj_type = SCM_type( obj );
  if ((obj_type == SCM_type_FIXNUM) ||
      (obj_type == SCM_type_SPECIAL) ||
      (obj_type == SCM_type_PLACEHOLDER)) /* don't copy placeholders... */
    return obj;
  else
    return barrier_call( do_local_copy, (long)obj );
}


long do_make_distributed_pair_chain( id, n )
long id;
long n;
{ SCM_obj result = (long)SCM_false;
  if (SCM_obj_to_int(pstate->id) == id)
  { long i = n-1;
    while (i >= 0)  /* warning: heap overflow checks not done... */
    { long *ptr;
      PSTATE_PTR p = pstate->ps[i%SCM_obj_to_int(pstate->nb_processors)];
      p->heap_ptr -= 2*sizeof(SCM_obj);
      ptr = (SCM_obj *)p->heap_ptr;
      ptr[0] = result;
      ptr[1] = SCM_false;
      result = SCM_add_type( ptr, SCM_type_PAIR );
      i--;
    }
    barrier_call( do_return, result );
  }
  else
    result = barrier_service();
  return result;
}


SCM_obj X23X23makeDdistributedDpairDchain( len )
SCM_obj len;
{ return barrier_call( do_make_distributed_pair_chain, SCM_obj_to_int( len ) );
}


long do_make_distributed_vector_chain( id, n_m )
long id;
long n_m;
{ SCM_obj result = (long)SCM_false;
  long n = n_m >> 8;
  long m = n_m & ((1 << 8) - 1);
  long size1 = m*sizeof(SCM_obj);
  long size2 = ceiling8(sizeof(SCM_obj)+size1);
  if (SCM_obj_to_int(pstate->id) == id)
  { long i = n-1;
    while (i >= 0)  /* warning: heap overflow checks not done... */
    { long *ptr;
      long j;
      PSTATE_PTR p = pstate->ps[i%SCM_obj_to_int(pstate->nb_processors)];
      p->heap_ptr -= size2;
      ptr = (SCM_obj *)p->heap_ptr;
      ptr[0] = SCM_make_header( size1, SCM_subtype_VECTOR );
      for (j=m; j>0; j--) ptr[j] = SCM_false;
      ptr[1] = result;
      result = SCM_add_type( ptr, SCM_type_SUBTYPED );
      i--;
    }
    barrier_call( do_return, result );
  }
  else
    result = barrier_service();
  return result;
}


SCM_obj X23X23makeDdistributedDvectorDchain( len, size )
SCM_obj len, size;
{ return barrier_call( do_make_distributed_vector_chain, (SCM_obj_to_int( len )<<8)+SCM_obj_to_int( size ) );
}


long do_stats_start( id, arg )
long id;
long arg;
{ stats_start1( id );
  barrier( "DO_STATS_START" );
  return 0;
}


long do_stats_stop( id, arg )
long id;
long arg;
{ barrier( "DO_STATS_STOP1" );
  stats_stop2();
  barrier( "DO_STATS_STOP2" );
  return 0;
}


SCM_obj X23X23statsDstart()
{ barrier_call( do_stats_start, 0L );
  stats_start2();
  return (long)SCM_true;
}


SCM_obj X23X23statsDstop()
{ long result = SCM_int_to_obj( stats_stop1() );
  barrier_call( do_stats_stop, 0L );
  return result;
}


SCM_obj X23X23fatalDheapDoverflow()
{ os_warn( "*** ERROR -- Fatal heap overflow, terminating...\n", 0L ); os_quit();
}


/*---------------------------------------------------------------------------*/


void init_runtime()
{ long i;

  for (i=0; i<(long)MAX_NB_OPEN_FILES; i++) file[i] = -1;

  file[0] = os_stdin;
  file[1] = os_stdout;
  file[2] = os_stderr;

  DEFINE_C_PROC(X23X23gc);
  DEFINE_C_PROC(X23X23barrier);
  DEFINE_C_PROC(X23X23quit);
  DEFINE_C_PROC(X23X23osDfileDopenDinput);
  DEFINE_C_PROC(X23X23osDfileDopenDoutput);
  DEFINE_C_PROC(X23X23osDfileDopenDinputDoutput);
  DEFINE_C_PROC(X23X23osDfileDclose);
  DEFINE_C_PROC(X23X23osDfileDreadDready);
  DEFINE_C_PROC(X23X23osDfileDread);
  DEFINE_C_PROC(X23X23osDfileDwrite);
  DEFINE_C_PROC(X23X23osDfileDblockDread);
  DEFINE_C_PROC(X23X23osDfileDblockDwrite);
  DEFINE_C_PROC(X23X23osDsetDtimerDinterval);
  DEFINE_C_PROC(X23X23osDgetDnextDevent);
  DEFINE_C_PROC(X23X23osDhandleDevent);
  DEFINE_C_PROC(X23X23cpuDtimes);
  DEFINE_C_PROC(X23X23realDtime);
  DEFINE_C_PROC(X23X23loadDobjectDfile);
  DEFINE_C_PROC(X23X23localDcopy);
  DEFINE_C_PROC(X23X23makeDdistributedDpairDchain);
  DEFINE_C_PROC(X23X23makeDdistributedDvectorDchain);
  DEFINE_C_PROC(X23X23statsDstart);
  DEFINE_C_PROC(X23X23statsDstop);
  DEFINE_C_PROC(X23X23fatalDheapDoverflow);

  /* setup OS specific extensions */

  ext_init();

  /* setup other globals */

  if (alloc_global( "##gc-report", &gc_report )) os_quit();
  if (set_global( "##gc-report", (long)SCM_false )) os_quit();
  if (alloc_global( "##exception.read-not-ready", &read_not_ready )) os_quit();
  if (alloc_global( "##exception.write-not-ready", &write_not_ready )) os_quit();
  if (alloc_global( "##exception.gc-finalize", &gc_finalize )) os_quit();
}


/*---------------------------------------------------------------------------*/


void stop()
{ /* can be used as a breakpoint for debugging */
}


void start_program( kernel )
void (*kernel)();
{
  /* start processors */

  if (sstate->debug>=1)
    os_warn( "Starting %d processor(s)\n", SCM_obj_to_int(pstate->nb_processors) );

  if (sstate->debug>=1)
    os_install_trap_handlers( user_intr_proc, timer_intr_proc, io_intr_proc, (void (*)())0 );
  else
    os_install_trap_handlers( user_intr_proc, timer_intr_proc, io_intr_proc, fatal_intr_proc );

  os_flush_caches();

  pstate = pstate->ps[ os_fork_on_processors( SCM_obj_to_int(pstate->nb_processors) ) ];


  /* wait until all processors are ready to go */

  barrier( "STARTUP" );


  /* setup processor state */

  if (sstate->debug>=1)
    os_warn( "Starting processor %d\n", SCM_obj_to_int(pstate->id) );

  pstate->flush_writes = os_flush_writes;

  if (SCM_obj_to_int(pstate->id) == 0) X23X23statsDstart();

  stop();  (*kernel)( table, pstate, os_M68881 );

  if (SCM_obj_to_int(pstate->id) == 0) X23X23statsDstop();
}


/*---------------------------------------------------------------------------*/