From hahn Require Import Hahn.
From imm Require Import
     AuxDef
     Events Execution TraversalConfig TraversalConfigAlt
     SimTraversal SimTraversalProperties
     imm_common imm_s imm_s_hb CertExecution1
     CombRelations Execution_eco.
Require Import AuxRel.
Require Import AuxDef.
Require Import ImmProperties.

Section CertRf.
Variable G  : execution.
Variable sc : relation actid.
Variable TC : trav_config.

Notation "'C'"  := (covered TC).
Notation "'I'"  := (issued TC).

Notation "'E'"  := G.(acts_set).
Notation "'lab'" := (G.(lab)).
Notation "'rmw'" := G.(rmw).

Notation "'Tid_' t" := (fun x => tid x = t) (at level 1).
Notation "'NTid_' t" := (fun x => tid x <> t) (at level 1).

Notation "'R'" := (fun a => is_true (is_r lab a)).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'F'" := (fun a => is_true (is_f lab a)).

Notation "'Acq'" := (fun a => is_true (is_acq lab a)).
Notation "'Rel'" := (fun a => is_true (is_rel lab a)).
Notation "'Sc'" := (fun a => is_true (is_sc lab a)).
Notation "'Acq/Rel'" := (fun a => is_true (is_ra lab a)).

Notation "'sb'"  := (G.(sb)).
Notation "'ppo'" := (G.(ppo)).
Notation "'sw'"  := (G.(imm_s_hb.sw)).
Notation "'hb'"  := (G.(imm_s_hb.hb)).
Notation "'rf'"  := (G.(rf)).
Notation "'rfi'" := (G.(rfi)).
Notation "'rfe'" := (G.(rfe)).
Notation "'co'"  := (G.(co)).
Notation "'loc'" := (loc lab).

Notation "'Loc_' l" := (fun x => loc x = Some l) (at level 1).
Notation "'W_' l" := (W ∩₁ Loc_ l) (at level 1).
Notation "'R_' l" := (R ∩₁ Loc_ l) (at level 1).

Notation "'furr'" := (furr G sc).

Definition CsbI := (C ∪₁ dom_rel (sb^? ⨾ ⦗ I ⦘)).

Definition D :=
  C ∪₁ I ∪₁
  dom_rel (rfi^? ⨾ ppo ⨾ ⦗ I ⦘) ∪₁
  codom_rel (⦗I⦘ ⨾ rfi) ∪₁
  codom_rel (rfe ⨾ ⦗ R ∩₁ Acq ⦘).

Definition vf :=
  ⦗ W ⦘ ⨾ (rf ⨾ ⦗ C ⦘)^? ⨾ hb^? ⨾ sc^? ⨾ hb^? ⨾ ⦗ E ⦘ ∪
  rf ⨾ ⦗ D ⦘ ⨾ sb^?.

Definition cert_rf :=
  vf ∩ same_loc lab ⨾ ⦗ CsbI ∩₁ R ⦘ \ co ⨾ vf.

Definition cert_rfi := cert_rf ∩ sb.
Definition cert_rfe := cert_rf \  sb.

Section Properties.
Variable WF  : Wf G.
Variable COH : imm_consistent G sc.
Variable TCCOH : tc_coherent G sc TC.
Variable RELCOH : W ∩₁ Rel ∩₁ I ⊆₁ C.

(******************************************************************************)
(** ** CsbI propeties *)
(******************************************************************************)

Lemma CsbI_in_E : CsbI ⊆₁ E.
Proof.
  unfold CsbI.
  rewrite coveredE, issuedE; try edone.
  rewrite (dom_l (@wf_sbE G)).
  basic_solver.
Qed.

Lemma CsbI_sb_prcl :
  dom_rel (sb ⨾ ⦗ CsbI ⦘) ⊆₁ CsbI.
Proof.
  unfold CsbI.
  rewrite id_union.
  rewrite seq_union_r.
  rewrite dom_union.
  apply set_union_Proper.
  { eapply dom_sb_covered; eauto. }
  rewrite !seq_eqv_r.
  unfolder; ins; desf; splits; auto.
  { do 2 eexists; splits; eauto. }
  do 2 eexists; splits.
  2-3: eauto.
  right. eapply sb_trans; eauto.
Qed.

Lemma CsbI_rmw_fwcl (RMWCOV : forall r w, rmw r w -> C r <-> C w) :
  ⦗CsbI⦘ ⨾ rmw ≡ ⦗CsbI⦘ ⨾ rmw ⨾ ⦗CsbI⦘.
Proof.
  split; [|basic_solver].
  unfold CsbI.
  rewrite !id_union.
  rewrite !seq_union_l, !seq_union_r.
  unionL.
  { repeat unionR left.
    unfolder. ins. splits; desf.
    match goal with
    | H : rmw ?x ?y |- _ => eapply RMWCOV in H
    end.
    intuition. }
  unionR right -> right.
  rewrite WF.(wf_rmwD) at 1.
  unfolder. ins. splits; desf.
  1,3: exfalso;
    match goal with
    | H : I ?y |- _ => rename H into AA
    end;
    eapply issuedW in AA; eauto;
      type_solver.
  all: do 2 eexists.
  { splits; eauto. }
  splits; [| |by eauto].
  2: done.
  destruct (classic (y = y0)) as [|NEQ]; eauto.
  right.
  match goal with
  | H : rmw ?x ?y |- _ => rename H into RMW
  end.
  apply WF.(rmw_from_non_init) in RMW.
  destruct_seq_l RMW as AA.
  edestruct sb_semi_total_l with (x:=x); eauto.
  { by apply rmw_in_sb. }
  exfalso.
  eapply wf_rmwi; eauto.
Qed.

Lemma CsbI_hb_prcl :
  dom_rel (hb ⨾ ⦗ CsbI ⦘) ⊆₁ CsbI.
Proof.
  unfold CsbI.
  rewrite <- seq_eqvK.
  sin_rewrite hb_in_Chb_sb; eauto.
  rewrite seq_union_l, dom_union.
  unionL; [|apply CsbI_sb_prcl].
  rewrite !seqA, !dom_seq.
  basic_solver.
Qed.

Lemma sc_hb_CsbI_in_C :
  dom_rel (sc ⨾ hb ⨾ ⦗CsbI⦘) ⊆₁ C.
Proof.
  arewrite (hb ⨾ ⦗CsbI⦘ ⊆ ⦗CsbI⦘ ⨾ hb).
  { generalize CsbI_hb_prcl. basic_solver. }
  unfold CsbI.
  rewrite <- seqA.
  erewrite scCsbI_C; eauto.
  basic_solver.
Qed.

Lemma hb_sc_hb_CsbI_alt :
  hb^? ⨾ sc^? ⨾ hb^? ⨾ ⦗CsbI⦘ ⊆
    (⦗C⦘ ⨾ hb^? ⨾ sc^? ⨾ hb^? ∪ sb)^?.
Proof.
  rewrite crE
    with (r := hb) at 1 2.
  rewrite crE
    with (r := sc) at 1.
  relsf.
  arewrite (hb ⨾ hb ⊆ hb).
  rewrite !unionA.
  apply union_mori.
  { basic_solver. }
  unionL.

  1,4,5 : unfold CsbI;
          rewrite hb_in_Chb_sb;
          eauto; basic_solver 10.

  { unfold CsbI.
    erewrite scCsbI_C; eauto.
    basic_solver 10. }

  { erewrite dom_rel_helper.
    2 : eapply sc_hb_CsbI_in_C; eauto.
    basic_solver 10. }

  { unfold CsbI.
    erewrite scCsbI_C; eauto.
    sin_rewrite hb_covered; eauto.
    basic_solver 10. }

  erewrite dom_rel_helper
    with (r := hb ⨾ ⦗CsbI⦘).
  2 : eapply CsbI_hb_prcl; eauto.
  arewrite
    (sc ⨾ ⦗CsbI⦘ ⊆ ⦗C⦘ ⨾ sc).
  { unfold CsbI at 1.
    erewrite scCsbI_C; eauto; done. }
  sin_rewrite hb_covered; eauto.
  basic_solver 10.
Qed.

(******************************************************************************)
(** ** D propeties *)
(******************************************************************************)

Lemma D_in_E : D ⊆₁ E.
Proof.
  unfold D.
  rewrite (wf_ppoE WF), (wf_rfiE WF), (wf_rfeE WF), (coveredE TCCOH).
  rewrite (issuedE TCCOH) at 1.
  basic_solver 21.
Qed.

Lemma D_R : D ∩₁ R ≡₁ C ∩₁ R ∪₁
  dom_rel (ppo ⨾ ⦗ I ⦘) ∪₁
  codom_rel (⦗I⦘ ⨾ rfi) ∪₁
  codom_rel (rfe ⨾ ⦗ R ∩₁ Acq ⦘).
Proof.
  unfold D.
  rewrite !set_inter_union_l.
  rewrite crE. relsf.
  arewrite
    (I ∩₁ R ≡₁ ∅).
  { split; [|done].
    rewrite issuedW; eauto.
    type_solver. }
  arewrite
    (dom_rel (rfi ⨾ ppo ⨾ ⦗I⦘) ∩₁ R ≡₁ ∅).
  { rewrite wf_rfiD; auto. type_solver. }
  rewrite wf_rfiD, wf_rfeD, wf_ppoD; auto.
  basic_solver 20.
Qed.

Lemma C_in_D : C ⊆₁ D.
Proof. unfold D. by repeat left. Qed.

Lemma I_in_D : I ⊆₁ D.
Proof. unfold D. do 3 left. by right. Qed.

Lemma CI_in_D : C ∪₁ I ⊆₁ D.
Proof. unfold D. by do 3 left. Qed.

Lemma rfi_D_in_D :
  dom_rel (rfi ⨾ ⦗ D ⦘) ⊆₁ D.
Proof.
  intros w [r RFI]. destruct_seq_r RFI as DR.
  apply wf_rfiD in RFI; auto. destruct_seq RFI as [WW RR].
  apply wf_rfiE in RFI; auto. destruct_seq RFI as [EW ER].
  red in DR. unfold set_union in DR. desf.
  { apply C_in_D. eapply dom_sb_covered; eauto.
    eexists. apply seq_eqv_r. split; eauto. apply RFI. }
  { eapply issuedW in DR; eauto. type_solver. }
  { red. do 2 left. right.
    destruct DR as [z [v [[EE|EE] DR]]].
    { desf. generalize RFI DR. basic_solver 10. }
    apply wf_rfiD in EE; auto. destruct_seq EE as [WR RV].
    clear -RR WR. type_solver. }
  { apply I_in_D. destruct DR as [v DR].
    destruct_seq_l DR as IV.
    assert (v = w); desf.
    eapply wf_rff; eauto.
    { apply DR. }
    apply RFI. }
  destruct DR as [v DR].
  destruct_seq_r DR as IV.
  assert (v = w); desf.
  { eapply wf_rff; eauto.
    { apply DR. }
    apply RFI. }
  unfold Execution.rfi, Execution.rfe in *.
  generalize RFI DR. basic_solver.
Qed.

Lemma rfe_D_CsbI_in_D :
  dom_rel (rfe ⨾ ⦗ D ∩₁ CsbI ⦘) ⊆₁ D.
Proof.
  intros w [r RFE]. destruct_seq_r RFE as DR.
  apply wf_rfeD in RFE; auto. destruct_seq RFE as [WW RR].
  apply wf_rfeE in RFE; auto. destruct_seq RFE as [EW ER].
  destruct DR as [DR CsbIr].
  assert (C r -> D w) as UU.
  { intros HH. apply I_in_D. eapply dom_rf_covered; eauto.
    eexists. apply seq_eqv_r. split; eauto. apply RFE. }
  destruct CsbIr as [EE0|EE0].
  { intuition. }

  red in DR. unfold set_union in DR. desf.
  { intuition. }
  { eapply issuedW in DR; eauto. type_solver. }
  { red. apply I_in_D.
    destruct DR as [z [v [[EE|EE] DR]]].
    2: { apply wf_rfiD in EE; auto. destruct_seq EE as [WR RV].
         clear -RR WR. type_solver. }
    desf. eapply dom_rfe_ppo_issued; eauto.
    do 2 eexists. eauto. }
  { exfalso. destruct DR as [v DR].
    destruct_seq_l DR as IV.
    assert (v = w); desf.
    eapply wf_rff; eauto.
    { apply DR. }
    { apply RFE. }
    apply RFE. apply DR. }
  destruct EE0 as [t EE0]. destruct_seq_r EE0 as IT.
  destruct EE0 as [|EE0]; subst.
  { eapply issuedW in IT; eauto. type_solver. }
  apply I_in_D.
  eapply dom_rfe_acq_sb_issued; eauto.
  destruct DR as [v DR].
  destruct_seq_r DR as IV.
  assert (v = w); desf.
  { eapply wf_rff; eauto.
    { apply DR. }
    apply RFE. }
  generalize DR IV IT EE0. basic_solver 10.
Qed.

Lemma rf_D_CsbI_in_D :
  dom_rel (rf ⨾ ⦗ D ∩₁ CsbI ⦘) ⊆₁ D.
Proof.
  intros w [r RF]. destruct_seq_r RF as DR.
  apply rfi_union_rfe in RF. destruct RF as [RF|RF].
  { apply rfi_D_in_D; auto. eexists.
    apply seq_eqv_r; split; eauto. apply DR. }
  apply rfe_D_CsbI_in_D; auto. eexists.
  apply seq_eqv_r; split; eauto.
Qed.

(******************************************************************************)
(** ** vf propeties *)
(******************************************************************************)

Lemma vfE : vf ≡ ⦗ E ⦘ ⨾ vf ⨾ ⦗ E ⦘.
Proof.
  apply dom_helper_3.
  unfold vf.
  rewrite WF.(wf_rfE).
  rewrite (dom_l WF.(wf_hbE)).
  cdes COH.
  rewrite (dom_l (wf_scE Wf_sc)).
  rewrite (dom_r (@wf_sbE G)).
  basic_solver.
Qed.

Lemma vf_dom : vf ≡ ⦗ W ⦘ ⨾ vf.
Proof.
  split; [|basic_solver].
  unfold vf.
  rewrite (dom_l WF.(wf_rfD)) at 2.
  rewrite !seqA. rewrite seq_union_r.
    by seq_rewrite seq_eqvK.
Qed.

Lemma vf_alt :
  vf ≡ ⦗ W ⦘ ⨾ (rf ⨾ ⦗ C ⦘)^? ⨾ hb^? ⨾ sc^? ⨾ hb^? ⨾ ⦗ E ⦘ ∪
        rf ⨾ ⦗ C ⦘ ⨾ sb^? ∪
        rf ⨾ ⦗ dom_rel (ppo ⨾ ⦗ I ⦘) ⦘ ⨾ sb^? ∪
        ⦗I⦘ ⨾ rfi ⨾ sb^? ∪
        rfe ⨾ ⦗ Acq ⦘ ⨾ sb^?.
