Add Atomic_array

Author: polytypic

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

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))

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

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))))
 
 ;;
 

src/Multicore_magic.ml renamed to 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

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))

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)

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))

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));
+}

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)