Async exns

Author: mshinwell

backend/cfg/cfg.ml

@@ -386,7 +386,8 @@ let can_raise_operation : operation -> bool = function
 
 let can_raise_basic : basic -> bool = function
   | Op op -> can_raise_operation op
-  | Call _ -> true
+  | Call (P (Alloc _)) -> false
+  | Call (P (External _ | Checkbound _)) | Call (F _) -> true
   | Reloadretaddr -> false
   | Pushtrap _ -> false
   | Poptrap -> false

backend/mach.ml

@@ -204,8 +204,7 @@ let operation_can_raise op =
   match op with
   | Icall_ind | Icall_imm _ | Iextcall _
   | Iintop (Icheckbound) | Iintop_imm (Icheckbound, _)
-  | Iprobe _
-  | Ialloc _ -> true
+  | Iprobe _ -> true
   | Ispecific sop -> Arch.operation_can_raise sop
   | Iintop_imm((Iadd | Isub | Imul | Imulh _ | Idiv | Imod | Iand | Ior | Ixor
                | Ilsl | Ilsr | Iasr | Ipopcnt | Iclz _|Ictz _|Icomp _), _)
@@ -217,7 +216,7 @@ let operation_can_raise op =
   | Istackoffset _ | Istore _  | Iload (_, _, _) | Iname_for_debugger _
   | Itailcall_imm _ | Itailcall_ind
   | Iopaque | Ibeginregion | Iendregion
-  | Iprobe_is_enabled _
+  | Iprobe_is_enabled _ | Ialloc _
     -> false
 
 let free_conts_for_handlers fundecl =

ocaml/otherlibs/systhreads/st_stubs.c

