Move some code from Asmgen to the middle end directory etc. (#2288)

Followup to (#2281)

.depend

@@ -1916,9 +1916,7 @@ asmcomp/arch.cmx : \
     utils/config.cmx \
     utils/clflags.cmx
 asmcomp/asmgen.cmo : \
-    middle_end/flambda/un_anf.cmi \
     lambda/translmod.cmi \
-    middle_end/symbol.cmi \
     asmcomp/split.cmi \
     asmcomp/spill.cmi \
     asmcomp/selection.cmi \
@@ -1930,22 +1928,17 @@ asmcomp/asmgen.cmo : \
     asmcomp/printmach.cmi \
     asmcomp/printlinear.cmi \
     asmcomp/printcmm.cmi \
-    middle_end/printclambda.cmi \
     typing/primitive.cmi \
-    typing/path.cmi \
     utils/misc.cmi \
     asmcomp/mach.cmi \
     parsing/location.cmi \
     asmcomp/liveness.cmi \
     asmcomp/linscan.cmi \
-    middle_end/linkage_name.cmi \
     asmcomp/linearize.cmi \
     lambda/lambda.cmi \
     asmcomp/interval.cmi \
     asmcomp/interf.cmi \
     typing/ident.cmi \
-    middle_end/flambda/flambda_to_clambda.cmi \
-    middle_end/flambda/flambda.cmi \
     asmcomp/emitaux.cmi \
     asmcomp/emit.cmi \
     asmcomp/deadcode.cmi \
@@ -1955,17 +1948,14 @@ asmcomp/asmgen.cmo : \
     asmcomp/coloring.cmi \
     asmcomp/cmmgen.cmi \
     asmcomp/cmm.cmi \
-    middle_end/closure/closure.cmi \
     utils/clflags.cmi \
     middle_end/clambda.cmi \
     asmcomp/CSE.cmo \
-    middle_end/flambda/build_export_info.cmi \
+    middle_end/backend_intf.cmi \
     asmcomp/debug/available_regs.cmi \
     asmcomp/asmgen.cmi
 asmcomp/asmgen.cmx : \
-    middle_end/flambda/un_anf.cmx \
     lambda/translmod.cmx \
-    middle_end/symbol.cmx \
     asmcomp/split.cmx \
     asmcomp/spill.cmx \
     asmcomp/selection.cmx \
@@ -1977,22 +1967,17 @@ asmcomp/asmgen.cmx : \
     asmcomp/printmach.cmx \
     asmcomp/printlinear.cmx \
     asmcomp/printcmm.cmx \
-    middle_end/printclambda.cmx \
     typing/primitive.cmx \
-    typing/path.cmx \
     utils/misc.cmx \
     asmcomp/mach.cmx \
     parsing/location.cmx \
     asmcomp/liveness.cmx \
     asmcomp/linscan.cmx \
-    middle_end/linkage_name.cmx \
     asmcomp/linearize.cmx \
     lambda/lambda.cmx \
     asmcomp/interval.cmx \
     asmcomp/interf.cmx \
     typing/ident.cmx \
-    middle_end/flambda/flambda_to_clambda.cmx \
-    middle_end/flambda/flambda.cmx \
     asmcomp/emitaux.cmx \
     asmcomp/emit.cmx \
     asmcomp/deadcode.cmx \
@@ -2002,18 +1987,16 @@ asmcomp/asmgen.cmx : \
     asmcomp/coloring.cmx \
     asmcomp/cmmgen.cmx \
     asmcomp/cmm.cmx \
-    middle_end/closure/closure.cmx \
     utils/clflags.cmx \
     middle_end/clambda.cmx \
     asmcomp/CSE.cmx \
-    middle_end/flambda/build_export_info.cmx \
+    middle_end/backend_intf.cmi \
     asmcomp/debug/available_regs.cmx \
     asmcomp/asmgen.cmi
 asmcomp/asmgen.cmi : \
     lambda/lambda.cmi \
-    typing/ident.cmi \
-    middle_end/flambda/flambda.cmi \
     asmcomp/cmm.cmi \
+    middle_end/clambda.cmi \
     middle_end/backend_intf.cmi
 asmcomp/asmlibrarian.cmo : \
     utils/misc.cmi \
@@ -2098,6 +2081,7 @@ asmcomp/asmpackager.cmo : \
     middle_end/compilenv.cmi \
     middle_end/compilation_unit.cmi \
     file_formats/cmx_format.cmi \
+    middle_end/closure/closure_middle_end.cmi \
     utils/clflags.cmi \
     utils/ccomp.cmi \
     asmcomp/asmlink.cmi \
@@ -2120,6 +2104,7 @@ asmcomp/asmpackager.cmx : \
     middle_end/compilenv.cmx \
     middle_end/compilation_unit.cmx \
     file_formats/cmx_format.cmi \
+    middle_end/closure/closure_middle_end.cmx \
     utils/clflags.cmx \
     utils/ccomp.cmx \
     asmcomp/asmlink.cmx \
@@ -3548,6 +3533,30 @@ middle_end/closure/closure.cmi : \
     lambda/lambda.cmi \
     middle_end/clambda.cmi \
     middle_end/backend_intf.cmi
+middle_end/closure/closure_middle_end.cmo : \
+    middle_end/printclambda.cmi \
+    typing/path.cmi \
+    lambda/lambda.cmi \
+    typing/ident.cmi \
+    middle_end/compilenv.cmi \
+    middle_end/closure/closure.cmi \
+    utils/clflags.cmi \
+    middle_end/clambda.cmi \
+    middle_end/closure/closure_middle_end.cmi
+middle_end/closure/closure_middle_end.cmx : \
+    middle_end/printclambda.cmx \
+    typing/path.cmx \
+    lambda/lambda.cmx \
+    typing/ident.cmx \
+    middle_end/compilenv.cmx \
+    middle_end/closure/closure.cmx \
+    utils/clflags.cmx \
+    middle_end/clambda.cmx \
+    middle_end/closure/closure_middle_end.cmi
+middle_end/closure/closure_middle_end.cmi : \
+    lambda/lambda.cmi \
+    middle_end/clambda.cmi \
+    middle_end/backend_intf.cmi
 middle_end/flambda/alias_analysis.cmo : \
     middle_end/variable.cmi \
     middle_end/flambda/base_types/var_within_closure.cmi \
@@ -4071,65 +4080,81 @@ middle_end/flambda/flambda_iterators.cmi : \
 middle_end/flambda/flambda_middle_end.cmo : \
     utils/warnings.cmi \
     middle_end/variable.cmi \
+    middle_end/flambda/un_anf.cmi \
     middle_end/symbol.cmi \
     middle_end/flambda/share_constants.cmi \
     middle_end/flambda/remove_unused_program_constructs.cmi \
     middle_end/flambda/remove_unused_closure_vars.cmi \
     middle_end/flambda/ref_to_variables.cmi \
     utils/profile.cmi \
+    middle_end/printclambda.cmi \
     utils/misc.cmi \
     parsing/location.cmi \
+    middle_end/linkage_name.cmi \
     middle_end/flambda/lift_let_to_initialize_symbol.cmi \
     middle_end/flambda/lift_constants.cmi \
     middle_end/flambda/lift_code.cmi \
+    lambda/lambda.cmi \
     utils/int_replace_polymorphic_compare.cmi \
     middle_end/flambda/inlining_cost.cmi \
     middle_end/flambda/inline_and_simplify.cmi \
     middle_end/flambda/initialize_symbol_to_let_symbol.cmi \
+    middle_end/flambda/flambda_to_clambda.cmi \
     middle_end/flambda/flambda_iterators.cmi \
     middle_end/flambda/flambda_invariants.cmi \
     middle_end/flambda/flambda.cmi \
     lambda/debuginfo.cmi \
+    middle_end/compilenv.cmi \
     middle_end/flambda/base_types/closure_id.cmi \
     middle_end/flambda/closure_conversion.cmi \
     utils/clflags.cmi \
+    middle_end/clambda.cmi \
+    middle_end/flambda/build_export_info.cmi \
     middle_end/backend_intf.cmi \
     middle_end/flambda/flambda_middle_end.cmi
 middle_end/flambda/flambda_middle_end.cmx : \
     utils/warnings.cmx \
     middle_end/variable.cmx \
+    middle_end/flambda/un_anf.cmx \
     middle_end/symbol.cmx \
     middle_end/flambda/share_constants.cmx \
     middle_end/flambda/remove_unused_program_constructs.cmx \
     middle_end/flambda/remove_unused_closure_vars.cmx \
     middle_end/flambda/ref_to_variables.cmx \
     utils/profile.cmx \
+    middle_end/printclambda.cmx \
     utils/misc.cmx \
     parsing/location.cmx \
+    middle_end/linkage_name.cmx \
     middle_end/flambda/lift_let_to_initialize_symbol.cmx \
     middle_end/flambda/lift_constants.cmx \
     middle_end/flambda/lift_code.cmx \
+    lambda/lambda.cmx \
     utils/int_replace_polymorphic_compare.cmx \
     middle_end/flambda/inlining_cost.cmx \
     middle_end/flambda/inline_and_simplify.cmx \
     middle_end/flambda/initialize_symbol_to_let_symbol.cmx \
+    middle_end/flambda/flambda_to_clambda.cmx \
     middle_end/flambda/flambda_iterators.cmx \
     middle_end/flambda/flambda_invariants.cmx \
     middle_end/flambda/flambda.cmx \
     lambda/debuginfo.cmx \
+    middle_end/compilenv.cmx \
     middle_end/flambda/base_types/closure_id.cmx \
     middle_end/flambda/closure_conversion.cmx \
     utils/clflags.cmx \
+    middle_end/clambda.cmx \
+    middle_end/flambda/build_export_info.cmx \
     middle_end/backend_intf.cmi \
     middle_end/flambda/flambda_middle_end.cmi
 middle_end/flambda/flambda_middle_end.cmi : \
     lambda/lambda.cmi \
-    typing/ident.cmi \
+    middle_end/clambda.cmi \
-    middle_end/flambda/flambda.cmi \
     middle_end/backend_intf.cmi
 middle_end/flambda/flambda_to_clambda.cmo : \
     middle_end/variable.cmi \
     middle_end/flambda/base_types/var_within_closure.cmi \
+    middle_end/flambda/un_anf.cmi \
     middle_end/flambda/base_types/tag.cmi \
     middle_end/symbol.cmi \
     middle_end/flambda/base_types/static_exception.cmi \
@@ -4148,6 +4173,7 @@ middle_end/flambda/flambda_to_clambda.cmo : \
     middle_end/flambda/export_info.cmi \
     lambda/debuginfo.cmi \
     middle_end/compilenv.cmi \
+    middle_end/compilation_unit.cmi \
     middle_end/flambda/closure_offsets.cmi \
     middle_end/flambda/base_types/closure_id.cmi \
     utils/clflags.cmi \
@@ -4158,6 +4184,7 @@ middle_end/flambda/flambda_to_clambda.cmo : \
 middle_end/flambda/flambda_to_clambda.cmx : \
     middle_end/variable.cmx \
     middle_end/flambda/base_types/var_within_closure.cmx \
+    middle_end/flambda/un_anf.cmx \
     middle_end/flambda/base_types/tag.cmx \
     middle_end/symbol.cmx \
     middle_end/flambda/base_types/static_exception.cmx \
@@ -4176,6 +4203,7 @@ middle_end/flambda/flambda_to_clambda.cmx : \
     middle_end/flambda/export_info.cmx \
     lambda/debuginfo.cmx \
     middle_end/compilenv.cmx \
+    middle_end/compilation_unit.cmx \
     middle_end/flambda/closure_offsets.cmx \
     middle_end/flambda/base_types/closure_id.cmx \
     utils/clflags.cmx \
@@ -5154,6 +5182,7 @@ middle_end/flambda/traverse_for_exported_symbols.cmi : \
     middle_end/flambda/base_types/export_id.cmi \
     middle_end/flambda/base_types/closure_id.cmi
 middle_end/flambda/un_anf.cmo : \
+    middle_end/symbol.cmi \
     middle_end/semantics_of_primitives.cmi \
     middle_end/printclambda.cmi \
     utils/misc.cmi \
@@ -5166,6 +5195,7 @@ middle_end/flambda/un_anf.cmo : \
     parsing/asttypes.cmi \
     middle_end/flambda/un_anf.cmi
 middle_end/flambda/un_anf.cmx : \
+    middle_end/symbol.cmx \
     middle_end/semantics_of_primitives.cmx \
     middle_end/printclambda.cmx \
     utils/misc.cmx \
@@ -5178,6 +5208,7 @@ middle_end/flambda/un_anf.cmx : \
     parsing/asttypes.cmi \
     middle_end/flambda/un_anf.cmi
 middle_end/flambda/un_anf.cmi : \
+    middle_end/symbol.cmi \
     middle_end/clambda.cmi
 middle_end/flambda/unbox_closures.cmo : \
     middle_end/variable.cmi \
@@ -5695,6 +5726,7 @@ driver/optcompile.cmo : \
     utils/config.cmi \
     middle_end/compilenv.cmi \
     driver/compile_common.cmi \
+    middle_end/closure/closure_middle_end.cmi \
     utils/clflags.cmi \
     asmcomp/asmgen.cmi \
     driver/optcompile.cmi
@@ -5709,6 +5741,7 @@ driver/optcompile.cmx : \
     utils/config.cmx \
     middle_end/compilenv.cmx \
     driver/compile_common.cmx \
+    middle_end/closure/closure_middle_end.cmx \
     utils/clflags.cmx \
     asmcomp/asmgen.cmx \
     driver/optcompile.cmi
@@ -5912,6 +5945,7 @@ toplevel/opttoploop.cmo : \
     driver/compmisc.cmi \
     middle_end/compilenv.cmi \
     driver/compenv.cmi \
+    middle_end/closure/closure_middle_end.cmi \
     utils/clflags.cmi \
     typing/btype.cmi \
     middle_end/backend_intf.cmi \
@@ -5958,6 +5992,7 @@ toplevel/opttoploop.cmx : \
     driver/compmisc.cmx \
     middle_end/compilenv.cmx \
     driver/compenv.cmx \
+    middle_end/closure/closure_middle_end.cmx \
     utils/clflags.cmx \
     typing/btype.cmx \
     middle_end/backend_intf.cmi \

Changes

@@ -146,7 +146,7 @@ OCaml 4.09.0
   (Mark Shinwell, review by Vincent Laviron)
 
 - #2281: Move some middle-end files around
-  (Mark Shinwell)
+  (Mark Shinwell, review by Pierre Chambart and Vincent Laviron)
 
 - #2283: Add [is_prefix] and [find_and_chop_longest_common_prefix] to
   [Misc.Stdlib.List]
@@ -159,6 +159,10 @@ OCaml 4.09.0
 - #2286: Functorise [Consistbl]
   (Mark Shinwell, review by Gabriel Radanne)
 
+- #2288: Move middle end code from [Asmgen] to [Clambda_middle_end] and
+  [Flambda_middle_end].  Run [Un_anf] from the middle end, not [Cmmgen].
+  (Mark Shinwell, review by Pierre Chambart)
+
 - #2291: Add [Compute_ranges] pass
   (Mark Shinwell, review by Vincent Laviron)
 

Makefile

@@ -189,7 +189,8 @@ ASMCOMP=\
 # the native code compiler is not present for some particular target.
 
 MIDDLE_END_CLOSURE=\
-  middle_end/closure/closure.cmo
+  middle_end/closure/closure.cmo \
+  middle_end/closure/closure_middle_end.cmo
 
 # Owing to dependencies through [Compilenv], which would be
 # difficult to remove, some of the lower parts of Flambda (anything that is

asmcomp/asmgen.ml

@@ -39,41 +39,6 @@ let pass_dump_linear_if ppf flag message phrase =
   if !flag then fprintf ppf "*** %s@.%a@." message Printlinear.fundecl phrase;
   phrase
 
-let flambda_raw_clambda_dump_if ppf
-      ({ Flambda_to_clambda. expr = ulambda; preallocated_blocks = _;
-        structured_constants; exported = _; } as input) =
-  if !dump_rawclambda then
-    begin
-      Format.fprintf ppf "@.clambda (before Un_anf):@.";
-      Printclambda.clambda ppf ulambda;
-      Symbol.Map.iter (fun sym cst ->
-          Format.fprintf ppf "%a:@ %a@."
-            Symbol.print sym
-            Printclambda.structured_constant cst)
-        structured_constants
-    end;
-  if !dump_cmm then Format.fprintf ppf "@.cmm:@.";
-  input
-
-type clambda_and_constants =
-  Clambda.ulambda *
-  Clambda.preallocated_block list *
-  Clambda.preallocated_constant list
-
-let raw_clambda_dump_if ppf
-      ((ulambda, _, structured_constants):clambda_and_constants) =
-  if !dump_rawclambda || !dump_clambda then
-    begin
-      Format.fprintf ppf "@.clambda:@.";
-      Printclambda.clambda ppf ulambda;
-      List.iter (fun {Clambda.symbol; definition} ->
-          Format.fprintf ppf "%s:@ %a@."
-            symbol
-            Printclambda.structured_constant definition)
-        structured_constants
-    end;
-  if !dump_cmm then Format.fprintf ppf "@.cmm:@."
-
 let rec regalloc ~ppf_dump round fd =
   if round > 50 then
     fatal_error(fd.Mach.fun_name ^
@@ -102,7 +67,6 @@ let (++) x f = f x
 
 let compile_fundecl ~ppf_dump fd_cmm =
   Proc.init ();
-  Cmmgen.reset ();
   Reg.reset();
   fd_cmm
   ++ Profile.record ~accumulate:true "selection" Selection.fundecl
@@ -145,8 +109,7 @@ let compile_genfuns ~ppf_dump f =
        | _ -> ())
     (Cmmgen.generic_functions true [Compilenv.current_unit_infos ()])
 
-let compile_unit _output_prefix asm_filename keep_asm
+let compile_unit asm_filename keep_asm obj_filename gen =
-      obj_filename gen =
   let create_asm = keep_asm || not !Emitaux.binary_backend_available in
   Emitaux.create_asm_file := create_asm;
   Misc.try_finally
@@ -167,109 +130,49 @@ let compile_unit _output_prefix asm_filename keep_asm
        if create_asm && not keep_asm then remove_file asm_filename
     )
 
-let set_export_info (ulambda, prealloc, structured_constants, export) =
-  Compilenv.set_export_info export;
-  (ulambda, prealloc, structured_constants)
-
 let end_gen_implementation ?toplevel ~ppf_dump
-    (clambda:clambda_and_constants) =
+    (clambda : Clambda.with_constants) =
   Emit.begin_assembly ();
   clambda
-  ++ Profile.record "cmm" (Cmmgen.compunit ~ppf_dump)
+  ++ Profile.record "cmm" Cmmgen.compunit
   ++ Profile.record "compile_phrases" (List.iter (compile_phrase ~ppf_dump))
   ++ (fun () -> ());
   (match toplevel with None -> () | Some f -> compile_genfuns ~ppf_dump f);
-
   (* We add explicit references to external primitive symbols.  This
      is to ensure that the object files that define these symbols,
      when part of a C library, won't be discarded by the linker.
      This is important if a module that uses such a symbol is later
      dynlinked. *)
-
   compile_phrase ~ppf_dump
     (Cmmgen.reference_symbols
-       (List.filter (fun s -> s <> "" && s.[0] <> '%')
+       (List.filter_map (fun prim ->
-          (List.map Primitive.native_name !Translmod.primitive_declarations))
+           if not (Primitive.native_name_is_external prim) then None
-    );
+           else Some (Primitive.native_name prim))
+          !Translmod.primitive_declarations));
   Emit.end_assembly ()
 
