[r2005-06-18 06:58:35 by afrisch] Start using unique pools

Original author: afrisch
Date: 2005-06-18 07:00:04+00:00

Makefile.distrib

@@ -143,6 +143,7 @@ OBJECTS = \
  misc/stats.cmo \
  misc/serialize.cmo misc/custom.cmo \
  misc/state.cmo misc/pool.cmo misc/encodings.cmo \
+ misc/upool.cmo \
   misc/pretty.cmo misc/ns.cmo misc/inttbl.cmo misc/imap.cmo \
  misc/html.cmo \
  \

depend

@@ -14,11 +14,13 @@ misc/pool.cmx: misc/state.cmx misc/serialize.cmx misc/custom.cmx \
     misc/pool.cmi 
 misc/encodings.cmo: misc/serialize.cmi misc/custom.cmo misc/encodings.cmi 
 misc/encodings.cmx: misc/serialize.cmx misc/custom.cmx misc/encodings.cmi 
+misc/upool.cmo: misc/custom.cmo misc/upool.cmi 
+misc/upool.cmx: misc/custom.cmx misc/upool.cmi 
 misc/pretty.cmo: misc/pretty.cmi 
 misc/pretty.cmx: misc/pretty.cmi 
-misc/ns.cmo: misc/state.cmi misc/serialize.cmi misc/pool.cmi \
+misc/ns.cmo: misc/upool.cmi misc/state.cmi misc/serialize.cmi \
     misc/encodings.cmi misc/custom.cmo misc/ns.cmi 
-misc/ns.cmx: misc/state.cmx misc/serialize.cmx misc/pool.cmx \
+misc/ns.cmx: misc/upool.cmx misc/state.cmx misc/serialize.cmx \
     misc/encodings.cmx misc/custom.cmx misc/ns.cmi 
 misc/inttbl.cmo: misc/inttbl.cmi 
 misc/inttbl.cmx: misc/inttbl.cmi 
@@ -40,10 +42,12 @@ types/intervals.cmo: misc/serialize.cmi types/intervals.cmi
 types/intervals.cmx: misc/serialize.cmx types/intervals.cmi 
 types/chars.cmo: misc/custom.cmo types/chars.cmi 
 types/chars.cmx: misc/custom.cmx types/chars.cmi 
-types/atoms.cmo: types/sortedList.cmi misc/pool.cmi misc/ns.cmi misc/imap.cmi \
-    misc/encodings.cmi misc/custom.cmo types/atoms.cmi 
-types/atoms.cmx: types/sortedList.cmx misc/pool.cmx misc/ns.cmx misc/imap.cmx \
-    misc/encodings.cmx misc/custom.cmx types/atoms.cmi 
+types/atoms.cmo: misc/upool.cmi types/sortedList.cmi misc/pool.cmi \
+    misc/ns.cmi misc/imap.cmi misc/encodings.cmi misc/custom.cmo \
+    types/atoms.cmi 
+types/atoms.cmx: misc/upool.cmx types/sortedList.cmx misc/pool.cmx \
+    misc/ns.cmx misc/imap.cmx misc/encodings.cmx misc/custom.cmx \
+    types/atoms.cmi 
 types/normal.cmo: types/normal.cmi 
 types/normal.cmx: types/normal.cmi 
 types/types.cmo: misc/stats.cmi misc/state.cmi types/sortedList.cmi \
@@ -83,9 +87,9 @@ types/builtin_defs.cmx: types/types.cmx types/sequence.cmx misc/ns.cmx \
     types/intervals.cmx types/ident.cmx misc/encodings.cmx types/chars.cmx \
     types/atoms.cmx types/builtin_defs.cmi 
 compile/lambda.cmo: types/types.cmi misc/serialize.cmi types/patterns.cmi \
-    misc/ns.cmi types/ident.cmo compile/lambda.cmi 
+    misc/ns.cmi misc/imap.cmi types/ident.cmo compile/lambda.cmi 
 compile/lambda.cmx: types/types.cmx misc/serialize.cmx types/patterns.cmx \
