Commit 392b7b43 authored by Amin Timany's avatar Amin Timany

Finish using new iris with "proof mode"

In Fμ and Fμ_ref we do support reduction under Fold.
In fact `Unfold (Fold v)` is reduced to `v` if and only if v is a variable.
parent 9825e341
...@@ -68,7 +68,7 @@ Section typed_interp. ...@@ -68,7 +68,7 @@ Section typed_interp.
end : itauto. end : itauto.
Local Tactic Notation "smart_wp_bind" uconstr(ctx) ident(v) constr(Hv) constr(Hp) := Local Tactic Notation "smart_wp_bind" uconstr(ctx) ident(v) constr(Hv) uconstr(Hp) :=
iApply (@wp_bind _ _ _ [ctx]); iApply (@wp_bind _ _ _ [ctx]);
iApply wp_impl_l; iApply wp_impl_l;
iSplit; [| iApply Hp; trivial]; cbn; iSplit; [| iApply Hp; trivial]; cbn;
...@@ -148,84 +148,64 @@ Section typed_interp. ...@@ -148,84 +148,64 @@ Section typed_interp.
iApply wp_mono; [|iApply "Hv"; auto with itauto]. iApply wp_mono; [|iApply "Hv"; auto with itauto].
intros; apply interp_closed_irrel_turnstile. intros; apply interp_closed_irrel_turnstile.
- (* TLam *) - (* TLam *)
value_case; iApply exist_intro; iSplit; trivial.
value_case; rewrite -exist_intro; apply and_intro; auto. iIntros {τi}; destruct τi as [τi τiPr].
apply forall_intro =>τi; iPoseProof always_intro "HΓ" as "HP"; try typeclasses eauto; try iExact "HP".
apply (always_intro _ _). iIntros "#HΓ"; iNext.
rewrite map_length in IHHtyped. iApply IHHtyped; [rewrite map_length|]; trivial.
destruct τi as [τi τiAS]. iRevert "HΓ".
specialize (IHHtyped rewrite zip_with_closed_ctx_list_subst.
(Vlist_cons τi Δ) iIntros "#HΓ"; trivial.
(closed_ctx_map
_ _ _ _
Hctx (λ τ, closed_type_S_ren2 τ 1 0 _))
(closed_type_forall HC)
(alwyas_stable_Vlist_cons _ _ _ τiAS)
_
Hlen
).
rewrite -wp_impl_l -later_intro. apply and_intro;
[ apply (always_intro _ _), forall_intro=> v /=; apply impl_intro_l|].
2: etransitivity; [|apply IHHtyped].
+ rewrite and_elim_l; trivial.
+ rewrite zip_with_closed_ctx_list_subst; trivial.
- (* TApp *) - (* TApp *)
smart_wp_bind TAppCtx _ v; cbn. smart_wp_bind TAppCtx v "#Hv" IHHtyped; cbn.
rewrite and_elim_l. iApply exist_elim; [|iExact "Hv"]; cbn.
rewrite exist_elim; eauto => e'. iIntros {e'} "[% #He']"; rewrite H0.
apply const_elim_l; intros H'; rewrite H'. iApply wp_TLam.
rewrite (forall_elim ((interp k τ' H Δ) _)). iSpecialize "He'" {((interp k τ' H Δ) _)}; cbn.
rewrite always_elim. iApply always_elim. iApply always_mono; [|trivial].
rewrite -wp_TLam; apply later_mono. iIntros "He'"; iNext.
apply wp_mono=> w. iApply wp_mono; [|trivial].
rewrite interp_subst; trivial. intros w; rewrite interp_subst; trivial.
- (* Fold *) - (* Fold *)
value_case. unfold interp_rec.
rewrite fixpoint_unfold.
cbn.
rewrite -exist_intro.
apply (always_intro _ _).
apply and_intro; auto.
rewrite map_length in IHHtyped. rewrite map_length in IHHtyped.
specialize (IHHtyped iApply (@wp_bind _ _ _ [FoldCtx]);
(Vlist_cons (interp k (TRec τ) HC Δ) Δ) iApply wp_impl_l;
(closed_ctx_map iSplit; [eapply (@always_intro _ _ _ _)|
_ _ _ _ iApply (IHHtyped _ _ (closed_type_rec HC)); trivial]; cbn.
Hctx (λ τ, closed_type_S_ren2 τ 1 0 _)) + iIntros {v} "#Hv".
(closed_type_rec HC) value_case. rewrite /interp_rec fixpoint_unfold. unfold interp_rec_pre at 1; cbn.
(alwyas_stable_Vlist_cons _ _ _ _) eapply (@always_intro _ _ _ _).
_ iApply exist_intro; iSplit; trivial.
Hlen iNext.
). change (fixpoint (interp_rec_pre
rewrite -wp_impl_l -later_intro. apply and_intro; (Vlist_cons_apply Δ (interp (S k) τ (closed_type_rec HC)))))
[ apply (always_intro _ _), forall_intro=> v /=; apply impl_intro_l|]. with ((interp k (TRec τ) HC) Δ); trivial.
2: etransitivity; [|apply IHHtyped]. + iRevert "HΓ"; rewrite zip_with_closed_ctx_list_subst; iIntros "#HΓ"; trivial.
+ rewrite and_elim_l; trivial.
+ rewrite zip_with_closed_ctx_list_subst; trivial.
- (* Unfold *) - (* Unfold *)
smart_wp_bind UnfoldCtx _ v; cbn. iApply (@wp_bind _ _ _ [UnfoldCtx]);
rewrite and_elim_l. iApply wp_impl_l;
unfold interp_rec. rewrite fixpoint_unfold /interp_rec_pre; cbn. iSplit; [eapply (@always_intro _ _ _ _)|
replace (fixpoint iApply (IHHtyped _ _ (typed_closed_type _ _ _ _ Htyped)); trivial]; cbn.
(λ rec_apr : leibniz_val -n> iProp lang Σ, iIntros {v}.
CofeMor rewrite /interp_rec fixpoint_unfold. unfold interp_rec_pre at 1; cbn.
(λ w : leibniz_val, iIntros "#Hv".
( e1 : expr, iApply exist_elim; [|iAssumption].
w = FoldV e1 iIntros {w}; cbn.
WP e1 @ {{ λ v1 : val, change (fixpoint (interp_rec_pre
((interp (S k) τ (closed_type_rec ?HC4)) (Vlist_cons_apply
(Vlist_cons rec_apr Δ)) v1 }}))%I)) Δ
with (interp
(interp k (TRec τ) (typed_closed_type _ _ _ _ Htyped) Δ) by (cbn; unfold interp_rec; trivial). (S k) τ
rewrite always_elim. (closed_type_rec
rewrite exist_elim; eauto => e'. (typed_closed_type k Γ e (TRec τ) Htyped))))))
apply const_elim_l; intros H'; rewrite H'. with ((interp k (TRec τ) (typed_closed_type k Γ e (TRec τ) Htyped)) Δ); trivial.
rewrite -wp_Fold. iIntros "[% #Hw]"; rewrite H.
apply later_mono, wp_mono => w. iApply wp_Fold; cbn; auto using to_of_val.
rewrite -interp_subst; eauto. iRevert "Hw". rewrite -interp_subst. iIntros "#Hw". trivial.
(* unshelving *) (* unshelving *)
Unshelve. Unshelve.
all: solve [eauto 2 using typed_closed_type | try typeclasses eauto]. all: cbn; solve [eauto 2 using closed_ctx_map_S_back,
typed_closed_type | try typeclasses eauto].
Qed. Qed.
End typed_interp. End typed_interp.
\ No newline at end of file
...@@ -21,7 +21,6 @@ Section logrel. ...@@ -21,7 +21,6 @@ Section logrel.
Arguments val_to_iprop_always_stable /. Arguments val_to_iprop_always_stable /.
Definition interp_unit : leibniz_val -n> iProp lang Σ := Definition interp_unit : leibniz_val -n> iProp lang Σ :=
{| {|
cofe_mor_car := λ w, (w = UnitV)%I cofe_mor_car := λ w, (w = UnitV)%I
...@@ -124,22 +123,22 @@ Section logrel. ...@@ -124,22 +123,22 @@ Section logrel.
(rec_apr : (leibniz_val -n> iProp lang Σ)) (rec_apr : (leibniz_val -n> iProp lang Σ))
: (leibniz_val -n> iProp lang Σ) := : (leibniz_val -n> iProp lang Σ) :=
{| {|
cofe_mor_car := λ w, ( ( e, w = FoldV e WP e @ {{ λ v, τi rec_apr v}}))%I cofe_mor_car := λ w, ( ( v, w = FoldV v (τi rec_apr v)))%I
|}. |}.
Global Instance interp_rec_pre_proper : Proper (() ==> () ==> ()) interp_rec_pre. Global Instance interp_rec_pre_proper : Proper (() ==> () ==> ()) interp_rec_pre.
Proof. Proof.
intros τ1 τ1' H1 τ2 τ2' H2 w. intros τ1 τ1' H1 τ2 τ2' H2 w.
apply always_proper; apply exist_proper=>e; apply and_proper; trivial. apply always_proper, exist_proper=>e; apply and_proper; trivial.
apply later_proper, wp_proper=>v. apply later_proper.
rewrite H1 H2; trivial. rewrite H1 H2; trivial.
Qed. Qed.
Global Instance interp_rec_pre_ne n : Proper (dist n ==> dist n ==> dist n) interp_rec_pre. Global Instance interp_rec_pre_ne n : Proper (dist n ==> dist n ==> dist n) interp_rec_pre.
Proof. Proof.
intros τ1 τ1' H1 τ2 τ2' H2 w. intros τ1 τ1' H1 τ2 τ2' H2 w.
apply always_ne; apply exist_ne=>e; apply and_ne; trivial. apply always_ne, exist_ne=>e; apply and_ne; trivial.
apply (contractive_ne _), wp_ne=>v. apply (contractive_ne _).
rewrite H1 H2; trivial. rewrite H1 H2; trivial.
Qed. Qed.
...@@ -149,9 +148,9 @@ Section logrel. ...@@ -149,9 +148,9 @@ Section logrel.
Contractive (interp_rec_pre τi). Contractive (interp_rec_pre τi).
Proof. Proof.
intros n f g H w; cbn. intros n f g H w; cbn.
apply always_ne;apply exist_ne; intros e; apply and_ne; trivial. apply always_ne, exist_ne; intros e; apply and_ne; trivial.
apply later_contractive =>i Hi. apply later_contractive =>i Hi.
apply wp_ne; intros v; rewrite H; trivial. rewrite H; trivial.
Qed. Qed.
Definition interp_rec (τi : (leibniz_val -n> iProp lang Σ) -n> (leibniz_val -n> iProp lang Σ)) Definition interp_rec (τi : (leibniz_val -n> iProp lang Σ) -n> (leibniz_val -n> iProp lang Σ))
...@@ -281,14 +280,15 @@ Section logrel. ...@@ -281,14 +280,15 @@ Section logrel.
{HΔ : VlistAlwaysStable Δ} {HΔ : VlistAlwaysStable Δ}
: Val_to_IProp_AlwaysStable (interp k τ H Δ). : Val_to_IProp_AlwaysStable (interp k τ H Δ).
Proof. Proof.
induction τ; cbn; intros v; try apply _. revert k H Δ HΔ.
- rewrite /interp_rec /PersistentP fixpoint_unfold /interp_rec_pre. induction τ; cbn; intros k H Δ HΔ v; try apply _.
apply always_intro'; trivial. - rewrite /PersistentP /interp_rec fixpoint_unfold /interp_rec_pre; cbn.
- apply (@force_lookup_Forall apply always_intro'; trivial.
_ _ - apply (@force_lookup_Forall
(λ f : leibniz_val -n> iProp lang Σ, PersistentP (f v))). _ _
apply Forall_forall => f H1. (λ f : leibniz_val -n> iProp lang Σ, PersistentP (f v))).
eapply Forall_forall in HΔ; [apply HΔ|trivial]. apply Forall_forall => f H1.
eapply Forall_forall in HΔ; [apply HΔ|trivial].
Qed. Qed.
Global Instance alwyas_stable_Δ k Δ Γ vs Global Instance alwyas_stable_Δ k Δ Γ vs
......
...@@ -94,11 +94,13 @@ Section lang_rules. ...@@ -94,11 +94,13 @@ Section lang_rules.
- by rewrite right_id. - by rewrite right_id.
Qed. Qed.
Lemma wp_Fold E e Q : Lemma wp_Fold E e v Q :
wp E e Q wp E (Unfold (Fold e)) Q. to_val e = Some v
Q v wp E (Unfold (Fold e)) Q.
Proof. Proof.
rewrite -(wp_lift_pure_det_step (Unfold _) e None) //=; auto. intros <-%of_to_val.
- by rewrite right_id. rewrite -(wp_lift_pure_det_step (Unfold _) (of_val v) None) //=; auto.
- rewrite right_id; auto using uPred.later_mono, wp_value'.
Qed. Qed.
Lemma wp_fst E e1 v1 e2 v2 Q : Lemma wp_fst E e1 v1 e2 v2 Q :
......
...@@ -334,4 +334,14 @@ Proof. ...@@ -334,4 +334,14 @@ Proof.
(s1 s2 : nat A) x, (x 0 s1 (pred x) = s2 (pred x)) up s1 x = up s2 x). (s1 s2 : nat A) x, (x 0 s1 (pred x) = s2 (pred x)) up s1 x = up s2 x).
{ intros A H1 H2. rewrite /up=> s1 s2 [|x] //=; auto with f_equal omega. } { intros A H1 H2. rewrite /up=> s1 s2 [|x] //=; auto with f_equal omega. }
induction Htyped => s1 s2 Hs; f_equal/=; eauto using lookup_lt_Some with omega typed_subst_invariant. induction Htyped => s1 s2 Hs; f_equal/=; eauto using lookup_lt_Some with omega typed_subst_invariant.
Qed.
Lemma closed_ctx_map_S_back (k : nat) (Γ : list type) (e : expr) (τ : type) :
closed_ctx k Γ
closed_ctx (S k) (map (λ t : type, t.[ren (+1)]) Γ).
Proof.
intros H.
eapply closed_ctx_map; [eassumption|].
clear; intros τ' H'.
set (HW := closed_type_S_ren2 τ' 1 0); cbn in HW; apply HW; trivial.
Qed. Qed.
\ No newline at end of file
This diff is collapsed.
...@@ -53,7 +53,7 @@ Module lang. ...@@ -53,7 +53,7 @@ Module lang.
| PairV (v1 v2 : val) | PairV (v1 v2 : val)
| InjLV (v : val) | InjLV (v : val)
| InjRV (v : val) | InjRV (v : val)
| FoldV (e : expr) | FoldV (v : val)
| LocV (l : loc). | LocV (l : loc).
Global Instance val_dec_eq (v v' : val) : Decision (v = v'). Global Instance val_dec_eq (v v' : val) : Decision (v = v').
...@@ -72,7 +72,7 @@ Module lang. ...@@ -72,7 +72,7 @@ Module lang.
| PairV v1 v2 => Pair (of_val v1) (of_val v2) | PairV v1 v2 => Pair (of_val v1) (of_val v2)
| InjLV v => InjL (of_val v) | InjLV v => InjL (of_val v)
| InjRV v => InjR (of_val v) | InjRV v => InjR (of_val v)
| FoldV e => Fold e | FoldV v => Fold (of_val v)
| LocV l => Loc l | LocV l => Loc l
end. end.
...@@ -84,7 +84,7 @@ Module lang. ...@@ -84,7 +84,7 @@ Module lang.
| Pair e1 e2 => v1 to_val e1; v2 to_val e2; Some (PairV v1 v2) | Pair e1 e2 => v1 to_val e1; v2 to_val e2; Some (PairV v1 v2)
| InjL e => InjLV <$> to_val e | InjL e => InjLV <$> to_val e
| InjR e => InjRV <$> to_val e | InjR e => InjRV <$> to_val e
| Fold e => Some (FoldV e) | Fold e => v to_val e; Some (FoldV v)
| Loc l => Some (LocV l) | Loc l => Some (LocV l)
| _ => None | _ => None
end. end.
...@@ -101,6 +101,7 @@ Module lang. ...@@ -101,6 +101,7 @@ Module lang.
| InjLCtx | InjLCtx
| InjRCtx | InjRCtx
| CaseCtx (e1 : {bind expr}) (e2 : {bind expr}) | CaseCtx (e1 : {bind expr}) (e2 : {bind expr})
| FoldCtx
| UnfoldCtx | UnfoldCtx
| AllocCtx | AllocCtx
| LoadCtx | LoadCtx
...@@ -121,6 +122,7 @@ Module lang. ...@@ -121,6 +122,7 @@ Module lang.
| InjLCtx => InjL e | InjLCtx => InjL e
| InjRCtx => InjR e | InjRCtx => InjR e
| CaseCtx e1 e2 => Case e e1 e2 | CaseCtx e1 e2 => Case e e1 e2
| FoldCtx => Fold e
| UnfoldCtx => Unfold e | UnfoldCtx => Unfold e
| AllocCtx => Alloc e | AllocCtx => Alloc e
| LoadCtx => Load e | LoadCtx => Load e
...@@ -152,7 +154,8 @@ Module lang. ...@@ -152,7 +154,8 @@ Module lang.
to_val e0 = Some v0 to_val e0 = Some v0
head_step (Case (InjR e0) e1 e2) σ e2.[e0/] σ None head_step (Case (InjR e0) e1 e2) σ e2.[e0/] σ None
(* Recursive Types *) (* Recursive Types *)
| Unfold_Fold e σ : | Unfold_Fold e v σ :
to_val e = Some v
head_step (Unfold (Fold e)) σ e σ None head_step (Unfold (Fold e)) σ e σ None
(* Polymorphic Types *) (* Polymorphic Types *)
| TBeta e σ : | TBeta e σ :
...@@ -171,10 +174,13 @@ Module lang. ...@@ -171,10 +174,13 @@ Module lang.
(** Atomic expressions: we don't consider any atomic operations. *) (** Atomic expressions: we don't consider any atomic operations. *)
Definition atomic (e: expr) := Definition atomic (e: expr) :=
match e with match e with
| Alloc e => is_Some (to_val e) | Alloc e => match (to_val e) with | Some _ => true | None => false end
| Load e => is_Some (to_val e) | Load e => match (to_val e) with | Some _ => true | None => false end
| Store e1 e2 => is_Some (to_val e1) is_Some (to_val e2) | Store e1 e2 =>
| _ => False andb
match (to_val e1) with | Some _ => true | None => false end
match (to_val e2) with | Some _ => true | None => false end
| _ => false
end. end.
(** Close reduction under evaluation contexts. (** Close reduction under evaluation contexts.
...@@ -226,7 +232,7 @@ We could potentially make this a generic construction. *) ...@@ -226,7 +232,7 @@ We could potentially make this a generic construction. *)
Proof. destruct e; cbn; intuition auto. Qed. Proof. destruct e; cbn; intuition auto. Qed.
Lemma atomic_fill_item Ki e : atomic (fill_item Ki e) is_Some (to_val e). Lemma atomic_fill_item Ki e : atomic (fill_item Ki e) is_Some (to_val e).
Proof. destruct Ki; cbn; intuition. Qed. Proof. destruct Ki; cbn; repeat destruct (to_val _); cbn; intuition eauto. Qed.
Lemma atomic_fill K e : atomic (fill K e) to_val e = None K = []. Lemma atomic_fill K e : atomic (fill K e) to_val e = None K = [].
Proof. Proof.
...@@ -240,8 +246,9 @@ We could potentially make this a generic construction. *) ...@@ -240,8 +246,9 @@ We could potentially make this a generic construction. *)
atomic e1 head_step e1 σ1 e2 σ2 ef is_Some (to_val e2). atomic e1 head_step e1 σ1 e2 σ2 ef is_Some (to_val e2).
Proof. Proof.
intros H1 H2. intros H1 H2.
destruct e1; inversion H1; inversion H2; subst; destruct e1; cbn in *; inversion H2;
try rewrite to_of_val; eauto using mk_is_Some. try destruct (to_val e1); cbn in *; try inversion H1;
eauto 2 using to_of_val.
Qed. Qed.
Lemma atomic_step e1 σ1 e2 σ2 ef : Lemma atomic_step e1 σ1 e2 σ2 ef :
......
...@@ -18,7 +18,7 @@ Section logrel. ...@@ -18,7 +18,7 @@ Section logrel.
Canonical Structure leibniz_val := leibnizC val. Canonical Structure leibniz_val := leibnizC val.
Class Val_to_IProp_AlwaysStable (f : leibniz_val -n> iPropG lang Σ) := Class Val_to_IProp_AlwaysStable (f : leibniz_val -n> iPropG lang Σ) :=
val_to_iprop_always_stable : v : val, Persistent ((cofe_mor_car _ _ f) v). val_to_iprop_always_stable : v : val, PersistentP ((cofe_mor_car _ _ f) v).
Arguments val_to_iprop_always_stable /. Arguments val_to_iprop_always_stable /.
...@@ -124,14 +124,14 @@ Section logrel. ...@@ -124,14 +124,14 @@ Section logrel.
(rec_apr : (leibniz_val -n> iPropG lang Σ)) (rec_apr : (leibniz_val -n> iPropG lang Σ))
: (leibniz_val -n> iPropG lang Σ) := : (leibniz_val -n> iPropG lang Σ) :=
{| {|
cofe_mor_car := λ w, ( ( e, w = FoldV e WP e @ {{ λ v, τi rec_apr v}}))%I cofe_mor_car := λ w, ( ( v, w = FoldV v τi rec_apr v))%I
|}. |}.
Global Instance interp_rec_pre_proper : Proper (() ==> () ==> ()) interp_rec_pre. Global Instance interp_rec_pre_proper : Proper (() ==> () ==> ()) interp_rec_pre.
Proof. Proof.
intros τ1 τ1' H1 τ2 τ2' H2 w. intros τ1 τ1' H1 τ2 τ2' H2 w.
apply always_proper; apply exist_proper=>e; apply and_proper; trivial. apply always_proper; apply exist_proper=>e; apply and_proper; trivial.
apply later_proper, wp_proper=>v. apply later_proper.
rewrite H1 H2; trivial. rewrite H1 H2; trivial.
Qed. Qed.
...@@ -139,7 +139,7 @@ Section logrel. ...@@ -139,7 +139,7 @@ Section logrel.
Proof. Proof.
intros τ1 τ1' H1 τ2 τ2' H2 w. intros τ1 τ1' H1 τ2 τ2' H2 w.
apply always_ne; apply exist_ne=>e; apply and_ne; trivial. apply always_ne; apply exist_ne=>e; apply and_ne; trivial.
apply (contractive_ne _); apply wp_ne=>v. apply (contractive_ne _).
rewrite H1 H2; trivial. rewrite H1 H2; trivial.
Qed. Qed.
...@@ -151,7 +151,7 @@ Section logrel. ...@@ -151,7 +151,7 @@ Section logrel.
intros n f g H w; cbn. intros n f g H w; cbn.
apply always_ne;apply exist_ne; intros e; apply and_ne; trivial. apply always_ne;apply exist_ne; intros e; apply and_ne; trivial.
apply later_contractive =>i Hi. apply later_contractive =>i Hi.
apply wp_ne; intros v; rewrite H; trivial. rewrite H; trivial.
Qed. Qed.
Definition interp_rec (τi : (leibniz_val -n> iPropG lang Σ) -n> (leibniz_val -n> iPropG lang Σ)) Definition interp_rec (τi : (leibniz_val -n> iPropG lang Σ) -n> (leibniz_val -n> iPropG lang Σ))
...@@ -295,12 +295,21 @@ Section logrel. ...@@ -295,12 +295,21 @@ Section logrel.
let H := fresh "H" in intros H; inversion H; congruence let H := fresh "H" in intros H; inversion H; congruence
end. end.
Qed. Qed.
Lemma interp_closed_irrel_turnstile
(k : nat) (τ : type) (HC HC': closed_type k τ)
(Δ : Vlist (leibniz_val -n> iPropG lang Σ) k)
(v : val)
: interp k τ HC Δ v interp k τ HC' Δ v.
Proof.
rewrite interp_closed_irrel; trivial.
Qed.
Definition env_subst (vs : list val) (x : var) : expr := Definition env_subst (vs : list val) (x : var) : expr :=
from_option (Var x) (of_val <$> vs !! x). from_option (Var x) (of_val <$> vs !! x).
Lemma typed_subst_head_simpl k Δ τ e w ws : Lemma typed_subst_head_simpl k Δ τ e w ws :
typed k Δ e τ -> length Δ = S (length ws) typed k Δ e τ -> List.length Δ = S (List.length ws)
e.[# w .: env_subst ws] = e.[env_subst (w :: ws)] e.[# w .: env_subst ws] = e.[env_subst (w :: ws)]
. .
Proof. Proof.
...@@ -317,7 +326,7 @@ Section logrel. ...@@ -317,7 +326,7 @@ Section logrel.
(f : leibniz_val -n> iPropG lang Σ) (f : leibniz_val -n> iPropG lang Σ)
{Hf : Val_to_IProp_AlwaysStable f} {Hf : Val_to_IProp_AlwaysStable f}
(v : val) (v : val)
: Persistent (f v). : PersistentP (f v).
Proof. apply Hf. Qed. Proof. apply Hf. Qed.
Global Instance interp_always_stable Global Instance interp_always_stable
...@@ -326,11 +335,11 @@ Section logrel. ...@@ -326,11 +335,11 @@ Section logrel.
: Val_to_IProp_AlwaysStable (interp k τ H Δ). : Val_to_IProp_AlwaysStable (interp k τ H Δ).
Proof. Proof.
induction τ; cbn; intros v; try apply _. induction τ; cbn; intros v; try apply _.
- rewrite /interp_rec /Persistent fixpoint_unfold /interp_rec_pre. - rewrite /interp_rec /PersistentP fixpoint_unfold /interp_rec_pre.
apply always_intro'; trivial. apply always_intro'; trivial.
- apply (@force_lookup_Forall - apply (@force_lookup_Forall
_ _ _ _
(λ f : leibniz_val -n> iPropG lang Σ, Persistent (f v))). (λ f : leibniz_val -n> iPropG lang Σ, PersistentP (f v))).
apply Forall_forall => f H1. apply Forall_forall => f H1.
eapply Forall_forall in HΔ; [apply HΔ|trivial]. eapply Forall_forall in HΔ; [apply HΔ|trivial].
Qed. Qed.
...@@ -338,7 +347,7 @@ Section logrel. ...@@ -338,7 +347,7 @@ Section logrel.
Global Instance alwyas_stable_Δ k Δ Γ vs Global Instance alwyas_stable_Δ k Δ Γ vs
(Hctx : closed_ctx k Γ) (Hctx : closed_ctx k Γ)
{HΔ : VlistAlwaysStable Δ} {HΔ : VlistAlwaysStable Δ}
: Persistent (Π∧ zip_with (λ τ v, interp k (` τ) (proj2_sig τ) Δ v) (closed_ctx_list _ Γ Hctx) vs)%I. : PersistentP (Π∧ zip_with (λ τ v, interp k (` τ) (proj2_sig τ) Δ v) (closed_ctx_list _ Γ Hctx) vs)%I.
Proof. typeclasses eauto. Qed. Proof. typeclasses eauto. Qed.
Global Instance alwyas_stable_Vlist_cons k f Δ Global Instance alwyas_stable_Vlist_cons k f Δ
...@@ -369,7 +378,26 @@ Section logrel. ...@@ -369,7 +378,26 @@ Section logrel.
apply and_proper. apply and_proper.
- apply interp_closed_irrel. - apply interp_closed_irrel.
- apply IHΓ. - apply IHΓ.
Qed. Qed.
Lemma type_context_closed_irrel_turnstile
(k : nat) (Δ : Vlist (leibniz_val -n> iPropG lang Σ) k) (Γ : list type)
(vs : list leibniz_val)
(Hctx Hctx' : closed_ctx k Γ) :
(Π∧ zip_with
(λ (τ : {τ : type | closed_type k τ}) (v0 : leibniz_val),
((interp k (` τ) (proj2_sig τ)) Δ) v0)
(closed_ctx_list k Γ Hctx)
vs)%I
(Π∧ zip_with
(λ (τ : {τ : type | closed_type k τ}) (v : leibniz_val),
((interp k (` τ) (proj2_sig τ)) Δ) v)
(closed_ctx_list k Γ Hctx')
vs)%I.
Proof.
rewrite type_context_closed_irrel; trivial.
Qed.
Local Ltac ipropsimpl := Local Ltac ipropsimpl :=
repeat repeat
......
...@@ -8,7 +8,7 @@ From iris.program_logic Require Import ownership auth. ...@@ -8,7 +8,7 @@ From iris.program_logic Require Import ownership auth.
Import uPred. Import uPred.
Section lang_rules. Section lang_rules.
Definition heapR : cmraT := mapR loc (fracR (dec_agreeR val)). Definition heapR : cmraT := gmapR loc (fracR (dec_agreeR val)).
(** The CMRA we need. *) (** The CMRA we need. *)
Class heapG Σ := Class heapG Σ :=
...@@ -35,7 +35,7 @@ Section lang_rules. ...@@ -35,7 +35,7 @@ Section lang_rules.
Global Instance heap_inv_proper : Proper (() ==> ()) heap_inv. Global Instance heap_inv_proper : Proper (() ==> ()) heap_inv.
Proof. solve_proper. Qed. Proof. solve_proper. Qed.
Global Instance heap_ctx_always_stable N : Persistent (heap_ctx N). Global Instance heap_ctx_always_stable N : PersistentP (heap_ctx N).
Proof. apply _. Qed. Proof. apply _. Qed.
End definitions. End definitions.
Typeclasses Opaque heap_ctx heap_mapsto. Typeclasses Opaque heap_ctx heap_mapsto.
...@@ -186,7 +186,7 @@ Section lang_rules. ...@@ -186,7 +186,7 @@ Section lang_rules.
induction σ as [|l v σ Hl IH] using map_ind. induction σ as [|l v σ Hl IH] using map_ind.
{ rewrite big_sepM_empty; apply True_intro. } { rewrite big_sepM_empty; apply True_intro. }
rewrite to_heap_insert big_sepM_insert //. rewrite to_heap_insert big_sepM_insert //.
rewrite (map_insert_singleton_op (to_heap σ)); rewrite (insert_singleton_op (to_heap σ));
last rewrite lookup_fmap Hl; auto. last rewrite lookup_fmap Hl; auto.
(* FIXME: investigate why we have to unfold auth_own here. *) (* FIXME: investigate why we have to unfold auth_own here. *)
by rewrite auth_own_op IH. by rewrite auth_own_op IH.
...@@ -197,16 +197,16 @@ Section lang_rules. ...@@ -197,16 +197,16 @@ Section lang_rules.
(** General properties of mapsto *) (** General properties of mapsto *)
Lemma heap_mapsto_op_eq l q1 q2 v : Lemma heap_mapsto_op_eq l q1 q2 v :
(l {q1} v l {q2} v)%I (l {q1+q2} v)%I. (l {q1} v l {q2} v)%I (l {q1+q2} v)%I.
Proof. by rewrite -auth_own_op map_op_singleton Frac_op dec_agree_idemp. Qed. Proof. by rewrite -auth_own_op op_singleton Frac_op dec_agree_idemp. Qed.
Lemma heap_mapsto_op l q1 q2 v1 v2 : Lemma heap_mapsto_op l q1 q2 v1 v2 :
(l {q1} v1 l {q2} v2)%I (v1 = v2 l {q1+q2} v1)%I. (l {q1} v1 l {q2} v2)%I (v1 = v2 l {q1+q2} v1)%I.
Proof. Proof.
destruct (decide (v1 = v2)) as [->|]. destruct (decide (v1 = v2)) as [->|].
{ by rewrite heap_mapsto_op_eq const_equiv // left_id. } { by rewrite heap_mapsto_op_eq const_equiv // left_id. }
rewrite -auth_own_op map_op_singleton Frac_op dec_agree_ne //. rewrite -auth_own_op op_singleton Frac_op dec_agree_ne //.
apply (anti_symm ()); last by apply const_elim_l. apply (anti_symm ()); last by apply const_elim_l.
rewrite auth_own_valid map_validI (forall_elim l) lookup_singleton. rewrite auth_own_valid gmap_validI (forall_elim l) lookup_singleton.
rewrite option_validI frac_validI discrete_valid. by apply const_elim_r. rewrite option_validI frac_validI discrete_valid. by apply const_elim_r.
Qed. Qed.
...@@ -231,7 +231,7 @@ Section lang_rules. ...@@ -231,7 +231,7 @@ Section lang_rules.
cbn; rewrite to_of_val. cbn; rewrite to_of_val.
apply const_elim_l=>-[l [-> [-Heq [-> ?]]]]; inversion Heq; subst. apply const_elim_l=>-[l [-> [-Heq [-> ?]]]]; inversion Heq; subst.
by rewrite (forall_elim l) right_id const_equiv // left_id wand_elim_r. by rewrite (forall_elim l) right_id const_equiv // left_id wand_elim_r.