1 (***********************************************************************)
5 (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
7 (* Copyright 1996 Institut National de Recherche en Informatique et *)
8 (* en Automatique. All rights reserved. This file is distributed *)
9 (* under the terms of the Q Public License version 1.0. *)
11 (***********************************************************************)
13 (* $Id: closure.ml 8966 2008-08-01 12:52:14Z xleroy $ *)
15 (* Introduction of closures, uncurrying, recognition of direct calls *)
24 (* Auxiliaries for compiling functions *)
26 let rec split_list n l =
27 if n <= 0 then ([], l) else begin
29 [] -> fatal_error "Closure.split_list"
30 | a::l -> let (l1, l2) = split_list (n-1) l in (a::l1, l2)
33 let rec build_closure_env env_param pos = function
36 Tbl.add id (Uprim(Pfield pos, [Uvar env_param], Debuginfo.none))
37 (build_closure_env env_param (pos+1) rem)
39 (* Auxiliary for accessing globals. We change the name of the global
40 to the name of the corresponding asm symbol. This is done here
41 and no longer in Cmmgen so that approximations stored in .cmx files
42 contain the right names if the -for-pack option is active. *)
45 Uprim(Pgetglobal (Ident.create_persistent (Compilenv.symbol_for_global id)),
48 (* Check if a variable occurs in a [clambda] term. *)
50 let occurs_var var u =
51 let rec occurs = function
54 | Udirect_apply(lbl, args, _) -> List.exists occurs args
55 | Ugeneric_apply(funct, args, _) -> occurs funct || List.exists occurs args
56 | Uclosure(fundecls, clos) -> List.exists occurs clos
57 | Uoffset(u, ofs) -> occurs u
58 | Ulet(id, def, body) -> occurs def || occurs body
59 | Uletrec(decls, body) ->
60 List.exists (fun (id, u) -> occurs u) decls || occurs body
61 | Uprim(p, args, _) -> List.exists occurs args
64 occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks
65 | Ustaticfail (_, args) -> List.exists occurs args
66 | Ucatch(_, _, body, hdlr) -> occurs body || occurs hdlr
67 | Utrywith(body, exn, hdlr) -> occurs body || occurs hdlr
68 | Uifthenelse(cond, ifso, ifnot) ->
69 occurs cond || occurs ifso || occurs ifnot
70 | Usequence(u1, u2) -> occurs u1 || occurs u2
71 | Uwhile(cond, body) -> occurs cond || occurs body
72 | Ufor(id, lo, hi, dir, body) -> occurs lo || occurs hi || occurs body
73 | Uassign(id, u) -> id = var || occurs u
74 | Usend(_, met, obj, args, _) ->
75 occurs met || occurs obj || List.exists occurs args
78 for i = 0 to Array.length a - 1 do
79 if occurs a.(i) then raise Exit
86 (* Determine whether the estimated size of a clambda term is below
89 let prim_size prim args =
94 | Pmakeblock(tag, mut) -> 5 + List.length args
96 | Psetfield(f, isptr) -> if isptr then 4 else 1
98 | Psetfloatfield f -> 1
99 | Pduprecord _ -> 10 + List.length args
100 | Pccall p -> (if p.prim_alloc then 10 else 4) + List.length args
103 | Pstringrefs | Pstringsets -> 6
104 | Pmakearray kind -> 5 + List.length args
105 | Parraylength kind -> if kind = Pgenarray then 6 else 2
106 | Parrayrefu kind -> if kind = Pgenarray then 12 else 2
107 | Parraysetu kind -> if kind = Pgenarray then 16 else 4
108 | Parrayrefs kind -> if kind = Pgenarray then 18 else 8
109 | Parraysets kind -> if kind = Pgenarray then 22 else 10
111 | Pbigarrayref(_, ndims, _, _) -> 4 + ndims * 6
112 | Pbigarrayset(_, ndims, _, _) -> 4 + ndims * 6
113 | _ -> 2 (* arithmetic and comparisons *)
115 (* Very raw approximation of switch cost *)
117 let lambda_smaller lam threshold =
119 let rec lambda_size lam =
120 if !size > threshold then raise Exit;
123 | Uconst(Const_base(Const_int _ | Const_char _ | Const_float _ |
124 Const_int32 _ | Const_int64 _ | Const_nativeint _) |
125 Const_pointer _) -> incr size
127 raise Exit (* avoid duplication of structured constants *)
128 | Udirect_apply(fn, args, _) ->
129 size := !size + 4; lambda_list_size args
130 | Ugeneric_apply(fn, args, _) ->
131 size := !size + 6; lambda_size fn; lambda_list_size args
132 | Uclosure(defs, vars) ->
133 raise Exit (* inlining would duplicate function definitions *)
134 | Uoffset(lam, ofs) ->
135 incr size; lambda_size lam
136 | Ulet(id, lam, body) ->
137 lambda_size lam; lambda_size body
138 | Uletrec(bindings, body) ->
139 raise Exit (* usually too large *)
140 | Uprim(prim, args, _) ->
141 size := !size + prim_size prim args;
142 lambda_list_size args
143 | Uswitch(lam, cases) ->
144 if Array.length cases.us_actions_consts > 1 then size := !size + 5 ;
145 if Array.length cases.us_actions_blocks > 1 then size := !size + 5 ;
147 lambda_array_size cases.us_actions_consts ;
148 lambda_array_size cases.us_actions_blocks
149 | Ustaticfail (_,args) -> lambda_list_size args
150 | Ucatch(_, _, body, handler) ->
151 incr size; lambda_size body; lambda_size handler
152 | Utrywith(body, id, handler) ->
153 size := !size + 8; lambda_size body; lambda_size handler
154 | Uifthenelse(cond, ifso, ifnot) ->
156 lambda_size cond; lambda_size ifso; lambda_size ifnot
157 | Usequence(lam1, lam2) ->
158 lambda_size lam1; lambda_size lam2
159 | Uwhile(cond, body) ->
160 size := !size + 2; lambda_size cond; lambda_size body
161 | Ufor(id, low, high, dir, body) ->
162 size := !size + 4; lambda_size low; lambda_size high; lambda_size body
163 | Uassign(id, lam) ->
164 incr size; lambda_size lam
165 | Usend(_, met, obj, args, _) ->
167 lambda_size met; lambda_size obj; lambda_list_size args
168 and lambda_list_size l = List.iter lambda_size l
169 and lambda_array_size a = Array.iter lambda_size a in
171 lambda_size lam; !size <= threshold
175 (* Check if a clambda term is ``pure'',
176 that is without side-effects *and* not containing function definitions *)
178 let rec is_pure_clambda = function
181 | Uprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ |
182 Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets |
183 Parraysetu _ | Parraysets _ | Pbigarrayset _), _, _) -> false
184 | Uprim(p, args, _) -> List.for_all is_pure_clambda args
187 (* Simplify primitive operations on integers *)
189 let make_const_int n = (Uconst(Const_base(Const_int n)), Value_integer n)
190 let make_const_ptr n = (Uconst(Const_pointer n), Value_constptr n)
191 let make_const_bool b = make_const_ptr(if b then 1 else 0)
193 let simplif_prim_pure p (args, approxs) dbg =
197 Pidentity -> make_const_int x
198 | Pnegint -> make_const_int (-x)
199 | Poffsetint y -> make_const_int (x + y)
200 | _ -> (Uprim(p, args, dbg), Value_unknown)
202 | [Value_integer x; Value_integer y] ->
204 Paddint -> make_const_int(x + y)
205 | Psubint -> make_const_int(x - y)
206 | Pmulint -> make_const_int(x * y)
207 | Pdivint when y <> 0 -> make_const_int(x / y)
208 | Pmodint when y <> 0 -> make_const_int(x mod y)
209 | Pandint -> make_const_int(x land y)
210 | Porint -> make_const_int(x lor y)
211 | Pxorint -> make_const_int(x lxor y)
212 | Plslint -> make_const_int(x lsl y)
213 | Plsrint -> make_const_int(x lsr y)
214 | Pasrint -> make_const_int(x asr y)
216 let result = match cmp with
223 make_const_bool result
224 | _ -> (Uprim(p, args, dbg), Value_unknown)
226 | [Value_constptr x] ->
228 Pidentity -> make_const_ptr x
229 | Pnot -> make_const_bool(x = 0)
230 | Pisint -> make_const_bool true
231 | _ -> (Uprim(p, args, dbg), Value_unknown)
233 | [Value_constptr x; Value_constptr y] ->
235 Psequand -> make_const_bool(x <> 0 && y <> 0)
236 | Psequor -> make_const_bool(x <> 0 || y <> 0)
237 | _ -> (Uprim(p, args, dbg), Value_unknown)
240 (Uprim(p, args, dbg), Value_unknown)
242 let simplif_prim p (args, approxs as args_approxs) dbg =
243 if List.for_all is_pure_clambda args
244 then simplif_prim_pure p args_approxs dbg
245 else (Uprim(p, args, dbg), Value_unknown)
247 (* Substitute variables in a [ulambda] term (a body of an inlined function)
248 and perform some more simplifications on integer primitives.
249 Also perform alpha-conversion on let-bound identifiers to avoid
250 clashes with locally-generated identifiers.
251 The variables must not be assigned in the term.
252 This is used to substitute "trivial" arguments for parameters
253 during inline expansion, and also for the translation of let rec
256 let approx_ulam = function
257 Uconst(Const_base(Const_int n)) -> Value_integer n
258 | Uconst(Const_base(Const_char c)) -> Value_integer(Char.code c)
259 | Uconst(Const_pointer n) -> Value_constptr n
262 let rec substitute sb ulam =
265 begin try Tbl.find v sb with Not_found -> ulam end
267 | Udirect_apply(lbl, args, dbg) ->
268 Udirect_apply(lbl, List.map (substitute sb) args, dbg)
269 | Ugeneric_apply(fn, args, dbg) ->
270 Ugeneric_apply(substitute sb fn, List.map (substitute sb) args, dbg)
271 | Uclosure(defs, env) ->
272 (* Question: should we rename function labels as well? Otherwise,
273 there is a risk that function labels are not globally unique.
274 This should not happen in the current system because:
275 - Inlined function bodies contain no Uclosure nodes
276 (cf. function [lambda_smaller])
277 - When we substitute offsets for idents bound by let rec
278 in [close], case [Lletrec], we discard the original
279 let rec body and use only the substituted term. *)
280 Uclosure(defs, List.map (substitute sb) env)
281 | Uoffset(u, ofs) -> Uoffset(substitute sb u, ofs)
282 | Ulet(id, u1, u2) ->
283 let id' = Ident.rename id in
284 Ulet(id', substitute sb u1, substitute (Tbl.add id (Uvar id') sb) u2)
285 | Uletrec(bindings, body) ->
287 List.map (fun (id, rhs) -> (id, Ident.rename id, rhs)) bindings in
290 (fun (id, id', _) s -> Tbl.add id (Uvar id') s)
293 List.map (fun (id, id', rhs) -> (id', substitute sb' rhs)) bindings1,
295 | Uprim(p, args, dbg) ->
296 let sargs = List.map (substitute sb) args in
297 let (res, _) = simplif_prim p (sargs, List.map approx_ulam sargs) dbg in
299 | Uswitch(arg, sw) ->
300 Uswitch(substitute sb arg,
303 Array.map (substitute sb) sw.us_actions_consts;
305 Array.map (substitute sb) sw.us_actions_blocks;
307 | Ustaticfail (nfail, args) ->
308 Ustaticfail (nfail, List.map (substitute sb) args)
309 | Ucatch(nfail, ids, u1, u2) ->
310 Ucatch(nfail, ids, substitute sb u1, substitute sb u2)
311 | Utrywith(u1, id, u2) ->
312 let id' = Ident.rename id in
313 Utrywith(substitute sb u1, id', substitute (Tbl.add id (Uvar id') sb) u2)
314 | Uifthenelse(u1, u2, u3) ->
315 begin match substitute sb u1 with
316 Uconst(Const_pointer n) ->
317 if n <> 0 then substitute sb u2 else substitute sb u3
319 Uifthenelse(su1, substitute sb u2, substitute sb u3)
321 | Usequence(u1, u2) -> Usequence(substitute sb u1, substitute sb u2)
322 | Uwhile(u1, u2) -> Uwhile(substitute sb u1, substitute sb u2)
323 | Ufor(id, u1, u2, dir, u3) ->
324 let id' = Ident.rename id in
325 Ufor(id', substitute sb u1, substitute sb u2, dir,
326 substitute (Tbl.add id (Uvar id') sb) u3)
330 match Tbl.find id sb with Uvar i -> i | _ -> assert false
333 Uassign(id', substitute sb u)
334 | Usend(k, u1, u2, ul, dbg) ->
335 Usend(k, substitute sb u1, substitute sb u2, List.map (substitute sb) ul, dbg)
337 (* Perform an inline expansion *)
339 let is_simple_argument = function
341 | Uconst(Const_base(Const_int _ | Const_char _ | Const_float _ |
342 Const_int32 _ | Const_int64 _ | Const_nativeint _)) ->
344 | Uconst(Const_pointer _) -> true
347 let no_effects = function
349 | Uconst(Const_base(Const_string _)) -> true
350 | u -> is_simple_argument u
352 let rec bind_params_rec subst params args body =
353 match (params, args) with
354 ([], []) -> substitute subst body
355 | (p1 :: pl, a1 :: al) ->
356 if is_simple_argument a1 then
357 bind_params_rec (Tbl.add p1 a1 subst) pl al body
359 let p1' = Ident.rename p1 in
361 bind_params_rec (Tbl.add p1 (Uvar p1') subst) pl al body in
362 if occurs_var p1 body then Ulet(p1', a1, body')
363 else if no_effects a1 then body'
364 else Usequence(a1, body')
366 | (_, _) -> assert false
368 let bind_params params args body =
369 (* Reverse parameters and arguments to preserve right-to-left
370 evaluation order (PR#2910). *)
371 bind_params_rec Tbl.empty (List.rev params) (List.rev args) body
373 (* Check if a lambda term is ``pure'',
374 that is without side-effects *and* not containing function definitions *)
376 let rec is_pure = function
379 | Lprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ |
380 Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets |
381 Parraysetu _ | Parraysets _ | Pbigarrayset _), _) -> false
382 | Lprim(p, args) -> List.for_all is_pure args
383 | Levent(lam, ev) -> is_pure lam
386 (* Generate a direct application *)
388 let direct_apply fundesc funct ufunct uargs =
390 if fundesc.fun_closed then uargs else uargs @ [ufunct] in
392 match fundesc.fun_inline with
393 None -> Udirect_apply(fundesc.fun_label, app_args, Debuginfo.none)
394 | Some(params, body) -> bind_params params app_args body in
395 (* If ufunct can contain side-effects or function definitions,
396 we must make sure that it is evaluated exactly once.
397 If the function is not closed, we evaluate ufunct as part of the
399 If the function is closed, we force the evaluation of ufunct first. *)
400 if not fundesc.fun_closed || is_pure funct
402 else Usequence(ufunct, app)
404 (* Add [Value_integer] or [Value_constptr] info to the approximation
407 let strengthen_approx appl approx =
408 match approx_ulam appl with
409 (Value_integer _ | Value_constptr _) as intapprox -> intapprox
412 (* If a term has approximation Value_integer or Value_constptr and is pure,
413 replace it by an integer constant *)
415 let check_constant_result lam ulam approx =
417 Value_integer n when is_pure lam -> make_const_int n
418 | Value_constptr n when is_pure lam -> make_const_ptr n
419 | _ -> (ulam, approx)
421 (* Evaluate an expression with known value for its side effects only,
422 or discard it if it's pure *)
424 let sequence_constant_expr lam ulam1 (ulam2, approx2 as res2) =
425 if is_pure lam then res2 else (Usequence(ulam1, ulam2), approx2)
427 (* Maintain the approximation of the global structure being defined *)
429 let global_approx = ref([||] : value_approximation array)
431 (* Maintain the nesting depth for functions *)
433 let function_nesting_depth = ref 0
434 let excessive_function_nesting_depth = 5
436 (* Decorate clambda term with debug information *)
438 let rec add_debug_info ev u =
439 match ev.lev_kind with
442 | Udirect_apply(lbl, args, dinfo) ->
443 Udirect_apply(lbl, args, Debuginfo.from_call ev)
444 | Ugeneric_apply(Udirect_apply(lbl, args1, dinfo1),
446 Ugeneric_apply(Udirect_apply(lbl, args1, Debuginfo.from_call ev),
447 args2, Debuginfo.from_call ev)
448 | Ugeneric_apply(fn, args, dinfo) ->
449 Ugeneric_apply(fn, args, Debuginfo.from_call ev)
450 | Uprim(Praise, args, dinfo) ->
451 Uprim(Praise, args, Debuginfo.from_call ev)
452 | Uprim(p, args, dinfo) ->
453 Uprim(p, args, Debuginfo.from_call ev)
454 | Usend(kind, u1, u2, args, dinfo) ->
455 Usend(kind, u1, u2, args, Debuginfo.from_call ev)
456 | Usequence(u1, u2) ->
457 Usequence(u1, add_debug_info ev u2)
462 (* Uncurry an expression and explicitate closures.
463 Also return the approximation of the expression.
464 The approximation environment [fenv] maps idents to approximations.
465 Idents not bound in [fenv] approximate to [Value_unknown].
466 The closure environment [cenv] maps idents to [ulambda] terms.
467 It is used to substitute environment accesses for free identifiers. *)
469 let close_approx_var fenv cenv id =
470 let approx = try Tbl.find id fenv with Not_found -> Value_unknown in
474 | Value_constptr n ->
477 let subst = try Tbl.find id cenv with Not_found -> Uvar id in
480 let close_var fenv cenv id =
481 let (ulam, app) = close_approx_var fenv cenv id in ulam
483 let rec close fenv cenv = function
485 close_approx_var fenv cenv id
488 Const_base(Const_int n) -> (Uconst cst, Value_integer n)
489 | Const_base(Const_char c) -> (Uconst cst, Value_integer(Char.code c))
490 | Const_pointer n -> (Uconst cst, Value_constptr n)
491 | _ -> (Uconst cst, Value_unknown)
493 | Lfunction(kind, params, body) as funct ->
494 close_one_function fenv cenv (Ident.create "fun") funct
495 | Lapply(funct, args, loc) ->
496 let nargs = List.length args in
497 begin match (close fenv cenv funct, close_list fenv cenv args) with
498 ((ufunct, Value_closure(fundesc, approx_res)),
499 [Uprim(Pmakeblock(_, _), uargs, _)])
500 when List.length uargs = - fundesc.fun_arity ->
501 let app = direct_apply fundesc funct ufunct uargs in
502 (app, strengthen_approx app approx_res)
503 | ((ufunct, Value_closure(fundesc, approx_res)), uargs)
504 when nargs = fundesc.fun_arity ->
505 let app = direct_apply fundesc funct ufunct uargs in
506 (app, strengthen_approx app approx_res)
507 | ((ufunct, Value_closure(fundesc, approx_res)), uargs)
508 when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity ->
509 let (first_args, rem_args) = split_list fundesc.fun_arity uargs in
510 (Ugeneric_apply(direct_apply fundesc funct ufunct first_args,
511 rem_args, Debuginfo.none),
513 | ((ufunct, _), uargs) ->
514 (Ugeneric_apply(ufunct, uargs, Debuginfo.none), Value_unknown)
516 | Lsend(kind, met, obj, args) ->
517 let (umet, _) = close fenv cenv met in
518 let (uobj, _) = close fenv cenv obj in
519 (Usend(kind, umet, uobj, close_list fenv cenv args, Debuginfo.none),
521 | Llet(str, id, lam, body) ->
522 let (ulam, alam) = close_named fenv cenv id lam in
523 begin match (str, alam) with
525 let (ubody, abody) = close fenv cenv body in
526 (Ulet(id, ulam, ubody), abody)
527 | (_, (Value_integer _ | Value_constptr _))
528 when str = Alias || is_pure lam ->
529 close (Tbl.add id alam fenv) cenv body
531 let (ubody, abody) = close (Tbl.add id alam fenv) cenv body in
532 (Ulet(id, ulam, ubody), abody)
534 | Lletrec(defs, body) ->
536 (function (id, Lfunction(_, _, _)) -> true | _ -> false)
539 (* Simple case: only function definitions *)
540 let (clos, infos) = close_functions fenv cenv defs in
541 let clos_ident = Ident.create "clos" in
544 (fun (id, pos, approx) fenv -> Tbl.add id approx fenv)
546 let (ubody, approx) = close fenv_body cenv body in
549 (fun (id, pos, approx) sb ->
550 Tbl.add id (Uoffset(Uvar clos_ident, pos)) sb)
552 (Ulet(clos_ident, clos, substitute sb ubody),
555 (* General case: recursive definition of values *)
556 let rec clos_defs = function
558 | (id, lam) :: rem ->
559 let (udefs, fenv_body) = clos_defs rem in
560 let (ulam, approx) = close fenv cenv lam in
561 ((id, ulam) :: udefs, Tbl.add id approx fenv_body) in
562 let (udefs, fenv_body) = clos_defs defs in
563 let (ubody, approx) = close fenv_body cenv body in
564 (Uletrec(udefs, ubody), approx)
566 | Lprim(Pgetglobal id, []) as lam ->
567 check_constant_result lam
569 (Compilenv.global_approx id)
570 | Lprim(Pmakeblock(tag, mut) as prim, lams) ->
571 let (ulams, approxs) = List.split (List.map (close fenv cenv) lams) in
572 (Uprim(prim, ulams, Debuginfo.none),
574 Immutable -> Value_tuple(Array.of_list approxs)
575 | Mutable -> Value_unknown
577 | Lprim(Pfield n, [lam]) ->
578 let (ulam, approx) = close fenv cenv lam in
581 Value_tuple a when n < Array.length a -> a.(n)
582 | _ -> Value_unknown in
583 check_constant_result lam (Uprim(Pfield n, [ulam], Debuginfo.none)) fieldapprox
584 | Lprim(Psetfield(n, _), [Lprim(Pgetglobal id, []); lam]) ->
585 let (ulam, approx) = close fenv cenv lam in
586 (!global_approx).(n) <- approx;
587 (Uprim(Psetfield(n, false), [getglobal id; ulam], Debuginfo.none),
589 | Lprim(Praise, [Levent(arg, ev)]) ->
590 let (ulam, approx) = close fenv cenv arg in
591 (Uprim(Praise, [ulam], Debuginfo.from_raise ev),
594 simplif_prim p (close_list_approx fenv cenv args) Debuginfo.none
595 | Lswitch(arg, sw) ->
596 (* NB: failaction might get copied, thus it should be some Lstaticraise *)
597 let (uarg, _) = close fenv cenv arg in
598 let const_index, const_actions =
599 close_switch fenv cenv sw.sw_consts sw.sw_numconsts sw.sw_failaction
600 and block_index, block_actions =
601 close_switch fenv cenv sw.sw_blocks sw.sw_numblocks sw.sw_failaction in
603 {us_index_consts = const_index;
604 us_actions_consts = const_actions;
605 us_index_blocks = block_index;
606 us_actions_blocks = block_actions}),
608 | Lstaticraise (i, args) ->
609 (Ustaticfail (i, close_list fenv cenv args), Value_unknown)
610 | Lstaticcatch(body, (i, vars), handler) ->
611 let (ubody, _) = close fenv cenv body in
612 let (uhandler, _) = close fenv cenv handler in
613 (Ucatch(i, vars, ubody, uhandler), Value_unknown)
614 | Ltrywith(body, id, handler) ->
615 let (ubody, _) = close fenv cenv body in
616 let (uhandler, _) = close fenv cenv handler in
617 (Utrywith(ubody, id, uhandler), Value_unknown)
618 | Lifthenelse(arg, ifso, ifnot) ->
619 begin match close fenv cenv arg with
620 (uarg, Value_constptr n) ->
621 sequence_constant_expr arg uarg
622 (close fenv cenv (if n = 0 then ifnot else ifso))
624 let (uifso, _) = close fenv cenv ifso in
625 let (uifnot, _) = close fenv cenv ifnot in
626 (Uifthenelse(uarg, uifso, uifnot), Value_unknown)
628 | Lsequence(lam1, lam2) ->
629 let (ulam1, _) = close fenv cenv lam1 in
630 let (ulam2, approx) = close fenv cenv lam2 in
631 (Usequence(ulam1, ulam2), approx)
632 | Lwhile(cond, body) ->
633 let (ucond, _) = close fenv cenv cond in
634 let (ubody, _) = close fenv cenv body in
635 (Uwhile(ucond, ubody), Value_unknown)
636 | Lfor(id, lo, hi, dir, body) ->
637 let (ulo, _) = close fenv cenv lo in
638 let (uhi, _) = close fenv cenv hi in
639 let (ubody, _) = close fenv cenv body in
640 (Ufor(id, ulo, uhi, dir, ubody), Value_unknown)
641 | Lassign(id, lam) ->
642 let (ulam, _) = close fenv cenv lam in
643 (Uassign(id, ulam), Value_unknown)
645 let (ulam, approx) = close fenv cenv lam in
646 (add_debug_info ev ulam, approx)
650 and close_list fenv cenv = function
653 let (ulam, _) = close fenv cenv lam in
654 ulam :: close_list fenv cenv rem
656 and close_list_approx fenv cenv = function
659 let (ulam, approx) = close fenv cenv lam in
660 let (ulams, approxs) = close_list_approx fenv cenv rem in
661 (ulam :: ulams, approx :: approxs)
663 and close_named fenv cenv id = function
664 Lfunction(kind, params, body) as funct ->
665 close_one_function fenv cenv id funct
669 (* Build a shared closure for a set of mutually recursive functions *)
671 and close_functions fenv cenv fun_defs =
672 (* Update and check nesting depth *)
673 incr function_nesting_depth;
674 let initially_closed =
675 !function_nesting_depth < excessive_function_nesting_depth in
676 (* Determine the free variables of the functions *)
678 IdentSet.elements (free_variables (Lletrec(fun_defs, lambda_unit))) in
679 (* Build the function descriptors for the functions.
680 Initially all functions are assumed not to need their environment
685 (id, Lfunction(kind, params, body)) ->
686 let label = Compilenv.make_symbol (Some (Ident.unique_name id)) in
687 let arity = List.length params in
690 fun_arity = (if kind = Tupled then -arity else arity);
691 fun_closed = initially_closed;
692 fun_inline = None } in
693 (id, params, body, fundesc)
694 | (_, _) -> fatal_error "Closure.close_functions")
696 (* Build an approximate fenv for compiling the functions *)
699 (fun (id, params, body, fundesc) fenv ->
700 Tbl.add id (Value_closure(fundesc, Value_unknown)) fenv)
701 uncurried_defs fenv in
702 (* Determine the offsets of each function's closure in the shared block *)
703 let env_pos = ref (-1) in
706 (fun (id, params, body, fundesc) ->
707 let pos = !env_pos + 1 in
708 env_pos := !env_pos + 1 + (if fundesc.fun_arity <> 1 then 3 else 2);
711 let fv_pos = !env_pos in
712 (* This reference will be set to false if the hypothesis that a function
713 does not use its environment parameter is invalidated. *)
714 let useless_env = ref initially_closed in
715 (* Translate each function definition *)
716 let clos_fundef (id, params, body, fundesc) env_pos =
717 let env_param = Ident.create "env" in
719 build_closure_env env_param (fv_pos - env_pos) fv in
722 (fun (id, params, arity, body) pos env ->
723 Tbl.add id (Uoffset(Uvar env_param, pos - env_pos)) env)
724 uncurried_defs clos_offsets cenv_fv in
725 let (ubody, approx) = close fenv_rec cenv_body body in
726 if !useless_env && occurs_var env_param ubody then useless_env := false;
727 let fun_params = if !useless_env then params else params @ [env_param] in
728 ((fundesc.fun_label, fundesc.fun_arity, fun_params, ubody),
729 (id, env_pos, Value_closure(fundesc, approx))) in
730 (* Translate all function definitions. *)
732 if initially_closed then begin
733 let cl = List.map2 clos_fundef uncurried_defs clos_offsets in
734 (* If the hypothesis that the environment parameters are useless has been
735 invalidated, then set [fun_closed] to false in all descriptions and
737 if !useless_env then cl else begin
739 (fun (id, params, body, fundesc) -> fundesc.fun_closed <- false)
741 List.map2 clos_fundef uncurried_defs clos_offsets
744 (* Excessive closure nesting: assume environment parameter is used *)
745 List.map2 clos_fundef uncurried_defs clos_offsets
747 (* Update nesting depth *)
748 decr function_nesting_depth;
749 (* Return the Uclosure node and the list of all identifiers defined,
750 with offsets and approximations. *)
751 let (clos, infos) = List.split clos_info_list in
752 (Uclosure(clos, List.map (close_var fenv cenv) fv), infos)
754 (* Same, for one non-recursive function *)
756 and close_one_function fenv cenv id funct =
757 match close_functions fenv cenv [id, funct] with
758 ((Uclosure([_, _, params, body], _) as clos),
759 [_, _, (Value_closure(fundesc, _) as approx)]) ->
760 (* See if the function can be inlined *)
761 if lambda_smaller body (!Clflags.inline_threshold + List.length params)
762 then fundesc.fun_inline <- Some(params, body);
764 | _ -> fatal_error "Closure.close_one_function"
768 and close_switch fenv cenv cases num_keys default =
769 let index = Array.create num_keys 0
770 and store = mk_store Lambda.same in
772 (* First default case *)
773 begin match default with
774 | Some def when List.length cases < num_keys ->
775 ignore (store.act_store def)
778 (* Then all other cases *)
781 index.(key) <- store.act_store lam)
787 let ulam,_ = close fenv cenv lam in
789 (store.act_get ()) in
791 | [| |] -> [| |], [| |] (* May happen when default is None *)
792 | _ -> index, actions
795 (* The entry point *)
798 function_nesting_depth := 0;
799 global_approx := Array.create size Value_unknown;
800 Compilenv.set_global_approx(Value_tuple !global_approx);
801 let (ulam, approx) = close Tbl.empty Tbl.empty lam in
802 global_approx := [||];