-    misc/ns.cmx types/ident.cmx compile/lambda.cmi 
+    misc/ns.cmx misc/imap.cmx types/ident.cmx compile/lambda.cmi 
 runtime/value.cmo: types/types.cmi types/sequence.cmi misc/ns.cmi \
     compile/lambda.cmi types/intervals.cmi misc/imap.cmi types/ident.cmo \
     misc/encodings.cmi types/chars.cmi types/atoms.cmi runtime/value.cmi 
@@ -189,45 +193,45 @@ schema/schema_converter.cmx: runtime/value.cmx types/types.cmx \
     schema/schema_builtin.cmx misc/ns.cmx types/ident.cmx misc/encodings.cmx \
     types/builtin_defs.cmx types/atoms.cmx 
 runtime/load_xml.cmo: runtime/value.cmi parser/url.cmi misc/ns.cmi \
-    parser/location.cmi types/ident.cmo misc/encodings.cmi types/atoms.cmi \
-    runtime/load_xml.cmi 
+    parser/location.cmi misc/imap.cmi types/ident.cmo misc/encodings.cmi \
+    types/atoms.cmi runtime/load_xml.cmi 
 runtime/load_xml.cmx: runtime/value.cmx parser/url.cmx misc/ns.cmx \
-    parser/location.cmx types/ident.cmx misc/encodings.cmx types/atoms.cmx \
-    runtime/load_xml.cmi 
+    parser/location.cmx misc/imap.cmx types/ident.cmx misc/encodings.cmx \
+    types/atoms.cmx runtime/load_xml.cmi 
 runtime/run_dispatch.cmo: runtime/value.cmi types/types.cmi \
-    types/patterns.cmi types/ident.cmo misc/encodings.cmi types/chars.cmi \
-    types/atoms.cmi runtime/run_dispatch.cmi 
+    types/patterns.cmi misc/imap.cmi types/ident.cmo misc/encodings.cmi \
+    types/chars.cmi types/atoms.cmi runtime/run_dispatch.cmi 
 runtime/run_dispatch.cmx: runtime/value.cmx types/types.cmx \
-    types/patterns.cmx types/ident.cmx misc/encodings.cmx types/chars.cmx \
-    types/atoms.cmx runtime/run_dispatch.cmi 
+    types/patterns.cmx misc/imap.cmx types/ident.cmx misc/encodings.cmx \
+    types/chars.cmx types/atoms.cmx runtime/run_dispatch.cmi 
 runtime/explain.cmo: runtime/value.cmi types/types.cmi \
-    runtime/run_dispatch.cmi types/patterns.cmi types/ident.cmo \
+    runtime/run_dispatch.cmi types/patterns.cmi misc/imap.cmi types/ident.cmo \
     misc/encodings.cmi types/chars.cmi types/atoms.cmi runtime/explain.cmi 
 runtime/explain.cmx: runtime/value.cmx types/types.cmx \
-    runtime/run_dispatch.cmx types/patterns.cmx types/ident.cmx \
+    runtime/run_dispatch.cmx types/patterns.cmx misc/imap.cmx types/ident.cmx \
     misc/encodings.cmx types/chars.cmx types/atoms.cmx runtime/explain.cmi 
 runtime/print_xml.cmo: runtime/value.cmi types/sequence.cmi \
-    schema/schema_builtin.cmi misc/ns.cmi types/intervals.cmi types/ident.cmo \
-    misc/encodings.cmi types/atoms.cmi runtime/print_xml.cmi 
+    schema/schema_builtin.cmi misc/ns.cmi types/intervals.cmi misc/imap.cmi \
+    types/ident.cmo misc/encodings.cmi types/atoms.cmi runtime/print_xml.cmi 
 runtime/print_xml.cmx: runtime/value.cmx types/sequence.cmx \
-    schema/schema_builtin.cmx misc/ns.cmx types/intervals.cmx types/ident.cmx \
-    misc/encodings.cmx types/atoms.cmx runtime/print_xml.cmi 
+    schema/schema_builtin.cmx misc/ns.cmx types/intervals.cmx misc/imap.cmx \
+    types/ident.cmx misc/encodings.cmx types/atoms.cmx runtime/print_xml.cmi 
 runtime/eval.cmo: runtime/value.cmi types/types.cmi typing/typer.cmi \
     schema/schema_common.cmi runtime/run_dispatch.cmi types/patterns.cmi \