-let flambda_gen_implementation ?toplevel ~backend ~ppf_dump
+type middle_end =
-    (program:Flambda.program) =
+     backend:(module Backend_intf.S)
-  let export = Build_export_info.build_transient ~backend program in
+  -> filename:string
-  let (clambda, preallocated, constants) =
+  -> prefixname:string
-    Profile.record_call "backend" (fun () ->
+  -> ppf_dump:Format.formatter
-      (program, export)
+  -> Lambda.program
-      ++ Flambda_to_clambda.convert
+  -> Clambda.with_constants
-      ++ flambda_raw_clambda_dump_if ppf_dump
-      ++ (fun { Flambda_to_clambda. expr; preallocated_blocks;
-                structured_constants; exported; } ->
-             (* "init_code" following the name used in
-                [Cmmgen.compunit_and_constants]. *)
-           Un_anf.apply ~ppf_dump expr ~what:"init_code", preallocated_blocks,
-           structured_constants, exported)
-      ++ set_export_info)
-  in
-  let constants =
-    List.map (fun (symbol, definition) ->
-        { Clambda.symbol = Linkage_name.to_string (Symbol.label symbol);
-          exported = true;
-          definition;
-          provenance = None;
-        })
-      (Symbol.Map.bindings constants)
-  in
-  end_gen_implementation ?toplevel ~ppf_dump
-    (clambda, preallocated, constants)
 
