Skip to content

GitLab

Commit 2c52fed9 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2004-12-25 05:09:22 by afrisch] Records 

Original author: afrisch
Date: 2004-12-25 05:09:22+00:00
parent f44e60be
Hide whitespace changes
Inline Side-by-side
Showing with 232 additions and 106 deletions
types/patterns.ml
View file @ 2c52fed9
......@@ -1657,6 +1657,9 @@ x=(1,2)
| SrcPair of source * source
| SrcFetchLeft of int
| SrcFetchRight of int
| SrcLocal of int
type push = PushConst of Types.const | PushField | PushCapture
let capture x = IdMap.singleton x SrcCapture
let captures xs = IdMap.constant SrcCapture xs
......@@ -1664,6 +1667,7 @@ x=(1,2)
let constants cs = IdMap.map (fun c -> SrcCst c) cs
let fetch_left f = SrcFetchLeft f
let fetch_right f = SrcFetchRight f
let fetch_local ofs i = SrcLocal (ofs + i)
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
......@@ -1678,6 +1682,7 @@ x=(1,2)
Format.fprintf ppf "(%a,%a)" print_src s1 print_src s2
| SrcFetchLeft x -> Format.fprintf ppf "x%i" x
| SrcFetchRight x -> Format.fprintf ppf "y%i" x
| SrcLocal x -> Format.fprintf ppf "local(%i)" x
let print ppf r =
Format.fprintf ppf "{ ";
......@@ -1699,6 +1704,28 @@ x=(1,2)
| TTimes of Types.pair_kind * int * descr * Types.t * fv * node * node
| TRecord of int * descr * Types.t * fv * label * node
(* TODO: allocate the stack locations by sorting the ids
(to allow ({ l = (x,y) } | (x:=1)&(y:=2))) *)
let push_csts pushes locals =
let push x =
pushes := x :: !pushes;
let loc = TargExpr.SrcLocal !locals in
incr locals; loc in
let reloc = function
| TargExpr.SrcCst c -> push (TargExpr.PushConst c)
| TargExpr.SrcLeft -> push TargExpr.PushField
| TargExpr.SrcCapture -> push TargExpr.PushCapture
| TargExpr.SrcLocal _ as s -> s
| _ -> assert false
in
let rec aux = function
| TCapt (pr,p) -> TCapt (IdMap.map reloc pr, p)
| TAlt (p,a1,p1,p2) -> TAlt (p,a1,aux p1,aux p2)
| TConj (a1,fv1,p1,p2) -> TConj (a1,fv1,aux p1, aux p2)
| p -> p
in
aux
let capt pr p =
if IdMap.is_empty pr then p else match p with
| TCapt (pr2,p) -> TCapt (TargExpr.merge pr pr2,p)
......@@ -1782,17 +1809,24 @@ x=(1,2)
else if Types.subtype t a then TSucceed
else TConstr (a,t)
let factorize ((a,_,_) as p) t xs f =
if Types.disjoint a t then TFail
else
let vs = Approx.approx_var p t xs in
let xs = IdSet.diff xs vs in
let pr = TargExpr.captures vs in
let approx_var p t xs f =
let vs = Approx.approx_var p t xs in
let xs = IdSet.diff xs vs in
let pr = f vs in
(pr,xs)
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
let approx_cst p t xs f =
let vs = Approx.approx_cst p t xs in
let xs = IdSet.diff xs (IdMap.domain vs) in
let pr = f vs in
(pr,xs)
let factorize ((a,_,_) as p) t xs f =
if Types.disjoint a t then TFail
else
let pr,xs = approx_var p t xs TargExpr.captures in
let pr',xs = approx_cst p t xs TargExpr.constants in
let pr = TargExpr.merge pr pr' in
capt pr (if (IdSet.is_empty xs) then constrain a t else f xs)
......@@ -1827,24 +1861,41 @@ x=(1,2)
| TCapt (_,p) -> f accu p
| TAlt (_,_,p1,p2) | TConj (_,_,p1,p2) -> f (f accu p1) p2
| _ -> accu
let iter f = function
| TCapt (_,p) -> f p
| TAlt (_,_,p1,p2) | TConj (_,_,p1,p2) -> f p1; f p2
| _ -> ()
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
| TConstr (t,s) -> (t,s)::accu
| p -> fold collect_constr accu p
let iter_constr f =
let rec aux = function
| TConstr (t,s) -> f (t,s)
| p -> iter aux p
in aux
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 iter_times k f =
let rec aux = function
| TTimes (kind,uid,_,t,xs,q1,q2) when k == kind -> f (uid,t,xs,q1,q2)
| p -> iter aux p
in aux
let rec collect_record accu = function
| TRecord (uid,_,t,xs,l,q) -> (uid,t,xs,l,q)::accu
| p -> fold collect_record accu p
let iter_records f =
let rec aux = function
| TRecord (uid,_,t,xs,l,q) -> f (uid,t,xs,l,q)
| p -> iter aux p
in aux
let iter_field l f =
let rec aux = function
| TRecord (uid,_,t,xs,l',q) when l == l' -> f (uid,t,xs,q)
| p -> iter aux p
in aux
let opt_all t0 =
List.map
......@@ -1855,49 +1906,55 @@ x=(1,2)
let get_results reqs =
List.map (fun (p,_,_) -> get_result p) reqs
let collect_all f reqs =
List.fold_left (fun accu (p,_,_) -> f accu p) [] reqs
let iter_all f g reqs =
List.iter (fun (p,_,_) -> f g p) reqs
let prod_all k side pi sel selq reqs =
let get_all pi get sel extract iter side reqs =
let extra = ref [] in
let aux3 s1 accu t12 =
let res = ref empty_reqs in
let aux3 s1 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 ~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
if not ((Types.subtype s1 t1) || (Types.disjoint s1 t1))
then res := add_req !res (constr t1) s1 IdSet.empty in
let aux2 (t,s) = List.iter (aux3 (pi s)) (get t) in
let aux z =
let uid,t,xs,q = extract z in
let xs = IdSet.cap xs q.fv and p = q.descr and t = pi t in
let pr,xs = approx_var p t xs side in
extra := (uid,pr)::!extra;
if not ((IdSet.is_empty xs)
&& (Types.subtype t (Types.descr q.accept))) then
res := add_req !res p t xs in
iter_all iter aux reqs;
iter_all iter_constr aux2 reqs;
!extra,!res
let prod_all k side pi sel selq reqs =
get_all pi (Types.Product.get ~kind:k) sel
(fun (uid,t,xs,q1,q2) -> uid,t,xs,selq (q1,q2))
(iter_times k)
side
reqs
let all_labels reqs =
let res = ref LabelSet.empty in
let aux2 (t,_) = res := LabelSet.cup !res (Types.Record.all_labels t) in
let aux (_,_,_,l,_) = res := LabelSet.add l !res in
iter_all iter_records aux reqs;
iter_all iter_constr aux2 reqs;
LabelSet.get !res
let record_all l reqs =
let extra,res =
get_all (Types.Record.pi l) (fun t -> Types.Record.split t l) fst
(fun z -> z)
(iter_field l)
TargExpr.captures_left
reqs in
extra,res
if (IdSet.is_empty xs) && (Types.subtype t (Types.descr q.accept))
then accu
else add_req accu p t xs in
let accu =
List.fold_left aux empty_reqs
(collect_all (collect_times k) reqs) in
let accu =
List.fold_left aux2 accu (collect_all collect_constr reqs) in
!extra,accu
let first_label reqs =
let min = ref LabelPool.dummy_max in
let f l = if l < !min then min := l in
let aux2 (t,_) = f (Types.Record.first_label t) in
let aux (_,_,_,l,_) = f l in
List.iter aux (collect_all collect_record reqs);
List.iter aux2 (collect_all collect_constr reqs);
!min
let rec find_binds q reqs binds fetch =
let rec find_binds q reqs binds fetch =
match (reqs,binds) with
| (p2,_)::_, Some b::_ when Pat.equal q.descr p2 ->
IdMap.map fetch b
......@@ -1922,6 +1979,18 @@ x=(1,2)
in
aux
let rec set_field l locals extra1 reqs1 binds1 =
let rec aux = function
| TRecord (uid,_,t,xs,l',q) when l == l' ->
let r = find_binds q reqs1 binds1
(TargExpr.fetch_local locals) uid extra1
in
success (IdMap.restrict r xs)
| x -> map aux x
in
aux
let mkopt p t xs = optimize t xs (mk p)
let demo ppf ((_,fv,_) as p) t =
......@@ -1929,14 +1998,14 @@ x=(1,2)
(* Format.fprintf ppf "%a@." print p; *)
let p = optimize t fv p in
Format.fprintf ppf "%a@." print p;
let ts = collect_record [] p in
Format.fprintf ppf "@.Fields:@.";
List.iter (fun (_,t,xs,l,q) ->
Format.fprintf ppf "(%a=%a) / %a@."
print_lab l
Print.print q.descr
Types.Print.print (Types.Record.project_opt t l)
) ts
iter_records
(fun (_,t,xs,l,q) ->
Format.fprintf ppf "(%a=%a) / %a@."
print_lab l
Print.print q.descr
Types.Print.print (Types.Record.project_opt t l)
) p
end
......@@ -1956,8 +2025,14 @@ x=(1,2)
basic: (Types.t * result) list;
prod: actions_prod;
xml: actions_prod;
record: label;
record: actions_record;
}
and actions_record =
| RecordLabel of label * dispatcher * record_tr array
| RecordLabelSkip of label * record_tr
| RecordNolabel of result
| RecordImpossible
and record_tr = (TargExpr.push list * actions_record)
and actions_prod =
| LeftRight of result dispatch dispatch
| RightLeft of result dispatch dispatch
......@@ -2076,8 +2151,36 @@ x=(1,2)
| Impossible -> ()
let print_record ppf l =
Format.fprintf ppf "First label = %a@." print_lab l
let print_pushes ppf l =
List.iter
(function
| TargExpr.PushConst c ->
Format.fprintf ppf "{push %a}" Types.Print.print_const c
| TargExpr.PushField ->
Format.fprintf ppf "{push field}"
| TargExpr.PushCapture ->
Format.fprintf ppf "{push record}"
) l
let rec print_field ppf = function
| RecordImpossible -> ()
| RecordLabel (l,d,cts) ->
to_print d;
Format.fprintf ppf "(label:%a,disp_%i" print_lab l d.id;
Array.iteri (fun i (pushes,x) ->
Format.fprintf ppf ";%i->%a%a" i
print_pushes pushes print_field x) cts;
Format.fprintf ppf ")"
| RecordLabelSkip (l,(pushes,cts)) ->
Format.fprintf ppf "(label:%a;%a%a)" print_lab l
print_pushes pushes
print_field cts
| RecordNolabel res ->
Format.fprintf ppf "[%a]" print_result res
let print_record ppf r =
Format.fprintf ppf "Record:%a@." print_field r
let rec print_rescode ppf = function
| RFail -> Format.fprintf ppf "Fail"
......@@ -2193,41 +2296,12 @@ x=(1,2)
if Types.is_empty t0 then []
else
let reqs = Derivation.opt_all t0 r.reqs in
let qs = Derivation.collect_all Derivation.collect_constr reqs in
let part = Types.cond_partition t0 qs in
let qs = ref [] in let aux x = qs := x::!qs in
Derivation.iter_all Derivation.iter_constr aux reqs;
let part = Types.cond_partition t0 !qs in
List.map (fun t -> (t, mk_res t r (Derivation.opt_all t reqs))) part
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 ~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 p t xs in
let accu =
List.fold_left aux empty_reqs
(Derivation.collect_all (Derivation.collect_times k) reqs) in
let accu =
List.fold_left aux2 accu (Derivation.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)
......@@ -2267,24 +2341,32 @@ x=(1,2)
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
| `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 = Derivation.opt_all t0 r.reqs in
let extra1,reqs1 = prod_all k TargExpr.captures_left pi1 fst fst' reqs in
let extra1,reqs1 = Derivation.prod_all
k TargExpr.captures_left pi1 fst fst' reqs in
let second (t1,ar1,binds1) =
let t0 = restr1 t0 t1 in
let reqs = Derivation.opt_all t0 reqs in
let extra2,reqs2 = prod_all k TargExpr.captures_right pi2 snd snd' reqs in
let extra2,reqs2 =
Derivation.prod_all k TargExpr.captures_right pi2 snd snd' reqs in
let final (t2,ar2,binds2) =
let t0 = restr2 t0 t2 in
let reqs = Derivation.opt_all t0 reqs in
let aux = Derivation.set_times k swap swap' extra1 extra2 reqs1 reqs2 binds1 binds2 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
opt_tail_call2 (call_disp reqs2 final) in
......@@ -2295,8 +2377,38 @@ x=(1,2)
let record_disp r =
let t0 = Types.cap r.assumpt Types.Record.any in
if Types.is_empty t0 then RecordImpossible else
let reqs = Derivation.opt_all t0 r.reqs in
Derivation.first_label reqs
let labs = Derivation.all_labels reqs in
(* TODO: memoize the field function *)
let rec field t0 reqs locals = function
| [] ->
(* TODO: distinguish between More / No more fields *)
RecordNolabel (mk_res t0 r reqs)
| l::labs ->
let extra1,reqs1 = Derivation.record_all l reqs in
let contin (t1,ar1,binds1) =
let t0 = Types.cap t0 (Types.record l (Types.cons t1)) in
let reqs = Derivation.opt_all t0 reqs in
let aux =
Derivation.set_field l locals extra1 reqs1 binds1 in
let reqs = List.map (fun (p,t,xs) -> (aux p,t,xs)) reqs in
let locals = ref (locals + ar1) in
let pushes = ref [] in
let aux = Derivation.push_csts pushes locals in
let reqs = List.map (fun (p,t,xs) -> (aux p,t,xs)) reqs in
(List.rev !pushes, field t0 reqs !locals labs)
in
if PatList.Map.is_empty reqs1
then
match contin (Types.any,0,[]) with
| [],c -> c
| x -> RecordLabelSkip (l,x)
else
let d = mk reqs1 in
RecordLabel (l, d, Array.map contin d.outputs)
in
field t0 reqs 0 labs
let print_disp ppf r =
match r.actions with
......
types/types.ml
View file @ 2c52fed9
......@@ -1176,13 +1176,15 @@ struct
TR.boolean_normal (aux_split d l)
let pi l d = TR.pi1 (split d l)
let project d l =
let t = TR.pi1 (split d l) in
let t = pi l d in
if t.absent then raise Not_found;
t
let project_opt d l =
let t = TR.pi1 (split d l) in
let t = pi l d in
{ t with hash = 0; absent = false }
let condition d l t =
......@@ -1194,6 +1196,14 @@ struct
let remove_field d l =
cap (TR.pi2 (split d l)) (record l only_absent_node)
let all_labels d =
let res = ref LabelSet.empty in
let aux (_,r) =
let ls = LabelMap.domain r in
res := LabelSet.cup ls !res in
BoolRec.iter aux d.record;
!res
let first_label d =
let min = ref LabelPool.dummy_max in
let aux (_,r) =
......
types/types.mli
View file @ 2c52fed9
......@@ -169,6 +169,9 @@ module Record : sig
val split : t -> label -> Product.t
val split_normal : t -> label -> Product.normal
val pi : label -> t -> t
(* May contain absent *)
val project : t -> label -> t
(* Raise Not_found if label is not necessarily present *)
......@@ -179,6 +182,7 @@ module Record : sig
val first_label: t -> label
val all_labels: t -> LabelSet.t
val empty_cases: t -> bool * 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