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
Iris
Actris
Commits
26dc79c4
Commit
26dc79c4
authored
Jul 08, 2019
by
Robbert Krebbers
Browse files
Use proper linked lists instead of functional lists.
TODO: fix in-place merge function.
parent
16045d70
Changes
10
Hide whitespace changes
Inline
Side-by-side
_CoqProject
View file @
26dc79c4
-Q theories actris
-arg -w -arg -notation-overridden,-redundant-canonical-projection,-several-object-files
theories/utils/auth_excl.v
theories/utils/list.v
theories/utils/flist.v
theories/utils/llist.v
theories/utils/compare.v
theories/utils/contribution.v
theories/channel/channel.v
...
...
theories/channel/channel.v
View file @
26dc79c4
From
iris
.
heap_lang
Require
Import
proofmode
notation
.
From
iris
.
heap_lang
.
lib
Require
Import
spin_lock
.
From
iris
.
algebra
Require
Import
excl
auth
list
.
From
actris
.
utils
Require
Import
auth_excl
list
.
From
actris
.
utils
Require
Import
auth_excl
l
list
.
Set
Default
Proof
Using
"Type"
.
Inductive
side
:
=
Left
|
Right
.
...
...
@@ -11,8 +11,8 @@ Definition side_elim {A} (s : side) (l r : A) : A :=
Definition
new_chan
:
val
:
=
λ
:
<>,
let
:
"l"
:
=
ref
(
lnil
#()
)
in
let
:
"r"
:
=
ref
(
lnil
#()
)
in
let
:
"l"
:
=
lnil
#()
in
let
:
"r"
:
=
lnil
#()
in
let
:
"lk"
:
=
newlock
#()
in
(((
"l"
,
"r"
),
"lk"
),
((
"r"
,
"l"
),
"lk"
)).
...
...
@@ -21,7 +21,7 @@ Definition send : val :=
let
:
"lk"
:
=
Snd
"c"
in
acquire
"lk"
;;
let
:
"l"
:
=
Fst
(
Fst
"c"
)
in
"l"
<-
lsnoc
!
"l"
"v"
;;
lsnoc
"l"
"v"
;;
release
"lk"
.
Definition
try_recv
:
val
:
=
...
...
@@ -29,11 +29,7 @@ Definition try_recv : val :=
let
:
"lk"
:
=
Snd
"c"
in
acquire
"lk"
;;
let
:
"l"
:
=
Snd
(
Fst
"c"
)
in
let
:
"ret"
:
=
match
:
!
"l"
with
SOME
"p"
=>
"l"
<-
Snd
"p"
;;
SOME
(
Fst
"p"
)
|
NONE
=>
NONE
end
in
let
:
"ret"
:
=
if
:
lisnil
"l"
then
NONE
else
SOME
(
lpop
"l"
)
in
release
"lk"
;;
"ret"
.
Definition
recv
:
val
:
=
...
...
@@ -52,27 +48,32 @@ Definition chanΣ : gFunctors :=
Instance
subG_chan
Σ
{
Σ
}
:
subG
chan
Σ
Σ
→
chanG
Σ
.
Proof
.
solve_inG
.
Qed
.
(** MOVE TO IRIS *)
Global
Instance
fst_atomic
a
v1
v2
:
Atomic
a
(
Fst
(
v1
,
v2
)%
V
).
Proof
.
apply
strongly_atomic_atomic
,
ectx_language_atomic
;
[
inversion
1
;
naive_solver
|
apply
ectxi_language_sub_redexes_are_values
;
intros
[]
**
;
naive_solver
].
Qed
.
Section
channel
.
Context
`
{!
heapG
Σ
,
!
chanG
Σ
}
(
N
:
namespace
).
Definition
is_list_ref
(
l
:
val
)
(
xs
:
list
val
)
:
iProp
Σ
:
=
(
∃
l'
:
loc
,
⌜
l
=
#
l'
⌝
∧
l'
↦
llist
xs
)%
I
.
Record
chan_name
:
=
Chan_name
{
chan_lock_name
:
gname
;
chan_l_name
:
gname
;
chan_r_name
:
gname
}.
Definition
chan_inv
(
γ
:
chan_name
)
(
l
r
:
val
)
:
iProp
Σ
:
=
Definition
chan_inv
(
γ
:
chan_name
)
(
l
r
:
loc
)
:
iProp
Σ
:
=
(
∃
ls
rs
,
is_
list
_ref
l
ls
∗
own
(
chan_l_name
γ
)
(
●
to_auth_excl
ls
)
∗
is_
list
_ref
r
rs
∗
own
(
chan_r_name
γ
)
(
●
to_auth_excl
rs
))%
I
.
l
list
l
ls
∗
own
(
chan_l_name
γ
)
(
●
to_auth_excl
ls
)
∗
l
list
r
rs
∗
own
(
chan_r_name
γ
)
(
●
to_auth_excl
rs
))%
I
.
Typeclasses
Opaque
chan_inv
.
Definition
is_chan
(
γ
:
chan_name
)
(
c1
c2
:
val
)
:
iProp
Σ
:
=
(
∃
l
r
lk
:
val
,
⌜
c1
=
((
l
,
r
),
lk
)%
V
∧
c2
=
((
r
,
l
),
lk
)%
V
⌝
∗
(
∃
(
l
r
:
loc
)
(
lk
:
val
)
,
⌜
c1
=
((
#
l
,
#
r
),
lk
)%
V
∧
c2
=
((
#
r
,
#
l
),
lk
)%
V
⌝
∗
is_lock
N
(
chan_lock_name
γ
)
lk
(
chan_inv
γ
l
r
))%
I
.
Global
Instance
is_chan_persistent
:
Persistent
(
is_chan
γ
c1
c2
).
...
...
@@ -91,20 +92,15 @@ Section channel.
Proof
.
iIntros
(
Φ
)
"_ HΦ"
.
rewrite
/
is_chan
/
chan_own
.
wp_lam
.
wp_apply
(
lnil_spec
with
"[//]"
)
;
iIntros
(
l
s
).
wp_alloc
l
as
"Hl"
.
wp_apply
(
lnil_spec
with
"[//]"
)
;
iIntros
(
r
s
).
wp_alloc
r
as
"Hr"
.
wp_apply
(
lnil_spec
with
"[//]"
)
;
iIntros
(
l
)
"Hl"
.
wp_apply
(
lnil_spec
with
"[//]"
)
;
iIntros
(
r
)
"Hr"
.
iMod
(
own_alloc
(
●
(
to_auth_excl
[])
⋅
◯
(
to_auth_excl
[])))
as
(
ls
γ
)
"[Hls Hls']"
.
{
by
apply
auth_both_valid
.
}
iMod
(
own_alloc
(
●
(
to_auth_excl
[])
⋅
◯
(
to_auth_excl
[])))
as
(
rs
γ
)
"[Hrs Hrs']"
.
{
by
apply
auth_both_valid
.
}
iAssert
(
is_list_ref
#
l
[])
with
"[Hl]"
as
"Hl"
.
{
rewrite
/
is_list_ref
;
eauto
.
}
iAssert
(
is_list_ref
#
r
[])
with
"[Hr]"
as
"Hr"
.
{
rewrite
/
is_list_ref
;
eauto
.
}
wp_apply
(
newlock_spec
N
(
∃
ls
rs
,
is_list_ref
#
l
ls
∗
own
ls
γ
(
●
to_auth_excl
ls
)
∗
is_list_ref
#
r
rs
∗
own
rs
γ
(
●
to_auth_excl
rs
))%
I
with
"[Hl Hr Hls Hrs]"
).
llist
l
ls
∗
own
ls
γ
(
●
to_auth_excl
ls
)
∗
llist
r
rs
∗
own
rs
γ
(
●
to_auth_excl
rs
))%
I
with
"[Hl Hr Hls Hrs]"
).
{
eauto
10
with
iFrame
.
}
iIntros
(
lk
γ
lk
)
"#Hlk"
.
wp_pures
.
iApply
(
"HΦ"
$!
_
_
(
Chan_name
γ
lk
ls
γ
rs
γ
))
;
simpl
.
...
...
@@ -113,9 +109,9 @@ Section channel.
Lemma
chan_inv_alt
s
γ
l
r
:
chan_inv
γ
l
r
⊣
⊢
∃
ls
rs
,
is_
list
_ref
(
side_elim
s
l
r
)
ls
∗
l
list
(
side_elim
s
l
r
)
ls
∗
own
(
side_elim
s
chan_l_name
chan_r_name
γ
)
(
●
to_auth_excl
ls
)
∗
is_
list
_ref
(
side_elim
s
r
l
)
rs
∗
l
list
(
side_elim
s
r
l
)
rs
∗
own
(
side_elim
s
chan_r_name
chan_l_name
γ
)
(
●
to_auth_excl
rs
).
Proof
.
destruct
s
;
rewrite
/
chan_inv
//=.
...
...
@@ -131,24 +127,20 @@ Section channel.
Proof
.
iIntros
"Hc HΦ"
.
wp_lam
;
wp_pures
.
iDestruct
"Hc"
as
(
l
r
lk
[->
->])
"#Hlock"
;
wp_pures
.
assert
(
side_elim
s
(
l
,
r
,
lk
)%
V
(
r
,
l
,
lk
)%
V
=
((
side_elim
s
l
r
,
side_elim
s
r
l
),
lk
)%
V
)
as
->
by
(
by
destruct
s
).
assert
(
side_elim
s
(
#
l
,
#
r
,
lk
)%
V
(
#
r
,
#
l
,
lk
)%
V
=
((
#(
side_elim
s
l
r
)
,
#(
side_elim
s
r
l
)
)
,
lk
)%
V
)
as
->
by
(
by
destruct
s
).
wp_apply
(
acquire_spec
with
"Hlock"
)
;
iIntros
"[Hlocked Hinv]"
.
wp_pures
.
iDestruct
(
chan_inv_alt
s
with
"Hinv"
)
as
(
vs
ws
)
"(Href & Hvs & Href' & Hws)"
.
iDestruct
"Href"
as
(
ll
Hslr
)
"Hll"
.
rewrite
Hslr
.
wp_load
.
wp_apply
(
lsnoc_spec
with
"[//]"
)
;
iIntros
(
_
).
wp_bind
(
_
<-
_
)%
E
.
(
vs
ws
)
"(Hll & Hvs & Href' & Hws)"
.
wp_seq
.
wp_bind
(
Fst
(
_
,
_
)%
V
)%
E
.
iMod
"HΦ"
as
(
vs'
)
"[Hchan HΦ]"
.
iDestruct
(
excl_eq
with
"Hvs Hchan"
)
as
%<-%
leibniz_equiv
.
iMod
(
excl_update
_
_
_
(
vs
++
[
v
])
with
"Hvs Hchan"
)
as
"[Hvs Hchan]"
.
wp_
sto
re
.
iMod
(
"HΦ"
with
"Hchan"
)
as
"HΦ"
.
iModIntro
.
wp_
pu
re
s
.
iMod
(
"HΦ"
with
"Hchan"
)
as
"HΦ"
;
iModIntro
.
wp_apply
(
lsnoc_spec
with
"Hll"
)
;
iIntros
"Hll"
.
wp_apply
(
release_spec
with
"[-HΦ $Hlock $Hlocked]"
)
;
last
eauto
.
iApply
(
chan_inv_alt
s
).
rewrite
/
is_
list
_ref
.
eauto
20
with
iFrame
.
rewrite
/
l
list
.
eauto
20
with
iFrame
.
Qed
.
Lemma
try_recv_spec
Φ
E
γ
c1
c2
s
:
...
...
@@ -162,28 +154,27 @@ Section channel.
Proof
.
iIntros
"Hc HΦ"
.
wp_lam
;
wp_pures
.
iDestruct
"Hc"
as
(
l
r
lk
[->
->])
"#Hlock"
;
wp_pures
.
assert
(
side_elim
s
(
r
,
l
,
lk
)%
V
(
l
,
r
,
lk
)%
V
=
((
side_elim
s
r
l
,
side_elim
s
l
r
),
lk
)%
V
)
as
->
by
(
by
destruct
s
).
assert
(
side_elim
s
(
#
r
,
#
l
,
lk
)%
V
(
#
l
,
#
r
,
lk
)%
V
=
((
#(
side_elim
s
r
l
)
,
#(
side_elim
s
l
r
)
)
,
lk
)%
V
)
as
->
by
(
by
destruct
s
).
wp_apply
(
acquire_spec
with
"Hlock"
)
;
iIntros
"[Hlocked Hinv]"
.
wp_pures
.
iDestruct
(
chan_inv_alt
s
with
"Hinv"
)
as
(
vs
ws
)
"(H
ref
& Hvs & Href' & Hws)"
.
iDestruct
"Href"
as
(
ll
Hslr
)
"Hll"
.
rewrite
Hslr
.
wp_bind
(!
_
)%
E
.
destruct
vs
as
[|
v
vs
]
;
simpl
.
-
iDestruct
"HΦ"
as
"[>HΦ _]"
.
wp_load
.
iMod
"HΦ"
;
iModIntro
.
as
(
vs
ws
)
"(H
ll
& Hvs & Href' & Hws)"
.
wp_seq
.
wp_bind
(
Fst
(
_
,
_
)%
V
)%
E
.
destruct
vs
as
[|
v
vs
]
;
simpl
.
-
iDestruct
"HΦ"
as
"[>HΦ _]"
.
wp_pures
.
iMod
"HΦ"
;
iModIntro
.
wp_apply
(
lisnil_spec
with
"Hll"
)
;
iIntros
"Hll"
.
wp_pures
.
wp_apply
(
release_spec
with
"[-HΦ $Hlocked $Hlock]"
).
{
iApply
(
chan_inv_alt
s
).
rewrite
/
is_
list
_ref
.
eauto
10
with
iFrame
.
}
rewrite
/
l
list
.
eauto
10
with
iFrame
.
}
iIntros
(
_
).
by
wp_pures
.
-
iDestruct
"HΦ"
as
"[_ >HΦ]"
.
iDestruct
"HΦ"
as
(
vs'
)
"[Hvs' HΦ]"
.
iDestruct
(
excl_eq
with
"Hvs Hvs'"
)
as
%<-%
leibniz_equiv
.
iMod
(
excl_update
_
_
_
vs
with
"Hvs Hvs'"
)
as
"[Hvs Hvs']"
.
wp_
load
.
iMod
(
"HΦ"
with
"[//] Hvs'"
)
as
"HΦ"
;
iModIntro
.
wp_
store
;
wp_pures
.
wp_
pures
.
iMod
(
"HΦ"
with
"[//] Hvs'"
)
as
"HΦ"
;
iModIntro
.
wp_apply
(
lisnil_spec
with
"Hll"
)
;
iIntros
"Hll"
.
wp_
apply
(
lpop_spec
with
"Hll"
)
;
iIntros
"Hll"
.
wp_apply
(
release_spec
with
"[-HΦ $Hlocked $Hlock]"
).
{
iApply
(
chan_inv_alt
s
).
rewrite
/
is_
list
_ref
.
eauto
10
with
iFrame
.
}
rewrite
/
l
list
.
eauto
10
with
iFrame
.
}
iIntros
(
_
).
by
wp_pures
.
Qed
.
...
...
theories/examples/loop_sort.v
View file @
26dc79c4
From
stdpp
Require
Import
sorting
.
From
actris
.
channel
Require
Import
proto_channel
.
From
iris
.
heap_lang
Require
Import
proofmode
notation
.
From
actris
.
utils
Require
Import
list
.
From
actris
.
examples
Require
Import
sort
.
Definition
loop_sort_service
:
val
:
=
...
...
theories/examples/map.v
View file @
26dc79c4
From
actris
.
channel
Require
Import
proto_channel
proofmode
.
From
iris
.
heap_lang
Require
Import
proofmode
notation
lib
.
spin_lock
.
From
actris
.
utils
Require
Import
list
contribution
.
From
actris
.
utils
Require
Import
l
list
contribution
.
From
iris
.
algebra
Require
Import
gmultiset
.
Definition
map_worker
:
val
:
=
...
...
@@ -30,22 +30,25 @@ Definition start_map_service : val := λ: "n" "map",
Definition
par_map_server
:
val
:
=
rec
:
"go"
"n"
"c"
"xs"
"ys"
:
=
if
:
"n"
=
#
0
then
"ys"
else
if
:
"n"
=
#
0
then
#()
else
if
:
recv
"c"
then
(* send item to map_worker *)
if
:
lisnil
"xs"
then
send
"c"
#
false
;;
"go"
(
"n"
-
#
1
)
"c"
"xs"
"ys"
else
send
"c"
#
true
;;
send
"c"
(
l
head
"xs"
)
;;
"go"
"n"
"c"
(
ltail
"xs"
)
"ys"
send
"c"
(
l
pop
"xs"
)
;;
"go"
"n"
"c"
"xs"
"ys"
else
(* receive item from map_worker *)
let
:
"zs"
:
=
recv
"c"
in
"go"
"n"
"c"
"xs"
(
lapp
"zs"
"ys"
).
lprep
"ys"
"zs"
;;
"go"
"n"
"c"
"xs"
"ys"
.
Definition
par_map
:
val
:
=
λ
:
"n"
"map"
"xs"
,
let
:
"c"
:
=
start_map_service
"n"
"map"
in
par_map_server
"n"
"c"
"xs"
(
lnil
#()).
let
:
"ys"
:
=
lnil
#()
in
par_map_server
"n"
"c"
"xs"
"ys"
;;
"ys"
.
Class
mapG
Σ
A
`
{
Countable
A
}
:
=
{
map_contributionG
:
>
contributionG
Σ
(
gmultisetUR
A
)
;
...
...
@@ -62,7 +65,7 @@ Section map.
Definition
map_spec
(
vmap
:
val
)
:
iProp
Σ
:
=
(
∀
x
v
,
{{{
IA
x
v
}}}
vmap
v
{{{
ws
,
RET
(
llist
ws
)
;
[
∗
list
]
y
;
w
∈
map
x
;
ws
,
IB
y
w
}}})%
I
.
{{{
l
ws
,
RET
#
l
;
llist
l
ws
∗
[
∗
list
]
y
;
w
∈
map
x
;
ws
,
IB
y
w
}}})%
I
.
Definition
map_worker_protocol_aux
(
rec
:
nat
-
d
>
gmultiset
A
-
d
>
iProto
Σ
)
:
nat
-
d
>
gmultiset
A
-
d
>
iProto
Σ
:
=
λ
i
X
,
...
...
@@ -72,7 +75,7 @@ Section map.
<+>
rec
(
pred
i
)
X
)
<{
⌜
i
≠
1
∨
X
=
∅
⌝
}&>
<?>
x
ws
,
MSG
llist
ws
{{
⌜
x
∈
X
⌝
∧
[
∗
list
]
y
;
w
∈
map
x
;
ws
,
IB
y
w
}}
;
<?>
x
(
l
:
loc
)
ws
,
MSG
#
l
{{
⌜
x
∈
X
⌝
∗
llist
l
ws
∗
[
∗
list
]
y
;
w
∈
map
x
;
ws
,
IB
y
w
}}
;
rec
i
(
X
∖
{[
x
]}))%
proto
.
Instance
map_worker_protocol_aux_contractive
:
Contractive
map_worker_protocol_aux
.
Proof
.
solve_proper_prepare
.
f_equiv
.
solve_proto_contractive
.
Qed
.
...
...
@@ -109,7 +112,7 @@ Section map.
rewrite
left_id_L
.
wp_apply
(
release_spec
with
"[$Hlk $Hl Hc Hs]"
).
{
iExists
(
S
i
),
_
.
iFrame
.
}
clear
dependent
i
X
.
iIntros
"Hu"
.
wp_apply
(
"Hmap"
with
"HI"
)
;
iIntros
(
w
)
"HI"
.
clear
dependent
i
X
.
iIntros
"Hu"
.
wp_apply
(
"Hmap"
with
"HI"
)
;
iIntros
(
l
ws
)
"HI"
.
wp_apply
(
acquire_spec
with
"[$Hlk $Hu]"
)
;
iIntros
"[Hl H]"
.
iDestruct
"H"
as
(
i
X
)
"[Hs Hc]"
.
iDestruct
(@
server_agree
with
"Hs Hγ"
)
...
...
@@ -156,38 +159,39 @@ Section map.
wp_apply
(
start_map_workers_spec
with
"Hf [$Hlk $Hγs]"
)
;
auto
.
Qed
.
Lemma
par_map_server_spec
n
c
vs
xs
ws
X
ys
:
Lemma
par_map_server_spec
n
c
l
k
vs
xs
ws
X
ys
:
(
n
=
0
→
X
=
∅
∧
xs
=
[])
→
{{{
llist
l
vs
∗
llist
k
ws
∗
c
↣
map_worker_protocol
n
X
@
N
∗
([
∗
list
]
x
;
v
∈
xs
;
vs
,
IA
x
v
)
∗
([
∗
list
]
y
;
w
∈
ys
;
ws
,
IB
y
w
)
}}}
par_map_server
#
n
c
(
llist
vs
)
(
llist
ws
)
{{{
ys'
ws'
,
RET
(
llist
ws'
)
;
⌜
ys'
≡
ₚ
(
xs
++
elements
X
)
≫
=
map
⌝
∗
[
∗
list
]
y
;
w
∈
ys'
++
ys
;
ws'
,
IB
y
w
par_map_server
#
n
c
#
l
#
k
{{{
ys'
ws'
,
RET
#()
;
⌜
ys'
≡
ₚ
(
xs
++
elements
X
)
≫
=
map
⌝
∗
llist
k
ws'
∗
[
∗
list
]
y
;
w
∈
ys'
++
ys
;
ws'
,
IB
y
w
}}}.
Proof
.
iIntros
(
Hn
Φ
)
"(Hc & HIA & HIB) HΦ"
.
iL
ö
b
as
"IH"
forall
(
n
vs
xs
ws
X
ys
Hn
Φ
)
;
wp_rec
;
wp_pures
;
simpl
.
iIntros
(
Hn
Φ
)
"(
Hl & Hk &
Hc & HIA & HIB) HΦ"
.
iL
ö
b
as
"IH"
forall
(
n
l
vs
xs
ws
X
ys
Hn
Φ
)
;
wp_rec
;
wp_pures
;
simpl
.
case_bool_decide
;
wp_pures
;
simplify_eq
/=.
{
destruct
Hn
as
[->
->]
;
first
lia
.
iApply
(
"HΦ"
$!
[])
;
simpl
;
auto
.
}
iApply
(
"HΦ"
$!
[])
;
simpl
;
auto
with
iFrame
.
}
destruct
n
as
[|
n
]=>
//=.
wp_branch
as
%?|%
_;
wp_pures
.
-
wp_apply
(
lisnil_spec
with
"
[//]
"
)
;
iIntros
(
_
)
.
-
wp_apply
(
lisnil_spec
with
"
Hl
"
)
;
iIntros
"Hl"
.
destruct
vs
as
[|
v
vs
],
xs
as
[|
x
xs
]
;
csimpl
;
try
done
;
wp_pures
.
+
wp_select
.
wp_pures
.
rewrite
Nat2Z
.
inj_succ
Z
.
sub_1_r
Z
.
pred_succ
.
iApply
(
"IH"
with
"[%] Hc [//] [$] HΦ"
)
;
naive_solver
.
iApply
(
"IH"
with
"[%]
Hl Hk
Hc [//] [$] HΦ"
)
;
naive_solver
.
+
iDestruct
"HIA"
as
"[HIAx HIA]"
.
wp_select
.
wp_apply
(
l
head
_spec
with
"
[//]
"
)
;
iIntros
(
_
)
.
wp_apply
(
l
pop
_spec
with
"
Hl
"
)
;
iIntros
"Hl"
.
wp_send
with
"[$HIAx]"
.
wp_apply
(
ltail_spec
with
"[//]"
)
;
iIntros
(
_
).
wp_apply
(
"IH"
with
"[] Hc HIA HIB"
)
;
first
done
.
wp_apply
(
"IH"
with
"[] Hl Hk Hc HIA HIB"
)
;
first
done
.
iIntros
(
ys'
ws'
).
rewrite
gmultiset_elements_disj_union
gmultiset_elements_singleton
.
rewrite
assoc_L
-(
comm
_
[
x
]).
iApply
"HΦ"
.
-
wp_recv
(
x
w
)
as
(
Hx
)
"HIBx"
.
wp_apply
(
l
a
pp_spec
with
"[
//
]"
)
;
iIntros
(
_
)
.
wp_apply
(
"IH"
$!
_
_
_
_
_
(
_
++
_
)
with
"[] Hc HIA [HIBx HIB]"
)
;
first
done
.
-
wp_recv
(
x
l'
w
)
as
(
Hx
)
"
[Hl'
HIBx
]
"
.
wp_apply
(
lp
re
p_spec
with
"[
$Hk $Hl'
]"
)
;
iIntros
"[Hk _]"
.
wp_apply
(
"IH"
$!
_
_
_
_
_
_
(
_
++
_
)
with
"[]
Hl Hk
Hc HIA [HIBx HIB]"
)
;
first
done
.
{
simpl
;
iFrame
.
}
iIntros
(
ys'
ws'
)
;
iDestruct
1
as
(
Hys
)
"HIB"
;
simplify_eq
/=.
iApply
(
"HΦ"
$!
(
ys'
++
map
x
)).
iSplit
.
...
...
@@ -198,17 +202,18 @@ Section map.
+
by
rewrite
-
assoc_L
.
Qed
.
Lemma
par_map_spec
n
vmap
vs
xs
:
Lemma
par_map_spec
n
vmap
l
vs
xs
:
0
<
n
→
map_spec
vmap
-
∗
{{{
[
∗
list
]
x
;
v
∈
xs
;
vs
,
IA
x
v
}}}
par_map
#
n
vmap
(
llist
vs
)
{{{
ys
ws
,
RET
(
llist
ws
)
;
⌜
ys
≡
ₚ
xs
≫
=
map
⌝
∗
[
∗
list
]
y
;
w
∈
ys
;
ws
,
IB
y
w
}}}.
{{{
llist
l
vs
∗
[
∗
list
]
x
;
v
∈
xs
;
vs
,
IA
x
v
}}}
par_map
#
n
vmap
#
l
{{{
k
ys
ws
,
RET
#
k
;
⌜
ys
≡
ₚ
xs
≫
=
map
⌝
∗
llist
k
ws
∗
[
∗
list
]
y
;
w
∈
ys
;
ws
,
IB
y
w
}}}.
Proof
.
iIntros
(?)
"#Hmap !>"
;
iIntros
(
Φ
)
"HI HΦ"
.
wp_lam
;
wp_pures
.
iIntros
(?)
"#Hmap !>"
;
iIntros
(
Φ
)
"
[Hl
HI
]
HΦ"
.
wp_lam
;
wp_pures
.
wp_apply
(
start_map_service_spec
with
"Hmap [//]"
)
;
iIntros
(
c
)
"Hc"
.
wp_pures
.
wp_apply
(
lnil_spec
with
"[//]"
)
;
iIntros
(
_
).
wp_apply
(
par_map_server_spec
_
_
_
_
[]
∅
[]
with
"[$Hc $HI //]"
)
;
first
lia
.
iIntros
(
ys
ws
).
rewrite
/=
gmultiset_elements_empty
!
right_id_L
.
iApply
"HΦ"
.
wp_pures
.
wp_apply
(
lnil_spec
with
"[//]"
)
;
iIntros
(
k
)
"Hk"
.
wp_apply
(
par_map_server_spec
_
_
_
_
_
_
[]
∅
[]
with
"[$Hl $Hk $Hc $HI //]"
)
;
first
lia
.
iIntros
(
ys
ws
)
"H"
.
rewrite
/=
gmultiset_elements_empty
!
right_id_L
.
wp_pures
.
by
iApply
"HΦ"
.
Qed
.
End
map
.
theories/examples/map_reduce.v
View file @
26dc79c4
From
stdpp
Require
Import
sorting
.
From
actris
.
channel
Require
Import
proto_channel
proofmode
.
From
iris
.
heap_lang
Require
Import
proofmode
notation
.
From
actris
.
utils
Require
Import
list
compare
contribution
.
From
actris
.
utils
Require
Import
l
list
compare
contribution
.
From
actris
.
examples
Require
Import
map
sort_elem
sort_elem_client
.
From
iris
.
algebra
Require
Import
gmultiset
.
From
Coq
Require
Import
SetoidPermutation
.
...
...
@@ -40,8 +40,8 @@ Definition par_map_reduce_map_server : val :=
"go"
(
"n"
-
#
1
)
"cmap"
"csort"
"xs"
else
send
"cmap"
#
true
;;
send
"cmap"
(
l
head
"xs"
)
;;
"go"
"n"
"cmap"
"csort"
(
ltail
"xs"
)
send
"cmap"
(
l
pop
"xs"
)
;;
"go"
"n"
"cmap"
"csort"
"xs"
else
(* receive item from mapper *)
let
:
"zs"
:
=
recv
"cmap"
in
send_all
"csort"
"zs"
;;
...
...
@@ -49,15 +49,15 @@ Definition par_map_reduce_map_server : val :=
Definition
par_map_reduce_collect
:
val
:
=
rec
:
"go"
"csort"
"i"
"ys"
:
=
if
:
~recv
"csort"
then
((
"i"
,
"ys"
),
NONE
)
else
if
:
~recv
"csort"
then
NONE
else
let
:
"jy"
:
=
recv
"csort"
in
let
:
"j"
:
=
Fst
"jy"
in
let
:
"y"
:
=
Snd
"jy"
in
if
:
"i"
=
"j"
then
"go"
"csort"
"j"
(
lcons
"y"
"ys"
)
else
((
"i"
,
"ys"
),
SOME
(
"j"
,
"y"
)
)
.
if
:
"i"
=
"j"
then
lcons
"y"
"ys"
;;
"go"
"csort"
"j"
"ys"
else
SOME
(
"j"
,
"y"
).
Definition
par_map_reduce_reduce_server
:
val
:
=
rec
:
"go"
"n"
"csort"
"cred"
"acc"
"zs"
:
=
if
:
"n"
=
#
0
then
"zs"
else
if
:
"n"
=
#
0
then
#()
else
if
:
recv
"cred"
then
(* Send item to mapper *)
match
:
"acc"
with
NONE
=>
...
...
@@ -65,15 +65,16 @@ Definition par_map_reduce_reduce_server : val :=
send
"cred"
#
false
;;
"go"
(
"n"
-
#
1
)
"csort"
"cred"
NONE
"zs"
|
SOME
"acc"
=>
(* Read subsequent items with the same key *)
let
:
"
grp
"
:
=
par_map_reduce_collect
"csort"
(
Fst
"acc"
)
(
lcons
(
Snd
"acc"
)
(
lnil
#()))
in
let
:
"
ys
"
:
=
lcons
(
Snd
"acc"
)
(
lnil
#())
in
let
:
"new_acc"
:
=
par_map_reduce_collect
"csort"
(
Fst
"acc"
)
"ys"
in
send
"cred"
#
true
;;
send
"cred"
(
Fst
"
grp
"
)
;;
"go"
"n"
"csort"
"cred"
(
Snd
"grp"
)
"zs"
send
"cred"
(
Fst
"
acc"
,
"ys
"
)
;;
"go"
"n"
"csort"
"cred"
"new_acc"
"zs"
end
else
(* receive item from mapper *)
let
:
"zs'"
:
=
recv
"cred"
in
"go"
"n"
"csort"
"cred"
"acc"
(
lapp
"zs'"
"zs"
).
lprep
"zs"
"zs'"
;;
"go"
"n"
"csort"
"cred"
"acc"
"zs"
.
Definition
cmpZfst
:
val
:
=
λ
:
"x"
"y"
,
Fst
"x"
≤
Fst
"y"
.
...
...
@@ -86,7 +87,8 @@ Definition par_map_reduce : val := λ: "n" "map" "red" "xs",
(* We need the first sorted element in the loop to compare subsequent elements *)
if
:
~recv
"csort"
then
lnil
#()
else
(* Handle the empty case *)
let
:
"jy"
:
=
recv
"csort"
in
par_map_reduce_reduce_server
"n"
"csort"
"cred"
(
SOME
"jy"
)
(
lnil
#()).
let
:
"zs"
:
=
lnil
#()
in
par_map_reduce_reduce_server
"n"
"csort"
"cred"
(
SOME
"jy"
)
"zs"
;;
"zs"
.
(** Properties about the functional version *)
...
...
@@ -220,7 +222,8 @@ Section mapper.
Definition
IZB
(
iy
:
Z
*
B
)
(
w
:
val
)
:
iProp
Σ
:
=
(
∃
w'
,
⌜
w
=
(#
iy
.
1
,
w'
)%
V
⌝
∧
IB
iy
.
1
iy
.
2
w'
)%
I
.
Definition
IZBs
(
iys
:
Z
*
list
B
)
(
w
:
val
)
:
iProp
Σ
:
=
(
∃
ws
,
⌜
w
=
(#
iys
.
1
,
llist
ws
)%
V
⌝
∧
[
∗
list
]
y
;
w'
∈
iys
.
2
;
ws
,
IB
iys
.
1
y
w'
)%
I
.
(
∃
(
l
:
loc
)
ws
,
⌜
w
=
(#
iys
.
1
,
#
l
)%
V
⌝
∗
llist
l
ws
∗
[
∗
list
]
y
;
w'
∈
iys
.
2
;
ws
,
IB
iys
.
1
y
w'
)%
I
.
Definition
RZB
:
relation
(
Z
*
B
)
:
=
prod_relation
(
≤
)%
Z
(
λ
_
_
:
B
,
True
).
Instance
RZB_dec
:
RelDecision
RZB
.
...
...
@@ -238,42 +241,42 @@ Section mapper.
repeat
case_bool_decide
=>
//
;
unfold
RZB
,
prod_relation
in
*
;
naive_solver
.
Qed
.
Lemma
par_map_reduce_map_server_spec
n
cmap
csort
vs
xs
X
ys
:
Lemma
par_map_reduce_map_server_spec
n
cmap
csort
l
vs
xs
X
ys
:
(
n
=
0
→
X
=
∅
∧
xs
=
[])
→
{{{
llist
l
vs
∗
cmap
↣
map_worker_protocol
IA
IZB
map
n
(
X
:
gmultiset
A
)
@
N
∗
csort
↣
sort_elem_head_protocol
IZB
RZB
ys
@
N
∗
([
∗
list
]
x
;
v
∈
xs
;
vs
,
IA
x
v
)
}}}
par_map_reduce_map_server
#
n
cmap
csort
(
llist
vs
)
par_map_reduce_map_server
#
n
cmap
csort
#
l
{{{
ys'
,
RET
#()
;
⌜
ys'
≡
ₚ
(
xs
++
elements
X
)
≫
=
map
⌝
∗
csort
↣
sort_elem_head_protocol
IZB
RZB
(
ys
++
ys'
)
@
N
}}}.
Proof
.
iIntros
(
Hn
Φ
)
"(Hcmap & Hcsort & HIA) HΦ"
.
iIntros
(
Hn
Φ
)
"(
Hl &
Hcmap & Hcsort & HIA) HΦ"
.
iL
ö
b
as
"IH"
forall
(
n
vs
xs
X
ys
Hn
Φ
)
;
wp_rec
;
wp_pures
;
simpl
.
case_bool_decide
;
wp_pures
;
simplify_eq
/=.
{
destruct
Hn
as
[->
->]
;
first
lia
.
iApply
(
"HΦ"
$!
[]).
rewrite
right_id_L
.
auto
.
}
destruct
n
as
[|
n
]=>
//=.
wp_branch
as
%?|%
_;
wp_pures
.
-
wp_apply
(
lisnil_spec
with
"
[//]
"
)
;
iIntros
(
_
)
.
-
wp_apply
(
lisnil_spec
with
"
Hl
"
)
;
iIntros
"Hl"
.
destruct
vs
as
[|
v
vs
],
xs
as
[|
x
xs
]
;
csimpl
;
try
done
;
wp_pures
.
+
wp_select
.
wp_pures
.
rewrite
Nat2Z
.
inj_succ
Z
.
sub_1_r
Z
.
pred_succ
.
iApply
(
"IH"
$!
_
_
[]
with
"[%] Hcmap Hcsort [//] HΦ"
)
;
naive_solver
.
iApply
(
"IH"
$!
_
_
[]
with
"[%]
Hl
Hcmap Hcsort [//] HΦ"
)
;
naive_solver
.
+
iDestruct
"HIA"
as
"[HIAx HIA]"
.
wp_select
.
wp_apply
(
l
head
_spec
with
"
[//]
"
)
;
iIntros
(
_
)
.
wp_apply
(
l
pop
_spec
with
"
Hl
"
)
;
iIntros
"Hl"
.
wp_send
with
"[$HIAx]"
.
wp_apply
(
ltail_spec
with
"[//]"
)
;
iIntros
(
_
).
wp_apply
(
"IH"
with
"[%] Hcmap Hcsort HIA"
)
;
first
done
.
wp_apply
(
"IH"
with
"[%] Hl Hcmap Hcsort HIA"
)
;
first
done
.
iIntros
(
ys'
).
rewrite
gmultiset_elements_disj_union
gmultiset_elements_singleton
.
rewrite
assoc_L
-(
comm
_
[
x
]).
iApply
"HΦ"
.
-
wp_recv
(
x
w
)
as
(
Hx
)
"HIBfx"
.
-
wp_recv
(
x
k
ws
)
as
(
Hx
)
"
[Hk
HIBfx
]
"
.
rewrite
-(
right_id
END
%
proto
_
(
sort_elem_head_protocol
_
_
_
)).
wp_apply
(
send_all_spec
with
"[$Hcsort $HIBfx]"
)
;
iIntros
"Hcsort"
.
wp_apply
(
send_all_spec
with
"[
$Hk
$Hcsort $HIBfx]"
)
;
iIntros
"Hcsort"
.
rewrite
right_id
.
wp_apply
(
"IH"
with
"[] Hcmap Hcsort HIA"
)
;
first
done
.
wp_apply
(
"IH"
with
"[]
Hl
Hcmap Hcsort HIA"
)
;
first
done
.
iIntros
(
ys'
).
iDestruct
1
as
(
Hys
)
"Hcsort"
;
simplify_eq
/=.
rewrite
-
assoc_L
.
iApply
(
"HΦ"
$!
(
map
x
++
ys'
)
with
"[$Hcsort]"
).
iPureIntro
.
rewrite
(
gmultiset_disj_union_difference
{[
x
]}
X
)
...
...
@@ -282,37 +285,39 @@ Section mapper.
by
rewrite
gmultiset_elements_singleton
assoc_L
bind_app
-
Hys
/=
right_id_L
comm
.
Qed
.
Lemma
par_map_reduce_collect_spec
csort
iys
iys_sorted
i
ys
ws
:
Lemma
par_map_reduce_collect_spec
csort
iys
iys_sorted
i
l
ys
ws
:
let
acc
:
=
from_option
(
λ
'
(
i
,
y
,
w
),
[(
i
,
y
)])
[]
in
let
accv
:
=
from_option
(
λ
'
(
i
,
y
,
w
),
SOMEV
(#(
i
:
Z
),
w
))
NONEV
in
ys
≠
[]
→
Sorted
RZB
(
iys_sorted
++
((
i
,)
<$>
ys
))
→
i
∉
iys_sorted
.*
1
→
{{{
llist
l
(
reverse
ws
)
∗
csort
↣
sort_elem_tail_protocol
IZB
RZB
iys
(
iys_sorted
++
((
i
,)
<$>
ys
))
@
N
∗
[
∗
list
]
y
;
w
∈
ys
;
ws
,
IB
i
y
w
}}}
par_map_reduce_collect
csort
#
i
(
llist
(
reverse
ws
))
{{{
ys'
ws'
miy
,
RET
((#
i
,
llist
(
reverse
ws'
)),
accv
miy
)
;
par_map_reduce_collect
csort
#
i
#
l
{{{
ys'
ws'
miy
,
RET
accv
miy
;
⌜
Sorted
RZB
((
iys_sorted
++
((
i
,)
<$>
ys
++
ys'
))
++
acc
miy
)
⌝
∗
⌜
from_option
(
λ
'
(
j
,
_
,
_
),
i
≠
j
∧
j
∉
iys_sorted
.*
1
)
(
iys_sorted
++
((
i
,)
<$>
ys
++
ys'
)
≡
ₚ
iys
)
miy
⌝
∗
llist
l
(
reverse
ws'
)
∗
csort
↣
from_option
(
λ
_
,
sort_elem_tail_protocol
IZB
RZB
iys
((
iys_sorted
++
((
i
,)
<$>
ys
++
ys'
))
++
acc
miy
))
END
%
proto
miy
@
N
∗
([
∗
list
]
y
;
w
∈
ys
++
ys'
;
ws'
,
IB
i
y
w
)
∗
from_option
(
λ
'
(
i
,
y
,
w
),
IB
i
y
w
)
True
miy
}}}.
Proof
.
iIntros
(
acc
accv
Hys
Hsort
Hi
Φ
)
"
[
Hcsort HIB
]
HΦ"
.
iIntros
(
acc
accv
Hys
Hsort
Hi
Φ
)
"
(Hl &
Hcsort
&
HIB
)
HΦ"
.
iL
ö
b
as
"IH"
forall
(
ys
ws
Hys
Hsort
Hi
Φ
)
;
wp_rec
;
wp_pures
;
simpl
.
wp_branch
as
%
_
|%
Hperm
;
last
first
;
wp_pures
.
{
iApply
(
"HΦ"
$!
[]
_
None
with
"[$Hcsort HIB]"
)
;
simpl
.
iEval
(
rewrite
!
right_id_L
)
;
auto
.
}