Commit 4107a238 authored by Ralf Jung's avatar Ralf Jung

prettify treiber stack

parent a04b230a
Pipeline #14062 failed with stage
...@@ -87,87 +87,81 @@ Section proof. ...@@ -87,87 +87,81 @@ Section proof.
Proof. generalize hd. induction xs; apply _. Qed. Proof. generalize hd. induction xs; apply _. Qed.
Lemma new_stack_spec: Lemma new_stack_spec:
(Φ: val iProp Σ), {{{ True }}} new_stack #() {{{ s, RET #s; is_stack s [] }}}.
( s, is_stack s [] - Φ #s) WP new_stack #() {{ Φ }}.
Proof. Proof.
iIntros (Φ) "HΦ". wp_lam. iIntros (Φ) "_ HΦ". wp_lam.
wp_bind (ref NONE)%E. wp_alloc l as "Hl". wp_bind (ref NONE)%E. wp_alloc l as "Hl".
wp_alloc l' as "Hl'". wp_alloc l' as "Hl'".
iApply "HΦ". rewrite /is_stack. iExists l. iApply "HΦ". rewrite /is_stack. iExists l.
iFrame. by iExists 1%Qp. iFrame. by iExists 1%Qp.
Qed. Qed.
Definition push_triple (s: loc) (x: val) :=
<<< (xs : list val) (hd : loc), s #hd is_list hd xs >>>
push #s x @
<<< hd' : loc, s #hd' hd' SOMEV (x, #hd) is_list hd xs, RET #() >>>.
Lemma push_atomic_spec (s: loc) (x: val) : Lemma push_atomic_spec (s: loc) (x: val) :
push_triple s x. <<< (xs : list val), is_stack s xs >>>
push #s x @
<<< is_stack s (x::xs), RET #() >>>.
Proof. Proof.
rewrite /push_triple. iApply wp_atomic_intro. iApply wp_atomic_intro. unfold is_stack.
iIntros (Φ) "HP". iLöb as "IH". wp_rec. iIntros (Φ) "HP". iLöb as "IH". wp_rec.
wp_let. wp_bind (! _)%E. wp_let. wp_bind (! _)%E.
iMod "HP" as (xs hd) "[[Hs Hhd] [Hvs' _]]". iMod "HP" as (xs) "[Hxs [Hvs' _]]".
wp_load. iMod ("Hvs'" with "[Hs Hhd]") as "HP"; first by iFrame. iDestruct "Hxs" as (hd) "[Hs Hhd]".
wp_load. iMod ("Hvs'" with "[Hs Hhd]") as "HP"; first by eauto with iFrame.
iModIntro. wp_let. wp_alloc l as "Hl". wp_let. iModIntro. wp_let. wp_alloc l as "Hl". wp_let.
wp_bind (CAS _ _ _)%E. wp_bind (CAS _ _ _)%E.
iMod "HP" as (xs' hd') "[[Hs Hhd'] Hvs']". iMod "HP" as (xs') "[Hxs' Hvs']".
iDestruct "Hxs'" as (hd') "[Hs' Hhd']".
destruct (decide (hd = hd')) as [->|Hneq]. destruct (decide (hd = hd')) as [->|Hneq].
* wp_cas_suc. iDestruct "Hvs'" as "[_ Hvs']". * wp_cas_suc. iDestruct "Hvs'" as "[_ Hvs']".
iMod ("Hvs'" with "[-]") as "HQ". iMod ("Hvs'" with "[-]") as "HQ".
{ by iFrame. } { by eauto with iFrame. }
iModIntro. wp_if. eauto. iModIntro. wp_if. eauto.
* wp_cas_fail. * wp_cas_fail.
iDestruct "Hvs'" as "[Hvs' _]". iDestruct "Hvs'" as "[Hvs' _]".
iMod ("Hvs'" with "[-]") as "HP"; first by iFrame. iMod ("Hvs'" with "[-]") as "HP"; first by eauto with iFrame.
iModIntro. wp_if. by iApply "IH". iModIntro. wp_if. by iApply "IH".
Qed. Qed.
Definition pop_triple (s: loc) := Lemma pop_atomic_spec (s: loc) :
<<< (xs : list val) (hd : loc), s #hd is_list hd xs >>> <<< (xs : list val), is_stack s xs >>>
pop #s @ pop #s @
<<< match xs with [] => s #hd is_list hd [] <<< match xs with [] => is_stack s []
| x::xs' => q (hd': loc), hd {q} SOMEV (x, #hd') s #hd' is_list hd' xs' end, | x::xs' => is_stack s xs' end,
RET match xs with [] => NONEV | x :: _ => SOMEV x end >>>. RET match xs with [] => NONEV | x :: _ => SOMEV x end >>>.
Lemma pop_atomic_spec (s: loc):
pop_triple s.
Proof. Proof.
rewrite /pop_triple. iApply wp_atomic_intro. iApply wp_atomic_intro. unfold is_stack.
iIntros (Φ) "HP". iLöb as "IH". wp_rec. iIntros (Φ) "HP". iLöb as "IH". wp_rec.
wp_bind (! _)%E. wp_bind (! _)%E.
iMod "HP" as (xs hd) "[[Hs Hhd] Hvs']". iMod "HP" as (xs) "[Hxs Hvs']".
iDestruct "Hxs" as (hd) "[Hs Hhd]".
destruct xs as [|y' xs']. destruct xs as [|y' xs'].
- simpl. wp_load. iDestruct "Hvs'" as "[_ Hvs']". - simpl. wp_load. iDestruct "Hvs'" as "[_ Hvs']".
iDestruct "Hhd" as (q) "[Hhd Hhd']". iDestruct "Hhd" as (q) "[Hhd Hhd']".
iMod ("Hvs'" with "[-Hhd]") as "HQ". iMod ("Hvs'" with "[-Hhd]") as "HQ".
{ iFrame. eauto. } { eauto with iFrame. }
iModIntro. wp_let. wp_load. wp_pures. iModIntro. wp_let. wp_load. wp_pures.
eauto. eauto.
- simpl. iDestruct "Hhd" as (hd' q) "([[Hhd1 Hhd2] Hhd'] & Hxs')". - simpl. iDestruct "Hhd" as (hd' q) "([[Hhd1 Hhd2] Hhd'] & Hxs')".
iDestruct (dup_is_list with "[Hxs']") as "[Hxs1 Hxs2]"; first by iFrame. iDestruct (dup_is_list with "[Hxs']") as "[Hxs1 Hxs2]"; first by iFrame.
wp_load. iDestruct "Hvs'" as "[Hvs' _]". wp_load. iDestruct "Hvs'" as "[Hvs' _]".
iMod ("Hvs'" with "[-Hhd1 Hhd2 Hxs1]") as "HP". iMod ("Hvs'" with "[-Hhd1 Hhd2 Hxs1]") as "HP".
{ iFrame. iExists hd', (q / 2)%Qp. by iFrame. } { eauto with iFrame. }
iModIntro. wp_let. wp_load. wp_match. wp_proj. iModIntro. wp_let. wp_load. wp_match. wp_proj.
wp_bind (CAS _ _ _). wp_bind (CAS _ _ _).
iMod "HP" as (xs hd'') "[[Hs Hhd''] Hvs']". iMod "HP" as (xs'') "[Hxs'' Hvs']".
iDestruct "Hxs''" as (hd'') "[Hs'' Hhd'']".
destruct (decide (hd = hd'')) as [->|Hneq]. destruct (decide (hd = hd'')) as [->|Hneq].
+ wp_cas_suc. iDestruct "Hvs'" as "[_ Hvs']". + wp_cas_suc. iDestruct "Hvs'" as "[_ Hvs']".
destruct xs as [|x' xs'']. destruct xs'' as [|x'' xs''].
{ simpl. iDestruct "Hhd''" as (?) "H". { simpl. iDestruct "Hhd''" as (?) "H".
iExFalso. by iDestruct (@mapsto_agree with "[$Hhd1] [$H]") as %?. } iExFalso. by iDestruct (@mapsto_agree with "[$Hhd1] [$H]") as %?. }
simpl. iDestruct "Hhd''" as (hd''' ?) "(Hhd'' & Hxs'')". simpl. iDestruct "Hhd''" as (hd''' ?) "(Hhd'' & Hxs'')".
iDestruct (@mapsto_agree with "[$Hhd1] [$Hhd'']") as %[=]. subst. iDestruct (@mapsto_agree with "[$Hhd1] [$Hhd'']") as %[=]. subst.
iMod ("Hvs'" with "[-]") as "HQ". iMod ("Hvs'" with "[-]") as "HQ".
{ iExists (q / 2 / 2)%Qp, _. { eauto with iFrame. }
iDestruct (uniq_is_list with "[Hxs1 Hxs'']") as "%"; first by iFrame. subst.
repeat (iSplitR "Hxs1 Hs"; first done).
iFrame. }
iModIntro. wp_if. wp_pures. eauto. iModIntro. wp_if. wp_pures. eauto.
+ wp_cas_fail. iDestruct "Hvs'" as "[Hvs' _]". + wp_cas_fail. iDestruct "Hvs'" as "[Hvs' _]".
iMod ("Hvs'" with "[-]") as "HP"; first by iFrame. iMod ("Hvs'" with "[-]") as "HP"; first by eauto with iFrame.
iModIntro. wp_if. by iApply "IH". iModIntro. wp_if. by iApply "IH".
Qed. Qed.
End proof. End proof.
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