Add attributes effects and coeffects

backend/cmm_helpers.ml

@@ -1417,9 +1417,14 @@ let default_prim name =
 let int64_native_prim name arity ~alloc =
   let u64 = Primitive.Unboxed_integer Primitive.Pint64 in
   let rec make_args = function 0 -> [] | n -> u64 :: make_args (n - 1) in
+  let effects, coeffects =
+    if alloc
+    then Primitive.Arbitrary_effects, Primitive.Has_coeffects
+    else Primitive.No_effects, Primitive.No_coeffects in
   Primitive.make ~name ~native_name:(name ^ "_native")
     ~alloc
     ~c_builtin:false
+    ~effects ~coeffects
     ~native_repr_args:(make_args arity)
     ~native_repr_res:u64
 

middle_end/flambda2/from_lambda/closure_conversion.ml

@@ -173,6 +173,8 @@ let close_c_call acc ~let_bound_var
        prim_arity;
        prim_alloc;
        prim_c_builtin;
+       prim_effects = _;
+       prim_coeffects = _;
        prim_native_name;
        prim_native_repr_args;
        prim_native_repr_res

ocaml/asmcomp/cmm_helpers.ml

@@ -1356,9 +1356,12 @@ let default_prim name =
 let int64_native_prim name arity ~alloc =
   let u64 = Primitive.Unboxed_integer Primitive.Pint64 in
   let rec make_args = function 0 -> [] | n -> u64 :: make_args (n - 1) in
+  let effects = Primitive.Arbitrary_effects in
+  let coeffects = Primitive.Has_coeffects in
   Primitive.make ~name ~native_name:(name ^ "_native")
     ~alloc
     ~c_builtin:false
+    ~effects ~coeffects
     ~native_repr_args:(make_args arity)
     ~native_repr_res:u64
 

ocaml/typing/primitive.ml

@@ -26,11 +26,16 @@ type native_repr =
   | Unboxed_integer of boxed_integer
   | Untagged_int
 
+type effects = No_effects | Only_generative_effects | Arbitrary_effects
+type coeffects = No_coeffects | Has_coeffects
+
 type description =
   { prim_name: string;         (* Name of primitive  or C function *)
     prim_arity: int;           (* Number of arguments *)
     prim_alloc: bool;          (* Does it allocates or raise? *)
     prim_c_builtin: bool;        (* Is the compiler allowed to replace it? *)
+    prim_effects: effects;
+    prim_coeffects: coeffects;
     prim_native_name: string;  (* Name of C function for the nat. code gen. *)
     prim_native_repr_args: native_repr list;
     prim_native_repr_res: native_repr }
@@ -39,6 +44,8 @@ type error =
   | Old_style_float_with_native_repr_attribute
   | Old_style_noalloc_with_noalloc_attribute
   | No_native_primitive_with_repr_attribute
+  | Inconsistent_attributes_for_effects
+  | Inconsistent_noalloc_attributes_for_effects
 
 exception Error of Location.t * error
 
@@ -71,16 +78,20 @@ let simple ~name ~arity ~alloc =
    prim_arity = arity;
    prim_alloc = alloc;
    prim_c_builtin = false;
+   prim_effects = Arbitrary_effects;
+   prim_coeffects = Has_coeffects;
    prim_native_name = "";
    prim_native_repr_args = make_native_repr_args arity Same_as_ocaml_repr;
    prim_native_repr_res = Same_as_ocaml_repr}
 
-let make ~name ~alloc ~c_builtin
+let make ~name ~alloc ~c_builtin ~effects ~coeffects
       ~native_name ~native_repr_args ~native_repr_res =
   {prim_name = name;
    prim_arity = List.length native_repr_args;
    prim_alloc = alloc;
    prim_c_builtin = c_builtin;
+   prim_effects = effects;
+   prim_coeffects = coeffects;
    prim_native_name = native_name;
    prim_native_repr_args = native_repr_args;
    prim_native_repr_res = native_repr_res}
@@ -106,6 +117,31 @@ let parse_declaration valdecl ~native_repr_args ~native_repr_res =
     Attr_helper.has_no_payload_attribute ["builtin"; "ocaml.builtin"]
       valdecl.pval_attributes
   in
+  let no_effects_attribute =
+    Attr_helper.has_no_payload_attribute ["no_effects"; "ocaml.no_effects"]
+      valdecl.pval_attributes
+  in
+  let only_generative_effects_attribute =
+    Attr_helper.has_no_payload_attribute ["only_generative_effects";
+                                          "ocaml.only_generative_effects"]
+      valdecl.pval_attributes
+  in
+  if no_effects_attribute && only_generative_effects_attribute then
+    raise (Error (valdecl.pval_loc,
+                  Inconsistent_attributes_for_effects));
+  let effects =
+    if no_effects_attribute then No_effects
+    else if only_generative_effects_attribute then Only_generative_effects
+    else Arbitrary_effects
+  in
+  let no_coeffects_attribute =
+    Attr_helper.has_no_payload_attribute ["no_coeffects"; "ocaml.no_coeffects"]
+      valdecl.pval_attributes
+  in
+  let coeffects =
+    if no_coeffects_attribute then No_coeffects
+    else Has_coeffects
+  in
   if old_style_float &&
      not (List.for_all is_ocaml_repr native_repr_args &&
           is_ocaml_repr native_repr_res) then
