Merge pull request #9680 from xavierleroy/bytecode-nnp

Adapt the bytecode interpreter to no-naked-pointers mode.

runtime/backtrace_byt.c

@@ -304,7 +304,7 @@ code_t caml_next_frame_pointer(value ** sp, value ** trsp)
     if (Is_long(*spv)) continue;
     p = (code_t*) spv;
     if(&Trap_pc(*trsp) == p) {
-      *trsp = Trap_link(*trsp);
+      *trsp = *trsp + Long_val(Trap_link_offset(*trsp));
       continue;
     }
 

runtime/callback.c

@@ -28,6 +28,7 @@
 
 /* Bytecode callbacks */
 
+#include "caml/codefrag.h"
 #include "caml/interp.h"
 #include "caml/instruct.h"
 #include "caml/fix_code.h"
@@ -37,25 +38,20 @@ CAMLexport int caml_callback_depth = 0;
 
 #ifndef LOCAL_CALLBACK_BYTECODE
 static opcode_t callback_code[] = { ACC, 0, APPLY, 0, POP, 1, STOP };
-#endif
-
 
-#ifdef THREADED_CODE
+static int callback_code_inited = 0;
 
-static int callback_code_threaded = 0;
-
-static void thread_callback(void)
+static void init_callback_code(void)
 {
+  caml_register_code_fragment((char *) callback_code,
+                              (char *) callback_code + sizeof(callback_code),
+                              DIGEST_IGNORE, NULL);
+#ifdef THREADED_CODE
   caml_thread_code(callback_code, sizeof(callback_code));
-  callback_code_threaded = 1;
+#endif
+  callback_code_inited = 1;
 }
 
-#define Init_callback() if (!callback_code_threaded) thread_callback()
-
-#else
-
-#define Init_callback()
-
 #endif
 
 CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
@@ -79,7 +75,7 @@ CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
   Caml_state->extern_sp[narg + 1] = Val_unit;    /* environment */
   Caml_state->extern_sp[narg + 2] = Val_long(0); /* extra args */
   Caml_state->extern_sp[narg + 3] = closure;
-  Init_callback();
+  if (!callback_code_inited) init_callback_code();
   callback_code[1] = narg + 3;
   callback_code[3] = narg;
   res = caml_interprete(callback_code, sizeof(callback_code));
@@ -96,6 +92,8 @@ CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
   local_callback_code[4] = POP;
   local_callback_code[5] =  1;
   local_callback_code[6] = STOP;
+  /* Not registering the code fragment, as code fragment management
+     would need to be revised thoroughly for an hypothetical JIT */
 #ifdef THREADED_CODE
   caml_thread_code(local_callback_code, sizeof(local_callback_code));
 #endif /*THREADED_CODE*/

runtime/caml/stacks.h

@@ -33,7 +33,7 @@
 #define caml_trap_barrier (Caml_state_field(trap_barrier))
 
 #define Trap_pc(tp) (((code_t *)(tp))[0])
-#define Trap_link(tp) (((value **)(tp))[1])
+#define Trap_link_offset(tp) (((value *)(tp))[1])
 
 void caml_init_stack (uintnat init_max_size);
 void caml_realloc_stack (asize_t required_size);

runtime/interp.c

@@ -538,7 +538,6 @@ value caml_interprete(code_t prog, asize_t prog_size)
         Alloc_small(accu, num_args + 3, Closure_tag);
         Field(accu, 2) = env;
         for (i = 0; i < num_args; i++) Field(accu, i + 3) = sp[i];
-        CAMLassert(!Is_in_value_area(pc-3));
         Code_val(accu) = pc - 3; /* Point to the preceding RESTART instr. */
         Closinfo_val(accu) = Make_closinfo(0, 2);
         sp += num_args;
@@ -567,7 +566,6 @@ value caml_interprete(code_t prog, asize_t prog_size)
       }
       /* The code pointer is not in the heap, so no need to go through
          caml_initialize. */
-      CAMLassert(!Is_in_value_area(pc + *pc));
       Code_val(accu) = pc + *pc;
       Closinfo_val(accu) = Make_closinfo(0, 2);
       pc++;
@@ -850,7 +848,7 @@ value caml_interprete(code_t prog, asize_t prog_size)
     Instruct(PUSHTRAP):
       sp -= 4;
       Trap_pc(sp) = pc + *pc;
-      Trap_link(sp) = Caml_state->trapsp;
+      Trap_link_offset(sp) = Val_long(Caml_state->trapsp - sp);
       sp[2] = env;
       sp[3] = Val_long(extra_args);
       Caml_state->trapsp = sp;
@@ -865,7 +863,7 @@ value caml_interprete(code_t prog, asize_t prog_size)
         pc--; /* restart the POPTRAP after processing the signal */
         goto process_actions;
       }