-let lambda_gen_implementation ?toplevel ~backend ~ppf_dump
+let compile_implementation ?toplevel ~backend ~filename ~prefixname ~middle_end
-    (lambda:Lambda.program) =
+      ~ppf_dump (program : Lambda.program) =
-  let clambda =
-    Closure.intro ~backend ~size:lambda.main_module_block_size lambda.code
-  in
-  let provenance : Clambda.usymbol_provenance =
-    { original_idents = [];
-      module_path =
-        Path.Pident (Ident.create_persistent (Compilenv.current_unit_name ()));
-    }
-  in
-  let preallocated_block =
-    Clambda.{
-      symbol = Compilenv.make_symbol None;
-      exported = true;
-      tag = 0;
-      fields = List.init lambda.main_module_block_size (fun _ -> None);
-      provenance = Some provenance;
-    }
-  in
-  let clambda_and_constants =
-    clambda, [preallocated_block], Compilenv.structured_constants ()
-  in
-  Compilenv.clear_structured_constants ();
-  raw_clambda_dump_if ppf_dump clambda_and_constants;
-  end_gen_implementation ?toplevel ~ppf_dump clambda_and_constants
-
-let compile_implementation_gen ?toplevel prefixname
-    ~required_globals ~ppf_dump gen_implementation program =
   let asmfile =
     if !keep_asm_file || !Emitaux.binary_backend_available
     then prefixname ^ ext_asm
     else Filename.temp_file "camlasm" ext_asm
   in
