Skip to content

GitLab

Commit 51d2ccfe authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-05-24 12:26:59 by afrisch] Empty log message 

Original author: afrisch
Date: 2005-05-24 12:26:59+00:00
parent 242b7f18
Show whitespace changes
Inline Side-by-side
Makefile.distrib
View file @ 51d2ccfe
......@@ -141,6 +141,7 @@ SCHEMA_OBJS = \
OBJECTS = \
driver/config.cmo \
misc/stats.cmo \
misc/ptmap.cmo misc/hashset.cmo \
misc/serialize.cmo misc/custom.cmo \
misc/state.cmo misc/pool.cmo misc/encodings.cmo \
misc/pretty.cmo misc/ns.cmo misc/inttbl.cmo misc/imap.cmo \
......
depend
View file @ 51d2ccfe
......@@ -2,6 +2,10 @@ driver/config.cmo: driver/config.cmi
driver/config.cmx: driver/config.cmi
misc/stats.cmo: misc/stats.cmi
misc/stats.cmx: misc/stats.cmi
misc/ptmap.cmo: misc/ptmap.cmi
misc/ptmap.cmx: misc/ptmap.cmi
misc/hashset.cmo: misc/ptmap.cmi misc/hashset.cmi
misc/hashset.cmx: misc/ptmap.cmx misc/hashset.cmi
misc/serialize.cmo: misc/serialize.cmi
misc/serialize.cmx: misc/serialize.cmi
misc/custom.cmo: misc/serialize.cmi
......@@ -14,8 +18,6 @@ misc/pool.cmx: misc/state.cmx misc/serialize.cmx misc/custom.cmx \
misc/pool.cmi
misc/encodings.cmo: misc/serialize.cmi misc/custom.cmo misc/encodings.cmi
misc/encodings.cmx: misc/serialize.cmx misc/custom.cmx misc/encodings.cmi
misc/bool.cmo: misc/serialize.cmi misc/custom.cmo misc/bool.cmi
misc/bool.cmx: misc/serialize.cmx misc/custom.cmx misc/bool.cmi
misc/pretty.cmo: misc/pretty.cmi
misc/pretty.cmx: misc/pretty.cmi
misc/ns.cmo: misc/state.cmi misc/serialize.cmi misc/pool.cmi \
......@@ -30,6 +32,10 @@ misc/html.cmo: misc/html.cmi
misc/html.cmx: misc/html.cmi
types/sortedList.cmo: misc/serialize.cmi misc/custom.cmo types/sortedList.cmi
types/sortedList.cmx: misc/serialize.cmx misc/custom.cmx types/sortedList.cmi
misc/bool.cmo: types/sortedList.cmi misc/serialize.cmi misc/custom.cmo \
misc/bool.cmi
misc/bool.cmx: types/sortedList.cmx misc/serialize.cmx misc/custom.cmx \
misc/bool.cmi
types/boolean.cmo: types/sortedList.cmi misc/custom.cmo types/boolean.cmi
types/boolean.cmx: types/sortedList.cmx misc/custom.cmx types/boolean.cmi
types/ident.cmo: types/sortedList.cmi misc/pool.cmi misc/ns.cmi \
......@@ -49,13 +55,13 @@ types/normal.cmx: types/normal.cmi
types/types.cmo: misc/stats.cmi misc/state.cmi types/sortedList.cmi \
misc/serialize.cmi misc/pretty.cmi misc/pool.cmi misc/ns.cmi \
types/normal.cmi misc/inttbl.cmi types/intervals.cmi types/ident.cmo \
misc/encodings.cmi misc/custom.cmo types/chars.cmi misc/bool.cmi \
types/atoms.cmi types/types.cmi
misc/hashset.cmi misc/encodings.cmi misc/custom.cmo types/chars.cmi \
misc/bool.cmi types/atoms.cmi types/types.cmi
types/types.cmx: misc/stats.cmx misc/state.cmx types/sortedList.cmx \
misc/serialize.cmx misc/pretty.cmx misc/pool.cmx misc/ns.cmx \
types/normal.cmx misc/inttbl.cmx types/intervals.cmx types/ident.cmx \
misc/encodings.cmx misc/custom.cmx types/chars.cmx misc/bool.cmx \
types/atoms.cmx types/types.cmi
misc/hashset.cmx misc/encodings.cmx misc/custom.cmx types/chars.cmx \
misc/bool.cmx types/atoms.cmx types/types.cmi
types/sample.cmo: types/types.cmi types/intervals.cmi types/ident.cmo \
types/chars.cmi types/atoms.cmi types/sample.cmi
types/sample.cmx: types/types.cmx types/intervals.cmx types/ident.cmx \
......@@ -350,11 +356,12 @@ runtime/cduce_pxp.cmo: parser/url.cmi schema/schema_xml.cmi \
runtime/cduce_pxp.cmx: parser/url.cmx schema/schema_xml.cmx \
parser/location.cmx runtime/load_xml.cmx driver/config.cmx \
runtime/cduce_pxp.cmi
misc/hashset.cmi: misc/pretty.cmi
misc/pool.cmi: misc/custom.cmo
misc/encodings.cmi: misc/serialize.cmi misc/custom.cmo
misc/bool.cmi: misc/custom.cmo
misc/ns.cmi: misc/serialize.cmi misc/encodings.cmi misc/custom.cmo
types/sortedList.cmi: misc/serialize.cmi misc/custom.cmo
misc/bool.cmi: misc/custom.cmo
types/boolean.cmi: misc/custom.cmo
types/intervals.cmi: misc/custom.cmo
types/chars.cmi: misc/custom.cmo
......
misc/bool.ml
View file @ 51d2ccfe
......@@ -602,6 +602,7 @@ module Simplify(X : Custom.T) = struct
module V = SortedList.Make(X)
type tree = Split of elem list * elem list * tree list option
type f = {
pos: V.t;
neg: V.t;
......@@ -759,11 +760,28 @@ module Simplify(X : Custom.T) = struct
p1 == p2 && m1 == m2 && (equal l1 l2) && (equal r1 r2)
| _ -> false
let rec compare x y = match x,y with
| Empty, Empty -> 0
| Leaf k1, Leaf k2 -> id k1 - id k2
| Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) ->
if (p1 < p2) then (-1) else if (p1 > p2) then 1
else if (m1 < m2) then (-1) else if (m1 > m2) then 1
else let c = compare l1 l2 in if c != 0 then c
else compare r1 r2
| Empty, _ -> -1 | _, Empty -> 1
| Leaf _, _ -> -1 | _, Leaf _ -> 1
(* 3,19,65599,1048577 *)
let z1 = 3 (* int_of_string (Sys.getenv "Z1") *)
let z2 = 19 (* int_of_string (Sys.getenv "Z2") *)
let z3 = 65599 (* int_of_string (Sys.getenv "Z3") *)
let z4 = 1048577 (* int_of_string (Sys.getenv "Z4") *)
let rec hash = function
| Empty -> 0
| Leaf k -> 1 + 3 * (id k)
| Leaf k -> 1 + z1 * (id k)
| Branch (p,m,l,r) ->
2 + 3 * p + 257 * m + 16387 * (hash l) + 1048577 * (hash r)
2 + z1 * p + z2 * m + z3 * (hash l) + z4 * (hash r)
let rec iter f = function
| Empty -> ()
......@@ -850,22 +868,170 @@ module Simplify(X : Custom.T) = struct
*)
(* Hash-consing *)
module W = Weak.Make(
struct
module H = struct
type t = f
let compare f g =
let c = V.compare f.pos g.pos in if c != 0 then c
else let c = V.compare f.neg g.neg in if c != 0 then c
else F.compare f.subs g.subs
let equal0 f pos neg subs =
V.equal f.pos pos
&& V.equal f.neg neg
&& F.equal f.subs subs
let hash f =
(V.hash f.pos)
+ 257 * (V.hash f.neg)
+ 65537 * (F.hash f.subs)
let hash0 pos neg subs =
(V.hash pos)
+ 257 * (V.hash neg)
+ 65537 * (F.hash subs)
let equal f1 f2 =
V.equal f1.pos f2.pos
&& V.equal f1.neg f2.neg
&& F.equal f1.subs f2.subs
end
)
let mk_f = let id = ref 0 and tbl = W.create 16387 in
(* module W = Weak.Make(H) *)
(*
module W = struct
type table = {
mutable table : H.t Weak.t array;
mutable totsize : int;
mutable limit : int;
}
let create sz =
let sz = if sz < 7 then 7 else sz in
let sz = if sz > Sys.max_array_length then Sys.max_array_length else sz in
let emptybucket = Weak.create 0 in
{ table = Array.create sz emptybucket;
totsize = 0;
limit = 3; }
let next_sz n = min (3*n/2 + 3) (Sys.max_array_length - 1)
let rec copy t t' =
let rec aux b =
for i = 0 to Weak.length b - 1 do
match Weak.get b i with
| Some v -> add t' v
(((H.hash0 v.pos v.neg v.subs) land max_int)
mod (Array.length t'.table))
| None -> ()
done
in
Array.iter aux t.table
and resize t =
let oldlen = Array.length t.table in
let newlen = next_sz oldlen in
if newlen > oldlen then begin
let newt = create newlen in
newt.limit <- t.limit + 100; (* prevent resizing of newt *)
copy t newt;
t.table <- newt.table;
t.limit <- t.limit + 2;
end
and add t v index =
let bucket = t.table.(index) in
let sz = Weak.length bucket in
let rec loop i =
if i >= sz then begin
let newsz = min (sz + 3) (Sys.max_array_length - 1) in
if newsz <= sz then
failwith "Hashcons.Make: hash bucket cannot grow more";
let newbucket = Weak.create newsz in
Weak.blit bucket 0 newbucket 0 sz;
Weak.set newbucket i (Some v);
t.table.(index) <- newbucket;
t.totsize <- t.totsize + (newsz - sz);
if t.totsize > t.limit * Array.length t.table then resize t;
end else begin
if Weak.check bucket i
then loop (i+1)
else Weak.set bucket i (Some v)
end
in
loop 0
let count t =
let rec count_bucket i b accu =
if i >= Weak.length b then accu else
count_bucket (i+1) b (accu + (if Weak.check b i then 1 else 0))
in
Array.fold_right (count_bucket 0) t.table 0
let stats t =
let len = Array.length t.table in
let lens = Array.map Weak.length t.table in
Array.sort compare lens;
let totlen = Array.fold_left ( + ) 0 lens in
(len, count t, totlen, lens.(0), lens.(len/2), lens.(len-1))
let cur_id = ref 0
let merge t pos neg subs =
let index = H.hash0 pos neg subs in
let index = (index land max_int) mod (Array.length t.table) in
let bucket = t.table.(index) in
let sz = Weak.length bucket in
let rec loop i =
if i >= sz then begin
let hnode = { id = (incr cur_id; !cur_id); pos = pos; neg = neg;
subs = subs; dnf = None; dnf_neg = None } in
add t hnode index;
(*
if (!cur_id mod 1000 = 0) then
(let (len, count, totlen, min, med, max) = stats t in
Format.fprintf Format.std_formatter
"id=%i len=%i count=%i totlen=%i min=%i med=%i max=%i ratio=%f@."
!cur_id len count totlen min med max
(float_of_int count /. float_of_int len)
);
*)
hnode
end else begin
match Weak.get_copy bucket i with
| Some v when H.equal0 v pos neg subs ->
begin match Weak.get bucket i with
| Some v -> v
| None -> loop (i+1)
end
| _ -> loop (i+1)
end
in
loop 0
end
*)
module W = struct
module H = Hashset.MakeTable(H)
let cur_id = ref 0
let create = H.create
let merge h pos neg subs =
let x = { pos = pos; neg = neg; subs = subs; dnf = None; dnf_neg = None;
id = 0 } in
try H.find h x
with Not_found ->
x.id <- (incr cur_id; !cur_id);
H.add h x x;
x
end
let s = 157 (* int_of_string (Sys.getenv "MEMO") *)
let mk_f = W.merge (W.create s)
(*
let mk_f = let id = ref 0 and tbl = W.create s in
fun pos neg subs ->
(* assert (V.length pos + V.length neg + F.cardinal subs >= 2);
assert (V.disjoint pos neg); *)
......@@ -874,6 +1040,7 @@ module Simplify(X : Custom.T) = struct
if f.id = 0 then (f.id <- (incr id; !id)(*; print_char '0'*))
(*else print_char '1'*);
f
*)
(*
let rec check_f f =
......@@ -947,12 +1114,13 @@ module Simplify(X : Custom.T) = struct
let new_memo n = { key1 = Array.create n (-1); key2 = Array.create n (-1);
res = Array.create n Zero }
let memo_cap = new_memo 16383
let memo_diff = new_memo 16383
let memo_nor = new_memo 16383
let s = 16383 (* int_of_string (Sys.getenv "H") *)
let memo_cap = new_memo s
let memo_diff = new_memo s
let memo_nor = new_memo s
let memo_bin tbl g f1 f2 =
let h = ((f1.id + 1027 * f2.id) land max_int) mod (Array.length tbl.res) in
let h = ((f1.id + 65599 * f2.id) land max_int) mod (Array.length tbl.res) in
if (tbl.key1.(h) == f1.id) && (tbl.key2.(h) == f2.id)
then tbl.res.(h)
else
......@@ -1003,7 +1171,7 @@ module Simplify(X : Custom.T) = struct
cap (NegF f) (neg (mk g.pos g.neg (F.remove f g.subs))) (* OPT *)
else if F.mem g f.subs then
cap (NegF g) (neg (mk f.pos f.neg (F.remove g f.subs))) (* OPT *)
else (
else
(* if overlap f g then
let pos1,posc,pos2 = V.split f.pos g.pos
and neg1,negc,neg2 = V.split f.neg g.neg
......@@ -1014,7 +1182,6 @@ module Simplify(X : Custom.T) = struct
neg (cap fc (neg (cap (neg f1) (neg f2))))
else *)
PosF (mk_f [] [] (F.union (Leaf f) (Leaf g)))
)
and cap t1 t2 = match t1,t2 with
| Zero, t | t, Zero -> Zero
......@@ -1029,10 +1196,16 @@ module Simplify(X : Custom.T) = struct
else PosF (mk_f [] (if c <0 then [x;y] else [y;x]) Empty)
| PosV x, NegV y
| NegV y, PosV x -> if X.equal x y then Zero else PosF (mk_f [x] [y] Empty)
| PosF f, PosF g -> memo_bin memo_cap cap_f f g
| PosF f, PosF g ->
if f.id < g.id then memo_bin memo_cap cap_f f g
else if f.id > g.id then memo_bin memo_cap cap_f g f
else t1
| PosF f, NegF g
| NegF g, PosF f -> memo_bin memo_diff diff_f f g
| NegF f, NegF g -> memo_bin memo_nor nor_f f g
| NegF f, NegF g ->
if f.id < g.id then memo_bin memo_nor nor_f f g
else if f.id > g.id then memo_bin memo_nor nor_f g f
else t1
| (PosF f as t), PosV x | PosV x, (PosF f as t) ->
if V.mem f.pos x then t
else if V.mem f.neg x then Zero
......@@ -1069,13 +1242,55 @@ module Simplify(X : Custom.T) = struct
else PosF (mk_f [] [x] (Leaf f))
let rec mk_clean pos neg negf f =
if not (V.disjoint pos f.neg) || not (V.disjoint neg f.pos) then Zero
else
let pos' = V.diff f.pos pos
and neg' = V.diff f.neg neg
and subs' = F.diff f.subs negf in
let pos = V.cup pos pos' and neg = V.cup neg neg' and negf =
F.union negf subs' in
let rec aux pos' neg' subs' = function
| g::r ->
(match mk_clean pos neg negf g with
| NegF g ->
if not (V.disjoint pos' g.neg) ||
not (V.disjoint neg' g.pos) then raise Exit;
aux
(V.cup pos' g.pos)
(V.cup neg' g.neg)
(F.union subs' g.subs)
r
| PosF g -> aux pos' neg' (F.add g subs') r
| NegV x ->
if V.mem neg' x then raise Exit;
aux (V.add x pos') neg' subs' r
| PosV x ->
if V.mem pos' x then raise Exit;
aux pos' (V.add x neg') subs' r
| One -> raise Exit
| Zero -> aux pos' neg' subs' r)
| [] -> mk pos' neg' subs'
in
try aux pos' neg' F.empty (F.elements [] subs') with Exit -> Zero
let clean = function
| PosF f as t when F.cardinal f.subs >= 1 ->
let t' = mk_clean [] [] F.empty f in
if equal t t' then t else t'
| NegF f as t when F.cardinal f.subs >= 1 ->
let t' = neg (mk_clean [] [] F.empty f) in
if equal t t' then t else t'
| x -> x
let get_f pos neg subs =
let all = ref [] in
let reg pos neg = all := (pos,neg) :: !all in
let rec aux pos neg = function
| [] -> reg pos neg
| f::r ->
if f.dnf_neg != None then print_char '.';
if (V.exists (fun x -> V.mem pos x) f.neg
|| V.exists (fun x -> V.mem neg x) f.pos)
then aux pos neg r
......@@ -1087,7 +1302,6 @@ module Simplify(X : Custom.T) = struct
if V.mem pos x then ()
else aux pos (V.add x neg) r) f.pos;
F.iter (fun f ->
if f.dnf != None then print_char 'o';
if not (V.disjoint f.pos neg && V.disjoint f.neg pos)
then ()
else
......@@ -1118,6 +1332,8 @@ module Simplify(X : Custom.T) = struct
| PosV x -> [ [x],[] ]
| NegV x -> [ [],[x] ]
let get t = get (clean t)
let non_triv = function
| PosF f | NegF f -> F.cardinal f.subs >= 1
| _ -> false
......@@ -1225,6 +1441,58 @@ module Simplify(X : Custom.T) = struct
| PosV x | NegV x -> h x
| PosF f | NegF f -> iter_f h f
let split r = function
| (pos,neg,Some []) -> r
| (pos,neg,Some [ Split(pos',neg',next) ]) ->
Split (V.cup pos pos', V.cup neg neg', next) :: r
| (pos,neg,l) -> Split (pos,neg,l) :: r
let get_tree pos neg subs =
let rec aux pos neg negf = function
| [] -> None
| f::r ->
if ((not (V.disjoint f.neg pos)) || (not (V.disjoint f.pos neg)))
(*|| not (F.mem f negf)*) then aux pos neg negf r
else
let pos = V.cup pos f.pos in
let neg = V.cup neg f.neg in
let negf = F.union negf f.subs in
let accu =
V.fold (fun accu x ->
(* if V.mem neg x then accu
else *)split accu ([x],[], aux (V.add x pos) neg negf r)) [] f.neg in
let accu =
V.fold (fun accu x ->
(* if V.mem pos x then accu
else *)split accu ([],[x], aux pos (V.add x neg) negf r)) accu f.pos in
let accu =
F.fold (fun f accu ->
split accu (f.pos,f.neg,
aux (V.cup f.pos pos) (V.cup f.neg neg) negf
(F.elements r f.subs))) f.subs accu
in
Some accu
in
match split [] (pos,neg,aux pos neg F.empty subs) with
| [] -> Split ([],[], Some [])
| [s] -> s
| _ -> assert false
let get_tree = function
| Zero -> Split ([],[],Some [])
| One -> Split ([],[],None)
| PosF f -> get_tree f.pos f.neg (F.elements [] f.subs)
| NegF f -> get_tree [] [] [f]
| PosV x -> Split ([x],[], None)
| NegV x -> Split ([],[x], None)
let get_tree t = get_tree (clean t)
end
module type S'' = sig
include S
type tree = Split of elem list * elem list * tree list option
val get_tree: t -> tree
end
misc/bool.mli
View file @ 51d2ccfe
......@@ -38,5 +38,13 @@ end
module MakeBdd(X : Custom.T) : S' with type elem = X.t
module Simplify : MAKE
module type S'' = sig
include S
type tree = Split of elem list * elem list * tree list option
val get_tree: t -> tree
end
module Simplify(X : Custom.T) : S'' with type elem = X.t
misc/encodings.ml
View file @ 51d2ccfe
......@@ -150,7 +150,7 @@ struct
)
else if p <= 0xffff then (
(* Refuse writing surrogate pairs, and fffe, ffff *)
if (p >= 0xd800 & p < 0xe000) or (p >= 0xfffe) then
if (p >= 0xd800 && p < 0xe000) || (p >= 0xfffe) then
failwith "Encodings.Utf8.store";
Buffer.add_char b (Char.chr (0xe0 lor (p lsr 12)));
Buffer.add_char b (Char.chr (0x80 lor ((p lsr 6) land 0x3f)));
......
misc/pretty.ml
View file @ 51d2ccfe
......@@ -7,7 +7,13 @@ type 'a regexp =
| Plus of 'a regexp
| Trans of 'a
module type TABLE = sig
type key
type 'a t
val create: int -> 'a t
val add: 'a t -> key -> 'a -> unit
val find: 'a t -> key -> 'a
end
module type S = sig
type t
......@@ -16,7 +22,7 @@ module type S = sig
val hash: t -> int
end
module Decompile(H : Hashtbl.S)(S : S) = struct
module Decompile(H : TABLE)(S : S) = struct
(* Now attempt to simplify regexp. Does not work.... disabled *)
module A = struct
......
misc/pretty.mli
View file @ 51d2ccfe
......@@ -16,7 +16,15 @@ module type S = sig
val hash: t -> int
end
module Decompile(X : Hashtbl.S)(S : S)
module type TABLE = sig
type key
type 'a t
val create: int -> 'a t
val add: 'a t -> key -> 'a -> unit
val find: 'a t -> key -> 'a
end
module Decompile(X : TABLE)(S : S)
: sig
val decompile: (X.key -> (S.t * X.key) list * bool) -> X.key -> S.t regexp
end
types/types.ml
View file @ 51d2ccfe
......@@ -484,13 +484,13 @@ end
(* It is also possible to use Boolean instead of Bool here;
need to analyze when each one is more efficient *)
and BoolPair : Bool.S with type elem = Node.t * Node.t =
(*Bool.Simplify*)(Bool.Make)(Custom.Pair(NodeT)(NodeT))
Bool.Simplify(*(Bool.Make)*)(Custom.Pair(NodeT)(NodeT))
and BoolRec : Bool.S with type elem = bool * Node.t label_map =
(*Bool.Simplify*)(Bool.Make)(Custom.Pair(Custom.Bool)(LabelSet.MakeMap(NodeT)))
module DescrHash = Hashtbl.Make(Descr)
module DescrMap = Map.Make(Descr)
module DescrHash = (*Hashtbl.Make*)Hashset.MakeTable(Descr)
module DescrMap = (*Map.Make*)Hashset.Make(Descr)
module DescrSet = Set.Make(Descr)
module DescrSList = SortedList.Make(Descr)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment