flambda-backend: Compile refactor (#1096)

Author: lukemaurer

asmcomp/asmpackager.ml

@@ -111,36 +111,26 @@ let make_package_object ~ppf_dump members targetobj targetname coercion
     let compilation_unit = CU.create for_pack_prefix modname in
     let prefixname = Filename.remove_extension objtemp in
     let required_globals = CU.Set.empty in
-    let program, middle_end =
-      if Config.flambda then
-        let main_module_block_size, code =
-          Translmod.transl_package_flambda components coercion
-        in
-        let code = Simplif.simplify_lambda code in
-        let program =
-          { Lambda.
-            code;
-            main_module_block_size;
-            compilation_unit;
-            required_globals;
-          }
-        in
-        program, Flambda_middle_end.lambda_to_clambda
-      else
-        let main_module_block_size, code =
-          Translmod.transl_store_package components
-            compilation_unit coercion
-        in
-        let code = Simplif.simplify_lambda code in
-        let program =
-          { Lambda.
-            code;
-            main_module_block_size;
-            compilation_unit;
-            required_globals;
-          }
-        in
-        program, Closure_middle_end.lambda_to_clambda
+    let transl_style : Translmod.compilation_unit_style =
+      if Config.flambda || Config.flambda2 then Plain_block
+      else Set_individual_fields
+    in
+    let main_module_block_size, code =
+      Translmod.transl_package components compilation_unit coercion
+        ~style:transl_style
+    in
+    let code = Simplif.simplify_lambda code in
+    let program =
+      { Lambda.
+        code;
+        main_module_block_size;
+        compilation_unit;
+        required_globals;
+      }
+    in
+    let middle_end =
+      if Config.flambda then Flambda_middle_end.lambda_to_clambda
+      else Closure_middle_end.lambda_to_clambda
     in
     Asmgen.compile_implementation ~backend
       ~prefixname

bytecomp/bytepackager.ml

@@ -161,7 +161,10 @@ let build_global_target ~ppf_dump oc target_name members pos coercion =
         | PM_intf -> None
         | PM_impl _ -> Some (m.pm_name |> unit_of_name))
       members in
-  let lam = Translmod.transl_package components compilation_unit coercion in
+  let _size, lam =
+    Translmod.transl_package components compilation_unit coercion
+      ~style:Set_global_to_block
+  in
   if !Clflags.dump_rawlambda then
     Format.fprintf ppf_dump "%a@." Printlambda.lambda lam;
   let lam = Simplif.simplify_lambda lam in

driver/compile.ml

@@ -33,7 +33,7 @@ let interface ~source_file ~output_prefix =
 let to_bytecode i Typedtree.{structure; coercion; _} =
   (structure, coercion)
   |> Profile.(record transl)
