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
Rice Wine
Iris
Commits
74960dec
Commit
74960dec
authored
Mar 20, 2016
by
Ralf Jung
Browse files
move other exampkes back here
parent
b5d6b7bb
Changes
3
Hide whitespace changes
Inline
Side-by-side
_CoqProject
View file @
74960dec
...
...
@@ -95,3 +95,5 @@ heap_lang/lib/barrier/proof.v
heap_lang/lib/barrier/client.v
tests/heap_lang.v
tests/program_logic.v
tests/one_shot.v
tests/joining_existentials.v
tests/joining_existentials.v
0 → 100644
View file @
74960dec
From
iris
.
program_logic
Require
Import
saved_one_shot
hoare
tactics
.
From
iris
.
heap_lang
.
lib
.
barrier
Require
Import
proof
specification
.
From
iris
.
heap_lang
Require
Import
notation
par
.
Import
uPred
.
Definition
client
eM
eW1
eW2
:
expr
[]
:
=
(
let
:
"b"
:
=
newbarrier
#()
in
(
eM
;;
^
signal
'
"b"
)
||
((^
wait
'
"b"
;;
eW1
)
||
(^
wait
'
"b"
;;
eW2
))).
Section
proof
.
Context
(
G
:
cFunctor
).
Context
{
Σ
:
gFunctors
}
`
{!
heapG
Σ
,
!
barrierG
Σ
,
!
spawnG
Σ
,
!
oneShotG
heap_lang
Σ
G
}.
Context
(
heapN
N
:
namespace
).
Local
Notation
iProp
:
=
(
iPropG
heap_lang
Σ
).
Local
Notation
X
:
=
(
G
iProp
).
Definition
barrier_res
γ
(
P
:
X
→
iProp
)
:
iProp
:
=
(
∃
x
:
X
,
one_shot_own
γ
x
★
P
x
)%
I
.
Lemma
worker_spec
e
γ
l
(
P
Q
:
X
→
iProp
)
(
R
:
iProp
)
:
R
⊢
(
∀
x
,
{{
P
x
}}
e
{{
λ
_
,
Q
x
}})
→
R
⊢
(
recv
heapN
N
l
(
barrier_res
γ
P
))
→
R
⊢
WP
wait
(%
l
)
;;
e
{{
λ
_
,
barrier_res
γ
Q
}}.
Proof
.
intros
He
H
Φ
.
rewrite
-[
R
](
idemp
(
∧
)%
I
)
{
1
}
He
H
Φ
always_and_sep_l
{
He
H
Φ
}.
ewp
(
eapply
wait_spec
).
ecancel
[
recv
_
_
l
_
].
apply
wand_intro_r
.
wp_seq
.
rewrite
/
barrier_res
sep_exist_l
.
apply
exist_elim
=>
x
.
rewrite
(
forall_elim
x
)
/
ht
always_elim
impl_wand
!
assoc
.
to_front
[
P
x
;
_
-
★
_
]%
I
.
rewrite
wand_elim_r
!
wp_frame_r
.
apply
wp_mono
=>
v
.
by
rewrite
-(
exist_intro
x
)
comm
.
Qed
.
Context
(
P'
:
iProp
)
(
P
P1
P2
Q
Q1
Q2
:
X
-
n
>
iProp
).
Context
{
P_split
:
∀
x
:
X
,
P
x
⊢
(
P1
x
★
P2
x
)}.
Context
{
Q_join
:
∀
x
:
X
,
(
Q1
x
★
Q2
x
)
⊢
Q
x
}.
Lemma
P_res_split
γ
:
barrier_res
γ
P
⊢
(
barrier_res
γ
P1
★
barrier_res
γ
P2
).
Proof
.
rewrite
/
barrier_res
.
apply
exist_elim
=>
x
.
do
2
rewrite
-(
exist_intro
x
).
rewrite
P_split
{
1
}[
one_shot_own
_
_
]
always_sep_dup
.
solve_sep_entails
.
Qed
.
Lemma
Q_res_join
γ
:
(
barrier_res
γ
Q1
★
barrier_res
γ
Q2
)
⊢
▷
barrier_res
γ
Q
.
Proof
.
rewrite
/
barrier_res
sep_exist_r
.
apply
exist_elim
=>
x1
.
rewrite
sep_exist_l
.
apply
exist_elim
=>
x2
.
rewrite
[
one_shot_own
γ
x1
]
always_sep_dup
.
to_front
[
one_shot_own
γ
x1
;
one_shot_own
γ
x2
].
rewrite
one_shot_agree
.
strip_later
.
rewrite
-(
exist_intro
x1
)
-
Q_join
.
ecancel
[
one_shot_own
γ
_;
Q1
_
].
eapply
(
eq_rewrite
x2
x1
(
λ
x
,
Q2
x
))
;
last
by
eauto
with
I
.
{
(* FIXME typeclass search should find this. *)
apply
cofe_mor_ne
.
}
rewrite
eq_sym
.
eauto
with
I
.
Qed
.
Lemma
client_spec
(
eM
eW1
eW2
:
expr
[])
(
eM'
eW1'
eW2'
:
expr
(
"b"
:
b
:
[]))
(
R
:
iProp
)
:
heapN
⊥
N
→
eM'
=
wexpr'
eM
→
eW1'
=
wexpr'
eW1
→
eW2'
=
wexpr'
eW2
→
R
⊢
({{
P'
}}
eM
{{
λ
_
,
∃
x
,
P
x
}})
→
R
⊢
(
∀
x
,
{{
P1
x
}}
eW1
{{
λ
_
,
Q1
x
}})
→
R
⊢
(
∀
x
,
{{
P2
x
}}
eW2
{{
λ
_
,
Q2
x
}})
→
R
⊢
heap_ctx
heapN
→
R
⊢
P'
→
R
⊢
WP
client
eM'
eW1'
eW2'
{{
λ
_
,
∃
γ
,
barrier_res
γ
Q
}}.
Proof
.
intros
HN
->
->
->
HeM
HeW1
HeW2
Hheap
HP'
.
rewrite
-
4
!{
1
}[
R
](
idemp
(
∧
)%
I
)
{
1
}
HeM
{
1
}
HeW1
{
1
}
HeW2
{
1
}
Hheap
{
1
}
HP'
!
always_and_sep_l
{
Hheap
}
/
client
.
to_front
[].
rewrite
one_shot_alloc
!
pvs_frame_r
!
sep_exist_r
.
apply
wp_strip_pvs
,
exist_elim
=>
γ
.
rewrite
{
1
}[
heap_ctx
_
]
always_sep_dup
.
(
ewp
(
eapply
(
newbarrier_spec
heapN
N
(
barrier_res
γ
P
))))
;
last
done
.
cancel
[
heap_ctx
heapN
].
apply
forall_intro
=>
l
.
apply
wand_intro_r
.
set
(
workers_post
(
v
:
val
)
:
=
(
barrier_res
γ
Q1
★
barrier_res
γ
Q2
)%
I
).
wp_let
.
(
ewp
(
eapply
wp_par
with
(
Ψ
1
:
=
λ
_
,
True
%
I
)
(
Ψ
2
:
=
workers_post
)))
;
last
first
.
{
done
.
}
(* FIXME why does this simple goal even appear? *)
rewrite
{
1
}[
heap_ctx
_
]
always_sep_dup
.
cancel
[
heap_ctx
heapN
].
sep_split
left
:
[
one_shot_pending
γ
;
send
_
_
_
_
;
P'
;
{{
_
}}
eM
{{
_
}}]%
I
.
{
(* Main thread. *)
wp_focus
eM
.
rewrite
/
ht
always_elim
impl_wand
wand_elim_r
!
wp_frame_l
.
apply
wp_mono
=>
v
.
wp_seq
.
rewrite
!
sep_exist_l
.
apply
exist_elim
=>
x
.
rewrite
(
one_shot_init
_
γ
x
)
!
pvs_frame_r
.
apply
wp_strip_pvs
.
ewp
(
eapply
signal_spec
).
ecancel
[
send
_
_
_
_
].
by
rewrite
/
barrier_res
-(
exist_intro
x
).
}
sep_split
right
:
[].
-
(* Worker threads. *)
rewrite
recv_mono
;
last
exact
:
P_res_split
.
rewrite
(
recv_split
_
_
⊤
)
//.
rewrite
?pvs_frame_r
!
pvs_frame_l
.
apply
wp_strip_pvs
.
(
ewp
(
eapply
wp_par
with
(
Ψ
1
:
=
λ
_
,
barrier_res
γ
Q1
)
(
Ψ
2
:
=
λ
_
,
barrier_res
γ
Q2
)))
;
last
first
.
{
done
.
}
ecancel
[
heap_ctx
_
].
sep_split
left
:
[
recv
_
_
_
(
barrier_res
γ
P1
)
;
∀
_
,
{{
_
}}
eW1
{{
_
}}]%
I
.
{
eapply
worker_spec
;
eauto
with
I
.
}
sep_split
left
:
[
recv
_
_
_
(
barrier_res
γ
P2
)
;
∀
_
,
{{
_
}}
eW2
{{
_
}}]%
I
.
{
eapply
worker_spec
;
eauto
with
I
.
}
rewrite
/
workers_post
.
do
2
apply
forall_intro
=>
_
.
(* FIXME: this should work: rewrite -later_intro. *)
apply
wand_intro_r
.
rewrite
-
later_intro
.
solve_sep_entails
.
-
(* Merging. *)
rewrite
/
workers_post
.
do
2
apply
forall_intro
=>
_
.
apply
wand_intro_r
.
rewrite
!
left_id
Q_res_join
.
strip_later
.
by
rewrite
-(
exist_intro
γ
).
Qed
.
End
proof
.
tests/one_shot.v
0 → 100644
View file @
74960dec
From
iris
.
algebra
Require
Import
one_shot
dec_agree
.
From
iris
.
program_logic
Require
Import
hoare
.
From
iris
.
heap_lang
Require
Import
heap
assert
wp_tactics
notation
.
Import
uPred
.
Definition
one_shot_example
:
val
:
=
λ
:
<>,
let
:
"x"
:
=
ref
(
InjL
#
0
)
in
(
(* tryset *)
(
λ
:
"n"
,
CAS
'
"x"
(
InjL
#
0
)
(
InjR
'
"n"
)),
(* check *)
(
λ
:
<>,
let
:
"y"
:
=
!
'
"x"
in
λ
:
<>,
match
:
'
"y"
with
InjL
<>
=>
#()
|
InjR
"n"
=>
match
:
!
'
"x"
with
InjL
<>
=>
Assert
#
false
|
InjR
"m"
=>
Assert
(
'
"n"
=
'
"m"
)
end
end
)).
Class
one_shotG
Σ
:
=
OneShotG
{
one_shot_inG
:
>
inG
heap_lang
Σ
(
one_shotR
(
dec_agreeR
Z
))
}.
Definition
one_shotGF
:
gFunctorList
:
=
[
GFunctor
(
constRF
(
one_shotR
(
dec_agreeR
Z
)))].
Instance
inGF_one_shotG
Σ
:
inGFs
heap_lang
Σ
one_shotGF
→
one_shotG
Σ
.
Proof
.
intros
[?
_
]
;
split
;
apply
:
inGF_inG
.
Qed
.
Section
proof
.
Context
{
Σ
:
gFunctors
}
`
{!
heapG
Σ
,
!
one_shotG
Σ
}.
Context
(
heapN
N
:
namespace
)
(
HN
:
heapN
⊥
N
).
Local
Notation
iProp
:
=
(
iPropG
heap_lang
Σ
).
Definition
one_shot_inv
(
γ
:
gname
)
(
l
:
loc
)
:
iProp
:
=
(
l
↦
InjLV
#
0
★
own
γ
OneShotPending
∨
∃
n
:
Z
,
l
↦
InjRV
#
n
★
own
γ
(
Shot
(
DecAgree
n
)))%
I
.
Lemma
wp_one_shot
(
Φ
:
val
→
iProp
)
:
(
heap_ctx
heapN
★
∀
f1
f2
:
val
,
(
∀
n
:
Z
,
□
WP
f1
#
n
{{
λ
w
,
w
=
#
true
∨
w
=
#
false
}})
★
□
WP
f2
#()
{{
λ
g
,
□
WP
g
#()
{{
λ
_
,
True
}}
}}
-
★
Φ
(
f1
,
f2
)%
V
)
⊢
WP
one_shot_example
#()
{{
Φ
}}.
Proof
.
wp_let
.
wp
eapply
wp_alloc
;
eauto
with
I
.
apply
forall_intro
=>
l
;
apply
wand_intro_l
.
eapply
sep_elim_True_l
;
first
by
apply
(
own_alloc
OneShotPending
).
rewrite
!
pvs_frame_r
;
apply
wp_strip_pvs
.
rewrite
!
sep_exist_r
;
apply
exist_elim
=>
γ
.
(* TODO: this is horrible *)
trans
(
heap_ctx
heapN
★
(|==>
inv
N
(
one_shot_inv
γ
l
))
★
(
∀
f1
f2
:
val
,
(
∀
n
:
Z
,
□
WP
f1
#
n
{{
λ
w
,
w
=
#
true
∨
w
=
#
false
}})
★
□
WP
f2
#()
{{
λ
g
,
□
WP
g
#()
{{
λ
_
,
True
}}
}}
-
★
Φ
(
f1
,
f2
)%
V
))%
I
.
{
ecancel
[
heap_ctx
_;
∀
_
,
_
]%
I
.
rewrite
-
inv_alloc
//
-
later_intro
.
apply
or_intro_l'
.
solve_sep_entails
.
}
rewrite
pvs_frame_r
pvs_frame_l
;
apply
wp_strip_pvs
;
wp_let
.
rewrite
!
assoc
2
!
forall_elim
;
eapply
wand_apply_r'
;
first
done
.
rewrite
(
always_sep_dup
(
_
★
_
))
;
apply
sep_mono
.
-
apply
forall_intro
=>
n
.
apply
:
always_intro
.
wp_let
.
eapply
(
wp_inv_timeless
_
_
_
(
one_shot_inv
γ
l
))
;
rewrite
/=
?to_of_val
;
eauto
10
with
I
.
rewrite
(
True_intro
(
inv
_
_
))
right_id
.
apply
wand_intro_r
;
rewrite
sep_or_l
;
apply
or_elim
.
+
rewrite
-
wp_pvs
.
wp
eapply
wp_cas_suc
;
rewrite
/=
?to_of_val
;
eauto
with
I
ndisj
.
rewrite
(
True_intro
(
heap_ctx
_
))
left_id
.
ecancel
[
l
↦
_
]%
I
;
apply
wand_intro_l
.
rewrite
(
own_update
)
;
(* FIXME: canonical structures are not working *)
last
by
apply
(
one_shot_update_shoot
(
DecAgree
n
:
dec_agreeR
_
)).
rewrite
pvs_frame_l
;
apply
pvs_mono
,
sep_intro_True_r
;
eauto
with
I
.
rewrite
/
one_shot_inv
-
or_intro_r
-(
exist_intro
n
).
solve_sep_entails
.
+
rewrite
sep_exist_l
;
apply
exist_elim
=>
m
.
eapply
wp_cas_fail
with
(
v'
:
=
InjRV
#
m
)
(
q
:
=
1
%
Qp
)
;
rewrite
/=
?to_of_val
;
eauto
with
I
ndisj
;
strip_later
.
ecancel
[
l
↦
_
]%
I
;
apply
wand_intro_l
,
sep_intro_True_r
;
eauto
with
I
.
rewrite
/
one_shot_inv
-
or_intro_r
-(
exist_intro
m
).
solve_sep_entails
.
-
apply
:
always_intro
.
wp_seq
.
wp_focus
(
Load
(%
l
))%
I
.
eapply
(
wp_inv_timeless
_
_
_
(
one_shot_inv
γ
l
))
;
rewrite
/=
?to_of_val
;
eauto
10
with
I
.
apply
wand_intro_r
.
trans
(
heap_ctx
heapN
★
inv
N
(
one_shot_inv
γ
l
)
★
∃
v
,
l
↦
v
★
((
v
=
InjLV
#
0
★
own
γ
OneShotPending
)
∨
∃
n
:
Z
,
v
=
InjRV
#
n
★
own
γ
(
Shot
(
DecAgree
n
))))%
I
.
{
rewrite
assoc
.
apply
sep_mono_r
,
or_elim
.
+
rewrite
-(
exist_intro
(
InjLV
#
0
)).
rewrite
-
or_intro_l
const_equiv
//.
solve_sep_entails
.
+
apply
exist_elim
=>
n
.
rewrite
-(
exist_intro
(
InjRV
#
n
))
-(
exist_intro
n
).
apply
sep_mono_r
,
or_intro_r'
,
sep_intro_True_l
;
eauto
with
I
.
}
rewrite
!
sep_exist_l
;
apply
exist_elim
=>
w
.
eapply
wp_load
with
(
q
:
=
1
%
Qp
)
(
v
:
=
w
)
;
eauto
with
I
ndisj
.
rewrite
-
later_intro
;
cancel
[
l
↦
w
]%
I
.
rewrite
-
later_intro
;
apply
wand_intro_l
.
trans
(
heap_ctx
heapN
★
inv
N
(
one_shot_inv
γ
l
)
★
one_shot_inv
γ
l
★
(
w
=
InjLV
#
0
∨
(
∃
n
:
Z
,
w
=
InjRV
#
n
★
own
γ
(
Shot
(
DecAgree
n
)))))%
I
.
{
cancel
[
heap_ctx
heapN
].
rewrite
!
sep_or_l
;
apply
or_elim
.
+
rewrite
-
or_intro_l
.
ecancel
[
inv
_
_
]%
I
.
rewrite
[(
_
★
_
)%
I
]
comm
-
assoc
.
apply
const_elim_sep_l
=>->.
rewrite
const_equiv
//
right_id
/
one_shot_inv
-
or_intro_l
.
solve_sep_entails
.
+
rewrite
-
or_intro_r
!
sep_exist_l
;
apply
exist_elim
=>
n
.
rewrite
-(
exist_intro
n
).
ecancel
[
inv
_
_
]%
I
.
rewrite
[(
_
★
_
)%
I
]
comm
-
assoc
.
apply
const_elim_sep_l
=>->.
rewrite
const_equiv
//
left_id
/
one_shot_inv
-
or_intro_r
.
rewrite
-(
exist_intro
n
)
{
1
}(
always_sep_dup
(
own
_
_
)).
solve_sep_entails
.
}
cancel
[
one_shot_inv
γ
l
].
(* FIXME: why aren't laters stripped? *)
wp_let
.
rewrite
-
later_intro
.
apply
:
always_intro
.
wp_seq
.
rewrite
-
later_intro
.
rewrite
!
sep_or_l
;
apply
or_elim
.
{
rewrite
assoc
.
apply
const_elim_sep_r
=>->.
wp_case
;
wp_seq
;
eauto
with
I
.
}
rewrite
!
sep_exist_l
;
apply
exist_elim
=>
n
.
rewrite
[(
w
=
_
★
_
)%
I
]
comm
!
assoc
;
apply
const_elim_sep_r
=>->.
(* FIXME: why do we need to fold? *)
wp_case
;
fold
of_val
.
wp_let
.
wp_focus
(
Load
(%
l
))%
I
.
eapply
(
wp_inv_timeless
_
_
_
(
one_shot_inv
γ
l
))
;
rewrite
/=
?to_of_val
;
eauto
10
with
I
.
rewrite
(
True_intro
(
inv
_
_
))
right_id
.
apply
wand_intro_r
;
rewrite
sep_or_l
;
apply
or_elim
.
+
rewrite
(
True_intro
(
heap_ctx
_
))
(
True_intro
(
l
↦
_
))
!
left_id
.
rewrite
-
own_op
own_valid_l
one_shot_validI
/=
left_absorb
.
apply
False_elim
.
+
rewrite
!
sep_exist_l
;
apply
exist_elim
=>
m
.
eapply
wp_load
with
(
q
:
=
1
%
Qp
)
(
v
:
=
InjRV
#
m
)
;
eauto
with
I
ndisj
;
strip_later
.
cancel
[
l
↦
InjRV
#
m
]%
I
.
apply
wand_intro_r
.
rewrite
(
True_intro
(
heap_ctx
heapN
))
left_id
.
rewrite
-
own_op
own_valid_l
one_shot_validI
Shot_op
/=
discrete_valid
.
rewrite
-
assoc
.
apply
const_elim_sep_l
=>
/
dec_agree_op_inv
[->].
rewrite
dec_agree_idemp
.
apply
sep_intro_True_r
.
{
rewrite
/
one_shot_inv
-
or_intro_r
-(
exist_intro
m
).
solve_sep_entails
.
}
wp_case
;
fold
of_val
.
wp_let
.
rewrite
-
wp_assert'
.
wp_op
;
by
eauto
using
later_intro
with
I
.
Qed
.
Lemma
hoare_one_shot
(
Φ
:
val
→
iProp
)
:
heap_ctx
heapN
⊢
{{
True
}}
one_shot_example
#()
{{
λ
ff
,
(
∀
n
:
Z
,
{{
True
}}
Fst
ff
#
n
{{
λ
w
,
w
=
#
true
∨
w
=
#
false
}})
★
{{
True
}}
Snd
ff
#()
{{
λ
g
,
{{
True
}}
g
#()
{{
λ
_
,
True
}}
}}
}}.
Proof
.
apply
:
always_intro
;
rewrite
left_id
-
wp_one_shot
/=.
cancel
[
heap_ctx
heapN
].
apply
forall_intro
=>
f1
;
apply
forall_intro
=>
f2
.
apply
wand_intro_l
;
rewrite
right_id
;
apply
sep_mono
.
-
apply
forall_mono
=>
n
.
apply
always_mono
;
rewrite
left_id
.
by
wp_proj
.
-
apply
always_mono
;
rewrite
left_id
.
wp_proj
.
apply
wp_mono
=>
v
.
by
apply
always_mono
;
rewrite
left_id
.
Qed
.
End
proof
.
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