From 9eb9448e6d9637d13a4e521dc865b951c145b8b9 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 17 Oct 2022 16:16:18 +0100 Subject: [PATCH] flambda-backend: Backport the main safepoints PRs (#740) Co-authored-by: Xavier Clerc Co-authored-by: Greta Yorsh <45005955+gretay-js@users.noreply.github.com> --- runtime/caml/domain_state.tbl | 2 +- runtime/signals_nat.c | 21 +- testsuite/tests/asmgen/main.c | 8 + testsuite/tests/asmgen/mainarith.c | 4 + testsuite/tests/backend/polling.c | 18 ++ testsuite/tests/backend/polling_insertion.ml | 293 +++++++++++++++++++ 6 files changed, 339 insertions(+), 7 deletions(-) create mode 100644 testsuite/tests/backend/polling.c create mode 100644 testsuite/tests/backend/polling_insertion.ml diff --git a/runtime/caml/domain_state.tbl b/runtime/caml/domain_state.tbl index a560becf44a..0666a09f999 100644 --- a/runtime/caml/domain_state.tbl +++ b/runtime/caml/domain_state.tbl @@ -14,8 +14,8 @@ /* */ /**************************************************************************/ -DOMAIN_STATE(value*, young_ptr) DOMAIN_STATE(value*, young_limit) +DOMAIN_STATE(value*, young_ptr) /* Minor heap limit. See minor_gc.c. */ DOMAIN_STATE(char*, exception_pointer) diff --git a/runtime/signals_nat.c b/runtime/signals_nat.c index ca86956783c..484553235e5 100644 --- a/runtime/signals_nat.c +++ b/runtime/signals_nat.c @@ -79,14 +79,23 @@ void caml_garbage_collection(void) including allocations combined by Comballoc */ alloc_len = (unsigned char*)(&d->live_ofs[d->num_live]); nallocs = *alloc_len++; - for (i = 0; i < nallocs; i++) { - allocsz += Whsize_wosize(Wosize_encoded_alloc_len(alloc_len[i])); + + if (nallocs == 0) { + /* This is a poll */ + caml_process_pending_actions(); } - /* We have computed whsize (including header), but need wosize (without) */ - allocsz -= 1; + else + { + for (i = 0; i < nallocs; i++) { + allocsz += Whsize_wosize(Wosize_encoded_alloc_len(alloc_len[i])); + } - caml_alloc_small_dispatch(allocsz, CAML_DO_TRACK | CAML_FROM_CAML, - nallocs, alloc_len); + /* We have computed whsize (including header), but need wosize (without) */ + allocsz -= 1; + + caml_alloc_small_dispatch(allocsz, CAML_DO_TRACK | CAML_FROM_CAML, + nallocs, alloc_len); + } } DECLARE_SIGNAL_HANDLER(handle_signal) diff --git a/testsuite/tests/asmgen/main.c b/testsuite/tests/asmgen/main.c index 103e022baf0..975b54833e8 100644 --- a/testsuite/tests/asmgen/main.c +++ b/testsuite/tests/asmgen/main.c @@ -18,6 +18,14 @@ #include #include +/* This stub isn't needed for msvc32, since it's already in asmgen_i386nt.asm */ +#if !defined(_MSC_VER) || !defined(_M_IX86) +void caml_call_gc() +{ + +} +#endif + void caml_ml_array_bound_error(void) { fprintf(stderr, "Fatal error: out-of-bound access in array or string\n"); diff --git a/testsuite/tests/asmgen/mainarith.c b/testsuite/tests/asmgen/mainarith.c index 354ab02d391..ae4d1c50e05 100644 --- a/testsuite/tests/asmgen/mainarith.c +++ b/testsuite/tests/asmgen/mainarith.c @@ -22,6 +22,10 @@ #include #define FMT ARCH_INTNAT_PRINTF_FORMAT +void caml_call_poll() +{ +} + void caml_ml_array_bound_error(void) { fprintf(stderr, "Fatal error: out-of-bound access in array or string\n"); diff --git a/testsuite/tests/backend/polling.c b/testsuite/tests/backend/polling.c new file mode 100644 index 00000000000..c28baab048b --- /dev/null +++ b/testsuite/tests/backend/polling.c @@ -0,0 +1,18 @@ +#define CAML_NAME_SPACE +#define CAML_INTERNALS + +#include +#include + +CAMLprim value request_minor_gc(value v) { + Caml_state->requested_minor_gc = 1; + Caml_state->requested_major_slice = 1; + caml_something_to_do = 1; + Caml_state->young_limit = Caml_state->young_alloc_end; + + return Val_unit; +} + +CAMLprim value minor_gcs(value v) { + return Val_long(Caml_state->stat_minor_collections); +} diff --git a/testsuite/tests/backend/polling_insertion.ml b/testsuite/tests/backend/polling_insertion.ml new file mode 100644 index 00000000000..5be260faba4 --- /dev/null +++ b/testsuite/tests/backend/polling_insertion.ml @@ -0,0 +1,293 @@ +(* TEST + modules = "polling.c" + compare_programs = "false" + * arch64 + ** native +*) + +(* This set of tests examine poll insertion behaviour. We do this by requesting + and checking the number of minor collections at various points to determine + whether a poll was correctly added. There are some subtleties because + [caml_empty_minor_heap] will not increment the minor_collections stat if + nothing has been allocated on the minor heap, so we sometimes need to + add an allocation before we call [request_minor_gc]. The [minor_gcs] + function returns the number of minor collections so far without allocating. + + ignore(Sys.opaque_identity(ref 41)) is used wherever we want to do an + allocation in order to use some minor heap so the minor collections stat is + incremented. + + ignore(Sys.opaque_identity(ref 42)) is used wherever we want an allocation + for the purposes of testing whether a poll would be elided or not. +*) + +external request_minor_gc : unit -> unit = "request_minor_gc" +external minor_gcs : unit -> int = "minor_gcs" + +(* This function tests that polls are added to loops *) +let polls_added_to_loops () = + let minors_before = minor_gcs () in + request_minor_gc (); + for a = 0 to 1 do + ignore (Sys.opaque_identity 42) + done; + let minors_now = minor_gcs () in + assert (minors_before < minors_now) + + +(* This function should have no prologue poll but will have + one in the loop. *) +let func_with_added_poll_because_loop () = + (* We do two loop iterations so that the poll is triggered whether + in poll-at-top or poll-at-bottom mode. *) + for a = 0 to Sys.opaque_identity(1) do + ignore (Sys.opaque_identity 42) + done + [@@inline never] + +let func_with_no_prologue_poll () = + (* this function does not have indirect or 'forward' tail call nor + does it call a synthesised function with suppressed polls. *) + ignore(Sys.opaque_identity(minor_gcs ())) + [@@inline never] + +let prologue_polls_in_functions () = + ignore(Sys.opaque_identity(ref 41)); + let minors_before = minor_gcs () in + request_minor_gc (); + func_with_added_poll_because_loop (); + let minors_now = minor_gcs () in + assert (minors_before < minors_now); + + ignore(Sys.opaque_identity(ref 41)); + let minors_before = minor_gcs () in + request_minor_gc (); + func_with_no_prologue_poll (); + let minors_now = minor_gcs () in + assert (minors_before = minors_now) + +(* These next functions test that polls are not added to functions that + unconditionally allocate. + [allocating_func] allocates unconditionally + [allocating_func_if] allocates unconditionally but does so + on two separate branches *) +let allocating_func minors_before = + let minors_now = minor_gcs () in + assert (minors_before = minors_now); + (* No poll yet *) + ignore (Sys.opaque_identity (ref 42)); + let minors_now2 = minor_gcs () in + assert (minors_before + 1 = minors_now2); + (* Polled at alloc *) + [@@inline never] + +let allocating_func_if minors_before = + let minors_now = minor_gcs () in + assert (minors_before = minors_now); + (* No poll yet *) + if minors_before > 0 then ignore (Sys.opaque_identity (ref 42)) + else ignore (Sys.opaque_identity (ref 42)); + let minors_now2 = minor_gcs () in + assert (minors_before + 1 = minors_now2); + (* Polled at alloc *) + [@@inline never] + +let allocating_func_nested_ifs minors_before = + let minors_now = minor_gcs () in + assert (minors_before = minors_now); + (* No poll yet *) + if Sys.opaque_identity(minors_before) > 0 then + if Sys.opaque_identity(minors_before) > 1 then + ignore (Sys.opaque_identity (ref 42)) + else + ignore (Sys.opaque_identity (ref 42)) + else + if Sys.opaque_identity(minors_before) < 5 then + ignore (Sys.opaque_identity (ref 42)) + else + ignore (Sys.opaque_identity (ref 42)); + let minors_now2 = minor_gcs () in + assert (minors_before + 1 = minors_now2); + (* Polled at alloc *) + [@@inline never] + +let allocating_func_match minors_before = + let minors_now = minor_gcs () in + assert (minors_before = minors_now); + (* No poll yet *) + match minors_before with + | 0 -> ignore (Sys.opaque_identity (ref 42)) + | _ -> ignore (Sys.opaque_identity (ref 42)); + let minors_now2 = minor_gcs () in + assert (minors_before + 1 = minors_now2); + (* Polled at alloc *) + [@@inline never] + +let polls_not_added_unconditionally_allocating_functions () = + let minors_before = minor_gcs () in + ignore(Sys.opaque_identity(ref 41)); + request_minor_gc (); + allocating_func minors_before; + let minors_before = minor_gcs () in + ignore(Sys.opaque_identity(ref 41)); + request_minor_gc (); + allocating_func_if minors_before; + let minors_before = minor_gcs () in + ignore(Sys.opaque_identity(ref 41)); + request_minor_gc (); + allocating_func_nested_ifs minors_before; + let minors_before = minor_gcs () in + ignore(Sys.opaque_identity(ref 41)); + request_minor_gc (); + allocating_func_match minors_before + +(* This function tests that polls are not added to the back edge of + where loop bodies allocat unconditionally *) +let polls_not_added_to_allocating_loops () = + let current_minors = ref (minor_gcs ()) in + request_minor_gc (); + for a = 0 to 1 do + (* Since the loop body allocates there should be no poll points *) + let minors_now = minor_gcs () in + assert(minors_now = !current_minors); + ignore(Sys.opaque_identity(ref 42)); + let minors_now2 = minor_gcs () in + assert(minors_now+1 = minors_now2); + current_minors := minors_now2; + ignore(Sys.opaque_identity(ref 41)); + request_minor_gc () + done + +(* this next set of functions tests that self tail recursive functions + have polls added correctly *) +let rec self_rec_func n = + match n with + | 0 -> 0 + | _ -> + begin + let n1 = Sys.opaque_identity(n-1) in + (self_rec_func[@tailcall]) n1 + end + +let polls_added_to_self_recursive_functions () = + let minors_before = minor_gcs () in + request_minor_gc (); + ignore(self_rec_func 2); + let minors_after = minor_gcs () in + (* should be at least one minor gc from polls in self_rec_func *) + assert(minors_before+1 = minors_after) + +(* this pair of mutually recursive functions is to test that a poll is + correctly placed in the first one compiled *) +let rec mut_rec_func_even d = + match d with + | 0 -> 0 + | _ -> mut_rec_func_odd (d-1) +and mut_rec_func_odd d = + mut_rec_func_even (d-1) +and mut_rec_func d = + match d with + | n when n mod 2 == 0 + -> mut_rec_func_even n + | n -> mut_rec_func_odd n + +let polls_added_to_mutually_recursive_functions () = + let minors_before = minor_gcs () in + request_minor_gc (); + ignore(mut_rec_func 3); + let minors_after = minor_gcs () in + (* should be at least one minor gc from polls in mut_rec_func *) + assert(minors_before < minors_after) + +(* this is to test that indirect tail calls (which might result in a self + call) have polls inserted in them. + These correspond to Itailcall_ind at Mach *) +let do_indirect_tail_call f n = + f (n-1) + [@@inline never] + +let polls_added_to_indirect_tail_calls () = + let f = fun n -> n+1 in + let minors_before = minor_gcs () in + request_minor_gc (); + ignore(do_indirect_tail_call f 3); + let minors_after = minor_gcs () in + (* should be at one minor gc from the poll in do_indirect_tail_call *) + assert(minors_before+1 = minors_after) + +(* this is to test that indirect non-tail calls do not have a poll placed + in them. These correspond to Icall_ind at Mach *) +let do_indirect_call f n = + n * f (n-1) + [@@inline never] + +let polls_not_added_to_indirect_calls () = + let f = fun n -> n+1 in + let minors_before = minor_gcs () in + request_minor_gc (); + ignore(do_indirect_call f 3); + let minors_after = minor_gcs () in + (* should be at one minor gc from the poll in do_indirect_tail_call *) + assert(minors_before = minors_after) + +(* this set of functions tests that we don't poll for immediate + (non-tail) calls. These correspond to Icall_imm at Mach *) +let call_func1 n = + Sys.opaque_identity(n-1) + [@@inline never] + +let call_func2 n = + n * (call_func1 (Sys.opaque_identity(n+1))) + [@@inline never] + +let polls_not_added_to_immediate_calls () = + let minors_before = minor_gcs () in + request_minor_gc (); + ignore(call_func1 100); + let minors_after = minor_gcs () in + (* should be no minor collections *) + assert(minors_before = minors_after) + +let[@inline never][@local never] app minors_before f x y = + let minors_after_prologue = minor_gcs () in + assert(minors_before+1 = minors_after_prologue); + request_minor_gc (); + f x y + +let polls_not_added_in_caml_apply () = + let minors_before = minor_gcs() in + request_minor_gc(); + ignore(Sys.opaque_identity(app minors_before (fun x y -> x * y) 5 4)); + let minors_after = minor_gcs() in + assert(minors_before+1 = minors_after) + +let () = + ignore(Sys.opaque_identity(ref 41)); + polls_added_to_loops (); (* relies on there being some minor heap usage *) + + ignore(Sys.opaque_identity(ref 41)); + prologue_polls_in_functions (); + + ignore(Sys.opaque_identity(ref 41)); + polls_added_to_self_recursive_functions (); + + ignore(Sys.opaque_identity(ref 41)); + polls_added_to_mutually_recursive_functions (); + + ignore(Sys.opaque_identity(ref 41)); + polls_added_to_indirect_tail_calls (); + + ignore(Sys.opaque_identity(ref 41)); + polls_not_added_to_indirect_calls (); + + ignore(Sys.opaque_identity(ref 41)); + polls_not_added_to_immediate_calls (); + + ignore(Sys.opaque_identity(ref 41)); + polls_not_added_unconditionally_allocating_functions (); + + ignore(Sys.opaque_identity(ref 41)); + polls_not_added_to_allocating_loops (); + + ignore(Sys.opaque_identity(ref 41)); + polls_not_added_in_caml_apply ()