blob: 0e01f9ba3f3ac7e48c748ae017417d4331180af6 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
|
(***********************************************************************)
(* *)
(* 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 Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* From lambda to assembly code *)
open Format
open Config
open Clflags
open Misc
open Cmm
type error = Assembler_error of string
exception Error of error
let liveness ppf phrase =
Liveness.fundecl ppf phrase; phrase
let dump_if ppf flag message phrase =
if !flag then Printmach.phase message ppf phrase
let pass_dump_if ppf flag message phrase =
dump_if ppf flag message phrase; phrase
let pass_dump_linear_if ppf flag message phrase =
if !flag then fprintf ppf "*** %s@.%a@." message Printlinear.fundecl phrase;
phrase
let clambda_dump_if ppf ulambda =
if !dump_clambda then Printclambda.clambda ppf ulambda; ulambda
let rec regalloc ppf round fd =
if round > 50 then
fatal_error(fd.Mach.fun_name ^
": function too complex, cannot complete register allocation");
dump_if ppf dump_live "Liveness analysis" fd;
Interf.build_graph fd;
if !dump_interf then Printmach.interferences ppf ();
if !dump_prefer then Printmach.preferences ppf ();
Coloring.allocate_registers();
dump_if ppf dump_regalloc "After register allocation" fd;
let (newfd, redo_regalloc) = Reload.fundecl fd in
dump_if ppf dump_reload "After insertion of reloading code" newfd;
if redo_regalloc then begin
Reg.reinit(); Liveness.fundecl ppf newfd; regalloc ppf (round + 1) newfd
end else newfd
let (++) x f = f x
let compile_fundecl (ppf : formatter) fd_cmm =
Proc.init ();
Reg.reset();
fd_cmm
++ Selection.fundecl
++ pass_dump_if ppf dump_selection "After instruction selection"
++ Comballoc.fundecl
++ pass_dump_if ppf dump_combine "After allocation combining"
++ CSE.fundecl
++ pass_dump_if ppf dump_cse "After CSE"
++ liveness ppf
++ Deadcode.fundecl
++ pass_dump_if ppf dump_live "Liveness analysis"
++ Spill.fundecl
++ liveness ppf
++ pass_dump_if ppf dump_spill "After spilling"
++ Split.fundecl
++ pass_dump_if ppf dump_split "After live range splitting"
++ liveness ppf
++ regalloc ppf 1
++ Linearize.fundecl
++ pass_dump_linear_if ppf dump_linear "Linearized code"
++ Scheduling.fundecl
++ pass_dump_linear_if ppf dump_scheduling "After instruction scheduling"
++ Emit.fundecl
let compile_phrase ppf p =
if !dump_cmm then fprintf ppf "%a@." Printcmm.phrase p;
match p with
| Cfunction fd -> compile_fundecl ppf fd
| Cdata dl -> Emit.data dl
(* For the native toplevel: generates generic functions unless
they are already available in the process *)
let compile_genfuns ppf f =
List.iter
(function
| (Cfunction {fun_name = name}) as ph when f name ->
compile_phrase ppf ph
| _ -> ())
(Cmmgen.generic_functions true [Compilenv.current_unit_infos ()])
let compile_unit asm_filename keep_asm obj_filename gen =
let create_asm = keep_asm || not !Emitaux.binary_backend_available in
Emitaux.create_asm_file := create_asm;
try
if create_asm then Emitaux.output_channel := open_out asm_filename;
begin try
gen ();
if create_asm then close_out !Emitaux.output_channel;
with exn when create_asm ->
close_out !Emitaux.output_channel;
if not keep_asm then remove_file asm_filename;
raise exn
end;
if Proc.assemble_file asm_filename obj_filename <> 0
then raise(Error(Assembler_error asm_filename));
if create_asm && not keep_asm then remove_file asm_filename
with exn ->
remove_file obj_filename;
raise exn
let gen_implementation ?toplevel ppf (size, lam) =
Emit.begin_assembly ();
Closure.intro size lam
++ clambda_dump_if ppf
++ Cmmgen.compunit size
++ List.iter (compile_phrase ppf) ++ (fun () -> ());
(match toplevel with None -> () | Some f -> compile_genfuns ppf 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
(Cmmgen.reference_symbols
(List.filter (fun s -> s <> "" && s.[0] <> '%')
(List.map Primitive.native_name !Translmod.primitive_declarations))
);
Emit.end_assembly ()
let compile_implementation ?toplevel prefixname ppf (size, lam) =
let asmfile =
if !keep_asm_file || !Emitaux.binary_backend_available
then prefixname ^ ext_asm
else Filename.temp_file "camlasm" ext_asm
in
compile_unit asmfile !keep_asm_file (prefixname ^ ext_obj)
(fun () -> gen_implementation ?toplevel ppf (size, lam))
(* Error report *)
let report_error ppf = function
| Assembler_error file ->
fprintf ppf "Assembler error, input left in file %a"
Location.print_filename file
let () =
Location.register_error_of_exn
(function
| Error err -> Some (Location.error_of_printer_file report_error err)
| _ -> None
)
|
