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

Followup to (#2281)

10 files changed, 205 insertions, 40 deletions

diff --git a/middle_end/clambda.ml b/middle_end/clambda.ml
index 406bfbccda..59402629fc 100644
--- a/middle_end/clambda.ml
+++ b/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) *)
 
diff --git a/middle_end/clambda.mli b/middle_end/clambda.mli
index ddd0956dee..9d74eb6655 100644
--- a/middle_end/clambda.mli
+++ b/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
diff --git a/middle_end/closure/closure_middle_end.ml b/middle_end/closure/closure_middle_end.ml
new file mode 100644
index 0000000000..cb593eb0ed
--- /dev/null
+++ b/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
diff --git a/middle_end/closure/closure_middle_end.mli b/middle_end/closure/closure_middle_end.mli
new file mode 100644
index 0000000000..e0ebb1decf
--- /dev/null
+++ b/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
diff --git a/middle_end/flambda/flambda_middle_end.ml b/middle_end/flambda/flambda_middle_end.ml
index e604a3285b..6330ff12d2 100644
--- a/middle_end/flambda/flambda_middle_end.ml
+++ b/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
-    ~size
-    ~filename
-    ~module_ident
-    ~module_initializer =
+let lambda_to_flambda ~ppf_dump ~prefixname ~backend ~size ~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
diff --git a/middle_end/flambda/flambda_middle_end.mli b/middle_end/flambda/flambda_middle_end.mli
index 584cb45a98..e7bb7478b5 100644
--- a/middle_end/flambda/flambda_middle_end.mli
+++ b/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
-   : ppf_dump:Format.formatter
-  -> prefixname:string
-  -> backend:(module Backend_intf.S)
-  -> size:int
+val lambda_to_clambda
+   : backend:(module Backend_intf.S)
   -> filename:string
-  -> module_ident:Ident.t
-  -> module_initializer:Lambda.lambda
-  -> Flambda.program
+  -> prefixname:string
+  -> ppf_dump:Format.formatter
+  -> Lambda.program
+  -> Clambda.with_constants
diff --git a/middle_end/flambda/flambda_to_clambda.ml b/middle_end/flambda/flambda_to_clambda.ml
index 2f60f9fcfc..9d6ea1518f 100644
--- a/middle_end/flambda/flambda_to_clambda.ml
+++ b/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 =
-      Compilenv.new_structured_constant (Uconst_string str) ~shared:true
+    let sym = Compilenv.new_const_symbol () in
+    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 =
-      Compilenv.new_structured_constant (Uconst_string str) ~shared:true
+    let sym = Compilenv.new_const_symbol () in
+    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 (subst_var env closure)
+    check_closure t (build_uoffset
+      (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
diff --git a/middle_end/flambda/flambda_to_clambda.mli b/middle_end/flambda/flambda_to_clambda.mli
index 8c493d40d6..d08af3e2ba 100644
--- a/middle_end/flambda/flambda_to_clambda.mli
+++ b/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
diff --git a/middle_end/flambda/un_anf.ml b/middle_end/flambda/un_anf.ml
index 50f9e7b1e2..19b04d85a4 100644
--- a/middle_end/flambda/un_anf.ml
+++ b/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
diff --git a/middle_end/flambda/un_anf.mli b/middle_end/flambda/un_anf.mli
index 92ea06cd03..a7d5e94e84 100644
--- a/middle_end/flambda/un_anf.mli
+++ b/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