Add -as-argument-for parameter

backend/asmpackager.ml

@@ -128,10 +128,15 @@ let make_package_object unix ~ppf_dump members targetobj targetname coercion
         ~style:transl_style
     in
     let code = Simplif.simplify_lambda code in
+    let arg_block_field =
+      (* Packs not supported as argument modules *)
+      None
+    in
     let program =
       { Lambda.
         code;
         main_module_block_size;
+        arg_block_field;
         compilation_unit;
         required_globals;
       }
@@ -232,6 +237,7 @@ let build_package_cmx members cmxfile =
       ui_defines =
           List.flatten (List.map (fun info -> info.ui_defines) units) @
           [ui.ui_unit];
+      ui_arg_descr = None;
       ui_imports_cmi =
           (Import_info.create modname
             ~crc_with_unit:(Some (ui.ui_unit, Env.crc_of_unit modname))) ::

driver/optcompile.ml

@@ -38,20 +38,21 @@ let compile i typed ~transl_style ~unix ~pipeline =
   |> print_if i.ppf_dump Clflags.dump_rawlambda Printlambda.program
   |> Compiler_hooks.execute_and_pipe Compiler_hooks.Raw_lambda
   |> Profile.(record generate)
-   (fun program ->
+   (fun (program : Lambda.program) ->
       let code = Simplif.simplify_lambda program.Lambda.code in
       { program with Lambda.code }
       |> print_if i.ppf_dump Clflags.dump_lambda Printlambda.program
       |> Compiler_hooks.execute_and_pipe Compiler_hooks.Lambda
-      |> (fun program ->
+      |> (fun (program : Lambda.program) ->
            Asmgen.compile_implementation
              unix
              ~pipeline
              ~filename:i.source_file
              ~prefixname:i.output_prefix
              ~ppf_dump:i.ppf_dump
              program);
-           Compilenv.save_unit_info (cmx i))
+           Compilenv.save_unit_info (cmx i)
+             ~arg_block_field:program.arg_block_field)
 
 type flambda2 =
   ppf_dump:Format.formatter ->
@@ -69,9 +70,16 @@ let emit unix i =
 
 let implementation unix ~backend ~(flambda2 : flambda2) ~start_from ~source_file
     ~output_prefix ~keep_symbol_tables =
-  let backend info ({ structure; coercion; _ } : Typedtree.implementation) =
+  let backend info ({ structure; coercion; secondary_iface; _ }
+                    : Typedtree.implementation) =
     Compilenv.reset info.module_name;
-    let typed = structure, coercion in
+    let secondary_coercion =
+      match secondary_iface with
+      | Some { si_coercion_from_primary; si_signature = _ } ->
+        Some si_coercion_from_primary
+      | None -> None
+    in
+    let typed = structure, coercion, secondary_coercion in
     let transl_style : Translmod.compilation_unit_style =
       if Config.flambda || Config.flambda2 then Plain_block
       else Set_individual_fields

file_formats/cmx_format.mli

@@ -59,6 +59,9 @@ type unit_infos =
                                           (* All compilation units in the
                                              .cmx file (i.e. [ui_unit] and
                                              any produced via [Asmpackager]) *)
+    mutable ui_arg_descr: Lambda.arg_descr option;
+                                          (* If this is an argument unit, the
+                                             parameter it implements *)
     mutable ui_imports_cmi: Import_info.t list;
                                           (* Interfaces imported *)
     mutable ui_imports_cmx: Import_info.t list;
@@ -71,6 +74,7 @@ type unit_infos =
 type unit_infos_raw =
   { uir_unit: Compilation_unit.t;
     uir_defines: Compilation_unit.t list;
+    uir_arg_descr: Lambda.arg_descr option;
     uir_imports_cmi: Import_info.t array;
     uir_imports_cmx: Import_info.t array;
     uir_generic_fns: generic_fns;

middle_end/compilenv.ml

@@ -94,6 +94,7 @@ let default_ui_export_info =
 let current_unit =
   { ui_unit = CU.dummy;
     ui_defines = [];
+    ui_arg_descr = None;
     ui_imports_cmi = [];
     ui_imports_cmx = [];
     ui_generic_fns = { curry_fun = []; apply_fun = []; send_fun = [] };
@@ -108,6 +109,7 @@ let reset compilation_unit =
   CU.set_current (Some compilation_unit);
   current_unit.ui_unit <- compilation_unit;
   current_unit.ui_defines <- [compilation_unit];
+  current_unit.ui_arg_descr <- None;
   current_unit.ui_imports_cmi <- [];
   current_unit.ui_imports_cmx <- [];
   current_unit.ui_generic_fns <-
@@ -148,6 +150,7 @@ let read_unit_info filename =
     let ui = {
       ui_unit = uir.uir_unit;
       ui_defines = uir.uir_defines;
+      ui_arg_descr = uir.uir_arg_descr;
       ui_imports_cmi = uir.uir_imports_cmi |> Array.to_list;
       ui_imports_cmx = uir.uir_imports_cmx |> Array.to_list;
       ui_generic_fns = uir.uir_generic_fns;
@@ -353,6 +356,7 @@ let write_unit_info info filename =
   let raw_info = {
     uir_unit = info.ui_unit;
     uir_defines = info.ui_defines;
+    uir_arg_descr = info.ui_arg_descr;
     uir_imports_cmi = Array.of_list info.ui_imports_cmi;
     uir_imports_cmx = Array.of_list info.ui_imports_cmx;
     uir_generic_fns = info.ui_generic_fns;
@@ -371,8 +375,17 @@ let write_unit_info info filename =
   Digest.output oc crc;
   close_out oc
 
-let save_unit_info filename =
+let save_unit_info filename ~arg_block_field =
   current_unit.ui_imports_cmi <- Env.imports();
+  current_unit.ui_arg_descr <-
+    begin match !Clflags.as_argument_for, arg_block_field with
+    | Some arg_param, Some arg_block_field ->
+      let arg_param = Compilation_unit.Name.of_string arg_param in
+      Some { arg_param; arg_block_field }
+    | None, None -> None
+    | Some _, None -> Misc.fatal_error "No argument block"
+    | None, Some _ -> Misc.fatal_error "Unexpected argument block"
+    end;
   write_unit_info current_unit filename
 
 let snapshot () = !structured_constants

middle_end/compilenv.mli

@@ -110,7 +110,7 @@ val read_unit_info: string -> unit_infos * Digest.t
         (* Read infos and MD5 from a [.cmx] file. *)
 val write_unit_info: unit_infos -> string -> unit
         (* Save the given infos in the given file *)
-val save_unit_info: string -> unit
+val save_unit_info: string -> arg_block_field:int option -> unit
         (* Save the infos for the current unit in the given file *)
 val cache_unit_info: unit_infos -> unit
         (* Enter the given infos in the cache.  The infos will be

native_toplevel/opttoploop.ml

@@ -319,6 +319,7 @@ let load_lambda ppf ~compilation_unit ~required_globals lam size =
     { Lambda.
       code = slam;
       main_module_block_size = size;
+      arg_block_field = None;
       compilation_unit;
       required_globals;
     }
@@ -447,7 +448,8 @@ let execute_phrase print_outcome ppf phr =
         if any_flambda then
           let { Lambda.compilation_unit; main_module_block_size = size;
                 required_globals; code = res } =
-            Translmod.transl_implementation compilation_unit (str, coercion)
+            Translmod.transl_implementation compilation_unit
+              (str, coercion, None)
               ~style:Plain_block
           in
           remember compilation_unit 0 sg';

ocaml/.depend

@@ -4503,7 +4503,8 @@ file_formats/cmi_format.cmi : \
 file_formats/cmo_format.cmi : \
     utils/import_info.cmi \
     typing/ident.cmi \
-    utils/compilation_unit.cmi
+    utils/compilation_unit.cmi \
+    lambda/lambda.cmi
 file_formats/cms_format.cmo : \
     typing/shape.cmi \
     parsing/parsetree.cmi \

ocaml/asmcomp/asmpackager.ml

@@ -120,10 +120,15 @@ let make_package_object ~ppf_dump members targetobj targetname coercion
         ~style:transl_style
     in
     let code = Simplif.simplify_lambda code in
+    let arg_block_field =
+      (* Packs not supported as argument modules *)
+      None
+    in
     let program =
       { Lambda.
         code;
         main_module_block_size;
+        arg_block_field;
         compilation_unit;
         required_globals;
       }
@@ -197,6 +202,7 @@ let build_package_cmx members cmxfile =
       ui_defines =
           List.flatten (List.map (fun info -> info.ui_defines) units) @
           [ui.ui_unit];
+      ui_arg_descr = None;
       ui_imports_cmi =
           (Import_info.create modname
             ~crc_with_unit:(Some (ui.ui_unit, Env.crc_of_unit modname))) ::

ocaml/bytecomp/bytepackager.ml

@@ -266,6 +266,7 @@ let package_object_files ~ppf_dump files targetfile targetname coercion =
         cu_pos = pos_code;
         cu_codesize = pos_debug - pos_code;
         cu_reloc = List.rev state.relocs;
+        cu_arg_descr = None;
         cu_imports =
           Array.of_list
             ((Import_info.create modname

ocaml/bytecomp/emitcode.ml

@@ -407,7 +407,7 @@ let rec emit = function
 
 (* Emission to a file *)
 
-let to_file outchan unit_name objfile ~required_globals code =
+let to_file outchan unit_name objfile ~required_globals ~arg_block_field code =
   init();
   Fun.protect ~finally:clear (fun () ->
   output_string outchan cmo_magic_number;
@@ -435,11 +435,21 @@ let to_file outchan unit_name objfile ~required_globals code =
       (p, pos_out outchan - p)
     end else
       (0, 0) in
+  let cu_arg_descr =
+    match !Clflags.as_argument_for, arg_block_field with
+    | Some param, Some arg_block_field ->
+        Some { arg_param = param |> Compilation_unit.Name.of_string;
+               arg_block_field = arg_block_field }
+    | None, None -> None
+    | Some _, None -> Misc.fatal_error "Expected argument field"
+    | None, Some _ -> Misc.fatal_error "Unexpected argument field"
+  in
   let compunit =
     { cu_name = unit_name;
       cu_pos = pos_code;
       cu_codesize = !out_position;
       cu_reloc = List.rev !reloc_info;
+      cu_arg_descr;
       cu_imports = Env.imports() |> Array.of_list;
       cu_primitives = List.map Primitive.byte_name
                                !Translmod.primitive_declarations;

ocaml/bytecomp/emitcode.mli

@@ -19,7 +19,8 @@ open Cmo_format
 open Instruct
 
 val to_file: out_channel -> Compilation_unit.t -> string ->
-  required_globals:Compilation_unit.Set.t -> instruction list -> unit
+  required_globals:Compilation_unit.Set.t -> arg_block_field:int option ->
+  instruction list -> unit
         (* Arguments:
              channel on output file
              name of compilation unit implemented

ocaml/driver/compile.ml

@@ -30,23 +30,29 @@ let interface ~source_file ~output_prefix =
 
 (** Bytecode compilation backend for .ml files. *)
 
-let to_bytecode i Typedtree.{structure; coercion; _} =
-  (structure, coercion)
+let to_bytecode i Typedtree.{structure; coercion; secondary_iface; _} =
+  let secondary_coercion =
+    match secondary_iface with
+    | Some { si_coercion_from_primary; si_signature = _ } ->
+        Some si_coercion_from_primary
+    | None -> None
+  in
+  (structure, coercion, secondary_coercion)
   |> Profile.(record transl)
     (Translmod.transl_implementation i.module_name ~style:Set_global_to_block)
   |> Profile.(record ~accumulate:true generate)
-    (fun { Lambda.code = lambda; required_globals } ->
+    (fun { Lambda.code = lambda; required_globals; arg_block_field } ->
        lambda
        |> print_if i.ppf_dump Clflags.dump_rawlambda Printlambda.lambda
        |> Simplif.simplify_lambda
        |> print_if i.ppf_dump Clflags.dump_lambda Printlambda.lambda
        |> Bytegen.compile_implementation
             (i.module_name |> Compilation_unit.name_as_string)
        |> print_if i.ppf_dump Clflags.dump_instr Printinstr.instrlist
-       |> fun bytecode -> bytecode, required_globals
+       |> fun bytecode -> bytecode, required_globals, arg_block_field
     )
 
-let emit_bytecode i (bytecode, required_globals) =
+let emit_bytecode i (bytecode, required_globals, arg_block_field) =
   let cmofile = cmo i in
   let oc = open_out_bin cmofile in
   Misc.try_finally
@@ -55,7 +61,8 @@ let emit_bytecode i (bytecode, required_globals) =
     (fun () ->
        bytecode
        |> Profile.(record ~accumulate:true generate)
-         (Emitcode.to_file oc i.module_name cmofile ~required_globals);
+         (Emitcode.to_file oc i.module_name cmofile ~required_globals
+            ~arg_block_field);
     )
 
 let implementation ~start_from ~source_file ~output_prefix

ocaml/driver/compile.mli

@@ -26,12 +26,12 @@ val implementation:
 val to_bytecode :
   Compile_common.info ->
   Typedtree.implementation ->
-  Instruct.instruction list * Compilation_unit.Set.t
+  Instruct.instruction list * Compilation_unit.Set.t * int option
 (** [to_bytecode info typed] takes a typechecked implementation
     and returns its bytecode.
 *)
 
 val emit_bytecode :
-  Compile_common.info -> Instruct.instruction list * Compilation_unit.Set.t ->
+  Compile_common.info -> Instruct.instruction list * Compilation_unit.Set.t * int option ->
     unit
 (** [emit_bytecode bytecode] output the bytecode executable. *)

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.module_name info.env
+    |> Typemod.type_interface info.source_file info.module_name info.env
     |> print_if info.ppf_dump Clflags.dump_typedtree Printtyped.interface
   in
   let sg = tsg.Typedtree.sig_type in
@@ -85,7 +85,12 @@ let emit_signature info ast tsg =
       if !Clflags.as_parameter then
         Parameter
       else
-        Normal { cmi_impl = info.module_name }
+        let cmi_arg_for =
+          match !Clflags.as_argument_for with
+          | Some arg_type -> Some (Compilation_unit.Name.of_string arg_type)
+          | None -> None
+        in
+        Normal { cmi_impl = info.module_name; cmi_arg_for }
     in
     let alerts = Builtin_attributes.alerts_of_sig ast in
     Env.save_signature ~alerts tsg.Typedtree.sig_type

ocaml/driver/main_args.ml

@@ -636,6 +636,11 @@ let mk_as_parameter f =
   "<module name> Compiles the interface as a parameter for an open 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."
+;;
+
 let mk_use_prims f =
   "-use-prims", Arg.String f, "<file>  (undocumented)"
 
@@ -923,6 +928,7 @@ end
 module type Compiler_options = sig
   val _a : unit -> unit
   val _annot : unit -> unit
+  val _as_argument_for : string -> unit
   val _as_parameter : unit -> unit
   val _binannot : unit -> unit
   val _binannot_cms : unit -> unit
@@ -1122,6 +1128,7 @@ struct
     mk_absname F._absname;
     mk_no_absname F._no_absname;
     mk_annot F._annot;
+    mk_as_argument_for F._as_argument_for;
     mk_as_parameter F._as_parameter;
     mk_binannot F._binannot;
     mk_binannot_cms F._binannot_cms;
@@ -1331,6 +1338,7 @@ struct
     mk_afl_instrument F._afl_instrument;
     mk_afl_inst_ratio F._afl_inst_ratio;
     mk_annot F._annot;
+    mk_as_argument_for F._as_argument_for;
     mk_as_parameter F._as_parameter;
     mk_binannot F._binannot;
     mk_binannot_cms F._binannot_cms;
@@ -1888,6 +1896,7 @@ module Default = struct
     let _annot = set annotations
     let _args = Arg.read_arg
     let _args0 = Arg.read_arg0
+    let _as_argument_for s = as_argument_for := Some s
     let _as_parameter = set as_parameter
     let _binannot = set binary_annotations
     let _binannot_cms = set binary_annotations_cms

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_argument_for : string -> unit
   val _as_parameter : unit -> unit
   val _binannot : unit -> unit
   val _binannot_cms : unit -> unit