Add a naked pointers dynamic checker (#9956)

This is selected at configure-time, option --enable-naked-pointers-checker.

The major GC warns when it detects out-of-heap pointers that could cause the no-naked-pointers runtime system to crash.

This is supported on x86-64 only, but on all ports (Unix and Windows).

Added tests involving naked pointers in tests/runtime-naked-pointers

Co-authored-by: KC Sivaramakrishnan <kc@kcsrk.info>
Co-authored-by: David Allsopp <david.allsopp@metastack.com>
Co-authored-by: Enguerrand Decorne <decorne.en@gmail.com>

Changes

@@ -140,6 +140,13 @@ Working version
   (KC Sivaramakrishnan, reported by Enguerrand Decorne, review by Gabriel
    Scherer, and Xavier Leroy)
 
+- #9534, #9947: Introduce a naked pointers checker mode to the runtime
+  (configure option --enable-naked-pointers-checker).  Alarms are printed
+  when the garbage collector finds out-of-heap pointers that could
+  cause a crash in no-naked-pointers mode.
+  (Enguerrand Decorne, KC Sivaramakrishnan, Xavier Leroy, Stephen Dolan,
+  David Allsopp, Nicolás Ojeda Bär review by Xavier Leroy, Nicolás Ojeda Bär)
+
 ### Code generation and optimizations:
 
 - #9551: ocamlc no longer loads DLLs at link time to check that

configure

@@ -747,6 +747,7 @@ build_os
 build_vendor
 build_cpu
 build
+naked_pointers_checker
 naked_pointers
 compute_deps
 stdlib_manpages
@@ -897,6 +898,7 @@ enable_ocamldoc
 enable_ocamltest
 enable_frame_pointers
 enable_naked_pointers
+enable_naked_pointers_checker
 enable_spacetime
 enable_call_counts
 enable_cfi
@@ -1570,6 +1572,8 @@ Optional Features:
   --enable-frame-pointers use frame pointers in runtime and generated code
   --disable-naked-pointers
                           do not allow naked pointers
+  --enable-naked-pointers-checker
+                          enable the naked pointers checker
   --enable-spacetime      build the spacetime profiler
   --disable-call-counts   disable the call counts in spacetime
   --disable-cfi           disable the CFI directives in assembly files
@@ -2941,6 +2945,7 @@ VERSION=4.12.0+dev0-2020-04-22
 
 
 
+
 
 
 ## Generated files
@@ -3201,6 +3206,12 @@ if test "${enable_naked_pointers+set}" = set; then :
 fi
 
 
+# Check whether --enable-naked-pointers-checker was given.
+if test "${enable_naked_pointers_checker+set}" = set; then :
+  enableval=$enable_naked_pointers_checker;
+fi
+
+
 # Check whether --enable-spacetime was given.
 if test "${enable_spacetime+set}" = set; then :
   enableval=$enable_spacetime;
@@ -16653,6 +16664,27 @@ else
   naked_pointers=true
 fi
 
+if test x"$enable_naked_pointers_checker" = "xyes" ; then :
+  if test x"$enable_naked_pointers" = "xno" ; then :
+  as_fn_error $? "--enable-naked-pointers-checker and --disable-naked-pointers are incompatible" "$LINENO" 5
+fi
+   case "$arch","$system" in #(
+  amd64,linux|amd64,macosx \
+    |amd64,openbsd|amd64,win64 \
+    |amd64,freebsd) :
+    naked_pointers_checker=true
+      $as_echo "#define NAKED_POINTERS_CHECKER 1" >>confdefs.h
+ ;; #(
+  *) :
+    as_fn_error $? "naked pointers checker not supported on this platform" "$LINENO" 5
+   ;; #(
+  *) :
+     ;;
+esac
+else
+  naked_pointers_checker=false
+fi
+
 ## Check for mmap support for huge pages and contiguous heap
 
   { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether mmap supports huge pages" >&5

configure.ac

@@ -170,6 +170,7 @@ AC_SUBST([PACKLD])
 AC_SUBST([stdlib_manpages])
 AC_SUBST([compute_deps])
 AC_SUBST([naked_pointers])
+AC_SUBST([naked_pointers_checker])
 
 ## Generated files
 
@@ -287,6 +288,10 @@ AC_ARG_ENABLE([naked-pointers],
   [AS_HELP_STRING([--disable-naked-pointers],
     [do not allow naked pointers])])
 
+AC_ARG_ENABLE([naked-pointers-checker],
+  [AS_HELP_STRING([--enable-naked-pointers-checker],
+    [enable the naked pointers checker])])
+
 AC_ARG_ENABLE([spacetime],
   [AS_HELP_STRING([--enable-spacetime],
     [build the spacetime profiler])])
@@ -1693,6 +1698,22 @@ AS_IF([test x"$enable_naked_pointers" = "xno" ],
    AC_DEFINE([NO_NAKED_POINTERS])],
   [naked_pointers=true])
 
