Commit 8f523096 authored by Jacques-Henri Jourdan's avatar Jacques-Henri Jourdan

Make ProofMode tactics work in RO mode.

Generalization of xpull in the case of RO triples, which are not local.
ram_apply locks the intermediate assertion if the post-condition is an evar.
use rule_seq instead of rule_seq' in ExampleListProofMode.
parent 0e67038d
......@@ -67,8 +67,8 @@ Lemma MCell_hstar_MCell_inv : forall p1 p2 x1 x2 y1 y2,
MCell x1 y1 p1 \* MCell x2 y2 p2 ==+> \[p1 <> p2].
Proof using.
intros. do 2 rewrite MCell_eq. tests C: (p1 = p2).
{ iClean. iIntros. iDestruct (hstar_hfield_same_loc_disjoint with "[$]") as %[]. }
{ iClean. auto with iFrame. }
{ iPrepare. iIntros. iDestruct (hstar_hfield_same_loc_disjoint with "[$]") as %[]. }
{ iPrepare. auto with iFrame. }
Qed.
......@@ -112,7 +112,7 @@ Lemma rule_set_hd : forall p v' v vq,
(MCell v' vq p)
(fun r => \[r = val_unit] \* MCell v vq p).
Proof using.
intros. unfold MCell. ram_apply rule_set_field. auto with iFrame.
intros. unfold MCell. ram_apply rule_set_field. auto with iFrame.
Qed.
Hint Extern 1 (Register_spec val_set_hd) => Provide rule_set_hd.
......@@ -174,9 +174,10 @@ Lemma rule_new_cell' : forall v q,
Proof using.
intros. eapply rule_app_fun2 =>//=; [].
eapply rule_let; [apply rule_alloc_cell|]=>p /=. xpull=> p' v' q' ->.
eapply rule_seq'. { rewrite MCell_eq. ram_apply rule_set_hd. auto with iFrame. }
eapply rule_seq'. { ram_apply rule_set_tl. auto with iFrame. }
eapply rule_val. auto with iFrame.
eapply rule_seq; last admit.
{ rewrite MCell_eq. ram_apply rule_set_hd. auto with iFrame. }
unlock. eapply rule_seq; last admit. { ram_apply rule_set_tl. auto with iFrame. }
unlock. eapply rule_val. iPrepare. auto with iFrame.
Qed.
Hint Extern 1 (Register_spec val_new_cell) => Provide rule_new_cell.
......@@ -304,18 +305,18 @@ Proof using.
intros L. induction_wf: list_sub_wf L. intros p.
applys rule_app_fix=>//=. applys rule_if'.
- ram_apply rule_neq. auto with iFrame.
- xpull=>[= Hp]. rewrite true_eq_isTrue_eq in Hp.
- unlock. xpull=>[= Hp]. rewrite true_eq_isTrue_eq in Hp.
xchange (MList_not_null_inv_cons p); [by auto|]. xpull=>p' x L' ?. subst.
applys rule_let. { ram_apply rule_get_tl. iIntros "?$%??". iAccu. }
move=> q /=. xpull=>->.
applys rule_let. { ram_apply (IH L'); [done|]. iIntros "?$%??". iAccu. }
move=> n /=. xpull=>->. ram_apply rule_add.
iIntros "??%->". iSplitR.
applys rule_let. { ram_apply rule_get_tl. auto with iFrame. }
unlock. move=> q /=. xpull=>->.
applys rule_let. { ram_apply (IH L'); [done|]. auto with iFrame. }
unlock. move=> n /=. xpull=>->. ram_apply rule_add.
iIntros "??" (?) "->". iSplitR.
{ iPureIntro. f_equal. math. } { iApply MList_cons. iFrame. }
- eapply rule_val. iClean. iIntros "HL" ([= Hp]). revert Hp.
- unlock. eapply rule_val. iPrepare. iIntros "HL" ([= Hp]). revert Hp.
rewrite false_eq_isTrue_eq=>/not_not_inv. intros [= ->].
iDestruct (MList_null_inv with "HL") as "[$ ->]". auto.
- iIntros ([] Hb) "[? %]"=>//. destruct Hb. eexists _. auto.
- unlock. iIntros ([] Hb) "[? %]"=>//. destruct Hb. eexists _. auto.
Qed.
(* ********************************************************************** *)
......@@ -344,33 +345,34 @@ Lemma rule_mlist_length_loop : forall L p,
Proof using.
intros L p. eapply rule_app_fun=>//=.
applys rule_let. { ram_apply rule_ref. auto with iFrame. }
move=> ? /=. xpull=>r ->.
unlock. move=> ? /=. xpull=>r ->.
applys rule_let. { ram_apply rule_ref. auto with iFrame. }
move=> ? /=. xpull=>n ->. applys rule_seq'.
unlock. move=> ? /=. xpull=>n ->. applys rule_seq; last admit.
- applys rule_while=>t R.
cuts K: (forall (nacc:int),
triple t (n ~~~> nacc \* MList L p \* r ~~~> p)
(λ r0 : val, \[r0 = '()] \* n ~~~> (nacc + length L)%Z \* MList L p)).
{ ram_apply K. auto with iFrame. }
gen p. induction_wf: list_sub_wf L=>p nacc. apply R. applys rule_if'.
+ eapply rule_let. ram_apply rule_get. { iIntros "??$ % ??". iAccu. }
move=>pp /=. xpull=>->. ram_apply rule_neq. eauto with iFrame.
+ xpull. intros [=Hp]. rewrite true_eq_isTrue_eq in Hp.
xchange (MList_not_null_inv_cons p); [by auto|iClean; auto with iFrame|].
xpull=>p' x L' ?. subst. applys rule_seq'.
* applys rule_seq'. { ram_apply rule_incr. auto with iFrame. }
eapply rule_let. { ram_apply rule_get. iIntros "$???%??". iAccu. }
xpull=>? -> /=. eapply rule_let.
{ ram_apply rule_get_tl. iIntros "??$?%??". iAccu. }
move=>? /=. xpull=>->. ram_apply rule_set. auto with iFrame.
* ram_apply (IH L'); [done|]. iIntros. iFrame. iIntros (?) "$ Hn ?". iSplitL "Hn".
+ eapply rule_let. ram_apply rule_get. { auto with iFrame. }
unlock. move=>pp /=. xpull=>->. ram_apply rule_neq. eauto with iFrame.
+ unlock. xpull. intros [=Hp]. rewrite true_eq_isTrue_eq in Hp.
xchange (MList_not_null_inv_cons p); [by auto|iPrepare; auto with iFrame|].
xpull=>p' x L' ?. subst. applys rule_seq; last admit.
* applys rule_seq; last admit. { ram_apply rule_incr. auto with iFrame. }
unlock. eapply rule_let. { ram_apply rule_get. auto with iFrame. }
unlock. xpull=>? -> /=. eapply rule_let.
{ ram_apply rule_get_tl. auto with iFrame. }
unlock. move=>? /=. xpull=>->. ram_apply rule_set. auto with iFrame.
* unlock. ram_apply (IH L'); [done|]. iIntros. iFrame.
iIntros (?) "$ Hn ?". iSplitL "Hn".
-- by math_rewrite ((nacc + 1) + length L' = nacc + S (length (L')))%Z.
-- iApply MList_cons. iFrame.
+ iApply rule_val_htop. iClean. iIntros "? HL ?" ([= Hp]).
+ unlock. iApply rule_val_htop. iPrepare. iIntros "? HL ?" ([= Hp]).
revert Hp. rewrite false_eq_isTrue_eq. intros [= ->]%not_not_inv.
iDestruct (MList_null_inv with "HL") as "[$ ->]". rewrite plus_zero_r. by iFrame.
+ iIntros ([] Hb) "(? & ? & ? & %)"=>//. destruct Hb. eexists _. auto.
- apply rule_htop_post. ram_apply rule_get. auto with iFrame.
+ unlock. iIntros ([] Hb) "(? & ? & ? & %)"=>//. destruct Hb. eexists _. auto.
- unlock. apply rule_htop_post. ram_apply rule_get. auto with iFrame.
Qed.
(* ********************************************************************** *)
......
......@@ -47,7 +47,7 @@ Lemma RO_himpl_RO_hstar_RO : forall H,
RO H ==> (RO H \* RO H).
Proof using. intros. applys RO_duplicatable. Qed.
Lemma rule_xchange : forall (H1 H1':hprop), H1 ==> H1' ->
Lemma rule_xchange : forall (H1 H1':hprop), H1 ==> H1' ->
forall t H H2 Q,
H ==> H1 \* H2 ->
triple t (H1' \* H2) Q ->
......@@ -59,7 +59,7 @@ Qed.
Lemma rule_frame_read_only_conseq : forall t H1 Q1 H2 H Q,
H ==> (H1 \* H2) ->
normal H1 ->
Normal H1 ->
triple t (RO H1 \* H2) Q1 ->
(Q1 \*+ H1) ===> Q ->
triple t H Q.
......@@ -71,12 +71,12 @@ Qed.
Lemma rule_get : forall v l,
triple (val_get (val_loc l))
triple (val_get (val_loc l))
(l ~~~> v)
(fun x => \[x = v] \* l ~~~> v).
Proof using.
intros. applys rule_frame_read_only_conseq (l ~~~> v).
{ hsimpl. } { applys normal_hsingle. (* todo: normal_hsingle? *) }
intros. applys rule_frame_read_only_conseq (l ~~~> v).
{ hsimpl. } { apply _. }
{ rew_heap. applys rule_get_ro. }
{ auto. }
Qed.
......@@ -90,7 +90,7 @@ Proof using. introv WP M1 M2. applys* rule_consequence WP. applys* rule_let. Qed
Lemma rule_frame : forall t H1 Q1 H2,
triple t H1 Q1 ->
normal H2 ->
Normal H2 ->
triple t (H1 \* H2) (Q1 \*+ H2).
Proof using.
introv M N. applys~ rule_frame_read_only.
......@@ -100,13 +100,13 @@ Qed.
Lemma rule_frame_conseq : forall t H1 Q1 H2 H Q,
H ==> H2 \* H1 ->
normal H1 ->
Normal H1 ->
triple t H2 Q1 ->
Q1 \*+ H1 ===> Q ->
triple t H Q.
Proof using. intros. applys* rule_consequence. applys* rule_frame. Qed.
Hint Resolve normal_hsingle.
Hint Resolve Normal_hsingle.
......@@ -175,7 +175,7 @@ Definition val_ref_update :=
val_set 'p 'y.
Lemma rule_ref_update : forall (f:val) (p:loc) (v:val) (H:hprop) (Q:val->hprop),
normal_post Q -> (* todo: this might not be needed if using "normally" *)
Normal_post Q -> (* todo: this might not be needed if using "normally" *)
(triple (f v)
PRE (RO(p ~~~> v) \* H)
POST Q)
......@@ -185,13 +185,13 @@ Lemma rule_ref_update : forall (f:val) (p:loc) (v:val) (H:hprop) (Q:val->hprop),
POST (fun r => \[r = val_unit] \* Hexists w, (p ~~~> w) \* (Q w))).
Proof using.
introv N M.
rew_nary; rew_vals_to_trms; applys rule_apps_funs;
rew_nary; rew_vals_to_trms; applys rule_apps_funs;
[unfold val_ref_update; rew_nary; reflexivity| auto | simpl].
applys rule_let.
{ applys rule_get. }
{ intros x; simpl; rew_heap. applys rule_extract_hprop ;=> E; subst x.
applys rule_let' \[]. { hsimpl. }
applys~ rule_frame_read_only_conseq (p ~~~> v).
applys~ rule_frame_read_only_conseq (p ~~~> v).
{ hsimpl. } { rew_heap. applys M. } { hsimpl. }
{ intros y; simpl; rew_heap. clear M.
applys~ rule_frame_conseq (Q y). hsimpl.
......
(**
This file formalizes example in Separation Logic with read-only predicates
Author: Arthur Charguéraud.
License: MIT.
*)
Set Implicit Arguments.
From Sep Require Import LambdaSepRO.
Import ProofMode.
Generalizable Variables A B.
Open Scope trm_scope.
Ltac auto_star ::= jauto.
Implicit Types p q : loc.
Implicit Types n : int.
Implicit Types v : val.
(* To move and factorize *)
Notation "F 'PRE' H 'POST' Q" :=
(F H Q)
(at level 69, only parsing) : heap_scope.
(* todo move *)
Lemma rule_apps_funs : forall xs F (Vs:vals) t1 H Q,
F = (val_funs xs t1) ->
var_funs (LibList.length Vs) xs ->
triple (substs xs Vs t1) H Q ->
triple (trm_apps F Vs) H Q.
Proof using.
introv E N M. intros h1 h2 D H1.
forwards~ (h1'&v&N1&N2&N3&N4): (rm M) h2 H1.
exists h1' v. splits~. { subst. applys~ red_app_funs_val. }
Qed.
Lemma var_funs_exec_elim : forall (n:nat) xs,
var_funs_exec n xs -> (var_funs n xs).
Proof using. introv M. rewrite var_funs_exec_eq in M. rew_istrue~ in M. Qed.
Hint Resolve var_funs_exec_elim.
(* ********************************************************************** *)
(* * Formalisation of higher-order iterator on a reference *)
(* ---------------------------------------------------------------------- *)
(** Apply a function to the contents of a reference *)
Definition val_ref_apply :=
ValFun 'f 'p :=
Let 'x := val_get 'p in
'f 'x.
Lemma rule_ref_apply : forall (f:val) (p:loc) (v:val) (H:hprop) (Q:val->hprop),
(triple (f v)
PRE (RO(p ~~~> v) \* H)
POST Q)
->
(triple (val_ref_apply f p)
PRE (RO(p ~~~> v) \* H)
POST Q).
Proof using.
introv M.
rew_nary; rew_vals_to_trms; applys rule_apps_funs;
[unfold val_ref_apply; rew_nary; reflexivity| auto | simpl].
ram_apply_let rule_get_ro. { auto with iFrame. }
move=>X /=. unlock. xpull=>->. done.
Qed.
(* ---------------------------------------------------------------------- *)
(** In-place update of a reference by applying a function *)
Definition val_ref_update :=
ValFun 'f 'p :=
Let 'x := val_get 'p in
Let 'y := 'f 'x in
val_set 'p 'y.
Lemma rule_ref_update : forall (f:val) (p:loc) (v:val) (H:hprop) (Q:val->hprop),
Normal_post Q -> (* todo: this might not be needed if using "normally" *)
(triple (f v)
PRE (RO(p ~~~> v) \* H)
POST Q)
->
(triple (val_ref_update f p)
PRE (p ~~~> v \* H)
POST (fun r => \[r = val_unit] \* Hexists w, (p ~~~> w) \* (Q w))).
Proof using.
introv N M.
rew_nary; rew_vals_to_trms; applys rule_apps_funs;
[unfold val_ref_update; rew_nary; reflexivity| auto | simpl].
ram_apply_let rule_get_ro. { auto with iFrame. }
unlock. move=>x /=. xpull=>->. ram_apply_let M. { auto with iFrame. }
unlock. move=>y /=. ram_apply rule_set. { auto 10 with iFrame. }
Qed.
......@@ -548,7 +548,7 @@ Proof using.
{ destruct M as (x&(h1&h2&M1&M2&D&U)). exists h1 h2. splits~. exists~ x. }
Qed.
Lemma hstar_hforall : forall H A (J:A->hprop),
Lemma hstar_hforall : forall H A (J:A->hprop),
(hforall J) \* H ==> hforall (J \*+ H).
Proof using.
intros. intros h M. destruct M as (h1&h2&M1&M2&D&U). intros x. exists~ h1 h2.
......@@ -646,6 +646,7 @@ Definition duplicatable (H:hprop) : Prop :=
Class Normal (H:hprop) : Prop :=
normal_emp h : H h -> h^r = fmap_empty.
Hint Mode Normal ! : typeclass_instances.
Notation Normal_post Q := (forall x, Normal (Q x)).
......@@ -1097,6 +1098,29 @@ Proof using.
exists h' v. splits~.
Qed.
(* ---------------------------------------------------------------------- *)
(* ** Customizing xpull *)
Lemma xpull_hprop (H1 H2 : hprop) (P : Prop) (Q : val -> hprop) (t : trm) :
(P -> triple t (H1 \* H2) Q) -> triple t (H1 \* \[P] \* H2) Q.
Proof. intros. rewrite hstar_comm_assoc. auto using rule_extract_hprop. Qed.
Lemma xpull_hexists (H1 H2 : hprop) (A : Type) (J:A->hprop)
(Q : val -> hprop) (t : trm) :
(forall x, triple t (H1 \* ((J x) \* H2)) Q) ->
triple t (H1 \* (hexists J \* H2)) Q.
Proof using.
intros. rewrite hstar_comm_assoc, hstar_hexists. apply rule_extract_hexists.
intros. rewrite~ hstar_comm_assoc.
Qed.
Lemma xpull_id A (x X : A) (H1 H2 : hprop) (Q : val -> hprop) (t : trm) :
(x = X -> triple t (H1 \* H2) Q) -> triple t (H1 \* (x ~> Id X \* H2)) Q.
Proof using. intros. rewrite repr_eq. apply xpull_hprop. auto. Qed.
Ltac xpull_hprop tt ::= apply xpull_hprop; intro.
Ltac xpull_hexists tt := apply xpull_hexists; intro.
Ltac xpull_id tt := apply xpull_id; intro.
(* ---------------------------------------------------------------------- *)
(* ** Term rules *)
......@@ -1288,7 +1312,7 @@ Qed.
(* ---------------------------------------------------------------------- *)
(* ** Definition of the [normally] modality *)
Definition normally H :=
Definition normally H : hprop :=
fun h => H h /\ h^r = fmap_empty.
Instance Normal_normally : forall H,
......@@ -1345,6 +1369,14 @@ Proof using.
{ auto. } }
Qed.
Lemma normally_hand_l : forall H1 H2,
normally (hand H1 H2) = hand (normally H1) H2.
Proof using.
intros H1 H2. applys himpl_antisym.
- intros ? [[??]?]. split; [split|]; auto.
- intros ? [[??]?]. split; [split|]; auto.
Qed.
Lemma normally_hstar : forall H1 H2,
normally (H1 \* H2) = normally H1 \* normally H2.
Proof using.
......@@ -1608,3 +1640,318 @@ Proof.
{ rewrite hstar_comm. apply himpl_frame_r, normally_erase. }
hchange (qwand_himpl_hwand X). hchange (hwand_cancel (Q1 X) (Q' X)). hsimpl.
Qed.
(* ********************************************************************** *)
(* * Support for Proof Mode *)
Module ProofMode.
Export SepROTactics.ProofMode.
Import iris.proofmode.coq_tactics.
(** Proper instances for normally, RO and ROFrame. *)
Instance normally_mono : Proper (() ==> ()) normally.
Proof. intros ???. by apply normally_himpl. Qed.
Instance normally_mono_flip : Proper (flip () ==> flip ()) normally.
Proof. intros ???. by apply normally_himpl. Qed.
Instance normally_ne : NonExpansive normally.
Proof. by intros ??? ->%leibniz_equiv_iff. Qed.
Instance normally_proper : Proper (() ==> ()) normally.
Proof. apply ne_proper, _. Qed.
Instance RO_mono : Proper (() ==> ()) RO.
Proof. intros ???. by apply RO_covariant. Qed.
Instance RO_mono_flip : Proper (flip () ==> flip ()) RO.
Proof. intros ???. by apply RO_covariant. Qed.
Instance RO_ne : NonExpansive RO.
Proof. by intros ??? ->%leibniz_equiv_iff. Qed.
Instance RO_proper : Proper (() ==> ()) RO.
Proof. apply ne_proper, _. Qed.
Instance ROFrame_mono : Proper (() ==> () ==> ()) ROFrame.
Proof. intros ??????. by apply ROFrame_himpl. Qed.
Instance ROFrame_mono_flip : Proper (flip () ==> flip () ==> flip ()) ROFrame.
Proof. intros ??????. by apply ROFrame_himpl. Qed.
Instance ROFrame_ne : NonExpansive2 ROFrame.
Proof. by intros ??? ->%leibniz_equiv_iff. Qed.
Instance ROFrame_proper : Proper (() ==> () ==> ()) ROFrame.
Proof. apply ne_proper_2, _. Qed.
(** Persistent and Affine instances. *)
Instance normally_persistent P : Persistent P Persistent (normally P).
Proof.
rewrite /Persistent /bi_persistently /= /hpersistently /normally=>HP h Hh.
split; [by apply (HP h), Hh|done].
Qed.
Instance normally_affine P : Affine P Affine (normally P).
Proof. rewrite /Affine=>->. by rewrite normally_hempty. Qed.
Instance RO_persistent P : Persistent P Persistent (RO P).
Proof.
rewrite /Persistent /bi_persistently /= /hpersistently /RO=>HP h [h' [Hh' _]].
exists heap_empty. split; [by eapply HP|split; [done|]].
by rewrite fmap_union_empty_l.
Qed.
Instance RO_affine P : Affine P Affine (RO P).
Proof. rewrite /Affine=>->. by rewrite RO_empty. Qed.
(* This is probably true, but not trivial to prove and not very usefull: *)
(* Instance ROFrame_persistent (P Q : hprop) : *)
(* Persistent P Persistent Q Persistent (ROFrame P Q). *)
(* Instance ROFrame_affine (P Q : hprop) : *)
(* Affine P Affine Q Affine (ROFrame P Q). *)
(** Into/From instances for RO, normally and ROFrame. *)
Instance normally_from_pure (P : hprop) (φ : Prop) :
FromPure true P φ FromPure true (normally P) φ.
Proof.
rewrite /FromPure /= /bi_affinely=><-. by rewrite normally_hand_l normally_hempty.
Qed.
Instance normally_into_pure (P : hprop) (φ : Prop) :
IntoPure P φ IntoPure (normally P) φ.
Proof. by rewrite /IntoPure normally_erase=>->. Qed.
Instance normally_from_sep (P Q R : hprop) :
FromSep P Q R FromSep (normally P) (normally Q) (normally R).
Proof. by rewrite /FromSep /bi_sep /= -normally_hstar =><-. Qed.
Instance normally_into_sep (P Q R : hprop) :
IntoSep P Q R IntoSep (normally P) (normally Q) (normally R).
Proof. by rewrite /IntoSep /bi_sep /= -normally_hstar =><-. Qed.
Instance normally_from_exist {A} (P : hprop) (Φ : A hprop) :
FromExist P Φ FromExist (normally P) (λ x, normally (Φ x)).
Proof. by rewrite /FromExist /bi_exist /= -normally_hexists=><-. Qed.
Instance normally_into_exist {A} (P : hprop) (Φ : A hprop) :
IntoExist P Φ IntoExist (normally P) (λ x, normally (Φ x)).
Proof. by rewrite /IntoExist /bi_exist /= -normally_hexists=><-. Qed.
Instance normally_from_forall {A} `{Inhabited A} (P : hprop) (Φ : A hprop) :
FromForall P Φ FromForall (normally P) (λ x, normally (Φ x)).
Proof.
assert (Inhab A). { split. by exists inhabitant. }
by rewrite /FromForall /bi_forall /= -normally_hforall=> <-.
Qed.
Instance normally_into_forall {A} (P : hprop) (Φ : A hprop) :
IntoForall P Φ IntoForall (normally P) (λ x, normally (Φ x)).
Proof.
rewrite /IntoForall=>->. apply bi.forall_intro=>?. f_equiv.
apply bi.forall_elim.
Qed.
Instance from_assumption_normally p (P Q : hprop) :
FromAssumption p P Q
KnownLFromAssumption p (normally P) Q.
Proof.
by rewrite /KnownLFromAssumption /FromAssumption normally_erase=><-.
Qed.
Instance RO_from_pure (a : bool) (P : hprop) (φ : Prop) :
FromPure true P φ FromPure true (RO P) φ.
Proof. rewrite /FromPure /= -hpure_pure =><-. by rewrite RO_pure. Qed.
Instance RO_into_pure (P : hprop) (φ : Prop) :
IntoPure P φ IntoPure (RO P) φ.
Proof.
rewrite /IntoPure /bi_pure /= /hpure_abs=>->.
rewrite RO_star RO_pure. f_equiv. auto.
Qed.
Instance RO_into_sep (P Q R : hprop) :
IntoSep P Q R IntoSep (RO P) (RO Q) (RO R).
Proof. by rewrite /IntoSep /bi_sep /= -RO_star =><-. Qed.
Instance RO_from_exist {A} (P : hprop) (Φ : A hprop) :
FromExist P Φ FromExist (RO P) (λ x, RO (Φ x)).
Proof. by rewrite /FromExist /bi_exist /= -RO_hexists=><-. Qed.
Instance RO_into_exist {A} (P : hprop) (Φ : A hprop) :
IntoExist P Φ IntoExist (RO P) (λ x, RO (Φ x)).
Proof. by rewrite /IntoExist /bi_exist /= -RO_hexists=><-. Qed.
Instance RO_into_forall {A} (P : hprop) (Φ : A hprop) :
IntoForall P Φ IntoForall (RO P) (λ x, RO (Φ x)).
Proof.
rewrite /IntoForall=>->. apply bi.forall_intro=>?. f_equiv.
apply bi.forall_elim.
Qed.
Instance ROFrame_from_sep (P Q : hprop) : FromSep (ROFrame P Q) P Q.
Proof. apply ROFrame_intro. Qed.
Instance ROFrame_from_and (P Q : hprop) :
FromAnd (P Q) P Q FromAnd (ROFrame P Q) P Q.
Proof. rewrite /FromAnd=>->. apply ROFrame_intro. Qed.
(** Frame instances *)
Class MakeNormally (P Q : hprop) :=
make_normally : normally P ⊣⊢ Q.
Arguments MakeNormally _%I _%I.
Hint Mode MakeNormally - - : typeclass_instances.
Instance make_normally_default P : MakeNormally P (normally P) | 100.
Proof. by unfold MakeNormally. Qed.
Instance make_normally_normal P : Normal P MakeNormally P P.
Proof. unfold MakeNormally. apply normally_Normal_eq. Qed.
Instance frame_normally (p : bool) (P Q R R' : hprop) :
Normal P Frame false P Q R MakeNormally R R'
Frame p P (normally Q) R'.
Proof.
rewrite /Frame /MakeNormally /= bi.affinely_persistently_if_elim =>? <- <-.
rewrite {1}(@normally_intro P) normally_hstar //.
Qed.
(* Contrarilly to other MakeXXX classes, [MakeROFRame] uses an
entailment instead of an equivalence, because the converse
direction is surprisingly difficult to prove (even though they
should hold, that is, no information is lost). *)
Class MakeROFrame (P Q R : hprop) :=
make_ro_frame : R ROFrame P Q.
Arguments MakeROFrame _%I _%I _%I.
Hint Mode MakeROFrame - - - : typeclass_instances.
Class KnownLMakeROFrame (P Q R : hprop) :=
knownl_make_ro_frame :> MakeROFrame P Q R.
Arguments KnownLMakeROFrame _%I _%I _%I.
Hint Mode KnownLMakeROFrame ! - - : typeclass_instances.
Class KnownRMakeROFrame (P Q R : hprop) :=
knownr_make_ro_frame :> MakeROFrame P Q R.
Arguments KnownRMakeROFrame _%I _%I _%I.
Hint Mode KnownRMakeROFrame ! - - : typeclass_instances.
Instance make_roframe_default (P Q : hprop) :
MakeROFrame P Q (ROFrame P Q) | 100.
Proof. by rewrite /MakeROFrame. Qed.
Instance make_roframe_emp_l (P : hprop) :
KnownLMakeROFrame emp P P.
Proof. rewrite /KnownLMakeROFrame /MakeROFrame. iIntros "H". by iSplitR. Qed.
Instance make_roframe_emp_r (P : hprop) :
KnownRMakeROFrame P emp P.
Proof. rewrite /KnownRMakeROFrame /MakeROFrame. iIntros "H". by iSplitL. Qed.
Typeclasses Opaque ROFrame.
(* There is no support, in IGPM, for resources that would be
duplicable but not persistent (like RO which is not affine). We
workaround this restriction with this [DupFrameRO] that repeatedly
tries to frame an RO permission in a goal. This [DupFrameRO] type
class is called when trying to frame in the LHS of an [ROFrame]. *)
Class DupFrameRO (R P Q : hprop) := dup_frame_ro : RO R Q P.
Arguments DupFrameRO _%I _%I _%I.
Hint Mode DupFrameRO ! ! - : typeclass_instances.
Instance dup_frame_ro_go (R P Q Q' : hprop) :
Frame false (RO R) P Q'
TCOr (DupFrameRO R Q' Q) (TCEq Q' Q)
DupFrameRO R P Q.
Proof.
rewrite /Frame /DupFrameRO=><- [<- /=|-> //].
rewrite assoc. f_equiv. apply RO_duplicatable.
Qed.
Class FrameOrWand (R P Q : hprop) := frame_or_wand : R Q P.
Arguments FrameOrWand _%I _%I _%I.
Hint Mode FrameOrWand ! - - : typeclass_instances.
Instance frame_or_wand_frame (R P Q : hprop) :
Frame false R P Q FrameOrWand R P Q | 0.
Proof. done. Qed.
Instance frame_or_wand_wand (R P : hprop) :
FrameOrWand R P (R - P) | 1.
Proof. unfold FrameOrWand. iIntros "[? H]". by iApply "H". Qed.
(* We try all these framing schemes, in this order:
TODO : there are computations to share. *)
(* 1st step: if we are tying to frame an RO, we first see if it is
needed on the LHS. If so, then we also make it available on the
RHS. *)
Instance frame_roframe_ro_lr p (R P P' Q Q' S : hprop) :
DupFrameRO R P P' FrameOrWand (RO R) Q Q'
MakeROFrame P' Q' S Frame p (RO R) (ROFrame P Q) S | 1.
Proof.
rewrite /Frame /DupFrameRO /FrameOrWand /MakeROFrame
bi.affinely_persistently_if_elim=><- <- ->.
assert (HR:=@RO_duplicatable R). unfold duplicatable in HR. rewrite {1}HR.
by rewrite /bi_sep /= hstar_assoc ROFrame_frame_r ROFrame_frame_l.
Qed.
(* 2nd step: we try to frame on the LHS. *)
Instance frame_roframe_l p (R P P' Q S : hprop) :
Frame p R P P' MakeROFrame P' Q S Frame p R (ROFrame P Q) S | 2.
Proof. rewrite /Frame /MakeROFrame=><- ->. apply ROFrame_frame_l. Qed.
(* 3rd step: we try to convert to a RO permission. *)
Instance frame_roframe_lr p (R P P' Q Q' S : hprop) :
Normal R DupFrameRO R P P' FrameOrWand R Q Q' MakeROFrame P' Q' S
Frame p R (ROFrame P Q) S | 3.
Proof.
rewrite /DupFrameRO /FrameOrWand /MakeROFrame /Frame
bi.affinely_persistently_if_elim =>? <- <- ->. apply ROFrame_frame_lr, _.
Qed.
(* 4th step: we frame on the RHS *)
Instance frame_roframe_r p (R P Q Q' S : hprop) :
Frame p R Q Q' MakeROFrame P Q' S Frame p R (ROFrame P Q) S | 4.
Proof.
rewrite /DupFrameRO /FrameOrWand /MakeROFrame /Frame=><- ->. apply ROFrame_frame_r.
Qed.
(** Setup iModIntro to work with normally. *)
Lemma modality_normally_mixin :
modality_mixin normally MIEnvId (MIEnvForall Normal).
Proof.
split; simpl; intros.
- by intros h [-> ?].
- by apply normally_intro.
- by rewrite normally_hempty.
- by f_equiv.
- by rewrite normally_hstar.
Qed.
Definition modality_normally :=
Modality _ modality_normally_mixin.
Instance from_modal_normally P :
FromModal modality_normally (normally P) (normally P) P.
Proof. by rewrite /FromModal. Qed.
(** A bit of automation for ROFrame and normally. *)
Hint Extern 2 (envs_entails _ (ROFrame _ _)) => progress iFrame : iFrame.
Hint Extern 0 (envs_entails _ (ROFrame \[_] _)) => iSplitR.
Hint Extern 0 (envs_entails _ (ROFrame _ \[_])) => iSplitL.
Hint Extern 0 (envs_entails _ (ROFrame \[] _)) => iSplitR.
Hint Extern 0 (envs_entails _ (ROFrame _ \[])) => iSplitL.
Hint Extern 0 (envs_entails _ (ROFrame emp%I _)) => iSplitR.
Hint Extern 0 (envs_entails _ (ROFrame _ emp%I)) => iSplitL.
Hint Extern 0 (envs_entails _ (normally _)) => iModIntro (normally _).
(** [PrepareHProp] stuff. *)
Instance prepare_hprop_normally (P Q : hprop) :
PrepareHProp P Q PrepareHProp (normally P) (normally Q).
Proof. by unfold PrepareHProp=>->. Qed.
Instance prepare_hprop_hstar (P P' Q Q' : hprop) :
PrepareHProp P P' PrepareHProp Q Q'
PrepareHProp (ROFrame P Q) (ROFrame P' Q').
Proof. by rewrite /PrepareHProp=>-> ->. Qed.
(** Tactics *)
Lemma rule_ramified_frame_read_only_locked : forall t H Q H' Q',
triple t H' Q' ->
H ==> ROFrame H' (normally (locked Q' \---* Q)) ->
triple t H Q.
Proof using. unlock. apply rule_ramified_frame_read_only. Qed.
Ltac ram_apply lem :=
lazymatch goal with
| |- triple _ _ ?Q =>
(is_evar Q; eapply rule_ramified_frame_read_only_locked) ||
eapply rule_ramified_frame_read_only
end; [eapply lem|iPrepare].
Lemma rule_let_ramified_frame_read_only_locked : forall x t1 t2 H1 H Q1 Q Q',
triple t1 H1 Q1 ->
H ==> ROFrame H1 (locked Q1 \---* Q') ->
(forall (X:val), triple (subst x X t2) (Q' X) Q) ->
triple (trm_let x t1 t2) H Q.
Proof using. unlock. apply rule_let_ramified_frame_read_only