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
445187e9
Commit
445187e9
authored
Sep 12, 2016
by
Zhen Zhang
Browse files
better proofs
parent
caa4beab
Changes
1
Hide whitespace changes
Inline
Side-by-side
treiber_stack.v
View file @
445187e9
...
...
@@ -5,12 +5,12 @@ From iris.heap_lang Require Import proofmode notation.
From
iris
.
algebra
Require
Import
upred
upred_big_op
.
From
iris
.
tests
Require
Import
atomic
.
Definition
new_stack
:
val
:
=
λ
:
<>,
ref
NONE
.
Definition
new_stack
:
val
:
=
λ
:
<>,
ref
(
ref
NONE
)
.
Definition
push
:
val
:
=
rec
:
"push"
"s"
"x"
:
=
let
:
"hd"
:
=
!
"s"
in
let
:
"s'"
:
=
SOME
(
"x"
,
ref
"hd"
)
in
let
:
"s'"
:
=
ref
SOME
(
"x"
,
"hd"
)
in
if
:
CAS
"s"
"hd"
"s'"
then
#()
else
"push"
"s"
"x"
.
...
...
@@ -18,7 +18,7 @@ Definition push: val :=
Definition
pop
:
val
:
=
rec
:
"pop"
"s"
:
=
let
:
"hd"
:
=
!
"s"
in
match
:
"hd"
with
match
:
!
"hd"
with
SOME
"pair"
=>
if
:
CAS
"s"
"hd"
(
Snd
"pair"
)
then
SOME
(
Fst
"pair"
)
...
...
@@ -29,42 +29,30 @@ Definition pop: val :=
Section
proof
.
Context
`
{!
heapG
Σ
}
(
N
:
namespace
)
(
R
:
val
→
iProp
Σ
)
`
{
∀
v
,
TimelessP
(
R
v
)}.
Fixpoint
is_stack
(
s
:
loc
)
(
xs
:
list
val
)
:
iProp
Σ
:
=
Fixpoint
is_stack
'
(
hd
:
loc
)
(
xs
:
list
val
)
:
iProp
Σ
:
=
match
xs
with
|
[]
=>
(
s
↦
NONEV
)%
I
|
x
::
xs
=>
(
∃
s
'
:
loc
,
s
↦
SOMEV
(
x
,
#
s
'
)
★
R
x
★
is_stack
s
'
xs
)%
I
|
[]
=>
(
∃
q
,
hd
↦
{
q
}
NONEV
)%
I
|
x
::
xs
=>
(
∃
(
hd
'
:
loc
)
q
,
hd
↦
{
q
}
SOMEV
(
x
,
#
hd
'
)
★
□
R
x
★
is_stack
'
hd
'
xs
)%
I
end
.
Definition
is_
some_
stack
(
s
:
loc
)
:
iProp
Σ
:
=
(
∃
xs
:
l
ist
val
,
is_stack
s
xs
)%
I
.
Definition
is_stack
(
s
:
loc
)
xs
:
iProp
Σ
:
=
(
∃
hd
:
l
oc
,
s
↦
#
hd
★
is_stack
'
hd
xs
)%
I
.
Definition
stack_inv
s
:
iProp
Σ
:
=
inv
N
(
is_some_stack
s
).
Instance
stack_inv_persistent
s
:
PersistentP
(
stack_inv
s
).
Proof
.
apply
_
.
Qed
.
Instance
is_stack_timeless
:
∀
xs
s
,
TimelessP
(
is_stack
s
xs
).
Proof
.
induction
xs
as
[|?
xs'
].
-
apply
_
.
-
simpl
.
intros
s
.
apply
uPred
.
exist_timeless
.
intros
s'
.
specialize
IHxs'
with
s'
.
apply
_
.
Qed
.
Instance
is_some_stack_timeless
:
∀
s
,
TimelessP
(
is_some_stack
s
).
Proof
.
intros
s
.
rewrite
/
is_some_stack
.
apply
uPred
.
exist_timeless
.
intros
?.
apply
is_stack_timeless
.
Qed
.
Definition
is_some_stack
(
s
:
loc
)
:
iProp
Σ
:
=
(
∃
xs
,
is_stack
s
xs
)%
I
.
Lemma
new_stack_spec
:
∀
(
Φ
:
val
→
iProp
Σ
),
heapN
⊥
N
→
heap_ctx
★
(
∀
s
,
is_stack
s
[]
-
★
Φ
#
s
)
⊢
WP
new_stack
#()
{{
Φ
}}.
Proof
.
iIntros
(
Φ
HN
)
"[#Hh HΦ]"
.
wp_seq
.
wp_alloc
l
as
"Hl"
.
by
iApply
"HΦ"
.
Qed
.
Proof
.
iIntros
(
Φ
HN
)
"[#Hh HΦ]"
.
wp_seq
.
wp_bind
(
ref
NONE
)%
E
.
wp_alloc
l
as
"Hl"
.
wp_alloc
l'
as
"Hl'"
.
iApply
"HΦ"
.
rewrite
/
is_stack
.
iExists
l
.
iFrame
.
by
iExists
1
%
Qp
.
Qed
.
Definition
push_triple
(
s
:
loc
)
(
x
:
val
)
:
=
atomic_triple
(
fun
xs
=>
R
x
★
is_stack
s
xs
)%
I
atomic_triple
(
fun
xs
=>
□
R
x
★
is_stack
s
xs
)%
I
(
fun
xs
_
=>
is_stack
s
(
x
::
xs
))
(
nclose
heapN
)
⊤
...
...
@@ -73,56 +61,71 @@ Section proof.
Lemma
push_atomic_spec
(
s
:
loc
)
(
x
:
val
)
:
heapN
⊥
N
→
heap_ctx
⊢
push_triple
s
x
.
Proof
.
iIntros
(
HN
)
"#?"
.
rewrite
/
push_triple
/
atomic_triple
.
iIntros
(
HN
)
"#?"
.
rewrite
/
push_triple
/
atomic_triple
.
iIntros
(
P
Q
)
"#Hvs"
.
iL
ö
b
as
"IH"
.
iIntros
"!# HP"
.
wp_rec
.
wp_let
.
wp_bind
(!
_
)%
E
.
iVs
(
"Hvs"
with
"HP"
)
as
(
xs
)
"[[Hx Hxs] [Hvs' _]]"
.
destruct
xs
as
[|
y
xs'
].
-
simpl
.
wp_load
.
iVs
(
"Hvs'"
with
"[Hx Hxs]"
)
as
"HP"
;
first
by
iFrame
.
iVsIntro
.
wp_let
.
wp_alloc
l
as
"Hl"
.
wp_let
.
wp_bind
(
CAS
_
_
_
)%
E
.
iVs
(
"Hvs"
with
"HP"
)
as
(
xs
)
"[[Hx Hxs] Hvs']"
.
destruct
xs
as
[|
y
xs'
].
+
simpl
.
wp_cas_suc
.
iDestruct
"Hvs'"
as
"[_ Hvs']"
.
iVs
(
"Hvs'"
$!
#()
with
"[Hl Hx Hxs]"
)
as
"HQ"
.
{
iExists
l
.
by
iFrame
.
}
iVsIntro
.
wp_if
.
iVsIntro
.
eauto
.
+
simpl
.
iDestruct
"Hxs"
as
(
s'
)
"(Hs & Hy & Hs')"
.
wp_cas_fail
.
iDestruct
"Hvs'"
as
"[Hvs' _]"
.
iVs
(
"Hvs'"
with
"[Hx Hs Hy Hs']"
).
{
iFrame
.
iExists
s'
.
by
iFrame
.
}
iVsIntro
.
wp_if
.
by
iApply
"IH"
.
-
simpl
.
iDestruct
"Hxs"
as
(
s'
)
"(Hs & Hy & Hs')"
.
wp_load
.
iVs
(
"Hvs'"
with
"[Hx Hs Hy Hs']"
)
as
"HP"
.
{
iFrame
.
iExists
s'
.
by
iFrame
.
}
iVsIntro
.
wp_let
.
wp_alloc
l
as
"Hl"
.
wp_let
.
wp_bind
(
CAS
_
_
_
)%
E
.
iVs
(
"Hvs"
with
"HP"
)
as
(
xs
)
"[[Hx Hxs] Hvs']"
.
destruct
xs
as
[|
y'
xs''
].
+
simpl
.
wp_cas_fail
.
iDestruct
"Hvs'"
as
"[Hvs' _]"
.
iVs
(
"Hvs'"
with
"[Hx Hxs]"
)
;
first
by
iFrame
.
iVsIntro
.
wp_if
.
by
iApply
"IH"
.
+
simpl
.
iDestruct
"Hxs"
as
(
s''
)
"(Hs & Hy' & Hs'')"
.
destruct
(
decide
(
s'
=
s''
∧
y
=
y'
))
as
[[]|
Hneq
].
*
subst
.
wp_cas_suc
.
iDestruct
"Hvs'"
as
"[_ Hvs']"
.
iVs
(
"Hvs'"
$!
#()
with
"[Hs Hx Hl Hy' Hs'']"
)
as
"HQ"
.
{
iExists
l
.
iFrame
.
iExists
s''
.
by
iFrame
.
}
iVsIntro
.
wp_if
.
iVsIntro
.
eauto
.
*
wp_cas_fail
.
{
intros
Heq
.
apply
Hneq
.
by
inversion
Heq
.
}
iDestruct
"Hvs'"
as
"[Hvs' _]"
.
iVs
(
"Hvs'"
with
"[Hx Hs Hy' Hs'']"
).
{
iFrame
.
iExists
s''
.
by
iFrame
.
}
iVsIntro
.
wp_if
.
by
iApply
"IH"
.
simpl
.
iDestruct
"Hxs"
as
(
hd
)
"[Hs Hhd]"
.
wp_load
.
iVs
(
"Hvs'"
with
"[Hx Hs Hhd]"
)
as
"HP"
.
{
rewrite
/
is_stack
.
iFrame
.
iExists
hd
.
by
iFrame
.
}
iVsIntro
.
wp_let
.
wp_alloc
l
as
"Hl"
.
wp_let
.
wp_bind
(
CAS
_
_
_
)%
E
.
iVs
(
"Hvs"
with
"HP"
)
as
(
xs'
)
"[[Hx Hxs] Hvs']"
.
simpl
.
iDestruct
"Hxs"
as
(
hd'
)
"[Hs Hhd']"
.
destruct
(
decide
(
hd
=
hd'
))
as
[->|
Hneq
].
*
wp_cas_suc
.
iDestruct
"Hvs'"
as
"[_ Hvs']"
.
iVs
(
"Hvs'"
$!
#()
with
"[-]"
)
as
"HQ"
.
{
iExists
l
.
iFrame
.
iExists
hd'
,
1
%
Qp
.
by
iFrame
.
}
iVsIntro
.
wp_if
.
iVsIntro
.
eauto
.
*
wp_cas_fail
.
iDestruct
"Hvs'"
as
"[Hvs' _]"
.
iVs
(
"Hvs'"
with
"[-]"
)
as
"HP"
.
{
iFrame
.
iExists
hd'
.
by
iFrame
.
}
iVsIntro
.
wp_if
.
by
iApply
"IH"
.
Qed
.
Definition
pop_triple
(
s
:
loc
)
:
=
atomic_triple
(
fun
xs
=>
is_stack
s
xs
)%
I
(
fun
xs
ret
=>
ret
=
NONEV
∨
(
∃
x
,
ret
=
SOMEV
x
★
□
R
x
))%
I
(* FIXME: we can give a stronger one *)
(
nclose
heapN
)
⊤
(
pop
#
s
).
Lemma
pop_atomic_spec
(
s
:
loc
)
(
x
:
val
)
:
heapN
⊥
N
→
heap_ctx
⊢
pop_triple
s
.
Proof
.
iIntros
(
HN
)
"#?"
.
rewrite
/
pop_triple
/
atomic_triple
.
iIntros
(
P
Q
)
"#Hvs"
.
iL
ö
b
as
"IH"
.
iIntros
"!# HP"
.
wp_rec
.
wp_bind
(!
_
)%
E
.
iVs
(
"Hvs"
with
"HP"
)
as
(
xs
)
"[Hxs Hvs']"
.
destruct
xs
as
[|
y'
xs'
].
-
simpl
.
iDestruct
"Hxs"
as
(
hd
)
"[Hs Hhd]"
.
wp_load
.
iDestruct
"Hvs'"
as
"[_ Hvs']"
.
iVs
(
"Hvs'"
$!
NONEV
with
"[]"
)
as
"HQ"
;
first
by
iLeft
.
iVsIntro
.
wp_let
.
iDestruct
"Hhd"
as
(
q
)
"Hhd"
.
wp_load
.
wp_match
.
iVsIntro
.
by
iExists
[].
-
simpl
.
iDestruct
"Hxs"
as
(
hd
)
"[Hs Hhd]"
.
simpl
.
iDestruct
"Hhd"
as
(
hd'
q
)
"([Hhd Hhd'] & #Hy' & Hxs')"
.
wp_load
.
iDestruct
"Hvs'"
as
"[Hvs' _]"
.
iVs
(
"Hvs'"
with
"[-Hhd]"
)
as
"HP"
.
{
iExists
hd
.
iFrame
.
iExists
hd'
,
(
q
/
2
)%
Qp
.
by
iFrame
.
}
iVsIntro
.
wp_let
.
wp_load
.
wp_match
.
wp_proj
.
wp_bind
(
CAS
_
_
_
).
iVs
(
"Hvs"
with
"HP"
)
as
(
xs
)
"[Hxs Hvs']"
.
iDestruct
"Hxs"
as
(
hd''
)
"[Hs Hhd'']"
.
destruct
(
decide
(
hd
=
hd''
))
as
[->|
Hneq
].
+
wp_cas_suc
.
iDestruct
"Hvs'"
as
"[_ Hvs']"
.
iVs
(
"Hvs'"
$!
(
SOMEV
y'
)
with
"[]"
)
as
"HQ"
.
{
iRight
.
eauto
.
}
iVsIntro
.
wp_if
.
wp_proj
.
eauto
.
+
wp_cas_fail
.
iDestruct
"Hvs'"
as
"[Hvs' _]"
.
iVs
(
"Hvs'"
with
"[-]"
)
as
"HP"
.
{
iExists
hd''
.
by
iFrame
.
}
iVsIntro
.
wp_if
.
by
iApply
"IH"
.
Qed
.
End
proof
.
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment