Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Iris
examples
Commits
5fc8c715
Commit
5fc8c715
authored
Jan 12, 2018
by
Aleš Bizjak
Browse files
Add concurrent stacks with helping case study by Danny.
Fix #5.
parent
85d365c5
Pipeline
#6308
passed with stage
in 6 minutes and 20 seconds
Changes
5
Pipelines
13
Expand all
Hide whitespace changes
Inline
Side-by-side
README.md
View file @
5fc8c715
...
...
@@ -53,6 +53,8 @@ This repository contains the following case studies:
concurrent stack implementations
*
[
spanning-tree
](
theories/spanning_tree
)
: Proof of a concurrent spanning tree
algorithm.
*
[
concurrent-stacks
](
theories/concurrent_stacks
)
: Proof of an implementation of
concurrent stacks with helping, as described in the
[
report
](
http://iris-project.org/pdfs/2017-case-study-concurrent-stacks-with-helping.pdf
)
.
*
[
lecture-notes
](
theories/lecture_notes
)
: Coq examples for the
[
Iris lecture notes
](
http://iris-project.org/tutorial-material.html
)
.
...
...
theories/concurrent_stacks/concurrent_stack1.v
0 → 100644
View file @
5fc8c715
From
iris
.
base_logic
Require
Import
base_logic
.
From
iris
.
proofmode
Require
Import
tactics
.
From
iris
.
base_logic
.
lib
Require
Import
invariants
.
From
iris
.
program_logic
Require
Export
weakestpre
hoare
.
From
iris
.
heap_lang
Require
Export
lang
.
From
iris
.
algebra
Require
Import
agree
list
.
From
iris
.
heap_lang
Require
Import
assert
proofmode
notation
.
Set
Default
Proof
Using
"Type"
.
Definition
mk_stack
:
val
:
=
λ
:
"_"
,
let
:
"r"
:
=
ref
NONEV
in
(
rec
:
"pop"
"n"
:
=
match
:
!
"r"
with
NONE
=>
#-
1
|
SOME
"hd"
=>
if
:
CAS
"r"
(
SOME
"hd"
)
(
Snd
"hd"
)
then
Fst
"hd"
else
"pop"
"n"
end
,
rec
:
"push"
"n"
:
=
let
:
"r'"
:
=
!
"r"
in
let
:
"r''"
:
=
SOME
(
"n"
,
"r'"
)
in
if
:
CAS
"r"
"r'"
"r''"
then
#()
else
"push"
"n"
).
Section
stacks
.
Context
`
{!
heapG
Σ
}.
Implicit
Types
l
:
loc
.
Definition
is_stack_pre
(
P
:
val
→
iProp
Σ
)
(
F
:
val
-
c
>
iProp
Σ
)
:
val
-
c
>
iProp
Σ
:
=
λ
v
,
(
v
≡
NONEV
∨
∃
(
h
t
:
val
),
v
≡
SOMEV
(
h
,
t
)%
V
∗
P
h
∗
▷
F
t
)%
I
.
Local
Instance
is_stack_contr
(
P
:
val
→
iProp
Σ
)
:
Contractive
(
is_stack_pre
P
).
Proof
.
rewrite
/
is_stack_pre
=>
n
f
f'
Hf
v
.
repeat
(
f_contractive
||
f_equiv
).
apply
Hf
.
Qed
.
Definition
is_stack_def
(
P
:
val
->
iProp
Σ
)
:
=
fixpoint
(
is_stack_pre
P
).
Definition
is_stack_aux
P
:
seal
(@
is_stack_def
P
).
by
eexists
.
Qed
.
Definition
is_stack
P
:
=
unseal
(
is_stack_aux
P
).
Definition
is_stack_eq
P
:
@
is_stack
P
=
@
is_stack_def
P
:
=
seal_eq
(
is_stack_aux
P
).
Definition
stack_inv
P
v
:
=
(
∃
l
v'
,
⌜
v
=
#
l
⌝
∗
l
↦
v'
∗
is_stack
P
v'
)%
I
.
Lemma
is_stack_unfold
(
P
:
val
→
iProp
Σ
)
v
:
is_stack
P
v
⊣
⊢
is_stack_pre
P
(
is_stack
P
)
v
.
Proof
.
rewrite
is_stack_eq
.
apply
(
fixpoint_unfold
(
is_stack_pre
P
)).
Qed
.
Lemma
is_stack_disj
(
P
:
val
→
iProp
Σ
)
v
:
is_stack
P
v
-
∗
is_stack
P
v
∗
(
v
≡
NONEV
∨
∃
(
h
t
:
val
),
v
≡
SOMEV
(
h
,
t
)%
V
).
Proof
.
iIntros
"Hstack"
.
iDestruct
(
is_stack_unfold
with
"Hstack"
)
as
"[#Hstack|Hstack]"
.
-
iSplit
;
try
iApply
is_stack_unfold
;
iLeft
;
auto
.
-
iDestruct
"Hstack"
as
(
h
t
)
"[#Heq rest]"
.
iSplitL
;
try
iApply
is_stack_unfold
;
iRight
;
auto
.
Qed
.
Theorem
stack_works
P
Φ
:
(
∀
(
f
₁
f
₂
:
val
),
(
∀
(
v
:
val
),
□
WP
f
₁
#()
{{
v
,
P
v
∨
v
≡
#-
1
}})
-
∗
(
∀
(
v
:
val
),
□
(
P
v
-
∗
WP
f
₂
v
{{
v
,
True
}}))
-
∗
Φ
(
f
₁
,
f
₂
)%
V
)%
I
-
∗
WP
mk_stack
#()
{{
Φ
}}.
Proof
.
iIntros
"HΦ"
.
wp_lam
.
wp_alloc
l
as
"Hl"
.
pose
proof
(
nroot
.@
"N"
)
as
N
.
rewrite
-
wp_fupd
.
iMod
(
inv_alloc
N
_
(
stack_inv
P
#
l
)
with
"[Hl]"
)
as
"#Hisstack"
.
iExists
l
,
NONEV
;
iSplit
;
iFrame
;
auto
.
{
iApply
is_stack_unfold
.
iLeft
;
auto
.
}
wp_let
.
iModIntro
.
iApply
"HΦ"
.
-
iIntros
(
v
)
"!#"
.
iL
ö
b
as
"IH"
.
wp_rec
.
wp_bind
(!
#
l
)%
E
.
iInv
N
as
"Hstack"
"Hclose"
.
iDestruct
"Hstack"
as
(
l'
v'
)
"[>% [Hl' Hstack]]"
.
injection
H
;
intros
;
subst
.
wp_load
.
iDestruct
(
is_stack_disj
with
"Hstack"
)
as
"[Hstack #Heq]"
.
iMod
(
"Hclose"
with
"[Hl' Hstack]"
).
iExists
l'
,
v'
;
iFrame
;
auto
.
iModIntro
.
iDestruct
"Heq"
as
"[H | H]"
.
+
iRewrite
"H"
.
wp_match
.
iRight
;
auto
.
+
iDestruct
"H"
as
(
h
t
)
"H"
.
iRewrite
"H"
.
assert
(
to_val
(
h
,
t
)%
V
=
Some
(
h
,
t
)%
V
)
by
apply
to_of_val
.
assert
(
is_Some
(
to_val
(
h
,
t
)%
V
))
by
(
exists
(
h
,
t
)%
V
;
auto
).
wp_match
.
fold
of_val
.
unfold
subst
;
simpl
;
fold
subst
.
wp_bind
(
CAS
_
_
_
).
wp_proj
.
iInv
N
as
"Hstack"
"Hclose"
.
iDestruct
"Hstack"
as
(
l''
v''
)
"[>% [Hl'' Hstack]]"
.
injection
H2
;
intros
;
subst
.
assert
(
Decision
(
v''
=
InjRV
(
h
,
t
)%
V
))
as
Heq
by
apply
val_eq_dec
.
destruct
Heq
.
*
wp_cas_suc
.
iDestruct
(
is_stack_unfold
with
"Hstack"
)
as
"[Hstack | Hstack]"
.
subst
.
iDestruct
"Hstack"
as
"%"
;
discriminate
.
iDestruct
"Hstack"
as
(
h'
t'
)
"[% [HP Hstack]]"
.
subst
.
injection
H3
.
intros
.
subst
.
iMod
(
"Hclose"
with
"[Hl'' Hstack]"
).
iExists
l''
,
t'
;
iFrame
;
auto
.
iModIntro
.
wp_if
.
wp_proj
.
iLeft
;
auto
.
*
wp_cas_fail
.
iMod
(
"Hclose"
with
"[Hl'' Hstack]"
).
iExists
l''
,
v''
;
iFrame
;
auto
.
iModIntro
.
wp_if
.
iApply
"IH"
.
-
iIntros
(
v
)
"!# HP"
.
iL
ö
b
as
"IH"
.
wp_rec
.
wp_bind
(!
_
)%
E
.
iInv
N
as
"Hstack"
"Hclose"
.
iDestruct
"Hstack"
as
(
l'
v'
)
"[>% [Hl' Hstack]]"
.
injection
H
;
intros
;
subst
.
wp_load
.
iMod
(
"Hclose"
with
"[Hl' Hstack]"
).
by
(
iExists
l'
,
v'
;
iFrame
).
iModIntro
.
wp_let
.
wp_let
.
wp_bind
(
CAS
_
_
_
).
iInv
N
as
"Hstack"
"Hclose"
.
iDestruct
"Hstack"
as
(
l''
v''
)
"[>% [Hl'' Hstack]]"
.
injection
H0
;
intros
;
subst
.
assert
(
Decision
(
v''
=
v'
%
V
))
as
Heq
by
apply
val_eq_dec
.
destruct
Heq
.
+
wp_cas_suc
.
iMod
(
"Hclose"
with
"[Hl'' HP Hstack]"
).
iExists
l''
,
(
InjRV
(
v
,
v'
)%
V
).
iFrame
;
auto
.
iSplit
;
auto
.
iApply
is_stack_unfold
.
iRight
.
iExists
v
,
v'
.
iSplit
;
auto
.
subst
;
iFrame
.
iModIntro
.
wp_if
.
done
.
+
wp_cas_fail
.
iMod
(
"Hclose"
with
"[Hl'' Hstack]"
).
iExists
l''
,
v''
;
iFrame
;
auto
.
iModIntro
.
wp_if
.
iApply
"IH"
.
done
.
Qed
.
End
stacks
.
theories/concurrent_stacks/concurrent_stack2.v
0 → 100644
View file @
5fc8c715
From
iris
.
program_logic
Require
Export
weakestpre
hoare
.
From
iris
.
heap_lang
Require
Export
lang
proofmode
notation
.
From
iris
.
algebra
Require
Import
excl
.
Set
Default
Proof
Using
"Type"
.
Definition
mk_offer
:
val
:
=
λ
:
"v"
,
(
"v"
,
ref
#
0
).
Definition
revoke_offer
:
val
:
=
λ
:
"v"
,
if
:
CAS
(
Snd
"v"
)
#
0
#
2
then
SOME
(
Fst
"v"
)
else
NONE
.
Definition
take_offer
:
val
:
=
λ
:
"v"
,
if
:
CAS
(
Snd
"v"
)
#
0
#
1
then
SOME
(
Fst
"v"
)
else
NONE
.
Definition
mailbox
:
val
:
=
λ
:
"_"
,
let
:
"r"
:
=
ref
NONEV
in
(
rec
:
"put"
"v"
:
=
let
:
"off"
:
=
mk_offer
"v"
in
"r"
<-
SOME
"off"
;;
revoke_offer
"off"
,
rec
:
"get"
"n"
:
=
let
:
"offopt"
:
=
!
"r"
in
match
:
"offopt"
with
NONE
=>
NONE
|
SOME
"x"
=>
take_offer
"x"
end
).
Definition
mk_stack
:
val
:
=
λ
:
"_"
,
let
:
"mailbox"
:
=
mailbox
#()
in
let
:
"put"
:
=
Fst
"mailbox"
in
let
:
"get"
:
=
Snd
"mailbox"
in
let
:
"r"
:
=
ref
NONEV
in
(
rec
:
"pop"
"n"
:
=
match
:
"get"
#()
with
NONE
=>
(
match
:
!
"r"
with
NONE
=>
NONE
|
SOME
"hd"
=>
if
:
CAS
"r"
(
SOME
"hd"
)
(
Snd
"hd"
)
then
SOME
(
Fst
"hd"
)
else
"pop"
"n"
end
)
|
SOME
"x"
=>
SOME
"x"
end
,
rec
:
"push"
"n"
:
=
match
:
"put"
"n"
with
NONE
=>
#()
|
SOME
"n"
=>
let
:
"r'"
:
=
!
"r"
in
let
:
"r''"
:
=
SOME
(
"n"
,
"r'"
)
in
if
:
CAS
"r"
"r'"
"r''"
then
#()
else
"push"
"n"
end
).
Definition
channelR
:
=
exclR
unitR
.
Class
channelG
Σ
:
=
{
channel_inG
:
>
inG
Σ
channelR
}.
Definition
channel
Σ
:
gFunctors
:
=
#[
GFunctor
channelR
].
Instance
subG_channel
Σ
{
Σ
}
:
subG
channel
Σ
Σ
→
channelG
Σ
.
Proof
.
solve_inG
.
Qed
.
Section
side_channel
.
Context
`
{!
heapG
Σ
,
!
channelG
Σ
}.
Implicit
Types
l
:
loc
.
Definition
stages
γ
(
P
:
val
→
iProp
Σ
)
l
v
:
=
((
l
↦
#
0
∗
P
v
)
∨
(
l
↦
#
1
)
∨
(
l
↦
#
2
∗
own
γ
(
Excl
())))%
I
.
Definition
is_offer
γ
(
P
:
val
→
iProp
Σ
)
(
v
:
val
)
:
iProp
Σ
:
=
(
∃
v'
l
,
⌜
v
=
(
v'
,
#
l
)%
V
⌝
∗
∃
ι
,
inv
ι
(
stages
γ
P
l
v'
))%
I
.
Definition
mailbox_inv
(
P
:
val
→
iProp
Σ
)
(
v
:
val
)
:
iProp
Σ
:
=
(
∃
l
,
⌜
v
=
#
l
⌝
∗
(
l
↦
NONEV
∨
(
∃
v'
γ
,
l
↦
SOMEV
v'
∗
is_offer
γ
P
v'
)))%
I
.
(* A partial specification for revoke that will be useful later *)
Lemma
revoke_works
N
γ
P
l
v
:
inv
N
(
stages
γ
P
l
v
)
∗
own
γ
(
Excl
())
-
∗
WP
revoke_offer
(
v
,
#
l
)
{{
v'
,
(
∃
v''
:
val
,
⌜
v'
=
InjRV
v''
⌝
∗
P
v''
)
∨
⌜
v'
=
InjLV
#()
⌝
}}.
Proof
.
iIntros
"[#Hinv Hγ]"
.
wp_let
.
wp_proj
.
wp_bind
(
CAS
_
_
_
).
iInv
N
as
"Hstages"
"Hclose"
.
iDestruct
"Hstages"
as
"[H | [H | H]]"
.
-
iDestruct
"H"
as
"[Hl HP]"
.
wp_cas_suc
.
iMod
(
"Hclose"
with
"[Hl Hγ]"
).
iRight
;
iRight
;
iFrame
.
iModIntro
.
wp_if
.
wp_proj
.
iLeft
.
iExists
v
;
iSplit
;
auto
.
-
wp_cas_fail
.
iMod
(
"Hclose"
with
"[H]"
).
iRight
;
iLeft
;
auto
.
iModIntro
.
wp_if
.
iRight
;
auto
.
-
iDestruct
"H"
as
"[Hl H]"
.
wp_cas_fail
.
by
iDestruct
(
own_valid_2
with
"H Hγ"
)
as
%?.
Qed
.
(* A partial specification for take that will be useful later *)
Lemma
take_works
γ
N
P
v
l
:
inv
N
(
stages
γ
P
l
v
)
-
∗
WP
take_offer
(
v
,
LitV
l
)%
V
{{
v'
,
(
∃
v''
:
val
,
⌜
v'
=
InjRV
v''
⌝
∗
P
v''
)
∨
⌜
v'
=
InjLV
#()
⌝
}}.
Proof
.
iIntros
"#Hinv"
.
wp_lam
.
wp_proj
.
wp_bind
(
CAS
_
_
_
).
iInv
N
as
"Hstages"
"Hclose"
.
iDestruct
"Hstages"
as
"[H | [H | H]]"
.
-
iDestruct
"H"
as
"[H HP]"
.
wp_cas_suc
.
iMod
(
"Hclose"
with
"[H]"
).
iRight
;
iLeft
;
done
.
iModIntro
.
wp_if
.
wp_proj
.
iLeft
.
auto
.
-
wp_cas_fail
.
iMod
(
"Hclose"
with
"[H]"
).
iRight
;
iLeft
;
done
.
iModIntro
.
wp_if
.
auto
.
-
iDestruct
"H"
as
"[Hl Hγ]"
.
wp_cas_fail
.
iMod
(
"Hclose"
with
"[Hl Hγ]"
).
iRight
;
iRight
;
iFrame
.
iModIntro
.
wp_if
.
auto
.
Qed
.
End
side_channel
.
Section
mailbox
.
Context
`
{!
heapG
Σ
}.
Implicit
Types
l
:
loc
.
Theorem
mailbox_works
{
channelG0
:
channelG
Σ
}
(
P
:
val
→
iProp
Σ
)
(
Φ
:
val
→
iProp
Σ
)
:
(
∀
(
v
₁
v
₂
:
val
),
⌜
Closed
[]
v
₁⌝
∗
⌜
Closed
[]
v
₂⌝
∗
(
∀
(
v
:
val
),
□
(
P
v
-
∗
WP
v
₁
v
{{
v'
,
(
∃
v''
,
⌜
v'
=
SOMEV
v''
⌝
∗
P
v''
)
∨
⌜
v'
=
NONEV
⌝
}}))
∗
(
□
(
WP
v
₂
#()
{{
v'
,
(
∃
v''
,
⌜
v'
=
SOMEV
v''
⌝
∗
P
v''
)
∨
⌜
v'
=
NONEV
⌝
}}))
-
∗
Φ
(
v
₁
,
v
₂
)%
V
)
-
∗
WP
mailbox
#()
{{
Φ
}}.
Proof
.
iIntros
"HΦ"
.
pose
proof
(
nroot
.@
"N"
)
as
N
.
rewrite
-
wp_fupd
.
wp_lam
.
wp_alloc
l
as
"Hl"
.
wp_let
.
iMod
(
inv_alloc
N
_
(
mailbox_inv
P
#
l
)
with
"[Hl]"
)
as
"#Hinv"
.
iExists
l
;
iSplit
;
try
iLeft
;
auto
.
iModIntro
.
iApply
"HΦ"
;
repeat
iSplit
;
try
(
iPureIntro
;
apply
_
).
*
iIntros
(
v
)
"!# HP"
.
wp_rec
.
wp_bind
(
mk_offer
v
).
pose
proof
(
nroot
.@
"N'"
)
as
N'
.
rewrite
-
wp_fupd
.
wp_lam
.
iMod
(
own_alloc
(
Excl
()))
as
(
γ
)
"Hγ"
.
done
.
wp_alloc
l'
as
"Hl'"
.
iMod
(
inv_alloc
N'
_
(
stages
γ
P
l'
v
)
with
"[HP Hl']"
)
as
"#Hinv'"
.
iLeft
;
iFrame
.
iModIntro
.
wp_let
.
wp_bind
(#
l
<-
_
)%
E
.
iInv
N
as
"Hmailbox"
"Hclose"
.
iDestruct
"Hmailbox"
as
(
l''
)
"[>% H]"
.
injection
H
;
intros
;
subst
.
iDestruct
"H"
as
"[H | H]"
;
[
idtac
|
iDestruct
"H"
as
(
v'
γ
'
)
"[Hl H]"
]
;
wp_store
;
[
iMod
(
"Hclose"
with
"[H]"
)
|
iMod
(
"Hclose"
with
"[Hl H]"
)]
;
try
(
iExists
l''
;
iSplit
;
try
iRight
;
auto
;
iExists
(
v
,
#
l'
)%
V
,
γ
;
iFrame
;
iExists
v
,
l'
;
auto
)
;
iModIntro
;
wp_let
;
iApply
(
revoke_works
with
"[Hγ Hinv]"
)
;
auto
.
*
iIntros
"!#"
.
wp_rec
.
wp_bind
(!
_
)%
E
.
iInv
N
as
"Hmailbox"
"Hclose"
.
iDestruct
"Hmailbox"
as
(
l'
)
"[>% H]"
.
injection
H
;
intros
;
subst
.
iDestruct
"H"
as
"[H | H]"
.
+
wp_load
.
iMod
(
"Hclose"
with
"[H]"
).
iExists
l'
;
iSplit
;
auto
.
iModIntro
.
wp_let
.
wp_match
.
iRight
;
auto
.
+
iDestruct
"H"
as
(
v'
γ
)
"[Hl' #Hoffer]"
.
wp_load
.
iMod
(
"Hclose"
with
"[Hl' Hoffer]"
).
{
iExists
l'
;
iSplit
;
auto
.
iRight
;
iExists
v'
,
γ
;
by
iSplit
.
}
iModIntro
.
wp_let
.
wp_match
.
iDestruct
"Hoffer"
as
(
v''
l''
)
"[% Hoffer]"
.
iDestruct
"Hoffer"
as
(
ι
)
"Hinv'"
.
subst
.
iApply
take_works
;
auto
.
Qed
.
End
mailbox
.
Section
stack_works
.
Context
`
{!
heapG
Σ
}.
Implicit
Types
l
:
loc
.
Definition
is_stack_pre
(
P
:
val
→
iProp
Σ
)
(
F
:
val
-
c
>
iProp
Σ
)
:
val
-
c
>
iProp
Σ
:
=
λ
v
,
(
v
≡
NONEV
∨
∃
(
h
t
:
val
),
v
≡
SOMEV
(
h
,
t
)%
V
∗
P
h
∗
▷
F
t
)%
I
.
Local
Instance
is_stack_contr
(
P
:
val
→
iProp
Σ
)
:
Contractive
(
is_stack_pre
P
).
Proof
.
rewrite
/
is_stack_pre
=>
n
f
f'
Hf
v
.
repeat
(
f_contractive
||
f_equiv
).
apply
Hf
.
Qed
.
Definition
is_stack_def
(
P
:
val
->
iProp
Σ
)
:
=
fixpoint
(
is_stack_pre
P
).
Definition
is_stack_aux
P
:
seal
(@
is_stack_def
P
).
by
eexists
.
Qed
.
Definition
is_stack
P
:
=
unseal
(
is_stack_aux
P
).
Definition
is_stack_eq
P
:
@
is_stack
P
=
@
is_stack_def
P
:
=
seal_eq
(
is_stack_aux
P
).
Definition
stack_inv
P
v
:
=
(
∃
l
v'
,
⌜
v
=
#
l
⌝
∗
l
↦
v'
∗
is_stack
P
v'
)%
I
.
Lemma
is_stack_unfold
(
P
:
val
→
iProp
Σ
)
v
:
is_stack
P
v
⊣
⊢
is_stack_pre
P
(
is_stack
P
)
v
.
Proof
.
rewrite
is_stack_eq
.
apply
(
fixpoint_unfold
(
is_stack_pre
P
)).
Qed
.
Lemma
is_stack_disj
(
P
:
val
→
iProp
Σ
)
v
:
is_stack
P
v
-
∗
is_stack
P
v
∗
(
v
≡
NONEV
∨
∃
(
h
t
:
val
),
v
≡
SOMEV
(
h
,
t
)%
V
).
Proof
.
iIntros
"Hstack"
.
iDestruct
(
is_stack_unfold
with
"Hstack"
)
as
"[#Hstack|Hstack]"
.
-
iSplit
;
try
iApply
is_stack_unfold
;
iLeft
;
auto
.
-
iDestruct
"Hstack"
as
(
h
t
)
"[#Heq rest]"
.
iSplitL
;
try
iApply
is_stack_unfold
;
iRight
;
auto
.
Qed
.
Theorem
stack_works
{
channelG0
:
channelG
Σ
}
P
Φ
:
(
∀
(
f
₁
f
₂
:
val
),
(
□
WP
f
₁
#()
{{
v
,
(
∃
(
v'
:
val
),
v
≡
SOMEV
v'
∗
P
v'
)
∨
v
≡
NONEV
}})
-
∗
(
∀
(
v
:
val
),
□
(
P
v
-
∗
WP
f
₂
v
{{
v
,
True
}}))
-
∗
Φ
(
f
₁
,
f
₂
)%
V
)%
I
-
∗
WP
mk_stack
#()
{{
Φ
}}.
Proof
.
iIntros
"HΦ"
.
wp_lam
.
wp_bind
(
mailbox
_
).
iApply
(
mailbox_works
P
).
iIntros
(
put
get
)
"[% [% [#Hput #Hget]]]"
.
wp_let
;
wp_proj
;
wp_let
;
wp_proj
;
wp_let
;
wp_alloc
l'
as
"Hl'"
.
pose
proof
(
nroot
.@
"N"
)
as
N
.
iMod
(
inv_alloc
N
_
(
stack_inv
P
#
l'
)
with
"[Hl']"
)
as
"#Hisstack"
.
{
iExists
l'
,
NONEV
;
iFrame
;
iSplit
;
auto
.
iApply
is_stack_unfold
;
iLeft
;
done
.
}
wp_let
.
iApply
"HΦ"
.
(* The verification of pop *)
-
iIntros
"!#"
.
iL
ö
b
as
"IH"
.
wp_rec
;
wp_bind
(
get
_
).
(* Switch from proving WP put #() {{ P }} to
* Q -∗ P where Q is the spec we have already assumed for P
*)
iApply
wp_wand
;
auto
.
iIntros
(
v
)
"Hv"
.
iDestruct
"Hv"
as
"[H | H]"
.
*
iDestruct
"H"
as
(
v'
)
"[% HP]"
.
subst
.
(* This is just some technical fidgetting to get wp_match to behave.
* It is safe to ignore
*)
assert
(
to_val
v'
=
Some
v'
)
by
apply
to_of_val
.
assert
(
is_Some
(
to_val
v'
))
by
(
exists
v'
;
auto
).
assert
(
to_val
(
InjRV
v'
)
=
Some
(
InjRV
v'
))
by
apply
to_of_val
.
assert
(
is_Some
(
to_val
(
InjRV
v'
)))
by
(
exists
(
InjRV
v'
)
;
auto
).
wp_match
.
iLeft
;
iExists
v'
;
auto
.
*
iDestruct
"H"
as
"%"
;
subst
.
wp_match
;
wp_bind
(!
#
l'
)%
E
.
iInv
N
as
"Hstack"
"Hclose"
.
iDestruct
"Hstack"
as
(
l''
v''
)
"[>% [Hl' Hstack]]"
.
injection
H1
;
intros
;
subst
.
wp_load
.
iDestruct
(
is_stack_disj
with
"Hstack"
)
as
"[Hstack #Heq]"
.
iMod
(
"Hclose"
with
"[Hl' Hstack]"
).
{
iExists
l''
,
v''
;
iFrame
;
auto
.
}
iModIntro
.
iDestruct
"Heq"
as
"[H | H]"
.
+
iRewrite
"H"
;
wp_match
;
iRight
;
auto
.
+
iDestruct
"H"
as
(
h
t
)
"H"
;
iRewrite
"H"
.
(* For technical reasons, wp_match gets confused by this
* position. Hence the assertions. They can be safely ignored
*)
assert
(
to_val
(
h
,
t
)%
V
=
Some
(
h
,
t
)%
V
)
by
apply
to_of_val
.
assert
(
is_Some
(
to_val
(
h
,
t
)%
V
))
by
(
exists
(
h
,
t
)%
V
;
auto
).
wp_match
.
fold
of_val
.
(* Now back to our regularly scheduled verification *)
wp_bind
(
CAS
_
_
_
)
;
wp_proj
.
iInv
N
as
"Hstack"
"Hclose"
.
iDestruct
"Hstack"
as
(
l'''
v'''
)
"[>% [Hl'' Hstack]]"
.
injection
H4
;
intros
;
subst
.
(* Case on whether or not the stack has been updated *)
destruct
(
decide
(
v'''
=
InjRV
(
h
,
t
)%
V
)).
++
(* If nothing has changed, the cas succeeds *)
wp_cas_suc
.
iDestruct
(
is_stack_unfold
with
"Hstack"
)
as
"[Hstack | Hstack]"
.
subst
.
iDestruct
"Hstack"
as
"%"
;
discriminate
.
iDestruct
"Hstack"
as
(
h'
t'
)
"[% [HP Hstack]]"
.
subst
.
injection
H5
.
intros
.
subst
.
iMod
(
"Hclose"
with
"[Hl'' Hstack]"
).
{
iExists
l'''
,
t'
;
iFrame
;
auto
.
}
iModIntro
.
wp_if
;
wp_proj
;
iLeft
;
auto
.
++
(* The case in which we fail *)
wp_cas_fail
.
iMod
(
"Hclose"
with
"[Hl'' Hstack]"
).
iExists
l'''
,
v'''
;
iFrame
;
auto
.
iModIntro
.
wp_if
.
(* Now we use our IH to loop *)
iApply
"IH"
.
(* The verification of push. This is actually markedly simpler. *)
-
iIntros
(
v
)
"!# HP"
.
simpl
in
*.
fold
of_val
in
*.
(* We grab an IH to be used in the case that we loop *)
iL
ö
b
as
"IH"
forall
(
v
).
wp_rec
.
wp_bind
(
put
_
).