flambda-backend: Fix all the no-naked-pointers problems (ocaml-flambd…

…a#1282)

* Fix wrong return values in new NNP version of caml_page_table_lookup and update comment

* Skip some assertions that cannot be checked in NNP mode during the heap check

* Fix marshalling and heap check for new closure representation

* Remove assertions that now prove nothing

* Ensure white remnants are created in bf_make_free_blocks with Abstract_tag tags

* Stop pointless memmove operations

* Fix misleading CI check name for ocaml-jst

* Remove check prior to memmove

* Fix marshalling of non-scanned environments

.github/workflows/build.yml

@@ -9,7 +9,7 @@ jobs:
       fail-fast: false
       matrix:
         include:
-          - name: closure-nnp-local
+          - name: closure-local
             config: --enable-stack-allocation
             os: ubuntu-latest
             ocamlparam: ''

runtime/caml/intext.h

@@ -80,6 +80,7 @@
 #define CODE_CUSTOM 0x12 /* deprecated */
 #define CODE_CUSTOM_LEN 0x18
 #define CODE_CUSTOM_FIXED 0x19
+#define CODE_UNBOXED_INT64 0x1a
 
 #if ARCH_FLOAT_ENDIANNESS == 0x76543210
 #define CODE_DOUBLE_NATIVE CODE_DOUBLE_BIG

runtime/extern.c

@@ -502,6 +502,14 @@ Caml_inline void extern_int(intnat n)
   }
 }
 
+Caml_inline void extern_unboxed_int(intnat n)
+{
+  if (extern_flags & COMPAT_32)
+    extern_failwith("output_value: cannot marshal unboxed values on 32 bit");
+
+  writecode64(CODE_UNBOXED_INT64, n);
+}
+
 /* Marshaling references to previously-marshaled blocks */
 
 Caml_inline void extern_shared_reference(uintnat d)
@@ -653,7 +661,7 @@ static void extern_code_pointer(char * codeptr)
   }
 }
 
-/* Marshaling the non-environment part of closures */
+/* Marshaling the non-scanned-environment part of closures */
 
 #ifdef NO_NAKED_POINTERS
 Caml_inline mlsize_t extern_closure_up_to_env(value v)
@@ -677,6 +685,10 @@ Caml_inline mlsize_t extern_closure_up_to_env(value v)
     }
   } while (!Is_last_closinfo(info));
   CAMLassert(i <= startenv);
+  /* The non-scanned part of the environment */
+  while (i < startenv) {
+    extern_unboxed_int(Field(v, i++));
+  }
   return startenv;
 }
 #endif

runtime/freelist.c

