| Anonymous | Login | Signup for a new account | 2013-05-25 02:35 CEST | ![]() |
| Main | My View | View Issues | Change Log | Roadmap |
| View Issue Details [ Jump to Notes ] | [ Issue History ] [ Print ] | ||||||||||
| ID | Project | Category | View Status | Date Submitted | Last Update | ||||||
| 0005894 | OCaml | OCaml backend (code generation) | public | 2013-01-17 21:07 | 2013-01-23 18:44 | ||||||
| Reporter | chambart | ||||||||||
| Assigned To | |||||||||||
| Priority | normal | Severity | feature | Reproducibility | have not tried | ||||||
| Status | new | Resolution | open | ||||||||
| Platform | OS | OS Version | |||||||||
| Product Version | |||||||||||
| Target Version | Fixed in Version | ||||||||||
| Summary | 0005894: [patch] Avoid boxing float/int32/int64 when doing direct call | ||||||||||
| Description | Functions taking floating points parameters always receive them boxed. When a direct call is done, it is possible to specialise the call to pass those parameters in registers. This also applies to boxed integers. The return value can also be unboxed. This allow avoiding all allocations in a function like let (+) = Nativeint.add let (-) = Nativeint.sub let rec fib n = if n < 2n then 0n + 1n else fib(n-1n) + fib(n-2n) | ||||||||||
| Additional Information | This patch take care of not unboxing parameters when it is possible that this could increase the number of allocation. For instance a function like this let bad (x:float) = ignore [x] (* force boxing of x *) bad will not be specialised because its parameter is used boxed inside its body. In a case like: let rec f x y = let _ = x +. 1. in let _ = y +. 1. in h 1. x and g a b = let _ = a+.1. in let _ = b+.1. in f b 1. and h c d = let _ = c +. 1. in let _ = d +. 1. in let _ = g 1. c in let _ = g 1. d in bad d; only the y parameter of f and a of g will be unboxed. The return value will be unboxed if every possible returned value is unboxed. For instance x +. y is considered unboxed but if b then x +. y else List.hd l is considered boxed because List.hd return an already boxed value. Current problems: - Constants are considered boxed because they are already boxed at compile time, but this may not be the right default choice. It can still be circumvented by things like 0n + 1n in the fibonacci example. - Specialised functions code is duplicated: * It is possible to know that some functions will never be used in direct call: those can be compiled only one time * specialisation could be forbidden over a certain size * the generic version of function specialised only for parameters (not return value) could be compiled by adding a stub before the specialised version. | ||||||||||
| Tags | No tags attached. | ||||||||||
| Attached Files | From 8ea5af4b982d4a10043e1e6e127cb820cd0d72e6 Mon Sep 17 00:00:00 2001
From: Pierre Chambart <pierre.chambart@ocamlpro.org>
Date: Thu, 17 Jan 2013 15:35:47 +0100
Subject: [PATCH 1/5] Preparing for specialisation patches 1
* Lambda.Lfunction type : use a record instead of a tupple for
easier extension
---
bytecomp/bytegen.ml | 12 +++++------
bytecomp/lambda.ml | 22 +++++++++++++-------
bytecomp/lambda.mli | 9 +++++++-
bytecomp/printlambda.ml | 2 +-
bytecomp/simplif.ml | 34 ++++++++++++++++--------------
bytecomp/translclass.ml | 53 +++++++++++++++++++++++++----------------------
bytecomp/translcore.ml | 27 ++++++++++++------------
bytecomp/translmod.ml | 16 +++++++-------
8 files changed, 96 insertions(+), 79 deletions(-)
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index e933df5..fd450fc 100644
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -139,7 +139,7 @@ let rec check_recordwith_updates id e =
;;
let rec size_of_lambda = function
- | Lfunction(kind, params, body) as funct ->
+ | Lfunction _ as funct ->
RHS_block (1 + IdentSet.cardinal(free_variables funct))
| Llet (Strict, id, Lprim (Pduprecord (kind, size), _), body)
when check_recordwith_updates id body ->
@@ -471,11 +471,11 @@ let rec comp_expr env exp sz cont =
comp_args env args' (sz + 3)
(getmethod :: Kapply nargs :: cont1)
end
- | Lfunction(kind, params, body) -> (* assume kind = Curried *)
+ | Lfunction{ f_params; f_body } -> (* assume kind = Curried *)
let lbl = new_label() in
let fv = IdentSet.elements(free_variables exp) in
let to_compile =
- { params = params; body = body; label = lbl;
+ { params = f_params; body = f_body; label = lbl;
free_vars = fv; num_defs = 1; rec_vars = []; rec_pos = 0 } in
Stack.push to_compile functions_to_compile;
comp_args env (List.map (fun n -> Lvar n) fv) sz
@@ -486,7 +486,7 @@ let rec comp_expr env exp sz cont =
(add_pop 1 cont))
| Lletrec(decl, body) ->
let ndecl = List.length decl in
- if List.for_all (function (_, Lfunction(_,_,_)) -> true | _ -> false)
+ if List.for_all (function (_, Lfunction _) -> true | _ -> false)
decl then begin
(* let rec of functions *)
let fv =
@@ -494,10 +494,10 @@ let rec comp_expr env exp sz cont =
let rec_idents = List.map (fun (id, lam) -> id) decl in
let rec comp_fun pos = function
[] -> []
- | (id, Lfunction(kind, params, body)) :: rem ->
+ | (id, Lfunction{ f_params; f_body }) :: rem ->
let lbl = new_label() in
let to_compile =
- { params = params; body = body; label = lbl; free_vars = fv;
+ { params = f_params; body = f_body; label = lbl; free_vars = fv;
num_defs = ndecl; rec_vars = rec_idents; rec_pos = pos} in
Stack.push to_compile functions_to_compile;
lbl :: comp_fun (pos + 1) rem
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index cfced85..c80d07a 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -156,7 +156,7 @@ type lambda =
Lvar of Ident.t
| Lconst of structured_constant
| Lapply of lambda * lambda list * Location.t
- | Lfunction of function_kind * Ident.t list * lambda
+ | Lfunction of lambda_function
| Llet of let_kind * Ident.t * lambda * lambda
| Lletrec of (Ident.t * lambda) list * lambda
| Lprim of primitive * lambda list
@@ -173,6 +173,11 @@ type lambda =
| Levent of lambda * lambda_event
| Lifused of Ident.t * lambda
+and lambda_function =
+ { f_kind : function_kind;
+ f_params : Ident.t list;
+ f_body : lambda; }
+
and lambda_switch =
{ sw_numconsts: int;
sw_consts: (int * lambda) list;
@@ -203,7 +208,8 @@ let rec same l1 l2 =
c1 = c2
| Lapply(a1, bl1, _), Lapply(a2, bl2, _) ->
same a1 a2 && samelist same bl1 bl2
- | Lfunction(k1, idl1, a1), Lfunction(k2, idl2, a2) ->
+ | Lfunction{ f_kind = k1; f_params = idl1; f_body = a1 },
+ Lfunction{ f_kind = k2; f_params = idl2; f_body = a2 } ->
k1 = k2 && samelist Ident.same idl1 idl2 && same a1 a2
| Llet(k1, id1, a1, b1), Llet(k2, id2, a2, b2) ->
k1 = k2 && Ident.same id1 id2 && same a1 a2 && same b1 b2
@@ -273,8 +279,8 @@ let iter f = function
| Lconst _ -> ()
| Lapply(fn, args, _) ->
f fn; List.iter f args
- | Lfunction(kind, params, body) ->
- f body
+ | Lfunction{ f_body } ->
+ f f_body
| Llet(str, id, arg, body) ->
f arg; f body
| Lletrec(decl, body) ->
@@ -325,8 +331,8 @@ let free_ids get l =
iter free l;
fv := List.fold_right IdentSet.add (get l) !fv;
match l with
- Lfunction(kind, params, body) ->
- List.iter (fun param -> fv := IdentSet.remove param !fv) params
+ Lfunction{ f_params } ->
+ List.iter (fun param -> fv := IdentSet.remove param !fv) f_params
| Llet(str, id, arg, body) ->
fv := IdentSet.remove id !fv
| Lletrec(decl, body) ->
@@ -406,7 +412,7 @@ let subst_lambda s lam =
begin try Ident.find_same id s with Not_found -> l end
| Lconst sc as l -> l
| Lapply(fn, args, loc) -> Lapply(subst fn, List.map subst args, loc)
- | Lfunction(kind, params, body) -> Lfunction(kind, params, subst body)
+ | Lfunction({ f_body } as func) -> Lfunction{ func with f_body = subst f_body }
| Llet(str, id, arg, body) -> Llet(str, id, subst arg, subst body)
| Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body)
| Lprim(p, args) -> Lprim(p, List.map subst args)
@@ -452,3 +458,5 @@ and negate_comparison = function
| Ceq -> Cneq| Cneq -> Ceq
| Clt -> Cge | Cle -> Cgt
| Cgt -> Cle | Cge -> Clt
+
+let lfun f_params f_body = Lfunction {f_kind = Curried; f_params; f_body}
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index 17da073..a124c8e 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -165,7 +165,7 @@ type lambda =
Lvar of Ident.t
| Lconst of structured_constant
| Lapply of lambda * lambda list * Location.t
- | Lfunction of function_kind * Ident.t list * lambda
+ | Lfunction of lambda_function
| Llet of let_kind * Ident.t * lambda * lambda
| Lletrec of (Ident.t * lambda) list * lambda
| Lprim of primitive * lambda list
@@ -182,6 +182,11 @@ type lambda =
| Levent of lambda * lambda_event
| Lifused of Ident.t * lambda
+and lambda_function =
+ { f_kind : function_kind;
+ f_params : Ident.t list;
+ f_body : lambda; }
+
and lambda_switch =
{ sw_numconsts: int; (* Number of integer cases *)
sw_consts: (int * lambda) list; (* Integer cases *)
@@ -219,6 +224,8 @@ val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda
val commute_comparison : comparison -> comparison
val negate_comparison : comparison -> comparison
+val lfun : Ident.t list -> lambda -> lambda
+
(***********************)
(* For static failures *)
(***********************)
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index 6531670..ff12a9f 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -239,7 +239,7 @@ let rec lam ppf = function
let lams ppf largs =
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs
- | Lfunction(kind, params, body) ->
+ | Lfunction { f_kind = kind; f_params = params; f_body = body } ->
let pr_params ppf params =
match kind with
| Curried ->
diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml
index 1492149..6205ce8 100644
--- a/bytecomp/simplif.ml
+++ b/bytecomp/simplif.ml
@@ -26,7 +26,7 @@ let rec eliminate_ref id = function
| Lconst cst as lam -> lam
| Lapply(e1, el, loc) ->
Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el, loc)
- | Lfunction(kind, params, body) as lam ->
+ | Lfunction _ as lam ->
if IdentSet.mem id (free_variables lam)
then raise Real_reference
else lam
@@ -103,7 +103,7 @@ let simplify_exits lam =
let rec count = function
| (Lvar _| Lconst _) -> ()
| Lapply(l1, ll, _) -> count l1; List.iter count ll
- | Lfunction(kind, params, l) -> count l
+ | Lfunction{ f_body } -> count f_body
| Llet(str, v, l1, l2) ->
count l2; count l1
| Lletrec(bindings, body) ->
@@ -184,7 +184,7 @@ let simplify_exits lam =
let rec simplif = function
| (Lvar _|Lconst _) as l -> l
| Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc)
- | Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l)
+ | Lfunction({ f_body } as func) -> Lfunction{ func with f_body = simplif f_body }
| 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)
@@ -332,16 +332,17 @@ let simplify_lets lam =
| Lconst cst -> ()
| Lvar v ->
use_var bv v 1
- | Lapply(Lfunction(Curried, params, body), args, _)
+ | Lapply(Lfunction{ f_kind = Curried; f_params = params; f_body = body }, args, _)
when optimize && List.length params = List.length args ->
count bv (beta_reduce params body args)
- | Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock _, args)], _)
+ | Lapply(Lfunction{ f_kind = Tupled; f_params = params; f_body = body },
+ [Lprim(Pmakeblock _, args)], _)
when optimize && List.length params = List.length args ->
count bv (beta_reduce params body args)
| Lapply(l1, ll, _) ->
count bv l1; List.iter (count bv) ll
- | Lfunction(kind, params, l) ->
- count Tbl.empty l
+ | Lfunction{ f_body } ->
+ count Tbl.empty f_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 *)
@@ -413,14 +414,15 @@ let simplify_lets lam =
l
end
| Lconst cst as l -> l
- | Lapply(Lfunction(Curried, params, body), args, _)
- when optimize && List.length params = List.length args ->
- simplif (beta_reduce params body args)
- | Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock _, args)], _)
- when optimize && List.length params = List.length args ->
- simplif (beta_reduce params body args)
+ | Lapply(Lfunction{ f_kind = Curried; f_params; f_body }, args, _)
+ when optimize && List.length f_params = List.length args ->
+ simplif (beta_reduce f_params f_body args)
+ | Lapply(Lfunction{ f_kind = Tupled; f_params; f_body },
+ [Lprim(Pmakeblock _, args)], _)
+ when optimize && List.length f_params = List.length args ->
+ simplif (beta_reduce f_params f_body args)
| Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc)
- | Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l)
+ | Lfunction({ f_body } as func) -> Lfunction{func with f_body = simplif f_body}
| Llet(str, v, Lvar w, l2) when optimize ->
Hashtbl.add subst v (simplif (Lvar w));
simplif l2
@@ -499,8 +501,8 @@ let rec emit_tail_infos is_tail lambda =
| Lapply (func, l, loc) ->
list_emit_tail_infos false l;
Stypes.record (Stypes.An_call (loc, call_kind l))
- | Lfunction (_, _, lam) ->
- emit_tail_infos true lam
+ | Lfunction { f_body } ->
+ emit_tail_infos true f_body
| Llet (_, _, lam, body) ->
emit_tail_infos false lam;
emit_tail_infos is_tail body
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index ec40912..6bb8acf 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -26,10 +26,10 @@ exception Error of Location.t * error
let lfunction params body =
if params = [] then body else
match body with
- Lfunction (Curried, params', body') ->
- Lfunction (Curried, params @ params', body')
+ Lfunction({f_kind = Curried; f_params = params'} as func) ->
+ Lfunction { func with f_params = params @ params' }
| _ ->
- Lfunction (Curried, params, body)
+ lfun params body
let lapply func args loc =
match func with
@@ -157,13 +157,15 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
(inh_init,
let build params rem =
let param = name_pattern "param" [pat, ()] in
- Lfunction (Curried, param::params,
- Matching.for_function
- pat.pat_loc None (Lvar param) [pat, rem] partial)
+ lfun (param::params)
+ (Matching.for_function
+ pat.pat_loc None (Lvar param) [pat, rem] partial)
in
begin match obj_init with
- Lfunction (Curried, params, rem) -> build params rem
- | rem -> build [] rem
+ Lfunction { f_kind = Curried; f_params = params; f_body = rem } ->
+ build params rem
+ | rem ->
+ build [] rem
end)
| Tcl_apply (cl, oexprs) ->
let (inh_init, obj_init) =
@@ -397,14 +399,16 @@ let rec transl_class_rebind obj_init cl vf =
let path, obj_init = transl_class_rebind obj_init cl vf in
let build params rem =
let param = name_pattern "param" [pat, ()] in
- Lfunction (Curried, param::params,
- Matching.for_function
- pat.pat_loc None (Lvar param) [pat, rem] partial)
+ lfun (param::params)
+ (Matching.for_function
+ pat.pat_loc None (Lvar param) [pat, rem] partial)
in
(path,
match obj_init with
- Lfunction (Curried, params, rem) -> build params rem
- | rem -> build [] rem)
+ Lfunction { f_kind = Curried; f_params; f_body } ->
+ build f_params f_body
+ | rem ->
+ build [] rem)
| Tcl_apply (cl, oexprs) ->
let path, obj_init = transl_class_rebind obj_init cl vf in
(path, transl_apply obj_init oexprs Location.none)
@@ -476,8 +480,8 @@ let rec module_path = function
let const_path local = function
Lvar id -> not (List.mem id local)
| Lconst _ -> true
- | Lfunction (Curried, _, body) ->
- let fv = free_variables body in
+ | Lfunction { f_kind = Curried; f_body } ->
+ let fv = free_variables f_body in
List.for_all (fun x -> not (IdentSet.mem x fv)) local
| p -> module_path p
@@ -516,7 +520,7 @@ let rec builtin_meths self env env2 body =
| Lsend(Cached, met, arg, [_;_], _) ->
let s, args = conv arg in
("send_"^s, met :: args)
- | Lfunction (Curried, [x], body) ->
+ | Lfunction { f_kind = Curried; f_params = [x]; f_body } ->
let rec enter self = function
| Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'])
when Ident.same x x' && List.mem s self ->
@@ -524,7 +528,7 @@ let rec builtin_meths self env env2 body =
| Llet(_, s', Lvar s, body) when List.mem s self ->
enter (s'::self) body
| _ -> raise Not_found
- in enter self body
+ in enter self f_body
| Lfunction _ -> raise Not_found
| _ ->
let s, args = conv body in ("get_"^s, args)
@@ -624,11 +628,11 @@ let transl_class ids cl_id pub_meths cl vflag =
in
let new_ids_meths = ref [] in
let msubst arr = function
- Lfunction (Curried, self :: args, body) ->
+ Lfunction { f_kind = Curried; f_params = self :: args; f_body } ->
let env = Ident.create "env" in
let body' =
- if new_ids = [] then body else
- subst_lambda (subst env body 0 new_ids_meths) body in
+ if new_ids = [] then f_body else
+ subst_lambda (subst env f_body 0 new_ids_meths) f_body in
begin try
(* Doesn't seem to improve size for bytecode *)
(* if not !Clflags.native_code then raise Not_found; *)
@@ -696,7 +700,7 @@ let transl_class ids cl_id pub_meths cl vflag =
let concrete = (vflag = Concrete)
and lclass lam =
- let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in
+ let cl_init = llets (lfun [cla] cl_init) in
Llet(Strict, class_init, cl_init, lam (free_variables cl_init))
and lbody fv =
if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then
@@ -713,7 +717,7 @@ let transl_class ids cl_id pub_meths cl vflag =
Lvar class_init; Lvar env_init; lambda_unit]))))
and lbody_virt lenvs =
Lprim(Pmakeblock(0, Immutable),
- [lambda_unit; Lfunction(Curried,[cla], cl_init); lambda_unit; lenvs])
+ [lambda_unit; lfun [cla] cl_init; lambda_unit; lenvs])
in
(* Still easy: a class defined at toplevel *)
if top && concrete then lclass lbody else
@@ -754,8 +758,7 @@ let transl_class ids cl_id pub_meths cl vflag =
let inh_keys =
List.map (fun (_,p) -> Lprim(Pfield 1, [transl_path p])) inh_paths in
let lclass lam =
- Llet(Strict, class_init,
- Lfunction(Curried, [cla], def_ids cla cl_init), lam)
+ Llet(Strict, class_init, lfun [cla] (def_ids cla cl_init), lam)
and lcache lam =
if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else
Llet(Strict, cached,
@@ -771,7 +774,7 @@ let transl_class ids cl_id pub_meths cl vflag =
Lsequence(mkappl (oo_prim "init_class", [Lvar cla]),
lset cached 0 (Lvar env_init))))
and lclass_virt () =
- lset cached 0 (Lfunction(Curried, [cla], def_ids cla cl_init))
+ lset cached 0 (lfun [cla] (def_ids cla cl_init))
in
llets (
lcache (
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 4e8de1b..717a69a 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -404,12 +404,12 @@ let transl_primitive loc p =
match prim with
Plazyforce ->
let parm = Ident.create "prim" in
- Lfunction(Curried, [parm], Matching.inline_lazy_force (Lvar parm) Location.none)
+ lfun [parm] (Matching.inline_lazy_force (Lvar parm) Location.none)
| _ ->
let rec make_params n =
if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in
let params = make_params p.prim_arity in
- Lfunction(Curried, params, Lprim(prim, List.map (fun id -> Lvar id) params))
+ lfun params (Lprim(prim, List.map (fun id -> Lvar id) params))
(* To check the well-formedness of r.h.s. of "let rec" definitions *)
@@ -431,7 +431,7 @@ let check_recursive_lambda idlist lam =
and check idlist = function
| Lvar _ -> true
- | Lfunction(kind, params, body) -> true
+ | Lfunction _ -> true
| Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam ->
true
| Llet(str, id, arg, body) ->
@@ -612,12 +612,12 @@ and transl_exp0 e =
if public_send || p.prim_name = "%sendself" then
let kind = if public_send then Public else Self in
let obj = Ident.create "obj" and meth = Ident.create "meth" in
- Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, [], e.exp_loc))
+ lfun [obj; meth] (Lsend(kind, Lvar meth, Lvar obj, [], e.exp_loc))
else if p.prim_name = "%sendcache" then
let obj = Ident.create "obj" and meth = Ident.create "meth" in
let cache = Ident.create "cache" and pos = Ident.create "pos" in
- Lfunction(Curried, [obj; meth; cache; pos],
- Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos], e.exp_loc))
+ lfun [obj; meth; cache; pos]
+ (Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos], e.exp_loc))
else
transl_primitive e.exp_loc p
| Texp_ident(path, _, {val_kind = Val_anc _}) ->
@@ -630,13 +630,13 @@ and transl_exp0 e =
| Texp_let(rec_flag, pat_expr_list, body) ->
transl_let rec_flag pat_expr_list (event_before body (transl_exp body))
| Texp_function (_, pat_expr_list, partial) ->
- let ((kind, params), body) =
+ let ((f_kind, f_params), f_body) =
event_function e
(function repr ->
let pl = push_defaults e.exp_loc [] pat_expr_list partial in
transl_function e.exp_loc !Clflags.native_code repr partial pl)
in
- Lfunction(kind, params, body)
+ Lfunction{f_kind; f_params; f_body}
| Texp_apply({exp_desc = Texp_ident(path, _, {val_kind = Val_prim p})}, oargs)
when List.length oargs >= p.prim_arity
&& List.for_all (fun (_, arg,_) -> arg <> None) oargs ->
@@ -858,7 +858,7 @@ and transl_exp0 e =
end
(* other cases compile to a lazy block holding a function *)
| _ ->
- let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in
+ let fn = lfun [Ident.create "param"] (transl_exp e) in
Lprim(Pmakeblock(Config.lazy_tag, Immutable), [fn])
end
| Texp_object (cs, meths) ->
@@ -914,12 +914,11 @@ and transl_apply lam sargs loc =
and id_arg = Ident.create "param" in
let body =
match build_apply handle ((Lvar id_arg, optional)::args') l with
- Lfunction(Curried, ids, lam) ->
- Lfunction(Curried, id_arg::ids, lam)
- | Levent(Lfunction(Curried, ids, lam), _) ->
- Lfunction(Curried, id_arg::ids, lam)
+ Lfunction({ f_kind = Curried } as func)
+ | Levent(Lfunction({ f_kind = Curried } as func), _) ->
+ Lfunction( lfun_add_param func id_arg )
| lam ->
- Lfunction(Curried, [id_arg], lam)
+ lfun [id_arg] lam
in
List.fold_left
(fun body (id, lam) -> Llet(Strict, id, lam, body))
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index 195dcc9..048025a 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -42,10 +42,10 @@ let rec apply_coercion restr arg =
| Tcoerce_functor(cc_arg, cc_res) ->
let param = Ident.create "funarg" in
name_lambda arg (fun id ->
- Lfunction(Curried, [param],
- apply_coercion cc_res
- (Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)],
- Location.none))))
+ lfun [param]
+ (apply_coercion cc_res
+ (Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)],
+ Location.none))))
| Tcoerce_primitive p ->
transl_primitive Location.none p
@@ -241,13 +241,11 @@ let rec transl_module cc rootpath mexp =
oo_wrap mexp.mod_env true
(function
| Tcoerce_none ->
- Lfunction(Curried, [param],
- transl_module Tcoerce_none bodypath body)
+ lfun [param] (transl_module Tcoerce_none bodypath body)
| Tcoerce_functor(ccarg, ccres) ->
let param' = Ident.create "funarg" in
- Lfunction(Curried, [param'],
- Llet(Alias, param, apply_coercion ccarg (Lvar param'),
- transl_module ccres bodypath body))
+ lfun [param'] (Llet(Alias, param, apply_coercion ccarg (Lvar param'),
+ transl_module ccres bodypath body))
| _ ->
fatal_error "Translmod.transl_module")
cc
--
1.7.10.4
From 76370af2250251b070da4f350b866fe5b2fbe7af Mon Sep 17 00:00:00 2001
From: Pierre Chambart <pierre.chambart@ocamlpro.org>
Date: Fri, 11 Jan 2013 18:18:03 +0100
Subject: [PATCH 2/5] Preparing for specialisation patches 2
* Clambda.Udirect_apply type : add the full function_description
instead of only the label.
---
asmcomp/clambda.ml | 4 ++--
asmcomp/clambda.mli | 4 ++--
asmcomp/closure.ml | 21 ++++++++++-----------
asmcomp/cmmgen.ml | 5 +++--
asmcomp/printclambda.ml | 4 ++--
5 files changed, 19 insertions(+), 19 deletions(-)
diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml
index dd53020..42ff697 100644
--- a/asmcomp/clambda.ml
+++ b/asmcomp/clambda.ml
@@ -21,7 +21,7 @@ type function_label = string
type ulambda =
Uvar of Ident.t
| Uconst of structured_constant * string option
- | Udirect_apply of function_label * ulambda list * Debuginfo.t
+ | Udirect_apply of function_description * ulambda list * Debuginfo.t
| Ugeneric_apply of ulambda * ulambda list * Debuginfo.t
| Uclosure of ufunction list * ulambda list
| Uoffset of ulambda * int
@@ -55,7 +55,7 @@ and ulambda_switch =
(* Description of known functions *)
-type function_description =
+and function_description =
{ fun_label: function_label; (* Label of direct entry point *)
fun_arity: int; (* Number of arguments *)
mutable fun_closed: bool; (* True if environment not used *)
diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli
index 737965d..24d1bcc 100644
--- a/asmcomp/clambda.mli
+++ b/asmcomp/clambda.mli
@@ -21,7 +21,7 @@ type function_label = string
type ulambda =
Uvar of Ident.t
| Uconst of structured_constant * string option
- | Udirect_apply of function_label * ulambda list * Debuginfo.t
+ | Udirect_apply of function_description * ulambda list * Debuginfo.t
| Ugeneric_apply of ulambda * ulambda list * Debuginfo.t
| Uclosure of ufunction list * ulambda list
| Uoffset of ulambda * int
@@ -55,7 +55,7 @@ and ulambda_switch =
(* Description of known functions *)
-type function_description =
+and function_description =
{ fun_label: function_label; (* Label of direct entry point *)
fun_arity: int; (* Number of arguments *)
mutable fun_closed: bool; (* True if environment not used *)
diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml
index a151319..5af2d6f 100644
--- a/asmcomp/closure.ml
+++ b/asmcomp/closure.ml
@@ -365,7 +365,7 @@ let no_effects = function
let rec bind_params_rec subst params args body =
match (params, args) with
([], []) -> substitute subst body
- | (p1 :: pl, a1 :: al) ->
+ | ((p1, _) :: pl, a1 :: al) ->
if is_simple_argument a1 then
bind_params_rec (Tbl.add p1 a1 subst) pl al body
else begin
@@ -403,7 +403,7 @@ let direct_apply fundesc funct ufunct uargs =
if fundesc.fun_closed then uargs else uargs @ [ufunct] in
let app =
match fundesc.fun_inline with
- None -> Udirect_apply(fundesc.fun_label, app_args, Debuginfo.none)
+ None -> Udirect_apply(fundesc, app_args, Debuginfo.none)
| Some(params, body) -> bind_params params app_args body in
(* If ufunct can contain side-effects or function definitions,
we must make sure that it is evaluated exactly once.
@@ -503,7 +503,7 @@ let rec close fenv cenv = function
| Const_pointer n -> (Uconst (cst, None), Value_constptr n)
| _ -> (Uconst (cst, Some (Compilenv.new_structured_constant cst true)), Value_unknown)
end
- | Lfunction(kind, params, body) as funct ->
+ | Lfunction{ f_kind; f_params; f_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]
@@ -539,8 +539,7 @@ let rec close fenv cenv = function
@ (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)))
+ (lfun final_args (Lapply(funct, internal_args, loc)))
in
let new_fun = iter first_args new_fun in
(new_fun, approx)
@@ -574,7 +573,7 @@ let rec close fenv cenv = function
end
| Lletrec(defs, body) ->
if List.for_all
- (function (id, Lfunction(_, _, _)) -> true | _ -> false)
+ (function (id, Lfunction _) -> true | _ -> false)
defs
then begin
(* Simple case: only function definitions *)
@@ -705,7 +704,7 @@ and close_list_approx fenv cenv = function
(ulam :: ulams, approx :: approxs)
and close_named fenv cenv id = function
- Lfunction(kind, params, body) as funct ->
+ Lfunction _ as funct ->
close_one_function fenv cenv id funct
| lam ->
close fenv cenv lam
@@ -726,15 +725,15 @@ and close_functions fenv cenv fun_defs =
let uncurried_defs =
List.map
(function
- (id, Lfunction(kind, params, body)) ->
+ (id, Lfunction{ f_kind; f_params; f_body }) ->
let label = Compilenv.make_symbol (Some (Ident.unique_name id)) in
- let arity = List.length params in
+ let arity = List.length f_params in
let fundesc =
{fun_label = label;
- fun_arity = (if kind = Tupled then -arity else arity);
+ fun_arity = (if f_kind = Tupled then -arity else arity);
fun_closed = initially_closed;
fun_inline = None } in
- (id, params, body, fundesc)
+ (id, f_params, f_body, fundesc)
| (_, _) -> fatal_error "Closure.close_functions")
fun_defs in
(* Build an approximate fenv for compiling the functions *)
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index 4e1695e..75cbc6d 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -1053,8 +1053,9 @@ let rec transl = function
Cop(Calloc, transl_fundecls 0 fundecls)
| Uoffset(arg, offset) ->
field_address (transl arg) offset
- | Udirect_apply(lbl, args, dbg) ->
- Cop(Capply(typ_addr, dbg), Cconst_symbol lbl :: List.map transl args)
+ | Udirect_apply(fundesc, args, dbg) ->
+ Cop(Capply(typ_addr, dbg),
+ Cconst_symbol fundesc.fun_label :: List.map transl args)
| Ugeneric_apply(clos, [arg], dbg) ->
bind "fun" (transl clos) (fun clos ->
Cop(Capply(typ_addr, dbg), [get_field clos 0; transl arg; clos]))
diff --git a/asmcomp/printclambda.ml b/asmcomp/printclambda.ml
index 7c4e9ab..ae05e5e 100644
--- a/asmcomp/printclambda.ml
+++ b/asmcomp/printclambda.ml
@@ -27,14 +27,14 @@ let rec lam ppf = function
| Udirect_apply(f, largs, _) ->
let lams ppf largs =
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
- fprintf ppf "@[<2>(apply*@ %s %a)@]" f lams largs
+ fprintf ppf "@[<2>(apply*@ %s %a)@]" f.fun_label lams largs
| Ugeneric_apply(lfun, largs, _) ->
let lams ppf largs =
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs
| Uclosure(clos, fv) ->
let idents ppf =
- List.iter (fprintf ppf "@ %a" Ident.print)in
+ List.iter (fun (id,typ) -> fprintf ppf "@ %a" Ident.print id)in
let one_fun ppf f =
fprintf ppf "(fun@ %s@ %d @[<2>%a@] @[<2>%a@])"
f.label f.arity idents f.params lam f.body in
--
1.7.10.4
From c149b757229deb04e7d7216762f55f1f4aacc3e5 Mon Sep 17 00:00:00 2001
From: Pierre Chambart <pierre.chambart@ocamlpro.org>
Date: Fri, 11 Jan 2013 18:38:38 +0100
Subject: [PATCH 3/5] Propagate simple type informations about parameters and
return value to lambda code
---
bytecomp/lambda.ml | 17 ++++++++++++-
bytecomp/lambda.mli | 7 +++++-
bytecomp/translcore.ml | 64 ++++++++++++++++++++++++++++++++++++------------
3 files changed, 71 insertions(+), 17 deletions(-)
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index c80d07a..c25d534 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -152,6 +152,8 @@ type meth_kind = Self | Public | Cached
type shared_code = (int * int) list
+type value_kind = Vaddr | Vfloat | Vint | Vbint of boxed_integer
+
type lambda =
Lvar of Ident.t
| Lconst of structured_constant
@@ -176,6 +178,8 @@ type lambda =
and lambda_function =
{ f_kind : function_kind;
f_params : Ident.t list;
+ f_params_kind : value_kind list;
+ f_return : value_kind;
f_body : lambda; }
and lambda_switch =
@@ -459,4 +463,15 @@ and negate_comparison = function
| Clt -> Cge | Cle -> Cgt
| Cgt -> Cle | Cge -> Clt
-let lfun f_params f_body = Lfunction {f_kind = Curried; f_params; f_body}
+let lfun ?(kind=Curried) f_params f_body =
+ Lfunction
+ { f_kind = kind;
+ f_return = Vaddr;
+ f_params;
+ f_params_kind = List.map (fun _ -> Vaddr) f_params;
+ f_body }
+
+let lfun_add_param func id_arg =
+ { func with
+ f_params = id_arg::func.f_params;
+ f_params_kind = Vaddr::func.f_params_kind }
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index a124c8e..75ae1ac 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -161,6 +161,8 @@ type meth_kind = Self | Public | Cached
type shared_code = (int * int) list (* stack size -> code label *)
+type value_kind = Vaddr | Vfloat | Vint | Vbint of boxed_integer
+
type lambda =
Lvar of Ident.t
| Lconst of structured_constant
@@ -185,6 +187,8 @@ type lambda =
and lambda_function =
{ f_kind : function_kind;
f_params : Ident.t list;
+ f_params_kind : value_kind list;
+ f_return : value_kind;
f_body : lambda; }
and lambda_switch =
@@ -224,7 +228,8 @@ val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda
val commute_comparison : comparison -> comparison
val negate_comparison : comparison -> comparison
-val lfun : Ident.t list -> lambda -> lambda
+val lfun : ?kind:function_kind -> Ident.t list -> lambda -> lambda
+val lfun_add_param : lambda_function -> Ident.t -> lambda_function
(***********************)
(* For static failures *)
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 717a69a..fb22ff2 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -630,13 +630,35 @@ and transl_exp0 e =
| Texp_let(rec_flag, pat_expr_list, body) ->
transl_let rec_flag pat_expr_list (event_before body (transl_exp body))
| Texp_function (_, pat_expr_list, partial) ->
- let ((f_kind, f_params), f_body) =
+ let ((f_kind, params, return_type), f_body) =
event_function e
(function repr ->
let pl = push_defaults e.exp_loc [] pat_expr_list partial in
- transl_function e.exp_loc !Clflags.native_code repr partial pl)
+ transl_function e.exp_loc !Clflags.native_code repr partial e.exp_type pl)
in
- Lfunction{f_kind; f_params; f_body}
+ let type_kind t = match (Btype.repr t).desc with
+ | Tconstr (path, [], _) when Path.same path Predef.path_float ->
+ Vfloat
+ | Tconstr (path, [], _) when Path.same path Predef.path_nativeint ->
+ Vbint Pnativeint
+ | Tconstr (path, [], _) when Path.same path Predef.path_int32 ->
+ Vbint Pint32
+ | Tconstr (path, [], _) when Path.same path Predef.path_int64 ->
+ Vbint Pint64
+ | Tconstr (path, [], _) when Path.same path Predef.path_int ->
+ Vint
+ | _ ->
+ Vaddr
+ in
+ let f_return = match return_type with
+ | None -> Vaddr
+ | Some return_type -> type_kind return_type
+ in
+ let f_params, params_types = List.split params in
+ let f_params_kind = List.map (function
+ | None -> Vaddr
+ | Some t -> type_kind t) params_types in
+ Lfunction{f_kind; f_return; f_params; f_params_kind; f_body}
| Texp_apply({exp_desc = Texp_ident(path, _, {val_kind = Val_prim p})}, oargs)
when List.length oargs >= p.prim_arity
&& List.for_all (fun (_, arg,_) -> arg <> None) oargs ->
@@ -930,35 +952,47 @@ and transl_apply lam sargs loc =
in
build_apply lam [] (List.map (fun (l, x,o) -> may_map transl_exp x, o) sargs)
-and transl_function loc untuplify_fn repr partial pat_expr_list =
+and transl_function loc untuplify_fn repr partial exp_type pat_expr_list =
+ let return_type = match (Btype.repr exp_type).desc with
+ | Tarrow (_,_,t,_) -> Some t
+ | _ -> None
+ (* XXX Verify that this case can't happen.
+ For instance is it possible to have a variable here ? *)
+ in
match pat_expr_list with
- [pat, ({exp_desc = Texp_function(_, pl,partial')} as exp)]
+ [pat, ({exp_desc = Texp_function(_, pl,partial'); exp_type} as exp)]
when Parmatch.fluid pat ->
let param = name_pattern "param" pat_expr_list in
- let ((_, params), body) =
- transl_function exp.exp_loc false repr partial' pl in
- ((Curried, param :: params),
+ let param_type = pat.pat_type in
+ let ((_, params, return_type'), body) =
+ transl_function exp.exp_loc false repr partial' exp_type pl in
+ ((Curried, (param, Some param_type) :: params ,return_type'),
Matching.for_function loc None (Lvar param) [pat, body] partial)
- | ({pat_desc = Tpat_tuple pl}, _) :: _ when untuplify_fn ->
+ | ({pat_desc = Tpat_tuple pl} as pat, _) :: _ when untuplify_fn ->
begin try
let size = List.length pl in
let pats_expr_list =
List.map
(fun (pat, expr) -> (Matching.flatten_pattern size pat, expr))
pat_expr_list in
- let params = List.map (fun p -> Ident.create "param") pl in
- ((Tupled, params),
- Matching.for_tupled_function loc params
+ let params = List.map (fun p -> Ident.create "param", Some p.pat_type ) pl in
+ ((Tupled, params, return_type),
+ Matching.for_tupled_function loc (List.map fst params)
(transl_tupled_cases pats_expr_list) partial)
with Matching.Cannot_flatten ->
let param = name_pattern "param" pat_expr_list in
- ((Curried, [param]),
+ ((Curried, [param, Some pat.pat_type], return_type),
Matching.for_function loc repr (Lvar param)
(transl_cases pat_expr_list) partial)
end
- | _ ->
+ | (pat,_)::_ ->
+ let param = name_pattern "param" pat_expr_list in
+ ((Curried, [param, Some pat.pat_type], return_type),
+ Matching.for_function loc repr (Lvar param)
+ (transl_cases pat_expr_list) partial)
+ | [] ->
let param = name_pattern "param" pat_expr_list in
- ((Curried, [param]),
+ ((Curried, [param, None], None),
Matching.for_function loc repr (Lvar param)
(transl_cases pat_expr_list) partial)
--
1.7.10.4
From e6d76e6ceefaabc8e25f98dc2bb32f17367574d1 Mon Sep 17 00:00:00 2001
From: Pierre Chambart <pierre.chambart@ocamlpro.org>
Date: Thu, 17 Jan 2013 15:18:31 +0100
Subject: [PATCH 4/5] Propagate type information to clambda
---
.depend | 116 ++++++------
Makefile | 2 +-
asmcomp/clambda.ml | 10 +-
asmcomp/clambda.mli | 10 +-
asmcomp/closure.ml | 54 ++++--
asmcomp/specialisation.ml | 441 ++++++++++++++++++++++++++++++++++++++++++++
asmcomp/specialisation.mli | 8 +
7 files changed, 566 insertions(+), 75 deletions(-)
create mode 100644 asmcomp/specialisation.ml
create mode 100644 asmcomp/specialisation.mli
diff --git a/.depend b/.depend
index 91a18a1..3e7c931 100644
--- a/.depend
+++ b/.depend
@@ -49,8 +49,6 @@ parsing/lexer.cmo : utils/warnings.cmi parsing/parser.cmi utils/misc.cmi \
parsing/location.cmi parsing/lexer.cmi
parsing/lexer.cmx : utils/warnings.cmx parsing/parser.cmx utils/misc.cmx \
parsing/location.cmx parsing/lexer.cmi
-parsing/linenum.cmo : utils/misc.cmi
-parsing/linenum.cmx : utils/misc.cmx
parsing/location.cmo : utils/warnings.cmi utils/terminfo.cmi \
parsing/location.cmi
parsing/location.cmx : utils/warnings.cmx utils/terminfo.cmx \
@@ -86,10 +84,10 @@ typing/ctype.cmi : typing/types.cmi typing/path.cmi parsing/longident.cmi \
typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
typing/datarepr.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi \
parsing/asttypes.cmi
+typing/envaux.cmi : typing/subst.cmi typing/path.cmi typing/env.cmi
typing/env.cmi : utils/warnings.cmi typing/types.cmi typing/subst.cmi \
typing/path.cmi parsing/longident.cmi parsing/location.cmi \
typing/ident.cmi utils/consistbl.cmi
-typing/envaux.cmi : typing/subst.cmi typing/path.cmi typing/env.cmi
typing/ident.cmi :
typing/includeclass.cmi : typing/types.cmi typing/env.cmi typing/ctype.cmi
typing/includecore.cmi : typing/types.cmi typing/typedtree.cmi \
@@ -107,9 +105,9 @@ typing/parmatch.cmi : typing/types.cmi typing/typedtree.cmi \
typing/path.cmi : typing/ident.cmi
typing/predef.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
typing/primitive.cmi :
+typing/printtyped.cmi : typing/typedtree.cmi
typing/printtyp.cmi : typing/types.cmi typing/path.cmi \
typing/outcometree.cmi parsing/longident.cmi typing/ident.cmi
-typing/printtyped.cmi : typing/typedtree.cmi
typing/stypes.cmi : typing/typedtree.cmi parsing/location.cmi \
typing/annot.cmi
typing/subst.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
@@ -123,11 +121,11 @@ typing/typedecl.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
typing/includecore.cmi typing/ident.cmi typing/env.cmi \
parsing/asttypes.cmi
+typing/typedtreeIter.cmi : typing/typedtree.cmi parsing/asttypes.cmi
+typing/typedtreeMap.cmi : typing/typedtree.cmi
typing/typedtree.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \
parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
typing/env.cmi parsing/asttypes.cmi
-typing/typedtreeIter.cmi : typing/typedtree.cmi parsing/asttypes.cmi
-typing/typedtreeMap.cmi : typing/typedtree.cmi
typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi \
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
typing/includemod.cmi typing/ident.cmi typing/env.cmi
@@ -167,6 +165,12 @@ typing/datarepr.cmo : typing/types.cmi typing/predef.cmi typing/path.cmi \
typing/datarepr.cmx : typing/types.cmx typing/predef.cmx typing/path.cmx \
typing/ident.cmx typing/btype.cmx parsing/asttypes.cmi \
typing/datarepr.cmi
+typing/envaux.cmo : typing/types.cmi typing/subst.cmi typing/printtyp.cmi \
+ typing/path.cmi typing/mtype.cmi utils/misc.cmi typing/env.cmi \
+ typing/envaux.cmi
+typing/envaux.cmx : typing/types.cmx typing/subst.cmx typing/printtyp.cmx \
+ typing/path.cmx typing/mtype.cmx utils/misc.cmx typing/env.cmx \
+ typing/envaux.cmi
typing/env.cmo : utils/warnings.cmi typing/types.cmi utils/tbl.cmi \
typing/subst.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \
parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
@@ -179,12 +183,6 @@ typing/env.cmx : utils/warnings.cmx typing/types.cmx utils/tbl.cmx \
typing/datarepr.cmx utils/consistbl.cmx utils/config.cmx \
typing/cmi_format.cmx utils/clflags.cmx typing/btype.cmx \
parsing/asttypes.cmi typing/env.cmi
-typing/envaux.cmo : typing/types.cmi typing/subst.cmi typing/printtyp.cmi \
- typing/path.cmi typing/mtype.cmi utils/misc.cmi typing/env.cmi \
- typing/envaux.cmi
-typing/envaux.cmx : typing/types.cmx typing/subst.cmx typing/printtyp.cmx \
- typing/path.cmx typing/mtype.cmx utils/misc.cmx typing/env.cmx \
- typing/envaux.cmi
typing/ident.cmo : typing/ident.cmi
typing/ident.cmx : typing/ident.cmi
typing/includeclass.cmo : typing/types.cmi typing/printtyp.cmi \
@@ -239,6 +237,12 @@ typing/predef.cmx : typing/types.cmx typing/path.cmx parsing/location.cmx \
typing/ident.cmx typing/btype.cmx parsing/asttypes.cmi typing/predef.cmi
typing/primitive.cmo : utils/misc.cmi typing/primitive.cmi
typing/primitive.cmx : utils/misc.cmx typing/primitive.cmi
+typing/printtyped.cmo : typing/typedtree.cmi typing/path.cmi \
+ parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
+ parsing/asttypes.cmi typing/printtyped.cmi
+typing/printtyped.cmx : typing/typedtree.cmx typing/path.cmx \
+ parsing/longident.cmx parsing/location.cmx typing/ident.cmx \
+ parsing/asttypes.cmi typing/printtyped.cmi
typing/printtyp.cmo : typing/types.cmi typing/primitive.cmi \
typing/predef.cmi typing/path.cmi typing/outcometree.cmi \
typing/oprint.cmi utils/misc.cmi parsing/longident.cmi typing/ident.cmi \
@@ -249,12 +253,6 @@ typing/printtyp.cmx : typing/types.cmx typing/primitive.cmx \
typing/oprint.cmx utils/misc.cmx parsing/longident.cmx typing/ident.cmx \
typing/env.cmx typing/ctype.cmx utils/clflags.cmx typing/btype.cmx \
parsing/asttypes.cmi typing/printtyp.cmi
-typing/printtyped.cmo : typing/typedtree.cmi typing/path.cmi \
- parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
- parsing/asttypes.cmi typing/printtyped.cmi
-typing/printtyped.cmx : typing/typedtree.cmx typing/path.cmx \
- parsing/longident.cmx parsing/location.cmx typing/ident.cmx \
- parsing/asttypes.cmi typing/printtyped.cmi
typing/stypes.cmo : typing/typedtree.cmi typing/printtyp.cmi \
parsing/location.cmi utils/clflags.cmi typing/annot.cmi typing/stypes.cmi
typing/stypes.cmx : typing/typedtree.cmx typing/printtyp.cmx \
@@ -313,12 +311,6 @@ typing/typedecl.cmx : utils/warnings.cmx typing/typetexp.cmx \
typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \
utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
typing/typedecl.cmi
-typing/typedtree.cmo : typing/types.cmi typing/primitive.cmi typing/path.cmi \
- utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
- typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/typedtree.cmi
-typing/typedtree.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \
- utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
- typing/ident.cmx typing/env.cmx parsing/asttypes.cmi typing/typedtree.cmi
typing/typedtreeIter.cmo : typing/typedtree.cmi parsing/asttypes.cmi \
typing/typedtreeIter.cmi
typing/typedtreeIter.cmx : typing/typedtree.cmx parsing/asttypes.cmi \
@@ -327,6 +319,12 @@ typing/typedtreeMap.cmo : typing/typedtree.cmi utils/misc.cmi \
parsing/asttypes.cmi typing/typedtreeMap.cmi
typing/typedtreeMap.cmx : typing/typedtree.cmx utils/misc.cmx \
parsing/asttypes.cmi typing/typedtreeMap.cmi
+typing/typedtree.cmo : typing/types.cmi typing/primitive.cmi typing/path.cmi \
+ utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
+ typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/typedtree.cmi
+typing/typedtree.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \
+ utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
+ typing/ident.cmx typing/env.cmx parsing/asttypes.cmi typing/typedtree.cmi
typing/typemod.cmo : utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \
typing/typedtree.cmi typing/typedecl.cmi typing/typecore.cmi \
typing/typeclass.cmi typing/subst.cmi typing/stypes.cmi \
@@ -563,9 +561,9 @@ asmcomp/asmpackager.cmi :
asmcomp/clambda.cmi : bytecomp/lambda.cmi typing/ident.cmi \
asmcomp/debuginfo.cmi parsing/asttypes.cmi
asmcomp/closure.cmi : bytecomp/lambda.cmi asmcomp/clambda.cmi
-asmcomp/cmm.cmi : typing/ident.cmi asmcomp/debuginfo.cmi
asmcomp/cmmgen.cmi : asmcomp/cmx_format.cmi asmcomp/cmm.cmi \
asmcomp/clambda.cmi
+asmcomp/cmm.cmi : typing/ident.cmi asmcomp/debuginfo.cmi
asmcomp/cmx_format.cmi : asmcomp/clambda.cmi
asmcomp/codegen.cmi : asmcomp/cmm.cmi
asmcomp/coloring.cmi :
@@ -573,8 +571,8 @@ asmcomp/comballoc.cmi : asmcomp/mach.cmi
asmcomp/compilenv.cmi : bytecomp/lambda.cmi typing/ident.cmi \
asmcomp/cmx_format.cmi asmcomp/clambda.cmi
asmcomp/debuginfo.cmi : parsing/location.cmi bytecomp/lambda.cmi
-asmcomp/emit.cmi : asmcomp/linearize.cmi asmcomp/cmm.cmi
asmcomp/emitaux.cmi : asmcomp/debuginfo.cmi
+asmcomp/emit.cmi : asmcomp/linearize.cmi asmcomp/cmm.cmi
asmcomp/interf.cmi : asmcomp/mach.cmi
asmcomp/linearize.cmi : asmcomp/reg.cmi asmcomp/mach.cmi \
asmcomp/debuginfo.cmi
@@ -587,8 +585,8 @@ asmcomp/printlinear.cmi : asmcomp/linearize.cmi
asmcomp/printmach.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
asmcomp/proc.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
asmcomp/reg.cmi : asmcomp/cmm.cmi
-asmcomp/reload.cmi : asmcomp/mach.cmi
asmcomp/reloadgen.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
+asmcomp/reload.cmi : asmcomp/mach.cmi
asmcomp/schedgen.cmi : asmcomp/mach.cmi asmcomp/linearize.cmi
asmcomp/scheduling.cmi : asmcomp/linearize.cmi
asmcomp/selectgen.cmi : utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
@@ -650,30 +648,32 @@ asmcomp/clambda.cmo : bytecomp/lambda.cmi typing/ident.cmi \
asmcomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/clambda.cmi
asmcomp/clambda.cmx : bytecomp/lambda.cmx typing/ident.cmx \
asmcomp/debuginfo.cmx parsing/asttypes.cmi asmcomp/clambda.cmi
-asmcomp/closure.cmo : utils/tbl.cmi bytecomp/switch.cmi typing/primitive.cmi \
- utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi asmcomp/debuginfo.cmi \
+asmcomp/closure.cmo : utils/tbl.cmi bytecomp/switch.cmi \
+ asmcomp/specialisation.cmo typing/primitive.cmi utils/misc.cmi \
+ bytecomp/lambda.cmi typing/ident.cmi asmcomp/debuginfo.cmi \
asmcomp/compilenv.cmi utils/clflags.cmi asmcomp/clambda.cmi \
parsing/asttypes.cmi asmcomp/arch.cmo asmcomp/closure.cmi
-asmcomp/closure.cmx : utils/tbl.cmx bytecomp/switch.cmx typing/primitive.cmx \
- utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx asmcomp/debuginfo.cmx \
+asmcomp/closure.cmx : utils/tbl.cmx bytecomp/switch.cmx \
+ asmcomp/specialisation.cmx typing/primitive.cmx utils/misc.cmx \
+ bytecomp/lambda.cmx typing/ident.cmx asmcomp/debuginfo.cmx \
asmcomp/compilenv.cmx utils/clflags.cmx asmcomp/clambda.cmx \
parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/closure.cmi
+asmcomp/cmmgen.cmo : bytecomp/switch.cmi asmcomp/specialisation.cmo \
+ asmcomp/proc.cmi typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi \
+ typing/ident.cmi asmcomp/debuginfo.cmi utils/config.cmi \
+ asmcomp/compilenv.cmi asmcomp/cmx_format.cmi asmcomp/cmm.cmi \
+ utils/clflags.cmi asmcomp/clambda.cmi parsing/asttypes.cmi \
+ asmcomp/arch.cmo asmcomp/cmmgen.cmi
+asmcomp/cmmgen.cmx : bytecomp/switch.cmx asmcomp/specialisation.cmx \
+ asmcomp/proc.cmx typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx \
+ typing/ident.cmx asmcomp/debuginfo.cmx utils/config.cmx \
+ asmcomp/compilenv.cmx asmcomp/cmx_format.cmi asmcomp/cmm.cmx \
+ utils/clflags.cmx asmcomp/clambda.cmx parsing/asttypes.cmi \
+ asmcomp/arch.cmx asmcomp/cmmgen.cmi
asmcomp/cmm.cmo : typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/arch.cmo \
asmcomp/cmm.cmi
asmcomp/cmm.cmx : typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/arch.cmx \
asmcomp/cmm.cmi
-asmcomp/cmmgen.cmo : bytecomp/switch.cmi asmcomp/proc.cmi \
- typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi \
- asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
- asmcomp/cmx_format.cmi asmcomp/cmm.cmi utils/clflags.cmi \
- asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/arch.cmo \
- asmcomp/cmmgen.cmi
-asmcomp/cmmgen.cmx : bytecomp/switch.cmx asmcomp/proc.cmx \
- typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx \
- asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
- asmcomp/cmx_format.cmi asmcomp/cmm.cmx utils/clflags.cmx \
- asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \
- asmcomp/cmmgen.cmi
asmcomp/codegen.cmo : asmcomp/split.cmi asmcomp/spill.cmi asmcomp/reload.cmi \
asmcomp/reg.cmi asmcomp/printmach.cmi asmcomp/printlinear.cmi \
asmcomp/printcmm.cmi asmcomp/liveness.cmi asmcomp/linearize.cmi \
@@ -700,6 +700,10 @@ asmcomp/debuginfo.cmo : parsing/location.cmi bytecomp/lambda.cmi \
asmcomp/debuginfo.cmi
asmcomp/debuginfo.cmx : parsing/location.cmx bytecomp/lambda.cmx \
asmcomp/debuginfo.cmi
+asmcomp/emitaux.cmo : asmcomp/linearize.cmi asmcomp/debuginfo.cmi \
+ utils/config.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emitaux.cmi
+asmcomp/emitaux.cmx : asmcomp/linearize.cmx asmcomp/debuginfo.cmx \
+ utils/config.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emitaux.cmi
asmcomp/emit.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
asmcomp/mach.cmi asmcomp/linearize.cmi asmcomp/emitaux.cmi \
asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
@@ -708,10 +712,6 @@ asmcomp/emit.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
asmcomp/mach.cmx asmcomp/linearize.cmx asmcomp/emitaux.cmx \
asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emit.cmi
-asmcomp/emitaux.cmo : asmcomp/linearize.cmi asmcomp/debuginfo.cmi \
- utils/config.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emitaux.cmi
-asmcomp/emitaux.cmx : asmcomp/linearize.cmx asmcomp/debuginfo.cmx \
- utils/config.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emitaux.cmi
asmcomp/interf.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \
asmcomp/interf.cmi
asmcomp/interf.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \
@@ -722,6 +722,10 @@ asmcomp/linearize.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
asmcomp/linearize.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \
asmcomp/linearize.cmi
+asmcomp/live_functions.cmo : bytecomp/lambda.cmi typing/ident.cmi \
+ asmcomp/clambda.cmi
+asmcomp/live_functions.cmx : bytecomp/lambda.cmx typing/ident.cmx \
+ asmcomp/clambda.cmx
asmcomp/liveness.cmo : asmcomp/reg.cmi asmcomp/proc.cmi \
asmcomp/printmach.cmi utils/misc.cmi asmcomp/mach.cmi \
asmcomp/liveness.cmi
@@ -760,14 +764,14 @@ asmcomp/proc.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
asmcomp/arch.cmx asmcomp/proc.cmi
asmcomp/reg.cmo : asmcomp/cmm.cmi asmcomp/reg.cmi
asmcomp/reg.cmx : asmcomp/cmm.cmx asmcomp/reg.cmi
-asmcomp/reload.cmo : asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
- asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/reload.cmi
-asmcomp/reload.cmx : asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \
- asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/reload.cmi
asmcomp/reloadgen.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
asmcomp/reloadgen.cmi
asmcomp/reloadgen.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
asmcomp/reloadgen.cmi
+asmcomp/reload.cmo : asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
+ asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/reload.cmi
+asmcomp/reload.cmx : asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \
+ asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/reload.cmi
asmcomp/schedgen.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \
asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
asmcomp/schedgen.cmi
@@ -790,6 +794,10 @@ asmcomp/selection.cmo : asmcomp/selectgen.cmi asmcomp/proc.cmi \
asmcomp/selection.cmx : asmcomp/selectgen.cmx asmcomp/proc.cmx \
utils/misc.cmx asmcomp/mach.cmx asmcomp/cmm.cmx utils/clflags.cmx \
asmcomp/arch.cmx asmcomp/selection.cmi
+asmcomp/specialisation.cmo : typing/primitive.cmi bytecomp/lambda.cmi \
+ typing/ident.cmi asmcomp/clambda.cmi asmcomp/arch.cmo
+asmcomp/specialisation.cmx : typing/primitive.cmx bytecomp/lambda.cmx \
+ typing/ident.cmx asmcomp/clambda.cmx asmcomp/arch.cmx
asmcomp/spill.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
asmcomp/mach.cmi asmcomp/spill.cmi
asmcomp/spill.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
@@ -800,8 +808,8 @@ asmcomp/split.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
asmcomp/split.cmi
driver/compile.cmi : typing/env.cmi
driver/errors.cmi :
-driver/main.cmi :
driver/main_args.cmi :
+driver/main.cmi :
driver/optcompile.cmi : typing/env.cmi
driver/opterrors.cmi :
driver/optmain.cmi :
@@ -840,6 +848,8 @@ driver/errors.cmx : utils/warnings.cmx typing/typetexp.cmx \
typing/includemod.cmx typing/env.cmx typing/ctype.cmx \
typing/cmi_format.cmx bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \
bytecomp/bytelibrarian.cmx driver/errors.cmi
+driver/main_args.cmo : utils/warnings.cmi driver/main_args.cmi
+driver/main_args.cmx : utils/warnings.cmx driver/main_args.cmi
driver/main.cmo : utils/warnings.cmi utils/misc.cmi driver/main_args.cmi \
parsing/location.cmi driver/errors.cmi utils/config.cmi \
driver/compile.cmi utils/clflags.cmi bytecomp/bytepackager.cmi \
@@ -848,8 +858,6 @@ driver/main.cmx : utils/warnings.cmx utils/misc.cmx driver/main_args.cmx \
parsing/location.cmx driver/errors.cmx utils/config.cmx \
driver/compile.cmx utils/clflags.cmx bytecomp/bytepackager.cmx \
bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmx driver/main.cmi
-driver/main_args.cmo : utils/warnings.cmi driver/main_args.cmi
-driver/main_args.cmx : utils/warnings.cmx driver/main_args.cmi
driver/optcompile.cmo : utils/warnings.cmi typing/typemod.cmi \
typing/typedtree.cmi typing/typecore.cmi bytecomp/translmod.cmi \
typing/stypes.cmi bytecomp/simplif.cmi typing/printtyped.cmi \
diff --git a/Makefile b/Makefile
index 726faa0..1a0f422 100644
--- a/Makefile
+++ b/Makefile
@@ -78,7 +78,7 @@ ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \
asmcomp/cmm.cmo asmcomp/printcmm.cmo \
asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \
asmcomp/clambda.cmo asmcomp/printclambda.cmo asmcomp/compilenv.cmo \
- asmcomp/closure.cmo asmcomp/cmmgen.cmo \
+ asmcomp/specialisation.cmo asmcomp/closure.cmo asmcomp/cmmgen.cmo \
asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \
asmcomp/comballoc.cmo asmcomp/liveness.cmo \
asmcomp/spill.cmo asmcomp/split.cmo \
diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml
index 42ff697..b35adf6 100644
--- a/asmcomp/clambda.ml
+++ b/asmcomp/clambda.ml
@@ -18,6 +18,8 @@ open Lambda
type function_label = string
+type param = Ident.t * value_kind
+
type ulambda =
Uvar of Ident.t
| Uconst of structured_constant * string option
@@ -42,7 +44,8 @@ type ulambda =
and ufunction = {
label : function_label;
arity : int;
- params : Ident.t list;
+ mutable params : param list;
+ mutable return : value_kind;
body : ulambda;
dbg : Debuginfo.t
}
@@ -58,8 +61,11 @@ and ulambda_switch =
and function_description =
{ fun_label: function_label; (* Label of direct entry point *)
fun_arity: int; (* Number of arguments *)
+ mutable fun_params: param list; (* How the parameters are passed *)
+ mutable fun_return: value_kind; (* How return value is passed *)
+ mutable fun_specialisation_done : bool;
mutable fun_closed: bool; (* True if environment not used *)
- mutable fun_inline: (Ident.t list * ulambda) option }
+ mutable fun_inline: (param list * ulambda) option }
(* Approximation of values *)
diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli
index 24d1bcc..dd0b295 100644
--- a/asmcomp/clambda.mli
+++ b/asmcomp/clambda.mli
@@ -18,6 +18,8 @@ open Lambda
type function_label = string
+type param = Ident.t * value_kind
+
type ulambda =
Uvar of Ident.t
| Uconst of structured_constant * string option
@@ -42,7 +44,8 @@ type ulambda =
and ufunction = {
label : function_label;
arity : int;
- params : Ident.t list;
+ mutable params : param list;
+ mutable return : value_kind;
body : ulambda;
dbg : Debuginfo.t;
}
@@ -58,8 +61,11 @@ and ulambda_switch =
and function_description =
{ fun_label: function_label; (* Label of direct entry point *)
fun_arity: int; (* Number of arguments *)
+ mutable fun_params: param list; (* How the parameters are passed *)
+ mutable fun_return: value_kind; (* How return value is passed *)
+ mutable fun_specialisation_done : bool;
mutable fun_closed: bool; (* True if environment not used *)
- mutable fun_inline: (Ident.t list * ulambda) option }
+ mutable fun_inline: (param list * ulambda) option }
(* Approximation of values *)
diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml
index 5af2d6f..c145415 100644
--- a/asmcomp/closure.ml
+++ b/asmcomp/closure.ml
@@ -493,6 +493,8 @@ let close_approx_var fenv cenv id =
let close_var fenv cenv id =
let (ulam, app) = close_approx_var fenv cenv id in ulam
+let module_functions = ref []
+
let rec close fenv cenv = function
Lvar id ->
close_approx_var fenv cenv id
@@ -721,32 +723,45 @@ and close_functions fenv cenv fun_defs =
IdentSet.elements (free_variables (Lletrec(fun_defs, lambda_unit))) in
(* Build the function descriptors for the functions.
Initially all functions are assumed not to need their environment
- parameter. *)
+ parameter.
+ Functions taking parameters of type float are first assumed to be
+ possible to do direct call them specialising this parameter: not boxing.
+ later when all constraints are known, the parameters that can't be passed
+ unboxed are removed *)
let uncurried_defs =
List.map
(function
- (id, Lfunction{ f_kind; f_params; f_body }) ->
+ (id, Lfunction{ f_kind; f_params; f_params_kind; f_body; f_return }) ->
let label = Compilenv.make_symbol (Some (Ident.unique_name id)) in
let arity = List.length f_params in
+ let rec map_kind id kind = match id,kind with
+ | [], [] -> []
+ | [], _ -> assert false (* possible ? *)
+ | id::q, [] -> (id,Vaddr) :: (map_kind q [])
+ | id::q1, kind::q2 -> (id,kind) :: (map_kind q1 q2)
+ in
let fundesc =
{fun_label = label;
fun_arity = (if f_kind = Tupled then -arity else arity);
+ fun_params = map_kind f_params f_params_kind;
+ fun_return = f_return;
+ fun_specialisation_done = false;
fun_closed = initially_closed;
fun_inline = None } in
- (id, f_params, f_body, fundesc)
+ (id, f_body, fundesc)
| (_, _) -> fatal_error "Closure.close_functions")
fun_defs in
(* Build an approximate fenv for compiling the functions *)
let fenv_rec =
List.fold_right
- (fun (id, params, body, fundesc) fenv ->
+ (fun (id, body, fundesc) fenv ->
Tbl.add id (Value_closure(fundesc, Value_unknown)) fenv)
uncurried_defs fenv in
(* Determine the offsets of each function's closure in the shared block *)
let env_pos = ref (-1) in
let clos_offsets =
List.map
- (fun (id, params, body, fundesc) ->
+ (fun (id, body, fundesc) ->
let pos = !env_pos + 1 in
env_pos := !env_pos + 1 + (if fundesc.fun_arity <> 1 then 3 else 2);
pos)
@@ -756,7 +771,7 @@ and close_functions fenv cenv fun_defs =
does not use its environment parameter is invalidated. *)
let useless_env = ref initially_closed in
(* Translate each function definition *)
- let clos_fundef (id, params, body, fundesc) env_pos =
+ let clos_fundef (id, body, fundesc) env_pos =
let dbg = match body with
| Levent (_,({lev_kind=Lev_function} as ev)) -> Debuginfo.from_call ev
| _ -> Debuginfo.none in
@@ -765,18 +780,23 @@ and close_functions fenv cenv fun_defs =
build_closure_env env_param (fv_pos - env_pos) fv in
let cenv_body =
List.fold_right2
- (fun (id, params, arity, body) pos env ->
+ (fun (id, arity, body) pos env ->
Tbl.add id (Uoffset(Uvar env_param, pos - env_pos)) env)
uncurried_defs clos_offsets cenv_fv in
let (ubody, approx) = close fenv_rec cenv_body body in
if !useless_env && occurs_var env_param ubody then useless_env := false;
- let fun_params = if !useless_env then params else params @ [env_param] in
- ({ label = fundesc.fun_label;
- arity = fundesc.fun_arity;
- params = fun_params;
- body = ubody;
- dbg },
- (id, env_pos, Value_closure(fundesc, approx))) in
+ let fun_params = if !useless_env
+ then fundesc.fun_params
+ else fundesc.fun_params @ [env_param, Vaddr] in
+ let clos =
+ { label = fundesc.fun_label;
+ arity = fundesc.fun_arity;
+ params = fun_params;
+ return = fundesc.fun_return;
+ body = ubody;
+ dbg } in
+ module_functions := (clos,fundesc) :: !module_functions;
+ (clos, (id, env_pos, Value_closure (fundesc, approx))) in
(* Translate all function definitions. *)
let clos_info_list =
if initially_closed then begin
@@ -786,7 +806,7 @@ and close_functions fenv cenv fun_defs =
recompile *)
if !useless_env then cl else begin
List.iter
- (fun (id, params, body, fundesc) -> fundesc.fun_closed <- false)
+ (fun (id, body, fundesc) -> fundesc.fun_closed <- false)
uncurried_defs;
List.map2 clos_fundef uncurried_defs clos_offsets
end
@@ -796,6 +816,7 @@ and close_functions fenv cenv fun_defs =
in
(* Update nesting depth *)
decr function_nesting_depth;
+
(* Return the Uclosure node and the list of all identifiers defined,
with offsets and approximations. *)
let (clos, infos) = List.split clos_info_list in
@@ -842,7 +863,6 @@ and close_switch fenv cenv cases num_keys default =
| [| |] -> [| |], [| |] (* May happen when default is None *)
| _ -> index, actions
-
(* The entry point *)
let intro size lam =
@@ -850,5 +870,7 @@ let intro size lam =
global_approx := Array.create size Value_unknown;
Compilenv.set_global_approx(Value_tuple !global_approx);
let (ulam, approx) = close Tbl.empty Tbl.empty lam in
+ Specialisation.function_constraints !module_functions;
+ module_functions := [];
global_approx := [||];
ulam
diff --git a/asmcomp/specialisation.ml b/asmcomp/specialisation.ml
new file mode 100644
index 0000000..05e7cc7
--- /dev/null
+++ b/asmcomp/specialisation.ml
@@ -0,0 +1,441 @@
+open Lambda
+open Clambda
+
+(* Function call specialisation:
+ This section is done to estimate wether a value (float) will be
+ used boxed or not and decide if it should be passed as boxed
+ parameter to a function or not.
+ This is also done for return values.
+
+ This is very conservative: it should never be worse that without
+ this optimisation. i.e. avoid taking parameter unboxed if it is
+ possible to need them boxed inside the body of the function *)
+
+module IdentMap =
+ Map.Make(struct
+ type t = Ident.t
+ let compare = compare
+ end)
+
+(* Identify a parameter position: i.e. a function and its position *)
+type param_pos = (function_label * int)
+
+(* Describes variable usage: wethere they are forced to be used boxed *)
+type param_constraint =
+ | Used_boxed
+ (* The variable is known to be needed in boxed version: put inside
+ a structure, passed to a polymorphic function, ... *)
+ | Used_as_param of param_pos list
+ (* No strong constraint, but known to be passed as parameter
+ to the given functions *)
+
+let variables_boxing_constraints u =
+ let tbl = ref IdentMap.empty in
+ let set_var v = function
+ | Uvar id ->
+ tbl := IdentMap.add id v !tbl
+ | _ -> () in
+ let add_var arg = set_var Used_boxed arg in
+ let add_param_var desc i = function
+ | Uvar id ->
+ let prev =
+ try IdentMap.find id !tbl with
+ | Not_found -> Used_as_param []
+ in
+ begin match prev with
+ | Used_boxed -> ()
+ | Used_as_param l ->
+ tbl := IdentMap.add id (Used_as_param ((desc,i)::l)) !tbl
+ end
+ | _ -> ()
+ in
+ let rec aux = function
+ | Ugeneric_apply (fn, params, _) ->
+ aux fn;
+ List.iter aux params;
+ List.iter add_var params
+ | Udirect_apply (desc, params, _) ->
+ List.iter aux params;
+ let fun_params =
+ let l = List.map snd desc.fun_params in
+ let rec map_kind param kind = match param,kind with
+ | [], [] -> []
+ | [], _ -> assert false (* possible ? *)
+ | t::q, [] -> Vaddr :: (map_kind q [])
+ | t::q1, kind::q2 -> kind :: (map_kind q1 q2)
+ in
+ map_kind params l in
+ let args = List.combine params fun_params in
+ let mark_params i (arg, kind) =
+ match kind with
+ | Vaddr -> add_var arg
+ | Vfloat
+ | Vbint _
+ | Vint ->
+ if desc.fun_specialisation_done
+ then ()
+ else add_param_var desc.fun_label i arg in
+ List.iteri mark_params args
+ | Usend (_, p1, p2, params, _) ->
+ aux p1;
+ aux p2;
+ List.iter aux params;
+ List.iter add_var params
+ | Ulet (id, lam1, lam2) ->
+ aux lam1;
+ aux lam2;
+ begin try
+ let v = IdentMap.find id !tbl in
+ set_var v lam1
+ with Not_found -> () end
+ | Uletrec (id_lst, lam) ->
+ aux lam;
+ List.iter (fun (id, lam1) ->
+ try
+ let v = IdentMap.find id !tbl in
+ set_var v lam1
+ with Not_found -> ()) id_lst
+ | Uvar _
+ | Uconst _ -> ()
+ | Uclosure (_, lst) ->
+ List.iter aux lst;
+ | Uswitch (lam, uswitch) ->
+ aux lam;
+ Array.iter aux uswitch.us_actions_consts;
+ Array.iter aux uswitch.us_actions_blocks
+ | Ustaticfail (_, lst) ->
+ List.iter aux lst
+ | Ucatch (nfail, ids, body, handler) ->
+ aux body;
+ aux handler;
+ | Uoffset (lam, _)
+ | Uassign (_, lam) ->
+ aux lam
+ | Utrywith (lam1, _, lam2)
+ | Usequence (lam1, lam2)
+ | Uwhile (lam1, lam2) ->
+ aux lam1; aux lam2
+ | Uifthenelse (lam1, lam2, lam3)
+ | Ufor (_, lam1, lam2, _, lam3) ->
+ aux lam1; aux lam2; aux lam3
+ | Uprim (prim, params, _) ->
+ begin
+ match prim with
+ | Psetglobal _
+ | Psetfield _ -> List.iter add_var params
+ | Pmakeblock _ -> List.iter add_var params
+ | Pccall desc ->
+ if not desc.Primitive.prim_native_float
+ then List.iter add_var params
+ | _ -> ()
+ end;
+ List.iter aux params
+ in
+ aux u;
+ !tbl
+
+(* Describes wether return value are built boxed *)
+type return_constraint =
+ | Returned_unboxed (* the value is build as a boxed value.
+ ex: extracted from a tuple, returned from a polymorphic function, etc *)
+ | Returned_boxed (* the value is build as an unboxed value.
+ ex: result of arithmetic expression, etc *)
+ | Returned_from of function_label list
+ (* No strong constraint is known but the value can be returned by
+ the listed functions *)
+
+let merge_return_info v1 v2 = match v1,v2 with
+ | Returned_boxed, _
+ | _, Returned_boxed -> Returned_boxed
+ | Returned_unboxed, t
+ | t, Returned_unboxed -> t
+ | Returned_from l1, Returned_from l2 -> Returned_from (l1@l2)
+
+let return_boxing_constraints fun_params u =
+ let tbl = ref IdentMap.empty in
+ let rec aux = function
+ | Ugeneric_apply (_, _, _) ->
+ Returned_boxed
+ | Udirect_apply (desc, _, _) ->
+ begin match desc.fun_return with
+ | Vaddr -> Returned_boxed
+ | Vfloat | Vbint _ | Vint -> Returned_from [desc.fun_label] end
+ | Usend (_, p1, p2, params, _) ->
+ Returned_boxed
+ | Ulet (id, lam1, lam2) ->
+ let r = aux lam1 in
+ tbl := IdentMap.add id r !tbl;
+ aux lam2
+ | Uletrec (id_lst, lam) ->
+ aux lam
+ | Uvar id ->
+ begin try IdentMap.find id !tbl
+ with Not_found ->
+ try match IdentMap.find id fun_params with
+ | Vaddr -> Returned_boxed
+ | Vint | Vfloat | Vbint _ -> Returned_unboxed
+ with Not_found -> Returned_boxed end
+ | Uconst _ -> Returned_boxed
+ | Uclosure (_, lst) -> Returned_boxed
+ | Uswitch (lam, uswitch) ->
+ let a1 = Array.map aux uswitch.us_actions_consts in
+ let a2 = Array.map aux uswitch.us_actions_blocks in
+ let r = Array.fold_left merge_return_info Returned_unboxed a1 in
+ Array.fold_left merge_return_info r a2
+ | Ustaticfail (_, _) ->
+ Returned_boxed
+ | Ucatch (_, _, body, handler) ->
+ merge_return_info (aux body) (aux handler)
+ | Uoffset (lam, _)
+ | Uassign (_, lam) ->
+ Returned_boxed
+ | Utrywith (lam1, _, lam2) ->
+ merge_return_info (aux lam1) (aux lam2)
+ | Usequence (lam1, lam2) ->
+ aux lam2
+ | Uwhile (lam1, lam2) ->
+ Returned_boxed
+ | Uifthenelse (lam1, lam2, lam3) ->
+ merge_return_info (aux lam2) (aux lam3)
+ | Ufor (_, lam1, lam2, _, lam3) ->
+ Returned_boxed
+ | Uprim (prim, params, _) ->
+ begin
+ match prim with
+ | Pidentity ->
+ (* allow forcing *)
+ Returned_unboxed
+ | Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _ | Paddbint _
+ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _
+ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _
+ | Pbintcomp _
+ | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint
+ | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint
+ | Pfloatofint | Pnegfloat | Pabsfloat | Paddfloat | Psubfloat
+ | Pmulfloat | Pdivfloat ->
+ Returned_unboxed
+ | Pfloatfield _
+ | Pstring_load_16 _ | Pstring_load_32 _ | Pstring_load_64 _
+ | Pbigstring_load_16 _ | Pbigstring_load_32 _
+ | Pbigstring_load_64 _ ->
+ Returned_unboxed
+ | Pbigarrayref(_,_,kind,_) ->
+ begin match kind with
+ | Pbigarray_unknown | Pbigarray_complex32 | Pbigarray_complex64 ->
+ Returned_boxed
+ | Pbigarray_float32 | Pbigarray_float64
+ | Pbigarray_sint8 | Pbigarray_uint8
+ | Pbigarray_sint16 | Pbigarray_uint16
+ | Pbigarray_int32 | Pbigarray_int64
+ | Pbigarray_caml_int | Pbigarray_native_int ->
+ Returned_unboxed
+ end
+ | Pccall desc ->
+ if desc.Primitive.prim_native_float
+ then Returned_unboxed
+ else Returned_boxed
+ | _ -> Returned_boxed
+ end
+ in
+ aux u
+
+type param_usage =
+ | Known of value_kind
+ | Depend of param_pos list
+
+type allow_spec =
+ | No_const
+ | Some_const
+
+type function_unbox_usage = param_usage array
+
+let param_usage_table : (function_label, function_unbox_usage) Hashtbl.t =
+ Hashtbl.create 0
+let param_type_table : (param_pos, allow_spec option) Hashtbl.t = Hashtbl.create 0
+let return_usage_table : (function_label, return_constraint) Hashtbl.t =
+ Hashtbl.create 0
+let return_type_table : (function_label, allow_spec option) Hashtbl.t = Hashtbl.create 0
+
+let clear_tables () =
+ Hashtbl.clear param_usage_table;
+ Hashtbl.clear param_type_table;
+ Hashtbl.clear return_usage_table;
+ Hashtbl.clear return_type_table
+
+let find_boxed_usage (fun_label,i) =
+ try
+ let usage = Hashtbl.find param_usage_table fun_label in
+ usage.(i)
+ with
+ | Not_found ->
+ Printf.eprintf "unregistered: %s %i\n%!" fun_label i;
+ assert false (* must be registered before searching ! *)
+
+let find_return_usage fun_label =
+ try
+ Hashtbl.find return_usage_table fun_label
+ with
+ | Not_found ->
+ Printf.eprintf "%s\n%!" fun_label;
+ assert false (* must be registered before searching ! *)
+
+let spec_kind = function
+ | Vaddr -> false
+ | Vfloat -> true
+ | Vint -> false
+ (* could be activated if some optimisations were added to Cmmgen *)
+ | Vbint bi ->
+ match bi with
+ | Pnativeint
+ | Pint32 -> true
+ | Pint64 ->
+ (* it is not possible to specialise for int64 on 32 bit arch *)
+ (Arch.size_int = 8)
+
+(* Find wether there are some boxing constraints on a function
+ parameter. The constraints can come from strong ones inside the
+ body of the function or a weak ones when the variable is used as
+ parameter for another mutually recursive function. *)
+let rec find_param_type (param:param_pos) =
+ try Hashtbl.find param_type_table param with
+ | Not_found ->
+ match find_boxed_usage param with
+ | Known Vaddr ->
+ Some Some_const
+ | Known (Vint | Vfloat | Vbint _) ->
+ Some No_const
+ | Depend l ->
+ Hashtbl.add param_type_table param None;
+ let rec iter ret = function
+ | [] -> ret
+ | t::q ->
+ match find_param_type t with
+ | None -> iter None q
+ | Some No_const -> iter ret q
+ | Some Some_const -> Some Some_const
+ in
+ match iter (Some No_const) l with
+ | Some _ as v ->
+ Hashtbl.replace param_type_table param v;
+ v
+ | None -> None
+
+let rec find_return_type func =
+ try Hashtbl.find return_type_table func with
+ | Not_found ->
+ match find_return_usage func with
+ | Returned_boxed ->
+ Some Some_const
+ | Returned_unboxed ->
+ Some No_const
+ | Returned_from l ->
+ Hashtbl.add return_type_table func None;
+ let rec iter ret = function
+ | [] -> ret
+ | t::q ->
+ match find_return_type t with
+ | None -> iter None q
+ | Some No_const -> iter ret q
+ | Some Some_const -> Some Some_const
+ in
+ match iter (Some No_const) l with
+ | Some _ as v ->
+ Hashtbl.replace return_type_table func v;
+ v
+ | None -> None
+
+(* Register boxing constraints of parameters of a function. When
+ calling find_param_type, all functions called must have been
+ registered with add_fun_param_constraints *)
+let add_fun_param_constraints (clos,fundesc) =
+ let tbl = variables_boxing_constraints clos.body in
+ let f = function
+ | (_,Vaddr) -> Known Vaddr
+ | (id, (Vfloat|Vint|Vbint _ as kind)) ->
+ if spec_kind kind
+ then
+ try
+ match IdentMap.find id tbl with
+ | Used_boxed -> Known Vaddr
+ | Used_as_param l -> Depend l
+ with
+ | Not_found -> Known kind
+ else Known Vaddr
+ in
+ let params = List.map f fundesc.fun_params in
+ Hashtbl.add param_usage_table fundesc.fun_label (Array.of_list params)
+
+(* Register boxing constraints of the return value of a function. When
+ calling find_return_type, all functions called must have been
+ registered with add_fun_return_constraints. *)
+let add_fun_return_constraints (clos,fundesc) =
+ let ret =
+ if spec_kind fundesc.fun_return
+ then
+ let param_tbl = List.fold_left
+ (fun map (id,kind) -> IdentMap.add id kind map)
+ IdentMap.empty clos.params in
+ return_boxing_constraints param_tbl clos.body
+ else Returned_boxed
+ in
+ Hashtbl.add return_usage_table fundesc.fun_label ret
+
+let specialised fundecl =
+ match fundecl.return with
+ | Vint | Vfloat | Vbint _ -> true
+ | Vaddr ->
+ List.exists (function (_, Vint)
+ | (_, Vbint _)
+ | (_, Vfloat) -> true
+ | (_, Vaddr) -> false)
+ fundecl.params
+
+let specialised' fundesc =
+ match fundesc.fun_return with
+ | Vint | Vfloat | Vbint _ -> true
+ | Vaddr ->
+ List.exists (function (_, Vint)
+ | (_, Vbint _)
+ | (_, Vfloat) -> true
+ | (_, Vaddr) -> false)
+ fundesc.fun_params
+
+let param_boxing (clos,fundesc) =
+ let rec last = function
+ | [] -> assert false
+ | [v] -> v
+ | t::q -> last q
+ in
+ let params =
+ List.mapi (fun i (id,t) ->
+ let new_t =
+ match find_param_type (fundesc.fun_label,i) with
+ | Some Some_const -> Vaddr
+ | Some No_const
+ | None -> t in
+ id, new_t)
+ fundesc.fun_params in
+ let clos_params =
+ if fundesc.fun_closed
+ then params
+ else params @ [last clos.params] (* environment *) in
+ fundesc.fun_params <- params;
+ clos.params <- clos_params
+
+let return_boxing (clos,fundesc) =
+ let return =
+ match find_return_type fundesc.fun_label with
+ | Some Some_const -> Vaddr
+ | Some No_const
+ | None -> fundesc.fun_return in
+ fundesc.fun_return <- return;
+ clos.return <- return
+
+let function_constraints module_functions =
+ List.iter add_fun_param_constraints module_functions;
+ List.iter param_boxing module_functions;
+ List.iter add_fun_return_constraints module_functions;
+ List.iter return_boxing module_functions;
+ List.iter (fun (_,desc) -> desc.fun_specialisation_done <- true)
+ module_functions;
+ clear_tables ()
diff --git a/asmcomp/specialisation.mli b/asmcomp/specialisation.mli
new file mode 100644
index 0000000..df33548
--- /dev/null
+++ b/asmcomp/specialisation.mli
@@ -0,0 +1,8 @@
+
+(* Remove type annotation from functions which will not benefit from
+ parameter type specialisation *)
+
+val function_constraints : (Clambda.ufunction * Clambda.function_description) list -> unit
+
+val specialised : Clambda.ufunction -> bool
+val specialised' : Clambda.function_description -> bool
--
1.7.10.4
From 2212511887700d29010068ada4d687eade8d1508 Mon Sep 17 00:00:00 2001
From: Pierre Chambart <pierre.chambart@ocamlpro.org>
Date: Thu, 17 Jan 2013 19:17:06 +0100
Subject: [PATCH 5/5] Use type information in cmm
* When a function can be specialised, it is compiled 2 times:
one time normally, and one time with float parameters and
returns unboxed. The specialised function has a label
suffixed by "_direct"
---
.depend | 11 ++++--
asmcomp/cmmgen.ml | 107 ++++++++++++++++++++++++++++++++++++++++++++++++-----
2 files changed, 105 insertions(+), 13 deletions(-)
diff --git a/.depend b/.depend
index 3e7c931..b73fca0 100644
--- a/.depend
+++ b/.depend
@@ -592,6 +592,7 @@ asmcomp/scheduling.cmi : asmcomp/linearize.cmi
asmcomp/selectgen.cmi : utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo
asmcomp/selection.cmi : asmcomp/mach.cmi asmcomp/cmm.cmi
+asmcomp/specialisation.cmi :
asmcomp/spill.cmi : asmcomp/mach.cmi
asmcomp/split.cmi : asmcomp/mach.cmi
asmcomp/arch.cmo :
@@ -649,7 +650,7 @@ asmcomp/clambda.cmo : bytecomp/lambda.cmi typing/ident.cmi \
asmcomp/clambda.cmx : bytecomp/lambda.cmx typing/ident.cmx \
asmcomp/debuginfo.cmx parsing/asttypes.cmi asmcomp/clambda.cmi
asmcomp/closure.cmo : utils/tbl.cmi bytecomp/switch.cmi \
- asmcomp/specialisation.cmo typing/primitive.cmi utils/misc.cmi \
+ asmcomp/specialisation.cmi typing/primitive.cmi utils/misc.cmi \
bytecomp/lambda.cmi typing/ident.cmi asmcomp/debuginfo.cmi \
asmcomp/compilenv.cmi utils/clflags.cmi asmcomp/clambda.cmi \
parsing/asttypes.cmi asmcomp/arch.cmo asmcomp/closure.cmi
@@ -658,7 +659,7 @@ asmcomp/closure.cmx : utils/tbl.cmx bytecomp/switch.cmx \
bytecomp/lambda.cmx typing/ident.cmx asmcomp/debuginfo.cmx \
asmcomp/compilenv.cmx utils/clflags.cmx asmcomp/clambda.cmx \
parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/closure.cmi
-asmcomp/cmmgen.cmo : bytecomp/switch.cmi asmcomp/specialisation.cmo \
+asmcomp/cmmgen.cmo : bytecomp/switch.cmi asmcomp/specialisation.cmi \
asmcomp/proc.cmi typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi \
typing/ident.cmi asmcomp/debuginfo.cmi utils/config.cmi \
asmcomp/compilenv.cmi asmcomp/cmx_format.cmi asmcomp/cmm.cmi \
@@ -795,9 +796,11 @@ asmcomp/selection.cmx : asmcomp/selectgen.cmx asmcomp/proc.cmx \
utils/misc.cmx asmcomp/mach.cmx asmcomp/cmm.cmx utils/clflags.cmx \
asmcomp/arch.cmx asmcomp/selection.cmi
asmcomp/specialisation.cmo : typing/primitive.cmi bytecomp/lambda.cmi \
- typing/ident.cmi asmcomp/clambda.cmi asmcomp/arch.cmo
+ typing/ident.cmi asmcomp/clambda.cmi asmcomp/arch.cmo \
+ asmcomp/specialisation.cmi
asmcomp/specialisation.cmx : typing/primitive.cmx bytecomp/lambda.cmx \
- typing/ident.cmx asmcomp/clambda.cmx asmcomp/arch.cmx
+ typing/ident.cmx asmcomp/clambda.cmx asmcomp/arch.cmx \
+ asmcomp/specialisation.cmi
asmcomp/spill.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
asmcomp/mach.cmi asmcomp/spill.cmi
asmcomp/spill.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index 75cbc6d..e54743f 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -21,6 +21,14 @@ open Clambda
open Cmm
open Cmx_format
+module IdentMap =
+ Map.Make(struct
+ type t = Ident.t
+ let compare = compare
+ end)
+
+let type_context = ref None
+
(* Local binding of complex expressions *)
let bind name arg fn =
@@ -978,6 +986,13 @@ let is_unboxed_number = function
| Pbbswap bi -> Boxed_integer bi
| _ -> No_unboxing
end
+ | Udirect_apply (desc,_,_) ->
+ begin match desc.fun_return with
+ | Vfloat -> Boxed_float
+ | Vbint bi -> Boxed_integer bi
+ | Vint
+ | Vaddr -> No_unboxing
+ end
| _ -> No_unboxing
let subst_boxed_number unbox_fn boxed_id unboxed_id exp =
@@ -1015,9 +1030,21 @@ let subst_boxed_number unbox_fn boxed_id unboxed_id exp =
let functions = (Queue.create() : ufunction Queue.t)
+let direct_label label = label ^ "_direct"
+
+let var_kind id =
+ match !type_context with
+ | None -> Vaddr
+ | Some map ->
+ try IdentMap.find id map with Not_found -> Vaddr
+
let rec transl = function
Uvar id ->
- Cvar id
+ begin match var_kind id with
+ | Vaddr -> Cvar id
+ | Vint -> tag_int (Cvar id)
+ | Vfloat -> box_float (Cvar id)
+ | Vbint bi -> box_int bi (Cvar id) end
| Uconst (sc, Some const_label) ->
Cconst_symbol const_label
| Uconst (sc, None) ->
@@ -1054,8 +1081,27 @@ let rec transl = function
| Uoffset(arg, offset) ->
field_address (transl arg) offset
| Udirect_apply(fundesc, args, dbg) ->
- Cop(Capply(typ_addr, dbg),
- Cconst_symbol fundesc.fun_label :: List.map transl args)
+ let args = List.map transl args in
+ let rec unbox_args params args = match params, args with
+ | [], [] -> []
+ | [], [arg] -> [arg] (* the environment *)
+ | (_,Vaddr)::q1, arg::q2 -> arg::(unbox_args q1 q2)
+ | (_,Vfloat)::q1, arg::q2 -> (unbox_float arg)::(unbox_args q1 q2)
+ | (_,Vbint bi)::q1, arg::q2 -> (unbox_int bi arg)::(unbox_args q1 q2)
+ | (_,Vint)::q1, arg::q2 -> (untag_int arg)::(unbox_args q1 q2)
+ | _, _ -> assert false in
+ let args' = unbox_args fundesc.fun_params args in
+ let fun_label =
+ if Specialisation.specialised' fundesc
+ then direct_label fundesc.fun_label
+ else fundesc.fun_label in
+ let arg = Cconst_symbol fun_label :: args' in
+ begin match fundesc.fun_return with
+ Vaddr -> Cop(Capply(typ_addr, dbg), arg)
+ | Vint -> tag_int (Cop(Capply(typ_int, dbg), arg))
+ | Vbint bi -> box_int bi (Cop(Capply(typ_int, dbg), arg))
+ | Vfloat -> box_float (Cop(Capply(typ_float, dbg), arg))
+ end
| Ugeneric_apply(clos, [arg], dbg) ->
bind "fun" (transl clos) (fun clos ->
Cop(Capply(typ_addr, dbg), [get_field clos 0; transl arg; clos]))
@@ -1889,12 +1935,55 @@ and transl_letrec bindings cont =
(* Translate a function definition *)
+let with_context c f x =
+ type_context := Some c;
+ let r = f x in
+ type_context := None;
+ r
+
+(* TODO: estimate wether direct or indirect version of a function can
+ be used to remove unused ones *)
let transl_function f =
- Cfunction {fun_name = f.label;
- fun_args = List.map (fun id -> (id, typ_addr)) f.params;
- fun_body = transl f.body;
- fun_fast = !Clflags.optimize_for_speed;
- fun_dbg = f.dbg; }
+ let transl_function' direct f =
+ Cfunction {
+ fun_name =
+ if direct
+ then direct_label f.label
+ else f.label;
+ fun_args =
+ if direct
+ then List.map (function
+ | (id, Vaddr) -> (id, typ_addr)
+ | (id, Vint) -> (id, typ_int)
+ | (id, Vbint _) -> (id, typ_int)
+ | (id, Vfloat) -> (id, typ_float)) f.params
+ else List.map (fun (id, _) -> (id, typ_addr)) f.params;
+ fun_body = begin
+ let context =
+ if direct
+ then
+ List.fold_left (fun map (id,kind) -> IdentMap.add id kind map)
+ IdentMap.empty f.params
+ else
+ IdentMap.empty in
+ let cmm_body = with_context context transl f.body in
+ if direct
+ then match f.return with
+ | Vfloat -> unbox_float cmm_body
+ | Vbint bi -> unbox_int bi cmm_body
+ | Vint -> untag_int cmm_body
+ | Vaddr -> cmm_body
+ else cmm_body
+ end;
+ fun_fast = !Clflags.optimize_for_speed;
+ fun_dbg = f.dbg; } in
+ let generic_body = transl_function' false f in
+ if Specialisation.specialised f
+ then
+ let direct_body = transl_function' true f in
+ [direct_body; generic_body]
+ else
+ [generic_body]
(* Translate all function definitions *)
@@ -1912,7 +2001,7 @@ let rec transl_all_functions already_translated cont =
else begin
transl_all_functions
(StringSet.add f.label already_translated)
- (transl_function f :: cont)
+ (transl_function f @ cont)
end
with Queue.Empty ->
cont
--
1.7.10.4
| ||||||||||
Notes |
|
|
(0008773) gasche (developer) 2013-01-17 23:45 edited on: 2013-01-17 23:46 |
Have you tested the efficiency of this optimization on some of the float-heavy benchmark code that started flowing in (from Alain for example)? > Specialised functions code is duplicated It should be possible to have the boxed version just unbox, and then call the unboxed version; that would result in little additional compiled code. But this is only efficient if the inliner reliably removes this indirection layer (which amounts to unboxing at call-site). Can the inliner be relied upon for this? How much does this degrade the performances in the case where no inlining can happen anyway (no .cmx, functor application...)? (A way to work around the "not sure if boxing will be needed" problem is to specialize to a function that takes *two* arguments, the boxed and the unboxed data. This is better than the boxing version because you don't have to unbox at definition site, could actually not have much overhead if the unboxed data is passed efficiently, and guarantees that no additional allocation is necessary -- it's essentially a specialization of the technique of "On the runtime complexity of type-directed unboxing", Garrigue and Minamide, 1998. I don't expect it to work in practice, but you never know.) |
|
(0008774) frisch (developer) 2013-01-18 09:06 |
This is great news. I fully support this project! > will not be specialised because its parameter is used boxed inside its body. I'm not sure this is a good criterion, although it is in line with the current intra-function behavior (don't unbox if there is a potential use site in boxed form). It could very well be the case that the parameter might be used boxed inside the body, but only in rare cases (e.g. to print an error message if some invariant is broken). If this disable the optimization, it means the caller might need to box the parameter. Have you tried to combine your patch with the strategy I propose to deal with boxing (0005204), i.e. box "lazily" (on demand + memoization)? |
|
(0008778) chambart (reporter) 2013-01-21 12:21 edited on: 2013-01-21 18:54 |
On Alain's bench on my computer: without patch: time: 21.0s minor_words: 2243147047 promoted_words: 450541 with patch (and a few forgoten cases present in my git branch): time: 20.1s minor_words: 1007129106 promoted_words: 238960 Notice that more than half the running time is taken in __ieee754_exp The majority of other float heavy benchmarks I encountered, where written with a big while loop such that nothing was boxed. I will update the patch with a few more things: function parameters where not considered as unboxable float so a function like let f x = let a = if Random.bool () then x else x in a +.a was compiled allocating x and loading from it. This is fixed in my git branch: https://github.com/chambart/ocaml/tree/float_args [^] testing it with opam: opam remote add comp https://github.com/chambart/opam-compilers-repository.git [^] opam switch install trunk+floatarg Gabriel: No the inliner cannot (yet) generate direct calls so a code like: let apply f x = f x let g x = apply (+.) x will generate a generic call to (+.) I have another patch in preparation for that kind of things. The main interest of avoiding boxing is to avoid some allocation, passing both parameters would loose that. The cost of loading from the boxed value is not that much and you would still have to pay for if at each function call (reloading spilled registers). Alain: I didn't merge both patch yet, I think that I will need to change the stategy a bit. I am not completely sure of which cases will not be worth unboxing, maybe when we can show that every possible path in the function use the value boxed. Off topic: How do I remove an attached file ? Is the bug reporter supposed to have the rights to do that ? |
Issue History |
|||
| Date Modified | Username | Field | Change |
| 2013-01-17 21:07 | chambart | New Issue | |
| 2013-01-17 21:07 | chambart | File Added: 0001-Preparing-for-specialisation-patches-1.patch | |
| 2013-01-17 21:08 | chambart | File Added: 0002-Preparing-for-specialisation-patches-2.patch | |
| 2013-01-17 21:08 | chambart | File Added: 0003-Propagate-simple-type-informations-about-parameters-.patch | |
| 2013-01-17 21:08 | chambart | File Added: 0004-Propagate-type-information-to-clambda.patch | |
| 2013-01-17 21:08 | chambart | File Added: 0005-Use-type-information-in-cmm.patch | |
| 2013-01-17 23:45 | gasche | Note Added: 0008773 | |
| 2013-01-17 23:46 | gasche | Note Edited: 0008773 | View Revisions |
| 2013-01-17 23:46 | gasche | Note Edited: 0008773 | View Revisions |
| 2013-01-18 09:06 | frisch | Note Added: 0008774 | |
| 2013-01-21 12:21 | chambart | Note Added: 0008778 | |
| 2013-01-21 18:54 | chambart | Note Edited: 0008778 | View Revisions |
| Copyright © 2000 - 2011 MantisBT Group |



