Commit d0e62387 authored by Ralf Jung's avatar Ralf Jung

prove the join-exist client

parent 9459fc48
...@@ -9,7 +9,7 @@ Definition client eM eW1 eW2 : expr [] := ...@@ -9,7 +9,7 @@ Definition client eM eW1 eW2 : expr [] :=
Section proof. Section proof.
Context (G : cFunctor). Context (G : cFunctor).
Context {Σ : gFunctors} `{!heapG Σ, !barrierG Σ, !oneShotG heap_lang Σ G}. Context {Σ : gFunctors} `{!heapG Σ, !barrierG Σ, !spawnG Σ, !oneShotG heap_lang Σ G}.
Context (heapN N : namespace). Context (heapN N : namespace).
Local Notation iProp := (iPropG heap_lang Σ). Local Notation iProp := (iPropG heap_lang Σ).
Local Notation X := (G iProp). Local Notation X := (G iProp).
...@@ -18,33 +18,88 @@ Definition barrier_res γ (P : X → iProp) : iProp := ...@@ -18,33 +18,88 @@ Definition barrier_res γ (P : X → iProp) : iProp :=
( x:X, one_shot_own γ x P x)%I. ( x:X, one_shot_own γ x P x)%I.
Lemma worker_spec e γ l (P Q : X iProp) (R : iProp) Φ : Lemma worker_spec e γ l (P Q : X iProp) (R : iProp) :
R ( x, {{ P x }} e {{ λ _, Q x }}) R ( x, {{ P x }} e {{ λ _, Q x }})
R (recv heapN N l (barrier_res γ P) ( v : val, barrier_res γ Q - Φ v )) R (recv heapN N l (barrier_res γ P))
R WP wait (%l) ;; e {{ Φ }}. R WP wait (%l) ;; e {{ λ _, barrier_res γ Q }}.
Proof. Proof.
intros He HΦ. rewrite -[R](idemp ()%I) {1}He HΦ always_and_sep_l {He HΦ}. 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. ewp (eapply wait_spec). ecancel [recv _ _ l _]. apply wand_intro_r. wp_seq.
rewrite /barrier_res sep_exist_l. apply exist_elim=>x. rewrite /barrier_res sep_exist_l. apply exist_elim=>x.
rewrite (forall_elim x) /ht always_elim impl_wand !assoc. rewrite (forall_elim x) /ht always_elim impl_wand !assoc.
to_front [P x; _ - _]%I. rewrite wand_elim_r !wp_frame_r. to_front [P x; _ - _]%I. rewrite wand_elim_r !wp_frame_r.
apply wp_mono=>v. rewrite (forall_elim v). rewrite -(exist_intro x). apply wp_mono=>v. by rewrite -(exist_intro x) comm.
to_front [one_shot_own _ _; Q _]. by rewrite wand_elim_r.
Qed. Qed.
Context (P' : iProp) (P P1 P2 Q Q1 Q2 : X iProp). Context (P' : iProp) (P P1 P2 Q Q1 Q2 : X -n> iProp).
Context {P_split : ( x:X, P x) (( x:X, P1 x) ( x:X, P2 x))}. Context {P_split : x:X, P x (P1 x P2 x)}.
Context {Q_join : (( x:X, Q1 x) ( x:X, Q2 x)) ( x:X, Q 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) : Lemma client_spec (eM eW1 eW2 : expr []) (eM' eW1' eW2' : expr ("b" :b: [])) (R : iProp) :
eM' = wexpr' eM eW1' = wexpr' eW1 eW2' = wexpr' eW2 heapN N eM' = wexpr' eM eW1' = wexpr' eW1 eW2' = wexpr' eW2
R ({{ P' }} eM {{ λ _, x, P x }}) R ({{ P' }} eM {{ λ _, x, P x }})
R ( x, {{ P1 x }} eW1 {{ λ _, Q1 x }}) R ( x, {{ P1 x }} eW1 {{ λ _, Q1 x }})
R ( x, {{ P2 x }} eW2 {{ λ _, Q2 x }}) R ( x, {{ P2 x }} eW2 {{ λ _, Q2 x }})
R heap_ctx heapN R heap_ctx heapN
R P'
R WP client eM' eW1' eW2' {{ λ _, γ, barrier_res γ Q }}. R WP client eM' eW1' eW2' {{ λ _, γ, barrier_res γ Q }}.
Proof. Proof.
Abort. 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. End proof.
...@@ -140,6 +140,17 @@ Proof. ...@@ -140,6 +140,17 @@ Proof.
apply wsubst_closed, not_elem_of_nil. apply wsubst_closed, not_elem_of_nil.
Qed. Qed.
(* Closed expressions *)
Instance do_wsubst_expr_nil' {X} x es (H : X `included` [x]) e :
WSubst x es H (wexpr' e) e | 0.
Proof. by rewrite /WSubst /wexpr' wsubst_wexpr' wsubst_closed_nil. Qed.
Instance do_wsubst_wexpr' X Y x es (H : X `included` x :: Y) e :
WSubst x es H (wexpr' e) (wexpr' e) | 1.
Proof.
rewrite /WSubst /wexpr' wsubst_wexpr'.
apply wsubst_closed, not_elem_of_nil.
Qed.
(* Boring connectives *) (* Boring connectives *)
Section wsubst. Section wsubst.
Context {X Y} (x : string) (es : expr []) (H : X `included` x :: Y). Context {X Y} (x : string) (es : expr []) (H : X `included` x :: Y).
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment