Add -as-parameter option (ocaml-flambda#1751)

* Add `-as-parameter` option

This allows compiling an .mli as a _parameter module_ rather than a normal
compilation unit. A parameter module defines a module _type_ rather than a
module, so it cannot be referred to directly from another module. A forthcoming
PR will add the `-parameter P` option which adds the parameter module `P` as a
parameter to the current module, which then allows references to `P` in the
module. Further PRs will deal with how to actually use a module that takes
parameters.

For the moment, `-parameter` is unimplemented, so any reference to a parameter
module is an error.

* Add checks for misuse of `-as-parameter`

* Raise error on combination of `-as-parameter` and `-for-pack`

* Add test for check for compiling `.ml` of parameter `.mli`

I've disabled the check on the output, since currently we get the wrong error
message (and the one we get is confusing). This will be much easier to fix when
PR ocaml-flambda#1764 is fixed to avoid unhelpful checks on `.mli` files that are loaded
directly rather than as part of name resolution.

* Add test of check for `-as-parameter` on implementation

* Implement `register_parameter_import` and `is_registered_parameter_import`

* Code review

* Code review

* Fix error message and re-enable test

ocaml/driver/compile_common.ml

@@ -63,7 +63,7 @@ let typecheck_intf info ast =
   Profile.(record_call typing) @@ fun () ->
   let tsg =
     ast
-    |> Typemod.type_interface info.env
+    |> Typemod.type_interface info.module_name info.env
     |> print_if info.ppf_dump Clflags.dump_typedtree Printtyped.interface
   in
   let sg = tsg.Typedtree.sig_type in
@@ -80,9 +80,15 @@ let typecheck_intf info ast =
 
 let emit_signature info ast tsg =
   let sg =
+    let kind : Cmi_format.kind =
+      if !Clflags.as_parameter then
+        Parameter
+      else
+        Normal
+    in
     let alerts = Builtin_attributes.alerts_of_sig ast in
     Env.save_signature ~alerts tsg.Typedtree.sig_type
-      info.module_name (info.output_prefix ^ ".cmi")
+      info.module_name kind (info.output_prefix ^ ".cmi")
   in
   Typemod.save_signature info.module_name tsg
     info.output_prefix info.source_file info.env sg

ocaml/driver/main_args.ml

@@ -631,6 +631,11 @@ let mk_match_context_rows f =
   Printf.sprintf
   "<n>  (advanced, see manual section %d.%d.)" chapter section
 
+let mk_as_parameter f =
+  "-as-parameter", Arg.Unit f,
+  "<module name> Compiles the interface as a parameter for an open module."
+;;
+
 let mk_use_prims f =
   "-use-prims", Arg.String f, "<file>  (undocumented)"
 
@@ -918,6 +923,7 @@ end
 module type Compiler_options = sig
   val _a : unit -> unit
   val _annot : unit -> unit
+  val _as_parameter : unit -> unit
   val _binannot : unit -> unit
   val _binannot_cms : unit -> unit
   val _c : unit -> unit
@@ -1116,6 +1122,7 @@ struct
     mk_absname F._absname;
     mk_no_absname F._no_absname;
     mk_annot F._annot;
+    mk_as_parameter F._as_parameter;
     mk_binannot F._binannot;
     mk_binannot_cms F._binannot_cms;
     mk_c F._c;
@@ -1324,6 +1331,7 @@ struct
     mk_afl_instrument F._afl_instrument;
     mk_afl_inst_ratio F._afl_inst_ratio;
     mk_annot F._annot;
+    mk_as_parameter F._as_parameter;
     mk_binannot F._binannot;
     mk_binannot_cms F._binannot_cms;
     mk_inline_branch_factor F._inline_branch_factor;
@@ -1880,6 +1888,7 @@ module Default = struct
     let _annot = set annotations
     let _args = Arg.read_arg
     let _args0 = Arg.read_arg0
+    let _as_parameter = set as_parameter
     let _binannot = set binary_annotations
     let _binannot_cms = set binary_annotations_cms
     let _c = set compile_only

ocaml/driver/main_args.mli

@@ -84,6 +84,7 @@ end
 module type Compiler_options = sig
   val _a : unit -> unit
   val _annot : unit -> unit
+  val _as_parameter : unit -> unit
   val _binannot : unit -> unit
   val _binannot_cms : unit -> unit
   val _c : unit -> unit

ocaml/file_formats/cmi_format.ml

@@ -20,6 +20,10 @@ type pers_flags =
   | Alerts of alerts
   | Opaque
 
+type kind =
+  | Normal
+  | Parameter
+
 type error =
   | Not_an_interface of filepath
   | Wrong_version_interface of filepath * string
@@ -53,10 +57,15 @@ module Serialized = Types.Make_wrapped(struct type 'a t = int end)
    input_value and output_value usage. *)
 type crcs = Import_info.t array  (* smaller on disk than using a list *)
 type flags = pers_flags list
-type header = Compilation_unit.t * Serialized.signature
+type header = {
+    header_name : Compilation_unit.t;
+    header_kind : kind;
+    header_sign : Serialized.signature;
+}
 
 type 'sg cmi_infos_generic = {
     cmi_name : Compilation_unit.t;
+    cmi_kind : kind;
     cmi_sign : 'sg;
     cmi_crcs : crcs;
     cmi_flags : flags;
@@ -108,11 +117,16 @@ let input_cmi_lazy ic =
   in
   let data_len = Bytes.get_int64_ne (read_bytes 8) 0 |> Int64.to_int in
   let data = read_bytes data_len in
-  let (name, sign) = (input_value ic : header) in
+  let {
+      header_name = name;
+      header_kind = kind;
+      header_sign = sign;
+    } = (input_value ic : header) in
   let crcs = (input_value ic : crcs) in
   let flags = (input_value ic : flags) in
   {
       cmi_name = name;
+      cmi_kind = kind;
       cmi_sign = deserialize data sign;
       cmi_crcs = crcs;
       cmi_flags = flags;
@@ -169,7 +183,12 @@ let output_cmi filename oc cmi =
   (* BACKPORT BEGIN *)
   (* CR ocaml 5 compressed-marshal mshinwell:
      upstream uses [Compression] here *)
-  output_value oc ((cmi.cmi_name, sign) : header);
+  output_value oc
+    {
+      header_name = cmi.cmi_name;
+      header_kind = cmi.cmi_kind;
+      header_sign = sign;
+    };
   (* BACKPORT END *)
   flush oc;
   let crc = Digest.file filename in

ocaml/file_formats/cmi_format.mli

@@ -20,8 +20,13 @@ type pers_flags =
   | Alerts of alerts
   | Opaque
 
+type kind =
+  | Normal
+  | Parameter
+
 type 'sg cmi_infos_generic = {
     cmi_name : Compilation_unit.t;
+    cmi_kind : kind;
     cmi_sign : 'sg;
     cmi_crcs : Import_info.t array;
     cmi_flags : pers_flags list;

ocaml/ocamldoc/odoc_analyse.ml

@@ -122,7 +122,7 @@ let process_interface_file sourcefile =
     Pparse.file ~tool_name inputfile
       (no_docstring Parse.interface) Pparse.Signature
   in
-  let sg = Typemod.type_interface (initial_env()) ast in
+  let sg = Typemod.type_interface compilation_unit (initial_env()) ast in
   Warnings.check_fatal ();
   (ast, sg, inputfile)
 

ocaml/testsuite/tests/self-contained-toplevel/main.ml

@@ -26,11 +26,12 @@ let () =
   Persistent_signature.load := (fun ~allow_hidden ~unit_name ->
     match unit_name |> Compilation_unit.Name.to_string with
     | "Foo" ->
-      let {Cmi_format.cmi_name; cmi_sign; cmi_crcs; cmi_flags} =
+      let {Cmi_format.cmi_name; cmi_kind; cmi_sign; cmi_crcs; cmi_flags} =
         Marshal.from_string Cached_cmi.foo 0
       in
       let cmi =
         { Cmi_format.cmi_name;
+          cmi_kind;
           cmi_sign = Subst.Lazy.of_signature cmi_sign;
           cmi_crcs;
           cmi_flags

ocaml/testsuite/tests/templates/basic/bad_impl_as_param.ml

@@ -0,0 +1,12 @@
+(* TEST
+
+readonly_files = "bad_impl_as_param.reference"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+flags = "-as-parameter"
+modules = "bad_impl_as_param.ml"
+ocamlc_byte_exit_status = "2"
+compiler_output = "bad_impl_as_param.output"
+*** check-ocamlc.byte-output
+compiler_reference = "bad_impl_as_param.reference" *)

ocaml/testsuite/tests/templates/basic/bad_impl_as_param.reference

@@ -0,0 +1,2 @@
+File "bad_impl_as_param.ml", line 1:
+Error: Cannot compile an implementation with -as-parameter.

ocaml/testsuite/tests/templates/basic/bad_param_impl.ml

@@ -0,0 +1,16 @@
+(* TEST
+
+readonly_files = "bad_param_impl.mli bad_param_impl.reference"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+flags = "-as-parameter"
+module = "bad_param_impl.mli"
+*** ocamlc.byte
+flags = ""
+module = "bad_param_impl.ml"
+ocamlc_byte_exit_status = "2"
+compiler_output = "bad_param_impl.output"
+**** check-ocamlc.byte-output
+compiler_reference = "bad_param_impl.reference"
+*)

ocaml/testsuite/tests/templates/basic/bad_param_impl.mli

@@ -0,0 +1 @@
+(* To be compiled with [-as-parameter] *)

ocaml/testsuite/tests/templates/basic/bad_param_impl.reference

@@ -0,0 +1,3 @@
+File "bad_param_impl.ml", line 1:
+Error: The interface for Bad_param_impl was compiled with -as-parameter.
+       It cannot be implemented directly.

ocaml/testsuite/tests/templates/basic/bad_param_packed.mli

@@ -0,0 +1,13 @@
+(* TEST
+
+readonly_files = "bad_param_packed.reference"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+flags = "-as-parameter -for-pack Pack"
+module = "bad_param_packed.mli"
+compiler_output = "bad_param_packed.output"
+ocamlc_byte_exit_status = "2"
+*** check-ocamlc.byte-output
+compiler_reference = "bad_param_packed.reference"
+*)

ocaml/testsuite/tests/templates/basic/bad_param_packed.reference

@@ -0,0 +1,2 @@
+File "_none_", line 1:
+Error: Cannot compile a parameter with -for-pack.

ocaml/testsuite/tests/templates/basic/bad_ref_direct.ml

@@ -0,0 +1,3 @@
+(* [Monoid] is not a parameter *)
+
+let empty = Monoid.id

ocaml/testsuite/tests/templates/basic/bad_ref_direct.reference

@@ -0,0 +1,3 @@
+File "bad_ref_direct.ml", line 1:
+Error: The file monoid.cmi contains the interface of a parameter.
+       Monoid is not declared as a parameter for the current unit (-parameter Monoid).

ocaml/testsuite/tests/templates/basic/monoid.mli

@@ -0,0 +1,4 @@
+type t
+
+val empty : t
+val append : t -> t -> t

ocaml/testsuite/tests/templates/basic/test.ml

@@ -0,0 +1,18 @@
+(* TEST
+
+readonly_files = "\
+  bad_ref_direct.ml bad_ref_direct.reference \
+  monoid.mli \
+"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+flags = "-as-parameter"
+module = "monoid.mli"
+*** ocamlc.byte
+module = "bad_ref_direct.ml"
+compiler_output = "bad_ref_direct.output"
+ocamlc_byte_exit_status = "2"
+**** check-ocamlc.byte-output
+compiler_reference = "bad_ref_direct.reference"
+*)

ocaml/tools/objinfo.ml

@@ -93,8 +93,15 @@ let print_cma_infos (lib : Cmo_format.library) =
   printf "\n";
   List.iter print_cmo_infos lib.lib_units
 
-let print_cmi_infos name crcs =
+let print_cmi_infos name crcs kind =
+  let open Cmi_format in
   printf "Unit name: %a\n" Compilation_unit.output name;
+  let is_param =
+    match kind with
+    | Normal -> false
+    | Parameter -> true
+  in
+  printf "Is parameter: %s\n" (if is_param then "YES" else "no");
   printf "Interfaces imported:\n";
   Array.iter print_intf_import crcs
 
@@ -340,6 +347,7 @@ let dump_obj_by_kind filename ic obj_kind =
          | None -> ()
          | Some cmi ->
             print_cmi_infos cmi.Cmi_format.cmi_name cmi.Cmi_format.cmi_crcs
+              cmi.Cmi_format.cmi_kind
        end;
        begin match cmt with
          | None -> ()

ocaml/typing/env.ml

@@ -1037,6 +1037,9 @@ let is_imported_opaque modname =
 let register_import_as_opaque modname =
   Persistent_env.register_import_as_opaque !persistent_env modname
 
+let is_parameter_unit modname =
+  Persistent_env.is_registered_parameter_import !persistent_env modname
+
 let reset_declaration_caches () =
   Types.Uid.Tbl.clear !value_declarations;
   Types.Uid.Tbl.clear !type_declarations;
@@ -2685,30 +2688,29 @@ let persistent_structures_of_dir dir =
   |> String.Set.of_seq
 
 (* Save a signature to a file *)
-let save_signature_with_transform cmi_transform ~alerts sg modname filename =
+let save_signature_with_transform cmi_transform ~alerts sg modname kind
+      filename =
   Btype.cleanup_abbrev ();
   Subst.reset_additional_action_type_id ();
   let sg = Subst.Lazy.of_signature sg
     |> Subst.Lazy.signature Make_local
         (Subst.with_additional_action Prepare_for_saving Subst.identity)
   in
   let cmi =
-    Persistent_env.make_cmi !persistent_env modname sg alerts
+    Persistent_env.make_cmi !persistent_env modname kind sg alerts
     |> cmi_transform in
   let pers_sig =
     Persistent_env.Persistent_signature.{ filename; cmi; visibility = Visible }
   in
   Persistent_env.save_cmi !persistent_env pers_sig;
   cmi
 
-let save_signature ~alerts sg modname filename =
-  save_signature_with_transform (fun cmi -> cmi)
-    ~alerts sg modname filename
+let save_signature ~alerts sg modname cu filename =
+  save_signature_with_transform (fun cmi -> cmi) ~alerts sg modname cu filename
 
-let save_signature_with_imports ~alerts sg modname filename imports =
+let save_signature_with_imports ~alerts sg modname cu filename imports =
   let with_imports cmi = { cmi with cmi_crcs = imports } in
-  save_signature_with_transform with_imports
-    ~alerts sg modname filename
+  save_signature_with_transform with_imports ~alerts sg modname cu filename
 
 (* Make the initial environment, without language extensions *)
 let initial =

ocaml/typing/env.mli

@@ -474,15 +474,14 @@ val read_signature:
            Results: signature. If [add_binding] is true, creates an entry for
            the module in the environment. *)
 val save_signature:
-  alerts:alerts -> signature -> Compilation_unit.t -> filepath
-  -> Cmi_format.cmi_infos_lazy
-        (* Arguments: signature, module name, file name. *)
+  alerts:alerts -> signature -> Compilation_unit.t -> Cmi_format.kind
+  -> filepath -> Cmi_format.cmi_infos_lazy
+        (* Arguments: signature, module name, module kind, file name. *)
 val save_signature_with_imports:
-  alerts:alerts -> signature -> Compilation_unit.t -> filepath
-  -> Import_info.t array
-  -> Cmi_format.cmi_infos_lazy
-        (* Arguments: signature, module name, file name,
-           imported units with their CRCs. *)
+  alerts:alerts -> signature -> Compilation_unit.t -> Cmi_format.kind
+  -> filepath -> Import_info.t array -> Cmi_format.cmi_infos_lazy
+        (* Arguments: signature, module name, module kind,
+           file name, imported units with their CRCs. *)
 
 (* Return the CRC of the interface of the given compilation unit *)
 val crc_of_unit: Compilation_unit.Name.t -> Digest.t
@@ -499,6 +498,10 @@ val is_imported_opaque: Compilation_unit.Name.t -> bool
 (* [register_import_as_opaque md] registers [md] as an opaque imported module *)
 val register_import_as_opaque: Compilation_unit.Name.t -> unit
 
+(* [is_parameter_unit md] returns true if [md] was compiled with
+   -as-parameter *)
+val is_parameter_unit: Compilation_unit.Name.t -> bool
+
 (* Summaries -- compact representation of an environment, to be
    exported in debugging information. *)