diff --git a/_CoqProject b/_CoqProject index de6d164eb9a6d7fad7020806efef78bc823f7891..a1e4ee53b068339b0809f6d497fd9199c97fce1b 100644 --- a/_CoqProject +++ b/_CoqProject @@ -92,13 +92,13 @@ program_logic/language.v program_logic/ectx_language.v program_logic/ectxi_language.v program_logic/ectx_lifting.v +program_logic/gen_heap.v heap_lang/lang.v heap_lang/tactics.v heap_lang/wp_tactics.v -heap_lang/lifting.v +heap_lang/rules.v heap_lang/derived.v heap_lang/notation.v -heap_lang/heap.v heap_lang/lib/spawn.v heap_lang/lib/par.v heap_lang/lib/assert.v diff --git a/heap_lang/adequacy.v b/heap_lang/adequacy.v index 9268f8c9fab49739f06946e5bc86c206e6b3a8ac..9c4d812ddd6b90e273ba1b34d3340828e051ae12 100644 --- a/heap_lang/adequacy.v +++ b/heap_lang/adequacy.v @@ -1,25 +1,26 @@ -From iris.program_logic Require Export weakestpre adequacy. -From iris.heap_lang Require Export heap. +From iris.program_logic Require Export weakestpre adequacy gen_heap. +From iris.heap_lang Require Export rules. From iris.algebra Require Import auth. From iris.heap_lang Require Import proofmode notation. From iris.proofmode Require Import tactics. Class heapPreG Σ := HeapPreG { heap_preG_iris :> invPreG Σ; - heap_preG_heap :> inG Σ (authR heapUR) + heap_preG_heap :> gen_heapPreG loc val Σ }. -Definition heapΣ : gFunctors := #[invΣ; GFunctor (constRF (authR heapUR))]. +Definition heapΣ : gFunctors := #[invΣ; gen_heapΣ loc val]. Instance subG_heapPreG {Σ} : subG heapΣ Σ → heapPreG Σ. -Proof. intros [? ?%subG_inG]%subG_inv. split; apply _. Qed. +Proof. intros [? ?]%subG_inv; split; apply _. Qed. Definition heap_adequacy Σ `{heapPreG Σ} e σ φ : (∀ `{heapG Σ}, True ⊢ WP e {{ v, ⌜φ v⌠}}) → adequate e σ φ. Proof. intros Hwp; eapply (wp_adequacy _ _); iIntros (?) "". - iMod (own_alloc (â— to_heap σ)) as (γ) "Hh". - { apply: auth_auth_valid. exact: to_heap_valid. } - iModIntro. iExists (λ σ, own γ (â— to_heap σ)); iFrame. - set (Hheap := HeapG _ _ _ γ). iApply (Hwp _). + iMod (own_alloc (â— to_gen_heap σ)) as (γ) "Hh". + { apply: auth_auth_valid. exact: to_gen_heap_valid. } + iModIntro. iExists (λ σ, own γ (â— to_gen_heap σ)); iFrame. + set (Hheap := GenHeapG loc val Σ _ _ _ _ γ). + iApply (Hwp (HeapG _ _ _)). Qed. diff --git a/heap_lang/derived.v b/heap_lang/derived.v index 367f34eaaa077df0ceb77cb5b2d3e7b52297feac..f327ef1f7153c431f2b2da544858ca5d9cf65852 100644 --- a/heap_lang/derived.v +++ b/heap_lang/derived.v @@ -1,4 +1,4 @@ -From iris.heap_lang Require Export lifting. +From iris.heap_lang Require Export rules. Import uPred. (** Define some derived forms, and derived lemmas about them. *) @@ -12,7 +12,7 @@ Notation Skip := (Seq (Lit LitUnit) (Lit LitUnit)). Notation Match e0 x1 e1 x2 e2 := (Case e0 (Lam x1 e1) (Lam x2 e2)). Section derived. -Context `{irisG heap_lang Σ}. +Context `{heapG Σ}. Implicit Types P Q : iProp Σ. Implicit Types Φ : val → iProp Σ. diff --git a/heap_lang/heap.v b/heap_lang/heap.v deleted file mode 100644 index dea2f1441820e8b204c9dd17cfd32e3f06f00219..0000000000000000000000000000000000000000 --- a/heap_lang/heap.v +++ /dev/null @@ -1,197 +0,0 @@ -From iris.heap_lang Require Export lifting. -From iris.algebra Require Import auth gmap frac dec_agree. -From iris.base_logic.lib Require Export invariants. -From iris.base_logic.lib Require Import fractional. -From iris.program_logic Require Import ectx_lifting. -From iris.proofmode Require Import tactics. -Import uPred. -(* TODO: The entire construction could be generalized to arbitrary languages that have - a finmap as their state. Or maybe even beyond "as their state", i.e. arbitrary - predicates over finmaps instead of just ownP. *) - -Definition heapUR : ucmraT := gmapUR loc (prodR fracR (dec_agreeR val)). -Definition to_heap : state → heapUR := fmap (λ v, (1%Qp, DecAgree v)). - -(** The CMRA we need. *) -Class heapG Σ := HeapG { - heapG_invG : invG Σ; - heap_inG :> inG Σ (authR heapUR); - heap_name : gname -}. -Instance heapG_irisG `{heapG Σ} : irisG heap_lang Σ := { - iris_invG := heapG_invG; - state_interp σ := own heap_name (â— to_heap σ) -}. - -Section definitions. - Context `{heapG Σ}. - - Definition heap_mapsto_def (l : loc) (q : Qp) (v: val) : iProp Σ := - 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. -End definitions. - -Typeclasses Opaque heap_mapsto. - -Notation "l ↦{ q } v" := (heap_mapsto l q v) - (at level 20, q at level 50, format "l ↦{ q } v") : uPred_scope. -Notation "l ↦ v" := (heap_mapsto l 1 v) (at level 20) : uPred_scope. - -Notation "l ↦{ q } -" := (∃ v, l ↦{q} v)%I - (at level 20, q at level 50, format "l ↦{ q } -") : uPred_scope. -Notation "l ↦ -" := (l ↦{1} -)%I (at level 20) : uPred_scope. - -Local Hint Extern 0 (head_reducible _ _) => eexists _, _, _; simpl. -Local Hint Constructors head_step. -Local Hint Resolve alloc_fresh. -Local Hint Resolve to_of_val. - -Section heap. - Context {Σ : gFunctors}. - Implicit Types P Q : iProp Σ. - Implicit Types Φ : val → iProp Σ. - Implicit Types σ : state. - Implicit Types h g : heapUR. - - (** Conversion to heaps and back *) - Lemma to_heap_valid σ : ✓ to_heap σ. - Proof. intros l. rewrite lookup_fmap. by case (σ !! l). Qed. - Lemma lookup_to_heap_None σ l : σ !! l = None → to_heap σ !! l = None. - Proof. by rewrite /to_heap lookup_fmap=> ->. Qed. - Lemma heap_singleton_included σ l q v : - {[l := (q, DecAgree v)]} ≼ to_heap σ → σ !! l = Some v. - Proof. - rewrite singleton_included=> -[[q' av] [/leibniz_equiv_iff Hl Hqv]]. - move: Hl. rewrite /to_heap lookup_fmap fmap_Some=> -[v' [Hl [??]]]; subst. - by move: Hqv=> /Some_pair_included_total_2 [_ /DecAgree_included ->]. - Qed. - Lemma to_heap_insert l v σ : - to_heap (<[l:=v]> σ) = <[l:=(1%Qp, DecAgree v)]> (to_heap σ). - Proof. by rewrite /to_heap fmap_insert. Qed. - - Context `{heapG Σ}. - - (** General properties of mapsto *) - Global Instance heap_mapsto_timeless l q v : TimelessP (l ↦{q} v). - Proof. rewrite heap_mapsto_eq /heap_mapsto_def. apply _. Qed. - Global Instance heap_mapsto_fractional l v : Fractional (λ q, l ↦{q} v)%I. - Proof. - intros p q. by rewrite heap_mapsto_eq -own_op -auth_frag_op - op_singleton pair_op dec_agree_idemp. - Qed. - Global Instance heap_mapsto_as_fractional l q v : - AsFractional (l ↦{q} v) (λ q, l ↦{q} v)%I q. - Proof. done. Qed. - - Lemma heap_mapsto_agree l q1 q2 v1 v2 : l ↦{q1} v1 ∗ l ↦{q2} v2 ⊢ ⌜v1 = v2âŒ. - Proof. - rewrite heap_mapsto_eq -own_op -auth_frag_op own_valid discrete_valid. - f_equiv=> /auth_own_valid /=. rewrite op_singleton singleton_valid pair_op. - by move=> [_ /= /dec_agree_op_inv [?]]. - Qed. - - Global Instance heap_ex_mapsto_fractional l : Fractional (λ q, l ↦{q} -)%I. - Proof. - intros p q. iSplit. - - iDestruct 1 as (v) "[H1 H2]". iSplitL "H1"; eauto. - - iIntros "[H1 H2]". iDestruct "H1" as (v1) "H1". iDestruct "H2" as (v2) "H2". - iDestruct (heap_mapsto_agree with "[$H1 $H2]") as %->. iExists v2. by iFrame. - Qed. - Global Instance heap_ex_mapsto_as_fractional l q : - AsFractional (l ↦{q} -) (λ q, l ↦{q} -)%I q. - Proof. done. Qed. - - Lemma heap_mapsto_valid l q v : l ↦{q} v ⊢ ✓ q. - Proof. - rewrite heap_mapsto_eq /heap_mapsto_def own_valid !discrete_valid. - by apply pure_mono=> /auth_own_valid /singleton_valid [??]. - Qed. - Lemma heap_mapsto_valid_2 l q1 q2 v1 v2 : - l ↦{q1} v1 ∗ l ↦{q2} v2 ⊢ ✓ (q1 + q2)%Qp. - Proof. - iIntros "[H1 H2]". iDestruct (heap_mapsto_agree with "[$H1 $H2]") as %->. - iApply (heap_mapsto_valid l _ v2). by iFrame. - Qed. - - (** Weakest precondition *) - Lemma wp_alloc E e v : - to_val e = Some v → - {{{ True }}} Alloc e @ E {{{ l, RET LitV (LitLoc l); l ↦ v }}}. - Proof. - iIntros (<-%of_to_val Φ) "HΦ". iApply wp_lift_atomic_head_step_no_fork; auto. - iIntros (σ1) "Hσ !>"; iSplit; first by auto. - iNext; iIntros (v2 σ2 efs Hstep); inv_head_step. - iMod (own_update with "Hσ") as "[Hσ Hl]". - { eapply auth_update_alloc, - (alloc_singleton_local_update _ _ (1%Qp, DecAgree _))=> //. - by apply lookup_to_heap_None. } - iModIntro; iSplit=> //. rewrite to_heap_insert. iFrame. - iApply "HΦ". by rewrite heap_mapsto_eq /heap_mapsto_def. - Qed. - - Lemma wp_load E l q v : - {{{ â–· l ↦{q} v }}} Load (Lit (LitLoc l)) @ E {{{ RET v; l ↦{q} v }}}. - Proof. - iIntros (Φ) ">Hl HΦ". rewrite heap_mapsto_eq /heap_mapsto_def. - iApply wp_lift_atomic_head_step_no_fork; auto. - iIntros (σ1) "Hσ !>". iDestruct (own_valid_2 with "Hσ Hl") - as %[?%heap_singleton_included _]%auth_valid_discrete_2. - iSplit; first by eauto. - iNext; iIntros (v2 σ2 efs Hstep); inv_head_step. - iModIntro; iSplit=> //. iFrame. by iApply "HΦ". - Qed. - - Lemma wp_store E l v' e v : - to_val e = Some v → - {{{ â–· l ↦ v' }}} Store (Lit (LitLoc l)) e @ E {{{ RET LitV LitUnit; l ↦ v }}}. - Proof. - iIntros (<-%of_to_val Φ) ">Hl HΦ". rewrite heap_mapsto_eq /heap_mapsto_def. - iApply wp_lift_atomic_head_step_no_fork; auto. - iIntros (σ1) "Hσ !>". iDestruct (own_valid_2 with "Hσ Hl") - as %[Hl%heap_singleton_included _]%auth_valid_discrete_2. - iSplit; first by eauto. - iNext; iIntros (v2 σ2 efs Hstep); inv_head_step. - iMod (own_update_2 with "Hσ Hl") as "[Hσ1 Hl]". - { eapply auth_update, singleton_local_update, - (exclusive_local_update _ (1%Qp, DecAgree _))=> //. - by rewrite /to_heap lookup_fmap Hl. } - iModIntro. iSplit=>//. rewrite to_heap_insert. iFrame. by iApply "HΦ". - Qed. - - Lemma wp_cas_fail E l q v' e1 v1 e2 v2 : - to_val e1 = Some v1 → to_val e2 = Some v2 → v' ≠v1 → - {{{ â–· l ↦{q} v' }}} CAS (Lit (LitLoc l)) e1 e2 @ E - {{{ RET LitV (LitBool false); l ↦{q} v' }}}. - Proof. - iIntros (<-%of_to_val <-%of_to_val ? Φ) ">Hl HΦ". - rewrite heap_mapsto_eq /heap_mapsto_def. - iApply wp_lift_atomic_head_step_no_fork; auto. - iIntros (σ1) "Hσ !>". iDestruct (own_valid_2 with "Hσ Hl") - as %[?%heap_singleton_included _]%auth_valid_discrete_2. - iSplit; first by eauto. - iNext; iIntros (v2' σ2 efs Hstep); inv_head_step. (* FIXME: this inversion is slow *) - iModIntro; iSplit=> //. iFrame. by iApply "HΦ". - Qed. - - Lemma wp_cas_suc E l e1 v1 e2 v2 : - to_val e1 = Some v1 → to_val e2 = Some v2 → - {{{ â–· l ↦ v1 }}} CAS (Lit (LitLoc l)) e1 e2 @ E - {{{ RET LitV (LitBool true); l ↦ v2 }}}. - Proof. - iIntros (<-%of_to_val <-%of_to_val Φ) ">Hl HΦ". - rewrite heap_mapsto_eq /heap_mapsto_def. - iApply wp_lift_atomic_head_step_no_fork; auto. - iIntros (σ1) "Hσ !>". iDestruct (own_valid_2 with "Hσ Hl") - as %[Hl%heap_singleton_included _]%auth_valid_discrete_2. - iSplit; first by eauto. - iNext; iIntros (v2' σ2 efs Hstep); inv_head_step. - iMod (own_update_2 with "Hσ Hl") as "[Hσ1 Hl]". - { eapply auth_update, singleton_local_update, - (exclusive_local_update _ (1%Qp, DecAgree _))=> //. - by rewrite /to_heap lookup_fmap Hl. } - iModIntro. iSplit=>//. rewrite to_heap_insert. iFrame. by iApply "HΦ". - Qed. -End heap. diff --git a/heap_lang/lib/counter.v b/heap_lang/lib/counter.v index eb2c176bd190f15f6d93e3d0c3e8f6114f7ac687..45dcdf8aa0a6140200738b892d16c1201d715d0f 100644 --- a/heap_lang/lib/counter.v +++ b/heap_lang/lib/counter.v @@ -1,4 +1,5 @@ From iris.program_logic Require Export weakestpre. +From iris.base_logic.lib Require Export invariants. From iris.heap_lang Require Export lang. From iris.proofmode Require Import tactics. From iris.algebra Require Import frac auth. diff --git a/heap_lang/lib/lock.v b/heap_lang/lib/lock.v index dfaa9edef7f9da3b26e92e5a28406a2398813905..ba10b131213c847cca5032a88bd1b2c41a12f834 100644 --- a/heap_lang/lib/lock.v +++ b/heap_lang/lib/lock.v @@ -1,4 +1,5 @@ -From iris.heap_lang Require Import heap notation. +From iris.heap_lang Require Export rules notation. +From iris.base_logic.lib Require Export invariants. Structure lock Σ `{!heapG Σ} := Lock { (* -- operations -- *) diff --git a/heap_lang/lib/spawn.v b/heap_lang/lib/spawn.v index c9049bbcaf0aaa094ce7e12808d6b54ff454a38b..ab8d39d93b1a023cc6a94deae3cc75302c58dbd4 100644 --- a/heap_lang/lib/spawn.v +++ b/heap_lang/lib/spawn.v @@ -1,4 +1,5 @@ From iris.program_logic Require Export weakestpre. +From iris.base_logic.lib Require Export invariants. From iris.heap_lang Require Export lang. From iris.proofmode Require Import tactics. From iris.heap_lang Require Import proofmode notation. @@ -71,7 +72,7 @@ Proof. - iDestruct "Hinv" as (v') "[% [HΨ|Hγ']]"; simplify_eq/=. + iMod ("Hclose" with "[Hl Hγ]"); [iNext; iExists _; iFrame; eauto|]. iModIntro. wp_match. by iApply "HΦ". - + iCombine "Hγ" "Hγ'" as "Hγ". iDestruct (own_valid with "Hγ") as %[]. + + iDestruct (own_valid_2 with "Hγ Hγ'") as %[]. Qed. End proof. diff --git a/heap_lang/proofmode.v b/heap_lang/proofmode.v index 6e0445d38abb5f17bbd630f91ff2b4a56f4f0ba6..08ae37f7937daff6827f3c9131907f60fb6bba34 100644 --- a/heap_lang/proofmode.v +++ b/heap_lang/proofmode.v @@ -1,7 +1,7 @@ From iris.program_logic Require Export weakestpre. From iris.proofmode Require Import coq_tactics. From iris.proofmode Require Export tactics. -From iris.heap_lang Require Export wp_tactics heap. +From iris.heap_lang Require Export wp_tactics rules. Import uPred. Ltac wp_strip_later ::= iNext. diff --git a/heap_lang/lifting.v b/heap_lang/rules.v similarity index 58% rename from heap_lang/lifting.v rename to heap_lang/rules.v index e41c4dcf33f9ae2d83a9f31cb58bc5392a961213..efeb15ab3192efd43d1e40854b383c512725c32f 100644 --- a/heap_lang/lifting.v +++ b/heap_lang/rules.v @@ -1,4 +1,4 @@ -From iris.program_logic Require Export weakestpre. +From iris.program_logic Require Export weakestpre gen_heap. From iris.program_logic Require Import ectx_lifting. From iris.heap_lang Require Export lang. From iris.heap_lang Require Import tactics. @@ -6,6 +6,25 @@ From iris.proofmode Require Import tactics. From iris.prelude Require Import fin_maps. Import uPred. +Class heapG Σ := HeapG { + heapG_invG : invG Σ; + heapG_gen_heapG :> gen_heapG loc val Σ +}. + +Instance heapG_irisG `{heapG Σ} : irisG heap_lang Σ := { + iris_invG := heapG_invG; + state_interp := gen_heap_ctx +}. + +(** Override the notations so that scopes and coercions work out *) +Notation "l ↦{ q } v" := (mapsto (L:=loc) (V:=val) l q v%V) + (at level 20, q at level 50, format "l ↦{ q } v") : uPred_scope. +Notation "l ↦ v" := + (mapsto (L:=loc) (V:=val) l 1 v%V) (at level 20) : uPred_scope. +Notation "l ↦{ q } -" := (∃ v, l ↦{q} v)%I + (at level 20, q at level 50, format "l ↦{ q } -") : uPred_scope. +Notation "l ↦ -" := (l ↦{1} -)%I (at level 20) : uPred_scope. + (** The tactic [inv_head_step] performs inversion on hypotheses of the shape [head_step]. The tactic will discharge head-reductions starting from values, and simplifies hypothesis related to conversions from and to values, and finite map @@ -15,6 +34,8 @@ Ltac inv_head_step := repeat match goal with | _ => progress simplify_map_eq/= (* simplify memory stuff *) | H : to_val _ = Some _ |- _ => apply of_to_val in H + | H : _ = of_val ?v |- _ => + is_var v; destruct v; first[discriminate H|injection H as H] | H : head_step ?e _ _ _ _ |- _ => try (is_var e; fail 1); (* inversion yields many goals if [e] is a variable and can thus better be avoided. *) @@ -28,8 +49,8 @@ Local Hint Constructors head_step. Local Hint Resolve alloc_fresh. Local Hint Resolve to_of_val. -Section lifting. -Context `{irisG heap_lang Σ}. +Section rules. +Context `{heapG Σ}. Implicit Types P Q : iProp Σ. Implicit Types Φ : val → iProp Σ. Implicit Types efs : list expr. @@ -134,4 +155,63 @@ Proof. rewrite -(wp_lift_pure_det_head_step_no_fork (Case _ _ _) (App e2 e0)); eauto. intros; inv_head_step; eauto. Qed. -End lifting. + +(** Heap *) +Lemma wp_alloc E e v : + to_val e = Some v → + {{{ True }}} Alloc e @ E {{{ l, RET LitV (LitLoc l); l ↦ v }}}. +Proof. + iIntros (<-%of_to_val Φ) "HΦ". iApply wp_lift_atomic_head_step_no_fork; auto. + iIntros (σ1) "Hσ !>"; iSplit; first by auto. + iNext; iIntros (v2 σ2 efs Hstep); inv_head_step. + iMod (@gen_heap_alloc with "Hσ") as "[Hσ Hl]"; first done. + iModIntro; iSplit=> //. iFrame. by iApply "HΦ". +Qed. + +Lemma wp_load E l q v : + {{{ â–· l ↦{q} v }}} Load (Lit (LitLoc l)) @ E {{{ RET v; l ↦{q} v }}}. +Proof. + iIntros (Φ) ">Hl HΦ". iApply wp_lift_atomic_head_step_no_fork; auto. + iIntros (σ1) "Hσ !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?. + iSplit; first by eauto. + iNext; iIntros (v2 σ2 efs Hstep); inv_head_step. + iModIntro; iSplit=> //. iFrame. by iApply "HΦ". +Qed. + +Lemma wp_store E l v' e v : + to_val e = Some v → + {{{ â–· l ↦ v' }}} Store (Lit (LitLoc l)) e @ E {{{ RET LitV LitUnit; l ↦ v }}}. +Proof. + iIntros (<-%of_to_val Φ) ">Hl HΦ". + iApply wp_lift_atomic_head_step_no_fork; auto. + iIntros (σ1) "Hσ !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?. + iSplit; first by eauto. iNext; iIntros (v2 σ2 efs Hstep); inv_head_step. + iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]". + iModIntro. iSplit=>//. by iApply "HΦ". +Qed. + +Lemma wp_cas_fail E l q v' e1 v1 e2 v2 : + to_val e1 = Some v1 → to_val e2 = Some v2 → v' ≠v1 → + {{{ â–· l ↦{q} v' }}} CAS (Lit (LitLoc l)) e1 e2 @ E + {{{ RET LitV (LitBool false); l ↦{q} v' }}}. +Proof. + iIntros (<-%of_to_val <-%of_to_val ? Φ) ">Hl HΦ". + iApply wp_lift_atomic_head_step_no_fork; auto. + iIntros (σ1) "Hσ !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?. + iSplit; first by eauto. iNext; iIntros (v2' σ2 efs Hstep); inv_head_step. + iModIntro; iSplit=> //. iFrame. by iApply "HΦ". +Qed. + +Lemma wp_cas_suc E l e1 v1 e2 v2 : + to_val e1 = Some v1 → to_val e2 = Some v2 → + {{{ â–· l ↦ v1 }}} CAS (Lit (LitLoc l)) e1 e2 @ E + {{{ RET LitV (LitBool true); l ↦ v2 }}}. +Proof. + iIntros (<-%of_to_val <-%of_to_val Φ) ">Hl HΦ". + iApply wp_lift_atomic_head_step_no_fork; auto. + iIntros (σ1) "Hσ !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?. + iSplit; first by eauto. iNext; iIntros (v2' σ2 efs Hstep); inv_head_step. + iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]". + iModIntro. iSplit=>//. by iApply "HΦ". +Qed. +End rules. diff --git a/program_logic/gen_heap.v b/program_logic/gen_heap.v new file mode 100644 index 0000000000000000000000000000000000000000..1d80623a6a0ae258edd1a81552dfa3a3a35c812b --- /dev/null +++ b/program_logic/gen_heap.v @@ -0,0 +1,145 @@ +From iris.algebra Require Import auth gmap frac dec_agree. +From iris.base_logic.lib Require Export own. +From iris.base_logic.lib Require Import fractional. +From iris.proofmode Require Import tactics. +Import uPred. + +Definition gen_heapUR (L V : Type) `{Countable L, EqDecision V} : ucmraT := + gmapUR L (prodR fracR (dec_agreeR V)). +Definition to_gen_heap `{Countable L, EqDecision V} : gmap L V → gen_heapUR L V := + fmap (λ v, (1%Qp, DecAgree v)). + +(** The CMRA we need. *) +Class gen_heapG (L V : Type) (Σ : gFunctors) + `{Countable L, EqDecision V} := GenHeapG { + gen_heap_inG :> inG Σ (authR (gen_heapUR L V)); + gen_heap_name : gname +}. + +Class gen_heapPreG (L V : Type) (Σ : gFunctors) `{Countable L, EqDecision V} := + { gen_heap_preG_inG :> inG Σ (authR (gen_heapUR L V)) }. + +Definition gen_heapΣ (L V : Type) `{Countable L, EqDecision V} : gFunctors := + #[GFunctor (constRF (authR (gen_heapUR L V)))]. + +Instance subG_gen_heapPreG {Σ} `{Countable L, EqDecision V} : + subG (gen_heapΣ L V) Σ → gen_heapPreG L V Σ. +Proof. intros ?%subG_inG; split; apply _. Qed. + +Section definitions. + Context `{gen_heapG L V Σ}. + + Definition gen_heap_ctx (σ : gmap L V) : iProp Σ := + own gen_heap_name (â— to_gen_heap σ). + + Definition mapsto_def (l : L) (q : Qp) (v: V) : iProp Σ := + own gen_heap_name (â—¯ {[ l := (q, DecAgree v) ]}). + Definition mapsto_aux : { x | x = @mapsto_def }. by eexists. Qed. + Definition mapsto := proj1_sig mapsto_aux. + Definition mapsto_eq : @mapsto = @mapsto_def := proj2_sig mapsto_aux. +End definitions. + +Local Notation "l ↦{ q } v" := (mapsto l q v) + (at level 20, q at level 50, format "l ↦{ q } v") : uPred_scope. +Local Notation "l ↦ v" := (mapsto l 1 v) (at level 20) : uPred_scope. + +Local Notation "l ↦{ q } -" := (∃ v, l ↦{q} v)%I + (at level 20, q at level 50, format "l ↦{ q } -") : uPred_scope. +Local Notation "l ↦ -" := (l ↦{1} -)%I (at level 20) : uPred_scope. + +Section gen_heap. + Context `{gen_heapG L V Σ}. + Implicit Types P Q : iProp Σ. + Implicit Types Φ : V → iProp Σ. + Implicit Types σ : gmap L V. + Implicit Types h g : gen_heapUR L V. + + (** Conversion to heaps and back *) + Lemma to_gen_heap_valid σ : ✓ to_gen_heap σ. + Proof. intros l. rewrite lookup_fmap. by case (σ !! l). Qed. + Lemma lookup_to_gen_heap_None σ l : σ !! l = None → to_gen_heap σ !! l = None. + Proof. by rewrite /to_gen_heap lookup_fmap=> ->. Qed. + Lemma gen_heap_singleton_included σ l q v : + {[l := (q, DecAgree v)]} ≼ to_gen_heap σ → σ !! l = Some v. + Proof. + rewrite singleton_included=> -[[q' av] [/leibniz_equiv_iff Hl Hqv]]. + move: Hl. rewrite /to_gen_heap lookup_fmap fmap_Some=> -[v' [Hl [??]]]; subst. + by move: Hqv=> /Some_pair_included_total_2 [_ /DecAgree_included ->]. + Qed. + Lemma to_gen_heap_insert l v σ : + to_gen_heap (<[l:=v]> σ) = <[l:=(1%Qp, DecAgree v)]> (to_gen_heap σ). + Proof. by rewrite /to_gen_heap fmap_insert. Qed. + + (** General properties of mapsto *) + Global Instance mapsto_timeless l q v : TimelessP (l ↦{q} v). + Proof. rewrite mapsto_eq /mapsto_def. apply _. Qed. + Global Instance mapsto_fractional l v : Fractional (λ q, l ↦{q} v)%I. + Proof. + intros p q. by rewrite mapsto_eq -own_op -auth_frag_op + op_singleton pair_op dec_agree_idemp. + Qed. + Global Instance mapsto_as_fractional l q v : + AsFractional (l ↦{q} v) (λ q, l ↦{q} v)%I q. + Proof. done. Qed. + + Lemma mapsto_agree l q1 q2 v1 v2 : l ↦{q1} v1 ∗ l ↦{q2} v2 ⊢ ⌜v1 = v2âŒ. + Proof. + rewrite mapsto_eq -own_op -auth_frag_op own_valid discrete_valid. + f_equiv=> /auth_own_valid /=. rewrite op_singleton singleton_valid pair_op. + by move=> [_ /= /dec_agree_op_inv [?]]. + Qed. + + Global Instance heap_ex_mapsto_fractional l : Fractional (λ q, l ↦{q} -)%I. + Proof. + intros p q. iSplit. + - iDestruct 1 as (v) "[H1 H2]". iSplitL "H1"; eauto. + - iIntros "[H1 H2]". iDestruct "H1" as (v1) "H1". iDestruct "H2" as (v2) "H2". + iDestruct (mapsto_agree with "[$H1 $H2]") as %->. iExists v2. by iFrame. + Qed. + Global Instance heap_ex_mapsto_as_fractional l q : + AsFractional (l ↦{q} -) (λ q, l ↦{q} -)%I q. + Proof. done. Qed. + + Lemma mapsto_valid l q v : l ↦{q} v ⊢ ✓ q. + Proof. + rewrite mapsto_eq /mapsto_def own_valid !discrete_valid. + by apply pure_mono=> /auth_own_valid /singleton_valid [??]. + Qed. + Lemma mapsto_valid_2 l q1 q2 v1 v2 : + l ↦{q1} v1 ∗ l ↦{q2} v2 ⊢ ✓ (q1 + q2)%Qp. + Proof. + iIntros "[H1 H2]". iDestruct (mapsto_agree with "[$H1 $H2]") as %->. + iApply (mapsto_valid l _ v2). by iFrame. + Qed. + + Lemma gen_heap_alloc σ l v : + σ !! l = None → gen_heap_ctx σ ==∗ gen_heap_ctx (<[l:=v]>σ) ∗ l ↦ v. + Proof. + iIntros (?) "Hσ". rewrite /gen_heap_ctx mapsto_eq /mapsto_def. + iMod (own_update with "Hσ") as "[Hσ Hl]". + { eapply auth_update_alloc, + (alloc_singleton_local_update _ _ (1%Qp, DecAgree v))=> //. + by apply lookup_to_gen_heap_None. } + iModIntro. rewrite to_gen_heap_insert. iFrame. + Qed. + + Lemma gen_heap_valid σ l q v : gen_heap_ctx σ -∗ l ↦{q} v -∗ ⌜σ !! l = Some vâŒ. + Proof. + iIntros "Hσ Hl". rewrite /gen_heap_ctx mapsto_eq /mapsto_def. + iDestruct (own_valid_2 with "Hσ Hl") + as %[Hl%gen_heap_singleton_included _]%auth_valid_discrete_2; auto. + Qed. + + Lemma gen_heap_update σ l v1 v2 : + gen_heap_ctx σ -∗ l ↦ v1 ==∗ gen_heap_ctx (<[l:=v2]>σ) ∗ l ↦ v2. + Proof. + iIntros "Hσ Hl". rewrite /gen_heap_ctx mapsto_eq /mapsto_def. + iDestruct (own_valid_2 with "Hσ Hl") + as %[Hl%gen_heap_singleton_included _]%auth_valid_discrete_2. + iMod (own_update_2 with "Hσ Hl") as "[Hσ Hl]". + { eapply auth_update, singleton_local_update, + (exclusive_local_update _ (1%Qp, DecAgree v2))=> //. + by rewrite /to_gen_heap lookup_fmap Hl. } + iModIntro. rewrite to_gen_heap_insert. iFrame. + Qed. +End gen_heap.