change really key to tags + move code to cmmgen

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

6 files changed, 64 insertions, 55 deletions

diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml
index f23bc93e41..a45f4a44a6 100644
--- a/asmcomp/closure.ml
+++ b/asmcomp/closure.ml
@@ -457,36 +457,10 @@ let rec close fenv cenv = function
       | ((ufunct, _), uargs) ->
           (Ugeneric_apply(ufunct, uargs), Value_unknown)
       end
-  | Lsend(Self, met, obj, args) ->
+  | Lsend(kind, met, obj, args) ->
       let (umet, _) = close fenv cenv met in
       let (uobj, _) = close fenv cenv obj in
-      (Usend(Self, umet, uobj, close_list fenv cenv args), Value_unknown)
-  | Lsend(Public, met, obj, args) ->
-      let self = Ident.create "obj" in
-      let prim kind arity =
-        {prim_name = "oo_"^kind^"_public_method"; prim_arity = arity;
-         prim_alloc = false; prim_native_name = ""; prim_native_float = false}
-      in
-      let met, args =
-        match args with
-          Lprim(Pfield n, [Lvar cache]) :: args
-          when Ident.name cache = "*cache*" ->
-            let imeths = Ident.create "meths"
-            and icache = Ident.create "cache" in
-            (Llet(Alias, imeths, Lprim(Pfield 0, [Lvar self]),
-             Llet(Alias, icache, Lvar cache,
-                  let cache = Lvar icache and meths = Lvar imeths in
-                  Lifthenelse(
-                  Lprim(Pintcomp Cneq, [Lprim(Pfield n, [cache]); meths]),
-                  Lprim(Pccall (prim "cache" 4),
-                        [meths; met; cache; Lconst(Const_pointer n)]),
-                  Lprim(Parrayrefu Paddrarray,
-                        [meths; Lprim(Pfield (n+1), [cache])])))),
-             args)
-        | _ ->
-            (Lprim (Pccall (prim "get" 2), [Lvar self; met]), args)
-      in
-      close fenv cenv (Llet(Alias, self, obj, Lapply(met, Lvar self :: args)))
+      (Usend(kind, umet, uobj, close_list fenv cenv args), Value_unknown)
   | Llet(str, id, lam, body) ->
       let (ulam, alam) = close_named fenv cenv id lam in
       begin match (str, alam) with
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index 2b21ef09b1..e63059a924 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -312,8 +312,25 @@ let string_length exp =
 
 (* Message sending *)
 
-let lookup_label kind obj lab =
-  if kind = Public then assert false else
+let lookup_tag_cache obj tag cache n =
+  bind "tag" tag (fun tag -> bind "cache" cache (fun cache ->
+    let cache n =
+      if n = 0 then cache else Cop(Cadda, [cache; Cconst_int (n * size_addr)])
+    in
+    let meths = Ident.create "meths" and tags = Ident.create "tags" in
+    Clet(meths, Cop(Cload Word, [obj]),
+    Clet(tags, Cop(Cload Word, [Cvar meths]),
+    Cifthenelse(Cop(Ccmpa Cne, [Cop(Cload Word, [cache n]); Cvar tags]),
+		Cop(Cextcall("oo_cache_public_method", typ_addr, false),
+		    [Cvar meths; tag; cache n]),
+		addr_array_ref (Cvar meths) (Cop(Cload Word,[cache (n+1)])))
+	))))
+
+let lookup_tag obj tag =
+  bind "tag" tag (fun tag ->
+    Cop(Cextcall("oo_get_public_method", typ_addr, false), [obj; tag]))
+
+let lookup_label obj lab =
   bind "lab" lab (fun lab ->
     let table = Cop (Cload Word, [obj]) in
     addr_array_ref table lab)
@@ -802,17 +819,23 @@ let rec transl = function
       let cargs = Cconst_symbol(apply_function arity) ::
         List.map transl (args @ [clos]) in
       Cop(Capply typ_addr, cargs)
-  | Usend(kind, met, obj, []) ->
-      bind "obj" (transl obj) (fun obj ->
-        bind "met" (lookup_label kind obj (transl met)) (fun clos ->
-          Cop(Capply typ_addr, [get_field clos 0; obj; clos])))
   | Usend(kind, met, obj, args) ->
-      let arity = List.length args + 1 in
+      let call_met obj args clos =
+	if args = [] then Cop(Capply typ_addr,[get_field clos 0;obj;clos]) else
+	let arity = List.length args + 1 in
+        let cargs = Cconst_symbol(apply_function arity) :: obj ::
+	  (List.map transl args) @ [clos] in
+        Cop(Capply typ_addr, cargs)
+      in
       bind "obj" (transl obj) (fun obj ->
-        bind "met" (lookup_label kind obj (transl met)) (fun clos ->
-          let cargs = Cconst_symbol(apply_function arity) ::
-            obj :: (List.map transl args) @ [clos] in
-          Cop(Capply typ_addr, cargs)))
+	let met, args =
+	  match kind, args with
+	    Self, args -> lookup_label obj (transl met), args
+	  | Cached, Uprim(Pfield n, [cache]) :: args ->
+	      lookup_tag_cache obj (transl met) (transl cache) n, args
+	  | _ -> lookup_tag obj (transl met), args
+	in
+        bind "met" met (call_met obj args))
   | Ulet(id, exp, body) ->
       begin match is_unboxed_number exp with
         No_unboxing ->
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index 72724eb48c..7f537ddf2b 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -115,7 +115,7 @@ type function_kind = Curried | Tupled
 
 type let_kind = Strict | Alias | StrictOpt | Variable
 
-type meth_kind = Self | Public
+type meth_kind = Self | Public | Cached
 
 type shared_code = (int * int) list
 
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index 809ba5bad0..2c7c56e01e 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -124,7 +124,7 @@ type let_kind = Strict | Alias | StrictOpt | Variable
       we can discard e if x does not appear in e'
     Variable: the variable x is assigned later in e' *)
 
-type meth_kind = Self | Public
+type meth_kind = Self | Public | Cached
 
 type shared_code = (int * int) list     (* stack size -> code label *)
 
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 7434b75259..c380ca906d 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -659,21 +659,14 @@ and transl_exp0 e =
         (Lifthenelse(transl_exp cond, event_before body (transl_exp body),
                      staticfail))
   | Texp_send(expr, met) ->
-      (*
-      let (kind, met) =
-        match met with
-          Tmeth_name nm -> (Public, Translobj.meth nm)
-        | Tmeth_val id  -> (Self, Lvar id)
-      in
-      event_after e (Lsend (kind, met, transl_exp expr, []))
-      *)
       let obj = transl_exp expr in
       let lam =
         match met with 
           Tmeth_val id -> Lsend (Self, Lvar id, obj, [])
         | Tmeth_name nm ->
             let (tag, cache) = Translobj.meth nm in
-            Lsend (Public, tag, obj, cache)
+	    let kind = if cache = [] then Public else Cached in
+            Lsend (kind, tag, obj, cache)
       in
       event_after e lam
   | Texp_new (cl, _) ->
diff --git a/byterun/obj.c b/byterun/obj.c
index 5202cd2005..e84ba5f2bd 100644
--- a/byterun/obj.c
+++ b/byterun/obj.c
@@ -195,10 +195,8 @@ CAMLprim value oo_get_public_method (value obj, value tag)
   return Field (meths, li+1);
 }
 
-CAMLprim value oo_cache_public_method (value meths, value tag,
-                                       value cache, value index)
+CAMLprim value oo_cache_public_method (value meths, value tag, value *cache)
 {
-  value n = Int_val(index);
   value tags = Field (meths, 0);
   value met;
   int li = 0, hi = Wosize_val(tags)-1, mi;
@@ -207,8 +205,29 @@ CAMLprim value oo_cache_public_method (value meths, value tag,
     if (tag < Field(tags,mi)) hi = mi-1;
     else li = mi;
   }
-  modify (&Field(cache, n), meths);
+  // cache[0] = tags;
+  modify(cache, tags);
   li++;
-  Field(cache, n+1) = Val_int(li);
+  cache[1] = Val_int(li);
   return Field(meths, li);
 }
+
+CAMLprim value oo_cache_public_method2 (value obj, value tag, value *cache)
+{
+  value meths = Field (obj, 0);
+  value tags = Field (meths, 0);
+  if (tags == cache[0]) return Field(meths, Int_val(cache[1]));
+  {
+    value met;
+    int li = 0, hi = Wosize_val(tags)-1, mi;
+    while (li < hi) {
+      mi = (li+hi+1) >> 1;
+      if (tag < Field(tags,mi)) hi = mi-1;
+      else li = mi;
+    }
+    cache[0] = tags;
+    li++;
+    cache[1] = Val_int(li);
+    return Field(meths, li);
+  }
+}