-    (Translmod.transl_implementation i.module_name)
+    (Translmod.transl_implementation i.module_name ~style:Set_global_to_block)
   |> Profile.(record ~accumulate:true generate)
     (fun { Lambda.code = lambda; required_globals } ->
        lambda

driver/optcompile.ml

@@ -30,43 +30,13 @@ let interface ~source_file ~output_prefix =
     ~hook_typed_tree:(fun _ -> ())
     info
 
-let (|>>) (x, y) f = (x, f y)
-
 (** Native compilation backend for .ml files. *)
 
-let flambda i backend Typedtree.{structure; coercion; _} =
+let compile i ~backend ~middle_end ~transl_style
+      Typedtree.{structure; coercion; _} =
   (structure, coercion)
   |> Profile.(record transl)
-      (Translmod.transl_implementation_flambda i.module_name)
-  |> Profile.(record generate)
-    (fun {Lambda.compilation_unit; main_module_block_size;
-          required_globals; code } ->
-    ((compilation_unit, main_module_block_size), code)
-    |>> print_if i.ppf_dump Clflags.dump_rawlambda Printlambda.lambda
-    |>> Simplif.simplify_lambda
-    |>> print_if i.ppf_dump Clflags.dump_lambda Printlambda.lambda
-    |> (fun ((compilation_unit, main_module_block_size), code) ->
-      let program : Lambda.program =
-        { Lambda.
-          compilation_unit;
-          main_module_block_size;
-          required_globals;
-          code;
-        }
-      in
-      Asmgen.compile_implementation
-        ~backend
-        ~prefixname:i.output_prefix
-        ~middle_end:Flambda_middle_end.lambda_to_clambda
-        ~ppf_dump:i.ppf_dump
-        program);
-    Compilenv.save_unit_info (cmx i))
-
-let clambda i backend Typedtree.{structure; coercion; _} =
-  Clflags.set_oclassic ();
-  (structure, coercion)
-  |> Profile.(record transl)
-    (Translmod.transl_store_implementation i.module_name)
+    (Translmod.transl_implementation i.module_name ~style:transl_style)
   |> print_if i.ppf_dump Clflags.dump_rawlambda Printlambda.program
   |> Profile.(record generate)
     (fun program ->
@@ -76,10 +46,19 @@ let clambda i backend Typedtree.{structure; coercion; _} =
        |> Asmgen.compile_implementation
             ~backend
             ~prefixname:i.output_prefix
-            ~middle_end:Closure_middle_end.lambda_to_clambda
+            ~middle_end
             ~ppf_dump:i.ppf_dump;
        Compilenv.save_unit_info (cmx i))
 
+let flambda i backend typed =
+  compile i typed ~backend ~transl_style:Plain_block
+    ~middle_end:Flambda_middle_end.lambda_to_clambda
+
+let clambda i backend typed =
+  Clflags.set_oclassic ();
+  compile i typed ~backend ~transl_style:Set_individual_fields
+    ~middle_end:Closure_middle_end.lambda_to_clambda
+
 (* Emit assembly directly from Linear IR *)
 let emit i =
   Compilenv.reset i.module_name;

lambda/translmod.ml

@@ -910,7 +910,12 @@ let required_globals ~flambda body =
 
 (* Compile an implementation *)
 
-let transl_implementation_flambda compilation_unit (str, cc) =
+type compilation_unit_style =
+  | Plain_block
+  | Set_global_to_block
+  | Set_individual_fields
+
+let transl_implementation_plain_block compilation_unit (str, cc) =
   reset_labels ();
   primitive_declarations := [];
   Translprim.clear_used_primitives ();
@@ -928,9 +933,9 @@ let transl_implementation_flambda compilation_unit (str, cc) =
     required_globals = required_globals ~flambda:true body;
     code = body }
 
-let transl_implementation module_name (str, cc) =
+let transl_implementation_set_global module_name (str, cc) =
   let implementation =
-    transl_implementation_flambda module_name (str, cc)
+    transl_implementation_plain_block module_name (str, cc)
   in
   let code =
     Lprim (Psetglobal implementation.compilation_unit, [implementation.code],
@@ -1522,7 +1527,7 @@ let transl_store_phrases module_name str =
   in
   transl_store_gen ~scopes module_name (str,Tcoerce_none) true
 
-let transl_store_implementation compilation_unit (str, restr) =
+let transl_implementation_set_fields compilation_unit (str, restr) =
   let s = !transl_store_subst in
   transl_store_subst := Ident.Map.empty;
   let scopes = enter_compilation_unit ~scopes:empty_scopes compilation_unit in
@@ -1535,6 +1540,12 @@ let transl_store_implementation compilation_unit (str, restr) =
     compilation_unit;
     required_globals = required_globals ~flambda:true code }
 
+let transl_implementation compilation_unit impl ~style =
+  match style with
+  | Plain_block -> transl_implementation_plain_block compilation_unit impl
+  | Set_global_to_block -> transl_implementation_set_global compilation_unit impl
+  | Set_individual_fields -> transl_implementation_set_fields compilation_unit impl
+
 (* Compile a toplevel phrase *)
 
 let toploop_unit = Compilation_unit.of_string "Toploop"
@@ -1736,7 +1747,7 @@ let get_component = function
     None -> Lconst const_unit
   | Some id -> Lprim(Pgetglobal id, [], Loc_unknown)
 
-let transl_package_flambda component_names coercion =
+let transl_package_plain_block component_names coercion =
   let size =
     match coercion with
     | Tcoerce_none -> List.length component_names
@@ -1751,13 +1762,9 @@ let transl_package_flambda component_names coercion =
            List.map get_component component_names,
            Loc_unknown))
 
-let transl_package component_names target_name coercion =
-  let components =
-    Lprim(Pmakeblock(0, Immutable, None, alloc_heap),
-          List.map get_component component_names, Loc_unknown) in
-  Lprim(Psetglobal target_name,
-        [apply_coercion Loc_unknown Strict coercion components],
-        Loc_unknown)
+let transl_package_set_global component_names target_name coercion =
+  let size, block = transl_package_plain_block component_names coercion in
+  size, Lprim(Psetglobal target_name, [block], Loc_unknown)
   (*
   let components =
     match coercion with
@@ -1774,7 +1781,7 @@ let transl_package component_names target_name coercion =
   Lprim(Psetglobal target_name, [Lprim(Pmakeblock(0, Immutable), components)])
    *)
 
-let transl_store_package component_names target_name coercion =
+let transl_package_set_fields component_names target_name coercion =
   let rec make_sequence fn pos arg =
     match arg with
       [] -> lambda_unit
@@ -1819,6 +1826,15 @@ let transl_store_package component_names target_name coercion =
   *)
   | _ -> assert false
 
+let transl_package component_names target_name coercion ~style =
+  match style with
+  | Plain_block ->
+      transl_package_plain_block component_names coercion
+  | Set_global_to_block ->
+      transl_package_set_global component_names target_name coercion
+  | Set_individual_fields ->
+      transl_package_set_fields component_names target_name coercion
+
 (* Error report *)
 
 open Format

lambda/translmod.mli

@@ -19,25 +19,21 @@
 open Typedtree
 open Lambda
 
+type compilation_unit_style =
+  | Plain_block (* Flambda *)
+  | Set_global_to_block (* Bytecode *)
+  | Set_individual_fields (* Closure *)
+
 val transl_implementation:
-      Compilation_unit.t -> structure * module_coercion -> Lambda.program
+      Compilation_unit.t -> structure * module_coercion
+        -> style:compilation_unit_style -> Lambda.program
 val transl_store_phrases: Compilation_unit.t -> structure -> int * lambda
-val transl_store_implementation:
-      Compilation_unit.t -> structure * module_coercion -> Lambda.program
-
-val transl_implementation_flambda:
-  Compilation_unit.t -> structure * module_coercion -> Lambda.program
 
 val transl_toplevel_definition: structure -> lambda
+
 val transl_package:
       Compilation_unit.t option list -> Compilation_unit.t -> module_coercion
-        -> lambda
-val transl_store_package:
-      Compilation_unit.t option list -> Compilation_unit.t -> module_coercion
-        -> int * lambda
-
-val transl_package_flambda:
-      Compilation_unit.t option list -> module_coercion -> int * lambda
+        -> style:compilation_unit_style -> int * lambda
 
 val toplevel_name: Ident.t -> string
 val nat_toplevel_name: Ident.t -> Compilation_unit.t * int

toplevel/native/topeval.ml

@@ -207,8 +207,8 @@ let execute_phrase print_outcome ppf phr =
         if Config.flambda then
           let { Lambda.compilation_unit; main_module_block_size = size;
                 required_globals; code = res } =
-            Translmod.transl_implementation_flambda phrase_comp_unit
-              (str, Tcoerce_none)
+            Translmod.transl_implementation phrase_comp_unit (str, Tcoerce_none)
+              ~style:Plain_block
           in
           remember compilation_unit 0 sg';
           compilation_unit, close_phrase res, required_globals, size