forked from rescript-lang/rescript-compiler
-
Notifications
You must be signed in to change notification settings - Fork 0
/
lam_pass_lets_dce.ml
277 lines (265 loc) · 10.7 KB
/
lam_pass_lets_dce.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
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
(***********************************************************************)
(* *)
(* 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. *)
(* *)
(***********************************************************************)
(* Adapted for Javascript backend : Hongbo Zhang, *)
let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam =
let subst : Lam.t Ident_hashtbl.t = Ident_hashtbl.create 32 in
let string_table : string Ident_hashtbl.t = Ident_hashtbl.create 32 in
let used v = (count_var v ).times > 0 in
let rec simplif (lam : Lam.t) =
match lam with
| Lvar v -> Ident_hashtbl.find_default subst v lam
| Llet( (Strict | Alias | StrictOpt) , v, Lvar w, l2)
->
Ident_hashtbl.add subst v (simplif (Lam.var w));
simplif l2
| Llet(Strict as kind,
v, (Lprim {primitive = (Pmakeblock(0, tag_info, Mutable)
as primitive);
args = [linit] ; loc}), lbody)
->
let slinit = simplif linit in
let slbody = simplif lbody in
begin
try (** TODO: record all references variables *)
Lam_util.refine_let
~kind:Variable v slinit
(Lam_pass_eliminate_ref.eliminate_ref v slbody)
with Lam_pass_eliminate_ref.Real_reference ->
Lam_util.refine_let
~kind v (Lam.prim ~primitive ~args:[slinit] loc)
slbody
end
| Llet(Alias, v, l1, l2) ->
(** For alias, [l1] is pure, we can always inline,
when captured, we should avoid recomputation
*)
begin
match count_var v, l1 with
| {times = 0; _}, _ -> simplif l2
| {times = 1; captured = false }, _
| {times = 1; captured = true }, (Lconst _ | Lvar _)
| _, (Lconst
((
Const_int _ | Const_char _ | Const_float _ | Const_int32 _
| Const_nativeint _ )
| Const_pointer _ |Const_js_true | Const_js_false | Const_js_undefined) (* could be poly-variant [`A] -> [65a]*)
| Lprim {primitive = Pfield (_);
args = [
Lglobal_module _
]}
)
(* Const_int64 is no longer primitive
Note for some constant which is not
inlined, we can still record it and
do constant folding independently
*)
->
Ident_hashtbl.add subst v (simplif l1); simplif l2
| _, Lconst (Const_string s ) ->
(** only "" added for later inlining *)
Ident_hashtbl.add string_table v s;
Lam.let_ Alias v l1 (simplif l2)
(* we need move [simplif l2] later, since adding Hashtbl does have side effect *)
| _ -> Lam.let_ Alias v (simplif l1) (simplif l2)
(* for Alias, in most cases [l1] is already simplified *)
end
| Llet(StrictOpt as kind, v, l1, lbody) ->
(** can not be inlined since [l1] depend on the store
{[
let v = [|1;2;3|]
]}
get [StrictOpt] here, we can not inline v,
since the value of [v] can be changed
GPR #1476
Note to pass the sanitizer, we do need remove dead code (not just best effort)
This logic is tied to {!Lam_pass_count.count}
{[
if kind = Strict || used v then count bv l1
]}
If the code which should be removed is not removed, it will hold references
to other variables which is already removed.
*)
if not @@ used v
then simplif lbody (* GPR #1476 *)
else
begin match l1 with
| (Lprim {primitive = (Pmakeblock(0, tag_info, Mutable)
as primitive);
args = [linit] ; loc})
->
let slinit = simplif linit in
let slbody = simplif lbody in
begin
try (** TODO: record all references variables *)
Lam_util.refine_let
~kind:Variable v slinit
(Lam_pass_eliminate_ref.eliminate_ref v slbody)
with Lam_pass_eliminate_ref.Real_reference ->
Lam_util.refine_let
~kind v (Lam.prim ~primitive ~args:[slinit] loc)
slbody
end
| _ ->
let l1 = simplif l1 in
begin match l1 with
| Lconst(Const_string s) ->
Ident_hashtbl.add string_table v s;
(* we need move [simplif lbody] later, since adding Hashtbl does have side effect *)
Lam.let_ Alias v l1 (simplif lbody)
| _ ->
Lam_util.refine_let ~kind v l1 (simplif lbody)
end
end
(* TODO: check if it is correct rollback to [StrictOpt]? *)
| Llet((Strict | Variable as kind), v, l1, l2) ->
if not @@ used v
then
let l1 = simplif l1 in
let l2 = simplif l2 in
if Lam_analysis.no_side_effects l1
then l2
else Lam.seq l1 l2
else
let l1 = (simplif l1) in
begin match kind, l1 with
| Strict, Lconst((Const_string s))
->
Ident_hashtbl.add string_table v s;
Lam.let_ Alias v l1 (simplif l2)
| _ ->
Lam_util.refine_let ~kind v l1 (simplif l2)
end
| Lifused(v, l) ->
if used v then
simplif l
else Lam.unit
| Lsequence(Lifused(v, l1), l2) ->
if used v
then Lam.seq (simplif l1) (simplif l2)
else simplif l2
| Lsequence(l1, l2) -> Lam.seq (simplif l1) (simplif l2)
| Lapply{fn = Lfunction{function_kind = Curried; params; body}; args; _}
when Ext_list.same_length params args ->
simplif (Lam_beta_reduce.beta_reduce params body args)
(* | Lapply{ fn = Lfunction{function_kind = Tupled; params; body}; *)
(* args = [Lprim {primitive = Pmakeblock _; args; _}]; _} *)
(* (\** TODO: keep track of this parameter in ocaml trunk, *)
(* can we switch to the tupled backend? *)
(* *\) *)
(* when Ext_list.same_length params args -> *)
(* simplif (Lam_beta_reduce.beta_reduce params body args) *)
| Lapply{fn = l1;args = ll; loc; status} ->
Lam.apply (simplif l1) (Ext_list.map simplif ll) loc status
| Lfunction{arity; function_kind; params; body = l} ->
Lam.function_ ~arity ~function_kind ~params ~body:(simplif l)
| Lconst _ -> lam
| Lletrec(bindings, body) ->
Lam.letrec
(Ext_list.map (fun (v, l) -> (v, simplif l)) bindings)
(simplif body)
| Lprim {primitive=Pstringadd; args = [l;r]; loc } ->
begin
let l' = simplif l in
let r' = simplif r in
let opt_l =
match l' with
| Lconst((Const_string ls)) -> Some ls
| Lvar i -> Ident_hashtbl.find_opt string_table i
| _ -> None in
match opt_l with
| None -> Lam.prim ~primitive:Pstringadd ~args:[l';r'] loc
| Some l_s ->
let opt_r =
match r' with
| Lconst ( (Const_string rs)) -> Some rs
| Lvar i -> Ident_hashtbl.find_opt string_table i
| _ -> None in
begin match opt_r with
| None -> Lam.prim ~primitive:Pstringadd ~args:[l';r'] loc
| Some r_s ->
Lam.const (Const_string(l_s^r_s))
end
end
| Lprim {primitive = (Pstringrefu|Pstringrefs) as primitive ;
args = [l;r] ; loc
} -> (* TODO: introudce new constant *)
let l' = simplif l in
let r' = simplif r in
let opt_l =
match l' with
| Lconst (Const_string ls) ->
Some ls
| Lvar i -> Ident_hashtbl.find_opt string_table i
| _ -> None in
begin match opt_l with
| None -> Lam.prim ~primitive ~args:[l';r'] loc
| Some l_s ->
match r with
|Lconst((Const_int i)) ->
if i < String.length l_s && i >=0 then
Lam.const ((Const_char l_s.[i]))
else
Lam.prim ~primitive ~args:[l';r'] loc
| _ ->
Lam.prim ~primitive ~args:[l';r'] loc
end
| Lglobal_module _ -> lam
| Lprim {primitive; args; loc}
-> Lam.prim ~primitive ~args:(Ext_list.map simplif args) loc
| Lswitch(l, sw) ->
let new_l = simplif l
and new_consts = Ext_list.map (fun (n, e) -> (n, simplif e)) sw.sw_consts
and new_blocks = Ext_list.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks
and new_fail =
match sw.sw_failaction with
| None -> None
| Some x -> Some (simplif x)
in
Lam.switch
new_l
{sw with sw_consts = new_consts ; sw_blocks = new_blocks;
sw_failaction = new_fail}
| Lstringswitch (l,sw,d) ->
Lam.stringswitch
(simplif l) (Ext_list.map (fun (s,l) -> s,simplif l) sw)
(match d with None -> None | Some d -> Some (simplif d))
| Lstaticraise (i,ls) ->
Lam.staticraise i (Ext_list.map simplif ls)
| Lstaticcatch(l1, (i,args), l2) ->
Lam.staticcatch (simplif l1) (i,args) (simplif l2)
| Ltrywith(l1, v, l2) -> Lam.try_ (simplif l1) v (simplif l2)
| Lifthenelse(l1, l2, l3) ->
Lam.if_ (simplif l1) (simplif l2) (simplif l3)
| Lwhile(l1, l2)
->
Lam.while_ (simplif l1) (simplif l2)
| Lfor(v, l1, l2, dir, l3) ->
Lam.for_ v (simplif l1) (simplif l2) dir (simplif l3)
| Lassign(v, l) -> Lam.assign v (simplif l)
| Lsend(k, m, o, ll, loc) ->
Lam.send k (simplif m) (simplif o) (Ext_list.map simplif ll) loc
in simplif lam ;;
(* To transform let-bound references into variables *)
let apply_lets occ lambda =
let count_var v =
match
Ident_hashtbl.find_opt occ v
with
| None -> Lam_pass_count.dummy_info ()
| Some v -> v in
lets_helper count_var lambda
let simplify_lets (lam : Lam.t) =
let occ = Lam_pass_count.collect_occurs lam in
#if BS_DEBUG then
Ext_log.dwarn "OCCTBL" "@[%a@]@." Lam_pass_count.pp_occ_tbl occ ;
#end
apply_lets occ lam