@@ -78,6 +78,8 @@ struct caml_thread_struct {
   uintnat last_retaddr;     /* Saved value of Caml_state->last_return_address */
   value * gc_regs;          /* Saved value of Caml_state->gc_regs */
   char * exception_pointer; /* Saved value of Caml_state->exception_pointer */
+  char * async_exception_pointer;
+                       /* Saved value of Caml_state->async_exception_pointer */
   struct caml__roots_block * local_roots; /* Saved value of local_roots */
   struct caml_local_arenas * local_arenas;
   struct longjmp_buffer * exit_buf; /* For thread exit */
@@ -90,6 +92,8 @@ struct caml_thread_struct {
   /* Saved value of Caml_state->local_roots */
   struct caml__roots_block * local_roots;
   struct longjmp_buffer * external_raise; /* Saved Caml_state->external_raise */
+  struct longjmp_buffer * external_raise_async;
+                                    /* Saved Caml_state->external_raise_async */
 #endif
   int backtrace_pos; /* Saved Caml_state->backtrace_pos */
   backtrace_slot * backtrace_buffer; /* Saved Caml_state->backtrace_buffer */
@@ -182,6 +186,7 @@ Caml_inline void caml_thread_save_runtime_state(void)
   curr_thread->last_retaddr = Caml_state->last_return_address;
   curr_thread->gc_regs = Caml_state->gc_regs;
   curr_thread->exception_pointer = Caml_state->exception_pointer;
+  curr_thread->async_exception_pointer = Caml_state->async_exception_pointer;
   curr_thread->local_arenas = caml_get_local_arenas();
 #else
   curr_thread->stack_low = Caml_state->stack_low;
@@ -190,6 +195,7 @@ Caml_inline void caml_thread_save_runtime_state(void)
   curr_thread->sp = Caml_state->extern_sp;
   curr_thread->trapsp = Caml_state->trapsp;
   curr_thread->external_raise = Caml_state->external_raise;
+  curr_thread->external_raise_async = Caml_state->external_raise_async;
 #endif
   curr_thread->local_roots = Caml_state->local_roots;
   curr_thread->backtrace_pos = Caml_state->backtrace_pos;
@@ -206,6 +212,7 @@ Caml_inline void caml_thread_restore_runtime_state(void)
   Caml_state->last_return_address = curr_thread->last_retaddr;
   Caml_state->gc_regs = curr_thread->gc_regs;
   Caml_state->exception_pointer = curr_thread->exception_pointer;
+  Caml_state->async_exception_pointer = curr_thread->async_exception_pointer;
   caml_set_local_arenas(curr_thread->local_arenas);
 #else
   Caml_state->stack_low = curr_thread->stack_low;
@@ -214,6 +221,7 @@ Caml_inline void caml_thread_restore_runtime_state(void)
   Caml_state->extern_sp = curr_thread->sp;
   Caml_state->trapsp = curr_thread->trapsp;
   Caml_state->external_raise = curr_thread->external_raise;
+  Caml_state->external_raise_async = curr_thread->external_raise_async;
 #endif
   Caml_state->local_roots = curr_thread->local_roots;
   Caml_state->backtrace_pos = curr_thread->backtrace_pos;
@@ -334,6 +342,7 @@ static caml_thread_t caml_thread_new_info(void)
   th->top_of_stack = NULL;
   th->last_retaddr = 1;
   th->exception_pointer = NULL;
+  th->async_exception_pointer = NULL;
   th->local_roots = NULL;
   th->local_arenas = NULL;
   th->exit_buf = NULL;
@@ -346,6 +355,7 @@ static caml_thread_t caml_thread_new_info(void)
   th->trapsp = th->stack_high;
   th->local_roots = NULL;
   th->external_raise = NULL;
+  th->external_raise_async = NULL;
 #endif
   th->backtrace_pos = 0;
   th->backtrace_buffer = NULL;
@@ -720,12 +730,12 @@ CAMLprim value caml_thread_yield(value unit)        /* ML */
      our blocking section doesn't contain anything interesting, don't bother
      with saving errno.)
   */
-  caml_raise_if_exception(caml_process_pending_signals_exn());
+  caml_raise_async_if_exception(caml_process_pending_signals_exn());
   caml_thread_save_runtime_state();
   st_thread_yield(&caml_master_lock);
   curr_thread = st_tls_get(thread_descriptor_key);
   caml_thread_restore_runtime_state();
-  caml_raise_if_exception(caml_process_pending_signals_exn());
+  caml_raise_async_if_exception(caml_process_pending_signals_exn());
 
   return Val_unit;
 }

ocaml/runtime/Makefile

