[r2003-09-24 23:21:08 by cvscast] Cleaning

Original author: cvscast
Date: 2003-09-24 23:21:10+00:00

Makefile.distrib

@@ -72,6 +72,7 @@ CLEAN_DIRS = $(DIRS) tools tests
 # Objects to build
 
 OBJECTS = \
+ misc/stats.cmo \
  misc/serialize.cmo misc/custom.cmo \
  misc/state.cmo misc/pool.cmo misc/encodings.cmo misc/bool.cmo \
  misc/pretty.cmo misc/ns.cmo \

depend

+misc/stats.cmo: misc/q_symbol.cmo misc/stats.cmi 
+misc/stats.cmx: misc/q_symbol.cmo misc/stats.cmi 
 misc/serialize.cmo: misc/q_symbol.cmo misc/serialize.cmi 
 misc/serialize.cmx: misc/q_symbol.cmo misc/serialize.cmi 
 misc/custom.cmo: misc/q_symbol.cmo misc/serialize.cmi 

driver/run.ml

@@ -34,6 +34,8 @@ let specs =
            "  suppress normal output (typing, results)";
     "--stdin", Arg.Unit (fun () -> src := "" :: !src),
            "  read CDuce script on standard input";
+    "--verbose", Arg.Unit (fun () -> Stats.set_verbosity Stats.Summary),
+             "print profiling/debugging information";
     "-v", Arg.Unit version,
       "       print CDuce version";
     "--version", Arg.Unit version,
@@ -165,5 +167,8 @@ let main () =
 
 
 
-let () = main ()
+let () = 
+  at_exit (fun () -> Stats.dump Format.std_formatter);
+  main ()
+
 

misc/stats.ml

+type verbosity = Quiet | Summary | Details
+let verbosity = ref Quiet
+let set_verbosity = (:=) verbosity
+
+let todo = ref []
+
+let register level f = todo := (level,f) :: !todo
+
+let dump ppf =
+  List.iter (function
+	       | (level,f) when level <= !verbosity -> f ppf
+	       | _ -> ()) !todo
+
+module Timer = struct
+  type t = {
+    name: string;
+    mutable count : int;
+    mutable total : float;
+    mutable last  : float;
+    mutable is_in : bool;
+  }
+
+  let print ppf c =
+    Format.fprintf ppf "Timer %s@\n Total time: %f@\n Count: %i@\n"
+      c.name c.total c.count
+      
+  let create s = 
+    let c = { name = s; count = 0; total = 0.; last = 0.; is_in = false } in
+    register Summary (fun ppf -> print ppf c);
+    c
+      
+  let start c =
+    assert(not c.is_in);
+    c.is_in <- true;
+    c.last <- Unix.gettimeofday();
+    c.count <- c.count + 1
+      
+  let stop c =
+    assert(c.is_in);
+    c.is_in <- false;
+    c.total <- c.total +. (Unix.gettimeofday () -. c.last)
+end

misc/stats.mli

+type verbosity = Quiet | Summary | Details
+val set_verbosity: verbosity -> unit
+
+val register: verbosity -> (Format.formatter -> unit) -> unit
+val dump: Format.formatter -> unit
+
+module Timer: sig
+  type t
+    
+  val create: string -> t
+  val start: t -> unit
+  val stop: t -> unit
+  val print: Format.formatter -> t -> unit
+end

parser/ast.ml

@@ -9,7 +9,7 @@ type pprog = pmodule_item list
 
 and pmodule_item = pmodule_item' located
 and pmodule_item' =
-  | TypeDecl of U.t * ppat
+  | TypeDecl of id * ppat
   | SchemaDecl of string * Schema_types.schema  (* name, schema *)
   | LetDecl of ppat * pexpr
   | FunDecl of pexpr
@@ -82,12 +82,12 @@ and branches = (ppat * pexpr) list
 
 and ppat = ppat' located
 and ppat' =
-  | PatVar of U.t
+  | PatVar of id
   | SchemaVar of  (* type/pattern schema variable *)
       schema_item_kind * string * string
   | Cst of pexpr
   | NsT of U.t
