1(**************************************************************************)
2(*                                                                        *)
3(*                                 OCaml                                  *)
4(*                                                                        *)
5(*                       Pierre Chambart, OCamlPro                        *)
6(*           Mark Shinwell and Leo White, Jane Street Europe              *)
7(*                                                                        *)
8(*   Copyright 2013--2016 OCamlPro SAS                                    *)
9(*   Copyright 2014--2016 Jane Street Group LLC                           *)
10(*                                                                        *)
11(*   All rights reserved.  This file is distributed under the terms of    *)
12(*   the GNU Lesser General Public License version 2.1, with the          *)
13(*   special exception on linking described in the file LICENSE.          *)
14(*                                                                        *)
15(**************************************************************************)
16
17[@@@ocaml.warning "+a-4-9-30-40-41-42"]
18
19let _dump_function_sizes flam ~backend =
20  let module Backend = (val backend : Backend_intf.S) in
21  let than = max_int in
22  Flambda_iterators.iter_on_set_of_closures_of_program flam
23    ~f:(fun ~constant:_ (set_of_closures : Flambda.set_of_closures) ->
24      Variable.Map.iter (fun fun_var
25            (function_decl : Flambda.function_declaration) ->
26          let closure_id = Closure_id.wrap fun_var in
27          let symbol = Backend.closure_symbol closure_id in
28          match Inlining_cost.lambda_smaller' function_decl.body ~than with
29          | Some size -> Format.eprintf "%a %d\n" Symbol.print symbol size
30          | None -> assert false)
31        set_of_closures.function_decls.funs)
32
33let middle_end ppf ~source_provenance ~prefixname ~backend
34    ~size
35    ~filename
36    ~module_ident
37    ~module_initializer =
38  let pass_number = ref 0 in
39  let round_number = ref 0 in
40  let check flam =
41    if !Clflags.flambda_invariant_checks then begin
42      try Flambda_invariants.check_exn flam
43      with exn ->
44        Misc.fatal_errorf "After Flambda pass %d, round %d:@.%s:@.%a"
45          !pass_number !round_number (Printexc.to_string exn)
46          Flambda.print_program flam
47    end
48  in
49  let (+-+) flam (name, pass) =
50    incr pass_number;
51    if !Clflags.dump_flambda_verbose then begin
52      Format.fprintf ppf "@.PASS: %s@." name;
53      Format.fprintf ppf "Before pass %d, round %d:@ %a@." !pass_number
54        !round_number Flambda.print_program flam;
55      Format.eprintf "\n@?"
56    end;
57    let timing_pass = (Timings.Flambda_pass (name, source_provenance)) in
58    let flam = Timings.accumulate_time timing_pass pass flam in
59    if !Clflags.flambda_invariant_checks then begin
60      Timings.accumulate_time (Flambda_pass ("check", source_provenance))
61        check flam
62    end;
63    flam
64  in
65  Timings.accumulate_time
66    (Flambda_pass ("middle_end", source_provenance)) (fun () ->
67    let flam =
68      let timing_pass =
69        Timings.Flambda_pass ("closure_conversion", source_provenance)
70      in
71      Timings.accumulate_time timing_pass (fun () ->
72          module_initializer
73          |> Closure_conversion.lambda_to_flambda ~backend ~module_ident
74                ~size ~filename)
75        ()
76    in
77    if !Clflags.dump_rawflambda
78    then
79      Format.fprintf ppf "After closure conversion:@ %a@."
80        Flambda.print_program flam;
81    check flam;
82    let fast_mode flam =
83      pass_number := 0;
84      let round = 0 in
85      flam
86      +-+ ("lift_lets 1", Lift_code.lift_lets)
87      +-+ ("Lift_constants", Lift_constants.lift_constants ~backend)
88      +-+ ("Share_constants", Share_constants.share_constants)
89      +-+ ("Lift_let_to_initialize_symbol",
90           Lift_let_to_initialize_symbol.lift ~backend)
91      +-+ ("Inline_and_simplify",
92           Inline_and_simplify.run ~never_inline:false ~backend
93             ~prefixname ~round)
94      +-+ ("Remove_unused_closure_vars 2",
95           Remove_unused_closure_vars.remove_unused_closure_variables
96             ~remove_direct_call_surrogates:false)
97      +-+ ("Ref_to_variables",
98           Ref_to_variables.eliminate_ref)
99      +-+ ("Initialize_symbol_to_let_symbol",
100           Initialize_symbol_to_let_symbol.run)
101    in
102    let rec loop flam =
103      pass_number := 0;
104      let round = !round_number in
105      incr round_number;
106      if !round_number > (Clflags.rounds ()) then flam
107      else
108        flam
109        (* Beware: [Lift_constants] must be run before any pass that might
110           duplicate strings. *)
111        +-+ ("lift_lets 1", Lift_code.lift_lets)
112        +-+ ("Lift_constants", Lift_constants.lift_constants ~backend)
113        +-+ ("Share_constants", Share_constants.share_constants)
114        +-+ ("Remove_unused_program_constructs",
115             Remove_unused_program_constructs.remove_unused_program_constructs)
116        +-+ ("Lift_let_to_initialize_symbol",
117             Lift_let_to_initialize_symbol.lift ~backend)
118        +-+ ("lift_lets 2", Lift_code.lift_lets)
119        +-+ ("Remove_unused_closure_vars 1",
120             Remove_unused_closure_vars.remove_unused_closure_variables
121              ~remove_direct_call_surrogates:false)
122        +-+ ("Inline_and_simplify",
123             Inline_and_simplify.run ~never_inline:false ~backend
124               ~prefixname ~round)
125        +-+ ("Remove_unused_closure_vars 2",
126             Remove_unused_closure_vars.remove_unused_closure_variables
127              ~remove_direct_call_surrogates:false)
128        +-+ ("lift_lets 3", Lift_code.lift_lets)
129        +-+ ("Inline_and_simplify noinline",
130             Inline_and_simplify.run ~never_inline:true ~backend
131              ~prefixname ~round)
132        +-+ ("Remove_unused_closure_vars 3",
133             Remove_unused_closure_vars.remove_unused_closure_variables
134              ~remove_direct_call_surrogates:false)
135        +-+ ("Ref_to_variables",
136             Ref_to_variables.eliminate_ref)
137        +-+ ("Initialize_symbol_to_let_symbol",
138             Initialize_symbol_to_let_symbol.run)
139        |> loop
140    in
141    let back_end flam =
142      flam
143      +-+ ("Remove_unused_closure_vars",
144           Remove_unused_closure_vars.remove_unused_closure_variables
145             ~remove_direct_call_surrogates:true)
146      +-+ ("Lift_constants", Lift_constants.lift_constants ~backend)
147      +-+ ("Share_constants", Share_constants.share_constants)
148      +-+ ("Remove_unused_program_constructs",
149        Remove_unused_program_constructs.remove_unused_program_constructs)
150    in
151    let flam =
152      if !Clflags.classic_inlining then
153        fast_mode flam
154      else
155        loop flam
156    in
157    let flam = back_end flam in
158    (* Check that there aren't any unused "always inline" attributes. *)
159    Flambda_iterators.iter_apply_on_program flam ~f:(fun apply ->
160        match apply.inline with
161        | Default_inline | Never_inline -> ()
162        | Always_inline ->
163          (* CR-someday mshinwell: consider a different error message if
164             this triggers as a result of the propagation of a user's
165             attribute into the second part of an over application
166             (inline_and_simplify.ml line 710). *)
167          Location.prerr_warning (Debuginfo.to_location apply.dbg)
168            (Warnings.Inlining_impossible "[@inlined] attribute was not \
169              used on this function application (the optimizer did not \
170              know what function was being applied)")
171        | Unroll _ ->
172          Location.prerr_warning (Debuginfo.to_location apply.dbg)
173            (Warnings.Inlining_impossible "[@unroll] attribute was not \
174              used on this function application (the optimizer did not \
175              know what function was being applied)"));
176    if !Clflags.dump_flambda
177    then
178      Format.fprintf ppf "End of middle end:@ %a@."
179        Flambda.print_program flam;
180    check flam;
181    (* CR-someday mshinwell: add -d... option for this *)
182    (* dump_function_sizes flam ~backend; *)
183    flam) ();
184