Merge pull request #800 from rgrinberg/interned-stdune
Move Interned to Stdune
This commit is contained in:
commit
1e3b90c1d6
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
18
src/lib.ml
18
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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
|
@ -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
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
|
@ -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
|
|
@ -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"
|
||||
|
||||
|
|
|
@ -1 +1,6 @@
|
|||
include Interned.Make ()
|
||||
open Stdune
|
||||
|
||||
include Interned.Make(struct
|
||||
let initial_size = 16
|
||||
let resize_policy = Interned.Conservative
|
||||
end)
|
||||
|
|
|
@ -1 +1 @@
|
|||
include Interned.S
|
||||
include Stdune.Interned.S
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue