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

add atomic concurrent increment

parent da432bbf
Pipeline #6967 passed with stage
in 11 minutes and 29 seconds
...@@ -78,6 +78,9 @@ theories/heap_lang/lang.v ...@@ -78,6 +78,9 @@ theories/heap_lang/lang.v
theories/heap_lang/tactics.v theories/heap_lang/tactics.v
theories/heap_lang/lifting.v theories/heap_lang/lifting.v
theories/heap_lang/notation.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/spawn.v
theories/heap_lang/lib/par.v theories/heap_lang/lib/par.v
theories/heap_lang/lib/assert.v theories/heap_lang/lib/assert.v
...@@ -86,9 +89,7 @@ theories/heap_lang/lib/spin_lock.v ...@@ -86,9 +89,7 @@ theories/heap_lang/lib/spin_lock.v
theories/heap_lang/lib/ticket_lock.v theories/heap_lang/lib/ticket_lock.v
theories/heap_lang/lib/counter.v theories/heap_lang/lib/counter.v
theories/heap_lang/lib/atomic_heap.v theories/heap_lang/lib/atomic_heap.v
theories/heap_lang/proofmode.v theories/heap_lang/lib/increment.v
theories/heap_lang/adequacy.v
theories/heap_lang/total_adequacy.v
theories/proofmode/base.v theories/proofmode/base.v
theories/proofmode/tokens.v theories/proofmode/tokens.v
theories/proofmode/coq_tactics.v theories/proofmode/coq_tactics.v
......
...@@ -10,8 +10,8 @@ Definition atomic_shift {PROP: sbi} `{!FUpd PROP} {A B : Type} ...@@ -10,8 +10,8 @@ Definition atomic_shift {PROP: sbi} `{!FUpd PROP} {A B : Type}
(P : PROP) (* pre-condition *) (P : PROP) (* pre-condition *)
(Q : A B PROP) (* post-condition *) (Q : A B PROP) (* post-condition *)
: PROP := : PROP :=
( ( E, Eo E - P ={E, EEm}= x, α x ( ( E, Eo E - P ={E, EEm}= x, α x
((α x ={EEm, E}= P) ( y, β x y ={EEm, E}= Q x y))) ((α x ={EEm, E}= P) ( y, β x y ={EEm, E}= Q x y)))
)%I. )%I.
Definition atomic_update {PROP: sbi} `{!FUpd PROP} {A B : Type} Definition atomic_update {PROP: sbi} `{!FUpd PROP} {A B : Type}
...@@ -21,7 +21,7 @@ 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 *) (Q : A B PROP) (* post-condition *)
: PROP := : PROP :=
tc_opaque ( 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. )%I.
Section lemmas. Section lemmas.
......
...@@ -6,7 +6,7 @@ From iris.heap_lang Require Import proofmode notation. ...@@ -6,7 +6,7 @@ From iris.heap_lang Require Import proofmode notation.
Set Default Proof Using "Type". Set Default Proof Using "Type".
(** A general logically atomic interface for a heap. *) (** A general logically atomic interface for a heap. *)
Structure atomic_heap Σ `{!heapG Σ} := AtomicHeap { Structure atomic_heap {Σ} `{!heapG Σ} := AtomicHeap {
(* -- operations -- *) (* -- operations -- *)
alloc : val; alloc : val;
load : val; load : val;
...@@ -26,19 +26,22 @@ Structure atomic_heap Σ `{!heapG Σ} := AtomicHeap { ...@@ -26,19 +26,22 @@ Structure atomic_heap Σ `{!heapG Σ} := AtomicHeap {
(λ '(v, q) (_:()), mapsto l q v) (λ '(v, q) (_:()), mapsto l q v)
(λ '(v, q) _, v); (λ '(v, q) _, v);
store_spec (l : loc) (w : val) : store_spec (l : loc) (e : expr) (w : val) :
atomic_wp (store (#l, w))%E IntoVal e w
atomic_wp (store (#l, e))%E
(λ v, mapsto l 1 v) (λ v, mapsto l 1 v)
(λ v (_:()), mapsto l 1 w) (λ v (_:()), mapsto l 1 w)
(λ _ _, #()%V); (λ _ _, #()%V);
cas_spec (l : loc) (w1 w2 : val) : cas_spec (l : loc) (e1 e2 : expr) (w1 w2 : val) :
atomic_wp (cas (#l, w1, w2))%E IntoVal e1 w1 IntoVal e2 w2
atomic_wp (cas (#l, e1, e2))%E
(λ v, mapsto l 1 v) (λ 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 mapsto l 1 w2 else mapsto l 1 v)
(λ v _, #(if decide (v = w1) then true else false)%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. *) (** Proof that the primitive physical operations of heap_lang satisfy said interface. *)
Definition primitive_alloc : val := Definition primitive_alloc : val :=
...@@ -71,26 +74,28 @@ Section proof. ...@@ -71,26 +74,28 @@ Section proof.
wp_load. iMod ("Hclose" $! () with "H↦"). done. wp_load. iMod ("Hclose" $! () with "H↦"). done.
Qed. Qed.
Lemma primitive_store_spec (l : loc) (w : val) : Lemma primitive_store_spec (l : loc) (e : expr) (w : val) :
atomic_wp (primitive_store (#l, w))%E IntoVal e w
atomic_wp (primitive_store (#l, e))%E
(λ v, l v)%I (λ v, l v)%I
(λ v (_:()), l w)%I (λ v (_:()), l w)%I
(λ _ _, #()%V). (λ _ _, #()%V).
Proof. 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. iMod (aupd_acc with "Aupd") as (v) "[H↦ [_ Hclose]]"; first solve_ndisj.
wp_store. iMod ("Hclose" $! () with "H↦"). done. wp_store. iMod ("Hclose" $! () with "H↦"). done.
Qed. Qed.
Lemma primitive_cas_spec (l : loc) (w1 w2 : val) : Lemma primitive_cas_spec (l : loc) e1 e2 (w1 w2 : val) :
atomic_wp (primitive_cas (#l, w1, w2))%E IntoVal e1 w1 IntoVal e2 w2
atomic_wp (primitive_cas (#l, e1, e2))%E
(λ v, l v)%I (λ v, l v)%I
(λ v (_:()), if decide (v = w1) then l w2 else 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). (λ v _, #(if decide (v = w1) then true else false)%V).
Proof. 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. 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]; destruct (decide (v = w1)) as [Hv|Hv]; [wp_cas_suc|wp_cas_fail];
iMod ("Hclose" $! () with "H↦"); done. 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.
Supports Markdown
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