Commit da39d1bb authored by Ralf Jung's avatar Ralf Jung
Browse files

heap_lang/tests: provide a closed Hoare proof

parent d40bbd57
...@@ -100,7 +100,7 @@ Section proof. ...@@ -100,7 +100,7 @@ Section proof.
Local Hint Immediate i_states_closed low_states_closed. Local Hint Immediate i_states_closed low_states_closed.
Notation iProp := (iPropG heap_lang Σ). Local Notation iProp := (iPropG heap_lang Σ).
Definition waiting (P : iProp) (I : gset gname) : iProp := Definition waiting (P : iProp) (I : gset gname) : iProp :=
( R : gname iProp, (P - Π★{set I} (λ i, R i)) ( R : gname iProp, (P - Π★{set I} (λ i, R i))
......
(** This file is essentially a bunch of testcases. *) (** This file is essentially a bunch of testcases. *)
From program_logic Require Import ownership. From program_logic Require Import ownership hoare auth.
From heap_lang Require Import wp_tactics heap notation. From heap_lang Require Import wp_tactics heap notation.
Import uPred. Import uPred.
...@@ -23,14 +23,16 @@ End LangTests. ...@@ -23,14 +23,16 @@ End LangTests.
Section LiftingTests. Section LiftingTests.
Context `{heapG Σ}. Context `{heapG Σ}.
Implicit Types P : iPropG heap_lang Σ. Local Notation iProp := (iPropG heap_lang Σ).
Implicit Types Q : val iPropG heap_lang Σ.
Definition e : expr := Implicit Types P : iProp.
Implicit Types Q : val iProp.
Definition heap_e : expr :=
let: "x" := ref '1 in "x" <- !"x" + '1;; !"x". let: "x" := ref '1 in "x" <- !"x" + '1;; !"x".
Goal N, heap_ctx N wp N e (λ v, v = '2). Lemma heap_e_spec E N : nclose N E heap_ctx N wp E heap_e (λ v, v = '2).
Proof. Proof.
move=> N. rewrite /e. rewrite /heap_e=>HN. rewrite -(wp_mask_weaken N E) //.
wp> eapply wp_alloc; eauto. apply forall_intro=>l; apply wand_intro_l. wp> eapply wp_alloc; eauto. apply forall_intro=>l; apply wand_intro_l.
wp_rec. wp> eapply wp_load; eauto with I. apply sep_mono_r, wand_intro_l. wp_rec. wp> eapply wp_load; eauto with I. apply sep_mono_r, wand_intro_l.
wp_bin_op. wp> eapply wp_store; eauto with I. apply sep_mono_r, wand_intro_l. wp_bin_op. wp> eapply wp_store; eauto with I. apply sep_mono_r, wand_intro_l.
...@@ -71,9 +73,33 @@ Section LiftingTests. ...@@ -71,9 +73,33 @@ Section LiftingTests.
- ewp apply FindPred_spec. auto with I omega. - ewp apply FindPred_spec. auto with I omega.
Qed. Qed.
Goal E, Lemma Pred_user E :
True wp (Σ:=globalF Σ) E (let: "x" := Pred '42 in Pred "x") (λ v, v = '40). True wp (Σ:=globalF Σ) E (let: "x" := Pred '42 in Pred "x") (λ v, v = '40).
Proof. Proof.
intros. ewp> apply Pred_spec. wp_rec. ewp> apply Pred_spec. auto with I. intros. ewp> apply Pred_spec. wp_rec. ewp> apply Pred_spec. auto with I.
Qed. Qed.
End LiftingTests. End LiftingTests.
Section ClosedProofs.
Definition Σ : iFunctorG := λ _, authF (constF heapRA).
Local Instance : inG heap_lang Σ (authRA heapRA).
Proof. by exists 1%nat. Qed.
(* TODO: Why do I even have to explicitly do this? *)
Local Instance : authG heap_lang Σ heapRA.
Proof. split; by apply _. Qed.
Local Notation iProp := (iPropG heap_lang Σ).
Lemma heap_e_hoare σ : {{ ownP σ : iProp }} heap_e @ {{ λ v, v = '2 }}.
Proof.
apply ht_alt. rewrite (heap_alloc nroot); last by rewrite nclose_nroot.
apply wp_strip_pvs, exist_elim=>?. rewrite and_elim_l.
rewrite -heap_e_spec; first by eauto with I. by rewrite nclose_nroot.
Qed.
Print Assumptions heap_e_hoare.
End ClosedProofs.
...@@ -29,12 +29,16 @@ Global Instance ht_mono' E : ...@@ -29,12 +29,16 @@ Global Instance ht_mono' E :
Proper (flip () ==> eq ==> pointwise_relation _ () ==> ()) (@ht Λ Σ E). Proper (flip () ==> eq ==> pointwise_relation _ () ==> ()) (@ht Λ Σ E).
Proof. by intros P P' HP e ? <- Q Q' HQ; apply ht_mono. Qed. Proof. by intros P P' HP e ? <- Q Q' HQ; apply ht_mono. Qed.
Lemma ht_val E v : Lemma ht_alt E P Q e : (P wp E e Q) {{ P }} e @ E {{ Q }}.
{{ True : iProp Λ Σ }} of_val v @ E {{ λ v', v = v' }}.
Proof. Proof.
apply (always_intro _ _), impl_intro_l. intros; rewrite -{1}always_const. apply (always_intro _ _), impl_intro_l.
by rewrite -wp_value'; apply const_intro. by rewrite always_const right_id.
Qed. Qed.
Lemma ht_val E v :
{{ True : iProp Λ Σ }} of_val v @ E {{ λ v', v = v' }}.
Proof. apply ht_alt. by rewrite -wp_value'; apply const_intro. Qed.
Lemma ht_vs E P P' Q Q' e : Lemma ht_vs E P P' Q Q' e :
((P ={E}=> P') {{ P' }} e @ E {{ Q' }} v, Q' v ={E}=> Q v) ((P ={E}=> P') {{ P' }} e @ E {{ Q' }} v, Q' v ={E}=> Q v)
{{ P }} e @ E {{ Q }}. {{ P }} e @ E {{ Q }}.
...@@ -45,6 +49,7 @@ Proof. ...@@ -45,6 +49,7 @@ Proof.
rewrite -(pvs_wp E e Q) -(wp_pvs E e Q); apply pvs_mono, wp_mono=> v. rewrite -(pvs_wp E e Q) -(wp_pvs E e Q); apply pvs_mono, wp_mono=> v.
by rewrite (forall_elim v) {1}/vs always_elim impl_elim_r. by rewrite (forall_elim v) {1}/vs always_elim impl_elim_r.
Qed. Qed.
Lemma ht_atomic E1 E2 P P' Q Q' e : Lemma ht_atomic E1 E2 P P' Q Q' e :
E2 E1 atomic e E2 E1 atomic e
((P ={E1,E2}=> P') {{ P' }} e @ E2 {{ Q' }} v, Q' v ={E2,E1}=> Q v) ((P ={E1,E2}=> P') {{ P' }} e @ E2 {{ Q' }} v, Q' v ={E2,E1}=> Q v)
...@@ -56,6 +61,7 @@ Proof. ...@@ -56,6 +61,7 @@ Proof.
rewrite -(wp_atomic E1 E2) //; apply pvs_mono, wp_mono=> v. rewrite -(wp_atomic E1 E2) //; apply pvs_mono, wp_mono=> v.
by rewrite (forall_elim v) {1}/vs always_elim impl_elim_r. by rewrite (forall_elim v) {1}/vs always_elim impl_elim_r.
Qed. Qed.
Lemma ht_bind `{LanguageCtx Λ K} E P Q Q' e : Lemma ht_bind `{LanguageCtx Λ K} E P Q Q' e :
({{ P }} e @ E {{ Q }} v, {{ Q v }} K (of_val v) @ E {{ Q' }}) ({{ P }} e @ E {{ Q }} v, {{ Q v }} K (of_val v) @ E {{ Q' }})
{{ P }} K e @ E {{ Q' }}. {{ P }} K e @ E {{ Q' }}.
...@@ -65,9 +71,11 @@ Proof. ...@@ -65,9 +71,11 @@ Proof.
rewrite wp_always_r -wp_bind //; apply wp_mono=> v. rewrite wp_always_r -wp_bind //; apply wp_mono=> v.
by rewrite (forall_elim v) /ht always_elim impl_elim_r. by rewrite (forall_elim v) /ht always_elim impl_elim_r.
Qed. Qed.
Lemma ht_mask_weaken E1 E2 P Q e : Lemma ht_mask_weaken E1 E2 P Q e :
E1 E2 {{ P }} e @ E1 {{ Q }} {{ P }} e @ E2 {{ Q }}. E1 E2 {{ P }} e @ E1 {{ Q }} {{ P }} e @ E2 {{ Q }}.
Proof. intros. by apply always_mono, impl_mono, wp_mask_frame_mono. Qed. Proof. intros. by apply always_mono, impl_mono, wp_mask_frame_mono. Qed.
Lemma ht_frame_l E P Q R e : Lemma ht_frame_l E P Q R e :
{{ P }} e @ E {{ Q }} {{ R P }} e @ E {{ λ v, R Q v }}. {{ P }} e @ E {{ Q }} {{ R P }} e @ E {{ λ v, R Q v }}.
Proof. Proof.
...@@ -75,9 +83,11 @@ Proof. ...@@ -75,9 +83,11 @@ Proof.
rewrite always_and_sep_r -assoc (sep_and P) always_elim impl_elim_r. rewrite always_and_sep_r -assoc (sep_and P) always_elim impl_elim_r.
by rewrite wp_frame_l. by rewrite wp_frame_l.
Qed. Qed.
Lemma ht_frame_r E P Q R e : Lemma ht_frame_r E P Q R e :
{{ P }} e @ E {{ Q }} {{ P R }} e @ E {{ λ v, Q v R }}. {{ P }} e @ E {{ Q }} {{ P R }} e @ E {{ λ v, Q v R }}.
Proof. setoid_rewrite (comm _ _ R); apply ht_frame_l. Qed. Proof. setoid_rewrite (comm _ _ R); apply ht_frame_l. Qed.
Lemma ht_frame_later_l E P R e Q : Lemma ht_frame_later_l E P R e Q :
to_val e = None to_val e = None
{{ P }} e @ E {{ Q }} {{ R P }} e @ E {{ λ v, R Q v }}. {{ P }} e @ E {{ Q }} {{ R P }} e @ E {{ λ v, R Q v }}.
...@@ -86,6 +96,7 @@ Proof. ...@@ -86,6 +96,7 @@ Proof.
rewrite always_and_sep_r -assoc (sep_and P) always_elim impl_elim_r. rewrite always_and_sep_r -assoc (sep_and P) always_elim impl_elim_r.
by rewrite wp_frame_later_l //; apply wp_mono=>v; rewrite pvs_frame_l. by rewrite wp_frame_later_l //; apply wp_mono=>v; rewrite pvs_frame_l.
Qed. Qed.
Lemma ht_frame_later_r E P R e Q : Lemma ht_frame_later_r E P R e Q :
to_val e = None to_val e = None
{{ P }} e @ E {{ Q }} {{ P R }} e @ E {{ λ v, Q v R }}. {{ P }} e @ E {{ Q }} {{ P R }} e @ E {{ λ v, Q v R }}.
...@@ -93,4 +104,5 @@ Proof. ...@@ -93,4 +104,5 @@ Proof.
rewrite (comm _ _ ( R)%I); setoid_rewrite (comm _ _ R). rewrite (comm _ _ ( R)%I); setoid_rewrite (comm _ _ R).
apply ht_frame_later_l. apply ht_frame_later_l.
Qed. Qed.
End hoare. End hoare.
...@@ -2,14 +2,14 @@ From prelude Require Export countable co_pset. ...@@ -2,14 +2,14 @@ From prelude Require Export countable co_pset.
From algebra Require Export base. From algebra Require Export base.
Definition namespace := list positive. Definition namespace := list positive.
Definition nnil : namespace := nil. Definition nroot : namespace := nil.
Definition ndot `{Countable A} (N : namespace) (x : A) : namespace := Definition ndot `{Countable A} (N : namespace) (x : A) : namespace :=
encode x :: N. encode x :: N.
Coercion nclose (N : namespace) : coPset := coPset_suffixes (encode N). Coercion nclose (N : namespace) : coPset := coPset_suffixes (encode N).
Instance ndot_inj `{Countable A} : Inj2 (=) (=) (=) (@ndot A _ _). Instance ndot_inj `{Countable A} : Inj2 (=) (=) (=) (@ndot A _ _).
Proof. by intros N1 x1 N2 x2 ?; simplify_eq. Qed. Proof. by intros N1 x1 N2 x2 ?; simplify_eq. Qed.
Lemma nclose_nnil : nclose nnil = . Lemma nclose_nroot : nclose nroot = .
Proof. by apply (sig_eq_pi _). Qed. Proof. by apply (sig_eq_pi _). Qed.
Lemma encode_nclose N : encode N nclose N. Lemma encode_nclose N : encode N nclose N.
Proof. by apply elem_coPset_suffixes; exists xH; rewrite (left_id_L _ _). Qed. Proof. by apply elem_coPset_suffixes; exists xH; rewrite (left_id_L _ _). Qed.
......
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