home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / !runtime / interp.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-18  |  38.8 KB  |  1,607 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. #ifdef HAS_UI
  18. #include "ui.h"
  19. #endif
  20.  
  21. #ifdef DEBUG
  22. static long icount = 0;
  23. static void stop_here () {}
  24. #endif
  25.  
  26. /* Registers for the abstract machine:
  27.     pc         the code pointer
  28.     sp         the stack pointer (grows downward)
  29.         accu       the accumulator
  30.         env        heap-allocated environment
  31.     trapsp     pointer to the current trap frame
  32.         extra_args number of extra arguments provided by the caller
  33.  
  34. sp is a local copy of the global variable extern_sp. */
  35.  
  36. extern code_t start_code;
  37.  
  38. typedef unsigned char opcode_t;
  39.  
  40. /* Other viewpoints on pc (to read immediate operands) */
  41.  
  42. #define SHORT  (sizeof(short))
  43. #define LONG   (sizeof(int32))
  44. #define DOUBLE (sizeof(double))
  45.  
  46. #define s16pc s16(pc)
  47. #define u16pc u16(pc)
  48. #define s32pc s32(pc)
  49. #define u32pc u32(pc)
  50.  
  51. /* The empty environment */
  52.  
  53. #define null_env Atom(0)
  54.  
  55. /* Code for returning from the signal handler */
  56.  
  57. unsigned char return_from_interrupt[] = { ACC0, RETURN, 1 };
  58.  
  59. /* GC interface */
  60.  
  61. #define Setup_for_gc { sp -= 2; sp[0] = accu; sp[1] = env; extern_sp = sp; }
  62. #define Restore_after_gc { accu = sp[0]; env = sp[1]; sp += 2; }
  63. #define Setup_for_c_call { *--sp = env; extern_sp = sp; }
  64. #define Restore_after_c_call { sp = extern_sp; env = *sp++; }
  65.  
  66. /* GCC 2.0 has labels as first-class values. We take advantage of that
  67.    to provide faster dispatch than the "switch" statement. */
  68.  
  69. #if defined(__GNUC__) && __GNUC__ >= 2 && !defined(DEBUG)
  70. #define DIRECT_JUMP
  71. #endif
  72.  
  73. /* The interpreter itself */
  74.  
  75. value interprete(prog)
  76.      code_t prog;
  77. {
  78.  
  79. /* Declarations for the registers of the abstract machine.
  80.    The most heavily used registers come first.
  81.    For reasonable performance, "pc" MUST reside in a register.
  82.    Many ``optimizing'' compilers underestimate the importance of "pc",
  83.    and don't put it in a register. 
  84.    For GCC users, I've hand-assigned registers for some architectures. */
  85.  
  86. #if defined(__GNUC__) && defined(sparc)
  87.   register code_t pc asm("%l0");
  88.   register value accu asm("%l1");
  89.   register value * sp asm("%l2");
  90. #else
  91. #if defined(__GNUC__) && defined(mc68000)
  92.   register code_t pc asm("a5");
  93.   register value accu;
  94.   register value * sp;
  95. #else
  96. #if defined(__GNUC__) && defined(mips)
  97.   register code_t   pc asm("$20");
  98.   register value  accu asm("$21");
  99.   register value * sp asm("$22");
  100. #else
  101. #if defined(__GNUC__) && defined(__alpha__)
  102.   register code_t   pc asm("$11");
  103.   register value  accu asm("$12");
  104.   register value * sp asm("$13");
  105. #else
  106. #if defined(__GNUC__) && defined(hppa)
  107.   register code_t   pc asm("%r11");
  108.   register value  accu asm("%r12");
  109.   register value * sp asm("%r13");
  110. #else        
  111. #if defined(__GNUC__) && defined(i386)
  112. #if defined(MSDOS)
  113.   register code_t pc asm("si");
  114.   register value * sp asm("di");
  115. #else
  116.   register code_t pc asm("%esi");
  117.   register value * sp asm("%edi");
  118. #endif
  119.   register value accu;
  120. #else
  121.   register code_t pc;
  122.   register value accu;
  123.   register value * sp;
  124. #endif
  125. #endif
  126. #endif
  127. #endif
  128. #endif
  129. #endif
  130.  
  131.   value env;
  132.   int extra_args;
  133.   struct longjmp_buffer * initial_external_raise;
  134.   int initial_sp_offset;
  135.   value * initial_c_roots_head;
  136.   struct longjmp_buffer raise_buf;
  137.   value * modify_dest, modify_newval;
  138.   value tmp;
  139.   int last_instr, cur_instr;
  140.  
  141. #ifdef DIRECT_JUMP
  142.   static void * jumptable[] = {
  143. #   include "jumptbl.h"
  144.   };
  145. #endif
  146.  
  147.   double dtmp;
  148.  
  149. /* #define FREQONE */
  150.  
  151. #ifdef FREQONE
  152. long freqtable[256];
  153. #include "opnames.h"
  154. {
  155.   int i;
  156.   for (i=0; i<256; i++)
  157.     freqtable[i] = 0;
  158. }
  159. #define INCRFREQ(instr1,instr2) freqtable[instr2]++;
  160. #define DUMPTABLE                    \
  161. {                            \
  162.   int i;                        \
  163.   printf("\n\n");                    \
  164.   for (i=0; i<256; i++)                    \
  165.     if (freqtable[i])                    \
  166.       printf("%.8d %s\n", freqtable[i],            \
  167.                           names_of_instructions[i]);    \
  168. }    
  169. #else
  170. #ifdef FREQTWO
  171. long freqtable[256][256];
  172. #include "opnames.h"
  173. {
  174.   int i1, i2;
  175.   for (i1=0; i1<256; i1++)
  176.     for (i2=0; i2<256; i2++)
  177.       freqtable[i1][i2] = 0;
  178.   last_instr = 0;
  179. }
  180.  
  181. #define INCRFREQ(instr1,instr2)                \
  182.   freqtable[instr1][instr2]++;                \
  183.   last_instr = cur_instr;
  184.  
  185. #define DUMPTABLE                    \
  186. {                            \
  187.   int i1, i2;                        \
  188.   printf("\n\n");                    \
  189.   for (i1=0; i1<256; i1++)                \
  190.     for (i2=0; i2<256; i2++)                \
  191.       if (freqtable[i1][i2])                \
  192.          printf("%.9d %s/%s\n", freqtable[i1][i2],    \
  193.                 names_of_instructions[i1],        \
  194.                 names_of_instructions[i2]);        \
  195. }    
  196. #else
  197. #define INCRFREQ(instr1,instr2) /* nothing */
  198. #define DUMPTABLE               /* nothing */
  199. #endif
  200. #endif
  201.  
  202.   sp = extern_sp;
  203.   pc = prog;
  204.   extra_args = 0;
  205.   env = null_env;
  206.   accu = Val_long(0);
  207.   initial_c_roots_head = c_roots_head;
  208.   initial_sp_offset = stack_high - sp;
  209.   initial_external_raise = external_raise;
  210.  
  211.   if (setjmp(raise_buf.buf)) {
  212.     c_roots_head = initial_c_roots_head;
  213.     accu = exn_bucket;
  214.     goto raise_exception;
  215.   }
  216.   external_raise = &raise_buf;
  217.  
  218. #ifdef DEBUG
  219.   log_ptr = log_buffer;
  220. #endif
  221.  
  222. #ifdef DIRECT_JUMP
  223. # define Instruct(name) lbl_##name
  224. # define Next cur_instr = *pc++; INCRFREQ(last_instr,cur_instr) \
  225.               goto *jumptable[cur_instr]
  226. #else
  227. # define Instruct(name) case name
  228. # define Next break
  229. #endif
  230.  
  231. #ifdef DIRECT_JUMP
  232.   Next;                         /* Jump to the first instruction */
  233. #else
  234.   while (1) {
  235. #ifdef DEBUG
  236.     if (icount-- == 0) stop_here ();
  237.     *log_ptr++ = pc;
  238.     if (log_ptr >= log_buffer + LOG_BUFFER_SIZE) log_ptr = log_buffer;
  239.     if (trace_flag) disasm_instr(pc);
  240.     Assert(sp >= stack_low);
  241.     Assert(sp <= stack_high);
  242. #endif
  243.     cur_instr = *pc++;
  244.   decode_instruction:
  245.     switch (cur_instr) {
  246. #endif
  247.  
  248. /* Basic stack operations */
  249.  
  250.     Instruct(SWAP):  
  251.     { value tmp = accu;
  252.       accu = sp[0];
  253.       sp[0] = tmp;
  254.       Next;
  255.     }
  256.  
  257.     Instruct(PUSH): 
  258.     Instruct(PUSHACC0): *--sp = accu; Next;
  259.     Instruct(ACC0): accu = sp[0]; Next;
  260.  
  261.     Instruct(PUSHACC1): *--sp = accu; /* Fallthrough */
  262.     Instruct(ACC1): accu = sp[1]; Next;
  263.  
  264.     Instruct(PUSHACC2): *--sp = accu; /* Fallthrough */
  265.     Instruct(ACC2): accu = sp[2]; Next;
  266.  
  267.     Instruct(PUSHACC3): *--sp = accu; /* Fallthrough */
  268.     Instruct(ACC3): accu = sp[3]; Next;
  269.  
  270.     Instruct(PUSHACC4): *--sp = accu; /* Fallthrough */
  271.     Instruct(ACC4): accu = sp[4]; Next;
  272.  
  273.     Instruct(PUSHACC5): *--sp = accu; /* Fallthrough */
  274.     Instruct(ACC5): accu = sp[5]; Next;
  275.  
  276.     Instruct(PUSHACC6): *--sp = accu; /* Fallthrough */
  277.     Instruct(ACC6): accu = sp[6]; Next;
  278.  
  279.     Instruct(PUSHACC7): *--sp = accu; /* Fallthrough */
  280.     Instruct(ACC7): accu = sp[7]; Next;
  281.  
  282.     Instruct(PUSHACC): *--sp = accu; /* Fallthrough */
  283.     Instruct(ACCESS): accu = sp[*pc++]; Next;
  284.  
  285.     Instruct(POP):
  286.       sp += *pc++;
  287.       Next;
  288.     Instruct(ASSIGN):
  289.       sp[*pc++] = accu;
  290.       accu = Val_unit;
  291.       Next;
  292.  
  293. /* Access in heap-allocated environment */
  294.  
  295.     Instruct(PUSHENV1): *--sp = accu; /* Fallthrough */
  296.     Instruct(ENV1): accu = Field(env, 1); Next;
  297.  
  298.     Instruct(PUSHENV2): *--sp = accu; /* Fallthrough */
  299.     Instruct(ENV2): accu = Field(env, 2); Next;
  300.  
  301.     Instruct(PUSHENV3): *--sp = accu; /* Fallthrough */
  302.     Instruct(ENV3): accu = Field(env, 3); Next;
  303.  
  304.     Instruct(PUSHENV4): *--sp = accu; /* Fallthrough */
  305.     Instruct(ENV4): accu = Field(env, 4); Next;
  306.  
  307.     Instruct(PUSHENV5): *--sp = accu; /* Fallthrough */
  308.     Instruct(ENV5): accu = Field(env, 5); Next;
  309.  
  310.     Instruct(PUSHENV6): *--sp = accu; /* Fallthrough */
  311.     Instruct(ENV6): accu = Field(env, 6); Next;
  312.  
  313.     Instruct(PUSHENV7): *--sp = accu; /* Fallthrough */
  314.     Instruct(ENV7): accu = Field(env, 7); Next;
  315.  
  316.     Instruct(PUSHENVACC): *--sp = accu; /* Fallthrough */
  317.     Instruct(ENVACC): accu = Field(env, *pc++); Next;
  318.  
  319.     Instruct(PUSH_ENV1_APPLY1): 
  320.     { 
  321.       sp -= 4;
  322.       sp[0] = accu;
  323.       sp[1] = (value)pc;
  324.       sp[2] = env;
  325.       sp[3] = Val_long(extra_args);
  326.       extra_args = 0;
  327.       accu = Field(env, 1); 
  328.       goto apply;
  329.     } 
  330.     
  331.     Instruct(PUSH_ENV1_APPLY2): 
  332.     { value arg2 = sp[0];
  333.       sp -= 4;
  334.       sp[0] = accu;
  335.       sp[1] = arg2;
  336.       sp[2] = (value)pc;
  337.       sp[3] = env;
  338.       sp[4] = Val_long(extra_args);
  339.       extra_args = 1;
  340.       accu = Field(env, 1); 
  341.       goto apply;
  342.     } 
  343.  
  344.     Instruct(PUSH_ENV1_APPLY3): 
  345.     { value arg2 = sp[0];
  346.       value arg3 = sp[1];
  347.       sp -= 4;
  348.       sp[0] = accu;
  349.       sp[1] = arg2;
  350.       sp[2] = arg3;
  351.       sp[3] = (value)pc;
  352.       sp[4] = env;
  353.       sp[5] = Val_long(extra_args);
  354.       extra_args = 2;
  355.       accu = Field(env, 1); 
  356.       goto apply;
  357.     } 
  358.  
  359.     Instruct(PUSH_ENV1_APPLY4): 
  360.     { value arg2 = sp[0];
  361.       value arg3 = sp[1];
  362.       value arg4 = sp[2];
  363.       sp -= 4;
  364.       sp[0] = accu;
  365.       sp[1] = arg2;
  366.       sp[2] = arg3;
  367.       sp[3] = arg4;
  368.       sp[4] = (value)pc;
  369.       sp[5] = env;
  370.       sp[6] = Val_long(extra_args);
  371.       extra_args = 3;
  372.       accu = Field(env, 1); 
  373.       goto apply;
  374.     } 
  375.  
  376.     Instruct(PUSH_ENV1_APPTERM1):
  377.     { sp = sp + *pc++ - 2;
  378.       sp[0] = accu;
  379.     } /* Fall through */
  380.     env1_appterm:
  381.       accu = Field(env, 1); 
  382.     appterm:
  383.       pc = Code_val(accu);
  384.       env = accu;
  385.       goto check_signals;
  386.  
  387.     Instruct(PUSH_ENV1_APPTERM2):
  388.     { value arg2 = sp[0];
  389.       sp = sp + *pc++ - 3;
  390.       sp[0] = accu;
  391.       sp[1] = arg2;
  392.       extra_args += 1;
  393.       goto env1_appterm;
  394.     }
  395.  
  396.     Instruct(PUSH_ENV1_APPTERM3):
  397.     { value arg2 = sp[0];
  398.       value arg3 = sp[1];
  399.       sp = sp + *pc++ - 4;
  400.       sp[0] = accu;
  401.       sp[1] = arg2;
  402.       sp[2] = arg3;
  403.       extra_args += 2;
  404.       goto env1_appterm;
  405.     }
  406.  
  407.     Instruct(PUSH_ENV1_APPTERM4):
  408.     { value arg2 = sp[0];
  409.       value arg3 = sp[1];
  410.       value arg4 = sp[2];
  411.       sp = sp + *pc++ - 5;
  412.       sp[0] = accu;
  413.       sp[1] = arg2;
  414.       sp[2] = arg3;
  415.       sp[3] = arg4;
  416.       extra_args += 3;
  417.       goto env1_appterm;
  418.     }
  419.  
  420. /* Function application */
  421.  
  422.     Instruct(PUSH_RETADDR): {
  423.       sp -= 3;
  424.       sp[0] = (value) (pc + s16pc);
  425.       sp[1] = env;
  426.       sp[2] = Val_long(extra_args);
  427.       pc += SHORT;
  428.       Next;
  429.     }
  430.     Instruct(APPLY): {
  431.       extra_args = *pc - 1;
  432.       goto apply;
  433.     }
  434.     Instruct(APPLY1): {
  435.       value arg1 = sp[0];
  436.       sp -= 3;
  437.       sp[0] = arg1;
  438.       sp[1] = (value)pc;
  439.       sp[2] = env;
  440.       sp[3] = Val_long(extra_args);
  441.       extra_args = 0;
  442.       goto apply;
  443.     }
  444.     Instruct(APPLY2): {
  445.       value arg1 = sp[0];
  446.       value arg2 = sp[1];
  447.       sp -= 3;
  448.       sp[0] = arg1;
  449.       sp[1] = arg2;
  450.       sp[2] = (value)pc;
  451.       sp[3] = env;
  452.       sp[4] = Val_long(extra_args);
  453.       extra_args = 1;
  454.       goto apply;
  455.     }
  456.     Instruct(APPLY3): {
  457.       value arg1 = sp[0];
  458.       value arg2 = sp[1];
  459.       value arg3 = sp[2];
  460.       sp -= 3;
  461.       sp[0] = arg1;
  462.       sp[1] = arg2;
  463.       sp[2] = arg3;
  464.       sp[3] = (value)pc;
  465.       sp[4] = env;
  466.       sp[5] = Val_long(extra_args);
  467.       extra_args = 2;
  468.       goto apply;
  469.     }
  470.     Instruct(APPLY4): {
  471.       value arg1 = sp[0];
  472.       value arg2 = sp[1];
  473.       value arg3 = sp[2];
  474.       value arg4 = sp[3];
  475.       sp -= 3;
  476.       sp[0] = arg1;
  477.       sp[1] = arg2;
  478.       sp[2] = arg3;
  479.       sp[3] = arg4;
  480.       sp[4] = (value)pc;
  481.       sp[5] = env;
  482.       sp[6] = Val_long(extra_args);
  483.       extra_args = 3;
  484.       goto apply;
  485.     }
  486.  
  487.     Instruct(APPTERM): {
  488.       int nargs = *pc++;
  489.       int slotsize = *pc++;
  490.       value * newsp;
  491.       int i;
  492.       /* Slide the nargs bottom words of the current frame to the top
  493.          of the frame, and discard the remainder of the frame */
  494.       newsp = sp + slotsize - nargs;
  495.       for (i = nargs - 1; i >= 0; i--) newsp[i] = sp[i];
  496.       sp = newsp;
  497.       extra_args += nargs - 1;
  498.       goto appterm;
  499.     }
  500.     Instruct(APPTERM1): {
  501.       value arg1 = sp[0];
  502.       sp = sp + *pc++ - 1;
  503.       sp[0] = arg1;
  504.       goto appterm;
  505.     }
  506.     Instruct(APPTERM2): {
  507.       value arg1 = sp[0];
  508.       value arg2 = sp[1];
  509.       sp = sp + *pc++ - 2;
  510.       sp[0] = arg1;
  511.       sp[1] = arg2;
  512.       extra_args += 1;
  513.       goto appterm;
  514.     }
  515.     Instruct(APPTERM3): {
  516.       value arg1 = sp[0];
  517.       value arg2 = sp[1];
  518.       value arg3 = sp[2];
  519.       sp = sp + *pc++ - 3;
  520.       sp[0] = arg1;
  521.       sp[1] = arg2;
  522.       sp[2] = arg3;
  523.       extra_args += 2;
  524.       goto appterm;
  525.     }
  526.     Instruct(APPTERM4): {
  527.       value arg1 = sp[0];
  528.       value arg2 = sp[1];
  529.       value arg3 = sp[2];
  530.       value arg4 = sp[3];
  531.       sp = sp + *pc++ - 4;
  532.       sp[0] = arg1;
  533.       sp[1] = arg2;
  534.       sp[2] = arg3;
  535.       sp[3] = arg4;
  536.       extra_args += 3;
  537.       goto appterm;
  538.     }
  539.  
  540.     Instruct(RETURN1):
  541.       sp += 1;
  542.     return_code:
  543.       if (extra_args > 0) {
  544.         extra_args--;
  545.         pc = Code_val(accu);
  546.         env = accu;
  547.       } else {
  548.         pc = (code_t)(sp[0]);
  549.         env = sp[1];
  550.         extra_args = Long_val(sp[2]);
  551.     sp += 3;
  552.     if (something_to_do) goto process_signal; 
  553.       }
  554.       Next;
  555.  
  556.     Instruct(RETURN2):
  557.       sp += 2;
  558.       goto return_code;
  559.  
  560.     Instruct(RETURN):
  561.       sp += *pc++;
  562.       goto return_code;
  563.  
  564.     Instruct(RESTART): {
  565.       int num_args = Wosize_val(env) - 2;
  566.       int i;
  567.       sp -= num_args;
  568.       for (i = 0; i < num_args; i++) sp[i] = Field(env, i + 2);
  569.       env = Field(env, 1);
  570.       extra_args += num_args;
  571.       Next;
  572.     }
  573.  
  574.     Instruct(GRAB): {
  575.       int required = *pc++;
  576.       if (extra_args >= required) {
  577.         extra_args -= required;
  578.       } else {
  579.         mlsize_t num_args, i;
  580.         num_args = 1 + extra_args; /* arg1 + extra args */
  581.         Alloc_small(accu, num_args + 2, Closure_tag);
  582.         Field(accu, 1) = env;
  583.         for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i];
  584.         Code_val(accu) = pc - 3; /* Point to the preceding RESTART instr. */
  585.         sp += num_args;
  586.         pc = (code_t)(sp[0]);
  587.         env = sp[1];
  588.         extra_args = Long_val(sp[2]);
  589.         sp += 3;
  590.       }
  591.       Next;
  592.     }
  593.  
  594.     Instruct(CLOSURE): {
  595.       int nvars = *pc++;
  596.       int i;
  597.       if (nvars > 0) *--sp = accu;
  598.       Alloc_small(accu, 1 + nvars, Closure_tag);
  599.       Code_val(accu) = pc + s16pc;
  600.       for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i];
  601.       sp += nvars;
  602.       pc += SHORT;
  603.       Next;
  604.     }
  605.  
  606.     Instruct(CLOSREC): {
  607.       int nvars = *pc++;
  608.       int i;
  609.       if (nvars > 0) *--sp = accu;
  610.       Alloc_small(accu, 2 + nvars, Closure_tag);
  611.       Code_val(accu) = pc + s16pc;
  612.       Field(accu, 1) = Val_int(0);
  613.       for (i = 0; i < nvars; i++) Field(accu, i + 2) = sp[i];
  614.       sp += nvars;
  615.       modify(&Field(accu, 1), accu);
  616.       pc += SHORT;
  617.       Next;
  618.     }
  619.  
  620. /* For recursive definitions */
  621.  
  622.     Instruct(DUMMY): {
  623.       int size = *pc++ + 1; /* size + 1 to match CLOSURE */
  624.       Alloc_small(accu, size, 0);
  625.       while (size--) Field(accu, size) = Val_long(0);
  626.       Next;
  627.     }
  628.     Instruct(UPDATE): {
  629.       value newval = *sp++;
  630.       mlsize_t size, n;
  631.       size = Wosize_val(newval);
  632.       Assert(size == Wosize_val(accu));
  633.       Tag_val(accu) = Tag_val(newval);
  634.       for (n = 0; n < size; n++) {
  635.         modify(&Field(accu, n), Field(newval, n));
  636.       }
  637.       accu = Val_unit;
  638.       Next;
  639.     }
  640.  
  641. /* Globals */
  642.  
  643.     Instruct(PUSH_GETGLOBAL):
  644.       *--sp = accu;
  645.       /* Fallthrough */
  646.     Instruct(GETGLOBAL):
  647.       accu = Field(global_data, u16pc);
  648.       pc += SHORT;
  649.       Next;
  650.  
  651.     Instruct(PUSH_GETGLOBAL_APPLY1): 
  652.     { sp -= 4;
  653.       sp[0] = accu;
  654.       accu = Field(global_data, u16pc);
  655.       pc += SHORT;
  656.       sp[1] = (value)pc;
  657.       sp[2] = env;
  658.       sp[3] = Val_long(extra_args);
  659.       extra_args = 0;
  660.     }
  661.     apply:
  662.       pc = Code_val(accu);
  663.       env = accu;
  664.       /* Fall through to stack check */
  665.  
  666.     check_stacks:
  667.       if (sp < stack_threshold) {
  668.         extern_sp = sp;
  669.         realloc_stack();
  670.         sp = extern_sp;
  671.       }
  672.       /* Fall through to signals check */
  673.  
  674.     check_signals:
  675.  
  676.     Instruct(CHECK_SIGNALS):    /* accu not preserved */
  677. #ifdef PERIODIC_ACTION_FREQ
  678.       { static int periodic_action_count = 1;
  679.         if (--periodic_action_count == 0) {
  680.           periodic_action_count = PERIODIC_ACTION_FREQ;
  681.           ui_periodic_action();
  682.         }
  683.       }
  684. #endif
  685. #ifdef macintosh
  686. #ifndef __MWERKS__
  687.       { static int spin_count = 1;
  688.         if (--spin_count == 0) { spin_count = 24; SpinCursor ((short) 1); }
  689.       }
  690. #endif
  691. #endif
  692. #if defined(MSDOS) && defined(__GNUC__)
  693.       { static int poll_count = 1;
  694.         if (--poll_count == 0) { poll_count = 500; poll_break(); }
  695.       }
  696. #endif
  697.       if (something_to_do) goto process_signal;
  698.       Next;
  699.  
  700.     Instruct(PUSH_GETGLOBAL_APPLY2): 
  701.     { value arg2 = sp[0];
  702.       sp -= 4;
  703.       sp[0] = accu;
  704.       sp[1] = arg2;
  705.       accu = Field(global_data, u16pc);
  706.       pc += SHORT;
  707.       sp[2] = (value)pc;
  708.       sp[3] = env;
  709.       sp[4] = Val_long(extra_args);
  710.       extra_args = 1;
  711.       goto apply;
  712.     }
  713.  
  714.     Instruct(PUSH_GETGLOBAL_APPLY3): 
  715.     { value arg2 = sp[0];
  716.       value arg3 = sp[1];
  717.       sp -= 4;
  718.       sp[0] = accu;
  719.       sp[1] = arg2;
  720.       sp[2] = arg3;
  721.       accu = Field(global_data, u16pc);
  722.       pc += SHORT;
  723.       sp[3] = (value)pc;
  724.       sp[4] = env;
  725.       sp[5] = Val_long(extra_args);
  726.       extra_args = 2;
  727.       goto apply;
  728.     }
  729.     Instruct(PUSH_GETGLOBAL_APPLY4): 
  730.     { value arg2 = sp[0];
  731.       value arg3 = sp[1];
  732.       value arg4 = sp[2];
  733.       sp -= 4;
  734.       sp[0] = accu;
  735.       sp[1] = arg2;
  736.       sp[2] = arg3;
  737.       sp[3] = arg4;
  738.       accu = Field(global_data, u16pc);
  739.       pc += SHORT;
  740.       sp[4] = (value)pc;
  741.       sp[5] = env;
  742.       sp[6] = Val_long(extra_args);
  743.       extra_args = 3;
  744.       goto apply;
  745.     }
  746.  
  747.     Instruct(PUSH_GETGLOBAL_APPTERM1):
  748.       /* opcode, popnbr, globalindex */
  749.       sp = sp + *pc++ - 2;
  750.       sp[0] = accu;
  751.     getglobal_appterm:
  752.       accu = Field(global_data, u16pc);
  753.       pc = Code_val(accu);
  754.       env = accu;
  755.       goto check_signals;
  756.     
  757.     Instruct(PUSH_GETGLOBAL_APPTERM2):
  758.     { value arg2 = sp[0];
  759.       sp = sp + *pc++ - 3;
  760.       sp[0] = accu;
  761.       sp[1] = arg2;
  762.       extra_args += 1;
  763.       goto getglobal_appterm;
  764.     }
  765.  
  766.     Instruct(PUSH_GETGLOBAL_APPTERM3):
  767.     { value arg2 = sp[0];
  768.       value arg3 = sp[1];
  769.       sp = sp + *pc++ - 4;
  770.       sp[0] = accu;
  771.       sp[1] = arg2;
  772.       sp[2] = arg3;
  773.       extra_args += 2;
  774.       goto getglobal_appterm;
  775.     }
  776.  
  777.     Instruct(PUSH_GETGLOBAL_APPTERM4):
  778.     { value arg2 = sp[0];
  779.       value arg3 = sp[1];
  780.       value arg4 = sp[2];
  781.       sp = sp + *pc++ - 5;
  782.       sp[0] = accu;
  783.       sp[1] = arg2;
  784.       sp[2] = arg3;
  785.       sp[3] = arg4;
  786.       extra_args += 3;
  787.       goto getglobal_appterm;
  788.     }
  789.  
  790.     Instruct(SETGLOBAL):
  791.       modify(&Field(global_data, u16pc), accu);
  792.       accu = Val_unit; /* ? */
  793.       pc += SHORT;
  794.       Next;
  795.  
  796. /* Allocation of blocks */
  797.  
  798.     Instruct(PUSHATOM0):
  799.       *--sp = accu;
  800.       /* Fallthrough */
  801.     Instruct(ATOM0):
  802.       accu = Atom(0); Next;
  803.  
  804.     Instruct(ATOM1):
  805.       accu = Atom(1); Next;
  806.     Instruct(ATOM2):
  807.       accu = Atom(2); Next;
  808.     Instruct(ATOM3):
  809.       accu = Atom(3); Next;
  810.     Instruct(ATOM4):
  811.       accu = Atom(4); Next;
  812.     Instruct(ATOM5):
  813.       accu = Atom(5); Next;
  814.     Instruct(ATOM6):
  815.       accu = Atom(6); Next;
  816.     Instruct(ATOM7):
  817.       accu = Atom(7); Next;
  818.     Instruct(ATOM8):
  819.       accu = Atom(8); Next;
  820.     Instruct(ATOM9):
  821.       accu = Atom(9); Next;
  822.  
  823.     Instruct(PUSHATOM):
  824.       *--sp = accu;
  825.       /* Fallthrough */
  826.     Instruct(ATOM):
  827.       accu = Atom(*pc++); Next;
  828.  
  829.     Instruct(MAKEBLOCK):
  830.       { header_t hdr;
  831.         mlsize_t size;
  832.     tag_t tag;
  833.     int i;
  834.     
  835.     hdr = u32pc;
  836.     pc += LONG;
  837.     size = Wosize_hd(hdr);
  838.     tag = Tag_hd(hdr);
  839.         if (size < Max_young_wosize) {
  840.           Alloc_small(tmp, size, tag);
  841.           Field(tmp, size-1) = accu;
  842.           for (i = size-2; i >= 0; i--) Field(tmp, i) = *sp++;
  843.           accu = tmp;
  844.         } else {
  845.           Setup_for_gc;
  846.           tmp = alloc_shr (size, tag);
  847.           Restore_after_gc;
  848.           initialize (&Field(tmp, size-1), accu);
  849.           for (i = size-2; i >= 0; i--) initialize (&Field(tmp, i), *sp++);
  850.           accu = tmp;
  851.         }
  852.     Next;
  853.       }
  854.       
  855.     Instruct(MAKEBLOCK1): {
  856.       tag_t tag = *pc++;
  857.       value block;
  858.       Alloc_small(block, 1, tag);
  859.       Field(block, 0) = accu;
  860.       accu = block;
  861.       Next;
  862.     }
  863.     Instruct(MAKEBLOCK2): {
  864.       tag_t tag = *pc++;
  865.       value block;
  866.       Alloc_small(block, 2, tag);
  867.       Field(block, 0) = sp[0];
  868.       Field(block, 1) = accu;
  869.       sp += 1;
  870.       accu = block;
  871.       Next;
  872.     }
  873.     Instruct(MAKEBLOCK3): {
  874.       tag_t tag = *pc++;
  875.       value block;
  876.       Alloc_small(block, 3, tag);
  877.       Field(block, 0) = sp[1];
  878.       Field(block, 1) = sp[0];
  879.       Field(block, 2) = accu;
  880.       sp += 2;
  881.       accu = block;
  882.       Next;
  883.     }
  884.     Instruct(MAKEBLOCK4): {
  885.       tag_t tag = *pc++;
  886.       value block;
  887.       Alloc_small(block, 4, tag);
  888.       Field(block, 0) = sp[2];
  889.       Field(block, 1) = sp[1];
  890.       Field(block, 2) = sp[0];
  891.       Field(block, 3) = accu;
  892.       sp += 3;
  893.       accu = block;
  894.       Next;
  895.     }
  896.  
  897. /* Access to components of blocks */
  898.  
  899.     Instruct(GETFIELD0):
  900.       accu = Field(accu, 0); Next;
  901.     Instruct(GETFIELD1):
  902.       accu = Field(accu, 1); Next;
  903.     Instruct(GETFIELD2):
  904.       accu = Field(accu, 2); Next;
  905.     Instruct(GETFIELD3):
  906.       accu = Field(accu, 3); Next;
  907.     Instruct(GETFIELD):
  908.       accu = Field(accu, u16pc); pc += SHORT; Next;
  909.  
  910.     Instruct(GETFIELD0_0):
  911.       accu = Field(accu, 0); 
  912.       accu = Field(accu, 0); 
  913.       Next;
  914.  
  915.     Instruct(GETFIELD0_1):
  916.       accu = Field(accu, 0); 
  917.       accu = Field(accu, 1); 
  918.       Next;
  919.  
  920.     Instruct(GETFIELD1_0):
  921.       accu = Field(accu, 1); 
  922.       accu = Field(accu, 0); 
  923.       Next;
  924.  
  925.     Instruct(GETFIELD1_1):
  926.       accu = Field(accu, 1); 
  927.       accu = Field(accu, 1); 
  928.       Next;
  929.  
  930.     Instruct(SETFIELD0):
  931.       modify_dest = &Field(*sp++, 0);
  932.       modify_newval = accu;
  933.     modify:
  934.       Modify(modify_dest, modify_newval);
  935.       accu = Val_unit; /* Atom(0); */
  936.       Next;
  937.     Instruct(SETFIELD1):
  938.       modify_dest = &Field(*sp++, 1);
  939.       modify_newval = accu;
  940.       goto modify;
  941.     Instruct(SETFIELD2):
  942.       modify_dest = &Field(*sp++, 2);
  943.       modify_newval = accu;
  944.       goto modify;
  945.     Instruct(SETFIELD3):
  946.       modify_dest = &Field(*sp++, 3);
  947.       modify_newval = accu;
  948.       goto modify;
  949.     Instruct(SETFIELD):
  950.       modify_dest = &Field(*sp++, u16pc);
  951.       pc += SHORT;
  952.       modify_newval = accu;
  953.       goto modify;
  954.  
  955. /* Array operations */
  956.  
  957.     Instruct(VECTLENGTH):
  958.       accu = Val_long(Wosize_val(accu));
  959.       Next;
  960.     Instruct(GETVECTITEM):
  961.       accu = Field(sp[0], Long_val(accu));
  962.       sp += 1;
  963.       Next;
  964.     Instruct(SETVECTITEM):
  965.       modify_dest = &Field(sp[1], Long_val(sp[0]));
  966.       modify_newval = accu;
  967.       sp += 2;
  968.       goto modify;
  969.  
  970. /* String operations */
  971.  
  972.     Instruct(GETSTRINGCHAR):
  973.       accu = Val_int(Byte_u(sp[0], Long_val(accu)));
  974.       sp += 1;
  975.       Next;
  976.     Instruct(SETSTRINGCHAR):
  977.       Byte_u(sp[1], Long_val(sp[0])) = Int_val(accu);
  978.       accu = Atom(0);
  979.       sp += 2;
  980.       Next;
  981.  
  982. /* Branches and conditional branches */
  983.  
  984. #define branch() pc += s16pc
  985.  
  986.     Instruct(BRANCH):
  987.       branch(); Next;
  988.     Instruct(BRANCHIF):
  989.       if (Tag_val(accu) != 0) branch(); else pc += SHORT;
  990.       Next;
  991.     Instruct(BRANCHIFNOT):
  992.       if (Tag_val(accu) == 0) branch(); else pc += SHORT;
  993.       Next;
  994.     Instruct(POPBRANCHIFNOT):
  995.       tmp = accu;
  996.       accu = *sp++;
  997.       if (Tag_val(tmp) == 0) branch(); else pc += SHORT;
  998.       Next;
  999.     Instruct(BRANCHIFNEQTAG):
  1000.       if (Tag_val(accu) != *pc++) branch(); else pc += SHORT;
  1001.       Next;
  1002.     Instruct(SWITCH):
  1003.       Assert(Long_val(accu) >= 0 && Long_val(accu) < *pc);
  1004.       pc++;
  1005.       pc += s16(pc + accu - 1);
  1006.       Next;
  1007.     Instruct(BOOLNOT):
  1008.       accu = Atom(Tag_val(accu) == 0); Next;
  1009.       
  1010.  
  1011. /* Exceptions */
  1012.  
  1013.     Instruct(PUSHTRAP):
  1014.       sp -= 4;
  1015.       Trap_pc(sp) = pc + s16pc;
  1016.       Trap_link(sp) = trapsp;
  1017.       sp[2] = env;
  1018.       sp[3] = Val_long(extra_args);
  1019.       trapsp = sp;
  1020.       pc += SHORT;
  1021.       Next;
  1022.  
  1023.     Instruct(POPTRAP):
  1024.       /* We should check here if a signal is pending, to preserve the
  1025.          semantics of the program w.r.t. exceptions. Unfortunately,
  1026.          process_signal destroys the accumulator, and there is no
  1027.          convenient way to preserve it... */
  1028.       trapsp = Trap_link(sp);
  1029.       sp += 4;
  1030.       Next;
  1031.  
  1032.     raise_exception:            /* An external raise jumps here */
  1033.  
  1034.     Instruct(RAISE):            /* arg */
  1035.       sp = trapsp;
  1036.       if (sp >= stack_high - initial_sp_offset) {
  1037.         exn_bucket = accu;
  1038.         external_raise = initial_external_raise;
  1039.         longjmp(external_raise->buf, 1);
  1040.       }
  1041.       pc = Trap_pc(sp);
  1042.       trapsp = Trap_link(sp);
  1043.       env = sp[2];
  1044.       extra_args = Long_val(sp[3]);
  1045.       sp += 4;
  1046.       Next;
  1047.  
  1048.     process_signal:
  1049.       something_to_do = 0;
  1050.       if (force_minor_flag){
  1051.     force_minor_flag = 0;
  1052.     Setup_for_gc;
  1053.     minor_collection ();
  1054.     Restore_after_gc;
  1055.       }
  1056.       /* If a signal arrives between the following two instructions,
  1057.          it will be lost. */
  1058.       { int signal_number = signal_is_pending;
  1059.         signal_is_pending = 0;
  1060.         if (signal_number) {
  1061.           /* e -- to save accu, why not?:
  1062.            sp -= 8;
  1063.            sp[0] = Val_int(signal_number);
  1064.            sp[1] = (value) return_from_interrupt;
  1065.            sp[2] = Atom(0);
  1066.            sp[3] = 0;
  1067.            sp[4] = accu;
  1068.            sp[5] = (value) pc;
  1069.            sp[6] = env;
  1070.            sp[7] = Val_long(extra_args);
  1071.            instead of...
  1072.        */
  1073.           /* Push a return frame to the current code location */
  1074.           sp -= 4;
  1075.           sp[0] = Val_int(signal_number);
  1076.           sp[1] = (value) pc;
  1077.           sp[2] = env;
  1078.           sp[3] = Val_long(extra_args);
  1079.           /* Branch to the signal handler */
  1080.           /* e -- signal_handler should be a closure, but isn't in 1.31.
  1081.           env = (value )signal_handler;  // env = Field(signal_handlers, signal_number); 
  1082.           pc = Code_val(env);
  1083.           I'm lazy, so for now... */
  1084.           env = null_env;
  1085.           pc = signal_handler;
  1086.           /* */
  1087.           extra_args = 0;
  1088.         }
  1089.       }
  1090.       Next;
  1091.  
  1092. /* Calling C functions */
  1093.  
  1094.     Instruct(C_CALL1):
  1095.       Setup_for_c_call;
  1096.       accu = (cprim[u16pc])(accu);
  1097.       Restore_after_c_call;
  1098.       pc += SHORT;
  1099.       Next;
  1100.     Instruct(C_CALL2):
  1101.       Setup_for_c_call;
  1102.       /* sp[0] temporarily holds the environment pointer */
  1103.       accu = (cprim[u16pc])(sp[1], accu);
  1104.       Restore_after_c_call;
  1105.       pc += SHORT;
  1106.       sp += 1;
  1107.       Next;
  1108.     Instruct(C_CALL3):
  1109.       Setup_for_c_call;
  1110.       accu = (cprim[u16pc])(sp[2], sp[1], accu);
  1111.       Restore_after_c_call;
  1112.       pc += SHORT;
  1113.       sp += 2;
  1114.       Next;
  1115.     Instruct(C_CALL4):
  1116.       Setup_for_c_call;
  1117.       accu = (cprim[u16pc])(sp[3], sp[2], sp[1], accu);
  1118.       Restore_after_c_call;
  1119.       pc += SHORT;
  1120.       sp += 3;
  1121.       Next;
  1122.     Instruct(C_CALL5):
  1123.       Setup_for_c_call;
  1124.       accu = (cprim[u16pc])(sp[4], sp[3], sp[2], sp[1], accu);
  1125.       Restore_after_c_call;
  1126.       pc += SHORT;
  1127.       sp += 4;
  1128.       Next;
  1129.     Instruct(C_CALLN):
  1130.       { int n = *pc++;
  1131.         value * args;
  1132.     int i;
  1133.         *--sp = accu;
  1134.         Setup_for_c_call;
  1135.     args = (value*)malloc(n * sizeof(value));
  1136.     for (i = 0; i < n; i++) 
  1137.       args[i] = sp[n-i];
  1138.         accu = (cprim[u16pc])(args, n);
  1139.         Restore_after_c_call;
  1140.         pc += SHORT;
  1141.     free(args);
  1142.         sp += n;
  1143.         Next; }
  1144.  
  1145. /* small values */
  1146.  
  1147.     Instruct(CONSTBYTE): accu = *pc++;  Next;
  1148.  
  1149.     Instruct(CONSTSHORT): accu = s16pc; pc += SHORT; Next;
  1150.  
  1151. /* Integer constants */
  1152.  
  1153.     Instruct(PUSHCONST0): *--sp = accu; /* Fallthrough */
  1154.     Instruct(CONST0): accu = Val_int(0); Next;
  1155.  
  1156.     Instruct(PUSHCONST1): *--sp = accu; /* Fallthrough */
  1157.     Instruct(CONST1): accu = Val_int(1); Next;
  1158.  
  1159.     Instruct(PUSHCONST2): *--sp = accu; /* Fallthrough */
  1160.     Instruct(CONST2): accu = Val_int(2); Next;
  1161.  
  1162.     Instruct(PUSHCONST3): *--sp = accu; /* Fallthrough */
  1163.     Instruct(CONST3): accu = Val_int(3); Next;
  1164.  
  1165.     Instruct(PUSHCONSTINT): *--sp = accu; /* Fallthrough */
  1166.     Instruct(CONSTINT):
  1167.       accu = Val_int(s32pc);
  1168.       pc += LONG;
  1169.       Next;
  1170.  
  1171. /* Unsigned integer arithmetic modulo 2^(wordsize-1) */
  1172.  
  1173.     Instruct(ADDINT):        /* Modified for Moscow ML: unsigned */
  1174.       accu = (unsigned long) ((unsigned long) *sp++ 
  1175.                   + (unsigned long) (accu - 1)); Next;
  1176.     Instruct(SUBINT):        /* unsigned */
  1177.       accu = (unsigned long) ((unsigned long) *sp++ 
  1178.                   - (unsigned long) (accu - 1)); Next;
  1179.     Instruct(MULINT):        /* unsigned */
  1180.       accu = (unsigned long) (1 + (unsigned long) (*sp++ >> 1) 
  1181.                   * (unsigned long) (accu - 1)); Next;
  1182.     Instruct(DIVINT):        /* unsigned */
  1183.       tmp = accu - 1;
  1184.       if (tmp == 0) {
  1185.         accu = Atom(SMLEXN_DIV);
  1186.         goto raise_exception;
  1187.       }
  1188.       accu = Val_long((unsigned long) ((unsigned long) (*sp++ - 1) 
  1189.                        / (unsigned long) tmp));
  1190.       Next;
  1191.  
  1192.     Instruct(MODINT):
  1193.       tmp = accu - 1;
  1194.       if (tmp == 0) {
  1195.         accu = Atom(SMLEXN_DIV);
  1196.         goto raise_exception;
  1197.       }
  1198.       accu = (unsigned long) (1 + (unsigned long) (*sp++ - 1) 
  1199.                   % (unsigned long) tmp);
  1200.       Next;
  1201.  
  1202.     Instruct(ANDINT):
  1203.       accu &= *sp++; Next;
  1204.     Instruct(ORINT):
  1205.       accu |= *sp++; Next;
  1206.     Instruct(XORINT):
  1207.       accu = 1 + (accu ^ *sp++); Next;
  1208.     Instruct(SHIFTLEFTINT):
  1209.       accu = 1 + ((*sp++ - 1) << Long_val(accu)); Next;
  1210.     Instruct(SHIFTRIGHTINTSIGNED):
  1211.       accu = 1 | ((*sp++ - 1) >> Long_val(accu)); Next;
  1212.     Instruct(SHIFTRIGHTINTUNSIGNED):
  1213.       accu = 1 | ((unsigned long)(*sp++ - 1) >> Long_val(accu)); Next;
  1214.       
  1215. #define inttest(name1,name2,tst)                         \
  1216.     Instruct(name1):                                 \
  1217.       accu = Atom(*sp++ tst accu);                         \
  1218.       Next;                                     \
  1219.     Instruct(name2):                                 \
  1220.       if (*sp++ tst accu) { branch(); } else { pc += SHORT; }                \
  1221.       Next;
  1222.       
  1223.       inttest(EQ,BRANCHIFEQ,==);
  1224.       inttest(NEQ,BRANCHIFNEQ,!=);
  1225.       inttest(LTINT,BRANCHIFLT,<);
  1226.       inttest(GTINT,BRANCHIFGT,>);
  1227.       inttest(LEINT,BRANCHIFLE,<=);
  1228.       inttest(GEINT,BRANCHIFGE,>=);
  1229.  
  1230.     Instruct(TAGOF):
  1231.       accu = Val_long(Tag_val(accu));
  1232.       Next;
  1233.  
  1234. #define unsigntest(name, tst)                        \
  1235.     Instruct(name):                            \
  1236.       accu = Atom((unsigned)(*sp++) tst (unsigned)accu);        \
  1237.       Next;                                \
  1238.  
  1239.       unsigntest(EQUNSIGN,==);
  1240.       unsigntest(NEQUNSIGN,!=);
  1241.       unsigntest(LTUNSIGN,<);
  1242.       unsigntest(GTUNSIGN,>);
  1243.       unsigntest(LEUNSIGN,<=);
  1244.       unsigntest(GEUNSIGN,>=);
  1245.  
  1246.     Instruct(BRANCHINTERVAL):
  1247.       { value low_bound, high_bound;
  1248.         high_bound = accu;
  1249.         low_bound = *sp++;
  1250.         accu = *sp++;
  1251.         if (accu < low_bound) {
  1252.           branch();
  1253.           Next;
  1254.         }
  1255.         pc += SHORT;
  1256.         if (accu > high_bound) {
  1257.           branch();
  1258.           Next;
  1259.         } 
  1260.         pc += SHORT;
  1261.         accu = accu - low_bound + 1;
  1262.         Next;
  1263.       }
  1264.  
  1265.     /* --- Moscow SML changes begin --- */
  1266.  
  1267. #define Check_float(dval) \
  1268.    if ((dval > maxdouble) || (dval < -maxdouble)) \
  1269.       { accu = Atom(float_exn); goto raise_exception; }
  1270.  
  1271.     Instruct(FLOATOFINT):
  1272.     dtmp = (double) Long_val(accu); goto float_done;
  1273.  
  1274.     Instruct(SMLNEGFLOAT):
  1275.     float_exn = SMLEXN_OVF;
  1276.     dtmp = -Double_val(accu);
  1277.     Check_float(dtmp); goto float_done;
  1278.  
  1279.     Instruct(SMLADDFLOAT):
  1280.     float_exn = SMLEXN_OVF;
  1281.     dtmp = Double_val(*sp++) + Double_val(accu);
  1282.     Check_float(dtmp); goto float_done;
  1283.  
  1284.     Instruct(SMLSUBFLOAT):
  1285.     float_exn = SMLEXN_OVF;
  1286.     dtmp = Double_val(*sp++) - Double_val(accu);
  1287.     Check_float(dtmp); goto float_done;
  1288.  
  1289.     Instruct(SMLMULFLOAT):
  1290.     float_exn = SMLEXN_OVF;
  1291.     dtmp = Double_val(*sp++) * Double_val(accu);
  1292.     Check_float(dtmp); goto float_done;
  1293.  
  1294.     Instruct(SMLDIVFLOAT):
  1295.     float_exn = SMLEXN_OVF;
  1296.     dtmp = Double_val(accu);
  1297.     if (dtmp == 0) {
  1298.         accu = Atom(SMLEXN_DIV);
  1299.         goto raise_exception;
  1300.     }
  1301.     dtmp = Double_val(*sp++) / dtmp;
  1302.     Check_float(dtmp); /* Fallthrough */
  1303.     float_done:
  1304.     Alloc_small(tmp, Double_wosize, Double_tag);
  1305.     Store_double_val(tmp, dtmp);
  1306.     accu = tmp;
  1307.     Next;
  1308.  
  1309.     /* --- Moscow SML changes end --- */
  1310.       
  1311.     Instruct(INTOFFLOAT):
  1312.       accu = Val_long((long)Double_val(accu)); Next;
  1313.       
  1314. #define floattest(name, tst)                             \
  1315.     Instruct(name):                                 \
  1316.       accu = Atom(Double_val(*sp++) tst Double_val(accu));             \
  1317.       Next;
  1318.       
  1319.       floattest(EQFLOAT,==);
  1320.       floattest(NEQFLOAT,!=);
  1321.       floattest(LTFLOAT,<);
  1322.       floattest(GTFLOAT,>);
  1323.       floattest(LEFLOAT,<=);
  1324.       floattest(GEFLOAT,>=);
  1325.       
  1326.     Instruct(STRINGLENGTH):
  1327.       accu = Val_long(string_length(accu));
  1328.       Next;
  1329.  
  1330. #define stringtest(name, tst)                                                \
  1331.     Instruct(name):                                                          \
  1332.       accu = Atom(compare_strings(*sp++, accu) tst Val_long(0));             \
  1333.       Next;
  1334.       
  1335.       stringtest(EQSTRING,==);
  1336.       stringtest(NEQSTRING,!=);
  1337.       stringtest(LTSTRING,<);
  1338.       stringtest(GTSTRING,>);
  1339.       stringtest(LESTRING,<=);
  1340.       stringtest(GESTRING, >=);
  1341.  
  1342.     Instruct(MAKEVECTOR):
  1343.       { mlsize_t size = Long_val(sp[0]);
  1344.         /* Make sure that the object referred to by sp[0] survives gc: */
  1345.         sp[0] = accu;
  1346.         if (size == 0)
  1347.           accu = Atom(0);
  1348.         else if (size < Max_young_wosize){
  1349.       Alloc_small (accu, size, 0);
  1350.       do {size--; Field (accu, size) = *sp;} while (size != 0);
  1351.     }else if (Is_block (*sp) && Is_young (*sp)){
  1352.       Setup_for_gc;
  1353.       minor_collection ();
  1354.       tmp = alloc_shr (size, 0);
  1355.       Restore_after_gc;
  1356.           accu = tmp;
  1357.       do {size--; Field (accu, size) = *sp;} while (size != 0);
  1358.     }else{
  1359.       Setup_for_gc;
  1360.       tmp = alloc_shr (size, 0);
  1361.       Restore_after_gc;
  1362.           accu = tmp;
  1363.       do {size--; initialize(&Field(accu, size), *sp);} while (size != 0);
  1364.     }
  1365.     sp++;
  1366.     Next;
  1367.       }
  1368.  
  1369. /* --- Additional instructions for Moscow SML --- */
  1370.  
  1371.     Instruct(SMLNEGINT):
  1372.       tmp =  - Long_val(accu);
  1373.       accu = Val_long(tmp);
  1374.       if( Long_val(accu) != tmp ) {
  1375.         accu = Atom(SMLEXN_OVF);
  1376.         goto raise_exception;
  1377.       }
  1378.       Next;
  1379.     Instruct(SMLSUCCINT):
  1380.       tmp =  Long_val(accu) + 1;
  1381.       accu = Val_long(tmp);
  1382.       if( Long_val(accu) != tmp ) {
  1383.         accu = Atom(SMLEXN_OVF);
  1384.         goto raise_exception;
  1385.       }
  1386.       Next;
  1387.     Instruct(SMLPREDINT):
  1388.       tmp =  Long_val(accu) - 1;
  1389.       accu = Val_long(tmp);
  1390.       if( Long_val(accu) != tmp ) {
  1391.         accu = Atom(SMLEXN_OVF);
  1392.         goto raise_exception;
  1393.       }
  1394.       Next;
  1395.     Instruct(SMLADDINT):
  1396.       tmp = Long_val(*sp++) + Long_val(accu);
  1397.       accu = Val_long(tmp);
  1398.       if( Long_val(accu) != tmp ) goto raise_sum;
  1399.       Next;
  1400.       raise_sum:
  1401.         accu = Atom(SMLEXN_OVF);
  1402.         goto raise_exception;
  1403.     Instruct(SMLSUBINT):
  1404.       tmp = Long_val(*sp++) - Long_val(accu);
  1405.       accu = Val_long(tmp);
  1406.       if( Long_val(accu) != tmp ) goto raise_diff;
  1407.       Next;
  1408.       raise_diff:
  1409.         accu = Atom(SMLEXN_OVF);
  1410.         goto raise_exception;
  1411.  
  1412. #define ChunkLen (4 * sizeof(value) - 1)
  1413. #define MaxChunk ((1L << ChunkLen) - 1)
  1414.  
  1415.     Instruct(SMLMULINT):
  1416.       { register long x, y;
  1417.         register int isNegative = 0;
  1418.         x = Long_val(*sp++);
  1419.         y = Long_val(accu);
  1420.         if( x < 0 ) { x = -x; isNegative = 1; }
  1421.         if( y < 0 ) { y = -y; isNegative = !isNegative; }
  1422.         if( y > x ) { tmp = y; y = x; x = tmp; }
  1423.         if( y > MaxChunk ) goto raise_prod;
  1424.         if( x <= MaxChunk )
  1425.           { accu = Val_long(isNegative?(-(x * y)):(x * y)); }
  1426.         else /* x > MaxChunk */
  1427.           { tmp = (x >> ChunkLen) * y;
  1428.             if( tmp > MaxChunk + 1) goto raise_prod;
  1429.             tmp = (tmp << ChunkLen) + (x & MaxChunk) * y;
  1430.             if( isNegative ) tmp = - tmp;
  1431.             accu = Val_long(tmp);
  1432.             if( Long_val(accu) != tmp ) goto raise_prod;
  1433.           }
  1434.       }
  1435.       Next;
  1436.       raise_prod :
  1437.         accu = Atom(SMLEXN_OVF);
  1438.         goto raise_exception;
  1439.  
  1440.     Instruct(SMLDIVINT):
  1441.       tmp = Long_val(accu);
  1442.       accu = Long_val(*sp++);
  1443.       if (tmp == 0) 
  1444.     { accu = Atom(SMLEXN_DIV);
  1445.       goto raise_exception;
  1446.     }
  1447.       if( tmp < 0 ) { accu = - accu; tmp = -tmp; }
  1448.       if( accu >= 0 )
  1449.         { tmp = accu / tmp; }
  1450.       else
  1451.         { accu = - accu;
  1452.           if( accu % tmp == 0 )
  1453.             tmp = - (accu /tmp);
  1454.           else
  1455.             tmp = - (accu / tmp) - 1;
  1456.         }
  1457.       accu = Val_long(tmp);
  1458.       if( Long_val(accu) != tmp ) 
  1459.     { accu = Atom(SMLEXN_OVF);
  1460.       goto raise_exception;
  1461.     }
  1462.       Next;
  1463.  
  1464.     Instruct(SMLMODINT):
  1465.       { register long y;
  1466.       y = tmp = Long_val(accu);
  1467.       accu = Long_val(*sp++);
  1468.       if (tmp == 0) 
  1469.     { accu = Atom(SMLEXN_DIV);
  1470.       goto raise_exception;
  1471.     }
  1472.       if( tmp < 0 ) { accu = -accu; tmp = -tmp; }
  1473.       if( accu >= 0 )
  1474.         tmp = accu % tmp;
  1475.       else
  1476.         { accu = (-accu) % tmp;
  1477.           tmp = ( accu == 0 )?( 0 ):( tmp - accu );
  1478.         }
  1479.       if( y < 0 ) tmp = -tmp;
  1480.       accu = Val_long(tmp);
  1481.       if( Long_val(accu) != tmp ) 
  1482.     { accu = Atom(SMLEXN_OVF);
  1483.       goto raise_exception;
  1484.     }
  1485.       }
  1486.       Next;
  1487.  
  1488.     Instruct(MAKEREFVECTOR):
  1489.       { mlsize_t size = Long_val(sp[0]);
  1490.         sp[0] = accu;
  1491.         if (size == 0)
  1492.           accu = Atom(Reference_tag);
  1493.         else if (size < Max_young_wosize){
  1494.           Alloc_small (accu, size, Reference_tag);
  1495.       do {size--; Field (accu, size) = *sp;} while (size != 0);
  1496.     }else if (Is_block (*sp) && Is_young (*sp)){
  1497.       Setup_for_gc;
  1498.       minor_collection ();
  1499.           tmp = alloc_shr (size, Reference_tag);
  1500.       Restore_after_gc;
  1501.           accu = tmp;
  1502.       do {size--; Field (accu, size) = *sp;} while (size != 0);
  1503.     }else{
  1504.       Setup_for_gc;
  1505.           tmp = alloc_shr (size, Reference_tag);
  1506.       Restore_after_gc;
  1507.           accu = tmp;
  1508.       do {size--; initialize(&Field(accu, size), *sp);} while (size != 0);
  1509.     }
  1510.     sp++;
  1511.     Next;
  1512.       }
  1513.  
  1514.     Instruct(SMLQUOTINT):
  1515.       tmp = accu - 1;
  1516.       if (tmp == 0) 
  1517.     { accu = Atom(SMLEXN_DIV);
  1518.       goto raise_exception;
  1519.     }
  1520.       tmp = (*sp++ - 1) / tmp;
  1521.       accu = Val_long(tmp);
  1522.       if( Long_val(accu) != tmp ) 
  1523.     { accu = Atom(SMLEXN_OVF);
  1524.       goto raise_exception;
  1525.     }
  1526.       Next;
  1527.     Instruct(SMLREMINT):
  1528.       tmp = accu - 1;
  1529.       if (tmp == 0) {
  1530.         accu = Atom(SMLEXN_DIV);
  1531.         goto raise_exception;
  1532.       }
  1533.       accu = 1 + (*sp++ - 1) % tmp;
  1534.       Next;
  1535.  
  1536. /* --- End of additional instructions for Moscow SML --- */
  1537.  
  1538. /* Machine control */
  1539.  
  1540.     Instruct(STOP):
  1541.       extern_sp = sp;
  1542.       external_raise = initial_external_raise;
  1543.       DUMPTABLE
  1544.       return accu;
  1545.       
  1546. #ifdef DIRECT_JUMP
  1547.     lbl_EVENT:
  1548. #else
  1549.     default:
  1550. #endif
  1551.  
  1552.       fatal_error("bad opcode");
  1553.  
  1554. #ifndef DIRECT_JUMP
  1555.     }
  1556.   }
  1557. #endif
  1558. }
  1559.  
  1560. static opcode_t callback1_code[] = { ACC1, APPLY1, POP, 1, STOP };
  1561. static opcode_t callback2_code[] = { ACC2, APPLY2, POP, 1, STOP };
  1562. static opcode_t callback3_code[] = { ACC3, APPLY3, POP, 1, STOP };
  1563.  
  1564. value callback(closure, arg)
  1565.      value closure, arg;
  1566. {
  1567.   value res;
  1568.   extern_sp -= 2;
  1569.   extern_sp[0] = arg;
  1570.   extern_sp[1] = closure;
  1571.   /* callback_depth++; */
  1572.   res = interprete(callback1_code, sizeof(callback1_code));
  1573.   /* callback_depth--; */
  1574.   return res;
  1575. }
  1576.  
  1577. value callback2(closure, arg1, arg2)
  1578.      value closure, arg1, arg2;
  1579. {
  1580.   value res;
  1581.   extern_sp -= 3;
  1582.   extern_sp[0] = arg1;
  1583.   extern_sp[1] = arg2;
  1584.   extern_sp[2] = closure;
  1585.   /* callback_depth++; */
  1586.   res = interprete(callback2_code, sizeof(callback2_code));
  1587.   /* callback_depth--; */
  1588.   return res;
  1589. }
  1590.  
  1591. value callback3(closure, arg1, arg2, arg3)
  1592.      value closure, arg1, arg2, arg3;
  1593. {
  1594.   value res;
  1595.   extern_sp -= 4;
  1596.   extern_sp[0] = arg1;
  1597.   extern_sp[1] = arg2;
  1598.   extern_sp[2] = arg3;
  1599.   extern_sp[3] = closure;
  1600.   /* callback_depth++; */
  1601.   res = interprete(callback3_code, sizeof(callback3_code));
  1602.   /* callback_depth--; */
  1603.   return res;
  1604. }
  1605.  
  1606. /* end */
  1607.