l4/pkg/ocaml/ocaml/contrib/byterun/interp.c

   1 /***********************************************************************/
   2 /*                                                                     */
   3 /*                           Objective Caml                            */
   4 /*                                                                     */
   5 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
   6 /*                                                                     */
   7 /*  Copyright 1996 Institut National de Recherche en Informatique et   */
   8 /*  en Automatique.  All rights reserved.  This file is distributed    */
   9 /*  under the terms of the GNU Library General Public License, with    */
  10 /*  the special exception on linking described in file ../LICENSE.     */
  11 /*                                                                     */
  12 /***********************************************************************/
  13
  14 /* $Id: interp.c 9513 2010-01-08 10:33:23Z xleroy $ */
  15
  16 /* The bytecode interpreter */
  17 #include <stdio.h>
  18 #include "alloc.h"
  19 #include "backtrace.h"
  20 #include "callback.h"
  21 #include "debugger.h"
  22 #include "fail.h"
  23 #include "fix_code.h"
  24 #include "instrtrace.h"
  25 #include "instruct.h"
  26 #include "interp.h"
  27 #include "major_gc.h"
  28 #include "memory.h"
  29 #include "misc.h"
  30 #include "mlvalues.h"
  31 #include "prims.h"
  32 #include "signals.h"
  33 #include "stacks.h"
  34
  35 /* Registers for the abstract machine:
  36         pc         the code pointer
  37         sp         the stack pointer (grows downward)
  38         accu       the accumulator
  39         env        heap-allocated environment
  40         caml_trapsp pointer to the current trap frame
  41         extra_args number of extra arguments provided by the caller
  42
  43 sp is a local copy of the global variable caml_extern_sp. */
  44
  45 /* Instruction decoding */
  46
  47 #ifdef THREADED_CODE
  48 #  define Instruct(name) lbl_##name
  49 #  if defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32)
  50 #    define Jumptbl_base ((char *) &&lbl_ACC0)
  51 #  else
  52 #    define Jumptbl_base ((char *) 0)
  53 #    define jumptbl_base ((char *) 0)
  54 #  endif
  55 #  ifdef DEBUG
  56 #    define Next goto next_instr
  57 #  else
  58 #    define Next goto *(void *)(jumptbl_base + *pc++)
  59 #  endif
  60 #else
  61 #  define Instruct(name) case name
  62 #  define Next break
  63 #endif
  64
  65 /* GC interface */
  66
  67 #define Setup_for_gc \
  68   { sp -= 2; sp[0] = accu; sp[1] = env; caml_extern_sp = sp; }
  69 #define Restore_after_gc \
  70   { accu = sp[0]; env = sp[1]; sp += 2; }
  71 #define Setup_for_c_call \
  72   { saved_pc = pc; *--sp = env; caml_extern_sp = sp; }
  73 #define Restore_after_c_call \
  74   { sp = caml_extern_sp; env = *sp++; saved_pc = NULL; }
  75
  76 /* An event frame must look like accu + a C_CALL frame + a RETURN 1 frame */
  77 #define Setup_for_event \
  78   { sp -= 6; \
  79     sp[0] = accu; /* accu */ \
  80     sp[1] = Val_unit; /* C_CALL frame: dummy environment */ \
  81     sp[2] = Val_unit; /* RETURN frame: dummy local 0 */ \
  82     sp[3] = (value) pc; /* RETURN frame: saved return address */ \
  83     sp[4] = env; /* RETURN frame: saved environment */ \
  84     sp[5] = Val_long(extra_args); /* RETURN frame: saved extra args */ \
  85     caml_extern_sp = sp; }
  86 #define Restore_after_event \
  87   { sp = caml_extern_sp; accu = sp[0]; \
  88     pc = (code_t) sp[3]; env = sp[4]; extra_args = Long_val(sp[5]); \
  89     sp += 6; }
  90
  91 /* Debugger interface */
  92
  93 #define Setup_for_debugger \
  94    { sp -= 4; \
  95      sp[0] = accu; sp[1] = (value)(pc - 1); \
  96      sp[2] = env; sp[3] = Val_long(extra_args); \
  97      caml_extern_sp = sp; }
  98 #define Restore_after_debugger { sp += 4; }
  99
 100 #ifdef THREADED_CODE
 101 #define Restart_curr_instr \
 102   goto *(jumptable[caml_saved_code[pc - 1 - caml_start_code]])
 103 #else
 104 #define Restart_curr_instr \
 105   curr_instr = caml_saved_code[pc - 1 - caml_start_code]; \
 106   goto dispatch_instr
 107 #endif
 108
 109 /* Register optimization.
 110    Some compilers underestimate the use of the local variables representing
 111    the abstract machine registers, and don't put them in hardware registers,
 112    which slows down the interpreter considerably.
 113    For GCC, I have hand-assigned hardware registers for several architectures.
 114 */
 115
 116 #if defined(__GNUC__) && !defined(DEBUG) && !defined(__INTEL_COMPILER) && !defined(__llvm__)
 117 #ifdef __mips__
 118 #define PC_REG asm("$16")
 119 #define SP_REG asm("$17")
 120 #define ACCU_REG asm("$18")
 121 #endif
 122 #ifdef __sparc__
 123 #define PC_REG asm("%l0")
 124 #define SP_REG asm("%l1")
 125 #define ACCU_REG asm("%l2")
 126 #endif
 127 #ifdef __alpha__
 128 #ifdef __CRAY__
 129 #define PC_REG asm("r9")
 130 #define SP_REG asm("r10")
 131 #define ACCU_REG asm("r11")
 132 #define JUMPTBL_BASE_REG asm("r12")
 133 #else
 134 #define PC_REG asm("$9")
 135 #define SP_REG asm("$10")
 136 #define ACCU_REG asm("$11")
 137 #define JUMPTBL_BASE_REG asm("$12")
 138 #endif
 139 #endif
 140 #ifdef __i386__
 141 #define PC_REG asm("%esi")
 142 #define SP_REG asm("%edi")
 143 #define ACCU_REG
 144 #endif
 145 #if defined(__ppc__) || defined(__ppc64__)
 146 #define PC_REG asm("26")
 147 #define SP_REG asm("27")
 148 #define ACCU_REG asm("28")
 149 #endif
 150 #ifdef __hppa__
 151 #define PC_REG asm("%r18")
 152 #define SP_REG asm("%r17")
 153 #define ACCU_REG asm("%r16")
 154 #endif
 155 #ifdef __mc68000__
 156 #define PC_REG asm("a5")
 157 #define SP_REG asm("a4")
 158 #define ACCU_REG asm("d7")
 159 #endif
 160 /* PR#4953: these specific registers not available in Thumb mode */
 161 #if defined (__arm__) && !defined(__thumb__)
 162 #define PC_REG asm("r9")
 163 #define SP_REG asm("r8")
 164 #define ACCU_REG asm("r7")
 165 #endif
 166 #ifdef __ia64__
 167 #define PC_REG asm("36")
 168 #define SP_REG asm("37")
 169 #define ACCU_REG asm("38")
 170 #define JUMPTBL_BASE_REG asm("39")
 171 #endif
 172 #ifdef __x86_64__
 173 #define PC_REG asm("%r15")
 174 #define SP_REG asm("%r14")
 175 #define ACCU_REG asm("%r13")
 176 #endif
 177 #endif
 178
 179 /* Division and modulus madness */
 180
 181 #ifdef NONSTANDARD_DIV_MOD
 182 extern intnat caml_safe_div(intnat p, intnat q);
 183 extern intnat caml_safe_mod(intnat p, intnat q);
 184 #endif
 185
 186
 187 #ifdef DEBUG
 188 static intnat caml_bcodcount;
 189 #endif
 190
 191 /* The interpreter itself */
 192
 193 value caml_interprete(code_t prog, asize_t prog_size)
 194 {
 195 #ifdef PC_REG
 196   register code_t pc PC_REG;
 197   register value * sp SP_REG;
 198   register value accu ACCU_REG;
 199 #else
 200   register code_t pc;
 201   register value * sp;
 202   register value accu;
 203 #endif
 204 #if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32)
 205 #ifdef JUMPTBL_BASE_REG
 206   register char * jumptbl_base JUMPTBL_BASE_REG;
 207 #else
 208   register char * jumptbl_base;
 209 #endif
 210 #endif
 211   value env;
 212   intnat extra_args;
 213   struct longjmp_buffer * initial_external_raise;
 214   int initial_sp_offset;
 215   /* volatile ensures that initial_local_roots and saved_pc
 216      will keep correct value across longjmp */
 217   struct caml__roots_block * volatile initial_local_roots;
 218   volatile code_t saved_pc = NULL;
 219   struct longjmp_buffer raise_buf;
 220   value * modify_dest, modify_newval;
 221 #ifndef THREADED_CODE
 222   opcode_t curr_instr;
 223 #endif
 224
 225 #ifdef THREADED_CODE
 226   static void * jumptable[] = {
 227 #    include "jumptbl.h"
 228   };
 229 #endif
 230
 231   if (prog == NULL) {           /* Interpreter is initializing */
 232 #ifdef THREADED_CODE
 233     caml_instr_table = (char **) jumptable;
 234     caml_instr_base = Jumptbl_base;
 235 #endif
 236     return Val_unit;
 237   }
 238
 239 #if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32)
 240   jumptbl_base = Jumptbl_base;
 241 #endif
 242   initial_local_roots = caml_local_roots;
 243   initial_sp_offset = (char *) caml_stack_high - (char *) caml_extern_sp;
 244   initial_external_raise = caml_external_raise;
 245   caml_callback_depth++;
 246   saved_pc = NULL;
 247
 248   if (sigsetjmp(raise_buf.buf, 0)) {
 249     caml_local_roots = initial_local_roots;
 250     sp = caml_extern_sp;
 251     accu = caml_exn_bucket;
 252     pc = saved_pc; saved_pc = NULL;
 253     if (pc != NULL) pc += 2;
 254         /* +2 adjustement for the sole purpose of backtraces */
 255     goto raise_exception;
 256   }
 257   caml_external_raise = &raise_buf;
 258
 259   sp = caml_extern_sp;
 260   pc = prog;
 261   extra_args = 0;
 262   env = Atom(0);
 263   accu = Val_int(0);
 264
 265 #ifdef THREADED_CODE
 266 #ifdef DEBUG
 267  next_instr:
 268   if (caml_icount-- == 0) caml_stop_here ();
 269   Assert(sp >= caml_stack_low);
 270   Assert(sp <= caml_stack_high);
 271 #endif
 272   goto *(void *)(jumptbl_base + *pc++); /* Jump to the first instruction */
 273 #else
 274   while(1) {
 275 #ifdef DEBUG
 276     caml_bcodcount++;
 277     if (caml_icount-- == 0) caml_stop_here ();
 278     if (caml_trace_flag>1) printf("\n##%ld\n", caml_bcodcount);
 279     if (caml_trace_flag) caml_disasm_instr(pc);
 280     if (caml_trace_flag>1) {
 281       printf("env=");
 282       caml_trace_value_file(env,prog,prog_size,stdout);
 283       putchar('\n');
 284       caml_trace_accu_sp_file(accu,sp,prog,prog_size,stdout);
 285       fflush(stdout);
 286     };
 287     Assert(sp >= caml_stack_low);
 288     Assert(sp <= caml_stack_high);
 289 #endif
 290     curr_instr = *pc++;
 291
 292   dispatch_instr:
 293     switch(curr_instr) {
 294 #endif
 295
 296 /* Basic stack operations */
 297
 298     Instruct(ACC0):
 299       accu = sp[0]; Next;
 300     Instruct(ACC1):
 301       accu = sp[1]; Next;
 302     Instruct(ACC2):
 303       accu = sp[2]; Next;
 304     Instruct(ACC3):
 305       accu = sp[3]; Next;
 306     Instruct(ACC4):
 307       accu = sp[4]; Next;
 308     Instruct(ACC5):
 309       accu = sp[5]; Next;
 310     Instruct(ACC6):
 311       accu = sp[6]; Next;
 312     Instruct(ACC7):
 313       accu = sp[7]; Next;
 314
 315     Instruct(PUSH): Instruct(PUSHACC0):
 316       *--sp = accu; Next;
 317     Instruct(PUSHACC1):
 318       *--sp = accu; accu = sp[1]; Next;
 319     Instruct(PUSHACC2):
 320       *--sp = accu; accu = sp[2]; Next;
 321     Instruct(PUSHACC3):
 322       *--sp = accu; accu = sp[3]; Next;
 323     Instruct(PUSHACC4):
 324       *--sp = accu; accu = sp[4]; Next;
 325     Instruct(PUSHACC5):
 326       *--sp = accu; accu = sp[5]; Next;
 327     Instruct(PUSHACC6):
 328       *--sp = accu; accu = sp[6]; Next;
 329     Instruct(PUSHACC7):
 330       *--sp = accu; accu = sp[7]; Next;
 331
 332     Instruct(PUSHACC):
 333       *--sp = accu;
 334       /* Fallthrough */
 335     Instruct(ACC):
 336       accu = sp[*pc++];
 337       Next;
 338
 339     Instruct(POP):
 340       sp += *pc++;
 341       Next;
 342     Instruct(ASSIGN):
 343       sp[*pc++] = accu;
 344       accu = Val_unit;
 345       Next;
 346
 347 /* Access in heap-allocated environment */
 348
 349     Instruct(ENVACC1):
 350       accu = Field(env, 1); Next;
 351     Instruct(ENVACC2):
 352       accu = Field(env, 2); Next;
 353     Instruct(ENVACC3):
 354       accu = Field(env, 3); Next;
 355     Instruct(ENVACC4):
 356       accu = Field(env, 4); Next;
 357
 358     Instruct(PUSHENVACC1):
 359       *--sp = accu; accu = Field(env, 1); Next;
 360     Instruct(PUSHENVACC2):
 361       *--sp = accu; accu = Field(env, 2); Next;
 362     Instruct(PUSHENVACC3):
 363       *--sp = accu; accu = Field(env, 3); Next;
 364     Instruct(PUSHENVACC4):
 365       *--sp = accu; accu = Field(env, 4); Next;
 366
 367     Instruct(PUSHENVACC):
 368       *--sp = accu;
 369       /* Fallthrough */
 370     Instruct(ENVACC):
 371       accu = Field(env, *pc++);
 372       Next;
 373
 374 /* Function application */
 375
 376     Instruct(PUSH_RETADDR): {
 377       sp -= 3;
 378       sp[0] = (value) (pc + *pc);
 379       sp[1] = env;
 380       sp[2] = Val_long(extra_args);
 381       pc++;
 382       Next;
 383     }
 384     Instruct(APPLY): {
 385       extra_args = *pc - 1;
 386       pc = Code_val(accu);
 387       env = accu;
 388       goto check_stacks;
 389     }
 390     Instruct(APPLY1): {
 391       value arg1 = sp[0];
 392       sp -= 3;
 393       sp[0] = arg1;
 394       sp[1] = (value)pc;
 395       sp[2] = env;
 396       sp[3] = Val_long(extra_args);
 397       pc = Code_val(accu);
 398       env = accu;
 399       extra_args = 0;
 400       goto check_stacks;
 401     }
 402     Instruct(APPLY2): {
 403       value arg1 = sp[0];
 404       value arg2 = sp[1];
 405       sp -= 3;
 406       sp[0] = arg1;
 407       sp[1] = arg2;
 408       sp[2] = (value)pc;
 409       sp[3] = env;
 410       sp[4] = Val_long(extra_args);
 411       pc = Code_val(accu);
 412       env = accu;
 413       extra_args = 1;
 414       goto check_stacks;
 415     }
 416     Instruct(APPLY3): {
 417       value arg1 = sp[0];
 418       value arg2 = sp[1];
 419       value arg3 = sp[2];
 420       sp -= 3;
 421       sp[0] = arg1;
 422       sp[1] = arg2;
 423       sp[2] = arg3;
 424       sp[3] = (value)pc;
 425       sp[4] = env;
 426       sp[5] = Val_long(extra_args);
 427       pc = Code_val(accu);
 428       env = accu;
 429       extra_args = 2;
 430       goto check_stacks;
 431     }
 432
 433     Instruct(APPTERM): {
 434       int nargs = *pc++;
 435       int slotsize = *pc;
 436       value * newsp;
 437       int i;
 438       /* Slide the nargs bottom words of the current frame to the top
 439          of the frame, and discard the remainder of the frame */
 440       newsp = sp + slotsize - nargs;
 441       for (i = nargs - 1; i >= 0; i--) newsp[i] = sp[i];
 442       sp = newsp;
 443       pc = Code_val(accu);
 444       env = accu;
 445       extra_args += nargs - 1;
 446       goto check_stacks;
 447     }
 448     Instruct(APPTERM1): {
 449       value arg1 = sp[0];
 450       sp = sp + *pc - 1;
 451       sp[0] = arg1;
 452       pc = Code_val(accu);
 453       env = accu;
 454       goto check_stacks;
 455     }
 456     Instruct(APPTERM2): {
 457       value arg1 = sp[0];
 458       value arg2 = sp[1];
 459       sp = sp + *pc - 2;
 460       sp[0] = arg1;
 461       sp[1] = arg2;
 462       pc = Code_val(accu);
 463       env = accu;
 464       extra_args += 1;
 465       goto check_stacks;
 466     }
 467     Instruct(APPTERM3): {
 468       value arg1 = sp[0];
 469       value arg2 = sp[1];
 470       value arg3 = sp[2];
 471       sp = sp + *pc - 3;
 472       sp[0] = arg1;
 473       sp[1] = arg2;
 474       sp[2] = arg3;
 475       pc = Code_val(accu);
 476       env = accu;
 477       extra_args += 2;
 478       goto check_stacks;
 479     }
 480
 481     Instruct(RETURN): {
 482       sp += *pc++;
 483       if (extra_args > 0) {
 484         extra_args--;
 485         pc = Code_val(accu);
 486         env = accu;
 487       } else {
 488         pc = (code_t)(sp[0]);
 489         env = sp[1];
 490         extra_args = Long_val(sp[2]);
 491         sp += 3;
 492       }
 493       Next;
 494     }
 495
 496     Instruct(RESTART): {
 497       int num_args = Wosize_val(env) - 2;
 498       int i;
 499       sp -= num_args;
 500       for (i = 0; i < num_args; i++) sp[i] = Field(env, i + 2);
 501       env = Field(env, 1);
 502       extra_args += num_args;
 503       Next;
 504     }
 505
 506     Instruct(GRAB): {
 507       int required = *pc++;
 508       if (extra_args >= required) {
 509         extra_args -= required;
 510       } else {
 511         mlsize_t num_args, i;
 512         num_args = 1 + extra_args; /* arg1 + extra args */
 513         Alloc_small(accu, num_args + 2, Closure_tag);
 514         Field(accu, 1) = env;
 515         for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i];
 516         Code_val(accu) = pc - 3; /* Point to the preceding RESTART instr. */
 517         sp += num_args;
 518         pc = (code_t)(sp[0]);
 519         env = sp[1];
 520         extra_args = Long_val(sp[2]);
 521         sp += 3;
 522       }
 523       Next;
 524     }
 525
 526     Instruct(CLOSURE): {
 527       int nvars = *pc++;
 528       int i;
 529       if (nvars > 0) *--sp = accu;
 530       Alloc_small(accu, 1 + nvars, Closure_tag);
 531       Code_val(accu) = pc + *pc;
 532       pc++;
 533       for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i];
 534       sp += nvars;
 535       Next;
 536     }
 537
 538     Instruct(CLOSUREREC): {
 539       int nfuncs = *pc++;
 540       int nvars = *pc++;
 541       int i;
 542       value * p;
 543       if (nvars > 0) *--sp = accu;
 544       Alloc_small(accu, nfuncs * 2 - 1 + nvars, Closure_tag);
 545       p = &Field(accu, nfuncs * 2 - 1);
 546       for (i = 0; i < nvars; i++) {
 547         *p++ = sp[i];
 548       }
 549       sp += nvars;
 550       p = &Field(accu, 0);
 551       *p = (value) (pc + pc[0]);
 552       *--sp = accu;
 553       p++;
 554       for (i = 1; i < nfuncs; i++) {
 555         *p = Make_header(i * 2, Infix_tag, Caml_white);  /* color irrelevant. */
 556         p++;
 557         *p = (value) (pc + pc[i]);
 558         *--sp = (value) p;
 559         p++;
 560       }
 561       pc += nfuncs;
 562       Next;
 563     }
 564
 565     Instruct(PUSHOFFSETCLOSURE):
 566       *--sp = accu; /* fallthrough */
 567     Instruct(OFFSETCLOSURE):
 568       accu = env + *pc++ * sizeof(value); Next;
 569
 570     Instruct(PUSHOFFSETCLOSUREM2):
 571       *--sp = accu; /* fallthrough */
 572     Instruct(OFFSETCLOSUREM2):
 573       accu = env - 2 * sizeof(value); Next;
 574     Instruct(PUSHOFFSETCLOSURE0):
 575       *--sp = accu; /* fallthrough */
 576     Instruct(OFFSETCLOSURE0):
 577       accu = env; Next;
 578     Instruct(PUSHOFFSETCLOSURE2):
 579       *--sp = accu; /* fallthrough */
 580     Instruct(OFFSETCLOSURE2):
 581       accu = env + 2 * sizeof(value); Next;
 582
 583
 584 /* Access to global variables */
 585
 586     Instruct(PUSHGETGLOBAL):
 587       *--sp = accu;
 588       /* Fallthrough */
 589     Instruct(GETGLOBAL):
 590       accu = Field(caml_global_data, *pc);
 591       pc++;
 592       Next;
 593
 594     Instruct(PUSHGETGLOBALFIELD):
 595       *--sp = accu;
 596       /* Fallthrough */
 597     Instruct(GETGLOBALFIELD): {
 598       accu = Field(caml_global_data, *pc);
 599       pc++;
 600       accu = Field(accu, *pc);
 601       pc++;
 602       Next;
 603     }
 604
 605     Instruct(SETGLOBAL):
 606       caml_modify(&Field(caml_global_data, *pc), accu);
 607       accu = Val_unit;
 608       pc++;
 609       Next;
 610
 611 /* Allocation of blocks */
 612
 613     Instruct(PUSHATOM0):
 614       *--sp = accu;
 615       /* Fallthrough */
 616     Instruct(ATOM0):
 617       accu = Atom(0); Next;
 618
 619     Instruct(PUSHATOM):
 620       *--sp = accu;
 621       /* Fallthrough */
 622     Instruct(ATOM):
 623       accu = Atom(*pc++); Next;
 624
 625     Instruct(MAKEBLOCK): {
 626       mlsize_t wosize = *pc++;
 627       tag_t tag = *pc++;
 628       mlsize_t i;
 629       value block;
 630       if (wosize <= Max_young_wosize) {
 631         Alloc_small(block, wosize, tag);
 632         Field(block, 0) = accu;
 633         for (i = 1; i < wosize; i++) Field(block, i) = *sp++;
 634       } else {
 635         block = caml_alloc_shr(wosize, tag);
 636         caml_initialize(&Field(block, 0), accu);
 637         for (i = 1; i < wosize; i++) caml_initialize(&Field(block, i), *sp++);
 638       }
 639       accu = block;
 640       Next;
 641     }
 642     Instruct(MAKEBLOCK1): {
 643       tag_t tag = *pc++;
 644       value block;
 645       Alloc_small(block, 1, tag);
 646       Field(block, 0) = accu;
 647       accu = block;
 648       Next;
 649     }
 650     Instruct(MAKEBLOCK2): {
 651       tag_t tag = *pc++;
 652       value block;
 653       Alloc_small(block, 2, tag);
 654       Field(block, 0) = accu;
 655       Field(block, 1) = sp[0];
 656       sp += 1;
 657       accu = block;
 658       Next;
 659     }
 660     Instruct(MAKEBLOCK3): {
 661       tag_t tag = *pc++;
 662       value block;
 663       Alloc_small(block, 3, tag);
 664       Field(block, 0) = accu;
 665       Field(block, 1) = sp[0];
 666       Field(block, 2) = sp[1];
 667       sp += 2;
 668       accu = block;
 669       Next;
 670     }
 671     Instruct(MAKEFLOATBLOCK): {
 672       mlsize_t size = *pc++;
 673       mlsize_t i;
 674       value block;
 675       if (size <= Max_young_wosize / Double_wosize) {
 676         Alloc_small(block, size * Double_wosize, Double_array_tag);
 677       } else {
 678         block = caml_alloc_shr(size * Double_wosize, Double_array_tag);
 679       }
 680       Store_double_field(block, 0, Double_val(accu));
 681       for (i = 1; i < size; i++){
 682         Store_double_field(block, i, Double_val(*sp));
 683         ++ sp;
 684       }
 685       accu = block;
 686       Next;
 687     }
 688
 689 /* Access to components of blocks */
 690
 691     Instruct(GETFIELD0):
 692       accu = Field(accu, 0); Next;
 693     Instruct(GETFIELD1):
 694       accu = Field(accu, 1); Next;
 695     Instruct(GETFIELD2):
 696       accu = Field(accu, 2); Next;
 697     Instruct(GETFIELD3):
 698       accu = Field(accu, 3); Next;
 699     Instruct(GETFIELD):
 700       accu = Field(accu, *pc); pc++; Next;
 701     Instruct(GETFLOATFIELD): {
 702       double d = Double_field(accu, *pc);
 703       Alloc_small(accu, Double_wosize, Double_tag);
 704       Store_double_val(accu, d);
 705       pc++;
 706       Next;
 707     }
 708
 709     Instruct(SETFIELD0):
 710       modify_dest = &Field(accu, 0);
 711       modify_newval = *sp++;
 712     modify:
 713       Modify(modify_dest, modify_newval);
 714       accu = Val_unit;
 715       Next;
 716     Instruct(SETFIELD1):
 717       modify_dest = &Field(accu, 1);
 718       modify_newval = *sp++;
 719       goto modify;
 720     Instruct(SETFIELD2):
 721       modify_dest = &Field(accu, 2);
 722       modify_newval = *sp++;
 723       goto modify;
 724     Instruct(SETFIELD3):
 725       modify_dest = &Field(accu, 3);
 726       modify_newval = *sp++;
 727       goto modify;
 728     Instruct(SETFIELD):
 729       modify_dest = &Field(accu, *pc);
 730       pc++;
 731       modify_newval = *sp++;
 732       goto modify;
 733     Instruct(SETFLOATFIELD):
 734       Store_double_field(accu, *pc, Double_val(*sp));
 735       accu = Val_unit;
 736       sp++;
 737       pc++;
 738       Next;
 739
 740 /* Array operations */
 741
 742     Instruct(VECTLENGTH): {
 743       mlsize_t size = Wosize_val(accu);
 744       if (Tag_val(accu) == Double_array_tag) size = size / Double_wosize;
 745       accu = Val_long(size);
 746       Next;
 747     }
 748     Instruct(GETVECTITEM):
 749       accu = Field(accu, Long_val(sp[0]));
 750       sp += 1;
 751       Next;
 752     Instruct(SETVECTITEM):
 753       modify_dest = &Field(accu, Long_val(sp[0]));
 754       modify_newval = sp[1];
 755       sp += 2;
 756       goto modify;
 757
 758 /* String operations */
 759
 760     Instruct(GETSTRINGCHAR):
 761       accu = Val_int(Byte_u(accu, Long_val(sp[0])));
 762       sp += 1;
 763       Next;
 764     Instruct(SETSTRINGCHAR):
 765       Byte_u(accu, Long_val(sp[0])) = Int_val(sp[1]);
 766       sp += 2;
 767       accu = Val_unit;
 768       Next;
 769
 770 /* Branches and conditional branches */
 771
 772     Instruct(BRANCH):
 773       pc += *pc;
 774       Next;
 775     Instruct(BRANCHIF):
 776       if (accu != Val_false) pc += *pc; else pc++;
 777       Next;
 778     Instruct(BRANCHIFNOT):
 779       if (accu == Val_false) pc += *pc; else pc++;
 780       Next;
 781     Instruct(SWITCH): {
 782       uint32 sizes = *pc++;
 783       if (Is_block(accu)) {
 784         intnat index = Tag_val(accu);
 785         Assert ((uintnat) index < (sizes >> 16));
 786         pc += pc[(sizes & 0xFFFF) + index];
 787       } else {
 788         intnat index = Long_val(accu);
 789         Assert ((uintnat) index < (sizes & 0xFFFF)) ;
 790         pc += pc[index];
 791       }
 792       Next;
 793     }
 794     Instruct(BOOLNOT):
 795       accu = Val_not(accu);
 796       Next;
 797
 798 /* Exceptions */
 799
 800     Instruct(PUSHTRAP):
 801       sp -= 4;
 802       Trap_pc(sp) = pc + *pc;
 803       Trap_link(sp) = caml_trapsp;
 804       sp[2] = env;
 805       sp[3] = Val_long(extra_args);
 806       caml_trapsp = sp;
 807       pc++;
 808       Next;
 809
 810     Instruct(POPTRAP):
 811       if (caml_something_to_do) {
 812         /* We must check here so that if a signal is pending and its
 813            handler triggers an exception, the exception is trapped
 814            by the current try...with, not the enclosing one. */
 815         pc--; /* restart the POPTRAP after processing the signal */
 816         goto process_signal;
 817       }
 818       caml_trapsp = Trap_link(sp);
 819       sp += 4;
 820       Next;
 821
 822     Instruct(RAISE):
 823     raise_exception:
 824       if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER);
 825       if (caml_backtrace_active) caml_stash_backtrace(accu, pc, sp);
 826       if ((char *) caml_trapsp
 827           >= (char *) caml_stack_high - initial_sp_offset) {
 828         caml_external_raise = initial_external_raise;
 829         caml_extern_sp = (value *) ((char *) caml_stack_high
 830                                     - initial_sp_offset);
 831         caml_callback_depth--;
 832         return Make_exception_result(accu);
 833       }
 834       sp = caml_trapsp;
 835       pc = Trap_pc(sp);
 836       caml_trapsp = Trap_link(sp);
 837       env = sp[2];
 838       extra_args = Long_val(sp[3]);
 839       sp += 4;
 840       Next;
 841
 842 /* Stack checks */
 843
 844     check_stacks:
 845       if (sp < caml_stack_threshold) {
 846         caml_extern_sp = sp;
 847         caml_realloc_stack(Stack_threshold / sizeof(value));
 848         sp = caml_extern_sp;
 849       }
 850       /* Fall through CHECK_SIGNALS */
 851
 852 /* Signal handling */
 853
 854     Instruct(CHECK_SIGNALS):    /* accu not preserved */
 855       if (caml_something_to_do) goto process_signal;
 856       Next;
 857
 858     process_signal:
 859       caml_something_to_do = 0;
 860       Setup_for_event;
 861       caml_process_event();
 862       Restore_after_event;
 863       Next;
 864
 865 /* Calling C functions */
 866
 867     Instruct(C_CALL1):
 868       Setup_for_c_call;
 869       accu = Primitive(*pc)(accu);
 870       Restore_after_c_call;
 871       pc++;
 872       Next;
 873     Instruct(C_CALL2):
 874       Setup_for_c_call;
 875       accu = Primitive(*pc)(accu, sp[1]);
 876       Restore_after_c_call;
 877       sp += 1;
 878       pc++;
 879       Next;
 880     Instruct(C_CALL3):
 881       Setup_for_c_call;
 882       accu = Primitive(*pc)(accu, sp[1], sp[2]);
 883       Restore_after_c_call;
 884       sp += 2;
 885       pc++;
 886       Next;
 887     Instruct(C_CALL4):
 888       Setup_for_c_call;
 889       accu = Primitive(*pc)(accu, sp[1], sp[2], sp[3]);
 890       Restore_after_c_call;
 891       sp += 3;
 892       pc++;
 893       Next;
 894     Instruct(C_CALL5):
 895       Setup_for_c_call;
 896       accu = Primitive(*pc)(accu, sp[1], sp[2], sp[3], sp[4]);
 897       Restore_after_c_call;
 898       sp += 4;
 899       pc++;
 900       Next;
 901     Instruct(C_CALLN): {
 902       int nargs = *pc++;
 903       *--sp = accu;
 904       Setup_for_c_call;
 905       accu = Primitive(*pc)(sp + 1, nargs);
 906       Restore_after_c_call;
 907       sp += nargs;
 908       pc++;
 909       Next;
 910     }
 911
 912 /* Integer constants */
 913
 914     Instruct(CONST0):
 915       accu = Val_int(0); Next;
 916     Instruct(CONST1):
 917       accu = Val_int(1); Next;
 918     Instruct(CONST2):
 919       accu = Val_int(2); Next;
 920     Instruct(CONST3):
 921       accu = Val_int(3); Next;
 922
 923     Instruct(PUSHCONST0):
 924       *--sp = accu; accu = Val_int(0); Next;
 925     Instruct(PUSHCONST1):
 926       *--sp = accu; accu = Val_int(1); Next;
 927     Instruct(PUSHCONST2):
 928       *--sp = accu; accu = Val_int(2); Next;
 929     Instruct(PUSHCONST3):
 930       *--sp = accu; accu = Val_int(3); Next;
 931
 932     Instruct(PUSHCONSTINT):
 933       *--sp = accu;
 934       /* Fallthrough */
 935     Instruct(CONSTINT):
 936       accu = Val_int(*pc);
 937       pc++;
 938       Next;
 939
 940 /* Integer arithmetic */
 941
 942     Instruct(NEGINT):
 943       accu = (value)(2 - (intnat)accu); Next;
 944     Instruct(ADDINT):
 945       accu = (value)((intnat) accu + (intnat) *sp++ - 1); Next;
 946     Instruct(SUBINT):
 947       accu = (value)((intnat) accu - (intnat) *sp++ + 1); Next;
 948     Instruct(MULINT):
 949       accu = Val_long(Long_val(accu) * Long_val(*sp++)); Next;
 950
 951     Instruct(DIVINT): {
 952       intnat divisor = Long_val(*sp++);
 953       if (divisor == 0) { Setup_for_c_call; caml_raise_zero_divide(); }
 954 #ifdef NONSTANDARD_DIV_MOD
 955       accu = Val_long(caml_safe_div(Long_val(accu), divisor));
 956 #else
 957       accu = Val_long(Long_val(accu) / divisor);
 958 #endif
 959       Next;
 960     }
 961     Instruct(MODINT): {
 962       intnat divisor = Long_val(*sp++);
 963       if (divisor == 0) { Setup_for_c_call; caml_raise_zero_divide(); }
 964 #ifdef NONSTANDARD_DIV_MOD
 965       accu = Val_long(caml_safe_mod(Long_val(accu), divisor));
 966 #else
 967       accu = Val_long(Long_val(accu) % divisor);
 968 #endif
 969       Next;
 970     }
 971     Instruct(ANDINT):
 972       accu = (value)((intnat) accu & (intnat) *sp++); Next;
 973     Instruct(ORINT):
 974       accu = (value)((intnat) accu | (intnat) *sp++); Next;
 975     Instruct(XORINT):
 976       accu = (value)(((intnat) accu ^ (intnat) *sp++) | 1); Next;
 977     Instruct(LSLINT):
 978       accu = (value)((((intnat) accu - 1) << Long_val(*sp++)) + 1); Next;
 979     Instruct(LSRINT):
 980       accu = (value)((((uintnat) accu - 1) >> Long_val(*sp++)) | 1);
 981       Next;
 982     Instruct(ASRINT):
 983       accu = (value)((((intnat) accu - 1) >> Long_val(*sp++)) | 1); Next;
 984
 985 #define Integer_comparison(typ,opname,tst) \
 986     Instruct(opname): \
 987       accu = Val_int((typ) accu tst (typ) *sp++); Next;
 988
 989     Integer_comparison(intnat,EQ, ==)
 990     Integer_comparison(intnat,NEQ, !=)
 991     Integer_comparison(intnat,LTINT, <)
 992     Integer_comparison(intnat,LEINT, <=)
 993     Integer_comparison(intnat,GTINT, >)
 994     Integer_comparison(intnat,GEINT, >=)
 995     Integer_comparison(uintnat,ULTINT, <)
 996     Integer_comparison(uintnat,UGEINT, >=)
 997
 998 #define Integer_branch_comparison(typ,opname,tst,debug) \
 999     Instruct(opname): \