-    misc/ns.cmi compile/lambda.cmi types/ident.cmo runtime/explain.cmi \
-    runtime/eval.cmi 
+    misc/ns.cmi compile/lambda.cmi misc/imap.cmi types/ident.cmo \
+    runtime/explain.cmi runtime/eval.cmi 
 runtime/eval.cmx: runtime/value.cmx types/types.cmx typing/typer.cmx \
     schema/schema_common.cmx runtime/run_dispatch.cmx types/patterns.cmx \
-    misc/ns.cmx compile/lambda.cmx types/ident.cmx runtime/explain.cmx \
-    runtime/eval.cmi 
+    misc/ns.cmx compile/lambda.cmx misc/imap.cmx types/ident.cmx \
+    runtime/explain.cmx runtime/eval.cmi 
 compile/compile.cmo: types/types.cmi typing/typer.cmi typing/typed.cmo \
     misc/serialize.cmi types/patterns.cmi parser/location.cmi \
-    compile/lambda.cmi types/ident.cmo runtime/eval.cmi parser/ast.cmo \
-    compile/compile.cmi 
+    compile/lambda.cmi misc/imap.cmi types/ident.cmo runtime/eval.cmi \
+    parser/ast.cmo compile/compile.cmi 
 compile/compile.cmx: types/types.cmx typing/typer.cmx typing/typed.cmx \
     misc/serialize.cmx types/patterns.cmx parser/location.cmx \
-    compile/lambda.cmx types/ident.cmx runtime/eval.cmx parser/ast.cmx \
-    compile/compile.cmi 
+    compile/lambda.cmx misc/imap.cmx types/ident.cmx runtime/eval.cmx \
+    parser/ast.cmx compile/compile.cmi 
 compile/operators.cmo: runtime/value.cmi types/types.cmi typing/typer.cmi \
     parser/location.cmi runtime/eval.cmi compile/operators.cmi 
 compile/operators.cmx: runtime/value.cmx types/types.cmx typing/typer.cmx \
@@ -354,7 +358,9 @@ runtime/cduce_pxp.cmx: parser/url.cmx schema/schema_xml.cmx \
     runtime/cduce_pxp.cmi 
 misc/pool.cmi: misc/custom.cmo 
 misc/encodings.cmi: misc/serialize.cmi misc/custom.cmo 
-misc/ns.cmi: misc/serialize.cmi misc/encodings.cmi misc/custom.cmo 
+misc/upool.cmi: misc/serialize.cmi misc/custom.cmo 
+misc/ns.cmi: misc/upool.cmi misc/serialize.cmi misc/encodings.cmi \
+    misc/custom.cmo 
 types/sortedList.cmi: misc/serialize.cmi misc/custom.cmo 
 misc/bool.cmi: misc/custom.cmo 
 types/boolean.cmi: misc/custom.cmo 
@@ -370,7 +376,7 @@ types/patterns.cmi: types/types.cmi types/ident.cmo misc/custom.cmo \
 compile/auto_opt.cmi: types/types.cmi types/patterns.cmi 
 types/builtin_defs.cmi: types/types.cmi types/ident.cmo types/atoms.cmi 
 compile/lambda.cmi: types/types.cmi misc/serialize.cmi types/patterns.cmi \
-    misc/ns.cmi types/ident.cmo 
+    misc/ns.cmi misc/imap.cmi types/ident.cmo 
 runtime/value.cmi: types/types.cmi misc/ns.cmi compile/lambda.cmi \
     types/intervals.cmi misc/imap.cmi types/ident.cmo misc/encodings.cmi \
     types/chars.cmi types/atoms.cmi 

misc/custom.ml

@@ -58,6 +58,8 @@ module String : T with type t = string = struct
 
   let equal x y = compare x y = 0
   let hash = Hashtbl.hash
+    (* Use hash_variant instead ? *)
+
   let serialize = Serialize.Put.string
   let deserialize = Serialize.Get.string
 end

misc/ns.ml

@@ -21,8 +21,12 @@ let split_qname s =
     ("", U.mk s)
 
 
-module P = Pool.Make(U)
+module P = Upool.Make(U)
+(* module P = Pool.Make(U) *)
 include P