-  compile_unit prefixname asmfile !keep_asm_file
+  compile_unit asmfile !keep_asm_file (prefixname ^ ext_obj)
-      (prefixname ^ ext_obj) (fun () ->
+    (fun () ->
-        Ident.Set.iter Compilenv.require_global required_globals;
+      Ident.Set.iter Compilenv.require_global program.required_globals;
-        gen_implementation ?toplevel ~ppf_dump program)
+      let clambda_with_constants =
-
+        middle_end ~backend ~filename ~prefixname ~ppf_dump program
-let compile_implementation_clambda ?toplevel prefixname
+      in
-    ~backend ~ppf_dump (program:Lambda.program) =
+      end_gen_implementation ?toplevel ~ppf_dump clambda_with_constants)
-  compile_implementation_gen ?toplevel prefixname
-    ~required_globals:program.Lambda.required_globals
-    ~ppf_dump (lambda_gen_implementation ~backend) program
-
-let compile_implementation_flambda ?toplevel prefixname
-    ~required_globals ~backend ~ppf_dump (program:Flambda.program) =
-  compile_implementation_gen ?toplevel prefixname
-    ~required_globals ~ppf_dump (flambda_gen_implementation ~backend) program
 
 (* Error report *)
 

asmcomp/asmgen.mli

@@ -13,20 +13,27 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* From lambda to assembly code *)
+(** From Lambda to assembly code *)
 
-val compile_implementation_flambda :
+(** The type of converters from Lambda to Clambda. *)
-    ?toplevel:(string -> bool) ->
+type middle_end =
-    string ->
+     backend:(module Backend_intf.S)
-    required_globals:Ident.Set.t ->
+  -> filename:string
-    backend:(module Backend_intf.S) ->
+  -> prefixname:string
-    ppf_dump:Format.formatter -> Flambda.program -> unit
+  -> ppf_dump:Format.formatter
+  -> Lambda.program
+  -> Clambda.with_constants
 
-val compile_implementation_clambda :
+(** Compile an implementation from Lambda using the given middle end. *)
-    ?toplevel:(string -> bool) ->
+val compile_implementation
-    string ->
+   : ?toplevel:(string -> bool)
-    backend:(module Backend_intf.S) ->
+  -> backend:(module Backend_intf.S)
-    ppf_dump:Format.formatter -> Lambda.program -> unit
+  -> filename:string
+  -> prefixname:string
+  -> middle_end:middle_end
+  -> ppf_dump:Format.formatter
+  -> Lambda.program
+  -> unit
 
 val compile_phrase :
     ppf_dump:Format.formatter -> Cmm.phrase -> unit
@@ -37,6 +44,5 @@ val report_error: Format.formatter -> error -> unit
 
 
 val compile_unit:
-  string(*prefixname*) ->
   string(*asm file*) -> bool(*keep asm*) ->
   string(*obj file*) -> (unit -> unit) -> unit

asmcomp/asmlink.ml

@@ -287,7 +287,7 @@ let link_shared ~ppf_dump objfiles output_name =
       then output_name ^ ".startup" ^ ext_asm
       else Filename.temp_file "camlstartup" ext_asm in
     let startup_obj = output_name ^ ".startup" ^ ext_obj in
