[r2003-03-23 11:34:36 by cvscast] Empty log message

Original author: cvscast
Date: 2003-03-23 11:34:37+00:00

parser/ast.ml

@@ -86,3 +86,66 @@ and regexp =
   | WeakStar of regexp
   | SeqCapture of id * regexp
  
+
+let rec equal_ppat p1 p2 =
+  let p1 = p1.descr and p2 = p2.descr in
+  (p1 == p2) ||
+  match (p1,p2) with
+    | PatVar x1, PatVar x2 -> x1 = x2
+    | Internal x1, Internal x2 -> Types.equal_descr x1 x2
+    | Or (x1,y1), Or (x2,y2) 
+    | And (x1,y1), And (x2,y2) 
+    | Diff (x1,y1), Diff (x2,y2) 
+    | Prod (x1,y1), Prod (x2,y2) 
+    | XmlT (x1,y1), XmlT (x2,y2) 
+    | Arrow (x1,y1), Arrow (x2,y2) 
+	-> (equal_ppat x1 x2) && (equal_ppat y1 y2)
+    | Optional x1, Optional x2 -> equal_ppat x1 x2
+    | Record (o1,r1), Record (o2,r2) ->
+	(o1 == o2) && (LabelMap.equal equal_ppat r1 r2)
+    | Capture x1, Capture x2 ->	x1 == x2
+    | Constant (x1,y1), Constant (x2,y2) ->
+	(x1 == x2) && (Types.equal_const y1 y2)
+    | Regexp (x1,y1), Regexp (x2,y2) ->
+	(equal_regexp x1 x2) && (equal_ppat y1 y2)
+(* todo: Recurs *)
+    | _ -> false
+and equal_regexp r1 r2 =
+  (r1 == r2) ||
+  match (r1,r2) with
+    | Elem x1, Elem x2 -> equal_ppat x1 x2
+    | Seq (x1,y1), Seq (x2,y2)
+    | Alt (x1,y1), Alt (x2,y2) -> (equal_regexp x1 x2) && (equal_regexp y1 y2)
+    | Star x1, Star x2 
+    | WeakStar x1, WeakStar x2 -> equal_regexp x1 x2
+    | SeqCapture (x1,y1), SeqCapture (x2,y2) -> 
+	(x1 == x2) && (equal_regexp y1 y2)
+    | _ -> false
+
+let rec hash_ppat p = 
+  match p.descr with
+    | PatVar x -> 1 + 17 * (Hashtbl.hash x)
+    | Internal x -> 2 + 17 * (Types.hash_descr x)
+    | Or (x,y) -> 3 + 17 * (hash_ppat x) + 257 * (hash_ppat y)
+    | And (x,y) -> 4 + 17 * (hash_ppat x) + 257 * (hash_ppat y)
+    | Diff (x,y) -> 5 + 17 * (hash_ppat x) + 257 * (hash_ppat y)
+    | Prod (x,y) -> 6 + 17 * (hash_ppat x) + 257 * (hash_ppat y)
+    | XmlT (x,y) -> 7 + 17 * (hash_ppat x) + 257 * (hash_ppat y)
+    | Arrow (x,y) -> 8 + 17 * (hash_ppat x) + 257 * (hash_ppat y)
+    | Optional x -> 9 + 17 * (hash_ppat x)
+    | Record (o,r) ->
+	(if o then 10 else 11) + (LabelMap.hash hash_ppat r)
+    | Capture x -> 12 + 17 * (Id.hash x)
+    | Constant (x,y) -> 13 + 17 * (Id.hash x) + 257 * (Types.hash_const y)
+    | Regexp (x,y) ->
+	14 + 17 * (hash_regexp x) + 16637 * (hash_ppat y)
+    | Recurs (x,l) ->
+	15 + 17 * (hash_ppat x) (* todo: hash l *)
+and hash_regexp = function
+  | Epsilon -> 1
+  | Elem x -> 2 + 17 * (hash_ppat x)
+  | Seq (x,y) -> 3 + 17 * (hash_regexp x) + 257 * (hash_regexp y)
+  | Alt (x,y) -> 4 + 17 * (hash_regexp x) + 257 * (hash_regexp y)
+  | Star x -> 5 + 17 * (hash_regexp x)
+  | WeakStar x -> 6 + 17 * (hash_regexp x)
+  | SeqCapture (x,y) -> 7 + 17 * (Id.hash x) + 257 * (hash_regexp y)

types/sortedList.ml

