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
|
(**************************************************************************)
(* *)
(* 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 rename_id_state = Export_id.Tbl.create 100
let rename_set_of_closures_id_state = Set_of_closures_id.Tbl.create 10
let imported_function_declarations_table =
(Set_of_closures_id.Tbl.create 10
: A.function_declarations Set_of_closures_id.Tbl.t)
(* Rename export identifiers' compilation units to denote that they now
live within a pack. *)
let import_eid_for_pack units pack id =
try Export_id.Tbl.find rename_id_state id
with Not_found ->
let unit_id = Export_id.get_compilation_unit id in
let id' =
if Compilation_unit.Set.mem unit_id units
then Export_id.create ?name:(Export_id.name id) pack
else id
in
Export_id.Tbl.add rename_id_state id id';
id'
(* Similar to [import_eid_for_pack], but for symbols. *)
let import_symbol_for_pack units pack symbol =
let compilation_unit = Symbol.compilation_unit symbol in
if Compilation_unit.Set.mem compilation_unit units
then Symbol.import_for_pack ~pack symbol
else symbol
let import_approx_for_pack units pack (approx : Export_info.approx)
: Export_info.approx =
match approx with
| Value_symbol sym -> Value_symbol (import_symbol_for_pack units pack sym)
| Value_id eid -> Value_id (import_eid_for_pack units pack eid)
| Value_unknown -> Value_unknown
let import_set_of_closures_id_for_pack units pack
(set_of_closures_id : Set_of_closures_id.t)
: Set_of_closures_id.t =
let compilation_unit =
Set_of_closures_id.get_compilation_unit set_of_closures_id
in
if Compilation_unit.Set.mem compilation_unit units then
Set_of_closures_id.Tbl.memoize
rename_set_of_closures_id_state
(fun _ ->
Set_of_closures_id.create
?name:(Set_of_closures_id.name set_of_closures_id)
pack)
set_of_closures_id
else set_of_closures_id
let import_set_of_closures_origin_for_pack units pack
(set_of_closures_origin : Set_of_closures_origin.t)
: Set_of_closures_origin.t =
Set_of_closures_origin.rename
(import_set_of_closures_id_for_pack units pack)
set_of_closures_origin
let import_set_of_closures units pack
(set_of_closures : Export_info.value_set_of_closures)
: Export_info.value_set_of_closures =
{ set_of_closures_id =
import_set_of_closures_id_for_pack units pack
set_of_closures.set_of_closures_id;
bound_vars =
Var_within_closure.Map.map (import_approx_for_pack units pack)
set_of_closures.bound_vars;
free_vars = set_of_closures.free_vars;
results =
Closure_id.Map.map (import_approx_for_pack units pack)
set_of_closures.results;
aliased_symbol =
Option.map
(import_symbol_for_pack units pack)
set_of_closures.aliased_symbol;
}
let import_descr_for_pack units pack (descr : Export_info.descr)
: Export_info.descr =
match descr with
| Value_int _
| Value_char _
| Value_string _
| Value_float _
| Value_float_array _
| Export_info.Value_boxed_int _
| Value_mutable_block _ as desc -> desc
| Value_block (tag, fields) ->
Value_block (tag, Array.map (import_approx_for_pack units pack) fields)
| Value_closure { closure_id; set_of_closures } ->
Value_closure {
closure_id;
set_of_closures = import_set_of_closures units pack set_of_closures;
}
| Value_set_of_closures set_of_closures ->
Value_set_of_closures (import_set_of_closures units pack set_of_closures)
| Value_unknown_descr -> Value_unknown_descr
let rec import_code_for_pack units pack expr =
Flambda_iterators.map_named (function
| Symbol sym -> Symbol (import_symbol_for_pack units pack sym)
| Read_symbol_field (sym, field) ->
Read_symbol_field (import_symbol_for_pack units pack sym, field)
| Set_of_closures set_of_closures ->
let set_of_closures =
Flambda.create_set_of_closures
~free_vars:set_of_closures.free_vars
~specialised_args:set_of_closures.specialised_args
~direct_call_surrogates:set_of_closures.direct_call_surrogates
~function_decls:
(import_function_declarations_for_pack_aux units pack
set_of_closures.function_decls)
in
Set_of_closures set_of_closures
| e -> e)
expr
and import_function_declarations_for_pack_aux units pack
(function_decls : Flambda.function_declarations) =
Flambda.import_function_declarations_for_pack
function_decls
(import_set_of_closures_id_for_pack units pack)
(import_set_of_closures_origin_for_pack units pack)
let import_function_declarations_for_pack_aux units pack
(function_decls : A.function_declarations) : A.function_declarations =
let funs =
Variable.Map.map
(fun (function_decl : A.function_declaration) ->
A.update_function_declaration_body function_decl
(fun body -> import_code_for_pack units pack body))
function_decls.funs
in
A.import_function_declarations_for_pack
(A.update_function_declarations function_decls ~funs)
(import_set_of_closures_id_for_pack units pack)
(import_set_of_closures_origin_for_pack units pack)
let import_function_declarations_approx_for_pack units pack
(function_decls: A.function_declarations) =
let original_set_of_closures_id = function_decls.set_of_closures_id in
try
Set_of_closures_id.Tbl.find imported_function_declarations_table
original_set_of_closures_id
with Not_found ->
let function_decls =
import_function_declarations_for_pack_aux units pack function_decls
in
Set_of_closures_id.Tbl.add
imported_function_declarations_table
original_set_of_closures_id
function_decls;
function_decls
let import_eidmap_for_pack units pack f map =
Export_info.nest_eid_map
(Compilation_unit.Map.fold
(fun _ map acc -> Export_id.Map.disjoint_union map acc)
(Compilation_unit.Map.map (fun map ->
Export_id.Map.map_keys (import_eid_for_pack units pack)
(Export_id.Map.map f map))
map)
Export_id.Map.empty)
let import_for_pack ~pack_units ~pack (exp : Export_info.t) =
let import_sym = import_symbol_for_pack pack_units pack in
let import_descr = import_descr_for_pack pack_units pack in
let import_eid = import_eid_for_pack pack_units pack in
let import_eidmap f map = import_eidmap_for_pack pack_units pack f map in
let import_set_of_closures_id =
import_set_of_closures_id_for_pack pack_units pack
in
let import_function_declarations =
import_function_declarations_approx_for_pack pack_units pack
in
let sets_of_closures =
Set_of_closures_id.Map.map_keys import_set_of_closures_id
(Set_of_closures_id.Map.map
import_function_declarations
exp.sets_of_closures)
in
Export_info.create ~sets_of_closures
~offset_fun:exp.offset_fun
~offset_fv:exp.offset_fv
~values:(import_eidmap import_descr exp.values)
~symbol_id:(Symbol.Map.map_keys import_sym
(Symbol.Map.map import_eid exp.symbol_id))
~constant_closures:exp.constant_closures
~invariant_params:
(Set_of_closures_id.Map.map_keys import_set_of_closures_id
exp.invariant_params)
~recursive:
(Set_of_closures_id.Map.map_keys import_set_of_closures_id
exp.recursive)
let clear_import_state () =
Set_of_closures_id.Tbl.clear imported_function_declarations_table;
Set_of_closures_id.Tbl.clear rename_set_of_closures_id_state;
Export_id.Tbl.clear rename_id_state
|
