Merge pull request #800 from rgrinberg/interned-stdune

Move Interned to Stdune

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

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 vars : t -> Binding.t Int.Map.t
-  val set_vars : t -> Binding.t Int_map.t -> 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
 

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 "@[<hv>[ %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 "@[<hov 1>%s@ =@ %a@]"
-          field pp () in
-      let pp_sep fmt () = Format.fprintf fmt "@,; " in
-      Format.fprintf fmt "@[<hv>{ %a@ }@]"
-        (Format.pp_print_list ~pp_sep pp) xs
-
-  let tuple ppfa ppfb fmt (a, b) =
-    Format.fprintf fmt "@[<hv>(%a, %a)@]" ppfa a ppfb b
-end
-
 (* This is ugly *)
 let printer = ref (Printf.eprintf "%s%!")
 let print_to_console s = !printer s

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
 

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
 

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 "@[<hv>[ %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 "@[<hov 1>%s@ =@ %a@]"
+        field pp () in
+    let pp_sep fmt () = Format.fprintf fmt "@,; " in
+    Format.fprintf fmt "@[<hv>{ %a@ }@]"
+      (Format.pp_print_list ~pp_sep pp) xs
+
+let tuple ppfa ppfb fmt (a, b) =
+  Format.fprintf fmt "@[<hv>(%a, %a)@]" ppfa a ppfb 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

src/stdune/int.ml

@@ -1,8 +1,15 @@
-type t = int
+module T = struct
-let compare (a : int) b : Ordering.t =
+  type t = int
-  if a < b then
+  let compare (a : int) b : Ordering.t =
-    Lt
+    if a < b then
-  else if a = b then
+      Lt
-    Eq
+    else if a = b then
-  else
+      Eq
-    Gt
+    else
+      Gt
+end
+
+include T
+
+module Set = Set.Make(T)
+module Map = Map.Make(T)

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

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
+type resize_policy = Conservative | Greedy
-  include Int
+
+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 =
-      let n = (!next land (lnot (increment_size - 1))) + (increment_size * 2) in
+        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

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

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"
 

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)

src/sub_system_name.mli

@@ -1 +1 @@
-include Interned.S
+include Stdune.Interned.S

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

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)

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"

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