Proof.
  unfold vf.
  rewrite !unionA.
  apply union_more; try done.
  rewrite <- !seqA, <- !unionA.
  rewrite <- !seq_union_l.
  apply seq_more; try done.
  arewrite (rf ⨾ ⦗D⦘ ≡ rf ⨾ ⦗D ∩₁ R⦘).
  { rewrite wf_rfD; auto. basic_solver. }
  rewrite D_R.
  rewrite !id_union, !seq_union_r.
  repeat apply union_more; try done.
  { rewrite wf_rfD; auto. basic_solver. }
  { rewrite seq_eqv_l, seq_eqv_r.
    unfolder; splits.
    { intros x y [RF [z [Iz RFI]]].
      arewrite (x = z); auto.
      eapply wf_rff; eauto.
      apply RFI. }
    intros x y [Ix RFI].
    split; [apply RFI|].
    exists x; splits; auto. }
  rewrite seq_eqv_r
    with (dom := R ∩₁ Acq).
  rewrite seq_eqv_r
    with (dom := Acq).
  rewrite seq_eqv_r.
  unfolder; splits.
  { intros x y [RF [z [RFE [Ry ACQy]]]].
    arewrite (x = z); auto.
    eapply wf_rff; eauto.
    apply RFE. }
  intros x y [RFE ACQy].
  split; [apply RFE|].
  exists x; splits; auto.
  apply wf_rfeD in RFE; auto.
  generalize RFE. basic_solver.
Qed.

Lemma vf_in_furr : vf ⊆ furr.
Proof.
  cdes COH.
  unfold vf.
  arewrite_id ⦗D⦘. arewrite_id ⦗E⦘. arewrite_id ⦗C⦘.
  rewrite !seq_id_r, !seq_id_l.
  rewrite furr_alt; auto.
  unionL; [done|].
  rewrite (dom_l WF.(wf_rfD)) at 1.
  rewrite sb_in_hb.
  basic_solver 20.
Qed.

Lemma sb_in_vf : ⦗ W ⦘ ⨾ sb ⊆ vf.
Proof.
  unfold vf.
  rewrite wf_sbE.
  rewrite sb_in_hb at 1.
  basic_solver 20.
Qed.

Lemma vf_sb_in_vf : vf ⨾ sb ⊆ vf.
Proof.
  unfold vf.
  rewrite seq_union_l, !seqA.
  apply union_mori.
  { do 4 (apply seq_mori; [done|]).
    rewrite wf_sbE.
    rewrite sb_in_hb.
    generalize hb_trans.
    basic_solver. }
  do 2 (apply seq_mori; [done|]).
  generalize sb_trans.
  basic_solver.
Qed.

(******************************************************************************)
(** ** cert_rf propeties *)
(******************************************************************************)

Lemma cert_rfE : cert_rf ≡ ⦗E⦘ ⨾ cert_rf ⨾ ⦗E⦘.
Proof.
  cdes COH.
  apply dom_helper_3.
  unfold cert_rf.
  rewrite vfE.
  basic_solver.
Qed.

Lemma cert_rfD : cert_rf ≡ ⦗W⦘ ⨾ cert_rf ⨾ ⦗R⦘.
Proof.
  apply dom_helper_3.
  unfold cert_rf.
  rewrite inclusion_minus_rel.
  rewrite inter_inclusion.
  rewrite vf_dom.
  basic_solver.
Qed.

Lemma cert_rf_codom : cert_rf ≡ cert_rf ⨾ ⦗CsbI⦘.
Proof. unfold cert_rf. basic_solver. Qed.

(* Lemma cert_rf_codomt : cert_rf ≡ cert_rf ⨾ ⦗Tid_ thread⦘. *)
(* Proof. *)
(*   split; [|basic_solver]. *)
(*   rewrite cert_rf_codomE0 at 1. *)
(*   unfold E0. basic_solver. *)
(* Qed. *)

Lemma cert_rfl : cert_rf ⊆ same_loc lab.
Proof. unfold cert_rf. basic_solver. Qed.

Lemma cert_rff : functional cert_rf⁻¹.
Proof.
  rewrite cert_rfD, cert_rfE.
  red. intros x y z AA BB.
  assert (exists l, loc y = Some l) as HH.
  { generalize (is_w_loc lab). unfolder in *.
    basic_solver 12. }
  desc.

  assert (loc z = Some l) as GG.
  { hahn_rewrite cert_rfl in AA.
    hahn_rewrite cert_rfl in BB.
    unfold same_loc in *.
    unfolder in *.
    desf. congruence. }

  unfolder in *.
  destruct (classic (y=z)) as [|X]; eauto; desf.
  exfalso.
  eapply wf_co_total in X; try basic_solver 22.
  2: { unfolder. splits; eauto. congruence. }
  unfold cert_rf in *. desf; unfolder in *; basic_solver 40.
Qed.

Lemma cert_rf_complete : forall b (IN: (CsbI ∩₁ R) b), exists a, cert_rf a b.
Proof.
  ins; unfolder in *; desc.
  assert (exists l, loc b = Some l); desc.
  { by generalize (is_r_loc lab); unfolder in *; basic_solver 12. }

  assert (E b) as UU.
  { by apply CsbI_in_E. }

  assert (E (InitEvent l)).
  { by apply WF; eauto. }
  assert (lab (InitEvent l) = Astore Xpln Opln l 0).
  { by apply WF. }
  assert (loc (InitEvent l) = Some l).
  { by unfold Events.loc; rewrite (wf_init_lab WF). }
  assert (W_ l (InitEvent l)).
  { by unfolder; unfold is_w, Events.loc; desf; eauto. }
  assert (sb (InitEvent l) b).
  { by apply init_ninit_sb; eauto; eapply read_or_fence_is_not_init; eauto. }
  assert (vf (InitEvent l) b).
  { left. red.
    exists (InitEvent l); splits.
    { red. splits; desf; by apply WF.(init_w). }
    unfold eqv_rel; eauto.
    hahn_rewrite <- sb_in_hb.
    basic_solver 21. }

  forward (eapply last_exists with (s:=co ⨾ ⦗fun x => vf x b⦘)
                                   (dom:= filterP (W_ l) G.(acts)) (a:=(InitEvent l))).
  { eapply acyclic_mon.
    apply trans_irr_acyclic; [apply co_irr| apply co_trans]; eauto.
    basic_solver. }
  { ins.
    assert (A: (co ⨾ ⦗fun x : actid => vf x b⦘)^? (InitEvent l) c).
    { apply rt_of_trans; try done.
      apply transitiveI.
      arewrite_id ⦗fun x : actid => vf x b⦘ at 1.
      rewrite seq_id_l.
      arewrite (co ⨾ co ⊆ co); [|done].
      apply transitiveI.
      eapply co_trans; eauto. }
    unfolder in A; desf.
    { by apply in_filterP_iff; split; auto. }
    apply in_filterP_iff.
    hahn_rewrite WF.(wf_coE) in A.
    hahn_rewrite WF.(wf_coD) in A.
    hahn_rewrite WF.(wf_col) in A.
    unfold same_loc in *; unfolder in *; desf; splits; eauto; congruence. }
  ins; desc.
  assert (A: (co ⨾ ⦗fun x : actid => vf x b⦘)^? (InitEvent l) b0).
  { apply rt_of_trans; [|by subst].
    apply transitiveI.
    arewrite_id ⦗fun x : actid => vf x b⦘ at 1.
    rewrite seq_id_l.
    arewrite (co ⨾ co ⊆ co); [|done].
    apply transitiveI.
    eapply co_trans; eauto. }
  assert (loc b0 = Some l).
  { unfolder in A; desf.
    hahn_rewrite WF.(wf_col) in A.
    unfold same_loc in *; desf; unfolder in *; congruence. }
  exists b0; red; split.
  { unfold urr, same_loc.
    unfolder in A; desf; unfolder; ins; desf; splits; try basic_solver 21; congruence. }
  unfold max_elt in *.
  unfolder in *; ins; desf; intro; desf; basic_solver 11.
Qed.

(* Lemma cert_rf_mod: E0 ∩₁ R ≡₁ codom_rel cert_rf. *)
(* Proof. *)
(*   split. *)
(*   { intros x HH. *)
(*     apply cert_rf_complete in HH. *)
(*     desc. eexists. eauto. } *)
(*   rewrite (dom_r cert_rfD). *)
(*   rewrite cert_rf_codomE0. *)
(*   rewrite !codom_eqv1. *)
(*   basic_solver 10. *)
(* Qed. *)

Lemma cert_rf_in_vf : cert_rf ⊆ vf.
Proof. unfold cert_rf. basic_solver. Qed.

Lemma cert_rf_in_furr : cert_rf ⊆ furr.
Proof. rewrite cert_rf_in_vf. apply vf_in_furr. Qed.

Lemma cert_rf_hb_sc_hb_irr: irreflexive (cert_rf ⨾ hb ⨾ (sc ⨾ hb)^?).
Proof.
  rewrite cert_rf_in_furr.
  apply furr_hb_sc_hb_irr; auto.
  all: apply COH.
Qed.

Lemma cert_rf_hb_irr: irreflexive (cert_rf ⨾ hb).
Proof. generalize cert_rf_hb_sc_hb_irr. basic_solver 10. Qed.

Lemma cert_rf_tid_in_sb thread (NINITT : thread <> tid_init) :
  ⦗ Tid_ thread ⦘ ⨾ cert_rf ⨾ ⦗ Tid_ thread ⦘ ⊆ sb.
Proof.
  intros x y CertRF.
  destruct_seq CertRF as [TIDx TIDy].
  apply cert_rfE in CertRF; auto. destruct_seq CertRF as [EX EY].
  apply cert_rfD in CertRF. destruct_seq CertRF as [WX RY].
  edestruct same_thread
    with (x:=x) (y:=y) as [[|SB]|SB]; eauto.
  { intros INITx.
    assert (is_w lab y)
      as INITy; [|type_solver].
    apply init_w; auto.
    unfold tid, is_init in *.
    destruct x, y; auto; congruence. }
  { congruence. }
  { type_solver. }
  exfalso. eapply cert_rf_hb_sc_hb_irr; eauto.
  eexists. splits; eauto.
  eexists. splits.
  { eapply imm_s_hb.sb_in_hb; eauto. }
    by left.
Qed.

Lemma rf_D_in_vf : rf ⨾ ⦗D⦘ ⊆ vf.
Proof.
  rewrite (dom_l WF.(wf_rfD)).
  arewrite (D ⊆₁ D ∩₁ E).
  { generalize D_in_E. basic_solver. }
  unfold vf. basic_solver 20.
Qed.

Lemma rf_vf_in_cert_rf : (rf ⨾ ⦗CsbI⦘) ∩ vf ⊆ cert_rf.
Proof.
  unfold cert_rf.
  rewrite minus_inter_compl.
  apply inclusion_inter_r.
  { rewrite (dom_r WF.(wf_rfD)).
    rewrite WF.(wf_rfl). basic_solver. }
  rewrite vf_in_furr.
  unfolder. ins. desf.
  intros HH. desf.
  eapply eco_furr_irr; eauto.
  all: try apply COH.
  eexists. split; eauto.
  apply fr_in_eco. eexists. split; eauto.
Qed.

Lemma rf_D_in_cert_rf : rf ⨾ ⦗ D ∩₁ CsbI ⦘ ⊆ cert_rf.
Proof.
  rewrite <- rf_vf_in_cert_rf.
  apply inclusion_inter_r.
  { basic_solver 10. }
  rewrite <- rf_D_in_vf. basic_solver.
Qed.

Lemma rf_C_in_cert_rf : rf ⨾ ⦗ C ⦘ ⊆ cert_rf.
Proof.
  rewrite <- rf_D_in_cert_rf.
  unfold D, CsbI.
  rewrite !set_inter_union_l,
          !id_union, !seq_union_r.
  basic_solver 10.
Qed.

Lemma rfi_in_cert_rf : rfi ⨾ ⦗ CsbI ⦘ ⊆ cert_rf.
Proof.
  unfold cert_rf. rewrite minus_inter_compl.
  apply inclusion_inter_r.
  { rewrite (dom_r WF.(wf_rfiD)).
    unfold Execution.rfi.
    rewrite <- seq_eqv_inter_lr
      with (r := vf).
    apply inclusion_inter_r.
    2: { rewrite WF.(wf_rfl). basic_solver. }
    unfold vf.
    rewrite seq_union_l.
    unionR left.
    rewrite (dom_l WF.(wf_rfD)), (dom_r WF.(wf_rfE)).
    rewrite sb_in_hb. basic_solver 30. }
  unfold Execution.rfi.
  rewrite vf_in_furr.
  unfolder. ins. desf.
  intros HH. desf.
  eapply eco_furr_irr; eauto.
  all: try apply COH.
  eexists. split; eauto.
  apply fr_in_eco. eexists. split; eauto.
Qed.

(* Lemma cert_rfi_union_cert_rfe : cert_rf ≡ cert_rfi ∪ cert_rfe. *)
(* Proof. *)
(*   unfold cert_rfi, cert_rfe. *)
(*   rewrite <- seq_union_l. *)
(*   rewrite <- id_union. *)
(*   arewrite (Tid_ thread ∪₁ NTid_ thread ≡₁ ⊤₁). *)
(*   { split; [basic_solver|]. *)
(*     unfolder. ins. apply classic. } *)
(*   rewrite seq_id_l. by rewrite cert_rf_codomt at 1. *)
(* Qed. *)

Lemma cert_rf_D_in_rf : cert_rf ⨾ ⦗ D ⦘ ⊆ rf.
Proof.
  rewrite cert_rf_codom, !seqA, <- id_inter.
  arewrite (cert_rf ⊆ cert_rf ⨾ ⦗ E ∩₁ R ⦘).
  { rewrite (dom_r cert_rfD), (dom_r cert_rfE) at 1.
    basic_solver. }
  cdes COH. red in Comp. rewrite Comp.
  unfolder. ins. desf.
  assert (x0 = x); try subst x0; desf.
  eapply cert_rff; eauto.
  apply rf_D_in_cert_rf.
  apply seq_eqv_r.
  do 3 (split; auto).
Qed.

Lemma cert_rf_C_in_rf : cert_rf ⨾ ⦗ C ⦘ ⊆ rf.
Proof.
  arewrite (C ⊆₁ D).
  { unfold D, CsbI. basic_solver 10. }
  apply cert_rf_D_in_rf.
Qed.

Lemma cert_rf_D_eq_rf_D : cert_rf ⨾ ⦗ D ∩₁ CsbI ⦘ ≡ rf ⨾ ⦗ D ∩₁ CsbI ⦘.
Proof. generalize cert_rf_D_in_rf, rf_D_in_cert_rf. basic_solver 10. Qed.

Lemma cert_rf_Acq_in_rf : cert_rf ⨾ ⦗ Acq ⦘ ⊆ rf.
Proof.
  arewrite (cert_rf ⊆ cert_rf ⨾ ⦗ E ∩₁ R ⦘).
  { rewrite (dom_r cert_rfD), (dom_r cert_rfE) at 1.
    basic_solver. }
  cdes COH. red in Comp. rewrite Comp.
  rewrite rfi_union_rfe at 1.
  rewrite codom_union, id_union, !seq_union_l, !seq_union_r.
  unfold Execution.rfi.
  rewrite <- !id_inter.
  arewrite (codom_rel rfe ∩₁ Acq ⊆₁ D).
  { unfold D.
    rewrite WF.(wf_rfeD).
    basic_solver 10. }
  unionL.
  2: by apply cert_rf_D_in_rf.
  rewrite cert_rf_codom.
  unfolder. ins. desf.
  assert (x0 = x); desf.
  eapply cert_rff; eauto.
  apply rfi_in_cert_rf.
  apply seq_eqv_r.
  basic_solver.
Qed.

Lemma cert_rf_sb_F_Acq_in_rf :
  cert_rf ⨾ sb ⨾ ⦗F⦘ ⨾ ⦗ Acq ⦘ ⨾ ⦗CsbI⦘ ⊆ rf ⨾ sb.