+AS_IF([test x"$enable_naked_pointers_checker" = "xyes" ],
+  [AS_IF([test x"$enable_naked_pointers" = "xno" ],
+         [AC_MSG_ERROR(m4_normalize([
+               --enable-naked-pointers-checker and --disable-naked-pointers
+               are incompatible]))])
+   AS_CASE(["$arch","$system"],
+    [amd64,linux|amd64,macosx \
+    |amd64,openbsd|amd64,win64 \
+    |amd64,freebsd],
+      [naked_pointers_checker=true
+      AC_DEFINE([NAKED_POINTERS_CHECKER])],
+    [*],
+      [AC_MSG_ERROR([naked pointers checker not supported on this platform])]
+  )],
+  [naked_pointers_checker=false])
+
 ## Check for mmap support for huge pages and contiguous heap
 OCAML_MMAP_SUPPORTS_HUGE_PAGES
 

runtime/caml/domain_state.tbl

@@ -84,3 +84,8 @@ DOMAIN_STATE(uintnat, eventlog_paused)
 DOMAIN_STATE(uintnat, eventlog_enabled)
 DOMAIN_STATE(FILE*, eventlog_out)
 /* See eventlog.c */
+
+#if defined(NAKED_POINTERS_CHECKER) && !defined(_WIN32)
+DOMAIN_STATE(void*, checking_pointer_pc)
+/* See major_gc.c */
+#endif

runtime/caml/m.h.in

@@ -87,6 +87,8 @@
 
 #undef NO_NAKED_POINTERS
 
+#undef NAKED_POINTERS_CHECKER
+
 #undef WITH_PROFINFO
 
 #undef CAML_WITH_FPIC

runtime/domain.c

@@ -87,4 +87,8 @@ void caml_init_domain ()
   Caml_state->eventlog_startup_pid = 0;
   Caml_state->eventlog_startup_timestamp = 0;
   Caml_state->eventlog_out = NULL;
+
+#if defined(NAKED_POINTERS_CHECKER) && !defined(_WIN32)
+  Caml_state->checking_pointer_pc = NULL;
+  #endif
 }

runtime/major_gc.c

