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

18 files changed, 111 insertions, 47 deletions

diff --git a/Changes b/Changes
index 32809a1e27..7f405f999a 100644
--- a/Changes
+++ b/Changes
@@ -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
diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml
index 543fbf9a77..175932c8f5 100644
--- a/asmcomp/closure.ml
+++ b/asmcomp/closure.ml
@@ -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)
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index 2868aefb37..82cb50a369 100644
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -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 =
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index e0f3a69f7d..70f22ed9a6 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -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
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index e1e4d20b1f..eba9593d7f 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -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
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index a4f5970b30..1bdeef8ea7 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -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 =
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index b4d4d3bd37..591822f3b8 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -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
diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml
index 932d307172..a7e004cbba 100644
--- a/bytecomp/simplif.ml
+++ b/bytecomp/simplif.ml
@@ -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
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index 250497f24c..f172e9a9ac 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -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));
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index cf26b2307b..6b43989130 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -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 ->
diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli
index 0c0355b3a4..75ba9fcf02 100644
--- a/bytecomp/translcore.mli
+++ b/bytecomp/translcore.mli
@@ -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
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index 448401f806..4ff70b7be4 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -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)
 
diff --git a/testsuite/tests/warnings/w50.ml b/testsuite/tests/warnings/w50.ml
new file mode 100644
index 0000000000..25e087068d
--- /dev/null
+++ b/testsuite/tests/warnings/w50.ml
@@ -0,0 +1,5 @@
+
+let rec fact = function
+  | 1 -> 1
+  | n -> n * (fact [@tailcall]) (n-1)
+;;
diff --git a/testsuite/tests/warnings/w50.reference b/testsuite/tests/warnings/w50.reference
new file mode 100644
index 0000000000..8cb6c814ff
--- /dev/null
+++ b/testsuite/tests/warnings/w50.reference
@@ -0,0 +1,2 @@
+File "w50.ml", line 4, characters 13-37:
+Warning 50: expected tailcall
diff --git a/testsuite/tests/warnings/w50_bis.ml b/testsuite/tests/warnings/w50_bis.ml
new file mode 100644
index 0000000000..810fcdd4f5
--- /dev/null
+++ b/testsuite/tests/warnings/w50_bis.ml
@@ -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
diff --git a/testsuite/tests/warnings/w50_bis.reference b/testsuite/tests/warnings/w50_bis.reference
new file mode 100644
index 0000000000..79d54596e6
--- /dev/null
+++ b/testsuite/tests/warnings/w50_bis.reference
@@ -0,0 +1,2 @@
+File "w50_bis.ml", line 4, characters 12-48:
+Warning 50: expected tailcall
diff --git a/utils/warnings.ml b/utils/warnings.ml
index 0547f21c95..c9bfd1d215 100644
--- a/utils/warnings.ml
+++ b/utils/warnings.ml
@@ -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";
   ]
 ;;
 
diff --git a/utils/warnings.mli b/utils/warnings.mli
index edfd732c31..ff8aee29db 100644
--- a/utils/warnings.mli
+++ b/utils/warnings.mli
@@ -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;;