@@ -1723,6 +1723,7 @@ static void bf_make_free_blocks (value *p, mlsize_t size, int do_merge,
                                  int color)
 {
   mlsize_t sz, wosz;
+  tag_t tag;
 
   while (size > 0){
     if (size > Whsize_wosize (Max_wosize)){
@@ -1737,10 +1738,12 @@ static void bf_make_free_blocks (value *p, mlsize_t size, int do_merge,
       }else{
         color = Caml_blue;
       }
-      *(header_t *)p = Make_header (wosz, 0, color);
+      tag = color == Caml_blue ? 0 : Abstract_tag;
+      *(header_t *)p = Make_header (wosz, tag, color);
       bf_insert_remnant (Val_hp (p));
     }else{
-      *(header_t *)p = Make_header (wosz, 0, color);
+      tag = color == Caml_blue ? 0 : Abstract_tag;
+      *(header_t *)p = Make_header (wosz, tag, color);
     }
     size -= sz;
     p += sz;

runtime/gc_ctrl.c

@@ -60,7 +60,11 @@ static void check_head (value v)
   CAMLassert (Is_block (v));
   CAMLassert (Is_in_heap (v));
 
+#ifndef NO_NAKED_POINTERS
+  /* This cannot be checked in no-naked-pointers mode: [v] might be a
+     statically-allocated empty array. */
   CAMLassert (Wosize_val (v) != 0);
+#endif
   CAMLassert (Color_hd (Hd_val (v)) != Caml_blue);
   CAMLassert (Is_in_heap (v));
   if (Tag_val (v) == Infix_tag){
@@ -81,12 +85,13 @@ static void check_head (value v)
 
 static void check_block (header_t *hp)
 {
-  mlsize_t i;
+  mlsize_t i, start;
+  tag_t tag = Tag_hp (hp);
   value v = Val_hp (hp);
   value f;
 
   check_head (v);
-  switch (Tag_hp (hp)){
+  switch (tag){
   case Abstract_tag: break;
   case String_tag:
     break;
@@ -97,7 +102,9 @@ static void check_block (header_t *hp)
     CAMLassert (Wosize_val (v) % Double_wosize == 0);
     break;
   case Custom_tag:
+#ifndef NO_NAKED_POINTERS
     CAMLassert (!Is_in_heap (Custom_ops_val (v)));
+#endif
     break;
 
   case Infix_tag:
@@ -106,7 +113,10 @@ static void check_block (header_t *hp)
 
   default:
     CAMLassert (Tag_hp (hp) < No_scan_tag);
-    for (i = 0; i < Wosize_hp (hp); i++){
+    /* For closures, skip to the start of the scannable environment */
+    if (tag == Closure_tag) start = Start_env_closinfo(Closinfo_val(v));
+    else start = 0;
+    for (i = start; i < Wosize_hp (hp); i++){
       f = Field (v, i);
       if (Is_block (f) && Is_in_heap (f)){
         check_head (f);

runtime/intern.c

@@ -427,6 +427,15 @@ static void intern_rec(value *dest)
         intern_cleanup();
         caml_failwith("input_value: integer too large");
         break;
+#endif
+      case CODE_UNBOXED_INT64:
+#ifdef ARCH_SIXTYFOUR
+        v = (intnat) (read64u());
+        break;
+#else
+        intern_cleanup();
+        caml_failwith("input_value: CODE_UNBOXED_INT64 not supported on 32 bit");
+        break;
 #endif
       case CODE_SHARED8:
         ofs = read8u();

runtime/major_gc.c

@@ -289,12 +289,6 @@ void caml_darken (value v, value *p)
       h = Hd_val (v);
       t = Tag_hd (h);
     }
-#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 is always
-       strictly necessary because the compactor relies on it. */
-    CAMLassert (Is_in_heap (v) || Is_black_hd (h));
-#endif
     CAMLassert (!Is_blue_hd (h));
     if (Is_white_hd (h)){
       caml_ephe_list_pure = 0;
@@ -474,10 +468,6 @@ Caml_inline void mark_ephe_darken(struct mark_stack* stk, value v, mlsize_t i,
       child -= Infix_offset_val(child);
       chd = Hd_val(child);
     }
-#ifdef NO_NAKED_POINTERS
-    /* See [caml_darken] for a description of this assertion. */
-    CAMLassert (Is_in_heap (child) || Is_black_hd (chd));
-#endif
     if (Is_white_hd (chd)){
       caml_ephe_list_pure = 0;
       Hd_val (child) = Blackhd_hd (chd);
@@ -659,10 +649,6 @@ Caml_noinline static intnat do_some_marking
         hd = Hd_val(block);
       }
 
-#ifdef NO_NAKED_POINTERS
-      /* See [caml_darken] for a description of this assertion. */
-      CAMLassert (Is_in_heap (block) || Is_black_hd (hd));
-#endif
       CAMLassert(Is_white_hd(hd) || Is_black_hd(hd));
       if (!Is_white_hd (hd)) {
         /* Already black, nothing to do */

runtime/memory.c

@@ -91,24 +91,27 @@ static struct page_table caml_page_table;
 int caml_page_table_lookup(void * addr)
 {
 #ifdef NO_NAKED_POINTERS
-  /* This case should only be hit if C stubs compiled without
+  /* This avoids consulting the page table at all when the compiler
+     is configured using --disable-naked-pointers.
+
+     This case can also be hit if C stubs compiled without
      NO_NAKED_POINTERS are linked into an executable using
      "-runtime-variant nnp".  The return value here should cause the
      macros in address_class.h to give the same results as when they
      are compiled with NO_NAKED_POINTERS defined. */
 
   caml_local_arenas* local_arenas = Caml_state->local_arenas;
 
-  if (Is_young(addr))
-    return In_heap | In_young;
+  if (Is_young((value) addr))
+    return In_young;
 
   if (local_arenas != NULL) {
     int arena;
     for (arena = 0; arena < local_arenas->count; arena++) {
       char* start = local_arenas->arenas[arena].base;
       char* end = start + local_arenas->arenas[arena].length;
       if ((char*) addr >= start && (char*) addr < end)
-        return In_heap | In_local;
+        return In_local;
     }
   }