+
+
+let value = get
 let empty = mk empty_str
 let xml_ns = mk (U.mk "http://www.w3.org/XML/1998/namespace")
 let xsd_ns = mk (U.mk "http://www.w3.org/2001/XMLSchema")

misc/ns.mli

@@ -4,12 +4,13 @@ val split_qname: Utf8.t -> string * Utf8.t
 
 exception UnknownPrefix of Utf8.t
 
-include Custom.T with type t = int  (* Namespaces (URIs) *)
+include Upool.S with type value = Utf8.t (* Namespaces (URIs) *)
 val mk: Utf8.t -> t
 val mk_ascii: string -> t
 val value: t -> Utf8.t
+
+
 val empty : t
-val value: t -> Utf8.t
 
 val xml_ns: t
 

misc/upool.ml

@@ -4,15 +4,12 @@ external int: 'a typed_int -> int = "%identity"
 module type S = sig
   type token
   type value
-  type t = token typed_int
+  include Custom.T with type t = token typed_int
   exception Not_unique of value * value
 
   val dummy: t
   val mk: value -> t
   val get: t -> value
-  val compare: t -> t -> int
-  val hash: t -> int
-  val equal: t -> t -> bool
 
   val extract: unit -> value list
   val intract: value list -> unit
@@ -22,7 +19,7 @@ module HInt = Hashtbl.Make(struct type t = int
 				  let hash x = x
 				  let equal x y = x==y end)
 
-module Make(X : Hashtbl.HashedType) = struct
+module Make(X : Custom.T) = struct
   type token
   type value = X.t
   type t = token typed_int
@@ -50,4 +47,10 @@ module Make(X : Hashtbl.HashedType) = struct
 
   let extract () = HInt.fold (fun _ v accu -> v::accu) pool []
   let intract = List.iter (fun v -> ignore (mk v))
+
+  let serialize s h = X.serialize s (get h)
+  let deserialize s = mk (X.deserialize s)
+
+  let check _ = ()
+  let dump ppf _ = ()
 end

misc/upool.mli

@@ -4,18 +4,15 @@ external int: 'a typed_int -> int = "%identity"
 module type S = sig
   type token
   type value
-  type t = token typed_int
+  include Custom.T with type t = token typed_int
   exception Not_unique of value * value
 
   val dummy: t
   val mk: value -> t
   val get: t -> value
-  val compare: t -> t -> int
-  val hash: t -> int
-  val equal: t -> t -> bool
 
   val extract: unit -> value list
   val intract: value list -> unit
 end
 
-module Make(X : Hashtbl.HashedType) : S with type value = X.t
+module Make(X : Custom.T) : S with type value = X.t

types/atoms.ml

@@ -85,10 +85,11 @@ let print s = match get s with
 type 'a map = 'a Imap.t Imap.t
 
 let get_map (ns,x) m =   
-  Imap.find_lower (Imap.find_lower m ns) x
+  Imap.find_lower (Imap.find_lower m (Upool.int ns)) x
 
 module IntSet = 
   Set.Make(struct type t = int let compare (x:int) y = Pervasives.compare x y end)
+module NsSet = Set.Make(Ns)
 
 let create def l = match def with
   | None ->
@@ -101,13 +102,13 @@ let mk_map l =
   let l = List.filter (fun (t,_) -> not (is_empty t)) l in
   if l = [] then Imap.empty
   else
-  let all_ns = ref IntSet.empty in
+  let all_ns = ref NsSet.empty in
   let def = ref None in
   List.iter 
     (function (s,x) ->
        match get s with
        | `Finite s -> 
-	   List.iter (fun (ns,_) -> all_ns := IntSet.add ns !all_ns) s
+	   List.iter (fun (ns,_) -> all_ns := NsSet.add ns !all_ns) s
        | `Cofinite _ -> def := Some (Imap.create_default x [||])
     ) l;
 
@@ -126,6 +127,6 @@ let mk_map l =
   in
 
   let t = 
-    List.fold_left (fun accu ns -> (ns, one_ns ns)::accu) [] 
-      (IntSet.elements !all_ns) in
+    List.fold_left (fun accu ns -> (Upool.int ns, one_ns ns)::accu) [] 
+      (NsSet.elements !all_ns) in
   create (!def) t