Implement at_exit with Atomics

Atomic becomes a dependency of Stdlib

stdlib/Compflags

@@ -18,6 +18,10 @@ case $1 in
   stdlib.cm[iox])
       echo ' -nopervasives -no-alias-deps -w -49' \
            ' -pp "$AWK -f ./expand_module_aliases.awk"';;
+  # stdlib dependencies
+  camlinternalFormatBasics*.cm[iox]) echo ' -nopervasives';;
+  stdlib__atomic*.cm[iox]) echo ' -nopervasives';;
+  # end stdlib dependencies
   camlinternalOO.cmx) echo ' -inline 0 -afl-inst-ratio 0';;
   camlinternalLazy.cmx) echo ' -afl-inst-ratio 0';;
     # never instrument camlinternalOO or camlinternalLazy (PR#7725)
@@ -25,7 +29,6 @@ case $1 in
                            # make sure add_char is inlined (PR#5872)
   stdlib__buffer.cm[io]) echo ' -w A';;
   camlinternalFormat.cm[io]) echo ' -w Ae';;
-  camlinternalFormatBasics*.cm[iox]) echo ' -nopervasives';;
   stdlib__printf.cm[io]|stdlib__format.cm[io]|stdlib__scanf.cm[io])
       echo ' -w Ae';;
   stdlib__scanf.cmx) echo ' -inline 9';;

stdlib/Makefile

@@ -34,7 +34,8 @@ OC_CPPFLAGS += -I$(ROOTDIR)/runtime
 include StdlibModules
 
 OBJS=$(addsuffix .cmo,$(STDLIB_MODULES))
-OTHERS=$(filter-out camlinternalFormatBasics.cmo stdlib.cmo,$(OBJS))
+NOSTDLIB= camlinternalFormatBasics.cmo stdlib__atomic.cmo stdlib.cmo
+OTHERS=$(filter-out $(NOSTDLIB),$(OBJS))
 
 PREFIXED_OBJS=$(filter stdlib__%.cmo,$(OBJS))
 UNPREFIXED_OBJS=$(PREFIXED_OBJS:stdlib__%.cmo=%)

stdlib/StdlibModules

@@ -30,11 +30,11 @@ endef
 
 # Modules should be listed in dependency order.
 STDLIB_MODS=\
-  camlinternalFormatBasics stdlib pervasives seq option result bool char uchar \
+  camlinternalFormatBasics atomic \
+  stdlib pervasives seq option result bool char uchar \
   sys list bytes string unit marshal obj array float int int32 int64 nativeint \
   lexing parsing set map stack queue camlinternalLazy lazy stream buffer \
-  camlinternalFormat printf arg atomic \
-  printexc fun gc digest random hashtbl weak \
+  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

stdlib/atomic.ml

@@ -13,6 +13,12 @@
 (*                                                                        *)
 (**************************************************************************)
 
+(* Atomic is a dependency of Stdlib, so it is compiled with
+   -nopervasives. *)
+external ( == ) : 'a -> 'a -> bool = "%eq"
+external ( + ) : int -> int -> int = "%addint"
+external ignore : 'a -> unit = "%ignore"
+
 (* 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. *)

stdlib/dune

@@ -18,7 +18,8 @@
    (exit_module std_exit)
    (internal_modules Camlinternal*)
    (modules_before_stdlib
-     camlinternalFormatBasics))
+     camlinternalFormatBasics
+     stdlib__atomic))
  (flags (:standard -w -9 -nolabels))
  (preprocess
    (per_module

stdlib/stdlib.ml

@@ -543,21 +543,25 @@ let ( ^^ ) (Format (fmt1, str1)) (Format (fmt2, str2)) =
 
 external sys_exit : int -> 'a = "caml_sys_exit"
 
-let exit_function = ref flush_all
+let exit_function = Stdlib__atomic.make flush_all
 
 let rec at_exit f =
-  let old_exit_function = !exit_function in
   (* MPR#7253, MPR#7796: make sure "f" is executed only once *)
   let f_already_ran = ref false in
-  let new_exit_function () =
-    if not !f_already_ran then begin f_already_ran := true; f() end;
-    old_exit_function()
+  let old_exit = Stdlib__atomic.get exit_function in
+  let new_exit () =
+    if not !f_already_ran then begin
+      f_already_ran := true;
+      f ()
+    end ;
+    old_exit ()
   in
-  (* atomic for systhreads *)
-  if old_exit_function == !exit_function then exit_function := new_exit_function
-  else at_exit f
+  let success =
+    Stdlib__atomic.compare_and_set exit_function old_exit new_exit
+  in
+  if not success then at_exit f
 
-let do_at_exit () = (!exit_function) ()
+let do_at_exit () = (Stdlib__atomic.get exit_function) ()
 
 let exit retcode =
   do_at_exit ();