[r2006-09-11 12:01:39 by afrisch] Empty log message

Original author: afrisch
Date: 2006-09-11 12:01:39+00:00

types/types.ml

@@ -937,6 +937,62 @@ let subtype d1 d2 =
 
 let equiv d1 d2 = (subtype d1 d2) && (subtype d2 d1)
 
+
+module Cache = struct
+(*
+  let type_has_witness t w =
+    Format.fprintf Format.std_formatter
+      "check wit:%a@." print_witness w; 
+    let r = type_has_witness t w in
+    Format.fprintf Format.std_formatter "Done@."; 
+    r
+*)
+
+  type 'a cache =
+    | Empty
+    | Type of t * 'a
+    | Split of Witness.witness * 'a cache * 'a cache
+
+  let rec find f t = function
+    | Empty -> 
+	let r = f t in Type (t,r), r
+    | Split (w,yes,no) ->
+	if Witness.type_has t w 
+	then let yes,r = find f t yes in Split (w,yes,no), r
+	else let no,r = find f t no in Split (w,yes,no), r
+    | Type (s,rs) as c ->
+	let f1 ()= 
+	  let w = witness (diff t s) in 
+	  let rt = f t in 
+	  Split (w, Type (t,rt), c), rt
+	and f2 () =
+	  let w = witness (diff s t) in 
+	  let rt = f t in
+	  Split (w, c, Type (t,rt)), rt in
+
+	if Random.int 2 = 0 then
+	  try f1 () with Not_found -> try f2 () with Not_found -> c, rs
+	else
+	  try f2 () with Not_found -> try f1 () with Not_found -> c, rs
+
+  let emp = Empty
+
+
+  let rec dump_cache f ppf = function
+    | Empty -> Format.fprintf ppf "Empty"
+    | Type (_,s) -> Format.fprintf ppf "*%a" f s
+    | Split (w,c1,c2) -> Format.fprintf ppf "?(%a,%a)"
+	(*Witness.print_witness w *)(dump_cache f) c1 (dump_cache f) c2
+
+  let memo f =
+    let c = ref emp in
+    fun t ->
+      let c',r = find f t !c in
+      c := c';
+      r
+
+end
+
 module Product =
 struct
   type t = (descr * descr) list
@@ -1082,6 +1138,22 @@ struct
       n
 
 
+  let merge_same_first tr =
+    let trs = ref [] in
+    let _ = 
+      List.fold_left
+	(fun memo (t1,t2) ->
+	   let memo',l = 
+	     Cache.find 
+	       (fun t1 -> let l = ref empty in trs := (t1,l) :: !trs; l) 
+	       t1 memo in
+	   l := cup t2 !l;
+	   memo')
+	Cache.emp tr in
+    List.map (fun (t1,l) -> (t1,!l)) !trs
+    
+
+  (* same on second component: use the same implem? *)
   let clean_normal l =
     let rec aux accu (t1,t2) =
       match accu with
@@ -1292,62 +1364,6 @@ struct
 end
 
 
-module Cache = struct
-(*
-  let type_has_witness t w =
-    Format.fprintf Format.std_formatter
-      "check wit:%a@." print_witness w; 
-    let r = type_has_witness t w in
-    Format.fprintf Format.std_formatter "Done@."; 
-    r
-*)
-
-  type 'a cache =
-    | Empty
-    | Type of t * 'a
-    | Split of Witness.witness * 'a cache * 'a cache
-
-  let rec find f t = function
-    | Empty -> 
-	let r = f t in Type (t,r), r
-    | Split (w,yes,no) ->
-	if Witness.type_has t w 
-	then let yes,r = find f t yes in Split (w,yes,no), r
-	else let no,r = find f t no in Split (w,yes,no), r
-    | Type (s,rs) as c ->
-	let f1 ()= 
-	  let w = witness (diff t s) in 
-	  let rt = f t in 
-	  Split (w, Type (t,rt), c), rt
-	and f2 () =
-	  let w = witness (diff s t) in 
-	  let rt = f t in
-	  Split (w, c, Type (t,rt)), rt in
-
-	if Random.int 2 = 0 then
-	  try f1 () with Not_found -> try f2 () with Not_found -> c, rs
-	else
-	  try f2 () with Not_found -> try f1 () with Not_found -> c, rs
-
-  let emp = Empty
-
-
-  let rec dump_cache f ppf = function
-    | Empty -> Format.fprintf ppf "Empty"
-    | Type (_,s) -> Format.fprintf ppf "*%a" f s
-    | Split (w,c1,c2) -> Format.fprintf ppf "?(%a,%a)"
-	(*Witness.print_witness w *)(dump_cache f) c1 (dump_cache f) c2
-
-  let memo f =
-    let c = ref emp in
-    fun t ->
-      let c',r = find f t !c in
-      c := c';
-      r
-
-end
-
-
 module Print = 
 struct
   let rec print_const ppf = function
@@ -1542,6 +1558,7 @@ struct
     Decompile.decompile 
       (fun t -> 
 	 let tr = Product.get t in 
+	 let tr = Product.merge_same_first tr in
 	 let tr = Product.clean_normal tr in
 
 	 let eps = Atoms.contains nil_atom t.atoms in