add some code for perfect hash

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

3 files changed, 88 insertions, 23 deletions

diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index b6e7e2e031..56bd9d1b02 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -529,6 +529,23 @@ module M = struct
 end
 open M
 
+let rec hash_size n tags =
+  let arr = String.make n ' ' in
+  let base = -(1 lsl 30) in
+  let ofs = n - base mod n in
+  let umod x = ((x lxor base) mod n + ofs) mod n in
+  try
+    List.iter
+      (fun x ->
+        let y = umod x in
+        if String.unsafe_get arr y = ' ' then String.unsafe_set arr y '1'
+        else raise Not_found)
+      tags;
+    n
+  with Not_found -> hash_size (n+1) tags
+
+let perfect_hash_size tags =
+  hash_size (List.length tags) tags
 
 (*
    Traduction d'une classe.
@@ -623,6 +640,11 @@ let transl_class ids cl_id arity pub_meths cl =
     List.sort
       (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s'))
       pub_meths in
+  let hash_size =
+    if not !Clflags.native_code then lambda_unit else
+    let size = perfect_hash_size (List.map Btype.hash_variant pub_meths) in
+    Lconst(Const_base(Const_int size))
+  in
   (*
   let public_map () =
     if not !Clflags.native_code then lambda_unit else
@@ -637,7 +659,8 @@ let transl_class ids cl_id arity pub_meths cl =
   *)
   let ltable table lam =
     Llet(Strict, table,
-         Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
+         Lapply (oo_prim "create_table",
+                 [hash_size; transl_meth_list pub_meths]), lam)
   and ldirect obj_init =
     Llet(Strict, obj_init, cl_init,
          Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
@@ -654,7 +677,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])
+            [hash_size; 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])
@@ -725,7 +748,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;
+                      [hash_size; transl_meth_list pub_meths;
                        Lvar class_init; Lvar cached]))),
   make_envs (
   if ids = [] then Lapply(lfield cached 0, [lenvs]) else
diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml
index b1c23822e1..9bef8118c8 100644
--- a/stdlib/camlinternalOO.ml
+++ b/stdlib/camlinternalOO.ml
@@ -94,10 +94,12 @@ type meths = label Meths.t
 module Labs = Map.Make(struct type t = label let compare = compare end)
 type labs = bool Labs.t
 
+
 (* The compiler assumes that the first field of this structure is [size]. *)
 type table =
  { mutable size: int;
    mutable methods: closure array;
+   mutable next_label: int;
    mutable methods_by_name: meths;
    mutable methods_by_label: labs;
    mutable previous_states:
@@ -109,6 +111,7 @@ type table =
 
 let dummy_table =
   { methods = [| |];
+    next_label = 0;
     methods_by_name = Meths.empty;
     methods_by_label = Labs.empty;
     previous_states = [];
@@ -119,9 +122,10 @@ let dummy_table =
 
 let table_count = ref 0
 
-let new_table pub_labels =
+let new_table meths next =
   incr table_count;
-  { methods = [| magic (pub_labels : tag array) |];
+  { methods = meths;
+    next_label = next;
     methods_by_name = Meths.empty;
     methods_by_label = Labs.empty;
     previous_states = [];
@@ -151,8 +155,13 @@ type t
 type meth = item
 
 let new_method table =
-  let index = Array.length table.methods in
-  resize table (index + 1);
+  let len = Array.length table.methods in
+  while table.next_label < len &&
+    table.methods.(table.next_label) <> dummy_item
+  do table.next_label <- table.next_label + 1 done;
+  let index = table.next_label in
+  table.next_label <- table.next_label + 1;
+  resize table (index+1);
   index
 
 let get_method_label table name =
@@ -260,16 +269,49 @@ let get_variables table names =
 let add_initializer table f =
   table.initializers <- f::table.initializers
 
+(*
 let create_table public_methods =
   if public_methods == magic 0 then new_table [||] else
-  let public_methods = Array.copy public_methods in
-  Array.sort
-    (fun s s' -> compare (public_method_label s) (public_method_label s'))
-    public_methods;
   let table = new_table (Array.map public_method_label public_methods) in
   Array.iter
     (function met ->
       let lab = new_method table in
+      table.methods.(lab) <- magic 1;
+      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;
+  table
+*)
+
+let compute_labels n tags =
+  if n = 0 then Array.mapi (fun i _ -> i+1) tags else
+  let base = -(1 lsl 30) in
+  let ofs = n - base mod n in
+  let umod (x : tag) = (((magic x : int) lxor base) mod n + ofs) mod n in
+  Array.map umod tags
+
+let init_hash n labels =
+  let arr = Array.create (n+1) 0 and last = ref 0 in
+  arr.(0) <- n;
+  Array.iter
+    (fun lab ->
+      last := max !last lab;
+      Array.unsafe_set arr lab 1)
+    labels;
+  if !last = n then arr else Array.sub arr 0 (!last+1)
+
+let create_table n public_methods =
+  if public_methods == magic 0 then new_table [||] 0 else
+  (* [public_methods] must be in ascending order for bytecode *)
+  let tags = Array.map public_method_label public_methods in
+  let labels = compute_labels n tags in
+  let table =
+    if n = 0 then new_table [|magic tags|] (Array.length tags + 1) else
+    new_table (magic (init_hash n labels : int array)) 1
+  in
+  Array.iteri
+    (fun i met ->
+      let lab = labels.(i) 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;
@@ -286,16 +328,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 hash_size pub_meths class_init =
+  let table = create_table hash_size 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 hash_size pub_meths class_init init_table =
+  let table = create_table hash_size pub_meths in
   let env_init = class_init table in
   init_class table;
   init_table.class_init <- class_init;
@@ -353,13 +395,13 @@ let send obj lab =
 external send : obj -> tag -> 'a = "%send"
 external sendself : obj -> label -> 'a = "%sendself"
 external get_public_method : obj -> tag -> closure
-    = "get_public_method" "noalloc"
+    = "oo_get_public_method" "noalloc"
 
 (**** table collection access ****)
 
-type tables = Empty | Cons of table * tables * tables
+type tables = Empty | Cons of closure * tables * tables
 type mut_tables =
-    {key: table; mutable data: tables; mutable next: tables}
+    {key: closure; mutable data: tables; mutable next: tables}
 external mut : tables -> mut_tables = "%identity"
 
 let build_path n keys tables =
diff --git a/stdlib/camlinternalOO.mli b/stdlib/camlinternalOO.mli
index 9d906dd2da..3377ec3044 100644
--- a/stdlib/camlinternalOO.mli
+++ b/stdlib/camlinternalOO.mli
@@ -41,17 +41,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 : int -> 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) ->
+    int -> 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
+    int -> string array -> (table -> t) -> init_table -> unit
 
 (** {6 Objects} *)
 
@@ -64,12 +64,12 @@ val create_object_and_run_initializers : obj -> table -> obj
 external send : obj -> tag -> t = "%send"
 external sendself : obj -> label -> t = "%sendself"
 external get_public_method : obj -> tag -> closure
-    = "get_public_method" "noalloc"
+    = "oo_get_public_method" "noalloc"
 
 (** {6 Table cache} *)
 
 type tables
-val lookup_tables : tables -> table array -> tables
+val lookup_tables : tables -> closure array -> tables
 
 (** {6 Builtins to reduce code size} *)