Skip to content

GitLab

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

[r2004-12-23 18:38:55 by afrisch] Continuing compilation 

Original author: afrisch
Date: 2004-12-23 18:38:55+00:00
parent 2ab48a3e
Hide whitespace changes
Inline Side-by-side
Showing with 216 additions and 76 deletions
types/patterns.ml
View file @ a6cb749d
......@@ -1676,9 +1676,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 descr * Types.t * fv * node * node
and atoms =
| TTimes of node * node
| TXml of node * node
| TRecord of label * node
......@@ -1688,6 +1687,9 @@ x=(1,2)
| TFail -> TFail
| p -> TCapt (pr,p)
let success pr =
capt pr TSucceed
let rec conj a1 fv1 r1 r2 = match (r1,r2) with
| TSucceed,r | r,TSucceed -> r
| TFail,r | r,TFail -> TFail
......@@ -1721,16 +1723,14 @@ x=(1,2)
Types.Print.print t
Print.print_xs xs
print_atom (t,xs,x)
| TTimes (_,t,xs,q1,q2) ->
Format.fprintf ppf "<t=%a;xs=%a;(%a,%a)>"
Types.Print.print t
Print.print_xs xs
Print.print q1.descr
Print.print q2.descr
and print_atom ppf (t,xs,d) =
match d with
| TTimes (q1,q2) ->
if IdSet.is_empty xs then
Format.fprintf ppf "(%a,%a)"
Types.Print.print_node q1.accept
Types.Print.print_node q2.accept
else
Format.fprintf ppf "(%a,%a)"
Print.print q1.descr Print.print q2.descr
| TXml _ -> Format.fprintf ppf "<_>_"
| TRecord _ -> Format.fprintf ppf "{_}"
......@@ -1753,9 +1753,9 @@ x=(1,2)
| Constr t -> TConstr (t, Types.any)
| Cup ((a1,_,_) as p1,p2) -> TAlt (p, a1,mk p1, mk p2)
| Cap ((a1,fv1,_) as p1,p2) -> TConj (a1,fv1,mk p1,mk p2)
| Capture x -> TCapt (TargExpr.capture x, TSucceed)
| Constant (x,c) -> TCapt (TargExpr.cst x c, TSucceed)
| Times (q1,q2) -> oth (TTimes (q1,q2))
| 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))
| Record (l,q) -> oth (TRecord (l,q))
| Dummy -> assert false
......@@ -1791,6 +1791,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))
| TOther (p,_,_,x) ->
factorize p t xs (fun xs -> TOther (p,t,xs,x))
| TSucceed -> if Types.is_empty t then TFail else TSucceed
......@@ -1799,20 +1801,45 @@ x=(1,2)
let rec fold f accu = function
| TCapt (_,p) -> fold f accu p
| TAlt (_,_,p1,p2) | TConj (_,_,p1,p2) -> fold f (fold f accu p1) p2
| TOther (_,t,xs,x) -> f accu t xs x
let fold f accu = function
| TCapt (_,p) -> f accu p
| TAlt (_,_,p1,p2) | TConj (_,_,p1,p2) -> f (f accu p1) p2
| _ -> accu
let map f = function
| TCapt (pr,p) -> capt pr (f p)
| TAlt (p,a1,p1,p2) -> alt p a1 (f p1) (f p2)
| TConj (a1,fv1,p1,p2) -> conj a1 fv1 (f p1) (f p2)
| x -> x
let rec collect_constr accu = function
| TCapt (_,p) -> collect_constr accu p
| TAlt (_,_,p1,p2) | TConj (_,_,p1,p2) ->
collect_constr (collect_constr accu p1) p2
| TConstr (t,s) -> (t,s)::accu
| _ -> accu
| p -> fold collect_constr accu p
let collect_basic = collect_constr
let rec collect_times accu = function
| TTimes (_,t,xs,q1,q2) -> (t,xs,q1,q2)::accu
| p -> fold collect_times accu p
let rec find_binds q reqs binds ofs =
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
| _ -> assert false
let find_binds q reqs binds =
find_binds q (PatList.Map.get reqs) binds
let rec set_times reqs1 reqs2 binds1 binds2 ar1 =
let rec aux =
function
| TTimes (_,t,xs,q1,q2) ->
let r1 = find_binds q1 reqs1 binds1 0
and r2 = find_binds q2 reqs2 binds2 ar1 in
let r = IdMap.merge (fun l r -> TargExpr.SrcPair (l,r)) r1 r2 in
success (IdMap.restrict r xs)
| x -> map aux x
in
aux
let mkopt p t xs = optimize t xs (mk p)
......@@ -1820,19 +1847,13 @@ x=(1,2)
let p = mkopt p t fv in
print ppf p;
let qs = collect_basic [] p in
let part = Types.cond_partition Types.non_constructed qs in
let t = Types.cap t Types.non_constructed in
Format.fprintf ppf "@.Partition:@.";
List.iter (fun t' ->
let t = Types.cap t t' in
let r = optimize t fv p in
Format.fprintf ppf "%a => %a@."
Types.Print.print t
print r;
Format.fprintf ppf " => %a@."
print_result (get_result r)
) part
let ts = collect_times [] p in
Format.fprintf ppf "@.First component:@.";
List.iter (fun (t,xs,q1,q2) ->
Format.fprintf ppf "%a / %a"
Print.print q1.descr
Types.Print.print (pi1 t)
) ts
end
......@@ -1844,15 +1865,28 @@ x=(1,2)
| RCode of int
| RSwitch of rescode * rescode
type t = {
type result = int * TargExpr.source array
type actions =
| AIgnore of result
| AKind of actions_kind
and actions_kind = {
basic: (Types.t * result) list;
prod: result dispatch dispatch;
}
and 'a dispatch =
| Dispatch of dispatcher * 'a array
| TailCall of dispatcher
| Ignore of 'a
| Impossible
and dispatcher = {
id : int;
outputs : output array;
rescode : rescode;
reqs : (Derivation.t * Types.t * fv) list;
assumpt : Types.t;
mutable actions : actions option;
}
type basic_disp = (Types.t * int * TargExpr.source array) list
let print ppf r =
Format.fprintf ppf "Request@.";
Array.iteri
......@@ -1860,26 +1894,78 @@ x=(1,2)
Format.fprintf ppf "[%i] %a@." i Types.Print.print t
) r.outputs
let print_result ppf (code,a) =
Format.fprintf ppf "$%i(" code;
Array.iter
(fun x -> Format.fprintf ppf "%a;" TargExpr.print_src x) a;
Format.fprintf ppf ")"
let print_basic_disp ppf l =
List.iter
(fun (t,code,a) ->
Format.fprintf ppf "%a => $%i(" Types.Print.print t code;
Array.iter
(fun x -> Format.fprintf ppf "%a;" TargExpr.print_src x) a;
Format.fprintf ppf ")@.";
(fun (t,res) ->
Format.fprintf ppf " | %a -> %a@."
Types.Print.print t
print_result res
) l
let print_prod2 ppf = function
| Dispatch (d, branches) ->
Format.fprintf ppf " Right(disp_%i)@\n" d.id;
Array.iteri
(fun code res ->
Format.fprintf ppf " | $%i -> %a@."
code
print_result res)
branches
| Ignore res ->
Format.fprintf ppf " Ignore Right@.";
Format.fprintf ppf " %a@."
print_result res
| _ -> assert false
let print_prod ppf = function
| Dispatch (d,branches) ->
Format.fprintf ppf " | Pair@.";
Format.fprintf ppf " Left(disp_%i)@." d.id;
Array.iteri
(fun code d2 ->
Format.fprintf ppf " | $%i -> %a@."
code
print_prod2 d2)
branches
| Ignore d2 ->
Format.fprintf ppf " | Pair@.";
Format.fprintf ppf " Ignore Left@.";
Format.fprintf ppf " %a@." print_prod2 d2
| _ -> assert false
let rec print_rescode ppf = function
| RFail -> Format.fprintf ppf "Fail"
| RCode i -> Format.fprintf ppf "(%i)" i
| RSwitch (a,b) ->
Format.fprintf ppf "S(%a,%a)" print_rescode a print_rescode b
let rec find_code bl rc = match (bl,rc) with
| Some _::bl,RSwitch (rc,_) | None::bl,RSwitch (_,rc) -> find_code bl rc
| ([], RCode i) -> i
| _ -> assert false
(*
let find_code bl rc =
Format.fprintf Format.std_formatter "%a@." print_rescode rc;
List.iter (fun x ->
Format.fprintf Format.std_formatter "%b "
(x != None)) bl;
Format.fprintf Format.std_formatter "@.";
find_code bl rc
*)
let alloc pos fv =
let i = ref (pos - 1) in
let r = IdMap.map_from_slist (fun x -> incr i; !i) fv in
(r,!i + 1)
let mk reqs t0 =
let disp_id = ref 0
let mk reqs =
let nb = ref (-1) in
let codes = ref [] in
let rec aux t0 ar binds l =
......@@ -1895,62 +1981,116 @@ x=(1,2)
ar (None::binds) rem)
in
let reqs = PatList.Map.get reqs in
(* let t0 =
let t0 =
List.fold_left
(fun accu (_,(t,_)) -> Types.cup accu t) Types.empty
reqs in *)
reqs in
let rc = aux t0 0 [] reqs in
let os = Array.of_list (List.rev !codes) in
let ders = List.map
(fun (p,(t,xs)) -> (Derivation.mkopt p t xs, t, xs)) reqs in
{ outputs = os;
{ id = (incr disp_id; !disp_id);
outputs = os;
rescode = rc;
reqs = ders;
assumpt = t0
}
assumpt = t0;
actions = None }
module ReqTable = Hashtbl.Make(Req)
let disps = ReqTable.create 1023
let mk reqs =
try ReqTable.find disps reqs
with Not_found ->
let d = mk reqs in
ReqTable.add disps reqs d;
d
let opt_all t0 =
List.map
(fun (p,t,xs) ->
if Types.subtype t t0 then (p,t,xs) else
let t = Types.cap t t0 in
(Derivation.optimize t xs p, t, xs))
if Types.subtype t t0 then (p,t,xs)
else let t = Types.cap t t0 in (Derivation.optimize t xs p, t, xs))
let get_results reqs =
List.map (fun (p,_,_) -> Derivation.get_result p) reqs
let basic_disp r : basic_disp =
let collect_all f reqs =
List.fold_left (fun accu (p,_,_) -> f accu p) [] reqs
let mk_res r reqs =
let res = get_results reqs in
let code = find_code res r.rescode in
let (_,ar,fill) = r.outputs.(code) in
let o = Array.make ar (TargExpr.SrcFetch (-1)) in
List.iter2
(fun res fill -> match (res,fill) with
| Some res, Some fill ->
IdMap.collide (fun i r -> o.(i) <- r) fill res
| None, None -> ()
| _ -> assert false)
res fill;
(code,o)
let basic_disp r =
let t0 = Types.cap r.assumpt Types.non_constructed in
if Types.is_empty t0 then []
else
let reqs = opt_all t0 r.reqs in
let qs = collect_all Derivation.collect_constr reqs in
let part = Types.cond_partition t0 qs in
List.map (fun t -> (t, mk_res r (opt_all t reqs))) part
let prod_types pi sel accu reqs =
let aux2 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 aux accu (t,s) =
List.fold_left (aux2 (pi s)) accu (Types.Product.get t) in
List.fold_left aux accu (collect_all Derivation.collect_constr reqs)
let prod_pat pi selq reqs =
let aux accu (t,xs,q1,q2) =
let q = selq (q1,q2) in
add_req accu q.descr (pi t) (IdSet.cap xs q.fv) in
List.fold_left aux empty_reqs (collect_all Derivation.collect_times reqs)
let prod_all pi sel selq reqs =
prod_types pi sel (prod_pat pi selq reqs) reqs
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 reqs = opt_all t0 r.reqs in
let qs =
List.fold_left
(fun accu (p,_,_) -> Derivation.collect_basic accu p) [] reqs in
let part = Types.cond_partition t0 qs in
List.map
(fun t ->
let reqs = opt_all t reqs in
let res = get_results reqs in
let code = find_code res r.rescode in
let (_,ar,fill) = r.outputs.(code) in
let o = Array.make ar (TargExpr.SrcFetch (-1)) in
List.iter2
(fun res fill -> match (res,fill) with
| Some res, Some fill ->
IdMap.iteri (fun x i -> o.(i) <- IdMap.assoc x res) fill
| None, None -> ()
| _ -> assert false)
res fill;
(t,code,o)
) part
let reqs1 = prod_all 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 reqs = opt_all t0 reqs in
let reqs2 = prod_all 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 reqs = opt_all t0 reqs in
let aux = Derivation.set_times reqs1 reqs2 binds1 binds2 ar1 in
let reqs = List.map (fun (p,t,xs) -> (aux p,t,xs)) reqs in
mk_res r reqs in
call_disp reqs2 final in
call_disp reqs1 second
let demo ppf t pl =
let (reqs,_) =
List.fold_left
(fun (reqs,t) ((a,fv,_) as p) ->
(add_req reqs p t fv, Types.diff t a)) (empty_reqs,t) pl in
let r = mk reqs t in
let r = mk reqs in
print ppf r;
print_basic_disp ppf (basic_disp r)
print_basic_disp ppf (basic_disp r);
print_prod ppf (times_disp r)
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