diff --git a/src/configurator/v1.ml b/src/configurator/v1.ml index d96e27ec..0f38eee2 100644 --- a/src/configurator/v1.ml +++ b/src/configurator/v1.ml @@ -7,8 +7,6 @@ let ( ^/ ) = Filename.concat exception Fatal_error of string -module Int_map = Stdune.Map.Make(Stdune.Int) - let die fmt = Printf.ksprintf (fun s -> raise (Fatal_error s); @@ -363,12 +361,12 @@ const char *s%i = "BEGIN-%i-false-END"; let extract_values obj_file vars = let values = Io.with_lexbuf_from_file obj_file ~f:(Extract_obj.extract []) - |> Int_map.of_list_exn + |> Int.Map.of_list_exn in List.mapi vars ~f:(fun i (name, t) -> let value = let raw_val = - match Int_map.find values i with + match Int.Map.find values i with | None -> die "Unable to get value for %s" name | Some v -> v in match t with diff --git a/src/fiber/fiber.ml b/src/fiber/fiber.ml index 10fd3252..424a539a 100644 --- a/src/fiber/fiber.ml +++ b/src/fiber/fiber.ml @@ -45,8 +45,6 @@ module Binding = struct type t = T : 'a Var0.t * 'a -> t end -module Int_map = Map.Make(Int) - module Execution_context : sig type t @@ -68,14 +66,14 @@ module Execution_context : sig -> on_error:(exn -> unit) -> t - val vars : t -> Binding.t Int_map.t - val set_vars : t -> Binding.t Int_map.t -> t + val vars : t -> Binding.t Int.Map.t + val set_vars : t -> Binding.t Int.Map.t -> t end = struct type t = { on_error : exn -> unit (* This callback must never raise *) ; fibers : int ref (* Number of fibers running in this execution context *) - ; vars : Binding.t Int_map.t + ; vars : Binding.t Int.Map.t ; on_release : unit -> unit } @@ -85,7 +83,7 @@ end = struct let create_initial () = { on_error = reraise ; fibers = ref 1 - ; vars = Int_map.empty + ; vars = Int.Map.empty ; on_release = ignore } @@ -274,14 +272,14 @@ module Var = struct include Var0 let find ctx var = - match Int_map.find (EC.vars ctx) (id var) with + match Int.Map.find (EC.vars ctx) (id var) with | None -> None | Some (Binding.T (var', v)) -> let eq = eq var' var in Some (Eq.cast eq v) let find_exn ctx var = - match Int_map.find (EC.vars ctx) (id var) with + match Int.Map.find (EC.vars ctx) (id var) with | None -> failwith "Fiber.Var.find_exn" | Some (Binding.T (var', v)) -> let eq = eq var' var in @@ -293,7 +291,7 @@ module Var = struct let set (type a) (var : a t) x fiber ctx k = let (module M) = var in let data = Binding.T (var, x) in - let ctx = EC.set_vars ctx (Int_map.add (EC.vars ctx) M.id data) in + let ctx = EC.set_vars ctx (Int.Map.add (EC.vars ctx) M.id data) in fiber ctx k end diff --git a/src/import.ml b/src/import.ml index ca2d0407..2972d36d 100644 --- a/src/import.ml +++ b/src/import.ml @@ -18,9 +18,6 @@ module String_map = struct ) fmt (to_list t) end -module Int_set = Set.Make(Int) -module Int_map = Map.Make(Int) - module Sys = struct include Sys @@ -99,62 +96,6 @@ module No_io = struct module Io = struct end end -module Fmt = struct - (* CR-someday diml: we should define a GADT for this: - - {[ - type 'a t = - | Int : int t - | Box : ... - | Colored : ... - ]} - - This way we could separate the creation of messages from the - actual rendering. - *) - type 'a t = Format.formatter -> 'a -> unit - - let kstrf f fmt = - let buf = Buffer.create 17 in - let f fmt = Format.pp_print_flush fmt () ; f (Buffer.contents buf) in - Format.kfprintf f (Format.formatter_of_buffer buf) fmt - - let failwith fmt = kstrf failwith fmt - - let list = Format.pp_print_list - let string s ppf = Format.pp_print_string ppf s - - let nl = Format.pp_print_newline - - let prefix f g ppf x = f ppf; g ppf x - - let ocaml_list pp fmt = function - | [] -> Format.pp_print_string fmt "[]" - | l -> - Format.fprintf fmt "@[[ %a@ ]@]" - (list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@,; ") - pp) l - - let quoted fmt = Format.fprintf fmt "%S" - - let const - : 'a t -> 'a -> unit t - = fun pp a' fmt () -> pp fmt a' - - let record fmt = function - | [] -> Format.pp_print_string fmt "{}" - | xs -> - let pp fmt (field, pp) = - Format.fprintf fmt "@[%s@ =@ %a@]" - field pp () in - let pp_sep fmt () = Format.fprintf fmt "@,; " in - Format.fprintf fmt "@[{ %a@ }@]" - (Format.pp_print_list ~pp_sep pp) xs - - let tuple ppfa ppfb fmt (a, b) = - Format.fprintf fmt "@[(%a, %a)@]" ppfa a ppfb b -end - (* This is ugly *) let printer = ref (Printf.eprintf "%s%!") let print_to_console s = !printer s diff --git a/src/lib.ml b/src/lib.ml index 22dfb567..18ce8b8b 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -436,12 +436,12 @@ module L = struct match l with | [] -> acc | x :: l -> - if Int_set.mem seen x.unique_id then + if Int.Set.mem seen x.unique_id then loop acc l seen else - loop (x :: acc) l (Int_set.add seen x.unique_id) + loop (x :: acc) l (Int.Set.add seen x.unique_id) in - loop [] l Int_set.empty + loop [] l Int.Set.empty end (* +-----------------------------------------------------------------+ @@ -523,12 +523,12 @@ let gen_unique_id = module Dep_stack = struct type t = { stack : Id.t list - ; seen : Int_set.t + ; seen : Int.Set.t } let empty = { stack = [] - ; seen = Int_set.empty + ; seen = Int.Set.empty } let to_required_by t ~stop_at = @@ -545,7 +545,7 @@ module Dep_stack = struct loop [] t.stack let dependency_cycle t (last : Id.t) = - assert (Int_set.mem t.seen last.unique_id); + assert (Int.Set.mem t.seen last.unique_id); let rec build_loop acc stack = match stack with | [] -> assert false @@ -564,15 +564,15 @@ module Dep_stack = struct let init = { Id. unique_id; name; path } in (init, { stack = init :: t.stack - ; seen = Int_set.add t.seen unique_id + ; seen = Int.Set.add t.seen unique_id }) let push t (x : Id.t) : (_, _) result = - if Int_set.mem t.seen x.unique_id then + if Int.Set.mem t.seen x.unique_id then Error (dependency_cycle t x) else Ok { stack = x :: t.stack - ; seen = Int_set.add t.seen x.unique_id + ; seen = Int.Set.add t.seen x.unique_id } end diff --git a/src/package.ml b/src/package.ml index 409fe9be..1b2d1577 100644 --- a/src/package.ml +++ b/src/package.ml @@ -1,7 +1,10 @@ open Stdune module Name = struct - include Interned.Make() + include Interned.Make(struct + let initial_size = 16 + let resize_policy = Interned.Conservative + end) let of_string = make diff --git a/src/stdune/fmt.ml b/src/stdune/fmt.ml new file mode 100644 index 00000000..a0d26090 --- /dev/null +++ b/src/stdune/fmt.ml @@ -0,0 +1,54 @@ + +(* CR-someday diml: we should define a GADT for this: + + {[ + type 'a t = + | Int : int t + | Box : ... + | Colored : ... + ]} + + This way we could separate the creation of messages from the + actual rendering. +*) +type 'a t = Format.formatter -> 'a -> unit + +let kstrf f fmt = + let buf = Buffer.create 17 in + let f fmt = Format.pp_print_flush fmt () ; f (Buffer.contents buf) in + Format.kfprintf f (Format.formatter_of_buffer buf) fmt + +let failwith fmt = kstrf failwith fmt + +let list = Format.pp_print_list +let string s ppf = Format.pp_print_string ppf s + +let nl = Format.pp_print_newline + +let prefix f g ppf x = f ppf; g ppf x + +let ocaml_list pp fmt = function + | [] -> Format.pp_print_string fmt "[]" + | l -> + Format.fprintf fmt "@[[ %a@ ]@]" + (list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@,; ") + pp) l + +let quoted fmt = Format.fprintf fmt "%S" + +let const + : 'a t -> 'a -> unit t + = fun pp a' fmt () -> pp fmt a' + +let record fmt = function + | [] -> Format.pp_print_string fmt "{}" + | xs -> + let pp fmt (field, pp) = + Format.fprintf fmt "@[%s@ =@ %a@]" + field pp () in + let pp_sep fmt () = Format.fprintf fmt "@,; " in + Format.fprintf fmt "@[{ %a@ }@]" + (Format.pp_print_list ~pp_sep pp) xs + +let tuple ppfa ppfb fmt (a, b) = + Format.fprintf fmt "@[(%a, %a)@]" ppfa a ppfb b diff --git a/src/stdune/fmt.mli b/src/stdune/fmt.mli new file mode 100644 index 00000000..8681035e --- /dev/null +++ b/src/stdune/fmt.mli @@ -0,0 +1,24 @@ +type 'a t = Format.formatter -> 'a -> unit + +val list : ?pp_sep:unit t -> 'a t -> 'a list t + +val failwith : ('a, Format.formatter, unit, 'b) format4 -> 'a + +val string : string -> Format.formatter -> unit + +val prefix + : (Format.formatter -> unit) + -> (Format.formatter -> 'b -> 'c) + -> (Format.formatter -> 'b -> 'c) + +val ocaml_list : 'a t -> 'a list t + +val quoted : string t + +val const : 'a t -> 'a -> unit t + +val record : (string * unit t) list t + +val tuple : 'a t -> 'b t -> ('a * 'b) t + +val nl : unit t diff --git a/src/stdune/int.ml b/src/stdune/int.ml index 5668aa89..c11dc3da 100644 --- a/src/stdune/int.ml +++ b/src/stdune/int.ml @@ -1,8 +1,15 @@ -type t = int -let compare (a : int) b : Ordering.t = - if a < b then - Lt - else if a = b then - Eq - else - Gt +module T = struct + type t = int + let compare (a : int) b : Ordering.t = + if a < b then + Lt + else if a = b then + Eq + else + Gt +end + +include T + +module Set = Set.Make(T) +module Map = Map.Make(T) diff --git a/src/stdune/int.mli b/src/stdune/int.mli index 951b188c..e9ff5063 100644 --- a/src/stdune/int.mli +++ b/src/stdune/int.mli @@ -1,2 +1,5 @@ type t = int val compare : t -> t -> Ordering.t + +module Set : Set.S with type elt = t +module Map : Map.S with type key = t diff --git a/src/interned.ml b/src/stdune/interned.ml similarity index 75% rename from src/interned.ml rename to src/stdune/interned.ml index ac663573..e3cfc92f 100644 --- a/src/interned.ml +++ b/src/stdune/interned.ml @@ -1,5 +1,3 @@ -open Import - module type S = sig type t val compare : t -> t -> Ordering.t @@ -22,12 +20,26 @@ module type S = sig end with type key := t end -module Make() = struct - include Int +type resize_policy = Conservative | Greedy + +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) += 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 @@ -36,12 +48,12 @@ module Make() = struct let create ~default_value = { default_value - ; data = [||] + ; data = Array.make R.initial_size default_value } let resize t = - let increment_size = 512 in - let n = (!next land (lnot (increment_size - 1))) + (increment_size * 2) in + let n = + new_size ~next:!next ~size:(Array.length t.data) R.resize_policy in let old_data = t.data in let new_data = Array.make n t.default_value in t.data <- new_data; @@ -77,7 +89,7 @@ module Make() = struct let pp fmt t = Format.fprintf fmt "%S" (to_string t) module Set = struct - include Int_set + include Int.Set let make l = List.fold_left l ~init:empty ~f:(fun acc s -> add acc (make s)) @@ -85,5 +97,5 @@ module Make() = struct let pp fmt (t : t) = Fmt.ocaml_list pp fmt (to_list t) end - module Map = Int_map + module Map = Int.Map end diff --git a/src/interned.mli b/src/stdune/interned.mli similarity index 84% rename from src/interned.mli rename to src/stdune/interned.mli index 613020bc..2b71006c 100644 --- a/src/interned.mli +++ b/src/stdune/interned.mli @@ -1,7 +1,5 @@ (** Interned strings *) -open! Import - module type S = sig type t val compare : t -> t -> Ordering.t @@ -36,4 +34,9 @@ module type S = sig end with type key := t end -module Make() : S +type resize_policy = Conservative | Greedy + +module Make(R : sig + val initial_size : int + val resize_policy : resize_policy + end) : S diff --git a/src/stdune/stdune.ml b/src/stdune/stdune.ml index 4fc041f2..e608c3d3 100644 --- a/src/stdune/stdune.ml +++ b/src/stdune/stdune.ml @@ -20,6 +20,8 @@ module String = String module Char = Char module Sexp = Sexp module Path = Path +module Fmt = Fmt +module Interned = Interned external reraise : exn -> _ = "%reraise" diff --git a/src/sub_system_name.ml b/src/sub_system_name.ml index 1cb555bd..14397bbf 100644 --- a/src/sub_system_name.ml +++ b/src/sub_system_name.ml @@ -1 +1,6 @@ -include Interned.Make () +open Stdune + +include Interned.Make(struct + let initial_size = 16 + let resize_policy = Interned.Conservative + end) diff --git a/src/sub_system_name.mli b/src/sub_system_name.mli index b4c0fbb5..30cd6fa7 100644 --- a/src/sub_system_name.mli +++ b/src/sub_system_name.mli @@ -1 +1 @@ -include Interned.S +include Stdune.Interned.S diff --git a/src/syntax.ml b/src/syntax.ml index 1141fd5f..81d123a9 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -22,14 +22,14 @@ module Version = struct end module Versioned_parser = struct - type 'a t = (int * 'a) Int_map.t + type 'a t = (int * 'a) Int.Map.t let make l = if List.is_empty l then Exn.code_error "Syntax.Versioned_parser.make got empty list" []; match List.map l ~f:(fun ((major, minor), p) -> (major, (minor, p))) - |> Int_map.of_list + |> Int.Map.of_list with | Ok x -> x | Error _ -> @@ -38,12 +38,12 @@ module Versioned_parser = struct [ "versions", Sexp.To_sexp.list Version.sexp_of_t (List.map l ~f:fst) ] let last t = - let major, (minor, p) = Option.value_exn (Int_map.max_binding t) in + let major, (minor, p) = Option.value_exn (Int.Map.max_binding t) in ((major, minor), p) let find_exn t ~loc ~data_version:(major, minor) = match - Option.bind (Int_map.find t major) ~f:(fun (minor', p) -> + Option.bind (Int.Map.find t major) ~f:(fun (minor', p) -> Option.some_if (minor' >= minor) p) with | None -> @@ -52,7 +52,7 @@ module Versioned_parser = struct %s" (Version.to_string (major, minor)) (String.concat ~sep:"\n" - (Int_map.to_list t |> List.map ~f:(fun (major, (minor, _)) -> + (Int.Map.to_list t |> List.map ~f:(fun (major, (minor, _)) -> sprintf "- %u.0 to %u.%u" major major minor))) | Some p -> p end diff --git a/src/top_closure.ml b/src/top_closure.ml index f7490947..cec04979 100644 --- a/src/top_closure.ml +++ b/src/top_closure.ml @@ -46,5 +46,5 @@ module Make(Keys : Keys) = struct | Error elts -> Error elts end -module Int = Make(Int_set) +module Int = Make(Int.Set) module String = Make(String.Set) diff --git a/src/variant.ml b/src/variant.ml index 0eab5f40..548b4855 100644 --- a/src/variant.ml +++ b/src/variant.ml @@ -1,4 +1,9 @@ -include Interned.Make() +open Stdune + +include Interned.Make(struct + let initial_size = 256 + let resize_policy = Interned.Conservative + end) let ppx_driver = make "ppx_driver" let mt = make "mt" diff --git a/src/variant.mli b/src/variant.mli index 93f98488..c91f261c 100644 --- a/src/variant.mli +++ b/src/variant.mli @@ -6,7 +6,7 @@ They are directly mapped to findlib predicates. *) -include Interned.S +include Stdune.Interned.S (** Well-known variants *) val ppx_driver : t