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