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