1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Xavier Leroy, projet Gallium, INRIA Rocquencourt *)
6 (* Pierre Chambart, OCamlPro *)
7 (* Mark Shinwell and Leo White, Jane Street Europe *)
8 (* *)
9 (* Copyright 2010 Institut National de Recherche en Informatique et *)
10 (* en Automatique *)
11 (* Copyright 2013--2016 OCamlPro SAS *)
12 (* Copyright 2014--2016 Jane Street Group LLC *)
13 (* *)
14 (* All rights reserved. This file is distributed under the terms of *)
15 (* the GNU Lesser General Public License version 2.1, with the *)
16 (* special exception on linking described in the file LICENSE. *)
17 (* *)
18 (**************************************************************************)
19
20 (* Compilation environments for compilation units *)
21
22 [@@@ocaml.warning "+a-4-9-40-41-42"]
23
24 open Config
25 open Cmx_format
26
27 type error =
28 Not_a_unit_info of string
29 | Corrupted_unit_info of string
30 | Illegal_renaming of string * string * string
31
32 exception Error of error
33
34 let global_infos_table =
35 (Hashtbl.create 17 : (string, unit_infos option) Hashtbl.t)
36 let export_infos_table =
37 (Hashtbl.create 10 : (string, Export_info.t) Hashtbl.t)
38
39 let imported_sets_of_closures_table =
40 (Set_of_closures_id.Tbl.create 10
41 : Simple_value_approx.function_declarations option
42 Set_of_closures_id.Tbl.t)
43
44 module CstMap =
45 Map.Make(struct
46 type t = Clambda.ustructured_constant
47 let compare = Clambda.compare_structured_constants
48 (* PR#6442: it is incorrect to use Stdlib.compare on values of type t
49 because it compares "0.0" and "-0.0" equal. *)
50 end)
51
52 module SymMap = Misc.Stdlib.String.Map
53
54 type structured_constants =
55 {
56 strcst_shared: string CstMap.t;
57 strcst_all: Clambda.ustructured_constant SymMap.t;
58 }
59
60 let structured_constants_empty =
61 {
62 strcst_shared = CstMap.empty;
63 strcst_all = SymMap.empty;
64 }
65
66 let structured_constants = ref structured_constants_empty
67
68
69 let exported_constants = Hashtbl.create 17
70
71 let merged_environment = ref Export_info.empty
72
73 let default_ui_export_info =
74 if Config.flambda then
75 Cmx_format.Flambda Export_info.empty
76 else
77 Cmx_format.Clambda Value_unknown
78
79 let current_unit =
80 { ui_name = "";
81 ui_symbol = "";
82 ui_defines = [];
83 ui_imports_cmi = [];
84 ui_imports_cmx = [];
85 ui_curry_fun = [];
86 ui_apply_fun = [];
87 ui_send_fun = [];
88 ui_force_link = false;
89 ui_export_info = default_ui_export_info }
90
91 let symbolname_for_pack pack name =
92 match pack with
93 | None -> name
94 | Some p ->
95 let b = Buffer.create 64 in
96 for i = 0 to String.length p - 1 do
97 match p.[i] with
98 | '.' -> Buffer.add_string b "__"
99 | c -> Buffer.add_char b c
100 done;
101 Buffer.add_string b "__";
102 Buffer.add_string b name;
103 Buffer.contents b
104
105 let unit_id_from_name name = Ident.create_persistent name
106
107 let concat_symbol unitname id =
108 unitname ^ "__" ^ id
109
110 let make_symbol ?(unitname = current_unit.ui_symbol) idopt =
111 let prefix = "caml" ^ unitname in
112 match idopt with
113 | None -> prefix
114 | Some id -> concat_symbol prefix id
115
116 let current_unit_linkage_name () =
117 Linkage_name.create (make_symbol ~unitname:current_unit.ui_symbol None)
118
119 let reset ?packname name =
120 Hashtbl.clear global_infos_table;
121 Set_of_closures_id.Tbl.clear imported_sets_of_closures_table;
122 let symbol = symbolname_for_pack packname name in
123 current_unit.ui_name <- name;
124 current_unit.ui_symbol <- symbol;
125 current_unit.ui_defines <- [symbol];
126 current_unit.ui_imports_cmi <- [];
127 current_unit.ui_imports_cmx <- [];
128 current_unit.ui_curry_fun <- [];
129 current_unit.ui_apply_fun <- [];
130 current_unit.ui_send_fun <- [];
131 current_unit.ui_force_link <- !Clflags.link_everything;
132 Hashtbl.clear exported_constants;
133 structured_constants := structured_constants_empty;
134 current_unit.ui_export_info <- default_ui_export_info;
135 merged_environment := Export_info.empty;
136 Hashtbl.clear export_infos_table;
137 let compilation_unit =
138 Compilation_unit.create
139 (Ident.create_persistent name)
140 (current_unit_linkage_name ())
141 in
142 Compilation_unit.set_current compilation_unit
143
144 let current_unit_infos () =
145 current_unit
146
147 let current_unit_name () =
148 current_unit.ui_name
149
150 let symbol_in_current_unit name =
151 let prefix = "caml" ^ current_unit.ui_symbol in
152 name = prefix ||
153 (let lp = String.length prefix in
154 String.length name >= 2 + lp
155 && String.sub name 0 lp = prefix
156 && name.[lp] = '_'
157 && name.[lp + 1] = '_')
158
159 let read_unit_info filename =
160 let ic = open_in_bin filename in
161 try
162 let buffer = really_input_string ic (String.length cmx_magic_number) in
163 if buffer <> cmx_magic_number then begin
164 close_in ic;
165 raise(Error(Not_a_unit_info filename))
166 end;
167 let ui = (input_value ic : unit_infos) in
168 let crc = Digest.input ic in
169 close_in ic;
170 (ui, crc)
171 with End_of_file | Failure _ ->
172 close_in ic;
173 raise(Error(Corrupted_unit_info(filename)))
174
175 let read_library_info filename =
176 let ic = open_in_bin filename in
177 let buffer = really_input_string ic (String.length cmxa_magic_number) in
178 if buffer <> cmxa_magic_number then
179 raise(Error(Not_a_unit_info filename));
180 let infos = (input_value ic : library_infos) in
181 close_in ic;
182 infos
183
184
185 (* Read and cache info on global identifiers *)
186
187 let get_global_info global_ident = (
188 let modname = Ident.name global_ident in
189 if modname = current_unit.ui_name then
190 Some current_unit
191 else begin
192 try
193 Hashtbl.find global_infos_table modname
194 with Not_found ->
195 let (infos, crc) =
196 if Env.is_imported_opaque modname then (None, None)
197 else begin
198 try
199 let filename =
200 Load_path.find_uncap (modname ^ ".cmx") in
201 let (ui, crc) = read_unit_info filename in
202 if ui.ui_name <> modname then
203 raise(Error(Illegal_renaming(modname, ui.ui_name, filename)));
204 (Some ui, Some crc)
205 with Not_found ->
206 let warn = Warnings.No_cmx_file modname in
207 Location.prerr_warning Location.none warn;
208 (None, None)
209 end
210 in
211 current_unit.ui_imports_cmx <-
212 (modname, crc) :: current_unit.ui_imports_cmx;
213 Hashtbl.add global_infos_table modname infos;
214 infos
215 end
216 )
217
218 let cache_unit_info ui =
219 Hashtbl.add global_infos_table ui.ui_name (Some ui)
220
221 (* Return the approximation of a global identifier *)
222
223 let get_clambda_approx ui =
224 assert(not Config.flambda);
225 match ui.ui_export_info with
226 | Flambda _ -> assert false
227 | Clambda approx -> approx
228
229 let toplevel_approx :
230 (string, Clambda.value_approximation) Hashtbl.t = Hashtbl.create 16
231
232 let record_global_approx_toplevel () =
233 Hashtbl.add toplevel_approx current_unit.ui_name
234 (get_clambda_approx current_unit)
235
236 let global_approx id =
237 if Ident.is_predef id then Clambda.Value_unknown
238 else try Hashtbl.find toplevel_approx (Ident.name id)
239 with Not_found ->
240 match get_global_info id with
241 | None -> Clambda.Value_unknown
242 | Some ui -> get_clambda_approx ui
243
244 (* Return the symbol used to refer to a global identifier *)
245
246 let symbol_for_global id =
247 if Ident.is_predef id then
248 "caml_exn_" ^ Ident.name id
249 else begin
250 let unitname = Ident.name id in
251 match
252 try ignore (Hashtbl.find toplevel_approx unitname); None
253 with Not_found -> get_global_info id
254 with
255 | None -> make_symbol ~unitname:(Ident.name id) None
256 | Some ui -> make_symbol ~unitname:ui.ui_symbol None
257 end
258
259 (* Register the approximation of the module being compiled *)
260
261 let unit_for_global id =
262 let sym_label = Linkage_name.create (symbol_for_global id) in
263 Compilation_unit.create id sym_label
264
265 let predefined_exception_compilation_unit =
266 Compilation_unit.create (Ident.create_persistent "__dummy__")
267 (Linkage_name.create "__dummy__")
268
269 let is_predefined_exception sym =
270 Compilation_unit.equal
271 predefined_exception_compilation_unit
272 (Symbol.compilation_unit sym)
273
274 let symbol_for_global' id =
275 let sym_label = Linkage_name.create (symbol_for_global id) in
276 if Ident.is_predef id then
277 Symbol.of_global_linkage predefined_exception_compilation_unit sym_label
278 else
279 Symbol.of_global_linkage (unit_for_global id) sym_label
280
281 let set_global_approx approx =
282 assert(not Config.flambda);
283 current_unit.ui_export_info <- Clambda approx
284
285 (* Exporting and importing cross module information *)
286
287 let get_flambda_export_info ui =
288 assert(Config.flambda);
289 match ui.ui_export_info with
290 | Clambda _ -> assert false
291 | Flambda ei -> ei
292
293 let set_export_info export_info =
294 assert(Config.flambda);
295 current_unit.ui_export_info <- Flambda export_info
296
297 let approx_for_global comp_unit =
298 let id = Compilation_unit.get_persistent_ident comp_unit in
299 if (Compilation_unit.equal
300 predefined_exception_compilation_unit
301 comp_unit)
302 || Ident.is_predef id
303 || not (Ident.global id)
304 then invalid_arg (Format.asprintf "approx_for_global %a" Ident.print id);
305 let modname = Ident.name id in
306 match Hashtbl.find export_infos_table modname with
307 | otherwise -> Some otherwise
308 | exception Not_found ->
309 match get_global_info id with
310 | None -> None
311 | Some ui ->
312 let exported = get_flambda_export_info ui in
313 Hashtbl.add export_infos_table modname exported;
314 merged_environment := Export_info.merge !merged_environment exported;
315 Some exported
316
317 let approx_env () = !merged_environment
318
319 (* Record that a currying function or application function is needed *)
320
321 let need_curry_fun n =
322 if not (List.mem n current_unit.ui_curry_fun) then
323 current_unit.ui_curry_fun <- n :: current_unit.ui_curry_fun
324
325 let need_apply_fun n =
326 assert(n > 0);
327 if not (List.mem n current_unit.ui_apply_fun) then
328 current_unit.ui_apply_fun <- n :: current_unit.ui_apply_fun
329
330 let need_send_fun n =
331 if not (List.mem n current_unit.ui_send_fun) then
332 current_unit.ui_send_fun <- n :: current_unit.ui_send_fun
333
334 (* Write the description of the current unit *)
335
336 let write_unit_info info filename =
337 let oc = open_out_bin filename in
338 output_string oc cmx_magic_number;
339 output_value oc info;
340 flush oc;
341 let crc = Digest.file filename in
342 Digest.output oc crc;
343 close_out oc
344
345 let save_unit_info filename =
346 current_unit.ui_imports_cmi <- Env.imports();
347 write_unit_info current_unit filename
348
349 let current_unit () =
350 match Compilation_unit.get_current () with
351 | Some current_unit -> current_unit
352 | None -> Misc.fatal_error "Compilenv.current_unit"
353
354 let current_unit_symbol () =
355 Symbol.of_global_linkage (current_unit ()) (current_unit_linkage_name ())
356
357 let const_label = ref 0
358
359 let new_const_symbol () =
360 incr const_label;
361 make_symbol (Some (Int.to_string !const_label))
362
363 let snapshot () = !structured_constants
364 let backtrack s = structured_constants := s
365
366 let new_structured_constant cst ~shared =
367 let {strcst_shared; strcst_all} = !structured_constants in
368 if shared then
369 try
370 CstMap.find cst strcst_shared
371 with Not_found ->
372 let lbl = new_const_symbol() in
373 structured_constants :=
374 {
375 strcst_shared = CstMap.add cst lbl strcst_shared;
376 strcst_all = SymMap.add lbl cst strcst_all;
377 };
378 lbl
379 else
380 let lbl = new_const_symbol() in
381 structured_constants :=
382 {
383 strcst_shared;
384 strcst_all = SymMap.add lbl cst strcst_all;
385 };
386 lbl
387
388 let add_exported_constant s =
389 Hashtbl.replace exported_constants s ()
390
391 let clear_structured_constants () =
392 structured_constants := structured_constants_empty
393
394 let structured_constant_of_symbol s =
395 SymMap.find_opt s (!structured_constants).strcst_all
396
397 let structured_constants () =
398 let provenance : Clambda.usymbol_provenance =
399 { original_idents = [];
400 module_path =
401 Path.Pident (Ident.create_persistent (current_unit_name ()));
402 }
403 in
404 SymMap.bindings (!structured_constants).strcst_all
405 |> List.map
406 (fun (symbol, definition) ->
407 {
408 Clambda.symbol;
409 exported = Hashtbl.mem exported_constants symbol;
410 definition;
411 provenance = Some provenance;
412 })
413
414 let closure_symbol fv =
415 let compilation_unit = Closure_id.get_compilation_unit fv in
416 let unitname =
417 Linkage_name.to_string (Compilation_unit.get_linkage_name compilation_unit)
418 in
419 let linkage_name =
420 concat_symbol unitname ((Closure_id.unique_name fv) ^ "_closure")
421 in
422 Symbol.of_global_linkage compilation_unit (Linkage_name.create linkage_name)
423
424 let function_label fv =
425 let compilation_unit = Closure_id.get_compilation_unit fv in
426 let unitname =
427 Linkage_name.to_string
428 (Compilation_unit.get_linkage_name compilation_unit)
429 in
430 (concat_symbol unitname (Closure_id.unique_name fv))
431
432 let require_global global_ident =
433 if not (Ident.is_predef global_ident) then
434 ignore (get_global_info global_ident : Cmx_format.unit_infos option)
435
436 (* Error report *)
437
438 open Format
439
440 let report_error ppf = function
441 | Not_a_unit_info filename ->
442 fprintf ppf "%a@ is not a compilation unit description."
443 Location.print_filename filename
444 | Corrupted_unit_info filename ->
445 fprintf ppf "Corrupted compilation unit description@ %a"
446 Location.print_filename filename
447 | Illegal_renaming(name, modname, filename) ->
448 fprintf ppf "%a@ contains the description for unit\
449 @ %s when %s was expected"
450 Location.print_filename filename name modname
451
452 let () =
453 Location.register_error_of_exn
454 (function
455 | Error err -> Some (Location.error_of_printer_file report_error err)
456 | _ -> None
457 )
458