Commit 69eefa4c authored by Robbert Krebbers's avatar Robbert Krebbers

Seal off mapsto, invariants, and ghost ownership.

Fixes issue #20.
parent 7e7adcb9
Pipeline #1491 passed with stage
...@@ -24,8 +24,13 @@ Definition of_heap : heapUR → state := omap (maybe DecAgree ∘ snd). ...@@ -24,8 +24,13 @@ Definition of_heap : heapUR → state := omap (maybe DecAgree ∘ snd).
Section definitions. Section definitions.
Context `{i : heapG Σ}. Context `{i : heapG Σ}.
Definition heap_mapsto (l : loc) (q : Qp) (v: val) : iPropG heap_lang Σ := Definition heap_mapsto_def (l : loc) (q : Qp) (v: val) : iPropG heap_lang Σ :=
auth_own heap_name {[ l := (q, DecAgree v) ]}. auth_own heap_name {[ l := (q, DecAgree v) ]}.
Definition heap_mapsto_aux : { x | x = @heap_mapsto_def }. by eexists. Qed.
Definition heap_mapsto := proj1_sig heap_mapsto_aux.
Definition heap_mapsto_eq : @heap_mapsto = @heap_mapsto_def :=
proj2_sig heap_mapsto_aux.
Definition heap_inv (h : heapUR) : iPropG heap_lang Σ := Definition heap_inv (h : heapUR) : iPropG heap_lang Σ :=
ownP (of_heap h). ownP (of_heap h).
Definition heap_ctx (N : namespace) : iPropG heap_lang Σ := Definition heap_ctx (N : namespace) : iPropG heap_lang Σ :=
...@@ -107,7 +112,7 @@ Section heap. ...@@ -107,7 +112,7 @@ Section heap.
apply (auth_alloc (ownP of_heap) N E); auto using to_heap_valid. } apply (auth_alloc (ownP of_heap) N E); auto using to_heap_valid. }
apply pvs_mono, exist_elim=> γ. apply pvs_mono, exist_elim=> γ.
rewrite -(exist_intro (HeapG _ _ γ)) /heap_ctx; apply and_mono_r. rewrite -(exist_intro (HeapG _ _ γ)) /heap_ctx; apply and_mono_r.
rewrite /heap_mapsto /heap_name. rewrite heap_mapsto_eq /heap_mapsto_def /heap_name.
induction σ as [|l v σ Hl IH] using map_ind. induction σ as [|l v σ Hl IH] using map_ind.
{ rewrite big_sepM_empty; apply True_intro. } { rewrite big_sepM_empty; apply True_intro. }
rewrite to_heap_insert big_sepM_insert //. rewrite to_heap_insert big_sepM_insert //.
...@@ -120,17 +125,19 @@ Section heap. ...@@ -120,17 +125,19 @@ Section heap.
(** General properties of mapsto *) (** General properties of mapsto *)
Global Instance heap_mapsto_timeless l q v : TimelessP (l {q} v). Global Instance heap_mapsto_timeless l q v : TimelessP (l {q} v).
Proof. rewrite /heap_mapsto. apply _. Qed. Proof. rewrite heap_mapsto_eq /heap_mapsto_def. apply _. Qed.
Lemma heap_mapsto_op_eq l q1 q2 v : l {q1} v l {q2} v l {q1+q2} v. Lemma heap_mapsto_op_eq l q1 q2 v : l {q1} v l {q2} v l {q1+q2} v.
Proof. by rewrite -auth_own_op op_singleton pair_op dec_agree_idemp. Qed. Proof.
by rewrite heap_mapsto_eq -auth_own_op op_singleton pair_op dec_agree_idemp.
Qed.
Lemma heap_mapsto_op l q1 q2 v1 v2 : Lemma heap_mapsto_op l q1 q2 v1 v2 :
l {q1} v1 l {q2} v2 v1 = v2 l {q1+q2} v1. l {q1} v1 l {q2} v2 v1 = v2 l {q1+q2} v1.
Proof. Proof.
destruct (decide (v1 = v2)) as [->|]. destruct (decide (v1 = v2)) as [->|].
{ by rewrite heap_mapsto_op_eq const_equiv // left_id. } { by rewrite heap_mapsto_op_eq const_equiv // left_id. }
rewrite -auth_own_op op_singleton pair_op dec_agree_ne //. rewrite heap_mapsto_eq -auth_own_op op_singleton pair_op dec_agree_ne //.
apply (anti_symm ()); last by apply const_elim_l. apply (anti_symm ()); last by apply const_elim_l.
rewrite auth_own_valid gmap_validI (forall_elim l) lookup_singleton. rewrite auth_own_valid gmap_validI (forall_elim l) lookup_singleton.
rewrite option_validI prod_validI frac_validI discrete_valid. rewrite option_validI prod_validI frac_validI discrete_valid.
...@@ -155,7 +162,7 @@ Section heap. ...@@ -155,7 +162,7 @@ Section heap.
rewrite -of_heap_insert -(insert_singleton_op h); last by apply of_heap_None. rewrite -of_heap_insert -(insert_singleton_op h); last by apply of_heap_None.
iFrame "Hheap". iSplit; first iPureIntro. iFrame "Hheap". iSplit; first iPureIntro.
{ by apply alloc_unit_singleton_local_update; first apply of_heap_None. } { by apply alloc_unit_singleton_local_update; first apply of_heap_None. }
iIntros "Hheap". iApply "HΦ". by rewrite /heap_mapsto. iIntros "Hheap". iApply "HΦ". by rewrite heap_mapsto_eq /heap_mapsto_def.
Qed. Qed.
Lemma wp_load N E l q v Φ : Lemma wp_load N E l q v Φ :
...@@ -163,7 +170,8 @@ Section heap. ...@@ -163,7 +170,8 @@ Section heap.
heap_ctx N l {q} v (l {q} v - Φ v) heap_ctx N l {q} v (l {q} v - Φ v)
WP Load (Lit (LitLoc l)) @ E {{ Φ }}. WP Load (Lit (LitLoc l)) @ E {{ Φ }}.
Proof. Proof.
iIntros {?} "[#Hh [Hl HΦ]]". rewrite /heap_ctx /heap_mapsto. iIntros {?} "[#Hh [Hl HΦ]]".
rewrite /heap_ctx heap_mapsto_eq /heap_mapsto_def.
iApply (auth_fsa heap_inv (wp_fsa _)); simpl; eauto. iApply (auth_fsa heap_inv (wp_fsa _)); simpl; eauto.
iFrame "Hh Hl". iIntros {h} "[% Hl]". rewrite /heap_inv. iFrame "Hh Hl". iIntros {h} "[% Hl]". rewrite /heap_inv.
iApply (wp_load_pst _ (<[l:=v]>(of_heap h)));first by rewrite lookup_insert. iApply (wp_load_pst _ (<[l:=v]>(of_heap h)));first by rewrite lookup_insert.
...@@ -177,7 +185,8 @@ Section heap. ...@@ -177,7 +185,8 @@ Section heap.
heap_ctx N l v' (l v - Φ (LitV LitUnit)) heap_ctx N l v' (l v - Φ (LitV LitUnit))
WP Store (Lit (LitLoc l)) e @ E {{ Φ }}. WP Store (Lit (LitLoc l)) e @ E {{ Φ }}.
Proof. Proof.
iIntros {??} "[#Hh [Hl HΦ]]". rewrite /heap_ctx /heap_mapsto. iIntros {??} "[#Hh [Hl HΦ]]".
rewrite /heap_ctx heap_mapsto_eq /heap_mapsto_def.
iApply (auth_fsa heap_inv (wp_fsa _)); simpl; eauto. iApply (auth_fsa heap_inv (wp_fsa _)); simpl; eauto.
iFrame "Hh Hl". iIntros {h} "[% Hl]". rewrite /heap_inv. iFrame "Hh Hl". iIntros {h} "[% Hl]". rewrite /heap_inv.
iApply (wp_store_pst _ (<[l:=v']>(of_heap h))); rewrite ?lookup_insert //. iApply (wp_store_pst _ (<[l:=v']>(of_heap h))); rewrite ?lookup_insert //.
...@@ -192,7 +201,8 @@ Section heap. ...@@ -192,7 +201,8 @@ Section heap.
heap_ctx N l {q} v' (l {q} v' - Φ (LitV (LitBool false))) heap_ctx N l {q} v' (l {q} v' - Φ (LitV (LitBool false)))
WP CAS (Lit (LitLoc l)) e1 e2 @ E {{ Φ }}. WP CAS (Lit (LitLoc l)) e1 e2 @ E {{ Φ }}.
Proof. Proof.
iIntros {????} "[#Hh [Hl HΦ]]". rewrite /heap_ctx /heap_mapsto. iIntros {????} "[#Hh [Hl HΦ]]".
rewrite /heap_ctx heap_mapsto_eq /heap_mapsto_def.
iApply (auth_fsa heap_inv (wp_fsa _)); simpl; eauto 10. iApply (auth_fsa heap_inv (wp_fsa _)); simpl; eauto 10.
iFrame "Hh Hl". iIntros {h} "[% Hl]". rewrite /heap_inv. iFrame "Hh Hl". iIntros {h} "[% Hl]". rewrite /heap_inv.
iApply (wp_cas_fail_pst _ (<[l:=v']>(of_heap h))); rewrite ?lookup_insert //. iApply (wp_cas_fail_pst _ (<[l:=v']>(of_heap h))); rewrite ?lookup_insert //.
...@@ -206,7 +216,8 @@ Section heap. ...@@ -206,7 +216,8 @@ Section heap.
heap_ctx N l v1 (l v2 - Φ (LitV (LitBool true))) heap_ctx N l v1 (l v2 - Φ (LitV (LitBool true)))
WP CAS (Lit (LitLoc l)) e1 e2 @ E {{ Φ }}. WP CAS (Lit (LitLoc l)) e1 e2 @ E {{ Φ }}.
Proof. Proof.
iIntros {???} "[#Hh [Hl HΦ]]". rewrite /heap_ctx /heap_mapsto. iIntros {???} "[#Hh [Hl HΦ]]".
rewrite /heap_ctx heap_mapsto_eq /heap_mapsto_def.
iApply (auth_fsa heap_inv (wp_fsa _)); simpl; eauto 10. iApply (auth_fsa heap_inv (wp_fsa _)); simpl; eauto 10.
iFrame "Hh Hl". iIntros {h} "[% Hl]". rewrite /heap_inv. iFrame "Hh Hl". iIntros {h} "[% Hl]". rewrite /heap_inv.
iApply (wp_cas_suc_pst _ (<[l:=v1]>(of_heap h))); rewrite ?lookup_insert //. iApply (wp_cas_suc_pst _ (<[l:=v1]>(of_heap h))); rewrite ?lookup_insert //.
......
...@@ -4,8 +4,11 @@ From iris.program_logic Require Export pviewshifts global_functor. ...@@ -4,8 +4,11 @@ From iris.program_logic Require Export pviewshifts global_functor.
From iris.program_logic Require Import ownership. From iris.program_logic Require Import ownership.
Import uPred. Import uPred.
Definition own `{inG Λ Σ A} (γ : gname) (a : A) : iPropG Λ Σ := Definition own_def `{inG Λ Σ A} (γ : gname) (a : A) : iPropG Λ Σ :=
ownG (to_globalF γ a). ownG (to_globalF γ a).
Definition own_aux : { x | x = @own_def }. by eexists. Qed.
Definition own {Λ Σ A i} := proj1_sig own_aux Λ Σ A i.
Definition own_eq : @own = @own_def := proj2_sig own_aux.
Instance: Params (@own) 5. Instance: Params (@own) 5.
Typeclasses Opaque own. Typeclasses Opaque own.
...@@ -16,16 +19,16 @@ Implicit Types a : A. ...@@ -16,16 +19,16 @@ Implicit Types a : A.
(** * Properties of own *) (** * Properties of own *)
Global Instance own_ne γ n : Proper (dist n ==> dist n) (own γ). Global Instance own_ne γ n : Proper (dist n ==> dist n) (own γ).
Proof. solve_proper. Qed. Proof. rewrite !own_eq. solve_proper. Qed.
Global Instance own_proper γ : Proper (() ==> ()) (own γ) := ne_proper _. Global Instance own_proper γ : Proper (() ==> ()) (own γ) := ne_proper _.
Lemma own_op γ a1 a2 : own γ (a1 a2) own γ a1 own γ a2. Lemma own_op γ a1 a2 : own γ (a1 a2) own γ a1 own γ a2.
Proof. by rewrite /own -ownG_op to_globalF_op. Qed. Proof. by rewrite !own_eq /own_def -ownG_op to_globalF_op. Qed.
Global Instance own_mono γ : Proper (flip () ==> ()) (own γ). Global Instance own_mono γ : Proper (flip () ==> ()) (own γ).
Proof. move=>a b [c ->]. rewrite own_op. eauto with I. Qed. Proof. move=>a b [c ->]. rewrite own_op. eauto with I. Qed.
Lemma own_valid γ a : own γ a a. Lemma own_valid γ a : own γ a a.
Proof. Proof.
rewrite /own ownG_valid /to_globalF. rewrite !own_eq /own_def ownG_valid /to_globalF.
rewrite iprod_validI (forall_elim (inG_id i)) iprod_lookup_singleton. rewrite iprod_validI (forall_elim (inG_id i)) iprod_lookup_singleton.
rewrite gmap_validI (forall_elim γ) lookup_singleton option_validI. rewrite gmap_validI (forall_elim γ) lookup_singleton option_validI.
(* implicit arguments differ a bit *) (* implicit arguments differ a bit *)
...@@ -36,9 +39,9 @@ Proof. apply: uPred.always_entails_r. apply own_valid. Qed. ...@@ -36,9 +39,9 @@ Proof. apply: uPred.always_entails_r. apply own_valid. Qed.
Lemma own_valid_l γ a : own γ a a own γ a. Lemma own_valid_l γ a : own γ a a own γ a.
Proof. by rewrite comm -own_valid_r. Qed. Proof. by rewrite comm -own_valid_r. Qed.
Global Instance own_timeless γ a : Timeless a TimelessP (own γ a). Global Instance own_timeless γ a : Timeless a TimelessP (own γ a).
Proof. rewrite /own; apply _. Qed. Proof. rewrite !own_eq /own_def; apply _. Qed.
Global Instance own_core_persistent γ a : Persistent a PersistentP (own γ a). Global Instance own_core_persistent γ a : Persistent a PersistentP (own γ a).
Proof. rewrite /own; apply _. Qed. Proof. rewrite !own_eq /own_def; apply _. Qed.
(* TODO: This also holds if we just have ✓ a at the current step-idx, as Iris (* TODO: This also holds if we just have ✓ a at the current step-idx, as Iris
assertion. However, the map_updateP_alloc does not suffice to show this. *) assertion. However, the map_updateP_alloc does not suffice to show this. *)
...@@ -52,7 +55,7 @@ Proof. ...@@ -52,7 +55,7 @@ Proof.
first (eapply alloc_updateP_strong', cmra_transport_valid, Ha); first (eapply alloc_updateP_strong', cmra_transport_valid, Ha);
naive_solver. naive_solver.
- apply exist_elim=>m; apply const_elim_l=>-[γ [Hfresh ->]]. - apply exist_elim=>m; apply const_elim_l=>-[γ [Hfresh ->]].
by rewrite -(exist_intro γ) const_equiv // left_id. by rewrite !own_eq /own_def -(exist_intro γ) const_equiv // left_id.
Qed. Qed.
Lemma own_alloc a E : a True ={E}=> γ, own γ a. Lemma own_alloc a E : a True ={E}=> γ, own γ a.
Proof. Proof.
...@@ -60,10 +63,9 @@ Proof. ...@@ -60,10 +63,9 @@ Proof.
apply pvs_mono, exist_mono=>?. eauto with I. apply pvs_mono, exist_mono=>?. eauto with I.
Qed. Qed.
Lemma own_updateP P γ a E : Lemma own_updateP P γ a E : a ~~>: P own γ a ={E}=> a', P a' own γ a'.
a ~~>: P own γ a ={E}=> a', P a' own γ a'.
Proof. Proof.
intros Ha. intros Ha. rewrite !own_eq.
rewrite -(pvs_mono _ _ ( m, ( a', m = to_globalF γ a' P a') ownG m)%I). rewrite -(pvs_mono _ _ ( m, ( a', m = to_globalF γ a' P a') ownG m)%I).
- eapply pvs_ownG_updateP, iprod_singleton_updateP; - eapply pvs_ownG_updateP, iprod_singleton_updateP;
first by (eapply singleton_updateP', cmra_transport_updateP', Ha). first by (eapply singleton_updateP', cmra_transport_updateP', Ha).
...@@ -85,7 +87,8 @@ Implicit Types a : A. ...@@ -85,7 +87,8 @@ Implicit Types a : A.
Lemma own_empty γ E : True ={E}=> own γ . Lemma own_empty γ E : True ={E}=> own γ .
Proof. Proof.
rewrite ownG_empty /own. apply pvs_ownG_update, iprod_singleton_update_empty. rewrite ownG_empty !own_eq /own_def.
apply pvs_ownG_update, iprod_singleton_update_empty.
apply (alloc_unit_singleton_update (cmra_transport inG_prf )); last done. apply (alloc_unit_singleton_update (cmra_transport inG_prf )); last done.
- apply cmra_transport_valid, ucmra_unit_valid. - apply cmra_transport_valid, ucmra_unit_valid.
- intros x; destruct inG_prf. by rewrite left_id. - intros x; destruct inG_prf. by rewrite left_id.
......
...@@ -4,8 +4,11 @@ From iris.proofmode Require Import pviewshifts. ...@@ -4,8 +4,11 @@ From iris.proofmode Require Import pviewshifts.
Import uPred. Import uPred.
(** Derived forms and lemmas about them. *) (** Derived forms and lemmas about them. *)
Definition inv {Λ Σ} (N : namespace) (P : iProp Λ Σ) : iProp Λ Σ := Definition inv_def {Λ Σ} (N : namespace) (P : iProp Λ Σ) : iProp Λ Σ :=
( i, (i nclose N) ownI i P)%I. ( i, (i nclose N) ownI i P)%I.
Definition inv_aux : { x | x = @inv_def }. by eexists. Qed.
Definition inv {Λ Σ} := proj1_sig inv_aux Λ Σ.
Definition inv_eq : @inv = @inv_def := proj2_sig inv_aux.
Instance: Params (@inv) 3. Instance: Params (@inv) 3.
Typeclasses Opaque inv. Typeclasses Opaque inv.
...@@ -17,10 +20,12 @@ Implicit Types P Q R : iProp Λ Σ. ...@@ -17,10 +20,12 @@ Implicit Types P Q R : iProp Λ Σ.
Implicit Types Φ : val Λ iProp Λ Σ. Implicit Types Φ : val Λ iProp Λ Σ.
Global Instance inv_contractive N : Contractive (@inv Λ Σ N). Global Instance inv_contractive N : Contractive (@inv Λ Σ N).
Proof. intros n ???. apply exist_ne=>i. by apply and_ne, ownI_contractive. Qed. Proof.
rewrite inv_eq=> n ???. apply exist_ne=>i. by apply and_ne, ownI_contractive.
Qed.
Global Instance inv_persistent N P : PersistentP (inv N P). Global Instance inv_persistent N P : PersistentP (inv N P).
Proof. rewrite /inv; apply _. Qed. Proof. rewrite inv_eq /inv; apply _. Qed.
Lemma always_inv N P : inv N P inv N P. Lemma always_inv N P : inv N P inv N P.
Proof. by rewrite always_always. Qed. Proof. by rewrite always_always. Qed.
...@@ -28,7 +33,7 @@ Proof. by rewrite always_always. Qed. ...@@ -28,7 +33,7 @@ Proof. by rewrite always_always. Qed.
Lemma inv_alloc N E P : nclose N E P ={E}=> inv N P. Lemma inv_alloc N E P : nclose N E P ={E}=> inv N P.
Proof. Proof.
intros. rewrite -(pvs_mask_weaken N) //. intros. rewrite -(pvs_mask_weaken N) //.
by rewrite /inv (pvs_allocI N); last apply coPset_suffixes_infinite. by rewrite inv_eq /inv (pvs_allocI N); last apply coPset_suffixes_infinite.
Qed. Qed.
(** Fairly explicit form of opening invariants *) (** Fairly explicit form of opening invariants *)
...@@ -37,7 +42,7 @@ Lemma inv_open E N P : ...@@ -37,7 +42,7 @@ Lemma inv_open E N P :
inv N P E', (E nclose N E' E) inv N P E', (E nclose N E' E)
|={E,E'}=> P ( P ={E',E}= True). |={E,E'}=> P ( P ={E',E}= True).
Proof. Proof.
rewrite /inv. iDestruct 1 as {i} "[% #Hi]". rewrite inv_eq /inv. iDestruct 1 as {i} "[% #Hi]".
iExists (E {[ i ]}). iSplit. { iPureIntro. set_solver. } iExists (E {[ i ]}). iSplit. { iPureIntro. set_solver. }
iPvs (pvs_openI' with "Hi") as "HP"; [set_solver..|]. iPvs (pvs_openI' with "Hi") as "HP"; [set_solver..|].
iPvsIntro. iSplitL "HP"; first done. iIntros "HP". iPvsIntro. iSplitL "HP"; first done. iIntros "HP".
...@@ -57,8 +62,7 @@ Proof. ...@@ -57,8 +62,7 @@ Proof.
iPvs "Hvs" as "[HP Hvs]"; first set_solver. iPvs "Hvs" as "[HP Hvs]"; first set_solver.
(* TODO: How do I do sth. like [iSpecialize "HΨ HP"]? *) (* TODO: How do I do sth. like [iSpecialize "HΨ HP"]? *)
iPvsIntro. iApply (fsa_mask_weaken _ (E N)); first set_solver. iPvsIntro. iApply (fsa_mask_weaken _ (E N)); first set_solver.
iApply fsa_wand_r. iSplitR "Hvs"; first by iApply "HΨ". iApply fsa_wand_r. iSplitR "Hvs"; first by iApply "HΨ"; simpl.
simpl. iIntros {v} "[HP HΨ]". iPvs ("Hvs" with "HP"); first set_solver. iIntros {v} "[HP HΨ]". by iPvs ("Hvs" with "HP"); first set_solver.
done.
Qed. Qed.
End inv. End inv.
...@@ -30,6 +30,18 @@ Section LiftingTests. ...@@ -30,6 +30,18 @@ Section LiftingTests.
wp_alloc l. wp_let. wp_load. wp_op. wp_store. wp_seq. by wp_load. wp_alloc l. wp_let. wp_load. wp_op. wp_store. wp_seq. by wp_load.
Qed. Qed.
Definition heap_e2 : expr [] :=
let: "x" := ref #1 in
let: "y" := ref #1 in
'"x" <- !'"x" + #1 ;; !'"x".
Lemma heap_e2_spec E N :
nclose N E heap_ctx N WP heap_e2 @ E {{ v, v = #2 }}.
Proof.
iIntros {HN} "#?". rewrite /heap_e2. iApply (wp_mask_weaken N); first done.
wp_alloc l. wp_let. wp_alloc l'. wp_let.
wp_load. wp_op. wp_store. wp_seq. wp_load. done.
Qed.
Definition FindPred : val := Definition FindPred : val :=
rec: "pred" "x" "y" := rec: "pred" "x" "y" :=
let: "yp" := '"y" + #1 in let: "yp" := '"y" + #1 in
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment