Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

GPR#111: `(f [@taillcall]) x y` warns if `f x y` is not a tail-call 

(Simon Cruanes)

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@16010 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Gabriel Scherer 2015-04-12 18:26:38 +00:00
parent 4530ee379c
commit 90061455e6
18 changed files with 111 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Changes
View File

@ -115,6 +115,8 @@ Features wishes:
- PR#6742: remove duplicate virtual_flag information from Tstr_class
- PR#6719: improve Buffer.add_channel when not enough input is available
(Simon Cruanes)
- GPR#111: `(f [@taillcall]) x y` warns if `f x y` is not a tail-call
(Simon Cruanes)
- GPR#118: ocamldep -allow-approx: fallback to a lexer-based approximation
(Frédéric Bour)
- GPR#137: add untypeast.ml (in open recursion style) to compiler-libs

8
asmcomp/closure.ml
View File

@ -119,7 +119,7 @@ let split_default_wrapper fun_id kind params body =
let inner_id = Ident.create (Ident.name fun_id ^ "_inner") in
let map_param p = try List.assoc p map with Not_found -> p in
let args = List.map (fun p -> Lvar (map_param p)) params in
let wrapper_body = Lapply (Lvar inner_id, args, Location.none) in
let wrapper_body = Lapply (Lvar inner_id, args, no_apply_info) in
let inner_params = List.map map_param params in
let new_ids = List.map Ident.rename inner_params in
@ -845,7 +845,7 @@ let rec close fenv cenv = function
(* We convert [f a] to [let a' = a in fun b c -> f a' b c]
when fun_arity > nargs *)
| Lapply(funct, args, loc) ->
| Lapply(funct, args, {apply_loc=loc}) ->
let nargs = List.length args in
begin match (close fenv cenv funct, close_list fenv cenv args) with
((ufunct, Value_closure(fundesc, approx_res)),
@ -880,7 +880,7 @@ let rec close fenv cenv = function
(Lfunction{
kind = Curried;
params = final_args;
body = Lapply(funct, internal_args, loc)})
body = Lapply(funct, internal_args, mk_apply_info loc)})
in
let new_fun = iter first_args new_fun in
(new_fun, approx)
@ -946,7 +946,7 @@ let rec close fenv cenv = function
end
| Lprim(Pdirapply loc,[funct;arg])
| Lprim(Prevapply loc,[arg;funct]) ->
close fenv cenv (Lapply(funct, [arg], loc))
close fenv cenv (Lapply(funct, [arg], mk_apply_info loc))
| Lprim(Pgetglobal id, []) as lam ->
check_constant_result lam
(getglobal id)

4
bytecomp/bytegen.ml
View File

@ -452,7 +452,7 @@ let rec comp_expr env exp sz cont =
end
| Lconst cst ->
Kconst cst :: cont
| Lapply(func, args, loc) ->
| Lapply(func, args, info) ->
let nargs = List.length args in
if is_tailcall cont then begin
comp_args env args sz
@ -574,7 +574,7 @@ let rec comp_expr env exp sz cont =
comp_expr env arg sz (add_const_unit cont)
| Lprim(Pdirapply loc, [func;arg])
| Lprim(Prevapply loc, [arg;func]) ->
let exp = Lapply(func, [arg], loc) in
let exp = Lapply(func, [arg], mk_apply_info loc) in
comp_expr env exp sz cont
| Lprim(Pnot, [arg]) ->
let newcont =

18
bytecomp/lambda.ml
View File

