stdlib: provide a sequential interface of the Atomic module from OCaml Multicore

This module provides a purely sequential implementation of the
concurrent atomic references provided by the Multicore OCaml
standard library:

https://github.com/ocaml-multicore/ocaml-multicore/blob/parallel_minor_gc/stdlib/atomic.mli

This sequential implementation is provided in the interest of
compatibility: when people will start writing code to run on
Multicore, it would be nice if their use of Atomic was
backward-compatible with older versions of OCaml without having to
import additional compatibility layers. *)

Changes

@@ -3,6 +3,10 @@ Working version
 
 ### Language features:
 
+- #9570: Provide an Atomic module with a trivial purely-sequential
+  implementation, to help write code that is compatible with Multicore
+  OCaml.
+  (Gabriel Scherer, review by Xavier Leroy)
 
 ### Runtime system:
 

stdlib/.depend

@@ -31,6 +31,11 @@ stdlib__arrayLabels.cmx : \
     stdlib__arrayLabels.cmi
 stdlib__arrayLabels.cmi : \
     stdlib__seq.cmi
+stdlib__atomic.cmo : \
+    stdlib__atomic.cmi
+stdlib__atomic.cmx : \
+    stdlib__atomic.cmi
+stdlib__atomic.cmi :
 stdlib__bigarray.cmo : \
     stdlib__sys.cmi \
     stdlib__complex.cmi \

stdlib/StdlibModules

@@ -36,7 +36,7 @@ STDLIB_MODS=\
   camlinternalFormat printf arg printexc fun gc digest random hashtbl weak \
   format scanf callback camlinternalOO oo camlinternalMod genlex ephemeron \
   filename complex arrayLabels listLabels bytesLabels stringLabels moreLabels \
-  stdLabels spacetime bigarray
+  stdLabels spacetime bigarray atomic
 
 STDLIB_MODULES=\
   $(foreach module, $(STDLIB_MODS), $(call add_stdlib_prefix,$(module)))

stdlib/atomic.ml

@@ -0,0 +1,43 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Gabriel Scherer, projet Partout, INRIA Paris-Saclay        *)
+(*                                                                        *)
+(*   Copyright 2020 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* We are not reusing ('a ref) directly to make it easier to reason
+   about atomicity if we wish to: even in a sequential implementation,
+   signals and other asynchronous callbacks might break atomicity. *)
+type 'a t = {mutable v: 'a}
+
+let make v = {v}
+let get r = r.v
+let set r v = r.v <- v
+
+let exchange r v =
+  let cur = r.v in
+  r.v <- v;
+  cur
+
+let compare_and_set r seen v =
+  let cur = r.v in
+  if cur == seen then
+    (r.v <- v; true)
+  else
+    false
+
+let fetch_and_add r n =
+  let cur = r.v in
+  r.v <- (cur + n);
+  cur
+
+let incr r = ignore (fetch_and_add r 1)
+let decr r = ignore (fetch_and_add r (-1))

stdlib/atomic.mli

@@ -0,0 +1,59 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Stephen Dolan, University of Cambridge                     *)
+(*             Gabriel Scherer, projet Partout, INRIA Paris-Saclay        *)
+(*                                                                        *)
+(*   Copyright 2020 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** This module provides a purely sequential implementation of the
+    concurrent atomic references provided by the Multicore OCaml
+    standard library:
+
+    https://github.com/ocaml-multicore/ocaml-multicore/blob/parallel_minor_gc/stdlib/atomic.mli
+
+    This sequential implementation is provided in the interest of
+    compatibility: when people will start writing code to run on
+    Multicore, it would be nice if their use of Atomic was
+    backward-compatible with older versions of OCaml without having to
+    import additional compatibility layers. *)
+
+(** An atomic (mutable) reference to a value of type ['a]. *)
+type 'a t
+
+(** Create an atomic reference. *)
+val make : 'a -> 'a t
+
+(** Get the current value of the atomic reference. *)
+val get : 'a t -> 'a
+
+(** Set a new value for the atomic reference. *)
+val set : 'a t -> 'a -> unit
+
+(** Set a new value for the atomic reference, and return the current value. *)
+val exchange : 'a t -> 'a -> 'a
+
+(** [compare_and_set r seen v] sets the new value of [r] to [v] only
+    if its current value is physically equal to [seen] -- the
+    comparison and the set occur atomically. Returns [true] if the
+    comparison succeeded (so the set happened) and [false]
+    otherwise. *)
+val compare_and_set : 'a t -> 'a -> 'a -> bool
+
+(** [fetch_and_add r n] atomically increments the value of [r] by [n],
+    and returns the current value (before the increment). *)
+val fetch_and_add : int t -> int -> int
+
+(** [incr r] atomically increments the value of [r] by [1]. *)
+val incr : int t -> unit
+
+(** [decr r] atomically decrements the value of [r] by [1]. *)
+val decr : int t -> unit

stdlib/stdlib.ml

@@ -566,6 +566,7 @@ let _ = register_named_value "Pervasives.do_at_exit" do_at_exit
 module Arg          = Arg
 module Array        = Array
 module ArrayLabels  = ArrayLabels
+module Atomic       = Atomic
 module Bigarray     = Bigarray
 module Bool         = Bool
 module Buffer       = Buffer

stdlib/stdlib.mli

@@ -1335,6 +1335,7 @@ val do_at_exit : unit -> unit
 module Arg          = Arg
 module Array        = Array
 module ArrayLabels  = ArrayLabels
+module Atomic       = Atomic
 module Bigarray     = Bigarray
 module Bool         = Bool
 module Buffer       = Buffer

testsuite/tests/lib-atomic/test_atomic.ml

@@ -0,0 +1,39 @@
+(* TEST *)
+
+let r = Atomic.make 1
+let () = assert (Atomic.get r = 1)
+
+let () = Atomic.set r 2
+let () = assert (Atomic.get r = 2)
+
+let () = assert (Atomic.exchange r 3 = 2)
+
+let () = assert (Atomic.compare_and_set r 3 4 = true)
+let () = assert (Atomic.get r = 4)
+
+let () = assert (Atomic.compare_and_set r 3 (-4) = false)
+let () = assert (Atomic.get r = 4 )
+
+let () = assert (Atomic.compare_and_set r 3 4 = false)
+
+let () = assert (Atomic.fetch_and_add r 2 = 4)
+let () = assert (Atomic.get r = 6)
+
+let () = assert (Atomic.fetch_and_add r (-2) = 6)
+let () = assert (Atomic.get r = 4)
+
+let () = assert ((Atomic.incr r; Atomic.get r) = 5)
+
+let () = assert ((Atomic.decr r; Atomic.get r) = 4)
+
+let () =
+  let r = Atomic.make 0 in
+  let cur = Atomic.get r in
+  ignore (Atomic.set r (cur + 1), Atomic.set r (cur - 1));
+  assert (Atomic.get r <> cur)
+
+let () =
+  let r = Atomic.make 0 in
+  let cur = Atomic.get r in
+  ignore (Atomic.incr r, Atomic.decr r);
+  assert (Atomic.get r = cur)