From eff7a243909ab12328da25bcb02bbdeafccf245d Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 6 Jun 2018 22:39:45 +0700 Subject: [PATCH] Add an intern option to control ordering There are 2 ways to order interned strings: * Fast but "random" * Slow but respects the original order Signed-off-by: Rudi Grinberg --- src/package.ml | 1 + src/stdune/interned.ml | 36 ++++++++++++++++++++++-------------- src/stdune/interned.mli | 3 +++ src/stdune/path.ml | 2 ++ src/sub_system_name.ml | 1 + src/variant.ml | 1 + 6 files changed, 30 insertions(+), 14 deletions(-) diff --git a/src/package.ml b/src/package.ml index c6350f03..d1cb330d 100644 --- a/src/package.ml +++ b/src/package.ml @@ -4,6 +4,7 @@ module Name = struct include Interned.Make(struct let initial_size = 16 let resize_policy = Interned.Conservative + let order = Interned.Natural end)() let of_string = make diff --git a/src/stdune/interned.ml b/src/stdune/interned.ml index b8f9b46e..96716e1d 100644 --- a/src/stdune/interned.ml +++ b/src/stdune/interned.ml @@ -22,24 +22,26 @@ end type resize_policy = Conservative | Greedy +type order = Natural | Fast + let new_size ~next ~size = function | Conservative -> let increment_size = 512 in (next land (lnot (increment_size - 1))) + (increment_size * 2) | Greedy -> size * 2 -module Make(R : sig - val resize_policy : resize_policy - val initial_size : int - end)() +module type Settings = sig + val initial_size : int + val resize_policy : resize_policy + val order : order +end + +module Make(R : Settings)() = struct - type t = int let ids = Hashtbl.create 1024 let next = ref 0 - let compare = Int.compare - module Table = struct type 'a t = { default_value : 'a @@ -86,10 +88,21 @@ module Make(R : sig let to_string t = Table.get names t + module T = struct + type nonrec t = int + + let compare = + match R.order with + | Fast -> Int.compare + | Natural -> fun x y -> String.compare (to_string x) (to_string y) + end + + include T + let pp fmt t = Format.fprintf fmt "%S" (to_string t) module Set = struct - include Int.Set + include Set.Make(T) let make l = List.fold_left l ~init:empty ~f:(fun acc s -> add acc (make s)) @@ -97,12 +110,7 @@ module Make(R : sig let pp fmt (t : t) = Fmt.ocaml_list pp fmt (to_list t) end - module Map = Int.Map -end - -module type Settings = sig - val initial_size : int - val resize_policy : resize_policy + module Map = Map.Make(T) end module No_interning(R : Settings)() = struct diff --git a/src/stdune/interned.mli b/src/stdune/interned.mli index 52d74905..acfe25ac 100644 --- a/src/stdune/interned.mli +++ b/src/stdune/interned.mli @@ -36,9 +36,12 @@ end type resize_policy = Conservative | Greedy +type order = Natural | Fast + module type Settings = sig val initial_size : int val resize_policy : resize_policy + val order : order end module Make(R : Settings)() : S diff --git a/src/stdune/path.ml b/src/stdune/path.ml index c806c749..e0c7681d 100644 --- a/src/stdune/path.ml +++ b/src/stdune/path.ml @@ -51,6 +51,7 @@ end = struct include Interned.No_interning(struct let initial_size = 512 let resize_policy = Interned.Greedy + let order = Interned.Natural end)() let compare_val x y = String.compare (to_string x) (to_string y) @@ -157,6 +158,7 @@ end = struct include Interned.No_interning(struct let initial_size = 512 let resize_policy = Interned.Greedy + let order = Interned.Natural end)() let compare_val x y = String.compare (to_string x) (to_string y) diff --git a/src/sub_system_name.ml b/src/sub_system_name.ml index a18a607a..bcd2411a 100644 --- a/src/sub_system_name.ml +++ b/src/sub_system_name.ml @@ -3,4 +3,5 @@ open Stdune include Interned.Make(struct let initial_size = 16 let resize_policy = Interned.Conservative + let order = Interned.Natural end)() diff --git a/src/variant.ml b/src/variant.ml index ed48c27b..f1968d34 100644 --- a/src/variant.ml +++ b/src/variant.ml @@ -3,6 +3,7 @@ open Stdune include Interned.Make(struct let initial_size = 256 let resize_policy = Interned.Conservative + let order = Interned.Fast end)() let ppx_driver = make "ppx_driver"