clever cache

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/newoolab@6095 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

3 files changed, 30 insertions, 6 deletions

diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index c380ca906d..a0f765ed93 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -664,7 +664,7 @@ and transl_exp0 e =
         match met with 
           Tmeth_val id -> Lsend (Self, Lvar id, obj, [])
         | Tmeth_name nm ->
-            let (tag, cache) = Translobj.meth nm in
+            let (tag, cache) = Translobj.meth obj nm in
 	    let kind = if cache = [] then Public else Cached in
             Lsend (kind, tag, obj, cache)
       in
diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml
index acbc921c53..8db6729be0 100644
--- a/bytecomp/translobj.ml
+++ b/bytecomp/translobj.ml
@@ -48,19 +48,43 @@ let share c =
 let cache_required = ref false
 let method_cache = ref lambda_unit
 let method_count = ref 0
+let method_table = ref []
 
 let meth_tag s = Lconst(Const_base(Const_int(Btype.hash_variant s)))
 
-let meth lab =
-  let tag = meth_tag lab in
-  if not (!cache_required && !Clflags.native_code) then (tag, []) else
+let next_cache tag =
   let n = !method_count in
   incr method_count;
   (tag, [Lprim(Pfield n, [!method_cache])])
 
+let rec is_path = function
+    Lvar _ | Lprim (Pgetglobal _, []) | Lconst _ -> true
+  | Lprim (Pfield _, [lam]) -> is_path lam
+  | Lprim ((Parrayrefu _ | Parrayrefs _), [lam1; lam2]) ->
+      is_path lam1 && is_path lam2
+  | _ -> false
+
+let meth obj lab =
+  let tag = meth_tag lab in
+  if not (!cache_required && !Clflags.native_code) then (tag, []) else
+  if not (is_path obj) then next_cache tag else
+  try
+    let r = List.assoc obj !method_table in
+    try
+      (tag, List.assoc tag !r)
+    with Not_found ->
+      let p = next_cache tag in
+      r := p :: !r;
+      p
+  with Not_found ->
+    let p = next_cache tag in
+    method_table := (obj, ref [p]) :: !method_table;
+    p
+
 let reset_labels () =
   Hashtbl.clear consts;
-  method_count := 0
+  method_count := 0;
+  method_table := []
 
 (* Insert labels *)
 
diff --git a/bytecomp/translobj.mli b/bytecomp/translobj.mli
index 6b3826984d..d6e432da5c 100644
--- a/bytecomp/translobj.mli
+++ b/bytecomp/translobj.mli
@@ -17,7 +17,7 @@ open Lambda
 val oo_prim: string -> lambda
 
 val share: structured_constant -> lambda
-val meth: string -> lambda * lambda list
+val meth: lambda -> string -> lambda * lambda list
 
 val reset_labels: unit -> unit
 val transl_label_init: lambda -> lambda