1473 lines | 56262 chars
1 | (**************************************************************************) |
2 | (* *) |
3 | (* OCaml *) |
4 | (* *) |
5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) |
6 | (* *) |
7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) |
8 | (* en Automatique. *) |
9 | (* *) |
10 | (* All rights reserved. This file is distributed under the terms of *) |
11 | (* the GNU Lesser General Public License version 2.1, with the *) |
12 | (* special exception on linking described in the file LICENSE. *) |
13 | (* *) |
14 | (**************************************************************************) |
15 | |
16 | (* Introduction of closures, uncurrying, recognition of direct calls *) |
17 | |
18 | open Misc |
19 | open Asttypes |
20 | open Primitive |
21 | open Lambda |
22 | open Switch |
23 | open Clambda |
24 | module P = Clambda_primitives |
25 | |
26 | module Int = Numbers.Int |
27 | module Storer = |
28 | Switch.Store |
29 | (struct |
30 | type t = lambda |
31 | type key = lambda |
32 | let make_key = Lambda.make_key |
33 | let compare_key = Stdlib.compare |
34 | end) |
35 | |
36 | module V = Backend_var |
37 | module VP = Backend_var.With_provenance |
38 | |
39 | (* The current backend *) |
40 | |
41 | let no_phantom_lets () = |
42 | Misc.fatal_error "Closure does not support phantom let generation" |
43 | |
44 | (* Auxiliaries for compiling functions *) |
45 | |
46 | let rec split_list n l = |
47 | if n <= 0 then ([], l) else begin |
48 | match l with |
49 | [] -> fatal_error "Closure.split_list" |
50 | | a::l -> let (l1, l2) = split_list (n-1) l in (a::l1, l2) |
51 | end |
52 | |
53 | let rec build_closure_env env_param pos = function |
54 | [] -> V.Map.empty |
55 | | id :: rem -> |
56 | V.Map.add id |
57 | (Uprim(P.Pfield pos, [Uvar env_param], Debuginfo.none)) |
58 | (build_closure_env env_param (pos+1) rem) |
59 | |
60 | (* Auxiliary for accessing globals. We change the name of the global |
61 | to the name of the corresponding asm symbol. This is done here |
62 | and no longer in Cmmgen so that approximations stored in .cmx files |
63 | contain the right names if the -for-pack option is active. *) |
64 | |
65 | let getglobal dbg id = |
66 | Uprim(P.Pread_symbol (Compilenv.symbol_for_global id), [], dbg) |
67 | |
68 | (* Check if a variable occurs in a [clambda] term. *) |
69 | |
70 | let occurs_var var u = |
71 | let rec occurs = function |
72 | Uvar v -> v = var |
73 | | Uconst _ -> false |
74 | | Udirect_apply(_lbl, args, _) -> List.exists occurs args |
75 | | Ugeneric_apply(funct, args, _) -> occurs funct || List.exists occurs args |
76 | | Uclosure(_fundecls, clos) -> List.exists occurs clos |
77 | | Uoffset(u, _ofs) -> occurs u |
78 | | Ulet(_str, _kind, _id, def, body) -> occurs def || occurs body |
79 | | Uphantom_let _ -> no_phantom_lets () |
80 | | Uletrec(decls, body) -> |
81 | List.exists (fun (_id, u) -> occurs u) decls || occurs body |
82 | | Uprim(_p, args, _) -> List.exists occurs args |
83 | | Uswitch(arg, s, _dbg) -> |
84 | occurs arg || |
85 | occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks |
86 | | Ustringswitch(arg,sw,d) -> |
87 | occurs arg || |
88 | List.exists (fun (_,e) -> occurs e) sw || |
89 | (match d with None -> false | Some d -> occurs d) |
90 | | Ustaticfail (_, args) -> List.exists occurs args |
91 | | Ucatch(_, _, body, hdlr) -> occurs body || occurs hdlr |
92 | | Utrywith(body, _exn, hdlr) -> occurs body || occurs hdlr |
93 | | Uifthenelse(cond, ifso, ifnot) -> |
94 | occurs cond || occurs ifso || occurs ifnot |
95 | | Usequence(u1, u2) -> occurs u1 || occurs u2 |
96 | | Uwhile(cond, body) -> occurs cond || occurs body |
97 | | Ufor(_id, lo, hi, _dir, body) -> occurs lo || occurs hi || occurs body |
98 | | Uassign(id, u) -> id = var || occurs u |
99 | | Usend(_, met, obj, args, _) -> |
100 | occurs met || occurs obj || List.exists occurs args |
101 | | Uunreachable -> false |
102 | and occurs_array a = |
103 | try |
104 | for i = 0 to Array.length a - 1 do |
105 | if occurs a.(i) then raise Exit |
106 | done; |
107 | false |
108 | with Exit -> |
109 | true |
110 | in occurs u |
111 | |
112 | (* Determine whether the estimated size of a clambda term is below |
113 | some threshold *) |
114 | |
115 | let prim_size prim args = |
116 | let open Clambda_primitives in |
117 | match prim with |
118 | | Pread_symbol _ -> 1 |
119 | | Pmakeblock _ -> 5 + List.length args |
120 | | Pfield _ -> 1 |
121 | | Psetfield(_f, isptr, init) -> |
122 | begin match init with |
123 | | Root_initialization -> 1 (* never causes a write barrier hit *) |
124 | | Assignment | Heap_initialization -> |
125 | match isptr with |
126 | | Pointer -> 4 |
127 | | Immediate -> 1 |
128 | end |
129 | | Pfloatfield _ -> 1 |
130 | | Psetfloatfield _ -> 1 |
131 | | Pduprecord _ -> 10 + List.length args |
132 | | Pccall p -> (if p.prim_alloc then 10 else 4) + List.length args |
133 | | Praise _ -> 4 |
134 | | Pstringlength -> 5 |
135 | | Pbyteslength -> 5 |
136 | | Pstringrefs -> 6 |
137 | | Pbytesrefs | Pbytessets -> 6 |
138 | | Pmakearray _ -> 5 + List.length args |
139 | | Parraylength kind -> if kind = Pgenarray then 6 else 2 |
140 | | Parrayrefu kind -> if kind = Pgenarray then 12 else 2 |
141 | | Parraysetu kind -> if kind = Pgenarray then 16 else 4 |
142 | | Parrayrefs kind -> if kind = Pgenarray then 18 else 8 |
143 | | Parraysets kind -> if kind = Pgenarray then 22 else 10 |
144 | | Pbigarrayref(_, ndims, _, _) -> 4 + ndims * 6 |
145 | | Pbigarrayset(_, ndims, _, _) -> 4 + ndims * 6 |
146 | | _ -> 2 (* arithmetic and comparisons *) |
147 | |
148 | (* Very raw approximation of switch cost *) |
149 | |
150 | let lambda_smaller lam threshold = |
151 | let size = ref 0 in |
152 | let rec lambda_size lam = |
153 | if !size > threshold then raise Exit; |
154 | match lam with |
155 | Uvar _ -> () |
156 | | Uconst _ -> incr size |
157 | | Udirect_apply(_, args, _) -> |
158 | size := !size + 4; lambda_list_size args |
159 | | Ugeneric_apply(fn, args, _) -> |
160 | size := !size + 6; lambda_size fn; lambda_list_size args |
161 | | Uclosure _ -> |
162 | raise Exit (* inlining would duplicate function definitions *) |
163 | | Uoffset(lam, _ofs) -> |
164 | incr size; lambda_size lam |
165 | | Ulet(_str, _kind, _id, lam, body) -> |
166 | lambda_size lam; lambda_size body |
167 | | Uphantom_let _ -> no_phantom_lets () |
168 | | Uletrec _ -> |
169 | raise Exit (* usually too large *) |
170 | | Uprim(prim, args, _) -> |
171 | size := !size + prim_size prim args; |
172 | lambda_list_size args |
173 | | Uswitch(lam, cases, _dbg) -> |
174 | if Array.length cases.us_actions_consts > 1 then size := !size + 5 ; |
175 | if Array.length cases.us_actions_blocks > 1 then size := !size + 5 ; |
176 | lambda_size lam; |
177 | lambda_array_size cases.us_actions_consts ; |
178 | lambda_array_size cases.us_actions_blocks |
179 | | Ustringswitch (lam,sw,d) -> |
180 | lambda_size lam ; |
181 | (* as ifthenelse *) |
182 | List.iter |
183 | (fun (_,lam) -> |
184 | size := !size+2 ; |
185 | lambda_size lam) |
186 | sw ; |
187 | Option.iter lambda_size d |
188 | | Ustaticfail (_,args) -> lambda_list_size args |
189 | | Ucatch(_, _, body, handler) -> |
190 | incr size; lambda_size body; lambda_size handler |
191 | | Utrywith(body, _id, handler) -> |
192 | size := !size + 8; lambda_size body; lambda_size handler |
193 | | Uifthenelse(cond, ifso, ifnot) -> |
194 | size := !size + 2; |
195 | lambda_size cond; lambda_size ifso; lambda_size ifnot |
196 | | Usequence(lam1, lam2) -> |
197 | lambda_size lam1; lambda_size lam2 |
198 | | Uwhile(cond, body) -> |
199 | size := !size + 2; lambda_size cond; lambda_size body |
200 | | Ufor(_id, low, high, _dir, body) -> |
201 | size := !size + 4; lambda_size low; lambda_size high; lambda_size body |
202 | | Uassign(_id, lam) -> |
203 | incr size; lambda_size lam |
204 | | Usend(_, met, obj, args, _) -> |
205 | size := !size + 8; |
206 | lambda_size met; lambda_size obj; lambda_list_size args |
207 | | Uunreachable -> () |
208 | and lambda_list_size l = List.iter lambda_size l |
209 | and lambda_array_size a = Array.iter lambda_size a in |
210 | try |
211 | lambda_size lam; !size <= threshold |
212 | with Exit -> |
213 | false |
214 | |
215 | let is_pure_prim p = |
216 | let open Semantics_of_primitives in |
217 | match Semantics_of_primitives.for_primitive p with |
218 | | (No_effects | Only_generative_effects), _ -> true |
219 | | Arbitrary_effects, _ -> false |
220 | |
221 | (* Check if a clambda term is ``pure'', |
222 | that is without side-effects *and* not containing function definitions *) |
223 | |
224 | let rec is_pure = function |
225 | Uvar _ -> true |
226 | | Uconst _ -> true |
227 | | Uprim(p, args, _) -> is_pure_prim p && List.for_all is_pure args |
228 | | Uoffset(arg, _) -> is_pure arg |
229 | | Ulet(Immutable, _, _var, def, body) -> |
230 | is_pure def && is_pure body |
231 | | _ -> false |
232 | |
233 | (* Simplify primitive operations on known arguments *) |
234 | |
235 | let make_const c = (Uconst c, Value_const c) |
236 | let make_const_ref c = |
237 | make_const(Uconst_ref(Compilenv.new_structured_constant ~shared:true c, |
238 | Some c)) |
239 | let make_const_int n = make_const (Uconst_int n) |
240 | let make_const_ptr n = make_const (Uconst_ptr n) |
241 | let make_const_bool b = make_const_ptr(if b then 1 else 0) |
242 | |
243 | let make_integer_comparison cmp x y = |
244 | let open Clambda_primitives in |
245 | make_const_bool |
246 | (match cmp with |
247 | Ceq -> x = y |
248 | | Cne -> x <> y |
249 | | Clt -> x < y |
250 | | Cgt -> x > y |
251 | | Cle -> x <= y |
252 | | Cge -> x >= y) |
253 | |
254 | let make_float_comparison cmp x y = |
255 | make_const_bool |
256 | (match cmp with |
257 | | CFeq -> x = y |
258 | | CFneq -> not (x = y) |
259 | | CFlt -> x < y |
260 | | CFnlt -> not (x < y) |
261 | | CFgt -> x > y |
262 | | CFngt -> not (x > y) |
263 | | CFle -> x <= y |
264 | | CFnle -> not (x <= y) |
265 | | CFge -> x >= y |
266 | | CFnge -> not (x >= y)) |
267 | |
268 | let make_const_float n = make_const_ref (Uconst_float n) |
269 | let make_const_natint n = make_const_ref (Uconst_nativeint n) |
270 | let make_const_int32 n = make_const_ref (Uconst_int32 n) |
271 | let make_const_int64 n = make_const_ref (Uconst_int64 n) |
272 | |
273 | (* The [fpc] parameter is true if constant propagation of |
274 | floating-point computations is allowed *) |
275 | |
276 | let simplif_arith_prim_pure ~backend fpc p (args, approxs) dbg = |
277 | let module B = (val backend : Backend_intf.S) in |
278 | let open Clambda_primitives in |
279 | let default = (Uprim(p, args, dbg), Value_unknown) in |
280 | match approxs with |
281 | (* int (or enumerated type) *) |
282 | | [ Value_const(Uconst_int n1 | Uconst_ptr n1) ] -> |
283 | begin match p with |
284 | | Pnot -> make_const_bool (n1 = 0) |
285 | | Pnegint -> make_const_int (- n1) |
286 | | Poffsetint n -> make_const_int (n + n1) |
287 | | Pfloatofint when fpc -> make_const_float (float_of_int n1) |
288 | | Pbintofint Pnativeint -> make_const_natint (Nativeint.of_int n1) |
289 | | Pbintofint Pint32 -> make_const_int32 (Int32.of_int n1) |
290 | | Pbintofint Pint64 -> make_const_int64 (Int64.of_int n1) |
291 | | Pbswap16 -> make_const_int (((n1 land 0xff) lsl 8) |
292 | lor ((n1 land 0xff00) lsr 8)) |
293 | | _ -> default |
294 | end |
295 | (* int (or enumerated type), int (or enumerated type) *) |
296 | | [ Value_const(Uconst_int n1 | Uconst_ptr n1); |
297 | Value_const(Uconst_int n2 | Uconst_ptr n2) ] -> |
298 | begin match p with |
299 | | Psequand -> make_const_bool (n1 <> 0 && n2 <> 0) |
300 | | Psequor -> make_const_bool (n1 <> 0 || n2 <> 0) |
301 | | Paddint -> make_const_int (n1 + n2) |
302 | | Psubint -> make_const_int (n1 - n2) |
303 | | Pmulint -> make_const_int (n1 * n2) |
304 | | Pdivint _ when n2 <> 0 -> make_const_int (n1 / n2) |
305 | | Pmodint _ when n2 <> 0 -> make_const_int (n1 mod n2) |
306 | | Pandint -> make_const_int (n1 land n2) |
307 | | Porint -> make_const_int (n1 lor n2) |
308 | | Pxorint -> make_const_int (n1 lxor n2) |
309 | | Plslint when 0 <= n2 && n2 < 8 * B.size_int -> |
310 | make_const_int (n1 lsl n2) |
311 | | Plsrint when 0 <= n2 && n2 < 8 * B.size_int -> |
312 | make_const_int (n1 lsr n2) |
313 | | Pasrint when 0 <= n2 && n2 < 8 * B.size_int -> |
314 | make_const_int (n1 asr n2) |
315 | | Pintcomp c -> make_integer_comparison c n1 n2 |
316 | | _ -> default |
317 | end |
318 | (* float *) |
319 | | [Value_const(Uconst_ref(_, Some (Uconst_float n1)))] when fpc -> |
320 | begin match p with |
321 | | Pintoffloat -> make_const_int (int_of_float n1) |
322 | | Pnegfloat -> make_const_float (-. n1) |
323 | | Pabsfloat -> make_const_float (abs_float n1) |
324 | | _ -> default |
325 | end |
326 | (* float, float *) |
327 | | [Value_const(Uconst_ref(_, Some (Uconst_float n1))); |
328 | Value_const(Uconst_ref(_, Some (Uconst_float n2)))] when fpc -> |
329 | begin match p with |
330 | | Paddfloat -> make_const_float (n1 +. n2) |
331 | | Psubfloat -> make_const_float (n1 -. n2) |
332 | | Pmulfloat -> make_const_float (n1 *. n2) |
333 | | Pdivfloat -> make_const_float (n1 /. n2) |
334 | | Pfloatcomp c -> make_float_comparison c n1 n2 |
335 | | _ -> default |
336 | end |
337 | (* nativeint *) |
338 | | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n)))] -> |
339 | begin match p with |
340 | | Pintofbint Pnativeint -> make_const_int (Nativeint.to_int n) |
341 | | Pcvtbint(Pnativeint, Pint32) -> make_const_int32 (Nativeint.to_int32 n) |
342 | | Pcvtbint(Pnativeint, Pint64) -> make_const_int64 (Int64.of_nativeint n) |
343 | | Pnegbint Pnativeint -> make_const_natint (Nativeint.neg n) |
344 | | _ -> default |
345 | end |
346 | (* nativeint, nativeint *) |
347 | | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n1))); |
348 | Value_const(Uconst_ref(_, Some (Uconst_nativeint n2)))] -> |
349 | begin match p with |
350 | | Paddbint Pnativeint -> make_const_natint (Nativeint.add n1 n2) |
351 | | Psubbint Pnativeint -> make_const_natint (Nativeint.sub n1 n2) |
352 | | Pmulbint Pnativeint -> make_const_natint (Nativeint.mul n1 n2) |
353 | | Pdivbint {size=Pnativeint} when n2 <> 0n -> |
354 | make_const_natint (Nativeint.div n1 n2) |
355 | | Pmodbint {size=Pnativeint} when n2 <> 0n -> |
356 | make_const_natint (Nativeint.rem n1 n2) |
357 | | Pandbint Pnativeint -> make_const_natint (Nativeint.logand n1 n2) |
358 | | Porbint Pnativeint -> make_const_natint (Nativeint.logor n1 n2) |
359 | | Pxorbint Pnativeint -> make_const_natint (Nativeint.logxor n1 n2) |
360 | | Pbintcomp(Pnativeint, c) -> make_integer_comparison c n1 n2 |
361 | | _ -> default |
362 | end |
363 | (* nativeint, int *) |
364 | | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n1))); |
365 | Value_const(Uconst_int n2)] -> |
366 | begin match p with |
367 | | Plslbint Pnativeint when 0 <= n2 && n2 < 8 * B.size_int -> |
368 | make_const_natint (Nativeint.shift_left n1 n2) |
369 | | Plsrbint Pnativeint when 0 <= n2 && n2 < 8 * B.size_int -> |
370 | make_const_natint (Nativeint.shift_right_logical n1 n2) |
371 | | Pasrbint Pnativeint when 0 <= n2 && n2 < 8 * B.size_int -> |
372 | make_const_natint (Nativeint.shift_right n1 n2) |
373 | | _ -> default |
374 | end |
375 | (* int32 *) |
376 | | [Value_const(Uconst_ref(_, Some (Uconst_int32 n)))] -> |
377 | begin match p with |
378 | | Pintofbint Pint32 -> make_const_int (Int32.to_int n) |
379 | | Pcvtbint(Pint32, Pnativeint) -> make_const_natint (Nativeint.of_int32 n) |
380 | | Pcvtbint(Pint32, Pint64) -> make_const_int64 (Int64.of_int32 n) |
381 | | Pnegbint Pint32 -> make_const_int32 (Int32.neg n) |
382 | | _ -> default |
383 | end |
384 | (* int32, int32 *) |
385 | | [Value_const(Uconst_ref(_, Some (Uconst_int32 n1))); |
386 | Value_const(Uconst_ref(_, Some (Uconst_int32 n2)))] -> |
387 | begin match p with |
388 | | Paddbint Pint32 -> make_const_int32 (Int32.add n1 n2) |
389 | | Psubbint Pint32 -> make_const_int32 (Int32.sub n1 n2) |
390 | | Pmulbint Pint32 -> make_const_int32 (Int32.mul n1 n2) |
391 | | Pdivbint {size=Pint32} when n2 <> 0l -> |
392 | make_const_int32 (Int32.div n1 n2) |
393 | | Pmodbint {size=Pint32} when n2 <> 0l -> |
394 | make_const_int32 (Int32.rem n1 n2) |
395 | | Pandbint Pint32 -> make_const_int32 (Int32.logand n1 n2) |
396 | | Porbint Pint32 -> make_const_int32 (Int32.logor n1 n2) |
397 | | Pxorbint Pint32 -> make_const_int32 (Int32.logxor n1 n2) |
398 | | Pbintcomp(Pint32, c) -> make_integer_comparison c n1 n2 |
399 | | _ -> default |
400 | end |
401 | (* int32, int *) |
402 | | [Value_const(Uconst_ref(_, Some (Uconst_int32 n1))); |
403 | Value_const(Uconst_int n2)] -> |
404 | begin match p with |
405 | | Plslbint Pint32 when 0 <= n2 && n2 < 32 -> |
406 | make_const_int32 (Int32.shift_left n1 n2) |
407 | | Plsrbint Pint32 when 0 <= n2 && n2 < 32 -> |
408 | make_const_int32 (Int32.shift_right_logical n1 n2) |
409 | | Pasrbint Pint32 when 0 <= n2 && n2 < 32 -> |
410 | make_const_int32 (Int32.shift_right n1 n2) |
411 | | _ -> default |
412 | end |
413 | (* int64 *) |
414 | | [Value_const(Uconst_ref(_, Some (Uconst_int64 n)))] -> |
415 | begin match p with |
416 | | Pintofbint Pint64 -> make_const_int (Int64.to_int n) |
417 | | Pcvtbint(Pint64, Pint32) -> make_const_int32 (Int64.to_int32 n) |
418 | | Pcvtbint(Pint64, Pnativeint) -> make_const_natint (Int64.to_nativeint n) |
419 | | Pnegbint Pint64 -> make_const_int64 (Int64.neg n) |
420 | | _ -> default |
421 | end |
422 | (* int64, int64 *) |
423 | | [Value_const(Uconst_ref(_, Some (Uconst_int64 n1))); |
424 | Value_const(Uconst_ref(_, Some (Uconst_int64 n2)))] -> |
425 | begin match p with |
426 | | Paddbint Pint64 -> make_const_int64 (Int64.add n1 n2) |
427 | | Psubbint Pint64 -> make_const_int64 (Int64.sub n1 n2) |
428 | | Pmulbint Pint64 -> make_const_int64 (Int64.mul n1 n2) |
429 | | Pdivbint {size=Pint64} when n2 <> 0L -> |
430 | make_const_int64 (Int64.div n1 n2) |
431 | | Pmodbint {size=Pint64} when n2 <> 0L -> |
432 | make_const_int64 (Int64.rem n1 n2) |
433 | | Pandbint Pint64 -> make_const_int64 (Int64.logand n1 n2) |
434 | | Porbint Pint64 -> make_const_int64 (Int64.logor n1 n2) |
435 | | Pxorbint Pint64 -> make_const_int64 (Int64.logxor n1 n2) |
436 | | Pbintcomp(Pint64, c) -> make_integer_comparison c n1 n2 |
437 | | _ -> default |
438 | end |
439 | (* int64, int *) |
440 | | [Value_const(Uconst_ref(_, Some (Uconst_int64 n1))); |
441 | Value_const(Uconst_int n2)] -> |
442 | begin match p with |
443 | | Plslbint Pint64 when 0 <= n2 && n2 < 64 -> |
444 | make_const_int64 (Int64.shift_left n1 n2) |
445 | | Plsrbint Pint64 when 0 <= n2 && n2 < 64 -> |
446 | make_const_int64 (Int64.shift_right_logical n1 n2) |
447 | | Pasrbint Pint64 when 0 <= n2 && n2 < 64 -> |
448 | make_const_int64 (Int64.shift_right n1 n2) |
449 | | _ -> default |
450 | end |
451 | (* TODO: Pbbswap *) |
452 | (* Catch-all *) |
453 | | _ -> |
454 | default |
455 | |
456 | let field_approx n = function |
457 | | Value_tuple a when n < Array.length a -> a.(n) |
458 | | Value_const (Uconst_ref(_, Some (Uconst_block(_, l)))) |
459 | when n < List.length l -> |
460 | Value_const (List.nth l n) |
461 | | _ -> Value_unknown |
462 | |
463 | let simplif_prim_pure ~backend fpc p (args, approxs) dbg = |
464 | let open Clambda_primitives in |
465 | match p, args, approxs with |
466 | (* Block construction *) |
467 | | Pmakeblock(tag, Immutable, _kind), _, _ -> |
468 | let field = function |
469 | | Value_const c -> c |
470 | | _ -> raise Exit |
471 | in |
472 | begin try |
473 | let cst = Uconst_block (tag, List.map field approxs) in |
474 | let name = |
475 | Compilenv.new_structured_constant cst ~shared:true |
476 | in |
477 | make_const (Uconst_ref (name, Some cst)) |
478 | with Exit -> |
479 | (Uprim(p, args, dbg), Value_tuple (Array.of_list approxs)) |
480 | end |
481 | (* Field access *) |
482 | | Pfield n, _, [ Value_const(Uconst_ref(_, Some (Uconst_block(_, l)))) ] |
483 | when n < List.length l -> |
484 | make_const (List.nth l n) |
485 | | Pfield n, [ Uprim(P.Pmakeblock _, ul, _) ], [approx] |
486 | when n < List.length ul -> |
487 | (List.nth ul n, field_approx n approx) |
488 | (* Strings *) |
489 | | (Pstringlength | Pbyteslength), |
490 | _, |
491 | [ Value_const(Uconst_ref(_, Some (Uconst_string s))) ] -> |
492 | make_const_int (String.length s) |
493 | (* Kind test *) |
494 | | Pisint, _, [a1] -> |
495 | begin match a1 with |
496 | | Value_const(Uconst_int _ | Uconst_ptr _) -> make_const_bool true |
497 | | Value_const(Uconst_ref _) -> make_const_bool false |
498 | | Value_closure _ | Value_tuple _ -> make_const_bool false |
499 | | _ -> (Uprim(p, args, dbg), Value_unknown) |
500 | end |
501 | (* Catch-all *) |
502 | | _ -> |
503 | simplif_arith_prim_pure ~backend fpc p (args, approxs) dbg |
504 | |
505 | let simplif_prim ~backend fpc p (args, approxs as args_approxs) dbg = |
506 | if List.for_all is_pure args |
507 | then simplif_prim_pure ~backend fpc p args_approxs dbg |
508 | else |
509 | (* XXX : always return the same approxs as simplif_prim_pure? *) |
510 | let approx = |
511 | match p with |
512 | | P.Pmakeblock(_, Immutable, _kind) -> |
513 | Value_tuple (Array.of_list approxs) |
514 | | _ -> |
515 | Value_unknown |
516 | in |
517 | (Uprim(p, args, dbg), approx) |
518 | |
519 | (* Substitute variables in a [ulambda] term (a body of an inlined function) |
520 | and perform some more simplifications on integer primitives. |
521 | Also perform alpha-conversion on let-bound identifiers to avoid |
522 | clashes with locally-generated identifiers, and refresh raise counts |
523 | in order to avoid clashes with inlined code from other modules. |
524 | The variables must not be assigned in the term. |
525 | This is used to substitute "trivial" arguments for parameters |
526 | during inline expansion, and also for the translation of let rec |
527 | over functions. *) |
528 | |
529 | let approx_ulam = function |
530 | Uconst c -> Value_const c |
531 | | _ -> Value_unknown |
532 | |
533 | let find_action idxs acts tag = |
534 | if 0 <= tag && tag < Array.length idxs then begin |
535 | let idx = idxs.(tag) in |
536 | assert(0 <= idx && idx < Array.length acts); |
537 | Some acts.(idx) |
538 | end else |
539 | (* Can this happen? *) |
540 | None |
541 | |
542 | let subst_debuginfo loc dbg = |
543 | if !Clflags.debug then |
544 | Debuginfo.inline loc dbg |
545 | else |
546 | dbg |
547 | |
548 | let rec substitute loc ((backend, fpc) as st) sb rn ulam = |
549 | match ulam with |
550 | Uvar v -> |
551 | begin try V.Map.find v sb with Not_found -> ulam end |
552 | | Uconst _ -> ulam |
553 | | Udirect_apply(lbl, args, dbg) -> |
554 | let dbg = subst_debuginfo loc dbg in |
555 | Udirect_apply(lbl, List.map (substitute loc st sb rn) args, dbg) |
556 | | Ugeneric_apply(fn, args, dbg) -> |
557 | let dbg = subst_debuginfo loc dbg in |
558 | Ugeneric_apply(substitute loc st sb rn fn, |
559 | List.map (substitute loc st sb rn) args, dbg) |
560 | | Uclosure(defs, env) -> |
561 | (* Question: should we rename function labels as well? Otherwise, |
562 | there is a risk that function labels are not globally unique. |
563 | This should not happen in the current system because: |
564 | - Inlined function bodies contain no Uclosure nodes |
565 | (cf. function [lambda_smaller]) |
566 | - When we substitute offsets for idents bound by let rec |
567 | in [close], case [Lletrec], we discard the original |
568 | let rec body and use only the substituted term. *) |
569 | Uclosure(defs, List.map (substitute loc st sb rn) env) |
570 | | Uoffset(u, ofs) -> Uoffset(substitute loc st sb rn u, ofs) |
571 | | Ulet(str, kind, id, u1, u2) -> |
572 | let id' = VP.rename id in |
573 | Ulet(str, kind, id', substitute loc st sb rn u1, |
574 | substitute loc st |
575 | (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2) |
576 | | Uphantom_let _ -> no_phantom_lets () |
577 | | Uletrec(bindings, body) -> |
578 | let bindings1 = |
579 | List.map (fun (id, rhs) -> |
580 | (VP.var id, VP.rename id, rhs)) bindings |
581 | in |
582 | let sb' = |
583 | List.fold_right (fun (id, id', _) s -> |
584 | V.Map.add id (Uvar (VP.var id')) s) |
585 | bindings1 sb |
586 | in |
587 | Uletrec( |
588 | List.map |
589 | (fun (_id, id', rhs) -> (id', substitute loc st sb' rn rhs)) |
590 | bindings1, |
591 | substitute loc st sb' rn body) |
592 | | Uprim(p, args, dbg) -> |
593 | let sargs = List.map (substitute loc st sb rn) args in |
594 | let dbg = subst_debuginfo loc dbg in |
595 | let (res, _) = |
596 | simplif_prim ~backend fpc p (sargs, List.map approx_ulam sargs) dbg in |
597 | res |
598 | | Uswitch(arg, sw, dbg) -> |
599 | let sarg = substitute loc st sb rn arg in |
600 | let action = |
601 | (* Unfortunately, we cannot easily deal with the |
602 | case of a constructed block (makeblock) bound to a local |
603 | identifier. This would require to keep track of |
604 | local let bindings (at least their approximations) |
605 | in this substitute function. |
606 | *) |
607 | match sarg with |
608 | | Uconst (Uconst_ref (_, Some (Uconst_block (tag, _)))) -> |
609 | find_action sw.us_index_blocks sw.us_actions_blocks tag |
610 | | Uconst (Uconst_ptr tag) -> |
611 | find_action sw.us_index_consts sw.us_actions_consts tag |
612 | | _ -> None |
613 | in |
614 | begin match action with |
615 | | Some u -> substitute loc st sb rn u |
616 | | None -> |
617 | Uswitch(sarg, |
618 | { sw with |
619 | us_actions_consts = |
620 | Array.map (substitute loc st sb rn) sw.us_actions_consts; |
621 | us_actions_blocks = |
622 | Array.map (substitute loc st sb rn) sw.us_actions_blocks; |
623 | }, |
624 | dbg) |
625 | end |
626 | | Ustringswitch(arg,sw,d) -> |
627 | Ustringswitch |
628 | (substitute loc st sb rn arg, |
629 | List.map (fun (s,act) -> s,substitute loc st sb rn act) sw, |
630 | Option.map (substitute loc st sb rn) d) |
631 | | Ustaticfail (nfail, args) -> |
632 | let nfail = |
633 | match rn with |
634 | | Some rn -> |
635 | begin try |
636 | Int.Map.find nfail rn |
637 | with Not_found -> |
638 | fatal_errorf "Closure.split_list: invalid nfail (%d)" nfail |
639 | end |
640 | | None -> nfail in |
641 | Ustaticfail (nfail, List.map (substitute loc st sb rn) args) |
642 | | Ucatch(nfail, ids, u1, u2) -> |
643 | let nfail, rn = |
644 | match rn with |
645 | | Some rn -> |
646 | let new_nfail = next_raise_count () in |
647 | new_nfail, Some (Int.Map.add nfail new_nfail rn) |
648 | | None -> nfail, rn in |
649 | let ids' = List.map (fun (id, k) -> VP.rename id, k) ids in |
650 | let sb' = |
651 | List.fold_right2 |
652 | (fun (id, _) (id', _) s -> |
653 | V.Map.add (VP.var id) (Uvar (VP.var id')) s |
654 | ) |
655 | ids ids' sb |
656 | in |
657 | Ucatch(nfail, ids', substitute loc st sb rn u1, |
658 | substitute loc st sb' rn u2) |
659 | | Utrywith(u1, id, u2) -> |
660 | let id' = VP.rename id in |
661 | Utrywith(substitute loc st sb rn u1, id', |
662 | substitute loc st |
663 | (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2) |
664 | | Uifthenelse(u1, u2, u3) -> |
665 | begin match substitute loc st sb rn u1 with |
666 | Uconst (Uconst_ptr n) -> |
667 | if n <> 0 then |
668 | substitute loc st sb rn u2 |
669 | else |
670 | substitute loc st sb rn u3 |
671 | | Uprim(P.Pmakeblock _, _, _) -> |
672 | substitute loc st sb rn u2 |
673 | | su1 -> |
674 | Uifthenelse(su1, substitute loc st sb rn u2, |
675 | substitute loc st sb rn u3) |
676 | end |
677 | | Usequence(u1, u2) -> |
678 | Usequence(substitute loc st sb rn u1, substitute loc st sb rn u2) |
679 | | Uwhile(u1, u2) -> |
680 | Uwhile(substitute loc st sb rn u1, substitute loc st sb rn u2) |
681 | | Ufor(id, u1, u2, dir, u3) -> |
682 | let id' = VP.rename id in |
683 | Ufor(id', substitute loc st sb rn u1, substitute loc st sb rn u2, dir, |
684 | substitute loc st |
685 | (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u3) |
686 | | Uassign(id, u) -> |
687 | let id' = |
688 | try |
689 | match V.Map.find id sb with Uvar i -> i | _ -> assert false |
690 | with Not_found -> |
691 | id in |
692 | Uassign(id', substitute loc st sb rn u) |
693 | | Usend(k, u1, u2, ul, dbg) -> |
694 | let dbg = subst_debuginfo loc dbg in |
695 | Usend(k, substitute loc st sb rn u1, substitute loc st sb rn u2, |
696 | List.map (substitute loc st sb rn) ul, dbg) |
697 | | Uunreachable -> |
698 | Uunreachable |
699 | |
700 | (* Perform an inline expansion *) |
701 | |
702 | let is_simple_argument = function |
703 | | Uvar _ | Uconst _ -> true |
704 | | _ -> false |
705 | |
706 | let no_effects = function |
707 | | Uclosure _ -> true |
708 | | u -> is_pure u |
709 | |
710 | let rec bind_params_rec loc fpc subst params args body = |
711 | match (params, args) with |
712 | ([], []) -> substitute loc fpc subst (Some Int.Map.empty) body |
713 | | (p1 :: pl, a1 :: al) -> |
714 | if is_simple_argument a1 then |
715 | bind_params_rec loc fpc (V.Map.add (VP.var p1) a1 subst) |
716 | pl al body |
717 | else begin |
718 | let p1' = VP.rename p1 in |
719 | let u1, u2 = |
720 | match VP.name p1, a1 with |
721 | | "*opt*", Uprim(P.Pmakeblock(0, Immutable, kind), [a], dbg) -> |
722 | a, Uprim(P.Pmakeblock(0, Immutable, kind), |
723 | [Uvar (VP.var p1')], dbg) |
724 | | _ -> |
725 | a1, Uvar (VP.var p1') |
726 | in |
727 | let body' = |
728 | bind_params_rec loc fpc (V.Map.add (VP.var p1) u2 subst) |
729 | pl al body in |
730 | if occurs_var (VP.var p1) body then |
731 | Ulet(Immutable, Pgenval, p1', u1, body') |
732 | else if no_effects a1 then body' |
733 | else Usequence(a1, body') |
734 | end |
735 | | (_, _) -> assert false |
736 | |
737 | let bind_params loc fpc params args body = |
738 | (* Reverse parameters and arguments to preserve right-to-left |
739 | evaluation order (PR#2910). *) |
740 | bind_params_rec loc fpc V.Map.empty (List.rev params) (List.rev args) body |
741 | |
742 | (* Check if a lambda term is ``pure'', |
743 | that is without side-effects *and* not containing function definitions *) |
744 | |
745 | let warning_if_forced_inline ~loc ~attribute warning = |
746 | if attribute = Always_inline then |
747 | Location.prerr_warning loc |
748 | (Warnings.Inlining_impossible warning) |
749 | |
750 | (* Generate a direct application *) |
751 | |
752 | let direct_apply ~backend fundesc ufunct uargs ~loc ~attribute = |
753 | let app_args = |
754 | if fundesc.fun_closed then uargs else uargs @ [ufunct] in |
755 | let app = |
756 | match fundesc.fun_inline, attribute with |
757 | | _, Never_inline | None, _ -> |
758 | let dbg = Debuginfo.from_location loc in |
759 | warning_if_forced_inline ~loc ~attribute |
760 | "Function information unavailable"; |
761 | Udirect_apply(fundesc.fun_label, app_args, dbg) |
762 | | Some(params, body), _ -> |
763 | bind_params loc (backend, fundesc.fun_float_const_prop) params app_args |
764 | body |
765 | in |
766 | (* If ufunct can contain side-effects or function definitions, |
767 | we must make sure that it is evaluated exactly once. |
768 | If the function is not closed, we evaluate ufunct as part of the |
769 | arguments. |
770 | If the function is closed, we force the evaluation of ufunct first. *) |
771 | if not fundesc.fun_closed || is_pure ufunct |
772 | then app |
773 | else Usequence(ufunct, app) |
774 | |
775 | (* Add [Value_integer] or [Value_constptr] info to the approximation |
776 | of an application *) |
777 | |
778 | let strengthen_approx appl approx = |
779 | match approx_ulam appl with |
780 | (Value_const _) as intapprox -> |
781 | intapprox |
782 | | _ -> approx |
783 | |
784 | (* If a term has approximation Value_integer or Value_constptr and is pure, |
785 | replace it by an integer constant *) |
786 | |
787 | let check_constant_result ulam approx = |
788 | match approx with |
789 | Value_const c when is_pure ulam -> make_const c |
790 | | Value_global_field (id, i) when is_pure ulam -> |
791 | begin match ulam with |
792 | | Uprim(P.Pfield _, [Uprim(P.Pread_symbol _, _, _)], _) -> (ulam, approx) |
793 | | _ -> |
794 | let glb = |
795 | Uprim(P.Pread_symbol id, [], Debuginfo.none) |
796 | in |
797 | Uprim(P.Pfield i, [glb], Debuginfo.none), approx |
798 | end |
799 | | _ -> (ulam, approx) |
800 | |
801 | (* Evaluate an expression with known value for its side effects only, |
802 | or discard it if it's pure *) |
803 | |
804 | let sequence_constant_expr ulam1 (ulam2, approx2 as res2) = |
805 | if is_pure ulam1 then res2 else (Usequence(ulam1, ulam2), approx2) |
806 | |
807 | (* Maintain the approximation of the global structure being defined *) |
808 | |
809 | let global_approx = ref([||] : value_approximation array) |
810 | |
811 | (* Maintain the nesting depth for functions *) |
812 | |
813 | let function_nesting_depth = ref 0 |
814 | let excessive_function_nesting_depth = 5 |
815 | |
816 | (* Uncurry an expression and explicitate closures. |
817 | Also return the approximation of the expression. |
818 | The approximation environment [fenv] maps idents to approximations. |
819 | Idents not bound in [fenv] approximate to [Value_unknown]. |
820 | The closure environment [cenv] maps idents to [ulambda] terms. |
821 | It is used to substitute environment accesses for free identifiers. *) |
822 | |
823 | exception NotClosed |
824 | |
825 | type env = { |
826 | backend : (module Backend_intf.S); |
827 | cenv : ulambda V.Map.t; |
828 | fenv : value_approximation V.Map.t; |
829 | } |
830 | |
831 | let close_approx_var { fenv; cenv } id = |
832 | let approx = try V.Map.find id fenv with Not_found -> Value_unknown in |
833 | match approx with |
834 | Value_const c -> make_const c |
835 | | approx -> |
836 | let subst = try V.Map.find id cenv with Not_found -> Uvar id in |
837 | (subst, approx) |
838 | |
839 | let close_var env id = |
840 | let (ulam, _app) = close_approx_var env id in ulam |
841 | |
842 | let rec close ({ backend; fenv; cenv } as env) lam = |
843 | let module B = (val backend : Backend_intf.S) in |
844 | match lam with |
845 | | Lvar id -> |
846 | close_approx_var env id |
847 | | Lconst cst -> |
848 | let str ?(shared = true) cst = |
849 | let name = |
850 | Compilenv.new_structured_constant cst ~shared |
851 | in |
852 | Uconst_ref (name, Some cst) |
853 | in |
854 | let rec transl = function |
855 | | Const_base(Const_int n) -> Uconst_int n |
856 | | Const_base(Const_char c) -> Uconst_int (Char.code c) |
857 | | Const_pointer n -> Uconst_ptr n |
858 | | Const_block (tag, fields) -> |
859 | str (Uconst_block (tag, List.map transl fields)) |
860 | | Const_float_array sl -> |
861 | (* constant float arrays are really immutable *) |
862 | str (Uconst_float_array (List.map float_of_string sl)) |
863 | | Const_immstring s -> |
864 | str (Uconst_string s) |
865 | | Const_base (Const_string (s, _)) -> |
866 | (* Strings (even literal ones) must be assumed to be mutable... |
867 | except when OCaml has been configured with |
868 | -safe-string. Passing -safe-string at compilation |
869 | time is not enough, since the unit could be linked |
870 | with another one compiled without -safe-string, and |
871 | that one could modify our string literal. *) |
872 | str ~shared:Config.safe_string (Uconst_string s) |
873 | | Const_base(Const_float x) -> str (Uconst_float (float_of_string x)) |
874 | | Const_base(Const_int32 x) -> str (Uconst_int32 x) |
875 | | Const_base(Const_int64 x) -> str (Uconst_int64 x) |
876 | | Const_base(Const_nativeint x) -> str (Uconst_nativeint x) |
877 | in |
878 | make_const (transl cst) |
879 | | Lfunction _ as funct -> |
880 | close_one_function env (Ident.create_local "fun") funct |
881 | |
882 | (* We convert [f a] to [let a' = a in let f' = f in fun b c -> f' a' b c] |
883 | when fun_arity > nargs *) |
884 | | Lapply{ap_func = funct; ap_args = args; ap_loc = loc; |
885 | ap_inlined = attribute} -> |
886 | let nargs = List.length args in |
887 | begin match (close env funct, close_list env args) with |
888 | ((ufunct, Value_closure(fundesc, approx_res)), |
889 | [Uprim(P.Pmakeblock _, uargs, _)]) |
890 | when List.length uargs = - fundesc.fun_arity -> |
891 | let app = |
892 | direct_apply ~backend ~loc ~attribute fundesc ufunct uargs in |
893 | (app, strengthen_approx app approx_res) |
894 | | ((ufunct, Value_closure(fundesc, approx_res)), uargs) |
895 | when nargs = fundesc.fun_arity -> |
896 | let app = |
897 | direct_apply ~backend ~loc ~attribute fundesc ufunct uargs in |
898 | (app, strengthen_approx app approx_res) |
899 | |
900 | | ((ufunct, (Value_closure(fundesc, _) as fapprox)), uargs) |
901 | when nargs < fundesc.fun_arity -> |
902 | let first_args = List.map (fun arg -> |
903 | (V.create_local "arg", arg) ) uargs in |
904 | let final_args = |
905 | Array.to_list (Array.init (fundesc.fun_arity - nargs) |
906 | (fun _ -> V.create_local "arg")) in |
907 | let rec iter args body = |
908 | match args with |
909 | [] -> body |
910 | | (arg1, arg2) :: args -> |
911 | iter args |
912 | (Ulet (Immutable, Pgenval, VP.create arg1, arg2, body)) |
913 | in |
914 | let internal_args = |
915 | (List.map (fun (arg1, _arg2) -> Lvar arg1) first_args) |
916 | @ (List.map (fun arg -> Lvar arg ) final_args) |
917 | in |
918 | let funct_var = V.create_local "funct" in |
919 | let fenv = V.Map.add funct_var fapprox fenv in |
920 | let (new_fun, approx) = close { backend; fenv; cenv } |
921 | (Lfunction{ |
922 | kind = Curried; |
923 | return = Pgenval; |
924 | params = List.map (fun v -> v, Pgenval) final_args; |
925 | body = Lapply{ap_should_be_tailcall=false; |
926 | ap_loc=loc; |
927 | ap_func=(Lvar funct_var); |
928 | ap_args=internal_args; |
929 | ap_inlined=Default_inline; |
930 | ap_specialised=Default_specialise}; |
931 | loc; |
932 | attr = default_function_attribute}) |
933 | in |
934 | let new_fun = |
935 | iter first_args |
936 | (Ulet (Immutable, Pgenval, VP.create funct_var, ufunct, new_fun)) |
937 | in |
938 | warning_if_forced_inline ~loc ~attribute "Partial application"; |
939 | (new_fun, approx) |
940 | |
941 | | ((ufunct, Value_closure(fundesc, _approx_res)), uargs) |
942 | when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity -> |
943 | let args = List.map (fun arg -> V.create_local "arg", arg) uargs in |
944 | let (first_args, rem_args) = split_list fundesc.fun_arity args in |
945 | let first_args = List.map (fun (id, _) -> Uvar id) first_args in |
946 | let rem_args = List.map (fun (id, _) -> Uvar id) rem_args in |
947 | let dbg = Debuginfo.from_location loc in |
948 | warning_if_forced_inline ~loc ~attribute "Over-application"; |
949 | let body = |
950 | Ugeneric_apply(direct_apply ~backend ~loc ~attribute |
951 | fundesc ufunct first_args, |
952 | rem_args, dbg) |
953 | in |
954 | let result = |
955 | List.fold_left (fun body (id, defining_expr) -> |
956 | Ulet (Immutable, Pgenval, VP.create id, defining_expr, body)) |
957 | body |
958 | args |
959 | in |
960 | result, Value_unknown |
961 | | ((ufunct, _), uargs) -> |
962 | let dbg = Debuginfo.from_location loc in |
963 | warning_if_forced_inline ~loc ~attribute "Unknown function"; |
964 | (Ugeneric_apply(ufunct, uargs, dbg), Value_unknown) |
965 | end |
966 | | Lsend(kind, met, obj, args, loc) -> |
967 | let (umet, _) = close env met in |
968 | let (uobj, _) = close env obj in |
969 | let dbg = Debuginfo.from_location loc in |
970 | (Usend(kind, umet, uobj, close_list env args, dbg), |
971 | Value_unknown) |
972 | | Llet(str, kind, id, lam, body) -> |
973 | let (ulam, alam) = close_named env id lam in |
974 | begin match (str, alam) with |
975 | (Variable, _) -> |
976 | let (ubody, abody) = close env body in |
977 | (Ulet(Mutable, kind, VP.create id, ulam, ubody), abody) |
978 | | (_, Value_const _) |
979 | when str = Alias || is_pure ulam -> |
980 | close { backend; fenv = (V.Map.add id alam fenv); cenv } body |
981 | | (_, _) -> |
982 | let (ubody, abody) = |
983 | close { backend; fenv = (V.Map.add id alam fenv); cenv } body |
984 | in |
985 | (Ulet(Immutable, kind, VP.create id, ulam, ubody), abody) |
986 | end |
987 | | Lletrec(defs, body) -> |
988 | if List.for_all |
989 | (function (_id, Lfunction _) -> true | _ -> false) |
990 | defs |
991 | then begin |
992 | (* Simple case: only function definitions *) |
993 | let (clos, infos) = close_functions env defs in |
994 | let clos_ident = V.create_local "clos" in |
995 | let fenv_body = |
996 | List.fold_right |
997 | (fun (id, _pos, approx) fenv -> V.Map.add id approx fenv) |
998 | infos fenv in |
999 | let (ubody, approx) = close { backend; fenv = fenv_body; cenv } body in |
1000 | let sb = |
1001 | List.fold_right |
1002 | (fun (id, pos, _approx) sb -> |
1003 | V.Map.add id (Uoffset(Uvar clos_ident, pos)) sb) |
1004 | infos V.Map.empty in |
1005 | (Ulet(Immutable, Pgenval, VP.create clos_ident, clos, |
1006 | substitute Location.none (backend, !Clflags.float_const_prop) sb |
1007 | None ubody), |
1008 | approx) |
1009 | end else begin |
1010 | (* General case: recursive definition of values *) |
1011 | let rec clos_defs = function |
1012 | [] -> ([], fenv) |
1013 | | (id, lam) :: rem -> |
1014 | let (udefs, fenv_body) = clos_defs rem in |
1015 | let (ulam, approx) = close_named env id lam in |
1016 | ((VP.create id, ulam) :: udefs, V.Map.add id approx fenv_body) in |
1017 | let (udefs, fenv_body) = clos_defs defs in |
1018 | let (ubody, approx) = close { backend; fenv = fenv_body; cenv } body in |
1019 | (Uletrec(udefs, ubody), approx) |
1020 | end |
1021 | (* Compile-time constants *) |
1022 | | Lprim(Pctconst c, [arg], _loc) -> |
1023 | let cst, approx = |
1024 | match c with |
1025 | | Big_endian -> make_const_bool B.big_endian |
1026 | | Word_size -> make_const_int (8*B.size_int) |
1027 | | Int_size -> make_const_int (8*B.size_int - 1) |
1028 | | Max_wosize -> make_const_int ((1 lsl ((8*B.size_int) - 10)) - 1 ) |
1029 | | Ostype_unix -> make_const_bool (Sys.os_type = "Unix") |
1030 | | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32") |
1031 | | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin") |
1032 | | Backend_type -> |
1033 | make_const_ptr 0 (* tag 0 is the same as Native here *) |
1034 | in |
1035 | let arg, _approx = close env arg in |
1036 | let id = Ident.create_local "dummy" in |
1037 | Ulet(Immutable, Pgenval, VP.create id, arg, cst), approx |
1038 | | Lprim(Pignore, [arg], _loc) -> |
1039 | let expr, approx = make_const_ptr 0 in |
1040 | Usequence(fst (close env arg), expr), approx |
1041 | | Lprim((Pidentity | Pbytes_to_string | Pbytes_of_string), [arg], _loc) -> |
1042 | close env arg |
1043 | | Lprim(Pdirapply,[funct;arg], loc) |
1044 | | Lprim(Prevapply,[arg;funct], loc) -> |
1045 | close env (Lapply{ap_should_be_tailcall=false; |
1046 | ap_loc=loc; |
1047 | ap_func=funct; |
1048 | ap_args=[arg]; |
1049 | ap_inlined=Default_inline; |
1050 | ap_specialised=Default_specialise}) |
1051 | | Lprim(Pgetglobal id, [], loc) -> |
1052 | let dbg = Debuginfo.from_location loc in |
1053 | check_constant_result (getglobal dbg id) |
1054 | (Compilenv.global_approx id) |
1055 | | Lprim(Pfield n, [lam], loc) -> |
1056 | let (ulam, approx) = close env lam in |
1057 | let dbg = Debuginfo.from_location loc in |
1058 | check_constant_result (Uprim(P.Pfield n, [ulam], dbg)) |
1059 | (field_approx n approx) |
1060 | | Lprim(Psetfield(n, is_ptr, init), [Lprim(Pgetglobal id, [], _); lam], loc)-> |
1061 | let (ulam, approx) = close env lam in |
1062 | if approx <> Value_unknown then |
1063 | (!global_approx).(n) <- approx; |
1064 | let dbg = Debuginfo.from_location loc in |
1065 | (Uprim(P.Psetfield(n, is_ptr, init), [getglobal dbg id; ulam], dbg), |
1066 | Value_unknown) |
1067 | | Lprim(Praise k, [arg], loc) -> |
1068 | let (ulam, _approx) = close env arg in |
1069 | let dbg = Debuginfo.from_location loc in |
1070 | (Uprim(P.Praise k, [ulam], dbg), |
1071 | Value_unknown) |
1072 | | Lprim (Pmakearray _, [], _loc) -> make_const_ref (Uconst_block (0, [])) |
1073 | | Lprim(p, args, loc) -> |
1074 | let p = Convert_primitives.convert p in |
1075 | let dbg = Debuginfo.from_location loc in |
1076 | simplif_prim ~backend !Clflags.float_const_prop |
1077 | p (close_list_approx env args) dbg |
1078 | | Lswitch(arg, sw, dbg) -> |
1079 | let fn fail = |
1080 | let (uarg, _) = close env arg in |
1081 | let const_index, const_actions, fconst = |
1082 | close_switch env sw.sw_consts sw.sw_numconsts fail |
1083 | and block_index, block_actions, fblock = |
1084 | close_switch env sw.sw_blocks sw.sw_numblocks fail in |
1085 | let ulam = |
1086 | Uswitch |
1087 | (uarg, |
1088 | {us_index_consts = const_index; |
1089 | us_actions_consts = const_actions; |
1090 | us_index_blocks = block_index; |
1091 | us_actions_blocks = block_actions}, |
1092 | Debuginfo.from_location dbg) |
1093 | in |
1094 | (fconst (fblock ulam),Value_unknown) in |
1095 | (* NB: failaction might get copied, thus it should be some Lstaticraise *) |
1096 | let fail = sw.sw_failaction in |
1097 | begin match fail with |
1098 | | None|Some (Lstaticraise (_,_)) -> fn fail |
1099 | | Some lamfail -> |
1100 | if |
1101 | (sw.sw_numconsts - List.length sw.sw_consts) + |
1102 | (sw.sw_numblocks - List.length sw.sw_blocks) > 1 |
1103 | then |
1104 | let i = next_raise_count () in |
1105 | let ubody,_ = fn (Some (Lstaticraise (i,[]))) |
1106 | and uhandler,_ = close env lamfail in |
1107 | Ucatch (i,[],ubody,uhandler),Value_unknown |
1108 | else fn fail |
1109 | end |
1110 | | Lstringswitch(arg,sw,d,_) -> |
1111 | let uarg,_ = close env arg in |
1112 | let usw = |
1113 | List.map |
1114 | (fun (s,act) -> |
1115 | let uact,_ = close env act in |
1116 | s,uact) |
1117 | sw in |
1118 | let ud = |
1119 | Option.map |
1120 | (fun d -> |
1121 | let ud,_ = close env d in |
1122 | ud) d in |
1123 | Ustringswitch (uarg,usw,ud),Value_unknown |
1124 | | Lstaticraise (i, args) -> |
1125 | (Ustaticfail (i, close_list env args), Value_unknown) |
1126 | | Lstaticcatch(body, (i, vars), handler) -> |
1127 | let (ubody, _) = close env body in |
1128 | let (uhandler, _) = close env handler in |
1129 | let vars = List.map (fun (var, k) -> VP.create var, k) vars in |
1130 | (Ucatch(i, vars, ubody, uhandler), Value_unknown) |
1131 | | Ltrywith(body, id, handler) -> |
1132 | let (ubody, _) = close env body in |
1133 | let (uhandler, _) = close env handler in |
1134 | (Utrywith(ubody, VP.create id, uhandler), Value_unknown) |
1135 | | Lifthenelse(arg, ifso, ifnot) -> |
1136 | begin match close env arg with |
1137 | (uarg, Value_const (Uconst_ptr n)) -> |
1138 | sequence_constant_expr uarg |
1139 | (close env (if n = 0 then ifnot else ifso)) |
1140 | | (uarg, _ ) -> |
1141 | let (uifso, _) = close env ifso in |
1142 | let (uifnot, _) = close env ifnot in |
1143 | (Uifthenelse(uarg, uifso, uifnot), Value_unknown) |
1144 | end |
1145 | | Lsequence(lam1, lam2) -> |
1146 | let (ulam1, _) = close env lam1 in |
1147 | let (ulam2, approx) = close env lam2 in |
1148 | (Usequence(ulam1, ulam2), approx) |
1149 | | Lwhile(cond, body) -> |
1150 | let (ucond, _) = close env cond in |
1151 | let (ubody, _) = close env body in |
1152 | (Uwhile(ucond, ubody), Value_unknown) |
1153 | | Lfor(id, lo, hi, dir, body) -> |
1154 | let (ulo, _) = close env lo in |
1155 | let (uhi, _) = close env hi in |
1156 | let (ubody, _) = close env body in |
1157 | (Ufor(VP.create id, ulo, uhi, dir, ubody), Value_unknown) |
1158 | | Lassign(id, lam) -> |
1159 | let (ulam, _) = close env lam in |
1160 | (Uassign(id, ulam), Value_unknown) |
1161 | | Levent(lam, _) -> |
1162 | close env lam |
1163 | | Lifused _ -> |
1164 | assert false |
1165 | |
1166 | and close_list env = function |
1167 | [] -> [] |
1168 | | lam :: rem -> |
1169 | let (ulam, _) = close env lam in |
1170 | ulam :: close_list env rem |
1171 | |
1172 | and close_list_approx env = function |
1173 | [] -> ([], []) |
1174 | | lam :: rem -> |
1175 | let (ulam, approx) = close env lam in |
1176 | let (ulams, approxs) = close_list_approx env rem in |
1177 | (ulam :: ulams, approx :: approxs) |
1178 | |
1179 | and close_named env id = function |
1180 | Lfunction _ as funct -> |
1181 | close_one_function env id funct |
1182 | | lam -> |
1183 | close env lam |
1184 | |
1185 | (* Build a shared closure for a set of mutually recursive functions *) |
1186 | |
1187 | and close_functions { backend; fenv; cenv } fun_defs = |
1188 | let fun_defs = |
1189 | List.flatten |
1190 | (List.map |
1191 | (function |
1192 | | (id, Lfunction{kind; params; return; body; attr; loc}) -> |
1193 | Simplif.split_default_wrapper ~id ~kind ~params |
1194 | ~body ~attr ~loc ~return |
1195 | | _ -> assert false |
1196 | ) |
1197 | fun_defs) |
1198 | in |
1199 | let inline_attribute = match fun_defs with |
1200 | | [_, Lfunction{attr = { inline; }}] -> inline |
1201 | | _ -> Default_inline (* recursive functions can't be inlined *) |
1202 | in |
1203 | (* Update and check nesting depth *) |
1204 | incr function_nesting_depth; |
1205 | let initially_closed = |
1206 | !function_nesting_depth < excessive_function_nesting_depth in |
1207 | (* Determine the free variables of the functions *) |
1208 | let fv = |
1209 | V.Set.elements (free_variables (Lletrec(fun_defs, lambda_unit))) in |
1210 | (* Build the function descriptors for the functions. |
1211 | Initially all functions are assumed not to need their environment |
1212 | parameter. *) |
1213 | let uncurried_defs = |
1214 | List.map |
1215 | (function |
1216 | (id, Lfunction{kind; params; return; body; loc}) -> |
1217 | let label = Compilenv.make_symbol (Some (V.unique_name id)) in |
1218 | let arity = List.length params in |
1219 | let fundesc = |
1220 | {fun_label = label; |
1221 | fun_arity = (if kind = Tupled then -arity else arity); |
1222 | fun_closed = initially_closed; |
1223 | fun_inline = None; |
1224 | fun_float_const_prop = !Clflags.float_const_prop } in |
1225 | let dbg = Debuginfo.from_location loc in |
1226 | (id, params, return, body, fundesc, dbg) |
1227 | | (_, _) -> fatal_error "Closure.close_functions") |
1228 | fun_defs in |
1229 | (* Build an approximate fenv for compiling the functions *) |
1230 | let fenv_rec = |
1231 | List.fold_right |
1232 | (fun (id, _params, _return, _body, fundesc, _dbg) fenv -> |
1233 | V.Map.add id (Value_closure(fundesc, Value_unknown)) fenv) |
1234 | uncurried_defs fenv in |
1235 | (* Determine the offsets of each function's closure in the shared block *) |
1236 | let env_pos = ref (-1) in |
1237 | let clos_offsets = |
1238 | List.map |
1239 | (fun (_id, _params, _return, _body, fundesc, _dbg) -> |
1240 | let pos = !env_pos + 1 in |
1241 | env_pos := !env_pos + 1 + (if fundesc.fun_arity <> 1 then 3 else 2); |
1242 | pos) |
1243 | uncurried_defs in |
1244 | let fv_pos = !env_pos in |
1245 | (* This reference will be set to false if the hypothesis that a function |
1246 | does not use its environment parameter is invalidated. *) |
1247 | let useless_env = ref initially_closed in |
1248 | (* Translate each function definition *) |
1249 | let clos_fundef (id, params, return, body, fundesc, dbg) env_pos = |
1250 | let env_param = V.create_local "env" in |
1251 | let cenv_fv = |
1252 | build_closure_env env_param (fv_pos - env_pos) fv in |
1253 | let cenv_body = |
1254 | List.fold_right2 |
1255 | (fun (id, _params, _return, _body, _fundesc, _dbg) pos env -> |
1256 | V.Map.add id (Uoffset(Uvar env_param, pos - env_pos)) env) |
1257 | uncurried_defs clos_offsets cenv_fv in |
1258 | let (ubody, approx) = |
1259 | close { backend; fenv = fenv_rec; cenv = cenv_body } body |
1260 | in |
1261 | if !useless_env && occurs_var env_param ubody then raise NotClosed; |
1262 | let fun_params = |
1263 | if !useless_env |
1264 | then params |
1265 | else params @ [env_param, Pgenval] |
1266 | in |
1267 | let f = |
1268 | { |
1269 | label = fundesc.fun_label; |
1270 | arity = fundesc.fun_arity; |
1271 | params = List.map (fun (var, kind) -> VP.create var, kind) fun_params; |
1272 | return; |
1273 | body = ubody; |
1274 | dbg; |
1275 | env = Some env_param; |
1276 | } |
1277 | in |
1278 | (* give more chance of function with default parameters (i.e. |
1279 | their wrapper functions) to be inlined *) |
1280 | let n = |
1281 | List.fold_left |
1282 | (fun n (id, _) -> n + if V.name id = "*opt*" then 8 else 1) |
1283 | 0 |
1284 | fun_params |
1285 | in |
1286 | let threshold = |
1287 | match inline_attribute with |
1288 | | Default_inline -> |
1289 | let inline_threshold = |
1290 | Clflags.Float_arg_helper.get ~key:0 !Clflags.inline_threshold |
1291 | in |
1292 | let magic_scale_constant = 8. in |
1293 | int_of_float (inline_threshold *. magic_scale_constant) + n |
1294 | | Always_inline -> max_int |
1295 | | Never_inline -> min_int |
1296 | | Unroll _ -> assert false |
1297 | in |
1298 | let fun_params = List.map (fun (var, _) -> VP.create var) fun_params in |
1299 | if lambda_smaller ubody threshold |
1300 | then fundesc.fun_inline <- Some(fun_params, ubody); |
1301 | |
1302 | (f, (id, env_pos, Value_closure(fundesc, approx))) in |
1303 | (* Translate all function definitions. *) |
1304 | let clos_info_list = |
1305 | if initially_closed then begin |
1306 | let snap = Compilenv.snapshot () in |
1307 | try List.map2 clos_fundef uncurried_defs clos_offsets |
1308 | with NotClosed -> |
1309 | (* If the hypothesis that the environment parameters are useless has been |
1310 | invalidated, then set [fun_closed] to false in all descriptions and |
1311 | recompile *) |
1312 | Compilenv.backtrack snap; (* PR#6337 *) |
1313 | List.iter |
1314 | (fun (_id, _params, _return, _body, fundesc, _dbg) -> |
1315 | fundesc.fun_closed <- false; |
1316 | fundesc.fun_inline <- None; |
1317 | ) |
1318 | uncurried_defs; |
1319 | useless_env := false; |
1320 | List.map2 clos_fundef uncurried_defs clos_offsets |
1321 | end else |
1322 | (* Excessive closure nesting: assume environment parameter is used *) |
1323 | List.map2 clos_fundef uncurried_defs clos_offsets |
1324 | in |
1325 | (* Update nesting depth *) |
1326 | decr function_nesting_depth; |
1327 | (* Return the Uclosure node and the list of all identifiers defined, |
1328 | with offsets and approximations. *) |
1329 | let (clos, infos) = List.split clos_info_list in |
1330 | let fv = if !useless_env then [] else fv in |
1331 | (Uclosure(clos, List.map (close_var { backend; fenv; cenv }) fv), infos) |
1332 | |
1333 | (* Same, for one non-recursive function *) |
1334 | |
1335 | and close_one_function env id funct = |
1336 | match close_functions env [id, funct] with |
1337 | | (clos, (i, _, approx) :: _) when id = i -> (clos, approx) |
1338 | | _ -> fatal_error "Closure.close_one_function" |
1339 | |
1340 | (* Close a switch *) |
1341 | |
1342 | and close_switch env cases num_keys default = |
1343 | let ncases = List.length cases in |
1344 | let index = Array.make num_keys 0 |
1345 | and store = Storer.mk_store () in |
1346 | |
1347 | (* First default case *) |
1348 | begin match default with |
1349 | | Some def when ncases < num_keys -> |
1350 | assert (store.act_store () def = 0) |
1351 | | _ -> () |
1352 | end ; |
1353 | (* Then all other cases *) |
1354 | List.iter |
1355 | (fun (key,lam) -> |
1356 | index.(key) <- store.act_store () lam) |
1357 | cases ; |
1358 | |
1359 | (* Explicit sharing with catch/exit, as switcher compilation may |
1360 | later unshare *) |
1361 | let acts = store.act_get_shared () in |
1362 | let hs = ref (fun e -> e) in |
1363 | |
1364 | (* Compile actions *) |
1365 | let actions = |
1366 | Array.map |
1367 | (function |
1368 | | Single lam|Shared (Lstaticraise (_,[]) as lam) -> |
1369 | let ulam,_ = close env lam in |
1370 | ulam |
1371 | | Shared lam -> |
1372 | let ulam,_ = close env lam in |
1373 | let i = next_raise_count () in |
1374 | (* |
1375 | let string_of_lambda e = |
1376 | Printlambda.lambda Format.str_formatter e ; |
1377 | Format.flush_str_formatter () in |
1378 | Printf.eprintf "SHARE CLOSURE %i [%s]\n%s\n" i |
1379 | (string_of_lambda arg) |
1380 | (string_of_lambda lam) ; |
1381 | *) |
1382 | let ohs = !hs in |
1383 | hs := (fun e -> Ucatch (i,[],ohs e,ulam)) ; |
1384 | Ustaticfail (i,[])) |
1385 | acts in |
1386 | match actions with |
1387 | | [| |] -> [| |], [| |], !hs (* May happen when default is None *) |
1388 | | _ -> index, actions, !hs |
1389 | |
1390 | |
1391 | (* Collect exported symbols for structured constants *) |
1392 | |
1393 | let collect_exported_structured_constants a = |
1394 | let rec approx = function |
1395 | | Value_closure (fd, a) -> |
1396 | approx a; |
1397 | begin match fd.fun_inline with |
1398 | | Some (_, u) -> ulam u |
1399 | | None -> () |
1400 | end |
1401 | | Value_tuple a -> Array.iter approx a |
1402 | | Value_const c -> const c |
1403 | | Value_unknown | Value_global_field _ -> () |
1404 | and const = function |
1405 | | Uconst_ref (s, (Some c)) -> |
1406 | Compilenv.add_exported_constant s; |
1407 | structured_constant c |
1408 | | Uconst_ref (_s, None) -> assert false (* Cannot be generated *) |
1409 | | Uconst_int _ | Uconst_ptr _ -> () |
1410 | and structured_constant = function |
1411 | | Uconst_block (_, ul) -> List.iter const ul |
1412 | | Uconst_float _ | Uconst_int32 _ |
1413 | | Uconst_int64 _ | Uconst_nativeint _ |
1414 | | Uconst_float_array _ | Uconst_string _ -> () |
1415 | | Uconst_closure _ -> assert false (* Cannot be generated *) |
1416 | and ulam = function |
1417 | | Uvar _ -> () |
1418 | | Uconst c -> const c |
1419 | | Udirect_apply (_, ul, _) -> List.iter ulam ul |
1420 | | Ugeneric_apply (u, ul, _) -> ulam u; List.iter ulam ul |
1421 | | Uclosure (fl, ul) -> |
1422 | List.iter (fun f -> ulam f.body) fl; |
1423 | List.iter ulam ul |
1424 | | Uoffset(u, _) -> ulam u |
1425 | | Ulet (_str, _kind, _, u1, u2) -> ulam u1; ulam u2 |
1426 | | Uphantom_let _ -> no_phantom_lets () |
1427 | | Uletrec (l, u) -> List.iter (fun (_, u) -> ulam u) l; ulam u |
1428 | | Uprim (_, ul, _) -> List.iter ulam ul |
1429 | | Uswitch (u, sl, _dbg) -> |
1430 | ulam u; |
1431 | Array.iter ulam sl.us_actions_consts; |
1432 | Array.iter ulam sl.us_actions_blocks |
1433 | | Ustringswitch (u,sw,d) -> |
1434 | ulam u ; |
1435 | List.iter (fun (_,act) -> ulam act) sw ; |
1436 | Option.iter ulam d |
1437 | | Ustaticfail (_, ul) -> List.iter ulam ul |
1438 | | Ucatch (_, _, u1, u2) |
1439 | | Utrywith (u1, _, u2) |
1440 | | Usequence (u1, u2) |
1441 | | Uwhile (u1, u2) -> ulam u1; ulam u2 |
1442 | | Uifthenelse (u1, u2, u3) |
1443 | | Ufor (_, u1, u2, _, u3) -> ulam u1; ulam u2; ulam u3 |
1444 | | Uassign (_, u) -> ulam u |
1445 | | Usend (_, u1, u2, ul, _) -> ulam u1; ulam u2; List.iter ulam ul |
1446 | | Uunreachable -> () |
1447 | in |
1448 | approx a |
1449 | |
1450 | let reset () = |
1451 | global_approx := [||]; |
1452 | function_nesting_depth := 0 |
1453 | |
1454 | (* The entry point *) |
1455 | |
1456 | let intro ~backend ~size lam = |
1457 | reset (); |
1458 | let id = Compilenv.make_symbol None in |
1459 | global_approx := Array.init size (fun i -> Value_global_field (id, i)); |
1460 | Compilenv.set_global_approx(Value_tuple !global_approx); |
1461 | let (ulam, _approx) = |
1462 | close { backend; fenv = V.Map.empty; cenv = V.Map.empty } lam |
1463 | in |
1464 | let opaque = |
1465 | !Clflags.opaque |
1466 | || Env.is_imported_opaque (Compilenv.current_unit_name ()) |
1467 | in |
1468 | if opaque |
1469 | then Compilenv.set_global_approx(Value_unknown) |
1470 | else collect_exported_structured_constants (Value_tuple !global_approx); |
1471 | global_approx := [||]; |
1472 | ulam |
1473 |