-    Asmgen.compile_unit output_name
+    Asmgen.compile_unit
       startup !Clflags.keep_startup_file startup_obj
       (fun () ->
          make_shared_startup_file ~ppf_dump
@@ -352,7 +352,7 @@ let link ~ppf_dump objfiles output_name =
       then output_name ^ ".startup" ^ ext_asm
       else Filename.temp_file "camlstartup" ext_asm in
     let startup_obj = Filename.temp_file "camlstartup" ext_obj in
-    Asmgen.compile_unit output_name
+    Asmgen.compile_unit
       startup !Clflags.keep_startup_file startup_obj
       (fun () -> make_startup_file ~ppf_dump units_tolink ~crc_interfaces);
     Misc.try_finally

asmcomp/asmpackager.ml

@@ -99,27 +99,42 @@ let make_package_object ~ppf_dump members targetobj targetname coercion
         members in
     let module_ident = Ident.create_persistent targetname in
     let prefixname = Filename.remove_extension objtemp in
-    if Config.flambda then begin
+    let required_globals = Ident.Set.empty in
-      let size, lam = Translmod.transl_package_flambda components coercion in
+    let program, middle_end =
-      let flam =
+      if Config.flambda then
-        Flambda_middle_end.middle_end ~ppf_dump
+        let main_module_block_size, code =
-          ~prefixname
+          Translmod.transl_package_flambda components coercion
-          ~backend
+        in
-          ~size
+        let program =
-          ~filename:targetname
+          { Lambda.
-          ~module_ident
+            code;
-          ~module_initializer:lam
+            main_module_block_size;
-      in
+            module_ident;
-      Asmgen.compile_implementation_flambda
+            required_globals;
-        prefixname ~backend ~required_globals:Ident.Set.empty ~ppf_dump flam;
+          }
-    end else begin
+        in
-      let main_module_block_size, code =
+        program, Flambda_middle_end.lambda_to_clambda
-        Translmod.transl_store_package
+      else
-          components (Ident.create_persistent targetname) coercion in
+        let main_module_block_size, code =
-      Asmgen.compile_implementation_clambda
+          Translmod.transl_store_package components
-        prefixname ~backend ~ppf_dump { Lambda.code; main_module_block_size;
+            (Ident.create_persistent targetname) coercion
-                         module_ident; required_globals = Ident.Set.empty }
+        in
-    end;
+        let program =
+          { Lambda.
+            code;
+            main_module_block_size;
+            module_ident;
+            required_globals;
+          }
+        in
+        program, Closure_middle_end.lambda_to_clambda
+    in
+    Asmgen.compile_implementation ~backend
+      ~filename:targetname
+      ~prefixname
+      ~middle_end
+      ~ppf_dump
+      program;
     let objfiles =
       List.map
         (fun m -> Filename.remove_extension m.pm_file ^ Config.ext_obj)
@@ -130,6 +145,7 @@ let make_package_object ~ppf_dump members targetobj targetname coercion
     remove_file objtemp;
     if not ok then raise(Error Linking_error)
   )
+
 (* Make the .cmx file for the package *)
 
 let get_export_info ui =

asmcomp/cmmgen.ml

@@ -3225,13 +3225,8 @@ and transl_letrec env bindings cont =
 
 (* Translate a function definition *)
 
-let transl_function ~ppf_dump f =
+let transl_function f =
-  let body =
+  let body = f.body in
-    if Config.flambda then
-      Un_anf.apply ~ppf_dump f.body ~what:f.label
-    else
-      f.body
-  in
   let cmm_body =
     let env = create_env ~environment_param:f.env in
     if !Clflags.afl_instrument then
@@ -3252,17 +3247,17 @@ let transl_function ~ppf_dump f =
 
 (* Translate all function definitions *)
 
-let rec transl_all_functions ~ppf_dump already_translated cont =
+let rec transl_all_functions already_translated cont =
   match Cmmgen_state.next_function () with
   | None -> cont, already_translated
   | Some f ->
     let sym = f.label in
     if String.Set.mem sym already_translated then
-      transl_all_functions ~ppf_dump already_translated cont
+      transl_all_functions already_translated cont
     else begin
-      transl_all_functions ~ppf_dump
+      transl_all_functions
         (String.Set.add sym already_translated)
-        ((f.dbg, transl_function ~ppf_dump f) :: cont)
+        ((f.dbg, transl_function f) :: cont)
     end
 
 (* Emit constant closures *)
@@ -3349,16 +3344,16 @@ let emit_cmm_data_items_for_constants cont =
           c := (Cdata cmm) :: !c
       | Const_table (global, elems) ->
           c := (Cdata (emit_constant_table (symbol, global) elems)) :: !c)
-    (Cmmgen_state.constants ());
+    (Cmmgen_state.get_and_clear_constants ());
-  Cdata (Cmmgen_state.data_items ()) :: !c
+  Cdata (Cmmgen_state.get_and_clear_data_items ()) :: !c
 
-let transl_all_functions ~ppf_dump cont =
+let transl_all_functions cont =
   let rec aux already_translated cont translated_functions =
     if Cmmgen_state.no_more_functions ()
     then cont, translated_functions
     else
       let translated_functions, already_translated =
-        transl_all_functions ~ppf_dump already_translated translated_functions
+        transl_all_functions already_translated translated_functions
       in
       aux already_translated cont translated_functions
   in
@@ -3422,7 +3417,8 @@ let emit_preallocated_blocks preallocated_blocks cont =
 
 (* Translate a compilation unit *)
 
-let compunit ~ppf_dump (ulam, preallocated_blocks, constants) =
+let compunit (ulam, preallocated_blocks, constants) =
+  assert (Cmmgen_state.no_more_functions ());
   let dbg = Debuginfo.none in
   let init_code =
     if !Clflags.afl_instrument then
@@ -3444,7 +3440,7 @@ let compunit ~ppf_dump (ulam, preallocated_blocks, constants) =
                          else [ Reduce_code_size ];
                        fun_dbg  = Debuginfo.none }] in
   let c2 = transl_clambda_constants constants c1 in
-  let c3 = transl_all_functions ~ppf_dump c2 in
+  let c3 = transl_all_functions c2 in
   let c4 = emit_preallocated_blocks preallocated_blocks c3 in
   emit_cmm_data_items_for_constants c4
 
@@ -3943,6 +3939,3 @@ let plugin_header units =
     } in
   global_data "caml_plugin_header"
     { dynu_magic = Config.cmxs_magic_number; dynu_units = List.map mk units }
-
-let reset () =
-  Cmmgen_state.reset ()

asmcomp/cmmgen.mli

@@ -15,9 +15,8 @@
 
 (* Translation from closed lambda to C-- *)
 
-val compunit:
+val compunit
-  ppf_dump:Format.formatter
+   : Clambda.ulambda
-  -> Clambda.ulambda
     * Clambda.preallocated_block list
     * Clambda.preallocated_constant list
   -> Cmm.phrase list
@@ -38,5 +37,3 @@ val code_segment_table: string list -> Cmm.phrase
 val predef_exception: int -> string -> Cmm.phrase
 val plugin_header: (Cmx_format.unit_infos * Digest.t) list -> Cmm.phrase
 val black_block_header: (*tag:*)int -> (*size:*)int -> nativeint
-
-val reset : unit -> unit

asmcomp/cmmgen_state.ml

