Add -parameter parameter (#1846)

Squashed from `parameter-parameter` branch on lukemaurer/flambda-backend (commit 81c50a7).

Declares that the module being compiled has a parameter, whose type is given by an .mli. Given `-parameter Param`, we require that:

* An interface `param.mli` is in the path and was compiled with `-as-parameter`
* All subsequent modules that refer to this module will also be compiled with `-parameter Param`

Once support for parameterised libraries is complete, it will also be possible for a reference to pass an argument rather than forwarding `Param` along.

Author: lukemaurer

ocaml/driver/main_args.ml

@@ -654,14 +654,19 @@ let mk_match_context_rows f =
   Printf.sprintf
   "<n>  (advanced, see manual section %d.%d.)" chapter section
 
+let mk_parameter f =
+  "-parameter", Arg.String f,
+  "<module name> Compile the module with <module name> as a parameter."
+;;
+
 let mk_as_parameter f =
   "-as-parameter", Arg.Unit f,
-  " Compiles the interface as a parameter for an open module."
+  " Compile the interface as a parameter module."
 ;;
 
 let mk_as_argument_for f =
   "-as-argument-for", Arg.String f,
-  "<module name> Compiles the module as an argument for the named parameter."
+  "<module name> Compile the module as an argument for the named parameter."
 ;;
 
 let mk_use_prims f =
@@ -1001,6 +1006,7 @@ module type Compiler_options = sig
   val _output_obj : unit -> unit
   val _output_complete_obj : unit -> unit
   val _pack : unit -> unit
+  val _parameter : string -> unit
   val _plugin : string -> unit
   val _pp : string -> unit
   val _principal : unit -> unit
@@ -1236,6 +1242,7 @@ struct
     mk_output_complete_obj F._output_complete_obj;
     mk_output_complete_exe F._output_complete_exe;
     mk_pack_byt F._pack;
+    mk_parameter F._parameter;
     mk_pp F._pp;
     mk_ppx F._ppx;
     mk_plugin F._plugin;
@@ -1473,6 +1480,7 @@ struct
     mk_output_complete_obj F._output_complete_obj;
     mk_p F._p;
     mk_pack_opt F._pack;
+    mk_parameter F._parameter;
     mk_plugin F._plugin;
     mk_pp F._pp;
     mk_ppx F._ppx;
@@ -2012,6 +2020,7 @@ module Default = struct
     let _o s = output_name := (Some s)
     let _opaque = set opaque
     let _pack = set make_package
+    let _parameter s = parameters := !parameters @ [ s ]
     let _plugin _p = plugin := true
     let _pp s = preprocessor := (Some s)
     let _runtime_variant s = runtime_variant := s

ocaml/driver/main_args.mli

@@ -119,6 +119,7 @@ module type Compiler_options = sig
   val _output_obj : unit -> unit
   val _output_complete_obj : unit -> unit
   val _pack : unit -> unit
+  val _parameter : string -> unit
   val _plugin : string -> unit
   val _pp : string -> unit
   val _principal : unit -> unit

ocaml/file_formats/cmi_format.ml

@@ -64,12 +64,14 @@ type header = {
     header_name : Compilation_unit.Name.t;
     header_kind : kind;
     header_sign : Serialized.signature;
+    header_params : Compilation_unit.Name.t list;
 }
 
 type 'sg cmi_infos_generic = {
     cmi_name : Compilation_unit.Name.t;
     cmi_kind : kind;
     cmi_sign : 'sg;
+    cmi_params : Compilation_unit.Name.t list;
     cmi_crcs : crcs;
     cmi_flags : flags;
 }
@@ -124,13 +126,15 @@ let input_cmi_lazy ic =
       header_name = name;
       header_kind = kind;
       header_sign = sign;
+      header_params = params;
     } = (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_params = params;
       cmi_crcs = crcs;
       cmi_flags = flags;
     }
