Skip to content

GitLab

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
Expand all Hide whitespace changes
Inline Side-by-side
Makefile.distrib
View file @ e2cc58c4
......@@ -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
View file @ e2cc58c4
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
View file @ e2cc58c4
......@@ -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 0 → 100644
View file @ e2cc58c4
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 0 → 100644
View file @ e2cc58c4
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
View file @ e2cc58c4
......@@ -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
View file @ e2cc58c4
......@@ -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
View file @ e2cc58c4
......@@ -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
View file @ e2cc58c4
......@@ -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
View file @ e2cc58c4
......@@ -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
View file @ e2cc58c4
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
| Some a when is_empty { t1 with atoms = Atoms.empty } -> `Tag a
| Some a when is_empty { t1 with hash=0; atoms = Atoms.empty } -> `Tag a
| _ -> `Type (prepare t1) in
assert (equal { t2 with times = empty.times } empty);
assert (equal { t2 with hash=0; times = empty.times } empty);
List.iter
(fun (ta,tb) -> add (Xml (tag, prepare ta, prepare tb)))
(Product.get t2)
......@@ -1411,7 +1449,7 @@ let rec rec_normalize d =