replace method labels by hashes

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

9 files changed, 111 insertions, 262 deletions

diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli
index 763f8fe03a..acbcd6ff8e 100644
--- a/bytecomp/matching.mli
+++ b/bytecomp/matching.mli
@@ -35,3 +35,7 @@ val for_tupled_function:
 exception Cannot_flatten
 
 val flatten_pattern: int -> pattern -> pattern list
+
+val make_test_sequence:
+        lambda option -> primitive -> primitive -> lambda ->
+        (Asttypes.constant * lambda) list -> lambda
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index 81b1fb52ee..68616a4173 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -204,12 +204,9 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =
 
 
 let bind_method tbl public_methods lab id cl_init =
-  if List.mem lab public_methods then
-    Llet(Alias, id, Lvar (meth lab), cl_init)
-  else
-    Llet(StrictOpt, id, Lapply (oo_prim "get_method_label",
-                                [Lvar tbl; transl_label lab]),
-    cl_init)
+  Llet(StrictOpt, id, Lapply (oo_prim "get_method_label",
+                              [Lvar tbl; transl_label lab]),
+       cl_init)
 
 let bind_methods tbl public_methods meths cl_init =
   Meths.fold (bind_method tbl public_methods) meths cl_init
@@ -572,6 +569,7 @@ let transl_class ids cl_id arity pub_meths cl =
           if new_ids = [] then body else
           subst_lambda (subst env body 0 new_ids_meths) body in
         begin try
+          raise Not_found;
           (* Doesn't seem to improve size for bytecode *)
           (* if not !Clflags.native_code then raise Not_found; *)
           builtin_meths arr [self] env env2 (lfunction args body')
@@ -611,9 +609,19 @@ let transl_class ids cl_id arity pub_meths cl =
   and class_init = Ident.create "class_init"
   and env_init = Ident.create "env_init"
   and obj_init = Ident.create "obj_init" in
+  let public_map pub_meths =
+    let meth = Ident.create "meth" in
+    let i = ref 0 in
+    let index m = incr i;
+      (Const_int (Btype.hash_variant m), Lconst(Const_pointer !i)) in
+    Lfunction(Curried, [meth],
+              Matching.make_test_sequence None (Pintcomp Cneq) (Pintcomp Clt)
+                (Lvar meth) (List.map index pub_meths))
+  in
   let ltable table lam =
     Llet(Strict, table,
-         Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
+         Lapply (oo_prim "create_table",
+                 [public_map pub_meths; transl_meth_list pub_meths]), lam)
   and ldirect obj_init =
     Llet(Strict, obj_init, cl_init,
          Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
@@ -630,7 +638,7 @@ let transl_class ids cl_id arity pub_meths cl =
          lam class_init)
   and lbody class_init =
     Lapply (oo_prim "make_class",
-            [transl_meth_list pub_meths; Lvar class_init])
+            [public_map pub_meths;transl_meth_list pub_meths; Lvar class_init])
   and lbody_virt lenvs =
     Lprim(Pmakeblock(0, Immutable),
           [lambda_unit; Lfunction(Curried,[cla], cl_init); lambda_unit; lenvs])
@@ -701,7 +709,7 @@ let transl_class ids cl_id arity pub_meths cl =
               if not concrete then lclass_virt () else
               lclass (
               Lapply (oo_prim "make_class_store",
-                      [transl_meth_list pub_meths;
+                      [public_map pub_meths; transl_meth_list pub_meths;
                        Lvar class_init; Lvar cached]))),
   make_envs (
   if ids = [] then Lapply(lfield cached 0, [lenvs]) else
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 49f4bd8ae7..17007f091a 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -655,12 +655,19 @@ and transl_exp0 e =
         (Lifthenelse(transl_exp cond, event_before body (transl_exp body),
                      staticfail))
   | Texp_send(expr, met) ->
-      let met_id =
+      let self = Ident.create "obj" in
+      let met_index =
         match met with
-          Tmeth_name nm -> Translobj.meth nm
-        | Tmeth_val id  -> id
+          Tmeth_name nm ->
+            Lapply(Lprim(Pfield 0,[Lprim(Pfield 0,[Lvar self])]),
+                   [Translobj.meth nm])
+        | Tmeth_val id  -> Lvar id
       in
-      event_after e (Lsend(Lvar met_id, transl_exp expr, []))
+      event_after e
+        (Llet(Strict, self, transl_exp expr,
+              Lapply(Lprim(Parrayrefu Paddrarray,
+                           [Lprim(Pfield 0,[Lvar self]); met_index]),
+                     [Lvar self])))
   | Texp_new (cl, _) ->
       Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit])
   | Texp_instvar(path_self, path) ->
diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml
index ea449202eb..d46c960d0a 100644
--- a/bytecomp/translobj.ml
+++ b/bytecomp/translobj.ml
@@ -46,6 +46,9 @@ let share c =
 
 let used_methods = ref ([] : (string * Ident.t) list);;
 
+let meth s = Lconst(Const_pointer(Btype.hash_variant s))
+
+(*
 let meth lab =
   try
     List.assoc lab !used_methods
@@ -53,6 +56,7 @@ let meth lab =
     let id = Ident.create lab in
     used_methods := (lab, id)::!used_methods;
     id
+*)
 
 let reset_labels () =
   Hashtbl.clear consts;
diff --git a/bytecomp/translobj.mli b/bytecomp/translobj.mli
index f0a92b3324..fe0ce1ab5e 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 -> Ident.t
+val meth: string -> lambda
 
 val reset_labels: unit -> unit
 val transl_label_init: lambda -> lambda
diff --git a/byterun/interp.c b/byterun/interp.c
index 557ed6f091..3eb9917da2 100644
--- a/byterun/interp.c
+++ b/byterun/interp.c
@@ -1009,14 +1009,34 @@ value interprete(code_t prog, asize_t prog_size)
     
 /* Object-oriented operations */
 
+/*
 #define Lookup(obj, lab) \
   Field (Field (Field (obj, 0), ((lab) >> 16) / sizeof (value)), \
          ((lab) / sizeof (value)) & 0xFF)
+*/
+#define Lookup(obj, lab) Field (Field (obj, 0), Int_val(lab))
 
     Instruct(GETMETHOD):
       accu = Lookup(sp[0], accu);
       Next;
 
+    Instruct(GETMETIND): {
+      /* accu == object, *pc == label */
+      value tags = Field (Field(accu,0), 0);
+      value tag = *pc;
+      pc++;
+      int li = 0, hi = Wosize_val(tags)-1, mi;
+      value low = Field(tags,li), high = Field(tags,hi), mid;
+      while (li < hi) {
+        mi = (li+hi+1) >> 1;
+        mid = Field(tags,mi);
+        if (tag < mid) hi = mi-1;
+        else li = mi;
+      }
+      accu = Field (Field(obj,0), li+1);
+      Next;
+    }
+
 /* Debugging and machine control */
 
     Instruct(STOP):
diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml
index 29e81dc8c0..566d620827 100644
--- a/stdlib/camlinternalOO.ml
+++ b/stdlib/camlinternalOO.ml
@@ -58,181 +58,30 @@ let first_bucket = 0
 let bucket_size = 32                    (* Must be 256 or less *)
 let initial_object_size = 2
 
-(**** Index ****)
-
-type label = int
-
-let label_count = ref 0
-
-let next label =
-  incr label_count;
-  let label = label + step in
-  if label mod (step * bucket_size) = 0 then
-    label + step * (65536 - bucket_size)
-  else
-    label
-
-let decode label =
-  (label / 65536 / step, (label mod (step * bucket_size)) / step)
-
 (**** Items ****)
 
 type item
 
 let dummy_item = (magic () : item)
 