@@ -191,6 +195,7 @@ let output_cmi filename oc cmi =
       header_name = cmi.cmi_name;
       header_kind = cmi.cmi_kind;
       header_sign = sign;
+      header_params = cmi.cmi_params;
     };
   (* BACKPORT END *)
   flush oc;

ocaml/file_formats/cmi_format.mli

@@ -23,6 +23,8 @@ type pers_flags =
 type kind =
   | Normal of {
       cmi_impl : Compilation_unit.t;
+        (* If this module takes parameters, [cmi_impl] will be the functor that
+           generates instances *)
       cmi_arg_for : Compilation_unit.Name.t option;
     }
   | Parameter
@@ -31,6 +33,7 @@ type 'sg cmi_infos_generic = {
     cmi_name : Compilation_unit.Name.t;
     cmi_kind : kind;
     cmi_sign : 'sg;
+    cmi_params : Compilation_unit.Name.t list;
     cmi_crcs : Import_info.t array;
     cmi_flags : pers_flags list;
 }

ocaml/lambda/translmod.ml

@@ -1547,12 +1547,41 @@ let transl_implementation_set_fields compilation_unit (str, restr) =
     compilation_unit;
     required_globals = required_globals ~flambda:true code }
 
-let transl_implementation compilation_unit impl ~style =
+let transl_implementation0 compilation_unit impl ~style =
   match style with
   | Plain_block -> transl_implementation_plain_block compilation_unit impl
   | Set_global_to_block -> transl_implementation_set_global compilation_unit impl
   | Set_individual_fields -> transl_implementation_set_fields compilation_unit impl
 
+let stub_out_runtime_parameters compilation_unit code =
+  let runtime_parameters = Env.runtime_parameters () in
+  match runtime_parameters with
+  | [] -> code
+  | _ ->
+      (* Raise [Invalid_argument "-parameter not yet implemented"] at top level. This
+         makes the module unusable (which is to say, safe) but well-formed so that
+         compilation goes through. *)
+    let scopes = enter_compilation_unit ~scopes:empty_scopes compilation_unit in
+    let loc = of_location ~scopes Location.none in
+    let slot =
+      transl_extension_path
+        loc
+        (Lazy.force Env.initial)
+        Predef.path_invalid_argument
+    in
+    let message =
+      Lconst (Const_base (Const_string("-parameter not yet implemented",
+                                       Location.none, None)))
+    in
+    Lprim (Praise Raise_regular,
+           [Lprim(Pmakeblock(0, Immutable, None, alloc_heap), [ slot; message ], loc)],
+           loc)
+
+let transl_implementation compilation_unit impl ~style =
+  let program = transl_implementation0 compilation_unit impl ~style in
+  let code = stub_out_runtime_parameters compilation_unit program.code in
+  { program with code }
+
 (* Compile a toplevel phrase *)
 
 let toploop_unit = Compilation_unit.of_string "Toploop"

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

