Improve the semantics of asynchronous exceptions (new simpler version)

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,14 @@ 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(),
+                                "signal handler");
   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(),
+                                "signal handler");
 
   return Val_unit;
 }

ocaml/runtime/amd64.S

@@ -576,7 +576,8 @@ FUNCTION(G(caml_start_program))
     /* Common code for caml_start_program and caml_callback* */
 LBL(caml_start_program):
     /* Build a callback link */
-        subq    $8, %rsp; CFI_ADJUST (8)        /* stack 16-aligned */
+        pushq   Caml_state(async_exception_pointer); CFI_ADJUST (8)
+        /* Stack is 16-aligned at this point */
         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)
@@ -587,6 +588,7 @@ LBL(caml_start_program):
         pushq   %r13; CFI_ADJUST(8)
         pushq   Caml_state(exception_pointer); CFI_ADJUST(8)
         movq    %rsp, Caml_state(exception_pointer)
+        movq    %rsp, Caml_state(async_exception_pointer)
     /* Call the OCaml code */
         call    *%r12
 LBL(107):
@@ -600,7 +602,7 @@ 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);
+        popq    Caml_state(async_exception_pointer); CFI_ADJUST(-8)
     /* Restore callee-save registers. */
         POP_CALLEE_SAVE_REGS
     /* Return to caller. */
@@ -696,7 +698,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 */

ocaml/runtime/callback.c

@@ -24,6 +24,19 @@
 #include "caml/memory.h"
 #include "caml/mlvalues.h"
 
+static value raise_if_exception(value res)
+{
+  if (Is_exception_result(res)) {
+    if (Caml_state->raising_async_exn) {
+      Caml_state->raising_async_exn = 0;
+      caml_raise_async(Extract_exception(res));
+    } else {
+      caml_raise(Extract_exception(res));
+    }
+  }
+  return res;
+}
+
 #ifndef NATIVE_CODE
 
 /* Bytecode callbacks */
@@ -51,7 +64,9 @@ static void init_callback_code(void)
   callback_code_inited = 1;
 }
 
-CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
+/* Functions that return all exceptions, including asynchronous ones */
+
+static value caml_callbackN_exn0(value closure, int narg, value args[])
 {
   int i;
   value res;
@@ -72,29 +87,75 @@ CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
   return res;
 }
 
+CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
+{
+  value res = caml_callbackN_exn0(closure, narg, args);
+  Caml_state->raising_async_exn = 0;
+  return res;
+}
+
 CAMLexport value caml_callback_exn(value closure, value arg1)
 {
-  value arg[1];
+  value res, arg[1];
   arg[0] = arg1;
-  return caml_callbackN_exn(closure, 1, arg);
+  res = caml_callbackN_exn0(closure, 1, arg);
+  Caml_state->raising_async_exn = 0;
+  return res;
 }
 
 CAMLexport value caml_callback2_exn(value closure, value arg1, value arg2)
 {
-  value arg[2];
+  value res, arg[2];
   arg[0] = arg1;
   arg[1] = arg2;
-  return caml_callbackN_exn(closure, 2, arg);
+  res = caml_callbackN_exn0(closure, 2, arg);
+  Caml_state->raising_async_exn = 0;
+  return res;
 }
 
 CAMLexport value caml_callback3_exn(value closure,
-                               value arg1, value arg2, value arg3)
+                                    value arg1, value arg2, value arg3)
+{
+  value res, arg[3];
+  arg[0] = arg1;
+  arg[1] = arg2;
+  arg[2] = arg3;
+  res = caml_callbackN_exn0(closure, 3, arg);
+  Caml_state->raising_async_exn = 0;
+  return res;
+}
+
+/* Functions that propagate all exceptions, with any asynchronous exceptions
+   also being propagated asynchronously. */
+
+CAMLexport value caml_callbackN(value closure, int narg, value args[])
+{
+  return raise_if_exception(caml_callbackN_exn0(closure, narg, args));
+}
+
+CAMLexport value caml_callback(value closure, value arg1)
+{
+  value arg[1];
+  arg[0] = arg1;
+  return caml_callbackN(closure, 1, arg);
+}
+
+CAMLexport value caml_callback2(value closure, value arg1, value arg2)
+{
+  value arg[2];
+  arg[0] = arg1;
+  arg[1] = arg2;
+  return caml_callbackN(closure, 2, arg);
+}
+
+CAMLexport value caml_callback3(value closure,
+                                value arg1, value arg2, value arg3)
 {
   value arg[3];
   arg[0] = arg1;
   arg[1] = arg2;
   arg[2] = arg3;
-  return caml_callbackN_exn(closure, 3, arg);
+  return caml_callbackN(closure, 3, arg);
 }
 
 #else
@@ -106,26 +167,24 @@ typedef value (callback_stub)(caml_domain_state* state, value closure,
 
 callback_stub caml_callback_asm, caml_callback2_asm, caml_callback3_asm;
 
-CAMLexport value caml_callback_exn(value closure, value arg)
+static value callback(value closure, value arg)
 {
   return caml_callback_asm(Caml_state, closure, &arg);
 }
 
-CAMLexport value caml_callback2_exn(value closure, value arg1, value arg2)
+static value callback2(value closure, value arg1, value arg2)
 {
   value args[] = {arg1, arg2};
   return caml_callback2_asm(Caml_state, closure, args);
 }
 
-CAMLexport value caml_callback3_exn(value closure,
-                                    value arg1, value arg2, value arg3)
+static value callback3(value closure, value arg1, value arg2, value arg3)
 {
   value args[] = {arg1, arg2, arg3};
   return caml_callback3_asm(Caml_state, closure, args);
 }
 
-
-CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
+static value callbackN(value closure, int narg, value args[])
 {
   CAMLparam1 (closure);
   CAMLxparamN (args, narg);
@@ -137,17 +196,17 @@ CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
     /* Pass as many arguments as possible */
     switch (narg - i) {
     case 1:
-      res = caml_callback_exn(res, args[i]);
+      res = callback(res, args[i]);
       if (Is_exception_result(res)) CAMLreturn (res);
       i += 1;
       break;
     case 2:
-      res = caml_callback2_exn(res, args[i], args[i + 1]);
+      res = callback2(res, args[i], args[i + 1]);
       if (Is_exception_result(res)) CAMLreturn (res);
       i += 2;
       break;
     default:
-      res = caml_callback3_exn(res, args[i], args[i + 1], args[i + 2]);
+      res = callback3(res, args[i], args[i + 1], args[i + 2]);
       if (Is_exception_result(res)) CAMLreturn (res);
       i += 3;
       break;
@@ -156,31 +215,76 @@ CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
   CAMLreturn (res);
 }
 
-#endif
+/* Functions that return all exceptions, including asynchronous ones */
+
+CAMLexport value caml_callback_exn(value closure, value arg)
+{
+  value res = callback(closure, arg);
+  Caml_state->raising_async_exn = 0;
+  return res;
+}
+
+CAMLexport value caml_callback2_exn(value closure, value arg1, value arg2)
+{
+  value res = callback2(closure, arg1, arg2);
+  Caml_state->raising_async_exn = 0;
+  return res;
+}
 
-/* Exception-propagating variants of the above */
+CAMLexport value caml_callback3_exn(value closure, value arg1, value arg2,
+                                    value arg3)
+{
+  value res = callback3(closure, arg1, arg2, arg3);
+  Caml_state->raising_async_exn = 0;
+  return res;
+}
+
+CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
+{
+  value res = callbackN(closure, narg, args);
+  Caml_state->raising_async_exn = 0;
+  return res;
+}
+
+/* Functions that propagate all exceptions, with any asynchronous exceptions
+   also being propagated asynchronously. */
 
 CAMLexport value caml_callback (value closure, value arg)
 {
-  return caml_raise_if_exception(caml_callback_exn(closure, arg));
+  return raise_if_exception(callback(closure, arg));
 }
 
 CAMLexport value caml_callback2 (value closure, value arg1, value arg2)
 {
-  return caml_raise_if_exception(caml_callback2_exn(closure, arg1, arg2));
+  return raise_if_exception(callback2(closure, arg1, arg2));
 }
 
 CAMLexport value caml_callback3 (value closure, value arg1, value arg2,
                                  value arg3)
 {
-  return caml_raise_if_exception(caml_callback3_exn(closure, arg1, arg2, arg3));
+  return raise_if_exception(callback3(closure, arg1, arg2, arg3));
 }
 
 CAMLexport value caml_callbackN (value closure, int narg, value args[])
 {
-  return caml_raise_if_exception(caml_callbackN_exn(closure, narg, args));
+  return raise_if_exception(callbackN(closure, narg, args));
 }
 
+#endif
+
+CAMLprim value caml_with_async_exns(value body_callback)
+{
+  value res;
+  res = caml_callback_exn(body_callback, Val_unit);
+
+  /* raised as a normal exn, even if it was asynchronous */
+  if (Is_exception_result(res))
+    caml_raise(Extract_exception(res));
+
+  return res;
+}
+
+
 /* Naming of OCaml values */
 
 struct named_value {