Commit 853deb85 authored by Andrei Paskevich's avatar Andrei Paskevich
Browse files

Ity: effect instantiation

parent e017894d
...@@ -720,53 +720,38 @@ let refresh_of_effect e = ...@@ -720,53 +720,38 @@ let refresh_of_effect e =
Mtv.fold add_rfr sbst rfr) e.eff_writes Mreg.empty in Mtv.fold add_rfr sbst rfr) e.eff_writes Mreg.empty in
{ e with eff_resets = Mreg.union merge_covers e.eff_resets rfr } { e with eff_resets = Mreg.union merge_covers e.eff_resets rfr }
(*
exception IllegalAlias of region exception IllegalAlias of region
let eff_full_inst sbs e = let eff_full_inst sbs e =
(* modified or reset regions in e *) (* all modified or reset regions in e must be instantiated
let wrt = Mreg.map (Util.const ()) e.eff_writes in into distinct regions *)
let rst = Mreg.map (Util.const ()) e.eff_resets in let inst fn src = Mreg.fold (fun r v acc ->
let wrt = Sreg.union wrt rst in let r = ity_full_inst sbs r in
Mreg.add_new (IllegalAlias r) r (fn v) acc) src Mreg.empty in
let aff = Sreg.fold (fun r acc -> let writes = inst (fun fld -> fld) e.eff_writes in
Sreg.add (ity_full_inst sbs r) acc) wrt Sreg.empty in let resets = inst (inst (fun () -> ())) e.eff_resets in
let impact = Mreg.merge (fun r fld cvr -> match fld, cvr with
let check_inst v ity acc = | Some _, Some _ -> raise (IllegalAlias r)
let i = ity_var_unsafe v in | _ -> Some ()) writes resets in
match i.ity_node with (* all type variables must be instantiated into types that are
| Ityvar _ -> Sreg.iter (fun r -> not affected by the effect, and all unaffected regions must
if ity_r_occurs r ity then raise (IllegalAlias r)) aff be instantiated into regions outside [impact].
|
Now, every region in the instantiated execution is either
(* read-only regions in e *) brought in by the type substitution and thus is unaffected,
let ro = Sreg.diff (Mreg.map (Util.const ()) s) wr in or instantiates one of the original regions and is affected
(* all modified or reset regions are instantiated into distinct regions *) if and only if the original one is. *)
let add_affected reg acc = let check_inst v dst = match ity_var_unsafe v with
let reg = ity_full_inst sbs reg in | {ity_node = Ityvar _} -> Sreg.iter (fun r ->
Sreg.add_new (IllegalAlias reg) reg acc in if ity_r_occurs r dst then raise (IllegalAlias r)) impact
let wrt = Sreg.fold add_affected wrt Sreg.empty in | reg when Mreg.mem reg e.eff_writes -> ()
(* all read-only regions are instantiated outside wr *) | reg when Mreg.mem reg e.eff_resets -> ()
let add_readonly r = | _ when Sreg.mem dst impact -> raise (IllegalAlias dst)
let r = Mreg.find r s in if Sreg.mem r wr then raise (IllegalAlias r) in | _ -> () in
Sreg.iter add_readonly ro; Mtv.iter check_inst sbs;
(* calculate instantiated effect *) { e with eff_writes = writes; eff_resets = resets }
let add_sreg r acc = Sreg.add (Mreg.find r s) acc in
let add_mreg r v acc =
Mreg.add (Mreg.find r s) (Opt.map (fun v -> Mreg.find v s) v) acc in
(* compute compared type variables *)
let add_stv tv acc =
let ity = Mtv.find tv sbs.ity_subst_tv in
let check () _ = raise (IllegalCompar (tv,ity)) in
ity_s_fold check (fun () _ -> ()) () ity;
Stv.union acc ity.ity_vars.vars_tv in
{ e with
eff_writes = Sreg.fold add_sreg e.eff_writes Sreg.empty;
eff_ghostw = Sreg.fold add_sreg e.eff_ghostw Sreg.empty;
eff_resets = Mreg.fold add_mreg e.eff_resets Mreg.empty;
eff_compar = Stv.fold add_stv e.eff_compar Stv.empty;
}
(*
let eff_filter vars e = let eff_filter vars e =
let check r = reg_occurs r vars in let check r = reg_occurs r vars in
let reset r = function let reset r = function
......
...@@ -229,14 +229,11 @@ val eff_assign : effect -> (region * pvsymbol * ity) list -> effect ...@@ -229,14 +229,11 @@ val eff_assign : effect -> (region * pvsymbol * ity) list -> effect
val refresh_of_effect : effect -> effect val refresh_of_effect : effect -> effect
(*
val eff_stale_region : effect -> varset -> bool
exception IllegalAlias of region exception IllegalAlias of region
exception GhostDiverg
val eff_full_inst : ity Mtv.t -> effect -> effect val eff_full_inst : ity Mtv.t -> effect -> effect
(*
(** {2 Specification} *) (** {2 Specification} *)
type pre = term (** precondition: pre_fmla *) type pre = term (** precondition: pre_fmla *)
......
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