flambda-backend: Add -as-parameter option (#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 #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

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

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

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

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

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;

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)
 

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

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" *)

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.

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"
+*)

testsuite/tests/templates/basic/bad_param_impl.mli

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

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.

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"
+*)

testsuite/tests/templates/basic/bad_param_packed.reference

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

testsuite/tests/templates/basic/bad_ref_direct.ml

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

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).

testsuite/tests/templates/basic/monoid.mli

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

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"
+*)

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 -> ()

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 =

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. *)