1 files changed, 75 insertions, 45 deletions
diff --git a/lib/store.ml b/lib/store.ml
index 28eb65c8..a1788f7d 100644
--- a/lib/store.ml
+++ b/lib/store.ml
@@ -6,56 +6,86 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(*** This module implements an "untyped store", in this particular case we
-        see it as an extensible record whose fields are left unspecified. ***)
+(** This module implements an "untyped store", in this particular case
+    we see it as an extensible record whose fields are left
+    unspecified. ***)
 
-(* We give a short implementation of a universal type. This is mostly equivalent
-    to what is proposed by module Dyn.ml, except that it requires no explicit tag. *)
-module type Universal = sig
-  type t
-  
-  type 'a etype = {
-     put : 'a -> t ;
-     get : t -> 'a option
-  }
+(** We use a dynamic "name" allocator. But if we needed to serialise
+    stores, we might want something static to avoid troubles with
+    plugins order. *)
 
-  val embed : unit -> 'a etype
+module type T =
+sig
 end
 
-(* We use a dynamic "name" allocator. But if we needed to serialise stores, we
-might want something static to avoid troubles with plugins order. *)
+module type S =
+sig
+  type t
+  type '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
 
-let next =
-  let count = ref 0 in fun () ->
-  let n = !count in
-  incr count;
-  n
+module Make (M : T) : S =
+struct
 
-type t = Obj.t Util.Intmap.t
+  let next =
+    let count = ref 0 in fun () ->
+      let n = !count in
+      incr count;
+      n
 
-module Field = struct
-  type 'a field = {
-    set : 'a -> t -> t ;
-    get : t -> 'a option ;
-    remove : t -> t 
-  }
-  type 'a t = 'a field
-end
+  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 = [||]
 
-open Field
-
-let empty = Util.Intmap.empty
-
-let field () =
-  let fid = next () in
-  let set a s =
-    Util.Intmap.add fid (Obj.repr a) s
-  in
-  let get s =
-    try Some (Obj.obj (Util.Intmap.find fid s))
-    with Not_found -> None
-  in
-  let remove s =
-    Util.Intmap.remove fid s
-  in
-  { set = set ; get = get ; remove = remove }
+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 ()
+
+end