Commit bf38948f authored by Dan Frumin's avatar Dan Frumin

Simplify the Treiber stack refinement

The simplification is acheieved by removing the stackUR workaround.
That RA was used to enusure that the nodes that were parts of the
stack do not change themselves -- this is crucial for the safety of
pop and iter operations.

Now this is achieved by using duplicable propositions (∃ q, n ↦ᵢ{q} v)
to ensure that the node are still alive/not freed.
parent 3792938d
...@@ -32,7 +32,6 @@ theories/examples/counter.v ...@@ -32,7 +32,6 @@ theories/examples/counter.v
theories/examples/lateearlychoice.v theories/examples/lateearlychoice.v
theories/examples/par.v theories/examples/par.v
theories/examples/bit.v theories/examples/bit.v
theories/examples/stack/stack_rules.v
theories/examples/stack/CG_stack.v theories/examples/stack/CG_stack.v
theories/examples/stack/FG_stack.v theories/examples/stack/FG_stack.v
theories/examples/stack/refinement.v theories/examples/stack/refinement.v
...@@ -52,4 +51,4 @@ theories/tests/tactics2.v ...@@ -52,4 +51,4 @@ theories/tests/tactics2.v
theories/tests/liftings.v theories/tests/liftings.v
theories/tests/value.v theories/tests/value.v
theories/examples/coqpl.v theories/examples/coqpl.v
theories/examples/brouwers.v theories/examples/brouwers.v
\ No newline at end of file
From iris.proofmode Require Import tactics. From iris.proofmode Require Import tactics.
From iris_logrel Require Import logrel. From iris_logrel Require Import logrel.
From iris_logrel.examples.stack Require Import From iris_logrel.examples.stack Require Import
CG_stack FG_stack stack_rules refinement. CG_stack FG_stack refinement.
Section Mod_refinement. Section Mod_refinement.
Context `{HLR : logrelG Σ}. Context `{HLR : logrelG Σ}.
...@@ -9,15 +9,15 @@ Section Mod_refinement. ...@@ -9,15 +9,15 @@ Section Mod_refinement.
Implicit Types Δ : listC D. Implicit Types Δ : listC D.
Import lang. Import lang.
Program Definition sint {LG : logrelG Σ} {Z : stackPreG Σ} τi : prodC valC valC -n> iProp Σ := λne vv, Program Definition sint τi : prodC valC valC -n> iProp Σ := λne vv,
( γ (l stk stk' : loc), (vv.2) = (#stk', #l)%V (vv.1) = #stk ( (l stk stk' : loc), (vv.2) = (#stk', #l)%V (vv.1) = #stk
inv (stackN .@ (stk,stk')) (sinv' γ τi stk stk' l))%I. inv (stackN .@ (stk,stk')) (sinv τi stk stk' l))%I.
Solve Obligations with solve_proper. Solve Obligations with solve_proper.
Instance sint_persistent `{logrelG Σ, stackPreG Σ} τi vv : Persistent (sint τi vv). Instance sint_persistent τi vv : Persistent (sint τi vv).
Proof. apply _. Qed. Proof. apply _. Qed.
Lemma module_refinement `{SPG : stackPreG Σ} Δ Γ : Lemma module_refinement Δ Γ :
{Δ;Γ} FG_stack.stackmod log CG_stack.stackmod : TForall $ TExists $ TProd (TProd {Δ;Γ} FG_stack.stackmod log CG_stack.stackmod : TForall $ TExists $ TProd (TProd
(TArrow TUnit (TVar 0)) (TArrow TUnit (TVar 0))
(TArrow (TVar 0) (TSum TUnit (TVar 1)))) (TArrow (TVar 0) (TSum TUnit (TVar 1))))
...@@ -40,25 +40,16 @@ Section Mod_refinement. ...@@ -40,25 +40,16 @@ Section Mod_refinement.
rel_alloc_r as l "Hl". rel_alloc_r as l "Hl".
rel_vals. rel_vals.
rewrite -persistent. rewrite -persistent.
iMod (own_alloc ( ( : stackUR))) as (γ) "Hemp"; first done. iAssert (sinv τi stk stk' l) with "[-]" as "Hinv".
pose (SG := StackG Σ _ γ). { iExists _,_. iFrame.
iAssert (prestack_owns γ ) with "[Hemp]" as "Hoe". rewrite stack_link_unfold. iExists _; iSplitL; eauto. }
{ rewrite /prestack_owns big_sepM_empty fmap_empty.
iFrame "Hemp". }
iMod (stack_owns_alloc with "[$Hoe $Histk]") as "[Hoe #Histk]".
iAssert (preStackLink γ τi (#istk, FoldV (InjLV #()))) with "[Histk]" as "#HLK".
{ rewrite preStackLink_unfold.
iExists _, _. iSplitR; simpl; trivial.
iFrame "Histk". iLeft. iSplit; trivial. }
iAssert (sinv' γ τi stk stk' l) with "[Hoe Hstk Hstk' HLK Hl]" as "Hinv".
{ iExists _, _, _. by iFrame. }
iMod (inv_alloc (stackN.@(stk,stk')) with "[Hinv]") as "#Hinv". iMod (inv_alloc (stackN.@(stk,stk')) with "[Hinv]") as "#Hinv".
{ iNext. iExact "Hinv". } { iNext. iExact "Hinv". }
iModIntro. iModIntro.
iExists γ, l, stk, stk'. eauto. iExists l, stk, stk'. eauto.
- iApply bin_log_related_arrow_val; eauto. - iApply bin_log_related_arrow_val; eauto.
iAlways. iIntros (? ?) "#Hvv /=". iAlways. iIntros (? ?) "#Hvv /=".
iDestruct "Hvv" as (γ l stk stk') "(% & % & #Hinv)". iDestruct "Hvv" as (l stk stk') "(% & % & #Hinv)".
simplify_eq/=. simplify_eq/=.
rel_let_l. rel_let_l.
rel_let_r. rel_let_r.
...@@ -73,15 +64,12 @@ Section Mod_refinement. ...@@ -73,15 +64,12 @@ Section Mod_refinement.
replace (TSum TUnit (TVar 1)) replace (TSum TUnit (TVar 1))
with (TSum TUnit (TVar 0)).[ren (+1)] by done. with (TSum TUnit (TVar 0)).[ren (+1)] by done.
iApply bin_log_related_weaken_2. iApply bin_log_related_weaken_2.
pose (SG := StackG Σ _ γ). iApply (FG_CG_pop_refinement' (stackN.@(stk,stk')) with "Hinv").
change γ with stack_name. solve_ndisj.
iApply (FG_CG_pop_refinement' (stackN.@(stk,stk'))).
{ solve_ndisj. }
by rewrite sinv_unfold.
- iApply bin_log_related_arrow_val; eauto. - iApply bin_log_related_arrow_val; eauto.
{ unlock FG_push. done. } { unlock FG_push. done. }
iAlways. iIntros (? ?) "#Hvv /=". iAlways. iIntros (? ?) "#Hvv /=".
iDestruct "Hvv" as (γ l stk stk') "(% & % & #Hinv)". iDestruct "Hvv" as (l stk stk') "(% & % & #Hinv)".
simplify_eq/=. simplify_eq/=.
rel_let_r. rel_let_r.
Transparent FG_push. Transparent FG_push.
...@@ -98,11 +86,8 @@ Section Mod_refinement. ...@@ -98,11 +86,8 @@ Section Mod_refinement.
with ((CG_locked_push $/ LitV stk' $/ LitV l) v')%E; last first. with ((CG_locked_push $/ LitV stk' $/ LitV l) v')%E; last first.
{ unlock CG_locked_push. simpl_subst/=. done. } { unlock CG_locked_push. simpl_subst/=. done. }
change TUnit with (TUnit.[ren (+1)]). change TUnit with (TUnit.[ren (+1)]).
pose (SG := StackG Σ _ γ). iApply (FG_CG_push_refinement (stackN.@(stk,stk')) with "Hinv Hτi").
change γ with stack_name. solve_ndisj.
iApply (FG_CG_push_refinement (stackN.@(stk,stk')) with "[Hinv] Hτi").
{ solve_ndisj. }
by rewrite sinv_unfold.
Qed. Qed.
End Mod_refinement. End Mod_refinement.
...@@ -113,7 +98,6 @@ Theorem module_ctx_refinement : ...@@ -113,7 +98,6 @@ Theorem module_ctx_refinement :
(TArrow (TVar 0) (TSum TUnit (TVar 1)))) (TArrow (TVar 0) (TSum TUnit (TVar 1))))
(TArrow (TVar 0) (TArrow (TVar 1) TUnit)). (TArrow (TVar 0) (TArrow (TVar 1) TUnit)).
Proof. Proof.
set (Σ := #[logrelΣ; GFunctor (authR stackUR)]). eapply (logrel_ctxequiv logrelΣ); [solve_closed.. | intros ].
eapply (logrel_ctxequiv Σ); [solve_closed.. | intros ].
apply module_refinement. apply module_refinement.
Qed. Qed.
From iris.proofmode Require Import tactics. From iris.proofmode Require Import tactics.
From iris_logrel Require Import logrel. From iris_logrel Require Import logrel.
From iris_logrel.examples.stack Require Import From iris_logrel.examples.stack Require Import CG_stack FG_stack.
CG_stack FG_stack stack_rules.
Definition stackN : namespace := nroot .@ "stack". Definition stackN : namespace := nroot .@ "stack".
...@@ -11,32 +10,81 @@ Section Stack_refinement. ...@@ -11,32 +10,81 @@ Section Stack_refinement.
Implicit Types Δ : listC D. Implicit Types Δ : listC D.
Import lang. Import lang.
Definition sinv' {SPG : authG Σ stackUR} γ τi stk stk' l' : iProp Σ := Notation DD := (prodC locC valC -n> iProp Σ).
( (istk : loc) v h, (prestack_owns γ h)
stk' ↦ₛ v
stk ↦ᵢ (FoldV #istk)
preStackLink γ τi (#istk, v)
l' ↦ₛ #false)%I.
Context `{stackG Σ}. (** The "partial pointsto" proposition is duplicable *)
Definition sinv τi stk stk' l : iProp Σ := Local Instance istk_fromand (istk : loc) (w : val) :
( (istk : loc) v h, (stack_owns h) FromAnd false ( q, istk ↦ᵢ{q} w) ( q, istk ↦ᵢ{q} w) ( q, istk ↦ᵢ{q} w).
stk' ↦ₛ v Proof.
stk ↦ᵢ (FoldV #istk) rewrite /FromAnd. iIntros "[H1 H2]".
StackLink τi (#istk, v) iDestruct "H1" as (q1) "H1". iDestruct "H2" as (q2) "H2".
l ↦ₛ #false)%I. iCombine "H1 H2" as "H". eauto.
Lemma sinv_unfold τi stk stk' l : Qed.
sinv τi stk stk' l = sinv' stack_name τi stk stk' l. Local Instance istk_intoand (istk : loc) (w : val) :
Proof. reflexivity. Qed. IntoAnd false ( q, istk ↦ᵢ{q} w) ( q, istk ↦ᵢ{q} w) ( q, istk ↦ᵢ{q} w).
Proof.
rewrite /IntoAnd. iDestruct 1 as (q) "[H1 H2]".
iSplitL "H1"; eauto.
Qed.
Program Definition stack_link_pre (τi : D) : DD -n> DD := λne P vv,
( w, ( q, vv.1 ↦ᵢ{q} w)
( (w = NONEV vv.2 = FoldV NONEV)
( (y1 : val) (z1 : loc) (y2 z2 : val),
w = SOMEV (PairV y1 (FoldV #z1))
vv.2 = FoldV (SOMEV (PairV y2 z2))
τi (y1, y2)
P (z1, z2))))%I.
Solve Obligations with solve_proper.
Global Instance stack_link_pre_contractive τi : Contractive (stack_link_pre τi).
Proof. solve_contractive. Qed.
Definition stack_link (Q : D) : DD := fixpoint (stack_link_pre Q).
Lemma stack_link_unfold (Q : D) (istk : loc) (v : val) :
stack_link Q (istk, v)
( w, ( q, istk ↦ᵢ{q} w)
((w = NONEV v = FoldV NONEV)
( (y1 : val) (z1 : loc) (y2 z2 : val),
w = SOMEV (PairV y1 (FoldV #z1))
v = FoldV (SOMEV (PairV y2 z2))
Q (y1, y2)
stack_link Q (z1, z2))))%I.
Proof. by rewrite {1}/stack_link fixpoint_unfold. Qed.
(** Actually, the whole `stack_link` predicate is duplicable *)
Local Instance stack_link_intoand (Q : D) (istk : loc) (v : val) :
IntoAnd false (stack_link Q (istk, v)) (stack_link Q (istk, v)) (stack_link Q (istk, v)).
Proof.
rewrite /IntoAnd. iLöb as "IH" forall (istk v).
rewrite {1 2 3}stack_link_unfold.
iDestruct 1 as (w) "([Histk Histk2] & [HLK | HLK])".
- iDestruct "HLK" as "[% %]".
iSplitL "Histk"; iExists _; iFrame; eauto.
- iDestruct "HLK" as (y1 z1 y2 z2) "(% & % & #HQ & HLK)".
iDestruct ("IH" with "HLK") as "[HLK HLK2]".
iClear "IH".
iSplitL "Histk HLK"; iExists _; iFrame; iRight; iExists _,_,_,_; eauto.
Qed.
Definition sinv (τi : D) stk stk' l' : iProp Σ :=
( (istk : loc) v,
stk' ↦ₛ v
l' ↦ₛ #false
stk ↦ᵢ (FoldV #istk)
stack_link τi (istk, v))%I.
Ltac close_sinv Hcl asn := Ltac close_sinv Hcl asn :=
iMod (Hcl with asn) as "_"; iMod (Hcl with asn) as "_";
[iNext; rewrite /sinv; iExists _,_,_; by iFrame |]; try iModIntro. [iNext; rewrite /sinv; iExists _,_; by iFrame |]; try iModIntro.
Lemma FG_CG_push_refinement N st st' (τi : D) (v v' : val) l Γ : Lemma FG_CG_push_refinement N st st' (τi : D) (v v' : val) l Γ :
N ## logrelN N ## logrelN
inv N (sinv τi st st' l) - τi (v,v') - inv N (sinv τi st st' l) - τi (v,v') -
Γ (FG_push $/ (LitV (Loc st))) v log (CG_locked_push $/ (LitV (Loc st')) $/ (LitV (Loc l))) v' : TUnit. Γ (FG_push $/ (LitV (Loc st))) v
log
(CG_locked_push $/ (LitV (Loc st')) $/ (LitV (Loc l))) v' : TUnit.
Proof. Proof.
iIntros (?) "#Hinv #Hvv'". iIntros (Δ). iIntros (?) "#Hinv #Hvv'". iIntros (Δ).
Transparent FG_push. Transparent FG_push.
...@@ -44,40 +92,36 @@ Section Stack_refinement. ...@@ -44,40 +92,36 @@ Section Stack_refinement.
iLöb as "IH". iLöb as "IH".
rel_rec_l. rel_rec_l.
rel_load_l_atomic. rel_load_l_atomic.
iInv N as (istk w h) "[Hoe [>Hst' [Hst [HLK >Hl]]]]" "Hclose". iInv N as (istk w) "(>Hst' & >Hl & >Hst & HLK)" "Hclose".
iExists (FoldV #istk). iFrame. iExists (FoldV #istk). iFrame.
iModIntro. iNext. iIntros "Hst". iModIntro. iNext. iIntros "Hst".
close_sinv "Hclose" "[Hst Hoe Hst' Hl HLK]". clear w h. close_sinv "Hclose" "[Hst Hst' Hl HLK]". clear w.
rel_rec_l. rel_rec_l.
rel_alloc_l as nstk "Hnstk". simpl. rel_alloc_l as nstk "Hnstk". simpl.
rel_cas_l_atomic. rel_cas_l_atomic.
iInv N as (istk' w h) "[Hoe [>Hst' [Hst [HLK >Hl]]]]" "Hclose". iInv N as (istk' w) "(>Hst' & >Hl & >Hst & HLK)" "Hclose".
iExists (FoldV #istk'). iFrame. iExists (FoldV #istk'). iFrame.
iModIntro. iModIntro. iSplit.
destruct (decide (istk' = istk)) as [e | nestk]; subst.
- (* CAS succeeds *)
iSplitR; first by iIntros ([]).
iIntros (?). iNext. iIntros "Hst".
rel_apply_r (CG_push_r with "Hst' Hl").
{ solve_ndisj. }
iIntros "Hst' Hl".
iMod (stack_owns_alloc with "[$Hoe $Hnstk]") as "[Hoe Hnstk]".
iMod ("Hclose" with "[Hst Hoe Hst' Hl HLK Hnstk]").
{ iNext. rewrite {2}/sinv. iExists _,_,_.
iFrame "Hoe Hst' Hst Hl".
rewrite (StackLink_unfold _ (# nstk, _)).
iExists _, _. iSplitR; auto.
iFrame "Hnstk".
iRight. iExists _, _, _, _. auto. }
rel_if_true_l.
by rel_vals.
- (* CAS fails *) - (* CAS fails *)
iSplitL; last by (iIntros (?); congruence).
iIntros (?); iNext; iIntros "Hst". iIntros (?); iNext; iIntros "Hst".
close_sinv "Hclose" "[Hst Hoe Hst' Hl HLK]". clear w h. close_sinv "Hclose" "[Hst Hst' Hl HLK]". clear w.
rel_if_false_l. simpl. rel_if_false_l. simpl.
rel_rec_l. rel_rec_l.
by iApply "IH". by iApply "IH".
- (* CAS succeeds *)
iIntros (?). simplify_eq/=. iNext. iIntros "Hst".
rel_apply_r (CG_push_r with "Hst' Hl").
{ solve_ndisj. }
iIntros "Hst' Hl".
iMod ("Hclose" with "[Hst Hst' Hl HLK Hnstk]").
{ iNext. rewrite {2}/sinv. iExists _,_.
iFrame "Hst' Hst Hl".
rewrite (stack_link_unfold _ nstk).
iExists _. iSplitL "Hnstk".
- iExists 1%Qp; iFrame.
- iRight. iExists _,_,_,_. eauto. }
rel_if_true_l.
iApply bin_log_related_unit.
Qed. Qed.
Lemma FG_CG_pop_refinement' N st st' (τi : D) l Δ Γ : Lemma FG_CG_pop_refinement' N st st' (τi : D) l Δ Γ :
...@@ -85,7 +129,7 @@ Section Stack_refinement. ...@@ -85,7 +129,7 @@ Section Stack_refinement.
inv N (sinv τi st st' l) - inv N (sinv τi st st' l) -
{τi::Δ;Γ} (FG_pop $/ LitV (Loc st)) #() log (CG_locked_pop $/ LitV (Loc st') $/ LitV (Loc l)) #() : TSum TUnit (TVar 0). {τi::Δ;Γ} (FG_pop $/ LitV (Loc st)) #() log (CG_locked_pop $/ LitV (Loc st') $/ LitV (Loc l)) #() : TSum TUnit (TVar 0).
Proof. Proof.
Transparent CG_locked_pop FG_pop CG_pop. Transparent CG_locked_pop FG_pop CG_pop.
iIntros (?) "#Hinv". iIntros (?) "#Hinv".
iLöb as "IH". iLöb as "IH".
rewrite {2}/FG_pop. unlock. simpl_subst/=. rewrite {2}/FG_pop. unlock. simpl_subst/=.
...@@ -102,120 +146,98 @@ replace ((rec: "pop" "st" <> := ...@@ -102,120 +146,98 @@ replace ((rec: "pop" "st" <> :=
rel_rec_l. rel_rec_l.
rel_load_l_atomic. rel_load_l_atomic.
iInv N as (istk v h) "[Hoe [Hst' [Hst [#HLK Hl]]]]" "Hclose". iInv N as (istk w) "(>Hst' & >Hl & >Hst & HLK)" "Hclose".
iExists _. iFrame. iExists _. iFrame.
iModIntro. iNext. iIntros "Hst /=". iModIntro. iNext. iIntros "Hst /=".
rel_rec_l. rel_rec_l.
rel_unfold_l. rel_unfold_l.
iPoseProof "HLK" as "HLK'". iDestruct "HLK" as "[HLK HLK2]".
rewrite {1}stack_link_unfold.
rewrite {1}StackLink_unfold. iDestruct "HLK" as (w') "(Histk & HLK)".
iDestruct "HLK" as (istk2 w) "(% & Histk & HLK)". simplify_eq/=.
iDestruct "HLK" as "[[% %] | HLK]"; simplify_eq/=. iDestruct "HLK" as "[[% %] | HLK]"; simplify_eq/=.
- (* The stack is empty *) - (* The stack is empty *)
rel_apply_r (CG_pop_fail_r with "Hst' Hl"). rel_apply_r (CG_pop_fail_r with "Hst' Hl").
{ solve_ndisj. } { solve_ndisj. }
iIntros "Hst' Hl". iIntros "Hst' Hl".
close_sinv "Hclose" "[Hoe Hst' Hst Hl HLK']". clear h. iClear "HLK'". (* duplicate the top node *)
rel_load_l_atomic. iDestruct "Histk" as "[Histk Histk2]".
iInv N as (istk v h) "[Hoe [Hst' [Hst [#HLK Hl]]]]" "Hclose". close_sinv "Hclose" "[Hst' Hst Hl HLK2]".
iDestruct (stack_owns_later_open_close with "Hoe Histk") as "[Histk_i Hoe]". iDestruct "Histk2" as (q) "Histk2".
iExists _. iFrame "Histk_i". rel_load_l. rel_let_l.
iModIntro. iNext. iIntros "Histk_i /=". rel_case_l. rel_let_l.
iSpecialize ("Hoe" with "Histk_i").
rel_rec_l.
rel_case_l.
rel_rec_l.
close_sinv "Hclose" "[Hoe Hst' Hst Hl HLK]".
rel_vals. rel_vals.
{ iModIntro. iLeft. iExists (_,_). eauto. } { iModIntro. iLeft. iExists (_,_). eauto. }
- (* The stack has a value *) - (* The stack has a value *)
iDestruct "HLK" as (y1 z1 y2 z2) "(% & % & Hτ & HLK_tail)"; simplify_eq/=. iDestruct "HLK" as (y1 z1 y2 z2) "(% & % & #Hτ & HLK_tail)"; simplify_eq/=.
close_sinv "Hclose" "[Hoe Hst' Hst Hl HLK']". clear h. (* duplicate the top node *)
rel_load_l_atomic. close_sinv "Hclose" "[Hst' Hst Hl HLK2]".
iInv N as (istk v h) "[Hoe [Hst' [Hst [HLK Hl]]]]" "Hclose". iDestruct "Histk" as (q) "Histk".
iDestruct (stack_owns_later_open_close with "Hoe Histk") as "[Histk_i Hoe]". rel_load_l. rel_let_l.
iExists _. iFrame. repeat (rel_pure_l _).
iModIntro. iNext. iIntros "Histk_i /=".
iSpecialize ("Hoe" with "Histk_i").
rel_rec_l.
rel_case_l.
rel_rec_l.
do 2 (rel_proj_l; rel_rec_l).
close_sinv "Hclose" "[Hoe Hst' Hst Hl HLK]". clear h istk v.
rel_cas_l_atomic. rel_cas_l_atomic.
iInv N as (istk v h) "[Hoe [Hst' [Hst [HLK2 Hl]]]]" "Hclose". iInv N as (istk' w) "(>Hst' & >Hl & >Hst & HLK)" "Hclose".
iExists _. iFrame. iExists _. iFrame.
iModIntro. iModIntro. iSplit.
destruct (decide (istk = istk2)) as [? |NE]; simplify_eq/=. + (* CAS fails *) iIntros (?); simplify_eq/=.
+ (* CAS succeeds *) iNext. iIntros "Hst".
iSplitR; first by (iIntros (?); contradiction). rel_if_l.
iIntros "%". iNext. iIntros "Hst". close_sinv "Hclose" "[Hst Hst' Hl HLK]".
rel_rec_l.
iApply "IH".
+ (* CAS succeeds *) iIntros (?); simplify_eq/=.
iNext. iIntros "Hst".
rel_if_l. rel_if_l.
rewrite (StackLink_unfold _ (#istk2, v)). rewrite (stack_link_unfold _ istk).
iDestruct "HLK2" as (istk2' v') "[% [#Histk' HLK2]]"; simplify_eq/=. iDestruct "HLK" as (w') "(Histk2 & HLK)".
iDestruct (stack_mapstos_agree with "Histk Histk'") as "%"; simplify_eq/=. iAssert (w' = InjRV (y1, FoldV #z1))%I with "[Histk Histk2]" as %->.
iDestruct "HLK2" as "[[% %]|HLK2]"; simplify_eq/=. { iDestruct "Histk2" as (?) "Histk2".
iDestruct "HLK2" as (ym1 ym2 zm1 zm2) iApply (mapsto_agree with "Histk2 Histk"). }
"[% [% [#Hrel #HLK2_tail]]]"; simplify_eq/=. iDestruct "HLK" as "[[% %] | HLK]"; first by congruence.
iDestruct "HLK" as (? ? ? ? ? ?) "[#Hτ2 HLK]". simplify_eq/=.
rel_apply_r (CG_pop_suc_r with "Hst' Hl"). rel_apply_r (CG_pop_suc_r with "Hst' Hl").
{ solve_ndisj. } { solve_ndisj. }
iIntros "Hst' Hl". iIntros "Hst' Hl".
iMod ("Hclose" with "[-]"). close_sinv "Hclose" "[-]".
{ iNext. rewrite /sinv.
rewrite (StackLink_unfold _ (ym2, z2)).
iDestruct "HLK_tail" as (yn2loc ?) "[% _]"; simplify_eq /=.
iExists _,_,_. by iFrame. }
rel_vals. rel_vals.
{ iModIntro. iRight. { iModIntro. iRight.
iExists (_,_). eauto. } iExists (_,_). eauto. }
+ (* CAS fails *)
iSplitL; last by (iIntros (?); congruence).
iIntros (?). iNext. iIntros "Hst".
rel_if_l.
close_sinv "Hclose" "[Hoe Hst Hst' Hl HLK2]".
rel_rec_l.
iApply "IH".
Qed. Qed.
Lemma FG_CG_pop_refinement st st' (τi : D) l Δ Γ : Lemma FG_CG_pop_refinement st st' (τi : D) l N Δ Γ :
inv stackN (sinv τi st st' l) - N ## logrelN
inv N (sinv τi st st' l) -
{τi::Δ;Γ} FG_pop $/ LitV (Loc st) log CG_locked_pop $/ LitV (Loc st') $/ LitV (Loc l) : TArrow TUnit (TSum TUnit (TVar 0)). {τi::Δ;Γ} FG_pop $/ LitV (Loc st) log CG_locked_pop $/ LitV (Loc st') $/ LitV (Loc l) : TArrow TUnit (TSum TUnit (TVar 0)).
Proof. Proof.
iIntros "#Hinv". iIntros (?) "#Hinv".
iApply bin_log_related_arrow_val; eauto. iApply bin_log_related_arrow_val; eauto.
{ unlock FG_pop CG_locked_pop. reflexivity. } { unlock FG_pop CG_locked_pop. reflexivity. }
{ unlock FG_pop CG_locked_pop. reflexivity. } { unlock FG_pop CG_locked_pop. reflexivity. }
{ unlock FG_pop CG_locked_pop. simpl_subst/=. solve_closed. } { unlock FG_pop CG_locked_pop. simpl_subst/=. solve_closed. }
{ unlock FG_pop CG_locked_pop. simpl_subst/=. solve_closed. } { unlock FG_pop CG_locked_pop. simpl_subst/=. solve_closed. }
iAlways. iIntros (? ?) "[% %]". simplify_eq/=. iAlways. iIntros (? ?) "[% %]". simplify_eq/=.
iApply (FG_CG_pop_refinement' stackN); eauto. iApply (FG_CG_pop_refinement' N); eauto.
{ solve_ndisj. }
Qed. Qed.
Lemma FG_CG_iter_refinement st st' (τi : D) l Δ Γ: Lemma FG_CG_iter_refinement st st' (τi : D) l N Δ Γ:
inv stackN (sinv τi st st' l) - N ## logrelN
inv N (sinv τi st st' l) -
{τi::Δ;Γ} FG_read_iter $/ LitV (Loc st) log CG_snap_iter $/ LitV (Loc st') $/ LitV (Loc l) : TArrow (TArrow (TVar 0) TUnit) TUnit. {τi::Δ;Γ} FG_read_iter $/ LitV (Loc st) log CG_snap_iter $/ LitV (Loc st') $/ LitV (Loc l) : TArrow (TArrow (TVar 0) TUnit) TUnit.
Proof. Proof.
iIntros "#Hinv". iIntros (?) "#Hinv".
Transparent FG_read_iter CG_snap_iter. Transparent FG_read_iter CG_snap_iter.
unfold FG_read_iter, CG_snap_iter. unlock. unfold FG_read_iter, CG_snap_iter. unlock.
simpl_subst/=. simpl_subst/=.
iApply bin_log_related_arrow_val; eauto. iApply bin_log_related_arrow; eauto.
iAlways. iIntros (f1 f2) "#Hff /=". iAlways. iIntros (f1 f2) "#Hff /=".
rel_rec_r. rel_rec_r.
rel_rec_l. rel_rec_l.
Transparent FG_iter CG_iter. unlock FG_iter CG_iter. Transparent FG_iter CG_iter. unlock FG_iter CG_iter.
rel_rec_l. rel_rec_l. rel_rec_r.
rel_rec_r.
Transparent CG_snap. unlock CG_snap. Transparent CG_snap. unlock CG_snap.
rel_rec_r. rel_rec_r. rel_rec_r. rel_rec_r.
rel_rec_r.
rel_rec_r.
rel_load_l_atomic. rel_load_l_atomic.
iInv stackN as (istk v h) "[Hoe [Hst' [Hst [#HLK Hl]]]]" "Hclose". iInv N as (istk w) "(>Hst' & >Hl & >Hst & HLK)" "Hclose".
iExists _. iFrame. iExists _. iFrame.
iModIntro. iNext. iIntros "Hst /=". iModIntro. iNext. iIntros "Hst /=".
...@@ -228,72 +250,33 @@ replace ((rec: "pop" "st" <> := ...@@ -228,72 +250,33 @@ replace ((rec: "pop" "st" <> :=
rel_apply_r (bin_log_related_release_r with "Hl"). rel_apply_r (bin_log_related_release_r with "Hl").
{ solve_ndisj. } { solve_ndisj. }
iIntros "Hl /=". iIntros "Hl /=".
rel_rec_r. rel_rec_r. rel_let_r.
close_sinv "Hclose" "[Hoe Hst' Hst Hl HLK]". clear h. rel_let_l.
iLöb as "IH" forall (istk v) "HLK". iDestruct "HLK" as "[HLK HLK2]".
rel_rec_l. iMod ("Hclose" with "[Hst' HLK2 Hst Hl]") as "_".
rel_unfold_l. { iNext. iExists _, _. iFrame. }
rel_rec_r. iLöb as "IH" forall (istk w).
iPoseProof "HLK" as "HLK'".
rewrite {1}StackLink_unfold. rewrite {1}stack_link_unfold.
iDestruct "HLK" as (istk2 w) "(% & Histk & HLK)". simplify_eq/=. iDestruct "HLK" as (w') "([Histk Histk2] & HLK)".
iDestruct "HLK" as "[[% %] | HLK]"; simplify_eq/=. iDestruct "HLK" as "[[% %] | HLK]"; simplify_eq/=.
- (* The stack is empty *) - (* The stack is empty *)
rel_fold_r. iDestruct "Histk2" as (q) "Histk2".
rel_case_r. rel_fold_r. rel_case_r. rel_rec_r.