[r2002-12-13 17:40:44 by cvscast] Empty log message

Original author: cvscast
Date: 2002-12-13 17:40:45+00:00

driver/run.ml

@@ -60,4 +60,4 @@ let main () =
 
 
 
-let () = main ()
+let () = main (); Types.print_stat ppf_err

tests/fixml4.3v20020920.cd

@@ -1562,3 +1562,5 @@ type ApplicationMessage =
           ];;
 type FIXMLMessage = <FIXMLMessage>[ (Header ApplicationMessage) ];;
 type FIXML = <FIXML>[ FIXMLMessage+ ];;
+
+debug compile Any FIXML;;
\ No newline at end of file

types/recursive.ml

@@ -44,4 +44,7 @@ sig
 
   val hash_descr: descr -> int
   val equal_descr: descr -> descr -> bool
+
+  val is_recurs: node -> bool
+  val is_recurs_descr: descr -> bool
 end

types/recursive_noshare.ml

@@ -8,6 +8,14 @@ struct
   type node = { 
     id : int; 
     mutable descr : descr;
+
+    mutable recurs : int;
+      (*   -1     means "not yet computed"
+           -2     means "no"
+           -3     means "marked"
+           id>=0  means "yes"
+      *)
+    mutable marked : int;
   }
   and descr = node X.t
 
@@ -20,6 +28,9 @@ struct
     { 
       id = !counter;
       descr = Obj.magic 0;
+
+      recurs = -1;
+      marked = -1;
     }
 
   let equal x y = x.id = y.id
@@ -41,4 +52,43 @@ struct
 	d1 d2; 
       true
     with NotEqual -> false
+
+
+(*
+  let rec mark_path start = function
+    | [] -> ()
+    | n::q -> if n.recurs = -3 then (n.recurs <- start; mark_path start q)
+
+(* This algo is wrong: rework it ... *)
+  let rec compute_recurs path start n =
+    match n.recurs with
+      | -3 -> n.recurs <- start; mark_path start path
+      | -1 -> 
+	  n.recurs <- (-3); 
+	  X.iter (compute_recurs (n :: path) start) n.descr;
+	  if n.recurs = -3 then n.recurs <- (-2)
+      | id when id = start -> mark_path start path
+      | _ -> ()  (* "no" or id <> start *)
+
+  let is_recurs n = 
+    if (n.recurs = -1) then compute_recurs [] n.id n;
+    n.recurs >= 0
+*)
+  let rec compute_recurs start n =
+    if n.marked = start then (if n.id = start then raise Exit) else
+      (
+	n.marked <- start;
+	X.iter (compute_recurs start) n.descr
+      )
+
+  let is_recurs n = 
+(*    if (n.recurs = -1) then 
+      (try compute_recurs n.id n; n.recurs <- (-2)
+       with Exit -> n.recurs <- 1); *)
+(*    n.recurs >= 0 *)
+    true
+
+  let is_recurs_descr d =
+    try X.iter (fun n -> if is_recurs n then raise Exit) d; false
+    with Exit -> true
 end

types/types.ml

@@ -293,6 +293,8 @@ let cache_false = ref Assumptions.empty
 
 exception NotEmpty
 
+let nb_rec = ref 0 and nb_norec = ref 0
+
 let rec empty_rec d =
   if Assumptions.mem d !cache_false then false 
   else if Assumptions.mem d !memo then true
@@ -301,7 +303,9 @@ let rec empty_rec d =
   else if not (Chars.is_empty d.chars) then false
   else (
     let backup = !memo in
-    memo := Assumptions.add d backup;
+    if is_recurs_descr d then 
+    (incr nb_rec; memo := Assumptions.add d backup)
+    else incr nb_norec;
     if 
       (empty_rec_times d.times) &&
       (empty_rec_times d.xml) &&
@@ -430,7 +434,8 @@ let is_empty d =
 (*  Printf.eprintf "+"; flush stderr; *)
   let old = !memo in
   let r = empty_rec d in
-  if not r then memo := old; 
+  if not r then memo := old
+  else if not (is_recurs_descr d) then memo := Assumptions.add d !memo;
 (*  cache_false := Assumptions.empty;  *)
 (*  Printf.eprintf "-\n"; flush stderr; *)
   r
@@ -1434,6 +1439,11 @@ module Char = struct
   let any = { empty with chars = Chars.any }
 end
 
+let print_stat ppf =
+  Format.fprintf ppf "nb_rec = %i@." !nb_rec;
+  Format.fprintf ppf "nb_norec = %i@." !nb_norec;
+  ()
+
 (*
 let rec print_normal_record ppf = function
   | Success -> Format.fprintf ppf "Yes"

types/types.mli

@@ -225,3 +225,4 @@ sig
 end
 
 val check: descr -> unit
+val print_stat: Format.formatter -> unit