diff --git a/_CoqProject b/_CoqProject index 8cc2e1a3b7f4b63962c34fb47a5bfe9a77d4f806..b4749740542cd68c1cf71c14c2df947590c0e760 100644 --- a/_CoqProject +++ b/_CoqProject @@ -55,11 +55,11 @@ theories/examples/lateearlychoice.v theories/examples/coinflip.v theories/examples/par.v - theories/experimental/cka.v theories/experimental/helping/offers.v theories/experimental/helping/helping_stack.v +theories/experimental/helping/helping_wrapper.v theories/experimental/hocap/counter.v theories/experimental/hocap/ticket_lock.v diff --git a/theories/examples/or.v b/theories/examples/or.v index 00ed7125c417c8931d67ce380222195bbeb6b968..510698a3faef48285135d9c9195a1d9dca73de74 100644 --- a/theories/examples/or.v +++ b/theories/examples/or.v @@ -30,7 +30,8 @@ Notation "e1 ⊕ e2" := (or (λ: <>, e1)%V (λ: <>, e2)%V) (at level 60) : val_scope. Section rules. - Context `{relocG Σ}. + Context `{!relocG Σ}. + Implicit Types e : expr. (** Symbolic execution rule for the LHS *) Definition or_inv x : iProp Σ := diff --git a/theories/examples/par.v b/theories/examples/par.v index 7040f745b7549509f44ccf335c513d0ac992b720..587f2560af40b1a09c91701b80533f5fd0cd177e 100644 --- a/theories/examples/par.v +++ b/theories/examples/par.v @@ -24,6 +24,7 @@ Notation "e1 ∥ e2" := (((e1;; #()) ||| (e2;; #()));; #())%E Section rules. Context `{!relocG Σ, !spawnG Σ}. + Implicit Type e t : expr. Lemma par_l_2 e1 e2 t : (WP e1 {{ _, True }}) -∗ @@ -85,20 +86,26 @@ Section rules. rel_pures_l. rel_rec_l. rel_pures_l. pose (N:=nroot.@"par"). - rewrite refines_eq /refines_def. iIntros (j K) "#Hspec Hj". - iModIntro. wp_bind (spawn _). - iApply (spawn_spec N (λ _, j ⤇ fill K #())%I with "[He1 Hj]"). + iApply refines_split. iIntros (k) "Hk". + rel_bind_l (spawn _). iApply refines_wp_l. + iApply (spawn_spec N (λ _, refines_right k #())%I with "[He1 Hk]"). - wp_pures. wp_bind e1. - iMod ("He1" with "Hspec Hj") as "He1". + rewrite refines_eq /refines_def. + iDestruct "Hk" as "[#Hs Hj]". + iMod ("He1" with "[$Hs $Hj]") as "He1". iApply (wp_wand with "He1"). iIntros (?) "P". wp_pures. - by iDestruct "P" as (v') "[Hj [-> ->]]". + iFrame "Hs". + by iDestruct "P" as (v') "[? [-> ->]]". - iNext. iIntros (l) "hndl". iSimpl. - wp_pures. wp_bind e2. + rel_pures_l. rel_bind_l e2. + iApply refines_wp_l. iApply (wp_wand with "He2"). iIntros (?) "_". - wp_pures. - wp_apply (join_spec with "hndl"). - iIntros (?) "Hj". wp_pures. iExists #(). eauto with iFrame. + simpl. rel_pures_l. rel_bind_l (spawn.join _). + iApply refines_wp_l. + iApply (join_spec with "hndl"). iNext. + iIntros (?) "Hk". simpl. rel_pures_l. iApply (refines_combine with "[] Hk"). + rel_values. Qed. Lemma par_l_1' Q K e1 e2 t : @@ -111,27 +118,30 @@ Section rules. rel_pures_l. rel_rec_l. rel_pures_l. pose (N:=nroot.@"par"). - rewrite {1 3}refines_eq /refines_def. iIntros (j K') "#Hspec Hj". - iModIntro. wp_bind (spawn _). - iApply (spawn_spec N (λ _, j ⤇ fill (K++K') #())%I with "[He1 Hj]"). + iApply refines_split. iIntros (k) "Hk". + rel_bind_l (spawn _). iApply refines_wp_l. + rewrite refines_right_bind. + iApply (spawn_spec N (λ _, refines_right k (fill K #()))%I with "[He1 Hk]"). - wp_pures. wp_bind e1. - rewrite -fill_app. - iMod ("He1" with "Hspec Hj") as "He1". + rewrite refines_eq /refines_def. + iAssert (spec_ctx) with "[Hk]" as "#Hs". + { iDestruct "Hk" as "[$ _]". } + iMod ("He1" with "Hk") as "He1". iApply (wp_wand with "He1"). iIntros (?) "P". wp_pures. - by iDestruct "P" as (v') "[Hj [-> ->]]". - - iNext. iIntros (l) "hndl". iSimpl. - wp_pures. wp_bind e2. + rewrite /refines_right. + iDestruct "P" as (v') "[Hj [-> ->]]". + iFrame "Hs". by rewrite fill_app. + - iNext. iIntros (l) "Hl". simpl. + rel_pures_l. rel_bind_l e2. + iApply refines_wp_l. iApply (wp_wand with "He2"). iIntros (?) "HQ". - wp_pures. - wp_apply (join_spec with "hndl"). - iIntros (?) "Hj". - iSpecialize ("Ht" with "HQ"). - rewrite refines_eq /refines_def. - rewrite fill_app. - iMod ("Ht" with "Hspec Hj") as "Ht". - rewrite wp_value_fupd. iMod "Ht" as (?) "[Ht [_ ->]]". - wp_pures. iExists #(). eauto with iFrame. + simpl. rel_pures_l. rel_bind_l (spawn.join _). + iApply refines_wp_l. + wp_apply (join_spec with "Hl"). + iIntros (?) "Hk". + iSpecialize ("Ht" with "HQ"). simpl. + rel_pures_l. iApply (refines_combine with "Ht Hk"). Qed. (* Lemma par_r_1 e1 e2 t (A : lrel Σ) E : *) @@ -202,14 +212,17 @@ Section rules. tp_pure i (App _ _). simpl. rel_pures_r. rel_bind_r e2. - iApply refines_spec_ctx. iIntros "#Hs". - iApply (par_l_1' (i ⤇ (#c2 <- InjR (#();; #())))%I + iApply (par_l_1' (refines_right i (#c2 <- InjR (#();; #())))%I with "He2 [He1 Hi]"). { rewrite refines_eq /refines_def. tp_bind i e1. - iMod ("He1" with "Hs Hi") as "He1". simpl. + rewrite refines_right_bind. + iAssert (spec_ctx) with "[Hi]" as "#Hs". + { iDestruct "Hi" as "[$ _]". } + iMod ("He1" with "Hi") as "He1". simpl. iApply (wp_wand with "He1"). iIntros (?). - iDestruct 1 as (?) "[Hi [-> ->]]". done. } + iDestruct 1 as (?) "[Hi [-> ->]]". + rewrite /refines_right. by iFrame. } iIntros "Hi". simpl. rel_pures_r. tp_pures i. tp_store i. rel_rec_r. rel_load_r. rel_pures_r. rel_values. @@ -242,28 +255,39 @@ Section rules. { simpl. eauto. } repeat rel_pure_r. tp_rec i. simpl. - rewrite {3}refines_eq /refines_def. - iIntros (j K) "#Hs Hj". iModIntro. + rewrite {3}refines_eq /refines_def /=. + iIntros (j' K). + set (j := {| tp_id := j'; tp_ctx := K |}). + iIntros "Hj". iModIntro. tp_bind j e2. tp_bind i e1. (* execute e1 *) wp_bind e1. tp_bind i e1. rewrite {1}refines_eq /refines_def. - iMod ("He1" with "Hs Hi") as "He1". + iDestruct "Hi" as "[#Hs Hi]". + iMod ("He1" $! (tp_id i) with "[Hi]") as "He1". + { rewrite /refines_right -fill_app //. by iFrame. } iApply (wp_wand with "He1"). iIntros (v1). iDestruct 1 as (v2) "[Hi Hv]". wp_pures. (* execute e2 *) rewrite refines_eq /refines_def. - iMod ("He2" with "Hs Hj") as "He2". + iMod ("He2" $! (tp_id j) with "[Hj]") as "He2". + { rewrite /refines_right -fill_app //. + cbn-[fill]. iFrame "Hj". } iApply wp_fupd. iApply (wp_wand with "He2"). iIntros (w1). iDestruct 1 as (w2) "[Hj Hw]". iSimpl in "Hi". iSimpl in "Hj". + iAssert (refines_right i (#c2 <- InjR v2)) with "[$Hi]" as "Hi". + { by iFrame. } + iAssert (refines_right j (let: "v2" := w2 in let: "v1" := spawn.join #c2 in ("v1", "v2"))) with "[Hj]" as "Hj". + { by iFrame. } tp_pure i _. tp_store i. tp_pures j. tp_rec j. tp_load j. tp_pures j. - iModIntro. iExists _. iFrame. + iModIntro. iExists _. + iDestruct "Hj" as "[_ $]". Qed. Lemma interchange a b c d (A B C D : lrel Σ) : @@ -286,45 +310,68 @@ Section rules. tp_rec i. simpl. rel_rec_l. repeat rel_pure_l. rewrite {5}refines_eq /refines_def. - iIntros (j K) "#Hs Hj". iModIntro. + iIntros (j' K). simpl. + set (j := {| tp_id := j'; tp_ctx := K |}). pose (N:=nroot.@"par"). + iIntros "Hj". iModIntro. wp_bind (spawn _). iApply (spawn_spec N with "[Ha Hj]"). - wp_lam. rewrite refines_eq /refines_def. tp_bind j a. - iMod ("Ha" with "Hs Hj") as "Ha". + iMod ("Ha" with "[Hj]") as "Ha". + { rewrite /refines_right -fill_app //. + cbn-[fill]. iFrame "Hj". } iExact "Ha". - iNext. iIntros (h) "Hdl". wp_pures. wp_bind b. rewrite {1}refines_eq /refines_def. tp_bind i b. - iMod ("Hb" with "Hs Hi") as "Hb". + iDestruct "Hi" as "[#Hs Hi]". + iMod ("Hb" with "[Hi]") as "Hb". + { rewrite /refines_right -fill_app //; by iFrame. } iApply (wp_wand with "Hb"). iIntros (bv). iDestruct 1 as (bv') "[Hi HB]". simpl. wp_pures. wp_bind (spawn.join _). iApply (join_spec with "Hdl"). iNext. iIntros (av). iDestruct 1 as (av') "[Hj HA]". - wp_pures. tp_pures j. tp_pures i. + wp_pures. + iAssert (refines_right i (#c2 <- InjR (bv';; c))) with "[Hi]" as "Hi". + { by iFrame. } + iAssert (refines_right j (let: "v2" := av';; d in + let: "v1" := spawn.join #c2 in ("v1", "v2"))) + with "[Hj]" as "Hj". + { by iFrame. } + tp_pures j. tp_pures i. wp_rec. wp_pures. wp_apply (spawn_spec N with "[Hc Hi]"). { wp_pures. - rewrite refines_eq /refines_def. + rewrite refines_eq /refines_def /=. tp_bind i c. - iMod ("Hc" with "Hs Hi") as "Hc". iExact "Hc". } + iMod ("Hc" with "[Hi]") as "Hc". + { rewrite /refines_right -fill_app //. } + iExact "Hc". } clear h. iIntros (h) "Hdl". wp_pures. wp_bind d. rewrite refines_eq /refines_def. tp_bind j d. - iMod ("Hd" with "Hs Hj") as "Hd". + iMod ("Hd" $! (tp_id j) with "[Hj]") as "Hd". + { rewrite /refines_right -fill_app //. + iSimpl. by iFrame. } iApply (wp_wand with "Hd"). iIntros (dv). iDestruct 1 as (dv') "[Hj HD]". wp_pures. wp_apply (join_spec with "Hdl"). iIntros (cv). iDestruct 1 as (cv') "[Hi HC]". iApply wp_fupd. wp_pures. iExists (cv', dv')%V. simpl. + iAssert (refines_right i (#c2 <- InjR cv')) with "[Hi]" as "Hi". + { by iFrame. } + iAssert (refines_right j (let: "v2" := dv' in let: "v1" := spawn.join #c2 in ("v1", "v2"))) with "[Hj]" as "Hj". + { by iFrame. } tp_pures i. tp_store i. tp_pures j. rewrite /spawn.join. tp_pures j. - tp_load j. tp_pures j. eauto with iFrame. + tp_load j. tp_pures j. + iModIntro; iSplit; eauto with iFrame. + iDestruct "Hj" as "[_ $]". Qed. End rules. diff --git a/theories/examples/ticket_lock.v b/theories/examples/ticket_lock.v index 4a65ea21ed887f751a5b97fa67dc5b0d41c18a09..ae23fda3363419cc361c816dffa7e5f753d7fa5a 100644 --- a/theories/examples/ticket_lock.v +++ b/theories/examples/ticket_lock.v @@ -21,7 +21,7 @@ Class tlockG Σ := tlock_G :> inG Σ (authR (gset_disjUR nat)). Definition tlockΣ : gFunctors := #[ GFunctor (authR $ gset_disjUR nat) ]. -Instance subG_tlockΣ {Σ} : subG tlockΣ Σ → tlockG Σ. +Global Instance subG_tlockΣ {Σ} : subG tlockΣ Σ → tlockG Σ. Proof. solve_inG. Qed. Definition lockPool := gset ((loc * loc * gname) * loc). @@ -30,7 +30,7 @@ Definition lockPoolR := gsetUR ((loc * loc * gname) * loc). Class lockPoolG Σ := lockPool_inG :> inG Σ (authR lockPoolR). Definition lockPoolΣ := #[ GFunctor (authR $ lockPoolR) ]. -Instance subG_lockPoolΣ {Σ} : subG lockPoolΣ Σ → lockPoolG Σ. +Global Instance subG_lockPoolΣ {Σ} : subG lockPoolΣ Σ → lockPoolG Σ. Proof. solve_inG. Qed. Section refinement. @@ -69,9 +69,9 @@ Section refinement. by iFrame. Qed. - Instance ticket_timeless γ n : Timeless (ticket γ n). + Global Instance ticket_timeless γ n : Timeless (ticket γ n). Proof. apply _. Qed. - Instance issuedTickets_timeless γ n : Timeless (issuedTickets γ n). + Global Instance issuedTickets_timeless γ n : Timeless (issuedTickets γ n). Proof. apply _. Qed. Opaque ticket issuedTickets. @@ -82,7 +82,7 @@ Section refinement. ∗ issuedTickets γ n ∗ is_locked_r l' b ∗ if b then ticket γ o else True)%I. - Instance ifticket_timeless (b : bool) γ o : + Local Instance ifticket_timeless (b : bool) γ o : Timeless (if b then ticket γ o else True)%I. Proof. destruct b; apply _. Qed. Instance lockInv_timeless lo ln γ l' : Timeless (lockInv lo ln γ l'). diff --git a/theories/examples/various.v b/theories/examples/various.v index 0ba447068ee8d72d85211fc4cd3596a712799caa..48db6e77209d1f3df3c08b79b78cea3dd04da5af 100644 --- a/theories/examples/various.v +++ b/theories/examples/various.v @@ -14,7 +14,7 @@ Instance subG_oneshotΣ {Σ} : subG oneshotΣ Σ → oneshotG Σ. Proof. solve_inG. Qed. Section proofs. - Context `{relocG Σ}. + Context `{!relocG Σ}. Lemma refinement1 : ⊢ REL @@ -366,7 +366,7 @@ Section proofs. (c1 ↦ #n ∗ c2 ↦ₛ #n ∗ pending γ) ∨ (c1 ↦ #(n+1) ∗ c2 ↦ₛ #n ∗ shot γ ∗ own γ' (Excl ())))%I. - Lemma profiled_g `{oneshotG Σ} `{inG Σ (exclR unitR)} γ γ' c1 c2 g1 g2 : + Lemma profiled_g `{oneshotG Σ} `{inG Σ (exclR unitR)} γ γ' c1 c2 (g1 g2 : expr) : inv shootN (i6 c1 c2 γ γ') -∗ â–¡ (REL g1 << g2 : () → ()) -∗ REL @@ -440,7 +440,8 @@ Section proofs. rel_values. } Qed. - Lemma profiled_g' `{oneshotG Σ} `{inG Σ (exclR unitR)} γ γ' c1 c2 g1 g2 : + Lemma profiled_g' `{!oneshotG Σ} `{!inG Σ (exclR unitR)} + γ γ' c1 c2 (g1 g2 : expr) : inv shootN (i6 c1 c2 γ γ') -∗ â–¡ (REL g1 << g2 : () → ()) -∗ REL @@ -469,7 +470,8 @@ Section proofs. iFrame. Qed. - Lemma refinement6_helper f'1 f'2 g1 g2 c1 c2 γ γ' m `{oneshotG Σ} `{inG Σ (exclR unitR)} : + Lemma refinement6_helper (f'1 f'2 g1 g2 : expr) + c1 c2 γ γ' m `{oneshotG Σ} `{inG Σ (exclR unitR)} : inv shootN (i6 c1 c2 γ γ') -∗ â–¡ (REL g1 << g2 : () → ()) -∗ â–¡ (REL f'1 << f'2 : (() → ()) → ()) -∗ diff --git a/theories/experimental/cka.v b/theories/experimental/cka.v index 9f83118a77d2fc54810269b305aa36a8689d0dd6..ad33e36cfa116347bd9ee6bf0d276cc06deb3ecb 100644 --- a/theories/experimental/cka.v +++ b/theories/experimental/cka.v @@ -174,7 +174,9 @@ Definition star : val := rec: "star" "f" := Notation "e **" := (star (λ: <>, e)%V) (at level 80). Section rules. - Context `{relocG Σ}. + Context `{!relocG Σ}. + + Implicit Types e : expr. Lemma star_compatible e e' : â–¡ (REL e << e' : ()) -∗ @@ -188,15 +190,6 @@ Section rules. - iApply "IH". Qed. - (* Lemma star_refines_l e t : *) - (* REL e ** << t : (). *) - (* Proof. *) - (* iIntros "H". rel_rec_l. repeat rel_pure_l. *) - (* iApply or_compatible; first by rel_values. *) - (* iApply refines_seq. *) - (* - rel_pure_l. rel_pure_r. iAssumption. *) - (* - iApply "IH". *) - Lemma star_id_1 e e' : â–¡(REL e << e' : ()) -∗ REL e ** << (#() ⊕ (e';; e' **))%V : (). diff --git a/theories/experimental/helping/helping_stack.v b/theories/experimental/helping/helping_stack.v index d160868c16fd5cca0d9df0b9e6fe99fbe74f3d33..b942ab5544bbb2635e33d3d30d44a68c52c50dd4 100644 --- a/theories/experimental/helping/helping_stack.v +++ b/theories/experimental/helping/helping_stack.v @@ -82,19 +82,18 @@ Definition CG_mkstack : val := λ: <>, value that is being offered and a potential thread with the continuation that accepts the offer, if it is present. *) -Canonical Structure ectx_itemO := leibnizO ectx_item. -Definition offerReg := gmap loc (val * gname * nat * (list ectx_item)). +Definition offerReg := gmap loc (val * gname * ref_id). Definition offerRegR := - gmapUR loc (agreeR (prodO valO (prodO gnameO (prodO natO (listO ectx_itemO))))). + gmapUR loc (agreeR (prodO valO (prodO gnameO ref_idO))). Class offerRegPreG Σ := OfferRegPreG { offerReg_inG :> inG Σ (authR offerRegR) }. -Definition offerize (x : (val * gname * nat * (list ectx_item))) : - (agreeR (prodO valO (prodO gnameO (prodO natO (listO ectx_itemO))))) := +Definition offerize (x : (val * gname * ref_id)) : + (agreeR (prodO valO (prodO gnameO ref_idO))) := match x with - | (v, γ, n, K) => to_agree (v, (γ, (n, K))) + | (v, γ, k) => to_agree (v, (γ, k)) end. Definition to_offer_reg : offerReg -> offerRegR := fmap offerize. @@ -102,32 +101,32 @@ Definition to_offer_reg : offerReg -> offerRegR := fmap offerize. Lemma to_offer_reg_valid N : ✓ to_offer_reg N. Proof. intros l. rewrite lookup_fmap. case (N !! l); simpl; try done. - intros [[[v γ] n] K]; simpl. done. + intros [[v γ] k]; simpl. done. Qed. Section offerReg_rules. Context `{!offerRegPreG Σ, !offerG Σ}. Lemma offerReg_alloc (o : loc) (v : val) (γ : gname) - (j : nat) (K : list ectx_item) (γo : gname) (N : offerReg) : + (k : ref_id) (γo : gname) (N : offerReg) : N !! o = None → own γo (â— to_offer_reg N) - ==∗ own γo (â— to_offer_reg (<[o:=(v, γ, j, K)]> N)) - ∗ own γo (â—¯ {[o := offerize (v, γ, j, K)]}). + ==∗ own γo (â— to_offer_reg (<[o:=(v, γ, k)]> N)) + ∗ own γo (â—¯ {[o := offerize (v, γ, k)]}). Proof. iIntros (HNo) "HN". iMod (own_update with "HN") as "[HN Hfrag]". { eapply auth_update_alloc. - eapply (alloc_singleton_local_update _ o (to_agree (v, (γ, (j, K))))); try done. + eapply (alloc_singleton_local_update _ o (to_agree (v, (γ, k)))); try done. by rewrite /to_offer_reg lookup_fmap HNo. } iFrame. by rewrite /to_offer_reg fmap_insert. Qed. Lemma offerReg_frag_lookup (o : loc) (v : val) (γ : gname) - (j : nat) (K : list ectx_item) (γo : gname) (N : offerReg) : + k (γo : gname) (N : offerReg) : own γo (â— to_offer_reg N) - -∗ own γo (â—¯ {[o := to_agree (v, (γ, (j, K)))]}) - -∗ ⌜N !! o = Some (v, γ, j, K)âŒ. + -∗ own γo (â—¯ {[o := to_agree (v, (γ, k))]}) + -∗ ⌜N !! o = Some (v, γ, k)âŒ. Proof. iIntros "HN Hfrag". iDestruct (own_valid_2 with "HN Hfrag") as %Hfoo. @@ -146,23 +145,23 @@ Section offerReg_rules. intros Hav. rewrite -(inj Some _ _ Hav). rewrite Some_included_total. - destruct av' as [[[??]?]?]. simpl. + destruct av' as [[??]?]. simpl. rewrite to_agree_included. fold_leibniz. intros. by simplify_eq. Qed. Lemma offerReg_lookup_frag (o : loc) (v : val) (γ : gname) - (j : nat) (K : list ectx_item) (γo : gname) (N : offerReg) : - N !! o = Some (v, γ, j, K) → + (k : ref_id) (γo : gname) (N : offerReg) : + N !! o = Some (v, γ, k) → own γo (â— to_offer_reg N) - ==∗ own γo (â—¯ {[o := to_agree (v, (γ, (j, K)))]}) + ==∗ own γo (â—¯ {[o := to_agree (v, (γ, k))]}) ∗ own γo (â— to_offer_reg N). Proof. iIntros (HNo) "Hown". iMod (own_update with "[Hown]") as "Hown". { eapply (auth_update (to_offer_reg N) ∅). - eapply (op_local_update_discrete _ ∅ {[o := to_agree (v, (γ, (j, K)))]}). + eapply (op_local_update_discrete _ ∅ {[o := to_agree (v, (γ, k))]}). intros. intros i. destruct (decide (i = o)); subst; rewrite lookup_op. + rewrite lookup_singleton lookup_fmap HNo. rewrite -Some_op. @@ -178,7 +177,7 @@ Section offerReg_rules. rewrite right_id. iFrame "Hown". } iDestruct "Hown" as "[Ho Hown]". rewrite right_id. iFrame. - assert ({[o := to_agree (v, (γ, (j, K)))]} â‹… to_offer_reg N ≡ to_offer_reg N) as Hfoo. + assert ({[o := to_agree (v, (γ, k))]} â‹… to_offer_reg N ≡ to_offer_reg N) as Hfoo. { intro i. rewrite /to_offer_reg lookup_merge !lookup_fmap. destruct (decide (i = o)); subst. @@ -196,9 +195,9 @@ Section offerReg_rules. Definition offerInv `{!relocG Σ} (N : offerReg) (st' : val) : iProp Σ := ([∗ map] l ↦ w ∈ N, match w with - | (v,γ,j,K) => is_offer γ l - (j ⤇ fill K (CG_locked_push st' (of_val v))%E) - (j ⤇ fill K #()) + | (v,γ,k) => is_offer γ l + (refines_right k (CG_locked_push st' (of_val v))%E) + (refines_right k #()) end)%I. Lemma offerInv_empty `{!relocG Σ} (st' : val) : ⊢ offerInv ∅ st'. @@ -210,7 +209,7 @@ Section offerReg_rules. rewrite /offerInv. iIntros "HN Ho". iAssert (⌜is_Some (N !! o)⌠→ False)%I as %Hbaz. { - iIntros ([[[[? ?] ?] ?] HNo]). + iIntros ([[[? ?] ?] HNo]). rewrite (big_sepM_lookup _ N o _ HNo). iApply (is_offer_exclusive with "HN Ho"). } @@ -251,25 +250,27 @@ Section refinement. This is also the only place where we need to unfold the definition of the refinement proposition. *) Lemma revoke_offer_l γ off E K (v : val) e1 e2 A : offer_token γ -∗ - (∀ j K', (j ⤇ fill K' e1) ={E}[⊤]â–·=∗ - â–· is_offer γ off (j ⤇ fill K' e1) (j ⤇ fill K' e2) ∗ - â–· (is_offer γ off (j ⤇ fill K' e1) (j ⤇ fill K' e2) -∗ + (∀ k, refines_right k e1 ={E}[⊤]â–·=∗ + â–· is_offer γ off (refines_right k e1) (refines_right k e2) ∗ + â–· (is_offer γ off (refines_right k e1) (refines_right k e2) -∗ ((REL fill K (of_val NONEV) << e2 @ E : A) ∧ (REL fill K (of_val $ SOMEV v) << e1 @ E : A)))) -∗ REL fill K (revoke_offer (v, #off)%V) << e1 @ E : A. Proof. iIntros "Hγ Hlog". - rewrite {3}refines_eq /refines_def. - iIntros (j K') "#Hs Hj". - iMod ("Hlog" with "Hj") as "Hlog". - iModIntro. iApply wp_bind. (* TODO: why do we have to use wp_bind here? *) + iApply refines_split. + iIntros (k) "Hk". + iMod ("Hlog" with "Hk") as "Hlog". + iApply refines_wp_l. wp_apply (wp_revoke_offer with "Hγ [-]"). iNext. iMod "Hlog" as "[Hoff Hcont]". iModIntro. iFrame "Hoff". iNext. iSplit. - iIntros "Hoff". iDestruct ("Hcont" with "Hoff") as "[Hcont _]". - rewrite refines_eq. by iApply "Hcont". + iIntros "Hk". iApply refines_left_fupd. + iApply (refines_combine with "Hcont Hk"). - iIntros "Hoff". iDestruct ("Hcont" with "Hoff") as "[_ Hcont]". - rewrite refines_eq. by iApply "Hcont". + iIntros "Hk". iApply refines_left_fupd. + iApply (refines_combine with "Hcont Hk"). Qed. (** Then we have definitions and lemmas that we use for actually @@ -320,10 +321,10 @@ Section refinement. ∗ is_stack st' ls2 ∗ ([∗ list] v1;v2 ∈ ls1;ls2, A v1 v2) ∗ (mb ↦ NONEV (* the mailbox is either empty or contains an offer that is in the registry *) - ∨ (∃ (l : loc) v1 v2 γ j K, + ∨ (∃ (l : loc) v1 v2 γ k, A v1 v2 ∗ mb ↦ SOMEV (v1, #l) - ∗ ⌜N !! l = Some (v2, γ, j, K)âŒ)) + ∗ ⌜N !! l = Some (v2, γ, k)âŒ)) ∗ own oname (â— to_offer_reg N) ∗ offerInv N st')%I. @@ -403,7 +404,7 @@ Section refinement. { iNext. iExists _, _, _, _; by iFrame. } iApply (pop_no_helping_refinement with "Hinv IH"). - (* YES OFFER *) - iDestruct "Hmb" as (l v1 v2 γ j K) "(#Hv & Hmb & >HNl)". + iDestruct "Hmb" as (l v1 v2 γ k) "(#Hv & >Hmb & >HNl)". iDestruct "HNl" as %HNl. rewrite /offerInv big_sepM_lookup_acc; eauto. iSimpl in "HN". iDestruct "HN" as "[HNl HN]". @@ -414,7 +415,7 @@ Section refinement. iMod ("Hcl" with "[-Hlown IH]") as "_". { iNext. iExists _, _, _, _; iFrame. iSplitL "Hmb". - - iRight. iExists _, _, _, _, _, _. + - iRight. iExists _, _, _, _, _. eauto with iFrame. - by iApply "HN". } @@ -434,22 +435,18 @@ Section refinement. rel_pures_l. iApply (pop_no_helping_refinement with "Hinv IH"). + (* An offer was accepted *) - iIntros "Hj Hoff". rel_pures_l. + iIntros "Hk Hoff". rel_pures_l. iDestruct "Hst2" as (st2l lk ->) "[Hlk Hst2]". - tp_rec j. tp_pures j. tp_rec j. + tp_rec k. tp_pures k. tp_rec k. unlock is_locked_r. iDestruct "Hlk" as (lk' ->) "Hl". (* TODO: make all the tp_ tactics work without the need for an explicit Fupd *) - iApply refines_spec_ctx. iIntros "#HÏ". - iApply fupd_refines. - (* because we manually applied `fupd_refines`, the tactical `with_spec_ctx` doesn't work anymore *) - tp_cmpxchg_suc j. - tp_pures j. tp_rec j. tp_pures j. - tp_load j. tp_pures j. - tp_store j. tp_pures j. - tp_rec j. tp_store j. - iSpecialize ("Hoff" with "Hj"). + tp_cmpxchg_suc k. + tp_pures k. tp_rec k. tp_pures k. + tp_load k. tp_pures k. + tp_store k. tp_pures k. + tp_rec k. tp_store k. + iSpecialize ("Hoff" with "Hk"). iSpecialize ("HN" with "Hoff"). - iClear "HÏ". iModIntro. rel_apply_r (refines_CG_pop_suc_r with "[Hst2 Hl]"). { iExists st2l,#lk'. rewrite /is_locked_r. by eauto with iFrame. } @@ -480,20 +477,20 @@ Section refinement. iAssert (∃ v, â–· mb ↦ v)%I with "[Hmb]" as (v) "Hmb". { iDestruct "Hmb" as "[Hmb | Hmb]". - iExists NONEV; eauto. - - iDestruct "Hmb" as (l m1 m2 γ' j K) "(Hm & Hmb & ?)". + - iDestruct "Hmb" as (l m1 m2 γ' k) "(Hm & Hmb & ?)". iExists (SOMEV (m1, #l)); eauto. } iExists _; iFrame; iNext. iIntros "Hmb". rel_pures_l. rel_apply_l (revoke_offer_l with "Htok"). - iIntros (j K') "Hj". iSpecialize ("Hoff" with "Hj"). + iIntros (k) "Hk". iSpecialize ("Hoff" with "Hk"). iDestruct (offerInv_excl with "HN Hoff") as %?. - iMod (offerReg_alloc off h2 γ j K' with "HNown") as "[HNown #Hfrag]"; eauto. + iMod (offerReg_alloc off h2 γ k with "HNown") as "[HNown #Hfrag]"; eauto. iMod ("Hcl" with "[-]") as "_". { iNext. iExists _,_,_,_; iFrame. iSplitL "Hmb". - - iRight. iExists off, h1, h2, _, _, _. iFrame "Hmb Hh". + - iRight. iExists off, h1, h2, _, _. iFrame "Hmb Hh". iPureIntro. by rewrite lookup_insert. - rewrite /offerInv big_sepM_insert; eauto with iFrame. } iModIntro. iNext. diff --git a/theories/experimental/helping/helping_wrapper.v b/theories/experimental/helping/helping_wrapper.v index b197ef2d6da45de0e9030863d557fb379bcacb18..b2c3cde172f733059e2f835e7b96ca5229374c0d 100644 --- a/theories/experimental/helping/helping_wrapper.v +++ b/theories/experimental/helping/helping_wrapper.v @@ -9,7 +9,6 @@ TODO: support recursion/callbacks into the wrapped functions. *) From iris.algebra Require Import auth gmap agree list excl. -From iris.base_logic.lib Require Import auth. From reloc Require Export reloc experimental.helping.offers. From reloc Require Import lib.list. @@ -46,19 +45,29 @@ Definition mk_helping : val := λ: "new_ds", (λ: <>, wrap_pop "f1" "mb", λ: "x", wrap_push "f2" "mb" "x"). +(** * Logical theory of an offer registry *) +(** We will use an "offer registery". It associates for each offer a +value that is being offered and a potential thread with the +continuation that accepts the offer, if it is present. *) + Canonical Structure ectx_itemO := leibnizO ectx_item. -Definition offerReg := gmap loc (val * gname * nat * (list ectx_item)). +(* TODO: move !! *) +Canonical Structure ref_idO := leibnizO ref_id. +Global Instance ref_id_inhabited : Inhabited ref_id. +Proof. split. apply (RefId 0 []). Qed. + +Definition offerReg := gmap loc (val * gname * ref_id). Definition offerRegR := - gmapUR loc (agreeR (prodO valO (prodO gnameO (prodO natO (listO ectx_itemO))))). + gmapUR loc (agreeR (prodO valO (prodO gnameO ref_idO))). Class offerRegPreG Σ := OfferRegPreG { - offerReg_inG :> authG Σ offerRegR + offerReg_inG :> inG Σ (authUR offerRegR) }. -Definition offerize (x : (val * gname * nat * (list ectx_item))) : - (agreeR (prodO valO (prodO gnameO (prodO natO (listO ectx_itemO))))) := +Definition offerize (x : (val * gname * ref_id)) : + (agreeR (prodO valO (prodO gnameO ref_idO))) := match x with - | (v, γ, n, K) => to_agree (v, (γ, (n, K))) + | (v, γ, k) => to_agree (v, (γ, k)) end. Definition to_offer_reg : offerReg -> offerRegR := fmap offerize. @@ -66,32 +75,32 @@ Definition to_offer_reg : offerReg -> offerRegR := fmap offerize. Lemma to_offer_reg_valid N : ✓ to_offer_reg N. Proof. intros l. rewrite lookup_fmap. case (N !! l); simpl; try done. - intros [[[v γ] n] K]; simpl. done. + intros [[v γ] k]; simpl. done. Qed. Section offerReg_rules. Context `{!offerRegPreG Σ, !offerG Σ}. Lemma offerReg_alloc (o : loc) (v : val) (γ : gname) - (j : nat) (K : list ectx_item) (γo : gname) (N : offerReg) : + (k : ref_id) (γo : gname) (N : offerReg) : N !! o = None → own γo (â— to_offer_reg N) - ==∗ own γo (â— to_offer_reg (<[o:=(v, γ, j, K)]> N)) - ∗ own γo (â—¯ {[o := offerize (v, γ, j, K)]}). + ==∗ own γo (â— to_offer_reg (<[o:=(v, γ, k)]> N)) + ∗ own γo (â—¯ {[o := offerize (v, γ, k)]}). Proof. iIntros (HNo) "HN". iMod (own_update with "HN") as "[HN Hfrag]". { eapply auth_update_alloc. - eapply (alloc_singleton_local_update _ o (to_agree (v, (γ, (j, K))))); try done. + eapply (alloc_singleton_local_update _ o (to_agree (v, (γ, k)))); try done. by rewrite /to_offer_reg lookup_fmap HNo. } iFrame. by rewrite /to_offer_reg fmap_insert. Qed. Lemma offerReg_frag_lookup (o : loc) (v : val) (γ : gname) - (j : nat) (K : list ectx_item) (γo : gname) (N : offerReg) : + k (γo : gname) (N : offerReg) : own γo (â— to_offer_reg N) - -∗ own γo (â—¯ {[o := to_agree (v, (γ, (j, K)))]}) - -∗ ⌜N !! o = Some (v, γ, j, K)âŒ. + -∗ own γo (â—¯ {[o := to_agree (v, (γ, k))]}) + -∗ ⌜N !! o = Some (v, γ, k)âŒ. Proof. iIntros "HN Hfrag". iDestruct (own_valid_2 with "HN Hfrag") as %Hfoo. @@ -110,23 +119,23 @@ Section offerReg_rules. intros Hav. rewrite -(inj Some _ _ Hav). rewrite Some_included_total. - destruct av' as [[[??]?]?]. simpl. + destruct av' as [[??]?]. simpl. rewrite to_agree_included. fold_leibniz. intros. by simplify_eq. Qed. Lemma offerReg_lookup_frag (o : loc) (v : val) (γ : gname) - (j : nat) (K : list ectx_item) (γo : gname) (N : offerReg) : - N !! o = Some (v, γ, j, K) → + (k : ref_id) (γo : gname) (N : offerReg) : + N !! o = Some (v, γ, k) → own γo (â— to_offer_reg N) - ==∗ own γo (â—¯ {[o := to_agree (v, (γ, (j, K)))]}) + ==∗ own γo (â—¯ {[o := to_agree (v, (γ, k))]}) ∗ own γo (â— to_offer_reg N). Proof. iIntros (HNo) "Hown". iMod (own_update with "[Hown]") as "Hown". { eapply (auth_update (to_offer_reg N) ∅). - eapply (op_local_update_discrete _ ∅ {[o := to_agree (v, (γ, (j, K)))]}). + eapply (op_local_update_discrete _ ∅ {[o := to_agree (v, (γ, k))]}). intros. intros i. destruct (decide (i = o)); subst; rewrite lookup_op. + rewrite lookup_singleton lookup_fmap HNo. rewrite -Some_op. @@ -142,7 +151,7 @@ Section offerReg_rules. rewrite right_id. iFrame "Hown". } iDestruct "Hown" as "[Ho Hown]". rewrite right_id. iFrame. - assert ({[o := to_agree (v, (γ, (j, K)))]} â‹… to_offer_reg N ≡ to_offer_reg N) as Hfoo. + assert ({[o := to_agree (v, (γ, k))]} â‹… to_offer_reg N ≡ to_offer_reg N) as Hfoo. { intro i. rewrite /to_offer_reg lookup_merge !lookup_fmap. destruct (decide (i = o)); subst. @@ -152,7 +161,8 @@ Section offerReg_rules. symmetry. apply agree_included. by apply to_agree_included. + rewrite lookup_singleton_ne; eauto. - by rewrite left_id. } + destruct ((offerize <$> N !! i)) as [?|] eqn:He; + rewrite He; simpl; done. } by rewrite Hfoo. Qed. @@ -160,9 +170,9 @@ Section offerReg_rules. Definition offerInv `{!relocG Σ} (N : offerReg) (f : val) : iProp Σ := ([∗ map] l ↦ w ∈ N, match w with - | (v,γ,j,K) => is_offer γ l - (j ⤇ fill K (f (of_val v))%E) - (j ⤇ fill K #()) + | (v,γ,k) => is_offer γ l + (refines_right k (f (of_val v))%E) + (refines_right k #()) end)%I. Lemma offerInv_empty `{!relocG Σ} (f : val) : ⊢ offerInv ∅ f. @@ -174,7 +184,7 @@ Section offerReg_rules. rewrite /offerInv. iIntros "HN Ho". iAssert (⌜is_Some (N !! o)⌠→ False)%I as %Hbaz. { - iIntros ([[[[? ?] ?] ?] HNo]). + iIntros ([[[? ?] ?] HNo]). rewrite (big_sepM_lookup _ N o _ HNo). iApply (is_offer_exclusive with "HN Ho"). } @@ -183,6 +193,7 @@ Section offerReg_rules. End offerReg_rules. + (** * Refinement proof *) Section refinement. Context `{!relocG Σ, !offerRegPreG Σ, !offerG Σ}. @@ -193,40 +204,29 @@ Section refinement. This is also the only place where we need to unfold the definition of the refinement proposition. *) Lemma revoke_offer_l γ off E K (v : val) e1 e2 A : offer_token γ -∗ - (∀ j K', (j ⤇ fill K' e1) ={E, ⊤, E}â–·=∗ - â–· is_offer γ off (j ⤇ fill K' e1) (j ⤇ fill K' e2) ∗ - â–· (is_offer γ off (j ⤇ fill K' e1) (j ⤇ fill K' e2) -∗ + (∀ k, refines_right k e1 ={E}[⊤]â–·=∗ + â–· is_offer γ off (refines_right k e1) (refines_right k e2) ∗ + â–· (is_offer γ off (refines_right k e1) (refines_right k e2) -∗ ((REL fill K (of_val NONEV) << e2 @ E : A) ∧ (REL fill K (of_val $ SOMEV v) << e1 @ E : A)))) -∗ REL fill K (revoke_offer (v, #off)%V) << e1 @ E : A. Proof. iIntros "Hγ Hlog". - rewrite {3}refines_eq /refines_def. - iIntros (j K') "#Hs Hj". - iMod ("Hlog" with "Hj") as "Hlog". - iModIntro. iApply wp_bind. (* TODO: why do we have to use wp_bind here? *) + iApply refines_split. + iIntros (k) "Hk". + iMod ("Hlog" with "Hk") as "Hlog". + iApply refines_wp_l. wp_apply (wp_revoke_offer with "Hγ [-]"). iNext. iMod "Hlog" as "[Hoff Hcont]". iModIntro. iFrame "Hoff". iNext. iSplit. - iIntros "Hoff". iDestruct ("Hcont" with "Hoff") as "[Hcont _]". - rewrite refines_eq. by iApply "Hcont". + iIntros "Hk". iApply refines_left_fupd. + iApply (refines_combine with "Hcont Hk"). - iIntros "Hoff". iDestruct ("Hcont" with "Hoff") as "[_ Hcont]". - rewrite refines_eq. by iApply "Hcont". + iIntros "Hk". iApply refines_left_fupd. + iApply (refines_combine with "Hcont Hk"). Qed. - (** We will also use the following instances for splitting and - compining read-only pointsto permissions. *) - Local Instance ro_pointsto_fromand (l : loc) (w : val) : - FromSep (∃ q, l ↦{q} w) (∃ q, l ↦{q} w) (∃ q, l ↦{q} w). - Proof. - rewrite /FromSep. iIntros "[$ _]". - Qed. - Local Instance ro_pointsto_intoand (l : loc) (w : val) : - IntoSep (∃ q, l ↦{q} w) (∃ q, l ↦{q} w) (∃ q, l ↦{q} w). - Proof. - rewrite /IntoSep /=. iDestruct 1 as (q) "[H1 H2]". - iSplitL "H1"; eauto with iFrame. - Qed. (* ************************************************** *) (** ** The main invariant that we will use for the proof *) @@ -234,17 +234,17 @@ Section refinement. Definition I A oname (mb : loc) (push_f : val) : iProp Σ := (∃ (N : offerReg), (mb ↦ NONEV (* the mailbox is either empty or contains an offer that is in the registry *) - ∨ (∃ (l : loc) v1 v2 γ j K, + ∨ (∃ (l : loc) v1 v2 γ k, A v1 v2 ∗ mb ↦ SOMEV (v1, #l) - ∗ ⌜N !! l = Some (v2, γ, j, K)âŒ)) + ∗ ⌜N !! l = Some (v2, γ, k)âŒ)) ∗ own oname (â— to_offer_reg N) ∗ offerInv N push_f)%I. Lemma wrap_pop_refinement A (pop1 pop2 push2 : val) γo mb : inv iN (I A γo mb push2) -∗ - (∀ e v2 j K, j ⤇ fill K (push2 (of_val v2)) -∗ - (j ⤇ fill K #() -∗ REL e << SOMEV v2 @ ⊤∖↑iN : () + A) -∗ + (∀ e v2 k, refines_right k (push2 (of_val v2)) -∗ + (refines_right k #() -∗ REL e << SOMEV v2 @ ⊤∖↑iN : () + A) -∗ REL e << pop2 #() @ ⊤∖↑iN : () + A) -∗ (REL pop1 << pop2 : () → () + A) -∗ REL wrap_pop pop1 #mb @@ -265,7 +265,7 @@ Section refinement. { iNext. iExists N; by iFrame. } iApply (refines_app with "Hpop"). by rel_values. - (* YES OFFER *) - iDestruct "Hmb" as (l v1 v2 γ j K) "(#Hv & Hmb & >HNl)". + iDestruct "Hmb" as (l v1 v2 γ k) "(#Hv & Hmb & >HNl)". iDestruct "HNl" as %HNl. rewrite /offerInv big_sepM_lookup_acc; eauto. iSimpl in "HN". iDestruct "HN" as "[HNl HN]". @@ -276,7 +276,7 @@ Section refinement. iMod ("Hcl" with "[-Hlown IH Hpop HpopGhost]") as "_". { iNext. iExists _. iFrame. iSplitL "Hmb". - - iRight. iExists _, _, _, _, _, _. + - iRight. iExists _, _, _, _, _. eauto with iFrame. - by iApply "HN". } @@ -328,20 +328,20 @@ Section refinement. iAssert (∃ v, â–· mb ↦ v)%I with "[Hmb]" as (v) "Hmb". { iDestruct "Hmb" as "[Hmb | Hmb]". - iExists NONEV; eauto. - - iDestruct "Hmb" as (l m1 m2 γ' j K) "(Hm & Hmb & ?)". + - iDestruct "Hmb" as (l m1 m2 γ' k) "(Hm & Hmb & ?)". iExists (SOMEV (m1, #l)); eauto. } iExists _; iFrame; iNext. iIntros "Hmb". rel_pures_l. rel_apply_l (revoke_offer_l with "Htok"). - iIntros (j K') "Hj". iSpecialize ("Hoff" with "Hj"). + iIntros (j) "Hj". iSpecialize ("Hoff" with "Hj"). iDestruct (offerInv_excl with "HN Hoff") as %?. - iMod (offerReg_alloc off h2 γ j K' with "HNown") as "[HNown #Hfrag]"; eauto. + iMod (offerReg_alloc off h2 γ with "HNown") as "[HNown #Hfrag]"; eauto. iMod ("Hcl" with "[-Hpush]") as "_". { iNext. iExists _. iFrame "HNown". iSplitL "Hmb". - - iRight. iExists off, h1, h2, _, _, _. iFrame "Hmb Hh". + - iRight. iExists off, h1, h2, _, _. iFrame "Hmb Hh". iPureIntro. by rewrite lookup_insert. - rewrite /offerInv big_sepM_insert; eauto with iFrame. } iModIntro. iNext. @@ -377,12 +377,12 @@ Section stack_example. Context `{!relocG Σ, !offerRegPreG Σ, !offerG Σ, !lockG Σ}. Definition stackI stl lk := - (∃ γ, is_lock (nroot.@"LoCk") γ lk (∃ ls1, stl ↦{1/2} val_of_list ls1))%I. + (∃ γ, is_lock (nroot.@"LoCk") γ lk (∃ ls1, stl ↦{#1/2} val_of_list ls1))%I. Definition stackInv A st st' := (∃ (stl : loc) lk, ⌜st = (#stl, lk)%V⌠∗ stackI stl lk ∗ inv stackN (∃ ls1 ls2, - (stl ↦{1/2} val_of_list ls1) + (stl ↦{#1/2} val_of_list ls1) ∗ is_stack st' ls2 ∗ ([∗ list] v1;v2 ∈ ls1;ls2, A v1 v2)))%I. @@ -395,23 +395,18 @@ Section stack_example. Proof. iIntros "#Hinv #Hstack". iApply (wrap_pop_refinement with "Hinv [] []"). - { iIntros (e v2 j K) "Hj Hcont". + { iIntros (e v2 j) "Hj Hcont". rel_pures_r. iDestruct "Hstack" as (st1l lk1 ->) "[#HstI #Hstack]". iInv stackN as (ls1 ls2) "(Hst1 & >Hst2 & HA)" "Hcl". iDestruct "Hst2" as (st2l lk2 ->) "[Hlk Hst2]". tp_rec j. tp_pures j. tp_rec j. tp_pures j. tp_rec j. unlock is_locked_r. iDestruct "Hlk" as (lk' ->) "Hl". - (* TODO: make all the tp_ tactics work without the need for an explicit Fupd *) - iApply refines_spec_ctx. iIntros "#HÏ". - iApply fupd_refines. - (* because we manually applied `fupd_refines`, the tactical `with_spec_ctx` doesn't work anymore *) tp_cmpxchg_suc j. tp_pures j. tp_rec j. tp_pures j. tp_load j. tp_pures j. tp_store j. tp_pures j. tp_rec j. tp_store j. - iClear "HÏ". iModIntro. rel_apply_r (refines_CG_pop_suc_r with "[Hst2 Hl]"). { iExists st2l,#lk'. rewrite /is_locked_r. by eauto with iFrame. } iIntros "Hst2". @@ -517,7 +512,7 @@ Section stack_example. do 5 rel_pure_r. rel_rec_l. rel_rec_l. rel_rec_l. rel_rec_l. rel_alloc_l st as "[Hst1 Hl1]". rel_pures_l. - rel_apply_l (refines_newlock_l (nroot.@"LoCk") (∃ ls1, st ↦{1/2} val_of_list ls1)%I with "[Hl1]"). + rel_apply_l (refines_newlock_l (nroot.@"LoCk") (∃ ls1, st ↦{#1/2} val_of_list ls1)%I with "[Hl1]"). { iExists []. iFrame. } iNext. iIntros (lk1 γ) "#Hlk1". rel_pures_l. rel_alloc_l mb as "Hmb". @@ -526,7 +521,7 @@ Section stack_example. iMod (own_alloc (â— to_offer_reg ∅ : authR offerRegR)) as (γo) "Hor". { apply auth_auth_valid. apply to_offer_reg_valid. } iMod (inv_alloc stackN _ (∃ ls1 ls2, - (st ↦{1/2} val_of_list ls1) + (st ↦{#1/2} val_of_list ls1) ∗ is_stack (#st',lk2) ls2 ∗ ([∗ list] v1;v2 ∈ ls1;ls2, A v1 v2)) with "[Hst1 Hst2 Hlk2]") as "#Hinv". { iNext. iExists [], []; simpl; iFrame. rewrite right_id. diff --git a/theories/experimental/helping/offers.v b/theories/experimental/helping/offers.v index f54792c453a60061e137f8fd52b4d6e6aa7ff2fe..9ba03c8510ceb667ccfdaed81ff6705831087905 100644 --- a/theories/experimental/helping/offers.v +++ b/theories/experimental/helping/offers.v @@ -37,7 +37,7 @@ Section rules. is_offer γ1 l P1 Q1 -∗ is_offer γ2 l P2 Q2 -∗ False. Proof. iDestruct 1 as (?) "[Hl1 _]". iDestruct 1 as (?) "[Hl2 _]". - iDestruct (gen_heap.mapsto_valid_2 with "Hl1 Hl2") as %[??]. contradiction. + iDestruct (gen_heap.mapsto_valid_2 with "Hl1 Hl2") as %[? _]. contradiction. Qed. Lemma make_is_offer γ l P Q : l ↦ #0 -∗ P -∗ is_offer γ l P Q. diff --git a/theories/logic/adequacy.v b/theories/logic/adequacy.v index 92c72bb7a63ad8cc171cca278d5792249c68e2ba..ccbdcea43b67d21836d72b4922ee0992abaa978b 100644 --- a/theories/logic/adequacy.v +++ b/theories/logic/adequacy.v @@ -16,7 +16,7 @@ Proof. solve_inG. Qed. Lemma refines_adequate Σ `{relocPreG Σ} (A : ∀ `{relocG Σ}, lrel Σ) - (P : val → val → Prop) e e' σ : + (P : val → val → Prop) (e e' : expr) σ : (∀ `{relocG Σ}, ∀ v v', A v v' -∗ ⌜P v v'âŒ) → (∀ `{relocG Σ}, ⊢ REL e << e' : A) → adequate NotStuck e σ @@ -39,11 +39,11 @@ Proof. iSplitL. - iPoseProof (Hlog _) as "Hrel". rewrite refines_eq /refines_def /spec_ctx. - iApply fupd_wp. - iSpecialize ("Hrel" $! 0 [] with "[Hcfg]"); first by eauto. - iApply "Hrel". - rewrite tpool_mapsto_eq /tpool_mapsto_def. iFrame. - by rewrite /to_tpool /= insert_empty map_fmap_singleton //. + iApply fupd_wp. iApply ("Hrel" $! 0 []). + iSplitR. + + iExists _. by iFrame. + + rewrite tpool_mapsto_eq /tpool_mapsto_def. + by rewrite /to_tpool /= insert_empty map_fmap_singleton //. - iIntros (v). iDestruct 1 as (v') "[Hj Hinterp]". rewrite HA. @@ -59,7 +59,7 @@ Proof. iIntros "!> !%"; eauto. Qed. -Theorem refines_typesafety Σ `{relocPreG Σ} e e' e1 +Theorem refines_typesafety Σ `{relocPreG Σ} (e e' : expr) e1 (A : ∀ `{relocG Σ}, lrel Σ) thp σ σ' : (∀ `{relocG Σ}, ⊢ REL e << e' : A) → rtc erased_step ([e], σ) (thp, σ') → e1 ∈ thp → diff --git a/theories/logic/compatibility.v b/theories/logic/compatibility.v index 31f9d311590b50648e74c0245117e0fd110c91b1..7acf8e55c66d7462b2531093e76776539dcb7886 100644 --- a/theories/logic/compatibility.v +++ b/theories/logic/compatibility.v @@ -8,7 +8,8 @@ From reloc.logic Require Export model rules. From reloc.logic Require Import proofmode.tactics proofmode.spec_tactics model. Section compatibility. - Context `{relocG Σ}. + Context `{!relocG Σ}. + Implicit Types e : expr. Local Ltac value_case := try rel_pure_l; try rel_pure_r; rel_values. @@ -53,21 +54,6 @@ Section compatibility. done. Qed. - Lemma refines_fork e e' E : - ↑relocN ⊆ E → - (REL e << e' @ E : ()) -∗ - REL Fork e << Fork e' @ E : (). - Proof. - iIntros (?) "IH". - rewrite refines_eq /refines_def. - iIntros (j K) "Hs Hj /=". - tp_fork j as i "Hi". - iMod ("IH" $! i [] with "Hs Hi") as "IH". - iApply (wp_fork with "[-Hj]"). - - iNext. iApply (wp_wand with "IH"). eauto. - - iExists #(); eauto. - Qed. - Lemma refines_pack (A : lrel Σ) e e' (C : lrel Σ → lrel Σ) : (REL e << e' : C A) -∗ REL e << e' : ∃ A, C A. diff --git a/theories/logic/derived.v b/theories/logic/derived.v index 934eef8ae252190801a5120d53a25ceacfec1959..e0ff1f8503bb570982872d3f425e27cbebd70c38 100644 --- a/theories/logic/derived.v +++ b/theories/logic/derived.v @@ -9,6 +9,7 @@ From reloc.logic Require Export model rules. Section rules. Context `{relocG Σ}. Implicit Types A : lrel Σ. + Implicit Types e : expr. Lemma refines_wand E e1 e2 A A' : (REL e1 << e2 @ E : A) -∗ @@ -24,7 +25,7 @@ Section rules. Lemma refines_arrow (v v' : val) A A' : â–¡ (∀ v1 v2 : val, â–¡(REL of_val v1 << of_val v2 : A) -∗ REL App v (of_val v1) << App v' (of_val v2) : A') -∗ - REL v << v' : (A → A')%lrel. + REL (of_val v) << (of_val v') : (A → A')%lrel. Proof. iIntros "#H". iApply refines_arrow_val; eauto. diff --git a/theories/logic/model.v b/theories/logic/model.v index afd17a5eef7b474ce3f03cac29f31655f580ae60..fa24ce78752a005eae6fb8f818bc3a17b258dd98 100644 --- a/theories/logic/model.v +++ b/theories/logic/model.v @@ -53,6 +53,16 @@ End lrel_ofe. Arguments lrelC : clear implicits. +Record ref_id := RefId { + tp_id : nat; + tp_ctx : list ectx_item }. + +Canonical Structure ectx_itemO := leibnizO ectx_item. +Canonical Structure ref_idO := leibnizO ref_id. + +Global Instance ref_id_inhabited : Inhabited ref_id. +Proof. split. apply (RefId 0 []). Qed. + Section semtypes. Context `{relocG Σ}. @@ -60,10 +70,23 @@ Section semtypes. Implicit Types E : coPset. Implicit Types A B : lrel Σ. + Definition rhs_t := sum expr ref_id. + Definition in_1 : expr -> rhs_t := inl. + Definition in_2 : ref_id -> rhs_t := inr. + Coercion in_1 : expr >-> rhs_t. + + + Definition refines_right (k : ref_id) (e : expr) := + (spec_ctx ∗ (tp_id k) ⤇ fill (tp_ctx k) e)%I. + Definition refines_def (E : coPset) - (e e' : expr) (A : lrel Σ) : iProp Σ := - (∀ j K, spec_ctx -∗ j ⤇ fill K e' - ={E,⊤}=∗ WP e {{ v, ∃ v', j ⤇ fill K (of_val v') ∗ A v v' }})%I. + (e : expr) (e'k : rhs_t) (A : lrel Σ) : iProp Σ := + (∀ j K, + match e'k with + | inl e' => refines_right (RefId j K) e' + | inr k => ⌜j = tp_id k⌠∗ ⌜K = tp_ctx k⌠+ end -∗ + |={E,⊤}=> WP e {{ v, ∃ v', j ⤇ fill K (of_val v') ∗ A v v' }})%I. Definition refines_aux : seal refines_def. Proof. by eexists. Qed. Definition refines := unseal refines_aux. @@ -83,7 +106,7 @@ Section semtypes. Definition lrel_int : lrel Σ := LRel (λ w1 w2, ∃ n : Z, ⌜ w1 = #n ∧ w2 = #n âŒ)%I. Definition lrel_arr (A1 A2 : lrel Σ) : lrel Σ := LRel (λ w1 w2, - â–¡ ∀ v1 v2, A1 v1 v2 -∗ refines ⊤ (App w1 v1) (App w2 v2) A2)%I. + â–¡ ∀ v1 v2, A1 v1 v2 -∗ refines ⊤ (App w1 v1) (in_1 (App w2 v2)) A2)%I. Definition lrel_ref (A : lrel Σ) : lrel Σ := LRel (λ w1 w2, ∃ l1 l2: loc, ⌜w1 = #l1⌠∧ ⌜w2 = #l2⌠∧ @@ -192,34 +215,89 @@ Section semtypes_properties. End semtypes_properties. +(* Notation "'REL' e1 '<<' e2 '@' E ':' A" := *) +(* (refines E e1%E (inl e2%E) (A)%lrel) *) +(* (at level 100, E at next level, e1, e2 at next level, *) +(* A at level 200, *) +(* format "'[hv' 'REL' e1 '/' '<<' '/ ' e2 '@' E : A ']'"). *) +(* Notation "'REL' e1 '<<' e2 ':' A" := *) +(* (refines ⊤ e1%E (inl e2%E) (A)%lrel) *) +(* (at level 100, e1, e2 at next level, *) +(* A at level 200, *) +(* format "'[hv' 'REL' e1 '/' '<<' '/ ' e2 : A ']'"). *) +Notation "'REL' e1 '<<{' id '}' '_' ':' A" := + (refines ⊤ e1%E (in_2 id) (A)%lrel) + (at level 100, e1 at next level, + A at level 200, + format "'[hv' 'REL' e1 '/' '<<{' id '}' '/ ' '_' : A ']'"). +Notation "'REL' e1 '<<{' id '}' '_' '@' E ':' A" := + (refines E e1%E (in_2 id) (A)%lrel) + (at level 100, E at next level, e1 at next level, + A at level 200, + format "'[hv' 'REL' e1 '/' '<<{' id '}' '/ ' '_' '@' E ':' A ']'"). +(* ( ̄~ ̄;) OOF *) Notation "'REL' e1 '<<' e2 '@' E ':' A" := (refines E e1%E e2%E (A)%lrel) (at level 100, E at next level, e1, e2 at next level, A at level 200, format "'[hv' 'REL' e1 '/' '<<' '/ ' e2 '@' E : A ']'"). -Notation "'REL' e1 '<<' e2 ':' A" := - (refines ⊤ e1%E e2%E (A)%lrel) - (at level 100, e1, e2 at next level, +Notation "'REL' e1 '<<' t ':' A" := + (refines ⊤ e1%E t%E (A)%lrel) + (at level 100, e1, t at next level, A at level 200, - format "'[hv' 'REL' e1 '/' '<<' '/ ' e2 : A ']'"). + format "'[hv' 'REL' e1 '/' '<<' '/ ' t : A ']'"). (** Properties of the relational interpretation *) Section related_facts. - Context `{relocG Σ}. + Context `{!relocG Σ}. + Implicit Types e : expr. + + + Lemma refines_split E e e' A : + (∀ k, refines_right k e' -∗ REL e <<{k} _ @ E : A) -∗ + REL e << e' @ E : A. + Proof. + iIntros "H". + rewrite refines_eq /refines_def. + iIntros (j K) "He'". pose (k := RefId j K). + iSpecialize ("H" $! k with "He'"). + by iApply "H". + Qed. + + Lemma refines_combine E e e' A k : + (REL e << e' @ E : A) -∗ + refines_right k e' -∗ + REL e <<{k} _ @ E : A. + Proof. + iIntros "H1 H2". + rewrite refines_eq /refines_def. + iIntros (j K) "[% %]". + iApply "H1". by destruct k; simplify_eq/=. + Qed. (* We need this to be able to open and closed invariants in front of logrels *) - Lemma fupd_refines E1 E2 e e' A : - (|={E1,E2}=> REL e << e' @ E2 : A) -∗ REL e << e' @ E1 : A. + Lemma fupd_refines E1 E2 e t A : + (|={E1, E2}=> refines E2 e t A) -∗ refines E1 e t A. + Proof. + rewrite refines_eq /refines_def. + iIntros "H". iIntros (j K) "Hr /=". + iMod "H" as "H". iApply ("H" with "Hr"). + Qed. + + Lemma refines_left_fupd E e k A : + (REL e <<{k} _ @ E : A) ={E,⊤}=∗ REL e <<{k} _ @ ⊤ : A. Proof. rewrite refines_eq /refines_def. - iIntros "H". iIntros (j K) "#Hs Hj /=". - iMod "H" as "H". iApply ("H" with "Hs Hj"). + iIntros "H". simpl. + iSpecialize ("H" $! (tp_id k) (tp_ctx k) with "[%//]"). + iMod "H" as "H". iModIntro. + iIntros (j K) "[-> ->]". done. Qed. - Global Instance elim_fupd_refines p E1 E2 e e' P A : + Global Instance elim_fupd_refines p E1 E2 e t P A : (* TODO: DF: look at the booleans here *) ElimModal True p false (|={E1,E2}=> P) P - (REL e << e' @ E1 : A) (REL e << e' @ E2: A). + (refines E1 e t A) (refines E2 e t A). Proof. rewrite /ElimModal. intros _. iIntros "[HP HI]". iApply fupd_refines. @@ -227,51 +305,43 @@ Section related_facts. iMod "HP"; iModIntro; by iApply "HI". Qed. - Global Instance elim_bupd_logrel p E e e' P A : + Global Instance elim_bupd_logrel p E e t P A : ElimModal True p false (|==> P) P - (REL e << e' @ E : A) (REL e << e' @ E : A). + (refines E e t A) (refines E e t A). Proof. rewrite /ElimModal (bupd_fupd E). apply: elim_fupd_refines. Qed. (* This + elim_modal_timless_bupd' is useful for stripping off laters of timeless propositions. *) - Global Instance is_except_0_logrel E e e' A : - IsExcept0 (REL e << e' @ E : A). + Global Instance is_except_0_logrel E e t A : + IsExcept0 (refines E e t A). Proof. rewrite /IsExcept0. iIntros "HL". iApply fupd_refines. by iMod "HL". Qed. - - Lemma refines_spec_ctx E e e' A : - (spec_ctx -∗ REL e << e' @ E : A) -∗ - (REL e << e' @ E : A). - Proof. - rewrite refines_eq /refines_def. - iIntros "Hctx". iIntros (j K) "#Hspec". - by iApply "Hctx". - Qed. End related_facts. Section monadic. - Context `{relocG Σ}. + Context `{!relocG Σ}. + Implicit Types e : expr. Lemma refines_bind K K' E A A' e e' : (REL e << e' @ E : A) -∗ (∀ v v', A v v' -∗ - REL fill K (of_val v) << fill K' (of_val v') : A') -∗ + REL fill K (of_val v) << (fill K' (of_val v')) : A') -∗ REL fill K e << fill K' e' @ E : A'. Proof. iIntros "Hm Hf". - rewrite refines_eq /refines_def. - iIntros (j Kâ‚) "#Hs Hj /=". - iSpecialize ("Hm" with "Hs"). - rewrite -fill_app. iMod ("Hm" with "Hj") as "Hm". + rewrite refines_eq /refines_def /refines_right. + iIntros (j Kâ‚) "[#Hs Hj] /=". + rewrite -fill_app. + iMod ("Hm" with "[$Hs $Hj]") as "Hm". iModIntro. iApply wp_bind. iApply (wp_wand with "Hm"). iIntros (v). iDestruct 1 as (v') "[Hj HA]". rewrite fill_app. - by iMod ("Hf" with "HA Hs Hj") as "Hf/=". + by iMod ("Hf" with "HA [$Hs $Hj]") as "Hf/=". Qed. Lemma refines_ret E e1 e2 v1 v2 (A : lrel Σ) : @@ -279,9 +349,10 @@ Section monadic. IntoVal e2 v2 → (|={E,⊤}=> A v1 v2) -∗ REL e1 << e2 @ E : A. Proof. + rewrite /IntoVal. iIntros (<-<-) "HA". rewrite refines_eq /refines_def. - iIntros (j K) "#Hs Hj /=". + iIntros (j K) "[#Hs Hj] /=". iMod "HA" as "HA". iModIntro. iApply wp_value. iExists _. by iFrame. Qed. diff --git a/theories/logic/proofmode/spec_tactics.v b/theories/logic/proofmode/spec_tactics.v index 4635215d88256c8b18cfcfcaa6363fdf7ea9d434..355979984ca35d48bfc8e6e30f1d128ba44cd025 100644 --- a/theories/logic/proofmode/spec_tactics.v +++ b/theories/logic/proofmode/spec_tactics.v @@ -10,10 +10,10 @@ Set Default Proof Using "Type". (** * TP tactics *) (** ** bind *) -Lemma tac_tp_bind_gen `{relocG Σ} j Δ Δ' i p e e' Q : - envs_lookup i Δ = Some (p, j ⤇ e)%I → +Lemma tac_tp_bind_gen `{relocG Σ} k Δ Δ' i p e e' Q : + envs_lookup i Δ = Some (p, refines_right k e)%I → e = e' → - envs_simple_replace i p (Esnoc Enil i (j ⤇ e')) Δ = Some Δ' → + envs_simple_replace i p (Esnoc Enil i (refines_right k e')) Δ = Some Δ' → (envs_entails Δ' Q) → (envs_entails Δ Q). Proof. @@ -22,10 +22,10 @@ Proof. destruct p; rewrite /= ?right_id; by rewrite bi.wand_elim_r. Qed. -Lemma tac_tp_bind `{relocG Σ} j e' Δ Δ' i p K' e Q : - envs_lookup i Δ = Some (p, j ⤇ e)%I → +Lemma tac_tp_bind `{relocG Σ} k e' Δ Δ' i p K' e Q : + envs_lookup i Δ = Some (p, refines_right k e)%I → e = fill K' e' → - envs_simple_replace i p (Esnoc Enil i (j ⤇ fill K' e')) Δ = Some Δ' → + envs_simple_replace i p (Esnoc Enil i (refines_right k (fill K' e'))) Δ = Some Δ' → (envs_entails Δ' Q) → (envs_entails Δ Q). Proof. intros. by eapply tac_tp_bind_gen. Qed. @@ -64,7 +64,7 @@ Tactic Notation "tp_bind" constr(j) open_constr(efoc) := |reflexivity |(* new goal *)]. -Lemma tac_tp_pure `{relocG Σ} e K' e1 j e2 Δ1 E1 i1 i2 p e' Ï• ψ Q n : +Lemma tac_tp_pure `{relocG Σ} e K' e1 k e2 Δ1 E1 i1 e' Ï• ψ Q n : (* we have those premises first, because we will be trying to solve them with backtracking using reashape_expr; see the accompanying Ltac. the first premise decomposes the expression, the second one checks @@ -73,32 +73,23 @@ Lemma tac_tp_pure `{relocG Σ} e K' e1 j e2 Δ1 E1 i1 i2 p e' Ï• ψ Q n : PureExec Ï• n e1 e2 → (∀ P, ElimModal ψ false false (|={E1}=> P) P Q Q) → nclose specN ⊆ E1 → - envs_lookup i1 Δ1 = Some (p, spec_ctx) → - envs_lookup i2 Δ1 = Some (false, j ⤇ e)%I → + envs_lookup i1 Δ1 = Some (false, refines_right k e)%I → ψ → Ï• → (* we will call simpl on this goal thus re-composing the expression again *) e' = fill K' e2 → - match envs_simple_replace i2 false (Esnoc Enil i2 (j ⤇ e')) Δ1 with + match envs_simple_replace i1 false (Esnoc Enil i1 (refines_right k e')) Δ1 with | Some Δ2 => envs_entails Δ2 Q | None => False end → envs_entails Δ1 Q. Proof. - rewrite envs_entails_eq. intros -> Hpure ?? HΔ1 ? Hψ HÏ• -> ?. - rewrite -(idemp bi_and (of_envs Δ1)). - rewrite {1}(envs_lookup_sound' Δ1 false). 2: apply HΔ1. - rewrite bi.sep_elim_l. - enough (<pers> spec_ctx ∧ of_envs Δ1 -∗ Q) as <-. - { rewrite -bi.intuitionistically_into_persistently_1. - destruct p; simpl; - by rewrite ?(bi.intuitionistic_intuitionistically spec_ctx). } - rewrite bi.persistently_and_intuitionistically_sep_l. - rewrite bi.intuitionistic_intuitionistically. + rewrite envs_entails_eq. intros -> Hpure ?? HΔ1 Hψ HÏ• -> ?. destruct (envs_simple_replace _ _ _ _) as [Δ2|] eqn:HΔ2; try done. - rewrite (envs_simple_replace_sound Δ1 Δ2 i2) //; simpl. + rewrite (envs_simple_replace_sound Δ1 Δ2 i1) //; simpl. rewrite right_id. - rewrite (assoc _ spec_ctx (j ⤇ _)%I). + rewrite /refines_right. + rewrite -!fill_app. rewrite step_pure //. rewrite -[Q]elim_modal // /=. apply bi.sep_mono_r. @@ -106,40 +97,28 @@ Proof. by rewrite bi.wand_elim_r. Qed. -(* helper tactic allowing us to use tp_ tactics whenever our goal is a refinement *) -Ltac with_spec_ctx tac := - lazymatch goal with - | |- envs_entails _ (refines ?E ?e1 ?e2 ?A) => - let H := iFresh in - iApply (refines_spec_ctx E e1 e2 A); - iIntros H; - (tac (); iClear H) - | _ => tac () - end. - Tactic Notation "tp_pure" constr(j) open_constr(ef) := iStartProof; - with_spec_ctx ltac:(fun _ => - lazymatch goal with - | |- context[environments.Esnoc _ ?H (j ⤇ fill ?K' ?e)] => - reshape_expr e ltac:(fun K e' => - unify e' ef; - eapply (tac_tp_pure (fill K' e) (K++K') e' j); - [by rewrite ?fill_app | iSolveTC | ..]) - | |- context[environments.Esnoc _ ?H (j ⤇ ?e)] => - reshape_expr e ltac:(fun K e' => - unify e' ef; - eapply (tac_tp_pure e K e' j); - [by rewrite ?fill_app | iSolveTC | ..]) - end; - [iSolveTC || fail "tp_pure: cannot eliminate modality in the goal" - |solve_ndisj || fail "tp_pure: cannot prove 'nclose specN ⊆ ?'" - |iAssumptionCore || fail "tp_pure: cannot find spec_ctx" (* spec_ctx *) - |iAssumptionCore || fail "tp_pure: cannot find '" j " ⤇ ?'" - |try (exact I || reflexivity) (* ψ *) - |try (exact I || reflexivity) (* Ï• *) - |simpl; reflexivity || fail "tp_pure: this should not happen" (* e' = fill K' e2 *) - |pm_reduce (* new goal *)]). + lazymatch goal with + | |- context[environments.Esnoc _ ?H (refines_right j (fill ?K' ?e))] => + reshape_expr e ltac:(fun K e' => + unify e' ef; + eapply (tac_tp_pure (fill K' e) (K++K') e' j); + [by rewrite ?fill_app | iSolveTC | ..]) + | |- context[environments.Esnoc _ ?H (refines_right j ?e)] => + reshape_expr e ltac:(fun K e' => + unify e' ef; + eapply (tac_tp_pure e K e' j); + [by rewrite ?fill_app | iSolveTC | ..]) + end; + [iSolveTC || fail "tp_pure: cannot eliminate modality in the goal" + |solve_ndisj || fail "tp_pure: cannot prove 'nclose specN ⊆ ?'" + (* |iAssumptionCore || fail "tp_pure: cannot find spec_ctx" (* spec_ctx *) *) + |iAssumptionCore || fail "tp_pure: cannot find the RHS" (* TODO fix error message *) + |try (exact I || reflexivity) (* ψ *) + |try (exact I || reflexivity) (* Ï• *) + |simpl; reflexivity || fail "tp_pure: this should not happen" (* e' = fill K' e2 *) + |pm_reduce (* new goal *)]. Tactic Notation "tp_pures" constr (j) := repeat (tp_pure j _). @@ -165,174 +144,145 @@ Tactic Notation "tp_if" constr(j) := tp_pure j (If _ _ _). Tactic Notation "tp_pair" constr(j) := tp_pure j (Pair _ _). Tactic Notation "tp_closure" constr(j) := tp_pure j (Rec _ _ _). -Lemma tac_tp_store `{relocG Σ} j Δ1 Δ2 E1 i1 i2 i3 p K' e (l : loc) e' e2 v' v Q : +Lemma tac_tp_store `{relocG Σ} k Δ1 Δ2 E1 i1 i2 K' e (l : loc) e' e2 v' v Q : (* TODO: here instead of True we can consider another Coq premise, like in tp_pure. Same goes for the rest of those tactics *) (∀ P, ElimModal True false false (|={E1}=> P) P Q Q) → nclose specN ⊆ E1 → - envs_lookup i1 Δ1 = Some (p, spec_ctx) → - envs_lookup_delete false i2 Δ1 = Some (false, j ⤇ e, Δ2)%I → + envs_lookup_delete false i1 Δ1 = Some (false, refines_right k e, Δ2)%I → e = fill K' (Store (# l) e') → IntoVal e' v → (* re-compose the expression and the evaluation context *) e2 = fill K' #() → - envs_lookup i3 Δ2 = Some (false, l ↦ₛ v')%I → - match envs_simple_replace i3 false - (Esnoc (Esnoc Enil i2 (j ⤇ e2)) i3 (l ↦ₛ v)) Δ2 with + envs_lookup i2 Δ2 = Some (false, l ↦ₛ v')%I → + match envs_simple_replace i2 false + (Esnoc (Esnoc Enil i1 (refines_right k e2)) i2 (l ↦ₛ v)) Δ2 with | None => False | Some Δ3 => envs_entails Δ3 Q end → envs_entails Δ1 Q. Proof. - rewrite envs_entails_eq. intros ???? -> <- -> ? HQ. - rewrite -(idemp bi_and (of_envs Δ1)). - rewrite {1}(envs_lookup_sound' _ false). 2: eassumption. - rewrite bi.sep_elim_l. - enough (spec_ctx ∗ of_envs Δ1 -∗ Q) as Hq. - { rewrite -Hq. - destruct p; simpl; last rewrite -(bi.intuitionistic_intuitionistically spec_ctx); - rewrite {1}bi.intuitionistically_into_persistently_1 bi.persistently_and_intuitionistically_sep_l; - by rewrite (bi.intuitionistic_intuitionistically spec_ctx). } + rewrite /IntoVal. + rewrite envs_entails_eq. intros ??? -> <- -> ? HQ. rewrite envs_lookup_delete_sound //; simpl. destruct (envs_simple_replace _ _ _ _) as [Δ3|] eqn:HΔ3; last done. rewrite envs_simple_replace_sound //; simpl. rewrite right_id. rewrite !assoc -(assoc _ spec_ctx). - rewrite step_store //. + rewrite -fill_app step_store // fill_app. rewrite -[Q]elim_modal //. apply bi.sep_mono_r. apply bi.wand_intro_l. - rewrite (comm _ _ (l ↦ₛ v)%I). + rewrite (comm _ _ (l ↦ₛ v)%I). simpl. + rewrite assoc. rewrite (comm _ spec_ctx (l ↦ₛ _)%I). by rewrite bi.wand_elim_r. Qed. Tactic Notation "tp_store" constr(j) := iStartProof; - with_spec_ctx ltac:(fun _ => - eapply (tac_tp_store j); - [iSolveTC || fail "tp_store: cannot eliminate modality in the goal" - |solve_ndisj || fail "tp_store: cannot prove 'nclose specN ⊆ ?'" - |iAssumptionCore || fail "tp_store: cannot find spec_ctx" (* spec_ctx *) - |iAssumptionCore || fail "tp_store: cannot find '" j " ⤇ ?'" - |tp_bind_helper - |iSolveTC || fail "tp_store: cannot convert the argument to a value" - |simpl; reflexivity || fail "tp_store: this should not happen" - |iAssumptionCore || fail "tp_store: cannot find '? ↦ₛ ?'" - |pm_reduce (* new goal *)]). - -(* -DF: -If [envs_lookup i1 Δ1 = Some (p, spec_ctx Ï)] and - [envs_lookup i2 Δ1 = Some (false, j ⤇ fill K e)], -how can we prove that [i1 <> i2]? If we can do that then we can utilize -the lemma [envs_lookup_envs_delete_ne]. -*) - -Lemma tac_tp_load `{relocG Σ} j Δ1 Δ2 E1 i1 i2 i3 p K' e e2 (l : loc) v Q q : + eapply (tac_tp_store j); + [iSolveTC || fail "tp_store: cannot eliminate modality in the goal" + |solve_ndisj || fail "tp_store: cannot prove 'nclose specN ⊆ ?'" + |iAssumptionCore || fail "tp_store: cannot find '" j " ' RHS" + |tp_bind_helper + |iSolveTC || fail "tp_store: cannot convert the argument to a value" + |simpl; reflexivity || fail "tp_store: this should not happen" + |iAssumptionCore || fail "tp_store: cannot find '? ↦ₛ ?'" + |pm_reduce (* new goal *)]. + +(* *) +(* DF: *) +(* If [envs_lookup i1 Δ1 = Some (p, spec_ctx Ï)] and *) +(* [envs_lookup i2 Δ1 = Some (false, j ⤇ fill K e)], *) +(* how can we prove that [i1 <> i2]? If we can do that then we can utilize *) +(* the lemma [envs_lookup_envs_delete_ne]. *) +(* *) + +Lemma tac_tp_load `{relocG Σ} k Δ1 Δ2 E1 i1 i2 K' e e2 (l : loc) v Q q : (∀ P, ElimModal True false false (|={E1}=> P) P Q Q) → nclose specN ⊆ E1 → - envs_lookup i1 Δ1 = Some (p, spec_ctx) → - envs_lookup_delete false i2 Δ1 = Some (false, j ⤇ e, Δ2)%I → + envs_lookup_delete false i1 Δ1 = Some (false, refines_right k e, Δ2)%I → e = fill K' (Load #l) → - envs_lookup i3 Δ2 = Some (false, l ↦ₛ{q} v)%I → + envs_lookup i2 Δ2 = Some (false, l ↦ₛ{q} v)%I → e2 = fill K' (of_val v) → - match envs_simple_replace i3 false - (Esnoc (Esnoc Enil i2 (j ⤇ e2)) i3 (l ↦ₛ{q} v)%I) Δ2 with + match envs_simple_replace i2 false + (Esnoc (Esnoc Enil i1 (refines_right k e2)) i2 (l ↦ₛ{q} v)%I) Δ2 with | Some Δ3 => envs_entails Δ3 Q | None => False end → envs_entails Δ1 Q. Proof. - rewrite envs_entails_eq. intros ???? -> ? -> HQ. - rewrite -(idemp bi_and (of_envs Δ1)). - rewrite {1}(envs_lookup_sound' Δ1 false); last by eassumption. - rewrite bi.sep_elim_l. - enough (spec_ctx ∗ of_envs Δ1 -∗ Q) as Hq. - { rewrite -Hq. - destruct p; simpl; last rewrite -(bi.intuitionistic_intuitionistically spec_ctx); - rewrite {1}bi.intuitionistically_into_persistently_1 bi.persistently_and_intuitionistically_sep_l; - by rewrite (bi.intuitionistic_intuitionistically spec_ctx). } + rewrite envs_entails_eq. intros ??? -> ? -> HQ. rewrite envs_lookup_delete_sound //; simpl. destruct (envs_simple_replace _ _ _ _) as [Δ3|] eqn:HΔ3; last done. - rewrite (envs_simple_replace_sound Δ2 Δ3 i3) //; simpl. + rewrite (envs_simple_replace_sound Δ2 Δ3 i2) //; simpl. + rewrite /refines_right. rewrite right_id. - rewrite (assoc _ spec_ctx (j ⤇ fill K' (Load _))%I). - rewrite assoc. - rewrite -(assoc _ spec_ctx (j ⤇ fill K' (Load _))%I). - rewrite step_load //. + rewrite assoc. rewrite -(assoc _ spec_ctx). + rewrite -fill_app step_load /= // fill_app. rewrite -[Q]elim_modal //. apply bi.sep_mono_r. apply bi.wand_intro_l. rewrite (comm _ _ (l ↦ₛ{q} v)%I). + rewrite assoc. + rewrite (comm _ _ (l ↦ₛ{q} v)%I). + rewrite -assoc. rewrite HQ. by apply bi.wand_elim_r. Qed. Tactic Notation "tp_load" constr(j) := iStartProof; - with_spec_ctx ltac:(fun _ => - eapply (tac_tp_load j); - [iSolveTC || fail "tp_load: cannot eliminate modality in the goal" - |solve_ndisj || fail "tp_load: cannot prove 'nclose specN ⊆ ?'" - |iAssumptionCore || fail "tp_load: cannot find spec_ctx" (* spec_ctx *) - |iAssumptionCore || fail "tp_load: cannot find '" j " ⤇ ?'" - |tp_bind_helper - |iAssumptionCore || fail "tp_load: cannot find '? ↦ₛ ?'" - |simpl; reflexivity || fail "tp_load: this should not happen" - |pm_reduce (* new goal *)]). - -Lemma tac_tp_cmpxchg_fail `{relocG Σ} j Δ1 Δ2 E1 i1 i2 i3 p K' e enew (l : loc) e1 e2 v' v1 v2 Q q : + eapply (tac_tp_load j); + [iSolveTC || fail "tp_load: cannot eliminate modality in the goal" + |solve_ndisj || fail "tp_load: cannot prove 'nclose specN ⊆ ?'" + |iAssumptionCore || fail "tp_load: cannot find the RHS '" j "'" + |tp_bind_helper + |iAssumptionCore || fail "tp_load: cannot find '? ↦ₛ ?'" + |simpl; reflexivity || fail "tp_load: this should not happen" + |pm_reduce (* new goal *)]. + +Lemma tac_tp_cmpxchg_fail `{relocG Σ} k Δ1 Δ2 E1 i1 i2 K' e enew (l : loc) e1 e2 v' v1 v2 Q q : (∀ P, ElimModal True false false (|={E1}=> P) P Q Q) → nclose specN ⊆ E1 → - envs_lookup i1 Δ1 = Some (p, spec_ctx) → - envs_lookup_delete false i2 Δ1 = Some (false, j ⤇ e, Δ2)%I → + envs_lookup_delete false i1 Δ1 = Some (false, refines_right k e, Δ2)%I → e = fill K' (CmpXchg #l e1 e2) → IntoVal e1 v1 → IntoVal e2 v2 → - envs_lookup i3 Δ2 = Some (false, l ↦ₛ{q} v')%I → + envs_lookup i2 Δ2 = Some (false, l ↦ₛ{q} v')%I → v' ≠v1 → vals_compare_safe v' v1 → enew = fill K' (v', #false)%V → - match envs_simple_replace i3 false - (Esnoc (Esnoc Enil i2 (j ⤇ enew)) i3 (l ↦ₛ{q} v')%I) Δ2 with + match envs_simple_replace i2 false + (Esnoc (Esnoc Enil i1 (refines_right k enew)) i2 (l ↦ₛ{q} v')%I) Δ2 with | Some Δ3 => envs_entails Δ3 Q | None => False end → envs_entails Δ1 Q. Proof. - rewrite envs_entails_eq. intros ???? -> Hv1 Hv2 ??? -> HQ. - rewrite -(idemp bi_and (of_envs Δ1)). - rewrite {1}(envs_lookup_sound' Δ1 false); last by eassumption. - rewrite bi.sep_elim_l. - enough (spec_ctx ∗ of_envs Δ1 -∗ Q) as Hq. - { rewrite -Hq. - destruct p; simpl; last rewrite -(bi.intuitionistic_intuitionistically spec_ctx); - rewrite {1}bi.intuitionistically_into_persistently_1 bi.persistently_and_intuitionistically_sep_l; - by rewrite (bi.intuitionistic_intuitionistically spec_ctx). } + rewrite envs_entails_eq. intros ??? -> Hv1 Hv2 ??? -> HQ. rewrite envs_lookup_delete_sound //; simpl. destruct (envs_simple_replace _ _ _ _) as [Δ3|] eqn:HΔ3; last done. - rewrite (envs_simple_replace_sound Δ2 Δ3 i3) //; simpl. + rewrite (envs_simple_replace_sound Δ2 Δ3 i2) //; simpl. rewrite right_id. - (* (S spec_ctx (S (j => fill _ _) (S (l ↦ v) ..))) *) - rewrite (assoc _ spec_ctx (j ⤇ fill K' _)%I). - (* (S (S spec_ctx (j => fill _ _)) (S (l ↦ v) ..)) *) - rewrite assoc. - rewrite -(assoc _ spec_ctx (j ⤇ fill K' _)%I). - rewrite step_cmpxchg_fail //. + rewrite /refines_right. rewrite -fill_app. + rewrite assoc. rewrite -(assoc _ spec_ctx). + rewrite step_cmpxchg_fail //. rewrite fill_app. rewrite -[Q]elim_modal //. apply bi.sep_mono_r. apply bi.wand_intro_l. rewrite (comm _ _ (l ↦ₛ{q} _)%I). + rewrite assoc. + rewrite (comm _ _ (l ↦ₛ{q} _)%I). + rewrite -assoc. rewrite HQ. by apply bi.wand_elim_r. Qed. Tactic Notation "tp_cmpxchg_fail" constr(j) := iStartProof; - with_spec_ctx ltac:(fun _ => eapply (tac_tp_cmpxchg_fail j); [iSolveTC || fail "tp_cmpxchg_fail: cannot eliminate modality in the goal" |solve_ndisj || fail "tp_cmpxchg_fail: cannot prove 'nclose specN ⊆ ?'" - |iAssumptionCore || fail "tp_cmpxchg_fail: cannot find spec_ctx" (* spec_ctx *) - |iAssumptionCore || fail "tp_cmpxchg_fail: cannot find '" j " ⤇ ?'" + |iAssumptionCore || fail "tp_cmpxchg_fail: cannot find the RHS '" j "'" |tp_bind_helper (* e = K'[CmpXchg _ _ _] *) |iSolveTC || fail "tp_cmpxchg_fail: argument is not a value" |iSolveTC || fail "tp_cmpxchg_fail: argument is not a value" @@ -340,234 +290,191 @@ Tactic Notation "tp_cmpxchg_fail" constr(j) := |try (simpl; congruence) (* v' ≠v1 *) |try heap_lang.proofmode.solve_vals_compare_safe |simpl; reflexivity || fail "tp_cmpxchg_fail: this should not happen" - |pm_reduce (* new goal *)]). + |pm_reduce (* new goal *)]. -Lemma tac_tp_cmpxchg_suc `{relocG Σ} j Δ1 Δ2 E1 i1 i2 i3 p K' e enew (l : loc) e1 e2 v' v1 v2 Q : +Lemma tac_tp_cmpxchg_suc `{relocG Σ} k Δ1 Δ2 E1 i1 i2 K' e enew (l : loc) e1 e2 v' v1 v2 Q : (∀ P, ElimModal True false false (|={E1}=> P) P Q Q) → nclose specN ⊆ E1 → - envs_lookup i1 Δ1 = Some (p, spec_ctx) → - envs_lookup_delete false i2 Δ1 = Some (false, j ⤇ e, Δ2)%I → + envs_lookup_delete false i1 Δ1 = Some (false, refines_right k e, Δ2)%I → e = fill K' (CmpXchg #l e1 e2) → IntoVal e1 v1 → IntoVal e2 v2 → - envs_lookup i3 Δ2 = Some (false, l ↦ₛ v')%I → + envs_lookup i2 Δ2 = Some (false, l ↦ₛ v')%I → v' = v1 → vals_compare_safe v' v1 → enew = fill K' (v', #true)%V → - match envs_simple_replace i3 false - (Esnoc (Esnoc Enil i2 (j ⤇ enew)) i3 (l ↦ₛ v2)%I) Δ2 with + match envs_simple_replace i2 false + (Esnoc (Esnoc Enil i1 (refines_right k enew)) i2 (l ↦ₛ v2)%I) Δ2 with | Some Δ3 => envs_entails Δ3 Q | None => False end → envs_entails Δ1 Q. Proof. - rewrite envs_entails_eq. intros ???? -> Hv1 Hv2 ??? -> HQ. - rewrite -(idemp bi_and (of_envs Δ1)). - rewrite {1}(envs_lookup_sound' Δ1 false); last by eassumption. - rewrite bi.sep_elim_l. - enough (spec_ctx ∗ of_envs Δ1 -∗ Q) as Hq. - { rewrite -Hq. - destruct p; simpl; last rewrite -(bi.intuitionistic_intuitionistically spec_ctx); - rewrite {1}bi.intuitionistically_into_persistently_1 bi.persistently_and_intuitionistically_sep_l; - by rewrite (bi.intuitionistic_intuitionistically spec_ctx). } + rewrite envs_entails_eq. intros ??? -> Hv1 Hv2 ??? -> HQ. rewrite envs_lookup_delete_sound //; simpl. destruct (envs_simple_replace _ _ _ _) as [Δ3|] eqn:HΔ3; last done. - rewrite (envs_simple_replace_sound Δ2 Δ3 i3) //; simpl. + rewrite (envs_simple_replace_sound Δ2 Δ3 i2) //; simpl. rewrite right_id. - (* (S spec_ctx (S (j => fill _ _) (S (l ↦ v) ..))) *) - rewrite (assoc _ spec_ctx (j ⤇ fill K' _)%I). - (* (S (S spec_ctx (j => fill _ _)) (S (l ↦ v) ..)) *) - rewrite assoc. - rewrite -(assoc _ spec_ctx (j ⤇ fill K' _)%I). - rewrite step_cmpxchg_suc //. + rewrite /refines_right. rewrite -fill_app. + rewrite assoc. rewrite -(assoc _ spec_ctx). + rewrite step_cmpxchg_suc //. rewrite fill_app. rewrite -[Q]elim_modal //. apply bi.sep_mono_r. apply bi.wand_intro_l. - rewrite (comm _ _ (l ↦ₛ _)%I). + rewrite (comm _ _ (l ↦ₛ _)%I) assoc. + rewrite (comm _ _ (l ↦ₛ _)%I) -assoc. rewrite HQ. by apply bi.wand_elim_r. Qed. Tactic Notation "tp_cmpxchg_suc" constr(j) := iStartProof; - with_spec_ctx ltac:(fun _ => - eapply (tac_tp_cmpxchg_suc j); - [iSolveTC || fail "tp_cmpxchg_suc: cannot eliminate modality in the goal" - |solve_ndisj || fail "tp_cmpxchg_suc: cannot prove 'nclose specN ⊆ ?'" - |iAssumptionCore || fail "tp_cmpxchg_suc: cannot find spec_ctx" (* spec_ctx *) - |iAssumptionCore || fail "tp_cmpxchg_suc: cannot find '" j " ⤇ ?'" - |tp_bind_helper (* e = K'[CmpXchg _ _ _] *) - |iSolveTC || fail "tp_cmpxchg_suc: argument is not a value" - |iSolveTC || fail "tp_cmpxchg_suc: argument is not a value" - |iAssumptionCore || fail "tp_cmpxchg_suc: cannot find '? ↦ ?'" - |try (simpl; congruence) (* v' = v1 *) - |try heap_lang.proofmode.solve_vals_compare_safe - |simpl; reflexivity || fail "tp_cmpxchg_suc: this should not happen" - |pm_reduce (* new goal *)]). - -Lemma tac_tp_faa `{relocG Σ} j Δ1 Δ2 E1 i1 i2 i3 p K' e enew (l : loc) e2 (z1 z2 : Z) Q : + eapply (tac_tp_cmpxchg_suc j); + [iSolveTC || fail "tp_cmpxchg_suc: cannot eliminate modality in the goal" + |solve_ndisj || fail "tp_cmpxchg_suc: cannot prove 'nclose specN ⊆ ?'" + |iAssumptionCore || fail "tp_cmpxchg_suc: cannot the RHS '" j "'" + |tp_bind_helper (* e = K'[CmpXchg _ _ _] *) + |iSolveTC || fail "tp_cmpxchg_suc: argument is not a value" + |iSolveTC || fail "tp_cmpxchg_suc: argument is not a value" + |iAssumptionCore || fail "tp_cmpxchg_suc: cannot find '? ↦ ?'" + |try (simpl; congruence) (* v' = v1 *) + |try heap_lang.proofmode.solve_vals_compare_safe + |simpl; reflexivity || fail "tp_cmpxchg_suc: this should not happen" + |pm_reduce (* new goal *)]. + +Lemma tac_tp_faa `{relocG Σ} k Δ1 Δ2 E1 i1 i2 K' e enew (l : loc) e2 (z1 z2 : Z) Q : (∀ P, ElimModal True false false (|={E1}=> P) P Q Q) → nclose specN ⊆ E1 → - envs_lookup i1 Δ1 = Some (p, spec_ctx) → - envs_lookup_delete false i2 Δ1 = Some (false, j ⤇ e, Δ2)%I → + envs_lookup_delete false i1 Δ1 = Some (false, refines_right k e, Δ2)%I → e = fill K' (FAA #l e2) → IntoVal e2 #z2 → - envs_lookup i3 Δ2 = Some (false, l ↦ₛ #z1)%I → + envs_lookup i2 Δ2 = Some (false, l ↦ₛ #z1)%I → enew = fill K' #z1 → - match envs_simple_replace i3 false - (Esnoc (Esnoc Enil i2 (j ⤇ enew)) i3 (l ↦ₛ #(z1+z2))%I) Δ2 with + match envs_simple_replace i2 false + (Esnoc (Esnoc Enil i1 (refines_right k enew)) i2 (l ↦ₛ #(z1+z2))%I) Δ2 with | Some Δ3 => envs_entails Δ3 Q | None => False end → envs_entails Δ1 Q. Proof. - rewrite envs_entails_eq. intros ???? -> ?? -> HQ. - rewrite -(idemp bi_and (of_envs Δ1)). - rewrite {1}(envs_lookup_sound' Δ1 false); last by eassumption. - rewrite bi.sep_elim_l. - enough (spec_ctx ∗ of_envs Δ1 -∗ Q) as Hq. - { rewrite -Hq. - destruct p; simpl; last rewrite -(bi.intuitionistic_intuitionistically spec_ctx); - rewrite {1}bi.intuitionistically_into_persistently_1 bi.persistently_and_intuitionistically_sep_l; - by rewrite (bi.intuitionistic_intuitionistically spec_ctx). } + rewrite envs_entails_eq. intros ??? -> ?? -> HQ. rewrite envs_lookup_delete_sound //; simpl. destruct (envs_simple_replace _ _ _ _) as [Δ3|] eqn:HΔ3; last done. - rewrite (envs_simple_replace_sound Δ2 Δ3 i3) //; simpl. + rewrite (envs_simple_replace_sound Δ2 Δ3 i2) //; simpl. rewrite right_id. - (* (S spec_ctx (S (j => fill _ _) (S (l ↦ v) ..))) *) - rewrite (assoc _ spec_ctx (j ⤇ fill K' _)%I). - (* (S (S spec_ctx (j => fill _ _)) (S (l ↦ v) ..)) *) - rewrite assoc. - rewrite -(assoc _ spec_ctx (j ⤇ fill K' _)%I). - rewrite step_faa //. + rewrite /refines_right. rewrite -fill_app. + rewrite assoc. rewrite -(assoc _ spec_ctx). + rewrite step_faa //. rewrite fill_app. rewrite -[Q]elim_modal //. apply bi.sep_mono_r. apply bi.wand_intro_l. - rewrite (comm _ _ (l ↦ₛ _)%I). + rewrite (comm _ _ (l ↦ₛ _)%I) assoc. + rewrite (comm _ _ (l ↦ₛ _)%I) -assoc. rewrite HQ. by apply bi.wand_elim_r. Qed. Tactic Notation "tp_faa" constr(j) := iStartProof; - with_spec_ctx ltac:(fun _ => - eapply (tac_tp_faa j); - [iSolveTC || fail "tp_faa: cannot eliminate modality in the goal" - |solve_ndisj || fail "tp_faa: cannot prove 'nclose specN ⊆ ?'" - |iAssumptionCore || fail "tp_faa: cannot find spec_ctx" (* spec_ctx *) - |iAssumptionCore || fail "tp_faa: cannot find '" j " ⤇ ?'" - |tp_bind_helper (* e = K'[FAA _ _ _] *) - |iSolveTC (* IntoVal *) - |iAssumptionCore || fail "tp_faa: cannot find '? ↦ ?'" - |simpl;reflexivity || fail "tp_faa: this should not happen" - |pm_reduce (* new goal *)]). - - -Lemma tac_tp_fork `{relocG Σ} j Δ1 E1 i1 i2 p K' e enew e' Q : + eapply (tac_tp_faa j); + [iSolveTC || fail "tp_faa: cannot eliminate modality in the goal" + |solve_ndisj || fail "tp_faa: cannot prove 'nclose specN ⊆ ?'" + |iAssumptionCore || fail "tp_faa: cannot find the RHS '" j "'" + |tp_bind_helper (* e = K'[FAA _ _ _] *) + |iSolveTC (* IntoVal *) + |iAssumptionCore || fail "tp_faa: cannot find '? ↦ ?'" + |simpl;reflexivity || fail "tp_faa: this should not happen" + |pm_reduce (* new goal *)]. + + +Lemma tac_tp_fork `{relocG Σ} k Δ1 E1 i1 K' e enew e' Q : (∀ P, ElimModal True false false (|={E1}=> P) P Q Q) → nclose specN ⊆ E1 → - envs_lookup i1 Δ1 = Some (p, spec_ctx) → - envs_lookup i2 Δ1 = Some (false, j ⤇ e)%I → + envs_lookup i1 Δ1 = Some (false, refines_right k e)%I → e = fill K' (Fork e') → enew = fill K' #() → - match envs_simple_replace i2 false - (Esnoc Enil i2 (j ⤇ fill K' #())) Δ1 with - | Some Δ2 => envs_entails Δ2 (∀ (j' : nat), j' ⤇ e' -∗ Q)%I + match envs_simple_replace i1 false + (Esnoc Enil i1 (refines_right k (fill K' #()))) Δ1 with + | Some Δ2 => envs_entails Δ2 (∀ k', refines_right k' e' -∗ Q)%I | None => False end → envs_entails Δ1 Q. Proof. - rewrite envs_entails_eq. intros ????->-> HQ. - rewrite -(idemp bi_and (of_envs Δ1)). - rewrite {1}(envs_lookup_sound' Δ1 false i1); last by eassumption. - rewrite bi.sep_elim_l /=. - enough (spec_ctx ∗ of_envs Δ1 -∗ Q) as Hq. - { rewrite -Hq. - destruct p; simpl; last rewrite -(bi.intuitionistic_intuitionistically spec_ctx); - rewrite {1}bi.intuitionistically_into_persistently_1 bi.persistently_and_intuitionistically_sep_l; - by rewrite (bi.intuitionistic_intuitionistically spec_ctx). } + rewrite envs_entails_eq. intros ???->-> HQ. destruct (envs_simple_replace _ _ _ _) as [Δ2|] eqn:HΔ2; last done. - rewrite (envs_simple_replace_sound Δ1 Δ2 i2) //; simpl. + rewrite (envs_simple_replace_sound Δ1 Δ2 i1) //; simpl. rewrite right_id. - rewrite (assoc _ spec_ctx (j ⤇ _)%I). - rewrite step_fork //. + rewrite /refines_right. rewrite -fill_app. + rewrite step_fork //. rewrite fill_app. rewrite -[Q]elim_modal //. apply bi.sep_mono_r. apply bi.wand_intro_l. rewrite bi.sep_exist_r. apply bi.exist_elim. intros j'. - rewrite (comm _ (j ⤇ _)%I (j' ⤇ _)%I). + (* rewrite (comm _ (j ⤇ _)%I (j' ⤇ _)%I). *) + rewrite (comm _ _ (spec_ctx ∗ j' ⤇ e')%I). rewrite -assoc. rewrite bi.wand_elim_r. - rewrite HQ. - rewrite (bi.forall_elim j'). + rewrite HQ. rewrite /refines_right. + rewrite (bi.forall_elim (RefId j' [])) /=. by rewrite bi.wand_elim_r. Qed. Tactic Notation "tp_fork" constr(j) := iStartProof; - with_spec_ctx ltac:(fun _ => - eapply (tac_tp_fork j); - [iSolveTC || fail "tp_fork: cannot eliminate modality in the goal" - |solve_ndisj || fail "tp_fork: cannot prove 'nclose specN ⊆ ?'" - |iAssumptionCore || fail "tp_fork: cannot find spec_ctx" (* spec_ctx *) - |iAssumptionCore || fail "tp_fork: cannot find '" j " ⤇ ?'" - |tp_bind_helper - |simpl; reflexivity || fail "tp_fork: this should not happen" - |pm_reduce (* new goal *)]). + eapply (tac_tp_fork j); + [iSolveTC || fail "tp_fork: cannot eliminate modality in the goal" + |solve_ndisj || fail "tp_fork: cannot prove 'nclose specN ⊆ ?'" + |iAssumptionCore || fail "tp_fork: cannot find the RHS '" j "'" + |tp_bind_helper + |simpl; reflexivity || fail "tp_fork: this should not happen" + |pm_reduce (* new goal *)]. Tactic Notation "tp_fork" constr(j) "as" ident(j') constr(H) := iStartProof; - with_spec_ctx ltac:(fun _ => - eapply (tac_tp_fork j); - [iSolveTC || fail "tp_fork: cannot eliminate modality in the goal" - |solve_ndisj || fail "tp_fork: cannot prove 'nclose specN ⊆ ?'" - |iAssumptionCore || fail "tp_fork: cannot find spec_ctx" (* spec_ctx *) - |iAssumptionCore || fail "tp_fork: cannot find '" j " ⤇ ?'" - |tp_bind_helper - |simpl; reflexivity || fail "tp_fork: this should not happen" - |pm_reduce; - (iIntros (j') || fail 1 "tp_fork: " j' " not fresh "); - (iIntros H || fail 1 "tp_fork: " H " not fresh") -(* new goal *)]). + eapply (tac_tp_fork j); + [iSolveTC || fail "tp_fork: cannot eliminate modality in the goal" + |solve_ndisj || fail "tp_fork: cannot prove 'nclose specN ⊆ ?'" + |iAssumptionCore || fail "tp_fork: cannot find the RHS '" j "'" + |tp_bind_helper + |simpl; reflexivity || fail "tp_fork: this should not happen" + |pm_reduce; + (iIntros (j') || fail 1 "tp_fork: " j' " not fresh "); + (iIntros H || fail 1 "tp_fork: " H " not fresh") +(* new goal *)]. Tactic Notation "tp_fork" constr(j) "as" ident(j') := let H := iFresh in tp_fork j as j' H. -Lemma tac_tp_alloc `{relocG Σ} j Δ1 E1 i1 i2 p K' e e' v Q : +Lemma tac_tp_alloc `{relocG Σ} k Δ1 E1 i1 K' e e' v Q : (∀ P, ElimModal True false false (|={E1}=> P) P Q Q) → nclose specN ⊆ E1 → - envs_lookup i1 Δ1 = Some (p, spec_ctx) → - envs_lookup i2 Δ1 = Some (false, j ⤇ e)%I → + envs_lookup i1 Δ1 = Some (false, refines_right k e)%I → e = fill K' (ref e') → IntoVal e' v → (* TODO use match here as well *) (∀ l : loc, ∃ Δ2, - envs_simple_replace i2 false - (Esnoc Enil i2 (j ⤇ fill K' #l)) Δ1 = Some Δ2 ∧ + envs_simple_replace i1 false + (Esnoc Enil i1 (refines_right k (fill K' #l))) Δ1 = Some Δ2 ∧ (envs_entails Δ2 ((l ↦ₛ v) -∗ Q)%I)) → envs_entails Δ1 Q. Proof. - rewrite envs_entails_eq. intros ? ??? Hfill <- HQ. - rewrite -(idemp bi_and (of_envs Δ1)). - rewrite {1}(envs_lookup_sound' Δ1 false i1); last by eassumption. - rewrite bi.sep_elim_l /=. - enough (spec_ctx ∗ of_envs Δ1 -∗ Q) as Hq. - { rewrite -Hq. - destruct p; simpl; last rewrite -(bi.intuitionistic_intuitionistically spec_ctx); - rewrite {1}bi.intuitionistically_into_persistently_1 bi.persistently_and_intuitionistically_sep_l; - by rewrite (bi.intuitionistic_intuitionistically spec_ctx). } - rewrite (envs_lookup_sound' Δ1 false i2); last by eassumption. - rewrite Hfill assoc /=. + rewrite envs_entails_eq. intros ??? Hfill <- HQ. + rewrite (envs_lookup_sound' Δ1 false i1); last by eassumption. + rewrite /refines_right. + rewrite Hfill -fill_app /=. rewrite step_alloc //. rewrite -[Q]elim_modal //. apply bi.sep_mono_r, bi.wand_intro_l. rewrite bi.sep_exist_r. apply bi.exist_elim=> l. destruct (HQ l) as (Δ2 & HΔ2 & HQ'). - rewrite (envs_simple_replace_sound' _ _ i2 _ _ HΔ2). - rewrite (comm _ (j ⤇ _)%I (l ↦ₛ _)%I). - rewrite -assoc /= right_id. + rewrite (envs_simple_replace_sound' _ _ i1 _ _ HΔ2) /=. + rewrite HQ' right_id. + rewrite /refines_right fill_app. + rewrite (comm _ _ (l ↦ₛ _)%I). + rewrite assoc. + rewrite (comm _ _ (l ↦ₛ _)%I). + rewrite -(assoc _ (l ↦ₛ _)%I spec_ctx _). rewrite -assoc. rewrite bi.wand_elim_r. - rewrite HQ'. by rewrite bi.wand_elim_r. Qed. @@ -578,97 +485,95 @@ Tactic Notation "tp_alloc" constr(j) "as" ident(l) constr(H) := [ reduction.pm_reflexivity | (iIntros H; tp_normalise j) || fail 1 "tp_alloc:" H "not correct intro pattern" ] in iStartProof; - with_spec_ctx ltac:(fun _ => - eapply (tac_tp_alloc j); - [iSolveTC || fail "tp_alloc: cannot eliminate modality in the goal" - |solve_ndisj || fail "tp_alloc: cannot prove 'nclose specN ⊆ ?'" - |iAssumptionCore || fail "tp_alloc: cannot find spec_ctx" (* spec_ctx *) - |iAssumptionCore || fail "tp_alloc: cannot find '" j " ⤇ ?'" - |tp_bind_helper - |iSolveTC || fail "tp_alloc: expressions is not a value" - |finish () -(* new goal *)]). + eapply (tac_tp_alloc j); + [iSolveTC || fail "tp_alloc: cannot eliminate modality in the goal" + |solve_ndisj || fail "tp_alloc: cannot prove 'nclose specN ⊆ ?'" + |iAssumptionCore || fail "tp_alloc: cannot find the RHS '" j "'" + |tp_bind_helper + |iSolveTC || fail "tp_alloc: expressions is not a value" + |finish () +(* new goal *)]. Tactic Notation "tp_alloc" constr(j) "as" ident(j') := let H := iFresh in tp_alloc j as j' H. -(* -(**************************) -(* tp_apply *) - -Fixpoint print_sel (ss : list sel_pat) (s : string) := - match ss with - | nil => s - | SelPure :: ss' => (String "%" (String " " (print_sel ss' s))) - | SelPersistent :: ss' => (String "#" (print_sel ss' s)) - | SelSpatial :: ss' => (* no clue :( *) (print_sel ss' s) - | SelIdent (INamed n) :: ss' => append n (String " " (print_sel ss' s)) - | SelIdent (IAnon _) :: ss' => String "?" (String " " (print_sel ss' s)) - (* wat to do with the index? *) - end. - -Ltac print_sel ss := - lazymatch type of ss with - | list sel_pat => eval vm_compute in (print_sel ss "") - | string => ss - end. - -Definition appP (ss : option (list sel_pat)) (Hj Hs : string) := - match ss with - | Some ss' => cons (SelIdent Hs) (app ss' [SelIdent Hj]) - | None => cons (SelIdent Hs) [SelIdent Hj] - end. - -Definition add_elim_pat (pat : string) (Hj : string) := - match pat with - | EmptyString => Hj - | _ => append (String "[" (append Hj (String " " pat))) "]" - end. - -Tactic Notation "tp_apply" constr(j) open_constr(lem) "with" constr(Hs) "as" constr(Hr) := - iStartProof; - let rec find Γ j := - match Γ with - | Esnoc ?Γ (IAnon _) ?P => - find Γ j - | Esnoc ?Γ (INamed ?Hj) ?P => - lazymatch P with - | (j ⤇ _)%I => Hj - | _ => find Γ j - end - | Enil => fail 2 "tp_apply: cannot find " j " ⤇ _ " - | _ => fail 2 "tp_apply: unknown error in find" - end in - let rec findSpec Γp Γs := - match Γp with - | Esnoc ?Γ (IAnon _) _ => findSpec Γ Γs - | Esnoc ?Γ (INamed ?Hspec) ?P => - lazymatch P with - | (spec_ctx _)%I => Hspec - | _ => findSpec Γ Γs - end - | Enil => - match Γs with - | Enil => fail 2 "tp_apply: cannot find spec_ctx _" - | _ => findSpec Γs Enil - end - | _ => fail 2 "tp_apply: unknown error in findSpec" - end in - match goal with - | |- envs_entails (Envs ?Γp ?Γs) ?Q => - let Hj := (find Γs j) in - let Hspec := findSpec Γp Γs in - let pat := eval vm_compute in (appP (sel_pat.parse Hs) Hj Hspec) in - let pats := print_sel pat in - let elim_pats := eval vm_compute in (add_elim_pat Hr Hj) in - iMod (lem with pats) as elim_pats; first try by solve_ndisj - | _ => fail "tp_apply: cannot parse the context" - end. - -Tactic Notation "tp_apply" constr(j) open_constr(lem) "with" constr(Hs) := tp_apply j lem with Hs as "". - -Tactic Notation "tp_apply" constr(j) open_constr(lem) "as" constr(Hr) := tp_apply j lem with "" as Hr. - -Tactic Notation "tp_apply" constr(j) open_constr(lem) := tp_apply j lem with "" as "". -*) +(* *) +(* (**************************) *) +(* (* tp_apply *) *) + +(* Fixpoint print_sel (ss : list sel_pat) (s : string) := *) +(* match ss with *) +(* | nil => s *) +(* | SelPure :: ss' => (String "%" (String " " (print_sel ss' s))) *) +(* | SelPersistent :: ss' => (String "#" (print_sel ss' s)) *) +(* | SelSpatial :: ss' => (* no clue :( *) (print_sel ss' s) *) +(* | SelIdent (INamed n) :: ss' => append n (String " " (print_sel ss' s)) *) +(* | SelIdent (IAnon _) :: ss' => String "?" (String " " (print_sel ss' s)) *) +(* (* wat to do with the index? *) *) +(* end. *) + +(* Ltac print_sel ss := *) +(* lazymatch type of ss with *) +(* | list sel_pat => eval vm_compute in (print_sel ss "") *) +(* | string => ss *) +(* end. *) + +(* Definition appP (ss : option (list sel_pat)) (Hj Hs : string) := *) +(* match ss with *) +(* | Some ss' => cons (SelIdent Hs) (app ss' [SelIdent Hj]) *) +(* | None => cons (SelIdent Hs) [SelIdent Hj] *) +(* end. *) + +(* Definition add_elim_pat (pat : string) (Hj : string) := *) +(* match pat with *) +(* | EmptyString => Hj *) +(* | _ => append (String "[" (append Hj (String " " pat))) "]" *) +(* end. *) + +(* Tactic Notation "tp_apply" constr(j) open_constr(lem) "with" constr(Hs) "as" constr(Hr) := *) +(* iStartProof; *) +(* let rec find Γ j := *) +(* match Γ with *) +(* | Esnoc ?Γ (IAnon _) ?P => *) +(* find Γ j *) +(* | Esnoc ?Γ (INamed ?Hj) ?P => *) +(* lazymatch P with *) +(* | (j ⤇ _)%I => Hj *) +(* | _ => find Γ j *) +(* end *) +(* | Enil => fail 2 "tp_apply: cannot find " j " ⤇ _ " *) +(* | _ => fail 2 "tp_apply: unknown error in find" *) +(* end in *) +(* let rec findSpec Γp Γs := *) +(* match Γp with *) +(* | Esnoc ?Γ (IAnon _) _ => findSpec Γ Γs *) +(* | Esnoc ?Γ (INamed ?Hspec) ?P => *) +(* lazymatch P with *) +(* | (spec_ctx _)%I => Hspec *) +(* | _ => findSpec Γ Γs *) +(* end *) +(* | Enil => *) +(* match Γs with *) +(* | Enil => fail 2 "tp_apply: cannot find spec_ctx _" *) +(* | _ => findSpec Γs Enil *) +(* end *) +(* | _ => fail 2 "tp_apply: unknown error in findSpec" *) +(* end in *) +(* match goal with *) +(* | |- envs_entails (Envs ?Γp ?Γs) ?Q => *) +(* let Hj := (find Γs j) in *) +(* let Hspec := findSpec Γp Γs in *) +(* let pat := eval vm_compute in (appP (sel_pat.parse Hs) Hj Hspec) in *) +(* let pats := print_sel pat in *) +(* let elim_pats := eval vm_compute in (add_elim_pat Hr Hj) in *) +(* iMod (lem with pats) as elim_pats; first try by solve_ndisj *) +(* | _ => fail "tp_apply: cannot parse the context" *) +(* end. *) + +(* Tactic Notation "tp_apply" constr(j) open_constr(lem) "with" constr(Hs) := tp_apply j lem with Hs as "". *) + +(* Tactic Notation "tp_apply" constr(j) open_constr(lem) "as" constr(Hr) := tp_apply j lem with "" as Hr. *) + +(* Tactic Notation "tp_apply" constr(j) open_constr(lem) := tp_apply j lem with "" as "". *) +(* *) diff --git a/theories/logic/proofmode/tactics.v b/theories/logic/proofmode/tactics.v index 8cfc9bc5f8dd3dfc8f31dc5b6b9ceb4e7cabd724..4b87c06610e32842ec3a661f6ad0feb6016f00ed 100644 --- a/theories/logic/proofmode/tactics.v +++ b/theories/logic/proofmode/tactics.v @@ -16,7 +16,7 @@ Lemma tac_rel_bind_l `{!relocG Σ} e' K ℶ E e t A : envs_entails ℶ (REL e << t @ E : A). Proof. intros. subst. assumption. Qed. -Lemma tac_rel_bind_r `{!relocG Σ} t' K ℶ E e t A : +Lemma tac_rel_bind_r `{!relocG Σ} (t' : expr) K ℶ E e t A : t = fill K t' → envs_entails ℶ (REL e << fill K t' @ E : A) → envs_entails ℶ (REL e << t @ E : A). @@ -73,10 +73,10 @@ Ltac rel_reshape_cont_l tac := Ltac rel_reshape_cont_r tac := lazymatch goal with - | |- envs_entails _ (refines _ _ (fill ?K ?e) _) => + | |- envs_entails _ (refines _ _ (in_1 (fill ?K ?e)) _) => reshape_expr e ltac:(fun K' e' => tac (K' ++ K) e') - | |- envs_entails _ (refines _ _ ?e _) => + | |- envs_entails _ (refines _ _ (in_1 ?e) _) => reshape_expr e ltac:(fun K' e' => tac K' e') end. @@ -141,7 +141,7 @@ Proof. - rewrite -refines_masked_l //. Qed. -Lemma tac_rel_pure_r `{!relocG Σ} K e1 ℶ E e e2 eres Ï• n t A : +Lemma tac_rel_pure_r `{!relocG Σ} K e1 ℶ E (e e2 eres : expr) Ï• n t A : e = fill K e1 → PureExec Ï• n e1 e2 → Ï• → @@ -154,19 +154,6 @@ Proof. rewrite -refines_pure_r //. Qed. -(* Tactic Notation "rel_pure_l" open_constr(ef) := *) -(* iStartProof; *) -(* (eapply tac_rel_pure_l; *) -(* [tac_bind_helper ef (** e = fill K e1' *) *) -(* |iSolveTC (** PureClosed Ï• n e1 e2 *) *) -(* |try fast_done (** The pure condition for PureClosed *) *) -(* |first [left; split; reflexivity (** Here we decide if the mask E is ⊤ *) *) -(* | right; reflexivity] (** (m = n ∧ E = ⊤) ∨ (m = 0) *) *) -(* |iSolveTC (** IntoLaters *) *) -(* |simpl; reflexivity (** eres = fill K e2 *) *) -(* |rel_finish (** new goal *)]) *) -(* || fail "rel_pure_l: cannot find the reduct". *) - Tactic Notation "rel_pure_l" open_constr(ef) := iStartProof; rel_reshape_cont_l ltac:(fun K e' => @@ -622,11 +609,11 @@ Lemma tac_rel_fork_r `{!relocG Σ} K ℶ E e' e t eres A : nclose specN ⊆ E → is_closed_expr [] e' → eres = fill K #() → - envs_entails ℶ (∀ i, i ⤇ e' -∗ refines E t eres A) → + envs_entails ℶ (∀ k, refines_right k e' -∗ refines E t eres A) → envs_entails ℶ (refines E t e A). Proof. intros ?????. subst e eres. - rewrite -refines_fork_r //. + by rewrite -refines_fork_r //. Qed. Tactic Notation "rel_fork_r" ident(i) "as" constr(H) := diff --git a/theories/logic/rules.v b/theories/logic/rules.v index 08b628d9b228dfb78d716f29458f77cd4f33568e..6e290564d016473c4888872eeb028e99016e085a 100644 --- a/theories/logic/rules.v +++ b/theories/logic/rules.v @@ -10,7 +10,7 @@ From reloc.prelude Require Import ctx_subst. Section rules. Context `{relocG Σ}. Implicit Types A : lrel Σ. - Implicit Types e t : expr. + Implicit Types e : expr. Implicit Types v w : val. Local Existing Instance pure_exec_fill. @@ -30,9 +30,9 @@ Section rules. Proof. intros Hpure HÏ•. rewrite refines_eq /refines_def. - iIntros "IH" ; iIntros (j K) "#Hs Hj /=". + iIntros "IH" ; iIntros (j K) "Hs /=". iModIntro. wp_pures. - iApply fupd_wp. iApply ("IH" with "Hs Hj"). + iApply fupd_wp. iApply ("IH" with "Hs"). Qed. Lemma refines_masked_l E n @@ -44,39 +44,39 @@ Section rules. Proof. intros Hpure HÏ•. rewrite refines_eq /refines_def. - iIntros "IH" ; iIntros (j K) "#Hs Hj /=". - iMod ("IH" with "Hs Hj") as "IH". + iIntros "IH" ; iIntros (j K) "Hs /=". + iMod ("IH" with "Hs") as "IH". iModIntro. by wp_pures. Qed. - Lemma refines_wp_l K e1 e2 A : + Lemma refines_wp_l K e1 t A : (WP e1 {{ v, - REL fill K (of_val v) << e2 : A }})%I -∗ - REL fill K e1 << e2 : A. + REL fill K (of_val v) << t : A }})%I -∗ + REL fill K e1 << t : A. Proof. rewrite refines_eq /refines_def. iIntros "He". - iIntros (j K') "#Hs Hj /=". + iIntros (j K') "Hs /=". iModIntro. iApply wp_bind. iApply (wp_wand with "He"). iIntros (v) "Hv". - by iMod ("Hv" with "Hs Hj"). + by iMod ("Hv" with "Hs"). Qed. - Lemma refines_atomic_l (E : coPset) K e1 e2 A + Lemma refines_atomic_l (E : coPset) K e1 t A (Hatomic : Atomic WeaklyAtomic e1) : (|={⊤,E}=> WP e1 @ E {{ v, - REL fill K (of_val v) << e2 @ E : A }})%I -∗ - REL fill K e1 << e2 : A. + REL fill K (of_val v) << t @ E : A }})%I -∗ + REL fill K e1 << t : A. Proof. rewrite refines_eq /refines_def. iIntros "Hlog". - iIntros (j K') "#Hs Hj /=". iModIntro. + iIntros (j K') "Hs /=". iModIntro. iApply wp_bind. iApply wp_atomic; auto. iMod "Hlog" as "He". iModIntro. iApply (wp_wand with "He"). iIntros (v) "Hlog". - by iApply ("Hlog" with "Hs Hj"). + by iApply ("Hlog" with "Hs"). Qed. (** ** Forward reductions on the RHS *) @@ -89,26 +89,33 @@ Section rules. ⊢ REL t << fill K' e @ E : A. Proof. rewrite refines_eq /refines_def => Hpure HÏ•. - iIntros "Hlog". iIntros (j K) "#Hs Hj /=". - tp_pure j _; auto. - iApply ("Hlog" with "Hs Hj"). + iIntros "Hlog". iIntros (j K) "Hs /=". + tp_pures ({| tp_id := j; tp_ctx := K |}) ; auto. + iApply ("Hlog" with "Hs"). Qed. + Lemma refines_right_bind k K e : + refines_right k (fill K e) ≡ refines_right (RefId (tp_id k) (K ++ tp_ctx k)) e. + Proof. rewrite /refines_right /=. by rewrite fill_app. Qed. + + Lemma refines_right_bind' j K K' e : + refines_right (RefId j K) (fill K' e) ≡ refines_right (RefId j (K' ++ K)) e. + Proof. rewrite /refines_right /=. by rewrite fill_app. Qed. + (* A helper lemma for proving the stateful reductions for the RHS below *) - Lemma refines_step_r Φ E K' e1 e2 A : - (∀ j K, spec_ctx -∗ (j ⤇ fill K e2 ={E}=∗ ∃ v, j ⤇ fill K (of_val v) - ∗ Φ v)) -∗ - (∀ v, Φ v -∗ REL e1 << fill K' (of_val v) @ E : A) -∗ + Lemma refines_step_r E K' e1 e2 A : + (∀ k, refines_right k e2 ={E}=∗ + ∃ v, refines_right k (of_val v) ∗ REL e1 << fill K' (of_val v) @ E : A) -∗ REL e1 << fill K' e2 @ E : A. Proof. rewrite refines_eq /refines_def. - iIntros "He Hlog". - iIntros (j K) "#Hs Hj /=". - rewrite -fill_app. - iMod ("He" $! j with "Hs Hj") as (v) "[Hj Hv]". - iSpecialize ("Hlog" $! v with "Hv Hs"). - rewrite fill_app. - by iApply "Hlog". + iIntros "He". + iIntros (j K) "Hs /=". + rewrite refines_right_bind /=. + iMod ("He" with "Hs") as (v) "[Hs He]". + rewrite -refines_right_bind'. + iSpecialize ("He" with "Hs"). + by iApply "He". Qed. Lemma refines_newproph_r E K t A @@ -117,14 +124,10 @@ Section rules. -∗ REL t << fill K NewProph @ E : A. Proof. iIntros "Hlog". - pose (Φ := (fun w => ∃ (p : proph_id), ⌜w = (# p)⌠: iProp Σ)%I). - iApply (refines_step_r Φ); simpl; auto. - { cbv[Φ]. - iIntros (j K') "#Hs Hj /=". - iMod (step_newproph with "[$Hs $Hj]") as (p) "Hj". done. - iModIntro. iExists _. iFrame. iExists _. iFrame. eauto. } - iIntros (v') "He'". iDestruct "He'" as (p) "%". subst. - by iApply "Hlog". + iApply refines_step_r. + iIntros (k) "[Hs Hj]". + iMod (step_newproph with "[$Hs $Hj]") as (p) "Hj". done. + iModIntro. iExists _. iFrame "Hj". by iApply "Hlog". Qed. Lemma refines_resolveproph_r E K t (p : proph_id) w A @@ -133,13 +136,23 @@ Section rules. -∗ REL t << fill K (ResolveProph #p (of_val w)) @ E : A. Proof. iIntros "Hlog". - pose (Φ := (fun w => ⌜w = #()⌠: iProp Σ)%I). - iApply (refines_step_r Φ); simpl; auto. - { cbv[Φ]. - iIntros (j K') "#Hs Hj /=". - iMod (step_resolveproph with "[$Hs $Hj]") as "Hj". done. - iModIntro. iExists _. iFrame. eauto. } - iIntros (v') "He'". iDestruct "He'" as %->. + iApply refines_step_r. + iIntros (k) "[Hs Hj]". + iMod (step_resolveproph with "[$Hs $Hj]") as "Hj". done. + iModIntro. iExists _. iFrame "Hj". by iApply "Hlog". + Qed. + + Lemma refines_store_r E K l e e' v v' A + (Hmasked : nclose specN ⊆ E) : + IntoVal e' v' → + l ↦ₛ v -∗ + (l ↦ₛ v' -∗ REL e << fill K (of_val #()) @ E : A) -∗ + REL e << fill K (#l <- e') @ E : A. + Proof. + rewrite /IntoVal. iIntros (<-) "Hl Hlog". + iApply refines_step_r. + iIntros (k) "Hk". simpl. + tp_store k. iModIntro. iExists _. iFrame. by iApply "Hlog". Qed. @@ -149,16 +162,12 @@ Section rules. (∀ l : loc, l ↦ₛ v -∗ REL t << fill K (of_val #l) @ E : A)%I -∗ REL t << fill K (ref e) @ E : A. Proof. - intros <-. + rewrite /IntoVal. intros <-. iIntros "Hlog". - pose (Φ := (fun w => ∃ l : loc, ⌜w = (# l)⌠∗ l ↦ₛ v)%I). - iApply (refines_step_r Φ); simpl; auto. - { cbv[Φ]. - iIntros (j K') "#Hs Hj /=". - tp_alloc j as l "Hl". iExists (# l). - iFrame. iExists l. eauto. } - iIntros (v') "He'". iDestruct "He'" as (l) "[% Hl]". subst. - by iApply "Hlog". + iApply refines_step_r. + iIntros (k) "Hk". + tp_alloc k as l "Hl". + iModIntro. iExists _. iFrame. by iApply "Hlog". Qed. Lemma refines_load_r E K l q v t A @@ -168,32 +177,10 @@ Section rules. -∗ REL t << (fill K !#l) @ E : A. Proof. iIntros "Hl Hlog". - pose (Φ := (fun w => ⌜w = v⌠∗ l ↦ₛ{q} v)%I). - iApply (refines_step_r Φ with "[Hl]"); eauto. - { cbv[Φ]. - iIntros (j K') "#Hs Hj /=". iExists v. - tp_load j. - iFrame. eauto. } - iIntros (?) "[% Hl]"; subst. - by iApply "Hlog". - Qed. - - Lemma refines_store_r E K l e e' v v' A - (Hmasked : nclose specN ⊆ E) : - IntoVal e' v' → - l ↦ₛ v -∗ - (l ↦ₛ v' -∗ REL e << fill K (of_val #()) @ E : A) -∗ - REL e << fill K (#l <- e') @ E : A. - Proof. - iIntros (<-) "Hl Hlog". - pose (Φ := (fun w => ⌜w = #()⌠∗ l ↦ₛ v')%I). - iApply (refines_step_r Φ with "[Hl]"); eauto. - { cbv[Φ]. - iIntros (j K') "#Hs Hj /=". iExists #(). - tp_store j. - iFrame. eauto. } - iIntros (w) "[% Hl]"; subst. - by iApply "Hlog". + iApply refines_step_r. + iIntros (k) "Hk". + tp_load k. + iModIntro. iExists _. iFrame. by iApply "Hlog". Qed. Lemma refines_cmpxchg_fail_r E K l e1 e2 v1 v2 v t A : @@ -206,16 +193,11 @@ Section rules. (l ↦ₛ v -∗ REL t << fill K (of_val (v, #false)) @ E : A) -∗ REL t << fill K (CmpXchg #l e1 e2) @ E : A. Proof. - iIntros (?<-<-??) "Hl Hlog". - pose (Φ := (fun (w : val) => ⌜w = (v, #false)%V⌠∗ l ↦ₛ v)%I). - iApply (refines_step_r Φ with "[Hl]"); eauto. - { cbv[Φ]. - iIntros (j K') "#Hs Hj /=". - tp_cmpxchg_fail j; auto. - iExists _. simpl. - iFrame. eauto. } - iIntros (w) "[% Hl]"; subst. - by iApply "Hlog". + rewrite /IntoVal. iIntros (?<-<-??) "Hl Hlog". + iApply refines_step_r. + iIntros (k) "Hk". + tp_cmpxchg_fail k. + iModIntro. iExists _. iFrame. by iApply "Hlog". Qed. Lemma refines_cmpxchg_suc_r E K l e1 e2 v1 v2 v t A : @@ -228,16 +210,11 @@ Section rules. (l ↦ₛ v2 -∗ REL t << fill K (of_val (v, #true)) @ E : A) -∗ REL t << fill K (CmpXchg #l e1 e2) @ E : A. Proof. - iIntros (?<-<-??) "Hl Hlog". - pose (Φ := (fun w => ⌜w = (v, #true)%V⌠∗ l ↦ₛ v2)%I). - iApply (refines_step_r Φ with "[Hl]"); eauto. - { cbv[Φ]. - iIntros (j K') "#Hs Hj /=". - tp_cmpxchg_suc j; auto. - iExists _. simpl. - iFrame. eauto. } - iIntros (w) "[% Hl]"; subst. - by iApply "Hlog". + rewrite /IntoVal. iIntros (?<-<-??) "Hl Hlog". + iApply refines_step_r. + iIntros (k) "Hk". + tp_cmpxchg_suc k. + iModIntro. iExists _. iFrame. by iApply "Hlog". Qed. Lemma refines_faa_r E K l e2 (i1 i2 : Z) t A : @@ -247,33 +224,24 @@ Section rules. (l ↦ₛ #(i1+i2) -∗ REL t << fill K (of_val #i1) @ E : A) -∗ REL t << fill K (FAA #l e2) @ E : A. Proof. - iIntros (?<-) "Hl Hlog". - pose (Φ := (fun w => ⌜w = #i1⌠∗ l ↦ₛ #(i1+i2))%I). - iApply (refines_step_r Φ with "[Hl]"); eauto. - { cbv[Φ]. - iIntros (j K') "#Hs Hj /=". - tp_faa j; auto. - iExists #i1. simpl. - iFrame. eauto. } - iIntros (w) "[% Hl]"; subst. - by iApply "Hlog". + rewrite /IntoVal. iIntros (?<-) "Hl Hlog". + iApply refines_step_r. + iIntros (k) "Hk". + tp_faa k. + iModIntro. iExists _. iFrame. by iApply "Hlog". Qed. Lemma refines_fork_r E K (e t : expr) A (Hmasked : nclose specN ⊆ E) : - (∀ i, i ⤇ e -∗ + (∀ k, refines_right k e -∗ REL t << fill K (of_val #()) @ E : A) -∗ REL t << fill K (Fork e) @ E : A. Proof. iIntros "Hlog". - pose (Φ := (fun (v : val) => ∃ i, i ⤇ e ∗ ⌜v = #()âŒ%V)%I). - iApply (refines_step_r Φ with "[]"); cbv[Φ]. - { iIntros (j K') "#Hspec Hj". - tp_fork j as i "Hi". - iModIntro. iExists #(). iFrame. eauto. - } - iIntros (v). iDestruct 1 as (i) "[Hi %]"; subst. - by iApply "Hlog". + iApply refines_step_r. + iIntros (k) "Hk". + tp_fork k as k' "Hk'". + iModIntro. iExists _. iFrame. by iApply "Hlog". Qed. (** ** Primitive structural rules *) @@ -283,26 +251,26 @@ Section rules. Proof. rewrite refines_eq /refines_def. iIntros "H". - iIntros (j K) "#Hs Hj /=". - tp_fork j as i "Hi". iModIntro. - iSpecialize ("H" $! i [] with "Hs Hi"). + iIntros (j K) "Hs /=". + tp_fork ({| tp_id := j; tp_ctx := K |}) as k' "Hk'". iModIntro. + simpl. + iSpecialize ("H" with "Hk'"). iApply (wp_fork with "[H]"). - iNext. iMod "H". iApply (wp_wand with "H"). eauto. - - iNext. iExists _. by iFrame. + - iNext. iExists _. rewrite /refines_right. + iDestruct "Hs" as "[_ $]". done. Qed. (** This rule is useful for proving that functions refine each other *) - Lemma refines_arrow_val v v' A A' : + Lemma refines_arrow_val (v v' : val) A A' : â–¡(∀ v1 v2, A v1 v2 -∗ REL App v (of_val v1) << App v' (of_val v2) : A') -∗ - REL v << v' : (A → A')%lrel. + REL (of_val v) << (of_val v') : (A → A')%lrel. Proof. - rewrite /AsRecV. iIntros "#H". - iApply refines_spec_ctx. iIntros "Hs". + iIntros "#H". iApply refines_ret. iModIntro. iModIntro. iIntros (v1 v2) "HA". iSpecialize ("H" with "HA"). - rewrite refines_eq /refines_def. by iApply "H". Qed. diff --git a/theories/logic/spec_ra.v b/theories/logic/spec_ra.v index 63bb37440faf8f1e9d34a881ef25b44ab8b4cde2..404953819d3ed2e354cb8606fb6f531aadb1c8f7 100644 --- a/theories/logic/spec_ra.v +++ b/theories/logic/spec_ra.v @@ -147,10 +147,10 @@ Section to_heap. Lemma to_heap_valid σ : ✓ to_heap σ. Proof. intros l. rewrite lookup_fmap. by case (σ !! l). Qed. -End to_heap. +End to_heap. Section mapsto. - Context `{cfgSG Σ}. + Context `{!cfgSG Σ}. Global Instance mapstoS_fractional l v : Fractional (λ q, l ↦ₛ{q} v)%I. Proof. @@ -164,10 +164,13 @@ Section mapsto. Lemma mapstoS_agree l q1 q2 v1 v2 : l ↦ₛ{q1} v1 -∗ l ↦ₛ{q2} v2 -∗ ⌜v1 = v2âŒ. Proof. apply bi.wand_intro_r. - rewrite heapS_mapsto_eq -own_op own_valid uPred.discrete_valid. f_equiv. - rewrite auth_frag_op_valid -pair_op singleton_op -pair_op. - rewrite pair_valid singleton_valid pair_valid to_agree_op_valid_L. - by intros [_ [_ [=]]]. + rewrite heapS_mapsto_eq -own_op -auth_frag_op own_valid uPred.discrete_valid. + f_equiv=> /=. + rewrite -pair_op singleton_op right_id -pair_op. + rewrite auth_frag_valid pair_valid. + intros [_ Hv]. move:Hv => /=. + rewrite singleton_valid. + by move=> [_] /to_agree_op_inv_L [->]. Qed. Lemma mapstoS_valid l q v : l ↦ₛ{q} v -∗ ✓ q. diff --git a/theories/logic/spec_rules.v b/theories/logic/spec_rules.v index a02bc4e21dcc0aa06001945106bb3b5b394c7ac0..66c8947d8f02da6c21054e575ee7463c5e66dc2a 100644 --- a/theories/logic/spec_rules.v +++ b/theories/logic/spec_rules.v @@ -38,27 +38,15 @@ Section rules. erased_step (tp, σ) (<[j:=fill K e']> tp, σ'). Proof. rewrite -(right_id_L [] (++) (<[_:=_]>_)). by apply step_insert. Qed. - Lemma nsteps_inv_r {A} n (R : A → A → Prop) x y : - relations.nsteps R (S n) x y → ∃ z, relations.nsteps R n x z ∧ R z y. - Proof. - revert x y; induction n; intros x y. - - inversion 1; subst. - match goal with H : relations.nsteps _ 0 _ _ |- _ => inversion H end; subst. - eexists; repeat econstructor; eauto. - - inversion 1; subst. - edestruct IHn as [z [? ?]]; eauto. - exists z; split; eauto using relations.nsteps_l. - Qed. - (** * Main rules *) (** Pure reductions *) Lemma step_pure E j K e e' (P : Prop) n : P → PureExec P n e e' → nclose specN ⊆ E → - spec_ctx ∗ j ⤇ fill K e ={E}=∗ j ⤇ fill K e'. + spec_ctx ∗ j ⤇ fill K e ={E}=∗ spec_ctx ∗ j ⤇ fill K e'. Proof. - iIntros (HP Hex ?) "[#Hspec Hj]". + iIntros (HP Hex ?) "[#Hspec Hj]". iFrame "Hspec". rewrite /spec_ctx tpool_mapsto_eq /tpool_mapsto_def /=. iDestruct "Hspec" as (Ï) "Hspec". iInv specN as (tp σ) ">[Hown Hrtc]" "Hclose". @@ -102,9 +90,9 @@ Section rules. Lemma step_newproph E j K : nclose specN ⊆ E → spec_ctx ∗ j ⤇ fill K NewProph ={E}=∗ - ∃ (p : proph_id), j ⤇ fill K #p. + ∃ (p : proph_id), spec_ctx ∗ j ⤇ fill K #p. Proof. - iIntros (?) "[#Hinv Hj]". + iIntros (?) "[#Hinv Hj]". iFrame "Hinv". rewrite /spec_ctx tpool_mapsto_eq /tpool_mapsto_def /=. iDestruct "Hinv" as (Ï) "Hinv". iInv specN as (tp σ) ">[Hown %]" "Hclose". @@ -123,9 +111,9 @@ Section rules. Lemma step_resolveproph E j K (p : proph_id) w : nclose specN ⊆ E → spec_ctx ∗ j ⤇ fill K (ResolveProph #p (of_val w)) ={E}=∗ - j ⤇ fill K #(). + spec_ctx ∗ j ⤇ fill K #(). Proof. - iIntros (?) "[#Hinv Hj]". + iIntros (?) "[#Hinv Hj]". iFrame "Hinv". rewrite /spec_ctx tpool_mapsto_eq /tpool_mapsto_def /=. iDestruct "Hinv" as (Ï) "Hinv". iInv specN as (tp σ) ">[Hown %]" "Hclose". @@ -144,9 +132,9 @@ Section rules. Lemma step_alloc E j K e v : IntoVal e v → nclose specN ⊆ E → - spec_ctx ∗ j ⤇ fill K (ref e) ={E}=∗ ∃ l, j ⤇ fill K (#l) ∗ l ↦ₛ v. + spec_ctx ∗ j ⤇ fill K (ref e) ={E}=∗ ∃ l, spec_ctx ∗ j ⤇ fill K (#l) ∗ l ↦ₛ v. Proof. - iIntros (<-?) "[#Hinv Hj]". + iIntros (<-?) "[#Hinv Hj]". iFrame "Hinv". rewrite /spec_ctx tpool_mapsto_eq /tpool_mapsto_def /=. iDestruct "Hinv" as (Ï) "Hinv". iInv specN as (tp σ) ">[Hown %]" "Hclose". @@ -172,9 +160,9 @@ Section rules. Lemma step_load E j K l q v: nclose specN ⊆ E → spec_ctx ∗ j ⤇ fill K (!#l) ∗ l ↦ₛ{q} v - ={E}=∗ j ⤇ fill K (of_val v) ∗ l ↦ₛ{q} v. + ={E}=∗ spec_ctx ∗ j ⤇ fill K (of_val v) ∗ l ↦ₛ{q} v. Proof. - iIntros (?) "(#Hinv & Hj & Hl)". + iIntros (?) "(#Hinv & Hj & Hl)". iFrame "Hinv". rewrite /spec_ctx tpool_mapsto_eq /tpool_mapsto_def. iDestruct "Hinv" as (Ï) "Hinv". rewrite heapS_mapsto_eq /heapS_mapsto_def /=. @@ -196,9 +184,9 @@ Section rules. IntoVal e v → nclose specN ⊆ E → spec_ctx ∗ j ⤇ fill K (#l <- e) ∗ l ↦ₛ v' - ={E}=∗ j ⤇ fill K #() ∗ l ↦ₛ v. + ={E}=∗ spec_ctx ∗ j ⤇ fill K #() ∗ l ↦ₛ v. Proof. - iIntros (<-?) "(#Hinv & Hj & Hl)". + iIntros (<-?) "(#Hinv & Hj & Hl)". iFrame "Hinv". rewrite /spec_ctx tpool_mapsto_eq /tpool_mapsto_def. iDestruct "Hinv" as (Ï) "Hinv". rewrite heapS_mapsto_eq /heapS_mapsto_def /=. @@ -231,9 +219,9 @@ Section rules. vals_compare_safe v' v1 → v' ≠v1 → spec_ctx ∗ j ⤇ fill K (CmpXchg #l e1 e2) ∗ l ↦ₛ{q} v' - ={E}=∗ j ⤇ fill K (v', #false)%V ∗ l ↦ₛ{q} v'. + ={E}=∗ spec_ctx ∗ j ⤇ fill K (v', #false)%V ∗ l ↦ₛ{q} v'. Proof. - iIntros (<-<-???) "(#Hinv & Hj & Hl)". + iIntros (<-<-???) "(#Hinv & Hj & Hl)". iFrame "Hinv". rewrite /spec_ctx tpool_mapsto_eq /tpool_mapsto_def heapS_mapsto_eq /heapS_mapsto_def. iDestruct "Hinv" as (Ï) "Hinv". iInv specN as (tp σ) ">[Hown %]" "Hclose". @@ -258,9 +246,9 @@ Section rules. vals_compare_safe v1' v1 → v1' = v1 → spec_ctx ∗ j ⤇ fill K (CmpXchg #l e1 e2) ∗ l ↦ₛ v1' - ={E}=∗ j ⤇ fill K (v1', #true)%V ∗ l ↦ₛ v2. + ={E}=∗ spec_ctx ∗ j ⤇ fill K (v1', #true)%V ∗ l ↦ₛ v2. Proof. - iIntros (<-<-???) "(#Hinv & Hj & Hl)"; subst. + iIntros (<-<-???) "(#Hinv & Hj & Hl)"; subst. iFrame "Hinv". rewrite /spec_ctx tpool_mapsto_eq /tpool_mapsto_def heapS_mapsto_eq /heapS_mapsto_def. iDestruct "Hinv" as (Ï) "Hinv". iInv specN as (tp σ) ">[Hown %]" "Hclose". @@ -289,9 +277,9 @@ Section rules. IntoVal e1 #i2 → nclose specN ⊆ E → spec_ctx ∗ j ⤇ fill K (FAA #l e1) ∗ l ↦ₛ #i1 - ={E}=∗ j ⤇ fill K #i1 ∗ l ↦ₛ #(i1+i2). + ={E}=∗ spec_ctx ∗ j ⤇ fill K #i1 ∗ l ↦ₛ #(i1+i2). Proof. - iIntros (<-?) "(#Hinv & Hj & Hl)"; subst. + iIntros (<-?) "(#Hinv & Hj & Hl)"; subst. iFrame "Hinv". rewrite /spec_ctx tpool_mapsto_eq /tpool_mapsto_def heapS_mapsto_eq /heapS_mapsto_def. iDestruct "Hinv" as (Ï) "Hinv". iInv specN as (tp σ) ">[Hown %]" "Hclose". @@ -318,9 +306,10 @@ Section rules. (** Fork *) Lemma step_fork E j K e : nclose specN ⊆ E → - spec_ctx ∗ j ⤇ fill K (Fork e) ={E}=∗ ∃ j', j ⤇ fill K #() ∗ j' ⤇ e. + spec_ctx ∗ j ⤇ fill K (Fork e) ={E}=∗ + ∃ j', (spec_ctx ∗ j ⤇ fill K #()) ∗ (spec_ctx ∗ j' ⤇ e). Proof. - iIntros (?) "[#Hspec Hj]". + iIntros (?) "[#Hspec Hj]". iFrame "Hspec". rewrite /spec_ctx tpool_mapsto_eq /tpool_mapsto_def. iDestruct "Hspec" as (Ï) "Hspec". iInv specN as (tp σ) ">[Hown %]" "Hclose". diff --git a/theories/tests/proofmode_tests.v b/theories/tests/proofmode_tests.v index c1dd406875cccfefbf8667d905f5f36a6be89843..911cd662c49480b332f51c44f8e33597d94fdf37 100644 --- a/theories/tests/proofmode_tests.v +++ b/theories/tests/proofmode_tests.v @@ -7,7 +7,7 @@ Context `{relocG Σ}. Definition EqI : lrel Σ := LRel (λ v1 v2, ⌜v1 = v2âŒ)%I. (* Pure reductions *) -Lemma test1 A P t : +Lemma test1 A P (t: expr) : â–· P -∗ (P -∗ REL #4 << t : A) -∗ REL (#2 + #2) << (λ: <>, t) #() : A. diff --git a/theories/tests/tp_tests.v b/theories/tests/tp_tests.v index 0b7077e433229ccf84963485b40b20229bafe9d4..442d4fb3d5c85b34fbcd4aa4ae6ad3c922cddc14 100644 --- a/theories/tests/tp_tests.v +++ b/theories/tests/tp_tests.v @@ -3,81 +3,81 @@ From reloc.logic Require Export spec_rules proofmode.spec_tactics. Set Default Proof Using "Type". Import lang. -Section test. -Context `{relocG Σ}. +(* Section test. *) +(* Context `{relocG Σ}. *) -(* store, load, and some pure reductions *) -Lemma test1 E1 j K (l : loc) (n : nat) : - nclose specN ⊆ E1 → - spec_ctx -∗ - j ⤇ fill K ((λ: "x", #l <- "x" + #1) !#l)%E -∗ - l ↦ₛ #n - ={E1}=∗ l ↦ₛ #(n+1) ∗ j ⤇ fill K #(). -Proof. - iIntros (?) "#? Hj Hl". - tp_load j. - tp_pures j. - tp_store j. by iFrame. -Qed. +(* (* store, load, and some pure reductions *) *) +(* Lemma test1 E1 j K (l : loc) (n : nat) : *) +(* nclose specN ⊆ E1 → *) +(* spec_ctx -∗ *) +(* j ⤇ fill K ((λ: "x", #l <- "x" + #1) !#l)%E -∗ *) +(* l ↦ₛ #n *) +(* ={E1}=∗ l ↦ₛ #(n+1) ∗ j ⤇ fill K #(). *) +(* Proof. *) +(* iIntros (?) "#? Hj Hl". *) +(* tp_load j. *) +(* tp_pures j. *) +(* tp_store j. by iFrame. *) +(* Qed. *) -(* CAS *) -Lemma test2 E1 j K (l : loc) (n : nat) : - nclose specN ⊆ E1 → - spec_ctx -∗ - j ⤇ fill K (CAS #l #2 #n;; CAS #l #3 (#n*#2)) -∗ - l ↦ₛ #3 - ={E1}=∗ l ↦ₛ #(n*2) ∗ j ⤇ fill K #true. -Proof. - iIntros (?) "#? Hj Hl". - tp_cmpxchg_fail j. - tp_pures j. - tp_cmpxchg_suc j. - tp_pures j. by iFrame. -Qed. +(* (* CAS *) *) +(* Lemma test2 E1 j K (l : loc) (n : nat) : *) +(* nclose specN ⊆ E1 → *) +(* spec_ctx -∗ *) +(* j ⤇ fill K (CAS #l #2 #n;; CAS #l #3 (#n*#2)) -∗ *) +(* l ↦ₛ #3 *) +(* ={E1}=∗ l ↦ₛ #(n*2) ∗ j ⤇ fill K #true. *) +(* Proof. *) +(* iIntros (?) "#? Hj Hl". *) +(* tp_cmpxchg_fail j. *) +(* tp_pures j. *) +(* tp_cmpxchg_suc j. *) +(* tp_pures j. by iFrame. *) +(* Qed. *) -(* fork *) -Lemma test3 E1 j e K (l : loc) (n : nat) : - nclose specN ⊆ E1 → - spec_ctx -∗ - j ⤇ fill K (Fork e) - ={E1}=∗ ∃ i, i ⤇ e ∗ j ⤇ fill K #(). -Proof. - iIntros (?) "#? Hj". - tp_fork j as i. eauto with iFrame. -Qed. +(* (* fork *) *) +(* Lemma test3 E1 j e K (l : loc) (n : nat) : *) +(* nclose specN ⊆ E1 → *) +(* spec_ctx -∗ *) +(* j ⤇ fill K (Fork e) *) +(* ={E1}=∗ ∃ i, i ⤇ e ∗ j ⤇ fill K #(). *) +(* Proof. *) +(* iIntros (?) "#? Hj". *) +(* tp_fork j as i. eauto with iFrame. *) +(* Qed. *) -(* alloc *) -Lemma test4 E1 j K (n : nat) : - nclose specN ⊆ E1 → - spec_ctx -∗ - j ⤇ fill K (ref #3) - ={E1}=∗ ∃ l, l ↦ₛ #3 ∗ j ⤇ fill K #l. -Proof. - iIntros (?) "#? Hj". - tp_alloc j as l "Hl". - iExists l. by iFrame. -Qed. +(* (* alloc *) *) +(* Lemma test4 E1 j K (n : nat) : *) +(* nclose specN ⊆ E1 → *) +(* spec_ctx -∗ *) +(* j ⤇ fill K (ref #3) *) +(* ={E1}=∗ ∃ l, l ↦ₛ #3 ∗ j ⤇ fill K #l. *) +(* Proof. *) +(* iIntros (?) "#? Hj". *) +(* tp_alloc j as l "Hl". *) +(* iExists l. by iFrame. *) +(* Qed. *) -End test. +(* End test. *) -(* Section test2. *) -(* Context `{logrelG Σ}. *) -(* (* TODO: Coq complains if I make it a section variable *) *) -(* Axiom (steps_release_test : forall E Ï j K (l : loc) (b : bool), *) -(* nclose specN ⊆ E → *) -(* spec_ctx -∗ l ↦ₛ #b -∗ j ⤇ fill K (App #() #l) *) -(* ={E}=∗ j ⤇ fill K #() ∗ l ↦ₛ #false). *) +(* (* Section test2. *) *) +(* (* Context `{logrelG Σ}. *) *) +(* (* (* TODO: Coq complains if I make it a section variable *) *) *) +(* (* Axiom (steps_release_test : forall E Ï j K (l : loc) (b : bool), *) *) +(* (* nclose specN ⊆ E → *) *) +(* (* spec_ctx -∗ l ↦ₛ #b -∗ j ⤇ fill K (App #() #l) *) *) +(* (* ={E}=∗ j ⤇ fill K #() ∗ l ↦ₛ #false). *) *) -(* Theorem test_apply E Ï j (b : bool) K l: *) -(* nclose specN ⊆ E → *) -(* spec_ctx -∗ *) -(* l ↦ₛ #b -∗ j ⤇ fill K (App #() #l) *) -(* -∗ |={E}=> True. *) -(* Proof. *) -(* iIntros (?) "#Hs Hst Hj". *) -(* tp_apply j steps_release_test with "Hst" as "Hl". *) -(* done. *) -(* Qed. *) +(* (* Theorem test_apply E Ï j (b : bool) K l: *) *) +(* (* nclose specN ⊆ E → *) *) +(* (* spec_ctx -∗ *) *) +(* (* l ↦ₛ #b -∗ j ⤇ fill K (App #() #l) *) *) +(* (* -∗ |={E}=> True. *) *) +(* (* Proof. *) *) +(* (* iIntros (?) "#Hs Hst Hj". *) *) +(* (* tp_apply j steps_release_test with "Hst" as "Hl". *) *) +(* (* done. *) *) +(* (* Qed. *) *) -(* End test2. *) +(* (* End test2. *) *) diff --git a/theories/typing/fundamental.v b/theories/typing/fundamental.v index 46fcd4df9540b218d82e9389670fdd39c75463a3..f4c96c7553132cc6fe03fa712f19dd4e617455f0 100644 --- a/theories/typing/fundamental.v +++ b/theories/typing/fundamental.v @@ -92,7 +92,6 @@ Section fundamental. iApply refines_arrow_val. iModIntro. iLöb as "IH". iIntros (v1 v2) "#HÏ„1". rel_pure_l. rel_pure_r. - iApply refines_spec_ctx. iIntros "#Hs". set (r := (RecV f x (subst_map (binder_delete x (binder_delete f (fst <$> vs))) e), RecV f x (subst_map (binder_delete x (binder_delete f (snd <$> vs))) e'))). set (vvs' := binder_insert f r (binder_insert x (v1,v2) vs)). diff --git a/theories/typing/soundness.v b/theories/typing/soundness.v index 8093802248f6da1007a76df7feafb814a559c784..4506b34ce0abb34c5bfcb4fdbc23d6e3680668c6 100644 --- a/theories/typing/soundness.v +++ b/theories/typing/soundness.v @@ -74,7 +74,7 @@ Proof. iModIntro. iIntros (?). iApply Hlog. Qed. -Lemma refines_sound Σ `{relocPreG Σ} e e' Ï„ : +Lemma refines_sound Σ `{relocPreG Σ} (e e': expr) Ï„ : (∀ `{relocG Σ} Δ, ⊢ REL e << e' : (interp Ï„ Δ)) → ∅ ⊨ e ≤ctx≤ e' : Ï„. Proof.