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
|
(***********************************************************************)
(* *)
(* Caml Special Light *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1995 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* Compilation environments for compilation units *)
open Config
open Misc
open Clambda
type error =
Not_a_unit_info of string
| Corrupted_unit_info of string
| Illegal_renaming of string * string
exception Error of error
(* Each .o file has a matching .cmx file that provides the following infos
on the compilation unit:
- list of other units imported, with CRCs of their .cmx files
- approximation of the structure implemented
(includes descriptions of known functions: arity and direct entry
points)
- list of currying functions and application functions needed
The .cmx file contains these infos (as an externed record) plus a CRC
of these infos *)
type unit_infos =
{ mutable ui_name: string; (* Name of unit implemented *)
mutable ui_interface: Digest.t; (* CRC of interface impl. *)
mutable ui_imports_cmi: (string * Digest.t) list; (* Interfaces imported *)
mutable ui_imports_cmx: (string * Digest.t) list; (* Infos imported *)
mutable ui_approx: value_approximation; (* Approx of the structure *)
mutable ui_curry_fun: int list; (* Currying functions needed *)
mutable ui_apply_fun: int list; (* Apply functions needed *)
mutable ui_force_link: bool } (* Always linked *)
let global_approx_table =
(Hashtbl.create 17 : (string, value_approximation) Hashtbl.t)
let current_unit =
{ ui_name = "";
ui_interface = "";
ui_imports_cmi = [];
ui_imports_cmx = [];
ui_approx = Value_unknown;
ui_curry_fun = [];
ui_apply_fun = [];
ui_force_link = false }
let reset name crc_intf =
Hashtbl.clear global_approx_table;
current_unit.ui_name <- name;
current_unit.ui_interface <- crc_intf;
current_unit.ui_imports_cmi <- [];
current_unit.ui_imports_cmx <- [];
current_unit.ui_curry_fun <- [];
current_unit.ui_apply_fun <- [];
current_unit.ui_force_link <- false
let current_unit_name () =
current_unit.ui_name
let read_unit_info filename =
let ic = open_in_bin filename in
try
let buffer = String.create (String.length cmx_magic_number) in
really_input ic buffer 0 (String.length cmx_magic_number);
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)))
(* Return the approximation of a global identifier *)
let cmx_not_found_crc =
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000"
let global_approx global_ident =
let modname = Ident.name global_ident in
try
Hashtbl.find global_approx_table modname
with Not_found ->
let (approx, crc) =
try
let filename =
find_in_path !load_path (lowercase modname ^ ".cmx") in
let (ui, crc) = read_unit_info filename in
if ui.ui_name <> modname then
raise(Error(Illegal_renaming(modname, filename)));
(ui.ui_approx, crc)
with Not_found ->
(Value_unknown, cmx_not_found_crc) in
current_unit.ui_imports_cmx <-
(modname, crc) :: current_unit.ui_imports_cmx;
Hashtbl.add global_approx_table modname approx;
approx
(* 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
(* Write the description of the current unit *)
let save_unit_info filename =
current_unit.ui_imports_cmi <- Env.imported_units();
let oc = open_out_bin filename in
output_string oc cmx_magic_number;
output_value oc current_unit;
flush oc;
let crc = Digest.file filename in
Digest.output oc crc;
close_out oc
(* Error report *)
open Format
let report_error = function
Not_a_unit_info filename ->
print_string filename; print_space();
print_string "is not a compilation unit description."
| Corrupted_unit_info filename ->
print_string "Corrupted compilation unit description"; print_space();
print_string filename
| Illegal_renaming(modname, filename) ->
print_string filename; print_space();
print_string "contains the description for unit"; print_space();
print_string modname
|
