Commit 246061ef authored by Hai Dang's avatar Hai Dang
Browse files

deref/ref take results

parent 2f224774
...@@ -474,16 +474,18 @@ Proof. ...@@ -474,16 +474,18 @@ Proof.
- by exists (Ki :: K'). - by exists (Ki :: K').
Qed. Qed.
Lemma tstep_ref_inv l tg T e' σ σ' Lemma tstep_ref_inv (pl: result) e' σ σ'
(STEP: ((& (Place l tg T))%E, σ) ~{fns}~> (e', σ')) : (STEP: ((& pl)%E, σ) ~{fns}~> (e', σ')) :
e' = #[ScPtr l tg]%E σ' = σ is_Some (σ.(shp) !! l). l tg T, pl = PlaceR l tg T e' = #[ScPtr l tg]%E σ' = σ is_Some (σ.(shp) !! l).
Proof. Proof.
inv_tstep. symmetry in Eq. inv_tstep. symmetry in Eq.
destruct (fill_ref_decompose _ _ _ Eq) destruct (fill_ref_decompose _ _ _ Eq)
as [[]|[K' [? Eq']]]; subst. as [[]|[K' [? Eq']]]; subst.
- clear Eq. simpl in HS. by inv_head_step. - clear Eq. simpl in HS. inv_head_step.
have Eq1 := to_of_result pl. rewrite -H /to_result in Eq1. simplify_eq.
naive_solver.
- apply result_head_stuck, (fill_not_result _ K') in HS. - apply result_head_stuck, (fill_not_result _ K') in HS.
by rewrite Eq' in HS. by rewrite Eq' to_of_result in HS.
Qed. Qed.
(** Deref *) (** Deref *)
...@@ -498,17 +500,19 @@ Proof. ...@@ -498,17 +500,19 @@ Proof.
- by exists (Ki :: K'). - by exists (Ki :: K').
Qed. Qed.
Lemma tstep_deref_inv l tg T e' σ σ' Lemma tstep_deref_inv (rf: result) T e' σ σ'
(STEP: ((Deref #[ScPtr l tg] T)%E, σ) ~{fns}~> (e', σ')) : (STEP: ((Deref rf T)%E, σ) ~{fns}~> (e', σ')) :
e' = Place l tg T σ' = σ l tg, rf = (ValR [ScPtr l tg])%R e' = Place l tg T σ' = σ
( (i: nat), (i < tsize T)%nat l + i dom (gset loc) σ.(shp)). ( (i: nat), (i < tsize T)%nat l + i dom (gset loc) σ.(shp)).
Proof. Proof.
inv_tstep. symmetry in Eq. inv_tstep. symmetry in Eq.
destruct (fill_deref_decompose _ _ _ _ Eq) destruct (fill_deref_decompose _ _ _ _ Eq)
as [[]|[K' [? Eq']]]; subst. as [[]|[K' [? Eq']]]; subst.
- clear Eq. simpl in HS. by inv_head_step. - clear Eq. simpl in HS. inv_head_step.
have Eq1 := to_of_result rf. rewrite -H0 /to_result in Eq1. simplify_eq.
naive_solver.
- apply result_head_stuck, (fill_not_result _ K') in HS. - apply result_head_stuck, (fill_not_result _ K') in HS.
by rewrite Eq' in HS. by rewrite Eq' to_of_result in HS.
Qed. Qed.
(** Call *) (** Call *)
...@@ -728,17 +732,21 @@ Proof. ...@@ -728,17 +732,21 @@ Proof.
- subst K. by exists (Ki :: K0). - subst K. by exists (Ki :: K0).
Qed. Qed.
Lemma tstep_copy_inv l tg T e' σ σ' Lemma tstep_copy_inv (pl: result) e' σ σ'
(STEP: (Copy (Place l tg T), σ) ~{fns}~> (e', σ')) : (STEP: (Copy pl, σ) ~{fns}~> (e', σ')) :
v α', e' = Val v read_mem l (tsize T) σ.(shp) = Some v l tg T v α',
pl = PlaceR l tg T
e' = Val v read_mem l (tsize T) σ.(shp) = Some v
memory_read σ.(sst) σ.(scs) l tg (tsize T) = Some α' memory_read σ.(sst) σ.(scs) l tg (tsize T) = Some α'
σ' = mkState σ.(shp) α' σ.(scs) σ.(snp) σ.(snc). σ' = mkState σ.(shp) α' σ.(scs) σ.(snp) σ.(snc).
Proof. Proof.
inv_tstep. symmetry in Eq. inv_tstep. symmetry in Eq.
destruct (fill_copy_decompose _ _ _ Eq) as [[]|[K' [? Eq']]]; subst. destruct (fill_copy_decompose _ _ _ Eq) as [[]|[K' [? Eq']]]; subst.
- clear Eq. simpl in HS. inv_head_step. naive_solver. - clear Eq. simpl in HS. inv_head_step.
have Eq1 := to_of_result pl. rewrite -H0 /to_result in Eq1. simplify_eq.
naive_solver.
- exfalso. apply val_head_stuck in HS. destruct (fill_val K' e1') as [? Eq1']. - exfalso. apply val_head_stuck in HS. destruct (fill_val K' e1') as [? Eq1'].
+ rewrite /= Eq'. by eexists. + rewrite /= Eq' to_of_result. by eexists.
+ by rewrite Eq1' in HS. + by rewrite Eq1' in HS.
Qed. Qed.
...@@ -776,9 +784,12 @@ Proof. ...@@ -776,9 +784,12 @@ Proof.
- subst K. right. by exists r1, (Ki :: K'). - subst K. right. by exists r1, (Ki :: K').
Qed. Qed.
Lemma tstep_write_inv l tg T v e' σ σ' Lemma tstep_write_inv (pl r: result) e' σ σ'
(STEP: ((Place l tg T <- #v)%E, σ) ~{fns}~> (e', σ')) : (STEP: ((pl <- r)%E, σ) ~{fns}~> (e', σ')) :
α', e' = (#[]%V) l tg T v α',
pl = PlaceR l tg T
r = ValR v
e' = (#[]%V)
memory_written σ.(sst) σ.(scs) l tg (tsize T) = Some α' memory_written σ.(sst) σ.(scs) l tg (tsize T) = Some α'
( (i: nat), (i < length v)%nat l + i dom (gset loc) σ.(shp)) ( (i: nat), (i < length v)%nat l + i dom (gset loc) σ.(shp))
(v <<t σ.(snp)) (length v = tsize T) (v <<t σ.(snp)) (length v = tsize T)
...@@ -787,12 +798,15 @@ Proof. ...@@ -787,12 +798,15 @@ Proof.
inv_tstep. symmetry in Eq. inv_tstep. symmetry in Eq.
destruct (fill_write_decompose _ _ _ _ Eq) destruct (fill_write_decompose _ _ _ _ Eq)
as [[]|[[K' [? Eq']]|[? [K' [? [Eq' ?]]]]]]; subst. as [[]|[[K' [? Eq']]|[? [K' [? [Eq' ?]]]]]]; subst.
- clear Eq. simpl in HS. inv_head_step. naive_solver. - clear Eq. simpl in HS. inv_head_step.
have Eq1 := to_of_result pl. rewrite -H0 /to_result in Eq1.
have Eq2 := to_of_result r. rewrite -H1 /to_result in Eq2. simplify_eq.
naive_solver.
- exfalso. apply val_head_stuck in HS. destruct (fill_val K' e1') as [? Eq1']. - exfalso. apply val_head_stuck in HS. destruct (fill_val K' e1') as [? Eq1'].
+ rewrite /= Eq'. by eexists. + rewrite /= Eq' to_of_result. by eexists.
+ by rewrite Eq1' in HS. + by rewrite Eq1' in HS.
- exfalso. apply val_head_stuck in HS. destruct (fill_val K' e1') as [? Eq1']. - exfalso. apply val_head_stuck in HS. destruct (fill_val K' e1') as [? Eq1'].
+ rewrite /= Eq'. by eexists. + rewrite /= Eq' to_of_result. by eexists.
+ by rewrite Eq1' in HS. + by rewrite Eq1' in HS.
Qed. Qed.
......
...@@ -14,8 +14,10 @@ Lemma sim_body_copy_left_1 ...@@ -14,8 +14,10 @@ Lemma sim_body_copy_left_1
Proof. Proof.
intros COND. pfold. intros NT r_f WSAT. intros COND. pfold. intros NT r_f WSAT.
edestruct NT as [[]|[es1 [σs1 STEP1]]]; [constructor 1|done|]. edestruct NT as [[]|[es1 [σs1 STEP1]]]; [constructor 1|done|].
destruct (tstep_copy_inv _ _ _ _ _ _ _ STEP1) as (vs & α' & ? & Eqvs & READ & ?). destruct (tstep_copy_inv _ (PlaceR l (Tagged t) int) _ _ _ STEP1)
subst es1 σs1. rewrite /= read_mem_equation_1 /= in Eqvs. as (l' & t' & T' & vs & α' & EqH & ? & Eqvs & READ & ?).
symmetry in EqH. simplify_eq.
rewrite /= read_mem_equation_1 /= in Eqvs.
destruct (σs.(shp) !! l) as [s|] eqn:Eqs; [|done]. simpl in Eqvs. simplify_eq. destruct (σs.(shp) !! l) as [s|] eqn:Eqs; [|done]. simpl in Eqvs. simplify_eq.
specialize (COND _ eq_refl). specialize (COND _ eq_refl).
......
...@@ -102,13 +102,14 @@ Proof. ...@@ -102,13 +102,14 @@ Proof.
move=>Hwf xs Hxswf /=. sim_bind (subst_map _ e) (subst_map _ e). move=>Hwf xs Hxswf /=. sim_bind (subst_map _ e) (subst_map _ e).
eapply sim_simple_post_mono, IHe; [|by auto..]. eapply sim_simple_post_mono, IHe; [|by auto..].
intros r' n' rs css' rt cst' (-> & -> & -> & Hrel). simpl. intros r' n' rs css' rt cst' (-> & -> & -> & Hrel). simpl.
Fail eapply sim_simple_deref. have ?:= (rrel_eq _ _ _ Hrel). subst rt.
admit. eapply sim_simple_deref. intros. by subst.
- (* Ref *) - (* Ref *)
move=>Hwf xs Hxswf /=. sim_bind (subst_map _ e) (subst_map _ e). move=>Hwf xs Hxswf /=. sim_bind (subst_map _ e) (subst_map _ e).
eapply sim_simple_post_mono, IHe; [|by auto..]. eapply sim_simple_post_mono, IHe; [|by auto..].
intros r' n' rs css' rt cst' (-> & -> & -> & Hrel). simpl. intros r' n' rs css' rt cst' (-> & -> & -> & Hrel). simpl.
Fail eapply sim_simple_ref. have ?:= (rrel_eq _ _ _ Hrel). subst rt.
eapply sim_simple_ref. intros. subst.
admit. admit.
- (* Copy *) admit. - (* Copy *) admit.
- (* Write *) admit. - (* Write *) admit.
......
...@@ -296,8 +296,8 @@ Proof. ...@@ -296,8 +296,8 @@ Proof.
{ right. { right.
destruct (NT (Copy (Place l (Tagged t) Ts)) σs) as [[]|[es' [σs' STEPS]]]; destruct (NT (Copy (Place l (Tagged t) Ts)) σs) as [[]|[es' [σs' STEPS]]];
[done..|]. [done..|].
destruct (tstep_copy_inv _ _ _ _ _ _ _ STEPS) destruct (tstep_copy_inv _ (PlaceR l (Tagged t) Ts) _ _ _ STEPS)
as (vs & α' & ? & Eqvs & Eqα' & ?). subst es'. as (?&?&?& vs & α' & EqH & ? & Eqvs & Eqα' & ?). symmetry in EqH. simplify_eq.
destruct (read_mem_is_Some l (tsize Tt) σt.(shp)) as [vt Eqvt]. destruct (read_mem_is_Some l (tsize Tt) σt.(shp)) as [vt Eqvt].
{ intros m. rewrite (srel_heap_dom _ _ _ WFS WFT SREL) -EQS. { intros m. rewrite (srel_heap_dom _ _ _ WFS WFT SREL) -EQS.
apply (read_mem_is_Some' l (tsize Ts) σs.(shp)). by eexists. } apply (read_mem_is_Some' l (tsize Ts) σs.(shp)). by eexists. }
...@@ -306,8 +306,8 @@ Proof. ...@@ -306,8 +306,8 @@ Proof.
exists (#vt)%E, (mkState σt.(shp) α' σt.(scs) σt.(snp) σt.(snc)). exists (#vt)%E, (mkState σt.(shp) α' σt.(scs) σt.(snp) σt.(snc)).
by eapply (head_step_fill_tstep _ []), copy_head_step'. } by eapply (head_step_fill_tstep _ []), copy_head_step'. }
constructor 1. intros. constructor 1. intros.
destruct (tstep_copy_inv _ _ _ _ _ _ _ STEPT) as (vt & α' & ? & Eqvt & Eqα' & ?). destruct (tstep_copy_inv _ (PlaceR l (Tagged t) Tt) _ _ _ STEPT)
subst et'. as (?&?&?& vt & α' & EqH & ? & Eqvt & Eqα' & ?). symmetry in EqH. simplify_eq.
destruct (read_mem_is_Some l (tsize Ts) σs.(shp)) as [vs Eqvs]. destruct (read_mem_is_Some l (tsize Ts) σs.(shp)) as [vs Eqvs].
{ intros m. rewrite -(srel_heap_dom _ _ _ WFS WFT SREL) EQS. { intros m. rewrite -(srel_heap_dom _ _ _ WFS WFT SREL) EQS.
apply (read_mem_is_Some' l (tsize Tt) σt.(shp)). by eexists. } apply (read_mem_is_Some' l (tsize Tt) σt.(shp)). by eexists. }
...@@ -374,7 +374,7 @@ Proof. ...@@ -374,7 +374,7 @@ Proof.
- by apply (tstep_wf _ _ _ STEPS WFS). - by apply (tstep_wf _ _ _ STEPS WFS).
- by apply (tstep_wf _ _ _ STEPT WFT). - by apply (tstep_wf _ _ _ STEPT WFT).
- done. - done.
- intros t1 k h Eqt. specialize (PINV t1 k h Eqt) as [Lt PI]. subst σt'. simpl. - intros t1 k h Eqt. specialize (PINV t1 k h Eqt) as [Lt PI]. simpl.
split; [done|]. intros l' s' Eqk'. split; [done|]. intros l' s' Eqk'.
specialize (PI _ _ Eqk') as [? PI]. split; [done|]. specialize (PI _ _ Eqk') as [? PI]. split; [done|].
intros stk' Eqstk'. intros stk' Eqstk'.
...@@ -394,7 +394,7 @@ Proof. ...@@ -394,7 +394,7 @@ Proof.
destruct k. destruct k.
+ eapply access1_head_preserving; eauto. + eapply access1_head_preserving; eauto.
+ eapply access1_active_SRO_preserving; eauto. + eapply access1_active_SRO_preserving; eauto.
- intros c cs Eqc. specialize (CINV _ _ Eqc). subst σt'. simpl. - intros c cs Eqc. specialize (CINV _ _ Eqc). simpl.
clear -Eqα' CINV. destruct cs as [[T|]| |]; [|done..]. clear -Eqα' CINV. destruct cs as [[T|]| |]; [|done..].
destruct CINV as [IN CINV]. split; [done|]. destruct CINV as [IN CINV]. split; [done|].
intros t1 InT. specialize (CINV _ InT) as [? CINV]. split; [done|]. intros t1 InT. specialize (CINV _ InT) as [? CINV]. split; [done|].
...@@ -403,8 +403,8 @@ Proof. ...@@ -403,8 +403,8 @@ Proof.
destruct (for_each_access1_active_preserving _ _ _ _ _ _ _ Eqα' _ _ Eqstk') destruct (for_each_access1_active_preserving _ _ _ _ _ _ _ Eqα' _ _ Eqstk')
as [stk [Eqstk AS]]. as [stk [Eqstk AS]].
exists stk, pm'. split; last split; [done| |done]. by apply AS. exists stk, pm'. split; last split; [done| |done]. by apply AS.
- subst σt'. rewrite /srel /=. by destruct SREL as (?&?&?&?&?). - rewrite /srel /=. by destruct SREL as (?&?&?&?&?).
- subst σs' σt'. intros l1. simpl. intros Inl1. - intros l1. simpl. intros Inl1.
specialize (LINV _ Inl1) as [InD1 LINV]. split; [done|]. specialize (LINV _ Inl1) as [InD1 LINV]. split; [done|].
intros s stk Eqs. intros s stk Eqs.
have HLF : i, (i < tsize Tt)%nat l1 (l + i). have HLF : i, (i < tsize Tt)%nat l1 (l + i).
...@@ -417,7 +417,7 @@ Proof. ...@@ -417,7 +417,7 @@ Proof.
apply (sim_body_result _ _ _ _ (ValR vs) (ValR vt)). intros. apply (sim_body_result _ _ _ _ (ValR vs) (ValR vt)). intros.
have VREL2: vrel (r (core (r_f r))) vs vt. have VREL2: vrel (r (core (r_f r))) vs vt.
{ eapply vrel_mono; [done| |exact VREL']. apply cmra_included_r. } { eapply vrel_mono; [done| |exact VREL']. apply cmra_included_r. }
subst σt'. apply POST; eauto. apply POST; eauto.
Admitted. Admitted.
(** Write *) (** Write *)
...@@ -510,17 +510,19 @@ Proof. ...@@ -510,17 +510,19 @@ Proof.
split; [|done|]. split; [|done|].
{ right. { right.
edestruct NT as [[]|[es' [σs' STEPS]]]; [constructor 1|done|]. edestruct NT as [[]|[es' [σs' STEPS]]]; [constructor 1|done|].
destruct (tstep_write_inv _ _ _ _ _ _ _ _ STEPS) destruct (tstep_write_inv _ (PlaceR _ _ _) (ValR _) _ _ _ STEPS)
as (α' & ? & Eqα' & EqD & IN & EQL & ?). as (?&?&?&?& α' & EqH & EqH' & ? & Eqα' & EqD & IN & EQL & ?).
subst es'. setoid_rewrite <-(srel_heap_dom _ _ _ WFS WFT SREL) in EqD. symmetry in EqH, EqH'. simplify_eq.
setoid_rewrite <-(srel_heap_dom _ _ _ WFS WFT SREL) in EqD.
destruct SREL as (Eqst&Eqnp&Eqcs&Eqnc&AREL). destruct SREL as (Eqst&Eqnp&Eqcs&Eqnc&AREL).
rewrite Eqst Eqcs in Eqα'. rewrite Eqnp in IN. rewrite EQL in EqD. rewrite Eqst Eqcs in Eqα'. rewrite Eqnp in IN. rewrite EQL in EqD.
exists (#[])%V, exists (#[])%V,
(mkState (write_mem l v σt.(shp)) α' σt.(scs) σt.(snp) σt.(snc)). (mkState (write_mem l v σt.(shp)) α' σt.(scs) σt.(snp) σt.(snc)).
eapply (head_step_fill_tstep _ []), write_head_step'; eauto. } eapply (head_step_fill_tstep _ []), write_head_step'; eauto. }
constructor 1. intros. constructor 1. intros.
destruct (tstep_write_inv _ _ _ _ _ _ _ _ STEPT) destruct (tstep_write_inv _ (PlaceR _ _ _) (ValR _) _ _ _ STEPT)
as (α' & ? & Eqα' & EqD & IN & EQL & ?). subst et'. as (?&?&?&?& α' & EqH & EqH' & ? & Eqα' & EqD & IN & EQL & ?).
symmetry in EqH, EqH'. simplify_eq.
assert ( s, v = [s]) as [s ?]. assert ( s, v = [s]) as [s ?].
{ rewrite LenT in EQL. destruct v as [|s v]; [simpl in EQL; done|]. { rewrite LenT in EQL. destruct v as [|s v]; [simpl in EQL; done|].
exists s. destruct v; [done|simpl in EQL; lia]. } subst v. exists s. destruct v; [done|simpl in EQL; lia]. } subst v.
...@@ -584,7 +586,7 @@ Proof. ...@@ -584,7 +586,7 @@ Proof.
(<[l:=Cinl (Excl (v', init_stack (Tagged tg)))]> (r_f.2 r'.2))). (<[l:=Cinl (Excl (v', init_stack (Tagged tg)))]> (r_f.2 r'.2))).
{ by rewrite lookup_insert. } { by rewrite lookup_insert. }
by apply exclusive_local_update. by apply exclusive_local_update.
- subst σt'. intros t k h HL. destruct (PINV t k h) as [? PI]. - intros t k h HL. destruct (PINV t k h) as [? PI].
{ rewrite Eqr. move: HL. by rewrite 4!lookup_op /= 2!right_id. } { rewrite Eqr. move: HL. by rewrite 4!lookup_op /= 2!right_id. }
split; [done|]. simpl. split; [done|]. simpl.
intros l1 s1 Eqs1. specialize (PI l1 s1 Eqs1) as [HLs1 PI]. intros l1 s1 Eqs1. specialize (PI l1 s1 Eqs1) as [HLs1 PI].
...@@ -595,11 +597,11 @@ Proof. ...@@ -595,11 +597,11 @@ Proof.
rewrite lookup_op (lookup_op (r_f.2 r'.2)) /init_local_res /= 2!lookup_fmap. rewrite lookup_op (lookup_op (r_f.2 r'.2)) /init_local_res /= 2!lookup_fmap.
do 2 rewrite lookup_insert_ne //. } do 2 rewrite lookup_insert_ne //. }
by setoid_rewrite lookup_insert_ne. by setoid_rewrite lookup_insert_ne.
- subst σt'. intros c cs. simpl. rewrite -HCEq. intros Eqcm. - intros c cs. simpl. rewrite -HCEq. intros Eqcm.
move : CINV. rewrite Eqr cmra_assoc => CINV. move : CINV. rewrite Eqr cmra_assoc => CINV.
specialize (CINV _ _ Eqcm). destruct cs as [[]| |]; [|done..]. specialize (CINV _ _ Eqcm). destruct cs as [[]| |]; [|done..].
destruct CINV as [? CINV]. split; [done|]. by setoid_rewrite <- HTEq. destruct CINV as [? CINV]. split; [done|]. by setoid_rewrite <- HTEq.
- subst σt'. destruct SREL as (?&?&?&?& REL). do 4 (split; [done|]). - destruct SREL as (?&?&?&?& REL). do 4 (split; [done|]).
simpl. intros l1 Inl1 Eq1. simpl. intros l1 Inl1 Eq1.
have NEql1: l1 l. have NEql1: l1 l.
{ intros ?. subst l1. move : Eq1. rewrite lookup_op HLN left_id. { intros ?. subst l1. move : Eq1. rewrite lookup_op HLN left_id.
...@@ -619,7 +621,7 @@ Proof. ...@@ -619,7 +621,7 @@ Proof.
setoid_rewrite Eqr. setoid_rewrite cmra_assoc. by setoid_rewrite <- HTEq. setoid_rewrite Eqr. setoid_rewrite cmra_assoc. by setoid_rewrite <- HTEq.
+ right. move : REL. setoid_rewrite Eqr. setoid_rewrite cmra_assoc. + right. move : REL. setoid_rewrite Eqr. setoid_rewrite cmra_assoc.
rewrite /priv_loc. by setoid_rewrite <- HTEq. rewrite /priv_loc. by setoid_rewrite <- HTEq.
- subst σt'. move : LINV. rewrite Eqr cmra_assoc. - move : LINV. rewrite Eqr cmra_assoc.
(* TODO: general property of lmap_inv w.r.t to separable resource *) (* TODO: general property of lmap_inv w.r.t to separable resource *)
intros LINV l1 Inl1. intros LINV l1 Inl1.
have EqD': dom (gset loc) (r_f r' res_mapsto l 1 s (init_stack (Tagged tg))).(rlm) have EqD': dom (gset loc) (r_f r' res_mapsto l 1 s (init_stack (Tagged tg))).(rlm)
...@@ -648,7 +650,7 @@ Proof. ...@@ -648,7 +650,7 @@ Proof.
by inversion 1. } by inversion 1. }
left. left.
eapply (sim_body_result _ _ _ _ (ValR [%S]) (ValR [%S])). eapply (sim_body_result _ _ _ _ (ValR [%S]) (ValR [%S])).
intros. simpl. subst σt'. by apply POST. intros. simpl. by apply POST.
Qed. Qed.
Lemma sim_body_write_related_values Lemma sim_body_write_related_values
...@@ -675,9 +677,10 @@ Proof. ...@@ -675,9 +677,10 @@ Proof.
split; [|done|]. split; [|done|].
{ right. { right.
edestruct NT as [[]|[es' [σs' STEPS]]]; [constructor 1|done|]. edestruct NT as [[]|[es' [σs' STEPS]]]; [constructor 1|done|].
destruct (tstep_write_inv _ _ _ _ _ _ _ _ STEPS) destruct (tstep_write_inv _ (PlaceR _ _ _) (ValR _) _ _ _ STEPS)
as (α' & ? & Eqα' & EqD & IN & EQL & ?). as (?&?&?&?& α' & EqH & EqH' & ? & Eqα' & EqD & IN & EQL & ?).
subst es'. setoid_rewrite <-(srel_heap_dom _ _ _ WFS WFT SREL) in EqD. symmetry in EqH, EqH'. simplify_eq.
setoid_rewrite <-(srel_heap_dom _ _ _ WFS WFT SREL) in EqD.
destruct SREL as (Eqst&Eqnp&Eqcs&Eqnc&AREL). destruct SREL as (Eqst&Eqnp&Eqcs&Eqnc&AREL).
rewrite Eqst Eqcs EQS in Eqα'. rewrite -EQL in EQS. rewrite Eqst Eqcs EQS in Eqα'. rewrite -EQL in EQS.
rewrite EQS in EqD. rewrite Eqnp in IN. rewrite EQS in EqD. rewrite Eqnp in IN.
...@@ -685,8 +688,9 @@ Proof. ...@@ -685,8 +688,9 @@ Proof.
(mkState (write_mem l v σt.(shp)) α' σt.(scs) σt.(snp) σt.(snc)). (mkState (write_mem l v σt.(shp)) α' σt.(scs) σt.(snp) σt.(snc)).
by eapply (head_step_fill_tstep _ []), write_head_step'. } by eapply (head_step_fill_tstep _ []), write_head_step'. }
constructor 1. intros. constructor 1. intros.
destruct (tstep_write_inv _ _ _ _ _ _ _ _ STEPT) destruct (tstep_write_inv _ (PlaceR _ _ _) (ValR _) _ _ _ STEPT)
as (α' & ? & Eqα' & EqD & IN & EQL & ?). subst et'. as (?&?&?&?& α' & EqH & EqH' & ? & Eqα' & EqD & IN & EQL & ?).
symmetry in EqH, EqH'. simplify_eq.
set σs' := mkState (write_mem l v σs.(shp)) α' σs.(scs) σs.(snp) σs.(snc). set σs' := mkState (write_mem l v σs.(shp)) α' σs.(scs) σs.(snp) σs.(snc).
have STEPS: ((Place l (Tagged tg) Ts <- v)%E, σs) ~{fs}~> ((#[])%V, σs'). have STEPS: ((Place l (Tagged tg) Ts <- v)%E, σs) ~{fs}~> ((#[])%V, σs').
{ setoid_rewrite (srel_heap_dom _ _ _ WFS WFT SREL) in EqD. { setoid_rewrite (srel_heap_dom _ _ _ WFS WFT SREL) in EqD.
...@@ -734,7 +738,7 @@ Proof. ...@@ -734,7 +738,7 @@ Proof.
move : Eqt. rewrite lookup_op Eqtg. by move => /tagKindR_exclusive_2. move : Eqt. rewrite lookup_op Eqtg. by move => /tagKindR_exclusive_2.
+ right. naive_solver. } + right. naive_solver. }
split. split.
{ subst σt'. simpl. destruct CASEt as [(?&?&?&?Eqh)|[Eqh NEQ]]. { simpl. destruct CASEt as [(?&?&?&?Eqh)|[Eqh NEQ]].
- subst t k k0. apply (PINV tg tkUnique h0). by rewrite HL2. - subst t k k0. apply (PINV tg tkUnique h0). by rewrite HL2.
- move : Eqh. apply PINV. } - move : Eqh. apply PINV. }
intros l' s' Eqk'. split. intros l' s' Eqk'. split.
...@@ -752,7 +756,7 @@ Proof. ...@@ -752,7 +756,7 @@ Proof.
destruct (PI l' ss0) as [? _]; [|done]. by rewrite Eqs0 Eqss0. destruct (PI l' ss0) as [? _]; [|done]. by rewrite Eqs0 Eqss0.
- specialize (PINV _ _ _ Eqh) as [? PINV]. - specialize (PINV _ _ _ Eqh) as [? PINV].
specialize (PINV _ _ Eqk') as [EQ _]. rewrite /r' /=. by destruct k0. } specialize (PINV _ _ Eqk') as [EQ _]. rewrite /r' /=. by destruct k0. }
intros stk'. subst σt'. simpl. intros stk'. simpl.
destruct (write_mem_lookup_case l v σt.(shp) l') destruct (write_mem_lookup_case l v σt.(shp) l')
as [[i [Lti [Eqi Eqmi]]]|[NEql Eql]]; last first. as [[i [Lti [Eqi Eqmi]]]|[NEql Eql]]; last first.
{ (* l' is NOT written to *) { (* l' is NOT written to *)
...@@ -829,7 +833,7 @@ Proof. ...@@ -829,7 +833,7 @@ Proof.
intros c cs Eqc'. intros c cs Eqc'.
have Eqc: (r_f r).(rcm) !! c Some cs. have Eqc: (r_f r).(rcm) !! c Some cs.
{ move : Eqc'. rewrite /r'. by destruct k0. } { move : Eqc'. rewrite /r'. by destruct k0. }
specialize (CINV _ _ Eqc). subst σt'. simpl. specialize (CINV _ _ Eqc). simpl.
clear -Eqα' CINV Eqtg VALID HL HL2. destruct cs as [[T|]| |]; [|done..]. clear -Eqα' CINV Eqtg VALID HL HL2. destruct cs as [[T|]| |]; [|done..].
destruct CINV as [IN CINV]. split; [done|]. destruct CINV as [IN CINV]. split; [done|].
intros t InT. specialize (CINV _ InT) as [? CINV]. split; [done|]. intros t InT. specialize (CINV _ InT) as [? CINV]. split; [done|].
...@@ -860,7 +864,7 @@ Proof. ...@@ -860,7 +864,7 @@ Proof.
as [stk [Eqstk AS]]. as [stk [Eqstk AS]].
exists stk, pm'. split; last split; [done|by apply AS|done]. exists stk, pm'. split; last split; [done|by apply AS|done].
- (* srel *) - (* srel *)
subst σt'. rewrite /srel /=. destruct SREL as (?&?&?&?&Eq). rewrite /srel /=. destruct SREL as (?&?&?&?&Eq).
repeat split; [done..|]. repeat split; [done..|].
intros l1 InD1 Eq1. intros l1 InD1 Eq1.
destruct (write_mem_lookup l v σs.(shp)) as [EqN EqO]. rewrite /r'. destruct (write_mem_lookup l v σs.(shp)) as [EqN EqO]. rewrite /r'.
...@@ -934,8 +938,8 @@ Proof. ...@@ -934,8 +938,8 @@ Proof.
{ exists h. rewrite /rtm /= HL lookup_insert_ne //. } { exists h. rewrite /rtm /= HL lookup_insert_ne //. }
- intros l'. rewrite -> Eqrlm. setoid_rewrite Eqrlm. - intros l'. rewrite -> Eqrlm. setoid_rewrite Eqrlm.
intros InD. specialize (LINV _ InD) as [? LINV]. intros InD. specialize (LINV _ InD) as [? LINV].
split. { subst σt'. rewrite /= write_mem_dom //. } split. { rewrite /= write_mem_dom //. }
intros s stk Eq. subst σt'. rewrite /=. intros s stk Eq. rewrite /=.
specialize (LINV _ _ Eq) as (?&?&?&?). specialize (LINV _ _ Eq) as (?&?&?&?).
destruct (write_mem_lookup l v σs.(shp)) as [_ HLs]. destruct (write_mem_lookup l v σs.(shp)) as [_ HLs].
destruct (write_mem_lookup l v σt.(shp)) as [_ HLt]. destruct (write_mem_lookup l v σt.(shp)) as [_ HLt].
...@@ -948,7 +952,7 @@ Proof. ...@@ -948,7 +952,7 @@ Proof.
} }
left. left.
eapply (sim_body_result fs ft r' n (ValR [%S]) (ValR [%S])). eapply (sim_body_result fs ft r' n (ValR [%S]) (ValR [%S])).
intros. simpl. subst σt'. by apply POST. intros. simpl. by apply POST.
Qed. Qed.
(** Retag *) (** Retag *)
......
...@@ -186,54 +186,61 @@ Lemma sim_body_let_place fs ft r n x ls lt ts tt tys tyt es2 et2 σs σt Φ : ...@@ -186,54 +186,61 @@ Lemma sim_body_let_place fs ft r n x ls lt ts tt tys tyt es2 et2 σs σt Φ :
Proof. apply sim_body_let; eauto. Qed. Proof. apply sim_body_let; eauto. Qed.
(** Ref *) (** Ref *)
Lemma sim_body_ref fs ft r n l tgs tgt Ts Tt σs σt Φ : Lemma sim_body_ref fs ft r n (pl: result) σs σt Φ :
Φ r n (ValR [ScPtr l tgs]) σs (ValR [ScPtr l tgt]) σt : Prop ( l t T, pl = PlaceR l t T
r {n,fs,ft} ((& (Place l tgs Ts))%E, σs) ((& (Place l tgt Tt))%E, σt) : Φ. Φ r n (ValR [ScPtr l t]) σs (ValR [ScPtr l t]) σt : Prop)
r {n,fs,ft} ((& pl)%E, σs) ((& pl)%E, σt) : Φ.
Proof. Proof.
intros SIM. pfold. intros POST. pfold.
intros NT r_f WSAT. split; [|done|]. intros NT r_f WSAT. split; [|done|].
{ right. { right.
destruct (NT (& (Place l tgs Ts))%E σs) as [[]|[es' [σs' STEPS]]]; [done..|]. destruct (NT (& pl)%E σs) as [[]|[es' [σs' STEPS]]]; [done..|].
destruct (tstep_ref_inv _ _ _ _ _ _ _ STEPS) as [? [? IS]]. subst es' σs'. destruct (tstep_ref_inv _ _ _ _ _ STEPS) as (l & tg & T & ? & ? & ? & IS).
simplify_eq.
have ?: is_Some (σt.(shp) !! l). have ?: is_Some (σt.(shp) !! l).
{ clear -WSAT IS. move : IS. { clear -WSAT IS. move : IS.
by rewrite -2!(elem_of_dom (D:=gset loc)) -wsat_heap_dom. } by rewrite -2!(elem_of_dom (D:=gset loc)) -wsat_heap_dom. }
exists #[ScPtr l tgt]%E, σt. exists #[ScPtr l tg]%E, σt.
eapply (head_step_fill_tstep _ []). by econstructor; econstructor. } eapply (head_step_fill_tstep _ []). by econstructor; econstructor. }
constructor 1. intros. constructor 1. intros.
destruct (tstep_ref_inv _ _ _ _ _ _ _ STEPT) as [? [? IS]]. subst et' σt'. destruct (tstep_ref_inv _ _ _ _ _ STEPT) as (l & tg & T & ? & ? & ? & IS).
simplify_eq.
have ?: is_Some (σs.(shp) !! l). have ?: is_Some (σs.(shp) !! l).
{ clear -WSAT IS. move : IS. { clear -WSAT IS. move : IS.
by rewrite -2!(elem_of_dom (D:=gset loc)) wsat_heap_dom. } by rewrite -2!(elem_of_dom (D:=gset loc)) wsat_heap_dom. }
exists #[ScPtr l tgs]%E, σs, r, n. split. exists #[ScPtr l tg]%E, σs, r, n. split.
{ left. constructor 1. eapply (head_step_fill_tstep _ []). { left. constructor 1. eapply (head_step_fill_tstep _ []).
by econstructor; econstructor. } by econstructor; econstructor. }