@@ -26,12 +26,20 @@ 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_kind; cmi_sign; cmi_crcs; cmi_flags} =
+      let
+        { Cmi_format.cmi_name;
+          cmi_kind;
+          cmi_params;
+          cmi_sign;
+          cmi_crcs;
+          cmi_flags
+        } =
         Marshal.from_string Cached_cmi.foo 0
       in
       let cmi =
         { Cmi_format.cmi_name;
           cmi_kind;
+          cmi_params;
           cmi_sign = Subst.Lazy.of_signature cmi_sign;
           cmi_crcs;
           cmi_flags

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

@@ -0,0 +1,19 @@
+(* TEST
+ readonly_files = "bad_param_not_param.reference widget.mli";
+ setup-ocamlc.byte-build-env;
+ flags = "";
+ module = "widget.mli";
+ compiler_output = "bad_param_not_param.output";
+ ocamlc_byte_exit_status = "0";
+ ocamlc.byte;
+ flags = "-parameter Widget";
+ module = "bad_param_not_param.mli";
+ ocamlc_byte_exit_status = "2";
+ ocamlc.byte;
+ compiler_reference = "bad_param_not_param.reference";
+ check-ocamlc.byte-output;
+*)
+
+(* Compiled with [-parameter Widget] but [Widget] is not a parameter *)
+
+val frobnicate : Widget.t -> Widget.t

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

@@ -0,0 +1,3 @@
+File "bad_param_not_param.mli", line 1:
+Error: The module Widget is specified as a parameter, but widget.cmi
+       was not compiled with -as-parameter.

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

@@ -0,0 +1,3 @@
+(* Compiled with both [-parameter Monoid] and [-as-parameter] *)
+
+val f : Monoid.t -> Monoid.t

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

@@ -0,0 +1,3 @@
+File "_none_", line 1:
+Error: Cannot combine -as-parameter with -parameter: parameters cannot
+       be parameterised.

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

@@ -0,0 +1,5 @@
+File "bad_ref_indirect.ml", line 1:
+Error: The module Monoid_utils is not accessible because it takes Monoid
+       as a parameter and the current unit does not.
+Hint: Pass `-parameter Monoid` to add Monoid as a parameter
+      of the current unit.

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

@@ -0,0 +1,3 @@
+type ts = Monoid.t list
+
+let concat = List.fold_left Monoid.append Monoid.empty

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

@@ -0,0 +1,3 @@
+type ts = Monoid.t list
+
+val concat : ts -> Monoid.t

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

@@ -0,0 +1 @@
+Fatal error: exception Invalid_argument("-parameter not yet implemented")

ocaml/testsuite/tests/templates/basic/ref_indirect.cmo.ocamlobjinfo.reference

@@ -0,0 +1,22 @@
+File ref_indirect.cmo
+Unit name: Ref_indirect
+Interfaces imported:
+	00000000000000000000000000000000	Stdlib
+	00000000000000000000000000000000	Ref_indirect
+	00000000000000000000000000000000	Monoid_utils
+	00000000000000000000000000000000	Monoid
+	00000000000000000000000000000000	CamlinternalFormatBasics
+Required globals:
+Uses unsafe features: no
+Force link: no
+File ref_indirect.cmi
+Unit name: Ref_indirect
+Is parameter: no
+Parameters:
+	Monoid
+Interfaces imported:
+	00000000000000000000000000000000	Ref_indirect
+	00000000000000000000000000000000	Stdlib
+	00000000000000000000000000000000	Monoid_utils
+	00000000000000000000000000000000	Monoid
+	00000000000000000000000000000000	CamlinternalFormatBasics

ocaml/testsuite/tests/templates/basic/ref_indirect.cmx.ocamlobjinfo.reference

@@ -0,0 +1,30 @@
+File ref_indirect.cmx
+Name: Ref_indirect
+CRC of implementation: 00000000000000000000000000000000
+Globals defined:
+	Ref_indirect
+Interfaces imported:
+	00000000000000000000000000000000	Stdlib
+	00000000000000000000000000000000	Ref_indirect
+	00000000000000000000000000000000	Monoid_utils
+	00000000000000000000000000000000	Monoid
+	00000000000000000000000000000000	CamlinternalFormatBasics
+Implementations imported:
+Flambda 2 unit (with no export information)
+Currying functions:
+Apply functions:
+Send functions:
+Force link: no
+Function summaries for static checks:
+		camlRef_indirect__entry = 0x15
+File ref_indirect.cmi
+Unit name: Ref_indirect
+Is parameter: no
+Parameters:
+	Monoid
+Interfaces imported:
+	00000000000000000000000000000000	Ref_indirect
+	00000000000000000000000000000000	Stdlib
+	00000000000000000000000000000000	Monoid_utils
+	00000000000000000000000000000000	Monoid
+	00000000000000000000000000000000	CamlinternalFormatBasics

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

@@ -0,0 +1 @@
+let concat = Monoid_utils.concat