Squash of 'instantiate' into upstream/main

Tip of 'instantiate' (#1905) as of commit 5afb940.

This cherry-pick effectively merges #1872, #1873, #1726, and #1905
onto the 5.1.1minus-18 release (previous cherry-picks already
added #1841 and #1846).

Author: lukemaurer

backend/amd64/proc.ml

@@ -174,7 +174,7 @@ let extension_regs (type a) ?prefix (ext : a Language_extension.t) () =
     | Small_numbers -> hard_float32_reg ()
     | Mode | Unique | Include_functor | Comprehensions
     | Polymorphic_parameters | Immutable_arrays
-    | Module_strengthening | Layouts | Labeled_tuples -> [||]
+    | Module_strengthening | Layouts | Labeled_tuples | Instances -> [||]
   in match prefix with
   | None -> regs
   | Some p -> Array.sub regs 0 (Int.min p (Array.length regs))

backend/asminstantiator.ml

@@ -0,0 +1,10 @@
+let read_unit_info file : Instantiator.unit_info =
+  let unit_info, _crc = Compilenv.read_unit_info file in
+  let { Cmx_format.ui_unit; ui_arg_descr; ui_format; _ } = unit_info in
+  { Instantiator.ui_unit; ui_arg_descr; ui_format; }
+
+let instantiate unix ~src ~args targetcmx ~flambda2 =
+  Instantiator.instantiate ~src ~args targetcmx
+    ~expected_extension:".cmx"
+    ~read_unit_info
+    ~compile:(Optcompile.instance unix ~flambda2 ~keep_symbol_tables:false)

backend/asminstantiator.mli

@@ -0,0 +1,13 @@
+val instantiate
+  : (module Compiler_owee.Unix_intf.S)
+  -> src:string
+  -> args:string list
+  -> string
+  -> flambda2:(
+      ppf_dump:Format.formatter ->
+      prefixname:string ->
+      filename:string ->
+      keep_symbol_tables:bool ->
+      Lambda.program ->
+      Cmm.phrase list)
+  -> unit

backend/asmpackager.ml

@@ -128,10 +128,18 @@ let make_package_object unix ~ppf_dump members targetobj targetname coercion
         ~style:transl_style
     in
     let code = Simplif.simplify_lambda code in
+    let module_block_format : Lambda.module_block_format =
+      Mb_record { mb_size = main_module_block_size }
+    in
+    let arg_block_field =
+      (* Packs not supported as argument modules *)
+      None
+    in
     let program =
       { Lambda.
         code;
-        main_module_block_size;
+        module_block_format;
+        arg_block_field;
         compilation_unit;
         required_globals;
       }
@@ -152,12 +160,13 @@ let make_package_object unix ~ppf_dump members targetobj targetname coercion
       Ccomp.call_linker Ccomp.Partial targetobj (objtemp :: objfiles) ""
     in
     remove_file objtemp;
-    if not (exitcode = 0) then raise(Error Linking_error)
+    if not (exitcode = 0) then raise(Error Linking_error);
+    main_module_block_size
   )
 
 (* Make the .cmx file for the package *)
 
-let build_package_cmx members cmxfile =
+let build_package_cmx members cmxfile ~main_module_block_size =
   let unit_names =
     List.map (fun m -> m.pm_name) members in
   let filter lst =
@@ -184,17 +193,23 @@ let build_package_cmx members cmxfile =
   List.iter (fun info -> Zero_alloc_info.merge info.ui_zero_alloc_info
                            ~into:ui_zero_alloc_info) units;
   let modname = Compilation_unit.name ui.ui_unit in
+  let format : Lambda.module_block_format =
+    (* Open modules not supported with packs, so always just a record *)
+    Mb_record { mb_size = main_module_block_size }
+  in
   let pkg_infos =
     { ui_unit = ui.ui_unit;
       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))) ::
             filter (Asmlink.extract_crc_interfaces ());
       ui_imports_cmx =
           filter(Asmlink.extract_crc_implementations());