-      Caml_state->trapsp = Trap_link(sp);
+      Caml_state->trapsp = sp + Long_val(Trap_link_offset(sp));
       sp += 4;
       Next;
 
@@ -898,7 +896,7 @@ value caml_interprete(code_t prog, asize_t prog_size)
       }
       sp = Caml_state->trapsp;
       pc = Trap_pc(sp);
-      Caml_state->trapsp = Trap_link(sp);
+      Caml_state->trapsp = sp + Long_val(Trap_link_offset(sp));
       env = sp[2];
       extra_args = Long_val(sp[3]);
       sp += 4;

runtime/major_gc.c

@@ -35,12 +35,6 @@
 #include "caml/memprof.h"
 #include "caml/eventlog.h"
 
-#if defined (NATIVE_CODE) && defined (NO_NAKED_POINTERS)
-#define NATIVE_CODE_AND_NO_NAKED_POINTERS
-#else
-#undef NATIVE_CODE_AND_NO_NAKED_POINTERS
-#endif
-
 #ifdef _MSC_VER
 Caml_inline double fmin(double a, double b) {
   return (a < b) ? a : b;
@@ -152,7 +146,7 @@ static void realloc_gray_vals (void)
 
 void caml_darken (value v, value *p /* not used */)
 {
-#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
+#ifdef NO_NAKED_POINTERS
   if (Is_block (v) && !Is_young (v)) {
 #else
   if (Is_block (v) && Is_in_heap (v)) {
@@ -164,7 +158,7 @@ void caml_darken (value v, value *p /* not used */)
       h = Hd_val (v);
       t = Tag_hd (h);
     }
-#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
+#ifdef NO_NAKED_POINTERS
     /* We insist that naked pointers to outside the heap point to things that
        look like values with headers coloured black.  This isn't always
        strictly necessary but is essential in certain cases---in particular
@@ -236,7 +230,7 @@ Caml_inline value* mark_slice_darken(value *gray_vals_ptr,
 
   child = Field (v, i);
 
-#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
+#ifdef NO_NAKED_POINTERS
   if (Is_block (child) && ! Is_young (child)) {
 #else
   if (Is_block (child) && Is_in_heap (child)) {
@@ -270,7 +264,7 @@ Caml_inline value* mark_slice_darken(value *gray_vals_ptr,
       child -= Infix_offset_val(child);
       chd = Hd_val(child);
     }
-#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
+#ifdef NO_NAKED_POINTERS
     /* See [caml_darken] for a description of this assertion. */
     CAMLassert (Is_in_heap (child) || Is_black_hd (chd));
 #endif

runtime/roots_byt.c

@@ -17,6 +17,7 @@
 
 /* To walk the memory roots for garbage collection */
 
+#include "caml/codefrag.h"
 #include "caml/finalise.h"
 #include "caml/globroots.h"
 #include "caml/major_gc.h"
@@ -42,6 +43,9 @@ void caml_oldify_local_roots (void)
   intnat i, j;
 
   /* The stack */
+  /* [caml_oldify_one] acts only on pointers into the minor heap.
+     So, it is safe to pass code pointers to [caml_oldify_one],
+     even in no-naked-pointers mode */
   for (sp = Caml_state->extern_sp; sp < Caml_state->stack_high; sp++) {
     caml_oldify_one (*sp, sp);
   }
@@ -118,7 +122,16 @@ CAMLexport void caml_do_local_roots (scanning_action f, value *stack_low,
   int i, j;
 
   for (sp = stack_low; sp < stack_high; sp++) {
+#ifdef NO_NAKED_POINTERS
+    /* Code pointers inside the stack are naked pointers.
+       We must avoid passing them to function [f]. */
+    value v = *sp;
+    if (Is_block(v) && caml_find_code_fragment_by_pc((char *) v) == NULL) {
+      f(v, sp);
+    }
+#else
     f (*sp, sp);
+#endif
   }
   for (lr = local_roots; lr != NULL; lr = lr->next) {
     for (i = 0; i < lr->ntables; i++){

runtime/stacks.c

@@ -47,7 +47,6 @@ void caml_realloc_stack(asize_t required_space)
 {
   asize_t size;
   value * new_low, * new_high, * new_sp;
-  value * p;
 
   CAMLassert(Caml_state->extern_sp >= Caml_state->stack_low);
   size = Caml_state->stack_high - Caml_state->stack_low;
@@ -72,8 +71,6 @@ void caml_realloc_stack(asize_t required_space)
   caml_stat_free(Caml_state->stack_low);
   Caml_state->trapsp = (value *) shift(Caml_state->trapsp);
   Caml_state->trap_barrier = (value *) shift(Caml_state->trap_barrier);
-  for (p = Caml_state->trapsp; p < new_high; p = Trap_link(p))
-    Trap_link(p) = (value *) shift(Trap_link(p));
   Caml_state->stack_low = new_low;
   Caml_state->stack_high = new_high;
   Caml_state->stack_threshold =