Fix semantics

Author: mshinwell

ocaml/runtime/amd64.S

@@ -727,6 +727,8 @@ CFI_STARTPROC
         movq    C_ARG_2, %rbx      /* closure */
         movq    0(C_ARG_3), %rax   /* argument */
         movq    0(%rbx), %r12      /* code pointer */
+        cmp     $1, C_ARG_4
+        je      LBL(caml_start_program_async_exn)
         jmp     LBL(caml_start_program)
 CFI_ENDPROC
 ENDFUNCTION(G(caml_callback_asm))
@@ -741,6 +743,8 @@ CFI_STARTPROC
         movq    0(C_ARG_3), %rax   /* first argument */
         movq    8(C_ARG_3), %rbx   /* second argument */
         LEA_VAR(caml_apply2, %r12) /* code pointer */
+        cmp     $1, C_ARG_4
+        je      LBL(caml_start_program_async_exn)
         jmp     LBL(caml_start_program)
 CFI_ENDPROC
 ENDFUNCTION(G(caml_callback2_asm))
@@ -756,24 +760,12 @@ CFI_STARTPROC
         movq    C_ARG_2, %rsi      /* closure */
         movq    16(C_ARG_3), %rdi  /* third argument */
         LEA_VAR(caml_apply3, %r12) /* code pointer */
+        cmp     $1, C_ARG_4
+        je      LBL(caml_start_program_async_exn)
         jmp     LBL(caml_start_program)
 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,26 +51,13 @@ static void init_callback_code(void)
   callback_code_inited = 1;
 }
 
-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;
-}
+/* Functions that return all exceptions, including asynchronous ones */
 
 static value caml_callbackN_exn0(value closure, int narg, value args[],
-                                 int catch_async_exns)
+                                 int *returning_async_exn)
 {
   int i;
-  value res, exn;
+  value res;
 
   CAMLassert(narg + 4 <= 256);
 
@@ -83,90 +70,119 @@ static value caml_callbackN_exn0(value closure, int narg, value args[],
   if (!callback_code_inited) init_callback_code();
   callback_code[1] = narg + 3;
   callback_code[3] = narg;
-  res = caml_interprete(callback_code, sizeof(callback_code));
+  res = caml_interprete(callback_code, sizeof(callback_code),
+    returning_async_exn);
   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);
+  return caml_callbackN_exn0(closure, narg, args, NULL);
 }
 
 CAMLexport value caml_callback_exn(value closure, value arg1)
 {
   value arg[1];
   arg[0] = arg1;
-  return caml_callbackN_exn(closure, 1, arg);
+  return caml_callbackN_exn0(closure, 1, arg, NULL);
 }
 
 CAMLexport value caml_callback2_exn(value closure, value arg1, value arg2)
 {
   value arg[2];
   arg[0] = arg1;
   arg[1] = arg2;
-  return caml_callbackN_exn(closure, 2, arg);
+  return caml_callbackN_exn0(closure, 2, arg, NULL);
 }
 
 CAMLexport value caml_callback3_exn(value closure,
-                               value arg1, value arg2, value arg3)
+                                    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_exn0(closure, 3, arg, NULL);
+}
+
+/* Functions that propagate all exceptions, with any asynchronous exceptions
+   also being propagated asynchronously. */
+
+CAMLexport value caml_callbackN(value closure, int narg, value args[])
+{
+  value res;
+  int returning_async_exn;
+
+  res = caml_callbackN_exn0(closure, narg, args, &returning_async_exn);
+  if (Is_exception_result(res)) {
+    value exn = Extract_exception(res);
+    if (returning_async_exn) caml_raise_async(exn);
+    else caml_raise(exn);
+  }
+
+  return res;
 }
 
-CAMLexport value caml_callback_async_exn(value closure, value arg1)
+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);
+}
 
-  return caml_callbackN_exn0(closure, 1, arg, 1);
+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(closure, 3, arg);
 }
 
 #else
 
 /* Native-code callbacks. */
 
 typedef value (callback_stub)(caml_domain_state* state, value closure,
-                              value* args);
+                              value* args, int catch_async_exns);
 
 callback_stub caml_callback_asm, caml_callback2_asm, caml_callback3_asm;
 
-CAMLexport value caml_callback_exn(value closure, value arg)
+/* First we build functions that allow control as to whether an asynchronous
+   exception trap frame is installed. */
+
+static value callback(value closure, value arg, int catch_async_exns)
 {
-  return caml_callback_asm(Caml_state, closure, &arg);
+  return caml_callback_asm(Caml_state, closure, &arg, catch_async_exns);
 }
 
-CAMLexport value caml_callback2_exn(value closure, value arg1, value arg2)
+static value callback2(value closure, value arg1, value arg2,
+                       int catch_async_exns)
 {
   value args[] = {arg1, arg2};
-  return caml_callback2_asm(Caml_state, closure, args);
+  return caml_callback2_asm(Caml_state, closure, args, catch_async_exns);
 }
 