+      ui_format = format;
       ui_generic_fns =
         { curry_fun =
             union(List.map (fun info -> info.ui_generic_fns.curry_fun) units);
@@ -221,9 +236,11 @@ let package_object_files unix ~ppf_dump files targetcmx
   in
   let members = map_left_right (read_member_info pack_path) files in
   check_units members;
-  make_package_object unix ~ppf_dump members targetobj targetname coercion
-    ~flambda2;
-  build_package_cmx members targetcmx
+  let main_module_block_size =
+    make_package_object unix ~ppf_dump members targetobj targetname coercion
+      ~flambda2
+  in
+  build_package_cmx members targetcmx ~main_module_block_size
 
 (* The entry point *)
 

driver/optcompile.ml

@@ -23,36 +23,55 @@ let tool_name = "ocamlopt"
 let with_info = Compile_common.with_info ~native:true ~tool_name
 
 let interface ~source_file ~output_prefix =
-  with_info ~source_file ~output_prefix ~dump_ext:"cmi" @@ fun info ->
+  with_info ~source_file ~output_prefix ~dump_ext:"cmi"
+    ~compilation_unit:Inferred_from_output_prefix
+  @@ fun info ->
   Compile_common.interface
   ~hook_parse_tree:(Compiler_hooks.execute Compiler_hooks.Parse_tree_intf)
   ~hook_typed_tree:(Compiler_hooks.execute Compiler_hooks.Typed_tree_intf)
     info
 
 (** Native compilation backend for .ml files. *)
 
-let compile i typed ~transl_style ~unix ~pipeline =
-  typed
-  |> Profile.(record transl)
-    (Translmod.transl_implementation i.module_name ~style:transl_style)
+let make_arg_descr ~param ~arg_block_field : Lambda.arg_descr option =
+  match param, arg_block_field with
+  | Some arg_param, Some arg_block_field -> Some { arg_param; arg_block_field }
+  | None, None -> None
+  | Some _, None -> Misc.fatal_error "No argument field"
+  | None, Some _ -> Misc.fatal_error "Unexpected argument field"
+
+let compile_from_raw_lambda i raw_lambda ~unix ~pipeline ~as_arg_for =
+  raw_lambda
   |> 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) ->
       Builtin_attributes.warn_unused ();
       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))
+           let arg_descr =
+             make_arg_descr ~param:as_arg_for
+               ~arg_block_field:program.arg_block_field
+           in
+           Compilenv.save_unit_info (cmx i)
+             ~module_block_format:program.module_block_format
+             ~arg_descr)
+
+let compile_from_typed i typed ~transl_style ~unix ~pipeline ~as_arg_for =
+  typed
+  |> Profile.(record transl)
+    (Translmod.transl_implementation i.module_name ~style:transl_style)
+  |> compile_from_raw_lambda i ~unix ~pipeline ~as_arg_for
 
 type flambda2 =
   ppf_dump:Format.formatter ->
@@ -68,31 +87,106 @@ let emit unix i =
   Asmgen.compile_implementation_linear unix
     i.output_prefix ~progname:i.source_file
 
-let implementation unix ~(flambda2 : flambda2) ~start_from ~source_file
-    ~output_prefix ~keep_symbol_tables =
-  let backend info ({ structure; coercion; _ } : Typedtree.implementation) =
+type starting_point =
+  | Parsing
+  | Emit
+  | Instantiation of {
+      runtime_args : Translmod.runtime_arg list;
+      main_module_block_size : int;
+      arg_descr : Lambda.arg_descr option;
+  }
+
+let starting_point_of_compiler_pass start_from  =
+  match (start_from:Clflags.Compiler_pass.t) with
+  | Parsing -> Parsing
+  | Emit -> Emit
+  | _ -> Misc.fatal_errorf "Cannot start from %s"
+           (Clflags.Compiler_pass.to_string start_from)
+
+let implementation0 unix ~(flambda2 : flambda2) ~start_from
+      ~source_file ~output_prefix ~keep_symbol_tables
+      ~(compilation_unit : Compile_common.compilation_unit_or_inferred) =
+  let transl_style : Translmod.compilation_unit_style =
+    if Config.flambda || Config.flambda2 then Plain_block
+    else Set_individual_fields
+  in
+  let pipeline : Asmgen.pipeline =
+    Direct_to_cmm (flambda2 ~keep_symbol_tables)
+  in
+  let backend info ({ structure; coercion; argument_interface; _ }
+                    : Typedtree.implementation) =
     Compilenv.reset info.module_name;
