Added tail call heuristic for native compilationannot-from-lambda

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/annot-from-lambda@10466 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

3 files changed, 40 insertions, 11 deletions

diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml
index 0b75c64bdc..15c66843a9 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/simplif.ml b/bytecomp/simplif.ml
index e758eed489..264a0800bc 100644
--- a/bytecomp/simplif.ml
+++ b/bytecomp/simplif.ml
@@ -409,20 +409,24 @@ let simplify_lets lam =
   in
   simplif 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 is_tail_native_heuristic _ =
-    true in
-  let call_kind x =
-    if is_tail && ((not !Clflags.native_code) || (is_tail_native_heuristic x)) then
-      Annot.Tail
-    else
-      Annot.Stack in
+  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 ()))
+      Stypes.record (Stypes.An_call (loc, call_kind l))
   | Lfunction (_, _, lam) ->
       emit_tail_infos true lam
   | Llet (_, _, lam, body) ->
@@ -471,7 +475,7 @@ 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 ()))
+      Stypes.record (Stypes.An_call (loc, call_kind (obj :: args)))
   | Levent (lam, _) ->
       emit_tail_infos is_tail lam
   | Lifused (_, lam) ->
@@ -481,7 +485,11 @@ and list_emit_tail_infos_fun f is_tail =
 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
-  emit_tail_infos true res;
+  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 *)