Add Transparent_atomic module

src/Multicore_magic.ml

@@ -1,4 +1,5 @@
 include Padding
+module Transparent_atomic = Transparent_atomic
 
 let[@inline] fenceless_get (atomic : 'a Atomic.t) = !(Obj.magic atomic : 'a ref)
 

src/Multicore_magic.mli

@@ -128,3 +128,43 @@ val fence : int Atomic.t -> unit
 (** Perform a full acquire-release fence on the given atomic.
 
     [fence atomic] is equivalent to [ignore (Atomic.fetch_and_add atomic 0)]. *)
+
+(** {1 Fixes and workarounds} *)
+
+module Transparent_atomic : sig
+  (** A replacement for [Stdlib.Atomic] with fixes and performance improvements
+
+      [Stdlib.Atomic.get] is incorrectly subject to CSE optimization in OCaml
+      5.0.0 and 5.1.0.  This can result in code being generated that can produce
+      results that cannot be explained with the OCaml memory model.  It can also
+      sometimes result in code being generated where a manual optimization to
+      avoid writing to memory is defeated by the compiler as the compiler
+      eliminates a (repeated) read access.  This module implements {!get} such
+      that argument to [Stdlib.Atomic.get] is passed through
+      [Sys.opaque_identity], which prevents the compiler from applying the CSE
+      optimization.
+
+      OCaml 5 generates inefficient accesses of ['a Stdlib.Atomic.t array]s
+      assuming that the array might be an array of [float]ing point numbers.
+      That is because the [Stdlib.Atomic.t] type constructor is opaque, which
+      means that the compiler cannot assume that [_ Stdlib.Atomic.t] is not the
+      same as [float].  This module defines {{!t} the type} as [private 'a ref],
+      which allows the compiler to know that it cannot be the same as [float],
+      which allows the compiler to generate more efficient array accesses.  This
+      can both improve performance and reduce size of generated code when using
+      arrays of atomics. *)
+
+  type !'a t = private 'a ref
+
+  val make : 'a -> 'a t
+  val make_contended : 'a -> 'a t
+  val get : 'a t -> 'a
+  val fenceless_get : 'a t -> 'a
+  val set : 'a t -> 'a -> unit
+  val fenceless_set : 'a t -> 'a -> unit
+  val exchange : 'a t -> 'a -> 'a
+  val compare_and_set : 'a t -> 'a -> 'a -> bool
+  val fetch_and_add : int t -> int -> int
+  val incr : int t -> unit
+  val decr : int t -> unit
+end

src/transparent_atomic.ml

@@ -0,0 +1,21 @@
+type 'a t = 'a ref
+
+open struct
+  external as_atomic : 'a t -> 'a Atomic.t = "%identity"
+  external of_atomic : 'a Atomic.t -> 'a t = "%identity"
+end
+
+let[@inline] make x = of_atomic (Atomic.make x)
+
+let[@inline] make_contended x =
+  of_atomic (Padding.copy_as_padded (Atomic.make x))
+
+let[@inline] get x = Atomic.get (Sys.opaque_identity (as_atomic x))
+let[@inline] fenceless_get x = !(Sys.opaque_identity x)
+let[@inline] compare_and_set x b a = Atomic.compare_and_set (as_atomic x) b a
+let[@inline] exchange x v = Atomic.exchange (as_atomic x) v
+let[@inline] set x v = Atomic.set (as_atomic x) v
+let[@inline] fenceless_set x v = x := v
+let[@inline] fetch_and_add x v = Atomic.fetch_and_add (as_atomic x) v
+let[@inline] incr x = Atomic.incr (as_atomic x)
+let[@inline] decr x = Atomic.decr (as_atomic x)

test/Multicore_magic_test.ml

@@ -71,6 +71,17 @@ let fence () =
     Multicore_magic.fence atomic;
     Atomic.get atomic = 76)
 
+let transparent_atomic v0 v1 v2 () =
+  let x = Multicore_magic.Transparent_atomic.make_contended v0 in
+  assert (v0 = Multicore_magic.Transparent_atomic.fenceless_get x);
+  assert (v0 = Multicore_magic.Transparent_atomic.get x);
+  Multicore_magic.Transparent_atomic.set x v1;
+  assert (v1 = Multicore_magic.Transparent_atomic.fenceless_get x);
+  assert (v1 = Multicore_magic.Transparent_atomic.get x);
+  Multicore_magic.Transparent_atomic.fenceless_set x v2;
+  assert (v2 = Multicore_magic.Transparent_atomic.fenceless_get x);
+  assert (v2 = Multicore_magic.Transparent_atomic.get x)
+
 let () =
   Alcotest.run "multicore-magic"
     [
@@ -91,4 +102,8 @@ let () =
       ("fenceless_get", [ Alcotest.test_case "" `Quick fenceless_get ]);
       ("fenceless_set", [ Alcotest.test_case "" `Quick fenceless_set ]);
       ("fence", [ Alcotest.test_case "" `Quick fence ]);
+      ( "transparent_atomic with floats",
+        [ Alcotest.test_case "" `Quick (transparent_atomic 4.2 1.01 7.6) ] );
+      ( "transparent_atomic with ints",
+        [ Alcotest.test_case "" `Quick (transparent_atomic 42 101 76) ] );
     ]