anil.recoil.org
My working unpac repository
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(* Elimination of useless Llet(Alias) bindings.
17 Also transform let-bound references into variables. *)
18
19open Asttypes
20open Lambda
21open Debuginfo.Scoped_location
22
23(* To transform let-bound references into variables *)
24
25exception Real_reference
26
27let check_function_escape id lfun =
28 (* Check that the identifier is not one of the parameters *)
29 let param_is_id (param, _) = Ident.same id param in
30 assert (not (List.exists param_is_id lfun.params));
31 if Ident.Set.mem id (Lambda.free_variables lfun.body) then
32 raise Real_reference
33
34let rec eliminate_ref id = function
35 Lvar v as lam ->
36 if Ident.same v id then raise Real_reference else lam
37 | Lmutvar _ | Lconst _ as lam -> lam
38 | Lapply ap ->
39 Lapply{ap with ap_func = eliminate_ref id ap.ap_func;
40 ap_args = List.map (eliminate_ref id) ap.ap_args}
41 | Lfunction lfun as lam ->
42 check_function_escape id lfun;
43 lam
44 | Llet(str, kind, v, e1, e2) ->
45 Llet(str, kind, v, eliminate_ref id e1, eliminate_ref id e2)
46 | Lmutlet(kind, v, e1, e2) ->
47 Lmutlet(kind, v, eliminate_ref id e1, eliminate_ref id e2)
48 | Lletrec(idel, e2) ->
49 List.iter (fun rb -> check_function_escape id rb.def) idel;
50 Lletrec(idel, eliminate_ref id e2)
51 | Lprim(Pfield (0, _, _), [Lvar v], _) when Ident.same v id ->
52 Lmutvar id
53 | Lprim(Psetfield(0, _, _), [Lvar v; e], _) when Ident.same v id ->
54 Lassign(id, eliminate_ref id e)
55 | Lprim(Poffsetref delta, [Lvar v], loc) when Ident.same v id ->
56 Lassign(id, Lprim(Poffsetint delta, [Lmutvar id], loc))
57 | Lprim(p, el, loc) ->
58 Lprim(p, List.map (eliminate_ref id) el, loc)
59 | Lswitch(e, sw, loc) ->
60 Lswitch(eliminate_ref id e,
61 {sw_numconsts = sw.sw_numconsts;
62 sw_consts =
63 List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_consts;
64 sw_numblocks = sw.sw_numblocks;
65 sw_blocks =
66 List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_blocks;
67 sw_failaction =
68 Option.map (eliminate_ref id) sw.sw_failaction; },
69 loc)
70 | Lstringswitch(e, sw, default, loc) ->
71 Lstringswitch
72 (eliminate_ref id e,
73 List.map (fun (s, e) -> (s, eliminate_ref id e)) sw,
74 Option.map (eliminate_ref id) default, loc)
75 | Lstaticraise (i,args) ->
76 Lstaticraise (i,List.map (eliminate_ref id) args)
77 | Lstaticcatch(e1, i, e2) ->
78 Lstaticcatch(eliminate_ref id e1, i, eliminate_ref id e2)
79 | Ltrywith(e1, v, e2) ->
80 Ltrywith(eliminate_ref id e1, v, eliminate_ref id e2)
81 | Lifthenelse(e1, e2, e3) ->
82 Lifthenelse(eliminate_ref id e1,
83 eliminate_ref id e2,
84 eliminate_ref id e3)
85 | Lsequence(e1, e2) ->
86 Lsequence(eliminate_ref id e1, eliminate_ref id e2)
87 | Lwhile(e1, e2) ->
88 Lwhile(eliminate_ref id e1, eliminate_ref id e2)
89 | Lfor(v, e1, e2, dir, e3) ->
90 Lfor(v, eliminate_ref id e1, eliminate_ref id e2,
91 dir, eliminate_ref id e3)
92 | Lassign(v, e) ->
93 Lassign(v, eliminate_ref id e)
94 | Lsend(k, m, o, el, loc) ->
95 Lsend(k, eliminate_ref id m, eliminate_ref id o,
96 List.map (eliminate_ref id) el, loc)
97 | Levent(l, ev) ->
98 Levent(eliminate_ref id l, ev)
99 | Lifused(v, e) ->
100 Lifused(v, eliminate_ref id e)
101
102(* Simplification of exits *)
103
104type exit = {
105 mutable count: int;
106 mutable max_depth: int;
107}
108
109let simplify_exits lam =
110
111 (* Count occurrences of (exit n ...) statements *)
112 let exits = Hashtbl.create 17 in
113
114 let get_exit i =
115 try Hashtbl.find exits i
116 with Not_found -> {count = 0; max_depth = 0}
117
118 and incr_exit i nb d =
119 match Hashtbl.find_opt exits i with
120 | Some r ->
121 r.count <- r.count + nb;
122 r.max_depth <- Int.max r.max_depth d
123 | None ->
124 let r = {count = nb; max_depth = d} in
125 Hashtbl.add exits i r
126 in
127
128 let rec count ~try_depth = function
129 | (Lvar _| Lmutvar _ | Lconst _) -> ()
130 | Lapply ap ->
131 count ~try_depth ap.ap_func;
132 List.iter (count ~try_depth) ap.ap_args
133 | Lfunction {body} -> count ~try_depth body
134 | Llet(_, _kind, _v, l1, l2)
135 | Lmutlet(_kind, _v, l1, l2) ->
136 count ~try_depth l2; count ~try_depth l1
137 | Lletrec(bindings, body) ->
138 List.iter (fun { def = { body } } -> count ~try_depth body) bindings;
139 count ~try_depth body
140 | Lprim(_p, ll, _) -> List.iter (count ~try_depth) ll
141 | Lswitch(l, sw, _loc) ->
142 count_default ~try_depth sw ;
143 count ~try_depth l;
144 List.iter (fun (_, l) -> count ~try_depth l) sw.sw_consts;
145 List.iter (fun (_, l) -> count ~try_depth l) sw.sw_blocks
146 | Lstringswitch(l, sw, d, _) ->
147 count ~try_depth l;
148 List.iter (fun (_, l) -> count ~try_depth l) sw;
149 begin match d with
150 | None -> ()
151 | Some d -> match sw with
152 | []|[_] -> count ~try_depth d
153 | _ -> (* default will get replicated *)
154 count ~try_depth d; count ~try_depth d
155 end
156 | Lstaticraise (i,ls) ->
157 incr_exit i 1 try_depth;
158 List.iter (count ~try_depth) ls
159 | Lstaticcatch (l1,(i,[]),Lstaticraise (j,[])) ->
160 (* i will be replaced by j in l1, so each occurrence of i in l1
161 increases j's ref count *)
162 count ~try_depth l1 ;
163 let ic = get_exit i in
164 incr_exit j ic.count (Int.max try_depth ic.max_depth)
165 | Lstaticcatch(l1, (i,_), l2) ->
166 count ~try_depth l1;
167 (* If l1 does not contain (exit i),
168 l2 will be removed, so don't count its exits *)
169 if (get_exit i).count > 0 then
170 count ~try_depth l2
171 | Ltrywith(l1, _v, l2) ->
172 count ~try_depth:(try_depth+1) l1;
173 count ~try_depth l2;
174 | Lifthenelse(l1, l2, l3) ->
175 count ~try_depth l1;
176 count ~try_depth l2;
177 count ~try_depth l3
178 | Lsequence(l1, l2) -> count ~try_depth l1; count ~try_depth l2
179 | Lwhile(l1, l2) -> count ~try_depth l1; count ~try_depth l2
180 | Lfor(_, l1, l2, _dir, l3) ->
181 count ~try_depth l1;
182 count ~try_depth l2;
183 count ~try_depth l3
184 | Lassign(_v, l) -> count ~try_depth l
185 | Lsend(_k, m, o, ll, _) -> List.iter (count ~try_depth) (m::o::ll)
186 | Levent(l, _) -> count ~try_depth l
187 | Lifused(_v, l) -> count ~try_depth l
188
189 and count_default ~try_depth sw = match sw.sw_failaction with
190 | None -> ()
191 | Some al ->
192 let nconsts = List.length sw.sw_consts
193 and nblocks = List.length sw.sw_blocks in
194 if
195 nconsts < sw.sw_numconsts && nblocks < sw.sw_numblocks
196 then begin (* default action will occur twice in native code *)
197 count ~try_depth al ; count ~try_depth al
198 end else begin (* default action will occur once *)
199 assert (nconsts < sw.sw_numconsts || nblocks < sw.sw_numblocks) ;
200 count ~try_depth al
201 end
202 in
203 count ~try_depth:0 lam;
204
205 (*
206 Second pass simplify ``catch body with (i ...) handler''
207 - if (exit i ...) does not occur in body, suppress catch
208 - if (exit i ...) occurs exactly once in body,
209 substitute it with handler
210 - If handler is a single variable, replace (exit i ..) with it
211 Note:
212 In ``catch body with (i x1 .. xn) handler''
213 Substituted expression is
214 let y1 = x1 and ... yn = xn in
215 handler[x1 <- y1 ; ... ; xn <- yn]
216 For the sake of preserving the uniqueness of bound variables.
217 (No alpha conversion of ``handler'' is presently needed, since
218 substitution of several ``(exit i ...)''
219 occurs only when ``handler'' is a variable.)
220 *)
221
222 let subst = Hashtbl.create 17 in
223 let rec simplif ~try_depth = function
224 | (Lvar _| Lmutvar _ | Lconst _) as l -> l
225 | Lapply ap ->
226 Lapply{ap with ap_func = simplif ~try_depth ap.ap_func;
227 ap_args = List.map (simplif ~try_depth) ap.ap_args}
228 | Lfunction lfun ->
229 Lfunction (map_lfunction (simplif ~try_depth) lfun)
230 | Llet(str, kind, v, l1, l2) ->
231 Llet(str, kind, v, simplif ~try_depth l1, simplif ~try_depth l2)
232 | Lmutlet(kind, v, l1, l2) ->
233 Lmutlet(kind, v, simplif ~try_depth l1, simplif ~try_depth l2)
234 | Lletrec(bindings, body) ->
235 let bindings =
236 List.map (fun ({ def = {kind; params; return; body = l; attr; loc} }
237 as rb) ->
238 let def =
239 lfunction' ~kind ~params ~return
240 ~body:(simplif ~try_depth l) ~attr ~loc
241 in
242 { rb with def })
243 bindings
244 in
245 Lletrec(bindings, simplif ~try_depth body)
246 | Lprim(p, ll, loc) -> begin
247 let ll = List.map (simplif ~try_depth) ll in
248 match p, ll with
249 (* Simplify Obj.with_tag *)
250 | Pccall { Primitive.prim_name = "caml_obj_with_tag"; _ },
251 [Lconst (Const_int tag);
252 Lprim (Pmakeblock (_, mut, shape), fields, loc)] ->
253 Lprim (Pmakeblock(tag, mut, shape), fields, loc)
254 | Pccall { Primitive.prim_name = "caml_obj_with_tag"; _ },
255 [Lconst (Const_int tag);
256 Lconst (Const_block (_, fields))] ->
257 Lconst (Const_block (tag, fields))
258
259 | _ -> Lprim(p, ll, loc)
260 end
261 | Lswitch(l, sw, loc) ->
262 let new_l = simplif ~try_depth l
263 and new_consts =
264 List.map (fun (n, e) -> (n, simplif ~try_depth e)) sw.sw_consts
265 and new_blocks =
266 List.map (fun (n, e) -> (n, simplif ~try_depth e)) sw.sw_blocks
267 and new_fail = Option.map (simplif ~try_depth) sw.sw_failaction in
268 Lswitch
269 (new_l,
270 {sw with sw_consts = new_consts ; sw_blocks = new_blocks;
271 sw_failaction = new_fail},
272 loc)
273 | Lstringswitch(l,sw,d,loc) ->
274 Lstringswitch
275 (simplif ~try_depth l,List.map (fun (s,l) -> s,simplif ~try_depth l) sw,
276 Option.map (simplif ~try_depth) d,loc)
277 | Lstaticraise (i,[]) as l ->
278 begin try
279 let _,handler = Hashtbl.find subst i in
280 handler
281 with
282 | Not_found -> l
283 end
284 | Lstaticraise (i,ls) ->
285 let ls = List.map (simplif ~try_depth) ls in
286 begin try
287 let xs,handler = Hashtbl.find subst i in
288 let ys = List.map (fun (x, k) -> Ident.rename x, k) xs in
289 let env =
290 List.fold_right2
291 (fun (x, _) (y, _) env -> Ident.Map.add x y env)
292 xs ys Ident.Map.empty
293 in
294 (* The evaluation order for Lstaticraise arguments is currently
295 right-to-left in all backends.
296 To preserve this, we use fold_left2 instead of fold_right2
297 (the first argument is inserted deepest in the expression,
298 so will be evaluated last).
299 *)
300 List.fold_left2
301 (fun r (y, kind) l -> Llet (Strict, kind, y, l, r))
302 (Lambda.rename env handler) ys ls
303 with
304 | Not_found -> Lstaticraise (i,ls)
305 end
306 | Lstaticcatch (l1,(i,[]),(Lstaticraise (_j,[]) as l2)) ->
307 Hashtbl.add subst i ([],simplif ~try_depth l2) ;
308 simplif ~try_depth l1
309 | Lstaticcatch (l1,(i,xs),l2) ->
310 let {count; max_depth} = get_exit i in
311 if count = 0 then
312 (* Discard staticcatch: not matching exit *)
313 simplif ~try_depth l1
314 else if
315 count = 1 && max_depth <= try_depth then begin
316 (* Inline handler if there is a single occurrence and it is not
317 nested within an inner try..with *)
318 assert(max_depth = try_depth);
319 Hashtbl.add subst i (xs,simplif ~try_depth l2);
320 simplif ~try_depth l1
321 end else
322 Lstaticcatch (simplif ~try_depth l1, (i,xs), simplif ~try_depth l2)
323 | Ltrywith(l1, v, l2) ->
324 let l1 = simplif ~try_depth:(try_depth + 1) l1 in
325 Ltrywith(l1, v, simplif ~try_depth l2)
326 | Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif ~try_depth l1,
327 simplif ~try_depth l2, simplif ~try_depth l3)
328 | Lsequence(l1, l2) -> Lsequence(simplif ~try_depth l1, simplif ~try_depth l2)
329 | Lwhile(l1, l2) -> Lwhile(simplif ~try_depth l1, simplif ~try_depth l2)
330 | Lfor(v, l1, l2, dir, l3) ->
331 Lfor(v, simplif ~try_depth l1, simplif ~try_depth l2, dir,
332 simplif ~try_depth l3)
333 | Lassign(v, l) -> Lassign(v, simplif ~try_depth l)
334 | Lsend(k, m, o, ll, loc) ->
335 Lsend(k, simplif ~try_depth m, simplif ~try_depth o,
336 List.map (simplif ~try_depth) ll, loc)
337 | Levent(l, ev) -> Levent(simplif ~try_depth l, ev)
338 | Lifused(v, l) -> Lifused (v,simplif ~try_depth l)
339 in
340 simplif ~try_depth:0 lam
341
342(* Compile-time beta-reduction of functions immediately applied:
343 Lapply(Lfunction(Curried, params, body), args, loc) ->
344 let paramN = argN in ... let param1 = arg1 in body
345 Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock(args))], loc) ->
346 let paramN = argN in ... let param1 = arg1 in body
347 Assumes |args| = |params|.
348*)
349
350let exact_application {kind; params; _} args =
351 let arity = List.length params in
352 Lambda.find_exact_application kind ~arity args
353
354let beta_reduce params body args =
355 List.fold_left2 (fun l (param, kind) arg -> Llet(Strict, kind, param, arg, l))
356 body params args
357
358(* Simplification of lets *)
359
360let simplify_lets lam =
361
362 (* Disable optimisations for bytecode compilation with -g flag *)
363 let optimize = !Clflags.native_code || not !Clflags.debug in
364
365 (* First pass: count the occurrences of all let-bound identifiers *)
366
367 let occ = (Hashtbl.create 83: (Ident.t, int ref) Hashtbl.t) in
368 (* The global table [occ] associates to each let-bound identifier
369 the number of its uses (as a reference):
370 - 0 if never used
371 - 1 if used exactly once in and not under a lambda or within a loop
372 - > 1 if used several times or under a lambda or within a loop.
373 The local table [bv] associates to each locally-let-bound variable
374 its reference count, as above. [bv] is enriched at let bindings
375 but emptied when crossing lambdas and loops. *)
376
377 (* Current use count of a variable. *)
378 let count_var v =
379 try
380 !(Hashtbl.find occ v)
381 with Not_found ->
382 0
383
384 (* Entering a [let]. Returns updated [bv]. *)
385 and bind_var bv v =
386 let r = ref 0 in
387 Hashtbl.add occ v r;
388 Ident.Map.add v r bv
389
390 (* Record a use of a variable *)
391 and use_var bv v n =
392 try
393 let r = Ident.Map.find v bv in r := !r + n
394 with Not_found ->
395 (* v is not locally bound, therefore this is a use under a lambda
396 or within a loop. Increase use count by 2 -- enough so
397 that single-use optimizations will not apply. *)
398 try
399 let r = Hashtbl.find occ v in r := !r + 2
400 with Not_found ->
401 (* Not a let-bound variable, ignore *)
402 () in
403
404 let rec count bv = function
405 | Lconst _ -> ()
406 | Lvar v ->
407 use_var bv v 1
408 | Lmutvar _ -> ()
409 | Lapply{ap_func = ll; ap_args = args} ->
410 let no_opt () = count bv ll; List.iter (count bv) args in
411 begin match ll with
412 | Lfunction lf when optimize ->
413 begin match exact_application lf args with
414 | None -> no_opt ()
415 | Some exact_args ->
416 count bv (beta_reduce lf.params lf.body exact_args)
417 end
418 | _ -> no_opt ()
419 end
420 | Lfunction fn ->
421 count_lfunction fn
422 | Llet(_str, _k, v, Lvar w, l2) when optimize ->
423 (* v will be replaced by w in l2, so each occurrence of v in l2
424 increases w's refcount *)
425 count (bind_var bv v) l2;
426 use_var bv w (count_var v)
427 | Llet(str, _kind, v, l1, l2) ->
428 count (bind_var bv v) l2;
429 (* If v is unused, l1 will be removed, so don't count its variables *)
430 if str = Strict || count_var v > 0 then count bv l1
431 | Lmutlet(_kind, _v, l1, l2) ->
432 count bv l1;
433 count bv l2
434 | Lletrec(bindings, body) ->
435 List.iter (fun { def } -> count_lfunction def) bindings;
436 count bv body
437 | Lprim(_p, ll, _) -> List.iter (count bv) ll
438 | Lswitch(l, sw, _loc) ->
439 count_default bv sw ;
440 count bv l;
441 List.iter (fun (_, l) -> count bv l) sw.sw_consts;
442 List.iter (fun (_, l) -> count bv l) sw.sw_blocks
443 | Lstringswitch(l, sw, d, _) ->
444 count bv l ;
445 List.iter (fun (_, l) -> count bv l) sw ;
446 begin match d with
447 | Some d ->
448 begin match sw with
449 | []|[_] -> count bv d
450 | _ -> count bv d ; count bv d
451 end
452 | None -> ()
453 end
454 | Lstaticraise (_i,ls) -> List.iter (count bv) ls
455 | Lstaticcatch(l1, _, l2) -> count bv l1; count bv l2
456 | Ltrywith(l1, _v, l2) -> count bv l1; count bv l2
457 | Lifthenelse(l1, l2, l3) -> count bv l1; count bv l2; count bv l3
458 | Lsequence(l1, l2) -> count bv l1; count bv l2
459 | Lwhile(l1, l2) -> count Ident.Map.empty l1; count Ident.Map.empty l2
460 | Lfor(_, l1, l2, _dir, l3) ->
461 count bv l1; count bv l2; count Ident.Map.empty l3
462 | Lassign(_v, l) ->
463 (* Lalias-bound variables are never assigned, so don't increase
464 v's refcount *)
465 count bv l
466 | Lsend(_, m, o, ll, _) -> List.iter (count bv) (m::o::ll)
467 | Levent(l, _) -> count bv l
468 | Lifused(v, l) ->
469 if count_var v > 0 then count bv l
470
471 and count_lfunction fn =
472 count Ident.Map.empty fn.body
473
474 and count_default bv sw = match sw.sw_failaction with
475 | None -> ()
476 | Some al ->
477 let nconsts = List.length sw.sw_consts
478 and nblocks = List.length sw.sw_blocks in
479 if
480 nconsts < sw.sw_numconsts && nblocks < sw.sw_numblocks
481 then begin (* default action will occur twice in native code *)
482 count bv al ; count bv al
483 end else begin (* default action will occur once *)
484 assert (nconsts < sw.sw_numconsts || nblocks < sw.sw_numblocks) ;
485 count bv al
486 end
487 in
488 count Ident.Map.empty lam;
489
490 (* Second pass: remove Lalias bindings of unused variables,
491 and substitute the bindings of variables used exactly once. *)
492
493 let subst = Hashtbl.create 83 in
494
495(* This (small) optimisation is always legal, it may uncover some
496 tail call later on. *)
497
498 let mklet str kind v e1 e2 =
499 match e2 with
500 | Lvar w when optimize && Ident.same v w -> e1
501 | _ -> Llet (str, kind,v,e1,e2)
502 in
503
504 let mkmutlet kind v e1 e2 =
505 match e2 with
506 | Lmutvar w when optimize && Ident.same v w -> e1
507 | _ -> Lmutlet (kind,v,e1,e2)
508 in
509
510 let rec simplif = function
511 Lvar v as l ->
512 begin try
513 Hashtbl.find subst v
514 with Not_found ->
515 l
516 end
517 | Lmutvar _ | Lconst _ as l -> l
518 | Lapply ({ap_func = ll; ap_args = args} as ap) ->
519 let no_opt () =
520 Lapply {ap with ap_func = simplif ap.ap_func;
521 ap_args = List.map simplif ap.ap_args} in
522 begin match ll with
523 | Lfunction lf when optimize ->
524 begin match exact_application lf args with
525 | None -> no_opt ()
526 | Some exact_args ->
527 simplif (beta_reduce lf.params lf.body exact_args)
528 end
529 | _ -> no_opt ()
530 end
531 | Lfunction{kind; params; return=return1; body = l; attr=attr1; loc}
532 ->
533 begin match simplif l with
534 Lfunction{kind=Curried; params=params'; return=return2; body;
535 attr=attr2; loc}
536 when kind = Curried && optimize &&
537 attr1.may_fuse_arity && attr2.may_fuse_arity &&
538 List.length params + List.length params' <= Lambda.max_arity() ->
539 (* The return type is the type of the value returned after
540 applying all the parameters to the function. The return
541 type of the merged function taking [params @ params'] as
542 parameters is the type returned after applying [params']. *)
543 let return = return2 in
544 lfunction ~kind ~params:(params @ params') ~return ~body ~attr:attr2
545 ~loc
546 | body ->
547 lfunction ~kind ~params ~return:return1 ~body ~attr:attr1 ~loc
548 end
549 | Llet(_str, _k, v, Lvar w, l2) when optimize ->
550 Hashtbl.add subst v (simplif (Lvar w));
551 simplif l2
552 | Llet(Strict, kind, v,
553 Lprim(Pmakeblock(0, Mutable, kind_ref) as prim, [linit], loc), lbody)
554 when optimize ->
555 let slinit = simplif linit in
556 let slbody = simplif lbody in
557 begin try
558 let kind = match kind_ref with
559 | None -> Pgenval
560 | Some [field_kind] -> field_kind
561 | Some _ -> assert false
562 in
563 mkmutlet kind v slinit (eliminate_ref v slbody)
564 with Real_reference ->
565 mklet Strict kind v (Lprim(prim, [slinit], loc)) slbody
566 end
567 | Llet(Alias, kind, v, l1, l2) ->
568 begin match count_var v with
569 0 -> simplif l2
570 | 1 when optimize -> Hashtbl.add subst v (simplif l1); simplif l2
571 | _ -> Llet(Alias, kind, v, simplif l1, simplif l2)
572 end
573 | Llet(StrictOpt, kind, v, l1, l2) ->
574 begin match count_var v with
575 0 -> simplif l2
576 | _ -> mklet StrictOpt kind v (simplif l1) (simplif l2)
577 end
578 | Llet(str, kind, v, l1, l2) -> mklet str kind v (simplif l1) (simplif l2)
579 | Lmutlet(kind, v, l1, l2) -> mkmutlet kind v (simplif l1) (simplif l2)
580 | Lletrec(bindings, body) ->
581 let bindings =
582 List.map (fun rb ->
583 { rb with def = map_lfunction simplif rb.def }
584 ) bindings
585 in
586 Lletrec(bindings, simplif body)
587 | Lprim(p, ll, loc) -> Lprim(p, List.map simplif ll, loc)
588 | Lswitch(l, sw, loc) ->
589 let new_l = simplif l
590 and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts
591 and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks
592 and new_fail = Option.map simplif sw.sw_failaction in
593 Lswitch
594 (new_l,
595 {sw with sw_consts = new_consts ; sw_blocks = new_blocks;
596 sw_failaction = new_fail},
597 loc)
598 | Lstringswitch (l,sw,d,loc) ->
599 Lstringswitch
600 (simplif l,List.map (fun (s,l) -> s,simplif l) sw,
601 Option.map simplif d,loc)
602 | Lstaticraise (i,ls) ->
603 Lstaticraise (i, List.map simplif ls)
604 | Lstaticcatch(l1, (i,args), l2) ->
605 Lstaticcatch (simplif l1, (i,args), simplif l2)
606 | Ltrywith(l1, v, l2) -> Ltrywith(simplif l1, v, simplif l2)
607 | Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif l1, simplif l2, simplif l3)
608 | Lsequence(Lifused(v, l1), l2) ->
609 if count_var v > 0
610 then Lsequence(simplif l1, simplif l2)
611 else simplif l2
612 | Lsequence(l1, l2) -> Lsequence(simplif l1, simplif l2)
613 | Lwhile(l1, l2) -> Lwhile(simplif l1, simplif l2)
614 | Lfor(v, l1, l2, dir, l3) ->
615 Lfor(v, simplif l1, simplif l2, dir, simplif l3)
616 | Lassign(v, l) -> Lassign(v, simplif l)
617 | Lsend(k, m, o, ll, loc) ->
618 Lsend(k, simplif m, simplif o, List.map simplif ll, loc)
619 | Levent(l, ev) -> Levent(simplif l, ev)
620 | Lifused(v, l) ->
621 if count_var v > 0 then simplif l else lambda_unit
622 in
623 simplif lam
624
625(* Tail call info in annotation files *)
626
627let rec emit_tail_infos is_tail lambda =
628 match lambda with
629 | Lvar _ -> ()
630 | Lmutvar _ -> ()
631 | Lconst _ -> ()
632 | Lapply ap ->
633 begin
634 (* Note: is_tail does not take backend-specific logic into
635 account (maximum number of parameters, etc.) so it may
636 over-approximate tail-callness.
637
638 Trying to do something more fine-grained would result in
639 different warnings depending on whether the native or
640 bytecode compiler is used. *)
641 let maybe_warn ~is_tail ~expect_tail =
642 if is_tail <> expect_tail then
643 Location.prerr_warning (to_location ap.ap_loc)
644 (Warnings.Wrong_tailcall_expectation expect_tail) in
645 match ap.ap_tailcall with
646 | Default_tailcall -> ()
647 | Tailcall_expectation expect_tail ->
648 maybe_warn ~is_tail ~expect_tail
649 end;
650 emit_tail_infos false ap.ap_func;
651 list_emit_tail_infos false ap.ap_args
652 | Lfunction lfun ->
653 emit_tail_infos_lfunction is_tail lfun
654 | Llet (_, _k, _, lam, body)
655 | Lmutlet (_k, _, lam, body) ->
656 emit_tail_infos false lam;
657 emit_tail_infos is_tail body
658 | Lletrec (bindings, body) ->
659 List.iter (fun { def } -> emit_tail_infos_lfunction is_tail def) bindings;
660 emit_tail_infos is_tail body
661 | Lprim ((Pbytes_to_string | Pbytes_of_string), [arg], _) ->
662 emit_tail_infos is_tail arg
663 | Lprim (Psequand, [arg1; arg2], _)
664 | Lprim (Psequor, [arg1; arg2], _) ->
665 emit_tail_infos false arg1;
666 emit_tail_infos is_tail arg2
667 | Lprim (_, l, _) ->
668 list_emit_tail_infos false l
669 | Lswitch (lam, sw, _loc) ->
670 emit_tail_infos false lam;
671 list_emit_tail_infos_fun snd is_tail sw.sw_consts;
672 list_emit_tail_infos_fun snd is_tail sw.sw_blocks;
673 Option.iter (emit_tail_infos is_tail) sw.sw_failaction
674 | Lstringswitch (lam, sw, d, _) ->
675 emit_tail_infos false lam;
676 List.iter
677 (fun (_,lam) -> emit_tail_infos is_tail lam)
678 sw ;
679 Option.iter (emit_tail_infos is_tail) d
680 | Lstaticraise (_, l) ->
681 list_emit_tail_infos false l
682 | Lstaticcatch (body, _, handler) ->
683 emit_tail_infos is_tail body;
684 emit_tail_infos is_tail handler
685 | Ltrywith (body, _, handler) ->
686 emit_tail_infos false body;
687 emit_tail_infos is_tail handler
688 | Lifthenelse (cond, ifso, ifno) ->
689 emit_tail_infos false cond;
690 emit_tail_infos is_tail ifso;
691 emit_tail_infos is_tail ifno
692 | Lsequence (lam1, lam2) ->
693 emit_tail_infos false lam1;
694 emit_tail_infos is_tail lam2
695 | Lwhile (cond, body) ->
696 emit_tail_infos false cond;
697 emit_tail_infos false body
698 | Lfor (_, low, high, _, body) ->
699 emit_tail_infos false low;
700 emit_tail_infos false high;
701 emit_tail_infos false body
702 | Lassign (_, lam) ->
703 emit_tail_infos false lam
704 | Lsend (_, meth, obj, args, _loc) ->
705 emit_tail_infos false meth;
706 emit_tail_infos false obj;
707 list_emit_tail_infos false args
708 | Levent (lam, _) ->
709 emit_tail_infos is_tail lam
710 | Lifused (_, lam) ->
711 emit_tail_infos is_tail lam
712and list_emit_tail_infos_fun f is_tail =
713 List.iter (fun x -> emit_tail_infos is_tail (f x))
714and list_emit_tail_infos is_tail =
715 List.iter (emit_tail_infos is_tail)
716and emit_tail_infos_lfunction _is_tail lfun =
717 (* Tail call annotations are only meaningful with respect to the
718 current function; so entering a function resets the [is_tail] flag *)
719 emit_tail_infos true lfun.body
720
721(* Split a function with default parameters into a wrapper and an
722 inner function. The wrapper fills in missing optional parameters
723 with their default value and tail-calls the inner function. The
724 wrapper can then hopefully be inlined on most call sites to avoid
725 the overhead associated with boxing an optional argument with a
726 'Some' constructor, only to deconstruct it immediately in the
727 function's body. *)
728
729let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body ~attr ~loc =
730 let rec aux map = function
731 (* When compiling [fun ?(x=expr) -> body], this is first translated
732 to:
733 [fun *opt* ->
734 let x =
735 match *opt* with
736 | None -> expr
737 | Some *sth* -> *sth*
738 in
739 body]
740 We want to detect the let binding to put it into the wrapper instead of
741 the inner function.
742 We need to find which optional parameter the binding corresponds to,
743 which is why we need a deep pattern matching on the expected result of
744 the pattern-matching compiler for options.
745 *)
746 | Llet(Strict, k, id,
747 (Lifthenelse(Lprim (Pisint, [Lvar optparam], _), _, _) as def),
748 rest) when
749 Ident.name optparam = "*opt*" && List.mem_assoc optparam params
750 && not (List.mem_assoc optparam map)
751 ->
752 let wrapper_body, inner = aux ((optparam, id) :: map) rest in
753 Llet(Strict, k, id, def, wrapper_body), inner
754 | _ when map = [] -> raise Exit
755 | body ->
756 (* Check that those *opt* identifiers don't appear in the remaining
757 body. This should not appear, but let's be on the safe side. *)
758 let fv = Lambda.free_variables body in
759 List.iter (fun (id, _) -> if Ident.Set.mem id fv then raise Exit) map;
760
761 let inner_id = Ident.create_local (Ident.name fun_id ^ "_inner") in
762 let map_param p = try List.assoc p map with Not_found -> p in
763 let args = List.map (fun (p, _) -> Lvar (map_param p)) params in
764 let wrapper_body =
765 Lapply {
766 ap_func = Lvar inner_id;
767 ap_args = args;
768 ap_loc = Loc_unknown;
769 ap_tailcall = Default_tailcall;
770 ap_inlined = Default_inline;
771 ap_specialised = Default_specialise;
772 }
773 in
774 let inner_params = List.map map_param (List.map fst params) in
775 let new_ids = List.map Ident.rename inner_params in
776 let subst =
777 List.fold_left2 (fun s id new_id ->
778 Ident.Map.add id new_id s
779 ) Ident.Map.empty inner_params new_ids
780 in
781 let body = Lambda.rename subst body in
782 let inner_fun =
783 lfunction' ~kind:Curried
784 ~params:(List.map (fun id -> id, Pgenval) new_ids)
785 ~return ~body ~attr ~loc
786 in
787 (wrapper_body, { id = inner_id;
788 def = inner_fun })
789 in
790 try
791 let body, inner = aux [] body in
792 let attr = default_stub_attribute in
793 [{ id = fun_id;
794 def = lfunction' ~kind ~params ~return ~body ~attr ~loc };
795 inner]
796 with Exit ->
797 [{ id = fun_id;
798 def = lfunction' ~kind ~params ~return ~body ~attr ~loc }]
799
800(* Simplify local let-bound functions: if all occurrences are
801 fully-applied function calls in the same "tail scope", replace the
802 function by a staticcatch handler (on that scope).
803
804 This handles as a special case functions used exactly once (in any
805 scope) for a full application.
806*)
807
808type slot =
809 {
810 func: lfunction;
811 function_scope: lambda;
812 mutable scope: lambda option;
813 }
814
815module LamTbl = Hashtbl.Make(struct
816 type t = lambda
817 let equal = (==)
818 let hash = Hashtbl.hash
819 end)
820
821let simplify_local_functions lam =
822 let slots = Hashtbl.create 16 in
823 let static_id = Hashtbl.create 16 in (* function id -> static id *)
824 let static = LamTbl.create 16 in (* scope -> static function on that scope *)
825 (* We keep track of the current "tail scope", identified
826 by the outermost lambda for which the current lambda
827 is in tail position. *)
828 let current_scope = ref lam in
829 (* PR11383: We will only apply the transformation if we don't have to move
830 code across function boundaries *)
831 let current_function_scope = ref lam in
832 let check_static lf =
833 if lf.attr.local = Always_local then
834 Location.prerr_warning (to_location lf.loc)
835 (Warnings.Inlining_impossible
836 "This function cannot be compiled into a static continuation")
837 in
838 let enabled = function
839 | {local = Always_local; _}
840 | {local = Default_local; inline = (Never_inline | Default_inline); _}
841 -> true
842 | {local = Default_local;
843 inline = (Always_inline | Unroll _ | Hint_inline); _}
844 | {local = Never_local; _}
845 -> false
846 in
847 let rec tail = function
848 | Llet (_str, _kind, id, Lfunction lf, cont) when enabled lf.attr ->
849 let r =
850 { func = lf;
851 function_scope = !current_function_scope;
852 scope = None }
853 in
854 Hashtbl.add slots id r;
855 tail cont;
856 begin match Hashtbl.find_opt slots id with
857 | Some {scope = Some scope; _} ->
858 let st = next_raise_count () in
859 let sc =
860 (* Do not move higher than current lambda *)
861 if scope == !current_scope then cont
862 else scope
863 in
864 Hashtbl.add static_id id st;
865 LamTbl.add static sc (st, lf);
866 (* The body of the function will become an handler
867 in that "scope". *)
868 with_scope ~scope lf.body
869 | _ ->
870 check_static lf;
871 (* note: if scope = None, the function is unused *)
872 function_definition lf
873 end
874 | Lapply {ap_func = Lvar id; ap_args; _} ->
875 begin match Hashtbl.find_opt slots id with
876 | Some {func; _}
877 when exact_application func ap_args = None ->
878 (* Wrong arity *)
879 Hashtbl.remove slots id
880 | Some {scope = Some scope; _} when scope != !current_scope ->
881 (* Different "tail scope" *)
882 Hashtbl.remove slots id
883 | Some {function_scope = fscope; _}
884 when fscope != !current_function_scope ->
885 (* Non local function *)
886 Hashtbl.remove slots id
887 | Some ({scope = None; _} as slot) ->
888 (* First use of the function: remember the current tail scope *)
889 slot.scope <- Some !current_scope
890 | _ ->
891 ()
892 end;
893 List.iter non_tail ap_args
894 | Lvar id ->
895 Hashtbl.remove slots id
896 | Lfunction lf ->
897 check_static lf;
898 function_definition lf
899 | lam ->
900 Lambda.shallow_iter ~tail ~non_tail lam
901 and non_tail lam =
902 with_scope ~scope:lam lam
903 and function_definition lf =
904 let old_function_scope = !current_function_scope in
905 current_function_scope := lf.body;
906 non_tail lf.body;
907 current_function_scope := old_function_scope
908 and with_scope ~scope lam =
909 let old_scope = !current_scope in
910 current_scope := scope;
911 tail lam;
912 current_scope := old_scope
913 in
914 tail lam;
915 let rec rewrite lam0 =
916 let lam =
917 match lam0 with
918 | Llet (_, _, id, _, cont) when Hashtbl.mem static_id id ->
919 rewrite cont
920 | Lapply {ap_func = Lvar id; ap_args; _} when Hashtbl.mem static_id id ->
921 let st = Hashtbl.find static_id id in
922 let slot = Hashtbl.find slots id in
923 begin match exact_application slot.func ap_args with
924 | None -> assert false
925 | Some exact_args ->
926 Lstaticraise (st, List.map rewrite exact_args)
927 end
928 | lam ->
929 Lambda.shallow_map rewrite lam
930 in
931 List.fold_right
932 (fun (st, lf) lam ->
933 Lstaticcatch (lam, (st, lf.params), rewrite lf.body)
934 )
935 (LamTbl.find_all static lam0)
936 lam
937 in
938 if LamTbl.length static = 0 then
939 lam
940 else
941 rewrite lam
942
943(* The entry point:
944 simplification
945 + rewriting of tail-modulo-cons calls
946 + emission of tailcall annotations, if needed
947*)
948
949let simplify_lambda lam =
950 let lam =
951 lam
952 |> (if !Clflags.native_code || not !Clflags.debug
953 then simplify_local_functions else Fun.id
954 )
955 |> simplify_exits
956 |> simplify_lets
957 |> Tmc.rewrite
958 in
959 if !Clflags.annotations
960 || Warnings.is_active (Warnings.Wrong_tailcall_expectation true)
961 then emit_tail_infos true lam;
962 lam