From 792a63bcefb0134b07711dd06933c58b11509a4b Mon Sep 17 00:00:00 2001
From: Simon Spies <simonspies@icloud.com>
Date: Fri, 9 Sep 2022 15:04:16 +0200
Subject: [PATCH] remove examples and instances
---
theories/examples/counterexamples.v | 227 --
.../keyideas/generalized_simulations.v | 147 --
theories/examples/keyideas/simulations.v | 129 --
theories/examples/refinements/derived.v | 124 --
theories/examples/refinements/memoization.v | 1914 -----------------
theories/examples/refinements/refinement.v | 842 --------
theories/examples/safety/assert.v | 28 -
theories/examples/safety/barrier/barrier.v | 7 -
.../examples/safety/barrier/example_client.v | 73 -
theories/examples/safety/barrier/proof.v | 187 --
.../examples/safety/barrier/specification.v | 30 -
theories/examples/safety/clairvoyant_coin.v | 84 -
theories/examples/safety/counter.v | 173 --
theories/examples/safety/lazy_coin.v | 68 -
theories/examples/safety/lock.v | 39 -
theories/examples/safety/nondet_bool.v | 25 -
theories/examples/safety/par.v | 46 -
theories/examples/safety/spawn.v | 78 -
theories/examples/safety/spin_lock.v | 100 -
theories/examples/safety/ticket_lock.v | 167 --
theories/examples/termination/adequacy.v | 67 -
theories/examples/termination/eventloop.v | 211 --
theories/examples/termination/logrel.v | 931 --------
theories/examples/termination/thunk.v | 139 --
theories/examples/transfinite.v | 150 --
theories/heap_lang/adequacy.v | 38 -
theories/heap_lang/lang.v | 769 -------
theories/heap_lang/lifting.v | 1349 ------------
theories/heap_lang/locations.v | 45 -
theories/heap_lang/metatheory.v | 224 --
theories/heap_lang/notation.v | 162 --
theories/heap_lang/proofmode.v | 1007 ---------
theories/heap_lang/tactics.v | 53 -
theories/program_logic/adequacy.v | 283 ---
theories/program_logic/ectx_language.v | 265 ---
theories/program_logic/ectx_lifting.v | 178 --
theories/program_logic/ectxi_language.v | 156 --
theories/program_logic/hoare.v | 162 --
theories/program_logic/language.v | 234 --
theories/program_logic/lifting.v | 281 ---
.../program_logic/refinement/ref_adequacy.v | 354 ---
.../refinement/ref_ectx_lifting.v | 201 --
.../program_logic/refinement/ref_lifting.v | 244 ---
.../program_logic/refinement/ref_source.v | 372 ----
.../program_logic/refinement/ref_weakestpre.v | 691 ------
.../program_logic/refinement/seq_weakestpre.v | 32 -
.../program_logic/refinement/tc_weakestpre.v | 103 -
theories/program_logic/weakestpre.v | 723 -------
48 files changed, 13912 deletions(-)
delete mode 100644 theories/examples/counterexamples.v
delete mode 100644 theories/examples/keyideas/generalized_simulations.v
delete mode 100644 theories/examples/keyideas/simulations.v
delete mode 100644 theories/examples/refinements/derived.v
delete mode 100644 theories/examples/refinements/memoization.v
delete mode 100644 theories/examples/refinements/refinement.v
delete mode 100644 theories/examples/safety/assert.v
delete mode 100644 theories/examples/safety/barrier/barrier.v
delete mode 100644 theories/examples/safety/barrier/example_client.v
delete mode 100644 theories/examples/safety/barrier/proof.v
delete mode 100644 theories/examples/safety/barrier/specification.v
delete mode 100644 theories/examples/safety/clairvoyant_coin.v
delete mode 100644 theories/examples/safety/counter.v
delete mode 100644 theories/examples/safety/lazy_coin.v
delete mode 100644 theories/examples/safety/lock.v
delete mode 100644 theories/examples/safety/nondet_bool.v
delete mode 100644 theories/examples/safety/par.v
delete mode 100644 theories/examples/safety/spawn.v
delete mode 100644 theories/examples/safety/spin_lock.v
delete mode 100644 theories/examples/safety/ticket_lock.v
delete mode 100644 theories/examples/termination/adequacy.v
delete mode 100644 theories/examples/termination/eventloop.v
delete mode 100644 theories/examples/termination/logrel.v
delete mode 100644 theories/examples/termination/thunk.v
delete mode 100644 theories/examples/transfinite.v
delete mode 100644 theories/heap_lang/adequacy.v
delete mode 100644 theories/heap_lang/lang.v
delete mode 100644 theories/heap_lang/lifting.v
delete mode 100644 theories/heap_lang/locations.v
delete mode 100644 theories/heap_lang/metatheory.v
delete mode 100644 theories/heap_lang/notation.v
delete mode 100644 theories/heap_lang/proofmode.v
delete mode 100644 theories/heap_lang/tactics.v
delete mode 100644 theories/program_logic/adequacy.v
delete mode 100644 theories/program_logic/ectx_language.v
delete mode 100644 theories/program_logic/ectx_lifting.v
delete mode 100644 theories/program_logic/ectxi_language.v
delete mode 100644 theories/program_logic/hoare.v
delete mode 100644 theories/program_logic/language.v
delete mode 100644 theories/program_logic/lifting.v
delete mode 100644 theories/program_logic/refinement/ref_adequacy.v
delete mode 100644 theories/program_logic/refinement/ref_ectx_lifting.v
delete mode 100644 theories/program_logic/refinement/ref_lifting.v
delete mode 100644 theories/program_logic/refinement/ref_source.v
delete mode 100644 theories/program_logic/refinement/ref_weakestpre.v
delete mode 100644 theories/program_logic/refinement/seq_weakestpre.v
delete mode 100644 theories/program_logic/refinement/tc_weakestpre.v
delete mode 100644 theories/program_logic/weakestpre.v
diff --git a/theories/examples/counterexamples.v b/theories/examples/counterexamples.v
deleted file mode 100644
index 9003e3f1..00000000
--- a/theories/examples/counterexamples.v
+++ /dev/null
@@ -1,227 +0,0 @@
-From iris.algebra Require Import base stepindex.
-
-(** counter-examples for existential properties *)
-Section existential_negative.
- (* Transfinite step-index types cannot validate the bounded existential property. *)
- Context {SI : indexT}.
- Record sProp :=
- {
- prop : SI → Prop;
- prop_downclosed : ∀ α β, α ≺ β → prop β → prop α
- }.
- Program Definition sProp_later (P : sProp) := Build_sProp (λ γ, ∀ γ', γ' ≺ γ → prop P γ') _.
- Next Obligation.
- intros [P Pdown] α β Hα. cbn. eauto with index.
- Qed.
- Program Definition sProp_false := Build_sProp (λ _, False) _.
- Next Obligation. intros. assumption. Qed.
-
- Program Definition sProp_ex {X} (Φ : X → sProp) := Build_sProp (λ α, ∃ x, prop (Φ x) α) _.
- Next Obligation.
- intros X Φ α β Hα. cbn. intros [x H]. exists x. by eapply prop_downclosed.
- Qed.
-
- Definition bounded_existential (X : Type) (Φ : X → sProp) α:=
- (∀ β, β ≺ α → ∃ x : X, prop (Φ x) β)
- → ∃ x : X, ∀ β, β ≺ α → prop (Φ x) β.
- Definition existential (X : Type) (Φ : X → sProp) :=
- (∀ α, ∃ x : X, prop (Φ x) α)
- → ∃ x : X, ∀ α, prop (Φ x) α.
-
- Section transfinite.
- Hypothesis (ω: SI).
- Hypothesis (is_limit_of_nat: ∀ n, Nat.iter n (index_succ SI) zero ≺ ω).
- Hypothesis (is_smallest: ∀ α, α ≺ ω → ∃ n, α = Nat.iter n (index_succ SI) zero).
-
- Lemma transfinite_no_bounded_existential :
- bounded_existential nat (λ n, Nat.iter n sProp_later sProp_false) ω → False.
- Proof.
- intros H. unfold bounded_existential in H. edestruct H as [n H'].
- { intros β Hβ. apply is_smallest in Hβ as (n & ->). exists (S n).
- induction n as [ | n IH].
- - intros ? []%index_lt_zero_is_normal.
- - intros α Hα. apply index_succ_iff in Hα as [ -> | Hα]. now apply IH.
- intros β Hβ. apply IH. eauto with index.
- }
- specialize (H' (Nat.iter n (index_succ SI) zero) ltac:(apply is_limit_of_nat)).
- induction n as [ | n IH]; cbn in H'. exact H'.
- apply IH. apply H'. apply index_succ_greater.
- Qed.
- End transfinite.
-End existential_negative.
-
-Section no_later_exists.
-(** A step-indexed logic cannot have
- * a sound later-operation,
- * Löb induction
- * Commutation of later with existentials: ▷ (∃ x. P) ⊢ ▷ False ∨ ∃ x. ▷ P
- * the existential property for countable types, if ⊢ ∃ n : nat. P n, then there is n : nat such that ⊢ P n.
-*)
-
- Context
- (PROP : Type) (* the type of propositions *)
- (entail : PROP → PROP → Prop) (* the entailment relation *)
- (TRUE : PROP) (* the true proposition *)
- (FALSE : PROP) (* the false proposition *)
- (later : PROP → PROP) (* the later modality *)
- (ex : (nat → PROP) → PROP). (* for simplicity, we restrict to predicates over nat here since we don't need more for the proof *)
-
- Implicit Types (P Q: PROP).
-
- Notation "▷ P" := (later P) (at level 20).
- Notation "P ⊢ Q" := (entail P Q) (at level 60).
- Notation "⊢ P" := (entail TRUE P) (at level 60).
-
- (* standard structural rules *)
- Context
- (cut : ∀ P Q R, P ⊢ Q → Q ⊢ R → P ⊢ R)
- (assumption : ∀ P, P ⊢ P)
- (ex_intro : ∀ P Φ, (∃ n, P ⊢ Φ n) → P ⊢ ex Φ)
- (ex_elim : ∀ P Φ, (∀ n, Φ n ⊢ P) → ex Φ ⊢ P).
-
-
- (* relevant assumptions about our step-indexed logic *)
- Context
- (logic_sound: ¬ ⊢ FALSE)
- (later_sound: ∀ P, ⊢ ▷ P → ⊢ P) (* later is sound *)
- (existential : ∀ (Φ : nat → PROP), (⊢ ex Φ) → ∃ n, ⊢ (Φ n)) (* the existential property for nat *)
- (Löb : ∀ P, (▷ P ⊢ P) → ⊢ P). (* Löb induction *)
-
- (* now later commuting with existentials is contradictory *)
- Lemma no_later_existential_commuting :
- (∀ Φ, ▷ (ex Φ) ⊢ (ex (λ n, ▷ (Φ n))) )
- → False.
- Proof.
- intros Hcomm. apply logic_sound.
- assert (∃ n, ⊢ Nat.iter n later FALSE) as [ n Hf].
- { apply existential.
- apply Löb.
- eapply cut. apply Hcomm.
- apply ex_elim.
- intros n. apply ex_intro. exists (S n). apply assumption.
- }
- induction n as [ | n IH].
- exact Hf.
- apply IH. apply later_sound, Hf.
- Qed.
-End no_later_exists.
-
-
-From iris.algebra Require Export cmra updates.
-From iris.base_logic Require Import upred.
-From iris.bi Require Import notation.
-Section more_counterexamples.
- Context {I: indexT} {M : ucmraT I}.
- Implicit Types φ : Prop.
- Implicit Types P Q : uPred M.
- Implicit Types A : Type.
- Arguments uPred_holds {_ _} !_ _ _ /.
- Hint Immediate uPred_in_entails : core.
-
- Notation "P ⊢ Q" := (@uPred_entails I M P%I Q%I) : stdpp_scope.
- Notation "(⊢)" := (@uPred_entails I M) (only parsing) : stdpp_scope.
- Notation "P ⊣⊢ Q" := (@uPred_equiv I M P%I Q%I) : stdpp_scope.
- Notation "(⊣⊢)" := (@uPred_equiv I M) (only parsing) : stdpp_scope.
-
- Notation "'True'" := (uPred_pure True) : bi_scope.
- Notation "'False'" := (uPred_pure False) : bi_scope.
- Notation "'⌜' φ '⌝'" := (uPred_pure φ%type%stdpp) : bi_scope.
- Infix "∧" := uPred_and : bi_scope.
- Infix "∨" := uPred_or : bi_scope.
- Infix "→" := uPred_impl : bi_scope.
- Notation "∀ x .. y , P" :=
- (uPred_forall (λ x, .. (uPred_forall (λ y, P)) ..)) : bi_scope.
- Notation "∃ x .. y , P" :=
- (uPred_exist (λ x, .. (uPred_exist (λ y, P)) ..)) : bi_scope.
- Infix "∗" := uPred_sep : bi_scope.
- Infix "-∗" := uPred_wand : bi_scope.
- Notation "□ P" := (uPred_persistently P) : bi_scope.
- Notation "■ P" := (uPred_plainly P) : bi_scope.
- Notation "x ≡ y" := (uPred_internal_eq x y) : bi_scope.
- Notation "▷ P" := (uPred_later P) : bi_scope.
- Notation "|==> P" := (uPred_bupd P) : bi_scope.
- Notation "▷^ n P" := (Nat.iter n uPred_later P) : bi_scope.
- Notation "▷? p P" := (Nat.iter (Nat.b2n p) uPred_later P) : bi_scope.
- Notation "⧍ P" := (∃ n, ▷^n P)%I : bi_scope.
- Notation "⧍^ n P" := (Nat.iter n (λ Q, ⧍ Q) P)%I : bi_scope.
-
- Import uPred_primitive.
-
- Section bounded_limit_preserving_counterexample.
-
- Definition F (P: uPred M) : uPred M := P.
- Definition G (P: uPred M) : uPred M := (∃ n, ▷^n False)%I.
- Definition c {α: I} : bchain (uPredO M) α := bchain_const (∃ n, ▷^n False)%I α.
-
- Hypothesis (omega: I).
- Hypothesis (is_limit_of_nat: ∀ n, Nat.iter n (index_succ I) zero ≺ omega).
- Hypothesis (is_smallest: ∀ α, α ≺ omega → ∃ n, α = Nat.iter n (index_succ I) zero).
-
- Notation "'ω'" := omega.
- Lemma zero_omega: zero ≺ ω.
- Proof using I is_limit_of_nat omega. eapply (is_limit_of_nat 0). Qed.
-
- Lemma bounded_limit_preserving_entails_counterexample:
- ¬ BoundedLimitPreserving (λ P, F P ⊢ G P).
- Proof using I M is_limit_of_nat is_smallest omega.
- intros H. specialize (H ω zero_omega c); simpl in H.
- assert (∀ β : I, β ≺ ω → F (⧍ ⌜False⌝) ⊢ G (⧍ ⌜False⌝)) as H'.
- { intros ??. destruct (entails_po (I:=I) (M:=M)) as [R _]. apply R. }
- specialize (H H'). destruct H as [H].
- specialize (H ω ε (ucmra_unit_validN ω)).
- unfold F in *. assert (bcompl zero_omega c ω ε) as H''.
- { eapply bcompl_unfold. unfold c; simpl.
- intros n' Hn' _ Hv. eapply is_smallest in Hn'.
- destruct Hn' as [m ->]. unseal.
- exists (S m). clear Hv H' H. induction m; cbn.
- - intros ? [] % index_lt_zero_is_normal.
- - intros n' Hn' n'' Hn''. eapply uPred_mono.
- eapply IHm; eauto.
- eapply index_lt_le_trans. eapply Hn''.
- eapply index_succ_iff, Hn'.
- all: eauto.
- }
- specialize (H H''). unfold G in *.
- revert H; unseal. intros [n].
- eapply uPred_mono with (n2 := (Nat.iter (S n) (index_succ I) zero)) in H; eauto.
- clear H' H''. induction n; simpl in *; eauto.
- Qed.
-
- End bounded_limit_preserving_counterexample.
-
- Section ne_does_not_preserve_limits.
- (* we show that, in general, non-expansive maps do not preserve limits. *)
-
- Program Definition f : uPredO M -n> uPredO M := λne P, (P ∧ ∃ n, ▷^n False)%I.
- Next Obligation.
- intros α x y Heq. apply and_ne. apply Heq. reflexivity.
- Qed.
- Definition c0 {α: I} : bchain (uPredO M) α := bchain_const (True)%I α.
-
- Hypothesis (omega: I).
- Hypothesis (is_limit_of_nat: ∀ n, Nat.iter n (index_succ I) zero ≺ omega).
- Hypothesis (is_smallest: ∀ α, α ≺ omega → ∃ n, α = Nat.iter n (index_succ I) zero).
-
-
- Notation "'ω'" := omega.
- Lemma zero_omega': zero ≺ ω.
- Proof using I is_limit_of_nat omega. eapply (is_limit_of_nat 0). Qed.
-
- Lemma test : ¬ (f (bcompl zero_omega' c0) ≡ bcompl zero_omega' (bchain_map f c0)).
- Proof using is_smallest.
- intros Heq. destruct Heq as [Heq]. specialize (Heq omega ε (ucmra_unit_validN _)).
- cbn in Heq. destruct Heq as [_ H1].
- revert H1. rewrite !bcompl_unfold; cbn. unseal. intros H. destruct H as [ _ H].
- 2: { destruct H as [n H]. eapply uPred_mono with (n2 := Nat.iter (S n) (index_succ I) zero) in H; eauto.
- induction n as [ | n IH]; cbn in H; [tauto | ].
- eapply IH. apply H. eapply index_succ_greater.
- }
- intros. split; [easy | ]. apply is_smallest in Hn' as [nn ->]. exists (S nn).
- clear H0 H. induction nn as [ | n IH]; cbn.
- - intros ? []%index_lt_zero_is_normal.
- - intros n' Hn' n'' Hn''. apply IH. eapply index_lt_le_trans.
- exact Hn''. apply index_succ_iff, Hn'.
- Qed.
- End ne_does_not_preserve_limits.
-
-End more_counterexamples.
diff --git a/theories/examples/keyideas/generalized_simulations.v b/theories/examples/keyideas/generalized_simulations.v
deleted file mode 100644
index 623475e5..00000000
--- a/theories/examples/keyideas/generalized_simulations.v
+++ /dev/null
@@ -1,147 +0,0 @@
-From iris.base_logic Require Export iprop satisfiable.
-From iris.bi Require Export fixpoint.
-From iris.proofmode Require Import tactics.
-
-
-Section simulations.
-
- Context {SI} `{LargeIndex SI} {Σ: gFunctors SI}.
-
-
- (* We assume a source and a target language *)
- Variable (S T: Type) (src_step: S → S → Prop) (tgt_step: T → T → Prop).
- Variable (V: Type) (val_to_tgt: V → T) (φ: V → S → Prop).
- Variable (val_irred: ∀ v, ¬ ∃ t', tgt_step (val_to_tgt v) t') (val_inj: Inj eq eq val_to_tgt).
-
-
- (* refinements *)
- Definition gtpr (t: T) (s: S) :=
- (∀ v, rtc tgt_step t (val_to_tgt v) → ∃ s', rtc src_step s s' ∧ φ v s') ∧
- (ex_loop tgt_step t → ex_loop src_step s).
-
-
- Notation "S *d T" := (prodO (leibnizO SI T) (leibnizO SI S)) (at level 60).
- Definition gsim_pre (sim: ((S *d T) → iProp Σ)) : (S *d T) → iProp Σ :=
- (λ '(t, s),
- (∃ v, ⌜φ v s⌝ ∧ ⌜val_to_tgt v = t⌝) ∨
- (∃ t', ⌜tgt_step t t'⌝) ∧
- (∀ t', ⌜tgt_step t t'⌝ → sim (t', s) ∨ ∃ s', ⌜src_step s s'⌝ ∧ ▷ sim (t', s'))
- )%I.
-
- Instance gsim_pre_mono: BiMonoPred gsim_pre.
- Proof.
- split.
- - intros Φ Ψ. iIntros "#H" ([t s]).
- rewrite /gsim_pre.
- iIntros "[Hsim|Hsim]"; eauto.
- iRight. iDestruct "Hsim" as "[Hsteps Hsim]".
- iSplit; eauto.
- iIntros (t' Htgt). iDestruct ("Hsim" $! t' Htgt) as "[Hsim|Hsim]".
- + iLeft. by iApply "H".
- + iRight. iDestruct "Hsim" as (s' Hsrc) "Hsim".
- iExists s'. iSplit; eauto. iNext. by iApply "H".
- - intros Φ Hdist α [t s] [t' s'] [Heq1 Heq2]; simpl in *.
- repeat f_equiv; eauto.
- Qed.
-
- Definition gsim := bi_least_fixpoint gsim_pre.
-
- Lemma sim_unfold t s:
- (gsim (t, s) ⊣⊢ (∃ v, ⌜φ v s⌝ ∧ ⌜val_to_tgt v = t⌝) ∨
- (∃ t', ⌜tgt_step t t'⌝) ∧
- (∀ t', ⌜tgt_step t t'⌝ → gsim (t', s) ∨ ∃ s', ⌜src_step s s'⌝ ∧ ▷ gsim (t', s')))%I.
- Proof.
- fold (gsim_pre gsim (t, s)). iSplit.
- - iApply least_fixpoint_unfold_1.
- - iApply least_fixpoint_unfold_2.
- Qed.
-
-
- Lemma satisfiable_pure ψ: satisfiable (⌜ψ⌝: iProp Σ)%I → ψ.
- Proof.
- intros Hsat. apply satisfiable_elim in Hsat; last apply _.
- by apply uPred.pure_soundness in Hsat.
- Qed.
-
- (* result preserving *)
- Lemma gsim_execute_tgt_step t s t':
- tgt_step t t' → satisfiable (gsim (t, s)) → ∃ s', rtc src_step s s' ∧ satisfiable (gsim (t', s')).
- Proof.
- intros Hstep Hsat.
- eapply satisfiable_mono with (Q := (∃ s', ⌜rtc src_step s s'⌝ ∧ ▷ gsim (t', s'))%I) in Hsat.
- - eapply satisfiable_exists in Hsat as [s' Hsat].
- exists s'. split.
- + eapply satisfiable_pure, satisfiable_mono; eauto. iIntros "[$ _]".
- + eapply satisfiable_later, satisfiable_mono; eauto. iIntros "[_ $]".
- - iIntros "Hsim". rewrite sim_unfold. iDestruct "Hsim" as "[Hsim|[_ Hsim]]".
- + iDestruct "Hsim" as (v) "[_ <-]". exfalso. naive_solver.
- + iDestruct ("Hsim" $! t' Hstep) as "[Hsim|Hsim]".
- * iExists s. iSplit; first by iPureIntro. by iNext.
- * iDestruct "Hsim" as (s' Hstep') "Hsim". iExists s'. iSplit; eauto.
- iPureIntro. by eapply rtc_l.
- Qed.
-
- Lemma sim_execute_tgt t s t':
- rtc tgt_step t t' → satisfiable (gsim (t, s)) → ∃ s', rtc src_step s s' ∧ satisfiable (gsim (t', s')).
- Proof.
- induction 1 in s.
- - intros Hsim. exists s. by split.
- - intros Hsim. eapply gsim_execute_tgt_step in Hsim; last eauto.
- destruct Hsim as [s' [Hsrc Hsat]].
- destruct (IHrtc _ Hsat) as [s'' [Hsrc' Hsat']].
- exists s''. split; auto. by transitivity s'.
- Qed.
-
-
- (* termination preserving *)
- Lemma sim_execute_tgt_step t s:
- ex_loop tgt_step t → satisfiable (gsim (t, s)) → ∃ t' s', src_step s s' ∧ ex_loop tgt_step t' ∧ satisfiable (gsim (t', s')).
- Proof.
- intros Hsteps Hsat.
- eapply satisfiable_mono with (Q := (∃ t' s', ⌜src_step s s'⌝ ∧ ⌜ex_loop tgt_step t'⌝ ∧ ▷ gsim (t', s'))%I) in Hsat; last first.
- iPoseProof (@least_fixpoint_strong_ind _ _ _ gsim_pre _ (λ '(t, s), ⌜ex_loop tgt_step t⌝ → ∃ (t' : T) (s' : S), ⌜src_step s s'⌝ ∧ ⌜ex_loop tgt_step t'⌝ ∧ ▷ gsim (t', s'))%I) as "Hind".
- { intros ? [t'' s''] [t' s'] [Heq1 Heq2]; repeat f_equiv; eauto. }
- - iIntros "Hsim". iRevert (Hsteps). iRevert "Hsim". iSpecialize ("Hind" with "[]"); last iApply ("Hind" $! (t, s)).
- clear Hsat t s. iModIntro. iIntros ([t s]). iIntros "Hsim" (Hloop).
- rewrite /gsim_pre. iDestruct "Hsim" as "[Hsim|Hsim]".
- + iDestruct "Hsim" as (v) "[_ %]".
- destruct Hloop as [t t']; subst t. naive_solver.
- + iDestruct "Hsim" as "[_ Hsim]".
- inversion Hloop as [t'' t' Hstep Hloop']; subst t''.
- iDestruct ("Hsim" $! t' Hstep) as "[Hsim|Hsim]".
- * iDestruct "Hsim" as "[Hsim _]". by iSpecialize ("Hsim" $! Hloop').
- * iDestruct "Hsim" as (s' Hstep') "Hsim".
- iExists t', s'. repeat iSplit; eauto.
- iNext. iDestruct "Hsim" as "[_ $]".
- - eapply satisfiable_exists in Hsat as [t' Hsat].
- eapply satisfiable_exists in Hsat as [s' Hsat].
- exists t', s'. repeat split.
- + eapply satisfiable_pure, satisfiable_mono; eauto. iIntros "($ & _ & _)".
- + eapply satisfiable_pure, satisfiable_mono; eauto. iIntros "(_ & $ & _)".
- + eapply satisfiable_later, satisfiable_mono; eauto. iIntros "(_ & _ & $)".
- Qed.
-
- Lemma sim_divergence t s:
- ex_loop tgt_step t → satisfiable (gsim (t, s)) → ex_loop src_step s.
- Proof.
- revert t s. cofix IH. intros t s Hloop Hsat.
- edestruct sim_execute_tgt_step as (t' & s' & Hsrc & Hloop' & Hsim); [eauto..|].
- econstructor; eauto.
- Qed.
-
- Lemma sim_is_tpr t s: (⊢ gsim (t, s)) → gtpr t s.
- Proof.
- intros Hsim. split.
- - apply satisfiable_intro in Hsim. intros v Hsteps.
- eapply sim_execute_tgt in Hsteps as [s' [Hsteps' Hsat]]; eauto.
- enough (φ v s') by eauto.
- eapply satisfiable_pure, satisfiable_mono; eauto.
- rewrite sim_unfold. iIntros "[H|[H _]]".
- + iDestruct "H" as (v') "[% H]". by iDestruct "H" as %->%val_inj.
- + iDestruct "H" as (t') "%". exfalso. naive_solver.
- - intros Hloop. eapply sim_divergence; eauto.
- apply satisfiable_intro, Hsim.
- Qed.
-
-End simulations.
-
diff --git a/theories/examples/keyideas/simulations.v b/theories/examples/keyideas/simulations.v
deleted file mode 100644
index 35f5f9e3..00000000
--- a/theories/examples/keyideas/simulations.v
+++ /dev/null
@@ -1,129 +0,0 @@
-From iris.base_logic Require Export iprop satisfiable.
-From iris.bi Require Export fixpoint.
-From iris.proofmode Require Import tactics.
-
-
-Section simulations.
-
- Context {SI} `{LargeIndex SI} {Σ: gFunctors SI}.
-
-
- (* We assume a source and a target language *)
- Variable (S T: Type) (src_step: S → S → Prop) (tgt_step: T → T → Prop).
- Variable (V: Type) (val_to_src: V → S) (val_to_tgt: V → T).
- Variable (val_irred: ∀ v, ¬ ∃ t', tgt_step (val_to_tgt v) t') (val_inj: Inj eq eq val_to_tgt).
-
-
- (* refinements *)
- Definition rpr (t: T) (s: S) :=
- (∀ v, rtc tgt_step t (val_to_tgt v) → rtc src_step s (val_to_src v)).
-
- Definition tpr (t: T) (s: S) :=
- (∀ v, rtc tgt_step t (val_to_tgt v) → rtc src_step s (val_to_src v)) ∧
- (ex_loop tgt_step t → ex_loop src_step s).
-
- Definition sim_pre (sim: (T -d> S -d> iProp Σ)) : T -d> S -d> iProp Σ :=
- (λ t s,
- (∃ v, ⌜val_to_src v = s⌝ ∧ ⌜val_to_tgt v = t⌝) ∨
- (∃ t', ⌜tgt_step t t'⌝) ∧
- (∀ t', ⌜tgt_step t t'⌝ → ∃ s', ⌜src_step s s'⌝ ∧ ▷ sim t' s')
- )%I.
-
- Instance sim_pre_contr: Contractive sim_pre.
- Proof.
- intros a sim sim' Heq. unfold sim_pre.
- intros t s. do 8 f_equiv. apply bi.later_contractive.
- intros ??. by apply Heq.
- Qed.
-
-
- Definition sim := fixpoint sim_pre.
-
- Lemma sim_unfold':
- sim ≡ sim_pre sim.
- Proof. by rewrite {1}/sim fixpoint_unfold. Qed.
-
- Lemma sim_unfold t s:
- (sim t s ⊣⊢ ((∃ v, ⌜val_to_src v = s⌝ ∧ ⌜val_to_tgt v = t⌝) ∨
- (∃ t', ⌜tgt_step t t'⌝) ∧
- (∀ t', ⌜tgt_step t t'⌝ → ∃ s', ⌜src_step s s'⌝ ∧ ▷ sim t' s')))%I.
- Proof. apply sim_unfold'. Qed.
-
- Instance sim_plain t s: Plain (sim t s).
- Proof.
- unfold Plain. iRevert (t s). iLöb as "IH".
- iIntros (t s); rewrite sim_unfold.
- iIntros "[H1|[H1 H2]]".
- - iLeft. iApply (plain with "H1").
- - iRight. iSplit; first iApply (plain with "H1").
- iIntros (t' Hstep). iDestruct ("H2" $! t' Hstep) as (s' Hstep') "Hsim".
- iExists s'; iSplit; first (iApply plain; by iPureIntro).
- iApply later_plainly_1. iNext. by iApply "IH".
- Qed.
-
- Lemma sim_valid_satisfiable t s: satisfiable (sim t s) ↔ ⊢ sim t s.
- Proof.
- split.
- - intros ? % satisfiable_elim; eauto. apply _.
- - by intros ? % satisfiable_intro.
- Qed.
-
-
- Lemma satisfiable_pure φ: satisfiable (⌜φ⌝: iProp Σ)%I → φ.
- Proof.
- intros Hsat. apply satisfiable_elim in Hsat; last apply _.
- by apply uPred.pure_soundness in Hsat.
- Qed.
-
- (* result preserving *)
- Lemma sim_execute_tgt_step t s t':
- tgt_step t t' → satisfiable (sim t s) → ∃ s', src_step s s' ∧ satisfiable (sim t' s').
- Proof.
- intros Hstep Hsat.
- eapply satisfiable_mono with (Q := (∃ s', ⌜src_step s s'⌝ ∧ ▷ sim t' s')%I) in Hsat.
- - eapply satisfiable_exists in Hsat as [s' Hsat].
- exists s'. split.
- + eapply satisfiable_pure, satisfiable_mono; eauto. iIntros "[$ _]".
- + eapply satisfiable_later, satisfiable_mono; eauto. iIntros "[_ $]".
- - iIntros "Hsim". rewrite sim_unfold. iDestruct "Hsim" as "[Hsim|[_ Hsim]]".
- + iDestruct "Hsim" as (v) "[<- <-]". exfalso. naive_solver.
- + iApply ("Hsim" $! t' Hstep).
- Qed.
-
- Lemma sim_execute_tgt t s t':
- rtc tgt_step t t' → satisfiable (sim t s)
- → ∃ s', rtc src_step s s' ∧ satisfiable (sim t' s').
- Proof.
- induction 1 in s.
- - intros Hsim. exists s. by split.
- - intros Hsim. eapply sim_execute_tgt_step in Hsim; eauto.
- destruct Hsim as [s' [Hsrc Hsat]].
- destruct (IHrtc _ Hsat) as [s'' [Hsrc' Hsat']].
- exists s''. split; auto. by eapply rtc_l.
- Qed.
-
- (* Lemma 2.1 *)
- Lemma sim_is_rpr t s: (⊢ sim t s) → rpr t s.
- Proof.
- intros Hsim % sim_valid_satisfiable v Hsteps.
- eapply sim_execute_tgt in Hsteps as [s' [Hsteps' Hsat]]; eauto.
- enough (s' = (val_to_src v)) as -> by eauto.
- eapply satisfiable_pure, satisfiable_mono; eauto.
- rewrite sim_unfold. iIntros "[H|[H _]]".
- - iDestruct "H" as (v') "[<- H]". by iDestruct "H" as %->%val_inj.
- - iDestruct "H" as (t') "%". exfalso. naive_solver.
- Qed.
-
-
- (* Lemma 2.2 *)
- Lemma sim_is_tpr t s: (⊢ sim t s) → tpr t s.
- Proof.
- intros Hsim. split.
- - by apply sim_is_rpr.
- - apply sim_valid_satisfiable in Hsim. revert t s Hsim.
- cofix IH. intros t s Hsat. inversion 1 as [t'' t' Hstep Hloop]; subst t''.
- destruct (sim_execute_tgt_step _ _ _ Hstep Hsat) as [s' [Hstep' Hsat']].
- econstructor; eauto.
- Qed.
-End simulations.
-
diff --git a/theories/examples/refinements/derived.v b/theories/examples/refinements/derived.v
deleted file mode 100644
index 931dfa3b..00000000
--- a/theories/examples/refinements/derived.v
+++ /dev/null
@@ -1,124 +0,0 @@
-
-From iris.program_logic.refinement Require Export ref_weakestpre ref_adequacy seq_weakestpre.
-From iris.examples.refinements Require Export refinement.
-From iris.algebra Require Import auth.
-From iris.heap_lang Require Import proofmode notation.
-From iris.proofmode Require Import tactics.
-Set Default Proof Using "Type".
-
-
-(* We illustrate here how to derive the rules shown in the paper *)
-
-
-Section derived.
- Context {SI: indexT} `{Σ: gFunctors SI} `{!rheapG Σ} `{!auth_sourceG Σ (natA SI)} `{!seqG Σ}.
-
- Definition seq_rswp E e φ : iProp Σ := (na_own seqG_name E -∗ RSWP e at 0 ⟨⟨ v, na_own seqG_name E ∗ φ v ⟩⟩)%I.
- Notation "⟨⟨ P ⟩ ⟩ e ⟨⟨ v , Q ⟩ ⟩" := (□ (P -∗ (seq_rswp ⊤ e (λ v, Q))))%I
- (at level 20, P, e, Q at level 200, format "⟨⟨ P ⟩ ⟩ e ⟨⟨ v , Q ⟩ ⟩") : stdpp_scope.
- Notation "{{ P } } e {{ v , Q } }" := (□ (P -∗ SEQ e ⟨⟨ v, Q ⟩⟩))%I
- (at level 20, P, e, Q at level 200, format "{{ P } } e {{ v , Q } }") : stdpp_scope.
-
-
- Lemma Value (v: val): (⊢ {{True}} v {{w, ⌜v = w⌝}})%I.
- Proof.
- iIntros "!> _ $". by iApply rwp_value.
- Qed.
-
- Lemma Frame (e: expr) P R Q: ({{P}} e {{v, Q v}} ⊢ {{P ∗ R}} e {{v, Q v ∗ R}})%I.
- Proof.
- iIntros "#H !> [P $]". by iApply "H".
- Qed.
-
- Lemma Bind (e: expr) K P Q R:
- ({{P}} e {{v, Q v}} ∗ (∀ v: val, ({{Q v}} fill K (Val v) {{w, R w}}))
- ⊢ {{P}} fill K e {{v, R v}})%I.
- Proof.
- iIntros "[#H1 #H2] !> P Hna".
- iApply rwp_bind. iSpecialize ("H1" with "P Hna").
- iApply (rwp_strong_mono with "H1 []"); auto.
- iIntros (v) "[Hna Q] !>". iApply ("H2" with "Q Hna").
- Qed.
-
- Lemma Löb (P : iPropI Σ) : (▷ P → P) ⊢ P.
- Proof. iApply bi.löb. Qed.
-
- Lemma TPPureT (e e': expr) P Q: pure_step e e' → ({{P}} e' {{v, Q v}} ⊢ ⟨⟨P⟩⟩ e ⟨⟨v, Q v⟩⟩)%I.
- Proof.
- iIntros (Hstep) "#H !> P Hna".
- iApply (ref_lifting.rswp_pure_step_later _ _ _ _ _ True); [|done|by iApply ("H" with "P Hna")].
- intros _. apply nsteps_once, Hstep.
- Qed.
-
- Lemma TPPureS (e e' et: expr) K P Q:
- to_val et = None
- → pure_step e e'
- → (⟨⟨src (fill K e') ∗ P⟩⟩ et ⟨⟨v, Q v⟩⟩ ⊢ {{src (fill K e) ∗ ▷ P}} et {{v, Q v}})%I.
- Proof.
- iIntros (Hexp Hstep) "#H !> [Hsrc P] Hna". iApply (rwp_take_step with "[P Hna] [Hsrc]"); first done; last first.
- - iApply step_pure; last iApply "Hsrc". apply pure_step_ctx; last done. apply _.
- - iIntros "Hsrc'". iApply rswp_do_step. iNext. iApply ("H" with "[$P $Hsrc'] Hna").
- Qed.
-
- Lemma TPStoreT l (v1 v2: val): (True ⊢ ⟨⟨l ↦ v1⟩⟩ #l <- v2 ⟨⟨w, ⌜w = #()⌝ ∗ l ↦ v2⟩⟩)%I.
- Proof.
- iIntros "_ !> Hl $". iApply (rswp_store with "[$Hl]").
- by iIntros "$".
- Qed.
-
- Lemma TPStoreS (et: expr) l v1 v2 K P Q:
- to_val et = None
- → (⟨⟨P ∗ src (fill K (Val #())) ∗ l ↦s v2⟩⟩ et ⟨⟨v, Q v⟩⟩
- ⊢ {{src (fill K (#l <- v2)) ∗ l ↦s v1 ∗ ▷ P}} et {{v, Q v}})%I.
- Proof.
- iIntros (Hexp) "#H !> [Hsrc [Hloc P]] Hna". iApply (rwp_take_step with "[P Hna] [Hsrc Hloc]"); first done; last first.
- - iApply step_store. iFrame.
- - iIntros "Hsrc'". iApply rswp_do_step. iNext. iApply ("H" with "[$P $Hsrc'] Hna").
- Qed.
-
- Lemma TPStutterT (e: expr) P Q: to_val e = None → (⟨⟨P⟩⟩ e ⟨⟨v, Q v⟩⟩ ⊢ {{P}} e {{v, Q v}})%I.
- Proof.
- iIntros (H) "#H !> P Hna". iApply rwp_no_step; first done.
- by iApply ("H" with "P Hna").
- Qed.
-
- Lemma TPStutterSStore (et : expr) v1 v2 K l P Q :
- to_val et = None
- → {{P ∗ src (fill K (Val #())) ∗ l ↦s v2}} et {{v, Q v}}
- ⊢ {{l ↦s v1 ∗ src (fill K (#l <- v2)) ∗ P}} et {{v, Q v}}.
- Proof.
- iIntros (Hv) "#H !> [Hloc [Hsrc P]] Hna".
- iApply (rwp_weaken with "[H Hna] [P Hloc Hsrc]"); first done.
- - instantiate (1 := (P ∗ src (fill K #()) ∗ l ↦s v2)%I).
- iIntros "H1". iApply ("H" with "[H1] [Hna]"); done.
- - iApply src_update_mono. iSplitL "Hsrc Hloc".
- iApply step_store. by iFrame.
- iIntros "[H0 H1]". by iFrame.
- Qed.
-
- Lemma TPStutterSPure (et es es' : expr) P Q :
- to_val et = None
- → pure_step es es'
- → {{ P ∗ src(es') }} et {{v, Q v}}
- ⊢ {{ P ∗ src(es)}} et {{v, Q v}}.
- Proof.
- iIntros (H0 H) "#H !> [P Hsrc] Hna".
- iApply (rwp_weaken with "[H Hna] [P Hsrc]"); first done.
- - instantiate (1 := (P ∗ src es')%I). iIntros "H1".
- by iApply ("H" with "[H1] Hna").
- - iApply src_update_mono. iSplitL "Hsrc".
- by iApply step_pure. iIntros "?"; by iFrame.
- Qed.
-
- Lemma HoareLöb X P Q e :
- (∀ x :X, {{P x ∗ ▷ (∀ x, {{P x}} e {{v, Q x v}})}} e {{ v, Q x v}})
- ⊢ ∀ x, {{ P x }} e {{v, Q x v}}.
- Proof.
- iIntros "H". iApply bi.löb.
- iIntros "#H1" (x).
- (*iIntros "H0".*)
- (*iSpecialize ("H" with x). *)
- (*iApply ("H"). iModIntro.*)
- Abort.
-
-End derived.
diff --git a/theories/examples/refinements/memoization.v b/theories/examples/refinements/memoization.v
deleted file mode 100644
index 3dc4e247..00000000
--- a/theories/examples/refinements/memoization.v
+++ /dev/null
@@ -1,1914 +0,0 @@
-
-From iris.program_logic.refinement Require Export ref_weakestpre ref_source seq_weakestpre.
-From iris.base_logic.lib Require Export invariants na_invariants.
-From iris.examples.refinements Require Export refinement.
-From iris.proofmode Require Import tactics.
-From iris.heap_lang Require Import proofmode notation metatheory.
-From iris.algebra Require Import auth gmap excl frac agree.
-Set Default Proof Using "Type".
-
-Definition refN := nroot .@ "ref".
-
-Lemma fill_item_injective a (e e': expr): fill_item a e = fill_item a e' → e = e'.
-Proof.
- induction a; simpl; injection 1; eauto.
-Qed.
-
-Lemma fill_injective K (e e': expr): fill K e = fill K e' → e = e'.
-Proof.
- revert e e'; induction K; intros e e'; simpl; eauto.
- intros ? % IHK. by eapply fill_item_injective.
-Qed.
-
-Definition eq_heaplang : val := (λ: "n1" "n2", "n1" = "n2").
-
-Notation exec := (tc (@pure_step heap_lang)).
-
-Section map_simple.
-
- Context {SI: indexT} {A: Type} `{Σ: gFunctors SI} `{!heapG Σ} `{!source Σ A}.
- Context (Comparable: val → iProp Σ).
- Context `{Comparable_timeless: ∀ v, Timeless (Comparable v)}.
-
- Fixpoint contents (kvs: list (val * val)) (l: loc) : iProp Σ :=
- (match kvs with
- | nil => l ↦ NONEV
- | (k, n) :: kvs' => ∃(l': loc), Comparable k ∗ l ↦ SOMEV ((k, n), #l') ∗ contents kvs' l'
- end)%I.
-
- Global Instance contents_timeless kvs l: Timeless (contents kvs l).
- Proof using Comparable_timeless.
- revert l; induction kvs as [|[] kvs IH]; intros l; simpl; apply _.
- Qed.
- Definition map : val :=
- λ: <>, ref (ref NONE).
-
- Definition get : val :=
- λ: "m" "eq" "a",
- (rec: "get" "h" "a" :=
- match: !"h" with
- NONE => NONE
- | SOME "p" =>
- let: "kv" := Fst "p" in
- let: "next" := Snd "p" in
- if: "eq" (Fst "kv") "a" then SOME (Snd "kv") else "get" "next" "a"
- end) (!"m") "a".
-
- Definition set : val :=
- λ: "h" "a" "v",
- "h" <- ref (SOME (("a", "v"), !"h")).
-
- Fixpoint to_map (kvs: list (val * val)) : gmap val val :=
- match kvs with
- | nil => ∅
- | (k, n) :: kvs => <[k := n]> (to_map kvs)
- end.
-
- Definition Map v (h: gmap val val) :=
- (∃ (l l': loc) kvs, ⌜v = #l⌝ ∗ ⌜h = to_map kvs⌝ ∗ l ↦ #l' ∗ contents kvs l')%I.
-
- Global Instance Map_timeless v h: Timeless (Map v h).
- Proof using Comparable_timeless. apply _. Qed.
-
- Lemma map_spec: ⊢ ⟨⟨⟨ True ⟩⟩⟩ map #() ⟨⟨⟨ v, RET v; Map v ∅ ⟩⟩⟩.
- Proof.
- iModIntro; iIntros (Φ) "_ Hpost". rewrite /map. wp_pures.
- wp_alloc r as "Hr". wp_alloc h as "Hh".
- iApply "Hpost".
- iExists h, r, nil; simpl; iFrame; iSplit; done.
- Qed.
-
- Definition embed (o: option val) :=
- match o with
- | None => NONEV
- | Some k => SOMEV k
- end.
-
- Definition eqfun (eq : val) (Q: val → val → iProp Σ) :=
- (∀ n1 n2,
- ⟨⟨⟨ Comparable n1 ∗ Comparable n2 ⟩⟩⟩ eq n1 n2
- ⟨⟨⟨ b, RET #(b: bool); Comparable n1 ∗ Comparable n2 ∗
- match b with
- | true => Q n1 n2
- | _ => Q n1 n2 -∗ False
- end ⟩⟩⟩)%I.
-
- Lemma get_spec h eq Q m (n: val) :
- ⊢ ⟨⟨⟨ Map m h ∗ eqfun eq Q ∗ Comparable n ⟩⟩⟩ get m eq n
- ⟨⟨⟨ o, RET (embed o);
- match o with
- | Some v => ∃ n', ⌜ h !! n' = Some v ⌝ ∗ Q n' n ∗ Map m h
- | None => (∀ n', ⌜ n' ∈ dom (gset val) h ⌝ -∗ Q n' n -∗ False) ∗ Map m h
- end ⟩⟩⟩.
- Proof using Comparable_timeless.
- iModIntro; iIntros (Φ) "(HM&#Heq&Hcompn) Hpost". rewrite /get {1}/Map.
- wp_pures. iDestruct "HM" as (l r kvs -> ->) "[Hr Hc]".
- wp_load.
- (* we prepare the goal for the induction *)
- iAssert (∀ o, contents kvs r -∗
- match o with
- | Some v => ∃ n' : val, ⌜to_map kvs !! n' = Some v⌝ ∗ Q n' n
- | None => (∀ n', ⌜ n' ∈ dom (gset val) (to_map kvs) ⌝ -∗ Q n' n -∗ False)
- end -∗ Φ (embed o))%I with "[Hr Hpost]" as "Hpost".
- { iIntros (o) "H1 H2". iApply "Hpost". destruct o.
- - iDestruct "H2" as (n') "(?&?)".
- iExists n'. iFrame. iExists l, r, kvs; iFrame; done.
- - iFrame. iExists l, r, kvs; iFrame; done.
- }
- wp_pure _. iInduction kvs as [|[k n'] kvs] "IH" forall (r) "Hc"; simpl.
- - wp_pures. wp_load. wp_pures.
- iApply ("Hpost" $! None with "[$]").
- iIntros (? Hin) "_". iPureIntro. set_solver.
- - iDestruct "Hc" as (l') "[Hcompk [Hr Hc]]". wp_pures.
- wp_load. wp_pures.
- wp_bind (eq k n).
- wp_apply ("Heq" with "[$Hcompk $Hcompn]").
- iIntros (b) "(Hcompk&Hcompn&Hif)".
- destruct b.
- + wp_pures. subst.
- iApply ("Hpost" $! (Some n') with "[Hcompk Hr Hc]").
- { iExists _; iFrame. }
- iExists k. rewrite lookup_insert.
- eauto.
- + wp_pure _. iApply ("IH" $! l' with "[$] [Hpost Hr Hcompk Hif] Hc").
- iIntros (o) "Hc H". iApply ("Hpost" with "[Hr Hcompk Hc] [H Hif]").
- { iExists _. iFrame. }
- { destruct o.
- * iDestruct "H" as (k') "(Heq'&HQ)".
- iAssert (⌜k' ≠ k⌝)%I with "[-]" as %Hneq.
- { iIntros (->). by iApply "Hif". }
- iExists k'. rewrite lookup_insert_ne //. iFrame.
- * iIntros (? Hin) "HQ".
- set_unfold in Hin. destruct Hin as [->|Hin].
- + by iApply "Hif".
- + by iApply "H".
- }
- Qed.
-
- Lemma set_spec h m (n k: val) :
- ⊢ ⟨⟨⟨ Map m h ∗ Comparable k ⟩⟩⟩ set m k n ⟨⟨⟨ RET #(); Map m (<[k := n]> h) ⟩⟩⟩.
- Proof.
- iModIntro; iIntros (Φ) "(HM&Hcomp) Hpost". rewrite /set /Map.
- wp_pures. iDestruct "HM" as (l r kvs -> ->) "[Hr Hc]".
- wp_load. wp_alloc r' as "Hr'". wp_store.
- iApply "Hpost". iExists l, r', ((k, n) :: kvs); simpl; iFrame; repeat iSplit; auto.
- iExists r. iFrame.
- Qed.
-
-End map_simple.
-
-
-Section memoization_functions.
- Definition memoize: val :=
- λ: "eq" "f",
- let: "h" := map #() in
- λ: "a",
- match: get "h" "eq" "a" with
- NONE => let: "y" := "f" "a" in set "h" "a" "y";; "y"
- | SOME "y" => "y"
- end.
-
-
- Definition mem_rec: val :=
- λ: "eq" "F",
- let: "h" := map #() in
- rec: "mem_rec" "a" :=
- match: get "h" "eq" "a" with
- NONE =>
- let: "y" := "F" "mem_rec" "a" in
- set "h" "a" "y";; "y"
- | SOME "y" => "y"
- end.
-End memoization_functions.
-
-
-
-
-
-Section timeless_memoization.
- Context {SI: indexT} {A: Type} `{Σ: gFunctors SI} `{Heap: !rheapG Σ} `{Cred: !auth_sourceG Σ (natA SI)} `{Seq: !seqG Σ}.
-
-
- Implicit Types (c: nat).
- Implicit Types (f g m v: val).
- Implicit Types (e: expr).
- Implicit Types (h: gmap val val).
-
-
- Variable (R: expr → val → iProp Σ).
- Variable (Pre Post: val → val → iProp Σ).
- Variable (Comparable: val → iProp Σ).
- Variable (Eq: val → val → iProp Σ).
- Context `{TL: !∀ e v, Timeless (R e v)}.
- Context `{TLPost: !∀ v v', Timeless (Post v v')}.
- Context `{PPre: !∀ v v', Persistent (Pre v v')}.
- Context `{PPost: !∀ v v', Persistent (Post v v')}.
- Context `{PEq: !∀ v v', Persistent (Eq v v')}.
- Context `{Comparable_timeless: ∀ v, Timeless (Comparable v)}.
- Variable (Pre_Comparable : ∀ v v', Pre v v' -∗ Comparable v).
- Variable (Pre_Eq_Proper: ∀ v1 v1' v2, Eq v1 v1' -∗ Pre v1' v2 -∗ Pre v1 v2).
-
- (* we allow arbitrary stutter *)
- Definition eval e v := (∀ K, src (fill K e) -∗ src_update ⊤ (src (fill K v)))%I.
- Definition mem_inv (m f: val) : iProp Σ :=
- (∃ h, Map Comparable m h ∗
- [∗ map] k ↦ v ∈ h, □ (∀ k', Pre k k' -∗ ∃ v', □ R (f (of_val k')) v' ∗ Post v v'))%I.
-
- Definition implements (g: val) (f: val) : iProp Σ :=
- (□ ∀ x x' K,
- Pre x x' -∗
- src (fill K (f x')) -∗
- SEQ (g x) ⟨⟨v, ∃ v': val, Post v v' ∗ src (fill K v') ∗
- □ (∀ x', Pre x x' -∗ ∃ v', □ R (f x') v' ∗ Post v v') ⟩⟩)%I.
-
-
- Lemma memoization_core (eq: val) (f: val) e (n n' : val) m K :
- SEQ e ⟨⟨ h, implements h f ⟩⟩ ∗
- se_inv refN (mem_inv m f) ∗
- □ (∀ e v, R e v -∗ eval e v) ∗
- Pre n n' ∗
- eqfun Comparable eq Eq ∗
- src (fill K (f n')) ⊢
- SEQ (match: get m eq n with
- NONE => let: "y" := e n in set m n "y";; "y"
- | SOME "y" => "y"
- end) ⟨⟨v, ∃ v': val, Post v v' ∗ src (fill K v') ∗ □ (∀ n', Pre n n' -∗ ∃ v', □ R (f n') v' ∗ Post v v') ⟩⟩.
- Proof using Comparable Comparable_timeless Cred Eq Heap PEq PPost PPre Post Pre Pre_Comparable Pre_Eq_Proper R SI
- Seq TL TLPost Σ.
- iIntros "(Spec & #I & #IEval & #HPre & #Heqfun & Hsrc) Hna".
- (* we open the timeless invariant for the get *)
- iMod (na_inv_acc_open_timeless with "I Hna") as "(Hc & Hna & Hclose)"; auto.
- iDestruct "Hc" as (h) "(HM & #Hupd)".
- wp_bind (get m eq n). wp_apply (get_spec with "[$HM $Heqfun]").
- { by iApply Pre_Comparable. }
- iIntros (o) "HM".
- destruct o as [k|] eqn: Heq.
- - (* we have stored this result before *)
- iDestruct "HM" as (n0 Hlookup) "(#Heq&HM)".
- iDestruct (big_sepM_lookup with "Hupd") as "#Hk"; first done.
- iDestruct (Pre_Eq_Proper with "[$] [$]") as "#HPre'".
- iDestruct ("Hk" with "[$]") as (?) "(#HR&#HP)".
- iApply (rwp_weaken with "[-Hsrc] [Hsrc]"); first done; last by iApply "IEval".
- iIntros "Hsrc".
- iApply fupd_rwp. iMod ("Hclose" with "[HM $Hna]") as "Hna".
- { iNext. iExists h. by iFrame. }
- iModIntro. wp_pures.
- iFrame. iExists _. iFrame "# ∗".
- iIntros "!>" (n'') "HPre''".
- iApply "Hk". iApply (Pre_Eq_Proper with "[$] [$]").
- - (* we close the invariant again for the recursive call *)
- iDestruct "HM" as "(Hnin&HM)".
- iMod ("Hclose" with "[HM $Hna]") as "Hna".
- { iNext. iExists _. iFrame "# ∗". }
- wp_pures. wp_bind e.
- iApply (rwp_strong_mono with "[Spec Hna]");[eauto..| by iApply "Spec" |].
- iIntros (g) "[Hna Hres] !>"; simpl.
- iSpecialize ("Hres" with "HPre Hsrc Hna").
- wp_bind (g _). iApply (rwp_wand with "Hres []").
- iIntros (v) "[Hna Hres]". iDestruct "Hres" as (k) "(#HPost & Hsrc & #Hk)".
- iMod (na_inv_acc_open_timeless with "I Hna") as "(Hc & Hna & Hclose)"; auto.
- iDestruct "Hc" as (h2) "(HM & #Hupd')".
- wp_pures. wp_apply (set_spec with "[$HM]").
- { by iApply Pre_Comparable. }
- iIntros "HM".
- iApply fupd_rwp. iMod ("Hclose" with "[HM $Hna]") as "Hna".
- { iNext. iExists (<[n:=_]> h2). iFrame.
- iApply big_sepM_insert_2; simpl; auto.
- }
- iModIntro. wp_pures. iFrame.
- iExists k. iFrame. iFrame "#".
- Qed.
-
-
- Lemma memoize_spec eq (f g: val):
- eqfun Comparable eq Eq ∗
- implements g f ∗
- □ (∀ (e : expr) (v : val), R e v -∗ eval e v)
- ⊢ SEQ (memoize eq g) ⟨⟨ h, implements h f ⟩⟩.
- Proof using Comparable Comparable_timeless Cred Eq Heap PEq PPost PPre Post Pre Pre_Comparable Pre_Eq_Proper R SI
- Seq TL TLPost Σ.
- iIntros "[#Heq [#H #R]] Hna". rewrite /memoize. wp_pures. iFrame.
- wp_apply map_spec; first done. iIntros (m) "Hm".
- iMod (na_inv_alloc seqG_name ⊤ refN (mem_inv m f) with "[Hm]") as "#IM".
- { iNext. iExists ∅. iFrame. rewrite big_sepM_empty; done. }
- wp_pures. iFrame.
-
- iModIntro; iIntros (n n' K) "#HPre Hsrc Hna".
- wp_pure _.
- iDestruct (Pre_Comparable with "HPre") as "Hcomp".
- iApply (memoization_core with "[-Hna] [$Hna]").
- iFrame "IM Hsrc R HPre Heq". iIntros "Hna". wp_value_head. iFrame.
- iApply "H".
- Qed.
-
- Lemma mem_rec_spec eq (F f: val):
- eqfun Comparable eq Eq ∗
- (□ ∀ g, ▷ implements g f -∗ SEQ (F g) ⟨⟨h, implements h f⟩⟩) ∗
- □ (∀ (e : expr) (v : val), R e v -∗ eval e v) ⊢
- SEQ (mem_rec eq F) ⟨⟨ h, implements h f ⟩⟩.
- Proof using Comparable Comparable_timeless Cred Eq Heap PEq PPost PPre Post Pre Pre_Comparable Pre_Eq_Proper R SI
- Seq TL TLPost Σ.
- iIntros "[#Heq [#H #R]] Hna". rewrite /mem_rec. wp_pures. iFrame.
- wp_apply map_spec; first done. iIntros (m) "Hm".
- iMod (na_inv_alloc seqG_name ⊤ refN (mem_inv m f) with "[Hm]") as "#IM".
- { iNext. iExists ∅. iFrame. rewrite big_sepM_empty; done. }
- wp_pures. iFrame.
-
- iLöb as "IH". iModIntro. iIntros (n n' K) "#HPre Hsrc Hna".
- wp_pure _.
- iDestruct (Pre_Comparable with "HPre") as "Hcomp".
- iApply (memoization_core with "[-Hna] [$Hna]").
- iFrame "IM Hsrc R HPre Heq". iApply "H". iApply "IH".
- Qed.
-
-End timeless_memoization.
-
-Section pure_nat_memoization.
- Context {SI: indexT} {A: Type} `{Σ: gFunctors SI} `{Heap: !rheapG Σ} `{Cred: !auth_sourceG Σ (natA SI)} `{Seq: !seqG Σ}.
-
-
- Implicit Types (c: nat).
- Implicit Types (f g m v: val).
- Implicit Types (e: expr).
- Implicit Types (h: gmap val val).
-
- Definition natRel (v1 v2: val) : iProp Σ :=
- (∃ n : nat, ⌜ v1 = #n ∧ v2 = #n ⌝)%I.
-
- Lemma lookup_O {X: Type} (l: list X) (x: X):
- l !! O = Some x →
- ∃ l', l = x :: l'.
- Proof.
- destruct l as [| a l']; rewrite ?lookup_nil; try congruence => //=.
- rewrite /=. intros. exists l'. congruence.
- Qed.
-
- Definition execV (e: expr) (v: val) : iProp Σ := (⌜exec e v⌝)%I.
-
- Lemma pure_exec_exec e1 e2 n φ: PureExec φ (S n) e1 e2 → φ → exec e1 e2.
- Proof.
- intros HP Hφ. specialize (HP Hφ); remember (S n) as m; revert n Heqm.
- induction HP as [|n e1 e2 e3 Hstep Hsteps]; first naive_solver.
- injection 1 as <-. destruct n as [|n].
- - inversion Hsteps; subst. eapply tc_once, Hstep.
- - eapply tc_l; naive_solver.
- Qed.
-
- Lemma exec_frame e1 e2 K: exec e1 e2 → exec (fill K e1) (fill K e2).
- Proof.
- induction 1.
- - eapply tc_once, pure_step_ctx; eauto. apply _.
- - etrans; eauto.
- eapply tc_once, pure_step_ctx; eauto. apply _.
- Qed.
-
- Lemma exec_src_update e1 e2 j E: exec e1 e2 → j ⤇ e1 ⊢ src_update E (j ⤇ e2).
- Proof.
- induction 1.
- - by apply step_pure.
- - iIntros "H". iApply src_update_bind. iSplitL.
- + iApply step_pure; eauto.
- + iApply IHtc.
- Qed.
-
- Lemma rtc_r_or_tc {X: Type} (R: relation X) x y:
- rtc R x y → x = y ∨ tc R x y.
- Proof.
- induction 1.
- - by left.
- - right. destruct IHrtc.
- * subst. by apply tc_once.
- * eapply tc_l; eauto.
- Qed.
-
- Definition natfun_refines (g: val) (f: val) : iProp Σ :=
- (□ ∀ (n : nat) K,
- src (fill K (f #n)) -∗
- SEQ (g #n) ⟨⟨v, ∃ n': nat, ⌜ v = #n' ⌝ ∗ src (fill K v) ⟩⟩)%I.
-
- Definition natfun_pure (f: val) :=
- ∀ (n1 n2 : nat) tp1 tp2 σ1 σ2 K,
- rtc erased_step (fill K (f #n1) :: tp1, σ1) (fill K (#n2) :: tp2, σ2) →
- (∀ K', rtc pure_step (fill K' (f #n1)) (fill K' (#n2))).
-
- Lemma natfun_mem_rec_spec (F f: val):
- natfun_pure f →
- (□ ∀ g, ▷ natfun_refines g f -∗ SEQ (F g) ⟨⟨h, natfun_refines h f⟩⟩) ⊢
- SEQ (mem_rec eq_heaplang F) ⟨⟨ h, natfun_refines h f ⟩⟩.
- Proof.
- iIntros (Hpure) "#Href".
- iIntros "Hna".
- iPoseProof (mem_rec_spec
- (λ e v, ∃ K (n1 n2: nat) tp1 tp2 σ1 σ2, ⌜ e = (f #n1) ∧ v = #n2 ∧
- rtc erased_step (fill K (f #n1) :: tp1, σ1) (fill K (#n2) :: tp2, σ2)⌝)%I
- natRel natRel
- (λ x, ⌜ val_is_unboxed x ⌝)%I (λ x1 x2, ⌜ x1 = x2 ⌝)%I
- with "[] [$Hna]") as "H"; last first.
- { iApply (rwp_mono with "H").
- iIntros (?) "($&#H)". rewrite /implements /natfun_refines.
- iIntros "!>" (n K) "Hsrc Hna".
- iSpecialize ("H" $! #n with "[] [$] [$]"); first eauto.
- iApply (rwp_mono with "H").
- iIntros (?) "($&Hrel)".
- iDestruct "Hrel" as (? (n'&->&->)) "(Hsrc&_)".
- iExists n'. eauto.
- }
- { iSplit.
- {
- rewrite /eqfun. iIntros (??) "!>". iIntros (Φ) "(%&%) H".
- rewrite /eq_heaplang. wp_pures.
- wp_pure _; first (rewrite /vals_compare_safe; eauto).
- iApply "H". iFrame "%". rewrite /bool_decide. destruct (decide_rel _); eauto.
- }
- iSplit.
- * iModIntro.
- iIntros (g) "Himpl Hna".
- iSpecialize ("Href" $! g with "[Himpl] [$]").
- {
- iNext. iDestruct "Himpl" as "#Himpl". iIntros (n K) "!> H Hna".
- iSpecialize ("Himpl" with "[] [$] [$]"); eauto.
- iApply (rwp_wand with "Himpl").
- iIntros (?) "($&H)".
- iDestruct "H" as (? (n'&Heq1&Heq2)) "(Hsrc&_)".
- subst; eauto.
- }
- iApply (rwp_wand with "Href").
- iIntros (?) "($&#Hnatfun)".
- rewrite /implements.
- iIntros (?? K) "!> H Hsrc Hna".
- iApply (rwp_weaken' with "[-Hsrc]"); first done; last first.
- { iApply (src_log with "[$]"). }
- iIntros "(Hsrc&Hlog)".
- iDestruct "Hlog" as (tp σ i Hlookup) "#Hfmlist".
- iDestruct "H" as %[n [-> ->]].
- iSpecialize ("Hnatfun" with "[$] [$]").
- iApply rwp_fupd'.
- iApply (rwp_wand with "Hnatfun").
- iIntros (?) "($&H)".
- iIntros (???) "(Hinterp&Hstate)".
- iDestruct "H" as (n' ?) "Hsrc".
- iDestruct (src_get_trace' with "[$]") as "(Hsrc&Hinterp&Hin)".
- iDestruct "Hin" as %(?&σ'&Hlookup'&Hrtc).
- iFrame. iModIntro.
- iExists #n'.
- subst.
- iSplit; first eauto.
- iSplit; first eauto.
- iModIntro. iIntros (?) "H".
- iDestruct "H" as %(?&Heq1&Heq2); subst.
- inversion Heq1 as [Heq].
- iExists #n'. iSplit; eauto.
- iModIntro.
- apply lookup_O in Hlookup as (tp1'&->).
- apply lookup_O in Hlookup' as (tp2'&->).
- iExists _, _, _, _, _,
- {| heap := fst σ; used_proph_id := {| mapset.mapset_car := snd σ |}|},
- {| heap := fst σ'; used_proph_id := {| mapset.mapset_car := snd σ' |}|}.
- iPureIntro.
- split_and!; eauto. rewrite /to_cfg in Hrtc. destruct σ, σ'. eapply Hrtc.
- * iModIntro. iIntros (e v) "H".
- iDestruct "H" as (K n1 n2 tp1 tp2 σ1 σ2) "H".
- iDestruct "H" as %(Heq1&Heq2&Hrtc).
- rewrite /eval.
- iIntros (K') "Hsrc".
- iApply (exec_src_update with "[$]").
- subst.
- apply Hpure in Hrtc. specialize (Hrtc K').
- apply rtc_r_or_tc in Hrtc as [Hr|Htc]; last eauto.
- { apply fill_injective in Hr. congruence. }
- }
- { iIntros (??? -> Hrel). iPureIntro. destruct Hrel as (x&->&->). eauto. }
- { iIntros (?? (n'&->&->)). eauto. }
- Qed.
-
-End pure_nat_memoization.
-
-Section repeatable_refinements.
- Context {SI: indexT} {A: Type} `{Σ: gFunctors SI} `{Heap: !rheapG Σ} `{Cred: !auth_sourceG Σ (natA SI)} `{Sync: !inG Σ (authR (optionUR (exclR (gmapO val (valO SI)))))} `{Seq: !seqG Σ}.
-
-
- Implicit Types (c: nat).
- Implicit Types (f g m v: val).
- Implicit Types (e: expr).
- Implicit Types (h: gmap val val).
- Variable (Pre Post: val → val → iProp Σ).
- Variable (Comparable: val → iProp Σ).
- Variable (Eq: val → val → iProp Σ).
- Context `{PPre: !∀ v v', Persistent (Pre v v')}.
- Context `{PPost: !∀ v v', Persistent (Post v v')}.
- Context `{PEq: !∀ v v', Persistent (Eq v v')}.
- Context `{Comparable_timeless: ∀ v, Timeless (Comparable v)}.
- Variable (Pre_Comparable : ∀ v v', Pre v v' ={⊤}=∗ Comparable v).
- Variable (Pre_Eq_Proper: ∀ v1 v1' v2, Eq v1 v1' -∗ Pre v1' v2 -∗ Pre v1 v2).
-
-
- (* we allow arbitrary stutter *)
- Definition mem_rec_tl_inv γ m : iProp Σ := (∃ h, Map Comparable m h ∗ own γ (● Excl' h) ∗ $ (1%nat))%I.
- Definition mem_rec_tf_inv γ (f: val) : iProp Σ :=
- (∃ h, own γ (◯ Excl' h) ∗ [∗ map] k ↦ v ∈ h, □ (∀ k', Pre k k' -∗ ∃ v', □ eval (f k') v' ∗ Post v v'))%I.
-
- Definition tf_implements (g: val) (f: val) : iProp Σ :=
- (□ ∀ x x' c K,
- Pre x x' -∗
- src (fill K (f x')) -∗
- SEQ (g x) ⟨⟨v, ∃ v': val, Post v v' ∗ $c ∗ src (fill K v') ∗
- □ (∀ x', Pre x x' -∗ ∃ v', □ eval (f x') v' ∗ Post v v') ⟩⟩)%I.
-
- Lemma tf_memoization_core `{FiniteBoundedExistential SI} (eq: val) (f: val) e c γ (n n' : val) m K :
- SEQ e ⟨⟨ h, tf_implements h f ⟩⟩ ∗
- se_inv (refN .@ "tl") (mem_rec_tl_inv γ m) ∗
- se_inv (refN .@ "tf") (mem_rec_tf_inv γ f) ∗
- Pre n n' ∗
- eqfun Comparable eq Eq ∗
- src (fill K (f n')) ⊢
- SEQ (match: get m eq n with
- NONE => let: "y" := e n in set m n "y";; "y"
- | SOME "y" => "y"
- end) ⟨⟨v, ∃ v': val, Post v v' ∗ $c ∗ src (fill K v') ∗ □ (∀ n', Pre n n' -∗ ∃ v', □ eval (f n') v' ∗ Post v v') ⟩⟩.
- Proof using Comparable Comparable_timeless Cred Eq Heap PEq PPost PPre Post Pre Pre_Comparable Pre_Eq_Proper SI
- Seq Sync Σ.
- iIntros "(Spec & #IM & #IC & #HPre & #Heqfun & Hsrc) Hna".
- (* we open the timeless invariant for the get *)
- iMod (na_inv_acc_open_timeless with "IM Hna") as "(Hc & Hna & Hclose1)"; auto.
- iDestruct "Hc" as (h) "(HM & H● & Hone)".
- wp_bind (get m eq n).
- iMod (Pre_Comparable with "HPre") as "HComp".
- wp_apply (get_spec with "[$HM $Heqfun $HComp]").
- iIntros (o) "HM".
- destruct o as [k|] eqn: Heq.
- - (* we have stored this result before *)
- iDestruct "HM" as (n0 Hlookup) "(#Heq&HM)".
- iMod (na_inv_acc_open with "IC Hna") as "Hcache"; auto; first solve_ndisj.
- iApply (rwp_take_step with "[-Hone] [Hone]"); first done; last first.
- { iApply step_stutter. iFrame. } iIntros "_".
- iApply rswp_do_step. iNext; simpl. iDestruct "Hcache" as "(HsrcI & Hna & Hclose2)".
- iDestruct "HsrcI" as (h') "[H◯ #Hupd]".
- iDestruct (own_valid_2 with "H● H◯") as % [->%Excl_included%leibniz_equiv _]%auth_both_valid.
- wp_pure _.
- iDestruct (big_sepM_lookup with "Hupd") as "#Hk"; first done.
- iDestruct ("Hk" with "[]") as (?) "(#Heval&#HP)".
- { iApply (Pre_Eq_Proper with "[$] [$]"). }
- iApply (rwp_weaken with "[-Hsrc] [Hsrc]"); first done; last first.
- { iApply (step_inv_alloc (S c) with "[] Hsrc"); iSplitL; first iApply "Heval".
- iIntros "Hsrc". iExists (fill K _). iFrame. iPureIntro. intros ? % fill_injective; discriminate. }
- rewrite nat_srcF_succ. iIntros "(Hsrc & Hone & Hc)".
- iApply fupd_rwp. iMod ("Hclose2" with "[H◯ $Hna]") as "Hna".
- { iNext. iExists h. iFrame. done. }
- iMod ("Hclose1" with "[H● HM $Hna Hone]") as "Hna".
- { iNext. iExists h. iFrame. }
- iModIntro. wp_pures.
- iFrame. iExists _. iFrame "# ∗".
- iIntros "!>" (n'') "HPre''".
- iApply "Hk". iApply (Pre_Eq_Proper with "[$] [$]").
- - (* we close the invariant again for the recursive call *)
- iDestruct "HM" as "(Hnin&HM)".
- iMod ("Hclose1" with "[H● HM $Hna Hone]") as "Hna".
- { iNext. iExists _. iFrame. }
- wp_pures. wp_bind e.
- iApply (rwp_strong_mono with "[Spec Hna]");[eauto..| by iApply "Spec" |].
- iIntros (g) "[Hna Hres] !>"; simpl.
- iSpecialize ("Hres" $! _ _ (S c) with "[$] Hsrc Hna").
- wp_bind (g _). iApply (rwp_wand with "Hres []").
- iIntros (v) "[Hna Hres]". iDestruct "Hres" as (k) "(HPost & Hcred & Hsrc & #Hk)".
- rewrite nat_srcF_succ. iDestruct ("Hcred") as "[Hone Hcred]".
- iMod (na_inv_acc_open_timeless with "IM Hna") as "(Hc & Hna & Hclose1)"; auto.
- iDestruct "Hc" as (h2) "(HM & H● & Hone')".
- iMod (na_inv_acc_open with "IC Hna") as "Hcache"; auto; first solve_ndisj.
- iApply (rwp_take_step with "[-Hone] [Hone]"); first done; last first.
- { iApply step_stutter. iFrame. } iIntros "_".
- iApply rswp_do_step. iNext; simpl. iDestruct "Hcache" as "(HsrcI & Hna & Hclose2)".
- iDestruct "HsrcI" as (h2') "[H◯ #Hupd]".
- iDestruct (own_valid_2 with "H● H◯") as % [->%Excl_included%leibniz_equiv _]%auth_both_valid.
- wp_pures.
- iMod (Pre_Comparable with "HPre") as "HComp".
- wp_apply (set_spec with "[$HM $HComp]").
- iIntros "HM".
- iMod (own_update_2 with "H● H◯") as "[H● H◯]".
- { apply auth_update, option_local_update, (exclusive_local_update _ (Excl (<[n := v]> h2))); done. }
- iApply fupd_rwp. iMod ("Hclose2" with "[H◯ $Hna]") as "Hna".
- { iNext. iExists (<[n:=_]> h2). iFrame.
- iApply big_sepM_insert_2; simpl; eauto. }
- iMod ("Hclose1" with "[H● HM $Hna Hone']") as "Hna".
- { iNext. iExists _. iFrame. }
- iModIntro. wp_pures. iFrame.
- iExists k. iFrame. iFrame "#".
- Qed.
-
- Lemma tf_memoize_spec `{FiniteBoundedExistential SI} eq (f g: val):
- eqfun Comparable eq Eq ∗
- tf_implements g f ∗
- $ (1%nat)
- ⊢ SEQ (memoize eq g) ⟨⟨ h, tf_implements h f ⟩⟩.
- Proof using Comparable Comparable_timeless Cred Eq Heap PEq PPost PPre Post Pre Pre_Comparable Pre_Eq_Proper SI
- Seq Sync Σ.
- iIntros "(#Heq&#H&Hcred) Hna". rewrite /memoize. wp_pures. iFrame.
- wp_apply map_spec; first done. iIntros (m) "Hm".
- iMod (own_alloc (● (Excl' ∅) ⋅ ◯ (Excl' ∅))) as (γ) "[H● H◯]".
- { apply auth_both_valid_2; done. }
- iMod (na_inv_alloc seqG_name ⊤ (refN .@ "tl") (mem_rec_tl_inv γ m) with "[H● Hm Hcred]") as "#IM".
- { iNext. iExists ∅. iFrame. }
- iMod (na_inv_alloc seqG_name ⊤ (refN .@ "tf") (mem_rec_tf_inv γ f) with "[H◯]") as "#IS".
- { iNext. iExists ∅. iFrame. rewrite big_sepM_empty; done. }
- wp_pures. iFrame.
- iIntros (n n' c K) "!> #HPre Hsrc Hna".
- wp_pure _.
- iDestruct (Pre_Comparable with "HPre") as "Hcomp".
- iApply (tf_memoization_core with "[-Hna] [$Hna]").
- iFrame "IM IS Hsrc HPre Heq". iIntros "Hna". wp_value_head. iFrame.
- iApply "H".
- Qed.
-
- Lemma tf_mem_rec_spec `{FiniteBoundedExistential SI} eq (F f: val):
- eqfun Comparable eq Eq ∗
- (□ ∀ g, ▷ tf_implements g f -∗ SEQ (F g) ⟨⟨h, tf_implements h f⟩⟩) ∗ $ (1%nat) ⊢
- SEQ (mem_rec eq F) ⟨⟨ h, tf_implements h f ⟩⟩.
- Proof using Comparable Comparable_timeless Cred Eq Heap PEq PPost PPre Post Pre Pre_Comparable Pre_Eq_Proper SI
- Seq Sync Σ.
- iIntros "[#Heq [#HF Hcred]] Hna". rewrite /mem_rec. wp_pures. iFrame.
- wp_apply map_spec; first done. iIntros (m) "Hm".
- iMod (own_alloc (● (Excl' ∅) ⋅ ◯ (Excl' ∅))) as (γ) "[H● H◯]".
- { apply auth_both_valid_2; done. }
- iMod (na_inv_alloc seqG_name ⊤ (refN .@ "tl") (mem_rec_tl_inv γ m) with "[H● Hm Hcred]") as "#IM".
- { iNext. iExists ∅. iFrame. }
- iMod (na_inv_alloc seqG_name ⊤ (refN .@ "tf") (mem_rec_tf_inv γ f) with "[H◯]") as "#IS".
- { iNext. iExists ∅. iFrame. rewrite big_sepM_empty; done. }
- wp_pures. iFrame.
-
- iLöb as "IH". iModIntro; iIntros (n n' c K) "#HPre Hsrc Hna".
- wp_pure _.
- iDestruct (Pre_Comparable with "HPre") as "Hcomp".
- iApply (tf_memoization_core with "[-Hna] Hna").
- iFrame "IM IS Hsrc HPre Heq". iApply "HF". iApply "IH".
- Qed.
-
-End repeatable_refinements.
-
-
-Section fibonacci.
- Context {SI: indexT} {A: Type} `{Σ: gFunctors SI} `{Heap: !rheapG Σ} `{Cred: !auth_sourceG Σ (natA SI)} `{Seq: !seqG Σ}.
-
- (* we define the body to reduce the number of lemmas we need to prove*)
- Definition Fib (fib : val) (n : expr): expr :=
- if: n = #0 then #0
- else if: n = #1 then #1
- else
- let: "n'" := n - #1 in
- let: "n''" := n - #2 in
- fib "n'" + fib "n''".
-
-
- Lemma Fib_zero fib: exec (Fib fib #0) (#0).
- Proof.
- eapply pure_exec_exec.
- - rewrite /Fib; pure_exec.
- - repeat split; solve_vals_compare_safe.
- Qed.
-
- Lemma Fib_one fib: exec (Fib fib #1) (#1).
- Proof.
- eapply pure_exec_exec.
- - rewrite /Fib; pure_exec.
- - repeat split; solve_vals_compare_safe.
- Qed.
-
- Lemma Fib_rec fib n: exec (Fib fib #(S (S n))) ((fib #(S n)) + (fib #n))%E.
- Proof.
- eapply pure_exec_exec.
- - rewrite /Fib; pure_exec.
- rewrite bool_decide_eq_false_2; last (injection 1; lia).
- pure_exec.
- - repeat split; try solve_vals_compare_safe.
- + rewrite /bin_op_eval //=. by replace (S (S n) - 1) with (S n: Z) by lia.
- + rewrite /bin_op_eval //=. by replace (S (S n) - 2) with (n: Z) by lia.
- Qed.
-
- Definition fib : val :=
- rec: "fib" "n" :=
- if: "n" = #0 then #0
- else if: "n" = #1 then #1
- else
- let: "n'" := "n" - #1 in
- let: "n''" := "n" - #2 in
- "fib" "n'" + "fib" "n''".
-
- Lemma fib_Fib (v: val): exec (fib v) (Fib fib v).
- Proof.
- eapply pure_exec_exec.
- - rewrite /Fib /fib; pure_exec.
- - repeat split.
- Qed.
-
- Definition fib_template : val :=
- λ: "fib" "n",
- if: "n" = #0 then #0
- else if: "n" = #1 then #1
- else
- let: "n'" := "n" - #1 in
- let: "n''" := "n" - #2 in
- "fib" "n'" + "fib" "n''".
-
- Tactic Notation "exec_bind" open_constr(efoc) :=
- match goal with
- | [|- exec ?e1 ?e2] =>
- src_bind_core e1 efoc ltac:(fun K e' => change (exec (fill K e') e2))
- end.
-
- Lemma fib_fundamental_core g K (n: nat):
- (▷ implements execV natRel natRel g fib) ∗
- src (fill K (fib #n)) ⊢
- SEQ (Fib g #n) ⟨⟨v, ∃ m: nat, ⌜v = #m⌝ ∗ src (fill K #m) ∗ □ execV (fib #n) #m ⟩⟩.
- Proof.
- iIntros "[#IH Hsrc] Hna".
- destruct n as [|[|n]]; (iApply (rwp_take_step with "[-Hsrc] [Hsrc]"); first done; last first).
- - iApply exec_src_update; eauto. eapply exec_frame.
- etrans; first apply fib_Fib. eapply Fib_zero.
- - iIntros "Hsrc". iApply rswp_do_step. iNext. rewrite /Fib.
- wp_pure _; first solve_vals_compare_safe. wp_pures. iFrame.
- iExists 0%nat. iFrame. iSplitL; eauto.
- iModIntro. iPureIntro. etrans; first apply fib_Fib. eapply Fib_zero.
- - iApply exec_src_update; eauto. eapply exec_frame.
- etrans; first apply fib_Fib. eapply Fib_one.
- - iIntros "Hsrc". iApply rswp_do_step. iNext. rewrite /Fib.
- wp_pure _; first solve_vals_compare_safe. wp_pures.
- wp_pure _; first solve_vals_compare_safe. wp_pures.
- iFrame. iExists 1%nat. iFrame. iSplitL; eauto.
- iModIntro. iPureIntro.
- etrans; first apply fib_Fib. eapply Fib_one.
- - iApply exec_src_update; eauto. eapply exec_frame.
- etrans; first apply fib_Fib. eapply Fib_rec.
- - iIntros "Hsrc". iApply rswp_do_step. iNext. rewrite /Fib.
- wp_pure _; first solve_vals_compare_safe. wp_pures.
- wp_pure _; first solve_vals_compare_safe.
- rewrite bool_decide_eq_false_2; last (injection 1; lia).
- do 7 wp_pure _.
- (* recursion for n *)
- wp_bind (g _)%E. replace (S (S n) - 2) with (n: Z) by lia.
- src_bind (fib #n) in "Hsrc".
- iApply (rwp_wand with "[Hna Hsrc]").
- { iApply ("IH" with "[] Hsrc Hna"); first eauto. }
- iIntros (v) "[Hna H]". iDestruct "H" as (m) "(HPre & Hsrc & #Hev1)"; simpl.
- iDestruct "HPre" as %[m' [Heq1 Heq2]]. subst.
- (* recursion for (n + 1) *)
- wp_bind (g _)%E. replace (S (S n) - 1) with (S n: Z) by lia.
- src_bind (fib _) in "Hsrc".
- iApply (rwp_wand with "[Hna Hsrc]").
- { iApply ("IH" with "[] Hsrc Hna"). eauto. }
- iIntros (v) "[Hna H]". iDestruct "H" as (v') "(HPre & Hsrc & #Hev2)"; simpl.
- iDestruct "HPre" as %[m [Heq1 Heq2]]. subst.
- iFrame. iApply (rwp_weaken with "[-Hsrc] [Hsrc]"); first done; last first.
- { iApply (steps_pure_exec with "Hsrc"). reflexivity. }
- simpl; iIntros "Hsrc"; wp_pure _.
- replace (m + m') with ((m' + m)%nat: Z) by lia.
- iExists (m' + m)%nat; iFrame; iSplitR; auto.
- iModIntro.
- iDestruct "Hev1" as % Hev1. iDestruct "Hev2" as % Hev2. iPureIntro.
- etrans; first eapply fib_Fib.
- etrans; first eapply Fib_rec.
- edestruct Hev1 as (?&Hexec1&?&Heq1&?); eauto.
- edestruct Hev2 as (?&Hexec2&?&Heq2&?); eauto; subst.
- inversion Heq1; subst.
- inversion Heq2; subst.
- exec_bind (fib _); etrans; first eapply exec_frame; eauto; simpl.
- exec_bind (fib _); etrans; first eapply exec_frame; eauto; simpl.
- eapply pure_exec_exec. apply _.
- rewrite /bin_op_eval. destruct (decide _) => //=.
- repeat f_equal. lia.
- Qed.
-
- Lemma fib_sound:
- ⊢ implements execV natRel natRel fib fib.
- Proof.
- iLöb as "IH".
- iModIntro; iIntros (v v' K) "HPre Hsrc Hna".
- iDestruct "HPre" as %[n [Heq1 Heq2]]. subst.
- rewrite {4}/fib. wp_pure _.
- fold fib. fold (Fib fib #n).
- iApply rwp_mono; last first.
- { iApply (fib_fundamental_core fib K n with "[$Hsrc $IH] Hna"). }
- iIntros (v) "($&H)".
- iDestruct "H" as (m ->) "(Hsrc&#Hexec)". iExists _. iFrame.
- iSplitR; first eauto.
- iModIntro. iIntros (x) "Hrel". iDestruct "Hrel" as %[? [-> ->]]. iExists _. iSplit; eauto.
- Qed.
-
- Lemma fib_template_sound g:
- ▷ implements execV natRel natRel g fib ⊢ SEQ (fib_template g) ⟨⟨h, implements execV natRel natRel h fib⟩⟩.
- Proof.
- iIntros "#H Hna". rewrite /fib_template. wp_pures. iFrame.
- iModIntro; iIntros (n n' K) "HPre Hsrc Hna".
- wp_pure _. fold (Fib g n).
- iDestruct "HPre" as %[n0 [-> ->]].
- iApply rwp_mono; last first.
- { by iApply (fib_fundamental_core g K n0 with "[$Hsrc] Hna"). }
- iIntros (v) "($&H)".
- iDestruct "H" as (m ->) "(Hsrc&#Hexec)". iExists _. iFrame.
- iSplitR; first eauto.
- iModIntro. iIntros (x) "Hrel". iDestruct "Hrel" as %[? [-> ->]]. iExists _. iSplit; eauto.
- Qed.
-
-
- (* memoized versions *)
- Lemma fib_memoized: ⊢ SEQ (memoize eq_heaplang fib) ⟨⟨ h, implements execV natRel natRel h fib ⟩⟩.
- Proof.
- (* XXX: the iApply fails over typeclass resolution (?) if we don't do iStartProof *)
- iStartProof.
- iApply (memoize_spec _ _ _ (λ x, ⌜ val_is_unboxed x ⌝)%I (λ x1 x2, ⌜ x1 = x2 ⌝)%I);
- [| | iSplit; [| iSplit]].
- - iIntros (??) "H". iDestruct "H" as %[? [-> ->]]. eauto.
- - iIntros (??? ->). auto.
- - rewrite /eqfun. iIntros (??) "!>". iIntros (Φ) "(%&%) H".
- rewrite /eq_heaplang. wp_pures.
- wp_pure _; first (rewrite /vals_compare_safe; eauto).
- iApply "H". iFrame "%". rewrite /bool_decide. destruct (decide_rel _); eauto.
- - iApply fib_sound.
- - iModIntro. iIntros (e v Hexec K).
- iApply exec_src_update. apply exec_frame, Hexec.
- Qed.
-
- Lemma fib_deep_memoized: ⊢ SEQ (mem_rec eq_heaplang fib_template) ⟨⟨ h, implements execV natRel natRel h fib ⟩⟩.
- Proof.
- iStartProof.
- iApply (mem_rec_spec _ _ _ (λ x, ⌜ val_is_unboxed x ⌝)%I (λ x1 x2, ⌜ x1 = x2 ⌝)%I);
- [| | iSplit; [| iSplit]].
- - iIntros (??) "H". iDestruct "H" as %[? [-> ->]]. eauto.
- - iIntros (??? ->). auto.
- - rewrite /eqfun. iIntros (??) "!>". iIntros (Φ) "(%&%) H".
- rewrite /eq_heaplang. wp_pures.
- wp_pure _; first (rewrite /vals_compare_safe; eauto).
- iApply "H". iFrame "%". rewrite /bool_decide. destruct (decide_rel _); eauto.
- - iModIntro. iIntros (g). iApply fib_template_sound.
- - iModIntro. iIntros (e v Hexec K).
- iApply exec_src_update. apply exec_frame, Hexec.
- Qed.
-End fibonacci.
-
-Section levenshtein.
- Context {SI: indexT} {A: Type} `{Σ: gFunctors SI} `{Heap: !rheapG Σ} `{Cred: !auth_sourceG Σ (natA SI)} `{Seq: !seqG Σ}.
-
- Definition eqstr : val :=
- rec: "eqstr" "s1" "s2" :=
- let: "c1" := !"s1" in
- let: "c2" := !"s2" in
- if: "c1" = "c2" then
- if: "c1" = #0 then
- #true
- else
- "eqstr" ("s1" +ₗ #1) ("s2" +ₗ #1)
- else
- #false.
-
- Definition Strlen (strlen : val) (l : expr): expr :=
- let: "c" := !l in
- if: "c" = #0 then #0
- else
- let: "r" := strlen (l +ₗ #1) in
- #1 + "r".
-
- Definition strlen_template : val :=
- λ: "strlen" "l",
- let: "c" := !"l" in
- if: "c" = #0 then #0
- else
- let: "r" := "strlen" ("l" +ₗ #1) in
- #1 + "r".
-
- Definition strlen : val :=
- rec: "strlen" "l" := strlen_template "strlen" "l".
-
- Definition min2 : val :=
- λ: "n1" "n2",
- if: "n1" ≤ "n2" then "n1" else "n2".
-
- Definition min3 : val :=
- λ: "n1" "n2" "n3",
- min2 (min2 "n1" "n2") ("n3").
-
- (*
- Fixpoint gallina_lev (s1 : list nat) (s2 : list nat) : nat :=
- match s1 with
- | [] => length s2
- | c1 :: s1' =>
- match s2 with
- | [] => length s1
- | c2 :: s2' =>
- if decide (c1 = c2) then
- gallina_lev s1' s2'
- else
- let r1 := gallina_lev s1 s2' in
- let r2 := gallina_lev s1' s2 in
- let r3 := gallina_lev s1' s2' in
- (1 + min (min r1 r2) r3)%nat
- end
- end.
- *)
-
- Definition Lev (strlen : val) (lev : val) (s12 : expr): expr :=
- let: "s1" := Fst s12 in
- let: "s2" := Snd s12 in
- let: "c1" := !"s1" in
- if: "c1" = #0 then strlen "s2" else
- let: "c2" := !"s2" in
- if: "c2" = #0 then strlen "s1" else
- if: "c1" = "c2" then lev ("s1" +ₗ #1, "s2" +ₗ #1)
- else
- let: "r1" := lev ("s1", "s2" +ₗ #1) in
- let: "r2" := lev ("s1" +ₗ #1, "s2") in
- let: "r3" := lev ("s1" +ₗ #1, "s2" +ₗ #1) in
- #1 + min3 "r1" "r2" "r3".
-
- Definition lev_template : val :=
- λ: "strlen" "lev" "s12",
- let: "s1" := Fst "s12" in
- let: "s2" := Snd "s12" in
- let: "c1" := !"s1" in
- if: "c1" = #0 then "strlen" "s2" else
- let: "c2" := !"s2" in
- if: "c2" = #0 then "strlen" "s1" else
- if: "c1" = "c2" then "lev" ("s1" +ₗ #1,"s2" +ₗ #1)
- else
- let: "r1" := "lev" ("s1", "s2" +ₗ #1) in
- let: "r2" := "lev" ("s1" +ₗ #1, "s2") in
- let: "r3" := "lev" ("s1" +ₗ #1, "s2" +ₗ #1) in
- #1 + min3 "r1" "r2" "r3".
-
- Definition lev_template' (slen : expr) : val :=
- λ: "lev" "s12",
- let: "s1" := Fst "s12" in
- let: "s2" := Snd "s12" in
- let: "c1" := !"s1" in
- if: "c1" = #0 then slen "s2" else
- let: "c2" := !"s2" in
- if: "c2" = #0 then slen "s1" else
- if: "c1" = "c2" then "lev" ("s1" +ₗ #1,"s2" +ₗ #1)
- else
- let: "r1" := "lev" ("s1", "s2" +ₗ #1) in
- let: "r2" := "lev" ("s1" +ₗ #1, "s2") in
- let: "r3" := "lev" ("s1" +ₗ #1, "s2" +ₗ #1) in
- #1 + min3 "r1" "r2" "r3".
-
- Definition lev : val :=
- rec: "lev" "s12" := lev_template strlen "lev" "s12".
-
- Notation exec := (tc (@pure_step heap_lang)).
-
- Tactic Notation "exec_bind" open_constr(efoc) :=
- match goal with
- | [|- exec ?e1 ?e2] =>
- src_bind_core e1 efoc ltac:(fun K e' => change (exec (fill K e') e2))
- end.
-
- Lemma strlen_Strlen (v: val): exec (strlen v) (Strlen strlen v).
- Proof.
- eapply pure_exec_exec.
- - rewrite /Strlen /strlen /strlen_template; repeat pure_exec.
- - repeat split.
- Qed.
-
- Lemma lev_Lev (v: val): exec (lev v) (Lev strlen lev v).
- Proof.
- eapply pure_exec_exec.
- - rewrite /Lev /lev /lev_template; repeat pure_exec.
- - repeat split.
- Qed.
-
- (* C-style null terminated strings *)
-
- Fixpoint string_is (l: loc) (s: list nat) :=
- match s with
- | [] => (∃ q, l ↦{q} #0)
- | n1 :: s' => ⌜ n1 ≠ O ⌝ ∗ (∃ q, l ↦{q} #n1) ∗ string_is (l +ₗ 1) s'
- end%I.
-
- Fixpoint src_string_is (l: loc) (s: list nat) :=
- match s with
- | [] => (∃ q, l ↦s{q} #0)
- | n1 :: s' => ⌜ n1 ≠ O ⌝ ∗ (∃ q, l ↦s{q} #n1) ∗ src_string_is (l +ₗ 1) s'
- end%I.
-
- Lemma string_is_dup l s :
- string_is l s -∗ string_is l s ∗ string_is l s.
- Proof.
- iInduction s as [| n s] "IH" forall (l).
- - iDestruct 1 as (q) "H". iDestruct "H" as "(H1&H2)".
- iSplitL "H1"; iExists _; iFrame.
- - simpl string_is. iDestruct 1 as (Hneq) "(H&Htl)".
- iDestruct "H" as (q) "(H1&H2)".
- iDestruct ("IH" with "Htl") as "(Htl1&Htl2)".
- iSplitL "H1 Htl1"; iFrame "% ∗"; iExists _; iFrame.
- Qed.
-
- Instance string_is_timeless l s : Timeless (string_is l s).
- Proof. revert l. induction s; apply _. Qed.
-
- Lemma src_string_is_dup l s :
- src_string_is l s -∗ src_string_is l s ∗ src_string_is l s.
- Proof.
- iInduction s as [| n s] "IH" forall (l).
- - iDestruct 1 as (q) "H". iDestruct "H" as "(H1&H2)".
- iSplitL "H1"; iExists _; iFrame.
- - simpl src_string_is. iDestruct 1 as (Hneq) "(H&Htl)".
- iDestruct "H" as (q) "(H1&H2)".
- iDestruct ("IH" with "Htl") as "(Htl1&Htl2)".
- iSplitL "H1 Htl1"; iFrame "% ∗"; iExists _; iFrame.
- Qed.
-
- Instance src_string_is_timeless l s : Timeless (src_string_is l s).
- Proof. revert l. induction s; apply _. Qed.
-
- Definition stringRel_is (v1 v2: val) (s: list nat) : iProp Σ :=
- (∃ (l1 l2 : loc), ⌜ v1 = #l1 ∧ v2 = #l2 ⌝ ∗ string_is l1 s ∗ src_string_is l2 s)%I.
-
- Definition strN := nroot.@"str".
-
- Definition imm_stringRel (v1 v2: val) : iProp Σ :=
- (∃ s, inv strN (stringRel_is v1 v2 s))%I.
-
- Lemma stringRel_inv_acc (v1 v2 : val) s :
- inv strN (stringRel_is v1 v2 s) ={⊤}=∗
- stringRel_is v1 v2 s.
- Proof.
- iIntros "Hinv". iInv "Hinv" as ">H" "Hclo".
- iDestruct "H" as (?? (Heq1&Heq2)) "(His1&His2)".
- iDestruct (string_is_dup with "His1") as "(His1&His1')".
- iDestruct (src_string_is_dup with "His2") as "(His2&His2')".
- iMod ("Hclo" with "[His1' His2']"); iModIntro; iExists _, _; iFrame; eauto.
- Qed.
-
- Definition pairRel Pa Pb (v1 v2 : val) : iProp Σ :=
- (∃ v1a v1b v2a v2b, ⌜ v1 = PairV v1a v1b⌝ ∗ ⌜v2 = PairV v2a v2b ⌝ ∗ Pa v1a v2a ∗ Pb v1b v2b)%I.
-
- Definition pair_imm_stringRel := pairRel imm_stringRel imm_stringRel.
-
- Lemma rwp_strlen l s:
- string_is l s -∗
- RWP (strlen #l) ⟨⟨v, ⌜v = #(length s)⌝ ⟩⟩.
- Proof.
- iIntros "Hstr".
- iInduction s as [| n s] "IH" forall (l).
- - rewrite /strlen/strlen_template. wp_pures.
- iDestruct "Hstr" as (?) "H".
- wp_load. wp_pures. wp_pure _; first solve_vals_compare_safe.
- wp_pures. iFrame. eauto.
- - rewrite /strlen/strlen_template. wp_pures. simpl string_is.
- iDestruct "Hstr" as (?) "(H1&Htl)".
- iDestruct "H1" as (?) "Hl".
- wp_load. wp_pures. wp_pure _; first solve_vals_compare_safe.
- case_bool_decide; wp_pure _; eauto.
- { exfalso. eapply H. inversion H1. lia. }
-
- wp_bind ((rec: "strlen" "l" :=
- (λ: "strlen" "l",
- let: "c" := ! "l" in
- if: "c" = #0 then #0 else let: "r" := "strlen" ("l" +ₗ #1) in #1 + "r")%V "strlen" "l")%V
- (#l +ₗ #1))%E.
- wp_pure _.
- iApply (rwp_wand with "[Htl]").
- { iApply ("IH" with "[$]"). }
- iIntros (v) "%". subst. wp_pures. iFrame. iPureIntro.
- do 2 f_equal. simpl. lia.
- Qed.
-
- Lemma eval_strlen l s:
- src_string_is l s -∗
- eval (strlen #l) #(length s).
- Proof.
- iIntros "Hstr" (K) "H".
- iInduction s as [| n s] "IH" forall (K l).
- - rewrite /strlen/strlen_template.
- do 4 src_pure _ in "H".
- iDestruct "Hstr" as (?) "Hstr".
- src_load in "H". do 4 src_pure _ in "H". iApply weak_src_update_return. by iFrame.
- - rewrite /strlen/strlen_template. do 4 src_pure _ in "H". simpl src_string_is.
- iDestruct "Hstr" as (?) "(H1&Htl)".
- iDestruct "H1" as (?) "Hl".
- src_load in "H".
- do 3 src_pure _ in "H".
- case_bool_decide; src_pure _ in "H"; eauto.
- { exfalso. eapply H. inversion H1. lia. }
- src_pure _ in "H".
- src_bind ((rec: "strlen" "l" :=
- (λ: "strlen" "l",
- let: "c" := ! "l" in
- if: "c" = #0 then #0 else let: "r" := "strlen" ("l" +ₗ #1) in #1 + "r")%V "strlen"
- "l")%V
- #(l +ₗ 1))%E in "H".
- iDestruct ("IH" with "Htl H") as "H".
- simpl fill.
- iApply src_update_weak_src_update.
- iApply weak_src_update_bind_r. iFrame.
- iIntros "H".
- do 3 src_pure _ in "H".
- iApply weak_src_update_return.
- replace (S (length s) : Z)%Z with (1 + length s)%Z; first by iFrame.
- rewrite Nat2Z.inj_succ //=. lia.
- Qed.
-
- Lemma stringRel_is_tl (l1 l2 : loc) n s:
- stringRel_is #l1 #l2 (n :: s) -∗
- stringRel_is #(l1 +ₗ 1) #(l2 +ₗ 1) s ∗
- (stringRel_is #(l1 +ₗ 1) #(l2 +ₗ 1) s -∗ stringRel_is #l1 #l2 (n :: s)).
- Proof.
- rewrite /stringRel_is.
- iDestruct 1 as (?? (Heq1&Heq2)) "(H1&H2)".
- inversion Heq1; subst.
- inversion Heq2; subst.
- simpl string_is. simpl src_string_is.
- iDestruct "H1" as (?) "(H1&Htl1)".
- iDestruct "H2" as (?) "(H2&Htl2)".
- iSplitL "Htl1 Htl2".
- { iExists _, _. iSplit; first eauto. iFrame. }
- iIntros "H". iExists _, _. iSplit; first eauto.
- iDestruct "H" as (?? (Heq1'&Heq2')) "(Htl1&Htl2)".
- iSplitL "H1 Htl1".
- { iSplit; eauto. iFrame. inversion Heq1'. subst. eauto. }
- { iSplit; eauto. iFrame. inversion Heq2'. subst. eauto. }
- Qed.
-
- Lemma inv_stringRel_is_tl N (l1 l2 : loc) n s:
- inv N (stringRel_is #l1 #l2 (n :: s)) -∗
- inv N (stringRel_is #(l1 +ₗ 1) #(l2 +ₗ 1) s).
- Proof.
- iIntros "Hinv". iApply (inv_alter_timeless with "Hinv").
- iIntros "!> H1".
- iDestruct (stringRel_is_tl with "H1") as "($&$)".
- Qed.
-
- Lemma min2_spec (n1 n2: nat) :
- ⊢ ⟨⟨⟨ True ⟩⟩⟩ min2 #n1 #n2 ⟨⟨⟨ RET #(min n1 n2) ; True ⟩⟩⟩.
- Proof.
- iIntros "!>" (Φ) "_ HΦ".
- rewrite /min2. wp_pures.
- case_bool_decide; wp_pures.
- - rewrite ->min_l by lia. by iApply "HΦ".
- - rewrite ->min_r by lia. by iApply "HΦ".
- Qed.
-
- Lemma min3_spec (n1 n2 n3: nat) :
- ⊢ ⟨⟨⟨ True ⟩⟩⟩ min3 #n1 #n2 #n3 ⟨⟨⟨ RET #(min (min n1 n2) n3) ; True ⟩⟩⟩.
- Proof.
- iIntros "!>" (Φ) "_ HΦ".
- rewrite /min3. wp_pures.
- repeat (wp_apply min2_spec; auto; iIntros "_").
- Qed.
-
- Lemma eval_min2 (n1 n2: nat) :
- eval (min2 #n1 #n2) #(min n1 n2).
- Proof.
- rewrite /eval. iIntros (K) "Hsrc".
- rewrite /min2. do 4 src_pure _ in "Hsrc".
- case_bool_decide; do 1 src_pure _ in "Hsrc".
- - rewrite ->min_l by lia. by iApply weak_src_update_return.
- - rewrite ->min_r by lia. by iApply weak_src_update_return.
- Qed.
-
- Lemma eval_min3 (n1 n2 n3: nat) :
- eval (min3 #n1 #n2 #n3) #(min (min n1 n2) n3).
- Proof.
- rewrite /eval. iIntros (K) "Hsrc".
- rewrite /min3/min2. do 9 src_pure _ in "Hsrc".
- case_bool_decide; do 1 src_pure _ in "Hsrc".
- - do 4 src_pure _ in "Hsrc".
- case_bool_decide; do 1 src_pure _ in "Hsrc".
- * do 2 rewrite ->min_l by lia. by iApply weak_src_update_return.
- * rewrite ->min_r by lia. by iApply weak_src_update_return.
- - do 4 src_pure _ in "Hsrc".
- case_bool_decide; do 1 src_pure _ in "Hsrc".
- * rewrite ->min_l by lia. rewrite ->min_r by lia. by iApply weak_src_update_return.
- * rewrite ->min_r by lia. by iApply weak_src_update_return.
- Qed.
-
- Lemma string_is_functional va s s' :
- string_is va s -∗
- string_is va s' -∗
- ⌜s = s'⌝.
- Proof.
- iIntros "Hrel1 Hrel2".
- iInduction s as [| n s] "IH" forall (va s').
- { destruct s'; first auto.
- simpl string_is.
- iDestruct "Hrel1" as (?) "Hva".
- iDestruct "Hrel2" as (Hneq) "(Hva'&?)".
- iDestruct "Hva'" as (?) "Hva'".
- iDestruct (mapsto_agree with "[$] [$]") as %Hfalse.
- iPureIntro. exfalso. inversion Hfalse. lia. }
- destruct s'; first auto.
- - simpl string_is.
- iDestruct "Hrel1" as (Hneq) "(Hva&?)".
- iDestruct "Hva" as (?) "Hva".
- iDestruct "Hrel2" as (?) "Hva'".
- iDestruct (mapsto_agree with "[$] [$]") as %Hfalse.
- iPureIntro. exfalso. inversion Hfalse. lia.
- - simpl string_is.
- iDestruct "Hrel1" as (Hneq) "(Hva&?)".
- iDestruct "Hva" as (?) "Hva".
- iDestruct "Hrel2" as (Hneq') "(Hva'&?)".
- iDestruct "Hva'" as (?) "Hva'".
- iDestruct (mapsto_agree with "[$] [$]") as %Heq1.
- iDestruct ("IH" with "[$] [$]") as %Heq2.
- iPureIntro. subst. inversion Heq1; subst. f_equal; lia.
- Qed.
-
- Lemma stringRel_is_functional va vb vb' s s' :
- stringRel_is va vb s -∗
- stringRel_is va vb' s' -∗
- ⌜s = s'⌝.
- Proof.
- iIntros "Hrel1 Hrel2".
- iDestruct "Hrel1" as (?? (->&->)) "(His1&?)".
- iDestruct "Hrel2" as (?? (Heq&?)) "(His2&?)".
- inversion Heq; subst. iApply (string_is_functional with "His1 [$]").
- Qed.
-
- Lemma strlen_fundamental_core slen c K (va vb: val):
- (▷ tf_implements imm_stringRel natRel slen strlen) ∗
- imm_stringRel va vb ∗
- src (fill K (strlen vb)) ⊢
- SEQ (Strlen slen va) ⟨⟨v, ∃ m: nat, ⌜v = #m⌝ ∗ $ c ∗ src (fill K #m) ∗ □ (∀ vb', imm_stringRel va vb' -∗ eval (strlen vb') #m) ⟩⟩.
- Proof.
- iIntros "[#IH [HPre Hsrc]] Hna".
- iDestruct "HPre" as (s) "#Hinv1".
- iApply (rwp_take_step with "[-Hsrc] [Hsrc]"); first done; last first.
- { iApply (step_inv_alloc c with "[] [$Hsrc]").
- iSplitL.
- { iApply exec_src_update; eauto. eapply exec_frame. apply strlen_Strlen. }
- iIntros "H". iExists _. iFrame. iPureIntro.
- rewrite /Strlen/strlen. intros Heq%fill_inj. congruence. }
- iIntros "(Hsrc&$)". iApply rswp_do_step. iNext. rewrite /Strlen.
- iMod (stringRel_inv_acc with "Hinv1") as "Hstr1".
- iDestruct "Hstr1" as (l1a l1b (->&->)) "(Hl1a&Hl1b)".
- destruct s as [| n s].
- {
- iDestruct "Hl1a" as (q1a) "Hl1a".
- iDestruct "Hl1b" as (q1b) "Hl1b".
- wp_load.
- src_load in "Hsrc".
- do 4 src_pure _ in "Hsrc".
- wp_pures. wp_pure _; first solve_vals_compare_safe. wp_pures.
- iFrame. iExists O. iSplit; first eauto. iFrame.
- iModIntro. rewrite /eval. iIntros (vb') "#HPre". iIntros (K') "H".
- iDestruct "HPre" as (s') "#Hinv1'".
- iApply fupd_src_update.
- iMod (stringRel_inv_acc with "Hinv1") as "Hstr1".
- iMod (stringRel_inv_acc with "Hinv1'") as "Hstr1'".
- iDestruct (stringRel_is_functional with "Hstr1' Hstr1") as %->.
- iModIntro.
- iClear "Hstr1".
- iRename "Hstr1'" into "Hstr1".
- iDestruct "Hstr1" as (?? (->&->)) "(Hl1a&Hl1b)".
- iDestruct "Hl1a" as (q1a') "Hl1a".
- iDestruct "Hl1b" as (q1b') "Hl1b".
- rewrite /strlen/strlen_template.
- do 4 src_pure _ in "H".
- src_load in "H".
- do 4 src_pure _ in "H".
- iApply weak_src_update_return; by iFrame.
- }
- simpl string_is. simpl src_string_is.
- iDestruct "Hl1a" as (H1neq0) "(Hpts1a&Hl1a)".
- iDestruct "Hpts1a" as (?) "Hpts1a".
- iDestruct "Hl1b" as (H1neq0') "(Hpts1b&Hl1b)".
- iDestruct "Hpts1b" as (?) "Hpts1b".
- wp_load. wp_pures. wp_pure _; first solve_vals_compare_safe.
- src_load in "Hsrc".
- do 3 src_pure _ in "Hsrc".
- rewrite bool_decide_false; last first.
- { intros Heq. inversion Heq. lia. }
- wp_pures.
- do 2 src_pure _ in "Hsrc".
- src_bind (strlen _)%E in "Hsrc".
- iSpecialize ("IH" $! #(l1a +ₗ 1) _ O with "[] Hsrc [$]").
- { iExists _. iApply inv_stringRel_is_tl. eauto. }
- wp_bind (slen _).
- iApply (rwp_wand with "[IH]").
- { wp_apply "IH". }
- iIntros (v) "($&H)".
- iDestruct "H" as (? (m&Heq1&Heq2)) "(_&Hsrc&#Heval')".
- subst. simpl fill. do 3 src_pure _ in "Hsrc". wp_pures. iExists (1 + m)%nat.
- iSplit.
- { iPureIntro. do 2 f_equal. lia. }
- simpl.
- iFrame.
- replace (1 + Z.of_nat m) with (Z.of_nat (S m)) by lia. iFrame.
- iModIntro. rewrite /eval. iIntros (vb') "#HPre". iIntros (K') "H".
- iDestruct "HPre" as (s') "#Hinv1'".
- iApply fupd_src_update.
- iMod (stringRel_inv_acc with "Hinv1") as "Hstr1".
- iMod (stringRel_inv_acc with "Hinv1'") as "Hstr1'".
- iDestruct (stringRel_is_functional with "Hstr1' Hstr1") as %->.
- iModIntro.
- iClear "Hstr1".
- iRename "Hstr1'" into "Hstr1".
- iDestruct "Hstr1" as (?? (Heq1a&Heq1b)) "(Hl1a&Hl1b)".
- simpl src_string_is.
- iDestruct "Hl1b" as (H1neq0'') "(Hpts1b&Hl1b)".
- iDestruct "Hpts1b" as (?) "Hpts1b".
- rewrite /strlen/strlen_template.
- do 4 src_pure _ in "H".
- rewrite Heq1b.
- src_load in "H".
- do 3 src_pure _ in "H".
- rewrite bool_decide_false; last first.
- { intros Heq. inversion Heq. lia. }
- do 2 src_pure _ in "H".
- src_bind (_ (#_)%V)%E in "H".
- rewrite fill_cons. simpl ectxi_language.fill_item.
- iApply src_update_weak_src_update.
- iDestruct ("Heval'" with "[]") as (r2') "(Heval''&Hrel)"; [|
- iDestruct "Hrel" as %[? (Heq2&->)]; iDestruct ("Heval''" with "H") as "H"].
- { iExists _. iApply inv_stringRel_is_tl. eauto. }
- simpl fill.
- iApply (src_update_bind with "[$H]").
- iIntros "H".
- simpl.
- rewrite -Heq2.
- do 3 src_pure _ in "H".
- replace (1 + Z.of_nat m) with (Z.of_nat (S m)) by lia.
- iApply weak_src_update_return; by iFrame.
- Qed.
-
- Lemma lev_fundamental_core g slen c K (va vb: val):
- (▷ tf_implements imm_stringRel natRel slen strlen) ∗
- (▷ tf_implements pair_imm_stringRel natRel g lev) ∗
- pair_imm_stringRel va vb ∗
- src (fill K (lev vb)) ⊢
- SEQ (Lev slen g va) ⟨⟨v, ∃ m: nat, ⌜v = #m⌝ ∗ $ c ∗ src (fill K #m) ∗ □ (∀ vb', pair_imm_stringRel va vb' -∗ eval (lev vb') #m) ⟩⟩.
- Proof.
- iIntros "[#Hstrlen [#IH [HPre Hsrc]]] Hna".
- iDestruct "HPre" as (v1a v2a v1b v2b Heq1 Heq2) "(Hs1&Hs2)". subst.
- iDestruct "Hs1" as (s1) "#Hinv1".
- iDestruct "Hs2" as (s2) "#Hinv2".
- iApply (rwp_take_step with "[-Hsrc] [Hsrc]"); first done; last first.
- { iApply (step_inv_alloc c with "[] [$Hsrc]").
- iSplitL.
- { iApply exec_src_update; eauto. eapply exec_frame. apply lev_Lev. }
- iIntros "H". iExists _. iFrame. iPureIntro.
- rewrite /Lev/lev. intros Heq%fill_inj. congruence. }
- iIntros "(Hsrc&$)". iApply rswp_do_step. iNext. rewrite /Lev.
- wp_pures.
- iMod (stringRel_inv_acc with "Hinv1") as "Hstr1".
- iMod (stringRel_inv_acc with "Hinv2") as "Hstr2".
- destruct s1 as [| n1 s1].
- {
- iDestruct "Hstr1" as (l1a l1b (->&->)) "(Hl1a&Hl1b)".
- iDestruct "Hstr2" as (l2a l2b (->&->)) "(Hl2a&Hl2b)".
- iDestruct "Hl1a" as (q1a) "Hl1a".
- iDestruct "Hl1b" as (q1b) "Hl1b".
- do 6 src_pure _ in "Hsrc".
- src_load in "Hsrc".
- do 4 src_pure _ in "Hsrc".
- iDestruct ("Hstrlen" $! _ _ O with "[] [$Hsrc]") as "Hstr1".
- { rewrite /imm_stringRel. iExists _; eauto. }
- wp_load. wp_pures. wp_pure _; first solve_vals_compare_safe. wp_pures.
- iApply (rwp_wand with "[Hstr1 Hna]").
- { wp_apply ("Hstr1" with "[$]"). }
- iIntros (v) "(Hna&H)".
- iDestruct "H" as (? (r1&Heq1&Heq2)) "(_&Hsrc&#Heval1)".
- iFrame.
- subst. wp_pures.
- simpl fill. iExists _. iSplit; first eauto. iFrame.
- iModIntro. rewrite /eval. iIntros (vb') "#HPre". iIntros (K') "H".
- iDestruct "HPre" as (v1a v2a v1b v2b Heq1 Heq2) "(Hs1&Hs2)". subst.
- symmetry in Heq1. inversion_clear Heq1. subst.
- iDestruct "Hs1" as (s1') "#Hinv1'".
- iDestruct "Hs2" as (s2') "#Hinv2'".
- iApply fupd_src_update.
- iMod (stringRel_inv_acc with "Hinv1") as "Hstr1".
- iMod (stringRel_inv_acc with "Hinv2") as "Hstr2".
- iMod (stringRel_inv_acc with "Hinv1'") as "Hstr1'".
- iMod (stringRel_inv_acc with "Hinv2'") as "Hstr2'".
- iDestruct (stringRel_is_functional with "Hstr1' Hstr1") as %->.
- iDestruct (stringRel_is_functional with "Hstr2' Hstr2") as %->.
- iClear "Hstr1 Hstr2".
- iRename "Hstr1'" into "Hstr1".
- iRename "Hstr2'" into "Hstr2".
- iDestruct "Hstr1" as (?? (->&->)) "(Hl1a&Hl1b)".
- iDestruct "Hstr2" as (?? (->&->)) "(Hl2a&Hl2b)".
- iDestruct "Hl1a" as (q1a') "Hl1a".
- iDestruct "Hl1b" as (q1b') "Hl1b".
- iModIntro.
- rewrite /Lev/lev/lev_template.
- do 12 src_pure _ in "H".
- src_load in "H".
- do 4 src_pure _ in "H".
- iApply src_update_weak_src_update.
- iDestruct ("Heval1" with "[]") as (v') "(Heval1'&Hrel)"; last first.
- { iDestruct "Hrel" as %[? (->&->)]. iApply "Heval1'". eauto. }
- rewrite /imm_stringRel. eauto.
- }
- iDestruct "Hstr1" as (l1a l1b (->&->)) "(Hl1a&Hl1b)".
- iDestruct "Hstr2" as (l2a l2b (->&->)) "(Hl2a&Hl2b)".
- simpl string_is.
- iDestruct "Hl1a" as (H1neq0) "(Hpts1a&Hl1a)".
- iDestruct "Hpts1a" as (?) "Hpts1a".
- wp_load. wp_pures. wp_pure _; first solve_vals_compare_safe.
- rewrite bool_decide_false //; last first.
- { intros Heq. inversion Heq. lia. }
- wp_pures.
- destruct s2 as [| n2 s2].
- {
- simpl src_string_is.
- iDestruct "Hl2a" as (q2a) "Hl2a".
- iDestruct "Hl1b" as (H1neq0') "(Hpts1b&Hl1b)".
- iDestruct "Hpts1b" as (?) "Hpts1b".
- wp_load. wp_pures. wp_pure _; first solve_vals_compare_safe.
- wp_pure _.
- do 6 src_pure _ in "Hsrc".
- src_load in "Hsrc".
- do 3 src_pure _ in "Hsrc".
- rewrite bool_decide_false //; last first.
- { intros Heq. inversion Heq. lia. }
- do 1 src_pure _ in "Hsrc".
- iDestruct "Hl2b" as (q2b) "Hl2b".
- src_load in "Hsrc".
- do 4 src_pure _ in "Hsrc".
- iDestruct ("Hstrlen" $! _ _ O with "[] [$Hsrc]") as "Hstr2".
- { rewrite /imm_stringRel. iExists _; eauto. }
- iApply (rwp_wand with "[Hstr2 Hna]").
- { wp_apply ("Hstr2" with "[$]"). }
- iIntros (v) "(Hna&H)".
- iDestruct "H" as (? (r1&Heq1&Heq2)) "(_&Hsrc&#Heval1)".
- iFrame.
- subst. wp_pures.
- simpl fill. iExists _. iSplit; first eauto. iFrame.
- iModIntro. rewrite /eval. iIntros (vb') "#HPre". iIntros (K') "H".
- iDestruct "HPre" as (v1a v2a v1b v2b Heq1 Heq2) "(Hs1&Hs2)". subst.
- symmetry in Heq1. inversion_clear Heq1. subst.
- iDestruct "Hs1" as (s1') "#Hinv1'".
- iDestruct "Hs2" as (s2') "#Hinv2'".
- iApply fupd_src_update.
- iMod (stringRel_inv_acc with "Hinv1") as "Hstr1".
- iMod (stringRel_inv_acc with "Hinv2") as "Hstr2".
- iMod (stringRel_inv_acc with "Hinv1'") as "Hstr1'".
- iMod (stringRel_inv_acc with "Hinv2'") as "Hstr2'".
- iDestruct (stringRel_is_functional with "Hstr1' Hstr1") as %->.
- iDestruct (stringRel_is_functional with "Hstr2' Hstr2") as %->.
- iClear "Hstr1 Hstr2".
- iRename "Hstr1'" into "Hstr1".
- iRename "Hstr2'" into "Hstr2".
- iDestruct "Hstr1" as (?? (->&->)) "(Hl1a&Hl1b)".
- iDestruct "Hstr2" as (?? (->&->)) "(Hl2a&Hl2b)".
- simpl src_string_is.
- iDestruct "Hl1b" as (H1neq0'') "(Hpts1b&Hl1b)".
- iDestruct "Hpts1b" as (?) "Hpts1b".
- rewrite /Lev/lev/lev_template.
- iModIntro.
- do 12 src_pure _ in "H".
- src_load in "H".
- do 3 src_pure _ in "H".
- rewrite bool_decide_false //; last first.
- { intros Heq. inversion Heq. lia. }
- do 1 src_pure _ in "H".
- iDestruct "Hl2b" as (q2b') "Hl2b".
- src_load in "H".
- do 4 src_pure _ in "H".
- iApply src_update_weak_src_update.
- iDestruct ("Heval1" with "[]") as (v') "(Heval1'&Hrel)"; last first.
- { iDestruct "Hrel" as %[? (->&->)]. iApply "Heval1'". eauto. }
- rewrite /imm_stringRel. eauto.
- }
- simpl string_is.
- iDestruct "Hl2a" as (H2neq0) "(Hpts2a&Hl2a)".
- iDestruct "Hpts2a" as (q2a) "Hpts2a".
- wp_load. wp_pures. wp_pure _; first solve_vals_compare_safe.
- rewrite bool_decide_false //; last first.
- { intros Heq. inversion Heq. lia. }
- wp_pures. wp_pure _; first solve_vals_compare_safe.
- rewrite /tf_implements.
- simpl src_string_is.
- iDestruct "Hl1b" as (H1neq0') "(Hpts1b&Hl1b)".
- iDestruct "Hpts1b" as (?) "Hpts1b".
- iDestruct "Hl2b" as (H2neq0') "(Hpts2b&Hl2b)".
- iDestruct "Hpts2b" as (?) "Hpts2b".
- do 6 src_pure _ in "Hsrc".
- src_load in "Hsrc".
- do 3 src_pure _ in "Hsrc".
- rewrite bool_decide_false //; last first.
- { intros Heq. inversion Heq. lia. }
- do 1 src_pure _ in "Hsrc".
- src_load in "Hsrc".
- do 3 src_pure _ in "Hsrc".
- rewrite bool_decide_false //; last first.
- { intros Heq. inversion Heq. lia. }
- do 2 src_pure _ in "Hsrc".
- iAssert (pair_imm_stringRel (#(l1a +ₗ 1), #(l2a +ₗ 1)) (#(l1b +ₗ 1), #(l2b +ₗ 1))) as "#Hshift_both".
- {
- iExists #(l1a +ₗ 1), #(l2a +ₗ 1), _, _.
- rewrite /imm_stringRel.
- iSplit; first eauto.
- iSplit; first eauto.
- iSplitL "Hinv1".
- { iExists _. iApply inv_stringRel_is_tl. iApply "Hinv1". }
- { iExists _. iApply inv_stringRel_is_tl. iApply "Hinv2". }
- }
- iAssert (pair_imm_stringRel ((#l1a, #(l2a +ₗ 1)))%V ((#l1b, #(l2b +ₗ 1)))%V) as "#Hshift_right".
- {
- iExists #(l1a), #(l2a +ₗ 1), _, _.
- rewrite /imm_stringRel.
- iSplit; first eauto.
- iSplit; first eauto.
- iSplitL "Hinv1".
- { iExists _. iApply "Hinv1". }
- { iExists _. iApply inv_stringRel_is_tl. iApply "Hinv2". }
- }
- iAssert (pair_imm_stringRel (#(l1a +ₗ 1), #l2a) (#(l1b +ₗ 1), #l2b)) as "#Hshift_left".
- {
- iExists #(l1a +ₗ 1), #(l2a), _, _.
- rewrite /imm_stringRel.
- iSplit; first eauto.
- iSplit; first eauto.
- iSplitL "Hinv1".
- { iExists _. iApply inv_stringRel_is_tl. iApply "Hinv1". }
- { iExists _. iApply "Hinv2". }
- }
- case_bool_decide.
- {
- do 2 wp_pure _.
- do 4 src_pure _ in "Hsrc".
- rewrite /tf_implements.
- iSpecialize ("IH" $! (#(l1a +ₗ 1), #(l2a +ₗ 1))%V _ O with "[$] Hsrc [$]").
- iApply (rwp_wand with "[IH]").
- { wp_apply "IH". }
- iIntros (v) "($&H)".
- iDestruct "H" as (? (m&Heq1&Heq2)) "(_&Hsrc&#Heval')".
- subst. iExists m. iSplit; first done.
- iFrame.
- iModIntro. rewrite /eval. iIntros (vb') "#HPre". iIntros (K') "H".
- iDestruct "HPre" as (v1a v2a v1b v2b Heq1 Heq2) "(Hs1&Hs2)". subst.
- symmetry in Heq1. inversion_clear Heq1. subst.
- iDestruct "Hs1" as (s1') "#Hinv1'".
- iDestruct "Hs2" as (s2') "#Hinv2'".
- iApply fupd_src_update.
- iMod (stringRel_inv_acc with "Hinv1") as "Hstr1".
- iMod (stringRel_inv_acc with "Hinv2") as "Hstr2".
- iMod (stringRel_inv_acc with "Hinv1'") as "Hstr1'".
- iMod (stringRel_inv_acc with "Hinv2'") as "Hstr2'".
- iDestruct (stringRel_is_functional with "Hstr1' Hstr1") as %->.
- iDestruct (stringRel_is_functional with "Hstr2' Hstr2") as %->.
- iClear "Hstr1 Hstr2".
- iRename "Hstr1'" into "Hstr1".
- iRename "Hstr2'" into "Hstr2".
- iModIntro.
- rewrite /Lev/lev/lev_template.
- do 12 src_pure _ in "H".
- iDestruct "Hstr1" as (?? (Heq1a&Heq1b)) "(Hl1a&Hl1b)".
- iDestruct "Hstr2" as (?? (Heq2a&Heq2b)) "(Hl2a&Hl2b)".
- simpl src_string_is.
- iDestruct "Hl1b" as (H1neq0'') "(Hpts1b&Hl1b)".
- iDestruct "Hpts1b" as (?) "Hpts1b".
- rewrite ?Heq1a ?Heq1b ?Heq2a ?Heq2b.
- src_load in "H".
- do 3 src_pure _ in "H".
- rewrite bool_decide_false //; last first.
- { intros Heq. inversion Heq. lia. }
- do 1 src_pure _ in "H".
- iDestruct "Hl2b" as (H2neq0'') "(Hpts2b&Hl2b)".
- iDestruct "Hpts2b" as (?) "Hpts2b".
- src_load in "H".
- do 3 src_pure _ in "H".
- rewrite bool_decide_false //; last first.
- { intros Heq. inversion Heq. lia. }
- do 2 src_pure _ in "H".
- rewrite bool_decide_true //; [].
- do 4 src_pure _ in "H".
- rewrite -?Heq1a -?Heq1b -?Heq2a -?Heq2b.
- iApply src_update_weak_src_update.
- iDestruct ("Heval'" with "[]") as (v') "(Heval1&Hrel)"; last first.
- { iDestruct "Hrel" as %[? (->&->)]. iApply "Heval1". eauto. }
- {
- iExists _, _, _, _; repeat (iSplit; try iExists _; eauto).
- { iApply inv_stringRel_is_tl. rewrite Heq1b. eauto. }
- { iApply inv_stringRel_is_tl. rewrite Heq2b. eauto. }
- }
- }
- do 3 wp_pure _.
- do 3 src_pure _ in "Hsrc".
- src_bind (lev _) in "Hsrc".
- iDestruct ("IH" $! _ _ O with "Hshift_right Hsrc [$]") as "IH1".
- wp_bind (g _).
- iApply (rwp_wand with "[IH1]").
- { wp_apply "IH1". }
- iIntros (v) "(Hna&H)".
- iDestruct "H" as (? (r1&Heq1&Heq2)) "(_&Hsrc&#Heval1)".
- subst. wp_pures.
- simpl fill.
- do 1 src_pure _ in "Hsrc".
-
- do 3 src_pure _ in "Hsrc".
- src_bind (lev _) in "Hsrc".
- iDestruct ("IH" $! _ _ O with "Hshift_left Hsrc [$]") as "IH2".
- wp_bind (g _).
- iApply (rwp_wand with "[IH2]").
- { wp_apply "IH2". }
- iIntros (v) "(Hna&H)".
- iDestruct "H" as (? (r2&Heq1&Heq2)) "(_&Hsrc&#Heval2)".
- subst. wp_pures.
- simpl fill.
- do 2 src_pure _ in "Hsrc".
-
- do 3 src_pure _ in "Hsrc".
- src_bind (lev _) in "Hsrc".
- iDestruct ("IH" $! _ _ O with "Hshift_both Hsrc [$]") as "IH2".
- wp_bind (g _).
- iApply (rwp_wand with "[IH2]").
- { wp_apply "IH2". }
- iIntros (v) "(Hna&H)".
- iDestruct "H" as (? (r3&Heq1&Heq2)) "(_&Hsrc&#Heval3)".
- subst. wp_pures.
- simpl fill.
- do 2 src_pure _ in "Hsrc".
-
- wp_bind (min3 _ _ _).
- wp_apply (min3_spec with "[//]").
- iIntros "_".
- src_bind (min3 _ _ _) in "Hsrc".
- iDestruct (eval_min3 with "Hsrc") as "Hsrc".
- iApply (rwp_weaken with "[-Hsrc] Hsrc"); first done.
- iIntros "Hsrc".
- simpl fill.
- src_pure _ in "Hsrc".
- wp_pures. iFrame. iExists (1 + (min (min r1 r2) r3)%nat)%nat.
- iSplit.
- { iPureIntro. do 2 f_equal. lia. }
- assert (#(1 + (r1 `min` r2) `min` r3)%nat =
- #(1 + ((r1 `min` r2) `min` r3)%nat)) as ->.
- { do 2 f_equal. lia. }
- iFrame.
- iModIntro. rewrite /eval. iIntros (vb') "#HPre". iIntros (K') "H".
- iDestruct "HPre" as (v1a v2a v1b v2b Heq1 Heq2) "(Hs1&Hs2)". subst.
- symmetry in Heq1. inversion_clear Heq1. subst.
- iDestruct "Hs1" as (s1') "#Hinv1'".
- iDestruct "Hs2" as (s2') "#Hinv2'".
- iApply fupd_src_update.
- iMod (stringRel_inv_acc with "Hinv1") as "Hstr1".
- iMod (stringRel_inv_acc with "Hinv2") as "Hstr2".
- iMod (stringRel_inv_acc with "Hinv1'") as "Hstr1'".
- iMod (stringRel_inv_acc with "Hinv2'") as "Hstr2'".
- iDestruct (stringRel_is_functional with "Hstr1' Hstr1") as %->.
- iDestruct (stringRel_is_functional with "Hstr2' Hstr2") as %->.
- iClear "Hstr1 Hstr2".
- iRename "Hstr1'" into "Hstr1".
- iRename "Hstr2'" into "Hstr2".
- iModIntro.
- rewrite /Lev/lev/lev_template.
- do 12 src_pure _ in "H".
- iDestruct "Hstr1" as (?? (Heq1a&Heq1b)) "(Hl1a&Hl1b)".
- iDestruct "Hstr2" as (?? (Heq2a&Heq2b)) "(Hl2a&Hl2b)".
- simpl src_string_is.
- iDestruct "Hl1b" as (H1neq0'') "(Hpts1b&Hl1b)".
- iDestruct "Hpts1b" as (?) "Hpts1b".
- rewrite ?Heq1a ?Heq1b ?Heq2a ?Heq2b.
- src_load in "H".
- do 3 src_pure _ in "H".
- rewrite bool_decide_false //; last first.
- { intros Heq. inversion Heq. lia. }
- do 1 src_pure _ in "H".
- iDestruct "Hl2b" as (H2neq0'') "(Hpts2b&Hl2b)".
- iDestruct "Hpts2b" as (?) "Hpts2b".
- src_load in "H".
- do 3 src_pure _ in "H".
- rewrite bool_decide_false //; last first.
- { intros Heq. inversion Heq. lia. }
- do 2 src_pure _ in "H".
- rewrite bool_decide_false //; [].
- do 1 src_pure _ in "H".
- do 1 src_pure _ in "H".
- do 1 src_pure _ in "H".
- src_bind (_ (#_, #_)%V)%E in "H".
- (* TODO: can't seem to bind this properly otherwise *)
- rewrite fill_cons. simpl ectxi_language.fill_item.
- iApply src_update_weak_src_update.
- iDestruct ("Heval1" with "[]") as (r1') "(Heval1'&Hrel)"; [|
- iDestruct "Hrel" as %[? (Heq1&->)]; iDestruct ("Heval1'" with "H") as "H"].
- {
- iExists _, _, _, _; repeat (iSplit; try iExists _; eauto).
- { iApply inv_stringRel_is_tl. rewrite Heq1b Heq2a. eauto. }
- }
- iApply (src_update_bind with "[$H]").
- iIntros "H".
- simpl.
- do 2 src_pure _ in "H".
-
- do 2 src_pure _ in "H".
- src_bind (_ (#_, #_)%V)%E in "H".
- (* TODO: can't seem to bind this properly otherwise *)
- rewrite fill_cons. simpl ectxi_language.fill_item.
- iApply src_update_weak_src_update.
- iDestruct ("Heval2" with "[]") as (r2') "(Heval2'&Hrel)"; [|
- iDestruct "Hrel" as %[? (Heq2&->)]; iDestruct ("Heval2'" with "H") as "H"].
- {
- iExists _, _, _, _; repeat (iSplit; try iExists _; eauto).
- { iApply inv_stringRel_is_tl. rewrite Heq1a Heq2b. eauto. }
- }
- iApply (src_update_bind with "[$H]").
- iIntros "H".
- simpl.
- do 2 src_pure _ in "H".
-
- do 3 src_pure _ in "H".
- src_bind (_ (#_, #_)%V)%E in "H".
- (* TODO: can't seem to bind this properly otherwise *)
- rewrite fill_cons. simpl ectxi_language.fill_item.
- iApply src_update_weak_src_update.
- iDestruct ("Heval3" with "[]") as (r3') "(Heval3'&Hrel)"; [|
- iDestruct "Hrel" as %[? (Heq3&->)]; iDestruct ("Heval3'" with "H") as "H"].
- {
- iExists _, _, _, _; repeat (iSplit; try iExists _; eauto).
- { iApply inv_stringRel_is_tl. rewrite Heq1a Heq2b. eauto. }
- { iApply inv_stringRel_is_tl. rewrite Heq1b Heq2a. eauto. }
- }
- iApply (src_update_bind with "[$H]").
- iIntros "H".
- simpl.
- do 2 src_pure _ in "H".
- rewrite -Heq1 -Heq2 -Heq3.
-
- src_bind (min3 _ _ _) in "H".
- iDestruct (eval_min3 with "[$]") as "H".
- iApply src_update_weak_src_update.
- iApply (src_update_bind with "[$H]").
- iIntros "H". simpl.
- do 1 src_pure _ in "H".
- iApply weak_src_update_return.
- iApply "H".
- Qed.
-
- Definition eq_pair : val := (λ: "n1" "n2", BinOp AndOp (Fst "n1" = Fst "n2") (Snd "n1" = Snd "n2")).
-
- Lemma strlen_sound :
- ⊢ tf_implements imm_stringRel natRel strlen strlen.
- Proof.
- iLöb as "IH".
- iModIntro. iIntros (?? c K) "#HPre Hsrc Hna".
- iDestruct "HPre" as (s) "#Hinv1".
- rewrite {4}/strlen. wp_pure _. rewrite {1}/strlen_template. do 3 wp_pure _.
- iPoseProof (strlen_fundamental_core strlen c K _ with "[Hsrc IH] Hna") as "H".
- { iFrame "Hsrc IH". iExists _. eauto. }
- iApply (rwp_wand with "H").
- iIntros (v) "($&H)".
- iDestruct "H" as (m ->) "(Hsrc&Hc&#Hexec)". iExists _. iFrame.
- iSplitR; first eauto.
- iModIntro. iIntros (x) "#Hrel". iExists #m. iSplit; last eauto.
- iModIntro. iApply "Hexec". eauto.
- Qed.
-
- Lemma strlen_template_sound g:
- ▷ tf_implements imm_stringRel natRel g strlen ⊢
- SEQ (strlen_template g) ⟨⟨h, tf_implements imm_stringRel natRel h strlen⟩⟩.
- Proof.
- iIntros "#IH Hna". rewrite /strlen_template. wp_pures. iFrame.
- iModIntro; iIntros (? ? c K) "HPre Hsrc Hna".
- wp_pure _.
- iDestruct "HPre" as (s1) "#Hinv1".
- iPoseProof (strlen_fundamental_core g c K _ with "[$Hsrc $IH] Hna") as "H".
- { iExists _. repeat iSplit; try iExists _; eauto. }
- rewrite /Strlen.
- iApply (rwp_wand with "H").
- iIntros (v) "($&H)".
- iDestruct "H" as (m ->) "(Hsrc&Hc&#Hexec)". iExists _. iFrame.
- iSplitR; first eauto.
- iModIntro. iIntros (x) "#Hrel". iExists #m. iSplit; last eauto.
- iModIntro. iApply "Hexec". eauto.
- Qed.
-
- Lemma lev_sound:
- ⊢ tf_implements pair_imm_stringRel natRel lev lev.
- Proof.
- iLöb as "IH".
- iModIntro. iIntros (v v' c K) "#HPre Hsrc Hna".
- iDestruct "HPre" as (v1a v2a v1b v2b Heq1 Heq2) "(Hs1&Hs2)". subst.
- iDestruct "Hs1" as (s1) "#Hinv1".
- iDestruct "Hs2" as (s2) "#Hinv2".
- rewrite {4}/lev. wp_pure _. rewrite {1}/lev_template. do 3 wp_pure _.
- iPoseProof (lev_fundamental_core lev strlen c K (v1a, v2a)%V with "[Hsrc IH] Hna") as "H".
- { iFrame "Hsrc". iSplitL.
- { iNext. iApply strlen_sound. }
- iFrame "IH".
- { iExists _, _, _, _. repeat iSplit; try iExists _; eauto. }
- }
- rewrite /Lev/lev.
- do 2 wp_pure _.
- iApply (rwp_wand with "H").
- iIntros (v) "($&H)".
- iDestruct "H" as (m ->) "(Hsrc&Hc&#Hexec)". iExists _. iFrame.
- iSplitR; first eauto.
- iModIntro. iIntros (x) "#Hrel". iExists #m. iSplit; last eauto.
- iModIntro. iApply "Hexec". eauto.
- Qed.
-
- Lemma lev_template'_sound g slen:
- ▷ tf_implements imm_stringRel natRel slen strlen ∗
- ▷ tf_implements pair_imm_stringRel natRel g lev ⊢
- SEQ (lev_template' slen g) ⟨⟨h, tf_implements pair_imm_stringRel natRel h lev⟩⟩.
- Proof.
- iIntros "[#Hslen #IH] Hna". rewrite /lev_template'. wp_pures. iFrame.
- iModIntro; iIntros (n n' c K) "HPre Hsrc Hna".
- wp_pure _.
- iDestruct "HPre" as (v1a v2a v1b v2b Heq1 Heq2) "(Hs1&Hs2)". subst.
- iDestruct "Hs1" as (s1) "#Hinv1".
- iDestruct "Hs2" as (s2) "#Hinv2".
- iPoseProof (lev_fundamental_core g slen c K (v1a, v2a)%V with "[$Hslen $Hsrc $IH] Hna") as "H".
- { iExists _, _, _, _. repeat iSplit; try iExists _; eauto. }
- rewrite /Lev.
- iApply (rwp_wand with "H").
- iIntros (v) "($&H)".
- iDestruct "H" as (m ->) "(Hsrc&Hc&#Hexec)". iExists _. iFrame.
- iSplitR; first eauto.
- iModIntro. iIntros (x) "#Hrel". iExists #m. iSplit; last eauto.
- iModIntro. iApply "Hexec". eauto.
- Qed.
-
- (* memoized versions *)
- Context `{Sync: !inG Σ (authR (optionUR (exclR (gmapO val (valO SI)))))}.
- Context `{Fin: FiniteBoundedExistential SI}.
-
- Lemma lev_memoized:
- $ (1%nat) ⊢ SEQ (memoize eq_pair lev) ⟨⟨ h, tf_implements pair_imm_stringRel natRel h lev ⟩⟩.
- Proof using Sync Fin.
- (* XXX: the iApply fails over typeclass resolution (?) if we don't do iStartProof *)
- iStartProof. iIntros "Hc".
- iApply (tf_memoize_spec _ _ (λ x, ∃ (l1 l2: loc), ⌜ x = (#l1, #l2)%V ⌝)%I (λ x1 x2, ⌜ x1 = x2 ⌝)%I);
- [| | iSplit].
- - iIntros (??) "HPre".
- iDestruct "HPre" as (v1a v2a v1b v2b Heq1 Heq2) "(Hs1&Hs2)". subst.
- iDestruct "Hs1" as (s1) "#Hinv1".
- iDestruct "Hs2" as (s2) "#Hinv2".
- iMod (stringRel_inv_acc with "Hinv1") as "Hstr1".
- iMod (stringRel_inv_acc with "Hinv2") as "Hstr2".
- iDestruct "Hstr1" as (?? (->&->)) "(Hl1a&Hl1b)".
- iDestruct "Hstr2" as (?? (->&->)) "(Hl2a&Hl2b)".
- eauto.
- - iIntros (??? ->); auto.
- - rewrite /eqfun. iIntros (??). iModIntro. iIntros (Φ) "(H1&H2) H".
- iDestruct "H1" as %[l1 [l2 ->]].
- iDestruct "H2" as %[l1' [l2' ->]].
- rewrite /eq_pair.
- wp_pures.
- wp_pure _; first solve_vals_compare_safe.
- wp_pure _.
- case_bool_decide;
- (wp_pures; wp_pure _; first solve_vals_compare_safe;
- case_bool_decide; (wp_pures; iApply "H"; iSplitL; [| iSplitL]; eauto; iPureIntro; congruence)).
- - iFrame. iApply lev_sound.
- Qed.
-
- Lemma lev_deep_memoized:
- $ (1%nat) ∗ $ (1%nat) ⊢
- SEQ (let: "strlen" := mem_rec eq_heaplang strlen_template in
- mem_rec eq_pair (lev_template "strlen"))
- ⟨⟨ h, tf_implements pair_imm_stringRel natRel h lev ⟩⟩.
- Proof using Sync Fin.
- iStartProof. iIntros "(Hc1&Hc2) Hna".
- wp_bind (mem_rec _ _).
- iPoseProof (tf_mem_rec_spec imm_stringRel natRel
- (λ x, ∃ l1 : loc, ⌜ x = #l1%V ⌝)%I (λ x1 x2, ⌜ x1 = x2 ⌝)%I with "[Hc1] [$Hna]")
- as "IH"; last (iApply (rwp_wand with "IH")).
- { iIntros (??) "HPre". iDestruct "HPre" as (s1) "#Hinv1".
- iMod (stringRel_inv_acc with "Hinv1") as "Hstr1".
- iDestruct "Hstr1" as (?? (->&->)) "(Hl1a&Hl1b)". eauto. }
- { iIntros (??? ->); auto. }
- { iSplit.
- { rewrite /eqfun. iIntros (??). iModIntro. iIntros (Φ) "(H1&H2) H".
- iDestruct "H1" as %[l1 ->].
- iDestruct "H2" as %[l1' ->].
- rewrite /eq_heaplang.
- wp_pures.
- wp_pure _; first solve_vals_compare_safe.
- case_bool_decide; eauto; iApply "H"; eauto. }
- iFrame.
- iModIntro. iIntros.
- iApply strlen_template_sound. eauto.
- }
- iIntros (h) "(Hna&#Himpl)".
- wp_pures.
- rewrite /lev_template. wp_pure _. wp_pure _.
- iApply (tf_mem_rec_spec _ _ (λ x, ∃ (l1 l2: loc), ⌜ x = (#l1, #l2)%V ⌝)%I (λ x1 x2, ⌜ x1 = x2 ⌝)%I with "[Hc2] [$Hna]"); [| | iSplit].
- - iIntros (??) "HPre".
- iDestruct "HPre" as (v1a v2a v1b v2b Heq1 Heq2) "(Hs1&Hs2)". subst.
- iDestruct "Hs1" as (s1) "#Hinv1".
- iDestruct "Hs2" as (s2) "#Hinv2".
- iMod (stringRel_inv_acc with "Hinv1") as "Hstr1".
- iMod (stringRel_inv_acc with "Hinv2") as "Hstr2".
- iDestruct "Hstr1" as (?? (->&->)) "(Hl1a&Hl1b)".
- iDestruct "Hstr2" as (?? (->&->)) "(Hl2a&Hl2b)".
- eauto.
- - iIntros (??? ->); auto.
- - rewrite /eqfun. iIntros (??). iModIntro. iIntros (Φ) "(H1&H2) H".
- iDestruct "H1" as %[l1 [l2 ->]].
- iDestruct "H2" as %[l1' [l2' ->]].
- rewrite /eq_pair.
- wp_pures.
- wp_pure _; first solve_vals_compare_safe.
- wp_pure _.
- case_bool_decide;
- (wp_pures; wp_pure _; first solve_vals_compare_safe;
- case_bool_decide; (wp_pures; iApply "H"; iSplitL; [| iSplitL]; eauto; iPureIntro; congruence)).
- - iFrame. iModIntro. iIntros (g) "H".
- iPoseProof (lev_template'_sound with "[H]") as "H".
- { iSplitR.
- * iApply "Himpl".
- * iApply "H".
- }
- iApply "H".
- Qed.
-End levenshtein.
-
diff --git a/theories/examples/refinements/refinement.v b/theories/examples/refinements/refinement.v
deleted file mode 100644
index 9adc3df8..00000000
--- a/theories/examples/refinements/refinement.v
+++ /dev/null
@@ -1,842 +0,0 @@
-From iris.program_logic.refinement Require Export ref_weakestpre ref_source seq_weakestpre.
-From iris.base_logic.lib Require Export invariants na_invariants.
-From iris.heap_lang Require Export lang lifting.
-From iris.proofmode Require Import tactics.
-From iris.heap_lang Require Import proofmode notation metatheory.
-From iris.algebra Require Import auth gmap excl frac agree mlist.
-Set Default Proof Using "Type".
-
-Inductive rtc_list {A : Type} (R : relation A) : list A → Prop :=
-| rtc_list_nil : rtc_list R nil
-| rtc_list_once : ∀ x, rtc_list R [x]
-| rtc_list_l : ∀ x y l, R x y → rtc_list R (y :: l) → rtc_list R (x :: y :: l).
-
-Lemma rtc_list_r {A : Type} (R : relation A) (x y: A) (l: list A) :
- R x y →
- rtc_list R (l ++ [x]) →
- rtc_list R (l ++ [x] ++ [y]).
-Proof.
- rewrite app_assoc.
- intros HR Hrtc.
- remember (l ++ [x]) as l' eqn:Heql. revert x y HR l Heql; induction Hrtc; intros.
- - apply rtc_list_once.
- - symmetry in Heql. apply app_singleton in Heql as [(?&Heq)|(?&?)]; last by congruence.
- apply rtc_list_l; last apply rtc_list_once.
- inversion Heq; subst; eauto.
- - destruct l0; first by (simpl in Heql; congruence).
- inversion Heql; subst.
- simpl; apply rtc_list_l; first done.
- rewrite app_comm_cons. eapply IHHrtc; eauto.
-Qed.
-
-Lemma rtc_list_app_r {A: Type} (R: relation A) l1 l2:
- rtc_list R (l1 ++ l2) → rtc_list R l2.
-Proof.
- revert l2. induction l1; first done.
- intros l2 Hrtc. inversion Hrtc as [| | ???? Hrtc' [Heq1 Heq2]].
- - assert (l2 = []) as -> by (eapply app_eq_nil; eauto).
- constructor.
- - apply IHl1. rewrite -Heq2; eauto.
-Qed.
-
-Lemma rtc_list_rtc {A: Type} (R: relation A) (x y : A) (l : list A):
- rtc_list R ([x] ++ l ++ [y]) →
- rtc R x y.
-Proof.
- revert x y.
- induction l as [| a l IHl]; intros x y Hrtc.
- - inversion Hrtc; subst; eauto using rtc_l, rtc_refl.
- - inversion Hrtc; subst.
- apply (rtc_l _ _ a); auto.
-Qed.
-
-Lemma rtc_list_lookup_last_rtc {A: Type} (R: relation A) (x y : A) (l : list A) (i: nat) :
- (l ++ [y]) !! i = Some x →
- rtc_list R (l ++ [y]) →
- rtc R x y.
-Proof.
- rewrite lookup_app_Some.
- intros [Hl|Hr].
- * apply elem_of_list_split_length in Hl.
- destruct Hl as (l1&l2&Heq&Hlen). subst.
- rewrite -app_assoc => Hrtc. apply rtc_list_app_r in Hrtc.
- rewrite -app_comm_cons in Hrtc. eapply rtc_list_rtc; eauto.
- simpl; eauto.
- * destruct Hr as (_&Hlookup). intros.
- destruct (i - length l)%nat.
- ** rewrite /= in Hlookup. inversion Hlookup. apply rtc_refl.
- ** exfalso. rewrite /= lookup_nil in Hlookup. congruence.
-Qed.
-
-(* HeapLang <={log} HeapLang *)
-Definition tpoolUR SI : ucmraT SI := gmapUR nat (exclR (exprO SI)).
-Definition cfgUR SI := prodUR (tpoolUR SI) (gen_heapUR SI loc val).
-
-Class rheapPreG {SI} (Σ: gFunctors SI) := RHeapPreG {
- rheapPreG_heapG :> heapPreG Σ;
- rheapPreG_ghost_repr :> inG Σ (authR (cfgUR SI)); (* the source ghost state *)
- rheapPreG_fmlistG :> fmlistG (cfg heap_lang) Σ;
-}.
-
-Class rheapG {SI} (Σ: gFunctors SI) := RHeapG {
- rheapG_heapG :> heapG Σ;
- rheapG_ghost_repr :> inG Σ (authR (cfgUR SI)); (* the source ghost state *)
- rheapG_ghost_name: gname;
- rheapG_fmlistG :> fmlistG (cfg heap_lang) Σ;
- rheapG_fmlist_name: gname;
-}.
-
-Section source_ghost_state.
- Context {SI: indexT} `{Σ: gFunctors SI} `{!rheapG Σ}.
-
- Fixpoint to_tpool_go (i : nat) (tp : list expr) : tpoolUR SI :=
- match tp with
- | [] => ∅
- | e :: tp => <[i:=Excl e]>(to_tpool_go (S i) tp)
- end.
- Definition to_tpool : list expr → tpoolUR SI := to_tpool_go 0.
-
- Definition heapS_mapsto (l : loc) (q : Qp) (v: val) : iProp Σ :=
- own rheapG_ghost_name (◯ (∅, {[ l := (q, to_agree v) ]})).
-
- Definition tpool_mapsto (j : nat) (e: expr) : iProp Σ :=
- own rheapG_ghost_name (◯ ({[ j := Excl e ]}, ∅)).
-
- Global Instance heapS_mapsto_timeless l q v : Timeless (heapS_mapsto l q v).
- Proof. apply _. Qed.
-
- Typeclasses Opaque heapS_mapsto tpool_mapsto.
-
-
- Section thread_pool_conversion.
- Open Scope nat.
- (** Conversion to tpools and back *)
- Lemma to_tpool_valid es : ✓ to_tpool es.
- Proof.
- rewrite /to_tpool. move: 0.
- induction es as [|e es]=> n //; simpl. by apply insert_valid.
- Qed.
-
- Lemma tpool_lookup tp j : to_tpool tp !! j = Excl <$> tp !! j.
- Proof.
- cut (∀ i, to_tpool_go i tp !! (i + j) = Excl <$> tp !! j).
- { intros help. apply (help 0). }
- revert j. induction tp as [|e tp IH]=> //= -[|j] i /=.
- - by rewrite Nat.add_0_r lookup_insert.
- - by rewrite -Nat.add_succ_comm lookup_insert_ne; last lia.
- Qed.
- Lemma tpool_lookup_Some tp j e : to_tpool tp !! j = Excl' e → tp !! j = Some e.
- Proof. rewrite tpool_lookup fmap_Some. naive_solver. Qed.
- Hint Resolve tpool_lookup_Some : core.
-
- Lemma to_tpool_insert tp j e :
- j < length tp →
- to_tpool (<[j:=e]> tp) = <[j:=Excl e]> (to_tpool tp).
- Proof.
- intros. apply: map_eq=> i. destruct (decide (i = j)) as [->|].
- - by rewrite tpool_lookup lookup_insert list_lookup_insert.
- - rewrite tpool_lookup lookup_insert_ne // list_lookup_insert_ne //.
- by rewrite tpool_lookup.
- Qed.
- Lemma to_tpool_insert' tp j e :
- is_Some (to_tpool tp !! j) →
- to_tpool (<[j:=e]> tp) = <[j:=Excl e]> (to_tpool tp).
- Proof.
- rewrite tpool_lookup fmap_is_Some lookup_lt_is_Some. apply to_tpool_insert.
- Qed.
-
- Lemma to_tpool_snoc tp e :
- to_tpool (tp ++ [e]) = <[length tp:=Excl e]>(to_tpool tp).
- Proof.
- intros. apply: map_eq=> i.
- destruct (lt_eq_lt_dec i (length tp)) as [[?| ->]|?].
- - rewrite lookup_insert_ne; last lia. by rewrite !tpool_lookup lookup_app_l.
- - by rewrite lookup_insert tpool_lookup lookup_app_r // Nat.sub_diag.
- - rewrite lookup_insert_ne; last lia.
- rewrite !tpool_lookup ?lookup_ge_None_2 ?app_length //=;
- change (ofe_car _ (exprO SI)) with expr; lia.
- Qed.
-
- Lemma tpool_singleton_included tp j e :
- {[j := Excl e]} ≼ to_tpool tp → tp !! j = Some e.
- Proof.
- move=> /singleton_included [ex [/leibniz_equiv_iff]].
- rewrite tpool_lookup fmap_Some=> [[e' [-> ->]] /Excl_included ?]. by f_equal.
- Qed.
- Lemma tpool_singleton_included' tp j e :
- {[j := Excl e]} ≼ to_tpool tp → to_tpool tp !! j = Excl' e.
- Proof. rewrite tpool_lookup. by move=> /tpool_singleton_included=> ->. Qed.
-
-End thread_pool_conversion.
-
-End source_ghost_state.
-Notation "l '↦s{' q } v" := (heapS_mapsto l q v) (at level 20, q at level 50, format "l '↦s{' q } v") : bi_scope.
-Notation "l '↦s' v" := (heapS_mapsto l 1 v) (at level 20) : bi_scope.
-Notation "j ⤇ e" := (tpool_mapsto j e) (at level 20) : bi_scope.
-Notation src e := (0 ⤇ e)%I.
-
-
-Definition heap_srcT : Set := (list expr * (gmap loc val * gmap proph_id unit)).
-Definition to_cfg '(es, (h, m)): cfg heap_lang := (es, {| heap := h; used_proph_id := {| mapset.mapset_car := m |} |}).
-Global Instance heap_lang_source {SI} {Σ: gFunctors SI} `{!rheapG Σ}: source Σ heap_srcT := {|
- source_rel := λ s s', erased_step (to_cfg s) (to_cfg s');
- source_interp := (λ '(tp, (h, proph)), own rheapG_ghost_name (● ((to_tpool tp, to_gen_heap SI h): cfgUR SI)) ∗
- ∃ l, let l' := (l ++ [to_cfg (tp, (h, proph))]) in
- ⌜rtc_list (erased_step) l'⌝ ∗
- fmlist rheapG_fmlist_name 1 l')%I
-|}.
-
-
-Section heap_lang_source_steps.
-
- Context {SI: indexT} `{Σ: gFunctors SI} `{!rheapG Σ} `{!auth_sourceG Σ (natA SI)}.
-
- (* we use stuttering heap lang as a source *)
- Global Instance: source Σ (heap_srcT * nat) | 0 := _.
-
- Lemma step_insert tp j (e: expr) σ e' σ' efs κ:
- tp !! j = Some e → prim_step e σ κ e' σ' efs →
- erased_step (tp, σ) (<[j:= e']> tp ++ efs, σ').
- Proof.
- intros. rewrite -(take_drop_middle tp j e) //.
- rewrite insert_app_r_alt take_length_le ?Nat.sub_diag /=;
- eauto using lookup_lt_Some, Nat.lt_le_incl.
- rewrite -(assoc_L (++)) /=. exists κ.
- eapply step_atomic; eauto.
- Qed.
-
-
- Lemma pure_step_prim_step (e1 e2: expr) σ:
- pure_step e1 e2 → prim_step e1 σ [] e2 σ [].
- Proof.
- destruct 1 as [safe det]. destruct (safe σ) as (e' & σ' & efs & step).
- by specialize (det σ [] e' σ' efs step) as (_ & -> & -> & ->).
- Qed.
-
-
- (* allocate stuttering budget post-hoc *)
- Lemma step_frame (c1 c2: heap_srcT) (n m k: nat):
- (c1, n) ↪ (c2, m) → (c1, (n + k)%nat) ↪ (c2, (m + k)%nat).
- Proof.
- inversion 1; subst.
- - by apply lex_left.
- - apply lex_right, auth_source_step_frame; eauto; done.
- Qed.
-
- Lemma steps_frame (c1 c2: heap_srcT) (n m k: nat):
- (c1, n) ↪⁺ (c2, m) → (c1, (n + k)%nat) ↪⁺ (c2, (m + k)%nat).
- Proof.
- intros Hsteps.
- remember (c1, n) as p. revert n c1 Heqp.
- remember (c2, m) as q. revert m c2 Heqq.
- induction Hsteps as [? ? Hstep|p [c' m'] q Hstep Hsteps]; intros n c2 -> m c1 ->.
- - apply tc_once, step_frame, Hstep.
- - eapply tc_l; first eapply step_frame, Hstep.
- by eapply IHHsteps.
- Qed.
-
- Lemma step_add_stutter (c1 c2: heap_srcT) (n m: nat) c:
- (c1, n) ↪⁺ (c2, m) → c1 ≠ c2 → (c1, n) ↪⁺ (c2, (m + c)%nat).
- Proof.
- intros Hsteps.
- remember (c1, n) as p. revert n c1 Heqp.
- remember (c2, m) as q. revert m c2 Heqq.
- induction Hsteps as [? ? Hstep|p [c2 m] q Hstep Hsteps]; intros k c3 -> n c1 -> Hneq.
- - inversion Hstep; subst.
- + by eapply tc_once, lex_left.
- + naive_solver.
- - inversion Hstep; subst.
- + eapply tc_l; first apply lex_left; eauto.
- eapply steps_frame, Hsteps.
- + eapply tc_l; first apply lex_right; eauto.
- Qed.
-
-
- Lemma step_inv_alloc c E P j e1:
- (j ⤇ e1 -∗ src_update E P) ∗ (P -∗ ∃ e2, j ⤇ e2 ∗ ⌜e2 ≠ e1⌝)
- ⊢ j ⤇ e1 -∗ src_update E (P ∗ $ c).
- Proof.
- rewrite /src_update. iIntros "[Hupd HP] Hj".
- iIntros ([[tp [h m]] n]) "[Hsrc Hcred]".
- iDestruct "Hsrc" as "(Hsrc&Hl)".
- iDestruct (own_valid_2 with "Hsrc Hj") as %[[Htp%tpool_singleton_included'%tpool_lookup_Some _]%prod_included _]%auth_both_valid.
- iSpecialize ("Hupd" with "Hj"). iMod ("Hupd" $! (tp, (h, m), n) with "[$Hsrc $Hl $Hcred]") as ([[tp' [h' m']] m''] Hsteps) "[[[Hsrc Hsrcl] Hcred] P]".
- iAssert (⌜∃ e2, tp' !! j = Some e2 ∧ e2 ≠ e1⌝)%I as %Htp'; last destruct Htp' as [e2 [Htp' Hneq]].
- { iDestruct ("HP" with "P") as (e2) "[Hj %]".
- iDestruct (own_valid_2 with "Hsrc Hj") as %[[Htp'%tpool_singleton_included' _]%prod_included _]%auth_both_valid.
- iPureIntro; exists e2. split; first eapply tpool_lookup_Some, Htp'. done.
- }
- iMod (own_update _ (● m'') (● (m'' + c)%nat ⋅ ◯ c) with "Hcred") as "[Hnat Hc]".
- { eapply auth_update_alloc, nat_local_update. rewrite /ε //= /nat_unit. }
- iModIntro. iExists (tp', (h', m'), (m'' + c)%nat). iFrame.
- iPureIntro. apply step_add_stutter; eauto.
- injection 1 as -> ->.
- eapply Hneq. eapply Some_inj. rewrite -Htp -Htp' //=.
- Qed.
-
-
- (* stuttering rule *)
- Lemma step_stutter E c:
- srcF (natA SI) (S c) ⊢ src_update E (srcF (natA SI) c).
- Proof.
- rewrite /src_update.
- iIntros "Hf" ([[tp σ] n]) "[H● Hnat]".
- iDestruct (own_valid_2 with "Hnat Hf") as %[Hle%nat_included _]%auth_both_valid.
- destruct n as [|n]; first lia.
- iMod (own_update_2 _ (● (S n)) (◯ (S c)) (● n ⋅ ◯ c) with "Hnat Hf") as "[Hnat Hc]".
- { eapply auth_update, nat_local_update. lia. }
- iModIntro. iExists (tp, σ, n); iFrame.
- iPureIntro. apply tc_once, lex_right; simpl; lia.
- Qed.
-
- Lemma src_log E j (e: expr) :
- j ⤇ e ⊢ weak_src_update E (j ⤇ e ∗
- ∃ tp σ i, ⌜ tp !! j = Some e ⌝ ∗ fmlist_idx rheapG_fmlist_name i (to_cfg (tp, σ))).
- Proof.
- iIntros "Hj".
- rewrite /weak_src_update /tpool_mapsto /source_interp //=.
- iIntros ([[tp [h m]] n]) "[[H● Hl] Hnat]".
- iDestruct (own_valid_2 with "H● Hj") as %[[H1%tpool_singleton_included' _]%prod_included _]%auth_both_valid.
- iDestruct "Hl" as (l Htrace) "Hfmlist".
- iMod (fmlist_get_lb with "Hfmlist") as "(Hfmlist&Hlb)".
- iDestruct (fmlist_lb_to_idx _ _ (length l) with "Hlb") as "Hidx".
- { rewrite lookup_app_r; last lia. replace (length l - length l)%nat with O by lia. rewrite //. }
- iModIntro. iExists (tp, (h, m), n). iFrame.
- iSplit; first eauto. iSplit.
- { iExists _. iFrame. eauto. }
- iExists tp, (h, m), (length l).
- iSplit; eauto.
- iPureIntro. eapply (tpool_lookup_Some (SI:=SI)); auto.
- Qed.
-
- Lemma src_get_trace' j (e: expr) i cfg σ :
- j ⤇ e ∗ fmlist_idx rheapG_fmlist_name i cfg ∗ source_interp σ -∗
- j ⤇ e ∗
- source_interp σ ∗
- ∃ tp σ, ⌜ tp !! j = Some e ∧ rtc erased_step cfg (to_cfg (tp, σ)) ⌝.
- Proof.
- iIntros "(Hj&Hidx&Hinterp)".
- rewrite /tpool_mapsto /source_interp //=.
- destruct σ as [[tp [h m]] n].
- iDestruct "Hinterp" as "[[H● Hl] Hnat]".
- iDestruct "Hl" as (l Htrace) "Hfmlist".
- iDestruct (fmlist_idx_agree_2 with "[$] [$]") as %Hlookup.
- iDestruct (own_valid_2 with "H● Hj") as %[[H1%tpool_singleton_included' _]%prod_included _]%auth_both_valid.
- iFrame.
- iSplit; first eauto.
- iExists tp, (h, m).
- iPureIntro. split.
- * eapply (tpool_lookup_Some (SI:=SI)); auto.
- * eapply rtc_list_lookup_last_rtc; eauto.
- Qed.
-
- Lemma src_get_trace E j (e: expr) i cfg :
- j ⤇ e ∗ fmlist_idx rheapG_fmlist_name i cfg ⊢ weak_src_update E (j ⤇ e ∗
- ∃ tp σ, ⌜ tp !! j = Some e ∧ rtc erased_step cfg (to_cfg (tp, σ)) ⌝).
- Proof.
- iIntros "(Hj&Hidx)".
- rewrite /weak_src_update /tpool_mapsto /source_interp //=.
- iIntros ([[tp [h m]] n]) "[[H● Hl] Hnat]".
- iDestruct "Hl" as (l Htrace) "Hfmlist".
- iDestruct (fmlist_idx_agree_2 with "[$] [$]") as %Hlookup.
- iDestruct (own_valid_2 with "H● Hj") as %[[H1%tpool_singleton_included' _]%prod_included _]%auth_both_valid.
- iModIntro. iExists (tp, (h, m), n). iFrame.
- iSplit; first eauto. iSplit.
- { iExists _. iFrame. eauto. }
- iExists tp, (h, m).
- iPureIntro. split.
- * eapply (tpool_lookup_Some (SI:=SI)); auto.
- * eapply rtc_list_lookup_last_rtc; eauto.
- Qed.
-
- (* operational rules *)
- Lemma step_pure E j (e1 e2: expr):
- pure_step e1 e2 → j ⤇ e1 ⊢ src_update E (j ⤇ e2).
- Proof.
- iIntros (Hp) "Hj"; rewrite /src_update /tpool_mapsto /source_interp //=.
- iIntros ([[tp [h m]] n]) "[[H● Hl] Hnat]".
- iDestruct (own_valid_2 with "H● Hj") as %[[H1%tpool_singleton_included' _]%prod_included _]%auth_both_valid.
- iMod (own_update_2 with "H● Hj") as "[H● Hj]".
- { eapply auth_update, prod_local_update_1, singleton_local_update; eauto.
- by eapply (exclusive_local_update) with (x' := Excl e2). }
- iDestruct "Hl" as (l Htrace) "Hfmlist".
- iMod (fmlist_update_snoc (to_cfg (<[j:= e2]> tp, (h, m))) with "[$]") as "(Hfmlist&_)".
- iFrame "Hj". iModIntro. iExists (((<[j:= e2]> tp), (h, m)), n).
- rewrite to_tpool_insert'; eauto; iFrame.
- iSplit.
- - iPureIntro.
- replace (<[j:=e2]> tp) with (<[j:=e2]> tp ++ []) by rewrite right_id_L //=.
- eapply tc_once, lex_left, step_insert; first by eapply tpool_lookup_Some.
- apply pure_step_prim_step, Hp.
- - iExists _. iFrame. iPureIntro. rewrite -app_assoc. apply rtc_list_r; auto.
- replace (<[j:=e2]> tp) with (<[j:=e2]> tp ++ []) by rewrite right_id_L //=.
- eapply step_insert; first by eapply tpool_lookup_Some.
- apply pure_step_prim_step, Hp.
- Qed.
-
- Lemma steps_pure n E j (e1 e2: expr):
- nsteps pure_step (S n) e1 e2 → j ⤇ e1 ⊢ src_update E (j ⤇ e2).
- Proof.
- remember (S n) as m. intros H; revert n Heqm; induction H as [|? e1 e2 e3 Hstep Hsteps]; intros m.
- - discriminate 1.
- - injection 1 as ->. destruct m.
- + inversion Hsteps; subst. by apply step_pure.
- + iIntros "P". iApply src_update_bind; iSplitL.
- * iApply step_pure; eauto.
- * by iApply IHHsteps.
- Qed.
-
- Lemma steps_pure_exec E j e1 e2 φ n:
- PureExec φ (S n) e1 e2 → φ → j ⤇ e1 ⊢ src_update E (j ⤇ e2).
- Proof.
- intros Hp Hφ. specialize (pure_exec Hφ); eapply steps_pure.
- Qed.
-
- Lemma step_load E j K (l: loc) q v:
- j ⤇ fill K (Load #l) ∗ l ↦s{q} v ⊢ src_update E (j ⤇ fill K (of_val v) ∗ l ↦s{q} v).
- Proof.
- iIntros "[Hj Hl]"; rewrite /src_update /tpool_mapsto /source_interp //=.
- iIntros ([[tp [h m]] n]) "[[H● Hfmlist] Hnat]".
- iDestruct (own_valid_2 with "H● Hj") as %[[H1%tpool_singleton_included' _]%prod_included _]%auth_both_valid.
- iDestruct (own_valid_2 with "H● Hl") as %[[_ ?%gen_heap_singleton_included]%prod_included ?]%auth_both_valid.
- iMod (own_update_2 with "H● Hj") as "[H● Hj]".
- { by eapply auth_update, prod_local_update_1, singleton_local_update,
- (exclusive_local_update _ (Excl (fill K (of_val v)))). }
- iDestruct "Hfmlist" as (tr Htrace) "Hfmlist".
- iMod (fmlist_update_snoc (to_cfg (<[j:= fill K (of_val v)]> tp, (h, m))) with "[$]") as "(Hfmlist&_)".
- iFrame "Hj Hl". iModIntro. iExists (((<[j:=fill K (of_val v)]> tp), (h, m)), n).
- rewrite to_tpool_insert'; last eauto. iFrame. iSplit.
- - iPureIntro.
- replace (<[j:=fill K v]> tp) with (<[j:=fill K v]> tp ++ []) by rewrite right_id_L //=.
- eapply tc_once, lex_left, step_insert; first by eapply tpool_lookup_Some.
- apply fill_prim_step, head_prim_step.
- econstructor; eauto.
- - iExists _. iFrame. iPureIntro. rewrite -app_assoc. apply rtc_list_r; auto.
- replace (<[j:=fill K v]> tp) with (<[j:=fill K v]> tp ++ []) by rewrite right_id_L //=.
- eapply step_insert; first by eapply tpool_lookup_Some.
- apply fill_prim_step, head_prim_step.
- econstructor; eauto.
- Qed.
-
- Lemma step_store E j K (l: loc) (v v': val):
- j ⤇ fill K (Store #l v) ∗ l ↦s v' ⊢ src_update E (j ⤇ fill K #() ∗ l ↦s v).
- Proof.
- iIntros "[Hj Hl]"; rewrite /src_update /tpool_mapsto /heapS_mapsto /source_interp //=.
- iIntros ([[tp [h m]] n]) "[[H● Hfmlist] Hnat]".
- iDestruct (own_valid_2 with "H● Hj") as %[[H1%tpool_singleton_included' _]%prod_included _]%auth_both_valid.
- iDestruct (own_valid_2 with "H● Hl") as %[[_ Hl%gen_heap_singleton_included]%prod_included ?]%auth_both_valid.
- iMod (own_update_2 with "H● Hj") as "[H● Hj]".
- { by eapply auth_update, prod_local_update_1, singleton_local_update,
- (exclusive_local_update _ (Excl (fill K (of_val #())))). }
- iMod (own_update_2 with "H● Hl") as "[H● Hl]".
- { eapply auth_update, prod_local_update_2, singleton_local_update,
- (exclusive_local_update _ (1%Qp, to_agree v)); last done.
- by rewrite /to_gen_heap lookup_fmap Hl. }
- iDestruct "Hfmlist" as (tr Htrace) "Hfmlist".
- iMod (fmlist_update_snoc (to_cfg (<[j:= fill K (of_val #())]> tp, (<[l:=v]>h, m))) with "[$]") as
- "(Hfmlist&_)".
- iFrame "Hj Hl". iExists (((<[j:=fill K (of_val #())]> tp), (<[l:=v]> h, m)), n).
- rewrite -to_gen_heap_insert -to_tpool_insert' //=; eauto.
- iModIntro. iFrame. iSplit.
- - iPureIntro.
- replace (<[j:=fill K #()]> tp) with (<[j:=fill K #()]> tp ++ []) by rewrite right_id_L //=.
- eapply tc_once, lex_left, step_insert; first by eapply tpool_lookup_Some.
- apply fill_prim_step, head_prim_step.
- econstructor; eauto.
- - iExists _. iFrame. iPureIntro. rewrite -app_assoc. apply rtc_list_r; auto.
- replace (<[j:=fill K #()]> tp) with (<[j:=fill K #()]> tp ++ []) by rewrite right_id_L //=.
- eapply step_insert; first by eapply tpool_lookup_Some.
- apply fill_prim_step, head_prim_step.
- econstructor; eauto.
- Qed.
-
- Lemma step_alloc E j K (v : val):
- j ⤇ fill K (Alloc v) ⊢ src_update E (∃ l: loc, j ⤇ fill K #l ∗ l ↦s v).
- Proof.
- iIntros "Hj"; rewrite /src_update /tpool_mapsto /heapS_mapsto /source_interp //=.
- iIntros ([[tp [h m]] n]) "[[H● Hfmlist] Hnat]".
- destruct (exist_fresh (dom (gset loc) h)) as [l Hl%not_elem_of_dom].
- iDestruct (own_valid_2 with "H● Hj") as %[[H1%tpool_singleton_included' _]%prod_included _]%auth_both_valid.
- iMod (own_update_2 with "H● Hj") as "[H● Hj]".
- { by eapply auth_update, prod_local_update_1, singleton_local_update,
- (exclusive_local_update _ (Excl (fill K (of_val #l)))). }
- iMod (own_update with "H●") as "[H● Hl]".
- { eapply auth_update_alloc, prod_local_update_2, (alloc_singleton_local_update _ l (1%Qp,to_agree v)); last done.
- by apply lookup_to_gen_heap_None. }
- iDestruct "Hfmlist" as (tr Htrace) "Hfmlist".
- iMod (fmlist_update_snoc (to_cfg (<[j:= fill K (of_val #l)]> tp, (<[l:=v]>h, m))) with "[$]") as
- "(Hfmlist&_)".
- iModIntro. iExists (((<[j:=fill K (of_val #l)]> tp), (<[l:=v]> h, m)), n).
- rewrite -to_gen_heap_insert to_tpool_insert' //=; eauto. iFrame.
- iSplitR; [| iSplitL "Hfmlist"]; last by iExists l; iFrame.
- - iPureIntro.
- replace (<[j:=fill K #l]> tp) with (<[j:=fill K #l]> tp ++ []) by rewrite right_id_L //=.
- eapply tc_once, lex_left, step_insert; first by eapply tpool_lookup_Some.
- apply fill_prim_step, head_prim_step.
- pose proof (AllocNS 1 v {| heap := h; used_proph_id := {| mapset.mapset_car := m |} |} l) as H.
- rewrite state_init_heap_singleton in H; simpl in H. apply H; first lia.
- intros i ??; assert (i = 0) as -> by lia; simpl; rewrite loc_add_0 //=.
- - iExists _. iFrame. iPureIntro. rewrite -app_assoc. apply rtc_list_r; auto.
- replace (<[j:=fill K #l]> tp) with (<[j:=fill K #l]> tp ++ []) by rewrite right_id_L //=.
- eapply step_insert; first by eapply tpool_lookup_Some.
- apply fill_prim_step, head_prim_step.
- pose proof (AllocNS 1 v {| heap := h; used_proph_id := {| mapset.mapset_car := m |} |} l) as H.
- rewrite state_init_heap_singleton in H; simpl in H. apply H; first lia.
- intros i ??; assert (i = 0) as -> by lia; simpl; rewrite loc_add_0 //=.
- Qed.
-
-End heap_lang_source_steps.
-
-
-(* some proof automation for source languages *)
-From iris.proofmode Require Import tactics coq_tactics reduction.
-Ltac strip_ectx e cb :=
- match e with
- | fill ?K ?e' => strip_ectx e' ltac:(fun K' e'' => match K' with nil => cb K e'' | _ => cb (K ++ K') e'' end)
- | _ => cb (@nil ectx_item) e
- end.
-
-Ltac src_bind_core e efoc cb :=
- strip_ectx e ltac:(fun K e' => reshape_expr e' ltac:(fun K' e'' => unify e'' efoc; cb (K' ++ K) e'')).
-
-Ltac src_bind_core' e cb :=
- strip_ectx e ltac:(fun K e' => reshape_expr e' ltac:(fun K' e'' => cb (K' ++ K) e'')).
-
-Lemma src_change e1 e2 {SI: indexT} `{Σ: gFunctors SI} `{!rheapG Σ} `{!auth_sourceG Σ (natA SI)} j Δ (G: iProp Σ):
- e1 = e2 →
- envs_entails Δ (j ⤇ e2 -∗ G) →
- envs_entails Δ (j ⤇ e1 -∗ G).
-Proof. by intros ->. Qed.
-
-Tactic Notation "src_bind" open_constr(efoc) :=
- match goal with
- | [|- envs_entails ?Δ (?j ⤇ ?e -∗ ?G)] =>
- src_bind_core e efoc ltac:(fun K e' => apply (src_change e (fill K e')); first reflexivity)
- end.
-
-Tactic Notation "src_bind" open_constr(efoc) "in" constr(H) :=
- iRevert H;
- src_bind efoc;
- last iIntros H.
-
-Lemma tac_src_pures_rwp e1 e2 {SI: indexT} `{Σ: gFunctors SI} `{!rheapG Σ} `{!auth_sourceG Σ (natA SI)}
- φ e Δ j E s Φ:
- PureExec φ 1 e1 e2 →
- to_val e = None →
- φ →
- envs_entails Δ (j ⤇ e2 -∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩) →
- envs_entails Δ (j ⤇ e1 -∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩).
-Proof.
- rewrite envs_entails_eq=> ? ? ? ->.
- iIntros "H Hj". iApply (rwp_weaken with "H"); auto.
- by iApply @steps_pure_exec.
-Qed.
-
-Lemma tac_src_pures e1 e2 {SI: indexT} `{Σ: gFunctors SI} `{!rheapG Σ} `{!auth_sourceG Σ (natA SI)}
- φ Δ j E P:
- PureExec φ 1 e1 e2 →
- φ →
- envs_entails Δ (j ⤇ e2 -∗ weak_src_update E P) →
- envs_entails Δ (j ⤇ e1 -∗ src_update E P).
-Proof.
- rewrite envs_entails_eq=> ? ? ->.
- iIntros "H Hj".
- iApply (weak_src_update_bind_r with "[$H Hj]").
- by iApply @steps_pure_exec.
-Qed.
-
-Lemma tac_src_load_rwp {SI: indexT} `{Σ: gFunctors SI} `{!rheapG Σ} `{!auth_sourceG Σ (natA SI)}
- e s Φ Δ E i j K l q v:
- to_val e = None →
- envs_lookup i Δ = Some (false, l ↦s{q} v)%I →
- envs_entails Δ (j ⤇ fill K (Val v) -∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩) →
- envs_entails Δ (j ⤇ fill K (Load (LitV l)) -∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩).
-Proof.
- rewrite envs_entails_eq=> ?? Henvs.
- iIntros "H Hj".
- rewrite envs_lookup_split //.
- iDestruct "H" as "(Hl&Hw)".
- iApply (rwp_weaken with "[Hw] [Hl Hj]"); first done; last first.
- { iApply step_load. iFrame. }
- iIntros "(Hj&Hl)".
- iSpecialize ("Hw" with "[$]"). iApply (Henvs with "[$] [$]").
-Qed.
-
-Lemma tac_src_load {SI: indexT} `{Σ: gFunctors SI} `{!rheapG Σ} `{!auth_sourceG Σ (natA SI)}
- Δ E P i j K l q v:
- envs_lookup i Δ = Some (false, l ↦s{q} v)%I →
- envs_entails Δ (j ⤇ fill K (Val v) -∗ weak_src_update E P) →
- envs_entails Δ (j ⤇ fill K (Load (LitV l)) -∗ src_update E P).
-Proof.
- rewrite envs_entails_eq=> ? Henvs.
- iIntros "H Hj".
- rewrite envs_lookup_split //.
- iDestruct "H" as "(Hl&Hw)".
- iApply (weak_src_update_bind_r with "[-]").
- iSplitL "Hl Hj".
- { iApply step_load. iFrame. }
- iIntros "(Hj&Hl)".
- iApply (Henvs with "[Hw Hl] Hj").
- by iApply "Hw".
-Qed.
-
-Lemma tac_src_store {SI: indexT} `{Σ: gFunctors SI} `{!rheapG Σ} `{!auth_sourceG Σ (natA SI)}
- Δ Δ' E P i j K l v v':
- envs_lookup i Δ = Some (false, l ↦s v)%I →
- envs_simple_replace i false (Esnoc Enil i (l ↦s v')) Δ = Some Δ' →
- envs_entails Δ' (j ⤇ fill K (Val $ LitV LitUnit) -∗ weak_src_update E P) →
- envs_entails Δ (j ⤇ fill K (Store (LitV l) (Val v')) -∗ src_update E P).
-Proof.
- rewrite envs_entails_eq=> ?? Henvs.
- iIntros "H Hj".
- rewrite envs_simple_replace_sound //.
- iDestruct "H" as "(Hl&Hw)".
- iApply (weak_src_update_bind_r with "[-]").
- iSplitL "Hl Hj".
- { iApply step_store. iFrame. }
- iIntros "(Hj&Hl)".
- iApply (Henvs with "[Hw Hl] Hj").
- iApply "Hw". simpl. rewrite right_id. eauto.
-Qed.
-
-Ltac weak_to_src_update :=
- lazymatch goal with
- | [|- envs_entails ?Δ (weak_src_update _ _)] =>
- iApply src_update_weak_src_update
- | _ => idtac
- end.
-
-Tactic Notation "src_pure" open_constr(efoc) :=
- match goal with
- | [|- envs_entails ?Δ (?j ⤇ ?e -∗ src_update _ _)] =>
- src_bind_core e efoc ltac:(fun K e' => eapply (tac_src_pures (fill K e'));
- [iSolveTC|try solve_vals_compare_safe| simpl ectx_language.fill])
- | [|- envs_entails ?Δ (?j ⤇ ?e -∗ rwp _ _ _ _)] =>
- src_bind_core e efoc ltac:(fun K e' => eapply (tac_src_pures_rwp (fill K e'));
- [iSolveTC|done|try solve_vals_compare_safe|simpl])
- end.
-
-Tactic Notation "src_pure" open_constr(efoc) "in" constr(H) :=
- weak_to_src_update;
- iRevert H;
- src_pure efoc;
- last iIntros H.
-
-Tactic Notation "src_load" open_constr (efoc) :=
- lazymatch goal with
- | [|- envs_entails ?Δ (?j ⤇ ?e -∗ rwp _ _ _ _)] =>
- src_bind_core e efoc ltac:(fun K e' => eapply (tac_src_load_rwp _ _ _ _ _ _ _ K);
- [done|iAssumptionCore| simpl fill])
- | [|- envs_entails ?Δ (?j ⤇ ?e -∗ weak_src_update _ _)] =>
- iApply src_update_weak_src_update;
- src_bind_core e efoc ltac:(fun K e' => eapply (tac_src_load _ _ _ _ _ K);
- [iAssumptionCore| simpl fill])
- | [|- envs_entails ?Δ (?j ⤇ ?e -∗ src_update _ _)] =>
- src_bind_core e efoc ltac:(fun K e' => eapply (tac_src_load _ _ _ _ _ K);
- [iAssumptionCore| simpl fill])
- end.
-
-Tactic Notation "src_load" "in" constr(H) :=
- weak_to_src_update;
- iRevert H;
- src_bind (! _)%E;
- src_load _;
- last iIntros H.
-
-Tactic Notation "pattern" open_constr(e) "in" tactic(f) := f e.
-
-Ltac single_pure_exec :=
- match goal with
- | [|- PureExec ?φ 1 ?e1 ?e2] => apply _
- | [|- PureExec ?φ 1 (fill ?K1 ?e1) (fill ?K2 ?e2)] =>
- unify K1 K2; eapply pure_exec_fill; single_pure_exec
- | [|- PureExec ?φ 1 ?e1 ?e2 ] =>
- reshape_expr e1 ltac:(fun K e1 =>
- pattern (_: expr) in ltac:(fun e2' =>
- unify e2 (fill K e2');
- change (PureExec φ 1 (fill K e1) (fill K e2'));
- apply pure_exec_fill, _
- ))
- end.
-
-
-Lemma pure_exec_cons φ ψ n (e1 e2 e3: expr):
- PureExec φ 1 e1 e2 → PureExec ψ n e2 e3 → PureExec (φ ∧ ψ) (S n) e1 e3.
-Proof.
- intros H1 H2 [Hφ Hψ]; econstructor; eauto.
- specialize (H1 Hφ).
- by inversion H1 as [|x y z a Hpure Hstep]; subst; inversion Hstep; subst.
-Qed.
-
-
-Lemma pure_exec_zero (e: expr): PureExec True 0 e e.
-Proof.
- intros ?. econstructor.
-Qed.
-
-Ltac pure_exec_cons :=
- match goal with
- | [|- PureExec ?φ 0 ?e1 ?e2] =>
- apply pure_exec_zero
- | [|- PureExec ?φ ?n ?e1 ?e2] =>
- unify e1 e2; apply pure_exec_zero
- | [|- PureExec ?φ ?n ?e1 ?e2] =>
- (eapply pure_exec_cons; [single_pure_exec|]); simpl
- end.
-
-Ltac pure_exec := repeat pure_exec_cons.
-
-
-
-
-Arguments satisfiable_at {_ _ _} _ _%I.
-
-Lemma satisfiable_update_alloc {SI} {Σ: gFunctors SI} `{LargeIndex SI} `{!invG Σ} {E} {P} Q:
- satisfiable_at E P → (⊢ |==> ∃ γ: gname, Q γ) → ∃ γ, satisfiable_at E (P ∗ Q γ).
-Proof.
- intros Hsat Hent. apply satisfiable_at_exists; first done.
- eapply satisfiable_at_fupd with (E1 := E).
- eapply satisfiable_at_mono; first apply Hsat.
- iIntros "$". iMod (Hent) as "$"; eauto.
-Qed.
-
-Lemma satisfiable_update_alloc_2 {SI} {Σ: gFunctors SI} `{LargeIndex SI} `{!invG Σ} {E} {P} Φ:
- satisfiable_at E P → (⊢ |==> ∃ γ1 γ2: gname, Φ γ1 γ2) → ∃ γ1 γ2, satisfiable_at E (P ∗ Φ γ1 γ2).
-Proof.
- intros Hsat Hent.
- eapply satisfiable_at_mono with (Q := (|==> ∃ γ1 γ2, P ∗ Φ γ1 γ2)%I) in Hsat.
- - eapply satisfiable_at_bupd in Hsat as Hsat.
- apply satisfiable_at_exists in Hsat as [γ1 Hsat]; auto.
- apply satisfiable_at_exists in Hsat as [γ2 Hsat]; eauto.
- - iIntros "$". by iMod Hent.
-Qed.
-
-Lemma satisfiable_at_alloc {SI A} {Σ: gFunctors SI} `{LargeIndex SI} `{!inG Σ A} `{!invG Σ} {E} {P} (a: A):
- satisfiable_at E P → ✓ a → ∃ γ, satisfiable_at E (P ∗ own γ a).
-Proof.
- intros Hsat Hent. apply satisfiable_update_alloc; first done.
- by eapply own_alloc.
-Qed.
-
-Lemma satisfiable_at_add {SI} (Σ: gFunctors SI) `{!invG Σ} E P Q: satisfiable_at E P → sbi_emp_valid Q → satisfiable_at E (P ∗ Q).
-Proof.
- intros Hsat Hval. eapply satisfiable_at_mono; first eauto.
- iIntros "$". iApply Hval.
-Qed.
-
-Lemma satisfiable_at_add' {SI} (Σ: gFunctors SI) `{!invG Σ} E Q: satisfiable_at E True → sbi_emp_valid Q → satisfiable_at E Q.
-Proof.
- intros Hsat Hval. eapply satisfiable_at_mono; first eauto.
- iIntros "_". iApply Hval.
-Qed.
-
-Lemma satisfiable_at_gen_heap {SI} {Σ: gFunctors SI} `{LargeIndex SI} `{!heapPreG Σ} κ σ:
- ∃ Hheap: heapG Σ, satisfiable_at ⊤ ((gen_heap_ctx (heap σ)) ∗ proph_map_ctx κ (used_proph_id σ)).
-Proof.
- (* allocate invariants *)
- edestruct satisfiable_at_intro as [Hinv Hsat].
- eapply satisfiable_update_alloc_2 in Hsat as (γ_gen_heap & γ_gen_heap_meta & Hsat); last eapply (alloc_gen_heap _ _ σ.(heap)).
- pose (Hgen := GenHeapG SI loc val _ _ _ _ _ _ γ_gen_heap γ_gen_heap_meta).
-
- (* TODO: prophecies are not really included in the refinement version *)
- (* allocate prophecies *)
- eapply satisfiable_update_alloc in Hsat as (γ_proph_map & Hsat); last apply (proph_map_init' κ σ.(used_proph_id)).
- pose (Hproph := ProphMapG SI proph_id (val * val) Σ _ _ _ γ_proph_map).
- exists (HeapG _ _ _ _ _).
- eapply satisfiable_at_mono; first apply Hsat.
- by iIntros "[[_ $] $]".
-Qed.
-
-
-Lemma satisfiable_at_ref_heapG {SI} {Σ: gFunctors SI} `{LargeIndex SI} `{!heapPreG Σ} n σ:
- ∃ Hheap: heapG Σ, satisfiable_at ⊤ (ref_state_interp n σ).
-Proof.
- edestruct (satisfiable_at_gen_heap nil) as [Hheap Hsat].
- exists Hheap. eapply satisfiable_at_mono; first eauto.
- iIntros "($ & _)".
-Qed.
-
-Lemma satisfiable_at_rheapG {SI} {Σ: gFunctors SI} `{LargeIndex SI} `{!rheapPreG Σ} n σ h m tp:
- ∃ Hheap: rheapG Σ, satisfiable_at ⊤ (ref_state_interp σ n ∗ source_interp (tp, (h, m)) ∗ own rheapG_ghost_name (◯ (to_tpool tp, to_gen_heap SI h))).
-Proof.
- edestruct (satisfiable_at_ref_heapG) as [Hheap Hsat].
- eapply (satisfiable_at_alloc (● (to_tpool tp, to_gen_heap SI h) ⋅ ◯ (to_tpool tp, to_gen_heap SI h))) in Hsat as [γ Hsat]; last first.
- { apply auth_both_valid; repeat split; eauto using to_tpool_valid, to_gen_heap_valid. }
- eapply (satisfiable_at_alloc ((●{1} (MList [to_cfg (tp, (h, m))])))) in Hsat as [γ' Hsat]; last first.
- { apply auth_auth_valid.
- cbv; auto. }
- exists (RHeapG _ _ _ _ γ _ γ').
- eapply satisfiable_at_mono; first apply Hsat.
- iIntros "(($&($&$))&H3)".
- iExists nil. simpl. rewrite /fmlist. iFrame.
- iPureIntro. apply rtc_list_once.
-Qed.
-
-Lemma rtc_to_cfg {SI} {Σ: gFunctors SI} `{!rheapG Σ} x y: rtc source_rel x y → rtc erased_step (to_cfg x) (to_cfg y).
-Proof.
- induction 1; first done.
- econstructor; by eauto.
-Qed.
-
-Lemma sn_to_cfg {SI} {Σ: gFunctors SI} `{!rheapG Σ} x: sn erased_step (to_cfg x) → sn source_rel x.
-Proof.
- remember (to_cfg x) as σ; intros Hsn; revert x Heqσ.
- induction Hsn as [x _ IH]; intros [ts [h m]] ->.
- constructor. intros [ts' [h' m']] Hstep.
- eapply IH; eauto. apply Hstep.
-Qed.
-
-From iris.program_logic Require Import ref_adequacy.
-(* Adequacy Theorem *)
-Section adequacy.
- Context {SI: indexT} `{C: Classical} `{LI: LargeIndex SI} {Σ: gFunctors SI}.
- Context `{Hpre: !rheapPreG Σ} `{Hna: !na_invG Σ} `{Hauth: !inG Σ (authR (natA SI))}.
-
- Theorem heap_lang_ref_adequacy (φ: val → val → Prop) (s t: expr) σ σ_src:
- (∀ `{!rheapG Σ} `{!seqG Σ} `{!auth_sourceG Σ (natA SI)}, src s ⊢ SEQ t ⟨⟨ v, ∃ v': val, src v' ∗ ⌜φ v v'⌝ ⟩⟩) →
- (∀ σ' v, rtc erased_step ([t], σ) ([Val v], σ') → ∃ v': val, ∃ σ_src' ts, rtc erased_step ([s], σ_src) (Val v' :: ts, σ_src') ∧ φ v v') ∧
- (sn erased_step ([s], σ_src) → sn erased_step ([t], σ)).
- Proof using SI C LI Σ Hpre Hna Hauth.
- intros Hobj.
- (* allocate the heap *)
- edestruct (satisfiable_at_rheapG 0 σ (heap σ_src) (mapset.mapset_car (used_proph_id σ_src)) [s]) as [Hheap Hsat].
- (* allocate sequential invariants *)
- eapply satisfiable_update_alloc in Hsat as [seqG_name Hsat]; last apply na_alloc.
- pose (seq := {| seqG_na_invG := _; seqG_name := seqG_name |}).
- (* allocte stuttering credits *)
- eapply (satisfiable_at_alloc (● 0%nat ⋅ ◯ 0%nat)) in Hsat as [authG_name Hsat]; last first.
- { apply auth_both_valid; by split. }
- pose (stutter := {| sourceG_inG := _; sourceG_name := authG_name |}).
- specialize (Hobj Hheap seq stutter).
- eapply satisfiable_at_mono in Hsat as Hsat; last first; [|split].
- - iIntros "[[(SI & Hsrc & Hsrc') Hna] [Hc Hc']]".
- iPoseProof (Hobj with "[Hsrc'] Hna") as "Hwp".
- + assert ((◯ (to_tpool [s], to_gen_heap SI (heap σ_src))) ≡ (◯ (to_tpool [s], ∅) ⋅ ◯ (∅, to_gen_heap SI (heap σ_src)))) as ->.
- { by rewrite -auth_frag_op pair_op left_id right_id. }
- iDestruct "Hsrc'" as "[$ _]".
- + iClear "Hc'". iCombine "Hsrc Hc" as "Hsrc".
- iCombine "Hsrc SI Hwp" as "G". iExact "G".
- - intros σ' v Hsteps. eapply (rwp_result _ _ ([s], (heap σ_src, mapset.mapset_car (used_proph_id σ_src)), 0%nat)) in Hsteps; last apply Hsat.
- destruct Hsteps as ([[ts [h p]] c] & m & Hsteps & Hsat').
- eapply satisfiable_at_pure.
- eapply satisfiable_at_mono; first apply Hsat'.
- iIntros "(Hsrc & SI & _ & Hv)". iDestruct "Hv" as (v') "[Hsrc' %]".
- iExists v', {| heap := h; used_proph_id := {| mapset.mapset_car := p |} |}.
- iDestruct "Hsrc" as "[[Hsrc _] _]".
- iDestruct (own_valid_2 with "Hsrc Hsrc'") as %[[H1%tpool_singleton_included' _]%prod_included _]%auth_both_valid.
- destruct ts as [|e ts]; first naive_solver.
- iExists ts.
- iPureIntro. split; auto.
- rewrite tpool_lookup in H1.
- injection H1 as ->.
- eapply lex_rtc in Hsteps.
- eapply rtc_to_cfg in Hsteps; simpl in Hsteps.
- destruct σ_src as [? [?]]; apply Hsteps.
- - intros Hsn. destruct σ_src as [h_src [p_src]]; simpl in *. eapply (rwp_sn_preservation _ ([s], (h_src, p_src), 0%nat) _ _ 0).
- { eapply sn_lex; first apply (sn_to_cfg ([s], (h_src, p_src))); eauto.
- intros y; apply lt_wf. }
- eapply satisfiable_at_mono; first apply Hsat.
- iIntros "($ & $ & $)".
- Qed.
-
-End adequacy.
diff --git a/theories/examples/safety/assert.v b/theories/examples/safety/assert.v
deleted file mode 100644
index 24d098c8..00000000
--- a/theories/examples/safety/assert.v
+++ /dev/null
@@ -1,28 +0,0 @@
-From iris.program_logic Require Export weakestpre.
-From iris.heap_lang Require Export lang.
-From iris.proofmode Require Import tactics.
-From iris.heap_lang Require Import proofmode notation.
-Set Default Proof Using "Type".
-
-Definition assert : val :=
- λ: "v", if: "v" #() then #() else #0 #0. (* #0 #0 is unsafe *)
-(* just below ;; *)
-Notation "'assert:' e" := (assert (λ: <>, e)%E) (at level 99) : expr_scope.
-Notation "'assert:' e" := (assert (λ: <>, e)%V) (at level 99) : val_scope.
-
-(*
-Lemma twp_assert `{!heapG Σ} E (Φ : val → iProp Σ) e :
- WP e @ E [{ v, ⌜v = #true⌝ ∧ Φ #() }] -∗
- WP (assert: e)%V @ E [{ Φ }].
-Proof.
- iIntros "HΦ". wp_lam.
- wp_apply (twp_wand with "HΦ"). iIntros (v) "[% ?]"; subst. by wp_if.
-Qed.*)
-
-Lemma wp_assert {SI} {Σ: gFunctors SI} `{!heapG Σ} E (Φ : val → iProp Σ) e :
- WP e @ E {{ v, ⌜v = #true⌝ ∧ ▷ Φ #() }} -∗
- WP (assert: e)%V @ E {{ Φ }}.
-Proof.
- iIntros "HΦ". wp_lam.
- wp_apply (wp_wand with "HΦ"). iIntros (v) "[% ?]"; subst. by wp_if.
-Qed.
diff --git a/theories/examples/safety/barrier/barrier.v b/theories/examples/safety/barrier/barrier.v
deleted file mode 100644
index 7ae83e5d..00000000
--- a/theories/examples/safety/barrier/barrier.v
+++ /dev/null
@@ -1,7 +0,0 @@
-From iris.heap_lang Require Export notation.
-Set Default Proof Using "Type".
-
-Definition newbarrier : val := λ: <>, ref #false.
-Definition signal : val := λ: "x", "x" <- #true.
-Definition wait : val :=
- rec: "wait" "x" := if: !"x" then #() else "wait" "x".
diff --git a/theories/examples/safety/barrier/example_client.v b/theories/examples/safety/barrier/example_client.v
deleted file mode 100644
index 21377276..00000000
--- a/theories/examples/safety/barrier/example_client.v
+++ /dev/null
@@ -1,73 +0,0 @@
-From iris.program_logic Require Export weakestpre.
-From iris.heap_lang Require Export lang.
-From iris.heap_lang Require Import adequacy proofmode.
-From iris.examples.safety Require Import par.
-From iris.examples.safety.barrier Require Import proof.
-Set Default Proof Using "Type".
-
-Definition worker (n : Z) : val :=
- λ: "b" "y", wait "b" ;; !"y" #n.
-Definition client : expr :=
- let: "y" := ref #0 in
- let: "b" := newbarrier #() in
- ("y" <- (λ: "z", "z" + #42) ;; signal "b") |||
- (worker 12 "b" "y" ||| worker 17 "b" "y").
-
-Section client.
- Local Set Default Proof Using "Type*".
- Context `{Σ : gFunctors SI} `{!heapG Σ, !barrierG Σ, !spawnG Σ}.
-
- Definition N := nroot .@ "barrier".
-
- Definition y_inv (q : Qp) (l : loc) : iProp Σ :=
- (∃ f : val, l ↦{q} f ∗ □ ∀ n : Z, WP f #n {{ v, ⌜v = #(n + 42)⌝ }})%I.
-
- Lemma y_inv_split q l : y_inv q l -∗ (y_inv (q/2) l ∗ y_inv (q/2) l).
- Proof.
- iDestruct 1 as (f) "[[Hl1 Hl2] #Hf]".
- iSplitL "Hl1"; iExists f; by iSplitL; try iAlways.
- Qed.
-
- Lemma worker_safe q (n : Z) (b y : loc) :
- recv N b (y_inv q y) -∗ WP worker n #b #y {{ _, True }}.
- Proof.
- iIntros "Hrecv". wp_lam. wp_let.
- wp_apply (wait_spec with "Hrecv"). iDestruct 1 as (f) "[Hy #Hf]".
- wp_seq. wp_load.
- iApply (wp_wand with "[]"). iApply "Hf". by iIntros (v) "_".
- Qed.
-
- Lemma client_safe : ⊢ WP client {{ _, True }}.
- Proof.
- iIntros ""; rewrite /client. wp_alloc y as "Hy". wp_let.
- wp_apply (newbarrier_spec N (y_inv 1 y) with "[//]").
- iIntros (l) "[Hr Hs]".
- wp_apply (wp_par (λ _, True%I) (λ _, True%I) with "[Hy Hs] [Hr]"); last auto.
- - (* The original thread, the sender. *)
- wp_store. iApply (signal_spec with "[-]"); last by iNext; auto.
- iSplitR "Hy"; first by eauto.
- iExists _; iSplitL; [done|]. iIntros "!#" (n). by wp_pures.
- - (* The two spawned threads, the waiters. *)
- iDestruct (recv_weaken with "[] Hr") as "Hr".
- { iIntros "Hy". by iApply (y_inv_split with "Hy"). }
- iPoseProof (recv_split with "Hr") as "H". instantiate (1 := ⊤). done.
- iApply swp_wp_lstep; eauto.
- iApply (lstepN_lstep _ _ 1).
- iMod "H". do 2 iModIntro. iNext. do 2 iModIntro. iMod "H". iModIntro. swp_finish.
- iDestruct "H" as "[H1 H2]".
- wp_apply (wp_par (λ _, True%I) (λ _, True%I) with "[H1] [H2]"); last auto.
- + by iApply worker_safe.
- + by iApply worker_safe.
-Qed.
-End client.
-
-Section ClosedProofs.
-
-Let Σ {SI} : gFunctors SI := #[ heapΣ SI ; barrierΣ ; spawnΣ SI ].
-
-Lemma client_adequate {SI : indexT} σ : adequate NotStuck client σ (λ _ _, True).
-Proof. apply (heap_adequacy Σ)=> ?. apply client_safe. Qed.
-
-End ClosedProofs.
-
-(*Print Assumptions client_adequate.*)
diff --git a/theories/examples/safety/barrier/proof.v b/theories/examples/safety/barrier/proof.v
deleted file mode 100644
index e40b3941..00000000
--- a/theories/examples/safety/barrier/proof.v
+++ /dev/null
@@ -1,187 +0,0 @@
-From iris.program_logic Require Export weakestpre.
-From iris.base_logic Require Import invariants saved_prop.
-From iris.heap_lang Require Export lang.
-From iris.heap_lang Require Import proofmode.
-From iris.algebra Require Import auth gset.
-From iris.examples.safety.barrier Require Export barrier.
-Set Default Proof Using "Type".
-
-(** The CMRAs/functors we need. *)
-Class barrierG {SI} (Σ : gFunctors SI) := BarrierG {
- barrier_inG :> inG Σ (authR (gset_disjUR gname));
- barrier_savedPropG :> savedPropG Σ;
-}.
-Definition barrierΣ {SI} : gFunctors SI :=
- #[ GFunctor (authRF (gset_disjUR gname)); savedPropΣ ].
-
-Instance subG_barrierΣ `{Σ : gFunctors SI} : subG barrierΣ Σ → barrierG Σ.
-Proof. solve_inG. Qed.
-
-(** Now we come to the Iris part of the proof. *)
-Section proof.
-Context `{Σ : gFunctors SI} `{!heapG Σ, !barrierG Σ} (N : namespace).
-
-(* P is the proposition that will be sent, R the one that will be received by the individual threads *)
-Definition barrier_inv (l : loc) (γ : gname) (P : iProp Σ) : iProp Σ :=
- (∃ (b : bool) (γsps : gset gname) (oracle : gname -> iProp Σ),
- l ↦ #b ∗
- own γ (● (GSet γsps)) ∗
- ((if b then True else P) -∗ ▷ [∗ set] γsp ∈ γsps, oracle γsp) ∗
- ([∗ set] γsp ∈ γsps, saved_prop_own γsp (oracle γsp)))%I.
-
-(*P is the proposition that will be sent, R' the one that will be received by this particular thread, and R the one we want to have *)
-Definition recv (l : loc) (R : iProp Σ) : iProp Σ :=
- (∃ γ P R' γsp,
- inv N (barrier_inv l γ P) ∗
- ▷ (R' -∗ R) ∗
- own γ (◯ GSet {[ γsp ]}) ∗
- saved_prop_own γsp R')%I.
-
-(* P is the prop that we need to send *)
-Definition send (l : loc) (P : iProp Σ) : iProp Σ :=
- (∃ γ, inv N (barrier_inv l γ P))%I.
-
-(** Setoids *)
-Instance barrier_inv_ne l γ : NonExpansive (barrier_inv l γ).
-Proof. solve_proper. Qed.
-Global Instance send_ne l : NonExpansive (send l).
-Proof. solve_proper. Qed.
-Global Instance recv_ne l : NonExpansive (recv l).
-Proof. solve_proper. Qed.
-
-(** Actual proofs *)
-Lemma newbarrier_spec (P : iProp Σ) :
- {{{ True }}} newbarrier #() {{{ l, RET #l; recv l P ∗ send l P }}}.
-Proof.
- iIntros (Φ) "_ HΦ". iApply wp_fupd. wp_lam. wp_alloc l as "Hl".
- iApply ("HΦ" with "[> -]").
- iMod (saved_prop_alloc P) as (γsp) "#Hsp".
- iMod (own_alloc (● GSet {[ γsp ]} ⋅ ◯ GSet {[ γsp ]})) as (γ) "[H● H◯]".
- { by apply auth_both_valid. }
- iMod (inv_alloc N _ (barrier_inv l γ P) with "[Hl H●]") as "#Hinv".
- { iExists false, {[ γsp ]}, (fun _ => P). iIntros "{$Hl $H●} !>".
- rewrite !big_sepS_singleton; eauto. }
- iModIntro; iSplitL "H◯".
- - iExists γ, P, P, γsp. iFrame; auto.
- - by iExists γ.
-Qed.
-
-Lemma signal_spec l P :
- {{{ send l P ∗ P }}} signal #l {{{ RET #(); True }}}.
-Proof.
- iIntros (Φ) "[Hs HP] HΦ".
- iDestruct "Hs" as (γ) "#Hinv". wp_lam.
- wp_swp. iInv "Hinv" as "H".
- swp_last_step. iNext; simpl.
- iDestruct "H" as ([] γsps oracle) "(Hl & H● & HRs & Hsaved)".
- { wp_store. iModIntro. iSplitR "HΦ"; last by iApply "HΦ".
- iExists true, γsps, oracle. iFrame. }
- wp_store. iDestruct ("HRs" with "HP") as "HRs".
- iModIntro. iSplitR "HΦ"; last by iApply "HΦ".
- iExists true, γsps, oracle. iFrame; eauto.
-Qed.
-
-Lemma wait_spec l P:
- {{{ recv l P }}} wait #l {{{ RET #(); P }}}.
-Proof.
- rename P into R.
- iIntros (Φ) "HR HΦ".
- iDestruct "HR" as (γ P R' γsp) "(#Hinv & HR & H◯ & #Hsp)".
- iLöb as "IH". wp_rec. wp_bind (! _)%E.
- iInv "Hinv" as "H". wp_swp. swp_step. iNext; simpl.
- iDestruct "H" as ([] γsps oracle) "(Hl & H● & HRs & Hsaved)"; last first.
- { wp_load. iModIntro. iSplitL "Hl H● HRs Hsaved".
- { iExists false, γsps, oracle. iFrame. }
- by wp_apply ("IH" with "[$] [$]"). }
- iSpecialize ("HRs" with "[//]").
- swp_last_step. iNext. wp_load.
- iDestruct (own_valid_2 with "H● H◯")
- as %[Hvalid%gset_disj_included%elem_of_subseteq_singleton _]%auth_both_valid.
- iDestruct (big_sepS_delete with "HRs") as "[HR'' HRs]"; first done.
- iDestruct (big_sepS_delete with "Hsaved") as "[HRsaved Hsaved]"; first done.
- iDestruct (saved_prop_agree with "Hsp HRsaved") as "#Heq".
- iMod (own_update_2 with "H● H◯") as "H●".
- { apply (auth_update_dealloc _ _ (GSet (γsps ∖ {[ γsp ]}))).
- apply gset_disj_dealloc_local_update. }
- iIntros "!>". iSplitL "Hl H● HRs Hsaved".
- { iModIntro.
- iExists true, (γsps ∖ {[ γsp ]}), oracle. iFrame; eauto.
- }
- wp_if. iApply "HΦ". iApply "HR". by iRewrite "Heq".
-Qed.
-
-Lemma recv_split E l P1 P2 :
- ↑N ⊆ E → ⊢ (recv l (P1 ∗ P2) -∗ |={E, ∅}=> ▷ |={∅, E}=> recv l P1 ∗ recv l P2)%I.
-Proof.
- rename P1 into R1; rename P2 into R2.
- iIntros (?). iDestruct 1 as (γ P R' γsp) "(#Hinv & HR & H◯ & #Hsp)".
- iInv N as "H" "Hclose".
- iMod (fupd_intro_mask' (E ∖ ↑N) ∅) as "H3". set_solver.
- iModIntro. iNext.
- iDestruct "H" as (b γsps oracle) "(Hl & H● & HRs & Hsaved)". (* as later does not commute with exists, this would fail without taking a step *)
- iDestruct (own_valid_2 with "H● H◯")
- as %[Hvalid%gset_disj_included%elem_of_subseteq_singleton _]%auth_both_valid.
- set (γsps' := γsps ∖ {[γsp]}).
- iMod (own_update_2 with "H● H◯") as "H●".
- { apply (auth_update_dealloc _ _ (GSet γsps')).
- apply gset_disj_dealloc_local_update. }
- iMod (saved_prop_alloc_cofinite γsps' R1) as (γsp1 Hγsp1) "#Hsp1".
- iMod (saved_prop_alloc_cofinite (γsps' ∪ {[ γsp1 ]}) R2)
- as (γsp2 [? ?%not_elem_of_singleton]%not_elem_of_union) "#Hsp2".
- iMod (own_update _ _ (● _ ⋅ (◯ GSet {[ γsp1 ]} ⋅ ◯ (GSet {[ γsp2 ]})))
- with "H●") as "(H● & H◯1 & H◯2)".
- { rewrite -auth_frag_op gset_disj_union; last set_solver.
- apply auth_update_alloc, (gset_disj_alloc_empty_local_update _ {[ γsp1; γsp2 ]}).
- set_solver. }
- iMod "H3" as "_".
- iMod ("Hclose" with "[HR Hl HRs Hsaved H●]") as "_".
- { iModIntro. iExists b, ({[γsp1; γsp2]} ∪ γsps'),
- (fun g => if (decide (g = γsp1)) then R1 else if (decide (g = γsp2)) then R2 else oracle g).
- iIntros "{$Hl $H●}".
- iDestruct (big_sepS_delete with "Hsaved") as "[HRsaved Hsaved]"; first done.
- iSplitL "HR HRs HRsaved".
- - iIntros "HP". iSpecialize ("HRs" with "HP").
- iDestruct (saved_prop_agree with "Hsp HRsaved") as "#Heq".
- iNext.
- iDestruct (big_sepS_delete with "HRs") as "[HR'' HRs]"; first done.
- iApply big_sepS_union; [set_solver|iSplitL "HR HR'' HRsaved"]; first last.
- {
- subst γsps'. iApply big_opS_forall. 2: iApply "HRs". cbn. intros γ' Hin.
- destruct (decide (γ' = γsp1)) as [-> |_]. 1: by destruct Hγsp1.
- destruct (decide (γ' = γsp2)) as [-> |_]. 1: by destruct H0.
- reflexivity.
- }
- iApply big_sepS_union; [set_solver|].
- iAssert (R')%I with "[HR'']" as "HR'"; [by iRewrite "Heq"|].
- iDestruct ("HR" with "HR'") as "[HR1 HR2]".
- iSplitL "HR1".
- + iApply big_sepS_singleton. rewrite decide_True; done.
- + iApply big_sepS_singleton. rewrite decide_False; [by rewrite decide_True | done].
- - iApply big_sepS_union; [set_solver| iSplitR "Hsaved"]; first last.
- {
- subst γsps'. iApply big_opS_forall. 2: iApply "Hsaved". cbn. intros γ' Hin.
- destruct (decide (γ' = γsp1)) as [-> | _]. by destruct Hγsp1.
- destruct (decide (γ' = γsp2)) as [-> | _]. by destruct H0.
- reflexivity.
- }
- iApply big_sepS_union; [set_solver|]; rewrite !big_sepS_singleton.
- iSplitL.
- + rewrite decide_True; done.
- + rewrite decide_False; [by rewrite decide_True | done].
- }
- iModIntro; iSplitL "H◯1".
- - iExists γ, P, R1, γsp1. iFrame; auto.
- - iExists γ, P, R2, γsp2. iFrame; auto.
-Qed.
-
-Lemma recv_weaken l P1 P2 : (P1 -∗ P2) -∗ recv l P1 -∗ recv l P2.
-Proof.
- iIntros "HP". iDestruct 1 as (γ P R' i) "(#Hinv & HR & H◯)".
- iExists γ, P, R', i. iIntros "{$Hinv $H◯} !> HR'". iApply "HP". by iApply "HR".
-Qed.
-
-Lemma recv_mono l P1 P2 : (P1 ⊢ P2) → recv l P1 ⊢ recv l P2.
-Proof. iIntros (HP) "H". iApply (recv_weaken with "[] H"). iApply HP. Qed.
-End proof.
-
-Typeclasses Opaque send recv.
diff --git a/theories/examples/safety/barrier/specification.v b/theories/examples/safety/barrier/specification.v
deleted file mode 100644
index 99ff8843..00000000
--- a/theories/examples/safety/barrier/specification.v
+++ /dev/null
@@ -1,30 +0,0 @@
-From iris.program_logic Require Export hoare.
-From iris.heap_lang Require Import proofmode.
-From iris.examples.safety.barrier Require Export barrier.
-From iris.examples.safety.barrier Require Import proof.
-Set Default Proof Using "Type".
-Import uPred.
-
-Section spec.
-Local Set Default Proof Using "Type*".
-Context `{Σ : gFunctors SI} `{!heapG Σ, !barrierG Σ}.
-
-Lemma barrier_spec (N : namespace) :
- ∃ recv send : loc → iProp Σ -n> iProp Σ,
- (∀ P, ⊢ {{ True }} newbarrier #()
- {{ v, ∃ l : loc, ⌜v = #l⌝ ∗ recv l P ∗ send l P }}) ∧
- (∀ l P, ⊢ {{ send l P ∗ P }} signal #l {{ _, True }}) ∧
- (∀ l P, ⊢ {{ recv l P }} wait #l {{ _, P }}) ∧
- (∀ l P Q, recv l (P ∗ Q) -∗ |={↑N, ∅}=> ▷ |={∅, ↑N}=> recv l P ∗ recv l Q) ∧
- (∀ l P Q, (P -∗ Q) -∗ recv l P -∗ recv l Q).
-Proof.
- exists (λ l, OfeMor (recv N l)), (λ l, OfeMor (send N l)).
- split_and?; simpl.
- - iIntros (P) "!# _". iApply (newbarrier_spec _ P with "[]"); [done..|].
- iNext. eauto.
- - iIntros (l P) "!# [Hl HP]". iApply (signal_spec with "[$Hl $HP]"). by eauto.
- - iIntros (l P) "!# Hl". iApply (wait_spec with "Hl"). eauto.
- - iIntros (l P Q). by iApply recv_split.
- - apply recv_weaken.
-Qed.
-End spec.
diff --git a/theories/examples/safety/clairvoyant_coin.v b/theories/examples/safety/clairvoyant_coin.v
deleted file mode 100644
index bdd90907..00000000
--- a/theories/examples/safety/clairvoyant_coin.v
+++ /dev/null
@@ -1,84 +0,0 @@
-From iris.base_logic Require Export invariants.
-From iris.program_logic Require Export weakestpre.
-From iris.heap_lang Require Export lang proofmode notation.
-From iris.examples.safety Require Export nondet_bool.
-
-(** The clairvoyant coin predicts all the values that it will
-*non-deterministically* choose throughout the execution of the
-program. This can be seen in the spec. The predicate [coin c bs]
-expresses that [bs] is the list of all the values of the coin in the
-future. The [read_coin] operation always returns the head of [bs] and the
-[toss_coin] operation takes the [tail] of [bs]. *)
-
-Definition new_coin: val :=
- λ: <>, (ref (nondet_bool #()), NewProph).
-
-Definition read_coin : val := λ: "cp", !(Fst "cp").
-
-Definition toss_coin : val :=
- λ: "cp",
- let: "c" := Fst "cp" in
- let: "p" := Snd "cp" in
- let: "r" := nondet_bool #() in
- "c" <- "r";; resolve_proph: "p" to: "r";; #().
-
-Section proof.
- Context {SI} {Σ: gFunctors SI} `{!heapG Σ}.
-
- Definition prophecy_to_list_bool (vs : list (val * val)) : list bool :=
- (λ v, bool_decide (v = #true)) ∘ snd <$> vs.
-
- Definition coin (cp : val) (bs : list bool) : iProp Σ :=
- (∃ (c : loc) (p : proph_id) (vs : list (val * val)),
- ⌜cp = (#c, #p)%V⌝ ∗
- ⌜bs ≠ []⌝ ∗ ⌜tail bs = prophecy_to_list_bool vs⌝ ∗
- proph p vs ∗
- from_option (λ b : bool, c ↦ #b) (∃ b : bool, c ↦ #b) (head bs))%I.
-
- Lemma new_coin_spec : {{{ True }}} new_coin #() {{{ c bs, RET c; coin c bs }}}.
- Proof.
- iIntros (Φ) "_ HΦ".
- wp_lam.
- wp_apply wp_new_proph; first done.
- iIntros (vs p) "Hp".
- wp_apply nondet_bool_spec; first done.
- iIntros (b) "_".
- wp_alloc c as "Hc".
- wp_pair.
- iApply ("HΦ" $! (#c, #p)%V (b :: prophecy_to_list_bool vs)).
- rewrite /coin; eauto with iFrame.
- Qed.
-
- Lemma read_coin_spec cp bs :
- {{{ coin cp bs }}}
- read_coin cp
- {{{b bs', RET #b; ⌜bs = b :: bs'⌝ ∗ coin cp bs }}}.
- Proof.
- iIntros (Φ) "Hc HΦ".
- iDestruct "Hc" as (c p vs -> ? ?) "[Hp Hb]".
- destruct bs as [|b bs]; simplify_eq/=.
- wp_lam. wp_load.
- iApply "HΦ"; iSplit; first done.
- rewrite /coin; eauto 10 with iFrame.
- Qed.
-
- Lemma toss_coin_spec cp bs :
- {{{ coin cp bs }}}
- toss_coin cp
- {{{b bs', RET #(); ⌜bs = b :: bs'⌝ ∗ coin cp bs' }}}.
- Proof.
- iIntros (Φ) "Hc HΦ".
- iDestruct "Hc" as (c p vs -> ? ?) "[Hp Hb]".
- destruct bs as [|b bs]; simplify_eq/=.
- wp_lam. do 2 (wp_proj; wp_let).
- wp_apply nondet_bool_spec; first done.
- iIntros (r) "_".
- wp_store.
- wp_apply (wp_resolve_proph with "[Hp]"); first done.
- iIntros (ws) "[-> Hp]".
- wp_seq.
- iApply "HΦ"; iSplit; first done.
- destruct r; rewrite /coin; eauto 10 with iFrame.
- Qed.
-
-End proof.
diff --git a/theories/examples/safety/counter.v b/theories/examples/safety/counter.v
deleted file mode 100644
index 27381bf5..00000000
--- a/theories/examples/safety/counter.v
+++ /dev/null
@@ -1,173 +0,0 @@
-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 auth.
-From iris.heap_lang Require Import proofmode notation.
-Set Default Proof Using "Type".
-
-Definition newcounter : val := λ: <>, ref #0.
-Definition incr : val := rec: "incr" "l" :=
- let: "n" := !"l" in
- if: CAS "l" "n" (#1 + "n") then #() else "incr" "l".
-Definition read : val := λ: "l", !"l".
-
-(** Monotone counter *)
-Class mcounterG {SI} (Σ: gFunctors SI) := MCounterG { mcounter_inG :> inG Σ (authR (mnatUR SI)) }.
-Definition mcounterΣ {SI} : gFunctors SI := #[GFunctor (authR (mnatUR SI))].
-
-Instance subG_mcounterΣ {SI} {Σ: gFunctors SI} : subG mcounterΣ Σ → mcounterG Σ.
-Proof. solve_inG. Qed.
-
-Section mono_proof.
- Context {SI} {Σ: gFunctors SI} `{!heapG Σ, !mcounterG Σ} (N : namespace).
-
- Definition mcounter_inv (γ : gname) (l : loc) : iProp Σ :=
- (∃ n, own γ (● (n : mnat)) ∗ l ↦ #n)%I.
-
- Definition mcounter (l : loc) (n : nat) : iProp Σ :=
- (∃ γ, inv N (mcounter_inv γ l) ∧ own γ (◯ (n : mnat)))%I.
-
- (** The main proofs. *)
- Global Instance mcounter_persistent l n : Persistent (mcounter l n).
- Proof. apply _. Qed.
-
- Lemma newcounter_mono_spec :
- {{{ True }}} newcounter #() {{{ l, RET #l; mcounter l 0 }}}.
- Proof.
- iIntros (Φ) "_ HΦ". rewrite -wp_fupd /newcounter /=. wp_lam. wp_alloc l as "Hl".
- iMod (own_alloc (● (O:mnat) ⋅ ◯ (O:mnat))) as (γ) "[Hγ Hγ']";
- first by apply auth_both_valid.
- iMod (inv_alloc N _ (mcounter_inv γ l) with "[Hl Hγ]").
- { iNext. iExists 0%nat. by iFrame. }
- iModIntro. iApply "HΦ". rewrite /mcounter; eauto 10.
- Qed.
-
- Lemma incr_mono_spec l n :
- {{{ mcounter l n }}} incr #l {{{ RET #(); mcounter l (S n) }}}.
- Proof.
- iIntros (Φ) "Hl HΦ". iLöb as "IH". wp_rec.
- iDestruct "Hl" as (γ) "[#? Hγf]".
- wp_bind (! _)%E.
- wp_swp 1%nat. iInv N as "H". swp_step. iNext. iDestruct "H" as (c) "[Hγ Hl]".
- wp_load. iModIntro. iSplitL "Hl Hγ"; [iNext; iExists c; by iFrame|].
- wp_pures. wp_bind (CmpXchg _ _ _).
- wp_swp 1%nat. iInv N as "H". swp_step. iNext. iDestruct "H" as (c') "[Hγ Hl]".
- destruct (decide (c' = c)) as [->|].
- - iDestruct (own_valid_2 with "Hγ Hγf")
- as %[?%mnat_included _]%auth_both_valid.
- iMod (own_update_2 with "Hγ Hγf") as "[Hγ Hγf]".
- { apply auth_update, (mnat_local_update _ _ (S c)); auto. }
- wp_cmpxchg_suc. iModIntro. iSplitL "Hl Hγ".
- { iNext. iExists (S c). rewrite Nat2Z.inj_succ Z.add_1_l. by iFrame. }
- wp_pures. iApply "HΦ"; iExists γ; repeat iSplit; eauto.
- iApply (own_mono with "Hγf").
- (* FIXME: FIXME(Coq #6294): needs new unification *)
- apply: auth_frag_mono. by apply mnat_included, le_n_S.
- - wp_cmpxchg_fail; first (by intros [= ?%Nat2Z.inj]). iModIntro.
- iSplitL "Hl Hγ"; [iNext; iExists c'; by iFrame|].
- wp_pures. iApply ("IH" with "[Hγf] [HΦ]"); last by auto.
- rewrite {3}/mcounter; simpl; eauto 10.
- Qed.
-
- Lemma read_mono_spec l j :
- {{{ mcounter l j }}} read #l {{{ i, RET #i; ⌜j ≤ i⌝%nat ∧ mcounter l i }}}.
- Proof.
- iIntros (ϕ) "Hc HΦ". iDestruct "Hc" as (γ) "[#Hinv Hγf]".
- rewrite /read /=. wp_lam.
- wp_swp 1%nat. iInv N as "H". swp_step. iNext. iDestruct "H" as (c) "[Hγ Hl]".
- wp_load.
- iDestruct (own_valid_2 with "Hγ Hγf")
- as %[?%mnat_included _]%auth_both_valid.
- iMod (own_update_2 with "Hγ Hγf") as "[Hγ Hγf]".
- { apply auth_update, (mnat_local_update _ _ c); auto. }
- iModIntro. iSplitL "Hl Hγ"; [iNext; iExists c; by iFrame|].
- iApply ("HΦ" with "[-]"). rewrite /mcounter; simpl; eauto 10.
- Qed.
-End mono_proof.
-
-(** Counter with contributions *)
-Class ccounterG {SI} Σ :=
- CCounterG { ccounter_inG :> inG Σ (frac_authR (natR SI)) }.
-Definition ccounterΣ {SI} : gFunctors SI :=
- #[GFunctor (frac_authR (natR SI))].
-
-Instance subG_ccounterΣ {SI} {Σ: gFunctors SI} : subG ccounterΣ Σ → ccounterG Σ.
-Proof. solve_inG. Qed.
-
-Section contrib_spec.
- Context {SI} {Σ: gFunctors SI} `{!heapG Σ, !ccounterG Σ} (N : namespace).
-
- Definition ccounter_inv (γ : gname) (l : loc) : iProp Σ :=
- (∃ n, own γ (●F n) ∗ l ↦ #n)%I.
-
- Definition ccounter_ctx (γ : gname) (l : loc) : iProp Σ :=
- inv N (ccounter_inv γ l).
-
- Definition ccounter (γ : gname) (q : frac) (n : nat) : iProp Σ :=
- own γ (◯F{q} n).
-
- (** The main proofs. *)
- Lemma ccounter_op γ q1 q2 n1 n2 :
- ccounter γ (q1 + q2) (n1 + n2) ⊣⊢ ccounter γ q1 n1 ∗ ccounter γ q2 n2.
- Proof. by rewrite /ccounter frac_auth_frag_op -own_op. Qed.
-
- Lemma newcounter_contrib_spec (R : iProp Σ) :
- {{{ True }}} newcounter #()
- {{{ γ l, RET #l; ccounter_ctx γ l ∗ ccounter γ 1 0 }}}.
- Proof.
- iIntros (Φ) "_ HΦ". rewrite -wp_fupd /newcounter /=. wp_lam. wp_alloc l as "Hl".
- iMod (own_alloc (●F O%nat ⋅ ◯F 0%nat)) as (γ) "[Hγ Hγ']";
- first by apply auth_both_valid.
- iMod (inv_alloc N _ (ccounter_inv γ l) with "[Hl Hγ]").
- { iNext. iExists 0%nat. by iFrame. }
- iModIntro. iApply "HΦ". rewrite /ccounter_ctx /ccounter; eauto 10.
- Qed.
-
- Lemma incr_contrib_spec γ l q n :
- {{{ ccounter_ctx γ l ∗ ccounter γ q n }}} incr #l
- {{{ RET #(); ccounter γ q (S n) }}}.
- Proof.
- iIntros (Φ) "[#? Hγf] HΦ". iLöb as "IH". wp_rec.
- wp_bind (! _)%E.
- wp_swp 1%nat. iInv N as "H". swp_step. iNext. iDestruct "H" as (c) "[Hγ Hl]".
- wp_load. iModIntro. iSplitL "Hl Hγ"; [iNext; iExists c; by iFrame|].
- wp_pures. wp_bind (CmpXchg _ _ _).
- wp_swp 1%nat. iInv N as "H". swp_step. iNext. iDestruct "H" as (c') "[Hγ Hl]".
- destruct (decide (c' = c)) as [->|].
- - iMod (own_update_2 with "Hγ Hγf") as "[Hγ Hγf]".
- { apply frac_auth_update, (nat_local_update _ _ (S c) (S n)); lia. }
- wp_cmpxchg_suc. iModIntro. iSplitL "Hl Hγ".
- { iNext. iExists (S c). rewrite Nat2Z.inj_succ Z.add_1_l. by iFrame. }
- wp_pures. by iApply "HΦ".
- - wp_cmpxchg_fail; first (by intros [= ?%Nat2Z.inj]).
- iModIntro. iSplitL "Hl Hγ"; [iNext; iExists c'; by iFrame|].
- wp_pures. by iApply ("IH" with "[Hγf] [HΦ]"); auto.
- Qed.
-
- Lemma read_contrib_spec γ l q n :
- {{{ ccounter_ctx γ l ∗ ccounter γ q n }}} read #l
- {{{ c, RET #c; ⌜n ≤ c⌝%nat ∧ ccounter γ q n }}}.
- Proof.
- iIntros (Φ) "[#? Hγf] HΦ".
- rewrite /read /=. wp_lam.
- wp_swp 1%nat. iInv N as "H". swp_step. iNext. iDestruct "H" as (c) "[Hγ Hl]".
- wp_load.
- iDestruct (own_valid_2 with "Hγ Hγf") as % ?%frac_auth_included_total%nat_included.
- iModIntro. iSplitL "Hl Hγ"; [iNext; iExists c; by iFrame|].
- iApply ("HΦ" with "[-]"); rewrite /ccounter; simpl; eauto 10.
- Qed.
-
- Lemma read_contrib_spec_1 γ l n :
- {{{ ccounter_ctx γ l ∗ ccounter γ 1 n }}} read #l
- {{{ n, RET #n; ccounter γ 1 n }}}.
- Proof.
- iIntros (Φ) "[#? Hγf] HΦ".
- rewrite /read /=. wp_lam.
- wp_swp 1%nat. iInv N as "H". swp_step. iNext. iDestruct "H" as (c) "[Hγ Hl]".
- wp_load.
- iDestruct (own_valid_2 with "Hγ Hγf") as % <-%frac_auth_agreeL.
- iModIntro. iSplitL "Hl Hγ"; [iNext; iExists c; by iFrame|].
- by iApply "HΦ".
- Qed.
-End contrib_spec.
diff --git a/theories/examples/safety/lazy_coin.v b/theories/examples/safety/lazy_coin.v
deleted file mode 100644
index adb4ee3d..00000000
--- a/theories/examples/safety/lazy_coin.v
+++ /dev/null
@@ -1,68 +0,0 @@
-From iris.base_logic Require Export invariants.
-From iris.program_logic Require Export weakestpre.
-From iris.heap_lang Require Export lang proofmode notation.
-From iris.examples.safety Require Export nondet_bool.
-
-Definition new_coin: val := λ: <>, (ref NONE, NewProph).
-
-Definition read_coin : val :=
- λ: "cp",
- let: "c" := Fst "cp" in
- let: "p" := Snd "cp" in
- match: !"c" with
- NONE => let: "r" := nondet_bool #() in
- "c" <- SOME "r";; resolve_proph: "p" to: "r";; "r"
- | SOME "b" => "b"
- end.
-
-Section proof.
- Context {SI} {Σ: gFunctors SI} `{!heapG Σ}.
-
- Definition val_to_bool (v : val) : bool := bool_decide (v = #true).
-
- Definition prophecy_to_bool (vs : list (val * val)) : bool :=
- default false (val_to_bool ∘ snd <$> head vs).
-
- Lemma prophecy_to_bool_of_bool (b : bool) v vs :
- prophecy_to_bool ((v, #b) :: vs) = b.
- Proof. by destruct b. Qed.
-
- Definition coin (cp : val) (b : bool) : iProp Σ :=
- (∃ (c : loc) (p : proph_id) (vs : list (val * val)),
- ⌜cp = (#c, #p)%V⌝ ∗ proph p vs ∗
- (c ↦ SOMEV #b ∨ (c ↦ NONEV ∗ ⌜b = prophecy_to_bool vs⌝)))%I.
-
- Lemma new_coin_spec : {{{ True }}} new_coin #() {{{ c b, RET c; coin c b }}}.
- Proof.
- iIntros (Φ) "_ HΦ".
- wp_lam.
- wp_apply wp_new_proph; first done.
- iIntros (vs p) "Hp".
- wp_alloc c as "Hc".
- wp_pair.
- iApply ("HΦ" $! (#c, #p)%V ).
- rewrite /coin; eauto 10 with iFrame.
- Qed.
-
- Lemma read_coin_spec cp b :
- {{{ coin cp b }}} read_coin cp {{{ RET #b; coin cp b }}}.
- Proof.
- iIntros (Φ) "Hc HΦ".
- iDestruct "Hc" as (c p vs ->) "[Hp [Hc | [Hc ->]]]".
- - wp_lam. wp_load. wp_match.
- iApply "HΦ".
- rewrite /coin; eauto 10 with iFrame.
- - wp_lam. wp_load. wp_match.
- wp_apply nondet_bool_spec; first done.
- iIntros (r) "_".
- wp_let.
- wp_store.
- wp_apply (wp_resolve_proph with "[Hp]"); first done.
- iIntros (ws) "[-> Hws]".
- rewrite !prophecy_to_bool_of_bool.
- wp_seq.
- iApply "HΦ".
- rewrite /coin; eauto with iFrame.
- Qed.
-
-End proof.
diff --git a/theories/examples/safety/lock.v b/theories/examples/safety/lock.v
deleted file mode 100644
index df71e47b..00000000
--- a/theories/examples/safety/lock.v
+++ /dev/null
@@ -1,39 +0,0 @@
-From iris.heap_lang Require Export lifting notation.
-From iris.base_logic.lib Require Export invariants.
-Set Default Proof Using "Type".
-
-Structure lock {SI} (Σ: gFunctors SI) `{!heapG Σ} := Lock {
- (* -- operations -- *)
- newlock : val;
- acquire : val;
- release : val;
- (* -- predicates -- *)
- (* name is used to associate locked with is_lock *)
- name : Type;
- is_lock (N: namespace) (γ: name) (lock: val) (R: iProp Σ) : iProp Σ;
- locked (γ: name) : iProp Σ;
- (* -- general properties -- *)
- is_lock_ne N γ lk : NonExpansive (is_lock N γ lk);
- is_lock_persistent N γ lk R : Persistent (is_lock N γ lk R);
- locked_timeless γ : Timeless (locked γ);
- locked_exclusive γ : locked γ -∗ locked γ -∗ False;
- (* -- operation specs -- *)
- newlock_spec N (R : iProp Σ) :
- {{{ R }}} newlock #() {{{ lk γ, RET lk; is_lock N γ lk R }}};
- acquire_spec N γ lk R :
- {{{ is_lock N γ lk R }}} acquire lk {{{ RET #(); locked γ ∗ R }}};
- release_spec N γ lk R :
- {{{ is_lock N γ lk R ∗ locked γ ∗ R }}} release lk {{{ RET #(); True }}}
-}.
-
-Arguments newlock {_ _ _} _.
-Arguments acquire {_ _ _} _.
-Arguments release {_ _ _} _.
-Arguments is_lock {_ _ _} _ _ _ _ _.
-Arguments locked {_ _ _} _ _.
-
-Existing Instances is_lock_ne is_lock_persistent locked_timeless.
-
-Instance is_lock_proper {SI} (Σ: gFunctors SI) `{!heapG Σ} (L: lock Σ) N γ lk:
- Proper ((≡) ==> (≡)) (is_lock L N γ lk) := ne_proper _.
-
diff --git a/theories/examples/safety/nondet_bool.v b/theories/examples/safety/nondet_bool.v
deleted file mode 100644
index f07854e3..00000000
--- a/theories/examples/safety/nondet_bool.v
+++ /dev/null
@@ -1,25 +0,0 @@
-From iris.base_logic Require Export invariants.
-From iris.program_logic Require Export weakestpre.
-From iris.heap_lang Require Export lang proofmode notation.
-
-Definition nondet_bool : val :=
- λ: <>, let: "l" := ref #true in Fork ("l" <- #false);; !"l".
-
-Section proof.
- Context {SI} {Σ: gFunctors SI} `{!heapG Σ}.
-
- Lemma nondet_bool_spec : {{{ True }}} nondet_bool #() {{{ (b : bool), RET #b; True }}}.
- Proof.
- iIntros (Φ) "_ HΦ".
- wp_lam. wp_alloc l as "Hl". wp_let.
- pose proof (nroot .@ "rnd") as rndN.
- iMod (inv_alloc rndN _ (∃ (b : bool), l ↦ #b)%I with "[Hl]") as "#Hinv";
- first by eauto.
- wp_apply wp_fork.
- - wp_swp 1%nat. iInv rndN as "H". swp_step. iNext. iDestruct "H" as (?) "?". wp_store; eauto.
- - wp_seq. wp_swp 1%nat. iInv rndN as "H". swp_step. iNext. iDestruct "H" as (?) "?". wp_load.
- iSplitR "HΦ"; first by eauto.
- by iApply "HΦ".
- Qed.
-
-End proof.
diff --git a/theories/examples/safety/par.v b/theories/examples/safety/par.v
deleted file mode 100644
index 57c6ea6a..00000000
--- a/theories/examples/safety/par.v
+++ /dev/null
@@ -1,46 +0,0 @@
-From iris.examples.safety Require Export spawn.
-From iris.heap_lang Require Import proofmode notation.
-Set Default Proof Using "Type".
-Import uPred.
-
-Definition parN : namespace := nroot .@ "par".
-
-Definition par : val :=
- λ: "e1" "e2",
- let: "handle" := spawn "e1" in
- let: "v2" := "e2" #() in
- let: "v1" := join "handle" in
- ("v1", "v2").
-Notation "e1 ||| e2" := (par (λ: <>, e1)%E (λ: <>, e2)%E) : expr_scope.
-Notation "e1 ||| e2" := (par (λ: <>, e1)%V (λ: <>, e2)%V) : val_scope.
-
-Section proof.
-Local Set Default Proof Using "Type*".
-Context {SI} {Σ: gFunctors SI} `{!heapG Σ, !spawnG Σ}.
-
-(* Notice that this allows us to strip a later *after* the two Ψ have been
- brought together. That is strictly stronger than first stripping a later
- and then merging them, as demonstrated by [tests/joining_existentials.v].
- This is why these are not Texan triples. *)
-Lemma par_spec (Ψ1 Ψ2 : val → iProp Σ) (f1 f2 : val) (Φ : val → iProp Σ) :
- WP f1 #() {{ Ψ1 }} -∗ WP f2 #() {{ Ψ2 }} -∗
- (▷ ∀ v1 v2, Ψ1 v1 ∗ Ψ2 v2 -∗ ▷ Φ (v1,v2)%V) -∗
- WP par f1 f2 {{ Φ }}.
-Proof.
- iIntros "Hf1 Hf2 HΦ". wp_lam. wp_let.
- wp_apply (spawn_spec parN with "Hf1").
- iIntros (l) "Hl". wp_let. wp_bind (f2 _).
- wp_apply (wp_wand with "Hf2"); iIntros (v) "H2". wp_let.
- wp_apply (join_spec with "[$Hl]"). iIntros (w) "H1".
- iSpecialize ("HΦ" with "[$H1 $H2]"). by wp_pures.
-Qed.
-
-Lemma wp_par (Ψ1 Ψ2 : val → iProp Σ) (e1 e2 : expr) (Φ : val → iProp Σ) :
- WP e1 {{ Ψ1 }} -∗ WP e2 {{ Ψ2 }} -∗
- (∀ v1 v2, Ψ1 v1 ∗ Ψ2 v2 -∗ ▷ Φ (v1,v2)%V) -∗
- WP (e1 ||| e2)%V {{ Φ }}.
-Proof.
- iIntros "H1 H2 H".
- wp_apply (par_spec Ψ1 Ψ2 with "[H1] [H2] [H]"); [by wp_lam..|auto].
-Qed.
-End proof.
diff --git a/theories/examples/safety/spawn.v b/theories/examples/safety/spawn.v
deleted file mode 100644
index 415dcd82..00000000
--- a/theories/examples/safety/spawn.v
+++ /dev/null
@@ -1,78 +0,0 @@
-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.
-From iris.algebra Require Import excl.
-Set Default Proof Using "Type".
-
-Definition spawn : val :=
- λ: "f",
- let: "c" := ref NONE in
- Fork ("c" <- SOME ("f" #())) ;; "c".
-Definition join : val :=
- rec: "join" "c" :=
- match: !"c" with
- SOME "x" => "x"
- | NONE => "join" "c"
- end.
-
-(** The CMRA & functor we need. *)
-(* Not bundling heapG, as it may be shared with other users. *)
-Class spawnG {SI} (Σ: gFunctors SI) := SpawnG { spawn_tokG :> inG Σ (exclR (unitO SI)) }.
-Definition spawnΣ SI : gFunctors SI := #[GFunctor (exclR (unitO SI))].
-
-Instance subG_spawnΣ {SI} {Σ: gFunctors SI} : subG (spawnΣ SI) Σ → spawnG Σ.
-Proof. solve_inG. Qed.
-
-(** Now we come to the Iris part of the proof. *)
-Section proof.
-Context {SI} {Σ: gFunctors SI} `{!heapG Σ, !spawnG Σ} (N : namespace).
-
-Definition spawn_inv (γ : gname) (l : loc) (Ψ : val → iProp Σ) : iProp Σ :=
- (∃ lv, l ↦ lv ∗ (⌜lv = NONEV⌝ ∨
- ∃ w, ⌜lv = SOMEV w⌝ ∗ (Ψ w ∨ own γ (Excl ()))))%I.
-
-Definition join_handle (l : loc) (Ψ : val → iProp Σ) : iProp Σ :=
- (∃ γ, own γ (Excl ()) ∗ inv N (spawn_inv γ l Ψ))%I.
-
-Global Instance spawn_inv_ne n γ l :
- Proper (pointwise_relation val (dist n) ==> dist n) (spawn_inv γ l).
-Proof. solve_proper. Qed.
-Global Instance join_handle_ne n l :
- Proper (pointwise_relation val (dist n) ==> dist n) (join_handle l).
-Proof. solve_proper. Qed.
-
-(** The main proofs. *)
-Lemma spawn_spec (Ψ : val → iProp Σ) (f : val) :
- {{{ WP f #() {{ Ψ }} }}} spawn f {{{ l, RET #l; join_handle l Ψ }}}.
-Proof.
- iIntros (Φ) "Hf HΦ". rewrite /spawn /=. wp_lam.
- wp_alloc l as "Hl".
- iMod (own_alloc (Excl ())) as (γ) "Hγ"; first done.
- iMod (inv_alloc N _ (spawn_inv γ l Ψ) with "[Hl]") as "#?".
- { iNext. iExists NONEV. iFrame; eauto. }
- wp_apply (wp_fork with "[Hf]").
- - iNext. wp_bind (f _). iApply (wp_wand with "Hf"); iIntros (v) "Hv".
- wp_inj. iInv N as "H". wp_swp 1%nat. swp_step. iNext. iDestruct "H" as (v') "[Hl _]".
- wp_store. iSplitL; last done. iIntros "!> !>". iExists (SOMEV v). iFrame. eauto.
- - wp_pures. iApply "HΦ". rewrite /join_handle. eauto.
-Qed.
-
-Lemma join_spec (Ψ : val → iProp Σ) l :
- {{{ join_handle l Ψ }}} join #l {{{ v, RET v; Ψ v }}}.
-Proof.
- iIntros (Φ) "H HΦ". iDestruct "H" as (γ) "[Hγ #?]".
- iLöb as "IH". wp_rec. wp_bind (! _)%E.
- iInv N as "H". wp_swp 1%nat. swp_step. iNext. iDestruct "H" as (v) "[Hl Hinv]".
- wp_load. iDestruct "Hinv" as "[%|Hinv]"; subst.
- - iModIntro. iSplitL "Hl"; [iNext; iExists _; iFrame; eauto|].
- wp_apply ("IH" with "Hγ [HΦ]"). auto.
- - iDestruct "Hinv" as (v' ->) "[HΨ|Hγ']".
- + iModIntro. iSplitL "Hl Hγ"; [iNext; iExists _; iFrame; eauto|].
- wp_pures. by iApply "HΦ".
- + iDestruct (own_valid_2 with "Hγ Hγ'") as %[].
-Qed.
-End proof.
-
-Typeclasses Opaque join_handle.
diff --git a/theories/examples/safety/spin_lock.v b/theories/examples/safety/spin_lock.v
deleted file mode 100644
index e7357329..00000000
--- a/theories/examples/safety/spin_lock.v
+++ /dev/null
@@ -1,100 +0,0 @@
-From iris.program_logic Require Export weakestpre.
-From iris.heap_lang Require Export lang.
-From iris.proofmode Require Import tactics.
-From iris.heap_lang Require Import proofmode notation.
-From iris.algebra Require Import excl.
-From iris.examples.safety Require Import lock.
-Set Default Proof Using "Type".
-
-Definition newlock : val := λ: <>, ref #false.
-Definition try_acquire : val := λ: "l", CAS "l" #false #true.
-Definition acquire : val :=
- rec: "acquire" "l" := if: try_acquire "l" then #() else "acquire" "l".
-Definition release : val := λ: "l", "l" <- #false.
-
-(** The CMRA we need. *)
-(* Not bundling heapG, as it may be shared with other users. *)
-Class lockG {SI} (Σ: gFunctors SI) := LockG { lock_tokG :> inG Σ (exclR (unitO SI)) }.
-Definition lockΣ SI : gFunctors SI := #[GFunctor (exclR (unitO SI))].
-
-Instance subG_lockΣ {SI} {Σ: gFunctors SI} : subG (lockΣ SI) Σ → lockG Σ.
-Proof. solve_inG. Qed.
-
-Section proof.
- Context {SI} {Σ: gFunctors SI} `{!heapG Σ, !lockG Σ} (N : namespace).
-
- Definition lock_inv (γ : gname) (l : loc) (R : iProp Σ) : iProp Σ :=
- (∃ b : bool, l ↦ #b ∗ if b then True else own γ (Excl ()) ∗ R)%I.
-
- Definition is_lock (γ : gname) (lk : val) (R : iProp Σ) : iProp Σ :=
- (∃ l: loc, ⌜lk = #l⌝ ∧ inv N (lock_inv γ l R))%I.
-
- Definition locked (γ : gname) : iProp Σ := own γ (Excl ()).
-
- Lemma locked_exclusive (γ : gname) : locked γ -∗ locked γ -∗ False.
- Proof. iIntros "H1 H2". by iDestruct (own_valid_2 with "H1 H2") as %?. Qed.
-
- Global Instance lock_inv_ne γ l : NonExpansive (lock_inv γ l).
- Proof. solve_proper. Qed.
- Global Instance is_lock_ne γ l : NonExpansive (is_lock γ l).
- Proof. solve_proper. Qed.
-
- (** The main proofs. *)
- Global Instance is_lock_persistent γ l R : Persistent (is_lock γ l R).
- Proof. apply _. Qed.
- Global Instance locked_timeless γ : Timeless (locked γ).
- Proof. apply _. Qed.
-
- Lemma newlock_spec (R : iProp Σ):
- {{{ R }}} newlock #() {{{ lk γ, RET lk; is_lock γ lk R }}}.
- Proof.
- iIntros (Φ) "HR HΦ". rewrite -wp_fupd /newlock /=.
- wp_lam. wp_alloc l as "Hl".
- iMod (own_alloc (Excl ())) as (γ) "Hγ"; first done.
- iMod (inv_alloc N _ (lock_inv γ l R) with "[-HΦ]") as "#?".
- { iIntros "!>". iExists false. by iFrame. }
- iModIntro. iApply "HΦ". iExists l. eauto.
- Qed.
-
- Lemma try_acquire_spec γ lk R :
- {{{ is_lock γ lk R }}} try_acquire lk
- {{{ b, RET #b; if b is true then locked γ ∗ R else True }}}.
- Proof.
- iIntros (Φ) "#Hl HΦ". iDestruct "Hl" as (l ->) "#Hinv".
- wp_rec. wp_bind (CmpXchg _ _ _). wp_swp. iInv N as "H". swp_step. iNext.
- iDestruct "H" as ([]) "[Hl HR]".
- - wp_cmpxchg_fail. iModIntro. iSplitL "Hl"; first (iNext; iExists true; eauto).
- wp_pures. iApply ("HΦ" $! false). done.
- - wp_cmpxchg_suc. iDestruct "HR" as "[Hγ HR]".
- iModIntro. iSplitL "Hl"; first (iNext; iExists true; eauto).
- rewrite /locked. wp_pures. by iApply ("HΦ" $! true with "[$Hγ $HR]").
- Unshelve. exact 0%nat.
- Qed.
-
- Lemma acquire_spec γ lk R :
- {{{ is_lock γ lk R }}} acquire lk {{{ RET #(); locked γ ∗ R }}}.
- Proof.
- iIntros (Φ) "#Hl HΦ". iLöb as "IH". wp_rec.
- wp_apply (try_acquire_spec with "Hl"). iIntros ([]).
- - iIntros "[Hlked HR]". wp_if. iApply "HΦ"; iFrame.
- - iIntros "_". wp_if. iApply ("IH" with "[HΦ]"). auto.
- Qed.
-
- Lemma release_spec γ lk R :
- {{{ is_lock γ lk R ∗ locked γ ∗ R }}} release lk {{{ RET #(); True }}}.
- Proof.
- iIntros (Φ) "(Hlock & Hlocked & HR) HΦ".
- iDestruct "Hlock" as (l ->) "#Hinv".
- rewrite /release /=. wp_lam. wp_swp. iInv N as "H". swp_step. iNext.
- iDestruct "H" as (b) "[Hl _]".
- wp_store. iSplitR "HΦ"; last by iApply "HΦ".
- iModIntro. iNext. iExists false. by iFrame.
- Unshelve. exact 0%nat.
- Qed.
-End proof.
-
-Typeclasses Opaque is_lock locked.
-
-Canonical Structure spin_lock {SI} {Σ: gFunctors SI} `{!heapG Σ, !lockG Σ} : lock Σ :=
- {| lock.locked_exclusive := locked_exclusive; lock.newlock_spec := newlock_spec;
- lock.acquire_spec := acquire_spec; lock.release_spec := release_spec |}.
diff --git a/theories/examples/safety/ticket_lock.v b/theories/examples/safety/ticket_lock.v
deleted file mode 100644
index 104824ac..00000000
--- a/theories/examples/safety/ticket_lock.v
+++ /dev/null
@@ -1,167 +0,0 @@
-From iris.program_logic Require Export weakestpre.
-From iris.heap_lang Require Export lang.
-From iris.proofmode Require Import tactics.
-From iris.heap_lang Require Import proofmode notation.
-From iris.algebra Require Import excl auth gset.
-From iris.examples.safety Require Export lock.
-Set Default Proof Using "Type".
-Import uPred.
-
-Definition wait_loop: val :=
- rec: "wait_loop" "x" "lk" :=
- let: "o" := !(Fst "lk") in
- if: "x" = "o"
- then #() (* my turn *)
- else "wait_loop" "x" "lk".
-
-Definition newlock : val :=
- λ: <>, ((* owner *) ref #0, (* next *) ref #0).
-
-Definition acquire : val :=
- rec: "acquire" "lk" :=
- let: "n" := !(Snd "lk") in
- if: CAS (Snd "lk") "n" ("n" + #1)
- then wait_loop "n" "lk"
- else "acquire" "lk".
-
-Definition release : val :=
- λ: "lk", (Fst "lk") <- !(Fst "lk") + #1.
-
-(** The CMRAs we need. *)
-Class tlockG {SI} (Σ: gFunctors SI) :=
- tlock_G :> inG Σ (authR (prodUR (optionUR (exclR (natO SI))) (gset_disjUR nat))).
-Definition tlockΣ {SI} : gFunctors SI :=
- #[ GFunctor (authR (prodUR (optionUR (exclR (natO SI))) (gset_disjUR nat))) ].
-
-Instance subG_tlockΣ {SI} {Σ: gFunctors SI} : subG tlockΣ Σ → tlockG Σ.
-Proof. solve_inG. Qed.
-
-Section proof.
- Context {SI} {Σ: gFunctors SI} `{!heapG Σ, !tlockG Σ} (N : namespace).
-
- Definition lock_inv (γ : gname) (lo ln : loc) (R : iProp Σ) : iProp Σ :=
- (∃ o n : nat,
- lo ↦ #o ∗ ln ↦ #n ∗
- own γ (● (Excl' o, GSet (set_seq 0 n))) ∗
- ((own γ (◯ (Excl' o, GSet ∅)) ∗ R) ∨ own γ (◯ (ε, GSet {[ o ]}))))%I.
-
- Definition is_lock (γ : gname) (lk : val) (R : iProp Σ) : iProp Σ :=
- (∃ lo ln : loc,
- ⌜lk = (#lo, #ln)%V⌝ ∗ inv N (lock_inv γ lo ln R))%I.
-
- Definition issued (γ : gname) (x : nat) : iProp Σ :=
- own γ (◯ (ε, GSet {[ x ]}))%I.
-
- Definition locked (γ : gname) : iProp Σ := (∃ o, own γ (◯ (Excl' o, GSet ∅)))%I.
-
- Global Instance lock_inv_ne γ lo ln :
- NonExpansive (lock_inv γ lo ln).
- Proof. solve_proper. Qed.
- Global Instance is_lock_ne γ lk : NonExpansive (is_lock γ lk).
- Proof. solve_proper. Qed.
- Global Instance is_lock_persistent γ lk R : Persistent (is_lock γ lk R).
- Proof. apply _. Qed.
- Global Instance locked_timeless γ : Timeless (locked γ).
- Proof. apply _. Qed.
-
- Lemma locked_exclusive (γ : gname) : locked γ -∗ locked γ -∗ False.
- Proof.
- iDestruct 1 as (o1) "H1". iDestruct 1 as (o2) "H2".
- iDestruct (own_valid_2 with "H1 H2") as %[[] _].
- Qed.
-
- Lemma newlock_spec (R : iProp Σ) :
- {{{ R }}} newlock #() {{{ lk γ, RET lk; is_lock γ lk R }}}.
- Proof.
- iIntros (Φ) "HR HΦ". rewrite -wp_fupd. wp_lam.
- wp_alloc ln as "Hln". wp_alloc lo as "Hlo".
- iMod (own_alloc (● (Excl' 0%nat, GSet ∅) ⋅ ◯ (Excl' 0%nat, GSet ∅))) as (γ) "[Hγ Hγ']".
- { by apply auth_both_valid. }
- iMod (inv_alloc _ _ (lock_inv γ lo ln R) with "[-HΦ]").
- { iNext. rewrite /lock_inv.
- iExists 0%nat, 0%nat. iFrame. iLeft. by iFrame. }
- wp_pures. iModIntro. iApply ("HΦ" $! (#lo, #ln)%V γ). iExists lo, ln. eauto.
- Qed.
-
- Lemma wait_loop_spec γ lk x R :
- {{{ is_lock γ lk R ∗ issued γ x }}} wait_loop #x lk {{{ RET #(); locked γ ∗ R }}}.
- Proof.
- iIntros (Φ) "[Hl Ht] HΦ". iDestruct "Hl" as (lo ln ->) "#Hinv".
- iLöb as "IH". wp_rec. subst. wp_pures. wp_bind (! _)%E.
- wp_swp 1%nat. iInv N as "Hlock". swp_step. iNext. iDestruct "Hlock" as (o n) "(Hlo & Hln & Ha)".
- wp_load. destruct (decide (x = o)) as [->|Hneq].
- - iDestruct "Ha" as "[Hainv [[Ho HR] | Haown]]".
- + iModIntro. iSplitL "Hlo Hln Hainv Ht".
- { iNext. iExists o, n. iFrame. }
- wp_pures. case_bool_decide; [|done]. wp_if.
- iApply ("HΦ" with "[-]"). rewrite /locked. iFrame. simpl. eauto.
- + iDestruct (own_valid_2 with "Ht Haown") as % [_ ?%gset_disj_valid_op].
- set_solver.
- - iModIntro. iSplitL "Hlo Hln Ha".
- { iNext. iExists o, n. by iFrame. }
- wp_pures. case_bool_decide; [simplify_eq |].
- wp_if. iApply ("IH" with "Ht"). iNext. by iExact "HΦ".
- Qed.
-
- Lemma acquire_spec γ lk R :
- {{{ is_lock γ lk R }}} acquire lk {{{ RET #(); locked γ ∗ R }}}.
- Proof.
- iIntros (ϕ) "Hl HΦ". iDestruct "Hl" as (lo ln ->) "#Hinv".
- iLöb as "IH". wp_rec. wp_bind (! _)%E. simplify_eq/=. wp_proj.
- wp_swp 1%nat. iInv N as "Hlock". swp_step. iNext. iDestruct "Hlock" as (o n) "(Hlo & Hln & Ha)".
- wp_load. iModIntro. iSplitL "Hlo Hln Ha".
- { iNext. iExists o, n. by iFrame. }
- wp_pures. wp_bind (CmpXchg _ _ _).
- wp_swp 1%nat. iInv N as "Hlock". swp_step. iNext. iDestruct "Hlock" as (o' n') "(Hlo' & Hln' & Hauth & Haown)".
- destruct (decide (#n' = #n))%V as [[= ->%Nat2Z.inj] | Hneq].
- - iMod (own_update with "Hauth") as "[Hauth Hofull]".
- { eapply auth_update_alloc, prod_local_update_2.
- eapply (gset_disj_alloc_empty_local_update _ {[ n ]}).
- apply (set_seq_S_end_disjoint 0). }
- rewrite -(set_seq_S_end_union_L 0).
- wp_cmpxchg_suc. iModIntro. iSplitL "Hlo' Hln' Haown Hauth".
- { iNext. iExists o', (S n).
- rewrite Nat2Z.inj_succ -Z.add_1_r. by iFrame. }
- wp_pures.
- iApply (wait_loop_spec γ (#lo, #ln) with "[-HΦ]").
- + iFrame. rewrite /is_lock; eauto 10.
- + by iNext.
- - wp_cmpxchg_fail. iModIntro.
- iSplitL "Hlo' Hln' Hauth Haown".
- { iNext. iExists o', n'. by iFrame. }
- wp_pures. by iApply "IH"; auto.
- Qed.
-
- Lemma release_spec γ lk R :
- {{{ is_lock γ lk R ∗ locked γ ∗ R }}} release lk {{{ RET #(); True }}}.
- Proof.
- iIntros (Φ) "(Hl & Hγ & HR) HΦ". iDestruct "Hl" as (lo ln ->) "#Hinv".
- iDestruct "Hγ" as (o) "Hγo".
- wp_lam. wp_proj. wp_bind (! _)%E.
- wp_swp 1%nat. iInv N as "Hlock". swp_step. iNext. iDestruct "Hlock" as (o' n) "(Hlo & Hln & Hauth & Haown)".
- wp_load.
- iDestruct (own_valid_2 with "Hauth Hγo") as
- %[[<-%Excl_included%leibniz_equiv _]%prod_included _]%auth_both_valid.
- iModIntro. iSplitL "Hlo Hln Hauth Haown".
- { iNext. iExists o, n. by iFrame. }
- wp_pures.
- wp_swp 1%nat. iInv N as "Hlock". swp_step. iNext. iDestruct "Hlock" as (o' n') "(Hlo & Hln & Hauth & Haown)".
- iApply swp_fupd. wp_store.
- iDestruct (own_valid_2 with "Hauth Hγo") as
- %[[<-%Excl_included%leibniz_equiv _]%prod_included _]%auth_both_valid.
- iDestruct "Haown" as "[[Hγo' _]|Haown]".
- { iDestruct (own_valid_2 with "Hγo Hγo'") as %[[] ?]. }
- iMod (own_update_2 with "Hauth Hγo") as "[Hauth Hγo]".
- { apply auth_update, prod_local_update_1.
- by apply option_local_update, (exclusive_local_update _ (Excl (S o))). }
- iModIntro. iSplitR "HΦ"; last by iApply "HΦ".
- iIntros "!> !>". iExists (S o), n'.
- rewrite Nat2Z.inj_succ -Z.add_1_r. iFrame. iLeft. by iFrame.
- Qed.
-End proof.
-
-Typeclasses Opaque is_lock issued locked.
-
-Canonical Structure ticket_lock {SI} {Σ: gFunctors SI} `{!heapG Σ, !tlockG Σ} : lock Σ :=
- {| lock.locked_exclusive := locked_exclusive; lock.newlock_spec := newlock_spec;
- lock.acquire_spec := acquire_spec; lock.release_spec := release_spec |}.
diff --git a/theories/examples/termination/adequacy.v b/theories/examples/termination/adequacy.v
deleted file mode 100644
index d46c9b88..00000000
--- a/theories/examples/termination/adequacy.v
+++ /dev/null
@@ -1,67 +0,0 @@
-From iris.program_logic.refinement Require Export ref_weakestpre ref_source seq_weakestpre.
-From iris.base_logic.lib Require Export invariants na_invariants.
-From iris.heap_lang Require Export lang lifting.
-From iris.proofmode Require Import tactics.
-From iris.heap_lang Require Import proofmode notation metatheory.
-From iris.algebra Require Import auth gmap excl frac agree.
-From iris.program_logic Require Import ref_adequacy.
-From iris.examples Require Import refinement.
-Set Default Proof Using "Type".
-
-
-(* Adequacy Theorem *)
-Section adequacy.
- Context {SI} `{C: Classical} {Σ: gFunctors SI} {Hlarge: LargeIndex SI}.
- Context `{Hpre: !heapPreG Σ} `{Hna: !na_invG Σ} `{Htc: !inG Σ (authR (ordA SI))}.
-
- Theorem heap_lang_ref_adequacy (e: expr) σ:
- (∀ `{heapG SI Σ} `{!seqG Σ} `{!auth_sourceG Σ (ordA SI)},
- True ⊢ (∃ α, $α -∗ SEQ e ⟨⟨ v, True ⟩⟩)%I
- ) →
- sn erased_step ([e], σ).
- Proof using C Hlarge Σ Hpre Hna Htc.
- intros Hobj.
- (* allocate the heap *)
- edestruct (satisfiable_at_gen_heap nil σ) as [Hheap Hsat].
- (* allocate sequential invariants *)
- eapply satisfiable_update_alloc in Hsat as [seqG_name Hsat]; last apply na_alloc.
- pose (seq := {| seqG_na_invG := _; seqG_name := seqG_name |}).
- (* allocte stuttering credits *)
- eapply (satisfiable_at_alloc (● zero ⋅ ◯ zero)) in Hsat as [authG_name Hsat]; last first.
- { apply auth_both_valid; by split. }
- pose (stutter := {| sourceG_inG := _; sourceG_name := authG_name |}).
- specialize (Hobj Hheap seq stutter).
- eapply satisfiable_at_mono with (Q := (∃ α: Ord, _)%I) in Hsat; last first.
- { iIntros "H". iPoseProof (Hobj with "[//]") as (α) "Hwp".
- iExists α. iCombine "H Hwp" as "H". iExact "H". }
- eapply satisfiable_at_exists in Hsat as [α Hsat]; last apply _.
- eapply satisfiable_at_mono with (Q := (|={⊤}=> _)%I) in Hsat; last first.
- - iIntros "[[[[SI _] Hna] [Hc Hc']] Hwp]".
- iMod (own_update_2 _ _ _ (● α ⋅ ◯ α) with "Hc Hc'") as "[Hc Hc']".
- { rewrite -[α]natural_addition_zero_left_id natural_addition_comm -ord_op_plus.
- eapply auth_update, op_local_update_discrete; done. }
- iSpecialize ("Hwp" with "Hc' Hna").
- iCombine "Hc SI Hwp" as "G". iExact "G".
- - eapply satisfiable_at_fupd in Hsat as Hsat.
- eapply (rwp_sn_preservation _ (α) _ _ 0); first apply index_lt_wf.
- eapply satisfiable_at_mono; first apply Hsat.
- iIntros "($ & $ & $)".
- Qed.
-
-End adequacy.
-
-Section adequacy_ord.
- (* result for the ordinal step-index type *)
- Context `{C: Classical} {Σ: gFunctors ordI}.
- Context `{Hpre: !heapPreG Σ} `{Hna: !na_invG Σ} `{Htc: !inG Σ (authR (ordA ordI))}.
- Theorem heap_lang_ref_adequacy_ord (e: expr) σ:
- (∀ `{heapG ordI Σ} `{!seqG Σ} `{!auth_sourceG Σ (ordA ordI)},
- True ⊢ (∃ α, $α -∗ SEQ e ⟨⟨ v, True ⟩⟩)%I
- ) →
- sn erased_step ([e], σ).
- Proof using C Σ Hpre Hna Htc.
- apply heap_lang_ref_adequacy.
- Qed.
- Print Assumptions heap_lang_ref_adequacy_ord.
-
-End adequacy_ord.
diff --git a/theories/examples/termination/eventloop.v b/theories/examples/termination/eventloop.v
deleted file mode 100644
index de992cf0..00000000
--- a/theories/examples/termination/eventloop.v
+++ /dev/null
@@ -1,211 +0,0 @@
-From iris.program_logic.refinement Require Export seq_weakestpre.
-From iris.base_logic.lib Require Export invariants na_invariants.
-From iris.heap_lang Require Export lang lifting.
-From iris.proofmode Require Import tactics.
-From iris.heap_lang Require Import proofmode notation metatheory.
-From iris.algebra Require Import auth.
-From iris.algebra.ordinals Require Import arithmetic.
-Set Default Proof Using "Type".
-
-Section eventloop_code.
- Definition new_stack : val := λ: <>, ref NONEV.
-
- Definition push : val := λ: "s", λ: "x",
- let: "hd" := !"s" in
- let: "p" := ("x", "hd") in
- "s" <- SOME (ref "p").
-
- Definition pop : val := (λ: "s",
- let: "hd" := !"s" in
- match: "hd" with
- NONE => NONE
- | SOME "l" =>
- let: "p" := !"l" in
- let: "x" := Fst "p" in
- "s" <- Snd "p" ;; SOME "x"
- end).
-
- Definition enqueue : val := push.
-
- Definition run : val :=
- λ: "q", rec: "run" <> :=
- match: pop "q" with
- NONE => #()
- | SOME "f" => "f" #() ;; "run" #()
- end.
-
- Definition mkqueue : val :=
- λ: <>, new_stack #().
-
-End eventloop_code.
-Section eventloop_spec.
-
- Context {SI} {Σ: gFunctors SI} `{Hheap: !heapG Σ} `{Htc: !tcG Σ} `{Hseq: !seqG Σ} (N : namespace).
-
- Implicit Types (l: loc).
-
- Fixpoint stack_contents (hd: val) (xs: list val) (φ: val → iProp Σ) :=
- match xs with
- | [] => ⌜hd = NONEV⌝
- | x :: xs => ∃ l hd', ⌜hd = SOMEV #l⌝ ∗ l ↦ (x, hd') ∗ φ x ∗ stack_contents hd' xs φ
- end%I.
- Definition stack (l: loc) (xs: list val) (φ: val → iProp Σ): iProp Σ := (∃ hd, l ↦ hd ∗ stack_contents hd xs φ)%I.
- Definition queue (q: val) : iProp Σ := (∃ l, ⌜q = #l⌝ ∗ na_inv seqG_name (N .@ l) (∃ xs, stack l xs (λ f, $ one ∗ SEQ f #() [{_, True}])))%I.
-
-
- Lemma new_stack_spec φ:
- sbi_emp_valid (WP (new_stack #()) [{ v, ∃ l, ⌜v = #l⌝ ∗ stack l nil φ }])%I.
- Proof.
- rewrite /new_stack. wp_pures.
- wp_alloc l as "Hl". iFrame.
- rewrite /stack. iExists l; iSplit; auto.
- Qed.
-
- Lemma push_spec l xs φ (x : val):
- (stack l xs φ ∗ φ x ⊢ RSWP (push #l x) at 0 ⟨⟨ v, ⌜v = #()⌝ ∗ stack l (x :: xs) φ ⟩⟩)%I.
- Proof.
- iIntros "(Hstack & Hφ)".
- rewrite /push /stack. wp_pures.
- iDestruct "Hstack" as (hd) "[Hl cont]".
- wp_load. wp_pures. wp_alloc r as "Hr". rewrite -tcwp_rwp.
- wp_store. iSplit; auto. iExists (SOMEV #r). iFrame "Hl".
- simpl. iExists r, hd. by iFrame.
- Qed.
-
- Lemma pop_element_spec l xs φ (x : val):
- (stack l (x :: xs) φ ⊢ RSWP (pop #l) at 0 ⟨⟨ v, ⌜v = SOMEV x⌝ ∗ φ x ∗ stack l xs φ ⟩⟩)%I.
- Proof.
- iIntros "Hstack".
- rewrite /pop /stack. wp_pures.
- iDestruct "Hstack" as (hd) "[Hl Hcont]".
- iDestruct "Hcont" as (r hd') "(-> & Hr & Hφ & Hcont)".
- wp_load. wp_pures. wp_load. wp_pures. wp_store. wp_pures; iFrame.
- iSplit; eauto. iExists hd'. iFrame.
- Qed.
-
- Lemma pop_empty_spec l φ:
- (stack l nil φ ⊢ RSWP (pop #l) at 0 ⟨⟨ v, ⌜v = NONEV⌝ ∗ stack l nil φ ⟩⟩)%I.
- Proof.
- iIntros "Hstack".
- rewrite /pop /stack. wp_pures.
- iDestruct "Hstack" as (hd) "[Hl ->]".
- wp_load. wp_pures; iSplit; eauto.
- Qed.
-
- Lemma run_spec `{FiniteBoundedExistential SI} q :
- queue q ∗ $ one ⊢ SEQ (run q #()) [{v, ⌜v = #()⌝ }].
- Proof.
- iIntros "[#Q Hc] Hna". rewrite /run. do 2 wp_pure _.
- iLöb as "IH". wp_pures.
- wp_bind (pop _). iDestruct "Q" as (l) "[-> I]".
- iMod (na_inv_acc_open _ _ _ with "I Hna") as "Hinv"; auto.
- iApply (tcwp_burn_credit with "Hc"); first done.
- iNext. iDestruct "Hinv" as "(Hinv & Hna & Hclose)".
- iDestruct "Hinv" as (xs) "Hstack".
- destruct xs as [|f xs].
- - iPoseProof (pop_empty_spec with "Hstack") as "Hwp".
- iApply (rswp_wand with "Hwp"). iIntros (v) "[-> Hstack]".
- iMod ("Hclose" with "[Hstack $Hna]") as "Hna"; eauto.
- wp_pures. by iFrame.
- - iPoseProof (pop_element_spec with "Hstack") as "Hwp".
- iApply (rswp_wand with "Hwp"). iIntros (v) "[-> [[Hone Hwp] Hstack]]".
- iMod ("Hclose" with "[Hstack $Hna]") as "Hna"; eauto.
- wp_pures. iSpecialize ("Hwp" with "Hna").
- wp_bind (f _).
- iApply (rwp_wand with "Hwp"). iIntros (v) "[Hna _]".
- do 2 wp_pure _. rewrite -tcwp_rwp.
- iApply ("IH" with "Hone Hna").
- Qed.
-
- Lemma enqueue_spec `{FiniteBoundedExistential SI} q (f: val) :
- queue q ∗ $ one ∗ $ one ∗ SEQ (f #()) [{ _, True }] ⊢ SEQ (enqueue q f) [{v, ⌜v = #()⌝ }].
- Proof.
- iIntros "[#Q [Hc Hf]] Hna". rewrite /enqueue.
- iDestruct "Q" as (l) "[-> I]".
- iMod (na_inv_acc_open _ _ _ with "I Hna") as "Hinv"; auto.
- iApply (tcwp_burn_credit with "Hc"); first done.
- iNext. iDestruct "Hinv" as "(Hinv & Hna & Hclose)".
- iDestruct "Hinv" as (xs) "Hstack".
- iPoseProof (push_spec with "[$Hstack $Hf]") as "Hpush".
- iApply (rswp_strong_mono with "Hpush"); auto.
- iIntros (v) "(-> & Hstack)". iMod ("Hclose" with "[Hstack $Hna]"); eauto.
- Qed.
-
- Lemma mkqueue_spec :
- sbi_emp_valid (SEQ (mkqueue #()) [{ q, queue q}])%I.
- Proof.
- iIntros "Hna". rewrite /mkqueue. wp_pures.
- iMod (new_stack_spec) as "_".
- iIntros (v) "H". iDestruct "H" as (l) "[-> Hstack]".
- iMod (na_inv_alloc with "[Hstack]"); last first.
- { iModIntro. iFrame. iExists l. iSplit; eauto. }
- iNext. by iExists nil.
- Qed.
-
-End eventloop_spec.
-
-
-
-
-
-Section open_example.
-
- Variable external_code: val.
- Variable print: val.
- Variable q: val.
- Context {SI} {Σ: gFunctors SI} `{Hheap: !heapG Σ} `{Htc: !tcG Σ} `{Hseq: !seqG Σ} (N : namespace).
-
-
- Definition for_loop: val :=
- (rec: "loop" "f" "n" :=
- if: "n" ≤ #0 then #() else let: "m" := "n" - #1 in "f" #() ;; "loop" "f" "m")%V.
-
- Notation "'for:' n 'do' e" := (for_loop (λ: <>, e)%V n%V) (at level 200, n at level 200, e at level 200) : val_scope.
- Notation "'for:' n 'do' e" := (for_loop (λ: <>, e)%E n%E) (at level 200, n at level 200, e at level 200) : expr_scope.
-
- Definition example : expr :=
- let: "n" := external_code #() in
- for: "n" do
- enqueue q (λ: <>, print "Hello World!").
-
- Lemma for_zero e:
- sbi_emp_valid (WP (for: #0 do e)%V [{ v, ⌜v = #()⌝ }])%I.
- Proof.
- rewrite /for_loop; by wp_pures.
- Qed.
-
- Lemma for_val (n: nat) e φ:
- WP (for: #n do e)%V [{v, φ v}] ⊢ WP (for: #n do e) [{ v, φ v }].
- Proof.
- rewrite /for_loop; iIntros "H". by wp_pure _.
- Qed.
-
-
- Lemma for_succ (n: nat) e φ:
- WP e;; (for: #n do e)%V [{v, φ v}] ⊢ WP (for: #(S n) do e)%V [{ v, φ v }].
- Proof.
- rewrite /for_loop; iIntros "H". wp_pures.
- by replace (S n - 1) with (n: Z) by lia.
- Qed.
-
- Lemma example_spec `{FiniteBoundedExistential SI}:
- queue N q ∗ $ (omul one) ∗ SEQ external_code #() [{ v, ∃ n: nat, ⌜v = #n⌝ }] ∗ (□ ∀ s: string, SEQ print s [{ _, True }]) ⊢
- SEQ example [{ _, True }].
- Proof.
- iIntros "(#Q & Hc & Hwp & #Hprint) Hna". rewrite /example.
- wp_bind (external_code _). iMod ("Hwp" with "Hna") as "_".
- iIntros (v) "[Hna Hn] !>". iDestruct "Hn" as (n) "->".
- do 2 wp_pure _. iApply (tc_weaken (omul one) (natmul (n * 2)%nat one)); auto; first apply (ord_stepindex.limit_upper_bound (λ n, natmul n one)).
- iFrame "Hc". iIntros "Hc". iApply for_val.
- iInduction n as [|n] "IH".
- - iMod (for_zero) as "_"; iFrame; auto.
- - simpl. rewrite !tc_split. iDestruct "Hc" as "(Ho & Ho' & Hc)".
- iApply for_succ. wp_pures.
- wp_bind (enqueue _ _).
- iMod (enqueue_spec with "[$Q $Ho $Ho'] Hna") as "_".
- + iIntros "Hna". wp_pures. iMod ("Hprint" with "Hna") as "_"; auto.
- + iIntros (v) "[Hna _] !>". wp_pures. iApply ("IH" with "Hna Hc").
- Qed.
-
-End open_example.
-
diff --git a/theories/examples/termination/logrel.v b/theories/examples/termination/logrel.v
deleted file mode 100644
index 2452064b..00000000
--- a/theories/examples/termination/logrel.v
+++ /dev/null
@@ -1,931 +0,0 @@
-
-From iris.program_logic.refinement Require Export seq_weakestpre.
-From iris.base_logic.lib Require Export invariants na_invariants.
-From iris.heap_lang Require Export lang lifting.
-From iris.proofmode Require Import tactics.
-From iris.heap_lang Require Import proofmode notation metatheory.
-From iris.algebra Require Import auth.
-From iris.algebra.ordinals Require Import arithmetic.
-Set Default Proof Using "Type".
-
-
-
-Section token_ra.
- Context {SI: indexT} {Σ: gFunctors SI} `{!inG Σ (authR (unitUR SI))}.
-
- Definition tok γ := own γ (● ()).
-
- Lemma tok_alloc: ⊢ (|==> ∃ γ, tok γ)%I.
- Proof.
- iStartProof. iMod (own_alloc (● ())); auto.
- by apply auth_auth_valid.
- Qed.
-
- Lemma tok_unique γ: tok γ ∗ tok γ ⊢ False.
- Proof.
- rewrite /tok -own_op own_valid -auth_auth_frac_op uPred.discrete_valid.
- iIntros (Htok). apply ->(@auth_auth_frac_valid SI) in Htok.
- destruct Htok as [Htok _]. apply ->(@frac_valid' SI) in Htok.
- exfalso. by eapply Qp_not_plus_q_ge_1.
- Qed.
-
-End token_ra.
-
-
-
-
-(* the heap values for empty, value, and computation *)
-Definition div : expr := (rec: "f" "x" := "f" "x") #().
-Definition E : expr := InjL #().
-Definition V (e: expr): expr := InjR (InjL e).
-Definition C (e: expr): expr := InjR (InjR e).
-Definition EV : val := InjLV #().
-Definition VV (v: val): val := InjRV (InjLV v).
-Definition CV (v: val): val := InjRV (InjRV v).
-Definition caseof : val :=
- λ: "e" "e_empty" "e_val" "e_cont",
- match: "e" with
- InjL <> => "e_empty" #()
- | InjR "x" =>
- match: "x" with
- InjL "v" => "e_val" "v"
- | InjR "f" => "e_cont" "f"
- end
- end.
-Notation "'case' e 'of' 'E' => e1 | 'V' v => e2 | 'C' c => e3 'end'" := (caseof e (λ: <>, e1)%E (λ: v, e2)%E (λ: c, e3)%E).
-
-Definition letpair : val :=
- λ: "p" "f", "f" (Fst "p") (Snd "p").
-
-Notation "'let:' ( x , y ) := p 'in' e" := (letpair p (λ: x y, e)%E) (at level 200, x at level 1, y at level 1, p, e at level 200, format "'[' 'let:' ( x , y ) := '[' p ']' 'in' '/' e ']'") : expr_scope.
-
-Definition iter : val :=
- rec: "iter" "s" := λ: "n" "f", if: "n" = #0 then "s" else "iter" ("f" "s") ("n" - #1) "f".
-
-Definition chan : val :=
- λ: <>, let: "c" := ref E in ("c", "c").
-
-Definition put : val :=
- λ: "p",
- let: "c" := Fst "p" in
- let: "v" := Snd "p" in
- case ! "c" of
- E => "c" <- V "v"
- | V <> => div
- | C "f" => "c" <- E;; "f" "v"
- end.
-
-Definition get : val :=
- λ: "p",
- let: "c" := Fst "p" in
- let: "f" := Snd "p" in
- case ! "c" of
- E => "c" <- C "f"
- | V "v" => "c" <- E;; "f" "v"
- | C <> => div
- end.
-
-Section semantic_model.
- Context {SI} {Σ: gFunctors SI} `{Heap: !heapG Σ} `{TimeCredits: !tcG Σ} `{Sequential: !seqG Σ} `{FBI: FiniteBoundedExistential SI} `{Tok: !inG Σ (authR (unitUR SI))}.
-
- Implicit Types (l r: loc).
- Implicit Types (n: nat).
- Implicit Types (b: bool).
- Implicit Types (e : expr).
- Implicit Types (v f: val).
- Implicit Types (P Q: iProp Σ).
- Implicit Types (Φ Ψ: val → iProp Σ).
- Implicit Types (x y: string).
-
-
- Section execution_lemmas.
- Lemma rwp_put_empty l v:
- l ↦ EV ⊢ WP (put (#l, v)%V)%E [{ w, ⌜w = #()⌝ ∗ l ↦ VV v}].
- Proof.
- iIntros "Hl". rewrite /put /caseof. wp_pures. wp_load. wp_pures.
- wp_store. by iFrame.
- Qed.
-
- Lemma rwp_put_cont l f v Φ:
- l ↦ CV f ∗ WP f v [{ w, Φ w }] ⊢ WP (put (#l, v)%V)%E [{ w, Φ w ∗ l ↦ EV}].
- Proof.
- iIntros "[Hl Hwp]". rewrite /put /caseof. wp_pures. wp_load. wp_pures.
- wp_store. by iFrame "Hl".
- Qed.
-
- Lemma rwp_get_empty l f:
- l ↦ EV ⊢ WP (get (#l, f)%V)%E [{ w, ⌜w = #()⌝ ∗ l ↦ CV f}].
- Proof.
- iIntros "Hl". rewrite /get /caseof. wp_pures. wp_load. wp_pures.
- wp_store. by iFrame.
- Qed.
-
- Lemma rwp_get_val l f v Φ:
- l ↦ VV v ∗ WP f v [{ w, Φ w }] ⊢ WP (get (#l, f)%V)%E [{ w, Φ w ∗ l ↦ EV}].
- Proof.
- iIntros "[Hl Hwp]". rewrite /get /caseof. wp_pures. wp_load. wp_pures.
- wp_store. by iFrame "Hl".
- Qed.
-
- Lemma rwp_chan :
- ⊢ (WP (chan #())%E [{ v, ∃ l, ⌜v = (#l, #l)%V⌝ ∗ l ↦ EV}])%I.
- Proof.
- iStartProof. rewrite /chan. wp_pures. wp_alloc l as "Hl".
- wp_pures. eauto.
- Qed.
- End execution_lemmas.
-
-
- Section closed_lemmas.
- (* the channel invariant *)
- Definition ch_inv γget γput l A :=
- (l ↦ EV ∨ (∃ v, l ↦ VV v ∗ tok γput ∗ A v) ∨ (∃ f, l ↦ CV f ∗ tok γget ∗ ∀ v, A v -∗ SEQ f v [{ v, ⌜v = #()⌝ }]))%I.
-
- (* we have a linear type system *)
- Definition lN := nroot .@ "type".
- Definition ltype := val -d> iProp Σ.
-
- Implicit Types (A B C: ltype).
-
- (* type interpretations *)
- Definition lunit : ltype := λ v, (⌜v = #()⌝)%I.
- Definition lbool : ltype := λ v, (∃ b, ⌜v = #b⌝)%I.
- Definition lnat : ltype := λ v, (∃ n, ⌜v = #n⌝)%I.
- Definition lget A : ltype := λ v, (∃ l γget γput, ⌜v = #l⌝ ∗ tok γget ∗ se_inv (lN .@ l) (ch_inv γget γput l A) ∗ $ one)%I.
- Definition lput A : ltype := λ v, (∃ l γget γput, ⌜v = #l⌝ ∗ tok γput ∗ se_inv (lN .@ l) (ch_inv γget γput l A) ∗ $ one)%I.
- Definition ltensor A B : ltype := λ v, (∃ v1 v2, ⌜v = (v1, v2)%V⌝ ∗ A v1 ∗ B v2)%I.
- Definition larr A B : ltype := λ f, (∀ v, A v -∗ SEQ f v [{ v, B v }])%I.
-
- Lemma closed_unit_intro: (SEQ #() [{ v, lunit v }])%I.
- Proof.
- iApply seq_value. by rewrite /lunit.
- Qed.
-
- Lemma closed_unit_elim e1 e2 Φ: (SEQ e1 [{ v, lunit v}] ∗ SEQ e2 [{ v, Φ v }] ⊢ SEQ e1;;e2 [{ v, Φ v }])%I.
- Proof.
- iIntros "[He He2] Hna". wp_bind e1.
- iMod ("He" with "Hna") as "_". iIntros (v) "[Hna ->] !>".
- wp_pures. by iApply "He2".
- Qed.
-
- Lemma closed_bool_intro (b: bool): (SEQ #b [{ v, lbool v }])%I.
- Proof.
- iApply seq_value. rewrite /lbool; eauto.
- Qed.
-
- Lemma closed_bool_elim e e_1 e_2 A P: (SEQ e [{ v, lbool v}] ∗ (P -∗ SEQ e_1 [{ v, A v}]) ∗ (P -∗ SEQ e_2 [{ v, A v}]) ∗ P) ⊢ (SEQ (if: e then e_1 else e_2) [{ v, A v}])%I.
- Proof.
- iIntros "(He & H1 & H2 & P) Hna". wp_bind e.
- iMod ("He" with "Hna") as "_"; iIntros (v) "[Hna Hb] !>"; iDestruct "Hb" as ([]) "->".
- - wp_pures. iApply ("H1" with "P Hna").
- - wp_pures. iApply ("H2" with "P Hna").
- Qed.
-
- Lemma closed_nat_intro n: (SEQ #n [{ v, lnat v }])%I.
- Proof.
- iApply seq_value. rewrite /lnat; eauto.
- Qed.
-
- Lemma closed_nat_add e1 e2: (SEQ e1 [{ v, lnat v }] ∗ SEQ e2 [{ v, lnat v }] ⊢ SEQ (e1 + e2) [{ v, lnat v}])%I.
- Proof.
- iIntros "(H1 & H2) Hna".
- wp_bind e2. iMod ("H2" with "Hna") as "_"; iIntros (v2) "[Hna Hv2] !>"; iDestruct "Hv2" as (n2) "->".
- wp_bind e1. iMod ("H1" with "Hna") as "_"; iIntros (v1) "[Hna Hv1] !>"; iDestruct "Hv1" as (n1) "->".
- wp_pures. iFrame. rewrite /lnat; iExists (n1 + n2)%nat. iPureIntro. do 2 f_equal.
- lia.
- Qed.
-
- Lemma closed_nat_iter_n n s f α A: (SEQ s [{ v, A v }] ∗ (□ $ α -∗ ∀ v, A v -∗ SEQ f v [{ w, A w }]) ∗ $ (natmul n α) ⊢ SEQ (iter s #n f) [{ v, A v}])%I.
- Proof.
- iIntros "(H1 & #H2 & Hc) Hna". iInduction n as [|n] "IH" forall (s); simpl.
- all: wp_bind s; iMod ("H1" with "Hna") as "_"; iIntros (v) "[Hna Hv] !>".
- - rewrite /iter. wp_pures. replace (#0%nat) with (#0) by ((do 2 f_equal); lia).
- wp_pure _; first naive_solver. wp_pures. by iFrame.
- - rewrite tc_split. iDestruct "Hc" as "[Hα Hc]".
- rewrite /iter. wp_pures. wp_pure _; first naive_solver.
- wp_pures. replace (S n - 1) with (n: Z) by lia.
- iApply ("IH" with "[Hα Hv] Hc Hna"). iApply ("H2" with "Hα Hv").
- Qed.
-
-
- Lemma closed_nat_iter e1 e2 f α A: (SEQ e1 [{ v, lnat v }] ∗ SEQ e2 [{ v, A v }] ∗ (□ $ α -∗ ∀ v, A v -∗ SEQ f v [{ w, A w }]) ∗ $ (omul α) ⊢ SEQ (iter e2 e1 f) [{ v, A v}])%I.
- Proof.
- iIntros "(H1 & H2 & H3 & Hc) Hna".
- wp_bind e1. iMod ("H1" with "Hna") as "_"; iIntros (v) "[Hna Hv] !>"; iDestruct "Hv" as (n) "->".
- iApply (tc_weaken (omul α) (natmul n α) with "[H2 H3 Hna $Hc]"); auto.
- { eapply (ord_stepindex.limit_upper_bound (λ n, natmul n α)). }
- iIntros "Hα". iApply (closed_nat_iter_n with "[$H2 $H3 $Hα] Hna").
- Qed.
-
- Lemma closed_fun_intro x e A B: (∀ v, A v -∗ SEQ (subst x v e) [{ w, B w}] ) ⊢ (SEQ (λ: x, e) [{ v, larr A B v}])%I.
- Proof.
- iIntros "H Hna". wp_pures. iFrame. iIntros (v) "Hv Hna". wp_pures.
- by iApply ("H" with "Hv Hna").
- Qed.
-
- Lemma closed_fun_elim e_1 e_2 A B: (SEQ e_1 [{ v, larr A B v}] ∗ SEQ e_2 [{ v, A v }]) ⊢ (SEQ (e_1 e_2) [{ v, B v}])%I.
- Proof.
- iIntros "(H1 & H2) Hna".
- wp_bind e_2. iMod ("H2" with "Hna") as "_"; iIntros (v) "[Hna HA] !>".
- wp_bind e_1. iMod ("H1" with "Hna") as "_"; iIntros (f) "[Hna HAB] !>".
- iApply ("HAB" with "HA Hna").
- Qed.
-
- Lemma closed_tensor_intro e_1 e_2 A B: (SEQ e_1 [{ v, A v}] ∗ SEQ e_2 [{ v, B v }]) ⊢ (SEQ (e_1, e_2) [{ v, ltensor A B v}])%I.
- Proof.
- iIntros "(H1 & H2) Hna".
- wp_bind e_2. iMod ("H2" with "Hna") as "_"; iIntros (v2) "[Hna HB] !>".
- wp_bind e_1. iMod ("H1" with "Hna") as "_"; iIntros (v1) "[Hna HA] !>".
- wp_pures. iFrame. iExists v1, v2; by iFrame.
- Qed.
-
- Lemma closed_tensor_elim x y e1 e2 A B C: x ≠ y → (SEQ e1 [{ v, ltensor A B v }]) ∗ (∀ v1 v2, A v1 -∗ B v2 -∗ SEQ (subst y v2 (subst x v1 e2)) [{ w, C w}]) ⊢ (SEQ (let: (x, y) := e1 in e2) [{ v, C v}])%I.
- Proof.
- iIntros (Hneq) "[H1 H2] Hna". wp_pures. wp_bind e1.
- iMod ("H1" with "Hna") as "_". iIntros (p) "[Hna Hp] !>".
- iDestruct "Hp" as (v1 v2) "(-> & Hv1 & Hv2)".
- rewrite /letpair. wp_pures.
- destruct decide as [H|H].
- - iApply ("H2" with "Hv1 Hv2 Hna").
- - exfalso. apply H; split; auto. by injection 1.
- Qed.
-
-
- Lemma closed_get e1 e2 A: SEQ e1 [{ v, lget A v}] ∗ SEQ e2 [{ f, larr A lunit f}] ⊢ SEQ (get (e1, e2)) [{ v, lunit v}].
- Proof using FBI Heap SI Sequential TimeCredits Σ.
- iIntros "[H1 H2] Hna".
- wp_bind e2. iMod ("H2" with "Hna") as "_"; iIntros (f) "[Hna Hf] !>".
- wp_bind e1. iMod ("H1" with "Hna") as "_"; iIntros (?) "[Hna Hloc] !>"; iDestruct "Hloc" as (l γget γput) "(-> & Hget & #I & Hone)".
- iMod (na_inv_acc_open with "I Hna") as "P"; auto.
- iApply (tcwp_burn_credit with "Hone"); first done. iNext. wp_pures. (* we use the step from expressions to values here conventiently *)
- rewrite -tcwp_rwp.
- iDestruct "P" as "([HI|[HI|HI]] & Hna & Hclose)".
- - iMod (rwp_get_empty with "HI") as "_". iIntros (?) "(-> & Hl)".
- iMod ("Hclose" with "[Hf Hl Hget $Hna]") as "Hna".
- { iNext. iRight. iRight. iExists f. iFrame. }
- iModIntro. iFrame. eauto.
- - iDestruct "HI" as (v) "[Hl [Hput Hv]]".
- iSpecialize ("Hf" with "Hv").
- (* we need to close the invariant after the value has been updated before we execute f, since f assumes all invariants *)
- rewrite /get. wp_pures. wp_load. rewrite /caseof. wp_pures.
- wp_store. iApply fupd_rwp.
- iMod ("Hclose" with "[Hl $Hna]") as "Hna".
- { iNext. by iLeft. }
- iApply ("Hf" with "Hna").
- - iDestruct "HI" as (f') "[_ [Hget' _]]".
- iExFalso. iApply (tok_unique with "[$Hget $Hget']").
- Qed.
-
- Lemma closed_put e1 e2 A: SEQ e1 [{ v, lput A v}] ∗ SEQ e2 [{ v, A v}] ⊢ SEQ (put (e1, e2)) [{ v, lunit v}].
- Proof using FBI Heap SI Sequential TimeCredits Σ.
- iIntros "[H1 H2] Hna".
- wp_bind e2. iMod ("H2" with "Hna") as "_"; iIntros (v) "[Hna Hv] !>".
- wp_bind e1. iMod ("H1" with "Hna") as "_"; iIntros (?) "[Hna Hloc] !>"; iDestruct "Hloc" as (l γget γput) "(-> & Hput & #I & Hone)".
- iMod (na_inv_acc_open with "I Hna") as "P"; auto.
- iApply (tcwp_burn_credit with "Hone"); first done. iNext. wp_pures. (* we use the step from expressions to values here conventiently *)
- rewrite -tcwp_rwp.
- iDestruct "P" as "([HI|[HI|HI]] & Hna & Hclose)".
- - iMod (rwp_put_empty with "HI") as "_". iIntros (?) "(-> & Hl)".
- iMod ("Hclose" with "[Hv Hl Hput $Hna]") as "Hna".
- { iNext. iRight. iLeft. iExists v. iFrame. }
- iModIntro. by iFrame.
- - iDestruct "HI" as (v') "[Hl [Hput' _]]".
- iExFalso. iApply (tok_unique with "[$Hput $Hput']").
- - iDestruct "HI" as (f) "[Hl [Hget Hf]]".
- iSpecialize ("Hf" with "Hv").
- (* we need to close the invariant after the value has been updated before we execute f, since f assumes all invariants *)
- rewrite /put. wp_pures. wp_load. rewrite /caseof. wp_pures.
- wp_store. iApply fupd_rwp.
- iMod ("Hclose" with "[Hl $Hna]") as "Hna".
- { iNext. by iLeft. }
- iApply ("Hf" with "Hna").
- Qed.
-
- Lemma closed_chan A: $ one ∗ $ one ⊢ SEQ (chan #()) [{ v, ltensor (lget A) (lput A) v}].
- Proof.
- iIntros "[Hone Hone'] Hna".
- iMod (rwp_chan) as "_". iIntros (v) "Hv". iDestruct "Hv" as (l) "[-> Hl]".
- iMod (tok_alloc) as (γget) "Hget".
- iMod (tok_alloc) as (γput) "Hput".
- iMod (na_inv_alloc seqG_name _ (lN .@ l) (ch_inv γget γput l A) with "[Hl]") as "#I".
- { iNext. by iLeft. }
- iModIntro; rewrite /ltensor /lget /lput; iFrame.
- iExists #l, #l; iSplit; auto.
- iSplitL "Hget"; iExists l, γget, γput; iFrame; eauto.
- Qed.
-
- End closed_lemmas.
-
- Section simple_logical_relation.
- (* The semantic typing judgment *)
- Implicit Types (Γ Δ: gmap string ltype).
- Implicit Types (θ τ: gmap string val).
-
- Definition env_ltyped Γ θ: iProp Σ := ([∗ map] x ↦ A ∈ Γ, ∃ v, ⌜θ !! x = Some v⌝ ∗ A v)%I.
- Definition ltyped Γ e A := ⊢ (∃ α, $ α -∗ ∀ θ, env_ltyped Γ θ -∗ SEQ subst_map θ e [{ v, A v }])%I.
- Notation "Γ ⊨ e : A" := (ltyped Γ e A) (at level 100, e at next level, A at level 200) : bi_scope.
-
- Lemma env_ltyped_split Γ Δ θ: Γ ##ₘ Δ → env_ltyped (Γ ∪ Δ) θ ⊢ env_ltyped Γ θ ∗ env_ltyped Δ θ.
- Proof.
- intros H. rewrite /env_ltyped. by rewrite big_sepM_union.
- Qed.
-
- Lemma env_ltyped_empty θ: ⊢ (env_ltyped ∅ θ).
- Proof.
- iStartProof. by rewrite /env_ltyped big_sepM_empty.
- Qed.
-
- Lemma env_ltyped_insert Γ θ A v x: env_ltyped Γ θ ∗ A v ⊢ env_ltyped (<[x:=A]> Γ) (<[x:=v]> θ).
- Proof.
- iIntros "[HΓ HA]". destruct (Γ !! x) eqn: Hx.
- - rewrite -[<[x:=A]> Γ]insert_delete. iApply (big_sepM_insert_2 with "[HA] [HΓ]"); simpl.
- + iExists v. iFrame. iPureIntro. apply lookup_insert.
- + rewrite /env_ltyped.
- rewrite big_sepM_delete; last apply Hx.
- iDestruct "HΓ" as "[_ HΓ]". iApply (big_sepM_mono with "HΓ").
- iIntros (y B Hy) "Hv"; simpl. iDestruct "Hv" as (w) "[% B]".
- iExists w. iFrame. iPureIntro.
- rewrite lookup_insert_ne; auto.
- intros ->. rewrite lookup_delete in Hy. discriminate.
- - iApply (big_sepM_insert_2 with "[HA] [HΓ]"); simpl.
- + iExists v. iFrame. iPureIntro. apply lookup_insert.
- + rewrite /env_ltyped. iApply (big_sepM_mono with "HΓ").
- iIntros (y B Hy) "Hv"; simpl. iDestruct "Hv" as (w) "[% B]".
- iExists w. iFrame. iPureIntro.
- rewrite lookup_insert_ne; auto.
- intros ->. rewrite Hy in Hx. discriminate.
- Qed.
-
- Lemma env_ltyped_weaken x A Γ θ: Γ !! x = None → env_ltyped (<[x:=A]> Γ) θ ⊢ env_ltyped Γ θ.
- Proof.
- intros Hx. rewrite insert_union_singleton_l. iIntros "H".
- iPoseProof (env_ltyped_split with "H") as "[_ $]".
- apply map_disjoint_insert_l_2, map_disjoint_empty_l; auto.
- Qed.
-
- (* the typing rules *)
- Lemma variable x A: ({[ x := A ]} ⊨ x : A)%I.
- Proof.
- iExists ord_stepindex.zero. iIntros "_".
- iIntros (θ) "HΓ". rewrite /env_ltyped.
- iPoseProof (big_sepM_lookup _ _ x A with "HΓ") as "Hx"; first eapply lookup_insert.
- simpl; iDestruct "Hx" as (v) "(-> & HA)".
- by iApply seq_value.
- Qed.
-
- Lemma weaken x Γ e A B: Γ !! x = None → (Γ ⊨ e : B)%I → (<[ x := A ]> Γ ⊨ e : B)%I.
- Proof.
- intros Hx He. iDestruct He as (α) "He".
- iExists α. iIntros "Hα". iIntros (θ) "Hθ".
- iApply ("He" with "Hα"). by iApply (env_ltyped_weaken with "Hθ").
- Qed.
-
- Lemma unit_intro: (∅ ⊨ #() : lunit)%I.
- Proof.
- iExists ord_stepindex.zero. iIntros "_".
- iIntros (θ) "HΓ"; simpl. iApply closed_unit_intro.
- Qed.
-
- Lemma unit_elim Γ Δ e e' A: Γ ##ₘ Δ → (Γ ⊨ e : lunit)%I → (Δ ⊨ e' : A)%I → (Γ ∪ Δ ⊨ (e ;; e'): A)%I.
- Proof.
- intros Hdis He He'. iDestruct He as (α_e) "He". iDestruct He' as (α_e') "He'".
- iExists (α_e ⊕ α_e'). rewrite tc_split. iIntros "[α_e α_e']".
- iIntros (θ). rewrite env_ltyped_split; auto. iIntros "[HΓ HΔ]".
- iSpecialize ("He" with "α_e HΓ"). iSpecialize ("He'" with "α_e' HΔ").
- simpl; iApply (closed_unit_elim with "[$He $He']").
- Qed.
-
- Lemma bool_intro b: (∅ ⊨ #b : lbool)%I.
- Proof.
- iExists ord_stepindex.zero. iIntros "_".
- iIntros (θ) "HΓ"; simpl. iApply closed_bool_intro.
- Qed.
-
- Lemma bool_elim Γ Δ e e_1 e_2 A: Γ ##ₘ Δ → (Γ ⊨ e : lbool)%I → (Δ ⊨ e_1 : A)%I → (Δ ⊨ e_2 : A)%I → (Γ ∪ Δ ⊨ (if: e then e_1 else e_2): A)%I.
- Proof.
- intros Hdis He H1 H2. iDestruct He as (α_e) "He". iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
- iExists (α_e ⊕ α_1 ⊕ α_2). rewrite !tc_split. iIntros "[[α_e α_1] α_2]".
- iIntros (θ). rewrite env_ltyped_split; auto. iIntros "[HΓ HΔ]".
- iSpecialize ("He" with "α_e HΓ"). simpl.
- iApply (closed_bool_elim _ _ _ _ (env_ltyped Δ θ)); iFrame.
- iSplitL "H1 α_1".
- - iApply ("H1" with "α_1").
- - iApply ("H2" with "α_2").
- Qed.
-
- Lemma nat_intro n: (∅ ⊨ #n : lnat)%I.
- Proof.
- iExists ord_stepindex.zero. iIntros "_".
- iIntros (θ) "HΓ"; simpl. iApply closed_nat_intro.
- Qed.
-
- Lemma nat_plus e1 e2 Γ Δ: Γ ##ₘ Δ → (Γ ⊨ e1 : lnat)%I → (Δ ⊨ e2 : lnat)%I → (Γ ∪ Δ ⊨ e1 + e2 : lnat)%I.
- Proof.
- intros Hdis H1 H2. iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
- iExists (α_1 ⊕ α_2). rewrite tc_split. iIntros "[α_1 α_2]".
- iIntros (θ). rewrite env_ltyped_split; auto. iIntros "[HΓ HΔ]".
- iSpecialize ("H1" with "α_1 HΓ"). iSpecialize ("H2" with "α_2 HΔ").
- simpl; iApply (closed_nat_add with "[$H1 $H2]").
- Qed.
-
- Lemma nat_elim e e_0 e_S x A Γ Δ: Γ ##ₘ Δ → (Γ ⊨ e : lnat)%I → (Δ ⊨ e_0 : A)%I → ({[ x := A ]} ⊨ e_S : A)%I → (Γ ∪ Δ ⊨ iter e_0 e (λ: x, e_S)%V : A)%I.
- Proof.
- intros Hdis He H0 HS.
- iDestruct He as (α_e) "He". iDestruct H0 as (α_0) "H0". iDestruct HS as (α_S) "HS".
- iExists (α_e ⊕ α_0 ⊕ omul α_S). rewrite !tc_split. iIntros "[[α_e α_0] α_S]".
- iIntros (θ). rewrite env_ltyped_split; auto. iIntros "[HΓ HΔ]". simpl.
- iSpecialize ("He" with "α_e HΓ"). iSpecialize ("H0" with "α_0 HΔ").
- simpl; iApply (closed_nat_iter _ _ _ α_S with "[$He $H0 $α_S]").
- iModIntro. iIntros "α_S". iIntros (v) "Hv".
- iIntros "Hna". wp_pures.
- replace e_S with (subst_map (delete x ∅) e_S) at 1; last by rewrite delete_empty subst_map_empty.
- rewrite -subst_map_insert. iApply ("HS" with "α_S [Hv] Hna").
- iApply env_ltyped_insert; iFrame.
- iApply env_ltyped_empty.
- Qed.
-
- Lemma fun_intro Γ x e A B: ((<[x:=A]> Γ) ⊨ e : B)%I → (Γ ⊨ (λ: x, e) : larr A B)%I.
- Proof.
- intros He. iDestruct He as (α_e) "He". iExists α_e.
- iIntros "α_e". iSpecialize ("He" with "α_e").
- iIntros (θ) "HΓ". simpl. iApply (closed_fun_intro).
- iIntros (v) "Hv". rewrite -subst_map_insert. iApply ("He" with "[HΓ Hv]").
- iApply (env_ltyped_insert with "[$HΓ Hv]"); first done.
- Qed.
-
- Lemma fun_elim Γ Δ e1 e2 A B: Γ ##ₘ Δ → (Γ ⊨ e1 : larr A B)%I → (Δ ⊨ e2 : A)%I → (Γ ∪ Δ ⊨ (e1 e2): B)%I.
- Proof.
- intros Hdis H1 H2. iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
- iExists (α_1 ⊕ α_2). rewrite tc_split. iIntros "[α_1 α_2]".
- iIntros (θ). rewrite env_ltyped_split; auto. iIntros "[HΓ HΔ]".
- iSpecialize ("H1" with "α_1 HΓ"). iSpecialize ("H2" with "α_2 HΔ").
- simpl; iApply (closed_fun_elim with "[$H1 $H2]").
- Qed.
-
- Lemma tensor_intro Γ Δ e1 e2 A B: Γ ##ₘ Δ → (Γ ⊨ e1 : A)%I → (Δ ⊨ e2 : B)%I → (Γ ∪ Δ ⊨ (e1, e2): ltensor A B)%I.
- Proof.
- intros Hdis H1 H2. iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
- iExists (α_1 ⊕ α_2). rewrite tc_split. iIntros "[α_1 α_2]".
- iIntros (θ). rewrite env_ltyped_split; auto. iIntros "[HΓ HΔ]".
- iSpecialize ("H1" with "α_1 HΓ"). iSpecialize ("H2" with "α_2 HΔ").
- iApply (closed_tensor_intro with "[$H1 $H2]").
- Qed.
-
- Lemma tensor_elim Γ Δ x y e1 e2 A B C: x ≠ y → Γ ##ₘ Δ → (Γ ⊨ e1 : ltensor A B)%I → ((<[x := A]> (<[y := B]> Δ)) ⊨ e2 : C)%I → (Γ ∪ Δ ⊨ (let: (x, y) := e1 in e2) : C)%I.
- Proof.
- intros Hne Hdis H1 H2. iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
- iExists (α_1 ⊕ α_2). rewrite tc_split. iIntros "[α_1 α_2]".
- iIntros (θ). rewrite env_ltyped_split; auto. iIntros "[HΓ HΔ]".
- iSpecialize ("H1" with "α_1 HΓ"). simpl. iApply (closed_tensor_elim with "[$H1 HΔ α_2]"); auto.
- iIntros (v1 v2) "Hv1 Hv2".
- rewrite delete_commute -subst_map_insert -delete_insert_ne; auto.
- rewrite -subst_map_insert. iApply ("H2" with "α_2").
- rewrite insert_commute; auto.
- do 2 (iApply env_ltyped_insert; iFrame).
- Qed.
-
- Lemma chan_alloc A: (∅ ⊨ chan #() : ltensor (lget A) (lput A))%I.
- Proof.
- iExists (one ⊕ one). rewrite tc_split. iIntros "Hcred".
- iIntros (θ) "_"; simpl. iApply (closed_chan A with "Hcred").
- Qed.
-
- Lemma chan_get Γ Δ e1 e2 A: Γ ##ₘ Δ → (Γ ⊨ e1 : lget A)%I → (Δ ⊨ e2 : larr A lunit)%I → (Γ ∪ Δ ⊨ get (e1, e2)%E: lunit)%I.
- Proof using FBI Heap SI Sequential TimeCredits Σ.
- intros Hdis H1 H2. iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
- iExists (α_1 ⊕ α_2). rewrite tc_split. iIntros "[α_1 α_2]".
- iIntros (θ). rewrite env_ltyped_split; auto. iIntros "[HΓ HΔ]".
- iSpecialize ("H1" with "α_1 HΓ"). iSpecialize ("H2" with "α_2 HΔ").
- simpl; iApply (closed_get with "[$H1 $H2]").
- Qed.
-
- Lemma chan_put Γ Δ e1 e2 A: Γ ##ₘ Δ → (Γ ⊨ e1 : lput A)%I → (Δ ⊨ e2 : A)%I → (Γ ∪ Δ ⊨ put (e1, e2)%E: lunit)%I.
- Proof using FBI Heap SI Sequential TimeCredits Σ.
- intros Hdis H1 H2. iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
- iExists (α_1 ⊕ α_2). rewrite tc_split. iIntros "[α_1 α_2]".
- iIntros (θ). rewrite env_ltyped_split; auto. iIntros "[HΓ HΔ]".
- iSpecialize ("H1" with "α_1 HΓ"). iSpecialize ("H2" with "α_2 HΔ").
- simpl; iApply (closed_put with "[$H1 $H2]").
- Qed.
-
- End simple_logical_relation.
-
- Section polymorphic_logical_relation.
- (* The semantic typing judgment *)
- Implicit Types (Ω: gset string) (* the type variables *).
- Implicit Types (δ: gmap string ltype) (* the instantiation of the type variables *).
- Definition lptype := gmap string ltype -d> ltype.
-
- Implicit Types (Π Ξ: gmap string lptype). (* the variables, given an instantiation of the type variables *)
- Implicit Types (T U: lptype). (* the types *)
- Implicit Types (θ τ: gmap string val).
-
- Definition subst_cons δ X A := <[X := A]> δ.
- Definition subst_ty (T: lptype) (X: string) U : lptype := λ δ, T (subst_cons δ X (U δ)).
- Definition well_formed Ω δ : iProp Σ := (⌜Ω ≡ dom (gset string) δ⌝)%I.
- Definition well_formed_type Ω T : Prop := (∀ δ δ', (∀ X, X ∈ Ω → δ !! X = δ' !! X) → T δ = T δ').
- Definition well_formed_ctx Ω Π : Prop := (∀ x T, Π !! x = Some T → well_formed_type Ω T).
- Definition env_lptyped Π δ θ : iProp Σ := (env_ltyped (fmap (λ T, T δ) Π) θ)%I.
- Definition lptyped Ω Π e T := ⊢ (∃ α, $ α -∗ ∀ δ, well_formed Ω δ -∗ ∀ θ, env_lptyped Π δ θ -∗ SEQ subst_map θ e [{ v, (T δ) v }])%I.
- Notation "Ω ; Π ⊨ e : T" := (lptyped Ω Π e T) (at level 100, Π at next level, e at next level, T at level 200) : bi_scope.
-
- (* Notation for well-formedness *)
- Class is_wf (A B: Type) := Is_wf: A → B → Prop.
- Notation "A ⊨ B" := (Is_wf A B) (at level 100, B at level 200).
- Instance: is_wf (gset string) (lptype) := well_formed_type.
- Instance: is_wf (gset string) (gmap string lptype) := well_formed_ctx.
-
- Definition lpunit : lptype := λ _, lunit.
- Definition lpbool : lptype := λ _, lbool.
- Definition lpnat : lptype := λ _, lnat.
- Definition lpget T : lptype := λ δ, lget (T δ).
- Definition lpput T : lptype := λ δ, lput (T δ).
- Definition lptensor T U : lptype := λ δ, ltensor (T δ) (U δ).
- Definition lparr T U : lptype := λ δ, larr (T δ) (U δ).
- Definition lpforall X (T: lptype) : lptype := λ δ f, (∀ U, SEQ (f #()) [{ u, (subst_ty T X U) δ u }])%I.
- Definition lpexists X (T: lptype) : lptype := λ δ v, (∃ U, (subst_ty T X U) δ v)%I.
-
- Definition tlam e : expr := λ: <>, e.
- Definition tapp e : expr := e #().
- Definition pack e : expr := e.
- Definition unpack e x e' : expr := (λ: x, e') e.
-
- Lemma well_formed_empty:
- True ⊢ well_formed ∅ ∅.
- Proof using SI Σ.
- iIntros (Heq). iPureIntro.
- by rewrite dom_empty.
- Qed.
-
-
- Lemma well_formed_insert Ω δ X A:
- well_formed Ω δ ⊢ well_formed ({[X]} ∪ Ω) (subst_cons δ X A).
- Proof using SI Σ.
- iIntros (Heq). iPureIntro.
- by rewrite dom_insert Heq.
- Qed.
-
- Lemma env_lptyped_split Π Ξ δ θ: Π ##ₘ Ξ → env_lptyped (Π ∪ Ξ) δ θ ⊢ env_lptyped Π δ θ ∗ env_lptyped Ξ δ θ.
- Proof.
- intros H. rewrite /env_lptyped /env_ltyped !big_sepM_fmap big_sepM_union; auto.
- Qed.
-
- Lemma env_lptyped_empty δ θ: sbi_emp_valid (env_lptyped ∅ δ θ).
- Proof.
- iStartProof. by rewrite /env_lptyped /env_ltyped !big_sepM_fmap big_sepM_empty.
- Qed.
-
- Lemma env_lptyped_insert Π δ θ T v x: env_lptyped Π δ θ ∗ T δ v ⊢ env_lptyped (<[x:=T]> Π) δ (<[x:=v]> θ).
- Proof.
- rewrite /env_lptyped fmap_insert. eapply env_ltyped_insert.
- Qed.
-
- Lemma env_lptyped_weaken x T Π θ δ: Π !! x = None → env_lptyped (<[x:=T]> Π) δ θ ⊢ env_lptyped Π δ θ.
- Proof.
- intros Hx. rewrite /env_lptyped fmap_insert env_ltyped_weaken //= lookup_fmap Hx //=.
- Qed.
-
- Lemma env_lptyped_update_type_map Ω Π T δ X θ:
- (Ω ⊨ Π) → (X ∉ Ω) → env_lptyped Π δ θ ⊢ env_lptyped Π (subst_cons δ X (T δ)) θ.
- Proof using SI Σ.
- clear FBI. intros Hwf HX. rewrite /env_lptyped /env_ltyped !big_opM_fmap.
- iIntros "Hθ". iApply (big_sepM_mono with "Hθ").
- iIntros (Y B HYB) "H". iDestruct "H" as (v) "[% B]".
- iExists v; iSplit; auto.
- feed pose proof (Hwf _ _ HYB δ (<[X:=T δ]> δ)) as HB.
- { intros Z Hx'. assert (X ≠ Z) by set_solver. by rewrite lookup_insert_ne. }
- by erewrite HB.
- Qed.
-
-
- (* the typing rules *)
- Lemma poly_variable Ω x T: (Ω; {[ x := T ]} ⊨ x : T)%I.
- Proof.
- iExists ord_stepindex.zero. iIntros "_".
- iIntros (δ) "%". iIntros (θ) "HΓ". rewrite /env_lptyped /env_ltyped big_opM_fmap.
- iPoseProof (big_sepM_lookup _ _ x T with "HΓ") as "Hx"; first eapply lookup_insert.
- simpl; iDestruct "Hx" as (v) "(-> & HA)".
- by iApply seq_value.
- Qed.
-
- Lemma poly_weaken x Ω Π e T U: Π !! x = None → (Ω; Π ⊨ e : U)%I → (Ω; (<[ x := T ]> Π) ⊨ e : U)%I.
- Proof.
- intros Hx He. iDestruct He as (α) "He".
- iExists α. iIntros "Hα". iIntros (δ) "Hδ". iIntros (θ) "Hθ".
- iApply ("He" with "Hα Hδ"). by iApply (env_lptyped_weaken with "Hθ").
- Qed.
-
- Lemma poly_unit_intro Ω: (Ω; ∅ ⊨ #() : lpunit)%I.
- Proof.
- iExists ord_stepindex.zero. iIntros "_".
- iIntros (δ) "Hδ". iIntros (θ) "HΓ"; simpl. iApply closed_unit_intro.
- Qed.
-
- Lemma poly_unit_elim Ω Π Ξ e e' T: Π ##ₘ Ξ → (Ω; Π ⊨ e : lpunit)%I → (Ω; Ξ ⊨ e' : T)%I → (Ω; Π ∪ Ξ ⊨ (e ;; e'): T)%I.
- Proof.
- intros Hdis He He'. iDestruct He as (α_e) "He". iDestruct He' as (α_e') "He'".
- iExists (α_e ⊕ α_e'). rewrite tc_split. iIntros "[α_e α_e']".
- iIntros (δ) "#Hδ". iIntros (θ). rewrite env_lptyped_split; auto. iIntros "[HΓ HΔ]".
- iSpecialize ("He" with "α_e Hδ HΓ"). iSpecialize ("He'" with "α_e' Hδ HΔ").
- simpl; iApply (closed_unit_elim with "[$He $He']").
- Qed.
-
- Lemma poly_bool_intro Ω b: (Ω; ∅ ⊨ #b : lpbool)%I.
- Proof.
- iExists ord_stepindex.zero. iIntros "_".
- iIntros (δ) "#Hδ". iIntros (θ) "HΓ"; simpl. iApply closed_bool_intro.
- Qed.
-
- Lemma poly_bool_elim Ω Π Ξ e e_1 e_2 T:
- Π ##ₘ Ξ
- → (Ω; Π ⊨ e : lpbool)%I
- → (Ω; Ξ ⊨ e_1 : T)%I
- → (Ω; Ξ ⊨ e_2 : T)%I
- → (Ω; (Π ∪ Ξ) ⊨ (if: e then e_1 else e_2): T)%I.
- Proof.
- intros Hdis He H1 H2. iDestruct He as (α_e) "He". iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
- iExists (α_e ⊕ α_1 ⊕ α_2). rewrite !tc_split. iIntros "[[α_e α_1] α_2]".
- iIntros (δ) "#Hδ". iIntros (θ). rewrite env_lptyped_split; auto. iIntros "[HΓ HΔ]".
- iSpecialize ("He" with "α_e Hδ HΓ"). simpl.
- iApply (closed_bool_elim _ _ _ _ (env_lptyped Ξ δ θ)); iFrame.
- iSplitL "H1 α_1".
- - iApply ("H1" with "α_1 Hδ").
- - iApply ("H2" with "α_2 Hδ").
- Qed.
-
- Lemma poly_nat_intro Ω n: (Ω; ∅ ⊨ #n : lpnat)%I.
- Proof.
- iExists ord_stepindex.zero. iIntros "_".
- iIntros (δ) "#Hδ". iIntros (θ) "HΓ"; simpl. iApply closed_nat_intro.
- Qed.
-
- Lemma poly_nat_plus Ω e1 e2 Π Ξ: Π ##ₘ Ξ → (Ω; Π ⊨ e1 : lpnat)%I → (Ω; Ξ ⊨ e2 : lpnat)%I → (Ω; Π ∪ Ξ ⊨ e1 + e2 : lpnat)%I.
- Proof.
- intros Hdis H1 H2. iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
- iExists (α_1 ⊕ α_2). rewrite tc_split. iIntros "[α_1 α_2]".
- iIntros (δ) "#Hδ". iIntros (θ). rewrite env_lptyped_split; auto. iIntros "[HΓ HΔ]".
- iSpecialize ("H1" with "α_1 Hδ HΓ"). iSpecialize ("H2" with "α_2 Hδ HΔ").
- simpl; iApply (closed_nat_add with "[$H1 $H2]").
- Qed.
-
- Lemma poly_nat_elim Ω e e_0 e_S x T Π Ξ:
- Π ##ₘ Ξ
- → (Ω; Π ⊨ e : lpnat)%I
- → (Ω; Ξ ⊨ e_0 : T)%I
- → (Ω; {[ x := T ]} ⊨ e_S : T)%I
- → (Ω; Π ∪ Ξ ⊨ iter e_0 e (λ: x, e_S)%V : T)%I.
- Proof.
- intros Hdis He H0 HS.
- iDestruct He as (α_e) "He". iDestruct H0 as (α_0) "H0". iDestruct HS as (α_S) "HS".
- iExists (α_e ⊕ α_0 ⊕ omul α_S). rewrite !tc_split. iIntros "[[α_e α_0] α_S]".
- iIntros (δ) "#Hδ". iIntros (θ). rewrite env_lptyped_split; auto. iIntros "[HΓ HΔ]". simpl.
- iSpecialize ("He" with "α_e Hδ HΓ"). iSpecialize ("H0" with "α_0 Hδ HΔ").
- simpl; iApply (closed_nat_iter _ _ _ α_S with "[$He $H0 $α_S]").
- iModIntro. iIntros "α_S". iIntros (v) "Hv".
- iIntros "Hna". wp_pures.
- replace e_S with (subst_map (delete x ∅) e_S) at 1; last by rewrite delete_empty subst_map_empty.
- rewrite -subst_map_insert. iApply ("HS" with "α_S Hδ [Hv] Hna").
- iApply env_lptyped_insert; iFrame.
- iApply env_lptyped_empty.
- Qed.
-
- Lemma poly_fun_intro Ω Π x e T U:
- (Ω; (<[x:=T]> Π) ⊨ e : U)%I
- → (Ω; Π ⊨ (λ: x, e) : lparr T U)%I.
- Proof.
- intros He. iDestruct He as (α_e) "He". iExists α_e.
- iIntros "α_e". iSpecialize ("He" with "α_e").
- iIntros (δ) "#Hδ". iIntros (θ) "HΓ". simpl. iApply (closed_fun_intro).
- iIntros (v) "Hv". rewrite -subst_map_insert. iApply ("He" with "Hδ [HΓ Hv]").
- iApply (env_lptyped_insert with "[$HΓ Hv]"); first done.
- Qed.
-
- Lemma poly_fun_elim Ω Π Ξ e1 e2 T U:
- Π ##ₘ Ξ
- → (Ω; Π ⊨ e1 : lparr T U)%I
- → (Ω; Ξ ⊨ e2 : T)%I
- → (Ω; Π ∪ Ξ ⊨ (e1 e2): U)%I.
- Proof.
- intros Hdis H1 H2. iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
- iExists (α_1 ⊕ α_2). rewrite tc_split. iIntros "[α_1 α_2]".
- iIntros (δ) "#Hδ". iIntros (θ). rewrite env_lptyped_split; auto. iIntros "[HΓ HΔ]".
- iSpecialize ("H1" with "α_1 Hδ HΓ"). iSpecialize ("H2" with "α_2 Hδ HΔ").
- simpl; iApply (closed_fun_elim with "[$H1 $H2]").
- Qed.
-
- Lemma poly_tensor_intro Ω Π Ξ e1 e2 T U:
- Π ##ₘ Ξ
- → (Ω; Π ⊨ e1 : T)%I
- → (Ω; Ξ ⊨ e2 : U)%I
- → (Ω; Π ∪ Ξ ⊨ (e1, e2): lptensor T U)%I.
- Proof.
- intros Hdis H1 H2. iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
- iExists (α_1 ⊕ α_2). rewrite tc_split. iIntros "[α_1 α_2]".
- iIntros (δ) "#Hδ". iIntros (θ). rewrite env_lptyped_split; auto. iIntros "[HΓ HΔ]".
- iSpecialize ("H1" with "α_1 Hδ HΓ"). iSpecialize ("H2" with "α_2 Hδ HΔ").
- iApply (closed_tensor_intro with "[$H1 $H2]").
- Qed.
-
- Lemma poly_tensor_elim Ω Π Ξ x y e1 e2 T1 T2 U:
- x ≠ y
- → Π ##ₘ Ξ
- → (Ω; Π ⊨ e1 : lptensor T1 T2)%I
- → (Ω; (<[x := T1]> (<[y := T2]> Ξ)) ⊨ e2 : U)%I
- → (Ω; Π ∪ Ξ ⊨ (let: (x, y) := e1 in e2) : U)%I.
- Proof.
- intros Hne Hdis H1 H2. iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
- iExists (α_1 ⊕ α_2). rewrite tc_split. iIntros "[α_1 α_2]".
- iIntros (δ) "#Hδ". iIntros (θ). rewrite env_lptyped_split; auto. iIntros "[HΓ HΔ]".
- iSpecialize ("H1" with "α_1 Hδ HΓ"). simpl. iApply (closed_tensor_elim with "[$H1 HΔ α_2]"); auto.
- iIntros (v1 v2) "Hv1 Hv2".
- rewrite delete_commute -subst_map_insert -delete_insert_ne; auto.
- rewrite -subst_map_insert. iApply ("H2" with "α_2 Hδ").
- rewrite insert_commute; auto.
- do 2 (iApply env_lptyped_insert; iFrame).
- Qed.
-
- Lemma poly_chan_alloc Ω T: (Ω; ∅ ⊨ chan #() : lptensor (lpget T) (lpput T))%I.
- Proof.
- iExists (one ⊕ one). rewrite tc_split. iIntros "Hcred".
- iIntros (δ) "#Hδ". iIntros (θ) "_"; simpl. iApply (closed_chan (T δ) with "Hcred").
- Qed.
-
- Lemma poly_chan_get Ω Π Ξ e1 e2 T:
- Π ##ₘ Ξ
- → (Ω; Π ⊨ e1 : lpget T)%I
- → (Ω; Ξ ⊨ e2 : lparr T lpunit)%I
- → (Ω; Π ∪ Ξ ⊨ get (e1, e2)%E: lpunit)%I.
- Proof using FBI Heap SI Sequential TimeCredits Σ.
- intros Hdis H1 H2. iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
- iExists (α_1 ⊕ α_2). rewrite tc_split. iIntros "[α_1 α_2]".
- iIntros (δ) "#Hδ". iIntros (θ). rewrite env_lptyped_split; auto. iIntros "[HΓ HΔ]".
- iSpecialize ("H1" with "α_1 Hδ HΓ"). iSpecialize ("H2" with "α_2 Hδ HΔ").
- simpl; iApply (closed_get with "[$H1 $H2]").
- Qed.
-
- Lemma poly_chan_put Ω Π Ξ e1 e2 T:
- Π ##ₘ Ξ
- → (Ω; Π ⊨ e1 : lpput T)%I
- → (Ω; Ξ ⊨ e2 : T)%I
- → (Ω; Π ∪ Ξ ⊨ put (e1, e2)%E: lpunit)%I.
- Proof using FBI Heap SI Sequential TimeCredits Σ.
- intros Hdis H1 H2. iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
- iExists (α_1 ⊕ α_2). rewrite tc_split. iIntros "[α_1 α_2]".
- iIntros (δ) "#Hδ". iIntros (θ). rewrite env_lptyped_split; auto. iIntros "[HΓ HΔ]".
- iSpecialize ("H1" with "α_1 Hδ HΓ"). iSpecialize ("H2" with "α_2 Hδ HΔ").
- simpl; iApply (closed_put with "[$H1 $H2]").
- Qed.
-
-
- Lemma poly_forall_intro Ω X Π e T:
- (Ω ⊨ Π) → X ∉ Ω → (({[X]} ∪ Ω); Π ⊨ e : T)%I → (Ω; Π ⊨ tlam e : lpforall X T)%I.
- Proof using FBI Heap SI Sequential TimeCredits Σ.
- intros Hwf Hx He.
- iDestruct He as (α_e) "He". iExists α_e.
- iIntros "Ha". iSpecialize ("He" with "Ha").
- iIntros (δ) "Hδ". iIntros (θ) "Hθ". simpl.
- iIntros "Hna". wp_pures. iFrame.
- unfold lpforall. iIntros (U) "Hna".
- wp_pures. unfold subst_ty. iApply ("He" with "[Hδ] [Hθ] Hna").
- - by iApply well_formed_insert.
- - iApply (env_lptyped_update_type_map with "Hθ"); eauto.
- Qed.
-
- (* For the compatibility lemma, we do not need well-formedness of U. It's only needed for type preservation. *)
- Lemma poly_forall_elim Ω X Π e T U:
- (* Ω ⊨ U → *) (Ω; Π ⊨ e : lpforall X T)%I → (Ω; Π ⊨ tapp e : subst_ty T X U)%I.
- Proof.
- intros He.
- iDestruct He as (α_e) "He". iExists α_e.
- iIntros "Ha". iSpecialize ("He" with "Ha").
- iIntros (δ) "Hδ". iIntros (θ) "Hθ". simpl.
- iIntros "Hna". wp_bind (subst_map _ e).
- iMod ("He" with "Hδ Hθ Hna") as "_".
- iIntros (v) "[Hna Hf] !>". rewrite /lpforall.
- by iApply "Hf".
- Qed.
-
- (* Well-formedness assumptions needed for type preservation but not for the compatibility lemma.*)
- Lemma poly_exists_intro Ω X Π e T U:
- (Ω; Π ⊨ e : subst_ty T X U)%I → (Ω; Π ⊨ pack e : lpexists X T)%I.
- Proof using FBI Heap SI Sequential TimeCredits Σ.
- intros He.
- iDestruct He as (α_e) "He". iExists α_e.
- iIntros "Ha". iSpecialize ("He" with "Ha").
- iIntros (δ) "Hδ". iIntros (θ) "Hθ".
- iIntros "Hna". iMod ("He" with "Hδ Hθ Hna") as "_".
- iIntros (v) "[$ HT] !>". by iExists U.
- Qed.
-
- Lemma poly_exists_elim Ω X Π Ξ x e e2 T U:
- X ∉ Ω
- → (Ω ⊨ Ξ)
- → (Ω ⊨ U)
- → Π ##ₘ Ξ
- → (Ω; Π ⊨ e : lpexists X T)%I
- → ({[X]} ∪ Ω; <[x := T ]> Ξ ⊨ e2 : U)%I
- → (Ω; Π ∪ Ξ ⊨ unpack e x e2 : U)%I.
- Proof using FBI Heap SI Sequential TimeCredits Σ.
- intros Hx Hwf HwfU Hdis He He2.
- iDestruct He as (α_e) "He". iDestruct He2 as (α_2) "H2".
- iExists (α_e ⊕ α_2). rewrite tc_split. iIntros "[α_e α_2]".
- iIntros (δ) "#Hδ". iIntros (θ). rewrite env_lptyped_split //=.
- iIntros "[HΓ HΞ] Hna".
- wp_bind (subst_map _ e). iMod ("He" with "α_e Hδ HΓ Hna") as "_".
- iIntros (v) "[Hna Hv] !>". iDestruct "Hv" as (T') "Hv".
- wp_pures. rewrite -subst_map_insert.
- iMod ("H2" with "α_2 [Hδ] [HΞ Hv] Hna") as "_".
- - by iApply well_formed_insert.
- - iApply env_lptyped_insert; iFrame.
- iApply (env_lptyped_update_type_map with "HΞ"); eauto.
- - feed pose proof (HwfU δ (<[X := (T' δ)]> δ)).
- { intros Z Hx'. assert (X ≠ Z) by set_solver. by rewrite lookup_insert_ne. }
- iIntros (w) "[$ HU] !>". by rewrite -H.
- Qed.
-
-End polymorphic_logical_relation.
-
-End semantic_model.
-
-From iris.examples.termination Require Import adequacy.
-Section adequacy.
-
- Context {SI} `{C: Classical} {Σ: gFunctors SI} {Hlarge: LargeIndex SI}.
- Context `{Hpre: !heapPreG Σ} `{Hna: !na_invG Σ} `{Htc: !inG Σ (authR (ordA SI))}.
-
- Theorem simple_logrel_adequacy (e: expr) σ A:
- (∀ `{heapG SI Σ} `{!seqG Σ} `{!auth_sourceG Σ (ordA SI)},
- ltyped ∅ e A
- ) →
- sn erased_step ([e], σ).
- Proof using Hlarge C Σ Hpre Hna Htc.
- intros Htyped.
- eapply heap_lang_ref_adequacy.
- intros ???. iIntros "_".
- iPoseProof (Htyped) as (α) "H".
- iExists α. iIntros "Hα". iSpecialize ("H" with "Hα").
- iPoseProof (env_ltyped_empty ∅) as "Henv". iSpecialize ("H" with "Henv").
- rewrite subst_map_empty. iIntros "Hna". iMod ("H" with "Hna"); eauto.
- by iIntros (v) "[$ _]".
- Qed.
-
- Theorem logrel_adequacy (e: expr) σ A:
- (∀ `{heapG SI Σ} `{!seqG Σ} `{!auth_sourceG Σ (ordA SI)},
- lptyped ∅ ∅ e A
- ) →
- sn erased_step ([e], σ).
- Proof using Hlarge C Σ Hpre Hna Htc.
- intros Htyped.
- eapply heap_lang_ref_adequacy.
- intros ???. iIntros "_".
- iPoseProof (Htyped) as (α) "H".
- iExists α. iIntros "Hα". iSpecialize ("H" with "Hα").
- iPoseProof (well_formed_empty with "[//]") as "Hctx".
- iPoseProof (env_lptyped_empty ∅ ∅) as "Henv".
- iSpecialize ("H" with "Hctx Henv").
- rewrite subst_map_empty. iIntros "Hna". iMod ("H" with "Hna"); eauto.
- by iIntros (v) "[$ _]".
- Qed.
-
-End adequacy.
-
-Section ordinals.
- Context `{C: Classical} {Σ: gFunctors ordI}.
- Context `{Hpre: !heapPreG Σ} `{Hna: !na_invG Σ} `{Htc: !inG Σ (authR (ordA ordI))}.
-
- Theorem simple_logrel_adequacy_ord (e: expr) σ A:
- (∀ `{heapG ordI Σ} `{!seqG Σ} `{!auth_sourceG Σ (ordA ordI)},
- ltyped ∅ e A
- ) →
- sn erased_step ([e], σ).
- Proof using C Σ Hpre Hna Htc.
- intros Htyped.
- eapply heap_lang_ref_adequacy.
- intros ???. iIntros "_".
- iPoseProof (Htyped) as (α) "H".
- iExists α. iIntros "Hα". iSpecialize ("H" with "Hα").
- iPoseProof (env_ltyped_empty ∅) as "Henv". iSpecialize ("H" with "Henv").
- rewrite subst_map_empty. iIntros "Hna". iMod ("H" with "Hna"); eauto.
- by iIntros (v) "[$ _]".
- Qed.
-
- Theorem logrel_adequacy_ord (e: expr) σ A:
- (∀ `{heapG ordI Σ} `{!seqG Σ} `{!auth_sourceG Σ (ordA ordI)},
- lptyped ∅ ∅ e A
- ) →
- sn erased_step ([e], σ).
- Proof using C Σ Hpre Hna Htc.
- intros Htyped.
- eapply heap_lang_ref_adequacy.
- intros ???. iIntros "_".
- iPoseProof (Htyped) as (α) "H".
- iExists α. iIntros "Hα". iSpecialize ("H" with "Hα").
- iPoseProof (well_formed_empty with "[//]") as "Hctx".
- iPoseProof (env_lptyped_empty ∅ ∅) as "Henv".
- iSpecialize ("H" with "Hctx Henv").
- rewrite subst_map_empty. iIntros "Hna". iMod ("H" with "Hna"); eauto.
- by iIntros (v) "[$ _]".
- Qed.
-
-End ordinals.
-
diff --git a/theories/examples/termination/thunk.v b/theories/examples/termination/thunk.v
deleted file mode 100644
index 615ea79a..00000000
--- a/theories/examples/termination/thunk.v
+++ /dev/null
@@ -1,139 +0,0 @@
-From iris.program_logic.refinement Require Export seq_weakestpre.
-From iris.base_logic.lib Require Export invariants na_invariants.
-From iris.heap_lang Require Export lang lifting.
-From iris.proofmode Require Import tactics.
-From iris.heap_lang Require Import proofmode notation metatheory.
-From iris.algebra Require Import auth.
-From iris.algebra.ordinals Require Import arithmetic.
-Set Default Proof Using "Type".
-
-
-
-Definition thunk : val :=
- λ: "f", let: "r" := ref NONE in
- λ: <>, match: !"r" with
- SOME "v" => "v"
- | NONE => (let: "y" := "f" #() in "r" <- SOME "y";; "y")
- end.
-
-Section thunk_proof.
- Context {SI} {Σ: gFunctors SI} `{Hheap: !heapG Σ} `{Htc: !tcG Σ} (N : namespace) `{Htok: !inG Σ (authR (unitUR SI))}.
-
- Implicit Types (α β: ord_stepindex.Ord).
-
- (* simplest spec - one to one correspondence *)
- Lemma thunk_partial_spec (f: val) Φ:
- WP f #() {{ Φ }} -∗ WP (thunk f) {{ g, WP g #() {{ Φ }} }}.
- Proof.
- iIntros "Hf". unfold thunk. wp_pures. wp_bind (ref _)%E.
- wp_alloc r as "Hr"; wp_pures.
- wp_pures. wp_load. wp_pures.
- wp_apply (wp_wand with "Hf [Hr]").
- iIntros (v) "Hv"; wp_pures.
- by wp_store.
- Qed.
-
- Lemma thunk_spec (f: val) Φ:
- WP f #() [{ Φ }] -∗ WP (thunk f) [{ g, WP g #() [{ Φ }] }].
- Proof.
- iIntros "Hf". unfold thunk. wp_pures. wp_bind (ref _)%E.
- wp_alloc r as "Hr"; wp_pures.
- wp_pures. wp_load. wp_pures.
- wp_apply (rwp_wand with "Hf [Hr]").
- iIntros (v) "Hv"; wp_pures.
- by wp_store.
- Qed.
-
-
- Definition thunk_inv `{!seqG Σ} r (f: val) Φ : iProp Σ :=
- (r ↦ NONEV ∗ SEQ (f #()) @ (⊤ ∖ ↑N) ⟨⟨ v, Φ v ⟩⟩ ∨ (∃ v, r ↦ SOMEV v ∗ Φ v))%I.
-
- Lemma thunk_sequential_spec `{!seqG Σ} `{FiniteBoundedExistential SI} (f: val) Φ:
- (∀ x, Persistent (Φ x)) →
- SEQ (f #()) @ (⊤ ∖ ↑N) ⟨⟨ v, Φ v ⟩⟩ -∗
- SEQ (thunk f) ⟨⟨ g, □ $one -∗ SEQ (g #()) ⟨⟨ v, Φ v⟩⟩⟩⟩.
- Proof.
- iIntros (HΦ) "Hf". rewrite /thunk. iIntros "Hna".
- wp_pures. wp_bind (ref _)%E.
- wp_alloc r as "Hr".
- iMod (na_inv_alloc seqG_name _ N (thunk_inv r f Φ) with "[Hr Hf]") as "#I".
- { iNext. iLeft. by iFrame. }
- wp_pures. iFrame. iModIntro.
- iIntros "Hc Hna". wp_pures.
- wp_bind (! _)%E.
- iMod (na_inv_acc_open with "I Hna") as "P"; eauto.
- iApply (tcwp_burn_credit with "Hc"); auto. iNext.
- iDestruct "P" as "([H|H] & Hna & Hclose)".
- - iDestruct "H" as "(Hr & Hwp)".
- wp_load. wp_pures. iSpecialize ("Hwp" with "Hna").
- wp_bind (f #()). iApply (rwp_wand with "Hwp [Hr Hclose]").
- iIntros (v) "[Hna #HΦ]". wp_pures.
- wp_bind (#r <- _)%E. wp_store.
- iMod ("Hclose" with "[Hr $Hna]") as "Hna".
- { iNext. iRight. iExists v. by iFrame. }
- wp_pures. by iFrame.
- - iDestruct "H" as (v) "[Hr #HΦ]".
- wp_load. iMod ("Hclose" with "[Hr $Hna]") as "Hna".
- { iNext. iRight. iExists v. by iFrame. }
- wp_pures. by iFrame.
- Qed.
-
-
- (* the timeless portion *)
- Definition prepaid_inv_tl `{!seqG Σ} γ r Φ : iProp Σ :=
- ((r ↦ NONEV ∗ $ one ∗ own γ (● ())) ∨ (∃ v, r ↦ SOMEV v ∗ Φ v))%I.
-
- Global Instance prepaid_inv_tl_timeless `{!seqG Σ} α γ Φ r: (∀ v, Timeless (Φ v)) → Timeless (prepaid_inv_tl γ r Φ).
- Proof.
- intros. rewrite /prepaid_inv_tl. apply _.
- Qed.
-
- Definition prepaid_inv_re `{!seqG Σ} γ (f: val) Φ : iProp Σ :=
- (SEQ (f #()) @ (⊤ ∖ ↑N.@"tl" ∖ ↑N.@"re") ⟨⟨ v, Φ v ⟩⟩ ∨ own γ (● ()))%I.
-
-
- Lemma thunk_sequential_prepaid_spec `{!seqG Σ} `{FiniteBoundedExistential SI} (f: val) Φ:
- (∀ x, Persistent (Φ x)) → (∀ x, Timeless (Φ x)) →
- SEQ (f #()) @ (⊤ ∖ ↑N.@"tl" ∖ ↑N.@"re") ⟨⟨v, Φ v⟩⟩ -∗ $one -∗ SEQ (thunk f) ⟨⟨ g, □ SEQ (g #()) ⟨⟨ v, Φ v⟩⟩⟩⟩.
- Proof using Hheap Htc Htok N SI Σ.
- iIntros (??) "Hf Hone". rewrite /thunk. iIntros "Hna".
- wp_pures.
- iMod (own_alloc (● ())) as (γ) "H●"; first by apply auth_auth_valid.
- wp_bind (ref _)%E.
- wp_alloc r as "Hr".
- iMod (na_inv_alloc seqG_name _ (N .@ "tl") (prepaid_inv_tl γ r Φ) with "[Hr Hone H●]") as "#Itl".
- { iNext. iLeft. by iFrame. }
- iMod (na_inv_alloc seqG_name _ (N .@ "re") (prepaid_inv_re γ f Φ) with "[$Hf]") as "#Ire".
- wp_pures. iFrame. iModIntro.
- iIntros "Hna". wp_pures.
- wp_bind (! _)%E.
- iMod (na_inv_acc_open_timeless with "Itl Hna") as "([H|H] & Hna & Hclose)"; eauto.
- - iDestruct "H" as "(Hr & Hone & H●)".
- iMod (na_inv_acc_open with "Ire Hna") as "P"; eauto; first solve_ndisj.
- iApply (tcwp_burn_credit with "Hone"); auto.
- iNext. iDestruct "P" as "(Hre & Hna & Hclose')".
- wp_load. wp_pures.
- wp_bind (f #()). rewrite /prepaid_inv_re.
- iDestruct "Hre" as "[Hwp|H●']".
- + iSpecialize ("Hwp" with "Hna").
- iApply (rwp_wand with "Hwp [Hr Hclose Hclose' H●]").
- iIntros (v) "[Hna #HΦ]". wp_pures.
- wp_bind (#r <- _)%E. wp_store.
- iMod ("Hclose'" with "[$Hna $H●]") as "Hna".
- iMod ("Hclose" with "[Hr $Hna]") as "Hna".
- { iNext. iRight. iExists v. by iFrame. }
- wp_pures. by iFrame.
- + iCombine "H● H●'" as "H".
- iPoseProof (own_valid with "H") as "H".
- rewrite uPred.discrete_valid.
- iDestruct "H" as "%".
- apply ->(@auth_auth_frac_valid SI) in H2.
- destruct H2 as [H2 _]. rewrite frac_op' in H2.
- apply ->(@frac_valid' SI) in H2.
- exfalso. by eapply Qp_not_plus_q_ge_1.
- - iDestruct "H" as (v) "[Hr #HΦ]".
- wp_load. iMod ("Hclose" with "[Hr $Hna]") as "Hna".
- { iNext. iRight. iExists v. by iFrame. }
- wp_pures. by iFrame.
- Qed.
-End thunk_proof.
diff --git a/theories/examples/transfinite.v b/theories/examples/transfinite.v
deleted file mode 100644
index c2554f18..00000000
--- a/theories/examples/transfinite.v
+++ /dev/null
@@ -1,150 +0,0 @@
-From iris.program_logic Require Export weakestpre.
-From iris.heap_lang Require Export lang.
-From iris.proofmode Require Import tactics.
-From iris.heap_lang Require Import proofmode notation.
-From iris.algebra Require Import auth.
-From iris.examples.safety Require Import lock.
-Set Default Proof Using "Type".
-
-
-Section how_to_handle_invariants.
- Context {SI} {Σ: gFunctors SI} `{!heapG Σ} (N : namespace).
-
-
-
- (* We compare how opening invariants worked previously and
- how it can be done in the transfinite setting. *)
- Lemma invariants_previously `{FiniteIndex SI} l Φ:
- {{{ inv N (∃ v, l ↦ v ∗ Φ v) }}} ! #l {{{ v, RET v; True }}}.
- Proof.
- iIntros (ϕ) "#I Post".
- iInv "I" as "H" "Hclose".
- iDestruct "H" as (v) "[Hl P]".
- wp_load. iMod ("Hclose" with "[Hl P]") as "_".
- { iNext. iExists v. iFrame. }
- iModIntro. by iApply "Post".
- Qed.
-
-
- Lemma invariants_transfinite l Φ:
- {{{ inv N (∃ v, l ↦ v ∗ Φ v) }}} ! #l {{{ v, RET v; True }}}.
- Proof.
- iIntros (ϕ) "#I Post".
- (* We move from the weakest pre to the stronger version which allows us to strip off laters.
- The argument is the number of laters we want to strip off. *)
- wp_swp 1%nat.
- (* SWP supports opening up invariants *)
- iInv "I" as "H" "Hclose".
- (* In general, we cannot commutate later with existential quantification *)
- Fail iDestruct "H" as (v) "[Hl P]".
- (* To access the contents of "H", we need to get rid of the later modality.
- We use the step property of SWP to add an additional later to our goal. *)
- swp_step. iNext; simpl.
- (* Afterwards the proof continues exactly the same as before. *)
- iDestruct "H" as (v) "[Hl P]".
- wp_load. iMod ("Hclose" with "[Hl P]") as "_".
- { iNext. iExists v. iFrame. }
- iModIntro. by iApply "Post".
- Qed.
-
-
- (* Using Coq EVars we leave the step counting to Coq: *)
- Lemma invariants_transfinite_evars l Φ:
- {{{ inv N (∃ v, l ↦ v ∗ Φ v) }}} ! #l {{{ v, RET v; True }}}.
- Proof.
- iIntros (ϕ) "#I Post".
- (* If no argument is provided to wp_swp, then the number of
- laters is instantiated with an evar (k in the following). *)
- wp_swp. iInv "I" as "H" "Hclose".
- (* In calling swp_step Coq creates a new evar, say k', and picks k := S k'.
- The user will usually only see k' from there on. *)
- swp_step.
- iNext; simpl.
- iDestruct "H" as (v) "[Hl P]".
- wp_load. iMod ("Hclose" with "[Hl P]") as "_".
- { iNext. iExists v. iFrame. }
- iModIntro. by iApply "Post".
- (* At the end we need to pick a value for the evar k'. Here 0 is always sufficient. *)
- Unshelve. exact 0%nat.
- (* Note that from k' := 0 automatically k := 1 follows *)
- Qed.
-
- (* Make the instantiation step explicit *)
- Lemma swp_finish E e s Φ : SWP e at 0%nat @ s; E {{ Φ }} ⊢ SWP e at 0%nat @ s; E {{ Φ }}.
- Proof. eauto. Qed.
- Ltac swp_finish := iApply swp_finish.
- Ltac swp_last_step := swp_step; swp_finish.
-
-
- (* Using Coq EVars we leave the step counting to Coq: *)
- Lemma invariants_transfinite_evars_inst l Φ:
- {{{ inv N (∃ v, l ↦ v ∗ Φ v) }}} ! #l {{{ v, RET v; True }}}.
- Proof.
- iIntros (ϕ) "#I Post".
- (* If no argument is provided to wp_swp, then the number of
- laters is instantiated with an evar (k in the following). *)
- wp_swp. iInv "I" as "H" "Hclose".
- (* do 5 swp_step. swp_finish. *)
- swp_last_step.
- iNext; simpl.
- iDestruct "H" as (v) "[Hl P]".
- wp_load. iMod ("Hclose" with "[Hl P]") as "_".
- { iNext. iExists v. iFrame. }
- iModIntro. by iApply "Post".
- Qed.
-
- (* Nested invariants *)
- (* We can nest invariants and open nested invariants in a single step of computation *)
- Section nested_invariants.
- Context `{inG SI Σ (authR (mnatUR SI))}.
-
- (* invariant asserting that the value stored at l is only increasing and already positive *)
- Definition Pos N l γ : iProp Σ := inv N (∃ n: mnat, l ↦ #n ∗ ⌜n > 0⌝ ∗ own γ (◯ n))%I.
-
-
- Definition L l1 γ : iProp Σ := inv (N .@ "L") (∃ m: mnat, l1 ↦ #m ∗ own γ (● m))%I.
- Definition R l2 γ : iProp Σ := inv (N .@ "R") (∃ l2': loc, l2 ↦ #l2' ∗ Pos (N .@ "I") l2' γ)%I.
-
- Lemma mnat_own (m n: mnat) γ:
- own γ (● m) -∗ own γ (◯ n) -∗ ⌜n ≤ m⌝%nat.
- Proof.
- iIntros "Hγ● Hγ◯". iDestruct (own_valid_2 with "Hγ● Hγ◯") as "H"; iRevert "H".
- iIntros (Hv). iPureIntro. eapply (mnat_included SI).
- apply auth_both_valid in Hv as [Hv _]; done.
- Qed.
-
- Lemma invariants_transfinite_nested γ l1 l2:
- {{{ L l1 γ ∗ R l2 γ }}} !#l1 {{{ (m: nat), RET #m; ⌜m > 0⌝ }}}.
- Proof.
- iIntros (ϕ) "[#L #R] H".
- (* we need to open all invariants to ensure that the value stored at l1 is positive *)
- wp_swp 2%nat.
- iInv "L" as "HL" "CloseL".
- iInv "R" as "HR" "CloseR".
- swp_step. iNext; simpl.
- iDestruct "HL" as (m) "[Hl1 Hγ●]". iDestruct "HR" as (l2') "[Hl2 #I]".
- iInv "I" as "HI" "CloseI".
- swp_step. iNext; simpl.
- iDestruct "HI" as (n) "(Hl2' & % & #Hγ◯)".
- iPoseProof (mnat_own with "Hγ● Hγ◯") as "%".
- wp_load.
- iMod ("CloseI" with "[Hl2']") as "_".
- { iExists n; iNext; iFrame; by iSplit. }
- iModIntro. iMod ("CloseR" with "[Hl2]") as "_".
- { iExists l2'; iNext; by iFrame. } iModIntro.
- iMod ("CloseL" with "[Hl1 Hγ●]") as "_"; first (iNext; iExists m; iFrame).
- iModIntro. iApply "H". iPureIntro. lia.
- Qed.
- End nested_invariants.
-
-
- Lemma invariants_swp k e φ P `{!Atomic StronglyAtomic e}:
- (P ⊢ SWP e at k @ ⊤∖↑N {{v, φ v ∗ P}}) → inv N P ⊢ SWP e at (S k) {{ v, φ v}}.
- Proof.
- iIntros (H) "I". iInv "I" as "P". swp_step. iNext.
- iPoseProof (H with "P") as "Q". iApply swp_wand_r.
- iFrame. iIntros (v) "($ & $)". by iModIntro.
- Qed.
-
-
-End how_to_handle_invariants.
diff --git a/theories/heap_lang/adequacy.v b/theories/heap_lang/adequacy.v
deleted file mode 100644
index eb1a8e0d..00000000
--- a/theories/heap_lang/adequacy.v
+++ /dev/null
@@ -1,38 +0,0 @@
-From iris.program_logic Require Export weakestpre adequacy.
-From iris.program_logic.refinement Require Export ref_weakestpre ref_adequacy tc_weakestpre.
-From iris.algebra Require Import auth.
-From iris.heap_lang Require Import proofmode notation.
-From iris.base_logic.lib Require Import proph_map.
-From iris.proofmode Require Import tactics.
-Set Default Proof Using "Type".
-
-Definition heapΣ SI : gFunctors SI := #[invΣ SI; gen_heapΣ loc val; proph_mapΣ proph_id (val * val)].
-Instance subG_heapPreG {SI} {Σ: gFunctors SI} : subG (heapΣ SI) Σ → heapPreG Σ.
-Proof. solve_inG. Qed.
-
-Definition heap_adequacy {SI} `{TransfiniteIndex SI} (Σ: gFunctors SI) `{!heapPreG Σ} s e σ φ :
- (∀ `{!heapG Σ}, sbi_emp_valid (WP e @ s; ⊤ {{ v, ⌜φ v⌝ }}%I)) →
- adequate s e σ (λ v _, φ v).
-Proof.
- intros Hwp; eapply (wp_adequacy _ _). iIntros (??) "".
- iMod (gen_heap_init σ.(heap)) as (?) "Hh".
- iMod (proph_map_init κs σ.(used_proph_id)) as (?) "Hp".
- iModIntro. iExists
- (λ σ κs, (gen_heap_ctx σ.(heap) ∗ proph_map_ctx κs σ.(used_proph_id))%I),
- (λ _, True%I).
- iFrame. iApply (Hwp (HeapG _ _ _ _ _)).
-Qed.
-
-
-Arguments satisfiable_at {_ _ _} _ _%I.
-Lemma satisfiable_at_add {SI} (Σ: gFunctors SI) `{!invG Σ} E P Q: satisfiable_at E P → sbi_emp_valid Q → satisfiable_at E (P ∗ Q).
-Proof.
- intros Hsat Hval. eapply satisfiable_at_mono; first eauto.
- iIntros "$". iApply Hval.
-Qed.
-
-Lemma satisfiable_at_add' {SI} (Σ: gFunctors SI) `{!invG Σ} E Q: satisfiable_at E True → sbi_emp_valid Q → satisfiable_at E Q.
-Proof.
- intros Hsat Hval. eapply satisfiable_at_mono; first eauto.
- iIntros "_". iApply Hval.
-Qed.
diff --git a/theories/heap_lang/lang.v b/theories/heap_lang/lang.v
deleted file mode 100644
index 723b6cbc..00000000
--- a/theories/heap_lang/lang.v
+++ /dev/null
@@ -1,769 +0,0 @@
-From iris.program_logic Require Export language ectx_language ectxi_language.
-From iris.heap_lang Require Export locations.
-From iris.algebra Require Export ofe.
-From stdpp Require Export binders strings.
-From stdpp Require Import gmap.
-Set Default Proof Using "Type".
-
-(** heap_lang. A fairly simple language used for common Iris examples.
-
-- This is a right-to-left evaluated language, like CakeML and OCaml. The reason
- for this is that it makes curried functions usable: Given a WP for [f a b], we
- know that any effects [f] might have to not matter until after *both* [a] and
- [b] are evaluated. With left-to-right evaluation, that triple is basically
- useless unless the user let-expands [b].
-
-- For prophecy variables, we annotate the reduction steps with an "observation"
- and tweak adequacy such that WP knows all future observations. There is
- another possible choice: Use non-deterministic choice when creating a prophecy
- variable ([NewProph]), and when resolving it ([Resolve]) make the
- program diverge unless the variable matches. That, however, requires an
- erasure proof that this endless loop does not make specifications useless.
-
-The expression [Resolve e p v] attaches a prophecy resolution (for prophecy
-variable [p] to value [v]) to the top-level head-reduction step of [e]. The
-prophecy resolution happens simultaneously with the head-step being taken.
-Furthermore, it is required that the head-step produces a value (otherwise
-the [Resolve] is stuck), and this value is also attached to the resolution.
-A prophecy variable is thus resolved to a pair containing (1) the result
-value of the wrapped expression (called [e] above), and (2) the value that
-was attached by the [Resolve] (called [v] above). This allows, for example,
-to distinguish a resolution originating from a successful [CmpXchg] from one
-originating from a failing [CmpXchg]. For example:
- - [Resolve (CmpXchg #l #n #(n+1)) #p v] will behave as [CmpXchg #l #n #(n+1)],
- which means step to a value-boole pair [(n', b)] while updating the heap, but
- in the meantime the prophecy variable [p] will be resolved to [(n', b), v)].
- - [Resolve (! #l) #p v] will behave as [! #l], that is return the value
- [w] pointed to by [l] on the heap (assuming it was allocated properly),
- but it will additionally resolve [p] to the pair [(w,v)].
-
-Note that the sub-expressions of [Resolve e p v] (i.e., [e], [p] and [v])
-are reduced as usual, from right to left. However, the evaluation of [e]
-is restricted so that the head-step to which the resolution is attached
-cannot be taken by the context. For example:
- - [Resolve (CmpXchg #l #n (#n + #1)) #p v] will first be reduced (with by a
- context-step) to [Resolve (CmpXchg #l #n #(n+1) #p v], and then behave as
- described above.
- - However, [Resolve ((λ: "n", CmpXchg #l "n" ("n" + #1)) #n) #p v] is stuck.
- Indeed, it can only be evaluated using a head-step (it is a β-redex),
- but the process does not yield a value.
-
-The mechanism described above supports nesting [Resolve] expressions to
-attach several prophecy resolutions to a head-redex. *)
-
-Delimit Scope expr_scope with E.
-Delimit Scope val_scope with V.
-
-Module heap_lang.
-Open Scope Z_scope.
-
-(** Expressions and vals. *)
-Definition proph_id := positive.
-
-Inductive base_lit : Set :=
- | LitInt (n : Z) | LitBool (b : bool) | LitUnit | LitErased
- | LitLoc (l : loc) | LitProphecy (p: proph_id).
-Inductive un_op : Set :=
- | NegOp | MinusUnOp.
-Inductive bin_op : Set :=
- | PlusOp | MinusOp | MultOp | QuotOp | RemOp (* Arithmetic *)
- | AndOp | OrOp | XorOp (* Bitwise *)
- | ShiftLOp | ShiftROp (* Shifts *)
- | LeOp | LtOp | EqOp (* Relations *)
- | OffsetOp. (* Pointer offset *)
-
-Inductive expr :=
- (* Values *)
- | Val (v : val)
- (* Base lambda calculus *)
- | Var (x : string)
- | Rec (f x : binder) (e : expr)
- | App (e1 e2 : expr)
- (* Base types and their operations *)
- | UnOp (op : un_op) (e : expr)
- | BinOp (op : bin_op) (e1 e2 : expr)
- | If (e0 e1 e2 : expr)
- (* Products *)
- | Pair (e1 e2 : expr)
- | Fst (e : expr)
- | Snd (e : expr)
- (* Sums *)
- | InjL (e : expr)
- | InjR (e : expr)
- | Case (e0 : expr) (e1 : expr) (e2 : expr)
- (* Concurrency *)
- | Fork (e : expr)
- (* Heap *)
- | AllocN (e1 e2 : expr) (* array length (positive number), initial value *)
- | Load (e : expr)
- | Store (e1 : expr) (e2 : expr)
- | CmpXchg (e0 : expr) (e1 : expr) (e2 : expr) (* Compare-exchange *)
- | FAA (e1 : expr) (e2 : expr) (* Fetch-and-add *)
- (* Prophecy *)
- | NewProph
- | Resolve (e0 : expr) (e1 : expr) (e2 : expr) (* wrapped expr, proph, val *)
-with val :=
- | LitV (l : base_lit)
- | RecV (f x : binder) (e : expr)
- | PairV (v1 v2 : val)
- | InjLV (v : val)
- | InjRV (v : val).
-
-Bind Scope expr_scope with expr.
-Bind Scope val_scope with val.
-
-(** An observation associates a prophecy variable (identifier) to a pair of
-values. The first value is the one that was returned by the (atomic) operation
-during which the prophecy resolution happened (typically, a boolean when the
-wrapped operation is a CmpXchg). The second value is the one that the prophecy
-variable was actually resolved to. *)
-Definition observation : Set := proph_id * (val * val).
-
-Notation of_val := Val (only parsing).
-
-Definition to_val (e : expr) : option val :=
- match e with
- | Val v => Some v
- | _ => None
- end.
-
-(** We assume the following encoding of values to 64-bit words: The least 3
-significant bits of every word are a "tag", and we have 61 bits of payload,
-which is enough if all pointers are 8-byte-aligned (common on 64bit
-architectures). The tags have the following meaning:
-
-0: Payload is the data for a LitV (LitInt _).
-1: Payload is the data for a InjLV (LitV (LitInt _)).
-2: Payload is the data for a InjRV (LitV (LitInt _)).
-3: Payload is the data for a LitV (LitLoc _).
-4: Payload is the data for a InjLV (LitV (LitLoc _)).
-4: Payload is the data for a InjRV (LitV (LitLoc _)).
-6: Payload is one of the following finitely many values, which 61 bits are more
- than enough to encode:
- LitV LitUnit, InjLV (LitV LitUnit), InjRV (LitV LitUnit),
- LitV (LitBool _), InjLV (LitV (LitBool _)), InjRV (LitV (LitBool _)).
-7: Value is boxed, i.e., payload is a pointer to some read-only memory area on
- the heap which stores whether this is a RecV, PairV, InjLV or InjRV and the
- relevant data for those cases. However, the boxed representation is never
- used if any of the above representations could be used.
-
-Ignoring (as usual) the fact that we have to fit the infinite Z/loc into 61
-bits, this means every value is machine-word-sized and can hence be atomically
-read and written. Also notice that the sets of boxed and unboxed values are
-disjoint. *)
-Definition lit_is_unboxed (l: base_lit) : Prop :=
- match l with
- (** Disallow comparing (erased) prophecies with (erased) prophecies, by
- considering them boxed. *)
- | LitProphecy _ | LitErased => False
- | _ => True
- end.
-Definition val_is_unboxed (v : val) : Prop :=
- match v with
- | LitV l => lit_is_unboxed l
- | InjLV (LitV l) => lit_is_unboxed l
- | InjRV (LitV l) => lit_is_unboxed l
- | _ => False
- end.
-
-Instance lit_is_unboxed_dec l : Decision (lit_is_unboxed l).
-Proof. destruct l; simpl; exact (decide _). Defined.
-Instance val_is_unboxed_dec v : Decision (val_is_unboxed v).
-Proof. destruct v as [ | | | [] | [] ]; simpl; exact (decide _). Defined.
-
-(** We just compare the word-sized representation of two values, without looking
-into boxed data. This works out fine if at least one of the to-be-compared
-values is unboxed (exploiting the fact that an unboxed and a boxed value can
-never be equal because these are disjoint sets). *)
-Definition vals_compare_safe (vl v1 : val) : Prop :=
- val_is_unboxed vl ∨ val_is_unboxed v1.
-Arguments vals_compare_safe !_ !_ /.
-
-(** The state: heaps of vals. *)
-Record state : Type := {
- heap: gmap loc val;
- used_proph_id: gset proph_id;
-}.
-
-(** Equality and other typeclass stuff *)
-Lemma to_of_val v : to_val (of_val v) = Some v.
-Proof. by destruct v. Qed.
-
-Lemma of_to_val e v : to_val e = Some v → of_val v = e.
-Proof. destruct e=>//=. by intros [= <-]. Qed.
-
-Instance of_val_inj : Inj (=) (=) of_val.
-Proof. intros ??. congruence. Qed.
-
-Instance base_lit_eq_dec : EqDecision base_lit.
-Proof. solve_decision. Defined.
-Instance un_op_eq_dec : EqDecision un_op.
-Proof. solve_decision. Defined.
-Instance bin_op_eq_dec : EqDecision bin_op.
-Proof. solve_decision. Defined.
-Instance expr_eq_dec : EqDecision expr.
-Proof.
- refine (
- fix go (e1 e2 : expr) {struct e1} : Decision (e1 = e2) :=
- match e1, e2 with
- | Val v, Val v' => cast_if (decide (v = v'))
- | Var x, Var x' => cast_if (decide (x = x'))
- | Rec f x e, Rec f' x' e' =>
- cast_if_and3 (decide (f = f')) (decide (x = x')) (decide (e = e'))
- | App e1 e2, App e1' e2' => cast_if_and (decide (e1 = e1')) (decide (e2 = e2'))
- | UnOp o e, UnOp o' e' => cast_if_and (decide (o = o')) (decide (e = e'))
- | BinOp o e1 e2, BinOp o' e1' e2' =>
- cast_if_and3 (decide (o = o')) (decide (e1 = e1')) (decide (e2 = e2'))
- | If e0 e1 e2, If e0' e1' e2' =>
- cast_if_and3 (decide (e0 = e0')) (decide (e1 = e1')) (decide (e2 = e2'))
- | Pair e1 e2, Pair e1' e2' =>
- cast_if_and (decide (e1 = e1')) (decide (e2 = e2'))
- | Fst e, Fst e' => cast_if (decide (e = e'))
- | Snd e, Snd e' => cast_if (decide (e = e'))
- | InjL e, InjL e' => cast_if (decide (e = e'))
- | InjR e, InjR e' => cast_if (decide (e = e'))
- | Case e0 e1 e2, Case e0' e1' e2' =>
- cast_if_and3 (decide (e0 = e0')) (decide (e1 = e1')) (decide (e2 = e2'))
- | Fork e, Fork e' => cast_if (decide (e = e'))
- | AllocN e1 e2, AllocN e1' e2' =>
- cast_if_and (decide (e1 = e1')) (decide (e2 = e2'))
- | Load e, Load e' => cast_if (decide (e = e'))
- | Store e1 e2, Store e1' e2' =>
- cast_if_and (decide (e1 = e1')) (decide (e2 = e2'))
- | CmpXchg e0 e1 e2, CmpXchg e0' e1' e2' =>
- cast_if_and3 (decide (e0 = e0')) (decide (e1 = e1')) (decide (e2 = e2'))
- | FAA e1 e2, FAA e1' e2' =>
- cast_if_and (decide (e1 = e1')) (decide (e2 = e2'))
- | NewProph, NewProph => left _
- | Resolve e0 e1 e2, Resolve e0' e1' e2' =>
- cast_if_and3 (decide (e0 = e0')) (decide (e1 = e1')) (decide (e2 = e2'))
- | _, _ => right _
- end
- with gov (v1 v2 : val) {struct v1} : Decision (v1 = v2) :=
- match v1, v2 with
- | LitV l, LitV l' => cast_if (decide (l = l'))
- | RecV f x e, RecV f' x' e' =>
- cast_if_and3 (decide (f = f')) (decide (x = x')) (decide (e = e'))
- | PairV e1 e2, PairV e1' e2' =>
- cast_if_and (decide (e1 = e1')) (decide (e2 = e2'))
- | InjLV e, InjLV e' => cast_if (decide (e = e'))
- | InjRV e, InjRV e' => cast_if (decide (e = e'))
- | _, _ => right _
- end
- for go); try (clear go gov; abstract intuition congruence).
-Defined.
-Instance val_eq_dec : EqDecision val.
-Proof. solve_decision. Defined.
-Instance state_eq_dec : EqDecision state.
-Proof. solve_decision. Defined.
-
-Instance base_lit_countable : Countable base_lit.
-Proof.
- refine (inj_countable' (λ l, match l with
- | LitInt n => (inl (inl n), None)
- | LitBool b => (inl (inr b), None)
- | LitUnit => (inr (inl false), None)
- | LitErased => (inr (inl true), None)
- | LitLoc l => (inr (inr l), None)
- | LitProphecy p => (inr (inl false), Some p)
- end) (λ l, match l with
- | (inl (inl n), None) => LitInt n
- | (inl (inr b), None) => LitBool b
- | (inr (inl false), None) => LitUnit
- | (inr (inl true), None) => LitErased
- | (inr (inr l), None) => LitLoc l
- | (_, Some p) => LitProphecy p
- end) _); by intros [].
-Qed.
-Instance un_op_finite : Countable un_op.
-Proof.
- refine (inj_countable' (λ op, match op with NegOp => 0 | MinusUnOp => 1 end)
- (λ n, match n with 0 => NegOp | _ => MinusUnOp end) _); by intros [].
-Qed.
-Instance bin_op_countable : Countable bin_op.
-Proof.
- refine (inj_countable' (λ op, match op with
- | PlusOp => 0 | MinusOp => 1 | MultOp => 2 | QuotOp => 3 | RemOp => 4
- | AndOp => 5 | OrOp => 6 | XorOp => 7 | ShiftLOp => 8 | ShiftROp => 9
- | LeOp => 10 | LtOp => 11 | EqOp => 12 | OffsetOp => 13
- end) (λ n, match n with
- | 0 => PlusOp | 1 => MinusOp | 2 => MultOp | 3 => QuotOp | 4 => RemOp
- | 5 => AndOp | 6 => OrOp | 7 => XorOp | 8 => ShiftLOp | 9 => ShiftROp
- | 10 => LeOp | 11 => LtOp | 12 => EqOp | _ => OffsetOp
- end) _); by intros [].
-Qed.
-Instance expr_countable : Countable expr.
-Proof.
- set (enc :=
- fix go e :=
- match e with
- | Val v => GenNode 0 [gov v]
- | Var x => GenLeaf (inl (inl x))
- | Rec f x e => GenNode 1 [GenLeaf (inl (inr f)); GenLeaf (inl (inr x)); go e]
- | App e1 e2 => GenNode 2 [go e1; go e2]
- | UnOp op e => GenNode 3 [GenLeaf (inr (inr (inl op))); go e]
- | BinOp op e1 e2 => GenNode 4 [GenLeaf (inr (inr (inr op))); go e1; go e2]
- | If e0 e1 e2 => GenNode 5 [go e0; go e1; go e2]
- | Pair e1 e2 => GenNode 6 [go e1; go e2]
- | Fst e => GenNode 7 [go e]
- | Snd e => GenNode 8 [go e]
- | InjL e => GenNode 9 [go e]
- | InjR e => GenNode 10 [go e]
- | Case e0 e1 e2 => GenNode 11 [go e0; go e1; go e2]
- | Fork e => GenNode 12 [go e]
- | AllocN e1 e2 => GenNode 13 [go e1; go e2]
- | Load e => GenNode 14 [go e]
- | Store e1 e2 => GenNode 15 [go e1; go e2]
- | CmpXchg e0 e1 e2 => GenNode 16 [go e0; go e1; go e2]
- | FAA e1 e2 => GenNode 17 [go e1; go e2]
- | NewProph => GenNode 18 []
- | Resolve e0 e1 e2 => GenNode 19 [go e0; go e1; go e2]
- end
- with gov v :=
- match v with
- | LitV l => GenLeaf (inr (inl l))
- | RecV f x e =>
- GenNode 0 [GenLeaf (inl (inr f)); GenLeaf (inl (inr x)); go e]
- | PairV v1 v2 => GenNode 1 [gov v1; gov v2]
- | InjLV v => GenNode 2 [gov v]
- | InjRV v => GenNode 3 [gov v]
- end
- for go).
- set (dec :=
- fix go e :=
- match e with
- | GenNode 0 [v] => Val (gov v)
- | GenLeaf (inl (inl x)) => Var x
- | GenNode 1 [GenLeaf (inl (inr f)); GenLeaf (inl (inr x)); e] => Rec f x (go e)
- | GenNode 2 [e1; e2] => App (go e1) (go e2)
- | GenNode 3 [GenLeaf (inr (inr (inl op))); e] => UnOp op (go e)
- | GenNode 4 [GenLeaf (inr (inr (inr op))); e1; e2] => BinOp op (go e1) (go e2)
- | GenNode 5 [e0; e1; e2] => If (go e0) (go e1) (go e2)
- | GenNode 6 [e1; e2] => Pair (go e1) (go e2)
- | GenNode 7 [e] => Fst (go e)
- | GenNode 8 [e] => Snd (go e)
- | GenNode 9 [e] => InjL (go e)
- | GenNode 10 [e] => InjR (go e)
- | GenNode 11 [e0; e1; e2] => Case (go e0) (go e1) (go e2)
- | GenNode 12 [e] => Fork (go e)
- | GenNode 13 [e1; e2] => AllocN (go e1) (go e2)
- | GenNode 14 [e] => Load (go e)
- | GenNode 15 [e1; e2] => Store (go e1) (go e2)
- | GenNode 16 [e0; e1; e2] => CmpXchg (go e0) (go e1) (go e2)
- | GenNode 17 [e1; e2] => FAA (go e1) (go e2)
- | GenNode 18 [] => NewProph
- | GenNode 19 [e0; e1; e2] => Resolve (go e0) (go e1) (go e2)
- | _ => Val $ LitV LitUnit (* dummy *)
- end
- with gov v :=
- match v with
- | GenLeaf (inr (inl l)) => LitV l
- | GenNode 0 [GenLeaf (inl (inr f)); GenLeaf (inl (inr x)); e] => RecV f x (go e)
- | GenNode 1 [v1; v2] => PairV (gov v1) (gov v2)
- | GenNode 2 [v] => InjLV (gov v)
- | GenNode 3 [v] => InjRV (gov v)
- | _ => LitV LitUnit (* dummy *)
- end
- for go).
- refine (inj_countable' enc dec _).
- refine (fix go (e : expr) {struct e} := _ with gov (v : val) {struct v} := _ for go).
- - destruct e as [v| | | | | | | | | | | | | | | | | | | |]; simpl; f_equal;
- [exact (gov v)|done..].
- - destruct v; by f_equal.
-Qed.
-Instance val_countable : Countable val.
-Proof. refine (inj_countable of_val to_val _); auto using to_of_val. Qed.
-
-Instance state_inhabited : Inhabited state :=
- populate {| heap := inhabitant; used_proph_id := inhabitant |}.
-Instance val_inhabited : Inhabited val := populate (LitV LitUnit).
-Instance expr_inhabited : Inhabited expr := populate (Val inhabitant).
-
-Canonical Structure stateO SI := leibnizO SI state.
-Canonical Structure locO SI := leibnizO SI loc.
-Canonical Structure valO SI := leibnizO SI val.
-Canonical Structure exprO SI := leibnizO SI expr.
-
-(** Evaluation contexts *)
-Inductive ectx_item :=
- | AppLCtx (v2 : val)
- | AppRCtx (e1 : expr)
- | UnOpCtx (op : un_op)
- | BinOpLCtx (op : bin_op) (v2 : val)
- | BinOpRCtx (op : bin_op) (e1 : expr)
- | IfCtx (e1 e2 : expr)
- | PairLCtx (v2 : val)
- | PairRCtx (e1 : expr)
- | FstCtx
- | SndCtx
- | InjLCtx
- | InjRCtx
- | CaseCtx (e1 : expr) (e2 : expr)
- | AllocNLCtx (v2 : val)
- | AllocNRCtx (e1 : expr)
- | LoadCtx
- | StoreLCtx (v2 : val)
- | StoreRCtx (e1 : expr)
- | CmpXchgLCtx (v1 : val) (v2 : val)
- | CmpXchgMCtx (e0 : expr) (v2 : val)
- | CmpXchgRCtx (e0 : expr) (e1 : expr)
- | FaaLCtx (v2 : val)
- | FaaRCtx (e1 : expr)
- | ResolveLCtx (ctx : ectx_item) (v1 : val) (v2 : val)
- | ResolveMCtx (e0 : expr) (v2 : val)
- | ResolveRCtx (e0 : expr) (e1 : expr).
-
-(** Contextual closure will only reduce [e] in [Resolve e (Val _) (Val _)] if
-the local context of [e] is non-empty. As a consequence, the first argument of
-[Resolve] is not completely evaluated (down to a value) by contextual closure:
-no head steps (i.e., surface reductions) are taken. This means that contextual
-closure will reduce [Resolve (CmpXchg #l #n (#n + #1)) #p #v] into [Resolve
-(CmpXchg #l #n #(n+1)) #p #v], but it cannot context-step any further. *)
-
-Fixpoint fill_item (Ki : ectx_item) (e : expr) : expr :=
- match Ki with
- | AppLCtx v2 => App e (of_val v2)
- | AppRCtx e1 => App e1 e
- | UnOpCtx op => UnOp op e
- | BinOpLCtx op v2 => BinOp op e (Val v2)
- | BinOpRCtx op e1 => BinOp op e1 e
- | IfCtx e1 e2 => If e e1 e2
- | PairLCtx v2 => Pair e (Val v2)
- | PairRCtx e1 => Pair e1 e
- | FstCtx => Fst e
- | SndCtx => Snd e
- | InjLCtx => InjL e
- | InjRCtx => InjR e
- | CaseCtx e1 e2 => Case e e1 e2
- | AllocNLCtx v2 => AllocN e (Val v2)
- | AllocNRCtx e1 => AllocN e1 e
- | LoadCtx => Load e
- | StoreLCtx v2 => Store e (Val v2)
- | StoreRCtx e1 => Store e1 e
- | CmpXchgLCtx v1 v2 => CmpXchg e (Val v1) (Val v2)
- | CmpXchgMCtx e0 v2 => CmpXchg e0 e (Val v2)
- | CmpXchgRCtx e0 e1 => CmpXchg e0 e1 e
- | FaaLCtx v2 => FAA e (Val v2)
- | FaaRCtx e1 => FAA e1 e
- | ResolveLCtx K v1 v2 => Resolve (fill_item K e) (Val v1) (Val v2)
- | ResolveMCtx ex v2 => Resolve ex e (Val v2)
- | ResolveRCtx ex e1 => Resolve ex e1 e
- end.
-
-(** Substitution *)
-Fixpoint subst (x : string) (v : val) (e : expr) : expr :=
- match e with
- | Val _ => e
- | Var y => if decide (x = y) then Val v else Var y
- | Rec f y e =>
- Rec f y $ if decide (BNamed x ≠ f ∧ BNamed x ≠ y) then subst x v e else e
- | App e1 e2 => App (subst x v e1) (subst x v e2)
- | UnOp op e => UnOp op (subst x v e)
- | BinOp op e1 e2 => BinOp op (subst x v e1) (subst x v e2)
- | If e0 e1 e2 => If (subst x v e0) (subst x v e1) (subst x v e2)
- | Pair e1 e2 => Pair (subst x v e1) (subst x v e2)
- | Fst e => Fst (subst x v e)
- | Snd e => Snd (subst x v e)
- | InjL e => InjL (subst x v e)
- | InjR e => InjR (subst x v e)
- | Case e0 e1 e2 => Case (subst x v e0) (subst x v e1) (subst x v e2)
- | Fork e => Fork (subst x v e)
- | AllocN e1 e2 => AllocN (subst x v e1) (subst x v e2)
- | Load e => Load (subst x v e)
- | Store e1 e2 => Store (subst x v e1) (subst x v e2)
- | CmpXchg e0 e1 e2 => CmpXchg (subst x v e0) (subst x v e1) (subst x v e2)
- | FAA e1 e2 => FAA (subst x v e1) (subst x v e2)
- | NewProph => NewProph
- | Resolve ex e1 e2 => Resolve (subst x v ex) (subst x v e1) (subst x v e2)
- end.
-
-Definition subst' (mx : binder) (v : val) : expr → expr :=
- match mx with BNamed x => subst x v | BAnon => id end.
-
-(** The stepping relation *)
-Definition un_op_eval (op : un_op) (v : val) : option val :=
- match op, v with
- | NegOp, LitV (LitBool b) => Some $ LitV $ LitBool (negb b)
- | NegOp, LitV (LitInt n) => Some $ LitV $ LitInt (Z.lnot n)
- | MinusUnOp, LitV (LitInt n) => Some $ LitV $ LitInt (- n)
- | _, _ => None
- end.
-
-Definition bin_op_eval_int (op : bin_op) (n1 n2 : Z) : option base_lit :=
- match op with
- | PlusOp => Some $ LitInt (n1 + n2)
- | MinusOp => Some $ LitInt (n1 - n2)
- | MultOp => Some $ LitInt (n1 * n2)
- | QuotOp => Some $ LitInt (n1 `quot` n2)
- | RemOp => Some $ LitInt (n1 `rem` n2)
- | AndOp => Some $ LitInt (Z.land n1 n2)
- | OrOp => Some $ LitInt (Z.lor n1 n2)
- | XorOp => Some $ LitInt (Z.lxor n1 n2)
- | ShiftLOp => Some $ LitInt (n1 ≪ n2)
- | ShiftROp => Some $ LitInt (n1 ≫ n2)
- | LeOp => Some $ LitBool (bool_decide (n1 ≤ n2))
- | LtOp => Some $ LitBool (bool_decide (n1 < n2))
- | EqOp => Some $ LitBool (bool_decide (n1 = n2))
- | OffsetOp => None (* Pointer arithmetic *)
- end.
-
-Definition bin_op_eval_bool (op : bin_op) (b1 b2 : bool) : option base_lit :=
- match op with
- | PlusOp | MinusOp | MultOp | QuotOp | RemOp => None (* Arithmetic *)
- | AndOp => Some (LitBool (b1 && b2))
- | OrOp => Some (LitBool (b1 || b2))
- | XorOp => Some (LitBool (xorb b1 b2))
- | ShiftLOp | ShiftROp => None (* Shifts *)
- | LeOp | LtOp => None (* InEquality *)
- | EqOp => Some (LitBool (bool_decide (b1 = b2)))
- | OffsetOp => None (* Pointer arithmetic *)
- end.
-
-Definition bin_op_eval (op : bin_op) (v1 v2 : val) : option val :=
- if decide (op = EqOp) then
- (* Crucially, this compares the same way as [CmpXchg]! *)
- if decide (vals_compare_safe v1 v2) then
- Some $ LitV $ LitBool $ bool_decide (v1 = v2)
- else
- None
- else
- match v1, v2 with
- | LitV (LitInt n1), LitV (LitInt n2) => LitV <$> bin_op_eval_int op n1 n2
- | LitV (LitBool b1), LitV (LitBool b2) => LitV <$> bin_op_eval_bool op b1 b2
- | LitV (LitLoc l), LitV (LitInt off) => Some $ LitV $ LitLoc (l +ₗ off)
- | _, _ => None
- end.
-
-Definition state_upd_heap (f: gmap loc val → gmap loc val) (σ: state) : state :=
- {| heap := f σ.(heap); used_proph_id := σ.(used_proph_id) |}.
-Arguments state_upd_heap _ !_ /.
-
-Definition state_upd_used_proph_id (f: gset proph_id → gset proph_id) (σ: state) : state :=
- {| heap := σ.(heap); used_proph_id := f σ.(used_proph_id) |}.
-Arguments state_upd_used_proph_id _ !_ /.
-
-Fixpoint heap_array (l : loc) (vs : list val) : gmap loc val :=
- match vs with
- | [] => ∅
- | v :: vs' => {[l := v]} ∪ heap_array (l +ₗ 1) vs'
- end.
-
-Lemma heap_array_singleton l v : heap_array l [v] = {[l := v]}.
-Proof. by rewrite /heap_array right_id. Qed.
-
-Lemma heap_array_lookup l vs w k :
- heap_array l vs !! k = Some w ↔
- ∃ j, 0 ≤ j ∧ k = l +ₗ j ∧ vs !! (Z.to_nat j) = Some w.
-Proof.
- revert k l; induction vs as [|v' vs IH]=> l' l /=.
- { rewrite lookup_empty. naive_solver lia. }
- rewrite -insert_union_singleton_l lookup_insert_Some IH. split.
- - intros [[-> ->] | (Hl & j & ? & -> & ?)].
- { exists 0. rewrite loc_add_0. naive_solver lia. }
- exists (1 + j). rewrite loc_add_assoc !Z.add_1_l Z2Nat.inj_succ; auto with lia.
- - intros (j & ? & -> & Hil). destruct (decide (j = 0)); simplify_eq/=.
- { rewrite loc_add_0; eauto. }
- right. split.
- { rewrite -{1}(loc_add_0 l). intros ?%(inj _); lia. }
- assert (Z.to_nat j = S (Z.to_nat (j - 1))) as Hj.
- { rewrite -Z2Nat.inj_succ; last lia. f_equal; lia. }
- rewrite Hj /= in Hil.
- exists (j - 1). rewrite loc_add_assoc Z.add_sub_assoc Z.add_simpl_l.
- auto with lia.
-Qed.
-
-Lemma heap_array_map_disjoint (h : gmap loc val) (l : loc) (vs : list val) :
- (∀ i, (0 ≤ i) → (i < length vs) → h !! (l +ₗ i) = None) →
- (heap_array l vs) ##ₘ h.
-Proof.
- intros Hdisj. apply map_disjoint_spec=> l' v1 v2.
- intros (j&?&->&Hj%lookup_lt_Some%inj_lt)%heap_array_lookup.
- move: Hj. rewrite Z2Nat.id // => ?. by rewrite Hdisj.
-Qed.
-
-(* [h] is added on the right here to make [state_init_heap_singleton] true. *)
-Definition state_init_heap (l : loc) (n : Z) (v : val) (σ : state) : state :=
- state_upd_heap (λ h, heap_array l (replicate (Z.to_nat n) v) ∪ h) σ.
-
-Lemma state_init_heap_singleton l v σ :
- state_init_heap l 1 v σ = state_upd_heap <[l:=v]> σ.
-Proof.
- destruct σ as [h p]. rewrite /state_init_heap /=. f_equiv.
- rewrite right_id insert_union_singleton_l. done.
-Qed.
-
-Inductive head_step : expr → state → list observation → expr → state → list expr → Prop :=
- | RecS f x e σ :
- head_step (Rec f x e) σ [] (Val $ RecV f x e) σ []
- | PairS v1 v2 σ :
- head_step (Pair (Val v1) (Val v2)) σ [] (Val $ PairV v1 v2) σ []
- | InjLS v σ :
- head_step (InjL $ Val v) σ [] (Val $ InjLV v) σ []
- | InjRS v σ :
- head_step (InjR $ Val v) σ [] (Val $ InjRV v) σ []
- | BetaS f x e1 v2 e' σ :
- e' = subst' x v2 (subst' f (RecV f x e1) e1) →
- head_step (App (Val $ RecV f x e1) (Val v2)) σ [] e' σ []
- | UnOpS op v v' σ :
- un_op_eval op v = Some v' →
- head_step (UnOp op (Val v)) σ [] (Val v') σ []
- | BinOpS op v1 v2 v' σ :
- bin_op_eval op v1 v2 = Some v' →
- head_step (BinOp op (Val v1) (Val v2)) σ [] (Val v') σ []
- | IfTrueS e1 e2 σ :
- head_step (If (Val $ LitV $ LitBool true) e1 e2) σ [] e1 σ []
- | IfFalseS e1 e2 σ :
- head_step (If (Val $ LitV $ LitBool false) e1 e2) σ [] e2 σ []
- | FstS v1 v2 σ :
- head_step (Fst (Val $ PairV v1 v2)) σ [] (Val v1) σ []
- | SndS v1 v2 σ :
- head_step (Snd (Val $ PairV v1 v2)) σ [] (Val v2) σ []
- | CaseLS v e1 e2 σ :
- head_step (Case (Val $ InjLV v) e1 e2) σ [] (App e1 (Val v)) σ []
- | CaseRS v e1 e2 σ :
- head_step (Case (Val $ InjRV v) e1 e2) σ [] (App e2 (Val v)) σ []
- | ForkS e σ:
- head_step (Fork e) σ [] (Val $ LitV LitUnit) σ [e]
- | AllocNS n v σ l :
- 0 < n →
- (∀ i, 0 ≤ i → i < n → σ.(heap) !! (l +ₗ i) = None) →
- head_step (AllocN (Val $ LitV $ LitInt n) (Val v)) σ
- []
- (Val $ LitV $ LitLoc l) (state_init_heap l n v σ)
- []
- | LoadS l v σ :
- σ.(heap) !! l = Some v →
- head_step (Load (Val $ LitV $ LitLoc l)) σ [] (of_val v) σ []
- | StoreS l v σ :
- is_Some (σ.(heap) !! l) →
- head_step (Store (Val $ LitV $ LitLoc l) (Val v)) σ
- []
- (Val $ LitV LitUnit) (state_upd_heap <[l:=v]> σ)
- []
- | CmpXchgS l v1 v2 vl σ b :
- σ.(heap) !! l = Some vl →
- (* Crucially, this compares the same way as [EqOp]! *)
- vals_compare_safe vl v1 →
- b = bool_decide (vl = v1) →
- head_step (CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2)) σ
- []
- (Val $ PairV vl (LitV $ LitBool b)) (if b then state_upd_heap <[l:=v2]> σ else σ)
- []
- | FaaS l i1 i2 σ :
- σ.(heap) !! l = Some (LitV (LitInt i1)) →
- head_step (FAA (Val $ LitV $ LitLoc l) (Val $ LitV $ LitInt i2)) σ
- []
- (Val $ LitV $ LitInt i1) (state_upd_heap <[l:=LitV (LitInt (i1 + i2))]>σ)
- []
- | NewProphS σ p :
- p ∉ σ.(used_proph_id) →
- head_step NewProph σ
- []
- (Val $ LitV $ LitProphecy p) (state_upd_used_proph_id (union {[ p ]}) σ)
- []
- | ResolveS p v e σ w σ' κs ts :
- head_step e σ κs (Val v) σ' ts →
- head_step (Resolve e (Val $ LitV $ LitProphecy p) (Val w)) σ
- (κs ++ [(p, (v, w))]) (Val v) σ' ts.
-
-(** Basic properties about the language *)
-Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki).
-Proof. induction Ki; intros ???; simplify_eq/=; auto with f_equal. Qed.
-
-Lemma fill_item_val Ki e :
- is_Some (to_val (fill_item Ki e)) → is_Some (to_val e).
-Proof. intros [v ?]. induction Ki; simplify_option_eq; eauto. Qed.
-
-Lemma val_head_stuck e1 σ1 κ e2 σ2 efs : head_step e1 σ1 κ e2 σ2 efs → to_val e1 = None.
-Proof. destruct 1; naive_solver. Qed.
-
-Lemma head_ctx_step_val Ki e σ1 κ e2 σ2 efs :
- head_step (fill_item Ki e) σ1 κ e2 σ2 efs → is_Some (to_val e).
-Proof. revert κ e2. induction Ki; inversion_clear 1; simplify_option_eq; eauto. Qed.
-
-Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 :
- to_val e1 = None → to_val e2 = None →
- fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2.
-Proof. revert Ki1. induction Ki2, Ki1; naive_solver eauto with f_equal. Qed.
-
-Lemma alloc_fresh v n σ :
- let l := fresh_locs (dom (gset loc) σ.(heap)) in
- 0 < n →
- head_step (AllocN ((Val $ LitV $ LitInt $ n)) (Val v)) σ []
- (Val $ LitV $ LitLoc l) (state_init_heap l n v σ) [].
-Proof.
- intros.
- apply AllocNS; first done.
- intros. apply (not_elem_of_dom (D := gset loc)).
- by apply fresh_locs_fresh.
-Qed.
-
-Lemma new_proph_id_fresh σ :
- let p := fresh σ.(used_proph_id) in
- head_step NewProph σ [] (Val $ LitV $ LitProphecy p) (state_upd_used_proph_id (union {[ p ]}) σ) [].
-Proof. constructor. apply is_fresh. Qed.
-
-Lemma heap_lang_mixin : EctxiLanguageMixin of_val to_val fill_item head_step.
-Proof.
- split; apply _ || eauto using to_of_val, of_to_val, val_head_stuck,
- fill_item_val, fill_item_no_val_inj, head_ctx_step_val.
-Qed.
-End heap_lang.
-
-(** Language *)
-Canonical Structure heap_ectxi_lang := EctxiLanguage heap_lang.heap_lang_mixin.
-Canonical Structure heap_ectx_lang := EctxLanguageOfEctxi heap_ectxi_lang.
-Canonical Structure heap_lang := LanguageOfEctx heap_ectx_lang.
-
-Global Instance cfg_eq_dec : EqDecision (cfg heap_lang).
-Proof. solve_decision. Defined.
-
-(* Prefer heap_lang names over ectx_language names. *)
-Export heap_lang.
-
-(* The following lemma is not provable using the axioms of [ectxi_language].
-The proof requires a case analysis over context items ([destruct i] on the
-last line), which in all cases yields a non-value. To prove this lemma for
-[ectxi_language] in general, we would require that a term of the form
-[fill_item i e] is never a value. *)
-Lemma to_val_fill_some K e v : to_val (fill K e) = Some v → K = [] ∧ e = Val v.
-Proof.
- intro H. destruct K as [|Ki K]; first by apply of_to_val in H. exfalso.
- assert (to_val e ≠ None) as He.
- { intro A. by rewrite fill_not_val in H. }
- assert (∃ w, e = Val w) as [w ->].
- { destruct e; try done; eauto. }
- assert (to_val (fill (Ki :: K) (Val w)) = None).
- { destruct Ki; simpl; apply fill_not_val; done. }
- by simplify_eq.
-Qed.
-
-Lemma to_val_fill_none e K: to_val e = None → to_val (fill K e) = None.
-Proof.
- intros H; destruct (to_val (fill K e)) eqn: Hval; auto.
- apply to_val_fill_some in Hval as [_ ->]. discriminate.
-Qed.
-
-Lemma prim_step_to_val_is_head_step e σ1 κs w σ2 efs :
- prim_step e σ1 κs (Val w) σ2 efs → head_step e σ1 κs (Val w) σ2 efs.
-Proof.
- intro H. destruct H as [K e1 e2 H1 H2].
- assert (to_val (fill K e2) = Some w) as H3; first by rewrite -H2.
- apply to_val_fill_some in H3 as [-> ->]. subst e. done.
-Qed.
-
-Lemma irreducible_resolve e v1 v2 σ :
- irreducible e σ → irreducible (Resolve e (Val v1) (Val v2)) σ.
-Proof.
- intros H κs ** [Ks e1' e2' Hfill -> step]. simpl in *.
- induction Ks as [|K Ks _] using rev_ind; simpl in Hfill.
- - subst e1'. inversion step. eapply H. by apply head_prim_step.
- - rewrite fill_app /= in Hfill.
- destruct K; (inversion Hfill; subst; clear Hfill; try
- match goal with | H : Val ?v = fill Ks ?e |- _ =>
- (assert (to_val (fill Ks e) = Some v) as HEq by rewrite -H //);
- apply to_val_fill_some in HEq; destruct HEq as [-> ->]; inversion step
- end).
- apply (H κs (fill_item K (foldl (flip fill_item) e2' Ks)) σ' efs).
- econstructor 1 with (K := Ks ++ [K]); last done; simpl; by rewrite fill_app.
-Qed.
diff --git a/theories/heap_lang/lifting.v b/theories/heap_lang/lifting.v
deleted file mode 100644
index 40d499bb..00000000
--- a/theories/heap_lang/lifting.v
+++ /dev/null
@@ -1,1349 +0,0 @@
-From iris.algebra Require Import auth gmap.
-From iris.base_logic Require Export gen_heap.
-From iris.base_logic.lib Require Export proph_map.
-From iris.program_logic Require Export weakestpre.
-From iris.program_logic Require Import ectx_lifting.
-From iris.program_logic.refinement Require Export ref_weakestpre.
-From iris.program_logic.refinement Require Import ref_ectx_lifting.
-From iris.heap_lang Require Export lang.
-From iris.heap_lang Require Import tactics notation.
-From iris.proofmode Require Import tactics.
-From stdpp Require Import fin_maps.
-Set Default Proof Using "Type".
-
-
-Class heapPreG {SI} (Σ: gFunctors SI) := HeapPreG {
- heap_preG_inv :> invPreG Σ;
- heap_preG_heap :> gen_heapPreG loc val Σ;
- heap_preG_proph :> proph_mapPreG proph_id (val * val) Σ
-}.
-
-
-Class heapG {SI} (Σ: gFunctors SI) := HeapG {
- heapG_invG : invG Σ;
- heapG_gen_heapG :> gen_heapG loc val Σ;
- heapG_proph_mapG :> proph_mapG proph_id (val * val) Σ
-}.
-
-Instance heapG_irisG {SI} {Σ: gFunctors SI} `{!heapG Σ} : irisG heap_lang Σ := {
- iris_invG := heapG_invG;
- state_interp σ κs _ :=
- (gen_heap_ctx σ.(heap) ∗ proph_map_ctx κs σ.(used_proph_id))%I;
- fork_post _ := True%I;
-}.
-
-Instance heapG_ref_irisG {SI} {Σ: gFunctors SI} `{!heapG Σ} : ref_irisG heap_lang Σ := {
- ref_state_interp σ _ := (gen_heap_ctx σ.(heap))%I;
- ref_fork_post _ := True%I;
-}.
-
-(** 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") : bi_scope.
-Notation "l ↦ v" :=
- (mapsto (L:=loc) (V:=val) l 1 v%V) (at level 20) : bi_scope.
-Notation "l ↦{ q } -" := (∃ v, l ↦{q} v)%I
- (at level 20, q at level 50, format "l ↦{ q } -") : bi_scope.
-Notation "l ↦ -" := (l ↦{1} -)%I (at level 20) : bi_scope.
-
-Definition array {SI} {Σ: gFunctors SI} `{!heapG Σ} (l : loc) (vs : list val) : iProp Σ :=
- ([∗ list] i ↦ v ∈ vs, (l +ₗ i) ↦ v)%I.
-Notation "l ↦∗ vs" := (array l vs)
- (at level 20, format "l ↦∗ vs") : bi_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
-operations. This tactic is slightly ad-hoc and tuned for proving our lifting
-lemmas. *)
-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 : head_step ?e _ _ _ _ _ |- _ =>
- try (is_var e; fail 1); (* inversion yields many goals if [e] is a variable
- and can thus better be avoided. *)
- inversion H; subst; clear H
- end.
-
-Local Hint Extern 0 (head_reducible _ _) => eexists _, _, _, _; simpl : core.
-Local Hint Extern 0 (head_reducible_no_obs _ _) => eexists _, _, _; simpl : core.
-
-(* [simpl apply] is too stupid, so we need extern hints here. *)
-Local Hint Extern 1 (head_step _ _ _ _ _ _) => econstructor : core.
-Local Hint Extern 0 (head_step (CmpXchg _ _ _) _ _ _ _ _) => eapply CmpXchgS : core.
-Local Hint Extern 0 (head_step (AllocN _ _) _ _ _ _ _) => apply alloc_fresh : core.
-Local Hint Extern 0 (head_step NewProph _ _ _ _ _) => apply new_proph_id_fresh : core.
-Local Hint Resolve to_of_val : core.
-
-Instance into_val_val v : IntoVal (Val v) v.
-Proof. done. Qed.
-Instance as_val_val v : AsVal (Val v).
-Proof. by eexists. Qed.
-
-Local Ltac solve_atomic :=
- apply strongly_atomic_atomic, ectx_language_atomic;
- [inversion 1; naive_solver
- |apply ectxi_language_sub_redexes_are_values; intros [] **; naive_solver].
-
-Instance alloc_atomic s v w : Atomic s (AllocN (Val v) (Val w)).
-Proof. solve_atomic. Qed.
-Instance load_atomic s v : Atomic s (Load (Val v)).
-Proof. solve_atomic. Qed.
-Instance store_atomic s v1 v2 : Atomic s (Store (Val v1) (Val v2)).
-Proof. solve_atomic. Qed.
-Instance cmpxchg_atomic s v0 v1 v2 : Atomic s (CmpXchg (Val v0) (Val v1) (Val v2)).
-Proof. solve_atomic. Qed.
-Instance faa_atomic s v1 v2 : Atomic s (FAA (Val v1) (Val v2)).
-Proof. solve_atomic. Qed.
-Instance fork_atomic s e : Atomic s (Fork e).
-Proof. solve_atomic. Qed.
-Instance skip_atomic s : Atomic s Skip.
-Proof. solve_atomic. Qed.
-Instance new_proph_atomic s : Atomic s NewProph.
-Proof. solve_atomic. Qed.
-Instance binop_atomic s op v1 v2 : Atomic s (BinOp op (Val v1) (Val v2)).
-Proof. solve_atomic. Qed.
-
-Instance proph_resolve_atomic s e v1 v2 :
- Atomic s e → Atomic s (Resolve e (Val v1) (Val v2)).
-Proof.
- rename e into e1. intros H σ1 e2 κ σ2 efs [Ks e1' e2' Hfill -> step].
- simpl in *. induction Ks as [|K Ks _] using rev_ind; simpl in Hfill.
- - subst. inversion_clear step. by apply (H σ1 (Val v) κs σ2 efs), head_prim_step.
- - rewrite fill_app. rewrite fill_app in Hfill.
- assert (∀ v, Val v = fill Ks e1' → False) as fill_absurd.
- { intros v Hv. assert (to_val (fill Ks e1') = Some v) as Htv by by rewrite -Hv.
- apply to_val_fill_some in Htv. destruct Htv as [-> ->]. inversion step. }
- destruct K; (inversion Hfill; clear Hfill; subst; try
- match goal with | H : Val ?v = fill Ks e1' |- _ => by apply fill_absurd in H end).
- refine (_ (H σ1 (fill (Ks ++ [K]) e2') _ σ2 efs _)).
- + destruct s; intro Hs; simpl in *.
- * destruct Hs as [v Hs]. apply to_val_fill_some in Hs. by destruct Hs, Ks.
- * apply irreducible_resolve. by rewrite fill_app in Hs.
- + econstructor 1 with (K := Ks ++ [K]); try done. simpl. by rewrite fill_app.
-Qed.
-
-Instance resolve_proph_atomic s v1 v2 : Atomic s (ResolveProph (Val v1) (Val v2)).
-Proof. by apply proph_resolve_atomic, skip_atomic. Qed.
-
-Local Ltac solve_exec_safe := intros; subst; do 3 eexists; econstructor; eauto.
-Local Ltac solve_exec_puredet := simpl; intros; by inv_head_step.
-Local Ltac solve_pure_exec :=
- subst; intros ?; apply nsteps_once, pure_head_step_pure_step;
- constructor; [solve_exec_safe | solve_exec_puredet].
-
-(** The behavior of the various [wp_] tactics with regard to lambda differs in
-the following way:
-
-- [wp_pures] does *not* reduce lambdas/recs that are hidden behind a definition.
-- [wp_rec] and [wp_lam] reduce lambdas/recs that are hidden behind a definition.
-
-To realize this behavior, we define the class [AsRecV v f x erec], which takes a
-value [v] as its input, and turns it into a [RecV f x erec] via the instance
-[AsRecV_recv : AsRecV (RecV f x e) f x e]. We register this instance via
-[Hint Extern] so that it is only used if [v] is syntactically a lambda/rec, and
-not if [v] contains a lambda/rec that is hidden behind a definition.
-
-To make sure that [wp_rec] and [wp_lam] do reduce lambdas/recs that are hidden
-behind a definition, we activate [AsRecV_recv] by hand in these tactics. *)
-Class AsRecV (v : val) (f x : binder) (erec : expr) :=
- as_recv : v = RecV f x erec.
-Hint Mode AsRecV ! - - - : typeclass_instances.
-Definition AsRecV_recv f x e : AsRecV (RecV f x e) f x e := eq_refl.
-Hint Extern 0 (AsRecV (RecV _ _ _) _ _ _) =>
- apply AsRecV_recv : typeclass_instances.
-
-Instance pure_recc f x (erec : expr) :
- PureExec True 1 (Rec f x erec) (Val $ RecV f x erec).
-Proof. solve_pure_exec. Qed.
-Instance pure_pairc (v1 v2 : val) :
- PureExec True 1 (Pair (Val v1) (Val v2)) (Val $ PairV v1 v2).
-Proof. solve_pure_exec. Qed.
-Instance pure_injlc (v : val) :
- PureExec True 1 (InjL $ Val v) (Val $ InjLV v).
-Proof. solve_pure_exec. Qed.
-Instance pure_injrc (v : val) :
- PureExec True 1 (InjR $ Val v) (Val $ InjRV v).
-Proof. solve_pure_exec. Qed.
-
-Instance pure_beta f x (erec : expr) (v1 v2 : val) `{!AsRecV v1 f x erec} :
- PureExec True 1 (App (Val v1) (Val v2)) (subst' x v2 (subst' f v1 erec)).
-Proof. unfold AsRecV in *. solve_pure_exec. Qed.
-
-Instance pure_unop op v v' :
- PureExec (un_op_eval op v = Some v') 1 (UnOp op (Val v)) (Val v').
-Proof. solve_pure_exec. Qed.
-
-Instance pure_binop op v1 v2 v' :
- PureExec (bin_op_eval op v1 v2 = Some v') 1 (BinOp op (Val v1) (Val v2)) (Val v') | 10.
-Proof. solve_pure_exec. Qed.
-(* Higher-priority instance for EqOp. *)
-Instance pure_eqop v1 v2 :
- PureExec (vals_compare_safe v1 v2) 1
- (BinOp EqOp (Val v1) (Val v2))
- (Val $ LitV $ LitBool $ bool_decide (v1 = v2)) | 1.
-Proof.
- intros Hcompare.
- cut (bin_op_eval EqOp v1 v2 = Some $ LitV $ LitBool $ bool_decide (v1 = v2)).
- { intros. revert Hcompare. solve_pure_exec. }
- rewrite /bin_op_eval /= decide_True //.
-Qed.
-
-Instance pure_if_true e1 e2 : PureExec True 1 (If (Val $ LitV $ LitBool true) e1 e2) e1.
-Proof. solve_pure_exec. Qed.
-
-Instance pure_if_false e1 e2 : PureExec True 1 (If (Val $ LitV $ LitBool false) e1 e2) e2.
-Proof. solve_pure_exec. Qed.
-
-Instance pure_fst v1 v2 :
- PureExec True 1 (Fst (Val $ PairV v1 v2)) (Val v1).
-Proof. solve_pure_exec. Qed.
-
-Instance pure_snd v1 v2 :
- PureExec True 1 (Snd (Val $ PairV v1 v2)) (Val v2).
-Proof. solve_pure_exec. Qed.
-
-Instance pure_case_inl v e1 e2 :
- PureExec True 1 (Case (Val $ InjLV v) e1 e2) (App e1 (Val v)).
-Proof. solve_pure_exec. Qed.
-
-Instance pure_case_inr v e1 e2 :
- PureExec True 1 (Case (Val $ InjRV v) e1 e2) (App e2 (Val v)).
-Proof. solve_pure_exec. Qed.
-
-Section lifting.
-Context {SI} {Σ: gFunctors SI} `{!heapG Σ}.
-Implicit Types P Q : iProp Σ.
-Implicit Types Φ : val → iProp Σ.
-Implicit Types efs : list expr.
-Implicit Types σ : state.
-Implicit Types v : val.
-Implicit Types vs : list val.
-Implicit Types l : loc.
-Implicit Types sz off : nat.
-
-(** Fork: Not using Texan triples to avoid some unnecessary [True] *)
-Lemma wp_fork s E e Φ :
- ▷ WP e @ s; ⊤ {{ _, True }} -∗ ▷ Φ (LitV LitUnit) -∗ WP Fork e @ s; E {{ Φ }}.
-Proof.
- iIntros "He HΦ". iApply wp_lift_atomic_head_step; [done|].
- iIntros (σ1 κ κs n) "Hσ !>"; iSplit; first by eauto.
- iNext; iIntros (v2 σ2 efs Hstep); inv_head_step. by iFrame.
-Qed.
-Lemma swp_fork k s E e Φ :
- ▷ WP e @ s; ⊤ {{ _, True }} -∗ ▷ Φ (LitV LitUnit) -∗ SWP Fork e at k @ s; E {{ Φ }}.
-Proof.
- iIntros "He HΦ". iApply swp_lift_atomic_head_step.
- iIntros (σ1 κ κs n) "Hσ !>"; iSplit; first by eauto.
- iNext; iIntros (v2 σ2 efs Hstep); inv_head_step. by iFrame.
-Qed.
-(*
-Lemma twp_fork s E e Φ :
- WP e @ s; ⊤ [{ _, True }] -∗ Φ (LitV LitUnit) -∗ WP Fork e @ s; E [{ Φ }].
-Proof.
- iIntros "He HΦ". iApply twp_lift_atomic_head_step; [done|].
- iIntros (σ1 κs n) "Hσ !>"; iSplit; first by eauto.
- iIntros (κ v2 σ2 efs Hstep); inv_head_step. by iFrame.
-Qed.
- *)
-
-Lemma array_nil l : l ↦∗ [] ⊣⊢ emp.
-Proof. by rewrite /array. Qed.
-
-Lemma array_singleton l v : l ↦∗ [v] ⊣⊢ l ↦ v.
-Proof. by rewrite /array /= right_id loc_add_0. Qed.
-
-Lemma array_app l vs ws :
- l ↦∗ (vs ++ ws) ⊣⊢ l ↦∗ vs ∗ (l +ₗ length vs) ↦∗ ws.
-Proof.
- rewrite /array big_sepL_app.
- setoid_rewrite Nat2Z.inj_add.
- by setoid_rewrite loc_add_assoc.
-Qed.
-
-Lemma array_cons l v vs : l ↦∗ (v :: vs) ⊣⊢ l ↦ v ∗ (l +ₗ 1) ↦∗ vs.
-Proof.
- rewrite /array big_sepL_cons loc_add_0.
- setoid_rewrite loc_add_assoc.
- setoid_rewrite Nat2Z.inj_succ.
- by setoid_rewrite Z.add_1_l.
-Qed.
-
-Lemma heap_array_to_array l vs :
- ([∗ map] l' ↦ v ∈ heap_array l vs, l' ↦ v) -∗ l ↦∗ vs.
-Proof.
- iIntros "Hvs". iInduction vs as [|v vs] "IH" forall (l); simpl.
- { by rewrite /array. }
- rewrite big_opM_union; last first.
- { apply map_disjoint_spec=> l' v1 v2 /lookup_singleton_Some [-> _].
- intros (j&?&Hjl&_)%heap_array_lookup.
- rewrite loc_add_assoc -{1}[l']loc_add_0 in Hjl. simplify_eq; lia. }
- rewrite array_cons.
- rewrite big_opM_singleton; iDestruct "Hvs" as "[$ Hvs]".
- by iApply "IH".
-Qed.
-
-Lemma heap_array_to_seq_meta l vs n :
- length vs = n →
- ([∗ map] l' ↦ _ ∈ heap_array l vs, meta_token l' ⊤) -∗
- [∗ list] i ∈ seq 0 n, meta_token (l +ₗ (i : nat)) ⊤.
-Proof.
- iIntros (<-) "Hvs". iInduction vs as [|v vs] "IH" forall (l)=> //=.
- rewrite big_opM_union; last first.
- { apply map_disjoint_spec=> l' v1 v2 /lookup_singleton_Some [-> _].
- intros (j&?&Hjl&_)%heap_array_lookup.
- rewrite loc_add_assoc -{1}[l']loc_add_0 in Hjl. simplify_eq; lia. }
- rewrite loc_add_0 -fmap_S_seq big_sepL_fmap.
- setoid_rewrite Nat2Z.inj_succ. setoid_rewrite <-Z.add_1_l.
- setoid_rewrite <-loc_add_assoc.
- rewrite big_opM_singleton; iDestruct "Hvs" as "[$ Hvs]". by iApply "IH".
-Qed.
-
-Lemma update_array l vs off v :
- vs !! off = Some v →
- sbi_emp_valid (l ↦∗ vs -∗ ((l +ₗ off) ↦ v ∗ ∀ v', (l +ₗ off) ↦ v' -∗ l ↦∗ <[off:=v']>vs))%I.
-Proof.
- iIntros (Hlookup) "Hl".
- rewrite -[X in (l ↦∗ X)%I](take_drop_middle _ off v); last done.
- iDestruct (array_app with "Hl") as "[Hl1 Hl]".
- iDestruct (array_cons with "Hl") as "[Hl2 Hl3]".
- assert (off < length vs)%nat as H by (apply lookup_lt_is_Some; by eexists).
- rewrite take_length min_l; last by lia. iFrame "Hl2".
- iIntros (w) "Hl2".
- clear Hlookup. assert (<[off:=w]> vs !! off = Some w) as Hlookup.
- { apply list_lookup_insert. lia. }
- rewrite -[in (l ↦∗ <[off:=w]> vs)%I](take_drop_middle (<[off:=w]> vs) off w Hlookup).
- iApply array_app. rewrite take_insert; last by lia. iFrame.
- iApply array_cons. rewrite take_length min_l; last by lia. iFrame.
- rewrite drop_insert; last by lia. done.
-Qed.
-
-(** Heap *)
-Lemma wp_allocN s E v n :
- 0 < n →
- {{{ True }}} AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E
- {{{ l, RET LitV (LitLoc l); l ↦∗ replicate (Z.to_nat n) v ∗
- [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ }}}.
-Proof.
- iIntros (Hn Φ) "_ HΦ". iApply wp_lift_atomic_head_step_no_fork; auto.
- iIntros (σ1 κ κs k) "[Hσ Hκs] !>"; iSplit; first by auto with lia.
- iNext; iIntros (v2 σ2 efs Hstep); inv_head_step.
- iMod (@gen_heap_alloc_gen with "Hσ") as "(Hσ & Hl & Hm)".
- { apply (heap_array_map_disjoint _ l (replicate (Z.to_nat n) v)); eauto.
- rewrite replicate_length Z2Nat.id; auto with lia. }
- iModIntro; iSplit; first done. iFrame "Hσ Hκs". iApply "HΦ". iSplitL "Hl".
- - by iApply heap_array_to_array.
- - iApply (heap_array_to_seq_meta with "Hm"). by rewrite replicate_length.
-Qed.
-Lemma swp_allocN k s E v n :
- 0 < n →
- {{{ True }}} AllocN (Val $ LitV $ LitInt $ n) (Val v) at k @ s; E
- {{{ l, RET LitV (LitLoc l); l ↦∗ replicate (Z.to_nat n) v ∗
- [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ }}}.
-Proof.
- iIntros (Hn Φ) "_ HΦ". iApply swp_lift_atomic_head_step_no_fork.
- iIntros (σ1 κ κs k') "[Hσ Hκs] !>"; iSplit; first by auto with lia.
- iNext; iIntros (v2 σ2 efs Hstep); inv_head_step.
- iMod (@gen_heap_alloc_gen with "Hσ") as "(Hσ & Hl & Hm)".
- { apply (heap_array_map_disjoint _ l (replicate (Z.to_nat n) v)); eauto.
- rewrite replicate_length Z2Nat.id; auto with lia. }
- iModIntro; iSplit; first done. iFrame "Hσ Hκs". iApply "HΦ". iSplitL "Hl".
- - by iApply heap_array_to_array.
- - iApply (heap_array_to_seq_meta with "Hm"). by rewrite replicate_length.
-Qed.
-
-(*Lemma twp_allocN s E v n :
- 0 < n →
- [[{ True }]] AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E
- [[{ l, RET LitV (LitLoc l); l ↦∗ replicate (Z.to_nat n) v ∗
- [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ }]].
-Proof.
- iIntros (Hn Φ) "_ HΦ". iApply twp_lift_atomic_head_step_no_fork; auto.
- iIntros (σ1 κs k) "[Hσ Hκs] !>"; iSplit; first by destruct n; auto with lia.
- iIntros (κ v2 σ2 efs Hstep); inv_head_step.
- iMod (@gen_heap_alloc_gen with "Hσ") as "(Hσ & Hl & Hm)".
- { apply (heap_array_map_disjoint _ l (replicate (Z.to_nat n) v)); eauto.
- rewrite replicate_length Z2Nat.id; auto with lia. }
- iModIntro; do 2 (iSplit; first done). iFrame "Hσ Hκs". iApply "HΦ". iSplitL "Hl".
- - by iApply heap_array_to_array.
- - iApply (heap_array_to_seq_meta with "Hm"). by rewrite replicate_length.
-Qed.*)
-
-Lemma wp_alloc s E v :
- {{{ True }}} Alloc (Val v) @ s; E {{{ l, RET LitV (LitLoc l); l ↦ v ∗ meta_token l ⊤ }}}.
-Proof.
- iIntros (Φ) "_ HΦ". iApply wp_allocN; auto with lia.
- iIntros "!>" (l) "/= (? & ? & _)".
- rewrite array_singleton loc_add_0. iApply "HΦ"; iFrame.
-Qed.
-Lemma swp_alloc k s E v :
- {{{ True }}} Alloc (Val v) at k @ s; E {{{ l, RET LitV (LitLoc l); l ↦ v ∗ meta_token l ⊤ }}}.
-Proof.
- iIntros (Φ) "_ HΦ". iApply swp_allocN; auto with lia.
- iIntros "!>" (l) "/= (? & ? & _)".
- rewrite array_singleton loc_add_0. iApply "HΦ"; iFrame.
-Qed.
-
-(*Lemma twp_alloc s E v :
- [[{ True }]] Alloc (Val v) @ s; E [[{ l, RET LitV (LitLoc l); l ↦ v ∗ meta_token l ⊤ }]].
-Proof.
- iIntros (Φ) "_ HΦ". iApply twp_allocN; auto with lia.
- iIntros (l) "/= (? & ? & _)".
- rewrite array_singleton loc_add_0. iApply "HΦ"; iFrame.
-Qed.*)
-
-Lemma wp_load s E l q v :
- {{{ ▷ l ↦{q} v }}} Load (Val $ LitV $ LitLoc l) @ s; E {{{ RET v; l ↦{q} v }}}.
-Proof.
- iIntros (Φ) ">Hl HΦ". iApply wp_lift_atomic_head_step_no_fork; auto.
- iIntros (σ1 κ κs n) "[Hσ Hκs] !>". 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 swp_load k s E l q v :
- {{{ ▷ l ↦{q} v }}} Load (Val $ LitV $ LitLoc l) at k @ s; E {{{ RET v; l ↦{q} v }}}.
-Proof.
- iIntros (Φ) ">Hl HΦ". iApply swp_lift_atomic_head_step_no_fork.
- iIntros (σ1 κ κs n) "[Hσ Hκs] !>". 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 twp_load s E l q v :
- [[{ l ↦{q} v }]] Load (Val $ LitV $ LitLoc l) @ s; E [[{ RET v; l ↦{q} v }]].
-Proof.
- iIntros (Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; auto.
- iIntros (σ1 κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
- iSplit; first by eauto. iIntros (κ v2 σ2 efs Hstep); inv_head_step.
- iModIntro; iSplit=> //. iSplit; first done. iFrame. by iApply "HΦ".
-Qed.*)
-
-Lemma wp_store s E l v' v :
- {{{ ▷ l ↦ v' }}} Store (Val $ LitV (LitLoc l)) (Val v) @ s; E
- {{{ RET LitV LitUnit; l ↦ v }}}.
-Proof.
- iIntros (Φ) ">Hl HΦ".
- iApply wp_lift_atomic_head_step_no_fork; auto.
- iIntros (σ1 κ κs n) "[Hσ Hκs] !>". 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=>//. iFrame. by iApply "HΦ".
-Qed.
-Lemma swp_store k s E l v' v :
- {{{ ▷ l ↦ v' }}} Store (Val $ LitV (LitLoc l)) (Val v) at k @ s; E
- {{{ RET LitV LitUnit; l ↦ v }}}.
-Proof.
- iIntros (Φ) ">Hl HΦ".
- iApply swp_lift_atomic_head_step_no_fork.
- iIntros (σ1 κ κs n) "[Hσ Hκs] !>". 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=>//. iFrame. by iApply "HΦ".
-Qed.
-
-(*Lemma twp_store s E l v' v :
- [[{ l ↦ v' }]] Store (Val $ LitV $ LitLoc l) (Val v) @ s; E
- [[{ RET LitV LitUnit; l ↦ v }]].
-Proof.
- iIntros (Φ) "Hl HΦ".
- iApply twp_lift_atomic_head_step_no_fork; auto.
- iIntros (σ1 κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
- iSplit; first by eauto. iIntros (κ v2 σ2 efs Hstep); inv_head_step.
- iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
- iModIntro. iSplit=>//. iSplit; first done. iFrame. by iApply "HΦ".
-Qed.*)
-
-Lemma wp_cmpxchg_fail s E l q v' v1 v2 :
- v' ≠ v1 → vals_compare_safe v' v1 →
- {{{ ▷ l ↦{q} v' }}} CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) @ s; E
- {{{ RET PairV v' (LitV $ LitBool false); l ↦{q} v' }}}.
-Proof.
- iIntros (?? Φ) ">Hl HΦ". iApply wp_lift_atomic_head_step_no_fork; auto.
- iIntros (σ1 κ κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
- iSplit; first by eauto. iNext; iIntros (v2' σ2 efs Hstep); inv_head_step.
- rewrite bool_decide_false //.
- iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
-Qed.
-Lemma swp_cmpxchg_fail k s E l q v' v1 v2 :
- v' ≠ v1 → vals_compare_safe v' v1 →
- {{{ ▷ l ↦{q} v' }}} CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) at k @ s; E
- {{{ RET PairV v' (LitV $ LitBool false); l ↦{q} v' }}}.
-Proof.
- iIntros (?? Φ) ">Hl HΦ". iApply swp_lift_atomic_head_step_no_fork.
- iIntros (σ1 κ κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
- iSplit; first by eauto. iNext; iIntros (v2' σ2 efs Hstep); inv_head_step.
- rewrite bool_decide_false //.
- iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
-Qed.
-(*Lemma twp_cmpxchg_fail s E l q v' v1 v2 :
- v' ≠ v1 → vals_compare_safe v' v1 →
- [[{ l ↦{q} v' }]] CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) @ s; E
- [[{ RET PairV v' (LitV $ LitBool false); l ↦{q} v' }]].
-Proof.
- iIntros (?? Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; auto.
- iIntros (σ1 κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
- iSplit; first by eauto. iIntros (κ v2' σ2 efs Hstep); inv_head_step.
- rewrite bool_decide_false //.
- iModIntro; iSplit=> //. iSplit; first done. iFrame. by iApply "HΦ".
-Qed.*)
-
-Lemma wp_cmpxchg_suc s E l v1 v2 v' :
- v' = v1 → vals_compare_safe v' v1 →
- {{{ ▷ l ↦ v' }}} CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) @ s; E
- {{{ RET PairV v' (LitV $ LitBool true); l ↦ v2 }}}.
-Proof.
- iIntros (?? Φ) ">Hl HΦ". iApply wp_lift_atomic_head_step_no_fork; auto.
- iIntros (σ1 κ κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
- iSplit; first by eauto. iNext; iIntros (v2' σ2 efs Hstep); inv_head_step.
- rewrite bool_decide_true //.
- iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
- iModIntro. iSplit=>//. iFrame. by iApply "HΦ".
-Qed.
-Lemma swp_cmpxchg_suc k s E l v1 v2 v' :
- v' = v1 → vals_compare_safe v' v1 →
- {{{ ▷ l ↦ v' }}} CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) at k @ s; E
- {{{ RET PairV v' (LitV $ LitBool true); l ↦ v2 }}}.
-Proof.
- iIntros (?? Φ) ">Hl HΦ". iApply swp_lift_atomic_head_step_no_fork.
- iIntros (σ1 κ κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
- iSplit; first by eauto. iNext; iIntros (v2' σ2 efs Hstep); inv_head_step.
- rewrite bool_decide_true //.
- iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
- iModIntro. iSplit=>//. iFrame. by iApply "HΦ".
-Qed.
-(*Lemma twp_cmpxchg_suc s E l v1 v2 v' :
- v' = v1 → vals_compare_safe v' v1 →
- [[{ l ↦ v' }]] CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) @ s; E
- [[{ RET PairV v' (LitV $ LitBool true); l ↦ v2 }]].
-Proof.
- iIntros (?? Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; auto.
- iIntros (σ1 κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
- iSplit; first by eauto. iIntros (κ v2' σ2 efs Hstep); inv_head_step.
- rewrite bool_decide_true //.
- iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
- iModIntro. iSplit=>//. iSplit; first done. iFrame. by iApply "HΦ".
-Qed.*)
-
-Lemma wp_faa s E l i1 i2 :
- {{{ ▷ l ↦ LitV (LitInt i1) }}} FAA (Val $ LitV $ LitLoc l) (Val $ LitV $ LitInt i2) @ s; E
- {{{ RET LitV (LitInt i1); l ↦ LitV (LitInt (i1 + i2)) }}}.
-Proof.
- iIntros (Φ) ">Hl HΦ". iApply wp_lift_atomic_head_step_no_fork; auto.
- iIntros (σ1 κ κs n) "[Hσ Hκs] !>". 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=>//. iFrame. by iApply "HΦ".
-Qed.
-Lemma swp_faa k s E l i1 i2 :
- {{{ ▷ l ↦ LitV (LitInt i1) }}} FAA (Val $ LitV $ LitLoc l) (Val $ LitV $ LitInt i2) at k @ s; E
- {{{ RET LitV (LitInt i1); l ↦ LitV (LitInt (i1 + i2)) }}}.
-Proof.
- iIntros (Φ) ">Hl HΦ". iApply swp_lift_atomic_head_step_no_fork.
- iIntros (σ1 κ κs n) "[Hσ Hκs] !>". 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=>//. iFrame. by iApply "HΦ".
-Qed.
-(*Lemma twp_faa s E l i1 i2 :
- [[{ l ↦ LitV (LitInt i1) }]] FAA (Val $ LitV $ LitLoc l) (Val $ LitV $ LitInt i2) @ s; E
- [[{ RET LitV (LitInt i1); l ↦ LitV (LitInt (i1 + i2)) }]].
-Proof.
- iIntros (Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; auto.
- iIntros (σ1 κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
- iSplit; first by eauto. iIntros (κ e2 σ2 efs Hstep); inv_head_step.
- iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
- iModIntro. iSplit=>//. iSplit; first done. iFrame. by iApply "HΦ".
-Qed.*)
-
-Lemma wp_new_proph s E :
- {{{ True }}}
- NewProph @ s; E
- {{{ pvs p, RET (LitV (LitProphecy p)); proph p pvs }}}.
-Proof.
- iIntros (Φ) "_ HΦ". iApply wp_lift_atomic_head_step_no_fork; auto.
- iIntros (σ1 κ κs n) "[Hσ HR] !>". iSplit; first by eauto.
- iNext; iIntros (v2 σ2 efs Hstep). inv_head_step.
- iMod (proph_map_new_proph p with "HR") as "[HR Hp]"; first done.
- iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
-Qed.
-Lemma swp_new_proph k s E :
- {{{ True }}}
- NewProph at k @ s; E
- {{{ pvs p, RET (LitV (LitProphecy p)); proph p pvs }}}.
-Proof.
- iIntros (Φ) "_ HΦ". iApply swp_lift_atomic_head_step_no_fork.
- iIntros (σ1 κ κs n) "[Hσ HR] !>". iSplit; first by eauto.
- iNext; iIntros (v2 σ2 efs Hstep). inv_head_step.
- iMod (proph_map_new_proph p with "HR") as "[HR Hp]"; first done.
- iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
-Qed.
-
-(* In the following, strong atomicity is required due to the fact that [e] must
-be able to make a head step for [Resolve e _ _] not to be (head) stuck. *)
-
-Lemma resolve_reducible e σ (p : proph_id) v :
- Atomic StronglyAtomic e → reducible e σ →
- reducible (Resolve e (Val (LitV (LitProphecy p))) (Val v)) σ.
-Proof.
- intros A (κ & e' & σ' & efs & H).
- exists (κ ++ [(p, (default v (to_val e'), v))]), e', σ', efs.
- eapply Ectx_step with (K:=[]); try done.
- assert (∃w, Val w = e') as [w <-].
- { unfold Atomic in A. apply (A σ e' κ σ' efs) in H. unfold is_Some in H.
- destruct H as [w H]. exists w. simpl in H. by apply (of_to_val _ _ H). }
- simpl. constructor. by apply prim_step_to_val_is_head_step.
-Qed.
-
-Lemma step_resolve e vp vt σ1 κ e2 σ2 efs :
- Atomic StronglyAtomic e →
- prim_step (Resolve e (Val vp) (Val vt)) σ1 κ e2 σ2 efs →
- head_step (Resolve e (Val vp) (Val vt)) σ1 κ e2 σ2 efs.
-Proof.
- intros A [Ks e1' e2' Hfill -> step]. simpl in *.
- induction Ks as [|K Ks _] using rev_ind.
- + simpl in *. subst. inversion step. by constructor.
- + rewrite fill_app /= in Hfill. destruct K; inversion Hfill; subst; clear Hfill.
- - assert (fill_item K (fill Ks e1') = fill (Ks ++ [K]) e1') as Eq1;
- first by rewrite fill_app.
- assert (fill_item K (fill Ks e2') = fill (Ks ++ [K]) e2') as Eq2;
- first by rewrite fill_app.
- rewrite fill_app /=. rewrite Eq1 in A.
- assert (is_Some (to_val (fill (Ks ++ [K]) e2'))) as H.
- { apply (A σ1 _ κ σ2 efs). eapply Ectx_step with (K0 := Ks ++ [K]); done. }
- destruct H as [v H]. apply to_val_fill_some in H. by destruct H, Ks.
- - assert (to_val (fill Ks e1') = Some vp); first by rewrite -H1 //.
- apply to_val_fill_some in H. destruct H as [-> ->]. inversion step.
- - assert (to_val (fill Ks e1') = Some vt); first by rewrite -H2 //.
- apply to_val_fill_some in H. destruct H as [-> ->]. inversion step.
-Qed.
-
-
-Arguments gstep : simpl never.
-Existing Instance elim_gstep.
-Lemma wp_resolve s E e Φ (p : proph_id) v (pvs : list (val * val)) :
- Atomic StronglyAtomic e →
- to_val e = None →
- proph p pvs -∗
- WP e @ s; E {{ r, ∀ pvs', ⌜pvs = (r, v)::pvs'⌝ -∗ proph p pvs' -∗ Φ r }} -∗
- WP Resolve e (Val $ LitV $ LitProphecy p) (Val v) @ s; E {{ Φ }}.
-Proof.
- (* TODO we should try to use a generic lifting lemma (and avoid [wp_unfold])
- here, since this breaks the WP abstraction. *)
- iIntros (A He) "Hp WPe". rewrite !wp_unfold /wp_pre /= He. simpl in *.
- iIntros (σ1 κ κs n) "[Hσ Hκ]". destruct κ as [|[p' [w' v']] κ' _] using rev_ind.
- - iMod ("WPe" $! σ1 [] κs n with "[$Hσ $Hκ]") as "[Hs WPe]".
- iSplit.
- { iDestruct "Hs" as "%". iPureIntro. destruct s; [ by apply resolve_reducible | done]. }
- iIntros (e2 σ2 efs step). exfalso. apply step_resolve in step; last done.
- inversion step. match goal with H: ?κs ++ [_] = [] |- _ => by destruct κs end.
- - rewrite -app_assoc.
- iMod ("WPe" $! σ1 _ _ n with "[$Hσ $Hκ]") as "[Hs WPe]".
- iSplit.
- { iDestruct "Hs" as %?. iPureIntro. destruct s; [ by apply resolve_reducible | done]. }
- iIntros (e2 σ2 efs step). apply step_resolve in step; last done.
- inversion step; simplify_list_eq.
- iMod ("WPe" $! (Val w') σ2 efs with "[%]") as "WPe".
- { by eexists [] _ _. }
- iModIntro. iNext. iMod "WPe" as "[[$ Hκ] WPe]".
- iMod (proph_map_resolve_proph p' (w',v') κs with "[$Hκ $Hp]") as (vs' ->) "[$ HPost]".
- iModIntro. rewrite !wp_unfold /wp_pre /=. iDestruct "WPe" as "[HΦ $]".
- iMod "HΦ". iModIntro. by iApply "HΦ".
-Qed.
-
-Arguments gstepN : simpl never.
-Existing Instance elim_gstepN.
-Lemma swp_resolve k s E e Φ (p : proph_id) v (pvs : list (val * val)) :
- Atomic StronglyAtomic e →
- proph p pvs -∗
- SWP e at k @ s; E {{ r, ∀ pvs', ⌜pvs = (r, v)::pvs'⌝ -∗ proph p pvs' -∗ Φ r }} -∗
- SWP Resolve e (Val $ LitV $ LitProphecy p) (Val v) at k @ s; E {{ Φ }}.
-Proof.
- (* TODO we should try to use a generic lifting lemma (and avoid [wp_unfold])
- here, since this breaks the WP abstraction. *)
- iIntros (A) "Hp WPe". rewrite !swp_unfold /swp_def /=. simpl in *.
- iIntros (σ1 κ κs n) "[Hσ Hκ]". destruct κ as [|[p' [w' v']] κ' _] using rev_ind.
- - iMod ("WPe" $! σ1 [] κs n with "[$Hσ $Hκ]") as "[Hs WPe]". iSplit.
- { iDestruct "Hs" as "%". iPureIntro. destruct s; [ by apply resolve_reducible | done]. }
- iIntros (e2 σ2 efs step). exfalso. apply step_resolve in step; last done.
- inversion step. match goal with H: ?κs ++ [_] = [] |- _ => by destruct κs end.
- - rewrite -app_assoc.
- iMod ("WPe" $! σ1 _ _ n with "[$Hσ $Hκ]") as "[Hs WPe]". iSplit.
- { iDestruct "Hs" as %?. iPureIntro. destruct s; [ by apply resolve_reducible | done]. }
- iIntros (e2 σ2 efs step). apply step_resolve in step; last done.
- inversion step; simplify_list_eq.
- iMod ("WPe" $! (Val w') σ2 efs with "[%]") as "WPe".
- { by eexists [] _ _. }
- iModIntro. iNext. iMod "WPe" as "[[$ Hκ] WPe]".
- iMod (proph_map_resolve_proph p' (w',v') κs with "[$Hκ $Hp]") as (vs' ->) "[$ HPost]".
- iModIntro. rewrite !wp_unfold /wp_pre /=. iDestruct "WPe" as "[HΦ $]".
- iMod "HΦ". iModIntro. by iApply "HΦ".
-Qed.
-
-(** Lemmas for some particular expression inside the [Resolve]. *)
-Lemma wp_resolve_proph s E (p : proph_id) (pvs : list (val * val)) v :
- {{{ proph p pvs }}}
- ResolveProph (Val $ LitV $ LitProphecy p) (Val v) @ s; E
- {{{ pvs', RET (LitV LitUnit); ⌜pvs = (LitV LitUnit, v)::pvs'⌝ ∗ proph p pvs' }}}.
-Proof.
- iIntros (Φ) "Hp HΦ". iApply (wp_resolve with "Hp"); first done.
- iApply wp_pure_step_later=> //=. iApply wp_value.
- iIntros "!>" (vs') "HEq Hp". iApply "HΦ". iFrame.
-Qed.
-
-Lemma swp_resolve_proph k s E (p : proph_id) (pvs : list (val * val)) v :
- {{{ proph p pvs }}}
- ResolveProph (Val $ LitV $ LitProphecy p) (Val v) at k @ s; E
- {{{ pvs', RET (LitV LitUnit); ⌜pvs = (LitV LitUnit, v)::pvs'⌝ ∗ proph p pvs' }}}.
-Proof.
- iIntros (Φ) "Hp HΦ". iApply (swp_resolve with "Hp").
- iApply swp_pure_step_later=> //=. iApply wp_value.
- iIntros "!>" (vs') "HEq Hp". iApply "HΦ". iFrame.
-Qed.
-
-Lemma wp_resolve_cmpxchg_suc s E l (p : proph_id) (pvs : list (val * val)) v1 v2 v :
- vals_compare_safe v1 v1 →
- {{{ proph p pvs ∗ ▷ l ↦ v1 }}}
- Resolve (CmpXchg #l v1 v2) #p v @ s; E
- {{{ RET (v1, #true) ; ∃ pvs', ⌜pvs = ((v1, #true)%V, v)::pvs'⌝ ∗ proph p pvs' ∗ l ↦ v2 }}}.
-Proof.
- iIntros (Hcmp Φ) "[Hp Hl] HΦ".
- iApply (wp_resolve with "Hp"); first done.
- assert (val_is_unboxed v1) as Hv1; first by destruct Hcmp.
- iApply (wp_cmpxchg_suc with "Hl"); [done..|]. iIntros "!> Hl".
- iIntros (pvs' ->) "Hp". iApply "HΦ". eauto with iFrame.
-Qed.
-
-Lemma swp_resolve_cmpxchg_suc k s E l (p : proph_id) (pvs : list (val * val)) v1 v2 v :
- vals_compare_safe v1 v1 →
- {{{ proph p pvs ∗ ▷ l ↦ v1 }}}
- Resolve (CmpXchg #l v1 v2) #p v at k @ s; E
- {{{ RET (v1, #true) ; ∃ pvs', ⌜pvs = ((v1, #true)%V, v)::pvs'⌝ ∗ proph p pvs' ∗ l ↦ v2 }}}.
-Proof.
- iIntros (Hcmp Φ) "[Hp Hl] HΦ".
- iApply (swp_resolve with "Hp").
- assert (val_is_unboxed v1) as Hv1; first by destruct Hcmp.
- iApply (swp_cmpxchg_suc with "Hl"); [done..|]. iIntros "!> Hl".
- iIntros (pvs' ->) "Hp". iApply "HΦ". eauto with iFrame.
-Qed.
-
-Lemma wp_resolve_cmpxchg_fail s E l (p : proph_id) (pvs : list (val * val)) q v' v1 v2 v :
- v' ≠ v1 → vals_compare_safe v' v1 →
- {{{ proph p pvs ∗ ▷ l ↦{q} v' }}}
- Resolve (CmpXchg #l v1 v2) #p v @ s; E
- {{{ RET (v', #false) ; ∃ pvs', ⌜pvs = ((v', #false)%V, v)::pvs'⌝ ∗ proph p pvs' ∗ l ↦{q} v' }}}.
-Proof.
- iIntros (NEq Hcmp Φ) "[Hp Hl] HΦ".
- iApply (wp_resolve with "Hp"); first done.
- iApply (wp_cmpxchg_fail with "Hl"); [done..|]. iIntros "!> Hl".
- iIntros (pvs' ->) "Hp". iApply "HΦ". eauto with iFrame.
-Qed.
-
-Lemma swp_resolve_cmpxchg_fail k s E l (p : proph_id) (pvs : list (val * val)) q v' v1 v2 v :
- v' ≠ v1 → vals_compare_safe v' v1 →
- {{{ proph p pvs ∗ ▷ l ↦{q} v' }}}
- Resolve (CmpXchg #l v1 v2) #p v at k @ s; E
- {{{ RET (v', #false) ; ∃ pvs', ⌜pvs = ((v', #false)%V, v)::pvs'⌝ ∗ proph p pvs' ∗ l ↦{q} v' }}}.
-Proof.
- iIntros (NEq Hcmp Φ) "[Hp Hl] HΦ".
- iApply (swp_resolve with "Hp").
- iApply (swp_cmpxchg_fail with "Hl"); [done..|]. iIntros "!> Hl".
- iIntros (pvs' ->) "Hp". iApply "HΦ". eauto with iFrame.
-Qed.
-
-(** Array lemmas *)
-Lemma wp_allocN_vec s E v n :
- 0 < n →
- {{{ True }}}
- AllocN #n v @ s ; E
- {{{ l, RET #l; l ↦∗ vreplicate (Z.to_nat n) v ∗
- [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ }}}.
-Proof.
- iIntros (Hzs Φ) "_ HΦ". iApply wp_allocN; [ lia | done | .. ]. iNext.
- iIntros (l) "[Hl Hm]". iApply "HΦ". rewrite vec_to_list_replicate. iFrame.
-Qed.
-
-Lemma swp_allocN_vec k s E v n :
- 0 < n →
- {{{ True }}}
- AllocN #n v at k @ s ; E
- {{{ l, RET #l; l ↦∗ vreplicate (Z.to_nat n) v ∗
- [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ }}}.
-Proof.
- iIntros (Hzs Φ) "_ HΦ". iApply swp_allocN; [ lia | done | .. ]. iNext.
- iIntros (l) "[Hl Hm]". iApply "HΦ". rewrite vec_to_list_replicate. iFrame.
-Qed.
-
-Lemma wp_load_offset s E l off vs v :
- vs !! off = Some v →
- {{{ ▷ l ↦∗ vs }}} ! #(l +ₗ off) @ s; E {{{ RET v; l ↦∗ vs }}}.
-Proof.
- iIntros (Hlookup Φ) ">Hl HΦ".
- iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
- iApply (wp_load with "Hl1"). iIntros "!> Hl1". iApply "HΦ".
- iDestruct ("Hl2" $! v) as "Hl2". rewrite list_insert_id; last done.
- iApply "Hl2". iApply "Hl1".
-Qed.
-
-Lemma swp_load_offset k s E l off vs v :
- vs !! off = Some v →
- {{{ ▷ l ↦∗ vs }}} ! #(l +ₗ off) at k @ s; E {{{ RET v; l ↦∗ vs }}}.
-Proof.
- iIntros (Hlookup Φ) ">Hl HΦ".
- iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
- iApply (swp_load with "Hl1"). iIntros "!> Hl1". iApply "HΦ".
- iDestruct ("Hl2" $! v) as "Hl2". rewrite list_insert_id; last done.
- iApply "Hl2". iApply "Hl1".
-Qed.
-
-Lemma wp_load_offset_vec s E l sz (off : fin sz) (vs : vec val sz) :
- {{{ ▷ l ↦∗ vs }}} ! #(l +ₗ off) @ s; E {{{ RET vs !!! off; l ↦∗ vs }}}.
-Proof. apply wp_load_offset. by apply vlookup_lookup. Qed.
-
-Lemma swp_load_offset_vec k s E l sz (off : fin sz) (vs : vec val sz) :
- {{{ ▷ l ↦∗ vs }}} ! #(l +ₗ off) at k @ s; E {{{ RET vs !!! off; l ↦∗ vs }}}.
-Proof. apply swp_load_offset. by apply vlookup_lookup. Qed.
-
-
-Lemma wp_store_offset s E l off vs v :
- is_Some (vs !! off) →
- {{{ ▷ l ↦∗ vs }}} #(l +ₗ off) <- v @ s; E {{{ RET #(); l ↦∗ <[off:=v]> vs }}}.
-Proof.
- iIntros ([w Hlookup] Φ) ">Hl HΦ".
- iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
- iApply (wp_store with "Hl1"). iNext. iIntros "Hl1".
- iApply "HΦ". iApply "Hl2". iApply "Hl1".
-Qed.
-Lemma swp_store_offset k s E l off vs v :
- is_Some (vs !! off) →
- {{{ ▷ l ↦∗ vs }}} #(l +ₗ off) <- v at k @ s; E {{{ RET #(); l ↦∗ <[off:=v]> vs }}}.
-Proof.
- iIntros ([w Hlookup] Φ) ">Hl HΦ".
- iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
- iApply (swp_store with "Hl1"). iNext. iIntros "Hl1".
- iApply "HΦ". iApply "Hl2". iApply "Hl1".
-Qed.
-
-Lemma wp_store_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v :
- {{{ ▷ l ↦∗ vs }}} #(l +ₗ off) <- v @ s; E {{{ RET #(); l ↦∗ vinsert off v vs }}}.
-Proof.
- setoid_rewrite vec_to_list_insert. apply wp_store_offset.
- eexists. by apply vlookup_lookup.
-Qed.
-Lemma swp_store_offset_vec k s E l sz (off : fin sz) (vs : vec val sz) v :
- {{{ ▷ l ↦∗ vs }}} #(l +ₗ off) <- v at k @ s; E {{{ RET #(); l ↦∗ vinsert off v vs }}}.
-Proof.
- setoid_rewrite vec_to_list_insert. apply swp_store_offset.
- eexists. by apply vlookup_lookup.
-Qed.
-
-
-Lemma wp_cmpxchg_suc_offset s E l off vs v' v1 v2 :
- vs !! off = Some v' →
- v' = v1 →
- vals_compare_safe v' v1 →
- {{{ ▷ l ↦∗ vs }}}
- CmpXchg #(l +ₗ off) v1 v2 @ s; E
- {{{ RET (v', #true); l ↦∗ <[off:=v2]> vs }}}.
-Proof.
- iIntros (Hlookup ?? Φ) ">Hl HΦ".
- iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
- iApply (wp_cmpxchg_suc with "Hl1"); [done..|].
- iNext. iIntros "Hl1". iApply "HΦ". iApply "Hl2". iApply "Hl1".
-Qed.
-Lemma swp_cmpxchg_suc_offset k s E l off vs v' v1 v2 :
- vs !! off = Some v' →
- v' = v1 →
- vals_compare_safe v' v1 →
- {{{ ▷ l ↦∗ vs }}}
- CmpXchg #(l +ₗ off) v1 v2 at k @ s; E
- {{{ RET (v', #true); l ↦∗ <[off:=v2]> vs }}}.
-Proof.
- iIntros (Hlookup ?? Φ) ">Hl HΦ".
- iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
- iApply (swp_cmpxchg_suc with "Hl1"); [done..|].
- iNext. iIntros "Hl1". iApply "HΦ". iApply "Hl2". iApply "Hl1".
-Qed.
-
-Lemma wp_cmpxchg_suc_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v1 v2 :
- vs !!! off = v1 →
- vals_compare_safe (vs !!! off) v1 →
- {{{ ▷ l ↦∗ vs }}}
- CmpXchg #(l +ₗ off) v1 v2 @ s; E
- {{{ RET (vs !!! off, #true); l ↦∗ vinsert off v2 vs }}}.
-Proof.
- intros. setoid_rewrite vec_to_list_insert. eapply wp_cmpxchg_suc_offset=> //.
- by apply vlookup_lookup.
-Qed.
-Lemma swp_cmpxchg_suc_offset_vec k s E l sz (off : fin sz) (vs : vec val sz) v1 v2 :
- vs !!! off = v1 →
- vals_compare_safe (vs !!! off) v1 →
- {{{ ▷ l ↦∗ vs }}}
- CmpXchg #(l +ₗ off) v1 v2 at k @ s; E
- {{{ RET (vs !!! off, #true); l ↦∗ vinsert off v2 vs }}}.
-Proof.
- intros. setoid_rewrite vec_to_list_insert. eapply swp_cmpxchg_suc_offset=> //.
- by apply vlookup_lookup.
-Qed.
-
-Lemma wp_cmpxchg_fail_offset s E l off vs v0 v1 v2 :
- vs !! off = Some v0 →
- v0 ≠ v1 →
- vals_compare_safe v0 v1 →
- {{{ ▷ l ↦∗ vs }}}
- CmpXchg #(l +ₗ off) v1 v2 @ s; E
- {{{ RET (v0, #false); l ↦∗ vs }}}.
-Proof.
- iIntros (Hlookup HNEq Hcmp Φ) ">Hl HΦ".
- iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
- iApply (wp_cmpxchg_fail with "Hl1"); first done.
- { destruct Hcmp; by [ left | right ]. }
- iIntros "!> Hl1". iApply "HΦ". iDestruct ("Hl2" $! v0) as "Hl2".
- rewrite list_insert_id; last done. iApply "Hl2". iApply "Hl1".
-Qed.
-
-Lemma swp_cmpxchg_fail_offset k s E l off vs v0 v1 v2 :
- vs !! off = Some v0 →
- v0 ≠ v1 →
- vals_compare_safe v0 v1 →
- {{{ ▷ l ↦∗ vs }}}
- CmpXchg #(l +ₗ off) v1 v2 at k @ s; E
- {{{ RET (v0, #false); l ↦∗ vs }}}.
-Proof.
- iIntros (Hlookup HNEq Hcmp Φ) ">Hl HΦ".
- iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
- iApply (swp_cmpxchg_fail with "Hl1"); first done.
- { destruct Hcmp; by [ left | right ]. }
- iIntros "!> Hl1". iApply "HΦ". iDestruct ("Hl2" $! v0) as "Hl2".
- rewrite list_insert_id; last done. iApply "Hl2". iApply "Hl1".
-Qed.
-
-Lemma wp_cmpxchg_fail_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v1 v2 :
- vs !!! off ≠ v1 →
- vals_compare_safe (vs !!! off) v1 →
- {{{ ▷ l ↦∗ vs }}}
- CmpXchg #(l +ₗ off) v1 v2 @ s; E
- {{{ RET (vs !!! off, #false); l ↦∗ vs }}}.
-Proof. intros. eapply wp_cmpxchg_fail_offset=> //. by apply vlookup_lookup. Qed.
-Lemma swp_cmpxchg_fail_offset_vec k s E l sz (off : fin sz) (vs : vec val sz) v1 v2 :
- vs !!! off ≠ v1 →
- vals_compare_safe (vs !!! off) v1 →
- {{{ ▷ l ↦∗ vs }}}
- CmpXchg #(l +ₗ off) v1 v2 at k @ s; E
- {{{ RET (vs !!! off, #false); l ↦∗ vs }}}.
-Proof. intros. eapply swp_cmpxchg_fail_offset=> //. by apply vlookup_lookup. Qed.
-
-Lemma wp_faa_offset s E l off vs (i1 i2 : Z) :
- vs !! off = Some #i1 →
- {{{ ▷ l ↦∗ vs }}} FAA #(l +ₗ off) #i2 @ s; E
- {{{ RET LitV (LitInt i1); l ↦∗ <[off:=#(i1 + i2)]> vs }}}.
-Proof.
- iIntros (Hlookup Φ) ">Hl HΦ".
- iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
- iApply (wp_faa with "Hl1").
- iNext. iIntros "Hl1". iApply "HΦ". iApply "Hl2". iApply "Hl1".
-Qed.
-Lemma swp_faa_offset k s E l off vs (i1 i2 : Z) :
- vs !! off = Some #i1 →
- {{{ ▷ l ↦∗ vs }}} FAA #(l +ₗ off) #i2 at k @ s; E
- {{{ RET LitV (LitInt i1); l ↦∗ <[off:=#(i1 + i2)]> vs }}}.
-Proof.
- iIntros (Hlookup Φ) ">Hl HΦ".
- iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
- iApply (swp_faa with "Hl1").
- iNext. iIntros "Hl1". iApply "HΦ". iApply "Hl2". iApply "Hl1".
-Qed.
-
-Lemma wp_faa_offset_vec s E l sz (off : fin sz) (vs : vec val sz) (i1 i2 : Z) :
- vs !!! off = #i1 →
- {{{ ▷ l ↦∗ vs }}} FAA #(l +ₗ off) #i2 @ s; E
- {{{ RET LitV (LitInt i1); l ↦∗ vinsert off #(i1 + i2) vs }}}.
-Proof.
- intros. setoid_rewrite vec_to_list_insert. apply wp_faa_offset=> //.
- by apply vlookup_lookup.
-Qed.
-Lemma swp_faa_offset_vec k s E l sz (off : fin sz) (vs : vec val sz) (i1 i2 : Z) :
- vs !!! off = #i1 →
- {{{ ▷ l ↦∗ vs }}} FAA #(l +ₗ off) #i2 at k @ s; E
- {{{ RET LitV (LitInt i1); l ↦∗ vinsert off #(i1 + i2) vs }}}.
-Proof.
- intros. setoid_rewrite vec_to_list_insert. apply swp_faa_offset=> //.
- by apply vlookup_lookup.
-Qed.
-
-End lifting.
-
-
-
-Section refinements.
-
- Context {SI} {Σ: gFunctors SI} {A: Type} `{!source Σ A} `{!heapG Σ}.
- Implicit Types P Q : iProp Σ.
- Implicit Types Φ : val → iProp Σ.
- Implicit Types efs : list expr.
- Implicit Types σ : state.
- Implicit Types v : val.
- Implicit Types vs : list val.
- Implicit Types l : loc.
- Implicit Types sz off : nat.
-
- (* TODO: Uniform approch to where the refinement *)
- Existing Instance heapG_invG.
-
-(** Fork: Not using Texan triples to avoid some unnecessary [True] *)
-Lemma rswp_fork k s E e Φ :
- RWP e @ s; ⊤ ⟨⟨ _, True ⟩⟩ -∗ Φ (LitV LitUnit) -∗ RSWP Fork e at k @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros "He HΦ". iApply rswp_lift_atomic_head_step.
- iIntros (σ1 n) "Hσ !>"; iSplit; first by eauto.
- iNext; iIntros (v2 σ2 efs κ Hstep); inv_head_step. by iFrame.
-Qed.
-
-(** Heap *)
-Lemma rswp_allocN k s E v n :
- 0 < n →
- ⟨⟨⟨ True ⟩⟩⟩ AllocN (Val $ LitV $ LitInt $ n) (Val v) at k @ s; E
- ⟨⟨⟨ l, RET LitV (LitLoc l); l ↦∗ replicate (Z.to_nat n) v ∗
- [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ ⟩⟩⟩.
-Proof.
- iIntros (Hn Φ) "_ HΦ". iApply rswp_lift_atomic_head_step_no_fork.
- iIntros (σ1 k') "Hσ !>"; iSplit; first by auto with lia.
- iNext; iIntros (v2 σ2 efs κ Hstep); inv_head_step.
- iMod (@gen_heap_alloc_gen with "Hσ") as "(Hσ & Hl & Hm)".
- { apply (heap_array_map_disjoint _ l (replicate (Z.to_nat n) v)); eauto.
- rewrite replicate_length Z2Nat.id; auto with lia. }
- iModIntro; iSplit; first done. iFrame "Hσ". iApply "HΦ". iSplitL "Hl".
- - by iApply heap_array_to_array.
- - iApply (heap_array_to_seq_meta with "Hm"). by rewrite replicate_length.
-Qed.
-
-Lemma rswp_alloc k s E v :
- ⟨⟨⟨ True ⟩⟩⟩ Alloc (Val v) at k @ s; E ⟨⟨⟨ l, RET LitV (LitLoc l); l ↦ v ∗ meta_token l ⊤ ⟩⟩⟩.
-Proof.
- iIntros (Φ) "_ HΦ". iApply rswp_allocN; auto with lia.
- iIntros "!>" (l) "/= (? & ? & _)".
- rewrite array_singleton loc_add_0. iApply "HΦ"; iFrame.
-Qed.
-
-(* TODO: we can always get rid of the later if the goal is a WP anyway. Having it in the rule seems unnecessary.*)
-Lemma rswp_load k s E l q v :
- ⟨⟨⟨ ▷ l ↦{q} v ⟩⟩⟩ Load (Val $ LitV $ LitLoc l) at k @ s; E ⟨⟨⟨ RET v; l ↦{q} v ⟩⟩⟩.
-Proof.
- iIntros (Φ) ">Hl HΦ". iApply rswp_lift_atomic_head_step_no_fork.
- iIntros (σ1 n) "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.
-
-(* TODO: we can always get rid of the later if the goal is a WP anyway. Having it in the rule seems unnecessary.*)
-Lemma rswp_store k s E l v' v :
- ⟨⟨⟨ ▷ l ↦ v' ⟩⟩⟩ Store (Val $ LitV (LitLoc l)) (Val v) at k @ s; E
- ⟨⟨⟨ RET LitV LitUnit; l ↦ v ⟩⟩⟩.
-Proof.
- iIntros (Φ) ">Hl HΦ".
- iApply rswp_lift_atomic_head_step_no_fork.
- iIntros (σ1 n) "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=>//. iFrame. by iApply "HΦ".
-Qed.
-
-Lemma rswp_cmpxchg_fail k s E l q v' v1 v2 :
- v' ≠ v1 → vals_compare_safe v' v1 →
- ⟨⟨⟨ ▷ l ↦{q} v' ⟩⟩⟩ CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) at k @ s; E
- ⟨⟨⟨ RET PairV v' (LitV $ LitBool false); l ↦{q} v' ⟩⟩⟩.
-Proof.
- iIntros (?? Φ) ">Hl HΦ". iApply rswp_lift_atomic_head_step_no_fork.
- iIntros (σ1 n) "Hσ !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
- iSplit; first by eauto. iNext; iIntros (v2' σ2 efs κ Hstep); inv_head_step.
- rewrite bool_decide_false //.
- iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
-Qed.
-
-Lemma rswp_cmpxchg_suc k s E l v1 v2 v' :
- v' = v1 → vals_compare_safe v' v1 →
- ⟨⟨⟨ ▷ l ↦ v' ⟩⟩⟩ CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) at k @ s; E
- ⟨⟨⟨ RET PairV v' (LitV $ LitBool true); l ↦ v2 ⟩⟩⟩.
-Proof.
- iIntros (?? Φ) ">Hl HΦ". iApply rswp_lift_atomic_head_step_no_fork.
- iIntros (σ1 n) "Hσ !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
- iSplit; first by eauto. iNext; iIntros (v2' σ2 efs κ Hstep); inv_head_step.
- rewrite bool_decide_true //.
- iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
- iModIntro. iSplit=>//. iFrame. by iApply "HΦ".
-Qed.
-
-Lemma rswp_faa k s E l i1 i2 :
- ⟨⟨⟨ ▷ l ↦ LitV (LitInt i1) ⟩⟩⟩ FAA (Val $ LitV $ LitLoc l) (Val $ LitV $ LitInt i2) at k @ s; E
- ⟨⟨⟨ RET LitV (LitInt i1); l ↦ LitV (LitInt (i1 + i2)) ⟩⟩⟩.
-Proof.
- iIntros (Φ) ">Hl HΦ". iApply rswp_lift_atomic_head_step_no_fork.
- iIntros (σ1 n) "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=>//. iFrame. by iApply "HΦ".
-Qed.
-
-Lemma rswp_allocN_vec k s E v n :
- 0 < n →
- ⟨⟨⟨ True ⟩⟩⟩
- AllocN #n v at k @ s ; E
- ⟨⟨⟨ l, RET #l; l ↦∗ vreplicate (Z.to_nat n) v ∗
- [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ ⟩⟩⟩.
-Proof.
- iIntros (Hzs Φ) "_ HΦ". iApply rswp_allocN; [ lia | done | .. ]. iNext.
- iIntros (l) "[Hl Hm]". iApply "HΦ". rewrite vec_to_list_replicate. iFrame.
-Qed.
-
-Lemma rswp_load_offset k s E l off vs v :
- vs !! off = Some v →
- ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩ ! #(l +ₗ off) at k @ s; E ⟨⟨⟨ RET v; l ↦∗ vs ⟩⟩⟩.
-Proof.
- iIntros (Hlookup Φ) ">Hl HΦ".
- iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
- iApply (rswp_load with "Hl1"). iIntros "!> Hl1". iApply "HΦ".
- iDestruct ("Hl2" $! v) as "Hl2". rewrite list_insert_id; last done.
- iApply "Hl2". iApply "Hl1".
-Qed.
-
-Lemma rswp_load_offset_vec k s E l sz (off : fin sz) (vs : vec val sz) :
- ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩ ! #(l +ₗ off) at k @ s; E ⟨⟨⟨ RET vs !!! off; l ↦∗ vs ⟩⟩⟩.
-Proof. apply rswp_load_offset. by apply vlookup_lookup. Qed.
-
-Lemma rswp_store_offset k s E l off vs v :
- is_Some (vs !! off) →
- ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩ #(l +ₗ off) <- v at k @ s; E ⟨⟨⟨ RET #(); l ↦∗ <[off:=v]> vs ⟩⟩⟩.
-Proof.
- iIntros ([w Hlookup] Φ) ">Hl HΦ".
- iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
- iApply (rswp_store with "Hl1"). iNext. iIntros "Hl1".
- iApply "HΦ". iApply "Hl2". iApply "Hl1".
-Qed.
-
-Lemma rswp_store_offset_vec k s E l sz (off : fin sz) (vs : vec val sz) v :
- ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩ #(l +ₗ off) <- v at k @ s; E ⟨⟨⟨ RET #(); l ↦∗ vinsert off v vs ⟩⟩⟩.
-Proof.
- setoid_rewrite vec_to_list_insert. apply rswp_store_offset.
- eexists. by apply vlookup_lookup.
-Qed.
-
-Lemma rswp_cmpxchg_suc_offset k s E l off vs v' v1 v2 :
- vs !! off = Some v' →
- v' = v1 →
- vals_compare_safe v' v1 →
- ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩
- CmpXchg #(l +ₗ off) v1 v2 at k @ s; E
- ⟨⟨⟨ RET (v', #true); l ↦∗ <[off:=v2]> vs ⟩⟩⟩.
-Proof.
- iIntros (Hlookup ?? Φ) ">Hl HΦ".
- iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
- iApply (rswp_cmpxchg_suc with "Hl1"); [done..|].
- iNext. iIntros "Hl1". iApply "HΦ". iApply "Hl2". iApply "Hl1".
-Qed.
-
-Lemma rswp_cmpxchg_suc_offset_vec k s E l sz (off : fin sz) (vs : vec val sz) v1 v2 :
- vs !!! off = v1 →
- vals_compare_safe (vs !!! off) v1 →
- ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩
- CmpXchg #(l +ₗ off) v1 v2 at k @ s; E
- ⟨⟨⟨ RET (vs !!! off, #true); l ↦∗ vinsert off v2 vs ⟩⟩⟩.
-Proof.
- intros. setoid_rewrite vec_to_list_insert. eapply rswp_cmpxchg_suc_offset=> //.
- by apply vlookup_lookup.
-Qed.
-
-Lemma rswp_cmpxchg_fail_offset k s E l off vs v0 v1 v2 :
- vs !! off = Some v0 →
- v0 ≠ v1 →
- vals_compare_safe v0 v1 →
- ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩
- CmpXchg #(l +ₗ off) v1 v2 at k @ s; E
- ⟨⟨⟨ RET (v0, #false); l ↦∗ vs ⟩⟩⟩.
-Proof.
- iIntros (Hlookup HNEq Hcmp Φ) ">Hl HΦ".
- iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
- iApply (rswp_cmpxchg_fail with "Hl1"); first done.
- { destruct Hcmp; by [ left | right ]. }
- iIntros "!> Hl1". iApply "HΦ". iDestruct ("Hl2" $! v0) as "Hl2".
- rewrite list_insert_id; last done. iApply "Hl2". iApply "Hl1".
-Qed.
-
-Lemma rswp_cmpxchg_fail_offset_vec k s E l sz (off : fin sz) (vs : vec val sz) v1 v2 :
- vs !!! off ≠ v1 →
- vals_compare_safe (vs !!! off) v1 →
- ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩
- CmpXchg #(l +ₗ off) v1 v2 at k @ s; E
- ⟨⟨⟨ RET (vs !!! off, #false); l ↦∗ vs ⟩⟩⟩.
-Proof. intros. eapply rswp_cmpxchg_fail_offset=> //. by apply vlookup_lookup. Qed.
-
-Lemma rswp_faa_offset k s E l off vs (i1 i2 : Z) :
- vs !! off = Some #i1 →
- ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩ FAA #(l +ₗ off) #i2 at k @ s; E
- ⟨⟨⟨ RET LitV (LitInt i1); l ↦∗ <[off:=#(i1 + i2)]> vs ⟩⟩⟩.
-Proof.
- iIntros (Hlookup Φ) ">Hl HΦ".
- iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
- iApply (rswp_faa with "Hl1").
- iNext. iIntros "Hl1". iApply "HΦ". iApply "Hl2". iApply "Hl1".
-Qed.
-
-Lemma rswp_faa_offset_vec k s E l sz (off : fin sz) (vs : vec val sz) (i1 i2 : Z) :
- vs !!! off = #i1 →
- ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩ FAA #(l +ₗ off) #i2 at k @ s; E
- ⟨⟨⟨ RET LitV (LitInt i1); l ↦∗ vinsert off #(i1 + i2) vs ⟩⟩⟩.
-Proof.
- intros. setoid_rewrite vec_to_list_insert. apply rswp_faa_offset=> //.
- by apply vlookup_lookup.
-Qed.
-
-
-(* refinement weakest pre versions *)
-(** Fork: Not using Texan triples to avoid some unnecessary [True] *)
-Lemma rwp_fork s E e Φ :
- RWP e @ s; ⊤ ⟨⟨ _, True ⟩⟩ -∗ Φ (LitV LitUnit) -∗ RWP Fork e @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_fork with "H HΦ").
-Qed.
-
-(** Heap *)
-Lemma rwp_allocN s E v n :
- 0 < n →
- ⟨⟨⟨ True ⟩⟩⟩ AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E
- ⟨⟨⟨ l, RET LitV (LitLoc l); l ↦∗ replicate (Z.to_nat n) v ∗
- [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ ⟩⟩⟩.
-Proof.
- iIntros (Hn Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_allocN _ _ _ _ _ Hn Φ with "H HΦ").
-Qed.
-
-Lemma rwp_alloc s E v :
- ⟨⟨⟨ True ⟩⟩⟩ Alloc (Val v) @ s; E ⟨⟨⟨ l, RET LitV (LitLoc l); l ↦ v ∗ meta_token l ⊤ ⟩⟩⟩.
-Proof.
- iIntros (Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_alloc with "H HΦ").
-Qed.
-
-Lemma rwp_load s E l q v :
- ⟨⟨⟨ ▷ l ↦{q} v ⟩⟩⟩ Load (Val $ LitV $ LitLoc l) @ s; E ⟨⟨⟨ RET v; l ↦{q} v ⟩⟩⟩.
-Proof.
- iIntros (Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_load with "H HΦ").
-Qed.
-
-Lemma rwp_store s E l v' v :
- ⟨⟨⟨ ▷ l ↦ v' ⟩⟩⟩ Store (Val $ LitV (LitLoc l)) (Val v) @ s; E
- ⟨⟨⟨ RET LitV LitUnit; l ↦ v ⟩⟩⟩.
-Proof.
- iIntros (Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_store with "H HΦ").
-Qed.
-
-Lemma rwp_cmpxchg_fail s E l q v' v1 v2 :
- v' ≠ v1 → vals_compare_safe v' v1 →
- ⟨⟨⟨ ▷ l ↦{q} v' ⟩⟩⟩ CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) @ s; E
- ⟨⟨⟨ RET PairV v' (LitV $ LitBool false); l ↦{q} v' ⟩⟩⟩.
-Proof.
- iIntros (?? Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_cmpxchg_fail with "H HΦ").
-Qed.
-
-Lemma rwp_cmpxchg_suc s E l v1 v2 v' :
- v' = v1 → vals_compare_safe v' v1 →
- ⟨⟨⟨ ▷ l ↦ v' ⟩⟩⟩ CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) @ s; E
- ⟨⟨⟨ RET PairV v' (LitV $ LitBool true); l ↦ v2 ⟩⟩⟩.
-Proof.
- iIntros (?? Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_cmpxchg_suc with "H HΦ").
-Qed.
-
-Lemma rwp_faa s E l i1 i2 :
- ⟨⟨⟨ ▷ l ↦ LitV (LitInt i1) ⟩⟩⟩ FAA (Val $ LitV $ LitLoc l) (Val $ LitV $ LitInt i2) @ s; E
- ⟨⟨⟨ RET LitV (LitInt i1); l ↦ LitV (LitInt (i1 + i2)) ⟩⟩⟩.
-Proof.
- iIntros (Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_faa with "H HΦ").
-Qed.
-
-Lemma rwp_allocN_vec s E v n :
- 0 < n →
- ⟨⟨⟨ True ⟩⟩⟩
- AllocN #n v @ s ; E
- ⟨⟨⟨ l, RET #l; l ↦∗ vreplicate (Z.to_nat n) v ∗
- [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ ⟩⟩⟩.
-Proof.
- iIntros (? Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_allocN_vec with "H HΦ").
-Qed.
-
-Lemma rwp_load_offset s E l off vs v :
- vs !! off = Some v →
- ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩ ! #(l +ₗ off) @ s; E ⟨⟨⟨ RET v; l ↦∗ vs ⟩⟩⟩.
-Proof.
- iIntros (? Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_load_offset with "H HΦ").
-Qed.
-
-Lemma rwp_load_offset_vec s E l sz (off : fin sz) (vs : vec val sz) :
- ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩ ! #(l +ₗ off) @ s; E ⟨⟨⟨ RET vs !!! off; l ↦∗ vs ⟩⟩⟩.
-Proof. apply rwp_load_offset. by apply vlookup_lookup. Qed.
-
-Lemma rwp_store_offset s E l off vs v :
- is_Some (vs !! off) →
- ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩ #(l +ₗ off) <- v @ s; E ⟨⟨⟨ RET #(); l ↦∗ <[off:=v]> vs ⟩⟩⟩.
-Proof.
- iIntros (? Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_store_offset with "H HΦ").
-Qed.
-
-Lemma rwp_store_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v :
- ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩ #(l +ₗ off) <- v @ s; E ⟨⟨⟨ RET #(); l ↦∗ vinsert off v vs ⟩⟩⟩.
-Proof.
- iIntros (Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_store_offset_vec with "H HΦ").
-Qed.
-
-Lemma rwp_cmpxchg_suc_offset s E l off vs v' v1 v2 :
- vs !! off = Some v' →
- v' = v1 →
- vals_compare_safe v' v1 →
- ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩
- CmpXchg #(l +ₗ off) v1 v2 @ s; E
- ⟨⟨⟨ RET (v', #true); l ↦∗ <[off:=v2]> vs ⟩⟩⟩.
-Proof.
- iIntros (??? Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_cmpxchg_suc_offset with "H HΦ").
-Qed.
-
-Lemma rwp_cmpxchg_suc_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v1 v2 :
- vs !!! off = v1 →
- vals_compare_safe (vs !!! off) v1 →
- ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩
- CmpXchg #(l +ₗ off) v1 v2 @ s; E
- ⟨⟨⟨ RET (vs !!! off, #true); l ↦∗ vinsert off v2 vs ⟩⟩⟩.
-Proof.
- iIntros (?? Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_cmpxchg_suc_offset_vec with "H HΦ").
-Qed.
-
-Lemma rwp_cmpxchg_fail_offset s E l off vs v0 v1 v2 :
- vs !! off = Some v0 →
- v0 ≠ v1 →
- vals_compare_safe v0 v1 →
- ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩
- CmpXchg #(l +ₗ off) v1 v2 @ s; E
- ⟨⟨⟨ RET (v0, #false); l ↦∗ vs ⟩⟩⟩.
-Proof.
- iIntros (??? Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_cmpxchg_fail_offset with "H HΦ").
-Qed.
-
-Lemma rwp_cmpxchg_fail_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v1 v2 :
- vs !!! off ≠ v1 →
- vals_compare_safe (vs !!! off) v1 →
- ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩
- CmpXchg #(l +ₗ off) v1 v2 @ s; E
- ⟨⟨⟨ RET (vs !!! off, #false); l ↦∗ vs ⟩⟩⟩.
-Proof. intros. eapply rwp_cmpxchg_fail_offset=> //. by apply vlookup_lookup. Qed.
-
-Lemma rwp_faa_offset s E l off vs (i1 i2 : Z) :
- vs !! off = Some #i1 →
- ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩ FAA #(l +ₗ off) #i2 @ s; E
- ⟨⟨⟨ RET LitV (LitInt i1); l ↦∗ <[off:=#(i1 + i2)]> vs ⟩⟩⟩.
-Proof.
- iIntros (? Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_faa_offset with "H HΦ").
-Qed.
-
-Lemma rwp_faa_offset_vec s E l sz (off : fin sz) (vs : vec val sz) (i1 i2 : Z) :
- vs !!! off = #i1 →
- ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩ FAA #(l +ₗ off) #i2 @ s; E
- ⟨⟨⟨ RET LitV (LitInt i1); l ↦∗ vinsert off #(i1 + i2) vs ⟩⟩⟩.
-Proof.
- iIntros (? Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_faa_offset_vec with "H HΦ").
-Qed.
-End refinements.
diff --git a/theories/heap_lang/locations.v b/theories/heap_lang/locations.v
deleted file mode 100644
index 7484c98a..00000000
--- a/theories/heap_lang/locations.v
+++ /dev/null
@@ -1,45 +0,0 @@
-From iris.algebra Require Import base.
-From stdpp Require Import countable numbers gmap.
-
-Record loc := { loc_car : Z }.
-
-Instance loc_eq_decision : EqDecision loc.
-Proof. solve_decision. Qed.
-
-Instance loc_inhabited : Inhabited loc := populate {|loc_car := 0 |}.
-
-Instance loc_countable : Countable loc.
-Proof. by apply (inj_countable' loc_car (λ i, {| loc_car := i |})); intros []. Qed.
-
-Program Instance loc_infinite : Infinite loc :=
- inj_infinite (λ p, {| loc_car := p |}) (λ l, Some (loc_car l)) _.
-Next Obligation. done. Qed.
-
-Definition loc_add (l : loc) (off : Z) : loc :=
- {| loc_car := loc_car l + off|}.
-
-Notation "l +ₗ off" :=
- (loc_add l off) (at level 50, left associativity) : stdpp_scope.
-
-Lemma loc_add_assoc l i j : l +ₗ i +ₗ j = l +ₗ (i + j).
-Proof. destruct l; rewrite /loc_add /=; f_equal; lia. Qed.
-
-Lemma loc_add_0 l : l +ₗ 0 = l.
-Proof. destruct l; rewrite /loc_add /=; f_equal; lia. Qed.
-
-Instance loc_add_inj l : Inj eq eq (loc_add l).
-Proof. destruct l; rewrite /Inj /loc_add /=; intros; simplify_eq; lia. Qed.
-
-Definition fresh_locs (ls : gset loc) : loc :=
- {| loc_car := set_fold (λ k r, (1 + loc_car k) `max` r)%Z 1%Z ls |}.
-
-Lemma fresh_locs_fresh ls i :
- (0 ≤ i)%Z → fresh_locs ls +ₗ i ∉ ls.
-Proof.
- intros Hi. cut (∀ l, l ∈ ls → loc_car l < loc_car (fresh_locs ls) + i)%Z.
- { intros help Hf%help. simpl in *. lia. }
- apply (set_fold_ind_L (λ r ls, ∀ l, l ∈ ls → (loc_car l < r + i)%Z));
- set_solver by eauto with lia.
-Qed.
-
-Global Opaque fresh_locs.
diff --git a/theories/heap_lang/metatheory.v b/theories/heap_lang/metatheory.v
deleted file mode 100644
index 9df37184..00000000
--- a/theories/heap_lang/metatheory.v
+++ /dev/null
@@ -1,224 +0,0 @@
-From iris.heap_lang Require Export lang.
-From stdpp Require Import gmap.
-
-(* This file contains some metatheory about the heap_lang language,
- which is not needed for verifying programs. *)
-
-(* Closed expressions and values. *)
-Fixpoint is_closed_expr (X : list string) (e : expr) : bool :=
- match e with
- | Val v => is_closed_val v
- | Var x => bool_decide (x ∈ X)
- | Rec f x e => is_closed_expr (f :b: x :b: X) e
- | UnOp _ e | Fst e | Snd e | InjL e | InjR e | Fork e | Load e =>
- is_closed_expr X e
- | App e1 e2 | BinOp _ e1 e2 | Pair e1 e2 | AllocN e1 e2 | Store e1 e2 | FAA e1 e2 =>
- is_closed_expr X e1 && is_closed_expr X e2
- | If e0 e1 e2 | Case e0 e1 e2 | CmpXchg e0 e1 e2 | Resolve e0 e1 e2 =>
- is_closed_expr X e0 && is_closed_expr X e1 && is_closed_expr X e2
- | NewProph => true
- end
-with is_closed_val (v : val) : bool :=
- match v with
- | LitV _ => true
- | RecV f x e => is_closed_expr (f :b: x :b: []) e
- | PairV v1 v2 => is_closed_val v1 && is_closed_val v2
- | InjLV v | InjRV v => is_closed_val v
- end.
-
-Lemma is_closed_weaken X Y e : is_closed_expr X e → X ⊆ Y → is_closed_expr Y e.
-Proof. revert X Y; induction e; naive_solver (eauto; set_solver). Qed.
-
-Lemma is_closed_weaken_nil X e : is_closed_expr [] e → is_closed_expr X e.
-Proof. intros. by apply is_closed_weaken with [], list_subseteq_nil. Qed.
-
-Lemma is_closed_subst X e x v :
- is_closed_val v → is_closed_expr (x :: X) e → is_closed_expr X (subst x v e).
-Proof.
- intros Hv. revert X.
- induction e=> X /= ?; destruct_and?; split_and?; simplify_option_eq;
- try match goal with
- | H : ¬(_ ∧ _) |- _ => apply not_and_l in H as [?%dec_stable|?%dec_stable]
- end; eauto using is_closed_weaken with set_solver.
-Qed.
-Lemma is_closed_subst' X e x v :
- is_closed_val v → is_closed_expr (x :b: X) e → is_closed_expr X (subst' x v e).
-Proof. destruct x; eauto using is_closed_subst. Qed.
-
-(* Substitution *)
-Lemma subst_is_closed X e x es : is_closed_expr X e → x ∉ X → subst x es e = e.
-Proof.
- revert X. induction e=> X /=; rewrite ?bool_decide_spec ?andb_True=> ??;
- repeat case_decide; simplify_eq/=; f_equal; intuition eauto with set_solver.
-Qed.
-
-Lemma subst_is_closed_nil e x v : is_closed_expr [] e → subst x v e = e.
-Proof. intros. apply subst_is_closed with []; set_solver. Qed.
-
-Lemma subst_subst e x v v' :
- subst x v (subst x v' e) = subst x v' e.
-Proof.
- intros. induction e; simpl; try (f_equal; by auto);
- simplify_option_eq; auto using subst_is_closed_nil with f_equal.
-Qed.
-Lemma subst_subst' e x v v' :
- subst' x v (subst' x v' e) = subst' x v' e.
-Proof. destruct x; simpl; auto using subst_subst. Qed.
-
-Lemma subst_subst_ne e x y v v' :
- x ≠ y → subst x v (subst y v' e) = subst y v' (subst x v e).
-Proof.
- intros. induction e; simpl; try (f_equal; by auto);
- simplify_option_eq; auto using eq_sym, subst_is_closed_nil with f_equal.
-Qed.
-Lemma subst_subst_ne' e x y v v' :
- x ≠ y → subst' x v (subst' y v' e) = subst' y v' (subst' x v e).
-Proof. destruct x, y; simpl; auto using subst_subst_ne with congruence. Qed.
-
-Lemma subst_rec' f y e x v :
- x = f ∨ x = y ∨ x = BAnon →
- subst' x v (Rec f y e) = Rec f y e.
-Proof. intros. destruct x; simplify_option_eq; naive_solver. Qed.
-Lemma subst_rec_ne' f y e x v :
- (x ≠ f ∨ f = BAnon) → (x ≠ y ∨ y = BAnon) →
- subst' x v (Rec f y e) = Rec f y (subst' x v e).
-Proof. intros. destruct x; simplify_option_eq; naive_solver. Qed.
-
-Lemma bin_op_eval_closed op v1 v2 v':
- is_closed_val v1 → is_closed_val v2 → bin_op_eval op v1 v2 = Some v' →
- is_closed_val v'.
-Proof.
- rewrite /bin_op_eval /bin_op_eval_bool /bin_op_eval_int;
- repeat case_match; by naive_solver.
-Qed.
-
-Lemma heap_closed_alloc σ l n w :
- 0 < n →
- is_closed_val w →
- map_Forall (λ _ v, is_closed_val v) (heap σ) →
- (∀ i : Z, 0 ≤ i → i < n → heap σ !! (l +ₗ i) = None) →
- map_Forall (λ _ v, is_closed_val v)
- (heap_array l (replicate (Z.to_nat n) w) ∪ heap σ).
-Proof.
- intros Hn Hw Hσ Hl.
- eapply (map_Forall_ind
- (λ k v, ((heap_array l (replicate (Z.to_nat n) w) ∪ heap σ)
- !! k = Some v))).
- - apply map_Forall_empty.
- - intros m i x Hi Hix Hkwm Hm.
- apply map_Forall_insert_2; auto.
- apply lookup_union_Some in Hix; last first.
- { eapply heap_array_map_disjoint;
- rewrite replicate_length Z2Nat.id; auto with lia. }
- destruct Hix as [(?&?&?&[-> Hlt%inj_lt]%lookup_replicate_1)%heap_array_lookup|
- [j Hj]%elem_of_map_to_list%elem_of_list_lookup_1].
- + rewrite !Z2Nat.id in Hlt; eauto with lia.
- + apply map_Forall_to_list in Hσ.
- by eapply Forall_lookup in Hσ; eauto; simpl in *.
- - apply map_Forall_to_list, Forall_forall.
- intros [? ?]; apply elem_of_map_to_list.
-Qed.
-
-(* The stepping relation preserves closedness *)
-Lemma head_step_is_closed e1 σ1 obs e2 σ2 es :
- is_closed_expr [] e1 →
- map_Forall (λ _ v, is_closed_val v) σ1.(heap) →
- head_step e1 σ1 obs e2 σ2 es →
-
- is_closed_expr [] e2 ∧ Forall (is_closed_expr []) es ∧
- map_Forall (λ _ v, is_closed_val v) σ2.(heap).
-Proof.
- intros Cl1 Clσ1 STEP.
- induction STEP; simpl in *; split_and!;
- try apply map_Forall_insert_2; try by naive_solver.
- - subst. repeat apply is_closed_subst'; naive_solver.
- - unfold un_op_eval in *. repeat case_match; naive_solver.
- - eapply bin_op_eval_closed; eauto; naive_solver.
- - by apply heap_closed_alloc.
- - case_match; try apply map_Forall_insert_2; by naive_solver.
-Qed.
-
-(* Parallel substitution with maps of values indexed by strings *)
-Definition binder_delete {A} (x : binder) (vs : gmap string A) : gmap string A :=
- if x is BNamed x' then delete x' vs else vs.
-Definition binder_insert {A} (x : binder) (v : A) (vs : gmap string A) : gmap string A :=
- if x is BNamed x' then <[x':=v]>vs else vs.
-
-Lemma binder_insert_fmap {A B : Type} (f : A → B) (x : A) b vs :
- f <$> binder_insert b x vs = binder_insert b (f x) (f <$> vs).
-Proof. destruct b; rewrite ?fmap_insert //. Qed.
-Lemma lookup_binder_delete_None {A : Type} (vs : gmap string A) x y :
- binder_delete x vs !! y = None ↔ x = BNamed y ∨ vs !! y = None.
-Proof. destruct x; rewrite /= ?lookup_delete_None; naive_solver. Qed.
-
-Fixpoint subst_map (vs : gmap string val) (e : expr) : expr :=
- match e with
- | Val _ => e
- | Var y => if vs !! y is Some v then Val v else Var y
- | Rec f y e => Rec f y (subst_map (binder_delete y (binder_delete f vs)) e)
- | App e1 e2 => App (subst_map vs e1) (subst_map vs e2)
- | UnOp op e => UnOp op (subst_map vs e)
- | BinOp op e1 e2 => BinOp op (subst_map vs e1) (subst_map vs e2)
- | If e0 e1 e2 => If (subst_map vs e0) (subst_map vs e1) (subst_map vs e2)
- | Pair e1 e2 => Pair (subst_map vs e1) (subst_map vs e2)
- | Fst e => Fst (subst_map vs e)
- | Snd e => Snd (subst_map vs e)
- | InjL e => InjL (subst_map vs e)
- | InjR e => InjR (subst_map vs e)
- | Case e0 e1 e2 => Case (subst_map vs e0) (subst_map vs e1) (subst_map vs e2)
- | Fork e => Fork (subst_map vs e)
- | AllocN e1 e2 => AllocN (subst_map vs e1) (subst_map vs e2)
- | Load e => Load (subst_map vs e)
- | Store e1 e2 => Store (subst_map vs e1) (subst_map vs e2)
- | CmpXchg e0 e1 e2 => CmpXchg (subst_map vs e0) (subst_map vs e1) (subst_map vs e2)
- | FAA e1 e2 => FAA (subst_map vs e1) (subst_map vs e2)
- | NewProph => NewProph
- | Resolve e0 e1 e2 => Resolve (subst_map vs e0) (subst_map vs e1) (subst_map vs e2)
- end.
-
-Lemma subst_map_empty e : subst_map ∅ e = e.
-Proof.
- assert (∀ x, binder_delete x (∅:gmap _ val) = ∅) as Hdel.
- { intros [|x]; by rewrite /= ?delete_empty. }
- induction e; simplify_map_eq; rewrite ?Hdel; auto with f_equal.
-Qed.
-Lemma subst_map_insert x v vs e :
- subst_map (<[x:=v]>vs) e = subst x v (subst_map (delete x vs) e).
-Proof.
- revert vs. assert (∀ (y : binder) (vs : gmap _ val), y ≠ BNamed x →
- binder_delete y (<[x:=v]> vs) = <[x:=v]> (binder_delete y vs)) as Hins.
- { intros [|y] vs ?; rewrite /= ?delete_insert_ne //; congruence. }
- assert (∀ (y : binder) (vs : gmap _ val),
- binder_delete y (delete x vs) = delete x (binder_delete y vs)) as Hdel.
- { by intros [|y] ?; rewrite /= 1?delete_commute. }
- induction e=> vs; simplify_map_eq; auto with f_equal.
- - match goal with
- | |- context [ <[?x:=_]> _ !! ?y ] =>
- destruct (decide (x = y)); simplify_map_eq=> //
- end. by case (vs !! _); simplify_option_eq.
- - destruct (decide _) as [[??]|[<-%dec_stable|[<-%dec_stable ?]]%not_and_l_alt].
- + rewrite !Hins // !Hdel. eauto with f_equal.
- + by rewrite /= delete_insert_delete delete_idemp.
- + by rewrite /= Hins // delete_insert_delete !Hdel delete_idemp.
-Qed.
-Lemma subst_map_binder_insert b v vs e :
- subst_map (binder_insert b v vs) e =
- subst' b v (subst_map (binder_delete b vs) e).
-Proof. destruct b; rewrite ?subst_map_insert //. Qed.
-
-(* subst_map on closed expressions *)
-Lemma subst_map_is_closed X e vs :
- is_closed_expr X e →
- (∀ x, x ∈ X → vs !! x = None) →
- subst_map vs e = e.
-Proof.
- revert X vs. assert (∀ x x1 x2 X (vs : gmap string val),
- (∀ x, x ∈ X → vs !! x = None) →
- x ∈ x2 :b: x1 :b: X →
- binder_delete x1 (binder_delete x2 vs) !! x = None).
- { intros x x1 x2 X vs ??. rewrite !lookup_binder_delete_None. set_solver. }
- induction e=> X vs /= ? HX; repeat case_match; naive_solver eauto with f_equal.
-Qed.
-
-Lemma subst_map_is_closed_nil e vs : is_closed_expr [] e → subst_map vs e = e.
-Proof. intros. apply subst_map_is_closed with []; set_solver. Qed.
diff --git a/theories/heap_lang/notation.v b/theories/heap_lang/notation.v
deleted file mode 100644
index 07e5df43..00000000
--- a/theories/heap_lang/notation.v
+++ /dev/null
@@ -1,162 +0,0 @@
-From iris.program_logic Require Import language.
-From iris.heap_lang Require Export lang.
-Set Default Proof Using "Type".
-
-Delimit Scope expr_scope with E.
-Delimit Scope val_scope with V.
-
-(** Coercions to make programs easier to type. *)
-Coercion LitInt : Z >-> base_lit.
-Coercion LitBool : bool >-> base_lit.
-Coercion LitLoc : loc >-> base_lit.
-Coercion LitProphecy : proph_id >-> base_lit.
-
-Coercion App : expr >-> Funclass.
-
-Coercion Val : val >-> expr.
-Coercion Var : string >-> expr.
-
-(** Define some derived forms. *)
-Notation Lam x e := (Rec BAnon x e) (only parsing).
-Notation Let x e1 e2 := (App (Lam x e2) e1) (only parsing).
-Notation Seq e1 e2 := (Let BAnon e1 e2) (only parsing).
-Notation LamV x e := (RecV BAnon x e) (only parsing).
-Notation LetCtx x e2 := (AppRCtx (LamV x e2)) (only parsing).
-Notation SeqCtx e2 := (LetCtx BAnon e2) (only parsing).
-Notation Match e0 x1 e1 x2 e2 := (Case e0 (Lam x1 e1) (Lam x2 e2)) (only parsing).
-Notation Alloc e := (AllocN (Val $ LitV $ LitInt 1) e) (only parsing).
-(** Compare-and-set (CAS) returns just a boolean indicating success or failure. *)
-Notation CAS l e1 e2 := (Snd (CmpXchg l e1 e2)) (only parsing).
-
-(* Skip should be atomic, we sometimes open invariants around
- it. Hence, we need to explicitly use LamV instead of e.g., Seq. *)
-Notation Skip := (App (Val $ LamV BAnon (Val $ LitV LitUnit)) (Val $ LitV LitUnit)).
-
-(* No scope for the values, does not conflict and scope is often not inferred
-properly. *)
-Notation "# l" := (LitV l%Z%V%stdpp) (at level 8, format "# l").
-
-(** Syntax inspired by Coq/Ocaml. Constructions with higher precedence come
- first. *)
-Notation "( e1 , e2 , .. , en )" := (Pair .. (Pair e1 e2) .. en) : expr_scope.
-Notation "( e1 , e2 , .. , en )" := (PairV .. (PairV e1 e2) .. en) : val_scope.
-
-(*
-Using the '[hv' ']' printing box, we make sure that when the notation for match
-does not fit on a single line, line breaks will be inserted for *each* breaking
-point '/'. Note that after each breaking point /, one can put n spaces (for
-example '/ '). That way, when the breaking point is turned into a line break,
-indentation of n spaces will appear after the line break. As such, when the
-match does not fit on one line, it will print it like:
-
- match: e0 with
- InjL x1 => e1
- | InjR x2 => e2
- end
-
-Moreover, if the branches do not fit on a single line, it will be printed as:
-
- match: e0 with
- InjL x1 =>
- lots of stuff bla bla bla bla bla bla bla bla
- | InjR x2 =>
- even more stuff bla bla bla bla bla bla bla bla
- end
-*)
-Notation "'match:' e0 'with' 'InjL' x1 => e1 | 'InjR' x2 => e2 'end'" :=
- (Match e0 x1%binder e1 x2%binder e2)
- (e0, x1, e1, x2, e2 at level 200,
- format "'[hv' 'match:' e0 'with' '/ ' '[' 'InjL' x1 => '/ ' e1 ']' '/' '[' | 'InjR' x2 => '/ ' e2 ']' '/' 'end' ']'") : expr_scope.
-Notation "'match:' e0 'with' 'InjR' x1 => e1 | 'InjL' x2 => e2 'end'" :=
- (Match e0 x2%binder e2 x1%binder e1)
- (e0, x1, e1, x2, e2 at level 200, only parsing) : expr_scope.
-
-Notation "()" := LitUnit : val_scope.
-Notation "! e" := (Load e%E) (at level 9, right associativity) : expr_scope.
-Notation "'ref' e" := (Alloc e%E) (at level 10) : expr_scope.
-Notation "- e" := (UnOp MinusUnOp e%E) : expr_scope.
-
-Notation "e1 + e2" := (BinOp PlusOp e1%E e2%E) : expr_scope.
-Notation "e1 +ₗ e2" := (BinOp OffsetOp e1%E e2%E) : expr_scope.
-Notation "e1 - e2" := (BinOp MinusOp e1%E e2%E) : expr_scope.
-Notation "e1 * e2" := (BinOp MultOp e1%E e2%E) : expr_scope.
-Notation "e1 `quot` e2" := (BinOp QuotOp e1%E e2%E) : expr_scope.
-Notation "e1 `rem` e2" := (BinOp RemOp e1%E e2%E) : expr_scope.
-Notation "e1 ≪ e2" := (BinOp ShiftLOp e1%E e2%E) : expr_scope.
-Notation "e1 ≫ e2" := (BinOp ShiftROp e1%E e2%E) : expr_scope.
-
-Notation "e1 ≤ e2" := (BinOp LeOp e1%E e2%E) : expr_scope.
-Notation "e1 < e2" := (BinOp LtOp e1%E e2%E) : expr_scope.
-Notation "e1 = e2" := (BinOp EqOp e1%E e2%E) : expr_scope.
-Notation "e1 ≠ e2" := (UnOp NegOp (BinOp EqOp e1%E e2%E)) : expr_scope.
-
-Notation "~ e" := (UnOp NegOp e%E) (at level 75, right associativity) : expr_scope.
-(* The unicode ← is already part of the notation "_ ← _; _" for bind. *)
-Notation "e1 <- e2" := (Store e1%E e2%E) (at level 80) : expr_scope.
-
-(* The breaking point '/ ' makes sure that the body of the rec is indented
-by two spaces in case the whole rec does not fit on a single line. *)
-Notation "'rec:' f x := e" := (Rec f%binder x%binder e%E)
- (at level 200, f at level 1, x at level 1, e at level 200,
- format "'[' 'rec:' f x := '/ ' e ']'") : expr_scope.
-Notation "'rec:' f x := e" := (RecV f%binder x%binder e%E)
- (at level 200, f at level 1, x at level 1, e at level 200,
- format "'[' 'rec:' f x := '/ ' e ']'") : val_scope.
-Notation "'if:' e1 'then' e2 'else' e3" := (If e1%E e2%E e3%E)
- (at level 200, e1, e2, e3 at level 200) : expr_scope.
-
-(** Derived notions, in order of declaration. The notations for let and seq
-are stated explicitly instead of relying on the Notations Let and Seq as
-defined above. This is needed because App is now a coercion, and these
-notations are otherwise not pretty printed back accordingly. *)
-Notation "'rec:' f x y .. z := e" := (Rec f%binder x%binder (Lam y%binder .. (Lam z%binder e%E) ..))
- (at level 200, f, x, y, z at level 1, e at level 200,
- format "'[' 'rec:' f x y .. z := '/ ' e ']'") : expr_scope.
-Notation "'rec:' f x y .. z := e" := (RecV f%binder x%binder (Lam y%binder .. (Lam z%binder e%E) ..))
- (at level 200, f, x, y, z at level 1, e at level 200,
- format "'[' 'rec:' f x y .. z := '/ ' e ']'") : val_scope.
-
-(* The breaking point '/ ' makes sure that the body of the λ: is indented
-by two spaces in case the whole λ: does not fit on a single line. *)
-Notation "λ: x , e" := (Lam x%binder e%E)
- (at level 200, x at level 1, e at level 200,
- format "'[' 'λ:' x , '/ ' e ']'") : expr_scope.
-Notation "λ: x y .. z , e" := (Lam x%binder (Lam y%binder .. (Lam z%binder e%E) ..))
- (at level 200, x, y, z at level 1, e at level 200,
- format "'[' 'λ:' x y .. z , '/ ' e ']'") : expr_scope.
-
-Notation "λ: x , e" := (LamV x%binder e%E)
- (at level 200, x at level 1, e at level 200,
- format "'[' 'λ:' x , '/ ' e ']'") : val_scope.
-Notation "λ: x y .. z , e" := (LamV x%binder (Lam y%binder .. (Lam z%binder e%E) .. ))
- (at level 200, x, y, z at level 1, e at level 200,
- format "'[' 'λ:' x y .. z , '/ ' e ']'") : val_scope.
-
-Notation "'let:' x := e1 'in' e2" := (Lam x%binder e2%E e1%E)
- (at level 200, x at level 1, e1, e2 at level 200,
- format "'[' 'let:' x := '[' e1 ']' 'in' '/' e2 ']'") : expr_scope.
-Notation "e1 ;; e2" := (Lam BAnon e2%E e1%E)
- (at level 100, e2 at level 200,
- format "'[' '[hv' '[' e1 ']' ;; ']' '/' e2 ']'") : expr_scope.
-
-(* Shortcircuit Boolean connectives *)
-Notation "e1 && e2" :=
- (If e1%E e2%E (LitV (LitBool false))) (only parsing) : expr_scope.
-Notation "e1 || e2" :=
- (If e1%E (LitV (LitBool true)) e2%E) (only parsing) : expr_scope.
-
-(** Notations for option *)
-Notation NONE := (InjL (LitV LitUnit)) (only parsing).
-Notation NONEV := (InjLV (LitV LitUnit)) (only parsing).
-Notation SOME x := (InjR x) (only parsing).
-Notation SOMEV x := (InjRV x) (only parsing).
-
-Notation "'match:' e0 'with' 'NONE' => e1 | 'SOME' x => e2 'end'" :=
- (Match e0 BAnon e1 x%binder e2)
- (e0, e1, x, e2 at level 200, only parsing) : expr_scope.
-Notation "'match:' e0 'with' 'SOME' x => e2 | 'NONE' => e1 'end'" :=
- (Match e0 BAnon e1 x%binder e2)
- (e0, e1, x, e2 at level 200, only parsing) : expr_scope.
-
-Notation ResolveProph e1 e2 := (Resolve Skip e1 e2) (only parsing).
-Notation "'resolve_proph:' p 'to:' v" := (ResolveProph p v) (at level 100) : expr_scope.
diff --git a/theories/heap_lang/proofmode.v b/theories/heap_lang/proofmode.v
deleted file mode 100644
index a48afd52..00000000
--- a/theories/heap_lang/proofmode.v
+++ /dev/null
@@ -1,1007 +0,0 @@
-From iris.program_logic Require Export weakestpre.
-From iris.program_logic.refinement Require Export ref_weakestpre tc_weakestpre.
-From iris.proofmode Require Import coq_tactics reduction.
-From iris.proofmode Require Export tactics.
-From iris.heap_lang Require Export tactics lifting.
-From iris.heap_lang Require Import notation.
-Set Default Proof Using "Type".
-Import uPred.
-
-Lemma tac_wp_expr_eval {SI} {Σ: gFunctors SI} `{!heapG Σ} Δ s E Φ e e' :
- (∀ (e'':=e'), e = e'') →
- envs_entails Δ (WP e' @ s; E {{ Φ }}) → envs_entails Δ (WP e @ s; E {{ Φ }}).
-Proof. by intros ->. Qed.
-Lemma tac_swp_expr_eval {SI} {Σ: gFunctors SI} `{!heapG Σ} k Δ s E Φ e e' :
- (∀ (e'':=e'), e = e'') →
- envs_entails Δ (SWP e' at k @ s; E {{ Φ }}) → envs_entails Δ (SWP e at k @ s; E {{ Φ }}).
-Proof. by intros ->. Qed.
-Lemma tac_rwp_expr_eval {SI A} {Σ: gFunctors SI} `{!heapG Σ} `{!source Σ A} Δ s E Φ e e' :
- (∀ (e'':=e'), e = e'') →
- envs_entails Δ (RWP e' @ s; E ⟨⟨ Φ ⟩⟩) → envs_entails Δ (RWP e @ s; E ⟨⟨ Φ ⟩⟩).
-Proof. by intros ->. Qed.
-Lemma tac_rswp_expr_eval {SI A} {Σ: gFunctors SI} `{!heapG Σ} `{!source Σ A} k Δ s E Φ e e' :
- (∀ (e'':=e'), e = e'') →
- envs_entails Δ (RSWP e' at k @ s; E ⟨⟨ Φ ⟩⟩) → envs_entails Δ (RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩).
-Proof. by intros ->. Qed.
-Lemma tac_twp_expr_eval {SI} {Σ: gFunctors SI} `{!heapG Σ} `{tcG Σ} Δ s E Φ e e' :
- (∀ (e'':=e'), e = e'') →
- envs_entails Δ (WP e' @ s; E [{ Φ }]) → envs_entails Δ (WP e @ s; E [{ Φ }]).
-Proof. by intros ->. Qed.
-
-Tactic Notation "wp_expr_eval" tactic(t) :=
- iStartProof;
- lazymatch goal with
- | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
- eapply tac_wp_expr_eval;
- [let x := fresh in intros x; t; unfold x; reflexivity|]
- | |- envs_entails _ (swp ?k ?s ?E ?e ?Q) =>
- eapply tac_swp_expr_eval;
- [let x := fresh in intros x; t; unfold x; reflexivity|]
- | |- envs_entails _ (rwp ?s ?E ?e ?Q) =>
- eapply tac_rwp_expr_eval;
- [let x := fresh in intros x; t; unfold x; reflexivity|]
- | |- envs_entails _ (rswp ?k ?s ?E ?e ?Q) =>
- eapply tac_rswp_expr_eval;
- [let x := fresh in intros x; t; unfold x; reflexivity|]
- | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
- eapply tac_twp_expr_eval;
- [let x := fresh in intros x; t; unfold x; reflexivity|]
- | _ => fail "wp_expr_eval: not a 'wp'"
- end.
-
-Lemma tac_wp_pure {SI} {Σ: gFunctors SI} `{!heapG Σ} Δ Δ' s E e1 e2 φ n Φ :
- PureExec φ n e1 e2 →
- φ →
- MaybeIntoLaterNEnvs n Δ Δ' →
- envs_entails Δ' (WP e2 @ s; E {{ Φ }}) →
- envs_entails Δ (WP e1 @ s; E {{ Φ }}).
-Proof.
- rewrite envs_entails_eq=> ??? HΔ'. rewrite into_laterN_env_sound /=.
- rewrite HΔ' -lifting.wp_pure_step_later //.
-Qed.
-Lemma tac_swp_pure {SI} {Σ: gFunctors SI} `{!heapG Σ} k Δ Δ' s E e1 e2 φ n Φ :
- PureExec φ (S n) e1 e2 →
- φ →
- MaybeIntoLaterNEnvs (S n) Δ Δ' →
- envs_entails Δ' (WP e2 @ s; E {{ Φ }}) →
- envs_entails Δ (SWP e1 at k @ s; E {{ Φ }}).
-Proof.
- rewrite envs_entails_eq=> Hsteps H ? HΔ'. rewrite into_laterN_env_sound /=.
- rewrite HΔ'. by rewrite -lifting.swp_pure_step_later //.
-Qed.
-Lemma tac_rwp_pure {SI A} {Σ: gFunctors SI} `{!heapG Σ} `{!source Σ A} Δ s E e1 e2 φ n Φ :
- PureExec φ n e1 e2 →
- φ →
- envs_entails Δ (RWP e2 @ s; E ⟨⟨ Φ ⟩⟩) →
- envs_entails Δ (RWP e1 @ s; E ⟨⟨ Φ ⟩⟩).
-Proof.
- rewrite envs_entails_eq=> ??. rewrite -ref_lifting.rwp_pure_step //.
-Qed.
-Lemma tac_rswp_pure {SI A} {Σ: gFunctors SI} `{!heapG Σ} `{!source Σ A} Δ Δ' s E k e1 e2 φ Φ :
- PureExec φ 1 e1 e2 →
- φ →
- MaybeIntoLaterNEnvs k Δ Δ' →
- envs_entails Δ' (RWP e2 @ s; E ⟨⟨ Φ ⟩⟩) →
- envs_entails Δ (RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩).
-Proof.
- rewrite envs_entails_eq=> Hsteps Hφ ? HΔ'. rewrite into_laterN_env_sound /=.
- rewrite HΔ'. by rewrite -ref_lifting.rswp_pure_step_later //.
-Qed.
-Lemma tac_twp_pure {SI} {Σ: gFunctors SI} `{!heapG Σ} `{tcG Σ} Δ s E e1 e2 φ n Φ :
- PureExec φ n e1 e2 →
- φ →
- envs_entails Δ (WP e2 @ s; E [{ Φ }]) →
- envs_entails Δ (WP e1 @ s; E [{ Φ }]).
-Proof.
- apply tac_rwp_pure.
-Qed.
-
-Lemma tac_wp_value {SI} {Σ: gFunctors SI} `{!heapG Σ} Δ s E Φ v :
- envs_entails Δ (Φ v) → envs_entails Δ (WP (Val v) @ s; E {{ Φ }}).
-Proof. rewrite envs_entails_eq=> ->. by apply wp_value. Qed.
-Lemma tac_rwp_value {SI} {Σ: gFunctors SI} `{!heapG Σ} `{!source Σ A} Δ s E Φ v :
- envs_entails Δ (Φ v) → envs_entails Δ (RWP (Val v) @ s; E ⟨⟨ Φ ⟩⟩).
-Proof. rewrite envs_entails_eq=> ->. by apply rwp_value. Qed.
-Lemma tac_twp_value {SI} {Σ: gFunctors SI} `{!heapG Σ} `{tcG Σ} Δ s E Φ v :
- envs_entails Δ (Φ v) → envs_entails Δ (WP (Val v) @ s; E [{ Φ }]).
-Proof. apply tac_rwp_value. Qed.
-
-Ltac wp_expr_simpl := wp_expr_eval simpl.
-
-Ltac wp_value_head :=
- first [eapply tac_wp_value || eapply tac_rwp_value || eapply tac_twp_value].
-
-Ltac wp_finish :=
- wp_expr_simpl; (* simplify occurences of subst/fill *)
- try wp_value_head; (* in case we have reached a value, get rid of the WP *)
- pm_prettify. (* prettify ▷s caused by [MaybeIntoLaterNEnvs] and
- λs caused by wp_value *)
-
-Ltac solve_vals_compare_safe :=
- (* The first branch is for when we have [vals_compare_safe] in the context.
- The other two branches are for when either one of the branches reduces to
- [True] or we have it in the context. *)
- fast_done || (left; fast_done) || (right; fast_done).
-
-(** The argument [efoc] can be used to specify the construct that should be
-reduced. For example, you can write [wp_pure (EIf _ _ _)], which will search
-for an [EIf _ _ _] in the expression, and reduce it.
-
-The use of [open_constr] in this tactic is essential. It will convert all holes
-(i.e. [_]s) into evars, that later get unified when an occurences is found
-(see [unify e' efoc] in the code below). *)
-Tactic Notation "wp_pure" open_constr(efoc) :=
- iStartProof;
- lazymatch goal with
- | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
- let e := eval simpl in e in
- reshape_expr e ltac:(fun K e' =>
- unify e' efoc;
- eapply (tac_wp_pure _ _ _ _ (fill K e'));
- [iSolveTC (* PureExec *)
- |try solve_vals_compare_safe (* The pure condition for PureExec -- handles trivial goals, including [vals_compare_safe] *)
- |iSolveTC (* IntoLaters *)
- |wp_finish (* new goal *)
- ])
- || fail "wp_pure: cannot find" efoc "in" e "or" efoc "is not a redex"
- | |- envs_entails _ (rwp ?s ?E ?e ?Q) =>
- let e := eval simpl in e in
- reshape_expr e ltac:(fun K e' =>
- unify e' efoc;
- eapply (tac_rwp_pure _ _ _ (fill K e'));
- [iSolveTC (* PureExec *)
- |try fast_done (* The pure condition for PureExec *)
- |wp_finish (* new goal *)
- ])
- || fail "wp_pure – rwp: cannot find" efoc "in" e "or" efoc "is not a redex"
- | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
- let e := eval simpl in e in
- reshape_expr e ltac:(fun K e' =>
- unify e' efoc;
- eapply (tac_twp_pure _ _ _ (fill K e'));
- [iSolveTC (* PureExec *)
- |try fast_done (* The pure condition for PureExec *)
- |wp_finish (* new goal *)
- ])
- || fail "wp_pure – twp: cannot find" efoc "in" e "or" efoc "is not a redex"
- | |- envs_entails _ (swp ?k ?s ?E ?e ?Q) =>
- let e := eval simpl in e in
- reshape_expr e ltac:(fun K e' =>
- unify e' efoc;
- eapply (tac_swp_pure _ _ _ _ _ (fill K e'));
- [ iSolveTC (* PureExec *)
- | try fast_done (* The pure condition for PureExec *)
- | apply _
- | simpl; wp_finish (* new goal *)
- ])
- || fail "wp_pure: cannot find" efoc "in" e "or" efoc "is not a redex"
- | |- envs_entails _ (rswp ?k ?s ?E ?e ?Q) =>
- let e := eval simpl in e in
- reshape_expr e ltac:(fun K e' =>
- unify e' efoc;
- eapply (tac_rswp_pure _ _ _ _ _ (fill K e'));
- [ iSolveTC (* PureExec *)
- | try fast_done (* The pure condition for PureExec *)
- | apply _
- | simpl; wp_finish (* new goal *)
- ])
- || fail "wp_pure: cannot find" efoc "in" e "or" efoc "is not a redex"
- | _ => fail "wp_pure: not a 'wp'"
- end.
-
-(* TODO: do this in one go, without [repeat]. *)
-Ltac wp_pures :=
- iStartProof;
- repeat (wp_pure _; []). (* The `;[]` makes sure that no side-condition
- magically spawns. *)
-
-(** Unlike [wp_pures], the tactics [wp_rec] and [wp_lam] should also reduce
-lambdas/recs that are hidden behind a definition, i.e. they should use
-[AsRecV_recv] as a proper instance instead of a [Hint Extern].
-
-We achieve this by putting [AsRecV_recv] in the current environment so that it
-can be used as an instance by the typeclass resolution system. We then perform
-the reduction, and finally we clear this new hypothesis. *)
-Tactic Notation "wp_rec" :=
- let H := fresh in
- assert (H := AsRecV_recv);
- wp_pure (App _ _);
- clear H.
-
-Tactic Notation "wp_if" := wp_pure (If _ _ _).
-Tactic Notation "wp_if_true" := wp_pure (If (LitV (LitBool true)) _ _).
-Tactic Notation "wp_if_false" := wp_pure (If (LitV (LitBool false)) _ _).
-Tactic Notation "wp_unop" := wp_pure (UnOp _ _).
-Tactic Notation "wp_binop" := wp_pure (BinOp _ _ _).
-Tactic Notation "wp_op" := wp_unop || wp_binop.
-Tactic Notation "wp_lam" := wp_rec.
-Tactic Notation "wp_let" := wp_pure (Rec BAnon (BNamed _) _); wp_lam.
-Tactic Notation "wp_seq" := wp_pure (Rec BAnon BAnon _); wp_lam.
-Tactic Notation "wp_proj" := wp_pure (Fst _) || wp_pure (Snd _).
-Tactic Notation "wp_case" := wp_pure (Case _ _ _).
-Tactic Notation "wp_match" := wp_case; wp_pure (Rec _ _ _); wp_lam.
-Tactic Notation "wp_inj" := wp_pure (InjL _) || wp_pure (InjR _).
-Tactic Notation "wp_pair" := wp_pure (Pair _ _).
-Tactic Notation "wp_closure" := wp_pure (Rec _ _ _).
-
-
-(* SWP Tactics *)
-(* TODO: figure out the right tactics here *)
-Tactic Notation "wp_swp" constr(k) := iApply (swp_wp k); first done.
-Tactic Notation "wp_swp" := iApply (swp_wp _); first done.
-Tactic Notation "swp_step" := iApply (swp_step _).
-Tactic Notation "swp_last_step" := swp_step; iApply swp_finish.
-Tactic Notation "swp_finish" := iApply swp_finish.
-
-Lemma tac_wp_bind {SI} {Σ: gFunctors SI} `{!heapG Σ} K Δ s E Φ e f :
- f = (λ e, fill K e) → (* as an eta expanded hypothesis so that we can `simpl` it *)
- envs_entails Δ (WP e @ s; E {{ v, WP f (Val v) @ s; E {{ Φ }} }})%I →
- envs_entails Δ (WP fill K e @ s; E {{ Φ }}).
-Proof. rewrite envs_entails_eq=> -> ->. by apply: wp_bind. Qed.
-Lemma tac_swp_bind {SI} {Σ: gFunctors SI} `{!heapG Σ} k K Δ s E Φ e f :
- language.to_val e = None →
- f = (λ e, fill K e) → (* as an eta expanded hypothesis so that we can `simpl` it *)
- envs_entails Δ (SWP e at k @ s; E {{ v, WP f (Val v) @ s; E {{ Φ }} }})%I →
- envs_entails Δ (SWP fill K e at k @ s; E {{ Φ }}).
-Proof. rewrite envs_entails_eq=> ? -> ->. by apply: swp_bind. Qed.
-Lemma tac_rwp_bind {SI A} {Σ: gFunctors SI} `{!heapG Σ} `{!source Σ A} K Δ s E Φ e f :
- f = (λ e, fill K e) → (* as an eta expanded hypothesis so that we can `simpl` it *)
- envs_entails Δ (RWP e @ s; E ⟨⟨ v, RWP f (Val v) @ s; E ⟨⟨ Φ ⟩⟩ ⟩⟩)%I →
- envs_entails Δ (RWP fill K e @ s; E ⟨⟨ Φ ⟩⟩).
-Proof. rewrite envs_entails_eq=> -> ->. by apply: rwp_bind. Qed.
-Lemma tac_rswp_bind {SI A} {Σ: gFunctors SI} `{!heapG Σ} `{!source Σ A} k K Δ s E Φ e f :
- language.to_val e = None →
- f = (λ e, fill K e) → (* as an eta expanded hypothesis so that we can `simpl` it *)
- envs_entails Δ (RSWP e at k @ s; E ⟨⟨ v, RWP f (Val v) @ s; E ⟨⟨ Φ ⟩⟩ ⟩⟩)%I →
- envs_entails Δ (RSWP fill K e at k @ s; E ⟨⟨ Φ ⟩⟩).
-Proof. rewrite envs_entails_eq=> ? -> ->. by apply: rswp_bind. Qed.
-Lemma tac_twp_bind {SI} {Σ: gFunctors SI} `{!heapG Σ} `{tcG Σ} K Δ s E Φ e f :
- f = (λ e, fill K e) → (* as an eta expanded hypothesis so that we can `simpl` it *)
- envs_entails Δ (WP e @ s; E [{ v, WP f (Val v) @ s; E [{ Φ }] }])%I →
- envs_entails Δ (WP fill K e @ s; E [{ Φ }]).
-Proof. rewrite envs_entails_eq=> -> ->. by apply: rwp_bind. Qed.
-
-Ltac wp_bind_core K :=
- lazymatch eval hnf in K with
- | [] => idtac
- | _ => eapply (tac_wp_bind K); [simpl; reflexivity|reduction.pm_prettify]
- end.
-Ltac swp_bind_core K :=
- lazymatch eval hnf in K with
- | [] => idtac
- | _ => eapply (tac_swp_bind _ K);[done| simpl; reflexivity|reduction.pm_prettify]
- end.
-Ltac rwp_bind_core K :=
- lazymatch eval hnf in K with
- | [] => idtac
- | _ => eapply (tac_rwp_bind K); [simpl; reflexivity|reduction.pm_prettify]
- end.
-Ltac rswp_bind_core K :=
- lazymatch eval hnf in K with
- | [] => idtac
- | _ => eapply (tac_rswp_bind _ K);[done| simpl; reflexivity|reduction.pm_prettify]
- end.
-Ltac twp_bind_core K :=
- lazymatch eval hnf in K with
- | [] => idtac
- | _ => eapply (tac_twp_bind K); [simpl; reflexivity|reduction.pm_prettify]
- end.
-
-Tactic Notation "wp_bind" open_constr(efoc) :=
- iStartProof;
- lazymatch goal with
- | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
- reshape_expr e ltac:(fun K e' => unify e' efoc; wp_bind_core K)
- || fail "wp_bind: cannot find" efoc "in" e
- | |- envs_entails _ (swp ?k ?s ?E ?e ?Q) =>
- reshape_expr e ltac:(fun K e' => unify e' efoc; swp_bind_core K)
- || fail "wp_bind: cannot find" efoc "in" e
- | |- envs_entails _ (rwp ?s ?E ?e ?Q) =>
- reshape_expr e ltac:(fun K e' => unify e' efoc; rwp_bind_core K)
- || fail "wp_bind: cannot find" efoc "in" e
- | |- envs_entails _ (rswp ?k ?s ?E ?e ?Q) =>
- reshape_expr e ltac:(fun K e' => unify e' efoc; rswp_bind_core K)
- || fail "wp_bind: cannot find" efoc "in" e
- | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
- reshape_expr e ltac:(fun K e' => unify e' efoc; twp_bind_core K)
- || fail "wp_bind: cannot find" efoc "in" e
- | _ => fail "wp_bind: not a 'wp'"
- end.
-
-(** Heap tactics *)
-Section heap.
-Context {SI} {Σ: gFunctors SI} `{!heapG Σ} .
-Implicit Types P Q : iProp Σ.
-Implicit Types Φ : val → iProp Σ.
-Implicit Types Δ : envs (uPredI (iResUR Σ)).
-Implicit Types v : val.
-Implicit Types z : Z.
-
-Lemma tac_wp_allocN Δ Δ' s E j K v n Φ :
- 0 < n →
- MaybeIntoLaterNEnvs 1 Δ Δ' →
- (∀ l, ∃ Δ'',
- envs_app false (Esnoc Enil j (array l (replicate (Z.to_nat n) v))) Δ' = Some Δ'' ∧
- envs_entails Δ'' (WP fill K (Val $ LitV $ LitLoc l) @ s; E {{ Φ }})) →
- envs_entails Δ (WP fill K (AllocN (Val $ LitV $ LitInt n) (Val v)) @ s; E {{ Φ }}).
-Proof.
- rewrite envs_entails_eq=> ? ? HΔ.
- rewrite -wp_bind. eapply wand_apply; first exact: wp_allocN.
- rewrite left_id into_laterN_env_sound; apply later_mono, forall_intro=> l.
- destruct (HΔ l) as (Δ''&?&HΔ'). rewrite envs_app_sound //; simpl.
- apply wand_intro_l. by rewrite (sep_elim_l (l ↦∗ _)%I) right_id wand_elim_r.
-Qed.
-Lemma tac_swp_allocN k Δ Δ' s E j K v n Φ :
- 0 < n →
- MaybeIntoLaterNEnvs 1 Δ Δ' →
- (∀ l, ∃ Δ'',
- envs_app false (Esnoc Enil j (array l (replicate (Z.to_nat n) v))) Δ' = Some Δ'' ∧
- envs_entails Δ'' (WP fill K (Val $ LitV $ LitLoc l) @ s; E {{ Φ }})) →
- envs_entails Δ (SWP fill K (AllocN (Val $ LitV $ LitInt n) (Val v)) at k @ s; E {{ Φ }}).
-Proof.
- rewrite envs_entails_eq=> ? ? HΔ.
- rewrite -swp_bind; last done. eapply wand_apply; first exact: swp_allocN.
- rewrite left_id into_laterN_env_sound; apply later_mono, forall_intro=> l.
- destruct (HΔ l) as (Δ''&?&HΔ'). rewrite envs_app_sound //; simpl.
- apply wand_intro_l. by rewrite (sep_elim_l (l ↦∗ _)%I) right_id wand_elim_r.
-Qed.
-Lemma tac_rwp_allocN {A} `{!source Σ A} Δ s E j K v n Φ :
- 0 < n →
- (∀ l, ∃ Δ'',
- envs_app false (Esnoc Enil j (array l (replicate (Z.to_nat n) v))) Δ = Some Δ'' ∧
- envs_entails Δ'' (RWP fill K (Val $ LitV $ LitLoc l) @ s; E ⟨⟨ Φ ⟩⟩)) →
- envs_entails Δ (RWP fill K (AllocN (Val $ LitV $ LitInt n) (Val v)) @ s; E ⟨⟨ Φ ⟩⟩).
-Proof.
- rewrite envs_entails_eq=> ? HΔ.
- rewrite -rwp_bind. eapply wand_apply; first exact: rwp_allocN.
- rewrite left_id; apply forall_intro=> l.
- destruct (HΔ l) as (Δ''&?&HΔ'). rewrite envs_app_sound //; simpl.
- apply wand_intro_l. by rewrite (sep_elim_l (l ↦∗ _)%I) right_id wand_elim_r.
-Qed.
-Lemma tac_rswp_allocN {A} `{!source Σ A} k Δ Δ' s E j K v n Φ :
- 0 < n →
- MaybeIntoLaterNEnvs k Δ Δ' →
- (∀ l, ∃ Δ'',
- envs_app false (Esnoc Enil j (array l (replicate (Z.to_nat n) v))) Δ' = Some Δ'' ∧
- envs_entails Δ'' (RWP fill K (Val $ LitV $ LitLoc l) @ s; E ⟨⟨ Φ ⟩⟩)) →
- envs_entails Δ (RSWP fill K (AllocN (Val $ LitV $ LitInt n) (Val v)) at k @ s; E ⟨⟨ Φ ⟩⟩).
-Proof.
- rewrite envs_entails_eq=> ? ? HΔ.
- rewrite -rswp_bind; last done. eapply wand_apply; first exact: rswp_allocN.
- rewrite left_id into_laterN_env_sound; apply laterN_mono, forall_intro=> l.
- destruct (HΔ l) as (Δ''&?&HΔ'). rewrite envs_app_sound //; simpl.
- apply wand_intro_l. by rewrite (sep_elim_l (l ↦∗ _)%I) right_id wand_elim_r.
-Qed.
-Lemma tac_twp_allocN `{!tcG Σ} Δ s E j K v n Φ :
- 0 < n →
- (∀ l, ∃ Δ',
- envs_app false (Esnoc Enil j (array l (replicate (Z.to_nat n) v))) Δ
- = Some Δ' ∧
- envs_entails Δ' (WP fill K (Val $ LitV $ LitLoc l) @ s; E [{ Φ }])) →
- envs_entails Δ (WP fill K (AllocN (Val $ LitV $ LitInt n) (Val v)) @ s; E [{ Φ }]).
-Proof.
- apply tac_rwp_allocN.
-Qed.
-
-Lemma tac_wp_alloc Δ Δ' s E j K v Φ :
- MaybeIntoLaterNEnvs 1 Δ Δ' →
- (∀ l, ∃ Δ'',
- envs_app false (Esnoc Enil j (l ↦ v)) Δ' = Some Δ'' ∧
- envs_entails Δ'' (WP fill K (Val $ LitV l) @ s; E {{ Φ }})) →
- envs_entails Δ (WP fill K (Alloc (Val v)) @ s; E {{ Φ }}).
-Proof.
- rewrite envs_entails_eq=> ? HΔ.
- rewrite -wp_bind. eapply wand_apply; first exact: wp_alloc.
- rewrite left_id into_laterN_env_sound; apply later_mono, forall_intro=> l.
- destruct (HΔ l) as (Δ''&?&HΔ'). rewrite envs_app_sound //; simpl.
- apply wand_intro_l. by rewrite (sep_elim_l (l ↦ v)%I) right_id wand_elim_r.
-Qed.
-Lemma tac_swp_alloc k Δ Δ' s E j K v Φ :
- MaybeIntoLaterNEnvs 1 Δ Δ' →
- (∀ l, ∃ Δ'',
- envs_app false (Esnoc Enil j (l ↦ v)) Δ' = Some Δ'' ∧
- envs_entails Δ'' (WP fill K (Val $ LitV l) @ s; E {{ Φ }})) →
- envs_entails Δ (SWP fill K (Alloc (Val v)) at k @ s; E {{ Φ }}).
-Proof.
- rewrite envs_entails_eq=> ? HΔ.
- rewrite -swp_bind; last done. eapply wand_apply; first exact: swp_alloc.
- rewrite left_id into_laterN_env_sound; apply later_mono, forall_intro=> l.
- destruct (HΔ l) as (Δ''&?&HΔ'). rewrite envs_app_sound //; simpl.
- apply wand_intro_l. by rewrite (sep_elim_l (l ↦ v)%I) right_id wand_elim_r.
-Qed.
-Lemma tac_rwp_alloc {A} `{!source Σ A} Δ s E j K v Φ :
- (∀ l, ∃ Δ'',
- envs_app false (Esnoc Enil j (l ↦ v)) Δ = Some Δ'' ∧
- envs_entails Δ'' (RWP fill K (Val $ LitV l) @ s; E ⟨⟨ Φ ⟩⟩)) →
- envs_entails Δ (RWP fill K (Alloc (Val v)) @ s; E ⟨⟨ Φ ⟩⟩).
-Proof.
- rewrite envs_entails_eq=> HΔ.
- rewrite -rwp_bind. eapply wand_apply; first exact: rwp_alloc.
- rewrite left_id; apply forall_intro=> l.
- destruct (HΔ l) as (Δ''&?&HΔ'). rewrite envs_app_sound //; simpl.
- apply wand_intro_l. by rewrite (sep_elim_l (l ↦ v)%I) right_id wand_elim_r.
-Qed.
-Lemma tac_rswp_alloc {A} `{!source Σ A} k Δ Δ' s E j K v Φ :
- MaybeIntoLaterNEnvs k Δ Δ' →
- (∀ l, ∃ Δ'',
- envs_app false (Esnoc Enil j (l ↦ v)) Δ' = Some Δ'' ∧
- envs_entails Δ'' (RWP fill K (Val $ LitV l) @ s; E ⟨⟨ Φ ⟩⟩)) →
- envs_entails Δ (RSWP fill K (Alloc (Val v)) at k @ s; E ⟨⟨ Φ ⟩⟩).
-Proof.
- rewrite envs_entails_eq=> ? HΔ.
- rewrite -rswp_bind; last done. eapply wand_apply; first exact: rswp_alloc.
- rewrite left_id into_laterN_env_sound; apply laterN_mono, forall_intro=> l.
- destruct (HΔ l) as (Δ''&?&HΔ'). rewrite envs_app_sound //; simpl.
- apply wand_intro_l. by rewrite (sep_elim_l (l ↦ v)%I) right_id wand_elim_r.
-Qed.
-Lemma tac_twp_alloc `{!tcG Σ} Δ s E j K v Φ :
- (∀ l, ∃ Δ',
- envs_app false (Esnoc Enil j (l ↦ v)) Δ = Some Δ' ∧
- envs_entails Δ' (WP fill K (Val $ LitV $ LitLoc l) @ s; E [{ Φ }])) →
- envs_entails Δ (WP fill K (Alloc (Val v)) @ s; E [{ Φ }]).
-Proof.
- apply tac_rwp_alloc.
-Qed.
-
-Lemma tac_wp_load Δ Δ' s E i K l q v Φ :
- MaybeIntoLaterNEnvs 1 Δ Δ' →
- envs_lookup i Δ' = Some (false, l ↦{q} v)%I →
- envs_entails Δ' (WP fill K (Val v) @ s; E {{ Φ }}) →
- envs_entails Δ (WP fill K (Load (LitV l)) @ s; E {{ Φ }}).
-Proof.
- rewrite envs_entails_eq=> ???.
- rewrite -wp_bind -(swp_wp 1) // -swp_step into_laterN_env_sound.
- apply later_mono.
- eapply wand_apply; first exact: swp_load.
- rewrite envs_lookup_split // -!later_intro; simpl.
- by apply sep_mono_r, wand_mono.
-Qed.
-Lemma tac_swp_load k Δ s E i K l q v Φ :
- envs_lookup i Δ = Some (false, l ↦{q} v)%I →
- envs_entails Δ (WP fill K (Val v) @ s; E {{ Φ }}) →
- envs_entails Δ (SWP fill K (Load (LitV l)) at k @ s; E {{ Φ }}).
-Proof.
- rewrite envs_entails_eq=> ??.
- rewrite -swp_bind; last done. eapply wand_apply; first exact: swp_load.
- rewrite envs_lookup_split // -!later_intro; simpl.
- by apply sep_mono_r, wand_mono.
-Qed.
-Lemma tac_rswp_load {A} `{!source Σ A} k Δ s E i K l q v Φ :
- envs_lookup i Δ = Some (false, l ↦{q} v)%I →
- envs_entails Δ (RWP fill K (Val v) @ s; E ⟨⟨ Φ ⟩⟩) →
- envs_entails Δ (RSWP fill K (Load (LitV l)) at k @ s; E ⟨⟨ Φ ⟩⟩).
-Proof.
- rewrite envs_entails_eq=> ? HΔ.
- rewrite -rswp_bind; last done. eapply wand_apply; first exact: rswp_load.
- rewrite envs_lookup_split//; simpl.
- by rewrite -!later_intro -laterN_intro HΔ.
-Qed.
-Lemma tac_rwp_load {A} `{!source Σ A} Δ s E i K l q v Φ :
- envs_lookup i Δ = Some (false, l ↦{q} v)%I →
- envs_entails Δ (RWP fill K (Val v) @ s; E ⟨⟨ Φ ⟩⟩) →
- envs_entails Δ (RWP fill K (Load (LitV l)) @ s; E ⟨⟨ Φ ⟩⟩).
-Proof.
- intros ??. rewrite -rwp_no_step; first by eapply tac_rswp_load.
- by eapply to_val_fill_none.
-Qed.
-Lemma tac_twp_load `{!tcG Σ} Δ s E i K l q v Φ :
- envs_lookup i Δ = Some (false, l ↦{q} v)%I →
- envs_entails Δ (WP fill K (Val v) @ s; E [{Φ}]) →
- envs_entails Δ (WP fill K (Load (LitV l)) @ s; E [{Φ}]).
-Proof.
- apply tac_rwp_load.
-Qed.
-
-Lemma tac_wp_store Δ Δ' Δ'' s E i K l v v' Φ :
- MaybeIntoLaterNEnvs 1 Δ Δ' →
- envs_lookup i Δ' = Some (false, l ↦ v)%I →
- envs_simple_replace i false (Esnoc Enil i (l ↦ v')) Δ' = Some Δ'' →
- envs_entails Δ'' (WP fill K (Val $ LitV LitUnit) @ s; E {{ Φ }}) →
- envs_entails Δ (WP fill K (Store (LitV l) (Val v')) @ s; E {{ Φ }}).
-Proof.
- rewrite envs_entails_eq=> ????.
- rewrite -wp_bind -(swp_wp 1) // -swp_step into_laterN_env_sound.
- eapply later_mono, wand_apply; first by eapply swp_store.
- rewrite -!later_intro envs_simple_replace_sound //; simpl.
- rewrite right_id. by apply sep_mono_r, wand_mono.
-Qed.
-Lemma tac_swp_store k Δ Δ' s E i K l v v' Φ :
- envs_lookup i Δ = Some (false, l ↦ v)%I →
- envs_simple_replace i false (Esnoc Enil i (l ↦ v')) Δ = Some Δ' →
- envs_entails Δ' (WP fill K (Val $ LitV LitUnit) @ s; E {{ Φ }}) →
- envs_entails Δ (SWP fill K (Store (LitV l) v') at k @ s; E {{ Φ }}).
-Proof.
- rewrite envs_entails_eq. intros. rewrite -swp_bind; last done.
- eapply wand_apply; first by eapply swp_store.
- rewrite envs_simple_replace_sound // -!later_intro; simpl.
- rewrite right_id. by apply sep_mono_r, wand_mono.
-Qed.
-Lemma tac_rswp_store {A} `{!source Σ A} k Δ Δ' s E i K l v v' Φ :
- envs_lookup i Δ = Some (false, l ↦ v')%I →
- envs_simple_replace i false (Esnoc Enil i (l ↦ v)) Δ = Some Δ' →
- envs_entails Δ' (RWP fill K (Val $ LitV LitUnit) @ s; E ⟨⟨ Φ ⟩⟩) →
- envs_entails Δ (RSWP fill K (Store (LitV l) v) at k @ s; E ⟨⟨ Φ ⟩⟩).
-Proof.
- rewrite envs_entails_eq=>?? HΔ. rewrite -rswp_bind; last done.
- eapply wand_apply; first by exact: rswp_store.
- rewrite envs_simple_replace_sound // -!later_intro -laterN_intro; simpl.
- rewrite right_id HΔ. by apply sep_mono_r, wand_mono.
-Qed.
-Lemma tac_rwp_store {A} `{!source Σ A} Δ Δ' s E i K l v v' Φ :
- envs_lookup i Δ = Some (false, l ↦ v')%I →
- envs_simple_replace i false (Esnoc Enil i (l ↦ v)) Δ = Some Δ' →
- envs_entails Δ' (RWP fill K (Val $ LitV LitUnit) @ s; E ⟨⟨ Φ ⟩⟩) →
- envs_entails Δ (RWP fill K (Store (LitV l) v) @ s; E ⟨⟨ Φ ⟩⟩).
-Proof.
- intros ???. rewrite -rwp_no_step; first by eapply tac_rswp_store.
- by eapply to_val_fill_none.
-Qed.
-Lemma tac_twp_store `{tcG Σ} Δ Δ' s E i K l v v' Φ :
- envs_lookup i Δ = Some (false, l ↦ v')%I →
- envs_simple_replace i false (Esnoc Enil i (l ↦ v)) Δ = Some Δ' →
- envs_entails Δ' (WP fill K (Val $ LitV LitUnit) @ s; E [{ Φ }]) →
- envs_entails Δ (WP fill K (Store (LitV l) v) @ s; E [{ Φ }]).
-Proof.
- apply tac_rwp_store.
-Qed.
-
-(* TODO: atomic operations for the refinement weakest preconditions *)
-Lemma tac_wp_cmpxchg Δ Δ' Δ'' s E i K l v v1 v2 Φ :
- MaybeIntoLaterNEnvs 1 Δ Δ' →
- envs_lookup i Δ' = Some (false, l ↦ v)%I →
- envs_simple_replace i false (Esnoc Enil i (l ↦ v2)) Δ' = Some Δ'' →
- vals_compare_safe v v1 →
- (v = v1 →
- envs_entails Δ'' (WP fill K (Val $ PairV v (LitV $ LitBool true)) @ s; E {{ Φ }})) →
- (v ≠ v1 →
- envs_entails Δ' (WP fill K (Val $ PairV v (LitV $ LitBool false)) @ s; E {{ Φ }})) →
- envs_entails Δ (WP fill K (CmpXchg (LitV l) (Val v1) (Val v2)) @ s; E {{ Φ }}).
-Proof.
- rewrite envs_entails_eq=> ???? Hsuc Hfail.
- destruct (decide (v = v1)) as [Heq|Hne].
- - rewrite -wp_bind -(swp_wp 1) // -swp_step into_laterN_env_sound. eapply later_mono, wand_apply.
- { eapply swp_cmpxchg_suc; eauto. }
- rewrite -!later_intro /= {1}envs_simple_replace_sound //; simpl.
- apply sep_mono_r. rewrite right_id. apply wand_mono; auto.
- - rewrite -wp_bind -(swp_wp 1) // -swp_step into_laterN_env_sound. eapply later_mono, wand_apply.
- { eapply swp_cmpxchg_fail; eauto. }
- rewrite -!later_intro /= {1}envs_lookup_split //; simpl.
- apply sep_mono_r. apply wand_mono; auto.
-Qed.
-Lemma tac_swp_cmpxchg k Δ Δ' s E i K l v v1 v2 Φ :
- envs_lookup i Δ = Some (false, l ↦ v)%I →
- envs_simple_replace i false (Esnoc Enil i (l ↦ v2)) Δ = Some Δ' →
- vals_compare_safe v v1 →
- (v = v1 →
- envs_entails Δ' (WP fill K (Val $ PairV v (LitV $ LitBool true)) @ s; E {{ Φ }})) →
- (v ≠ v1 →
- envs_entails Δ (WP fill K (Val $ PairV v (LitV $ LitBool false)) @ s; E {{ Φ }})) →
- envs_entails Δ (SWP fill K (CmpXchg (LitV l) v1 v2) at k @ s; E {{ Φ }}).
-Proof.
- rewrite envs_entails_eq=> ??? Hsuc Hfail.
- destruct (decide (v = v1)) as [Heq|Hne].
- - rewrite -swp_bind //. eapply wand_apply.
- { eapply swp_cmpxchg_suc; eauto. }
- rewrite /= {1}envs_simple_replace_sound // -!later_intro; simpl.
- apply sep_mono_r. rewrite right_id. apply wand_mono; auto.
- - rewrite -swp_bind //. eapply wand_apply.
- { eapply swp_cmpxchg_fail; eauto. }
- rewrite /= {1}envs_lookup_split // -!later_intro; simpl.
- apply sep_mono_r. apply wand_mono; auto.
-Qed.
-
-Lemma tac_wp_cmpxchg_fail Δ Δ' s E i K l q v v1 v2 Φ :
- MaybeIntoLaterNEnvs 1 Δ Δ' →
- envs_lookup i Δ' = Some (false, l ↦{q} v)%I →
- v ≠ v1 → vals_compare_safe v v1 →
- envs_entails Δ' (WP fill K (Val $ PairV v (LitV $ LitBool false)) @ s; E {{ Φ }}) →
- envs_entails Δ (WP fill K (CmpXchg (LitV l) v1 v2) @ s; E {{ Φ }}).
-Proof.
- rewrite envs_entails_eq=> ?????.
- rewrite -wp_bind -(swp_wp 1) // -swp_step into_laterN_env_sound.
- eapply later_mono, wand_apply; first exact: swp_cmpxchg_fail.
- rewrite -!later_intro envs_lookup_split //; simpl.
- by apply sep_mono_r, wand_mono.
-Qed.
-Lemma tac_swp_cmpxchg_fail k Δ s E i K l q v v1 v2 Φ :
- envs_lookup i Δ = Some (false, l ↦{q} v)%I →
- v ≠ v1 → vals_compare_safe v v1 →
- envs_entails Δ (WP fill K (Val $ PairV v (LitV $ LitBool false)) @ s; E {{ Φ }}) →
- envs_entails Δ (SWP fill K (CmpXchg (LitV l) v1 v2) at k @ s; E {{ Φ }}).
-Proof.
- rewrite envs_entails_eq. intros. rewrite -swp_bind //.
- eapply wand_apply; first exact: swp_cmpxchg_fail.
- rewrite -!later_intro envs_lookup_split //; simpl. by do 2 f_equiv.
-Qed.
-
-Lemma tac_wp_cmpxchg_suc Δ Δ' Δ'' s E i K l v v1 v2 Φ :
- MaybeIntoLaterNEnvs 1 Δ Δ' →
- envs_lookup i Δ' = Some (false, l ↦ v)%I →
- envs_simple_replace i false (Esnoc Enil i (l ↦ v2)) Δ' = Some Δ'' →
- v = v1 → vals_compare_safe v v1 →
- envs_entails Δ'' (WP fill K (Val $ PairV v (LitV $ LitBool true)) @ s; E {{ Φ }}) →
- envs_entails Δ (WP fill K (CmpXchg (LitV l) v1 v2) @ s; E {{ Φ }}).
-Proof.
- rewrite envs_entails_eq=> ??????; subst.
- rewrite -wp_bind -(swp_wp 1) // -swp_step into_laterN_env_sound. eapply later_mono, wand_apply.
- { eapply swp_cmpxchg_suc; eauto. }
- rewrite -!later_intro envs_simple_replace_sound //; simpl.
- rewrite right_id. by apply sep_mono_r, wand_mono.
-Qed.
-Lemma tac_swp_cmpxchg_suc k Δ Δ' s E i K l v v1 v2 Φ :
- envs_lookup i Δ = Some (false, l ↦ v)%I →
- envs_simple_replace i false (Esnoc Enil i (l ↦ v2)) Δ = Some Δ' →
- v = v1 → vals_compare_safe v v1 →
- envs_entails Δ' (WP fill K (Val $ PairV v (LitV $ LitBool true)) @ s; E {{ Φ }}) →
- envs_entails Δ (SWP fill K (CmpXchg (LitV l) v1 v2) at k @ s; E {{ Φ }}).
-Proof.
- rewrite envs_entails_eq=>?????; subst.
- rewrite -swp_bind //. eapply wand_apply.
- { eapply swp_cmpxchg_suc; eauto. }
- rewrite envs_simple_replace_sound //; simpl.
- rewrite right_id -!later_intro. by apply sep_mono_r, wand_mono.
-Qed.
-
-Lemma tac_wp_faa Δ Δ' Δ'' s E i K l z1 z2 Φ :
- MaybeIntoLaterNEnvs 1 Δ Δ' →
- envs_lookup i Δ' = Some (false, l ↦ LitV z1)%I →
- envs_simple_replace i false (Esnoc Enil i (l ↦ LitV (z1 + z2))) Δ' = Some Δ'' →
- envs_entails Δ'' (WP fill K (Val $ LitV z1) @ s; E {{ Φ }}) →
- envs_entails Δ (WP fill K (FAA (LitV l) (LitV z2)) @ s; E {{ Φ }}).
-Proof.
- rewrite envs_entails_eq=> ????.
- rewrite -wp_bind -(swp_wp 1) // -swp_step into_laterN_env_sound.
- eapply later_mono, wand_apply; first exact: (swp_faa _ _ _ _ z1 z2).
- rewrite -!later_intro envs_simple_replace_sound //; simpl.
- rewrite right_id. by apply sep_mono_r, wand_mono.
-Qed.
-Lemma tac_swp_faa k Δ Δ' s E i K l z1 z2 Φ :
- envs_lookup i Δ = Some (false, l ↦ LitV z1)%I →
- envs_simple_replace i false (Esnoc Enil i (l ↦ LitV (z1 + z2))) Δ = Some Δ' →
- envs_entails Δ' (WP fill K (Val $ LitV z1) @ s; E {{ Φ }}) →
- envs_entails Δ (SWP fill K (FAA (LitV l) (LitV z2)) at k @ s; E {{ Φ }}).
-Proof.
- rewrite envs_entails_eq=> ???.
- rewrite -swp_bind //. eapply wand_apply; first exact: (swp_faa _ _ _ _ z1 z2).
- rewrite envs_simple_replace_sound //; simpl.
- rewrite right_id -!later_intro. by apply sep_mono_r, wand_mono.
-Qed.
-End heap.
-
-(** Evaluate [lem] to a hypothesis [H] that can be applied, and then run
-[wp_bind K; tac H] for every possible evaluation context. [tac] can do
-[iApplyHyp H] to actually apply the hypothesis. TC resolution of [lem] premises
-happens *after* [tac H] got executed. *)
-Tactic Notation "wp_apply_core" open_constr(lem) tactic(tac) :=
- wp_pures;
- iPoseProofCore lem as false (fun H =>
- lazymatch goal with
- | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
- reshape_expr e ltac:(fun K e' =>
- wp_bind_core K; tac H) ||
- lazymatch iTypeOf H with
- | Some (_,?P) => fail "wp_apply: cannot apply" P
- end
- | |- envs_entails _ (swp ?k ?s ?E ?e ?Q) =>
- reshape_expr e ltac:(fun K e' =>
- swp_bind_core K; tac H) ||
- lazymatch iTypeOf H with
- | Some (_,?P) => fail "wp_apply: cannot apply" P
- end
- | |- envs_entails _ (rwp ?s ?E ?e ?Q) =>
- reshape_expr e ltac:(fun K e' =>
- rwp_bind_core K; tac H) ||
- lazymatch iTypeOf H with
- | Some (_,?P) => fail "wp_apply: cannot apply" P
- end
- | |- envs_entails _ (rswp ?k ?s ?E ?e ?Q) =>
- reshape_expr e ltac:(fun K e' =>
- rswp_bind_core K; tac H) ||
- lazymatch iTypeOf H with
- | Some (_,?P) => fail "wp_apply: cannot apply" P
- end
- | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
- reshape_expr e ltac:(fun K e' =>
- twp_bind_core K; tac H) ||
- lazymatch iTypeOf H with
- | Some (_,?P) => fail "wp_apply: cannot apply" P
- end
- | _ => fail "wp_apply: not a 'wp'"
- end).
-Tactic Notation "wp_apply" open_constr(lem) :=
- wp_apply_core lem (fun H => iApplyHyp H; try iNext; try wp_expr_simpl).
-
-(*(** Tactic tailored for atomic triples: the first, simple one just runs
-[iAuIntro] on the goal, as atomic triples always have an atomic update as their
-premise. The second one additionaly does some framing: it gets rid of [Hs] from
-the context, which is intended to be the non-laterable assertions that iAuIntro
-would choke on. You get them all back in the continuation of the atomic
-operation. *)
-Tactic Notation "awp_apply" open_constr(lem) :=
- wp_apply_core lem (fun H => iApplyHyp H; last iAuIntro).
-Tactic Notation "awp_apply" open_constr(lem) "without" constr(Hs) :=
- wp_apply_core lem (fun H => iApply wp_frame_wand_l; iSplitL Hs; [iAccu|iApplyHyp H; last iAuIntro]).
- *)
-
-Tactic Notation "wp_alloc" ident(l) "as" constr(H) :=
- let Htmp := iFresh in
- let finish _ :=
- first [intros l | fail 1 "wp_alloc:" l "not fresh"];
- eexists; split;
- [pm_reflexivity || fail "wp_alloc:" H "not fresh"
- |iDestructHyp Htmp as H; wp_finish] in
- wp_pures;
- (** The code first tries to use allocation lemma for a single reference,
- ie, [tac_wp_alloc] (respectively, [tac_twp_alloc]).
- If that fails, it tries to use the lemma [tac_wp_allocN]
- (respectively, [tac_twp_allocN]) for allocating an array.
- Notice that we could have used the array allocation lemma also for single
- references. However, that would produce the resource l ↦∗ [v] instead of
- l ↦ v for single references. These are logically equivalent assertions
- but are not equal. *)
- lazymatch goal with
- | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
- let process_single _ :=
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_wp_alloc _ _ _ _ Htmp K))
- |fail 1 "wp_alloc: cannot find 'Alloc' in" e];
- [iSolveTC
- |finish ()]
- in
- let process_array _ :=
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_wp_allocN _ _ _ _ Htmp K))
- |fail 1 "wp_alloc: cannot find 'Alloc' in" e];
- [idtac|iSolveTC
- |finish ()]
- in (process_single ()) || (process_array ())
- | |- envs_entails _ (swp ?k ?s ?E ?e ?Q) =>
- let process_single _ :=
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_swp_alloc _ _ _ _ _ Htmp K))
- |fail 1 "wp_alloc: cannot find 'Alloc' in" e];
- finish ()
- in
- let process_array _ :=
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_swp_allocN _ _ _ _ _ Htmp K))
- |fail 1 "wp_alloc: cannot find 'Alloc' in" e];
- finish ()
- in (process_single ()) || (process_array ())
- | |- envs_entails _ (rwp ?s ?E ?e ?Q) =>
- let process_single _ :=
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_rwp_alloc _ _ _ Htmp K))
- |fail 1 "wp_alloc: cannot find 'Alloc' in" e];
- finish ()
- in
- let process_array _ :=
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_rwp_allocN _ _ _ Htmp K))
- |fail 1 "wp_alloc: cannot find 'Alloc' in" e];
- finish ()
- in (process_single ()) || (process_array ())
- | |- envs_entails _ (rswp ?k ?s ?E ?e ?Q) =>
- let process_single _ :=
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_rswp_alloc _ _ _ _ _ Htmp K))
- |fail 1 "wp_alloc: cannot find 'Alloc' in" e];
- [iSolveTC|finish ()]
- in
- let process_array _ :=
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_rswp_allocN _ _ _ _ _ Htmp K))
- |fail 1 "wp_alloc: cannot find 'Alloc' in" e];
- [idtac|iSolveTC
- |finish ()]
- in (process_single ()) || (process_array ())
- | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
- let process_single _ :=
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_twp_alloc _ _ _ Htmp K))
- |fail 1 "wp_alloc: cannot find 'Alloc' in" e];
- finish ()
- in
- let process_array _ :=
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_twp_allocN _ _ _ Htmp K))
- |fail 1 "wp_alloc: cannot find 'Alloc' in" e];
- [idtac| finish ()]
- in (process_single ()) || (process_array ())
- | _ => fail "wp_alloc: not a 'wp'"
- end.
-
-Tactic Notation "wp_alloc" ident(l) :=
- wp_alloc l as "?".
-
-Tactic Notation "wp_load" :=
- let solve_mapsto _ :=
- let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
- iAssumptionCore || fail "wp_load: cannot find" l "↦ ?" in
- wp_pures;
- lazymatch goal with
- | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_wp_load _ _ _ _ _ K))
- |fail 1 "wp_load: cannot find 'Load' in" e];
- [iSolveTC
- |solve_mapsto ()
- |wp_finish]
- | |- envs_entails _ (swp ?k ?s ?E ?e ?Q) =>
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_swp_load _ _ _ _ _ K))
- |fail 1 "wp_load: cannot find 'Load' in" e];
- [solve_mapsto ()
- |wp_finish]
- | |- envs_entails _ (rwp ?s ?E ?e ?Q) =>
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_rwp_load _ _ _ _ K))
- |fail 1 "wp_load: cannot find 'Load' in" e];
- [solve_mapsto ()
- |wp_finish]
- | |- envs_entails _ (rswp ?k ?s ?E ?e ?Q) =>
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_rswp_load _ _ _ _ _ K))
- |fail 1 "wp_load: cannot find 'Load' in" e];
- [solve_mapsto ()
- |wp_finish]
- | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_twp_load _ _ _ _ K))
- |fail 1 "wp_load: cannot find 'Load' in" e];
- [solve_mapsto ()
- |wp_finish]
- | _ => fail "wp_load: not a 'wp'"
- end.
-
-Tactic Notation "wp_store" :=
- let solve_mapsto _ :=
- let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
- iAssumptionCore || fail "wp_store: cannot find" l "↦ ?" in
- wp_pures;
- lazymatch goal with
- | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_wp_store _ _ _ _ _ _ K))
- |fail 1 "wp_store: cannot find 'Store' in" e];
- [iSolveTC
- |solve_mapsto ()
- |pm_reflexivity
- |first [wp_seq|wp_finish]]
- | |- envs_entails _ (swp ?k ?s ?E ?e ?Q) =>
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_swp_store _ _ _ _ _ _ K))
- |fail 1 "wp_store: cannot find 'Store' in" e];
- [solve_mapsto ()
- |pm_reflexivity
- |first [wp_seq|wp_finish]]
- | |- envs_entails _ (rwp ?s ?E ?e ?Q) =>
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_rwp_store _ _ _ _ _ K))
- |fail 1 "wp_store: cannot find 'Store' in" e];
- [solve_mapsto ()
- |pm_reflexivity
- |first [wp_seq|wp_finish]]
- | |- envs_entails _ (rswp ?k ?s ?E ?e ?Q) =>
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_rswp_store _ _ _ _ _ _ K))
- |fail 1 "wp_store: cannot find 'Store' in" e];
- [solve_mapsto ()
- |pm_reflexivity
- |first [wp_seq|wp_finish]]
- | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_twp_store _ _ _ _ _ K))
- |fail 1 "wp_store: cannot find 'Store' in" e];
- [solve_mapsto ()
- |pm_reflexivity
- |first [wp_seq|wp_finish]]
- | _ => fail "wp_store: not a 'wp'"
- end.
-
-(* TODO: refinement versions *)
-Tactic Notation "wp_cmpxchg" "as" simple_intropattern(H1) "|" simple_intropattern(H2) :=
- let solve_mapsto _ :=
- let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
- iAssumptionCore || fail "wp_cmpxchg: cannot find" l "↦ ?" in
- wp_pures;
- lazymatch goal with
- | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_wp_cmpxchg _ _ _ _ _ _ K))
- |fail 1 "wp_cmpxchg: cannot find 'CmpXchg' in" e];
- [iSolveTC
- |solve_mapsto ()
- |pm_reflexivity
- |try solve_vals_compare_safe
- |intros H1; wp_finish
- |intros H2; wp_finish]
- | |- envs_entails _ (swp ?k ?s ?E ?e ?Q) =>
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_swp_cmpxchg _ _ _ _ _ _ K))
- |fail 1 "wp_cmpxchg: cannot find 'CmpXchg' in" e];
- [solve_mapsto ()
- |pm_reflexivity
- |try solve_vals_compare_safe
- |intros H1; wp_finish
- |intros H2; wp_finish]
- | _ => fail "wp_cmpxchg: not a 'wp'"
- end.
-
-Tactic Notation "wp_cmpxchg_fail" :=
- let solve_mapsto _ :=
- let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
- iAssumptionCore || fail "wp_cmpxchg_fail: cannot find" l "↦ ?" in
- wp_pures;
- lazymatch goal with
- | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_wp_cmpxchg_fail _ _ _ _ _ K))
- |fail 1 "wp_cmpxchg_fail: cannot find 'CmpXchg' in" e];
- [iSolveTC
- |solve_mapsto ()
- |try (simpl; congruence) (* value inequality *)
- |try solve_vals_compare_safe
- |wp_finish]
- | |- envs_entails _ (swp ?k ?s ?E ?e ?Q) =>
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_swp_cmpxchg_fail _ _ _ _ _ K))
- |fail 1 "wp_cmpxchg_fail: cannot find 'CmpXchg' in" e];
- [solve_mapsto ()
- |try (simpl; congruence) (* value inequality *)
- |try solve_vals_compare_safe
- |wp_finish]
- | _ => fail "wp_cmpxchg_fail: not a 'wp'"
- end.
-
-Tactic Notation "wp_cmpxchg_suc" :=
- let solve_mapsto _ :=
- let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
- iAssumptionCore || fail "wp_cmpxchg_suc: cannot find" l "↦ ?" in
- wp_pures;
- lazymatch goal with
- | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_wp_cmpxchg_suc _ _ _ _ _ _ K))
- |fail 1 "wp_cmpxchg_suc: cannot find 'CmpXchg' in" e];
- [iSolveTC
- |solve_mapsto ()
- |pm_reflexivity
- |try (simpl; congruence) (* value equality *)
- |try solve_vals_compare_safe
- |wp_finish]
- | |- envs_entails _ (swp ?k ?s ?E ?e ?Q) =>
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_swp_cmpxchg_suc _ _ _ _ _ _ K))
- |fail 1 "wp_cmpxchg_suc: cannot find 'CmpXchg' in" e];
- [solve_mapsto ()
- |pm_reflexivity
- |try (simpl; congruence) (* value equality *)
- |try solve_vals_compare_safe
- |wp_finish]
- | _ => fail "wp_cmpxchg_suc: not a 'wp'"
- end.
-
-Tactic Notation "wp_faa" :=
- let solve_mapsto _ :=
- let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
- iAssumptionCore || fail "wp_faa: cannot find" l "↦ ?" in
- wp_pures;
- lazymatch goal with
- | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_wp_faa _ _ _ _ _ _ K))
- |fail 1 "wp_faa: cannot find 'FAA' in" e];
- [iSolveTC
- |solve_mapsto ()
- |pm_reflexivity
- |wp_finish]
- | |- envs_entails _ (swp ?k ?s ?E ?e ?Q) =>
- first
- [reshape_expr e ltac:(fun K e' => eapply (tac_swp_faa _ _ _ _ _ _ K))
- |fail 1 "wp_faa: cannot find 'FAA' in" e];
- [solve_mapsto ()
- |pm_reflexivity
- |wp_finish]
- | _ => fail "wp_faa: not a 'wp'"
- end.
diff --git a/theories/heap_lang/tactics.v b/theories/heap_lang/tactics.v
deleted file mode 100644
index 368f202f..00000000
--- a/theories/heap_lang/tactics.v
+++ /dev/null
@@ -1,53 +0,0 @@
-From iris.heap_lang Require Export lang.
-Set Default Proof Using "Type".
-Import heap_lang.
-
-(** The tactic [reshape_expr e tac] decomposes the expression [e] into an
-evaluation context [K] and a subexpression [e']. It calls the tactic [tac K e']
-for each possible decomposition until [tac] succeeds. *)
-Ltac reshape_expr e tac :=
- (* Note that the current context is spread into a list of fully-constructed
- items [K], and a list of pairs of values [vs] (prophecy identifier and
- resolution value) that is only non-empty if a [ResolveLCtx] item (maybe
- having several levels) is in the process of being constructed. Note that
- a fully-constructed item is inserted into [K] by calling [add_item], and
- that is only the case when a non-[ResolveLCtx] item is built. When [vs]
- is non-empty, [add_item] also wraps the item under several [ResolveLCtx]
- constructors: one for each pair in [vs]. *)
- let rec go K vs e :=
- match e with
- | _ => lazymatch vs with [] => tac K e | _ => fail end
- | App ?e (Val ?v) => add_item (AppLCtx v) vs K e
- | App ?e1 ?e2 => add_item (AppRCtx e1) vs K e2
- | UnOp ?op ?e => add_item (UnOpCtx op) vs K e
- | BinOp ?op ?e (Val ?v) => add_item (BinOpLCtx op v) vs K e
- | BinOp ?op ?e1 ?e2 => add_item (BinOpRCtx op e1) vs K e2
- | If ?e0 ?e1 ?e2 => add_item (IfCtx e1 e2) vs K e0
- | Pair ?e (Val ?v) => add_item (PairLCtx v) vs K e
- | Pair ?e1 ?e2 => add_item (PairRCtx e1) vs K e2
- | Fst ?e => add_item FstCtx vs K e
- | Snd ?e => add_item SndCtx vs K e
- | InjL ?e => add_item InjLCtx vs K e
- | InjR ?e => add_item InjRCtx vs K e
- | Case ?e0 ?e1 ?e2 => add_item (CaseCtx e1 e2) vs K e0
- | AllocN ?e (Val ?v) => add_item (AllocNLCtx v) vs K e
- | AllocN ?e1 ?e2 => add_item (AllocNRCtx e1) vs K e2
- | Load ?e => add_item LoadCtx vs K e
- | Store ?e (Val ?v) => add_item (StoreLCtx v) vs K e
- | Store ?e1 ?e2 => add_item (StoreRCtx e1) vs K e2
- | CmpXchg ?e0 (Val ?v1) (Val ?v2) => add_item (CmpXchgLCtx v1 v2) vs K e0
- | CmpXchg ?e0 ?e1 (Val ?v2) => add_item (CmpXchgMCtx e0 v2) vs K e1
- | CmpXchg ?e0 ?e1 ?e2 => add_item (CmpXchgRCtx e0 e1) vs K e2
- | FAA ?e (Val ?v) => add_item (FaaLCtx v) vs K e
- | FAA ?e1 ?e2 => add_item (FaaRCtx e1) vs K e2
- | Resolve ?ex (Val ?v1) (Val ?v2) => go K ((v1,v2) :: vs) ex
- | Resolve ?ex ?e1 (Val ?v2) => add_item (ResolveMCtx ex v2) vs K e1
- | Resolve ?ex ?e1 ?e2 => add_item (ResolveRCtx ex e1) vs K e2
- end
- with add_item Ki vs K e :=
- lazymatch vs with
- | [] => go (Ki :: K) (@nil (val * val)) e
- | (?v1,?v2) :: ?vs => add_item (ResolveLCtx Ki v1 v2) vs K e
- end
- in
- go (@nil ectx_item) (@nil (val * val)) e.
diff --git a/theories/program_logic/adequacy.v b/theories/program_logic/adequacy.v
deleted file mode 100644
index 100a4b32..00000000
--- a/theories/program_logic/adequacy.v
+++ /dev/null
@@ -1,283 +0,0 @@
-From iris.program_logic Require Export weakestpre.
-From iris.algebra Require Import gmap auth agree gset coPset.
-From iris.base_logic.lib Require Import wsat.
-From iris.proofmode Require Import tactics.
-Set Default Proof Using "Type".
-Import uPred.
-
-(** This file contains the adequacy statements of the Iris program logic. First we prove a number of auxilary results. *)
-
-Lemma lstep_fupd_soundness {SI} {Σ: gFunctors SI} `{TransfiniteIndex SI} `{!invPreG Σ} φ n:
- (∀ Hinv : invG Σ, @sbi_emp_valid SI (iPropSI Σ) (>={⊤}=={⊤}=>^n ⌜φ⌝)%I) → φ.
-Proof.
- intros Hiter. assert ((True ⊢ ⧍^n ⌜φ⌝ : iProp Σ)%I → φ) as Hlater;
- last (apply Hlater).
- { intros H1.
- eapply pure_soundness, uPred_primitive.big_laterN_soundness, H1.
- }
- apply (fupd_plain_soundness ⊤ ⊤ _)=> Hinv.
- iPoseProof (Hiter Hinv) as "H". by iApply lstep_fupdN_plain.
-Qed.
-
-Section adequacy.
-Context {SI} {Σ: gFunctors SI} `{!irisG Λ Σ}.
-Implicit Types e : expr Λ.
-Implicit Types P Q : iProp Σ.
-Implicit Types Φ : val Λ → iProp Σ.
-Implicit Types Φs : list (val Λ → iProp Σ).
-
-
-
-Notation wptp s t := ([∗ list] ef ∈ t, WP ef @ s; ⊤ {{ fork_post }})%I.
-
-Existing Instance elim_eventuallyN.
-Existing Instance elim_gstep.
-Lemma wp_step s e1 σ1 κ κs e2 σ2 efs m Φ :
- prim_step e1 σ1 κ e2 σ2 efs →
- state_interp σ1 (κ ++ κs) m -∗ WP e1 @ s; ⊤ {{ Φ }} -∗ >={⊤}=={⊤}=>
- (state_interp σ2 κs (length efs + m) ∗ WP e2 @ s; ⊤ {{ Φ }} ∗ wptp s efs).
-Proof.
- rewrite {1}wp_unfold /wp_pre. iIntros (?) "Hσ H".
- rewrite (val_stuck e1 σ1 κ e2 σ2 efs) //.
- iMod ("H" $! σ1 with "Hσ") as "H". iMod "H".
- iDestruct "H" as (n) "H".
- iApply (gstepN_gstep _ _ _ (S n)). iModIntro.
- replace (S n) with (n + 1) by lia. iApply eventuallyN_compose. iMod "H".
- iMod "H" as "[% H]". iMod ("H" $! e2 σ2 efs with "[//]") as "H".
- by iIntros "!> !> !> !>".
-Qed.
-
-Lemma wptp_step s e1 t1 t2 κ κs σ1 σ2 Φ :
- step (e1 :: t1,σ1) κ (t2, σ2) →
- state_interp σ1 (κ ++ κs) (length t1) -∗ WP e1 @ s; ⊤ {{ Φ }} -∗ wptp s t1 -∗
- ∃ e2 t2', ⌜t2 = e2 :: t2'⌝ ∗
- >={⊤}=={⊤}=> (state_interp σ2 κs (pred (length t2)) ∗ WP e2 @ s; ⊤ {{ Φ }} ∗ wptp s t2').
-Proof.
- iIntros (Hstep) "Hσ He Ht".
- destruct Hstep as [e1' σ1' e2' σ2' efs [|? t1'] t2' ?? Hstep]; simplify_eq/=.
- - iExists e2', (t2' ++ efs). iSplitR; first by eauto.
- iMod (wp_step with "Hσ He") as "(Hσ & He2 & Hefs)"; first done.
- rewrite Nat.add_comm app_length. iFrame.
- - iExists e, (t1' ++ e2' :: t2' ++ efs); iSplitR; first eauto.
- iDestruct "Ht" as "(Ht1 & He1 & Ht2)".
- iMod (wp_step with "Hσ He1") as "(Hσ & He2 & Hefs)"; first done.
- rewrite !app_length /= !app_length.
- replace (length t1' + S (length t2' + length efs))
- with (length efs + (length t1' + S (length t2'))) by omega. iFrame.
-Qed.
-
-Lemma wptp_steps s n e1 t1 κs κs' t2 σ1 σ2 Φ :
- nsteps n (e1 :: t1, σ1) κs (t2, σ2) →
- state_interp σ1 (κs ++ κs') (length t1) -∗ WP e1 @ s; ⊤ {{ Φ }} -∗ wptp s t1
- -∗ (>={⊤}=={⊤}=>^n
- (∃ e2 t2', ⌜t2 = e2 :: t2'⌝ ∗
- state_interp σ2 κs' (pred (length t2)) ∗
- WP e2 @ s; ⊤ {{ Φ }} ∗ wptp s t2')).
-Proof.
- revert e1 t1 κs κs' t2 σ1 σ2; simpl.
- induction n as [|n IH]=> e1 t1 κs κs' t2 σ1 σ2 /=.
- { inversion_clear 1; iIntros "???"; iExists e1, t1; iFrame; eauto 10. }
- iIntros (Hsteps) "Hσ He Ht". inversion_clear Hsteps as [|?? [t1' σ1']].
- rewrite -(assoc_L (++)).
- iPoseProof (wptp_step with "Hσ He Ht") as (e1' t1'' ?) ">(Hσ & He & Ht)"; first eauto.
- simplify_eq. by iApply (IH with "Hσ He Ht").
-Qed.
-
-Lemma wp_safe κs m e σ Φ :
- state_interp σ κs m -∗
- WP e {{ Φ }} ={⊤}=∗ ⧍ ⌜is_Some (to_val e) ∨ reducible e σ⌝.
-Proof.
- rewrite wp_unfold /wp_pre. iIntros "Hσ H".
- destruct (to_val e) as [v|] eqn:?; first by eauto.
- iSpecialize ("H" $! σ [] κs with "Hσ").
- iAssert (|={⊤,∅}=> ⧍ ⌜reducible e σ⌝)%I with "[H]" as "H".
- { iMod "H". iMod (eventually_plain with "[H]") as "H"; last by iModIntro. apply _.
- iMod "H" as (n) "H". iModIntro. iExists (S n). replace (S n) with (n + 1)by lia. iApply eventuallyN_compose.
- iMod "H". by iMod "H" as "[$ _]". }
- iMod (fupd_plain_mask with "H") as "H"; eauto.
- iModIntro. iMod "H" as "%". by iRight.
-Qed.
-
-Lemma list_big_later {X} (L: list X) (P: X → iProp Σ): ([∗ list] x ∈ L, ⧍ P x) ⊢ ⧍ [∗ list] x ∈ L, P x.
-Proof.
- iInduction L as [|L] "IH"; simpl.
- - iIntros "_". by iExists 0.
- - iIntros "[H1 H2]". iSpecialize ("IH" with "H2").
- iDestruct "H1" as (n1) "H1". iDestruct "IH" as (n2) "IH".
- iExists (n1 + n2). iNext. iFrame.
-Qed.
-
-Lemma big_later_eventually P E: ⧍ P -∗ <E> P.
-Proof.
- iDestruct 1 as (n) "H". iExists n.
- iModIntro. iInduction n as [ | n] "IH"; simpl; eauto.
- iModIntro. iNext. iModIntro. by iApply "IH".
-Qed.
-
-Existing Instance elim_gstep_N.
-Lemma wptp_strong_adequacy Φ κs' s n e1 t1 κs e2 t2 σ1 σ2 :
- nsteps n (e1 :: t1, σ1) κs (t2, σ2) →
- state_interp σ1 (κs ++ κs') (length t1) -∗
- WP e1 @ s; ⊤ {{ Φ }} -∗
- wptp s t1 -∗ >={⊤}=={⊤}=>^(S n) ∃ e2 t2',
- ⌜ t2 = e2 :: t2' ⌝ ∗
- ⌜ ∀ e2, s = NotStuck → e2 ∈ t2 → (is_Some (to_val e2) ∨ reducible e2 σ2) ⌝ ∗
- state_interp σ2 κs' (length t2') ∗
- from_option Φ True (to_val e2) ∗
- ([∗ list] v ∈ omap to_val t2', fork_post v).
-Proof.
- iIntros (Hstep) "Hσ He Ht". rewrite Nat_iter_S_r.
- iDestruct (wptp_steps with "Hσ He Ht") as "Hwp"; first done.
- iMod "Hwp". iDestruct "Hwp" as (e2' t2' ?) "(Hσ & Hwp & Ht)"; simplify_eq/=.
- iMod (fupd_plain_keep_l ⊤
- ( ⌜s = NotStuck⌝ → [∗ list] e2 ∈ (e2' :: t2'), ⧍ ⌜(is_Some (to_val e2) ∨ reducible e2 σ2) ⌝)%I
- (state_interp σ2 κs' (length t2') ∗ WP e2' @ s; ⊤ {{ v, Φ v }} ∗ wptp s t2')%I
- with "[$Hσ $Hwp $Ht]") as "(Hsafe&Hσ&Hwp&Hvs)".
- { iIntros "(Hσ & Hwp & Ht)" (->); simpl.
- iMod (fupd_plain_keep_l ⊤ (⧍ ⌜is_Some (to_val e2') ∨ reducible e2' σ2⌝)%I
- (state_interp σ2 κs' (length t2') ∗ WP e2' @ ⊤ {{ v, Φ v }})%I
- with "[$Hσ $Hwp]") as "($ & Hσ & _)".
- { iIntros "[H1 H2]". iApply (wp_safe with "H1 H2"). }
- clear Hstep. generalize (length t2') as l. intros l. iInduction t2' as [| e3 t3] "IH"; simpl.
- - by iModIntro.
- - iDestruct "Ht" as "[Hwp Ht]".
- iMod (fupd_plain_keep_l ⊤ (⧍ ⌜is_Some (to_val e3) ∨ reducible e3 σ2⌝)%I
- (state_interp σ2 κs' l ∗ WP e3 {{ v, fork_post v }})%I
- with "[$Hσ $Hwp]") as "($ & Hσ & _)".
- { iIntros "[H1 H2]". iApply (wp_safe with "H1 H2"). }
- iMod ("IH" with "Ht Hσ") as "$". by iModIntro. }
- iAssert (⧍ ⌜ ∀ e2, s = NotStuck → e2 ∈ (e2' :: t2') → (is_Some (to_val e2) ∨ reducible e2 σ2) ⌝)%I with "[Hsafe]" as "Hsafe".
- { destruct s; last (iExists 0; iIntros (? H); discriminate). iSpecialize ("Hsafe" with "[]"); eauto.
- iMod (list_big_later with "Hsafe") as "Hsafe". iIntros (e) "_ %".
- by iApply (big_sepL_elem_of with "Hsafe"). }
- iMod (fupd_intro_mask') as "Hclose". apply empty_subseteq. iModIntro.
- iApply big_later_eventually. iMod "Hsafe". iMod "Hclose" as "_".
- iExists _, _. iSplitL ""; first done. iFrame "Hsafe Hσ".
- iSplitL "Hwp".
- - destruct (to_val e2') as [v2|] eqn:He2'; last done.
- apply of_to_val in He2' as <-. iApply (wp_value_inv' with "Hwp").
- - clear Hstep. iInduction t2' as [|e t2'] "IH"; csimpl; first by iFrame.
- iDestruct "Hvs" as "[Hv Hvs]". destruct (to_val e) as [v|] eqn:He.
- + apply of_to_val in He as <-. iMod (wp_value_inv' with "Hv") as "$".
- by iApply "IH".
- + by iApply "IH".
-Qed.
-End adequacy.
-
-Existing Instance elim_gstep_N.
-(** Iris's generic adequacy result *)
-Theorem wp_strong_adequacy {SI} `{TransfiniteIndex SI} (Σ: gFunctors SI) Λ `{!invPreG Σ} e1 σ1 n κs t2 σ2 φ :
- (∀ `{Hinv : !invG Σ},
- ⊢ (|={⊤}=> ∃
- (s: stuckness)
- (stateI : state Λ → list (observation Λ) → nat → iProp Σ)
- (Φ fork_post : val Λ → iProp Σ),
- let _ : irisG Λ Σ := IrisG _ _ _ Hinv stateI fork_post in
- stateI σ1 κs 0 ∗
- WP e1 @ s; ⊤ {{ Φ }} ∗
- (∀ e2 t2',
- (* e2 is the final state of the main thread, t2' the rest *)
- ⌜ t2 = e2 :: t2' ⌝ -∗
- (* If this is a stuck-free triple (i.e. [s = NotStuck]), then all
- threads in [t2] are either done (a value) or reducible *)
- ⌜ ∀ e2, s = NotStuck → e2 ∈ t2 → (is_Some (to_val e2) ∨ reducible e2 σ2) ⌝ -∗
- (* The state interpretation holds for [σ2] *)
- stateI σ2 [] (length t2') -∗
- (* If the main thread is done, its post-condition [Φ] holds *)
- from_option Φ True (to_val e2) -∗
- (* For all threads that are done, their postcondition [fork_post] holds. *)
- ([∗ list] v ∈ omap to_val t2', fork_post v) -∗
- (* Under all these assumptions, and while opening all invariants, we
- can conclude [φ] in the logic. After opening all required invariants,
- one can use [fupd_intro_mask'] or [fupd_mask_weaken] to introduce the
- fancy update. *)
- |={⊤,∅}=> ⌜ φ ⌝))%I) →
- nsteps n ([e1], σ1) κs (t2, σ2) →
- (* Then we can conclude [φ] at the meta-level. *)
- φ.
-Proof.
- intros Hwp ?.
- eapply (@lstep_fupd_soundness _ Σ _ _ _ (S (S n) + 1))=> Hinv.
- rewrite Nat_iter_add Nat_iter_S.
- iMod Hwp as (s stateI Φ fork_post) "(Hσ & Hwp & Hφ)".
- iApply lstep_intro. iModIntro.
- iPoseProof (@wptp_strong_adequacy _ _ _ (IrisG _ _ _ Hinv stateI fork_post) _ []
- with "[Hσ] Hwp") as "Hpost". 1-3:eauto. by rewrite right_id_L. iSpecialize ("Hpost" with "[$]").
- iMod "Hpost". iDestruct "Hpost" as (e2 t2' ->) "(? & ? & ? & ?)".
- iApply lstep_intro.
- iApply fupd_plain_mask_empty.
- iMod ("Hφ" with "[% //] [$] [$] [$] [$]"). done.
-Qed.
-
-(** Since the full adequacy statement is quite a mouthful, we prove some more
-intuitive and simpler corollaries. These lemmas are moreover stated in terms of
-[rtc erased_step] so one does not have to provide the trace. *)
-Record adequate {Λ} (s : stuckness) (e1 : expr Λ) (σ1 : state Λ)
- (φ : val Λ → state Λ → Prop) := {
- adequate_result t2 σ2 v2 :
- rtc erased_step ([e1], σ1) (of_val v2 :: t2, σ2) → φ v2 σ2;
- adequate_not_stuck t2 σ2 e2 :
- s = NotStuck →
- rtc erased_step ([e1], σ1) (t2, σ2) →
- e2 ∈ t2 → (is_Some (to_val e2) ∨ reducible e2 σ2)
-}.
-
-Lemma adequate_alt {Λ} s e1 σ1 (φ : val Λ → state Λ → Prop) :
- adequate s e1 σ1 φ ↔ ∀ t2 σ2,
- rtc erased_step ([e1], σ1) (t2, σ2) →
- (∀ v2 t2', t2 = of_val v2 :: t2' → φ v2 σ2) ∧
- (∀ e2, s = NotStuck → e2 ∈ t2 → (is_Some (to_val e2) ∨ reducible e2 σ2)).
-Proof. split. intros []; naive_solver. constructor; naive_solver. Qed.
-
-Theorem adequate_tp_safe {Λ} (e1 : expr Λ) t2 σ1 σ2 φ :
- adequate NotStuck e1 σ1 φ →
- rtc erased_step ([e1], σ1) (t2, σ2) →
- Forall (λ e, is_Some (to_val e)) t2 ∨ ∃ t3 σ3, erased_step (t2, σ2) (t3, σ3).
-Proof.
- intros Had ?.
- destruct (decide (Forall (λ e, is_Some (to_val e)) t2)) as [|Ht2]; [by left|].
- apply (not_Forall_Exists _), Exists_exists in Ht2; destruct Ht2 as (e2&?&He2).
- destruct (adequate_not_stuck NotStuck e1 σ1 φ Had t2 σ2 e2) as [?|(κ&e3&σ3&efs&?)];
- rewrite ?eq_None_not_Some; auto.
- { exfalso. eauto. }
- destruct (elem_of_list_split t2 e2) as (t2'&t2''&->); auto.
- right; exists (t2' ++ e3 :: t2'' ++ efs), σ3, κ; econstructor; eauto.
-Qed.
-
-Corollary wp_adequacy {SI} `{TransfiniteIndex SI} {Σ: gFunctors SI} Λ `{!invPreG Σ} s e σ φ :
- (∀ `{Hinv : !invG Σ} κs,
- sbi_emp_valid (|={⊤}=> ∃
- (stateI : state Λ → list (observation Λ) → iProp Σ)
- (fork_post : val Λ → iProp Σ),
- let _ : irisG Λ Σ := IrisG _ _ _ Hinv (λ σ κs _, stateI σ κs) fork_post in
- stateI σ κs ∗ WP e @ s; ⊤ {{ v, ⌜φ v⌝ }})%I) →
- adequate s e σ (λ v _, φ v).
-Proof.
- intros Hwp. apply adequate_alt; intros t2 σ2 [n [κs ?]]%erased_steps_nsteps.
- eapply (wp_strong_adequacy Σ _); [|done]=> ?.
- iMod Hwp as (stateI fork_post) "[Hσ Hwp]".
- iExists s, (λ σ κs _, stateI σ κs), (λ v, ⌜φ v⌝%I), fork_post.
- iIntros "{$Hσ $Hwp} !>" (e2 t2' -> ?) "_ H _".
- iApply fupd_mask_weaken; [done|]. iSplit; [|done].
- iIntros (v2 t2'' [= -> <-]). by rewrite to_of_val.
-Qed.
-
-Corollary wp_invariance {SI} `{TransfiniteIndex SI} {Σ: gFunctors SI} Λ `{!invPreG Σ} s e1 σ1 t2 σ2 φ :
- (∀ `{Hinv : !invG Σ} κs,
- sbi_emp_valid (|={⊤}=> ∃
- (stateI : state Λ → list (observation Λ) → nat → iProp Σ)
- (fork_post : val Λ → iProp Σ),
- let _ : irisG Λ Σ := IrisG _ _ _ Hinv stateI fork_post in
- stateI σ1 κs 0 ∗ WP e1 @ s; ⊤ {{ _, True }} ∗
- (stateI σ2 [] (pred (length t2)) -∗ ∃ E, |={⊤,E}=> ⌜φ⌝))%I) →
- rtc erased_step ([e1], σ1) (t2, σ2) →
- φ.
-Proof.
- intros Hwp [n [κs ?]]%erased_steps_nsteps.
- eapply (wp_strong_adequacy Σ _); [|done]=> ?.
- iMod (Hwp _ κs) as (stateI fork_post) "(Hσ & Hwp & Hφ)".
- iExists s, stateI, (λ _, True)%I, fork_post.
- iIntros "{$Hσ $Hwp} !>" (e2 t2' -> _) "Hσ _ _ /=".
- iDestruct ("Hφ" with "Hσ") as (E) ">Hφ".
- by iApply fupd_mask_weaken; first set_solver.
-Qed.
diff --git a/theories/program_logic/ectx_language.v b/theories/program_logic/ectx_language.v
deleted file mode 100644
index f687b137..00000000
--- a/theories/program_logic/ectx_language.v
+++ /dev/null
@@ -1,265 +0,0 @@
-(** An axiomatization of evaluation-context based languages, including a proof
- that this gives rise to a "language" in the Iris sense. *)
-From iris.algebra Require Export base.
-From iris.program_logic Require Import language.
-Set Default Proof Using "Type".
-
-(* TAKE CARE: When you define an [ectxLanguage] canonical structure for your
-language, you need to also define a corresponding [language] canonical
-structure. Use the coercion [LanguageOfEctx] as defined in the bottom of this
-file for doing that. *)
-
-Section ectx_language_mixin.
- Context {expr val ectx state observation : Type}.
- Context (of_val : val → expr).
- Context (to_val : expr → option val).
- Context (empty_ectx : ectx).
- Context (comp_ectx : ectx → ectx → ectx).
- Context (fill : ectx → expr → expr).
- Context (head_step : expr → state → list observation → expr → state → list expr → Prop).
-
- Record EctxLanguageMixin := {
- mixin_to_of_val v : to_val (of_val v) = Some v;
- mixin_of_to_val e v : to_val e = Some v → of_val v = e;
- mixin_val_head_stuck e1 σ1 κ e2 σ2 efs :
- head_step e1 σ1 κ e2 σ2 efs → to_val e1 = None;
-
- mixin_fill_empty e : fill empty_ectx e = e;
- mixin_fill_comp K1 K2 e : fill K1 (fill K2 e) = fill (comp_ectx K1 K2) e;
- mixin_fill_inj K : Inj (=) (=) (fill K);
- mixin_fill_val K e : is_Some (to_val (fill K e)) → is_Some (to_val e);
-
- (* There are a whole lot of sensible axioms (like associativity, and left and
- right identity, we could demand for [comp_ectx] and [empty_ectx]. However,
- positivity suffices. *)
- mixin_ectx_positive K1 K2 :
- comp_ectx K1 K2 = empty_ectx → K1 = empty_ectx ∧ K2 = empty_ectx;
-
- mixin_step_by_val K K' e1 e1' σ1 κ e2 σ2 efs :
- fill K e1 = fill K' e1' →
- to_val e1 = None →
- head_step e1' σ1 κ e2 σ2 efs →
- ∃ K'', K' = comp_ectx K K'';
- }.
-End ectx_language_mixin.
-
-Structure ectxLanguage := EctxLanguage {
- expr : Type;
- val : Type;
- ectx : Type;
- state : Type;
- observation : Type;
-
- of_val : val → expr;
- to_val : expr → option val;
- empty_ectx : ectx;
- comp_ectx : ectx → ectx → ectx;
- fill : ectx → expr → expr;
- head_step : expr → state → list observation → expr → state → list expr → Prop;
-
- ectx_language_mixin :
- EctxLanguageMixin of_val to_val empty_ectx comp_ectx fill head_step
-}.
-
-Arguments EctxLanguage {_ _ _ _ _ _ _ _ _ _ _} _.
-Arguments of_val {_} _%V.
-Arguments to_val {_} _%E.
-Arguments empty_ectx {_}.
-Arguments comp_ectx {_} _ _.
-Arguments fill {_} _ _%E.
-Arguments head_step {_} _%E _ _ _%E _ _.
-
-(* From an ectx_language, we can construct a language. *)
-Section ectx_language.
- Context {Λ : ectxLanguage}.
- Implicit Types v : val Λ.
- Implicit Types e : expr Λ.
- Implicit Types K : ectx Λ.
-
- (* Only project stuff out of the mixin that is not also in language *)
- Lemma val_head_stuck e1 σ1 κ e2 σ2 efs : head_step e1 σ1 κ e2 σ2 efs → to_val e1 = None.
- Proof. apply ectx_language_mixin. Qed.
- Lemma fill_empty e : fill empty_ectx e = e.
- Proof. apply ectx_language_mixin. Qed.
- Lemma fill_comp K1 K2 e : fill K1 (fill K2 e) = fill (comp_ectx K1 K2) e.
- Proof. apply ectx_language_mixin. Qed.
- Global Instance fill_inj K : Inj (=) (=) (fill K).
- Proof. apply ectx_language_mixin. Qed.
- Lemma fill_val K e : is_Some (to_val (fill K e)) → is_Some (to_val e).
- Proof. apply ectx_language_mixin. Qed.
- Lemma ectx_positive K1 K2 :
- comp_ectx K1 K2 = empty_ectx → K1 = empty_ectx ∧ K2 = empty_ectx.
- Proof. apply ectx_language_mixin. Qed.
- Lemma step_by_val K K' e1 e1' σ1 κ e2 σ2 efs :
- fill K e1 = fill K' e1' →
- to_val e1 = None →
- head_step e1' σ1 κ e2 σ2 efs →
- ∃ K'', K' = comp_ectx K K''.
- Proof. apply ectx_language_mixin. Qed.
-
- Definition head_reducible (e : expr Λ) (σ : state Λ) :=
- ∃ κ e' σ' efs, head_step e σ κ e' σ' efs.
- Definition head_reducible_no_obs (e : expr Λ) (σ : state Λ) :=
- ∃ e' σ' efs, head_step e σ [] e' σ' efs.
- Definition head_irreducible (e : expr Λ) (σ : state Λ) :=
- ∀ κ e' σ' efs, ¬head_step e σ κ e' σ' efs.
- Definition head_stuck (e : expr Λ) (σ : state Λ) :=
- to_val e = None ∧ head_irreducible e σ.
-
- (* All non-value redexes are at the root. In other words, all sub-redexes are
- values. *)
- Definition sub_redexes_are_values (e : expr Λ) :=
- ∀ K e', e = fill K e' → to_val e' = None → K = empty_ectx.
-
- Inductive prim_step (e1 : expr Λ) (σ1 : state Λ) (κ : list (observation Λ))
- (e2 : expr Λ) (σ2 : state Λ) (efs : list (expr Λ)) : Prop :=
- Ectx_step K e1' e2' :
- e1 = fill K e1' → e2 = fill K e2' →
- head_step e1' σ1 κ e2' σ2 efs → prim_step e1 σ1 κ e2 σ2 efs.
-
- Lemma Ectx_step' K e1 σ1 κ e2 σ2 efs :
- head_step e1 σ1 κ e2 σ2 efs → prim_step (fill K e1) σ1 κ (fill K e2) σ2 efs.
- Proof. econstructor; eauto. Qed.
-
- Definition ectx_lang_mixin : LanguageMixin of_val to_val prim_step.
- Proof.
- split.
- - apply ectx_language_mixin.
- - apply ectx_language_mixin.
- - intros ?????? [??? -> -> ?%val_head_stuck].
- apply eq_None_not_Some. by intros ?%fill_val%eq_None_not_Some.
- Qed.
-
- Canonical Structure ectx_lang : language := Language ectx_lang_mixin.
-
- Definition head_atomic (a : atomicity) (e : expr Λ) : Prop :=
- ∀ σ κ e' σ' efs,
- head_step e σ κ e' σ' efs →
- if a is WeaklyAtomic then irreducible e' σ' else is_Some (to_val e').
-
- (* Some lemmas about this language *)
- Lemma fill_not_val K e : to_val e = None → to_val (fill K e) = None.
- Proof. rewrite !eq_None_not_Some. eauto using fill_val. Qed.
-
- Lemma head_prim_step e1 σ1 κ e2 σ2 efs :
- head_step e1 σ1 κ e2 σ2 efs → prim_step e1 σ1 κ e2 σ2 efs.
- Proof. apply Ectx_step with empty_ectx; by rewrite ?fill_empty. Qed.
-
- Lemma head_reducible_no_obs_reducible e σ :
- head_reducible_no_obs e σ → head_reducible e σ.
- Proof. intros (?&?&?&?). eexists. eauto. Qed.
- Lemma not_head_reducible e σ : ¬head_reducible e σ ↔ head_irreducible e σ.
- Proof. unfold head_reducible, head_irreducible. naive_solver. Qed.
-
-
- Lemma fill_prim_step K e1 σ1 κ e2 σ2 efs :
- prim_step e1 σ1 κ e2 σ2 efs → prim_step (fill K e1) σ1 κ (fill K e2) σ2 efs.
- Proof.
- destruct 1 as [K' e1' e2' -> ->].
- rewrite !fill_comp. by econstructor.
- Qed.
- Lemma fill_reducible K e σ : reducible e σ → reducible (fill K e) σ.
- Proof.
- intros (κ&e'&σ'&efs&?). exists κ, (fill K e'), σ', efs.
- by apply fill_prim_step.
- Qed.
- Lemma head_prim_reducible e σ : head_reducible e σ → reducible e σ.
- Proof. intros (κ&e'&σ'&efs&?). eexists κ, e', σ', efs. by apply head_prim_step. Qed.
- Lemma head_prim_fill_reducible e K σ :
- head_reducible e σ → reducible (fill K e) σ.
- Proof. intro. by apply fill_reducible, head_prim_reducible. Qed.
- Lemma head_prim_reducible_no_obs e σ : head_reducible_no_obs e σ → reducible_no_obs e σ.
- Proof. intros (e'&σ'&efs&?). eexists e', σ', efs. by apply head_prim_step. Qed.
- Lemma head_prim_irreducible e σ : irreducible e σ → head_irreducible e σ.
- Proof.
- rewrite -not_reducible -not_head_reducible. eauto using head_prim_reducible.
- Qed.
-
- Lemma prim_head_reducible e σ :
- reducible e σ → sub_redexes_are_values e → head_reducible e σ.
- Proof.
- intros (κ&e'&σ'&efs&[K e1' e2' -> -> Hstep]) ?.
- assert (K = empty_ectx) as -> by eauto 10 using val_head_stuck.
- rewrite fill_empty /head_reducible; eauto.
- Qed.
- Lemma prim_head_irreducible e σ :
- head_irreducible e σ → sub_redexes_are_values e → irreducible e σ.
- Proof.
- rewrite -not_reducible -not_head_reducible. eauto using prim_head_reducible.
- Qed.
-
- Lemma head_stuck_stuck e σ :
- head_stuck e σ → sub_redexes_are_values e → stuck e σ.
- Proof.
- intros [] ?. split; first done.
- by apply prim_head_irreducible.
- Qed.
-
- Lemma ectx_language_atomic a e :
- head_atomic a e → sub_redexes_are_values e → Atomic a e.
- Proof.
- intros Hatomic_step Hatomic_fill σ κ e' σ' efs [K e1' e2' -> -> Hstep].
- assert (K = empty_ectx) as -> by eauto 10 using val_head_stuck.
- rewrite fill_empty. eapply Hatomic_step. by rewrite fill_empty.
- Qed.
-
- Lemma head_reducible_prim_step e1 σ1 κ e2 σ2 efs :
- head_reducible e1 σ1 →
- prim_step e1 σ1 κ e2 σ2 efs →
- head_step e1 σ1 κ e2 σ2 efs.
- Proof.
- intros (κ'&e2''&σ2''&efs''&?) [K e1' e2' -> -> Hstep].
- destruct (step_by_val K empty_ectx e1' (fill K e1') σ1 κ' e2'' σ2'' efs'')
- as [K' [-> _]%symmetry%ectx_positive];
- eauto using fill_empty, fill_not_val, val_head_stuck.
- by rewrite !fill_empty.
- Qed.
-
- (* Every evaluation context is a context. *)
- Global Instance ectx_lang_ctx K : LanguageCtx (fill K).
- Proof.
- split; simpl.
- - eauto using fill_not_val.
- - intros ?????? [K' e1' e2' Heq1 Heq2 Hstep].
- by exists (comp_ectx K K') e1' e2'; rewrite ?Heq1 ?Heq2 ?fill_comp.
- - intros e1 σ1 κ e2 σ2 ? Hnval [K'' e1'' e2'' Heq1 -> Hstep].
- destruct (step_by_val K K'' e1 e1'' σ1 κ e2'' σ2 efs) as [K' ->]; eauto.
- rewrite -fill_comp in Heq1; apply (inj (fill _)) in Heq1.
- exists (fill K' e2''); rewrite -fill_comp; split; auto.
- econstructor; eauto.
- Qed.
-
- Record pure_head_step (e1 e2 : expr Λ) := {
- pure_head_step_safe σ1 : head_reducible_no_obs e1 σ1;
- pure_head_step_det σ1 κ e2' σ2 efs :
- head_step e1 σ1 κ e2' σ2 efs → κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs = []
- }.
-
- Lemma pure_head_step_pure_step e1 e2 : pure_head_step e1 e2 → pure_step e1 e2.
- Proof.
- intros [Hp1 Hp2]. split.
- - intros σ. destruct (Hp1 σ) as (e2' & σ2 & efs & ?).
- eexists e2', σ2, efs. by apply head_prim_step.
- - intros σ1 κ e2' σ2 efs ?%head_reducible_prim_step; eauto using head_reducible_no_obs_reducible.
- Qed.
-
- Global Instance pure_exec_fill K φ n e1 e2 :
- PureExec φ n e1 e2 →
- PureExec φ n (fill K e1) (fill K e2).
- Proof. apply: pure_exec_ctx. Qed.
-End ectx_language.
-
-Arguments ectx_lang : clear implicits.
-Coercion ectx_lang : ectxLanguage >-> language.
-
-(* This definition makes sure that the fields of the [language] record do not
-refer to the projections of the [ectxLanguage] record but to the actual fields
-of the [ectxLanguage] record. This is crucial for canonical structure search to
-work.
-
-Note that this trick no longer works when we switch to canonical projections
-because then the pattern match [let '...] will be desugared into projections. *)
-Definition LanguageOfEctx (Λ : ectxLanguage) : language :=
- let '@EctxLanguage E V C St K of_val to_val empty comp fill head mix := Λ in
- @Language E V St K of_val to_val _
- (@ectx_lang_mixin (@EctxLanguage E V C St K of_val to_val empty comp fill head mix)).
diff --git a/theories/program_logic/ectx_lifting.v b/theories/program_logic/ectx_lifting.v
deleted file mode 100644
index 57131548..00000000
--- a/theories/program_logic/ectx_lifting.v
+++ /dev/null
@@ -1,178 +0,0 @@
-(** Some derived lemmas for ectx-based languages *)
-From iris.program_logic Require Export ectx_language weakestpre lifting.
-From iris.proofmode Require Import tactics.
-Set Default Proof Using "Type".
-
-Section wp.
-Context {SI} {Σ: gFunctors SI} {Λ : ectxLanguage} `{!irisG Λ Σ} {Hinh : Inhabited (state Λ)}.
-Implicit Types s : stuckness.
-Implicit Types P : iProp Σ.
-Implicit Types Φ : val Λ → iProp Σ.
-Implicit Types v : val Λ.
-Implicit Types e : expr Λ.
-Hint Resolve head_prim_reducible head_reducible_prim_step : core.
-Hint Resolve (reducible_not_val _ inhabitant) : core.
-Hint Resolve head_stuck_stuck : core.
-
-Lemma wp_lift_head_step_fupd {s E Φ} e1 :
- to_val e1 = None →
- (∀ σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E,∅}=∗
- ⌜head_reducible e1 σ1⌝ ∗
- ∀ e2 σ2 efs, ⌜head_step e1 σ1 κ e2 σ2 efs⌝ ={∅,∅,E}▷=∗
- state_interp σ2 κs (length efs + n) ∗
- WP e2 @ s; E {{ Φ }} ∗
- [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ fork_post }})
- ⊢ WP e1 @ s; E {{ Φ }}.
-Proof.
- iIntros (?) "H". iApply wp_lift_step_fupd=>//. iIntros (σ1 κ κs Qs) "Hσ".
- iMod ("H" with "Hσ") as "[% H]"; iModIntro.
- iSplit; first by destruct s; eauto. iIntros (e2 σ2 efs ?).
- iApply "H"; eauto.
-Qed.
-
-Lemma wp_lift_head_step {s E Φ} e1 :
- to_val e1 = None →
- (∀ σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E,∅}=∗
- ⌜head_reducible e1 σ1⌝ ∗
- ▷ ∀ e2 σ2 efs, ⌜head_step e1 σ1 κ e2 σ2 efs⌝ ={∅,E}=∗
- state_interp σ2 κs (length efs + n) ∗
- WP e2 @ s; E {{ Φ }} ∗
- [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ fork_post }})
- ⊢ WP e1 @ s; E {{ Φ }}.
-Proof.
- iIntros (?) "H". iApply wp_lift_head_step_fupd; [done|]. iIntros (????) "?".
- iMod ("H" with "[$]") as "[$ H]". iIntros "!>" (e2 σ2 efs ?) "!> !>". by iApply "H".
-Qed.
-
-Lemma wp_lift_head_stuck E Φ e :
- to_val e = None →
- sub_redexes_are_values e →
- (∀ σ κs n, state_interp σ κs n ={E,∅}=∗ ⌜head_stuck e σ⌝)
- ⊢ WP e @ E ?{{ Φ }}.
-Proof.
- iIntros (??) "H". iApply wp_lift_stuck; first done.
- iIntros (σ κs n) "Hσ". iMod ("H" with "Hσ") as "%". by auto.
-Qed.
-
-Lemma wp_lift_pure_head_stuck E Φ e :
- to_val e = None →
- sub_redexes_are_values e →
- (∀ σ, head_stuck e σ) →
- WP e @ E ?{{ Φ }}%I.
-Proof.
- iIntros (?? Hstuck). iApply wp_lift_head_stuck; [done|done|].
- iIntros (σ κs n) "_". iMod (fupd_intro_mask' E ∅) as "_"; first set_solver.
- by auto.
-Qed.
-
-Lemma wp_lift_atomic_head_step_fupd {s E1 E2 Φ} e1 :
- to_val e1 = None →
- (∀ σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E1}=∗
- ⌜head_reducible e1 σ1⌝ ∗
- ∀ e2 σ2 efs, ⌜head_step e1 σ1 κ e2 σ2 efs⌝ ={E1,E2}▷=∗
- state_interp σ2 κs (length efs + n) ∗
- from_option Φ False (to_val e2) ∗
- [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ fork_post }})
- ⊢ WP e1 @ s; E1 {{ Φ }}.
-Proof.
- iIntros (?) "H". iApply wp_lift_atomic_step_fupd; [done|].
- iIntros (σ1 κ κs Qs) "Hσ1". iMod ("H" with "Hσ1") as "[% H]"; iModIntro.
- iSplit; first by destruct s; auto. iIntros (e2 σ2 efs Hstep).
- iApply "H"; eauto.
-Qed.
-
-Lemma wp_lift_atomic_head_step {s E Φ} e1 :
- to_val e1 = None →
- (∀ σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E}=∗
- ⌜head_reducible e1 σ1⌝ ∗
- ▷ ∀ e2 σ2 efs, ⌜head_step e1 σ1 κ e2 σ2 efs⌝ ={E}=∗
- state_interp σ2 κs (length efs + n) ∗
- from_option Φ False (to_val e2) ∗
- [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ fork_post }})
- ⊢ WP e1 @ s; E {{ Φ }}.
-Proof.
- iIntros (?) "H". iApply wp_lift_atomic_step; eauto.
- iIntros (σ1 κ κs Qs) "Hσ1". iMod ("H" with "Hσ1") as "[% H]"; iModIntro.
- iSplit; first by destruct s; auto. iNext. iIntros (e2 σ2 efs Hstep).
- iApply "H"; eauto.
-Qed.
-
-Lemma swp_lift_atomic_head_step {k s E Φ} e1 :
- (∀ σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E}=∗
- ⌜head_reducible e1 σ1⌝ ∗
- ▷ ∀ e2 σ2 efs, ⌜head_step e1 σ1 κ e2 σ2 efs⌝ ={E}=∗
- state_interp σ2 κs (length efs + n) ∗
- from_option Φ False (to_val e2) ∗
- [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ fork_post }})
- ⊢ SWP e1 at k @ s; E {{ Φ }}.
-Proof.
- iIntros "H". iApply swp_lift_atomic_step; eauto.
- iIntros (σ1 κ κs Qs) "Hσ1". iMod ("H" with "Hσ1") as "[% H]"; iModIntro.
- iSplit; first by destruct s; auto. iNext. iIntros (e2 σ2 efs Hstep).
- iApply "H"; eauto.
-Qed.
-
-Lemma wp_lift_atomic_head_step_no_fork_fupd {s E1 E2 Φ} e1 :
- to_val e1 = None →
- (∀ σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E1}=∗
- ⌜head_reducible e1 σ1⌝ ∗
- ∀ e2 σ2 efs, ⌜head_step e1 σ1 κ e2 σ2 efs⌝ ={E1,E2}▷=∗
- ⌜efs = []⌝ ∗ state_interp σ2 κs n ∗ from_option Φ False (to_val e2))
- ⊢ WP e1 @ s; E1 {{ Φ }}.
-Proof.
- iIntros (?) "H". iApply wp_lift_atomic_head_step_fupd; [done|].
- iIntros (σ1 κ κs Qs) "Hσ1". iMod ("H" $! σ1 with "Hσ1") as "[$ H]"; iModIntro.
- iIntros (v2 σ2 efs Hstep).
- iMod ("H" $! v2 σ2 efs with "[# //]") as "H".
- iIntros "!> !>". iMod "H" as "(-> & ? & ?) /=". by iFrame.
-Qed.
-
-Lemma wp_lift_atomic_head_step_no_fork {s E Φ} e1 :
- to_val e1 = None →
- (∀ σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E}=∗
- ⌜head_reducible e1 σ1⌝ ∗
- ▷ ∀ e2 σ2 efs, ⌜head_step e1 σ1 κ e2 σ2 efs⌝ ={E}=∗
- ⌜efs = []⌝ ∗ state_interp σ2 κs n ∗ from_option Φ False (to_val e2))
- ⊢ WP e1 @ s; E {{ Φ }}.
-Proof.
- iIntros (?) "H". iApply wp_lift_atomic_head_step; eauto.
- iIntros (σ1 κ κs Qs) "Hσ1". iMod ("H" $! σ1 with "Hσ1") as "[$ H]"; iModIntro.
- iNext; iIntros (v2 σ2 efs Hstep).
- iMod ("H" $! v2 σ2 efs with "[//]") as "(-> & ? & ?) /=". by iFrame.
-Qed.
-
-Lemma swp_lift_atomic_head_step_no_fork {k s E Φ} e1 :
- (∀ σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E}=∗
- ⌜head_reducible e1 σ1⌝ ∗
- ▷ ∀ e2 σ2 efs, ⌜head_step e1 σ1 κ e2 σ2 efs⌝ ={E}=∗
- ⌜efs = []⌝ ∗ state_interp σ2 κs n ∗ from_option Φ False (to_val e2))
- ⊢ SWP e1 at k @ s; E {{ Φ }}.
-Proof.
- iIntros "H". iApply swp_lift_atomic_head_step; eauto.
- iIntros (σ1 κ κs Qs) "Hσ1". iMod ("H" $! σ1 with "Hσ1") as "[$ H]"; iModIntro.
- iNext; iIntros (v2 σ2 efs Hstep).
- iMod ("H" $! v2 σ2 efs with "[//]") as "(-> & ? & ?) /=". by iFrame.
-Qed.
-
-Lemma wp_lift_pure_det_head_step_no_fork {s E E' Φ} e1 e2 :
- to_val e1 = None →
- (∀ σ1, head_reducible e1 σ1) →
- (∀ σ1 κ e2' σ2 efs',
- head_step e1 σ1 κ e2' σ2 efs' → κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) →
- (|={E,E'}▷=> WP e2 @ s; E {{ Φ }}) ⊢ WP e1 @ s; E {{ Φ }}.
-Proof using Hinh.
- intros. rewrite -(wp_lift_pure_det_step_no_fork e1 e2); eauto.
- destruct s; by auto.
-Qed.
-
-Lemma wp_lift_pure_det_head_step_no_fork' {s E Φ} e1 e2 :
- to_val e1 = None →
- (∀ σ1, head_reducible e1 σ1) →
- (∀ σ1 κ e2' σ2 efs',
- head_step e1 σ1 κ e2' σ2 efs' → κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) →
- ▷ WP e2 @ s; E {{ Φ }} ⊢ WP e1 @ s; E {{ Φ }}.
-Proof using Hinh.
- intros. rewrite -[(WP e1 @ s; _ {{ _ }})%I]wp_lift_pure_det_head_step_no_fork //.
- rewrite -step_fupd_intro //.
-Qed.
-End wp.
diff --git a/theories/program_logic/ectxi_language.v b/theories/program_logic/ectxi_language.v
deleted file mode 100644
index a8e3807d..00000000
--- a/theories/program_logic/ectxi_language.v
+++ /dev/null
@@ -1,156 +0,0 @@
-(** An axiomatization of languages based on evaluation context items, including
- a proof that these are instances of general ectx-based languages. *)
-From iris.algebra Require Export base.
-From iris.program_logic Require Import language ectx_language.
-Set Default Proof Using "Type".
-
-(* TAKE CARE: When you define an [ectxiLanguage] canonical structure for your
-language, you need to also define a corresponding [language] and [ectxLanguage]
-canonical structure for canonical structure inference to work properly. You
-should use the coercion [EctxLanguageOfEctxi] and [LanguageOfEctx] for that, and
-not [ectxi_lang] and [ectxi_lang_ectx], otherwise the canonical projections will
-not point to the right terms.
-
-A full concrete example of setting up your language can be found in [heap_lang].
-Below you can find the relevant parts:
-
- Module heap_lang.
- (* Your language definition *)
-
- Lemma heap_lang_mixin : EctxiLanguageMixin of_val to_val fill_item head_step.
- Proof. (* ... *) Qed.
- End heap_lang.
-
- Canonical Structure heap_ectxi_lang := EctxiLanguage heap_lang.heap_lang_mixin.
- Canonical Structure heap_ectx_lang := EctxLanguageOfEctxi heap_ectxi_lang.
- Canonical Structure heap_lang := LanguageOfEctx heap_ectx_lang.
-*)
-
-Section ectxi_language_mixin.
- Context {expr val ectx_item state observation : Type}.
- Context (of_val : val → expr).
- Context (to_val : expr → option val).
- Context (fill_item : ectx_item → expr → expr).
- Context (head_step : expr → state → list observation → expr → state → list expr → Prop).
-
- Record EctxiLanguageMixin := {
- mixin_to_of_val v : to_val (of_val v) = Some v;
- mixin_of_to_val e v : to_val e = Some v → of_val v = e;
- mixin_val_stuck e1 σ1 κ e2 σ2 efs : head_step e1 σ1 κ e2 σ2 efs → to_val e1 = None;
-
- mixin_fill_item_inj Ki : Inj (=) (=) (fill_item Ki);
- mixin_fill_item_val Ki e : is_Some (to_val (fill_item Ki e)) → is_Some (to_val e);
- mixin_fill_item_no_val_inj Ki1 Ki2 e1 e2 :
- to_val e1 = None → to_val e2 = None →
- fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2;
-
- mixin_head_ctx_step_val Ki e σ1 κ e2 σ2 efs :
- head_step (fill_item Ki e) σ1 κ e2 σ2 efs → is_Some (to_val e);
- }.
-End ectxi_language_mixin.
-
-Structure ectxiLanguage := EctxiLanguage {
- expr : Type;
- val : Type;
- ectx_item : Type;
- state : Type;
- observation : Type;
-
- of_val : val → expr;
- to_val : expr → option val;
- fill_item : ectx_item → expr → expr;
- head_step : expr → state → list observation → expr → state → list expr → Prop;
-
- ectxi_language_mixin :
- EctxiLanguageMixin of_val to_val fill_item head_step
-}.
-
-Arguments EctxiLanguage {_ _ _ _ _ _ _ _ _} _.
-Arguments of_val {_} _%V.
-Arguments to_val {_} _%E.
-Arguments fill_item {_} _ _%E.
-Arguments head_step {_} _%E _ _ _%E _ _.
-
-Section ectxi_language.
- Context {Λ : ectxiLanguage}.
- Implicit Types (e : expr Λ) (Ki : ectx_item Λ).
- Notation ectx := (list (ectx_item Λ)).
-
- (* Only project stuff out of the mixin that is not also in ectxLanguage *)
- Global Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki).
- Proof. apply ectxi_language_mixin. Qed.
- Lemma fill_item_val Ki e : is_Some (to_val (fill_item Ki e)) → is_Some (to_val e).
- Proof. apply ectxi_language_mixin. Qed.
- Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 :
- to_val e1 = None → to_val e2 = None →
- fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2.
- Proof. apply ectxi_language_mixin. Qed.
- Lemma head_ctx_step_val Ki e σ1 κ e2 σ2 efs :
- head_step (fill_item Ki e) σ1 κ e2 σ2 efs → is_Some (to_val e).
- Proof. apply ectxi_language_mixin. Qed.
-
- Definition fill (K : ectx) (e : expr Λ) : expr Λ := foldl (flip fill_item) e K.
-
- Lemma fill_app (K1 K2 : ectx) e : fill (K1 ++ K2) e = fill K2 (fill K1 e).
- Proof. apply foldl_app. Qed.
-
- Lemma fill_cons Ki (K2 : ectx) e : fill (Ki :: K2) e = fill K2 (fill_item Ki e).
- Proof. replace (Ki :: K2) with ([Ki] ++ K2) by auto. rewrite fill_app //. Qed.
-
- Definition ectxi_lang_ectx_mixin :
- EctxLanguageMixin of_val to_val [] (flip (++)) fill head_step.
- Proof.
- assert (fill_val : ∀ K e, is_Some (to_val (fill K e)) → is_Some (to_val e)).
- { intros K. induction K as [|Ki K IH]=> e //=. by intros ?%IH%fill_item_val. }
- assert (fill_not_val : ∀ K e, to_val e = None → to_val (fill K e) = None).
- { intros K e. rewrite !eq_None_not_Some. eauto. }
- split.
- - apply ectxi_language_mixin.
- - apply ectxi_language_mixin.
- - apply ectxi_language_mixin.
- - done.
- - intros K1 K2 e. by rewrite /fill /= foldl_app.
- - intros K; induction K as [|Ki K IH]; rewrite /Inj; naive_solver.
- - done.
- - by intros [] [].
- - intros K K' e1 κ e1' σ1 e2 σ2 efs Hfill Hred Hstep; revert K' Hfill.
- induction K as [|Ki K IH] using rev_ind=> /= K' Hfill; eauto using app_nil_r.
- destruct K' as [|Ki' K' _] using @rev_ind; simplify_eq/=.
- { rewrite fill_app in Hstep. apply head_ctx_step_val in Hstep.
- apply fill_val in Hstep. by apply not_eq_None_Some in Hstep. }
- rewrite !fill_app /= in Hfill.
- assert (Ki = Ki') as ->.
- { eapply fill_item_no_val_inj, Hfill; eauto using val_head_stuck.
- apply fill_not_val. revert Hstep. apply ectxi_language_mixin. }
- simplify_eq. destruct (IH K') as [K'' ->]; auto.
- exists K''. by rewrite assoc.
- Qed.
-
- Canonical Structure ectxi_lang_ectx := EctxLanguage ectxi_lang_ectx_mixin.
- Canonical Structure ectxi_lang := LanguageOfEctx ectxi_lang_ectx.
-
- Lemma fill_not_val K e : to_val e = None → to_val (fill K e) = None.
- Proof. rewrite !eq_None_not_Some. eauto using fill_val. Qed.
-
- Lemma ectxi_language_sub_redexes_are_values e :
- (∀ Ki e', e = fill_item Ki e' → is_Some (to_val e')) →
- sub_redexes_are_values e.
- Proof.
- intros Hsub K e' ->. destruct K as [|Ki K _] using @rev_ind=> //=.
- intros []%eq_None_not_Some. eapply fill_val, Hsub. by rewrite /= fill_app.
- Qed.
-
- Global Instance ectxi_lang_ctx_item Ki : LanguageCtx (fill_item Ki).
- Proof. change (LanguageCtx (fill [Ki])). apply _. Qed.
-End ectxi_language.
-
-Arguments fill {_} _ _%E.
-Arguments ectxi_lang_ectx : clear implicits.
-Arguments ectxi_lang : clear implicits.
-Coercion ectxi_lang_ectx : ectxiLanguage >-> ectxLanguage.
-Coercion ectxi_lang : ectxiLanguage >-> language.
-
-Definition EctxLanguageOfEctxi (Λ : ectxiLanguage) : ectxLanguage :=
- let '@EctxiLanguage E V C St K of_val to_val fill head mix := Λ in
- @EctxLanguage E V (list C) St K of_val to_val _ _ _ _
- (@ectxi_lang_ectx_mixin (@EctxiLanguage E V C St K of_val to_val fill head mix)).
diff --git a/theories/program_logic/hoare.v b/theories/program_logic/hoare.v
deleted file mode 100644
index 4e03f84b..00000000
--- a/theories/program_logic/hoare.v
+++ /dev/null
@@ -1,162 +0,0 @@
-From iris.program_logic Require Export weakestpre.
-From iris.base_logic.lib Require Export viewshifts.
-From iris.proofmode Require Import tactics.
-Set Default Proof Using "Type".
-
-Definition ht {SI} `{!@irisG Λ SI Σ} (s : stuckness) (E : coPset) (P : iProp Σ)
- (e : expr Λ) (Φ : val Λ → iProp Σ) : iProp Σ :=
- (□ (P -∗ WP e @ s; E {{ Φ }}))%I.
-Instance: Params (@ht) 6 := {}.
-
-Notation "{{ P } } e @ s ; E {{ Φ } }" := (ht s E P%I e%E Φ%I)
- (at level 20, P, e, Φ at level 200,
- format "{{ P } } e @ s ; E {{ Φ } }") : stdpp_scope.
-Notation "{{ P } } e @ E {{ Φ } }" := (ht NotStuck E P%I e%E Φ%I)
- (at level 20, P, e, Φ at level 200,
- format "{{ P } } e @ E {{ Φ } }") : stdpp_scope.
-Notation "{{ P } } e @ E ? {{ Φ } }" := (ht MaybeStuck E P%I e%E Φ%I)
- (at level 20, P, e, Φ at level 200,
- format "{{ P } } e @ E ? {{ Φ } }") : stdpp_scope.
-Notation "{{ P } } e {{ Φ } }" := (ht NotStuck ⊤ P%I e%E Φ%I)
- (at level 20, P, e, Φ at level 200,
- format "{{ P } } e {{ Φ } }") : stdpp_scope.
-Notation "{{ P } } e ? {{ Φ } }" := (ht MaybeStuck ⊤ P%I e%E Φ%I)
- (at level 20, P, e, Φ at level 200,
- format "{{ P } } e ? {{ Φ } }") : stdpp_scope.
-
-Notation "{{ P } } e @ s ; E {{ v , Q } }" := (ht s E P%I e%E (λ v, Q)%I)
- (at level 20, P, e, Q at level 200,
- format "{{ P } } e @ s ; E {{ v , Q } }") : stdpp_scope.
-Notation "{{ P } } e @ E {{ v , Q } }" := (ht NotStuck E P%I e%E (λ v, Q)%I)
- (at level 20, P, e, Q at level 200,
- format "{{ P } } e @ E {{ v , Q } }") : stdpp_scope.
-Notation "{{ P } } e @ E ? {{ v , Q } }" := (ht MaybeStuck E P%I e%E (λ v, Q)%I)
- (at level 20, P, e, Q at level 200,
- format "{{ P } } e @ E ? {{ v , Q } }") : stdpp_scope.
-Notation "{{ P } } e {{ v , Q } }" := (ht NotStuck ⊤ P%I e%E (λ v, Q)%I)
- (at level 20, P, e, Q at level 200,
- format "{{ P } } e {{ v , Q } }") : stdpp_scope.
-Notation "{{ P } } e ? {{ v , Q } }" := (ht MaybeStuck ⊤ P%I e%E (λ v, Q)%I)
- (at level 20, P, e, Q at level 200,
- format "{{ P } } e ? {{ v , Q } }") : stdpp_scope.
-
-Section hoare.
-Context {SI} `{!@irisG Λ SI Σ}.
-Implicit Types s : stuckness.
-Implicit Types P Q : iProp Σ.
-Implicit Types Φ Ψ : val Λ → iProp Σ.
-Implicit Types v : val Λ.
-Import uPred.
-
-Global Instance ht_ne s E n :
- Proper (dist n ==> eq ==> pointwise_relation _ (dist n) ==> dist n) (ht s E).
-Proof. solve_proper. Qed.
-Global Instance ht_proper s E :
- Proper ((≡) ==> eq ==> pointwise_relation _ (≡) ==> (≡)) (ht s E).
-Proof. solve_proper. Qed.
-Lemma ht_mono s E P P' Φ Φ' e :
- (P ⊢ P') → (∀ v, Φ' v ⊢ Φ v) → {{ P' }} e @ s; E {{ Φ' }} ⊢ {{ P }} e @ s; E {{ Φ }}.
-Proof. by intros; apply affinely_mono, persistently_mono, wand_mono, wp_mono. Qed.
-Lemma ht_stuck_mono s1 s2 E P Φ e :
- s1 ⊑ s2 → {{ P }} e @ s1; E {{ Φ }} ⊢ {{ P }} e @ s2; E {{ Φ }}.
-Proof. by intros; apply affinely_mono, persistently_mono, wand_mono, wp_stuck_mono. Qed.
-Global Instance ht_mono' s E :
- Proper (flip (⊢) ==> eq ==> pointwise_relation _ (⊢) ==> (⊢)) (ht s E).
-Proof. solve_proper. Qed.
-
-Lemma ht_alt s E P Φ e : (P ⊢ WP e @ s; E {{ Φ }}) → {{ P }} e @ s; E {{ Φ }}.
-Proof. iIntros (Hwp) "!# HP". by iApply Hwp. Qed.
-
-Lemma ht_val s E v : {{ True }} of_val v @ s; E {{ v', ⌜v = v'⌝ }}.
-Proof. iIntros "!# _". by iApply wp_value'. Qed.
-
-Lemma ht_vs s E P P' Φ Φ' e :
- (P ={E}=> P') ∧ {{ P' }} e @ s; E {{ Φ' }} ∧ (∀ v, Φ' v ={E}=> Φ v)
- ⊢ {{ P }} e @ s; E {{ Φ }}.
-Proof.
- iIntros "(#Hvs & #Hwp & #HΦ) !# HP". iMod ("Hvs" with "HP") as "HP".
- iApply wp_fupd. iApply (wp_wand with "(Hwp HP)").
- iIntros (v) "Hv". by iApply "HΦ".
-Qed.
-
-Lemma ht_atomic s E1 E2 P P' Φ Φ' e `{!Atomic StronglyAtomic e} :
- (P ={E1,E2}=> P') ∧ {{ P' }} e @ s; E2 {{ Φ' }} ∧ (∀ v, Φ' v ={E2,E1}=> Φ v)
- ⊢ {{ P }} e @ s; E1 {{ Φ }}.
-Proof.
- iIntros "(#Hvs & #Hwp & #HΦ) !# HP". iApply (wp_atomic _ E2); auto.
- iMod ("Hvs" with "HP") as "HP". iModIntro.
- iApply (wp_wand with "(Hwp HP)").
- iIntros (v) "Hv". by iApply "HΦ".
-Qed.
-
-Lemma ht_bind `{!LanguageCtx K} s E P Φ Φ' e :
- {{ P }} e @ s; E {{ Φ }} ∧ (∀ v, {{ Φ v }} K (of_val v) @ s; E {{ Φ' }})
- ⊢ {{ P }} K e @ s; E {{ Φ' }}.
-Proof.
- iIntros "[#Hwpe #HwpK] !# HP". iApply wp_bind.
- iApply (wp_wand with "(Hwpe HP)").
- iIntros (v) "Hv". by iApply "HwpK".
-Qed.
-
-Lemma ht_stuck_weaken s E P Φ e :
- {{ P }} e @ s; E {{ Φ }} ⊢ {{ P }} e @ E ?{{ Φ }}.
-Proof.
- by iIntros "#Hwp !# ?"; iApply wp_stuck_weaken; iApply "Hwp".
-Qed.
-
-Lemma ht_mask_weaken s E1 E2 P Φ e :
- E1 ⊆ E2 → {{ P }} e @ s; E1 {{ Φ }} ⊢ {{ P }} e @ s; E2 {{ Φ }}.
-Proof.
- iIntros (?) "#Hwp !# HP". iApply (wp_mask_mono _ E1 E2); try done.
- by iApply "Hwp".
-Qed.
-
-Lemma ht_frame_l s E P Φ R e :
- {{ P }} e @ s; E {{ Φ }} ⊢ {{ R ∗ P }} e @ s; E {{ v, R ∗ Φ v }}.
-Proof. iIntros "#Hwp !# [$ HP]". by iApply "Hwp". Qed.
-
-Lemma ht_frame_r s E P Φ R e :
- {{ P }} e @ s; E {{ Φ }} ⊢ {{ P ∗ R }} e @ s; E {{ v, Φ v ∗ R }}.
-Proof. iIntros "#Hwp !# [HP $]". by iApply "Hwp". Qed.
-
-Lemma ht_frame_step_l s E1 E2 P R1 R2 e Φ :
- to_val e = None → E2 ⊆ E1 →
- (R1 ={E1,E2}=> ▷ |={E2,E1}=> R2) ∧ {{ P }} e @ s; E2 {{ Φ }}
- ⊢ {{ R1 ∗ P }} e @ s; E1 {{ λ v, R2 ∗ Φ v }}.
-Proof.
- iIntros (??) "[#Hvs #Hwp] !# [HR HP]".
- iApply (wp_frame_step_l _ E1 E2); try done.
- iSplitL "HR"; [by iApply "Hvs"|by iApply "Hwp"].
-Qed.
-
-Lemma ht_frame_step_r s E1 E2 P R1 R2 e Φ :
- to_val e = None → E2 ⊆ E1 →
- (R1 ={E1,E2}=> ▷ |={E2,E1}=> R2) ∧ {{ P }} e @ s; E2 {{ Φ }}
- ⊢ {{ P ∗ R1 }} e @ s; E1 {{ λ v, Φ v ∗ R2 }}.
-Proof.
- iIntros (??) "[#Hvs #Hwp] !# [HP HR]".
- iApply (wp_frame_step_r _ E1 E2); try done.
- iSplitR "HR"; [by iApply "Hwp"|by iApply "Hvs"].
-Qed.
-
-Lemma ht_frame_step_l' s E P R e Φ :
- to_val e = None →
- {{ P }} e @ s; E {{ Φ }} ⊢ {{ ▷ R ∗ P }} e @ s; E {{ v, R ∗ Φ v }}.
-Proof.
- iIntros (?) "#Hwp !# [HR HP]".
- iApply wp_frame_step_l'; try done. iFrame "HR". by iApply "Hwp".
-Qed.
-
-Lemma ht_frame_step_r' s E P Φ R e :
- to_val e = None →
- {{ P }} e @ s; E {{ Φ }} ⊢ {{ P ∗ ▷ R }} e @ s; E {{ v, Φ v ∗ R }}.
-Proof.
- iIntros (?) "#Hwp !# [HP HR]".
- iApply wp_frame_step_r'; try done. iFrame "HR". by iApply "Hwp".
-Qed.
-
-Lemma ht_exists (T : Type) s E (P : T → iProp Σ) Φ e :
- (∀ x, {{ P x }} e @ s; E {{ Φ }}) ⊢ {{ ∃ x, P x }} e @ s; E {{ Φ }}.
-Proof. iIntros "#HT !# HP". iDestruct "HP" as (x) "HP". by iApply "HT". Qed.
-
-End hoare.
diff --git a/theories/program_logic/language.v b/theories/program_logic/language.v
deleted file mode 100644
index e8862d49..00000000
--- a/theories/program_logic/language.v
+++ /dev/null
@@ -1,234 +0,0 @@
-From iris.algebra Require Export ofe.
-Set Default Proof Using "Type".
-
-Section language_mixin.
- Context {expr val state observation : Type}.
- Context (of_val : val → expr).
- Context (to_val : expr → option val).
- (** We annotate the reduction relation with observations [κ], which we will
- use in the definition of weakest preconditions to predict future
- observations and assert correctness of the predictions. *)
- Context (prim_step : expr → state → list observation → expr → state → list expr → Prop).
-
- Record LanguageMixin := {
- mixin_to_of_val v : to_val (of_val v) = Some v;
- mixin_of_to_val e v : to_val e = Some v → of_val v = e;
- mixin_val_stuck e σ κ e' σ' efs : prim_step e σ κ e' σ' efs → to_val e = None
- }.
-End language_mixin.
-
-Structure language := Language {
- expr : Type;
- val : Type;
- state : Type;
- observation : Type;
- of_val : val → expr;
- to_val : expr → option val;
- prim_step : expr → state → list observation → expr → state → list expr → Prop;
- language_mixin : LanguageMixin of_val to_val prim_step
-}.
-Delimit Scope expr_scope with E.
-Delimit Scope val_scope with V.
-Bind Scope expr_scope with expr.
-Bind Scope val_scope with val.
-
-Arguments Language {_ _ _ _ _ _ _} _.
-Arguments of_val {_} _.
-Arguments to_val {_} _.
-Arguments prim_step {_} _ _ _ _ _ _.
-
-Canonical Structure stateO (SI: indexT) Λ : ofeT SI := leibnizO SI (state Λ).
-Canonical Structure valO (SI: indexT) Λ : ofeT SI := leibnizO SI (val Λ).
-Canonical Structure exprO (SI: indexT) Λ : ofeT SI := leibnizO SI (expr Λ).
-
-Definition cfg (Λ : language) := (list (expr Λ) * state Λ)%type.
-
-Class LanguageCtx {Λ : language} (K : expr Λ → expr Λ) := {
- fill_not_val e :
- to_val e = None → to_val (K e) = None;
- fill_step e1 σ1 κ e2 σ2 efs :
- prim_step e1 σ1 κ e2 σ2 efs →
- prim_step (K e1) σ1 κ (K e2) σ2 efs;
- fill_step_inv e1' σ1 κ e2 σ2 efs :
- to_val e1' = None → prim_step (K e1') σ1 κ e2 σ2 efs →
- ∃ e2', e2 = K e2' ∧ prim_step e1' σ1 κ e2' σ2 efs
-}.
-
-Instance language_ctx_id Λ : LanguageCtx (@id (expr Λ)).
-Proof. constructor; naive_solver. Qed.
-
-Inductive atomicity := StronglyAtomic | WeaklyAtomic.
-
-Section language.
- Context {Λ : language}.
- Implicit Types v : val Λ.
- Implicit Types e : expr Λ.
-
- Lemma to_of_val v : to_val (of_val v) = Some v.
- Proof. apply language_mixin. Qed.
- Lemma of_to_val e v : to_val e = Some v → of_val v = e.
- Proof. apply language_mixin. Qed.
- Lemma val_stuck e σ κ e' σ' efs : prim_step e σ κ e' σ' efs → to_val e = None.
- Proof. apply language_mixin. Qed.
-
- Definition reducible (e : expr Λ) (σ : state Λ) :=
- ∃ κ e' σ' efs, prim_step e σ κ e' σ' efs.
- (* Total WP only permits reductions without observations *)
- Definition reducible_no_obs (e : expr Λ) (σ : state Λ) :=
- ∃ e' σ' efs, prim_step e σ [] e' σ' efs.
- Definition irreducible (e : expr Λ) (σ : state Λ) :=
- ∀ κ e' σ' efs, ¬prim_step e σ κ e' σ' efs.
- Definition stuck (e : expr Λ) (σ : state Λ) :=
- to_val e = None ∧ irreducible e σ.
-
- (* [Atomic WeaklyAtomic]: This (weak) form of atomicity is enough to open
- invariants when WP ensures safety, i.e., programs never can get stuck. We
- have an example in lambdaRust of an expression that is atomic in this
- sense, but not in the stronger sense defined below, and we have to be able
- to open invariants around that expression. See `CasStuckS` in
- [lambdaRust](https://gitlab.mpi-sws.org/FP/LambdaRust-coq/blob/master/theories/lang/lang.v).
-
- [Atomic StronglyAtomic]: To open invariants with a WP that does not ensure
- safety, we need a stronger form of atomicity. With the above definition,
- in case `e` reduces to a stuck non-value, there is no proof that the
- invariants have been established again. *)
- Class Atomic (a : atomicity) (e : expr Λ) : Prop :=
- atomic σ e' κ σ' efs :
- prim_step e σ κ e' σ' efs →
- if a is WeaklyAtomic then irreducible e' σ' else is_Some (to_val e').
-
- Inductive step (ρ1 : cfg Λ) (κ : list (observation Λ)) (ρ2 : cfg Λ) : Prop :=
- | step_atomic e1 σ1 e2 σ2 efs t1 t2 :
- ρ1 = (t1 ++ e1 :: t2, σ1) →
- ρ2 = (t1 ++ e2 :: t2 ++ efs, σ2) →
- prim_step e1 σ1 κ e2 σ2 efs →
- step ρ1 κ ρ2.
- Hint Constructors step : core.
-
- Inductive nsteps : nat → cfg Λ → list (observation Λ) → cfg Λ → Prop :=
- | nsteps_refl ρ :
- nsteps 0 ρ [] ρ
- | nsteps_l n ρ1 ρ2 ρ3 κ κs :
- step ρ1 κ ρ2 →
- nsteps n ρ2 κs ρ3 →
- nsteps (S n) ρ1 (κ ++ κs) ρ3.
- Hint Constructors nsteps : core.
-
- Definition erased_step (ρ1 ρ2 : cfg Λ) := ∃ κ, step ρ1 κ ρ2.
-
- (** [rtc erased_step] and [nsteps] encode the same thing, just packaged
- in a different way. *)
- Lemma erased_steps_nsteps ρ1 ρ2 :
- rtc erased_step ρ1 ρ2 ↔ ∃ n κs, nsteps n ρ1 κs ρ2.
- Proof.
- split.
- - induction 1; firstorder eauto. (* FIXME: [naive_solver eauto] should be able to handle this *)
- - intros (n & κs & Hsteps). unfold erased_step.
- induction Hsteps; eauto using rtc_refl, rtc_l.
- Qed.
-
- Lemma of_to_val_flip v e : of_val v = e → to_val e = Some v.
- Proof. intros <-. by rewrite to_of_val. Qed.
-
- Lemma not_reducible e σ : ¬reducible e σ ↔ irreducible e σ.
- Proof. unfold reducible, irreducible. naive_solver. Qed.
- Lemma reducible_not_val e σ : reducible e σ → to_val e = None.
- Proof. intros (?&?&?&?&?); eauto using val_stuck. Qed.
- Lemma reducible_no_obs_reducible e σ : reducible_no_obs e σ → reducible e σ.
- Proof. intros (?&?&?&?); eexists; eauto. Qed.
- Lemma val_irreducible e σ : is_Some (to_val e) → irreducible e σ.
- Proof. intros [??] ???? ?%val_stuck. by destruct (to_val e). Qed.
- Global Instance of_val_inj : Inj (=) (=) (@of_val Λ).
- Proof. by intros v v' Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.
-
- Lemma strongly_atomic_atomic e a :
- Atomic StronglyAtomic e → Atomic a e.
- Proof. unfold Atomic. destruct a; eauto using val_irreducible. Qed.
-
- Lemma reducible_fill `{!@LanguageCtx Λ K} e σ :
- to_val e = None → reducible (K e) σ → reducible e σ.
- Proof.
- intros ? (e'&σ'&k&efs&Hstep); unfold reducible.
- apply fill_step_inv in Hstep as (e2' & _ & Hstep); eauto.
- Qed.
- Lemma reducible_no_obs_fill `{!@LanguageCtx Λ K} e σ :
- to_val e = None → reducible_no_obs (K e) σ → reducible_no_obs e σ.
- Proof.
- intros ? (e'&σ'&efs&Hstep); unfold reducible_no_obs.
- apply fill_step_inv in Hstep as (e2' & _ & Hstep); eauto.
- Qed.
- Lemma irreducible_fill `{!@LanguageCtx Λ K} e σ :
- to_val e = None → irreducible e σ → irreducible (K e) σ.
- Proof. rewrite -!not_reducible. naive_solver eauto using reducible_fill. Qed.
-
- Lemma stuck_fill `{!@LanguageCtx Λ K} e σ :
- stuck e σ → stuck (K e) σ.
- Proof. intros [??]. split. by apply fill_not_val. by apply irreducible_fill. Qed.
-
- Lemma step_Permutation (t1 t1' t2 : list (expr Λ)) κ σ1 σ2 :
- t1 ≡ₚ t1' → step (t1,σ1) κ (t2,σ2) → ∃ t2', t2 ≡ₚ t2' ∧ step (t1',σ1) κ (t2',σ2).
- Proof.
- intros Ht [e1 σ1' e2 σ2' efs tl tr ?? Hstep]; simplify_eq/=.
- move: Ht; rewrite -Permutation_middle (symmetry_iff (≡ₚ)).
- intros (tl'&tr'&->&Ht)%Permutation_cons_inv.
- exists (tl' ++ e2 :: tr' ++ efs); split; [|by econstructor].
- by rewrite -!Permutation_middle !assoc_L Ht.
- Qed.
-
- Lemma erased_step_Permutation (t1 t1' t2 : list (expr Λ)) σ1 σ2 :
- t1 ≡ₚ t1' → erased_step (t1,σ1) (t2,σ2) → ∃ t2', t2 ≡ₚ t2' ∧ erased_step (t1',σ1) (t2',σ2).
- Proof.
- intros Heq [? Hs]. pose proof (step_Permutation _ _ _ _ _ _ Heq Hs). firstorder.
- (* FIXME: [naive_solver] should be able to handle this *)
- Qed.
-
- Record pure_step (e1 e2 : expr Λ) := {
- pure_step_safe σ1 : reducible_no_obs e1 σ1;
- pure_step_det σ1 κ e2' σ2 efs :
- prim_step e1 σ1 κ e2' σ2 efs → κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs = []
- }.
-
- (* TODO: Exclude the case of [n=0], either here, or in [wp_pure] to avoid it
- succeeding when it did not actually do anything. *)
- Class PureExec (φ : Prop) (n : nat) (e1 e2 : expr Λ) :=
- pure_exec : φ → relations.nsteps pure_step n e1 e2.
-
- Lemma pure_step_ctx K `{!@LanguageCtx Λ K} e1 e2 :
- pure_step e1 e2 →
- pure_step (K e1) (K e2).
- Proof.
- intros [Hred Hstep]. split.
- - unfold reducible_no_obs in *. naive_solver eauto using fill_step.
- - intros σ1 κ e2' σ2 efs Hpstep.
- destruct (fill_step_inv e1 σ1 κ e2' σ2 efs) as (e2'' & -> & ?); [|exact Hpstep|].
- + destruct (Hred σ1) as (? & ? & ? & ?); eauto using val_stuck.
- + edestruct (Hstep σ1 κ e2'' σ2 efs) as (? & -> & -> & ->); auto.
- Qed.
-
- Lemma pure_step_nsteps_ctx K `{!@LanguageCtx Λ K} n e1 e2 :
- relations.nsteps pure_step n e1 e2 →
- relations.nsteps pure_step n (K e1) (K e2).
- Proof. induction 1; econstructor; eauto using pure_step_ctx. Qed.
-
- (* We do not make this an instance because it is awfully general. *)
- Lemma pure_exec_ctx K `{!@LanguageCtx Λ K} φ n e1 e2 :
- PureExec φ n e1 e2 →
- PureExec φ n (K e1) (K e2).
- Proof. rewrite /PureExec; eauto using pure_step_nsteps_ctx. Qed.
-
- (* This is a family of frequent assumptions for PureExec *)
- Class IntoVal (e : expr Λ) (v : val Λ) :=
- into_val : of_val v = e.
-
- Class AsVal (e : expr Λ) := as_val : ∃ v, of_val v = e.
- (* There is no instance [IntoVal → AsVal] as often one can solve [AsVal] more
- efficiently since no witness has to be computed. *)
- Global Instance as_vals_of_val vs : TCForall AsVal (of_val <$> vs).
- Proof.
- apply TCForall_Forall, Forall_fmap, Forall_true=> v.
- rewrite /AsVal /=; eauto.
- Qed.
- Lemma as_val_is_Some e :
- (∃ v, of_val v = e) → is_Some (to_val e).
- Proof. intros [v <-]. rewrite to_of_val. eauto. Qed.
-End language.
diff --git a/theories/program_logic/lifting.v b/theories/program_logic/lifting.v
deleted file mode 100644
index 36ceb429..00000000
--- a/theories/program_logic/lifting.v
+++ /dev/null
@@ -1,281 +0,0 @@
-From iris.program_logic Require Export weakestpre.
-From iris.proofmode Require Import tactics.
-Set Default Proof Using "Type".
-
-Section lifting.
-Context {SI} {Σ: gFunctors SI} `{!irisG Λ Σ}.
-Implicit Types s : stuckness.
-Implicit Types v : val Λ.
-Implicit Types e : expr Λ.
-Implicit Types σ : state Λ.
-Implicit Types P Q : iProp Σ.
-Implicit Types Φ : val Λ → iProp Σ.
-
-Hint Resolve reducible_no_obs_reducible : core.
-
-Lemma wp_lift_step_fupd s E Φ e1 :
- to_val e1 = None →
- (∀ σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E,∅}=∗
- ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
- ∀ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ ={∅,∅,E}▷=∗
- state_interp σ2 κs (length efs + n) ∗
- WP e2 @ s; E {{ Φ }} ∗
- [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ fork_post }})
- ⊢ WP e1 @ s; E {{ Φ }}.
-Proof.
- rewrite wp_unfold /wp_pre=>->. iIntros "H" (σ1 κ κs n) "Hσ".
- iMod ("H" with "Hσ") as "(%&H)". iApply lstep_intro. iModIntro. iSplit.
- by destruct s.
- iIntros (????). iApply "H". eauto.
-Qed.
-
-Lemma swp_lift_step_fupd k s E Φ e1 :
- (∀ σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E,∅}=∗
- ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
- ∀ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ ={∅,∅,E}▷=∗
- state_interp σ2 κs (length efs + n) ∗
- WP e2 @ s; E {{ Φ }} ∗
- [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ fork_post }})
- ⊢ SWP e1 at k @ s; E {{ Φ }}.
-Proof.
- rewrite swp_unfold /swp_def. iIntros "H" (σ1 κ κs n) "Hσ".
- iMod ("H" with "Hσ") as "(%&H)". iApply lstepN_intro. iModIntro.
- iSplit; eauto.
-Qed.
-
-Lemma wp_lift_stuck E Φ e :
- to_val e = None →
- (∀ σ κs n, state_interp σ κs n ={E,∅}=∗ ⌜stuck e σ⌝)
- ⊢ WP e @ E ?{{ Φ }}.
-Proof.
- rewrite wp_unfold /wp_pre=>->. iIntros "H" (σ1 κ κs n) "Hσ".
- iMod ("H" with "Hσ") as %[? Hirr]. iApply lstep_intro. iModIntro.
- iSplit; first done.
- iIntros (e2 σ2 efs ?). by case: (Hirr κ e2 σ2 efs).
-Qed.
-
-(** Derived lifting lemmas. *)
-Lemma wp_lift_step s E Φ e1 :
- to_val e1 = None →
- (∀ σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E,∅}=∗
- ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
- ▷ ∀ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ ={∅,E}=∗
- state_interp σ2 κs (length efs + n) ∗
- WP e2 @ s; E {{ Φ }} ∗
- [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ fork_post }})
- ⊢ WP e1 @ s; E {{ Φ }}.
-Proof.
- iIntros (?) "H". iApply wp_lift_step_fupd; [done|]. iIntros (????) "Hσ".
- iMod ("H" with "Hσ") as "[$ H]". iIntros "!> * % !> !>". by iApply "H".
-Qed.
-
-Lemma swp_lift_step k s E Φ e1 :
- (∀ σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E,∅}=∗
- ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
- ▷ ∀ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ ={∅,E}=∗
- state_interp σ2 κs (length efs + n) ∗
- WP e2 @ s; E {{ Φ }} ∗
- [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ fork_post }})
- ⊢ SWP e1 at k @ s; E {{ Φ }}.
-Proof.
- iIntros "H". iApply swp_lift_step_fupd. iIntros (????) "Hσ".
- iMod ("H" with "Hσ") as "[$ H]". iIntros "!> * % !> !>". by iApply "H".
-Qed.
-
-Lemma wp_lift_pure_step_no_fork `{!Inhabited (state Λ)} s E E' Φ e1 :
- (∀ σ1, if s is NotStuck then reducible e1 σ1 else to_val e1 = None) →
- (∀ κ σ1 e2 σ2 efs, prim_step e1 σ1 κ e2 σ2 efs → κ = [] ∧ σ2 = σ1 ∧ efs = []) →
- (|={E,E'}▷=> ∀ κ e2 efs σ, ⌜prim_step e1 σ κ e2 σ efs⌝ → WP e2 @ s; E {{ Φ }})
- ⊢ WP e1 @ s; E {{ Φ }}.
-Proof.
- iIntros (Hsafe Hstep) "H". iApply wp_lift_step.
- { specialize (Hsafe inhabitant). destruct s; eauto using reducible_not_val. }
- iIntros (σ1 κ κs n) "Hσ". iMod "H".
- iMod fupd_intro_mask' as "Hclose"; last iModIntro; first by set_solver. iSplit.
- { iPureIntro. destruct s; done. }
- iNext. iIntros (e2 σ2 efs ?).
- destruct (Hstep κ σ1 e2 σ2 efs) as (-> & <- & ->); auto.
- iMod "Hclose" as "_". iMod "H". iModIntro.
- iDestruct ("H" with "[//]") as "H". simpl. iFrame.
-Qed.
-
-
-Lemma swp_lift_pure_step_no_fork k s E E' Φ e1 :
- (∀ σ1, s = NotStuck → reducible e1 σ1) →
- (∀ κ σ1 e2 σ2 efs, prim_step e1 σ1 κ e2 σ2 efs → κ = [] ∧ σ2 = σ1 ∧ efs = []) →
- (|={E,E'}▷=> ∀ κ e2 efs σ, ⌜prim_step e1 σ κ e2 σ efs⌝ → WP e2 @ s; E {{ Φ }})
- ⊢ SWP e1 at k @ s; E {{ Φ }}.
-Proof.
- iIntros (Hsafe Hstep) "H". iApply swp_lift_step.
- iIntros (σ1 κ κs n) "Hσ". iMod "H".
- iMod fupd_intro_mask' as "Hclose"; last iModIntro; first by set_solver. iSplit.
- { iPureIntro. destruct s; eauto. }
- iNext. iIntros (e2 σ2 efs ?).
- destruct (Hstep κ σ1 e2 σ2 efs) as (-> & <- & ->); auto.
- iMod "Hclose" as "_". iMod "H". iModIntro.
- iDestruct ("H" with "[//]") as "H". simpl. iFrame.
-Qed.
-
-Lemma wp_lift_pure_stuck `{!Inhabited (state Λ)} E Φ e :
- (∀ σ, stuck e σ) →
- True ⊢ WP e @ E ?{{ Φ }}.
-Proof.
- iIntros (Hstuck) "_". iApply wp_lift_stuck.
- - destruct(to_val e) as [v|] eqn:He; last done.
- rewrite -He. by case: (Hstuck inhabitant).
- - iIntros (σ κs n) "_". by iMod (fupd_intro_mask' E ∅) as "_"; first set_solver.
-Qed.
-
-(* Atomic steps don't need any mask-changing business here, one can
- use the generic lemmas here. *)
-Lemma wp_lift_atomic_step_fupd {s E1 E2 Φ} e1 :
- to_val e1 = None →
- (∀ σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E1}=∗
- ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
- ∀ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ ={E1,E2}▷=∗
- state_interp σ2 κs (length efs + n) ∗
- from_option Φ False (to_val e2) ∗
- [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ fork_post }})
- ⊢ WP e1 @ s; E1 {{ Φ }}.
-Proof.
- iIntros (?) "H".
- iApply (wp_lift_step_fupd s E1 _ e1)=>//; iIntros (σ1 κ κs n) "Hσ1".
- iMod ("H" $! σ1 with "Hσ1") as "[$ H]".
- iMod (fupd_intro_mask' E1 ∅) as "Hclose"; first set_solver.
- iIntros "!>" (e2 σ2 efs ?). iMod "Hclose" as "_".
- iMod ("H" $! e2 σ2 efs with "[#]") as "H"; [done|].
- iMod (fupd_intro_mask' E2 ∅) as "Hclose"; [set_solver|]. iIntros "!> !>".
- iMod "Hclose" as "_". iMod "H" as "($ & HQ & $)".
- destruct (to_val e2) eqn:?; last by iExFalso.
- iApply wp_value; last done. by apply of_to_val.
-Qed.
-
-Lemma swp_lift_atomic_step_fupd {k s E1 E2 Φ} e1 :
- (∀ σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E1}=∗
- ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
- ∀ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ ={E1,E2}▷=∗
- state_interp σ2 κs (length efs + n) ∗
- from_option Φ False (to_val e2) ∗
- [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ fork_post }})
- ⊢ SWP e1 at k @ s; E1 {{ Φ }}.
-Proof.
- iIntros "H".
- iApply (swp_lift_step_fupd k s E1 _ e1)=>//; iIntros (σ1 κ κs n) "Hσ1".
- iMod ("H" $! σ1 with "Hσ1") as "[$ H]".
- iMod (fupd_intro_mask' E1 ∅) as "Hclose"; first set_solver.
- iIntros "!>" (e2 σ2 efs ?). iMod "Hclose" as "_".
- iMod ("H" $! e2 σ2 efs with "[#]") as "H"; [done|].
- iMod (fupd_intro_mask' E2 ∅) as "Hclose"; [set_solver|]. iIntros "!> !>".
- iMod "Hclose" as "_". iMod "H" as "($ & HQ & $)".
- destruct (to_val e2) eqn:?; last by iExFalso.
- iApply wp_value; last done. by apply of_to_val.
-Qed.
-
-Lemma wp_lift_atomic_step {s E Φ} e1 :
- to_val e1 = None →
- (∀ σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E}=∗
- ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
- ▷ ∀ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ ={E}=∗
- state_interp σ2 κs (length efs + n) ∗
- from_option Φ False (to_val e2) ∗
- [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ fork_post }})
- ⊢ WP e1 @ s; E {{ Φ }}.
-Proof.
- iIntros (?) "H". iApply wp_lift_atomic_step_fupd; [done|].
- iIntros (????) "?". iMod ("H" with "[$]") as "[$ H]".
- iIntros "!> *". iIntros (Hstep) "!> !>".
- by iApply "H".
-Qed.
-
-Lemma swp_lift_atomic_step {k s E Φ} e1 :
- (∀ σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E}=∗
- ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
- ▷ ∀ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ ={E}=∗
- state_interp σ2 κs (length efs + n) ∗
- from_option Φ False (to_val e2) ∗
- [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ fork_post }})
- ⊢ SWP e1 at k @ s; E {{ Φ }}.
-Proof.
- iIntros "H". iApply swp_lift_atomic_step_fupd.
- iIntros (????) "?". iMod ("H" with "[$]") as "[$ H]".
- iIntros "!> *". iIntros (Hstep) "!> !>".
- by iApply "H".
-Qed.
-
-
-Lemma wp_lift_pure_det_step_no_fork `{!Inhabited (state Λ)} {s E E' Φ} e1 e2 :
- (∀ σ1, if s is NotStuck then reducible e1 σ1 else to_val e1 = None) →
- (∀ σ1 κ e2' σ2 efs', prim_step e1 σ1 κ e2' σ2 efs' →
- κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) →
- (|={E,E'}▷=> WP e2 @ s; E {{ Φ }}) ⊢ WP e1 @ s; E {{ Φ }}.
-Proof.
- iIntros (? Hpuredet) "H". iApply (wp_lift_pure_step_no_fork s E E'); try done.
- { naive_solver. }
- iApply (step_fupd_wand with "H"); iIntros "H".
- iIntros (κ e' efs' σ (_&?&->&?)%Hpuredet); auto.
-Qed.
-
-Lemma swp_lift_pure_det_step_no_fork {k s E E' Φ} e1 e2 :
- (∀ σ1, s = NotStuck → reducible e1 σ1) →
- (∀ σ1 κ e2' σ2 efs', prim_step e1 σ1 κ e2' σ2 efs' →
- κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) →
- (|={E,E'}▷=> WP e2 @ s; E {{ Φ }}) ⊢ SWP e1 at k @ s; E {{ Φ }}.
-Proof.
- iIntros (? Hpuredet) "H". iApply (swp_lift_pure_step_no_fork k s E E'); try done.
- { naive_solver. }
- iApply (step_fupd_wand with "H"); iIntros "H".
- iIntros (κ e' efs' σ (_&?&->&?)%Hpuredet); auto.
-Qed.
-
-Lemma wp_pure_step_fupd `{!Inhabited (state Λ)} s E E' e1 e2 φ n Φ :
- PureExec φ n e1 e2 →
- φ →
- (|={E,E'}▷=>^n WP e2 @ s; E {{ Φ }}) ⊢ WP e1 @ s; E {{ Φ }}.
-Proof.
- iIntros (Hexec Hφ) "Hwp". specialize (Hexec Hφ).
- iInduction Hexec as [e|n e1 e2 e3 [Hsafe ?]] "IH"; simpl; first done.
- iApply wp_lift_pure_det_step_no_fork.
- - intros σ. specialize (Hsafe σ). destruct s; eauto using reducible_not_val.
- - done.
- - by iApply (step_fupd_wand with "Hwp").
-Qed.
-
-Lemma swp_pure_step_fupd k s E E' e1 e2 φ n Φ `{!Inhabited (state Λ)} :
- PureExec φ (S n) e1 e2 →
- φ →
- (|={E,E'}▷=>^(S n) WP e2 @ s; E {{ Φ }}) ⊢ SWP e1 at k @ s; E {{ Φ }}.
-Proof.
- iIntros (Hexec Hφ) "Hwp". specialize (Hexec Hφ).
- iInduction n as [|n] "IH" forall (e1 Hexec); simpl;
- inversion Hexec as [|n' ? e1' ? Hstep Hrest]; subst.
- all: iApply swp_lift_pure_det_step_no_fork.
- 1, 4: intros σ; intros H; subst; eauto using pure_step_safe, reducible_no_obs_reducible, reducible_not_val.
- 1, 3: eauto using pure_step_det.
- - inversion Hrest; subst; eauto.
- - iSpecialize ("IH" with "[//] Hwp").
- iMod "IH". iModIntro. iNext. iMod "IH". iModIntro.
- iPoseProof (swp_wp with "IH") as "IH"; eauto.
- inversion Hrest; subst.
- unshelve eauto using pure_step_safe, reducible_no_obs_reducible, reducible_not_val.
- exact inhabitant.
-Qed.
-
-Lemma wp_pure_step_later `{!Inhabited (state Λ)} s E e1 e2 φ n Φ :
- PureExec φ n e1 e2 →
- φ →
- ▷^n WP e2 @ s; E {{ Φ }} ⊢ WP e1 @ s; E {{ Φ }}.
-Proof.
- intros Hexec ?. rewrite -wp_pure_step_fupd //. clear Hexec.
- induction n as [|n IH]; by rewrite //= -step_fupd_intro // IH.
-Qed.
-
-
-Lemma swp_pure_step_later `{!Inhabited (state Λ)} k s E e1 e2 φ n Φ :
- PureExec φ (S n) e1 e2 →
- φ →
- ▷^(S n) WP e2 @ s; E {{ Φ }} ⊢ SWP e1 at k @ s; E {{ Φ }}.
-Proof.
- intros Hexec ?. rewrite -swp_pure_step_fupd //. iIntros "H".
- iApply step_fupdN_intro; eauto.
-Qed.
-End lifting.
diff --git a/theories/program_logic/refinement/ref_adequacy.v b/theories/program_logic/refinement/ref_adequacy.v
deleted file mode 100644
index 0a9b9d39..00000000
--- a/theories/program_logic/refinement/ref_adequacy.v
+++ /dev/null
@@ -1,354 +0,0 @@
-From iris.program_logic Require Export language.
-From iris.bi Require Export weakestpre fixpoint.
-From iris.proofmode Require Import base tactics classes.
-From iris.algebra Require Import auth list.
-From iris.base_logic Require Export satisfiable gen_heap.
-From iris.base_logic.lib Require Export fancy_updates logical_step.
-From iris.program_logic.refinement Require Export ref_source ref_weakestpre.
-Set Default Proof Using "Type".
-
-
-
-Lemma sn_not_ex_loop {A} `{Classical} (R : relation A) x :
- ¬ex_loop R x → sn R x.
-Proof.
- intros Hex. destruct (excluded_middle (sn R x)) as [|Hsn]; [done|].
- destruct Hex. revert x Hsn. cofix IH; intros x Hsn.
- destruct (excluded_middle (∃ y, R x y ∧ ¬sn R y)) as [(y&?&?)|Hnot].
- - exists y; auto.
- - destruct Hsn. constructor. intros y Hxy.
- destruct (excluded_middle (sn R y)); naive_solver.
-Qed.
-
-
-Section refinements.
-Context {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ}.
-Implicit Types s : stuckness.
-Implicit Types P : iProp Σ.
-Implicit Types Φ : val Λ → iProp Σ.
-Implicit Types v : val Λ.
-Implicit Types e : expr Λ.
-Implicit Types a : A.
-Implicit Types b : bool.
-
-(** We first prove that termination is preserverd: if the source is strongly normalising, then also the target is strongly normalising *)
-
-(* With rwp_tp, we lift the essential parts for termination preserving refinement of rwp to thread pools. *)
-Definition rwp_tp_pre (rwp_tp: list (expr Λ) → iProp Σ) (t1: list (expr Λ)) : iProp Σ :=
- (∀ t2 σ σ' κ a n,
- ⌜step (t1, σ) κ (t2, σ')⌝
- -∗ source_interp a ∗ ref_state_interp σ n
- ={⊤, ∅}=∗ ∃ b,
- ▷?b |={∅, ⊤}=> ∃ m,
- ref_state_interp σ' m
- ∗ if b then ∃ a', ⌜a ↪⁺ a'⌝ ∗ rwp_tp t2 ∗ source_interp a'
- else rwp_tp t2 ∗ source_interp a)%I.
-
-(* Not every recursive occurrence is guarded by a later. We obtain a fixpoint of the defintion using a least fixpoint operator.*)
-Definition rwp_tp (t : list (expr Λ)) : iProp Σ := bi_least_fixpoint rwp_tp_pre t.
-
-Lemma rwp_tp_pre_mono (rwp_tp1 rwp_tp2 : list (expr Λ) → iProp Σ) :
- ⊢ (<pers> (∀ t, rwp_tp1 t -∗ rwp_tp2 t) →
- ∀ t, rwp_tp_pre rwp_tp1 t -∗ rwp_tp_pre rwp_tp2 t)%I.
-Proof.
- iIntros "#H"; iIntros (t) "Hwp". rewrite /rwp_tp_pre.
- iIntros (t2 σ1 σ2 κ a n1) "Hstep Hσ".
- iMod ("Hwp" with "[$] [$]") as (b) "Hwp".
- iModIntro. iExists b. iNext. iMod "Hwp". iModIntro.
- iDestruct "Hwp" as (m) "(Hσ & Hwp)". iExists m. iFrame "Hσ".
- destruct b; eauto.
- - iDestruct "Hwp" as (a') "(Hstep & Hgn & Hsrc)".
- iExists a'. iFrame. by iApply "H".
- - iDestruct "Hwp" as "(Hgn & $)". by iApply "H".
-Qed.
-
-Local Instance rwp_tp_pre_mono' : BiMonoPred rwp_tp_pre.
-Proof.
- constructor; first apply rwp_tp_pre_mono.
- intros wp Hwp n t1 t2 ?%(discrete_iff _ _)%leibniz_equiv; solve_proper.
-Qed.
-
-
-Lemma rwp_tp_unfold t : rwp_tp t ⊣⊢ rwp_tp_pre rwp_tp t.
-Proof. by rewrite /rwp_tp least_fixpoint_unfold. Qed.
-
-Lemma rwp_tp_ind Ψ :
- ⊢ ((□ ∀ t, rwp_tp_pre (λ t, Ψ t ∧ rwp_tp t) t -∗ Ψ t) → ∀ t, rwp_tp t -∗ Ψ t)%I.
-Proof.
- iIntros "#IH" (t) "H".
- assert (NonExpansive Ψ).
- { by intros n ?? ->%(discrete_iff _ _)%leibniz_equiv. }
- iApply (least_fixpoint_strong_ind _ Ψ with "[] H").
- iIntros "!#" (t') "H". by iApply "IH".
-Qed.
-
-Instance rwp_tp_Permutation : Proper ((≡ₚ) ==> (⊢)) rwp_tp.
-Proof.
- iIntros (t1 t1' Ht) "Ht1". iRevert (t1' Ht); iRevert (t1) "Ht1".
- iApply rwp_tp_ind; iIntros "!#" (t1) "IH"; iIntros (t1' Ht).
- rewrite rwp_tp_unfold /rwp_tp_pre. iIntros (t2 σ1 σ2 κ a n Hstep) "Hσ".
- destruct (step_Permutation t1' t1 t2 κ σ1 σ2) as (t2'&?&?); try done.
- iMod ("IH" with "[% //] Hσ") as (b) "IH". iModIntro. iExists b. iNext.
- iMod "IH" as (n2) "(Hσ & IH)".
- iModIntro. iExists n2. iFrame "Hσ".
- destruct b.
- - iDestruct "IH" as (a') "(Hstep & [IH _] & Hsrc)".
- iExists a'. iFrame. by iApply "IH".
- - iDestruct "IH" as "([IH _] & $)".
- by iApply "IH".
-Qed.
-
-Lemma rwp_tp_app t1 t2: rwp_tp t1 -∗ rwp_tp t2 -∗ rwp_tp (t1 ++ t2).
-Proof.
- iIntros "H1". iRevert (t2). iRevert (t1) "H1".
- iApply rwp_tp_ind; iIntros "!#" (t1) "IH1". iIntros (t2) "H2".
- iRevert (t1) "IH1"; iRevert (t2) "H2".
- iApply rwp_tp_ind; iIntros "!#" (t2) "IH2". iIntros (t1) "IH1".
- rewrite rwp_tp_unfold {4}/rwp_tp_pre. iIntros (t1'' σ1 σ2 κ a n Hstep) "Hσ1".
- destruct Hstep as [e1 σ1' e2 σ2' efs' t1' t2' [=Ht ?] ? Hstep]; simplify_eq/=.
- apply app_eq_inv in Ht as [(t&?&?)|(t&?&?)]; subst.
- - destruct t as [|e1' ?]; simplify_eq/=.
- + iMod ("IH2" with "[%] Hσ1") as (b) "IH2".
- { by eapply step_atomic with (t1:=[]). }
- iModIntro. iExists b. iNext. iMod "IH2" as (n2) "[Hσ IH2]". iModIntro. iExists n2. iFrame "Hσ".
- rewrite -{2}(left_id_L [] (++) (e2 :: _)). destruct b.
- * iDestruct "IH2" as (a' Hsrc) "[[IH2 _] Hsrc]". iExists a'. iFrame "Hsrc".
- iSplit; first by iPureIntro. iApply "IH2".
- by rewrite (right_id_L [] (++)).
- * iDestruct "IH2" as "[[IH2 _] Hsrc]". iFrame "Hsrc". iApply "IH2".
- by rewrite (right_id_L [] (++)).
- + iMod ("IH1" with "[%] Hσ1") as (b) "IH1".
- { by econstructor. }
- iModIntro. iExists b. iApply (bi.laterN_wand with "[IH2] IH1"). iNext.
- iIntros "IH1". iMod "IH1" as (n2) "(Hσ & IH1)". iModIntro.
- iExists n2. iFrame "Hσ".
- iAssert (rwp_tp t2) with "[IH2]" as "Ht2".
- { rewrite rwp_tp_unfold. iApply (rwp_tp_pre_mono with "[] IH2").
- iIntros "!# * [_ ?] //". }
- destruct b.
- * iDestruct "IH1" as (a' Hsrc) "[[IH1 _] Hsrc]".
- iExists a'. iFrame "Hsrc". iSplit; first by iPureIntro.
- rewrite -assoc_L (comm _ t2) !cons_middle !assoc_L. by iApply "IH1".
- * iDestruct "IH1" as "[[IH1 _] Hsrc]".
- iFrame "Hsrc". rewrite -assoc_L (comm _ t2) !cons_middle !assoc_L. by iApply "IH1".
- - iMod ("IH2" with "[%] Hσ1") as (b) "IH2"; first by econstructor.
- iModIntro. iExists b. iApply (bi.laterN_wand with "[IH1] IH2"). iNext.
- iIntros "IH2". iMod "IH2" as (n2) "[Hσ IH2]". iModIntro. iExists n2.
- iFrame "Hσ". rewrite -assoc_L. destruct b.
- + iDestruct "IH2" as (a' Hsrc) "[[IH2 _] Hsrc]". iExists a'. iFrame "Hsrc".
- iSplit; first by iPureIntro. by iApply "IH2".
- + iDestruct "IH2" as "[[IH2 _] Hsrc]". iFrame "Hsrc". by iApply "IH2".
-Qed.
-
-(* rwp_tp subsumes rwp *)
-Lemma rwp_rwp_tp s Φ e : RWP e @ s; ⊤ ⟨⟨ Φ ⟩⟩ -∗ rwp_tp [e].
-Proof.
- iIntros "He". remember (⊤ : coPset) as E eqn:HE.
- iRevert (HE). iRevert (e E Φ) "He". iApply rwp_ind.
- iIntros "!#" (e E Φ). iIntros "IH" (->).
- rewrite /rwp_pre /rwp_step rwp_tp_unfold /rwp_tp_pre.
- iIntros (t' σ σ' κ a n Hstep).
- destruct Hstep as [e1 σ1 e2 σ2 efs [|? t1] t2 ?? Hstep];
- simplify_eq/=; try discriminate_list.
- destruct (to_val e1) as [v|] eqn:He1.
- { apply val_stuck in Hstep; naive_solver. }
- iIntros "[Ha Hσ]".
- iMod ("IH" with "[$Ha $Hσ]") as (b) "IH". iModIntro.
- iExists b. iApply (bi.laterN_wand with "[] IH"). iNext.
- iIntros "H". iMod "H" as "[_ IH]".
- iMod ("IH" with "[% //]") as "(Hsrc & Hσ & IH & IHs)".
- iModIntro. iExists (length efs + n). iFrame "Hσ".
- iAssert (rwp_tp (e2 :: efs))%I with "[IH IHs]" as "Hrwp_tp".
- { iApply (rwp_tp_app [_] with "(IH [//])").
- clear. iInduction efs as [|e efs] "IH"; simpl.
- { rewrite rwp_tp_unfold /rwp_tp_pre. iIntros (t2 σ1 κ σ2 a n1 Hstep).
- destruct Hstep; simplify_eq/=; discriminate_list. }
- iDestruct "IHs" as "[IH' IHfork]".
- iApply (rwp_tp_app [_] with "(IH' [//])"). by iApply "IH".
- }
- destruct b; iFrame.
-Qed.
-
-
-(* We unfold the refinement to a sequence of later operations interleaved with fancy updates. *)
-Definition guarded_pre (grd: (A -d> iProp Σ -d> iProp Σ)) : A -d> iProp Σ -d> iProp Σ :=
- λ (a: A) (P: iProp Σ),
- (|={⊤,∅}=> (|={∅,⊤}=> P) ∨ (▷ |={∅,⊤}=> ∃ a', ⌜a ↪⁺ a'⌝ ∗ grd a' P))%I.
-
-Global Instance guarded_pre_contractive: Contractive (guarded_pre).
-Proof.
- intros α ev1 ev2 Heq. rewrite /guarded_pre; simpl.
- intros e_S P. do 2 f_equiv. f_contractive. intros ??.
- do 2 f_equiv. intros e_s'. f_equiv. by apply Heq.
-Qed.
-
-Definition guarded := fixpoint guarded_pre.
-
-Lemma guarded_unfold a P: guarded a P ≡ (|={⊤,∅}=> (|={∅,⊤}=> P) ∨ (▷ |={∅,⊤}=> ∃ a', ⌜a ↪⁺a'⌝ ∗ guarded a' P))%I.
-Proof. unfold guarded. apply (@fixpoint_unfold SI (A -d> iProp Σ -d> iProp Σ) _ guarded_pre _). Qed.
-
-(* Guarded propositions eventually become true, if the source does not allow infinite loops. *)
-Lemma guarded_satisfiable `{LargeIndex SI} a P:
- sn source_rel a
- → satisfiable_at ⊤ (guarded a P)
- → satisfiable_at ⊤ P.
-Proof.
- intros Hsn % sn_tc. induction Hsn as [a Ha IH]. rewrite guarded_unfold.
- intros Hsat. apply satisfiable_at_fupd in Hsat.
- apply satisfiable_at_or in Hsat as [Hsat|Hsat].
- { by apply satisfiable_at_fupd in Hsat. }
- apply satisfiable_at_later in Hsat.
- apply satisfiable_at_fupd in Hsat.
- apply satisfiable_at_exists in Hsat as [b Hsat]; last apply _.
- apply satisfiable_at_sep in Hsat as [Hsat1 % satisfiable_at_pure Hsat2].
- by eapply IH.
-Qed.
-
-
-
-Lemma rwp_tp_guarded_false t:
- rwp_tp t ⊢ ∀ σ a n, ⌜ex_loop erased_step (t, σ)⌝
- -∗ source_interp a
- -∗ ref_state_interp σ n
- -∗ guarded a False.
-Proof.
- iApply (rwp_tp_ind (λ t, ∀ σ a n, ⌜ex_loop erased_step (t, σ)⌝ -∗ source_interp a -∗ ref_state_interp σ n -∗ guarded a False)%I with "[]"). clear t.
- iModIntro. iIntros (t). rewrite /rwp_tp_pre. iIntros "Hrwp_tp". iIntros (σ a n Hloop) "Hsrc Hσ".
- inversion Hloop as [x [t' σ'] [κ Hstep] Hloop']; subst x; clear Hloop.
- iSpecialize ("Hrwp_tp" $! t' σ σ' κ a n with "[]"); eauto.
- iSpecialize ("Hrwp_tp" with "[$Hsrc $Hσ]"). iApply guarded_unfold.
- iMod "Hrwp_tp" as (b) "Hrwp_tp". destruct b.
- + iModIntro. iRight. iNext. iMod "Hrwp_tp" as (m) "(Hσ & Hev)".
- iModIntro. iDestruct "Hev" as (a' Hsrc) "[[Hev _] Hsrc]".
- iExists a'. iSplit; first by iPureIntro.
- iApply ("Hev" with "[] Hsrc Hσ"); eauto.
- + iMod "Hrwp_tp" as (m) "(Hσ & [Hev _] & Ha)".
- iSpecialize ("Hev" with "[//] Ha Hσ").
- by rewrite guarded_unfold.
-Qed.
-
-Lemma rwp_adequacy `{LargeIndex SI} Φ a e σ n s:
- sn source_rel a
- → ex_loop erased_step ([e], σ)
- → satisfiable_at ⊤ (source_interp a ∗ ref_state_interp σ n ∗ RWP e @ s; ⊤ ⟨⟨ Φ ⟩⟩)%I
- → False.
-Proof.
- intros Hsn Hloop Hsat. eapply (satisfiable_at_mono _ _ (guarded a False)%I) in Hsat.
- - apply guarded_satisfiable in Hsat; eauto. by eapply satisfiable_at_pure.
- - iIntros "(Hsrc & Hσ & Hwp)".
- iApply (rwp_tp_guarded_false with "[Hwp] [//] Hsrc Hσ").
- by iApply rwp_rwp_tp.
-Qed.
-
-Lemma rwp_sn_preservation `{Classical} `{LargeIndex SI} Φ a e σ n s:
- sn source_rel a
- → satisfiable_at ⊤ (source_interp a ∗ ref_state_interp σ n ∗ RWP e @ s; ⊤ ⟨⟨ Φ ⟩⟩)%I
- → sn erased_step ([e], σ).
-Proof.
- intros Hsn Hsat. eapply sn_not_ex_loop. intros Hloop.
- eapply rwp_adequacy; eauto.
-Qed.
-
-
-(** the following lemmas are completely independent from the preceding lemmas*)
-(** they provide a general result which can be used to prove that the result of a computation refines a source computation
- -- however, the concrete shape of this strongly depends on the chosen source and state interpretations *)
-
-(* we are ignoring any threads that are forked off *)
-Lemma rwp_prim_step `{LargeIndex SI} F s κ a n e e' σ σ' Φ efs:
- prim_step e σ κ e' σ' efs →
- satisfiable_at ⊤ (source_interp a ∗ ref_state_interp σ n ∗ RWP e @ s; ⊤ ⟨⟨ Φ ⟩⟩ ∗ F)%I
- → ∃ a' m, rtc source_rel a a'
- ∧ satisfiable_at ⊤ (source_interp a' ∗ ref_state_interp σ' m ∗ RWP e' @ s; ⊤ ⟨⟨ Φ ⟩⟩
- ∗ ([∗ list] e ∈ efs, RWP e @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩) ∗ F)%I.
-Proof.
- intros Hstep Hsat.
- eapply satisfiable_at_mono with (Q := (|={⊤, ∅}=> ▷ |={∅, ⊤}=> ∃ a' m, ⌜rtc source_rel a a'⌝ ∗ source_interp a' ∗ ref_state_interp σ' m ∗ RWP e' @ s; ⊤ ⟨⟨ Φ ⟩⟩ ∗ ([∗ list] e ∈ efs, RWP e @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩) ∗ F)%I) in Hsat; last first.
- - rewrite rwp_unfold /rwp_pre /rwp_step.
- iIntros "(Hsrc & SI & Hwp & F)".
- erewrite val_stuck; eauto.
- iMod ("Hwp" $! σ n a with "[$Hsrc $SI]") as ([]) "Hwp"; simpl; iModIntro; iNext; iMod "Hwp" as "[_ Hwp]".
- + iMod ("Hwp" $! _ _ _ _ Hstep) as "(Hsrc & SI & RWP & Hfork)".
- iDestruct "Hsrc" as (a' Hsteps) "Hsrc".
- iModIntro. iExists a', _. iFrame. iPureIntro.
- by apply tc_rtc.
- + iMod ("Hwp" $! _ _ _ _ Hstep) as "(Hsrc & SI & RWP & Hfork)".
- iModIntro. iExists a, _. iFrame. by iPureIntro.
- - apply satisfiable_at_fupd in Hsat.
- apply satisfiable_at_later in Hsat.
- apply satisfiable_at_fupd in Hsat.
- apply satisfiable_at_exists in Hsat as [a' Hsat]; auto.
- apply satisfiable_at_exists in Hsat as [m Hsat]; auto.
- apply satisfiable_at_sep in Hsat as [Hsteps Hsat].
- apply satisfiable_at_pure in Hsteps.
- exists a', m. eauto.
-Qed.
-
-
-Definition thread_wps s Φ (es: list (expr Λ)) : iProp Σ :=
- ([∗ list] i ↦ e ∈ es, if i is 0 then RWP e @ s; ⊤ ⟨⟨ Φ ⟩⟩ else RWP e @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩)%I.
-
-(* thread lifting *)
-Lemma rwp_erased_step `{LargeIndex SI} s Φ a n ts ts' σ σ':
- erased_step (ts, σ) (ts', σ')
- → satisfiable_at ⊤ (source_interp a ∗ ref_state_interp σ n ∗ thread_wps s Φ ts)%I
- → ∃ a' m, rtc source_rel a a'
- ∧ satisfiable_at ⊤ (source_interp a' ∗ ref_state_interp σ' m ∗ thread_wps s Φ ts')%I.
-Proof.
- intros [κ Hstep] Hsat. inversion Hstep as [e1 σ1 e2 σ2 efs t1 t2 Heq1 Heq2 Hstep'].
- injection Heq1 as -> ->. injection Heq2 as -> ->. revert Hsat.
- destruct t1; simpl in *; rewrite /thread_wps //=.
- - intros Hsat. eapply rwp_prim_step in Hsat; eauto. rewrite /thread_wps //=.
- destruct Hsat as (a' & m & Hrtc & Hsat).
- exists a', m. split; auto.
- by rewrite big_sepL_app [(([∗ list] y ∈ t2, _) ∗ _)%I]bi.sep_comm.
- - rewrite big_sepL_app //=.
- intros Hsat; eapply satisfiable_at_mono with (Q := (_ ∗ _ ∗ _ ∗ _)%I)in Hsat; last first.
- { iIntros "(Hsrc & SI & Hrwp & Ht1 & He & Ht2)".
- iSplitL "Hsrc"; first iAssumption.
- iSplitL "SI"; first iAssumption.
- iSplitL "He"; first iAssumption.
- iCombine "Hrwp Ht1 Ht2" as "H"; iAssumption. }
- eapply rwp_prim_step in Hsat; eauto.
- destruct Hsat as (a' & m & Hrtc & Hsat).
- exists a', m. split; auto.
- eapply satisfiable_at_mono; first apply Hsat.
- iIntros "($ & $ & He2 & Hefs & $ & Ht1 & Ht2)".
- rewrite big_sepL_app //= big_sepL_app; iFrame.
-Qed.
-
-
-Lemma rwp_erased_steps `{LargeIndex SI} s Φ a n ts ts' σ σ':
- rtc erased_step (ts, σ) (ts', σ')
- → satisfiable_at ⊤ (source_interp a ∗ ref_state_interp σ n ∗ thread_wps s Φ ts)%I
- → ∃ a' m, rtc source_rel a a'
- ∧ satisfiable_at ⊤ (source_interp a' ∗ ref_state_interp σ' m ∗ thread_wps s Φ ts')%I.
-Proof.
- intros Hsteps. remember (ts, σ) as c. remember (ts', σ') as c'.
- revert ts σ Heqc ts' σ' Heqc' n a.
- induction Hsteps as [|x [ts'' σ''] z Hstep]; intros ts σ Heqc ts' σ' Heqc' n a; subst.
- - injection Heqc' as -> ->. intros Hsteps. exists a, n; by split.
- - intros Hsat. eapply rwp_erased_step in Hsat as (a' & m & Hsteps' & Hsat); last eauto.
- edestruct IHHsteps as (a'' & m' & Hsteps'' & Hsat'); [done|done| |].
- + apply Hsat.
- + exists a'', m'; split; eauto. transitivity a'; eauto.
-Qed.
-
-Lemma rwp_result `{LargeIndex SI} Φ ts a n e v σ σ' s:
- rtc erased_step ([e], σ) (of_val v :: ts, σ')
- → satisfiable_at ⊤ (source_interp a ∗ ref_state_interp σ n ∗ RWP e @ s; ⊤ ⟨⟨ Φ ⟩⟩)%I
- → ∃ a' m, rtc source_rel a a'
- ∧ satisfiable_at ⊤ (source_interp a' ∗ ref_state_interp σ' m ∗ Φ v)%I.
-Proof.
- intros Hsteps Hsat. eapply rwp_erased_steps in Hsteps; last first.
- { rewrite /thread_wps //=. eapply satisfiable_at_mono; first apply Hsat.
- by iIntros "($ & $ & $)". }
- destruct Hsteps as (a' & m & Hrtc & Hsat'). exists a', m; split; auto.
- eapply satisfiable_at_fupd, satisfiable_at_mono; first apply Hsat'.
- iIntros "(Hsrc & Href & Hthread)".
- rewrite /thread_wps. iDestruct "Hthread" as "[Hthread _]".
- rewrite rwp_unfold /rwp_pre to_of_val.
- by iMod ("Hthread" with "[$]") as "($&$&$)".
-Qed.
-
-End refinements.
diff --git a/theories/program_logic/refinement/ref_ectx_lifting.v b/theories/program_logic/refinement/ref_ectx_lifting.v
deleted file mode 100644
index d6614261..00000000
--- a/theories/program_logic/refinement/ref_ectx_lifting.v
+++ /dev/null
@@ -1,201 +0,0 @@
-(** Some derived lemmas for ectx-based languages *)
-From iris.program_logic Require Export ectx_language.
-
-From iris.program_logic.refinement Require Export ref_weakestpre ref_lifting.
-From iris.proofmode Require Import tactics.
-Set Default Proof Using "Type".
-
-Section rwp.
-Context {SI} {Σ: gFunctors SI} {A} {Λ: ectxLanguage} `{Hsrc: !source Σ A} `{Hiris: !ref_irisG Λ Σ} `{Hexp: Inhabited (expr Λ)} `{Hstate: Inhabited (state Λ)}.
-Implicit Types s : stuckness.
-Implicit Types P Q : iProp Σ.
-Implicit Types a : A.
-Implicit Types b : bool.
-Implicit Types Φ : val Λ → iProp Σ.
-Hint Resolve head_prim_reducible head_reducible_prim_step : core.
-Hint Resolve (reducible_not_val _ inhabitant) : core.
-Hint Resolve head_stuck_stuck : core.
-
-
-(* refinement weakest precondition *)
-Lemma rwp_lift_head_step_fupd {s E Φ} e1 :
- to_val e1 = None →
- (∀ σ1 n (a: A), source_interp a ∗ ref_state_interp σ1 n ={E,∅}=∗
- ∃ b, ▷? b |={∅}=> ⌜head_reducible e1 σ1⌝ ∗
- ∀ e2 σ2 efs κ, ⌜head_step e1 σ1 κ e2 σ2 efs⌝ ={∅,E}=∗
- (if b then ∃ a' : A, ⌜a ↪⁺ a'⌝ ∗ source_interp a' else source_interp a) ∗
- ref_state_interp σ2 (length efs + n) ∗
- RWP e2 @ s; E ⟨⟨ Φ ⟩⟩ ∗
- [∗ list] ef ∈ efs, RWP ef @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩)
- ⊢ RWP e1 @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros (?) "H". iApply rwp_lift_step_fupd=>//. iIntros (σ1 n a) "Hσ".
- iMod ("H" with "Hσ") as (b) "H"; iExists b. iModIntro. iNext. iMod "H" as "[% H]". iModIntro.
- iSplit; first by destruct s; eauto. iIntros (e2 σ2 efs κ ?).
- iApply "H"; eauto.
-Qed.
-
-Lemma rwp_lift_atomic_head_step_fupd {s E Φ} e1 :
- to_val e1 = None →
- (∀ σ1 n a, source_interp a ∗ ref_state_interp σ1 n ={E}=∗
- ∃ b, ▷? b |={E}=> ⌜head_reducible e1 σ1⌝ ∗
- ∀ e2 σ2 efs κ, ⌜head_step e1 σ1 κ e2 σ2 efs⌝ ={E}=∗
- (if b then ∃ (a': A), ⌜a ↪⁺ a'⌝ ∗ source_interp a' else source_interp a) ∗
- ref_state_interp σ2 (length efs + n) ∗
- from_option Φ False (to_val e2) ∗
- [∗ list] ef ∈ efs, RWP ef @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩)
- ⊢ RWP e1 @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros (?) "H". iApply rwp_lift_atomic_step_fupd; [done|].
- iIntros (σ1 Qs a) "H'". iMod ("H" with "H'") as (b) "H'".
- iModIntro. iExists b. iNext. iMod "H'" as "[% H']". iModIntro.
- iSplit; first by destruct s; auto. iIntros (e2 σ2 efs κ Hstep).
- iMod ("H'" with "[]"); eauto.
-Qed.
-
-Lemma rwp_lift_pure_head_step_no_fork s E Φ e1 :
- (∀ σ1, head_reducible e1 σ1) →
- (∀ κ σ1 e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs → κ = [] ∧ σ2 = σ1 ∧ efs = []) →
- (∀ κ e2 efs σ, ⌜head_step e1 σ κ e2 σ efs⌝ → RWP e2 @ s; E ⟨⟨ Φ ⟩⟩)%I
- ⊢ RWP e1 @ s; E ⟨⟨ Φ ⟩⟩.
-Proof using A Hexp Hiris Hsrc Hstate SI Λ Σ.
- intros Hsafe Hstep.
- iIntros "H". iApply rwp_lift_head_step_fupd; auto.
- iIntros (σ1 n a) "[Ha Hσ]". iMod (fupd_intro_mask' E ∅) as "Hclose"; first set_solver.
- iModIntro. iExists false. iModIntro; iSplit; auto.
- iIntros (e2 σ2 efs κ H'). destruct (Hstep κ σ1 e2 σ2 efs) as (-> & <- & ->); auto.
- iMod "Hclose" as "_". iModIntro.
- iDestruct ("H" with "[//]") as "H". simpl. iFrame.
-Qed.
-
-Lemma rwp_lift_pure_det_head_step_no_fork {s E Φ} e1 e2 :
- to_val e1 = None →
- (∀ σ1, head_reducible e1 σ1) →
- (∀ σ1 κ e2' σ2 efs',
- head_step e1 σ1 κ e2' σ2 efs' → κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) →
- (RWP e2 @ s; E ⟨⟨ Φ ⟩⟩) ⊢ RWP e1 @ s; E ⟨⟨ Φ ⟩⟩.
-Proof using A Hexp Hiris Hsrc Hstate SI Λ Σ.
- intros H2 Hstep Hpuredet.
- iIntros "H". iApply rwp_lift_pure_head_step_no_fork; auto.
- { naive_solver. }
- iIntros (κ e' efs' σ (_&?&->&?)%Hpuredet); auto.
-Qed.
-
-
-(* lemmas for the indexed version *)
-Lemma rswp_lift_head_step_fupd {k s E Φ} e1 :
- (∀ σ1 n, ref_state_interp σ1 n ={E,∅}=∗
- |={∅, ∅}▷=>^k ⌜head_reducible e1 σ1⌝ ∗
- ∀ e2 σ2 efs κ, ⌜head_step e1 σ1 κ e2 σ2 efs⌝ ={∅,E}=∗
- ref_state_interp σ2 (length efs + n) ∗
- RWP e2 @ s; E ⟨⟨ Φ ⟩⟩ ∗
- [∗ list] ef ∈ efs, RWP ef @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩)
- ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros "H". iApply rswp_lift_step_fupd=>//. iIntros (σ1 n) "Hσ".
- iMod ("H" with "Hσ") as "H". iModIntro. iApply (step_fupdN_wand with "H").
- iIntros "[% H]".
- iSplit; first by destruct s; eauto.
- iIntros (e2 σ2 efs κ ?).
- iApply "H"; eauto.
-Qed.
-
-Lemma rswp_lift_atomic_head_step_fupd {k s E Φ} e1 :
- (∀ σ1 n, ref_state_interp σ1 n ={E}=∗
- |={E,E}▷=>^k ⌜head_reducible e1 σ1⌝ ∗
- ∀ e2 σ2 efs κ, ⌜head_step e1 σ1 κ e2 σ2 efs⌝ ={E}=∗
- ref_state_interp σ2 (length efs + n) ∗
- from_option Φ False (to_val e2) ∗
- [∗ list] ef ∈ efs, RWP ef @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩)
- ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros "H". iApply rswp_lift_atomic_step_fupd; eauto.
- iIntros (σ1 Qs) "Hσ1". iMod ("H" with "Hσ1") as "H"; iModIntro.
- iApply (step_fupdN_wand with "H"); iIntros "[% H]".
- iSplit; first by destruct s; auto. iIntros (e2 σ2 efs κ Hstep).
- iApply "H"; eauto.
-Qed.
-
-Lemma rswp_lift_atomic_head_step {k s E Φ} e1 :
- (∀ σ1 n, ref_state_interp σ1 n ={E}=∗
- ▷^k (⌜head_reducible e1 σ1⌝ ∗
- ∀ e2 σ2 efs κ, ⌜head_step e1 σ1 κ e2 σ2 efs⌝ ={E}=∗
- ref_state_interp σ2 (length efs + n) ∗
- from_option Φ False (to_val e2) ∗
- [∗ list] ef ∈ efs, RWP ef @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩))
- ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros "H". iApply rswp_lift_atomic_head_step_fupd; eauto.
- iIntros (σ1 Qs) "Hσ1". iMod ("H" with "Hσ1") as "H"; iModIntro.
- by iApply step_fupdN_intro.
-Qed.
-
-Lemma rswp_lift_atomic_head_step_no_fork_fupd {k s E Φ} e1 :
- (∀ σ1 n, ref_state_interp σ1 n ={E}=∗
- |={E,E}▷=>^k ⌜head_reducible e1 σ1⌝ ∗
- ∀ e2 σ2 efs κ, ⌜head_step e1 σ1 κ e2 σ2 efs⌝ ={E}=∗
- ⌜efs = []⌝ ∗ ref_state_interp σ2 n ∗ from_option Φ False (to_val e2))
- ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros "H". iApply rswp_lift_atomic_head_step_fupd; eauto.
- iIntros (σ1 Qs) "Hσ1". iMod ("H" $! σ1 with "Hσ1") as "H"; iModIntro.
- iApply (step_fupdN_wand with "H"); iIntros "[$ H]" (v2 σ2 efs κ Hstep).
- iMod ("H" $! v2 σ2 efs with "[//]") as "(-> & ? & ?) /=". by iFrame.
-Qed.
-
-Lemma rswp_lift_atomic_head_step_no_fork {k s E Φ} e1 :
- (∀ σ1 n, ref_state_interp σ1 n ={E}=∗
- ▷^k (⌜head_reducible e1 σ1⌝ ∗
- ∀ e2 σ2 efs κ, ⌜head_step e1 σ1 κ e2 σ2 efs⌝ ={E}=∗
- ⌜efs = []⌝ ∗ ref_state_interp σ2 n ∗ from_option Φ False (to_val e2)))
- ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros "H". iApply rswp_lift_atomic_head_step_no_fork_fupd.
- iIntros (σ1 Qs) "Hσ1". iMod ("H" $! σ1 with "Hσ1") as "H"; iModIntro.
- by iApply step_fupdN_intro.
-Qed.
-
-
-Lemma rswp_lift_pure_head_step_no_fork_fupd k s E Φ e1 :
- (∀ σ1, head_reducible e1 σ1) →
- (∀ κ σ1 e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs → κ = [] ∧ σ2 = σ1 ∧ efs = []) →
- (|={E,E}▷=>^k ∀ κ e2 efs σ, ⌜head_step e1 σ κ e2 σ efs⌝ → RWP e2 @ s; E ⟨⟨ Φ ⟩⟩)%I
- ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
-Proof using A Hexp Hiris Hsrc Hstate SI Λ Σ.
- intros Hsafe Hstep.
- iIntros "H". iApply rswp_lift_pure_step_no_fork; eauto.
- iModIntro. iApply (step_fupdN_wand with "H"); iIntros "H" (κ e2 efs σ Hs).
- iApply "H"; eauto.
-Qed.
-
-Lemma rswp_lift_pure_head_step_no_fork k s E Φ e1 :
- (∀ σ1, head_reducible e1 σ1) →
- (∀ κ σ1 e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs → κ = [] ∧ σ2 = σ1 ∧ efs = []) →
- (▷^k ∀ κ e2 efs σ, ⌜head_step e1 σ κ e2 σ efs⌝ → RWP e2 @ s; E ⟨⟨ Φ ⟩⟩)%I
- ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
-Proof using A Hexp Hiris Hsrc Hstate SI Λ Σ.
- iIntros (Hsafe Hstep) "H". iApply rswp_lift_pure_head_step_no_fork_fupd; eauto.
- by iApply step_fupdN_intro.
-Qed.
-
-Lemma rswp_lift_pure_det_head_step_no_fork_fupd {k s E Φ} e1 e2 :
- (∀ σ1, head_reducible e1 σ1) →
- (∀ σ1 κ e2' σ2 efs',
- head_step e1 σ1 κ e2' σ2 efs' → κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) →
- (|={E,E}▷=>^k RWP e2 @ s; E ⟨⟨ Φ ⟩⟩) ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
-Proof using A Hexp Hiris Hsrc Hstate SI Λ Σ.
- iIntros (Hstep Hdet) "H". iApply rswp_lift_pure_head_step_no_fork_fupd; eauto.
- { naive_solver. }
- iApply (step_fupdN_wand with "H"); by iIntros "H" (κ e2' efs σ (_&_&->&->)%Hdet).
-Qed.
-
-Lemma rswp_lift_pure_det_head_step_no_fork {k s E Φ} e1 e2 :
- (∀ σ1, head_reducible e1 σ1) →
- (∀ σ1 κ e2' σ2 efs',
- head_step e1 σ1 κ e2' σ2 efs' → κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) →
- (▷^k RWP e2 @ s; E ⟨⟨ Φ ⟩⟩) ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
-Proof using A Hexp Hiris Hsrc Hstate SI Λ Σ.
- iIntros (Hsafe Hstep) "H". iApply rswp_lift_pure_det_head_step_no_fork_fupd; eauto.
- by iApply step_fupdN_intro.
-Qed.
-End rwp.
diff --git a/theories/program_logic/refinement/ref_lifting.v b/theories/program_logic/refinement/ref_lifting.v
deleted file mode 100644
index a1b1c4c6..00000000
--- a/theories/program_logic/refinement/ref_lifting.v
+++ /dev/null
@@ -1,244 +0,0 @@
-From iris.proofmode Require Import tactics.
-Set Default Proof Using "Type".
-
-From iris.program_logic.refinement Require Export ref_weakestpre.
-(* TODO: move to the right place *)
-Section step_fupdN.
-
- Context {SI} {PROP: sbi SI} `{FU: BiFUpd SI PROP}.
-
- Lemma step_fupdN_mask_comm n E1 E2 E3 E4 (P: PROP):
- E1 ⊆ E2 → E4 ⊆ E3 →
- ((|={E1, E2}=>|={E2, E3}▷=>^n P) ⊢ |={E1, E4}▷=>^n |={E1, E2}=> P)%I.
- Proof.
- iIntros (Hsub1 Hsub2) "H". iInduction n as [|n] "IH"; auto; simpl.
- iMod "H". iMod "H". iMod (fupd_intro_mask' E3 E4) as "Hclose"; auto.
- iModIntro. iNext. iMod "Hclose". iMod "H".
- iMod (fupd_intro_mask' E2 E1) as "Hclose'"; auto.
- iModIntro. iApply "IH". iMod "Hclose'". by iModIntro.
- Qed.
-
- Lemma step_fupdN_mask_comm' n E1 E2 (P: PROP):
- E2 ⊆ E1 →
- ((|={E1, E1}▷=>^n |={E1, E2}=> P) ⊢ |={E1, E2}=> |={E2, E2}▷=>^n P)%I.
- Proof.
- iIntros (Hsub) "H". iInduction n as [|n] "IH"; auto; simpl.
- iMod "H". iMod (fupd_intro_mask' E1 E2) as "Hclose"; auto.
- do 2 iModIntro. iNext. iMod "Hclose". iMod "H". by iApply "IH".
- Qed.
-
-
-End step_fupdN.
-
-
-Section lifting.
-Context {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} `{Inhabited (expr Λ)}.
-Implicit Types s : stuckness.
-Implicit Types P Q : iProp Σ.
-Implicit Types Φ : val Λ → iProp Σ.
-Implicit Types v : val Λ.
-Implicit Types e : expr Λ.
-Implicit Types a : A.
-Implicit Types b : bool.
-
-(* refinement weakest precondition *)
-Hint Resolve reducible_no_obs_reducible : core.
-
-Lemma rwp_lift_step_fupd s E Φ e1 :
- to_val e1 = None →
- (∀ σ1 n a, source_interp a ∗ ref_state_interp σ1 n ={E,∅}=∗
- ∃ b, ▷? b |={∅}=> (⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
- ∀ e2 σ2 efs κ, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ -∗ |={∅,E}=>
- (if b then ∃ (a': A), ⌜a ↪⁺ a'⌝ ∗ source_interp a' else source_interp a) ∗
- ref_state_interp σ2 (length efs + n) ∗ RWP e2 @ s; E ⟨⟨ Φ ⟩⟩ ∗ [∗ list] i ↦ ef ∈ efs, RWP ef @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩))
- ⊢ RWP e1 @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- by rewrite rwp_unfold /rwp_pre /rwp_step=> ->.
-Qed.
-
-Lemma rwp_lift_atomic_step_fupd {s E Φ} e1 :
- to_val e1 = None →
- (∀ σ1 n a, source_interp a ∗ ref_state_interp σ1 n ={E}=∗
- ∃ b, ▷? b |={E}=> ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
- ∀ e2 σ2 efs κ, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ ={E}=∗
- (if b then ∃ (a': A), ⌜a ↪⁺ a'⌝ ∗ source_interp a' else source_interp a) ∗
- ref_state_interp σ2 (length efs + n) ∗
- from_option Φ False (to_val e2) ∗
- [∗ list] ef ∈ efs, RWP ef @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩)
- ⊢ RWP e1 @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros (?) "H".
- iApply (rwp_lift_step_fupd s E _ e1)=>//; iIntros (σ1 n a) "H'".
- iMod ("H" $! σ1 with "H'") as (b) "H". iExists b.
- iMod (fupd_intro_mask' E ∅) as "Hclose"; first set_solver.
- iModIntro. iNext. iMod "Hclose" as "_". iMod "H" as "[$ H]".
- iMod (fupd_intro_mask' E ∅) as "Hclose"; first set_solver.
- iIntros "!>" (e2 σ2 efs κ ?). iMod "Hclose" as "_".
- iMod ("H" $! e2 σ2 efs with "[#]") as "($ & $ & H & $)"; [done|].
- iModIntro.
- destruct (to_val e2) eqn:?; last by iExFalso.
- iApply rwp_value; last done. by apply of_to_val.
-Qed.
-
-Lemma rwp_lift_pure_step_no_fork `{!Inhabited (state Λ)} s E Φ e1 :
- (∀ σ1, if s is NotStuck then reducible e1 σ1 else to_val e1 = None) →
- (∀ κ σ1 e2 σ2 efs, prim_step e1 σ1 κ e2 σ2 efs → κ = [] ∧ σ2 = σ1 ∧ efs = []) →
- (∀ κ e2 efs σ, ⌜prim_step e1 σ κ e2 σ efs⌝ → RWP e2 @ s; E ⟨⟨ Φ ⟩⟩)
- ⊢ RWP e1 @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros (Hsafe Hstep) "H". iApply rwp_lift_step_fupd.
- { specialize (Hsafe inhabitant). destruct s; eauto using reducible_not_val. }
- iIntros (σ1 n e_s) "Hσ".
- iMod fupd_intro_mask' as "Hclose"; last iModIntro; first by set_solver.
- iExists false. iModIntro. iSplit.
- { iPureIntro. destruct s; done. }
- iIntros (e2 σ2 efs κ ?).
- destruct (Hstep κ σ1 e2 σ2 efs) as (-> & <- & ->); auto.
- iMod "Hclose" as "_". iModIntro.
- iDestruct ("H" with "[//]") as "H". simpl. iFrame.
-Qed.
-
-Lemma rwp_lift_pure_det_step_no_fork `{!Inhabited (state Λ)} {s E Φ} e1 e2 :
- (∀ σ1, if s is NotStuck then reducible e1 σ1 else to_val e1 = None) →
- (∀ σ1 κ e2' σ2 efs', prim_step e1 σ1 κ e2' σ2 efs' →
- κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) →
- (RWP e2 @ s; E ⟨⟨ Φ ⟩⟩) ⊢ RWP e1 @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros (? Hpuredet) "H". iApply (rwp_lift_pure_step_no_fork s E); try done.
- { naive_solver. }
- iIntros (κ e' efs' σ (_&?&->&?)%Hpuredet); auto.
-Qed.
-
-Lemma rwp_pure_step `{!Inhabited (state Λ)} s E e1 e2 φ n Φ :
- PureExec φ n e1 e2 →
- φ →
- RWP e2 @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RWP e1 @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros (Hexec Hφ) "Hwp". specialize (Hexec Hφ).
- iInduction Hexec as [e|n e1 e2 e3 [Hsafe ?]] "IH"; simpl; first done.
- iApply rwp_lift_pure_det_step_no_fork.
- - intros σ. specialize (Hsafe σ). destruct s; eauto using reducible_not_val.
- - done.
- - by iApply "IH".
-Qed.
-
-
-(* step refinement weakest lemmas *)
-Lemma rswp_lift_step_fupd k s E Φ e1 :
- (∀ σ1 n, ref_state_interp σ1 n ={E,∅}=∗
- |={∅,∅}▷=>^k ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
- ∀ e2 σ2 efs κ, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ ={∅,E}=∗
- ref_state_interp σ2 (length efs + n) ∗
- RWP e2 @ s; E ⟨⟨ Φ ⟩⟩ ∗
- [∗ list] ef ∈ efs, RWP ef @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩)
- ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- rewrite rswp_unfold /rswp_def /rswp_step. iIntros "H" (σ1 n ?) "(?&Hσ)".
- iMod ("H" with "Hσ") as "H". iModIntro. iApply (step_fupdN_wand with "H").
- iIntros "($&H)". iFrame. eauto.
-Qed.
-
-Lemma rswp_lift_step k s E Φ e1 :
- (∀ σ1 n, ref_state_interp σ1 n ={E,∅}=∗
- ▷^k (⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
- ∀ e2 σ2 efs κ, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ ={∅,E}=∗
- ref_state_interp σ2 (length efs + n) ∗
- RWP e2 @ s; E ⟨⟨ Φ ⟩⟩ ∗
- [∗ list] ef ∈ efs, RWP ef @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩))
- ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros "H". iApply rswp_lift_step_fupd. iIntros (??) "Hσ".
- iMod ("H" with "Hσ") as "H". iIntros "!>". by iApply step_fupdN_intro.
-Qed.
-
-Lemma rswp_lift_pure_step_no_fork k s E E' Φ e1 :
- (∀ σ1, s = NotStuck → reducible e1 σ1) →
- (∀ κ σ1 e2 σ2 efs, prim_step e1 σ1 κ e2 σ2 efs → κ = [] ∧ σ2 = σ1 ∧ efs = []) →
- (|={E}=>|={E,E'}▷=>^k ∀ κ e2 efs σ, ⌜prim_step e1 σ κ e2 σ efs⌝ → RWP e2 @ s; E ⟨⟨ Φ ⟩⟩)
- ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros (Hsafe Hstep) "H". iApply rswp_lift_step_fupd.
- iIntros (σ1 n) "Hσ". iMod "H".
- iMod fupd_intro_mask' as "Hclose"; last iModIntro; first by set_solver.
- iApply (step_fupdN_wand with "[Hclose H]").
- { iApply (step_fupdN_mask_comm _ _ E E'); first set_solver; first set_solver.
- iMod "Hclose". by iModIntro. }
- iIntros "H". iSplit.
- { iPureIntro. destruct s; eauto. }
- iIntros (e2 σ2 efs κ Hstep'). iMod "H"; iModIntro.
- destruct (Hstep κ σ1 e2 σ2 efs) as (-> & <- & ->); auto.
- iDestruct ("H" with "[//]") as "H". simpl. iFrame.
-Qed.
-
-Lemma rswp_lift_atomic_step_fupd {k s E1 Φ} e1 :
- (∀ σ1 n, ref_state_interp σ1 n ={E1}=∗
- |={E1,E1}▷=>^k ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
- ∀ e2 σ2 efs κ, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ ={E1}=∗
- ref_state_interp σ2 (length efs + n) ∗
- from_option Φ False (to_val e2) ∗
- [∗ list] ef ∈ efs, RWP ef @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩)
- ⊢ RSWP e1 at k @ s; E1 ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros "H".
- iApply (rswp_lift_step_fupd k s E1 _ e1)=>//; iIntros (σ1 n) "Hσ1".
- iMod ("H" $! σ1 with "Hσ1") as "H". iApply step_fupdN_mask_comm'; first set_solver.
- iApply (step_fupdN_wand with "H"); iIntros "[% H]".
- iMod (fupd_intro_mask' E1 ∅) as "Hclose"; first set_solver.
- iModIntro; iSplit; auto.
- iIntros (e2 σ2 efs κ Hstep). iMod "Hclose".
- iMod ("H" with "[//]") as "($ & H & $)".
- destruct (to_val e2) eqn:?; last by iExFalso.
- iApply rwp_value; last done. by apply of_to_val.
-Qed.
-
-Lemma rswp_lift_atomic_step {k s E Φ} e1 :
- (∀ σ1 n, ref_state_interp σ1 n ={E}=∗
- ▷^k (⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
- ∀ e2 σ2 efs κ, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ ={E}=∗
- ref_state_interp σ2 (length efs + n) ∗
- from_option Φ False (to_val e2) ∗
- [∗ list] ef ∈ efs, RWP ef @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩))
- ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros "H". iApply rswp_lift_atomic_step_fupd.
- iIntros (??) "?". iMod ("H" with "[$]") as "H".
- iIntros "!>". by iApply step_fupdN_intro; first done.
-Qed.
-
-Lemma rswp_lift_pure_det_step_no_fork {k s E E' Φ} e1 e2 :
- (∀ σ1, s = NotStuck → reducible e1 σ1) →
- (∀ σ1 κ e2' σ2 efs', prim_step e1 σ1 κ e2' σ2 efs' →
- κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) →
- (|={E,E'}▷=>^k RWP e2 @ s; E ⟨⟨ Φ ⟩⟩) ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros (? Hpuredet) "H". iApply (rswp_lift_pure_step_no_fork k s E); try done.
- { naive_solver. }
- iModIntro. iApply (step_fupdN_wand with "H"); iIntros "H".
- iIntros (κ e' efs' σ (_&?&->&?)%Hpuredet); auto.
-Qed.
-
-
-(* RSWP lemmas are designed to be used with a single step only. The RSWP returns to RWP after a single step.*)
-Lemma rswp_pure_step_fupd k s E E' e1 e2 φ Φ `{!Inhabited (state Λ)} :
- PureExec φ 1 e1 e2 →
- φ →
- (|={E,E'}▷=>^k RWP e2 @ s; E ⟨⟨ Φ ⟩⟩) ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros (Hexec Hφ) "Hwp". specialize (Hexec Hφ).
- inversion Hexec as [|n' ? e1' ? Hstep Hrest]; subst.
- iApply rswp_lift_pure_det_step_no_fork.
- - intros σ; intros ->; eauto using pure_step_safe, reducible_no_obs_reducible, reducible_not_val.
- - eauto using pure_step_det.
- - inversion Hrest; subst; eauto.
-Qed.
-
-Lemma rswp_pure_step_later `{!Inhabited (state Λ)} k s E e1 e2 φ Φ :
- PureExec φ 1 e1 e2 →
- φ →
- ▷^k RWP e2 @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- intros Hexec ?. rewrite -rswp_pure_step_fupd //. iIntros "H".
- iApply step_fupdN_intro; eauto.
-Qed.
-
-End lifting.
diff --git a/theories/program_logic/refinement/ref_source.v b/theories/program_logic/refinement/ref_source.v
deleted file mode 100644
index e269ea43..00000000
--- a/theories/program_logic/refinement/ref_source.v
+++ /dev/null
@@ -1,372 +0,0 @@
-From iris.base_logic.lib Require Export fancy_updates.
-From iris.proofmode Require Import base tactics classes.
-From iris.algebra Require Import excl auth ord_stepindex arithmetic.
-Set Default Proof Using "Type".
-
-Class source {SI: indexT} (Σ: gFunctors SI) (A: Type) := mkSource {
- source_rel : relation A;
- source_interp : A → iProp Σ
-}.
-
-Infix "↪" := (source_rel) (at level 60).
-
-(* We use the transitive closure.
- It's normalization is equivalent to normalization of source_rel. *)
-Infix "↪⁺" := (tc source_rel) (at level 60).
-
-Infix "↪⋆" := (rtc source_rel) (at level 60).
-
-Lemma sn_tc {X} (R: X → X → Prop) (x: X): sn R x ↔ sn (tc R) x.
-Proof.
- split.
- - induction 1 as [x _ IH]; constructor; simpl; intros y Hy; revert IH; simpl.
- destruct Hy as [x y Honce|x y z Honce Hsteps]; intros IH; eauto.
- destruct (IH _ Honce) as [Hy]; eauto.
- - induction 1 as [z _ IH]; constructor; intros ??; apply IH; simpl in *; eauto using tc_once.
-Qed.
-
-
-
-Section src_update.
- Context {SI A} {Σ: gFunctors SI} `{!source Σ A} `{!invG Σ}.
-
- Definition src_update E (P: iProp Σ) : iProp Σ :=
- (∀ a: A, source_interp a -∗ |={E}=> ∃ b: A, ⌜a ↪⁺ b⌝ ∗ source_interp b ∗ P)%I.
-
- Definition weak_src_update E (P: iProp Σ) : iProp Σ :=
- (∀ a: A, source_interp a -∗ |={E}=> ∃ b: A, ⌜a ↪⋆ b⌝ ∗ source_interp b ∗ P)%I.
-
- Lemma src_update_bind E P Q: src_update E P ∗ (P -∗ src_update E Q) ⊢ src_update E Q.
- Proof.
- rewrite /src_update. iIntros "[P PQ]" (a) "Ha".
- iMod ("P" $! a with "Ha") as (b Hab) "[Hb P]".
- iSpecialize ("PQ" with "P").
- iMod ("PQ" $! b with "Hb") as (c Hbc) "[Hc Q]".
- iModIntro. iExists c. iFrame. iPureIntro.
- by trans b.
- Qed.
-
- Lemma src_update_mono_fupd E P Q: src_update E P ∗ (P ={E}=∗ Q) ⊢ src_update E Q.
- Proof.
- iIntros "[HP PQ]". iIntros (a) "Hsrc".
- iMod ("HP" with "Hsrc") as (b Hstep) "[Hsrc P]".
- iMod ("PQ" with "P"). iFrame. iModIntro.
- iExists b; by iFrame.
- Qed.
-
- Lemma src_update_mono E P Q: src_update E P ∗ (P -∗ Q) ⊢ src_update E Q.
- Proof.
- iIntros "[Hupd HPQ]". iApply (src_update_mono_fupd with "[$Hupd HPQ]").
- iIntros "P". iModIntro. by iApply "HPQ".
- Qed.
-
- Lemma fupd_src_update E P : (|={E}=> src_update E P) ⊢ src_update E P.
- Proof.
- iIntros "H". rewrite /src_update. iIntros (e) "Hsrc".
- iMod "H". by iApply "H".
- Qed.
-
- Lemma src_update_weak_src_update E P: src_update E P ⊢ weak_src_update E P.
- Proof.
- rewrite /src_update /weak_src_update. iIntros "P" (a) "Ha".
- iMod ("P" $! a with "Ha") as (b Hab) "[Hb P]".
- iModIntro. iExists b. iFrame. iPureIntro.
- by apply tc_rtc.
- Qed.
-
- Lemma weak_src_update_return E P: P ⊢ weak_src_update E P.
- Proof.
- rewrite /src_update. iIntros "P" (a) "Ha".
- iModIntro. iExists (a). iFrame. iPureIntro.
- reflexivity.
- Qed.
-
- Lemma weak_src_update_bind_l E P Q: weak_src_update E P ∗ (P -∗ src_update E Q) ⊢ src_update E Q.
- Proof.
- rewrite /src_update. iIntros "[P PQ]" (a) "Ha".
- iMod ("P" $! a with "Ha") as (b Hab) "[Hb P]".
- iSpecialize ("PQ" with "P").
- iMod ("PQ" $! b with "Hb") as (c Hbc) "[Hc Q]".
- iModIntro. iExists c. iFrame. iPureIntro.
- by eapply tc_rtc_l.
- Qed.
-
- Lemma weak_src_update_bind_r E P Q: src_update E P ∗ (P -∗ weak_src_update E Q) ⊢ src_update E Q.
- Proof.
- rewrite /src_update. iIntros "[P PQ]" (a) "Ha".
- iMod ("P" $! a with "Ha") as (b Hab) "[Hb P]".
- iSpecialize ("PQ" with "P").
- iMod ("PQ" $! b with "Hb") as (c Hbc) "[Hc Q]".
- iModIntro. iExists c. iFrame. iPureIntro.
- by eapply tc_rtc_r.
- Qed.
-
- Lemma weak_src_update_mono_fupd E P Q: weak_src_update E P ∗ (P ={E}=∗ Q) ⊢ weak_src_update E Q.
- Proof.
- iIntros "[HP PQ]". iIntros (a) "Hsrc".
- iMod ("HP" with "Hsrc") as (b Hstep) "[Hsrc P]".
- iMod ("PQ" with "P"). iFrame. iModIntro.
- iExists b; by iFrame.
- Qed.
-
- Lemma weak_src_update_mono E P Q: weak_src_update E P ∗ (P -∗ Q) ⊢ weak_src_update E Q.
- Proof.
- iIntros "[Hupd HPQ]". iApply (weak_src_update_mono_fupd with "[$Hupd HPQ]").
- iIntros "P". iModIntro. by iApply "HPQ".
- Qed.
-
- Lemma fupd_weak_src_update E P : (|={E}=> weak_src_update E P) ⊢ weak_src_update E P.
- Proof.
- iIntros "H". rewrite /weak_src_update. iIntros (e) "Hsrc".
- iMod "H". by iApply "H".
- Qed.
-
-End src_update.
-
-
-Section auth_source.
-
- Structure auth_source SI := {
- auth_sourceUR :> ucmraT SI;
- auth_source_discrete : CmraDiscrete auth_sourceUR;
- auth_source_trans : relation auth_sourceUR;
- auth_source_trans_proper: Proper (equiv ==> equiv ==> iff) auth_source_trans;
- auth_source_step_frame (a a' f: auth_sourceUR):
- auth_source_trans a a' → ✓ (a ⋅ f) → ✓ (a' ⋅ f) ∧ auth_source_trans (a ⋅ f) (a' ⋅ f);
- auth_source_op_cancel (a f f': auth_sourceUR):
- ✓ (a ⋅ f) → a ⋅ f ≡ a ⋅ f' → f ≡ f'
- }.
- Existing Instance auth_source_trans_proper.
- Existing Instance auth_source_discrete.
-
- Class auth_sourceG {SI} (Σ: gFunctors SI) (S: auth_source SI) := {
- sourceG_inG :> inG Σ (authR S);
- sourceG_name : gname;
- }.
-
- Global Instance source_auth_source {SI} (Σ: gFunctors SI) (S: auth_source SI) `{!auth_sourceG Σ S} : source Σ S :=
- {|
- source_rel := auth_source_trans _ S;
- source_interp a := own sourceG_name (● a)
- |}.
-
- Definition srcA {SI} {Σ: gFunctors SI} (S: auth_source SI) `{!auth_sourceG Σ S} (s: S) : iProp Σ := own sourceG_name (● s).
- Definition srcF {SI} {Σ: gFunctors SI} (S: auth_source SI) `{!auth_sourceG Σ S} (s: S) : iProp Σ := own sourceG_name (◯ s).
-
-
- Section auth_updates.
- Context {SI} {Σ: gFunctors SI} (S: auth_source SI) `{!auth_sourceG Σ S}.
-
- Lemma source_step_update (E_s e_s e_s': S):
- ✓ E_s → e_s ≼ E_s → e_s ↪ e_s' → ∃ E_s', (E_s, e_s) ~l~> (E_s', e_s') ∧ E_s ↪ E_s'.
- Proof.
- intros Hv Hincl Hstep.
- destruct Hincl as [e_f Heq]. erewrite Heq in Hv.
- specialize (auth_source_step_frame _ S _ _ _ Hstep Hv) as [Hv' Hstep'].
- exists (e_s' ⋅ e_f). split; rewrite Heq.
- - intros α [e_f'|]; simpl; intros ? Heq'; split.
- + by apply cmra_valid_validN.
- + f_equiv. eapply discrete_iff; first apply _.
- eapply discrete_iff in Heq'; last apply _.
- eapply auth_source_op_cancel; last eauto; eauto.
- + by apply cmra_valid_validN.
- + specialize (ucmra_unit_right_id e_s') as H'. rewrite -{2}H'. f_equiv.
- eapply discrete_iff; first apply _.
- eapply discrete_iff in Heq'; last apply _.
- eapply auth_source_op_cancel; first apply Hv.
- by rewrite ucmra_unit_right_id.
- - eapply Hstep'.
- Qed.
-
- Lemma auth_src_update `{!invG Σ} E s s':
- s ↪ s' → srcF S s ⊢ src_update E (srcF S s').
- Proof.
- intros Hstep. unfold src_update. iIntros "SF" (E_s). iIntros "SA".
- iCombine "SA SF" as "S".
- iPoseProof (own_valid_l with "S") as (Hv) "S".
- apply auth_both_valid in Hv as [Hincl Hv].
- eapply source_step_update in Hv as [E_s' [Hl Hstep']]; eauto.
- iMod (own_update _ _ (● E_s' ⋅ ◯ s') with "S") as "S".
- - by apply auth_update.
- - iModIntro. iExists (E_s'); iDestruct "S" as "($ & $)".
- iPureIntro; eauto using tc_once.
- Qed.
-
-
- Lemma srcF_split s t:
- srcF S (s ⋅ t) ⊣⊢ srcF S s ∗ srcF S t.
- Proof.
- rewrite /srcF -own_op auth_frag_op //=.
- Qed.
- End auth_updates.
-
-End auth_source.
-
-Class Credit (SI: indexT) := credit_source: auth_source SI.
-Notation "$ a" := (srcF credit_source a) (at level 60).
-Notation "●$ a" := (srcA credit_source a) (at level 60).
-
-
-(* nat auth source *)
-Section nat_auth_source.
-
- Context (SI: indexT).
-
- Lemma nat_source_step_frame (a a' f : natR SI):
- a' < a → ✓ (a ⋅ f) → ✓ (a' ⋅ f) ∧ (a' ⋅ f) < (a ⋅ f).
- Proof.
- intros Hαβ _; split; first done.
- rewrite !nat_op_plus. lia.
- Qed.
-
- Lemma nat_source_op_cancel (a f f' : natR SI):
- ✓ (a ⋅ f) → a ⋅ f = a ⋅ f' → f = f'.
- Proof using SI.
- intros _; rewrite !nat_op_plus. by intros H% Nat.add_cancel_l.
- Qed.
-
-
- (* we define an auth structure for ordinals *)
- Program Canonical Structure natA : auth_source SI := {|
- auth_sourceUR := natUR SI;
- auth_source_trans := flip lt;
- auth_source_discrete := _;
- auth_source_trans_proper := _;
- auth_source_step_frame := nat_source_step_frame;
- auth_source_op_cancel := nat_source_op_cancel
- |}.
-
- Lemma nat_srcF_split `{!auth_sourceG Σ natA} (n m: nat):
- srcF natA (n + m) ⊣⊢ srcF natA n ∗ srcF natA m.
- Proof. apply srcF_split. Qed.
-
- Lemma nat_srcF_succ `{!auth_sourceG Σ natA} (n: nat):
- srcF natA (S n) ⊣⊢ srcF natA 1 ∗ srcF natA n.
- Proof. rewrite -srcF_split //=. Qed.
-
- Global Instance nat_credit `{!auth_sourceG Σ natA}: Credit SI := natA.
-
-End nat_auth_source.
-
-(* ord auth source *)
-Section ord_auth_source.
-
- Context (SI: indexT).
- Lemma ord_source_step_frame (a a' f : OrdR SI):
- a' ≺ a → ✓ (a ⋅ f) → ✓ (a' ⋅ f) ∧ (a' ⋅ f) ≺ (a ⋅ f).
- Proof.
- intros Hαβ _; split; first done.
- by eapply natural_addition_strict_compat.
- Qed.
-
- Lemma ord_source_op_cancel (a f f' : OrdR SI):
- ✓ (a ⋅ f) → a ⋅ f = a ⋅ f' → f = f'.
- Proof using SI.
- intros _; rewrite comm_L [a ⋅ f']comm_L.
- by apply natural_addition_cancel.
- Qed.
-
- (* we define an auth structure for ordinals *)
- Program Canonical Structure ordA : auth_source SI := {|
- auth_sourceUR := OrdUR SI;
- auth_source_trans := flip (index_lt ordI);
- auth_source_discrete := _;
- auth_source_trans_proper := _;
- auth_source_step_frame := ord_source_step_frame;
- auth_source_op_cancel := ord_source_op_cancel
- |}.
-
- Lemma ord_srcF_split `{!auth_sourceG Σ ordA} (n m: Ord):
- srcF ordA (n ⊕ m) ⊣⊢ srcF ordA n ∗ srcF ordA m.
- Proof. apply srcF_split. Qed.
-
- Definition one := succ zero.
- Lemma ord_srcF_succ `{!auth_sourceG Σ ordA} (n: Ord):
- srcF ordA (succ n) ⊣⊢ srcF ordA one ∗ srcF ordA n.
- Proof.
- rewrite -ord_srcF_split //= natural_addition_succ natural_addition_zero_left_id //=.
- Qed.
-
- Global Instance ord_credit `{!auth_sourceG Σ ordA}: Credit SI := ordA.
-
-End ord_auth_source.
-
-Inductive lex {X Y} (R: X → X → Prop) (S: Y → Y → Prop) : (X * Y) → (X * Y) -> Prop :=
-| lex_left x x' y y': R x x' → lex R S (x, y) (x', y')
-| lex_right x y y': S y y' → lex R S (x, y) (x, y').
-
-Lemma sn_lex {X Y} (R: X → X → Prop) (S: Y → Y → Prop) x y: sn R x -> (forall y, sn S y) → sn (lex R S) (x, y).
-Proof.
- intros Sx Sy. revert y; induction Sx as [x _ IHx]; intros y.
- induction (Sy y) as [y _ IHy].
- constructor. intros [x' y']; simpl; inversion 1; subst.
- - apply IHx; auto.
- - apply IHy; auto.
-Qed.
-
-Lemma tc_lex_left {X Y} (R: X → X → Prop) (S: Y → Y → Prop) x x' y y': tc R x x' → tc (lex R S) (x, y) (x', y').
-Proof.
- induction 1 as [x x' Hstep| x x' x'' Hstep Hsteps] in y, y'.
- - constructor 1. by constructor.
- - econstructor 2; eauto. by eapply (lex_left _ _ _ _ y y).
-Qed.
-
-Lemma tc_lex_right {X Y} (R: X → X → Prop) (S: Y → Y → Prop) x y y': tc S y y' → tc (lex R S) (x, y) (x, y').
-Proof.
- induction 1 as [y y' Hstep|y y' y'' Hstep Hsteps].
- - constructor 1. by constructor.
- - econstructor 2; eauto. by constructor 2.
-Qed.
-
-Lemma lex_rtc {X Y} (R: X → X → Prop) (S: Y → Y → Prop) x x' y y': rtc (lex R S) (x, y) (x', y') → rtc R x x'.
-Proof.
- remember (x, y) as p1. remember (x', y') as p2. intros Hrtc.
- revert x x' y y' Heqp1 Heqp2. induction Hrtc as [p|p1 p2 p3 Hstep Hsteps IH]; intros x x' y y' -> Heq.
- - injection Heq. by intros -> ->.
- - subst p3. inversion Hstep; subst.
- + etransitivity; last by eapply IH.
- eapply rtc_l; by eauto.
- + by eapply IH.
-Qed.
-
-
-(* stuttering: we can stutter with any auth source *)
-Section lexicographic.
-
- Context {SI A B} {Σ: gFunctors SI} `{src1: !source Σ A} `{src2: !source Σ B}.
-
- Global Instance lex_source : source Σ (A * B) := {|
- source_rel := lex source_rel source_rel;
- source_interp := (λ '(a, b), source_interp a ∗ source_interp b)%I;
- |}.
-
- Lemma source_update_embed_l_strong `{!invG Σ} E P Q:
- @src_update _ _ Σ src1 _ E P ∗
- (∀ b: B, source_interp b ={E}=∗ ∃ b': B, source_interp b' ∗ Q)
- ⊢ @src_update _ _ Σ lex_source _ E (P ∗ Q).
- Proof.
- rewrite /src_update; simpl. iIntros "[H Hupd]".
- iIntros ([a b]) "[Hs Hsrc]". iMod ("H" with "Hs") as (a' Hstep) "[SI P]".
- iFrame. iMod ("Hupd" with "Hsrc") as (b') "[Hsrc $]". iModIntro. iExists (a', b'); iFrame.
- iPureIntro. by apply tc_lex_left.
- Qed.
-
- Lemma source_update_embed_l `{!invG Σ} E P:
- @src_update _ _ Σ src1 _ E P ⊢ @src_update _ _ Σ lex_source _ E P.
- Proof.
- iIntros "H". iPoseProof (source_update_embed_l_strong _ _ True%I with "[$H]") as "H".
- - iIntros (b) "Hsrc". iModIntro. iExists b. iFrame.
- - iApply src_update_mono; iFrame; iIntros "[$ _]".
- Qed.
-
- Lemma source_update_embed_r `{!invG Σ} E P:
- @src_update _ _ Σ src2 _ E P ⊢ @src_update _ _ Σ lex_source _ E P.
- Proof.
- rewrite /src_update; simpl. iIntros "H".
- iIntros ([a b]) "[Ha Hb]". iMod ("H" with "Hb") as (b' Hstep) "[SI P]".
- iFrame. iModIntro. iExists (a, b'); iFrame.
- iPureIntro. by apply tc_lex_right.
- Qed.
-
-
-End lexicographic.
diff --git a/theories/program_logic/refinement/ref_weakestpre.v b/theories/program_logic/refinement/ref_weakestpre.v
deleted file mode 100644
index a04bc270..00000000
--- a/theories/program_logic/refinement/ref_weakestpre.v
+++ /dev/null
@@ -1,691 +0,0 @@
-From iris.program_logic Require Export language.
-From iris.bi Require Export fixpoint weakestpre.
-From iris.proofmode Require Import base tactics classes.
-From iris.algebra Require Import auth list.
-From iris.base_logic Require Export gen_heap.
-From iris.base_logic.lib Require Export fancy_updates logical_step.
-From iris.program_logic.refinement Require Export ref_source.
-Set Default Proof Using "Type".
-
-From iris.program_logic Require Import weakestpre.
-
-Class ref_irisG (Λ : language) {SI} (Σ : gFunctors SI) := IrisG {
- ref_iris_invG :> invG Σ;
- (** The state interpretation is an invariant that should hold in between each
- step of reduction. Here [Λstate] is the global state and [nat] is the number of forked-off threads
- (not the total number of threads, which is one higher because there is always
- a main thread). *)
- ref_state_interp : state Λ → nat → iProp Σ;
-
- (** A fixed postcondition for any forked-off thread. For most languages, e.g.
- heap_lang, this will simply be [True]. However, it is useful if one wants to
- keep track of resources precisely, as in e.g. Iron. *)
- ref_fork_post : val Λ → iProp Σ;
-}.
-
-(* we first define the core of the WP for the case that e1 is not a value.
- Φ is the prop that needs to hold for the expression (and forked-off threads) that we step to. *)
-Definition rwp_step {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} E s (e1: expr Λ) (φ: expr Λ → list (expr Λ) → iProp Σ) : iProp Σ :=
- (∀ σ1 n (a: A), source_interp a ∗ ref_state_interp σ1 n ={E,∅}=∗
- ∃ b, ▷? b |={∅}=> (⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
- ∀ e2 σ2 efs κ, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ -∗ |={∅,E}=> (
- (if b then ∃ (a': A), ⌜a ↪⁺ a'⌝ ∗ source_interp a' else source_interp a) ∗
- ref_state_interp σ2 (length efs + n) ∗ φ e2 efs)))%I.
-
-(* a "stronger" version: we cannot take a source step, but have to prove that the target
- can take a step under k laters *)
-Definition rswp_step {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} (k: nat) E s (e1: expr Λ) (φ: expr Λ → list (expr Λ) → iProp Σ) : iProp Σ :=
- (∀ σ1 n a, source_interp a ∗ ref_state_interp σ1 n ={E,∅}=∗
- |={∅, ∅}▷=>^k (⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
- ∀ e2 σ2 efs κ, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ -∗ |={∅,E}=> (
- source_interp a ∗
- ref_state_interp σ2 (length efs + n) ∗ φ e2 efs)))%I.
-
-(* pre-definition of rwp of which we will take a fixpoint. *)
-Definition rwp_pre {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} (s: stuckness)
- (rwp : coPset → expr Λ → (val Λ → iProp Σ) → iProp Σ) :
- coPset → expr Λ → (val Λ → iProp Σ) → iProp Σ := λ E e1 Φ,
- match to_val e1 with
- | Some v => ∀ σ n a, source_interp a ∗ ref_state_interp σ n ={E}=∗ source_interp a ∗ ref_state_interp σ n ∗ Φ v
- | None => rwp_step E s e1 (λ e2 efs, (rwp E e2 Φ) ∗ [∗ list] i ↦ ef ∈ efs, rwp ⊤ ef ref_fork_post)
- end%I.
-
-Lemma rwp_pre_mono {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} s (wp1 wp2 : coPset → expr Λ → (val Λ → iProp Σ) → iProp Σ) :
- ⊢ ((□ ∀ E e Φ, wp1 E e Φ -∗ wp2 E e Φ) →
- ∀ E e Φ, rwp_pre s wp1 E e Φ -∗ rwp_pre s wp2 E e Φ)%I.
-Proof.
-iIntros "#H"; iIntros (E e1 Φ) "Hwp". rewrite /rwp_pre /rwp_step.
-destruct (to_val e1) as [v|]; first done.
-iIntros (σ1 n e_s) "Hσ". iMod ("Hwp" with "Hσ") as (b) "Hwp"; iModIntro.
-iExists b. iApply (bi.laterN_wand with "[] Hwp"). iNext. iIntros "Hwp". iMod "Hwp" as "($ & Hwp)". iModIntro.
-iIntros (e2 σ2 efs κ) "Hstep"; iMod ("Hwp" with "Hstep") as "(Hsrc & Hσ & Hwp & Hfork)".
-iModIntro; iFrame "Hsrc Hσ". iSplitL "Hwp"; first by iApply "H".
-iApply (@big_sepL_impl with "Hfork"); iIntros "!#" (k e _) "Hwp".
- by iApply "H".
-Qed.
-
-(* Uncurry [rwp_pre] and equip its type with an OFE structure *)
-Definition rwp_pre' {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} (s : stuckness) :
-(prodO (prodO (leibnizO SI coPset) (exprO SI Λ)) (val Λ -d> iProp Σ) → iProp Σ) →
-prodO (prodO (leibnizO SI coPset) (exprO SI Λ)) (val Λ -d> iProp Σ) → iProp Σ
-:= curry3 ∘ rwp_pre s ∘ uncurry3.
-
-Local Instance rwp_pre_mono' {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} s :
- BiMonoPred (rwp_pre' s).
-Proof.
-constructor.
-- iIntros (wp1 wp2) "#H"; iIntros ([[E e1] Φ]); iRevert (E e1 Φ).
- iApply rwp_pre_mono. iIntros "!#" (E e Φ). iApply ("H" $! (E,e,Φ)).
-- intros wp Hwp n [[E1 e1] Φ1] [[E2 e2] Φ2]
- [[?%leibniz_equiv ?%leibniz_equiv] ?]; simplify_eq/=.
- rewrite /uncurry3 /rwp_pre /rwp_step. do 28 (f_equiv || done).
- by apply pair_ne.
-Qed.
-
-(* take the least fixpoint of the above definition *)
-Definition rwp_def {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} (s : stuckness) (E : coPset)
- (e : expr Λ) (Φ : val Λ → iProp Σ) : iProp Σ
- := bi_least_fixpoint (rwp_pre' s) (E,e,Φ).
-Definition rwp_aux {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} : seal (@rwp_def SI Σ A Λ _ _). by eexists. Qed.
-Instance rwp' {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} : Rwp Λ (iProp Σ) stuckness := rwp_aux.(unseal).
-Definition rwp_eq {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} : rwp = @rwp_def SI Σ A Λ _ _ := rwp_aux.(seal_eq).
-
-(* take a rswp_step and afterwards, we prove an rwp *)
-Definition rswp_def {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} (k: nat) (s : stuckness) (E : coPset) (e : expr Λ) (Φ : val Λ → iProp Σ) : iProp Σ
- := rswp_step k E s e (λ e2 efs, (rwp s E e2 Φ)
- ∗ [∗ list] i ↦ ef ∈ efs, rwp s ⊤ ef ref_fork_post)%I.
-Definition rswp_aux {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} : seal (@rswp_def SI Σ A Λ _ _). by eexists. Qed.
-Instance rswp' {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} : Rswp Λ (iProp Σ) stuckness := rswp_aux.(unseal).
-Definition rswp_eq {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} : rswp = @rswp_def SI Σ A Λ _ _ := rswp_aux.(seal_eq).
-
-
-
-Section rwp.
-Context {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ}.
-Implicit Types s : stuckness.
-Implicit Types P : iProp Σ.
-Implicit Types Φ : val Λ → iProp Σ.
-Implicit Types v : val Λ.
-Implicit Types e : expr Λ.
-Implicit Types a : A.
-Implicit Types b : bool.
-
-(* Weakest pre *)
-Lemma rwp_unfold s E e Φ :
- RWP e @ s; E ⟨⟨ Φ ⟩⟩ ⊣⊢ rwp_pre s (rwp (PROP:=iProp Σ) s) E e Φ.
-Proof. by rewrite rwp_eq /rwp_def least_fixpoint_unfold. Qed.
-
-
-Lemma rwp_strong_ind s Ψ :
- (∀ n E e, Proper (pointwise_relation _ (dist n) ==> dist n) (Ψ E e))
- → ⊢ (□ (∀ e E Φ, rwp_pre s (λ E e Φ, Ψ E e Φ ∧ RWP e @ s; E ⟨⟨ Φ ⟩⟩) E e Φ -∗ Ψ E e Φ)
- → ∀ e E Φ, RWP e @ s; E ⟨⟨ Φ ⟩⟩ -∗ Ψ E e Φ)%I.
-Proof.
- iIntros (HΨ). iIntros "#IH" (e E Φ) "H". rewrite rwp_eq.
- set (Ψ' := curry3 Ψ :
- prodO (prodO (leibnizO SI coPset) (exprO SI Λ)) (val Λ -d> iProp Σ) → iProp Σ).
- assert (NonExpansive Ψ').
- { intros n [[E1 e1] Φ1] [[E2 e2] Φ2]
- [[?%leibniz_equiv ?%leibniz_equiv] ?]; simplify_eq/=. by apply HΨ. }
- iApply (least_fixpoint_strong_ind _ Ψ' with "[] H").
- iIntros "!#" ([[??] ?]) "H". by iApply "IH".
-Qed.
-
-Lemma rwp_ind s Ψ :
- (∀ n E e, Proper (pointwise_relation _ (dist n) ==> dist n) (Ψ E e))
- → ⊢ (□ (∀ e E Φ, rwp_pre s (λ E e Φ, Ψ E e Φ) E e Φ -∗ Ψ E e Φ)
- → ∀ e E Φ, RWP e @ s; E ⟨⟨ Φ ⟩⟩ -∗ Ψ E e Φ)%I.
-Proof.
- iIntros (HΨ) "#H". iApply rwp_strong_ind. iIntros "!>" (e E Φ) "Hrwp".
- iApply "H". iApply (rwp_pre_mono with "[] Hrwp"). clear.
- iIntros "!>" (E e Φ) "[$ _]".
-Qed.
-
-Global Instance rwp_ne s E e n :
- Proper (pointwise_relation _ (dist n) ==> dist n) (rwp (PROP:=iProp Σ) s E e).
-Proof.
- intros Φ1 Φ2 HΦ. rewrite !rwp_eq. by apply (least_fixpoint_ne _), pair_ne, HΦ.
-Qed.
-
-Global Instance rwp_proper s E e :
- Proper (pointwise_relation _ (≡) ==> (≡)) (rwp (PROP:=iProp Σ) s E e).
-Proof.
- by intros Φ Φ' ?; apply equiv_dist=>n; apply rwp_ne=>v; apply equiv_dist.
-Qed.
-
-Lemma rwp_value' s E Φ v : Φ v ⊢ RWP of_val v @ s; E ⟨⟨ Φ ⟩⟩.
-Proof. iIntros "HΦ". rewrite rwp_unfold /rwp_pre to_of_val. iIntros (???) "($&$)". auto. Qed.
-(*
-Lemma rwp_value_inv' s E Φ v : RWP of_val v @ s; E ⟨⟨ Φ ⟩⟩ ={E}=∗ Φ v.
-Proof. by rewrite rwp_unfold /rwp_pre to_of_val. Qed.
-*)
-
-
-Lemma rwp_strong_mono' s1 s2 E1 E2 e Φ Ψ :
- s1 ⊑ s2 → E1 ⊆ E2 →
- RWP e @ s1; E1 ⟨⟨ Φ ⟩⟩ -∗
- (∀ σ n a v, source_interp a ∗ ref_state_interp σ n ∗ Φ v ={E2}=∗
- source_interp a ∗ ref_state_interp σ n ∗ Ψ v) -∗
- RWP e @ s2; E2 ⟨⟨ Ψ ⟩⟩.
-Proof.
- iIntros (? HE) "H HΦ". iRevert (E2 Ψ HE) "HΦ"; iRevert (e E1 Φ) "H".
- iApply rwp_ind; first solve_proper.
- iIntros "!#" (e E1 Φ) "IH"; iIntros (E2 Ψ HE) "HΦ".
- rewrite !rwp_unfold /rwp_pre /rwp_step.
- destruct (to_val e) as [v|] eqn:?.
- { iIntros (???) "H".
- iSpecialize ("IH" with "[$]").
- iMod (fupd_mask_mono with "IH") as "(H1&H2&H)"; auto.
- by iApply ("HΦ" with "[$]"). }
- iIntros (σ1 n e_s) "Hσ". iMod (fupd_intro_mask' E2 E1) as "Hclose"; first done.
- iMod ("IH" with "[$]") as "IH". iModIntro. iDestruct "IH" as (b) "IH". iExists b.
- iNext. iMod "IH" as "[? IH]"; iModIntro.
- iSplit; [by destruct s1, s2|]. iIntros (e2 σ2 efs κ Hstep).
- iSpecialize ("IH" with "[//]"). iMod "IH". iMod "Hclose" as "_". iModIntro.
- iDestruct "IH" as "($ & $ & IH & Hefs)". iSplitR "Hefs".
- - iApply ("IH" with "[//] HΦ").
- - iApply (big_sepL_impl with "Hefs"); iIntros "!#" (k ef _).
- iIntros "IH". iApply ("IH" with "[]"); auto.
-Qed.
-
-Lemma rwp_strong_mono s1 s2 E1 E2 e Φ Ψ :
- s1 ⊑ s2 → E1 ⊆ E2 →
- RWP e @ s1; E1 ⟨⟨ Φ ⟩⟩ -∗ (∀ v, Φ v ={E2}=∗ Ψ v) -∗ RWP e @ s2; E2 ⟨⟨ Ψ ⟩⟩.
-Proof.
- iIntros (??) "Hrwp H". iApply (rwp_strong_mono' with "[$]"); auto.
- iIntros (????) "($&$&HΦ)". by iApply "H".
-Qed.
-
-Lemma fupd_rwp s E e Φ : (|={E}=> RWP e @ s; E ⟨⟨ Φ ⟩⟩) ⊢ RWP e @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- rewrite rwp_unfold /rwp_pre. iIntros "H". destruct (to_val e) as [v|] eqn:?.
- { by iMod "H". }
- iIntros (σ1 n e_s) "HS". iMod "H". by iApply "H".
-Qed.
-Lemma fupd_rwp' s E e Φ : (∀ σ1 n a, source_interp a ∗ ref_state_interp σ1 n ={E}=∗
- source_interp a ∗ ref_state_interp σ1 n ∗
- RWP e @ s; E ⟨⟨ Φ ⟩⟩) ⊢ RWP e @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros "H".
- iEval (rewrite rwp_unfold /rwp_pre). destruct (to_val e) as [v|] eqn:Heq.
- { iIntros. iSpecialize ("H" with "[$]"). rewrite rwp_unfold /rwp_pre Heq.
- iMod "H" as "(H1&H2&Hwand)". by iMod ("Hwand" with "[$]") as "$". }
- iIntros (σ1 n e_s) "HS".
- iSpecialize ("H" with "[$]"). rewrite rwp_unfold /rwp_pre Heq.
- iMod "H" as "(H1&H2&Hwand)". by iMod ("Hwand" with "[$]") as "$".
-Qed.
-Lemma rwp_fupd s E e Φ : RWP e @ s; E ⟨⟨ v, |={E}=> Φ v ⟩⟩ ⊢ RWP e @ s; E ⟨⟨ Φ ⟩⟩.
-Proof. iIntros "H". iApply (rwp_strong_mono s s E with "H"); auto. Qed.
-
-Lemma rwp_fupd' s E e Φ : RWP e @ s; E ⟨⟨ v, ∀ σ1 n a, source_interp a ∗ ref_state_interp σ1 n ={E}=∗
- source_interp a ∗ ref_state_interp σ1 n ∗ Φ v⟩⟩
- ⊢ RWP e @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros "H". iApply (rwp_strong_mono' s s E with "H"); auto. iIntros (????) "(?&?&H)".
- by iMod ("H" with "[$]").
-Qed.
-
-
-(* TODO: We do not need StronglyAtomic for the definition with a single later but for the definition with a logical step. *)
-Lemma rwp_atomic E1 E2 e s Φ `{!Atomic StronglyAtomic e} :
- (|={E1,E2}=> RWP e @ s; E2 ⟨⟨ v, |={E2,E1}=> Φ v ⟩⟩) ⊢ RWP e @ s; E1 ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros "H". rewrite !rwp_unfold /rwp_pre.
- destruct (to_val e) as [v|] eqn:He.
- { iIntros. iMod ("H"). iMod ("H" with "[$]") as "($&$&$)". }
- iIntros (σ1 n e_s) "Hσ". iMod "H".
- iMod ("H" $! σ1 with "Hσ") as "H". iModIntro.
- iDestruct "H" as (b) "H". iExists b. iNext. iMod "H" as "[$ H]"; iModIntro.
- iIntros (e2 σ2 efs κ Hstep). iSpecialize ("H" with "[//]"). iMod "H".
- iDestruct "H" as "(Hsrc & Hσ & H & Hefs)".
- rewrite rwp_unfold /rwp_pre. destruct (to_val e2) as [v2|] eqn:He2.
- - rewrite rwp_unfold /rwp_pre He2.
- destruct b.
- * iDestruct "Hsrc" as (??) "H'". iMod ("H" with "[$]") as "(Hsrc&$&H)".
- iFrame. iMod "H". iIntros "!>".
- iSplitL "Hsrc"; first eauto.
- iIntros (???) "(?&?) !>". iFrame.
- * iMod ("H" with "[$]") as "(Hsrc&$&H)".
- iFrame. iMod "H". iIntros "!>".
- iIntros (???) "(?&?) !>". iFrame.
- - specialize (atomic _ _ _ _ _ Hstep) as []; congruence.
-Qed.
-
-Lemma rwp_bind K `{!LanguageCtx K} s E e Φ :
- RWP e @ s; E ⟨⟨ v, RWP K (of_val v) @ s; E ⟨⟨ Φ ⟩⟩ ⟩⟩ ⊢ RWP K e @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- revert Φ. cut (∀ Φ', RWP e @ s; E ⟨⟨ Φ' ⟩⟩ -∗ ∀ Φ,
- (∀ v, Φ' v -∗ RWP K (of_val v) @ s; E ⟨⟨ Φ ⟩⟩) -∗ RWP K e @ s; E ⟨⟨ Φ ⟩⟩).
- { iIntros (help Φ) "H". iApply (help with "H"); auto. }
- iIntros (Φ') "H". iRevert (e E Φ') "H". iApply rwp_strong_ind; first solve_proper.
- iIntros "!#" (e E1 Φ') "IH". iIntros (Φ) "HΦ".
- rewrite /rwp_pre /rwp_step.
- destruct (to_val e) as [v|] eqn:He.
- { apply of_to_val in He as <-. iApply fupd_rwp'.
- iIntros. iMod ("IH" with "[$]") as "($&$&H)".
- by iApply "HΦ". }
- rewrite rwp_unfold /rwp_pre /rwp_step fill_not_val //.
- iIntros (σ1 n a) "H". iMod ("IH" with "H") as "IH". iModIntro.
- iDestruct "IH" as (b) "IH". iExists b. iNext.
- iMod "IH" as "[% IH]"; iModIntro. iSplit.
- { iPureIntro. destruct s; last done.
- unfold reducible in *. naive_solver eauto using fill_step. }
- iIntros (e2 σ2 efs κ Hstep).
- destruct (fill_step_inv e σ1 κ e2 σ2 efs) as (e2'&->&?); auto.
- iMod ("IH" $! e2' σ2 efs with "[//]") as "($ & $ & IH & IHfork)". iIntros "!>".
- iSplitL "IH HΦ".
- - iDestruct "IH" as "[IH _]". by iApply "IH".
- - by setoid_rewrite bi.and_elim_r.
-Qed.
-
-
-Lemma rwp_bind_inv K `{!LanguageCtx K} s E e Φ :
- RWP K e @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RWP e @ s; E ⟨⟨ v, RWP K (of_val v) @ s; E ⟨⟨ Φ ⟩⟩ ⟩⟩.
-Proof.
- iIntros "H". remember (K e) as e' eqn:He'.
- iRevert (e He'). iRevert (e' E Φ) "H". iApply rwp_strong_ind; first solve_proper.
- iIntros "!#" (e' E1 Φ) "IH". iIntros (e ->).
- rewrite !rwp_unfold {2}/rwp_pre.
- destruct (to_val e) as [v|] eqn:He.
- { iIntros (???) "($&$)". iModIntro. apply of_to_val in He as <-. rewrite !rwp_unfold.
- iApply (rwp_pre_mono with "[] IH"). by iIntros "!#" (E e Φ') "[_ ?]". }
- rewrite /rwp_pre fill_not_val //.
- iIntros (σ1 κs n) "Hσ". iMod ("IH" with "[$]") as (b) "IH". iModIntro.
- iExists b. iNext. iMod "IH" as "[% IH]"; iModIntro. iSplit.
- { destruct s; eauto using reducible_fill. }
- iIntros (e2 σ2 efs κ Hstep).
- iMod ("IH" $! (K e2) σ2 efs κ with "[]") as "(Hsrc & Hσ & IH & IHefs)"; eauto using fill_step.
- iModIntro. iFrame "Hsrc Hσ". iSplitR "IHefs".
- - iDestruct "IH" as "[IH _]". by iApply "IH".
- - by setoid_rewrite bi.and_elim_r.
-Qed.
-
-(** * Derived rules *)
-Lemma rwp_mono s E e Φ Ψ : (∀ v, Φ v ⊢ Ψ v) → RWP e @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RWP e @ s; E ⟨⟨ Ψ ⟩⟩.
-Proof.
- iIntros (HΦ) "H"; iApply (rwp_strong_mono with "H"); auto.
- iIntros (v) "?". by iApply HΦ.
-Qed.
-Lemma rwp_stuck_mono s1 s2 E e Φ :
- s1 ⊑ s2 → RWP e @ s1; E ⟨⟨ Φ ⟩⟩ ⊢ RWP e @ s2; E ⟨⟨ Φ ⟩⟩.
-Proof. iIntros (?) "H". iApply (rwp_strong_mono with "H"); auto. Qed.
-Lemma rwp_stuck_weaken s E e Φ :
- RWP e @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RWP e @ E ?⟨⟨ Φ ⟩⟩.
-Proof. apply rwp_stuck_mono. by destruct s. Qed.
-Lemma rwp_mask_mono s E1 E2 e Φ : E1 ⊆ E2 → RWP e @ s; E1 ⟨⟨ Φ ⟩⟩ ⊢ RWP e @ s; E2 ⟨⟨ Φ ⟩⟩.
-Proof. iIntros (?) "H"; iApply (rwp_strong_mono with "H"); auto. Qed.
-Global Instance rwp_mono' s E e :
- Proper (pointwise_relation _ (⊢) ==> (⊢)) (rwp (PROP:=iProp Σ) s E e).
-Proof. by intros Φ Φ' ?; apply rwp_mono. Qed.
-
-Lemma rwp_value s E Φ e v : IntoVal e v → Φ v ⊢ RWP e @ s; E ⟨⟨ Φ ⟩⟩.
-Proof. intros <-. by apply rwp_value'. Qed.
-Lemma rwp_value_fupd' s E Φ v : (|={E}=> Φ v) ⊢ RWP of_val v @ s; E ⟨⟨ Φ ⟩⟩.
-Proof. intros. by rewrite -rwp_fupd -rwp_value'. Qed.
-Lemma rwp_value_fupd s E Φ e v `{!IntoVal e v} :
- (|={E}=> Φ v) ⊢ RWP e @ s; E ⟨⟨ Φ ⟩⟩.
-Proof. intros. rewrite -rwp_fupd -rwp_value //. Qed.
-(*
-Lemma rwp_value_inv s E Φ e v : IntoVal e v → RWP e @ s; E ⟨⟨ Φ ⟩⟩ ={E}=∗ Φ v.
-Proof. intros <-. by apply rwp_value_inv'. Qed.
-*)
-
-Lemma rwp_frame_l s E e Φ R : R ∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RWP e @ s; E ⟨⟨ v, R ∗ Φ v ⟩⟩.
-Proof. iIntros "[? H]". iApply (rwp_strong_mono with "H"); auto with iFrame. Qed.
-Lemma rwp_frame_r s E e Φ R : RWP e @ s; E ⟨⟨ Φ ⟩⟩ ∗ R ⊢ RWP e @ s; E ⟨⟨ v, Φ v ∗ R ⟩⟩.
-Proof. iIntros "[H ?]". iApply (rwp_strong_mono with "H"); auto with iFrame. Qed.
-
-Lemma rwp_wand s E e Φ Ψ :
- RWP e @ s; E ⟨⟨ Φ ⟩⟩ -∗ (∀ v, Φ v -∗ Ψ v) -∗ RWP e @ s; E ⟨⟨ Ψ ⟩⟩.
-Proof.
- iIntros "Hwp H". iApply (rwp_strong_mono with "Hwp"); auto.
- iIntros (?) "?". by iApply "H".
-Qed.
-Lemma rwp_wand_l s E e Φ Ψ :
- (∀ v, Φ v -∗ Ψ v) ∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RWP e @ s; E ⟨⟨ Ψ ⟩⟩.
-Proof. iIntros "[H Hwp]". iApply (rwp_wand with "Hwp H"). Qed.
-Lemma rwp_wand_r s E e Φ Ψ :
- RWP e @ s; E ⟨⟨ Φ ⟩⟩ ∗ (∀ v, Φ v -∗ Ψ v) ⊢ RWP e @ s; E ⟨⟨ Ψ ⟩⟩.
-Proof. iIntros "[Hwp H]". iApply (rwp_wand with "Hwp H"). Qed.
-Lemma rwp_frame_wand_l s E e Q Φ :
- Q ∗ RWP e @ s; E ⟨⟨ v, Q -∗ Φ v ⟩⟩ -∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros "[HQ HRWP]". iApply (rwp_wand with "HRWP").
- iIntros (v) "HΦ". by iApply "HΦ".
-Qed.
-
-End rwp.
-
-
-Section rswp.
-Context {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ}.
-Implicit Types s : stuckness.
-Implicit Types P : iProp Σ.
-Implicit Types Φ : val Λ → iProp Σ.
-Implicit Types v : val Λ.
-Implicit Types e : expr Λ.
-Implicit Types a : A.
-Implicit Types b : bool.
-Implicit Types k : nat.
-
-(* Weakest pre *)
-Lemma rswp_unfold k s E e Φ :
- RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩ ⊣⊢ rswp_def k s E e Φ.
-Proof. by rewrite rswp_eq. Qed.
-
-
-Global Instance rswp_ne k s E e n :
- Proper (pointwise_relation _ (dist n) ==> dist n) (rswp (PROP:=iProp Σ) k s E e).
-Proof.
- intros Φ1 Φ2 HΦ. rewrite !rswp_eq /rswp_def /rswp_step.
- do 20 f_equiv. by rewrite HΦ.
-Qed.
-
-Global Instance rswp_proper s E e :
- Proper (pointwise_relation _ (≡) ==> (≡)) (rwp (PROP:=iProp Σ) s E e).
-Proof.
- apply _.
-Qed.
-
-Lemma rswp_strong_mono k s1 s2 E1 E2 e Φ Ψ :
- s1 ⊑ s2 → E1 ⊆ E2 →
- RSWP e at k @ s1; E1 ⟨⟨ Φ ⟩⟩ -∗ (∀ v, Φ v ={E2}=∗ Ψ v) -∗ RSWP e at k @ s2; E2 ⟨⟨ Ψ ⟩⟩.
-Proof.
- iIntros (? HE); rewrite !rswp_eq /rswp_def /rswp_step.
- iIntros "H HΦ" (σ1 n a) "Hσ". iMod (fupd_intro_mask' E2 E1) as "Hclose"; first done.
- iMod ("H" with "[$]") as "H". iModIntro. iApply (step_fupdN_wand with "H").
- iIntros "[H' H]". iSplit; [by destruct s1, s2|]. iIntros (e2 σ2 efs κ Hstep).
- iSpecialize ("H" with "[//]"). iMod "H". iMod "Hclose" as "_". iModIntro.
- iDestruct "H" as "($ & $ & H & Hefs)". iSplitR "Hefs".
- - iApply (rwp_strong_mono with "H"); auto.
- - iApply (big_sepL_impl with "Hefs"); iIntros "!#" (k' ef _).
- iIntros "H"; iApply (rwp_strong_mono with "H"); auto.
-Qed.
-
-
-Lemma fupd_rswp k s E e Φ : (|={E}=> RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩) ⊢ RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- rewrite rswp_eq /rswp_def /rswp_step. iIntros "H".
- iIntros (σ1 n a) "HS". iMod "H". by iApply "H".
-Qed.
-Lemma rswp_fupd k s E e Φ : RSWP e at k @ s; E ⟨⟨ v, |={E}=> Φ v ⟩⟩ ⊢ RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩.
-Proof. iIntros "H". iApply (rswp_strong_mono k s s E with "H"); auto. Qed.
-
-
-(* do not take a source step, end up with an rswp with no later budget *)
-Lemma rwp_no_step E e s Φ:
- to_val e = None →
- (RSWP e at 0 @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RWP e @ s; E ⟨⟨ Φ ⟩⟩)%I.
-Proof.
- rewrite rswp_eq rwp_unfold /rswp_def /rwp_pre /rswp_step /rwp_step.
- iIntros (He) "Hswp". rewrite He. iIntros (σ1 n a) "[Ha Hσ]".
- iMod ("Hswp" with "[$]") as "[$ Hswp]". iModIntro.
- iExists false. iModIntro. iIntros (e2 σ2 efs κ Hstep).
- by iMod ("Hswp" with "[//]") as "($ & $ & $)".
-Qed.
-
-(* take a source step, end up with an rswp with a budget of one later *)
-Lemma rwp_take_step P E e s Φ:
- to_val e = None
- → ⊢ ((P -∗ RSWP e at 1 @ s; E ⟨⟨ Φ ⟩⟩) -∗ src_update E P -∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩)%I.
-Proof.
- rewrite rswp_eq rwp_unfold /rswp_def /rwp_pre /rswp_step /rwp_step.
- iIntros (He) "Hswp Hsrc". rewrite He. iIntros (σ1 n a) "[Ha Hσ]". rewrite /src_update.
- iMod ("Hsrc" with "Ha") as (a' Ha) "(Hsource_interp & P)". iMod ("Hswp" with "P [$]") as "Hswp".
- iMod "Hswp". iModIntro. iExists true. iNext. iMod "Hswp" as "[$ Hswp]"; iModIntro.
- iIntros (e2 σ2 efs κ Hstep'). iMod ("Hswp" with "[//]") as "(Hsrc & $ & Hrwp & $)".
- iModIntro; iFrame. iExists a'; iSplit; eauto.
-Qed.
-
-Lemma rwp_weaken' P E e s Φ:
- to_val e = None
- → ⊢ ((P -∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩) -∗ weak_src_update E P -∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩)%I.
-Proof.
- rewrite rwp_unfold /rwp_pre /rwp_step.
- iIntros (He) "Hwp Hsrc". rewrite He. iIntros (σ1 n a) "[Ha Hσ]". rewrite /src_update.
- iMod ("Hsrc" with "Ha") as (a' Ha) "(Hsource_interp & P)". iMod ("Hwp" with "P [$Hsource_interp $Hσ]") as (b) "Hwp".
- iModIntro. destruct Ha as [a|].
- { iExists b. iFrame. }
- iExists true. destruct b; iNext.
- - iMod "Hwp" as "[$ Hwp]"; iModIntro.
- iIntros (e2 σ2 efs κ Hstep'); iMod ("Hwp" with "[//]") as "(Hstep & $ & $)"; iModIntro.
- iDestruct "Hstep" as (a' Hsteps) "S". iExists a'. iFrame. iPureIntro.
- eapply tc_l, tc_rtc_l; eauto.
- - iMod "Hwp" as "[$ Hwp]"; iModIntro.
- iIntros (e2 σ2 efs κ Hstep'); iMod ("Hwp" with "[//]") as "(Hstep & $ & $)"; iModIntro.
- iExists z. iFrame. iPureIntro.
- eapply tc_rtc_r; eauto. by apply tc_once.
-Qed.
-
-Lemma rwp_weaken P E e s Φ:
- to_val e = None
- → ⊢ ((P -∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩) -∗ src_update E P -∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩)%I.
-Proof.
- intros H. rewrite src_update_weak_src_update. by apply rwp_weaken'.
-Qed.
-
-Lemma rswp_do_step k E e s Φ:
- ▷ RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RSWP e at (S k) @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- rewrite rswp_eq /rswp_def /rswp_step.
- iIntros "H". iIntros (σ1 n a) "Hσ". iMod (fupd_intro_mask' _ ∅) as "Hclose"; first set_solver.
- simpl; do 2 iModIntro. iNext. iSpecialize ("H" with "Hσ"). by iMod "Hclose".
-Qed.
-
-(* TODO: We do not need StronglyAtomic for the definition with a single later but for the definition with a logical step. *)
-Lemma rswp_atomic k E1 E2 e s Φ `{!Atomic StronglyAtomic e} :
- (|={E1,E2}=> RSWP e at k @ s; E2 ⟨⟨ v, |={E2,E1}=> Φ v ⟩⟩) ⊢ RSWP e at k @ s; E1 ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros "H". rewrite !rswp_eq /rswp_def /rswp_step.
- iIntros (σ1 n a) "Hσ". iMod "H".
- iMod ("H" $! σ1 with "Hσ") as "H". iModIntro.
- iApply (step_fupdN_wand with "H"); iIntros "[$ H]".
- iIntros (e2 σ2 efs κ Hstep). iSpecialize ("H" with "[//]"). iMod "H".
- iDestruct "H" as "(? & Hσ & H & Hefs)".
- rewrite rwp_unfold /rwp_pre. destruct (to_val e2) as [v2|] eqn:He2.
- - rewrite rwp_unfold /rwp_pre He2. iDestruct ("H" with "[$]") as ">($&$&>$)". iFrame. eauto.
- - specialize (atomic _ _ _ _ _ Hstep) as []; congruence.
-Qed.
-
-Lemma rswp_bind K `{!LanguageCtx K} k s E e Φ :
- to_val e = None →
- RSWP e at k @ s; E ⟨⟨ v, RWP K (of_val v) @ s; E ⟨⟨ Φ ⟩⟩ ⟩⟩ ⊢ RSWP K e at k @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros (He) "H". rewrite !rswp_eq /rswp_def /rswp_step.
- iIntros (σ1 n a) "Hσ". iMod ("H" with "Hσ") as "H".
- iModIntro. iApply (step_fupdN_wand with "H").
- iIntros "[% H]". iSplit.
- { iPureIntro. destruct s; last done.
- unfold reducible in *. naive_solver eauto using fill_step. }
- iIntros (e2 σ2 efs κ Hstep).
- destruct (fill_step_inv e σ1 κ e2 σ2 efs) as (e2'&->&?); auto.
- iMod ("H" $! e2' σ2 efs with "[//]") as "($ & $ & H & $)". iIntros "!>".
- by iApply rwp_bind.
-Qed.
-
-
-Lemma rswp_bind_inv K `{!LanguageCtx K} k s E e Φ :
- to_val e = None →
- RSWP K e at k @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RSWP e at k @ s; E ⟨⟨ v, RWP K (of_val v) @ s; E ⟨⟨ Φ ⟩⟩ ⟩⟩.
-Proof.
- iIntros (He) "H". rewrite !rswp_eq /rswp_def /rswp_step.
- iIntros (σ1 n a) "Hσ". iMod ("H" with "Hσ") as "H".
- iModIntro. iApply (step_fupdN_wand with "H").
- iIntros "[% H]". iSplit.
- { destruct s; eauto using reducible_fill. }
- iIntros (e2 σ2 efs κ Hstep).
- iMod ("H" $! (K e2) σ2 efs κ with "[]") as "($ & $ & H & $)"; eauto using fill_step.
- iModIntro. by iApply rwp_bind_inv.
-Qed.
-
-(** * Derived rules *)
-Lemma rswp_mono k s E e Φ Ψ : (∀ v, Φ v ⊢ Ψ v) → RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RSWP e at k @ s; E ⟨⟨ Ψ ⟩⟩.
-Proof.
- iIntros (HΦ) "H". iApply (rswp_strong_mono with "[H] []"); auto.
- iIntros (v) "?". by iApply HΦ.
-Qed.
-Lemma rswp_stuck_mono k s1 s2 E e Φ :
- s1 ⊑ s2 → RSWP e at k @ s1; E ⟨⟨ Φ ⟩⟩ ⊢ RSWP e at k @ s2; E ⟨⟨ Φ ⟩⟩.
-Proof. iIntros (?) "H". iApply (rswp_strong_mono with "H"); auto. Qed.
-Lemma rswp_stuck_weaken k s E e Φ :
- RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RSWP e at k @ E ?⟨⟨ Φ ⟩⟩.
-Proof. apply rswp_stuck_mono. by destruct s. Qed.
-Lemma rswp_mask_mono k s E1 E2 e Φ : E1 ⊆ E2 → RSWP e at k @ s; E1 ⟨⟨ Φ ⟩⟩ ⊢ RSWP e at k @ s; E2 ⟨⟨ Φ ⟩⟩.
-Proof. iIntros (?) "H"; iApply (rswp_strong_mono with "H"); auto. Qed.
-Global Instance rswp_mono' k s E e :
- Proper (pointwise_relation _ (⊢) ==> (⊢)) (rswp (PROP:=iProp Σ) k s E e).
-Proof. by intros Φ Φ' ?; apply rswp_mono. Qed.
-
-Lemma rswp_frame_l k s E e Φ R : R ∗ RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RSWP e at k @ s; E ⟨⟨ v, R ∗ Φ v ⟩⟩.
-Proof. iIntros "[? H]". iApply (rswp_strong_mono with "H"); auto with iFrame. Qed.
-Lemma rswp_frame_r k s E e Φ R : RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩ ∗ R ⊢ RSWP e at k @ s; E ⟨⟨ v, Φ v ∗ R ⟩⟩.
-Proof. iIntros "[H ?]". iApply (rswp_strong_mono with "H"); auto with iFrame. Qed.
-
-Lemma rswp_wand k s E e Φ Ψ :
- RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩ -∗ (∀ v, Φ v -∗ Ψ v) -∗ RSWP e at k @ s; E ⟨⟨ Ψ ⟩⟩.
-Proof.
- iIntros "Hwp H". iApply (rswp_strong_mono with "Hwp"); auto.
- iIntros (?) "?". by iApply "H".
-Qed.
-Lemma rswp_wand_l k s E e Φ Ψ :
- (∀ v, Φ v -∗ Ψ v) ∗ RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RSWP e at k @ s; E ⟨⟨ Ψ ⟩⟩.
-Proof. iIntros "[H Hwp]". iApply (rswp_wand with "Hwp H"). Qed.
-Lemma rswp_wand_r k s E e Φ Ψ :
- RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩ ∗ (∀ v, Φ v -∗ Ψ v) ⊢ RSWP e at k @ s; E ⟨⟨ Ψ ⟩⟩.
-Proof. iIntros "[Hwp H]". iApply (rswp_wand with "Hwp H"). Qed.
-Lemma rswp_frame_wand_l k s E e Q Φ :
- Q ∗ RSWP e at k @ s; E ⟨⟨ v, Q -∗ Φ v ⟩⟩ -∗ RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩.
-Proof.
- iIntros "[HQ HWP]". iApply (rswp_wand with "HWP").
- iIntros (v) "HΦ". by iApply "HΦ".
-Qed.
-
-End rswp.
-
-
-(** Proofmode class instances *)
-Section proofmode_classes.
- Context {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ}.
- Implicit Types P Q : iProp Σ.
- Implicit Types Φ : val Λ → iProp Σ.
-
- Global Instance frame_rwp p s E e R Φ Ψ :
- (∀ v, Frame p R (Φ v) (Ψ v)) →
- Frame p R (RWP e @ s; E ⟨⟨ Φ ⟩⟩) (RWP e @ s; E ⟨⟨ Ψ ⟩⟩).
- Proof. rewrite /Frame=> HR. rewrite rwp_frame_l. apply rwp_mono, HR. Qed.
-
- Global Instance frame_rswp k p s E e R Φ Ψ :
- (∀ v, Frame p R (Φ v) (Ψ v)) →
- Frame p R (RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩) (RSWP e at k @ s; E ⟨⟨ Ψ ⟩⟩).
- Proof. rewrite /Frame=> HR. rewrite rswp_frame_l. apply rswp_mono, HR. Qed.
-
- Global Instance is_except_0_rwp s E e Φ : IsExcept0 (RWP e @ s; E ⟨⟨ Φ ⟩⟩).
- Proof. by rewrite /IsExcept0 -{2}fupd_rwp -except_0_fupd -fupd_intro. Qed.
-
- Global Instance is_except_0_rswp k s E e Φ : IsExcept0 (RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩).
- Proof. by rewrite /IsExcept0 -{2}fupd_rswp -except_0_fupd -fupd_intro. Qed.
-
- Global Instance elim_modal_bupd_rwp p s E e P Φ :
- ElimModal True p false (|==> P) P (RWP e @ s; E ⟨⟨ Φ ⟩⟩) (RWP e @ s; E ⟨⟨ Φ ⟩⟩).
- Proof.
- by rewrite /ElimModal bi.intuitionistically_if_elim
- (bupd_fupd E) fupd_frame_r bi.wand_elim_r fupd_rwp.
- Qed.
-
- Global Instance elim_modal_bupd_rswp k p s E e P Φ :
- ElimModal True p false (|==> P) P (RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩) (RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩).
- Proof.
- by rewrite /ElimModal bi.intuitionistically_if_elim
- (bupd_fupd E) fupd_frame_r bi.wand_elim_r fupd_rswp.
- Qed.
-
- Global Instance elim_modal_fupd_rwp p s E e P Φ :
- ElimModal True p false (|={E}=> P) P (RWP e @ s; E ⟨⟨ Φ ⟩⟩) (RWP e @ s; E ⟨⟨ Φ ⟩⟩).
- Proof.
- by rewrite /ElimModal bi.intuitionistically_if_elim
- fupd_frame_r bi.wand_elim_r fupd_rwp.
- Qed.
-
- Global Instance elim_modal_fupd_rswp k p s E e P Φ :
- ElimModal True p false (|={E}=> P) P (RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩) (RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩).
- Proof.
- by rewrite /ElimModal bi.intuitionistically_if_elim
- fupd_frame_r bi.wand_elim_r fupd_rswp.
- Qed.
-
- Global Instance elim_modal_fupd_rwp_atomic s p E1 E2 e P Φ :
- Atomic StronglyAtomic e →
- ElimModal True p false (|={E1,E2}=> P) P
- (RWP e @ s; E1 ⟨⟨ Φ ⟩⟩) (RWP e @ s; E2 ⟨⟨ v, |={E2,E1}=> Φ v ⟩⟩)%I.
- Proof.
- intros. by rewrite /ElimModal bi.intuitionistically_if_elim
- fupd_frame_r bi.wand_elim_r rwp_atomic.
- Qed.
-
- Global Instance elim_modal_fupd_rswp_atomic k s p E1 E2 e P Φ :
- Atomic StronglyAtomic e →
- ElimModal True p false (|={E1,E2}=> P) P
- (RSWP e at k @ s; E1 ⟨⟨ Φ ⟩⟩) (RSWP e at k @ s; E2 ⟨⟨ v, |={E2,E1}=> Φ v ⟩⟩)%I.
- Proof.
- intros. by rewrite /ElimModal bi.intuitionistically_if_elim
- fupd_frame_r bi.wand_elim_r rswp_atomic.
- Qed.
-
-
- Global Instance add_modal_fupd_rwp s E e P Φ :
- AddModal (|={E}=> P) P (RWP e @ s; E ⟨⟨ Φ ⟩⟩).
- Proof. by rewrite /AddModal fupd_frame_r bi.wand_elim_r fupd_rwp. Qed.
-
- Global Instance add_modal_fupd_rswp k s E e P Φ :
- AddModal (|={E}=> P) P (RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩).
- Proof. by rewrite /AddModal fupd_frame_r bi.wand_elim_r fupd_rswp. Qed.
-
-
- Global Instance elim_acc_wp {X} s E1 E2 α β γ e Φ :
- Atomic StronglyAtomic e →
- ElimAcc (X:=X) (fupd E1 E2) (fupd E2 E1)
- α β γ (RWP e @ s; E1 ⟨⟨ Φ ⟩⟩)
- (λ x, RWP e @ s; E2 ⟨⟨ v, |={E2}=> β x ∗ (γ x -∗? Φ v) ⟩⟩)%I.
- Proof.
- intros ?. rewrite /ElimAcc.
- iIntros "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]".
- iApply (rwp_wand with "(Hinner Hα)").
- iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose".
- Qed.
-
- Global Instance elim_acc_rswp {X} k s E1 E2 α β γ e Φ :
- Atomic StronglyAtomic e →
- ElimAcc (X:=X) (fupd E1 E2) (fupd E2 E1)
- α β γ (RSWP e at k @ s; E1 ⟨⟨ Φ ⟩⟩)
- (λ x, RSWP e at k @ s; E2 ⟨⟨ v, |={E2}=> β x ∗ (γ x -∗? Φ v) ⟩⟩)%I.
- Proof.
- intros ?. rewrite /ElimAcc.
- iIntros "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]".
- iApply (rswp_wand with "(Hinner Hα)").
- iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose".
- Qed.
-
- Global Instance elim_acc_wp_nonatomic {X} E α β γ e s Φ :
- ElimAcc (X:=X) (fupd E E) (fupd E E)
- α β γ (RWP e @ s; E ⟨⟨ Φ ⟩⟩)
- (λ x, RWP e @ s; E ⟨⟨ v, |={E}=> β x ∗ (γ x -∗? Φ v) ⟩⟩)%I.
- Proof.
- rewrite /ElimAcc.
- iIntros "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]".
- iApply rwp_fupd.
- iApply (rwp_wand with "(Hinner Hα)").
- iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose".
- Qed.
-
- Global Instance elim_acc_swp_nonatomic {X} k E α β γ e s Φ :
- ElimAcc (X:=X) (fupd E E) (fupd E E)
- α β γ (RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩)
- (λ x, RSWP e at k @ s; E ⟨⟨ v, |={E}=> β x ∗ (γ x -∗? Φ v) ⟩⟩)%I.
- Proof.
- rewrite /ElimAcc.
- iIntros "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]".
- iApply rswp_fupd.
- iApply (rswp_wand with "(Hinner Hα)").
- iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose".
- Qed.
-End proofmode_classes.
diff --git a/theories/program_logic/refinement/seq_weakestpre.v b/theories/program_logic/refinement/seq_weakestpre.v
deleted file mode 100644
index 0b647dea..00000000
--- a/theories/program_logic/refinement/seq_weakestpre.v
+++ /dev/null
@@ -1,32 +0,0 @@
-From iris.proofmode Require Import tactics.
-From iris.base_logic.lib Require Import na_invariants.
-From iris.program_logic.refinement Require Import ref_weakestpre tc_weakestpre.
-Set Default Proof Using "Type".
-
-
-(* sequential reasoning *)
-Class seqG {SI} (Σ: gFunctors SI) := {
- seqG_na_invG :> na_invG Σ;
- seqG_name: gname;
-}.
-
-Definition seq {SI A Λ} {Σ: gFunctors SI} `{!source Σ A} `{!ref_irisG Λ Σ} `{!seqG Σ} E (e: expr Λ) Φ : iProp Σ :=
- (na_own seqG_name E -∗ RWP e ⟨⟨ v, na_own seqG_name E ∗ Φ v ⟩⟩)%I.
-
-Definition se_inv {SI} {Σ: gFunctors SI} `{!invG Σ} `{!seqG Σ} (N: namespace) (P: iProp Σ) := na_inv seqG_name N P.
-
-Notation "'SEQ' e @ E ⟨⟨ v , Q ⟩ ⟩" := (seq E e%E (λ v, Q)) (at level 20, e, Q at level 200,
-format "'[' 'SEQ' e '/' '[ ' @ E ⟨⟨ v , Q ⟩ ⟩ ']' ']'") : bi_scope.
-Notation "'SEQ' e ⟨⟨ v , Q ⟩ ⟩" := (seq ⊤ e%E (λ v, Q)) (at level 20, e, Q at level 200,
-format "'[' 'SEQ' e '/' '[ ' ⟨⟨ v , Q ⟩ ⟩ ']' ']'") : bi_scope.
-
-Lemma seq_value {SI A Λ} {Σ: gFunctors SI} `{!source Σ A} `{!ref_irisG Λ Σ} `{!seqG Σ} Φ E (v: val Λ) e `{!IntoVal e v}: Φ v ⊢ SEQ e @ E ⟨⟨ v, Φ v⟩⟩.
-Proof.
- iIntros "Hv Hna". iApply rwp_value. iFrame.
-Qed.
-
-
-Notation "'SEQ' e @ E [{ v , Q } ]" := (@seq _ (ordA _) _ _ _ _ _ E e%E (λ v, Q)) (at level 20, e, Q at level 200,
-format "'[' 'SEQ' e '/' '[ ' @ E [{ v , Q } ] ']' ']'") : bi_scope.
-Notation "'SEQ' e [{ v , Q } ]" := (@seq _ (ordA _) _ _ _ _ _ ⊤ e%E (λ v, Q)) (at level 20, e, Q at level 200,
-format "'[' 'SEQ' e '/' '[ ' [{ v , Q } ] ']' ']'") : bi_scope.
diff --git a/theories/program_logic/refinement/tc_weakestpre.v b/theories/program_logic/refinement/tc_weakestpre.v
deleted file mode 100644
index a5f00b1a..00000000
--- a/theories/program_logic/refinement/tc_weakestpre.v
+++ /dev/null
@@ -1,103 +0,0 @@
-From iris.program_logic Require Export language.
-From iris.proofmode Require Import base tactics classes.
-From iris.algebra Require Import auth.
-From iris.algebra.ordinals Require Export ord_stepindex arithmetic.
-From iris.program_logic.refinement Require Import ref_adequacy ref_source ref_weakestpre.
-Set Default Proof Using "Type".
-
-
-(* time credits weakest precondition, using notation of total weakest-pre *)
-Notation tcG Σ := (auth_sourceG Σ (ordA _)).
-
-Global Program Instance tcwp {SI} {Σ: gFunctors SI} `{!tcG Σ} `{!ref_irisG Λ Σ} : Twp Λ (iProp Σ) stuckness := rwp.
-
-Section lemmas.
- Context {SI} {Σ: gFunctors SI} {Λ} `{!ref_irisG Λ Σ} `{!tcG Σ}.
-
- Definition one := (succ zero).
-
- Lemma tc_split α β: $ (α ⊕ β) ≡ ($α ∗ $β)%I.
- Proof.
- by rewrite -ord_op_plus /srcF auth_frag_op own_op.
- Qed.
-
- Lemma tc_succ α: $ succ α ≡ ($ α ∗ $ one)%I.
- Proof.
- by rewrite -tc_split /one natural_addition_comm natural_addition_succ natural_addition_zero_left_id.
- Qed.
-
- Lemma tcwp_rwp e E s Φ:
- twp s E e Φ ≡ rwp s E e Φ.
- Proof. reflexivity. Qed.
-
- Lemma tcwp_burn_credit e E s (Φ: val Λ → iProp Σ):
- to_val e = None →
- ⊢ ($ one -∗ (▷ RSWP e at 0 @ s; E ⟨⟨ v, Φ v ⟩⟩) -∗ WP e @ s; E [{ v, Φ v }])%I.
- Proof.
- iIntros (?) "Hone Hwp". rewrite tcwp_rwp.
- iApply (rwp_take_step with "[Hwp] [Hone]"); first done.
- - iIntros "_". iApply rswp_do_step. by iNext.
- - iApply (@auth_src_update _ _ (ordA SI) with "Hone").
- eapply succ_greater.
- Qed.
-
- Lemma tc_weaken (α β: Ord) e s E Φ:
- to_val e = None
- → β ⪯ α
- → ($β -∗ WP e @ s; E [{ Φ }]) ∗ $ α ⊢ WP e @ s; E [{ Φ }].
- Proof.
- intros He [->|]; iIntros "[Hwp Hc]".
- - by iApply "Hwp".
- - iApply (rwp_weaken with "[Hwp] [Hc]"); first done.
- + iExact "Hwp".
- + by iApply (@auth_src_update _ _ (ordA SI) with "Hc").
- Qed.
-
- Lemma tc_alloc_zero s E e Φ: ($ zero -∗ WP e @ s; E [{ Φ }]) ⊢ WP e @ s; E [{ Φ }].
- Proof.
- iIntros "H".
- iMod (@own_unit _ _ _ sourceG_inG sourceG_name) as "Hz".
- replace (ε: @authR SI (auth_sourceUR SI (ordA SI)))
- with (◯ zero: @authR SI (auth_sourceUR SI (ordA SI))) by reflexivity.
- by iSpecialize ("H" with "Hz").
- Qed.
-
- Global Instance tc_timeless α : Timeless ($ α).
- Proof. apply _. Qed.
-
- Global Instance zero_persistent : Persistent ($ zero).
- Proof.
- apply own_core_persistent, auth_frag_core_id.
- replace zero with (core zero) by reflexivity.
- apply cmra_core_core_id.
- Qed.
-
- Global Instance tcwp_elim_wand p e s E Φ Ψ :
- ElimModal True p false (twp s E e Φ) emp (twp s E e Ψ) (∀ v, Φ v ={E}=∗ Ψ v).
- Proof.
- iIntros (_) "(P & HPQ)". iPoseProof (bi.intuitionistically_if_elim with "P") as "P".
- iApply (rwp_strong_mono with "P"); auto. iIntros (v) "HΦ". by iApply ("HPQ" with "[] HΦ").
- Qed.
-End lemmas.
-
-
-
-(* adequacy lemmas *)
-Lemma tcwp_adequacy {SI} {Σ: gFunctors SI} {Λ} `{!ref_irisG Λ Σ} `{!tcG Σ} `{LargeIndex SI} Φ (e: expr Λ) σ (n: nat) (α: Ord):
- satisfiable_at ⊤ (●$ α ∗ ref_state_interp σ n ∗ (WP e [{ v, Φ v}]))%I
- → ex_loop erased_step ([e], σ)
- → False.
-Proof.
- specialize (@rwp_adequacy SI Σ Ord Λ _ _ _ Φ α e σ n NotStuck).
- simpl; rewrite /srcA. intros Had Hsat Hloop. eapply Had; auto.
- by apply wf_ord_lt.
-Qed.
-
-(* instantiation with the ordinal index to be sure *)
-Lemma tcwp_adequacy' {Λ} {Σ: gFunctors ordI} `{!ref_irisG Λ Σ} `{!tcG Σ} Φ e (n: nat) σ (α: Ord):
- satisfiable_at ⊤ (●$ α ∗ ref_state_interp σ n ∗ (WP e [{ v, Φ v}]))%I
- → ex_loop erased_step ([e], σ)
- → False.
-Proof.
- apply tcwp_adequacy.
-Qed.
diff --git a/theories/program_logic/weakestpre.v b/theories/program_logic/weakestpre.v
deleted file mode 100644
index f7a523d3..00000000
--- a/theories/program_logic/weakestpre.v
+++ /dev/null
@@ -1,723 +0,0 @@
-From iris.base_logic.lib Require Export fancy_updates.
-From iris.base_logic.lib Require Export logical_step.
-From iris.program_logic Require Export language.
-From iris.bi Require Export weakestpre.
-From iris.proofmode Require Import base tactics classes.
-Set Default Proof Using "Type".
-Import uPred.
-
-Section eventually.
-
- Context {SI} {PROP: sbi SI} `{FU: BiFUpd SI PROP}.
-
-
- Global Instance big_later_elim p (P Q: PROP):
- ElimModal True p false (⧍ P) P (⧍ Q) Q.
- Proof.
- iIntros (_) "(P & HPQ)". iPoseProof (intuitionistically_if_elim with "P") as "P".
- iDestruct "P" as (n) "P". iExists n. iNext. by iApply "HPQ".
- Qed.
-
- Global Instance plain_big_later `{BP: BiPlainly SI PROP} (P: PROP): Plain P → Plain (⧍ P).
- Proof. apply _. Qed.
-
- Global Instance plain_big_laterN `{BP: BiPlainly SI PROP} (P: PROP) n: Plain P → Plain (⧍^n P).
- Proof. intros HP. induction n; simpl; apply _. Qed.
-
- Lemma eventuallyN_plain `{BP: BiPlainly SI PROP} `{@BiFUpdPlainly SI PROP FU BP} (P : PROP) n E:
- Plain P → (<E>_n P) ⊢ |={E}=> ▷^(S n) P.
- Proof.
- iIntros (HP) "H". iInduction n as [ | n] "IH".
- - iMod "H". by iModIntro.
- - simpl. iSpecialize ("IH" with "H").
- iMod "IH".
- iPoseProof (fupd_trans with "IH") as "IH".
- iPoseProof (fupd_plain_later with "IH") as "IH".
- iMod "IH". iModIntro.
- iNext. by iApply except_0_later.
- Qed.
-
- Lemma eventually_plain `{BP: BiPlainly SI PROP} `{@BiFUpdPlainly SI PROP FU BP} (P : PROP) E:
- Plain P → (<E> P) ⊢ |={E}=> ⧍ P.
- Proof.
- intros HP. iIntros "H".
- unfold eventually. iMod "H". iDestruct "H" as (n) "H".
- iDestruct (eventuallyN_plain _ with "H") as "H".
- iMod "H". iModIntro. eauto.
- Qed.
-
- Existing Instance elim_eventuallyN.
- Lemma lstep_fupd_plain `{BP: BiPlainly SI PROP} `{@BiFUpdPlainly SI PROP FU BP} (P : PROP):
- Plain P → ((>={⊤}=={⊤}=> P) ⊢ |={⊤}=> ⧍ P)%I.
- Proof.
- iIntros (HP) "H".
- iApply (fupd_plain_mask _ ∅). iMod "H".
- iApply eventually_plain.
- iApply eventually_fupd_right.
- iMod "H" as (n) "H". iApply (eventuallyN_eventually (n)). iMod "H".
- by iApply (fupd_plain_mask _ ⊤).
- Qed.
-
- Lemma lstep_fupdN_plain `{BP: BiPlainly SI PROP} `{@BiFUpdPlainly SI PROP FU BP} (P : PROP) n:
- Plain P → ((>={⊤}=={⊤}=>^n P) ⊢ |={⊤}=> ⧍^n P)%I.
- Proof.
- intros HP. iIntros "H". iInduction n as [|n] "IH"; simpl.
- - by iModIntro.
- - iAssert (>={⊤}=={⊤}=> ⧍^n P)%I with "[H]" as "H".
- { do 2 iMod "H". iModIntro. iDestruct "H" as (n') "H".
- iApply (eventuallyN_eventually (n' )). iMod "H".
- iMod "H". by iSpecialize ("IH" with "H").
- }
- iApply (lstep_fupd_plain with "H").
- Qed.
-End eventually.
-
-
-Class irisG (Λ : language) {SI} (Σ : gFunctors SI) := IrisG {
- iris_invG :> invG Σ;
-
- (** The state interpretation is an invariant that should hold in between each
- step of reduction. Here [Λstate] is the global state, [list Λobservation] are
- the remaining observations, and [nat] is the number of forked-off threads
- (not the total number of threads, which is one higher because there is always
- a main thread). *)
- state_interp : state Λ → list (observation Λ) → nat → iProp Σ;
-
- (** A fixed postcondition for any forked-off thread. For most languages, e.g.
- heap_lang, this will simply be [True]. However, it is useful if one wants to
- keep track of resources precisely, as in e.g. Iron. *)
- fork_post : val Λ → iProp Σ;
-}.
-Global Opaque iris_invG.
-
-Definition wp_pre {SI} {Σ: gFunctors SI} `{!irisG Λ Σ} (s : stuckness)
- (wp : coPset -d> expr Λ -d> (val Λ -d> iProp Σ) -d> iProp Σ) :
- coPset -d> expr Λ -d> (val Λ -d> iProp Σ) -d> iProp Σ := λ E e1 Φ,
- match to_val e1 with
- | Some v => |={E}=> Φ v
- | None => ∀ σ1 κ κs n,
- state_interp σ1 (κ ++ κs) n -∗ >={E}=={∅}=> (
- ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
- ∀ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ -∗ |={∅,∅,E}▷=> (
- state_interp σ2 κs (length efs + n) ∗
- wp E e2 Φ ∗
- [∗ list] i ↦ ef ∈ efs, wp ⊤ ef fork_post))
- end%I.
-
-Local Instance wp_pre_contractive {SI} {Σ: gFunctors SI} `{!irisG Λ Σ} s : Contractive (wp_pre s).
-Proof.
- rewrite /wp_pre=> n wp wp' Hwp E e1 Φ.
- do 20 f_equiv. f_contractive. intros β Hβ. do 3 f_equiv. apply (Hwp β Hβ).
- do 3 f_equiv. apply (Hwp β Hβ).
-Qed.
-
-Definition wp_def {SI} {Σ: gFunctors SI} `{!irisG Λ Σ} (s : stuckness) :
- coPset → expr Λ → (val Λ → iProp Σ) → iProp Σ := fixpoint (wp_pre s).
-Definition wp_aux {SI} {Σ: gFunctors SI} `{!irisG Λ Σ} : seal (@wp_def SI Σ Λ _). by eexists. Qed.
-Instance wp' {SI} {Σ: gFunctors SI} `{!irisG Λ Σ} : Wp Λ (iProp Σ) stuckness := wp_aux.(unseal).
-Definition wp_eq {SI} {Σ: gFunctors SI} `{!irisG Λ Σ} : wp = @wp_def SI Σ Λ _ := wp_aux.(seal_eq).
-
-Definition swp_def {SI} {Σ: gFunctors SI} `{!irisG Λ Σ} (k: nat) (s : stuckness) (E: coPset) (e1: expr Λ) (Φ: val Λ → iProp Σ) : iProp Σ :=
- (∀ σ1 κ κs n,
- state_interp σ1 (κ ++ κs) n -∗ >={E}=={∅}=>_k (
- ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
- ∀ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ -∗ |={∅,∅,E}▷=> (
- state_interp σ2 κs (length efs + n) ∗
- WP e2 @ s; E {{ v, Φ v }} ∗
- [∗ list] i ↦ ef ∈ efs, WP ef @ s; ⊤ {{ v, fork_post v }})))%I.
-Definition swp_aux {SI} {Σ: gFunctors SI} `{!irisG Λ Σ} : seal (@swp_def SI Σ Λ _). by eexists. Qed.
-Instance swp' {SI} {Σ: gFunctors SI} `{!irisG Λ Σ} : Swp Λ (iProp Σ) stuckness := swp_aux.(unseal).
-Definition swp_eq {SI} {Σ: gFunctors SI} `{!irisG Λ Σ} : swp = @swp_def SI Σ Λ _ :=
- swp_aux.(seal_eq).
-
-Section wp.
-Context {SI} {Σ: gFunctors SI} `{!irisG Λ Σ}.
-Implicit Types s : stuckness.
-Implicit Types P : iProp Σ.
-Implicit Types Φ : val Λ → iProp Σ.
-Implicit Types v : val Λ.
-Implicit Types e : expr Λ.
-
-(* Weakest pre *)
-Lemma wp_unfold s E e Φ :
- WP e @ s; E {{ Φ }} ⊣⊢ wp_pre s (wp (PROP:=iProp Σ) s) E e Φ.
-Proof. rewrite wp_eq. apply (fixpoint_unfold (wp_pre s)). Qed.
-
-Lemma swp_unfold k s E e Φ :
- SWP e at k @ s; E {{ Φ }} ⊣⊢ swp_def k s E e Φ.
-Proof. by rewrite swp_eq. Qed.
-
-
-Global Instance wp_ne s E e n :
- Proper (pointwise_relation _ (dist n) ==> dist n) (wp (PROP:=iProp Σ) s E e).
-Proof.
- revert e. induction (index_lt_wf SI n) as [n _ IH]=> e Φ Ψ HΦ.
- rewrite !wp_unfold /wp_pre.
- (* FIXME: figure out a way to properly automate this proof *)
- (* FIXME: reflexivity, as being called many times by f_equiv and f_contractive
- is very slow here *)
- do 20 f_equiv. f_contractive. intros β Hβ.
- do 3 f_equiv. eapply IH; eauto.
- intros v. eapply dist_le; eauto.
-Qed.
-Global Instance wp_proper s E e :
- Proper (pointwise_relation _ (≡) ==> (≡)) (wp (PROP:=iProp Σ) s E e).
-Proof.
- by intros Φ Φ' ?; apply equiv_dist=>n; apply wp_ne=>v; apply equiv_dist.
-Qed.
-
-Global Instance swp_ne k s E e n :
- Proper (pointwise_relation _ (dist n) ==> dist n) (swp (PROP:=iProp Σ) k s E e).
-Proof.
- intros Φ Ψ HΦ. rewrite !swp_unfold /swp_def.
- (* FIXME: figure out a way to properly automate this proof *)
- (* FIXME: reflexivity, as being called many times by f_equiv and f_contractive
- is very slow here *)
- do 19 f_equiv. f_contractive. intros β Hβ.
- do 3 f_equiv. eapply wp_ne.
- intros v. eapply dist_le; eauto.
-Qed.
-Global Instance swp_proper k s E e :
- Proper (pointwise_relation _ (≡) ==> (≡)) (swp k (PROP:=iProp Σ) s E e).
-Proof.
- by intros Φ Φ' ?; apply equiv_dist=>n; apply swp_ne=>v; apply equiv_dist.
-Qed.
-
-Lemma wp_value' s E Φ v : Φ v ⊢ WP of_val v @ s; E {{ Φ }}.
-Proof. iIntros "HΦ". rewrite wp_unfold /wp_pre to_of_val. auto. Qed.
-Lemma wp_value_inv' s E Φ v : WP of_val v @ s; E {{ Φ }} ={E}=∗ Φ v.
-Proof. by rewrite wp_unfold /wp_pre to_of_val. Qed.
-
-Section gstep.
-Local Existing Instance elim_gstep.
-Lemma wp_strong_mono s1 s2 E1 E2 e Φ Ψ :
- s1 ⊑ s2 → E1 ⊆ E2 →
- WP e @ s1; E1 {{ Φ }} -∗ (∀ v, Φ v ={E2}=∗ Ψ v) -∗ WP e @ s2; E2 {{ Ψ }}.
-Proof.
- iIntros (? HE) "H HΦ". iLöb as "IH" forall (e E1 E2 HE Φ Ψ).
- rewrite !wp_unfold /wp_pre.
- destruct (to_val e) as [v|] eqn:?.
- { iApply ("HΦ" with "[> -]"). by iApply (fupd_mask_mono E1 _). }
- iIntros (σ1 κ κs n) "Hσ". iMod (fupd_intro_mask' E2 E1) as "Hclose"; first done.
- iMod ("H" with "[$]") as "[? H]".
- iSplit; [by destruct s1, s2|]. iIntros (e2 σ2 efs Hstep).
- iSpecialize ("H" with "[//]"). iMod "H". iModIntro. iNext. iMod "H". iMod "Hclose" as "_".
- iModIntro.
- iDestruct "H" as "(Hσ & H & Hefs)". iFrame "Hσ". iSplitR "Hefs".
- - iApply ("IH" with "[//] H HΦ").
- - iApply (big_sepL_impl with "Hefs"); iIntros "!#" (k ef _).
- iIntros "H". iApply ("IH" with "[] H"); auto.
-Qed.
-
-Lemma fupd_wp s E e Φ : (|={E}=> WP e @ s; E {{ Φ }}) ⊢ WP e @ s; E {{ Φ }}.
-Proof.
- rewrite wp_unfold /wp_pre. iIntros "H". destruct (to_val e) as [v|] eqn:?.
- { by iMod "H". }
- iIntros (σ1 κ κs n) "Hσ1". iMod "H". by iApply "H".
-Qed.
-Lemma wp_fupd s E e Φ : WP e @ s; E {{ v, |={E}=> Φ v }} ⊢ WP e @ s; E {{ Φ }}.
-Proof. iIntros "H". iApply (wp_strong_mono s s E with "H"); auto. Qed.
-
-
-Lemma wp_atomic E1 E2 e s Φ `{!Atomic StronglyAtomic e} :
- (|={E1,E2}=> WP e @ s; E2 {{ v, |={E2,E1}=> Φ v }}) ⊢ WP e @ s; E1 {{ Φ }}.
-Proof.
- iIntros "H". rewrite !wp_unfold /wp_pre.
- destruct (to_val e) as [v|] eqn:He.
- { by iDestruct "H" as ">>> $". }
- iIntros (σ1 κ κs n) "Hσ". iMod "H".
- iMod ("H" $! σ1 with "Hσ") as "[$ H]".
- iIntros (e2 σ2 efs Hstep). iSpecialize ("H" with "[//]"). iMod "H". iModIntro. iNext.
- iMod "H" as "(Hσ & H & Hefs)".
- + rewrite wp_unfold /wp_pre. destruct (to_val e2) as [v2|] eqn:He2.
- * rewrite wp_unfold /wp_pre He2. iDestruct "H" as ">> $". by iFrame.
- * specialize (atomic _ _ _ _ _ Hstep) as []; congruence.
-Qed.
-
-
-Local Existing Instance elim_gstepN.
-Lemma swp_strong_mono k1 k2 s1 s2 E1 E2 e Φ Ψ :
- s1 ⊑ s2 → E1 ⊆ E2 → k1 ≤ k2 →
- SWP e at k1 @ s1; E1 {{ Φ }} -∗ (∀ v, Φ v ={E2}=∗ Ψ v) -∗ SWP e at k2 @ s2; E2 {{ Ψ }}.
-Proof.
- iIntros (? HE Hk) "H HΦ". rewrite !swp_unfold /swp_def.
- iIntros (σ1 κ κs n) "S". iMod (fupd_intro_mask' E2 E1) as "E"; eauto.
- iSpecialize ("H" with "S"). iApply (gstepN_mono _ _ _ _ _ _ Hk).
- iMod ("H") as "[? H]".
- iSplit; [by destruct s1, s2|]. iIntros (e2 σ2 efs Hstep).
- iSpecialize ("H" with "[//]"). iMod "H". iModIntro. iNext. iMod "H". iMod "E" as "_".
- iModIntro.
- iDestruct "H" as "(Hσ & H & Hefs)". iFrame "Hσ". iSplitR "Hefs".
- - iApply (wp_strong_mono with "H"); eauto.
- - iApply (big_sepL_impl with "Hefs"); iIntros "!#" (k ef _).
- iIntros "H". iApply (wp_strong_mono with "H"); eauto.
-Qed.
-
-Lemma fupd_swp k s E e Φ : (|={E}=> SWP e at k @ s; E {{ Φ }})%I ⊢ SWP e at k @ s; E {{ Φ }}.
-Proof.
- rewrite swp_unfold /swp_def. iIntros "SWP".
- iIntros (σ1 κ κs n) "S". iMod "SWP".
- iApply "SWP"; iFrame.
-Qed.
-
-Lemma swp_fupd k s E e Φ : SWP e at k @ s; E {{ v, |={E}=> Φ v}} ⊢ SWP e at k @ s; E {{ Φ }}.
-Proof. iIntros "H". iApply (swp_strong_mono k k s s E with "H"); auto. Qed.
-
-
-Lemma swp_atomic k E1 E2 e s Φ `{!Atomic StronglyAtomic e} :
- (|={E1, E2}=> SWP e at k @ s; E2 {{ v, |={E2, E1}=> Φ v}})%I ⊢ SWP e at k @ s; E1 {{ Φ }}.
-Proof.
- rewrite !swp_unfold /swp_def. iIntros "SWP". iIntros (σ1 κ κs n) "S".
- iMod "SWP". iMod ("SWP" with "S") as "[$ SWP]".
- iIntros (e2 σ2 efs Hstep). iMod ("SWP" with "[//]") as "SWP". iModIntro. iNext.
- iMod "SWP" as "($& SWP & $)". destruct (atomic _ _ _ _ _ Hstep) as [v Hv].
- rewrite !wp_unfold /wp_pre Hv. do 2 iMod "SWP". by do 2 iModIntro.
-Qed.
-
-Lemma swp_wp k s E e Φ : to_val e = None →
- SWP e at k @ s; E {{ Φ }} ⊢ WP e @ s; E {{ Φ }}%I.
-Proof.
- intros H; rewrite swp_unfold wp_unfold /swp_def /wp_pre H.
- iIntros "SWP". iIntros (σ1 κ κs n) "S".
- iApply gstepN_gstep. iMod ("SWP" with "S") as "$".
-Qed.
-
-Lemma swp_step k E e s Φ : ▷ SWP e at k @ s; E {{ Φ }} ⊢ SWP e at S k @ s; E {{ Φ }}.
-Proof.
- rewrite !swp_unfold /swp_def. iIntros "SWP". iIntros (σ1 κ κs n) "S".
- iMod (fupd_intro_mask') as "M". apply empty_subseteq.
- do 3 iModIntro. iMod "M" as "_".
- iMod ("SWP" with "S") as "$".
-Qed.
-
-
-Lemma wp_bind K `{!LanguageCtx K} s E e Φ :
- WP e @ s; E {{ v, WP K (of_val v) @ s; E {{ Φ }} }} ⊢ WP K e @ s; E {{ Φ }}.
-Proof.
- iIntros "H". iLöb as "IH" forall (E e Φ). rewrite wp_unfold /wp_pre.
- destruct (to_val e) as [v|] eqn:He.
- { apply of_to_val in He as <-. by iApply fupd_wp. }
- rewrite wp_unfold /wp_pre fill_not_val //.
- iIntros (σ1 κ κs n) "Hσ". iMod ("H" with "[$]") as "[% H]"; iSplit.
- { iPureIntro. destruct s; last done.
- unfold reducible in *. naive_solver eauto using fill_step. }
- iIntros (e2 σ2 efs Hstep).
- destruct (fill_step_inv e σ1 κ e2 σ2 efs) as (e2'&->&?); auto.
- iMod ("H" $! e2' σ2 efs with "[//]") as "H". iIntros "!> !>".
- iMod "H" as "(Hσ & H & Hefs)".
- iModIntro. iFrame "Hσ Hefs". by iApply "IH".
-Qed.
-
-Lemma swp_bind k K `{!LanguageCtx K} s E e Φ : to_val e = None →
- SWP e at k @ s; E {{ v, WP K (of_val v) @ s; E {{ Φ }} }} ⊢ SWP K e at k @ s; E {{ Φ }}.
-Proof.
- iIntros (H) "H". rewrite !swp_unfold /swp_def.
- iIntros (σ1 κ κs n) "Hσ". iMod ("H" with "[$]") as "[% H]"; iSplit.
- { iPureIntro. destruct s; last done.
- unfold reducible in *. naive_solver eauto using fill_step. }
- iIntros (e2 σ2 efs Hstep).
- destruct (fill_step_inv e σ1 κ e2 σ2 efs) as (e2'&->&?); auto.
- iMod ("H" $! e2' σ2 efs with "[//]") as "H". iIntros "!> !>".
- iMod "H" as "(Hσ & H & Hefs)".
- iModIntro. iFrame "Hσ Hefs". by iApply wp_bind.
-Qed.
-
-
-Lemma wp_bind_inv K `{!LanguageCtx K} s E e Φ :
- WP K e @ s; E {{ Φ }} ⊢ WP e @ s; E {{ v, WP K (of_val v) @ s; E {{ Φ }} }}.
-Proof.
- iIntros "H". iLöb as "IH" forall (E e Φ). rewrite !wp_unfold /wp_pre.
- destruct (to_val e) as [v|] eqn:He.
- { apply of_to_val in He as <-. by rewrite !wp_unfold /wp_pre. }
- rewrite fill_not_val //.
- iIntros (σ1 κ κs n) "Hσ". iMod ("H" with "[$]") as "[% H]"; iSplit.
- { destruct s; eauto using reducible_fill. }
- iIntros (e2 σ2 efs Hstep).
- iMod ("H" $! (K e2) σ2 efs with "[]") as "H"; [by eauto using fill_step|].
- iIntros "!> !>". iMod "H" as "(Hσ & H & Hefs)".
- iModIntro. iFrame "Hσ Hefs". by iApply "IH".
-Qed.
-
-Lemma swp_bind_inv K `{!LanguageCtx K} k s E e Φ : to_val e = None →
- SWP K e at k @ s; E {{ Φ }} ⊢ SWP e at k @ s; E {{ v, WP K (of_val v) @ s; E {{ Φ }} }}.
-Proof.
- iIntros (H) "H". rewrite !swp_unfold /swp_def.
- iIntros (σ1 κ κs n) "Hσ". iMod ("H" with "[$]") as "[% H]"; iSplit.
- { destruct s; eauto using reducible_fill. }
- iIntros (e2 σ2 efs Hstep).
- iMod ("H" $! (K e2) σ2 efs with "[]") as "H"; [by eauto using fill_step|].
- iIntros "!> !>". iMod "H" as "(Hσ & H & Hefs)".
- iModIntro. iFrame "Hσ Hefs". by iApply wp_bind_inv.
-Qed.
-
-(** * Derived rules *)
-Lemma wp_mono s E e Φ Ψ : (∀ v, Φ v ⊢ Ψ v) → WP e @ s; E {{ Φ }} ⊢ WP e @ s; E {{ Ψ }}.
-Proof.
- iIntros (HΦ) "H"; iApply (wp_strong_mono with "H"); auto.
- iIntros (v) "?". by iApply HΦ.
-Qed.
-Lemma wp_stuck_mono s1 s2 E e Φ :
- s1 ⊑ s2 → WP e @ s1; E {{ Φ }} ⊢ WP e @ s2; E {{ Φ }}.
-Proof. iIntros (?) "H". iApply (wp_strong_mono with "H"); auto. Qed.
-Lemma wp_stuck_weaken s E e Φ :
- WP e @ s; E {{ Φ }} ⊢ WP e @ E ?{{ Φ }}.
-Proof. apply wp_stuck_mono. by destruct s. Qed.
-Lemma wp_mask_mono s E1 E2 e Φ : E1 ⊆ E2 → WP e @ s; E1 {{ Φ }} ⊢ WP e @ s; E2 {{ Φ }}.
-Proof. iIntros (?) "H"; iApply (wp_strong_mono with "H"); auto. Qed.
-Global Instance wp_mono' s E e :
- Proper (pointwise_relation _ (⊢) ==> (⊢)) (wp (PROP:=iProp Σ) s E e).
-Proof. by intros Φ Φ' ?; apply wp_mono. Qed.
-
-Lemma wp_value s E Φ e v : IntoVal e v → Φ v ⊢ WP e @ s; E {{ Φ }}.
-Proof. intros <-. by apply wp_value'. Qed.
-Lemma wp_value_fupd' s E Φ v : (|={E}=> Φ v) ⊢ WP of_val v @ s; E {{ Φ }}.
-Proof. intros. by rewrite -wp_fupd -wp_value'. Qed.
-Lemma wp_value_fupd s E Φ e v `{!IntoVal e v} :
- (|={E}=> Φ v) ⊢ WP e @ s; E {{ Φ }}.
-Proof. intros. rewrite -wp_fupd -wp_value //. Qed.
-Lemma wp_value_inv s E Φ e v : IntoVal e v → WP e @ s; E {{ Φ }} ={E}=∗ Φ v.
-Proof. intros <-. by apply wp_value_inv'. Qed.
-
-Lemma wp_frame_l s E e Φ R : R ∗ WP e @ s; E {{ Φ }} ⊢ WP e @ s; E {{ v, R ∗ Φ v }}.
-Proof. iIntros "[? H]". iApply (wp_strong_mono with "H"); auto with iFrame. Qed.
-Lemma wp_frame_r s E e Φ R : WP e @ s; E {{ Φ }} ∗ R ⊢ WP e @ s; E {{ v, Φ v ∗ R }}.
-Proof. iIntros "[H ?]". iApply (wp_strong_mono with "H"); auto with iFrame. Qed.
-
-End gstep.
-
-Existing Instance elim_eventuallyN.
-Lemma wp_step_fupd s E1 E2 e P Φ :
- to_val e = None → E2 ⊆ E1 →
- (|={E1,E2}▷=> P) -∗ WP e @ s; E2 {{ v, P ={E1}=∗ Φ v }} -∗ WP e @ s; E1 {{ Φ }}.
-Proof.
- rewrite !wp_unfold /wp_pre. iIntros (-> ?) "HR H".
- iIntros (σ1 κ κs n) "Hσ". iMod "HR".
- iMod ("H" with "[$]") as ">H". iDestruct "H" as (n1) "H".
- iApply (gstepN_gstep _ _ _ (S n1)). iApply gstepN_later; first eauto. iNext.
- iModIntro. iMod "H". iMod "H" as "[$ H]". iModIntro.
- iIntros(e2 σ2 efs Hstep).
- iSpecialize ("H" $! e2 σ2 efs with "[% //]"). iMod "H". iModIntro. iNext.
- iMod "H" as "(Hσ & H & Hefs)".
- iMod "HR". iModIntro. iFrame "Hσ Hefs".
- iApply (wp_strong_mono s s E2 with "H"); [done..|].
- iIntros (v) "H". by iApply "H".
-Qed.
-
-
-Lemma wp_step_gstep s E e P Φ :
- to_val e = None →
- (>={E}=={E}=> P) -∗ WP e @ s; ∅ {{ v, P ={E}=∗ Φ v }} -∗ WP e @ s; E {{ Φ }}.
-Proof.
- rewrite !wp_unfold /wp_pre. iIntros (->) "HR H".
- iIntros (σ1 κ κs n) "Hσ". iMod "HR". iMod "HR". iDestruct "HR" as (n1) "HR".
- iMod ("H" with "[$]") as ">H". iDestruct "H" as (n2) "H".
- iApply (gstepN_gstep _ _ _ (n1 + n2)).
- iModIntro. iApply eventuallyN_compose.
- iMod "HR". iMod "H". iMod "H" as "[$ H]". iMod "HR".
- iMod (fupd_intro_mask' _ ∅) as "Hcnt"; first set_solver.
- iModIntro. iIntros(e2 σ2 efs Hstep).
- iSpecialize ("H" $! e2 σ2 efs with "[% //]"). iMod "H". iModIntro. iNext.
- iMod "H" as "($ & H & $)". iMod "Hcnt". iModIntro.
- iApply (wp_strong_mono s s ∅ with "H"); [done | set_solver|].
- iIntros (v) "Hv". iApply ("Hv" with "HR").
-Qed.
-
-Lemma swp_step_fupd k s E1 E2 e P Φ :
- E2 ⊆ E1 →
- (|={E1,E2}▷=> P) -∗ SWP e at k @ s; E2 {{ v, P ={E1}=∗ Φ v }} -∗ SWP e at k @ s; E1 {{ Φ }}.
-Proof.
- rewrite !swp_unfold /swp_def. iIntros (?) "HR H".
- iIntros (σ1 κ κs n) "Hσ". iMod "HR". iMod ("H" with "[$]") as "H". iModIntro.
- iMod "H". iMod "H" as "[$ H]". iModIntro. iIntros(e2 σ2 efs Hstep).
- iSpecialize ("H" $! e2 σ2 efs with "[% //]"). iMod "H". iModIntro. iNext.
- iMod "H" as "(Hσ & H & Hefs)".
- iMod "HR". iModIntro. iFrame "Hσ Hefs".
- iApply (wp_strong_mono s s E2 with "H"); [done..|].
- iIntros (v) "H". by iApply "H".
-Qed.
-
-Lemma wp_frame_step_l s E1 E2 e Φ R :
- to_val e = None → E2 ⊆ E1 →
- (|={E1,E2}▷=> R) ∗ WP e @ s; E2 {{ Φ }} ⊢ WP e @ s; E1 {{ v, R ∗ Φ v }}.
-Proof.
- iIntros (??) "[Hu Hwp]". iApply (wp_step_fupd with "Hu"); try done.
- iApply (wp_mono with "Hwp"). by iIntros (?) "$$".
-Qed.
-Lemma wp_frame_step_r s E1 E2 e Φ R :
- to_val e = None → E2 ⊆ E1 →
- WP e @ s; E2 {{ Φ }} ∗ (|={E1,E2}▷=> R) ⊢ WP e @ s; E1 {{ v, Φ v ∗ R }}.
-Proof.
- rewrite [(WP _ @ _; _ {{ _ }} ∗ _)%I]comm; setoid_rewrite (comm _ _ R).
- apply wp_frame_step_l.
-Qed.
-Lemma wp_frame_step_l' s E e Φ R :
- to_val e = None → ▷ R ∗ WP e @ s; E {{ Φ }} ⊢ WP e @ s; E {{ v, R ∗ Φ v }}.
-Proof. iIntros (?) "[??]". iApply (wp_frame_step_l s E E); try iFrame; eauto. Qed.
-Lemma wp_frame_step_r' s E e Φ R :
- to_val e = None → WP e @ s; E {{ Φ }} ∗ ▷ R ⊢ WP e @ s; E {{ v, Φ v ∗ R }}.
-Proof. iIntros (?) "[??]". iApply (wp_frame_step_r s E E); try iFrame; eauto. Qed.
-
-Lemma wp_wand s E e Φ Ψ :
- WP e @ s; E {{ Φ }} -∗ (∀ v, Φ v -∗ Ψ v) -∗ WP e @ s; E {{ Ψ }}.
-Proof.
- iIntros "Hwp H". iApply (wp_strong_mono with "Hwp"); auto.
- iIntros (?) "?". by iApply "H".
-Qed.
-Lemma wp_wand_l s E e Φ Ψ :
- (∀ v, Φ v -∗ Ψ v) ∗ WP e @ s; E {{ Φ }} ⊢ WP e @ s; E {{ Ψ }}.
-Proof. iIntros "[H Hwp]". iApply (wp_wand with "Hwp H"). Qed.
-Lemma wp_wand_r s E e Φ Ψ :
- WP e @ s; E {{ Φ }} ∗ (∀ v, Φ v -∗ Ψ v) ⊢ WP e @ s; E {{ Ψ }}.
-Proof. iIntros "[Hwp H]". iApply (wp_wand with "Hwp H"). Qed.
-Lemma wp_frame_wand_l s E e Q Φ :
- Q ∗ WP e @ s; E {{ v, Q -∗ Φ v }} -∗ WP e @ s; E {{ Φ }}.
-Proof.
- iIntros "[HQ HWP]". iApply (wp_wand with "HWP").
- iIntros (v) "HΦ". by iApply "HΦ".
-Qed.
-
-(* we can pull out a logical step from a WP when switching to the SWP *)
-Local Existing Instance elim_fupd_step.
-Instance elim_fupd_stepN b E P Q n:
- ElimModal True b false (|={E, E}▷=>^n P)%I P (|={E, E}▷=>^n Q)%I Q.
-Proof.
- iIntros (_) "(P & HPQ)". iPoseProof (intuitionistically_if_elim with "P") as "P".
- iInduction n as [ |n] "IH"; cbn.
- - by iApply "HPQ".
- - iMod "P". fold Nat.iter. by iApply ("IH" with "HPQ").
-Qed.
-Lemma fupd_fupd_step E P n :
- (|={E}=> |={E, E}▷=>^n P)%I -∗ |={E, E}▷=>^n (|={E}=> P)%I.
-Proof.
- iIntros "H". iInduction n as [ | n] "IH"; cbn.
- iApply "H".
- iMod "H".
- iApply "IH". iMod "H". iModIntro. iApply "H".
-Qed.
-
-Lemma fupd_step_fupd E P n :
- (|={E, E}▷=>^n |={E}=> P)%I -∗ (|={E}=> |={E, E}▷=>^n P)%I .
-Proof.
- iIntros "H". iInduction n as [ | n] "IH". cbn.
- iApply "H". iApply "IH". iModIntro.
- iMod "H". iModIntro. iNext. iApply fupd_fupd_step.
- iMod "H". iApply "IH". iApply "H".
-Qed.
-
-Lemma swp_wp_lstep k2 s E e Φ : to_val e = None →
- (>={E}=={E}=> SWP e at k2 @ s ; E {{ Φ }}) ⊢ WP e @ s; E {{ Φ }}%I.
-Proof.
- intros H; rewrite wp_unfold swp_unfold /wp_pre /swp_def H.
- iIntros "WP". iIntros (σ1 κ κs n) "S".
- do 2 iMod "WP". iDestruct ("WP") as (k1) "WP".
- iApply (lstepN_lstep _ _ (k1 + (1 + k2))). iModIntro. iApply eventuallyN_compose.
- iMod ("WP"). iApply eventuallyN_compose. iMod "WP".
- iMod ("WP" with "S") as "WP".
- do 4 iModIntro. do 2 iMod "WP". iModIntro.
- iApply "WP".
-Qed.
-End wp.
-
-
-Section swp.
- Context {SI} {Σ: gFunctors SI} `{!irisG Λ Σ}.
- Implicit Types s : stuckness.
- Implicit Types P : iProp Σ.
- Implicit Types Φ : val Λ → iProp Σ.
- Implicit Types v : val Λ.
- Implicit Types e : expr Λ.
- Variable (k: nat).
-
- Lemma swp_mono s E e Φ Ψ : (∀ v, Φ v ⊢ Ψ v) → SWP e at k @ s; E {{ Φ }} ⊢ SWP e at k @ s; E {{ Ψ }}.
- Proof.
- iIntros (HΦ) "H"; iApply (swp_strong_mono with "H"); auto.
- iIntros (v) "?". by iApply HΦ.
- Qed.
- Lemma swp_stuck_mono s1 s2 E e Φ :
- s1 ⊑ s2 → SWP e at k @ s1; E {{ Φ }} ⊢ SWP e at k @ s2; E {{ Φ }}.
- Proof. iIntros (?) "H". iApply (swp_strong_mono with "H"); auto. Qed.
- Lemma swp_stuck_weaken s E e Φ :
- SWP e at k @ s; E {{ Φ }} ⊢ SWP e at k @ E ?{{ Φ }}.
- Proof. apply swp_stuck_mono. by destruct s. Qed.
- Lemma swp_mask_mono s E1 E2 e Φ : E1 ⊆ E2 → SWP e at k @ s; E1 {{ Φ }} ⊢ SWP e at k @ s; E2 {{ Φ }}.
- Proof. iIntros (?) "H"; iApply (swp_strong_mono with "H"); auto. Qed.
- Global Instance swp_mono' s E e :
- Proper (pointwise_relation _ (⊢) ==> (⊢)) (swp (PROP:=iProp Σ) k s E e).
- Proof. by intros Φ Φ' ?; apply swp_mono. Qed.
-
- Lemma swp_frame_l s E e Φ R : R ∗ SWP e at k @ s; E {{ Φ }} ⊢ SWP e at k @ s; E {{ v, R ∗ Φ v }}.
- Proof. iIntros "[? H]". iApply (swp_strong_mono with "H"); auto with iFrame. Qed.
- Lemma swp_frame_r s E e Φ R : SWP e at k @ s; E {{ Φ }} ∗ R ⊢ SWP e at k @ s; E {{ v, Φ v ∗ R }}.
- Proof. iIntros "[H ?]". iApply (swp_strong_mono with "H"); auto with iFrame. Qed.
-
- Lemma swp_frame_step_l s E1 E2 e Φ R :
- to_val e = None → E2 ⊆ E1 →
- (|={E1,E2}▷=> R) ∗ SWP e at k @ s; E2 {{ Φ }} ⊢ SWP e at k @ s; E1 {{ v, R ∗ Φ v }}.
- Proof.
- iIntros (??) "[Hu Hwp]". iApply (swp_step_fupd with "Hu"); try done.
- iApply (swp_mono with "Hwp"). by iIntros (?) "$$".
- Qed.
- Lemma swp_frame_step_r s E1 E2 e Φ R :
- to_val e = None → E2 ⊆ E1 →
- SWP e at k @ s; E2 {{ Φ }} ∗ (|={E1,E2}▷=> R) ⊢ SWP e at k @ s; E1 {{ v, Φ v ∗ R }}.
- Proof.
- rewrite [(WP _ @ _; _ {{ _ }} ∗ _)%I]comm; setoid_rewrite (comm _ _ R).
- apply swp_frame_step_l.
- Qed.
- Lemma swp_frame_step_l' s E e Φ R :
- to_val e = None → ▷ R ∗ SWP e at k @ s; E {{ Φ }} ⊢ SWP e at k @ s; E {{ v, R ∗ Φ v }}.
- Proof. iIntros (?) "[??]". iApply (swp_frame_step_l s E E); try iFrame; eauto. Qed.
- Lemma swp_frame_step_r' s E e Φ R :
- to_val e = None → SWP e at k @ s; E {{ Φ }} ∗ ▷ R ⊢ SWP e at k @ s; E {{ v, Φ v ∗ R }}.
- Proof. iIntros (?) "[??]". iApply (swp_frame_step_r s E E); try iFrame; eauto. Qed.
-
- Lemma swp_wand s E e Φ Ψ :
- SWP e at k @ s; E {{ Φ }} -∗ (∀ v, Φ v -∗ Ψ v) -∗ SWP e at k @ s; E {{ Ψ }}.
- Proof.
- iIntros "Hwp H". iApply (swp_strong_mono with "Hwp"); auto.
- iIntros (?) "?". by iApply "H".
- Qed.
- Lemma swp_wand_l s E e Φ Ψ :
- (∀ v, Φ v -∗ Ψ v) ∗ SWP e at k @ s; E {{ Φ }} ⊢ SWP e at k @ s; E {{ Ψ }}.
- Proof. iIntros "[H Hwp]". iApply (swp_wand with "Hwp H"). Qed.
- Lemma swp_wand_r s E e Φ Ψ :
- SWP e at k @ s; E {{ Φ }} ∗ (∀ v, Φ v -∗ Ψ v) ⊢ SWP e at k @ s; E {{ Ψ }}.
- Proof. iIntros "[Hwp H]". iApply (swp_wand with "Hwp H"). Qed.
- Lemma swp_frame_wand_l s E e Q Φ :
- Q ∗ SWP e at k @ s; E {{ v, Q -∗ Φ v }} -∗ SWP e at k @ s; E {{ Φ }}.
- Proof.
- iIntros "[HQ HWP]". iApply (swp_wand with "HWP").
- iIntros (v) "HΦ". by iApply "HΦ".
- Qed.
-
- Lemma swp_finish E e s Φ : SWP e at 0%nat @ s; E {{ Φ }} ⊢ SWP e at 0%nat @ s; E {{ Φ }}.
- Proof. eauto. Qed.
-End swp.
-
-(** Proofmode class instances *)
-Section proofmode_classes.
- Context {SI} {Σ: gFunctors SI} `{!irisG Λ Σ}.
- Implicit Types P Q : iProp Σ.
- Implicit Types Φ : val Λ → iProp Σ.
-
- Global Instance frame_wp p s E e R Φ Ψ :
- (∀ v, Frame p R (Φ v) (Ψ v)) →
- Frame p R (WP e @ s; E {{ Φ }}) (WP e @ s; E {{ Ψ }}).
- Proof. rewrite /Frame=> HR. rewrite wp_frame_l. apply wp_mono, HR. Qed.
-
- Global Instance frame_swp k p s E e R Φ Ψ :
- (∀ v, Frame p R (Φ v) (Ψ v)) →
- Frame p R (SWP e at k @ s; E {{ Φ }}) (SWP e at k @ s; E {{ Ψ }}).
- Proof. rewrite /Frame=> HR. rewrite swp_frame_l. apply swp_mono, HR. Qed.
-
- Global Instance is_except_0_wp s E e Φ : IsExcept0 (WP e @ s; E {{ Φ }}).
- Proof. by rewrite /IsExcept0 -{2}fupd_wp -except_0_fupd -fupd_intro. Qed.
-
- Global Instance is_except_0_swp k s E e Φ : IsExcept0 (SWP e at k @ s; E {{ Φ }}).
- Proof. by rewrite /IsExcept0 -{2}fupd_swp -except_0_fupd -fupd_intro. Qed.
-
- Global Instance elim_modal_bupd_wp p s E e P Φ :
- ElimModal True p false (|==> P) P (WP e @ s; E {{ Φ }}) (WP e @ s; E {{ Φ }}).
- Proof.
- by rewrite /ElimModal intuitionistically_if_elim
- (bupd_fupd E) fupd_frame_r wand_elim_r fupd_wp.
- Qed.
-
- Global Instance elim_modal_bupd_swp k p s E e P Φ :
- ElimModal True p false (|==> P) P (SWP e at k @ s; E {{ Φ }}) (SWP e at k @ s; E {{ Φ }}).
- Proof.
- by rewrite /ElimModal intuitionistically_if_elim
- (bupd_fupd E) fupd_frame_r wand_elim_r fupd_swp.
- Qed.
-
- Global Instance elim_modal_fupd_wp p s E e P Φ :
- ElimModal True p false (|={E}=> P) P (WP e @ s; E {{ Φ }}) (WP e @ s; E {{ Φ }}).
- Proof.
- by rewrite /ElimModal intuitionistically_if_elim
- fupd_frame_r wand_elim_r fupd_wp.
- Qed.
-
- Global Instance elim_modal_fupd_swp k p s E e P Φ :
- ElimModal True p false (|={E}=> P) P (SWP e at k @ s; E {{ Φ }}) (SWP e at k @ s; E {{ Φ }}).
- Proof.
- by rewrite /ElimModal intuitionistically_if_elim
- fupd_frame_r wand_elim_r fupd_swp.
- Qed.
-
- Global Instance elim_modal_fupd_wp_atomic s p E1 E2 e P Φ :
- Atomic StronglyAtomic e →
- ElimModal True p false (|={E1,E2}=> P) P
- (WP e @ s; E1 {{ Φ }}) (WP e @ s; E2 {{ v, |={E2,E1}=> Φ v }})%I.
- Proof.
- intros. by rewrite /ElimModal intuitionistically_if_elim
- fupd_frame_r wand_elim_r wp_atomic.
- Qed.
-
- Global Instance elim_modal_fupd_swp_atomic k s p E1 E2 e P Φ :
- Atomic StronglyAtomic e →
- ElimModal True p false (|={E1,E2}=> P) P
- (SWP e at k @ s; E1 {{ Φ }}) (SWP e at k @ s; E2 {{ v, |={E2,E1}=> Φ v }})%I.
- Proof.
- intros. by rewrite /ElimModal intuitionistically_if_elim
- fupd_frame_r wand_elim_r swp_atomic.
- Qed.
-
-
- Global Instance add_modal_fupd_wp s E e P Φ :
- AddModal (|={E}=> P) P (WP e @ s; E {{ Φ }}).
- Proof. by rewrite /AddModal fupd_frame_r wand_elim_r fupd_wp. Qed.
-
- Global Instance add_modal_fupd_swp k s E e P Φ :
- AddModal (|={E}=> P) P (SWP e at k @ s; E {{ Φ }}).
- Proof. by rewrite /AddModal fupd_frame_r wand_elim_r fupd_swp. Qed.
-
-
- Global Instance elim_acc_wp {X} s E1 E2 α β γ e Φ :
- Atomic StronglyAtomic e →
- ElimAcc (X:=X) (fupd E1 E2) (fupd E2 E1)
- α β γ (WP e @ s; E1 {{ Φ }})
- (λ x, WP e @ s; E2 {{ v, |={E2}=> β x ∗ (γ x -∗? Φ v) }})%I.
- Proof.
- intros ?. rewrite /ElimAcc.
- iIntros "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]".
- iApply (wp_wand with "(Hinner Hα)").
- iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose".
- Qed.
-
- Global Instance elim_acc_swp {X} k s E1 E2 α β γ e Φ :
- Atomic StronglyAtomic e →
- ElimAcc (X:=X) (fupd E1 E2) (fupd E2 E1)
- α β γ (SWP e at k @ s; E1 {{ Φ }})
- (λ x, SWP e at k @ s; E2 {{ v, |={E2}=> β x ∗ (γ x -∗? Φ v) }})%I.
- Proof.
- intros ?. rewrite /ElimAcc.
- iIntros "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]".
- iApply (swp_wand with "(Hinner Hα)").
- iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose".
- Qed.
-
- Global Instance elim_acc_wp_nonatomic {X} E α β γ e s Φ :
- ElimAcc (X:=X) (fupd E E) (fupd E E)
- α β γ (WP e @ s; E {{ Φ }})
- (λ x, WP e @ s; E {{ v, |={E}=> β x ∗ (γ x -∗? Φ v) }})%I.
- Proof.
- rewrite /ElimAcc.
- iIntros "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]".
- iApply wp_fupd.
- iApply (wp_wand with "(Hinner Hα)").
- iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose".
- Qed.
-
- Global Instance elim_acc_swp_nonatomic {X} k E α β γ e s Φ :
- ElimAcc (X:=X) (fupd E E) (fupd E E)
- α β γ (SWP e at k @ s; E {{ Φ }})
- (λ x, SWP e at k @ s; E {{ v, |={E}=> β x ∗ (γ x -∗? Φ v) }})%I.
- Proof.
- rewrite /ElimAcc.
- iIntros "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]".
- iApply swp_fupd.
- iApply (swp_wand with "(Hinner Hα)").
- iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose".
- Qed.
-End proofmode_classes.
-
--
GitLab