Commit 3dd3c5c7 authored by Ralf Jung's avatar Ralf Jung

Merge branch 'v2.0' of gitlab.mpi-sws.org:FP/iris-coq into v2.0

parents bb499fdd b91562fe
......@@ -64,6 +64,7 @@ iris/language.v
iris/functor.v
iris/tests.v
barrier/heap_lang.v
barrier/heap_lang_tactics.v
barrier/lifting.v
barrier/sugar.v
barrier/tests.v
This diff is collapsed.
Require Export barrier.heap_lang.
Require Import prelude.fin_maps.
Import heap_lang.
Ltac inv_step :=
repeat match goal with
| _ => progress simplify_map_equality' (* simplify memory stuff *)
| H : to_val _ = Some _ |- _ => apply of_to_val in H
| H : context [to_val (of_val _)] |- _ => rewrite to_of_val in H
| H : prim_step _ _ _ _ _ |- _ => destruct H; subst
| H : _ = fill ?K ?e |- _ =>
destruct K as [|[]];
simpl in H; first [subst e|discriminate H|injection' H]
(* ensure that we make progress for each subgoal *)
| H : head_step ?e _ _ _ _, Hv : of_val ?v = fill ?K ?e |- _ =>
apply values_head_stuck, (fill_not_val K) in H;
by rewrite -Hv to_of_val in H (* maybe use a helper lemma here? *)
| 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.
Ltac reshape_expr e tac :=
let rec go K e :=
match e with
| _ => tac (reverse K) e
| App ?e1 ?e2 =>
lazymatch e1 with
| of_val ?v1 => go (AppRCtx v1 :: K) e2 | _ => go (AppLCtx e2 :: K) e1
end
| Plus ?e1 ?e2 =>
lazymatch e1 with
| of_val ?v1 => go (PlusRCtx v1 :: K) e2 | _ => go (PlusLCtx e2 :: K) e1
end
| Le ?e1 ?e2 =>
lazymatch e1 with
| of_val ?v1 => go (LeRCtx v1 :: K) e2 | _ => go (LeLCtx e2 :: K) e1
end
| Pair ?e1 ?e2 =>
lazymatch e1 with
| of_val ?v1 => go (PairRCtx v1 :: K) e2 | _ => go (PairLCtx e2 :: K) e1
end
| Fst ?e => go (FstCtx :: K) e
| Snd ?e => go (SndCtx :: K) e
| InjL ?e => go (InjLCtx :: K) e
| InjR ?e => go (InjRCtx :: K) e
| Case ?e0 ?e1 ?e2 => go (CaseCtx e1 e2 :: K) e0
| Alloc ?e => go (AllocCtx :: K) e
| Load ?e => go (LoadCtx :: K) e
| Store ?e1 ?e2 => go (StoreLCtx e2 :: K) e1 || go (StoreRCtx e1 :: K) e2
| Cas ?e0 ?e1 ?e2 =>
lazymatch e0 with
| of_val ?v0 =>
lazymatch e1 with
| of_val ?v1 => go (CasRCtx v0 v1 :: K) e2
| _ => go (CasMCtx v0 e2 :: K) e1
end
| _ => go (CasLCtx e1 e2 :: K) e0
end
end in go (@nil ectx_item) e.
Ltac do_step tac :=
try match goal with |- reducible _ _ => eexists _, _, _ end;
simpl;
match goal with
| |- prim_step ?e1 ?σ1 ?e2 ?σ2 ?ef =>
reshape_expr e1 ltac:(fun K e1' =>
eapply Ectx_step with K e1' _); [reflexivity|reflexivity|];
first [apply alloc_fresh|econstructor];
rewrite ?to_of_val; tac; fail
end.
This diff is collapsed.
Require Export barrier.heap_lang barrier.lifting.
Import uPred.
Import heap_lang.
(** Define some syntactic sugar. LitTrue and LitFalse are defined in heap_lang.v. *)
Definition Lam (e : {bind expr}) := Rec e.[ren(+1)].
......@@ -13,67 +14,52 @@ Definition Eq e1 e2 :=
Definition LamV (e : {bind expr}) := RecV e.[ren(+1)].
Definition LetCtx (K1 : ectx) (e2 : {bind expr}) := AppRCtx (LamV e2) K1.
Definition SeqCtx (K1 : ectx) (e2 : expr) := LetCtx K1 (e2.[ren(+1)]).
Definition LetCtx (e2 : {bind expr}) := AppRCtx (LamV e2).
Definition SeqCtx (e2 : expr) := LetCtx (e2.[ren(+1)]).
Section suger.
Context {Σ : iFunctor}.
Implicit Types P : iProp heap_lang Σ.
Implicit Types Q : val heap_lang iProp heap_lang Σ.
Implicit Types Q : val iProp heap_lang Σ.
(** Proof rules for the sugar *)
Lemma wp_lam E ef e v Q :
e2v e = Some v wp E ef.[e/] Q wp E (App (Lam ef) e) Q.
to_val e = Some v wp E ef.[e/] Q wp E (App (Lam ef) e) Q.
Proof.
intros Hv. rewrite -wp_rec; last eassumption.
(* RJ: This pulls in functional extensionality. If that bothers us, we have
to talk to the Autosubst guys. *)
by asimpl.
Qed.
Lemma wp_let e1 e2 E Q :
wp E e1 (λ v, wp E (e2.[v2e v/]) Q) wp E (Let e1 e2) Q.
Lemma wp_let E e1 e2 Q :
wp E e1 (λ v, wp E (e2.[of_val v/]) Q) wp E (Let e1 e2) Q.
Proof.
rewrite -(wp_bind (LetCtx EmptyCtx e2)). apply wp_mono=>v.
rewrite -wp_lam //. by rewrite v2v.
rewrite -(wp_bind [LetCtx e2]). apply wp_mono=>v.
by rewrite -wp_lam //= to_of_val.
Qed.
Lemma wp_if_true e1 e2 E Q :
wp E e1 Q wp E (If LitTrue e1 e2) Q.
Proof.
rewrite -wp_case_inl //. by asimpl.
Qed.
Lemma wp_if_false e1 e2 E Q :
wp E e2 Q wp E (If LitFalse e1 e2) Q.
Proof.
rewrite -wp_case_inr //. by asimpl.
Qed.
Lemma wp_lt n1 n2 E P Q :
(n1 < n2 P Q LitTrueV)
(n1 n2 P Q LitFalseV)
Lemma wp_if_true E e1 e2 Q : wp E e1 Q wp E (If LitTrue e1 e2) Q.
Proof. rewrite -wp_case_inl //. by asimpl. Qed.
Lemma wp_if_false E e1 e2 Q : wp E e2 Q wp E (If LitFalse e1 e2) Q.
Proof. rewrite -wp_case_inr //. by asimpl. Qed.
Lemma wp_lt E n1 n2 P Q :
(n1 < n2 P Q LitTrueV)
(n1 n2 P Q LitFalseV)
P wp E (Lt (LitNat n1) (LitNat n2)) Q.
Proof.
intros HPlt HPge.
rewrite -(wp_bind (LeLCtx EmptyCtx _)) -wp_plus -later_intro. simpl.
apply wp_le; intros; [apply HPlt|apply HPge]; omega.
intros; rewrite -(wp_bind [LeLCtx _]) -wp_plus -later_intro /=.
auto using wp_le with lia.
Qed.
Lemma wp_eq n1 n2 E P Q :
(n1 = n2 P Q LitTrueV)
(n1 n2 P Q LitFalseV)
Lemma wp_eq E n1 n2 P Q :
(n1 = n2 P Q LitTrueV)
(n1 n2 P Q LitFalseV)
P wp E (Eq (LitNat n1) (LitNat n2)) Q.
Proof.
intros HPeq HPne.
rewrite -wp_let -wp_value' // -later_intro. asimpl.
rewrite -wp_rec //. asimpl.
rewrite -(wp_bind (CaseCtx EmptyCtx _ _)) -later_intro.
apply wp_le; intros Hn12.
- asimpl. rewrite -wp_case_inl // -!later_intro. apply wp_le; intros Hn12'.
+ apply HPeq; omega.
+ apply HPne; omega.
- asimpl. rewrite -wp_case_inr // -later_intro -wp_value' //.
apply HPne; omega.
rewrite -wp_let -wp_value' // -later_intro; asimpl.
rewrite -wp_rec //; asimpl.
rewrite -(wp_bind [CaseCtx _ _]) -later_intro; asimpl.
apply wp_le; intros; asimpl.
* rewrite -wp_case_inl // -!later_intro. apply wp_le; auto with lia.
* rewrite -wp_case_inr // -later_intro -wp_value' //; auto with lia.
Qed.
End suger.
(** This file is essentially a bunch of testcases. *)
Require Import modures.logic.
Require Import barrier.lifting barrier.sugar.
Import heap_lang.
Import uPred.
Module LangTests.
Definition add := Plus (LitNat 21) (LitNat 21).
Definition add := Plus (LitNat 21) (LitNat 21).
Goal σ, prim_step add σ (LitNat 42) σ None.
Proof.
constructor.
Qed.
Proof. intros; do_step done. Qed.
Definition rec := Rec (App (Var 0) (Var 1)). (* fix f x => f x *)
Definition rec_app := App rec (LitNat 0).
Goal σ, prim_step rec_app σ rec_app σ None.
Proof.
move=>?. eapply BetaS.
reflexivity.
Qed.
Proof. intros; do_step done. Qed.
Definition lam := Lam (Plus (Var 0) (LitNat 21)).
Goal σ, prim_step (App lam (LitNat 21)) σ add σ None.
Proof.
move=>?. eapply BetaS. reflexivity.
Qed.
Proof. intros; do_step done. Qed.
End LangTests.
Module LiftingTests.
Context {Σ : iFunctor}.
Implicit Types P : iProp heap_lang Σ.
Implicit Types Q : val heap_lang iProp heap_lang Σ.
Implicit Types Q : val iProp heap_lang Σ.
(* TODO RJ: Some syntactic sugar for language expressions would be nice. *)
Definition e3 := Load (Var 0).
......@@ -42,26 +34,24 @@ Module LiftingTests.
rewrite -later_intro. apply forall_intro=>l.
apply wand_intro_l. rewrite right_id. apply const_elim_l; move=>_.
rewrite -later_intro. asimpl.
rewrite -(wp_bind (SeqCtx EmptyCtx (Load (Loc _)))).
rewrite -(wp_bind (StoreRCtx (LocV _) EmptyCtx)).
rewrite -(wp_bind (PlusLCtx EmptyCtx _)).
rewrite -(wp_bind [SeqCtx (Load (Loc _))]).
rewrite -(wp_bind [StoreRCtx (LocV _)]).
rewrite -(wp_bind [PlusLCtx _]).
rewrite -wp_load_pst; first (apply sep_intro_True_r; first done); last first.
{ apply: lookup_insert. } (* RJ TODO: figure out why apply and eapply fail. *)
{ by rewrite lookup_insert. } (* RJ TODO: figure out why apply and eapply fail. *)
rewrite -later_intro. apply wand_intro_l. rewrite right_id.
rewrite -wp_plus -later_intro.
rewrite -wp_store_pst; first (apply sep_intro_True_r; first done); last first.
{ apply: lookup_insert. }
{ reflexivity. }
{ by rewrite lookup_insert. }
{ done. }
rewrite -later_intro. apply wand_intro_l. rewrite right_id.
rewrite -wp_lam // -later_intro. asimpl.
rewrite -wp_load_pst; first (apply sep_intro_True_r; first done); last first.
{ apply: lookup_insert. }
{ by rewrite lookup_insert. }
rewrite -later_intro. apply wand_intro_l. rewrite right_id.
by apply const_intro.
Qed.
Import Nat.
Definition FindPred' n1 Sn1 n2 f := If (Lt Sn1 n2)
(App f Sn1)
n1.
......@@ -83,12 +73,12 @@ Module LiftingTests.
{ apply and_mono; first done. by rewrite -later_intro. }
apply later_mono.
(* Go on. *)
rewrite -(wp_let _ (FindPred' (LitNat n1) (Var 0) (LitNat n2) (FindPred $ LitNat n2))).
rewrite -(wp_let _ _ (FindPred' (LitNat n1) (Var 0) (LitNat n2) (FindPred $ LitNat n2))).
rewrite -wp_plus. asimpl.
rewrite -(wp_bind (CaseCtx EmptyCtx _ _)).
rewrite -!later_intro. simpl.
rewrite -(wp_bind [CaseCtx _ _]).
rewrite -!later_intro /=.
apply wp_lt; intros Hn12.
- (* TODO RJ: It would be better if we could use wp_if_true here
* (* TODO RJ: It would be better if we could use wp_if_true here
(and below). But we cannot, because the substitutions in there
got already unfolded. *)
rewrite -wp_case_inl //.
......@@ -97,30 +87,29 @@ Module LiftingTests.
eapply impl_elim; first by eapply and_elim_l. apply and_intro.
+ apply const_intro; omega.
+ by rewrite !and_elim_r.
- rewrite -wp_case_inr //.
* rewrite -wp_case_inr //.
rewrite -!later_intro -wp_value' //.
rewrite and_elim_r. apply const_elim_l=>Hle.
assert (Heq: n1 = pred n2) by omega. by subst n1.
by replace n1 with (pred n2) by lia.
Qed.
Lemma Pred_spec n E Q :
Q (LitNatV $ pred n) wp E (App Pred (LitNat n)) Q.
Proof.
rewrite -wp_lam //. asimpl.
rewrite -(wp_bind (CaseCtx EmptyCtx _ _)).
apply later_mono, wp_le; intros Hn.
rewrite -(wp_bind [CaseCtx _ _]).
apply later_mono, wp_le=> Hn.
- rewrite -wp_case_inl //.
rewrite -!later_intro -wp_value' //.
assert (Heq: n = 0) by omega. by subst n.
by replace n with 0 by lia.
- rewrite -wp_case_inr //.
rewrite -!later_intro -FindPred_spec. apply and_intro.
+ by apply const_intro; omega.
+ done.
rewrite -!later_intro -FindPred_spec.
auto using and_intro, const_intro with lia.
Qed.
Goal E,
(True : iProp heap_lang Σ)
wp E (Let (App Pred (LitNat 42)) (App Pred (Var 0))) (λ v, (v = LitNatV 40)).
True wp (Σ:=Σ) E
(Let (App Pred (LitNat 42)) (App Pred (Var 0))) (λ v, (v = LitNatV 40)).
Proof.
intros E. rewrite -wp_let. rewrite -Pred_spec -!later_intro.
asimpl. (* TODO RJ: Can we somehow make it so that Pred gets folded again? *)
......
......@@ -57,9 +57,9 @@ Proof.
rewrite -(wp_atomic E1 E2) //; apply pvs_mono, wp_mono=> v.
rewrite (forall_elim v) pvs_impl_r -(pvs_intro E1) pvs_trans; solve_elem_of.
Qed.
Lemma ht_bind `(HK : is_ctx K) E P Q Q' e :
({{ P }} e @ E {{ Q }} v, {{ Q v }} K (of_val v) @ E {{ Q' }})
{{ P }} K e @ E {{ Q' }}.
Lemma ht_bind `{CtxLanguage Λ C} K E P Q Q' e :
({{ P }} e @ E {{ Q }} v, {{ Q v }} fill K (of_val v) @ E {{ Q' }})
{{ P }} fill K e @ E {{ Q' }}.
Proof.
intros; apply (always_intro' _ _), impl_intro_l.
rewrite (associative _ P) {1}/ht always_elim impl_elim_r.
......
......@@ -55,7 +55,7 @@ Proof.
rewrite -(ht_lift_step E E φ' _ P
(λ e2 σ2 ef, ownP σ2 (φ' e2 σ2 ef))%I
(λ e2 σ2 ef, φ e2 σ2 ef P)%I);
try by (rewrite /φ'; eauto using atomic_not_value, atomic_step).
try by (rewrite /φ'; eauto using atomic_not_val, atomic_step).
apply and_intro; [by rewrite -vs_reflexive; apply const_intro|].
apply forall_mono=>e2; apply forall_mono=>σ2; apply forall_mono=>ef.
apply and_intro; [|apply and_intro; [|done]].
......
......@@ -11,7 +11,7 @@ Structure language := Language {
to_of_val v : to_val (of_val v) = Some v;
of_to_val e v : to_val e = Some v of_val v = e;
values_stuck e σ e' σ' ef : prim_step e σ e' σ' ef to_val e = None;
atomic_not_value e : atomic e to_val e = None;
atomic_not_val e : atomic e to_val e = None;
atomic_step e1 σ1 e2 σ2 ef :
atomic e1
prim_step e1 σ1 e2 σ2 ef
......@@ -24,7 +24,7 @@ Arguments prim_step {_} _ _ _ _ _.
Arguments to_of_val {_} _.
Arguments of_to_val {_} _ _ _.
Arguments values_stuck {_} _ _ _ _ _ _.
Arguments atomic_not_value {_} _ _.
Arguments atomic_not_val {_} _ _.
Arguments atomic_step {_} _ _ _ _ _ _ _.
Canonical Structure istateC Σ := leibnizC (state Σ).
......@@ -47,19 +47,22 @@ Section language.
Lemma reducible_not_val e σ : reducible e σ to_val e = None.
Proof. intros (?&?&?&?); eauto using values_stuck. Qed.
Lemma atomic_of_val v : ¬atomic (of_val v).
Proof.
by intros Hat; apply atomic_not_value in Hat; rewrite to_of_val in Hat.
Qed.
Proof. by intros Hat%atomic_not_val; rewrite to_of_val in Hat. Qed.
Global Instance: Injective (=) (=) (@of_val Λ).
Proof. by intros v v' Hv; apply (injective Some); rewrite -!to_of_val Hv. Qed.
Record is_ctx (K : expr Λ expr Λ) := IsCtx {
is_ctx_value e : to_val e = None to_val (K e) = None;
is_ctx_step_preserved e1 σ1 e2 σ2 ef :
prim_step e1 σ1 e2 σ2 ef prim_step (K e1) σ1 (K e2) σ2 ef;
is_ctx_step e1' σ1 e2 σ2 ef :
to_val e1' = None prim_step (K e1') σ1 e2 σ2 ef
e2', e2 = K e2' prim_step e1' σ1 e2' σ2 ef
}.
End language.
Class Fill C E := fill : C E E.
Instance: Params (@fill) 3.
Arguments fill {_ _ _} !_ _ / : simpl nomatch.
Class CtxLanguage (Λ : language) (C : Type) `{Fill C (expr Λ)} := {
fill_not_val K e :
to_val e = None to_val (fill K e) = None;
fill_step K e1 σ1 e2 σ2 ef :
prim_step e1 σ1 e2 σ2 ef
prim_step (fill K e1) σ1 (fill K e2) σ2 ef;
fill_step_inv K e1' σ1 e2 σ2 ef :
to_val e1' = None prim_step (fill K e1') σ1 e2 σ2 ef
e2', e2 = fill K e2' prim_step e1' σ1 e2' σ2 ef
}.
......@@ -117,7 +117,7 @@ Qed.
Lemma wp_atomic E1 E2 e Q :
E2 E1 atomic e pvs E1 E2 (wp E2 e (λ v, pvs E2 E1 (Q v))) wp E1 e Q.
Proof.
intros ? He r n ? Hvs; constructor; eauto using atomic_not_value.
intros ? He r n ? Hvs; constructor; eauto using atomic_not_val.
intros rf k Ef σ1 ???.
destruct (Hvs rf (S k) Ef σ1) as (r'&Hwp&?); auto.
inversion Hwp as [|???? Hgo]; subst; [by destruct (atomic_of_val v)|].
......@@ -161,17 +161,17 @@ Proof.
* apply wp_frame_r; [auto|exists r2, rR; split_ands; auto].
eapply uPred_weaken with rR n; eauto.
Qed.
Lemma wp_bind `(HK : is_ctx K) E e Q :
wp E e (λ v, wp E (K (of_val v)) Q) wp E (K e) Q.
Lemma wp_bind `{CtxLanguage Λ C} E K e Q :
wp E e (λ v, wp E (fill K (of_val v)) Q) wp E (fill K e) Q.
Proof.
intros r n; revert e r; induction n as [n IH] using lt_wf_ind; intros e r ?.
destruct 1 as [|n r e ? Hgo]; [|constructor]; auto using is_ctx_value.
destruct 1 as [|n r e ? Hgo]; [|constructor]; auto using fill_not_val.
intros rf k Ef σ1 ???; destruct (Hgo rf k Ef σ1) as [Hsafe Hstep]; auto.
split.
{ destruct Hsafe as (e2&σ2&ef&?).
by exists (K e2), σ2, ef; apply is_ctx_step_preserved. }
by exists (fill K e2), σ2, ef; apply fill_step. }
intros e2 σ2 ef ?.
destruct (is_ctx_step _ HK e σ1 e2 σ2 ef) as (e2'&->&?); auto.
destruct (fill_step_inv K e σ1 e2 σ2 ef) as (e2'&->&?); auto.
destruct (Hstep e2' σ2 ef) as (r2&r2'&?&?&?); auto.
exists r2, r2'; split_ands; try eapply IH; eauto.
Qed.
......
......@@ -453,6 +453,8 @@ Lemma const_elim_l φ Q R : (φ → Q ⊑ R) → (■ φ ∧ Q) ⊑ R.
Proof. intros; apply const_elim with φ; eauto. Qed.
Lemma const_elim_r φ Q R : (φ Q R) (Q φ) R.
Proof. intros; apply const_elim with φ; eauto. Qed.
Lemma const_equiv (φ : Prop) : φ ( φ : uPred M)%I True%I.
Proof. intros; apply (anti_symmetric _); auto using const_intro. Qed.
Lemma equiv_eq {A : cofeT} P (a b : A) : a b P (a b).
Proof. intros ->; apply eq_refl. Qed.
Lemma eq_sym {A : cofeT} (a b : A) : (a b) (b a).
......@@ -524,6 +526,12 @@ Global Instance or_comm : Commutative (≡) (@uPred_or M).
Proof. intros P Q; apply (anti_symmetric ()); auto. Qed.
Global Instance or_assoc : Associative () (@uPred_or M).
Proof. intros P Q R; apply (anti_symmetric ()); auto. Qed.
Global Instance True_impl : LeftId () True%I (@uPred_impl M).
Proof.
intros P; apply (anti_symmetric ()).
* by rewrite -(left_id True%I uPred_and (_ _)%I) impl_elim_r.
* by apply impl_intro_l; rewrite left_id.
Qed.
Lemma or_and_l P Q R : (P Q R)%I ((P Q) (P R))%I.
Proof.
apply (anti_symmetric ()); first auto.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment