summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJacques Garrigue <garrigue at math.nagoya-u.ac.jp>2003-12-02 02:12:58 +0000
committerJacques Garrigue <garrigue at math.nagoya-u.ac.jp>2003-12-02 02:12:58 +0000
commitb86942ab51344e9bced6701e644f13202cead3d0 (patch)
treeb9db359fa36083e504d1e13c8b89d991da97a7d2
parent7a399d7230d4ec4ddc0b61d1a3d73e07c06c1386 (diff)
downloadocaml-b86942ab51344e9bced6701e644f13202cead3d0.tar.gz
add some code for perfect hash
git-svn-id: http://caml.inria.fr/svn/ocaml/branches/newoolab@5993 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
-rw-r--r--bytecomp/translclass.ml29
-rw-r--r--stdlib/camlinternalOO.ml72
-rw-r--r--stdlib/camlinternalOO.mli10
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} *)