PR#4794, PR#4959: call annotations not generated by ocamlopt.

git-svn-id: http://caml.inria.fr/svn/ocaml/version/3.12@10667 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

11 files changed, 145 insertions, 38 deletions

diff --git a/Changes b/Changes
index 7c35b12741..66c6d463d7 100644
--- a/Changes
+++ b/Changes
@@ -1,3 +1,9 @@
+Objective Caml 3.12.1:
+----------------------
+
+Bug fixes:
+- PR#4794, PR#4959: call annotations not generated by ocamlopt
+
 Objective Caml 3.12.0:
 ----------------------
 
diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml
index 7524fb4e0d..4ff4d72098 100644
--- a/asmcomp/closure.ml
+++ b/asmcomp/closure.ml
@@ -513,7 +513,7 @@ let rec close fenv cenv = function
       | ((ufunct, _), uargs) ->
           (Ugeneric_apply(ufunct, uargs, Debuginfo.none), Value_unknown)
       end
-  | Lsend(kind, met, obj, args) ->
+  | Lsend(kind, met, obj, args, _) ->
       let (umet, _) = close fenv cenv met in
       let (uobj, _) = close fenv cenv obj in
       (Usend(kind, umet, uobj, close_list fenv cenv args, Debuginfo.none),
diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml
index a8979235e9..50f949a77f 100644
--- a/asmcomp/selectgen.ml
+++ b/asmcomp/selectgen.ml
@@ -824,3 +824,17 @@ method emit_fundecl f =
     fun_fast = f.Cmm.fun_fast }
 
 end
+
+(* Tail call criterion (estimated).  Assumes:
+- all arguments are of type "int" (always the case for Caml function calls)
+- one extra argument representing the closure environment (conservative).
+*)
+
+let is_tail_call nargs =
+  assert (Reg.dummy.typ = Int);
+  let args = Array.make (nargs + 1) Reg.dummy in
+  let (loc_arg, stack_ofs) = Proc.loc_arguments args in
+  stack_ofs = 0
+
+let _ =
+  Simplif.is_tail_native_heuristic := is_tail_call
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index 09c254d4f3..b6c8f6fae8 100644
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -413,12 +413,10 @@ let rec comp_expr env exp sz cont =
   | Lapply(func, args, loc) ->
       let nargs = List.length args in
       if is_tailcall cont then begin
-        Stypes.record (Stypes.An_call (loc, Annot.Tail));
         comp_args env args sz
           (Kpush :: comp_expr env func (sz + nargs)
             (Kappterm(nargs, sz + nargs) :: discard_dead_code cont))
       end else begin
-        Stypes.record (Stypes.An_call (loc, Annot.Stack));
         if nargs < 4 then
           comp_args env args sz
             (Kpush :: comp_expr env func (sz + nargs) (Kapply nargs :: cont))
@@ -430,7 +428,7 @@ let rec comp_expr env exp sz cont =
                       (Kapply nargs :: cont1))
         end
       end
-  | Lsend(kind, met, obj, args) ->
+  | Lsend(kind, met, obj, args, _) ->
       let args = if kind = Cached then List.tl args else args in
       let nargs = List.length args + 1 in
       let getmethod, args' =
@@ -746,9 +744,9 @@ let rec comp_expr env exp sz cont =
       | Lev_after ty ->
           let info =
             match lam with
-              Lapply(_, args, _)   -> Event_return (List.length args)
-            | Lsend(_, _, _, args) -> Event_return (List.length args + 1)
-            | _                 -> Event_other
+              Lapply(_, args, _)      -> Event_return (List.length args)
+            | Lsend(_, _, _, args, _) -> Event_return (List.length args + 1)
+            | _                       -> Event_other
           in
           let ev = event (Event_after ty) info in
           let cont1 = add_event ev cont in
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index ff94a6d9cc..06523ebcc1 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -140,7 +140,7 @@ type lambda =
   | Lwhile of lambda * lambda
   | Lfor of Ident.t * lambda * lambda * direction_flag * lambda
   | Lassign of Ident.t * lambda
-  | Lsend of meth_kind * lambda * lambda * lambda list
+  | Lsend of meth_kind * lambda * lambda * lambda list * Location.t
   | Levent of lambda * lambda_event
   | Lifused of Ident.t * lambda
 
@@ -201,7 +201,7 @@ let rec same l1 l2 =
       same b1 b2 && df1 = df2 && same c1 c2
   | Lassign(id1, a1), Lassign(id2, a2) ->
       Ident.same id1 id2 && same a1 a2
