Commit 2d0a5475 authored by Ralf Jung's avatar Ralf Jung

state the lifting lemmas slightly differently

parent 90c6d1b9
...@@ -45,10 +45,10 @@ Qed. ...@@ -45,10 +45,10 @@ Qed.
(* TODO RJ: Figure out some better way to make the (* TODO RJ: Figure out some better way to make the
postcondition a predicate over a *location* *) postcondition a predicate over a *location* *)
Lemma wp_alloc_pst E σ e v: Lemma wp_alloc_pst E σ e v Q :
e2v e = Some v e2v e = Some v
ownP (Σ:=Σ) σ wp (Σ:=Σ) E (Alloc e) (ownP (Σ:=Σ) σ ( l, (σ !! l = None) ownP (Σ:=Σ) (<[l:=v]>σ) - Q (LocV l)))
(λ v', l, (v' = LocV l σ !! l = None) ownP (Σ:=Σ) (<[l:=v]>σ)). wp (Σ:=Σ) E (Alloc e) Q.
Proof. Proof.
(* RJ FIXME (also for most other lemmas in this file): rewrite would be nicer... *) (* RJ FIXME (also for most other lemmas in this file): rewrite would be nicer... *)
intros Hvl. etransitivity; last eapply wp_lift_step with (σ1 := σ) intros Hvl. etransitivity; last eapply wp_lift_step with (σ1 := σ)
...@@ -62,21 +62,19 @@ Proof. ...@@ -62,21 +62,19 @@ Proof.
apply (not_elem_of_dom (D := gset loc)). apply is_fresh. apply (not_elem_of_dom (D := gset loc)). apply is_fresh.
- reflexivity. - reflexivity.
- reflexivity. - reflexivity.
- (* RJ FIXME I am sure there is a better way to invoke right_id, but I could not find it. *) - rewrite -pvs_intro. apply sep_mono; first done. apply later_mono.
rewrite -pvs_intro. rewrite -{1}[ownP σ](@right_id _ _ _ _ uPred.sep_True).
apply sep_mono; first done. rewrite -later_intro.
apply forall_intro=>e2. apply forall_intro=>σ2. apply forall_intro=>e2. apply forall_intro=>σ2.
apply wand_intro_l. rewrite right_id. rewrite -pvs_intro. apply wand_intro_l. rewrite -pvs_intro.
rewrite always_and_sep_l' -associative -always_and_sep_l'.
apply const_elim_l. intros [l [-> [-> Hl]]]. apply const_elim_l. intros [l [-> [-> Hl]]].
rewrite -wp_value'; last reflexivity. rewrite (forall_elim _ l). eapply const_intro_l; first eexact Hl.
erewrite <-exist_intro with (a := l). apply and_intro. rewrite always_and_sep_l' associative -always_and_sep_l' wand_elim_r.
+ by apply const_intro. rewrite -wp_value'; done.
+ done.
Qed. Qed.
Lemma wp_load_pst E σ l v: Lemma wp_load_pst E σ l v Q :
σ !! l = Some v σ !! l = Some v
ownP (Σ:=Σ) σ wp (Σ:=Σ) E (Load (Loc l)) (λ v', (v' = v) ownP (Σ:=Σ) σ). (ownP (Σ:=Σ) σ (ownP σ - Q v)) wp (Σ:=Σ) E (Load (Loc l)) Q.
Proof. Proof.
intros Hl. etransitivity; last eapply wp_lift_step with (σ1 := σ) intros Hl. etransitivity; last eapply wp_lift_step with (σ1 := σ)
(φ := λ e' σ', e' = v2e v σ' = σ); last first. (φ := λ e' σ', e' = v2e v σ' = σ); last first.
...@@ -85,21 +83,19 @@ Proof. ...@@ -85,21 +83,19 @@ Proof.
- do 3 eexists. econstructor; eassumption. - do 3 eexists. econstructor; eassumption.
- reflexivity. - reflexivity.
- reflexivity. - reflexivity.
- rewrite -pvs_intro. rewrite -{1}[ownP σ](@right_id _ _ _ _ uPred.sep_True). - rewrite -pvs_intro.
apply sep_mono; first done. rewrite -later_intro. apply sep_mono; first done. apply later_mono.
apply forall_intro=>e2. apply forall_intro=>σ2. apply forall_intro=>e2. apply forall_intro=>σ2.
apply wand_intro_l. rewrite right_id. rewrite -pvs_intro. apply wand_intro_l. rewrite -pvs_intro.
rewrite always_and_sep_l' -associative -always_and_sep_l'.
apply const_elim_l. intros [-> ->]. apply const_elim_l. intros [-> ->].
rewrite -wp_value. apply and_intro. by rewrite wand_elim_r -wp_value.
+ by apply const_intro.
+ done.
Qed. Qed.
Lemma wp_store_pst E σ l e v v': Lemma wp_store_pst E σ l e v v' Q :
e2v e = Some v e2v e = Some v
σ !! l = Some v' σ !! l = Some v'
ownP (Σ:=Σ) σ wp (Σ:=Σ) E (Store (Loc l) e) (ownP (Σ:=Σ) σ (ownP (<[l:=v]>σ) - Q LitUnitV)) wp (Σ:=Σ) E (Store (Loc l) e) Q.
(λ v', (v' = LitUnitV) ownP (Σ:=Σ) (<[l:=v]>σ)).
Proof. Proof.
intros Hvl Hl. etransitivity; last eapply wp_lift_step with (σ1 := σ) intros Hvl Hl. etransitivity; last eapply wp_lift_step with (σ1 := σ)
(φ := λ e' σ', e' = LitUnit σ' = <[l:=v]>σ); last first. (φ := λ e' σ', e' = LitUnit σ' = <[l:=v]>σ); last first.
...@@ -108,21 +104,19 @@ Proof. ...@@ -108,21 +104,19 @@ Proof.
- do 3 eexists. eapply StoreS; last (eexists; eassumption). eassumption. - do 3 eexists. eapply StoreS; last (eexists; eassumption). eassumption.
- reflexivity. - reflexivity.
- reflexivity. - reflexivity.
- rewrite -pvs_intro. rewrite -{1}[ownP σ](@right_id _ _ _ _ uPred.sep_True). - rewrite -pvs_intro.
apply sep_mono; first done. rewrite -later_intro. apply sep_mono; first done. apply later_mono.
apply forall_intro=>e2. apply forall_intro=>σ2. apply forall_intro=>e2. apply forall_intro=>σ2.
apply wand_intro_l. rewrite right_id. rewrite -pvs_intro. apply wand_intro_l. rewrite -pvs_intro.
rewrite always_and_sep_l' -associative -always_and_sep_l'.
apply const_elim_l. intros [-> ->]. apply const_elim_l. intros [-> ->].
rewrite -wp_value'; last reflexivity. apply and_intro. by rewrite wand_elim_r -wp_value'.
+ by apply const_intro.
+ done.
Qed. Qed.
Lemma wp_cas_fail_pst E σ l e1 v1 e2 v2 v' : Lemma wp_cas_fail_pst E σ l e1 v1 e2 v2 v' Q :
e2v e1 = Some v1 e2v e2 = Some v2 e2v e1 = Some v1 e2v e2 = Some v2
σ !! l = Some v' v' <> v1 σ !! l = Some v' v' <> v1
ownP (Σ:=Σ) σ wp (Σ:=Σ) E (Cas (Loc l) e1 e2) (ownP (Σ:=Σ) σ (ownP σ - Q LitFalseV)) wp (Σ:=Σ) E (Cas (Loc l) e1 e2) Q.
(λ v', (v' = LitFalseV) ownP (Σ:=Σ) σ).
Proof. Proof.
intros Hvl Hl. etransitivity; last eapply wp_lift_step with (σ1 := σ) intros Hvl Hl. etransitivity; last eapply wp_lift_step with (σ1 := σ)
(φ := λ e' σ', e' = LitFalse σ' = σ); last first. (φ := λ e' σ', e' = LitFalse σ' = σ); last first.
...@@ -133,21 +127,19 @@ Proof. ...@@ -133,21 +127,19 @@ Proof.
- do 3 eexists. eapply CasFailS; eassumption. - do 3 eexists. eapply CasFailS; eassumption.
- reflexivity. - reflexivity.
- reflexivity. - reflexivity.
- rewrite -pvs_intro. rewrite -{1}[ownP σ](@right_id _ _ _ _ uPred.sep_True). - rewrite -pvs_intro.
apply sep_mono; first done. rewrite -later_intro. apply sep_mono; first done. apply later_mono.
apply forall_intro=>e2'. apply forall_intro=>σ2'. apply forall_intro=>e2'. apply forall_intro=>σ2'.
apply wand_intro_l. rewrite right_id. rewrite -pvs_intro. apply wand_intro_l. rewrite -pvs_intro.
rewrite always_and_sep_l' -associative -always_and_sep_l'.
apply const_elim_l. intros [-> ->]. apply const_elim_l. intros [-> ->].
rewrite -wp_value'; last reflexivity. apply and_intro. by rewrite wand_elim_r -wp_value'.
+ by apply const_intro.
+ done.
Qed. Qed.
Lemma wp_cas_suc_pst E σ l e1 v1 e2 v2 : Lemma wp_cas_suc_pst E σ l e1 v1 e2 v2 Q :
e2v e1 = Some v1 e2v e2 = Some v2 e2v e1 = Some v1 e2v e2 = Some v2
σ !! l = Some v1 σ !! l = Some v1
ownP (Σ:=Σ) σ wp (Σ:=Σ) E (Cas (Loc l) e1 e2) (ownP (Σ:=Σ) σ (ownP (<[l:=v2]>σ) - Q LitTrueV)) wp (Σ:=Σ) E (Cas (Loc l) e1 e2) Q.
(λ v', (v' = LitTrueV) ownP (Σ:=Σ) (<[l:=v2]>σ)).
Proof. Proof.
intros Hvl Hl. etransitivity; last eapply wp_lift_step with (σ1 := σ) intros Hvl Hl. etransitivity; last eapply wp_lift_step with (σ1 := σ)
(φ := λ e' σ', e' = LitTrue σ' = <[l:=v2]>σ); last first. (φ := λ e' σ', e' = LitTrue σ' = <[l:=v2]>σ); last first.
...@@ -160,14 +152,13 @@ Proof. ...@@ -160,14 +152,13 @@ Proof.
- do 3 eexists. eapply CasSucS; eassumption. - do 3 eexists. eapply CasSucS; eassumption.
- reflexivity. - reflexivity.
- reflexivity. - reflexivity.
- rewrite -pvs_intro. rewrite -{1}[ownP σ](@right_id _ _ _ _ uPred.sep_True). - rewrite -pvs_intro.
apply sep_mono; first done. rewrite -later_intro. apply sep_mono; first done. apply later_mono.
apply forall_intro=>e2'. apply forall_intro=>σ2'. apply forall_intro=>e2'. apply forall_intro=>σ2'.
apply wand_intro_l. rewrite right_id. rewrite -pvs_intro. apply wand_intro_l. rewrite -pvs_intro.
rewrite always_and_sep_l' -associative -always_and_sep_l'.
apply const_elim_l. intros [-> ->]. apply const_elim_l. intros [-> ->].
rewrite -wp_value'; last reflexivity. apply and_intro. by rewrite wand_elim_r -wp_value'.
+ by apply const_intro.
+ done.
Qed. Qed.
(** Base axioms for core primitives of the language: Stateless reductions *) (** Base axioms for core primitives of the language: Stateless reductions *)
...@@ -218,7 +209,7 @@ Proof. ...@@ -218,7 +209,7 @@ Proof.
rewrite right_id. done. rewrite right_id. done.
Qed. Qed.
Lemma wp_rec' E e v Q : Lemma wp_rec E e v Q :
wp (Σ:=Σ) E (e.[Rec e, v2e v /]) Q wp (Σ:=Σ) E (App (Rec e) (v2e v)) Q. wp (Σ:=Σ) E (e.[Rec e, v2e v /]) Q wp (Σ:=Σ) E (App (Rec e) (v2e v)) Q.
Proof. Proof.
etransitivity; last eapply wp_lift_pure_step with etransitivity; last eapply wp_lift_pure_step with
...@@ -233,7 +224,7 @@ Qed. ...@@ -233,7 +224,7 @@ Qed.
Lemma wp_lam E e v Q : Lemma wp_lam E e v Q :
wp (Σ:=Σ) E (e.[v2e v/]) Q wp (Σ:=Σ) E (App (Lam e) (v2e v)) Q. wp (Σ:=Σ) E (e.[v2e v/]) Q wp (Σ:=Σ) E (App (Lam e) (v2e v)) Q.
Proof. Proof.
rewrite -wp_rec'. rewrite -wp_rec.
(* RJ: This pulls in functional extensionality. If that bothers us, we have (* RJ: This pulls in functional extensionality. If that bothers us, we have
to talk to the Autosubst guys. *) to talk to the Autosubst guys. *)
by asimpl. by asimpl.
......
...@@ -37,25 +37,27 @@ Module LiftingTests. ...@@ -37,25 +37,27 @@ Module LiftingTests.
Goal σ E, (ownP (Σ:=Σ) σ) (wp (Σ:=Σ) E e (λ v, (v = LitNatV 2))). Goal σ E, (ownP (Σ:=Σ) σ) (wp (Σ:=Σ) E e (λ v, (v = LitNatV 2))).
Proof. Proof.
move=> σ E. rewrite /e. move=> σ E. rewrite /e.
rewrite -(wp_bind _ _ (LetCtx EmptyCtx e2)). rewrite -wp_mono. rewrite -(wp_bind _ _ (LetCtx EmptyCtx e2)). rewrite -wp_alloc_pst; last done.
{ eapply wp_alloc_pst; done. } apply sep_intro_True_r; first done.
move=>v; apply exist_elim=>l. apply const_elim_l; move=>[-> _] {v}. rewrite -later_intro. apply forall_intro=>l.
apply wand_intro_l. rewrite right_id. apply const_elim_l; move=>_.
rewrite -wp_lam -later_intro. asimpl. rewrite -wp_lam -later_intro. asimpl.
rewrite -(wp_bind _ _ (SeqCtx (StoreRCtx (LocV _) rewrite -(wp_bind _ _ (SeqCtx (StoreRCtx (LocV _)
(PlusLCtx EmptyCtx _)) (Load (Loc _)))). (PlusLCtx EmptyCtx _)) (Load (Loc _)))).
rewrite -wp_mono. rewrite -wp_load_pst; first (apply sep_intro_True_r; first done); last first.
{ eapply wp_load_pst. apply: lookup_insert. } (* RJ TODO: figure out why apply and eapply fail. *) { apply: lookup_insert. } (* RJ TODO: figure out why apply and eapply fail. *)
move=>v; apply const_elim_l; move=>-> {v}. rewrite -later_intro. apply wand_intro_l. rewrite right_id.
rewrite -(wp_bind _ _ (SeqCtx (StoreRCtx (LocV _) EmptyCtx) (Load (Loc _)))). rewrite -(wp_bind _ _ (SeqCtx (StoreRCtx (LocV _) EmptyCtx) (Load (Loc _)))).
rewrite -wp_plus -later_intro. rewrite -wp_plus -later_intro.
rewrite -(wp_bind _ _ (SeqCtx EmptyCtx (Load (Loc _)))). rewrite -(wp_bind _ _ (SeqCtx EmptyCtx (Load (Loc _)))).
rewrite -wp_mono. rewrite -wp_store_pst; first (apply sep_intro_True_r; first done); last first.
{ eapply wp_store_pst; first reflexivity. apply: lookup_insert. } { apply: lookup_insert. }
move=>v; apply const_elim_l; move=>-> {v}. { reflexivity. }
rewrite -later_intro. apply wand_intro_l. rewrite right_id.
rewrite -wp_lam -later_intro. asimpl. rewrite -wp_lam -later_intro. asimpl.
rewrite -wp_mono. rewrite -wp_load_pst; first (apply sep_intro_True_r; first done); last first.
{ eapply wp_load_pst. apply: lookup_insert. } { apply: lookup_insert. }
move=>v; apply const_elim_l; move=>-> {v}. rewrite -later_intro. apply wand_intro_l. rewrite right_id.
by apply const_intro. by apply const_intro.
Qed. Qed.
End LiftingTests. End LiftingTests.
...@@ -616,6 +616,16 @@ Proof. intros ->; apply sep_elim_l. Qed. ...@@ -616,6 +616,16 @@ Proof. intros ->; apply sep_elim_l. Qed.
Lemma sep_elim_r' P Q R : Q R (P Q) R. Lemma sep_elim_r' P Q R : Q R (P Q) R.
Proof. intros ->; apply sep_elim_r. Qed. Proof. intros ->; apply sep_elim_r. Qed.
Hint Resolve sep_elim_l' sep_elim_r'. Hint Resolve sep_elim_l' sep_elim_r'.
Lemma sep_intro_True_l P Q R : True P R Q R (P Q).
Proof.
intros HP HQ. etransitivity; last (eapply sep_mono; eassumption).
by rewrite left_id.
Qed.
Lemma sep_intro_True_r P Q R : R P True Q R (P Q).
Proof.
intros HP HQ. etransitivity; last (eapply sep_mono; eassumption).
by rewrite right_id.
Qed.
Lemma wand_intro_l P Q R : (Q P) R P (Q - R). Lemma wand_intro_l P Q R : (Q P) R P (Q - R).
Proof. rewrite (commutative _); apply wand_intro_r. Qed. Proof. rewrite (commutative _); apply wand_intro_r. Qed.
Lemma wand_elim_r P Q : (P (P - Q)) Q. Lemma wand_elim_r P Q : (P (P - Q)) Q.
......
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