@ -161,6 +161,18 @@ type structured_constant =
| Const_float_array of string list
| Const_immstring of string
type apply_info = {
apply_loc : Location.t;
apply_should_be_tailcall : bool; (* true if [@tailcall] was specified *)
}
let mk_apply_info ?(tailcall=false) loc =
{apply_loc=loc;
apply_should_be_tailcall=tailcall; }
let no_apply_info =
{apply_loc=Location.none; apply_should_be_tailcall=false;}
type function_kind = Curried | Tupled
type let_kind = Strict | Alias | StrictOpt | Variable
@ -172,7 +184,7 @@ type shared_code = (int * int) list
type lambda =
Lvar of Ident.t
| Lconst of structured_constant
| Lapply of lambda * lambda list * Location.t
| Lapply of lambda * lambda list * apply_info
| Lfunction of lfunction
| Llet of let_kind * Ident.t * lambda * lambda
| Lletrec of (Ident.t * lambda) list * lambda
@ -245,8 +257,8 @@ let make_key e =
(* Mutable constants are not shared *)
raise Not_simple
| Lconst _ -> e
| Lapply (e,es,loc) ->
Lapply (tr_rec env e,tr_recs env es,Location.none)
| Lapply (e,es,info) ->
Lapply (tr_rec env e,tr_recs env es,{info with apply_loc=Location.none})
| Llet (Alias,x,ex,e) -> (* Ignore aliases -> substitute *)
let ex = tr_rec env ex in
tr_rec (Ident.add x ex env) e

14
bytecomp/lambda.mli
View File

@ -161,6 +161,18 @@ type structured_constant =
| Const_float_array of string list
| Const_immstring of string
type apply_info = {
apply_loc : Location.t;
apply_should_be_tailcall : bool; (* true if [@tailcall] was specified *)
}
val no_apply_info : apply_info
(** Default [apply_info]: no location, no tailcall *)
val mk_apply_info : ?tailcall:bool -> Location.t -> apply_info
(** Build apply_info
@param tailcall if true, the application should be in tail position; default false *)
type function_kind = Curried | Tupled
type let_kind = Strict | Alias | StrictOpt | Variable
@ -181,7 +193,7 @@ type shared_code = (int * int) list (* stack size -> code label *)
type lambda =
Lvar of Ident.t
| Lconst of structured_constant
| Lapply of lambda * lambda list * Location.t
| Lapply of lambda * lambda list * apply_info
| Lfunction of lfunction
| Llet of let_kind * Ident.t * lambda * lambda
| Lletrec of (Ident.t * lambda) list * lambda

4
bytecomp/matching.ml
View File

@ -1526,7 +1526,7 @@ let inline_lazy_force_cond arg loc =
(* ... if (tag == Obj.lazy_tag) then Lazy.force varg else ... *)
Lprim(Pintcomp Ceq,
[Lvar tag; Lconst(Const_base(Const_int Obj.lazy_tag))]),
Lapply(force_fun, [varg], loc),
Lapply(force_fun, [varg], mk_apply_info loc),
(* ... arg *)
varg))))
@ -1544,7 +1544,7 @@ let inline_lazy_force_switch arg loc =
sw_blocks =
[ (Obj.forward_tag, Lprim(Pfield 0, [varg]));
(Obj.lazy_tag,
Lapply(force_fun, [varg], loc)) ];
Lapply(force_fun, [varg], mk_apply_info loc)) ];
sw_failaction = Some varg } ))))
let inline_lazy_force arg loc =

4
bytecomp/printlambda.ml
View File

@ -254,6 +254,10 @@ let rec lam ppf = function
Ident.print ppf id
| Lconst cst ->
struct_const ppf cst
| Lapply(lfun, largs, info) when info.apply_should_be_tailcall ->
let lams ppf largs =
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
fprintf ppf "@[<2>(apply@ %a%a @@tailcall)@]" lam lfun lams largs
| Lapply(lfun, largs, _) ->
let lams ppf largs =
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in

37
bytecomp/simplif.ml
View File

