From 79dc037a3a81aa4a858013a24dd77417547d1e9e Mon Sep 17 00:00:00 2001 From: Vesa Karvonen Date: Sat, 25 May 2024 17:29:55 +0300 Subject: [PATCH] Add `Atomic_array` --- src/Multicore_magic.mli | 60 +++++++++++++++++++ src/boxed5/dune | 7 +++ src/boxed5/multicore_magic_atomic_array.ml | 17 ++++++ src/dune | 9 ++- ...ore_magic.ml => multicore_magic.common.ml} | 2 + src/ocaml4/dune | 6 ++ src/ocaml4/multicore_magic_atomic_array.ml | 48 +++++++++++++++ src/unboxed5/dune | 11 ++++ src/unboxed5/multicore_magic_atomic_array.c | 9 +++ src/unboxed5/multicore_magic_atomic_array.ml | 43 +++++++++++++ test/Multicore_magic_test.ml | 16 +++++ 11 files changed, 227 insertions(+), 1 deletion(-) create mode 100644 src/boxed5/dune create mode 100644 src/boxed5/multicore_magic_atomic_array.ml rename src/{Multicore_magic.ml => multicore_magic.common.ml} (87%) create mode 100644 src/ocaml4/dune create mode 100644 src/ocaml4/multicore_magic_atomic_array.ml create mode 100644 src/unboxed5/dune create mode 100644 src/unboxed5/multicore_magic_atomic_array.c create mode 100644 src/unboxed5/multicore_magic_atomic_array.ml diff --git a/src/Multicore_magic.mli b/src/Multicore_magic.mli index ec817e9..45a3e68 100644 --- a/src/Multicore_magic.mli +++ b/src/Multicore_magic.mli @@ -169,6 +169,66 @@ module Transparent_atomic : sig val decr : int t -> unit end +(** {1 Missing functionality} *) + +module Atomic_array : sig + (** Array of (potentially unboxed) atomic locations. + + Where available, this uses an undocumented operation exported by the OCaml + 5 runtime, + {{:https://github.com/ocaml/ocaml/blob/7a5d882d22cdd32b6319e9be680bd1a3d67377a9/runtime/memory.c#L313-L338} + [caml_atomic_cas_field]}, which makes it possible to perform sequentially + consistent atomic updates of record fields and array elements. + + Hopefully a future version of OCaml provides more comprehensive and even + more efficient support for both sequentially consistent and relaxed atomic + operations on records and arrays. *) + + type !'a t + (** Represents an array of atomic locations. *) + + val make : int -> 'a -> 'a t + (** [make n value] creates a new array of [n] atomic locations having given + [value]. *) + + val of_array : 'a array -> 'a t + (** [of_array non_atomic_array] create a new array of atomic locations as a + copy of the given [non_atomic_array]. *) + + val init : int -> (int -> 'a) -> 'a t + (** [init n fn] is equivalent to {{!of_array} [of_array (Array.init n fn)]}. *) + + val length : 'a t -> int + (** [length atomic_array] returns the length of the [atomic_array]. *) + + val unsafe_fenceless_get : 'a t -> int -> 'a + (** [unsafe_fenceless_get atomic_array index] reads and returns the value at + the specified [index] of the [atomic_array]. + + ⚠️ The read is {i relaxed} and may be reordered with respect to other reads + and writes in program order. + + ⚠️ No bounds checking is performed. *) + + val unsafe_fenceless_set : 'a t -> int -> 'a -> unit + (** [unsafe_fenceless_set atomic_array index value] writes the given [value] + to the specified [index] of the [atomic_array]. + + ⚠️ The write is {i relaxed} and may be reordered with respect to other + reads and (non-initializing) writes in program order. + + ⚠️ No bounds checking is performed. *) + + val unsafe_compare_and_set : 'a t -> int -> 'a -> 'a -> bool + (** [unsafe_compare_and_set atomic_array index before after] atomically + updates the specified [index] of the [atomic_array] to the [after] value + in case it had the [before] value and returns a boolean indicating whether + that was the case. This operation is {i sequentially consistent} and may + not be reordered with respect to other reads and writes in program order. + + ⚠️ No bounds checking is performed. *) +end + (** {1 Avoiding contention} *) val instantaneous_domain_index : unit -> int diff --git a/src/boxed5/dune b/src/boxed5/dune new file mode 100644 index 0000000..439610f --- /dev/null +++ b/src/boxed5/dune @@ -0,0 +1,7 @@ +(library + (name multicore_magic_atomic_array_boxed5) + (package multicore-magic) + (enabled_if + (and + (<= 5.3.0 %{ocaml_version}))) + (wrapped false)) diff --git a/src/boxed5/multicore_magic_atomic_array.ml b/src/boxed5/multicore_magic_atomic_array.ml new file mode 100644 index 0000000..5907ec5 --- /dev/null +++ b/src/boxed5/multicore_magic_atomic_array.ml @@ -0,0 +1,17 @@ +type 'a t = 'a Atomic.t array + +let[@inline] at (type a) (xs : a t) i : a Atomic.t = + (* ['a t] does not contain [float]s. *) + Obj.magic (Array.unsafe_get (Obj.magic xs : a ref array) i) + +let[@inline] make n v = Array.init n @@ fun _ -> Atomic.make v +let[@inline] init n fn = Array.init n @@ fun i -> Atomic.make (fn i) +let[@inline] of_array xs = init (Array.length xs) (Array.unsafe_get xs) + +external length : 'a array -> int = "%array_length" + +let[@inline] unsafe_fenceless_set xs i v = Obj.magic (at xs i) := v +let[@inline] unsafe_fenceless_get xs i = !(Obj.magic (at xs i)) + +let[@inline] unsafe_compare_and_set xs i b a = + Atomic.compare_and_set (at xs i) b a diff --git a/src/dune b/src/dune index e3ffb92..ee1c9d3 100644 --- a/src/dune +++ b/src/dune @@ -1,6 +1,13 @@ (library (name Multicore_magic) - (public_name multicore-magic)) + (public_name multicore-magic) + (libraries + (select + multicore_magic.ml + from + (multicore_magic_atomic_array_unboxed5 -> multicore_magic.common.ml) + (multicore_magic_atomic_array_boxed5 -> multicore_magic.common.ml) + (multicore_magic_atomic_array_ocaml4 -> multicore_magic.common.ml)))) ;; diff --git a/src/Multicore_magic.ml b/src/multicore_magic.common.ml similarity index 87% rename from src/Multicore_magic.ml rename to src/multicore_magic.common.ml index daa313c..9086635 100644 --- a/src/Multicore_magic.ml +++ b/src/multicore_magic.common.ml @@ -9,3 +9,5 @@ let[@inline] fenceless_set (atomic : 'a Atomic.t) value = (Obj.magic atomic : 'a ref) := value let[@inline] fence atomic = Atomic.fetch_and_add atomic 0 |> ignore + +module Atomic_array = Multicore_magic_atomic_array diff --git a/src/ocaml4/dune b/src/ocaml4/dune new file mode 100644 index 0000000..7b6ecb0 --- /dev/null +++ b/src/ocaml4/dune @@ -0,0 +1,6 @@ +(library + (name multicore_magic_atomic_array_ocaml4) + (package multicore-magic) + (enabled_if + (< %{ocaml_version} 5.0.0)) + (wrapped false)) diff --git a/src/ocaml4/multicore_magic_atomic_array.ml b/src/ocaml4/multicore_magic_atomic_array.ml new file mode 100644 index 0000000..9a6fbbc --- /dev/null +++ b/src/ocaml4/multicore_magic_atomic_array.ml @@ -0,0 +1,48 @@ +type !'a t = 'a array + +let[@inline] unsafe_fenceless_set xs i x = + (* We never create [float array]s. *) + Array.unsafe_set (Obj.magic xs : string array) i (Obj.magic x) + +let[@inline never] make n x = + (* We never create [float array]s. *) + if Obj.tag (Obj.repr x) != Obj.double_tag then Array.make n x + else + let xs = Array.make n (Obj.magic ()) in + for i = 0 to n - 1 do + unsafe_fenceless_set xs i x + done; + xs + +let[@inline never] init n fn = + (* We never create [float array]s. *) + let ys = Array.make n (Obj.magic ()) in + for i = 0 to n - 1 do + unsafe_fenceless_set ys i (fn i) + done; + ys + +let[@inline never] of_array xs = + if Obj.tag (Obj.repr xs) != Obj.double_array_tag then Array.copy xs + else init (Array.length xs) (fun i -> Array.unsafe_get xs i) + +external length : 'a array -> int = "%array_length" + +let[@inline] unsafe_fenceless_get xs i = + (* We never create [float array]s. *) + Obj.magic + (Sys.opaque_identity (Array.unsafe_get (Obj.magic xs : string array) i)) + +let[@poll error] [@inline never] unsafe_compare_and_set (xs : string array) i b + a = + let before = Array.unsafe_get xs i in + before == b + && begin + Array.unsafe_set xs i a; + true + end + +let[@inline] unsafe_compare_and_set (type a) (xs : a array) i (b : a) (a : a) = + unsafe_compare_and_set + (Obj.magic xs : string array) + i (Obj.magic b) (Obj.magic a) diff --git a/src/unboxed5/dune b/src/unboxed5/dune new file mode 100644 index 0000000..8357fd8 --- /dev/null +++ b/src/unboxed5/dune @@ -0,0 +1,11 @@ +(library + (name multicore_magic_atomic_array_unboxed5) + (package multicore-magic) + (enabled_if + (and + (<= 5.0.0 %{ocaml_version}) + (< %{ocaml_version} 5.3.0))) + (foreign_stubs + (language c) + (names multicore_magic_atomic_array)) + (wrapped false)) diff --git a/src/unboxed5/multicore_magic_atomic_array.c b/src/unboxed5/multicore_magic_atomic_array.c new file mode 100644 index 0000000..8f7bb1e --- /dev/null +++ b/src/unboxed5/multicore_magic_atomic_array.c @@ -0,0 +1,9 @@ +#include "caml/mlvalues.h" +#include "caml/memory.h" +#include "caml/alloc.h" + +CAMLprim value caml_multicore_magic_atomic_array_cas( + value obj, intnat field, value oldval, value newval) +{ + return Val_int(caml_atomic_cas_field(obj, Int_val(field), oldval, newval)); +} diff --git a/src/unboxed5/multicore_magic_atomic_array.ml b/src/unboxed5/multicore_magic_atomic_array.ml new file mode 100644 index 0000000..4043cd7 --- /dev/null +++ b/src/unboxed5/multicore_magic_atomic_array.ml @@ -0,0 +1,43 @@ +type !'a t = 'a array + +let[@inline] unsafe_fenceless_set xs i x = + (* We never create [float array]s. *) + Array.unsafe_set (Obj.magic xs : string array) i (Obj.magic x) + +let[@inline never] make n x = + (* We never create [float array]s. *) + if Obj.tag (Obj.repr x) != Obj.double_tag then Array.make n x + else + let xs = Array.make n (Obj.magic ()) in + for i = 0 to n - 1 do + unsafe_fenceless_set xs i x + done; + xs + +let[@inline never] init n fn = + (* We never create [float array]s. *) + let ys = Array.make n (Obj.magic ()) in + for i = 0 to n - 1 do + unsafe_fenceless_set ys i (fn i) + done; + ys + +let[@inline never] of_array xs = + if Obj.tag (Obj.repr xs) != Obj.double_array_tag then Array.copy xs + else init (Array.length xs) (fun i -> Array.unsafe_get xs i) + +external length : 'a array -> int = "%array_length" + +let[@inline] unsafe_fenceless_get xs i = + (* We never create [float array]s. *) + Obj.magic + (Sys.opaque_identity (Array.unsafe_get (Obj.magic xs : string array) i)) + +let[@inline] unsafe_compare_and_set xs i b a : bool = + let open struct + external unsafe_compare_and_set_as_int : + 'a array -> (int[@untagged]) -> 'a -> 'a -> (int[@untagged]) + = "caml_multicore_magic_atomic_array_cas" "caml_atomic_cas_field" + [@@noalloc] + end in + Obj.magic (unsafe_compare_and_set_as_int xs i b a) diff --git a/test/Multicore_magic_test.ml b/test/Multicore_magic_test.ml index 10ee417..0f6f0ee 100644 --- a/test/Multicore_magic_test.ml +++ b/test/Multicore_magic_test.ml @@ -157,6 +157,21 @@ let test_instantaneous_domain_index () = stress () end +let atomic_array () = + let module Atomic_array = Multicore_magic.Atomic_array in + let floats = Atomic_array.of_array [| 1.01; 4.2 |] in + assert (Obj.tag (Obj.repr floats) != Obj.double_array_tag); + assert (Atomic_array.length floats = 2); + assert (Atomic_array.unsafe_fenceless_get floats 0 = 1.01); + assert (Atomic_array.unsafe_fenceless_get floats 1 = 4.2); + assert ( + Atomic_array.unsafe_compare_and_set floats 1 + (Atomic_array.unsafe_fenceless_get floats 1) + 7.6); + assert (Atomic_array.unsafe_fenceless_get floats 1 = 7.6); + Atomic_array.unsafe_fenceless_set floats 0 9.6; + assert (Atomic_array.unsafe_fenceless_get floats 0 = 9.6) + let () = Alcotest.run "multicore-magic" [ @@ -183,4 +198,5 @@ let () = [ Alcotest.test_case "" `Quick (transparent_atomic 42 101 76) ] ); ( "instantaneous_domain_index", [ Alcotest.test_case "" `Quick test_instantaneous_domain_index ] ); + ("Atomic_array", [ Alcotest.test_case "" `Quick atomic_array ]); ]