@@ -21,15 +21,15 @@ include $(ROOTDIR)/Makefile.common
 
 BYTECODE_C_SOURCES := $(addsuffix .c, \
   interp misc stacks fix_code startup_aux startup_byt freelist major_gc \
-  minor_gc memory alloc roots_byt globroots fail_byt signals \
+  minor_gc memory alloc roots_byt globroots fail fail_byt signals \
   signals_byt printexc backtrace_byt backtrace compare ints eventlog \
   floats str array io extern intern hash sys meta parsing gc_ctrl md5 obj \
   lexing callback debugger weak compact finalise custom dynlink \
   afl $(UNIX_OR_WIN32) bigarray main memprof domain \
   skiplist codefrag)
 
 NATIVE_C_SOURCES := $(addsuffix .c, \
-  startup_aux startup_nat main fail_nat roots_nat signals \
+  startup_aux startup_nat main fail fail_nat roots_nat signals \
   signals_nat misc freelist major_gc minor_gc memory alloc compare ints \
   floats str array io extern intern hash sys parsing gc_ctrl eventlog md5 obj \
   lexing $(UNIX_OR_WIN32) printexc callback weak compact finalise custom \

ocaml/runtime/amd64.S

@@ -573,10 +573,22 @@ FUNCTION(G(caml_start_program))
         movq    C_ARG_1, %r14
     /* Initial entry point is G(caml_program) */
         LEA_VAR(caml_program, %r12)
-    /* Common code for caml_start_program and caml_callback* */
+LBL(caml_start_program_async_exn):
+    /* Register the same exception handler as below for async exceptions */
+        pushq   Caml_state(async_exception_pointer); CFI_ADJUST (8)
+        movq    %rsp, %r13
+        subq    $40, %r13
+        movq    %r13, Caml_state(async_exception_pointer)
+        jmp     LBL(107a)
+    /* Common code for caml_start_program and caml_callback*.
+       If you update the number of stack pushes, update the number 40
+       above. */
 LBL(caml_start_program):
+    /* Save the current async exception pointer */
+        pushq   Caml_state(async_exception_pointer); CFI_ADJUST (8)
+LBL(107a):
+    /* Stack is 16-aligned at this point */
     /* Build a callback link */
-        subq    $8, %rsp; CFI_ADJUST (8)        /* stack 16-aligned */
         pushq   Caml_state(gc_regs); CFI_ADJUST(8)
         pushq   Caml_state(last_return_address); CFI_ADJUST(8)
         pushq   Caml_state(bottom_of_stack); CFI_ADJUST(8)
@@ -600,7 +612,9 @@ LBL(109):
         popq    Caml_state(bottom_of_stack); CFI_ADJUST(-8)
         popq    Caml_state(last_return_address); CFI_ADJUST(-8)
         popq    Caml_state(gc_regs); CFI_ADJUST(-8)
-        addq    $8, %rsp; CFI_ADJUST (-8);
+    /* Restore the asynchronous exception pointer (this will be a no-op
+       if this function was not invoked via [caml_start_program_async_exn]). */
+        popq    Caml_state(async_exception_pointer); CFI_ADJUST(-8)
     /* Restore callee-save registers. */
         POP_CALLEE_SAVE_REGS
     /* Return to caller. */
@@ -696,7 +710,7 @@ ENDFUNCTION(G(caml_raise_exception))
 FUNCTION(G(caml_stack_overflow))
         movq    C_ARG_1, %r14                 /* Caml_state */
         LEA_VAR(caml_exn_Stack_overflow, %rax)
-        movq    Caml_state(exception_pointer), %rsp /* cut the stack */
+        movq    Caml_state(async_exception_pointer), %rsp /* cut the stack */
      /* Recover previous exn handler */
         popq    Caml_state(exception_pointer)
         ret                                   /* jump to handler's code */
@@ -746,6 +760,20 @@ CFI_STARTPROC
 CFI_ENDPROC
 ENDFUNCTION(G(caml_callback3_asm))
 
+/* Variant of caml_callback_asm that installs an async exn trap frame. */
+FUNCTION(G(caml_callback_asm_async_exn))
+CFI_STARTPROC
+    /* Save callee-save registers */
+        PUSH_CALLEE_SAVE_REGS
+    /* Initial loading of arguments */
+        movq    C_ARG_1, %r14      /* Caml_state */
+        movq    C_ARG_2, %rbx      /* closure */
+        movq    0(C_ARG_3), %rax   /* argument */
+        movq    0(%rbx), %r12      /* code pointer */
+        jmp     LBL(caml_start_program_async_exn)
+CFI_ENDPROC
+ENDFUNCTION(G(caml_callback_asm_async_exn))
+
 FUNCTION(G(caml_ml_array_bound_error))
 CFI_STARTPROC
         LEA_VAR(caml_array_bound_error, %rax)

ocaml/runtime/callback.c

@@ -51,10 +51,26 @@ static void init_callback_code(void)
   callback_code_inited = 1;
 }
 
-CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
+static int is_async_exn(value exn)
+{
+  const value *break_exn;
+
+  if (caml_global_data == 0) return 0;
+
+  if (exn == Field(caml_global_data, STACK_OVERFLOW_EXN)) return 1;
+
+  /* "Sys.Break" must match stdlib/sys.mlp. */
+  break_exn = caml_named_value("Sys.Break");
+  if (break_exn != NULL && exn == *break_exn) return 1;
+
+  return 0;
+}
+
+static value caml_callbackN_exn0(value closure, int narg, value args[],
+                                 int catch_async_exns)
 {
   int i;
-  value res;
+  value res, exn;
 
   CAMLassert(narg + 4 <= 256);
 
@@ -69,9 +85,26 @@ CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
   callback_code[3] = narg;
   res = caml_interprete(callback_code, sizeof(callback_code));
   if (Is_exception_result(res)) Caml_state->extern_sp += narg + 4; /* PR#3419 */
+
+  if (!Is_exception_result(res)) return res;
+
+  exn = Extract_exception(res);
+
+  /* When not called from [Sys.with_async_exns], any asynchronous exceptions
+     must be reraised here, rather than being returned as the result of one
+     of the [caml_callback*] functions.  This will cause them to arrive only
+     at any [Sys.with_async_exns] and toplevel uncaught exception handler
+     sites. */
+  if (!catch_async_exns && is_async_exn(exn)) caml_raise_async(exn);
+
   return res;
 }
 
+CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
+{
+  return caml_callbackN_exn0(closure, narg, args, 0);
+}
+
 CAMLexport value caml_callback_exn(value closure, value arg1)
 {
   value arg[1];
@@ -97,6 +130,14 @@ CAMLexport value caml_callback3_exn(value closure,
   return caml_callbackN_exn(closure, 3, arg);
 }
 
+CAMLexport value caml_callback_async_exn(value closure, value arg1)
+{
+  value arg[1];
+  arg[0] = arg1;
+
+  return caml_callbackN_exn0(closure, 1, arg, 1);
+}
+
 #else
 
 /* Native-code callbacks. */
@@ -156,6 +197,14 @@ CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
   CAMLreturn (res);
 }
 
+extern value (caml_callback_asm_async_exn)
+  (caml_domain_state* state, value closure, value* args);
+
+CAMLexport value caml_callback_async_exn(value closure, value arg)
+{
+  return caml_callback_asm_async_exn(Caml_state, closure, &arg);
+}
+
 #endif
 
 /* Exception-propagating variants of the above */

ocaml/runtime/caml/callback.h

@@ -39,6 +39,8 @@ CAMLextern value caml_callback3_exn (value closure,
                                      value arg1, value arg2, value arg3);
 CAMLextern value caml_callbackN_exn (value closure, int narg, value args[]);
 
+CAMLextern value caml_callback_async_exn (value closure, value arg);
+
 CAMLextern const value * caml_named_value (char const * name);
 typedef void (*caml_named_action) (const value*, char *);
 CAMLextern void caml_iterate_named_values(caml_named_action f);

ocaml/runtime/caml/domain_state.tbl

@@ -21,6 +21,9 @@ DOMAIN_STATE(value*, young_limit)
 DOMAIN_STATE(char*, exception_pointer)
 /* Exception pointer that points into the current stack */
 
+DOMAIN_STATE(char*, async_exception_pointer)
+/* Async exception pointer that points into the current stack */
+
 DOMAIN_STATE(void*, young_base)
 DOMAIN_STATE(value*, young_start)
 DOMAIN_STATE(value*, young_end)
@@ -51,6 +54,7 @@ DOMAIN_STATE(value*, extern_sp)
 DOMAIN_STATE(value*, trapsp)
 DOMAIN_STATE(value*, trap_barrier)
 DOMAIN_STATE(struct longjmp_buffer*, external_raise)
+DOMAIN_STATE(struct longjmp_buffer*, external_raise_async)
 DOMAIN_STATE(value, exn_bucket)
 /* See interp.c */
 

ocaml/runtime/caml/fail.h

