diff options
Diffstat (limited to 'runtime')
38 files changed, 666 insertions, 521 deletions
diff --git a/runtime/afl.c b/runtime/afl.c index 0d3c77d8c1..54a1f83d3f 100644 --- a/runtime/afl.c +++ b/runtime/afl.c @@ -13,26 +13,34 @@ /**************************************************************************/ /* Runtime support for afl-fuzz */ + +#define CAML_INTERNALS + #include "caml/config.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" /* Values used by the instrumentation logic (see cmmgen.ml) */ -static unsigned char afl_area_initial[1 << 16]; -unsigned char* caml_afl_area_ptr = afl_area_initial; + +#define INITIAL_AFL_AREA_SIZE (1 << 16) +unsigned char * caml_afl_area_ptr = NULL; uintnat caml_afl_prev_loc; #if !defined(HAS_SYS_SHM_H) || !defined(HAS_SHMAT) -#include "caml/mlvalues.h" -#include "caml/domain.h" - -CAMLprim value caml_reset_afl_instrumentation(value full) +CAMLexport value caml_setup_afl(value unit) { + /* AFL is not supported, but we still need to allocate space for the bitmap + (the instrumented OCaml code will write into it). */ + if (caml_afl_area_ptr == NULL) { + caml_afl_area_ptr = caml_stat_alloc(INITIAL_AFL_AREA_SIZE); + memset(caml_afl_area_ptr, 0, INITIAL_AFL_AREA_SIZE); + } return Val_unit; } -CAMLexport value caml_setup_afl(value unit) +CAMLprim value caml_reset_afl_instrumentation(value full) { - /* AFL is not supported */ return Val_unit; } @@ -46,9 +54,8 @@ CAMLexport value caml_setup_afl(value unit) #include <stdio.h> #include <string.h> -#define CAML_INTERNALS +#include "caml/domain.h" #include "caml/misc.h" -#include "caml/mlvalues.h" #include "caml/osdeps.h" static int afl_initialised = 0; @@ -87,7 +94,11 @@ CAMLexport value caml_setup_afl(value unit) shm_id_str = caml_secure_getenv("__AFL_SHM_ID"); if (shm_id_str == NULL) { - /* Not running under afl-fuzz, continue as normal */ + /* Not running under afl-fuzz. Allocate space for the bitmap + (the instrumented OCaml code will write into it), + and continue as normal. */ + caml_afl_area_ptr = caml_stat_alloc(INITIAL_AFL_AREA_SIZE); + memset(caml_afl_area_ptr, 0, INITIAL_AFL_AREA_SIZE); return Val_unit; } @@ -164,8 +175,8 @@ CAMLexport value caml_setup_afl(value unit) CAMLprim value caml_reset_afl_instrumentation(value full) { - if (full == Val_true) { - memset(caml_afl_area_ptr, 0, sizeof(afl_area_initial)); + if (full == Val_true && caml_afl_area_ptr != NULL) { + memset(caml_afl_area_ptr, 0, INITIAL_AFL_AREA_SIZE); } caml_afl_prev_loc = 0; return Val_unit; diff --git a/runtime/alloc.c b/runtime/alloc.c index 49188fb69f..94ab9db598 100644 --- a/runtime/alloc.c +++ b/runtime/alloc.c @@ -316,7 +316,17 @@ CAMLprim value caml_update_dummy(value dummy, value newval) tag = Tag_val (newval); - if (tag == Double_array_tag){ + if (Wosize_val(dummy) == 0) { + /* Size-0 blocks are statically-allocated atoms. We cannot + mutate them, but there is no need: + - All atoms used in the runtime to represent OCaml values + have tag 0 --- including empty flat float arrays, or other + types that use a non-0 tag for non-atom blocks. + - The dummy was already created with tag 0. + So doing nothing suffices. */ + CAMLassert(Wosize_val(newval) == 0); + CAMLassert(Tag_val(dummy) == Tag_val(newval)); + } else if (tag == Double_array_tag){ CAMLassert (Wosize_val(newval) == Wosize_val(dummy)); CAMLassert (Tag_val(dummy) != Infix_tag); Unsafe_store_tag_val(dummy, Double_array_tag); diff --git a/runtime/amd64.S b/runtime/amd64.S index e9bb38b423..8dc9f81ec6 100644 --- a/runtime/amd64.S +++ b/runtime/amd64.S @@ -144,9 +144,17 @@ #define Handler_parent 24 /* struct c_stack_link */ +#if defined(SYS_mingw64) || defined (SYS_cygwin) +#define Cstack_stack 32 +#define Cstack_sp 40 +#define Cstack_prev 48 +#define SIZEOF_C_STACK_LINK 56 +#else #define Cstack_stack 0 #define Cstack_sp 8 #define Cstack_prev 16 +#define SIZEOF_C_STACK_LINK 24 +#endif /******************************************************************************/ /* DWARF */ @@ -369,20 +377,7 @@ #endif -#if defined(SYS_mingw64) || defined (SYS_cygwin) - /* Calls from OCaml to C must reserve 32 bytes of extra stack space */ -# define PREPARE_FOR_C_CALL subq $32, %rsp; CFI_ADJUST(32) -# define CLEANUP_AFTER_C_CALL addq $32, %rsp; CFI_ADJUST(-32) - /* Stack probing mustn't be larger than the page size */ -# define STACK_PROBE_SIZE 4096 -#else -# define PREPARE_FOR_C_CALL -# define CLEANUP_AFTER_C_CALL -# define STACK_PROBE_SIZE 4096 -#endif - -#define C_call(target) \ - PREPARE_FOR_C_CALL; CHECK_STACK_ALIGNMENT; call target; CLEANUP_AFTER_C_CALL +#define C_call(target) CHECK_STACK_ALIGNMENT; call target /******************************************************************************/ /* Registers holding arguments of C functions. */ @@ -635,6 +630,9 @@ CFI_STARTPROC /* Make the alloc ptr available to the C code */ movq %r15, Caml_state(young_ptr) /* Copy arguments from OCaml to C stack */ +#if defined(SYS_mingw64) || defined (SYS_cygwin) + addq $32, %rsp +#endif LBL(105): subq $8, %r12 cmpq %r13,%r12 @@ -642,6 +640,9 @@ LBL(105): push (%r12); CFI_ADJUST(8) jmp LBL(105) LBL(106): +#if defined(SYS_mingw64) || defined (SYS_cygwin) + subq $32, %rsp +#endif /* Call the function (address in %rax) */ C_call (*%rax) /* Pop arguments back off the stack */ @@ -680,7 +681,7 @@ LBL(caml_start_program): /* Load young_ptr into %r15 */ movq Caml_state(young_ptr), %r15 /* Build struct c_stack_link on the C stack */ - subq $24 /* sizeof struct c_stack_link */, %rsp; CFI_ADJUST(24) + subq $SIZEOF_C_STACK_LINK, %rsp; CFI_ADJUST(SIZEOF_C_STACK_LINK) movq $0, Cstack_stack(%rsp) movq $0, Cstack_sp(%rsp) movq Caml_state(c_stack), %r10 @@ -737,7 +738,7 @@ LBL(108): /* Pop the struct c_stack_link */ movq Cstack_prev(%rsp), %r10 movq %r10, Caml_state(c_stack) - addq $24, %rsp; CFI_ADJUST(-24) + addq $SIZEOF_C_STACK_LINK, %rsp; CFI_ADJUST(-SIZEOF_C_STACK_LINK) /* Restore callee-save registers. */ POP_CALLEE_SAVE_REGS /* Return to caller. */ diff --git a/runtime/array.c b/runtime/array.c index 317153901e..5a850b4944 100644 --- a/runtime/array.c +++ b/runtime/array.c @@ -336,14 +336,12 @@ static void wo_memmove (volatile value* const dst, if (dst < src) { /* copy ascending */ for (i = 0; i < nvals; i++) - atomic_store_explicit(&((atomic_value*)dst)[i], src[i], - memory_order_release); + atomic_store_release(&((atomic_value*)dst)[i], src[i]); } else { /* copy descending */ for (i = nvals; i > 0; i--) - atomic_store_explicit(&((atomic_value*)dst)[i-1], src[i-1], - memory_order_release); + atomic_store_release(&((atomic_value*)dst)[i-1], src[i-1]); } } } diff --git a/runtime/callback.c b/runtime/callback.c index e5df197023..68df624aab 100644 --- a/runtime/callback.c +++ b/runtime/callback.c @@ -27,6 +27,22 @@ #include "caml/mlvalues.h" #include "caml/platform.h" +/* A note about callbacks and GC. For best performance, a callback such as + [caml_callback_exn(value closure, value arg)] + should not extend the lifetime of the values [closure] + and [arg] any farther than necessary, that is, they should not be + registered as GC roots when the function call actually happens. + + This mirrors the reachability/lifetime guarantees provided by + function calls in OCaml code, where the arguments can be collected + as soon as they are not used anymore within the function body. + + The closure and its arguments may still have to be registered as + GC roots, typically across a call to [alloc_and_clear_stack_parent] below, + but registration should stop before the actual callback. + + See #12121 for more discussion. */ + /* * These functions are to ensure effects are handled correctly inside * callbacks. There are two aspects: @@ -36,7 +52,8 @@ * is executing to ensure that the garbage collector follows the * stack parent */ -Caml_inline value save_and_clear_stack_parent(caml_domain_state* domain_state) { +Caml_inline value alloc_and_clear_stack_parent(caml_domain_state* domain_state) +{ struct stack_info* parent_stack = Stack_parent(domain_state->current_stack); value cont = caml_alloc_1(Cont_tag, Val_ptr(parent_stack)); Stack_parent(domain_state->current_stack) = NULL; @@ -44,7 +61,8 @@ Caml_inline value save_and_clear_stack_parent(caml_domain_state* domain_state) { } Caml_inline void restore_stack_parent(caml_domain_state* domain_state, - value cont) { + value cont) +{ struct stack_info* parent_stack = Ptr_val(Op_val(cont)[0]); CAMLassert(Stack_parent(domain_state->current_stack) == NULL); Stack_parent(domain_state->current_stack) = parent_stack; @@ -77,8 +95,7 @@ static void init_callback_code(void) CAMLexport value caml_callbackN_exn(value closure, int narg, value args[]) { - CAMLparam1(closure); - CAMLxparamN(args, narg); + CAMLparam0(); /* no need to register closure and args as roots, see below */ CAMLlocal1(cont); value res; int i; @@ -100,7 +117,10 @@ CAMLexport value caml_callbackN_exn(value closure, int narg, value args[]) domain_state->current_stack->sp[narg + 2] = Val_long(0); /* extra args */ domain_state->current_stack->sp[narg + 3] = closure; - cont = save_and_clear_stack_parent(domain_state); + cont = alloc_and_clear_stack_parent(domain_state); + /* This can call the GC and invalidate the values [closure] and [args]. + However, they are never used afterwards, + as they were copied into the root [domain_state->current_stack]. */ res = caml_interprete(callback_code, sizeof(callback_code)); if (Is_exception_result(res)) @@ -157,15 +177,22 @@ CAMLexport value caml_callback_exn(value closure, value arg) caml_maybe_expand_stack(); if (Stack_parent(domain_state->current_stack)) { - CAMLparam2 (closure, arg); - CAMLlocal1 (cont); - value res; + value cont, res; - cont = save_and_clear_stack_parent(domain_state); + /* [closure] and [arg] need to be preserved across the allocation + of the stack parent, but need not and should not be registered + as roots past this allocation. */ + Begin_roots2(closure, arg); + cont = alloc_and_clear_stack_parent(domain_state); + End_roots(); + + Begin_roots1(cont); res = caml_callback_asm(domain_state, closure, &arg); + End_roots(); + restore_stack_parent(domain_state, cont); - CAMLreturn (res); + return res; } else { return caml_callback_asm(domain_state, closure, &arg); } @@ -178,16 +205,21 @@ CAMLexport value caml_callback2_exn(value closure, value arg1, value arg2) caml_maybe_expand_stack(); if (Stack_parent(domain_state->current_stack)) { - CAMLparam3 (closure, arg1, arg2); - CAMLlocal1 (cont); - value res; + value cont, res; + + /* Root registration policy: see caml_callback_exn. */ + Begin_roots3(closure, arg1, arg2); + cont = alloc_and_clear_stack_parent(domain_state); + End_roots(); - cont = save_and_clear_stack_parent(domain_state); + Begin_roots1(cont); value args[] = {arg1, arg2}; res = caml_callback2_asm(domain_state, closure, args); + End_roots(); + restore_stack_parent(domain_state, cont); - CAMLreturn (res); + return res; } else { value args[] = {arg1, arg2}; return caml_callback2_asm(domain_state, closure, args); @@ -202,51 +234,54 @@ CAMLexport value caml_callback3_exn(value closure, caml_maybe_expand_stack(); if (Stack_parent(domain_state->current_stack)) { - CAMLparam4 (closure, arg1, arg2, arg3); - CAMLlocal1 (cont); - value res; + value cont, res; + + /* Root registration policy: see caml_callback_exn. */ + Begin_roots4(closure, arg1, arg2, arg3); + cont = alloc_and_clear_stack_parent(domain_state); + End_roots(); - cont = save_and_clear_stack_parent(domain_state); + Begin_root(cont); value args[] = {arg1, arg2, arg3}; res = caml_callback3_asm(domain_state, closure, args); + End_roots(); + restore_stack_parent(domain_state, cont); - CAMLreturn (res); + return res; } else { value args[] = {arg1, arg2, arg3}; return caml_callback3_asm(domain_state, closure, args); } } -CAMLexport value caml_callbackN_exn(value closure, int narg, value args[]) -{ - CAMLparam1 (closure); - CAMLxparamN (args, narg); - CAMLlocal1 (res); - int i; +CAMLexport value caml_callbackN_exn(value closure, int narg, value args[]) { + while (narg >= 3) { + /* We apply the first 3 arguments to get a new closure, + and continue with the remaining arguments. */ + value *remaining_args = args + 3; + int remaining_narg = narg - 3; - res = closure; - for (i = 0; i < narg; /*nothing*/) { - /* Pass as many arguments as possible */ - switch (narg - i) { - case 1: - res = caml_callback_exn(res, args[i]); - if (Is_exception_result(res)) CAMLreturn (res); - i += 1; - break; - case 2: - res = caml_callback2_exn(res, args[i], args[i + 1]); - if (Is_exception_result(res)) CAMLreturn (res); - i += 2; - break; - default: - res = caml_callback3_exn(res, args[i], args[i + 1], args[i + 2]); - if (Is_exception_result(res)) CAMLreturn (res); - i += 3; - break; - } + /* We need to register the remaining arguments as roots + in case a GC occurs during [caml_callback3_exn]. + Arguments 0, 1 and 2 need not and should not be registered. */ + Begin_roots_block(remaining_args, remaining_narg); + closure = caml_callback3_exn(closure, args[0], args[1], args[2]); + End_roots(); + + if (Is_exception_result(closure)) return closure; + + args = remaining_args; + narg = remaining_narg; + } + switch (narg) { + case 0: + return closure; + case 1: + return caml_callback_exn(closure, args[0]); + default: /* case 2: */ + return caml_callback2_exn(closure, args[0], args[1]); } - CAMLreturn (res); } #endif diff --git a/runtime/caml/atomic_refcount.h b/runtime/caml/atomic_refcount.h index 3e4a239d51..aba5ce7f67 100644 --- a/runtime/caml/atomic_refcount.h +++ b/runtime/caml/atomic_refcount.h @@ -21,7 +21,7 @@ #include "camlatomic.h" Caml_inline void caml_atomic_refcount_init(atomic_uintnat* refc, uintnat n){ - atomic_store_rel(refc, n); + atomic_store_release(refc, n); } Caml_inline uintnat caml_atomic_refcount_decr(atomic_uintnat* refcount){ diff --git a/runtime/caml/config.h b/runtime/caml/config.h index e03bb7f928..1d7b4b0542 100644 --- a/runtime/caml/config.h +++ b/runtime/caml/config.h @@ -49,7 +49,6 @@ #ifndef CAML_CONFIG_H_NO_TYPEDEFS #include <stddef.h> -#include <stdbool.h> #if defined(HAS_LOCALE_H) || defined(HAS_XLOCALE_H) #define HAS_LOCALE diff --git a/runtime/caml/domain.h b/runtime/caml/domain.h index 17c011ecee..49194ae73d 100644 --- a/runtime/caml/domain.h +++ b/runtime/caml/domain.h @@ -92,7 +92,7 @@ CAMLextern atomic_uintnat caml_num_domains_running; Caml_inline intnat caml_domain_alone(void) { - return atomic_load_acq(&caml_num_domains_running) == 1; + return atomic_load_acquire(&caml_num_domains_running) == 1; } #ifdef DEBUG diff --git a/runtime/caml/exec.h b/runtime/caml/exec.h index 2fb024c9ae..6d5ed7d785 100644 --- a/runtime/caml/exec.h +++ b/runtime/caml/exec.h @@ -60,7 +60,7 @@ struct exec_trailer { /* Magic number for this release */ -#define EXEC_MAGIC "Caml1999X032" +#define EXEC_MAGIC "Caml1999X033" #endif /* CAML_INTERNALS */ diff --git a/runtime/caml/fiber.h b/runtime/caml/fiber.h index 133a3ba0df..1883c6dd68 100644 --- a/runtime/caml/fiber.h +++ b/runtime/caml/fiber.h @@ -98,6 +98,10 @@ CAML_STATIC_ASSERT(sizeof(struct stack_info) == * stack is reallocated, this linked list is walked to update the OCaml stack * pointers. It is also used for DWARF backtraces. */ struct c_stack_link { +#if defined(_WIN32) || defined(__CYGWIN__) + /* Win64 ABI shadow store for argument registers */ + void* shadow_store[4]; +#endif /* The reference to the OCaml stack */ struct stack_info* stack; /* OCaml return address */ diff --git a/runtime/caml/frame_descriptors.h b/runtime/caml/frame_descriptors.h index 3dc73e84e4..71142a5550 100644 --- a/runtime/caml/frame_descriptors.h +++ b/runtime/caml/frame_descriptors.h @@ -21,6 +21,7 @@ #ifdef CAML_INTERNALS +#include <stdbool.h> #include "config.h" /* The compiler generates a "frame descriptor" for every potential diff --git a/runtime/caml/gc_stats.h b/runtime/caml/gc_stats.h index 752238081f..80227b33c2 100644 --- a/runtime/caml/gc_stats.h +++ b/runtime/caml/gc_stats.h @@ -56,7 +56,6 @@ struct alloc_stats { uint64_t minor_words; uint64_t promoted_words; uint64_t major_words; - uint64_t minor_collections; uint64_t forced_major_collections; }; void caml_accum_alloc_stats( diff --git a/runtime/caml/lf_skiplist.h b/runtime/caml/lf_skiplist.h index f35f112256..db6544c867 100644 --- a/runtime/caml/lf_skiplist.h +++ b/runtime/caml/lf_skiplist.h @@ -95,8 +95,7 @@ extern void caml_lf_skiplist_free_garbage(struct lf_skiplist *sk); #define LF_SK_UNMARK(p) ((struct lf_skipcell *)(((uintptr_t)(p)) & ~1)) #define LF_SK_EXTRACT(from, mark_to, ptr_to) \ { \ - uintptr_t tmp = \ - (uintptr_t)atomic_load_explicit(&from, memory_order_acquire); \ + uintptr_t tmp = (uintptr_t)atomic_load_acquire(&(from)); \ mark_to = LF_SK_IS_MARKED(tmp); \ ptr_to = LF_SK_UNMARK(tmp); \ } diff --git a/runtime/caml/misc.h b/runtime/caml/misc.h index a9790d8a77..ed458e833f 100644 --- a/runtime/caml/misc.h +++ b/runtime/caml/misc.h @@ -457,6 +457,7 @@ struct ext_table { extern void caml_ext_table_init(struct ext_table * tbl, int init_capa); extern int caml_ext_table_add(struct ext_table * tbl, void * data); +extern int caml_ext_table_add_noexc(struct ext_table * tbl, void * data); extern void caml_ext_table_remove(struct ext_table * tbl, void * data); extern void caml_ext_table_free(struct ext_table * tbl, int free_entries); extern void caml_ext_table_clear(struct ext_table * tbl, int free_entries); diff --git a/runtime/caml/platform.h b/runtime/caml/platform.h index 77027405be..373419e3c9 100644 --- a/runtime/caml/platform.h +++ b/runtime/caml/platform.h @@ -49,27 +49,16 @@ Caml_inline void cpu_relax(void) { #endif } -/* Loads and stores with acquire and release semantics respectively */ +/* Loads and stores with acquire, release and relaxed semantics */ -Caml_inline uintnat atomic_load_acq(atomic_uintnat* p) -{ - return atomic_load_explicit(p, memory_order_acquire); -} - -Caml_inline uintnat atomic_load_relaxed(atomic_uintnat* p) -{ - return atomic_load_explicit(p, memory_order_relaxed); -} - -Caml_inline void atomic_store_rel(atomic_uintnat* p, uintnat v) -{ - atomic_store_explicit(p, v, memory_order_release); -} - -Caml_inline void atomic_store_relaxed(atomic_uintnat* p, uintnat v) -{ - atomic_store_explicit(p, v, memory_order_relaxed); -} +#define atomic_load_acquire(p) \ + atomic_load_explicit((p), memory_order_acquire) +#define atomic_load_relaxed(p) \ + atomic_load_explicit((p), memory_order_relaxed) +#define atomic_store_release(p, v) \ + atomic_store_explicit((p), (v), memory_order_release) +#define atomic_store_relaxed(p, v) \ + atomic_store_explicit((p), (v), memory_order_relaxed) /* Spin-wait loops */ @@ -94,7 +83,7 @@ CAMLextern unsigned caml_plat_spin_wait(unsigned spins, Caml_inline uintnat atomic_load_wait_nonzero(atomic_uintnat* p) { SPIN_WAIT { - uintnat v = atomic_load_acq(p); + uintnat v = atomic_load_acquire(p); if (v) return v; } } diff --git a/runtime/codefrag.c b/runtime/codefrag.c index d1659563c8..9237995fa2 100644 --- a/runtime/codefrag.c +++ b/runtime/codefrag.c @@ -95,7 +95,7 @@ void caml_remove_code_fragment(struct code_fragment *cf) { cf_cell->cf = cf; do { - cf_cell->next = atomic_load_explicit(&garbage_head, memory_order_acquire); + cf_cell->next = atomic_load_acquire(&garbage_head); } while (!atomic_compare_exchange_strong(&garbage_head, &cf_cell->next, cf_cell)); } @@ -167,7 +167,7 @@ void caml_code_fragment_cleanup (void) caml_lf_skiplist_free_garbage(&code_fragments_by_pc); caml_lf_skiplist_free_garbage(&code_fragments_by_num); - curr = atomic_load_explicit(&garbage_head, memory_order_acquire); + curr = atomic_load_acquire(&garbage_head); while (curr != NULL) { struct code_fragment_garbage *next = curr->next; @@ -178,5 +178,5 @@ void caml_code_fragment_cleanup (void) curr = next; } - atomic_store_explicit(&garbage_head, NULL, memory_order_release); + atomic_store_release(&garbage_head, NULL); } diff --git a/runtime/compare.c b/runtime/compare.c index 8348f99dda..eb48994ce4 100644 --- a/runtime/compare.c +++ b/runtime/compare.c @@ -25,7 +25,7 @@ /* Structural comparison on trees. */ -struct compare_item { volatile value * v1, * v2; mlsize_t count; }; +struct compare_item { value v1, v2, offset, size; }; #define COMPARE_STACK_INIT_SIZE 8 #define COMPARE_STACK_MIN_ALLOC_SIZE 32 @@ -37,6 +37,8 @@ struct compare_stack { struct compare_item* limit; }; +#define COMPARE_POLL_PERIOD 1024 + /* Free the compare stack if needed */ static void compare_free_stack(struct compare_stack* stk) { @@ -84,7 +86,6 @@ static struct compare_item * compare_resize_stack(struct compare_stack* stk, return newstack + sp_offset; } - static intnat do_compare_val(struct compare_stack* stk, value v1, value v2, int total); @@ -99,6 +100,24 @@ static intnat compare_val(value v1, value v2, int total) return res; } +static void run_pending_actions(struct compare_stack* stk, + struct compare_item* sp) +{ + value exn; + value* roots_start = (value*)(stk->stack); + size_t roots_length = + (sp - stk->stack) + * sizeof(struct compare_item) / sizeof(value); + Begin_roots_block(roots_start, roots_length); + exn = caml_do_pending_actions_exn(); + End_roots(); + if (Is_exception_result(exn)) { + exn = Extract_exception(exn); + compare_free_stack(stk); + caml_raise(exn); + } +} + /* Structural comparison */ @@ -118,191 +137,212 @@ static intnat do_compare_val(struct compare_stack* stk, { struct compare_item * sp; tag_t t1, t2; + int poll_timer; sp = stk->stack; while (1) { - if (v1 == v2 && total) goto next_item; - if (Is_long(v1)) { - if (v1 == v2) goto next_item; - if (Is_long(v2)) - return Long_val(v1) - Long_val(v2); - /* Subtraction above cannot overflow and cannot result in UNORDERED */ - switch (Tag_val(v2)) { - case Forward_tag: - v2 = Forward_val(v2); - continue; - case Custom_tag: { - int res; - int (*compare)(value v1, value v2) = Custom_ops_val(v2)->compare_ext; - if (compare == NULL) break; /* for backward compatibility */ - Caml_state->compare_unordered = 0; - res = compare(v1, v2); - if (Caml_state->compare_unordered && !total) return UNORDERED; - if (res != 0) return res; - goto next_item; - } - default: /*fallthrough*/; - } + poll_timer = COMPARE_POLL_PERIOD; + while (--poll_timer > 0) { + if (v1 == v2 && total) goto next_item; + if (Is_long(v1)) { + if (v1 == v2) goto next_item; + if (Is_long(v2)) + return Long_val(v1) - Long_val(v2); + /* Subtraction above cannot overflow and cannot result in UNORDERED */ + switch (Tag_val(v2)) { + case Forward_tag: + v2 = Forward_val(v2); + continue; + case Custom_tag: { + int res; + int (*compare)(value v1, value v2) = + Custom_ops_val(v2)->compare_ext; + if (compare == NULL) break; /* for backward compatibility */ + Caml_state->compare_unordered = 0; + res = compare(v1, v2); + if (Caml_state->compare_unordered && !total) return UNORDERED; + if (res != 0) return res; + goto next_item; + } + default: /*fallthrough*/; + } - return LESS; /* v1 long < v2 block */ - } - if (Is_long(v2)) { - switch (Tag_val(v1)) { - case Forward_tag: - v1 = Forward_val(v1); - continue; - case Custom_tag: { - int res; - int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare_ext; - if (compare == NULL) break; /* for backward compatibility */ - Caml_state->compare_unordered = 0; - res = compare(v1, v2); - if (Caml_state->compare_unordered && !total) return UNORDERED; - if (res != 0) return res; - goto next_item; - } - default: /*fallthrough*/; - } - return GREATER; /* v1 block > v2 long */ - } - t1 = Tag_val(v1); - t2 = Tag_val(v2); - if (t1 != t2) { - /* Besides long/block comparisons, the only forms of - heterogeneous comparisons we support are: - - Forward_tag pointers, which may point to values of any type, and - - comparing Infix_tag and Closure_tag functions (#9521). + return LESS; /* v1 long < v2 block */ + } + if (Is_long(v2)) { + switch (Tag_val(v1)) { + case Forward_tag: + v1 = Forward_val(v1); + continue; + case Custom_tag: { + int res; + int (*compare)(value v1, value v2) = + Custom_ops_val(v1)->compare_ext; + if (compare == NULL) break; /* for backward compatibility */ + Caml_state->compare_unordered = 0; + res = compare(v1, v2); + if (Caml_state->compare_unordered && !total) return UNORDERED; + if (res != 0) return res; + goto next_item; + } + default: /*fallthrough*/; + } + return GREATER; /* v1 block > v2 long */ + } + t1 = Tag_val(v1); + t2 = Tag_val(v2); + if (t1 != t2) { + /* Besides long/block comparisons, the only forms of + heterogeneous comparisons we support are: + - Forward_tag pointers, which may point to values of any type, and + - comparing Infix_tag and Closure_tag functions (#9521). - Other heterogeneous cases may still happen due to - existential types, and we just compare the tags. - */ - if (t1 == Forward_tag) { v1 = Forward_val (v1); continue; } - if (t2 == Forward_tag) { v2 = Forward_val (v2); continue; } - if (t1 == Infix_tag) t1 = Closure_tag; - if (t2 == Infix_tag) t2 = Closure_tag; - if (t1 != t2) - return (intnat)t1 - (intnat)t2; - } - switch(t1) { - case Forward_tag: { - v1 = Forward_val (v1); - v2 = Forward_val (v2); - continue; - } - case String_tag: { - mlsize_t len1, len2; - int res; - if (v1 == v2) break; - len1 = caml_string_length(v1); - len2 = caml_string_length(v2); - res = memcmp(String_val(v1), String_val(v2), len1 <= len2 ? len1 : len2); - if (res < 0) return LESS; - if (res > 0) return GREATER; - if (len1 != len2) return len1 - len2; - break; - } - case Double_tag: { - double d1 = Double_val(v1); - double d2 = Double_val(v2); - if (d1 < d2) return LESS; - if (d1 > d2) return GREATER; - if (d1 != d2) { - if (! total) return UNORDERED; - /* One or both of d1 and d2 is NaN. Order according to the - convention NaN = NaN and NaN < f for all other floats f. */ - if (d1 == d1) return GREATER; /* d1 is not NaN, d2 is NaN */ - if (d2 == d2) return LESS; /* d2 is not NaN, d1 is NaN */ - /* d1 and d2 are both NaN, thus equal: continue comparison */ + Other heterogeneous cases may still happen due to + existential types, and we just compare the tags. + */ + if (t1 == Forward_tag) { v1 = Forward_val (v1); continue; } + if (t2 == Forward_tag) { v2 = Forward_val (v2); continue; } + if (t1 == Infix_tag) t1 = Closure_tag; + if (t2 == Infix_tag) t2 = Closure_tag; + if (t1 != t2) + return (intnat)t1 - (intnat)t2; } - break; - } - case Double_array_tag: { - mlsize_t sz1 = Wosize_val(v1) / Double_wosize; - mlsize_t sz2 = Wosize_val(v2) / Double_wosize; - mlsize_t i; - if (sz1 != sz2) return sz1 - sz2; - for (i = 0; i < sz1; i++) { - double d1 = Double_flat_field(v1, i); - double d2 = Double_flat_field(v2, i); + switch(t1) { + case Forward_tag: { + v1 = Forward_val (v1); + v2 = Forward_val (v2); + continue; + } + case String_tag: { + mlsize_t len1, len2; + int res; + if (v1 == v2) break; + len1 = caml_string_length(v1); + len2 = caml_string_length(v2); + res = memcmp(String_val(v1), String_val(v2), + len1 <= len2 ? len1 : len2); + if (res < 0) return LESS; + if (res > 0) return GREATER; + if (len1 != len2) return len1 - len2; + break; + } + case Double_tag: { + double d1 = Double_val(v1); + double d2 = Double_val(v2); if (d1 < d2) return LESS; if (d1 > d2) return GREATER; if (d1 != d2) { if (! total) return UNORDERED; - /* See comment for Double_tag case */ - if (d1 == d1) return GREATER; - if (d2 == d2) return LESS; + /* One or both of d1 and d2 is NaN. Order according to the + convention NaN = NaN and NaN < f for all other floats f. */ + if (d1 == d1) return GREATER; /* d1 is not NaN, d2 is NaN */ + if (d2 == d2) return LESS; /* d2 is not NaN, d1 is NaN */ + /* d1 and d2 are both NaN, thus equal: continue comparison */ } + break; } - break; - } - case Abstract_tag: - compare_free_stack(stk); - caml_invalid_argument("compare: abstract value"); - case Closure_tag: - case Infix_tag: - compare_free_stack(stk); - caml_invalid_argument("compare: functional value"); - case Cont_tag: - compare_free_stack(stk); - caml_invalid_argument("compare: continuation value"); - case Object_tag: { - intnat oid1 = Oid_val(v1); - intnat oid2 = Oid_val(v2); - if (oid1 != oid2) return oid1 - oid2; - break; - } - case Custom_tag: { - int res; - int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare; - /* Hardening against comparisons between different types */ - if (compare != Custom_ops_val(v2)->compare) { - return strcmp(Custom_ops_val(v1)->identifier, - Custom_ops_val(v2)->identifier) < 0 - ? LESS : GREATER; + case Double_array_tag: { + mlsize_t sz1 = Wosize_val(v1) / Double_wosize; + mlsize_t sz2 = Wosize_val(v2) / Double_wosize; + mlsize_t i; + if (sz1 != sz2) return sz1 - sz2; + for (i = 0; i < sz1; i++) { + double d1 = Double_flat_field(v1, i); + double d2 = Double_flat_field(v2, i); + if (d1 < d2) return LESS; + if (d1 > d2) return GREATER; + if (d1 != d2) { + if (! total) return UNORDERED; + /* See comment for Double_tag case */ + if (d1 == d1) return GREATER; + if (d2 == d2) return LESS; + } + } + break; } - if (compare == NULL) { + case Abstract_tag: compare_free_stack(stk); caml_invalid_argument("compare: abstract value"); + case Closure_tag: + case Infix_tag: + compare_free_stack(stk); + caml_invalid_argument("compare: functional value"); + case Cont_tag: + compare_free_stack(stk); + caml_invalid_argument("compare: continuation value"); + case Object_tag: { + intnat oid1 = Oid_val(v1); + intnat oid2 = Oid_val(v2); + if (oid1 != oid2) return oid1 - oid2; + break; } - Caml_state->compare_unordered = 0; - res = compare(v1, v2); - if (Caml_state->compare_unordered && !total) return UNORDERED; - if (res != 0) return res; - break; - } - default: { - mlsize_t sz1 = Wosize_val(v1); - mlsize_t sz2 = Wosize_val(v2); - /* Compare sizes first for speed */ - if (sz1 != sz2) return sz1 - sz2; - if (sz1 == 0) break; - /* Remember that we still have to compare fields 1 ... sz - 1 */ - if (sz1 > 1) { - sp++; - if (sp >= stk->limit) sp = compare_resize_stack(stk, sp); - sp->v1 = &Field(v1, 1); - sp->v2 = &Field(v2, 1); - sp->count = sz1 - 1; + case Custom_tag: { + int res; + int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare; + /* Hardening against comparisons between different types */ + if (compare != Custom_ops_val(v2)->compare) { + return strcmp(Custom_ops_val(v1)->identifier, + Custom_ops_val(v2)->identifier) < 0 + ? LESS : GREATER; + } + if (compare == NULL) { + compare_free_stack(stk); + caml_invalid_argument("compare: abstract value"); + } + Caml_state->compare_unordered = 0; + res = compare(v1, v2); + if (Caml_state->compare_unordered && !total) return UNORDERED; + if (res != 0) return res; + break; } - /* Continue comparison with first field */ - v1 = Field(v1, 0); - v2 = Field(v2, 0); - continue; + default: { + mlsize_t sz1 = Wosize_val(v1); + mlsize_t sz2 = Wosize_val(v2); + /* Compare sizes first for speed */ + if (sz1 != sz2) return sz1 - sz2; + if (sz1 == 0) break; + /* Remember that we still have to compare fields 1 ... sz - 1. */ + if (sz1 > 1) { + if (sp >= stk->limit) sp = compare_resize_stack(stk, sp); + struct compare_item* next = sp++; + next->v1 = v1; + next->v2 = v2; + next->size = Val_long(sz1); + next->offset = Val_long(1); + } + /* Continue comparison with first field */ + v1 = Field(v1, 0); + v2 = Field(v2, 0); + continue; + } + } + next_item: + /* Pop one more item to compare, if any */ + if (sp == stk->stack) return EQUAL; /* we're done */ + + struct compare_item* last = sp-1; + v1 = Field(last->v1, Long_val(last->offset)); + v2 = Field(last->v2, Long_val(last->offset)); + last->offset += 2;/* Long_val(last->offset) += 1 */ + if (last->offset == last->size) sp--; } + /* Poll for actions */ + if (caml_check_pending_actions()) { + /* Preserve v1, v2 if a GC occurs. Registering v1 and v2 directly + as roots would prevent them from being allocated to registers. */ + value root_v1 = v1, root_v2 = v2; + Begin_roots2(root_v1, root_v2); + run_pending_actions(stk, sp); + v1 = root_v1; v2 = root_v2; + End_roots(); } - next_item: - /* Pop one more item to compare, if any */ - if (sp == stk->stack) return EQUAL; /* we're done */ - v1 = *((sp->v1)++); - v2 = *((sp->v2)++); - if (--(sp->count) == 0) sp--; + /* Resume comparison after resetting poll_timer */ } } CAMLprim value caml_compare(value v1, value v2) { intnat res = compare_val(v1, v2, 1); - /* Free stack if needed */ if (res < 0) return Val_int(LESS); else if (res > 0) diff --git a/runtime/domain.c b/runtime/domain.c index 88d7c1469c..91325c4bfc 100644 --- a/runtime/domain.c +++ b/runtime/domain.c @@ -294,22 +294,22 @@ CAMLexport caml_domain_state* caml_get_domain_state(void) Caml_inline void interrupt_domain(struct interruptor* s) { - atomic_store_rel(s->interrupt_word, (uintnat)(-1)); + atomic_store_release(s->interrupt_word, (uintnat)(-1)); } int caml_incoming_interrupts_queued(void) { - return atomic_load_acq(&domain_self->interruptor.interrupt_pending); + return atomic_load_acquire(&domain_self->interruptor.interrupt_pending); } /* must NOT be called with s->lock held */ static void stw_handler(caml_domain_state* domain); static uintnat handle_incoming(struct interruptor* s) { - uintnat handled = atomic_load_acq(&s->interrupt_pending); + uintnat handled = atomic_load_acquire(&s->interrupt_pending); CAMLassert (s->running); if (handled) { - atomic_store_rel(&s->interrupt_pending, 0); + atomic_store_release(&s->interrupt_pending, 0); stw_handler(domain_self->state); } @@ -330,7 +330,7 @@ void caml_handle_incoming_interrupts(void) int caml_send_interrupt(struct interruptor* target) { /* signal that there is an interrupt pending */ - atomic_store_rel(&target->interrupt_pending, 1); + atomic_store_release(&target->interrupt_pending, 1); /* Signal the condition variable, in case the target is itself waiting for an interrupt to be processed elsewhere */ @@ -349,7 +349,7 @@ static void caml_wait_interrupt_serviced(struct interruptor* target) /* Often, interrupt handlers are fast, so spin for a bit before waiting */ for (i=0; i<1000; i++) { - if (!atomic_load_acq(&target->interrupt_pending)) { + if (!atomic_load_acquire(&target->interrupt_pending)) { return; } cpu_relax(); @@ -357,7 +357,7 @@ static void caml_wait_interrupt_serviced(struct interruptor* target) { SPIN_WAIT { - if (!atomic_load_acq(&target->interrupt_pending)) + if (!atomic_load_acquire(&target->interrupt_pending)) return; } } @@ -453,7 +453,7 @@ static void free_minor_heap(void) { domain_state->young_end = NULL; domain_state->young_ptr = NULL; domain_state->young_trigger = NULL; - atomic_store_rel(&domain_state->young_limit, + atomic_store_release(&domain_state->young_limit, (uintnat) domain_state->young_start); } @@ -545,7 +545,7 @@ static void domain_create(uintnat initial_minor_heap_wsize) { caml_plat_lock(&all_domains_lock); /* Wait until any in-progress STW sections end. */ - while (atomic_load_acq(&stw_leader)) { + while (atomic_load_acquire(&stw_leader)) { /* [caml_plat_wait] releases [all_domains_lock] until the current STW section ends, and then takes the lock again. */ caml_plat_wait(&all_domains_cond); @@ -938,7 +938,7 @@ static void* backup_thread_func(void* v) domain_self = di; caml_state = di->state; - msg = atomic_load_acq (&di->backup_thread_msg); + msg = atomic_load_acquire (&di->backup_thread_msg); while (msg != BT_TERMINATE) { CAMLassert (msg <= BT_TERMINATE); switch (msg) { @@ -958,7 +958,7 @@ static void* backup_thread_func(void* v) * Will be woken from caml_leave_blocking_section */ caml_plat_lock(&s->lock); - msg = atomic_load_acq (&di->backup_thread_msg); + msg = atomic_load_acquire (&di->backup_thread_msg); if (msg == BT_IN_BLOCKING_SECTION && !caml_incoming_interrupts_queued()) caml_plat_wait(&s->cond); @@ -970,7 +970,7 @@ static void* backup_thread_func(void* v) * or domain_terminate */ caml_plat_lock(&di->domain_lock); - msg = atomic_load_acq (&di->backup_thread_msg); + msg = atomic_load_acquire (&di->backup_thread_msg); if (msg == BT_ENTERING_OCAML) caml_plat_wait(&di->domain_cond); caml_plat_unlock(&di->domain_lock); @@ -979,11 +979,11 @@ static void* backup_thread_func(void* v) cpu_relax(); break; }; - msg = atomic_load_acq (&di->backup_thread_msg); + msg = atomic_load_acquire (&di->backup_thread_msg); } /* doing terminate */ - atomic_store_rel(&di->backup_thread_msg, BT_INIT); + atomic_store_release(&di->backup_thread_msg, BT_INIT); return 0; } @@ -999,7 +999,7 @@ static void install_backup_thread (dom_internal* di) CAMLassert (di->backup_thread_msg == BT_INIT || /* Using fresh domain */ di->backup_thread_msg == BT_TERMINATE); /* Reusing domain */ - while (atomic_load_acq(&di->backup_thread_msg) != BT_INIT) { + while (atomic_load_acquire(&di->backup_thread_msg) != BT_INIT) { /* Give a chance for backup thread on this domain to terminate */ caml_plat_unlock (&di->domain_lock); cpu_relax (); @@ -1012,7 +1012,7 @@ static void install_backup_thread (dom_internal* di) pthread_sigmask(SIG_BLOCK, &mask, &old_mask); #endif - atomic_store_rel(&di->backup_thread_msg, BT_ENTERING_OCAML); + atomic_store_release(&di->backup_thread_msg, BT_ENTERING_OCAML); err = pthread_create(&di->backup_thread, 0, backup_thread_func, (void*)di); #ifndef _WIN32 @@ -1227,11 +1227,11 @@ void caml_global_barrier_end(barrier_status b) uintnat sense = b & BARRIER_SENSE_BIT; if (caml_global_barrier_is_final(b)) { /* last domain into the barrier, flip sense */ - atomic_store_rel(&stw_request.barrier, sense ^ BARRIER_SENSE_BIT); + atomic_store_release(&stw_request.barrier, sense ^ BARRIER_SENSE_BIT); } else { /* wait until another domain flips the sense */ SPIN_WAIT { - uintnat barrier = atomic_load_acq(&stw_request.barrier); + uintnat barrier = atomic_load_acquire(&stw_request.barrier); if ((barrier & BARRIER_SENSE_BIT) != sense) break; } } @@ -1259,7 +1259,7 @@ static void decrement_stw_domains_still_processing(void) if( am_last ) { /* release the STW lock to allow new STW sections */ caml_plat_lock(&all_domains_lock); - atomic_store_rel(&stw_leader, 0); + atomic_store_release(&stw_leader, 0); caml_plat_broadcast(&all_domains_cond); caml_gc_log("clearing stw leader"); caml_plat_unlock(&all_domains_lock); @@ -1272,7 +1272,7 @@ static void stw_handler(caml_domain_state* domain) CAML_EV_BEGIN(EV_STW_API_BARRIER); { SPIN_WAIT { - if (atomic_load_acq(&stw_request.domains_still_running) == 0) + if (atomic_load_acquire(&stw_request.domains_still_running) == 0) break; if (stw_request.enter_spin_callback) @@ -1384,21 +1384,21 @@ int caml_try_run_on_all_domains_with_spin_work( situations. Without this read, [stw_leader] would be protected by [all_domains_lock] and could be a non-atomic variable. */ - if (atomic_load_acq(&stw_leader) || + if (atomic_load_acquire(&stw_leader) || !caml_plat_try_lock(&all_domains_lock)) { caml_handle_incoming_interrupts(); return 0; } /* see if there is a stw_leader already */ - if (atomic_load_acq(&stw_leader)) { + if (atomic_load_acquire(&stw_leader)) { caml_plat_unlock(&all_domains_lock); caml_handle_incoming_interrupts(); return 0; } /* we have the lock and can claim the stw_leader */ - atomic_store_rel(&stw_leader, (uintnat)domain_self); + atomic_store_release(&stw_leader, (uintnat)domain_self); CAML_EV_BEGIN(EV_STW_LEADER); caml_gc_log("causing STW"); @@ -1409,10 +1409,10 @@ int caml_try_run_on_all_domains_with_spin_work( stw_request.enter_spin_data = enter_spin_data; stw_request.callback = handler; stw_request.data = data; - atomic_store_rel(&stw_request.barrier, 0); - atomic_store_rel(&stw_request.domains_still_running, 1); + atomic_store_release(&stw_request.barrier, 0); + atomic_store_release(&stw_request.domains_still_running, 1); stw_request.num_domains = stw_domains.participating_domains; - atomic_store_rel(&stw_request.num_domains_still_processing, + atomic_store_release(&stw_request.num_domains_still_processing, stw_domains.participating_domains); if( leader_setup ) { @@ -1462,7 +1462,7 @@ int caml_try_run_on_all_domains_with_spin_work( } /* release from the enter barrier */ - atomic_store_rel(&stw_request.domains_still_running, 0); + atomic_store_release(&stw_request.domains_still_running, 0); #ifdef DEBUG domain_state->inside_stw_handler = 1; @@ -1511,7 +1511,7 @@ void caml_reset_young_limit(caml_domain_state * dom_st) || dom_st->major_slice_epoch < atomic_load (&caml_major_slice_epoch) || atomic_load_relaxed(&dom_st->requested_external_interrupt) || dom_st->action_pending) { - atomic_store_rel(&dom_st->young_limit, (uintnat)-1); + atomic_store_release(&dom_st->young_limit, (uintnat)-1); CAMLassert(caml_check_gc_interrupt(dom_st)); } } @@ -1599,7 +1599,7 @@ void caml_poll_gc_work(void) CAML_EV_END(EV_MAJOR); } - if (atomic_load_acq(&d->requested_external_interrupt)) { + if (atomic_load_acquire(&d->requested_external_interrupt)) { caml_domain_external_interrupt_hook(); } caml_reset_young_limit(d); @@ -1621,7 +1621,7 @@ void caml_handle_gc_interrupt(void) CAMLexport int caml_bt_is_in_blocking_section(void) { - uintnat status = atomic_load_acq(&domain_self->backup_thread_msg); + uintnat status = atomic_load_acquire(&domain_self->backup_thread_msg); return status == BT_IN_BLOCKING_SECTION; } @@ -1650,7 +1650,7 @@ CAMLexport void caml_bt_enter_ocaml(void) CAMLassert(caml_domain_alone() || self->backup_thread_running); if (self->backup_thread_running) { - atomic_store_rel(&self->backup_thread_msg, BT_ENTERING_OCAML); + atomic_store_release(&self->backup_thread_msg, BT_ENTERING_OCAML); } } @@ -1668,7 +1668,7 @@ CAMLexport void caml_bt_exit_ocaml(void) CAMLassert(caml_domain_alone() || self->backup_thread_running); if (self->backup_thread_running) { - atomic_store_rel(&self->backup_thread_msg, BT_IN_BLOCKING_SECTION); + atomic_store_release(&self->backup_thread_msg, BT_IN_BLOCKING_SECTION); /* Wakeup backup thread if it is sleeping */ caml_plat_signal(&self->domain_cond); } @@ -1827,7 +1827,7 @@ static void domain_terminate (void) /* signal the domain termination to the backup thread NB: for a program with no additional domains, the backup thread will not have been started */ - atomic_store_rel(&domain_self->backup_thread_msg, BT_TERMINATE); + atomic_store_release(&domain_self->backup_thread_msg, BT_TERMINATE); caml_plat_signal(&domain_self->domain_cond); caml_plat_unlock(&domain_self->domain_lock); diff --git a/runtime/extern.c b/runtime/extern.c index 9d9746ecf3..4301c3df13 100644 --- a/runtime/extern.c +++ b/runtime/extern.c @@ -120,30 +120,44 @@ struct caml_extern_state { struct output_block * extern_output_block; }; -static struct caml_extern_state* get_extern_state (void) +static void extern_init_stack(struct caml_extern_state* s) +{ + /* (Re)initialize the globals for next time around */ + s->extern_stack = s->extern_stack_init; + s->extern_stack_limit = s->extern_stack + EXTERN_STACK_INIT_SIZE; +} + +static struct caml_extern_state* prepare_extern_state (void) { Caml_check_caml_state(); - struct caml_extern_state* extern_state; + struct caml_extern_state* s; if (Caml_state->extern_state != NULL) return Caml_state->extern_state; - extern_state = - caml_stat_alloc_noexc(sizeof(struct caml_extern_state)); - if (extern_state == NULL) { - return NULL; - } + s = caml_stat_alloc(sizeof(struct caml_extern_state)); + + s->extern_flags = 0; + s->obj_counter = 0; + s->size_32 = 0; + s->size_64 = 0; + extern_init_stack(s); + + Caml_state->extern_state = s; + return s; +} + +static struct caml_extern_state* get_extern_state (void) +{ + Caml_check_caml_state(); - extern_state->extern_flags = 0; - extern_state->obj_counter = 0; - extern_state->size_32 = 0; - extern_state->size_64 = 0; - extern_state->extern_stack = extern_state->extern_stack_init; - extern_state->extern_stack_limit = - extern_state->extern_stack + EXTERN_STACK_INIT_SIZE; + if (Caml_state->extern_state == NULL) + caml_fatal_error ( + "extern_state not initialized:" + "this function can only be called from a `caml_output_*` entrypoint." + ); - Caml_state->extern_state = extern_state; - return extern_state; + return Caml_state->extern_state; } void caml_free_extern_state (void) @@ -174,17 +188,15 @@ CAMLnoreturn_end; static void free_extern_output(struct caml_extern_state* s); -/* Free the extern stack if needed */ static void extern_free_stack(struct caml_extern_state* s) { + /* Free the extern stack if needed */ if (s->extern_stack != s->extern_stack_init) { caml_stat_free(s->extern_stack); - /* Reinitialize the globals for next time around */ - s->extern_stack = s->extern_stack_init; - s->extern_stack_limit = s->extern_stack + EXTERN_STACK_INIT_SIZE; } -} + extern_init_stack(s); +} static struct extern_item * extern_resize_stack(struct caml_extern_state* s, struct extern_item * sp) @@ -1072,7 +1084,7 @@ void caml_output_val(struct channel *chan, value v, value flags) char header[MAX_INTEXT_HEADER_SIZE]; int header_len; struct output_block * blk, * nextblk; - struct caml_extern_state* s = get_extern_state (); + struct caml_extern_state* s = prepare_extern_state (); if (! caml_channel_binary_mode(chan)) caml_failwith("output_value: not a binary channel"); @@ -1110,7 +1122,7 @@ CAMLprim value caml_output_value_to_bytes(value v, value flags) intnat data_len, ofs; value res; struct output_block * blk, * nextblk; - struct caml_extern_state* s = get_extern_state (); + struct caml_extern_state* s = prepare_extern_state (); init_extern_output(s); data_len = extern_value(s, v, flags, header, &header_len); @@ -1143,7 +1155,7 @@ CAMLexport intnat caml_output_value_to_block(value v, value flags, char header[MAX_INTEXT_HEADER_SIZE]; int header_len; intnat data_len; - struct caml_extern_state* s = get_extern_state (); + struct caml_extern_state* s = prepare_extern_state (); /* At this point we don't know the size of the header. Guess that it is small, and fix up later if not. */ @@ -1180,7 +1192,7 @@ CAMLexport void caml_output_value_to_malloc(value v, value flags, intnat data_len; char * res; struct output_block * blk, * nextblk; - struct caml_extern_state* s = get_extern_state (); + struct caml_extern_state* s = prepare_extern_state (); init_extern_output(s); data_len = extern_value(s, v, flags, header, &header_len); @@ -1340,7 +1352,7 @@ CAMLprim value caml_obj_reachable_words(value v) struct extern_item * sp; uintnat h = 0; uintnat pos = 0; - struct caml_extern_state *s = get_extern_state (); + struct caml_extern_state *s = prepare_extern_state (); s->obj_counter = 0; s->extern_flags = 0; diff --git a/runtime/fail_nat.c b/runtime/fail_nat.c index 2245f933b3..bb891b940f 100644 --- a/runtime/fail_nat.c +++ b/runtime/fail_nat.c @@ -197,7 +197,7 @@ CAMLexport value caml_raise_if_exception(value res) static value array_bound_exn(void) { static atomic_uintnat exn_cache = ATOMIC_UINTNAT_INIT(0); - const value* exn = (const value*)atomic_load_acq(&exn_cache); + const value* exn = (const value*)atomic_load_acquire(&exn_cache); if (!exn) { exn = caml_named_value("Pervasives.array_bound_error"); if (!exn) { @@ -205,7 +205,7 @@ static value array_bound_exn(void) "Invalid_argument(\"index out of bounds\")\n"); exit(2); } - atomic_store_rel(&exn_cache, (uintnat)exn); + atomic_store_release(&exn_cache, (uintnat)exn); } return *exn; } diff --git a/runtime/fiber.c b/runtime/fiber.c index 52d68fbbff..d86daf9141 100644 --- a/runtime/fiber.c +++ b/runtime/fiber.c @@ -670,14 +670,14 @@ static const value * cache_named_exception(const value * _Atomic * cache, const char * name) { const value * exn; - exn = atomic_load_explicit(cache, memory_order_acquire); + exn = atomic_load_acquire(cache); if (exn == NULL) { exn = caml_named_value(name); if (exn == NULL) { fprintf(stderr, "Fatal error: exception %s\n", name); exit(2); } - atomic_store_explicit(cache, exn, memory_order_release); + atomic_store_release(cache, exn); } return exn; } diff --git a/runtime/gc_ctrl.c b/runtime/gc_ctrl.c index 46a4145e15..1b43aca8c8 100644 --- a/runtime/gc_ctrl.c +++ b/runtime/gc_ctrl.c @@ -56,16 +56,17 @@ CAMLprim value caml_gc_quick_stat(value v) CAMLlocal1 (res); /* get a copy of these before allocating anything... */ - intnat majcoll; + intnat majcoll, mincoll; struct gc_stats s; caml_compute_gc_stats(&s); majcoll = caml_major_cycles_completed; + mincoll = atomic_load(&caml_minor_collections_count); res = caml_alloc_tuple (17); Store_field (res, 0, caml_copy_double ((double)s.alloc_stats.minor_words)); Store_field (res, 1, caml_copy_double ((double)s.alloc_stats.promoted_words)); Store_field (res, 2, caml_copy_double ((double)s.alloc_stats.major_words)); - Store_field (res, 3, Val_long (s.alloc_stats.minor_collections)); + Store_field (res, 3, Val_long (mincoll)); Store_field (res, 4, Val_long (majcoll)); Store_field (res, 5, Val_long ( s.heap_stats.pool_words + s.heap_stats.large_words)); diff --git a/runtime/gc_stats.c b/runtime/gc_stats.c index 4435521b68..c869de0f13 100644 --- a/runtime/gc_stats.c +++ b/runtime/gc_stats.c @@ -54,7 +54,6 @@ void caml_accum_alloc_stats( acc->minor_words += s->minor_words; acc->promoted_words += s->promoted_words; acc->major_words += s->major_words; - acc->minor_collections += s->minor_collections; acc->forced_major_collections += s->forced_major_collections; } @@ -65,7 +64,6 @@ void caml_collect_alloc_stats_sample( sample->minor_words = local->stat_minor_words; sample->promoted_words = local->stat_promoted_words; sample->major_words = local->stat_major_words; - sample->minor_collections = atomic_load(&caml_minor_collections_count); sample->forced_major_collections = local->stat_forced_major_collections; } @@ -96,7 +94,7 @@ void caml_orphan_alloc_stats(caml_domain_state *domain) { caml_collect_alloc_stats_sample(domain, &alloc_stats); caml_reset_domain_alloc_stats(domain); - /* push them into the oprhan stats */ + /* push them into the orphan stats */ caml_plat_lock(&orphan_lock); caml_accum_alloc_stats(&orphaned_alloc_stats, &alloc_stats); caml_plat_unlock(&orphan_lock); diff --git a/runtime/interp.c b/runtime/interp.c index 891096debf..92f6dd7d3e 100644 --- a/runtime/interp.c +++ b/runtime/interp.c @@ -1211,8 +1211,7 @@ value caml_interprete(code_t prog, asize_t prog_size) accu = Val_int(*pc++); /* We use relaxed atomic accesses to avoid racing with other domains updating the cache */ - ofs = atomic_load_explicit((_Atomic opcode_t *)pc, memory_order_relaxed) - & Field(meths,1); + ofs = atomic_load_relaxed((_Atomic opcode_t *)pc) & Field(meths,1); if (*(value*)(((char*)&Field(meths,3)) + ofs) == accu) { #ifdef CAML_TEST_CACHE hits++; @@ -1227,8 +1226,7 @@ value caml_interprete(code_t prog, asize_t prog_size) if (accu < Field(meths,mi)) hi = mi-2; else li = mi; } - atomic_store_explicit((_Atomic opcode_t *)pc, (li-3)*sizeof(value), - memory_order_relaxed); + atomic_store_relaxed((_Atomic opcode_t *)pc, (li-3)*sizeof(value)); accu = Field (meths, li-1); } pc++; diff --git a/runtime/lf_skiplist.c b/runtime/lf_skiplist.c index 6cbe46d874..59434fee82 100644 --- a/runtime/lf_skiplist.c +++ b/runtime/lf_skiplist.c @@ -74,8 +74,7 @@ static int random_level(void) { (Knuth vol 2 p. 106, line 15 of table 1), additive = 25173. */ while( 1 ) { - uint32_t curr = - atomic_load_explicit(&random_seed, memory_order_relaxed); + uint32_t curr = atomic_load_relaxed(&random_seed); r = curr * 69069 + 25173; @@ -97,7 +96,7 @@ static int random_level(void) { /* Initialize a skip list */ void caml_lf_skiplist_init(struct lf_skiplist *sk) { - atomic_store_explicit(&sk->search_level, 0, memory_order_relaxed); + atomic_store_relaxed(&sk->search_level, 0); /* This concurrent skip list has two sentinel nodes, the first [head] is less than any possible key in the data structure and the second [tail] is @@ -125,11 +124,9 @@ void caml_lf_skiplist_init(struct lf_skiplist *sk) { /* each level in the skip list starts of being just head pointing to tail */ for (int j = 0; j < NUM_LEVELS; j++) { - atomic_store_explicit - (&sk->head->forward[j], sk->tail, memory_order_release); + atomic_store_release(&sk->head->forward[j], sk->tail); - atomic_store_explicit - (&sk->tail->forward[j], NULL, memory_order_release); + atomic_store_release(&sk->tail->forward[j], NULL); } } @@ -172,8 +169,7 @@ retry: compare-and-swap. */ for (int level = NUM_LEVELS - 1; level >= 0; level--) { - curr = LF_SK_UNMARK( - atomic_load_explicit(&pred->forward[level], memory_order_acquire)); + curr = LF_SK_UNMARK(atomic_load_acquire(&pred->forward[level])); while (1) { int is_marked; @@ -210,10 +206,9 @@ retry: This is why we need to a retry loop and yet another CAS. */ while (1) { struct lf_skipcell *_Atomic current_garbage_head = - atomic_load_explicit(&sk->garbage_head, memory_order_acquire); + atomic_load_acquire(&sk->garbage_head); - atomic_store_explicit(&curr->garbage_next, current_garbage_head, - memory_order_release); + atomic_store_release(&curr->garbage_next, current_garbage_head); if (atomic_compare_exchange_strong( &sk->garbage_head, @@ -225,8 +220,7 @@ retry: /* Now try to load the current node again. We need to check it too hasn't been marked. If it has we repeat the process */ - curr = LF_SK_UNMARK(atomic_load_explicit(&pred->forward[level], - memory_order_acquire)); + curr = LF_SK_UNMARK(atomic_load_acquire(&pred->forward[level])); LF_SK_EXTRACT(curr->forward[level], is_marked, succ); } @@ -271,11 +265,9 @@ static struct lf_skipcell *lf_skiplist_lookup(struct lf_skiplist *sk, level then our only cost is an increased number of nodes searched. If we did the same thing in the find function above then we'd also fail to snip out marked nodes. If we did that for long enough we might leak memory. */ - for (int level = - atomic_load_explicit(&sk->search_level, memory_order_relaxed); + for (int level = atomic_load_relaxed(&sk->search_level); level >= 0; level--) { - curr = LF_SK_UNMARK( - atomic_load_explicit(&pred->forward[level], memory_order_acquire)); + curr = LF_SK_UNMARK(atomic_load_acquire(&pred->forward[level])); while (1) { LF_SK_EXTRACT(curr->forward[level], marked, succ); while (marked) { @@ -355,8 +347,7 @@ int caml_lf_skiplist_insert(struct lf_skiplist *sk, uintnat key, uintnat data) { if (found) { /* Already present; update data */ - atomic_store_explicit((atomic_uintnat*)&succs[0]->data, data, - memory_order_relaxed); + atomic_store_relaxed((atomic_uintnat*)&succs[0]->data, data); return 1; } else { /* node does not exist. We need to generate a random top_level and @@ -374,11 +365,10 @@ int caml_lf_skiplist_insert(struct lf_skiplist *sk, uintnat key, uintnat data) { new_cell->top_level = top_level; new_cell->key = key; new_cell->data = data; - atomic_store_explicit(&new_cell->garbage_next,NULL,memory_order_relaxed); + atomic_store_relaxed(&new_cell->garbage_next,NULL); for (int level = 0; level <= top_level; level++) { - atomic_store_explicit(&new_cell->forward[level], succs[level], - memory_order_release); + atomic_store_release(&new_cell->forward[level], succs[level]); } /* Now we need to actually slip the node in. We start at the bottom-most @@ -426,10 +416,8 @@ int caml_lf_skiplist_insert(struct lf_skiplist *sk, uintnat key, uintnat data) { /* If we put the new node at a higher level than the current [search_level] then to speed up searches we need to bump it. We don't care too much if this fails though. */ - if (top_level > - atomic_load_explicit(&sk->search_level, memory_order_relaxed)) { - atomic_store_explicit(&sk->search_level, top_level, - memory_order_relaxed); + if (top_level > atomic_load_relaxed(&sk->search_level)) { + atomic_store_relaxed(&sk->search_level, top_level); } return 1; @@ -500,17 +488,15 @@ int caml_lf_skiplist_remove(struct lf_skiplist *sk, uintnat key) { skiplist */ void caml_lf_skiplist_free_garbage(struct lf_skiplist *sk) { - struct lf_skipcell *curr = - atomic_load_explicit(&sk->garbage_head, memory_order_acquire); + struct lf_skipcell *curr = atomic_load_acquire(&sk->garbage_head); struct lf_skipcell *head = sk->head; while (curr != head) { - struct lf_skipcell *next = atomic_load_explicit - (&curr->garbage_next, memory_order_relaxed); + struct lf_skipcell *next = atomic_load_relaxed(&curr->garbage_next); // acquire not useful, if executed in STW caml_stat_free(curr); curr = next; } - atomic_store_explicit(&sk->garbage_head, sk->head, memory_order_release); + atomic_store_release(&sk->garbage_head, sk->head); } diff --git a/runtime/major_gc.c b/runtime/major_gc.c index 3ed9bba0a8..7f1dac022d 100644 --- a/runtime/major_gc.c +++ b/runtime/major_gc.c @@ -44,14 +44,14 @@ #define MARK_STACK_INIT_SIZE (1 << 12) /* The mark stack consists of two parts: - 1. the stack - consisting of spans of fields that need to be marked, and - 2. the compressed stack - consisting of entries (k, bitfield) - where the bitfield represents word offsets from k that need to - be marked. + 1. the stack - a dynamic array of spans of fields that need to be marked, and + 2. the compressed stack - a bitset of fields that need to be marked. The stack is bounded relative to the heap size. When the stack overflows the bound, then entries from the stack are compressed and - transferred into the compressed stack. + transferred into the compressed stack, expect for "large" entries, + spans of more than BITS_PER_WORD entries, that are more compactly + represented as spans and remain on the uncompressed stack. When the stack is empty, the compressed stack is processed. The compressed stack iterator marks the point up to which @@ -196,8 +196,8 @@ static void ephe_next_cycle (void) caml_plat_lock(&ephe_lock); atomic_fetch_add(&ephe_cycle_info.ephe_cycle, +1); - CAMLassert(atomic_load_acq(&ephe_cycle_info.num_domains_done) <= - atomic_load_acq(&ephe_cycle_info.num_domains_todo)); + CAMLassert(atomic_load_acquire(&ephe_cycle_info.num_domains_done) <= + atomic_load_acquire(&ephe_cycle_info.num_domains_todo)); atomic_store(&ephe_cycle_info.num_domains_done, 0); caml_plat_unlock(&ephe_lock); @@ -216,8 +216,8 @@ static void ephe_todo_list_emptied (void) /* Since the todo list is empty, this domain does not need to participate in * further ephemeron cycles. */ atomic_fetch_add(&ephe_cycle_info.num_domains_todo, -1); - CAMLassert(atomic_load_acq(&ephe_cycle_info.num_domains_done) <= - atomic_load_acq(&ephe_cycle_info.num_domains_todo)); + CAMLassert(atomic_load_acquire(&ephe_cycle_info.num_domains_done) <= + atomic_load_acquire(&ephe_cycle_info.num_domains_todo)); caml_plat_unlock(&ephe_lock); } @@ -225,18 +225,18 @@ static void ephe_todo_list_emptied (void) /* Record that ephemeron marking was done for the given ephemeron cycle. */ static void record_ephe_marking_done (uintnat ephe_cycle) { - CAMLassert (ephe_cycle <= atomic_load_acq(&ephe_cycle_info.ephe_cycle)); + CAMLassert (ephe_cycle <= atomic_load_acquire(&ephe_cycle_info.ephe_cycle)); CAMLassert (Caml_state->marking_done); - if (ephe_cycle < atomic_load_acq(&ephe_cycle_info.ephe_cycle)) + if (ephe_cycle < atomic_load_acquire(&ephe_cycle_info.ephe_cycle)) return; caml_plat_lock(&ephe_lock); if (ephe_cycle == atomic_load(&ephe_cycle_info.ephe_cycle)) { Caml_state->ephe_info->cycle = ephe_cycle; atomic_fetch_add(&ephe_cycle_info.num_domains_done, +1); - CAMLassert(atomic_load_acq(&ephe_cycle_info.num_domains_done) <= - atomic_load_acq(&ephe_cycle_info.num_domains_todo)); + CAMLassert(atomic_load_acquire(&ephe_cycle_info.num_domains_done) <= + atomic_load_acquire(&ephe_cycle_info.num_domains_todo)); } caml_plat_unlock(&ephe_lock); } @@ -939,10 +939,22 @@ again: return budget; } -/* compressed mark stack */ -#define PAGE_MASK (~(uintnat)(BITS_PER_WORD-1)) -#define PTR_TO_PAGE(v) (((uintnat)(v)/sizeof(value)) & PAGE_MASK) -#define PTR_TO_PAGE_OFFSET(v) ((((uintnat)(v)/sizeof(value)) & ~PAGE_MASK)) +/* Compressed mark stack + + We use a bitset, implemented as a hashtable storing word-sized + integers (uintnat). Each integer represents a "chunk" of addresses + that may or may not be present in the stack. + */ +static const uintnat chunk_mask = ~(uintnat)(BITS_PER_WORD-1); +static inline uintnat ptr_to_chunk(value *ptr) { + return ((uintnat)(ptr) / sizeof(value)) & chunk_mask; +} +static inline uintnat ptr_to_chunk_offset(value *ptr) { + return ((uintnat)(ptr) / sizeof(value)) & ~chunk_mask; +} +static inline value* chunk_and_offset_to_ptr(uintnat chunk, uintnat offset) { + return (value*)((chunk + offset) * sizeof(value)); +} /* mark until the budget runs out or marking is done */ static intnat mark(intnat budget) { @@ -950,12 +962,11 @@ static intnat mark(intnat budget) { while (budget > 0 && !domain_state->marking_done) { budget = do_some_marking(domain_state->mark_stack, budget); if (budget > 0) { - int i; struct mark_stack* mstk = domain_state->mark_stack; addrmap_iterator it = mstk->compressed_stack_iter; if (caml_addrmap_iter_ok(&mstk->compressed_stack, it)) { - uintnat k = caml_addrmap_iter_key(&mstk->compressed_stack, it); - value v = caml_addrmap_iter_value(&mstk->compressed_stack, it); + uintnat chunk = caml_addrmap_iter_key(&mstk->compressed_stack, it); + uintnat bitset = caml_addrmap_iter_value(&mstk->compressed_stack, it); /* NB: must update the iterator here, as possible that mark_slice_darken could lead to the mark stack being pruned @@ -963,9 +974,9 @@ static intnat mark(intnat budget) { mstk->compressed_stack_iter = caml_addrmap_next(&mstk->compressed_stack, it); - for(i=0; i<BITS_PER_WORD; i++) { - if(v & ((uintnat)1 << i)) { - value* p = (value*)((k + i)*sizeof(value)); + for(int ofs=0; ofs<BITS_PER_WORD; ofs++) { + if(bitset & ((uintnat)1 << ofs)) { + value* p = chunk_and_offset_to_ptr(chunk, ofs); mark_slice_darken(domain_state->mark_stack, *p, &budget); } } @@ -998,10 +1009,8 @@ void caml_darken_cont(value cont) if (Ptr_val(stk) != NULL) caml_scan_stack(&caml_darken, darken_scanning_flags, Caml_state, Ptr_val(stk), 0); - atomic_store_explicit( - Hp_atomic_val(cont), - With_status_hd(hd, caml_global_heap_state.MARKED), - memory_order_release); + atomic_store_release(Hp_atomic_val(cont), + With_status_hd(hd, caml_global_heap_state.MARKED)); } } } @@ -1157,8 +1166,8 @@ static void cycle_all_domains_callback(caml_domain_state* domain, void* unused, CAML_EV_BEGIN(EV_MAJOR_GC_CYCLE_DOMAINS); CAMLassert(domain == Caml_state); - CAMLassert(atomic_load_acq(&ephe_cycle_info.num_domains_todo) == - atomic_load_acq(&ephe_cycle_info.num_domains_done)); + CAMLassert(atomic_load_acquire(&ephe_cycle_info.num_domains_todo) == + atomic_load_acquire(&ephe_cycle_info.num_domains_done)); CAMLassert(atomic_load(&num_domains_to_mark) == 0); CAMLassert(atomic_load(&num_domains_to_sweep) == 0); CAMLassert(atomic_load(&num_domains_to_ephe_sweep) == 0); @@ -1235,20 +1244,22 @@ static void cycle_all_domains_callback(caml_domain_state* domain, void* unused, domain->swept_words = 0; num_domains_in_stw = (uintnat)caml_global_barrier_num_domains(); - atomic_store_rel(&num_domains_to_sweep, num_domains_in_stw); - atomic_store_rel(&num_domains_to_mark, num_domains_in_stw); + atomic_store_release(&num_domains_to_sweep, num_domains_in_stw); + atomic_store_release(&num_domains_to_mark, num_domains_in_stw); caml_gc_phase = Phase_sweep_and_mark_main; atomic_store(&ephe_cycle_info.num_domains_todo, num_domains_in_stw); atomic_store(&ephe_cycle_info.ephe_cycle, 1); atomic_store(&ephe_cycle_info.num_domains_done, 0); - atomic_store_rel(&num_domains_to_ephe_sweep, 0); + atomic_store_release(&num_domains_to_ephe_sweep, 0); /* Will be set to the correct number when switching to [Phase_sweep_ephe] */ - atomic_store_rel(&num_domains_to_final_update_first, num_domains_in_stw); - atomic_store_rel(&num_domains_to_final_update_last, num_domains_in_stw); + atomic_store_release(&num_domains_to_final_update_first, + num_domains_in_stw); + atomic_store_release(&num_domains_to_final_update_last, + num_domains_in_stw); atomic_store(&domain_global_roots_started, WORK_UNSTARTED); @@ -1355,11 +1366,11 @@ static int is_complete_phase_sweep_and_mark_main (void) { return caml_gc_phase == Phase_sweep_and_mark_main && - atomic_load_acq (&num_domains_to_sweep) == 0 && - atomic_load_acq (&num_domains_to_mark) == 0 && + atomic_load_acquire (&num_domains_to_sweep) == 0 && + atomic_load_acquire (&num_domains_to_mark) == 0 && /* Marking is done */ - atomic_load_acq(&ephe_cycle_info.num_domains_todo) == - atomic_load_acq(&ephe_cycle_info.num_domains_done) && + atomic_load_acquire(&ephe_cycle_info.num_domains_todo) == + atomic_load_acquire(&ephe_cycle_info.num_domains_done) && /* Ephemeron marking is done */ no_orphaned_work(); /* All orphaned ephemerons have been adopted */ @@ -1369,12 +1380,12 @@ static int is_complete_phase_mark_final (void) { return caml_gc_phase == Phase_mark_final && - atomic_load_acq (&num_domains_to_final_update_first) == 0 && + atomic_load_acquire (&num_domains_to_final_update_first) == 0 && /* updated finalise first values */ - atomic_load_acq (&num_domains_to_mark) == 0 && + atomic_load_acquire (&num_domains_to_mark) == 0 && /* Marking is done */ - atomic_load_acq(&ephe_cycle_info.num_domains_todo) == - atomic_load_acq(&ephe_cycle_info.num_domains_done) && + atomic_load_acquire(&ephe_cycle_info.num_domains_todo) == + atomic_load_acquire(&ephe_cycle_info.num_domains_done) && /* Ephemeron marking is done */ no_orphaned_work(); /* All orphaned ephemerons have been adopted */ @@ -1384,9 +1395,9 @@ static int is_complete_phase_sweep_ephe (void) { return caml_gc_phase == Phase_sweep_ephe && - atomic_load_acq (&num_domains_to_ephe_sweep) == 0 && + atomic_load_acquire (&num_domains_to_ephe_sweep) == 0 && /* All domains have swept their ephemerons */ - atomic_load_acq (&num_domains_to_final_update_last) == 0 && + atomic_load_acquire (&num_domains_to_final_update_last) == 0 && /* All domains have updated finalise last values */ no_orphaned_work(); /* All orphaned structures have been adopted */ @@ -1405,7 +1416,7 @@ static void try_complete_gc_phase (caml_domain_state* domain, void* unused, caml_gc_phase = Phase_mark_final; } else if (is_complete_phase_mark_final()) { caml_gc_phase = Phase_sweep_ephe; - atomic_store_rel(&num_domains_to_ephe_sweep, participant_count); + atomic_store_release(&num_domains_to_ephe_sweep, participant_count); for (int i = 0; i < participant_count; i++) participating[i]->ephe_info->must_sweep_ephe = 1; } @@ -1549,7 +1560,7 @@ mark_again: /* Ephemerons */ if (caml_gc_phase != Phase_sweep_ephe) { /* Ephemeron Marking */ - saved_ephe_cycle = atomic_load_acq(&ephe_cycle_info.ephe_cycle); + saved_ephe_cycle = atomic_load_acquire(&ephe_cycle_info.ephe_cycle); if (domain_state->ephe_info->todo != (value) NULL && saved_ephe_cycle > domain_state->ephe_info->cycle) { CAML_EV_BEGIN(EV_MAJOR_EPHE_MARK); @@ -1756,19 +1767,20 @@ void caml_finish_sweeping (void) CAML_EV_END(EV_MAJOR_FINISH_SWEEPING); } -Caml_inline int add_addr(struct addrmap* amap, value v) { - uintnat k = PTR_TO_PAGE(v); - uintnat flag = (uintnat)1 << PTR_TO_PAGE_OFFSET(v); +Caml_inline int add_addr(struct addrmap* amap, value* ptr) { + uintnat chunk = ptr_to_chunk(ptr); + uintnat offset = ptr_to_chunk_offset(ptr); + uintnat flag = (uintnat)1 << offset; int new_entry = 0; - value* amap_pos = caml_addrmap_insert_pos(amap, k); + value* amap_pos = caml_addrmap_insert_pos(amap, chunk); if (*amap_pos == ADDRMAP_NOT_PRESENT) { new_entry = 1; *amap_pos = 0; } - CAMLassert(v == (value)((k + PTR_TO_PAGE_OFFSET(v))*sizeof(value))); + CAMLassert(ptr == chunk_and_offset_to_ptr(chunk, offset)); if (!(*amap_pos & flag)) { *amap_pos |= flag; @@ -1813,7 +1825,7 @@ static void mark_stack_prune(struct mark_stack* stk) } else { while(me.start < me.end) { compressed_entries += add_addr(&stk->compressed_stack, - (uintnat)me.start); + me.start); me.start++; } } diff --git a/runtime/memory.c b/runtime/memory.c index 3af3a6f72b..1907d5ce84 100644 --- a/runtime/memory.c +++ b/runtime/memory.c @@ -152,8 +152,7 @@ CAMLexport CAMLweakdef void caml_modify (volatile value *fp, value val) /* See Note [MM] above */ atomic_thread_fence(memory_order_acquire); - atomic_store_explicit(&Op_atomic_val((value)fp)[0], val, - memory_order_release); + atomic_store_release(&Op_atomic_val((value)fp)[0], val); } /* Dependent memory is all memory blocks allocated out of the heap diff --git a/runtime/minor_gc.c b/runtime/minor_gc.c index 55476b9026..faad61c915 100644 --- a/runtime/minor_gc.c +++ b/runtime/minor_gc.c @@ -172,7 +172,7 @@ static void spin_on_header(value v) { } Caml_inline header_t get_header_val(value v) { - header_t hd = atomic_load_explicit(Hp_atomic_val(v), memory_order_acquire); + header_t hd = atomic_load_acquire(Hp_atomic_val(v)); if (!Is_update_in_progress(hd)) return hd; @@ -210,9 +210,9 @@ static int try_update_object_header(value v, volatile value *p, value result, header_t desired_hd = In_progress_update_val; if( atomic_compare_exchange_strong(Hp_atomic_val(v), &hd, desired_hd) ) { /* Success. Now we can write the forwarding pointer. */ - atomic_store_explicit(Op_atomic_val(v), result, memory_order_relaxed); + atomic_store_relaxed(Op_atomic_val(v), result); /* And update header ('release' ensures after update of fwd pointer) */ - atomic_store_rel(Hp_atomic_val(v), 0); + atomic_store_release(Hp_atomic_val(v), 0); /* Let the caller know we were responsible for the update */ success = 1; } else { @@ -675,7 +675,7 @@ void caml_do_opportunistic_major_slice if needed. */ void caml_empty_minor_heap_setup(caml_domain_state* domain_unused) { - atomic_store_explicit(&domains_finished_minor_gc, 0, memory_order_release); + atomic_store_release(&domains_finished_minor_gc, 0); /* Increment the total number of minor collections done in the program */ atomic_fetch_add (&caml_minor_collections_count, 1); } @@ -706,10 +706,8 @@ caml_stw_empty_minor_heap_no_major_slice(caml_domain_state* domain, CAML_EV_BEGIN(EV_MINOR_LEAVE_BARRIER); { SPIN_WAIT { - if( atomic_load_explicit - (&domains_finished_minor_gc, memory_order_acquire) - == - participating_count ) { + if (atomic_load_acquire(&domains_finished_minor_gc) == + participating_count) { break; } diff --git a/runtime/misc.c b/runtime/misc.c index 43fc5d600a..fd584cb719 100644 --- a/runtime/misc.c +++ b/runtime/misc.c @@ -30,6 +30,7 @@ __declspec(noreturn) void __cdecl abort(void); #include <stdarg.h> #include <stdlib.h> #include "caml/config.h" +#include "caml/fail.h" #include "caml/misc.h" #include "caml/memory.h" #include "caml/osdeps.h" @@ -136,20 +137,35 @@ CAMLexport void caml_fatal_error_arg2 (const char *fmt1, const char *arg1, exit(2); } +#ifdef ARCH_SIXTYFOUR +#define MAX_EXT_TABLE_CAPACITY INT_MAX +#else +#define MAX_EXT_TABLE_CAPACITY ((asize_t) (-1) / sizeof(void *)) +#endif + void caml_ext_table_init(struct ext_table * tbl, int init_capa) { + CAMLassert (init_capa <= MAX_EXT_TABLE_CAPACITY); tbl->size = 0; tbl->capacity = init_capa; - tbl->contents = caml_stat_alloc(sizeof(void *) * init_capa); + tbl->contents = caml_stat_alloc(sizeof(void *) * (asize_t) init_capa); } -int caml_ext_table_add(struct ext_table * tbl, caml_stat_block data) +int caml_ext_table_add_noexc(struct ext_table * tbl, caml_stat_block data) { int res; if (tbl->size >= tbl->capacity) { - tbl->capacity *= 2; - tbl->contents = - caml_stat_resize(tbl->contents, sizeof(void *) * tbl->capacity); + if (tbl->capacity == MAX_EXT_TABLE_CAPACITY) return -1; /* overflow */ + int new_capacity = + tbl->capacity <= MAX_EXT_TABLE_CAPACITY / 2 + ? tbl->capacity * 2 + : MAX_EXT_TABLE_CAPACITY; + void ** new_contents = + caml_stat_resize_noexc(tbl->contents, + sizeof(void *) * (asize_t) new_capacity); + if (new_contents == NULL) return -1; + tbl->capacity = new_capacity; + tbl->contents = new_contents; } res = tbl->size; tbl->contents[res] = data; @@ -157,6 +173,13 @@ int caml_ext_table_add(struct ext_table * tbl, caml_stat_block data) return res; } +int caml_ext_table_add(struct ext_table * tbl, caml_stat_block data) +{ + int res = caml_ext_table_add_noexc(tbl, data); + if (res == -1) caml_raise_out_of_memory(); + return res; +} + void caml_ext_table_remove(struct ext_table * tbl, caml_stat_block data) { int i; diff --git a/runtime/obj.c b/runtime/obj.c index cdaa4c1766..56db69f5fa 100644 --- a/runtime/obj.c +++ b/runtime/obj.c @@ -44,7 +44,7 @@ static int obj_tag (value arg) /* The acquire load ensures that reading the field of a Forward_tag block in stdlib/camlinternalLazy.ml:force_gen has the necessary synchronization. */ - hd = (header_t)atomic_load_acq(Hp_atomic_val(arg)); + hd = (header_t)atomic_load_acquire(Hp_atomic_val(arg)); return Tag_hd(hd); } } diff --git a/runtime/platform.c b/runtime/platform.c index 34544b8bf5..b3bf88a7aa 100644 --- a/runtime/platform.c +++ b/runtime/platform.c @@ -165,7 +165,7 @@ void* caml_mem_map(uintnat size, uintnat alignment, int reserve_only) if (mmap_blocks.head == NULL) { /* The first call to caml_mem_map should be during caml_init_domains, called by caml_init_gc during startup - i.e. before any domains have started. */ - CAMLassert(atomic_load_acq(&caml_num_domains_running) <= 1); + CAMLassert(atomic_load_acquire(&caml_num_domains_running) <= 1); caml_lf_skiplist_init(&mmap_blocks); } #endif diff --git a/runtime/runtime_events.c b/runtime/runtime_events.c index 921b3cd538..1e5e141c0f 100644 --- a/runtime/runtime_events.c +++ b/runtime/runtime_events.c @@ -182,7 +182,7 @@ static void runtime_events_teardown_raw(int remove_file) { caml_stat_free(current_ring_loc); current_metadata = NULL; - atomic_store_rel(&runtime_events_enabled, 0); + atomic_store_release(&runtime_events_enabled, 0); } /* Stop-the-world which calls the teardown code */ @@ -204,7 +204,7 @@ void caml_runtime_events_post_fork(void) { new domain can have run yet. Let's be double sure. */ CAMLassert(caml_domain_alone()); - if (atomic_load_acq(&runtime_events_enabled)) { + if (atomic_load_acquire(&runtime_events_enabled)) { /* In the child we need to tear down the various structures used for the existing runtime_events from the parent. In doing so we need to make sure we don't remove the runtime_events file itself as that may still be used by @@ -220,7 +220,7 @@ void caml_runtime_events_post_fork(void) { /* Return the current location for the ring buffers of this process. This is used in the consumer to read the ring buffers of the current process */ char_os* caml_runtime_events_current_location(void) { - if( atomic_load_acq(&runtime_events_enabled) ) { + if( atomic_load_acquire(&runtime_events_enabled) ) { return current_ring_loc; } else { return NULL; @@ -230,7 +230,7 @@ char_os* caml_runtime_events_current_location(void) { /* Write a lifecycle event and then trigger a stop the world to tear down the ring buffers */ void caml_runtime_events_destroy(void) { - if (atomic_load_acq(&runtime_events_enabled)) { + if (atomic_load_acquire(&runtime_events_enabled)) { write_to_ring( EV_RUNTIME, (ev_message_type){.runtime=EV_LIFECYCLE}, EV_RING_STOP, 0, NULL, 0); @@ -242,7 +242,7 @@ void caml_runtime_events_destroy(void) { caml_try_run_on_all_domains(&stw_teardown_runtime_events, &remove_file, NULL); } - while( atomic_load_acq(&runtime_events_enabled) ); + while( atomic_load_acquire(&runtime_events_enabled) ); } } @@ -251,7 +251,7 @@ void caml_runtime_events_destroy(void) { domain running. */ static void runtime_events_create_raw(void) { /* Don't initialise runtime_events twice */ - if (!atomic_load_acq(&runtime_events_enabled)) { + if (!atomic_load_acquire(&runtime_events_enabled)) { int ret, ring_headers_length, ring_data_length; #ifdef _WIN32 DWORD pid = GetCurrentProcessId(); @@ -386,10 +386,10 @@ static void runtime_events_create_raw(void) { // runtime_events_enabled to 1 caml_plat_lock(&user_events_lock); value current_user_event = user_events; - atomic_store_rel(&runtime_events_enabled, 1); + atomic_store_release(&runtime_events_enabled, 1); caml_plat_unlock(&user_events_lock); - atomic_store_rel(&runtime_events_paused, 0); + atomic_store_release(&runtime_events_paused, 0); caml_ev_lifecycle(EV_RING_START, pid); @@ -421,7 +421,7 @@ stw_create_runtime_events(caml_domain_state *domain_state, void *data, } CAMLprim value caml_runtime_events_start(void) { - while (!atomic_load_acq(&runtime_events_enabled)) { + while (!atomic_load_acquire(&runtime_events_enabled)) { caml_try_run_on_all_domains(&stw_create_runtime_events, NULL, NULL); } @@ -429,7 +429,7 @@ CAMLprim value caml_runtime_events_start(void) { } CAMLprim value caml_runtime_events_pause(void) { - if (!atomic_load_acq(&runtime_events_enabled)) return Val_unit; + if (!atomic_load_acquire(&runtime_events_enabled)) return Val_unit; uintnat not_paused = 0; @@ -441,7 +441,7 @@ CAMLprim value caml_runtime_events_pause(void) { } CAMLprim value caml_runtime_events_resume(void) { - if (!atomic_load_acq(&runtime_events_enabled)) return Val_unit; + if (!atomic_load_acquire(&runtime_events_enabled)) return Val_unit; uintnat paused = 1; @@ -478,10 +478,8 @@ static void write_to_ring(ev_category category, ev_message_type type, /* the head and tail indexes for the current domain's ring buffer (out of the header) */ - uint64_t ring_head = atomic_load_explicit(&domain_ring_header->ring_head, - memory_order_acquire); - uint64_t ring_tail = atomic_load_explicit(&domain_ring_header->ring_tail, - memory_order_acquire); + uint64_t ring_head = atomic_load_acquire(&domain_ring_header->ring_head); + uint64_t ring_tail = atomic_load_acquire(&domain_ring_header->ring_tail); /* since rings can only be powers of two in size, we use this mask to cheaply convert the head and tail indexes in to the physical offset in the ring @@ -519,8 +517,8 @@ static void write_to_ring(ev_category category, ev_message_type type, ring_head += RUNTIME_EVENTS_ITEM_LENGTH(head_header); - atomic_store_explicit(&domain_ring_header->ring_head, ring_head, - memory_order_release); // advance the ring head + // advance the ring head + atomic_store_release(&domain_ring_header->ring_head, ring_head); } if (padding_required > 0) { @@ -532,8 +530,7 @@ static void write_to_ring(ev_category category, ev_message_type type, ring_tail += ring_distance_to_end; - atomic_store_explicit(&domain_ring_header->ring_tail, ring_tail, - memory_order_release); + atomic_store_release(&domain_ring_header->ring_tail, ring_tail); ring_tail_offset = 0; } @@ -553,17 +550,16 @@ static void write_to_ring(ev_category category, ev_message_type type, memcpy(&ring_ptr[ring_tail_offset], content + word_offset, event_length * sizeof(uint64_t)); } - atomic_store_explicit(&domain_ring_header->ring_tail, - ring_tail + length_with_header_ts, - memory_order_release); + atomic_store_release(&domain_ring_header->ring_tail, + ring_tail + length_with_header_ts); } /* Functions for putting runtime data on to the runtime_events */ static inline int ring_is_active(void) { return - atomic_load_explicit(&runtime_events_enabled, memory_order_relaxed) - && !atomic_load_explicit(&runtime_events_paused, memory_order_relaxed); + atomic_load_relaxed(&runtime_events_enabled) + && !atomic_load_relaxed(&runtime_events_paused); } void caml_ev_begin(ev_runtime_phase phase) { @@ -680,7 +676,7 @@ CAMLprim value caml_runtime_events_user_register(value event_name, // critical section: when we update the user_events list we need to make sure // it is not updated while we construct the pointer to the next element - if (atomic_load_acq(&runtime_events_enabled)) { + if (atomic_load_acquire(&runtime_events_enabled)) { // Ring buffer is already available, we register the name events_register_write_buffer(index, event_name); } diff --git a/runtime/shared_heap.c b/runtime/shared_heap.c index 0859801a01..19888b9751 100644 --- a/runtime/shared_heap.c +++ b/runtime/shared_heap.c @@ -480,7 +480,7 @@ static intnat pool_sweep(struct caml_heap_state* local, pool** plist, { int i; mlsize_t wo = Wosize_whsize(wh); - for (i = 2; i < wo; i++) { + for (i = 1; i < wo; i++) { Field(Val_hp(p), i) = Debug_free_major; } } diff --git a/runtime/signals.c b/runtime/signals.c index cf9774d199..5a21024ad4 100644 --- a/runtime/signals.c +++ b/runtime/signals.c @@ -285,7 +285,7 @@ CAMLno_tsan /* When called from [caml_record_signal], these memory void caml_set_action_pending(caml_domain_state * dom_st) { dom_st->action_pending = 1; - atomic_store_rel(&dom_st->young_limit, (uintnat)-1); + atomic_store_release(&dom_st->young_limit, (uintnat)-1); } CAMLexport int caml_check_pending_actions(void) diff --git a/runtime/sys.c b/runtime/sys.c index 0c93b788b1..26c7246b00 100644 --- a/runtime/sys.c +++ b/runtime/sys.c @@ -169,7 +169,7 @@ CAMLexport void caml_do_exit(int retcode) (intnat) majwords); caml_gc_message(0x400, "minor_collections: %"ARCH_INTNAT_PRINTF_FORMAT"d\n", - (intnat) s.alloc_stats.minor_collections); + (intnat) atomic_load(&caml_minor_collections_count)); caml_gc_message(0x400, "major_collections: %"ARCH_INTNAT_PRINTF_FORMAT"d\n", caml_major_cycles_completed); diff --git a/runtime/unix.c b/runtime/unix.c index 0877ec37a0..a71980497c 100644 --- a/runtime/unix.c +++ b/runtime/unix.c @@ -354,7 +354,8 @@ CAMLexport int caml_read_directory(char * dirname, struct ext_table * contents) e = readdir(d); if (e == NULL) break; if (strcmp(e->d_name, ".") == 0 || strcmp(e->d_name, "..") == 0) continue; - caml_ext_table_add(contents, caml_stat_strdup(e->d_name)); + int rc = caml_ext_table_add_noexc(contents, caml_stat_strdup(e->d_name)); + if (rc == -1) { closedir(d); errno = ENOMEM; return -1; } } closedir(d); return 0; diff --git a/runtime/weak.c b/runtime/weak.c index 1c5444b524..6ac6e22568 100644 --- a/runtime/weak.c +++ b/runtime/weak.c @@ -275,61 +275,93 @@ CAMLprim value caml_weak_get (value ar, value n) return caml_ephe_get_key(ar, n); } -static value ephe_get_field_copy (value e, mlsize_t offset) +/* Copy the contents of an object from `from` to `to` (which is + * already allocated and has the necessary header word). Darken + * any pointer fields. */ + +static void ephe_copy_and_darken(value from, value to) { - CAMLparam1 (e); - CAMLlocal2 (res, elt); - mlsize_t i, infix_offs = 0; - value v; /* Caution: this is NOT a local root. */ - value f; + mlsize_t i = 0; /* size of non-scannable prefix */ - clean_field(e, offset); - v = Field(e, offset); - if (v == caml_ephe_none) { - res = Val_none; - goto out; + CAMLassert(Is_block(from)); + CAMLassert(Is_block(to)); + CAMLassert(Tag_val(from) == Tag_val(to)); + CAMLassert(Tag_val(from) != Infix_tag); + CAMLassert(Wosize_val(from) == Wosize_val(to)); + + if (Tag_val(from) > No_scan_tag) { + i = Wosize_val(to); + } + else if (Tag_val(from) == Closure_tag) { + i = Start_env_closinfo(Closinfo_val(from)); } - /** Don't copy custom_block #7279 */ - if (Is_block(v) && Tag_val(v) != Custom_tag) { - if (Tag_val(v) == Infix_tag) { - infix_offs = Infix_offset_val(v); - v -= infix_offs; - } - elt = caml_alloc (Wosize_val(v), Tag_val(v)); + /* Copy non-scannable prefix */ + memcpy (Bp_val(to), Bp_val(from), Bsize_wsize(i)); + + /* Copy and darken scannable fields */ + caml_domain_state* domain_state = Caml_state; + while (i < Wosize_val(to)) { + value field = Field(from, i); + caml_darken (domain_state, field, 0); + Store_field(to, i, field); + ++ i; + } +} +static value ephe_get_field_copy (value e, mlsize_t offset) +{ + CAMLparam1 (e); + CAMLlocal3 (res, val, copy); + mlsize_t infix_offs = 0; + + copy = Val_unit; + /* Loop in case allocating the copy triggers a GC which modifies the + * ephemeron or the value. In the common case, we go around this + * loop 1.5 times. */ + while (1) { clean_field(e, offset); - v = Field(e, offset); - if (v == caml_ephe_none) CAMLreturn (Val_none); + val = Field(e, offset); - if (Tag_val(v) == Infix_tag) { - infix_offs = Infix_offset_val(v); - v -= infix_offs; + if (val == caml_ephe_none) { + res = Val_none; + goto out; } + infix_offs = 0; - if (Tag_val(v) < No_scan_tag) { - caml_domain_state* domain_state = Caml_state; - i = 0; - if (Tag_val (v) == Closure_tag) { - /* Direct copy of the code pointers and closure info fields */ - i = Start_env_closinfo(Closinfo_val(v)); - memcpy (Bp_val (elt), Bp_val (v), Bsize_wsize (i)); - } - /* Field-by-field copy and darkening of the remaining fields */ - for (/*nothing*/; i < Wosize_val(v); i++) { - f = Field(v, i); - caml_darken (domain_state, f, 0); - Store_field(elt, i, f); - } - } else { - memmove (Bp_val(elt), Bp_val(v), Bosize_val(v)); + /* Don't copy immediates or custom blocks #7279 */ + if (!Is_block(val) || Tag_val(val) == Custom_tag) { + copy = val; + goto some; } - } else { - Field(e, offset) = elt = v; + + if (Tag_val(val) == Infix_tag) { + infix_offs = Infix_offset_val(val); + val -= infix_offs; + } + + if (copy != Val_unit && + (Tag_val(val) == Tag_val(copy)) && + (Wosize_val(val) == Wosize_val(copy))) { + /* The copy we allocated (on a previous iteration) is large + * enough and has the right header bits for us to copy the + * contents of val into it. Note that we don't care whether val + * has changed since we allocated copy. */ + break; + } + + /* This allocation could provoke a GC, which could change the + * header or size of val (e.g. in a finalizer). So we go around + * the loop to read val again. */ + copy = caml_alloc (Wosize_val(val), Tag_val(val)); + val = Val_unit; } - res = caml_alloc_small (1, Tag_some); - Field(res, 0) = elt + infix_offs; - out: + + ephe_copy_and_darken(val, copy); + +some: + res = caml_alloc_some(copy + infix_offs); +out: /* run GC and memprof callbacks */ caml_process_pending_actions(); CAMLreturn(res); diff --git a/runtime/win32.c b/runtime/win32.c index 70c90f7a11..599805145f 100644 --- a/runtime/win32.c +++ b/runtime/win32.c @@ -445,7 +445,9 @@ CAMLexport int caml_read_directory(wchar_t * dirname, } do { if (wcscmp(fileinfo.name, L".") != 0 && wcscmp(fileinfo.name, L"..") != 0) { - caml_ext_table_add(contents, caml_stat_strdup_of_utf16(fileinfo.name)); + res = caml_ext_table_add_noexc(contents, + caml_stat_strdup_of_utf16(fileinfo.name)); + if (res == -1) { _findclose(h); errno = ENOMEM; return -1; } } } while (_wfindnext(h, &fileinfo) == 0); _findclose(h); |