diff --git a/heap_lang/lang.v b/heap_lang/lang.v index fbc352ce21d7ec4f42063cd0bce22217e857caba..c8c9019612fd7ba7ea1e299cfa14d5c61b07c688 100644 --- a/heap_lang/lang.v +++ b/heap_lang/lang.v @@ -417,6 +417,10 @@ Proof. apply wsubst_closed, not_elem_of_nil. Qed. +Lemma of_val'_closed (v : val) : + of_val' v = of_val v. +Proof. by rewrite /of_val' wexpr_id. Qed. + (** to_val propagation. TODO: automatically appliy in wp_tactics? *) Lemma to_val_InjL e v : to_val e = Some v → to_val (InjL e) = Some (InjLV v). diff --git a/heap_lang/par.v b/heap_lang/par.v index 3bbdda8c5e49c51532f16ae52f9b10080d8d15a9..34332f9eac241475ba33e8c031df576101375eed 100644 --- a/heap_lang/par.v +++ b/heap_lang/par.v @@ -1,23 +1,50 @@ From heap_lang Require Export heap. -From heap_lang Require Import spawn notation. +From heap_lang Require Import spawn wp_tactics notation. +Import uPred. Definition par : val := λ: "f1" "f2", let: "handle" := ^spawn '"f1" in let: "v2" := '"f2" #() in let: "v1" := ^join '"handle" in Pair '"v1" '"v2". -Notation Par e1 e2 := (^par (λ: <>, e1)%V (λ: <>, e2)%V)%E. +Notation Par e1 e2 := (^par (λ: <>, e1) (λ: <>, e2))%E. +Infix "||" := Par : expr_scope. Section proof. Context {Σ : rFunctorG} `{!heapG Σ, !spawnG Σ}. Context (heapN N : namespace). Local Notation iProp := (iPropG heap_lang Σ). -Lemma par_spec (Ψ1 Ψ2 : val → iProp) (f1 f2 : val) (Φ : val → iProp) : - (#> f1 #() {{ Ψ1 }} ★ #> f2 #() {{ Ψ2 }} ★ +Lemma par_spec (Ψ1 Ψ2 : val → iProp) e1 e2 (f1 f2 : val) (Φ : val → iProp) : + heapN ⊥ N → to_val e1 = Some f1 → to_val e2 = Some f2 → + (* TODO like in spawn.v -- wp about e or f? *) + (heap_ctx heapN ★ #> e1 #() {{ Ψ1 }} ★ #> e2 #() {{ Ψ2 }} ★ ∀ v1 v2, Ψ1 v1 ★ Ψ2 v2 -★ Φ (PairV v1 v2)) - ⊑ #> par f1 f2 {{ Φ }}. + ⊑ #> par e1 e2 {{ Φ }}. Proof. -Abort. + intros. rewrite /par. + wp_focus e1. etransitivity; last by eapply wp_value. wp_let. + wp_focus e2. etransitivity; last by eapply wp_value. wp_let. + (ewp eapply spawn_spec); eauto using to_of_val. + apply sep_mono_r. rewrite (of_to_val e1) //. apply sep_mono_r. + apply forall_intro=>h. apply wand_intro_l. wp_let. + wp_focus (f2 _). rewrite wp_frame_r wp_frame_l. rewrite (of_to_val e2) //. + apply wp_mono=>v2. wp_let. + (ewp eapply join_spec); eauto using to_of_val. apply sep_mono_r. + apply forall_intro=>v1. apply wand_intro_l. wp_let. + etransitivity; last by (eapply wp_value, to_val_Pair; eapply to_of_val). + rewrite (forall_elim v1) (forall_elim v2). rewrite assoc. + eapply wand_apply_r'; done. +Qed. -End proof. \ No newline at end of file +Lemma wp_par (Ψ1 Ψ2 : val → iProp) (e1 e2 : expr []) (Φ : val → iProp) : + heapN ⊥ N → + (heap_ctx heapN ★ #> e1 {{ Ψ1 }} ★ #> e2 {{ Ψ2 }} ★ + ∀ v1 v2, Ψ1 v1 ★ Ψ2 v2 -★ Φ (PairV v1 v2)) + ⊑ #> e1 || e2 {{ Φ }}. +Proof. + intros. rewrite of_val'_closed -par_spec //. apply sep_mono_r. + apply sep_mono; last apply sep_mono_l; by wp_seq. +Qed. + +End proof. diff --git a/heap_lang/spawn.v b/heap_lang/spawn.v index 84676f0049a7b4e00213733a02e0cf1b181ea4a0..5bb8fe9d16cc26113bba0b226363d95b54622346 100644 --- a/heap_lang/spawn.v +++ b/heap_lang/spawn.v @@ -42,21 +42,27 @@ Global Instance join_handle_ne n l : Proof. solve_proper. Qed. (** The main proofs. *) -Lemma spawn_spec (Ψ : val → iProp) (f : val) (Φ : val → iProp) : +Lemma spawn_spec (Ψ : val → iProp) e (f : val) (Φ : val → iProp) : + to_val e = Some f → heapN ⊥ N → - (heap_ctx heapN ★ #> f #() {{ Ψ }} ★ ∀ l, join_handle l Ψ -★ Φ (%l)) - ⊑ #> spawn f {{ Φ }}. + (* TODO: Not sure whether the wp should be about [e] or [f]. Both work. *) + (heap_ctx heapN ★ #> e #() {{ Ψ }} ★ ∀ l, join_handle l Ψ -★ Φ (%l)) + ⊑ #> spawn e {{ Φ }}. Proof. - intros Hdisj. rewrite /spawn. wp_let. (ewp eapply wp_alloc); eauto with I. - strip_later. apply forall_intro=>l. apply wand_intro_l. wp_let. + intros Hval Hdisj. rewrite /spawn. + (* TODO: Make this more convenient. *) + wp_focus e. etransitivity; last by eapply wp_value. wp_let. + (* FIXME: can we change the ewp notation so that the parentheses become unnecessary? *) + (ewp eapply wp_alloc); eauto with I. strip_later. + apply forall_intro=>l. apply wand_intro_l. wp_let. rewrite (forall_elim l). eapply sep_elim_True_l. { eapply (own_alloc (Excl ())). done. } rewrite !pvs_frame_r. eapply wp_strip_pvs. rewrite !sep_exist_r. apply exist_elim=>γ. (* TODO: Figure out a better way to say "I want to establish ▷ spawn_inv". *) - trans (heap_ctx heapN ★ #> f #() {{ Ψ }} ★ (join_handle l Ψ -★ Φ (%l)%V) ★ + trans (heap_ctx heapN ★ #> e #() {{ Ψ }} ★ (join_handle l Ψ -★ Φ (%l)%V) ★ own γ (Excl ()) ★ ▷ (spawn_inv γ l Ψ))%I. - { ecancel [ #> f #() {{ _ }}; _ -★ _; heap_ctx _; own _ _]%I. + { ecancel [ #> _ {{ _ }}; _ -★ _; heap_ctx _; own _ _]%I. rewrite -later_intro /spawn_inv -(exist_intro (InjLV #0)). cancel [l ↦ InjLV #0]%I. apply or_intro_l'. by rewrite const_equiv. } rewrite (inv_alloc N) // !pvs_frame_l. eapply wp_strip_pvs. @@ -66,23 +72,49 @@ Proof. - wp_seq. rewrite -!assoc. eapply wand_apply_l; [done..|]. rewrite /join_handle. rewrite const_equiv // left_id -(exist_intro γ). solve_sep_entails. - - wp_focus (f _). rewrite wp_frame_r wp_frame_l. apply wp_mono=>v. + - wp_focus (f _). rewrite wp_frame_r wp_frame_l. + rewrite (of_to_val e) //. apply wp_mono=>v. eapply (inv_fsa (wp_fsa _)) with (N0:=N); simpl; (* TODO: Collect these in some Hint DB? Or add to an existing one? *) eauto using to_val_InjR,to_val_InjL,to_of_val with I ndisj. apply wand_intro_l. rewrite /spawn_inv {1}later_exist !sep_exist_r. - apply exist_elim=>vl. rewrite later_sep. + apply exist_elim=>lv. rewrite later_sep. eapply wp_store; eauto using to_val_InjR,to_val_InjL,to_of_val with I ndisj. - cancel [▷ (l ↦ vl)]%I. strip_later. apply wand_intro_l. + cancel [▷ (l ↦ lv)]%I. strip_later. apply wand_intro_l. rewrite right_id -later_intro -{2}[(∃ _, _ ↦ _ ★ _)%I](exist_intro (InjRV v)). ecancel [l ↦ _]%I. apply or_intro_r'. rewrite sep_elim_r sep_elim_r sep_elim_l. rewrite -(exist_intro v). rewrite const_equiv // left_id. apply or_intro_l. Qed. Lemma join_spec (Ψ : val → iProp) l (Φ : val → iProp) : - (join_handle l Ψ ★ ∀ v, Ψ v -★ Φ (%l)) + (join_handle l Ψ ★ ∀ v, Ψ v -★ Φ v) ⊑ #> join (%l) {{ Φ }}. Proof. -Abort. + wp_rec. wp_focus (! _)%E. + rewrite {1}/join_handle sep_exist_l !sep_exist_r. apply exist_elim=>γ. + rewrite -!assoc. apply const_elim_sep_l=>Hdisj. + eapply (inv_fsa (wp_fsa _)) with (N0:=N); simpl; eauto with I ndisj. + apply wand_intro_l. rewrite /spawn_inv {1}later_exist !sep_exist_r. + apply exist_elim=>lv. rewrite later_sep. + eapply wp_load; eauto with I ndisj. cancel [▷ (l ↦ lv)]%I. strip_later. + apply wand_intro_l. rewrite -later_intro -[X in _ ⊑ (X ★ _)](exist_intro lv). + cancel [l ↦ lv]%I. rewrite sep_or_r. apply or_elim. + - (* Case 1 : nothing sent yet, we wait. *) + rewrite -or_intro_l. apply const_elim_sep_l=>-> {lv}. + do 2 rewrite const_equiv // left_id. (ewp eapply wp_case_inl); eauto. + wp_seq. rewrite -always_wand_impl always_elim. + rewrite !assoc. eapply wand_apply_r'; first done. + rewrite -(exist_intro γ). solve_sep_entails. + - rewrite [(_ ★ □ _)%I]sep_elim_l -or_intro_r !sep_exist_r. apply exist_mono=>v. + rewrite -!assoc. apply const_elim_sep_l=>->{lv}. rewrite const_equiv // left_id. + rewrite sep_or_r. apply or_elim; last first. + { (* contradiction: we have the token twice. *) + rewrite [(heap_ctx _ ★ _)%I]sep_elim_r !assoc. rewrite -own_op own_valid_l. + rewrite -!assoc discrete_valid. apply const_elim_sep_l=>-[]. } + rewrite -or_intro_r. ecancel [own _ _]. + (ewp apply: wp_case_inr); eauto using to_of_val. + wp_let. etransitivity; last by eapply wp_value, to_of_val. + rewrite (forall_elim v). rewrite !assoc. eapply wand_apply_r'; eauto with I. +Qed. End proof.