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 (***********************************************************************)
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 _
), _
) -> 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
) ->
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
Pervasives.(=) 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 := [||];