-(**** Buckets ****)
-
-type bucket = item array
-
-let version = ref 0
-
-let set_bucket_version (bucket : bucket) =
-  bucket.(bucket_size) <- (magic !version : item)
-
-let bucket_version bucket =
-  (magic bucket.(bucket_size) : int)
-
-let bucket_list = ref []
-
-let empty_bucket = [| |]
-
-let new_bucket () =
-  let bucket = Array.create (bucket_size + 1) dummy_item in
-  set_bucket_version bucket;
-  bucket_list := bucket :: !bucket_list;
-  bucket
-
-let copy_bucket bucket =
-  let bucket = Array.copy bucket in
-  set_bucket_version bucket;
-  bucket.(bucket_size) <- (magic !version : item);
-  bucket_list := bucket :: !bucket_list;
-  bucket
-
-(**** Make a clean bucket ****)
-
-let new_filled_bucket pos methods =
-  let bucket = new_bucket () in
-  List.iter
-    (fun (lab, met) ->
-       let (buck, elem) = decode lab in
-       if buck = pos then
-         bucket.(elem) <- (magic met : item))
-    (List.rev methods);
-  bucket
-
-(**** Bucket merging ****)
-
-let small_buckets = ref (Array.create 10 [| |])
-let small_bucket_count = ref 0
-
-let insert_bucket bucket =
-  let length = Array.length !small_buckets in
-  if !small_bucket_count >= length then begin
-    let new_array = Array.create (2 * length) [| |] in
-    Array.blit !small_buckets 0 new_array 0 length;
-    small_buckets := new_array
-  end;
-  !small_buckets.(!small_bucket_count) <- bucket;
-  incr small_bucket_count
-
-let remove_bucket n =
-  !small_buckets.(n) <- !small_buckets.(!small_bucket_count - 1);
-  decr small_bucket_count
-
-let bucket_used b =
-  let n = ref 0 in
-  for i = 0 to bucket_size - 1 do
-    if b.(i) != dummy_item then incr n
-  done;
-  !n
-
-let small_bucket b = bucket_used b <= params.bucket_small_size
-
-exception Failed
-
-let rec except e =
-  function
-    [] -> []
-  | e'::l -> if e == e' then l else e'::(except e l)
-
-let merge_buckets b1 b2 =
-  for i = 0 to bucket_size - 1 do
-    if
-      (b2.(i) != dummy_item) && (b1.(i) != dummy_item) && (b2.(i) != b1.(i))
-    then
-      raise Failed
-  done;
-  for i = 0 to bucket_size - 1 do
-    if b2.(i) != dummy_item then
-      b1.(i) <- b2.(i)
-  done;
-  bucket_list := except b2 !bucket_list;
-  b1
-
-let prng = Random.State.make [| 0 |];;
-
-let rec choose bucket i =
-  if (i > 0) && (!small_bucket_count > 0) then begin
-    let n = Random.State.int prng !small_bucket_count in
-    if not (small_bucket !small_buckets.(n)) then begin
-      remove_bucket n; choose bucket i
-    end else
-      try
-        merge_buckets !small_buckets.(n) bucket
-      with Failed ->
-        choose bucket (i - 1)
-  end else begin
-    insert_bucket bucket;
-    bucket
-  end
-
-let compact b =
-  if
-    (b != empty_bucket) && (bucket_version b = !version) && (small_bucket b)
-  then
-    choose b params.retry_count
-  else
-    b
+(**** Types ****)
 
