Commit d96b1624 authored by Filip Sieczkowski's avatar Filip Sieczkowski
Browse files

Fixed the def'n of wp to include a frame over mask, fixed all the

proofs. One change to axiomatisation was needed.
parent 02a753f4
...@@ -96,6 +96,9 @@ Module Type CORE_LANG. ...@@ -96,6 +96,9 @@ Module Type CORE_LANG.
Axiom atomic_reducible : Axiom atomic_reducible :
forall e, atomic e -> reducible e. forall e, atomic e -> reducible e.
Axiom atomic_fill :
forall e K (HAt : atomic (K [[e ]])),
K = empty_ctx.
Axiom atomic_step: forall e σ e' σ', Axiom atomic_step: forall e σ e' σ',
atomic e -> atomic e ->
......
...@@ -137,6 +137,14 @@ Module Iris (RL : PCM_T) (C : CORE_LANG). ...@@ -137,6 +137,14 @@ Module Iris (RL : PCM_T) (C : CORE_LANG).
Notation "∀ x : T , p" := (all n[(fun x : T => p)] : Props) (at level 60, x ident, no associativity) : iris_scope. Notation "∀ x : T , p" := (all n[(fun x : T => p)] : Props) (at level 60, x ident, no associativity) : iris_scope.
Notation "∃ x : T , p" := (all n[(fun x : T => p)] : Props) (at level 60, x ident, no associativity) : iris_scope. Notation "∃ x : T , p" := (all n[(fun x : T => p)] : Props) (at level 60, x ident, no associativity) : iris_scope.
Lemma valid_iff p :
valid p <-> ( p).
Proof.
split; intros Hp.
- intros w n r _; apply Hp.
- intros w n r; apply Hp; exact I.
Qed.
(** Ownership **) (** Ownership **)
Definition ownR (r : res) : Props := Definition ownR (r : res) : Props :=
pcmconst (up_cr (pord r)). pcmconst (up_cr (pord r)).
...@@ -187,7 +195,6 @@ Module Iris (RL : PCM_T) (C : CORE_LANG). ...@@ -187,7 +195,6 @@ Module Iris (RL : PCM_T) (C : CORE_LANG).
destruct r1 as [r1 |]; destruct r2 as [r2 |]; try contradiction; simpl in EQr; subst; reflexivity. destruct r1 as [r1 |]; destruct r2 as [r2 |]; try contradiction; simpl in EQr; subst; reflexivity.
Qed. Qed.
(** Lemmas about box **) (** Lemmas about box **)
Lemma box_intro p q (Hpq : p q) : Lemma box_intro p q (Hpq : p q) :
p q. p q.
...@@ -232,8 +239,6 @@ Module Iris (RL : PCM_T) (C : CORE_LANG). ...@@ -232,8 +239,6 @@ Module Iris (RL : PCM_T) (C : CORE_LANG).
destruct (Some rt · Some ru)%pcm as [rut |]; destruct (Some rt · Some ru)%pcm as [rut |];
[| now erewrite pcm_op_zero in EQr by apply _]. [| now erewrite pcm_op_zero in EQr by apply _].
exists rut; assumption. exists rut; assumption.
(* TODO: own 0 = False, own 1 = True *)
Qed. Qed.
(** Timeless *) (** Timeless *)
...@@ -477,7 +482,6 @@ Module Iris (RL : PCM_T) (C : CORE_LANG). ...@@ -477,7 +482,6 @@ Module Iris (RL : PCM_T) (C : CORE_LANG).
rewrite <- HSub; apply HTL, Hp; [reflexivity | assumption]. rewrite <- HSub; apply HTL, Hp; [reflexivity | assumption].
Qed. Qed.
(* TODO: Why do we even need the nonzero lemma about erase_state here? *)
Lemma vsOpen i p : Lemma vsOpen i p :
valid (vs (mask_sing i) mask_emp (inv i p) ( p)). valid (vs (mask_sing i) mask_emp (inv i p) ( p)).
Proof. Proof.
...@@ -570,18 +574,14 @@ Module Iris (RL : PCM_T) (C : CORE_LANG). ...@@ -570,18 +574,14 @@ Module Iris (RL : PCM_T) (C : CORE_LANG).
intros w' n r1 [Hpq Hqr] w HSub; specialize (Hpq _ HSub); rewrite HSub in Hqr; clear w' HSub. intros w' n r1 [Hpq Hqr] w HSub; specialize (Hpq _ HSub); rewrite HSub in Hqr; clear w' HSub.
intros np rp HLe HS Hp w1; intros; specialize (Hpq _ _ HLe HS Hp). intros np rp HLe HS Hp w1; intros; specialize (Hpq _ _ HLe HS Hp).
edestruct Hpq as [w2 [rq [sq [HSw12 [Hq HEq] ] ] ] ]; try eassumption; [|]. edestruct Hpq as [w2 [rq [sq [HSw12 [Hq HEq] ] ] ] ]; try eassumption; [|].
{ (* XXX: possible lemma *) { clear - HD HMS; intros j [Hmf Hm12]; apply (HD j); split; [assumption |].
clear - HD HMS.
intros j [Hmf Hm12]; apply (HD j); split; [assumption |].
destruct Hm12 as [Hm1 | Hm2]; [left; assumption | apply HMS, Hm2]. destruct Hm12 as [Hm1 | Hm2]; [left; assumption | apply HMS, Hm2].
} }
clear HS; assert (HS : pcm_unit _ rq) by (exists rq; now erewrite comm, pcm_op_unit by apply _). clear HS; assert (HS : pcm_unit _ rq) by (exists rq; now erewrite comm, pcm_op_unit by apply _).
rewrite <- HLe, HSub in Hqr; specialize (Hqr _ HSw12); clear Hpq HE w HSub Hp. rewrite <- HLe, HSub in Hqr; specialize (Hqr _ HSw12); clear Hpq HE w HSub Hp.
edestruct (Hqr (S k) _ HLe0 HS Hq w2) as [w3 [rR [sR [HSw23 [Hr HEr] ] ] ] ]; edestruct (Hqr (S k) _ HLe0 HS Hq w2) as [w3 [rR [sR [HSw23 [Hr HEr] ] ] ] ];
try (reflexivity || eassumption); [now auto with arith | |]. try (reflexivity || eassumption); [now auto with arith | |].
{ (* XXX: possible lemma *) { clear - HD HMS; intros j [Hmf Hm23]; apply (HD j); split; [assumption |].
clear - HD HMS.
intros j [Hmf Hm23]; apply (HD j); split; [assumption |].
destruct Hm23 as [Hm2 | Hm3]; [apply HMS, Hm2 | right; assumption]. destruct Hm23 as [Hm2 | Hm3]; [apply HMS, Hm2 | right; assumption].
} }
clear HEq Hq HS. clear HEq Hq HS.
...@@ -620,24 +620,6 @@ Module Iris (RL : PCM_T) (C : CORE_LANG). ...@@ -620,24 +620,6 @@ Module Iris (RL : PCM_T) (C : CORE_LANG).
clear; intros i; tauto. clear; intros i; tauto.
Qed. Qed.
(* XXX: extra lemma *)
Lemma valid_iff p :
valid p <-> ( p).
Proof.
split; intros Hp.
- intros w n r _; apply Hp.
- intros w n r; apply Hp; exact I.
Qed.
Lemma vsFalse m1 m2 : (* TODO move to derived rules *)
valid (vs m1 m2 ).
Proof.
rewrite valid_iff, box_top.
unfold vs; apply box_intro.
rewrite <- and_impl, and_projR.
apply bot_false.
Qed.
Instance LP_optres (P : option RL.res -> Prop) : LimitPreserving P. Instance LP_optres (P : option RL.res -> Prop) : LimitPreserving P.
Proof. Proof.
intros σ σc HPc; simpl; unfold option_compl. intros σ σc HPc; simpl; unfold option_compl.
...@@ -805,27 +787,27 @@ Qed. ...@@ -805,27 +787,27 @@ Qed.
Local Obligation Tactic := intros; eauto with typeclass_instances. Local Obligation Tactic := intros; eauto with typeclass_instances.
Definition wpFP m (WP : expr -n> (value -n> Props) -n> Props) e φ w n r := Definition wpFP m (WP : expr -n> (value -n> Props) -n> Props) e φ w n r :=
forall w' k s rf σ (HSw : w w') (HLt : k < n) forall w' k s rf mf σ (HSw : w w') (HLt : k < n) (HD : mf # m)
(HE : erasure σ m (Some r · rf) s w' @ S k), (HE : erasure σ (m mf) (Some r · rf) s w' @ S k),
(forall (HV : is_value e), (forall (HV : is_value e),
exists w'' r' s', w' w'' /\ φ (exist _ e HV) w'' (S k) r' exists w'' r' s', w' w'' /\ φ (exist _ e HV) w'' (S k) r'
/\ erasure σ m (Some r' · rf) s' w'' @ S k) /\ /\ erasure σ (m mf) (Some r' · rf) s' w'' @ S k) /\
(forall σ' ei ei' K (HDec : e = K [[ ei ]]) (forall σ' ei ei' K (HDec : e = K [[ ei ]])
(HStep : prim_step (ei, σ) (ei', σ')), (HStep : prim_step (ei, σ) (ei', σ')),
exists w'' r' s', w' w'' /\ WP (K [[ ei' ]]) φ w'' k r' exists w'' r' s', w' w'' /\ WP (K [[ ei' ]]) φ w'' k r'
/\ erasure σ' m (Some r' · rf) s' w'' @ k) /\ /\ erasure σ' (m mf) (Some r' · rf) s' w'' @ k) /\
(forall e' K (HDec : e = K [[ fork e' ]]), (forall e' K (HDec : e = K [[ fork e' ]]),
exists w'' rfk rret s', w' w'' exists w'' rfk rret s', w' w''
/\ WP (K [[ fork_ret ]]) φ w'' k rret /\ WP (K [[ fork_ret ]]) φ w'' k rret
/\ WP e' (umconst ) w'' k rfk /\ WP e' (umconst ) w'' k rfk
/\ erasure σ m (Some rfk · Some rret · rf) s' w'' @ k). /\ erasure σ (m mf) (Some rfk · Some rret · rf) s' w'' @ k).
Program Definition wpF m : (expr -n> (value -n> Props) -n> Props) -n> expr -n> (value -n> Props) -n> Props := Program Definition wpF m : (expr -n> (value -n> Props) -n> Props) -n> expr -n> (value -n> Props) -n> Props :=
n[(fun WP => n[(fun e => n[(fun φ => m[(fun w => mkUPred (wpFP m WP e φ w) _)])])])]. n[(fun WP => n[(fun e => n[(fun φ => m[(fun w => mkUPred (wpFP m WP e φ w) _)])])])].
Next Obligation. Next Obligation.
intros n1 n2 r1 r2 HLe [rd EQr] Hp w' k s rf σ HSw HLt HE. intros n1 n2 r1 r2 HLe [rd EQr] Hp w' k s rf mf σ HSw HLt HD HE.
rewrite <- EQr, (comm (Some rd)), <- assoc in HE. rewrite <- EQr, (comm (Some rd)), <- assoc in HE.
specialize (Hp w' k s (Some rd · rf) σ); destruct Hp as [HV [HS HF] ]; specialize (Hp w' k s (Some rd · rf) mf σ); destruct Hp as [HV [HS HF] ];
[| now eauto with arith | ..]; try assumption; []. [| now eauto with arith | ..]; try assumption; [].
split; [clear HS HF | split; [clear HV HF | clear HV HS] ]; intros. split; [clear HS HF | split; [clear HV HF | clear HV HS] ]; intros.
- specialize (HV HV0); destruct HV as [w'' [r1' [s' [HSw' [Hφ HE'] ] ] ] ]. - specialize (HV HV0); destruct HV as [w'' [r1' [s' [HSw' [Hφ HE'] ] ] ] ].
...@@ -1013,7 +995,7 @@ Qed. ...@@ -1013,7 +995,7 @@ Qed.
(WPTP : wptp m w n tp rs) : (WPTP : wptp m w n tp rs) :
wptp m w n (e :: tp) (r :: rs). wptp m w n (e :: tp) (r :: rs).
(* Trivial lemma about application split *) (* Trivial lemmas about split over append *)
Lemma wptp_app m w n tp1 tp2 rs1 rs2 Lemma wptp_app m w n tp1 tp2 rs1 rs2
(HW1 : wptp m w n tp1 rs1) (HW1 : wptp m w n tp1 rs1)
(HW2 : wptp m w n tp2 rs2) : (HW2 : wptp m w n tp2 rs2) :
...@@ -1022,17 +1004,6 @@ Qed. ...@@ -1022,17 +1004,6 @@ Qed.
induction HW1; [| constructor]; now trivial. induction HW1; [| constructor]; now trivial.
Qed. Qed.
(* Closure under future worlds and smaller steps *)
Lemma wptp_closure m (w1 w2 : Wld) n1 n2 tp rs
(HSW : w1 w2) (HLe : n2 <= n1)
(HW : wptp m w1 n1 tp rs) :
wptp m w2 n2 tp rs.
Proof.
induction HW; constructor; [| assumption].
eapply uni_pred; [eassumption | reflexivity |].
rewrite <- HSW; assumption.
Qed.
Lemma wptp_app_tp m w n t1 t2 rs Lemma wptp_app_tp m w n t1 t2 rs
(HW : wptp m w n (t1 ++ t2) rs) : (HW : wptp m w n (t1 ++ t2) rs) :
exists rs1 rs2, rs1 ++ rs2 = rs /\ wptp m w n t1 rs1 /\ wptp m w n t2 rs2. exists rs1 rs2, rs1 ++ rs2 = rs /\ wptp m w n t1 rs1 /\ wptp m w n t2 rs2.
...@@ -1051,6 +1022,17 @@ Qed. ...@@ -1051,6 +1022,17 @@ Qed.
now rewrite IHrs1, assoc. now rewrite IHrs1, assoc.
Qed. Qed.
(* Closure under future worlds and smaller steps *)
Lemma wptp_closure m (w1 w2 : Wld) n1 n2 tp rs
(HSW : w1 w2) (HLe : n2 <= n1)
(HW : wptp m w1 n1 tp rs) :
wptp m w2 n2 tp rs.
Proof.
induction HW; constructor; [| assumption].
eapply uni_pred; [eassumption | reflexivity |].
rewrite <- HSW; assumption.
Qed.
Definition wf_nat_ind := well_founded_induction Wf_nat.lt_wf. Definition wf_nat_ind := well_founded_induction Wf_nat.lt_wf.
Lemma unfold_wp m : Lemma unfold_wp m :
...@@ -1072,9 +1054,11 @@ Qed. ...@@ -1072,9 +1054,11 @@ Qed.
intros; inversion HSN; subst; clear HSN. intros; inversion HSN; subst; clear HSN.
(* e is a value *) (* e is a value *)
{ rename e' into e; clear HInd HWTP; simpl plus in *; rewrite unfold_wp in HWE. { rename e' into e; clear HInd HWTP; simpl plus in *; rewrite unfold_wp in HWE.
edestruct (HWE w k) as [HVal _]; [reflexivity | unfold lt; reflexivity | eassumption |]. edestruct (HWE w k) as [HVal _];
[reflexivity | unfold lt; reflexivity | apply mask_emp_disjoint
| rewrite mask_emp_union; eassumption |].
specialize (HVal HV); destruct HVal as [w' [r' [s' [HSW [Hφ HE'] ] ] ] ]. specialize (HVal HV); destruct HVal as [w' [r' [s' [HSW [Hφ HE'] ] ] ] ].
destruct (Some r' · comp_list rs) as [r'' |] eqn: EQr. rewrite mask_emp_union in HE'; destruct (Some r' · comp_list rs) as [r'' |] eqn: EQr.
- exists w' r'' s'; split; [assumption | split; [| assumption] ]. - exists w' r'' s'; split; [assumption | split; [| assumption] ].
eapply uni_pred, Hφ; [reflexivity |]. eapply uni_pred, Hφ; [reflexivity |].
rewrite ord_res_optRes; exists (comp_list rs); rewrite comm, EQr; reflexivity. rewrite ord_res_optRes; exists (comp_list rs); rewrite comm, EQr; reflexivity.
...@@ -1086,15 +1070,16 @@ Qed. ...@@ -1086,15 +1070,16 @@ Qed.
{ destruct t1 as [| ee t1]; inversion H0; subst; clear H0. { destruct t1 as [| ee t1]; inversion H0; subst; clear H0.
(* step in e *) (* step in e *)
- simpl in HSN0; rewrite unfold_wp in HWE; edestruct (HWE w (n + S k)) as [_ [HS _] ]; - simpl in HSN0; rewrite unfold_wp in HWE; edestruct (HWE w (n + S k)) as [_ [HS _] ];
[reflexivity | apply le_n | eassumption |]. [reflexivity | apply le_n | apply mask_emp_disjoint | rewrite mask_emp_union; eassumption |].
edestruct HS as [w' [r' [s' [HSW [HWE' HE'] ] ] ] ]; [reflexivity | eassumption | clear HS HWE HE]. edestruct HS as [w' [r' [s' [HSW [HWE' HE'] ] ] ] ]; [reflexivity | eassumption | clear HS HWE HE].
setoid_rewrite HSW; eapply HInd; try eassumption. rewrite mask_emp_union in HE'; setoid_rewrite HSW; eapply HInd; try eassumption.
eapply wptp_closure, HWTP; [assumption | now auto with arith]. eapply wptp_closure, HWTP; [assumption | now auto with arith].
(* step in a spawned thread *) (* step in a spawned thread *)
- apply wptp_app_tp in HWTP; destruct HWTP as [rs1 [rs2 [EQrs [HWTP1 HWTP2] ] ] ]. - apply wptp_app_tp in HWTP; destruct HWTP as [rs1 [rs2 [EQrs [HWTP1 HWTP2] ] ] ].
inversion HWTP2; subst; clear HWTP2; rewrite unfold_wp in WPE. inversion HWTP2; subst; clear HWTP2; rewrite unfold_wp in WPE.
edestruct (WPE w (n + S k) s (Some r · comp_list (rs1 ++ rs0))) as [_ [HS _] ]; edestruct (WPE w (n + S k) s (Some r · comp_list (rs1 ++ rs0))) as [_ [HS _] ];
[reflexivity | apply le_n | eapply erasure_equiv, HE; try reflexivity; [] |]. [reflexivity | apply le_n | apply mask_emp_disjoint
| eapply erasure_equiv, HE; try reflexivity; [apply mask_emp_union |] |].
+ rewrite !comp_list_app; simpl comp_list; unfold equiv. + rewrite !comp_list_app; simpl comp_list; unfold equiv.
rewrite assoc, (comm (Some r0)), <- assoc; apply pcm_op_equiv; [reflexivity |]. rewrite assoc, (comm (Some r0)), <- assoc; apply pcm_op_equiv; [reflexivity |].
now rewrite assoc, (comm (Some r0)), <- assoc. now rewrite assoc, (comm (Some r0)), <- assoc.
...@@ -1104,7 +1089,7 @@ Qed. ...@@ -1104,7 +1089,7 @@ Qed.
* rewrite <- HSW; eapply uni_pred, HWE; [now auto with arith | reflexivity]. * rewrite <- HSW; eapply uni_pred, HWE; [now auto with arith | reflexivity].
* apply wptp_app; [eapply wptp_closure, HWTP1; [assumption | now auto with arith] |]. * apply wptp_app; [eapply wptp_closure, HWTP1; [assumption | now auto with arith] |].
constructor; [eassumption | eapply wptp_closure, WPTP; [assumption | now auto with arith] ]. constructor; [eassumption | eapply wptp_closure, WPTP; [assumption | now auto with arith] ].
* eapply erasure_equiv, HE'; try reflexivity; []. * eapply erasure_equiv, HE'; try reflexivity; [symmetry; apply mask_emp_union |].
rewrite assoc, (comm (Some r0')), <- assoc; apply pcm_op_equiv; [reflexivity |]. rewrite assoc, (comm (Some r0')), <- assoc; apply pcm_op_equiv; [reflexivity |].
rewrite !comp_list_app; simpl comp_list. rewrite !comp_list_app; simpl comp_list.
now rewrite assoc, (comm (comp_list rs1)), <- assoc. now rewrite assoc, (comm (comp_list rs1)), <- assoc.
...@@ -1113,12 +1098,12 @@ Qed. ...@@ -1113,12 +1098,12 @@ Qed.
destruct t1 as [| ee t1]; inversion H; subst; clear H. destruct t1 as [| ee t1]; inversion H; subst; clear H.
(* fork from e *) (* fork from e *)
- simpl in HSN0; rewrite unfold_wp in HWE; edestruct (HWE w (n + S k)) as [_ [_ HF] ]; - simpl in HSN0; rewrite unfold_wp in HWE; edestruct (HWE w (n + S k)) as [_ [_ HF] ];
[reflexivity | apply le_n | eassumption |]. [reflexivity | apply le_n | apply mask_emp_disjoint | rewrite mask_emp_union; eassumption |].
specialize (HF _ _ eq_refl); destruct HF as [w' [rfk [rret [s' [HSW [HWE' [HWFK HE'] ] ] ] ] ] ]. specialize (HF _ _ eq_refl); destruct HF as [w' [rfk [rret [s' [HSW [HWE' [HWFK HE'] ] ] ] ] ] ].
clear HWE HE; setoid_rewrite HSW; eapply HInd with (rs := rs ++ [rfk]); try eassumption; [|]. clear HWE HE; setoid_rewrite HSW; eapply HInd with (rs := rs ++ [rfk]); try eassumption; [|].
+ apply wptp_app; [| now auto using wptp]. + apply wptp_app; [| now auto using wptp].
eapply wptp_closure, HWTP; [assumption | now auto with arith]. eapply wptp_closure, HWTP; [assumption | now auto with arith].
+ eapply erasure_equiv, HE'; try reflexivity; []; unfold equiv; clear. + eapply erasure_equiv, HE'; try reflexivity; [symmetry; apply mask_emp_union |].
rewrite (comm (Some rfk)), <- assoc; apply pcm_op_equiv; [reflexivity |]. rewrite (comm (Some rfk)), <- assoc; apply pcm_op_equiv; [reflexivity |].
rewrite comp_list_app; simpl comp_list; rewrite comm. rewrite comp_list_app; simpl comp_list; rewrite comm.
now erewrite (comm _ 1), pcm_op_unit by apply _. now erewrite (comm _ 1), pcm_op_unit by apply _.
...@@ -1126,7 +1111,8 @@ Qed. ...@@ -1126,7 +1111,8 @@ Qed.
- apply wptp_app_tp in HWTP; destruct HWTP as [rs1 [rs2 [EQrs [HWTP1 HWTP2] ] ] ]. - apply wptp_app_tp in HWTP; destruct HWTP as [rs1 [rs2 [EQrs [HWTP1 HWTP2] ] ] ].
inversion HWTP2; subst; clear HWTP2; rewrite unfold_wp in WPE. inversion HWTP2; subst; clear HWTP2; rewrite unfold_wp in WPE.
edestruct (WPE w (n + S k) s (Some r · comp_list (rs1 ++ rs0))) as [_ [_ HF] ]; edestruct (WPE w (n + S k) s (Some r · comp_list (rs1 ++ rs0))) as [_ [_ HF] ];
[reflexivity | apply le_n | eapply erasure_equiv, HE; try reflexivity; [] |]. [reflexivity | apply le_n | apply mask_emp_disjoint
| eapply erasure_equiv, HE; try reflexivity; [apply mask_emp_union |] |].
+ rewrite assoc, (comm (Some r0)), <- assoc; apply pcm_op_equiv; [reflexivity |]. + rewrite assoc, (comm (Some r0)), <- assoc; apply pcm_op_equiv; [reflexivity |].
rewrite !comp_list_app; simpl comp_list; now rewrite assoc, (comm (Some r0)), <- assoc. rewrite !comp_list_app; simpl comp_list; now rewrite assoc, (comm (Some r0)), <- assoc.
+ specialize (HF _ _ eq_refl); destruct HF as [w' [rfk [rret [s' [HSW [WPE' [WPS HE'] ] ] ] ] ] ]; clear WPE. + specialize (HF _ _ eq_refl); destruct HF as [w' [rfk [rret [s' [HSW [WPE' [WPS HE'] ] ] ] ] ] ]; clear WPE.
...@@ -1135,7 +1121,7 @@ Qed. ...@@ -1135,7 +1121,7 @@ Qed.
* apply wptp_app; [eapply wptp_closure, HWTP1; [assumption | now auto with arith] |]. * apply wptp_app; [eapply wptp_closure, HWTP1; [assumption | now auto with arith] |].
constructor; [eassumption | apply wptp_app; [| now eauto using wptp] ]. constructor; [eassumption | apply wptp_app; [| now eauto using wptp] ].
eapply wptp_closure, WPTP; [assumption | now auto with arith]. eapply wptp_closure, WPTP; [assumption | now auto with arith].
* eapply erasure_equiv, HE'; try reflexivity; []. * eapply erasure_equiv, HE'; try reflexivity; [symmetry; apply mask_emp_union |].
rewrite (assoc _ (Some r)), (comm _ (Some r)), <- assoc. rewrite (assoc _ (Some r)), (comm _ (Some r)), <- assoc.
apply pcm_op_equiv; [reflexivity |]. apply pcm_op_equiv; [reflexivity |].
rewrite (comm (Some rfk)), <- assoc, comp_list_app; simpl comp_list. rewrite (comm (Some rfk)), <- assoc, comp_list_app; simpl comp_list.
...@@ -1196,25 +1182,26 @@ Qed. ...@@ -1196,25 +1182,26 @@ Qed.
valid (ht m e (eqV (exist _ e HV))). valid (ht m e (eqV (exist _ e HV))).
Proof. Proof.
intros w' nn rr w _ n r' _ _ _; clear w' nn rr. intros w' nn rr w _ n r' _ _ _; clear w' nn rr.
unfold wp; rewrite fixp_eq; fold (wp m). rewrite unfold_wp; intros w'; intros; split; [| split]; intros.
intros w'; intros; split; [| split]; intros.
- exists w' r' s; split; [reflexivity | split; [| assumption] ]. - exists w' r' s; split; [reflexivity | split; [| assumption] ].
simpl; reflexivity. simpl; reflexivity.
- assert (HT := values_stuck _ HV). - contradiction (values_stuck _ HV _ _ HDec).
eapply HT in HStep; [contradiction | eassumption]. repeat eexists; eassumption.
- subst e; assert (HT := fill_value _ _ HV); subst K. - subst e; assert (HT := fill_value _ _ HV); subst K.
revert HV; rewrite fill_empty; intros. revert HV; rewrite fill_empty; intros.
contradiction (fork_not_value _ HV). contradiction (fork_not_value _ HV).
Qed. Qed.
Implicit Type (C : Props).
Lemma wpO m e φ w r : wp m e φ w O r. Lemma wpO m e φ w r : wp m e φ w O r.
Proof. Proof.
unfold wp; rewrite fixp_eq; fold (wp m); intros w'; intros; now inversion HLt. rewrite unfold_wp; intros w'; intros; now inversion HLt.
Qed. Qed.
(** Bind **) (** Bind **)
(** Quantification in the logic works over nonexpansive maps, so
we need to show that plugging the value into the postcondition
and context is nonexpansive. *)
Program Definition plugV m φ φ' K := Program Definition plugV m φ φ' K :=
n[(fun v : value => ht m (φ v) (K [[` v]]) φ')]. n[(fun v : value => ht m (φ v) (K [[` v]]) φ')].
Next Obligation. Next Obligation.
...@@ -1237,23 +1224,22 @@ Qed. ...@@ -1237,23 +1224,22 @@ Qed.
specialize (He _ HSw _ _ HLe (unit_min _) HP). specialize (He _ HSw _ _ HLe (unit_min _) HP).
rewrite HSw, <- HLe in HK; clear wz nz HSw HLe HP. rewrite HSw, <- HLe in HK; clear wz nz HSw HLe HP.
revert e w r He HK; induction n using wf_nat_ind; intros; rename H into IH. revert e w r He HK; induction n using wf_nat_ind; intros; rename H into IH.
unfold wp; rewrite fixp_eq; fold (wp m). rewrite unfold_wp in He; rewrite unfold_wp.
unfold wp in He; rewrite fixp_eq in He; fold (wp m) in He.
destruct (is_value_dec e) as [HVal | HNVal]; [clear IH |]. destruct (is_value_dec e) as [HVal | HNVal]; [clear IH |].
- intros w'; intros; edestruct He as [HV _]; try eassumption; []. - intros w'; intros; edestruct He as [HV _]; try eassumption; [].
clear He HE; specialize (HV HVal); destruct HV as [w'' [r' [s' [HSw' [Hφ HE] ] ] ] ]. clear He HE; specialize (HV HVal); destruct HV as [w'' [r' [s' [HSw' [Hφ HE] ] ] ] ].
(* Fold the goal back into a wp *) (* Fold the goal back into a wp *)
setoid_rewrite HSw'. setoid_rewrite HSw'.
assert (HT : wp m (K [[ e ]]) φ' w'' (S k) r'); assert (HT : wp m (K [[ e ]]) φ' w'' (S k) r');
[| unfold wp in HT; rewrite fixp_eq in HT; fold (wp m) in HT; [| rewrite unfold_wp in HT; eapply HT; [reflexivity | unfold lt; reflexivity | eassumption | eassumption] ].
eapply HT; [reflexivity | unfold lt; reflexivity | eassumption] ].
clear HE; specialize (HK (exist _ e HVal)). clear HE; specialize (HK (exist _ e HVal)).
do 30 red in HK; unfold proj1_sig in HK. do 30 red in HK; unfold proj1_sig in HK.
apply HK; [etransitivity; eassumption | apply HLt | apply unit_min | assumption]. apply HK; [etransitivity; eassumption | apply HLt | apply unit_min | assumption].
- intros w'; intros; edestruct He as [_ [HS HF] ]; try eassumption; []. - intros w'; intros; edestruct He as [_ [HS HF] ]; try eassumption; [].
split; [intros HVal; contradiction HNVal; assert (HT := fill_value _ _ HVal); split; [intros HVal; contradiction HNVal; assert (HT := fill_value _ _ HVal);
subst K; rewrite fill_empty in HVal; assumption | split; intros]. subst K; rewrite fill_empty in HVal; assumption | split; intros].
+ clear He HF HE; edestruct step_by_value as [K' EQK]; try eassumption; []. + clear He HF HE; edestruct step_by_value as [K' EQK];
[eassumption | repeat eexists; eassumption | eassumption |].
subst K0; rewrite <- fill_comp in HDec; apply fill_inj2 in HDec. subst K0; rewrite <- fill_comp in HDec; apply fill_inj2 in HDec.
edestruct HS as [w'' [r' [s' [HSw' [He HE] ] ] ] ]; try eassumption; []. edestruct HS as [w'' [r' [s' [HSw' [He HE] ] ] ] ]; try eassumption; [].
subst e; clear HStep HS. subst e; clear HStep HS.
...@@ -1271,6 +1257,9 @@ Qed. ...@@ -1271,6 +1257,9 @@ Qed.
(** Consequence **) (** Consequence **)
(** Much like in the case of the plugging, we need to show that
the map from a value to a view shift between the applied
postconditions is nonexpansive *)
Program Definition vsLift m1 m2 φ φ' := Program Definition vsLift m1 m2 φ φ' :=
n[(fun v => vs m1 m2 (φ v) (φ' v))]. n[(fun v => vs m1 m2 (φ v) (φ' v))].
Next Obligation. Next Obligation.
...@@ -1286,40 +1275,32 @@ Qed. ...@@ -1286,40 +1275,32 @@ Qed.
vs m m P P' ht m P' e φ' all (vsLift m m φ' φ) ht m P e φ. vs m m P P' ht m P' e φ' all (vsLift m m φ' φ) ht m P e φ.
Proof. Proof.
intros wz nz rz [ [HP He] Hφ] w HSw n r HLe _ Hp. intros wz nz rz [ [HP He] Hφ] w HSw n r HLe _ Hp.
specialize (HP _ HSw _ _ HLe (unit_min _) Hp). specialize (HP _ HSw _ _ HLe (unit_min _) Hp); rewrite unfold_wp.
unfold wp; rewrite fixp_eq; fold (wp m).
rewrite <- HLe, HSw in He, Hφ; clear wz nz HSw HLe Hp. rewrite <- HLe, HSw in He, Hφ; clear wz nz HSw HLe Hp.
intros w'; intros; edestruct HP with (mf := mask_emp) as [w'' [r' [s' [HSw' [Hp' HE'] ] ] ] ]; try eassumption; intros w'; intros; edestruct HP as [w'' [r' [s' [HSw' [Hp' HE'] ] ] ] ]; try eassumption; [now rewrite mask_union_idem |].
[intros j; tauto | eapply erasure_equiv, HE; try reflexivity; unfold mask_emp, const; intros j; tauto |].
clear HP HE; rewrite HSw in He; specialize (He w'' HSw' _ r' HLt (unit_min _) Hp'). clear HP HE; rewrite HSw in He; specialize (He w'' HSw' _ r' HLt (unit_min _) Hp').
setoid_rewrite HSw'. setoid_rewrite HSw'.
assert (HT : wp m e φ w'' (S k) r'); assert (HT : wp m e φ w'' (S k) r');
[| unfold wp in HT; rewrite fixp_eq in HT; fold (wp m) in HT; [| rewrite unfold_wp in HT; eapply HT; [reflexivity | apply le_n | eassumption | eassumption] ].
eapply HT; [reflexivity | unfold lt; reflexivity |];
eapply erasure_equiv, HE'; try reflexivity; unfold mask_emp, const; intros j; tauto ].
unfold lt in HLt; rewrite HSw, HSw', <- HLt in Hφ; clear - He Hφ. unfold lt in HLt; rewrite HSw, HSw', <- HLt in Hφ; clear - He Hφ.
(* Second phase of the proof: got rid of the preconditions, (* Second phase of the proof: got rid of the preconditions,
now induction takes care of the evaluation. *) now induction takes care of the evaluation. *)
rename r' into r; rename w'' into w. rename r' into r; rename w'' into w.
revert w r e He Hφ; generalize (S k) as n; clear k; induction n using wf_nat_ind. revert w r e He Hφ; generalize (S k) as n; clear k; induction n using wf_nat_ind.
rename H into IH; intros; unfold wp; rewrite fixp_eq; fold (wp m). rename H into IH; intros; rewrite unfold_wp; rewrite unfold_wp in He.
unfold wp in He; rewrite fixp_eq in He; fold (wp m).
intros w'; intros; edestruct He as [HV [HS HF] ]; try eassumption; []. intros w'; intros; edestruct He as [HV [HS HF] ]; try eassumption; [].
split; [intros HVal; clear HS HF IH | split; intros; [clear HV HF | clear HV HS] ]. split; [intros HVal; clear HS HF IH | split; intros; [clear HV HF | clear HV HS] ].
- clear He HE; specialize (HV HVal); destruct HV as [w'' [r' [s' [HSw' [Hφ' HE] ] ] ] ]. - clear He HE; specialize (HV HVal); destruct HV as [w'' [r' [s' [HSw' [Hφ' HE] ] ] ] ].
eapply Hφ in Hφ'; [| etransitivity; eassumption | apply HLt | apply unit_min]. eapply Hφ in Hφ'; [| etransitivity; eassumption