Commit 504296c5 authored by Ralf Jung's avatar Ralf Jung

add atomic concurrent increment

parent da432bbf
......@@ -78,6 +78,9 @@ theories/heap_lang/lang.v
theories/heap_lang/tactics.v
theories/heap_lang/lifting.v
theories/heap_lang/notation.v
theories/heap_lang/proofmode.v
theories/heap_lang/adequacy.v
theories/heap_lang/total_adequacy.v
theories/heap_lang/lib/spawn.v
theories/heap_lang/lib/par.v
theories/heap_lang/lib/assert.v
......@@ -86,9 +89,7 @@ theories/heap_lang/lib/spin_lock.v
theories/heap_lang/lib/ticket_lock.v
theories/heap_lang/lib/counter.v
theories/heap_lang/lib/atomic_heap.v
theories/heap_lang/proofmode.v
theories/heap_lang/adequacy.v
theories/heap_lang/total_adequacy.v
theories/heap_lang/lib/increment.v
theories/proofmode/base.v
theories/proofmode/tokens.v
theories/proofmode/coq_tactics.v
......
......@@ -10,8 +10,8 @@ Definition atomic_shift {PROP: sbi} `{!FUpd PROP} {A B : Type}
(P : PROP) (* pre-condition *)
(Q : A B PROP) (* post-condition *)
: PROP :=
( ( E, Eo E - P ={E, EEm}= x, α x
((α x ={EEm, E}= P) ( y, β x y ={EEm, E}= Q x y)))
( ( E, Eo E - P ={E, EEm}= x, α x
((α x ={EEm, E}= P) ( y, β x y ={EEm, E}= Q x y)))
)%I.
Definition atomic_update {PROP: sbi} `{!FUpd PROP} {A B : Type}
......@@ -21,7 +21,7 @@ Definition atomic_update {PROP: sbi} `{!FUpd PROP} {A B : Type}
(Q : A B PROP) (* post-condition *)
: PROP :=
tc_opaque (
(F P : PROP), F P atomic_shift α β Eo Em P (λ x y, F - Q x y)
(F P : PROP), F P atomic_shift α β Eo Em ( P) (λ x y, F - Q x y)
)%I.
Section lemmas.
......
......@@ -6,7 +6,7 @@ From iris.heap_lang Require Import proofmode notation.
Set Default Proof Using "Type".
(** A general logically atomic interface for a heap. *)
Structure atomic_heap Σ `{!heapG Σ} := AtomicHeap {
Structure atomic_heap {Σ} `{!heapG Σ} := AtomicHeap {
(* -- operations -- *)
alloc : val;
load : val;
......@@ -26,19 +26,22 @@ Structure atomic_heap Σ `{!heapG Σ} := AtomicHeap {
(λ '(v, q) (_:()), mapsto l q v)
(λ '(v, q) _, v);
store_spec (l : loc) (w : val) :
atomic_wp (store (#l, w))%E
store_spec (l : loc) (e : expr) (w : val) :
IntoVal e w
atomic_wp (store (#l, e))%E
(λ v, mapsto l 1 v)
(λ v (_:()), mapsto l 1 w)
(λ _ _, #()%V);
cas_spec (l : loc) (w1 w2 : val) :
atomic_wp (cas (#l, w1, w2))%E
cas_spec (l : loc) (e1 e2 : expr) (w1 w2 : val) :
IntoVal e1 w1 IntoVal e2 w2
atomic_wp (cas (#l, e1, e2))%E
(λ v, mapsto l 1 v)
(λ v (_:()), if decide (v = w1) then mapsto l 1 w2 else mapsto l 1 v)
(λ v _, #(if decide (v = w1) then true else false)%V);
}.
Arguments atomic_heap _ {_}.
(** Proof that the primitive physical operations of heap_lang satisfy said interface. *)
Definition primitive_alloc : val :=
......@@ -71,26 +74,28 @@ Section proof.
wp_load. iMod ("Hclose" $! () with "H↦"). done.
Qed.
Lemma primitive_store_spec (l : loc) (w : val) :
atomic_wp (primitive_store (#l, w))%E
Lemma primitive_store_spec (l : loc) (e : expr) (w : val) :
IntoVal e w
atomic_wp (primitive_store (#l, e))%E
(λ v, l v)%I
(λ v (_:()), l w)%I
(λ _ _, #()%V).
Proof.
iIntros (Φ) "Aupd". wp_let. wp_proj. wp_proj.
iIntros (<-%of_to_val Φ) "Aupd". wp_let. wp_proj. wp_proj.
iMod (aupd_acc with "Aupd") as (v) "[H↦ [_ Hclose]]"; first solve_ndisj.
wp_store. iMod ("Hclose" $! () with "H↦"). done.
Qed.
Lemma primitive_cas_spec (l : loc) (w1 w2 : val) :
atomic_wp (primitive_cas (#l, w1, w2))%E
Lemma primitive_cas_spec (l : loc) e1 e2 (w1 w2 : val) :
IntoVal e1 w1 IntoVal e2 w2
atomic_wp (primitive_cas (#l, e1, e2))%E
(λ v, l v)%I
(λ v (_:()), if decide (v = w1) then l w2 else l v)%I
(λ v _, #(if decide (v = w1) then true else false)%V).
Proof.
iIntros (Φ) "Aupd". wp_let. repeat wp_proj.
iIntros (<-%of_to_val <-%of_to_val Φ) "Aupd". wp_let. repeat wp_proj.
iMod (aupd_acc with "Aupd") as (v) "[H↦ [_ Hclose]]"; first solve_ndisj.
destruct (decide (v = w1)) as [Hv|Hv]; [wp_cas_suc|wp_cas_fail];
iMod ("Hclose" $! () with "H↦"); done.
......
From iris.heap_lang Require Export lifting notation.
From iris.base_logic.lib Require Export invariants.
From iris.program_logic Require Export atomic.
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Import proofmode notation atomic_heap.
Set Default Proof Using "Type".
(** Show taht implementing fetch-and-add on top of CAS preserves logical
atomicity. *)
(* TODO: Move this to iris-examples once gen_proofmode is merged. *)
Section increment.
Context `{!heapG Σ} {aheap: atomic_heap Σ}.
Definition incr: val :=
rec: "incr" "l" :=
let: "oldv" := aheap.(load) "l" in
if: aheap.(cas) ("l", "oldv", ("oldv" + #1))
then "oldv" (* return old value if success *)
else "incr" "l".
Lemma incr_spec (l: loc) :
atomic_wp (incr #l)
(λ (v: Z), aheap.(mapsto) l 1 #v)%I
(λ v (_:()), aheap.(mapsto) l 1 #(v + 1))%I
(λ v _, #v).
Proof.
iIntros (Φ) "AUpd". iLöb as "IH". wp_let.
wp_apply load_spec.
(* Prove the atomic shift for load *)
iDestruct "AUpd" as (F P) "(HF & HP & #AShft)".
iExists F, P. iFrame. iIntros "!# * % HP".
iMod ("AShft" with "[%] HP") as (x) "[H↦ Hclose]"; first done.
iModIntro. iExists (#x, 1%Qp). iFrame. iSplit.
{ iDestruct "Hclose" as "[Hclose _]". iApply "Hclose". }
iIntros (_) "H↦". iDestruct "Hclose" as "[Hclose _]".
iMod ("Hclose" with "H↦") as "HP". iIntros "!> HF".
clear dependent E.
(* Now go on *)
wp_let. wp_op. wp_bind (aheap.(cas) _)%I.
wp_apply cas_spec.
(* Prove the atomic shift for CAS *)
iExists F, P. iFrame. iIntros "!# * % HP".
iMod ("AShft" with "[%] HP") as (x') "[H↦ Hclose]"; first done.
iModIntro. iExists #x'. iFrame. iSplit.
{ iDestruct "Hclose" as "[Hclose _]". iApply "Hclose". }
iIntros (_). destruct (decide (#x' = #x)) as [[= Hx]|Hx].
- iIntros "H↦". iDestruct "Hclose" as "[_ Hclose]". subst.
iMod ("Hclose" $! () with "H↦") as "HΦ". iIntros "!> HF".
wp_if. by iApply "HΦ".
- iDestruct "Hclose" as "[Hclose _]". iIntros "H↦".
iMod ("Hclose" with "H↦") as "HP". iIntros "!> HF".
wp_if. iApply "IH". iExists F, P. iFrame. done.
Qed.
End increment.
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