[refactor] simplify the definition of atomic functions

In trunk, all atomic functions exposed in the runtime are also exposed
as language primitives in our intermediate representations (lambda,
clambda). But except for `Patomic_load`, which benefits from
dedicated code generation, they are all transformed into C calls
on all backends.

The present PR simplifies the code noticeably by removing the
intermediate primitives, by producing C calls directly in
lambda/translprim.ml.

This reduces the amount of boilerplate to modify to implement
atomic record fields (ocaml/RFCs#39).

Co-authored-by: Clément Allain <clef-men@orange.fr>

Author: gasche

asmcomp/cmmgen.ml

@@ -508,8 +508,7 @@ let rec transl env e =
       | ((Pfield_computed|Psequand
          | Prunstack | Pperform | Presume | Preperform
          | Pdls_get
-         | Patomic_load _ | Patomic_exchange
-         | Patomic_cas | Patomic_fetch_add
+         | Patomic_load _
          | Psequor | Pnot | Pnegint | Paddint | Psubint
          | Pmulint | Pandint | Porint | Pxorint | Plslint
          | Plsrint | Pasrint | Pintoffloat | Pfloatofint
@@ -841,7 +840,6 @@ and transl_prim_1 env p arg dbg =
                 return_unit dbg (Cop(Cpoll, [], dbg))))
   | (Pfield_computed | Psequand | Psequor
     | Prunstack | Presume | Preperform
-    | Patomic_exchange | Patomic_cas | Patomic_fetch_add
     | Paddint | Psubint | Pmulint | Pandint
     | Porint | Pxorint | Plslint | Plsrint | Pasrint
     | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
@@ -1025,14 +1023,8 @@ and transl_prim_2 env p arg1 arg2 dbg =
       tag_int (Cop(Ccmpi cmp,
                      [transl_unbox_int dbg env bi arg1;
                       transl_unbox_int dbg env bi arg2], dbg)) dbg
-  | Patomic_exchange ->
-     Cop (Cextcall ("caml_atomic_exchange", typ_val, [], false),
-          [transl env arg1; transl env arg2], dbg)
-  | Patomic_fetch_add ->
-     Cop (Cextcall ("caml_atomic_fetch_add", typ_int, [], false),
-          [transl env arg1; transl env arg2], dbg)
   | Prunstack | Pperform | Presume | Preperform | Pdls_get
-  | Patomic_cas | Patomic_load _
+  | Patomic_load _
   | Pnot | Pnegint | Pintoffloat | Pfloatofint | Pnegfloat
   | Pabsfloat | Pstringlength | Pbyteslength | Pbytessetu | Pbytessets
   | Pisint | Pbswap16 | Pint_as_pointer | Popaque | Pread_symbol _
@@ -1084,10 +1076,6 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg =
       bigstring_set size unsafe (transl env arg1) (transl env arg2)
         (transl_unbox_sized size dbg env arg3) dbg
 
-  | Patomic_cas ->
-     Cop (Cextcall ("caml_atomic_cas", typ_int, [], false),
-          [transl env arg1; transl env arg2; transl env arg3], dbg)
-
   (* Effects *)
 
   | Prunstack ->
@@ -1103,7 +1091,7 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg =
            dbg)
 
   | Pperform | Pdls_get | Presume
-  | Patomic_exchange | Patomic_fetch_add | Patomic_load _
+  | Patomic_load _
   | Pfield_computed | Psequand | Psequor | Pnot | Pnegint | Paddint
   | Psubint | Pmulint | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint
   | Pintoffloat | Pfloatofint | Pnegfloat | Pabsfloat | Paddfloat | Psubfloat
@@ -1134,9 +1122,9 @@ and transl_prim_4 env p arg1 arg2 arg3 arg4 dbg =
            dbg)
   | Psetfield_computed _
   | Pbytessetu | Pbytessets | Parraysetu _
-  | Parraysets _ | Pbytes_set _ | Pbigstring_set _ | Patomic_cas
+  | Parraysets _ | Pbytes_set _ | Pbigstring_set _
   | Prunstack | Preperform | Pperform | Pdls_get
-  | Patomic_exchange | Patomic_fetch_add | Patomic_load _
+  | Patomic_load _
   | Pfield_computed | Psequand | Psequor | Pnot | Pnegint | Paddint
   | Psubint | Pmulint | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint
   | Pintoffloat | Pfloatofint | Pnegfloat | Pabsfloat | Paddfloat | Psubfloat

bytecomp/bytegen.ml

@@ -164,7 +164,7 @@ let preserve_tailcall_for_prim = function
   | Pbytes_set_64 _ | Pbigstring_load_16 _ | Pbigstring_load_32 _
   | Pbigstring_load_64 _ | Pbigstring_set_16 _ | Pbigstring_set_32 _
   | Pbigstring_set_64 _ | Pctconst _ | Pbswap16 | Pbbswap _ | Pint_as_pointer
-  | Patomic_exchange | Patomic_cas | Patomic_fetch_add | Patomic_load _
+  | Patomic_load _
   | Pdls_get ->
       false
 
@@ -489,9 +489,6 @@ let comp_primitive stack_info p sz args =
   | Pbytes_to_string -> Kccall("caml_string_of_bytes", 1)
   | Pbytes_of_string -> Kccall("caml_bytes_of_string", 1)
   | Patomic_load _ -> Kccall("caml_atomic_load", 1)