@ -24,8 +24,8 @@ let rec eliminate_ref id = function
Lvar v as lam ->
if Ident.same v id then raise Real_reference else lam
| Lconst cst as lam -> lam
| Lapply(e1, el, loc) ->
Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el, loc)
| Lapply(e1, el, info) ->
Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el, info)
| Lfunction{kind; params; body} as lam ->
if IdentSet.mem id (free_variables lam)
then raise Real_reference
@ -193,7 +193,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)
| Lapply(l1, ll, info) -> Lapply(simplif l1, List.map simplif ll, info)
| Lfunction{kind; params; body = l} ->
Lfunction{kind; params; body = simplif l}
| Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2)
@ -203,16 +203,16 @@ let simplify_exits lam =
let ll = List.map simplif ll in
match p, ll with
(* Simplify %revapply, for n-ary functions with n > 1 *)
| Prevapply loc, [x; Lapply(f, args, _)]
| Prevapply loc, [x; Levent (Lapply(f, args, _),_)] ->
Lapply(f, args@[x], loc)
| Prevapply loc, [x; f] -> Lapply(f, [x], loc)
| Prevapply loc, [x; Lapply(f, args, info)]
| Prevapply loc, [x; Levent (Lapply(f, args, info),_)] ->
Lapply(f, args@[x], {info with apply_loc=loc})
| Prevapply loc, [x; f] -> Lapply(f, [x], mk_apply_info loc)
(* Simplify %apply, for n-ary functions with n > 1 *)
| Pdirapply loc, [Lapply(f, args, _); x]
| Pdirapply loc, [Levent (Lapply(f, args, _),_); x] ->
Lapply(f, args@[x], loc)
| Pdirapply loc, [f; x] -> Lapply(f, [x], loc)
| Pdirapply loc, [Lapply(f, args, info); x]
| Pdirapply loc, [Levent (Lapply(f, args, info),_); x] ->
Lapply(f, args@[x], {info with apply_loc=loc})
| Pdirapply loc, [f; x] -> Lapply(f, [x], mk_apply_info loc)
| _ -> Lprim(p, ll)
end
@ -518,9 +518,14 @@ let rec emit_tail_infos is_tail lambda =
match lambda with
| Lvar _ -> ()
| Lconst _ -> ()
| Lapply (func, l, loc) ->
| Lapply (func, l, ({apply_loc=loc} as info)) ->
if info.apply_should_be_tailcall
&& not is_tail
&& Warnings.is_active Warnings.Expect_tailcall
then Location.prerr_warning loc Warnings.Expect_tailcall;
list_emit_tail_infos false l;
Stypes.record (Stypes.An_call (loc, call_kind l))
if !Clflags.annotations then
Stypes.record (Stypes.An_call (loc, call_kind l));
| Lfunction {body = lam} ->
emit_tail_infos true lam
| Llet (_, _, lam, body) ->
@ -576,7 +581,8 @@ let rec emit_tail_infos is_tail lambda =
emit_tail_infos false meth;
emit_tail_infos false obj;
list_emit_tail_infos false args;
Stypes.record (Stypes.An_call (loc, call_kind (obj :: args)))
if !Clflags.annotations then
Stypes.record (Stypes.An_call (loc, call_kind (obj :: args)));
| Levent (lam, _) ->
emit_tail_infos is_tail lam
| Lifused (_, lam) ->
@ -591,5 +597,6 @@ and list_emit_tail_infos is_tail =
let simplify_lambda lam =
let res = simplify_lets (simplify_exits lam) in
if !Clflags.annotations then emit_tail_infos true res;
if !Clflags.annotations || Warnings.is_active Warnings.Expect_tailcall
then emit_tail_infos true res;
res

4
bytecomp/translclass.ml
View File

