From d483768b93e81bbc55b8ef45d84cb747259bd83f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9mie=20Dimino?= Date: Tue, 19 Jun 2018 11:32:10 +0100 Subject: [PATCH] Move universal maps from Fiber to Stdune (#892) Signed-off-by: Jeremie Dimino --- src/fiber/fiber.ml | 79 +++++------------------------------------ src/stdune/stdune.ml | 1 + src/stdune/univ_map.ml | 73 +++++++++++++++++++++++++++++++++++++ src/stdune/univ_map.mli | 19 ++++++++++ 4 files changed, 102 insertions(+), 70 deletions(-) create mode 100644 src/stdune/univ_map.ml create mode 100644 src/stdune/univ_map.mli diff --git a/src/fiber/fiber.ml b/src/fiber/fiber.ml index 424a539a..f89955d1 100644 --- a/src/fiber/fiber.ml +++ b/src/fiber/fiber.ml @@ -1,50 +1,5 @@ open Stdune -module Eq = struct - type ('a, 'b) t = T : ('a, 'a) t - - let cast (type a) (type b) (T : (a, b) t) (x : a) : b = x -end - -module Var0 = struct - module Key = struct - type 'a t = .. - end - - module type T = sig - type t - type 'a Key.t += T : t Key.t - val id : int - end - - type 'a t = (module T with type t = 'a) - - let next = ref 0 - - let create (type a) () = - let n = !next in - next := n + 1; - let module M = struct - type t = a - type 'a Key.t += T : t Key.t - let id = n - end in - (module M : T with type t = a) - - let id (type a) (module M : T with type t = a) = M.id - - let eq (type a) (type b) - (module A : T with type t = a) - (module B : T with type t = b) : (a, b) Eq.t = - match A.T with - | B.T -> Eq.T - | _ -> assert false -end - -module Binding = struct - type t = T : 'a Var0.t * 'a -> t -end - module Execution_context : sig type t @@ -66,14 +21,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 -> Univ_map.t + val set_vars : t -> Univ_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 : Univ_map.t ; on_release : unit -> unit } @@ -83,7 +38,7 @@ end = struct let create_initial () = { on_error = reraise ; fibers = ref 1 - ; vars = Int.Map.empty + ; vars = Univ_map.empty ; on_release = ignore } @@ -269,29 +224,13 @@ let parallel_iter l ~f ctx k = EC.forward_error ctx exn) module Var = struct - include Var0 + include Univ_map.Key - let find ctx var = - 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 get var ctx k = k (Univ_map.find (EC.vars ctx) var) + let get_exn var ctx k = k (Univ_map.find_exn (EC.vars ctx) var) - let find_exn ctx var = - 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 - Eq.cast eq v - - let get var ctx k = k (find ctx var) - let get_exn var ctx k = k (find_exn ctx var) - - 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 set var x fiber ctx k = + let ctx = EC.set_vars ctx (Univ_map.add (EC.vars ctx) var x) in fiber ctx k end diff --git a/src/stdune/stdune.ml b/src/stdune/stdune.ml index e608c3d3..4aadebec 100644 --- a/src/stdune/stdune.ml +++ b/src/stdune/stdune.ml @@ -22,6 +22,7 @@ module Sexp = Sexp module Path = Path module Fmt = Fmt module Interned = Interned +module Univ_map = Univ_map external reraise : exn -> _ = "%reraise" diff --git a/src/stdune/univ_map.ml b/src/stdune/univ_map.ml new file mode 100644 index 00000000..fcb2fb64 --- /dev/null +++ b/src/stdune/univ_map.ml @@ -0,0 +1,73 @@ +module Eq = struct + type ('a, 'b) t = T : ('a, 'a) t + + let cast (type a) (type b) (T : (a, b) t) (x : a) : b = x +end + +module Key = struct + module Witness = struct + type 'a t = .. + end + + module type T = sig + type t + type 'a Witness.t += T : t Witness.t + val id : int + end + + type 'a t = (module T with type t = 'a) + + let next = ref 0 + + let create (type a) () = + let n = !next in + next := n + 1; + let module M = struct + type t = a + type 'a Witness.t += T : t Witness.t + let id = n + end in + (module M : T with type t = a) + + let id (type a) (module M : T with type t = a) = M.id + + let eq (type a) (type b) + (module A : T with type t = a) + (module B : T with type t = b) : (a, b) Eq.t = + match A.T with + | B.T -> Eq.T + | _ -> assert false +end + +module Binding = struct + type t = T : 'a Key.t * 'a -> t +end + +type t = Binding.t Int.Map.t + +let empty = Int.Map.empty +let is_empty = Int.Map.is_empty + +let add (type a) t (key : a Key.t) x = + let (module M) = key in + let data = Binding.T (key, x) in + Int.Map.add t M.id data + +let mem t key = Int.Map.mem t (Key.id key) + +let remove t key = Int.Map.remove t (Key.id key) + +let find t key = + match Int.Map.find t (Key.id key) with + | None -> None + | Some (Binding.T (key', v)) -> + let eq = Key.eq key' key in + Some (Eq.cast eq v) + +let find_exn t key = + match Int.Map.find t (Key.id key) with + | None -> failwith "Univ_map.find_exn" + | Some (Binding.T (key', v)) -> + let eq = Key.eq key' key in + Eq.cast eq v + diff --git a/src/stdune/univ_map.mli b/src/stdune/univ_map.mli new file mode 100644 index 00000000..5c9b76eb --- /dev/null +++ b/src/stdune/univ_map.mli @@ -0,0 +1,19 @@ +(** Universal maps *) + +(** A universal map is a map that can store values for arbitrary + keys. It is the the key that conveys the type of the data + associated to it. *) +type t + +module Key : sig + type 'a t + val create : unit -> 'a t +end + +val empty : t +val is_empty : t -> bool +val mem : t -> 'a Key.t -> bool +val add : t -> 'a Key.t -> 'a -> t +val remove : t -> 'a Key.t -> t +val find : t -> 'a Key.t -> 'a option +val find_exn : t -> 'a Key.t -> 'a