-  | Patomic_exchange -> Kccall("caml_atomic_exchange", 2)
-  | Patomic_cas -> Kccall("caml_atomic_cas", 3)
-  | Patomic_fetch_add -> Kccall("caml_atomic_fetch_add", 2)
   | Pdls_get -> Kccall("caml_domain_dls_get", 1)
   | Ppoll -> Kccall("caml_process_pending_actions_with_root", 1)
   (* The cases below are handled in [comp_expr] before the [comp_primitive] call

lambda/lambda.ml

@@ -144,9 +144,6 @@ type primitive =
   | Pint_as_pointer
   (* Atomic operations *)
   | Patomic_load of {immediate_or_pointer : immediate_or_pointer}
-  | Patomic_exchange
-  | Patomic_cas
-  | Patomic_fetch_add
   (* Inhibition of optimisation *)
   | Popaque
   (* Fetching domain-local state *)

lambda/lambda.mli

@@ -154,9 +154,6 @@ type primitive =
   | Pint_as_pointer
   (* Atomic operations *)
   | Patomic_load of {immediate_or_pointer : immediate_or_pointer}
-  | Patomic_exchange
-  | Patomic_cas
-  | Patomic_fetch_add
   (* Inhibition of optimisation *)
   | Popaque
   (* Fetching domain-local state *)

lambda/printlambda.ml

@@ -354,9 +354,6 @@ let primitive ppf = function
       (match immediate_or_pointer with
         | Immediate -> fprintf ppf "atomic_load_imm"
         | Pointer -> fprintf ppf "atomic_load_ptr")
-  | Patomic_exchange -> fprintf ppf "atomic_exchange"
-  | Patomic_cas -> fprintf ppf "atomic_cas"
-  | Patomic_fetch_add -> fprintf ppf "atomic_fetch_add"
   | Popaque -> fprintf ppf "opaque"
   | Pdls_get -> fprintf ppf "dls_get"
   | Ppoll -> fprintf ppf "poll"
@@ -466,9 +463,6 @@ let name_of_primitive = function
       (match immediate_or_pointer with
         | Immediate -> "atomic_load_imm"
         | Pointer -> "atomic_load_ptr")
-  | Patomic_exchange -> "Patomic_exchange"
-  | Patomic_cas -> "Patomic_cas"
-  | Patomic_fetch_add -> "Patomic_fetch_add"
   | Popaque -> "Popaque"
   | Prunstack -> "Prunstack"
   | Presume -> "Presume"

lambda/tmc.ml

@@ -865,7 +865,7 @@ let rec choice ctx t =
     | Prunstack | Pperform | Presume | Preperform | Pdls_get
 
     (* we don't handle atomic primitives *)
-    | Patomic_exchange | Patomic_cas | Patomic_fetch_add | Patomic_load _
+    | Patomic_load _
 
     (* we don't handle array indices as destinations yet *)
     | (Pmakearray _ | Pduparray _)

lambda/translprim.ml

@@ -113,6 +113,14 @@ let gen_array_kind =
 let prim_sys_argv =
   Primitive.simple ~name:"caml_sys_argv" ~arity:1 ~alloc:true
 
+let prim_atomic_exchange =
+  Primitive.simple ~name:"caml_atomic_exchange" ~arity:2 ~alloc:false
+let prim_atomic_cas =
+  Primitive.simple ~name:"caml_atomic_cas" ~arity:3 ~alloc:false
+let prim_atomic_fetch_add =
+  Primitive.simple ~name:"caml_atomic_fetch_add" ~arity:2 ~alloc:false
+
+
 let primitives_table =
   create_hashtable 57 [
     "%identity", Identity;
@@ -366,9 +374,9 @@ let primitives_table =
     "%compare", Comparison(Compare, Compare_generic);
     "%atomic_load",
     Primitive ((Patomic_load {immediate_or_pointer=Pointer}), 1);
-    "%atomic_exchange", Primitive (Patomic_exchange, 2);
-    "%atomic_cas", Primitive (Patomic_cas, 3);
-    "%atomic_fetch_add", Primitive (Patomic_fetch_add, 2);
+    "%atomic_exchange", External prim_atomic_exchange;
+    "%atomic_cas", External prim_atomic_cas;
+    "%atomic_fetch_add", External prim_atomic_fetch_add;
     "%runstack", Primitive (Prunstack, 3);
     "%reperform", Primitive (Preperform, 3);
     "%perform", Primitive (Pperform, 1);
@@ -826,7 +834,7 @@ let lambda_primitive_needs_event_after = function
   | Pfloatcomp _ | Pstringlength | Pstringrefu | Pbyteslength | Pbytesrefu
   | Pbytessetu | Pmakearray ((Pintarray | Paddrarray | Pfloatarray), _)
   | Parraylength _ | Parrayrefu _ | Parraysetu _ | Pisint | Pisout
-  | Patomic_exchange | Patomic_cas | Patomic_fetch_add | Patomic_load _
+  | Patomic_load _
   | Pintofbint _ | Pctconst _ | Pbswap16 | Pint_as_pointer | Popaque | Pdls_get
       -> false
 

lambda/value_rec_compiler.ml

@@ -305,9 +305,6 @@ let compute_static_size lam =
     | Pbbswap _
     | Pint_as_pointer
     | Patomic_load _
-    | Patomic_exchange
-    | Patomic_cas
-    | Patomic_fetch_add
     | Popaque
     | Pdls_get ->
         dynamic_size ()

middle_end/clambda_primitives.ml

@@ -121,9 +121,6 @@ type primitive =
   | Pint_as_pointer
   (* Atomic operations *)
   | Patomic_load of {immediate_or_pointer : immediate_or_pointer}
-  | Patomic_exchange
-  | Patomic_cas
-  | Patomic_fetch_add
   (* Inhibition of optimisation *)
   | Popaque
   (* Fetch domain-local state *)

middle_end/clambda_primitives.mli

@@ -124,9 +124,6 @@ type primitive =
   | Pint_as_pointer
   (* Atomic operations *)
   | Patomic_load of {immediate_or_pointer : immediate_or_pointer}
-  | Patomic_exchange
-  | Patomic_cas
-  | Patomic_fetch_add
   (* Inhibition of optimisation *)
   | Popaque
   (* Fetch domain-local state *)