Commit e2cc58c4 authored by Pietro Abate's avatar Pietro Abate
Browse files

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

Original author: cvscast
Date: 2003-09-24 23:21:10+00:00
parent 100aebe4
...@@ -72,6 +72,7 @@ CLEAN_DIRS = $(DIRS) tools tests ...@@ -72,6 +72,7 @@ CLEAN_DIRS = $(DIRS) tools tests
# Objects to build # Objects to build
OBJECTS = \ OBJECTS = \
misc/stats.cmo \
misc/serialize.cmo misc/custom.cmo \ misc/serialize.cmo misc/custom.cmo \
misc/state.cmo misc/pool.cmo misc/encodings.cmo misc/bool.cmo \ misc/state.cmo misc/pool.cmo misc/encodings.cmo misc/bool.cmo \
misc/pretty.cmo misc/ns.cmo \ misc/pretty.cmo misc/ns.cmo \
......
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.cmo: misc/q_symbol.cmo misc/serialize.cmi
misc/serialize.cmx: 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 misc/custom.cmo: misc/q_symbol.cmo misc/serialize.cmi
......
...@@ -34,6 +34,8 @@ let specs = ...@@ -34,6 +34,8 @@ let specs =
" suppress normal output (typing, results)"; " suppress normal output (typing, results)";
"--stdin", Arg.Unit (fun () -> src := "" :: !src), "--stdin", Arg.Unit (fun () -> src := "" :: !src),
" read CDuce script on standard input"; " read CDuce script on standard input";
"--verbose", Arg.Unit (fun () -> Stats.set_verbosity Stats.Summary),
"print profiling/debugging information";
"-v", Arg.Unit version, "-v", Arg.Unit version,
" print CDuce version"; " print CDuce version";
"--version", Arg.Unit version, "--version", Arg.Unit version,
...@@ -165,5 +167,8 @@ let main () = ...@@ -165,5 +167,8 @@ let main () =
let () = main () let () =
at_exit (fun () -> Stats.dump Format.std_formatter);
main ()
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
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
...@@ -9,7 +9,7 @@ type pprog = pmodule_item list ...@@ -9,7 +9,7 @@ type pprog = pmodule_item list
and pmodule_item = pmodule_item' located and pmodule_item = pmodule_item' located
and pmodule_item' = and pmodule_item' =
| TypeDecl of U.t * ppat | TypeDecl of id * ppat
| SchemaDecl of string * Schema_types.schema (* name, schema *) | SchemaDecl of string * Schema_types.schema (* name, schema *)
| LetDecl of ppat * pexpr | LetDecl of ppat * pexpr
| FunDecl of pexpr | FunDecl of pexpr
...@@ -82,12 +82,12 @@ and branches = (ppat * pexpr) list ...@@ -82,12 +82,12 @@ and branches = (ppat * pexpr) list
and ppat = ppat' located and ppat = ppat' located
and ppat' = and ppat' =
| PatVar of U.t | PatVar of id
| SchemaVar of (* type/pattern schema variable *) | SchemaVar of (* type/pattern schema variable *)
schema_item_kind * string * string schema_item_kind * string * string
| Cst of pexpr | Cst of pexpr
| NsT of U.t | NsT of U.t
| Recurs of ppat * (U.t * ppat) list | Recurs of ppat * (id * ppat) list
| Internal of Types.descr | Internal of Types.descr
| Or of ppat * ppat | Or of ppat * ppat
| And of ppat * ppat | And of ppat * ppat
......
...@@ -92,7 +92,7 @@ EXTEND ...@@ -92,7 +92,7 @@ EXTEND
[ l = LIST0 [ p = phrase ; OPT ";;" -> p ]; EOI -> List.flatten l ] [ l = LIST0 [ p = phrase ; OPT ";;" -> p ]; EOI -> List.flatten l ]
]; ];
uident: [ [ x = IDENT -> parse_ident x ] ]; uident: [ [ x = IDENT -> ident x ] ];
phrase: [ phrase: [
[ (f,p,e) = let_binding -> [ (f,p,e) = let_binding ->
...@@ -192,7 +192,6 @@ EXTEND ...@@ -192,7 +192,6 @@ EXTEND
typ = [ IDENT | keyword ] -> typ = [ IDENT | keyword ] ->
exp loc (Validate (e, schema, typ)) exp loc (Validate (e, schema, typ))
| "fun"; (f,a,b) = fun_decl -> | "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 }) exp loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
| (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"-> | (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
exp loc (Match (e1,[p,e2])) exp loc (Match (e1,[p,e2]))
...@@ -289,7 +288,7 @@ EXTEND ...@@ -289,7 +288,7 @@ EXTEND
| s = STRING2 -> | s = STRING2 ->
let s = U.mk s in let s = U.mk s in
exp loc (String (U.start_index s, U.end_index s, s, cst_nil)) 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 -> | "!"; e = expr ->
exp loc (Apply (Dot (e, U.mk "get"), cst_nil)) exp loc (Apply (Dot (e, U.mk "get"), cst_nil))
| i = INT -> exp loc (Integer (Intervals.V.mk i)) | i = INT -> exp loc (Integer (Intervals.V.mk i))
...@@ -333,7 +332,7 @@ EXTEND ...@@ -333,7 +332,7 @@ EXTEND
[ "let"; is_fun_decl; OPT "fun"; (f,a,b) = fun_decl -> [ "let"; is_fun_decl; OPT "fun"; (f,a,b) = fun_decl ->
let f = match f with Some x -> x | None -> assert false in let f = match f with Some x -> x | None -> assert false in
let p = mk loc (PatVar f) 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 let e = exp loc (Abstraction abst) in
(true,p,e) (true,p,e)
| "let"; p = pat; "="; e = expr -> (false,p,e) | "let"; p = pat; "="; e = expr -> (false,p,e)
...@@ -366,8 +365,9 @@ EXTEND ...@@ -366,8 +365,9 @@ EXTEND
fun_decl: [ fun_decl: [
[ f = OPT uident; "("; (a,b) = fun_decl_after_lparen -> [ f = OPT IDENT; "("; (a,b) = fun_decl_after_lparen ->
(f,a,b) let f = match f with Some x -> Some (ident x) | None -> None in
(f,a,b)
] ]
]; ];
...@@ -399,8 +399,8 @@ EXTEND ...@@ -399,8 +399,8 @@ EXTEND
| x = regexp; "?" -> Alt (x, Epsilon) | x = regexp; "?" -> Alt (x, Epsilon)
| x = regexp; "??" -> Alt (Epsilon, x) ] | x = regexp; "??" -> Alt (Epsilon, x) ]
| [ "("; x = regexp; ")" -> x | [ "("; x = regexp; ")" -> x
| "("; a = IDENT; ":="; c = expr; ")" -> | "("; a = uident; ":="; c = expr; ")" ->
Elem (mk loc (Constant ((ident a,c)))) Elem (mk loc (Constant ((a,c))))
| IDENT "PCDATA" -> string_regexp | IDENT "PCDATA" -> string_regexp
| i = STRING1; "--"; j = STRING1 -> | i = STRING1; "--"; j = STRING1 ->
let i = Chars.V.mk_int (parse_char loc i) let i = Chars.V.mk_int (parse_char loc i)
...@@ -413,8 +413,8 @@ EXTEND ...@@ -413,8 +413,8 @@ EXTEND
let c = Chars.atom c in let c = Chars.atom c in
Seq (Elem (mknoloc (Internal (Types.char c))), accu)) Seq (Elem (mknoloc (Internal (Types.char c))), accu))
(seq_of_string s) (seq_of_string s)
Epsilon Epsilon ]
| e = pat LEVEL "simple" -> Elem e | [ e = pat LEVEL "simple" -> Elem e
] ]
]; ];
......
...@@ -22,7 +22,7 @@ let () = ...@@ -22,7 +22,7 @@ let () =
List.iter List.iter
(fun (n,t) -> (fun (n,t) ->
Typer.register_global_types Typer.register_global_types
[ Ident.U.mk n, [ Ident.ident (Ident.U.mk n),
Location.mknoloc (Ast.Internal t)]) Location.mknoloc (Ast.Internal t)])
types types
......
...@@ -9,6 +9,11 @@ type fv = IdSet.t ...@@ -9,6 +9,11 @@ type fv = IdSet.t
let ident = Id.mk 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 module Label = struct
type t = Ns.qname type t = Ns.qname
......
...@@ -68,7 +68,7 @@ let approx t = ...@@ -68,7 +68,7 @@ let approx t =
let map_tree f seq = let map_tree f seq =
let memo = ref H.empty in let memo = ref H.empty in
let rec aux t = let rec aux t =
(* Printf.eprintf "A"; flush stderr; *) (* Printf.eprintf "A"; flush stderr; *)
try H.find t !memo try H.find t !memo
with Not_found -> with Not_found ->
let v = V.forward () in let v = V.forward () in
......
open Ident open Ident
open Encodings 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 ... To be sure not to use generic comparison ...
*) *)
...@@ -76,6 +81,7 @@ sig ...@@ -76,6 +81,7 @@ sig
but a bug in OCaml 3.07+beta 2 makes it impossible but a bug in OCaml 3.07+beta 2 makes it impossible
*) *)
type t = { type t = {
mutable hash: int;
atoms : Atoms.t; atoms : Atoms.t;
ints : Intervals.t; ints : Intervals.t;
chars : Chars.t; chars : Chars.t;
...@@ -96,6 +102,7 @@ end = ...@@ -96,6 +102,7 @@ end =
struct struct
include Custom.Dummy include Custom.Dummy
type t = { type t = {
mutable hash: int;
atoms : Atoms.t; atoms : Atoms.t;
ints : Intervals.t; ints : Intervals.t;
chars : Chars.t; chars : Chars.t;
...@@ -106,14 +113,16 @@ struct ...@@ -106,14 +113,16 @@ struct
absent: bool absent: bool
} }
let equal a b = let equal a b =
(Atoms.equal a.atoms b.atoms) && (a == b) || (
(Chars.equal a.chars b.chars) && (Atoms.equal a.atoms b.atoms) &&
(Intervals.equal a.ints b.ints) && (Chars.equal a.chars b.chars) &&
(BoolPair.equal a.times b.times) && (Intervals.equal a.ints b.ints) &&
(BoolPair.equal a.xml b.xml) && (BoolPair.equal a.times b.times) &&
(BoolPair.equal a.arrow b.arrow) && (BoolPair.equal a.xml b.xml) &&
(BoolRec.equal a.record b.record) && (BoolPair.equal a.arrow b.arrow) &&
(a.absent == b.absent) (BoolRec.equal a.record b.record) &&
(a.absent == b.absent)
)
let compare a b = let compare a b =
if a == b then 0 if a == b then 0
...@@ -129,15 +138,18 @@ struct ...@@ -129,15 +138,18 @@ struct
else 0 else 0
let hash a = let hash a =
let accu = Chars.hash a.chars in if a.hash <> 0 then a.hash else (
let accu = 17 * accu + Intervals.hash a.ints in let accu = Chars.hash a.chars in
let accu = 17 * accu + Atoms.hash a.atoms in let accu = 17 * accu + Intervals.hash a.ints in
let accu = 17 * accu + BoolPair.hash a.times in let accu = 17 * accu + Atoms.hash a.atoms in
let accu = 17 * accu + BoolPair.hash a.xml in let accu = 17 * accu + BoolPair.hash a.times in
let accu = 17 * accu + BoolPair.hash a.arrow in let accu = 17 * accu + BoolPair.hash a.xml in
let accu = 17 * accu + BoolRec.hash a.record in let accu = 17 * accu + BoolPair.hash a.arrow in
let accu = if a.absent then accu+5 else accu in let accu = 17 * accu + BoolRec.hash a.record in
accu let accu = if a.absent then accu+5 else accu in
a.hash <- accu;
accu
)
let serialize t a = let serialize t a =
Chars.serialize t a.chars; Chars.serialize t a.chars;
...@@ -158,7 +170,8 @@ struct ...@@ -158,7 +170,8 @@ struct
let arrow = BoolPair.deserialize t in let arrow = BoolPair.deserialize t in
let record = BoolRec.deserialize t in let record = BoolRec.deserialize t in
let absent = Serialize.Get.bool 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 } arrow = arrow; record = record; absent = absent }
...@@ -213,6 +226,7 @@ type node = Node.t ...@@ -213,6 +226,7 @@ type node = Node.t
include Descr include Descr
let empty = { let empty = {
hash = 0;
times = BoolPair.empty; times = BoolPair.empty;
xml = BoolPair.empty; xml = BoolPair.empty;
arrow = BoolPair.empty; arrow = BoolPair.empty;
...@@ -224,6 +238,7 @@ let empty = { ...@@ -224,6 +238,7 @@ let empty = {
} }
let any = { let any = {
hash = 0;
times = BoolPair.full; times = BoolPair.full;
xml = BoolPair.full; xml = BoolPair.full;
arrow = BoolPair.full; arrow = BoolPair.full;
...@@ -235,22 +250,26 @@ let any = { ...@@ -235,22 +250,26 @@ let any = {
} }
let non_constructed = 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 interval i = { empty with hash = 0; ints = i }
let times x y = { empty with times = BoolPair.atom (x,y) } let times x y = { empty with hash = 0; times = BoolPair.atom (x,y) }
let xml x y = { empty with xml = BoolPair.atom (x,y) } let xml x y = { empty with hash = 0; xml = BoolPair.atom (x,y) }
let arrow x y = { empty with arrow = BoolPair.atom (x,y) } let arrow x y = { empty with hash = 0; arrow = BoolPair.atom (x,y) }
let record label t = 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) = let record' (x : bool * node Ident.label_map) =
{ empty with record = BoolRec.atom x } { empty with hash = 0; record = BoolRec.atom x }
let atom a = { empty with atoms = a } let atom a = { empty with hash = 0; atoms = a }
let char c = { empty with chars = c } let char c = { empty with hash = 0; chars = c }
let cup x y = let cup x y =
if x == y then x else { if x == y then x else {
hash = 0;
times = BoolPair.cup x.times y.times; times = BoolPair.cup x.times y.times;
xml = BoolPair.cup x.xml y.xml; xml = BoolPair.cup x.xml y.xml;
arrow = BoolPair.cup x.arrow y.arrow; arrow = BoolPair.cup x.arrow y.arrow;
...@@ -263,6 +282,7 @@ let cup x y = ...@@ -263,6 +282,7 @@ let cup x y =
let cap x y = let cap x y =
if x == y then x else { if x == y then x else {
hash = 0;
times = BoolPair.cap x.times y.times; times = BoolPair.cap x.times y.times;
xml = BoolPair.cap x.xml y.xml; xml = BoolPair.cap x.xml y.xml;
record= BoolRec.cap x.record y.record; record= BoolRec.cap x.record y.record;
...@@ -275,6 +295,7 @@ let cap x y = ...@@ -275,6 +295,7 @@ let cap x y =
let diff x y = let diff x y =
if x == y then empty else { if x == y then empty else {
hash = 0;
times = BoolPair.diff x.times y.times; times = BoolPair.diff x.times y.times;
xml = BoolPair.diff x.xml y.xml; xml = BoolPair.diff x.xml y.xml;
arrow = BoolPair.diff x.arrow y.arrow; arrow = BoolPair.diff x.arrow y.arrow;
...@@ -305,18 +326,26 @@ module DescrMap = Map.Make(Descr) ...@@ -305,18 +326,26 @@ module DescrMap = Map.Make(Descr)
module DescrSet = Set.Make(Descr) module DescrSet = Set.Make(Descr)
module DescrSList = SortedList.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 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 make () = incr count; { Node.id = !count; Node.descr = empty }
let define n d = let define n d =
(* DescrHash.add hash_cons d n; *) DescrHash.add hash_cons d n;
n.Node.descr <- d n.Node.descr <- d
let cons d = let cons d =
(* try DescrHash.find hash_cons d with Not_found -> try DescrHash.find hash_cons d
incr count; let n = { id = !count; descr = d } in with Not_found ->
DescrHash.add hash_cons d n; n *) incr count;
incr count; { Node.id = !count; Node.descr = d } let n = { Node.id = !count; Node.descr = d } in
DescrHash.add hash_cons d n; n
let descr n = n.Node.descr let descr n = n.Node.descr
let internalize n = n let internalize n = n
let id n = n.Node.id let id n = n.Node.id
...@@ -342,6 +371,9 @@ let any_node = cons any ...@@ -342,6 +371,9 @@ let any_node = cons any
module LabelS = Set.Make(LabelPool) 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 get_record r =
let labs accu (_,r) = let labs accu (_,r) =
List.fold_left List.fold_left
...@@ -356,8 +388,8 @@ let get_record r = ...@@ -356,8 +388,8 @@ let get_record r =
descrs.(i) <- cap descrs.(i) (descr x); descrs.(i) <- cap descrs.(i) (descr x);
aux (i+1) labs r aux (i+1) labs r
| r -> | r ->
if not o then descrs.(i) <- if not o then
cap descrs.(i) { empty with absent = true }; (* TODO:OPT *) descrs.(i) <- cap descrs.(i) only_absent; (* TODO:OPT *)
aux (i+1) labs r aux (i+1) labs r
in in
aux 0 labs (LabelMap.get r); aux 0 labs (LabelMap.get r);
...@@ -368,7 +400,7 @@ let get_record r = ...@@ -368,7 +400,7 @@ let get_record r =
List.fold_left labs (List.fold_left labs LabelS.empty p) n in List.fold_left labs (List.fold_left labs LabelS.empty p) n in
let labels = LabelS.elements labels in let labels = LabelS.elements labels in
let nlab = List.length 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 pos = mk () in
let opos = List.fold_left let opos = List.fold_left
...@@ -400,7 +432,7 @@ let cap_product any_left any_right l = ...@@ -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)) (fun (d1,d2) (t1,t2) -> (cap_t d1 t1, cap_t d2 t2))
(any_left,any_right) (any_left,any_right)
l l
let any_pair = { empty with times = any.times } let any_pair = { empty with hash = 0; times = any.times }
let rec exists max f =