diff --git a/backend/cmm_helpers.ml b/backend/cmm_helpers.ml index b2de73b3477..ca2e25adae2 100644 --- a/backend/cmm_helpers.ml +++ b/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 diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml index e187d954ae7..7bdacfd7439 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.ml +++ b/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 diff --git a/ocaml/asmcomp/cmm_helpers.ml b/ocaml/asmcomp/cmm_helpers.ml index 2410c1a0b80..2b27cb5dcf5 100644 --- a/ocaml/asmcomp/cmm_helpers.ml +++ b/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 diff --git a/ocaml/boot/ocamlc b/ocaml/boot/ocamlc index 32682885682..cdb357901bc 100755 Binary files a/ocaml/boot/ocamlc and b/ocaml/boot/ocamlc differ diff --git a/ocaml/boot/ocamllex b/ocaml/boot/ocamllex index 549ecf025b7..79b09bd6963 100755 Binary files a/ocaml/boot/ocamllex and b/ocaml/boot/ocamllex differ diff --git a/ocaml/typing/primitive.ml b/ocaml/typing/primitive.ml index 14415bec2dd..8334948fc62 100644 --- a/ocaml/typing/primitive.ml +++ b/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 diff --git a/ocaml/typing/primitive.mli b/ocaml/typing/primitive.mli index 1855457e6f5..5146ecef2ed 100644 --- a/ocaml/typing/primitive.mli +++ b/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