1(**************************************************************************)
2(*                                                                        *)
3(*                                 OCaml                                  *)
4(*                                                                        *)
5(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
6(*                                                                        *)
7(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
8(*     en Automatique.                                                    *)
9(*                                                                        *)
10(*   All rights reserved.  This file is distributed under the terms of    *)
11(*   the GNU Lesser General Public License version 2.1, with the          *)
12(*   special exception on linking described in the file LICENSE.          *)
13(*                                                                        *)
14(**************************************************************************)
15
16(* From lambda to assembly code *)
17
18[@@@ocaml.warning "+a-4-9-40-41-42"]
19
20open Format
21open Config
22open Clflags
23open Misc
24open Cmm
25
26type error = Assembler_error of string
27
28exception Error of error
29
30let liveness ppf phrase =
31  Liveness.fundecl ppf phrase; phrase
32
33let dump_if ppf flag message phrase =
34  if !flag then Printmach.phase message ppf phrase
35
36let pass_dump_if ppf flag message phrase =
37  dump_if ppf flag message phrase; phrase
38
39let pass_dump_linear_if ppf flag message phrase =
40  if !flag then fprintf ppf "*** %s@.%a@." message Printlinear.fundecl phrase;
41  phrase
42
43let flambda_raw_clambda_dump_if ppf
44      ({ Flambda_to_clambda. expr = ulambda; preallocated_blocks = _;
45        structured_constants; exported = _; } as input) =
46  if !dump_rawclambda then
47    begin
48      Format.fprintf ppf "@.clambda (before Un_anf):@.";
49      Printclambda.clambda ppf ulambda;
50      Symbol.Map.iter (fun sym cst ->
51          Format.fprintf ppf "%a:@ %a@."
52            Symbol.print sym
53            Printclambda.structured_constant cst)
54        structured_constants
55    end;
56  if !dump_cmm then Format.fprintf ppf "@.cmm:@.";
57  input
58
59type clambda_and_constants =
60  Clambda.ulambda *
61  Clambda.preallocated_block list *
62  Clambda.preallocated_constant list
63
64let raw_clambda_dump_if ppf
65      ((ulambda, _, structured_constants):clambda_and_constants) =
66  if !dump_rawclambda || !dump_clambda then
67    begin
68      Format.fprintf ppf "@.clambda:@.";
69      Printclambda.clambda ppf ulambda;
70      List.iter (fun {Clambda.symbol; definition} ->
71          Format.fprintf ppf "%s:@ %a@."
72            symbol
73            Printclambda.structured_constant definition)
74        structured_constants
75    end;
76  if !dump_cmm then Format.fprintf ppf "@.cmm:@."
77
78let rec regalloc ppf round fd =
79  if round > 50 then
80    fatal_error(fd.Mach.fun_name ^
81                ": function too complex, cannot complete register allocation");
82  dump_if ppf dump_live "Liveness analysis" fd;
83  Interf.build_graph fd;
84  if !dump_interf then Printmach.interferences ppf ();
85  if !dump_prefer then Printmach.preferences ppf ();
86  Coloring.allocate_registers();
87  dump_if ppf dump_regalloc "After register allocation" fd;
88  let (newfd, redo_regalloc) = Reload.fundecl fd in
89  dump_if ppf dump_reload "After insertion of reloading code" newfd;
90  if redo_regalloc then begin
91    Reg.reinit(); Liveness.fundecl ppf newfd; regalloc ppf (round + 1) newfd
92  end else newfd
93
94let (++) x f = f x
95
96let compile_fundecl (ppf : formatter) fd_cmm =
97  Proc.init ();
98  Reg.reset();
99  let build = Compilenv.current_build () in
100  fd_cmm
101  ++ Timings.(accumulate_time (Selection build)) Selection.fundecl
102  ++ pass_dump_if ppf dump_selection "After instruction selection"
103  ++ Timings.(accumulate_time (Comballoc build)) Comballoc.fundecl
104  ++ pass_dump_if ppf dump_combine "After allocation combining"
105  ++ Timings.(accumulate_time (CSE build)) CSE.fundecl
106  ++ pass_dump_if ppf dump_cse "After CSE"
107  ++ Timings.(accumulate_time (Liveness build)) (liveness ppf)
108  ++ Timings.(accumulate_time (Deadcode build)) Deadcode.fundecl
109  ++ pass_dump_if ppf dump_live "Liveness analysis"
110  ++ Timings.(accumulate_time (Spill build)) Spill.fundecl
111  ++ Timings.(accumulate_time (Liveness build)) (liveness ppf)
112  ++ pass_dump_if ppf dump_spill "After spilling"
113  ++ Timings.(accumulate_time (Split build)) Split.fundecl
114  ++ pass_dump_if ppf dump_split "After live range splitting"
115  ++ Timings.(accumulate_time (Liveness build)) (liveness ppf)
116  ++ Timings.(accumulate_time (Regalloc build)) (regalloc ppf 1)
117  ++ Timings.(accumulate_time (Linearize build)) Linearize.fundecl
118  ++ pass_dump_linear_if ppf dump_linear "Linearized code"
119  ++ Timings.(accumulate_time (Scheduling build)) Scheduling.fundecl
120  ++ pass_dump_linear_if ppf dump_scheduling "After instruction scheduling"
121  ++ Timings.(accumulate_time (Emit build)) Emit.fundecl
122
123let compile_phrase ppf p =
124  if !dump_cmm then fprintf ppf "%a@." Printcmm.phrase p;
125  match p with
126  | Cfunction fd -> compile_fundecl ppf fd
127  | Cdata dl -> Emit.data dl
128
129
130(* For the native toplevel: generates generic functions unless
131   they are already available in the process *)
132let compile_genfuns ppf f =
133  List.iter
134    (function
135       | (Cfunction {fun_name = name}) as ph when f name ->
136           compile_phrase ppf ph
137       | _ -> ())
138    (Cmmgen.generic_functions true [Compilenv.current_unit_infos ()])
139
140let compile_unit ~source_provenance _output_prefix asm_filename keep_asm
141      obj_filename gen =
142  let create_asm = keep_asm || not !Emitaux.binary_backend_available in
143  Emitaux.create_asm_file := create_asm;
144  try
145    if create_asm then Emitaux.output_channel := open_out asm_filename;
146    begin try
147      gen ();
148      if create_asm then close_out !Emitaux.output_channel;
149    with exn when create_asm ->
150      close_out !Emitaux.output_channel;
151      if not keep_asm then remove_file asm_filename;
152      raise exn
153    end;
154    let assemble_result =
155      Timings.(time (Assemble source_provenance))
156        (Proc.assemble_file asm_filename) obj_filename
157    in
158    if assemble_result <> 0
159    then raise(Error(Assembler_error asm_filename));
160    if create_asm && not keep_asm then remove_file asm_filename
161  with exn ->
162    remove_file obj_filename;
163    raise exn
164
165let set_export_info (ulambda, prealloc, structured_constants, export) =
166  Compilenv.set_export_info export;
167  (ulambda, prealloc, structured_constants)
168
169let end_gen_implementation ?toplevel ~source_provenance ppf
170    (clambda:clambda_and_constants) =
171  Emit.begin_assembly ();
172  clambda
173  ++ Timings.(time (Cmm source_provenance)) Cmmgen.compunit
174  ++ Timings.(time (Compile_phrases source_provenance))
175       (List.iter (compile_phrase ppf))
176  ++ (fun () -> ());
177  (match toplevel with None -> () | Some f -> compile_genfuns ppf f);
178
179  (* We add explicit references to external primitive symbols.  This
180     is to ensure that the object files that define these symbols,
181     when part of a C library, won't be discarded by the linker.
182     This is important if a module that uses such a symbol is later
183     dynlinked. *)
184
185  compile_phrase ppf
186    (Cmmgen.reference_symbols
187       (List.filter (fun s -> s <> "" && s.[0] <> '%')
188          (List.map Primitive.native_name !Translmod.primitive_declarations))
189    );
190  Emit.end_assembly ()
191
192let flambda_gen_implementation ?toplevel ~source_provenance ~backend ppf
193    (program:Flambda.program) =
194  let export = Build_export_info.build_export_info ~backend program in
195  let (clambda, preallocated, constants) =
196    Timings.time (Flambda_pass ("backend", source_provenance)) (fun () ->
197      (program, export)
198      ++ Flambda_to_clambda.convert
199      ++ flambda_raw_clambda_dump_if ppf
200      ++ (fun { Flambda_to_clambda. expr; preallocated_blocks;
201                structured_constants; exported; } ->
202             (* "init_code" following the name used in
203                [Cmmgen.compunit_and_constants]. *)
204           Un_anf.apply expr ~what:"init_code", preallocated_blocks,
205           structured_constants, exported)
206      ++ set_export_info) ()
207  in
208  let constants =
209    List.map (fun (symbol, definition) ->
210        { Clambda.symbol = Linkage_name.to_string (Symbol.label symbol);
211          exported = true;
212          definition })
213      (Symbol.Map.bindings constants)
214  in
215  end_gen_implementation ?toplevel ~source_provenance ppf
216    (clambda, preallocated, constants)
217
218let lambda_gen_implementation ?toplevel ~source_provenance ppf
219    (lambda:Lambda.program) =
220  let clambda = Closure.intro lambda.main_module_block_size lambda.code in
221  let preallocated_block =
222    Clambda.{
223      symbol = Compilenv.make_symbol None;
224      exported = true;
225      tag = 0;
226      size = lambda.main_module_block_size;
227    }
228  in
229  let clambda_and_constants =
230    clambda, [preallocated_block], []
231  in
232  raw_clambda_dump_if ppf clambda_and_constants;
233  end_gen_implementation ?toplevel ~source_provenance ppf clambda_and_constants
234
235let compile_implementation_gen ?toplevel ~source_provenance prefixname
236    ~required_globals ppf gen_implementation program =
237  let asmfile =
238    if !keep_asm_file || !Emitaux.binary_backend_available
239    then prefixname ^ ext_asm
240    else Filename.temp_file "camlasm" ext_asm
241  in
242  compile_unit ~source_provenance prefixname asmfile !keep_asm_file
243      (prefixname ^ ext_obj) (fun () ->
244        Ident.Set.iter Compilenv.require_global required_globals;
245        gen_implementation ?toplevel ~source_provenance ppf program)
246
247let compile_implementation_clambda ?toplevel ~source_provenance prefixname
248    ppf (program:Lambda.program) =
249  compile_implementation_gen ?toplevel ~source_provenance prefixname
250    ~required_globals:program.Lambda.required_globals
251    ppf lambda_gen_implementation program
252
253let compile_implementation_flambda ?toplevel ~source_provenance prefixname
254    ~required_globals ~backend ppf (program:Flambda.program) =
255  compile_implementation_gen ?toplevel ~source_provenance prefixname
256    ~required_globals ppf (flambda_gen_implementation ~backend) program
257
258(* Error report *)
259
260let report_error ppf = function
261  | Assembler_error file ->
262      fprintf ppf "Assembler error, input left in file %a"
263        Location.print_filename file
264
265let () =
266  Location.register_error_of_exn
267    (function
268      | Error err -> Some (Location.error_of_printer_file report_error err)
269      | _ -> None
270    )
271