diff --git a/heap_lang/lib/ticket_lock.v b/heap_lang/lib/ticket_lock.v index 28fa844df19a5ae1408ebaf7b0909941ff4b199d..8eaa7ba8aa5d8eb4f46c84fa8cc6889633776cd9 100644 --- a/heap_lang/lib/ticket_lock.v +++ b/heap_lang/lib/ticket_lock.v @@ -1,9 +1,8 @@ From iris.program_logic Require Export weakestpre. From iris.heap_lang Require Export lang. -From iris.program_logic Require Import auth. From iris.proofmode Require Import invariants. From iris.heap_lang Require Import proofmode notation. -From iris.algebra Require Import gset. +From iris.algebra Require Import auth gset. From iris.heap_lang.lib Require Export lock. Import uPred. @@ -23,53 +22,44 @@ Definition acquire : val := then wait_loop "n" "lock" else "acquire" "lock". -Definition release : val := - rec: "release" "lock" := - let: "o" := !(Fst "lock") in - if: CAS (Fst "lock") "o" ("o" + #1) - then #() - else "release" "lock". +Definition release : val := λ: "lock", + (Fst "lock") <- !(Fst "lock") + #1. Global Opaque newlock acquire release wait_loop. (** The CMRAs we need. *) -Class tlockG Σ := TlockG { - tlock_G :> authG Σ (gset_disjUR nat); - tlock_exclG :> inG Σ (exclR unitC) -}. +Class tlockG Σ := + tlock_G :> inG Σ (authR (prodUR (optionUR (exclR natC)) (gset_disjUR nat))). Definition tlockΣ : gFunctors := - #[authΣ (gset_disjUR nat); GFunctor (constRF (exclR unitC))]. + #[ GFunctor (constRF (authR (prodUR (optionUR (exclR natC)) (gset_disjUR nat)))) ]. Instance subG_tlockΣ {Σ} : subG tlockΣ Σ → tlockG Σ. -Proof. intros [? [?%subG_inG _]%subG_inv]%subG_inv. split; apply _. Qed. +Proof. by intros ?%subG_inG. Qed. Section proof. Context `{!heapG Σ, !tlockG Σ} (N : namespace). - Definition tickets_inv (n: nat) (gs: gset_disjUR nat) : iProp Σ := - (gs = GSet (seq_set 0 n))%I. - - Definition lock_inv (γ1 γ2: gname) (lo ln: loc) (R : iProp Σ) : iProp Σ := - (∃ (o n: nat), - lo ↦ #o ★ ln ↦ #n ★ - auth_inv γ1 (tickets_inv n) ★ - ((own γ2 (Excl ()) ★ R) ∨ auth_own γ1 (GSet {[ o ]})))%I. + Definition lock_inv (γ : gname) (lo ln : loc) (R : iProp Σ) : iProp Σ := + (∃ o n : nat, + lo ↦ #o ★ ln ↦ #n ★ + own γ (◠(Excl' o, GSet (seq_set 0 n))) ★ + ((own γ (◯ (Excl' o, ∅)) ★ R) ∨ own γ (◯ (∅, GSet {[ o ]}))))%I. - Definition is_lock (γs: gname * gname) (l: val) (R: iProp Σ) : iProp Σ := - (∃ (lo ln: loc), + Definition is_lock (γ : gname) (lk : val) (R : iProp Σ) : iProp Σ := + (∃ lo ln : loc, heapN ⊥ N ∧ heap_ctx ∧ - l = (#lo, #ln)%V ∧ inv N (lock_inv (fst γs) (snd γs) lo ln R))%I. + lk = (#lo, #ln)%V ∧ inv N (lock_inv γ lo ln R))%I. - Definition issued (γs: gname * gname) (l : val) (x: nat) (R : iProp Σ) : iProp Σ := - (∃ (lo ln: loc), + Definition issued (γ : gname) (lk : val) (x : nat) (R : iProp Σ) : iProp Σ := + (∃ lo ln: loc, heapN ⊥ N ∧ heap_ctx ∧ - l = (#lo, #ln)%V ∧ inv N (lock_inv (fst γs) (snd γs) lo ln R) ∧ - auth_own (fst γs) (GSet {[ x ]}))%I. + lk = (#lo, #ln)%V ∧ inv N (lock_inv γ lo ln R) ∧ + own γ (◯ (∅, GSet {[ x ]})))%I. - Definition locked (γs: gname * gname) : iProp Σ := own (snd γs) (Excl ())%I. + Definition locked (γ : gname) : iProp Σ := (∃ o, own γ (◯ (Excl' o, ∅)))%I. - Global Instance lock_inv_ne n γ1 γ2 lo ln : - Proper (dist n ==> dist n) (lock_inv γ1 γ2 lo ln). + Global Instance lock_inv_ne n γs lo ln : + Proper (dist n ==> dist n) (lock_inv γs lo ln). Proof. solve_proper. Qed. Global Instance is_lock_ne γs n l : Proper (dist n ==> dist n) (is_lock γs l). Proof. solve_proper. Qed. @@ -78,47 +68,41 @@ Section proof. Global Instance locked_timeless γs : TimelessP (locked γs). Proof. apply _. Qed. - Lemma locked_exclusive (γs: gname * gname) : (locked γs ★ locked γs ⊢ False)%I. - Proof. rewrite /locked -own_op own_valid. by iIntros (?). Qed. + Lemma locked_exclusive (γ : gname) : (locked γ ★ locked γ ⊢ False)%I. + Proof. + iIntros "[H1 H2]". iDestruct "H1" as (o1) "H1". iDestruct "H2" as (o2) "H2". + iCombine "H1" "H2" as "H". iDestruct (own_valid with "H") as %[[] _]. + Qed. Lemma newlock_spec (R : iProp Σ) Φ : heapN ⊥ N → - heap_ctx ★ R ★ (∀ lk γs, is_lock γs lk R -★ Φ lk) ⊢ WP newlock #() {{ Φ }}. + heap_ctx ★ R ★ (∀ lk γ, is_lock γ lk R -★ Φ lk) ⊢ WP newlock #() {{ Φ }}. Proof. iIntros (HN) "(#Hh & HR & HΦ)". rewrite /newlock /=. wp_seq. wp_alloc lo as "Hlo". wp_alloc ln as "Hln". - iVs (own_alloc (Excl ())) as (γ2) "Hγ2"; first done. - iVs (own_alloc_strong (Auth (Excl' ∅) ∅) {[ γ2 ]}) as (γ1) "[% Hγ1]"; first done. - iVs (inv_alloc N _ (lock_inv γ1 γ2 lo ln R) with "[-HΦ]"). - - iNext. rewrite /lock_inv. - iExists 0%nat, 0%nat. - iFrame. - iSplitL "Hγ1". - + rewrite /auth_inv. - iExists (GSet ∅). - by iFrame. - + iLeft. by iFrame. - - iVsIntro. - iApply ("HΦ" $! (#lo, #ln)%V (γ1, γ2)). - iExists lo, ln. - iSplit; by eauto. + iVs (own_alloc (◠(Excl' 0%nat, ∅) ⋅ ◯ (Excl' 0%nat, ∅))) as (γ) "[Hγ Hγ']". + { by rewrite -auth_both_op. } + iVs (inv_alloc _ _ (lock_inv γ lo ln R) with "[-HΦ]"). + { iNext. rewrite /lock_inv. + iExists 0%nat, 0%nat. iFrame. iLeft. by iFrame. } + iVsIntro. iApply ("HΦ" $! (#lo, #ln)%V γ). iExists lo, ln. eauto. Qed. - Lemma wait_loop_spec γs l x R (Φ : val → iProp Σ) : - issued γs l x R ★ (locked γs -★ R -★ Φ #()) ⊢ WP wait_loop #x l {{ Φ }}. + Lemma wait_loop_spec γ l x R (Φ : val → iProp Σ) : + issued γ l x R ★ (locked γ -★ R -★ Φ #()) ⊢ WP wait_loop #x l {{ Φ }}. Proof. iIntros "[Hl HΦ]". iDestruct "Hl" as (lo ln) "(% & #? & % & #? & Ht)". iLöb as "IH". wp_rec. subst. wp_let. wp_proj. wp_bind (! _)%E. - iInv N as (o n) "[Hlo [Hln Ha]]" "Hclose". + iInv N as (o n) "(Hlo & Hln & Ha)" "Hclose". wp_load. destruct (decide (x = o)) as [->|Hneq]. - iDestruct "Ha" as "[Hainv [[Ho HR] | Haown]]". - + iVs ("Hclose" with "[Hlo Hln Hainv Ht]"). + + iVs ("Hclose" with "[Hlo Hln Hainv Ht]") as "_". { iNext. iExists o, n. iFrame. eauto. } iVsIntro. wp_let. wp_op=>[_|[]] //. wp_if. iVsIntro. - iApply ("HΦ" with "[-HR] HR"). eauto. + iApply ("HΦ" with "[-HR] HR"). rewrite /locked; eauto. + iExFalso. iCombine "Ht" "Haown" as "Haown". - iDestruct (auth_own_valid with "Haown") as % ?%gset_disj_valid_op. + iDestruct (own_valid with "Haown") as % [_ ?%gset_disj_valid_op]. set_solver. - iVs ("Hclose" with "[Hlo Hln Ha]"). { iNext. iExists o, n. by iFrame. } @@ -126,64 +110,72 @@ Section proof. wp_if. iApply ("IH" with "Ht"). by iExact "HΦ". Qed. - Lemma acquire_spec γs l R (Φ : val → iProp Σ) : - is_lock γs l R ★ (locked γs -★ R -★ Φ #()) ⊢ WP acquire l {{ Φ }}. + Lemma acquire_spec γ l R (Φ : val → iProp Σ) : + is_lock γ l R ★ (locked γ -★ R -★ Φ #()) ⊢ WP acquire l {{ Φ }}. Proof. iIntros "[Hl HΦ]". iDestruct "Hl" as (lo ln) "(% & #? & % & #?)". iLöb as "IH". wp_rec. wp_bind (! _)%E. subst. wp_proj. iInv N as (o n) "[Hlo [Hln Ha]]" "Hclose". - wp_load. iVs ("Hclose" with "[Hlo Hln Ha]"). + wp_load. iVs ("Hclose" with "[Hlo Hln Ha]") as "_". { iNext. iExists o, n. by iFrame. } iVsIntro. wp_let. wp_proj. wp_op. wp_bind (CAS _ _ _). - iInv N as (o' n') "[Hlo' [Hln' [Hainv Haown]]]" "Hclose". + iInv N as (o' n') "(>Hlo' & >Hln' & >Hauth & Haown)" "Hclose". destruct (decide (#n' = #n))%V as [[= ->%Nat2Z.inj] | Hneq]. - wp_cas_suc. - iDestruct "Hainv" as (s) "[Ho %]"; subst. - iVs (own_update with "Ho") as "Ho". - { eapply auth_update_no_frag, (gset_disj_alloc_empty_local_update n). - rewrite elem_of_seq_set; omega. } - iDestruct "Ho" as "[Hofull Hofrag]". - iVs ("Hclose" with "[Hlo' Hln' Haown Hofull]"). - { rewrite gset_disj_union; last by apply (seq_set_S_disjoint 0). - rewrite -(seq_set_S_union_L 0). - iNext. iExists o', (S n)%nat. - rewrite Nat2Z.inj_succ -Z.add_1_r. - iFrame. iExists (GSet (seq_set 0 (S n))). by iFrame. } + iVs (own_update with "Hauth") as "Hauth". + { eapply (auth_update_no_frag _ (∅, _)), prod_local_update, + (gset_disj_alloc_empty_local_update n); [done|]. + rewrite elem_of_seq_set. omega. } + rewrite pair_op left_id_L. iDestruct "Hauth" as "[Hauth Hofull]". + rewrite gset_disj_union; last by apply (seq_set_S_disjoint 0). + rewrite -(seq_set_S_union_L 0). + iVs ("Hclose" with "[Hlo' Hln' Haown Hauth]") as "_". + { iNext. iExists o', (S n). + rewrite Nat2Z.inj_succ -Z.add_1_r. by iFrame. } iVsIntro. wp_if. - iApply (wait_loop_spec γs (#lo, #ln)). - iSplitR "HΦ"; last by auto. - rewrite /issued /auth_own; eauto 10. + iApply (wait_loop_spec γ (#lo, #ln)). + iFrame "HΦ". rewrite /issued; eauto 10. - wp_cas_fail. - iVs ("Hclose" with "[Hlo' Hln' Hainv Haown]"). + iVs ("Hclose" with "[Hlo' Hln' Hauth Haown]"). { iNext. iExists o', n'. by iFrame. } iVsIntro. wp_if. by iApply "IH". Qed. - Lemma release_spec γs l R (Φ : val → iProp Σ): - is_lock γs l R ★ locked γs ★ R ★ Φ #() ⊢ WP release l {{ Φ }}. + Lemma release_spec γ l R (Φ : val → iProp Σ): + is_lock γ l R ★ locked γ ★ R ★ Φ #() ⊢ WP release l {{ Φ }}. Proof. - iIntros "(Hl & Hγ & HR & HΦ)". iDestruct "Hl" as (lo ln) "(% & #? & % & #?)". - iLöb as "IH". wp_rec. subst. wp_proj. wp_bind (! _)%E. - iInv N as (o n) "[Hlo [Hln Hr]]" "Hclose". - wp_load. iVs ("Hclose" with "[Hlo Hln Hr]"). + iIntros "(Hl & Hγ & HR & HΦ)". + iDestruct "Hl" as (lo ln) "(% & #? & % & #?)"; subst. + iDestruct "Hγ" as (o) "Hγo". + rewrite /release. wp_let. wp_proj. wp_proj. wp_bind (! _)%E. + iInv N as (o' n) "(>Hlo & >Hln & >Hauth & Haown)" "Hclose". + wp_load. + iAssert (o' = o)%I with "[#]" as "%"; subst. + { iCombine "Hγo" "Hauth" as "Hγo". + by iDestruct (own_valid with "Hγo") (* FIXME: this is horrible *) + as %[[[[?|] ?] [=]%leibniz_equiv_iff] ?]%auth_valid_discrete. } + iVs ("Hclose" with "[Hlo Hln Hauth Haown]") as "_". { iNext. iExists o, n. by iFrame. } - iVsIntro. wp_let. wp_bind (CAS _ _ _ ). - wp_proj. wp_op. - iInv N as (o' n') "[Hlo' [Hln' Hr]]" "Hclose". - destruct (decide (#o' = #o))%V as [[= ->%Nat2Z.inj ] | Hneq]. - - wp_cas_suc. - iDestruct "Hr" as "[Hainv [[Ho _] | Hown]]". - + iExFalso. iCombine "Hγ" "Ho" as "Ho". - iDestruct (own_valid with "#Ho") as %[]. - + iVs ("Hclose" with "[Hlo' Hln' HR Hγ Hainv]"). - { iNext. iExists (o + 1)%nat, n'%nat. - iFrame. rewrite Nat2Z.inj_add. - iFrame. iLeft; by iFrame. } - iVsIntro. by wp_if. - - wp_cas_fail. iVs ("Hclose" with "[Hlo' Hln' Hr]"). - { iNext. iExists o', n'. by iFrame. } - iVsIntro. wp_if. by iApply ("IH" with "Hγ HR"). + iVsIntro. wp_op. + iInv N as (o' n') "(>Hlo & >Hln & >Hauth & Haown)" "Hclose". + wp_store. + iAssert (o' = o)%I with "[#]" as "%"; subst. + { iCombine "Hγo" "Hauth" as "Hγo". + by iDestruct (own_valid with "Hγo") + as %[[[[?|] ?] [=]%leibniz_equiv_iff] ?]%auth_valid_discrete. } + iDestruct "Haown" as "[[Hγo' _]|?]". + { iCombine "Hγo" "Hγo'" as "Hγo". + iDestruct (own_valid with "#Hγo") as %[[] ?]. } + iCombine "Hauth" "Hγo" as "Hauth". + iVs (own_update with "Hauth") as "Hauth". + { rewrite pair_split_L. apply: (auth_update _ _ (Excl' (S o), _)). (* FIXME: apply is slow *) + apply prod_local_update, reflexivity; simpl. + by apply option_local_update, exclusive_local_update. } + rewrite -pair_split_L. iDestruct "Hauth" as "[Hauth Hγo]". + iVs ("Hclose" with "[Hlo Hln Hauth Haown Hγo HR]") as "_"; last auto. + iNext. iExists (S o), n'. + rewrite Nat2Z.inj_succ -Z.add_1_r. iFrame. iLeft. by iFrame. Qed. End proof.