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

[r2004-12-24 00:03:30 by afrisch] compilation: right/left, XML elem, ...

Original author: afrisch
Date: 2004-12-24 00:03:31+00:00
parent 16f489e3
......@@ -1581,8 +1581,8 @@ module Compile2 = struct
module NodeSet = Set.Make(Node)
let pi1 t = Types.Product.pi1 (Types.Product.get t)
let pi2 t = Types.Product.pi2 (Types.Product.get t)
let pi1 ~kind t = Types.Product.pi1 (Types.Product.get ~kind t)
let pi2 ~kind t = Types.Product.pi2 (Types.Product.get ~kind t)
module Approx = struct
......@@ -1608,11 +1608,16 @@ x=(1,2)
xs
| Constant (_,c) ->
if (Types.subtype t (Types.constant c)) then xs else IdSet.empty
| Times (q1,q2) | Xml (q1,q2) ->
| Times (q1,q2) ->
let xs = IdSet.cap xs (IdSet.cap q1.fv q2.fv) in
IdSet.cap
(approx_var_node seen q1 (pi1 t) xs)
(approx_var_node seen q2 (pi2 t) xs)
(approx_var_node seen q1 (pi1 ~kind:`Normal t) xs)
(approx_var_node seen q2 (pi2 ~kind:`Normal t) xs)
| Xml (q1,q2) ->
let xs = IdSet.cap xs (IdSet.cap q1.fv q2.fv) in
IdSet.cap
(approx_var_node seen q1 (pi1 ~kind:`XML t) xs)
(approx_var_node seen q2 (pi2 ~kind:`XML t) xs)
| Record _ -> IdSet.empty
| _ -> assert false
......@@ -1641,24 +1646,32 @@ x=(1,2)
type t = source IdMap.map
and source =
| SrcCapture
| SrcLeft | SrcRight
| SrcCst of Types.const
| SrcPair of source * source
| SrcFetch of int
| SrcFetchLeft of int
| SrcFetchRight of int
let capture x = IdMap.singleton x SrcCapture
let captures xs = IdMap.constant SrcCapture xs
let cst x c = IdMap.singleton x (SrcCst c)
let constants cs = IdMap.map (fun c -> SrcCst c) cs
let fetch x f = IdMap.singleton x (SrcFetch f)
let fetch_left f = SrcFetchLeft f
let fetch_right f = SrcFetchRight f
let empty = IdMap.empty
let merge e1 e2 = IdMap.merge (fun s1 s2 -> SrcPair (s1,s2)) e1 e2
let captures_left xs = IdMap.constant SrcLeft xs
let captures_right xs = IdMap.constant SrcRight xs
let rec print_src ppf = function
| SrcCapture -> Format.fprintf ppf "#"
| SrcCapture -> Format.fprintf ppf "v"
| SrcLeft -> Format.fprintf ppf "v1"
| SrcRight -> Format.fprintf ppf "v2"
| SrcCst c -> Types.Print.print_const ppf c
| SrcPair (s1,s2) ->
Format.fprintf ppf "(%a,%a)" print_src s1 print_src s2
| SrcFetch x -> Format.fprintf ppf "$%i" x
| SrcFetchLeft x -> Format.fprintf ppf "x%i" x
| SrcFetchRight x -> Format.fprintf ppf "y%i" x
let print ppf r =
Format.fprintf ppf "{ ";
......@@ -1678,9 +1691,8 @@ x=(1,2)
| TAlt of descr * Types.t * t * t
| TConj of Types.t * fv * t * t
| TOther of descr * Types.t * fv * atoms
| TTimes of descr * Types.t * fv * node * node
| TTimes of Types.pair_kind * int * descr * Types.t * fv * node * node
and atoms =
| TXml of node * node
| TRecord of label * node
let capt pr p =
......@@ -1725,7 +1737,7 @@ x=(1,2)
Types.Print.print t
Print.print_xs xs
print_atom (t,xs,x)
| TTimes (_,t,xs,q1,q2) ->
| TTimes (kind,_,_,t,xs,q1,q2) ->
Format.fprintf ppf "<t=%a;xs=%a;(%a,%a)>"
Types.Print.print t
Print.print_xs xs
......@@ -1733,7 +1745,6 @@ x=(1,2)
Print.print q2.descr
and print_atom ppf (t,xs,d) =
match d with
| TXml _ -> Format.fprintf ppf "<_>_"
| TRecord _ -> Format.fprintf ppf "{_}"
let get_result = function
......@@ -1749,6 +1760,7 @@ x=(1,2)
| Some r -> TargExpr.print ppf r
let uid = ref 0
let rec mk ((a,fv,d) as p) =
let oth x = TOther (p,Types.any,fv,x) in
match d with
......@@ -1757,8 +1769,10 @@ x=(1,2)
| Cap ((a1,fv1,_) as p1,p2) -> TConj (a1,fv1,mk p1,mk p2)
| Capture x -> success (TargExpr.capture x)
| Constant (x,c) -> success (TargExpr.cst x c)
| Times (q1,q2) -> TTimes (p,Types.any,fv,q1,q2)
| Xml (q1,q2) -> oth (TXml (q1,q2))
| Times (q1,q2) ->
TTimes (`Normal,(incr uid; !uid), p,Types.any,fv,q1,q2)
| Xml (q1,q2) ->
TTimes (`XML,(incr uid; !uid), p,Types.any,fv,q1,q2)
| Record (l,q) -> oth (TRecord (l,q))
| Dummy -> assert false
......@@ -1798,8 +1812,8 @@ x=(1,2)
(optimize t (IdSet.cap xs fv1) p1)
(optimize (Types.cap t a1) (IdSet.diff xs fv1) p2)
| TConstr (a,_) -> constr a t
| TTimes (p,_,_,q1,q2) ->
factorize p t xs (fun xs -> TTimes (p,t,xs,q1,q2))
| TTimes (kind,uid, p,_,_,q1,q2) ->
factorize p t xs (fun xs -> TTimes (kind,uid, p,t,xs,q1,q2))
| TOther (p,_,_,x) ->
factorize p t xs (fun xs -> TOther (p,t,xs,x))
| TSucceed -> if Types.is_empty t then TFail else TSucceed
......@@ -1822,28 +1836,33 @@ x=(1,2)
| TConstr (t,s) -> (t,s)::accu
| p -> fold collect_constr accu p
let rec collect_times accu = function
| TTimes (_,t,xs,q1,q2) -> (t,xs,q1,q2)::accu
| p -> fold collect_times accu p
let rec collect_times k accu = function
| TTimes (kind,uid,_,t,xs,q1,q2) when k == kind -> (uid,t,xs,q1,q2)::accu
| p -> fold (collect_times k) accu p
let rec find_binds q reqs binds ofs =
let rec find_binds q reqs binds fetch =
match (reqs,binds) with
| (p2,_)::_, Some b::_ when Pat.equal q.descr p2 ->
IdMap.map (fun i -> TargExpr.SrcFetch (i + ofs)) b
| _::reqs, _::binds -> find_binds q reqs binds ofs
IdMap.map fetch b
| _::reqs, _::binds -> find_binds q reqs binds fetch
| _ -> raise Not_found
let find_binds q reqs binds ofs =
try find_binds q (PatList.Map.get reqs) binds ofs
with Not_found -> IdMap.empty
let find_binds q reqs binds fetch uid extra =
let r = List.assq uid extra in
try TargExpr.merge r (find_binds q (PatList.Map.get reqs) binds fetch)
with Not_found -> r
let rec set_times reqs1 reqs2 binds1 binds2 ar1 =
let rec set_times k swap swap' extra1 extra2 reqs1 reqs2 binds1 binds2 =
let rec aux =
function
| TTimes (_,t,xs,q1,q2) ->
let r1 = find_binds q1 reqs1 binds1 0
and r2 = find_binds q2 reqs2 binds2 100 (* ar1 *) in
let r = IdMap.merge (fun l r -> TargExpr.SrcPair (l,r)) r1 r2 in
| TTimes (kind,uid,_,t,xs,q1,q2) when k == kind->
let (q1,q2) = swap (q1,q2) in
let r1 = find_binds q1 reqs1 binds1 TargExpr.fetch_left uid extra1
and r2 = find_binds q2 reqs2 binds2 TargExpr.fetch_right uid extra2
in
let r = IdMap.merge (fun l r ->
let (l,r) = swap' (l,r) in
TargExpr.SrcPair (l,r)) r1 r2 in
success (IdMap.restrict r xs)
| x -> map aux x
in
......@@ -1855,12 +1874,12 @@ x=(1,2)
let p = mkopt p t fv in
print ppf p;
let ts = collect_times [] p in
let ts = collect_times `Normal [] p in
Format.fprintf ppf "@.First component:@.";
List.iter (fun (t,xs,q1,q2) ->
List.iter (fun (_,t,xs,q1,q2) ->
Format.fprintf ppf "%a / %a"
Print.print q1.descr
Types.Print.print (pi1 t)
Types.Print.print (pi1 ~kind:`Normal t)
) ts
end
......@@ -1879,13 +1898,17 @@ x=(1,2)
| AKind of actions_kind
and actions_kind = {
basic: (Types.t * result) list;
prod: result dispatch dispatch;
prod: actions_prod;
xml: actions_prod;
}
and actions_prod =
| LeftRight of result dispatch dispatch
| RightLeft of result dispatch dispatch
| Impossible
and 'a dispatch =
| Dispatch of dispatcher * 'a array
| TailCall of dispatcher
| Ignore of 'a
| Impossible
and dispatcher = {
id : int;
outputs : output array;
......@@ -1913,6 +1936,7 @@ x=(1,2)
let print ppf r =
Format.fprintf ppf "disp_%i:@." r.id;
(*
Array.iteri
(fun i (t,ar,binds) ->
Format.fprintf ppf "[%i]{%i}{%a} %a@." i ar print_binds binds Types.Print.print t
......@@ -1923,11 +1947,15 @@ x=(1,2)
Derivation.print p
Types.Print.print t
Print.print_xs xs) r.reqs
*)
()
let print_result ppf (code,a) =
Format.fprintf ppf "$%i(" code;
Array.iter
(fun x -> Format.fprintf ppf "%a;" TargExpr.print_src x) a;
Array.iteri
(fun i x -> Format.fprintf ppf "%s%a"
(if i > 0 then "," else "")
TargExpr.print_src x) a;
Format.fprintf ppf ")"
let print_basic_disp ppf l =
......@@ -1938,40 +1966,57 @@ x=(1,2)
print_result res
) l
let arity d code = let (_,n,_) = d.outputs.(code) in n
let print_lhs ppf (s,n) =
if n > 0 then (
Format.fprintf ppf "(%s0" s;
for i = 1 to n - 1 do Format.fprintf ppf ",%s%i" s i done;
Format.fprintf ppf ")"
)
let print_prod2 ppf = function
| Dispatch (d, branches) ->
to_print d;
Format.fprintf ppf " Right(disp_%i)@\n" d.id;
Format.fprintf ppf " match disp_%i v2 with@\n" d.id;
Array.iteri
(fun code res ->
Format.fprintf ppf " | $%i -> %a@."
Format.fprintf ppf " | $%i%a -> %a@."
code
print_lhs ("y", arity d code)
print_result res)
branches
| Ignore res ->
Format.fprintf ppf " Ignore Right@.";
Format.fprintf ppf " %a@."
Format.fprintf ppf " %a@."
print_result res
| _ -> assert false
| TailCall d ->
to_print d;
Format.fprintf ppf " disp_%i v2@\n" d.id
let print_prod ppf = function
let print_prod1 ppf = function
| Dispatch (d,branches) ->
to_print d;
Format.fprintf ppf " | Pair@.";
Format.fprintf ppf " Left(disp_%i)@." d.id;
Format.fprintf ppf " match disp_%i v1 with@." d.id;
Array.iteri
(fun code d2 ->
Format.fprintf ppf " | $%i -> %a@."
Format.fprintf ppf " | $%i%a -> %a@."
code
print_lhs ("x", arity d code)
print_prod2 d2)
branches
| Ignore d2 ->
Format.fprintf ppf " | Pair@.";
Format.fprintf ppf " Ignore Left@.";
Format.fprintf ppf " %a@." print_prod2 d2
| Impossible ->
()
| _ -> assert false
Format.fprintf ppf " %a@." print_prod2 d2
| TailCall d ->
to_print d;
Format.fprintf ppf " disp_%i v1@\n" d.id
let print_prod pr ppf = function
| LeftRight d ->
Format.fprintf ppf " | %s(v1,v2) -> @.%a" pr print_prod1 d
| RightLeft d ->
Format.fprintf ppf " | %s(v2,v1) -> @.%a" pr print_prod1 d
| Impossible -> ()
let rec print_rescode ppf = function
| RFail -> Format.fprintf ppf "Fail"
......@@ -2077,7 +2122,7 @@ x=(1,2)
(* let code = find_code_t0 t0 r in *)
if (code < 0) then (code,[||]) else
let (_,ar,fill) = r.outputs.(code) in
let o = Array.make ar (TargExpr.SrcFetch (-1)) in
let o = Array.make ar (TargExpr.SrcFetchLeft (-1)) in
List.iter2
(fun res fill -> match (res,fill) with
| Some res, Some fill ->
......@@ -2086,7 +2131,7 @@ x=(1,2)
IdMap.iteri (fun x i ->
Format.fprintf Format.std_formatter "%a->%i@."
Ident.print x i) fill;
let fill = IdMap.restrict fill (IdMap.domain res) in *)
let fill = IdMap.restrict fill (IdMap.domain res) in *)
IdMap.collide (fun i r -> o.(i) <- r) fill res
| None, None -> ()
| _ -> assert false)
......@@ -2103,58 +2148,112 @@ x=(1,2)
List.map (fun t -> (t, mk_res t r (opt_all t reqs))) part
let prod_all pi sel selq reqs =
let prod_all k side pi sel selq reqs =
let extra = ref [] in
let aux3 s1 accu t12 =
let t1 = sel t12 in
if (Types.subtype s1 t1) || (Types.disjoint s1 t1) then accu
else add_req accu (constr t1) s1 IdSet.empty in
let aux2 accu (t,s) =
List.fold_left (aux3 (pi s)) accu (Types.Product.get t) in
let aux accu (t,xs,q1,q2) =
List.fold_left (aux3 (pi s)) accu (Types.Product.get ~kind:k t) in
let aux accu (uid,t,xs,q1,q2) =
let q = selq (q1,q2) in
let xs = IdSet.cap xs q.fv in
let p = q.descr in
let t = pi t in
let vs = Approx.approx_var p t xs in
let xs = IdSet.diff xs vs in
let pr = side vs in
extra := (uid,pr)::!extra;
if (IdSet.is_empty xs) && (Types.subtype t (Types.descr q.accept))
then accu
else add_req accu q.descr t xs in
else add_req accu p t xs in
let accu =
List.fold_left aux empty_reqs
(collect_all Derivation.collect_times reqs) in
List.fold_left aux2 accu (collect_all Derivation.collect_constr reqs)
(collect_all (Derivation.collect_times k) reqs) in
let accu =
List.fold_left aux2 accu (collect_all Derivation.collect_constr reqs) in
!extra,accu
let call_disp reqs f =
if PatList.Map.is_empty reqs then Ignore (f (Types.any,0,[]))
else let d = mk reqs in Dispatch (d, Array.map f d.outputs)
let times_disp r =
let t0 = Types.cap r.assumpt Types.Product.any in
let check_tail_call2 d brs =
let chk i = function
| TargExpr.SrcFetchRight j when i = j -> ()
| _ -> raise Exit in
let aux code (code',a) =
let n = arity d code in
if (code != code') || (n != Array.length a) then raise Exit;
Array.iteri chk a in
try Array.iteri aux brs; true with Exit -> false
let opt_tail_call2 = function
| Dispatch (d, brs) when check_tail_call2 d brs -> TailCall d
| d -> d
let check_tail_call1 d brs =
let chk i = function
| TargExpr.SrcFetchLeft j when i = j -> ()
| _ -> raise Exit in
let aux code = function
| Ignore (code',a) ->
let n = arity d code in
if (code != code') || (n != Array.length a) then raise Exit;
Array.iteri chk a
| _ -> raise Exit in
try Array.iteri aux brs; true with Exit -> false
let opt_tail_call1 = function
| Dispatch (d, brs) when check_tail_call1 d brs -> TailCall d
| d -> d
let restr1 c t0 t1 = Types.cap t0 (c (Types.cons t1) Types.any_node)
let restr2 c t0 t2 = Types.cap t0 (c Types.any_node (Types.cons t2))
let swap (x,y) = (y,x)
let noswap (x,y) = (x,y)
let times_disp direction k r =
let c = match k with `XML -> Types.xml | `Normal -> Types.times in
let pi1,pi2,fst,fst',snd,snd',restr1,restr2,swap,swap' =
match direction with
| `LeftRight -> pi1 ~kind:k,pi2 ~kind:k,fst,fst,snd,snd,restr1 c,restr2 c,noswap,noswap
| `RightLeft -> pi2 ~kind:k,pi1 ~kind:k,snd,snd,fst,fst,restr2 c,restr1 c,swap,swap in
let t0 = Types.cap r.assumpt (Types.Product.any_of k) in
if Types.is_empty t0 then Impossible else
let reqs = opt_all t0 r.reqs in
let reqs1 = prod_all pi1 fst fst reqs in
let extra1,reqs1 = prod_all k TargExpr.captures_left pi1 fst fst' reqs in
let second (t1,ar1,binds1) =
let t0 = Types.cap t0 (Types.times (Types.cons t1) Types.any_node) in
let t0 = restr1 t0 t1 in
let reqs = opt_all t0 reqs in
let reqs2 = prod_all pi2 snd snd reqs in
let extra2,reqs2 = prod_all k TargExpr.captures_right pi2 snd snd' reqs in
let final (t2,ar2,binds2) =
let t0 = Types.cap t0 (Types.times Types.any_node (Types.cons t2)) in
let t0 = restr2 t0 t2 in
let reqs = opt_all t0 reqs in
let aux = Derivation.set_times reqs1 reqs2 binds1 binds2 ar1 in
let aux = Derivation.set_times k swap swap' extra1 extra2 reqs1 reqs2 binds1 binds2 in
let reqs = List.map (fun (p,t,xs) -> (aux p,t,xs)) reqs in
mk_res t0 r reqs in
call_disp reqs2 final in
call_disp reqs1 second
opt_tail_call2 (call_disp reqs2 final) in
let r = opt_tail_call1 (call_disp reqs1 second) in
match direction with
| `LeftRight -> LeftRight r
| `RightLeft -> RightLeft r
let print_disp ppf r =
match r.actions with
| Some _ -> ()
| None ->
print ppf r;
let basic = basic_disp r and prod = times_disp r in
let basic = basic_disp r
and prod = times_disp `RightLeft `Normal r
and xml = times_disp `LeftRight `XML r in
print_basic_disp ppf basic;
print_prod ppf prod;
r.actions <- Some (AKind { basic = basic; prod = prod })
print_prod "" ppf prod;
print_prod "XML" ppf xml;
r.actions <- Some (AKind { basic = basic; prod = prod; xml = xml })
let demo ppf t pl =
let (reqs,_) =
......
......@@ -1097,6 +1097,7 @@ struct
let any = { empty with hash = 0; times = any.times }
and any_xml = { empty with hash = 0; xml = any.xml }
let is_empty d = d == []
let any_of = function `XML -> any_xml | `Normal -> any
end
module Record =
......
......@@ -130,6 +130,7 @@ end
module Product : sig
val any : t
val any_xml : t
val any_of: pair_kind -> t
val other : ?kind:pair_kind -> t -> t
val is_product : ?kind:pair_kind -> t -> bool
......
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