Skip to content

GitLab

Commit 87ad191d authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-06-16 13:53:05 by afrisch] Compilation: new algo for basic 

Original author: afrisch
Date: 2005-06-16 13:53:05+00:00
parent a3b8ff22
Hide whitespace changes
Inline Side-by-side
Showing with 120 additions and 76 deletions
types/patterns.ml
View file @ 87ad191d
......@@ -138,6 +138,8 @@ let capture x = (Types.any, IdSet.singleton x, Capture x)
let constant x c = (Types.any, IdSet.singleton x, Constant (x,c))
let print_node = ref (fun _ _ -> assert false)
module Node = struct
type t = node
let compare n1 n2 = n1.id - n2.id
......@@ -145,7 +147,7 @@ module Node = struct
let hash n = n.id
let check n = ()
let dump = print_node
let dump ppf x = !print_node ppf x
module SMemo = Set.Make(Custom.Int)
......@@ -377,6 +379,7 @@ module Print = struct
Format.fprintf ppf "}"
end
let () = print_node := (fun ppf n -> Print.print ppf (descr n))
(* Static semantics *)
......@@ -572,13 +575,20 @@ module Normal = struct
| SCatch, _ -> -1 | _, SCatch -> 1
| SConst c1, SConst c2 -> Types.Const.compare c1 c2
(*
let hash_source = function
| SCatch -> 1
| SConst c -> Types.Const.hash c
*)
let compare_result r1 r2 =
IdMap.compare compare_source r1 r2
module ResultMap = Map.Make(struct
type t = result
let compare = compare_result
end)
module NodeSet = SortedList.Make(Node)
module Nnf = struct
......@@ -609,14 +619,6 @@ module Normal = struct
end
module NBasic = struct
type t = result * Types.t
let compare (r1,t1) (r2,t2) =
let c = compare_result r1 r2 in if c <> 0 then c
else Types.compare t1 t2
end
module NProd = struct
type t = result * Nnf.t * Nnf.t
......@@ -626,14 +628,12 @@ module Normal = struct
else Nnf.compare y1 y2
end
module NLineBasic = Set.Make(NBasic)
module NLineProd = Set.Make(NProd)
type record =
| RecNolabel of result option * result option
| RecLabel of label * NLineProd.t
type t = {
nbasic : NLineBasic.t;
nprod : NLineProd.t;
nxml : NLineProd.t;
nrecord: record
......@@ -642,8 +642,7 @@ module Normal = struct
let fus = IdMap.union_disj
let nempty lab =
{ nbasic = NLineBasic.empty;
nprod = NLineProd.empty;
{ nprod = NLineProd.empty;
nxml = NLineProd.empty;
nrecord = (match lab with
| Some l -> RecLabel (l,NLineProd.empty)
......@@ -653,8 +652,7 @@ module Normal = struct
let ncup nf1 nf2 =
{ nbasic = NLineBasic.union nf1.nbasic nf2.nbasic;
nprod = NLineProd.union nf1.nprod nf2.nprod;
{ nprod = NLineProd.union nf1.nprod nf2.nprod;
nxml = NLineProd.union nf1.nxml nf2.nxml;
nrecord = (match (nf1.nrecord,nf2.nrecord) with
| RecLabel (l1,r1), RecLabel (l2,r2) ->
......@@ -666,11 +664,6 @@ module Normal = struct
| _ -> assert false)
}
let double_fold_basic f l1 l2 =
NLineBasic.fold
(fun x1 accu -> NLineBasic.fold (fun x2 accu -> f accu x1 x2) l2 accu)
l1 NLineBasic.empty
let double_fold_prod f l1 l2 =
NLineProd.fold
(fun x1 accu -> NLineProd.fold (fun x2 accu -> f accu x1 x2) l2 accu)
......@@ -687,11 +680,6 @@ module Normal = struct
(NodeSet.cup ql1 ql2, s, IdSet.cup ys1 ys2))
accu
in
let basic accu (res1,t1) (res2,t2) =
let t = Types.cap t1 t2 in
if Types.is_empty t then accu else
NLineBasic.add (fus res1 res2, t) accu
in
let record r1 r2 = match r1,r2 with
| RecLabel (l1,r1), RecLabel (l2,r2) ->
(* assert (l1 = l2); *)
......@@ -706,8 +694,7 @@ module Normal = struct
RecNolabel (x,y)
| _ -> assert false
in
{ nbasic = double_fold_basic basic nf1.nbasic nf2.nbasic;
nprod = double_fold_prod prod nf1.nprod nf2.nprod;
{ nprod = double_fold_prod prod nf1.nprod nf2.nprod;
nxml = double_fold_prod prod nf1.nxml nf2.nxml;
nrecord = record nf1.nrecord nf2.nrecord;
}
......@@ -719,7 +706,6 @@ module Normal = struct
let empty_res = IdMap.empty
let single_basic src t = NLineBasic.singleton (src, t)
let single_prod src p q = NLineProd.singleton (src, p,q)
let ntimes lab acc p q xs =
......@@ -759,15 +745,13 @@ module Normal = struct
(if y then Some empty_res else None))
| Some l ->
RecLabel (l,aux (Types.Record.split_normal t l)) in
{ nbasic = single_basic empty_res (Types.cap t any_basic);
nprod = aux (Types.Product.normal t);
{ nprod = aux (Types.Product.normal t);
nxml = aux (Types.Product.normal ~kind:`XML t);
nrecord = record
}
let nany lab res =
{ nbasic = single_basic res any_basic;
nprod = single_prod res ncany ncany;
{ nprod = single_prod res ncany ncany;
nxml = single_prod res ncany ncany;
nrecord = match lab with
| None -> RecNolabel (Some res, Some res)
......@@ -818,27 +802,82 @@ module Normal = struct
(fun a p -> ncap a (nnormal l (descr p) xs)) (nconstr l t) pl
let nnf lab t0 (pl,t,xs) =
assert (not (Types.disjoint t t0));
(* assert (not (Types.disjoint t t0)); *)
let t = if Types.subtype t t0 then t else Types.cap t t0 in
normal lab t (NodeSet.get pl) xs
let basic_tests t0 (pl,t,xs) =
let t0 = Types.cap t0 any_basic in
let rec aux accu t res = function
| [] -> (res,t) :: accu
| (tp,xp,d) :: rest ->
let basic_tests f (pl,t,xs) =
let rec aux more s accu t res = function
(* Invariant: t and s disjoint, t not empty *)
| [] ->
let accu =
try
let t' = ResultMap.find res accu in
ResultMap.add res (Types.cup t t') accu
with Not_found -> ResultMap.add res t accu in
cont (Types.cup t s) accu more
| (tp,xp,d) :: r ->
if (IdSet.disjoint xp xs)
then aux accu (Types.cap t tp) res rest
then aux_check more s accu (Types.cap t tp) res r
else match d with
| Constr s -> aux accu (Types.cap t s) res rest
| Cup (p1,p2) -> aux (aux accu t res (p2::rest)) t res (p1::rest)
| Cap (p1,p2) -> aux accu t res (p1 :: p2 :: rest)
| Capture x -> aux accu t (IdMap.add x SCatch res) rest
| Constant (x,c) -> aux accu t (IdMap.add x (SConst c) res) rest
| _ -> accu
| Cup (p1,p2) -> aux ((t,res,p2::r)::more) s accu t res (p1::r)
| Cap (p1,p2) -> aux more s accu t res (p1 :: p2 :: r)
| Capture x -> aux more s accu t (IdMap.add x SCatch res) r
| Constant (x,c) ->
aux more s accu t (IdMap.add x (SConst c) res) r
| _ -> cont s accu more
and aux_check more s accu t res pl =
if Types.is_empty t then cont s accu more else aux more s accu t res pl
and cont s accu = function
| [] -> ResultMap.iter f accu
| (t,res,pl)::tl -> aux_check tl s accu (Types.diff t s) res pl
in
aux [] (Types.cap t any_basic) IdMap.empty (List.map descr pl)
aux_check [] Types.empty ResultMap.empty (Types.cap t any_basic)
IdMap.empty (List.map descr pl)
(*
let prod_tests (pl,t,xs) =
let rec aux accu q1 q2 res = function
| [] -> (res,q1,q2) :: accu
| (tp,xp,d) :: r ->
if (IdSet.disjoint xp xs)
then aux_check accu q1 q2 res tp r
else match d with
| Cup (p1,p2) -> aux (aux accu q1 q2 res (p2::r)) q1 q2 res (p1::r)
| Cap (p1,p2) -> aux accu q1 q2 res (p1 :: p2 :: r)
| Capture x -> aux accu q1 q2 (IdMap.add x SCatch res) r
| Constant (x,c) -> aux accu q1 q2 (IdMap.add x (SConst c) res) r
| Times (p1,p2) ->
let (pl1,t1,xs1) = q1 and (pl2,t2,xs2) = q2 in
let t1 = Types.cap t1 (Types.descr (accept p1)) in
if Types.is_empty t1 then accu
else let t2 = Types.cap t2 (Types.descr (accept p2)) in
if Types.is_empty t2 then accu
else
let q1 =
let xs1' = IdSet.cap (fv p1) xs in
if IdSet.is_empty xs1' then (pl1,t1,xs1)
else (NodeSet.add p1 pl1, t1, IdSet.cup xs1 xs1')
and q2 =
let xs2' = IdSet.cap (fv p2) xs in
if IdSet.is_empty xs2' then (pl2,t2,xs2)
else (NodeSet.add p2 pl2, t2, IdSet.cup xs2 xs2')
in
aux accu q1 q2 res r
| _ -> accu
and aux_check accu q1 q2 res t r =
List.fold_left
(fun accu (t1',t2') ->
let (pl1,t1,xs1) = q1 and (pl2,t2,xs2) = q2 in
let t1 = Types.cap t1 t1' in
if Types.is_empty t1 then accu
else let t2 = Types.cap t2 t2' in
if Types.is_empty t2 then accu
else aux accu (pl1,t1,xs1) (pl2,t2,xs2) res r)
accu (Types.Product.clean_normal (Types.Product.normal t))
in
aux_check [] ncany ncany IdMap.empty t (List.map descr pl)
*)
end
......@@ -1080,7 +1119,14 @@ struct
let find_code d a =
let rec aux i = function
| `Result code -> code
| `None -> assert false
| `None ->
Format.fprintf Format.std_formatter
"IFACE=%a@." print_iface d.interface;
for i = 0 to Array.length a - 1 do
Format.fprintf Format.std_formatter
"a.(i)=%b@." (a.(i) != None)
done;
assert false
| `Switch (yes,_) when a.(i) != None -> aux (i + 1) yes
| `Switch (_,no) -> aux (i + 1) no in
aux 0 d.interface
......@@ -1090,8 +1136,7 @@ struct
Array.of_list (Array.fold_right aux pl [])
let return disp pl f ar =
let aux = function [x] -> Some (f x) | [] -> None
| _ -> dump_disp disp; assert false in
let aux = function x::_ -> Some (f x) | [] -> None in
let final = Array.map aux pl in
(find_code disp final, create_result final, ar)
......@@ -1138,13 +1183,12 @@ struct
module TypeList = SortedList.Make(Types)
let dispatch_basic disp pl : (Types.t * result) list =
(* TODO: try other algo, using disp.codes .... *)
let pl = Array.map (fun p -> p.Normal.nbasic) pl in
let tests =
let accu = ref [] in
let aux i (res,x) = accu := (x, [i,res]) :: !accu in
Array.iteri (fun i -> Normal.NLineBasic.iter (aux i)) pl;
let aux i res t = accu := (t, [i,res]) :: !accu in
Array.iteri (fun i p -> Normal.basic_tests (aux i) p) disp.pl;
TypeList.Map.get (TypeList.Map.from_list (@) !accu) in
let t = Types.cap any_basic disp.t in
......@@ -1187,11 +1231,11 @@ struct
(* Build continuation *)
let result (t,ar,m) =
let get a (req,info) =
let get (req,info) a =
let i = NfMap.find req idx in
let (var,nil,_) = reqs_facto.(i) in
match m.(i) with Some res -> ((var,nil,res),info)::a | _ -> a in
let pl = Array.map (List.fold_left get []) pl in
let pl = Array.map (fun l -> List.fold_right get l []) pl in
d t ar pl
in
let res = Array.map result disp.codes in
......@@ -1217,13 +1261,7 @@ struct
get_tests false pl (fun x -> x) t res (fun x -> x)
let rec dispatch_prod ?(kind=`Normal) disp pl =
let extr = match kind with
| `Normal -> fun p -> Normal.NLineProd.elements p.Normal.nprod
| `XML -> fun p -> Normal.NLineProd.elements p.Normal.nxml in
let t = Types.Product.get ~kind disp.t in
dispatch_prod0 disp t (Array.map extr pl)
and dispatch_prod0 disp t pl =
let rec dispatch_prod0 disp t pl =
get_tests true pl
(fun (res,p,q) -> p, (res,q))
(Types.Product.pi1 t)
......@@ -1239,6 +1277,16 @@ struct
let aux_final (ret2, (ret1, res)) = merge_res_prod ar1 ar2 ret1 ret2 res in
return disp pl aux_final (ar1 + ar2)
let dispatch_prod disp pl =
let t = Types.Product.get disp.t in
dispatch_prod0 disp t
(Array.map (fun p -> Normal.NLineProd.elements p.Normal.nprod) pl)
(* dispatch_prod0 disp t (Array.map Normal.prod_tests disp.pl) *)
let dispatch_xml disp pl =
let t = Types.Product.get ~kind:`XML disp.t in
dispatch_prod0 disp t
(Array.map (fun p -> Normal.NLineProd.elements p.Normal.nxml) pl)
let dispatch_record disp pl : record option =
let t = disp.t in
......@@ -1299,7 +1347,7 @@ struct
let a = combine_kind
(dispatch_basic disp pl)
(dispatch_prod disp pl)
(dispatch_prod ~kind:`XML disp pl)
(dispatch_xml disp pl)
(dispatch_record disp pl)
in
disp.actions <- Some a;
......@@ -1431,27 +1479,19 @@ struct
| AIgnore r -> Format.fprintf ppf "v -> %a@\n" (print_ret []) r
let print_dispatcher ppf d =
(*
Format.fprintf ppf "Dispatcher %i accepts [%a]@\n"
d.id Types.Print.print (Types.normalize d.t);
let print_code code (t, arity, m) =
Format.fprintf ppf " Returns $%i(arity=%i) for [%a]"
code arity
Types.Print.print (Types.normalize t);
(*
List.iter
(fun (i,b) ->
Format.fprintf ppf "[%i:" i;
List.iter
(fun (v,i) -> Format.fprintf ppf "%s=>%i;" v i)
b;
Format.fprintf ppf "]"
) m; *)
Format.fprintf ppf "@\n";
in
Array.iteri print_code d.codes;
*)
Array.iter (fun p ->
Format.fprintf ppf " pat %a@." Normal.Nnf.print p;
) d.pl;
Format.fprintf ppf "let disp_%i = function@\n" d.id;
print_actions ppf (actions d);
Format.fprintf ppf "====================================@\n"
......@@ -1475,7 +1515,7 @@ struct
let t = Types.descr t in
let pl = Array.of_list
(List.map (fun p -> ([p],Types.cap t (Types.descr (accept p)),fv p)) pl) in
(List.map (fun p -> ([p],Types.descr (accept p),fv p)) pl) in
show ppf t pl;
Format.fprintf ppf "# compiled states: %i@\n" !generated
......@@ -1496,6 +1536,7 @@ end
(****** More efficient compilation (less optimized) ******)
(*
module Compile2 =
struct
type source =
......@@ -2309,3 +2350,4 @@ struct
end
(* debug compile Any (Int,Int) & (x,y) *)
*)
types/patterns.mli
View file @ 87ad191d
......@@ -86,6 +86,8 @@ module Compile: sig
end
(*
module Compile2: sig
val debug_compile : Format.formatter -> Types.Node.t -> node list -> unit
end
*)
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