@@ -63,9 +63,20 @@ struct longjmp_buffer {
 #define caml_external_raise (Caml_state_field(external_raise))
 #define caml_exn_bucket (Caml_state_field(exn_bucket))
 
+CAMLextern value caml_prepare_for_raise(value v, int *turned_into_async_exn);
+CAMLextern value caml_check_async_exn0(value res, const char *msg,
+                                       value stack_overflow_exn);
+
+CAMLextern value caml_check_async_exn(value res, const char *msg);
+
 int caml_is_special_exception(value exn);
 
 CAMLextern value caml_raise_if_exception(value res);
+CAMLextern value caml_raise_async_if_exception(value res);
+
+CAMLnoreturn_start
+CAMLextern void caml_raise_async(value res)
+CAMLnoreturn_end;
 
 #endif /* CAML_INTERNALS */
 
@@ -113,6 +124,10 @@ CAMLnoreturn_start
 CAMLextern void caml_raise_out_of_memory (void)
 CAMLnoreturn_end;
 
+CAMLnoreturn_start
+CAMLextern void caml_raise_out_of_memory_fatal (void)
+CAMLnoreturn_end;
+
 CAMLnoreturn_start
 CAMLextern void caml_raise_stack_overflow (void)
 CAMLnoreturn_end;

ocaml/runtime/caml/printexc.h

@@ -28,6 +28,8 @@ extern "C" {
 CAMLextern char * caml_format_exception (value);
 #ifdef CAML_INTERNALS
 CAMLnoreturn_start void caml_fatal_uncaught_exception (value) CAMLnoreturn_end;
+CAMLnoreturn_start void caml_fatal_uncaught_exception_with_message
+  (value, const char *) CAMLnoreturn_end;
 #endif /* CAML_INTERNALS */
 
 #ifdef __cplusplus

ocaml/runtime/caml/signals.h

@@ -25,6 +25,7 @@
 #endif
 #include "misc.h"
 #include "mlvalues.h"
+#include "fail.h"
 
 #ifdef __cplusplus
 extern "C" {

ocaml/runtime/caml/stack.h

@@ -141,6 +141,7 @@ extern intnat * caml_frametable[];
 #define caml_last_return_address (Caml_state_field(last_return_address))
 #define caml_gc_regs (Caml_state_field(gc_regs))
 #define caml_exception_pointer (Caml_state_field(exception_pointer))
+#define caml_async_exception_pointer (Caml_state_field(async_exception_pointer))
 
 CAMLextern frame_descr * caml_next_frame_descriptor(uintnat * pc, char ** sp);
 

ocaml/runtime/debugger.c

@@ -274,17 +274,21 @@ static void putval(struct channel *chan, value val)
 static void safe_output_value(struct channel *chan, value val)
 {
   struct longjmp_buffer raise_buf, * saved_external_raise;
+  struct longjmp_buffer *saved_external_raise_async;
 
   /* Catch exceptions raised by [caml_output_val] */
   saved_external_raise = Caml_state->external_raise;
+  saved_external_raise_async = Caml_state->external_raise_async;
   if (sigsetjmp(raise_buf.buf, 0) == 0) {
     Caml_state->external_raise = &raise_buf;
+    Caml_state->external_raise_async = &raise_buf;
     caml_output_val(chan, val, marshal_flags);
   } else {
     /* Send wrong magic number, will cause [caml_input_value] to fail */
     caml_really_putblock(chan, "\000\000\000\000", 4);
   }
   Caml_state->external_raise = saved_external_raise;
+  Caml_state->external_raise_async = saved_external_raise_async;
 }
 
 static void save_instruction(code_t pc)

ocaml/runtime/domain.c

@@ -54,6 +54,7 @@ void caml_init_domain ()
   Caml_state->trapsp = NULL;
   Caml_state->trap_barrier = NULL;
   Caml_state->external_raise = NULL;
+  Caml_state->external_raise_async = NULL;
   Caml_state->exn_bucket = Val_unit;
 
   Caml_state->local_arenas = NULL;