Disable stack checks by default.

backend/amd64/emit.mlp

@@ -1905,7 +1905,7 @@ let fundecl fundecl =
   D.label (label_name (emit_symbol fundecl.fun_name));
   emit_debug_info fundecl.fun_dbg;
   cfi_startproc ();
-  if Config.runtime5 && !Clflags.runtime_variant = "d" then begin
+  if Config.runtime5 && (not Config.no_stack_checks) && !Clflags.runtime_variant = "d" then begin
     emit_call (Cmm.global_symbol "caml_assert_stack_invariants");
   end;
   emit_all ~first:true ~fallthrough:true fundecl.fun_body;

ocaml/configure.ac

@@ -97,10 +97,18 @@ AS_IF([test x"$enable_runtime5" = xyes],
       [runtime_suffix=],
       [runtime_suffix=4])
 
+AC_ARG_ENABLE([stack_checks],
+  [AS_HELP_STRING([--enable-stack_checks],
+    [Enable stack checks])])
+AS_IF([test x"$enable_stack_checks" = xyes],
+      [AC_DEFINE([STACK_CHECKS_ENABLED])],
+      [])
+
 ## Output variables
 
 AC_SUBST([enable_runtime5])
 AC_SUBST([runtime_suffix])
+AC_SUBST([enable_stack_checks])
 AC_SUBST([CONFIGURE_ARGS])
 AC_SUBST([native_compiler])
 AC_SUBST([default_build_target])

ocaml/otherlibs/systhreads/st_stubs.c

@@ -354,6 +354,16 @@ static void caml_thread_leave_blocking_section(void)
   restore_runtime_state(th);
 }
 
+int get_pthreads_stack_size(void) {
+  pthread_attr_t attr;
+  size_t res = 8388608;
+  if (pthread_attr_init(&attr) == 0) {
+    pthread_attr_getstacksize(&attr, &res);
+  }
+  pthread_attr_destroy(&attr);
+  return res;
+}
+
 /* Create and setup a new thread info block.
    This block has no associated thread descriptor and
    is not inserted in the list of threads. */
@@ -362,7 +372,7 @@ static caml_thread_t caml_thread_new_info(void)
 {
   caml_thread_t th;
   caml_domain_state *domain_state;
-  uintnat stack_wsize = caml_get_init_stack_wsize();
+  uintnat stack_wsize = caml_get_init_stack_wsize(get_pthreads_stack_size());
 
   domain_state = Caml_state;
   th = NULL;

ocaml/runtime/amd64.S

@@ -545,6 +545,23 @@ LBL(caml_call_gc):
 CFI_ENDPROC
 ENDFUNCTION(G(caml_call_gc))
 
+FUNCTION(G(caml_raise_stack_overflow_nat))
+CFI_STARTPROC
+        CFI_SIGNAL_FRAME
+        ENTER_FUNCTION
+LBL(caml_raise_stack_overflow_nat):
+        SAVE_ALL_REGS
+        movq    %r15, Caml_state(gc_regs)
+        SWITCH_OCAML_TO_C
+        C_call (GCALL(caml_raise_stack_overflow))
+        SWITCH_C_TO_OCAML
+        movq    Caml_state(gc_regs), %r15
+        RESTORE_ALL_REGS
+        LEAVE_FUNCTION
+        ret
+CFI_ENDPROC
+ENDFUNCTION(G(caml_raise_stack_overflow_nat))
+
 FUNCTION(G(caml_alloc1))
 CFI_STARTPROC
         ENTER_FUNCTION
@@ -800,16 +817,10 @@ LBL(117):
         movq    %rax, %r12        /* Save exception bucket */
         movq    Caml_state(c_stack), %rsp
         movq    %rax, C_ARG_1     /* arg 1: exception bucket */
-#ifdef WITH_FRAME_POINTERS
-        movq    8(%r10), C_ARG_2   /* arg 2: pc of raise */
-        leaq    16(%r10), C_ARG_3  /* arg 3: sp at raise */
-#else
-        movq    (%r10), C_ARG_2   /* arg 2: pc of raise */
-        leaq    8(%r10), C_ARG_3  /* arg 3: sp at raise */
-#endif
-        movq    Caml_state(exn_handler), C_ARG_4
-                                  /* arg 4: sp of handler */
-        C_call  (GCALL(caml_stash_backtrace))
+        movq    %r10, C_ARG_2     /* arg 2: passed rsp */
+        movq    Caml_state(exn_handler), C_ARG_3
+                                  /* arg 3: sp of handler */
+        C_call  (GCALL(caml_stash_backtrace_wrapper))
         movq    %r12, %rax        /* Recover exception bucket */
         RESTORE_EXN_HANDLER_OCAML
         ret

ocaml/runtime/backtrace_nat.c

@@ -20,6 +20,7 @@
 #include <stdio.h>
 #include <stdlib.h>
 #include <string.h>
+#include <unistd.h>
 
 #include "caml/alloc.h"
 #include "caml/backtrace.h"
@@ -132,6 +133,32 @@ void caml_stash_backtrace(value exn, uintnat pc, char * sp, char* trapsp)
   }
 }
 