@@ -84,6 +84,7 @@ sig
 
     val compare: ('b -> 'b -> int) -> ('a,'b) map -> ('a,'b) map -> int
     val hash: ('b -> int) -> ('a,'b) map -> int
+    val equal: ('b -> 'b -> bool) -> ('a,'b) map -> ('a,'b) map -> bool
   end
 end
 
@@ -386,6 +387,14 @@ module Map = struct
   let rec hash f = function
     | [] -> 1
     | (x,y)::l -> X.hash x + 17 * (f y) + 257 * (hash f l)
+
+  let rec equal f l1 l2  =
+    (l1 == l2) ||
+    match (l1,l2) with
+      | (x1,y1)::l1, (x2,y2)::l2 ->
+	  (X.equal x1 x2) && (f y1 y2) && (equal f l1 l2)
+      | _ -> false
+
 end
 
 end

types/sortedList.mli

@@ -80,6 +80,7 @@ sig
     val assoc_present:  'a elem -> ('a,'b) map -> 'b
     val compare: ('b -> 'b -> int) -> ('a,'b) map -> ('a,'b) map -> int
     val hash: ('b -> int) -> ('a,'b) map -> int
+    val equal: ('b -> 'b -> bool) -> ('a,'b) map -> ('a,'b) map -> bool
   end
 end
 

types/types.ml

@@ -44,6 +44,8 @@ let hash_const = function
   | Atom x -> Atoms.vhash x
   | Char x -> Chars.vhash x
 
+let equal_const c1 c2 = compare_const c1 c2 = 0
+
 type pair_kind = [ `Normal | `XML ]
 
 type 'a node0 = { id : int; mutable descr : 'a }

types/types.mli

@@ -6,6 +6,7 @@ type const = | Integer of Intervals.v
 
 val compare_const: const -> const -> int
 val hash_const: const -> int
+val equal_const: const -> const -> bool
 
 (** Algebra **)
 

typing/typer.ml

 (* TODO:
-   rewrite type-checking of operators to propagate constraint *)
+ - rewrite type-checking of operators to propagate constraint
+ - rewrite translation of types and patterns -> hash cons
+*)
+
 
 (* I. Transform the abstract syntax of types and patterns into
       the internal form *)
@@ -165,65 +168,6 @@ module Regexp = struct
 	  defs := (n,d) :: !defs;
 	  v
 
-(*
-  type trans = [ `Alt of gnode * gnode | `Elem of Ast.ppat * gnode | `Final ]
-  and gnode = 
-      {
-	mutable seen  : bool;
-	mutable compile : bool;
-	name  : string;
-	mutable trans : trans;
-      }
-
-  let new_node() = { seen = false; compile = false; 
-		     name = name(); trans = `Final }
-  let to_compile = ref []
-
-  let rec compile after = function
-    | `Epsilon -> after
-    | `Elem (_,p) -> 
-	if not after.compile then (after.compile <- true; 
-				   to_compile := after :: !to_compile);
-	{ new_node () with trans = `Elem (p, after)  }
-    | `Seq(r1,r2) -> compile (compile after r2) r1
-    | `Alt(r1,r2) ->
-	let r1 = compile after r1 and r2 = compile after r2 in
-	{ new_node () with trans = `Alt (r1,r2) }
-    | `Star r ->
-	let n  = new_node() in
-	n.trans <- `Alt (compile n r, after);
-	n
-    | `WeakStar r ->
-	let n  = new_node() in
-	n.trans <- `Alt (after, compile n r);
-	n
-
-  let seens = ref []	
-  let rec collect_aux accu n =
-    if n.seen then accu 
-    else ( seens := n :: !seens;
-	   match n.trans with
-	     | `Alt (n1,n2) -> collect_aux (collect_aux accu n2) n1
-	     | _ -> n :: accu
-	 )
-
-  let collect fin n =
-    let l = collect_aux [] n in
-    List.iter (fun n -> n.seen <- false) !seens;
-    let l = List.map (fun n ->
-			match n.trans with
-			  | `Final -> fin
-			  | `Elem (p,a) -> 
-			      mk !re_loc (Prod(p, mk !re_loc (PatVar a.name)))
-			  | _ -> assert false
-		     ) l in
-    match l with
-      | h::t ->
-	  List.fold_left (fun accu p -> mk !re_loc (Or (accu,p))) h t
-      | _ -> assert false
-*)    
-	
-
   let constant_nil t v = 
     mk_loc !re_loc 
       (And (t, (mk_loc !re_loc (Constant (v, Types.Atom Sequence.nil_atom)))))
@@ -237,15 +181,29 @@ module Regexp = struct
     memo := Memo.empty; 
     let d = !defs in
     defs := [];
+    mk_loc !re_loc (Recurs (n,d))
 
-(*
-    let after = new_node() in
-    let n = collect queue (compile after re) in
-    let d = List.map (fun n -> (n.name, collect queue n)) !to_compile in
-    to_compile := [];
-*)
+  module H = Hashtbl.Make(
+    struct
+      type t = Ast.regexp * Ast.ppat
+      let equal (r1,p1) (r2,p2) = 
+	(Ast.equal_regexp r1 r2) &&
+	(Ast.equal_ppat p1 p2)
+      let hash (r,p) = 
+	(Ast.hash_regexp r) + 16637 * (Ast.hash_ppat p)
+    end)
+  let hash = H.create 67
 
-    mk_loc !re_loc (Recurs (n,d))
+  let compile loc regexp queue : ppat =
+    try 
+      let c = H.find hash (regexp,queue) in
+(*      Printf.eprintf "regexp cached\n"; flush stderr; *)
+      c
+    with
+	Not_found ->
+	  let c = compile loc regexp queue in
+	  H.add hash (regexp,queue) c;
+	  c
 end
 
 let compile_regexp = Regexp.compile noloc