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
I
Iris
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
0
Issues
0
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
Simon Spies
Iris
Commits
5ef58527
Commit
5ef58527
authored
Jun 24, 2019
by
Ralf Jung
Browse files
Options
Browse Files
Download
Plain Diff
Merge branch 'ralf/cas' into 'master'
Turn CAS from compare-and-set to compare-and-swap See merge request
iris/iris!274
parents
4a85888c
f02197aa
Changes
17
Hide whitespace changes
Inline
Side-by-side
Showing
17 changed files
with
288 additions
and
256 deletions
+288
-256
CHANGELOG.md
CHANGELOG.md
+6
-0
tests/heap_lang.ref
tests/heap_lang.ref
+5
-4
tests/heap_lang.v
tests/heap_lang.v
+9
-9
tests/heap_lang_proph.v
tests/heap_lang_proph.v
+7
-31
tests/ipm_paper.v
tests/ipm_paper.v
+5
-5
tests/one_shot.v
tests/one_shot.v
+4
-4
theories/heap_lang/lang.v
theories/heap_lang/lang.v
+33
-37
theories/heap_lang/lib/atomic_heap.v
theories/heap_lang/lib/atomic_heap.v
+34
-14
theories/heap_lang/lib/counter.v
theories/heap_lang/lib/counter.v
+12
-12
theories/heap_lang/lib/increment.v
theories/heap_lang/lib/increment.v
+5
-5
theories/heap_lang/lib/spin_lock.v
theories/heap_lang/lib/spin_lock.v
+5
-5
theories/heap_lang/lib/ticket_lock.v
theories/heap_lang/lib/ticket_lock.v
+5
-5
theories/heap_lang/lifting.v
theories/heap_lang/lifting.v
+77
-47
theories/heap_lang/metatheory.v
theories/heap_lang/metatheory.v
+3
-2
theories/heap_lang/notation.v
theories/heap_lang/notation.v
+2
-0
theories/heap_lang/proofmode.v
theories/heap_lang/proofmode.v
+73
-73
theories/heap_lang/tactics.v
theories/heap_lang/tactics.v
+3
-3
No files found.
CHANGELOG.md
View file @
5ef58527
...
...
@@ -54,6 +54,12 @@ Changes in heap_lang:
"normalized" to the same. This makes all closures indistinguishable from each
other while remaining unqueal to anything else. We also use the same
"normalization" to make sure all prophecy variables seem equal to
`()`
.
*
CAS (compare-and-set) got replaced by CmpXchg (compare-exchange). The
difference is that CmpXchg returns a pair consisting of the old value and a
boolean indicating whether the comparison was successful and hence the
exchange happened. CAS can be obtained by simply projecting to the second
component, but also providing the old value more closely models the primitive
typically provided in systems languages (C, C++, Rust).
Changes in Coq:
...
...
tests/heap_lang.ref
View file @
5ef58527
...
...
@@ -40,7 +40,7 @@
============================
_ : ▷ l ↦ #0
--------------------------------------∗
WP C
AS
#l #0 #1 {{ _, l ↦ #1 }}
WP C
mpXchg
#l #0 #1 {{ _, l ↦ #1 }}
1 subgoal
...
...
@@ -144,8 +144,9 @@ Tactic failure: wp_pure: cannot find ?y in (Var "x") or
let: "val2" := fun2 "val1" in
let: "val3" := fun3 "val2" in if: "val1" = "val2" then "val" else "val3"
{{{ (x y : val) (z : Z), RET (x, y, #z); True }}}
"not_c
as
"
"not_c
mpxchg
"
: string
The command has indeed failed with message:
Ltac call to "wp_cas_suc" failed.
Tactic failure: wp_cas_suc: cannot find 'CAS' in (#() #()).
Ltac call to "wp_cmpxchg_suc" failed.
Tactic failure: wp_cmpxchg_suc: cannot find 'CmpXchg' in
(#() #()).
tests/heap_lang.v
View file @
5ef58527
...
...
@@ -79,14 +79,14 @@ Section tests.
Lemma
heap_e6_spec
(
v
:
val
)
:
(
WP
heap_e6
v
{{
w
,
⌜
w
=
#
true
⌝
}})%
I
.
Proof
.
wp_lam
.
wp_op
.
by
case_bool_decide
.
Qed
.
Definition
heap_e7
:
val
:
=
λ
:
"v"
,
C
AS
"v"
#
0
#
1
.
Definition
heap_e7
:
val
:
=
λ
:
"v"
,
C
mpXchg
"v"
#
0
#
1
.
Lemma
heap_e7_spec_total
l
:
l
↦
#
0
-
∗
WP
heap_e7
#
l
[{
_
,
l
↦
#
1
}].
Proof
.
iIntros
.
wp_lam
.
wp_c
as
_suc
.
auto
.
Qed
.
Proof
.
iIntros
.
wp_lam
.
wp_c
mpxchg
_suc
.
auto
.
Qed
.
Check
"heap_e7_spec"
.
Lemma
heap_e7_spec
l
:
▷
^
2
l
↦
#
0
-
∗
WP
heap_e7
#
l
{{
_
,
l
↦
#
1
}}.
Proof
.
iIntros
.
wp_lam
.
Show
.
wp_c
as
_suc
.
Show
.
auto
.
Qed
.
Proof
.
iIntros
.
wp_lam
.
Show
.
wp_c
mpxchg
_suc
.
Show
.
auto
.
Qed
.
Definition
FindPred
:
val
:
=
rec
:
"pred"
"x"
"y"
:
=
...
...
@@ -124,11 +124,11 @@ Section tests.
P
-
∗
(
∀
Q
Φ
,
Q
-
∗
WP
e
{{
Φ
}})
-
∗
WP
e
{{
_
,
True
}}.
Proof
.
iIntros
"HP HW"
.
wp_apply
"HW"
.
iExact
"HP"
.
Qed
.
Lemma
wp_c
as
l
v
:
Lemma
wp_c
mpxchg
l
v
:
val_is_unboxed
v
→
l
↦
v
-
∗
WP
C
AS
#
l
v
v
{{
_
,
True
}}.
l
↦
v
-
∗
WP
C
mpXchg
#
l
v
v
{{
_
,
True
}}.
Proof
.
iIntros
(?)
"?"
.
wp_c
as
as
?
|
?.
done
.
done
.
iIntros
(?)
"?"
.
wp_c
mpxchg
as
?
|
?.
done
.
done
.
Qed
.
Lemma
wp_alloc_split
:
...
...
@@ -210,11 +210,11 @@ End printing_tests.
Section
error_tests
.
Context
`
{!
heapG
Σ
}.
Check
"not_c
as
"
.
Lemma
not_c
as
:
Check
"not_c
mpxchg
"
.
Lemma
not_c
mpxchg
:
(
WP
#()
#()
{{
_
,
True
}})%
I
.
Proof
.
Fail
wp_c
as
_suc
.
Fail
wp_c
mpxchg
_suc
.
Abort
.
End
error_tests
.
...
...
tests/heap_lang_proph.v
View file @
5ef58527
...
...
@@ -8,46 +8,22 @@ Section tests.
Implicit
Types
P
Q
:
iProp
Σ
.
Implicit
Types
Φ
:
val
→
iProp
Σ
.
Definition
CAS_resolve
e1
e2
e3
p
v
:
=
Resolve
(
CAS
e1
e2
e3
)
p
v
.
Lemma
wp_cas_suc_resolve
s
E
(
l
:
loc
)
(
p
:
proph_id
)
(
vs
:
list
(
val
*
val
))
(
v1
v2
v
:
val
)
:
vals_cas_compare_safe
v1
v1
→
{{{
proph
p
vs
∗
▷
l
↦
v1
}}}
CAS_resolve
#
l
v1
v2
#
p
v
@
s
;
E
{{{
RET
#
true
;
∃
vs'
,
⌜
vs
=
(#
true
,
v
)
::
vs'
⌝
∗
proph
p
vs'
∗
l
↦
v2
}}}.
Proof
.
iIntros
(
Hcmp
Φ
)
"[Hp Hl] HΦ"
.
wp_apply
(
wp_resolve
with
"Hp"
)
;
first
done
.
assert
(
val_is_unboxed
v1
)
as
Hv1
;
first
by
destruct
Hcmp
.
wp_cas_suc
.
iIntros
(
vs'
->)
"Hp"
.
iApply
"HΦ"
.
eauto
with
iFrame
.
Qed
.
Lemma
wp_cas_fail_resolve
s
E
(
l
:
loc
)
(
p
:
proph_id
)
(
vs
:
list
(
val
*
val
))
(
v'
v1
v2
v
:
val
)
:
val_for_compare
v'
≠
val_for_compare
v1
→
vals_cas_compare_safe
v'
v1
→
{{{
proph
p
vs
∗
▷
l
↦
v'
}}}
CAS_resolve
#
l
v1
v2
#
p
v
@
s
;
E
{{{
RET
#
false
;
∃
vs'
,
⌜
vs
=
(#
false
,
v
)
::
vs'
⌝
∗
proph
p
vs'
∗
l
↦
v'
}}}.
Proof
.
iIntros
(
NEq
Hcmp
Φ
)
"[Hp Hl] HΦ"
.
wp_apply
(
wp_resolve
with
"Hp"
)
;
first
done
.
wp_cas_fail
.
iIntros
(
vs'
->)
"Hp"
.
iApply
"HΦ"
.
eauto
with
iFrame
.
Qed
.
Lemma
test_resolve1
E
(
l
:
loc
)
(
n
:
Z
)
(
p
:
proph_id
)
(
vs
:
list
(
val
*
val
))
(
v
:
val
)
:
l
↦
#
n
-
∗
proph
p
vs
-
∗
WP
Resolve
(
CAS
#
l
#
n
(#
n
+
#
1
))
#
p
v
@
E
{{
v
,
⌜
v
=
#
true
⌝
∗
∃
vs
,
proph
p
vs
∗
l
↦
#(
n
+
1
)
}}%
I
.
WP
Resolve
(
CmpXchg
#
l
#
n
(#
n
+
#
1
))
#
p
v
@
E
{{
v
,
⌜
v
=
(#
n
,
#
true
)%
V
⌝
∗
∃
vs
,
proph
p
vs
∗
l
↦
#(
n
+
1
)
}}.
Proof
.
iIntros
"Hl Hp"
.
wp_pures
.
wp_apply
(
wp_resolve
with
"Hp"
)
;
first
done
.
wp_cas_suc
.
iIntros
(
ws
->)
"Hp"
.
eauto
with
iFrame
.
wp_cmpxchg_suc
.
iIntros
(
ws
->)
"Hp"
.
eauto
with
iFrame
.
Restart
.
iIntros
"Hl Hp"
.
wp_pures
.
wp_apply
(
wp_resolve_cmpxchg_suc
with
"[$Hp $Hl]"
)
;
first
by
left
.
iIntros
"Hpost"
.
iDestruct
"Hpost"
as
(
ws
->)
"Hp"
.
eauto
with
iFrame
.
Qed
.
Lemma
test_resolve2
E
(
l
:
loc
)
(
n
m
:
Z
)
(
p
:
proph_id
)
(
vs
:
list
(
val
*
val
))
:
proph
p
vs
-
∗
WP
Resolve
(#
n
+
#
m
-
(#
n
+
#
m
))
#
p
#()
@
E
{{
v
,
⌜
v
=
#
0
⌝
∗
∃
vs
,
proph
p
vs
}}
%
I
.
WP
Resolve
(#
n
+
#
m
-
(#
n
+
#
m
))
#
p
#()
@
E
{{
v
,
⌜
v
=
#
0
⌝
∗
∃
vs
,
proph
p
vs
}}.
Proof
.
iIntros
"Hp"
.
wp_pures
.
wp_apply
(
wp_resolve
with
"Hp"
)
;
first
done
.
wp_pures
.
iIntros
(
ws
->)
"Hp"
.
rewrite
Z
.
sub_diag
.
eauto
with
iFrame
.
...
...
tests/ipm_paper.v
View file @
5ef58527
...
...
@@ -222,19 +222,19 @@ Section counter_proof.
iDestruct
1
as
(
c
)
"[Hl Hγ]"
.
wp_load
.
iSplitL
"Hl Hγ"
;
[
iNext
;
iExists
c
;
by
iFrame
|].
wp_let
.
wp_op
.
wp_bind
(
C
AS
_
_
_
).
iApply
wp_inv_open
;
last
iFrame
"Hinv"
;
auto
.
wp_bind
(
C
mpXchg
_
_
_
).
iApply
wp_inv_open
;
last
iFrame
"Hinv"
;
auto
.
iDestruct
1
as
(
c'
)
">[Hl Hγ]"
.
destruct
(
decide
(
c'
=
c
))
as
[->|].
-
iCombine
"Hγ"
"Hγf"
as
"Hγ"
.
iDestruct
(
own_valid
with
"Hγ"
)
as
%?%
auth_frag_valid
;
rewrite
-
auth_frag_op
//.
iMod
(
own_update
with
"Hγ"
)
as
"Hγ"
;
first
apply
M_update
.
rewrite
(
auth_frag_op
(
S
n
)
(
S
c
))
;
last
lia
;
iDestruct
"Hγ"
as
"[Hγ Hγf]"
.
wp_c
as
_suc
.
iSplitL
"Hl Hγ"
.
wp_c
mpxchg
_suc
.
iSplitL
"Hl Hγ"
.
{
iNext
.
iExists
(
S
c
).
rewrite
Nat2Z
.
inj_succ
Z
.
add_1_l
.
by
iFrame
.
}
wp_
if
.
rewrite
{
3
}/
C
;
eauto
10
.
-
wp_c
as
_fail
;
first
(
intros
[=]
;
abstract
omega
).
wp_
pures
.
rewrite
{
3
}/
C
;
eauto
10
.
-
wp_c
mpxchg
_fail
;
first
(
intros
[=]
;
abstract
omega
).
iSplitL
"Hl Hγ"
;
[
iNext
;
iExists
c'
;
by
iFrame
|].
wp_
if
.
iApply
(
"IH"
with
"[Hγf]"
).
rewrite
{
3
}/
C
;
eauto
10
.
wp_
pures
.
iApply
(
"IH"
with
"[Hγf]"
).
rewrite
{
3
}/
C
;
eauto
10
.
Qed
.
Check
"read_spec"
.
...
...
tests/one_shot.v
View file @
5ef58527
...
...
@@ -49,13 +49,13 @@ Proof.
iMod
(
inv_alloc
N
_
(
one_shot_inv
γ
l
)
with
"[Hl Hγ]"
)
as
"#HN"
.
{
iNext
.
iLeft
.
by
iSplitL
"Hl"
.
}
wp_pures
.
iModIntro
.
iApply
"Hf"
;
iSplit
.
-
iIntros
(
n
)
"!#"
.
wp_lam
.
wp_pures
.
-
iIntros
(
n
)
"!#"
.
wp_lam
.
wp_pures
.
wp_bind
(
CmpXchg
_
_
_
).
iInv
N
as
">[[Hl Hγ]|H]"
;
last
iDestruct
"H"
as
(
m
)
"[Hl Hγ]"
.
+
iMod
(
own_update
with
"Hγ"
)
as
"Hγ"
.
{
by
apply
cmra_update_exclusive
with
(
y
:
=
Shot
n
).
}
wp_c
as_suc
.
iSplitL
;
last
eauto
.
i
ModIntro
.
i
Next
;
iRight
;
iExists
n
;
by
iFrame
.
+
wp_c
as_fail
.
iSplitL
;
last
eauto
.
wp_c
mpxchg_suc
.
iModIntro
.
iSplitL
;
last
(
wp_pures
;
by
eauto
)
.
iNext
;
iRight
;
iExists
n
;
by
iFrame
.
+
wp_c
mpxchg_fail
.
iModIntro
.
iSplitL
;
last
(
wp_pures
;
by
eauto
)
.
rewrite
/
one_shot_inv
;
eauto
10
.
-
iIntros
"!# /="
.
wp_lam
.
wp_bind
(!
_
)%
E
.
iInv
N
as
">Hγ"
.
...
...
theories/heap_lang/lang.v
View file @
5ef58527
...
...
@@ -28,11 +28,11 @@ the [Resolve] is stuck), and this value is also attached to the resolution.
A prophecy variable is thus resolved to a pair containing (1) the result
value of the wrapped expression (called [e] above), and (2) the value that
was attached by the [Resolve] (called [v] above). This allows, for example,
to distinguish a resolution originating from a successful [C
AS
] from one
originating from a failing [C
AS
]. For example:
- [Resolve (C
AS #l #n #(n+1)) #p v] will behave as [CAS
#l #n #(n+1)],
which means step to a
boolean [b] while updating the heap, but in the
meantime the prophecy variable [p] will be resolved to [(#b
, v)].
to distinguish a resolution originating from a successful [C
mpXchg
] from one
originating from a failing [C
mpXchg
]. For example:
- [Resolve (C
mpXchg #l #n #(n+1)) #p v] will behave as [CmpXchg
#l #n #(n+1)],
which means step to a
value-boole pair [(n', b)] while updating the heap, but
in the meantime the prophecy variable [p] will be resolved to [(n', b)
, v)].
- [Resolve (! #l) #p v] will behave as [! #l], that is return the value
[w] pointed to by [l] on the heap (assuming it was allocated properly),
but it will additionally resolve [p] to the pair [(w,v)].
...
...
@@ -41,10 +41,10 @@ Note that the sub-expressions of [Resolve e p v] (i.e., [e], [p] and [v])
are reduced as usual, from right to left. However, the evaluation of [e]
is restricted so that the head-step to which the resolution is attached
cannot be taken by the context. For example:
- [Resolve (C
AS
#l #n (#n + #1)) #p v] will first be reduced (with by a
context-step) to [Resolve (C
AS
#l #n #(n+1) #p v], and then behave as
- [Resolve (C
mpXchg
#l #n (#n + #1)) #p v] will first be reduced (with by a
context-step) to [Resolve (C
mpXchg
#l #n #(n+1) #p v], and then behave as
described above.
- However, [Resolve ((λ: "n", C
AS
#l "n" ("n" + #1)) #n) #p v] is stuck.
- However, [Resolve ((λ: "n", C
mpXchg
#l "n" ("n" + #1)) #n) #p v] is stuck.
Indeed, it can only be evaluated using a head-step (it is a β-redex),
but the process does not yield a value.
...
...
@@ -97,8 +97,8 @@ Inductive expr :=
|
AllocN
(
e1
e2
:
expr
)
(* array length (positive number), initial value *)
|
Load
(
e
:
expr
)
|
Store
(
e1
:
expr
)
(
e2
:
expr
)
|
C
AS
(
e0
:
expr
)
(
e1
:
expr
)
(
e2
:
expr
)
|
FAA
(
e1
:
expr
)
(
e2
:
expr
)
|
C
mpXchg
(
e0
:
expr
)
(
e1
:
expr
)
(
e2
:
expr
)
(* Compare-exchange *
)
|
FAA
(
e1
:
expr
)
(
e2
:
expr
)
(* Fetch-and-add *)
(* Prophecy *)
|
NewProph
|
Resolve
(
e0
:
expr
)
(
e1
:
expr
)
(
e2
:
expr
)
(* wrapped expr, proph, val *)
...
...
@@ -115,7 +115,7 @@ Bind Scope val_scope with val.
(** An observation associates a prophecy variable (identifier) to a pair of
values. The first value is the one that was returned by the (atomic) operation
during which the prophecy resolution happened (typically, a boolean when the
wrapped operation is a C
AS
). The second value is the one that the prophecy
wrapped operation is a C
mpXchg
). The second value is the one that the prophecy
variable was actually resolved to. *)
Definition
observation
:
Set
:
=
proph_id
*
(
val
*
val
).
...
...
@@ -159,13 +159,13 @@ Definition val_is_unboxed (v : val) : Prop :=
|
_
=>
False
end
.
(** C
AS
just compares the word-sized representation of two values, it cannot
(** C
mpXchg
just compares the word-sized representation of two values, it cannot
look into boxed data. This works out fine if at least one of the to-be-compared
values is unboxed (exploiting the fact that an unboxed and a boxed value can
never be equal because these are disjoint sets). *)
Definition
vals_c
as
_compare_safe
(
vl
v1
:
val
)
:
Prop
:
=
Definition
vals_c
mpxchg
_compare_safe
(
vl
v1
:
val
)
:
Prop
:
=
val_is_unboxed
vl
∨
val_is_unboxed
v1
.
Arguments
vals_c
as
_compare_safe
!
_
!
_
/.
Arguments
vals_c
mpxchg
_compare_safe
!
_
!
_
/.
(** We don't compare the logical program values, but we first normalize them
to make sure that prophecies are treated like unit.
...
...
@@ -235,7 +235,7 @@ Proof.
|
Load
e
,
Load
e'
=>
cast_if
(
decide
(
e
=
e'
))
|
Store
e1
e2
,
Store
e1'
e2'
=>
cast_if_and
(
decide
(
e1
=
e1'
))
(
decide
(
e2
=
e2'
))
|
C
AS
e0
e1
e2
,
CAS
e0'
e1'
e2'
=>
|
C
mpXchg
e0
e1
e2
,
CmpXchg
e0'
e1'
e2'
=>
cast_if_and3
(
decide
(
e0
=
e0'
))
(
decide
(
e1
=
e1'
))
(
decide
(
e2
=
e2'
))
|
FAA
e1
e2
,
FAA
e1'
e2'
=>
cast_if_and
(
decide
(
e1
=
e1'
))
(
decide
(
e2
=
e2'
))
...
...
@@ -311,7 +311,7 @@ Proof.
|
AllocN
e1
e2
=>
GenNode
13
[
go
e1
;
go
e2
]
|
Load
e
=>
GenNode
14
[
go
e
]
|
Store
e1
e2
=>
GenNode
15
[
go
e1
;
go
e2
]
|
C
AS
e0
e1
e2
=>
GenNode
16
[
go
e0
;
go
e1
;
go
e2
]
|
C
mpXchg
e0
e1
e2
=>
GenNode
16
[
go
e0
;
go
e1
;
go
e2
]
|
FAA
e1
e2
=>
GenNode
17
[
go
e1
;
go
e2
]
|
NewProph
=>
GenNode
18
[]
|
Resolve
e0
e1
e2
=>
GenNode
19
[
go
e0
;
go
e1
;
go
e2
]
...
...
@@ -346,7 +346,7 @@ Proof.
|
GenNode
13
[
e1
;
e2
]
=>
AllocN
(
go
e1
)
(
go
e2
)
|
GenNode
14
[
e
]
=>
Load
(
go
e
)
|
GenNode
15
[
e1
;
e2
]
=>
Store
(
go
e1
)
(
go
e2
)
|
GenNode
16
[
e0
;
e1
;
e2
]
=>
C
AS
(
go
e0
)
(
go
e1
)
(
go
e2
)
|
GenNode
16
[
e0
;
e1
;
e2
]
=>
C
mpXchg
(
go
e0
)
(
go
e1
)
(
go
e2
)
|
GenNode
17
[
e1
;
e2
]
=>
FAA
(
go
e1
)
(
go
e2
)
|
GenNode
18
[]
=>
NewProph
|
GenNode
19
[
e0
;
e1
;
e2
]
=>
Resolve
(
go
e0
)
(
go
e1
)
(
go
e2
)
...
...
@@ -401,9 +401,9 @@ Inductive ectx_item :=
|
LoadCtx
|
StoreLCtx
(
v2
:
val
)
|
StoreRCtx
(
e1
:
expr
)
|
C
as
LCtx
(
v1
:
val
)
(
v2
:
val
)
|
C
as
MCtx
(
e0
:
expr
)
(
v2
:
val
)
|
C
as
RCtx
(
e0
:
expr
)
(
e1
:
expr
)
|
C
mpXchg
LCtx
(
v1
:
val
)
(
v2
:
val
)
|
C
mpXchg
MCtx
(
e0
:
expr
)
(
v2
:
val
)
|
C
mpXchg
RCtx
(
e0
:
expr
)
(
e1
:
expr
)
|
FaaLCtx
(
v2
:
val
)
|
FaaRCtx
(
e1
:
expr
)
|
ResolveLCtx
(
ctx
:
ectx_item
)
(
v1
:
val
)
(
v2
:
val
)
...
...
@@ -414,8 +414,8 @@ Inductive ectx_item :=
the local context of [e] is non-empty. As a consequence, the first argument of
[Resolve] is not completely evaluated (down to a value) by contextual closure:
no head steps (i.e., surface reductions) are taken. This means that contextual
closure will reduce [Resolve (C
AS #l #n (#n + #1)) #p #v] into [Resolve (CAS
#l #n #(n+1)) #p #v], but it cannot context-step any further. *)
closure will reduce [Resolve (C
mpXchg #l #n (#n + #1)) #p #v] into [Resolve
(CmpXchg
#l #n #(n+1)) #p #v], but it cannot context-step any further. *)
Fixpoint
fill_item
(
Ki
:
ectx_item
)
(
e
:
expr
)
:
expr
:
=
match
Ki
with
...
...
@@ -437,9 +437,9 @@ Fixpoint fill_item (Ki : ectx_item) (e : expr) : expr :=
|
LoadCtx
=>
Load
e
|
StoreLCtx
v2
=>
Store
e
(
Val
v2
)
|
StoreRCtx
e1
=>
Store
e1
e
|
C
asLCtx
v1
v2
=>
CAS
e
(
Val
v1
)
(
Val
v2
)
|
C
asMCtx
e0
v2
=>
CAS
e0
e
(
Val
v2
)
|
C
asRCtx
e0
e1
=>
CAS
e0
e1
e
|
C
mpXchgLCtx
v1
v2
=>
CmpXchg
e
(
Val
v1
)
(
Val
v2
)
|
C
mpXchgMCtx
e0
v2
=>
CmpXchg
e0
e
(
Val
v2
)
|
C
mpXchgRCtx
e0
e1
=>
CmpXchg
e0
e1
e
|
FaaLCtx
v2
=>
FAA
e
(
Val
v2
)
|
FaaRCtx
e1
=>
FAA
e1
e
|
ResolveLCtx
K
v1
v2
=>
Resolve
(
fill_item
K
e
)
(
Val
v1
)
(
Val
v2
)
...
...
@@ -468,7 +468,7 @@ Fixpoint subst (x : string) (v : val) (e : expr) : expr :=
|
AllocN
e1
e2
=>
AllocN
(
subst
x
v
e1
)
(
subst
x
v
e2
)
|
Load
e
=>
Load
(
subst
x
v
e
)
|
Store
e1
e2
=>
Store
(
subst
x
v
e1
)
(
subst
x
v
e2
)
|
C
AS
e0
e1
e2
=>
CAS
(
subst
x
v
e0
)
(
subst
x
v
e1
)
(
subst
x
v
e2
)
|
C
mpXchg
e0
e1
e2
=>
CmpXchg
(
subst
x
v
e0
)
(
subst
x
v
e1
)
(
subst
x
v
e2
)
|
FAA
e1
e2
=>
FAA
(
subst
x
v
e1
)
(
subst
x
v
e2
)
|
NewProph
=>
NewProph
|
Resolve
ex
e1
e2
=>
Resolve
(
subst
x
v
ex
)
(
subst
x
v
e1
)
(
subst
x
v
e2
)
...
...
@@ -518,6 +518,7 @@ Definition bin_op_eval_bool (op : bin_op) (b1 b2 : bool) : option base_lit :=
Definition
bin_op_eval
(
op
:
bin_op
)
(
v1
v2
:
val
)
:
option
val
:
=
if
decide
(
op
=
EqOp
)
then
(* Crucially, this compares the same way as [CmpXchg]! *)
Some
$
LitV
$
LitBool
$
bool_decide
(
val_for_compare
v1
=
val_for_compare
v2
)
else
match
v1
,
v2
with
...
...
@@ -633,19 +634,14 @@ Inductive head_step : expr → state → list observation → expr → state →
[]
(
Val
$
LitV
LitUnit
)
(
state_upd_heap
<[
l
:
=
v
]>
σ
)
[]
|
C
asFailS
l
v1
v2
vl
σ
:
vals_c
as
_compare_safe
vl
v1
→
|
C
mpXchgS
l
v1
v2
vl
σ
b
:
vals_c
mpxchg
_compare_safe
vl
v1
→
σ
.(
heap
)
!!
l
=
Some
vl
→
val_for_compare
vl
≠
val_for_compare
v1
→
head_step
(
CAS
(
Val
$
LitV
$
LitLoc
l
)
(
Val
v1
)
(
Val
v2
))
σ
[]
(
Val
$
LitV
$
LitBool
false
)
σ
[]
|
CasSucS
l
v1
v2
vl
σ
:
vals_cas_compare_safe
vl
v1
→
σ
.(
heap
)
!!
l
=
Some
vl
→
val_for_compare
vl
=
val_for_compare
v1
→
head_step
(
CAS
(
Val
$
LitV
$
LitLoc
l
)
(
Val
v1
)
(
Val
v2
))
σ
(* Crucially, this compares the same way as [EqOp]! *)
b
=
bool_decide
(
val_for_compare
vl
=
val_for_compare
v1
)
→
head_step
(
CmpXchg
(
Val
$
LitV
$
LitLoc
l
)
(
Val
v1
)
(
Val
v2
))
σ
[]
(
Val
$
LitV
$
LitBool
true
)
(
state_upd_heap
<[
l
:
=
v2
]>
σ
)
(
Val
$
PairV
vl
(
LitV
$
LitBool
b
))
(
if
b
then
state_upd_heap
<[
l
:
=
v2
]>
σ
else
σ
)
[]
|
FaaS
l
i1
i2
σ
:
σ
.(
heap
)
!!
l
=
Some
(
LitV
(
LitInt
i1
))
→
...
...
theories/heap_lang/lib/atomic_heap.v
View file @
5ef58527
...
...
@@ -11,7 +11,7 @@ Class atomic_heap {Σ} `{!heapG Σ} := AtomicHeap {
alloc
:
val
;
load
:
val
;
store
:
val
;
c
as
:
val
;
c
mpxchg
:
val
;
(* -- predicates -- *)
mapsto
(
l
:
loc
)
(
q
:
Qp
)
(
v
:
val
)
:
iProp
Σ
;
(* -- mapsto properties -- *)
...
...
@@ -31,12 +31,14 @@ Class atomic_heap {Σ} `{!heapG Σ} := AtomicHeap {
(* This spec is slightly weaker than it could be: It is sufficient for [w1]
*or* [v] to be unboxed. However, by writing it this way the [val_is_unboxed]
is outside the atomic triple, which makes it much easier to use -- and the
spec is still good enough for all our applications. *)
cas_spec
(
l
:
loc
)
(
w1
w2
:
val
)
:
spec is still good enough for all our applications.
The postcondition deliberately does not use [bool_decide] so that users can
[destruct (decide (a = b))] and it will simplify in both places. *)
cmpxchg_spec
(
l
:
loc
)
(
w1
w2
:
val
)
:
val_is_unboxed
w1
→
<<<
∀
v
,
mapsto
l
1
v
>>>
c
as
#
l
w1
w2
@
⊤
<<<
∀
v
,
mapsto
l
1
v
>>>
c
mpxchg
#
l
w1
w2
@
⊤
<<<
if
decide
(
val_for_compare
v
=
val_for_compare
w1
)
then
mapsto
l
1
w2
else
mapsto
l
1
v
,
RET
#(
if
decide
(
val_for_compare
v
=
val_for_compare
w1
)
then
true
else
false
)
>>>
;
RET
(
v
,
#
if
decide
(
val_for_compare
v
=
val_for_compare
w1
)
then
true
else
false
)
>>>
;
}.
Arguments
atomic_heap
_
{
_
}.
...
...
@@ -54,10 +56,28 @@ Notation "'ref' e" := (alloc e) : expr_scope.
Notation
"! e"
:
=
(
load
e
)
:
expr_scope
.
Notation
"e1 <- e2"
:
=
(
store
e1
e2
)
:
expr_scope
.
Notation
CAS
e1
e2
e3
:
=
(
cas
e1
e2
e3
).
Notation
CAS
e1
e2
e3
:
=
(
Snd
(
cmpxchg
e1
e2
e3
)
).
End
notation
.
Section
derived
.
Context
`
{!
heapG
Σ
,
!
atomic_heap
Σ
}.
Import
notation
.
Lemma
cas_spec
(
l
:
loc
)
(
w1
w2
:
val
)
:
val_is_unboxed
w1
→
<<<
∀
v
,
mapsto
l
1
v
>>>
CAS
#
l
w1
w2
@
⊤
<<<
if
decide
(
val_for_compare
v
=
val_for_compare
w1
)
then
mapsto
l
1
w2
else
mapsto
l
1
v
,
RET
#
if
decide
(
val_for_compare
v
=
val_for_compare
w1
)
then
true
else
false
>>>.
Proof
.
iIntros
(?
Φ
)
"AU"
.
awp_apply
cmpxchg_spec
;
first
done
.
iApply
(
aacc_aupd_commit
with
"AU"
)
;
first
done
.
iIntros
(
v
)
"H↦"
.
iAaccIntro
with
"H↦"
;
first
by
eauto
with
iFrame
.
iIntros
"$ !> HΦ !>"
.
wp_pures
.
done
.
Qed
.
End
derived
.
(** Proof that the primitive physical operations of heap_lang satisfy said interface. *)
Definition
primitive_alloc
:
val
:
=
λ
:
"v"
,
ref
"v"
.
...
...
@@ -65,8 +85,8 @@ Definition primitive_load : val :=
λ
:
"l"
,
!
"l"
.
Definition
primitive_store
:
val
:
=
λ
:
"l"
"x"
,
"l"
<-
"x"
.
Definition
primitive_c
as
:
val
:
=
λ
:
"l"
"e1"
"e2"
,
C
AS
"l"
"e1"
"e2"
.
Definition
primitive_c
mpxchg
:
val
:
=
λ
:
"l"
"e1"
"e2"
,
C
mpXchg
"l"
"e1"
"e2"
.
Section
proof
.
Context
`
{!
heapG
Σ
}.
...
...
@@ -95,17 +115,17 @@ Section proof.
wp_store
.
iMod
(
"Hclose"
with
"H↦"
)
as
"HΦ"
.
done
.
Qed
.
Lemma
primitive_c
as
_spec
(
l
:
loc
)
(
w1
w2
:
val
)
:
Lemma
primitive_c
mpxchg
_spec
(
l
:
loc
)
(
w1
w2
:
val
)
:
val_is_unboxed
w1
→
<<<
∀
(
v
:
val
),
l
↦
v
>>>
primitive_c
as
#
l
w1
w2
@
⊤
primitive_c
mpxchg
#
l
w1
w2
@
⊤
<<<
if
decide
(
val_for_compare
v
=
val_for_compare
w1
)
then
l
↦
w2
else
l
↦
v
,
RET
#(
if
decide
(
val_for_compare
v
=
val_for_compare
w1
)
then
true
else
false
)
>>>.
RET
(
v
,
#
if
decide
(
val_for_compare
v
=
val_for_compare
w1
)
then
true
else
false
)
>>>.
Proof
.
iIntros
(?
Φ
)
"AU"
.
wp_lam
.
wp_
let
.
wp_let
.
iIntros
(?
Φ
)
"AU"
.
wp_lam
.
wp_
pures
.
iMod
"AU"
as
(
v
)
"[H↦ [_ Hclose]]"
.
destruct
(
decide
(
val_for_compare
v
=
val_for_compare
w1
))
as
[
Heq
|
Hne
]
;
[
wp_c
as_suc
|
wp_cas
_fail
]
;
[
wp_c
mpxchg_suc
|
wp_cmpxchg
_fail
]
;
iMod
(
"Hclose"
with
"H↦"
)
as
"HΦ"
;
done
.
Qed
.
End
proof
.
...
...
@@ -116,5 +136,5 @@ Definition primitive_atomic_heap `{!heapG Σ} : atomic_heap Σ :=
{|
alloc_spec
:
=
primitive_alloc_spec
;
load_spec
:
=
primitive_load_spec
;
store_spec
:
=
primitive_store_spec
;
c
as_spec
:
=
primitive_cas
_spec
;
c
mpxchg_spec
:
=
primitive_cmpxchg
_spec
;
mapsto_agree
:
=
gen_heap
.
mapsto_agree
|}.
theories/heap_lang/lib/counter.v
View file @
5ef58527
...
...
@@ -50,22 +50,22 @@ Section mono_proof.
iDestruct
"Hl"
as
(
γ
)
"[#? Hγf]"
.
wp_bind
(!
_
)%
E
.
iInv
N
as
(
c
)
">[Hγ Hl]"
.
wp_load
.
iModIntro
.
iSplitL
"Hl Hγ"
;
[
iNext
;
iExists
c
;
by
iFrame
|].
wp_pures
.
wp_bind
(
CAS
_
_
_
).
iInv
N
as
(
c'
)
">[Hγ Hl]"
.
wp_pures
.
wp_bind
(
CmpXchg
_
_
_
).
iInv
N
as
(
c'
)
">[Hγ Hl]"
.
destruct
(
decide
(
c'
=
c
))
as
[->|].
-
iDestruct
(
own_valid_2
with
"Hγ Hγf"
)
as
%[?%
mnat_included
_
]%
auth_both_valid
.
iMod
(
own_update_2
with
"Hγ Hγf"
)
as
"[Hγ Hγf]"
.
{
apply
auth_update
,
(
mnat_local_update
_
_
(
S
c
))
;
auto
.
}
wp_c
as
_suc
.
iModIntro
.
iSplitL
"Hl Hγ"
.
wp_c
mpxchg
_suc
.
iModIntro
.
iSplitL
"Hl Hγ"
.
{
iNext
.
iExists
(
S
c
).
rewrite
Nat2Z
.
inj_succ
Z
.
add_1_l
.
by
iFrame
.
}
wp_
if
.
iApply
"HΦ"
;
iExists
γ
;
repeat
iSplit
;
eauto
.
wp_
pures
.
iApply
"HΦ"
;
iExists
γ
;
repeat
iSplit
;
eauto
.
iApply
(
own_mono
with
"Hγf"
).
(* FIXME: FIXME(Coq #6294): needs new unification *)
apply
:
auth_frag_mono
.
by
apply
mnat_included
,
le_n_S
.
-
wp_c
as
_fail
;
first
(
by
intros
[=
?%
Nat2Z
.
inj
]).
iModIntro
.
-
wp_c
mpxchg
_fail
;
first
(
by
intros
[=
?%
Nat2Z
.
inj
]).
iModIntro
.
iSplitL
"Hl Hγ"
;
[
iNext
;
iExists
c'
;
by
iFrame
|].
wp_
if
.
iApply
(
"IH"
with
"[Hγf] [HΦ]"
)
;
last
by
auto
.
wp_
pures
.
iApply
(
"IH"
with
"[Hγf] [HΦ]"
)
;
last
by
auto
.
rewrite
{
3
}/
mcounter
;
eauto
10
.
Qed
.
...
...
@@ -129,17 +129,17 @@ Section contrib_spec.
iIntros
(
Φ
)
"[#? Hγf] HΦ"
.
iL
ö
b
as
"IH"
.
wp_rec
.
wp_bind
(!
_
)%
E
.
iInv
N
as
(
c
)
">[Hγ Hl]"
.
wp_load
.
iModIntro
.
iSplitL
"Hl Hγ"
;
[
iNext
;
iExists
c
;
by
iFrame
|].
wp_pures
.
wp_bind
(
CAS
_
_
_
).
iInv
N
as
(
c'
)
">[Hγ Hl]"
.
wp_pures
.
wp_bind
(
CmpXchg
_
_
_
).
iInv
N
as
(
c'
)
">[Hγ Hl]"
.
destruct
(
decide
(
c'
=
c
))
as
[->|].
-
iMod
(
own_update_2
with
"Hγ Hγf"
)
as
"[Hγ Hγf]"
.
{
apply
frac_auth_update
,
(
nat_local_update
_
_
(
S
c
)
(
S
n
))
;
lia
.
}
wp_c
as
_suc
.
iModIntro
.
iSplitL
"Hl Hγ"
.
wp_c
mpxchg
_suc
.
iModIntro
.
iSplitL
"Hl Hγ"
.
{
iNext
.
iExists
(
S
c
).
rewrite
Nat2Z
.
inj_succ
Z
.
add_1_l
.
by
iFrame
.
}
wp_
if
.
by
iApply
"HΦ"
.
-
wp_c
as
_fail
;
first
(
by
intros
[=
?%
Nat2Z
.
inj
]).
wp_
pures
.
by
iApply
"HΦ"
.
-
wp_c
mpxchg
_fail
;
first
(
by
intros
[=
?%
Nat2Z
.
inj
]).
iModIntro
.
iSplitL
"Hl Hγ"
;
[
iNext
;
iExists
c'
;
by
iFrame
|].
wp_
if
.
by
iApply
(
"IH"
with
"[Hγf] [HΦ]"
)
;
auto
.
wp_
pures
.
by
iApply
(
"IH"
with
"[Hγf] [HΦ]"
)
;
auto
.
Qed
.
Lemma
read_contrib_spec
γ
l
q
n
:
...
...
theories/heap_lang/lib/increment.v
View file @
5ef58527
...
...
@@ -26,12 +26,12 @@ Section increment_physical.
iIntros
(
Φ
)
"AU"
.
iL
ö
b
as
"IH"
.
wp_lam
.
wp_bind
(!
_
)%
E
.
iMod
"AU"
as
(
v
)
"[Hl [Hclose _]]"
.
wp_load
.
iMod
(
"Hclose"
with
"Hl"
)
as
"AU"
.
iModIntro
.
wp_pures
.
wp_bind
(
C
AS
_
_
_
)%
E
.
iMod
"AU"
as
(
w
)
"[Hl Hclose]"
.
wp_pures
.
wp_bind
(
C
mpXchg
_
_
_
)%
E
.
iMod
"AU"
as
(
w
)
"[Hl Hclose]"
.
destruct
(
decide
(#
v
=
#
w
))
as
[[=
->]|
Hx
].
-
wp_c
as
_suc
.
iDestruct
"Hclose"
as
"[_ Hclose]"
.
iMod
(
"Hclose"
with
"Hl"
)
as
"HΦ"
.
iModIntro
.
wp_
if
.
done
.
-
wp_c
as
_fail
.
iDestruct
"Hclose"
as
"[Hclose _]"
.
iMod
(
"Hclose"
with
"Hl"
)
as
"AU"
.
iModIntro
.
wp_
if
.
iApply
"IH"
.
done
.
-
wp_c
mpxchg
_suc
.
iDestruct
"Hclose"
as
"[_ Hclose]"
.
iMod
(
"Hclose"
with
"Hl"
)
as
"HΦ"
.
iModIntro
.
wp_
pures
.
done
.
-
wp_c
mpxchg
_fail
.
iDestruct
"Hclose"
as
"[Hclose _]"
.
iMod
(
"Hclose"
with
"Hl"
)
as
"AU"
.
iModIntro
.
wp_
pures
.
iApply
"IH"
.
done
.
Qed
.
End
increment_physical
.
...
...
theories/heap_lang/lib/spin_lock.v
View file @
5ef58527
...
...
@@ -61,12 +61,12 @@ Section proof.
{{{
b
,
RET
#
b
;
if
b
is
true
then
locked
γ
∗
R
else
True
}}}.
Proof
.
iIntros
(
Φ
)
"#Hl HΦ"
.
iDestruct
"Hl"
as
(
l
->)
"#Hinv"
.
wp_rec
.
iInv
N
as
([])
"[Hl HR]"
.
-
wp_c
as
_fail
.
iModIntro
.
iSplitL
"Hl"
;
first
(
iNext
;
iExists
true
;
eauto
).
iApply
(
"HΦ"
$!
false
).
done
.
-
wp_c
as
_suc
.
iDestruct
"HR"
as
"[Hγ HR]"
.
wp_rec
.
wp_bind
(
CmpXchg
_
_
_
).
iInv
N
as
([])
"[Hl HR]"
.
-
wp_c
mpxchg
_fail
.
iModIntro
.
iSplitL
"Hl"
;
first
(
iNext
;
iExists
true
;
eauto
).
wp_pures
.
iApply
(
"HΦ"
$!
false
).
done
.
-
wp_c
mpxchg
_suc
.
iDestruct
"HR"
as
"[Hγ HR]"
.
iModIntro
.
iSplitL
"Hl"
;
first
(
iNext
;
iExists
true
;
eauto
).
rewrite
/
locked
.
by
iApply
(
"HΦ"
$!
true
with
"[$Hγ $HR]"
).
rewrite
/
locked
.
wp_pures
.
by
iApply
(
"HΦ"
$!
true
with
"[$Hγ $HR]"
).
Qed
.
Lemma
acquire_spec
γ
lk
R
:
...
...
theories/heap_lang/lib/ticket_lock.v
View file @
5ef58527
...
...
@@ -111,7 +111,7 @@ Section proof.
iInv
N
as
(
o
n
)
"[Hlo [Hln Ha]]"
.
wp_load
.
iModIntro
.
iSplitL
"Hlo Hln Ha"
.
{
iNext
.
iExists
o
,
n
.
by
iFrame
.
}
wp_pures
.
wp_bind
(
C
AS
_
_
_
).
wp_pures
.
wp_bind
(
C
mpXchg
_
_
_
).
iInv
N
as
(
o'
n'
)
"(>Hlo' & >Hln' & >Hauth & Haown)"
.
destruct
(
decide
(#
n'
=
#
n
))%
V
as
[[=
->%
Nat2Z
.
inj
]
|
Hneq
].
-
iMod
(
own_update
with
"Hauth"
)
as
"[Hauth Hofull]"
.
...
...
@@ -119,17 +119,17 @@ Section proof.
eapply
(
gset_disj_alloc_empty_local_update
_
{[
n
]}).
apply
(
set_seq_S_end_disjoint
0
).
}
rewrite
-(
set_seq_S_end_union_L
0
).