@ -38,7 +38,7 @@ let lapply func args loc =
| _ ->
Lapply(func, args, loc)
let mkappl (func, args) = Lapply (func, args, Location.none);;
let mkappl (func, args) = Lapply (func, args, no_apply_info);;
let lsequence l1 l2 =
if l2 = lambda_unit then l1 else Lsequence(l1, l2)
@ -449,7 +449,7 @@ let transl_class_rebind ids cl vf =
try
let obj_init = Ident.create "obj_init"
and self = Ident.create "self" in
let obj_init0 = lapply (Lvar obj_init) [Lvar self] Location.none in
let obj_init0 = lapply (Lvar obj_init) [Lvar self] no_apply_info in
let path, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in
if not (Translcore.check_recursive_lambda ids obj_init') then
raise(Error(cl.cl_loc, Illegal_class_expr));

24
bytecomp/translcore.ml
View File

@ -646,6 +646,9 @@ let rec cut n l =
let try_ids = Hashtbl.create 8
let has_tailcall_attribute e =
List.exists (fun ({txt},_) -> txt="tailcall") e.exp_attributes
let rec transl_exp e =
let eval_once =
(* Whether classes for immediate objects must be cached *)
@ -691,14 +694,16 @@ and transl_exp0 e =
in
Lfunction{kind; params; body}
| Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p});
exp_type = prim_type }, oargs)
exp_type = prim_type } as funct, oargs)
when List.length oargs >= p.prim_arity
&& List.for_all (fun (_, arg,_) -> arg <> None) oargs ->
let args, args' = cut p.prim_arity oargs in
let wrap f =
if args' = []
then event_after e f
else event_after e (transl_apply f args' e.exp_loc)
else
let should_be_tailcall = has_tailcall_attribute funct in
event_after e (transl_apply ~should_be_tailcall f args' e.exp_loc)
in
let wrap0 f =
if args' = [] then f else wrap f in
@ -746,7 +751,8 @@ and transl_exp0 e =
end
end
| Texp_apply(funct, oargs) ->
event_after e (transl_apply (transl_exp funct) oargs e.exp_loc)
let should_be_tailcall = has_tailcall_attribute funct in
event_after e (transl_apply ~should_be_tailcall (transl_exp funct) oargs e.exp_loc)
| Texp_match(arg, pat_expr_list, exn_pat_expr_list, partial) ->
transl_match e arg pat_expr_list exn_pat_expr_list partial
| Texp_try(body, pat_expr_list) ->
@ -864,7 +870,7 @@ and transl_exp0 e =
event_after e lam
| Texp_new (cl, {Location.loc=loc}, _) ->
Lapply(Lprim(Pfield 0, [transl_path ~loc e.exp_env cl]),
[lambda_unit], Location.none)
[lambda_unit], no_apply_info)
| Texp_instvar(path_self, path, _) ->
Lprim(Parrayrefu Paddrarray,
[transl_normal_path path_self; transl_normal_path path])
@ -874,7 +880,7 @@ and transl_exp0 e =
let cpy = Ident.create "copy" in
Llet(Strict, cpy,
Lapply(Translobj.oo_prim "copy", [transl_normal_path path_self],
Location.none),
no_apply_info),
List.fold_right
(fun (path, _, expr) rem ->
Lsequence(transl_setinstvar (Lvar cpy) path expr, rem))
@ -985,17 +991,17 @@ and transl_tupled_cases patl_expr_list =
List.map (fun (patl, guard, expr) -> (patl, transl_guard guard expr))
patl_expr_list
and transl_apply lam sargs loc =
and transl_apply ?(should_be_tailcall=false) lam sargs loc =
let lapply funct args =
match funct with
Lsend(k, lmet, lobj, largs, loc) ->
Lsend(k, lmet, lobj, largs @ args, loc)
| Levent(Lsend(k, lmet, lobj, largs, loc), _) ->
Lsend(k, lmet, lobj, largs @ args, loc)
| Lapply(lexp, largs, _) ->
Lapply(lexp, largs @ args, loc)
| Lapply(lexp, largs, info) ->
Lapply(lexp, largs @ args, {info with apply_loc=loc})
| lexp ->
Lapply(lexp, args, loc)
Lapply(lexp, args, mk_apply_info ~tailcall:should_be_tailcall loc)
in
let rec build_apply lam args = function
(None, optional) :: l ->

3
bytecomp/translcore.mli
View File

@ -18,7 +18,8 @@ open Typedtree
open Lambda
val transl_exp: expression -> lambda
val transl_apply: lambda -> (arg_label * expression option * optional) list
val transl_apply: ?should_be_tailcall:bool
-> lambda -> (arg_label * expression option * optional) list
-> Location.t -> lambda
val transl_let: rec_flag -> value_binding list -> lambda -> lambda
val transl_primitive: Location.t -> Primitive.description -> Env.t

14
bytecomp/translmod.ml
View File

@ -97,7 +97,7 @@ let rec apply_coercion strict restr arg =
Strict cc_res
(Lapply(Lvar id,
[apply_coercion Alias cc_arg (Lvar param)],
Location.none))})
no_apply_info))})
| Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } ->
transl_primitive pc_loc pc_desc pc_env pc_type
| Tcoerce_alias (path, cc) ->
@ -281,7 +281,8 @@ let eval_rec_bindings bindings cont =
| (id, None, rhs) :: rem ->
bind_inits rem
| (id, Some(loc, shape), rhs) :: rem ->
Llet(Strict, id, Lapply(mod_prim "init_mod", [loc; shape], Location.none),
Llet(Strict, id,
Lapply(mod_prim "init_mod", [loc; shape], no_apply_info),
bind_inits rem)
and bind_strict = function
[] ->
@ -296,8 +297,7 @@ let eval_rec_bindings bindings cont =
| (id, None, rhs) :: rem ->
patch_forwards rem
| (id, Some(loc, shape), rhs) :: rem ->
Lsequence(Lapply(mod_prim "update_mod", [shape; Lvar id; rhs],
Location.none),
Lsequence(Lapply(mod_prim "update_mod", [shape; Lvar id; rhs], no_apply_info),
patch_forwards rem)
in
bind_inits bindings
@ -368,7 +368,7 @@ let rec transl_module cc rootpath mexp =
oo_wrap mexp.mod_env true
(apply_coercion Strict cc)
(Lapply(transl_module Tcoerce_none None funct,
[transl_module ccarg None arg], mexp.mod_loc))
[transl_module ccarg None arg], mk_apply_info mexp.mod_loc))
| Tmod_constraint(arg, mty, _, ccarg) ->
transl_module (compose_coercions cc ccarg) rootpath arg
| Tmod_unpack(arg, _) ->
@ -800,13 +800,13 @@ let toploop_getvalue id =
Lapply(Lprim(Pfield toploop_getvalue_pos,
[Lprim(Pgetglobal toploop_ident, [])]),
[Lconst(Const_base(Const_string (toplevel_name id, None)))],
Location.none)
no_apply_info)
let toploop_setvalue id lam =
Lapply(Lprim(Pfield toploop_setvalue_pos,
[Lprim(Pgetglobal toploop_ident, [])]),
[Lconst(Const_base(Const_string (toplevel_name id, None))); lam],
Location.none)
no_apply_info)
let toploop_setvalue_id id = toploop_setvalue id (Lvar id)