+void caml_stash_backtrace_wrapper(value exn, char* rsp, char* trapsp) {
+#if defined(NATIVE_CODE) && !defined(STACK_CHECKS_ENABLED)
+  /* if we have protected part of the memory, and get an rsp in the
+   * protected range, just do nothing - using rsp would trigger another
+   * segfault, while we are probably in the process of raising the
+   * exception from a segfault... */
+  struct stack_info *block = Caml_state->current_stack;
+  int page_size = getpagesize();
+  char* protected_low = (char *) block + page_size;
+  char* protected_high = protected_low + page_size;
+  if ((rsp >= protected_low) && (rsp < protected_high)) {
+    return;
+  }
+#endif
+  char* pc;
+  char* sp;
+#ifdef WITH_FRAME_POINTERS
+  pc = rsp + 8;
+  sp = rsp + 16;
+#else
+  pc = rsp;
+  sp = rsp + 8;
+#endif
+  caml_stash_backtrace(exn, *((uintnat*) pc), sp, trapsp);
+}
+
 /* minimum size to allocate a backtrace (in slots) */
 #define MIN_BACKTRACE_SIZE 16
 

ocaml/runtime/caml/fiber.h

@@ -257,7 +257,7 @@ struct stack_info* caml_alloc_stack_noexc(mlsize_t wosize, value hval,
 /* try to grow the stack until at least required_size words are available.
    returns nonzero on success */
 CAMLextern int caml_try_realloc_stack (asize_t required_wsize);
-CAMLextern uintnat caml_get_init_stack_wsize(void);
+CAMLextern uintnat caml_get_init_stack_wsize(int thread_stack_wsz);
 void caml_change_max_stack_size (uintnat new_max_wsize);
 void caml_maybe_expand_stack(void);
 CAMLextern void caml_free_stack(struct stack_info* stk);

ocaml/runtime/caml/m.h.in

@@ -101,3 +101,5 @@
 #undef USE_MMAP_MAP_STACK
 
 #undef STACK_ALLOCATION
+
+#undef STACK_CHECKS_ENABLED

ocaml/runtime/caml/signals.h

@@ -27,6 +27,8 @@
 extern "C" {
 #endif
 
+CAMLextern void caml_init_nat_signals(void);
+
 CAMLextern void caml_enter_blocking_section (void);
 CAMLextern void caml_enter_blocking_section_no_pending (void);
 CAMLextern void caml_leave_blocking_section (void);

ocaml/runtime/caml/startup_aux.h

@@ -46,6 +46,8 @@ struct caml_params {
   uintnat init_custom_minor_ratio;
   uintnat init_custom_minor_max_bsz;
 
+  uintnat init_main_stack_wsz;
+  uintnat init_thread_stack_wsz;
   uintnat init_max_stack_wsz;
 
   uintnat backtrace_enabled;

ocaml/runtime/domain.c

@@ -545,7 +545,7 @@ static void domain_create(uintnat initial_minor_heap_wsize,
   dom_internal* d = 0;
   caml_domain_state* domain_state;
   struct interruptor* s;
-  uintnat stack_wsize = caml_get_init_stack_wsize();
+  uintnat stack_wsize = caml_get_init_stack_wsize(-1 /* main thread */);
 
   CAMLassert (domain_self == 0);
 

ocaml/runtime/fiber.c

@@ -49,13 +49,21 @@
 
 static _Atomic int64_t fiber_id = 0;
 
-uintnat caml_get_init_stack_wsize (void)
+uintnat caml_get_init_stack_wsize (int thread_stack_wsz)
 {
-  uintnat default_stack_wsize = Wsize_bsize(Stack_init_bsize);
+#if defined(NATIVE_CODE) && !defined(STACK_CHECKS_ENABLED)
+  uintnat init_stack_wsize =
+    thread_stack_wsz < 0
+    ? caml_params->init_main_stack_wsz
+    : caml_params->init_thread_stack_wsz > 0 ? caml_params->init_thread_stack_wsz : thread_stack_wsz;
+#else
+  (void) thread_stack_wsz;
+  uintnat init_stack_wsize = Wsize_bsize(Stack_init_bsize);
+#endif
   uintnat stack_wsize;
 
-  if (default_stack_wsize < caml_max_stack_wsize)
-    stack_wsize = default_stack_wsize;
+  if (init_stack_wsize < caml_max_stack_wsize)
+    stack_wsize = init_stack_wsize;
   else
     stack_wsize = caml_max_stack_wsize;
 
@@ -97,11 +105,11 @@ struct stack_info** caml_alloc_stack_cache (void)
 
 Caml_inline struct stack_info* alloc_for_stack (mlsize_t wosize)
 {
+#ifdef USE_MMAP_MAP_STACK
   size_t len = sizeof(struct stack_info) +
                sizeof(value) * wosize +
                8 /* for alignment to 16-bytes, needed for arm64 */ +
                sizeof(struct stack_handler);
-#ifdef USE_MMAP_MAP_STACK
   struct stack_info* si;
   si = mmap(NULL, len, PROT_WRITE | PROT_READ,
              MAP_ANONYMOUS | MAP_PRIVATE | MAP_STACK, -1, 0);
@@ -111,7 +119,65 @@ Caml_inline struct stack_info* alloc_for_stack (mlsize_t wosize)
   si->size = len;
   return si;
 #else
+#if defined(NATIVE_CODE) && !defined(STACK_CHECKS_ENABLED)
+  /* (We use the following strategy only in native code, because bytecode
+   * has its own way of dealing with stack checks.)
+   *
+   * We want to detect a stack overflow by triggering a segfault when a
+   * given part of the memory is accessed; in order to do so, we protect
+   * a page near the end of the stack to make it unreadable/unwritable.
+   * A signal handler for segfault will be installed, that will check if
+   * the invalid address is in the range we protect, and will raise a stack
+   * overflow exception accordingly.
+   *
+   * The sequence of steps to achieve that is loosely based on the glibc
+   * code (See nptl/allocatestack.c):
+   * - first, we mmap the memory for the stack, with PROT_NONE so that
+   *   the allocated memory is not committed;
+   * - second, we madvise to not use huge pages for this memory chunk;
+   * - third, we restore the read/write permissions for the whole memory
+   *   chunk;
+   * - finally, we disable the read/write permissions again, but only
+   *   for the page that will act as the guard.
+   *
+   * The reasoning behind this convoluted process is that if we only
+   * mmap and then mprotect, we incur the risk of splitting a huge page
+   * and losing its benefits while causing more bookkeeping.
+   */
+  size_t bsize = Bsize_wsize(wosize);
+  int page_size = getpagesize();
+  int num_pages = (bsize + page_size - 1) / page_size;
+  bsize = (num_pages + 2) * page_size;
+  size_t len = sizeof(struct stack_info) +
+               bsize +
+               8 /* for alignment to 16-bytes, needed for arm64 */ +
+               sizeof(struct stack_handler);
+  struct stack_info* block;
+  block = mmap(NULL, len, PROT_NONE, MAP_PRIVATE | MAP_ANONYMOUS | MAP_STACK, -1, 0);
+  if (block == MAP_FAILED) {
+    return NULL;
+  }
+  if (madvise (block, len, MADV_NOHUGEPAGE)) {
+    munmap(block, len);
+    return NULL;
+  }
+  if (mprotect(block, len, PROT_READ | PROT_WRITE)) {
+    munmap(block, len);
+    return NULL;
+  }
+  if (mprotect((char *) block + page_size, page_size, PROT_NONE)) {
+    munmap(block, len);
+    return NULL;
+  }
+  block->size = len;
+  return block;
+#else
+  size_t len = sizeof(struct stack_info) +
+               sizeof(value) * wosize +
+               8 /* for alignment to 16-bytes, needed for arm64 */ +
+               sizeof(struct stack_handler);
   return caml_stat_alloc_noexc(len);
+#endif /* NATIVE_CODE */
 #endif /* USE_MMAP_MAP_STACK */
 }
 
@@ -808,6 +874,16 @@ void caml_free_stack (struct stack_info* stack)
 
   CAMLassert(stack->magic == 42);
   CAMLassert(cache != NULL);
+
+#ifndef USE_MMAP_MAP_STACK
+#if defined(NATIVE_CODE) && !defined(STACK_CHECKS_ENABLED)
+  int page_size = getpagesize();
+  mprotect((void *) ((char *) stack + page_size),
+           page_size,
+           PROT_READ | PROT_WRITE);
+#endif
+#endif
+
   if (stack->cache_bucket != -1) {
     stack->exception_ptr =
       (void*)(cache[stack->cache_bucket]);
@@ -822,8 +898,12 @@ void caml_free_stack (struct stack_info* stack)
 #endif
 #ifdef USE_MMAP_MAP_STACK
     munmap(stack, stack->size);
+#else
+#if defined(NATIVE_CODE) && !defined(STACK_CHECKS_ENABLED)
+    munmap(stack, stack->size);
 #else
     caml_stat_free(stack);
+#endif
 #endif
   }
 }