diff options
author | David Monniaux <david.monniaux@univ-grenoble-alpes.fr> | 2020-03-03 08:17:40 +0100 |
---|---|---|
committer | David Monniaux <david.monniaux@univ-grenoble-alpes.fr> | 2020-03-03 08:17:40 +0100 |
commit | 1ab7b51c30e1b10ac45b0bd64cefdc01da0f7f68 (patch) | |
tree | 210ffc156c83f04fb0c61a40b4f9037d7ba8a7e1 /test/monniaux/ocaml/byterun/interp.c | |
parent | 222c9047d61961db9c6b19fed5ca49829223fd33 (diff) | |
parent | 12be46d59a2483a10d77fa8ee67f7e0ca1bd702f (diff) | |
download | compcert-kvx-1ab7b51c30e1b10ac45b0bd64cefdc01da0f7f68.tar.gz compcert-kvx-1ab7b51c30e1b10ac45b0bd64cefdc01da0f7f68.zip |
Merge branch 'mppa-cse2' of gricad-gitlab.univ-grenoble-alpes.fr:sixcy/CompCert into mppa-work
Diffstat (limited to 'test/monniaux/ocaml/byterun/interp.c')
-rw-r--r-- | test/monniaux/ocaml/byterun/interp.c | 1172 |
1 files changed, 1172 insertions, 0 deletions
diff --git a/test/monniaux/ocaml/byterun/interp.c b/test/monniaux/ocaml/byterun/interp.c new file mode 100644 index 00000000..0b74df3d --- /dev/null +++ b/test/monniaux/ocaml/byterun/interp.c @@ -0,0 +1,1172 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS + +/* The bytecode interpreter */ +#include <stdio.h> +#include "caml/alloc.h" +#include "caml/backtrace.h" +#include "caml/callback.h" +#include "caml/debugger.h" +#include "caml/fail.h" +#include "caml/fix_code.h" +#include "caml/instrtrace.h" +#include "caml/instruct.h" +#include "caml/interp.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/prims.h" +#include "caml/signals.h" +#include "caml/stacks.h" +#include "caml/startup_aux.h" + +/* Registers for the abstract machine: + pc the code pointer + sp the stack pointer (grows downward) + accu the accumulator + env heap-allocated environment + caml_trapsp pointer to the current trap frame + extra_args number of extra arguments provided by the caller + +sp is a local copy of the global variable caml_extern_sp. */ + +/* Instruction decoding */ + +#ifdef THREADED_CODE +# define Instruct(name) lbl_##name +# if defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) +# define Jumptbl_base ((char *) &&lbl_ACC0) +# else +# define Jumptbl_base ((char *) 0) +# define jumptbl_base ((char *) 0) +# endif +# ifdef DEBUG +# define Next goto next_instr +# else +# define Next goto *(void *)(jumptbl_base + *pc++) +# endif +#else +# define Instruct(name) case name +# define Next break +#endif + +/* GC interface */ + +#define Setup_for_gc \ + { sp -= 2; sp[0] = accu; sp[1] = env; caml_extern_sp = sp; } +#define Restore_after_gc \ + { accu = sp[0]; env = sp[1]; sp += 2; } +#define Setup_for_c_call \ + { saved_pc = pc; *--sp = env; caml_extern_sp = sp; } +#define Restore_after_c_call \ + { sp = caml_extern_sp; env = *sp++; saved_pc = NULL; } + +/* An event frame must look like accu + a C_CALL frame + a RETURN 1 frame */ +#define Setup_for_event \ + { sp -= 6; \ + sp[0] = accu; /* accu */ \ + sp[1] = Val_unit; /* C_CALL frame: dummy environment */ \ + sp[2] = Val_unit; /* RETURN frame: dummy local 0 */ \ + sp[3] = (value) pc; /* RETURN frame: saved return address */ \ + sp[4] = env; /* RETURN frame: saved environment */ \ + sp[5] = Val_long(extra_args); /* RETURN frame: saved extra args */ \ + caml_extern_sp = sp; } +#define Restore_after_event \ + { sp = caml_extern_sp; accu = sp[0]; \ + pc = (code_t) sp[3]; env = sp[4]; extra_args = Long_val(sp[5]); \ + sp += 6; } + +/* Debugger interface */ + +#define Setup_for_debugger \ + { sp -= 4; \ + sp[0] = accu; sp[1] = (value)(pc - 1); \ + sp[2] = env; sp[3] = Val_long(extra_args); \ + caml_extern_sp = sp; } +#define Restore_after_debugger { sp += 4; } + +#ifdef THREADED_CODE +#define Restart_curr_instr \ + goto *(jumptable[caml_saved_code[pc - 1 - caml_start_code]]) +#else +#define Restart_curr_instr \ + curr_instr = caml_saved_code[pc - 1 - caml_start_code]; \ + goto dispatch_instr +#endif + +/* Register optimization. + Some compilers underestimate the use of the local variables representing + the abstract machine registers, and don't put them in hardware registers, + which slows down the interpreter considerably. + For GCC, I have hand-assigned hardware registers for several architectures. +*/ + +#if defined(__GNUC__) && !defined(DEBUG) && !defined(__INTEL_COMPILER) \ + && !defined(__llvm__) +#ifdef __mips__ +#define PC_REG asm("$16") +#define SP_REG asm("$17") +#define ACCU_REG asm("$18") +#endif +#ifdef __sparc__ +#define PC_REG asm("%l0") +#define SP_REG asm("%l1") +#define ACCU_REG asm("%l2") +#endif +#ifdef __alpha__ +#ifdef __CRAY__ +#define PC_REG asm("r9") +#define SP_REG asm("r10") +#define ACCU_REG asm("r11") +#define JUMPTBL_BASE_REG asm("r12") +#else +#define PC_REG asm("$9") +#define SP_REG asm("$10") +#define ACCU_REG asm("$11") +#define JUMPTBL_BASE_REG asm("$12") +#endif +#endif +#ifdef __i386__ +#define PC_REG asm("%esi") +#define SP_REG asm("%edi") +#define ACCU_REG +#endif +#if defined(__ppc__) || defined(__ppc64__) +#define PC_REG asm("26") +#define SP_REG asm("27") +#define ACCU_REG asm("28") +#endif +#ifdef __hppa__ +#define PC_REG asm("%r18") +#define SP_REG asm("%r17") +#define ACCU_REG asm("%r16") +#endif +#ifdef __mc68000__ +#define PC_REG asm("a5") +#define SP_REG asm("a4") +#define ACCU_REG asm("d7") +#endif +/* PR#4953: these specific registers not available in Thumb mode */ +#if defined (__arm__) && !defined(__thumb__) +#define PC_REG asm("r6") +#define SP_REG asm("r8") +#define ACCU_REG asm("r7") +#endif +#ifdef __ia64__ +#define PC_REG asm("36") +#define SP_REG asm("37") +#define ACCU_REG asm("38") +#define JUMPTBL_BASE_REG asm("39") +#endif +#ifdef __x86_64__ +#define PC_REG asm("%r15") +#define SP_REG asm("%r14") +#define ACCU_REG asm("%r13") +#endif +#ifdef __aarch64__ +#define PC_REG asm("%x19") +#define SP_REG asm("%x20") +#define ACCU_REG asm("%x21") +#define JUMPTBL_BASE_REG asm("%x22") +#endif +#endif + +#ifdef DEBUG +static intnat caml_bcodcount; +#endif + +/* The interpreter itself */ + +value caml_interprete(code_t prog, asize_t prog_size) +{ +#ifdef PC_REG + register code_t pc PC_REG; + register value * sp SP_REG; + register value accu ACCU_REG; +#else + register code_t pc; + register value * sp; + register value accu; +#endif +#if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) +#ifdef JUMPTBL_BASE_REG + register char * jumptbl_base JUMPTBL_BASE_REG; +#else + register char * jumptbl_base; +#endif +#endif + value env; + intnat extra_args; + struct longjmp_buffer * initial_external_raise; + int initial_sp_offset; + /* volatile ensures that initial_local_roots and saved_pc + will keep correct value across longjmp */ + struct caml__roots_block * volatile initial_local_roots; + volatile code_t saved_pc = NULL; + struct longjmp_buffer raise_buf; +#ifndef THREADED_CODE + opcode_t curr_instr; +#endif + +#ifdef THREADED_CODE + static void * jumptable[] = { +# include "caml/jumptbl.h" + }; +#endif + + if (prog == NULL) { /* Interpreter is initializing */ +#ifdef THREADED_CODE + caml_instr_table = (char **) jumptable; + caml_instr_base = Jumptbl_base; +#endif + return Val_unit; + } + +#if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) + jumptbl_base = Jumptbl_base; +#endif + initial_local_roots = caml_local_roots; + initial_sp_offset = (char *) caml_stack_high - (char *) caml_extern_sp; + initial_external_raise = caml_external_raise; + caml_callback_depth++; + saved_pc = NULL; + + if (sigsetjmp(raise_buf.buf, 0)) { + caml_local_roots = initial_local_roots; + sp = caml_extern_sp; + accu = caml_exn_bucket; + pc = saved_pc; saved_pc = NULL; + if (pc != NULL) pc += 2; + /* +2 adjustement for the sole purpose of backtraces */ + goto raise_exception; + } + caml_external_raise = &raise_buf; + + sp = caml_extern_sp; + pc = prog; + extra_args = 0; + env = Atom(0); + accu = Val_int(0); + +#ifdef THREADED_CODE +#ifdef DEBUG + next_instr: + if (caml_icount-- == 0) caml_stop_here (); + CAMLassert(sp >= caml_stack_low); + CAMLassert(sp <= caml_stack_high); +#endif + goto *(void *)(jumptbl_base + *pc++); /* Jump to the first instruction */ +#else + while(1) { +#ifdef DEBUG + caml_bcodcount++; + if (caml_icount-- == 0) caml_stop_here (); + if (caml_trace_level>1) printf("\n##%" ARCH_INTNAT_PRINTF_FORMAT "d\n", + caml_bcodcount); + if (caml_trace_level>0) caml_disasm_instr(pc); + if (caml_trace_level>1) { + printf("env="); + caml_trace_value_file(env,prog,prog_size,stdout); + putchar('\n'); + caml_trace_accu_sp_file(accu,sp,prog,prog_size,stdout); + fflush(stdout); + }; + CAMLassert(sp >= caml_stack_low); + CAMLassert(sp <= caml_stack_high); +#endif + curr_instr = *pc++; + + dispatch_instr: + switch(curr_instr) { +#endif + +/* Basic stack operations */ + + Instruct(ACC0): + accu = sp[0]; Next; + Instruct(ACC1): + accu = sp[1]; Next; + Instruct(ACC2): + accu = sp[2]; Next; + Instruct(ACC3): + accu = sp[3]; Next; + Instruct(ACC4): + accu = sp[4]; Next; + Instruct(ACC5): + accu = sp[5]; Next; + Instruct(ACC6): + accu = sp[6]; Next; + Instruct(ACC7): + accu = sp[7]; Next; + + Instruct(PUSH): Instruct(PUSHACC0): + *--sp = accu; Next; + Instruct(PUSHACC1): + *--sp = accu; accu = sp[1]; Next; + Instruct(PUSHACC2): + *--sp = accu; accu = sp[2]; Next; + Instruct(PUSHACC3): + *--sp = accu; accu = sp[3]; Next; + Instruct(PUSHACC4): + *--sp = accu; accu = sp[4]; Next; + Instruct(PUSHACC5): + *--sp = accu; accu = sp[5]; Next; + Instruct(PUSHACC6): + *--sp = accu; accu = sp[6]; Next; + Instruct(PUSHACC7): + *--sp = accu; accu = sp[7]; Next; + + Instruct(PUSHACC): + *--sp = accu; + /* Fallthrough */ + Instruct(ACC): + accu = sp[*pc++]; + Next; + + Instruct(POP): + sp += *pc++; + Next; + Instruct(ASSIGN): + sp[*pc++] = accu; + accu = Val_unit; + Next; + +/* Access in heap-allocated environment */ + + Instruct(ENVACC1): + accu = Field(env, 1); Next; + Instruct(ENVACC2): + accu = Field(env, 2); Next; + Instruct(ENVACC3): + accu = Field(env, 3); Next; + Instruct(ENVACC4): + accu = Field(env, 4); Next; + + Instruct(PUSHENVACC1): + *--sp = accu; accu = Field(env, 1); Next; + Instruct(PUSHENVACC2): + *--sp = accu; accu = Field(env, 2); Next; + Instruct(PUSHENVACC3): + *--sp = accu; accu = Field(env, 3); Next; + Instruct(PUSHENVACC4): + *--sp = accu; accu = Field(env, 4); Next; + + Instruct(PUSHENVACC): + *--sp = accu; + /* Fallthrough */ + Instruct(ENVACC): + accu = Field(env, *pc++); + Next; + +/* Function application */ + + Instruct(PUSH_RETADDR): { + sp -= 3; + sp[0] = (value) (pc + *pc); + sp[1] = env; + sp[2] = Val_long(extra_args); + pc++; + Next; + } + Instruct(APPLY): { + extra_args = *pc - 1; + pc = Code_val(accu); + env = accu; + goto check_stacks; + } + Instruct(APPLY1): { + value arg1 = sp[0]; + sp -= 3; + sp[0] = arg1; + sp[1] = (value)pc; + sp[2] = env; + sp[3] = Val_long(extra_args); + pc = Code_val(accu); + env = accu; + extra_args = 0; + goto check_stacks; + } + Instruct(APPLY2): { + value arg1 = sp[0]; + value arg2 = sp[1]; + sp -= 3; + sp[0] = arg1; + sp[1] = arg2; + sp[2] = (value)pc; + sp[3] = env; + sp[4] = Val_long(extra_args); + pc = Code_val(accu); + env = accu; + extra_args = 1; + goto check_stacks; + } + Instruct(APPLY3): { + value arg1 = sp[0]; + value arg2 = sp[1]; + value arg3 = sp[2]; + sp -= 3; + sp[0] = arg1; + sp[1] = arg2; + sp[2] = arg3; + sp[3] = (value)pc; + sp[4] = env; + sp[5] = Val_long(extra_args); + pc = Code_val(accu); + env = accu; + extra_args = 2; + goto check_stacks; + } + + Instruct(APPTERM): { + int nargs = *pc++; + int slotsize = *pc; + value * newsp; + int i; + /* Slide the nargs bottom words of the current frame to the top + of the frame, and discard the remainder of the frame */ + newsp = sp + slotsize - nargs; + for (i = nargs - 1; i >= 0; i--) newsp[i] = sp[i]; + sp = newsp; + pc = Code_val(accu); + env = accu; + extra_args += nargs - 1; + goto check_stacks; + } + Instruct(APPTERM1): { + value arg1 = sp[0]; + sp = sp + *pc - 1; + sp[0] = arg1; + pc = Code_val(accu); + env = accu; + goto check_stacks; + } + Instruct(APPTERM2): { + value arg1 = sp[0]; + value arg2 = sp[1]; + sp = sp + *pc - 2; + sp[0] = arg1; + sp[1] = arg2; + pc = Code_val(accu); + env = accu; + extra_args += 1; + goto check_stacks; + } + Instruct(APPTERM3): { + value arg1 = sp[0]; + value arg2 = sp[1]; + value arg3 = sp[2]; + sp = sp + *pc - 3; + sp[0] = arg1; + sp[1] = arg2; + sp[2] = arg3; + pc = Code_val(accu); + env = accu; + extra_args += 2; + goto check_stacks; + } + + Instruct(RETURN): { + sp += *pc++; + if (extra_args > 0) { + extra_args--; + pc = Code_val(accu); + env = accu; + } else { + pc = (code_t)(sp[0]); + env = sp[1]; + extra_args = Long_val(sp[2]); + sp += 3; + } + Next; + } + + Instruct(RESTART): { + int num_args = Wosize_val(env) - 2; + int i; + sp -= num_args; + for (i = 0; i < num_args; i++) sp[i] = Field(env, i + 2); + env = Field(env, 1); + extra_args += num_args; + Next; + } + + Instruct(GRAB): { + int required = *pc++; + if (extra_args >= required) { + extra_args -= required; + } else { + mlsize_t num_args, i; + num_args = 1 + extra_args; /* arg1 + extra args */ + Alloc_small(accu, num_args + 2, Closure_tag); + Field(accu, 1) = env; + for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i]; + Code_val(accu) = pc - 3; /* Point to the preceding RESTART instr. */ + sp += num_args; + pc = (code_t)(sp[0]); + env = sp[1]; + extra_args = Long_val(sp[2]); + sp += 3; + } + Next; + } + + Instruct(CLOSURE): { + int nvars = *pc++; + int i; + if (nvars > 0) *--sp = accu; + if (nvars < Max_young_wosize) { + /* nvars + 1 <= Max_young_wosize, can allocate in minor heap */ + Alloc_small(accu, 1 + nvars, Closure_tag); + for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i]; + } else { + /* PR#6385: must allocate in major heap */ + /* caml_alloc_shr and caml_initialize never trigger a GC, + so no need to Setup_for_gc */ + accu = caml_alloc_shr(1 + nvars, Closure_tag); + for (i = 0; i < nvars; i++) caml_initialize(&Field(accu, i + 1), sp[i]); + } + /* The code pointer is not in the heap, so no need to go through + caml_initialize. */ + Code_val(accu) = pc + *pc; + pc++; + sp += nvars; + Next; + } + + Instruct(CLOSUREREC): { + int nfuncs = *pc++; + int nvars = *pc++; + mlsize_t blksize = nfuncs * 2 - 1 + nvars; + int i; + value * p; + if (nvars > 0) *--sp = accu; + if (blksize <= Max_young_wosize) { + Alloc_small(accu, blksize, Closure_tag); + p = &Field(accu, nfuncs * 2 - 1); + for (i = 0; i < nvars; i++, p++) *p = sp[i]; + } else { + /* PR#6385: must allocate in major heap */ + /* caml_alloc_shr and caml_initialize never trigger a GC, + so no need to Setup_for_gc */ + accu = caml_alloc_shr(blksize, Closure_tag); + p = &Field(accu, nfuncs * 2 - 1); + for (i = 0; i < nvars; i++, p++) caml_initialize(p, sp[i]); + } + sp += nvars; + /* The code pointers and infix headers are not in the heap, + so no need to go through caml_initialize. */ + p = &Field(accu, 0); + *p = (value) (pc + pc[0]); + *--sp = accu; + p++; + for (i = 1; i < nfuncs; i++) { + *p = Make_header(i * 2, Infix_tag, Caml_white); /* color irrelevant. */ + p++; + *p = (value) (pc + pc[i]); + *--sp = (value) p; + p++; + } + pc += nfuncs; + Next; + } + + Instruct(PUSHOFFSETCLOSURE): + *--sp = accu; /* fallthrough */ + Instruct(OFFSETCLOSURE): + accu = env + *pc++ * sizeof(value); Next; + + Instruct(PUSHOFFSETCLOSUREM2): + *--sp = accu; /* fallthrough */ + Instruct(OFFSETCLOSUREM2): + accu = env - 2 * sizeof(value); Next; + Instruct(PUSHOFFSETCLOSURE0): + *--sp = accu; /* fallthrough */ + Instruct(OFFSETCLOSURE0): + accu = env; Next; + Instruct(PUSHOFFSETCLOSURE2): + *--sp = accu; /* fallthrough */ + Instruct(OFFSETCLOSURE2): + accu = env + 2 * sizeof(value); Next; + + +/* Access to global variables */ + + Instruct(PUSHGETGLOBAL): + *--sp = accu; + /* Fallthrough */ + Instruct(GETGLOBAL): + accu = Field(caml_global_data, *pc); + pc++; + Next; + + Instruct(PUSHGETGLOBALFIELD): + *--sp = accu; + /* Fallthrough */ + Instruct(GETGLOBALFIELD): { + accu = Field(caml_global_data, *pc); + pc++; + accu = Field(accu, *pc); + pc++; + Next; + } + + Instruct(SETGLOBAL): + caml_modify(&Field(caml_global_data, *pc), accu); + accu = Val_unit; + pc++; + Next; + +/* Allocation of blocks */ + + Instruct(PUSHATOM0): + *--sp = accu; + /* Fallthrough */ + Instruct(ATOM0): + accu = Atom(0); Next; + + Instruct(PUSHATOM): + *--sp = accu; + /* Fallthrough */ + Instruct(ATOM): + accu = Atom(*pc++); Next; + + Instruct(MAKEBLOCK): { + mlsize_t wosize = *pc++; + tag_t tag = *pc++; + mlsize_t i; + value block; + if (wosize <= Max_young_wosize) { + Alloc_small(block, wosize, tag); + Field(block, 0) = accu; + for (i = 1; i < wosize; i++) Field(block, i) = *sp++; + } else { + block = caml_alloc_shr(wosize, tag); + caml_initialize(&Field(block, 0), accu); + for (i = 1; i < wosize; i++) caml_initialize(&Field(block, i), *sp++); + } + accu = block; + Next; + } + Instruct(MAKEBLOCK1): { + tag_t tag = *pc++; + value block; + Alloc_small(block, 1, tag); + Field(block, 0) = accu; + accu = block; + Next; + } + Instruct(MAKEBLOCK2): { + tag_t tag = *pc++; + value block; + Alloc_small(block, 2, tag); + Field(block, 0) = accu; + Field(block, 1) = sp[0]; + sp += 1; + accu = block; + Next; + } + Instruct(MAKEBLOCK3): { + tag_t tag = *pc++; + value block; + Alloc_small(block, 3, tag); + Field(block, 0) = accu; + Field(block, 1) = sp[0]; + Field(block, 2) = sp[1]; + sp += 2; + accu = block; + Next; + } + Instruct(MAKEFLOATBLOCK): { + mlsize_t size = *pc++; + mlsize_t i; + value block; + if (size <= Max_young_wosize / Double_wosize) { + Alloc_small(block, size * Double_wosize, Double_array_tag); + } else { + block = caml_alloc_shr(size * Double_wosize, Double_array_tag); + } + Store_double_flat_field(block, 0, Double_val(accu)); + for (i = 1; i < size; i++){ + Store_double_flat_field(block, i, Double_val(*sp)); + ++ sp; + } + accu = block; + Next; + } + +/* Access to components of blocks */ + + Instruct(GETFIELD0): + accu = Field(accu, 0); Next; + Instruct(GETFIELD1): + accu = Field(accu, 1); Next; + Instruct(GETFIELD2): + accu = Field(accu, 2); Next; + Instruct(GETFIELD3): + accu = Field(accu, 3); Next; + Instruct(GETFIELD): + accu = Field(accu, *pc); pc++; Next; + Instruct(GETFLOATFIELD): { + double d = Double_flat_field(accu, *pc); + Alloc_small(accu, Double_wosize, Double_tag); + Store_double_val(accu, d); + pc++; + Next; + } + + Instruct(SETFIELD0): + caml_modify(&Field(accu, 0), *sp++); + accu = Val_unit; + Next; + Instruct(SETFIELD1): + caml_modify(&Field(accu, 1), *sp++); + accu = Val_unit; + Next; + Instruct(SETFIELD2): + caml_modify(&Field(accu, 2), *sp++); + accu = Val_unit; + Next; + Instruct(SETFIELD3): + caml_modify(&Field(accu, 3), *sp++); + accu = Val_unit; + Next; + Instruct(SETFIELD): + caml_modify(&Field(accu, *pc), *sp++); + accu = Val_unit; + pc++; + Next; + Instruct(SETFLOATFIELD): + Store_double_flat_field(accu, *pc, Double_val(*sp)); + accu = Val_unit; + sp++; + pc++; + Next; + +/* Array operations */ + + Instruct(VECTLENGTH): { + /* Todo: when FLAT_FLOAT_ARRAY is false, this instruction should + be split into VECTLENGTH and FLOATVECTLENGTH because we know + statically which one it is. */ + mlsize_t size = Wosize_val(accu); + if (Tag_val(accu) == Double_array_tag) size = size / Double_wosize; + accu = Val_long(size); + Next; + } + Instruct(GETVECTITEM): + accu = Field(accu, Long_val(sp[0])); + sp += 1; + Next; + Instruct(SETVECTITEM): + caml_modify(&Field(accu, Long_val(sp[0])), sp[1]); + accu = Val_unit; + sp += 2; + Next; + +/* Bytes/String operations */ + Instruct(GETSTRINGCHAR): + Instruct(GETBYTESCHAR): + accu = Val_int(Byte_u(accu, Long_val(sp[0]))); + sp += 1; + Next; + Instruct(SETBYTESCHAR): + Byte_u(accu, Long_val(sp[0])) = Int_val(sp[1]); + sp += 2; + accu = Val_unit; + Next; + +/* Branches and conditional branches */ + + Instruct(BRANCH): + pc += *pc; + Next; + Instruct(BRANCHIF): + if (accu != Val_false) pc += *pc; else pc++; + Next; + Instruct(BRANCHIFNOT): + if (accu == Val_false) pc += *pc; else pc++; + Next; + Instruct(SWITCH): { + uint32_t sizes = *pc++; + if (Is_block(accu)) { + intnat index = Tag_val(accu); + CAMLassert ((uintnat) index < (sizes >> 16)); + pc += pc[(sizes & 0xFFFF) + index]; + } else { + intnat index = Long_val(accu); + CAMLassert ((uintnat) index < (sizes & 0xFFFF)) ; + pc += pc[index]; + } + Next; + } + Instruct(BOOLNOT): + accu = Val_not(accu); + Next; + +/* Exceptions */ + + Instruct(PUSHTRAP): + sp -= 4; + Trap_pc(sp) = pc + *pc; + Trap_link(sp) = caml_trapsp; + sp[2] = env; + sp[3] = Val_long(extra_args); + caml_trapsp = sp; + pc++; + Next; + + Instruct(POPTRAP): + if (caml_something_to_do) { + /* We must check here so that if a signal is pending and its + handler triggers an exception, the exception is trapped + by the current try...with, not the enclosing one. */ + pc--; /* restart the POPTRAP after processing the signal */ + goto process_signal; + } + caml_trapsp = Trap_link(sp); + sp += 4; + Next; + + Instruct(RAISE_NOTRACE): + if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER); + goto raise_notrace; + + Instruct(RERAISE): + if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER); + if (caml_backtrace_active) caml_stash_backtrace(accu, pc, sp, 1); + goto raise_notrace; + + Instruct(RAISE): + raise_exception: + if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER); + if (caml_backtrace_active) caml_stash_backtrace(accu, pc, sp, 0); + raise_notrace: + if ((char *) caml_trapsp + >= (char *) caml_stack_high - initial_sp_offset) { + caml_external_raise = initial_external_raise; + caml_extern_sp = (value *) ((char *) caml_stack_high + - initial_sp_offset); + caml_callback_depth--; + return Make_exception_result(accu); + } + sp = caml_trapsp; + pc = Trap_pc(sp); + caml_trapsp = Trap_link(sp); + env = sp[2]; + extra_args = Long_val(sp[3]); + sp += 4; + Next; + +/* Stack checks */ + + check_stacks: + if (sp < caml_stack_threshold) { + caml_extern_sp = sp; + caml_realloc_stack(Stack_threshold / sizeof(value)); + sp = caml_extern_sp; + } + /* Fall through CHECK_SIGNALS */ + +/* Signal handling */ + + Instruct(CHECK_SIGNALS): /* accu not preserved */ + if (caml_something_to_do) goto process_signal; + Next; + + process_signal: + caml_something_to_do = 0; + Setup_for_event; + caml_process_event(); + Restore_after_event; + Next; + +/* Calling C functions */ + + Instruct(C_CALL1): + Setup_for_c_call; + accu = Primitive(*pc)(accu); + Restore_after_c_call; + pc++; + Next; + Instruct(C_CALL2): + Setup_for_c_call; + accu = Primitive(*pc)(accu, sp[1]); + Restore_after_c_call; + sp += 1; + pc++; + Next; + Instruct(C_CALL3): + Setup_for_c_call; + accu = Primitive(*pc)(accu, sp[1], sp[2]); + Restore_after_c_call; + sp += 2; + pc++; + Next; + Instruct(C_CALL4): + Setup_for_c_call; + accu = Primitive(*pc)(accu, sp[1], sp[2], sp[3]); + Restore_after_c_call; + sp += 3; + pc++; + Next; + Instruct(C_CALL5): + Setup_for_c_call; + accu = Primitive(*pc)(accu, sp[1], sp[2], sp[3], sp[4]); + Restore_after_c_call; + sp += 4; + pc++; + Next; + Instruct(C_CALLN): { + int nargs = *pc++; + *--sp = accu; + Setup_for_c_call; + accu = Primitive(*pc)(sp + 1, nargs); + Restore_after_c_call; + sp += nargs; + pc++; + Next; + } + +/* Integer constants */ + + Instruct(CONST0): + accu = Val_int(0); Next; + Instruct(CONST1): + accu = Val_int(1); Next; + Instruct(CONST2): + accu = Val_int(2); Next; + Instruct(CONST3): + accu = Val_int(3); Next; + + Instruct(PUSHCONST0): + *--sp = accu; accu = Val_int(0); Next; + Instruct(PUSHCONST1): + *--sp = accu; accu = Val_int(1); Next; + Instruct(PUSHCONST2): + *--sp = accu; accu = Val_int(2); Next; + Instruct(PUSHCONST3): + *--sp = accu; accu = Val_int(3); Next; + + Instruct(PUSHCONSTINT): + *--sp = accu; + /* Fallthrough */ + Instruct(CONSTINT): + accu = Val_int(*pc); + pc++; + Next; + +/* Integer arithmetic */ + + Instruct(NEGINT): + accu = (value)(2 - (intnat)accu); Next; + Instruct(ADDINT): + accu = (value)((intnat) accu + (intnat) *sp++ - 1); Next; + Instruct(SUBINT): + accu = (value)((intnat) accu - (intnat) *sp++ + 1); Next; + Instruct(MULINT): + accu = Val_long(Long_val(accu) * Long_val(*sp++)); Next; + + Instruct(DIVINT): { + intnat divisor = Long_val(*sp++); + if (divisor == 0) { Setup_for_c_call; caml_raise_zero_divide(); } + accu = Val_long(Long_val(accu) / divisor); + Next; + } + Instruct(MODINT): { + intnat divisor = Long_val(*sp++); + if (divisor == 0) { Setup_for_c_call; caml_raise_zero_divide(); } + accu = Val_long(Long_val(accu) % divisor); + Next; + } + Instruct(ANDINT): + accu = (value)((intnat) accu & (intnat) *sp++); Next; + Instruct(ORINT): + accu = (value)((intnat) accu | (intnat) *sp++); Next; + Instruct(XORINT): + accu = (value)(((intnat) accu ^ (intnat) *sp++) | 1); Next; + Instruct(LSLINT): + accu = (value)((((intnat) accu - 1) << Long_val(*sp++)) + 1); Next; + Instruct(LSRINT): + accu = (value)((((uintnat) accu) >> Long_val(*sp++)) | 1); Next; + Instruct(ASRINT): + accu = (value)((((intnat) accu) >> Long_val(*sp++)) | 1); Next; + +#define Integer_comparison(typ,opname,tst) \ + Instruct(opname): \ + accu = Val_int((typ) accu tst (typ) *sp++); Next; + + Integer_comparison(intnat,EQ, ==) + Integer_comparison(intnat,NEQ, !=) + Integer_comparison(intnat,LTINT, <) + Integer_comparison(intnat,LEINT, <=) + Integer_comparison(intnat,GTINT, >) + Integer_comparison(intnat,GEINT, >=) + Integer_comparison(uintnat,ULTINT, <) + Integer_comparison(uintnat,UGEINT, >=) + +#define Integer_branch_comparison(typ,opname,tst,debug) \ + Instruct(opname): \ + if ( *pc++ tst (typ) Long_val(accu)) { \ + pc += *pc ; \ + } else { \ + pc++ ; \ + } ; Next; + + Integer_branch_comparison(intnat,BEQ, ==, "==") + Integer_branch_comparison(intnat,BNEQ, !=, "!=") + Integer_branch_comparison(intnat,BLTINT, <, "<") + Integer_branch_comparison(intnat,BLEINT, <=, "<=") + Integer_branch_comparison(intnat,BGTINT, >, ">") + Integer_branch_comparison(intnat,BGEINT, >=, ">=") + Integer_branch_comparison(uintnat,BULTINT, <, "<") + Integer_branch_comparison(uintnat,BUGEINT, >=, ">=") + + Instruct(OFFSETINT): + accu += *pc << 1; + pc++; + Next; + Instruct(OFFSETREF): + Field(accu, 0) += *pc << 1; + accu = Val_unit; + pc++; + Next; + Instruct(ISINT): + accu = Val_long(accu & 1); + Next; + +/* Object-oriented operations */ + +#define Lookup(obj, lab) Field (Field (obj, 0), Int_val(lab)) + + /* please don't forget to keep below code in sync with the + functions caml_cache_public_method and + caml_cache_public_method2 in obj.c */ + + Instruct(GETMETHOD): + accu = Lookup(sp[0], accu); + Next; + +#define CAML_METHOD_CACHE +#ifdef CAML_METHOD_CACHE + Instruct(GETPUBMET): { + /* accu == object, pc[0] == tag, pc[1] == cache */ + value meths = Field (accu, 0); + value ofs; +#ifdef CAML_TEST_CACHE + static int calls = 0, hits = 0; + if (calls >= 10000000) { + fprintf(stderr, "cache hit = %d%%\n", hits / 100000); + calls = 0; hits = 0; + } + calls++; +#endif + *--sp = accu; + accu = Val_int(*pc++); + ofs = *pc & Field(meths,1); + if (*(value*)(((char*)&Field(meths,3)) + ofs) == accu) { +#ifdef CAML_TEST_CACHE + hits++; +#endif + accu = *(value*)(((char*)&Field(meths,2)) + ofs); + } + else + { + int li = 3, hi = Field(meths,0), mi; + while (li < hi) { + mi = ((li+hi) >> 1) | 1; + if (accu < Field(meths,mi)) hi = mi-2; + else li = mi; + } + *pc = (li-3)*sizeof(value); + accu = Field (meths, li-1); + } + pc++; + Next; + } +#else + Instruct(GETPUBMET): + *--sp = accu; + accu = Val_int(*pc); + pc += 2; + /* Fallthrough */ +#endif + Instruct(GETDYNMET): { + /* accu == tag, sp[0] == object, *pc == cache */ + value meths = Field (sp[0], 0); + int li = 3, hi = Field(meths,0), mi; + while (li < hi) { + mi = ((li+hi) >> 1) | 1; + if (accu < Field(meths,mi)) hi = mi-2; + else li = mi; + } + accu = Field (meths, li-1); + Next; + } + +/* Debugging and machine control */ + + Instruct(STOP): + caml_external_raise = initial_external_raise; + caml_extern_sp = sp; + caml_callback_depth--; + return accu; + + Instruct(EVENT): + if (--caml_event_count == 0) { + Setup_for_debugger; + caml_debugger(EVENT_COUNT); + Restore_after_debugger; + } + Restart_curr_instr; + + Instruct(BREAK): + Setup_for_debugger; + caml_debugger(BREAKPOINT); + Restore_after_debugger; + Restart_curr_instr; + +#ifndef THREADED_CODE + default: +#if _MSC_VER >= 1200 + __assume(0); +#else + caml_fatal_error_arg("Fatal error: bad opcode (%" + ARCH_INTNAT_PRINTF_FORMAT "x)\n", + (char *) (intnat) *(pc-1)); +#endif + } + } +#endif +} + +void caml_prepare_bytecode(code_t prog, asize_t prog_size) { + /* other implementations of the interpreter (such as an hypothetical + JIT translator) might want to do something with a bytecode before + running it */ + CAMLassert(prog); + CAMLassert(prog_size>0); + /* actually, the threading of the bytecode might be done here */ +} + +void caml_release_bytecode(code_t prog, asize_t prog_size) { + /* other implementations of the interpreter (such as an hypothetical + JIT translator) might want to know when a bytecode is removed */ + /* check that we have a program */ + CAMLassert(prog); + CAMLassert(prog_size>0); +} |