Review / new approach.

Author: xclerc

ocaml/configure

@@ -100,6 +100,9 @@ AS_IF([test x"$enable_runtime5" = xyes],
 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
 

ocaml/configure.ac

@@ -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(false);
+  uintnat stack_wsize = caml_get_init_stack_wsize(get_pthreads_stack_size());
 
   domain_state = Caml_state;
   th = NULL;

ocaml/otherlibs/systhreads/st_stubs.c

@@ -545,11 +545,11 @@ LBL(caml_call_gc):
 CFI_ENDPROC
 ENDFUNCTION(G(caml_call_gc))
 
-FUNCTION(G(caml_raise_stack_overflow))
+FUNCTION(G(caml_raise_stack_overflow_nat))
 CFI_STARTPROC
         CFI_SIGNAL_FRAME
         ENTER_FUNCTION
-LBL(caml_raise_stack_overflow):
+LBL(caml_raise_stack_overflow_nat):
         SAVE_ALL_REGS
         movq    %r15, Caml_state(gc_regs)
         SWITCH_OCAML_TO_C
@@ -560,7 +560,7 @@ LBL(caml_raise_stack_overflow):
         LEAVE_FUNCTION
         ret
 CFI_ENDPROC
-ENDFUNCTION(G(caml_raise_stack_overflow))
+ENDFUNCTION(G(caml_raise_stack_overflow_nat))
 
 FUNCTION(G(caml_alloc1))
 CFI_STARTPROC
@@ -817,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/amd64.S

@@ -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/backtrace_nat.c

@@ -21,7 +21,6 @@
 
 #ifdef CAML_INTERNALS
 
-#include <stdbool.h>
 #include "misc.h"
 #include "mlvalues.h"
 #include "roots.h"
@@ -258,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(bool is_main_thread);
+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/fiber.h

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

ocaml/runtime/caml/m.h.in

@@ -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(true);
+  uintnat stack_wsize = caml_get_init_stack_wsize(-1 /* main thread */);
 
   CAMLassert (domain_self == 0);
 

ocaml/runtime/domain.c

@@ -49,12 +49,17 @@
 
 static _Atomic int64_t fiber_id = 0;
 
-uintnat caml_get_init_stack_wsize (bool is_main_thread)
+uintnat caml_get_init_stack_wsize (int thread_stack_wsz)
 {
+#if defined(NATIVE_CODE) && !defined(STACK_CHECKS_ENABLED)
   uintnat init_stack_wsize =
-    is_main_thread
+    thread_stack_wsz < 0
     ? caml_params->init_main_stack_wsz
-    : caml_params->init_thread_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 (init_stack_wsize < caml_max_stack_wsize)
@@ -114,7 +119,7 @@ Caml_inline struct stack_info* alloc_for_stack (mlsize_t wosize)
   si->size = len;
   return si;
 #else
-#ifdef NATIVE_CODE
+#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.)
    *
@@ -136,7 +141,7 @@ Caml_inline struct stack_info* alloc_for_stack (mlsize_t wosize)
    *   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 disk of splitting a huge page
+   * 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);
@@ -871,7 +876,7 @@ void caml_free_stack (struct stack_info* stack)
   CAMLassert(cache != NULL);
 
 #ifndef USE_MMAP_MAP_STACK
-#ifdef NATIVE_CODE
+#if defined(NATIVE_CODE) && !defined(STACK_CHECKS_ENABLED)
   int page_size = getpagesize();
   mprotect((void *) ((char *) stack + page_size),
            page_size,
@@ -894,7 +899,7 @@ void caml_free_stack (struct stack_info* stack)
 #ifdef USE_MMAP_MAP_STACK
     munmap(stack, stack->size);
 #else
-#ifdef NATIVE_CODE
+#if defined(NATIVE_CODE) && !defined(STACK_CHECKS_ENABLED)
     munmap(stack, stack->size);
 #else
     caml_stat_free(stack);

ocaml/runtime/fiber.c

@@ -97,8 +97,9 @@ void caml_garbage_collection(void)
   sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name);    \
   sigact.sa_flags = SA_SIGINFO
 
+#if defined(NATIVE_CODE) && !defined(STACK_CHECKS_ENABLED)
 
-CAMLextern void caml_raise_stack_overflow(void);
+CAMLextern void caml_raise_stack_overflow_nat(void);
 
 DECLARE_SIGNAL_HANDLER(segv_handler)
 {
@@ -109,7 +110,7 @@ DECLARE_SIGNAL_HANDLER(segv_handler)
   char* protected_low = (char *) block + page_size;
   char* protected_high = protected_low + page_size;
   if ((fault_addr >= protected_low) && (fault_addr < protected_high)) {
-    context->uc_mcontext.gregs[REG_RIP]= (greg_t) &caml_raise_stack_overflow;
+    context->uc_mcontext.gregs[REG_RIP]= (greg_t) &caml_raise_stack_overflow_nat;
   } else {
     act.sa_handler = SIG_DFL;
     act.sa_flags = 0;
@@ -126,3 +127,11 @@ void caml_init_nat_signals(void)
   sigemptyset(&act.sa_mask);
   sigaction(SIGSEGV, &act, NULL);
 }
+
+#else
+
+void caml_init_nat_signals(void)
+{
+}
+
+#endif

ocaml/runtime/signals_nat.c

@@ -71,7 +71,7 @@ static void init_startup_params(void)
   params.init_custom_minor_ratio = Custom_minor_ratio_def;
   params.init_custom_minor_max_bsz = Custom_minor_max_bsz_def;
   params.init_main_stack_wsz = init_main_stack_wsz;
-  params.init_thread_stack_wsz = init_main_stack_wsz / 4;
+  params.init_thread_stack_wsz = 0;
   params.init_max_stack_wsz = Max_stack_def;
   params.runtime_events_log_wsize = Default_runtime_events_log_wsize;