/* The bytecode interpreter */

#include <math.h>
#include "alloc.h"
#include "debugger.h"
#include "fail.h"
#include "instruct.h"
#include "memory.h"
#include "minor_gc.h"
#include "misc.h"
#include "mlvalues.h"
#include "prims.h"
#include "signals.h"
#include "stacks.h"
#include "str.h"
#include "unalignd.h"
#ifdef HAS_UI
#include "ui.h"
#endif

#ifdef DEBUG
static long icount = 0;
static void stop_here () {}
#endif

/* Registers for the abstract machine:
	pc         the code pointer
	sp         the stack pointer (grows downward)
        accu       the accumulator
        env        heap-allocated environment
	trapsp     pointer to the current trap frame
        extra_args number of extra arguments provided by the caller

sp is a local copy of the global variable extern_sp. */

extern code_t start_code;

typedef unsigned char opcode_t;

/* Other viewpoints on pc (to read immediate operands) */

#define SHORT  (sizeof(short))
#define LONG   (sizeof(int32))
#define DOUBLE (sizeof(double))

#define s16pc s16(pc)
#define u16pc u16(pc)
#define s32pc s32(pc)
#define u32pc u32(pc)

/* The empty environment */

#define null_env Atom(0)

/* Code for returning from the signal handler */

unsigned char return_from_interrupt[] = { ACC0, RETURN, 1 };

/* GC interface */

#define Setup_for_gc { sp -= 2; sp[0] = accu; sp[1] = env; extern_sp = sp; }
#define Restore_after_gc { accu = sp[0]; env = sp[1]; sp += 2; }
#define Setup_for_c_call { *--sp = env; extern_sp = sp; }
#define Restore_after_c_call { sp = extern_sp; env = *sp++; }

/* GCC 2.0 has labels as first-class values. We take advantage of that
   to provide faster dispatch than the "switch" statement. */

#if defined(__GNUC__) && __GNUC__ >= 2 && !defined(DEBUG)
#define DIRECT_JUMP
#endif

/* The interpreter itself */

