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
|
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
module A = Simple_value_approx
let import_set_of_closures =
let import_function_declarations (clos : A.function_declarations)
: A.function_declarations =
(* CR-soon mshinwell for pchambart: Do we still need to do this
rewriting? I'm wondering if maybe we don't have to any more. *)
let sym_to_fun_var_map (clos : A.function_declarations) =
Variable.Map.fold (fun fun_var _ acc ->
let closure_id = Closure_id.wrap fun_var in
let sym = Compilenv.closure_symbol closure_id in
Symbol.Map.add sym fun_var acc)
clos.funs Symbol.Map.empty
in
let sym_map = sym_to_fun_var_map clos in
let f_named (named : Flambda.named) =
match named with
| Symbol sym ->
begin try Flambda.Expr (Var (Symbol.Map.find sym sym_map)) with
| Not_found -> named
end
| named -> named
in
let funs =
Variable.Map.map (fun (function_decl : A.function_declaration) ->
A.update_function_declaration_body function_decl
(Flambda_iterators.map_toplevel_named f_named))
clos.funs
in
A.update_function_declarations clos ~funs
in
let aux set_of_closures_id =
match
Compilenv.approx_for_global
(Set_of_closures_id.get_compilation_unit set_of_closures_id)
with
| None -> None
| Some ex_info ->
try
let function_declarations =
Set_of_closures_id.Map.find set_of_closures_id
ex_info.sets_of_closures
in
Some (import_function_declarations function_declarations)
with Not_found ->
Misc.fatal_error "Cannot find set of closures"
in
Set_of_closures_id.Tbl.memoize Compilenv.imported_sets_of_closures_table aux
let rec import_ex ex =
let import_value_set_of_closures ~set_of_closures_id ~bound_vars ~free_vars
~(ex_info : Export_info.t) ~what : A.value_set_of_closures option =
let bound_vars = Var_within_closure.Map.map import_approx bound_vars in
match import_set_of_closures set_of_closures_id with
| None -> None
| Some function_decls ->
(* CR-someday xclerc: add a test to the test suite to ensure that
classic mode behaves as expected. *)
let is_classic_mode = function_decls.is_classic_mode in
let invariant_params =
match
Set_of_closures_id.Map.find set_of_closures_id
ex_info.invariant_params
with
| exception Not_found ->
if is_classic_mode then
Variable.Map.empty
else
Misc.fatal_errorf "Set of closures ID %a not found in \
invariant_params (when importing [%a: %s])"
Set_of_closures_id.print set_of_closures_id
Export_id.print ex
what
| found -> found
in
let recursive =
match
Set_of_closures_id.Map.find set_of_closures_id ex_info.recursive
with
| exception Not_found ->
if is_classic_mode then
Variable.Set.empty
else
Misc.fatal_errorf "Set of closures ID %a not found in \
recursive (when importing [%a: %s])"
Set_of_closures_id.print set_of_closures_id
Export_id.print ex
what
| found -> found
in
Some (A.create_value_set_of_closures
~function_decls
~bound_vars
~free_vars
~invariant_params:(lazy invariant_params)
~recursive:(lazy recursive)
~specialised_args:Variable.Map.empty
~freshening:Freshening.Project_var.empty
~direct_call_surrogates:Closure_id.Map.empty)
in
let compilation_unit = Export_id.get_compilation_unit ex in
match Compilenv.approx_for_global compilation_unit with
| None -> A.value_unknown Other
| Some ex_info ->
match Export_info.find_description ex_info ex with
| exception Not_found ->
Misc.fatal_errorf "Cannot find export id %a" Export_id.print ex
| Value_unknown_descr -> A.value_unknown Other
| Value_int i -> A.value_int i
| Value_char c -> A.value_char c
| Value_float f -> A.value_float f
| Value_float_array float_array ->
begin match float_array.contents with
| Unknown_or_mutable ->
A.value_mutable_float_array ~size:float_array.size
| Contents contents ->
A.value_immutable_float_array
(Array.map (function
| None -> A.value_any_float
| Some f -> A.value_float f)
contents)
end
| Export_info.Value_boxed_int (t, i) -> A.value_boxed_int t i
| Value_string { size; contents } ->
let contents =
match contents with
| Unknown_or_mutable -> None
| Contents contents -> Some contents
in
A.value_string size contents
| Value_mutable_block _ -> A.value_unknown Other
| Value_block (tag, fields) ->
A.value_block tag (Array.map import_approx fields)
| Value_closure { closure_id;
set_of_closures =
{ set_of_closures_id; bound_vars; free_vars; aliased_symbol } } ->
let value_set_of_closures =
import_value_set_of_closures
~set_of_closures_id ~bound_vars ~free_vars ~ex_info
~what:(Format.asprintf "Value_closure %a" Closure_id.print closure_id)
in
begin match value_set_of_closures with
| None -> A.value_unresolved (Set_of_closures_id set_of_closures_id)
| Some value_set_of_closures ->
A.value_closure ?set_of_closures_symbol:aliased_symbol
value_set_of_closures closure_id
end
| Value_set_of_closures
{ set_of_closures_id; bound_vars; free_vars; aliased_symbol } ->
let value_set_of_closures =
import_value_set_of_closures ~set_of_closures_id
~bound_vars ~free_vars ~ex_info ~what:"Value_set_of_closures"
in
match value_set_of_closures with
| None ->
A.value_unresolved (Set_of_closures_id set_of_closures_id)
| Some value_set_of_closures ->
let approx = A.value_set_of_closures value_set_of_closures in
match aliased_symbol with
| None -> approx
| Some symbol -> A.augment_with_symbol approx symbol
and import_approx (ap : Export_info.approx) =
match ap with
| Value_unknown -> A.value_unknown Other
| Value_id ex -> A.value_extern ex
| Value_symbol sym -> A.value_symbol sym
let import_symbol sym =
if Compilenv.is_predefined_exception sym then
A.value_unknown Other
else begin
let compilation_unit = Symbol.compilation_unit sym in
match Compilenv.approx_for_global compilation_unit with
| None -> A.value_unresolved (Symbol sym)
| Some export_info ->
match Symbol.Map.find sym export_info.symbol_id with
| approx -> A.augment_with_symbol (import_ex approx) sym
| exception Not_found ->
Misc.fatal_errorf
"Compilation unit = %a Cannot find symbol %a"
Compilation_unit.print compilation_unit
Symbol.print sym
end
(* Note for code reviewers: Observe that [really_import] iterates until
the approximation description is fully resolved (or a necessary .cmx
file is missing). *)
let rec really_import (approx : A.descr) =
match approx with
| Value_extern ex -> really_import_ex ex
| Value_symbol sym -> really_import_symbol sym
| r -> r
and really_import_ex ex =
really_import (import_ex ex).descr
and really_import_symbol sym =
really_import (import_symbol sym).descr
let really_import_approx (approx : Simple_value_approx.t) =
A.replace_description approx (really_import approx.descr)
|
