From b86942ab51344e9bced6701e644f13202cead3d0 Mon Sep 17 00:00:00 2001 From: Jacques Garrigue Date: Tue, 2 Dec 2003 02:12:58 +0000 Subject: add some code for perfect hash git-svn-id: http://caml.inria.fr/svn/ocaml/branches/newoolab@5993 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- bytecomp/translclass.ml | 29 +++++++++++++++++-- stdlib/camlinternalOO.ml | 72 +++++++++++++++++++++++++++++++++++++---------- stdlib/camlinternalOO.mli | 10 +++---- 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} *) -- cgit v1.2.1