1000       if ( *pc++ tst (typ) Long_val(accu)) { \
1001         pc += *pc ; \
1002       } else { \
1003         pc++ ; \
1004       } ; Next;
1005
1006     Integer_branch_comparison(intnat,BEQ, ==, "==")
1007     Integer_branch_comparison(intnat,BNEQ, !=, "!=")
1008     Integer_branch_comparison(intnat,BLTINT, <, "<")
1009     Integer_branch_comparison(intnat,BLEINT, <=, "<=")
1010     Integer_branch_comparison(intnat,BGTINT, >, ">")
1011     Integer_branch_comparison(intnat,BGEINT, >=, ">=")
1012     Integer_branch_comparison(uintnat,BULTINT, <, "<")
1013     Integer_branch_comparison(uintnat,BUGEINT, >=, ">=")
1014
1015     Instruct(OFFSETINT):
1016       accu += *pc << 1;
1017       pc++;
1018       Next;
1019     Instruct(OFFSETREF):
1020       Field(accu, 0) += *pc << 1;
1021       accu = Val_unit;
1022       pc++;
1023       Next;
1024     Instruct(ISINT):
1025       accu = Val_long(accu & 1);
1026       Next;
1027
1028 /* Object-oriented operations */
1029
1030 #define Lookup(obj, lab) Field (Field (obj, 0), Int_val(lab))
1031
1032       /* please don't forget to keep below code in sync with the
1033          functions caml_cache_public_method and
1034          caml_cache_public_method2 in obj.c */
1035
1036     Instruct(GETMETHOD):
1037       accu = Lookup(sp[0], accu);
1038       Next;
1039
1040 #define CAML_METHOD_CACHE
1041 #ifdef CAML_METHOD_CACHE
1042     Instruct(GETPUBMET): {
1043       /* accu == object, pc[0] == tag, pc[1] == cache */
1044       value meths = Field (accu, 0);
1045       value ofs;
1046 #ifdef CAML_TEST_CACHE
1047       static int calls = 0, hits = 0;
1048       if (calls >= 10000000) {
1049         fprintf(stderr, "cache hit = %d%%\n", hits / 100000);
1050         calls = 0; hits = 0;
1051       }
1052       calls++;
1053 #endif
1054       *--sp = accu;
1055       accu = Val_int(*pc++);
1056       ofs = *pc & Field(meths,1);
1057       if (*(value*)(((char*)&Field(meths,3)) + ofs) == accu) {
1058 #ifdef CAML_TEST_CACHE
1059         hits++;
1060 #endif
1061         accu = *(value*)(((char*)&Field(meths,2)) + ofs);
1062       }
1063       else
1064       {
1065         int li = 3, hi = Field(meths,0), mi;
1066         while (li < hi) {
1067           mi = ((li+hi) >> 1) | 1;
1068           if (accu < Field(meths,mi)) hi = mi-2;
1069           else li = mi;
1070         }
1071         *pc = (li-3)*sizeof(value);
1072         accu = Field (meths, li-1);
1073       }
1074       pc++;
1075       Next;
1076     }
1077 #else
1078     Instruct(GETPUBMET):
1079       *--sp = accu;
1080       accu = Val_int(*pc);
1081       pc += 2;
1082       /* Fallthrough */
1083 #endif
1084     Instruct(GETDYNMET): {
1085       /* accu == tag, sp[0] == object, *pc == cache */
1086       value meths = Field (sp[0], 0);
1087       int li = 3, hi = Field(meths,0), mi;
1088       while (li < hi) {
1089         mi = ((li+hi) >> 1) | 1;
1090         if (accu < Field(meths,mi)) hi = mi-2;
1091         else li = mi;
1092       }
1093       accu = Field (meths, li-1);
1094       Next;
1095     }
1096
1097 /* Debugging and machine control */
1098
1099     Instruct(STOP):
1100       caml_external_raise = initial_external_raise;
1101       caml_extern_sp = sp;
1102       caml_callback_depth--;
1103       return accu;
1104
1105     Instruct(EVENT):
1106       if (--caml_event_count == 0) {
1107         Setup_for_debugger;
1108         caml_debugger(EVENT_COUNT);
1109         Restore_after_debugger;
1110       }
1111       Restart_curr_instr;
1112
1113     Instruct(BREAK):
1114       Setup_for_debugger;
1115       caml_debugger(BREAKPOINT);
1116       Restore_after_debugger;
1117       Restart_curr_instr;
1118
1119 #ifndef THREADED_CODE
1120     default:
1121 #if _MSC_VER >= 1200
1122       __assume(0);
1123 #else
1124       caml_fatal_error_arg("Fatal error: bad opcode (%"
1125                            ARCH_INTNAT_PRINTF_FORMAT "x)\n",
1126                            (char *)(*(pc-1)));
1127 #endif
1128     }
1129   }
1130 #endif
1131 }
1132
1133 void caml_prepare_bytecode(code_t prog, asize_t prog_size) {
1134   /* other implementations of the interpreter (such as an hypothetical
1135      JIT translator) might want to do something with a bytecode before
1136      running it */
1137   Assert(prog);
1138   Assert(prog_size>0);
1139   /* actually, the threading of the bytecode might be done here */
1140 }
1141
1142 void caml_release_bytecode(code_t prog, asize_t prog_size) {
1143   /* other implementations of the interpreter (such as an hypothetical
1144      JIT translator) might want to know when a bytecode is removed */
1145   /* check that we have a program */
1146   Assert(prog);
1147   Assert(prog_size>0);
1148 }