From 893a9c4d51fd388affa32cf14c9fe61f6143d9bf Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Wed, 11 Aug 2021 17:03:40 +0100 Subject: [PATCH 1/6] Async exns --- backend/cfg/cfg.ml | 3 +- backend/mach.ml | 5 +- ocaml/otherlibs/systhreads/st_stubs.c | 14 ++- ocaml/runtime/Makefile | 4 +- ocaml/runtime/amd64.S | 36 +++++- ocaml/runtime/callback.c | 53 ++++++++- ocaml/runtime/caml/callback.h | 2 + ocaml/runtime/caml/domain_state.tbl | 4 + ocaml/runtime/caml/fail.h | 15 +++ ocaml/runtime/caml/printexc.h | 2 + ocaml/runtime/caml/signals.h | 1 + ocaml/runtime/caml/stack.h | 1 + ocaml/runtime/debugger.c | 4 + ocaml/runtime/domain.c | 1 + ocaml/runtime/dune | 6 +- ocaml/runtime/fail.c | 80 +++++++++++++ ocaml/runtime/fail_byt.c | 84 +++++++++++-- ocaml/runtime/fail_nat.c | 110 +++++++++++++++--- ocaml/runtime/finalise.c | 3 +- ocaml/runtime/gc_ctrl.c | 10 +- ocaml/runtime/gen_primitives.sh | 2 +- ocaml/runtime/i386.S | 39 ++++++- ocaml/runtime/interp.c | 40 ++++++- ocaml/runtime/memory.c | 14 +-- ocaml/runtime/memprof.c | 9 +- ocaml/runtime/minor_gc.c | 13 ++- ocaml/runtime/printexc.c | 20 +++- ocaml/runtime/signals.c | 10 +- ocaml/runtime/stacks.c | 4 +- ocaml/stdlib/stdlib.mli | 7 +- ocaml/stdlib/sys.mli | 20 +++- ocaml/stdlib/sys.mlp | 7 ++ ocaml/testsuite/lib/lib.ml | 1 + .../tests/async-exns/async_exns_1.ml | 31 +++++ .../tests/async-exns/async_exns_1.reference | 1 + ocaml/testsuite/tests/lib-systhreads/eintr.ml | 30 +++-- ocaml/testsuite/tests/misc/pr7168.ml | 2 +- .../tests/runtime-errors/stackoverflow.ml | 6 +- .../tests/tool-ocaml/t360-stacks-2.ml | 5 +- 39 files changed, 593 insertions(+), 106 deletions(-) create mode 100644 ocaml/runtime/fail.c create mode 100644 ocaml/testsuite/tests/async-exns/async_exns_1.ml create mode 100644 ocaml/testsuite/tests/async-exns/async_exns_1.reference 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..6f4839553e4 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,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; } diff --git a/ocaml/runtime/Makefile b/ocaml/runtime/Makefile index b89decafd63..d1542c950bd 100644 --- a/ocaml/runtime/Makefile +++ b/ocaml/runtime/Makefile @@ -21,7 +21,7 @@ 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 \ @@ -29,7 +29,7 @@ BYTECODE_C_SOURCES := $(addsuffix .c, \ 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 \ diff --git a/ocaml/runtime/amd64.S b/ocaml/runtime/amd64.S index 117dc5b0c61..89b35ea6a6c 100644 --- a/ocaml/runtime/amd64.S +++ b/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) diff --git a/ocaml/runtime/callback.c b/ocaml/runtime/callback.c index 347e3a9d1f2..c2a09de0acd 100644 --- a/ocaml/runtime/callback.c +++ b/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 */ diff --git a/ocaml/runtime/caml/callback.h b/ocaml/runtime/caml/callback.h index eef3342ec78..524f6afa455 100644 --- a/ocaml/runtime/caml/callback.h +++ b/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); diff --git a/ocaml/runtime/caml/domain_state.tbl b/ocaml/runtime/caml/domain_state.tbl index 895298da66d..f540605612a 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 */ diff --git a/ocaml/runtime/caml/fail.h b/ocaml/runtime/caml/fail.h index 677b1f724f1..872fc01a661 100644 --- a/ocaml/runtime/caml/fail.h +++ b/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; 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..78a01de684a 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; diff --git a/ocaml/runtime/dune b/ocaml/runtime/dune index 703b7e118b7..eff2c1fe507 100644 --- a/ocaml/runtime/dune +++ b/ocaml/runtime/dune @@ -23,7 +23,7 @@ callback.c weak.c finalise.c stacks.c dynlink.c backtrace_byt.c backtrace.c afl.c - bigarray.c eventlog.c) + bigarray.c eventlog.c fail_nat.c) (action (with-stdout-to %{targets} (run %{dep:gen_primitives.sh})))) ; Shouldn't this use foreign build sandboxing? @@ -36,7 +36,7 @@ (glob_files caml/*.h) interp.c misc.c stacks.c fix_code.c startup_aux.c startup_byt.c freelist.c major_gc.c minor_gc.c memory.c alloc.c roots_byt.c - globroots.c fail_byt.c signals.c signals_byt.c printexc.c + globroots.c fail.c fail_byt.c signals.c signals_byt.c printexc.c backtrace_byt.c backtrace.c compare.c ints.c floats.c str.c array.c io.c extern.c intern.c hash.c sys.c meta.c parsing.c gc_ctrl.c md5.c obj.c lexing.c callback.c debugger.c weak.c compact.c finalise.c @@ -60,7 +60,7 @@ (deps ../Makefile.config ../Makefile.common ../Makefile.build_config ../Makefile.config_if_required Makefile (glob_files caml/*.h) signals_osdep.h amd64.S - startup_aux.c startup_nat.c main.c fail_nat.c roots_nat.c signals.c + startup_aux.c startup_nat.c main.c fail.c fail_nat.c roots_nat.c signals.c signals_nat.c misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c compare.c ints.c floats.c str.c array.c io.c extern.c intern.c hash.c sys.c parsing.c gc_ctrl.c md5.c obj.c lexing.c unix.c printexc.c callback.c weak.c diff --git a/ocaml/runtime/fail.c b/ocaml/runtime/fail.c new file mode 100644 index 00000000000..690117dd57c --- /dev/null +++ b/ocaml/runtime/fail.c @@ -0,0 +1,80 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* Mark Shinwell, Jane Street Europe */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* Copyright 2022 Jane Street Group LLC. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS + +/* Code related to the raising of exceptions that is shared between + the bytecode and native code runtimes. */ + +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +#include "caml/printexc.h" +#include "caml/signals.h" +#include "caml/io.h" +#include "caml/callback.h" + +CAMLno_asan +CAMLexport value caml_prepare_for_raise(value v, int *turned_into_async_exn) +{ + 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] should now be raised as an asynchronous exception. + + if (turned_into_async_exn != NULL) + *turned_into_async_exn = 1; + } + else + { + if (turned_into_async_exn != NULL) + *turned_into_async_exn = 0; + } + + return v; +} + +CAMLexport value caml_check_async_exn0(value res, const char *msg, + value stack_overflow_exn) +{ + value exn; + const value *break_exn; + + if (!Is_exception_result(res)) + return res; + + exn = Extract_exception(res); + + if (exn == stack_overflow_exn) + return 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 res; + + caml_fatal_uncaught_exception_with_message(exn, msg); +} diff --git a/ocaml/runtime/fail_byt.c b/ocaml/runtime/fail_byt.c index 0d0d2b05afa..09e3a966653 100644 --- a/ocaml/runtime/fail_byt.c +++ b/ocaml/runtime/fail_byt.c @@ -31,19 +31,44 @@ #include "caml/signals.h" #include "caml/stacks.h" +static void prepare_for_raise(value v, int *turned_into_async_exn) +{ + v = caml_prepare_for_raise(v, turned_into_async_exn); + Caml_state->exn_bucket = v; +} + CAMLexport void caml_raise(value v) { - Unlock_exn(); - CAMLassert(!Is_exception_result(v)); + int turned_into_async_exn = 0; + prepare_for_raise(v, &turned_into_async_exn); - // avoid calling caml_raise recursively - v = caml_process_pending_actions_with_root_exn(v); - if (Is_exception_result(v)) - v = Extract_exception(v); + if (turned_into_async_exn) + { + if (Caml_state->external_raise_async == NULL) { + caml_fatal_uncaught_exception(v); + } - Caml_state->exn_bucket = v; - if (Caml_state->external_raise == NULL) caml_fatal_uncaught_exception(v); - siglongjmp(Caml_state->external_raise->buf, 1); + siglongjmp(Caml_state->external_raise_async->buf, 1); + } + else + { + 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) +{ + prepare_for_raise(v, NULL); + + if (Caml_state->external_raise_async == NULL) + { + caml_fatal_uncaught_exception(v); + } + + siglongjmp(Caml_state->external_raise_async->buf, 1); } CAMLexport void caml_raise_constant(value tag) @@ -161,10 +186,15 @@ CAMLexport void caml_raise_out_of_memory(void) caml_raise_constant(Field(caml_global_data, OUT_OF_MEMORY_EXN)); } +CAMLexport void caml_raise_out_of_memory_fatal(void) +{ + caml_raise_out_of_memory(); +} + 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) @@ -203,6 +233,13 @@ CAMLexport value caml_raise_if_exception(value res) return res; } +CAMLexport value caml_raise_async_if_exception(value result) +{ + if (Is_exception_result(result)) caml_raise_async(Extract_exception(result)); + + return result; +} + 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 @@ -213,3 +250,30 @@ int caml_is_special_exception(value exn) { || exn == Field(caml_global_data, ASSERT_FAILURE_EXN) || exn == Field(caml_global_data, UNDEFINED_RECURSIVE_MODULE_EXN); } + +CAMLexport value caml_check_async_exn(value res, const char *msg) +{ + check_global_data("Stack_overflow"); + return caml_check_async_exn0(res, msg, + Field(caml_global_data, STACK_OVERFLOW_EXN)); +} + +CAMLprim value caml_with_async_exns(value body_callback) +{ + value exn; + value result = caml_callback_async_exn(body_callback, Val_unit); + + if (!Is_exception_result(result)) + return result; + + exn = Extract_exception(result); + + /* Irrespective as to whether the exception was asynchronous, it is raised as + a normal exception, without any processing of pending actions. */ + + if (Caml_state->external_raise == NULL) + caml_fatal_uncaught_exception(exn); + + Caml_state->exn_bucket = exn; + siglongjmp(Caml_state->external_raise->buf, 1); +} diff --git a/ocaml/runtime/fail_nat.c b/ocaml/runtime/fail_nat.c index 013171cb726..3e786921636 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" @@ -53,31 +54,63 @@ extern caml_generated_constant /* Exception raising */ CAMLnoreturn_start - extern void caml_raise_exception (caml_domain_state* state, value bucket) +extern void caml_raise_exception(caml_domain_state *state, value bucket) +CAMLnoreturn_end; + +CAMLnoreturn_start +void caml_raise_async_exception(value bucket) CAMLnoreturn_end; +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; + } +} + +CAMLno_asan void caml_raise_async_exception(value v) +{ + Caml_state->exception_pointer = Caml_state->async_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(value v) +void caml_raise(value exn) { - Unlock_exn(); + int turned_into_async_exn = 0; + exn = caml_prepare_for_raise(exn, &turned_into_async_exn); - CAMLassert(!Is_exception_result(v)); + if (turned_into_async_exn) + { + if (Caml_state->async_exception_pointer == NULL) + caml_fatal_uncaught_exception(exn); - // avoid calling caml_raise recursively - v = caml_process_pending_actions_with_root_exn(v); - if (Is_exception_result(v)) - v = Extract_exception(v); - - if (Caml_state->exception_pointer == NULL) caml_fatal_uncaught_exception(v); + unwind_local_roots(Caml_state->async_exception_pointer); + caml_raise_async_exception(exn); + } + else + { + if (Caml_state->exception_pointer == NULL) + caml_fatal_uncaught_exception(exn); - 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, exn); } +} - caml_raise_exception(Caml_state, v); +CAMLno_asan void caml_raise_async(value exn) +{ + exn = caml_prepare_for_raise(exn, NULL); + + if (Caml_state->async_exception_pointer == NULL) + caml_fatal_uncaught_exception(exn); + + unwind_local_roots(Caml_state->async_exception_pointer); + caml_raise_async_exception(exn); } /* Used by the stack overflow handler -> deactivate ASAN (see @@ -145,15 +178,22 @@ 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); } +void caml_raise_out_of_memory_fatal(void) +{ + fprintf(stderr, "[ocaml] Out of memory\n"); + abort(); +} + /* Used by the stack overflow handler -> deactivate ASAN (see segv_handler in signals_nat.c). */ 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) @@ -187,6 +227,13 @@ CAMLexport value caml_raise_if_exception(value res) return res; } +CAMLexport value caml_raise_async_if_exception(value result) +{ + if (Is_exception_result(result)) caml_raise_async(Extract_exception(result)); + + return result; +} + /* 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]). */ @@ -195,10 +242,12 @@ static const value * caml_array_bound_error_exn = NULL; void caml_array_bound_error(void) { - if (caml_array_bound_error_exn == NULL) { + if (caml_array_bound_error_exn == NULL) + { caml_array_bound_error_exn = - caml_named_value("Pervasives.array_bound_error"); - if (caml_array_bound_error_exn == NULL) { + caml_named_value("Pervasives.array_bound_error"); + if (caml_array_bound_error_exn == NULL) + { fprintf(stderr, "Fatal error: exception " "Invalid_argument(\"index out of bounds\")\n"); exit(2); @@ -215,3 +264,28 @@ int caml_is_special_exception(value exn) { || exn == (value) caml_exn_Assert_failure || exn == (value) caml_exn_Undefined_recursive_module; } + +CAMLexport value caml_check_async_exn(value res, const char *msg) +{ + return caml_check_async_exn0(res, msg, (value) caml_exn_Stack_overflow); +} + +CAMLprim value caml_with_async_exns(value body_callback) +{ + value exn; + value result = caml_callback_async_exn(body_callback, Val_unit); + + if (!Is_exception_result(result)) + return result; + + exn = Extract_exception(result); + + /* Irrespective as to whether the exception was asynchronous, it is raised as + a normal exception, without any processing of pending actions. */ + + if (Caml_state->exception_pointer == NULL) + caml_fatal_uncaught_exception(exn); + + unwind_local_roots(Caml_state->exception_pointer); + caml_raise_exception(Caml_state, exn); +} diff --git a/ocaml/runtime/finalise.c b/ocaml/runtime/finalise.c index 46e1b7dd4fa..e3bffde40f9 100644 --- a/ocaml/runtime/finalise.c +++ b/ocaml/runtime/finalise.c @@ -183,7 +183,8 @@ value caml_final_do_calls_exn (void) -- to_do_hd->size; f = to_do_hd->item[to_do_hd->size]; running_finalisation_function = 1; - res = caml_callback_exn (f.fun, f.val + f.offset); + res = caml_check_async_exn(caml_callback_exn (f.fun, f.val + f.offset), + "finaliser"); running_finalisation_function = 0; if (Is_exception_result (res)) return res; } diff --git a/ocaml/runtime/gc_ctrl.c b/ocaml/runtime/gc_ctrl.c index 4d51cb42442..63ae990d874 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/gen_primitives.sh b/ocaml/runtime/gen_primitives.sh index a727d5c25cf..c7e08e16a4c 100755 --- a/ocaml/runtime/gen_primitives.sh +++ b/ocaml/runtime/gen_primitives.sh @@ -25,7 +25,7 @@ export LC_ALL=C alloc array compare extern floats gc_ctrl hash intern interp ints io \ lexing md5 meta memprof obj parsing signals str sys callback weak \ finalise stacks dynlink backtrace_byt backtrace afl \ - bigarray eventlog + bigarray eventlog fail_nat do sed -n -e 's/^CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p' "$prim.c" done diff --git a/ocaml/runtime/i386.S b/ocaml/runtime/i386.S index 73ba8213a96..c9d9c472549 100644 --- a/ocaml/runtime/i386.S +++ b/ocaml/runtime/i386.S @@ -272,9 +272,25 @@ FUNCTION(caml_start_program) pushl %ebp; CFI_ADJUST(4) /* Initial entry point is caml_program */ movl $ G(caml_program), %esi - /* Common code for caml_start_program and caml_callback* */ +LBL(106a): + /* Register the same exception handler as below for async exceptions */ + movl G(Caml_state), %edi + pushl CAML_STATE(async_exception_pointer, %edi); CFI_ADJUST(4) + subl $40, %esp + movl %esp, CAML_STATE(async_exception_pointer, %edi) + addl $40, %esp + ALIGN_STACK(12) /* must match below */ + jmp LBL(106b) + /* Common code for caml_start_program and caml_callback*. + If you update the stack pushes / stack pointer changes below, update + the number 24 above. */ LBL(106): + /* Save the current async exception pointer without disturbing the + alignment of the stack (see note below). */ movl G(Caml_state), %edi + pushl CAML_STATE(async_exception_pointer, %edi); CFI_ADJUST(4) + ALIGN_STACK(12) +LBL(106b): /* Build a callback link */ pushl CAML_STATE(gc_regs, %edi); CFI_ADJUST(4) pushl CAML_STATE(last_return_address, %edi); CFI_ADJUST(4) @@ -298,6 +314,10 @@ 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) + /* Restore the asynchronous exception pointer (this will be a no-op + if this function was not invoked via [L106a]). */ + UNDO_ALIGN_STACK(12) + popl CAML_STATE(async_exception_pointer, %edi); CFI_ADJUST(-4) /* Restore callee-save registers. */ popl %ebp; CFI_ADJUST(-4) popl %edi; CFI_ADJUST(-4) @@ -428,6 +448,23 @@ FUNCTION(caml_callback3_asm) CFI_ENDPROC ENDFUNCTION(caml_callback3_asm) +/* Variant of caml_callback_asm that installs an async exn trap frame. */ +FUNCTION(caml_callback_asm_async_exn) + CFI_STARTPROC + /* Save callee-save registers */ + pushl %ebx; CFI_ADJUST(4) + pushl %esi; CFI_ADJUST(4) + pushl %edi; CFI_ADJUST(4) + pushl %ebp; CFI_ADJUST(4) + /* Initial loading of arguments */ + movl 24(%esp), %ebx /* arg2: closure */ + movl 28(%esp), %edi /* arguments array */ + movl 0(%edi), %eax /* arg1: argument */ + movl 0(%ebx), %esi /* code pointer */ + jmp LBL(106a) + CFI_ENDPROC +ENDFUNCTION(caml_callback_asm_async_exn) + FUNCTION(caml_ml_array_bound_error) CFI_STARTPROC /* Empty the floating-point stack */ diff --git a/ocaml/runtime/interp.c b/ocaml/runtime/interp.c index a59811c87d8..ac53263f1c2 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,9 +265,13 @@ 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)) { + if (sigsetjmp(raise_buf.buf, 1)) { Caml_state->local_roots = initial_local_roots; sp = Caml_state->extern_sp; accu = Caml_state->exn_bucket; @@ -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, 1)) { + 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..929ebdd5523 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_raise_out_of_memory_fatal (); else return 0; } @@ -483,7 +483,7 @@ Caml_inline value caml_alloc_shr_aux (mlsize_t wosize, tag_t tag, int track, else if (Caml_state->in_minor_collection) caml_fatal_error ("out of memory"); else - caml_raise_out_of_memory (); + caml_raise_out_of_memory_fatal (); } caml_fl_add_blocks ((value) new_block); hp = caml_fl_allocate (wosize); @@ -933,7 +933,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_raise_out_of_memory_fatal(); return result; } @@ -967,7 +967,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_raise_out_of_memory_fatal(); return result; } @@ -1014,7 +1014,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_raise_out_of_memory_fatal(); return result; } @@ -1046,7 +1046,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_raise_out_of_memory_fatal(); return result; } @@ -1057,7 +1057,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_raise_out_of_memory_fatal(); memcpy(result, s, (slen + 1)*sizeof(wchar_t)); return result; } diff --git a/ocaml/runtime/memprof.c b/ocaml/runtime/memprof.c index c14da084d2d..42fede34f2b 100644 --- a/ocaml/runtime/memprof.c +++ b/ocaml/runtime/memprof.c @@ -450,7 +450,7 @@ Caml_inline value run_callback_exn( local->callback_status = ea == &entries_global ? t_idx : CB_LOCAL; t->running = local; t->user_data = Val_unit; /* Release root. */ - res = caml_callback_exn(cb, param); + res = caml_check_async_exn(caml_callback_exn(cb, param), "memprof callback"); if (local->callback_status == CB_STOPPED) { /* Make sure this entry has not been removed by [caml_memprof_stop] */ local->callback_status = CB_IDLE; @@ -963,8 +963,11 @@ 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)); + if (Is_exception_result(res)) { + value exn = Extract_exception(res); + if (from_caml) caml_raise_async(exn); + else caml_raise(exn); + } /* /!\ 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..85e0079ec07 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_raise_out_of_memory_fatal(); if (caml_page_table_add(In_young, new_heap, new_heap + bsz) != 0) - caml_raise_out_of_memory(); + caml_raise_out_of_memory_fatal(); if (Caml_state->young_start != NULL){ caml_page_table_remove(In_young, Caml_state->young_start, @@ -554,6 +554,7 @@ void caml_alloc_small_dispatch (intnat wosize, int flags, int nallocs, unsigned char* encoded_alloc_lens) { intnat whsize = Whsize_wosize (wosize); + value res; /* First, we un-do the allocation performed in [Alloc_small] */ Caml_state->young_ptr += whsize; @@ -561,10 +562,14 @@ void caml_alloc_small_dispatch (intnat wosize, int flags, while(1) { /* We might be here because of an async callback / urgent GC request. Take the opportunity to do what has been requested. */ - if (flags & CAML_FROM_CAML) + 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 ()); + res = caml_do_pending_actions_exn (); + if (Is_exception_result(res)) { + caml_raise_async(Extract_exception(res)); + } + } else { caml_check_urgent_gc (Val_unit); /* In the case of long-running C code that regularly polls with diff --git a/ocaml/runtime/printexc.c b/ocaml/runtime/printexc.c index 2828fdbc5ad..d75185f534b 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"); - if (at_exit != NULL) caml_callback_exn(*at_exit, Val_unit); + /* We use [caml_callback_async_exn] to ensure that, in the event of an + asynchronous exception occurring, it still gets caught here. */ + if (at_exit != NULL) caml_callback_async_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..516458e5a9a 100644 --- a/ocaml/runtime/signals.c +++ b/ocaml/runtime/signals.c @@ -153,7 +153,7 @@ 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()); caml_enter_blocking_section_hook (); /* Check again for pending signals. If none, done; otherwise, try again */ @@ -224,7 +224,7 @@ value caml_execute_signal_exn(int signal_number, int in_signal_handler) caml_sigmask_hook(SIG_SETMASK, &sigs, NULL); } #endif - return res; + return caml_check_async_exn(res, "signal handler"); } void caml_update_young_limit (void) @@ -318,7 +318,7 @@ 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); + return caml_raise_async_if_exception(res); } CAMLexport value caml_process_pending_actions_exn(void) @@ -329,7 +329,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 +486,6 @@ 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()); CAMLreturn (res); } diff --git a/ocaml/runtime/stacks.c b/ocaml/runtime/stacks.c index a1409b2abd7..04e5e44106f 100644 --- a/ocaml/runtime/stacks.c +++ b/ocaml/runtime/stacks.c @@ -51,7 +51,9 @@ void caml_realloc_stack(asize_t required_space) CAMLassert(Caml_state->extern_sp >= Caml_state->stack_low); size = Caml_state->stack_high - Caml_state->stack_low; do { - if (size >= caml_max_stack_size) caml_raise_stack_overflow(); + if (size >= caml_max_stack_size) { + caml_raise_stack_overflow(); + } size *= 2; } while (size < Caml_state->stack_high - Caml_state->extern_sp + required_space); 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..e85b4c469de --- /dev/null +++ b/ocaml/testsuite/tests/async-exns/async_exns_1.ml @@ -0,0 +1,31 @@ +(* TEST *) + +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) + +let () = + let finished = ref false in + let r = allocate_bytes finished in + try + Sys.with_async_exns (fun () -> + try + r := None; + while true do + let _ = Sys.opaque_identity (42, Random.int 42) in + () + done + with exn -> Printf.printf "wrong handler\n%!"; assert false + ) + with + | Sys.Break -> assert !finished; Printf.printf "OK\n%!" + | _ -> 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..d86bac9de59 --- /dev/null +++ b/ocaml/testsuite/tests/async-exns/async_exns_1.reference @@ -0,0 +1 @@ +OK 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 -> () ;; From a80743be2b7f757cdf17d39696c47869c2bba978 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 3 Oct 2022 10:13:36 +0100 Subject: [PATCH 2/6] Fix semantics --- ocaml/runtime/amd64.S | 20 ++-- ocaml/runtime/callback.c | 166 +++++++++++++++++++++------------- ocaml/runtime/caml/callback.h | 2 - ocaml/runtime/caml/fail.h | 7 +- ocaml/runtime/caml/interp.h | 3 +- ocaml/runtime/fail.c | 7 ++ ocaml/runtime/fail_byt.c | 15 +-- ocaml/runtime/fail_nat.c | 15 +-- ocaml/runtime/i386.S | 26 ++---- ocaml/runtime/interp.c | 6 +- ocaml/runtime/printexc.c | 6 +- ocaml/runtime/startup_byt.c | 8 +- 12 files changed, 148 insertions(+), 133 deletions(-) diff --git a/ocaml/runtime/amd64.S b/ocaml/runtime/amd64.S index 89b35ea6a6c..c6a4c1fbca9 100644 --- a/ocaml/runtime/amd64.S +++ b/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) diff --git a/ocaml/runtime/callback.c b/ocaml/runtime/callback.c index c2a09de0acd..4e6f13cc964 100644 --- a/ocaml/runtime/callback.c +++ b/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,33 +70,23 @@ 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) @@ -117,25 +94,60 @@ 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 @@ -143,30 +155,34 @@ CAMLexport value caml_callback_async_exn(value closure, value arg1) /* 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 { diff --git a/ocaml/runtime/caml/callback.h b/ocaml/runtime/caml/callback.h index 524f6afa455..eef3342ec78 100644 --- a/ocaml/runtime/caml/callback.h +++ b/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); diff --git a/ocaml/runtime/caml/fail.h b/ocaml/runtime/caml/fail.h index 872fc01a661..c727f507608 100644 --- a/ocaml/runtime/caml/fail.h +++ b/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 diff --git a/ocaml/runtime/caml/interp.h b/ocaml/runtime/caml/interp.h index 00d2de87edb..74f4563aba3 100644 --- a/ocaml/runtime/caml/interp.h +++ b/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 */ diff --git a/ocaml/runtime/fail.c b/ocaml/runtime/fail.c index 690117dd57c..29680180286 100644 --- a/ocaml/runtime/fail.c +++ b/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) { diff --git a/ocaml/runtime/fail_byt.c b/ocaml/runtime/fail_byt.c index 09e3a966653..36e2e797ba8 100644 --- a/ocaml/runtime/fail_byt.c +++ b/ocaml/runtime/fail_byt.c @@ -227,19 +227,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; -} - -CAMLexport value caml_raise_async_if_exception(value result) -{ - if (Is_exception_result(result)) caml_raise_async(Extract_exception(result)); - - return result; -} - 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 @@ -261,7 +248,7 @@ CAMLexport value caml_check_async_exn(value res, const char *msg) CAMLprim value caml_with_async_exns(value body_callback) { value exn; - value result = caml_callback_async_exn(body_callback, Val_unit); + value result = caml_callback_exn(body_callback, Val_unit); if (!Is_exception_result(result)) return result; diff --git a/ocaml/runtime/fail_nat.c b/ocaml/runtime/fail_nat.c index 3e786921636..b05ded8a31c 100644 --- a/ocaml/runtime/fail_nat.c +++ b/ocaml/runtime/fail_nat.c @@ -221,19 +221,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; -} - -CAMLexport value caml_raise_async_if_exception(value result) -{ - if (Is_exception_result(result)) caml_raise_async(Extract_exception(result)); - - return result; -} - /* 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]). */ @@ -273,7 +260,7 @@ CAMLexport value caml_check_async_exn(value res, const char *msg) CAMLprim value caml_with_async_exns(value body_callback) { value exn; - value result = caml_callback_async_exn(body_callback, Val_unit); + value result = caml_callback_exn(body_callback, Val_unit); if (!Is_exception_result(result)) return result; diff --git a/ocaml/runtime/i386.S b/ocaml/runtime/i386.S index c9d9c472549..ef062cd4961 100644 --- a/ocaml/runtime/i386.S +++ b/ocaml/runtime/i386.S @@ -409,6 +409,9 @@ FUNCTION(caml_callback_asm) movl 28(%esp), %edi /* arguments array */ movl 0(%edi), %eax /* arg1: argument */ movl 0(%ebx), %esi /* code pointer */ + movl 32(%esp), %ebp + cmp $1, %ebp + je LBL(106a) jmp LBL(106) CFI_ENDPROC ENDFUNCTION(caml_callback_asm) @@ -426,6 +429,9 @@ FUNCTION(caml_callback2_asm) movl 0(%edi), %eax /* arg1: first argument */ movl 4(%edi), %ebx /* arg2: second argument */ movl $ G(caml_apply2), %esi /* code pointer */ + movl 32(%esp), %ebp + cmp $1, %ebp + je LBL(106a) jmp LBL(106) CFI_ENDPROC ENDFUNCTION(caml_callback2_asm) @@ -444,27 +450,13 @@ FUNCTION(caml_callback3_asm) movl 4(%edi), %ebx /* arg2: second argument */ movl 8(%edi), %ecx /* arg3: third argument */ movl $ G(caml_apply3), %esi /* code pointer */ + movl 32(%esp), %ebp + cmp $1, %ebp + je LBL(106a) jmp LBL(106) CFI_ENDPROC ENDFUNCTION(caml_callback3_asm) -/* Variant of caml_callback_asm that installs an async exn trap frame. */ -FUNCTION(caml_callback_asm_async_exn) - CFI_STARTPROC - /* Save callee-save registers */ - pushl %ebx; CFI_ADJUST(4) - pushl %esi; CFI_ADJUST(4) - pushl %edi; CFI_ADJUST(4) - pushl %ebp; CFI_ADJUST(4) - /* Initial loading of arguments */ - movl 24(%esp), %ebx /* arg2: closure */ - movl 28(%esp), %edi /* arguments array */ - movl 0(%edi), %eax /* arg1: argument */ - movl 0(%ebx), %esi /* code pointer */ - jmp LBL(106a) - CFI_ENDPROC -ENDFUNCTION(caml_callback_asm_async_exn) - FUNCTION(caml_ml_array_bound_error) CFI_STARTPROC /* Empty the floating-point stack */ diff --git a/ocaml/runtime/interp.c b/ocaml/runtime/interp.c index ac53263f1c2..4c5ddb6d08d 100644 --- a/ocaml/runtime/interp.c +++ b/ocaml/runtime/interp.c @@ -211,7 +211,7 @@ static intnat caml_bcodcount; /* The interpreter itself */ -value caml_interprete(code_t prog, asize_t prog_size) +value caml_interprete(code_t prog, asize_t prog_size, int *returning_async_exn) { #ifdef PC_REG register code_t pc PC_REG; @@ -250,6 +250,8 @@ value caml_interprete(code_t prog, asize_t prog_size) }; #endif + if (returning_async_exn != NULL) *returning_async_exn = 0; + if (prog == NULL) { /* Interpreter is initializing */ #ifdef THREADED_CODE caml_instr_table = (char **) jumptable; @@ -306,6 +308,8 @@ value caml_interprete(code_t prog, asize_t prog_size) Caml_state->trapsp = (value *) ((char *) Caml_state->stack_high - initial_trapsp_offset); + if (returning_async_exn != NULL) *returning_async_exn = 1; + goto raise_notrace; } Caml_state->external_raise_async = &raise_async_buf; diff --git a/ocaml/runtime/printexc.c b/ocaml/runtime/printexc.c index d75185f534b..5a24738ec80 100644 --- a/ocaml/runtime/printexc.c +++ b/ocaml/runtime/printexc.c @@ -122,9 +122,9 @@ static void default_fatal_uncaught_exception(value exn, const char *msg2) saved_backtrace_pos = Caml_state->backtrace_pos; Caml_state->backtrace_active = 0; at_exit = caml_named_value("Pervasives.do_at_exit"); - /* We use [caml_callback_async_exn] to ensure that, in the event of an - asynchronous exception occurring, it still gets caught here. */ - if (at_exit != NULL) caml_callback_async_exn(*at_exit, Val_unit); + /* 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 */ diff --git a/ocaml/runtime/startup_byt.c b/ocaml/runtime/startup_byt.c index 95b38e72033..bd4a101e172 100644 --- a/ocaml/runtime/startup_byt.c +++ b/ocaml/runtime/startup_byt.c @@ -425,7 +425,7 @@ CAMLexport void caml_main(char_os **argv) caml_init_atom_table(); caml_init_backtrace(); /* Initialize the interpreter */ - caml_interprete(NULL, 0); + caml_interprete(NULL, 0, NULL); /* Initialize the debugger, if needed */ caml_debugger_init(); /* Load the code */ @@ -466,7 +466,7 @@ CAMLexport void caml_main(char_os **argv) #endif /* Execute the program */ caml_debugger(PROGRAM_START, Val_unit); - res = caml_interprete(caml_start_code, caml_code_size); + res = caml_interprete(caml_start_code, caml_code_size, NULL); if (Is_exception_result(res)) { Caml_state->exn_bucket = Extract_exception(res); if (caml_debugger_in_use) { @@ -527,7 +527,7 @@ CAMLexport value caml_startup_code_exn( caml_init_atom_table(); caml_init_backtrace(); /* Initialize the interpreter */ - caml_interprete(NULL, 0); + caml_interprete(NULL, 0, NULL); /* Initialize the debugger, if needed */ caml_debugger_init(); /* Load the code */ @@ -557,7 +557,7 @@ CAMLexport value caml_startup_code_exn( caml_load_main_debug_info(); /* Execute the program */ caml_debugger(PROGRAM_START, Val_unit); - return caml_interprete(caml_start_code, caml_code_size); + return caml_interprete(caml_start_code, caml_code_size, NULL); } CAMLexport void caml_startup_code( From 05d64eef410c816ea0817efaafb74dcbbd55d1e3 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 3 Oct 2022 13:56:20 +0100 Subject: [PATCH 3/6] More test cases --- .../tests/async-exns/async_exns_1.ml | 168 +++++++++++++++++- .../tests/async-exns/async_exns_stubs.c | 72 ++++++++ 2 files changed, 237 insertions(+), 3 deletions(-) create mode 100644 ocaml/testsuite/tests/async-exns/async_exns_stubs.c diff --git a/ocaml/testsuite/tests/async-exns/async_exns_1.ml b/ocaml/testsuite/tests/async-exns/async_exns_1.ml index e85b4c469de..af169230d1d 100644 --- a/ocaml/testsuite/tests/async-exns/async_exns_1.ml +++ b/ocaml/testsuite/tests/async-exns/async_exns_1.ml @@ -1,4 +1,6 @@ -(* TEST *) +(* TEST + modules = "async_exns_stubs.c" +*) let () = Sys.catch_break true @@ -12,6 +14,9 @@ let[@inline never] allocate_bytes finished = 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 @@ -20,12 +25,169 @@ let () = 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 "wrong handler\n%!"; assert false + with exn -> Printf.printf "1. wrong handler\n%!"; assert false ) with - | Sys.Break -> assert !finished; Printf.printf "OK\n%!" + | 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 test_caml_callback_reraises_async_exns_as_async_exns + : (unit -> unit) -> unit + = "test_caml_callback_reraises_async_exns_as_async_exns" + +(* 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 + test_caml_callback_reraises_async_exns_as_async_exns + 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 test_caml_callback2_reraises_async_exns_as_async_exns + : (unit -> unit -> unit) -> unit + = "test_caml_callback2_reraises_async_exns_as_async_exns" + +let () = + try + Sys.with_async_exns (fun () -> + try + test_caml_callback2_reraises_async_exns_as_async_exns + 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 test_caml_callback3_reraises_async_exns_as_async_exns + : (unit -> unit -> unit -> unit) -> unit + = "test_caml_callback3_reraises_async_exns_as_async_exns" + +let () = + try + Sys.with_async_exns (fun () -> + try + test_caml_callback3_reraises_async_exns_as_async_exns + 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 test_caml_callbackN_reraises_async_exns_as_async_exns + : (unit -> unit -> unit -> unit -> unit) -> unit + = "test_caml_callbackN_reraises_async_exns_as_async_exns" + +let () = + try + Sys.with_async_exns (fun () -> + try + test_caml_callbackN_reraises_async_exns_as_async_exns + raise_break_from_finaliser4 + with exn -> Printf.printf "4d. wrong handler\n%!"; assert false + ) + with + | Sys.Break -> Printf.printf "4d. OK\n%!" + | _ -> assert false 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..60f23bc7678 --- /dev/null +++ b/ocaml/testsuite/tests/async-exns/async_exns_stubs.c @@ -0,0 +1,72 @@ +#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 test_caml_callback_reraises_async_exns_as_async_exns( + value raise_break_async) +{ + return caml_callback(raise_break_async, Val_unit); +} + +value test_caml_callback2_reraises_async_exns_as_async_exns( + value raise_break_async) +{ + return caml_callback2(raise_break_async, Val_unit, Val_unit); +} + +value test_caml_callback3_reraises_async_exns_as_async_exns( + value raise_break_async) +{ + return caml_callback3(raise_break_async, Val_unit, Val_unit, Val_unit); +} + +value test_caml_callbackN_reraises_async_exns_as_async_exns( + value raise_break_async) +{ + value args[] = { Val_unit, Val_unit, Val_unit, Val_unit }; + return caml_callbackN(raise_break_async, 4, args); +} From ea464277ebe4521c451739ce6f285902bfc412d4 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 3 Oct 2022 14:04:02 +0100 Subject: [PATCH 4/6] More test cases 2 --- .../tests/async-exns/async_exns_1.ml | 82 ++++++++++++++----- .../tests/async-exns/async_exns_stubs.c | 12 +-- 2 files changed, 66 insertions(+), 28 deletions(-) diff --git a/ocaml/testsuite/tests/async-exns/async_exns_1.ml b/ocaml/testsuite/tests/async-exns/async_exns_1.ml index af169230d1d..5bc0388c193 100644 --- a/ocaml/testsuite/tests/async-exns/async_exns_1.ml +++ b/ocaml/testsuite/tests/async-exns/async_exns_1.ml @@ -120,18 +120,16 @@ let () = with | _ -> assert false -external test_caml_callback_reraises_async_exns_as_async_exns +external invoke_caml_callback : (unit -> unit) -> unit - = "test_caml_callback_reraises_async_exns_as_async_exns" + = "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 - test_caml_callback_reraises_async_exns_as_async_exns - raise_break_from_finaliser + try invoke_caml_callback raise_break_from_finaliser with exn -> Printf.printf "4a. wrong handler\n%!"; assert false ) with @@ -140,16 +138,14 @@ let () = (* Same but for a 2-parameter callback *) -external test_caml_callback2_reraises_async_exns_as_async_exns +external invoke_caml_callback2 : (unit -> unit -> unit) -> unit - = "test_caml_callback2_reraises_async_exns_as_async_exns" + = "invoke_caml_callback2" let () = try Sys.with_async_exns (fun () -> - try - test_caml_callback2_reraises_async_exns_as_async_exns - raise_break_from_finaliser2 + try invoke_caml_callback2 raise_break_from_finaliser2 with exn -> Printf.printf "4b. wrong handler\n%!"; assert false ) with @@ -158,16 +154,14 @@ let () = (* Same but for a 3-parameter callback *) -external test_caml_callback3_reraises_async_exns_as_async_exns +external invoke_caml_callback3 : (unit -> unit -> unit -> unit) -> unit - = "test_caml_callback3_reraises_async_exns_as_async_exns" + = "invoke_caml_callback3" let () = try Sys.with_async_exns (fun () -> - try - test_caml_callback3_reraises_async_exns_as_async_exns - raise_break_from_finaliser3 + try invoke_caml_callback3 raise_break_from_finaliser3 with exn -> Printf.printf "4c. wrong handler\n%!"; assert false ) with @@ -176,18 +170,66 @@ let () = (* Same but for a 4-parameter callback *) -external test_caml_callbackN_reraises_async_exns_as_async_exns +external invoke_caml_callbackN : (unit -> unit -> unit -> unit -> unit) -> unit - = "test_caml_callbackN_reraises_async_exns_as_async_exns" + = "invoke_caml_callbackN" let () = try Sys.with_async_exns (fun () -> - try - test_caml_callbackN_reraises_async_exns_as_async_exns - raise_break_from_finaliser4 + 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_stubs.c b/ocaml/testsuite/tests/async-exns/async_exns_stubs.c index 60f23bc7678..8675a815544 100644 --- a/ocaml/testsuite/tests/async-exns/async_exns_stubs.c +++ b/ocaml/testsuite/tests/async-exns/async_exns_stubs.c @@ -46,26 +46,22 @@ value test_caml_callbackN_exn_collects_async_exns(value raise_break_async) return Val_unit; } -value test_caml_callback_reraises_async_exns_as_async_exns( - value raise_break_async) +value invoke_caml_callback(value raise_break_async) { return caml_callback(raise_break_async, Val_unit); } -value test_caml_callback2_reraises_async_exns_as_async_exns( - value raise_break_async) +value invoke_caml_callback2(value raise_break_async) { return caml_callback2(raise_break_async, Val_unit, Val_unit); } -value test_caml_callback3_reraises_async_exns_as_async_exns( - value raise_break_async) +value invoke_caml_callback3(value raise_break_async) { return caml_callback3(raise_break_async, Val_unit, Val_unit, Val_unit); } -value test_caml_callbackN_reraises_async_exns_as_async_exns( - value raise_break_async) +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); From 3d977a91f003a31e4de2c0e2525f18947bf7ad58 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 3 Oct 2022 14:28:50 +0100 Subject: [PATCH 5/6] Update reference file --- .../tests/async-exns/async_exns_1.reference | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/ocaml/testsuite/tests/async-exns/async_exns_1.reference b/ocaml/testsuite/tests/async-exns/async_exns_1.reference index d86bac9de59..9290ae2fb59 100644 --- a/ocaml/testsuite/tests/async-exns/async_exns_1.reference +++ b/ocaml/testsuite/tests/async-exns/async_exns_1.reference @@ -1 +1,14 @@ -OK +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 From 0efc8443b4129e0c619b2f7624bc2bced83bbe47 Mon Sep 17 00:00:00 2001 From: Stephen Dolan Date: Tue, 11 Oct 2022 17:48:32 +0100 Subject: [PATCH 6/6] Simplify the implementation of new asynchronous exception semantics (#19) * Simplify the implementation of new asynchronous exception semantics - Use a flag in Caml_state to indicate whether an async exception is being raised, removing the need for two versions of caml_start_program - Use the same flag mechanism to distinguish async exceptions on both bytecode and native code - Check that only Break may be raised from async callbacks at the point of *raising*, rather than at the point of running the callback - No longer propagate Stack_overflow from async callbacks to the main program - Simplify raising logic by removing prepare_for_raise, as there is no longer a need to carefully avoid caml_raise recursion (Now, caml_raise may trigger callbacks, which may trigger caml_raise_async, which can trigger no further work) - Revert a change to setsigmask behaviour in interp.c - caml_raise_out_of_memory_fatal renamed to caml_fatal_out_of_memory, and is always a fatal error on both bytecode and native * review * comments --- ocaml/otherlibs/systhreads/st_stubs.c | 6 +- ocaml/runtime/Makefile | 4 +- ocaml/runtime/amd64.S | 26 +---- ocaml/runtime/callback.c | 141 ++++++++++++++------------ ocaml/runtime/caml/domain_state.tbl | 3 + ocaml/runtime/caml/fail.h | 18 +--- ocaml/runtime/caml/interp.h | 3 +- ocaml/runtime/caml/misc.h | 4 + ocaml/runtime/domain.c | 1 + ocaml/runtime/dune | 6 +- ocaml/runtime/fail.c | 87 ---------------- ocaml/runtime/fail_byt.c | 67 ++---------- ocaml/runtime/fail_nat.c | 99 +++++------------- ocaml/runtime/finalise.c | 3 +- ocaml/runtime/gc_ctrl.c | 10 +- ocaml/runtime/gen_primitives.sh | 2 +- ocaml/runtime/i386.S | 32 +----- ocaml/runtime/interp.c | 10 +- ocaml/runtime/memory.c | 16 ++- ocaml/runtime/memprof.c | 8 +- ocaml/runtime/minor_gc.c | 13 +-- ocaml/runtime/misc.c | 5 + ocaml/runtime/signals.c | 46 ++++++++- ocaml/runtime/stacks.c | 4 +- ocaml/runtime/startup_byt.c | 8 +- ocaml/runtime/startup_nat.c | 7 +- 26 files changed, 222 insertions(+), 407 deletions(-) delete mode 100644 ocaml/runtime/fail.c diff --git a/ocaml/otherlibs/systhreads/st_stubs.c b/ocaml/otherlibs/systhreads/st_stubs.c index 6f4839553e4..aaf47f3cce4 100644 --- a/ocaml/otherlibs/systhreads/st_stubs.c +++ b/ocaml/otherlibs/systhreads/st_stubs.c @@ -730,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_async_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_async_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/Makefile b/ocaml/runtime/Makefile index d1542c950bd..b89decafd63 100644 --- a/ocaml/runtime/Makefile +++ b/ocaml/runtime/Makefile @@ -21,7 +21,7 @@ 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 fail_byt signals \ + minor_gc memory alloc roots_byt globroots 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 \ @@ -29,7 +29,7 @@ BYTECODE_C_SOURCES := $(addsuffix .c, \ skiplist codefrag) NATIVE_C_SOURCES := $(addsuffix .c, \ - startup_aux startup_nat main fail fail_nat roots_nat signals \ + startup_aux startup_nat main 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 \ diff --git a/ocaml/runtime/amd64.S b/ocaml/runtime/amd64.S index c6a4c1fbca9..ca1d18b0939 100644 --- a/ocaml/runtime/amd64.S +++ b/ocaml/runtime/amd64.S @@ -573,22 +573,11 @@ FUNCTION(G(caml_start_program)) movq C_ARG_1, %r14 /* Initial entry point is G(caml_program) */ LEA_VAR(caml_program, %r12) -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. */ + /* Common code for caml_start_program and caml_callback* */ 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 */ + 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) @@ -599,6 +588,7 @@ LBL(107a): 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): @@ -612,8 +602,6 @@ 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) - /* 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 @@ -727,8 +715,6 @@ 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)) @@ -743,8 +729,6 @@ 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)) @@ -760,8 +744,6 @@ 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)) diff --git a/ocaml/runtime/callback.c b/ocaml/runtime/callback.c index 4e6f13cc964..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 */ @@ -53,8 +66,7 @@ static void init_callback_code(void) /* Functions that return all exceptions, including asynchronous ones */ -static value caml_callbackN_exn0(value closure, int narg, value args[], - int *returning_async_exn) +static value caml_callbackN_exn0(value closure, int narg, value args[]) { int i; value res; @@ -70,41 +82,47 @@ 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), - returning_async_exn); + res = caml_interprete(callback_code, sizeof(callback_code)); if (Is_exception_result(res)) Caml_state->extern_sp += narg + 4; /* PR#3419 */ - return res; } CAMLexport value caml_callbackN_exn(value closure, int narg, value args[]) { - return caml_callbackN_exn0(closure, narg, args, NULL); + 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_exn0(closure, 1, arg, NULL); + 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_exn0(closure, 2, arg, NULL); + 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 arg[3]; + value res, arg[3]; arg[0] = arg1; arg[1] = arg2; arg[2] = arg3; - return caml_callbackN_exn0(closure, 3, arg, NULL); + res = caml_callbackN_exn0(closure, 3, arg); + Caml_state->raising_async_exn = 0; + return res; } /* Functions that propagate all exceptions, with any asynchronous exceptions @@ -112,17 +130,7 @@ CAMLexport value caml_callback3_exn(value closure, 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; + return raise_if_exception(caml_callbackN_exn0(closure, narg, args)); } CAMLexport value caml_callback(value closure, value arg1) @@ -155,34 +163,28 @@ CAMLexport value caml_callback3(value closure, /* Native-code callbacks. */ typedef value (callback_stub)(caml_domain_state* state, value closure, - value* args, int catch_async_exns); + value* args); callback_stub caml_callback_asm, caml_callback2_asm, caml_callback3_asm; -/* 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) +static value callback(value closure, value arg) { - return caml_callback_asm(Caml_state, closure, &arg, catch_async_exns); + return caml_callback_asm(Caml_state, closure, &arg); } -static value callback2(value closure, value arg1, value arg2, - int catch_async_exns) +static value callback2(value closure, value arg1, value arg2) { value args[] = {arg1, arg2}; - return caml_callback2_asm(Caml_state, closure, args, catch_async_exns); + return caml_callback2_asm(Caml_state, closure, args); } -static value callback3(value closure, value arg1, value arg2, value arg3, - int catch_async_exns) +static value callback3(value closure, value arg1, value arg2, value arg3) { value args[] = {arg1, arg2, arg3}; - return caml_callback3_asm(Caml_state, closure, args, catch_async_exns); + return caml_callback3_asm(Caml_state, closure, args); } -static value callbackN(value closure, int narg, value args[], - int catch_async_exns) +static value callbackN(value closure, int narg, value args[]) { CAMLparam1 (closure); CAMLxparamN (args, narg); @@ -194,17 +196,17 @@ static value callbackN(value closure, int narg, value args[], /* Pass as many arguments as possible */ switch (narg - i) { case 1: - res = callback(res, args[i], catch_async_exns); + res = callback(res, args[i]); if (Is_exception_result(res)) CAMLreturn (res); i += 1; break; case 2: - res = callback2(res, args[i], args[i + 1], catch_async_exns); + res = callback2(res, args[i], args[i + 1]); if (Is_exception_result(res)) CAMLreturn (res); i += 2; break; default: - res = callback3(res, args[i], args[i + 1], args[i + 2], catch_async_exns); + res = callback3(res, args[i], args[i + 1], args[i + 2]); if (Is_exception_result(res)) CAMLreturn (res); i += 3; break; @@ -217,60 +219,71 @@ static value callbackN(value closure, int narg, value args[], CAMLexport value caml_callback_exn(value closure, value arg) { - return callback(closure, arg, 1); + value res = callback(closure, arg); + Caml_state->raising_async_exn = 0; + return res; } CAMLexport value caml_callback2_exn(value closure, value arg1, value arg2) { - return callback2(closure, arg1, arg2, 1); + value res = callback2(closure, arg1, arg2); + Caml_state->raising_async_exn = 0; + return res; } -CAMLexport value caml_callback3_exn(value closure, - value arg1, value arg2, value arg3) +CAMLexport value caml_callback3_exn(value closure, value arg1, value arg2, + value arg3) { - return callback3(closure, arg1, arg2, arg3, 1); + 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[]) { - return callbackN(closure, narg, args, 1); + 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. 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). */ + also being propagated asynchronously. */ -static value raise_if_exception(value res) +CAMLexport value caml_callback (value closure, value arg) { - if (Is_exception_result(res)) caml_raise(Extract_exception(res)); - return res; + return raise_if_exception(callback(closure, arg)); } -CAMLexport value caml_callback(value closure, value arg) +CAMLexport value caml_callback2 (value closure, value arg1, value arg2) { - return raise_if_exception(callback(closure, arg, 0)); + return raise_if_exception(callback2(closure, arg1, arg2)); } -CAMLexport value caml_callback2(value closure, value arg1, value arg2) +CAMLexport value caml_callback3 (value closure, value arg1, value arg2, + value arg3) { - return raise_if_exception(callback2(closure, arg1, arg2, 0)); + return raise_if_exception(callback3(closure, arg1, arg2, arg3)); } -CAMLexport value caml_callback3(value closure, - value arg1, value arg2, value arg3) +CAMLexport value caml_callbackN (value closure, int narg, value args[]) { - return raise_if_exception(callback3(closure, arg1, arg2, arg3, 0)); + return raise_if_exception(callbackN(closure, narg, args)); } -CAMLexport value caml_callbackN (value closure, int narg, value args[]) +#endif + +CAMLprim value caml_with_async_exns(value body_callback) { - return raise_if_exception(callbackN(closure, narg, args, 0)); + 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; } -#endif /* Naming of OCaml values */ diff --git a/ocaml/runtime/caml/domain_state.tbl b/ocaml/runtime/caml/domain_state.tbl index f540605612a..a560becf44a 100644 --- a/ocaml/runtime/caml/domain_state.tbl +++ b/ocaml/runtime/caml/domain_state.tbl @@ -64,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 c727f507608..17a0413df10 100644 --- a/ocaml/runtime/caml/fail.h +++ b/ocaml/runtime/caml/fail.h @@ -63,21 +63,9 @@ 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); - -/* 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_async_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) @@ -129,10 +117,6 @@ 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; diff --git a/ocaml/runtime/caml/interp.h b/ocaml/runtime/caml/interp.h index 74f4563aba3..00d2de87edb 100644 --- a/ocaml/runtime/caml/interp.h +++ b/ocaml/runtime/caml/interp.h @@ -24,8 +24,7 @@ #include "mlvalues.h" /* interpret a bytecode */ -value caml_interprete (code_t prog, asize_t prog_size, - int *returning_async_exn); +value caml_interprete (code_t prog, asize_t prog_size); #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/domain.c b/ocaml/runtime/domain.c index 78a01de684a..f6b9ce8cdb8 100644 --- a/ocaml/runtime/domain.c +++ b/ocaml/runtime/domain.c @@ -78,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/dune b/ocaml/runtime/dune index eff2c1fe507..703b7e118b7 100644 --- a/ocaml/runtime/dune +++ b/ocaml/runtime/dune @@ -23,7 +23,7 @@ callback.c weak.c finalise.c stacks.c dynlink.c backtrace_byt.c backtrace.c afl.c - bigarray.c eventlog.c fail_nat.c) + bigarray.c eventlog.c) (action (with-stdout-to %{targets} (run %{dep:gen_primitives.sh})))) ; Shouldn't this use foreign build sandboxing? @@ -36,7 +36,7 @@ (glob_files caml/*.h) interp.c misc.c stacks.c fix_code.c startup_aux.c startup_byt.c freelist.c major_gc.c minor_gc.c memory.c alloc.c roots_byt.c - globroots.c fail.c fail_byt.c signals.c signals_byt.c printexc.c + globroots.c fail_byt.c signals.c signals_byt.c printexc.c backtrace_byt.c backtrace.c compare.c ints.c floats.c str.c array.c io.c extern.c intern.c hash.c sys.c meta.c parsing.c gc_ctrl.c md5.c obj.c lexing.c callback.c debugger.c weak.c compact.c finalise.c @@ -60,7 +60,7 @@ (deps ../Makefile.config ../Makefile.common ../Makefile.build_config ../Makefile.config_if_required Makefile (glob_files caml/*.h) signals_osdep.h amd64.S - startup_aux.c startup_nat.c main.c fail.c fail_nat.c roots_nat.c signals.c + startup_aux.c startup_nat.c main.c fail_nat.c roots_nat.c signals.c signals_nat.c misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c compare.c ints.c floats.c str.c array.c io.c extern.c intern.c hash.c sys.c parsing.c gc_ctrl.c md5.c obj.c lexing.c unix.c printexc.c callback.c weak.c diff --git a/ocaml/runtime/fail.c b/ocaml/runtime/fail.c deleted file mode 100644 index 29680180286..00000000000 --- a/ocaml/runtime/fail.c +++ /dev/null @@ -1,87 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* Mark Shinwell, Jane Street Europe */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* Copyright 2022 Jane Street Group LLC. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#define CAML_INTERNALS - -/* Code related to the raising of exceptions that is shared between - the bytecode and native code runtimes. */ - -#include "caml/fail.h" -#include "caml/memory.h" -#include "caml/mlvalues.h" -#include "caml/printexc.h" -#include "caml/signals.h" -#include "caml/io.h" -#include "caml/callback.h" - -CAMLno_asan -CAMLexport value caml_prepare_for_raise(value v, int *turned_into_async_exn) -{ - 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] should now be raised as an asynchronous exception. - - if (turned_into_async_exn != NULL) - *turned_into_async_exn = 1; - } - else - { - if (turned_into_async_exn != NULL) - *turned_into_async_exn = 0; - } - - 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) -{ - value exn; - const value *break_exn; - - if (!Is_exception_result(res)) - return res; - - exn = Extract_exception(res); - - if (exn == stack_overflow_exn) - return 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 res; - - caml_fatal_uncaught_exception_with_message(exn, msg); -} diff --git a/ocaml/runtime/fail_byt.c b/ocaml/runtime/fail_byt.c index 36e2e797ba8..7e0c0d807dd 100644 --- a/ocaml/runtime/fail_byt.c +++ b/ocaml/runtime/fail_byt.c @@ -31,43 +31,28 @@ #include "caml/signals.h" #include "caml/stacks.h" -static void prepare_for_raise(value v, int *turned_into_async_exn) -{ - v = caml_prepare_for_raise(v, turned_into_async_exn); - Caml_state->exn_bucket = v; -} - CAMLexport void caml_raise(value v) { - int turned_into_async_exn = 0; - prepare_for_raise(v, &turned_into_async_exn); + Unlock_exn(); + CAMLassert(!Is_exception_result(v)); - if (turned_into_async_exn) - { - if (Caml_state->external_raise_async == NULL) { - caml_fatal_uncaught_exception(v); - } + v = caml_process_pending_actions_with_root(v); - siglongjmp(Caml_state->external_raise_async->buf, 1); - } - else - { - if (Caml_state->external_raise == NULL) - caml_fatal_uncaught_exception(v); - - siglongjmp(Caml_state->external_raise->buf, 1); - } + 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) { - prepare_for_raise(v, NULL); + 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); } @@ -186,11 +171,6 @@ CAMLexport void caml_raise_out_of_memory(void) caml_raise_constant(Field(caml_global_data, OUT_OF_MEMORY_EXN)); } -CAMLexport void caml_raise_out_of_memory_fatal(void) -{ - caml_raise_out_of_memory(); -} - CAMLexport void caml_raise_stack_overflow(void) { check_global_data("Stack_overflow"); @@ -237,30 +217,3 @@ int caml_is_special_exception(value exn) { || exn == Field(caml_global_data, ASSERT_FAILURE_EXN) || exn == Field(caml_global_data, UNDEFINED_RECURSIVE_MODULE_EXN); } - -CAMLexport value caml_check_async_exn(value res, const char *msg) -{ - check_global_data("Stack_overflow"); - return caml_check_async_exn0(res, msg, - Field(caml_global_data, STACK_OVERFLOW_EXN)); -} - -CAMLprim value caml_with_async_exns(value body_callback) -{ - value exn; - value result = caml_callback_exn(body_callback, Val_unit); - - if (!Is_exception_result(result)) - return result; - - exn = Extract_exception(result); - - /* Irrespective as to whether the exception was asynchronous, it is raised as - a normal exception, without any processing of pending actions. */ - - if (Caml_state->external_raise == NULL) - caml_fatal_uncaught_exception(exn); - - Caml_state->exn_bucket = exn; - siglongjmp(Caml_state->external_raise->buf, 1); -} diff --git a/ocaml/runtime/fail_nat.c b/ocaml/runtime/fail_nat.c index b05ded8a31c..2763783889d 100644 --- a/ocaml/runtime/fail_nat.c +++ b/ocaml/runtime/fail_nat.c @@ -54,14 +54,10 @@ extern caml_generated_constant /* Exception raising */ CAMLnoreturn_start -extern void caml_raise_exception(caml_domain_state *state, value bucket) + extern void caml_raise_exception (caml_domain_state* state, value bucket) CAMLnoreturn_end; -CAMLnoreturn_start -void caml_raise_async_exception(value bucket) -CAMLnoreturn_end; - -CAMLno_asan static void unwind_local_roots(char *exception_pointer) +static void unwind_local_roots(char *exception_pointer) { while (Caml_state->local_roots != NULL && (char *)Caml_state->local_roots < exception_pointer) @@ -70,47 +66,41 @@ CAMLno_asan static void unwind_local_roots(char *exception_pointer) } } -CAMLno_asan void caml_raise_async_exception(value v) +void caml_raise(value v) { - Caml_state->exception_pointer = Caml_state->async_exception_pointer; - caml_raise_exception(Caml_state, v); -} + Unlock_exn(); -/* Used by the stack overflow handler -> deactivate ASAN (see - segv_handler in signals_nat.c). */ -CAMLno_asan -void caml_raise(value exn) -{ - int turned_into_async_exn = 0; - exn = caml_prepare_for_raise(exn, &turned_into_async_exn); + CAMLassert(!Is_exception_result(v)); - if (turned_into_async_exn) - { - if (Caml_state->async_exception_pointer == NULL) - caml_fatal_uncaught_exception(exn); + /* 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); - unwind_local_roots(Caml_state->async_exception_pointer); - caml_raise_async_exception(exn); - } - else - { - if (Caml_state->exception_pointer == NULL) - caml_fatal_uncaught_exception(exn); + if (Caml_state->exception_pointer == NULL) caml_fatal_uncaught_exception(v); - unwind_local_roots(Caml_state->exception_pointer); - caml_raise_exception(Caml_state, exn); - } + unwind_local_roots(Caml_state->exception_pointer); + caml_raise_exception(Caml_state, v); } -CAMLno_asan void caml_raise_async(value exn) + +/* Used by the stack overflow handler -> deactivate ASAN (see + segv_handler in signals_nat.c). */ +CAMLno_asan void caml_raise_async(value v) { - exn = caml_prepare_for_raise(exn, NULL); + 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(exn); + caml_fatal_uncaught_exception(v); unwind_local_roots(Caml_state->async_exception_pointer); - caml_raise_async_exception(exn); + Caml_state->exception_pointer = Caml_state->async_exception_pointer; + Caml_state->raising_async_exn = 1; + caml_raise_exception(Caml_state, v); } /* Used by the stack overflow handler -> deactivate ASAN (see @@ -182,12 +172,6 @@ void caml_raise_out_of_memory(void) caml_raise_constant((value) caml_exn_Out_of_memory); } -void caml_raise_out_of_memory_fatal(void) -{ - fprintf(stderr, "[ocaml] Out of memory\n"); - abort(); -} - /* Used by the stack overflow handler -> deactivate ASAN (see segv_handler in signals_nat.c). */ CAMLno_asan @@ -229,12 +213,10 @@ static const value * caml_array_bound_error_exn = NULL; void caml_array_bound_error(void) { - if (caml_array_bound_error_exn == NULL) - { + if (caml_array_bound_error_exn == NULL) { caml_array_bound_error_exn = - caml_named_value("Pervasives.array_bound_error"); - if (caml_array_bound_error_exn == NULL) - { + caml_named_value("Pervasives.array_bound_error"); + if (caml_array_bound_error_exn == NULL) { fprintf(stderr, "Fatal error: exception " "Invalid_argument(\"index out of bounds\")\n"); exit(2); @@ -251,28 +233,3 @@ int caml_is_special_exception(value exn) { || exn == (value) caml_exn_Assert_failure || exn == (value) caml_exn_Undefined_recursive_module; } - -CAMLexport value caml_check_async_exn(value res, const char *msg) -{ - return caml_check_async_exn0(res, msg, (value) caml_exn_Stack_overflow); -} - -CAMLprim value caml_with_async_exns(value body_callback) -{ - value exn; - value result = caml_callback_exn(body_callback, Val_unit); - - if (!Is_exception_result(result)) - return result; - - exn = Extract_exception(result); - - /* Irrespective as to whether the exception was asynchronous, it is raised as - a normal exception, without any processing of pending actions. */ - - if (Caml_state->exception_pointer == NULL) - caml_fatal_uncaught_exception(exn); - - unwind_local_roots(Caml_state->exception_pointer); - caml_raise_exception(Caml_state, exn); -} diff --git a/ocaml/runtime/finalise.c b/ocaml/runtime/finalise.c index e3bffde40f9..46e1b7dd4fa 100644 --- a/ocaml/runtime/finalise.c +++ b/ocaml/runtime/finalise.c @@ -183,8 +183,7 @@ value caml_final_do_calls_exn (void) -- to_do_hd->size; f = to_do_hd->item[to_do_hd->size]; running_finalisation_function = 1; - res = caml_check_async_exn(caml_callback_exn (f.fun, f.val + f.offset), - "finaliser"); + res = caml_callback_exn (f.fun, f.val + f.offset); running_finalisation_function = 0; if (Is_exception_result (res)) return res; } diff --git a/ocaml/runtime/gc_ctrl.c b/ocaml/runtime/gc_ctrl.c index 63ae990d874..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_async_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_async_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_async_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_async_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_async_if_exception(exn); + caml_raise_async_if_exception(exn, ""); return Val_unit; } diff --git a/ocaml/runtime/gen_primitives.sh b/ocaml/runtime/gen_primitives.sh index c7e08e16a4c..a727d5c25cf 100755 --- a/ocaml/runtime/gen_primitives.sh +++ b/ocaml/runtime/gen_primitives.sh @@ -25,7 +25,7 @@ export LC_ALL=C alloc array compare extern floats gc_ctrl hash intern interp ints io \ lexing md5 meta memprof obj parsing signals str sys callback weak \ finalise stacks dynlink backtrace_byt backtrace afl \ - bigarray eventlog fail_nat + bigarray eventlog do sed -n -e 's/^CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p' "$prim.c" done diff --git a/ocaml/runtime/i386.S b/ocaml/runtime/i386.S index ef062cd4961..2f919356d44 100644 --- a/ocaml/runtime/i386.S +++ b/ocaml/runtime/i386.S @@ -272,25 +272,11 @@ FUNCTION(caml_start_program) pushl %ebp; CFI_ADJUST(4) /* Initial entry point is caml_program */ movl $ G(caml_program), %esi -LBL(106a): - /* Register the same exception handler as below for async exceptions */ - movl G(Caml_state), %edi - pushl CAML_STATE(async_exception_pointer, %edi); CFI_ADJUST(4) - subl $40, %esp - movl %esp, CAML_STATE(async_exception_pointer, %edi) - addl $40, %esp - ALIGN_STACK(12) /* must match below */ - jmp LBL(106b) - /* Common code for caml_start_program and caml_callback*. - If you update the stack pushes / stack pointer changes below, update - the number 24 above. */ + /* Common code for caml_start_program and caml_callback* */ LBL(106): - /* Save the current async exception pointer without disturbing the - alignment of the stack (see note below). */ movl G(Caml_state), %edi - pushl CAML_STATE(async_exception_pointer, %edi); CFI_ADJUST(4) ALIGN_STACK(12) -LBL(106b): + 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) @@ -301,6 +287,7 @@ LBL(106b): 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): @@ -314,10 +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) - /* Restore the asynchronous exception pointer (this will be a no-op - if this function was not invoked via [L106a]). */ - UNDO_ALIGN_STACK(12) 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) @@ -409,9 +394,6 @@ FUNCTION(caml_callback_asm) movl 28(%esp), %edi /* arguments array */ movl 0(%edi), %eax /* arg1: argument */ movl 0(%ebx), %esi /* code pointer */ - movl 32(%esp), %ebp - cmp $1, %ebp - je LBL(106a) jmp LBL(106) CFI_ENDPROC ENDFUNCTION(caml_callback_asm) @@ -429,9 +411,6 @@ FUNCTION(caml_callback2_asm) movl 0(%edi), %eax /* arg1: first argument */ movl 4(%edi), %ebx /* arg2: second argument */ movl $ G(caml_apply2), %esi /* code pointer */ - movl 32(%esp), %ebp - cmp $1, %ebp - je LBL(106a) jmp LBL(106) CFI_ENDPROC ENDFUNCTION(caml_callback2_asm) @@ -450,9 +429,6 @@ FUNCTION(caml_callback3_asm) movl 4(%edi), %ebx /* arg2: second argument */ movl 8(%edi), %ecx /* arg3: third argument */ movl $ G(caml_apply3), %esi /* code pointer */ - movl 32(%esp), %ebp - cmp $1, %ebp - je LBL(106a) jmp LBL(106) CFI_ENDPROC ENDFUNCTION(caml_callback3_asm) diff --git a/ocaml/runtime/interp.c b/ocaml/runtime/interp.c index 4c5ddb6d08d..6fac4212765 100644 --- a/ocaml/runtime/interp.c +++ b/ocaml/runtime/interp.c @@ -211,7 +211,7 @@ static intnat caml_bcodcount; /* The interpreter itself */ -value caml_interprete(code_t prog, asize_t prog_size, int *returning_async_exn) +value caml_interprete(code_t prog, asize_t prog_size) { #ifdef PC_REG register code_t pc PC_REG; @@ -250,8 +250,6 @@ value caml_interprete(code_t prog, asize_t prog_size, int *returning_async_exn) }; #endif - if (returning_async_exn != NULL) *returning_async_exn = 0; - if (prog == NULL) { /* Interpreter is initializing */ #ifdef THREADED_CODE caml_instr_table = (char **) jumptable; @@ -273,7 +271,7 @@ value caml_interprete(code_t prog, asize_t prog_size, int *returning_async_exn) caml_callback_depth++; - if (sigsetjmp(raise_buf.buf, 1)) { + if (sigsetjmp(raise_buf.buf, 0)) { Caml_state->local_roots = initial_local_roots; sp = Caml_state->extern_sp; accu = Caml_state->exn_bucket; @@ -289,7 +287,7 @@ value caml_interprete(code_t prog, asize_t prog_size, int *returning_async_exn) } Caml_state->external_raise = &raise_buf; - if (sigsetjmp(raise_async_buf.buf, 1)) { + if (sigsetjmp(raise_async_buf.buf, 0)) { Caml_state->local_roots = initial_local_roots; sp = Caml_state->extern_sp; accu = Caml_state->exn_bucket; @@ -308,8 +306,6 @@ value caml_interprete(code_t prog, asize_t prog_size, int *returning_async_exn) Caml_state->trapsp = (value *) ((char *) Caml_state->stack_high - initial_trapsp_offset); - if (returning_async_exn != NULL) *returning_async_exn = 1; - goto raise_notrace; } Caml_state->external_raise_async = &raise_async_buf; diff --git a/ocaml/runtime/memory.c b/ocaml/runtime/memory.c index 929ebdd5523..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_fatal (); + 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_fatal (); + 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_fatal(); + 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_fatal(); + 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_fatal(); + 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_fatal(); + 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_fatal(); + 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 42fede34f2b..db1af755612 100644 --- a/ocaml/runtime/memprof.c +++ b/ocaml/runtime/memprof.c @@ -450,7 +450,7 @@ Caml_inline value run_callback_exn( local->callback_status = ea == &entries_global ? t_idx : CB_LOCAL; t->running = local; t->user_data = Val_unit; /* Release root. */ - res = caml_check_async_exn(caml_callback_exn(cb, param), "memprof callback"); + res = caml_callback_exn(cb, param); if (local->callback_status == CB_STOPPED) { /* Make sure this entry has not been removed by [caml_memprof_stop] */ local->callback_status = CB_IDLE; @@ -963,11 +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)) { - value exn = Extract_exception(res); - if (from_caml) caml_raise_async(exn); - else caml_raise(exn); - } + 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 85e0079ec07..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_fatal(); + 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_fatal(); + caml_fatal_out_of_memory(); if (Caml_state->young_start != NULL){ caml_page_table_remove(In_young, Caml_state->young_start, @@ -554,7 +554,6 @@ void caml_alloc_small_dispatch (intnat wosize, int flags, int nallocs, unsigned char* encoded_alloc_lens) { intnat whsize = Whsize_wosize (wosize); - value res; /* First, we un-do the allocation performed in [Alloc_small] */ Caml_state->young_ptr += whsize; @@ -562,14 +561,10 @@ void caml_alloc_small_dispatch (intnat wosize, int flags, while(1) { /* We might be here because of an async callback / urgent GC request. Take the opportunity to do what has been requested. */ - if (flags & CAML_FROM_CAML) { + if (flags & CAML_FROM_CAML) /* In the case of allocations performed from OCaml, execute asynchronous callbacks. */ - res = caml_do_pending_actions_exn (); - if (Is_exception_result(res)) { - caml_raise_async(Extract_exception(res)); - } - } + 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/signals.c b/ocaml/runtime/signals.c index 516458e5a9a..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_async_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; @@ -224,7 +255,7 @@ value caml_execute_signal_exn(int signal_number, int in_signal_handler) caml_sigmask_hook(SIG_SETMASK, &sigs, NULL); } #endif - return caml_check_async_exn(res, "signal handler"); + return res; } void caml_update_young_limit (void) @@ -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_async_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_async_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_async_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/stacks.c b/ocaml/runtime/stacks.c index 04e5e44106f..a1409b2abd7 100644 --- a/ocaml/runtime/stacks.c +++ b/ocaml/runtime/stacks.c @@ -51,9 +51,7 @@ void caml_realloc_stack(asize_t required_space) CAMLassert(Caml_state->extern_sp >= Caml_state->stack_low); size = Caml_state->stack_high - Caml_state->stack_low; do { - if (size >= caml_max_stack_size) { - caml_raise_stack_overflow(); - } + if (size >= caml_max_stack_size) caml_raise_stack_overflow(); size *= 2; } while (size < Caml_state->stack_high - Caml_state->extern_sp + required_space); diff --git a/ocaml/runtime/startup_byt.c b/ocaml/runtime/startup_byt.c index bd4a101e172..95b38e72033 100644 --- a/ocaml/runtime/startup_byt.c +++ b/ocaml/runtime/startup_byt.c @@ -425,7 +425,7 @@ CAMLexport void caml_main(char_os **argv) caml_init_atom_table(); caml_init_backtrace(); /* Initialize the interpreter */ - caml_interprete(NULL, 0, NULL); + caml_interprete(NULL, 0); /* Initialize the debugger, if needed */ caml_debugger_init(); /* Load the code */ @@ -466,7 +466,7 @@ CAMLexport void caml_main(char_os **argv) #endif /* Execute the program */ caml_debugger(PROGRAM_START, Val_unit); - res = caml_interprete(caml_start_code, caml_code_size, NULL); + res = caml_interprete(caml_start_code, caml_code_size); if (Is_exception_result(res)) { Caml_state->exn_bucket = Extract_exception(res); if (caml_debugger_in_use) { @@ -527,7 +527,7 @@ CAMLexport value caml_startup_code_exn( caml_init_atom_table(); caml_init_backtrace(); /* Initialize the interpreter */ - caml_interprete(NULL, 0, NULL); + caml_interprete(NULL, 0); /* Initialize the debugger, if needed */ caml_debugger_init(); /* Load the code */ @@ -557,7 +557,7 @@ CAMLexport value caml_startup_code_exn( caml_load_main_debug_info(); /* Execute the program */ caml_debugger(PROGRAM_START, Val_unit); - return caml_interprete(caml_start_code, caml_code_size, NULL); + return caml_interprete(caml_start_code, caml_code_size); } CAMLexport void caml_startup_code( 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)