Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
George Pirlea
Iris
Commits
ddbc49ba
Commit
ddbc49ba
authored
Feb 26, 2016
by
Robbert Krebbers
Browse files
Fractional heap.
parent
82d4b448
Changes
1
Hide whitespace changes
Inline
Side-by-side
heap_lang/heap.v
View file @
ddbc49ba
From
heap_lang
Require
Export
lifting
.
From
algebra
Require
Import
upred_big_op
frac
.
From
algebra
Require
Import
upred_big_op
frac
dec_agree
.
From
program_logic
Require
Export
invariants
ghost_ownership
.
From
program_logic
Require
Import
ownership
auth
.
Import
uPred
.
...
...
@@ -7,7 +7,7 @@ Import uPred.
a finmap as their state. Or maybe even beyond "as their state", i.e. arbitrary
predicates over finmaps instead of just ownP. *)
Definition
heapRA
:
cmraT
:
=
mapRA
loc
(
exclRA
(
leibnizC
val
)).
Definition
heapRA
:
cmraT
:
=
mapRA
loc
(
fracRA
(
dec_agreeRA
val
)).
Definition
heapGF
:
iFunctor
:
=
authGF
heapRA
.
Class
heapG
Σ
:
=
HeapG
{
...
...
@@ -17,13 +17,15 @@ Class heapG Σ := HeapG {
Instance
heap_authG
`
{
i
:
heapG
Σ
}
:
authG
heap_lang
Σ
heapRA
:
=
{|
auth_inG
:
=
heap_inG
|}.
Definition
to_heap
:
state
→
heapRA
:
=
fmap
Excl
.
Definition
of_heap
:
heapRA
→
state
:
=
omap
(
maybe
Excl
).
Definition
to_heap
:
state
→
heapRA
:
=
fmap
(
λ
v
,
Frac
1
(
DecAgree
v
)).
Definition
of_heap
:
heapRA
→
state
:
=
omap
(
mbind
(
maybe
DecAgree
∘
snd
)
∘
maybe2
Frac
).
(* heap_mapsto is defined strongly opaquely, to prevent unification from
matching it against other forms of ownership. *)
Definition
heap_mapsto
`
{
heapG
Σ
}
(
l
:
loc
)
(
v
:
val
)
:
iPropG
heap_lang
Σ
:
=
auth_own
heap_name
{[
l
:
=
Excl
v
]}.
Definition
heap_mapsto
`
{
heapG
Σ
}
(
l
:
loc
)(
q
:
Qp
)
(
v
:
val
)
:
iPropG
heap_lang
Σ
:
=
auth_own
heap_name
{[
l
:
=
Frac
q
(
DecAgree
v
)
]}.
Typeclasses
Opaque
heap_mapsto
.
Definition
heap_inv
`
{
i
:
heapG
Σ
}
(
h
:
heapRA
)
:
iPropG
heap_lang
Σ
:
=
...
...
@@ -31,7 +33,9 @@ Definition heap_inv `{i : heapG Σ} (h : heapRA) : iPropG heap_lang Σ :=
Definition
heap_ctx
`
{
i
:
heapG
Σ
}
(
N
:
namespace
)
:
iPropG
heap_lang
Σ
:
=
auth_ctx
heap_name
N
heap_inv
.
Notation
"l ↦ v"
:
=
(
heap_mapsto
l
v
)
(
at
level
20
)
:
uPred_scope
.
Notation
"l ↦{ q } v"
:
=
(
heap_mapsto
l
q
v
)
(
at
level
20
,
q
at
level
50
,
format
"l ↦{ q } v"
)
:
uPred_scope
.
Notation
"l ↦ v"
:
=
(
heap_mapsto
l
1
v
)
(
at
level
20
)
:
uPred_scope
.
Section
heap
.
Context
{
Σ
:
iFunctorG
}.
...
...
@@ -50,27 +54,45 @@ Section heap.
Qed
.
Lemma
to_heap_valid
σ
:
✓
to_heap
σ
.
Proof
.
intros
l
.
rewrite
lookup_fmap
.
by
case
(
σ
!!
l
).
Qed
.
Lemma
of_heap_insert
l
v
h
:
of_heap
(<[
l
:
=
Excl
v
]>
h
)
=
<[
l
:
=
v
]>
(
of_heap
h
).
Proof
.
by
rewrite
/
of_heap
-(
omap_insert
_
_
_
(
Excl
v
)).
Qed
.
Lemma
to_heap_insert
l
v
σ
:
to_heap
(<[
l
:
=
v
]>
σ
)
=
<[
l
:
=
Excl
v
]>
(
to_heap
σ
).
Lemma
of_heap_insert
l
v
h
:
of_heap
(<[
l
:
=
Frac
1
(
DecAgree
v
)]>
h
)
=
<[
l
:
=
v
]>
(
of_heap
h
).
Proof
.
by
rewrite
/
of_heap
-(
omap_insert
_
_
_
(
Frac
1
(
DecAgree
v
))).
Qed
.
Lemma
of_heap_singleton_op
l
q
v
h
:
✓
({[
l
:
=
Frac
q
(
DecAgree
v
)]}
⋅
h
)
→
of_heap
({[
l
:
=
Frac
q
(
DecAgree
v
)]}
⋅
h
)
=
<[
l
:
=
v
]>
(
of_heap
h
).
Proof
.
intros
Hv
.
apply
map_eq
=>
l'
;
destruct
(
decide
(
l'
=
l
))
as
[->|].
-
move
:
(
Hv
l
).
rewrite
/
of_heap
lookup_insert
lookup_omap
(
lookup_op
_
h
)
lookup_singleton
.
case
_:
(
h
!!
l
)=>[[
q'
[
v'
|]|]|]
//=
;
last
by
move
=>
[??].
move
=>
[?
/
dec_agree_op_inv
[->]].
by
rewrite
dec_agree_idemp
.
-
rewrite
/
of_heap
lookup_insert_ne
//
!
lookup_omap
.
by
rewrite
(
lookup_op
_
h
)
lookup_singleton_ne
//
left_id
.
Qed
.
Lemma
to_heap_insert
l
v
σ
:
to_heap
(<[
l
:
=
v
]>
σ
)
=
<[
l
:
=
Frac
1
(
DecAgree
v
)]>
(
to_heap
σ
).
Proof
.
by
rewrite
/
to_heap
-
fmap_insert
.
Qed
.
Lemma
of_heap_None
h
l
:
✓
h
→
of_heap
h
!!
l
=
None
→
h
!!
l
=
None
∨
h
!!
l
≡
Some
Excl
Unit
.
✓
h
→
of_heap
h
!!
l
=
None
→
h
!!
l
=
None
∨
h
!!
l
≡
Some
Frac
Unit
.
Proof
.
move
=>
/(
_
l
).
rewrite
/
of_heap
lookup_omap
.
by
case
:
(
h
!!
l
)=>
[[
]|]
;
auto
.
by
case
:
(
h
!!
l
)=>
[[
q
[
v
|]|]|]
//=
;
destruct
1
;
auto
.
Qed
.
Lemma
heap_singleton_inv_l
h
l
v
:
✓
({[
l
:
=
Excl
v
]}
⋅
h
)
→
h
!!
l
=
None
∨
h
!!
l
≡
Some
ExclUnit
.
Lemma
heap_store_valid
l
h
v1
v2
:
✓
({[
l
:
=
Frac
1
(
DecAgree
v1
)]}
⋅
h
)
→
✓
({[
l
:
=
Frac
1
(
DecAgree
v2
)]}
⋅
h
).
Proof
.
move
=>
/(
_
l
).
rewrite
lookup_op
lookup_singleton
.
by
case
:
(
h
!!
l
)=>
[[]|]
;
auto
.
intros
Hv
l'
;
move
:
(
Hv
l'
).
destruct
(
decide
(
l'
=
l
))
as
[->|].
-
rewrite
!
lookup_op
!
lookup_singleton
.
case
:
(
h
!!
l
)=>[
x
|]
;
[|
done
]=>
/
frac_valid_inv_l
=>->
//.
-
by
rewrite
!
lookup_op
!
lookup_singleton_ne
.
Qed
.
Hint
Resolve
heap_store_valid
.
(** Allocation *)
Lemma
heap_alloc
E
N
σ
:
authG
heap_lang
Σ
heapRA
→
nclose
N
⊆
E
→
ownP
σ
⊑
(|={
E
}=>
∃
_
:
heapG
Σ
,
heap_ctx
N
∧
Π★
{
map
σ
}
heap_mapsto
).
ownP
σ
⊑
(|={
E
}=>
∃
_
:
heapG
Σ
,
heap_ctx
N
∧
Π★
{
map
σ
}
(
λ
l
v
,
l
↦
v
)
).
Proof
.
intros
.
rewrite
-{
1
}(
from_to_heap
σ
).
etrans
.
{
rewrite
[
ownP
_
]
later_intro
.
...
...
@@ -95,11 +117,19 @@ Section heap.
Proof
.
solve_proper
.
Qed
.
(** General properties of mapsto *)
Lemma
heap_mapsto_disjoint
l
v1
v2
:
(
l
↦
v1
★
l
↦
v2
)%
I
⊑
False
.
Lemma
heap_mapsto_op_eq
l
q1
q2
v
:
(
l
↦
{
q1
}
v
★
l
↦
{
q2
}
v
)%
I
≡
(
l
↦
{
q1
+
q2
}
v
)%
I
.
Proof
.
by
rewrite
-
auth_own_op
map_op_singleton
Frac_op
dec_agree_idemp
.
Qed
.
Lemma
heap_mapsto_op
l
q1
q2
v1
v2
:
(
l
↦
{
q1
}
v1
★
l
↦
{
q2
}
v2
)%
I
≡
(
v1
=
v2
∧
l
↦
{
q1
+
q2
}
v1
)%
I
.
Proof
.
rewrite
-
auth_own_op
auth_own_valid
map_op_singleton
.
rewrite
map_validI
(
forall_elim
l
)
lookup_singleton
.
by
rewrite
option_validI
excl_validI
.
destruct
(
decide
(
v1
=
v2
))
as
[->|].
{
by
rewrite
heap_mapsto_op_eq
const_equiv
//
left_id
.
}
rewrite
-
auth_own_op
map_op_singleton
Frac_op
dec_agree_ne
//.
apply
(
anti_symm
(
⊑
))
;
last
by
apply
const_elim_l
.
rewrite
auth_own_valid
map_validI
(
forall_elim
l
)
lookup_singleton
.
rewrite
option_validI
frac_validI
discrete_valid
.
by
apply
const_elim_r
.
Qed
.
(** Weakest precondition *)
...
...
@@ -120,29 +150,28 @@ Section heap.
apply
sep_mono_r
;
rewrite
HP
;
apply
later_mono
.
apply
forall_mono
=>
l
;
apply
wand_intro_l
.
rewrite
always_and_sep_l
-
assoc
;
apply
const_elim_sep_l
=>
?.
rewrite
-(
exist_intro
(
op
{[
l
:
=
Excl
v
]})).
rewrite
-(
exist_intro
(
op
{[
l
:
=
Frac
1
(
DecAgree
v
)
]})).
repeat
erewrite
<-
exist_intro
by
apply
_;
simpl
.
rewrite
-
of_heap_insert
left_id
right_id
.
rewrite
/
heap_mapsto
.
ecancel
[
_
-
★
Φ
_
]%
I
.
rewrite
-(
map_insert_singleton_op
h
)
;
last
by
apply
of_heap_None
.
rewrite
const_equiv
?left_id
;
last
by
apply
(
map_insert_valid
h
).
apply
later_intro
.
rewrite
const_equiv
;
last
by
apply
(
map_insert_valid
h
).
by
rewrite
left_id
-
later_intro
.
Qed
.
Lemma
wp_load
N
E
l
v
P
Φ
:
Lemma
wp_load
N
E
l
q
v
P
Φ
:
P
⊑
heap_ctx
N
→
nclose
N
⊆
E
→
P
⊑
(
▷
l
↦
v
★
▷
(
l
↦
v
-
★
Φ
v
))
→
P
⊑
(
▷
l
↦
{
q
}
v
★
▷
(
l
↦
{
q
}
v
-
★
Φ
v
))
→
P
⊑
||
Load
(
Loc
l
)
@
E
{{
Φ
}}.
Proof
.
rewrite
/
heap_ctx
/
heap_inv
=>
??
HP
Φ
.
apply
(
auth_fsa'
heap_inv
(
wp_fsa
_
)
id
)
with
N
heap_name
{[
l
:
=
Excl
v
]}
;
simpl
;
eauto
with
I
.
with
N
heap_name
{[
l
:
=
Frac
q
(
DecAgree
v
)
]}
;
simpl
;
eauto
with
I
.
rewrite
HP
Φ
{
HP
Φ
}
;
apply
sep_mono_r
,
forall_intro
=>
h
;
apply
wand_intro_l
.
rewrite
-
assoc
discrete_valid
;
apply
const_elim_sep_l
=>
?.
rewrite
-(
wp_load_pst
_
(<[
l
:
=
v
]>(
of_heap
h
)))
?lookup_insert
//.
rewrite
const_equiv
//
left_id
.
rewrite
-(
map_insert_singleton_op
h
)
;
last
by
eapply
heap_singleton_inv_l
.
rewrite
-
of_heap_insert
.
rewrite
/
heap_inv
of_heap_singleton_op
//.
apply
sep_mono_r
,
later_mono
,
wand_intro_l
.
by
rewrite
-
later_intro
.
Qed
.
...
...
@@ -153,33 +182,30 @@ Section heap.
P
⊑
||
Store
(
Loc
l
)
e
@
E
{{
Φ
}}.
Proof
.
rewrite
/
heap_ctx
/
heap_inv
=>
???
HP
Φ
.
apply
(
auth_fsa'
heap_inv
(
wp_fsa
_
)
(
alter
(
λ
_
,
Excl
v
)
l
))
with
N
heap_name
{[
l
:
=
Excl
v'
]}
;
simpl
;
eauto
with
I
.
apply
(
auth_fsa'
heap_inv
(
wp_fsa
_
)
(
alter
(
λ
_
,
Frac
1
(
DecAgree
v
)
)
l
))
with
N
heap_name
{[
l
:
=
Frac
1
(
DecAgree
v'
)
]}
;
simpl
;
eauto
with
I
.
rewrite
HP
Φ
{
HP
Φ
}
;
apply
sep_mono_r
,
forall_intro
=>
h
;
apply
wand_intro_l
.
rewrite
-
assoc
discrete_valid
;
apply
const_elim_sep_l
=>
?.
rewrite
-(
wp_store_pst
_
(<[
l
:
=
v'
]>(
of_heap
h
)))
?lookup_insert
//.
rewrite
/
heap_inv
alter_singleton
insert_insert
.
rewrite
-!(
map_insert_singleton_op
h
)
;
try
by
eapply
heap_singleton_inv_l
.
rewrite
-!
of_heap_insert
const_equiv
;
last
(
split
;
[
naive_solver
|
by
eapply
map_insert_valid
,
cmra_valid_op_r
]).
rewrite
/
heap_inv
alter_singleton
insert_insert
!
of_heap_singleton_op
;
eauto
.
rewrite
const_equiv
;
last
naive_solver
.
apply
sep_mono_r
,
later_mono
,
wand_intro_l
.
by
rewrite
left_id
-
later_intro
.
Qed
.
Lemma
wp_cas_fail
N
E
l
v'
e1
v1
e2
v2
P
Φ
:
Lemma
wp_cas_fail
N
E
l
q
v'
e1
v1
e2
v2
P
Φ
:
to_val
e1
=
Some
v1
→
to_val
e2
=
Some
v2
→
v'
≠
v1
→
P
⊑
heap_ctx
N
→
nclose
N
⊆
E
→
P
⊑
(
▷
l
↦
v'
★
▷
(
l
↦
v'
-
★
Φ
(
LitV
(
LitBool
false
))))
→
P
⊑
(
▷
l
↦
{
q
}
v'
★
▷
(
l
↦
{
q
}
v'
-
★
Φ
(
LitV
(
LitBool
false
))))
→
P
⊑
||
Cas
(
Loc
l
)
e1
e2
@
E
{{
Φ
}}.
Proof
.
rewrite
/
heap_ctx
/
heap_inv
=>?????
HP
Φ
.
apply
(
auth_fsa'
heap_inv
(
wp_fsa
_
)
id
)
with
N
heap_name
{[
l
:
=
Excl
v'
]}
;
simpl
;
eauto
10
with
I
.
with
N
heap_name
{[
l
:
=
Frac
q
(
DecAgree
v'
)
]}
;
simpl
;
eauto
10
with
I
.
rewrite
HP
Φ
{
HP
Φ
}
;
apply
sep_mono_r
,
forall_intro
=>
h
;
apply
wand_intro_l
.
rewrite
-
assoc
discrete_valid
;
apply
const_elim_sep_l
=>
?.
rewrite
-(
wp_cas_fail_pst
_
(<[
l
:
=
v'
]>(
of_heap
h
)))
?lookup_insert
//.
rewrite
const_equiv
//
left_id
.
rewrite
-(
map_insert_singleton_op
h
)
;
last
by
eapply
heap_singleton_inv_l
.
rewrite
-
of_heap_insert
.
rewrite
/
heap_inv
!
of_heap_singleton_op
//.
apply
sep_mono_r
,
later_mono
,
wand_intro_l
.
by
rewrite
-
later_intro
.
Qed
.
...
...
@@ -190,17 +216,14 @@ Section heap.
P
⊑
||
Cas
(
Loc
l
)
e1
e2
@
E
{{
Φ
}}.
Proof
.
rewrite
/
heap_ctx
/
heap_inv
=>
????
HP
Φ
.
apply
(
auth_fsa'
heap_inv
(
wp_fsa
_
)
(
alter
(
λ
_
,
Excl
v2
)
l
))
with
N
heap_name
{[
l
:
=
Excl
v1
]}
;
simpl
;
eauto
10
with
I
.
apply
(
auth_fsa'
heap_inv
(
wp_fsa
_
)
(
alter
(
λ
_
,
Frac
1
(
DecAgree
v2
)
)
l
))
with
N
heap_name
{[
l
:
=
Frac
1
(
DecAgree
v1
)
]}
;
simpl
;
eauto
10
with
I
.
rewrite
HP
Φ
{
HP
Φ
}
;
apply
sep_mono_r
,
forall_intro
=>
h
;
apply
wand_intro_l
.
rewrite
-
assoc
discrete_valid
;
apply
const_elim_sep_l
=>
?.
rewrite
-(
wp_cas_suc_pst
_
(<[
l
:
=
v1
]>(
of_heap
h
)))
//
;
last
by
rewrite
lookup_insert
.
rewrite
/
heap_inv
alter_singleton
insert_insert
.
rewrite
-!(
map_insert_singleton_op
h
)
;
try
by
eapply
heap_singleton_inv_l
.
rewrite
-!
of_heap_insert
const_equiv
;
last
first
.
{
split
;
last
by
eapply
map_insert_valid
,
cmra_valid_op_r
.
eexists
;
rewrite
lookup_insert
;
naive_solver
.
}
rewrite
/
heap_inv
alter_singleton
insert_insert
!
of_heap_singleton_op
;
eauto
.
rewrite
lookup_insert
const_equiv
;
last
naive_solver
.
apply
sep_mono_r
,
later_mono
,
wand_intro_l
.
by
rewrite
left_id
-
later_intro
.
Qed
.
End
heap
.
Write
Preview
Supports
Markdown
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