-  | Lsend(k1, a1, b1, cl1), Lsend(k2, a2, b2, cl2) ->
+  | Lsend(k1, a1, b1, cl1, _), Lsend(k2, a2, b2, cl2, _) ->
       k1 = k2 && same a1 a2 && same b1 b2 && samelist same cl1 cl2
   | Levent(a1, ev1), Levent(a2, ev2) ->
       same a1 a2 && ev1.lev_loc = ev2.lev_loc
@@ -277,7 +277,7 @@ let rec iter f = function
       f e1; f e2; f e3
   | Lassign(id, e) ->
       f e
-  | Lsend (k, met, obj, args) ->
+  | Lsend (k, met, obj, args, _) ->
       List.iter f (met::obj::args)
   | Levent (lam, evt) ->
       f lam
@@ -320,7 +320,7 @@ let free_variables l =
   free_ids (function Lvar id -> [id] | _ -> []) l
 
 let free_methods l =
-  free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> []) l
+  free_ids (function Lsend(Self, Lvar meth, obj, _, _) -> [meth] | _ -> []) l
 
 (* Check if an action has a "when" guard *)
 let raise_count = ref 0
@@ -398,8 +398,8 @@ let subst_lambda s lam =
   | Lwhile(e1, e2) -> Lwhile(subst e1, subst e2)
   | Lfor(v, e1, e2, dir, e3) -> Lfor(v, subst e1, subst e2, dir, subst e3)
   | Lassign(id, e) -> Lassign(id, subst e)
-  | Lsend (k, met, obj, args) ->
-      Lsend (k, subst met, subst obj, List.map subst args)
+  | Lsend (k, met, obj, args, loc) ->
+      Lsend (k, subst met, subst obj, List.map subst args, loc)
   | Levent (lam, evt) -> Levent (subst lam, evt)
   | Lifused (v, e) -> Lifused (v, subst e)
   and subst_decl (id, exp) = (id, subst exp)
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index 8c34ac94ab..e671b89156 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -149,7 +149,7 @@ type lambda =
   | Lwhile of lambda * lambda
   | Lfor of Ident.t * lambda * lambda * direction_flag * lambda
   | Lassign of Ident.t * lambda
-  | Lsend of meth_kind * lambda * lambda * lambda list
+  | Lsend of meth_kind * lambda * lambda * lambda list * Location.t
   | Levent of lambda * lambda_event
   | Lifused of Ident.t * lambda
 
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index 0d6e19148d..9bfa099e15 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -285,7 +285,7 @@ let rec lam ppf = function
        lam hi lam body
   | Lassign(id, expr) ->
       fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr
-  | Lsend (k, met, obj, largs) ->
+  | Lsend (k, met, obj, largs, _) ->
       let args ppf largs =
         List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
       let kind =
diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml
index 6081d5bd4a..cd942ca2d5 100644
--- a/bytecomp/simplif.ml
+++ b/bytecomp/simplif.ml
@@ -75,9 +75,9 @@ let rec eliminate_ref id = function
            dir, eliminate_ref id e3)
   | Lassign(v, e) ->
       Lassign(v, eliminate_ref id e)
-  | Lsend(k, m, o, el) ->
+  | Lsend(k, m, o, el, loc) ->
       Lsend(k, eliminate_ref id m, eliminate_ref id o,
-            List.map (eliminate_ref id) el)
+            List.map (eliminate_ref id) el, loc)
   | Levent(l, ev) ->
       Levent(eliminate_ref id l, ev)
   | Lifused(v, e) ->
@@ -144,7 +144,7 @@ let simplify_exits lam =
       (* Lalias-bound variables are never assigned, so don't increase
          v's refcount *)
       count l
-  | Lsend(k, m, o, ll) -> List.iter count (m::o::ll)
+  | Lsend(k, m, o, ll, _) -> List.iter count (m::o::ll)
   | Levent(l, _) -> count l
   | Lifused(v, l) -> count l
 
@@ -250,7 +250,7 @@ let simplify_exits lam =
   | Lfor(v, l1, l2, dir, l3) ->
       Lfor(v, simplif l1, simplif l2, dir, simplif l3)
   | Lassign(v, l) -> Lassign(v, simplif l)
-  | Lsend(k, m, o, ll) -> Lsend(k, simplif m, simplif o, List.map simplif ll)
+  | Lsend(k, m, o, ll, loc) -> Lsend(k, simplif m, simplif o, List.map simplif ll, loc)
   | Levent(l, ev) -> Levent(simplif l, ev)
   | Lifused(v, l) -> Lifused (v,simplif l)
   in
@@ -313,7 +313,7 @@ let simplify_lets lam =
       (* Lalias-bound variables are never assigned, so don't increase
          v's refcount *)
       count l
-  | Lsend(_, m, o, ll) -> List.iter count (m::o::ll)
+  | Lsend(_, m, o, ll, _) -> List.iter count (m::o::ll)
   | Levent(l, _) -> count l
   | Lifused(v, l) ->
       if count_var v > 0 then count l
@@ -402,11 +402,93 @@ let simplify_lets lam =
   | Lfor(v, l1, l2, dir, l3) ->
       Lfor(v, simplif l1, simplif l2, dir, simplif l3)
   | Lassign(v, l) -> Lassign(v, simplif l)
-  | Lsend(k, m, o, ll) -> Lsend(k, simplif m, simplif o, List.map simplif ll)
+  | Lsend(k, m, o, ll, loc) -> Lsend(k, simplif m, simplif o, List.map simplif ll, loc)
   | Levent(l, ev) -> Levent(simplif l, ev)
   | Lifused(v, l) ->
       if count_var v > 0 then simplif l else lambda_unit
   in
   simplif lam
 
-let simplify_lambda lam = simplify_lets (simplify_exits lam)
+(* Tail call info in annotation files *)
+
+let is_tail_native_heuristic : (int -> bool) ref =
+  ref (fun n -> true)
+
+let rec emit_tail_infos is_tail lambda =
+  let call_kind args =
+    if is_tail
+    && ((not !Clflags.native_code)
+        || (!is_tail_native_heuristic (List.length args)))
+   then Annot.Tail
+   else Annot.Stack in
+  match lambda with
+  | Lvar _ -> ()
+  | Lconst _ -> ()
+  | 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
+  | Llet (_, _, lam, body) ->
+      emit_tail_infos false lam;
+      emit_tail_infos is_tail body
+  | Lletrec (bindings, body) ->
+      List.iter (fun (_, lam) -> emit_tail_infos false lam) bindings;
+      emit_tail_infos is_tail body
+  | Lprim (Pidentity, [arg]) ->
+      emit_tail_infos is_tail arg
+  | Lprim (Psequand, [arg1; arg2])
+  | Lprim (Psequor, [arg1; arg2]) ->
+      emit_tail_infos false arg1;
+      emit_tail_infos is_tail arg2
+  | Lprim (_, l) ->
+      list_emit_tail_infos false l
+  | Lswitch (lam, sw) ->
+      emit_tail_infos false lam;
+      list_emit_tail_infos_fun snd is_tail sw.sw_consts;
+      list_emit_tail_infos_fun snd is_tail sw.sw_blocks
+  | Lstaticraise (_, l) ->
+      list_emit_tail_infos false l
+  | Lstaticcatch (body, _, handler) ->
+      emit_tail_infos is_tail body;
+      emit_tail_infos is_tail handler
+  | Ltrywith (body, _, handler) ->
+      emit_tail_infos false body;
+      emit_tail_infos is_tail handler
+  | Lifthenelse (cond, ifso, ifno) ->
+      emit_tail_infos false cond;
+      emit_tail_infos is_tail ifso;
+      emit_tail_infos is_tail ifno
+  | Lsequence (lam1, lam2) ->
+      emit_tail_infos false lam1;
+      emit_tail_infos is_tail lam2
+  | Lwhile (cond, body) ->
+      emit_tail_infos false cond;
+      emit_tail_infos false body
+  | Lfor (_, low, high, _, body) ->
+      emit_tail_infos false low;
+      emit_tail_infos false high;
+      emit_tail_infos false body
+  | Lassign (_, lam) ->
+      emit_tail_infos false lam
+  | Lsend (_, meth, obj, args, loc) ->
+      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)))
+  | Levent (lam, _) ->
+      emit_tail_infos is_tail lam
+  | Lifused (_, lam) ->
+      emit_tail_infos is_tail lam
+and list_emit_tail_infos_fun f is_tail =
+  List.iter (fun x -> emit_tail_infos is_tail (f x))
+and list_emit_tail_infos is_tail =
+  List.iter (emit_tail_infos is_tail)
+
+(* The entry point:
+   simplification + emission of tailcall annotations, if needed. *)
+
+let simplify_lambda lam =
+  let res = simplify_lets (simplify_exits lam) in
+  if !Clflags.annotations then emit_tail_infos true res;
+  res
diff --git a/bytecomp/simplif.mli b/bytecomp/simplif.mli
index 5e5217ff18..2d9b352bb6 100644
--- a/bytecomp/simplif.mli
+++ b/bytecomp/simplif.mli
@@ -12,8 +12,15 @@
 
 (* $Id$ *)
 
-(* Elimination of useless Llet(Alias) bindings *)
+(* Elimination of useless Llet(Alias) bindings.
+   Transformation of let-bound references into variables.
+   Simplification over staticraise/staticcatch constructs.
+   Generation of tail-call annotations if -annot is set. *)
 
 open Lambda
 
 val simplify_lambda: lambda -> lambda
+
+(* To be filled by asmcomp/selectgen.ml *)
+val is_tail_native_heuristic: (int -> bool) ref
+                          (* # arguments -> can tailcall *)
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index cf5783a979..e18a13ba6c 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -495,7 +495,7 @@ let rec builtin_meths self env env2 body =
         "var", [Lvar n]
     | Lprim(Pfield n, [Lvar e]) when Ident.same e env ->
         "env", [Lvar env2; Lconst(Const_pointer n)]
-    | Lsend(Self, met, Lvar s, []) when List.mem s self ->
+    | Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
         "meth", [met]
     | _ -> raise Not_found
   in
@@ -510,15 +510,15 @@ let rec builtin_meths self env env2 body =
   | Lapply(f, [p; arg], _) when const_path f && const_path p ->
       let s, args = conv arg in
       ("app_const_"^s, f :: p :: args)
-  | Lsend(Self, Lvar n, Lvar s, [arg]) when List.mem s self ->
+  | Lsend(Self, Lvar n, Lvar s, [arg], _) when List.mem s self ->
       let s, args = conv arg in
       ("meth_app_"^s, Lvar n :: args)
-  | Lsend(Self, met, Lvar s, []) when List.mem s self ->
+  | Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
       ("get_meth", [met])
-  | Lsend(Public, met, arg, []) ->
+  | Lsend(Public, met, arg, [], _) ->
       let s, args = conv arg in
       ("send_"^s, met :: args)
-  | Lsend(Cached, met, arg, [_;_]) ->
+  | Lsend(Cached, met, arg, [_;_], _) ->
       let s, args = conv arg in
       ("send_"^s, met :: args)
   | Lfunction (Curried, [x], body) ->
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 5fcd8eeb97..3b0b0b0d54 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -571,12 +571,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, []))
+        Lfunction(Curried, [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]))
+                  Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos], e.exp_loc))
       else
         transl_primitive p
   | Texp_ident(path, {val_kind = Val_anc _}) ->
@@ -614,10 +614,10 @@ and transl_exp0 e =
       if public_send || p.prim_name = "%sendself" then
         let kind = if public_send then Public else Self in
         let obj = List.hd argl in
-        wrap (Lsend (kind, List.nth argl 1, obj, []))
+        wrap (Lsend (kind, List.nth argl 1, obj, [], e.exp_loc))
       else if p.prim_name = "%sendcache" then
         match argl with [obj; meth; cache; pos] ->
-          wrap (Lsend(Cached, meth, obj, [cache; pos]))
+          wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc))
         | _ -> assert false
       else begin
         let prim = transl_prim p args in
@@ -737,11 +737,11 @@ and transl_exp0 e =
       let obj = transl_exp expr in
       let lam =
         match met with
-          Tmeth_val id -> Lsend (Self, Lvar id, obj, [])
+          Tmeth_val id -> Lsend (Self, Lvar id, obj, [], e.exp_loc)
         | Tmeth_name nm ->
             let (tag, cache) = Translobj.meth obj nm in
             let kind = if cache = [] then Public else Cached in
-            Lsend (kind, tag, obj, cache)
+            Lsend (kind, tag, obj, cache, e.exp_loc)
       in
       event_after e lam
   | Texp_new (cl, _) ->
@@ -840,10 +840,10 @@ and transl_tupled_cases patl_expr_list =
 and transl_apply lam sargs loc =
   let lapply funct args =
     match funct with
-      Lsend(k, lmet, lobj, largs) ->
-        Lsend(k, lmet, lobj, largs @ args)
-    | Levent(Lsend(k, lmet, lobj, largs), _) ->
-        Lsend(k, lmet, lobj, largs @ args)
+      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)
     | lexp ->