From a7a5484f2d8de1e7b64c7cbd65d9625649609e81 Mon Sep 17 00:00:00 2001 From: Hongbo Zhang Date: Fri, 17 Jun 2016 10:51:48 -0400 Subject: [PATCH] clean up, improve lam_iter, and free variables --- jscomp/core.mllib | 1 + jscomp/lam.ml | 12 +-- jscomp/lam.mli | 7 +- jscomp/lam_beta_reduce.ml | 4 +- jscomp/lam_beta_reduce_util.ml | 4 +- jscomp/lam_compile.ml | 31 ++++--- jscomp/lam_compile_global.ml | 20 +++-- jscomp/lam_group.ml | 15 ++-- jscomp/lam_inline_util.ml | 37 ++------ jscomp/lam_iter.ml | 78 +++++++++++++++++ jscomp/lam_iter.mli | 25 ++++++ jscomp/lam_pass_alpha_conversion.ml | 4 +- jscomp/lam_pass_exits.ml | 10 +-- jscomp/lam_pass_lets_dce.ml | 16 ++-- jscomp/lam_pass_remove_alias.ml | 42 +++------ jscomp/lam_util.ml | 130 ++++++---------------------- jscomp/lam_util.mli | 4 +- 17 files changed, 228 insertions(+), 212 deletions(-) create mode 100644 jscomp/lam_iter.ml create mode 100644 jscomp/lam_iter.mli diff --git a/jscomp/core.mllib b/jscomp/core.mllib index 14a1fdd1c7..6911789303 100644 --- a/jscomp/core.mllib +++ b/jscomp/core.mllib @@ -8,6 +8,7 @@ config_util lam +lam_iter lam_print lam_compile_env lam_dispatch_primitive diff --git a/jscomp/lam.ml b/jscomp/lam.ml index 81c250d837..9ca02ffa23 100644 --- a/jscomp/lam.ml +++ b/jscomp/lam.ml @@ -119,8 +119,8 @@ let const ct : t = Lconst ct let apply fn args loc status : t = Lapply { fn; args; loc ; status } -let function_ arity kind ids body : t = - Lfunction { arity; kind; params = ids; body} +let function_ ~arity ~kind ~params ~body : t = + Lfunction { arity; kind; params ; body} let let_ kind id e body : t = Llet (kind,id,e,body) @@ -241,7 +241,7 @@ let lift_int32 b : t = let lift_int64 b : t = Lconst (Const_base (Const_int64 b)) -let prim (prim : Prim.t) (ll : t list) : t = +let prim ~primitive:(prim : Prim.t) ~args:(ll : t list) : t = let default () : t = Lprim { primitive = prim ;args = ll } in match ll with | [Lconst a] -> @@ -395,8 +395,10 @@ let rec convert (lam : Lambda.lambda) : t = | Lapply (fn,args,info) -> apply (convert fn) (List.map convert args) info.apply_loc info.apply_status - | Lfunction (kind, ids,body) - -> function_ (List.length ids) kind ids (convert body) + | Lfunction (kind, params,body) + -> function_ + ~arity:(List.length params) ~kind ~params + ~body:(convert body) | Llet (kind,id,e,body) -> Llet(kind,id,convert e, convert body) | Lletrec (bindings,body) diff --git a/jscomp/lam.mli b/jscomp/lam.mli index 067a3e8fb3..d296021a28 100644 --- a/jscomp/lam.mli +++ b/jscomp/lam.mli @@ -89,7 +89,10 @@ val var : Ident.t -> t val const : Lambda.structured_constant -> t val apply : t -> t list -> Location.t -> Lambda.apply_status -> t -val function_ : int -> Lambda.function_kind -> Ident.t list -> t -> t +val function_ : + arity:int -> + kind:Lambda.function_kind -> params:Ident.t list -> body:t -> t + val let_ : Lambda.let_kind -> Ident.t -> t -> t -> t val letrec : (Ident.t * t) list -> t -> t val if_ : triop @@ -115,7 +118,7 @@ val send : t -> t -> t list -> Location.t -> t -val prim : Lambda.primitive -> t list -> t +val prim : primitive:Lambda.primitive -> args:t list -> t val staticcatch : t -> int * Ident.t list -> t -> t diff --git a/jscomp/lam_beta_reduce.ml b/jscomp/lam_beta_reduce.ml index 9e345d428f..38ae4257e2 100644 --- a/jscomp/lam_beta_reduce.ml +++ b/jscomp/lam_beta_reduce.ml @@ -102,7 +102,7 @@ let rewrite (map : (Ident.t, _) Hashtbl.t) | Lfunction{arity; kind; params; body} -> let params = List.map rebind params in let body = aux body in - Lam.function_ arity kind params body + Lam.function_ ~arity ~kind ~params ~body | Lstaticcatch(l1, (i,xs), l2) -> let l1 = aux l1 in let xs = List.map rebind xs in @@ -117,7 +117,7 @@ let rewrite (map : (Ident.t, _) Hashtbl.t) | Lconst _ -> lam | Lprim {primitive; args } -> (* here it makes sure that global vars are not rebound *) - Lam.prim primitive (List.map aux args) + Lam.prim ~primitive ~args:(List.map aux args) | Lapply {fn; args; loc; status } -> let fn = aux fn in let args = List.map aux args in diff --git a/jscomp/lam_beta_reduce_util.ml b/jscomp/lam_beta_reduce_util.ml index b02df2f82d..c49d194931 100644 --- a/jscomp/lam_beta_reduce_util.ml +++ b/jscomp/lam_beta_reduce_util.ml @@ -75,12 +75,12 @@ let simple_beta_reduce params body args = List.iter2 (fun p a -> Hashtbl.add param_hash p {lambda = a; used = false }) params args in begin match aux [] args' with - | us -> + | args -> let result = Hashtbl.fold (fun _param {lambda; used} code -> if not used then Lam.seq lambda code - else code) param_hash (Lam.prim primitive us ) in + else code) param_hash (Lam.prim ~primitive ~args) in Hashtbl.clear param_hash; Some result | exception _ -> diff --git a/jscomp/lam_compile.ml b/jscomp/lam_compile.ml index 4db6550d41..ff493bb033 100644 --- a/jscomp/lam_compile.ml +++ b/jscomp/lam_compile.ml @@ -911,15 +911,22 @@ and begin match fn with | Lfunction {params = [_]; body} - -> compile_lambda cxt (Lam.function_ 0 Curried [] body) + -> + compile_lambda cxt + (Lam.function_ + ~arity:0 + ~kind:Curried + ~params:[] + ~body) | _ -> compile_lambda cxt - (Lam.function_ 0 Curried [] - @@ - Lam.apply fn - [Lam.unit] - Location.none App_na - ) + (Lam.function_ ~arity:0 + ~kind:Curried ~params:[] + ~body:( + Lam.apply fn + [Lam.unit] + Location.none App_na + )) end else begin match fn with @@ -928,10 +935,14 @@ and if len = arity then compile_lambda cxt fn else if len > arity then - let first, rest = Ext_list.take arity args in + let params, rest = Ext_list.take arity args in compile_lambda cxt - (Lam.function_ arity - kind first (Lam.function_ (len - arity) kind rest body)) + (Lam.function_ + ~arity + ~kind ~params + ~body:(Lam.function_ ~arity:(len - arity) + ~kind ~params:rest ~body) + ) else compile_lambda cxt (Lam_util.eta_conversion arity diff --git a/jscomp/lam_compile_global.ml b/jscomp/lam_compile_global.ml index c26b7b22f7..efc8fd0400 100644 --- a/jscomp/lam_compile_global.ml +++ b/jscomp/lam_compile_global.ml @@ -44,13 +44,19 @@ let query_lambda id env = Lam_compile_env.query_and_add_if_not_exist (Lam_module_ident.of_ml id) (Has_env env) ~not_found:(fun id -> assert false) - ~found:(fun {signature = sigs; _} -> - Lam.prim (Pmakeblock(0, Blk_module None, Immutable)) - (List.mapi (fun i _ -> - Lam.prim (Pfield (i, Lambda.Fld_na)) - [Lam.prim (Pgetglobal id) [] ] ) - sigs) - ) + ~found:(fun {signature = sigs; _} + -> + Lam.prim + ~primitive:(Pmakeblock(0, Blk_module None, Immutable)) + ~args:( + List.mapi (fun i _ -> + Lam.prim + ~primitive:(Pfield (i, Lambda.Fld_na)) + ~args:[ + Lam.prim + ~primitive:(Pgetglobal id) + ~args:[]]) + sigs)) (* Given an module name and position, find its corresponding name *) diff --git a/jscomp/lam_group.ml b/jscomp/lam_group.ml index 93eb8a825e..7a25462af2 100644 --- a/jscomp/lam_group.ml +++ b/jscomp/lam_group.ml @@ -140,7 +140,10 @@ let deep_flatten let id' = Ident.rename id in flatten acc (Lam.let_ str id' arg - (Lam.let_ Alias id (Lam.prim (Pccall p) [Lam.var id']) + (Lam.let_ Alias id + (Lam.prim + ~primitive:(Pccall p) + ~args: [Lam.var id']) body) ) | Llet (str,id,arg,body) -> @@ -302,11 +305,11 @@ let deep_flatten (* TODO: note when int is too big, [caml_int64_to_float] is unsafe *) Lam.const (Const_base (Const_float (Js_number.to_string (Int64.to_float i) ))) - | Lprim {primitive = p; args = ll} + | Lprim {primitive ; args } -> begin - let ll = List.map aux ll in - match p, ll with + let args = List.map aux args in + match primitive, args with (* Simplify %revapply, for n-ary functions with n > 1 *) | Prevapply loc, [x; Lapply {fn = f; args; _}] | Prevapply loc, [x; Levent (Lapply {fn = f; args; _},_)] -> @@ -319,10 +322,10 @@ let deep_flatten Lam.apply f (args@[x]) loc App_na | Pdirapply loc, [f; x] -> Lam.apply f [x] loc App_na - | _ -> Lam.prim p ll + | _ -> Lam.prim ~primitive ~args end | Lfunction{arity; kind; params; body = l} -> - Lam.function_ arity kind params (aux l) + Lam.function_ ~arity ~kind ~params ~body:(aux l) | Lswitch(l, {sw_failaction; sw_consts; sw_blocks; diff --git a/jscomp/lam_inline_util.ml b/jscomp/lam_inline_util.ml index c70f252037..f5e1bd34f6 100644 --- a/jscomp/lam_inline_util.ml +++ b/jscomp/lam_inline_util.ml @@ -28,41 +28,18 @@ +(* TODO: add a context, like + [args] + [Lfunction(params,body)] + *) let maybe_functor (name : string) = name.[0] >= 'A' && name.[0] <= 'Z' -let should_be_functor (name : string) lam = - maybe_functor name && - (function | Lam.Lfunction _ -> true | _ -> false) lam +let should_be_functor (name : string) (lam : Lam.t) = + maybe_functor name && + (match lam with Lfunction _ -> true | _ -> false) -(* TODO: add a context, like - [args] - [Lfunction(params,body)] - *) -(* HONGBO .. doe snot look like this function is used (not in .mli) *) -(* let app_definitely_inlined (body : Lam.t) = *) -(* match body with *) -(* | Lvar _ *) -(* | Lconst _ *) -(* | Lprim _ *) -(* | Lapply _ -> true *) -(* | Llet _ *) -(* | Lletrec _ *) -(* | Lstringswitch _ *) -(* | Lswitch _ *) -(* | Lstaticraise _ *) -(* | Lfunction _ *) -(* | Lstaticcatch _ *) -(* | Ltrywith _ *) -(* | Lifthenelse _ *) -(* | Lsequence _ *) -(* | Lwhile _ *) -(* | Lfor _ *) -(* | Lassign _ *) -(* | Lsend _ *) -(* | Levent _ *) -(* | Lifused _ -> false *) diff --git a/jscomp/lam_iter.ml b/jscomp/lam_iter.ml new file mode 100644 index 0000000000..5a19298905 --- /dev/null +++ b/jscomp/lam_iter.ml @@ -0,0 +1,78 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + + +let inner_iter f l = + match (l : Lam.t) with + Lvar _ + | Lconst _ -> () + | Lapply{fn; args; _} -> + f fn; List.iter f args + | Lfunction{body;_} -> + f body + | Llet(str, id, arg, body) -> + f arg; f body + | Lletrec(decl, body) -> + f body; + List.iter (fun (id, exp) -> f exp) decl + | Lprim {args; _} -> + List.iter f args + | Lswitch(arg, sw) -> + f arg; + List.iter (fun (key, case) -> f case) sw.sw_consts; + List.iter (fun (key, case) -> f case) sw.sw_blocks; + begin match sw.sw_failaction with + | None -> () + | Some a -> f a + end + | Lstringswitch (arg,cases,default) -> + f arg ; + List.iter (fun (_,act) -> f act) cases ; + begin match default with + | None -> () + | Some a -> f a + end + | Lstaticraise (_,args) -> + List.iter f args + | Lstaticcatch(e1, (_,vars), e2) -> + f e1; f e2 + | Ltrywith(e1, exn, e2) -> + f e1; f e2 + | Lifthenelse(e1, e2, e3) -> + f e1; f e2; f e3 + | Lsequence(e1, e2) -> + f e1; f e2 + | Lwhile(e1, e2) -> + f e1; f e2 + | Lfor(v, e1, e2, dir, e3) -> + f e1; f e2; f e3 + | Lassign(id, e) -> + f e + | Lsend (k, met, obj, args, _) -> + List.iter f (met::obj::args) + | Levent (lam, evt) -> + f lam + | Lifused (v, e) -> + f e + diff --git a/jscomp/lam_iter.mli b/jscomp/lam_iter.mli new file mode 100644 index 0000000000..0db25653dd --- /dev/null +++ b/jscomp/lam_iter.mli @@ -0,0 +1,25 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +val inner_iter : (Lam.t -> unit) -> Lam.t -> unit diff --git a/jscomp/lam_pass_alpha_conversion.ml b/jscomp/lam_pass_alpha_conversion.ml index 74233ae781..bc0384f110 100644 --- a/jscomp/lam_pass_alpha_conversion.ml +++ b/jscomp/lam_pass_alpha_conversion.ml @@ -73,10 +73,10 @@ let alpha_conversion (meta : Lam_stats.meta) (lam : Lam.t) : Lam.t = let bindings = List.map (fun (k,l) -> (k, simpl l)) bindings in Lam.letrec bindings (simpl body) | Lprim {primitive; args } -> - Lam.prim primitive (List.map simpl args) + Lam.prim ~primitive ~args:(List.map simpl args) | Lfunction {arity; kind; params; body = l} -> (* Lam_mk.lfunction kind params (simpl l) *) - Lam.function_ arity kind params (simpl l) + Lam.function_ ~arity ~kind ~params ~body:(simpl l) | Lswitch (l, {sw_failaction; sw_consts; sw_blocks; diff --git a/jscomp/lam_pass_exits.ml b/jscomp/lam_pass_exits.ml index 692406a208..ceb894d1f8 100644 --- a/jscomp/lam_pass_exits.ml +++ b/jscomp/lam_pass_exits.ml @@ -252,17 +252,17 @@ let subst_helper (subst : subst_tbl) query lam = | Lapply {fn = l1; args = ll; loc; status } -> Lam.apply (simplif l1) (List.map simplif ll) loc status | Lfunction {arity; kind; params; body = l} -> - Lam.function_ arity kind params (simplif l) + Lam.function_ ~arity ~kind ~params ~body:(simplif l) | Llet (kind, v, l1, l2) -> Lam.let_ kind v (simplif l1) (simplif l2) | Lletrec (bindings, body) -> Lam.letrec ( List.map (fun (v, l) -> (v, simplif l)) bindings) (simplif body) - | Lprim {primitive = p; args= ll; _} -> + | Lprim {primitive; args; _} -> begin - let ll = List.map simplif ll in - match p, ll with + let args = List.map simplif args in + match primitive, args with (* Simplify %revapply, for n-ary functions with n > 1 *) | Prevapply loc, [x; Lapply {fn = f; args; _}] | Prevapply loc, [x; Levent (Lapply {fn = f; args; _},_)] -> @@ -275,7 +275,7 @@ let subst_helper (subst : subst_tbl) query lam = Lam.apply f (args@[x]) loc App_na | Pdirapply loc, [f; x] -> Lam.apply f [x] loc App_na - | _ -> Lam.prim p ll + | _ -> Lam.prim primitive args end | Lswitch(l, sw) -> let new_l = simplif l diff --git a/jscomp/lam_pass_lets_dce.ml b/jscomp/lam_pass_lets_dce.ml index 8a2973fb9f..9ed299aa43 100644 --- a/jscomp/lam_pass_lets_dce.ml +++ b/jscomp/lam_pass_lets_dce.ml @@ -54,7 +54,7 @@ let rec eliminate_ref id (lam : Lam.t) = Lam.assign id (eliminate_ref id e) | Lprim {primitive = Poffsetref delta ; args = [Lvar v]} when Ident.same v id -> - Lam.assign id (Lam.prim (Poffsetint delta) [Lam.var id]) + Lam.assign id (Lam.prim ~primitive:(Poffsetint delta) ~args:[Lam.var id]) | Lconst _ -> lam | Lapply{fn = e1; args = el; loc; status} -> Lam.apply @@ -67,8 +67,8 @@ let rec eliminate_ref id (lam : Lam.t) = Lam.letrec (List.map (fun (v, e) -> (v, eliminate_ref id e)) idel) (eliminate_ref id e2) - | Lprim {primitive = p; args = el} -> - Lam.prim p (List.map (eliminate_ref id) el) + | Lprim {primitive ; args } -> + Lam.prim ~primitive ~args:(List.map (eliminate_ref id) args) | Lswitch(e, sw) -> Lam.switch(eliminate_ref id e) {sw_numconsts = sw.sw_numconsts; @@ -150,7 +150,8 @@ let lets_helper (count_var : Ident.t -> used_info) lam = Hashtbl.add subst v (simplif (Lam.var w)); simplif l2 | Llet((Strict | StrictOpt as kind) , - v, (Lprim {primitive = (Pmakeblock(0, tag_info, Mutable) as prim); + v, (Lprim {primitive = (Pmakeblock(0, tag_info, Mutable) + as primitive); args = [linit]}), lbody) -> let slinit = simplif linit in @@ -161,7 +162,7 @@ let lets_helper (count_var : Ident.t -> used_info) lam = ~kind:Variable v slinit (eliminate_ref v slbody) with Real_reference -> Lam_util.refine_let - ~kind v (Lam.prim prim [slinit]) + ~kind v (Lam.prim ~primitive ~args:[slinit]) slbody end | Llet(Alias, v, l1, l2) -> @@ -237,13 +238,14 @@ let lets_helper (count_var : Ident.t -> used_info) lam = | Lapply{fn = l1;args = ll; loc; status} -> Lam.apply (simplif l1) (List.map simplif ll) loc status | Lfunction{arity; kind; params; body = l} -> - Lam.function_ arity kind params (simplif l) + Lam.function_ ~arity ~kind ~params ~body:(simplif l) | Lconst _ -> lam | Lletrec(bindings, body) -> Lam.letrec (List.map (fun (v, l) -> (v, simplif l)) bindings) (simplif body) - | Lprim {primitive = p; args = ll} -> Lam.prim p (List.map simplif ll) + | Lprim {primitive; args } + -> Lam.prim ~primitive ~args:(List.map simplif args) | Lswitch(l, sw) -> let new_l = simplif l and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts diff --git a/jscomp/lam_pass_remove_alias.ml b/jscomp/lam_pass_remove_alias.ml index a7dc0d9183..169f0e6103 100644 --- a/jscomp/lam_pass_remove_alias.ml +++ b/jscomp/lam_pass_remove_alias.ml @@ -71,14 +71,14 @@ let simplify_alias let l1 = match x with | Null - -> Lam.not ( Lam.prim Lam.Prim.js_is_nil [l]) + -> Lam.not ( Lam.prim ~primitive:Lam.Prim.js_is_nil ~args:[l]) | Undefined -> - Lam.not (Lam.prim Lam.Prim.js_is_undef [l]) + Lam.not (Lam.prim ~primitive:Lam.Prim.js_is_undef ~args:[l]) | Null_undefined -> Lam.not - ( Lam.prim Lam.Prim.js_is_nil_undef [l]) + ( Lam.prim ~primitive:Lam.Prim.js_is_nil_undef ~args:[l]) | Normal -> l1 in Lam.if_ l1 (simpl l2) (simpl l3) @@ -95,8 +95,8 @@ let simplify_alias | Lletrec(bindings, body) -> let bindings = List.map (fun (k,l) -> (k, simpl l) ) bindings in Lam.letrec bindings (simpl body) - | Lprim {primitive = prim; args = ll} - -> Lam.prim prim (List.map simpl ll) + | Lprim {primitive; args } + -> Lam.prim ~primitive ~args:(List.map simpl args) (* complicated 1. inline this function @@ -143,11 +143,11 @@ let simplify_alias - scope issues - code bloat *) - | Lapply{fn = (Lvar v as l1); args; loc ; status} -> + | Lapply{fn = (Lvar v as fn); args; loc ; status} -> (* Check info for always inlining *) (* Ext_log.dwarn __LOC__ "%s/%d" v.name v.stamp; *) - + let normal () = Lam.apply ( simpl fn) (List.map simpl args) loc status in begin match Hashtbl.find meta.ident_tbl v with | Function {lambda = Lfunction {params; body} as _m; @@ -155,6 +155,7 @@ let simplify_alias _ } -> let lam_size = Lam_analysis.size body in + if Ext_list.same_length args params (* && false *) then if Lam_inline_util.maybe_functor v.name @@ -200,29 +201,14 @@ let simplify_alias simpl (Lam_beta_reduce.propogate_beta_reduce_with_map meta param_map params body args) end - | _ -> - Lam.apply ( simpl l1) (List.map simpl args) loc status + | _ -> normal () else - begin - (* Ext_log.dwarn __LOC__ "%s/%d: %d " *) - (* v.name v.stamp lam_size *) - (* ; *) - Lam.apply ( simpl l1) (List.map simpl args) loc status - end + normal () else - begin - (* Ext_log.dwarn __LOC__ "%d vs %d " (List.length args) (List.length params); *) - Lam.apply ( simpl l1) (List.map simpl args) loc status - end + normal () + | _ -> normal () + | exception Not_found -> normal () - | _ -> - begin - (* Ext_log.dwarn __LOC__ "%s/%d -- no source " v.name v.stamp; *) - Lam.apply ( simpl l1) (List.map simpl args) loc status - end - | exception Not_found -> - (* Ext_log.dwarn __LOC__ "%s/%d -- not found " v.name v.stamp; *) - Lam.apply ( simpl l1) (List.map simpl args) loc status end | Lapply{ fn = Lfunction{ kind = Curried ; params; body}; args; _} @@ -239,7 +225,7 @@ let simplify_alias | Lapply {fn = l1; args = ll; loc ; status} -> Lam.apply (simpl l1) (List.map simpl ll) loc status | Lfunction {arity; kind; params; body = l} - -> Lam.function_ arity kind params (simpl l) + -> Lam.function_ ~arity ~kind ~params ~body:(simpl l) | Lswitch (l, {sw_failaction; sw_consts; sw_blocks; diff --git a/jscomp/lam_util.ml b/jscomp/lam_util.ml index f33b82e2e1..e864953f78 100644 --- a/jscomp/lam_util.ml +++ b/jscomp/lam_util.ml @@ -84,8 +84,8 @@ let add_required_modules ( x : Ident.t list) (meta : Lam_stats.meta) = Assumes that the image of the substitution is out of reach of the bound variables of the lambda-term (no capture). *) -let subst_lambda s lam = - let rec subst (x : Lam.t) = +let subst_lambda (s : Lam.t Ident_map.t) lam = + let rec subst (x : Lam.t) : Lam.t = match x with | Lvar id as l -> begin @@ -95,13 +95,13 @@ let subst_lambda s lam = | Lapply{fn; args; loc; status} -> Lam.apply (subst fn) (List.map subst args) loc status | Lfunction {arity; kind; params; body} -> - Lam.function_ arity kind params (subst body) + Lam.function_ ~arity ~kind ~params ~body:(subst body) | Llet(str, id, arg, body) -> Lam.let_ str id (subst arg) (subst body) | Lletrec(decl, body) -> Lam.letrec (List.map subst_decl decl) (subst body) | Lprim { primitive ; args; _} -> - Lam.prim primitive (List.map subst args) + Lam.prim ~primitive ~args:(List.map subst args) | Lswitch(arg, sw) -> Lam.switch (subst arg) {sw with sw_consts = List.map subst_case sw.sw_consts; @@ -156,7 +156,7 @@ let refine_let | _, _, Lprim {primitive ; args = [Lvar w]; _} when Ident.same w param && (function | Lambda.Pmakeblock _ -> false | _ -> true) primitive (* don't inline inside a block *) - -> Lam.prim primitive [arg] + -> Lam.prim ~primitive ~args:[arg] (* we can not do this substitution when capttured *) (* | _, Lvar _, _ -> (\** let u = h in xxx*\) *) (* (\* assert false *\) *) @@ -287,9 +287,8 @@ let kind_of_lambda_block kind (xs : Lam.t list) : Lam_stats.kind = let get lam v i tbl : Lam.t = match (Hashtbl.find tbl v : Lam_stats.kind) with | Module g -> - Lam.prim - (Pfield (i, Lambda.Fld_na)) - [Lam.prim (Pgetglobal g) [] ] + Lam.prim ~primitive:(Pfield (i, Lambda.Fld_na)) + ~args:[Lam.prim ~primitive:(Pgetglobal g) ~args:[] ] | ImmutableBlock (arr, _) -> begin match arr.(i) with | NA -> lam @@ -336,12 +335,11 @@ let ident_set_of_list ls = let print_ident_set fmt s = Format.fprintf fmt "@[{%a}@]@." (fun fmt s -> - Ident_set.iter (fun e -> Format.fprintf fmt "@[%a@],@ " Ident.print e) s + Ident_set.iter + (fun e -> Format.fprintf fmt "@[%a@],@ " Ident.print e) s ) s -let mk_apply_info ?(loc = Location.none) apply_status : Lambda.apply_info = - { apply_loc = loc; apply_status } @@ -362,22 +360,7 @@ let not_function (lam : Lam.t) = lapply (let a = 3 in let b = 4 in fun x y -> x + y) 2 3 ]} *) -let (* rec *) lapply (fn : Lam.t) args loc status = - (* match fn with *) - (* | Lambda.Lfunction(kind, params, body) -> *) - (* let rec aux acc params args = *) - (* match params, args with *) - (* | [], [] -> acc, body *) - (* | [], args' -> acc, lapply body args' info *) - (* | params' , [] -> *) - (* acc, Lambda.Lfunction(kind, params', body) *) - (* | x::xs, y::ys -> aux ((x,y)::acc) xs ys in *) - (* let env, rest = aux [] params args in *) - (* List.fold_left *) - (* (fun acc (v,e) -> *) - (* Lambda.Llet (Strict,v,e ,acc) ) rest env *) - - (* | _ -> *) Lam.apply fn args loc status + (* let f x y = x + y Invariant: there is no currying @@ -404,8 +387,8 @@ let eta_conversion n loc status fn args = | fn::args , bindings -> let rest : Lam.t = - Lam.function_ n Curried extra_args - (lapply fn (args @ extra_lambdas) + Lam.function_ ~arity:n ~kind:Curried ~params:extra_args + ~body:(Lam.apply fn (args @ extra_lambdas) loc status ) in @@ -416,89 +399,30 @@ let eta_conversion n loc status fn args = end -(* FIXME: application location is important for error message *) -let default_apply_info : Lambda.apply_info = - { apply_status = App_na ; apply_loc = Location.none } - - - - -let iter_opt f = function - | None -> () - | Some e -> f e - -let iter f l = - match (l : Lam.t) with - Lvar _ - | Lconst _ -> () - | Lapply{fn; args; _} -> - f fn; List.iter f args - | Lfunction{body;_} -> - f body - | Llet(str, id, arg, body) -> - f arg; f body - | Lletrec(decl, body) -> - f body; - List.iter (fun (id, exp) -> f exp) decl - | Lprim {args; _} -> - List.iter f args - | Lswitch(arg, sw) -> - f arg; - List.iter (fun (key, case) -> f case) sw.sw_consts; - List.iter (fun (key, case) -> f case) sw.sw_blocks; - iter_opt f sw.sw_failaction - | Lstringswitch (arg,cases,default) -> - f arg ; - List.iter (fun (_,act) -> f act) cases ; - iter_opt f default - | Lstaticraise (_,args) -> - List.iter f args - | Lstaticcatch(e1, (_,vars), e2) -> - f e1; f e2 - | Ltrywith(e1, exn, e2) -> - f e1; f e2 - | Lifthenelse(e1, e2, e3) -> - f e1; f e2; f e3 - | Lsequence(e1, e2) -> - f e1; f e2 - | Lwhile(e1, e2) -> - f e1; f e2 - | Lfor(v, e1, e2, dir, e3) -> - f e1; f e2; f e3 - | Lassign(id, e) -> - f e - | Lsend (k, met, obj, args, _) -> - List.iter f (met::obj::args) - | Levent (lam, evt) -> - f lam - | Lifused (v, e) -> - f e - -let free_ids get (l : Lam.t) = + + +let free_variables l = let fv = ref Ident_set.empty in - let rec free l = - iter free l; - fv := List.fold_right Ident_set.add (get l) !fv; + let rec free (l : Lam.t) = + Lam_iter.inner_iter free l; match l with - | Lfunction{ params;} -> (* TODO: learn *) - List.iter (fun param -> fv := Ident_set.remove param !fv) params + | Lvar id -> fv := Ident_set.add id !fv + | Lfunction{ params;} -> + List.iter (fun param -> fv := Ident_set.remove param !fv) params | Llet(str, id, arg, body) -> - fv := Ident_set.remove id !fv + fv := Ident_set.remove id !fv | Lletrec(decl, body) -> - List.iter (fun (id, exp) -> fv := Ident_set.remove id !fv) decl + List.iter (fun (id, exp) -> fv := Ident_set.remove id !fv) decl | Lstaticcatch(e1, (_,vars), e2) -> - List.iter (fun id -> fv := Ident_set.remove id !fv) vars + List.iter (fun id -> fv := Ident_set.remove id !fv) vars | Ltrywith(e1, exn, e2) -> - fv := Ident_set.remove exn !fv + fv := Ident_set.remove exn !fv | Lfor(v, e1, e2, dir, e3) -> - fv := Ident_set.remove v !fv + fv := Ident_set.remove v !fv | Lassign(id, e) -> - fv := Ident_set.add id !fv - | Lvar _ | Lconst _ | Lapply _ + fv := Ident_set.add id !fv + | Lconst _ | Lapply _ | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _ | Lifthenelse _ | Lsequence _ | Lwhile _ | Lsend _ | Levent _ | Lifused _ -> () in free l; !fv - -let free_variables l = - free_ids (function Lvar id -> [id] | _ -> []) l diff --git a/jscomp/lam_util.mli b/jscomp/lam_util.mli index 037ca635de..e7ed3ac0bd 100644 --- a/jscomp/lam_util.mli +++ b/jscomp/lam_util.mli @@ -66,8 +66,6 @@ val ident_set_of_list : Ident.t list -> Ident_set.t val print_ident_set : Format.formatter -> Ident_set.t -> unit -val mk_apply_info : ?loc:Location.t -> Lambda.apply_status -> Lambda.apply_info - val not_function : Lam.t -> bool @@ -78,7 +76,7 @@ val eta_conversion : int -> Location.t -> Lambda.apply_status -> Lam.t -> Lam.t list -> Lam.t -val default_apply_info : Lambda.apply_info + val subst_lambda : Lam.t Ident_map.t -> Lam.t -> Lam.t