diff --git a/backend/cfg/cfg.ml b/backend/cfg/cfg.ml index 39b683af355..1b826a34ea7 100644 --- a/backend/cfg/cfg.ml +++ b/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 diff --git a/backend/mach.ml b/backend/mach.ml index 1ce415134ac..1b8be679b6b 100644 --- a/backend/mach.ml +++ b/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 = diff --git a/ocaml/otherlibs/systhreads/st_stubs.c b/ocaml/otherlibs/systhreads/st_stubs.c index 73d86789c5c..aaf47f3cce4 100644 --- a/ocaml/otherlibs/systhreads/st_stubs.c +++ b/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; } diff --git a/ocaml/runtime/amd64.S b/ocaml/runtime/amd64.S index 117dc5b0c61..ca1d18b0939 100644 --- a/ocaml/runtime/amd64.S +++ b/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 */ diff --git a/ocaml/runtime/callback.c b/ocaml/runtime/callback.c index 347e3a9d1f2..5205e2dd8ab 100644 --- a/ocaml/runtime/callback.c +++ b/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 { diff --git a/ocaml/runtime/caml/domain_state.tbl b/ocaml/runtime/caml/domain_state.tbl index 895298da66d..a560becf44a 100644 --- a/ocaml/runtime/caml/domain_state.tbl +++ b/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 */ @@ -60,6 +64,9 @@ DOMAIN_STATE(uintnat, last_return_address) DOMAIN_STATE(value*, gc_regs) /* See roots_nat.c */ +DOMAIN_STATE(intnat, raising_async_exn) +/* Set when an async exn is raised, cleared when caught */ + DOMAIN_STATE(intnat, backtrace_active) DOMAIN_STATE(intnat, backtrace_pos) DOMAIN_STATE(backtrace_slot*, backtrace_buffer) diff --git a/ocaml/runtime/caml/fail.h b/ocaml/runtime/caml/fail.h index 677b1f724f1..17a0413df10 100644 --- a/ocaml/runtime/caml/fail.h +++ b/ocaml/runtime/caml/fail.h @@ -65,7 +65,11 @@ struct longjmp_buffer { int caml_is_special_exception(value exn); -CAMLextern value caml_raise_if_exception(value res); +CAMLextern void caml_raise_async_if_exception(value res, const char* where); + +CAMLnoreturn_start +CAMLextern void caml_raise_async(value res) +CAMLnoreturn_end; #endif /* CAML_INTERNALS */ diff --git a/ocaml/runtime/caml/misc.h b/ocaml/runtime/caml/misc.h index 2e7ca7077a8..b1989725d00 100644 --- a/ocaml/runtime/caml/misc.h +++ b/ocaml/runtime/caml/misc.h @@ -223,6 +223,10 @@ CAMLextern void caml_fatal_error (char *, ...) #endif CAMLnoreturn_end; +CAMLnoreturn_start +CAMLextern void caml_fatal_out_of_memory (void) +CAMLnoreturn_end; + /* Detection of available C built-in functions, the Clang way. */ #ifdef __has_builtin diff --git a/ocaml/runtime/caml/printexc.h b/ocaml/runtime/caml/printexc.h index 8ae788b139e..a7574058c48 100644 --- a/ocaml/runtime/caml/printexc.h +++ b/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 diff --git a/ocaml/runtime/caml/signals.h b/ocaml/runtime/caml/signals.h index 285dbd7febd..1cd96de0e41 100644 --- a/ocaml/runtime/caml/signals.h +++ b/ocaml/runtime/caml/signals.h @@ -25,6 +25,7 @@ #endif #include "misc.h" #include "mlvalues.h" +#include "fail.h" #ifdef __cplusplus extern "C" { diff --git a/ocaml/runtime/caml/stack.h b/ocaml/runtime/caml/stack.h index 74cd512acf3..4dab8186cb5 100644 --- a/ocaml/runtime/caml/stack.h +++ b/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); diff --git a/ocaml/runtime/debugger.c b/ocaml/runtime/debugger.c index 53d85c943f0..ec8b3db9d1b 100644 --- a/ocaml/runtime/debugger.c +++ b/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) diff --git a/ocaml/runtime/domain.c b/ocaml/runtime/domain.c index 7ab701436e7..f6b9ce8cdb8 100644 --- a/ocaml/runtime/domain.c +++ b/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; @@ -77,6 +78,7 @@ void caml_init_domain () Caml_state->stat_forced_major_collections = 0; Caml_state->stat_heap_chunks = 0; + Caml_state->raising_async_exn = 0; Caml_state->backtrace_active = 0; Caml_state->backtrace_pos = 0; Caml_state->backtrace_buffer = NULL; diff --git a/ocaml/runtime/fail_byt.c b/ocaml/runtime/fail_byt.c index 0d0d2b05afa..7e0c0d807dd 100644 --- a/ocaml/runtime/fail_byt.c +++ b/ocaml/runtime/fail_byt.c @@ -36,16 +36,26 @@ CAMLexport void caml_raise(value v) Unlock_exn(); CAMLassert(!Is_exception_result(v)); - // avoid calling caml_raise recursively - v = caml_process_pending_actions_with_root_exn(v); - if (Is_exception_result(v)) - v = Extract_exception(v); + v = caml_process_pending_actions_with_root(v); Caml_state->exn_bucket = v; if (Caml_state->external_raise == NULL) caml_fatal_uncaught_exception(v); siglongjmp(Caml_state->external_raise->buf, 1); } +CAMLexport void caml_raise_async(value v) +{ + Unlock_exn(); + CAMLassert(!Is_exception_result(v)); + + if (Caml_state->external_raise_async == NULL) + caml_fatal_uncaught_exception(v); + + Caml_state->exn_bucket = v; + Caml_state->raising_async_exn = 1; + siglongjmp(Caml_state->external_raise_async->buf, 1); +} + CAMLexport void caml_raise_constant(value tag) { caml_raise(tag); @@ -164,7 +174,7 @@ CAMLexport void caml_raise_out_of_memory(void) CAMLexport void caml_raise_stack_overflow(void) { check_global_data("Stack_overflow"); - caml_raise_constant(Field(caml_global_data, STACK_OVERFLOW_EXN)); + caml_raise_async(Field(caml_global_data, STACK_OVERFLOW_EXN)); } CAMLexport void caml_raise_sys_error(value msg) @@ -197,12 +207,6 @@ CAMLexport void caml_raise_sys_blocked_io(void) caml_raise_constant(Field(caml_global_data, SYS_BLOCKED_IO)); } -CAMLexport value caml_raise_if_exception(value res) -{ - if (Is_exception_result(res)) caml_raise(Extract_exception(res)); - return res; -} - int caml_is_special_exception(value exn) { /* this function is only used in caml_format_exception to produce a more readable textual representation of some exceptions. It is diff --git a/ocaml/runtime/fail_nat.c b/ocaml/runtime/fail_nat.c index 013171cb726..2763783889d 100644 --- a/ocaml/runtime/fail_nat.c +++ b/ocaml/runtime/fail_nat.c @@ -20,6 +20,7 @@ #include #include #include "caml/alloc.h" +#include "caml/callback.h" #include "caml/domain.h" #include "caml/fail.h" #include "caml/io.h" @@ -56,27 +57,49 @@ CAMLnoreturn_start extern void caml_raise_exception (caml_domain_state* state, value bucket) CAMLnoreturn_end; -/* Used by the stack overflow handler -> deactivate ASAN (see - segv_handler in signals_nat.c). */ -CAMLno_asan +static void unwind_local_roots(char *exception_pointer) +{ + while (Caml_state->local_roots != NULL && + (char *)Caml_state->local_roots < exception_pointer) + { + Caml_state->local_roots = Caml_state->local_roots->next; + } +} + void caml_raise(value v) { Unlock_exn(); CAMLassert(!Is_exception_result(v)); - // avoid calling caml_raise recursively - v = caml_process_pending_actions_with_root_exn(v); - if (Is_exception_result(v)) - v = Extract_exception(v); + /* Run callbacks here, so that a signal handler that arrived during + a blocking call has a chance to interrupt the raising of EINTR */ + v = caml_process_pending_actions_with_root(v); if (Caml_state->exception_pointer == NULL) caml_fatal_uncaught_exception(v); - while (Caml_state->local_roots != NULL && - (char *) Caml_state->local_roots < Caml_state->exception_pointer) { - Caml_state->local_roots = Caml_state->local_roots->next; - } + unwind_local_roots(Caml_state->exception_pointer); + caml_raise_exception(Caml_state, v); +} + +/* Used by the stack overflow handler -> deactivate ASAN (see + segv_handler in signals_nat.c). */ +CAMLno_asan void caml_raise_async(value v) +{ + Unlock_exn(); + CAMLassert(!Is_exception_result(v)); + + /* Do not run callbacks here: we are already raising an async exn, + so no need to check for another one, and avoiding polling here + removes the risk of recursion in caml_raise */ + + if (Caml_state->async_exception_pointer == NULL) + caml_fatal_uncaught_exception(v); + + unwind_local_roots(Caml_state->async_exception_pointer); + Caml_state->exception_pointer = Caml_state->async_exception_pointer; + Caml_state->raising_async_exn = 1; caml_raise_exception(Caml_state, v); } @@ -145,6 +168,7 @@ void caml_invalid_argument_value (value msg) void caml_raise_out_of_memory(void) { + /* Note that this is not an async exn. */ caml_raise_constant((value) caml_exn_Out_of_memory); } @@ -153,7 +177,7 @@ void caml_raise_out_of_memory(void) CAMLno_asan void caml_raise_stack_overflow(void) { - caml_raise_constant((value) caml_exn_Stack_overflow); + caml_raise_async((value) caml_exn_Stack_overflow); } void caml_raise_sys_error(value msg) @@ -181,12 +205,6 @@ void caml_raise_sys_blocked_io(void) caml_raise_constant((value) caml_exn_Sys_blocked_io); } -CAMLexport value caml_raise_if_exception(value res) -{ - if (Is_exception_result(res)) caml_raise(Extract_exception(res)); - return res; -} - /* We use a pre-allocated exception because we can't do a GC before the exception is raised (lack of stack descriptors for the ccall to [caml_array_bound_error]). */ diff --git a/ocaml/runtime/gc_ctrl.c b/ocaml/runtime/gc_ctrl.c index 4d51cb42442..e50dcd2496c 100644 --- a/ocaml/runtime/gc_ctrl.c +++ b/ocaml/runtime/gc_ctrl.c @@ -539,7 +539,7 @@ CAMLprim value caml_gc_minor(value v) // call the gc and call finalisers exn = caml_process_pending_actions_exn(); CAML_EV_END(EV_EXPLICIT_GC_MINOR); - caml_raise_if_exception(exn); + caml_raise_async_if_exception(exn, ""); return Val_unit; } @@ -571,7 +571,7 @@ CAMLprim value caml_gc_major(value v) // call finalisers exn = caml_process_pending_actions_exn(); CAML_EV_END(EV_EXPLICIT_GC_MAJOR); - caml_raise_if_exception(exn); + caml_raise_async_if_exception(exn, ""); return Val_unit; } @@ -596,7 +596,7 @@ CAMLprim value caml_gc_full_major(value v) cleanup: CAML_EV_END(EV_EXPLICIT_GC_FULL_MAJOR); - caml_raise_if_exception(exn); + caml_raise_async_if_exception(exn, ""); return Val_unit; } @@ -617,7 +617,7 @@ CAMLprim value caml_gc_major_slice (value v) caml_major_collection_slice (Long_val (v)); } CAML_EV_END(EV_EXPLICIT_GC_MAJOR_SLICE); - caml_raise_if_exception (exn); + caml_raise_async_if_exception(exn, ""); return Val_long (0); } @@ -643,7 +643,7 @@ CAMLprim value caml_gc_compaction(value v) cleanup: CAML_EV_END(EV_EXPLICIT_GC_COMPACT); - caml_raise_if_exception(exn); + caml_raise_async_if_exception(exn, ""); return Val_unit; } diff --git a/ocaml/runtime/i386.S b/ocaml/runtime/i386.S index 73ba8213a96..2f919356d44 100644 --- a/ocaml/runtime/i386.S +++ b/ocaml/runtime/i386.S @@ -275,6 +275,8 @@ FUNCTION(caml_start_program) /* Common code for caml_start_program and caml_callback* */ LBL(106): movl G(Caml_state), %edi + ALIGN_STACK(12) + pushl CAML_STATE(async_exception_pointer, %edi); CFI_ADJUST(4) /* Build a callback link */ pushl CAML_STATE(gc_regs, %edi); CFI_ADJUST(4) pushl CAML_STATE(last_return_address, %edi); CFI_ADJUST(4) @@ -285,6 +287,7 @@ LBL(106): ALIGN_STACK(8) pushl CAML_STATE(exception_pointer, %edi); CFI_ADJUST(4) movl %esp, CAML_STATE(exception_pointer, %edi) + movl %esp, CAML_STATE(async_exception_pointer, %edi) /* Call the OCaml code */ call *%esi LBL(107): @@ -298,6 +301,8 @@ LBL(109): popl CAML_STATE(bottom_of_stack, %edi); CFI_ADJUST(-4) popl CAML_STATE(last_return_address, %edi); CFI_ADJUST(-4) popl CAML_STATE(gc_regs, %edi); CFI_ADJUST(-4) + popl CAML_STATE(async_exception_pointer, %edi); CFI_ADJUST(-4) + UNDO_ALIGN_STACK(12) /* Restore callee-save registers. */ popl %ebp; CFI_ADJUST(-4) popl %edi; CFI_ADJUST(-4) diff --git a/ocaml/runtime/interp.c b/ocaml/runtime/interp.c index a59811c87d8..6fac4212765 100644 --- a/ocaml/runtime/interp.c +++ b/ocaml/runtime/interp.c @@ -232,11 +232,14 @@ value caml_interprete(code_t prog, asize_t prog_size) value env; intnat extra_args; struct longjmp_buffer * initial_external_raise; + struct longjmp_buffer * initial_external_raise_async; intnat initial_sp_offset; - /* volatile ensures that initial_local_roots - will keep correct value across longjmp */ + intnat initial_trapsp_offset; + /* volatile ensures that initial_local_roots will keep correct values across + longjmp. The other "initial_..." variables don't need "volatile" + because they aren't changed between the setjmp and any longjmp. */ struct caml__roots_block * volatile initial_local_roots; - struct longjmp_buffer raise_buf; + struct longjmp_buffer raise_buf, raise_async_buf; #ifndef THREADED_CODE opcode_t curr_instr; #endif @@ -262,6 +265,10 @@ value caml_interprete(code_t prog, asize_t prog_size) initial_sp_offset = (char *) Caml_state->stack_high - (char *) Caml_state->extern_sp; initial_external_raise = Caml_state->external_raise; + initial_external_raise_async = Caml_state->external_raise_async; + initial_trapsp_offset = + (char *) Caml_state->stack_high - (char *) Caml_state->trapsp; + caml_callback_depth++; if (sigsetjmp(raise_buf.buf, 0)) { @@ -280,6 +287,29 @@ value caml_interprete(code_t prog, asize_t prog_size) } Caml_state->external_raise = &raise_buf; + if (sigsetjmp(raise_async_buf.buf, 0)) { + Caml_state->local_roots = initial_local_roots; + sp = Caml_state->extern_sp; + accu = Caml_state->exn_bucket; + + Check_trap_barrier; + if (Caml_state->backtrace_active) { + caml_stash_backtrace(accu, sp, 0); + } + + /* Skip any exception handlers installed by this invocation of + [caml_interprete]. This will cause the [raise_notrace] code below to + return asynchronous exceptions to the caller, typically in + [caml_callbackN_exn0]. When that function reraises such an exception + then [Caml_state->trapsp] will correctly be pointing at the most + recent prior trap. */ + Caml_state->trapsp = (value *) ((char *) Caml_state->stack_high + - initial_trapsp_offset); + + goto raise_notrace; + } + Caml_state->external_raise_async = &raise_async_buf; + sp = Caml_state->extern_sp; pc = prog; extra_args = 0; @@ -889,6 +919,7 @@ value caml_interprete(code_t prog, asize_t prog_size) if ((char *) Caml_state->trapsp >= (char *) Caml_state->stack_high - initial_sp_offset) { Caml_state->external_raise = initial_external_raise; + Caml_state->external_raise_async = initial_external_raise_async; Caml_state->extern_sp = (value *) ((char *) Caml_state->stack_high - initial_sp_offset); caml_callback_depth--; @@ -1147,6 +1178,7 @@ value caml_interprete(code_t prog, asize_t prog_size) Instruct(STOP): Caml_state->external_raise = initial_external_raise; + Caml_state->external_raise_async = initial_external_raise_async; Caml_state->extern_sp = sp; caml_callback_depth--; return accu; diff --git a/ocaml/runtime/memory.c b/ocaml/runtime/memory.c index ee4ef00b52c..79fdb387273 100644 --- a/ocaml/runtime/memory.c +++ b/ocaml/runtime/memory.c @@ -469,7 +469,7 @@ Caml_inline value caml_alloc_shr_aux (mlsize_t wosize, tag_t tag, int track, if (wosize > Max_wosize) { if (raise_oom) - caml_raise_out_of_memory (); + caml_fatal_out_of_memory (); else return 0; } @@ -480,10 +480,8 @@ Caml_inline value caml_alloc_shr_aux (mlsize_t wosize, tag_t tag, int track, if (new_block == NULL) { if (!raise_oom) return 0; - else if (Caml_state->in_minor_collection) - caml_fatal_error ("out of memory"); else - caml_raise_out_of_memory (); + caml_fatal_out_of_memory (); } caml_fl_add_blocks ((value) new_block); hp = caml_fl_allocate (wosize); @@ -933,7 +931,7 @@ CAMLexport void* caml_stat_alloc_aligned(asize_t sz, int modulo, void *result = caml_stat_alloc_aligned_noexc(sz, modulo, b); /* malloc() may return NULL if size is 0 */ if ((result == NULL) && (sz != 0)) - caml_raise_out_of_memory(); + caml_fatal_out_of_memory(); return result; } @@ -967,7 +965,7 @@ CAMLexport caml_stat_block caml_stat_alloc(asize_t sz) void *result = caml_stat_alloc_noexc(sz); /* malloc() may return NULL if size is 0 */ if ((result == NULL) && (sz != 0)) - caml_raise_out_of_memory(); + caml_fatal_out_of_memory(); return result; } @@ -1014,7 +1012,7 @@ CAMLexport caml_stat_block caml_stat_resize(caml_stat_block b, asize_t sz) { void *result = caml_stat_resize_noexc(b, sz); if (result == NULL) - caml_raise_out_of_memory(); + caml_fatal_out_of_memory(); return result; } @@ -1046,7 +1044,7 @@ CAMLexport caml_stat_string caml_stat_strdup(const char *s) { caml_stat_string result = caml_stat_strdup_noexc(s); if (result == NULL) - caml_raise_out_of_memory(); + caml_fatal_out_of_memory(); return result; } @@ -1057,7 +1055,7 @@ CAMLexport wchar_t * caml_stat_wcsdup(const wchar_t *s) int slen = wcslen(s); wchar_t* result = caml_stat_alloc((slen + 1)*sizeof(wchar_t)); if (result == NULL) - caml_raise_out_of_memory(); + caml_fatal_out_of_memory(); memcpy(result, s, (slen + 1)*sizeof(wchar_t)); return result; } diff --git a/ocaml/runtime/memprof.c b/ocaml/runtime/memprof.c index c14da084d2d..db1af755612 100644 --- a/ocaml/runtime/memprof.c +++ b/ocaml/runtime/memprof.c @@ -963,8 +963,7 @@ void caml_memprof_track_young(uintnat wosize, int from_caml, [local->entries] to make sure the floag is not set back to 1. */ caml_memprof_set_suspended(0); - if (Is_exception_result(res)) - caml_raise(Extract_exception(res)); + caml_raise_async_if_exception(res, "memprof callback"); /* /!\ Since the heap is in an invalid state before initialization, very little heap operations are allowed until then. */ diff --git a/ocaml/runtime/minor_gc.c b/ocaml/runtime/minor_gc.c index ac766e4dd3f..b2b3d9bcb11 100644 --- a/ocaml/runtime/minor_gc.c +++ b/ocaml/runtime/minor_gc.c @@ -154,9 +154,9 @@ void caml_set_minor_heap_size (asize_t bsz) } CAMLassert (Caml_state->young_ptr == Caml_state->young_alloc_end); new_heap = caml_stat_alloc_aligned_noexc(bsz, 0, &new_heap_base); - if (new_heap == NULL) caml_raise_out_of_memory(); + if (new_heap == NULL) caml_fatal_out_of_memory(); if (caml_page_table_add(In_young, new_heap, new_heap + bsz) != 0) - caml_raise_out_of_memory(); + caml_fatal_out_of_memory(); if (Caml_state->young_start != NULL){ caml_page_table_remove(In_young, Caml_state->young_start, @@ -564,7 +564,7 @@ void caml_alloc_small_dispatch (intnat wosize, int flags, if (flags & CAML_FROM_CAML) /* In the case of allocations performed from OCaml, execute asynchronous callbacks. */ - caml_raise_if_exception(caml_do_pending_actions_exn ()); + caml_raise_async_if_exception(caml_do_pending_actions_exn (), "minor GC"); else { caml_check_urgent_gc (Val_unit); /* In the case of long-running C code that regularly polls with diff --git a/ocaml/runtime/misc.c b/ocaml/runtime/misc.c index f0c4f40386f..80b2dec6ce6 100644 --- a/ocaml/runtime/misc.c +++ b/ocaml/runtime/misc.c @@ -93,6 +93,11 @@ CAMLexport void caml_fatal_error (char *msg, ...) abort(); } +void caml_fatal_out_of_memory(void) +{ + caml_fatal_error("Out of memory"); +} + void caml_ext_table_init(struct ext_table * tbl, int init_capa) { tbl->size = 0; diff --git a/ocaml/runtime/printexc.c b/ocaml/runtime/printexc.c index 2828fdbc5ad..5a24738ec80 100644 --- a/ocaml/runtime/printexc.c +++ b/ocaml/runtime/printexc.c @@ -108,7 +108,7 @@ CAMLexport char * caml_format_exception(value exn) #endif /* Default C implementation in case the OCaml one is not registered. */ -static void default_fatal_uncaught_exception(value exn) +static void default_fatal_uncaught_exception(value exn, const char *msg2) { char * msg; const value * at_exit; @@ -122,11 +122,16 @@ static void default_fatal_uncaught_exception(value exn) saved_backtrace_pos = Caml_state->backtrace_pos; Caml_state->backtrace_active = 0; at_exit = caml_named_value("Pervasives.do_at_exit"); + /* In the event of an asynchronous exception occurring, it will still get + caught here, because of the semantics of [caml_callback_exn]. */ if (at_exit != NULL) caml_callback_exn(*at_exit, Val_unit); Caml_state->backtrace_active = saved_backtrace_active; Caml_state->backtrace_pos = saved_backtrace_pos; /* Display the uncaught exception */ - fprintf(stderr, "Fatal error: exception %s\n", msg); + if (msg2) + fprintf(stderr, "Fatal error: exception (from %s) %s\n", msg2, msg); + else + fprintf(stderr, "Fatal error: exception %s\n", msg); caml_stat_free(msg); /* Display the backtrace if available */ if (Caml_state->backtrace_active && !DEBUGGER_IN_USE) @@ -135,7 +140,7 @@ static void default_fatal_uncaught_exception(value exn) int caml_abort_on_uncaught_exn = 0; /* see afl.c */ -void caml_fatal_uncaught_exception(value exn) +void caml_fatal_uncaught_exception_with_message(value exn, const char *msg) { const value *handle_uncaught_exception; @@ -152,7 +157,7 @@ void caml_fatal_uncaught_exception(value exn) /* [Printexc.handle_uncaught_exception] does not raise exception. */ caml_callback2(*handle_uncaught_exception, exn, Val_bool(DEBUGGER_IN_USE)); else - default_fatal_uncaught_exception(exn); + default_fatal_uncaught_exception(exn, msg); /* Terminate the process */ if (caml_abort_on_uncaught_exn) { abort(); @@ -160,3 +165,8 @@ void caml_fatal_uncaught_exception(value exn) exit(2); } } + +void caml_fatal_uncaught_exception(value exn) +{ + caml_fatal_uncaught_exception_with_message(exn, NULL); +} diff --git a/ocaml/runtime/signals.c b/ocaml/runtime/signals.c index 7cf746f275a..d1cacd0f552 100644 --- a/ocaml/runtime/signals.c +++ b/ocaml/runtime/signals.c @@ -32,6 +32,7 @@ #include "caml/sys.h" #include "caml/memprof.h" #include "caml/finalise.h" +#include "caml/printexc.h" #ifndef NSIG #define NSIG 64 @@ -153,7 +154,8 @@ CAMLexport void caml_enter_blocking_section(void) { while (1){ /* Process all pending signals now */ - caml_raise_if_exception(caml_process_pending_signals_exn()); + caml_raise_async_if_exception(caml_process_pending_signals_exn(), + "signal handler"); caml_enter_blocking_section_hook (); /* Check again for pending signals. If none, done; otherwise, try again */ @@ -194,6 +196,35 @@ CAMLexport void caml_leave_blocking_section(void) errno = saved_errno; } +static void check_async_exn(value res, const char *msg) +{ + value exn; + const value *break_exn; + + if (!Is_exception_result(res)) + return; + + exn = Extract_exception(res); + + /* [Break] is not introduced as a predefined exception (in predef.ml and + stdlib.ml) since it causes trouble in conjunction with warnings about + constructor shadowing e.g. in format.ml. + "Sys.Break" must match stdlib/sys.mlp. */ + break_exn = caml_named_value("Sys.Break"); + if (break_exn != NULL && exn == *break_exn) + return; + + caml_fatal_uncaught_exception_with_message(exn, msg); +} + +void caml_raise_async_if_exception(value res, const char* where) +{ + if (Is_exception_result(res)) { + check_async_exn(res, where); + caml_raise_async(res); + } +} + /* Execute a signal handler immediately */ static value caml_signal_handlers = 0; @@ -270,14 +301,17 @@ value caml_do_pending_actions_exn(void) // Call signal handlers first exn = caml_process_pending_signals_exn(); + check_async_exn(exn, "signal handler"); if (Is_exception_result(exn)) goto exception; // Call memprof callbacks exn = caml_memprof_handle_postponed_exn(); + check_async_exn(exn, "memprof callback"); if (Is_exception_result(exn)) goto exception; // Call finalisers exn = caml_final_do_calls_exn(); + check_async_exn(exn, "finaliser"); if (Is_exception_result(exn)) goto exception; return Val_unit; @@ -318,7 +352,8 @@ value caml_process_pending_actions_with_root_exn(value extra_root) value caml_process_pending_actions_with_root(value extra_root) { value res = process_pending_actions_with_root_exn(extra_root); - return caml_raise_if_exception(res); + caml_raise_async_if_exception(res, ""); + return res; } CAMLexport value caml_process_pending_actions_exn(void) @@ -329,7 +364,7 @@ CAMLexport value caml_process_pending_actions_exn(void) CAMLexport void caml_process_pending_actions(void) { value exn = process_pending_actions_with_root_exn(Val_unit); - caml_raise_if_exception(exn); + caml_raise_async_if_exception(exn, ""); } /* OS-independent numbering of signals */ @@ -486,6 +521,7 @@ CAMLprim value caml_install_signal_handler(value signal_number, value action) } caml_modify(&Field(caml_signal_handlers, sig), Field(action, 0)); } - caml_raise_if_exception(caml_process_pending_signals_exn()); + caml_raise_async_if_exception(caml_process_pending_signals_exn(), + "signal handler"); CAMLreturn (res); } diff --git a/ocaml/runtime/startup_nat.c b/ocaml/runtime/startup_nat.c index 722f834b1ca..c1255537c69 100644 --- a/ocaml/runtime/startup_nat.c +++ b/ocaml/runtime/startup_nat.c @@ -107,6 +107,7 @@ value caml_startup_common(char_os **argv, int pooling) { char_os * exe_name, * proc_self_exe; char tos; + value res; /* Initialize the domain */ caml_init_domain(); @@ -155,7 +156,11 @@ value caml_startup_common(char_os **argv, int pooling) if (caml_termination_hook != NULL) caml_termination_hook(NULL); return Val_unit; } - return caml_start_program(Caml_state); + res = caml_start_program(Caml_state); + /* ignore distinction between async and normal, + it's an uncaught exception either way */ + Caml_state->raising_async_exn = 0; + return res; } value caml_startup_exn(char_os **argv) diff --git a/ocaml/stdlib/stdlib.mli b/ocaml/stdlib/stdlib.mli index dc218097f15..9d574085f6a 100644 --- a/ocaml/stdlib/stdlib.mli +++ b/ocaml/stdlib/stdlib.mli @@ -81,9 +81,10 @@ exception Not_found not be found. *) exception Out_of_memory -(** Exception raised by the garbage collector when there is - insufficient memory to complete the computation. (Not reliable for - allocations on the minor heap.) *) +(** Exception raised by functions such as those for array and bigarray + creation when there is insufficient memory. Failure to allocate + memory during garbage collection causes a fatal error, unlike in + previous versions. *) exception Stack_overflow (** Exception raised by the bytecode interpreter when the evaluation diff --git a/ocaml/stdlib/sys.mli b/ocaml/stdlib/sys.mli index 55a1d29c2e9..a95959ac0a1 100644 --- a/ocaml/stdlib/sys.mli +++ b/ocaml/stdlib/sys.mli @@ -328,10 +328,22 @@ exception Break val catch_break : bool -> unit (** [catch_break] governs whether interactive interrupt (ctrl-C) - terminates the program or raises the [Break] exception. - Call [catch_break true] to enable raising [Break], - and [catch_break false] to let the system - terminate the program on user interrupt. *) + terminates the program or raises the [Break] exception. + Call [catch_break true] to enable raising [Break], + and [catch_break false] to let the system + terminate the program on user interrupt. + + By default, having done [catch_break true], [Break] will be delivered to + the toplevel uncaught exception handler. To deliver it elsewhere, use + [with_async_exns], below. +*) + +val with_async_exns : (unit -> 'a) -> 'a +(** [with_async_exns f] runs [f] and returns its result, in addition to + causing any asynchronous [Break] or [Stack_overflow] exceptions + (e.g. from finalisers, signal handlers or the GC) to be raised from the + call site of [with_async_exns]. +*) val ocaml_version : string diff --git a/ocaml/stdlib/sys.mlp b/ocaml/stdlib/sys.mlp index 69c3ac9b57c..3ae45a2595f 100644 --- a/ocaml/stdlib/sys.mlp +++ b/ocaml/stdlib/sys.mlp @@ -115,6 +115,12 @@ let sigxcpu = -27 let sigxfsz = -28 exception Break +(* We don't use [Callback] or [Obj] because of circular dependencies. + The string "Sys.Break" must match runtime/fail.c. *) +external register_named_value : string -> 'a -> unit + = "caml_register_named_value" +(* Various places in the runtime rely on the "Sys.Break" name. *) +let () = register_named_value "Sys.Break" Break let catch_break on = if on then @@ -122,6 +128,7 @@ let catch_break on = else set_signal sigint Signal_default +external with_async_exns : (unit -> 'a) -> 'a = "caml_with_async_exns" external enable_runtime_warnings: bool -> unit = "caml_ml_enable_runtime_warnings" diff --git a/ocaml/testsuite/lib/lib.ml b/ocaml/testsuite/lib/lib.ml index 59b8549df5f..47896f8be3b 100644 --- a/ocaml/testsuite/lib/lib.ml +++ b/ocaml/testsuite/lib/lib.ml @@ -14,6 +14,7 @@ (**************************************************************************) external raise : exn -> 'a = "%raise" +external with_async_exns : (unit -> 'a) -> 'a = "caml_with_async_exns" external not : bool -> bool = "%boolnot" diff --git a/ocaml/testsuite/tests/async-exns/async_exns_1.ml b/ocaml/testsuite/tests/async-exns/async_exns_1.ml new file mode 100644 index 00000000000..5bc0388c193 --- /dev/null +++ b/ocaml/testsuite/tests/async-exns/async_exns_1.ml @@ -0,0 +1,235 @@ +(* TEST + modules = "async_exns_stubs.c" +*) + +let () = Sys.catch_break true + +(* Lifted out to ensure this works in bytecode, where [b] is easily + held on to as a root on the stack. *) +let[@inline never] allocate_bytes finished = + let b = Bytes.create 42 in + Gc.finalise_last (fun () -> + finished := true; + raise Sys.Break) + b; + ref (Some b) + +(* Ensure that an async exn raised from a finaliser skips an exception + handler, placed around the point where the GC was invoked, instead arriving + at an outer [Sys.with_async_exns] point. *) +let () = + let finished = ref false in + let r = allocate_bytes finished in + try + Sys.with_async_exns (fun () -> + try + r := None; + while true do + (* This allocation will eventually trigger the finaliser *) + let _ = Sys.opaque_identity (42, Random.int 42) in + () + done + with exn -> Printf.printf "1. wrong handler\n%!"; assert false + ) + with + | Sys.Break -> assert !finished; Printf.printf "1. OK\n%!" + | _ -> assert false + +(* Ensure that [Sys.Break] can be raised and caught as a normal exception. *) +let () = + try + Sys.with_async_exns (fun () -> + try raise (Sys.opaque_identity Sys.Break) + with Sys.Break -> Printf.printf "2. OK\n%!" + ) + with + | _ -> Printf.printf "2. wrong handler\n%!"; assert false + +(* Ensure that [caml_callback_exn] collects async exns arising from the + callback. *) +let raise_break_from_finaliser () = + let finished = ref false in + let r = allocate_bytes finished in + try + r := None; + while true do + let _ = Sys.opaque_identity (42, Random.int 42) in + () + done + with exn -> Printf.printf "3a. wrong handler\n%!"; exit 1 + +external test_caml_callback_exn_collects_async_exns : (unit -> unit) -> unit + = "test_caml_callback_exn_collects_async_exns" + +let () = + try + Sys.with_async_exns (fun () -> + test_caml_callback_exn_collects_async_exns raise_break_from_finaliser); + Printf.printf "3a. OK\n%!" + with + | _ -> assert false + +(* Same but for a 2-parameter callback *) + +external test_caml_callback2_exn_collects_async_exns + : (unit -> unit -> unit) -> unit + = "test_caml_callback2_exn_collects_async_exns" + +let raise_break_from_finaliser2 () () = + raise_break_from_finaliser () + +let () = + try + Sys.with_async_exns (fun () -> + test_caml_callback2_exn_collects_async_exns raise_break_from_finaliser2); + Printf.printf "3b. OK\n%!" + with + | _ -> assert false + +(* Same but for a 3-parameter callback *) + +external test_caml_callback3_exn_collects_async_exns + : (unit -> unit -> unit -> unit) -> unit + = "test_caml_callback3_exn_collects_async_exns" + +let raise_break_from_finaliser3 () () () = + raise_break_from_finaliser () + +let () = + try + Sys.with_async_exns (fun () -> + test_caml_callback3_exn_collects_async_exns raise_break_from_finaliser3); + Printf.printf "3c. OK\n%!" + with + | _ -> assert false + +(* Same but for a 4-parameter callback *) + +external test_caml_callbackN_exn_collects_async_exns + : (unit -> unit -> unit -> unit -> unit) -> unit + = "test_caml_callbackN_exn_collects_async_exns" + +let raise_break_from_finaliser4 () () () () = + raise_break_from_finaliser () + +let () = + try + Sys.with_async_exns (fun () -> + test_caml_callbackN_exn_collects_async_exns raise_break_from_finaliser4); + Printf.printf "3d. OK\n%!" + with + | _ -> assert false + +external invoke_caml_callback + : (unit -> unit) -> unit + = "invoke_caml_callback" + +(* Ensure that [caml_callback] reraises an async exn arising from the + callback, and that such reraise is done as an async raise. *) +let () = + try + Sys.with_async_exns (fun () -> + try invoke_caml_callback raise_break_from_finaliser + with exn -> Printf.printf "4a. wrong handler\n%!"; assert false + ) + with + | Sys.Break -> Printf.printf "4a. OK\n%!" + | _ -> assert false + +(* Same but for a 2-parameter callback *) + +external invoke_caml_callback2 + : (unit -> unit -> unit) -> unit + = "invoke_caml_callback2" + +let () = + try + Sys.with_async_exns (fun () -> + try invoke_caml_callback2 raise_break_from_finaliser2 + with exn -> Printf.printf "4b. wrong handler\n%!"; assert false + ) + with + | Sys.Break -> Printf.printf "4b. OK\n%!" + | _ -> assert false + +(* Same but for a 3-parameter callback *) + +external invoke_caml_callback3 + : (unit -> unit -> unit -> unit) -> unit + = "invoke_caml_callback3" + +let () = + try + Sys.with_async_exns (fun () -> + try invoke_caml_callback3 raise_break_from_finaliser3 + with exn -> Printf.printf "4c. wrong handler\n%!"; assert false + ) + with + | Sys.Break -> Printf.printf "4c. OK\n%!" + | _ -> assert false + +(* Same but for a 4-parameter callback *) + +external invoke_caml_callbackN + : (unit -> unit -> unit -> unit -> unit) -> unit + = "invoke_caml_callbackN" + +let () = + try + Sys.with_async_exns (fun () -> + try invoke_caml_callbackN raise_break_from_finaliser4 + with exn -> Printf.printf "4d. wrong handler\n%!"; assert false + ) + with + | Sys.Break -> Printf.printf "4d. OK\n%!" + | _ -> assert false + +(* Ensure that [caml_callback] raises [Sys.Break] that did not arise in + an async exn context as a normal exception. *) + +let raise_break () = raise Sys.Break +let raise_break2 () () = raise Sys.Break +let raise_break3 () () () = raise Sys.Break +let raise_break4 () () () () = raise Sys.Break + +let () = + try + Sys.with_async_exns (fun () -> + try invoke_caml_callback raise_break + with exn -> Printf.printf "5a. OK\n%!" + ) + with + | _ -> assert false + +(* Same but for a 2-parameter callback *) + +let () = + try + Sys.with_async_exns (fun () -> + try invoke_caml_callback2 raise_break2 + with exn -> Printf.printf "5b. OK\n%!" + ) + with + | _ -> assert false + +(* Same but for a 3-parameter callback *) + +let () = + try + Sys.with_async_exns (fun () -> + try invoke_caml_callback3 raise_break3 + with exn -> Printf.printf "5c. OK\n%!" + ) + with + | _ -> assert false + +(* Same but for a 4-parameter callback *) + +let () = + try + Sys.with_async_exns (fun () -> + try invoke_caml_callbackN raise_break4 + with exn -> Printf.printf "5d. OK\n%!" + ) + with + | _ -> assert false diff --git a/ocaml/testsuite/tests/async-exns/async_exns_1.reference b/ocaml/testsuite/tests/async-exns/async_exns_1.reference new file mode 100644 index 00000000000..9290ae2fb59 --- /dev/null +++ b/ocaml/testsuite/tests/async-exns/async_exns_1.reference @@ -0,0 +1,14 @@ +1. OK +2. OK +3a. OK +3b. OK +3c. OK +3d. OK +4a. OK +4b. OK +4c. OK +4d. OK +5a. OK +5b. OK +5c. OK +5d. OK diff --git a/ocaml/testsuite/tests/async-exns/async_exns_stubs.c b/ocaml/testsuite/tests/async-exns/async_exns_stubs.c new file mode 100644 index 00000000000..8675a815544 --- /dev/null +++ b/ocaml/testsuite/tests/async-exns/async_exns_stubs.c @@ -0,0 +1,68 @@ +#include +#include +#include +#include + +static value sys_break(void) +{ + const value *break_exn; + break_exn = caml_named_value("Sys.Break"); + if (break_exn == NULL) abort (); + return *break_exn; +} + +value test_caml_callback_exn_collects_async_exns(value raise_break_async) +{ + value res = caml_callback_exn(raise_break_async, Val_unit); + assert(Is_exception_result(res)); + assert(Extract_exception(res) == sys_break()); + return Val_unit; +} + +value test_caml_callback2_exn_collects_async_exns(value raise_break_async) +{ + value res = caml_callback2_exn(raise_break_async, Val_unit, Val_unit); + assert(Is_exception_result(res)); + assert(Extract_exception(res) == sys_break()); + return Val_unit; +} + +value test_caml_callback3_exn_collects_async_exns(value raise_break_async) +{ + value res; + res = caml_callback3_exn(raise_break_async, Val_unit, Val_unit, Val_unit); + assert(Is_exception_result(res)); + assert(Extract_exception(res) == sys_break()); + return Val_unit; +} + +value test_caml_callbackN_exn_collects_async_exns(value raise_break_async) +{ + value res; + value args[] = { Val_unit, Val_unit, Val_unit, Val_unit }; + res = caml_callbackN_exn(raise_break_async, 4, args); + assert(Is_exception_result(res)); + assert(Extract_exception(res) == sys_break()); + return Val_unit; +} + +value invoke_caml_callback(value raise_break_async) +{ + return caml_callback(raise_break_async, Val_unit); +} + +value invoke_caml_callback2(value raise_break_async) +{ + return caml_callback2(raise_break_async, Val_unit, Val_unit); +} + +value invoke_caml_callback3(value raise_break_async) +{ + return caml_callback3(raise_break_async, Val_unit, Val_unit, Val_unit); +} + +value invoke_caml_callbackN(value raise_break_async) +{ + value args[] = { Val_unit, Val_unit, Val_unit, Val_unit }; + return caml_callbackN(raise_break_async, 4, args); +} diff --git a/ocaml/testsuite/tests/lib-systhreads/eintr.ml b/ocaml/testsuite/tests/lib-systhreads/eintr.ml index 5c0a4d045e1..b9040b62fa9 100644 --- a/ocaml/testsuite/tests/lib-systhreads/eintr.ml +++ b/ocaml/testsuite/tests/lib-systhreads/eintr.ml @@ -26,10 +26,14 @@ let request_signal () = Atomic.incr signals_requested let () = let (rd, wr) = Unix.pipe () in Sys.catch_break true; - request_signal (); - begin match Unix.read rd (Bytes.make 1 'a') 0 1 with + begin match + Sys.with_async_exns (fun () -> + request_signal (); + Unix.read rd (Bytes.make 1 'a') 0 1) + with | _ -> assert false - | exception Sys.Break -> print_endline "break: ok" end; + | exception Sys.Break -> + print_endline "break: ok" end; Sys.catch_break false; Unix.close rd; Unix.close wr @@ -71,19 +75,23 @@ let () = let before = Sys.opaque_identity (ref (mklist ())) in let during = Atomic.make (Sys.opaque_identity (mklist ())) in let siglist = ref [] in - Sys.set_signal Sys.sigint (Signal_handle (fun _ -> - Gc.full_major (); poke_stdout (); Gc.compact (); - siglist := mklist (); - raise Sys.Break)); - request_signal (); - begin match + let test_body () = + (* Allocate [test_body]'s closure here, to avoid disturbing the + test in the context of [with_async_exns] below. *) + request_signal (); while true do poke_stdout (); Atomic.set during (mklist ()) done - with + in + Sys.set_signal Sys.sigint (Signal_handle (fun _ -> + Gc.full_major (); poke_stdout (); Gc.compact (); + siglist := mklist (); + raise Sys.Break)); + begin match Sys.with_async_exns test_body with | () -> assert false - | exception Sys.Break -> () end; + | exception Sys.Break -> () + end; let expected = Sys.opaque_identity (mklist ()) in assert (!before = expected); assert (Atomic.get during = expected); diff --git a/ocaml/testsuite/tests/misc/pr7168.ml b/ocaml/testsuite/tests/misc/pr7168.ml index 0d41593c2a5..a61f7a12c2d 100644 --- a/ocaml/testsuite/tests/misc/pr7168.ml +++ b/ocaml/testsuite/tests/misc/pr7168.ml @@ -75,6 +75,6 @@ let _ = reliably detect stack overflow. *) Printf.printf "OK\n" end else begin - try f 1 + try Sys.with_async_exns (fun () -> f 1) with Stack_overflow -> Printf.printf "OK\n" end diff --git a/ocaml/testsuite/tests/runtime-errors/stackoverflow.ml b/ocaml/testsuite/tests/runtime-errors/stackoverflow.ml index 82c1c25ac8d..09712b6829d 100644 --- a/ocaml/testsuite/tests/runtime-errors/stackoverflow.ml +++ b/ocaml/testsuite/tests/runtime-errors/stackoverflow.ml @@ -28,7 +28,7 @@ let rec f x = then 1 + f (x + 1) else try - 1 + f (x + 1) + Sys.with_async_exns (fun () -> 1 + f (x + 1)) with Stack_overflow -> print_string "x = "; print_int x; print_newline(); raise Stack_overflow @@ -36,7 +36,7 @@ let rec f x = let _ = begin try - ignore(f 0) + Sys.with_async_exns (fun () -> ignore(f 0)) with Stack_overflow -> print_string "Stack overflow caught"; print_newline() end ; @@ -44,7 +44,7 @@ let _ = Printexc.record_backtrace true; begin try - ignore(f 0) + Sys.with_async_exns (fun () -> ignore(f 0)) with Stack_overflow -> print_string "second Stack overflow caught"; print_newline() end diff --git a/ocaml/testsuite/tests/tool-ocaml/t360-stacks-2.ml b/ocaml/testsuite/tests/tool-ocaml/t360-stacks-2.ml index 016cc0db524..99eaa462927 100644 --- a/ocaml/testsuite/tests/tool-ocaml/t360-stacks-2.ml +++ b/ocaml/testsuite/tests/tool-ocaml/t360-stacks-2.ml @@ -12,8 +12,9 @@ let rec f n = else 1 + f (n-1) in try - ignore (f 3000000); - raise Not_found + with_async_exns (fun () -> + ignore (f 3000000); + raise Not_found) with Stack_overflow -> () ;;