Require Import Lia.
From hahn Require Import Hahn.
From PromisingLib Require Import Basic Language.
From imm Require Import
     AuxDef
     Events Execution
     Traversal TraversalConfig SimTraversal SimTraversalProperties
     Prog ProgToExecution ProgToExecutionProperties Receptiveness
     imm_common imm_s imm_s_hb SimState PromiseLTS
     CertExecution2
     SubExecution CombRelations.
Require Import AuxRel.
Require Import AuxDef.
Require Import LblStep.
Require Import CertRf.
Require Import ImmProperties.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Classical_Prop.

Set Implicit Arguments.
Local Open Scope program_scope.

Section CertGraph.
  Variable prog : Prog.t.
  Variable G  : execution.
  Variable GPROG : program_execution prog G.
  Variable sc : relation actid.
  Variable TC : trav_config.
  Variable TC': trav_config.
  Variable thread : thread_id.
  Variable state : state.

  Notation "'certG'" := state.(ProgToExecution.G).

  Notation "'certE'" := certG.(acts_set).

  Definition certLab : actid -> label :=
    restr_fun certE certG.(lab) G.(lab).

  Notation "'certRmw'" := (certG.(rmw)).

  Notation "'cert_rf'" := (cert_rf G sc TC').

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

  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 G.(lab) a)).
  Notation "'W'" := (fun a => is_true (is_w G.(lab) a)).
  Notation "'F'" := (fun a => is_true (is_f G.(lab) a)).

  Notation "'Rel'" := (fun a => is_true (is_rel G.(lab) a)).

  Notation "'R_ex'" := (fun a => R_ex G.(lab) a).

  Notation "'sb'" := (G.(sb)).
  Notation "'rmw'" := G.(rmw).
  Notation "'addr'" := G.(addr).
  Notation "'data'" := G.(data).
  Notation "'ctrl'" := G.(ctrl).
  Notation "'rmw_dep'" := G.(rmw_dep).
  Notation "'rf'" := (G.(rf)).
  Notation "'co'" := (G.(co)).

  Notation "'ppo'" := (G.(ppo)).
  Notation "'hb'" := (G.(imm_s_hb.hb)).
  Notation "'vf'" := (furr G sc).

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

  Notation "'E0'" := (Tid_ thread ∩₁ CsbI G TC').

  Definition cert_dom st :=
    (C ∪₁ (dom_rel (sb^? ⨾ ⦗ I ⦘) ∩₁ NTid thread) ∪₁ acts_set st.(ProgToExecution.G)).

  Lemma cert_dom_alt st
    (STCOV : C ∩₁ Tid thread ⊆₁ acts_set st.(ProgToExecution.G)) :
      cert_dom st ≡₁
               (C ∪₁ dom_rel (sb^? ⨾ ⦗ I ⦘)) ∩₁ NTid thread ∪₁
               acts_set st.(ProgToExecution.G).
  Proof.
    unfold cert_dom.
    split; [|basic_solver 10].
    arewrite (C ≡₁ C ∩₁ Tid thread ∪₁ C ∩₁ NTid thread) at 1.
    { rewrite <- set_inter_union_r.
      rewrite tid_set_dec.
      basic_solver. }
    rewrite STCOV. basic_solver 10.
  Qed.

  Record cert_graph :=
    { cslab : eq_dom (D G TC') certLab G.(lab);
      cuplab_cert : same_lab_u2v_dom certE certG.(lab) G.(lab);

      dcertE : certE ≡₁ E0;
      dcertRMW : certRmw ≡ ⦗ certE ⦘ ⨾ rmw;

      cert_rfv_clab : cert_rf ⨾ ⦗ Tid_ thread ⦘ ⊆ same_val certLab;
    }.

  Section CertGraphProperties.
    Variable WF : Wf G.
    Variable Wf_sc : wf_sc G sc.
    Variable IMMC : imm_consistent G sc.
    Variable TCCOH : tc_coherent G sc TC.
    Variable TSTEP : isim_trav_step G sc thread TC TC'.

    Lemma isim_trav_step_coherence : tc_coherent G sc TC'.
    Proof. eapply sim_trav_step_coherence; eauto. red. eauto. Qed.

    Hint Resolve isim_trav_step_coherence.

    Lemma trstep_thread_prog : IdentMap.In thread prog.
    Proof.
      apply sim_trav_step_to_step in TSTEP.
      destruct TSTEP as [e [T'' ITSTEP]]. desf.
      assert (E e) as EE.
      { cdes ITSTEP. desf.
        { apply COV. }
        apply ISS. }
      set (BB := EE).
      apply GPROG in BB.
      desf. exfalso.
      cdes ITSTEP. desf.
      { apply NEXT. by eapply init_covered; eauto. }
      apply NISS. by eapply init_issued; eauto.
    Qed.

    (******************************************************************************)
    (** ** E0 propeties *)
    (******************************************************************************)

    Lemma E0_in_thread_execE st
          (TEH : thread_restricted_execution G thread st.(ProgToExecution.G)) :
      E0 ⊆₁ acts_set st.(ProgToExecution.G).
    Proof.
      rewrite tr_acts_set; eauto.
      rewrite set_interC.
      rewrite CsbI_in_E; eauto.
    Qed.

    Lemma E0_sb_prcl :
      dom_rel (⦗Tid_ thread ⦘ ⨾ sb ⨾ ⦗E0⦘) ⊆₁ E0.
    Proof.
      rewrite seq_eqv_lr.
      intros x [y [TIDx [SB E0y]]].
      split; auto.
      eapply CsbI_sb_prcl; eauto.
      exists y.
      apply seq_eqv_r.
      split; auto.
      apply E0y.
    Qed.

    Lemma E0_rmw_fwcl
          (RMWCLOS : forall r w (RMW : rmw r w), C' r <-> C' w)
          (IRELCOV : W ∩₁ Rel ∩₁ I' ⊆₁ C') :
      ⦗E0⦘ ⨾ rmw ≡ ⦗E0⦘ ⨾ rmw ⨾ ⦗E0⦘.
    Proof.
      split; [|basic_solver].
      rewrite seq_eqv_l, seq_eqv_lr.
      unfolder. ins. desc.
      splits; auto.
      { subst thread. symmetry.
        by apply WF.(wf_rmwt). }
      assert ((⦗CsbI G TC'⦘ ⨾ rmw) x y) as HH.
      { basic_solver. }
      eapply CsbI_rmw_fwcl in HH; eauto.
      by destruct_seq HH as [AA BB].
    Qed.

    Lemma E0_eindex_weak e (CTE : E0 e) (NINITT : thread <> tid_init) :
      exists index : nat,
        ⟪ EREP : e = ThreadEvent thread index ⟫.
    Proof.
      ins. destruct CTE as [AA BB].
      destruct e; simpls; rewrite <- AA in *; desf.
      eauto.
    Qed.

    Lemma E0_eindex st
          (NINITT : thread <> tid_init)
          (GPC : wf_thread_state thread st)
          (TEH : thread_restricted_execution G thread st.(ProgToExecution.G)) :
      exists ctindex,
        ⟪ CCLOS :forall index (LT : index < ctindex),
            E0 (ThreadEvent thread index) ⟫ /\
        ⟪ CREP : forall e (CTE : E0 e),
            exists index : nat,
              ⟪ EREP : e = ThreadEvent thread index ⟫ /\
              ⟪ ILT : index < ctindex ⟫ ⟫.
    Proof.
      assert (E0 ⊆₁ E) as E0_in_E.
      { rewrite CsbI_in_E; eauto. basic_solver. }
      destruct (classic (exists e, E0 e)) as [|NCT].
      2: { exists 0. splits.
           { ins. inv LT. }
           ins. exfalso. apply NCT. eauto. }
      desc.
      assert (acyclic (sb ⨾ ⦗ E0 ⦘)) as AC.
      { arewrite (sb ⨾ ⦗E0⦘ ⊆ sb). apply sb_acyclic. }
      set (doml := filterP E0 G.(acts)).
      assert (forall c, (sb ⨾ ⦗E0⦘)＊ e c -> In c doml) as UU.
      { intros c SCC. apply rtE in SCC. destruct SCC as [SCC|SCC].
        { red in SCC. desf. apply in_filterP_iff.
          split; auto. eapply E0_in_E. eauto. }
        apply inclusion_ct_seq_eqv_r in SCC. apply seq_eqv_r in SCC.
        apply in_filterP_iff. split; auto; [apply E0_in_E|]; desf. }
      edestruct (last_exists doml AC UU) as [max [MM1 MM2]].
      assert (E0 max) as CTMAX.
      { apply rtE in MM1. destruct MM1 as [MM1|MM1].
        { red in MM1. desf. }
        apply inclusion_ct_seq_eqv_r in MM1. apply seq_eqv_r in MM1. desf. }
      assert (Tid thread max) as CTTID by apply CTMAX.
      destruct max as [l|mthread mindex].
      { simpls. rewrite <- CTTID in *. desf. }
      simpls. rewrite CTTID in *.
      assert (acts_set G (ThreadEvent thread mindex)) as EEM.
      { by apply E0_in_E. }
      exists (1 + mindex). splits.
      { ins. destruct CTMAX as [_ CTMAX].
        split; [by ins|].
        apply le_lt_or_eq in LT. destruct LT as [LT|LT].
        2: { inv LT. }
        assert (acts_set (st.(ProgToExecution.G)) (ThreadEvent thread mindex)) as PP.
        { apply TEH.(tr_acts_set). by split. }
        assert (E (ThreadEvent thread index)) as EEE.
        { apply TEH.(tr_acts_set). eapply acts_rep in PP; eauto. desc.
          eapply GPC.(acts_clos). inv REP. lia. }
        assert (sb (ThreadEvent thread index) (ThreadEvent thread mindex)) as QQQ.
        { red.
          apply seq_eqv_l. split; auto.
          apply seq_eqv_r. split; auto.
          red. split; auto. lia. }
        destruct CTMAX as [AA|[z AA]]; [left|right].
        { apply isim_trav_step_coherence in AA. apply AA. eexists.
          apply seq_eqv_r. split; eauto. }
        exists z. apply seq_eqv_r in AA. destruct AA as [AA1 AA2].
        apply seq_eqv_r. split; auto.
        apply rewrite_trans_seq_cr_cr.
        { apply sb_trans. }
        eexists; split; [|by eauto].
          by apply r_step. }
      ins. set (CTE' := CTE).
      apply E0_eindex_weak in CTE'; auto; desc.
      eexists. splits; eauto.
      destruct (le_gt_dec index mindex) as [LL|LL].
      { by apply le_lt_n_Sm. }
      exfalso.
      eapply MM2. apply seq_eqv_r. split; [|by apply CTE].
      red.
      apply seq_eqv_l. split; auto.
      apply seq_eqv_r. split; auto.
      red. rewrite EREP.
      split; auto.
    Qed.

    (******************************************************************************)
    (** ** certLab propeties *)
    (******************************************************************************)

    Lemma cuplab (SCG : cert_graph) :
      same_lab_u2v certLab G.(lab).
    Proof.
      red. red. ins.
      unfold certLab.
      unfold restr_fun.
      desf.
      { by apply SCG. }
      red. desf.
    Qed.

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

    Lemma cert_rfl_clab (CERTG : cert_graph) :
      cert_rf ⊆ same_loc certLab.
    Proof.
      erewrite same_lab_u2v_same_loc.
      { eapply cert_rfl. }
      apply cuplab; auto.
    Qed.

    Lemma cert_rf_ntid_old_iss_sb
          (SCG : cert_graph)
          (NINITT : thread <> tid_init)
          (IRELCOV : W ∩₁ Rel ∩₁ I ⊆₁ C) :
      cert_rf ⨾ ⦗ Tid_ thread ⦘ ⊆
        ⦗ NTid thread ∩₁ I ⦘ ⨾ cert_rf ∪ sb ∩ same_tid.
    Proof.
      assert (IRELCOV' : W ∩₁ Rel ∩₁ I' ⊆₁ C').
      { eapply sim_trav_step_rel_covered; eauto; red; eauto. }
      erewrite cert_rf_ntid_iss_sb; eauto.
      rewrite isim_trav_step_new_issued_tid; eauto.
      basic_solver.
    Qed.

    Lemma cert_rf_cert_dom st
          (SCG : cert_graph)
          (NINITT : thread <> tid_init)
          (IRELCOV : W ∩₁ Rel ∩₁ I ⊆₁ C)
          (WFST : wf_thread_state thread st) :
      dom_rel (cert_rf ⨾ ⦗ eq (ThreadEvent thread st.(eindex)) ⦘) ⊆₁ cert_dom st.
    Proof.
      unfold cert_dom.
      rewrite <- seq_eqvK.
      arewrite
        (eq (ThreadEvent thread (eindex st)) ⊆₁ Tid_ thread)
        at 1.
      { basic_solver. }
      rewrite <- seq_eqvK
        with (dom := Tid thread).
      do 2 rewrite <- seqA.
      erewrite cert_rf_ntid_old_iss_sb; eauto.
      rewrite !seq_union_l, dom_union.
      apply set_subset_union_l. split.
      { basic_solver 10. }

      arewrite (sb ∩ same_tid ⨾ ⦗Tid thread⦘ ≡ ⦗Tid thread⦘ ⨾ sb).
      { unfolder; splits; ins; splits; desf; auto.
        { unfold same_tid.
          edestruct sb_tid_init as [STID | INITx]; eauto.
          exfalso. apply NINITT.
            by apply is_init_tid in INITx. }
        edestruct sb_tid_init as [STID | INITx]; eauto.
        exfalso. apply NINITT.
          by apply is_init_tid in INITx. }
      intros x [y HH]. right.
      apply seq_eqv_lr in HH.
      destruct HH as [TIDx [SB EQy]].
      destruct x; [intuition|].
      unfold tid in TIDx. subst.
      apply acts_clos; auto.
      unfold Execution.sb, ext_sb in SB.
      apply seq_eqv_lr in SB; desf.
    Qed.

    (******************************************************************************)
    (** ** deps propeties *)
    (******************************************************************************)

    Lemma dom_addrE_in_D : dom_rel (addr ⨾ ⦗ E0 ⦘) ⊆₁ D G TC'.
    Proof.
      unfold CsbI.
      rewrite set_inter_union_r.
      rewrite id_union; relsf; unionL; splits.
      { rewrite (addr_in_sb WF).
        generalize (dom_sb_covered isim_trav_step_coherence).
        unfold D; basic_solver 21. }
      arewrite (Tid thread ∩₁ dom_rel (sb^? ⨾ ⦗I'⦘) ⊆₁
                      dom_rel (sb^? ⨾ ⦗I'⦘)) by basic_solver.
      rewrite dom_rel_eqv_dom_rel.
      arewrite (⦗I'⦘ ⊆ ⦗W⦘ ⨾ ⦗I'⦘).
      { generalize (issuedW isim_trav_step_coherence); basic_solver. }
      rewrite (dom_l (wf_addrD WF)), !seqA.
      arewrite (⦗R⦘ ⨾ addr ⨾ sb^? ⨾ ⦗W⦘ ⊆ ppo).
      { unfold imm_common.ppo; rewrite <- ct_step; basic_solver 12. }
      unfold D; basic_solver 21.
    Qed.

    Lemma dom_ctrlE_in_D : dom_rel (ctrl ⨾ ⦗ E0 ⦘) ⊆₁ D G TC'.
    Proof.
      unfold CsbI.
      rewrite set_inter_union_r.
      rewrite id_union; relsf; unionL; splits.
      { rewrite (ctrl_in_sb WF).
        generalize (dom_sb_covered isim_trav_step_coherence).
        unfold D; basic_solver 21. }
      arewrite (Tid thread ∩₁ dom_rel (sb^? ⨾ ⦗I'⦘) ⊆₁
                      dom_rel (sb^? ⨾ ⦗I'⦘)) by basic_solver.
      rewrite dom_rel_eqv_dom_rel.
      arewrite (ctrl ⨾ sb^? ⊆ ctrl).
      { generalize (ctrl_sb WF); basic_solver 21. }
      arewrite (⦗I'⦘ ⊆ ⦗W⦘ ⨾ ⦗I'⦘).
      { generalize (issuedW isim_trav_step_coherence); basic_solver. }
      rewrite (wf_ctrlD WF), !seqA.
      arewrite (⦗R⦘ ⨾ ctrl ⨾ ⦗W⦘ ⊆ ppo).
      { unfold imm_common.ppo; rewrite <- ct_step; basic_solver 12. }
      unfold D; basic_solver 21.
    Qed.

    Lemma dom_rmw_depE_in_D : dom_rel (rmw_dep ⨾ ⦗ E0 ⦘) ⊆₁ D G TC'.
    Proof.
      unfold CsbI.
      rewrite set_inter_union_r.
      rewrite id_union; relsf; unionL; splits.
      { rewrite (rmw_dep_in_sb WF).
        generalize (dom_sb_covered isim_trav_step_coherence).
        unfold D; basic_solver 21. }
      arewrite (Tid thread ∩₁ dom_rel (sb^? ⨾ ⦗I'⦘) ⊆₁
                      dom_rel (sb^? ⨾ ⦗I'⦘)) by basic_solver.
      rewrite dom_rel_eqv_dom_rel.
      rewrite (wf_rmw_depD WF), !seqA.
      arewrite (⦗I'⦘ ⊆ ⦗W⦘ ⨾ ⦗I'⦘).
      { generalize (issuedW isim_trav_step_coherence); basic_solver. }
      arewrite (⦗R⦘ ⨾ rmw_dep ⨾ ⦗R_ex⦘ ⨾ sb^? ⨾ ⦗W⦘ ⊆ ppo).
      2: unfold D; basic_solver 21.
      unfold imm_common.ppo; hahn_frame.
      case_refl _.
      { by rewrite <- ct_step; basic_solver 12. }
      rewrite ct_begin; rewrite <- inclusion_t_rt, <- ct_step; basic_solver 12.
    Qed.

    Lemma dom_rmwE_in_D : dom_rel (rmw ⨾ ⦗ E0 ⦘) ⊆₁ D G TC'.
    Proof.
      unfold CsbI.
      rewrite set_inter_union_r.
      rewrite id_union; relsf; unionL; splits.
      { rewrite (rmw_in_sb WF).
        generalize (dom_sb_covered isim_trav_step_coherence).
        unfold D; basic_solver 21. }
      arewrite (Tid thread ∩₁ dom_rel (sb^? ⨾ ⦗I'⦘) ⊆₁
                      dom_rel (sb^? ⨾ ⦗I'⦘)) by basic_solver.
      rewrite dom_rel_eqv_dom_rel.
      arewrite (⦗I'⦘ ⊆ ⦗W⦘ ⨾ ⦗I'⦘).
      { generalize (issuedW isim_trav_step_coherence); basic_solver. }
      generalize (rmw_in_ppo WF) (rmw_sb_W_in_ppo WF).
      unfold D; basic_solver 21.
    Qed.

    Lemma dom_dataD_in_D : dom_rel (data ⨾ ⦗D G TC'⦘) ⊆₁ D G TC'.
    Proof.
      unfold CsbI.
      unfold D.
      rewrite !id_union; relsf; unionL; splits.
      { rewrite (data_in_sb WF).
        generalize dom_sb_covered. basic_solver 21. }
      { rewrite (data_in_ppo WF).
        basic_solver 12. }
      { rewrite dom_rel_eqv_dom_rel.
        rewrite crE at 1; relsf; unionL; splits.
        { rewrite (dom_r (wf_dataD WF)), (dom_l (@wf_ppoD G)). type_solver. }
        rewrite (data_in_ppo WF).
        sin_rewrite ppo_rfi_ppo. basic_solver 21. }
      { rewrite (dom_r (wf_dataD WF)), (dom_r (wf_rfiD WF)). type_solver. }
      rewrite (dom_r (wf_dataD WF)), (dom_r (wf_rfeD WF)). type_solver.
    Qed.

  End CertGraphProperties.
End CertGraph.

Section CertGraphLemmas.

Variable prog : Prog.t.
Variable G  : execution.
Variable GPROG : program_execution prog G.
Variable sc : relation actid.
Variable TC : trav_config.
Variable TC': trav_config.
Variable thread : thread_id.

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

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

Notation "'Rel'" := (fun a => is_true (is_rel G.(lab) a)).

Notation "'R_ex'" := (fun a => R_ex G.(lab) a).

Notation "'sb'" := (G.(sb)).
Notation "'rmw'" := G.(rmw).
Notation "'addr'" := G.(addr).
Notation "'data'" := G.(data).
Notation "'ctrl'" := G.(ctrl).
Notation "'rmw_dep'" := G.(rmw_dep).
Notation "'rf'" := (G.(rf)).
Notation "'co'" := (G.(co)).

Notation "'ppo'" := (G.(ppo)).
Notation "'hb'" := (G.(imm_s_hb.hb)).
Notation "'vf'" := (furr G sc).

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

Notation "'E0'" := (Tid_ thread ∩₁ CsbI G TC').
(* Notation "'D'" := (D G TC' thread). *)

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

Variable WF : Wf G.
Variable Wf_sc : wf_sc G sc.
Variable IMMC : imm_consistent G sc.
Variable TCCOH : tc_coherent G sc TC.
Variable TSTEP : isim_trav_step G sc thread TC TC'.

Hint Resolve isim_trav_step_coherence.

(******************************************************************************)
(** ** cert_graph start lemma *)
(******************************************************************************)

Lemma cert_graph_start
      (state : Language.state (PromiseLTS.thread_lts thread))
      (NINITT : thread <> tid_init)
      (GPC : wf_thread_state thread state)
      (PROGST : stable_lprog (instrs state))
      (REACHABLE : (step thread)＊ (init (instrs state)) state)
      (SSTATE : sim_state G sim_normal C state)
      (STATECOV : acts_set state.(ProgToExecution.G) ⊆₁ C)
      (RMWCLOS : forall r w (RMW : rmw r w), C r <-> C w)
      (IRELCOV : W ∩₁ Rel ∩₁ I ⊆₁ C) :
  exists state',
    ⟪ CERTG : cert_graph G sc TC' thread state' ⟫ /\
    ⟪ CST_STABLE : stable_state state' ⟫ /\
    ⟪ CST_REACHABLE : (step thread)＊ state state' ⟫.
Proof.
    cdes SSTATE. cdes SSTATE1.

    assert (wf_thread_state thread state') as GPC'.
    { eapply wf_thread_state_steps; eauto. }

    assert (forall r w, rmw r w -> covered TC' r <-> covered TC' w) as RMWCOV.
    { eapply sim_trav_step_rmw_covered; eauto.
      red. eauto. }

    edestruct E0_eindex; eauto; desf.
    edestruct steps_middle_set with
      (thread := thread)
      (state0 := state) (state':=state') as [state''].
    3: { eapply E0_in_thread_execE; eauto. }
    all: eauto.
    { apply set_subset_inter_r. split.
      { etransitivity.
        { eapply steps_preserve_E; eauto. }
        etransitivity.
        { eapply TEH.(tr_acts_set). }
        basic_solver. }
      unionR left.
      etransitivity; eauto.
      eapply sim_trav_step_covered_le. red. eauto. }
    { ins.
      eapply rmw_in_thread_restricted_rmw in RMW; eauto.
      split; intros [TT XX]; split.
      1,3: by apply WF.(wf_rmwt) in RMW; rewrite <- TT; red in RMW; desf.
      all: destruct XX as [XX|XX]; [by left; eapply RMWCOV with (r:=r); eauto|right].
      all: destruct XX as [e XX].
      all: apply seq_eqv_r in XX; destruct XX as [SB II].
      all: exists e; apply seq_eqv_r; split; auto.
      2: { apply (wf_rmwi WF) in RMW.
           generalize SB RMW (@sb_trans G). basic_solver. }
      assert (R r) as RR.
      { apply WF.(wf_rmwD) in RMW. destruct_seq RMW as [AAA BBB].
        type_solver. }
      apply (wf_rmwi WF) in RMW.
      destruct SB as [|SB]; subst.
      { eapply issuedW in II; eauto. type_solver. }
      destruct (classic (w = e)) as [|NEQ]; [by left|].
      assert (~ is_init r) as NINIT.
      { intros GG. eapply WF.(init_w) in GG.
        type_solver. }
      edestruct sb_semi_total_l with (y:=w) (z:=e); eauto.
      { apply RMW. }
      exfalso. eapply RMW; eauto. }
    desf.

    assert (wf_thread_state thread state'') as GPC''.
    { eapply wf_thread_state_steps. apply GPC. auto. }

    set (new_rf := cert_rf G sc TC' ⨾ ⦗ E0 \₁ D G TC' ⦘).
    set (new_rfi := ⦗ Tid thread ⦘ ⨾ new_rf ⨾ ⦗ Tid thread ⦘).
    set (new_rfe := ⦗ NTid thread ⦘ ⨾ new_rf ⨾ ⦗ Tid thread ⦘).
    set (new_rfe_ex := new_rfe ∪ ⦗ set_compl (codom_rel new_rfe) ⦘).

    assert (new_rfi ⊆ ⦗ Tid_ thread ⦘ ⨾ cert_rf G sc TC' ⨾ ⦗ Tid_ thread ⦘)
      as NEWRFI_IN_CERT.
    { unfold new_rfi, new_rf. basic_solver. }

    assert (new_rff : functional new_rf⁻¹).
    { arewrite (new_rf ⊆ cert_rf G sc TC').
      apply cert_rff; auto. }
    assert (new_rfif : functional new_rfi⁻¹).
    { arewrite (new_rfi ⊆ new_rf); auto.
      unfold new_rfi; basic_solver. }
    assert (new_rfef : functional new_rfe⁻¹).
    { arewrite (new_rfe ⊆ new_rf); auto.
      unfold new_rfe; basic_solver. }

    assert (tc_coherent G sc TC') as TCCOH'.
    { eapply isim_trav_step_coherence; [ eapply TCCOH | apply TSTEP]. }
    assert (W ∩₁ Rel ∩₁ I' ⊆₁ C') as RELCOV'.
    { eapply sim_trav_step_rel_covered; eauto. red. eauto. }

    assert (new_rfi ≡ ⦗ E0 ⦘ ⨾ new_rfi ⨾ ⦗ E0 ⦘) as NEW_RFIE.
    { split; [|basic_solver].
      etransitivity.
      2: apply doma_helper.
      { unfold new_rfi, new_rf. basic_solver 10. }
      arewrite (new_rfi ⊆ ⦗Tid thread⦘ ⨾ sb).
      { etransitivity.
        { apply NEWRFI_IN_CERT. }
        rewrite <- seq_eqvK at 1.
        rewrite !seqA.
        by rewrite cert_rf_tid_in_sb; auto. }
      unfold doma. ins.
      eapply E0_sb_prcl; [|eauto|]; eauto.
      basic_solver. }

    assert (forall r, exists ! w, new_rfe_ex⁻¹ r w) as new_rfe_unique.
    { ins.
      destruct (classic ((codom_rel new_rfe) r)) as [X|X].
      { unfolder in X.
        destruct X as [w RFE].
        exists w; red; splits.
        unfold new_rfe_ex; basic_solver 12.
        unfold new_rfe_ex; unfolder; ins; desf.
        eapply new_rfef; basic_solver.
        exfalso; eauto. }
      exists r; red; splits.
      unfold new_rfe_ex; basic_solver 12.
      unfold new_rfe_ex; unfolder; ins; desf.
      unfolder in X; exfalso; eauto. }

    assert (exists new_value, forall x, (new_rfe_ex)⁻¹ x (new_value x)) as HH; desc.
    { apply (unique_choice (new_rfe_ex)⁻¹ (new_rfe_unique)). }

    set (get_val (v: option value) :=  match v with | Some v => v | _ => 0 end).
    set (new_val := fun r => get_val (val G.(lab) (new_value r))).

    assert (forall e (IN: acts_set (ProgToExecution.G state'') e),
               lab (ProgToExecution.G state'') e = G.(lab) e) as LST2.
    { ins.
      assert (tid e = thread) as ETT.
      { eapply acts_rep in IN.
        2: by eapply wf_thread_state_steps; [|by eauto]; eauto.
        desf. }
      erewrite <- steps_preserve_lab; try rewrite ETT; eauto.
      eapply tr_lab; eauto.
      eapply steps_preserve_E; eauto. }

    edestruct steps_old_restrict with (state0:=state'') (state':=state') as [ORMW]; eauto.
    desc. unnw.
    edestruct receptiveness_full with
        (tid:=thread)
        (s_init:=state) (s:=state'')
        (new_val:=new_val)
        (new_rfi:=new_rfi)
        (MOD:=E0 \₁ D G TC') as [pre_cert_state]; eauto.
    { rewrite CACTS. apply NEW_RFIE. }
    { split; [|basic_solver].
      rewrite NEW_RFIE at 1.
      unfolder. intros w r [EEX [RFXY EEY]].
      set (AA := RFXY).
      unfold new_rfi in AA.
      destruct_seq AA as [TX TY].
      unfold new_rf in AA. apply seq_eqv_r in AA. destruct AA as [AA _].
      apply cert_rfD in AA; auto. destruct_seq AA as [WX RY].
      splits; auto; unfold is_w, is_r.
      all: erewrite <- steps_preserve_lab with (state0:=state'') (state':=state'); eauto;
        [ erewrite tr_lab; eauto; eapply E0_in_thread_execE with (TC:=TC); eauto
        | | | by apply CACTS].
      1-2: rewrite TX; auto.
      all: rewrite TY; auto. }
    { rewrite NEWRFI_IN_CERT.
      rewrite cert_rf_tid_in_sb; auto.
      unfold Execution.sb. basic_solver. }
    { unfold new_rfi, new_rf. basic_solver. }
    { rewrite <- CACTS. basic_solver. }
    { rewrite STATECOV.
      sin_rewrite sim_trav_step_covered_le.
      2: by red; eauto.
      rewrite C_in_D; eauto.
      basic_solver. }

    Ltac _ltt thread EE0 TCCOH OC CC CACTS CCD :=
      rewrite OC; rewrite CC;
      rewrite CACTS;
      arewrite_id ⦗Tid thread⦘; arewrite_id ⦗E0⦘ at 1;
      rewrite !seq_id_l;
      (*unfold EE0, thread;*)
      rewrite CCD; [| |apply TCCOH|]; auto;
      basic_solver.

    { _ltt thread E0 TCCOH OFAILDEP TEH.(tr_rmw_dep) CACTS dom_rmw_depE_in_D. }
    { _ltt thread E0 TCCOH OADDR TEH.(tr_addr) CACTS dom_addrE_in_D. }
    2: { _ltt thread E0 TCCOH OCTRL TEH.(tr_ctrl) CACTS dom_ctrlE_in_D. }

    { rewrite CACTS.
      arewrite ((E0 \₁ D G TC') ∩₁ E0 ⊆₁ E0 \₁ D G TC') by basic_solver.
      intros e [[EE DE] RE]. red.
      apply DE.
      set (EE':=EE).
      destruct EE' as [TT [AA|AA]].
      { by apply C_in_D. }
      unfolder in AA.
      destruct AA as [y [z [[EQx | SB] [EQ Iz]]]].
      { rewrite EQx. by apply I_in_D. }
      subst. red. do 2 left. right.
      eexists. eexists. split.
      { by left. }
      apply seq_eqv_r. split; eauto.
      assert (R_ex e) as UU.
      { unfold Events.R_ex. rewrite <- LST2; auto. by apply CACTS. }
      red. apply seq_eqv_l. split.
      { by apply R_ex_in_R. }
      apply seq_eqv_r. split.
      2: by eapply issuedW; eauto.
      apply ct_step. left. right.
      apply seq_eqv_l. split; auto. }

    { rewrite ODATA, CACTS.
      arewrite_id ⦗E0⦘ at 1. rewrite seq_id_l.
      rewrite <- id_inter.
      arewrite (E0 ∩₁ set_compl (E0 \₁ D G TC') ⊆₁ D G TC').
      { unfolder. intros a [AA BB].
        destruct (classic (D G TC' a)); auto.
        exfalso. apply BB. desf. }
      rewrite TEH.(tr_data), !seqA.
      arewrite_id ⦗Tid thread⦘. rewrite !seq_id_l.
      generalize (dom_dataD_in_D). basic_solver 10. }

    desf.

    assert (instrs pre_cert_state = instrs state) as INSTRSS.
    { eapply steps_same_instrs; eauto. }

    edestruct get_stable with (state0:=pre_cert_state) (thread:=thread)
      as [cert_state [CC _]].
    { by rewrite INSTRSS. }
    { eapply transitive_rt; [|by eauto]. by rewrite INSTRSS. }
    desc.

    assert (ProgToExecution.G cert_state = ProgToExecution.G pre_cert_state) as SCC.
    { eapply eps_steps_same_G; eauto. }

    assert (acts_set (ProgToExecution.G pre_cert_state) =
            acts_set (ProgToExecution.G state'')) as SS.
    { unfold acts_set. by rewrite RACTS. }

    exists cert_state.
    splits; auto.
    2 : { eapply transitive_rt; eauto. by apply eps_steps_in_steps. }

    assert (eq_dom (D G TC') (certLab G cert_state) (lab G))
      as CERTLABD.
    { intros e DE. unfold certLab.
      unfold restr_fun.
      destruct (excluded_middle_informative
                  (acts_set (ProgToExecution.G cert_state) e))
               as [CEE|]; auto.
      rewrite SCC in *. rewrite SS in CEE.
      rewrite <- LST2; auto.
      apply same_label_u2v_val; auto.
      apply OLD_VAL. intros [_ ND]. desf. }

    constructor; auto.
    all: try rewrite SCC.
    { intros e DD.
      eapply same_label_u2v_trans.
      { by apply SAME. }
      rewrite LST2; [by red; desf|].
      red. by rewrite RACTS. }
    { unfold acts_set. by rewrite <- RACTS. }
    { rewrite <- RRMW, SS. rewrite ORMW, !CACTS.
      rewrite TEH.(tr_rmw), !seqA.
      rewrite seq_eqvC. seq_rewrite <- !id_inter.
      arewrite (E0 ∩₁ Tid thread ≡₁ E0).
      { rewrite set_interC. unfold CsbI. rewrite <- !set_interA.
          by rewrite set_interK. }
      symmetry. eapply E0_rmw_fwcl.
      3 : eauto.
      all: eauto. }

    rewrite seq_eqv_r.
    intros w r [RF TIDy].
    apply cert_rf_codom in RF.
    destruct_seq_r RF as EER.
    unfold same_val, val.

    destruct (classic (D G TC' r)) as [DR|NDR].
    { rewrite CERTLABD with (x:=r); auto.
      assert (rf w r) as RFWR.
      { intros. eapply cert_rf_D_in_rf with (TC:=TC'); eauto.
        apply seq_eqv_r. do 2 (split; eauto). }
      assert (D G TC' w).
      2: { rewrite CERTLABD; auto. apply wf_rfv; auto. }
      eapply rf_D_CsbI_in_D; eauto.
      basic_solver 10. }

    unfold certLab at 2.
    set (STE := EER).
    assert (E0 r) as E0r.
    { basic_solver. }
    apply CACTS in E0r.
    unfold restr_fun.
    destruct (excluded_middle_informative (acts_set (ProgToExecution.G cert_state) r))
      as [VV|VV].
    2: { exfalso. apply VV. rewrite SCC. red. by rewrite <- RACTS. }
    rewrite SCC.

    set (LL := RF).
    apply cert_rfE in LL; auto. destruct_seq LL as [RE RW].
    apply cert_rfD in LL; auto. destruct_seq LL as [RR WW].

    assert (Tid thread w -> sb w r) as SBWR.
    { intros TTW.
      edestruct same_thread with (x:=r) (y:=w) as [[SB|SB]|SB]; eauto.
      { intros II. eapply init_w in II; eauto.
        clear -WW II. type_solver. }
      { desf. }
      { subst. clear -RR WW. type_solver. }
      exfalso. eapply cert_rf_hb_irr; eauto.
      eexists; split; eauto. by apply sb_in_hb. }

    assert (Tid thread w -> acts_set (ProgToExecution.G cert_state) w) as PP.
    { intros TT. set (AA := TT).
      apply SBWR in AA. rewrite SCC. red.
      rewrite <- RACTS. apply CACTS.
      eapply E0_sb_prcl; [|eauto|]; eauto.
      basic_solver 10. }

    destruct (classic (codom_rel new_rfi r)) as [DD|DD].
    { set (TT:=DD). destruct TT as [w' TT].
      set (OO := TT). destruct_seq OO as [TTW TTR].
      assert (w' = w); subst.
      { destruct_seq_r OO as QQ. eapply cert_rff; eauto. }
      unfold certLab. unfold restr_fun.
      set (OO' := OO). destruct_seq_r OO' as OOK.
      assert (tid w = tid r) as EQT by congruence.
      specialize (PP EQT).
      destruct (excluded_middle_informative (acts_set (ProgToExecution.G cert_state) w));
        [|done].
      rewrite SCC.
      symmetry. apply NEW_VAL1. red.
      apply seq_eqv_l. split; auto.
      apply seq_eqv_r. split; auto. }

    destruct (classic (Tid thread w)) as [TTW|NTTW].
    { exfalso. apply DD. exists w.
      apply seq_eqv_l. split; auto.
      apply seq_eqv_r. split; auto.
      apply seq_eqv_r. do 2 (split; auto).
      basic_solver. }

    rewrite CERTLABD.
    2: { apply cert_rf_iss_sb in LL; auto.
         destruct LL as [LL | [SB STID]];
           auto; [|congruence].
         destruct_seq_l LL as Iw.
           by apply I_in_D. }

    etransitivity.
    2: { symmetry. apply NEW_VAL2; auto.
         2: by split.
         eapply same_lab_u2v_is_r; eauto. unfold is_r. by rewrite LST2. }
    unfold new_val, get_val, val.
    assert (new_value r = w) as FF.
    2: { rewrite FF; desf. clear -Heq RR. type_solver. }
    assert (new_rfe w r) as RFE.
    { apply seq_eqv_l. split; auto.
      apply seq_eqv_r. split; auto.
      apply seq_eqv_r. repeat (split; auto). }
    specialize (HH r). destruct HH as [HH|HH].
    { eapply new_rfef; eauto. }
    clear -HH RFE. red in HH. desf.
    exfalso. apply HH0. rewrite HH.
    eexists. eauto.
Qed.

(******************************************************************************)
(** ** ilbl_step lemmas *)
(******************************************************************************)

Lemma ilbl_step_E0_eindex lbls
        (st st' st'' : Language.state (PromiseLTS.thread_lts thread))
        (WFT : wf_thread_state thread st)
        (CG : cert_graph G sc TC' thread st'')
        (ILBL_STEP : ilbl_step thread lbls st st')
        (CST_REACHABLE : (lbl_step thread)＊ st' st'') :
  E0 (ThreadEvent thread st.(eindex)).
Proof.
  eapply dcertE; [apply CG|].
  eapply preserve_event.
  { eapply lbl_steps_in_steps; eauto. }
  edestruct ilbl_step_cases as [l [l' HH]]; eauto.
  desf; apply ACTS; basic_solver.
Qed.

Lemma ilbl_step_E0_eindex' lbls lbl lbl'
        (st st' st'' : Language.state (PromiseLTS.thread_lts thread))
        (WFT : wf_thread_state thread st)
        (CG : cert_graph G sc TC' thread st'')
        (ILBL_STEP : ilbl_step thread lbls st st')
        (LBLS_EQ : lbls = opt_to_list lbl' ++ [lbl])
        (LBL' : lbl' <> None)
        (CST_REACHABLE : (lbl_step thread)＊ st' st'') :
  E0 (ThreadEvent thread (1 + st.(eindex))).
Proof.
  eapply dcertE; [apply CG|].
  eapply preserve_event.
  { eapply lbl_steps_in_steps; eauto. }
  edestruct ilbl_step_cases as [l [l' HH]]; eauto.
  desf.
  1-4 : apply opt_to_list_app_singl in LBLS; intuition.
  desf; apply ACTS; basic_solver.
Qed.

(* Lemma ilbl_step_cert_dom_eindex lbls *)
(*         (st st' st'' : Language.state (Promise.thread_lts thread)) *)
(*         (WFT : wf_thread_state thread st)  *)
(*         (CG : cert_graph G sc TC TC' thread st'') *)
(*         (ILBL_STEP : ilbl_step thread lbls st st') *)
(*         (CST_REACHABLE : (lbl_step thread)＊ st' st'') :  *)
(*   cert_dom st' ≡₁ cert_dom st ∪  *)
(*            eq (ThreadEvent thread st.(eindex)) ∪₁ eq (ThreadEvent thread (1 + st.(eindex))) *)
(*   E0 (ThreadEvent thread st.(eindex)). *)

End CertGraphLemmas.


Require Export Program.Basics. Open Scope program_scope.
From Paco Require Import paco.
From Paco Require Import paconotation_internal paco_internal pacotac_internal.
From Paco Require Export paconotation.
From Fairness Require Import pind_internal.
Set Implicit Arguments.

Section PIND9.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable T4 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2), Type.
Variable T5 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3), Type.
Variable T6 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4), Type.
Variable T7 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5), Type.
Variable T8 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6), Type.

(** ** Predicates of Arity 9
*)

Definition pind9(gf : rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8 -> rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8)(r: rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8) : rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8 :=
  @curry9 T0 T1 T2 T3 T4 T5 T6 T7 T8 (pind (fun R0 => @uncurry9 T0 T1 T2 T3 T4 T5 T6 T7 T8 (gf (@curry9 T0 T1 T2 T3 T4 T5 T6 T7 T8 R0))) (@uncurry9 T0 T1 T2 T3 T4 T5 T6 T7 T8 r)).

Definition upind9(gf : rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8 -> rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8)(r: rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8) := pind9 gf r /9\ r.
Arguments pind9 : clear implicits.
Arguments upind9 : clear implicits.
#[local] Hint Unfold upind9 : core.

Lemma monotone9_inter (gf gf': rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8 -> rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8)
      (MON1: monotone9 gf)
      (MON2: monotone9 gf'):
  monotone9 (gf /10\ gf').
Proof.
  red; intros. destruct IN. split; eauto.
Qed.

Lemma _pind9_mon_gen (gf gf': rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8 -> rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8) r r'
    (LEgf: gf <10= gf')
    (LEr: r <9= r'):
  pind9 gf r <9== pind9 gf' r'.
Proof.
  apply curry_map9. red; intros. eapply pind_mon_gen. apply PR.
  - intros. apply LEgf, PR0.
  - intros. apply LEr, PR0.
Qed.

Lemma pind9_mon_gen (gf gf': rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8 -> rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8) r r' x0 x1 x2 x3 x4 x5 x6 x7 x8
    (REL: pind9 gf r x0 x1 x2 x3 x4 x5 x6 x7 x8)
    (LEgf: gf <10= gf')
    (LEr: r <9= r'):
  pind9 gf' r' x0 x1 x2 x3 x4 x5 x6 x7 x8.
Proof.
  eapply _pind9_mon_gen; [apply LEgf | apply LEr | apply REL].
Qed.

Lemma pind9_mon_bot (gf gf': rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8 -> rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8) r' x0 x1 x2 x3 x4 x5 x6 x7 x8
    (REL: pind9 gf bot9 x0 x1 x2 x3 x4 x5 x6 x7 x8)
    (LEgf: gf <10= gf'):
  pind9 gf' r' x0 x1 x2 x3 x4 x5 x6 x7 x8.
Proof.
  eapply pind9_mon_gen; [apply REL | apply LEgf | intros; contradiction PR].
Qed.

Definition top9 { T0 T1 T2 T3 T4 T5 T6 T7 T8} (x0: T0) (x1: T1 x0) (x2: T2 x0 x1) (x3: T3 x0 x1 x2) (x4: T4 x0 x1 x2 x3) (x5: T5 x0 x1 x2 x3 x4) (x6: T6 x0 x1 x2 x3 x4 x5) (x7: T7 x0 x1 x2 x3 x4 x5 x6) (x8: T8 x0 x1 x2 x3 x4 x5 x6 x7) := True.

Lemma pind9_mon_top (gf gf': rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8 -> rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8) r x0 x1 x2 x3 x4 x5 x6 x7 x8
    (REL: pind9 gf r x0 x1 x2 x3 x4 x5 x6 x7 x8)
    (LEgf: gf <10= gf'):
  pind9 gf' top9 x0 x1 x2 x3 x4 x5 x6 x7 x8.
Proof.
  eapply pind9_mon_gen; eauto. red. auto.
Qed.

Lemma upind9_mon_gen (gf gf': rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8 -> rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8) r r' x0 x1 x2 x3 x4 x5 x6 x7 x8
    (REL: upind9 gf r x0 x1 x2 x3 x4 x5 x6 x7 x8)
    (LEgf: gf <10= gf')
    (LEr: r <9= r'):
  upind9 gf' r' x0 x1 x2 x3 x4 x5 x6 x7 x8.
Proof.
  destruct REL. split; eauto.
  eapply pind9_mon_gen; [apply H | apply LEgf | apply LEr].
Qed.

Lemma upind9_mon_bot (gf gf': rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8 -> rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8) r' x0 x1 x2 x3 x4 x5 x6 x7 x8
    (REL: upind9 gf bot9 x0 x1 x2 x3 x4 x5 x6 x7 x8)
    (LEgf: gf <10= gf'):
  upind9 gf' r' x0 x1 x2 x3 x4 x5 x6 x7 x8.
Proof.
  eapply upind9_mon_gen; [apply REL | apply LEgf | intros; contradiction PR].
Qed.

Lemma upind9mon_top (gf gf': rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8 -> rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8) r x0 x1 x2 x3 x4 x5 x6 x7 x8
    (REL: upind9 gf r x0 x1 x2 x3 x4 x5 x6 x7 x8)
    (LEgf: gf <10= gf'):
  upind9 gf' top9 x0 x1 x2 x3 x4 x5 x6 x7 x8.
Proof.
  eapply upind9_mon_gen; eauto. red. auto.
Qed.

Section Arg9.

Variable gf : rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8 -> rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8.
Arguments gf : clear implicits.

Theorem _pind9_mon: _monotone9 (pind9 gf).
Proof.
  red; intros. eapply curry_map9, _pind_mon; apply uncurry_map9; assumption.
Qed.

Theorem _pind9_acc: forall
  l r (OBG: forall rr (DEC: rr <9== r) (IH: rr <9== l), pind9 gf rr <9== l),
  pind9 gf r <9== l.
Proof.
  intros. apply curry_adjoint2_9.
  eapply _pind_acc. intros.
  apply curry_adjoint2_9 in DEC. apply curry_adjoint2_9 in IH.
  apply curry_adjoint1_9.
  eapply le9_trans. 2: eapply (OBG _ DEC IH).
  apply curry_map9.
  apply _pind_mon; try apply le1_refl; apply curry_bij2_9.
Qed.

Theorem _pind9_mult_strong: forall r,
  pind9 gf r <9== pind9 gf (upind9 gf r).
Proof.
  intros. apply curry_map9.
  eapply le1_trans; [eapply _pind_mult_strong |].
  apply _pind_mon; intros [] H. apply H.
Qed.

Theorem _pind9_fold: forall r,
  gf (upind9 gf r) <9== pind9 gf r.
Proof.
  intros. apply uncurry_adjoint1_9.
  eapply le1_trans; [| apply _pind_fold]. apply le1_refl.
Qed.

Theorem _pind9_unfold: forall (MON: _monotone9 gf) r,
  pind9 gf r <9== gf (upind9 gf r).
Proof.
  intros. apply curry_adjoint2_9.
  eapply _pind_unfold; apply monotone9_map; assumption.
Qed.

Theorem pind9_acc: forall
  l r (OBG: forall rr (DEC: rr <9= r) (IH: rr <9= l), pind9 gf rr <9= l),
  pind9 gf r <9= l.
Proof.
  apply _pind9_acc.
Qed.

Theorem pind9_mon: monotone9 (pind9 gf).
Proof.
  apply monotone9_eq.
  apply _pind9_mon.
Qed.

Theorem upind9_mon: monotone9 (upind9 gf).
Proof.
  red; intros.
  destruct IN. split; eauto.
  eapply pind9_mon. apply H. apply LE.
Qed.

Theorem pind9_mult_strong: forall r,
  pind9 gf r <9= pind9 gf (upind9 gf r).
Proof.
  apply _pind9_mult_strong.
Qed.

Corollary pind9_mult: forall r,
  pind9 gf r <9= pind9 gf (pind9 gf r).
Proof. intros; eapply pind9_mult_strong in PR. eapply pind9_mon; eauto. intros. destruct PR0. eauto. Qed.

Theorem pind9_fold: forall r,
  gf (upind9 gf r) <9= pind9 gf r.
Proof.
  apply _pind9_fold.
Qed.

Theorem pind9_unfold: forall (MON: monotone9 gf) r,
  pind9 gf r <9= gf (upind9 gf r).
Proof.
  intro. eapply _pind9_unfold; apply monotone9_eq; assumption.
Qed.

End Arg9.

Arguments pind9_acc : clear implicits.
Arguments pind9_mon : clear implicits.
Arguments upind9_mon : clear implicits.
Arguments pind9_mult_strong : clear implicits.
Arguments pind9_mult : clear implicits.
Arguments pind9_fold : clear implicits.
Arguments pind9_unfold : clear implicits.

End PIND9.

Global Opaque pind9.

#[export] Hint Unfold upind9 : core.
#[export] Hint Resolve pind9_fold : core.
#[export] Hint Unfold monotone9 : core.


Require Import RelationClasses.
Require Import List.
Require Import Basics.
Require Import Coqlib.

Require Import sflib.
From Paco Require Import paco.

Require Import Basic.
Require Import Axioms.
Require Import Loc.
Require Import DenseOrder.
Require Import Language.
Require Import ZArith.
Require Import Maps.
Require Import FSets.
Require Import FSetInterface.
Require Import Lattice.
Require Import Event.
Require Import Syntax.
Require Import Semantics.

Require Import Memory.
Require Import Cell.
Require Import Time.
Require Import Thread.
Require Import Local.
Require Import CompAuxDef.

Require Import Kildall.
Require Import AveAnalysis.
Require Import CorrectOpt.
Require Import MsgMapping.
Require Import CSE.
Require Import LocalSim.
Require Import LibTactics.
Require Import Event.
Require Import View.
Require Import TView.

Require Import CSEProofAux.
Require Import CSEProofMState.
Require Import CSEProofStep.

(** * Correctness Proof of Common subexpression elimination *)

(** Top level proofs for Common Subexpression Elimination's correctness *)

(** the top lemma organizes individual transition's correctness *)
Theorem cse_match_state_implies_sim:
  forall inj lo e_tgt e_src b,
  cse_match_state inj lo e_tgt e_src b
  -> @local_sim_state nat lt rtl_lang cse_invariant lo inj DelaySet.dset_init b e_tgt e_src.
Proof.
  cofix COFIX.
  intros.
  destruct e_tgt as (st_tgt, lc_tgt, sc_tgt, mem_tgt) eqn:EqETgt.
  destruct e_src as (st_src, lc_src, sc_src, mem_src) eqn:EqESrc.

  pose proof (classic (Local.promise_consistent lc_tgt)).
  destruct H0 as [CsstTgt|NotCsstTgt].
  2: {
    eapply local_sim_state_tgt_not_prm_consistent_intro; eauto.
  }

  pose proof (classic (Thread.is_abort e_tgt lo)).
  destruct H0 as [|NotAbort].
  {
    eapply local_sim_state_abort_intro; eauto.
    eapply cse_match_state_implies_abort_preserving. splits; eauto.
    rewrite EqETgt in H0; eauto.
  }

  eapply local_sim_state_step_intro; eauto.
  eapply cse_match_state_implies_si; eauto.
  4: { (** case: abort step -> sim. proved. *)
    intro. rewrite EqETgt in NotAbort. contradiction.
  }
  3: { (** case: done step -> sim *)
    pose proof (classic (Thread.is_done e_tgt)).

    destruct H0 as [Done|NotDone].
    2: {
      intros. rewrite <- EqETgt in DONE. contradiction.
    }
    (** case: done. straightforward. *)
    intros. clear DONE.
    inversion H. simpls.
    exists e_src; exists inj'.
    splits; eauto.
    { (** na_steps *)
      rewrite <- EqESrc.
      eapply rtc_refl.
      econs.
    }
    2: { (** trivial incr_inj *)
      destruct PREEMPT as [(_&EQ_INJ) | (_&INCR_INJ)].
      apply eq_inj_implies_incr; trivial.
      trivial.
    }
    2: { (** trivial invariant *)
      rewrite EqESrc; simpls.
      trivial.
    }
    { (** tgt done -> src done *)
      unfolds Thread.is_done.
      destruct Done as (IsTermTgt & NoPrmTgt).
      splits.
      2: { (** src promise free *)
        rewrite EqESrc. rewrite EqETgt in NoPrmTgt. simpls.
        inv H. inv MATCH_LOCAL. simpls.
        rewrite <- PROMISES_EQ. trivial.
      }
      { (** src done *)
        unfolds Language.is_terminal; simpls.
        unfolds State.is_terminal.
        destruct IsTermTgt as (RetTgt & ContDoneTgt).
        inv H.
        inv MATCH_LOCAL.
        inv MATCH_RTL_STATE. simpls.
        splits.
        inv MATCH_FRAME.
        remember (AveAI.br_from_i analysis !! l i) as ai.
        rewrite RetTgt in TRANSF_BLK.
        eapply ret_transformed_by_ret; eauto.

        inv MATCH_CONT.
        destruct DONE; trivial.
        rewrite ContDoneTgt in CONT_T; discriminate.
      }
    }
  }
  2: { (** case: rely step -> sim *)
    intro.
    splits.
    { (** I still holds *)
      inv H; simpls.
      destruct PREEMPT as [(_&EQ_INJ) | (B&INCR_INJ)].
      2: { discriminate. }
      eapply eq_inj_implies_invariant; eauto.
      eapply eq_inj_sym.
      trivial.
    }
    intros.
    rewrite OUT_ATMBLK in H.
    eapply cse_match_state_preserving_rely in H; eauto.
  }
  (** case: thread step -> sim *)
  intros. splits.
  { (** case: at step -> sim *)
    intros.
    destruct e_tgt' as (st_tgt', lc_tgt', sc_tgt', mem_tgt') eqn:EqETgt'.
    eapply cse_match_state_preserving_at
      with (st_tgt' := st_tgt') (lc_tgt' := lc_tgt')
           (sc_tgt' := sc_tgt') (mem_tgt' := mem_tgt')
      in H; eauto.
    2: {
          {
            inversion STEP.
            {
              (** at is not prc *)
              inv STEP0.
              unfolds ThreadEvent.is_at_or_out_step. contradiction.
            }
            trivial.
          }
      }
      {
        destruct H as (st_src' & lc_src' & sc_src' & mem_src' & inj' & H & H1 & H2).
        remember {|
                Thread.state := st_src';
                Thread.local := lc_src';
                Thread.sc := sc_src';
                Thread.memory := mem_src'
              |} as e_src'.

        exists e_src. exists e_src'. exists inj'. exists te.
        rewrite <- EqESrc.
        splits; eauto.
        rewrite EqESrc.
        trivial.
        eapply thrdevt_eq_refl.
      }
  }
  { (** case: na step -> sim *)
    intros.
    destruct e_tgt' as (st_tgt', lc_tgt', sc_tgt', mem_tgt') eqn:EqETgt'.
    pose proof classic (ThreadEvent.is_na_access te).
    destruct H0 as [IS_NA_ACCESS | NOT_NA_ACCESS].
    { (** is na access *)
      eapply cse_match_state_preserving_na_access
      with (st_tgt' := st_tgt') (lc_tgt' := lc_tgt')
          (sc_tgt' := sc_tgt') (mem_tgt' := mem_tgt')
      in H; eauto.
      destruct H as (st_src' & lc_src' & sc_src' & mem_src' & H1 & H2).
      2: {
          {
            inversion STEP.
            {
              inv STEP0.
              unfolds ThreadEvent.is_at_or_out_step. contradiction.
            }
            trivial.
          }
        }
        remember {|
        Thread.state := st_src';
        Thread.local := lc_src';
        Thread.sc := sc_src';
        Thread.memory := mem_src'
      |} as e_src'.
      pose proof classic (ThreadEvent.is_na_write te).
      destruct H as [IS_NA_WRITE | NOT_NA_WRITE].
      2: { (** na read *)
        exists e_src'.
        do 3 exists (@DelaySet.dset_init nat).
        unfolds ThreadEvent.is_na_write; unfolds ThreadEvent.is_na_access.
        inversion H1.
        simpls.
        destruct te; simpls; try contradiction; eauto.
        destruct ord; simpls; try contradiction; eauto.
        splits; eauto.
        - eapply DelaySet.dset_become_na_read; eauto.
        - eapply DelaySet.na_steps_dset_read with (dset:=DelaySet.dset_init) in H1; eauto.
          {
            eapply Operators_Properties.clos_rt1n_step in H1.
            rewrite <- H6 in H1.
            rewrite H1.
            eapply rtc_refl. econs.
          }
          {
            simpls. intros.
            rewrite DelaySet.dset_gempty in H.
            discriminate.
          }
        - eapply DelaySet.dset_reduce_init; eauto.
        - rewrite <- H6 in H2. auto.
      }
      (** is na write *)
      unfolds ThreadEvent.is_na_write.
      destruct te; try contradiction; eauto.
      destruct ord; try contradiction; eauto.
      exists e_src'.
      exists (DelaySet.dset_add loc to 0 DelaySet.dset_init).
      do 2 exists (@DelaySet.dset_init nat).
      splits; eauto.
      - eapply DelaySet.dset_become_na_write; eauto.
      - eapply DelaySet.na_steps_dset_write in H1; eauto.
        right. exists to.
        rewrite DelaySet.dset_remove_add. trivial.
      - eapply DelaySet.dset_reduce_init.
    }
    { (** is na silent *)
      unfolds ThreadEvent.is_na_access.
      unfolds ThreadEvent.is_na_step.
      destruct te eqn:EqTe; simpls; eauto; try contradiction.
      clear NA_STEP; clear NOT_NA_ACCESS.
      eapply cse_match_state_preserving_na_silent
      with (st_tgt' := st_tgt') (lc_tgt' := lc_tgt')
          (sc_tgt' := sc_tgt') (mem_tgt' := mem_tgt')
      in H; eauto.
      2: {
        inversion STEP. inversion STEP0.   auto.
      }
      destruct H as (st_src' & lc_src' & sc_src' & mem_src' & te' & SILENT & SRCSTEP & MATCH_STATE).
      remember {|
        Thread.state := st_src';
        Thread.local := lc_src';
        Thread.sc := sc_src';
        Thread.memory := mem_src'
      |} as e_src'.
      exists e_src'.
      do 3 exists (@DelaySet.dset_init nat).
      splits; eauto.
      - eapply DelaySet.dset_become_na_read; eauto.
      - destruct SILENT; eauto.
        {
          rewrite H in SRCSTEP.
          eapply DelaySet.na_steps_dset_tau in SRCSTEP; eauto.
        }
        {
          unfold ThreadEvent.is_na_read in H.
          destruct te'; try discriminate; try contradiction; eauto.
          destruct ord; try contradiction; eauto.
          eapply DelaySet.na_steps_dset_read in SRCSTEP; eauto.
          simpls.
          intros.
          rewrite DelaySet.dset_gempty in H0; discriminate.
        }
      - eapply DelaySet.dset_reduce_init; eauto.
    }
  }
  { (** case: promise step -> sim *)
    intros.
    destruct e_tgt' as (st_tgt', lc_tgt', sc_tgt', mem_tgt') eqn:EqETgt'.
    eapply cse_match_state_preserving_prm
      with (st_tgt' := st_tgt') (lc_tgt' := lc_tgt')
          (sc_tgt' := sc_tgt') (mem_tgt' := mem_tgt')
          (te := te)
      in H; eauto.
    2: {
      rewrite PROMISE in STEP.
      destruct PRM_STEP as (loc & t & PRM_STEP).
      unfolds ThreadEvent.is_promising.
      destruct te; try discriminate; eauto.
      inv PRM_STEP.
      inv STEP.
      trivial.
    }
    destruct H as (st_src' & lc_src' & sc_src' & mem_src' & inj' & H & H1 & H2).
    remember {|
        Thread.state := st_src';
        Thread.local := lc_src';
        Thread.sc := sc_src';
        Thread.memory := mem_src'
      |} as e_src'.
    exists e_src'. exists inj'.
    splits; eauto.
    eapply rtc_n1 with (b:=e_src).
    - rewrite EqESrc. eapply rtc_refl. trivial.
    - rewrite EqESrc.
      rewrite PROMISE in STEP.
      destruct PRM_STEP as (loc & t & PRM_STEP).
      unfolds ThreadEvent.is_promising.
      destruct te; try discriminate; eauto.
      inv PRM_STEP.
      eapply Thread.prc_step_intro; eauto.
  }
  { (** case: promise-free step -> sim *)
    intros.
    destruct e_tgt' as (st_tgt', lc_tgt', sc_tgt', mem_tgt') eqn:EqETgt'.
    eapply cse_match_state_preserving_pf_prm
      with (st_tgt' := st_tgt') (lc_tgt' := lc_tgt')
           (sc_tgt' := sc_tgt') (mem_tgt' := mem_tgt')
      in H; eauto.
    2: {
        eapply Thread.pf_promise_step_intro with (e:=te).
        rewrite PF in STEP.
        destruct PRM_STEP as (loc & t & PRM_STEP).
        unfolds ThreadEvent.is_promising.
        destruct te; try discriminate; eauto.
        inv PRM_STEP. simpls.
        inv STEP; eauto.
        inversion STEP0.
        inv LOCAL; try discriminate; eauto.
    }
    destruct H as (st_src' & lc_src' & sc_src' & mem_src' & H & H1).
    remember {|
        Thread.state := st_src';
        Thread.local := lc_src';
        Thread.sc := sc_src';
        Thread.memory := mem_src'
      |} as e_src'.
    exists e_src'.
    splits; eauto.
  }
Qed.

(** ** Correctness of the Common subexpression elimination *)
(** proof for initial match state *)
Theorem verif_cse:
  forall code_s code_t lo,
      cse_optimizer lo code_s = Some code_t
      ->
      @local_sim nat lt rtl_lang cse_invariant lo code_t code_s.
Proof.
  intros.
  constructor.
  - apply nat_lt_is_well_founded.
  - apply wf_cse_invariant.
  - apply cse_invariant_init.
  - intros.
    inv INIT_STATE.
    unfolds State.init; simpls.
    destruct (code_t ! fid) eqn:CodetFunc; try discriminate.
    destruct f eqn:FunctCdhp. destruct (c ! f0) eqn:CdhptBlk; try discriminate.
    inversion H1. clear H1. rewrite H2.
    pose proof H as OPT.
    unfold cse_optimizer in H. inversion H. clear H.
    unfolds transform_prog.
    pose proof CodetFunc.
    rewrite <- H1 in H.

    rewrite PTree.gmap in H.
    unfolds Coqlib.option_map.
    destruct (code_s ! fid) eqn:CodeSFunc; try discriminate.
    inversion H. clear H.
    destruct f1 eqn:FuncS.
    rename f1 into func_s, c0 into cdhp_s, f2 into fentry_s.
    rename f into func_t, c into cdhp_t, f0 into fentry_t, t into blk_t.
    (**
      code_t -> func_t -> (cdhp_t, fentry_t) -> blk_t
      code_s -> func_s -> chdp_s [] -> []
    *)
    unfolds transform_func.
    remember (AveDS.analyze_program code_s succ AveLat.top Ave_B.transf_blk) ! fid as AFunc.
    assert (fentry_s = fentry_t). {
      destruct AFunc; inv H3; auto.
    }
    remember (cdhp_s ! fentry_s) as opt_blk_s.
    destruct opt_blk_s eqn:BlkS.
    2: {  (** blk_t exists implies blk_s exists  *)
      destruct AFunc eqn:AFuncEq.
      2: { (** AFunc = None => blk_t = blk_s *)
        inversion H3. rewrite H4 in Heqopt_blk_s. rewrite H5 in Heqopt_blk_s. rewrite <- Heqopt_blk_s in CdhptBlk. discriminate.
      } (** AFunc = Some res => blk_t becomes from blk_s *)
      inversion H3.
      pose proof CdhptBlk.
      unfolds transform_cdhp.
      rewrite <- H4 in H0.
      rewrite PTree.gmap in H0.
      unfolds Coqlib.option_map.
      destruct (cdhp_s ! fentry_t) eqn:BlkSS; try discriminate.
      rename t into blk_s. rewrite <- H5 in BlkSS. rewrite BlkSS in Heqopt_blk_s. discriminate.
    }
    rename t into blk_s.
    clear BlkS opt_blk_s.
    (** Some prepare clean-up finished.*)
    (** Now we have:
        fid & AFunc
        code_t -> func_t -> (cdhp_t, fentry_t) -> blk_t
          SS       SS          SS       ||         SS
        code_s -> func_s -> (chdp_s, fentry_t) -> blk_s
    *)
    (** Let prove match_state_init *)
    remember (State.mk RegFile.init blk_s cdhp_s Continuation.done code_s) as st_src.
    exists st_src.
    splits.
    { (** Init(code_s, fid) = st_src*)
        unfolds State.init. rewrite CodeSFunc. rewrite <- Heqopt_blk_s. eapply f_equal. eauto.
    }
    (** let's prove local simulation *)
    (** 1. we have match_state on initial states *)
    pose proof (cse_invariant_init lo).
  assert (cse_match_state inj_init lo
    (Thread.mk rtl_lang st_tgt Local.init TimeMap.bot Memory.init)
    (Thread.mk rtl_lang st_src Local.init TimeMap.bot Memory.init) true). {
      eapply cse_match_state_intro with (inj' := inj_init); simpls; eauto.
      2: { (** inj = inj' = init_inj *)
        left. splits; eauto.
        unfolds eq_inj. intros; eauto.
      }
      2: {
        eapply Local.wf_init.
      }
      2: {
        eapply Memory.closed_timemap_bot.
        unfolds Memory.inhabited; intros; eauto.
      }
      2: {
        eapply Memory.init_closed.
      }
      (** match local state *)
      eapply cse_match_local_state_intro; eauto.
      2: {
        unfolds Local.init; simpl; eauto. unfolds TView.eq; eauto.
      }
      destruct AFunc eqn:AFunc_is_None.
      (** match rtl state *)
      eapply cse_match_rtl_state_intro; eauto.
      { (** transform code_s aprog = code_t *)
        rewrite Heqst_src; simpls.
        rewrite <- H2; simpls. auto.
      }
      2: { (* match_cont *)
      rewrite Heqst_src; rewrite <- H2; simpls.
      eapply cse_match_cont_base; auto.
      }
      { (* cse_match_frame *)
        rename a into acdhp.
        eapply cse_match_frame_intro with (i := 0) (l := fentry_s) (enode := fentry_s) (blk := blk_s) (analysis:= acdhp);
        try rewrite Heqst_src; try rewrite <- H2; simpls; eauto.
        2: { inv H3; trivial. }
        3: { (** match abstract interp *)
          unfolds match_abstract_interp; unfolds AveAI.br_from_i; simpls.
          assert (AveAI.ge (AveAI.getFirst (acdhp !! fentry_s)) AveLat.top).
          {
            eapply AveDS.analyze_func_entry; eauto.
            eapply Ave_B.wf_transf_blk.
          }
          remember (AveAI.getFirst acdhp!!fentry_s) as aentry.
          - destruct aentry; eauto.
            simpls.
            intros.
            pose proof W.empty_1. unfolds W.Empty. unfolds W.Subset.
            eapply H4 in H5. eapply H6 in H5. contradiction.
        }
        2: {  (** transform blk_s analysis fentry_s => blk_t *)
            unfolds AveAI.br_from_i; simpls.
            inversion H3; clear H6.
            unfold transform_cdhp in H5.
            pose proof CdhptBlk.
            rewrite <- H5 in H4.
            rewrite PTree.gmap in H4; unfolds Coqlib.option_map; simpls.
            rewrite <- H in H4; rewrite <- Heqopt_blk_s in H4.
            inversion H4.
            unfold transform_blk'. rewrite H; auto.
        }
        {
            pose proof HeqAFunc.
            unfold AveDS.analyze_program in H4.
            rewrite PTree.gmap1 in H4.
            unfolds Coqlib.option_map.
            rewrite CodeSFunc in H4. simpls.
            inversion H4.
            remember (AveDS.fixpoint_blk cdhp_s succ fentry_s AveLat.top
                (fun (n : positive) (ai : AveDS.AI.t) =>
                match cdhp_s ! n with
                | Some b => Ave_B.transf_blk ai b
                | None => AveDS.AI.Atom ai
                end)) as acdhp_partial.
            destruct acdhp_partial eqn:acdhp_partial_eq.
             - left.  trivial.
             - right. trivial.
        }
        { (** link *)
          unfolds AveAI.br_from_i; simpls.
          intros.
          eapply AveDS.analyze_func_solution; eauto.
          eapply Ave_B.wf_transf_blk.
          eapply Ave_B.wf_transf_blk2.
        }
        {
          unfolds AveAI.br_from_i; simpls.
          assert (AveAI.ge (AveAI.getFirst (acdhp !! fentry_s)) AveLat.top).
          {
            eapply AveDS.analyze_func_entry; eauto.
            eapply Ave_B.wf_transf_blk.
          }
          unfold AveAI.ge in H4. unfold AveDS.L.ge in H4.
          destruct (AveAI.getFirst acdhp !! fentry_s) eqn:EqEntry; unfolds AveLat.top; try contradiction; eauto.
          assert (W.Empty tuples). {
            unfolds W.Subset.
            pose proof (classic (exists a, W.In a tuples)). destruct H5; trivial.
            2: {
              unfold W.Empty.
              eapply not_ex_all_not. trivial.
            }
            destruct H5.
            specialize (H4 x H5).
            pose proof W.empty_1. unfolds W.Empty.
            specialize (H6 x). contradiction.
          }
          unfolds loc_fact_valid.
          intros.
          unfolds W.Empty.
          specialize (H5 (AveTuple.AVar r loc)).
          contradiction.
        }
      }
      {
          rewrite <- H2.
          rewrite Heqst_src.
          simpls.
          eapply AveDS.wf_analyze_func with (eval := AveLat.top) (transfb := Ave_B.transf_blk) in CodeSFunc; eauto.
          destruct CodeSFunc as (acdhp & ACdhp).
          rewrite ACdhp in HeqAFunc. discriminate.
      }
      {
        unfold mem_injected.
        intros.
        unfold Local.init in MSG; simpls.
        rewrite Memory.bot_get in MSG. discriminate.
      }
    }
    apply cse_match_state_implies_sim in H4; simpls; auto.
Qed.

(** Common subexpression elimination optimizer is correct. *)
Theorem correct_cse:
  Correct cse_optimizer.
Proof.
  eapply Verif_implies_Correctness.
  unfolds Verif. intros. exists cse_invariant nat lt.
  eapply verif_cse; eauto.
Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.
From extructures Require Import ord fmap.
From CoqUtils Require Import hseq word.
Require Import Coq.Strings.String.

Require Import lib.utils.
Require Import common.types.
Require Import concrete.concrete.
Require Import concrete.exec.
Require Import symbolic.symbolic.
Require Import symbolic.exec.
Require Import symbolic.rules.
Require Import symbolic.refinement_common.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Hint Constructors restricted_exec.
Hint Unfold exec.
Hint Resolve restricted_exec_trans.

Section Refinement.

Context {mt : machine_types}
        {ops : machine_ops mt}
        {opss : machine_ops_spec ops}
        {sp : Symbolic.params}
        {e : encodable mt Symbolic.ttypes}
        {mi : monitor_invariant}
        {table : Symbolic.syscall_table mt}
        {mcc : monitor_code_bwd_correctness mi table}.

Hint Unfold Symbolic.next_state.
Hint Unfold Symbolic.next_state_reg_and_pc.
Hint Unfold Symbolic.next_state_pc.
Hint Unfold Symbolic.next_state_reg.

Hint Resolve monitor_invariant_upd_mem.
Hint Resolve monitor_invariant_upd_reg.
Hint Resolve monitor_invariant_store_mvec.

Local Open Scope string_scope.

Ltac check_conv t1 t2 :=
  let e := constr:(erefl t1 : t1 = t2) in idtac.

Ltac contradict_in_user :=
  match goal with
  | INUSER : is_true (in_user ?st),
    ISMONITOR : ?t = Concrete.TMonitor |- _ =>
    check_conv (Concrete.pct st) t;
    first [ rewrite ISMONITOR /in_user /= decode_monitor_tag in INUSER; done |
            failwith "contradict_in_user" ]
  end.

Ltac destruct_hseq :=
  repeat match goal with
  | x : hseq _ _ |- _ => simpl in x
  | x : hseq_nil |- _ => destruct x
  | x : hseq_cons _ _ |- _ => destruct x
  end.

Ltac analyze_cache :=
  match goal with
  | LOOKUP : Concrete.cache_lookup ?cache _ ?mvec = Some ?rvec,
    PC     : getm _ ?pc = Some ?i@_,
    INST   : decode_instr ?i = Some _,
    INUSER : is_true (in_user (Concrete.State _ _ _ ?pc@_ _)),
    CACHE  : cache_correct ?cache ?cmem |- _ =>
    first [
        assert (CACHEHIT := analyze_cache CACHE LOOKUP INUSER);
        simpl in CACHEHIT;
        repeat match type of CACHEHIT with
        | exists _, _ => destruct CACHEHIT as [? CACHEHIT]
        | _ /\ _ => destruct CACHEHIT as [? CACHEHIT]
        | _ \/ _ => destruct CACHEHIT as [CACHEHIT | CACHEHIT]
        | and3 _ _ _ => destruct CACHEHIT
        | and4 _ _ _ _ => destruct CACHEHIT
        | False => destruct CACHEHIT
        end;
        try contradict_in_user; destruct_hseq; match_inv; simpl in *
      | failwith "analyze_cache hit" ]
  | INUSER : is_true (in_user (Concrete.miss_state ?st ?mvec)) |- _ =>
    first [ destruct (negP (miss_state_not_user st mvec) INUSER) |
            failwith "analyze_cache miss" ]
  end.

Ltac relate_register_get :=
  match goal with
  | REFR : refine_registers ?areg ?creg ?cmem,
    GET : getm ?creg ?r = Some _@?t,
    DEC : decode Symbolic.R ?cmem ?t = Some _ |- _ =>
    match goal with
    | GET' : getm areg r = Some _ |- _ => fail 1
    | |- _ => first [ pose proof (proj1 REFR _ _ _ _ DEC GET) |
                      failwith "relate_register_get" ]
    end
  end.

Ltac relate_memory_get :=
  match goal with
  | MEM : getm ?cmem ?addr = Some _@?t,
    REFM : refine_memory ?smem ?cmem,
    DEC : decode Symbolic.M ?cmem ?t = Some (User _) |- _ =>
    match goal with
    | _ : getm smem addr = Some _ |- _ => fail 1
    | |- _ => idtac
    end;
    first [ pose proof (proj1 REFM _ _ _ _ DEC MEM) |
            failwith "relate_memory_get" ]
  end.

Ltac relate_register_upd :=
  match goal with
  | GET : getm ?reg ?r = Some _@?t,
    DEC : decode Symbolic.R ?cmem ?t = Some _,
    UPD : updm ?reg ?r ?v@?t' = Some ?reg',
    DEC' : decode Symbolic.R ?cmem ?t' = Some _,
    REFR : refine_registers _ ?reg ?cmem,
    MINV : monitor_invariant_statement ?mi ?cmem _ _ _ |- _ =>
    first [ destruct (refine_registers_upd REFR GET DEC UPD DEC') as [? ? ?];
            pose proof (monitor_invariant_upd_reg MINV GET DEC UPD DEC')
          | failwith "relate_register_upd" ]
  end.

Ltac relate_memory_upd :=
  match goal with
  | GET : getm ?cmem ?addr = Some _@?t,
    DEC : decode Symbolic.M ?cmem ?t = Some (User _),
    UPD : updm ?cmem ?addr _@?t' = Some _,
    DEC' : decode Symbolic.M ?cmem ?t' = Some (User _),
    CACHE : cache_correct _ ?cmem,
    REFR : refine_registers _ _ ?cmem,
    REFM : refine_memory _ ?cmem,
    WFENTRYPOINTS : wf_entry_points _ ?cmem,
    MVEC : mvec_in_monitor ?cmem |- _ =>
    first [ destruct (refine_memory_upd CACHE REFR REFM GET DEC UPD DEC') as [? [? ? ?]];
            pose proof (wf_entry_points_user_upd WFENTRYPOINTS GET DEC UPD DEC');
            pose proof (mvec_in_monitor_user_upd MVEC GET DEC UPD DEC')
          | failwith "relate_memory_upd" ]
  end.

Ltac update_decodings :=
  match goal with
  | DEC : decode ?k ?cmem ?ct = Some ?ut,
    UPD : updm ?cmem _ _ = Some ?cmem' |-
    decode ?k ?cmem' ?ct = Some ?ut =>
    first [ solve [ rewrite /= -DEC (updm_set UPD);
                    erewrite decode_monotonic; eauto ] |
            failwith "update_decodings" ]
  end.

Ltac find_and_rewrite :=
  match goal with
  | H : ?x = _ |- context[?x] =>
    rewrite H; clear H; simpl
  end.

Ltac simplify_eqs :=
  match goal with
  | E1 : ?x = ?y1,
    E2 : ?x = ?y2 |- _ =>
    rewrite E1 in E2;
    inversion E2; subst; clear E2
  end.

Ltac solve_step :=
  solve [
      s_econstructor (
          solve [eauto;
                 repeat autounfold;
                 repeat simplify_eqs;
                 repeat (find_and_rewrite; simpl);
                 reflexivity])
    | failwith "solve_step" ].

Ltac solve_refine_state :=
  solve [ econstructor; eauto; try update_decodings
        | failwith "solve_refine_state" ].

Lemma refine_ivec_inv sst cst cmvec ivec :
  refine_state mi table sst cst ->
  build_cmvec cst = Some cmvec ->
  decode_ivec e (Concrete.mem cst) cmvec = Some ivec ->
  build_ivec table sst = Some ivec.
Proof.
  move=> Href Hbuild /decode_ivec_inv /=.
  case: ivec => [[op|] tpc ti ts]; last first.
    case=> [Hop Hdec_tpc Hdec_ti].
    rewrite (build_cmvec_ctpc Hbuild) in Hdec_tpc.
    have [i [instr [Hget Hdec_i Hop']]] := build_cmvec_cop_cti Hbuild.
    move: Hop. rewrite -{}Hop'.
    case: instr Hdec_i => // /is_nopP Hdec_i _.
    have [sc Hget_sc Hsct] := wf_entry_points_only_if (rs_entry_points Href)
                                                      Hget Hdec_ti Hdec_i.
    rewrite /build_ivec (rs_pc Href).
    case Hget': (getm _ _) => [[i' ti']|] //=.
      have [cti] := proj2 (rs_refm Href) _ _ _ Hget'.
      rewrite Hget => Hdec_ti' [? ?]. subst i' cti.
      by rewrite Hdec_ti' in Hdec_ti.
    rewrite (rs_pct Href) in Hdec_tpc.
    case: Hdec_tpc => ->. rewrite Hget_sc Hsct.
    by rewrite [in RHS]hseq0.
  case=> [Hop Hpriv Hdec_tpc Hdec_ti Hdec_ts].
  move: ti ts Hdec_ti Hdec_ts; rewrite {}Hop => ti ts Hdec_ti Hdec_ts.
  rewrite (build_cmvec_ctpc Hbuild) (rs_pct Href) in Hdec_tpc.
  case: Hdec_tpc => ?. subst tpc.
  have [i [instr [Hget_i Hdec_i Hop']]] := build_cmvec_cop_cti Hbuild.
  move: ts Hdec_ts; rewrite -{}Hop'=> ts Hdec_ts.
  move: Hbuild.
  rewrite /build_cmvec /build_ivec (rs_pc Href) Hget_i Hdec_i.
  rewrite (proj1 (rs_refm Href) _ _ _ _ Hdec_ti Hget_i) Hdec_i /=.
  destruct Href, instr, cmvec; move=> Hbuild; simpl in *; match_inv;
  repeat match goal with
  | x : hseq_nil |- _ => destruct x
  | x : hseq_cons _ _ |- _ => destruct x
  | x : atom _ _ |- _ => destruct x
  | H : Some _ = Some _ |- _ => inv H
  end; simpl in *; match_inv;
  repeat relate_register_get;
  repeat relate_memory_get;
  trivial; repeat find_and_rewrite; by trivial.
Qed.

Lemma cache_hit_simulation sst cst cst' :
  refine_state mi table sst cst ->
  hit_step cst cst' ->
  exists2 sst',
    Symbolic.step table sst sst' &
    refine_state mi table sst' cst'.
Proof.
  case: sst => smem sregs [pc atpc] int.
  move => [/= PC DEC REFM REFR CACHE MVEC WFENTRYPOINTS MINV] [INUSER INUSER' STEP].
  rewrite /Symbolic.pcv /= in PC. subst pc.
  inv STEP; subst mv;
  unfold Concrete.next_state_reg, Concrete.next_state_reg_and_pc,
         Concrete.next_state_pc, Concrete.next_state in *;
  simpl in *;
  try rewrite KER in NEXT; simpl in *;

  match_inv;

  analyze_cache;

  repeat relate_register_get;

  repeat relate_memory_get;

  try relate_register_upd;

  try relate_memory_upd;

  (eexists; [ solve_step | solve_refine_state ]).

Qed.

Lemma initial_handler_state cst kst cmvec :
  forall (CMVEC : build_cmvec cst = Some cmvec)
         (MISS : Concrete.cache_lookup (Concrete.cache cst) masks cmvec = None)
         (STEP : Concrete.step _ masks cst kst),
      kst = Concrete.State (Concrete.store_mvec (Concrete.mem cst) cmvec)
                             (Concrete.regs cst)
                             (Concrete.cache cst)
                             (Concrete.fault_handler_start mt)@Concrete.TMonitor
                             (Concrete.pc cst).
Proof.
  move=> BUILD LOOKUP /step_lookup_success_or_fault.
  rewrite BUILD.
  case=> [cmvec' [[<-]]] {cmvec'}.
  by rewrite LOOKUP.
Qed.

Lemma monitor_user_exec_determ k s1 s2 :
  monitor_user_exec k s1 ->
  monitor_user_exec k s2 ->
  s1 = s2.
Proof.
  unfold monitor_user_exec. intros EXEC1 EXEC2.
  eapply exec_until_determ; eauto.
  - clear. intros s s1 s2.
    do 2 rewrite <- concrete.exec.stepP in *. congruence.
  - clear. by move=> s /= ->.
  - clear. by move=> s /= ->.
Qed.

Lemma user_monitor_user_step_determ s s1 s2 :
  user_monitor_user_step s s1 ->
  user_monitor_user_step s s2 ->
  s1 = s2.
Proof.
  move => [s' USER1 STEP1 EXEC1] [s'' USER2 STEP2 EXEC2].
  have E: (s' = s'') by rewrite <- concrete.exec.stepP in *; congruence. subst s''.
  eauto using monitor_user_exec_determ.
Qed.

Lemma build_cmvec_cache_lookup_pc cst cst' cmvec crvec :
  Concrete.step _ masks cst cst' ->
  build_cmvec cst = Some cmvec ->
  Concrete.cache_lookup (Concrete.cache cst) masks cmvec = Some crvec ->
  taga (Concrete.pc cst') = Concrete.ctrpc crvec.
Proof.
  move=> STEP BUILD LOOKUP.
  move/step_lookup_success_or_fault: STEP.
  rewrite BUILD.
  case=> cmvec' [[<-]] {cmvec'}.
  by rewrite LOOKUP.
Qed.

Lemma monitor_cache_lookup_fail (cst cst' : Concrete.state mt) cmvec :
  in_user cst ->
  in_monitor cst' ->
  Concrete.step _ masks cst cst' ->
  ~~ cache_allows_syscall table cst ->
  wf_entry_points table (Concrete.mem cst) ->
  cache_correct (Concrete.cache cst) (Concrete.mem cst) ->
  build_cmvec cst = Some cmvec ->
  Concrete.cache_lookup (Concrete.cache cst) masks cmvec = None.
Proof.
  move=> INUSER INMONITOR STEP NOTALLOWED WFENTRYPOINTS CACHECORRECT BUILD.
  move/step_lookup_success_or_fault: STEP NOTALLOWED.
  rewrite /cache_allows_syscall BUILD.
  case=> cmvec' [[<-]] {cmvec'}.
  case LOOKUP: (Concrete.cache_lookup _ _ _) => [[ctrpc ctr]|] //= E. subst ctrpc.
  case GETSC: (getm table _) => [sc|] //=.
  move: INMONITOR LOOKUP.
  rewrite /in_monitor /Concrete.is_monitor_tag => /eqP -> LOOKUP _.
  rewrite /in_user /= -(build_cmvec_ctpc BUILD) in INUSER.
  case/(_ cmvec _ LOOKUP INUSER): CACHECORRECT => ivec [ovec [/decode_ivec_inv DECi DECo _]].
  case: ivec DECi ovec DECo => [[op|] tpc ti ts] /= => [[E Hpriv _ _ _]|[DECop _ DECti]].
    by rewrite {}E /decode_ovec /= decode_monitor_tag /= => ovec.
  suff : false by done.
  move: (build_cmvec_cop_cti BUILD) DECop => [i [instr [GETPC DECi <-]]] DECop.
  have {DECi} ISNOP : is_nop i by rewrite /is_nop {}DECi; case: instr DECop.
  move: (wf_entry_points_only_if WFENTRYPOINTS GETPC DECti ISNOP).
  by rewrite GETSC; case.
Qed.

Lemma cache_miss_simulation sst cst cst' :
  refine_state mi table sst cst ->
  ~~ cache_allows_syscall table cst ->
  user_monitor_user_step cst cst' ->
  refine_state mi table sst cst'.
Proof.
  case: sst => smem sregs [pc tpc] int.
  case: cst => cmem cregs cache [pc' ctpc] epc.
  move => REF NOTALLOWED [kst ISUSER STEP KEXEC].
  have KER : in_monitor kst = true.
  { destruct KEXEC as [? EXEC]. exact (restricted_exec_fst EXEC). }
  case: REF=> [//= PC DEC REFM REFR CACHECORRECT MVEC WFENTRYPOINTS MINV].
  rewrite /Concrete.pcv /= in PC. subst pc'.
  have ISUSER' : ~~ in_monitor cst' by case: KEXEC.
  have [cmvec Hcmvec] := step_build_cmvec STEP.
  have LOOKUP := monitor_cache_lookup_fail ISUSER KER STEP NOTALLOWED WFENTRYPOINTS CACHECORRECT Hcmvec.
  have H := initial_handler_state Hcmvec LOOKUP STEP.
  have EXEC : exec (Concrete.step _ masks) kst cst'.
    case: KEXEC => kst' EXEC _ STEP'.
    apply restricted_exec_weaken in EXEC.
    by apply restricted_exec_trans with kst'; eauto.
  subst kst. rewrite /= in STEP KEXEC EXEC KER LOOKUP.
  destruct (handler_correct_allowed_case_bwd MINV CACHECORRECT KEXEC)
      as (ivec & ovec & DECivec & TRANS & CACHE' & MVEC' &
          HPCT & HMEM & HREGS & HPC & WFENTRYPOINTS' & MINV').
  case: cst' {KEXEC EXEC} HPC CACHE'
             ISUSER' MVEC' HPCT HMEM HREGS WFENTRYPOINTS' MINV' =>
        cmem'' cregs'' cache' pc' ? /= -> {pc'} CACHE' ISUSER' MVEC' HPCT HMEM HREGS WFENTRYPOINTS' MINV'.
  econstructor; eauto.
  - by apply/HPCT.
  - split.
    + move=> w x ctg atg {DECivec DEC} /HPCT DEC GET.
      move: (HMEM w x ctg _ DEC) GET => H /H {H} ?.
      by eapply (proj1 REFM); eauto.
    + move=> w x atg /(proj2 REFM) {DEC} [ctg DEC GET].
      move: DEC (HMEM w x ctg _ DEC) GET => /HPCT DEC H /H {H} ? /=.
      by eauto.
  - split.
    + move=> r x ctg atg {DECivec DEC} /HPCT DEC GET.
      move: (HREGS r x ctg _ DEC) GET => H /H {H} ?.
      by eapply (proj1 REFR); eauto.
    + move=> r x atg /(proj2 REFR) {DEC} [ctg DEC GET].
      move: DEC (HREGS r x ctg _ DEC) GET => /HPCT DEC H /H {H} ? /=.
      by eauto.
Qed.

Lemma syscall_simulation sst cst cst' :
  refine_state mi table sst cst ->
  cache_allows_syscall table cst ->
  user_monitor_user_step cst cst' ->
  exists2 sst', Symbolic.step table sst sst' &
                refine_state mi table sst' cst'.
Proof.
  case: sst=> smem sregs [pc tpc] int.
  case: cst=> cmem cregs cache [pc' ctpc] epc.
  intros REF ALLOWED STEP.
  case: REF=> [//= PC DEC REFM REFR CACHE MVEC WFENTRYPOINTS MINV].
  rewrite /Concrete.pcv /= in PC. subst pc'.
  have [sc GETCALL]: (exists sc, table pc = Some sc).
  { rewrite /cache_allows_syscall in ALLOWED.
    case GETCALL: (table pc) ALLOWED => [sc|//] ALLOWED.
    by eauto. }
  destruct cst' as [cmem' creg' cache' [cpc' ctpc'] epc'].
  have := syscalls_correct_allowed_case_bwd MINV REFM REFR CACHE MVEC GETCALL
                                            DEC ALLOWED STEP.
  move/(_ mcc).
  intros (smem' & sregs' & stpc' & sint' & RUNSC &
          HPCT & REFM' & REFR' & CACHE' & MVEC' & WFENTRYPOINTS' & MINV').
  exists (Symbolic.State smem' sregs' cpc'@stpc' sint').
  - eapply Symbolic.step_syscall; eauto.
    eapply wf_entry_points_if in GETCALL; last by exact WFENTRYPOINTS.
    move: GETCALL => [i [ti [GETPC DECti ISNOP]]].
    case GET': (getm smem pc) => [[? ?]|] //.
    move: (proj2 REFM _ _ _ GET') => {GET' DEC} [ctg' DEC GET'].
    rewrite GETPC in GET'.
    move: GET' => [? H]. subst i ti.
    by rewrite DEC in DECti.
  - by econstructor; eauto.
Qed.

Lemma user_into_monitor sst cst cst' :
  refine_state mi table sst cst ->
  Concrete.step _ masks cst cst' ->
  ~~ in_user cst'->
  in_monitor cst'.
Proof.
  move=> REF STEP NUSER.
  move: (refine_state_in_user REF) => INUSER.
  case: REF => [? ? ? ? CACHE ? ? ?]. subst.
  move : (valid_pcs STEP CACHE INUSER) NUSER.
  rewrite /in_monitor /Concrete.is_monitor_tag /in_user.
  move => [[t ->]|->] //=.
Qed.

Definition refine_state_weak sst cst :=
  refine_state mi table sst cst \/
  exists cst0 kst,
    refine_state mi table sst cst0 /\
    Concrete.step _ masks cst0 kst /\
    monitor_exec kst cst.

Lemma backwards_simulation sst cst cst' :
  refine_state_weak sst cst ->
  Concrete.step _ masks cst cst' ->
  refine_state_weak sst cst' \/
  exists2 sst',
    Symbolic.step table sst sst' &
    refine_state mi table sst' cst'.
Proof.
  intros [REF | (cst0 & kst & REF & KSTEP & EXEC)] STEP.
  - have USER : in_user cst by eapply refine_state_in_user; eauto.
    have [USER'|USER'] := boolP (in_user cst').
    + right.
      eapply cache_hit_simulation; eauto.
      by constructor; auto.
    + left. right. do 2 eexists. do 2 (split; eauto).
      constructor.
      by eapply user_into_monitor; eauto.
  - have USER : in_user cst0 by eapply refine_state_in_user; eauto.
    have [KER'|KER'] := boolP (in_monitor cst').
    + left. right.
      do 2 eexists. do 2 (split; eauto).
      eapply restricted_exec_trans; eauto.
      have KER : in_monitor cst by eapply restricted_exec_snd in EXEC.
      eapply re_step; by eauto using user_into_monitor.
    + assert (EXEC' : user_monitor_user_step cst0 cst').
      { econstructor; eauto.
        econstructor; eauto using in_user_in_monitor. }
      case: (boolP (cache_allows_syscall table cst0)) => [ALLOWED | NOTALLOWED].
      * right. by eapply syscall_simulation; eauto.
      * left. left. by eapply cache_miss_simulation; eauto.
Qed.

Lemma monitor_step cst cst' ast kst cst0 :
  refine_state mi table ast cst0 ->
  Concrete.step ops rules.masks cst0 kst ->
  monitor_exec kst cst ->
  Concrete.step _ masks cst cst' ->
  in_monitor cst ->
  ~~ in_user cst' ->
  in_monitor cst'.
Proof.
  intros REF STEP EXEC STEP' INMONITOR INUSER.
  assert (REFW: refine_state_weak ast cst).
  { right. eauto. }
  generalize (backwards_simulation REFW STEP').
  intros [[REF' | (? & ? & ? & ? & KEXEC')] | [? _ REF']].
  - apply @refine_state_in_user in REF'. by rewrite REF' in INUSER.
  - by apply restricted_exec_snd in KEXEC'.
  - apply @refine_state_in_user in REF'. by rewrite REF' in INUSER.
Qed.

Theorem backwards_refinement sst cst cst' :
  refine_state mi table sst cst ->
  exec (Concrete.step _ masks) cst cst' ->
  in_user cst' ->
  exists2 sst',
    exec (Symbolic.step table) sst sst' &
    refine_state mi table sst' cst'.
Proof.
  intros REF EXEC USER'.
  have {REF} REF: refine_state_weak sst cst by left.
  move: sst REF.
  induction EXEC as [cst _|cst cst'' cst' _ STEP EXEC IH].
  - move => sst [? | REF]; first by eauto.
    destruct REF as (? & ? & ? & ? & EXEC).
    apply restricted_exec_snd in EXEC.
    apply in_user_in_monitor in USER'.
    by rewrite EXEC in USER'.
  - move => sst REF.
    have [REF' | [sst' SSTEP REF']] := backwards_simulation REF STEP;
      first by auto.
    have {REF'} REF': refine_state_weak sst' cst'' by left.
    move: (IH USER' _ REF') => {IH USER' REF'} [sst'' EXEC' REF'].
    eexists; last by eauto.
    eapply re_step; trivial; eauto.
Qed.

End Refinement.


Require Import Classical List Relations Peano_dec.
Require Import Hahn.
Require Import Basic RC11_Events RC11_Model RC11_Threads.

Set Implicit Arguments.
Remove Hints plus_n_O.

Section WriteBefore.

Variable G : execution.

Notation "'acts'" := G.(acts).
Notation "'lab'" := G.(lab).
Notation "'loc'" := (loc lab).
Notation "'val'" := (val lab).
Notation "'sb'" := G.(sb).
Notation "'rf'" := G.(rf).
Notation "'mo'" := G.(mo).
Notation "'sw'" := G.(sw).
Notation "'rmw'" := G.(rmw).
Notation "'rb'" := G.(rb).
Notation "'hb'" := G.(hb).
Notation "'data'" := G.(data).
Notation "'addr'" := G.(addr).
Notation "'ctrl'" := G.(ctrl).
Notation "'deps'" := G.(deps).
Notation "'eco'" := G.(eco).
Notation "'same_loc'" := G.(same_loc).
Notation "rel |loc" := (rel ∩ same_loc) (at level 1).
Notation "'psc'" := G.(psc).
Notation "'psc_base'" := G.(psc_base).
Notation "'psc_f'" := G.(psc_f).
Notation "'scb'" := G.(scb).

Notation "'E'" := G.(E).
Notation "'R'" := (R lab).
Notation "'W'" := (W lab).
Notation "'F'" := (F lab).
Notation "'RMW'" := (RMW lab).
Notation "'RW'" := (RW lab).
Notation "'FR'" := (FR lab).
Notation "'FW'" := (FW lab).
Notation "'Na'" := (Only_Na lab).
Notation "'Rlx'" := (Rlx lab).
Notation "'Rel'" := (Rel lab).
Notation "'Acq'" := (Acq lab).
Notation "'Acqrel'" := (Acqrel lab).
Notation "'Sc'" := (Sc lab).
Notation "type ~ mode" := (type ∩₁ mode) (at level 1).

Hypothesis NRMW: NO_RMW_EVENTS G.

Definition wb0 :=
  ⦗W⦘ ⨾ (rmw⁻¹ ⨾ rf⁻¹)＊ ⨾ (rf^? ⨾ hb|loc ⨾ rf⁻¹^? \  (rf ⨾ rmw)＊ ) ⨾ ⦗W⦘.
Definition wb :=  rf ⨾ rmw ∪ wb0.

Definition consistent_wb :=
  << WF   : Wf G >> /\
  << WB  : acyclic wb >> /\
  << AT   : functional (rf ⨾ rmw)  >> /\
  << SC   : acyclic psc >> /\
  << SBRF : acyclic (sb ∪ rf) >>.

Lemma con_wb_wf  (CON: consistent_wb) : Wf G.
Proof. cdes CON; done. Qed.

Hint Resolve con_wb_wf.

Lemma wb0_acta (WF: Wf G) : doma wb0 E.
Proof.
cdes WF; unfold wb0.
clear_equivs ⦗W⦘.
rewrite rtE at 1; relsf.
apply union_doma; [| by eauto 12 using rmw_actb with rel].
apply minus_doma.
rewrite inter_inclusion, crE; relsf.
eauto 12 using hb_acta, rf_acta, rmw_actb with rel.
Qed.

Lemma wb_acta (WF: Wf G) : (doma wb (fun x => In x acts)).
Proof.
cdes WF; unfold wb.
apply union_doma.
by eauto 12 using hb_acta, rf_acta, rmw_actb with rel.
by apply wb0_acta.
Qed.

Lemma wb0_actb (WF: Wf G) : (domb wb0 (fun x => In x acts)).
Proof.
cdes WF; unfold wb0.
arewrite_id (⦗W⦘); rels.
apply seq_domb.
apply minus_domb.
rewrite (crE rf⁻¹), inter_inclusion; relsf.
eauto 12 using hb_actb, rf_acta with rel.
Qed.

Lemma wb_actb (WF: Wf G) : (domb wb (fun x => In x acts)).
Proof.
cdes WF; unfold wb.
apply union_domb.
by eauto using rmw_actb with rel.
by apply wb0_actb.
Qed.

Lemma wb0_act (WF: Wf G) :
  wb0 ⊆ <| fun x => In x acts |> ⨾ wb0 ⨾ <| fun x => In x acts |>.
Proof.
eapply act_helper; split; [apply wb0_acta| apply wb0_actb]; done.
Qed.

Lemma wb_act (WF: Wf G) :
  wb ⊆ <| fun x => In x acts |> ⨾ wb ⨾ <| fun x => In x acts |>.
Proof.
eapply act_helper; split; [apply wb_acta| apply wb_actb]; done.
Qed.

Lemma rmw_functional (WF: Wf  G) :
   functional rmw.
Proof.
cdes WF; cdes WF_RMW; cdes WF_SB.
unfold functional; intros x y z H0 H1.
assert (Ix: I x) by eby eapply no_rmw_from_init.
hahn_rewrite RMW_IMM in H0.
hahn_rewrite RMW_IMM in H1.
apply sb_immediate_adjacent in H0; try done.
apply sb_immediate_adjacent in H1; try done.
desf.
eapply adjacent_uniqe1 with (r:=sb); try edone.
by apply trans_irr_acyclic.
Qed.

Lemma transp_rmw_functional (WF: Wf  G) :
   functional rmw⁻¹.
Proof.
cdes WF; cdes WF_RMW; cdes WF_SB.
unfold functional; intros x y z H0 H1.
unfold transp in *.
assert (Iy: I y) by eby eapply no_rmw_from_init.
assert (Iz: I z) by eby eapply no_rmw_from_init.
hahn_rewrite RMW_IMM in H0.
hahn_rewrite RMW_IMM in H1.
apply sb_immediate_adjacent in H0; try done.
apply sb_immediate_adjacent in H1; try done.
desf.
eapply adjacent_uniqe2 with (r:=sb); try edone.
by apply trans_irr_acyclic.
Qed.

Lemma rf_rmw_wb (WF: Wf G) (FUN: functional (rf ⨾ rmw)) :
  rmw⁻¹ ⨾ rf⁻¹ ⨾ wb ⊆ wb^?.
Proof.
unfold wb; relsf.
apply inclusion_union_l; rels.
- rewrite <- !seqA with (r1 := rmw⁻¹).
 rewrite <- transp_seq.
apply functional_alt in FUN; rewrite FUN; basic_solver.
- unfold wb0 at 1.
arewrite_id (⦗W⦘) at 1; rels.
cdes WF; cdes WF_RMW; rewrite RMW_DOM at 1.
clear_equivs ⦗R⦘; rels.
rewrite transp_seq; rels; rewrite !seqA.
rewrite <- !seqA with (r1 := rmw⁻¹).
rels.
arewrite ((rmw⁻¹⨾ rf⁻¹) ^+ ⊆ (rmw⁻¹⨾ rf⁻¹) ＊).
unfold wb0; eauto with rel.
Qed.

Lemma rfU_successor (WF: Wf G) (FUN: functional (rf ⨾ rmw)) :
    Successor wb^+ (rf ⨾ rmw).
Proof.
red; splits; auto.
- rewrite transp_seq.
  apply functional_seq; [apply transp_rmw_functional; auto | apply WF].
- rewrite transp_seq; rewrite seqA, ct_begin.
  sin_rewrite rf_rmw_wb; [rels| auto| auto].
- unfold wb; eauto with rel.
Qed.

Lemma wb_base:
⦗W⦘ ⨾ rf^? ⨾ hb|loc ⨾ (rf⁻¹)^? ⨾ ⦗W⦘
⊆
wb＊.
Proof.
arewrite (⦗W⦘⨾ rf ^?⨾ hb|loc ⨾ (rf⁻¹)^?⨾ ⦗W⦘ ⊆
 (⦗W⦘⨾ rf^?⨾ hb|loc ⨾ (rf⁻¹)^?⨾ ⦗W⦘ \(rf⨾rmw)＊) ∪ (rf⨾rmw)＊).
by eapply inclusion_union_minus.
unfold wb, wb0.
apply inclusion_union_l; [|eauto with rel].
arewrite (⦗W⦘⨾ rf ^?⨾ hb|loc ⨾ (rf⁻¹)^?⨾ ⦗W⦘ \(rf⨾ rmw) ＊ ⊆
  ⦗W⦘⨾ (rf ^?⨾ hb|loc ⨾ (rf⁻¹)^? \ (rf⨾ rmw) ＊) ⨾ ⦗W⦘).
by rewrite minus_eqv_rel_helper, !seqA.
arewrite (⦗W⦘ ⊆ ⦗W⦘⨾ (rmw⁻¹⨾ rf⁻¹) ＊) at 1.
rewrite rtE; relsf.
Qed.

Lemma mo_wb_coh (WF: Wf G) (SBRF : acyclic (sb ∪ rf))
  (WB: wb ⊆ mo) :
  irreflexive (hb ⨾ eco^?).
Proof.
rewrite eco_alt2; auto.
rewrite crE; relsf.
rewrite !irreflexive_union; splits.
- rewrite hb_in_sb_rf; auto.
- rewrite hb_in_sb_rf; [ |auto].
  arewrite (rf ⊆ (sb ∪ rf)) at 2; rels.
  arewrite ((sb ∪ rf)^+ ⊆ (sb ∪ rf)＊); rels.
- cdes WF; cdes WF_RF; cdes WF_MO.
  eapply funeq_irreflexive.
  by ins; eauto 10 with rel.
  rewrite MO_DOM.
  rewrite <- !seqA, irreflexive_seqC, <- !seqA, irreflexive_seqC, !seqA.
  rewrite <- !seqA with (r3 := mo).
  arewrite (⦗W⦘ ⨾ rf^? ⊆ ⦗W⦘ ⨾ rf^? ;; ⦗RW⦘).
  by rewrite RF_DOM at 1; solve_type_mismatch 10.
  arewrite ( (rf⁻¹)^? ⨾ ⦗W⦘ ⊆ ⦗RW⦘ ;;  (rf⁻¹)^? ⨾ ⦗W⦘).
  by rewrite RF_DOM at 1; unfold RC11_Events.RW; basic_solver 42.
  seq_rewrite restr_eq_rel_same_loc.
  sin_rewrite wb_base.
  rewrite WB; relsf.
Qed.

Lemma mo_wb_at (WF: Wf G)
  (SUC: Successor mo (rf ⨾ rmw)) :
  irreflexive (rb ⨾ mo ⨾ rmw⁻¹).
Proof.
rewrite NRMW_implies_original_rb; auto.
red in SUC; desc.
rewrite <- irreflexive_seqC, !seqA.
rewrite transp_seq, !seqA in SUC.
rewrite SUC.
cdes WF; cdes WF_MO.
relsf.
Qed.

Lemma two_rmws (WF: Wf G) (COH: irreflexive (hb ⨾ clos_refl eco))
  (AT: irreflexive (rb ⨾ mo ⨾ rmw⁻¹)) :
    functional (rf ⨾ rmw).
Proof.
red; unfold seq, transp; ins; desf; splits; auto.
assert (LOCz: exists l, loc z = Some l).
  eapply rw_has_location.
  eapply rmw_domb in H1; cdes WF; cdes WF_RMW; eauto.
  solve_type_mismatch.
desc.
cdes WF; cdes WF_RF; cdes WF_RMW.
assert (LOCy: loc y = Some l).
  apply RF_LOC in H; try done.
  apply RF_LOC in H0; try done.
  apply RMW_LOC in H1; try done.
  apply RMW_LOC in H2; try done.
  by congruence.
destruct (classic (y=z)) as [X|NEQ]; [eauto| exfalso].
cdes WF; cdes WF_MO; eapply MO_TOT in NEQ; eauto.
- desf; rewrite NRMW_implies_original_rb in AT; auto.
  * apply AT with (x:=z0).
    exists y; splits.
    repeat eexists; eauto.
    eapply rf_rmw_mo; eauto.
    exists z1; eauto.
    repeat eexists; eauto.
  * apply AT with (x:=z1).
    exists z; splits.
    repeat eexists; eauto.
    eapply rf_rmw_mo; eauto.
    exists z0; eauto.
    repeat eexists; eauto.
- unfolder; splits; eauto.
  eapply rmw_actb; eauto.
  eapply rmw_domb; eauto.
- unfolder; splits; eauto.
  eapply rmw_actb; eauto.
  eapply rmw_domb; eauto.
Qed.

Lemma mo_tot_helper (r: relation event)
  (WF: Wf G)
  (IRR: irreflexive r)
  (ACTS: r ⊆ ⦗E⦘ ⨾ (fun _ _ => True) ⨾ ⦗E⦘)
  (WW: r ⊆ ⦗W⦘⨾ (fun _ _ => True) ⨾ ⦗W⦘)
  (LOC: funeq loc r)
  (MO: irreflexive (r ⨾ mo)):
 r ⊆ mo.
Proof.
red; ins.
assert (exists l, loc x = Some l).
by eapply rw_has_location; apply WW in H; generalize H; solve_type_mismatch.
desc.
eapply tot_ex.
eapply WF.
unfolder; splits; eauto.
apply ACTS in H; generalize H; basic_solver.
apply WW in H; generalize H; basic_solver.
eby apply LOC in H;  rewrite <- H.
unfolder; splits; eauto.
apply ACTS in H; generalize H; basic_solver.
apply WW in H; generalize H; basic_solver.
generalize MO; basic_solver 10.
intro; subst; eapply IRR; eauto.
Qed.

Lemma transp_rmw_rf_mo (CON: consistent G) :
(rmw⁻¹⨾ rf⁻¹)⨾ mo ⊆ mo^? .
Proof.
rewrite crE.
apply inclusion_minus_l.
apply mo_tot_helper; auto.
basic_solver 10.
all: arewrite(fun __ => __ \ ⦗fun _ : event => True⦘ ⊆ __).
- cdes CON; cdes WF; cdes WF_SB; cdes WF_MO.
  rewrite rmw_in_sb; auto.
  rewrite SB_ACT, MO_ACT.
  basic_solver.
- cdes CON; cdes WF; cdes WF_RMW; cdes WF_MO.
  rewrite RMW_DOM, MO_DOM.
  basic_solver.
- cdes CON; cdes CON; cdes WF; cdes WF_RMW; cdes WF_RF; cdes WF_MO.
  eauto with rel.
- arewrite (rf⁻¹ ⨾ mo ⊆ rb).
    by cdes CON; apply NRMW_implies_original_rb.
  rotate 2.
  by cdes CON.
Qed.

Lemma transp_rmw_rf_mo1 (CON: consistent G) :
(rmw⁻¹⨾ rf⁻¹)⨾ (mo \ (rf⨾ rmw) ＊) ⊆ mo \ (rf⨾ rmw) ＊.
Proof.
rewrite fun_seq_minus_helper.
2: apply functional_seq; [apply transp_rmw_functional; auto | apply CON].
red; unfold minus_rel; ins;desc.
assert (MO: mo^? x y).
apply transp_rmw_rf_mo; eauto.
destruct MO.
* exfalso; subst; unfold seq in *; desf.
  apply H0; eauto.
  eexists; splits; eauto.
  econs; unfold transp in *; desf; eauto.
* splits; eauto.
  intro.
  apply H0.
  destruct H; desf.
  eexists; splits; eauto.
   unfold transp, seq in H; desf; eauto.
  eapply clos_trans_in_rt, t_step_rt.
  eexists; unfold seq; eauto.
Qed.

Lemma wb0_in_mo (CON: consistent G) : wb0 ⊆ mo \ (rf⨾ rmw) ＊.
Proof.
eapply rt_ind_left with (P:= fun __ => ⦗W⦘⨾ __⨾
  (rf ^?⨾ hb|loc ⨾ (rf⁻¹) ^? \ (rf⨾ rmw) ＊)⨾ ⦗W⦘).
- eauto with rel.
- rels.
arewrite ((rf ^?⨾ hb|loc ⨾ (rf⁻¹) ^?) \ (rf⨾ rmw) ＊ ⊆
(rf ^?⨾ hb|loc ⨾ (rf⁻¹) ^?) \ (rf⨾ rmw) ＊ \ (rf⨾ rmw) ＊).
rewrite minus_eqv_rel_helper.
apply inclusion_minus_mon; try done.
 eapply mo_tot_helper; eauto.
  * arewrite_id (⦗W⦘); rels.
     basic_solver.
  * transitivity wb0.
    unfold wb0.
    rewrite rtE with (r:=rmw⁻¹⨾ rf⁻¹); relsf.
    etransitivity; [eapply wb0_act; eauto| basic_solver].
  * basic_solver 10.
  * cdes CON; cdes WF; cdes WF_RF; cdes WF_RMW.
    eauto 10 using loceq_hb_loc with rel.
  * arewrite (fun __ => __\ (rf⨾ rmw) ＊ ⊆ __).
    arewrite_id !(⦗W⦘).
    rels.
    apply irreflexive_seqC.
    rewrite !crE; relsf.
    arewrite (rf⁻¹ ⨾ mo ⊆ rb) by cdes CON; apply NRMW_implies_original_rb.
    rewrite rb_in_eco, mo_in_eco, rf_in_eco; eauto.
    assert (transitive eco).
      by apply eco_trans; eauto.
    relsf.
    arewrite (eco ⊆ eco^?).
    rewrite inter_inclusion.
    by cdes CON.
- ins. rewrite !seqA.
 arewrite (rf⁻¹  ⊆ rf⁻¹ ⨾ ⦗W⦘) at 1.
      by cdes CON; cdes WF; generalize (rf_doma WF_RF); basic_solver 10.
    rewrite H.
    arewrite_id (⦗W⦘) at 1.
    rels.
  rewrite <- !seqA with (r1 := rmw⁻¹).
by apply transp_rmw_rf_mo1.
Qed.

Lemma wb_in_mo (CON: consistent G) : wb ⊆ mo.
Proof.
apply inclusion_union_l.
apply rf_rmw_mo; eauto; apply CON.
etransitivity; [apply wb0_in_mo; eauto | basic_solver].
Qed.

Lemma wb_consistency : consistent G -> consistent_wb.
Proof.
unfold consistent_wb.
intro CON.
 cdes CON; ins; desf; splits; eauto.
rewrite wb_in_mo; try done.
red; cdes WF; cdes WF_MO; relsf.
apply two_rmws; eauto.
Qed.

End WriteBefore.