Allow modalities on primitives (#2778)

Author: riaqn

ocaml/testsuite/tests/typing-modes/modes.ml

@@ -385,18 +385,6 @@ let foo () =
 val foo : unit -> unit = <fun>
 |}]
 
-(* modalities on primitives are parsed but not supported yet. *)
-
-module type S = sig
-  external x : string -> string @ local @@ foo bar = "%hello"
-end
-[%%expect{|
-Line 2, characters 43-46:
-2 |   external x : string -> string @ local @@ foo bar = "%hello"
-                                               ^^^
-Error: Modality on primitive is not supported yet.
-|}]
-
 (* modalities on normal values requires [-extension mode_alpha] *)
 module type S = sig
   val x : string -> string @ local @@ foo bar

ocaml/testsuite/tests/typing-modes/val_modalities.ml

@@ -304,3 +304,60 @@ Line 6, characters 12-15:
                 ^^^
 Error: The value M.x is nonportable, so cannot be used inside a closure that is portable.
 |}]
+
+(* Modalities on primitives are supported. They are simpler than real values,
+   because primitives have the same parsetree in [sig] and [struct]. In
+   particular, both contain [val_modalities] already, so we just do a simple
+   sub-modality check. *)
+module M : sig
+  external length : string -> int @@ portable = "%string_length"
+end = struct
+  external length : string -> int = "%string_length"
+end
+[%%expect{|
+Lines 3-5, characters 6-3:
+3 | ......struct
+4 |   external length : string -> int = "%string_length"
+5 | end
+Error: Signature mismatch:
+       Modules do not match:
+         sig external length : string -> int = "%string_length" end
+       is not included in
+         sig
+           external length : string -> int @@ portable = "%string_length"
+         end
+       Values do not match:
+         external length : string -> int = "%string_length"
+       is not included in
+         external length : string -> int @@ portable = "%string_length"
+       The second is portable and the first is not.
+|}]
+
+module M : sig
+  external length : string -> int @@ portable = "%string_length"
+end = struct
+  external length : string -> int @@ portable = "%string_length"
+end
+
+let _ = portable_use M.length
+[%%expect{|
+module M :
+  sig external length : string -> int @@ portable = "%string_length" end
+- : unit = ()
+|}]
+
+(* weakening to non-portable *)
+module M : sig
+  external length : string -> int = "%string_length"
+end = struct
+  external length : string -> int @@ portable = "%string_length"
+end
+
+let _ = portable_use M.length
+[%%expect{|
+module M : sig external length : string -> int = "%string_length" end
+Line 7, characters 21-29:
+7 | let _ = portable_use M.length
+                         ^^^^^^^^
+Error: This value is nonportable but expected to be portable.
+|}]

ocaml/typing/typedecl.ml

@@ -135,7 +135,6 @@ type error =
   | Local_not_enabled
   | Unexpected_layout_any_in_primitive of string
   | Useless_layout_poly
-  | Modality_on_primitive
   | Zero_alloc_attr_unsupported of Builtin_attributes.zero_alloc_attribute
   | Zero_alloc_attr_non_function
   | Zero_alloc_attr_bad_user_arity
@@ -2900,6 +2899,12 @@ let error_if_containing_unexpected_jkind prim env cty ty =
 (* Translate a value declaration *)
 let transl_value_decl env loc valdecl =
   let cty = Typetexp.transl_type_scheme env valdecl.pval_type in
+  let modalities =
+    valdecl.pval_modalities
+    |> Typemode.transl_modalities ~maturity:Alpha
+        ~has_mutable_implied_modalities:false
+    |> Mode.Modality.Value.of_const
+  in
   (* CR layouts v5: relax this to check for representability. *)
   begin match Ctype.constrain_type_jkind env cty.ctyp_type
                 (Jkind.Primitive.value ~why:Structure_element) with
@@ -2911,12 +2916,6 @@ let transl_value_decl env loc valdecl =
   let v =
   match valdecl.pval_prim with
     [] when Env.is_in_signature env ->
-      let modalities =
-        valdecl.pval_modalities
-        |> Typemode.transl_modalities ~maturity:Alpha
-            ~has_mutable_implied_modalities:false
-        |> Mode.Modality.Value.of_const
-      in
       let default_arity =
         let rec count_arrows n ty =
           match get_desc ty with
@@ -2949,11 +2948,6 @@ let transl_value_decl env loc valdecl =
   | [] ->
       raise (Error(valdecl.pval_loc, Val_in_structure))
   | _ ->
-      let modalities =
-        match valdecl.pval_modalities with
-        | [] -> Mode.Modality.Value.id
-        | m :: _ -> raise (Error(m.loc, Modality_on_primitive))
-      in
       let global_repr =
         match
           get_native_repr_attribute valdecl.pval_attributes ~global_repr:None
@@ -3748,9 +3742,6 @@ let report_error ppf = function
         "@[[@@layout_poly] on this external declaration has no@ \
            effect. Consider removing it or adding a type@ \
            variable for it to operate on.@]"
-  | Modality_on_primitive ->
-      fprintf ppf
-        "@[Modality on primitive is not supported yet.@]"
   | Zero_alloc_attr_unsupported ca ->
       let variety = match ca with
         | Default_zero_alloc  | Check _ -> assert false

ocaml/typing/typedecl.mli

@@ -174,7 +174,6 @@ type error =
   | Local_not_enabled
   | Unexpected_layout_any_in_primitive of string
   | Useless_layout_poly
-  | Modality_on_primitive
   | Zero_alloc_attr_unsupported of Builtin_attributes.zero_alloc_attribute
   | Zero_alloc_attr_non_function
   | Zero_alloc_attr_bad_user_arity