Proof.
  arewrite (sb ⨾ ⦗F⦘ ⨾ ⦗Acq⦘ ⨾ ⦗CsbI⦘ ⊆ ⦗C⦘ ⨾ sb).
  2 : by sin_rewrite cert_rf_C_in_rf.
  rewrite <- !id_inter, seq_eqv_r, seq_eqv_l.
  intros x y [SB [Fy [ACQy E0y]]].
  splits; auto.
  eapply dom_sb_covered; eauto.
  exists y. apply seq_eqv_r.
  splits; auto.
  destruct E0y as [Cy | SBIy]; auto.
  destruct SBIy as [z HH].
  apply seq_eqv_r in HH.
  destruct HH as [[EQz | SB'] Iy].
  { subst. eapply issuedW in Iy; eauto. type_solver. }
  eapply dom_F_sb_issued; eauto.
  unfold is_ra.
  basic_solver 20.
Qed.

Lemma cert_rf_F_Acq_in_rf :
  cert_rf ⨾ (sb ⨾ ⦗F⦘)^? ⨾ ⦗ Acq ⦘ ⨾ ⦗ CsbI ⦘ ⊆ rf ⨾ sb^?.
Proof.
  rewrite !crE, !seq_union_l, !seq_union_r, !seq_id_l, !seq_id_r, !seqA.
  apply union_mori.
  { sin_rewrite cert_rf_Acq_in_rf. basic_solver. }
  apply cert_rf_sb_F_Acq_in_rf.
Qed.

Lemma nI_rf_D_CsbI_in_sb :
  ⦗set_compl I⦘ ⨾ rf ⨾ ⦗D⦘ ⨾ ⦗CsbI⦘ ⊆ sb.
Proof.
  unfold D.
  relsf.
  rewrite !id_union.
  rewrite !seq_union_l, !seq_union_r.
  unionL.
  { seq_rewrite rf_covered; eauto. basic_solver. }
  { rewrite issuedW at 2; eauto.
    rewrite (dom_r WF.(wf_rfD)).
    type_solver. }
  { rewrite rfi_union_rfe.
    rewrite !seq_union_l, !seq_union_r.
    unionL.
    { generalize (@sb_trans G). unfold Execution.rfi. basic_solver. }
    arewrite (
      rfe ⨾ ⦗dom_rel (rfi^? ⨾ ppo ⨾ ⦗I⦘)⦘ ⊆ rfe ⨾ ⦗dom_rel (ppo ⨾ ⦗I⦘)⦘
    ).
    { rewrite crE. relsf.
      rewrite id_union, !seq_union_r.
      unionL; [done|].
      rewrite (dom_l WF.(wf_rfiD)),
              (dom_r WF.(wf_rfeD)).
      rewrite !seqA, dom_eqv1.
      type_solver. }
    arewrite (
      rfe ⨾ ⦗dom_rel (ppo ⨾ ⦗I⦘)⦘ ⊆ ⦗I⦘ ⨾ rfe ⨾ ⦗dom_rel (ppo ⨾ ⦗I⦘)⦘
    ).
    { generalize (dom_rfe_ppo_issued WF TCCOH). basic_solver 20. }
    basic_solver. }
  { arewrite (rf ⨾ ⦗codom_rel (⦗I⦘ ⨾ rfi)⦘ ⊆ sb).
    2: { generalize (@sb_trans G). basic_solver. }
    unfolder; ins; desf.
    match goal with H : rfi _ _ |- _ => destruct H as [AA BB] end.
    eapply wf_rff in H; eauto.
    apply H in AA. by rewrite AA. }
  unfold CsbI.
  rewrite !id_union. rewrite !seq_union_r.
  unionL.
  { rewrite seq_eqvC. seq_rewrite rf_covered; eauto. basic_solver. }
  rewrite rfi_union_rfe. rewrite !seq_union_l, !seq_union_r.
  unionL.
  { unfold Execution.rfi. basic_solver. }
  assert (∅₂ ⊆ sb) as UU by done.
  etransitivity; eauto.
  unfolder; ins; desf.
  { match goal with H : I _ |- _ => eapply issuedW in H; eauto end.
    type_solver. }
  match goal with H : ~ I _ |- _ => apply H end.
  eapply dom_rfe_acq_sb_issued; eauto.
  eexists. eexists. split; eauto.
  apply seq_eqv_l. split; [split|]; auto.
  apply seq_eqv_r. split; eauto.
Qed.

Lemma non_I_cert_rf: ⦗set_compl I⦘ ⨾ cert_rf ⊆ sb.
Proof.
  cdes COH.
  rewrite (dom_r (cert_rfD)).
  rewrite cert_rf_codom.
  rewrite cert_rf_in_vf.
  unfold vf.
  arewrite_id (⦗E⦘).
  relsf. rewrite !seqA. unionL.

  { rewrite !crE.
    repeat (rewrite seq_union_l, seq_id_l).
    rewrite !seq_union_r.
    unionL.
    all: try (
      try rewrite (dom_r WF.(wf_rfD));
      try rewrite Wf_sc.(wf_scD);
      by type_solver
    ).
    5-9:
      erewrite rf_covered; eauto;
      basic_solver.
    all: arewrite_id (⦗R⦘); seq_rewrite seq_id_r.
    3 : sin_rewrite rewrite_trans; [|by apply hb_trans].
    1-3: unfold CsbI; sin_rewrite hb_in_Chb_sb; eauto.
    1-3: rewrite !seq_union_r; seq_rewrite <- !id_inter.
    1-3: rewrite set_interA; erewrite w_covered_issued; eauto.
    1-3: basic_solver.
    arewrite (sc ⨾ hb ⨾ ⦗CsbI⦘ ⊆ ⦗C⦘ ⨾ sc ⨾ hb).
    { generalize sc_hb_CsbI_in_C. basic_solver 10. }
    sin_rewrite hb_covered; eauto.
    rewrite !seqA. seq_rewrite <- !id_inter.
    rewrite set_interA; erewrite w_covered_issued; eauto.
    basic_solver. }

  arewrite_id (⦗R⦘); seq_rewrite seq_id_r.
  arewrite (sb^? ⨾ ⦗CsbI⦘ ⊆ ⦗CsbI⦘ ⨾ sb^?).
  { rewrite crE. relsf.
    apply union_mori; try done.
    generalize CsbI_sb_prcl. basic_solver. }
  sin_rewrite nI_rf_D_CsbI_in_sb.
  generalize sb_trans. basic_solver.
Qed.

Lemma cert_rf_iss_sb :
  cert_rf ⊆ ⦗ I ⦘ ⨾ cert_rf ∪ sb ∩ same_tid.
Proof.
  rewrite <- seq_id_l
    with (r := cert_rf) at 1.
  rewrite <- set_compl_union_id
    with (s := I).
  rewrite id_union, seq_union_l.
  apply union_mori; try done.
  rewrite seq_eqv_l.
  intros x y [nI CertRF].
  assert (sb x y) as SB.
  { apply non_I_cert_rf. basic_solver. }
  split; auto.
  apply sb_tid_init in SB.
  destruct SB as [TID | INITx]; auto.
  exfalso. apply nI.
  eapply init_issued; eauto.
  split; auto.
  apply cert_rfE in CertRF.
  by destruct_seq CertRF as [AA BB].
Qed.

Lemma cert_rf_ntid_iss_sb thread (NINITT : thread <> tid_init) :
  cert_rf ⨾ ⦗ Tid_ thread ⦘ ⊆
    ⦗ NTid_ thread ∩₁ I ⦘ ⨾ cert_rf ∪ sb ∩ same_tid.
Proof.
  rewrite <- seq_id_l
    with (r := cert_rf) at 1.
  rewrite <- tid_set_dec with (thread := thread).
  rewrite set_unionC, id_union, !seq_union_l, !seqA.
  apply union_mori.
  { rewrite cert_rf_iss_sb at 1.
    unfold same_tid.
    basic_solver 10. }
  apply inclusion_inter_r.
  { apply cert_rf_tid_in_sb; auto. }
  unfold same_tid.
  basic_solver.
Qed.

Lemma dom_cert_rfe :
  dom_rel cert_rfe ⊆₁ I.
Proof.
  unfold cert_rfe.
  rewrite cert_rf_iss_sb.
  basic_solver.
Qed.

End Properties.

End CertRf.

Section CertRfLemmas.
Variable G  : execution.
Variable sc : relation actid.
Variable WF  : Wf G.
Variable COH : imm_consistent G sc.

Notation "'E'"  := G.(acts_set).
Notation "'lab'" := (G.(lab)).
Notation "'rmw'" := G.(rmw).

Notation "'Tid_' t" := (fun x => tid x = t) (at level 1).
Notation "'NTid_' t" := (fun x => tid x <> t) (at level 1).

Notation "'R'" := (fun a => is_true (is_r lab a)).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'F'" := (fun a => is_true (is_f lab a)).

Notation "'Acq'" := (fun a => is_true (is_acq lab a)).
Notation "'Rel'" := (fun a => is_true (is_rel lab a)).
Notation "'Sc'" := (fun a => is_true (is_sc lab a)).
Notation "'Acq/Rel'" := (fun a => is_true (is_ra lab a)).

Notation "'sb'"  := (G.(sb)).
Notation "'ppo'" := (G.(ppo)).
Notation "'sw'"  := (G.(imm_s_hb.sw)).
Notation "'hb'"  := (G.(imm_s_hb.hb)).
Notation "'rf'"  := (G.(rf)).
Notation "'rfi'" := (G.(rfi)).
Notation "'rfe'" := (G.(rfe)).
Notation "'co'"  := (G.(co)).
Notation "'loc'" := (loc lab).

Notation "'Loc_' l" := (fun x => loc x = Some l) (at level 1).
Notation "'W_' l" := (W ∩₁ Loc_ l) (at level 1).
Notation "'R_' l" := (R ∩₁ Loc_ l) (at level 1).

Notation "'furr'" := (furr G sc).

Lemma sim_trav_step_CsbI_mon TC TC'
      (TCOH : tc_coherent G sc TC)
      (TRAV_STEP : sim_trav_step G sc TC TC') :
  CsbI G TC ⊆₁ CsbI G TC'.
Proof.
  unfold CsbI.
  rewrite sim_trav_step_covered_le; eauto.
  rewrite sim_trav_step_issued_le; eauto.
Qed.

Lemma sim_trav_step_D_mon TC TC'
      (TCOH : tc_coherent G sc TC)
      (TRAV_STEP : sim_trav_step G sc TC TC') :
  D G TC ⊆₁ D G TC'.
Proof.
  unfold D.
  rewrite sim_trav_step_covered_le; eauto.
  rewrite sim_trav_step_issued_le; eauto.
Qed.

Lemma sim_trav_step_vf_mon TC TC'
      (TCOH : tc_coherent G sc TC)
      (TRAV_STEP : sim_trav_step G sc TC TC') :
  vf G sc TC ⊆ vf G sc TC'.
Proof.
  unfold vf.
  rewrite sim_trav_step_covered_le; eauto.
  rewrite sim_trav_step_D_mon; eauto.
  done.
Qed.

Lemma sim_trav_step_cert_rf_co TC TC'
      (TCOH : tc_coherent G sc TC)
      (TRAV_STEP : sim_trav_step G sc TC TC') :
  cert_rf G sc TC ⨾ (cert_rf G sc TC')⁻¹ ⊆ co^?.
Proof.
  intros x y [z [CertRF CertRF']].
  red in CertRF'.
  destruct (classic (x = y))
    as [EQ|nEQ].
  { basic_solver. }
  edestruct wf_co_total
    as [CO|CO]; eauto.
  { unfolder. splits.
    { apply cert_rfE in CertRF; auto.
      generalize CertRF. basic_solver. }
    { apply cert_rfD in CertRF; auto.
      generalize CertRF. basic_solver. }
    edone. }
  { unfolder. splits.
    { apply cert_rfE in CertRF'; auto.
      generalize CertRF'. basic_solver. }
    { apply cert_rfD in CertRF'; auto.
      generalize CertRF'. basic_solver. }
    symmetry.
    apply cert_rfl in CertRF.
    apply cert_rfl in CertRF'.
    congruence. }
  exfalso.
  unfold cert_rf in *.
  apply CertRF'.
  exists x; splits; auto.
  eapply sim_trav_step_vf_mon; eauto.
  generalize CertRF. basic_solver.
Qed.

Lemma isim_trav_step_vf_ntid thread TC TC'
      (NINITT : thread <> tid_init)
      (TCOH : tc_coherent G sc TC)
      (RELCOH : W ∩₁ Rel ∩₁ (issued TC) ⊆₁ covered TC)
      (ITRAV_STEP : isim_trav_step G sc thread TC TC') :
  vf G sc TC' ⨾ ⦗CsbI G TC ∩₁ NTid_ thread⦘ ⊆ vf G sc TC.
Proof.
  assert (sim_trav_step G sc TC TC')
    as TRAV_STEP.
  { eexists; edone. }
  assert (tc_coherent G sc TC')
    as TCCOH'.
  { eapply sim_trav_step_coherence; eauto. }
  assert (W ∩₁ Rel ∩₁ issued TC' ⊆₁ covered TC')
    as RELCOH'.
  { eapply sim_trav_step_rel_covered; eauto. }
  rewrite !vf_alt; eauto.
  rewrite !seq_union_l.

  rewrite !seqA.
  arewrite
    (sb^? ⨾ ⦗CsbI G TC ∩₁ NTid_ thread⦘ ⊆ ⦗CsbI G TC ∩₁ NTid_ thread⦘ ⨾ sb^?).
  { rewrite !crE. relsf.
    apply union_mori; try done.
    rewrite seq_eqv_l, seq_eqv_r.
    intros x y [SB [CsbIy nTIDy]].
    unfolder; splits; auto.
    { eapply CsbI_sb_prcl; eauto. basic_solver 10. }
    intros TIDx.
    apply sb_tid_init in SB.
    destruct SB as [EQtid | INITx].
    { congruence. }
    apply is_init_tid in INITx.
    congruence. }

  repeat apply union_mori.

  { rewrite crE
      with (r := rf ⨾ ⦗covered TC'⦘).
    relsf. unionL.
    { basic_solver 20. }
    rewrite !seqA.
    arewrite
      (⦗E⦘ ⨾ ⦗CsbI G TC ∩₁ NTid_ thread⦘ ⊆
       ⦗CsbI G TC⦘ ⨾ ⦗NTid_ thread⦘ ⨾ ⦗E⦘).
    { basic_solver. }
    arewrite
      (hb^? ⨾ sc^? ⨾ hb^? ⨾ ⦗CsbI G TC⦘ ⊆
       (⦗covered TC⦘ ⨾ hb^? ⨾ sc^? ⨾ hb^? ∪ sb)^?).
    { eapply hb_sc_hb_CsbI_alt; auto. }
    rewrite crE. relsf. unionL.
    { erewrite isim_trav_step_new_covered_tid;
        eauto.
      basic_solver 20. }
    { basic_solver 20. }
    arewrite
      (sb ⨾ ⦗NTid_ thread⦘ ⊆ ⦗NTid_ thread⦘ ⨾ sb).
    { rewrite seq_eqv_r, seq_eqv_l.
      intros x y [SB nTIDy].
      split; auto.
      apply sb_tid_init in SB.
      destruct SB as [EQtid | INITx].
      { congruence. }
      apply is_init_tid in INITx.
      congruence. }
    erewrite isim_trav_step_new_covered_tid;
      eauto.
    rewrite sb_in_hb.
    basic_solver 20. }

  { erewrite isim_trav_step_new_covered_tid;
      eauto.
    basic_solver 10. }

  { seq_rewrite !seq_eqv_r.
    intros x y [z [HH SB']].
    destruct HH as [HH [CsbIz nTIDz]].
    destruct HH as [RF [z' [PPO Iy']]].
    do 2 (eexists; splits; eauto).
    eapply isim_trav_step_new_issued_tid in Iy'; eauto.
    destruct Iy' as [[Iy _] | [Iy' TIDy]]; auto.
    assert (SB := PPO).
    apply ppo_in_sb in SB; auto.
    apply sb_tid_init in SB.
    destruct SB as [EQtid | INITx].
    { congruence. }
    eapply init_w in INITx; eauto.
    apply wf_ppoD in PPO.
    exfalso.
    generalize PPO.
    type_solver. }

  { arewrite
      (rfi ⨾ ⦗CsbI G TC ∩₁ NTid_ thread⦘ ⊆ ⦗CsbI G TC ∩₁ NTid_ thread⦘ ⨾ rfi).
    { rewrite seq_eqv_l, seq_eqv_r.
      intros x y [RFI [CsbIy nTIDy]].
      assert (sb x y) as SB.
      { apply RFI. }
      unfolder; splits; auto.
      { eapply CsbI_sb_prcl; eauto. basic_solver 10. }
      intros TIDx.
      apply sb_tid_init in SB.
      destruct SB as [EQtid | INITx].
      { congruence. }
      apply is_init_tid in INITx.
      congruence. }
    erewrite isim_trav_step_new_issued_tid;
      eauto.
    basic_solver 10. }

  basic_solver 10.

Qed.

Lemma isim_trav_step_cert_rf_ntid thread TC TC'
      (NINITT : thread <> tid_init)
      (TCOH : tc_coherent G sc TC)
      (RELCOH : W ∩₁ Rel ∩₁ (issued TC) ⊆₁ covered TC)
      (ITRAV_STEP : isim_trav_step G sc thread TC TC') :
  cert_rf G sc TC ⨾ ⦗NTid_ thread⦘ ⊆ cert_rf G sc TC'.
Proof.
  assert (sim_trav_step G sc TC TC')
    as TRAV_STEP.
  { eexists; edone. }
  unfold cert_rf.
  rewrite !seq_eqv_r
    with (dom := CsbI G TC ∩₁ R).
  rewrite !seq_eqv_r.
  intros x y [CertRF nTIDy].
  destruct CertRF as [VF nCOVF].
  destruct VF as [[VF EQloc] [CsbIy Ry]].
  unfolder; splits; auto.
  { eapply sim_trav_step_vf_mon; eauto. }
  { eapply sim_trav_step_CsbI_mon; eauto. }
  intros [z [CO VF']].
  apply nCOVF.
  exists z; splits; auto.
  eapply isim_trav_step_vf_ntid; eauto.
  basic_solver.
Qed.

End CertRfLemmas.


From Coq Require Import FSets.FMapPositive.
From Velus Require Import Common.
From Velus Require Import Operators.
From Velus Require Import Clocks.
From Velus Require Import CoreExpr.CESyntax.

From Coq Require Import List.
From Coq Require Import Morphisms.
From Coq Require Import Permutation.

(** * Well clocked expressions *)

Module Type CECLOCKING
       (Import Ids  : IDS)
       (Import Op   : OPERATORS)
       (Import Syn  : CESYNTAX Op).

  Inductive SameVar : option ident -> exp -> Prop :=
  | SVNone: forall e,
      SameVar None e
  | SVSome: forall x ty,
      SameVar (Some x) (Evar x ty).

  Section WellClocked.

    Variable vars : list (ident * clock).

    Inductive wc_exp : exp -> clock -> Prop :=
    | Cconst:
        forall c,
          wc_exp (Econst c) Cbase
    | Cvar:
        forall x ck ty,
          In (x, ck) vars ->
          wc_exp (Evar x ty) ck
    | Cwhen:
        forall e x b ck,
          wc_exp e ck ->
          In (x, ck) vars ->
          wc_exp (Ewhen e x b) (Con ck x b)
    | Cunop:
        forall op e ck ty,
          wc_exp e ck ->
          wc_exp (Eunop op e ty) ck
    | Cbinop:
        forall op e1 e2 ck ty,
          wc_exp e1 ck ->
          wc_exp e2 ck ->
          wc_exp (Ebinop op e1 e2 ty) ck.

    Inductive wc_cexp : cexp -> clock -> Prop :=
    | Cmerge:
        forall x t f ck,
          In (x, ck) vars ->
          wc_cexp t (Con ck x true) ->
          wc_cexp f (Con ck x false) ->
          wc_cexp (Emerge x t f) ck
    | Cite:
        forall b t f ck,
          wc_exp b ck ->
          wc_cexp t ck ->
          wc_cexp f ck ->
          wc_cexp (Eite b t f) ck
    | Cexp:
        forall e ck,
          wc_exp e ck ->
          wc_cexp (Eexp e) ck.

  End WellClocked.

  (** ** Basic properties of clocking *)

  Lemma wc_clock_exp:
    forall vars le ck,
      wc_env vars ->
      wc_exp vars le ck ->
      wc_clock vars ck.
  Proof.
    induction le as [| |le IH | |] (* using exp_ind2 *).
    - inversion_clear 2; now constructor.
    - intros ck Hwc; inversion_clear 1 as [|? ? ? Hcv| | |].
      apply wc_env_var with (1:=Hwc) (2:=Hcv).
    - intros ck Hwc.
      inversion_clear 1 as [| |? ? ? ck' Hle Hcv | |].
      constructor; [now apply IH with (1:=Hwc) (2:=Hle)|assumption].
    - intros ck Hwc; inversion_clear 1; auto.
    - intros ck Hwc; inversion_clear 1; auto.
  Qed.

  Lemma wc_clock_cexp:
    forall vars ce ck,
      wc_env vars ->
      wc_cexp vars ce ck ->
      wc_clock vars ck.
  Proof.
    induction ce as [i ce1 IH1 ce2 IH2| |].
    - intros ck Hwc.
      inversion_clear 1 as [? ? ? ? Hcv Hct Hcf| |].
      apply IH1 with (1:=Hwc) in Hct.
      inversion_clear Hct; assumption.
    - intros ck Hwc; inversion_clear 1 as [|? ? ? ? Hl H1 H2|].
      now apply IHce1.
    - intros ck Hwc; inversion_clear 1 as [| |? ? Hck].
      apply wc_clock_exp with (1:=Hwc) (2:=Hck).
  Qed.

  Hint Constructors wc_clock wc_exp wc_cexp : nlclocking.
  Hint Resolve Forall_nil : nlclocking.

  Instance wc_exp_Proper:
    Proper (@Permutation (ident * clock) ==> @eq exp ==> @eq clock ==> iff)
           wc_exp.
  Proof.
    intros env' env Henv e' e He ck' ck Hck.
    rewrite He, Hck; clear He Hck e' ck'.
    revert ck.
    induction e;
      split; auto with nlclocking;
        inversion_clear 1;
        (rewrite Henv in * || rewrite <-Henv in * || idtac);
        try edestruct IHe;
        try edestruct IHe1, IHe2;
        auto with nlclocking.
  Qed.

  Instance wc_cexp_Proper:
    Proper (@Permutation (ident * clock) ==> @eq cexp ==> @eq clock ==> iff)
           wc_cexp.
  Proof.
    intros env' env Henv e' e He ck' ck Hck.
    rewrite He, Hck; clear He Hck e' ck'.
    revert ck.
    induction e;
      split; inversion_clear 1;
        (rewrite Henv in * || rewrite <-Henv in *);
         constructor; auto;
         now (rewrite <-IHe1 || rewrite IHe1
              || rewrite <-IHe2 || rewrite IHe2).
  Qed.

End CECLOCKING.

Module CEClockingFun
       (Import Ids  : IDS)
       (Import Op   : OPERATORS)
       (Import Syn  : CESYNTAX Op)
  <: CECLOCKING Ids Op Syn.
  Include CECLOCKING Ids Op Syn.
End CEClockingFun.


Require Import CSet Le Arith.Compare_dec.

Require Import Plus Util Map CMap Status Take Subset1 ListMax.
Require Import Val Var Envs IL Annotation Liveness.Liveness MoreList SetOperations.
Require Import AnnotationLattice AnnP.
Require Import Coherence Coherence.Allocation RenamedApart AllocationAlgo.
Require Import RenamedApart_Liveness LabelsDefined Restrict InfiniteSubset InfinitePartition MapSep.
Require Import RenameApart_Partition Filter AllocationAlgoSep StableFresh.

Set Implicit Arguments.

Require Import AllocationAlgoCorrect AnnP BoundedIn VarP SmallestK.

Lemma mapAnn_renamedApart al ans s (ϱ ϱ': var -> var)
      (P1:Proper (_eq ==> _eq) ϱ) (P2:Proper (_eq ==> _eq) ϱ')
      (AR:ann_R Subset1 al ans)
      (RA:renamedApart s ans)
      (AGR:agree_on _eq (fst (getAnn ans) ∪ snd (getAnn ans)) ϱ ϱ')
:  ann_R SetInterface.Equal (mapAnn (lookup_set ϱ) al)
         (mapAnn (lookup_set ϱ') al).
Proof.
  general induction RA; invt @ann_R; pe_rewrite; simpl in *; set_simpl.
  - econstructor; eauto.
    + eapply lookup_set_agree; eauto.
      simpl. eapply agree_on_incl; eauto. eauto with cset.
    + eapply IHRA; eauto using agree_on_incl with cset.
  - econstructor; eauto.
    + eapply lookup_set_agree; eauto.
      simpl. eapply agree_on_incl; eauto. eauto with cset.
    + eauto using agree_on_incl with cset.
    + eauto using agree_on_incl with cset.
  - econstructor; eauto.
    + eapply lookup_set_agree; eauto.
      simpl. eapply agree_on_incl; eauto.
  - econstructor; eauto.
    + eapply lookup_set_agree; eauto.
      simpl. eapply agree_on_incl; eauto.
  - econstructor; eauto.
    + eapply lookup_set_agree; eauto.
      simpl. eapply agree_on_incl; eauto. rewrite <- H9. clear; cset_tac.
    + eauto with len.
    + intros; inv_get.
      eapply H1; eauto.
      simpl. eapply agree_on_incl; eauto.
      eapply ans_incl_D_union; eauto.
    + eapply IHRA; eauto.
      simpl. eapply agree_on_incl; eauto.
      clear; cset_tac.
Qed.

Lemma regAssign_assignment_small k p o (ϱ:Map [var,var]) ZL Lv s alv ϱ' ra
      (LS:live_sound Functional ZL Lv s alv)
      (inj:injective_on (getAnn alv) (findt ϱ default_var))
      (SEP:sep var p (getAnn alv) (findt ϱ default_var))
      (RA:renamedApart s ra)
      (INCL:ann_R Subset1 alv ra)
      (allocOK:regAssign p o s alv ϱ = Success ϱ')
      (BND:ann_P (part_size_bounded (part_1 p) k) alv)
      (up:For_all (part_vars_bounded (part_1 p) k) (lookup_set (findt ϱ default_var) (getAnn alv)))
  : ann_P (For_all (part_vars_bounded (part_1 p) k)) (mapAnn (lookup_set (findt ϱ' default_var)) alv).
Proof.
  general induction LS; invt ann_P; invt renamedApart; invt @ann_R; simpl in *.
  - econstructor; eauto.
    + exploit regAssign_renamedApart_agree; eauto using live_sound.
      pe_rewrite.
      rewrite <- map_update_update_agree in H2.
      eapply agree_on_update_inv in H2.
      rewrite <- lookup_set_agree; swap 1 4.
      simpl. eapply agree_on_incl; eauto. revert H10 H7; clear; cset_tac.
      eauto. eauto. eauto.
    + eapply IHLS; eauto.
      * eapply injective_on_agree; [|eapply map_update_update_agree].
        eapply injective_on_update_fresh; eauto using injective_on_incl.
        eapply least_fresh_part_fresh.
      * rewrite <- map_update_update_agree.
        eapply sep_update_part.
        eauto using sep_incl.
      * hnf; intros.
        rewrite <- lookup_set_agree in H2; swap 1 4.
        eapply map_update_update_agree. eauto. eauto.
        assert (EQal:getAnn al [=] getAnn al \ singleton x ∪ singleton x). {
          revert H1. clear.
          cset_tac.
        }
        eapply lookup_set_morphism_eq in H2; [|rewrite EQal; reflexivity].
        rewrite lookup_set_union in H2. eapply union_iff in H2; destruct H2.
        -- rewrite lookup_set_agree in H2; swap 1 4.
           eapply agree_on_update_dead. clear. cset_tac. reflexivity. eauto. eauto.
           eapply up. rewrite <- H0. eauto.
        -- rewrite lookup_set_singleton' in H2; eauto. eapply In_single in H2.
           invc H2. lud; [|isabsurd].
           hnf; intros. eapply ann_P_get in H5.
           eapply least_fresh_part_small1. eauto.
           rewrite <- sep_filter_map_comm.
           rewrite <- H5. rewrite cardinal_map.
           eapply subset_cardinal_lt with (x0 := x).
           rewrite filter_difference. eauto with cset. eauto.
           eapply zfilter_3; eauto.
           eapply least_fresh_part_p1 in H2. eauto.
           rewrite filter_incl. clear. cset_tac.
           eauto. eauto. eauto. eapply sep_incl; eauto.
        -- eauto.
  - monadS_inv allocOK.
    exploit regAssign_renamedApart_agree; eauto using live_sound. pe_rewrite.
    exploit regAssign_renamedApart_agree; try eapply EQ; eauto using live_sound. pe_rewrite.
    exploit regAssign_renamedApart_agree'; eauto. pe_rewrite.
    econstructor; eauto.
    + rewrite <- lookup_set_agree; eauto.
      simpl.
      etransitivity; eauto using agree_on_incl.
    + exploit IHLS1; eauto.
      * eauto using injective_on_incl; eauto.
      * rewrite H0. eauto.
      * eapply ann_P_morph with (R:=SetInterface.Equal); eauto.
        intros. rewrite <- H17. eauto.
        eapply mapAnn_renamedApart; eauto.
        eapply agree_on_incl; eauto.
        pe_rewrite. rewrite <- disj_eq_minus; try reflexivity.
        eapply disj_union_left. symmetry. eapply renamedApart_disj in H12. pe_rewrite. eauto.
        symmetry; eauto.
    + exploit IHLS2; try eapply EQ0; eauto.
      * eapply injective_on_agree; swap 1 2.
        simpl.
        eapply agree_on_incl. eapply H3. etransitivity; eauto.
        eauto using injective_on_incl; eauto.
      * rewrite H1. eapply sep_agree. eauto using agree_on_incl.
        eauto.
      * rewrite <- lookup_set_agree; swap 1 4.
        simpl. eapply agree_on_incl; eauto. etransitivity; eauto.
        eauto. eauto. rewrite H1. eauto.
  - econstructor.
    eauto.
  - econstructor; eauto.
  - monadS_inv allocOK.
    exploit regAssign_renamedApart_agree; eauto using live_sound. pe_rewrite.
    exploit regAssign_renamedApart_agreeF'; eauto using live_sound.
    intros. eapply regAssign_renamedApart_agree'; eauto using live_sound.
    reflexivity.
    econstructor; eauto.
    + rewrite <- lookup_set_agree; eauto.
      simpl.
      etransitivity; eauto using agree_on_incl.
      eapply agree_on_incl; eauto.
      rewrite <- disj_eq_minus; try reflexivity.
      rewrite H19.  eapply disj_D_defVars; eauto.
    + intros. inv_get.
      edestruct regAssignF_get; eauto.
      * intros. exploit disj_D_defVars; eauto.
        eapply renamedApart_disj in H13. pe_rewrite.
        eapply defVars_disj_D; eauto. eapply disj_union_right; eauto.
      * dcr. instantiate (1:=fst (getAnn x1) ∪ snd (getAnn x1)) in H27.
        rewrite <- disj_eq_minus in H27; try reflexivity; swap 1 2.
        {
          edestruct H11; dcr; eauto.
          rewrite H20. setoid_rewrite union_comm at 2. rewrite union_assoc.
          eapply disj_union_left; symmetry.
          eapply disj_D_defVars_take; eauto.
          exploit defVars_take_disj; eauto.
        }
        rewrite <- map_update_list_update_agree' in H27; eauto with len.
        assert (INCLx0:getAnn x0 ⊆ fst (getAnn x1) ∪ snd (getAnn x1)). {
          exploit H22; eauto.
          eapply ann_R_get in H20. rewrite H20. eauto with cset.
        }
        assert (DECOMP:getAnn x0 [=] getAnn x0 \ of_list (fst x2) ∪ of_list (fst x2)). {
          edestruct H2; eauto; dcr.
          revert H20; clear; cset_tac.
        }
        assert (Inclx2:getAnn x0 \ of_list (fst x2) ⊆ lv). {
          edestruct H2; eauto; dcr.
        }
        exploit H1; eauto.
        -- eapply injective_on_agree; simpl; eauto using agree_on_incl.
           rewrite DECOMP at 1.
           eapply injective_on_fresh_list. eauto.
           eapply injective_on_incl; eauto. eauto with len.
           eapply fresh_list_stable_spec.
           eapply fresh_list_stable_nodup.
        -- eapply sep_agree; eauto.
           eapply agree_on_incl; eauto.
           rewrite DECOMP at 1.
           eapply sep_update_list; eauto.
           edestruct H2; eauto.
           eapply sep_incl; eauto.
           rewrite <- Inclx2. clear. cset_tac.
        -- rewrite <- lookup_set_agree; swap 1 4; eauto using agree_on_incl.
           rewrite DECOMP at 2.
           rewrite lookup_set_union; eauto.
           rewrite lookup_set_update_disj; eauto; swap 1 2.
           clear. cset_tac.
           rewrite For_all_union; split.
           ++ rewrite Inclx2. eauto.
           ++ edestruct H2; eauto; dcr.
             rewrite update_with_list_lookup_list; eauto with len.
             eapply fresh_list_stable_small; eauto.
             exploit H8 as BNDk; eauto. eapply ann_P_get in BNDk.
             hnf in BNDk.
             rewrite DECOMP in BNDk.
             rewrite filter_union in BNDk; eauto.
             rewrite union_cardinal in BNDk; eauto; swap 1 2.
             rewrite !filter_incl; eauto.
             rewrite <- cardinal_map with (f:=findt ϱ default_var) in BNDk; eauto.
             rewrite <- sep_filter_map_comm; eauto.
        -- eapply ann_P_morph with (R:=SetInterface.Equal); eauto.
           intros. rewrite <- H26. eauto.
           eapply mapAnn_renamedApart; eauto.
           eapply regAssign_renamedApart_agreeF' with (ans:=drop (S n ) ans) in H24;
             eauto; try reflexivity; intros; inv_get; eauto with len.
           ++ etransitivity. eapply agree_on_incl; eauto.
             rewrite <- disj_eq_minus; swap 1 3.
             eapply disj_fst_snd_ra; eauto. reflexivity. reflexivity.
             eapply agree_on_incl.
             eapply regAssign_renamedApart_agree'; try eapply EQ0; eauto.
             pe_rewrite.
             rewrite <- disj_eq_minus; swap 1 3; try reflexivity.
             eapply disj_fst_snd_Dt; eauto.
           ++ eapply regAssign_renamedApart_agree' in H30; eauto.
    + exploit IHLS; try eapply EQ0; eauto.
      * eapply injective_on_agree; swap 1 2.
        change _eq with (@eq var).
        eapply agree_on_incl. eapply H5. etransitivity; eauto.
        rewrite <- disj_eq_minus; try reflexivity.
        rewrite H19.  eapply disj_D_defVars; eauto.
        eauto using injective_on_incl; eauto.
      * eapply sep_incl; eauto.
        etransitivity; eauto.
        rewrite <- disj_eq_minus; try reflexivity.
        rewrite H19.  eapply disj_D_defVars; eauto.
      * rewrite <- lookup_set_agree; swap 1 4.
        eapply agree_on_incl; eauto.
        etransitivity; eauto.
        rewrite <- disj_eq_minus; try reflexivity.
        rewrite H19.  eapply disj_D_defVars; eauto. eauto. eauto.
        rewrite H3. eauto.
Qed.

Lemma regAssign_assignment_small_I k p o (ϱ:Map [var,var]) ZL Lv s alv ϱ' ra
      (LS:live_sound Imperative ZL Lv s alv)
      (inj:injective_on (getAnn alv) (findt ϱ default_var))
      (SEP:sep var p (getAnn alv) (findt ϱ default_var))
      (RA:renamedApart s ra)
      (INCL:ann_R Subset1 alv ra)
      (allocOK:regAssign p o s alv ϱ = Success ϱ')
      (BND:ann_P (part_size_bounded (part_1 p) k) alv)
      (up:For_all (part_vars_bounded (part_1 p) k) (lookup_set (findt ϱ default_var) (getAnn alv)))
      (BOUND:bounded (Some ⊝ Lv \\ ZL) (fst (getAnn ra)))
      (NUC:noUnreachableCode (isCalled true) s)
  : ann_P (For_all (part_vars_bounded (part_1 p) k)) (mapAnn (lookup_set (findt ϱ' default_var)) alv).
Proof.
  intros.
  eapply renamedApart_live_imperative_is_functional in LS; eauto using bounded_disjoint, renamedApart_disj, meet1_Subset1, live_sound_annotation, renamedApart_annotation.
  eapply live_sound_overapproximation_F in LS.
  exploit regAssign_assignment_small; eauto using locally_inj_subset, meet1_Subset, live_sound_annotation, renamedApart_annotation.
Qed.

Lemma ann_P_live_var_P i ZL Lv p k s lv
  : ann_P (For_all (part_vars_bounded p k)) lv
    -> live_sound i ZL Lv s lv
    -> var_P (part_vars_bounded p k) s.
Proof.
  intros ANN LS.
  general induction LS; invt ann_P; eauto using var_P, ann_P_get.
  - econstructor; eauto.
    + eapply ann_P_get in H5. eauto.
    + rewrite Exp.freeVars_live; eauto.
  - econstructor; eauto.
    rewrite Ops.freeVars_live; eauto.
  - econstructor; eauto.
    rewrite Ops.freeVars_live_list; eauto.
  - econstructor; eauto.
    rewrite Ops.freeVars_live; eauto.
  - econstructor; intros; inv_get; eauto.
    edestruct H2; dcr; eauto.
    exploit H8; eauto. eapply ann_P_get in H10.
    rewrite H6; eauto.
Qed.


(* PREAMBLE *)

From compcert.cfrontend     Require Csyntax.
From trancert.properties    Require State Env.
From trancert.lib           Require All.

Import Csem properties.State properties.Env List Memory.Mem BinNums Coqlib lib.All Maps PTree ZArith.

Open Scope positive.

Section Norepet.
  Let alloc_variables_blocks_norepet_aux:
    forall (ge : genv) ls e1  m1 e2 m2,
      list_norepet (List.map fst ls) ->
      (forall i b, get i e1 = Some b -> ~ In i (List.map fst ls)) ->
      list_norepet (List.map (fst ∘ fst) (blocks_of_env ge e1)) ->
      (forall b x t, get x e1 = Some (b,t) -> b < nextblock m1) ->
      alloc_variables ge e1 m1 ls e2 m2 ->
      list_norepet (List.map (fst ∘ fst) (blocks_of_env ge e2))
  .
  Proof.
    unfold blocks_of_env,block_of_binding.
    move => ge ls e1 m1 e2 m2.
    move => Hnorepet Hcond1 Hcond2 Hmem Halloc.
    rewrite List.map_map in Hcond2; rewrite List.map_map.
    rewrite <-(map_ext (fun x : AST.ident * (Values.block * Ctypes.type) => fst (snd x))) in *; try by intros (? & (? & ?)).
    generalize dependent e1.
    generalize dependent e2.
    generalize dependent m1.
    generalize dependent m2.
    generalize dependent ge.
    induction ls; simpl in *; intros; inv Halloc; auto.
    exploit alloc_result; eauto. intro; subst.
    exploit nextblock_alloc; eauto. intro Hnext.
    inv Hnorepet.
    eapply IHls in H6; eauto; clear IHls.
    - intros i b H. destruct (peq i id); first by subst.
      rewrite gso in H; auto.
      apply Hcond1 in H.
      simpl in *.
      contradict H. auto.
    - intros b x t0 H.
      rewrite Hnext.
      rewrite gsspec in H.
      destruct (peq _ _).
      + inv H. apply Pos.lt_succ_diag_r.
      + apply Hmem in H. eapply Pos.lt_trans; eauto.
        apply Pos.lt_succ_diag_r.
    - rewrite map_elem .
      rewrite map_elem in Hcond2.
      apply elements_list_norepet.
      pose proof list_norepet_elements _ Hcond2 as H''.
      move => x y v Hget1 Hget2.
      rewrite gmap gsspec in Hget1.
      rewrite gmap gsspec in Hget2.
      destruct (peq x _), (peq y _); subst; auto; simpl in *; try autoinj.
      exfalso.
      + destruct (e1 ! y) eqn: Hget; try discriminate.
        destruct p.
        eapply Hmem in Hget.
        simpl in *. autoinj. by apply Pos.lt_irrefl in Hget.
      + destruct (e1 ! x) eqn: Hget; try discriminate.
        destruct p.
        eapply Hmem in Hget.
        simpl in *. autoinj. by apply Pos.lt_irrefl in Hget.
      + eapply H''; rewrite gmap; by eauto.
  Qed.

  Theorem alloc_variables_blocks_norepet:
    forall (ge:genv) ls m1 e2 m2,
      list_norepet (List.map fst ls) ->
      alloc_variables ge empty_env m1 ls e2 m2 ->
      list_norepet (List.map (fst ∘ fst) (blocks_of_env ge e2)).
  Proof.
    intros ge ls m1 e2 m2 H H0.
    eapply alloc_variables_blocks_norepet_aux; eauto.
    - intros. rewrite gempty in H1. discriminate.
    - constructor.
    - intros. rewrite gempty in H1. discriminate.
  Qed.

End Norepet.

(** Local variables are allocated in valid blocks. *)
Theorem alloc_variables_inside:
  forall e1 m1 vars e2 m2 ge,
    alloc_variables ge e1 m1 vars e2 m2 ->
    env_inside m1 e1 -> env_inside m2 e2.
Proof.
  unfold env_inside, valid_block.
  intros e1 m1 vars e2 m2 ge H.
  induction H; eauto.
  intros Hpre id0 b t0 Hget.
  eapply IHalloc_variables.
  - move => ? ? ?. move: gsspec -> .
    exploit alloc_result; eauto 1 => ->.
    erewrite (nextblock_alloc m _ _ m1); last by eassumption.
    destruct (peq _ _).
    + intros; autoinj.
      rewrite Pplus_one_succ_r. by apply Pos.lt_add_r.
    + intros.
      eapply (Pos.lt_trans _ (nextblock m)).
      eapply Hpre; eauto.
      rewrite Pplus_one_succ_r. apply Pos.lt_add_r.
  - eassumption.
Qed.

(** Allocating new variables in an existing local environment preserves its
contents. *)

Theorem alloc_variables_preserves:
  forall id ge e1 m1 vs e2 m2,
    (forall ty, ~ In (id, ty) vs) ->
    alloc_variables ge e1 m1 vs e2 m2 ->
    get id e2 = get id e1.
Proof.
  intros until m2.
  induction 2 =>//=.
  simpl in *.
  rewrite gso in IHalloc_variables.
  - by contradict H; subst; eauto.
  - eapply IHalloc_variables.
    intros ty0 H''. eapply (H ty0). by right.
Qed.

(** Allocating a list of variables [ls] produces an environment that contains
the variables from [ls]. *)

Theorem alloc_variables_get :
  forall (ge: genv) e1 m1 (ls : list (AST.ident * Ctypes.type))  e2 m2 ty id,
    list_norepet (List.map fst ls) ->
    e1 ! id = None ->
    alloc_variables ge e1 m1 ls e2 m2 ->
    In (id, ty) ls ->
    exists b, e2 ! id = Some (b,ty).
Proof.
  move=>ge e1 m1 ls. move: ls ge e1 m1.
  elim; first by inversion 2.
  intros a l IH ge e1 m1 e2 m2 ty id Hnorepet Hget Halloc.
  inv Halloc.
  inv Hnorepet.
  move => [Hin|Hin].
  - inv Hin.
    erewrite alloc_variables_preserves; eauto.
    + by rewrite gss; eauto.
    + move => ty0. contradict H1.
      replace id with (fst (id, ty0)); by [eapply (in_map fst)|done].
  - eapply IH in H6; eauto.
    destruct (peq id id0).
    + subst. contradiction H1.
      replace id0 with (fst (id0, ty)); by [eapply (in_map fst)|done].
    + by rewrite gso.
Qed.

(** Allocating new variables in an existing local environment preserves its contents. *)
Theorem alloc_variables_set_commute:
  forall ge ls e1 m1  e2 m2 i b ty,
    (forall t, ~In (i, t) ls) ->
    alloc_variables ge e1 m1 ls e2 m2 ->
    alloc_variables ge (set i (b,ty) e1) m1 ls (set i (b,ty) e2) m2.
Proof.
  induction ls.
  - by inversion 2; constructor.
  - intros until ty.
    inversion 2; subst.
    econstructor; eauto 1.
    have Hi: (i <> id) by (contradict H; subst; simpl; by eauto).
    rewrite set_set_commute; auto.
    eapply IHls; eauto.
    intros t0 Hin.
    eapply H; simpl; eauto.
Qed.

(** If the environment contained no variable [i] and neither did the list [ls]
    then allocating [ls] will preserve the absence of [i]. *)

Theorem alloc_variables_none_preserves:
  forall i ls e1 e2 ge m1 m2,
    get i e1 = None ->
    alloc_variables ge e1 m1 ls e2 m2 ->
    (forall ty, ~In (i, ty) ls) ->
    get i e2 = None.
Proof.
  induction ls; inversion 2; subst =>//=.
  intros.
  inv H0.
  eapply IHls; try eapply H8.
  - rewrite gsspec.
    destruct (peq _ _) =>//=.
    + by subst; contradiction (H1 ty); auto.
  - intros ty0 Hnotin.
      by contradiction (H1 ty0); auto.
Qed.

(** After allocation of a list of unique variables the resulting environment
will contain them. *)

Theorem alloc_variables_spec:
  forall hs id ty ts e1 m1 e2 m2 ge,
    list_norepet (Csyntax.var_names (hs ++ (id,ty) :: ts)) ->
    alloc_variables ge e1 m1 (hs ++ (id,ty) :: ts) e2 m2 ->
    exists b, get id e2 = Some (b, ty).
Proof.
  elim.
  - move => id ty ts e1 m1 e2 m2 ge.
    do 2 inversion 1. subst.
    simpl in *.
    inv H.
    erewrite alloc_variables_preserves; eauto.
    + by rewrite gss; eauto.
    + move => ty0.
      contradict H5.
        by apply (in_map fst) in H5.
  - move => a l H id ty ts e1 m1 e2 m2 ge.
    do 2 inversion 1. subst.
      by eapply H in H13.
Qed.

(** Any other freeable environment will reman freeable after allocating local
variables. *)

Theorem alloc_variables_freeable_any:
  forall ge e e1 m1 ls e2 m2,
    alloc_variables ge e1 m1 ls e2 m2 ->
    env_freeable ge m1 e  ->
    env_freeable ge m2 e .
Proof.
  intros ge e e1 m1 ls e2 m2.
  induction 1 => //= => Hfreeable.
  eapply IHalloc_variables.
  intros i b t0 H2 delta Hdelta.
  eapply perm_alloc_1; eauto.
  eapply Hfreeable; eauto.
Qed.

(** Allocating variables produces a memory where variables can be freed (and preserves this property). *)

Theorem alloc_variables_freeable_after:
  forall ge e1 m1 ls e2 m2,
    alloc_variables ge e1 m1 ls e2 m2 ->
    env_freeable ge m1 e1  ->
    env_freeable ge m2 e2 .
Proof.
  move => ge e1 m1 ls e2 m2.
  induction 1 =>//.
  move => Hfreeable H1.
  eapply IHalloc_variables.
  intros i b t0 Hget delta Hdelta.
  rewrite gsspec in Hget.
  destruct (peq _ _).
  - autoinj. eapply perm_alloc_2; eauto.
  - eapply perm_alloc_1; eauto.
      by eapply Hfreeable; eauto.
Qed.

(** The maximal block index is not decreasing when variables are being
allocated. *)

Theorem alloc_variables_nextblock_le:
  forall (ge:Csem.genv) ls e1 m1 e2 m2,
    alloc_variables ge e1 m1 ls e2 m2 ->
    Ple (nextblock m1) (nextblock m2) .
Proof.
  induction ls.
    by inversion 1; apply Ple_refl.
    inversion 1; subst.
    eapply IHls in H7.
    exploit alloc_result; eauto.
    exploit nextblock_alloc; eauto.
    intros; subst.
    rewrite H0 in H7.
    eapply Ple_trans; eauto.
    eapply Ple_succ.
Qed.

(** Variables allocated in [m1] are placed after the last block of [m1]. *)
Theorem alloc_variables_block_range:
  forall (ge:Csem.genv) ls e1 m1 e2 m2 i b t,
    alloc_variables ge e1 m1 ls e2 m2 ->
    get i e2 = Some (b,t) ->
    get i e1 = Some (b,t) \/ b >= nextblock m1.
Proof.
  induction ls; inversion 1; subst; first by auto.
  intro Hget.
  exploit alloc_result; eauto.
  exploit nextblock_alloc; eauto.
  intros. subst.
  eapply IHls in H7; eauto.
  rewrite gsspec in H7.
  rewrite H0 in H7.
  destruct H7.
  - destruct (peq _ _); auto; autoinj.
      by right; apply Pos.le_ge; apply Ple_refl.
  - right.
    apply Pos.le_ge.
    eapply Ple_trans; eauto.
    apply Ple_succ.
      by apply Pos.ge_le.
Qed.

Lemma alloc_variables_nextblocks_len:
  forall ls (ge:genv) e1 m1 e2 m2,
    alloc_variables ge e1 m1 ls e2 m2 ->
    ls <> [] ->
    nextblock m2 = nextblock m1 + Pos.of_nat (length ls).
Proof.
  case. congruence.
  move => a ls. move: ls a. elim.
  - move => a ge e1 m1 e2 m2 H _. inv H. inv H7.
    exploit nextblock_alloc; eauto. simpl.
      by move => -> ; apply Pplus_one_succ_r.
  -
    move => [x y] l H a0 ge e1 m1 e2 m2 H0 _. inv H0.
    eapply H in H8; last by discriminate.
    exploit nextblock_alloc; eauto. simpl.
    rewrite H8 => ->.
    simpl.
    rewrite ! Pplus_one_succ_r.
    rewrite - Pos.add_assoc.
    apply Pos.add_cancel_l.
    apply Pos.add_comm.
Qed.

Theorem alloc_variables_app:
  forall xs ge e1 m1 ys e2 m2,
    Csem.alloc_variables ge e1 m1 (xs ++ ys) e2 m2 ->
    exists e' m',
      Csem.alloc_variables ge e1 m1 xs e' m' /\ Csem.alloc_variables ge e' m' ys e2 m2 .
Proof.
  induction xs.
  {
    intros.
    simpl in *.
    exists e1. exists m1.
    split; auto.
    constructor.
  }
  {
    intros.
    simpl in *.
    inv H.
    eapply IHxs in H7.
    destruct H7 as (e' & m' & Halloc & Hvars).
    eexists.
    eexists.
    split; eauto.
    econstructor; eassumption.
  }
Qed.

(** CompCert does not expose the internals of memory interface operations and it
also does not define enough properties to reason about allocations on the low
level. These two lemmas provide information about how the allocated memory is
constructed. *)

Theorem alloc_mem_contents:
  forall m m' lo hi nb ,
    alloc m lo hi = (m', nb) ->
    mem_contents m' = Maps.PMap.set (nextblock m) (Maps.ZMap.init Memdata.Undef) (mem_contents m).
Proof.
  intros m m' lo hi nb H.
  change alloc with (
fun (m : Memory.mem) (lo hi : Z) =>
({|
 mem_contents := Maps.PMap.set (nextblock m) (Maps.ZMap.init Memdata.Undef) (mem_contents m);
 mem_access := Maps.PMap.set (nextblock m)
                 (fun (ofs : Z) (_ : perm_kind) =>
                  if zle lo ofs && zlt ofs hi is true then Some Freeable else None)
                 (mem_access m);
 nextblock := Pos.succ (nextblock m);
 access_max := (fun (m0 : Memory.mem) (lo0 hi0 : Z) (b : positive) (ofs : Z) =>
                Memory.Mem.alloc_obligation_1 m0 lo0 hi0 b ofs) m lo hi;
 nextblock_noaccess := (fun (m0 : Memory.mem) (lo0 hi0 : Z) (b : positive)
                          (ofs : Z) (k : perm_kind) (H : ~ Plt b (Pos.succ (nextblock m0))) =>
                        Memory.Mem.alloc_obligation_2 m0 lo0 hi0 b ofs k H) m lo hi;
 contents_default := (fun (m0 : Memory.mem) (_ _ : Z) (b : positive) =>
                        Memory.Mem.alloc_obligation_3 m0 b) m lo hi |}, nextblock m)).

  simpl in *.
  inv H.
  reflexivity.
Qed.

Theorem alloc_mem_access:
forall m m' lo hi nb',
  alloc m lo hi = (m', nb') ->
  mem_access m' = Maps.PMap.set (nextblock m)
                           (fun (ofs : Z) (_ : Memtype.perm_kind) =>
                              if zle lo ofs && zlt ofs hi is true then Some Memtype.Freeable else None)
                           (mem_access m).
Proof.
  intros m m' lo hi nb' H.
  change alloc with (
fun (m : Memory.mem) (lo hi : Z) =>
({|
 mem_contents := Maps.PMap.set (nextblock m) (Maps.ZMap.init Memdata.Undef) (mem_contents m);
 mem_access := Maps.PMap.set (nextblock m)
                 (fun (ofs : Z) (_ : perm_kind) =>
                  if zle lo ofs && zlt ofs hi is true then Some Freeable else None)
                 (mem_access m);
 nextblock := Pos.succ (nextblock m);
 access_max := (fun (m0 : Memory.mem) (lo0 hi0 : Z) (b : positive) (ofs : Z) =>
                Memory.Mem.alloc_obligation_1 m0 lo0 hi0 b ofs) m lo hi;
 nextblock_noaccess := (fun (m0 : Memory.mem) (lo0 hi0 : Z) (b : positive)
                          (ofs : Z) (k : perm_kind) (H : ~ Plt b (Pos.succ (nextblock m0))) =>
                        Memory.Mem.alloc_obligation_2 m0 lo0 hi0 b ofs k H) m lo hi;
 contents_default := (fun (m0 : Memory.mem) (_ _ : Z) (b : positive) =>
                        Memory.Mem.alloc_obligation_3 m0 b) m lo hi |}, nextblock m)).
  simpl in *.
  destruct m'.
  simpl in *.
  inv H.
  auto.
Qed.


Set Implicit Arguments.

Require Import Platform.Cito.LayoutHintsUtil Platform.Cito.ADT.
Require Import Platform.Cito.RepInv Platform.Cito.WordMap.

Module Make (Import E : ADT) (Import M : RepInv E).

  Require Import Platform.Cito.Inv.
  Module Import InvMake := Inv.Make E.
  Module Import InvMake2 := InvMake.Make M.
  Import SemanticsMake.
  Require Import Platform.Cito.SemanticsFacts5.
  Require Import Platform.Cito.SemanticsUtil.

  Section TopSection.

    Definition heap_to_split h (_ : list (W * ArgIn)) := is_heap h.

    Lemma split_heap' : forall pairs h, good_inputs h pairs -> heap_to_split h pairs ===> let h1 := make_heap pairs in is_heap h1 * is_heap (heap_diff h h1).
      unfold heap_to_split; induction pairs; simpl; intros.

      unfold heap_diff, heap_empty.
      eapply Himp_trans; [ | apply Himp_star_Emp' ].
      unfold is_heap, heap_elements.
      apply starL_permute.

      apply NoDupA_NoDup.
      apply WordMap.elements_3w.

      apply NoDupA_NoDup.
      apply WordMap.elements_3w.

      intuition.
      apply In_InA' in H0.
      apply InA_In.
      apply WordMap.elements_1.
      apply WordMap.elements_2 in H0.
      Require Import Platform.Cito.WordMapFacts.
      apply diff_mapsto_iff.
      intuition.
      destruct H1.
      eapply WordMap.empty_1; eauto.
      apply In_InA' in H0.
      apply WordMap.elements_2 in H0.
      apply diff_mapsto_iff in H0.
      intuition.
      apply InA_In.
      apply WordMap.elements_1; auto.

      unfold is_heap, heap_elements.
      destruct H.
      inversion_clear H.
      hnf in H1.
      hnf in H0.
      case_eq (snd a); intros.
      rewrite H in *; subst.
      unfold make_heap; simpl.
      unfold store_pair at 2 4.
      unfold ArgIn, SemanticsMake.ArgIn.
      unfold WordMap.key in H.
      rewrite H.
      apply IHpairs.
      split; auto.
      hnf.
      simpl in H0.
      unfold ArgIn, SemanticsMake.ArgIn in H0.
      rewrite H in H0.
      auto.

      rewrite H in H1.
      generalize H1; intro Ho.
      apply WordMap.find_2 in Ho.
      apply WordMap.elements_1 in Ho.
      apply InA_In in Ho.
      eapply starL_out in Ho.
      destruct Ho; intuition.
      eapply Himp_trans; [ apply H4 | ].
      clear H4; simpl.
      2: apply NoDupA_NoDup; apply WordMap.elements_3w.
      assert (In (fst a, a0) (WordMap.elements (elt:=elt) (make_heap (a :: pairs)))).
      unfold make_heap; simpl.

      apply InA_In.
      apply elements_mapsto_iff.
      simpl in H0.
      unfold is_adt in H0.
      unfold WordMap.key, SemanticsMake.ArgIn in *.
      rewrite H in *; simpl in *.
      inversion_clear H0.
      apply preserve_store; auto.
      apply Forall_forall; intros.
      case_eq (snd x0); intuition idtac.
      unfold store_pair in H8.
      unfold WordMap.key, ArgIn, SemanticsMake.ArgIn in *.
      rewrite H in H8.
      unfold heap_upd in H8.
      eapply add_in_iff in H8; intuition idtac.
      2: destruct H9; eapply WordMap.empty_1; eauto.
      destruct a; simpl in *; subst.
      destruct x0; simpl in *; subst.

      eauto using keep_key.
      unfold store_pair.
      unfold WordMap.key, ArgIn, SemanticsMake.ArgIn in *.
      rewrite H.
      unfold heap_upd.
      apply WordMap.add_1; auto.

      simpl in *.
      destruct a; simpl in *; subst; simpl in *.
      rename w into k.
      inversion_clear H0.
      eapply Himp_trans; [ | apply Himp_star_frame; [ apply starL_permute | apply Himp_refl ] ].
      instantiate (1 := (k, a0) :: heap_elements (make_heap pairs)).
      Focus 2.
      constructor.
      intro.
      unfold heap_elements, make_heap in H0.
      apply In_InA' in H0.
      apply WordMap.elements_2 in H0.

      apply store_keys in H0; intuition idtac.
      apply H.
      change k with (fst (k, AxSpec.ADT a0)).
      apply in_map; apply filter_In; tauto.
      eapply WordMap.empty_1; eauto.
      apply NoDupA_NoDup; apply WordMap.elements_3w.
      2: apply NoDupA_NoDup; apply WordMap.elements_3w.
      Focus 2.
      simpl.
      split.
      destruct 1; subst.
      auto.
      unfold heap_elements in H0.

      apply InA_In.
      destruct x0.
      apply WordMap.elements_1.
      unfold make_heap; simpl.
      apply store_keys'; auto.
      apply In_InA' in H0.
      apply WordMap.elements_2 in H0.
      apply store_keys in H0; intuition idtac.
      exfalso; eapply WordMap.empty_1; eauto.

      intro.
      apply In_InA' in H0.
      destruct x0.
      apply WordMap.elements_2 in H0.
      unfold make_heap in H0; simpl in H0.
      apply store_keys in H0.
      intuition idtac.
      right.
      apply InA_In.
      apply WordMap.elements_1.
      apply store_keys'; auto.
      unfold store_pair in H7; simpl in H7.
      apply add_mapsto_iff in H7; intuition subst.
      auto.
      exfalso; eapply WordMap.empty_1; eauto.

      simpl.
      eapply Himp_trans; [ | apply Himp_star_assoc' ].
      apply Himp_star_frame; try apply Himp_refl.
      eapply Himp_trans; [ apply starL_permute | ].
      auto.
      instantiate (1 := WordMap.elements (WordMap.remove k h)).
      apply NoDupA_NoDup; apply WordMap.elements_3w.
      split; intro.
      apply InA_In.
      destruct x0.
      apply WordMap.elements_1.
      apply remove_mapsto_iff.
      apply H6 in H0.
      destruct H0; split; auto.
      2: apply WordMap.elements_2; apply In_InA'; auto.
      apply In_InA' in H7; apply WordMap.elements_2 in H7.
      apply WordMap.find_1 in H7.
      congruence.
      apply In_InA' in H0.
      destruct x0; apply WordMap.elements_2 in H0.
      apply remove_mapsto_iff in H0.
      apply H6; intuition (try congruence).
      apply InA_In; apply WordMap.elements_1; auto.

      eapply Himp_trans; [ apply IHpairs | ]; clear IHpairs.
      split; auto.
      apply Forall_forall; intros.
      eapply Forall_forall in H2; [ | apply H0 ].
      hnf in H2; hnf.
      destruct x0; simpl in *.
      rename w into k0.
      destruct v; auto.
      apply WordMap.find_1.
      apply remove_mapsto_iff.
      apply WordMap.find_2 in H2.
      intuition subst.
      apply H.
      change k0 with (fst (k0, AxSpec.ADT a)).
      apply in_map.
      apply filter_In; auto.

      apply Himp_star_frame; try apply Himp_refl.
      apply starL_permute; try (apply NoDupA_NoDup; apply WordMap.elements_3w); intros.
      intuition; apply InA_In; apply WordMap.elements_1;
        apply In_InA' in H0; apply WordMap.elements_2 in H0;
          apply diff_mapsto_iff; apply diff_mapsto_iff in H0; intuition idtac.
      apply remove_mapsto_iff in H7; tauto.
      apply remove_mapsto_iff in H7; intuition subst.
      destruct H0.
      eapply store_keys in H0; intuition idtac.
      simpl in *; intuition (try congruence).
      apply H8.
      eexists.
      eapply store_keys'; eauto.
      exfalso; eapply WordMap.empty_1; eauto.
      apply remove_mapsto_iff; intuition subst.
      apply H8.
      eexists; eapply store_keys'; eauto.
      simpl; eauto.
      auto.
      constructor; auto.
      apply H8.
      destruct H0.
      eapply store_keys in H0; intuition idtac.
      eexists.
      eapply store_keys'.
      simpl; eauto.
      constructor; auto.
      exfalso; eapply WordMap.empty_1; eauto.
    Qed.

    Lemma split_heap : forall h pairs, good_inputs h pairs -> heap_to_split h pairs ===> let h1 := make_heap pairs in is_heap h1 * is_heap (heap_diff h h1).
      eauto using split_heap'.
    Qed.

    Definition hints_split_heap : TacPackage.
      prepare split_heap tt.
    Defined.

  End TopSection.

End Make.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*              Tactics                                                *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

(** This file provide the tactic for refinement proof between layers*)

Require Import Coqlib.
Require Import Integers.

Definition Z64ofwords (i1 i2: Z) :=
  (Z.lor (Z.shiftl i1 32) i2).

Definition Z64_lo_int (i: Z) : int :=
  Int.repr i.

Definition Z64_hi_int (i: Z) : int :=
  Int.repr (Z.shiftr i 32).


Require Import FunctionalExtensionality.
Require Import Arith.
Require Import Omega.
Require Import List.
Require Import Pred.
Require Import Mem.
Require Import AsyncDisk.
Require Import DiskSet.
Require Import Array.
Require Import ListUtils.
Require Import LogReplay.
Require Import GenSepN.
Require Import ListPred.

Import ListNotations.

Definition syncedmem := @Mem.mem _ addr_eq_dec bool.

Definition sm_vs_valid (sm : @Mem.mem _ addr_eq_dec _) vs :=
  forall a, a < length vs -> sm a <> None /\ (sm a = Some true -> vs_synced a vs).

Definition sm_ds_valid (sm : @Mem.mem _ addr_eq_dec _) ds :=
  Forall (sm_vs_valid sm) (fst ds :: snd ds).

Lemma sm_ds_valid_pushd_iff: forall sm ds d,
  sm_ds_valid sm ds /\ sm_vs_valid sm d <-> sm_ds_valid sm (pushd d ds).
Proof.
  unfold pushd, sm_ds_valid, ds_synced.
  split; intuition; cbn in *.
  all: repeat apply Forall_cons.
  all: try solve [eapply Forall_inv; eauto | eapply Forall_cons2; eauto].
  repeat (eapply Forall_cons2; eauto).
  eapply Forall_inv.
  eapply Forall_cons2; eauto.
Qed.

Lemma sm_ds_valid_pushd: forall sm ds d,
  sm_vs_valid sm d ->
  sm_ds_valid sm ds -> sm_ds_valid sm (pushd d ds).
Proof.
  intros.
  apply sm_ds_valid_pushd_iff.
  auto.
Qed.

Lemma sm_ds_valid_pushd_r: forall sm ds d,
  sm_ds_valid sm (pushd d ds) ->
  sm_ds_valid sm ds.
Proof.
  intros.
  rewrite <- sm_ds_valid_pushd_iff in H.
  intuition.
Qed.

Lemma sm_ds_valid_pushd_l: forall sm ds d,
  sm_ds_valid sm (pushd d ds) ->
  sm_vs_valid sm d.
Proof.
  intros.
  rewrite <- sm_ds_valid_pushd_iff in H.
  intuition.
Qed.

Lemma vs_synced_updN_synced: forall a d i v,
  vs_synced a d ->
  vs_synced a (updN d i (v, nil)).
Proof.
  unfold vs_synced, vssync.
  intros.
  destruct (lt_dec i (length d)).
  destruct (addr_eq_dec i a); subst.
  rewrite selN_updN_eq; auto.
  rewrite selN_updN_ne; auto.
  rewrite updN_oob by omega; auto.
Qed.

Lemma sm_vs_valid_upd_unsynced: forall sm d a v,
  sm_vs_valid sm d ->
  sm_vs_valid (Mem.upd sm a false) (updN d a v).
Proof.
  unfold sm_vs_valid, Mem.upd, vsupd.
  intros.
  rewrite length_updN in *.
  intuition.
  destruct addr_eq_dec; subst.
  congruence.
  eapply H; eauto.
  destruct addr_eq_dec.
  congruence.
  unfold vs_synced.
  rewrite selN_updN_ne; auto.
  eapply H; eauto.
Qed.

Lemma sm_vs_valid_upd_synced: forall sm i d v,
  sm_vs_valid sm d ->
  sm_vs_valid (Mem.upd sm i true) (updN d i (v, nil)).
Proof.
  unfold sm_vs_valid, Mem.upd; cbn.
  intros.
  rewrite length_updN in *.
  intuition.
  destruct addr_eq_dec; subst.
  congruence.
  eapply H; eauto.
  destruct addr_eq_dec; subst.
  unfold vs_synced.
  rewrite selN_updN_eq; auto.
  apply vs_synced_updN_synced.
  eapply H; eauto.
Qed.

Lemma sm_vs_valid_same_upd_synced: forall sm i d v,
  sm_vs_valid sm d ->
  sm_vs_valid sm (updN d i (v, nil)).
Proof.
  unfold sm_vs_valid, Mem.upd; cbn.
  intros.
  rewrite length_updN in *.
  intuition.
  - eapply H; eauto.
  - destruct (addr_eq_dec a i); subst.
    + unfold vs_synced.
      rewrite selN_updN_eq; auto.
    + apply vs_synced_updN_synced.
      eapply H; eauto.
Qed.

Lemma sm_vs_valid_vssync': forall sm vs a,
  sm_vs_valid sm vs -> sm_vs_valid sm (vssync vs a).
Proof.
  unfold sm_vs_valid, vssync; intros.
  rewrite length_updN in *.
  intuition.
  eapply H; eauto.
  eapply H in H1; auto.
  eapply vs_synced_updN_synced.
  auto.
Qed.

Lemma sm_vs_valid_vs_synced: forall sm vs a,
  sm_vs_valid sm vs -> sm a = Some true ->
  vs_synced a vs.
Proof.
  unfold vs_synced, sm_vs_valid.
  intros.
  destruct (lt_dec a (length vs)) as [Hl|Hl].
  apply H in Hl; intuition.
  rewrite selN_oob by omega.
  auto.
Qed.

Lemma sm_ds_valid_dsupd: forall sm ds a v,
  a < length (ds!!) ->
  sm_ds_valid sm ds ->
  sm_ds_valid (Mem.upd sm a false) (dsupd ds a v).
Proof.
  unfold sm_ds_valid.
  intros.
  constructor.
  rewrite dsupd_fst.
  eapply sm_vs_valid_upd_unsynced.
  eapply Forall_inv; eauto.
  unfold dsupd; cbn.
  rewrite <- Forall_map.
  rewrite Forall_forall in *.
  intros.
  cbn in *.
  eapply sm_vs_valid_upd_unsynced; auto.
Qed.

Lemma sm_ds_valid_latest: forall sm ds,
  sm_ds_valid sm ds ->
  sm_vs_valid sm ds!!.
Proof.
  unfold latest, sm_ds_valid; cbn.
  intros.
  inversion H; subst.
  destruct (snd ds) eqn:?; cbn; eauto.
  eapply Forall_inv; eauto.
Qed.

Lemma sm_ds_valid_synced: forall sm d,
  sm_vs_valid sm d ->
  sm_ds_valid sm (d, nil).
Proof.
  unfold sm_ds_valid.
  cbn; intros.
  repeat (constructor; auto).
Qed.

Lemma sm_ds_valid_dssync: forall sm ds a,
  sm_ds_valid sm ds ->
  sm_ds_valid (Mem.upd sm a true) (dssync ds a).
Proof.
  unfold sm_ds_valid.
  intros.
  constructor.
  setoid_rewrite d_map_fst.
  unfold vssync.
  destruct (selN) eqn:?; cbn.
  apply sm_vs_valid_upd_synced.
  eapply Forall_inv; eauto.
  unfold dssync; cbn.
  rewrite <- Forall_map.
  inversion H; subst.
  rewrite Forall_forall in *.
  intros.
  eapply sm_vs_valid_upd_synced; auto.
Qed.

Lemma sm_ds_valid_dssync': forall sm ds a,
  sm_ds_valid sm ds -> sm_ds_valid sm (dssync ds a).
Proof.
  unfold sm_ds_valid; cbn; intros.
  inversion H; subst; constructor.
  eapply sm_vs_valid_vssync'; auto.
  rewrite <- Forall_map.
  rewrite Forall_forall in *.
  intros x; specialize (H x); intuition.
  eapply sm_vs_valid_vssync'; auto.
Qed.

Lemma sm_ds_valid_dssync_vecs': forall sm ds al,
  sm_ds_valid sm ds -> sm_ds_valid sm (dssync_vecs ds al).
Proof.
  induction al; cbn; intros.
  rewrite dssync_vecs_nop by constructor.
  auto.
  rewrite dssync_vecs_cons.
  rewrite dssync_vecs_dssync_comm.
  eapply sm_ds_valid_dssync'; auto.
Qed.

Lemma sm_ds_valid_ds_synced: forall sm ds a,
  sm_ds_valid sm ds -> sm a = Some true ->
  ds_synced a ds.
Proof.
  unfold ds_synced, sm_ds_valid.
  intros.
  rewrite Forall_forall in *.
  intros x; specialize (H x); intuition.
  eapply sm_vs_valid_vs_synced; eauto.
Qed.

Lemma sm_ds_valid_pushd_latest: forall sm ds,
  sm_ds_valid sm ds ->
  sm_ds_valid sm (pushd ds!! ds).
Proof.
  intros.
  auto using sm_ds_valid_pushd, sm_ds_valid_latest.
Qed.

Lemma sm_ds_valid_d_in: forall sm ds d,
  sm_ds_valid sm ds ->
  d_in d ds ->
  sm_vs_valid sm d.
Proof.
  unfold d_in, sm_ds_valid.
  intros.
  inversion H; clear H; rewrite Forall_forall in *; subst.
  intuition; subst.
  auto.
Qed.

Lemma sm_ds_valid_nthd: forall n sm ds,
  sm_ds_valid sm ds ->
  sm_vs_valid sm (nthd n ds).
Proof.
  intros.
  eapply sm_ds_valid_d_in; eauto.
  eapply nthd_in_ds.
Qed.

Lemma sm_vs_valid_all_synced: forall sm d d',
  sm_vs_valid sm d ->
  length d = length d' ->
  Forall (fun v => snd v = []) d' ->
  sm_vs_valid sm d'.
Proof.
  unfold sm_vs_valid.
  intros.
  rewrite Forall_forall in *.
  rewrite H0 in *.
  intuition.
  eapply H; eauto.
  unfold vs_synced.
  eauto using in_selN.
Qed.

Definition sm_disk_exact (d : diskstate) :=
  list2nmem (map (fun v => match (snd v) with [] => true | _ => false end) d).

Lemma sm_vs_valid_disk_exact: forall d,
  sm_vs_valid (sm_disk_exact d) d.
Proof.
  unfold sm_vs_valid, sm_disk_exact, list2nmem.
  intros.
  rewrite map_map.
  erewrite selN_map by auto.
  intuition.
  congruence.
  unfold vs_synced.
  inversion H0.
  destruct selN as [? l] eqn:H'.
  rewrite H' in *.
  destruct l; cbn in *; congruence.
Qed.

Definition sm_unsynced : syncedmem := fun _ => Some false.
Definition sm_synced : syncedmem := fun _ => Some true.
Definition sm_sync_all (sm : syncedmem) : syncedmem := fun a =>
  match sm a with
  | None => None
  | Some _ => Some true
  end.

Definition sm_sync_invariant (p : pred) : Prop := forall sm, p sm -> p (sm_sync_all sm).

Lemma sm_vs_valid_sm_unsynced: forall d,
  sm_vs_valid sm_unsynced d.
Proof.
  unfold sm_vs_valid; firstorder. discriminate.
  unfold sm_unsynced in *. congruence.
Qed.
Local Hint Resolve sm_vs_valid_sm_unsynced.

Lemma sm_ds_valid_sm_unsynced: forall ds,
  sm_ds_valid sm_unsynced ds.
Proof.
  unfold sm_ds_valid; intros.
  induction (fst ds :: snd ds); constructor; auto.
Qed.

Definition sm_set_vecs (b : bool) (sm : syncedmem) (a : list addr) :=
  fold_left (fun sm a => @Mem.upd _ _ addr_eq_dec sm a b) a sm.

Definition sm_upd_vecs sm (a : list (_ * valu)) := sm_set_vecs false sm (map fst a).
Definition sm_sync_vecs := sm_set_vecs true.

Lemma sm_set_vecs_cons: forall a sm x b,
  sm_set_vecs b sm (x :: a) = Mem.upd (sm_set_vecs b sm a) x b.
Proof.
  unfold sm_set_vecs.
  induction a; cbn; intros.
  auto.
  rewrite <- IHa.
  cbn.
  destruct (Nat.eq_dec a x).
  congruence.
  rewrite Mem.upd_comm; auto.
Qed.

Lemma sm_set_vecs_cons_inside: forall a sm x b,
  sm_set_vecs b sm (x :: a) = sm_set_vecs b (Mem.upd sm x b) a.
Proof.
  unfold sm_set_vecs.
  induction a; cbn; intros.
  auto.
  rewrite <- IHa.
  cbn.
  destruct (Nat.eq_dec a x).
  congruence.
  rewrite Mem.upd_comm; auto.
Qed.

Lemma sm_upd_vecs_cons: forall a sm x,
  sm_upd_vecs sm (x :: a) = Mem.upd (sm_upd_vecs sm a) (fst x) false.
Proof.
  eauto using sm_set_vecs_cons.
Qed.

Lemma sm_sync_vecs_cons: forall a sm x,
  sm_sync_vecs sm (x :: a) = Mem.upd (sm_sync_vecs sm a) x true.
Proof.
  eauto using sm_set_vecs_cons.
Qed.

Lemma sm_upd_vecs_cons_inside: forall a sm x,
  sm_upd_vecs sm (x :: a) = sm_upd_vecs (Mem.upd sm (fst x) false) a.
Proof.
  eauto using sm_set_vecs_cons_inside.
Qed.

Lemma sm_sync_vecs_cons_inside: forall a sm x,
  sm_sync_vecs sm (x :: a) = sm_sync_vecs (Mem.upd sm x true) a.
Proof.
  eauto using sm_set_vecs_cons_inside.
Qed.

Lemma sm_vs_valid_vsupd_vecs: forall a sm v,
  sm_vs_valid sm v ->
  sm_vs_valid (sm_upd_vecs sm a) (vsupd_vecs v a).
Proof.
  induction a; intros.
  auto.
  destruct a.
  rewrite vsupd_vecs_cons, sm_upd_vecs_cons_inside.
  cbn.
  eapply IHa.
  eapply sm_vs_valid_upd_unsynced.
  auto.
Qed.

Lemma sm_vs_valid_vssync_vecs: forall a sm v,
  sm_vs_valid sm v ->
  sm_vs_valid (sm_sync_vecs sm a) (vssync_vecs v a).
Proof.
  induction a; intros.
  auto.
  rewrite vssync_vecs_cons, sm_sync_vecs_cons_inside.
  eapply IHa.
  eapply sm_vs_valid_upd_synced.
  auto.
Qed.

Lemma sm_vs_valid_ds_valid: forall sm ds,
  Forall (sm_vs_valid sm) (fst ds :: snd ds) ->
  sm_ds_valid sm ds.
Proof.
  intros.
  unfold sm_ds_valid; auto.
Qed.

Lemma sm_ds_valid_dsupd_vecs: forall a sm ds,
  sm_ds_valid sm ds ->
  sm_ds_valid (sm_upd_vecs sm a) (dsupd_vecs ds a).
Proof.
  intros.
  apply sm_vs_valid_ds_valid.
  rewrite Forall_forall; intros.
  unfold dsupd_vecs, d_map in *.
  cbn in *.
  intuition subst.
  eapply sm_vs_valid_vsupd_vecs.
  inversion H; auto.
  rewrite in_map_iff in *.
  deex.
  eapply sm_vs_valid_vsupd_vecs.
  inversion H; subst.
  rewrite Forall_forall in *.
  auto.
Qed.

Lemma sm_ds_valid_dssync_vecs: forall a sm ds,
  sm_ds_valid sm ds ->
  sm_ds_valid (sm_sync_vecs sm a) (dssync_vecs ds a).
Proof.
  intros.
  apply sm_vs_valid_ds_valid.
  rewrite Forall_forall; intros.
  unfold dssync_vecs, d_map in *.
  cbn in *.
  intuition subst.
  eapply sm_vs_valid_vssync_vecs.
  inversion H; auto.
  rewrite in_map_iff in *.
  deex.
  eapply sm_vs_valid_vssync_vecs.
  inversion H; subst.
  rewrite Forall_forall in *.
  auto.
Qed.

Lemma sm_sync_all_mem_union: forall AEQ m1 m2,
  @mem_union _ AEQ _ (sm_sync_all m1) (sm_sync_all m2) = sm_sync_all (mem_union m1 m2).
Proof.
  unfold mem_union, sm_sync_all.
  intros.
  apply functional_extensionality.
  intros.
  destruct m1, m2; auto.
Qed.

Lemma sm_sync_all_mem_disjoint: forall m1 m2 AEQ,
  mem_disjoint m1 m2 -> @mem_disjoint _ AEQ _ (sm_sync_all m1) (sm_sync_all m2).
Proof.
  unfold mem_disjoint, sm_sync_all.
  intuition repeat deex.
  destruct m1 eqn:?, m2 eqn:?; try congruence.
  apply H; eauto.
Qed.

Lemma sm_sync_invariant_sep_star: forall (p q : pred),
  sm_sync_invariant p -> sm_sync_invariant q ->
  sm_sync_invariant (p * q).
Proof.
  unfold_sep_star.
  unfold sm_sync_invariant.
  intuition repeat deex.
  repeat eexists.
  rewrite sm_sync_all_mem_union; eauto.
  eauto using sm_sync_all_mem_disjoint.
  all: auto.
Qed.

Lemma sm_sync_all_sep_star_swap: forall AEQ (p p' q q' : @pred _ AEQ _) sm,
  (p * q)%pred sm ->
  (forall m, p m -> p' (sm_sync_all m)) ->
  (forall m, q m -> q' (sm_sync_all m)) ->
  (p' * q')%pred (sm_sync_all sm).
Proof.
  unfold_sep_star.
  intuition repeat deex.
  repeat eexists.
  rewrite sm_sync_all_mem_union.
  reflexivity.
  apply sm_sync_all_mem_disjoint; auto.
  all: auto.
Qed.

Lemma sm_sync_all_sep_star_swap_l: forall (p p' q : pred) sm,
  (p * q)%pred sm ->
  (forall m, p m -> p' (sm_sync_all m)) ->
  sm_sync_invariant q ->
  (p' * q)%pred (sm_sync_all sm).
Proof.
  eauto using sm_sync_all_sep_star_swap.
Qed.

Lemma sm_sync_all_sep_star_swap_r: forall (p q q' : pred) sm,
  (p * q)%pred sm ->
  (forall m, q m -> q' (sm_sync_all m)) ->
  sm_sync_invariant p ->
  (p * q')%pred (sm_sync_all sm).
Proof.
  eauto using sm_sync_all_sep_star_swap.
Qed.

Lemma sm_sync_invariant_lift_empty: forall P,
  sm_sync_invariant (lift_empty P).
Proof.
  unfold sm_sync_invariant, sm_sync_all, lift_empty.
  intuition.
  rewrite H1; auto.
Qed.

Lemma sm_sync_all_ptsto: forall AEQ a b (m : syncedmem),
  (@ptsto _ AEQ _ a b)%pred m ->
  (@ptsto _ AEQ _ a true)%pred (sm_sync_all m).
Proof.
  unfold ptsto, sm_sync_all.
  intuition.
  rewrite H0; auto.
  rewrite H1; auto.
Qed.

Lemma sm_sync_invariant_exis_ptsto: forall a,
  sm_sync_invariant (a |->?)%pred.
Proof.
  unfold sm_sync_invariant, sm_sync_all, ptsto.
  intros.
  destruct H as [x ?].
  intuition.
  exists true.
  destruct sm; try congruence.
  intuition.
  rewrite H1; auto.
Qed.

Lemma sm_sync_invariant_emp:
  sm_sync_invariant emp.
Proof.
  unfold sm_sync_invariant, sm_sync_all, emp.
  intuition.
  rewrite H.
  auto.
Qed.

Lemma sm_sync_invariant_listpred: forall T prd (l : list T),
  (forall x, In x l -> sm_sync_invariant (prd x)) ->
  sm_sync_invariant (listpred prd l).
Proof.
  induction l; cbn; intros.
  apply sm_sync_invariant_emp.
  apply sm_sync_invariant_sep_star; auto.
Qed.

Lemma sm_sync_all_listpred_swap: forall T AEQ (prd prd' : T -> @pred _ AEQ _) (l : list T) sm,
  (forall sm x, In x l -> prd x sm -> prd' x (sm_sync_all sm)) ->
  listpred prd l sm ->
  listpred prd' l (sm_sync_all sm).
Proof.
  induction l; cbn; intros.
  apply sm_sync_invariant_emp; auto.
  eapply sm_sync_all_sep_star_swap; eauto.
Qed.

Lemma sm_sync_all_arrayN_swap: forall T AEQ (prd prd' : nat -> T -> @pred _ AEQ _) d (l : list T) i sm,
  (forall sm  i' x, i' < length l -> selN l i' d = x -> prd (i + i') x sm -> prd' (i + i') x (sm_sync_all sm)) ->
  arrayN prd i l sm ->
  arrayN prd' i l (sm_sync_all sm).
Proof.
  induction l; cbn; intros.
  apply sm_sync_invariant_emp; auto.
  eapply sm_sync_all_sep_star_swap; eauto.
  intros.
  specialize (H m 0).
  rewrite Nat.add_0_r in *.
  apply H; auto.
  omega.
  intros.
  eapply IHl; auto.
  intros.
  rewrite plus_Snm_nSm in *.
  apply H; auto.
  omega.
Qed.

Lemma sm_sync_invariant_piff: forall (p q : pred),
  piff p q -> sm_sync_invariant p <-> sm_sync_invariant q.
Proof.
  unfold sm_sync_invariant.
  intros.
  intuition.
  all : do 3 match goal with H: _ |- _ => apply H end; auto.
Qed.

Hint Resolve sm_sync_invariant_sep_star.
Hint Resolve sm_sync_invariant_exis_ptsto.
Hint Resolve sm_sync_invariant_emp.
Hint Resolve sm_sync_invariant_lift_empty.
Hint Resolve sm_sync_invariant_listpred.

Hint Resolve sm_sync_all_ptsto.

Definition mem_except_mem {AT AEQ V} (m ex : @Mem.mem AT AEQ V) : @Mem.mem AT AEQ V := fun a =>
  match ex a with
  | Some _ => None
  | None => m a
  end.

Lemma mem_except_mem_disjoint: forall AT AEQ V (m ex : @Mem.mem AT AEQ V),
  mem_disjoint (mem_except_mem m ex) ex.
Proof.
  unfold mem_disjoint, mem_except_mem.
  intuition repeat deex.
  destruct ex; congruence.
Qed.

Lemma mem_except_mem_union: forall AT AEQ V (m ex : @Mem.mem AT AEQ V),
  mem_union (mem_except_mem m ex) ex = (mem_union ex m).
Proof.
  intros.
  unfold mem_union, mem_except_mem.
  eapply functional_extensionality.
  intros.
  destruct ex; auto.
  destruct m; auto.
Qed.

Lemma sm_sync_all_mem_union_sm_synced: forall m m1 m2,
  sm_sync_all m = mem_union m1 m2 ->
  mem_disjoint m1 m2 ->
  sm_synced = mem_union m2 sm_synced.
Proof.
  unfold sm_sync_all, mem_union, sm_synced.
  intros.
  eapply functional_extensionality.
  intros a.
  eapply equal_f in H.
  instantiate (1 := a) in H.
  destruct m eqn:?, m1 eqn:?; inversion H; subst.
  destruct m2 eqn:?; auto.
  match goal with Hm: mem_disjoint _ _ |- _ =>
    exfalso; apply Hm end.
  all: eauto.
Qed.

Lemma sm_synced_sep_star_l: forall AEQ (p q : @pred _ AEQ _) m,
  (p * q)%pred (sm_sync_all m) ->
  (any * q)%pred sm_synced.
Proof.
  unfold_sep_star.
  intuition repeat deex.
  repeat eexists.
  3: eassumption.
  2: apply mem_except_mem_disjoint.
  rewrite mem_except_mem_union.
  eapply sm_sync_all_mem_union_sm_synced; eauto.
Qed.

Lemma sm_synced_sep_star_r: forall AEQ (p q : @pred _ AEQ _) m,
  (p * q)%pred (sm_sync_all m) ->
  (p * any)%pred sm_synced.
Proof.
  intros.
  apply sep_star_comm.
  apply sep_star_comm in H.
  eauto using sm_synced_sep_star_l.
Qed.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  Substitutions

*)

Set Implicit Arguments.
Require Export Cyclone_Formal_Syntax Cyclone_Static_Semantics_Kinding_And_Context_Well_Formedness.
Require Export Cyclone_Static_Semantics_Typing_Heap_Objects.
Require Export Cyclone_Classes Cyclone_Inductions Cyclone_LN_Tactics Cyclone_LN_Extra_Lemmas_And_Automation.
Require Export Cyclone_Context_Weakening_Proof.
Require Export Cyclone_LN_Types_Lemmas.
Require Export Cyclone_Get_Lemmas.
Require Export Cyclone_Admit_Environment.
Close Scope list_scope.
Import LibEnvNotations.
Import LVPE.LibVarPathEnvNotations.

Lemma A_6_Subsititution_1:
  forall d d' t k,
      ok (d & d') ->
      K (d & d') t k ->
      forall alpha t' k',
        ok (d & alpha ~ k & d') ->
        K (d & alpha ~ k & d') t' k' ->
        K (d & d')  (T.subst t alpha t') k'.
Proof.
  introv okdd' Kd okdakd' Kdakd'.
  gen_eq G: (d & alpha ~ k & d'). gen d'.
  induction Kdakd'; intros; subst; auto.
  simpl.
  case_var.
  apply get_middle_eq_inv in H; subst; auto.
  apply get_subst in H; subst; auto.

  simpl.
  case_var.
  apply K_ptype.
  (* yes k is A! *)
  admit.
  apply K_star_A.
  admit.

  simpl.
  apply_fresh K_utype.
  intros.
  assert(NI: y \notin L). admit.
  assert(OKB: ok (d & alpha ~ k & d' & y ~ k0)). admit.
  specialize (H y NI OKB).
  specialize (H0 y NI OKB OKB (d' & y ~ k0)).
(*
  rewrite <- ok_commutes in H0.
  rewrite <- K_context_commutes in H0.
  rewrite <- K_context_commutes in H0.
  assert(KW: K (d & d' & y ~ k0) t k). admit. (* k weakening *)
  assert(CC: d & alpha ~ k & d' & y ~ k0 = d & alpha ~ k & (d' & y ~ k0)). admit.
  (* contexts commute, meta theorem I must accept. *)
  specialize (H0 H1 KW CC).
  rewrite* <- TP.subst_open_var.

  apply K__lc with (d:= (d&d')) (k:=k); auto.
  admit.

  apply K_B_A.
  apply* IHKdakd'.
*)
Admitted.

Lemma A_6_Subsititution_2:
  forall d d' t k,
      ok (d & d') ->
      AK (d & d') t k ->
      forall alpha t' k',
        ok (d & alpha ~ k & d') ->
        AK (d & alpha ~ k & d') t' k' ->
        AK (d & d') (T.subst t alpha t') k'.
Proof.
  introv okdd' AKd okdakd' AKdakd'.
  inversions* AKdakd'.
  inversions* AKd.
  constructor.
  apply A_6_Subsititution_1 with (k:=k); auto.
  constructor.
  apply A_6_Subsititution_1 with (k:=A); auto.
  (* bug ? A/B *)
  admit.
  simpl.
  case_var*.
  apply get_middle_eq_inv in H; subst*.
  apply AK_A.
  admit. (* get strengthening. *)
Admitted.

Lemma A_6_Subsititution_3:
  forall d d' t,
      ok (d & d') ->
      ASGN (d & d') t ->
      forall alpha t' k,
        ok (d & alpha ~ k & d') ->
        ASGN (d & alpha ~ k & d') t' ->
        ASGN (d & d') (T.subst t alpha t').
Proof.
  introv okdd' ASGNdd' OKdakd' ASGNdakd'.
  gen_eq G: (d & alpha ~ k & d'). gen d'.
  induction ASGNdakd'; intros; subst; auto; simpl; try solve[constructor; auto];
    try solve[case_var*;
              apply ASGN_B;
              apply get_subst in H; subst; auto].

  apply_fresh ASGN_utype.
  assert(NI: y \notin L). auto.
  specialize (H y NI).
  assert(OKB: ok (d & alpha ~ k & d' & y ~ k0)). admit.
  assert(OKL : ok (d & d' & y ~ k0)); auto.
  specialize (H0 y NI OKB (d' & y ~ k0)).
(*
  rewrite <- ok_commutes in H0.
  assert(ASGNB: ASGN (d & (d' & y ~ k0)) t). admit. (* asgn commutes, commits *)
  assert(H1: d & alpha ~ k & d' & y ~ k0 = d & alpha ~ k & (d' & y ~ k0)). admit.
  specialize (H0 OKL ASGNB H1).
  rewrite <- TP.subst_open_var.
*)
Admitted.