Skip to content

GitLab

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

[r2004-12-27 15:49:44 by afrisch] Cleanup 

Original author: afrisch
Date: 2004-12-27 15:49:45+00:00
parent cc6e034a
Hide whitespace changes
Inline Side-by-side
CHANGES
View file @ bf0b9c53
......@@ -8,6 +8,7 @@ Since 0.2.1
- bug fix for the compilation of complex patterns with records
- new syntax { l = p else p' }
- fixed a little bit support for XML Schema, but still largely broken
- better compilation of sequence capture variables
0.2.1
......
types/patterns.ml
View file @ bf0b9c53
......@@ -453,6 +453,15 @@ let min (a:int) (b:int) = if a < b then a else b
let any_basic = Types.Record.or_absent Types.non_constructed
let rec first_label (acc,fv,d) =
if Types.is_empty acc
then LabelPool.dummy_max
else match d with
| Constr t -> Types.Record.first_label t
| Cap (p,q) -> min (first_label p) (first_label q)
| Cup ((acc1,_,_) as p,q) -> min (first_label p) (first_label q)
| Record (l,p) -> l
| _ -> LabelPool.dummy_max
module Normal = struct
......@@ -506,6 +515,13 @@ module Normal = struct
let hash (l,t,xs) =
(NodeSet.hash l) + 17 * (Types.hash t) + 257 * (IdSet.hash xs)
let equal x y = compare x y == 0
let first_label (pl,t,xs) =
List.fold_left
(fun l p -> min l (first_label (descr p)))
(Types.Record.first_label t)
pl
end
module NBasic = struct
......@@ -781,16 +797,6 @@ module Normal = struct
(*TODO: when an operand of Cap has its first_label > lab,
directly shift it*)
let rec first_label (acc,fv,d) =
if Types.is_empty acc
then LabelPool.dummy_max
else match d with
| Constr t -> Types.Record.first_label t
| Cap (p,q) -> min (first_label p) (first_label q)
| Cup ((acc1,_,_) as p,q) -> min (first_label p) (first_label q)
(* should "first_label_type acc1" ? *)
| Record (l,p) -> l
| _ -> LabelPool.dummy_max
let print_node_list ppf pl =
......@@ -802,6 +808,11 @@ module Normal = struct
(nconstr l t)
pl
let nnf lab (pl,t,xs) =
let pl = NodeSet.get pl in
normal lab t pl xs
(*
let normal l t pl =
let nf = normal l t pl in
......@@ -852,7 +863,7 @@ struct
and return_code =
Types.t * int * (* accepted type, arity *)
(int * int id_map) list
int id_map option array
and interface =
[ `Result of int
......@@ -875,6 +886,14 @@ struct
let l1 = Array.length a1 and l2 = Array.length a2 in
(l1 == l2) && (aux (l1 - 1))
let array_for_all f a =
let rec aux f a i = (i < 0) || (f a.(i) && (aux f a (pred i))) in
aux f a (Array.length a - 1)
let array_for_all_i f a =
let rec aux f a i = (i < 0) || (f i a.(i) && (aux f a (pred i))) in
aux f a (Array.length a - 1)
let equal_source s1 s2 =
(s1 == s2) || match (s1,s2) with
| Const x, Const y -> Types.Const.equal x y
......@@ -886,67 +905,43 @@ struct
let equal_result (r1,s1) (r2,s2) =
(r1 == r2) && (equal_array equal_source s1 s2)
let equal_result_dispatch d1 d2 =
(d1 == d2) || match (d1,d2) with
| Dispatch (d1,a1), Dispatch (d2,a2) -> (d1 == d2) && (equal_array equal_result a1 a2)
| TailCall d1, TailCall d2 -> d1 == d2
| Ignore a1, Ignore a2 -> equal_result a1 a2
| _ -> false
let array_for_all f a =
let rec aux f a i =
if i == Array.length a then true
else f a.(i) && (aux f a (succ i))
in
aux f a 0
let array_for_all_i f a =
let rec aux f a i =
if i == Array.length a then true
else f i a.(i) && (aux f a (succ i))
in
aux f a 0
let equal_result_dispatch d1 d2 = (d1 == d2) || match (d1,d2) with
| Dispatch (d1,a1), Dispatch (d2,a2) ->
(d1 == d2) && (equal_array equal_result a1 a2)
| TailCall d1, TailCall d2 -> d1 == d2
| Ignore a1, Ignore a2 -> equal_result a1 a2
| _ -> false
let immediate_res basic prod xml record =
let res = ref None in
let chk = function Catch | Const _ -> true | _ -> false in
let f ((_,ret) as r) =
match !res with
| Some r0 when equal_result r r0 -> ()
| None when array_for_all chk ret -> res := Some r
| _ -> raise Exit in
(match basic with [_,r] -> f r | [] -> () | _ -> raise Exit);
(match prod with Ignore (Ignore r) -> f r |Impossible ->()| _->raise Exit);
(match xml with Ignore (Ignore r) -> f r |Impossible ->()| _->raise Exit);
(match record with
| None -> ()
| Some (RecLabel (_,Ignore (Ignore r))) -> f r
| Some (RecNolabel (Some r1, Some r2)) -> f r1; f r2
| _ -> raise Exit);
match !res with Some r -> r | None -> raise Exit
let split_kind basic prod xml record = {
basic = basic;
atoms = Atoms.mk_map (List.map (fun (t,r) -> Types.Atom.get t, r) basic);
chars = Chars.mk_map (List.map (fun (t,r) -> Types.Char.get t, r) basic);
prod = prod;
xml = xml;
record = record
}
let combine_kind basic prod xml record =
try (
let rs = [] in
let rs = match basic with
| [_,r] -> r :: rs
| [] -> rs
| _ -> raise Exit in
let rs = match prod with
| Impossible -> rs
| Ignore (Ignore r) -> r :: rs
| _ -> raise Exit in
let rs = match xml with
| Impossible -> rs
| Ignore (Ignore r) -> r :: rs
| _ -> raise Exit in
let rs = match record with
| None -> rs
| Some (RecLabel (_,Ignore (Ignore r))) -> r :: rs
| Some (RecNolabel (Some r1, Some r2)) -> r1 :: r2 :: rs
| _ -> raise Exit in
match rs with
| ((_, ret) as r) :: rs when
List.for_all ( equal_result r ) rs
&& array_for_all
(function Catch | Const _ -> true | _ -> false) ret
-> AIgnore r
| _ -> raise Exit
)
with Exit ->
AKind
{ basic = basic;
atoms =
Atoms.mk_map (List.map (fun (t,r) -> Types.Atom.get t, r) basic);
chars =
Chars.mk_map (List.map (fun (t,r) -> Types.Char.get t, r) basic);
prod = prod;
xml = xml;
record = record;
}
try AIgnore (immediate_res basic prod xml record)
with Exit -> AKind (split_kind basic prod xml record)
let combine f (disp,act) =
if Array.length act == 0 then Impossible
......@@ -957,45 +952,38 @@ struct
else
Dispatch (disp, act)
let detect_right_tail_call = function
| Dispatch (disp,branches)
when
array_for_all_i
(fun i (code,ret) ->
(i == code) &&
(array_for_all_i
(fun pos ->
function Right j when pos == j -> true | _ -> false)
ret
)
) branches
-> TailCall disp
let detect_tail_call f = function
| Dispatch (disp,branches) when array_for_all_i f branches -> TailCall disp
| x -> x
let detect_left_tail_call = function
| Dispatch (disp,branches)
when
array_for_all_i
(fun i ->
function
| Ignore (code,ret) ->
(i == code) &&
(array_for_all_i
(fun pos ->
function Left j when pos == j -> true | _ -> false)
ret
)
| _ -> false
) branches
->
TailCall disp
| x -> x
let detect_right_tail_call =
detect_tail_call
(fun i (code,ret) ->
(i == code) &&
(array_for_all_i
(fun pos ->
function Right j when pos == j -> true | _ -> false)
ret
)
)
let detect_left_tail_call =
detect_tail_call
(fun i ->
function
| Ignore (code,ret) when (i == code) ->
array_for_all_i
(fun pos ->
function Left j when pos == j -> true | _ -> false)
ret
| _ -> false
)
let cur_id = State.ref "Patterns.cur_id" 0
(* TODO: save dispatchers ? *)
module NfMap = Map.Make(Normal)
module NfSet = Set.Make(Normal)
module DispMap = Map.Make(Custom.Pair(Types)(Custom.Array(Normal)))
......@@ -1014,32 +1002,28 @@ struct
let dispatcher t pl lab : dispatcher =
try DispMap.find (t,pl) !dispatchers
with Not_found ->
(* let ppf = Format.std_formatter in
Format.fprintf ppf "dispatcher %i:" !cur_id;
Array.iter (fun x -> Format.fprintf ppf "%a;" Normal.print x) pl;
Format.fprintf ppf "@."; *)
let nb = ref 0 in
let codes = ref [] in
let rec aux t arity i accu =
if i == Array.length pl
then (incr nb; codes := (t,arity,accu)::!codes; `Result (!nb - 1))
then (incr nb; let r = Array.of_list (List.rev accu) in
codes := (t,arity,r)::!codes; `Result (!nb - 1))
else
let p = pl.(i) in
let tp = p.Normal.na in
(* let tp = Types.normalize tp in *)
let a1 = Types.cap t tp in
if Types.is_empty a1 then
`Switch (`None,aux t arity (i+1) accu)
`Switch (`None,aux t arity (i+1) (None::accu))
else
let v = p.Normal.nfv in
let a2 = Types.diff t tp in
let accu' = (i,IdMap.num arity v) :: accu in
let accu' = Some (IdMap.num arity v) :: accu in
if Types.is_empty a2 then
`Switch (aux t (arity + (IdSet.length v)) (i+1) accu',`None)
else
`Switch (aux a1 (arity + (IdSet.length v)) (i+1) accu',
aux a2 arity (i+1) accu)
aux a2 arity (i+1) (None::accu))
(* Unopt version:
`Switch
......@@ -1050,25 +1034,18 @@ struct
*)
in
(*
Array.iteri (fun i p ->
Format.fprintf Format.std_formatter
"Pattern %i/%i accepts %a@." i (Array.length pl)
Types.Print.print p.Normal.na) pl;
*)
Stats.Timer.start timer_disp;
let iface =
if Types.is_empty t then `None else aux t 0 0 [] in
let iface = if Types.is_empty t then `None else aux t 0 0 [] in
Stats.Timer.stop timer_disp ();
(* Format.fprintf Format.std_formatter "iface=%a@." print_iface iface;*)
let res = { id = !cur_id;
t = t;
label = lab;
pl = pl;
interface = iface;
codes = Array.of_list (List.rev !codes);
actions = None; printed = false } in
let res = {
id = !cur_id;
t = t;
label = lab;
pl = pl;
interface = iface;
codes = Array.of_list (List.rev !codes);
actions = None; printed = false
} in
incr cur_id;
dispatchers := DispMap.add (t,pl) res !dispatchers;
res
......@@ -1078,20 +1055,7 @@ struct
| `Result code -> code
| `None -> assert false
| `Switch (yes,_) when a.(i) != None -> aux (i + 1) yes
| `Switch (_,no) -> aux (i + 1) no
in
(*
let ppf = Format.std_formatter in
Format.fprintf ppf "find_code iface=%a [ "
print_iface d.interface;
for i = 0 to Array.length a - 1 do
if (a.(i) != None) then
Format.fprintf ppf "+ "
else
Format.fprintf ppf "- "
done;
Format.fprintf ppf "]@.";
*)
| `Switch (_,no) -> aux (i + 1) no in
aux 0 d.interface
let create_result pl =
......@@ -1148,55 +1112,35 @@ struct
!accu
let get_tests pl f t d post =
let accu = ref [] in
let aux i x =
let (pl,ty,xs), info = f x in
let pl = Normal.NodeSet.get pl in
accu := (ty,pl,xs,i,info) :: !accu in
Array.iteri (fun i -> List.iter (aux i)) pl;
let lab =
List.fold_left
(fun l (ty,pl,_,_,_) ->
List.fold_left
(fun l p -> min l (Normal.first_label (descr p)))
(min l (Types.Record.first_label ty))
pl
) LabelPool.dummy_max !accu in
let lab = if lab == LabelPool.dummy_max then None else Some lab in
let first_lab pl =
let aux l (req,_) = min l (Normal.Nnf.first_label req) in
let lab = Array.fold_left (List.fold_left aux) LabelPool.dummy_max pl in
if lab == LabelPool.dummy_max then None else Some lab
let pats = ref NfMap.empty in
let nb_p = ref 0 in
List.iter
(fun (ty,pl,xs,i,info) ->
let p = Normal.normal lab ty pl xs in
let x = (i, IdSet.empty (* p.Normal.ncatchv *) , info) in
try
let s = NfMap.find p !pats in
s := x :: !s
with Not_found ->
pats := NfMap.add p (ref [x]) !pats;
incr nb_p
) !accu;
let infos = Array.make !nb_p [] in
let ps = Array.make !nb_p Normal.dummy in
let count = ref 0 in
NfMap.iter (fun p l ->
let i = !count in
infos.(i) <- !l;
ps.(i) <- p;
count := succ i) !pats;
assert( !nb_p == !count );
let disp = dispatcher t ps lab in
let get_tests pl f t d post =
let pl = Array.map (List.map f) pl in
let lab = first_lab pl in
let pl = Array.map (List.map (fun (x,info) -> (Normal.nnf lab x,info))) pl
in
(* Collect all subrequests *)
let aux reqs (req,_) = NfSet.add req reqs in
let reqs = Array.fold_left (List.fold_left aux) NfSet.empty pl in
let reqs = Array.of_list (NfSet.elements reqs) in
(* Map subrequest -> idx in reqs *)
let idx = ref NfMap.empty in
Array.iteri (fun i req -> idx := NfMap.add req i !idx) reqs;
let idx = !idx in
(* Build dispatcher *)
let disp = dispatcher t reqs lab in
(* Build continuation *)
let result (t,_,m) =
(* Format.fprintf Format.std_formatter "Result=%a@." Types.Print.print t;*)
let selected = Array.create (Array.length pl) [] in
let add r (i, ncv, inf) = selected.(i) <- (r,ncv,inf) :: selected.(i) in
List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;
d t selected
let get a (req,info) =
match m.(NfMap.find req idx) with Some res -> (res,info)::a | _ -> a in
let pl = Array.map (List.fold_left get []) pl in
d t pl
in
let res = Array.map result disp.codes in
post (disp,res)
......@@ -1204,45 +1148,29 @@ struct
type 'a rhs = Match of (id * int) list * 'a | Fail
let make_branches t brs =
let (_,brs) =
List.fold_left
(fun (t,brs) (p,e) ->
let p' = (Normal.NodeSet.singleton p,t, fv p) in
let t' = Types.diff t (Types.descr (accept p)) in
(t', (p',(fv p, e)) :: brs)
) (t,[]) brs in
let pl = Array.map (fun x -> [x]) (Array.of_list brs) in
get_tests
pl
(fun x -> x)
t
(fun _ pl ->
let r = ref Fail in
let aux = function
| [(res,catchv,(fvl,e))] -> assert (!r == Fail);
let catchv = IdMap.constant (-1) catchv in
let m = IdMap.union_disj catchv res in
let m = List.map (fun x -> (x,IdMap.assoc x m)) fvl in
r := Match (m,e)
| [] -> () | _ -> assert false in
Array.iter aux pl;
!r
)
(fun x -> x)
let t0 = ref t in
let aux (p,e) =
let xs = fv p in
let nnf = (Normal.NodeSet.singleton p, !t0, xs) in
t0 := Types.diff !t0 (Types.descr (accept p));
[(nnf, (xs, e))] in
let res _ pl =
let aux r = function
| [(res, (xs,e))] -> assert (r == Fail);
let m = List.map (fun x -> (x,IdMap.assoc x res)) xs in
Match (m,e)
| [] -> r | _ -> assert false in
Array.fold_left aux Fail pl in
let pl = Array.map aux (Array.of_list brs) in
get_tests pl (fun x -> x) t res (fun x -> x)
let rec dispatch_prod ?(kind=`Normal) disp =
let pl =
match kind with
| `Normal ->
Array.map (fun p -> Normal.NLineProd.get p.Normal.nprod) disp.pl
| `XML ->
Array.map (fun p -> Normal.NLineProd.get p.Normal.nxml) disp.pl
in
let extr = match kind with
| `Normal -> fun p -> Normal.NLineProd.get p.Normal.nprod
| `XML -> fun p -> Normal.NLineProd.get p.Normal.nxml in
let t = Types.Product.get ~kind disp.t in
dispatch_prod0 disp t pl
dispatch_prod0 disp t (Array.map extr disp.pl)
and dispatch_prod0 disp t pl =
get_tests pl
(fun (res,p,q) -> p, (res,q))
......@@ -1251,12 +1179,12 @@ struct
(fun x -> detect_left_tail_call (combine equal_result_dispatch x))
and dispatch_prod1 disp t t1 pl =
get_tests pl
(fun (ret1, ncatchv, (res,q)) -> q, (ret1,res) )
(fun (ret1, (res,q)) -> q, (ret1,res) )
(Types.Product.pi2_restricted t1 t)
(dispatch_prod2 disp)
(fun x -> detect_right_tail_call (combine equal_result x))
and dispatch_prod2 disp t2 pl =
let aux_final (ret2, ncatchv, (ret1, res)) =
let aux_final (ret2, (ret1, res)) =
IdMap.mapi_to_list (conv_source_prod ret1 ret2) res in
return disp pl aux_final
......@@ -1471,7 +1399,7 @@ struct
let t = Types.descr t in
let lab =
List.fold_left
(fun l p -> min l (Normal.first_label (descr p)))
(fun l p -> min l (first_label (descr p)))
(Types.Record.first_label t) pl in
let lab = if lab == LabelPool.dummy_max then None else Some lab in
......
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