Commit 9f34cfe5 authored by Robbert's avatar Robbert

Merge branch 'atomic_resolve' into 'master'

Resolution of prophecy variables can be attached to atomic expressions

See merge request iris/iris!244
parents 2c926d86 f87db2d2
From iris.program_logic Require Export weakestpre total_weakestpre.
From iris.heap_lang Require Import lang adequacy proofmode notation.
From iris.heap_lang Require Import lang.
Set Default Proof Using "Type".
Section tests.
Context `{!heapG Σ}.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val iProp Σ.
Definition CAS_resolve e1 e2 e3 p v :=
Resolve (CAS e1 e2 e3) p v.
Lemma wp_cas_suc_resolve s E (l : loc) (p : proph_id) (vs : list (val * val)) (v1 v2 v : val) :
vals_cas_compare_safe v1 v1
{{{ proph p vs l v1 }}}
CAS_resolve #l v1 v2 #p v @ s; E
{{{ RET #true ; vs', vs = (#true, v)::vs' proph p vs' l v2 }}}.
Proof.
iIntros (Hcmp Φ) "[Hp Hl] HΦ".
wp_apply (wp_resolve with "Hp"); first done.
assert (val_is_unboxed v1) as Hv1; first by destruct Hcmp.
wp_cas_suc. iIntros (vs' ->) "Hp".
iApply "HΦ". eauto with iFrame.
Qed.
Lemma wp_cas_fail_resolve s E (l : loc) (p : proph_id) (vs : list (val * val)) (v' v1 v2 v : val) :
v' v1 vals_cas_compare_safe v' v1
{{{ proph p vs l v' }}}
CAS_resolve #l v1 v2 #p v @ s; E
{{{ RET #false ; vs', vs = (#false, v)::vs' proph p vs' l v' }}}.
Proof.
iIntros (NEq Hcmp Φ) "[Hp Hl] HΦ".
wp_apply (wp_resolve with "Hp"); first done.
wp_cas_fail. iIntros (vs' ->) "Hp".
iApply "HΦ". eauto with iFrame.
Qed.
Lemma test_resolve1 E (l : loc) (n : Z) (p : proph_id) (vs : list (val * val)) (v : val) :
l #n -
proph p vs -
WP Resolve (CAS #l #n (#n + #1)) #p v @ E {{ v, v = #true vs, proph p vs l #(n+1) }}%I.
Proof.
iIntros "Hl Hp". wp_pures. wp_apply (wp_resolve with "Hp"); first done.
wp_cas_suc. iIntros (ws ->) "Hp". eauto with iFrame.
Qed.
Lemma test_resolve2 E (l : loc) (n m : Z) (p : proph_id) (vs : list (val * val)) :
proph p vs -
WP Resolve (#n + #m - (#n + #m)) #p #() @ E {{ v, v = #0 vs, proph p vs }}%I.
Proof.
iIntros "Hp". wp_pures. wp_apply (wp_resolve with "Hp"); first done.
wp_pures. iIntros (ws ->) "Hp". rewrite Z.sub_diag. eauto with iFrame.
Qed.
Lemma test_resolve3 s E (p1 p2 : proph_id) (vs1 vs2 : list (val * val)) (n : Z) :
{{{ proph p1 vs1 proph p2 vs2 }}}
Resolve (Resolve (#n - #n) #p2 #2) #p1 #1 @ s; E
{{{ RET #0 ; vs1' vs2', vs1 = (#0, #1)::vs1' vs2 = (#0, #2)::vs2' proph p1 vs1' proph p2 vs2' }}}.
Proof.
iIntros (Φ) "[Hp1 Hp2] HΦ".
wp_apply (wp_resolve with "Hp1"); first done.
wp_apply (wp_resolve with "Hp2"); first done.
wp_op.
iIntros (vs2' ->) "Hp2". iIntros (vs1' ->) "Hp1". rewrite Z.sub_diag.
iApply "HΦ". iExists vs1', vs2'. eauto with iFrame.
Qed.
Lemma test_resolve4 s E (p1 p2 : proph_id) (vs1 vs2 : list (val * val)) (n : Z) :
{{{ proph p1 vs1 proph p2 vs2 }}}
Resolve (Resolve (#n - #n) ((λ: "x", "x") #p2) (#0 + #2)) ((λ: "x", "x") #p1) (#0 + #1) @ s; E
{{{ RET #0 ; vs1' vs2', vs1 = (#0, #1)::vs1' vs2 = (#0, #2)::vs2' proph p1 vs1' proph p2 vs2' }}}.
Proof.
iIntros (Φ) "[Hp1 Hp2] HΦ".
wp_apply (wp_resolve with "Hp1"); first done.
wp_apply (wp_resolve with "Hp2"); first done.
wp_op.
iIntros (vs2' ->) "Hp2". iIntros (vs1' ->) "Hp1". rewrite Z.sub_diag.
iApply "HΦ". iExists vs1', vs2'. eauto with iFrame.
Qed.
End tests.
......@@ -8,10 +8,10 @@ Set Default Proof Using "Type".
Class heapPreG Σ := HeapPreG {
heap_preG_iris :> invPreG Σ;
heap_preG_heap :> gen_heapPreG loc val Σ;
heap_preG_proph :> proph_mapPreG proph_id val Σ
heap_preG_proph :> proph_mapPreG proph_id (val * val) Σ
}.
Definition heapΣ : gFunctors := #[invΣ; gen_heapΣ loc val; proph_mapΣ proph_id val].
Definition heapΣ : gFunctors := #[invΣ; gen_heapΣ loc val; proph_mapΣ proph_id (val * val)].
Instance subG_heapPreG {Σ} : subG heapΣ Σ heapPreG Σ.
Proof. solve_inG. Qed.
......
This diff is collapsed.
......@@ -61,10 +61,10 @@ Section coinflip.
iModIntro. wp_seq. done.
Qed.
Definition val_list_to_bool (v : list val) : bool :=
match v with
| LitV (LitBool b) :: _ => b
| _ => true
Definition extract_bool (l : list (val * val)) : bool :=
match l with
| (_, LitV (LitBool b)) :: _ => b
| _ => true
end.
Lemma lateChoice_spec (x: loc) :
......@@ -81,7 +81,7 @@ Section coinflip.
iMod "AU" as "[Hl [_ Hclose]]".
iDestruct "Hl" as (v') "Hl".
wp_store.
iMod ("Hclose" $! (val_list_to_bool v) with "[Hl]") as "HΦ"; first by eauto.
iMod ("Hclose" $! (extract_bool v) with "[Hl]") as "HΦ"; first by eauto.
iModIntro. wp_apply rand_spec; try done.
iIntros (b') "_".
wp_apply (wp_resolve_proph with "Hp").
......
From Coq.Lists Require Import List. (* used for lemma "exists_last" *)
From iris.algebra Require Import auth gmap.
From iris.base_logic Require Export gen_heap.
From iris.base_logic.lib Require Export proph_map.
......@@ -12,7 +13,7 @@ Set Default Proof Using "Type".
Class heapG Σ := HeapG {
heapG_invG : invG Σ;
heapG_gen_heapG :> gen_heapG loc val Σ;
heapG_proph_mapG :> proph_mapG proph_id val Σ
heapG_proph_mapG :> proph_mapG proph_id (val * val) Σ
}.
Instance heapG_irisG `{!heapG Σ} : irisG heap_lang Σ := {
......@@ -83,9 +84,31 @@ Instance skip_atomic s : Atomic s Skip.
Proof. solve_atomic. Qed.
Instance new_proph_atomic s : Atomic s NewProph.
Proof. solve_atomic. Qed.
Instance resolve_proph_atomic s v1 v2 : Atomic s (ResolveProph (Val v1) (Val v2)).
Instance binop_atomic s op v1 v2 : Atomic s (BinOp op (Val v1) (Val v2)).
Proof. solve_atomic. Qed.
Instance proph_resolve_atomic s e v1 v2 :
Atomic s e Atomic s (Resolve e (Val v1) (Val v2)).
Proof.
rename e into e1. intros H σ1 e2 κ σ2 efs [Ks e1' e2' Hfill -> step].
simpl in *. induction Ks as [|K Ks _] using rev_ind; simpl in Hfill.
- subst. inversion_clear step. by apply (H σ1 (Val v) κs σ2 efs), head_prim_step.
- rewrite fill_app. rewrite fill_app in Hfill.
assert ( v, Val v = fill Ks e1' False) as fill_absurd.
{ intros v Hv. assert (to_val (fill Ks e1') = Some v) as Htv by by rewrite -Hv.
apply to_val_fill_some in Htv. destruct Htv as [-> ->]. inversion step. }
destruct K; (inversion Hfill; clear Hfill; subst; try
match goal with | H : Val ?v = fill Ks e1' |- _ => by apply fill_absurd in H end).
refine (_ (H σ1 (fill (Ks ++ [K]) e2') _ σ2 efs _)).
+ destruct s; intro Hs; simpl in *.
* destruct Hs as [v Hs]. apply to_val_fill_some in Hs. by destruct Hs, Ks.
* apply irreducible_resolve. by rewrite fill_app in Hs.
+ econstructor 1 with (K := Ks ++ [K]); try done. simpl. by rewrite fill_app.
Qed.
Instance resolve_proph_atomic s v1 v2 : Atomic s (ResolveProph (Val v1) (Val v2)).
Proof. by apply proph_resolve_atomic, skip_atomic. Qed.
Local Ltac solve_exec_safe := intros; subst; do 3 eexists; econstructor; eauto.
Local Ltac solve_exec_puredet := simpl; intros; by inv_head_step.
Local Ltac solve_pure_exec :=
......@@ -396,18 +419,88 @@ Proof.
iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
Qed.
(* In the following, strong atomicity is required due to the fact that [e] must
be able to make a head step for [Resolve e _ _] not to be (head) stuck. *)
Lemma resolve_reducible e σ p v :
Atomic StronglyAtomic e reducible e σ
reducible (Resolve e (Val (LitV (LitProphecy p))) (Val v)) σ.
Proof.
intros A (κ & e' & σ' & efs & H).
exists (κ ++ [(p, (default v (to_val e'), v))]), e', σ', efs.
eapply Ectx_step with (K:=[]); try done.
assert (w, Val w = e') as [w <-].
{ unfold Atomic in A. apply (A σ e' κ σ' efs) in H. unfold is_Some in H.
destruct H as [w H]. exists w. simpl in H. by apply (of_to_val _ _ H). }
simpl. constructor. by apply prim_step_to_val_is_head_step.
Qed.
Lemma step_resolve e p v σ1 κ e2 σ2 efs :
Atomic StronglyAtomic e
prim_step (Resolve e (Val p) (Val v)) σ1 κ e2 σ2 efs
head_step (Resolve e (Val p) (Val v)) σ1 κ e2 σ2 efs.
Proof.
intros A [Ks e1' e2' Hfill -> step]. simpl in *.
induction Ks as [|K Ks _] using rev_ind.
+ simpl in *. subst. inversion step. by constructor.
+ rewrite fill_app /= in Hfill. destruct K; inversion Hfill; subst; clear Hfill.
- assert (fill_item K (fill Ks e1') = fill (Ks ++ [K]) e1') as Eq1;
first by rewrite fill_app.
assert (fill_item K (fill Ks e2') = fill (Ks ++ [K]) e2') as Eq2;
first by rewrite fill_app.
rewrite fill_app /=. rewrite Eq1 in A.
assert (is_Some (to_val (fill (Ks ++ [K]) e2'))) as H.
{ apply (A σ1 _ κ σ2 efs). eapply Ectx_step with (K0 := Ks ++ [K]); done. }
destruct H as [v H]. apply to_val_fill_some in H. by destruct H, Ks.
- assert (to_val (fill Ks e1') = Some p); first by rewrite -H1 //.
apply to_val_fill_some in H. destruct H as [-> ->]. inversion step.
- assert (to_val (fill Ks e1') = Some v); first by rewrite -H2 //.
apply to_val_fill_some in H. destruct H as [-> ->]. inversion step.
Qed.
Lemma wp_resolve s E e Φ p v vs :
Atomic StronglyAtomic e
to_val e = None
proph p vs -
WP e @ s; E {{ r, vs', vs = (r, v)::vs' - proph p vs' - Φ r }} -
WP Resolve e (Val $ LitV $ LitProphecy p) (Val v) @ s; E {{ Φ }}.
Proof.
(* TODO we should try to use a generic lifting lemma (and avoid [wp_unfold])
here, since this breaks the WP abstraction. *)
iIntros (A He) "Hp WPe". rewrite !wp_unfold /wp_pre /= He. simpl in *.
iIntros (σ1 κ κs n) "[Hσ Hκ]". destruct (decide (κ = [])) as [->|HNeq].
- iMod ("WPe" $! σ1 [] κs n with "[$Hσ $Hκ]") as "[Hs WPe]". iModIntro. iSplit.
{ iDestruct "Hs" as "%". iPureIntro. destruct s; [ by apply resolve_reducible | done]. }
iIntros (e2 σ2 efs step). exfalso. apply step_resolve in step; last done.
inversion step. match goal with H: ?κs ++ [_] = [] |- _ => by destruct κs end.
- apply exists_last in HNeq as [κ' [[p' [w' v']] ->]]. rewrite -app_assoc.
iMod ("WPe" $! σ1 _ _ n with "[$Hσ $Hκ]") as "[Hs WPe]". iModIntro. iSplit.
{ iDestruct "Hs" as "%". iPureIntro. destruct s; [ by apply resolve_reducible | done]. }
iIntros (e2 σ2 efs step). apply step_resolve in step; last done. inversion step.
match goal with H: _ ++ _ = _ ++ _ |- _ =>
apply app_inj_2 in H; last done; destruct H as [-> [=-> -> ->]] end. subst.
iMod ("WPe" $! (Val w') σ2 efs with "[%]") as "WPe". { eexists [] _ _; try done. }
iModIntro. iNext. iMod "WPe" as "[[$ Hκ] WPe]".
iMod (proph_map_resolve_proph p' (w',v') κs with "[$Hκ $Hp]") as (vs' ->) "[$ HPost]".
iModIntro. rewrite !wp_unfold /wp_pre /=. iDestruct "WPe" as "[HΦ $]".
iMod "HΦ". iModIntro. iApply "HΦ"; [ done | iFrame ].
Qed.
Lemma wp_skip s E Φ : Φ (LitV LitUnit) - WP Skip @ s; E {{ Φ }}.
Proof.
iIntros "HΦ". iApply wp_lift_atomic_head_step_no_fork; auto.
iIntros (σ1 κ κs n) "Hσ". iModIntro. iSplit.
- iPureIntro. eexists _, _, _, _. by constructor.
- iIntros (e2 σ2 efs step) "!>". inversion step. simplify_eq. by iFrame.
Qed.
Lemma wp_resolve_proph s E p vs v :
{{{ proph p vs }}}
ResolveProph (Val $ LitV $ LitProphecy p) (Val v) @ s; E
{{{ vs', RET (LitV LitUnit); vs = v::vs' proph p vs' }}}.
{{{ vs', RET (LitV LitUnit); vs = (LitV LitUnit, v)::vs' proph p vs' }}}.
Proof.
iIntros (Φ) "Hp HΦ". iApply wp_lift_atomic_head_step_no_fork; auto.
iIntros (σ1 κ κs n) "[Hσ HR] !>". iSplit; first by eauto.
iNext; iIntros (v2 σ2 efs Hstep). inv_head_step.
iMod (proph_map_resolve_proph p v κs with "[HR Hp]") as "HPost"; first by iFrame.
iModIntro. iFrame. iSplitR; first done.
iDestruct "HPost" as (vs') "[HEq [HR Hp]]". iFrame.
iApply "HΦ". iFrame.
iIntros (Φ) "Hp HΦ". iApply (wp_resolve with "Hp"); first done.
iApply wp_skip. iNext. iIntros (vs') "HEq Hp". iApply "HΦ". iFrame.
Qed.
End lifting.
......
......@@ -12,10 +12,9 @@ Fixpoint is_closed_expr (X : list string) (e : expr) : bool :=
| Rec f x e => is_closed_expr (f :b: x :b: X) e
| UnOp _ e | Fst e | Snd e | InjL e | InjR e | Fork e | Load e =>
is_closed_expr X e
| App e1 e2 | BinOp _ e1 e2 | Pair e1 e2 | AllocN e1 e2 | Store e1 e2 | FAA e1 e2
| ResolveProph e1 e2 =>
| App e1 e2 | BinOp _ e1 e2 | Pair e1 e2 | AllocN e1 e2 | Store e1 e2 | FAA e1 e2 =>
is_closed_expr X e1 && is_closed_expr X e2
| If e0 e1 e2 | Case e0 e1 e2 | CAS e0 e1 e2 =>
| If e0 e1 e2 | Case e0 e1 e2 | CAS e0 e1 e2 | Resolve e0 e1 e2 =>
is_closed_expr X e0 && is_closed_expr X e1 && is_closed_expr X e2
| NewProph => true
end
......@@ -130,7 +129,7 @@ Lemma head_step_is_closed e1 σ1 obs e2 σ2 es :
map_Forall (λ _ v, is_closed_val v) σ2.(heap).
Proof.
intros Cl1 Clσ1 STEP.
destruct STEP; simpl in *; split_and!;
induction STEP; simpl in *; split_and!;
try apply map_Forall_insert_2; try by naive_solver.
- subst. repeat apply is_closed_subst'; naive_solver.
- unfold un_op_eval in *. repeat case_match; naive_solver.
......@@ -173,7 +172,7 @@ Fixpoint subst_map (vs : gmap string val) (e : expr) : expr :=
| CAS e0 e1 e2 => CAS (subst_map vs e0) (subst_map vs e1) (subst_map vs e2)
| FAA e1 e2 => FAA (subst_map vs e1) (subst_map vs e2)
| NewProph => NewProph
| ResolveProph e1 e2 => ResolveProph (subst_map vs e1) (subst_map vs e2)
| Resolve e0 e1 e2 => Resolve (subst_map vs e0) (subst_map vs e1) (subst_map vs e2)
end.
Lemma subst_map_empty e : subst_map e = e.
......
......@@ -6,32 +6,48 @@ Import heap_lang.
evaluation context [K] and a subexpression [e']. It calls the tactic [tac K e']
for each possible decomposition until [tac] succeeds. *)
Ltac reshape_expr e tac :=
let rec go K e :=
match e with
| _ => tac K e
| App ?e (Val ?v) => go (AppLCtx v :: K) e
| App ?e1 ?e2 => go (AppRCtx e1 :: K) e2
| UnOp ?op ?e => go (UnOpCtx op :: K) e
| BinOp ?op ?e (Val ?v) => go (BinOpLCtx op v :: K) e
| BinOp ?op ?e1 ?e2 => go (BinOpRCtx op e1 :: K) e2
| If ?e0 ?e1 ?e2 => go (IfCtx e1 e2 :: K) e0
| Pair ?e (Val ?v) => go (PairLCtx v :: K) e
| Pair ?e1 ?e2 => go (PairRCtx e1 :: K) e2
| Fst ?e => go (FstCtx :: K) e
| Snd ?e => go (SndCtx :: K) e
| InjL ?e => go (InjLCtx :: K) e
| InjR ?e => go (InjRCtx :: K) e
| Case ?e0 ?e1 ?e2 => go (CaseCtx e1 e2 :: K) e0
| AllocN ?e (Val ?v) => go (AllocNLCtx v :: K) e
| AllocN ?e1 ?e2 => go (AllocNRCtx e1 :: K) e2
| Load ?e => go (LoadCtx :: K) e
| Store ?e (Val ?v) => go (StoreLCtx v :: K) e
| Store ?e1 ?e2 => go (StoreRCtx e1 :: K) e2
| CAS ?e0 (Val ?v1) (Val ?v2) => go (CasLCtx v1 v2 :: K) e0
| CAS ?e0 ?e1 (Val ?v2) => go (CasMCtx e0 v2 :: K) e1
| CAS ?e0 ?e1 ?e2 => go (CasRCtx e0 e1 :: K) e2
| FAA ?e (Val ?v) => go (FaaLCtx v :: K) e
| FAA ?e1 ?e2 => go (FaaRCtx e1 :: K) e2
| ResolveProph ?e (Val ?v) => go (ProphLCtx v :: K) e
| ResolveProph ?e1 ?e2 => go (ProphRCtx e1 :: K) e2
end in go (@nil ectx_item) e.
(* Note that the current context is spread into a list of fully-constructed
items [K], and a list of pairs of values [vs] (prophecy identifier and
resolution value) that is only non-empty if a [ResolveLCtx] item (maybe
having several levels) is in the process of being constructed. Note that
a fully-constructed item is inserted into [K] by calling [add_item], and
that is only the case when a non-[ResolveLCtx] item is built. When [vs]
is non-empty, [add_item] also wraps the item under several [ResolveLCtx]
constructors: one for each pair in [vs]. *)
let rec go K vs e :=
match e with
| _ => lazymatch vs with [] => tac K e | _ => fail end
| App ?e (Val ?v) => add_item (AppLCtx v) vs K e
| App ?e1 ?e2 => add_item (AppRCtx e1) vs K e2
| UnOp ?op ?e => add_item (UnOpCtx op) vs K e
| BinOp ?op ?e (Val ?v) => add_item (BinOpLCtx op v) vs K e
| BinOp ?op ?e1 ?e2 => add_item (BinOpRCtx op e1) vs K e2
| If ?e0 ?e1 ?e2 => add_item (IfCtx e1 e2) vs K e0
| Pair ?e (Val ?v) => add_item (PairLCtx v) vs K e
| Pair ?e1 ?e2 => add_item (PairRCtx e1) vs K e2
| Fst ?e => add_item FstCtx vs K e
| Snd ?e => add_item SndCtx vs K e
| InjL ?e => add_item InjLCtx vs K e
| InjR ?e => add_item InjRCtx vs K e
| Case ?e0 ?e1 ?e2 => add_item (CaseCtx e1 e2) vs K e0
| AllocN ?e (Val ?v) => add_item (AllocNLCtx v) vs K e
| AllocN ?e1 ?e2 => add_item (AllocNRCtx e1) vs K e2
| Load ?e => add_item LoadCtx vs K e
| Store ?e (Val ?v) => add_item (StoreLCtx v) vs K e
| Store ?e1 ?e2 => add_item (StoreRCtx e1) vs K e2
| CAS ?e0 (Val ?v1) (Val ?v2) => add_item (CasLCtx v1 v2) vs K e0
| CAS ?e0 ?e1 (Val ?v2) => add_item (CasMCtx e0 v2) vs K e1
| CAS ?e0 ?e1 ?e2 => add_item (CasRCtx e0 e1) vs K e2
| FAA ?e (Val ?v) => add_item (FaaLCtx v) vs K e
| FAA ?e1 ?e2 => add_item (FaaRCtx e1) vs K e2
| Resolve ?ex (Val ?v1) (Val ?v2) => go K ((v1,v2) :: vs) ex
| Resolve ?ex ?e1 (Val ?v2) => add_item (ResolveMCtx ex v2) vs K e1
| Resolve ?ex ?e1 ?e2 => add_item (ResolveRCtx ex e1) vs K e2
end
with add_item Ki vs K e :=
lazymatch vs with
| [] => go (Ki :: K) (@nil (val * val)) e
| (?v1,?v2) :: ?vs => add_item (ResolveLCtx Ki v1 v2) vs K e
end
in
go (@nil ectx_item) (@nil (val * val)) e.
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