686 lines
25 KiB
OCaml
686 lines
25 KiB
OCaml
(**************************************************************************)
|
|
(* *)
|
|
(* OCaml *)
|
|
(* *)
|
|
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
(* *)
|
|
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
|
(* en Automatique. *)
|
|
(* *)
|
|
(* All rights reserved. This file is distributed under the terms of *)
|
|
(* the GNU Lesser General Public License version 2.1, with the *)
|
|
(* special exception on linking described in the file LICENSE. *)
|
|
(* *)
|
|
(**************************************************************************)
|
|
|
|
(* Elimination of useless Llet(Alias) bindings.
|
|
Also transform let-bound references into variables. *)
|
|
|
|
open Asttypes
|
|
open Lambda
|
|
|
|
(* To transform let-bound references into variables *)
|
|
|
|
exception Real_reference
|
|
|
|
let rec eliminate_ref id = function
|
|
Lvar v as lam ->
|
|
if Ident.same v id then raise Real_reference else lam
|
|
| Lconst _ as lam -> lam
|
|
| Lapply ap ->
|
|
Lapply{ap with ap_func = eliminate_ref id ap.ap_func;
|
|
ap_args = List.map (eliminate_ref id) ap.ap_args}
|
|
| Lfunction _ as lam ->
|
|
if IdentSet.mem id (free_variables lam)
|
|
then raise Real_reference
|
|
else lam
|
|
| Llet(str, v, e1, e2) ->
|
|
Llet(str, v, eliminate_ref id e1, eliminate_ref id e2)
|
|
| Lletrec(idel, e2) ->
|
|
Lletrec(List.map (fun (v, e) -> (v, eliminate_ref id e)) idel,
|
|
eliminate_ref id e2)
|
|
| Lprim(Pfield 0, [Lvar v]) when Ident.same v id ->
|
|
Lvar id
|
|
| Lprim(Psetfield(0, _, _), [Lvar v; e]) when Ident.same v id ->
|
|
Lassign(id, eliminate_ref id e)
|
|
| Lprim(Poffsetref delta, [Lvar v]) when Ident.same v id ->
|
|
Lassign(id, Lprim(Poffsetint delta, [Lvar id]))
|
|
| Lprim(p, el) ->
|
|
Lprim(p, List.map (eliminate_ref id) el)
|
|
| Lswitch(e, sw) ->
|
|
Lswitch(eliminate_ref id e,
|
|
{sw_numconsts = sw.sw_numconsts;
|
|
sw_consts =
|
|
List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_consts;
|
|
sw_numblocks = sw.sw_numblocks;
|
|
sw_blocks =
|
|
List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_blocks;
|
|
sw_failaction =
|
|
Misc.may_map (eliminate_ref id) sw.sw_failaction; })
|
|
| Lstringswitch(e, sw, default) ->
|
|
Lstringswitch
|
|
(eliminate_ref id e,
|
|
List.map (fun (s, e) -> (s, eliminate_ref id e)) sw,
|
|
Misc.may_map (eliminate_ref id) default)
|
|
| Lstaticraise (i,args) ->
|
|
Lstaticraise (i,List.map (eliminate_ref id) args)
|
|
| Lstaticcatch(e1, i, e2) ->
|
|
Lstaticcatch(eliminate_ref id e1, i, eliminate_ref id e2)
|
|
| Ltrywith(e1, v, e2) ->
|
|
Ltrywith(eliminate_ref id e1, v, eliminate_ref id e2)
|
|
| Lifthenelse(e1, e2, e3) ->
|
|
Lifthenelse(eliminate_ref id e1,
|
|
eliminate_ref id e2,
|
|
eliminate_ref id e3)
|
|
| Lsequence(e1, e2) ->
|
|
Lsequence(eliminate_ref id e1, eliminate_ref id e2)
|
|
| Lwhile(e1, e2) ->
|
|
Lwhile(eliminate_ref id e1, eliminate_ref id e2)
|
|
| Lfor(v, e1, e2, dir, e3) ->
|
|
Lfor(v, eliminate_ref id e1, eliminate_ref id e2,
|
|
dir, eliminate_ref id e3)
|
|
| Lassign(v, e) ->
|
|
Lassign(v, eliminate_ref id e)
|
|
| Lsend(k, m, o, el, loc) ->
|
|
Lsend(k, eliminate_ref id m, eliminate_ref id o,
|
|
List.map (eliminate_ref id) el, loc)
|
|
| Levent(l, ev) ->
|
|
Levent(eliminate_ref id l, ev)
|
|
| Lifused(v, e) ->
|
|
Lifused(v, eliminate_ref id e)
|
|
|
|
(* Simplification of exits *)
|
|
|
|
let simplify_exits lam =
|
|
|
|
(* Count occurrences of (exit n ...) statements *)
|
|
let exits = Hashtbl.create 17 in
|
|
|
|
let count_exit i =
|
|
try
|
|
!(Hashtbl.find exits i)
|
|
with
|
|
| Not_found -> 0
|
|
|
|
and incr_exit i =
|
|
try
|
|
incr (Hashtbl.find exits i)
|
|
with
|
|
| Not_found -> Hashtbl.add exits i (ref 1) in
|
|
|
|
let rec count = function
|
|
| (Lvar _| Lconst _) -> ()
|
|
| Lapply ap -> count ap.ap_func; List.iter count ap.ap_args
|
|
| Lfunction {body} -> count body
|
|
| Llet(_str, _v, l1, l2) ->
|
|
count l2; count l1
|
|
| Lletrec(bindings, body) ->
|
|
List.iter (fun (_v, l) -> count l) bindings;
|
|
count body
|
|
| Lprim(_p, ll) -> List.iter count ll
|
|
| Lswitch(l, sw) ->
|
|
count_default sw ;
|
|
count l;
|
|
List.iter (fun (_, l) -> count l) sw.sw_consts;
|
|
List.iter (fun (_, l) -> count l) sw.sw_blocks
|
|
| Lstringswitch(l, sw, d) ->
|
|
count l;
|
|
List.iter (fun (_, l) -> count l) sw;
|
|
begin match d with
|
|
| None -> ()
|
|
| Some d -> match sw with
|
|
| []|[_] -> count d
|
|
| _ -> count d; count d (* default will get replicated *)
|
|
end
|
|
| Lstaticraise (i,ls) -> incr_exit i ; List.iter count ls
|
|
| Lstaticcatch (l1,(i,[]),Lstaticraise (j,[])) ->
|
|
(* i will be replaced by j in l1, so each occurence of i in l1
|
|
increases j's ref count *)
|
|
count l1 ;
|
|
let ic = count_exit i in
|
|
begin try
|
|
let r = Hashtbl.find exits j in r := !r + ic
|
|
with
|
|
| Not_found ->
|
|
Hashtbl.add exits j (ref ic)
|
|
end
|
|
| Lstaticcatch(l1, (i,_), l2) ->
|
|
count l1;
|
|
(* If l1 does not contain (exit i),
|
|
l2 will be removed, so don't count its exits *)
|
|
if count_exit i > 0 then
|
|
count l2
|
|
| Ltrywith(l1, _v, l2) -> count l1; count l2
|
|
| Lifthenelse(l1, l2, l3) -> count l1; count l2; count l3
|
|
| Lsequence(l1, l2) -> count l1; count l2
|
|
| Lwhile(l1, l2) -> count l1; count l2
|
|
| Lfor(_, l1, l2, _dir, l3) -> count l1; count l2; count l3
|
|
| Lassign(_v, l) -> count l
|
|
| Lsend(_k, m, o, ll, _) -> List.iter count (m::o::ll)
|
|
| Levent(l, _) -> count l
|
|
| Lifused(_v, l) -> count l
|
|
|
|
and count_default sw = match sw.sw_failaction with
|
|
| None -> ()
|
|
| Some al ->
|
|
let nconsts = List.length sw.sw_consts
|
|
and nblocks = List.length sw.sw_blocks in
|
|
if
|
|
nconsts < sw.sw_numconsts && nblocks < sw.sw_numblocks
|
|
then begin (* default action will occur twice in native code *)
|
|
count al ; count al
|
|
end else begin (* default action will occur once *)
|
|
assert (nconsts < sw.sw_numconsts || nblocks < sw.sw_numblocks) ;
|
|
count al
|
|
end
|
|
in
|
|
count lam;
|
|
|
|
(*
|
|
Second pass simplify ``catch body with (i ...) handler''
|
|
- if (exit i ...) does not occur in body, suppress catch
|
|
- if (exit i ...) occurs exactly once in body,
|
|
substitute it with handler
|
|
- If handler is a single variable, replace (exit i ..) with it
|
|
Note:
|
|
In ``catch body with (i x1 .. xn) handler''
|
|
Substituted expression is
|
|
let y1 = x1 and ... yn = xn in
|
|
handler[x1 <- y1 ; ... ; xn <- yn]
|
|
For the sake of preserving the uniqueness of bound variables.
|
|
(No alpha conversion of ``handler'' is presently needed, since
|
|
substitution of several ``(exit i ...)''
|
|
occurs only when ``handler'' is a variable.)
|
|
*)
|
|
|
|
let subst = Hashtbl.create 17 in
|
|
|
|
let rec simplif = function
|
|
| (Lvar _|Lconst _) as l -> l
|
|
| Lapply ap ->
|
|
Lapply{ap with ap_func = simplif ap.ap_func;
|
|
ap_args = List.map simplif ap.ap_args}
|
|
| Lfunction{kind; params; body = l; attr} ->
|
|
Lfunction{kind; params; body = simplif l; attr}
|
|
| Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2)
|
|
| Lletrec(bindings, body) ->
|
|
Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body)
|
|
| Lprim(p, ll) -> begin
|
|
let ll = List.map simplif ll in
|
|
match p, ll with
|
|
(* Simplify %revapply, for n-ary functions with n > 1 *)
|
|
| Prevapply loc, [x; Lapply ap]
|
|
| Prevapply loc, [x; Levent (Lapply ap,_)] ->
|
|
Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc}
|
|
| Prevapply loc, [x; f] -> Lapply {ap_should_be_tailcall=false;
|
|
ap_loc=loc;
|
|
ap_func=f;
|
|
ap_args=[x];
|
|
ap_inlined=Default_inline;
|
|
ap_specialised=Default_specialise}
|
|
|
|
(* Simplify %apply, for n-ary functions with n > 1 *)
|
|
| Pdirapply loc, [Lapply ap; x]
|
|
| Pdirapply loc, [Levent (Lapply ap,_); x] ->
|
|
Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc}
|
|
| Pdirapply loc, [f; x] -> Lapply {ap_should_be_tailcall=false;
|
|
ap_loc=loc;
|
|
ap_func=f;
|
|
ap_args=[x];
|
|
ap_inlined=Default_inline;
|
|
ap_specialised=Default_specialise}
|
|
|
|
| _ -> Lprim(p, ll)
|
|
end
|
|
| Lswitch(l, sw) ->
|
|
let new_l = simplif l
|
|
and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts
|
|
and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks
|
|
and new_fail = Misc.may_map simplif sw.sw_failaction in
|
|
Lswitch
|
|
(new_l,
|
|
{sw with sw_consts = new_consts ; sw_blocks = new_blocks;
|
|
sw_failaction = new_fail})
|
|
| Lstringswitch(l,sw,d) ->
|
|
Lstringswitch
|
|
(simplif l,List.map (fun (s,l) -> s,simplif l) sw,
|
|
Misc.may_map simplif d)
|
|
| Lstaticraise (i,[]) as l ->
|
|
begin try
|
|
let _,handler = Hashtbl.find subst i in
|
|
handler
|
|
with
|
|
| Not_found -> l
|
|
end
|
|
| Lstaticraise (i,ls) ->
|
|
let ls = List.map simplif ls in
|
|
begin try
|
|
let xs,handler = Hashtbl.find subst i in
|
|
let ys = List.map Ident.rename xs in
|
|
let env =
|
|
List.fold_right2
|
|
(fun x y t -> Ident.add x (Lvar y) t)
|
|
xs ys Ident.empty in
|
|
List.fold_right2
|
|
(fun y l r -> Llet (Alias, y, l, r))
|
|
ys ls (Lambda.subst_lambda env handler)
|
|
with
|
|
| Not_found -> Lstaticraise (i,ls)
|
|
end
|
|
| Lstaticcatch (l1,(i,[]),(Lstaticraise (_j,[]) as l2)) ->
|
|
Hashtbl.add subst i ([],simplif l2) ;
|
|
simplif l1
|
|
| Lstaticcatch (l1,(i,xs),l2) ->
|
|
begin match count_exit i with
|
|
| 0 -> simplif l1
|
|
| 1 when i >= 0 ->
|
|
Hashtbl.add subst i (xs,simplif l2) ;
|
|
simplif l1
|
|
| _ ->
|
|
Lstaticcatch (simplif l1, (i,xs), simplif l2)
|
|
end
|
|
| Ltrywith(l1, v, l2) -> Ltrywith(simplif l1, v, simplif l2)
|
|
| Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif l1, simplif l2, simplif l3)
|
|
| Lsequence(l1, l2) -> Lsequence(simplif l1, simplif l2)
|
|
| Lwhile(l1, l2) -> Lwhile(simplif l1, simplif l2)
|
|
| Lfor(v, l1, l2, dir, l3) ->
|
|
Lfor(v, simplif l1, simplif l2, dir, simplif l3)
|
|
| Lassign(v, l) -> Lassign(v, simplif l)
|
|
| Lsend(k, m, o, ll, loc) ->
|
|
Lsend(k, simplif m, simplif o, List.map simplif ll, loc)
|
|
| Levent(l, ev) -> Levent(simplif l, ev)
|
|
| Lifused(v, l) -> Lifused (v,simplif l)
|
|
in
|
|
simplif lam
|
|
|
|
(* Compile-time beta-reduction of functions immediately applied:
|
|
Lapply(Lfunction(Curried, params, body), args, loc) ->
|
|
let paramN = argN in ... let param1 = arg1 in body
|
|
Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock(args))], loc) ->
|
|
let paramN = argN in ... let param1 = arg1 in body
|
|
Assumes |args| = |params|.
|
|
*)
|
|
|
|
let beta_reduce params body args =
|
|
List.fold_left2 (fun l param arg -> Llet(Strict, param, arg, l))
|
|
body params args
|
|
|
|
(* Simplification of lets *)
|
|
|
|
let simplify_lets lam =
|
|
|
|
(* Disable optimisations for bytecode compilation with -g flag *)
|
|
let optimize = !Clflags.native_code || not !Clflags.debug in
|
|
|
|
(* First pass: count the occurrences of all let-bound identifiers *)
|
|
|
|
let occ = (Hashtbl.create 83: (Ident.t, int ref) Hashtbl.t) in
|
|
(* The global table [occ] associates to each let-bound identifier
|
|
the number of its uses (as a reference):
|
|
- 0 if never used
|
|
- 1 if used exactly once in and not under a lambda or within a loop
|
|
- > 1 if used several times or under a lambda or within a loop.
|
|
The local table [bv] associates to each locally-let-bound variable
|
|
its reference count, as above. [bv] is enriched at let bindings
|
|
but emptied when crossing lambdas and loops. *)
|
|
|
|
(* Current use count of a variable. *)
|
|
let count_var v =
|
|
try
|
|
!(Hashtbl.find occ v)
|
|
with Not_found ->
|
|
0
|
|
|
|
(* Entering a [let]. Returns updated [bv]. *)
|
|
and bind_var bv v =
|
|
let r = ref 0 in
|
|
Hashtbl.add occ v r;
|
|
Tbl.add v r bv
|
|
|
|
(* Record a use of a variable *)
|
|
and use_var bv v n =
|
|
try
|
|
let r = Tbl.find v bv in r := !r + n
|
|
with Not_found ->
|
|
(* v is not locally bound, therefore this is a use under a lambda
|
|
or within a loop. Increase use count by 2 -- enough so
|
|
that single-use optimizations will not apply. *)
|
|
try
|
|
let r = Hashtbl.find occ v in r := !r + 2
|
|
with Not_found ->
|
|
(* Not a let-bound variable, ignore *)
|
|
() in
|
|
|
|
let rec count bv = function
|
|
| Lconst _ -> ()
|
|
| Lvar v ->
|
|
use_var bv v 1
|
|
| Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args}
|
|
when optimize && List.length params = List.length args ->
|
|
count bv (beta_reduce params body args)
|
|
| Lapply{ap_func = Lfunction{kind = Tupled; params; body};
|
|
ap_args = [Lprim(Pmakeblock _, args)]}
|
|
when optimize && List.length params = List.length args ->
|
|
count bv (beta_reduce params body args)
|
|
| Lapply{ap_func = l1; ap_args = ll} ->
|
|
count bv l1; List.iter (count bv) ll
|
|
| Lfunction {body} ->
|
|
count Tbl.empty body
|
|
| Llet(_str, v, Lvar w, l2) when optimize ->
|
|
(* v will be replaced by w in l2, so each occurrence of v in l2
|
|
increases w's refcount *)
|
|
count (bind_var bv v) l2;
|
|
use_var bv w (count_var v)
|
|
| Llet(str, v, l1, l2) ->
|
|
count (bind_var bv v) l2;
|
|
(* If v is unused, l1 will be removed, so don't count its variables *)
|
|
if str = Strict || count_var v > 0 then count bv l1
|
|
| Lletrec(bindings, body) ->
|
|
List.iter (fun (_v, l) -> count bv l) bindings;
|
|
count bv body
|
|
| Lprim(_p, ll) -> List.iter (count bv) ll
|
|
| Lswitch(l, sw) ->
|
|
count_default bv sw ;
|
|
count bv l;
|
|
List.iter (fun (_, l) -> count bv l) sw.sw_consts;
|
|
List.iter (fun (_, l) -> count bv l) sw.sw_blocks
|
|
| Lstringswitch(l, sw, d) ->
|
|
count bv l ;
|
|
List.iter (fun (_, l) -> count bv l) sw ;
|
|
begin match d with
|
|
| Some d ->
|
|
begin match sw with
|
|
| []|[_] -> count bv d
|
|
| _ -> count bv d ; count bv d
|
|
end
|
|
| None -> ()
|
|
end
|
|
| Lstaticraise (_i,ls) -> List.iter (count bv) ls
|
|
| Lstaticcatch(l1, _, l2) -> count bv l1; count bv l2
|
|
| Ltrywith(l1, _v, l2) -> count bv l1; count bv l2
|
|
| Lifthenelse(l1, l2, l3) -> count bv l1; count bv l2; count bv l3
|
|
| Lsequence(l1, l2) -> count bv l1; count bv l2
|
|
| Lwhile(l1, l2) -> count Tbl.empty l1; count Tbl.empty l2
|
|
| Lfor(_, l1, l2, _dir, l3) -> count bv l1; count bv l2; count Tbl.empty l3
|
|
| Lassign(_v, l) ->
|
|
(* Lalias-bound variables are never assigned, so don't increase
|
|
v's refcount *)
|
|
count bv l
|
|
| Lsend(_, m, o, ll, _) -> List.iter (count bv) (m::o::ll)
|
|
| Levent(l, _) -> count bv l
|
|
| Lifused(v, l) ->
|
|
if count_var v > 0 then count bv l
|
|
|
|
and count_default bv sw = match sw.sw_failaction with
|
|
| None -> ()
|
|
| Some al ->
|
|
let nconsts = List.length sw.sw_consts
|
|
and nblocks = List.length sw.sw_blocks in
|
|
if
|
|
nconsts < sw.sw_numconsts && nblocks < sw.sw_numblocks
|
|
then begin (* default action will occur twice in native code *)
|
|
count bv al ; count bv al
|
|
end else begin (* default action will occur once *)
|
|
assert (nconsts < sw.sw_numconsts || nblocks < sw.sw_numblocks) ;
|
|
count bv al
|
|
end
|
|
in
|
|
count Tbl.empty lam;
|
|
|
|
(* Second pass: remove Lalias bindings of unused variables,
|
|
and substitute the bindings of variables used exactly once. *)
|
|
|
|
let subst = Hashtbl.create 83 in
|
|
|
|
(* This (small) optimisation is always legal, it may uncover some
|
|
tail call later on. *)
|
|
|
|
let mklet (kind,v,e1,e2) = match e2 with
|
|
| Lvar w when optimize && Ident.same v w -> e1
|
|
| _ -> Llet (kind,v,e1,e2) in
|
|
|
|
|
|
let rec simplif = function
|
|
Lvar v as l ->
|
|
begin try
|
|
Hashtbl.find subst v
|
|
with Not_found ->
|
|
l
|
|
end
|
|
| Lconst _ as l -> l
|
|
| Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args}
|
|
when optimize && List.length params = List.length args ->
|
|
simplif (beta_reduce params body args)
|
|
| Lapply{ap_func = Lfunction{kind = Tupled; params; body};
|
|
ap_args = [Lprim(Pmakeblock _, args)]}
|
|
when optimize && List.length params = List.length args ->
|
|
simplif (beta_reduce params body args)
|
|
| Lapply ap -> Lapply {ap with ap_func = simplif ap.ap_func;
|
|
ap_args = List.map simplif ap.ap_args}
|
|
| Lfunction{kind; params; body = l; attr} ->
|
|
begin match simplif l with
|
|
Lfunction{kind=Curried; params=params'; body; attr}
|
|
when kind = Curried && optimize ->
|
|
Lfunction{kind; params = params @ params'; body; attr}
|
|
| body ->
|
|
Lfunction{kind; params; body; attr}
|
|
end
|
|
| Llet(_str, v, Lvar w, l2) when optimize ->
|
|
Hashtbl.add subst v (simplif (Lvar w));
|
|
simplif l2
|
|
| Llet(Strict, v, Lprim(Pmakeblock(0, Mutable), [linit]), lbody)
|
|
when optimize ->
|
|
let slinit = simplif linit in
|
|
let slbody = simplif lbody in
|
|
begin try
|
|
mklet (Variable, v, slinit, eliminate_ref v slbody)
|
|
with Real_reference ->
|
|
mklet(Strict, v, Lprim(Pmakeblock(0, Mutable), [slinit]), slbody)
|
|
end
|
|
| Llet(Alias, v, l1, l2) ->
|
|
begin match count_var v with
|
|
0 -> simplif l2
|
|
| 1 when optimize -> Hashtbl.add subst v (simplif l1); simplif l2
|
|
| _ -> Llet(Alias, v, simplif l1, simplif l2)
|
|
end
|
|
| Llet(StrictOpt, v, l1, l2) ->
|
|
begin match count_var v with
|
|
0 -> simplif l2
|
|
| _ -> mklet(Alias, v, simplif l1, simplif l2)
|
|
end
|
|
| Llet(kind, v, l1, l2) -> mklet(kind, v, simplif l1, simplif l2)
|
|
| Lletrec(bindings, body) ->
|
|
Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body)
|
|
| Lprim(p, ll) -> Lprim(p, List.map simplif ll)
|
|
| Lswitch(l, sw) ->
|
|
let new_l = simplif l
|
|
and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts
|
|
and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks
|
|
and new_fail = Misc.may_map simplif sw.sw_failaction in
|
|
Lswitch
|
|
(new_l,
|
|
{sw with sw_consts = new_consts ; sw_blocks = new_blocks;
|
|
sw_failaction = new_fail})
|
|
| Lstringswitch (l,sw,d) ->
|
|
Lstringswitch
|
|
(simplif l,List.map (fun (s,l) -> s,simplif l) sw,
|
|
Misc.may_map simplif d)
|
|
| Lstaticraise (i,ls) ->
|
|
Lstaticraise (i, List.map simplif ls)
|
|
| Lstaticcatch(l1, (i,args), l2) ->
|
|
Lstaticcatch (simplif l1, (i,args), simplif l2)
|
|
| Ltrywith(l1, v, l2) -> Ltrywith(simplif l1, v, simplif l2)
|
|
| Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif l1, simplif l2, simplif l3)
|
|
| Lsequence(Lifused(v, l1), l2) ->
|
|
if count_var v > 0
|
|
then Lsequence(simplif l1, simplif l2)
|
|
else simplif l2
|
|
| Lsequence(l1, l2) -> Lsequence(simplif l1, simplif l2)
|
|
| Lwhile(l1, l2) -> Lwhile(simplif l1, simplif l2)
|
|
| Lfor(v, l1, l2, dir, l3) ->
|
|
Lfor(v, simplif l1, simplif l2, dir, simplif l3)
|
|
| Lassign(v, l) -> Lassign(v, simplif l)
|
|
| Lsend(k, m, o, ll, loc) ->
|
|
Lsend(k, simplif m, simplif o, List.map simplif ll, loc)
|
|
| Levent(l, ev) -> Levent(simplif l, ev)
|
|
| Lifused(v, l) ->
|
|
if count_var v > 0 then simplif l else lambda_unit
|
|
in
|
|
simplif lam
|
|
|
|
(* Tail call info in annotation files *)
|
|
|
|
let is_tail_native_heuristic : (int -> bool) ref =
|
|
ref (fun _ -> true)
|
|
|
|
let rec emit_tail_infos is_tail lambda =
|
|
let call_kind args =
|
|
if is_tail
|
|
&& ((not !Clflags.native_code)
|
|
|| (!is_tail_native_heuristic (List.length args)))
|
|
then Annot.Tail
|
|
else Annot.Stack in
|
|
match lambda with
|
|
| Lvar _ -> ()
|
|
| Lconst _ -> ()
|
|
| Lapply ap ->
|
|
if ap.ap_should_be_tailcall
|
|
&& not is_tail
|
|
&& Warnings.is_active Warnings.Expect_tailcall
|
|
then Location.prerr_warning ap.ap_loc Warnings.Expect_tailcall;
|
|
emit_tail_infos false ap.ap_func;
|
|
list_emit_tail_infos false ap.ap_args;
|
|
if !Clflags.annotations then
|
|
Stypes.record (Stypes.An_call (ap.ap_loc, call_kind ap.ap_args))
|
|
| Lfunction {body = lam} ->
|
|
emit_tail_infos true lam
|
|
| Llet (_, _, lam, body) ->
|
|
emit_tail_infos false lam;
|
|
emit_tail_infos is_tail body
|
|
| Lletrec (bindings, body) ->
|
|
List.iter (fun (_, lam) -> emit_tail_infos false lam) bindings;
|
|
emit_tail_infos is_tail body
|
|
| Lprim (Pidentity, [arg]) ->
|
|
emit_tail_infos is_tail arg
|
|
| Lprim (Psequand, [arg1; arg2])
|
|
| Lprim (Psequor, [arg1; arg2]) ->
|
|
emit_tail_infos false arg1;
|
|
emit_tail_infos is_tail arg2
|
|
| Lprim (_, l) ->
|
|
list_emit_tail_infos false l
|
|
| Lswitch (lam, sw) ->
|
|
emit_tail_infos false lam;
|
|
list_emit_tail_infos_fun snd is_tail sw.sw_consts;
|
|
list_emit_tail_infos_fun snd is_tail sw.sw_blocks;
|
|
Misc.may (emit_tail_infos is_tail) sw.sw_failaction
|
|
| Lstringswitch (lam, sw, d) ->
|
|
emit_tail_infos false lam;
|
|
List.iter
|
|
(fun (_,lam) -> emit_tail_infos is_tail lam)
|
|
sw ;
|
|
Misc.may (emit_tail_infos is_tail) d
|
|
| Lstaticraise (_, l) ->
|
|
list_emit_tail_infos false l
|
|
| Lstaticcatch (body, _, handler) ->
|
|
emit_tail_infos is_tail body;
|
|
emit_tail_infos is_tail handler
|
|
| Ltrywith (body, _, handler) ->
|
|
emit_tail_infos false body;
|
|
emit_tail_infos is_tail handler
|
|
| Lifthenelse (cond, ifso, ifno) ->
|
|
emit_tail_infos false cond;
|
|
emit_tail_infos is_tail ifso;
|
|
emit_tail_infos is_tail ifno
|
|
| Lsequence (lam1, lam2) ->
|
|
emit_tail_infos false lam1;
|
|
emit_tail_infos is_tail lam2
|
|
| Lwhile (cond, body) ->
|
|
emit_tail_infos false cond;
|
|
emit_tail_infos false body
|
|
| Lfor (_, low, high, _, body) ->
|
|
emit_tail_infos false low;
|
|
emit_tail_infos false high;
|
|
emit_tail_infos false body
|
|
| Lassign (_, lam) ->
|
|
emit_tail_infos false lam
|
|
| Lsend (_, meth, obj, args, loc) ->
|
|
emit_tail_infos false meth;
|
|
emit_tail_infos false obj;
|
|
list_emit_tail_infos false args;
|
|
if !Clflags.annotations then
|
|
Stypes.record (Stypes.An_call (loc, call_kind (obj :: args)));
|
|
| Levent (lam, _) ->
|
|
emit_tail_infos is_tail lam
|
|
| Lifused (_, lam) ->
|
|
emit_tail_infos is_tail lam
|
|
and list_emit_tail_infos_fun f is_tail =
|
|
List.iter (fun x -> emit_tail_infos is_tail (f x))
|
|
and list_emit_tail_infos is_tail =
|
|
List.iter (emit_tail_infos is_tail)
|
|
|
|
(* Split a function with default parameters into a wrapper and an
|
|
inner function. The wrapper fills in missing optional parameters
|
|
with their default value and tail-calls the inner function. The
|
|
wrapper can then hopefully be inlined on most call sites to avoid
|
|
the overhead associated with boxing an optional argument with a
|
|
'Some' constructor, only to deconstruct it immediately in the
|
|
function's body. *)
|
|
|
|
let split_default_wrapper ?(create_wrapper_body = fun lam -> lam)
|
|
fun_id kind params body attr =
|
|
let rec aux map = function
|
|
| Llet(Strict, id, (Lifthenelse(Lvar optparam, _, _) as def), rest) when
|
|
Ident.name optparam = "*opt*" && List.mem optparam params
|
|
&& not (List.mem_assoc optparam map)
|
|
->
|
|
let wrapper_body, inner = aux ((optparam, id) :: map) rest in
|
|
Llet(Strict, id, def, wrapper_body), inner
|
|
| _ when map = [] -> raise Exit
|
|
| body ->
|
|
(* Check that those *opt* identifiers don't appear in the remaining
|
|
body. This should not appear, but let's be on the safe side. *)
|
|
let fv = Lambda.free_variables body in
|
|
List.iter (fun (id, _) -> if IdentSet.mem id fv then raise Exit) map;
|
|
|
|
let inner_id = Ident.create (Ident.name fun_id ^ "_inner") in
|
|
let map_param p = try List.assoc p map with Not_found -> p in
|
|
let args = List.map (fun p -> Lvar (map_param p)) params in
|
|
let wrapper_body =
|
|
Lapply {
|
|
ap_func = Lvar inner_id;
|
|
ap_args = args;
|
|
ap_loc = Location.none;
|
|
ap_should_be_tailcall = false;
|
|
ap_inlined = Default_inline;
|
|
ap_specialised = Default_specialise;
|
|
}
|
|
in
|
|
let inner_params = List.map map_param params in
|
|
let new_ids = List.map Ident.rename inner_params in
|
|
let subst = List.fold_left2
|
|
(fun s id new_id ->
|
|
Ident.add id (Lvar new_id) s)
|
|
Ident.empty inner_params new_ids
|
|
in
|
|
let body = Lambda.subst_lambda subst body in
|
|
let inner_fun =
|
|
Lfunction { kind = Curried; params = new_ids; body; attr; }
|
|
in
|
|
(wrapper_body, (inner_id, inner_fun))
|
|
in
|
|
try
|
|
let wrapper_body, inner = aux [] body in
|
|
[(fun_id, Lfunction{kind; params; body = create_wrapper_body wrapper_body;
|
|
attr}); inner]
|
|
with Exit ->
|
|
[(fun_id, Lfunction{kind; params; body; attr})]
|
|
|
|
(* The entry point:
|
|
simplification + emission of tailcall annotations, if needed. *)
|
|
|
|
let simplify_lambda lam =
|
|
let res = simplify_lets (simplify_exits lam) in
|
|
if !Clflags.annotations || Warnings.is_active Warnings.Expect_tailcall
|
|
then emit_tail_infos true res;
|
|
res
|