Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
Iris
examples
Commits
5fc8c715
Commit
5fc8c715
authored
Jan 12, 2018
by
Aleš Bizjak
4
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
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
Showing
5 changed files
with
1364 additions
and
0 deletions
+1364
-0
README.md
README.md
+2
-0
theories/concurrent_stacks/concurrent_stack1.v
theories/concurrent_stacks/concurrent_stack1.v
+176
-0
theories/concurrent_stacks/concurrent_stack2.v
theories/concurrent_stacks/concurrent_stack2.v
+402
-0
theories/concurrent_stacks/concurrent_stack3.v
theories/concurrent_stacks/concurrent_stack3.v
+196
-0
theories/concurrent_stacks/concurrent_stack4.v
theories/concurrent_stacks/concurrent_stack4.v
+588
-0
No files found.
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
_
).
(* Switch from proving WP put #() {{ P }} to
* Q -∗ P where Q is the spec we have already assumed for put