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
C
c
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
Iris
c
Commits
bfa32cfe
Commit
bfa32cfe
authored
Nov 16, 2018
by
Robbert Krebbers
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Rename stuff to be consistent with the paper.
parent
81137d7c
Changes
19
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
19 changed files
with
659 additions
and
659 deletions
+659
-659
theories/c_translation/monad.v
theories/c_translation/monad.v
+108
-108
theories/c_translation/proofmode.v
theories/c_translation/proofmode.v
+39
-39
theories/c_translation/translation.v
theories/c_translation/translation.v
+252
-252
theories/tests/basics.v
theories/tests/basics.v
+23
-23
theories/tests/binop.v
theories/tests/binop.v
+2
-2
theories/tests/fact.v
theories/tests/fact.v
+12
-12
theories/tests/gcd.v
theories/tests/gcd.v
+12
-12
theories/tests/invoke.v
theories/tests/invoke.v
+12
-12
theories/tests/lists.v
theories/tests/lists.v
+56
-56
theories/tests/memcpy.v
theories/tests/memcpy.v
+11
-11
theories/tests/par_inc.v
theories/tests/par_inc.v
+11
-11
theories/tests/swap.v
theories/tests/swap.v
+15
-15
theories/tests/unknowns.v
theories/tests/unknowns.v
+9
-9
theories/vcgen/dcexpr.v
theories/vcgen/dcexpr.v
+7
-7
theories/vcgen/denv.v
theories/vcgen/denv.v
+6
-6
theories/vcgen/forward.v
theories/vcgen/forward.v
+13
-13
theories/vcgen/proofmode.v
theories/vcgen/proofmode.v
+5
-5
theories/vcgen/reification.v
theories/vcgen/reification.v
+7
-7
theories/vcgen/vcg.v
theories/vcgen/vcg.v
+59
-59
No files found.
theories/c_translation/monad.v
View file @
bfa32cfe
...
...
@@ -7,27 +7,27 @@ From iris_c.lib Require Import mset flock.
(* M A := ref (list loc) → Mutex → A *)
(* A → M A *)
Definition
a
_ret
:
val
:
=
λ
:
"a"
<>
<>,
"a"
.
Definition
c
_ret
:
val
:
=
λ
:
"a"
<>
<>,
"a"
.
(* (A → M B) → M A → M B *)
Definition
a
_bind
:
val
:
=
λ
:
"x"
"f"
"env"
"l"
,
Definition
c
_bind
:
val
:
=
λ
:
"x"
"f"
"env"
"l"
,
let
:
"a"
:
=
"x"
"env"
"l"
in
"f"
"a"
"env"
"l"
.
Notation
"x ←ᶜ y ;;ᶜ z"
:
=
(
a
_bind
y
(
λ
:
x
,
z
))%
E
(
c
_bind
y
(
λ
:
x
,
z
))%
E
(
at
level
100
,
y
at
next
level
,
z
at
level
200
,
right
associativity
)
:
expr_scope
.
Notation
"y ;;ᶜ z"
:
=
(
a
_bind
y
(
λ
:
<>,
z
))%
E
Notation
"y ;;ᶜ z"
:
=
(
c
_bind
y
(
λ
:
<>,
z
))%
E
(
at
level
100
,
z
at
level
200
,
right
associativity
)
:
expr_scope
.
(* M A → A *)
Definition
a
_run
:
val
:
=
λ
:
"x"
,
Definition
c
_run
:
val
:
=
λ
:
"x"
,
let
:
"env"
:
=
mset_create
#()
in
let
:
"l"
:
=
newlock
#()
in
"x"
"env"
"l"
.
(* M A → M A *)
Definition
a
_atomic
:
val
:
=
λ
:
"x"
"env"
"l"
,
Definition
c
_atomic
:
val
:
=
λ
:
"x"
"env"
"l"
,
acquire
"l"
;;
let
:
"k"
:
=
newlock
#()
in
let
:
"a"
:
=
"x"
#()
"env"
"k"
in
...
...
@@ -35,28 +35,28 @@ Definition a_atomic : val := λ: "x" "env" "l",
"a"
.
(* (ref (list loc) → A) → M A *)
Definition
a
_atomic_env
:
val
:
=
λ
:
"f"
"env"
"l"
,
Definition
c
_atomic_env
:
val
:
=
λ
:
"f"
"env"
"l"
,
acquire
"l"
;;
let
:
"a"
:
=
"f"
"env"
in
release
"l"
;;
"a"
.
(* M A → M B → M (A * B) *)
Definition
a
_par
:
val
:
=
λ
:
"x"
"y"
"env"
"l"
,
Definition
c
_par
:
val
:
=
λ
:
"x"
"y"
"env"
"l"
,
"x"
"env"
"l"
|||
"y"
"env"
"l"
.
Notation
"e1 |||ᶜ e2"
:
=
(
a
_par
e1
e2
)%
E
(
at
level
50
)
:
expr_scope
.
Notation
"e1 |||ᶜ e2"
:
=
(
c
_par
e1
e2
)%
E
(
at
level
50
)
:
expr_scope
.
Definition
a
monadN
:
=
nroot
.@
"amonad"
.
Definition
c
monadN
:
=
nroot
.@
"amonad"
.
Class
a
monadG
(
Σ
:
gFunctors
)
:
=
AMonadG
{
Class
c
monadG
(
Σ
:
gFunctors
)
:
=
AMonadG
{
aheapG
:
>
heapG
Σ
;
aflockG
:
>
flockG
Σ
;
alocking_heapG
:
>
locking_heapG
Σ
;
aspawnG
:
>
spawnG
Σ
}.
Section
a_
wp
.
Context
`
{
a
monadG
Σ
}.
Section
c
wp
.
Context
`
{
c
monadG
Σ
}.
Definition
env_inv
(
env
:
val
)
:
iProp
Σ
:
=
(
∃
(
X
:
gset
val
)
(
σ
:
gmap
cloc
(
lvl
*
val
)),
...
...
@@ -65,70 +65,70 @@ Section a_wp.
full_locking_heap
σ
)%
I
.
Definition
flock_resources
(
γ
:
flock_name
)
(
I
:
gmap
prop_id
lock_res
)
:
=
([
∗
map
]
i
↦
X
∈
I
,
flock_res
a
monadN
γ
i
X
)%
I
.
([
∗
map
]
i
↦
X
∈
I
,
flock_res
c
monadN
γ
i
X
)%
I
.
(** DF: The outer `WP` here is needed to be able to perform some reductions inside a heap_lang context.
Without this, the `
a_wp_a
wp` rule is not provable.
Without this, the `
cwp_c
wp` rule is not provable.
My intuitive explanation: we want to preform some reductions to `e` until it is actually a value that is a monadic computation.
In some sense it is a form of CPSing on a logical level.
But I still cannot precisely state why is it needed.
*)
Definition
a
wp_def
(
e
:
expr
)
Definition
c
wp_def
(
e
:
expr
)
(
R
:
iProp
Σ
)
(
Φ
:
val
→
iProp
Σ
)
:
iProp
Σ
:
=
WP
e
{{
ev
,
∀
(
γ
:
flock_name
)
(
env
:
val
)
(
l
:
val
)
(
I
:
gmap
prop_id
lock_res
),
is_flock
a
monadN
γ
l
-
∗
is_flock
c
monadN
γ
l
-
∗
flock_resources
γ
I
-
∗
([
∗
map
]
X
∈
I
,
res_prop
X
)
≡
(
env_inv
env
∗
R
)
-
∗
WP
ev
env
l
{{
v
,
Φ
v
∗
flock_resources
γ
I
}}
}}%
I
.
Definition
awp_aux
:
seal
(@
a
wp_def
).
by
eexists
.
Qed
.
Definition
awp
:
=
unseal
a
wp_aux
.
Definition
awp_eq
:
@
awp
=
@
awp_def
:
=
seal_eq
a
wp_aux
.
End
a_
wp
.
Definition
cwp_aux
:
seal
(@
c
wp_def
).
by
eexists
.
Qed
.
Definition
cwp
:
=
unseal
c
wp_aux
.
Definition
cwp_eq
:
@
cwp
=
@
cwp_def
:
=
seal_eq
c
wp_aux
.
End
c
wp
.
Notation
"'
AWP' e @ R {{ Φ } }"
:
=
(
a
wp
e
%
E
R
%
I
Φ
)
Notation
"'
CWP' e @ R {{ Φ } }"
:
=
(
c
wp
e
%
E
R
%
I
Φ
)
(
at
level
20
,
e
,
Φ
at
level
200
,
only
parsing
)
:
bi_scope
.
Notation
"'
AWP' e {{ Φ } }"
:
=
(
a
wp
e
%
E
True
%
I
Φ
)
Notation
"'
CWP' e {{ Φ } }"
:
=
(
c
wp
e
%
E
True
%
I
Φ
)
(
at
level
20
,
e
,
Φ
at
level
200
,
only
parsing
)
:
bi_scope
.
Notation
"'
AWP' e @ R {{ v , Q } }"
:
=
(
a
wp
e
%
E
R
%
I
(
λ
v
,
Q
))
Notation
"'
CWP' e @ R {{ v , Q } }"
:
=
(
c
wp
e
%
E
R
%
I
(
λ
v
,
Q
))
(
at
level
20
,
e
,
Q
at
level
200
,
format
"'[' '
A
WP' e '/' '[ ' @ R {{ v , Q } } ']' ']'"
)
:
bi_scope
.
Notation
"'
AWP' e {{ v , Q } }"
:
=
(
a
wp
e
%
E
True
%
I
(
λ
v
,
Q
))
format
"'[' '
C
WP' e '/' '[ ' @ R {{ v , Q } } ']' ']'"
)
:
bi_scope
.
Notation
"'
CWP' e {{ v , Q } }"
:
=
(
c
wp
e
%
E
True
%
I
(
λ
v
,
Q
))
(
at
level
20
,
e
,
Q
at
level
200
,
format
"'[' '
A
WP' e '/' '[ ' {{ v , Q } } ']' ']'"
)
:
bi_scope
.
format
"'[' '
C
WP' e '/' '[ ' {{ v , Q } } ']' ']'"
)
:
bi_scope
.
Section
a_
wp_rules
.
Context
`
{
a
monadG
Σ
}.
Section
c
wp_rules
.
Context
`
{
c
monadG
Σ
}.
Lemma
a_wp_a
wp
R
Φ
Ψ
e
:
A
WP
e
@
R
{{
Φ
}}
-
∗
(
∀
v
:
val
,
A
WP
v
@
R
{{
Φ
}}
-
∗
Ψ
v
)
-
∗
Lemma
cwp_
wp
R
Φ
Ψ
e
:
C
WP
e
@
R
{{
Φ
}}
-
∗
(
∀
v
:
val
,
C
WP
v
@
R
{{
Φ
}}
-
∗
Ψ
v
)
-
∗
WP
e
{{
Ψ
}}.
Proof
.
iIntros
"Hwp H"
.
rewrite
a
wp_eq
/=.
iApply
(
wp_wand
with
"Hwp"
).
iIntros
"Hwp H"
.
rewrite
c
wp_eq
/=.
iApply
(
wp_wand
with
"Hwp"
).
iIntros
(
v
)
"Hwp"
.
iApply
"H"
.
by
iApply
wp_value'
.
Qed
.
Lemma
wp_
a
wp_bind
R
Φ
K
e
:
WP
e
{{
v
,
A
WP
(
fill
K
(
of_val
v
))
@
R
{{
Φ
}}
}}
-
∗
A
WP
fill
K
e
@
R
{{
Φ
}}.
Proof
.
rewrite
a
wp_eq
.
by
apply
:
wp_bind
.
Qed
.
Lemma
wp_
c
wp_bind
R
Φ
K
e
:
WP
e
{{
v
,
C
WP
(
fill
K
(
of_val
v
))
@
R
{{
Φ
}}
}}
-
∗
C
WP
fill
K
e
@
R
{{
Φ
}}.
Proof
.
rewrite
c
wp_eq
.
by
apply
:
wp_bind
.
Qed
.
Lemma
wp_
a
wp_bind_inv
R
Φ
K
e
:
A
WP
fill
K
e
@
R
{{
Φ
}}
-
∗
WP
e
{{
v
,
A
WP
fill
K
(
of_val
v
)
@
R
{{
Φ
}}
}}.
Proof
.
rewrite
a
wp_eq
.
by
apply
:
wp_bind_inv
.
Qed
.
Lemma
wp_
c
wp_bind_inv
R
Φ
K
e
:
C
WP
fill
K
e
@
R
{{
Φ
}}
-
∗
WP
e
{{
v
,
C
WP
fill
K
(
of_val
v
)
@
R
{{
Φ
}}
}}.
Proof
.
rewrite
c
wp_eq
.
by
apply
:
wp_bind_inv
.
Qed
.
Lemma
a
wp_insert_res
e
Φ
R1
R2
:
Lemma
c
wp_insert_res
e
Φ
R1
R2
:
▷
R1
-
∗
A
WP
e
@
(
R1
∗
R2
)
{{
v
,
▷
R1
={
⊤
}=
∗
Φ
v
}}
-
∗
A
WP
e
@
R2
{{
Φ
}}.
C
WP
e
@
(
R1
∗
R2
)
{{
v
,
▷
R1
={
⊤
}=
∗
Φ
v
}}
-
∗
C
WP
e
@
R2
{{
Φ
}}.
Proof
.
iIntros
"HR1 H
awp"
.
rewrite
a
wp_eq
.
iApply
(
wp_wand
with
"H
a
wp"
).
iIntros
"HR1 H
cwp"
.
rewrite
c
wp_eq
.
iApply
(
wp_wand
with
"H
c
wp"
).
iIntros
(
v
)
"HΦ"
.
iIntros
(
γ
env
l
I
)
"#Hflock Hres #Heq"
.
iMod
(
flock_res_alloc_strong
_
(
dom
(
gset
prop_id
)
I
)
with
"Hflock HR1"
)
as
(
j
ρ
)
"[% Hres']"
;
first
done
.
...
...
@@ -149,58 +149,58 @@ Section a_wp_rules.
by
iApply
"HΦ"
.
Qed
.
Lemma
a
wp_fupd_wand
e
Φ
Ψ
R
:
A
WP
e
@
R
{{
Φ
}}
-
∗
Lemma
c
wp_fupd_wand
e
Φ
Ψ
R
:
C
WP
e
@
R
{{
Φ
}}
-
∗
(
∀
v
,
Φ
v
={
⊤
}=
∗
Ψ
v
)
-
∗
A
WP
e
@
R
{{
Ψ
}}.
C
WP
e
@
R
{{
Ψ
}}.
Proof
.
iIntros
"Hwp H"
.
rewrite
a
wp_eq
.
iIntros
"Hwp H"
.
rewrite
c
wp_eq
.
iApply
(
wp_wand
with
"Hwp"
)
;
iIntros
(
v
)
"HΦ"
.
iIntros
(
γ
env
l
I
)
"#Hflock Hres #Heq"
.
iApply
wp_fupd
.
iApply
(
wp_wand
with
"[HΦ Hres]"
).
iApply
(
"HΦ"
with
"Hflock Hres Heq"
).
iIntros
(
w
)
"[HΦ $]"
.
by
iApply
"H"
.
Qed
.
Lemma
a
wp_fupd
e
Φ
R
:
AWP
e
@
R
{{
v
,
|={
⊤
}=>
Φ
v
}}
-
∗
A
WP
e
@
R
{{
Φ
}}.
Proof
.
iIntros
"Hwp"
.
iApply
(
a
wp_fupd_wand
with
"Hwp"
)
;
auto
.
Qed
.
Lemma
c
wp_fupd
e
Φ
R
:
CWP
e
@
R
{{
v
,
|={
⊤
}=>
Φ
v
}}
-
∗
C
WP
e
@
R
{{
Φ
}}.
Proof
.
iIntros
"Hwp"
.
iApply
(
c
wp_fupd_wand
with
"Hwp"
)
;
auto
.
Qed
.
Lemma
fupd_
a
wp
e
Φ
R
:
(|={
⊤
}=>
AWP
e
@
R
{{
v
,
Φ
v
}})
-
∗
A
WP
e
@
R
{{
Φ
}}.
Proof
.
rewrite
a
wp_eq
.
by
iIntros
">Hwp"
.
Qed
.
Lemma
fupd_
c
wp
e
Φ
R
:
(|={
⊤
}=>
CWP
e
@
R
{{
v
,
Φ
v
}})
-
∗
C
WP
e
@
R
{{
Φ
}}.
Proof
.
rewrite
c
wp_eq
.
by
iIntros
">Hwp"
.
Qed
.
Lemma
a
wp_wand
e
Φ
Ψ
R
:
A
WP
e
@
R
{{
Φ
}}
-
∗
Lemma
c
wp_wand
e
Φ
Ψ
R
:
C
WP
e
@
R
{{
Φ
}}
-
∗
(
∀
v
,
Φ
v
-
∗
Ψ
v
)
-
∗
A
WP
e
@
R
{{
Ψ
}}.
C
WP
e
@
R
{{
Ψ
}}.
Proof
.
iIntros
"Hwp H"
.
iApply
(
a
wp_fupd_wand
with
"Hwp"
)
;
iIntros
(
v
)
"HΦ !>"
.
iIntros
"Hwp H"
.
iApply
(
c
wp_fupd_wand
with
"Hwp"
)
;
iIntros
(
v
)
"HΦ !>"
.
by
iApply
"H"
.
Qed
.
Lemma
a
wp_pure
K
φ
n
e1
e2
R
Φ
:
Lemma
c
wp_pure
K
φ
n
e1
e2
R
Φ
:
PureExec
φ
n
e1
e2
→
φ
→
▷
^
n
A
WP
(
fill
K
e2
)
@
R
{{
Φ
}}
-
∗
A
WP
(
fill
K
e1
)
@
R
{{
Φ
}}.
▷
^
n
C
WP
(
fill
K
e2
)
@
R
{{
Φ
}}
-
∗
C
WP
(
fill
K
e1
)
@
R
{{
Φ
}}.
Proof
.
iIntros
(?
H
φ
)
"H
awp"
.
iApply
wp_a
wp_bind
.
wp_pure
_
.
by
iApply
wp_
a
wp_bind_inv
.
iIntros
(?
H
φ
)
"H
cwp"
.
iApply
wp_c
wp_bind
.
wp_pure
_
.
by
iApply
wp_
c
wp_bind_inv
.
Qed
.
Lemma
a
wp_ret
e
R
Φ
:
WP
e
{{
Φ
}}
-
∗
AWP
a
_ret
e
@
R
{{
Φ
}}.
Lemma
c
wp_ret
e
R
Φ
:
WP
e
{{
Φ
}}
-
∗
CWP
c
_ret
e
@
R
{{
Φ
}}.
Proof
.
iIntros
"Hwp"
.
rewrite
awp_eq
/
a
wp_def
.
wp_apply
(
wp_wand
with
"Hwp"
).
iIntros
"Hwp"
.
rewrite
cwp_eq
/
c
wp_def
.
wp_apply
(
wp_wand
with
"Hwp"
).
iIntros
(
v
)
"HΦ"
.
wp_lam
.
wp_pures
.
iIntros
(
γ
env
l
I
)
"#Hlock Hres #Heq"
.
wp_pures
.
iFrame
.
Qed
.
Lemma
a
wp_bind
(
f
:
val
)
(
e
:
expr
)
R
Φ
:
AWP
e
@
R
{{
ev
,
A
WP
f
ev
@
R
{{
Φ
}}
}}
-
∗
AWP
a
_bind
e
f
@
R
{{
Φ
}}.
Lemma
c
wp_bind
(
f
:
val
)
(
e
:
expr
)
R
Φ
:
CWP
e
@
R
{{
ev
,
C
WP
f
ev
@
R
{{
Φ
}}
}}
-
∗
CWP
c
_bind
e
f
@
R
{{
Φ
}}.
Proof
.
iIntros
"Hwp"
.
rewrite
awp_eq
/
a
wp_def
.
iIntros
"Hwp"
.
rewrite
cwp_eq
/
c
wp_def
.
wp_apply
(
wp_wand
with
"Hwp"
).
iIntros
(
ev
)
"Hwp"
.
wp_lam
.
wp_pures
.
iIntros
(
γ
env
l
I
)
"#Hflock Hres #Heq"
.
wp_pures
.
wp_bind
(
ev
env
l
).
...
...
@@ -209,11 +209,11 @@ Section a_wp_rules.
iIntros
(
v
)
"H"
.
iApply
(
"H"
with
"Hflock Hres Heq"
).
Qed
.
Lemma
a
wp_atomic
(
ev
:
val
)
R
Φ
:
(
R
-
∗
▷
∃
R'
,
R'
∗
A
WP
ev
#()
@
R'
{{
w
,
R'
-
∗
R
∗
Φ
w
}})
-
∗
AWP
a
_atomic
ev
@
R
{{
Φ
}}.
Lemma
c
wp_atomic
(
ev
:
val
)
R
Φ
:
(
R
-
∗
▷
∃
R'
,
R'
∗
C
WP
ev
#()
@
R'
{{
w
,
R'
-
∗
R
∗
Φ
w
}})
-
∗
CWP
c
_atomic
ev
@
R
{{
Φ
}}.
Proof
.
iIntros
"Hwp"
.
rewrite
awp_eq
/
a
wp_def
.
wp_lam
.
wp_pures
.
iIntros
"Hwp"
.
rewrite
cwp_eq
/
c
wp_def
.
wp_lam
.
wp_pures
.
iIntros
(
γ
env
l
I
)
"#Hlock1 Hres #Heq1"
.
wp_pures
.
wp_apply
(
acquire_flock_spec
with
"[$]"
).
iIntros
"Hfl"
.
...
...
@@ -222,7 +222,7 @@ Section a_wp_rules.
iDestruct
"HI"
as
"[Henv HR]"
.
wp_pures
;
simpl
.
iDestruct
(
"Hwp"
with
"HR"
)
as
(
Q
)
"[HQ Hwp]"
.
wp_apply
(
newflock_spec
a
monadN
)
;
first
done
.
wp_apply
(
newflock_spec
c
monadN
)
;
first
done
.
iIntros
(
k
γ
'
)
"#Hlock2"
.
iMod
(
flock_res_alloc_strong
_
∅
_
_
(
env_inv
env
∗
Q
)%
I
with
"Hlock2 [$HQ $Henv]"
)
as
(
s
ρ
)
"[_ Hres]"
;
first
done
.
wp_let
.
...
...
@@ -242,12 +242,12 @@ Section a_wp_rules.
iIntros
"$"
.
wp_pures
.
iFrame
.
Qed
.
Lemma
a
wp_atomic_env
(
ev
:
val
)
R
Φ
:
Lemma
c
wp_atomic_env
(
ev
:
val
)
R
Φ
:
(
∀
env
,
env_inv
env
-
∗
R
-
∗
WP
ev
env
{{
w
,
▷
(
env_inv
env
∗
R
∗
Φ
w
)
}})
-
∗
AWP
a
_atomic_env
ev
@
R
{{
Φ
}}.
CWP
c
_atomic_env
ev
@
R
{{
Φ
}}.
Proof
.
iIntros
"Hwp"
.
rewrite
awp_eq
/
a
wp_def
.
wp_lam
.
wp_pures
.
iIntros
"Hwp"
.
rewrite
cwp_eq
/
c
wp_def
.
wp_lam
.
wp_pures
.
iIntros
(
γ
env
l
I
)
"#Hlock Hres #Heq"
.
wp_pures
.
wp_apply
(
acquire_flock_spec
with
"[$]"
).
iIntros
"Hfl"
.
...
...
@@ -264,13 +264,13 @@ Section a_wp_rules.
iIntros
"$"
.
wp_pures
.
iFrame
.
Qed
.
Lemma
a
wp_par
Ψ
1
Ψ
2 e1
e2
R
Φ
:
A
WP
e1
@
R
{{
Ψ
1
}}
-
∗
A
WP
e2
@
R
{{
Ψ
2
}}
-
∗
Lemma
c
wp_par
Ψ
1
Ψ
2 e1
e2
R
Φ
:
C
WP
e1
@
R
{{
Ψ
1
}}
-
∗
C
WP
e2
@
R
{{
Ψ
2
}}
-
∗
▷
(
∀
w1
w2
,
Ψ
1
w1
-
∗
Ψ
2
w2
-
∗
▷
Φ
(
w1
,
w2
)%
V
)
-
∗
A
WP
e1
|||
ᶜ
e2
@
R
{{
Φ
}}.
C
WP
e1
|||
ᶜ
e2
@
R
{{
Φ
}}.
Proof
.
iIntros
"Hwp1 Hwp2 HΦ"
.
rewrite
awp_eq
/
a
wp_def
.
iIntros
"Hwp1 Hwp2 HΦ"
.
rewrite
cwp_eq
/
c
wp_def
.
wp_apply
(
wp_wand
with
"Hwp2"
).
iIntros
(
ev2
)
"Hwp2"
.
wp_apply
(
wp_wand
with
"Hwp1"
).
...
...
@@ -299,50 +299,50 @@ Section a_wp_rules.
iApply
(
"HΦ"
with
"[$] [$]"
).
Qed
.
Global
Instance
frame_
a
wp
p
R'
e
R
Φ
Ψ
:
Global
Instance
frame_
c
wp
p
R'
e
R
Φ
Ψ
:
(
∀
v
,
Frame
p
R
(
Φ
v
)
(
Ψ
v
))
→
Frame
p
R
(
AWP
e
@
R'
{{
Φ
}})
(
A
WP
e
@
R'
{{
Ψ
}}).
Frame
p
R
(
CWP
e
@
R'
{{
Φ
}})
(
C
WP
e
@
R'
{{
Ψ
}}).
Proof
.
rewrite
/
Frame
.
iIntros
(
HR
)
"[HR H]"
.
iApply
(
a
wp_wand
with
"H"
).
rewrite
/
Frame
.
iIntros
(
HR
)
"[HR H]"
.
iApply
(
c
wp_wand
with
"H"
).
iIntros
(
v
)
"H"
.
iApply
HR
;
iFrame
.
Qed
.
Global
Instance
is_except_0_
awp
R
e
Φ
:
IsExcept0
(
A
WP
e
@
R
{{
Φ
}}).
Proof
.
rewrite
/
IsExcept0
.
iIntros
"H"
.
iApply
fupd_
a
wp
.
by
iMod
"H"
.
Qed
.
Global
Instance
is_except_0_
cwp
R
e
Φ
:
IsExcept0
(
C
WP
e
@
R
{{
Φ
}}).
Proof
.
rewrite
/
IsExcept0
.
iIntros
"H"
.
iApply
fupd_
c
wp
.
by
iMod
"H"
.
Qed
.
Global
Instance
elim_modal_bupd_
a
wp
p
R
e
P
Φ
:
ElimModal
True
p
false
(|==>
P
)
P
(
AWP
e
@
R
{{
Φ
}})
(
A
WP
e
@
R
{{
Φ
}}).
Global
Instance
elim_modal_bupd_
c
wp
p
R
e
P
Φ
:
ElimModal
True
p
false
(|==>
P
)
P
(
CWP
e
@
R
{{
Φ
}})
(
C
WP
e
@
R
{{
Φ
}}).
Proof
.
rewrite
/
ElimModal
bi
.
intuitionistically_if_elim
;
iIntros
(
_
)
"[HP HR]"
.
iApply
fupd_
a
wp
.
iMod
"HP"
.
by
iApply
"HR"
.
iApply
fupd_
c
wp
.
iMod
"HP"
.
by
iApply
"HR"
.
Qed
.
Global
Instance
elim_modal_fupd_wp
p
R
e
P
Φ
:
ElimModal
True
p
false
(|={
⊤
}=>
P
)
P
(
AWP
e
@
R
{{
Φ
}})
(
A
WP
e
@
R
{{
Φ
}}).
ElimModal
True
p
false
(|={
⊤
}=>
P
)
P
(
CWP
e
@
R
{{
Φ
}})
(
C
WP
e
@
R
{{
Φ
}}).
Proof
.
rewrite
/
ElimModal
bi
.
intuitionistically_if_elim
;
iIntros
(
_
)
"[HP HR]"
.
iApply
fupd_
a
wp
.
iMod
"HP"
.
by
iApply
"HR"
.
iApply
fupd_
c
wp
.
iMod
"HP"
.
by
iApply
"HR"
.
Qed
.
Global
Instance
add_modal_fupd_wp
R
e
P
Φ
:
AddModal
(|={
⊤
}=>
P
)
P
(
A
WP
e
@
R
{{
Φ
}}).
AddModal
(|={
⊤
}=>
P
)
P
(
C
WP
e
@
R
{{
Φ
}}).
Proof
.
rewrite
/
AddModal
.
iIntros
"[>HP H]"
.
by
iApply
"H"
.
Qed
.
End
a_
wp_rules
.
End
c
wp_rules
.
Section
a_
wp_run
.
Section
c
wp_run
.
Context
`
{
heapG
Σ
,
flockG
Σ
,
spawnG
Σ
,
locking_heapPreG
Σ
}.
Lemma
a
wp_run
(
ev
:
val
)
Φ
:
(
∀
`
{
amonadG
Σ
},
A
WP
ev
{{
w
,
Φ
w
}})
-
∗
WP
a
_run
ev
{{
Φ
}}.
Lemma
c
wp_run
(
ev
:
val
)
Φ
:
(
∀
`
{
cmonadG
Σ
},
C
WP
ev
{{
w
,
Φ
w
}})
-
∗
WP
c
_run
ev
{{
Φ
}}.
Proof
.
iIntros
"Hwp"
.
wp_lam
.
wp_bind
(
mset_create
#()).
iApply
mset_create_spec
;
first
done
.
iNext
.
iIntros
(
env
)
"Henv"
.
wp_let
.
iMod
locking_heap_init
as
(?)
"Hσ"
.
pose
(
amg
:
=
AMonadG
Σ
_
_
_
_
).
iSpecialize
(
"Hwp"
$!
amg
).
rewrite
awp_eq
/
a
wp_def
.
wp_apply
(
newflock_spec
a
monadN
)
;
first
done
.
iSpecialize
(
"Hwp"
$!
amg
).
rewrite
cwp_eq
/
c
wp_def
.
wp_apply
(
newflock_spec
c
monadN
)
;
first
done
.
iIntros
(
k
γ
'
)
"#Hlock"
.
iApply
wp_fupd
.
iMod
(
flock_res_alloc_strong
_
∅
_
_
(
env_inv
env
)%
I
with
"Hlock [Henv Hσ]"
)
as
(
s
ρ
)
"[_ Hres]"
;
first
done
.
...
...
@@ -357,11 +357,11 @@ Section a_wp_run.
rewrite
/
flock_resources
big_sepM_singleton
/=.
by
iMod
(
flock_res_dealloc
with
"Hlock Hres"
)
as
"Henv"
.
Qed
.
End
a_
wp_run
.
End
c
wp_run
.
(* Make sure that we only use the provided rules and don't break the abstraction *)
Typeclasses
Opaque
a_ret
a_bind
(* a_run *)
a_atomic
a_atomic_env
a
_par
.
Opaque
a_ret
a_bind
(* a_run *)
a_atomic
a_atomic_env
a
_par
.
Typeclasses
Opaque
c_ret
c_bind
c_run
c_atomic
c_atomic_env
c
_par
.
Opaque
c_ret
c_bind
c_run
c_atomic
c_atomic_env
c
_par
.
(* Definition locking_heapΣ : gFunctors := *)
(* #[heapΣ; GFunctor (auth.authR locking_heapUR)]. *)
...
...
@@ -369,8 +369,8 @@ Opaque a_ret a_bind (* a_run *) a_atomic a_atomic_env a_par.
(* Instance subG_locking_heapG {Σ} : subG locking_heapΣ Σ → locking_heapPreG Σ. *)
(* Proof. solve_inG. Qed. *)
(* Definition
a
wp_adequacy Σ R s v σ φ : *)
(* (R -∗ (∀ `{locking_heapG Σ},
a
wp (of_val v) R (λ w, R -∗ ⌜φ w⌝)))%I → *)
(* Definition
c
wp_adequacy Σ R s v σ φ : *)
(* (R -∗ (∀ `{locking_heapG Σ},
c
wp (of_val v) R (λ w, R -∗ ⌜φ w⌝)))%I → *)
(* adequate MaybeStuck (a_run v) σ φ. *)
(* (∀ `{heapG Σ}, WP e @ s; ⊤ {{ v, ⌜φ v⌝ }}%I) → *)
(* Proof. *)
...
...
theories/c_translation/proofmode.v
View file @
bfa32cfe
...
...
@@ -2,41 +2,41 @@ From iris.heap_lang Require Export proofmode notation.
From
iris_c
.
c_translation
Require
Export
monad
.
From
iris
.
proofmode
Require
Import
coq_tactics
.
Lemma
tac_
awp_bind
`
{
a
monadG
Σ
}
K
Δ
R
Φ
e
f
:
Lemma
tac_
cwp_bind
`
{
c
monadG
Σ
}
K
Δ
R
Φ
e
f
:
f
=
(
λ
e
,
fill
K
e
)
→
(* as an eta expanded hypothesis so that we can `simpl` it *)
envs_entails
Δ
(
WP
e
{{
v
,
a
wp
(
f
(
of_val
v
))
R
Φ
}})%
I
→
envs_entails
Δ
(
a
wp
(
fill
K
e
)
R
Φ
).
Proof
.
rewrite
envs_entails_eq
=>
->
->.
by
apply
:
wp_
a
wp_bind
.
Qed
.
envs_entails
Δ
(
WP
e
{{
v
,
c
wp
(
f
(
of_val
v
))
R
Φ
}})%
I
→
envs_entails
Δ
(
c
wp
(
fill
K
e
)
R
Φ
).
Proof
.
rewrite
envs_entails_eq
=>
->
->.
by
apply
:
wp_
c
wp_bind
.
Qed
.
Ltac
a
wp_bind_core
K
:
=
Ltac
c
wp_bind_core
K
:
=
lazymatch
eval
hnf
in
K
with
|
[]
=>
idtac
|
_
=>
eapply
(
tac_
a
wp_bind
K
)
;
[
simpl
;
reflexivity
|
lazy
beta
]
|
_
=>
eapply
(
tac_
c
wp_bind
K
)
;
[
simpl
;
reflexivity
|
lazy
beta
]
end
.
Tactic
Notation
"
a
wp_apply"
open_constr
(
lem
)
:
=
Tactic
Notation
"
c
wp_apply"
open_constr
(
lem
)
:
=
iPoseProofCore
lem
as
false
true
(
fun
H
=>
lazymatch
goal
with
|
|-
envs_entails
_
(
a
wp
?e
?R
?Q
)
=>
|
|-
envs_entails
_
(
c
wp
?e
?R
?Q
)
=>
reshape_expr
e
ltac
:
(
fun
K
e'
=>
a
wp_bind_core
K
;
iApplyHyp
H
;
try
iNext
(*; try wp_expr_simpl*)
)
||
c
wp_bind_core
K
;
iApplyHyp
H
;
try
iNext
(*; try wp_expr_simpl*)
)
||
lazymatch
iTypeOf
H
with
|
Some
(
_
,
?P
)
=>
fail
"
a
wp_apply: cannot apply"
P
|
Some
(
_
,
?P
)
=>
fail
"
c
wp_apply: cannot apply"
P
end
|
_
=>
fail
"
awp_apply: not a 'a
wp'"
|
_
=>
fail
"
cwp_apply: not a 'c
wp'"
end
).
Lemma
tac_
awp_pure
`
{
a
monadG
Σ
}
Δ
Δ
'
K
e1
e2
e
φ
n
R
Φ
:
Lemma
tac_
cwp_pure
`
{
c
monadG
Σ
}
Δ
Δ
'
K
e1
e2
e
φ
n
R
Φ
:
e
=
fill
K
e1
→
PureExec
φ
n
e1
e2
→
φ
→
MaybeIntoLaterNEnvs
n
Δ
Δ
'
→
envs_entails
Δ
'
(
a
wp
(
fill
K
e2
)
R
Φ
)
→
envs_entails
Δ
(
a
wp
e
R
Φ
).
envs_entails
Δ
'
(
c
wp
(
fill
K
e2
)
R
Φ
)
→
envs_entails
Δ
(
c
wp
e
R
Φ
).
Proof
.
rewrite
envs_entails_eq
=>
->
???
H
Δ
'
.
rewrite
into_laterN_env_sound
/=.
rewrite
H
Δ
'
-
a
wp_pure
//.
rewrite
H
Δ
'
-
c
wp_pure
//.
Qed
.
Tactic
Notation
"tac_bind_helper"
:
=
...
...
@@ -52,48 +52,48 @@ Tactic Notation "tac_bind_helper" :=
replace
e
with
(
fill
K'
e'
)
by
(
by
rewrite
?fill_app
))
end
;
reflexivity
.
Tactic
Notation
"
a
wp_pure"
open_constr
(
efoc
)
:
=
Tactic
Notation
"
c
wp_pure"
open_constr
(
efoc
)
:
=
iStartProof
;
lazymatch
goal
with
|
|-
envs_entails
_
(
a
wp
?e
?R
?Q
)
=>
|
|-
envs_entails
_
(
c
wp
?e
?R
?Q
)
=>
let
e
:
=
eval
simpl
in
e
in
reshape_expr
e
ltac
:
(
fun
K
e'
=>
unify
e'
efoc
;
eapply
(
tac_
a
wp_pure
_
_
_
_
_
(
fill
K
e'
))
;
eapply
(
tac_
c
wp_pure
_
_
_
_
_
(
fill
K
e'
))
;
[
tac_bind_helper
(* e = fill K e' *)
|
apply
_
(* PureExec *)
|
try
fast_done
(* The pure condition for PureExec *)
|
apply
_
(* IntoLaters *)
|
simpl
])
||
fail
"
a
wp_pure: cannot find"
efoc
"in"
e
"or"
efoc
"is not a redex"
|
_
=>
fail
"
awp_pure: not an 'a
wp'"
||
fail
"
c
wp_pure: cannot find"
efoc
"in"
e
"or"
efoc
"is not a redex"
|
_
=>
fail
"
cwp_pure: not an 'c
wp'"
end
.
(* See Iris for documentation on this tactic *)
Ltac
a
wp_pures
:
=
Ltac
c
wp_pures
:
=
iStartProof
;
repeat
(
a
wp_pure
_;
[]).
(* The `;[]` makes sure that no side-condition
repeat
(
c
wp_pure
_;
[]).
(* The `;[]` makes sure that no side-condition
magically spawns. *)
Tactic
Notation
"
a
wp_rec"
:
=
Tactic
Notation
"
c
wp_rec"
:
=
let
H
:
=
fresh
in
assert
(
H
:
=
AsRecV_recv_locked
)
;
a
wp_pure
(
App
_
_
)
;
c
wp_pure
(
App
_
_
)
;
clear
H
.
Tactic
Notation
"
awp_if"
:
=
a
wp_pure
(
If
_
_
_
).
Tactic
Notation
"
awp_if_true"
:
=
a
wp_pure
(
If
(
LitV
(
LitBool
true
))
_
_
).
Tactic
Notation
"
awp_if_false"
:
=
a
wp_pure
(
If
(
LitV
(
LitBool
false
))
_
_
).
Tactic
Notation
"
awp_unop"
:
=
a
wp_pure
(
UnOp
_
_
).
Tactic
Notation
"
awp_binop"
:
=
a
wp_pure
(
BinOp
_
_
_
).
Tactic
Notation
"
awp_op"
:
=
awp_unop
||
a
wp_binop
.
Tactic
Notation
"
awp_lam"
:
=
a
wp_rec
.
Tactic
Notation
"
awp_let"
:
=
a
wp_lam
.
Tactic
Notation
"
awp_seq"
:
=
a
wp_lam
.
Tactic
Notation
"
awp_proj"
:
=
awp_pure
(
Fst
_
)
||
a
wp_pure
(
Snd
_
).
Tactic
Notation
"
awp_case"
:
=
a
wp_pure
(
Case
_
_
_
).
Tactic
Notation
"
awp_match"
:
=
awp_case
;
a
wp_let
.
Tactic
Notation
"
awp_inj"
:
=
a
wp_pure
(
InjL
_
)
||
wp_pure
(
InjR
_
).
Tactic
Notation
"
awp_pair"
:
=
a
wp_pure
(
Pair
_
_
).
Tactic
Notation
"
awp_closure"
:
=
a
wp_pure
(
Rec
_
_
_
).
Tactic
Notation
"
cwp_if"
:
=
c
wp_pure
(
If
_
_
_
).
Tactic
Notation
"
cwp_if_true"
:
=
c
wp_pure
(
If
(
LitV
(
LitBool
true
))
_
_
).
Tactic
Notation
"
cwp_if_false"
:
=
c
wp_pure
(
If
(
LitV
(
LitBool
false
))
_
_
).
Tactic
Notation
"
cwp_unop"
:
=
c
wp_pure
(
UnOp
_
_
).
Tactic
Notation
"
cwp_binop"
:
=
c
wp_pure
(
BinOp
_
_
_
).
Tactic
Notation
"
cwp_op"
:
=
cwp_unop
||
c
wp_binop
.
Tactic
Notation
"
cwp_lam"
:
=
c
wp_rec
.
Tactic
Notation
"
cwp_let"
:
=
c
wp_lam
.
Tactic
Notation
"
cwp_seq"
:
=
c
wp_lam
.
Tactic
Notation
"
cwp_proj"
:
=
cwp_pure
(
Fst
_
)
||
c
wp_pure
(
Snd
_
).
Tactic
Notation
"
cwp_case"
:
=
c
wp_pure
(
Case
_
_
_
).
Tactic
Notation
"
cwp_match"
:
=
cwp_case
;
c
wp_let
.
Tactic
Notation
"
cwp_inj"
:
=
c
wp_pure
(
InjL
_
)
||
wp_pure
(
InjR
_
).
Tactic
Notation
"
cwp_pair"
:
=
c
wp_pure
(
Pair
_
_
).
Tactic
Notation
"
cwp_closure"
:
=
c
wp_pure
(
Rec
_
_
_
).