Skip to content

GitLab

Commit 08e0fe01 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2004-12-23 21:26:54 by afrisch] Empty log message 

Original author: afrisch
Date: 2004-12-23 21:26:54+00:00
parent a6cb749d
Hide whitespace changes
Inline Side-by-side
types/patterns.ml
View file @ 08e0fe01
......@@ -1633,7 +1633,8 @@ x=(1,2)
else accu in
IdMap.from_list_disj (List.fold_left aux [] (filter_descr t p))
let approx_var ((a,_,_) as p) t = approx_var NodeSet.empty p (Types.cap t a)
let approx_var ((a,_,_) as p) t =
approx_var NodeSet.empty p (Types.cap t a)
end
module TargExpr = struct
......@@ -1647,6 +1648,7 @@ x=(1,2)
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 empty = IdMap.empty
let merge e1 e2 = IdMap.merge (fun s1 s2 -> SrcPair (s1,s2)) e1 e2
......@@ -1771,6 +1773,11 @@ x=(1,2)
let vs = Approx.approx_var p t xs in
let xs = IdSet.diff xs vs in
let pr = TargExpr.captures vs in
let vs = Approx.approx_cst p t xs in
let xs = IdSet.diff xs (IdMap.domain vs) in
let pr = TargExpr.merge (TargExpr.constants vs) pr in
capt pr (if (IdSet.is_empty xs) then constr a t else f xs)
......@@ -1825,16 +1832,17 @@ x=(1,2)
| (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
| _ -> 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 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
and r2 = find_binds q2 reqs2 binds2 100 (* 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
......@@ -1865,7 +1873,7 @@ x=(1,2)
| RCode of int
| RSwitch of rescode * rescode
type result = int * TargExpr.source array
type result = int * TargExpr.source array
type actions =
| AIgnore of result
| AKind of actions_kind
......@@ -1887,12 +1895,33 @@ x=(1,2)
mutable actions : actions option;
}
let print_queue = Queue.create ()
let to_print d = Queue.push d print_queue
let print_binds ppf binds =
List.iter
(function
| None -> Format.fprintf ppf "* "
| Some m ->
Format.fprintf ppf "( ";
IdMap.iteri
(fun x i ->
Format.fprintf Format.std_formatter "%a:%i "
Ident.print x i) m;
Format.fprintf ppf ") ";) binds
let print ppf r =
Format.fprintf ppf "Request@.";
Format.fprintf ppf "disp_%i:@." r.id;
Array.iteri
(fun i (t,ar,_) ->
Format.fprintf ppf "[%i] %a@." i Types.Print.print t
) r.outputs
(fun i (t,ar,binds) ->
Format.fprintf ppf "[%i]{%i}{%a} %a@." i ar print_binds binds Types.Print.print t
) r.outputs;
List.iter
(fun (p,t,xs) ->
Format.fprintf ppf "%a. t=%a. xs=%a@."
Derivation.print p
Types.Print.print t
Print.print_xs xs) r.reqs
let print_result ppf (code,a) =
Format.fprintf ppf "$%i(" code;
......@@ -1910,6 +1939,7 @@ x=(1,2)
let print_prod2 ppf = function
| Dispatch (d, branches) ->
to_print d;
Format.fprintf ppf " Right(disp_%i)@\n" d.id;
Array.iteri
(fun code res ->
......@@ -1925,6 +1955,7 @@ x=(1,2)
let print_prod ppf = function
| Dispatch (d,branches) ->
to_print d;
Format.fprintf ppf " | Pair@.";
Format.fprintf ppf " Left(disp_%i)@." d.id;
Array.iteri
......@@ -1937,6 +1968,8 @@ x=(1,2)
Format.fprintf ppf " | Pair@.";
Format.fprintf ppf " Ignore Left@.";
Format.fprintf ppf " %a@." print_prod2 d2
| Impossible ->
()
| _ -> assert false
let rec print_rescode ppf = function
......@@ -1948,7 +1981,8 @@ x=(1,2)
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
| _ -> (-1) (* assert false *)
(*
let find_code bl rc =
Format.fprintf Format.std_formatter "%a@." print_rescode rc;
......@@ -1959,6 +1993,15 @@ x=(1,2)
find_code bl rc
*)
let find_code_t0 t0 r =
let rec aux i =
if i = Array.length r.outputs then (-1)
else
let (t,_,_) = r.outputs.(i) in
if Types.subtype t0 t then i else aux (succ i)
in
aux 0
let alloc pos fv =
let i = ref (pos - 1) in
let r = IdMap.map_from_slist (fun x -> incr i; !i) fv in
......@@ -1973,11 +2016,11 @@ x=(1,2)
else match l with
| [] -> incr nb; codes := (t0,ar,List.rev binds) :: !codes; RCode !nb
| ((a,fv,_),(t,xs)) :: rem ->
let (alc,ar') = alloc ar fv in
let (alc,ar') = alloc ar xs in
RSwitch
(aux (Types.cap t0 a)
(aux (Types.diff t0 (Types.diff t a))
ar' (Some alc::binds) rem,
aux (Types.diff t0 a)
aux (Types.diff t0 (Types.cap t a))
ar (None::binds) rem)
in
let reqs = PatList.Map.get reqs in
......@@ -1985,6 +2028,7 @@ x=(1,2)
List.fold_left
(fun accu (_,(t,_)) -> Types.cup accu t) Types.empty
reqs in
(* let t0 = Types.any in *)
let rc = aux t0 0 [] reqs in
let os = Array.of_list (List.rev !codes) in
let ders = List.map
......@@ -2019,14 +2063,26 @@ x=(1,2)
let collect_all f reqs =
List.fold_left (fun accu (p,_,_) -> f accu p) [] reqs
let mk_res r reqs =
let mk_res t0 r reqs =
(* Format.fprintf Format.std_formatter "mk_res t=%a@." Types.Print.print t0;
List.iter (fun (p,_,_) ->
Format.fprintf Format.std_formatter "%a@."
Derivation.print p) reqs; *)
let res = get_results reqs in
let code = find_code res r.rescode in
(* 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
List.iter2
(fun res fill -> match (res,fill) with
| Some res, Some fill ->
(* Format.fprintf Format.std_formatter "Res=%a@."
TargExpr.print res;
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 *)
IdMap.collide (fun i r -> o.(i) <- r) fill res
| None, None -> ()
| _ -> assert false)
......@@ -2040,26 +2096,27 @@ x=(1,2)
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
List.map (fun t -> (t, mk_res t r (opt_all t reqs))) part
let prod_types pi sel accu reqs =
let aux2 s1 accu t12 =
let prod_all pi sel selq reqs =
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 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 aux2 accu (t,s) =
List.fold_left (aux3 (pi s)) accu (Types.Product.get t) in
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 xs = IdSet.cap xs q.fv in
let t = pi t in
if (IdSet.is_empty xs) && (Types.subtype t (Types.descr q.accept))
then accu
else add_req accu q.descr 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)
let call_disp reqs f =
if PatList.Map.is_empty reqs then Ignore (f (Types.any,0,[]))
......@@ -2067,6 +2124,7 @@ x=(1,2)
let times_disp r =
let t0 = Types.cap r.assumpt Types.Product.any 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 second (t1,ar1,binds1) =
......@@ -2078,19 +2136,29 @@ x=(1,2)
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
mk_res t0 r reqs in
call_disp reqs2 final in
call_disp reqs1 second
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
print_basic_disp ppf basic;
print_prod ppf prod;
r.actions <- Some (AKind { basic = basic; prod = prod })
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 in
print ppf r;
print_basic_disp ppf (basic_disp r);
print_prod ppf (times_disp r)
to_print r;
(try while true do print_disp ppf (Queue.take print_queue) done;
with Queue.Empty -> ())
end
......@@ -2104,3 +2172,10 @@ let approx ((_,fv,_) as p) t =
let demo = Compile2.Derivation.demo
let demo_compile = Compile2.Request.demo
(* Failure:
debug compile [ Int* Char* ] [ (x::Int|y::_)* ];;
*)
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