-CAMLexport value caml_callback3_exn(value closure,
-                                    value arg1, value arg2, value arg3)
+static value callback3(value closure, value arg1, value arg2, value arg3,
+                       int catch_async_exns)
 {
   value args[] = {arg1, arg2, arg3};
-  return caml_callback3_asm(Caml_state, closure, args);
+  return caml_callback3_asm(Caml_state, closure, args, catch_async_exns);
 }
 
-
-CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
+static value callbackN(value closure, int narg, value args[],
+                       int catch_async_exns)
 {
   CAMLparam1 (closure);
   CAMLxparamN (args, narg);
@@ -178,17 +194,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], catch_async_exns);
       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], catch_async_exns);
       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], catch_async_exns);
       if (Is_exception_result(res)) CAMLreturn (res);
       i += 3;
       break;
@@ -197,39 +213,65 @@ 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);
+/* Functions that return all exceptions, including asynchronous ones */
 
-CAMLexport value caml_callback_async_exn(value closure, value arg)
+CAMLexport value caml_callback_exn(value closure, value arg)
 {
-  return caml_callback_asm_async_exn(Caml_state, closure, &arg);
+  return callback(closure, arg, 1);
 }
 
-#endif
+CAMLexport value caml_callback2_exn(value closure, value arg1, value arg2)
+{
+  return callback2(closure, arg1, arg2, 1);
+}
+
+CAMLexport value caml_callback3_exn(value closure,
+                                    value arg1, value arg2, value arg3)
+{
+  return callback3(closure, arg1, arg2, arg3, 1);
+}
+
+CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
+{
+  return callbackN(closure, narg, args, 1);
+}
 
-/* Exception-propagating variants of the above */
+/* Functions that propagate all exceptions, with any asynchronous exceptions
+   also being propagated asynchronously.  In these cases we do not install
+   an asynchronous exception trap frame, avoiding any need to perform
+   comparisons on exception values to determine if they represent asynchronous
+   exceptions (which would be problematic for [Sys.Break], thus likely
+   necessitating these being wrapped in another constructor). */
 
-CAMLexport value caml_callback (value closure, value arg)
+static value raise_if_exception(value res)
 {
-  return caml_raise_if_exception(caml_callback_exn(closure, arg));
+  if (Is_exception_result(res)) caml_raise(Extract_exception(res));
+  return res;
 }
 
-CAMLexport value caml_callback2 (value closure, value arg1, value arg2)
+CAMLexport value caml_callback(value closure, value arg)
 {
-  return caml_raise_if_exception(caml_callback2_exn(closure, arg1, arg2));
+  return raise_if_exception(callback(closure, arg, 0));
 }
 
-CAMLexport value caml_callback3 (value closure, value arg1, value arg2,
-                                 value arg3)
+CAMLexport value caml_callback2(value closure, value arg1, value arg2)
 {
-  return caml_raise_if_exception(caml_callback3_exn(closure, arg1, arg2, arg3));
+  return raise_if_exception(callback2(closure, arg1, arg2, 0));
+}
+
+CAMLexport value caml_callback3(value closure,
+                                value arg1, value arg2, value arg3)
+{
+  return raise_if_exception(callback3(closure, arg1, arg2, arg3, 0));
 }
 
 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, 0));
 }
 
+#endif
+
 /* Naming of OCaml values */
 
 struct named_value {

ocaml/runtime/caml/callback.h

@@ -39,8 +39,6 @@ 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/fail.h

@@ -64,14 +64,19 @@ struct longjmp_buffer {
 #define caml_exn_bucket (Caml_state_field(exn_bucket))
 
 CAMLextern value caml_prepare_for_raise(value v, int *turned_into_async_exn);
+
+/* For internal use of fail_byt.c and fail_nat.c only. */
 CAMLextern value caml_check_async_exn0(value res, const char *msg,
                                        value stack_overflow_exn);
 
+/* This function must only be used in a context where it is certain that
+   occurrences of [Sys.Break] and [Stack_overflow] must be raised as
+   asynchronous exceptions (for example in a finaliser, signal handler or
+   memprof callback). */
 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

ocaml/runtime/caml/interp.h

@@ -24,7 +24,8 @@
 #include "mlvalues.h"
 
 /* interpret a bytecode */
-value caml_interprete (code_t prog, asize_t prog_size);
+value caml_interprete (code_t prog, asize_t prog_size,
+  int *returning_async_exn);
 
 #endif /* CAML_INTERNALS */
 

ocaml/runtime/fail.c

@@ -54,6 +54,13 @@ CAMLexport value caml_prepare_for_raise(value v, int *turned_into_async_exn)
   return v;
 }
 
+CAMLexport value caml_raise_async_if_exception(value result)
+{
+  if (Is_exception_result(result)) caml_raise_async(Extract_exception(result));
+
+  return result;
+}
+
 CAMLexport value caml_check_async_exn0(value res, const char *msg,
                                        value stack_overflow_exn)
 {