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
theories/examples/lateearlychoice.v
theories/examples/par.v
theories/examples/bit.v
theories/examples/stack/stack_rules.v
theories/examples/stack/CG_stack.v
theories/examples/stack/FG_stack.v
theories/examples/stack/refinement.v
......@@ -52,4 +51,4 @@ theories/tests/tactics2.v
theories/tests/liftings.v
theories/tests/value.v
theories/examples/coqpl.v
theories/examples/brouwers.v
\ No newline at end of file
theories/examples/brouwers.v
From iris.proofmode Require Import tactics.
From iris_logrel Require Import logrel.
From iris_logrel.examples.stack Require Import
CG_stack FG_stack stack_rules refinement.
CG_stack FG_stack refinement.
Section Mod_refinement.
Context `{HLR : logrelG Σ}.
......@@ -9,15 +9,15 @@ Section Mod_refinement.
Implicit Types Δ : listC D.
Import lang.
Program Definition sint {LG : logrelG Σ} {Z : stackPreG Σ} τi : prodC valC valC -n> iProp Σ := λne vv,
( γ (l stk stk' : loc), (vv.2) = (#stk', #l)%V (vv.1) = #stk
inv (stackN .@ (stk,stk')) (sinv' γ τi stk stk' l))%I.
Program Definition sint τi : prodC valC valC -n> iProp Σ := λne vv,
( (l stk stk' : loc), (vv.2) = (#stk', #l)%V (vv.1) = #stk
inv (stackN .@ (stk,stk')) (sinv τi stk stk' l))%I.
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.
Lemma module_refinement `{SPG : stackPreG Σ} Δ Γ :
Lemma module_refinement Δ Γ :
{Δ;Γ} FG_stack.stackmod log CG_stack.stackmod : TForall $ TExists $ TProd (TProd
(TArrow TUnit (TVar 0))
(TArrow (TVar 0) (TSum TUnit (TVar 1))))
......@@ -40,25 +40,16 @@ Section Mod_refinement.
rel_alloc_r as l "Hl".
rel_vals.
rewrite -persistent.
iMod (own_alloc ( ( : stackUR))) as (γ) "Hemp"; first done.
pose (SG := StackG Σ _ γ).
iAssert (prestack_owns γ ) with "[Hemp]" as "Hoe".
{ 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. }
iAssert (sinv τi stk stk' l) with "[-]" as "Hinv".
{ iExists _,_. iFrame.
rewrite stack_link_unfold. iExists _; iSplitL; eauto. }
iMod (inv_alloc (stackN.@(stk,stk')) with "[Hinv]") as "#Hinv".
{ iNext. iExact "Hinv". }
iModIntro.
iExists γ, l, stk, stk'. eauto.
iExists l, stk, stk'. eauto.
- iApply bin_log_related_arrow_val; eauto.
iAlways. iIntros (? ?) "#Hvv /=".
iDestruct "Hvv" as (γ l stk stk') "(% & % & #Hinv)".
iDestruct "Hvv" as (l stk stk') "(% & % & #Hinv)".
simplify_eq/=.
rel_let_l.
rel_let_r.
......@@ -73,15 +64,12 @@ Section Mod_refinement.
replace (TSum TUnit (TVar 1))
with (TSum TUnit (TVar 0)).[ren (+1)] by done.
iApply bin_log_related_weaken_2.
pose (SG := StackG Σ _ γ).
change γ with stack_name.
iApply (FG_CG_pop_refinement' (stackN.@(stk,stk'))).
{ solve_ndisj. }
by rewrite sinv_unfold.
iApply (FG_CG_pop_refinement' (stackN.@(stk,stk')) with "Hinv").
solve_ndisj.
- iApply bin_log_related_arrow_val; eauto.
{ unlock FG_push. done. }
iAlways. iIntros (? ?) "#Hvv /=".
iDestruct "Hvv" as (γ l stk stk') "(% & % & #Hinv)".
iDestruct "Hvv" as (l stk stk') "(% & % & #Hinv)".
simplify_eq/=.
rel_let_r.
Transparent FG_push.
......@@ -98,11 +86,8 @@ Section Mod_refinement.
with ((CG_locked_push $/ LitV stk' $/ LitV l) v')%E; last first.
{ unlock CG_locked_push. simpl_subst/=. done. }
change TUnit with (TUnit.[ren (+1)]).
pose (SG := StackG Σ _ γ).
change γ with stack_name.
iApply (FG_CG_push_refinement (stackN.@(stk,stk')) with "[Hinv] Hτi").
{ solve_ndisj. }
by rewrite sinv_unfold.
iApply (FG_CG_push_refinement (stackN.@(stk,stk')) with "Hinv Hτi").
solve_ndisj.
Qed.
End Mod_refinement.
......@@ -113,7 +98,6 @@ Theorem module_ctx_refinement :
(TArrow (TVar 0) (TSum TUnit (TVar 1))))
(TArrow (TVar 0) (TArrow (TVar 1) TUnit)).
Proof.
set (Σ := #[logrelΣ; GFunctor (authR stackUR)]).
eapply (logrel_ctxequiv Σ); [solve_closed.. | intros ].
eapply (logrel_ctxequiv logrelΣ); [solve_closed.. | intros ].
apply module_refinement.
Qed.
This diff is collapsed.
From iris.algebra Require Import gmap agree.
From iris.base_logic.lib Require Export auth.
From iris_logrel Require Export logrel.
Import uPred.
Definition stackUR : ucmraT := gmapUR loc (agreeR valC).
Class stackG Σ :=
StackG { stack_inG :> authG Σ stackUR; stack_name : gname }.
Class stackPreG Σ := StackPreG { stack_pre_inG :> authG Σ stackUR }.
Definition stackΣ : gFunctors := #[authΣ stackUR].
Instance subG_stackPreG {Σ} : subG stackΣ Σ stackPreG Σ.
Proof. solve_inG. Qed.
(* Instance stackG_stackPreG {Σ} : stackG Σ stackPreG Σ. *)
(* Proof. intros [S ?]. by constructor. Qed. *)
Definition prestack_mapsto `{authG Σ stackUR} (γ : gname) (l : loc) (v : val) : iProp Σ :=
own γ ( {[ l := to_agree v ]}).
Definition stack_mapsto `{stackG Σ} l v : iProp Σ := prestack_mapsto stack_name l v.
Notation "l ↦ˢᵗᵏ v" := (stack_mapsto l v) (at level 20) : uPred_scope.
Section Rules_pre.
Context `{authG Σ stackUR}.
Variable (γ : gname).
Notation D := (prodC valC valC -n> iProp Σ).
Notation "l ↦ˢᵗᵏ v" := (prestack_mapsto γ l v) (at level 20) : uPred_scope.
Global Instance stack_mapsto_persistent l v : Persistent (l ↦ˢᵗᵏ v).
Proof. apply _. Qed.
Lemma prestack_mapstos_agree_uncurried l v w : l ↦ˢᵗᵏ v l ↦ˢᵗᵏ w v = w.
Proof.
rewrite -own_op -auth_frag_op op_singleton.
change (own γ ( {[l := to_agree v to_agree w]}))
with (auth_own γ {[l := to_agree v to_agree w]}).
rewrite auth_own_valid. iIntros "Hvalid". iDestruct "Hvalid" as %Hvalid.
rewrite singleton_valid in Hvalid *.
intros Hagree. by rewrite (agree_op_inv' v w Hagree).
Qed.
Lemma prestack_mapstos_agree l v w : l ↦ˢᵗᵏ v - l ↦ˢᵗᵏ w - v = w.
Proof.
iIntros "??".
iApply prestack_mapstos_agree_uncurried. by iFrame.
Qed.
(* stacklink Q := {((Loc l), nil) l ↦ˢᵗᵏ (InjL #()) }
{((Loc l), cons y2 z2) y1 z1, l ↦ˢᵗᵏ (y1, z1)
(y1, y2) Q
stacklink Q (z1, z2) }*)
Program Definition preStackLink_pre (Q : D) : D -n> D := λne P v,
( (l : loc) w, v.1 = # l l ↦ˢᵗᵏ w
((w = InjLV #() v.2 = FoldV (InjLV #()))
( y1 z1 y2 z2, w = InjRV (PairV y1 (FoldV z1))
v.2 = FoldV (InjRV (PairV y2 z2)) Q (y1, y2) P(z1, z2))))%I.
Solve Obligations with solve_proper.
Global Instance StackLink_pre_contractive Q : Contractive (preStackLink_pre Q).
Proof. solve_contractive. Qed.
Definition preStackLink (Q : D) : D := fixpoint (preStackLink_pre Q).
Lemma preStackLink_unfold Q v :
preStackLink Q v ( (l : loc) w,
v.1 = # l l ↦ˢᵗᵏ w
((w = InjLV #() v.2 = FoldV (InjLV #()))
( y1 z1 y2 z2, w = InjRV (PairV y1 (FoldV z1))
v.2 = FoldV (InjRV (PairV y2 z2))
Q (y1, y2) preStackLink Q (z1, z2))))%I.
Proof. by rewrite {1}/preStackLink fixpoint_unfold. Qed.
Global Opaque preStackLink. (* So that we can only use the unfold above. *)
Global Instance preStackLink_persistent (Q : D) v :
Persistent (preStackLink Q v).
Proof.
rewrite /Persistent.
iIntros "H". iLöb as "IH" forall (v). rewrite preStackLink_unfold.
iDestruct "H" as (l w) "[% [#Hl [[% %]|Hr]]]"; subst.
{ iExists l, _; iAlways; eauto. }
iDestruct "Hr" as (y1 z1 y2 z2) "[% [% [#HQ Hrec]]]"; subst.
rewrite later_forall.
iSpecialize ("IH" $! (z1, z2)). rewrite later_wand.
iSpecialize ("IH" with "Hrec"). rewrite -persistently_later.
iDestruct "IH" as "#IH".
iAlways. iExists _,_; eauto 20.
Qed.
Lemma stackR_alloc (h : stackUR) (i : loc) (v : val) :
h !! i = None h ~~> (<[i := to_agree v]> h) {[i := to_agree v]}.
Proof. intros. by apply auth_update_alloc, alloc_singleton_local_update. Qed.
Definition prestack_owns `{logrelG Σ} (h : gmap loc val) : iProp Σ :=
(own γ ( (to_agree <$> h : stackUR))
[ map] l v h, l ↦ᵢ v)%I.
Lemma prestack_owns_alloc `{logrelG Σ} h l v :
prestack_owns h l ↦ᵢ v == prestack_owns (<[l := v]> h) l ↦ˢᵗᵏ v.
Proof.
iIntros "[[Hown Hall] Hl]".
iDestruct (own_valid with "Hown") as %Hvalid.
destruct (h !! l) as [av|] eqn:Hhl.
{ iDestruct (big_sepM_lookup _ h l with "Hall") as "Hl'"; first done.
iDestruct (mapsto_valid_2 with "Hl Hl'") as %Hval.
cbv in Hval. exfalso; by apply Hval. }
{ iMod (own_update with "Hown") as "[Hown Hl']".
eapply auth_update_alloc.
eapply (alloc_singleton_local_update _ l (to_agree v)).
- rewrite lookup_fmap Hhl. by compute.
- by compute.
- iModIntro. rewrite /prestack_owns. rewrite fmap_insert.
iFrame "Hown Hl'".
iApply (big_sepM_insert _ h l); eauto.
by iFrame. }
Qed.
Lemma prestack_owns_open_close `{logrelG Σ} h l v :
prestack_owns h - l ↦ˢᵗᵏ v - l ↦ᵢ v (l ↦ᵢ v - prestack_owns h).
Proof.
iIntros "[Howns Hls] Hl".
iDestruct (own_valid_2 with "Howns Hl")
as %[[? [[av [Hav ?]]%equiv_Some_inv_r' Hav']]%singleton_included ?]%auth_valid_discrete_2.
setoid_subst.
(* TODO: ask Robbert why did I have to change this *)
apply -> @Some_included_total in Hav'; [| apply _].
move: Hav. rewrite lookup_fmap fmap_Some.
move=> [v' [Hl Hav]]; subst.
apply to_agree_included in Hav'; setoid_subst.
iDestruct (big_sepM_lookup_acc _ h l with "Hls") as "[$ Hclose]"; first done.
iIntros "Hl'". rewrite /prestack_owns. iFrame "Howns". by iApply "Hclose".
Qed.
Lemma prestack_owns_later_open_close `{logrelG Σ} h l v :
prestack_owns h - l ↦ˢᵗᵏ v - (l ↦ᵢ v (l ↦ᵢ v - prestack_owns h)).
Proof. iIntros "H1 H2". iNext; by iApply (prestack_owns_open_close with "H1"). Qed.
End Rules_pre.
Section Rules.
Context `{stackG Σ}.
Notation D := (prodC valC valC -n> iProp Σ).
Definition stack_owns `{logrelG Σ} := prestack_owns stack_name.
Lemma stack_mapstos_agree l v w : l ↦ˢᵗᵏ v - l ↦ˢᵗᵏ w - v = w.
Proof. apply prestack_mapstos_agree. Qed.
Lemma stack_owns_alloc `{logrelG Σ} h l v :
stack_owns h l ↦ᵢ v == stack_owns (<[l := v]> h) l ↦ˢᵗᵏ v.
Proof. apply prestack_owns_alloc. Qed.
Lemma stack_owns_open_close `{logrelG Σ} h l v :
stack_owns h - l ↦ˢᵗᵏ v - l ↦ᵢ v (l ↦ᵢ v - stack_owns h).
Proof. apply prestack_owns_open_close. Qed.
Lemma stack_owns_later_open_close `{logrelG Σ} h l v :
stack_owns h - l ↦ˢᵗᵏ v - (l ↦ᵢ v (l ↦ᵢ v - stack_owns h)).
Proof. apply prestack_owns_later_open_close. Qed.
Definition StackLink Q v := preStackLink stack_name Q v.
Lemma StackLink_unfold Q v :
StackLink Q v ( (l : loc) w,
v.1 = # l l ↦ˢᵗᵏ w
((w = InjLV #() v.2 = FoldV (InjLV #()))
( y1 z1 y2 z2, w = InjRV (PairV y1 (FoldV z1))
v.2 = FoldV (InjRV (PairV y2 z2))
Q (y1, y2) StackLink Q (z1, z2))))%I.
Proof. by rewrite /StackLink preStackLink_unfold. Qed.
Global Instance StackLink_persistent (Q : D) v :
Persistent (StackLink Q v).
Proof. apply _. Qed.
Global Opaque StackLink.
End Rules.
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