-let compact_buckets buckets =
-  for i = first_bucket to Array.length buckets - 1 do
-    buckets.(i) <- compact buckets.(i)
-  done
+type label = int
+type closure = item
+type obj = t array
+external ret : (obj -> 'a) -> closure = "%identity"
 
 (**** Labels ****)
 
-let first_label = first_bucket * 65536 * step
-
-let last_label = ref first_label
-let methods = Hashtbl.create 101
-
-let new_label () =
-  let label = !last_label in
-  last_label := next !last_label;
-  label
-
-let new_method met =
-  try
-    Hashtbl.find methods met
-  with Not_found ->
-    let label = new_label () in
-    Hashtbl.add methods met label;
-    label
-
-let public_method_label met =
-  try
-    Hashtbl.find methods met
-  with Not_found ->
-    invalid_arg "Oo.public_method_label"
-
-let new_anonymous_method =
-  new_label
-
-(**** Types ****)
-
-type obj = t array
+let public_method_label s =
+  let accu = ref 0 in
+  for i = 0 to String.length s - 1 do
+    accu := 223 * !accu + Char.code s.[i]
+  done;
+  (* reduce to 31 bits *)
+  accu := !accu land (1 lsl 31 - 1);
+  (* make it signed for 64 bits architectures *)
+  if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu
 
 (**** Sparse array ****)
 
@@ -247,7 +96,7 @@ type labs = bool Labs.t
 (* The compiler assumes that the first field of this structure is [size]. *)
 type table =
  { mutable size: int;
-   mutable buckets: bucket array;
+   mutable methods: closure array;
    mutable methods_by_name: meths;
    mutable methods_by_label: labs;
    mutable previous_states:
@@ -258,20 +107,20 @@ type table =
    mutable initializers: (obj -> unit) list }
 
 let dummy_table =
-  { buckets = [| |];
+  { methods = [| |];
     methods_by_name = Meths.empty;
     methods_by_label = Labs.empty;
     previous_states = [];
     hidden_meths = [];
     vars = Vars.empty;
     initializers = [];
-    size = initial_object_size }
+    size = 0 }
 
 let table_count = ref 0
 
-let new_table () =
+let new_table public =
   incr table_count;
-  { buckets = [| |];
+  { methods = [| public |];
     methods_by_name = Meths.empty;
     methods_by_label = Labs.empty;
     previous_states = [];
@@ -281,22 +130,16 @@ let new_table () =
     size = initial_object_size }
 
 let resize array new_size =
-  let old_size = Array.length array.buckets in
+  let old_size = Array.length array.methods in
   if new_size > old_size then begin
-    let new_buck = Array.create new_size empty_bucket in
-    Array.blit array.buckets 0 new_buck 0 old_size;
-    array.buckets <- new_buck
+    let new_buck = Array.create new_size dummy_item in
+    Array.blit array.methods 0 new_buck 0 old_size;
+    array.methods <- new_buck
  end
 
 let put array label element =
-  let (buck, elem) = decode label in
-  resize array (buck + 1);
-  let bucket = ref (array.buckets.(buck)) in
-  if !bucket == empty_bucket then begin
-    bucket := new_bucket ();
-    array.buckets.(buck) <- !bucket
-  end;
-  !bucket.(elem) <- element
+  resize array (label + 1);
+  array.methods.(label) <- element
 
 (**** Classes ****)
 
@@ -306,11 +149,16 @@ let inst_var_count = ref 0
 type t
 type meth = item
 
+let new_method table =
+  let index = Array.length table.methods in
+  resize table (index + 1);
+  index
+
 let get_method_label table name =
   try
     Meths.find name table.methods_by_name
   with Not_found ->
-    let label = new_anonymous_method () in
+    let label = new_method table in
     table.methods_by_name <- Meths.add name label table.methods_by_name;
     table.methods_by_label <- Labs.add label true table.methods_by_label;
     label
@@ -323,9 +171,8 @@ let set_method table label element =
     table.hidden_meths <- (label, element) :: table.hidden_meths
 
 let get_method table label =
-  try List.assoc label table.hidden_meths with Not_found ->
-  let (buck, elem) = decode label in
-  table.buckets.(buck).(elem)
+  try List.assoc label table.hidden_meths
+  with Not_found -> table.methods.(label)
 
 let to_list arr =
   if arr == magic 0 then [] else Array.to_list arr
@@ -406,12 +253,12 @@ let get_variable table name =
 let add_initializer table f =
   table.initializers <- f::table.initializers
 
-let create_table public_methods =
-  let table = new_table () in
+let create_table public_map public_methods =
+  let table = new_table public_map in
   if public_methods != magic 0 then
     Array.iter
       (function met ->
-        let lab = new_method met in
+        let lab = new_method table in
         table.methods_by_name  <- Meths.add met lab table.methods_by_name;
         table.methods_by_label <- Labs.add lab true table.methods_by_label)
       public_methods;
@@ -419,8 +266,6 @@ let create_table public_methods =
 
 let init_class table =
   inst_var_count := !inst_var_count + table.size - 1;
-  if params.compact_table then
-    compact_buckets table.buckets;
   table.initializers <- List.rev table.initializers
 
 let inherits cla vals virt_meths concr_meths (_, super, _, env) top =
@@ -430,16 +275,16 @@ let inherits cla vals virt_meths concr_meths (_, super, _, env) top =
   widen cla;
   init
 
-let make_class pub_meths class_init =
-  let table = create_table pub_meths in
+let make_class pub_map pub_meths class_init =
+  let table = create_table pub_map pub_meths in
   let env_init = class_init table in
   init_class table;
   (env_init (Obj.repr 0), class_init, env_init, Obj.repr 0)
 
 type init_table = { mutable env_init: t; mutable class_init: table -> t }
 
-let make_class_store pub_meths class_init init_table =
-  let table = create_table pub_meths in
+let make_class_store pub_map pub_meths class_init init_table =
+  let table = create_table pub_map pub_meths in
   let env_init = class_init table in
   init_class table;
   init_table.class_init <- class_init;
@@ -451,7 +296,7 @@ let create_object table =
   (* XXX Appel de [obj_block] *)
   let obj = Obj.new_block Obj.object_tag table.size in
   (* XXX Appel de [modify] *)
-  Obj.set_field obj 0 (Obj.repr table.buckets);
+  Obj.set_field obj 0 (Obj.repr table.methods);
   set_id obj last_id;
   (Obj.obj obj)
 
@@ -460,7 +305,7 @@ let create_object_opt obj_0 table =
     (* XXX Appel de [obj_block] *)
     let obj = Obj.new_block Obj.object_tag table.size in
     (* XXX Appel de [modify] *)
-    Obj.set_field obj 0 (Obj.repr table.buckets);
+    Obj.set_field obj 0 (Obj.repr table.methods);
     set_id obj last_id;
     (Obj.obj obj)
   end
@@ -533,9 +378,6 @@ let lookup_tables root keys =
 
 (**** builtin methods ****)
 
-type closure = item
-external ret : (obj -> 'a) -> closure = "%identity"
-
 let get_const x = ret (fun obj -> x)
 let get_var n   = ret (fun obj -> Array.unsafe_get obj n)
 let get_env e n = ret (fun obj -> Obj.field (Array.unsafe_get obj e) n)
@@ -635,35 +477,8 @@ let set_methods table methods =
 (**** Statistics ****)
 
 type stats =
-  { classes: int; labels: int; methods: int; inst_vars: int; buckets: int;
-    distrib : int array; small_bucket_count: int; small_bucket_max: int }
-
-let distrib () =
-  let d = Array.create 32 0 in
-  List.iter
-    (function b ->
-       let n = bucket_used b in
-       d.(n - 1) <- d.(n - 1) + 1)
-    !bucket_list;
-  d
+  { classes: int; methods: int; inst_vars: int; }
 
 let stats () =
-  { classes = !table_count; labels = !label_count;
-    methods = !method_count; inst_vars = !inst_var_count;
-    buckets = List.length !bucket_list; distrib = distrib ();
-    small_bucket_count = !small_bucket_count;
-    small_bucket_max = Array.length !small_buckets  }
-
-let sort_buck lst =
-  List.map snd
-    (Sort.list (fun (n, _) (n', _) -> n <= n')
-       (List.map (function b -> (bucket_used b, b)) lst))
-
-let show_buckets () =
-  List.iter
-    (function b ->
-       for i = 0 to bucket_size - 1 do
-         print_char (if b.(i) == dummy_item then '.' else '*')
-       done;
-       print_newline ())
-    (sort_buck !bucket_list)
+  { classes = !table_count;
+    methods = !method_count; inst_vars = !inst_var_count; }
diff --git a/stdlib/camlinternalOO.mli b/stdlib/camlinternalOO.mli
index 0195d465f5..7fa609918a 100644
--- a/stdlib/camlinternalOO.mli
+++ b/stdlib/camlinternalOO.mli
@@ -17,18 +17,16 @@
     All functions in this module are for system use only, not for the
     casual user. *)
 
-(** {6 Methods} *)
-
-type label
-val new_method : string -> label
-val public_method_label : string -> label
-
 (** {6 Classes} *)
 
+type label
 type table
 type meth
 type t
 type obj
+type closure
+val public_method_label : string -> label
+val new_method : table -> label
 val new_variable : table -> string -> int
 val new_variables : table -> string array -> int
 val get_variable : table -> string -> int
@@ -40,17 +38,17 @@ val narrow : table -> string array -> string array -> string array -> unit
 val widen : table -> unit
 val add_initializer : table -> (obj -> unit) -> unit
 val dummy_table : table
-val create_table : string array -> table
+val create_table : closure -> string array -> table
 val init_class : table -> unit
 val inherits :
     table -> string array -> string array -> string array ->
     (t * (table -> obj -> Obj.t) * t * obj) -> bool -> Obj.t
 val make_class :
-    string array -> (table -> Obj.t -> t) ->
+    closure -> string array -> (table -> Obj.t -> t) ->
     (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t)
 type init_table
 val make_class_store :
-    string array -> (table -> t) -> init_table -> unit
+    closure -> string array -> (table -> t) -> init_table -> unit
 
 (** {6 Objects} *)
 
@@ -70,7 +68,6 @@ val lookup_tables : tables -> table array -> tables
 (** {6 Builtins to reduce code size} *)
 
 open Obj
-type closure
 val get_const : t -> closure
 val get_var : int -> closure
 val get_env : int -> int -> closure
@@ -130,12 +127,6 @@ val params : params
 
 type stats =
   { classes : int; 
-    labels : int; 
     methods : int; 
-    inst_vars : int; 
-    buckets : int;
-    distrib : int array; 
-    small_bucket_count : int; 
-    small_bucket_max : int }
+    inst_vars : int }
 val stats : unit -> stats
-val show_buckets : unit -> unit
diff --git a/stdlib/oo.ml b/stdlib/oo.ml
index e8795d8573..c9ec64ae44 100644
--- a/stdlib/oo.ml
+++ b/stdlib/oo.ml
@@ -15,5 +15,5 @@
 
 let copy = CamlinternalOO.copy
 external id : < .. > -> int = "%field1"
-let new_method = CamlinternalOO.new_method
+let new_method = CamlinternalOO.public_method_label
 let public_method_label = CamlinternalOO.public_method_label