-  | Recurs of ppat * (U.t * ppat) list
+  | Recurs of ppat * (id * ppat) list
   | Internal of Types.descr
   | Or of ppat * ppat
   | And of ppat * ppat

parser/parser.ml

@@ -92,7 +92,7 @@ EXTEND
     [ l = LIST0 [ p = phrase ; OPT ";;" -> p ]; EOI -> List.flatten l ]
   ];
 
-  uident: [ [ x = IDENT -> parse_ident x ] ];
+  uident: [ [ x = IDENT -> ident x ] ];
 
   phrase: [
     [ (f,p,e) = let_binding -> 
@@ -192,7 +192,6 @@ EXTEND
       typ = [ IDENT | keyword ] ->
         exp loc (Validate (e, schema, typ))
     | "fun"; (f,a,b) = fun_decl ->
-	let f = match f with Some x -> Some (Ident.ident x) | None -> None in
 	exp loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
     | (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
         exp loc (Match (e1,[p,e2]))
@@ -289,7 +288,7 @@ EXTEND
     | s = STRING2 ->
 	let s = U.mk s in
 	exp loc (String (U.start_index s, U.end_index s, s, cst_nil))
-    | a = IDENT -> exp loc (Var (ident a))
+    | a = uident -> exp loc (Var a)
     | "!"; e = expr ->
 	exp loc (Apply (Dot (e, U.mk "get"), cst_nil))
     | i = INT -> exp loc (Integer (Intervals.V.mk i))
@@ -333,7 +332,7 @@ EXTEND
     [ "let"; is_fun_decl; OPT "fun"; (f,a,b) = fun_decl ->
 	let f = match f with Some x -> x | None -> assert false in
 	let p = mk loc (PatVar f) in
-	let abst = { fun_name = Some (Ident.ident f); fun_iface = a; fun_body = b } in
+	let abst = { fun_name = Some f; fun_iface = a; fun_body = b } in
         let e = exp loc (Abstraction abst) in
         (true,p,e)
     | "let"; p = pat; "="; e = expr -> (false,p,e)
@@ -366,8 +365,9 @@ EXTEND
 
 
  fun_decl: [
-   [ f = OPT uident; "("; (a,b) = fun_decl_after_lparen ->
-	    (f,a,b)
+   [ f = OPT IDENT; "("; (a,b) = fun_decl_after_lparen ->
+       let f = match f with Some x -> Some (ident x) | None -> None in
+       (f,a,b)
    ]
  ];
 
@@ -399,8 +399,8 @@ EXTEND
     | x = regexp; "?" ->  Alt (x, Epsilon)
     | x = regexp; "??" -> Alt (Epsilon, x) ]
   | [ "("; x = regexp; ")" -> x
-    | "("; a = IDENT; ":="; c = expr; ")" -> 
-	Elem (mk loc (Constant ((ident a,c))))
+    | "("; a = uident; ":="; c = expr; ")" -> 
+	Elem (mk loc (Constant ((a,c))))
     | IDENT "PCDATA" -> string_regexp
     | i = STRING1; "--"; j = STRING1 ->
 	let i = Chars.V.mk_int (parse_char loc i)
@@ -413,8 +413,8 @@ EXTEND
 	     let c = Chars.atom c in
 	     Seq (Elem (mknoloc (Internal (Types.char c))), accu))
 	  (seq_of_string s)
-	  Epsilon 
-    | e = pat LEVEL "simple" -> Elem e
+	  Epsilon ]
+    | [ e = pat LEVEL "simple" -> Elem e
     ]
   ];
 

types/builtin.ml

@@ -22,7 +22,7 @@ let () =
   List.iter
     (fun (n,t) -> 
        Typer.register_global_types 
-         [ Ident.U.mk n, 
+         [ Ident.ident (Ident.U.mk n), 
 	   Location.mknoloc (Ast.Internal t)]) 
     types
 

types/ident.ml

@@ -9,6 +9,11 @@ type fv = IdSet.t
 
 let ident = Id.mk
 
+let to_string id =
+  U.to_string (Id.value id)
+
+let print ppf id =
+  Format.fprintf ppf "%s" (to_string id)
 
 module Label = struct
   type t = Ns.qname

types/sequence.ml

@@ -68,7 +68,7 @@ let approx t =
 let map_tree f seq =
   let memo = ref H.empty in
   let rec aux t =
-(*    Printf.eprintf "A"; flush stderr; *)
+ (*   Printf.eprintf "A"; flush stderr; *)
     try H.find t !memo
     with Not_found ->
       let v = V.forward () in

types/types.ml

 open Ident
 open Encodings
 
+(* TODO:
+   - I store hash in types to avoid computing it several times.
+     Does not seem to help a lot.
+*)
+
 (*
 To be sure not to use generic comparison ...
 *)
@@ -76,6 +81,7 @@ sig
   but a  bug in OCaml 3.07+beta 2 makes it impossible
 *)
   type t = {
+    mutable hash: int;
     atoms : Atoms.t;
     ints  : Intervals.t;
     chars : Chars.t;
@@ -96,6 +102,7 @@ end =
 struct
   include Custom.Dummy
   type t = {
+    mutable hash: int;
     atoms : Atoms.t;
     ints  : Intervals.t;
     chars : Chars.t;
@@ -106,14 +113,16 @@ struct
     absent: bool
   }
   let equal a b =
-    (Atoms.equal a.atoms b.atoms) &&
-    (Chars.equal a.chars b.chars) &&
-    (Intervals.equal a.ints  b.ints) &&
-    (BoolPair.equal a.times b.times) &&
-    (BoolPair.equal a.xml b.xml) &&
-    (BoolPair.equal a.arrow b.arrow) &&
-    (BoolRec.equal a.record b.record) &&
-    (a.absent == b.absent)
+    (a == b) || (
+      (Atoms.equal a.atoms b.atoms) &&
+      (Chars.equal a.chars b.chars) &&
+      (Intervals.equal a.ints  b.ints) &&
+      (BoolPair.equal a.times b.times) &&
+      (BoolPair.equal a.xml b.xml) &&
+      (BoolPair.equal a.arrow b.arrow) &&
+      (BoolRec.equal a.record b.record) &&
+      (a.absent == b.absent)
+    )
 
   let compare a b =
     if a == b then 0 
@@ -129,15 +138,18 @@ struct
     else 0
       
   let hash a =
-    let accu = Chars.hash a.chars in
-    let accu = 17 * accu + Intervals.hash a.ints in
-    let accu = 17 * accu + Atoms.hash a.atoms in
-    let accu = 17 * accu + BoolPair.hash a.times in
-    let accu = 17 * accu + BoolPair.hash a.xml in
-    let accu = 17 * accu + BoolPair.hash a.arrow in
-    let accu = 17 * accu + BoolRec.hash a.record in
-    let accu = if a.absent then accu+5 else accu in
-    accu
+    if a.hash <> 0 then a.hash else (
+      let accu = Chars.hash a.chars in
+      let accu = 17 * accu + Intervals.hash a.ints in
+      let accu = 17 * accu + Atoms.hash a.atoms in
+      let accu = 17 * accu + BoolPair.hash a.times in
+      let accu = 17 * accu + BoolPair.hash a.xml in
+      let accu = 17 * accu + BoolPair.hash a.arrow in
+      let accu = 17 * accu + BoolRec.hash a.record in
+      let accu = if a.absent then accu+5 else accu in
+      a.hash <- accu;
+      accu
+    )
 
   let serialize t a =
     Chars.serialize t a.chars;
@@ -158,7 +170,8 @@ struct
     let arrow = BoolPair.deserialize t in
     let record = BoolRec.deserialize t in
     let absent = Serialize.Get.bool t in
-    { chars = chars; ints = ints; atoms = atoms; times = times; xml = xml;
+    { hash=0; 
+      chars = chars; ints = ints; atoms = atoms; times = times; xml = xml;
       arrow = arrow; record = record; absent = absent }
    
     
@@ -213,6 +226,7 @@ type node = Node.t
 include Descr
 	       
 let empty = { 
+  hash = 0;
   times = BoolPair.empty; 
   xml   = BoolPair.empty; 
   arrow = BoolPair.empty; 
@@ -224,6 +238,7 @@ let empty = {
 }
 	      
 let any =  {
+  hash = 0;
   times = BoolPair.full; 
   xml   = BoolPair.full; 
   arrow = BoolPair.full; 
@@ -235,22 +250,26 @@ let any =  {
 }
 
 let non_constructed =
-  { any with times = empty.times; xml = empty.xml; record = empty.record }
+  { any with  
+      hash = 0;
+      times = empty.times; xml = empty.xml; record = empty.record }
      
 	     
-let interval i = { empty with ints = i }
-let times x y = { empty with times = BoolPair.atom (x,y) }
-let xml x y = { empty with xml = BoolPair.atom (x,y) }
-let arrow x y = { empty with arrow = BoolPair.atom (x,y) }
+let interval i = { empty with hash = 0; ints = i }
+let times x y = { empty with hash = 0; times = BoolPair.atom (x,y) }
+let xml x y = { empty with hash = 0; xml = BoolPair.atom (x,y) }
+let arrow x y = { empty with hash = 0; arrow = BoolPair.atom (x,y) }
 let record label t = 
-  { empty with record = BoolRec.atom (true,LabelMap.singleton label t) }
+  { empty with hash = 0; 
+      record = BoolRec.atom (true,LabelMap.singleton label t) }
 let record' (x : bool * node Ident.label_map) =
-  { empty with record = BoolRec.atom x }
-let atom a = { empty with atoms = a }
-let char c = { empty with chars = c }
+  { empty with hash = 0; record = BoolRec.atom x }
+let atom a = { empty with hash = 0; atoms = a }
+let char c = { empty with hash = 0; chars = c }
       
 let cup x y = 
   if x == y then x else {
+    hash = 0;
     times = BoolPair.cup x.times y.times;
     xml   = BoolPair.cup x.xml y.xml;
     arrow = BoolPair.cup x.arrow y.arrow;
@@ -263,6 +282,7 @@ let cup x y =
     
 let cap x y = 
   if x == y then x else {
+    hash = 0;
     times = BoolPair.cap x.times y.times;
     xml   = BoolPair.cap x.xml y.xml;
     record= BoolRec.cap x.record y.record;
@@ -275,6 +295,7 @@ let cap x y =
     
 let diff x y = 
   if x == y then empty else {
+    hash = 0;
     times = BoolPair.diff x.times y.times;
     xml   = BoolPair.diff x.xml y.xml;
     arrow = BoolPair.diff x.arrow y.arrow;
@@ -305,18 +326,26 @@ module DescrMap = Map.Make(Descr)
 module DescrSet = Set.Make(Descr)
 module DescrSList = SortedList.Make(Descr)
 
-(* let hash_cons = DescrHash.create 17000 *)
+let hash_cons = DescrHash.create 17000  
 
 let count = State.ref "Types.count" 0
+
+let () =
+  Stats.register Stats.Summary
+    (fun ppf -> Format.fprintf ppf "Allocated type nodes:%i@\n" !count)
+
 let make () = incr count; { Node.id = !count; Node.descr = empty }
 let define n d = 
-(*  DescrHash.add hash_cons d n; *)
+  DescrHash.add hash_cons d n; 
   n.Node.descr <- d
 let cons d = 
-(*   try DescrHash.find hash_cons d with Not_found ->
-  incr count; let n = { id = !count; descr = d } in
-  DescrHash.add hash_cons d n; n  *)
-  incr count; { Node.id = !count; Node.descr = d }
+  try DescrHash.find hash_cons d 
+  with Not_found ->
+    incr count; 
+    let n = { Node.id = !count; Node.descr = d } in
+    DescrHash.add hash_cons d n; n  
+
+
 let descr n = n.Node.descr
 let internalize n = n
 let id n = n.Node.id
@@ -342,6 +371,9 @@ let any_node = cons any
 
 module LabelS = Set.Make(LabelPool)
 
+let any_or_absent = { any with hash=0; absent = true } 
+let only_absent = { empty with hash=0; absent = true }
+
 let get_record r =
   let labs accu (_,r) = 
     List.fold_left 
@@ -356,8 +388,8 @@ let get_record r =
 		  descrs.(i) <- cap descrs.(i) (descr x);
 		  aux (i+1) labs r
 	      | r ->
-		  if not o then descrs.(i) <- 
-		    cap descrs.(i) { empty with absent = true }; (* TODO:OPT *)
+		  if not o then 
+		    descrs.(i) <- cap descrs.(i) only_absent; (* TODO:OPT *)
 		  aux (i+1) labs r
     in
     aux 0 labs (LabelMap.get r);
@@ -368,7 +400,7 @@ let get_record r =
       List.fold_left labs (List.fold_left labs LabelS.empty p) n in
     let labels = LabelS.elements labels in
     let nlab = List.length labels in
-    let mk () = Array.create nlab { any with absent = true } in
+    let mk () = Array.create nlab any_or_absent in
 
     let pos = mk () in
     let opos = List.fold_left 
@@ -400,7 +432,7 @@ let cap_product any_left any_right l =
     (fun (d1,d2) (t1,t2) -> (cap_t d1 t1, cap_t d2 t2))
     (any_left,any_right)
     l
-let any_pair = { empty with times = any.times }
+let any_pair = { empty with hash = 0; times = any.times }
 
 
 let rec exists max f =
@@ -553,6 +585,8 @@ let clearly_disjoint t1 t2 =
 *)
   trivially_disjoint t1 t2 || ClearlyEmpty.is_empty (cap t1 t2) 
 
+(* TODO: need to invesigate when ClearEmpty is a good thing... *)
+
 let memo = DescrHash.create 33000
 let marks = ref [] 
 
@@ -659,13 +693,17 @@ and check_record (labels,(oleft,left),rights) s =
   start (Array.length left - 1) s
 
 
+let timer_subtype = Stats.Timer.create "Types.is_empty"
+
 let is_empty d =
+  Stats.Timer.start timer_subtype;
   let s = slot d in
   List.iter 
     (fun s' -> 
        if s'.status == Maybe then s'.status <- Empty; s'.notify <- Nothing) 
     !marks;
   marks := [];
+  Stats.Timer.stop timer_subtype;
   s.status == Empty
 
 (*
@@ -690,8 +728,8 @@ struct
 
   let other ?(kind=`Normal) d = 
     match kind with
-      | `Normal -> { d with times = empty.times }
-      | `XML -> { d with xml = empty.xml }
+      | `Normal -> { d with hash = 0; times = empty.times }
+      | `XML -> { d with hash = 0; xml = empty.xml }
 
   let is_product ?kind d = is_empty (other ?kind d)
 
@@ -828,19 +866,19 @@ struct
       any
       n
 
-  let any = { empty with times = any.times }
-  and any_xml = { empty with xml = any.xml }
+  let any = { empty with hash = 0; times = any.times }
+  and any_xml = { empty with hash = 0; xml = any.xml }
   let is_empty d = d == []
 end
 
 module Record = 
 struct
-  let has_record d = not (is_empty { empty with record = d.record })
-  let or_absent d = { d with absent = true }
+  let has_record d = not (is_empty { empty with hash= 0; record = d.record })
+  let or_absent d = { d with hash = 0; absent = true }
   let any_or_absent = or_absent any
   let has_absent d = d.absent
 
-  let only_absent = {empty with absent = true}
+  let only_absent = {empty with hash = 0; absent = true}
   let only_absent_node = cons only_absent
 
   module T = struct
@@ -854,7 +892,7 @@ struct
   end
   module R = struct
     type t = descr
-    let any = { empty with record = any.record }
+    let any = { empty with hash = 0; record = any.record }
     let cap = cap
     let cup = cup
     let diff = diff
@@ -863,11 +901,11 @@ struct
   end
   module TR = Normal.Make(T)(R)
 
-  let any_record = { empty with record = BoolRec.full }
+  let any_record = { empty with hash = 0; record = BoolRec.full }
 
   let atom o l = 
     if o && LabelMap.is_empty l then any_record else
-    { empty with record = BoolRec.atom (o,l) }
+    { empty with hash = 0; record = BoolRec.atom (o,l) }
 
   type zor = Pair of descr * descr | Any
 
@@ -879,10 +917,10 @@ struct
       with Not_found -> 
 	if o then
 	  if LabelMap.is_empty r then Any else
-	    Pair (any_or_absent, { empty with record = BoolRec.atom (o,r) })
+	    Pair (any_or_absent, { empty with hash=0; record = BoolRec.atom (o,r) })
 	else
 	  Pair (only_absent,
-		{ empty with record = BoolRec.atom (o,r) })
+		{ empty with hash = 0; record = BoolRec.atom (o,r) })
     in
     List.fold_left 
       (fun b (p,n) ->
@@ -916,7 +954,7 @@ struct
 
   let project_opt d l =
     let t = TR.pi1 (split d l) in
-    { t with absent = false }
+    { t with hash = 0; absent = false }
 
   let condition d l t =
     TR.pi2_restricted t (split d l)
@@ -979,7 +1017,7 @@ struct
 	let loop (t1,d1) (t2,d2) =
 	  let t = 
 	    if t2.absent 
-	    then cup t1 { t2 with absent = false } 
+	    then cup t1 { t2 with hash = 0; absent = false } 
 	    else t2 
 	  in
 	  aux ((l,cons t)::accu) d1 d2
@@ -990,7 +1028,7 @@ struct
     aux [] d1 d2;
     !res
 
-  let any = { empty with record = any.record }
+  let any = { empty with hash = 0; record = any.record }
 
   let get d =
     let rec aux r accu d =
@@ -1001,7 +1039,7 @@ struct
       else
 	List.fold_left 
 	  (fun accu (t1,t2) -> 
-	     let x = (t1.absent, { t1 with absent = false }) in
+	     let x = (t1.absent, { t1 with hash = 0; absent = false }) in
 	     aux ((l,x)::r) accu t2)
 	  accu
 	  (split d l)
@@ -1066,7 +1104,7 @@ struct
   let named = State.ref "Types.Print.named" DescrMap.empty
   let named_xml = State.ref "Types.Print.named_xml"  DescrPairMap.empty
   let register_global (name : U.t) d = 
-    if equal { d with xml = BoolPair.empty } empty then 
+    if equal { d with hash = 0; xml = BoolPair.empty } empty then 
       (let l = (*Product.merge_same_2*) (Product.get ~kind:`XML d) in
       match l with
 	| [(t1,t2)] -> named_xml := DescrPairMap.add (t1,t2) name !named_xml
@@ -1086,7 +1124,7 @@ struct
 
   let trivial_rec b = 
     b == BoolRec.empty || 
-    (is_empty { empty with record = BoolRec.diff BoolRec.full b})
+    (is_empty { empty with hash = 0; record = BoolRec.diff BoolRec.full b})
 
   let trivial_pair b = b == BoolPair.empty || b == BoolPair.full
 
@@ -1123,7 +1161,7 @@ struct
 	if not (worth_abbrev d) then slot.state <- `Expand;
 	DescrHash.add memo d slot;
 	let (seq,not_seq) =
-	  if (subtype { empty with times = d.times } seqs_descr) then
+	  if (subtype { empty with hash = 0; times = d.times } seqs_descr) then
 	    (cap d seqs_descr, diff d seqs_descr)
 	  else
 	    (empty, d) in
@@ -1143,9 +1181,9 @@ struct
 		 Not_found ->
 	     let tag = 
 	       match Atoms.print_tag t1.atoms with