diff options
author | Xavier Leroy <xavier.leroy@inria.fr> | 2011-06-12 10:04:46 +0000 |
---|---|---|
committer | Xavier Leroy <xavier.leroy@inria.fr> | 2011-06-12 10:04:46 +0000 |
commit | 9af488cbbd372e3ed5ea5f94f5b2151b13bbd431 (patch) | |
tree | d2318eca4bca658efc6004df19c42e12172e6286 /asmcomp | |
parent | b5bc74437d6cdd6fc3fc760bab84133b16f26c90 (diff) | |
download | ocaml-9af488cbbd372e3ed5ea5f94f5b2151b13bbd431.tar.gz |
PR#5287: Optimized handling of partially-applied functions
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@11086 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
Diffstat (limited to 'asmcomp')
-rw-r--r-- | asmcomp/closure.ml | 28 | ||||
-rw-r--r-- | asmcomp/cmmgen.ml | 73 |
2 files changed, 91 insertions, 10 deletions
diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index aaf3ee7d52..11006df8f4 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -495,6 +495,9 @@ let rec close fenv cenv = function end | Lfunction(kind, params, body) as funct -> close_one_function fenv cenv (Ident.create "fun") funct + + (* We convert [f a] to [let a' = a in fun b c -> f a' b c] + when fun_arity > nargs *) | Lapply(funct, args, loc) -> let nargs = List.length args in begin match (close fenv cenv funct, close_list fenv cenv args) with @@ -507,6 +510,31 @@ let rec close fenv cenv = function when nargs = fundesc.fun_arity -> let app = direct_apply fundesc funct ufunct uargs in (app, strengthen_approx app approx_res) + + | ((ufunct, Value_closure(fundesc, approx_res)), uargs) + when nargs < fundesc.fun_arity -> + let first_args = List.map (fun arg -> + (Ident.create "arg", arg) ) uargs in + let final_args = Array.to_list (Array.init (fundesc.fun_arity - nargs) (fun _ -> + Ident.create "arg")) in + let rec iter args body = + match args with + [] -> body + | (arg1, arg2) :: args -> + iter args + (Ulet ( arg1, arg2, body)) + in + let internal_args = + (List.map (fun (arg1, arg2) -> Lvar arg1) first_args) + @ (List.map (fun arg -> Lvar arg ) final_args) + in + let (new_fun, approx) = close fenv cenv + (Lfunction( + Curried, final_args, Lapply(funct, internal_args, loc))) + in + let new_fun = iter first_args new_fun in + (new_fun, approx) + | ((ufunct, Value_closure(fundesc, approx_res)), uargs) when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity -> let (first_args, rem_args) = split_list fundesc.fun_arity uargs in diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index bf99b7c543..40f7650d98 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -1896,18 +1896,25 @@ let tuplify_function arity = (* Generate currying functions: (defun caml_curryN (arg clos) - (alloc HDR caml_curryN_1 arg clos)) + (alloc HDR caml_curryN_1 <arity (N-1)> caml_curry_N_1_app arg clos)) (defun caml_curryN_1 (arg clos) - (alloc HDR caml_curryN_2 arg clos)) + (alloc HDR caml_curryN_2 <arity (N-2)> caml_curry_N_2_app arg clos)) ... (defun caml_curryN_N-1 (arg clos) - (let (closN-2 clos.cdr - closN-3 closN-2.cdr + (let (closN-2 clos.vars[1] + closN-3 closN-2.vars[1] ... - clos1 clos2.cdr - clos clos1.cdr) + clos1 clos2.vars[1] + clos clos1.vars[1]) (app clos.direct - clos1.car clos2.car ... closN-2.car clos.car arg clos))) *) + clos1.vars[0] ... closN-2.vars[0] clos.vars[0] arg clos))) + Special "shortcut" functions are also generated to handle the + case where a partially applied function is applied to all remaining + arguments in one go. For instance: + (defun caml_curry_N_1_app (arg2 ... argN clos) + (let clos' clos.vars[1] + (app clos'.direct clos.vars[0] arg2 ... argN clos'))) +*) let final_curry_function arity = let last_arg = Ident.create "arg" in @@ -1917,11 +1924,19 @@ let final_curry_function arity = Cop(Capply(typ_addr, Debuginfo.none), get_field (Cvar clos) 2 :: args @ [Cvar last_arg; Cvar clos]) - else begin + else + if n = arity - 1 then + begin let newclos = Ident.create "clos" in Clet(newclos, get_field (Cvar clos) 3, curry_fun (get_field (Cvar clos) 2 :: args) newclos (n-1)) + end else + begin + let newclos = Ident.create "clos" in + Clet(newclos, + get_field (Cvar clos) 4, + curry_fun (get_field (Cvar clos) 3 :: args) newclos (n-1)) end in Cfunction {fun_name = "caml_curry" ^ string_of_int arity ^ @@ -1940,12 +1955,50 @@ let rec intermediate_curry_functions arity num = Cfunction {fun_name = name2; fun_args = [arg, typ_addr; clos, typ_addr]; - fun_body = Cop(Calloc, + fun_body = + if arity - num > 2 then + Cop(Calloc, + [alloc_closure_header 5; + Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1)); + int_const (arity - num - 1); + Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1) ^ "_app"); + Cvar arg; Cvar clos]) + else + Cop(Calloc, [alloc_closure_header 4; Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1)); int_const 1; Cvar arg; Cvar clos]); fun_fast = true} - :: intermediate_curry_functions arity (num+1) + :: + (if arity - num > 2 then + let rec iter i = + if i <= arity then + let arg = Ident.create (Printf.sprintf "arg%d" i) in + (arg, typ_addr) :: iter (i+1) + else [] + in + let direct_args = iter (num+2) in + let rec iter i args clos = + if i = 0 then + Cop(Capply(typ_addr, Debuginfo.none), + (get_field (Cvar clos) 2) :: args @ [Cvar clos]) + else + let newclos = Ident.create "clos" in + Clet(newclos, + get_field (Cvar clos) 4, + iter (i-1) (get_field (Cvar clos) 3 :: args) newclos) + in + let cf = + Cfunction + {fun_name = name1 ^ "_" ^ string_of_int (num+1) ^ "_app"; + fun_args = direct_args @ [clos, typ_addr]; + fun_body = iter (num+1) + (List.map (fun (arg,_) -> Cvar arg) direct_args) clos; + fun_fast = true} + in + cf :: intermediate_curry_functions arity (num+1) + else + intermediate_curry_functions arity (num+1)) end let curry_function arity = |