@@ -130,6 +166,9 @@ let parse_declaration valdecl ~native_repr_args ~native_repr_res =
     raise (Error (valdecl.pval_loc,
                   No_native_primitive_with_repr_attribute));
   let noalloc = old_style_noalloc || noalloc_attribute in
+  if noalloc && only_generative_effects_attribute then
+    raise (Error (valdecl.pval_loc,
+                  Inconsistent_noalloc_attributes_for_effects));
   let native_repr_args, native_repr_res =
     if old_style_float then
       (make_native_repr_args arity Unboxed_float, Unboxed_float)
@@ -140,6 +179,8 @@ let parse_declaration valdecl ~native_repr_args ~native_repr_res =
    prim_arity = arity;
    prim_alloc = not noalloc;
    prim_c_builtin = builtin_attribute;
+   prim_effects = effects;
+   prim_coeffects = coeffects;
    prim_native_name = native_name;
    prim_native_repr_args = native_repr_args;
    prim_native_repr_res = native_repr_res}
@@ -165,6 +206,9 @@ let oattr_unboxed = { oattr_name = "unboxed" }
 let oattr_untagged = { oattr_name = "untagged" }
 let oattr_noalloc = { oattr_name = "noalloc" }
 let oattr_builtin = { oattr_name = "builtin" }
+let oattr_no_effects = { oattr_name = "no_effects" }
+let oattr_only_generative_effects = { oattr_name = "only_generative_effects" }
+let oattr_no_coeffects = { oattr_name = "no_coeffects" }
 
 let print p osig_val_decl =
   let prims =
@@ -180,6 +224,15 @@ let print p osig_val_decl =
   let all_untagged = for_all is_untagged in
   let attrs = if p.prim_alloc then [] else [oattr_noalloc] in
   let attrs = if p.prim_c_builtin then oattr_builtin::attrs else attrs in
+  let attrs = match p.prim_effects with
+    | No_effects -> oattr_no_effects::attrs
+    | Only_generative_effects -> oattr_only_generative_effects::attrs
+    | Arbitrary_effects -> attrs
+  in
+  let attrs = match p.prim_coeffects with
+    | No_coeffects -> oattr_no_coeffects::attrs
+    | Has_coeffects -> attrs
+  in
   let attrs =
     if all_unboxed then
       oattr_unboxed :: attrs
@@ -227,6 +280,12 @@ let report_error ppf err =
     Format.fprintf ppf
       "[@The native code version of the primitive is mandatory@ \
        when attributes [%@untagged] or [%@unboxed] are present.@]"
+  | Inconsistent_attributes_for_effects ->
+    Format.fprintf ppf "At most one of [%@no_effects] and \
+                        [%@only_generative_effects] can be specified."
+  | Inconsistent_noalloc_attributes_for_effects ->
+    Format.fprintf ppf "Cannot use [%@%@no_generative_effects] \
+                        in conjunction with [%@%@noalloc]."
 
 let () =
   Location.register_error_of_exn

ocaml/typing/primitive.mli

@@ -25,6 +25,10 @@ type native_repr =
   | Unboxed_integer of boxed_integer
   | Untagged_int
 
+(* See [middle_end/semantics_of_primitives.mli] *)
+type effects = No_effects | Only_generative_effects | Arbitrary_effects
+type coeffects = No_coeffects | Has_coeffects
+
 type description = private
   { prim_name: string;         (* Name of primitive  or C function *)
     prim_arity: int;           (* Number of arguments *)
@@ -35,6 +39,8 @@ type description = private
        based on its name [prim_name], into a predetermined instruction sequence.
        [prim_c_builtin] is ignored on compiler primitives
        whose name [prim_name] starts with %. *)
+    prim_effects: effects;
+    prim_coeffects: coeffects;
     prim_native_name: string;  (* Name of C function for the nat. code gen. *)
     prim_native_repr_args: native_repr list;
     prim_native_repr_res: native_repr }
@@ -51,6 +57,8 @@ val make
   :  name:string
   -> alloc:bool
   -> c_builtin:bool
+  -> effects:effects
+  -> coeffects:coeffects
   -> native_name:string
   -> native_repr_args: native_repr list
   -> native_repr_res: native_repr
@@ -79,5 +87,7 @@ type error =
   | Old_style_float_with_native_repr_attribute
   | Old_style_noalloc_with_noalloc_attribute
   | No_native_primitive_with_repr_attribute
+  | Inconsistent_attributes_for_effects
+  | Inconsistent_noalloc_attributes_for_effects
 
 exception Error of Location.t * error