[r2006-04-21 16:03:53 by afrisch] Tracing the cache

Original author: afrisch
Date: 2006-04-21 16:03:53+00:00

types/types.ml

@@ -1240,7 +1240,9 @@ module Cache = struct
       ~atom:f
 
 
-  let rec type_has_witness t = function (* Special case for empty, any ? *)
+  let rec type_has_witness t w =
+    print_char '?'; flush stdout;
+      match w with
     | WInt i -> Intervals.contains i t.ints
     | WChar c -> Chars.contains c t.chars
     | WAtom a -> Atoms.contains_sample a t.atoms
@@ -1276,32 +1278,53 @@ module Cache = struct
     | WAbsent -> t.absent
     | WAbstract a -> Abstract.contains_sample a t.abstract
 
-
+(*
+  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 * 'a cache * 'a cache
 
+  let steps = ref 0
+
   let rec find f t = function
     | Empty -> 
 	let r = f t in Type (t,r), r
     | Split (w,yes,no) ->
+	incr steps;
+	print_char '.'; flush stdout;
 	if type_has_witness 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 ->
+	Format.fprintf Format.std_formatter "!@.";
 	try 
 	  let w = witness (diff t s) in 
+(*	  Format.fprintf Format.std_formatter "wit:%a@." print_witness w; *)
 	  let rt = f t in 
 	  Split (w, Type (t,rt), c), rt
 	with Not_found -> try
 	  let w = witness (diff s t) in 
+(*	  Format.fprintf Format.std_formatter "wit:%a@." print_witness w; *)
 	  let rt = f t in
 	  Split (w, c, Type (t,rt)), rt
 	with Not_found ->
 	  c, rs
 
+  let find f t c =
+    steps := 0;
+    Format.fprintf Format.std_formatter "begin find@.";
+    let r = find f t c in
+    Format.fprintf Format.std_formatter "steps:%i@." !steps;
+    r
+
   let emp = Empty
 
   let memo f =
@@ -1380,9 +1403,12 @@ struct
 
   module DescrPairMap = Map.Make(Custom.Pair(Descr)(Descr))
 
+  let uniq = (*Cache.memo*) (fun t -> t)
+
   let named = ref DescrMap.empty
   let named_xml = ref DescrPairMap.empty
   let register_global cu (name : Ns.QName.t) d = 
+    let d = uniq d in
     if equal { d with xml = BoolPair.empty } empty then 
       (let l = (*Product.merge_same_2*) (Product.get ~kind:`XML d) in
        match l with
@@ -1395,6 +1421,7 @@ struct
     else named := DescrMap.add d (cu,name) !named
 	
   let unregister_global d =
+    let d = uniq d in
     if equal { d with xml = BoolPair.empty } empty then
       (let l = Product.get ~kind:`XML d in
       match l with
@@ -1439,6 +1466,7 @@ struct
     n >= 5
 
   let rec prepare d =
+    let d = uniq d in
     try DescrHash.find memo d
     with Not_found ->
       try