-    let typed = structure, coercion in
-    let transl_style : Translmod.compilation_unit_style =
-      if Config.flambda || Config.flambda2 then Plain_block
-      else Set_individual_fields
+    let argument_coercion =
+      match argument_interface with
+      | Some { ai_coercion_from_primary; ai_signature = _ } ->
+        Some ai_coercion_from_primary
+      | None -> None
     in
-    let pipeline : Asmgen.pipeline =
-      Direct_to_cmm (flambda2 ~keep_symbol_tables)
+    let typed = structure, coercion, argument_coercion in
+    let as_arg_for =
+      !Clflags.as_argument_for
+      |> Option.map (fun param ->
+           (* Currently, parameters don't have parameters, so we assume the argument
+              list is empty *)
+           Global_module.Name.create_exn param [])
     in
     if not (Config.flambda || Config.flambda2) then Clflags.set_oclassic ();
-    compile info typed ~unix ~transl_style ~pipeline
+    compile_from_typed info typed ~unix ~transl_style ~pipeline ~as_arg_for
   in
-  with_info ~source_file ~output_prefix ~dump_ext:"cmx" @@ fun info ->
+  with_info ~source_file ~output_prefix ~dump_ext:"cmx" ~compilation_unit
+  @@ fun info ->
   if !Flambda_backend_flags.internal_assembler then
       Emitaux.binary_backend_available := true;
-  match (start_from:Clflags.Compiler_pass.t) with
+  match start_from with
   | Parsing ->
     Compile_common.implementation
       ~hook_parse_tree:(Compiler_hooks.execute Compiler_hooks.Parse_tree_impl)
       ~hook_typed_tree:(fun (impl : Typedtree.implementation) ->
         Compiler_hooks.execute Compiler_hooks.Typed_tree_impl impl)
       info ~backend
   | Emit -> emit unix info ~ppf_dump:info.ppf_dump
-  | _ -> Misc.fatal_errorf "Cannot start from %s"
-           (Clflags.Compiler_pass.to_string start_from)
+  | Instantiation { runtime_args; main_module_block_size; arg_descr } ->
+    Compilenv.reset info.module_name;
+    (* FIXME delete {[
+    let global_name =
+      Compilation_unit.to_global_name_exn info.module_name
+    in
+    (* Consider the names of arguments to be parameters for the purposes of the
+       subset rule - that is, a module we import can refer to our arguments as
+       parameters. *)
+    List.iter
+      (fun (param, _value) ->
+        let import = Compilation_unit.Name.of_head_of_global_name param in
+        Env.register_parameter_import import)
+      global_name.args;
+    ]} *)
+    let as_arg_for, arg_block_field =
+      match (arg_descr : Lambda.arg_descr option) with
+      | Some { arg_param; arg_block_field } ->
+        Some arg_param, Some arg_block_field
+      | None -> None, None
+    in
+    let impl =
+      Translmod.transl_instance info.module_name ~runtime_args
+        ~main_module_block_size ~arg_block_field
+        ~style:transl_style
+    in
+    if not (Config.flambda || Config.flambda2) then Clflags.set_oclassic ();
+    compile_from_raw_lambda info impl ~unix ~pipeline ~as_arg_for
+
+let implementation unix ~flambda2 ~start_from ~source_file
+      ~output_prefix ~keep_symbol_tables =
+  let start_from = start_from |> starting_point_of_compiler_pass in
+  implementation0 unix ~flambda2 ~start_from ~source_file
+    ~output_prefix ~keep_symbol_tables
+    ~compilation_unit:Inferred_from_output_prefix
+
+let instance unix ~flambda2 ~source_file
+      ~output_prefix ~compilation_unit ~runtime_args ~main_module_block_size
+      ~arg_descr ~keep_symbol_tables =
+  let start_from =
+    Instantiation { runtime_args; main_module_block_size; arg_descr }
+  in
+  implementation0 unix ~flambda2 ~start_from ~source_file
+    ~output_prefix ~keep_symbol_tables
+    ~compilation_unit:(Exactly compilation_unit)

