Skip to content
GitLab
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
ff2265d8
Commit
ff2265d8
authored
Sep 06, 2016
by
Zhen Zhang
Browse files
srv
parent
6c6a1f19
Changes
2
Hide whitespace changes
Inline
Side-by-side
srv.v
View file @
ff2265d8
...
...
@@ -15,10 +15,12 @@ Definition srv : val :=
Definition
wait
:
val
:
=
rec
:
"wait"
"p"
:
=
match
:
!
"p"
with
InjR
"r"
=>
"p"
<-
#
0
;;
"r"
InjR
"r"
=>
"p"
<-
InjR
#
0
;;
"r"
|
InjL
"_"
=>
"wait"
"p"
end
.
Local
Opaque
wait
.
Definition
mk_srv
:
val
:
=
λ
:
"f"
,
let
:
"p"
:
=
ref
(
InjR
#
0
)%
V
in
...
...
@@ -26,7 +28,7 @@ Definition mk_srv : val :=
Fork
(
srv
"f"
"p"
)
;;
λ
:
"x"
,
acquire
"l"
;;
"p"
<-
InjL
"x"
;;
"p"
<-
InjL
"x"
;;
let
:
"ret"
:
=
wait
"p"
in
release
"l"
;;
"ret"
.
...
...
@@ -57,15 +59,62 @@ Section proof.
Context
`
{!
heapG
Σ
,
!
lockG
Σ
,
!
srvG
Σ
}
(
N
:
namespace
).
Definition
srv_inv
(
γ
:
gname
)
(
p
:
loc
)
(
γ
x
γ
1
γ
2
:
gname
)
(
p
:
loc
)
(
Q
:
val
→
val
→
Prop
)
:
iProp
Σ
:
=
((
∃
x
:
val
,
p
↦
InjRV
x
)
∨
(
∃
(
x
:
val
)
(
γ
2
:
gname
),
p
↦
InjLV
x
★
own
γ
((
1
/
2
)%
Qp
,
DecAgree
x
)
★
own
γ
2
(
Excl
()))
∨
(
∃
(
x
y
:
val
)
(
γ
2
:
gname
),
p
↦
InjRV
y
★
own
γ
((
1
/
2
)%
Qp
,
DecAgree
x
)
★
■
Q
x
y
★
own
γ
2
(
Excl
())))%
I
.
Lemma
srv_inv_timeless
γ
p
Q
:
TimelessP
(
srv_inv
γ
p
Q
).
Proof
.
apply
_
.
Qed
.
((
∃
(
x
:
val
),
p
↦
InjRV
x
★
own
γ
1
(
Excl
()))
∨
(
∃
(
x
:
val
),
p
↦
InjLV
x
★
own
γ
x
((
1
/
2
)%
Qp
,
DecAgree
x
)
★
own
γ
2
(
Excl
()))
∨
(
∃
(
x
y
:
val
),
p
↦
InjRV
y
★
own
γ
x
((
1
/
2
)%
Qp
,
DecAgree
x
)
★
■
Q
x
y
★
own
γ
2
(
Excl
())))%
I
.
Lemma
srv_inv_timeless
γ
x
γ
1
γ
2
p
Q
:
TimelessP
(
srv_inv
γ
x
γ
1
γ
2
p
Q
).
Proof
.
apply
_
.
Qed
.
Lemma
wait_spec
(
Φ
:
val
→
iProp
Σ
)
(
Q
:
val
→
val
→
Prop
)
x
γ
x
γ
1
γ
2
p
:
heapN
⊥
N
→
heap_ctx
★
inv
N
(
srv_inv
γ
x
γ
1
γ
2
p
Q
)
★
own
γ
x
((
1
/
2
)%
Qp
,
DecAgree
x
)
★
own
γ
1
(
Excl
())
★
(
∀
y
,
own
γ
2
(
Excl
())
-
★
own
γ
x
(
1
%
Qp
,
DecAgree
x
)
-
★
■
Q
x
y
-
★
Φ
y
)
⊢
WP
wait
#
p
{{
Φ
}}.
Proof
.
iIntros
(
HN
)
"(#Hh & #Hsrv & Hx & Hempty & HΦ)"
.
iL
ö
b
as
"IH"
.
wp_rec
.
wp_bind
(!
#
p
)%
E
.
iInv
N
as
">[Hinv|[Hinv|Hinv]]"
"Hclose"
.
+
(* collision with Hempty *)
admit
.
+
(* not finished *)
iDestruct
"Hinv"
as
(
x'
)
"(Hp & Hx' & Hissued)"
.
wp_load
.
iVs
(
"Hclose"
with
"[Hp Hx' Hissued]"
).
{
iNext
.
iRight
.
iLeft
.
iExists
x'
.
by
iFrame
.
}
iVsIntro
.
wp_match
.
by
iApply
(
"IH"
with
"Hx Hempty"
).
+
(* finished *)
iDestruct
"Hinv"
as
(
x'
y
)
"(Hp & Hx' & % & Hissued)"
.
(* assert (x = x'). *)
(* { admit. (* should use the properties of agreement monoid to fix this *) } *)
wp_load
.
iVs
(
"Hclose"
with
"[Hp Hx' Hissued]"
).
{
iNext
.
iRight
.
iRight
.
iExists
x'
,
y
.
by
iFrame
.
}
iVsIntro
.
wp_match
.
wp_bind
(
_
<-
_
)%
E
.
iInv
N
as
">[Hinv|[Hinv|Hinv]]"
"Hclose"
.
-
(* colission *)
admit
.
-
(* impossible ... this is why irreversibility is important *)
admit
.
-
iDestruct
"Hinv"
as
(
x''
y'
)
"(Hp & Hx' & % & Hissued)"
.
assert
(
x
=
x''
).
{
admit
.
(* should use the properties of agreement monoid to fix this *)
}
subst
.
wp_store
.
iVs
(
"Hclose"
with
"[Hp Hempty]"
).
{
iNext
.
iLeft
.
iExists
#
0
.
by
iFrame
.
}
iVsIntro
.
wp_seq
.
assert
(
y
=
y'
).
{
admit
.
(* exclusivity *)
}
subst
.
iClear
"Hx"
.
iClear
"Hx'"
.
iAssert
(
own
γ
x
(
1
%
Qp
,
DecAgree
x''
))
as
"Hx"
.
{
admit
.
}
iSpecialize
(
"HΦ"
$!
y'
with
"Hissued Hx"
).
by
iApply
"HΦ"
.
Admitted
.
Lemma
mk_srv_spec
(
f
:
val
)
Q
:
heapN
⊥
N
→
heap_ctx
★
□
(
∀
x
:
val
,
WP
f
x
{{
v
,
■
Q
x
v
}})
...
...
@@ -73,39 +122,52 @@ Section proof.
Proof
.
iIntros
(
HN
)
"[#Hh #Hf]"
.
wp_let
.
wp_alloc
p
as
"Hp"
.
iVs
(
own_alloc
(
Excl
()))
as
(
γ
1
)
"Hγ1"
;
first
done
.
iVs
(
own_alloc
(
1
%
Qp
,
DecAgree
#
0
))
as
(
γ
2
)
"Hγ2"
;
first
done
.
iVs
(
inv_alloc
N
_
(
srv_inv
γ
1
γ
2
p
Q
)
with
"[Hp Hγ1]"
)
as
"#?"
.
iVs
(
own_alloc
(
Excl
()))
as
(
γ
1
)
"Hempty"
;
first
done
.
(* black token *)
iVs
(
own_alloc
(
Excl
()))
as
(
γ
2
)
"Hissued"
;
first
done
.
(* white token *)
iVs
(
own_alloc
(
1
%
Qp
,
DecAgree
#
0
))
as
(
γ
x
)
"Hx"
;
first
done
.
iVs
(
inv_alloc
N
_
(
srv_inv
γ
x
γ
1
γ
2
p
Q
)
with
"[Hp Hempty]"
)
as
"#?"
.
{
iNext
.
rewrite
/
srv_inv
.
iLeft
.
iExists
#
0
.
by
iFrame
.
}
wp_let
.
wp_bind
(
newlock
_
).
iApply
newlock_spec
=>//.
iFrame
"Hh"
.
iAssert
(
∃
x
:
val
,
own
γ
2
(
1
%
Qp
,
DecAgree
x
))%
I
with
"[Hγ2]"
as
"Hinv"
;
first
by
eauto
.
iFrame
"Hinv"
.
iIntros
(
lk
γ
)
"#Hlk"
.
iAssert
(
∃
x
,
own
γ
x
(
1
%
Qp
,
DecAgree
x
)
★
own
γ
2
(
Excl
()))%
I
with
"[Hissued Hx]"
as
"Hinv"
.
{
iExists
#
0
.
by
iFrame
.
}
iFrame
"Hinv"
.
iIntros
(
lk
γ
lk
)
"#Hlk"
.
wp_let
.
wp_apply
wp_fork
.
iSplitL
.
-
(* client closure *)
iVsIntro
.
wp_seq
.
iVsIntro
.
iAlways
.
iIntros
(
x
).
iL
ö
b
as
"IH"
.
wp_r
ec
.
wp_bind
(
acquire
_
).
iApply
acquire_spec
.
iFrame
"Hlk"
.
iIntros
"Hlked Ho"
.
iDestruct
"Ho"
as
(
x'
)
"
Ho
"
.
wp_let
.
wp_bind
(
acquire
_
).
iApply
acquire_sp
ec
.
iFrame
"Hlk"
.
iIntros
"Hlked Ho"
.
iDestruct
"Ho"
as
(
x'
)
"
[Hx Hissued]
"
.
wp_seq
.
wp_bind
(
_
<-
_
)%
E
.
iInv
N
as
">Hinv"
"Hclose"
.
rewrite
/
srv_inv
.
iDestruct
"Hinv"
as
"[Hinv|[Hinv|Hinv]]"
.
+
iDestruct
"Hinv"
as
(
x''
)
"Hp"
.
+
iDestruct
"Hinv"
as
(
x''
)
"
[
Hp
Hempty]
"
.
wp_store
.
iAssert
(
own
γ
2
(
1
%
Qp
,
DecAgree
x'
)
-
★
(
own
γ
2
((
1
/
2
)%
Qp
,
DecAgree
x
)
★
own
γ
2
((
1
/
2
)%
Qp
,
DecAgree
x
)))%
I
as
"Hsplit"
.
iAssert
(
own
γ
x
(
1
%
Qp
,
DecAgree
x'
)
-
★
(
own
γ
x
((
1
/
2
)%
Qp
,
DecAgree
x
)
★
own
γ
x
((
1
/
2
)%
Qp
,
DecAgree
x
)))%
I
as
"Hsplit"
.
{
admit
.
}
iDestruct
(
"Hsplit"
with
"Ho"
)
as
"[Ho1 Ho2]"
.
iVs
(
"Hclose"
with
"[Hlked Hp Ho1]"
).
*
rewrite
/
locked
.
iNext
.
iRight
.
iLeft
.
iExists
x
.
iFrame
.
iDestruct
(
"Hsplit"
with
"Hx"
)
as
"[Hx1 Hx2]"
.
iVs
(
"Hclose"
with
"[Hp Hissued Hx1]"
).
{
rewrite
/
locked
.
iNext
.
iRight
.
iLeft
.
iExists
x
.
by
iFrame
.
}
(* now prove things about wait *)
iVsIntro
.
wp_seq
.
wp_bind
(
wait
_
).
iApply
(
wait_spec
with
"[Hempty Hx2 Hlked]"
)
;
first
by
auto
.
{
iFrame
"Hh"
.
iFrame
"~"
.
iFrame
.
iIntros
(
y
)
"Hempty Hx HQ"
.
wp_let
.
wp_bind
(
release
_
).
iApply
release_spec
.
iFrame
"Hlk Hlked"
.
iSplitL
"Hempty Hx"
.
-
iExists
x
.
by
iFrame
.
-
by
wp_seq
.
}
+
(* Impossible: reenter locked *)
iExFalso
.
admit
.
+
(* Impossible: reenter locked *)
iExFalso
.
admit
.
\ No newline at end of file
iExFalso
.
admit
.
Admitted
.
sync.v
View file @
ff2265d8
...
...
@@ -4,6 +4,8 @@ From iris.heap_lang Require Export lang.
From
iris
.
heap_lang
Require
Import
proofmode
notation
.
From
iris
.
heap_lang
.
lib
Require
Import
spin_lock
.
From
iris
.
tests
Require
Import
atomic
.
From
iris
.
algebra
Require
Import
dec_agree
frac
.
From
iris
.
program_logic
Require
Import
auth
.
Import
uPred
.
(* See CaReSL paper §3.2 *)
...
...
@@ -83,31 +85,36 @@ Section proof.
iFrame
.
by
wp_seq
.
Qed
.
End
proof
.
(* a general way to get atomic triple from mk_styc *)
Definition
atomic_triple'
{
A
:
Type
}
(
ϕ
:
A
→
iProp
Σ
)
(
β
:
A
→
A
→
val
→
iProp
Σ
)
(
Ei
Eo
:
coPset
)
(
e
:
expr
)
:
iProp
Σ
:
=
(
∀
P
Q
,
(
P
={
Eo
,
Ei
}=>
∃
g
g'
,
ϕ
g
★
(
∀
v
,
β
g
g'
v
={
Ei
,
Eo
}=
★
Q
v
)
)
-
★
{{
P
}}
e
@
⊤
{{
Q
}})%
I
.
Section
generic
.
Context
{
A
:
Type
}
`
{
∀
x
y
:
A
,
Decision
(
x
=
y
)}.
End
proof
.
Definition
syncR
:
=
authR
(
optionUR
(
prodR
fracR
(
dec_agreeR
A
)))
.
From
iris
.
algebra
Require
Import
dec_agree
frac
.
From
iris
.
program_logic
Require
Import
auth
.
Class
syncG
Σ
:
=
SyncG
{
sync_tokG
:
>
inG
Σ
syncR
}
.
Definition
sync
Σ
:
gFunctors
:
=
#[
GFunctor
(
constRF
syncR
)]
.
Definition
pcas_R
:
=
authR
(
optionUR
(
prodR
fracR
(
dec_agreeR
(
val
*
val
)))).
Section
triple
.
Context
`
{!
heapG
Σ
,
!
lockG
Σ
,
!
syncG
Σ
}
(
N
:
namespace
).
Class
pcasG
Σ
:
=
PcasG
{
pcas_tokG
:
>
inG
Σ
pcas_R
}.
Definition
pcas
Σ
:
gFunctors
:
=
#[
GFunctor
(
constRF
pcas_R
)].
Definition
gFragR
(
g
:
A
)
:
syncR
:
=
◯
Some
((
1
/
2
)%
Qp
,
DecAgree
g
).
Definition
gFullR
(
g
:
A
)
:
syncR
:
=
●
Some
((
1
/
2
)%
Qp
,
DecAgree
g
).
Definition
gFrag
(
γ
:
gname
)
(
g
:
A
)
:
iProp
Σ
:
=
own
γ
(
gFragR
g
).
Definition
gFull
(
γ
:
gname
)
(
g
:
A
)
:
iProp
Σ
:
=
own
γ
(
gFullR
g
).
Definition
atomic_triple'
(
β
:
A
→
A
→
val
→
iProp
Σ
)
(
Ei
Eo
:
coPset
)
(
e
:
expr
)
γ
:
iProp
Σ
:
=
(
∀
Q
,
(
∀
g
g'
r
,
(
True
={
Eo
,
Ei
}=>
gFrag
γ
g
)
★
(
gFrag
γ
g'
★
β
g
g'
r
={
Ei
,
Eo
}=>
Q
r
))
-
★
WP
e
{{
Q
}})%
I
.
End
triple
.
End
generic
.
Section
atomic_pair
.
Context
`
{!
heapG
Σ
,
!
lockG
Σ
,
!
pcasG
Σ
}
(
N
:
namespace
).
Context
`
{!
heapG
Σ
,
!
lockG
Σ
,
!
(@
syncG
(
val
*
val
)
_
Σ
)
}
(
N
:
namespace
).
Definition
pcas_seq
:
val
:
=
λ
:
"l1"
"l2"
"a"
"b"
,
...
...
@@ -156,33 +163,22 @@ Section atomic_pair.
let
:
"v"
:
=
pcas_seq
"l1"
"l2"
"a"
"b"
in
release
"lk"
;;
"v"
.
Definition
gFullR
(
x1
x2
:
val
)
:
pcas_R
:
=
●
Some
((
1
/
2
)%
Qp
,
DecAgree
(
x1
,
x2
)).
Definition
gFragR
(
x1
x2
:
val
)
:
pcas_R
:
=
◯
Some
((
1
/
2
)%
Qp
,
DecAgree
(
x1
,
x2
)).
Definition
gFull
(
x1
x2
:
val
)
γ
:
iProp
Σ
:
=
own
γ
(
gFullR
x1
x2
).
Definition
gFrag
(
x1
x2
:
val
)
γ
:
iProp
Σ
:
=
own
γ
(
gFragR
x1
x2
).
Definition
β
(
x1
x2
x1'
x2'
v
a
b
:
val
)
:
iProp
Σ
:
=
((
v
=
#
true
∧
x1
=
a
∧
x2
=
a
∧
x1'
=
b
∧
x2'
=
b
)
∨
(
v
=
#
false
∧
x1
=
a
∧
x2
=
a
∧
x1'
=
b
∧
x2'
=
b
))%
I
.
Definition
is_pcas
γ
(
f
:
val
)
(
Ei
Eo
:
coPset
)
:
iProp
Σ
:
=
(
∀
(
a
b
:
val
)
(
Q
:
val
→
iProp
Σ
),
(
∀
x1
x2
x1'
x2'
(
r
:
val
),
(
True
={
Ei
,
Eo
}=>
gFrag
x1
x2
γ
)
★
(
gFrag
x1'
x2'
γ
★
β
x1
x2
x1'
x2'
r
a
b
={
Eo
,
Ei
}=>
Q
r
))
-
★
WP
f
a
b
{{
Q
}})%
I
.
Definition
β
(
a
b
:
val
)
(
xs
xs'
:
val
*
val
)
(
v
:
val
)
:
iProp
Σ
:
=
((
v
=
#
true
∧
fst
xs
=
a
∧
snd
xs
=
a
∧
fst
xs'
=
b
∧
snd
xs'
=
b
)
∨
(
v
=
#
false
∧
fst
xs
=
a
∧
snd
xs
=
a
∧
fst
xs'
=
b
∧
snd
xs'
=
b
))%
I
.
Definition
is_pcas
γ
(
f
:
val
)
:
iProp
Σ
:
=
(
∀
a
b
:
val
,
atomic_triple'
(
β
a
b
)
heapN
(
⊤
∖
nclose
N
)
(
f
a
b
)
γ
)%
I
.
Lemma
pcas_atomic_spec
(
x10
x20
:
val
)
:
(* let's fix Eo as ⊤, and Ei as heapN *)
heapN
⊥
N
→
heap_ctx
⊢
WP
mk_pcas
x10
x20
{{
f
,
∃
γ
,
□
is_pcas
γ
f
(
⊤
∖
nclose
N
)
heapN
}}.
Lemma
pcas_atomic_spec
(
x10
x20
:
val
)
:
heapN
⊥
N
→
heap_ctx
⊢
WP
mk_pcas
x10
x20
{{
f
,
∃
γ
,
□
is_pcas
γ
f
}}.
Proof
.
iIntros
(
HN
)
"#Hh"
.
repeat
wp_let
.
wp_alloc
l1
as
"Hl1"
.
wp_let
.
wp_alloc
l2
as
"Hl2"
.
iVs
(
own_alloc
(
gFullR
x10
x20
⋅
gFragR
x10
x20
))
as
(
γ
)
"Hγ"
;
first
by
done
.
wp_alloc
l2
as
"Hl2"
.
iVs
(
own_alloc
(
gFullR
(
x10
,
x20
)
⋅
gFragR
(
x10
,
x20
))
)
as
(
γ
)
"Hγ"
;
first
by
done
.
iDestruct
(
own_op
with
"Hγ"
)
as
"[Hfull Hfrag]"
.
iAssert
(
∃
x1
x2
,
l1
↦
x1
★
l2
↦
x2
★
gFull
x1
x2
γ
)%
I
with
"[-Hfrag]"
as
"HR"
.
iAssert
(
∃
x1
x2
,
l1
↦
x1
★
l2
↦
x2
★
gFull
γ
(
x1
,
x2
)
)%
I
with
"[-Hfrag]"
as
"HR"
.
{
iExists
x10
,
x20
.
by
iFrame
.
}
wp_let
.
wp_bind
(
newlock
_
).
iApply
newlock_spec
=>//.
...
...
@@ -209,24 +205,26 @@ Section atomic_pair.
wp_if
.
wp_store
.
wp_store
.
wp_let
.
wp_let
.
iDestruct
(
"H"
$!
a
a
b
b
#
true
)
as
"[Hvs1 Hvs2]"
.
iDestruct
(
"H"
$!
(
a
,
a
)
(
b
,
b
)
#
true
)
as
"[Hvs1 Hvs2]"
.
rewrite
/
is_lock
.
iDestruct
"Hlk"
as
(
l
)
"(% & _ & % & Hinv)"
.
iInv
N
as
([])
">[Hl _]"
"Hclose"
.
*
iVs
(
"Hvs1"
with
"[]"
)
as
"Hfraga"
;
first
by
auto
.
subst
.
wp_store
.
iAssert
(
β
a
a
b
b
#
true
a
b
)
as
"Hβ"
.
iAssert
(
β
a
b
(
a
,
a
)
(
b
,
b
)
#
true
)
as
"Hβ"
.
{
iLeft
.
eauto
.
}
iAssert
(
gFrag
a
a
γ
★
gFull
a
a
γ
-
★
gFrag
b
b
γ
★
gFull
b
b
γ
)%
I
as
"H"
.
iAssert
(
gFrag
γ
(
a
,
a
)
★
gFull
γ
(
a
,
a
)
-
★
gFrag
γ
(
b
,
b
)
★
gFull
γ
(
b
,
b
)
)%
I
as
"H"
.
{
admit
.
}
iDestruct
(
"H"
with
"[Hfraga HFulla]"
)
as
"[HFragb HFullb]"
;
first
by
iFrame
.
iVs
(
"Hvs2"
with
"[HFragb Hβ]"
)
;
first
by
iFrame
.
rewrite
/
lock_inv
.
iVsIntro
.
iVs
(
"Hclose"
with
"[-~]"
).
{
iNext
.
iExists
false
.
iFrame
.
iExists
b
,
b
.
by
iFrame
.
}
iVsIntro
.
wp_seq
.
done
.
Admitted
.
Admitted
.
End
atomic_pair
.
Section
sync_atomic
.
Context
`
{!
heapG
Σ
,
!
lockG
Σ
}
(
N
:
namespace
)
{
A
:
Type
}.
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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