Reimplement Store using Dyn.

2 files changed, 29 insertions, 63 deletions

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. *)