driver/optcompile.mli

@@ -29,3 +29,20 @@ val implementation
   -> start_from:Clflags.Compiler_pass.t
   -> source_file:string -> output_prefix:string -> keep_symbol_tables:bool
   -> unit
+
+val instance
+   : (module Compiler_owee.Unix_intf.S)
+  -> flambda2:(
+    ppf_dump:Format.formatter ->
+    prefixname:string ->
+    filename:string ->
+    keep_symbol_tables:bool ->
+    Lambda.program ->
+    Cmm.phrase list)
+  -> source_file:string -> output_prefix:string
+  -> compilation_unit:Compilation_unit.t
+  -> runtime_args:Translmod.runtime_arg list
+  -> main_module_block_size:int
+  -> arg_descr:Lambda.arg_descr option
+  -> keep_symbol_tables:bool
+  -> unit

driver/optmaindriver.ml

@@ -81,21 +81,21 @@ let main unix argv ppf ~flambda2 =
     Compenv.readenv ppf Before_link;
     if
       List.length (List.filter (fun x -> !x)
-                     [make_package; make_archive; shared;
+                     [make_package; make_archive; shared; instantiate;
                       Compenv.stop_early; output_c_object]) > 1
     then
     begin
       let module P = Clflags.Compiler_pass in
       match !stop_after with
       | None ->
           Compenv.fatal "Please specify at most one of -pack, -a, -shared, -c, \
-                         -output-obj";
+                         -output-obj, -instantiate";
       | Some ((P.Parsing | P.Typing | P.Lambda | P.Middle_end | P.Scheduling
               | P.Simplify_cfg | P.Emit | P.Selection) as p) ->
         assert (P.is_compilation_pass p);
         Printf.ksprintf Compenv.fatal
           "Options -i and -stop-after (%s) \
-           are  incompatible with -pack, -a, -shared, -output-obj"
+           are  incompatible with -pack, -a, -shared, -output-obj, -instantiate"
           (String.concat "|"
              (P.available_pass_names ~filter:(fun _ -> true) ~native:true))
     end;
@@ -116,6 +116,23 @@ let main unix argv ppf ~flambda2 =
           ~flambda2);
       Warnings.check_fatal ();
     end
+    else if !instantiate then begin
+      Compmisc.init_path ();
+      (* Requiring [-o] isn't really necessary, but we don't intend for humans
+         to be invoking [-instantiate] by hand, and computing the correct value
+         here would be awkward *)
+      let target = Compenv.extract_output !output_name in
+      let src, args =
+        match Compenv.get_objfiles ~with_ocamlparam:false with
+        | [] | [_] ->
+          Printf.ksprintf Compenv.fatal
+            "Must specify at least two .cmx files with -instantiate"
+        | src :: args ->
+          src, args
+      in
+      Asminstantiator.instantiate unix ~src ~args target ~flambda2;
+      Warnings.check_fatal ();
+    end
     else if !shared then begin
       Compmisc.init_path ();
       let target = Compenv.extract_output !output_name in

dune

@@ -86,6 +86,7 @@
   afl_instrument
   arch
   asmgen
+  asminstantiator
   asmlibrarian
   asmlink
   asmpackager