5
testsuite/tests/warnings/w50.ml Normal file
View File

@ -0,0 +1,5 @@
let rec fact = function
| 1 -> 1
| n -> n * (fact [@tailcall]) (n-1)
;;

2
testsuite/tests/warnings/w50.reference Normal file
View File

@ -0,0 +1,2 @@
File "w50.ml", line 4, characters 13-37:
Warning 50: expected tailcall

5
testsuite/tests/warnings/w50_bis.ml Normal file
View File

@ -0,0 +1,5 @@
let rec foldl op acc = function
[] -> acc
| x :: xs ->
try (foldl [@tailcall]) op (op x acc) xs
with Not_found -> assert false

2
testsuite/tests/warnings/w50_bis.reference Normal file
View File

@ -0,0 +1,2 @@
File "w50_bis.ml", line 4, characters 12-48:
Warning 50: expected tailcall

7
utils/warnings.ml
View File

@ -67,6 +67,7 @@ type t =
| Attribute_payload of string * string (* 47 *)
| Eliminated_optional_arguments of string list (* 48 *)
| No_cmi_file of string (* 49 *)
| Expect_tailcall (* 50 *)
;;
(* If you remove a warning, leave a hole in the numbering. NEVER change
@ -125,9 +126,10 @@ let number = function
| Attribute_payload _ -> 47
| Eliminated_optional_arguments _ -> 48
| No_cmi_file _ -> 49
| Expect_tailcall -> 50
;;
let last_warning_number = 49
let last_warning_number = 50
(* Must be the max number returned by the [number] function. *)
let letter = function
@ -384,6 +386,8 @@ let message = function
(String.concat ", " sl)
| No_cmi_file s ->
"no cmi file was found in path for module " ^ s
| Expect_tailcall ->
Printf.sprintf "expected tailcall"
;;
let nerrors = ref 0;;
@ -478,6 +482,7 @@ let descriptions =
47, "Illegal attribute payload.";
48, "Implicit elimination of optional arguments.";
49, "Absent cmi file when looking up module alias.";
50, "Warning on non-tail calls if @tailcall present";
]
;;

1
utils/warnings.mli
View File

@ -62,6 +62,7 @@ type t =
| Attribute_payload of string * string (* 47 *)
| Eliminated_optional_arguments of string list (* 48 *)
| No_cmi_file of string (* 49 *)
| Expect_tailcall (* 50 *)
;;
val parse_options : bool -> string -> unit;;