@@ -39,11 +39,6 @@ let empty = {
 
 let state = empty
 
-let reset () =
-  state.constants <- S.Map.empty;
-  state.data_items <- [];
-  Queue.clear state.functions
-
 let add_constant sym cst =
   state.constants <- S.Map.add sym cst state.constants
 
@@ -53,9 +48,15 @@ let add_data_items items =
 let add_function func =
   Queue.add func state.functions
 
-let constants () = state.constants
+let get_and_clear_constants () =
+  let constants = state.constants in
+  state.constants <- S.Map.empty;
+  constants
 
-let data_items () = List.concat (List.rev state.data_items)
+let get_and_clear_data_items () =
+  let data_items = List.concat (List.rev state.data_items) in
+  state.data_items <- [];
+  data_items
 
 let next_function () =
   match Queue.take state.functions with

asmcomp/cmmgen_state.mli

@@ -19,8 +19,6 @@
 
 [@@@ocaml.warning "+a-4-30-40-41-42"]
 
-val reset : unit -> unit
-
 type is_global = Global | Local
 
 type constant =
@@ -33,9 +31,9 @@ val add_data_items : Cmm.data_item list -> unit
 
 val add_function : Clambda.ufunction -> unit
 
-val constants : unit -> constant Misc.Stdlib.String.Map.t
+val get_and_clear_constants : unit -> constant Misc.Stdlib.String.Map.t
 
-val data_items : unit -> Cmm.data_item list
+val get_and_clear_data_items : unit -> Cmm.data_item list
 
 val next_function : unit -> Clambda.ufunction option
 

driver/optcompile.ml

@@ -48,17 +48,22 @@ let flambda i backend typed =
     |>> print_if i.ppf_dump Clflags.dump_rawlambda Printlambda.lambda
     |>> Simplif.simplify_lambda
     |>> print_if i.ppf_dump Clflags.dump_lambda Printlambda.lambda
-    |> (fun ((module_ident, size), lam) ->
+    |> (fun ((module_ident, main_module_block_size), code) ->
-      Flambda_middle_end.middle_end
+      let program : Lambda.program =
-        ~ppf_dump:i.ppf_dump
+        { Lambda.
-        ~prefixname:i.output_prefix
+          module_ident;
-        ~size
+          main_module_block_size;
-        ~filename:i.source_file
+          required_globals;
-        ~module_ident
+          code;
+        }
+      in
+      Asmgen.compile_implementation
         ~backend
-        ~module_initializer:lam)
+        ~filename:i.source_file
-    |> Asmgen.compile_implementation_flambda
+        ~prefixname:i.output_prefix
-      i.output_prefix ~required_globals ~backend ~ppf_dump:i.ppf_dump;
+        ~middle_end:Flambda_middle_end.lambda_to_clambda
+        ~ppf_dump:i.ppf_dump
+        program);
     Compilenv.save_unit_info (cmx i))
 
 let clambda i backend typed =
@@ -72,8 +77,12 @@ let clambda i backend typed =
        let code = Simplif.simplify_lambda program.Lambda.code in
        { program with Lambda.code }
        |> print_if i.ppf_dump Clflags.dump_lambda Printlambda.program
-       |> Asmgen.compile_implementation_clambda
+       |> Asmgen.compile_implementation
-         i.output_prefix ~backend ~ppf_dump:i.ppf_dump;
+            ~backend
+            ~filename:i.source_file
+            ~prefixname:i.output_prefix
+            ~middle_end:Closure_middle_end.lambda_to_clambda
+            ~ppf_dump:i.ppf_dump;
        Compilenv.save_unit_info (cmx i))
 
 let implementation ~backend ~source_file ~output_prefix =

middle_end/clambda.ml

@@ -136,6 +136,9 @@ type preallocated_constant = {
   provenance : usymbol_provenance option;
 }
 
+type with_constants =
+  ulambda * preallocated_block list * preallocated_constant list
+
 (* Comparison functions for constants.  We must not use Stdlib.compare
    because it compares "0.0" and "-0.0" equal.  (PR#6442) *)
 

middle_end/clambda.mli

@@ -151,3 +151,6 @@ type preallocated_constant = {
   definition : ustructured_constant;
   provenance : usymbol_provenance option;
 }
+
+type with_constants =
+  ulambda * preallocated_block list * preallocated_constant list

middle_end/closure/closure_middle_end.ml

@@ -0,0 +1,58 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-30-40-41-42"]
+
+let raw_clambda_dump_if ppf
+      ((ulambda, _, structured_constants) : Clambda.with_constants) =
+  if !Clflags.dump_rawclambda || !Clflags.dump_clambda then
+    begin
+      Format.fprintf ppf "@.clambda:@.";
+      Printclambda.clambda ppf ulambda;
+      List.iter (fun { Clambda. symbol; definition; _ } ->
+          Format.fprintf ppf "%s:@ %a@."
+            symbol
+            Printclambda.structured_constant definition)
+        structured_constants
+    end;
+  if !Clflags.dump_cmm then Format.fprintf ppf "@.cmm:@."
+
+let lambda_to_clambda ~backend ~filename:_ ~prefixname:_ ~ppf_dump
+      (lambda : Lambda.program) =
+  let clambda =
+    Closure.intro ~backend ~size:lambda.main_module_block_size lambda.code
+  in
+  let provenance : Clambda.usymbol_provenance =
+    { original_idents = [];
+      module_path =
+        Path.Pident (Ident.create_persistent (Compilenv.current_unit_name ()));
+    }
+  in
+  let preallocated_block =
+    Clambda.{
+      symbol = Compilenv.make_symbol None;
+      exported = true;
+      tag = 0;
+      fields = List.init lambda.main_module_block_size (fun _ -> None);
+      provenance = Some provenance;
+    }
+  in
+  let constants = Compilenv.structured_constants () in
+  Compilenv.clear_structured_constants ();
+  let clambda_and_constants =
+    clambda, [preallocated_block], constants
+  in
+  raw_clambda_dump_if ppf_dump clambda_and_constants;
+  clambda_and_constants

middle_end/closure/closure_middle_end.mli

@@ -0,0 +1,22 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+val lambda_to_clambda
+   : backend:(module Backend_intf.S)
+  -> filename:string
+  -> prefixname:string
+  -> ppf_dump:Format.formatter
+  -> Lambda.program
+  -> Clambda.with_constants

middle_end/flambda/flambda_middle_end.ml

@@ -6,7 +6,7 @@
 (*           Mark Shinwell and Leo White, Jane Street Europe              *)
 (*                                                                        *)
 (*   Copyright 2013--2016 OCamlPro SAS                                    *)
-(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*   Copyright 2014--2019 Jane Street Group LLC                           *)
 (*                                                                        *)
 (*   All rights reserved.  This file is distributed under the terms of    *)
 (*   the GNU Lesser General Public License version 2.1, with the          *)
@@ -14,7 +14,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-[@@@ocaml.warning "+a-4-9-30-40-41-42-66"]
+[@@@ocaml.warning "+a-4-30-40-41-42-66"]
 open! Int_replace_polymorphic_compare
 
 let _dump_function_sizes flam ~backend =
@@ -31,11 +31,8 @@ let _dump_function_sizes flam ~backend =
           | None -> assert false)
         set_of_closures.function_decls.funs)
 
-let middle_end ~ppf_dump ~prefixname ~backend
+let lambda_to_flambda ~ppf_dump ~prefixname ~backend ~size ~filename
-    ~size
+      ~module_ident ~module_initializer =
-    ~filename
-    ~module_ident
-    ~module_initializer =
   Profile.record_call "flambda" (fun () ->
     let previous_warning_reporter = !Location.warning_reporter in
     let module WarningSet =
@@ -198,3 +195,54 @@ let middle_end ~ppf_dump ~prefixname ~backend
            (* dump_function_sizes flam ~backend; *)
            flam))
       )
+
+let flambda_raw_clambda_dump_if ppf
+      ({ Flambda_to_clambda. expr = ulambda; preallocated_blocks = _;
+        structured_constants; exported = _; } as input) =
+  if !Clflags.dump_rawclambda then
+    begin
+      Format.fprintf ppf "@.clambda (before Un_anf):@.";
+      Printclambda.clambda ppf ulambda;
+      Symbol.Map.iter (fun sym cst ->
+          Format.fprintf ppf "%a:@ %a@."
+            Symbol.print sym
+            Printclambda.structured_constant cst)
+        structured_constants
+    end;
+  if !Clflags.dump_cmm then Format.fprintf ppf "@.cmm:@.";
+  input
+
+let lambda_to_clambda ~backend ~filename ~prefixname ~ppf_dump
+      (program : Lambda.program) =
+  let program =
+    lambda_to_flambda ~ppf_dump ~prefixname ~backend
+      ~size:program.main_module_block_size
+      ~filename
+      ~module_ident:program.module_ident
+      ~module_initializer:program.code
+  in
+  let export = Build_export_info.build_transient ~backend program in
+  let clambda, preallocated_blocks, constants =
+    Profile.record_call "backend" (fun () ->
+      (program, export)
+      |> Flambda_to_clambda.convert ~ppf_dump
+      |> flambda_raw_clambda_dump_if ppf_dump
+      |> (fun { Flambda_to_clambda. expr; preallocated_blocks;
+                structured_constants; exported; } ->
+           Compilenv.set_export_info exported;
+           let clambda =
+             Un_anf.apply ~what:(Compilenv.current_unit_symbol ())
+               ~ppf_dump expr
+           in
+           clambda, preallocated_blocks, structured_constants))
+  in
+  let constants =
+    List.map (fun (symbol, definition) ->
+        { Clambda.symbol = Linkage_name.to_string (Symbol.label symbol);
+          exported = true;
+          definition;
+          provenance = None;
+        })
+      (Symbol.Map.bindings constants)
+  in
+  clambda, preallocated_blocks, constants

middle_end/flambda/flambda_middle_end.mli

@@ -16,14 +16,12 @@
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
 
-(* Translate Lambda code to Flambda code and then optimize it. *)
+(** Translate Lambda code to Flambda code, optimize it, and produce Clambda. *)
 
-val middle_end
+val lambda_to_clambda
-   : ppf_dump:Format.formatter
+   : backend:(module Backend_intf.S)
-  -> prefixname:string
-  -> backend:(module Backend_intf.S)
-  -> size:int
   -> filename:string
-  -> module_ident:Ident.t
+  -> prefixname:string
-  -> module_initializer:Lambda.lambda
+  -> ppf_dump:Format.formatter
-  -> Flambda.program
+  -> Lambda.program
+  -> Clambda.with_constants

middle_end/flambda/flambda_to_clambda.ml

@@ -31,6 +31,9 @@ type t = {
     Set_of_closures_id.t for_one_or_more_units;
   imported_units :
     Simple_value_approx.function_declarations for_one_or_more_units;
+  ppf_dump : Format.formatter;
+  mutable constants_for_instrumentation :
+    Clambda.ustructured_constant Symbol.Map.t;
 }
 
 let get_fun_offset t closure_id =
@@ -70,7 +73,7 @@ let is_function_constant t closure_id =
 (* Instrumentation of closure and field accesses to try to catch compiler
    bugs. *)
 
-let check_closure ulam named : Clambda.ulambda =
+let check_closure t ulam named : Clambda.ulambda =
   if not !Clflags.clambda_checks then ulam
   else
     let desc =
@@ -78,14 +81,19 @@ let check_closure ulam named : Clambda.ulambda =
         ~arity:2 ~alloc:false
     in
     let str = Format.asprintf "%a" Flambda.print_named named in
-    let str_const =
+    let sym = Compilenv.new_const_symbol () in
-      Compilenv.new_structured_constant (Uconst_string str) ~shared:true
+    let sym' =
+      Symbol.of_global_linkage (Compilation_unit.get_current_exn ())
+        (Linkage_name.create sym)
     in
+    t.constants_for_instrumentation <-
+      Symbol.Map.add sym' (Clambda.Uconst_string str)
+        t.constants_for_instrumentation;
     Uprim (Pccall desc,
-           [ulam; Clambda.Uconst (Uconst_ref (str_const, None))],
+           [ulam; Clambda.Uconst (Uconst_ref (sym, None))],
            Debuginfo.none)
 
-let check_field ulam pos named_opt : Clambda.ulambda =
+let check_field t ulam pos named_opt : Clambda.ulambda =
   if not !Clflags.clambda_checks then ulam
   else
     let desc =
@@ -97,11 +105,16 @@ let check_field ulam pos named_opt : Clambda.ulambda =
       | None -> "<none>"
       | Some named -> Format.asprintf "%a" Flambda.print_named named
     in
-    let str_const =
+    let sym = Compilenv.new_const_symbol () in
-      Compilenv.new_structured_constant (Uconst_string str) ~shared:true
+    let sym' =
+      Symbol.of_global_linkage (Compilation_unit.get_current_exn ())
+        (Linkage_name.create sym)
     in
+    t.constants_for_instrumentation <-
+      Symbol.Map.add sym' (Clambda.Uconst_string str)
+        t.constants_for_instrumentation;
     Uprim (Pccall desc, [ulam; Clambda.Uconst (Uconst_int pos);
-        Clambda.Uconst (Uconst_ref (str_const, None))],
+        Clambda.Uconst (Uconst_ref (sym, None))],
       Debuginfo.none)
 
 module Env : sig
@@ -258,7 +271,7 @@ let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda =
     to_clambda_direct_apply t func args direct_func dbg env
   | Apply { func; args; kind = Indirect; dbg = dbg } ->
     let callee = subst_var env func in
-    Ugeneric_apply (check_closure callee (Flambda.Expr (Var func)),
+    Ugeneric_apply (check_closure t callee (Flambda.Expr (Var func)),
       subst_vars env args, dbg)
   | Switch (arg, sw) ->
     let aux () : Clambda.ulambda =
@@ -368,15 +381,15 @@ and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda =
        a [Uoffset] construction in the event that the offset is zero, otherwise
        we might break pattern matches in Cmmgen (in particular for the
        compilation of "let rec"). *)
