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
3dd3c5c7
Commit
3dd3c5c7
authored
Feb 02, 2016
by
Ralf Jung
Browse files
Merge branch 'v2.0' of gitlab.mpi-sws.org:FP/iris-coq into v2.0
parents
bb499fdd
b91562fe
Changes
11
Expand all
Hide whitespace changes
Inline
Side-by-side
_CoqProject
View file @
3dd3c5c7
...
...
@@ -64,6 +64,7 @@ iris/language.v
iris/functor.v
iris/tests.v
barrier/heap_lang.v
barrier/heap_lang_tactics.v
barrier/lifting.v
barrier/sugar.v
barrier/tests.v
barrier/heap_lang.v
View file @
3dd3c5c7
This diff is collapsed.
Click to expand it.
barrier/heap_lang_tactics.v
0 → 100644
View file @
3dd3c5c7
Require
Export
barrier
.
heap_lang
.
Require
Import
prelude
.
fin_maps
.
Import
heap_lang
.
Ltac
inv_step
:
=
repeat
match
goal
with
|
_
=>
progress
simplify_map_equality'
(* simplify memory stuff *)
|
H
:
to_val
_
=
Some
_
|-
_
=>
apply
of_to_val
in
H
|
H
:
context
[
to_val
(
of_val
_
)]
|-
_
=>
rewrite
to_of_val
in
H
|
H
:
prim_step
_
_
_
_
_
|-
_
=>
destruct
H
;
subst
|
H
:
_
=
fill
?K
?e
|-
_
=>
destruct
K
as
[|[]]
;
simpl
in
H
;
first
[
subst
e
|
discriminate
H
|
injection'
H
]
(* ensure that we make progress for each subgoal *)
|
H
:
head_step
?e
_
_
_
_
,
Hv
:
of_val
?v
=
fill
?K
?e
|-
_
=>
apply
values_head_stuck
,
(
fill_not_val
K
)
in
H
;
by
rewrite
-
Hv
to_of_val
in
H
(* maybe use a helper lemma here? *)
|
H
:
head_step
?e
_
_
_
_
|-
_
=>
try
(
is_var
e
;
fail
1
)
;
(* inversion yields many goals if e is a variable
and can thus better be avoided. *)
inversion
H
;
subst
;
clear
H
end
.
Ltac
reshape_expr
e
tac
:
=
let
rec
go
K
e
:
=
match
e
with
|
_
=>
tac
(
reverse
K
)
e
|
App
?e1
?e2
=>
lazymatch
e1
with
|
of_val
?v1
=>
go
(
AppRCtx
v1
::
K
)
e2
|
_
=>
go
(
AppLCtx
e2
::
K
)
e1
end
|
Plus
?e1
?e2
=>
lazymatch
e1
with
|
of_val
?v1
=>
go
(
PlusRCtx
v1
::
K
)
e2
|
_
=>
go
(
PlusLCtx
e2
::
K
)
e1
end
|
Le
?e1
?e2
=>
lazymatch
e1
with
|
of_val
?v1
=>
go
(
LeRCtx
v1
::
K
)
e2
|
_
=>
go
(
LeLCtx
e2
::
K
)
e1
end
|
Pair
?e1
?e2
=>
lazymatch
e1
with
|
of_val
?v1
=>
go
(
PairRCtx
v1
::
K
)
e2
|
_
=>
go
(
PairLCtx
e2
::
K
)
e1
end
|
Fst
?e
=>
go
(
FstCtx
::
K
)
e
|
Snd
?e
=>
go
(
SndCtx
::
K
)
e
|
InjL
?e
=>
go
(
InjLCtx
::
K
)
e
|
InjR
?e
=>
go
(
InjRCtx
::
K
)
e
|
Case
?e0
?e1
?e2
=>
go
(
CaseCtx
e1
e2
::
K
)
e0
|
Alloc
?e
=>
go
(
AllocCtx
::
K
)
e
|
Load
?e
=>
go
(
LoadCtx
::
K
)
e
|
Store
?e1
?e2
=>
go
(
StoreLCtx
e2
::
K
)
e1
||
go
(
StoreRCtx
e1
::
K
)
e2
|
Cas
?e0
?e1
?e2
=>
lazymatch
e0
with
|
of_val
?v0
=>
lazymatch
e1
with
|
of_val
?v1
=>
go
(
CasRCtx
v0
v1
::
K
)
e2
|
_
=>
go
(
CasMCtx
v0
e2
::
K
)
e1
end
|
_
=>
go
(
CasLCtx
e1
e2
::
K
)
e0
end
end
in
go
(@
nil
ectx_item
)
e
.
Ltac
do_step
tac
:
=
try
match
goal
with
|-
reducible
_
_
=>
eexists
_
,
_
,
_
end
;
simpl
;
match
goal
with
|
|-
prim_step
?e1
?
σ
1
?e2
?
σ
2
?ef
=>
reshape_expr
e1
ltac
:
(
fun
K
e1'
=>
eapply
Ectx_step
with
K
e1'
_
)
;
[
reflexivity
|
reflexivity
|]
;
first
[
apply
alloc_fresh
|
econstructor
]
;
rewrite
?to_of_val
;
tac
;
fail
end
.
barrier/lifting.v
View file @
3dd3c5c7
Require
Import
prelude
.
gmap
iris
.
lifting
.
Require
Export
iris
.
weakestpre
barrier
.
heap_lang
.
Require
Export
iris
.
weakestpre
barrier
.
heap_lang
_tactics
.
Import
uPred
.
Import
heap_lang
.
Local
Hint
Extern
0
(
reducible
_
_
)
=>
do_step
ltac
:
(
eauto
2
).
Section
lifting
.
Context
{
Σ
:
iFunctor
}.
Implicit
Types
P
:
iProp
heap_lang
Σ
.
Implicit
Types
Q
:
val
heap_lang
→
iProp
heap_lang
Σ
.
Implicit
Types
Q
:
val
→
iProp
heap_lang
Σ
.
Implicit
Types
K
:
ectx
.
(** Bind. *)
Lemma
wp_bind
{
E
e
}
K
Q
:
wp
E
e
(
λ
v
,
wp
E
(
fill
K
(
v2e
v
))
Q
)
⊑
wp
E
(
fill
K
e
)
Q
.
Proof
.
apply
(
wp_bind
(
K
:
=
fill
K
)),
fill_is_ctx
.
Qed
.
wp
E
e
(
λ
v
,
wp
E
(
fill
K
(
of_val
v
))
Q
)
⊑
wp
E
(
fill
K
e
)
Q
.
Proof
.
apply
wp_bind
.
Qed
.
(** Base axioms for core primitives of the language: Stateful reductions. *)
Lemma
wp_lift_step
E1
E2
(
φ
:
expr
→
state
→
Prop
)
Q
e1
σ
1
:
E1
⊆
E2
→
to_val
e1
=
None
→
reducible
e1
σ
1
→
...
...
@@ -23,303 +25,176 @@ Lemma wp_lift_step E1 E2 (φ : expr → state → Prop) Q e1 σ1 :
⊑
wp
E2
e1
Q
.
Proof
.
intros
?
He
Hsafe
Hstep
.
(* RJ: working around https://coq.inria.fr/bugs/show_bug.cgi?id=4536 *)
etransitivity
;
last
eapply
wp_lift_step
with
(
σ
2
:
=
σ
1
)
(
φ
0
:
=
λ
e'
σ
'
ef
,
ef
=
None
∧
φ
e'
σ
'
)
;
last
first
.
-
intros
e2
σ
2
ef
Hstep'
%
prim_ectx_step
;
last
done
.
by
apply
Hstep
.
-
destruct
Hsafe
as
(
e'
&
σ
'
&
?
&
?).
do
3
eexists
.
exists
EmptyCtx
.
do
2
eexists
.
split_ands
;
try
(
by
rewrite
fill_empty
)
;
eassumption
.
-
done
.
-
eassumption
.
-
apply
pvs_mono
.
apply
sep_mono
;
first
done
.
apply
later_mono
.
apply
forall_mono
=>
e2
.
apply
forall_mono
=>
σ
2
.
apply
forall_intro
=>
ef
.
apply
wand_intro_l
.
rewrite
always_and_sep_l'
-
associative
-
always_and_sep_l'
.
apply
const_elim_l
;
move
=>[->
H
φ
].
eapply
const_intro_l
;
first
eexact
H
φ
.
rewrite
always_and_sep_l'
associative
-
always_and_sep_l'
wand_elim_r
.
apply
pvs_mono
.
rewrite
right_id
.
done
.
rewrite
-(
wp_lift_step
E1
E2
(
λ
e'
σ
'
ef
,
ef
=
None
∧
φ
e'
σ
'
)
_
_
σ
1
)
//.
apply
pvs_mono
,
sep_mono
,
later_mono
;
first
done
.
apply
forall_mono
=>
e2
;
apply
forall_mono
=>
σ
2
.
apply
forall_intro
=>
ef
;
apply
wand_intro_l
.
rewrite
always_and_sep_l'
-
associative
-
always_and_sep_l'
.
apply
const_elim_l
=>-[->
?]
/=.
by
rewrite
const_equiv
//
left_id
wand_elim_r
right_id
.
Qed
.
(* TODO RJ: Figure out some better way to make the
postcondition a predicate over a *location* *)
Lemma
wp_alloc_pst
E
σ
e
v
Q
:
e2v
e
=
Some
v
→
(
ownP
σ
★
▷
(
∀
l
,
■
(
σ
!!
l
=
None
)
∧
ownP
(<[
l
:
=
v
]>
σ
)
-
★
Q
(
LocV
l
)))
to_val
e
=
Some
v
→
(
ownP
σ
★
▷
(
∀
l
,
■
(
σ
!!
l
=
None
)
∧
ownP
(<[
l
:
=
v
]>
σ
)
-
★
Q
(
LocV
l
)))
⊑
wp
E
(
Alloc
e
)
Q
.
Proof
.
(* RJ FIXME (also for most other lemmas in this file): rewrite would be nicer... *)
intros
Hvl
.
etransitivity
;
last
eapply
wp_lift_step
with
(
σ
1
:
=
σ
)
(
φ
:
=
λ
e'
σ
'
,
∃
l
,
e'
=
Loc
l
∧
σ
'
=
<[
l
:
=
v
]>
σ
∧
σ
!!
l
=
None
)
;
last
first
.
-
intros
e2
σ
2
ef
Hstep
.
inversion_clear
Hstep
.
split
;
first
done
.
rewrite
Hv
in
Hvl
.
inversion_clear
Hvl
.
eexists
;
split_ands
;
done
.
-
set
(
l
:
=
fresh
$
dom
(
gset
loc
)
σ
).
exists
(
Loc
l
),
((<[
l
:
=
v
]>)
σ
),
None
.
eapply
AllocS
;
first
done
.
apply
(
not_elem_of_dom
(
D
:
=
gset
loc
)).
apply
is_fresh
.
-
reflexivity
.
-
reflexivity
.
-
rewrite
-
pvs_intro
.
apply
sep_mono
;
first
done
.
apply
later_mono
.
apply
forall_intro
=>
e2
.
apply
forall_intro
=>
σ
2
.
apply
wand_intro_l
.
rewrite
-
pvs_intro
.
rewrite
always_and_sep_l'
-
associative
-
always_and_sep_l'
.
apply
const_elim_l
.
intros
[
l
[->
[->
Hl
]]].
rewrite
(
forall_elim
l
).
eapply
const_intro_l
;
first
eexact
Hl
.
rewrite
always_and_sep_l'
associative
-
always_and_sep_l'
wand_elim_r
.
rewrite
-
wp_value'
;
done
.
intros
;
set
(
φ
e'
σ
'
:
=
∃
l
,
e'
=
Loc
l
∧
σ
'
=
<[
l
:
=
v
]>
σ
∧
σ
!!
l
=
None
).
rewrite
-(
wp_lift_step
E
E
φ
_
_
σ
)
//
/
φ
;
last
by
intros
;
inv_step
;
eauto
.
rewrite
-
pvs_intro
.
apply
sep_mono
,
later_mono
;
first
done
.
apply
forall_intro
=>
e2
;
apply
forall_intro
=>
σ
2
;
apply
wand_intro_l
.
rewrite
-
pvs_intro
always_and_sep_l'
-
associative
-
always_and_sep_l'
.
apply
const_elim_l
=>-[
l
[->
[->
?]]].
by
rewrite
(
forall_elim
l
)
const_equiv
//
left_id
wand_elim_r
-
wp_value'
.
Qed
.
Lemma
wp_load_pst
E
σ
l
v
Q
:
σ
!!
l
=
Some
v
→
(
ownP
σ
★
▷
(
ownP
σ
-
★
Q
v
))
⊑
wp
E
(
Load
(
Loc
l
))
Q
.
(
ownP
σ
★
▷
(
ownP
σ
-
★
Q
v
))
⊑
wp
E
(
Load
(
Loc
l
))
Q
.
Proof
.
intros
Hl
.
etransitivity
;
last
eapply
wp_lift_step
with
(
σ
1
:
=
σ
)
(
φ
:
=
λ
e'
σ
'
,
e'
=
v2e
v
∧
σ
'
=
σ
)
;
last
first
.
-
intros
e2
σ
2
ef
Hstep
.
move
:
Hl
.
inversion_clear
Hstep
=>{
σ
}.
rewrite
Hlookup
.
case
=>->.
done
.
-
do
3
eexists
.
econstructor
;
eassumption
.
-
reflexivity
.
-
reflexivity
.
-
rewrite
-
pvs_intro
.
apply
sep_mono
;
first
done
.
apply
later_mono
.
apply
forall_intro
=>
e2
.
apply
forall_intro
=>
σ
2
.
apply
wand_intro_l
.
rewrite
-
pvs_intro
.
rewrite
always_and_sep_l'
-
associative
-
always_and_sep_l'
.
apply
const_elim_l
.
intros
[->
->].
by
rewrite
wand_elim_r
-
wp_value
.
intros
;
rewrite
-(
wp_lift_step
E
E
(
λ
e'
σ
'
,
e'
=
of_val
v
∧
σ
'
=
σ
))
//
;
last
by
intros
;
inv_step
;
eauto
.
rewrite
-
pvs_intro
;
apply
sep_mono
,
later_mono
;
first
done
.
apply
forall_intro
=>
e2
;
apply
forall_intro
=>
σ
2
;
apply
wand_intro_l
.
rewrite
-
pvs_intro
always_and_sep_l'
-
associative
-
always_and_sep_l'
.
apply
const_elim_l
=>-[->
->]
;
by
rewrite
wand_elim_r
-
wp_value
.
Qed
.
Lemma
wp_store_pst
E
σ
l
e
v
v'
Q
:
e2v
e
=
Some
v
→
σ
!!
l
=
Some
v'
→
(
ownP
σ
★
▷
(
ownP
(<[
l
:
=
v
]>
σ
)
-
★
Q
LitUnitV
))
⊑
wp
E
(
Store
(
Loc
l
)
e
)
Q
.
to_val
e
=
Some
v
→
σ
!!
l
=
Some
v'
→
(
ownP
σ
★
▷
(
ownP
(<[
l
:
=
v
]>
σ
)
-
★
Q
LitUnitV
))
⊑
wp
E
(
Store
(
Loc
l
)
e
)
Q
.
Proof
.
intros
Hvl
Hl
.
etransitivity
;
last
eapply
wp_lift_step
with
(
σ
1
:
=
σ
)
(
φ
:
=
λ
e'
σ
'
,
e'
=
LitUnit
∧
σ
'
=
<[
l
:
=
v
]>
σ
)
;
last
first
.
-
intros
e2
σ
2
ef
Hstep
.
move
:
Hl
.
inversion_clear
Hstep
=>{
σ
2
}.
rewrite
Hvl
in
Hv
.
inversion_clear
Hv
.
done
.
-
do
3
eexists
.
eapply
StoreS
;
last
(
eexists
;
eassumption
).
eassumption
.
-
reflexivity
.
-
reflexivity
.
-
rewrite
-
pvs_intro
.
apply
sep_mono
;
first
done
.
apply
later_mono
.
apply
forall_intro
=>
e2
.
apply
forall_intro
=>
σ
2
.
apply
wand_intro_l
.
rewrite
-
pvs_intro
.
rewrite
always_and_sep_l'
-
associative
-
always_and_sep_l'
.
apply
const_elim_l
.
intros
[->
->].
by
rewrite
wand_elim_r
-
wp_value'
.
intros
.
rewrite
-(
wp_lift_step
E
E
(
λ
e'
σ
'
,
e'
=
LitUnit
∧
σ
'
=
<[
l
:
=
v
]>
σ
))
//
;
last
by
intros
;
inv_step
;
eauto
.
rewrite
-
pvs_intro
;
apply
sep_mono
,
later_mono
;
first
done
.
apply
forall_intro
=>
e2
;
apply
forall_intro
=>
σ
2
;
apply
wand_intro_l
.
rewrite
-
pvs_intro
always_and_sep_l'
-
associative
-
always_and_sep_l'
.
apply
const_elim_l
=>-[->
->]
;
by
rewrite
wand_elim_r
-
wp_value'
.
Qed
.
Lemma
wp_cas_fail_pst
E
σ
l
e1
v1
e2
v2
v'
Q
:
e2v
e1
=
Some
v1
→
e2v
e2
=
Some
v2
→
σ
!!
l
=
Some
v'
→
v'
<>
v1
→
(
ownP
σ
★
▷
(
ownP
σ
-
★
Q
LitFalseV
))
⊑
wp
E
(
Cas
(
Loc
l
)
e1
e2
)
Q
.
to_val
e1
=
Some
v1
→
to_val
e2
=
Some
v2
→
σ
!!
l
=
Some
v'
→
v'
≠
v1
→
(
ownP
σ
★
▷
(
ownP
σ
-
★
Q
LitFalseV
))
⊑
wp
E
(
Cas
(
Loc
l
)
e1
e2
)
Q
.
Proof
.
intros
Hvl
Hl
.
etransitivity
;
last
eapply
wp_lift_step
with
(
σ
1
:
=
σ
)
(
φ
:
=
λ
e'
σ
'
,
e'
=
LitFalse
∧
σ
'
=
σ
)
(
E1
:
=
E
)
;
auto
;
last
first
.
-
by
inversion_clear
1
;
simplify_map_equality
.
-
do
3
eexists
;
econstructor
;
eauto
.
-
rewrite
-
pvs_intro
.
apply
sep_mono
;
first
done
.
apply
later_mono
.
apply
forall_intro
=>
e2'
.
apply
forall_intro
=>
σ
2
'
.
apply
wand_intro_l
.
rewrite
-
pvs_intro
.
rewrite
always_and_sep_l'
-
associative
-
always_and_sep_l'
.
apply
const_elim_l
.
intros
[->
->].
by
rewrite
wand_elim_r
-
wp_value'
.
intros
;
rewrite
-(
wp_lift_step
E
E
(
λ
e'
σ
'
,
e'
=
LitFalse
∧
σ
'
=
σ
))
//
;
last
by
intros
;
inv_step
;
eauto
.
rewrite
-
pvs_intro
;
apply
sep_mono
,
later_mono
;
first
done
.
apply
forall_intro
=>
e2'
;
apply
forall_intro
=>
σ
2
;
apply
wand_intro_l
.
rewrite
-
pvs_intro
always_and_sep_l'
-
associative
-
always_and_sep_l'
.
apply
const_elim_l
=>-[->
->]
;
by
rewrite
wand_elim_r
-
wp_value'
.
Qed
.
Lemma
wp_cas_suc_pst
E
σ
l
e1
v1
e2
v2
Q
:
e2v
e1
=
Some
v1
→
e2v
e2
=
Some
v2
→
σ
!!
l
=
Some
v1
→
(
ownP
σ
★
▷
(
ownP
(<[
l
:
=
v2
]>
σ
)
-
★
Q
LitTrueV
))
⊑
wp
E
(
Cas
(
Loc
l
)
e1
e2
)
Q
.
to_val
e1
=
Some
v1
→
to_val
e2
=
Some
v2
→
σ
!!
l
=
Some
v1
→
(
ownP
σ
★
▷
(
ownP
(<[
l
:
=
v2
]>
σ
)
-
★
Q
LitTrueV
))
⊑
wp
E
(
Cas
(
Loc
l
)
e1
e2
)
Q
.
Proof
.
intros
Hvl
Hl
.
etransitivity
;
last
eapply
wp_lift_step
with
(
σ
1
:
=
σ
)
(
φ
:
=
λ
e'
σ
'
,
e'
=
LitTrue
∧
σ
'
=
<[
l
:
=
v2
]>
σ
)
;
last
first
.
-
intros
e2'
σ
2
'
ef
Hstep
.
move
:
H
.
inversion_clear
Hstep
=>
H
.
(* FIXME this rewriting is rather ugly. *)
+
exfalso
.
rewrite
H
in
Hlookup
.
case
:
Hlookup
=>?
;
subst
vl
.
rewrite
Hvl
in
Hv1
.
case
:
Hv1
=>?
;
subst
v1
.
done
.
+
rewrite
H
in
Hlookup
.
case
:
Hlookup
=>?
;
subst
v1
.
rewrite
Hl
in
Hv2
.
case
:
Hv2
=>?
;
subst
v2
.
done
.
-
do
3
eexists
.
eapply
CasSucS
;
eassumption
.
-
reflexivity
.
-
reflexivity
.
-
rewrite
-
pvs_intro
.
apply
sep_mono
;
first
done
.
apply
later_mono
.
apply
forall_intro
=>
e2'
.
apply
forall_intro
=>
σ
2
'
.
apply
wand_intro_l
.
rewrite
-
pvs_intro
.
rewrite
always_and_sep_l'
-
associative
-
always_and_sep_l'
.
apply
const_elim_l
.
intros
[->
->].
by
rewrite
wand_elim_r
-
wp_value'
.
intros
.
rewrite
-(
wp_lift_step
E
E
(
λ
e'
σ
'
,
e'
=
LitTrue
∧
σ
'
=
<[
l
:
=
v2
]>
σ
))
//
;
last
by
intros
;
inv_step
;
eauto
.
rewrite
-
pvs_intro
;
apply
sep_mono
,
later_mono
;
first
done
.
apply
forall_intro
=>
e2'
;
apply
forall_intro
=>
σ
2
;
apply
wand_intro_l
.
rewrite
-
pvs_intro
always_and_sep_l'
-
associative
-
always_and_sep_l'
.
apply
const_elim_l
=>-[->
->]
;
by
rewrite
wand_elim_r
-
wp_value'
.
Qed
.
(** Base axioms for core primitives of the language: Stateless reductions *)
Lemma
wp_fork
E
e
:
▷
wp
coPset_all
e
(
λ
_
,
True
:
iProp
heap_lang
Σ
)
⊑
wp
E
(
Fork
e
)
(
λ
v
,
■
(
v
=
LitUnitV
)).
▷
wp
(
Σ
:
=
Σ
)
coPset_all
e
(
λ
_
,
True
)
⊑
wp
E
(
Fork
e
)
(
λ
v
,
■
(
v
=
LitUnitV
)).
Proof
.
etransitivity
;
last
eapply
wp_lift_pure_step
with
(
φ
:
=
λ
e'
ef
,
e'
=
LitUnit
∧
ef
=
Some
e
)
;
last
first
.
-
intros
σ
1 e2
σ
2
ef
Hstep
%
prim_ectx_step
;
last
first
.
{
do
3
eexists
.
eapply
ForkS
.
}
inversion_clear
Hstep
.
done
.
-
intros
?.
do
3
eexists
.
exists
EmptyCtx
.
do
2
eexists
.
split_ands
;
try
(
by
rewrite
fill_empty
)
;
[].
eapply
ForkS
.
-
reflexivity
.
-
apply
later_mono
.
apply
forall_intro
=>
e2
;
apply
forall_intro
=>
ef
.
apply
impl_intro_l
,
const_elim_l
=>-[->
->]
/=
;
apply
sep_intro_True_l
;
auto
.
by
rewrite
-
wp_value'
//
;
apply
const_intro
.
rewrite
-(
wp_lift_pure_step
E
(
λ
e'
ef
,
e'
=
LitUnit
∧
ef
=
Some
e
))
//=
;
last
by
intros
;
inv_step
;
eauto
.
apply
later_mono
,
forall_intro
=>
e2
;
apply
forall_intro
=>
ef
.
apply
impl_intro_l
,
const_elim_l
=>-[->
->]
/=.
apply
sep_intro_True_l
;
last
done
.
by
rewrite
-
wp_value'
//
;
apply
const_intro
.
Qed
.
Lemma
wp_lift_pure_step
E
(
φ
:
expr
→
Prop
)
Q
e1
:
to_val
e1
=
None
→
(
∀
σ
1
,
reducible
e1
σ
1
)
→
(
∀
σ
1 e2
σ
2
ef
,
prim_step
e1
σ
1 e2
σ
2
ef
→
σ
1
=
σ
2
∧
ef
=
None
∧
φ
e2
)
→
(
▷
∀
e2
,
■
φ
e2
→
wp
E
e2
Q
)
⊑
wp
E
e1
Q
.
Proof
.
intros
He
Hsafe
Hstep
.
(* RJ: working around https://coq.inria.fr/bugs/show_bug.cgi?id=4536 *)
etransitivity
;
last
eapply
wp_lift_pure_step
with
(
φ
0
:
=
λ
e'
ef
,
ef
=
None
∧
φ
e'
)
;
last
first
.
-
intros
σ
1 e2
σ
2
ef
Hstep'
%
prim_ectx_step
;
last
done
.
by
apply
Hstep
.
-
intros
σ
1
.
destruct
(
Hsafe
σ
1
)
as
(
e'
&
σ
'
&
?
&
?).
do
3
eexists
.
exists
EmptyCtx
.
do
2
eexists
.
split_ands
;
try
(
by
rewrite
fill_empty
)
;
eassumption
.
-
done
.
-
apply
later_mono
.
apply
forall_mono
=>
e2
.
apply
forall_intro
=>
ef
.
apply
impl_intro_l
.
apply
const_elim_l
;
move
=>[->
H
φ
].
eapply
const_intro_l
;
first
eexact
H
φ
.
rewrite
impl_elim_r
.
rewrite
right_id
.
done
.
intros
;
rewrite
-(
wp_lift_pure_step
E
(
λ
e'
ef
,
ef
=
None
∧
φ
e'
))
//=.
apply
later_mono
,
forall_mono
=>
e2
;
apply
forall_intro
=>
ef
.
apply
impl_intro_l
,
const_elim_l
=>-[->
?]
/=.
by
rewrite
const_equiv
//
left_id
right_id
.
Qed
.
Lemma
wp_rec
E
ef
e
v
Q
:
e2v
e
=
Some
v
→
▷
wp
E
ef
.[
Rec
ef
,
e
/]
Q
⊑
wp
E
(
App
(
Rec
ef
)
e
)
Q
.
to_val
e
=
Some
v
→
▷
wp
E
ef
.[
Rec
ef
,
e
/]
Q
⊑
wp
E
(
App
(
Rec
ef
)
e
)
Q
.
Proof
.
etransitivity
;
last
eapply
wp_lift_pure_step
with
(
φ
:
=
λ
e'
,
e'
=
ef
.[
Rec
ef
,
e
/])
;
last
first
.
-
intros
?
?
?
?
Hstep
.
inversion_clear
Hstep
.
done
.
-
intros
?.
do
3
eexists
.
eapply
BetaS
;
eassumption
.
-
reflexivity
.
-
apply
later_mono
,
forall_intro
=>
e2
.
apply
impl_intro_l
.
apply
const_elim_l
=>->.
done
.
intros
;
rewrite
-(
wp_lift_pure_step
E
(
λ
e'
,
e'
=
ef
.[
Rec
ef
,
e
/])
Q
(
App
(
Rec
ef
)
e
))
//=
;
last
by
intros
;
inv_step
;
eauto
.
by
apply
later_mono
,
forall_intro
=>
e2
;
apply
impl_intro_l
,
const_elim_l
=>->.
Qed
.
Lemma
wp_plus
n1
n2
E
Q
:
▷
Q
(
LitNatV
(
n1
+
n2
))
⊑
wp
E
(
Plus
(
LitNat
n1
)
(
LitNat
n2
))
Q
.
Lemma
wp_plus
E
n1
n2
Q
:
▷
Q
(
LitNatV
(
n1
+
n2
))
⊑
wp
E
(
Plus
(
LitNat
n1
)
(
LitNat
n2
))
Q
.
Proof
.
etransitivity
;
last
eapply
wp_lift_pure_step
with
(
φ
:
=
λ
e'
,
e'
=
LitNat
(
n1
+
n2
))
;
last
first
.
-
intros
?
?
?
?
Hstep
.
inversion_clear
Hstep
;
done
.
-
intros
?.
do
3
eexists
.
econstructor
.
-
reflexivity
.
-
apply
later_mono
,
forall_intro
=>
e2
.
apply
impl_intro_l
.
apply
const_elim_l
=>->.
rewrite
-
wp_value'
;
last
reflexivity
;
done
.
rewrite
-(
wp_lift_pure_step
E
(
λ
e'
,
e'
=
LitNat
(
n1
+
n2
)))
//=
;
last
by
intros
;
inv_step
;
eauto
.
apply
later_mono
,
forall_intro
=>
e2
;
apply
impl_intro_l
,
const_elim_l
=>->.
by
rewrite
-
wp_value'
.
Qed
.
Lemma
wp_le_true
n1
n2
E
Q
:
Lemma
wp_le_true
E
n1
n2
Q
:
n1
≤
n2
→
▷
Q
LitTrueV
⊑
wp
E
(
Le
(
LitNat
n1
)
(
LitNat
n2
))
Q
.
▷
Q
LitTrueV
⊑
wp
E
(
Le
(
LitNat
n1
)
(
LitNat
n2
))
Q
.
Proof
.
intros
Hle
.
etransitivity
;
last
eapply
wp_lift_pure_step
with
(
φ
:
=
λ
e'
,
e'
=
LitTrue
)
;
last
first
.
-
intros
?
?
?
?
Hstep
.
inversion_clear
Hstep
;
first
done
.
exfalso
.
eapply
le_not_gt
with
(
n
:
=
n1
)
;
eassumption
.
-
intros
?.
do
3
eexists
.
econstructor
;
done
.
-
reflexivity
.
-
apply
later_mono
,
forall_intro
=>
e2
.
apply
impl_intro_l
.
apply
const_elim_l
=>->.
rewrite
-
wp_value'
;
last
reflexivity
;
done
.
intros
;
rewrite
-(
wp_lift_pure_step
E
(
λ
e'
,
e'
=
LitTrue
))
//=
;
last
by
intros
;
inv_step
;
eauto
with
lia
.
apply
later_mono
,
forall_intro
=>
e2
;
apply
impl_intro_l
,
const_elim_l
=>->.
by
rewrite
-
wp_value'
.
Qed
.
Lemma
wp_le_false
n1
n2
E
Q
:
Lemma
wp_le_false
E
n1
n2
Q
:
n1
>
n2
→
▷
Q
LitFalseV
⊑
wp
E
(
Le
(
LitNat
n1
)
(
LitNat
n2
))
Q
.
▷
Q
LitFalseV
⊑
wp
E
(
Le
(
LitNat
n1
)
(
LitNat
n2
))
Q
.
Proof
.
intros
Hle
.
etransitivity
;
last
eapply
wp_lift_pure_step
with
(
φ
:
=
λ
e'
,
e'
=
LitFalse
)
;
last
first
.
-
intros
?
?
?
?
Hstep
.
inversion_clear
Hstep
;
last
done
.
exfalso
.
eapply
le_not_gt
with
(
n
:
=
n1
)
;
eassumption
.
-
intros
?.
do
3
eexists
.
econstructor
;
done
.
-
reflexivity
.
-
apply
later_mono
,
forall_intro
=>
e2
.
apply
impl_intro_l
.
apply
const_elim_l
=>->.
rewrite
-
wp_value'
;
last
reflexivity
;
done
.
intros
;
rewrite
-(
wp_lift_pure_step
E
(
λ
e'
,
e'
=
LitFalse
))
//=
;
last
by
intros
;
inv_step
;
eauto
with
lia
.
apply
later_mono
,
forall_intro
=>
e2
;
apply
impl_intro_l
,
const_elim_l
=>->.
by
rewrite
-
wp_value'
.
Qed
.
Lemma
wp_fst
e1
v1
e2
v2
E
Q
:
e2v
e1
=
Some
v1
→
e2v
e2
=
Some
v2
→
Lemma
wp_fst
E
e1
v1
e2
v2
Q
:
to_val
e1
=
Some
v1
→
to_val
e2
=
Some
v2
→
▷
Q
v1
⊑
wp
E
(
Fst
(
Pair
e1
e2
))
Q
.
Proof
.
intros
Hv1
Hv2
.
etransitivity
;
last
eapply
wp_lift_pure_step
with
(
φ
:
=
λ
e'
,
e'
=
e1
)
;
last
first
.
-
intros
?
?
?
?
Hstep
.
inversion_clear
Hstep
.
done
.
-
intros
?.
do
3
eexists
.
econstructor
;
eassumption
.
-
reflexivity
.
-
apply
later_mono
,
forall_intro
=>
e2'
.
apply
impl_intro_l
.
apply
const_elim_l
=>->.
rewrite
-
wp_value'
;
last
eassumption
;
done
.
intros
;
rewrite
-(
wp_lift_pure_step
E
(
λ
e'
,
e'
=
e1
))
//=
;
last
by
intros
;
inv_step
;
eauto
.
apply
later_mono
,
forall_intro
=>
e2'
;
apply
impl_intro_l
,
const_elim_l
=>->.
by
rewrite
-
wp_value'
.
Qed
.
Lemma
wp_snd
e1
v1
e2
v2
E
Q
:
e2v
e1
=
Some
v1
→
e2v
e2
=
Some
v2
→
▷
Q
v2
⊑
wp
E
(
Snd
(
Pair
e1
e2
))
Q
.
Lemma
wp_snd
E
e1
v1
e2
v2
Q
:
to_val
e1
=
Some
v1
→
to_val
e2
=
Some
v2
→
▷
Q
v2
⊑
wp
E
(
Snd
(
Pair
e1
e2
))
Q
.
Proof
.
intros
Hv1
Hv2
.
etransitivity
;
last
eapply
wp_lift_pure_step
with
(
φ
:
=
λ
e'
,
e'
=
e2
)
;
last
first
.
-
intros
?
?
?
?
Hstep
.
inversion_clear
Hstep
;
done
.
-
intros
?.
do
3
eexists
.
econstructor
;
eassumption
.
-
reflexivity
.
-
apply
later_mono
,
forall_intro
=>
e2'
.
apply
impl_intro_l
.
apply
const_elim_l
=>->.
rewrite
-
wp_value'
;
last
eassumption
;
done
.
intros
;
rewrite
-(
wp_lift_pure_step
E
(
λ
e'
,
e'
=
e2
))
//=
;
last
by
intros
;
inv_step
;
eauto
.
apply
later_mono
,
forall_intro
=>
e2'
;
apply
impl_intro_l
,
const_elim_l
=>->.
by
rewrite
-
wp_value'
.
Qed
.
Lemma
wp_case_inl
e0
v0
e1
e2
E
Q
:
e2v
e0
=
Some
v0
→
▷
wp
E
e1
.[
e0
/]
Q
⊑
wp
E
(
Case
(
InjL
e0
)
e1
e2
)
Q
.
Lemma
wp_case_inl
E
e0
v0
e1
e2
Q
:
to_val
e0
=
Some
v0
→
▷
wp
E
e1
.[
e0
/]
Q
⊑
wp
E
(
Case
(
InjL
e0
)
e1
e2
)
Q
.
Proof
.
intros
Hv0
.
etransitivity
;
last
eapply
wp_lift_pure_step
with
(
φ
:
=
λ
e'
,
e'
=
e1
.[
e0
/])
;
last
first
.
-
intros
?
?
?
?
Hstep
.
inversion_clear
Hstep
;
done
.
-
intros
?.
do
3
eexists
.
econstructor
;
eassumption
.
-
reflexivity
.
-
apply
later_mono
,
forall_intro
=>
e1'
.
apply
impl_intro_l
.
by
apply
const_elim_l
=>->.
intros
;
rewrite
-(
wp_lift_pure_step
E
(
λ
e'
,
e'
=
e1
.[
e0
/])
_
(
Case
(
InjL
e0
)
e1
e2
))
//=
;
last
by
intros
;
inv_step
;
eauto
.
by
apply
later_mono
,
forall_intro
=>
e1'
;
apply
impl_intro_l
,
const_elim_l
=>->.
Qed
.
Lemma
wp_case_inr
e0
v0
e1
e2
E
Q
:
e2v
e0
=
Some
v0
→
▷
wp
E
e2
.[
e0
/]
Q
⊑
wp
E
(
Case
(
InjR
e0
)
e1
e2
)
Q
.
Lemma
wp_case_inr
E
e0
v0
e1
e2
Q
:
to_val
e0
=
Some
v0
→
▷
wp
E
e2
.[
e0
/]
Q
⊑
wp
E
(
Case
(
InjR
e0
)
e1
e2
)
Q
.
Proof
.
intros
Hv0
.
etransitivity
;
last
eapply
wp_lift_pure_step
with
(
φ
:
=
λ
e'
,
e'
=
e2
.[
e0
/])
;
last
first
.
-
intros
?
?
?
?
Hstep
.
inversion_clear
Hstep
;
done
.
-
intros
?.
do
3
eexists
.
econstructor
;
eassumption
.
-
reflexivity
.
-
apply
later_mono
,
forall_intro
=>
e2'
.
apply
impl_intro_l
.
by
apply
const_elim_l
=>->.
intros
;
rewrite
-(
wp_lift_pure_step
E
(
λ
e'
,
e'
=
e2
.[
e0
/])
_
(
Case
(
InjR
e0
)
e1
e2
))
//=
;
last
by
intros
;
inv_step
;
eauto
.
by
apply
later_mono
,
forall_intro
=>
e1'
;
apply
impl_intro_l
,
const_elim_l
=>->.
Qed
.
(** Some derived stateless axioms *)
Lemma
wp_le
n1
n2
E
P
Q
:
(
n1
≤
n2
→
P
⊑
▷
Q
LitTrueV
)
→
(
n1
>
n2
→
P
⊑
▷
Q
LitFalseV
)
→
Lemma
wp_le
E
n1
n2
P
Q
:
(
n1
≤
n2
→
P
⊑
▷
Q
LitTrueV
)
→
(
n1
>
n2
→
P
⊑
▷
Q
LitFalseV
)
→
P
⊑
wp
E
(
Le
(
LitNat
n1
)
(
LitNat
n2
))
Q
.
Proof
.
intros
HPle
HPgt
.
assert
(
Decision
(
n1
≤
n2
))
as
Hn12
by
apply
_
.
destruct
Hn12
as
[
Hle
|
Hgt
].
-
rewrite
-
wp_le_true
;
auto
.
-
assert
(
n1
>
n2
)
by
omega
.
rewrite
-
wp_le_false
;
auto
.
intros
;
destruct
(
decide
(
n1
≤
n2
)).
*
rewrite
-
wp_le_true
;
auto
.
*
rewrite
-
wp_le_false
;
auto
with
lia
.