forked from colinbenner/ocaml-llvm
-
Notifications
You must be signed in to change notification settings - Fork 1
/
compilenv.ml
237 lines (191 loc) · 6.88 KB
/
compilenv.ml
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
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
(***********************************************************************)
(* *)
(* 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. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* Compilation environments for compilation units *)
open Config
open Misc
open Clambda
open Cmx_format
type error =
Not_a_unit_info of string
| Corrupted_unit_info of string
| Illegal_renaming of string * string
exception Error of error
let global_infos_table =
(Hashtbl.create 17 : (string, unit_infos option) Hashtbl.t)
let structured_constants = ref ([] : (string * bool * Lambda.structured_constant) list)
let current_unit =
{ ui_name = "";
ui_symbol = "";
ui_defines = [];
ui_imports_cmi = [];
ui_imports_cmx = [];
ui_approx = Value_unknown;
ui_curry_fun = [];
ui_apply_fun = [];
ui_send_fun = [];
ui_force_link = false }
let symbolname_for_pack pack name =
match pack with
| None -> name
| Some p ->
let b = Buffer.create 64 in
for i = 0 to String.length p - 1 do
match p.[i] with
| '.' -> Buffer.add_string b "__"
| c -> Buffer.add_char b c
done;
Buffer.add_string b "__";
Buffer.add_string b name;
Buffer.contents b
let reset ?packname name =
Hashtbl.clear global_infos_table;
let symbol = symbolname_for_pack packname name in
current_unit.ui_name <- name;
current_unit.ui_symbol <- symbol;
current_unit.ui_defines <- [symbol];
current_unit.ui_imports_cmi <- [];
current_unit.ui_imports_cmx <- [];
current_unit.ui_curry_fun <- [];
current_unit.ui_apply_fun <- [];
current_unit.ui_send_fun <- [];
current_unit.ui_force_link <- false;
structured_constants := []
let current_unit_infos () =
current_unit
let current_unit_name () =
current_unit.ui_name
let make_symbol ?(unitname = current_unit.ui_symbol) idopt =
let prefix = "caml" ^ unitname in
match idopt with
| None -> prefix
| Some id -> prefix ^ "__" ^ id
let read_unit_info filename =
let ic = open_in_bin filename in
try
let buffer = input_bytes ic (String.length cmx_magic_number) in
if buffer <> cmx_magic_number then begin
close_in ic;
raise(Error(Not_a_unit_info filename))
end;
let ui = (input_value ic : unit_infos) in
let crc = Digest.input ic in
close_in ic;
(ui, crc)
with End_of_file | Failure _ ->
close_in ic;
raise(Error(Corrupted_unit_info(filename)))
let read_library_info filename =
let ic = open_in_bin filename in
let buffer = input_bytes ic (String.length cmxa_magic_number) in
if buffer <> cmxa_magic_number then
raise(Error(Not_a_unit_info filename));
let infos = (input_value ic : library_infos) in
close_in ic;
infos
(* Read and cache info on global identifiers *)
let cmx_not_found_crc =
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000"
let get_global_info global_ident =
let modname = Ident.name global_ident in
if modname = current_unit.ui_name then
Some current_unit
else begin
try
Hashtbl.find global_infos_table modname
with Not_found ->
let (infos, crc) =
try
let filename =
find_in_path_uncap !load_path (modname ^ ".cmx") in
let (ui, crc) = read_unit_info filename in
if ui.ui_name <> modname then
raise(Error(Illegal_renaming(ui.ui_name, filename)));
(Some ui, crc)
with Not_found ->
(None, cmx_not_found_crc) in
current_unit.ui_imports_cmx <-
(modname, crc) :: current_unit.ui_imports_cmx;
Hashtbl.add global_infos_table modname infos;
infos
end
let cache_unit_info ui =
Hashtbl.add global_infos_table ui.ui_name (Some ui)
(* Return the approximation of a global identifier *)
let toplevel_approx = Hashtbl.create 16
let record_global_approx_toplevel id =
Hashtbl.add toplevel_approx current_unit.ui_name current_unit.ui_approx
let global_approx id =
if Ident.is_predef_exn id then Value_unknown
else try Hashtbl.find toplevel_approx (Ident.name id)
with Not_found ->
match get_global_info id with
| None -> Value_unknown
| Some ui -> ui.ui_approx
(* Return the symbol used to refer to a global identifier *)
let symbol_for_global id =
if Ident.is_predef_exn id then
"caml_exn_" ^ Ident.name id
else begin
match get_global_info id with
| None -> make_symbol ~unitname:(Ident.name id) None
| Some ui -> make_symbol ~unitname:ui.ui_symbol None
end
(* Register the approximation of the module being compiled *)
let set_global_approx approx =
current_unit.ui_approx <- approx
(* Record that a currying function or application function is needed *)
let need_curry_fun n =
if not (List.mem n current_unit.ui_curry_fun) then
current_unit.ui_curry_fun <- n :: current_unit.ui_curry_fun
let need_apply_fun n =
if not (List.mem n current_unit.ui_apply_fun) then
current_unit.ui_apply_fun <- n :: current_unit.ui_apply_fun
let need_send_fun n =
if not (List.mem n current_unit.ui_send_fun) then
current_unit.ui_send_fun <- n :: current_unit.ui_send_fun
(* Write the description of the current unit *)
let write_unit_info info filename =
let oc = open_out_bin filename in
output_string oc cmx_magic_number;
output_value oc info;
flush oc;
let crc = Digest.file filename in
Digest.output oc crc;
close_out oc
let save_unit_info filename =
current_unit.ui_imports_cmi <- Env.imported_units();
write_unit_info current_unit filename
let const_label = ref 0
let new_const_label () =
incr const_label;
!const_label
let new_const_symbol () =
incr const_label;
make_symbol (Some (string_of_int !const_label))
let new_structured_constant cst global =
let lbl = new_const_symbol() in
structured_constants := (lbl, global, cst) :: !structured_constants;
lbl
let structured_constants () = !structured_constants
(* Error report *)
open Format
let report_error ppf = function
| Not_a_unit_info filename ->
fprintf ppf "%a@ is not a compilation unit description."
Location.print_filename filename
| Corrupted_unit_info filename ->
fprintf ppf "Corrupted compilation unit description@ %a"
Location.print_filename filename
| Illegal_renaming(modname, filename) ->
fprintf ppf "%a@ contains the description for unit@ %s"
Location.print_filename filename modname