-    check_closure (
+    check_closure t (
       build_uoffset
-        (check_closure (subst_var env set_of_closures)
+        (check_closure t (subst_var env set_of_closures)
            (Flambda.Expr (Var set_of_closures)))
         (get_fun_offset t closure_id))
       named
   | Move_within_set_of_closures { closure; start_from; move_to } ->
-    check_closure (build_uoffset
+    check_closure t (build_uoffset
-      (check_closure (subst_var env closure)
+      (check_closure t (subst_var env closure)
          (Flambda.Expr (Var closure)))
       ((get_fun_offset t move_to) - (get_fun_offset t start_from)))
       named
@@ -386,13 +399,14 @@ and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda =
     let var_offset = get_fv_offset t var in
     let pos = var_offset - fun_offset in
     Uprim (Pfield pos,
-      [check_field (check_closure ulam (Expr (Var closure))) pos (Some named)],
+      [check_field t (check_closure t ulam (Expr (Var closure)))
+         pos (Some named)],
       Debuginfo.none)
   | Prim (Pfield index, [block], dbg) ->
-    Uprim (Pfield index, [check_field (subst_var env block) index None], dbg)
+    Uprim (Pfield index, [check_field t (subst_var env block) index None], dbg)
   | Prim (Psetfield (index, maybe_ptr, init), [block; new_value], dbg) ->
     Uprim (Psetfield (index, maybe_ptr, init), [
-        check_field (subst_var env block) index None;
+        check_field t (subst_var env block) index None;
         subst_var env new_value;
       ], dbg)
   | Prim (Popaque, args, dbg) ->
@@ -569,11 +583,15 @@ and to_clambda_closed_set_of_closures t env symbol
           env, id :: params)
         function_decl.params (env, [])
     in
+    let body =
+      Un_anf.apply ~ppf_dump:t.ppf_dump ~what:symbol
+        (to_clambda t env_body function_decl.body)
+    in
     { label = Compilenv.function_label (Closure_id.wrap id);
       arity = Flambda_utils.function_arity function_decl;
       params = List.map (fun var -> VP.create var, Lambda.Pgenval) params;
       return = Lambda.Pgenval;
-      body = to_clambda t env_body function_decl.body;
+      body;
       dbg = function_decl.dbg;
       env = None;
     }
@@ -698,7 +716,7 @@ type result = {
   exported : Export_info.t;
 }
 
-let convert (program, exported_transient) : result =
+let convert ~ppf_dump (program, exported_transient) : result =
   let current_unit =
     let closures =
       Closure_id.Map.keys (Flambda_utils.make_closure_map program)
@@ -733,10 +751,20 @@ let convert (program, exported_transient) : result =
       closures;
     }
   in
-  let t = { current_unit; imported_units; } in
+  let t =
+    { current_unit;
+      imported_units;
+      constants_for_instrumentation = Symbol.Map.empty;
+      ppf_dump;
+    }
+  in
   let expr, structured_constants, preallocated_blocks =
     to_clambda_program t Env.empty Symbol.Map.empty program
   in
+  let structured_constants =
+    Symbol.Map.disjoint_union structured_constants
+      t.constants_for_instrumentation
+  in
   let exported =
     Export_info.t_of_transient exported_transient
       ~program

middle_end/flambda/flambda_to_clambda.mli

@@ -35,4 +35,7 @@ type result = {
     For direct calls, the hidden closure parameter is added.  Switch
     tables are also built.
 *)
-val convert : Flambda.program * Export_info.transient -> result
+val convert
+   : ppf_dump:Format.formatter
+  -> Flambda.program * Export_info.transient
+  -> result

middle_end/flambda/un_anf.ml

@@ -799,7 +799,7 @@ and un_anf_list var_info env clams : Clambda.ulambda list =
 and un_anf_array var_info env clams : Clambda.ulambda array =
   Array.map (un_anf var_info env) clams
 
-let apply ~ppf_dump clam ~what =
+let apply ~what ~ppf_dump clam =
   let var_info = make_var_info clam in
   let let_bound_vars_that_can_be_moved =
     let_bound_vars_that_can_be_moved var_info clam
@@ -812,6 +812,8 @@ let apply ~ppf_dump clam ~what =
   let clam = un_anf var_info V.Map.empty clam in
   if !Clflags.dump_clambda then begin
     Format.fprintf ppf_dump
-      "@.un-anf (%s):@ %a@." what Printclambda.clambda clam
+      "@.un-anf (%a):@ %a@."
+        Symbol.print what
+        Printclambda.clambda clam
   end;
   clam

middle_end/flambda/un_anf.mli

@@ -17,7 +17,7 @@
 (** Expand ANF-like constructs so that pattern matches in [Cmmgen] will
     work correctly. *)
 val apply
-  : ppf_dump:Format.formatter
+   : what:Symbol.t
+  -> ppf_dump:Format.formatter
   -> Clambda.ulambda
-  -> what:string
   -> Clambda.ulambda

toplevel/opttoploop.ml

@@ -248,19 +248,24 @@ let load_lambda ppf ~module_ident ~required_globals lam size =
     if !Clflags.keep_asm_file then !phrase_name ^ ext_dll
     else Filename.temp_file ("caml" ^ !phrase_name) ext_dll
   in
-  let fn = Filename.chop_extension dll in
+  let filename = Filename.chop_extension dll in
-  if not Config.flambda then
+  let program =
-    Asmgen.compile_implementation_clambda
+    { Lambda.
-      ~toplevel:need_symbol fn ~backend ~ppf_dump:ppf
+      code = slam;
-      { Lambda.code=slam ; main_module_block_size=size;
+      main_module_block_size = size;
-        module_ident; required_globals }
+      module_ident;
-  else
+      required_globals;
-    Asmgen.compile_implementation_flambda
+    }
-      ~required_globals ~backend ~toplevel:need_symbol fn ~ppf_dump:ppf
+  in
-      (Flambda_middle_end.middle_end ~ppf_dump:ppf ~prefixname:"" ~backend ~size
+  let middle_end =
-         ~module_ident ~module_initializer:slam ~filename:"toplevel");
+    if Config.flambda then Flambda_middle_end.lambda_to_clambda
-  Asmlink.call_linker_shared [fn ^ ext_obj] dll;
+    else Closure_middle_end.lambda_to_clambda
-  Sys.remove (fn ^ ext_obj);
+  in
+  Asmgen.compile_implementation ~toplevel:need_symbol
+    ~backend ~filename ~prefixname:""
+    ~middle_end ~ppf_dump:ppf program;
+  Asmlink.call_linker_shared [filename ^ ext_obj] dll;
+  Sys.remove (filename ^ ext_obj);
 
   let dll =
     if Filename.is_implicit dll

typing/primitive.ml

@@ -200,6 +200,9 @@ let native_name p =
 let byte_name p =
   p.prim_name
 
+let native_name_is_external p =
+  p.prim_native_name <> "" && p.prim_native_name.[0] <> '%'
+
 let report_error ppf err =
   match err with
   | Old_style_float_with_native_repr_attribute ->

typing/primitive.mli

@@ -63,6 +63,11 @@ val print
 val native_name: description -> string
 val byte_name: description -> string
 
+(** [native_name_is_externa] returns [true] iff the [native_name] for the
+    given primitive identifies that the primitive is not implemented in the
+    compiler itself. *)
+val native_name_is_external : description -> bool
+
 type error =
   | Old_style_float_with_native_repr_attribute
   | Old_style_noalloc_with_noalloc_attribute