value interprete(prog)
     code_t prog;
{

/* Declarations for the registers of the abstract machine.
   The most heavily used registers come first.
   For reasonable performance, "pc" MUST reside in a register.
   Many ``optimizing'' compilers underestimate the importance of "pc",
   and don't put it in a register. 
   For GCC users, I've hand-assigned registers for some architectures. */

#if defined(__GNUC__) && defined(sparc)
  register code_t pc asm("%l0");
  register value accu asm("%l1");
  register value * sp asm("%l2");
#else
#if defined(__GNUC__) && defined(mc68000)
  register code_t pc asm("a5");
  register value accu;
  register value * sp;
#else
#if defined(__GNUC__) && defined(mips)
  register code_t   pc asm("$20");
  register value  accu asm("$21");
  register value * sp asm("$22");
#else
#if defined(__GNUC__) && defined(__alpha__)
  register code_t   pc asm("$11");
  register value  accu asm("$12");
  register value * sp asm("$13");
#else
#if defined(__GNUC__) && defined(hppa)
  register code_t   pc asm("%r11");
  register value  accu asm("%r12");
  register value * sp asm("%r13");
#else        
#if defined(__GNUC__) && defined(i386)
#if defined(MSDOS)
  register code_t pc asm("si");
  register value * sp asm("di");
#else
  register code_t pc asm("%esi");
  register value * sp asm("%edi");
#endif
  register value accu;
#else
  register code_t pc;
  register value accu;
  register value * sp;
#endif
#endif
#endif
#endif
#endif
#endif

  value env;
  int extra_args;
  struct longjmp_buffer * initial_external_raise;
  int initial_sp_offset;
  value * initial_c_roots_head;
  struct longjmp_buffer raise_buf;
  value * modify_dest, modify_newval;
  value tmp;
  int last_instr, cur_instr;

#ifdef DIRECT_JUMP
  static void * jumptable[] = {
#   include "jumptbl.h"
  };
#endif

  double dtmp;

/* #define FREQONE */

#ifdef FREQONE
long freqtable[256];
#include "opnames.h"
{
  int i;
  for (i=0; i<256; i++)
    freqtable[i] = 0;
}
#define INCRFREQ(instr1,instr2) freqtable[instr2]++;
#define DUMPTABLE					\
{							\
  int i;						\
  printf("\n\n");					\
  for (i=0; i<256; i++)					\
    if (freqtable[i])					\
      printf("%.8d %s\n", freqtable[i],			\
                          names_of_instructions[i]);	\
}	
#else
#ifdef FREQTWO
long freqtable[256][256];
#include "opnames.h"
{
  int i1, i2;
  for (i1=0; i1<256; i1++)
    for (i2=0; i2<256; i2++)
      freqtable[i1][i2] = 0;
  last_instr = 0;
}

#define INCRFREQ(instr1,instr2)				\
  freqtable[instr1][instr2]++;				\
  last_instr = cur_instr;

#define DUMPTABLE					\
{							\
  int i1, i2;						\
  printf("\n\n");					\
  for (i1=0; i1<256; i1++)				\
    for (i2=0; i2<256; i2++)				\
      if (freqtable[i1][i2])				\
         printf("%.9d %s/%s\n", freqtable[i1][i2],	\
                names_of_instructions[i1],		\
                names_of_instructions[i2]);		\
}	
#else
#define INCRFREQ(instr1,instr2) /* nothing */
#define DUMPTABLE               /* nothing */
#endif
#endif

  sp = extern_sp;
  pc = prog;
  extra_args = 0;
  env = null_env;
  accu = Val_long(0);
  initial_c_roots_head = c_roots_head;
  initial_sp_offset = stack_high - sp;
  initial_external_raise = external_raise;

  if (setjmp(raise_buf.buf)) {
    c_roots_head = initial_c_roots_head;
    accu = exn_bucket;
    goto raise_exception;
  }
  external_raise = &raise_buf;

#ifdef DEBUG
  log_ptr = log_buffer;
#endif

#ifdef DIRECT_JUMP
# define Instruct(name) lbl_##name
# define Next cur_instr = *pc++; INCRFREQ(last_instr,cur_instr) \
              goto *jumptable[cur_instr]
#else
# define Instruct(name) case name
# define Next break
#endif

#ifdef DIRECT_JUMP
  Next;                         /* Jump to the first instruction */
#else
  while (1) {
#ifdef DEBUG
    if (icount-- == 0) stop_here ();
    *log_ptr++ = pc;
    if (log_ptr >= log_buffer + LOG_BUFFER_SIZE) log_ptr = log_buffer;
    if (trace_flag) disasm_instr(pc);
    Assert(sp >= stack_low);
    Assert(sp <= stack_high);
#endif
    cur_instr = *pc++;
  decode_instruction:
    switch (cur_instr) {
#endif

/* Basic stack operations */

    Instruct(SWAP):  
    { value tmp = accu;
      accu = sp[0];
      sp[0] = tmp;
      Next;
    }

    Instruct(PUSH): 
    Instruct(PUSHACC0): *--sp = accu; Next;
    Instruct(ACC0): accu = sp[0]; Next;

    Instruct(PUSHACC1): *--sp = accu; /* Fallthrough */
    Instruct(ACC1): accu = sp[1]; Next;

    Instruct(PUSHACC2): *--sp = accu; /* Fallthrough */
    Instruct(ACC2): accu = sp[2]; Next;

    Instruct(PUSHACC3): *--sp = accu; /* Fallthrough */
    Instruct(ACC3): accu = sp[3]; Next;

    Instruct(PUSHACC4): *--sp = accu; /* Fallthrough */
    Instruct(ACC4): accu = sp[4]; Next;

    Instruct(PUSHACC5): *--sp = accu; /* Fallthrough */
    Instruct(ACC5): accu = sp[5]; Next;

    Instruct(PUSHACC6): *--sp = accu; /* Fallthrough */
    Instruct(ACC6): accu = sp[6]; Next;

    Instruct(PUSHACC7): *--sp = accu; /* Fallthrough */
    Instruct(ACC7): accu = sp[7]; Next;

    Instruct(PUSHACC): *--sp = accu; /* Fallthrough */
    Instruct(ACCESS): accu = sp[*pc++]; Next;

    Instruct(POP):
      sp += *pc++;
      Next;
    Instruct(ASSIGN):
      sp[*pc++] = accu;
      accu = Val_unit;
      Next;

/* Access in heap-allocated environment */

    Instruct(PUSHENV1): *--sp = accu; /* Fallthrough */
    Instruct(ENV1): accu = Field(env, 1); Next;

    Instruct(PUSHENV2): *--sp = accu; /* Fallthrough */
    Instruct(ENV2): accu = Field(env, 2); Next;

    Instruct(PUSHENV3): *--sp = accu; /* Fallthrough */
    Instruct(ENV3): accu = Field(env, 3); Next;

    Instruct(PUSHENV4): *--sp = accu; /* Fallthrough */
    Instruct(ENV4): accu = Field(env, 4); Next;

    Instruct(PUSHENV5): *--sp = accu; /* Fallthrough */
    Instruct(ENV5): accu = Field(env, 5); Next;

    Instruct(PUSHENV6): *--sp = accu; /* Fallthrough */
    Instruct(ENV6): accu = Field(env, 6); Next;

    Instruct(PUSHENV7): *--sp = accu; /* Fallthrough */
    Instruct(ENV7): accu = Field(env, 7); Next;

    Instruct(PUSHENVACC): *--sp = accu; /* Fallthrough */
    Instruct(ENVACC): accu = Field(env, *pc++); Next;

    Instruct(PUSH_ENV1_APPLY1): 
    { 
      sp -= 4;
      sp[0] = accu;
      sp[1] = (value)pc;
      sp[2] = env;
      sp[3] = Val_long(extra_args);
      extra_args = 0;
      accu = Field(env, 1); 
      goto apply;
    } 
    
    Instruct(PUSH_ENV1_APPLY2): 
    { value arg2 = sp[0];
      sp -= 4;
      sp[0] = accu;
      sp[1] = arg2;
      sp[2] = (value)pc;
      sp[3] = env;
      sp[4] = Val_long(extra_args);
      extra_args = 1;
      accu = Field(env, 1); 
      goto apply;
    } 

    Instruct(PUSH_ENV1_APPLY3): 
    { value arg2 = sp[0];
      value arg3 = sp[1];
      sp -= 4;
      sp[0] = accu;
      sp[1] = arg2;
      sp[2] = arg3;
      sp[3] = (value)pc;
      sp[4] = env;
      sp[5] = Val_long(extra_args);
      extra_args = 2;
      accu = Field(env, 1); 
      goto apply;
    } 

    Instruct(PUSH_ENV1_APPLY4): 
    { value arg2 = sp[0];
      value arg3 = sp[1];
      value arg4 = sp[2];
      sp -= 4;
      sp[0] = accu;
      sp[1] = arg2;
      sp[2] = arg3;
      sp[3] = arg4;
      sp[4] = (value)pc;
      sp[5] = env;
      sp[6] = Val_long(extra_args);
      extra_args = 3;
      accu = Field(env, 1); 
      goto apply;
    } 

    Instruct(PUSH_ENV1_APPTERM1):
    { sp = sp + *pc++ - 2;
      sp[0] = accu;
    } /* Fall through */
    env1_appterm:
      accu = Field(env, 1); 
    appterm:
      pc = Code_val(accu);
      env = accu;
      goto check_signals;

    Instruct(PUSH_ENV1_APPTERM2):
    { value arg2 = sp[0];
      sp = sp + *pc++ - 3;
      sp[0] = accu;
      sp[1] = arg2;
      extra_args += 1;
      goto env1_appterm;
    }

    Instruct(PUSH_ENV1_APPTERM3):
    { value arg2 = sp[0];
      value arg3 = sp[1];
      sp = sp + *pc++ - 4;
      sp[0] = accu;
      sp[1] = arg2;
      sp[2] = arg3;
      extra_args += 2;
      goto env1_appterm;
    }

    Instruct(PUSH_ENV1_APPTERM4):
    { value arg2 = sp[0];
      value arg3 = sp[1];
      value arg4 = sp[2];
      sp = sp + *pc++ - 5;
      sp[0] = accu;
      sp[1] = arg2;
      sp[2] = arg3;
      sp[3] = arg4;
      extra_args += 3;
      goto env1_appterm;
    }

/* Function application */

    Instruct(PUSH_RETADDR): {
      sp -= 3;
      sp[0] = (value) (pc + s16pc);
      sp[1] = env;
      sp[2] = Val_long(extra_args);
      pc += SHORT;
      Next;
    }
    Instruct(APPLY): {
      extra_args = *pc - 1;
      goto apply;
    }
    Instruct(APPLY1): {
      value arg1 = sp[0];
      sp -= 3;
      sp[0] = arg1;
      sp[1] = (value)pc;
      sp[2] = env;
      sp[3] = Val_long(extra_args);
      extra_args = 0;
      goto apply;
    }
    Instruct(APPLY2): {
      value arg1 = sp[0];
      value arg2 = sp[1];
      sp -= 3;
      sp[0] = arg1;
      sp[1] = arg2;
      sp[2] = (value)pc;
      sp[3] = env;
      sp[4] = Val_long(extra_args);
      extra_args = 1;
      goto apply;
    }
    Instruct(APPLY3): {
      value arg1 = sp[0];
      value arg2 = sp[1];
      value arg3 = sp[2];
      sp -= 3;
      sp[0] = arg1;
      sp[1] = arg2;
      sp[2] = arg3;
      sp[3] = (value)pc;
      sp[4] = env;
      sp[5] = Val_long(extra_args);
      extra_args = 2;
      goto apply;
    }
    Instruct(APPLY4): {
      value arg1 = sp[0];
      value arg2 = sp[1];
      value arg3 = sp[2];
      value arg4 = sp[3];
      sp -= 3;
      sp[0] = arg1;
      sp[1] = arg2;
      sp[2] = arg3;
      sp[3] = arg4;
      sp[4] = (value)pc;
      sp[5] = env;
      sp[6] = Val_long(extra_args);
      extra_args = 3;
      goto apply;
    }

    Instruct(APPTERM): {
      int nargs = *pc++;
      int slotsize = *pc++;
      value * newsp;
      int i;
      /* Slide the nargs bottom words of the current frame to the top
         of the frame, and discard the remainder of the frame */
      newsp = sp + slotsize - nargs;
      for (i = nargs - 1; i >= 0; i--) newsp[i] = sp[i];
      sp = newsp;
      extra_args += nargs - 1;
      goto appterm;
    }
    Instruct(APPTERM1): {
      value arg1 = sp[0];
      sp = sp + *pc++ - 1;
      sp[0] = arg1;
      goto appterm;
    }
    Instruct(APPTERM2): {
      value arg1 = sp[0];
      value arg2 = sp[1];
      sp = sp + *pc++ - 2;
      sp[0] = arg1;
      sp[1] = arg2;
      extra_args += 1;
      goto appterm;
    }
    Instruct(APPTERM3): {
      value arg1 = sp[0];
      value arg2 = sp[1];
      value arg3 = sp[2];
      sp = sp + *pc++ - 3;
      sp[0] = arg1;
      sp[1] = arg2;
      sp[2] = arg3;
      extra_args += 2;
      goto appterm;
    }
    Instruct(APPTERM4): {
      value arg1 = sp[0];
      value arg2 = sp[1];
      value arg3 = sp[2];
      value arg4 = sp[3];
      sp = sp + *pc++ - 4;
      sp[0] = arg1;
      sp[1] = arg2;
      sp[2] = arg3;
      sp[3] = arg4;
      extra_args += 3;
      goto appterm;
    }

    Instruct(RETURN1):
      sp += 1;
    return_code:
      if (extra_args > 0) {
        extra_args--;
        pc = Code_val(accu);
        env = accu;
      } else {
        pc = (code_t)(sp[0]);
        env = sp[1];
        extra_args = Long_val(sp[2]);
	sp += 3;
	if (something_to_do) goto process_signal; 
      }
      Next;

    Instruct(RETURN2):
      sp += 2;
      goto return_code;

    Instruct(RETURN):
      sp += *pc++;
      goto return_code;

    Instruct(RESTART): {
      int num_args = Wosize_val(env) - 2;
      int i;
      sp -= num_args;
      for (i = 0; i < num_args; i++) sp[i] = Field(env, i + 2);
      env = Field(env, 1);
      extra_args += num_args;
      Next;
    }

    Instruct(GRAB): {
      int required = *pc++;
      if (extra_args >= required) {
        extra_args -= required;
      } else {
        mlsize_t num_args, i;
        num_args = 1 + extra_args; /* arg1 + extra args */
        Alloc_small(accu, num_args + 2, Closure_tag);
        Field(accu, 1) = env;
        for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i];
        Code_val(accu) = pc - 3; /* Point to the preceding RESTART instr. */
        sp += num_args;
        pc = (code_t)(sp[0]);
        env = sp[1];
        extra_args = Long_val(sp[2]);
        sp += 3;
      }
      Next;
    }

    Instruct(CLOSURE): {
      int nvars = *pc++;
      int i;
      if (nvars > 0) *--sp = accu;
      Alloc_small(accu, 1 + nvars, Closure_tag);
      Code_val(accu) = pc + s16pc;
      for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i];
      sp += nvars;
      pc += SHORT;
      Next;
    }

    Instruct(CLOSREC): {
      int nvars = *pc++;
      int i;
      if (nvars > 0) *--sp = accu;
      Alloc_small(accu, 2 + nvars, Closure_tag);
      Code_val(accu) = pc + s16pc;
      Field(accu, 1) = Val_int(0);
      for (i = 0; i < nvars; i++) Field(accu, i + 2) = sp[i];
      sp += nvars;
      modify(&Field(accu, 1), accu);
      pc += SHORT;
      Next;
    }

/* For recursive definitions */

    Instruct(DUMMY): {
      int size = *pc++ + 1; /* size + 1 to match CLOSURE */
      Alloc_small(accu, size, 0);
      while (size--) Field(accu, size) = Val_long(0);
      Next;
    }
    Instruct(UPDATE): {
      value newval = *sp++;
      mlsize_t size, n;
      size = Wosize_val(newval);
      Assert(size == Wosize_val(accu));
      Tag_val(accu) = Tag_val(newval);
      for (n = 0; n < size; n++) {
        modify(&Field(accu, n), Field(newval, n));
      }
      accu = Val_unit;
      Next;
    }

/* Globals */

    Instruct(PUSH_GETGLOBAL):
      *--sp = accu;
      /* Fallthrough */
    Instruct(GETGLOBAL):
      accu = Field(global_data, u16pc);
      pc += SHORT;
      Next;

    Instruct(PUSH_GETGLOBAL_APPLY1): 
    { sp -= 4;
      sp[0] = accu;
      accu = Field(global_data, u16pc);
      pc += SHORT;
      sp[1] = (value)pc;
      sp[2] = env;
      sp[3] = Val_long(extra_args);
      extra_args = 0;
    }
    apply:
      pc = Code_val(accu);
      env = accu;
      /* Fall through to stack check */

    check_stacks:
      if (sp < stack_threshold) {
        extern_sp = sp;
        realloc_stack();
        sp = extern_sp;
      }
      /* Fall through to signals check */

    check_signals:

    Instruct(CHECK_SIGNALS):    /* accu not preserved */
#ifdef PERIODIC_ACTION_FREQ
      { static int periodic_action_count = 1;
        if (--periodic_action_count == 0) {
          periodic_action_count = PERIODIC_ACTION_FREQ;
          ui_periodic_action();
        }
      }
#endif
#ifdef macintosh
#ifndef __MWERKS__
      { static int spin_count = 1;
        if (--spin_count == 0) { spin_count = 24; SpinCursor ((short) 1); }
      }
#endif
#endif
#if defined(MSDOS) && defined(__GNUC__)
      { static int poll_count = 1;
        if (--poll_count == 0) { poll_count = 500; poll_break(); }
      }
#endif
      if (something_to_do) goto process_signal;
      Next;

    Instruct(PUSH_GETGLOBAL_APPLY2): 
    { value arg2 = sp[0];
      sp -= 4;
      sp[0] = accu;
      sp[1] = arg2;
      accu = Field(global_data, u16pc);
      pc += SHORT;
      sp[2] = (value)pc;
      sp[3] = env;
      sp[4] = Val_long(extra_args);
      extra_args = 1;
      goto apply;
    }

    Instruct(PUSH_GETGLOBAL_APPLY3): 
    { value arg2 = sp[0];
      value arg3 = sp[1];
      sp -= 4;
      sp[0] = accu;
      sp[1] = arg2;
      sp[2] = arg3;
      accu = Field(global_data, u16pc);
      pc += SHORT;
      sp[3] = (value)pc;
      sp[4] = env;
      sp[5] = Val_long(extra_args);
      extra_args = 2;
      goto apply;
    }
    Instruct(PUSH_GETGLOBAL_APPLY4): 
    { value arg2 = sp[0];
      value arg3 = sp[1];
      value arg4 = sp[2];
      sp -= 4;
      sp[0] = accu;
      sp[1] = arg2;
      sp[2] = arg3;
      sp[3] = arg4;
      accu = Field(global_data, u16pc);
      pc += SHORT;
      sp[4] = (value)pc;
      sp[5] = env;
      sp[6] = Val_long(extra_args);
      extra_args = 3;
      goto apply;
    }

    Instruct(PUSH_GETGLOBAL_APPTERM1):
      /* opcode, popnbr, globalindex */
      sp = sp + *pc++ - 2;
      sp[0] = accu;
    getglobal_appterm:
      accu = Field(global_data, u16pc);
      pc = Code_val(accu);
      env = accu;
      goto check_signals;
    
    Instruct(PUSH_GETGLOBAL_APPTERM2):
    { value arg2 = sp[0];
      sp = sp + *pc++ - 3;
      sp[0] = accu;
      sp[1] = arg2;
      extra_args += 1;
      goto getglobal_appterm;
    }

    Instruct(PUSH_GETGLOBAL_APPTERM3):
    { value arg2 = sp[0];
      value arg3 = sp[1];
      sp = sp + *pc++ - 4;
      sp[0] = accu;
      sp[1] = arg2;
      sp[2] = arg3;
      extra_args += 2;
      goto getglobal_appterm;
    }

    Instruct(PUSH_GETGLOBAL_APPTERM4):
    { value arg2 = sp[0];
      value arg3 = sp[1];
      value arg4 = sp[2];
      sp = sp + *pc++ - 5;
      sp[0] = accu;
      sp[1] = arg2;
      sp[2] = arg3;
      sp[3] = arg4;
      extra_args += 3;
      goto getglobal_appterm;
    }

    Instruct(SETGLOBAL):
      modify(&Field(global_data, u16pc), accu);
      accu = Val_unit; /* ? */
      pc += SHORT;
      Next;

/* Allocation of blocks */

    Instruct(PUSHATOM0):
      *--sp = accu;
      /* Fallthrough */
    Instruct(ATOM0):
      accu = Atom(0); Next;

    Instruct(ATOM1):
      accu = Atom(1); Next;
    Instruct(ATOM2):
      accu = Atom(2); Next;
    Instruct(ATOM3):
      accu = Atom(3); Next;
    Instruct(ATOM4):
      accu = Atom(4); Next;
    Instruct(ATOM5):
      accu = Atom(5); Next;
    Instruct(ATOM6):
      accu = Atom(6); Next;
    Instruct(ATOM7):
      accu = Atom(7); Next;
    Instruct(ATOM8):
      accu = Atom(8); Next;
    Instruct(ATOM9):
      accu = Atom(9); Next;

    Instruct(PUSHATOM):
      *--sp = accu;
      /* Fallthrough */
    Instruct(ATOM):
      accu = Atom(*pc++); Next;

    Instruct(MAKEBLOCK):
      { header_t hdr;
        mlsize_t size;
	tag_t tag;
	int i;
	
	hdr = u32pc;
	pc += LONG;
	size = Wosize_hd(hdr);
	tag = Tag_hd(hdr);
        if (size < Max_young_wosize) {
          Alloc_small(tmp, size, tag);
          Field(tmp, size-1) = accu;
          for (i = size-2; i >= 0; i--) Field(tmp, i) = *sp++;
          accu = tmp;
        } else {
          Setup_for_gc;
          tmp = alloc_shr (size, tag);
          Restore_after_gc;
          initialize (&Field(tmp, size-1), accu);
          for (i = size-2; i >= 0; i--) initialize (&Field(tmp, i), *sp++);
          accu = tmp;
        }
	Next;
      }
      
    Instruct(MAKEBLOCK1): {
      tag_t tag = *pc++;
      value block;
      Alloc_small(block, 1, tag);
      Field(block, 0) = accu;
      accu = block;
      Next;
    }
    Instruct(MAKEBLOCK2): {
      tag_t tag = *pc++;
      value block;
      Alloc_small(block, 2, tag);
      Field(block, 0) = sp[0];
      Field(block, 1) = accu;
      sp += 1;
      accu = block;
      Next;
    }
    Instruct(MAKEBLOCK3): {
      tag_t tag = *pc++;
      value block;
      Alloc_small(block, 3, tag);
      Field(block, 0) = sp[1];
      Field(block, 1) = sp[0];
      Field(block, 2) = accu;
      sp += 2;
      accu = block;
      Next;
    }
    Instruct(MAKEBLOCK4): {
      tag_t tag = *pc++;
      value block;
      Alloc_small(block, 4, tag);
      Field(block, 0) = sp[2];
      Field(block, 1) = sp[1];
      Field(block, 2) = sp[0];
      Field(block, 3) = accu;
      sp += 3;
      accu = block;
      Next;
    }

/* Access to components of blocks */

    Instruct(GETFIELD0):
      accu = Field(accu, 0); Next;
    Instruct(GETFIELD1):
      accu = Field(accu, 1); Next;
    Instruct(GETFIELD2):
      accu = Field(accu, 2); Next;
    Instruct(GETFIELD3):
      accu = Field(accu, 3); Next;
    Instruct(GETFIELD):
      accu = Field(accu, u16pc); pc += SHORT; Next;

    Instruct(GETFIELD0_0):
      accu = Field(accu, 0); 
      accu = Field(accu, 0); 
      Next;

    Instruct(GETFIELD0_1):
      accu = Field(accu, 0); 
      accu = Field(accu, 1); 
      Next;

    Instruct(GETFIELD1_0):
      accu = Field(accu, 1); 
      accu = Field(accu, 0); 
      Next;

    Instruct(GETFIELD1_1):
      accu = Field(accu, 1); 
      accu = Field(accu, 1); 
      Next;

    Instruct(SETFIELD0):
      modify_dest = &Field(*sp++, 0);
      modify_newval = accu;
    modify:
      Modify(modify_dest, modify_newval);
      accu = Val_unit; /* Atom(0); */
      Next;
    Instruct(SETFIELD1):
      modify_dest = &Field(*sp++, 1);
      modify_newval = accu;
      goto modify;
    Instruct(SETFIELD2):
      modify_dest = &Field(*sp++, 2);
      modify_newval = accu;
      goto modify;
    Instruct(SETFIELD3):
      modify_dest = &Field(*sp++, 3);
      modify_newval = accu;
      goto modify;
    Instruct(SETFIELD):
      modify_dest = &Field(*sp++, u16pc);
      pc += SHORT;
      modify_newval = accu;
      goto modify;

/* Array operations */

    Instruct(VECTLENGTH):
      accu = Val_long(Wosize_val(accu));
      Next;
    Instruct(GETVECTITEM):
      accu = Field(sp[0], Long_val(accu));
      sp += 1;
      Next;
    Instruct(SETVECTITEM):
      modify_dest = &Field(sp[1], Long_val(sp[0]));
      modify_newval = accu;
      sp += 2;
      goto modify;

/* String operations */

    Instruct(GETSTRINGCHAR):
      accu = Val_int(Byte_u(sp[0], Long_val(accu)));
      sp += 1;
      Next;
    Instruct(SETSTRINGCHAR):
      Byte_u(sp[1], Long_val(sp[0])) = Int_val(accu);
      accu = Atom(0);
      sp += 2;
      Next;

/* Branches and conditional branches */

#define branch() pc += s16pc

    Instruct(BRANCH):
      branch(); Next;
    Instruct(BRANCHIF):
      if (Tag_val(accu) != 0) branch(); else pc += SHORT;
      Next;
    Instruct(BRANCHIFNOT):
      if (Tag_val(accu) == 0) branch(); else pc += SHORT;
      Next;
    Instruct(POPBRANCHIFNOT):
      tmp = accu;
      accu = *sp++;
      if (Tag_val(tmp) == 0) branch(); else pc += SHORT;
      Next;
    Instruct(BRANCHIFNEQTAG):
      if (Tag_val(accu) != *pc++) branch(); else pc += SHORT;
      Next;
    Instruct(SWITCH):
      Assert(Long_val(accu) >= 0 && Long_val(accu) < *pc);
      pc++;
      pc += s16(pc + accu - 1);
      Next;
    Instruct(BOOLNOT):
      accu = Atom(Tag_val(accu) == 0); Next;
      

/* Exceptions */

    Instruct(PUSHTRAP):
      sp -= 4;
      Trap_pc(sp) = pc + s16pc;
      Trap_link(sp) = trapsp;
      sp[2] = env;
      sp[3] = Val_long(extra_args);
      trapsp = sp;
      pc += SHORT;
      Next;

    Instruct(POPTRAP):
      /* We should check here if a signal is pending, to preserve the
         semantics of the program w.r.t. exceptions. Unfortunately,
         process_signal destroys the accumulator, and there is no
         convenient way to preserve it... */
      trapsp = Trap_link(sp);
      sp += 4;
      Next;

    raise_exception:			/* An external raise jumps here */

    Instruct(RAISE):            /* arg */
      sp = trapsp;
      if (sp >= stack_high - initial_sp_offset) {
        exn_bucket = accu;
        external_raise = initial_external_raise;
        longjmp(external_raise->buf, 1);
      }
      pc = Trap_pc(sp);
      trapsp = Trap_link(sp);
      env = sp[2];
      extra_args = Long_val(sp[3]);
      sp += 4;
      Next;

    process_signal:
      something_to_do = 0;
      if (force_minor_flag){
	force_minor_flag = 0;
	Setup_for_gc;
	minor_collection ();
	Restore_after_gc;
      }
      /* If a signal arrives between the following two instructions,
         it will be lost. */
      { int signal_number = signal_is_pending;
        signal_is_pending = 0;
        if (signal_number) {
          /* e -- to save accu, why not?:
           sp -= 8;
           sp[0] = Val_int(signal_number);
           sp[1] = (value) return_from_interrupt;
           sp[2] = Atom(0);
           sp[3] = 0;
           sp[4] = accu;
           sp[5] = (value) pc;
           sp[6] = env;
           sp[7] = Val_long(extra_args);
           instead of...
	   */
          /* Push a return frame to the current code location */
          sp -= 4;
          sp[0] = Val_int(signal_number);
          sp[1] = (value) pc;
          sp[2] = env;
          sp[3] = Val_long(extra_args);
          /* Branch to the signal handler */
          /* e -- signal_handler should be a closure, but isn't in 1.31.
          env = (value )signal_handler;  // env = Field(signal_handlers, signal_number); 
          pc = Code_val(env);
          I'm lazy, so for now... */
          env = null_env;
          pc = signal_handler;
          /* */
          extra_args = 0;
        }
      }
      Next;

/* Calling C functions */

    Instruct(C_CALL1):
      Setup_for_c_call;
      accu = (cprim[u16pc])(accu);
      Restore_after_c_call;
      pc += SHORT;
      Next;
    Instruct(C_CALL2):
      Setup_for_c_call;
      /* sp[0] temporarily holds the environment pointer */
      accu = (cprim[u16pc])(sp[1], accu);
      Restore_after_c_call;
      pc += SHORT;
      sp += 1;
      Next;
    Instruct(C_CALL3):
      Setup_for_c_call;
      accu = (cprim[u16pc])(sp[2], sp[1], accu);
      Restore_after_c_call;
      pc += SHORT;
      sp += 2;
      Next;
    Instruct(C_CALL4):
      Setup_for_c_call;
      accu = (cprim[u16pc])(sp[3], sp[2], sp[1], accu);
      Restore_after_c_call;
      pc += SHORT;
      sp += 3;
      Next;
    Instruct(C_CALL5):
      Setup_for_c_call;
      accu = (cprim[u16pc])(sp[4], sp[3], sp[2], sp[1], accu);
      Restore_after_c_call;
      pc += SHORT;
      sp += 4;
      Next;
    Instruct(C_CALLN):
      { int n = *pc++;
        value * args;
	int i;
        *--sp = accu;
        Setup_for_c_call;
	args = (value*)malloc(n * sizeof(value));
	for (i = 0; i < n; i++) 
	  args[i] = sp[n-i];
        accu = (cprim[u16pc])(args, n);
        Restore_after_c_call;
        pc += SHORT;
	free(args);
        sp += n;
        Next; }

/* small values */

    Instruct(CONSTBYTE): accu = *pc++;  Next;

    Instruct(CONSTSHORT): accu = s16pc; pc += SHORT; Next;

/* Integer constants */

    Instruct(PUSHCONST0): *--sp = accu; /* Fallthrough */
    Instruct(CONST0): accu = Val_int(0); Next;

    Instruct(PUSHCONST1): *--sp = accu; /* Fallthrough */
    Instruct(CONST1): accu = Val_int(1); Next;

    Instruct(PUSHCONST2): *--sp = accu; /* Fallthrough */
    Instruct(CONST2): accu = Val_int(2); Next;

    Instruct(PUSHCONST3): *--sp = accu; /* Fallthrough */
    Instruct(CONST3): accu = Val_int(3); Next;

    Instruct(PUSHCONSTINT): *--sp = accu; /* Fallthrough */
    Instruct(CONSTINT):
      accu = Val_int(s32pc);
      pc += LONG;
      Next;

/* Unsigned integer arithmetic modulo 2^(wordsize-1) */

    Instruct(ADDINT):		/* Modified for Moscow ML: unsigned */
      accu = (unsigned long) ((unsigned long) *sp++ 
			      + (unsigned long) (accu - 1)); Next;
    Instruct(SUBINT):		/* unsigned */
      accu = (unsigned long) ((unsigned long) *sp++ 
			      - (unsigned long) (accu - 1)); Next;
    Instruct(MULINT):		/* unsigned */
      accu = (unsigned long) (1 + (unsigned long) (*sp++ >> 1) 
			      * (unsigned long) (accu - 1)); Next;
    Instruct(DIVINT):		/* unsigned */
      tmp = accu - 1;
      if (tmp == 0) {
        accu = Atom(SMLEXN_DIV);
        goto raise_exception;
      }
      accu = Val_long((unsigned long) ((unsigned long) (*sp++ - 1) 
				       / (unsigned long) tmp));
      Next;

    Instruct(MODINT):
      tmp = accu - 1;
      if (tmp == 0) {
        accu = Atom(SMLEXN_DIV);
        goto raise_exception;
      }
      accu = (unsigned long) (1 + (unsigned long) (*sp++ - 1) 
			      % (unsigned long) tmp);
      Next;

    Instruct(ANDINT):
      accu &= *sp++; Next;
    Instruct(ORINT):
      accu |= *sp++; Next;
    Instruct(XORINT):
      accu = 1 + (accu ^ *sp++); Next;
    Instruct(SHIFTLEFTINT):
      accu = 1 + ((*sp++ - 1) << Long_val(accu)); Next;
    Instruct(SHIFTRIGHTINTSIGNED):
      accu = 1 | ((*sp++ - 1) >> Long_val(accu)); Next;
    Instruct(SHIFTRIGHTINTUNSIGNED):
      accu = 1 | ((unsigned long)(*sp++ - 1) >> Long_val(accu)); Next;
      
#define inttest(name1,name2,tst)					     \
    Instruct(name1):							     \
      accu = Atom(*sp++ tst accu);					     \
      Next;								     \
    Instruct(name2):							     \
      if (*sp++ tst accu) { branch(); } else { pc += SHORT; }                \
      Next;
      
      inttest(EQ,BRANCHIFEQ,==);
      inttest(NEQ,BRANCHIFNEQ,!=);
      inttest(LTINT,BRANCHIFLT,<);
      inttest(GTINT,BRANCHIFGT,>);
      inttest(LEINT,BRANCHIFLE,<=);
      inttest(GEINT,BRANCHIFGE,>=);

    Instruct(TAGOF):
      accu = Val_long(Tag_val(accu));
      Next;

#define unsigntest(name, tst)    					\
    Instruct(name):							\
      accu = Atom((unsigned)(*sp++) tst (unsigned)accu);		\
      Next;								\

      unsigntest(EQUNSIGN,==);
      unsigntest(NEQUNSIGN,!=);
      unsigntest(LTUNSIGN,<);
      unsigntest(GTUNSIGN,>);
      unsigntest(LEUNSIGN,<=);
      unsigntest(GEUNSIGN,>=);

    Instruct(BRANCHINTERVAL):
      { value low_bound, high_bound;
        high_bound = accu;
        low_bound = *sp++;
        accu = *sp++;
        if (accu < low_bound) {
          branch();
          Next;
        }
        pc += SHORT;
        if (accu > high_bound) {
          branch();
          Next;
        } 
        pc += SHORT;
        accu = accu - low_bound + 1;
        Next;
      }

    /* --- Moscow SML changes begin --- */

#define Check_float(dval) \
   if ((dval > maxdouble) || (dval < -maxdouble)) \
      { accu = Atom(float_exn); goto raise_exception; }

    Instruct(FLOATOFINT):
	dtmp = (double) Long_val(accu); goto float_done;

    Instruct(SMLNEGFLOAT):
	float_exn = SMLEXN_OVF;
	dtmp = -Double_val(accu);
	Check_float(dtmp); goto float_done;

    Instruct(SMLADDFLOAT):
	float_exn = SMLEXN_OVF;
	dtmp = Double_val(*sp++) + Double_val(accu);
	Check_float(dtmp); goto float_done;

    Instruct(SMLSUBFLOAT):
	float_exn = SMLEXN_OVF;
	dtmp = Double_val(*sp++) - Double_val(accu);
	Check_float(dtmp); goto float_done;

    Instruct(SMLMULFLOAT):
	float_exn = SMLEXN_OVF;
	dtmp = Double_val(*sp++) * Double_val(accu);
	Check_float(dtmp); goto float_done;

    Instruct(SMLDIVFLOAT):
	float_exn = SMLEXN_OVF;
	dtmp = Double_val(accu);
	if (dtmp == 0) {
	    accu = Atom(SMLEXN_DIV);
	    goto raise_exception;
	}
	dtmp = Double_val(*sp++) / dtmp;
	Check_float(dtmp); /* Fallthrough */
    float_done:
	Alloc_small(tmp, Double_wosize, Double_tag);
	Store_double_val(tmp, dtmp);
	accu = tmp;
	Next;

    /* --- Moscow SML changes end --- */
      
    Instruct(INTOFFLOAT):
      accu = Val_long((long)Double_val(accu)); Next;
      
#define floattest(name, tst)    					     \
    Instruct(name):							     \
      accu = Atom(Double_val(*sp++) tst Double_val(accu));		     \
      Next;
      
      floattest(EQFLOAT,==);
      floattest(NEQFLOAT,!=);
      floattest(LTFLOAT,<);
      floattest(GTFLOAT,>);
      floattest(LEFLOAT,<=);
      floattest(GEFLOAT,>=);
      
    Instruct(STRINGLENGTH):
      accu = Val_long(string_length(accu));
      Next;

#define stringtest(name, tst)                                                \
    Instruct(name):                                                          \
      accu = Atom(compare_strings(*sp++, accu) tst Val_long(0));             \
      Next;
      
      stringtest(EQSTRING,==);
      stringtest(NEQSTRING,!=);
      stringtest(LTSTRING,<);
      stringtest(GTSTRING,>);
      stringtest(LESTRING,<=);
      stringtest(GESTRING, >=);

    Instruct(MAKEVECTOR):
      { mlsize_t size = Long_val(sp[0]);
        /* Make sure that the object referred to by sp[0] survives gc: */
        sp[0] = accu;
        if (size == 0)
          accu = Atom(0);
        else if (size < Max_young_wosize){
	  Alloc_small (accu, size, 0);
	  do {size--; Field (accu, size) = *sp;} while (size != 0);
	}else if (Is_block (*sp) && Is_young (*sp)){
	  Setup_for_gc;
	  minor_collection ();
	  tmp = alloc_shr (size, 0);
	  Restore_after_gc;
          accu = tmp;
	  do {size--; Field (accu, size) = *sp;} while (size != 0);
	}else{
	  Setup_for_gc;
	  tmp = alloc_shr (size, 0);
	  Restore_after_gc;
          accu = tmp;
	  do {size--; initialize(&Field(accu, size), *sp);} while (size != 0);
	}
	sp++;
	Next;
      }

/* --- Additional instructions for Moscow SML --- */

    Instruct(SMLNEGINT):
      tmp =  - Long_val(accu);
      accu = Val_long(tmp);
      if( Long_val(accu) != tmp ) {
        accu = Atom(SMLEXN_OVF);
        goto raise_exception;
      }
      Next;
    Instruct(SMLSUCCINT):
      tmp =  Long_val(accu) + 1;
      accu = Val_long(tmp);
      if( Long_val(accu) != tmp ) {
        accu = Atom(SMLEXN_OVF);
        goto raise_exception;
      }
      Next;
    Instruct(SMLPREDINT):
      tmp =  Long_val(accu) - 1;
      accu = Val_long(tmp);
      if( Long_val(accu) != tmp ) {
        accu = Atom(SMLEXN_OVF);
        goto raise_exception;
      }
      Next;
    Instruct(SMLADDINT):
      tmp = Long_val(*sp++) + Long_val(accu);
      accu = Val_long(tmp);
      if( Long_val(accu) != tmp ) goto raise_sum;
      Next;
      raise_sum:
        accu = Atom(SMLEXN_OVF);
        goto raise_exception;
    Instruct(SMLSUBINT):
      tmp = Long_val(*sp++) - Long_val(accu);
      accu = Val_long(tmp);
      if( Long_val(accu) != tmp ) goto raise_diff;
      Next;
      raise_diff:
        accu = Atom(SMLEXN_OVF);
        goto raise_exception;

#define ChunkLen (4 * sizeof(value) - 1)
#define MaxChunk ((1L << ChunkLen) - 1)

    Instruct(SMLMULINT):
      { register long x, y;
        register int isNegative = 0;
        x = Long_val(*sp++);
        y = Long_val(accu);
        if( x < 0 ) { x = -x; isNegative = 1; }
        if( y < 0 ) { y = -y; isNegative = !isNegative; }
        if( y > x ) { tmp = y; y = x; x = tmp; }
        if( y > MaxChunk ) goto raise_prod;
        if( x <= MaxChunk )
          { accu = Val_long(isNegative?(-(x * y)):(x * y)); }
        else /* x > MaxChunk */
          { tmp = (x >> ChunkLen) * y;
            if( tmp > MaxChunk + 1) goto raise_prod;
            tmp = (tmp << ChunkLen) + (x & MaxChunk) * y;
            if( isNegative ) tmp = - tmp;
            accu = Val_long(tmp);
            if( Long_val(accu) != tmp ) goto raise_prod;
          }
      }
      Next;
      raise_prod :
        accu = Atom(SMLEXN_OVF);
        goto raise_exception;

    Instruct(SMLDIVINT):
      tmp = Long_val(accu);
      accu = Long_val(*sp++);
      if (tmp == 0) 
	{ accu = Atom(SMLEXN_DIV);
	  goto raise_exception;
	}
      if( tmp < 0 ) { accu = - accu; tmp = -tmp; }
      if( accu >= 0 )
        { tmp = accu / tmp; }
      else
        { accu = - accu;
          if( accu % tmp == 0 )
            tmp = - (accu /tmp);
          else
            tmp = - (accu / tmp) - 1;
        }
      accu = Val_long(tmp);
      if( Long_val(accu) != tmp ) 
	{ accu = Atom(SMLEXN_OVF);
	  goto raise_exception;
	}
      Next;

    Instruct(SMLMODINT):
      { register long y;
      y = tmp = Long_val(accu);
      accu = Long_val(*sp++);
      if (tmp == 0) 
	{ accu = Atom(SMLEXN_DIV);
	  goto raise_exception;
	}
      if( tmp < 0 ) { accu = -accu; tmp = -tmp; }
      if( accu >= 0 )
        tmp = accu % tmp;
      else
        { accu = (-accu) % tmp;
          tmp = ( accu == 0 )?( 0 ):( tmp - accu );
        }
      if( y < 0 ) tmp = -tmp;
      accu = Val_long(tmp);
      if( Long_val(accu) != tmp ) 
	{ accu = Atom(SMLEXN_OVF);
	  goto raise_exception;
	}
      }
      Next;

    Instruct(MAKEREFVECTOR):
      { mlsize_t size = Long_val(sp[0]);
        sp[0] = accu;
        if (size == 0)
          accu = Atom(Reference_tag);
        else if (size < Max_young_wosize){
          Alloc_small (accu, size, Reference_tag);
	  do {size--; Field (accu, size) = *sp;} while (size != 0);
	}else if (Is_block (*sp) && Is_young (*sp)){
	  Setup_for_gc;
	  minor_collection ();
          tmp = alloc_shr (size, Reference_tag);
	  Restore_after_gc;
          accu = tmp;
	  do {size--; Field (accu, size) = *sp;} while (size != 0);
	}else{
	  Setup_for_gc;
          tmp = alloc_shr (size, Reference_tag);
	  Restore_after_gc;
          accu = tmp;
	  do {size--; initialize(&Field(accu, size), *sp);} while (size != 0);
	}
	sp++;
	Next;
      }

    Instruct(SMLQUOTINT):
      tmp = accu - 1;
      if (tmp == 0) 
	{ accu = Atom(SMLEXN_DIV);
	  goto raise_exception;
	}
      tmp = (*sp++ - 1) / tmp;
      accu = Val_long(tmp);
      if( Long_val(accu) != tmp ) 
	{ accu = Atom(SMLEXN_OVF);
	  goto raise_exception;
	}
      Next;
    Instruct(SMLREMINT):
      tmp = accu - 1;
      if (tmp == 0) {
        accu = Atom(SMLEXN_DIV);
        goto raise_exception;
      }
      accu = 1 + (*sp++ - 1) % tmp;
      Next;

/* --- End of additional instructions for Moscow SML --- */

/* Machine control */

    Instruct(STOP):
      extern_sp = sp;
      external_raise = initial_external_raise;
      DUMPTABLE
      return accu;
      
#ifdef DIRECT_JUMP
    lbl_EVENT:
#else
    default:
#endif

      fatal_error("bad opcode");

#ifndef DIRECT_JUMP
    }
  }
#endif
}

static opcode_t callback1_code[] = { ACC1, APPLY1, POP, 1, STOP };
static opcode_t callback2_code[] = { ACC2, APPLY2, POP, 1, STOP };
static opcode_t callback3_code[] = { ACC3, APPLY3, POP, 1, STOP };

value callback(closure, arg)
     value closure, arg;
{
  value res;
  extern_sp -= 2;
  extern_sp[0] = arg;
  extern_sp[1] = closure;
  /* callback_depth++; */
  res = interprete(callback1_code, sizeof(callback1_code));
  /* callback_depth--; */
  return res;
}

value callback2(closure, arg1, arg2)
     value closure, arg1, arg2;
{
  value res;
  extern_sp -= 3;
  extern_sp[0] = arg1;
  extern_sp[1] = arg2;
  extern_sp[2] = closure;
  /* callback_depth++; */
  res = interprete(callback2_code, sizeof(callback2_code));
  /* callback_depth--; */
  return res;
}

value callback3(closure, arg1, arg2, arg3)
     value closure, arg1, arg2, arg3;
{
  value res;
  extern_sp -= 4;
  extern_sp[0] = arg1;
  extern_sp[1] = arg2;
  extern_sp[2] = arg3;
  extern_sp[3] = closure;
  /* callback_depth++; */
  res = interprete(callback3_code, sizeof(callback3_code));
  /* callback_depth--; */
  return res;
}

/* end */