@@ -218,7 +218,7 @@ Caml_inline void mark_stack_push(struct mark_stack* stk, value block,
   CAMLassert(Tag_val(block) != Infix_tag);
   CAMLassert(Tag_val(block) < No_scan_tag);
 
-#ifdef NO_NAKED_POINTERS
+#if defined(NO_NAKED_POINTERS) || defined(NAKED_POINTERS_CHECKER)
   if (Tag_val(block) == Closure_tag) {
     /* Skip the code pointers and integers at beginning of closure;
         start scanning at the first word of the environment part. */
@@ -272,13 +272,16 @@ Caml_inline void mark_stack_push(struct mark_stack* stk, value block,
   me->offset = offset;
 }
 
+#if defined(NAKED_POINTERS_CHECKER) && defined(NATIVE_CODE)
+static void is_naked_pointer_safe (value v, value *p);
+#endif
 
-void caml_darken (value v, value *p /* not used */)
+void caml_darken (value v, value *p)
 {
 #ifdef NO_NAKED_POINTERS
-  if (Is_block (v) && !Is_young (v)) {
+  if (Is_block(v) && !Is_young (v)) {
 #else
-  if (Is_block (v) && Is_in_heap (v)) {
+  if (Is_block(v) && Is_in_heap (v)) {
 #endif
     header_t h = Hd_val (v);
     tag_t t = Tag_hd (h);
@@ -302,6 +305,11 @@ void caml_darken (value v, value *p /* not used */)
       }
     }
   }
+#if defined(NAKED_POINTERS_CHECKER) && defined(NATIVE_CODE)
+  else if (Is_block(v) && !Is_young(v)) {
+    is_naked_pointer_safe(v, p);
+  }
+#endif
 }
 
 /* This function shrinks the mark stack back to the MARK_STACK_INIT_SIZE size
@@ -405,7 +413,7 @@ Caml_inline void mark_slice_darken(struct mark_stack* stk, value v, mlsize_t i,
   child = Field (v, i);
 
 #ifdef NO_NAKED_POINTERS
-  if (Is_block (child) && !Is_young (child)) {
+  if (Is_block (child) && ! Is_young (child)) {
 #else
   if (Is_block (child) && Is_in_heap (child)) {
 #endif
@@ -452,6 +460,11 @@ Caml_inline void mark_slice_darken(struct mark_stack* stk, value v, mlsize_t i,
       }
     }
   }
+#if defined(NAKED_POINTERS_CHECKER) && defined(NATIVE_CODE)
+  else if (Is_block(child) && ! Is_young(child)) {
+    is_naked_pointer_safe(child, &Field (v, i));
+  }
+#endif
 }
 
 static void mark_ephe_aux (struct mark_stack *stk, intnat *work,
@@ -542,8 +555,6 @@ static void mark_ephe_aux (struct mark_stack *stk, intnat *work,
   }
 }
 
-
-
 static void mark_slice (intnat work)
 {
   mark_entry me = {0, 0};
@@ -1077,3 +1088,91 @@ void caml_finalise_heap (void)
   while (caml_gc_phase == Phase_sweep)
     sweep_slice (LONG_MAX);
 }
+
+#if defined(NAKED_POINTERS_CHECKER) && defined(NATIVE_CODE)
+
+#ifdef _WIN32
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+
+Caml_inline int safe_load(volatile header_t * p, header_t * result)
+{
+  header_t v;
+  __try {
+    v = *p;
+  }
+  __except(GetExceptionCode() == EXCEPTION_ACCESS_VIOLATION ?
+        EXCEPTION_EXECUTE_HANDLER : EXCEPTION_CONTINUE_SEARCH) {
+    *result = 0xdeadbeef;
+    return 0;
+  }
+  *result = v;
+  return 1;
+}
+
+#else
+
+Caml_inline int safe_load (header_t * addr, /*out*/ header_t * contents)
+{
+  int ok;
+  header_t h;
+  intnat tmp;
+
+  asm volatile(
+      "leaq 1f(%%rip), %[tmp] \n\t"
+      "movq %[tmp], 0(%[handler]) \n\t"
+      "xorl %[ok], %[ok] \n\t"
+      "movq 0(%[addr]), %[h] \n\t"
+      "movl $1, %[ok] \n\t"
+  "1: \n\t"
+      "xorq %[tmp], %[tmp] \n\t"
+      "movq %[tmp], 0(%[handler])"
+      : [tmp] "=&r" (tmp), [ok] "=&r" (ok), [h] "=&r" (h)
+      : [addr] "r" (addr),
+        [handler] "r" (&(Caml_state->checking_pointer_pc)));
+  *contents = h;
+  return ok;
+}
+
+#endif
+
+static void is_naked_pointer_safe (value v, value *p)
+{
+  header_t h;
+  tag_t t;
+
+  /* The following conditions were checked by the caller */
+  CAMLassert(Is_block(v) && !Is_young(v) && !Is_in_heap(v));
+
+  if (! safe_load(&Hd_val(v), &h)) goto on_segfault;
+
+  t = Tag_hd(h);
+  if (t == Infix_tag) {
+    v -= Infix_offset_hd(h);
+    if (! safe_load(&Hd_val(v), &h)) goto on_segfault;
+    t = Tag_hd(h);
+  }
+
+  /* For the out-of-heap pointer to be considered safe,
+   * it should have a black header and its size should be < 2 ** 40
+   * words (128 GB). If not, we report a warning. */
+  if (Is_black_hd(h) && Wosize_hd(h) < (INT64_LITERAL(1) << 40))
+    return;
+
+  if (!Is_black_hd(h)) {
+    fprintf (stderr, "Out-of-heap pointer at %p of value %p has "
+                     "non-black head (tag=%d)\n", p, (void*)v, t);
+  } else {
+    fprintf (stderr,
+             "Out-of-heap pointer at %p of value %p has "
+             "suspiciously large size: %" ARCH_INT64_PRINTF_FORMAT "u words\n",
+              p, (void*)v, Wosize_hd(h));
+  }
+  return;
+
+ on_segfault:
+  fprintf (stderr, "Out-of-heap pointer at %p of value %p. "
+           "Cannot read head.\n", p, (void*)v);
+}
+
+#endif

runtime/signals_nat.c

@@ -231,6 +231,14 @@ DECLARE_SIGNAL_HANDLER(segv_handler)
 #endif
     caml_raise_stack_overflow();
 #endif
+#ifdef NAKED_POINTERS_CHECKER
+  } else if (Caml_state->checking_pointer_pc) {
+#ifdef CONTEXT_PC
+    CONTEXT_PC = (context_reg)Caml_state->checking_pointer_pc;
+#else
+#error "CONTEXT_PC must be defined if RETURN_AFTER_STACK_OVERFLOW is"
+#endif /* CONTEXT_PC */
+#endif /* NAKED_POINTERS_CHECKER */
   } else {
     /* Otherwise, deactivate our exception handler and return,
        causing fatal signal to be generated at point of error. */

runtime/sys.c

@@ -698,3 +698,12 @@ CAMLprim value caml_sys_isatty(value chan)
 
   return ret;
 }
+
+CAMLprim value caml_sys_const_naked_pointers_checked(value unit)
+{
+#ifdef NAKED_POINTERS_CHECKER
+  return Val_true;
+#else
+  return Val_false;
+#endif
+}

stdlib/stdlib.ml

@@ -565,6 +565,11 @@ let exit retcode =
 
 let _ = register_named_value "Pervasives.do_at_exit" do_at_exit
 
+external major : unit -> unit = "caml_gc_major"
+external naked_pointers_checked : unit -> bool
+  = "caml_sys_const_naked_pointers_checked"
+let () = if naked_pointers_checked () then at_exit major
+
 (*MODULE_ALIASES*)
 module Arg          = Arg
 module Array        = Array

testsuite/tests/runtime-naked-pointers/cstubs.c

@@ -0,0 +1,20 @@
+#include <string.h>
+#include "caml/mlvalues.h"
+#include "caml/gc.h"
+#include "caml/memory.h"
+
+static int colors[4] = { Caml_white, Caml_gray, Caml_blue, Caml_black };
+
+value make_block(value header_size, value color, value size)
+{
+  intnat sz = Nativeint_val(size);
+  value * p = caml_stat_alloc((1 + sz) * sizeof(value));
+  p[0] = Make_header(Nativeint_val(header_size), 0, colors[Int_val(color)]);
+  memset(p + 1, 0x80, sz * sizeof(value));
+  return (value) (p + 1);
+}
+
+value make_raw_pointer (value v)
+{
+  return (value) Nativeint_val(v);
+}

testsuite/tests/runtime-naked-pointers/np.ml

@@ -0,0 +1,11 @@
+type color = White | Gray | Blue | Black
+
+external make_block: nativeint -> color -> nativeint -> Obj.t
+         = "make_block"
+
+external make_raw_pointer: nativeint -> Obj.t
+         = "make_raw_pointer"
+
+let do_gc root =
+  Gc.compact();   (* full major + compaction *)
+  root

testsuite/tests/runtime-naked-pointers/np1.ml

@@ -0,0 +1,12 @@
+(* TEST
+   modules = "cstubs.c np.ml"
+   * bytecode
+   * native
+*)
+
+open Np
+
+(* Out-of-heap object with black header is accepted even in no-naked-pointers
+   mode.  GC doesn't scan black objects. *)
+
+let x = do_gc [ make_block 100n Black 100n ]

testsuite/tests/runtime-naked-pointers/np2.ml

@@ -0,0 +1,13 @@
+(* TEST
+   modules = "cstubs.c np.ml"
+   * bytecode
+   * native
+*)
+
+open Np
+
+(* Out-of-heap object with black header is accepted even in no-naked-pointers
+   mode.  GC doesn't scan black objects.  However, if the size in the
+   head is crazily big, the naked pointer detector will warn. *)
+
+let x = do_gc [ make_block (-1n) Black 100n ]

testsuite/tests/runtime-naked-pointers/np2.run

@@ -0,0 +1,3 @@
+#!/bin/sh
+
+exec ${test_source_directory}/runtest.sh

testsuite/tests/runtime-naked-pointers/np3.ml

@@ -0,0 +1,15 @@
+(* TEST
+   modules = "cstubs.c np.ml"
+   * naked_pointers
+   ** bytecode
+   ** native
+*)
+
+open Np
+
+(* Out-of-heap object with non-black header is OK in naked pointers mode only *)
+(* Note that the header size can be wrong as it should not be used by the GC *)
+
+let x = do_gc [ make_block 10000n White 10n;
+                make_block 1n Blue 0n;
+                make_block (-1n) Gray 5n ]

testsuite/tests/runtime-naked-pointers/np3.run

@@ -0,0 +1,3 @@
+#!/bin/sh
+
+exec ${test_source_directory}/runtest.sh

testsuite/tests/runtime-naked-pointers/np4.ml

@@ -0,0 +1,13 @@
+(* TEST
+   modules = "cstubs.c np.ml"
+   * naked_pointers
+   ** bytecode
+   ** native
+*)
+
+open Np
+
+(* Null pointers and bad pointers outside the heap are OK
+   in naked pointers mode only *)
+
+let x = do_gc [ make_raw_pointer 0n; make_raw_pointer 42n ]

testsuite/tests/runtime-naked-pointers/np4.run

@@ -0,0 +1,3 @@
+#!/bin/sh
+
+exec ${test_source_directory}/runtest.sh

testsuite/tests/runtime-naked-pointers/runtest.sh

@@ -0,0 +1,10 @@
+#!/bin/sh
+
+if grep -q "#define NAKED_POINTERS_CHECKER" ${ocamlsrcdir}/runtime/caml/m.h \
+&& (echo ${program} | grep -q '\.opt')
+then
+  (${program} > ${output}) 2>&1 | grep -q '^Out-of-heap '
+  exit $?
+else
+  exec ${program} > ${output}
+fi