Move universal maps from Fiber to Stdune (#892)
Signed-off-by: Jeremie Dimino <jeremie@dimino.org>
This commit is contained in:
parent
14e6b1e038
commit
d483768b93
|
@ -1,50 +1,5 @@
|
||||||
open Stdune
|
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
|
module Execution_context : sig
|
||||||
type t
|
type t
|
||||||
|
|
||||||
|
@ -66,14 +21,14 @@ module Execution_context : sig
|
||||||
-> on_error:(exn -> unit)
|
-> on_error:(exn -> unit)
|
||||||
-> t
|
-> t
|
||||||
|
|
||||||
val vars : t -> Binding.t Int.Map.t
|
val vars : t -> Univ_map.t
|
||||||
val set_vars : t -> Binding.t Int.Map.t -> t
|
val set_vars : t -> Univ_map.t -> t
|
||||||
end = struct
|
end = struct
|
||||||
type t =
|
type t =
|
||||||
{ on_error : exn -> unit (* This callback must never raise *)
|
{ on_error : exn -> unit (* This callback must never raise *)
|
||||||
; fibers : int ref (* Number of fibers running in this execution
|
; fibers : int ref (* Number of fibers running in this execution
|
||||||
context *)
|
context *)
|
||||||
; vars : Binding.t Int.Map.t
|
; vars : Univ_map.t
|
||||||
; on_release : unit -> unit
|
; on_release : unit -> unit
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -83,7 +38,7 @@ end = struct
|
||||||
let create_initial () =
|
let create_initial () =
|
||||||
{ on_error = reraise
|
{ on_error = reraise
|
||||||
; fibers = ref 1
|
; fibers = ref 1
|
||||||
; vars = Int.Map.empty
|
; vars = Univ_map.empty
|
||||||
; on_release = ignore
|
; on_release = ignore
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -269,29 +224,13 @@ let parallel_iter l ~f ctx k =
|
||||||
EC.forward_error ctx exn)
|
EC.forward_error ctx exn)
|
||||||
|
|
||||||
module Var = struct
|
module Var = struct
|
||||||
include Var0
|
include Univ_map.Key
|
||||||
|
|
||||||
let find ctx var =
|
let get var ctx k = k (Univ_map.find (EC.vars ctx) var)
|
||||||
match Int.Map.find (EC.vars ctx) (id var) with
|
let get_exn var ctx k = k (Univ_map.find_exn (EC.vars ctx) var)
|
||||||
| None -> None
|
|
||||||
| Some (Binding.T (var', v)) ->
|
|
||||||
let eq = eq var' var in
|
|
||||||
Some (Eq.cast eq v)
|
|
||||||
|
|
||||||
let find_exn ctx var =
|
let set var x fiber ctx k =
|
||||||
match Int.Map.find (EC.vars ctx) (id var) with
|
let ctx = EC.set_vars ctx (Univ_map.add (EC.vars ctx) var x) in
|
||||||
| 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
|
|
||||||
fiber ctx k
|
fiber ctx k
|
||||||
end
|
end
|
||||||
|
|
||||||
|
|
|
@ -22,6 +22,7 @@ module Sexp = Sexp
|
||||||
module Path = Path
|
module Path = Path
|
||||||
module Fmt = Fmt
|
module Fmt = Fmt
|
||||||
module Interned = Interned
|
module Interned = Interned
|
||||||
|
module Univ_map = Univ_map
|
||||||
|
|
||||||
external reraise : exn -> _ = "%reraise"
|
external reraise : exn -> _ = "%reraise"
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
Loading…
Reference in New Issue