home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / C / Applications / Moscow ML 1.31 / source code / mosml / src / runtime / interp.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-07-03  |  29.4 KB  |  1,178 lines  |  [TEXT/R*ch]
  1. /* The bytecode interpreter */
  2.  
  3. #include <math.h>
  4. #include "alloc.h"
  5. #include "debugger.h"
  6. #include "fail.h"
  7. #include "instruct.h"
  8. #include "memory.h"
  9. #include "minor_gc.h"
  10. #include "misc.h"
  11. #include "mlvalues.h"
  12. #include "prims.h"
  13. #include "signals.h"
  14. #include "stacks.h"
  15. #include "str.h"
  16. #include "unalignd.h"
  17. #include "debugcom.h"
  18. #ifdef HAS_UI
  19. #include "ui.h"
  20. #endif
  21.  
  22. #ifdef DEBUG
  23. static long icount = 0;
  24. static void stop_here () {}
  25. #endif
  26.  
  27. /* Registers for the abstract machine */
  28.  
  29. /*    pc      the code pointer
  30.     asp      the stack pointer for the argument stack (grows downward)
  31.     rsp      the stack pointer for the return stack (grows downward)
  32.     tp      pointer to the current trap frame
  33.     env      the remanent part (heap-allocated) of the environment
  34.      cache_size the number of entries in the volatile part of the environment
  35.     accu      the accumulator
  36.  
  37. "asp" and "rsp" are local copies of the global variables
  38. "extern_asp" and "extern_rsp".
  39.  
  40. */
  41.  
  42. extern value global_data;
  43. extern code_t start_code;
  44.  
  45. /* Other viewpoints on rsp */
  46.  
  47. #define retsp  ((struct return_frame *) rsp)
  48. #define trapsp ((struct trap_frame   *) rsp)
  49.  
  50. #define push_ret_frame() \
  51.   (rsp = (value *) ((char *) rsp - sizeof(struct return_frame)))
  52. #define pop_ret_frame() \
  53.   (rsp = (value *) ((char *) rsp + sizeof(struct return_frame)))
  54. #define push_trap_frame() \
  55.   (rsp = (value *) ((char *) rsp - sizeof(struct trap_frame)))
  56. #define pop_trap_frame() \
  57.   (rsp = (value *) ((char *) rsp + sizeof(struct trap_frame)))
  58.  
  59. /* Other viewpoints on pc (to read immediate operands) */
  60.  
  61. #define SHORT  (sizeof(short))
  62. #define LONG   (sizeof(int32))
  63. #define DOUBLE (sizeof(double))
  64.  
  65. #define s16pc s16(pc)
  66. #define u16pc u16(pc)
  67. #define s32pc s32(pc)
  68. #define u32pc u32(pc)
  69.  
  70. /* The empty environment */
  71.  
  72. #define null_env Atom(0)
  73.  
  74. /* Code for returning from a signal handler */
  75.  
  76. unsigned char return_from_interrupt[] = { POP, RETURN };
  77.  
  78. /* To save and restore registers around GC calls */
  79.  
  80. #define Setup_for_gc                                 \
  81.   { push_ret_frame();                                 \
  82.     retsp->env = env;                                 \
  83.     retsp->cache_size = cache_size;                         \
  84.     *--asp = accu;                                 \
  85.     extern_asp = asp; extern_rsp = rsp;                         \
  86.   }
  87.  
  88. #define Restore_after_gc                             \
  89.   { accu = *asp++;                                 \
  90.     env = retsp->env;                                 \
  91.     pop_ret_frame ();                                 \
  92.   }
  93.  
  94. /* To save and restore registers around C primitive calls. */
  95.  
  96. #define Setup_for_c_call                                                     \
  97.   { push_ret_frame();                                                        \
  98.     retsp->env = env;                                                        \
  99.     retsp->cache_size = cache_size;                                          \
  100.     extern_asp = asp;                                                        \
  101.     extern_rsp = rsp;                                                        \
  102.   }
  103. #define Restore_after_c_call                                                 \
  104.   { asp = extern_asp;                                                        \
  105.     rsp = extern_rsp;                                                        \
  106.     env = retsp->env;                                                        \
  107.     pop_ret_frame();                                                         \
  108.   }
  109.  
  110. /* To heap-allocate the whole environment */
  111.  
  112. #define heapify_env()                                 \
  113. {                                         \
  114.   mlsize_t env_size = Wosize_val(env);                         \
  115.   mlsize_t new_size = env_size + cache_size;                     \
  116.   value * from, * to;                                 \
  117.                                          \
  118.   Alloc_small(tmp,  new_size, 0);                         \
  119.   for(to = Op_val(tmp); cache_size > 0; cache_size--) *to++ = *rsp++;         \
  120.   for(from = Op_val(env); env_size > 0; env_size--  ) *to++ = *from++;         \
  121.   env = tmp;                                     \
  122. }
  123.  
  124. /* GCC 2.0 has labels as first-class values. We take advantage of that
  125.    to provide faster dispatch than the "switch" statement. */
  126.  
  127. #if defined(__GNUC__) && __GNUC__ >= 2 && !defined(DEBUG)
  128. #define DIRECT_JUMP
  129. #endif
  130.  
  131. /* The interpreter itself */
  132.  
  133. value interprete(prog)
  134.      code_t prog;
  135. {
  136. /* Declarations for the registers of the abstract machine.
  137.    The most heavily used registers come first.
  138.    For reasonable performance, "pc" MUST reside in a register.
  139.    Many ``optimizing'' compilers underestimate the importance of "pc",
  140.    and don't put it in a register. 
  141.    For GCC users, I've hand-assigned registers for some architectures. */
  142.  
  143. #if defined(__GNUC__) && defined(sparc)
  144.   register code_t pc asm("%l0");
  145.   register value accu asm("%l1");
  146.   register value * asp asm("%l2");
  147.   register value * rsp asm("%l3");
  148. #else
  149. #if defined(__GNUC__) && defined(mc68000)
  150.   register code_t pc asm("a5");
  151.   register value accu;
  152.   register value * asp;
  153.   register value * rsp;
  154. #else
  155. #if defined(__GNUC__) && defined(mips)
  156.   register code_t   pc asm("$20");
  157.   register value  accu asm("$21");
  158.   register value * asp asm("$22");
  159.   register value * rsp asm("$23");
  160. #else
  161. #if defined(__GNUC__) && defined(__alpha__)
  162.   register code_t   pc asm("$11");
  163.   register value  accu asm("$12");
  164.   register value * asp asm("$13");
  165.   register value * rsp asm("$14");
  166. #else
  167. #if defined(__GNUC__) && defined(hppa)
  168.   register code_t   pc asm("%r11");
  169.   register value  accu asm("%r12");
  170.   register value * asp asm("%r13");
  171.   register value * rsp asm("%r14");
  172. #else        
  173. #if defined(__GNUC__) && defined(i386)
  174. #if defined(MSDOS)
  175.   register code_t pc asm("si");
  176. #else
  177.   register code_t pc asm("%esi");
  178. #endif
  179.   register value accu;
  180.   register value * asp;
  181.   register value * rsp;
  182. #else
  183.   register code_t pc;
  184.   register value accu;
  185.   register value * asp;
  186.   register value * rsp;
  187. #endif
  188. #endif
  189. #endif
  190. #endif
  191. #endif
  192. #endif
  193.   int cur_instr;
  194.   int cache_size;
  195.   value env;
  196.   value tmp;
  197.   struct longjmp_buffer * initial_external_raise;
  198.   int initial_rsp_offset;
  199.   value * initial_c_roots_head;
  200.   struct longjmp_buffer raise_buf;
  201.  
  202. #ifdef DIRECT_JUMP
  203.   static void * jumptable[] = {
  204. #   include "jumptbl.h"
  205.   };
  206. #endif
  207.  
  208.   double dtmp;
  209.  
  210.   asp = extern_asp;
  211.   rsp = extern_rsp;
  212.   pc = prog;
  213.   env = null_env;
  214.   cache_size = 0;
  215.   accu = Val_long(0);
  216.   initial_c_roots_head = c_roots_head;
  217.  
  218.   if (setjmp(raise_buf.buf)) {
  219.     c_roots_head = initial_c_roots_head;
  220.     accu = exn_bucket;
  221.     asp = extern_asp;
  222.     rsp = extern_rsp;
  223.     goto raise;
  224.   }
  225.   initial_external_raise = external_raise;
  226.   external_raise = &raise_buf;
  227.   initial_rsp_offset = (char *) ret_stack_high - (char *) rsp;
  228.  
  229. #ifdef DEBUG
  230.   log_ptr = log_buffer;
  231. #endif
  232.  
  233. #ifdef DIRECT_JUMP
  234. # define Instruct(name) lbl_##name
  235. # define Next cur_instr = *pc++; goto *jumptable[cur_instr]
  236. #else
  237. # define Instruct(name) case name
  238. # define Next break
  239. #endif
  240.  
  241. #ifdef DIRECT_JUMP
  242.   Next;                         /* Jump to the first instruction */
  243. #else
  244.   while (1) {
  245. #ifdef DEBUG
  246.     if (icount-- == 0) stop_here ();
  247.     *log_ptr++ = pc;
  248.     if (log_ptr >= log_buffer + LOG_BUFFER_SIZE) log_ptr = log_buffer;
  249.     if (trace_flag) disasm_instr(pc);
  250.     Assert(asp >= arg_stack_low);
  251.     Assert(asp <= arg_stack_high);
  252.     Assert(rsp >= ret_stack_low);
  253.     Assert(rsp <= ret_stack_high);
  254. #endif
  255.     cur_instr = *pc++;
  256.   decode_instruction:
  257.     switch (cur_instr) {
  258. #endif
  259.  
  260.     Instruct(STOP):
  261.       extern_asp = asp;
  262.       extern_rsp = rsp;
  263.       external_raise = initial_external_raise;
  264.       return accu;
  265.       
  266.     Instruct(CUR):
  267.       if (cache_size) heapify_env();
  268.       Alloc_small(accu, Closure_wosize, Closure_tag);
  269.       Env_val(accu) = env;
  270.       Code_val(accu) = pc + s16pc;
  271.       pc += SHORT;
  272.       Next;
  273.       
  274.     Instruct(APPLY):
  275.     apply:
  276.       push_ret_frame();
  277.       retsp->pc = pc;
  278.       retsp->env = env;
  279.       retsp->cache_size = cache_size;
  280.       *--rsp = *asp++;
  281.       cache_size = 1;
  282.       pc = Code_val(accu);
  283.       env = Env_val(accu);
  284.       goto check_stacks;
  285.       
  286.     Instruct(RETURN):
  287.       if (*asp == MARK) {
  288.     rsp += cache_size;
  289.     asp++;
  290.     pc = retsp->pc;
  291.     env = retsp->env;
  292.     cache_size = retsp->cache_size;
  293.     pop_ret_frame();
  294.     if (something_to_do) goto process_signal;
  295.     Next;
  296.       }
  297.       /* fall through APPTERM */
  298.  
  299.     Instruct(APPTERM):
  300.     appterm:
  301.       rsp += cache_size;
  302.       *--rsp = *asp++;
  303.       cache_size = 1;
  304.       pc = Code_val(accu);
  305.       env = Env_val(accu);
  306.  
  307.     check_stacks:
  308.       if (asp < arg_stack_threshold || rsp < ret_stack_threshold) {
  309.         Setup_for_gc;
  310.         realloc_stacks();
  311.         rsp = extern_rsp;
  312.         asp = extern_asp;
  313.         Restore_after_gc;
  314.       }
  315.       /* fall through CHECK_SIGNALS */
  316.  
  317.     Instruct(CHECK_SIGNALS):
  318. #ifdef PERIODIC_ACTION_FREQ
  319.       { static int periodic_action_count = 1;
  320.         if (--periodic_action_count == 0) {
  321.           periodic_action_count = PERIODIC_ACTION_FREQ;
  322.           ui_periodic_action();
  323.         }
  324.       }
  325. #endif
  326. #ifdef macintosh
  327. #ifndef __MWERKS__
  328.       { static int spin_count = 1;
  329.         if (--spin_count == 0) { spin_count = 24; SpinCursor ((short) 1); }
  330.       }
  331. #endif
  332. #endif
  333. #if defined(MSDOS) && defined(__GNUC__)
  334.       { static int poll_count = 1;
  335.         if (--poll_count == 0) { poll_count = 500; poll_break(); }
  336.       }
  337. #endif
  338.       if (something_to_do) goto process_signal;
  339.       Next;
  340.  
  341.     process_signal:
  342.       something_to_do = 0;
  343.       if (force_minor_flag){
  344.     force_minor_flag = 0;
  345.     Setup_for_gc;
  346.     minor_collection ();
  347.     Restore_after_gc;
  348.       }
  349.       if (signal_is_pending){
  350.     signal_is_pending = 0;
  351.     push_ret_frame();
  352.     retsp->pc = pc;
  353.     retsp->env = env;
  354.     retsp->cache_size = cache_size;
  355.     *--asp = MARK;
  356.     *--asp = accu;
  357.     *--asp = MARK;
  358.     env = Atom(0);
  359.     push_ret_frame();
  360.     retsp->pc = return_from_interrupt;
  361.     retsp->env = env;
  362.     retsp->cache_size = 0;
  363.     *--rsp = Val_int(signal_number);
  364.     cache_size = 1;
  365.     pc = signal_handler;
  366.       }
  367.       Next;
  368.  
  369.     Instruct(PUSH_GETGLOBAL_APPLY):
  370.       *--asp = accu;
  371.       accu = Field(global_data, u16pc);
  372.       pc += SHORT;
  373.       goto apply;
  374.  
  375.     Instruct(PUSH_GETGLOBAL_APPTERM):
  376.       *--asp = accu;
  377.       accu = Field(global_data, u16pc);
  378.       pc += SHORT;
  379.       goto appterm;
  380.  
  381.     Instruct(GRAB):
  382.       if (*asp != MARK) {
  383.     *--rsp = *asp++;
  384.     cache_size++;
  385.       } else {
  386.     if (cache_size) heapify_env();
  387.     Alloc_small(accu, Closure_wosize, Closure_tag);
  388.     Code_val(accu) = pc;
  389.     Env_val(accu) = env;
  390.     asp++;
  391.     pc = retsp->pc;
  392.     env = retsp->env;
  393.     cache_size = retsp->cache_size;
  394.     pop_ret_frame();
  395.       }
  396.       Next;
  397.       
  398. #define access(n) (cache_size > n ? rsp[n] : Field(env, n - cache_size))
  399. #define access0() (cache_size > 0 ? rsp[0] : Field(env,0))
  400.  
  401.     Instruct(ACC0):
  402.       accu = access0(); Next;
  403.     Instruct(ACC1):
  404.       accu = access(1); Next;
  405.     Instruct(ACC2):
  406.       accu = access(2); Next;
  407.     Instruct(ACC3):
  408.       accu = access(3); Next;
  409.     Instruct(ACC4):
  410.       accu = access(4); Next;
  411.     Instruct(ACC5):
  412.       accu = access(5); Next;
  413.     Instruct(ACCESS):
  414.       { int n = *pc++;
  415.     accu = access(n);
  416.     Next;
  417.       }
  418.       
  419.     Instruct(LET):
  420.       *--rsp = accu;
  421.       cache_size++;
  422.       Next;
  423.       
  424.     Instruct(DUMMY):
  425.       { int n = *pc++;
  426.     Assert (n > 0);
  427.     Alloc_small(accu, n, 0);
  428.     while (n--){
  429.       Field (accu, n) = Val_long (0);
  430.     }
  431.     Next;
  432.       }
  433.  
  434.     Instruct(UPDATE):
  435.       { mlsize_t n;
  436.         tmp = *asp++;
  437.         Tag_val (accu) = Tag_val (tmp);
  438.         for (n = 0; n < Wosize_val (tmp); n++) {
  439.           modify (&Field (accu, n), Field (tmp, n));
  440.         }
  441.         Next;
  442.       }
  443.  
  444.     Instruct(LETREC1):        /* Replaces Dummy 1; Cur lbl; Update 0 */
  445.       Alloc_small(accu, Closure_wosize, Closure_tag);
  446.       Field(accu,0) = Field(accu,1) = Atom(0);
  447.       *--rsp = accu;
  448.       cache_size++;
  449.       heapify_env();
  450.       Code_val(accu) = pc + s16pc;
  451.       Modify(&Env_val(accu), env);
  452.       pc += SHORT;
  453.       Next;
  454.       
  455.     Instruct(ENDLET1):
  456.       if (cache_size != 0) {
  457.     cache_size--; rsp++;
  458.       } else {
  459.     int i;
  460.     value * from;
  461.     i = Wosize_val(env);
  462.         from = &Field(env, i);
  463.         cache_size = i - 1;
  464.         for (i = cache_size; i > 0; i--) *--rsp = *--from;
  465.     env = null_env;
  466.       }
  467.       Next;
  468.       
  469.     Instruct(ENDLET):
  470.       { int n = *pc++;
  471.     if (cache_size >= n) {
  472.       cache_size -= n;
  473.       rsp += n;
  474.     } else {
  475.       int i;
  476.       value * from;
  477.       n -= cache_size;
  478.       rsp += cache_size;
  479.           i = Wosize_val(env);
  480.       cache_size = i - n;
  481.           from = &Field(env, i);
  482.       for (i = cache_size; i > 0; i--) *--rsp = *--from;
  483.       env = null_env;
  484.     }
  485.     Next;
  486.       }
  487.       
  488.     Instruct(PUSHTRAP):
  489.       { value * src = rsp + cache_size;
  490.     int i = cache_size;
  491.     
  492.     push_trap_frame();
  493.     trapsp->pc = pc + s16pc;
  494.     pc += SHORT;
  495.     trapsp->env = env;
  496.     trapsp->cache_size = cache_size + 2;
  497.     trapsp->asp = asp;
  498.     trapsp->tp = tp;
  499.     tp = trapsp;
  500.     while(i--) *--rsp = *--src;
  501.     *--asp = MARK;
  502.     Next;
  503.       }
  504.  
  505.     raise:            /* An external raise jumps here */
  506.  
  507.     Instruct(RAISE):
  508.       if ((value *) tp >= trap_barrier) {
  509.         Setup_for_gc;
  510.         retsp->pc = pc;
  511.     extern_rsp = (value *) tp;
  512.         debugger(TRAP_BARRIER);
  513.         Restore_after_gc;
  514.       }
  515.       rsp = (value *) tp;
  516.       if (rsp >= (value *)((char *) ret_stack_high - initial_rsp_offset)) {
  517.         exn_bucket = accu;
  518.         external_raise = initial_external_raise;
  519.         longjmp(external_raise->buf, 1);
  520.       }
  521.       pc = trapsp->pc;
  522.       env = trapsp->env;
  523.       cache_size = trapsp->cache_size - 2;
  524.       asp = trapsp->asp;
  525.       tp = trapsp->tp;
  526.       pop_trap_frame();
  527.       *--rsp = accu;
  528.       cache_size++;
  529.       Next;
  530.       
  531.     Instruct(POPTRAP):
  532.       if (something_to_do) {
  533.         /* We must check here so that if a signal is pending and its
  534.            handler triggers an exception, the exception is trapped
  535.            by the current try...with, not the enclosing one. */
  536.         pc--; /* restart the POPTRAP after processing the signal */
  537.         goto process_signal;
  538.       }
  539.       rsp = (value *) tp;
  540.       env = trapsp->env;
  541.       cache_size = trapsp->cache_size - 2;
  542.       asp = trapsp->asp;
  543.       tp = trapsp->tp;
  544.       pop_trap_frame();
  545.       Next;
  546.       
  547.     Instruct(CONSTBYTE):
  548.       accu = *pc++;  Next;
  549.     Instruct(CONSTSHORT):
  550.       accu = s16pc; pc += SHORT; Next;
  551.  
  552.     Instruct(ATOM0):
  553.       accu = Atom(0); Next;
  554.     Instruct(ATOM1):
  555.       accu = Atom(1); Next;
  556.     Instruct(ATOM2):
  557.       accu = Atom(2); Next;
  558.     Instruct(ATOM3):
  559.       accu = Atom(3); Next;
  560.     Instruct(ATOM4):
  561.       accu = Atom(4); Next;
  562.     Instruct(ATOM5):
  563.       accu = Atom(5); Next;
  564.     Instruct(ATOM6):
  565.       accu = Atom(6); Next;
  566.     Instruct(ATOM7):
  567.       accu = Atom(7); Next;
  568.     Instruct(ATOM8):
  569.       accu = Atom(8); Next;
  570.     Instruct(ATOM9):
  571.       accu = Atom(9); Next;
  572.     Instruct(ATOM):
  573.       accu = Atom(*pc++); Next;
  574.       
  575.     Instruct(GETGLOBAL):
  576.       accu = Field(global_data, u16pc);
  577.       pc += SHORT;
  578.       Next;
  579.     Instruct(SETGLOBAL):
  580.       modify(&Field(global_data, u16pc), accu);
  581.       pc += SHORT;
  582.       Next;
  583.       
  584.     Instruct(PUSH):
  585.       *--asp = accu; Next;
  586.     Instruct(POP):
  587.       accu = *asp++; Next;
  588.     Instruct(PUSHMARK):
  589.       *--asp = MARK;
  590.       Next;
  591.       
  592. #define branch() pc += s16pc
  593. #define cond_branch(condition) if (condition) branch(); else pc += 2
  594.  
  595.     Instruct(BRANCH):
  596.       branch(); Next;
  597.     Instruct(BRANCHIF):
  598.       if (Tag_val(accu) != 0) branch(); else pc += SHORT;
  599.       Next;
  600.     Instruct(BRANCHIFNOT):
  601.       if (Tag_val(accu) == 0) branch(); else pc += SHORT;
  602.       Next;
  603.     Instruct(POPBRANCHIFNOT):
  604.       tmp = accu;
  605.       accu = *asp++;
  606.       if (Tag_val(tmp) == 0) branch(); else pc += SHORT;
  607.       Next;
  608.     Instruct(BRANCHIFNEQTAG):
  609.       if (Tag_val(accu) != *pc++) branch(); else pc += SHORT;
  610.       Next;
  611.     Instruct(SWITCH):
  612.       Assert(Long_val(accu) >= 0 && Long_val(accu) < *pc);
  613.       pc++;
  614.       pc += s16(pc + accu - 1);
  615.       Next;
  616.     Instruct(BOOLNOT):
  617.       accu = Atom(Tag_val(accu) == 0); Next;
  618.       
  619.     Instruct(GETFIELD0):
  620.       accu = Field(accu,0); Next;
  621.     Instruct(GETFIELD1):
  622.       accu = Field(accu,1); Next;
  623.     Instruct(GETFIELD2):
  624.       accu = Field(accu,2); Next;
  625.     Instruct(GETFIELD3):
  626.       accu = Field(accu,3); Next;
  627.     Instruct(GETFIELD):
  628.       accu = Field(accu,*pc++); Next;
  629.       
  630.     Instruct(SETFIELD0):
  631.       tmp = 0;
  632.     setfield:
  633.       { value * ptr;
  634.         ptr = &Field(accu, tmp);
  635.         tmp = *asp++;
  636.         Modify(ptr, tmp);
  637.         accu = Atom(0);
  638.       }
  639.       Next;
  640.     Instruct(SETFIELD1):
  641.       tmp = 1;
  642.       goto setfield;
  643.     Instruct(SETFIELD2):
  644.       tmp = 2;
  645.       goto setfield;
  646.     Instruct(SETFIELD3):
  647.       tmp = 3;
  648.       goto setfield;
  649.     Instruct(SETFIELD):
  650.       tmp = *pc++;
  651.       goto setfield;
  652.       
  653.     Instruct(MAKEBLOCK1):
  654.       Alloc_small(tmp, 1, *pc);
  655.       pc++;
  656.       Field(tmp,0) = accu;
  657.       accu = tmp;
  658.       Next;
  659.     Instruct(MAKEBLOCK2):
  660.       Alloc_small(tmp, 2, *pc);
  661.       pc++;
  662.       Field(tmp,0) = accu;
  663.       Field(tmp,1) = *asp++;
  664.       accu = tmp;
  665.       Next;
  666.     Instruct(MAKEBLOCK3):
  667.       Alloc_small(tmp, 3, *pc);
  668.       pc++;
  669.       Field(tmp,0) = accu;
  670.       Field(tmp,1) = *asp++;
  671.       Field(tmp,2) = *asp++;
  672.       accu = tmp;
  673.       Next;
  674.     Instruct(MAKEBLOCK4):
  675.       Alloc_small(tmp, 4, *pc);
  676.       pc++;
  677.       Field(tmp,0) = accu;
  678.       Field(tmp,1) = *asp++;
  679.       Field(tmp,2) = *asp++;
  680.       Field(tmp,3) = *asp++;
  681.       accu = tmp;
  682.       Next;
  683.     Instruct(MAKEBLOCK):
  684.       { header_t hdr;
  685.         mlsize_t size;
  686.     tag_t tag;
  687.     value * to;
  688.     
  689.     hdr = u32pc;
  690.     pc += LONG;
  691.     size = Wosize_hd(hdr);
  692.     tag = Tag_hd(hdr);
  693.         if (size < Max_young_wosize) {
  694.           Alloc_small(tmp, size, tag);
  695.           to = &Field(tmp, 0);
  696.           *to++ = accu;
  697.           for (size--; size > 0; size--) *to++ = *asp++;
  698.           accu = tmp;
  699.         } else {
  700.           Setup_for_gc;
  701.           tmp = alloc_shr (size, tag);
  702.           Restore_after_gc;
  703.           to = &Field(tmp, 0);
  704.           initialize (to++, accu);
  705.           for (size--; size > 0; size--) initialize (to++, *asp++);
  706.           accu = tmp;
  707.         }
  708.     Next;
  709.       }
  710.       
  711.     Instruct(TAGOF):
  712.       accu = Val_long(Tag_val(accu));
  713.       Next;
  714.  
  715.     Instruct(C_CALL1):
  716.       Setup_for_c_call;
  717.       accu = (cprim[u16pc])(accu);
  718.       Restore_after_c_call;
  719.       pc += SHORT;
  720.       Next;
  721.     Instruct(C_CALL2):
  722.       Setup_for_c_call;
  723.       accu = (cprim[u16pc])(accu, asp[0]);
  724.       Restore_after_c_call;
  725.       pc += SHORT;
  726.       asp += 1;
  727.       Next;
  728.     Instruct(C_CALL3):
  729.       Setup_for_c_call;
  730.       accu = (cprim[u16pc])(accu, asp[0], asp[1]);
  731.       Restore_after_c_call;
  732.       pc += SHORT;
  733.       asp += 2;
  734.       Next;
  735.     Instruct(C_CALL4):
  736.       Setup_for_c_call;
  737.       accu = (cprim[u16pc])(accu, asp[0], asp[1], asp[2]);
  738.       Restore_after_c_call;
  739.       pc += SHORT;
  740.       asp += 3;
  741.       Next;
  742.     Instruct(C_CALL5):
  743.       Setup_for_c_call;
  744.       accu = (cprim[u16pc])(accu, asp[0], asp[1], asp[2], asp[3]);
  745.       Restore_after_c_call;
  746.       pc += SHORT;
  747.       asp += 4;
  748.       Next;
  749.     Instruct(C_CALLN):
  750.       { int n = *pc++;
  751.         *--asp = accu;
  752.         Setup_for_c_call;
  753.         accu = (cprim[u16pc])(asp, n);
  754.         Restore_after_c_call;
  755.         pc += SHORT;
  756.         asp += n;
  757.         Next; }
  758.       
  759.     Instruct(NEGINT):
  760.       accu = 2 - accu; Next;
  761.     Instruct(SUCCINT):
  762.       accu += 2; Next;
  763.     Instruct(PREDINT):
  764.       accu -= 2; Next;
  765.     Instruct(ADDINT):        /* Modified for Moscow ML: unsigned */
  766.       accu = (unsigned long) ((unsigned long) accu 
  767.                   + (unsigned long) (*asp++ - 1)); Next;
  768.     Instruct(SUBINT):        /* unsigned */
  769.       accu = (unsigned long) ((unsigned long) accu 
  770.                   - (unsigned long) (*asp++ - 1)); Next;
  771.     Instruct(MULINT):        /* unsigned */
  772.       accu = (unsigned long) (1 + (unsigned long) (accu >> 1) 
  773.                   * (unsigned long) (*asp++ - 1)); Next;
  774.     Instruct(DIVINT):        /* unsigned */
  775.       tmp = *asp++ - 1;
  776.       if (tmp == 0) {
  777.         accu = Atom(SMLEXN_DIV);
  778.         goto raise;
  779.       }
  780.       accu = Val_long((unsigned long) ((unsigned long) (accu - 1) 
  781.                        / (unsigned long) tmp));
  782.       Next;
  783.     Instruct(MODINT):
  784.       tmp = *asp++ - 1;
  785.       if (tmp == 0) {
  786.         accu = Atom(SMLEXN_DIV);
  787.         goto raise;
  788.       }
  789.       accu = (unsigned long) (1 + (unsigned long) (accu - 1) 
  790.                   % (unsigned long) tmp);
  791.       Next;
  792.     Instruct(ANDINT):
  793.       accu &= *asp++; Next;
  794.     Instruct(ORINT):
  795.       accu |= *asp++; Next;
  796.     Instruct(XORINT):
  797.       accu = 1 + (accu ^ *asp++); Next;
  798.     Instruct(SHIFTLEFTINT):
  799.       accu = 1 + ((accu - 1) << Long_val(*asp++)); Next;
  800.     Instruct(SHIFTRIGHTINTSIGNED):
  801.       accu = 1 | ((accu - 1) >> Long_val(*asp++)); Next;
  802.     Instruct(SHIFTRIGHTINTUNSIGNED):
  803.       accu = 1 | ((unsigned long)(accu - 1) >> Long_val(*asp++)); Next;
  804.       
  805. #define inttest(name1,name2,tst)                         \
  806.     Instruct(name1):                                 \
  807.       accu = Atom(accu tst *asp++);                         \
  808.       Next;                                     \
  809.     Instruct(name2):                                 \
  810.       if (accu tst *asp++) { branch(); } else { pc += SHORT; }               \
  811.       Next;
  812.       
  813.       inttest(EQ,BRANCHIFEQ,==);
  814.       inttest(NEQ,BRANCHIFNEQ,!=);
  815.       inttest(LTINT,BRANCHIFLT,<);
  816.       inttest(GTINT,BRANCHIFGT,>);
  817.       inttest(LEINT,BRANCHIFLE,<=);
  818.       inttest(GEINT,BRANCHIFGE,>=);
  819.  
  820.     Instruct(BRANCHINTERVAL):
  821.       { value low_bound, high_bound;
  822.         high_bound = accu;
  823.         low_bound = *asp++;
  824.         accu = *asp++;
  825.         if (accu < low_bound) {
  826.           branch();
  827.           Next;
  828.         }
  829.         pc += SHORT;
  830.         if (accu > high_bound) {
  831.           branch();
  832.           Next;
  833.         } 
  834.         pc += SHORT;
  835.         accu = accu - low_bound + 1;
  836.         Next;
  837.       }
  838.  
  839.     Instruct(INCR):
  840.       Field(accu, 0) += 2; accu = Atom(0); Next;
  841.     Instruct(DECR):
  842.       Field(accu, 0) -= 2; accu = Atom(0); Next;
  843.  
  844.     /* --- Moscow SML changes begin --- */
  845.  
  846. #define Check_float(dval) \
  847.    if ((dval > maxdouble) || (dval < -maxdouble)) \
  848.       { accu = Atom(float_exn); goto raise; }
  849.  
  850.     Instruct(FLOATOP):
  851.       { switch(*pc++) {
  852.     case FLOATOFINT:
  853.       dtmp = (double) Long_val(accu); break;
  854.     case NEGFLOAT:
  855.     case SMLNEGFLOAT:
  856.       float_exn = SMLEXN_OVF;
  857.       dtmp = -Double_val(accu);
  858.       Check_float(dtmp); break;
  859.     case ADDFLOAT:
  860.     case SMLADDFLOAT:
  861.       float_exn = SMLEXN_OVF;
  862.       dtmp = Double_val(accu) + Double_val(*asp++);
  863.       Check_float(dtmp); break;
  864.     case SUBFLOAT:
  865.     case SMLSUBFLOAT:
  866.       float_exn = SMLEXN_OVF;
  867.       dtmp = Double_val(accu) - Double_val(*asp++);
  868.       Check_float(dtmp); break;
  869.     case MULFLOAT:
  870.     case SMLMULFLOAT:
  871.       float_exn = SMLEXN_OVF;
  872.       dtmp = Double_val(accu) * Double_val(*asp++);
  873.       Check_float(dtmp); break;
  874.     case DIVFLOAT:
  875.     case SMLDIVFLOAT:
  876.       float_exn = SMLEXN_OVF;
  877.       dtmp = Double_val(*asp++);
  878.       if (dtmp == 0) {
  879.         accu = Atom(SMLEXN_DIV);
  880.         goto raise;
  881.       }
  882.       dtmp = Double_val(accu) / dtmp;
  883.       Check_float(dtmp); break;
  884.     }
  885.     Alloc_small(tmp, Double_wosize, Double_tag);
  886.     Store_double_val(tmp, dtmp);
  887.     accu = tmp;
  888.     Next;
  889.       }
  890.  
  891.     /* --- Moscow SML changes end --- */
  892.       
  893.     Instruct(INTOFFLOAT):
  894.       accu = Val_long((long)Double_val(accu)); Next;
  895.       
  896. #define floattest(name, tst)                             \
  897.     Instruct(name):                                 \
  898.       accu = Atom(Double_val(accu) tst Double_val(*asp++));             \
  899.       Next;
  900.       
  901.       floattest(EQFLOAT,==);
  902.       floattest(NEQFLOAT,!=);
  903.       floattest(LTFLOAT,<);
  904.       floattest(GTFLOAT,>);
  905.       floattest(LEFLOAT,<=);
  906.       floattest(GEFLOAT,>=);
  907.       
  908.     Instruct(STRINGLENGTH):
  909.       accu = Val_long(string_length(accu));
  910.       Next;
  911.     Instruct(GETSTRINGCHAR):
  912.       accu = Val_long(Byte_u(accu, Long_val(*asp++)));
  913.       Next;
  914.     Instruct(SETSTRINGCHAR):
  915.       Byte_u(accu, Long_val(asp[0])) = Long_val(asp[1]);
  916.       accu = Atom(0);
  917.       asp += 2;
  918.       Next;
  919.  
  920. #define stringtest(name, tst)                                                \
  921.     Instruct(name):                                                          \
  922.       accu = Atom(compare_strings(accu, *asp++) tst Val_long(0));            \
  923.       Next;
  924.       
  925.       stringtest(EQSTRING,==);
  926.       stringtest(NEQSTRING,!=);
  927.       stringtest(LTSTRING,<);
  928.       stringtest(GTSTRING,>);
  929.       stringtest(LESTRING,<=);
  930.       stringtest(GESTRING, >=);
  931.  
  932.     Instruct(MAKEVECTOR):
  933.       { mlsize_t size = Long_val(accu);
  934.         if (size == 0)
  935.           accu = Atom(0);
  936.         else if (size < Max_young_wosize){
  937.       Alloc_small (accu, size, 0);
  938.       do {size--; Field (accu, size) = *asp;} while (size != 0);
  939.     }else if (Is_block (*asp) && Is_young (*asp)){
  940.       Setup_for_gc;
  941.       minor_collection ();
  942.       tmp = alloc_shr (size, 0);
  943.       Restore_after_gc;
  944.           accu = tmp;
  945.       do {size--; Field (accu, size) = *asp;} while (size != 0);
  946.     }else{
  947.       Setup_for_gc;
  948.       tmp = alloc_shr (size, 0);
  949.       Restore_after_gc;
  950.           accu = tmp;
  951.       do {size--; initialize(&Field(accu, size), *asp);} while (size != 0);
  952.     }
  953.         asp++;
  954.     Next;
  955.       }
  956.     Instruct(VECTLENGTH):
  957.       accu = Val_long(Wosize_val(accu));
  958.       Next;
  959.     Instruct(GETVECTITEM):
  960.       accu = Field(accu, Long_val(*asp++));
  961.       Next;
  962.     Instruct(SETVECTITEM):
  963.       tmp = Long_val(*asp++);
  964.       goto setfield;
  965.  
  966. /* --- Additional instructions for Moscow SML --- */
  967.  
  968.     Instruct(SMLNEGINT):
  969.       tmp =  - Long_val(accu);
  970.       accu = Val_long(tmp);
  971.       if( Long_val(accu) != tmp ) {
  972.         accu = Atom(SMLEXN_OVF);
  973.         goto raise;
  974.       }
  975.       Next;
  976.     Instruct(SMLSUCCINT):
  977.       tmp =  Long_val(accu) + 1;
  978.       accu = Val_long(tmp);
  979.       if( Long_val(accu) != tmp ) {
  980.         accu = Atom(SMLEXN_OVF);
  981.         goto raise;
  982.       }
  983.       Next;
  984.     Instruct(SMLPREDINT):
  985.       tmp =  Long_val(accu) - 1;
  986.       accu = Val_long(tmp);
  987.       if( Long_val(accu) != tmp ) {
  988.         accu = Atom(SMLEXN_OVF);
  989.         goto raise;
  990.       }
  991.       Next;
  992.     Instruct(SMLADDINT):
  993.       tmp = Long_val(*asp++) + Long_val(accu);
  994.       accu = Val_long(tmp);
  995.       if( Long_val(accu) != tmp ) goto raise_sum;
  996.       Next;
  997.       raise_sum:
  998.         accu = Atom(SMLEXN_OVF);
  999.         goto raise;
  1000.     Instruct(SMLSUBINT):
  1001.       tmp = Long_val(accu) - Long_val(*asp++);
  1002.       accu = Val_long(tmp);
  1003.       if( Long_val(accu) != tmp ) goto raise_diff;
  1004.       Next;
  1005.       raise_diff:
  1006.         accu = Atom(SMLEXN_OVF);
  1007.         goto raise;
  1008.  
  1009. #define ChunkLen (4 * sizeof(value) - 1)
  1010. #define MaxChunk ((1L << ChunkLen) - 1)
  1011.  
  1012.     Instruct(SMLMULINT):
  1013.       { register long x, y;
  1014.         register int isNegative = 0;
  1015.         x = Long_val(accu);
  1016.         y = Long_val(*asp++);
  1017.         if( x < 0 ) { x = -x; isNegative = 1; }
  1018.         if( y < 0 ) { y = -y; isNegative = !isNegative; }
  1019.         if( y > x ) { tmp = y; y = x; x = tmp; }
  1020.         if( y > MaxChunk ) goto raise_prod;
  1021.         if( x <= MaxChunk )
  1022.           { accu = Val_long(isNegative?(-(x * y)):(x * y)); }
  1023.         else /* x > MaxChunk */
  1024.           { tmp = (x >> ChunkLen) * y;
  1025.             if( tmp > MaxChunk + 1) goto raise_prod;
  1026.             tmp = (tmp << ChunkLen) + (x & MaxChunk) * y;
  1027.             if( isNegative ) tmp = - tmp;
  1028.             accu = Val_long(tmp);
  1029.             if( Long_val(accu) != tmp ) goto raise_prod;
  1030.           }
  1031.       }
  1032.       Next;
  1033.       raise_prod :
  1034.         accu = Atom(SMLEXN_OVF);
  1035.         goto raise;
  1036.  
  1037.     Instruct(SMLDIVINT):
  1038.       tmp = Long_val(*asp++);
  1039.       accu = Long_val(accu);
  1040.       if (tmp == 0) 
  1041.     { accu = Atom(SMLEXN_DIV);
  1042.       goto raise;
  1043.     }
  1044.       if( tmp < 0 ) { accu = - accu; tmp = -tmp; }
  1045.       if( accu >= 0 )
  1046.         { tmp = accu / tmp; }
  1047.       else
  1048.         { accu = - accu;
  1049.           if( accu % tmp == 0 )
  1050.             tmp = - (accu /tmp);
  1051.           else
  1052.             tmp = - (accu / tmp) - 1;
  1053.         }
  1054.       accu = Val_long(tmp);
  1055.       if( Long_val(accu) != tmp ) 
  1056.     { accu = Atom(SMLEXN_OVF);
  1057.       goto raise;
  1058.     }
  1059.       Next;
  1060.  
  1061.     Instruct(SMLMODINT):
  1062.       tmp = Long_val(*asp);
  1063.       accu = Long_val(accu);
  1064.       if (tmp == 0) 
  1065.     { accu = Atom(SMLEXN_DIV);
  1066.       goto raise;
  1067.     }
  1068.       if( tmp < 0 ) { accu = -accu; tmp = -tmp; }
  1069.       if( accu >= 0 )
  1070.         tmp = accu % tmp;
  1071.       else
  1072.         { accu = (-accu) % tmp;
  1073.           tmp = ( accu == 0 )?( 0 ):( tmp - accu );
  1074.         }
  1075.       if( *asp++ < 0 ) tmp = -tmp;
  1076.       accu = Val_long(tmp);
  1077.       if( Long_val(accu) != tmp ) 
  1078.     { accu = Atom(SMLEXN_OVF);
  1079.       goto raise;
  1080.     }
  1081.       Next;
  1082.  
  1083.     Instruct(MAKEREFVECTOR):
  1084.       { mlsize_t size = Long_val(accu);
  1085.         if (size == 0)
  1086.           accu = Atom(Reference_tag);
  1087.         else if (size < Max_young_wosize){
  1088.           Alloc_small (accu, size, Reference_tag);
  1089.       do {size--; Field (accu, size) = *asp;} while (size != 0);
  1090.     }else if (Is_block (*asp) && Is_young (*asp)){
  1091.       Setup_for_gc;
  1092.       minor_collection ();
  1093.           tmp = alloc_shr (size, Reference_tag);
  1094.       Restore_after_gc;
  1095.           accu = tmp;
  1096.       do {size--; Field (accu, size) = *asp;} while (size != 0);
  1097.     }else{
  1098.       Setup_for_gc;
  1099.           tmp = alloc_shr (size, Reference_tag);
  1100.       Restore_after_gc;
  1101.           accu = tmp;
  1102.       do {size--; initialize(&Field(accu, size), *asp);} while (size != 0);
  1103.     }
  1104.         asp++;
  1105.     Next;
  1106.       }
  1107.     Instruct(SMLQUOTINT):
  1108.       tmp = *asp++ - 1;
  1109.       if (tmp == 0) 
  1110.     { accu = Atom(SMLEXN_DIV);
  1111.       goto raise;
  1112.     }
  1113.       tmp = (accu - 1) / tmp;
  1114.       accu = Val_long(tmp);
  1115.       if( Long_val(accu) != tmp ) 
  1116.     { accu = Atom(SMLEXN_OVF);
  1117.       goto raise;
  1118.     }
  1119.       Next;
  1120.     Instruct(SMLREMINT):
  1121.       tmp = *asp++ - 1;
  1122.       if (tmp == 0) {
  1123.         accu = Atom(SMLEXN_DIV);
  1124.         goto raise;
  1125.       }
  1126.       accu = 1 + (accu - 1) % tmp;
  1127.       Next;
  1128.  
  1129. /* --- End of additional instructions for Moscow SML --- */
  1130.  
  1131.     Instruct(BREAK):
  1132.       Setup_for_gc;
  1133.       retsp->pc = pc - 1;
  1134.       cur_instr = debugger(BREAKPOINT);
  1135.       if (cur_instr == -1) cur_instr = pc[-1];
  1136.       Restore_after_gc;
  1137. #ifdef DIRECT_JUMP
  1138.       goto *jumptable[cur_instr & 0x7F];
  1139. #else
  1140.       cur_instr &= 0x7F;
  1141.       goto decode_instruction;
  1142. #endif
  1143.  
  1144. #ifdef DIRECT_JUMP
  1145.     lbl_EVENT:
  1146. #else
  1147.     default:
  1148. #endif
  1149.       if (--event_count == 0) {
  1150.         Setup_for_gc;
  1151.         retsp->pc = pc - 1;
  1152.         debugger(EVENT);
  1153.         Restore_after_gc;
  1154.       }
  1155. #ifdef DIRECT_JUMP
  1156.       goto *jumptable[cur_instr & 0x7F];
  1157. #else
  1158.       cur_instr &= 0x7F;
  1159.       goto decode_instruction;
  1160. #endif
  1161.  
  1162. #ifndef DIRECT_JUMP
  1163.     }
  1164.   }
  1165. #endif
  1166. }
  1167.  
  1168. static unsigned char callback_code [] = { POP, APPLY, STOP };
  1169.  
  1170. value callback(closure, argument)
  1171.      value closure, argument;
  1172. {
  1173.   *--extern_asp = MARK;
  1174.   *--extern_asp = argument;
  1175.   *--extern_asp = closure;
  1176.   return interprete(callback_code);
  1177. }
  1178.