diff --git a/Changes b/Changes index 08ac0552f..9c477168f 100644 --- a/Changes +++ b/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: diff --git a/stdlib/.depend b/stdlib/.depend index 2c1676660..1e8c53687 100644 --- a/stdlib/.depend +++ b/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 \ diff --git a/stdlib/StdlibModules b/stdlib/StdlibModules index cb21a6714..0475e6b73 100644 --- a/stdlib/StdlibModules +++ b/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))) diff --git a/stdlib/atomic.ml b/stdlib/atomic.ml new file mode 100644 index 000000000..8e01069d6 --- /dev/null +++ b/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)) diff --git a/stdlib/atomic.mli b/stdlib/atomic.mli new file mode 100644 index 000000000..08f3f8a21 --- /dev/null +++ b/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 diff --git a/stdlib/stdlib.ml b/stdlib/stdlib.ml index c58613a73..ac123794c 100644 --- a/stdlib/stdlib.ml +++ b/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 diff --git a/stdlib/stdlib.mli b/stdlib/stdlib.mli index 3330a5b24..58a665986 100644 --- a/stdlib/stdlib.mli +++ b/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 diff --git a/testsuite/tests/lib-atomic/test_atomic.ml b/testsuite/tests/lib-atomic/test_atomic.ml new file mode 100644 index 000000000..fba6952cf --- /dev/null +++ b/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)