Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
R
ReLoC-v1
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
1
Issues
1
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Dan Frumin
ReLoC-v1
Commits
a7ff7a8d
Commit
a7ff7a8d
authored
Oct 28, 2017
by
Dan Frumin
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Ticket lock refines spin lock
parent
51f95bd3
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
with
287 additions
and
0 deletions
+287
-0
_CoqProject
_CoqProject
+1
-0
theories/examples/ticket_lock.v
theories/examples/ticket_lock.v
+286
-0
No files found.
_CoqProject
View file @
a7ff7a8d
...
...
@@ -26,6 +26,7 @@ theories/logrel/contextual_refinement.v
theories/logrel/soundness_binary.v
theories/logrel.v
theories/examples/lock.v
theories/examples/ticket_lock.v
theories/examples/counter.v
theories/examples/lateearlychoice.v
theories/examples/par.v
...
...
theories/examples/ticket_lock.v
0 → 100644
View file @
a7ff7a8d
From
iris
.
proofmode
Require
Import
tactics
.
From
iris
.
algebra
Require
Import
auth
gset
excl
.
From
iris
.
base_logic
Require
Import
auth
.
From
iris_logrel
Require
Export
logrel
examples
.
lock
.
Definition
wait_loop
:
val
:=
rec:
"wait_loop"
"x"
"lk"
:=
if:
"x"
=
!
(
Fst
"lk"
)
then
#()
(
*
my
turn
*
)
else
"wait_loop"
"x"
"lk"
.
Definition
newlock
:
val
:=
λ
:
<>
,
((
*
owner
*
)
ref
#
0
,
(
*
next
*
)
ref
#
0
).
Definition
acquire
:
val
:=
rec:
"acquire"
"lk"
:=
let:
"n"
:=
!
(
Snd
"lk"
)
in
if:
CAS
(
Snd
"lk"
)
"n"
(
"n"
+
#
1
)
then
wait_loop
"n"
"lk"
else
"acquire"
"lk"
.
Definition
release
:
val
:=
λ
:
"lk"
,
(
Fst
"lk"
)
<-
!
(
Fst
"lk"
)
+
#
1.
Definition
LockType
:=
TProd
(
Tref
TNat
)
(
Tref
TNat
).
Hint
Unfold
LockType
:
typeable
.
Lemma
newlock_type
Γ
:
typed
Γ
newlock
(
TArrow
TUnit
LockType
).
Proof
.
solve_typed
.
Qed
.
Hint
Resolve
newlock_type
:
typeable
.
Lemma
acquire_type
Γ
:
typed
Γ
acquire
(
TArrow
LockType
TUnit
).
Proof
.
unlock
acquire
wait_loop
.
solve_typed
.
Qed
.
Hint
Resolve
acquire_type
:
typeable
.
Lemma
release_type
Γ
:
typed
Γ
release
(
TArrow
LockType
TUnit
).
Proof
.
solve_typed
.
Qed
.
Hint
Resolve
release_type
:
typeable
.
Definition
lock
τ
:=
TExists
(
TProd
(
TProd
(
TArrow
TUnit
(
TVar
0
))
(
TArrow
(
TVar
0
)
TUnit
))
(
TArrow
(
TVar
0
)
TUnit
)).
Lemma
ticket_lock_typed
Γ
:
typed
Γ
(
Pack
(
newlock
,
acquire
,
release
))
lock
τ
.
Proof
.
apply
TPack
with
LockType
.
asimpl
.
solve_typed
.
Qed
.
Class
tlockG
Σ
:=
tlock_G
:>
authG
Σ
(
gset_disjUR
nat
).
Definition
tlock
Σ
:
gFunctors
:=
#[
auth
Σ
(
gset_disjUR
nat
)
].
Definition
lockPool
:=
gset
((
loc
*
loc
*
gname
)
*
loc
).
Definition
lockPoolR
:=
gsetUR
((
loc
*
loc
*
gname
)
*
loc
).
Class
lockPoolG
Σ
:=
lockPool_inG
:>
authG
Σ
lockPoolR
.
Section
refinement
.
Context
`
{
logrelG
Σ
,
tlockG
Σ
,
lockPoolG
Σ
}
.
Definition
lockInv
(
lo
ln
:
loc
)
(
γ
:
gname
)
(
l
'
:
loc
)
:
iProp
Σ
:=
(
∃
(
o
n
:
nat
)
(
b
:
bool
),
lo
↦ᵢ
#
o
∗
ln
↦ᵢ
#
n
∗
own
γ
(
●
GSet
(
seq_set
0
n
))
∗
l
'
↦ₛ
#
b
∗
if
b
then
own
γ
(
◯
GSet
{
[
o
]
}
)
else
True
)
%
I
.
Definition
lockPoolInv
(
P
:
lockPool
)
:
iProp
Σ
:=
([
∗
set
]
rs
∈
P
,
match
rs
with
|
((
lo
,
ln
,
γ
),
l
'
)
=>
lockInv
lo
ln
γ
l
'
end
)
%
I
.
Definition
moduleInv
γ
p
:
iProp
Σ
:=
(
∃
(
P
:
lockPool
),
own
γ
p
(
●
P
)
∗
lockPoolInv
P
)
%
I
.
Program
Definition
lockInt
(
γ
p
:
gname
)
:=
λ
ne
vv
,
(
∃
(
lo
ln
:
loc
)
(
γ
:
gname
)
(
l
'
:
loc
),
⌜
vv
.1
=
(#
lo
,
#
ln
)
%
V
⌝
∗
⌜
vv
.2
=
#
l
'⌝
∗
own
γ
p
(
◯
{
[(
lo
,
ln
,
γ
),
l
'
]
}
))
%
I
.
Next
Obligation
.
solve_proper
.
Qed
.
Instance
lockInt_persistent
γ
p
ww
:
PersistentP
(
lockInt
γ
p
ww
).
Proof
.
apply
_.
Qed
.
Lemma
lockPool_open_later
(
P
:
lockPool
)
(
lo
ln
:
loc
)
(
γ
:
gname
)
(
l
'
:
loc
)
:
(
lo
,
ln
,
γ
,
l
'
)
∈
P
→
▷
lockPoolInv
P
-
∗
(
▷
lockInv
lo
ln
γ
l
'
)
∗
▷
(
lockInv
lo
ln
γ
l
'
-
∗
lockPoolInv
P
).
Proof
.
iIntros
(
Hrin
)
"Hreg"
.
rewrite
/
lockPoolInv
.
iDestruct
(
big_sepS_elem_of_acc
_
P
_
with
"Hreg"
)
as
"[Hrs Hreg]"
;
first
apply
Hrin
.
by
iFrame
.
Qed
.
Lemma
lockPool_lookup
γ
p
(
P
:
lockPool
)
x
:
own
γ
p
(
●
P
)
-
∗
own
γ
p
(
◯
{
[
x
]
}
)
-
∗
⌜
x
∈
P
⌝
.
Proof
.
iIntros
"Ho Hrs"
.
iDestruct
(
own_valid_2
with
"Ho Hrs"
)
as
%
Hfoo
.
iPureIntro
.
apply
auth_valid_discrete
in
Hfoo
.
simpl
in
Hfoo
.
destruct
Hfoo
as
[
Hfoo
_
].
revert
Hfoo
.
rewrite
left_id
.
by
rewrite
gset_included
elem_of_subseteq_singleton
.
Qed
.
Lemma
lockPool_excl
(
P
:
lockPool
)
(
lo
ln
:
loc
)
γ
l
'
(
v
:
val
)
:
lockPoolInv
P
-
∗
lo
↦ᵢ
v
-
∗
⌜
(
lo
,
ln
,
γ
,
l
'
)
∉
P
⌝
.
Proof
.
rewrite
/
lockPoolInv
.
iIntros
"HP Hlo"
.
iAssert
(
⌜
(
lo
,
ln
,
γ
,
l
'
)
∈
P
⌝
→
False
)
%
I
as
%
Hbaz
.
{
iIntros
(
HP
).
rewrite
(
big_sepS_elem_of
_
P
_
HP
).
iDestruct
"HP"
as
(
a
b
c
)
"(Hlo' & Hln & ?)"
.
iDestruct
(
mapsto_valid_2
with
"Hlo' Hlo"
)
as
%
Hfoo
;
compute
in
Hfoo
;
contradiction
.
}
iPureIntro
.
eauto
.
Qed
.
Lemma
ticket_lock_refinement
Γ
:
Γ
⊨
Pack
(
newlock
,
acquire
,
release
)
≤
log
≤
Pack
(
lock
.
newlock
,
lock
.
acquire
,
lock
.
release
)
:
lock
τ
.
Proof
.
iIntros
(
Δ
).
pose
(
N
:=
logrelN
.
@
"locked"
).
iApply
fupd_logrel
'
.
iMod
(
own_alloc
(
●
(
∅
:
lockPoolR
)))
as
(
γ
p
)
"HP"
;
first
done
.
iMod
(
inv_alloc
N
_
(
moduleInv
γ
p
)
with
"[HP]"
)
as
"#Hinv"
.
{
iNext
.
iExists
∅
.
iFrame
.
by
rewrite
/
lockPoolInv
big_sepS_empty
.
}
iModIntro
.
iApply
(
bin_log_related_pack
_
(
lockInt
γ
p
)).
repeat
iApply
bin_log_related_pair
.
-
(
*
Allocating
a
new
lock
*
)
unlock
newlock
lock
.
newlock
.
iApply
bin_log_related_arrow_val
;
eauto
.
iAlways
.
iIntros
(
?
?
)
"/= [% %]"
.
simplify_eq
.
rel_let_l
.
rel_let_r
.
rel_alloc_r
as
l
'
"Hl'"
.
rel_alloc_l
as
lo
"Hlo"
.
rel_alloc_l_atomic
.
iInv
N
as
(
P
)
"[>HP Hpool]"
"Hcl"
.
iModIntro
.
iNext
.
iIntros
(
ln
)
"Hln"
.
iApply
fupd_logrel
'
.
iMod
(
own_alloc
(
●
(
GSet
∅
)
⋅
◯
(
GSet
∅
)))
as
(
γ
)
"[Hγ Hγ']"
.
{
by
rewrite
-
auth_both_op
.
}
iMod
(
own_update
with
"HP"
)
as
"[HP Hls]"
.
{
eapply
auth_update_alloc
.
eapply
(
gset_local_update
_
_
(
{
[(
lo
,
ln
,
γ
,
l
'
)]
}
∪
P
)).
apply
union_subseteq_r
.
}
iModIntro
.
iDestruct
(
lockPool_excl
_
lo
ln
γ
l
'
with
"Hpool Hlo"
)
as
%
Hnew
.
iMod
(
"Hcl"
with
"[-Hls]"
)
as
"_"
.
{
iNext
.
iExists
_
;
iFrame
.
rewrite
/
lockPoolInv
.
rewrite
big_sepS_insert
;
last
assumption
.
iFrame
.
iExists
_
,
_
,
_.
iFrame
.
simpl
.
iFrame
.
}
rel_vals
.
iModIntro
.
rewrite
-
gset_op_union
.
iDestruct
"Hls"
as
"[#Hls _]"
.
iAlways
.
iExists
_
,
_
,
_
,
_.
iFrame
"Hls"
.
eauto
.
-
(
*
Acquire
*
)
unlock
acquire
.
iApply
bin_log_related_arrow_val
;
eauto
.
{
by
unlock
lock
.
acquire
.
}
iAlways
.
iIntros
(
?
?
)
"/= #Hl"
.
iDestruct
"Hl"
as
(
lo
ln
γ
l
'
)
"(% & % & Hls)"
.
simplify_eq
.
iL
ö
b
as
"IH"
.
rel_let_l
.
repeat
rel_proj_l
.
rel_load_l_atomic
.
iInv
N
as
(
P
)
"[>HP Hpool]"
"Hcl"
.
iDestruct
(
lockPool_lookup
with
"HP Hls"
)
as
%
Hls
.
iDestruct
(
lockPool_open_later
with
"Hpool"
)
as
"[Hlk Hpool]"
;
first
apply
Hls
.
rewrite
{
1
}/
lockInv
.
iDestruct
"Hlk"
as
(
o
n
b
)
"(>Hlo & >Hln & ?)"
.
iModIntro
.
iExists
_
;
iFrame
;
iNext
.
iIntros
"Hln"
.
iMod
(
"Hcl"
with
"[-]"
)
as
"_"
.
{
iNext
.
iExists
P
;
iFrame
.
iApply
"Hpool"
.
iExists
_
,
_
,
_
;
iFrame
.
}
rel_let_l
.
rel_proj_l
.
rel_op_l
.
clear
Hls
o
b
P
.
rel_cas_l_atomic
.
iInv
N
as
(
P
)
"[>HP Hpool]"
"Hcl"
.
iDestruct
(
lockPool_lookup
with
"HP Hls"
)
as
%
Hls
.
iDestruct
(
lockPool_open_later
with
"Hpool"
)
as
"[Hlk Hpool]"
;
first
apply
Hls
.
rewrite
{
1
}/
lockInv
.
iDestruct
"Hlk"
as
(
o
n
'
b
)
"(>Hlo & >Hln & Hseq & Hl' & Hrest)"
.
iModIntro
.
iExists
_
;
iFrame
.
iSplit
;
iIntros
(
?
);
iNext
;
iIntros
"Hln"
;
rel_if_l
.
+
iMod
(
"Hcl"
with
"[-]"
)
as
"_"
.
{
iNext
.
iExists
P
;
iFrame
.
iApply
"Hpool"
.
iExists
_
,
_
,
_
;
by
iFrame
.
}
iApply
"IH"
.
+
simplify_eq
.
iApply
fupd_logrel
'
.
iMod
(
own_update
with
"Hseq"
)
as
"[Hseq Hticket]"
.
{
eapply
auth_update_alloc
.
eapply
(
gset_disj_alloc_empty_local_update
_
{
[
n
]
}
).
apply
(
seq_set_S_disjoint
0
).
}
iModIntro
.
rewrite
-
(
seq_set_S_union_L
0
).
rewrite
Nat
.
add_1_r
.
iMod
(
"Hcl"
with
"[-Hticket]"
)
as
"_"
.
{
iNext
.
iExists
P
;
iFrame
.
iApply
"Hpool"
.
iExists
_
,
_
,
_
;
by
iFrame
.
}
iClear
"IH"
.
unlock
wait_loop
.
rel_rec_l
.
iL
ö
b
as
"IH"
.
rel_let_l
.
rel_proj_l
.
rel_load_l_atomic
.
clear
Hls
P
o
b
.
iInv
N
as
(
P
)
"[>HP Hpool]"
"Hcl"
.
iDestruct
(
lockPool_lookup
with
"HP Hls"
)
as
%
Hls
.
iDestruct
(
lockPool_open_later
with
"Hpool"
)
as
"[Hlk Hpool]"
;
first
apply
Hls
.
rewrite
{
1
}/
lockInv
.
iDestruct
"Hlk"
as
(
o
n
'
b
)
"(>Hlo & >Hln & Hseq & Hl' & Hrest)"
.
iModIntro
.
iExists
_
;
iFrame
;
iNext
.
iIntros
"Hlo"
.
destruct
(
decide
(
n
=
o
));
simplify_eq
;
rel_op_l
.
(
*
The
ticket
is
called
out
*
)
*
replace
(
if
PeanoNat
.
Nat
.
eq_dec
o
o
then
LitV
true
else
LitV
false
)
with
#
true
;
last
first
.
{
(
*
TODO
:
(
*
)
case_match
;
congruence
.
}
rel_if_l
.
unlock
lock
.
acquire
.
rel_rec_r
.
destruct
b
.
{
iDestruct
(
own_valid_2
with
"Hticket Hrest"
)
as
%?%
gset_disj_valid_op
.
set_solver
.
}
rel_cas_suc_r
.
rel_if_r
.
iMod
(
"Hcl"
with
"[-]"
)
as
"_"
.
{
iNext
.
iExists
P
;
iFrame
.
iApply
"Hpool"
.
iExists
_
,
_
,
_
;
by
iFrame
.
}
iApply
bin_log_related_unit
.
*
replace
(
if
PeanoNat
.
Nat
.
eq_dec
n
o
then
LitV
true
else
LitV
false
)
with
#
false
;
last
first
.
{
(
*
TODO
:
(
*
)
case_match
;
congruence
.
}
rel_if_l
.
iMod
(
"Hcl"
with
"[-Hticket]"
)
as
"_"
.
{
iNext
.
iExists
P
;
iFrame
.
iApply
"Hpool"
.
iExists
_
,
_
,
_
;
by
iFrame
.
}
rel_rec_l
.
by
iApply
"IH"
.
-
(
*
Release
*
)
unlock
release
lock
.
release
.
iApply
bin_log_related_arrow_val
;
eauto
.
iAlways
.
iIntros
(
?
?
)
"/= #Hl"
.
iDestruct
"Hl"
as
(
lo
ln
γ
l
'
)
"(% & % & Hls)"
.
simplify_eq
.
rel_let_l
.
repeat
rel_proj_l
.
rel_load_l_atomic
.
iInv
N
as
(
P
)
"[>HP Hpool]"
"Hcl"
.
iDestruct
(
lockPool_lookup
with
"HP Hls"
)
as
%
Hls
.
iDestruct
(
lockPool_open_later
with
"Hpool"
)
as
"[Hlk Hpool]"
;
first
apply
Hls
.
rewrite
{
1
}/
lockInv
.
iDestruct
"Hlk"
as
(
o
n
b
)
"(>Hlo & >Hln & ?)"
.
iModIntro
.
iExists
_
;
iFrame
;
iNext
.
iIntros
"Hlo"
.
iMod
(
"Hcl"
with
"[-]"
)
as
"_"
.
{
iNext
.
iExists
P
;
iFrame
.
iApply
"Hpool"
.
iExists
_
,
_
,
_
;
iFrame
.
}
rel_op_l
.
rel_store_l_atomic
.
clear
Hls
n
b
P
.
iInv
N
as
(
P
)
"[>HP Hpool]"
"Hcl"
.
iDestruct
(
lockPool_lookup
with
"HP Hls"
)
as
%
Hls
.
iDestruct
(
lockPool_open_later
with
"Hpool"
)
as
"[Hlk Hpool]"
;
first
apply
Hls
.
rewrite
{
1
}/
lockInv
.
iDestruct
"Hlk"
as
(
o
'
n
b
)
"(>Hlo & >Hln & Hseq & Hl' & Hrest)"
.
iModIntro
.
iExists
_
;
iFrame
;
iNext
.
iIntros
"Hlo"
.
rel_let_r
.
rel_store_r
.
iMod
(
"Hcl"
with
"[-]"
)
as
"_"
.
{
iNext
.
iExists
P
;
iFrame
.
iApply
"Hpool"
.
iExists
_
,
_
,
_
;
iFrame
.
}
iApply
bin_log_related_unit
.
Qed
.
End
refinement
.
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