Merge PR #7881: Reimplement Store using Dyn

4 files changed, 50 insertions, 70 deletions

diff --git a/clib/dyn.ml b/clib/dyn.ml
index 6c45767246..22c49706be 100644
--- a/clib/dyn.ml
+++ b/clib/dyn.ml
@@ -38,6 +38,7 @@ sig
   type t = Dyn : 'a tag * 'a -> t
 
   val create : string -> 'a tag
+  val anonymous : int -> 'a tag
   val eq : 'a tag -> 'b tag -> ('a, 'b) CSig.eq option
   val repr : 'a tag -> string
 
@@ -81,15 +82,22 @@ module Self : PreS = struct
 
   let create (s : string) =
     let hash = Hashtbl.hash s in
-    let () =
-      if Int.Map.mem hash !dyntab then
-        let old = Int.Map.find hash !dyntab in
-        let () = Printf.eprintf "Dynamic tag collision: %s vs. %s\n%!" s old in
-        assert false
-    in
-    let () = dyntab := Int.Map.add hash s !dyntab in
+    if Int.Map.mem hash !dyntab then begin
+      let old = Int.Map.find hash !dyntab in
+      Printf.eprintf "Dynamic tag collision: %s vs. %s\n%!" s old;
+      assert false
+    end;
+    dyntab := Int.Map.add hash s !dyntab;
     hash
 
+  let anonymous n =
+    if Int.Map.mem n !dyntab then begin
+      Printf.eprintf "Dynamic tag collision: %d\n%!" n;
+      assert false
+    end;
+    dyntab := Int.Map.add n "<anonymous>" !dyntab;
+    n
+
   let eq : 'a 'b. 'a tag -> 'b tag -> ('a, 'b) CSig.eq option =
     fun h1 h2 -> if Int.equal h1 h2 then Some (Obj.magic CSig.Refl) else None
 
diff --git a/clib/dyn.mli b/clib/dyn.mli
index ff9762bd6b..1bd78b2db8 100644
--- a/clib/dyn.mli
+++ b/clib/dyn.mli
@@ -48,6 +48,12 @@ sig
       Type names are hashed, so [create] may raise even if no type with
       the exact same name was registered due to a collision. *)
 
+  val anonymous : int -> 'a tag
+  (** [anonymous i] returns a tag describing an [i]-th anonymous type.
+      If [anonymous] is not used together with [create], [max_int] anonymous types
+      are available.
+      [anonymous] raises an exception if [i] is already registered. *)
+
   val eq : 'a tag -> 'b tag -> ('a, 'b) CSig.eq option
   (** [eq t1 t2] returns [Some witness] if [t1] is the same as [t2], [None] otherwise. *)
 
diff --git a/clib/store.ml b/clib/store.ml
index 1469358c9d..79e26908d7 100644
--- a/clib/store.ml
+++ b/clib/store.ml
@@ -20,70 +20,37 @@ module type S =
 sig
   type t
   type 'a field
+  val field : unit -> 'a field
   val empty : t
   val set : t -> 'a field -> 'a -> t
   val get : t -> 'a field -> 'a option
   val remove : t -> 'a field -> t
   val merge : t -> t -> t
-  val field : unit -> 'a field
 end
 
-module Make () : S =
+module Make() : S =
 struct
-
-  let next =
-    let count = ref 0 in fun () ->
-      let n = !count in
-      incr count;
-      n
-
-  type t = Obj.t option array
-  (** Store are represented as arrays. For small values, which is typicial,
-      is slightly quicker than other implementations. *)
-
-type 'a field = int
-
-let allocate len : t = Array.make len None
-
-let empty : t = [||]
-
-let set (s : t) (i : 'a field) (v : 'a) : t =
-  let len = Array.length s in
-  let nlen = if i < len then len else succ i in
-  let () = assert (0 <= i) in
-  let ans = allocate nlen in
-  Array.blit s 0 ans 0 len;
-  Array.unsafe_set ans i (Some (Obj.repr v));
-  ans
-
-let get (s : t) (i : 'a field) : 'a option =
-  let len = Array.length s in
-  if len <= i then None
-  else Obj.magic (Array.unsafe_get s i)
-
-let remove (s : t) (i : 'a field) =
-  let len = Array.length s in
-  let () = assert (0 <= i) in
-  let ans = allocate len in
-  Array.blit s 0 ans 0 len;
-  if i < len then Array.unsafe_set ans i None;
-  ans
-
-let merge (s1 : t) (s2 : t) : t =
-  let len1 = Array.length s1 in
-  let len2 = Array.length s2 in
-  let nlen = if len1 < len2 then len2 else len1 in
-  let ans = allocate nlen in
-  (** Important: No more allocation from here. *)
-  Array.blit s2 0 ans 0 len2;
-  for i = 0 to pred len1 do
-    let v = Array.unsafe_get s1 i in
-    match v with
-    | None -> ()
-    | Some _ -> Array.unsafe_set ans i v
-  done;
-  ans
-
-let field () = next ()
-
+  module Dyn = Dyn.Make()
+  module Map = Dyn.Map(struct type 'a t = 'a end)
+
+  type t = Map.t
+  type 'a field = 'a Dyn.tag
+
+  let next = ref 0
+  let field () =
+    let f = Dyn.anonymous !next in
+    incr next;
+    f
+
+  let empty =
+    Map.empty
+  let set s f v =
+    Map.add f v s
+  let get s f =
+    try Some (Map.find f s)
+    with Not_found -> None
+  let remove s f =
+    Map.remove f s
+  let merge s1 s2 =
+    Map.fold (fun (Map.Any (f, v)) s -> Map.add f v s) s1 s2
 end
diff --git a/clib/store.mli b/clib/store.mli
index 0c2b2e0856..7cdd1d3bed 100644
--- a/clib/store.mli
+++ b/clib/store.mli
@@ -19,6 +19,9 @@ sig
   type 'a field
   (** Type of field of such stores *)
 
+  val field : unit -> 'a field
+  (** Create a new field *)
+
   val empty : t
   (** Empty store *)
 
@@ -33,11 +36,7 @@ sig
 
   val merge : t -> t -> t
   (** [merge s1 s2] adds all the fields of [s1] into [s2]. *)
-
-  val field : unit -> 'a field
-  (** Create a new field *)
-
 end
 
-module Make () : S
+module Make() : S
 (** Create a new store type. *)