Require Import Setoid PArith.
From hahn Require Import Hahn.
Require Import PromisingLib.
From Promising2 Require Import TView View Time Event Cell Thread Memory Configuration Local.

From imm Require Import Events.
From imm Require Import Execution.
From imm Require Import Execution_eco.
From imm Require Import imm_s_hb.
From imm Require Import imm_s.
From imm Require Import imm_bob imm_s_ppo.
From imm Require Import CombRelations.
From imm Require Import AuxDef.
From imm Require Import AuxRel2.

From imm Require Import TraversalConfig.
Require Import SimulationRel.
Require Import SimState.
Require Import MemoryAux.
Require Import MaxValue.
Require Import ViewRel.
From imm Require Import ViewRelHelpers.
Require Import Event_imm_promise.
Require Import ExtTraversalConfig.
Require Import ExtTraversal.
Require Import ExtTraversalProperties.
From imm Require Import TraversalProperties.
Require Import FtoCoherent.
Require Import SimulationRelProperties.
Require Import IntervalHelper.
Require Import AuxTime.

Set Implicit Arguments.

Section Aux.

Variable G : execution.
Variable WF : Wf G.
Variable sc : relation actid.

Notation "'acts'" := G.(acts).
Notation "'co'" := G.(co).
Notation "'sw'" := G.(sw).
Notation "'hb'" := G.(hb).
Notation "'sb'" := G.(sb).
Notation "'rf'" := G.(rf).
Notation "'rfi'" := G.(rfi).
Notation "'rfe'" := G.(rfe).
Notation "'rmw'" := G.(rmw).
Notation "'lab'" := G.(lab).
Notation "'msg_rel'" := (msg_rel G sc).
Notation "'urr'" := (urr G sc).
Notation "'release'" := G.(release).

Notation "'E'" := G.(acts_set).
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 "'Loc_' l" := (fun x => loc lab x = Some l) (at level 1).
Notation "'Tid_' t" := (fun x => tid x = t) (at level 1).
Notation "'W_'" := (fun l => W ∩₁ Loc_ l).
Notation "'FR'" := (fun x => F x \/ R x).
Notation "'FW'" := (fun x => F x \/ W x).

Notation "'W_ex'" := (W_ex G).
Notation "'W_ex_acq'" := (W_ex ∩₁ (fun a => is_true (is_xacq lab a))).

Notation "'Pln'" := (fun a => is_true (is_only_pln lab a)).
Notation "'Rlx'" := (is_rlx lab).
Notation "'Rel'" := (is_rel lab).
Notation "'Acq'" := (is_acq lab).
Notation "'Acqrel'" := (is_acqrel lab).
Notation "'Sc'" := (fun a => is_true (is_sc lab a)).

Hypothesis IMMCON : imm_consistent G sc.

Variable T : trav_config.
Variable S : actid -> Prop.
Hypothesis ETCCOH : etc_coherent G sc (mkETC T S).

Hypothesis RELCOV : W ∩₁ Rel ∩₁ issued T ⊆₁ covered T.

Variable f_to f_from : actid -> Time.t.
Hypothesis FCOH : f_to_coherent G S f_to f_from.

Variable thread : thread_id.
Variable PC : Configuration.t.
Variable local : Local.t.

Hypothesis SIM_TVIEW : sim_tview G sc (covered T) f_to local.(Local.tview) thread.
Hypothesis SIM_MEM : sim_mem G sc T f_to f_from thread local PC.(Configuration.memory).
Hypothesis INHAB : Memory.inhabited PC.(Configuration.memory).
Hypothesis PLN_RLX_EQ : pln_rlx_eq local.(Local.tview).
Hypothesis MEM_CLOSE : memory_close local.(Local.tview) PC.(Configuration.memory).

Hypothesis SIM_RES_MEM :
  sim_res_mem G T S f_to f_from thread local (Configuration.memory PC).

Hypothesis PROM_IN_MEM :
  forall thread' langst local
         (TID : IdentMap.find thread' PC.(Configuration.threads) =
                Some (langst, local)),
    Memory.le local.(Local.promises) PC.(Configuration.memory).

(* In the correspoding case, we don't reserve new events
   so the simulation would be able to proceed with the same timestamp mapping functions,
   i.e. f_to' = f_to /\ f_from' = f_from, but we need to guarantee that
   the new message is not immediately before others
   (specifically, reservations introduced by the capped memory).
 *)
Lemma exists_time_interval_for_issue_reserved_no_next
      w locw valw langst smode
      (WNISS : ~ issued T w)
      (ISSUABLE : issuable G sc T w)
      (SW : S w)
      (NONEXT : dom_sb_S_rfrmw G (mkETC T S) rfi (eq w) ⊆₁ ∅)
      (LOC : loc lab w = Some locw)
      (VAL : val lab w = Some valw)
      (WTID : thread = tid w)
      (RESERVED_TIME: reserved_time G T S f_to f_from smode PC.(Configuration.memory))
      (TID : IdentMap.find (tid w) PC.(Configuration.threads) = Some (langst, local)) :
  let promises := local.(Local.promises) in
  let memory   := PC.(Configuration.memory) in
  let T'       := mkTC (covered T) (issued T ∪₁ eq w) in
  let S'       := S ∪₁ eq w ∪₁ dom_sb_S_rfrmw G (mkETC T S) rfi (eq w) in
  exists p_rel, rfrmw_prev_rel G sc T f_to f_from PC.(Configuration.memory) w locw p_rel /\
    let f_to' := upd f_to w (Time.middle (f_from w) (f_to w)) in
    let rel'' :=
        if is_rel lab w
        then (TView.cur (Local.tview local))
        else (TView.rel (Local.tview local) locw)
    in
    let rel' := (View.join (View.join rel'' p_rel.(View.unwrap))
                           (View.singleton_ur locw (f_to' w))) in
    ⟪ RELWFEQ : View.pln rel' = View.rlx rel' ⟫ /\
    ⟪ REL_VIEW_LT : Time.lt (View.rlx rel'' locw) (f_to' w) ⟫ /\
    ⟪ REL_VIEW_LE : Time.le (View.rlx rel'  locw) (f_to' w) ⟫ /\

    ⟪ REQ_TO   : forall e (NEQ : e <> w), f_to' e = f_to e ⟫ /\
    ⟪ ISSEQ_TO : forall e (ISS : issued T e), f_to' e = f_to e ⟫ /\

    exists promises_cancel memory_cancel,
      ⟪ PCANCEL :
          Memory.remove promises locw (f_from w) (f_to w)
                        Message.reserve promises_cancel ⟫ /\
      ⟪ MCANCEL :
          Memory.remove memory locw (f_from w) (f_to w)
                        Message.reserve memory_cancel ⟫ /\

      exists promises_add memory_add,
        ⟪ PADD :
            Memory.add promises_cancel locw (f_from w) (f_to' w)
                       (Message.full valw (Some rel')) promises_add ⟫ /\
        ⟪ MADD :
            Memory.add memory_cancel locw (f_from w) (f_to' w)
                       (Message.full valw (Some rel')) memory_add ⟫ /\

        ⟪ INHAB : Memory.inhabited memory_add ⟫ /\
        ⟪ RELMCLOS : Memory.closed_timemap (View.rlx rel') memory_add ⟫ /\
        ⟪ RELVCLOS : Memory.closed_view rel' memory_add ⟫ /\

        ⟪ FCOH : f_to_coherent G S' f_to' f_from ⟫ /\

        ⟪ HELPER :
            sim_mem_helper
              G sc f_to' w (f_from w) valw
              (View.join (View.join (if is_rel lab w
                                     then (TView.cur (Local.tview local))
                                     else (TView.rel (Local.tview local) locw))
                                    p_rel.(View.unwrap))
                         (View.singleton_ur locw (f_to' w))) ⟫ /\

        ⟪ RESERVED_TIME :
            reserved_time G T' S' f_to' f_from smode memory_add ⟫.
Proof using WF IMMCON ETCCOH RELCOV FCOH SIM_TVIEW SIM_RES_MEM SIM_MEM INHAB PLN_RLX_EQ MEM_CLOSE PROM_IN_MEM.
  assert (sc_per_loc G) as SPL.
  { apply coherence_sc_per_loc. apply IMMCON. }
  assert (complete G) as COMPL by apply IMMCON.
  assert (tc_coherent G sc T) as TCCOH by apply ETCCOH.

  (* set (AA:=TSTEP). *)
  (* destruct AA as [_ ETCCOH']. *)

  assert (E w) as EW.
  { by apply ETCCOH.(etc_S_in_E). }
  assert (W w) as WW.
  { by apply (reservedW WF ETCCOH). }

  assert (~ covered T w) as WNCOV.
  { intros HH. apply WNISS.
    eapply w_covered_issued; [by apply ETCCOH|by split]. }
  assert (~ is_init w) as WNINIT.
  { intros HH. apply WNCOV. eapply init_covered; [by apply ETCCOH| by split]. }

  assert (W_ex w) as WEXW.
  { apply ETCCOH. by split. }

  assert ((E ∩₁ W ∩₁ Loc_ locw) w) as WEW.
  { split; [split|]; auto. }

  assert (codom_rel (rf ⨾ rmw) w) as [wprev PRMWE].
  { eapply W_ex_in_codom_rfrmw; eauto. }

  assert (E wprev) as EPREV.
  { apply WF.(wf_rfrmwE) in PRMWE. by destruct_seq PRMWE as [AA BB]. }
  assert (W wprev) as WPREV.
  { apply WF.(wf_rfrmwD) in PRMWE. by destruct_seq PRMWE as [AA BB]. }

  assert (wprev <> w) as NEQPREV.
  { intros HH; subst. eapply wf_rfrmw_irr; eauto. }

  assert (loc lab wprev = Some locw) as PREVLOC.
  { rewrite <- LOC. by apply WF.(wf_rfrmwl). }

  assert (issued T wprev) as ISSPREV.
  { assert ((issued T ∪₁ eq w) wprev) as AA.
    2: by destruct AA; desf.
    left. eapply (dom_rf_rmw_S_in_I WF ETCCOH).
    exists w. apply seqA. apply seq_eqv_r. split; auto. }
  assert (S wprev) as SPREV.
  { by apply ETCCOH.(etc_I_in_S). }

  assert (dom_rel (rf ⨾ rmw ⨾ ⦗eq w⦘) ⊆₁ issued T) as RFRMWISS.
  { rewrite <- seqA. intros a [b HH]. apply seq_eqv_r in HH. desc; subst.
    assert (a = wprev); subst; auto.
    eapply wf_rfrmwf; eauto. }

  assert (dom_rel (rf ⨾ rmw ⨾ ⦗eq w⦘) ⊆₁ S) as DRFRMWS.
  { rewrite RFRMWISS. apply ETCCOH. }
  assert (immediate (⦗S⦘ ⨾ co) wprev w) as IMMSPREV.
  { eapply (rfrmwP_in_immPco WF IMMCON) with (P':=eq w); auto.
    apply seqA. basic_solver. }

  assert (exists vprev, val lab wprev = Some vprev) as [vprev PREVVAL] by (by apply is_w_val).

  edestruct exists_wprev_rel with (w:=w) as [p_rel PRELSPEC]; eauto.

  exists p_rel. split.
  { apply PRELSPEC. }

  red in PRELSPEC.
  set (rel'' :=
         if Rel w
         then TView.cur (Local.tview local)
         else TView.rel (Local.tview local) locw).

  assert (Time.lt (f_from w) (f_to w)) as FFT by (by apply FCOH).
  assert (co wprev w) as COWPREV.
  { eapply rf_rmw_in_co; eauto. }

  set (f_to' := upd f_to w (Time.middle (f_from w) (f_to w))).
  assert (REQ_TO : forall e (NEQ : e <> w), f_to' e = f_to e).
  { ins. unfold f_to'. rewrite updo; auto. }
  assert (ISSEQ_TO : forall e (ISS : issued T e), f_to' e = f_to e).
  { ins. unfold f_to'. rewrite updo; auto. by intros HH; subst. }

  assert (Time.lt (f_to' wprev) (f_to w)) as PREVNLT.
  { rewrite REQ_TO; auto. eapply f_to_co_mon; eauto. }
  assert (Time.le (f_to' wprev) (f_from w)) as PREVNEF.
  { rewrite REQ_TO; auto. apply FCOH; eauto. }
  assert (Time.lt (f_to' wprev) (f_to' w)) as PREVNLT'.
  { unfold f_to' at 2. rewrite upds.
    eapply TimeFacts.le_lt_lt with (b:=f_from w); auto.
      by apply Time.middle_spec. }

  assert (Time.le (View.rlx rel'' locw)
                  (View.rlx (TView.cur (Local.tview local)) locw)) as GG.
  { unfold rel''. destruct (Rel w).
    { reflexivity. }
    subst. eapply rel_le_cur; eauto. }

  assert (Time.lt (View.rlx rel'' locw) (f_to' w)) as REL_VIEW_LT.
  { eapply TimeFacts.le_lt_lt; [by apply GG|].
    eapply TimeFacts.le_lt_lt; [|by apply PREVNLT'].
    rewrite REQ_TO; auto. eapply le_cur_f_to_wprev; eauto. }

  set (rel' := View.join (View.join rel'' (View.unwrap p_rel))
                         (View.singleton_ur locw (f_to' w))).
  assert (Time.le (View.rlx (View.unwrap p_rel) locw) (f_to' wprev)) as PREL_LE'.
  { rewrite REQ_TO; auto.
    eapply le_p_rel_f_to_wprev; eauto. }
  assert (Time.le (View.rlx (View.unwrap p_rel) locw) (f_to' w)) as PREL_LE.
  { desc.
    destruct PRELSPEC0; desc.
    { rewrite PREL. apply Time.bot_spec. }
    assert (p = wprev); subst.
    { eapply wf_rfrmwf; eauto. }
    apply Time.le_lteq. left.
    eapply TimeFacts.le_lt_lt.
    2: by apply PREVNLT'.
    done. }

  assert (Time.le (View.rlx rel' locw) (f_to' w)) as REL_VIEW_LE.
  { unfold rel'.
    unfold View.join, TimeMap.join. simpls.
    unfold TimeMap.singleton, LocFun.add.
    rewrite Loc.eq_dec_eq.
    apply Time.join_spec; [|reflexivity].
    apply Time.join_spec; auto.
    apply Time.le_lteq; auto. }

  assert (Memory.get locw (f_to w) (Local.promises local) =
          Some (f_from w, Message.reserve)) as PMSG.
  { eapply SIM_RES_MEM; eauto. }
  assert (exists promises_cancel,
             Memory.remove (Local.promises local) locw
                           (f_from w) (f_to w) Message.reserve promises_cancel)
    as [promises_cancel PCANCEL].
  { by apply Memory.remove_exists. }

  assert (Memory.get locw (f_to w) (Configuration.memory PC) =
          Some (f_from w, Message.reserve)) as MMSG.
  { eapply SIM_RES_MEM; eauto. }
  assert (exists memory_cancel,
             Memory.remove
               PC.(Configuration.memory) locw (f_from w) (f_to w)
                                         Message.reserve memory_cancel)
    as [memory_cancel MCANCEL].
  { by apply Memory.remove_exists. }

  assert (Time.lt (f_from w) (f_to' w)) as WFLT.
  { unfold f_to'. rewrite upds. by apply Time.middle_spec. }

  assert (View.pln rel' = View.rlx rel') as RELWFEQ.
  { unfold rel'. simpls. desc. rewrite REL_PLN_RLX.
    arewrite (View.pln rel'' = View.rlx rel'').
    2: reflexivity.
    unfold rel''. destruct (Rel w); apply PLN_RLX_EQ. }
  assert (View.opt_wf (Some rel')) as RELWF.
  { apply opt_wf_unwrap. simpls.
    constructor.
    arewrite (View.pln rel' = View.rlx rel').
    apply TimeMap.le_PreOrder. }

  simpls. splits; eauto.
  do 2 eexists. splits; eauto.

  assert (Message.wf (Message.full valw (Some rel'))) as MWF by (by constructor).

  assert (Interval.le (f_from w, f_to' w) (f_from w, f_to w)) as LENIOI.
  { unfold f_to'. rewrite upds. constructor; simpls.
    { reflexivity. }
    apply Time.le_lteq. left. by apply Time.middle_spec. }

  assert (exists promises_add,
             Memory.add promises_cancel locw
                        (f_from w) (f_to' w) (Message.full valw (Some rel'))
                        promises_add)
    as [promises_add PADD].
  { apply Memory.add_exists; auto.
    (* TODO: generalize to a lemma. *)
    ins.
    erewrite Memory.remove_o in GET2; eauto.
    destruct (loc_ts_eq_dec (locw, to2) (locw, f_to w)) as [LTEQ|LTNEQ].
    { simpls. desc; subst.
      rewrite (loc_ts_eq_dec_eq locw (f_to w)) in GET2. inv GET2. }
    rewrite loc_ts_eq_dec_neq in GET2; eauto.
    apply Interval.le_disjoint with (b:=(f_from w, f_to w)); auto.
    edestruct Memory.get_disjoint with (t1:=f_to w) (t2:=to2)
                                       (m:=Local.promises local); eauto.
    desf. }
  assert (exists memory_add,
             Memory.add memory_cancel locw
                        (f_from w) (f_to' w) (Message.full valw (Some rel'))
                        memory_add)
    as [memory_add MADD].
  { apply Memory.add_exists; auto.
    (* TODO: generalize to a lemma. *)
    ins.
    erewrite Memory.remove_o in GET2; eauto.
    destruct (loc_ts_eq_dec (locw, to2) (locw, f_to w)) as [LTEQ|LTNEQ].
    { simpls. desc; subst.
      rewrite (loc_ts_eq_dec_eq locw (f_to w)) in GET2. inv GET2. }
    rewrite loc_ts_eq_dec_neq in GET2; eauto.
    apply Interval.le_disjoint with (b:=(f_from w, f_to w)); auto.
    edestruct Memory.get_disjoint with (t1:=f_to w) (t2:=to2)
                                       (m:=PC.(Configuration.memory)); eauto.
    desf. }

  assert (Memory.inhabited memory_add) as INHABADD.
  { red. ins.
    erewrite Memory.add_o; eauto.
    erewrite Memory.remove_o; eauto.
    destruct (loc_ts_eq_dec (loc, Time.bot) (locw, f_to' w)) as [AA|LL']; simpls; desc; subst.
    { exfalso. eapply time_lt_bot with (a:=f_from w). rewrite AA0; auto. }
    rewrite !(loc_ts_eq_dec_neq LL').
    destruct (loc_ts_eq_dec (loc, Time.bot) (locw, f_to w)) as [AA|LL]; simpls; desc; subst.
    { exfalso. eapply time_lt_bot with (a:=f_from w). rewrite AA0; auto. }
    rewrite !(loc_ts_eq_dec_neq LL).
    apply INHAB. }

  assert (S ∪₁ eq w ∪₁ dom_sb_S_rfrmw G (mkETC T S) rfi (eq w) ≡₁ S) as NEWS.
  { arewrite (dom_sb_S_rfrmw G (mkETC T S) rfi (eq w) ≡₁ ∅).
    generalize SW. basic_solver. }

  assert (reserved_time G (mkTC (covered T) (issued T ∪₁ eq w))
                        S f_to' f_from smode memory_add) as REST.
  { destruct smode; [|by apply RESERVED_TIME].
    unfold f_to'.
    red. splits.
    3: { intros x y SX SY CO FF.
         destruct (classic (x = w)); subst.
         2: { rewrite REQ_TO in FF; auto. by apply RESERVED_TIME. }
         exfalso. rewrite upds in FF.
         eapply Time.lt_strorder with (x:=Time.middle (f_from w) (f_to w)).
         rewrite FF at 2.
         apply TimeFacts.lt_le_lt with (b:=f_to w).
         2: by apply FCOH.
           by apply Time.middle_spec. }
    all: red; ins; erewrite Memory.add_o in MSG; eauto.
    all: destruct (loc_ts_eq_dec (l, to) (locw, f_to' w)) as [LTEQ|LTNEQ'].
    { simpls. desc; subst. right. exists w. splits; eauto.
      { clear. basic_solver. }
      rewrite (loc_ts_eq_dec_eq locw (f_to' w)) in MSG. inv MSG. }
    { rewrite loc_ts_eq_dec_neq in MSG; eauto.
      erewrite Memory.remove_o in MSG; eauto.
      destruct (loc_ts_eq_dec (l, to) (locw, f_to w)) as [LTEQ|LTNEQ].
      { simpls. desc. subst. rewrite (loc_ts_eq_dec_eq locw (f_to w)) in MSG. inv MSG. }
      rewrite loc_ts_eq_dec_neq in MSG; eauto.
      eapply RESERVED_TIME in MSG. destruct MSG as [|MSG]; desc; subst; auto.
      right. exists b. splits; eauto.
        by left. }
    { simpls. desc; subst.
      rewrite (loc_ts_eq_dec_eq locw (f_to' w)) in MSG. inv MSG. }
    rewrite loc_ts_eq_dec_neq in MSG; eauto.
    erewrite Memory.remove_o in MSG; eauto.
    destruct (loc_ts_eq_dec (l, to) (locw, f_to w)) as [LTEQ|LTNEQ].
    { simpls. desc. subst. rewrite (loc_ts_eq_dec_eq locw (f_to w)) in MSG. inv MSG. }
    rewrite loc_ts_eq_dec_neq in MSG; eauto.
    eapply RESERVED_TIME in MSG.
    desc. subst.
    assert (b <> w) as NEQBW.
    { intros HH. subst. simpls.
      rewrite LOC0 in LOC. inv LOC.
      clear -LTNEQ. desf. }
    exists b. splits; eauto.
    intros [|AA]; desf. }

  assert (f_to_coherent G S f_to' f_from) as FCOH_NEW.
  { unfold f_to' in *.
    red. splits.
    { intros x []. rewrite REQ_TO; [|by intros HH; subst]. by apply FCOH. }
    { by apply FCOH. }
    all: ins; destruct (classic (x = w)); subst; [rewrite upds|rewrite updo; auto; by apply FCOH].
    { by apply Time.middle_spec. }
    { apply Time.le_lteq. left. apply TimeFacts.lt_le_lt with (b:=f_to w).
      { by apply Time.middle_spec. }
        by apply FCOH. }
    exfalso. apply WNISS. eapply dom_rf_rmw_S_in_I with (T:=mkETC T S); eauto.
    exists y. apply seqA. apply seq_eqv_r. by split. }

  assert (forall tmap (MCLOS : Memory.closed_timemap tmap PC.(Configuration.memory)),
             Memory.closed_timemap tmap memory_add) as MADDCLOS.
  { ins. eapply Memory.add_closed_timemap; eauto.
    eapply Memory.cancel_closed_timemap; eauto. }

  assert (Memory.closed_timemap (View.rlx rel') memory_add) as RELMCLOS.
  { unfold rel'. simpls.
    apply Memory.join_closed_timemap.
    2: { unfold TimeMap.singleton, LocFun.add, LocFun.find.
         red. ins. destruct (Loc.eq_dec loc locw) as [|LNEQ]; subst.
         { erewrite Memory.add_o; eauto. rewrite loc_ts_eq_dec_eq. eauto. }
         unfold LocFun.init.
         exists Time.bot, 0, None. apply INHABADD. }
    apply MADDCLOS.
    desc. apply Memory.join_closed_timemap; auto.
    unfold rel''.
    destruct (Rel w); simpls.
    all: apply MEM_CLOSE. }
  do 2 eexists. splits; eauto.
  { constructor; auto. simpls. by rewrite RELWFEQ. }
  { by rewrite NEWS. }
  { eapply sim_helper_issue with (S':=S); eauto. by apply ETCCOH. }
  eapply reserved_time_more.
  3: by apply NEWS.
  all: eauto.
  apply same_trav_config_refl.
Qed.

Lemma exists_time_interval_for_issue_reserved_with_next
      w locw valw langst wnext smode
      (SW : S w)
      (WNISS : ~ issued T w)
      (ISSUABLE : issuable G sc T w)
      (WNEXT : dom_sb_S_rfrmw G (mkETC T S) rfi (eq w) wnext)
      (LOC : loc lab w = Some locw)
      (VAL : val lab w = Some valw)
      (WTID : thread = tid w)
      (RESERVED_TIME: reserved_time G T S f_to f_from smode PC.(Configuration.memory))
      (TID : IdentMap.find (tid w) PC.(Configuration.threads) = Some (langst, local)) :
  let promises := local.(Local.promises) in
  let memory   := PC.(Configuration.memory) in
  let T'       := mkTC (covered T) (issued T ∪₁ eq w) in
  let S'       := S ∪₁ eq w ∪₁ dom_sb_S_rfrmw G (mkETC T S) rfi (eq w) in
  let n_to     := Time.middle (f_from w) (f_to w) in
  let f_to'    := upd (upd f_to w n_to) wnext (f_to w) in
  let f_from'  := upd f_from wnext n_to in

  exists p_rel, rfrmw_prev_rel G sc T f_to f_from PC.(Configuration.memory) w locw p_rel /\
    let rel'' :=
        if is_rel lab w
        then (TView.cur (Local.tview local))
        else (TView.rel (Local.tview local) locw)
    in
    let rel' := (View.join (View.join rel'' p_rel.(View.unwrap))
                           (View.singleton_ur locw (f_to' w))) in
    ⟪ RELWFEQ : View.pln rel' = View.rlx rel' ⟫ /\
    ⟪ REL_VIEW_LT : Time.lt (View.rlx rel'' locw) (f_to' w) ⟫ /\
    ⟪ REL_VIEW_LE : Time.le (View.rlx rel'  locw) (f_to' w) ⟫ /\

    exists promises_split memory_split,
      ⟪ PSPLIT :
          Memory.split local.(Local.promises) locw (f_from' w) (f_to' w) (f_to' wnext)
                       (Message.full valw (Some rel')) Message.reserve promises_split ⟫ /\
      ⟪ MSPLIT :
          Memory.split memory locw (f_from' w) (f_to' w) (f_to' wnext)
                       (Message.full valw (Some rel')) Message.reserve memory_split ⟫ /\

      ⟪ INHAB : Memory.inhabited memory_split ⟫ /\
      ⟪ RELMCLOS : Memory.closed_timemap (View.rlx rel') memory_split ⟫ /\
      ⟪ RELVCLOS : Memory.closed_view rel' memory_split ⟫ /\

      ⟪ FCOH : f_to_coherent G S' f_to' f_from' ⟫ /\

      ⟪ HELPER :
          sim_mem_helper
            G sc f_to' w (f_from' w) valw
            (View.join (View.join (if is_rel lab w
                                   then (TView.cur (Local.tview local))
                                   else (TView.rel (Local.tview local) locw))
                                  p_rel.(View.unwrap))
                       (View.singleton_ur locw (f_to' w))) ⟫ /\

      ⟪ RESERVED_TIME :
          reserved_time G T' S' f_to' f_from' smode memory_split ⟫.
Proof using WF IMMCON ETCCOH RELCOV FCOH SIM_TVIEW SIM_RES_MEM SIM_MEM INHAB PLN_RLX_EQ MEM_CLOSE PROM_IN_MEM.
  assert (sc_per_loc G) as SPL.
  { apply coherence_sc_per_loc. apply IMMCON. }
  assert (complete G) as COMPL by apply IMMCON.
  assert (tc_coherent G sc T) as TCCOH by apply ETCCOH.

  assert (E w) as EW.
  { by apply ETCCOH.(etc_S_in_E). }
  assert (W w) as WW.
  { by apply (reservedW WF ETCCOH). }

  assert (~ covered T w) as WNCOV.
  { intros HH. apply WNISS.
    eapply w_covered_issued; [by apply ETCCOH|by split]. }
  assert (~ is_init w) as WNINIT.
  { intros HH. apply WNCOV. eapply init_covered; [by apply ETCCOH| by split]. }

  assert (W_ex w) as WEXW.
  { apply ETCCOH. by split. }

  assert ((E ∩₁ W ∩₁ Loc_ locw) w) as WEW.
  { split; [split|]; auto. }

  assert (codom_rel (rf ⨾ rmw) w) as [wprev PRMWE].
  { eapply W_ex_in_codom_rfrmw; eauto. }

  assert (E wprev) as EPREV.
  { apply WF.(wf_rfrmwE) in PRMWE. by destruct_seq PRMWE as [AA BB]. }
  assert (W wprev) as WPREV.
  { apply WF.(wf_rfrmwD) in PRMWE. by destruct_seq PRMWE as [AA BB]. }

  assert (wprev <> w) as NEQPREV.
  { intros HH; subst. eapply wf_rfrmw_irr; eauto. }

  assert (loc lab wprev = Some locw) as PREVLOC.
  { rewrite <- LOC. by apply WF.(wf_rfrmwl). }

  assert (issued T wprev) as ISSPREV.
  { assert ((issued T ∪₁ eq w) wprev) as AA.
    2: by destruct AA; desf.
    left. eapply (dom_rf_rmw_S_in_I WF ETCCOH).
    exists w. apply seqA. apply seq_eqv_r. split; auto. }
  assert (S wprev) as SPREV.
  { by apply ETCCOH.(etc_I_in_S). }

  assert (dom_rel (rf ⨾ rmw ⨾ ⦗eq w⦘) ⊆₁ issued T) as RFRMWISS.
  { rewrite <- seqA. intros a [b HH]. apply seq_eqv_r in HH. desc; subst.
    assert (a = wprev); subst; auto.
    eapply wf_rfrmwf; eauto. }

  assert (dom_rel (rf ⨾ rmw ⨾ ⦗eq w⦘) ⊆₁ S) as DRFRMWS.
  { rewrite RFRMWISS. apply ETCCOH. }
  assert (immediate (⦗S⦘ ⨾ co) wprev w) as IMMSPREV.
  { eapply (rfrmwP_in_immPco WF IMMCON) with (P':=eq w); auto.
    apply seqA. basic_solver. }

  assert (exists vprev, val lab wprev = Some vprev) as [vprev PREVVAL] by (by apply is_w_val).

  edestruct exists_wprev_rel with (w:=w) as [p_rel PRELSPEC]; eauto.

  exists p_rel. split.
  { apply PRELSPEC. }

  red in PRELSPEC.
  set (rel'' :=
         if Rel w
         then TView.cur (Local.tview local)
         else TView.rel (Local.tview local) locw).

  assert (co wprev w) as COWPREV.
  { eapply rf_rmw_in_co; eauto. }
  assert (Time.lt (f_to wprev) (f_to w)) as PREVNLT_OLD.
  { eapply f_to_co_mon; eauto. }

  assert ((rf ⨾ rmw) w wnext) as RFRMWNEXT.
  { destruct WNEXT as [_ BB]. generalize BB. unfold Execution.rfi.
    clear. basic_solver. }
  assert (w <> wnext) as NEQ.
  { intros HH; subst. eapply wf_rfrmw_irr; eauto. }
  assert (co w wnext) as COWNEXT.
  { by apply rf_rmw_in_co. }
  assert (~ is_init wnext) as NINITNEXT.
  { apply no_co_to_init in COWNEXT; auto. by destruct_seq_r COWNEXT as AA. }
  assert (E wnext) as EWNEXT.
  { apply WF.(wf_coE) in COWNEXT. by destruct_seq COWNEXT as [AA BB]. }
  assert (~ S wnext) as NSNEXT.
  { intros HH. apply WNISS. eapply dom_rf_rmw_S_in_I with (T:=mkETC T S); eauto.
    exists wnext. apply seqA. apply seq_eqv_r. by split. }
  assert (~ issued T wnext) as NINEXT.
  { intros HH. apply NSNEXT. by apply ETCCOH.(etc_I_in_S). }
  assert (loc lab wnext = Some locw) as NLOC.
  { rewrite <- LOC. symmetry. by apply wf_rfrmwl. }

  set (n_to := Time.middle (f_from w) (f_to w)).
  set (f_to'   := upd (upd f_to w n_to) wnext (f_to w)).
  set (f_from' := upd f_from wnext n_to).

  assert (Time.lt (f_from w) (f_to w)) as WFLT by (by apply FCOH).
  assert (Time.lt (f_from w) (Time.middle (f_from w) (f_to w))) as FROMNTOLT.
  { by apply Time.middle_spec. }
  assert (Time.lt (Time.middle (f_from w) (f_to w)) (f_to w)) as NTOTOLT.
  { by apply Time.middle_spec. }

  assert (f_to wprev = f_from w) as PREVFEQ by (by apply FCOH).
  assert (Time.lt (f_to wprev) (f_to' w)) as PREVNLT.
  { unfold f_to'. rewrite updo; auto. rewrite upds.
    unfold n_to. eapply TimeFacts.le_lt_lt with (b:=f_from w); auto.
    rewrite PREVFEQ. apply DenseOrder_le_PreOrder. }

  assert (Time.le (View.rlx rel'' locw)
                  (View.rlx (TView.cur (Local.tview local)) locw)) as GG.
  { unfold rel''. destruct (Rel w).
    { reflexivity. }
    subst. eapply rel_le_cur; eauto. }

  assert (Time.lt (View.rlx rel'' locw) (f_to' w)) as REL_VIEW_LT.
  { eapply TimeFacts.le_lt_lt; [by apply GG|].
    eapply TimeFacts.le_lt_lt; [|by apply PREVNLT].
    eapply le_cur_f_to_wprev with (w:=w) (wprev:=wprev); eauto. }

  set (rel' := View.join (View.join rel'' (View.unwrap p_rel))
                         (View.singleton_ur locw (f_to' w))).
  assert (Time.le (View.rlx (View.unwrap p_rel) locw) (f_to wprev)) as PREL_LE'.
  { eapply le_p_rel_f_to_wprev with (w:=w) (wprev:=wprev); eauto. }
  assert (Time.le (View.rlx (View.unwrap p_rel) locw) (f_to' w)) as PREL_LE.
  { desc.
    destruct PRELSPEC0; desc.
    { rewrite PREL. apply Time.bot_spec. }
    assert (p = wprev); subst.
    { eapply wf_rfrmwf; eauto. }
    apply Time.le_lteq. left.
    eapply TimeFacts.le_lt_lt.
    2: by apply PREVNLT.
    done. }

  assert (Time.le (View.rlx rel' locw) (f_to' w)) as REL_VIEW_LE.
  { unfold rel'.
    unfold View.join, TimeMap.join. simpls.
    unfold TimeMap.singleton, LocFun.add.
    rewrite Loc.eq_dec_eq.
    apply Time.join_spec; [|reflexivity].
    apply Time.join_spec; auto.
    apply Time.le_lteq; auto. }

  assert (View.pln rel' = View.rlx rel') as RELWFEQ.
  { unfold rel'. simpls. desc. rewrite REL_PLN_RLX.
    arewrite (View.pln rel'' = View.rlx rel'').
    2: reflexivity.
    unfold rel''. destruct (Rel w); apply PLN_RLX_EQ. }
  assert (View.opt_wf (Some rel')) as RELWF.
  { apply opt_wf_unwrap. simpls.
    constructor.
    arewrite (View.pln rel' = View.rlx rel').
    apply TimeMap.le_PreOrder. }

  assert (Message.wf (Message.full valw (Some rel'))) as MWF by (by constructor).

  assert (Memory.get locw (f_to w) (Local.promises local) =
          Some (f_from w, Message.reserve)) as PMSG.
  { eapply SIM_RES_MEM; eauto. }
  assert (exists promises_split,
             Memory.split (Local.promises local) locw
                          (f_from' w) (f_to' w) (f_to' wnext)
                          (Message.full valw (Some rel'))
                          Message.reserve promises_split)
    as [promises_split PSPLIT].
  { unfold f_from'. rewrite updo; auto.
    unfold f_to'. rewrite upds. rewrite updo; auto. rewrite upds.
      by apply Memory.split_exists. }

  assert (Memory.get locw (f_to w) (Configuration.memory PC) =
          Some (f_from w, Message.reserve)) as MMSG.
  { eapply SIM_RES_MEM; eauto. }
  assert (exists memory_split,
             Memory.split PC.(Configuration.memory) locw
                          (f_from' w) (f_to' w) (f_to' wnext)
                          (Message.full valw (Some rel'))
                          Message.reserve memory_split)
    as [memory_split MSPLIT].
  { unfold f_from'. rewrite updo; auto.
    unfold f_to'. rewrite upds. rewrite updo; auto. rewrite upds.
      by apply Memory.split_exists. }

  assert (forall tmap (MCLOS : Memory.closed_timemap tmap PC.(Configuration.memory)),
             Memory.closed_timemap tmap memory_split) as MSPLITCLOS.
  { ins. eapply Memory.split_closed_timemap; eauto. }

  assert (Memory.inhabited memory_split) as INHABSPLIT.
  { red. ins.
    erewrite Memory.split_o; eauto.
    destruct (loc_ts_eq_dec (loc, Time.bot) (locw, Time.middle (f_from w) (f_to w)))
      as [AA|LL]; simpls; desc; subst.
    { exfalso. eapply time_lt_bot. rewrite AA0.
        by do 2 (apply Time.middle_spec with (lhs:=f_from w)). }
    unfold f_to'. rewrite upds. rewrite updo; auto. rewrite upds.
    rewrite !(loc_ts_eq_dec_neq LL).
    destruct (loc_ts_eq_dec (loc, Time.bot) (locw, f_to w))
      as [AA|LL']; simpls; desc; subst.
    { exfalso. eapply time_lt_bot. rewrite AA0. by apply FCOH. }
    rewrite !(loc_ts_eq_dec_neq LL').
    apply INHAB. }

  assert (dom_sb_S_rfrmw G (mkETC T S) rfi (eq w) ≡₁ eq wnext) as NEWS'.
  { eapply dom_sb_S_rfrmw_single; eauto. }

  assert (S ∪₁ eq w ∪₁ dom_sb_S_rfrmw G (mkETC T S) rfi (eq w) ≡₁ S ∪₁ eq wnext) as NEWS.
  { rewrite NEWS'. generalize SW. clear. basic_solver. }

  splits; eauto. eexists promises_split, memory_split.

  (* TODO: generalize to a lemma. *)
  assert (f_to_coherent
            G (S ∪₁ eq w ∪₁ dom_sb_S_rfrmw G {| etc_TC := T; reserved := S |} rfi (eq w))
            f_to' f_from') as FCOH'.
  { eapply f_to_coherent_more.
    2: by apply NEWS.
    all: eauto.
    red. splits; unfold f_to', f_from', n_to.
    1,2: intros x [IE EX].
    1,2: repeat (rewrite updo; [|by intros HH; desf]).
    1,2: by apply FCOH; split.
    { intros x [SX|] IE; subst.
      2: by rewrite !upds.
      do 2 (rewrite updo; [|by intros HH; desf]).
      destruct (classic (x = w)); subst.
      { by rewrite upds. }
      rewrite updo; auto. by apply FCOH. }
    { intros x y SX SY CO; subst.
      assert (x <> y) as NEQXY.
      { intros HH; subst. eapply co_irr; eauto. }
      destruct SX as [SX|]; destruct SY as [SY|]; subst.
      4: by exfalso; eapply co_irr; eauto.
      3: { rewrite upds. rewrite updo; auto.
           apply FCOH; eauto. eapply co_trans; eauto. }
      { rewrite updo; [|by intros HH; desf].
        rewrite updo with (a:=wnext); [|by intros HH; desf].
        destruct (classic (x = w)); subst.
        { rewrite upds.
          etransitivity.
          { apply Time.le_lteq.
            left. by apply Time.middle_spec with (lhs:=f_from w) (rhs:=f_to w). }
            by apply FCOH. }
        rewrite updo; auto. by apply FCOH. }
      rewrite upds. rewrite updo; auto.
      destruct (classic (x = w)); subst.
      { rewrite upds. apply DenseOrder_le_PreOrder. }
      rewrite updo; auto.
      etransitivity.
      2: { apply Time.le_lteq.
           left. by apply Time.middle_spec with (lhs:=f_from w) (rhs:=f_to w). }
      apply FCOH; auto.
      edestruct WF.(wf_co_total) with (a:=x) (b:=w); eauto.
      2: by exfalso; eapply rfrmw_in_im_co; eauto.
      split; [split|].
      { by apply ETCCOH.(etc_S_in_E). }
      { by apply (reservedW WF ETCCOH). }
      apply WF.(wf_col) in CO. rewrite CO.
      rewrite <- LOC. symmetry. by apply wf_rfrmwl. }
    intros x y SX SY CO; subst.
    assert (x <> y) as NEQXY.
    { intros HH; subst. eapply wf_rfrmw_irr; eauto. }
    cdes FCOH.
    destruct SX as [SX|]; destruct SY as [SY|]; subst; try done.
    3: { rewrite upds. rewrite updo; auto.
         exfalso. apply NSNEXT. eapply dom_rf_rmw_S with (T:=mkETC T S); eauto.
         exists y. apply seqA. apply seq_eqv_r. by split. }
    { rewrite updo; [|by intros HH; desf].
      rewrite updo with (a:=wnext); [|by intros HH; desf].
      destruct (classic (x = w)); subst.
      2: by rewrite updo; auto.
      exfalso.
      assert (y = wnext); [|by desf].
      eapply wf_rfrmwsf; eauto. }
    rewrite upds. rewrite updo; auto.
    assert (x = w); [|by subst; rewrite upds].
    eapply wf_rfrmwf; eauto. }

  assert (S ⊆₁ E ∩₁ W) as SEW.
  { apply set_subset_inter_r. split; [by apply ETCCOH|].
    apply (reservedW WF ETCCOH). }

  (* TODO: generalize to a lemma. *)
  assert (reserved_time G (mkTC (covered T) (issued T ∪₁ eq w))
                        (S ∪₁ eq w ∪₁ dom_sb_S_rfrmw G (mkETC T S) rfi (eq w))
                        f_to' f_from' smode memory_split) as REST.
  { eapply reserved_time_more.
    3: by apply NEWS.
    all: eauto.
    { apply same_tc. }
    destruct smode; simpls; desc.
    2: { splits.
         2: rewrite RMW_BEF_S; basic_solver 10.
         rewrite <- FOR_SPLIT.
         hahn_frame.
         clear. apply eqv_rel_mori.
         apply AuxRel.set_compl_mori. red.
         basic_solver 10. }
    splits.
    3: { intros x y SX SY CO; subst.
         assert (x <> y) as NEQXY.
         { intros HH; subst. eapply co_irr; eauto. }
         unfold f_to', f_from'.
         destruct SX as [SX|]; destruct SY as [SY|]; subst; try done.
         { repeat (rewrite updo with (a:=wnext); [|by intros HH; desf]).
           destruct (classic (x = w)) as [|NEQXW]; subst;
             [rewrite upds|by rewrite updo; auto].
           unfold n_to. intros HH.
           exfalso.
           apply no_co_to_init in CO; auto. destruct_seq_r CO as BB.
           edestruct to_from_disjoint_from with (w:=w) (w':=y) (I:=S) as [AA|AA]; eauto.
           { by apply wf_col. }
           { rewrite <- HH in AA. by eapply time_middle_lt_lhs; [|apply AA]. }
           rewrite <- HH in AA. by eapply time_middle_le_rhs; [|apply AA]. }
         { rewrite upds. rewrite updo; auto.
           destruct (classic (x = w)) as [|NEQXW]; subst; auto.
           rewrite updo; auto.
           unfold n_to. intros HH.
           exfalso.
           edestruct to_from_disjoint_to with (w:=w) (w':=x) (I:=S) as [AA|AA]; eauto.
           { red. rewrite LOC. symmetry. rewrite <- NLOC. by apply WF.(wf_col). }
           { rewrite HH in AA. by eapply time_middle_le_lhs; [|apply AA]. }
           rewrite HH in AA. by eapply time_middle_lt_rhs; [|apply AA]. }
         rewrite upds. rewrite updo; auto.
         intros HH.
         exfalso.
         apply TFRMW in HH; auto.
         2: { eapply co_trans; eauto. }
         apply NEQXY. eapply wf_rfrmwsf; eauto. }
    all: red; ins; erewrite Memory.split_o in MSG; eauto; unfold f_to', f_from' in *.
    all: rewrite updo in MSG; auto; rewrite upds in MSG.
    all: destruct (loc_ts_eq_dec (l, to) (locw, n_to)) as [LTEQ|LTNEQ].
    { simpls. desc; subst. right.
      rewrite (loc_ts_eq_dec_eq locw n_to) in MSG. inv MSG.
      exists w. splits; eauto.
      { by right. }
      rewrite updo; auto. by rewrite upds. }
    { rewrite loc_ts_eq_dec_neq in MSG; eauto.
      rewrite upds in MSG.
      destruct (loc_ts_eq_dec (l, to) (locw, f_to w)) as [LTEQ|LTNEQ'].
      { simpls. desc; subst.
        rewrite (loc_ts_eq_dec_eq locw (f_to w)) in MSG. inv MSG. }
      rewrite loc_ts_eq_dec_neq in MSG; auto.
      apply MEM in MSG. destruct MSG as [|MSG]; [left|right]; auto.
      desc. exists b.
      assert (S b) as SB by (by apply ETCCOH.(etc_I_in_S)).
      splits; eauto.
      { by left. }
      { by rewrite updo; [|by intros HH; desf]. }
        by repeat (rewrite updo; [|by intros HH; desf]). }
    { simpls. desc; subst.
      rewrite (loc_ts_eq_dec_eq locw n_to) in MSG. inv MSG. }
    rewrite loc_ts_eq_dec_neq in MSG; eauto.
    rewrite upds in MSG.
    destruct (loc_ts_eq_dec (l, to) (locw, f_to w)) as [LTEQ|LTNEQ'].
    { simpls. desc; subst.
      rewrite (loc_ts_eq_dec_eq locw (f_to w)) in MSG. inv MSG.
      exists wnext. rewrite !upds. splits; auto.
      { by right. }
      intros [A|A]; desf. }
    rewrite loc_ts_eq_dec_neq in MSG; auto. simpls.
    apply HMEM in MSG.
    desc.
    assert (b <> wnext) as BNEQ by (intros HH; desf).
    exists b. rewrite !updo with (a:=wnext); auto. splits; auto.
    { by left. }
    { intros [A|A]; desf. }
    destruct (classic (w = b)); subst.
    2: by rewrite updo; auto.
    exfalso. rewrite LOC in LOC0. inv LOC0. inv LTNEQ'. }

  assert (Memory.closed_timemap (View.rlx rel') memory_split) as RELMCLOS.
  { unfold rel'. simpls.
    apply Memory.join_closed_timemap.
    2: { unfold TimeMap.singleton, LocFun.add, LocFun.find.
         red. ins. destruct (Loc.eq_dec loc locw) as [|LNEQ]; subst.
         { erewrite Memory.split_o; eauto. rewrite loc_ts_eq_dec_eq. eauto. }
         unfold LocFun.init.
         exists Time.bot, 0, None. apply INHABSPLIT. }
    apply MSPLITCLOS.
    desc. apply Memory.join_closed_timemap; auto.
    unfold rel''.
    destruct (Rel w); simpls.
    all: apply MEM_CLOSE. }

  splits; eauto.
  { constructor; auto. simpls. unfold rel''0. by rewrite RELWFEQ. }
  eapply sim_helper_issue with
      (S':=S ∪₁ eq w ∪₁ dom_sb_S_rfrmw G {| etc_TC := T; reserved := S |} rfi (eq w)); eauto.
  3: { etransitivity; [by apply ETCCOH.(etc_I_in_S)|]. basic_solver. }
  2: basic_solver.
  unfold f_to'. ins. by repeat (rewrite updo; [|by intros HH; desf]).
Qed.

End Aux.


Require Import Coq.Lists.List.
Import ListNotations.
Require Import Tactics.
Require Import Sequence.
Require Import Relation.
Require Import Syntax.
Require Import Subst.
Require Import SimpSub.
Require Import Dynamic.
Require Import Promote.
Require Import Hygiene.
Require Import Rules.
Require Defs.
Require Import Obligations.
Require Import Morphism.
Require Import DefsEquiv.
Require Import Equivalence.
Require Import Equivalences.
Require Import Dots.

Require Import DerivedRules.
Require Import ValidationUtil.
Require Import Defined.

Require Import SumLemmas.
Require Import ValidationSigma.

Hint Rewrite def_inl def_inr def_sum def_sumcase : prepare.

Lemma sum_body_formation :
  forall G a b c d,
    tr G (deqtype a c)
    -> tr G (deqtype b d)
    -> tr (hyp_tm booltp :: G) (deqtype (bite (var 0) (subst sh1 a) (subst sh1 b)) (bite (var 0) (subst sh1 c) (subst sh1 d))).
Proof.
intros G a b c d Hac Hbd.
apply tr_booltp_elim_eqtype.
  {
  eapply hypothesis; eauto using index_0.
  }

  {
  eapply (weakening _ [_] []).
    {
    cbn [length unlift].
    simpsub.
    auto.
    }

    {
    cbn [length unlift].
    simpsub.
    auto.
    }
  cbn [length unlift].
  simpsub.
  auto.
  }

  {
  eapply (weakening _ [_] []).
    {
    cbn [length unlift].
    simpsub.
    auto.
    }

    {
    cbn [length unlift].
    simpsub.
    auto.
    }
  cbn [length unlift].
  simpsub.
  auto.
  }
Qed.

Lemma sumForm_valid : sumForm_obligation.
Proof.
prepare.
intros G a b ext1 ext0 Ha Hb.
apply tr_sigma_formation.
  {
  apply tr_booltp_istype.
  }
apply sum_body_formation; auto.
Qed.

Lemma sumEq_valid : sumEq_obligation.
Proof.
prepare.
intros G a b c d ext1 ext0 Ha Hb.
apply tr_sigma_formation.
  {
  apply tr_booltp_istype.
  }
apply sum_body_formation; auto.
Qed.

Lemma sumFormUniv_valid : sumFormUniv_obligation.
Proof.
prepare.
intros G a b i ext1 ext0 Ha Hb.
apply tr_sigma_formation_univ.
  {
  apply (tr_univ_cumulative _ Defined.nzero); auto.
    {
    apply tr_booltp_formation_univ.
    }

    {
    apply tr_univ_formation_invert.
    eapply tr_inhabitation_formation; eauto.
    }

    {
    rewrite -> leqpagetp_nzero_equiv.
    apply tr_unittp_intro.
    }
  }
replace (univ (subst sh1 i)) with (subst1 (var 0) (univ (subst (sh 2) i))) by (simpsub; auto).
apply tr_booltp_elim.
  {
  eapply hypothesis; eauto using index_0.
  }

  {
  simpsub.
  eapply (weakening _ [_] []).
    {
    cbn [length unlift].
    simpsub.
    auto.
    }

    {
    cbn [length unlift].
    simpsub.
    auto.
    }
  cbn [length unlift].
  simpsub.
  cbn [List.app].
  exact Ha.
  }

  {
  simpsub.
  eapply (weakening _ [_] []).
    {
    cbn [length unlift].
    simpsub.
    auto.
    }

    {
    cbn [length unlift].
    simpsub.
    auto.
    }
  cbn [length unlift].
  simpsub.
  cbn [List.app].
  exact Hb.
  }
Qed.

Lemma sumEqUniv_valid : sumEqUniv_obligation.
Proof.
prepare.
intros G a b c d i ext1 ext0 Ha Hb.
apply tr_sigma_formation_univ.
  {
  apply (tr_univ_cumulative _ Defined.nzero); auto.
    {
    apply tr_booltp_formation_univ.
    }

    {
    apply tr_univ_formation_invert.
    eapply tr_inhabitation_formation; eauto.
    }

    {
    rewrite -> leqpagetp_nzero_equiv.
    apply tr_unittp_intro.
    }
  }
replace (univ (subst sh1 i)) with (subst1 (var 0) (univ (subst (sh 2) i))) by (simpsub; auto).
apply tr_booltp_elim.
  {
  eapply hypothesis; eauto using index_0.
  }

  {
  simpsub.
  eapply (weakening _ [_] []).
    {
    cbn [length unlift].
    simpsub.
    auto.
    }

    {
    cbn [length unlift].
    simpsub.
    auto.
    }
  cbn [length unlift].
  simpsub.
  cbn [List.app].
  exact Ha.
  }

  {
  simpsub.
  eapply (weakening _ [_] []).
    {
    cbn [length unlift].
    simpsub.
    auto.
    }

    {
    cbn [length unlift].
    simpsub.
    auto.
    }
  cbn [length unlift].
  simpsub.
  cbn [List.app].
  exact Hb.
  }
Qed.

Lemma sumSub_valid : sumSub_obligation.
Proof.
prepare.
intros G a b c d ext1 ext0 Hab Hcd.
apply tr_sigma_sub.
  {
  apply tr_subtype_intro; auto using tr_booltp_istype.
  eapply hypothesis; eauto using index_0.
  }

  {
  apply (tr_subtype_eta2 _ _ _ (bite (var 0) (subst (under 0 sh1) triv) (subst (under 0 sh1) triv)) (bite (var 0) (subst (under 0 sh1) triv) (subst (under 0 sh1) triv))).
  apply (tr_booltp_eta_hyp _ []).
    {
    simpsub.
    cbn [List.app].
    rewrite -> !equiv_bite_l.
    auto.
    }

    {
    simpsub.
    cbn [List.app].
    rewrite -> !equiv_bite_r.
    auto.
    }
  }

  {
  apply sum_body_formation.
    {
    eapply tr_subtype_formation_invert2.
    eapply tr_inhabitation_formation; eauto.
    }

    {
    eapply tr_subtype_formation_invert2.
    eapply tr_inhabitation_formation; eauto.
    }
  }
Qed.

Lemma sumIntro1Of_valid : sumIntro1Of_obligation.
Proof.
prepare.
intros G a b m ext1 ext0 Hb Hm.
apply tr_sigma_intro.
  {
  apply tr_booltp_intro_btrue.
  }

  {
  simpsub.
  rewrite -> equiv_bite_l.
  auto.
  }

  {
  apply sum_body_formation; auto.
  eapply tr_inhabitation_formation; eauto.
  }
Qed.

Lemma sumIntro1Eq_valid : sumIntro1Eq_obligation.
Proof.
prepare.
intros G a b m n ext1 ext0 Hb Hm.
apply tr_sigma_intro.
  {
  apply tr_booltp_intro_btrue.
  }

  {
  simpsub.
  rewrite -> equiv_bite_l.
  auto.
  }

  {
  apply sum_body_formation; auto.
  eapply tr_inhabitation_formation; eauto.
  }
Qed.

Lemma sumIntro1_valid : sumIntro1_obligation.
Proof.
prepare.
intros G a b ext0 m Hb Hm.
apply tr_sigma_intro.
  {
  apply tr_booltp_intro_btrue.
  }

  {
  simpsub.
  rewrite -> equiv_bite_l.
  auto.
  }

  {
  apply sum_body_formation; auto.
  eapply tr_inhabitation_formation; eauto.
  }
Qed.

Lemma sumIntro2Of_valid : sumIntro2Of_obligation.
Proof.
prepare.
intros G a b m ext1 ext0 Hb Hm.
apply tr_sigma_intro.
  {
  apply tr_booltp_intro_bfalse.
  }

  {
  simpsub.
  rewrite -> equiv_bite_r.
  auto.
  }

  {
  apply sum_body_formation; auto.
  eapply tr_inhabitation_formation; eauto.
  }
Qed.

Lemma sumIntro2Eq_valid : sumIntro2Eq_obligation.
Proof.
prepare.
intros G a b m n ext1 ext0 Hb Hm.
apply tr_sigma_intro.
  {
  apply tr_booltp_intro_bfalse.
  }

  {
  simpsub.
  rewrite -> equiv_bite_r.
  auto.
  }

  {
  apply sum_body_formation; auto.
  eapply tr_inhabitation_formation; eauto.
  }
Qed.

Lemma sumIntro2_valid : sumIntro2_obligation.
Proof.
prepare.
intros G a b ext0 m Hb Hm.
apply tr_sigma_intro.
  {
  apply tr_booltp_intro_bfalse.
  }

  {
  simpsub.
  rewrite -> equiv_bite_r.
  auto.
  }

  {
  apply sum_body_formation; auto.
  eapply tr_inhabitation_formation; eauto.
  }
Qed.

Lemma sumElimOf_valid : sumElimOf_obligation.
Proof.
prepare.
intros G a b c m p r ext2 ext1 ext0 Hm Hp Hr.
eapply tr_sumtype_elim; eauto.
Qed.

Lemma sumElimOfNondep_valid : sumElimOfNondep_obligation.
Proof.
prepare.
intros G a b c m p r ext2 ext1 ext0 Hm Hp Hr.
replace c with (subst1 m (subst sh1 c)) by (simpsub; auto).
eapply tr_sumtype_elim; eauto; simpsub; auto.
Qed.

Lemma sumElimEq_valid : sumElimEq_obligation.
Proof.
prepare.
intros G a b c m n p q r s ext2 ext1 ext0 Hab Hpq Hrs.
eapply tr_sumtype_elim; eauto.
Qed.

Lemma sumElim_valid : sumElim_obligation.
Proof.
prepare.
intros G a b c m ext0 p r Hm Hp Hr.
eapply tr_sumtype_elim; eauto.
Qed.

Lemma sumElimNondep_valid : sumElimNondep_obligation.
Proof.
prepare.
intros G a b c m p r Hm Hp Hr.
replace c with (subst1 m (subst sh1 c)) by (simpsub; auto).
eapply tr_sumtype_elim; eauto; simpsub; auto.
Qed.

Lemma sumElimIstype_valid : sumElimIstype_obligation.
Proof.
prepare.
intros G a b c e m ext2 ext1 ext0 Hab Hc He.
eapply tr_sumtype_elim_eqtype; eauto.
Qed.

Lemma sumElimEqtype_valid : sumElimEqtype_obligation.
Proof.
prepare.
intros G a b c d e f m n ext2 ext1 ext0 Hmn Hcd Hef.
eapply tr_sumtype_elim_eqtype; eauto.
Qed.

Lemma sumFormInv1_valid : sumFormInv1_obligation.
Proof.
prepare.
intros G a b ext0 Hsig.
unfold sumtype in Hsig.
so (tr_sigma_formation_invert2 _#5 Hsig) as Hab.
so (tr_generalize _#4 (tr_booltp_intro_btrue _) Hab) as Ha.
simpsubin Ha.
rewrite -> (steps_equiv _#3 (star_one _#4 (step_bite2 _#3))) in Ha.
auto.
Qed.

Lemma sumFormInv2_valid : sumFormInv2_obligation.
Proof.
prepare.
intros G a b ext0 Hsig.
unfold sumtype in Hsig.
so (tr_sigma_formation_invert2 _#5 Hsig) as Hab.
so (tr_generalize _#4 (tr_booltp_intro_bfalse _) Hab) as Hb.
simpsubin Hb.
rewrite -> (steps_equiv _#3 (star_one _#4 (step_bite3 _#3))) in Hb.
auto.
Qed.

Hint Rewrite def_intersect def_pi def_arrow : prepare.

Require Import NatLemmas.

Lemma sumcaseType_valid : sumcaseType_obligation.
Proof.
prepare.
intros G.
unfold Defs.sumcase.
apply tr_intersect_intro; auto using tr_nattp_formation.
simpsub.
apply tr_intersect_intro.
  {
  apply tr_univ_formation.
  unfold pagetp.
  eapply hypothesis; eauto using index_0.
  }
simpsub.
apply tr_intersect_intro.
  {
  apply tr_univ_formation.
  unfold pagetp.
  eapply hypothesis; eauto using index_0, index_S.
  }
simpsub.
apply tr_intersect_intro.
  {
  apply tr_univ_formation.
  unfold pagetp.
  eapply hypothesis; eauto using index_0, index_S.
  }
simpsub.
cbn [Nat.add].
simpsub.
apply tr_pi_intro.
  {
  apply tr_sumtype_formation.
    {
    eapply tr_formation_weaken.
    eapply hypothesis; eauto using index_0, index_S.
    simpsub.
    cbn [Nat.add].
    eauto.
    }

    {
    eapply tr_formation_weaken.
    eapply hypothesis; eauto using index_0, index_S.
    simpsub.
    cbn [Nat.add].
    eauto.
    }
  }
eapply tr_pi_intro.
  {
  eapply tr_pi_formation.
    {
    eapply tr_formation_weaken.
    eapply hypothesis; eauto using index_0, index_S.
    simpsub.
    cbn [Nat.add].
    eauto.
    }
  eapply tr_formation_weaken.
  eapply hypothesis; eauto using index_0, index_S.
  simpsub.
  cbn [Nat.add].
  eauto.
  }
eapply tr_pi_intro.
  {
  eapply tr_pi_formation.
    {
    eapply tr_formation_weaken.
    eapply hypothesis; eauto using index_0, index_S.
    simpsub.
    cbn [Nat.add].
    eauto.
    }
  eapply tr_formation_weaken.
  eapply hypothesis; eauto using index_0, index_S.
  simpsub.
  cbn [Nat.add].
  eauto.
  }
match goal with
| |- tr ?X _ =>
   change (tr X (deq (sumcase (var 2) (app (var 2) (var 0)) (app (var 1) (var 0))) (sumcase (var 2) (app (var 2) (var 0)) (app (var 1) (var 0))) (subst1 (var 2) (var 4))))
end.
eapply tr_sumtype_elim.
  {
  eapply hypothesis; eauto using index_0, index_S.
  simpsub.
  cbn [Nat.add].
  eauto.
  }

  {
  eapply tr_pi_elim'.
    {
    eapply hypothesis; eauto using index_0, index_S.
    simpsub.
    cbn [Nat.add].
    eauto.
    }

    {
    eapply hypothesis; eauto using index_0.
    }

    {
    simpsub.
    auto.
    }
  }

  {
  eapply tr_pi_elim'.
    {
    eapply hypothesis; eauto using index_0, index_S.
    simpsub.
    cbn [Nat.add].
    eauto.
    }

    {
    eapply hypothesis; eauto using index_0.
    }

    {
    simpsub.
    auto.
    }
  }
Qed.


(* PREAMBLE *)

From compcert.cfrontend          Require Csem.
From trancert.lib                Require All.
From trancert.invariants         Require Common EnvAppears EnvsFreeable EnvAppearsNot
                                         ForallExprInState EnvsFreeable.
From trancert.properties         Require Estate State Events.
From trancert.analysis           Require Genv.
From trancert.transformations    Require Specification LocalDeclarations.
From trancert                    Require simulations.Def .
From trancert.axioms             Require NoFreeLocals Biject.
From trancert.semantics          Require CsemAugmented.
From trancert.simulations.memory.bijection
                                 Require Def Env Continuation Context Symbols Semantics.
From trancert.simulations.tags   Require KcallLifted MatchExprImm MatchExprReds
                                         ContextCommute FunctionsMapped.

Import Csem lib.All Coqlib Csyntax Ctypes Events Values Memory Mem Errors invariants.Common
       transformations.Specification common.Events properties.Events common.Values properties.State
       Globalenvs Globalenvs.Genv analysis.Genv Def
       EnvAppearsNot EnvAppears EnvsFreeable
       ForallExprInState
       analysis.Program
       analysis.Function
       bijection.Symbols
       bijection.Semantics
       bijection.Def bijection.Env bijection.Continuation bijection.Context PTree bijection.AST
       LocalDeclarations .

Import KcallLifted MatchExprImm MatchExprReds ContextCommute FunctionsMapped.

Local Notation program := Csyntax.program.
Local Notation fundef   := Csyntax.fundef.
Local Notation ident    := AST.ident.
Local Notation function := Csyntax.function.
Local Notation type     := Ctypes.type.
Local Notation globalenv := Csem.genv.

Section Step.

  Context (p p': program) (refparams: LocalDeclarations.params).
  Let ge  := Csem.globalenv p.
  Let ge' := Csem.globalenv p'.

  (*Hypothesis Huniques: Program.distinct_functions p.
  Hypothesis Huniques': Program.distinct_functions p'.*)
  Hypothesis Hp: LocalDeclarations.spec refparams p p'.

  Hypothesis Hfreeable: axioms.NoFreeLocals.locals_stay_free_axiom.
  Hypothesis Hextcall_biject: axioms.Biject.biject_extcall_axiom.

  Record bisim_params : Type :=
    {
    bp_mapping: mapping
    }.

  Inductive R__env (b:bisim_params): fundef -> ident -> env -> env -> Prop :=
  | env_refactored:
      forall e1 e2,
        biject_env (bp_mapping b) (remove (var refparams) e1) e2 ->
        forall func, R__env b func (fn refparams) e1 e2
  | env_other:
      forall fid e1 e2,
        fid <> fn refparams ->
        biject_env (bp_mapping b) e1 e2 ->
        forall func, R__env b func fid e1 e2.

  Local Notation _with_embedding R:= (fun M => R (m_fwd M)) .

  Record R__mem (b: bisim_params) (m1 m2: mem) : Prop :=
    {
    rm_biject: biject (bp_mapping b) m1 m2 ;
    rm_symbols: symbols_biject (bp_mapping b) ge ge' ;
    rm_globals:  forall i def, find_def ge  i = Some def -> m_fwd (bp_mapping b) i = Some i ;
    rm_globals': forall i def, find_def ge' i = Some def -> m_fwd (bp_mapping b) i = Some i
    }.

  Let P__state p := env_appears_removed p (var refparams) (ty refparams) (fn refparams)
                                      /*\ state_env_freeable p
                                      /*\ forall_expr_in_state
                                      (fun f i e => i = fn refparams ->
                                               ~ Appears.appears_expr (var refparams) e )
                                      (fun f i C => i = fn refparams ->
                                               ~ Appears.appears_ctx (var refparams) C ) p .

  Let P'__state p' := env_appears_not_removed p' (var refparams) (fn refparams)
                                    /*\ state_env_freeable p'
                                    /*\ forall_expr_in_state
                                    (fun f i e => i = fn refparams ->
                                             ~ Appears.appears_expr (var refparams) e )
                                    (fun f i C => i = fn refparams ->
                                             ~ Appears.appears_ctx (var refparams) C ) p'.

  Program Definition bparams : Def.sim_rel p p' bisim_params :=
    {|
      Def.P__program := precond refparams;
      Def.P'__program := postcond refparams;
      Def.R__program := spec refparams;
      Def.match_fundef := LocalDeclarations.R__fundef refparams;
      Def.match_var := LocalDeclarations.R__var;
      Def.match_env := R__env;
      Def.match_cont := fun b fd fid => biject_econt (m_fwd (bp_mapping b))
                                          (fun f1 fid f2 => R__fundef refparams fid f1 f2)
                                          (R__env b)
      ;
      Def.match_stmt := fun b _ _ => biject_statement (m_fwd (bp_mapping b));
      Def.match_expr := fun b _ _=> biject_expr (m_fwd (bp_mapping b));
      Def.match_ctx := fun b _ _ => biject_context (m_fwd (bp_mapping b));
      Def.match_value := fun b _ _ => biject_value (m_fwd (bp_mapping b));
      Def.match_mem := fun b _ _ => R__mem b;
      Def.match_event := Logic.eq ;
      Def.P__state := P__state p;
      Def.P'__state := P'__state p';
      Def.P__mem := fun _ => True ;
      Def.P'__mem := fun _ => True ;
      Def.P__expr := fun f i e => i = fn refparams -> ~ Appears.appears_expr (var refparams) e ;
      Def.P'__expr := fun f i e => i = fn refparams -> ~ Appears.appears_expr (var refparams) e;
      Def.P__env := fun f i e => i = fn refparams -> exists b, e ! (var refparams) = Some(b, ty refparams);
      Def.P'__env := fun f i e => i = fn refparams -> e ! (var refparams) = None
    |}.
  Next Obligation.
    econstructor; eauto;
    inv Hp; eauto.
  Qed.
  Next Obligation.
    subst P__state. simpl in *. decomp.
    inv H2.
    eapply sc_expr; eauto.
  Qed.
  Next Obligation.
    subst P'__state. simpl in *. decomp.
    inv H2.
    eapply sc_expr; eauto.
  Qed.
  Next Obligation.
    subst P__state. simpl in *. decomp.
    eapply i_env_appears; eauto.
  Qed.
  Next Obligation.
    subst P'__state. simpl in *. decomp.
    eapply i_env_appears_not; eauto.
  Qed.

  Program Definition is_kcalllifted := Build_KcallLifted bparams _.
  Next Obligation.
    econstructor; simpl in *; eauto.
  Qed.

  Program Definition is_match_expr_imm := Build_MatchExprImm bparams _ _.
  Next Obligation.
    inv H.
    by inv H2; eauto.
  Qed.
  Next Obligation.
    by inv H; eauto.
  Qed.

  Program Definition is_functions_mapped: FunctionsMapped bparams := Build_FunctionsMapped bparams _ _ _ .
  Next Obligation.
    inv Hp.
    inv rs_correct.
    eapply list_forall2_in_left in pm_idents; eauto.
    decomp.
    destruct x.
    inv H1.
    by inv H3; eauto.
  Qed.
  Next Obligation.
    inv Hp.
    inv rs_correct.
    eapply list_forall2_in_right in pm_idents; eauto.
    decomp.
    destruct x.
    inv H1.
    by inv H3; eauto.
  Qed.
  Next Obligation.
    inv Hp.
    exploit Programs.match_program_defs; eauto.
    by inversion 1; subst.
  Qed.

  Program Definition is_match_expr_red: MatchExprReds bparams := Build_MatchExprReds bparams _ _ _ _ _ _ .
  Next Obligation. (* lred fwd *)
    clean.
    inv H3; inv H4; simpl in *; try inv_biject_expr.
    - inv H2. inv mcse_env.
      + edestruct H1 as (b' & Hb); eauto.
        destruct (AST.ident_eq x (var refparams)).
        * subst. by contradiction H; repeat econstructor.
        * simpl in *.
          inv H2.
          unfold Env.inject_env in *.
          edestruct be_fwd as (b0' & Hb' & Hh); eauto.
          { rewrite gro; eauto. }
          eapply meminj_embedding_some in Hh.
          eexists. exists m1', b.
          split; auto.
          split; auto; repeat (econstructor; eauto).
      + inv H3.
        unfold Env.inject_env in *.
        edestruct be_fwd as (b0' & Hb' & Hh); eauto.
        eapply meminj_embedding_some in Hh.
        simpl in *.
        eexists. exists m1', b.
        split; auto.
        split; auto.
        * econstructor; eauto.
          ** econstructor; eauto.
          ** econstructor 2; eauto.
             econstructor; eauto.
        * econstructor 1; eauto.
    - exists (Eloc b0 Integers.Ptrofs.zero ty), m1', b.
      inv H2. simpl in *.
      split; auto.
      have Hmap: (m_fwd (bp_mapping b) b0 = Some b0).
      {
        eapply gwf_sd_correspond in H5; last by apply globalenv_wf; inv Hp.
        decomp. eapply mcse_mem; eauto.
      }
      have Hsymb': (find_symbol ge' x = Some b0).
      {
        inv mcse_mem.
        inv rm_symbols0.
        edestruct sb_symb_fwd as (b1 & Hfwd & Hsymb'); eauto.
        by rewrite Hmap in Hfwd; autoinj.
      }
      inv mcse_env.
      + (* refactored function *)
        edestruct H1 as (b' & Hb); eauto.
        destruct (peq x (var refparams)); first by subst; congruence.
        split; auto.
        * repeat (econstructor; eauto).
        * eapply biject_env_none in H2; eauto.
          rewrite gro in H2; eauto.
          econstructor 2; eauto. by eapply H2.
      + (* any other function *)
        econstructor; eauto.
        * econstructor; eauto.
          ** econstructor; eauto.
          ** econstructor 2; eauto.
        * econstructor 2; eauto.
          eapply biject_env_none in H3; eauto.
          eapply H3; eauto.
    - simpl in *. repeat inv_biject_expr.
      inv H6.
      exists (Eloc b2 ofs ty), m1', b.
      split; auto.
      split; auto.
      econstructor; eauto.
      econstructor; eauto.
      econstructor; eauto.
    - repeat inv_biject_expr.
      inv H7.
      eexists. exists m1', b.
      split; auto.
      split; auto.
      econstructor; eauto.
      econstructor; eauto.
      econstructor 4 ; eauto.
      + simpl; inv Hp.
        erewrite Programs.pm_ce; eauto.
        eapply  Programs.match_program_symm; eauto.
      + simpl; inv Hp.
        erewrite Programs.pm_ce; eauto.
        eapply  Programs.match_program_symm; eauto.
    - repeat inv_biject_expr.
      inv H6.
      eexists. exists m1', b.
      split; auto.
      split; auto.
      econstructor; eauto.
      econstructor; eauto.
      econstructor 5 ; eauto.
      + simpl; inv Hp.
        erewrite Programs.pm_ce; eauto.
        eapply  Programs.match_program_symm; eauto.
  Qed.
  Next Obligation. (* lred bwd *)
    clean;
    inv H4; inv H3; inv H2; simpl in *; repeat inv_biject_expr.
    - inv mcse_env; simpl in *.
      + inv H2.
        destruct (AST.ident_eq x (var refparams)).
        * subst.  contradiction H; repeat econstructor; eauto.
        * simpl in *.
          unfold Env.inject_env in *.
          edestruct be_bwd as (b0' & Hb' & Hh); eauto.
          eapply meminj_embedding_some in Hh.
          apply (bp_mapping b) in Hh.
          eexists. exists m1, b.
          rewrite gro in Hb'; auto.
          split; auto.
          split; auto; repeat (econstructor; eauto).
      + inv H3.
        unfold Env.inject_env in *.
        edestruct be_bwd as (b0' & Hb' & Hh); eauto.
        eapply meminj_embedding_some in Hh.
        apply (bp_mapping b) in Hh.
        simpl in *.
        eexists. exists m1, b.
        split; auto.
        split; auto.
        * econstructor; eauto.
          ** econstructor; eauto.
          ** econstructor 2; eauto.
             econstructor; eauto.
        * econstructor 1; eauto.
    - exists (Eloc b0 Integers.Ptrofs.zero ty), m1, b.
      split; auto.
      inv mcse_mem.
      eapply (sb_symb_bwd _ _ _ rm_symbols0) in H4; eauto.
      decomp.
      apply (bp_mapping b) in H2.

      have Hmap: (m_fwd (bp_mapping b) x0 = Some x0).
      {
        eapply gwf_sd_correspond in H3; last by apply globalenv_wf; inv Hp.
        decomp. inv rm_symbols0.
        eapply rm_globals0; eauto.
      }
      rewrite H2 in Hmap; autoinj.
      inv mcse_env.
      + (* refactored function *)
        destruct (peq x (var refparams)); first by subst; contradiction H; auto; repeat econstructor.
        have Hev: (ev ! x = None).
        {
          eapply biject_env_none in H4; eauto.
          rewrite -> gro in *; eauto. by apply H4.
        }
        split.
        * repeat (econstructor; eauto).
        * econstructor 2; eauto.
      + (* any other function *)
        have Hev: (ev ! x = None) by (by eapply biject_env_none in H5; eauto; apply H5).
        econstructor; eauto.
        * econstructor; eauto.
          ** econstructor; eauto.
          ** econstructor 2; eauto.
          ** econstructor; eauto.
        * econstructor 2; eauto.
    - inv H4. simpl in *.
      exists (Eloc b1 ofs ty), m1, b.
      split; auto.
      split; auto.
      econstructor; eauto.
      econstructor; eauto.
      econstructor; eauto.
      econstructor; eauto.
      econstructor 3; eauto.
    - inv H6.
      eexists. exists m1, b.
      split; auto.
      split; auto.
      econstructor; eauto.
      econstructor; eauto.
      econstructor; eauto.
      econstructor; eauto.
      econstructor 4 ; eauto.
      + simpl; inv Hp.
        erewrite <- Programs.pm_ce; eauto.
        by eapply Programs.match_program_symm; eauto.
      + simpl; inv Hp.
        erewrite <- Programs.pm_ce; eauto.
        by eapply Programs.match_program_symm; eauto.
    - inv H5.
      eexists. exists m1, b.
      split; auto.
      split; auto.
      econstructor; eauto.
      econstructor; eauto.
      econstructor; eauto.
      econstructor; eauto.
      econstructor 5 ; eauto.
      + simpl; inv Hp.
        erewrite <- Programs.pm_ce; eauto.
        by eapply Programs.match_program_symm; eauto.
  Qed.
  Next Obligation. (* rred fwd *)
    clean.
    rename f into f'', f' into f. rename f'' into f'.
    inv H3; inv H2; simpl in *; repeat inv_biject_expr; inv mcse_mem.
    - (* red_rvalof*)
      eapply biject_deref_loc1 in H0; eauto; decomp.
      eexists. exists m1', b, tra.
      constructor; auto.
      split; first by apply list_forall2_refl.
      split; constructor; simpl; auto.
      econstructor; eauto.
      econstructor; eauto.
      eassumption.
    - (* red_addrof *)
      eexists. exists m1', b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split; econstructor; simpl; eauto.
      repeat econstructor; eauto.
      econstructor; eauto.
    - (* red_unop *)
      eapply unop_biject in H0; eauto; decomp.
      eexists. exists m1', b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split; econstructor; simpl; eauto.
      repeat econstructor; eauto.
      econstructor; eauto.
    - (* red_unop *)
      eapply binop_biject in H0; eauto; decomp.
      eexists. exists m1', b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split; econstructor; simpl; eauto.
      repeat econstructor; eauto.
      econstructor; eauto.
      inv Hp.
      erewrite  <- Programs.pm_ce; eauto.
    - (* red_cast *)
      eapply sem_cast_biject in H0; eauto; decomp.
      eexists. exists m1', b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split; econstructor; simpl; eauto.
      repeat econstructor; eauto.
      econstructor; eauto.
    - (* red_seqand_true *)
      eapply bool_val_biject in H0; eauto.
      eexists. exists m1', b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split.
      + econstructor; simpl; eauto.
        repeat econstructor; eauto.
        econstructor; eauto.
      + by eapply red_seqand_true.
    - (* red_seqand_false *)
      eapply bool_val_biject in H0; eauto.
      eexists. exists m1', b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split.
      + econstructor; simpl; eauto.
        repeat econstructor; eauto.
        econstructor; eauto.
      + by eapply red_seqand_false.
    - (* red_seqor_true *)
      eapply bool_val_biject in H0; eauto.
      eexists. exists m1', b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split.
      + econstructor; simpl; eauto.
        repeat econstructor; eauto.
        econstructor; eauto.
      + by eapply red_seqor_true.
    - (* red_seqor_false *)
      eapply bool_val_biject in H0; eauto.
      eexists. exists m1', b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split.
      + econstructor; simpl; eauto.
        repeat econstructor; eauto.
        econstructor; eauto.
      + by eapply red_seqor_false.
    - (* red_condition *)
      eapply bool_val_biject in H0; eauto.
      eexists (Eparen (if b0 is true then e2' else e3') _ _). exists m1', b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split.
      + econstructor; simpl; eauto.
        repeat econstructor; eauto.
        destruct b0;  eauto.
        econstructor; eauto.
      + by eapply red_condition.
    - (* red_sizeof *)
      eexists. exists m1', b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split.
      + econstructor; simpl; eauto.
        repeat econstructor; eauto.
        econstructor; eauto.
      + inv Hp.
        erewrite  Programs.pm_ce; eauto.
        eapply red_sizeof.
    - (* red_alignof *)
      eexists. exists m1', b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split.
      + econstructor; simpl; eauto.
        repeat econstructor; eauto.
        econstructor; eauto.
      + inv Hp.
        erewrite  Programs.pm_ce; eauto.
        eapply red_alignof.
    - (* red_assign *)
      eapply sem_cast_biject in H6; eauto.
      decomp.
      eapply biject_assign_loc in H3; try eapply H2; eauto; decomp; last by inv Hp; eapply Programs.pm_ce; eauto.
      eexists. exists x0, b, tra.
      split; auto.
      split; first by apply list_forall2_refl.
      split.
      + econstructor; simpl; eauto.
        repeat econstructor; eauto.
        econstructor; eauto.
      + econstructor; eauto.
    - (* red_assignop *)
      eapply biject_deref_loc1 in H0; eauto; decomp.
      eexists. exists m1', b, tra.
      split; auto.
      split; first by apply list_forall2_refl.
      split.
      + econstructor; simpl; eauto.
        repeat econstructor; eauto.
        econstructor; eauto.
      + econstructor; eauto.
    - (* red_postincr *)
      eapply biject_deref_loc1 in H0; eauto; decomp.
      eexists. exists m1', b, tra.
      split; auto.
      split; first by apply list_forall2_refl.
      split; econstructor; simpl; eauto.
      repeat econstructor; eauto.
      econstructor; eauto.
    - (* red_comma *)
      eexists. exists m1', b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split; econstructor; simpl; eauto.
      econstructor; eauto.
      inv H6; reflexivity.
    - (* red_paren *)
      eapply sem_cast_biject in H0; eauto; decomp.
      eexists. exists m1', b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split; econstructor; simpl; eauto.
      econstructor; eauto.
      econstructor; eauto.
    - (* red_builtin *)
      eapply cast_arguments_biject in H0; eauto.
      decomp.
      edestruct (Hextcall_biject ef); eauto.
      decomp.
      eexists _, x2, (Build_bisim_params x0), tra.
      split; auto.
      + intros C C' k1 k2 _ _ H15 H16 H17.
        eapply biject_context_evolve; eauto.
        simpl in *.
        by inv H5; simpl in *.
      + split; first by apply list_forall2_refl.
        split; econstructor; simpl; eauto.
        * econstructor; eauto.
          eapply biject_value_evolve; eauto.
          by inv H5.
        * inv mcse_env.
          ** econstructor; eauto.
             eapply biject_env_evolve; eauto.
          ** econstructor 2; eauto.
             eapply biject_env_evolve; eauto.
        * inv Hp.
          econstructor; simpl; auto.
          ** by eapply symbols_biject_evolve; eauto; eapply globalenv_wf.
          ** move => i def /rm_globals0.
             destruct b.
             simpl in *; subst.
             intros HH. inv H5. simpl in *.
               by eapply H13.
          ** move => i def /rm_globals'0.
             destruct b. inv H5.
             simpl in *. subst.
               by eapply H13.
        * inv H5. destruct b. simpl in *. subst. simpl in *.
          eapply biject_econt_evolve; eauto.
          simpl in *.
          eapply biject_econt_incr2; last by eauto.
          intros x0 y f0 i H5.
          inv H5.
          ** econstructor 1. simpl in *. eapply biject_env_evolve; eauto.
             econstructor; eauto.
          ** econstructor 2; simpl in *; auto. eapply biject_env_evolve;eauto.
             simpl in *.
             econstructor; simpl in *; eauto.
  Qed.

  Next Obligation. (* rred bwd *)
    clean.
    rename f into f'', f' into f. rename f'' into f'.
    inv H2; inv H3; simpl in *; repeat inv_biject_expr; inv mcse_mem;
      edestruct biject_symm_exists as (M' & Hmax1 & Hmax2 & Hinv); eauto; decomp;
        exploit symbols_biject_symm; eauto; intros Hsymb';
          match goal with |[H: mapping_inverse _ _|-_] => inversion H end;
          try match goal with |[Hfwd: m_fwd _ _ = Some _ |- _]  => rewrite -> mi_fwd in Hfwd end.
          (*repeat match goal with |[Hval: biject_value (m_fwd ?M) ?x ?y ,  Hmap: mapping_inverse ?M _ |- _]  =>
                               eapply biject_value_inv_mapping in Hval; eauto end.*)
    - (* red_rvalof*)
      eapply biject_deref_loc1 in H0; eauto; decomp; last by apply M'; eauto.
      eexists. exists m1, b, tra'.
      constructor; eauto.
      split; first by apply list_forall2_refl.
      split; constructor; simpl; eauto.
      + econstructor; eauto with bijection.
      + econstructor; eauto.
    - (* red_addrof *)
      eexists. exists m1, b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split; econstructor; simpl; eauto.
      repeat econstructor; eauto.
      by rewrite mi_fwd.
      econstructor; eauto.
    - (* red_unop *)
      eapply unop_biject in H0; eauto with bijection; decomp.
      eexists. exists m1, b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split; econstructor; simpl; eauto with bijection.
      econstructor; eauto with bijection.
    - (* red_binop *)
      eapply binop_biject in H0; eauto with bijection; decomp.
      eexists. exists m1, b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split; econstructor; simpl; eauto.
      + repeat econstructor; eauto.
        eapply mapping_inverse_symm in H2.
        eapply biject_value_inv_mapping; eauto.
      + econstructor; eauto.
      + inv Hp. erewrite Programs.pm_ce; eauto.
    - (* red_cast *)
      eapply sem_cast_biject in H0; eauto with bijection; decomp.
      eexists. exists m1, b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split; econstructor; simpl; eauto.
      repeat econstructor; eauto with bijection.
      + econstructor; eauto.
    - (* red_seqand_true *)
      eapply bool_val_biject in H0; eauto with bijection.
      eexists. exists m1, b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split.
      + econstructor; simpl; eauto with bijection.
        econstructor; eauto.
      + by eapply red_seqand_true.
    - (* red_seqand_false *)
      eapply bool_val_biject in H0; eauto with bijection.
      eexists. exists m1, b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split.
      + econstructor; simpl; eauto with bijection.
        econstructor; eauto.
      + by eapply red_seqand_false.
    - (* red_seqor_true *)
      eapply bool_val_biject in H0; eauto with bijection.
      eexists. exists m1, b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split.
      + econstructor; simpl; eauto with bijection.
        econstructor; eauto.
      + by eapply red_seqor_true.
    - (* red_seqor_false *)
      eapply bool_val_biject in H0; eauto with bijection.
      eexists. exists m1, b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split.
      + econstructor; simpl; eauto with bijection.
        econstructor; eauto.
      + by eapply red_seqor_false.
    - (* red_condition *)
      eapply bool_val_biject in H0; eauto with bijection.
      eexists (Eparen (if b0 is true then e2 else e3) _ _). exists m1, b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split.
      + econstructor; simpl; eauto with bijection.
        econstructor; eauto.
        destruct b0;  eauto.
        econstructor; eauto.
      + by eapply red_condition.
    - (* red_sizeof *)
      eexists. exists m1, b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split.
      + econstructor; simpl; eauto.
        repeat econstructor; eauto.
        econstructor; eauto.
      + inv Hp.
        erewrite  Programs.pm_ce; eauto; last by apply Programs.match_program_symm; eassumption.
        eapply red_sizeof.
    - (* red_alignof *)
      eexists. exists m1, b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split.
      + econstructor; simpl; eauto.
        repeat econstructor; eauto.
        econstructor; eauto.
      + inv Hp.
        erewrite  Programs.pm_ce; eauto; last by apply Programs.match_program_symm; eassumption.
        eapply red_alignof.
    - (* red_assign *)
      eapply sem_cast_biject in H0; eauto with bijection; decomp.
      eapply biject_assign_loc in H4; eauto with bijection; decomp;
        [|
        by eapply M'; eassumption|
          by inv Hp; eapply Programs.pm_ce; eauto with bijection; eapply Programs.match_program_symm; eassumption].

      eexists. exists x0, b, tra'.
      split; auto.
      split; first by apply list_forall2_refl.
      split.
      + econstructor; simpl; eauto with bijection.
        econstructor; eauto with bijection.
      + econstructor; eauto.
    - (* red_assignop *)
      eapply biject_deref_loc1 in H0; eauto with bijection; decomp.
      eexists. exists m1, b, tra'.
      split; auto.
      split; first by apply list_forall2_refl.
      split.
      + econstructor; simpl; eauto with bijection.
        repeat econstructor; eauto with bijection.
        by erewrite mi_fwd; eassumption.
        econstructor; eauto with bijection.
      + econstructor; eassumption.
      + by eapply M'.
    - (* red_postincr *)
      eapply biject_deref_loc1 in H0; eauto with bijection; decomp.
      eexists. exists m1, b, tra'.
      split; auto.
      split; first by apply list_forall2_refl.
      split; econstructor; simpl; eauto with bijection.
      + econstructor; eauto with bijection.
        econstructor; eauto with bijection;
          econstructor; eauto with bijection.
          by erewrite mi_fwd; eassumption.
      + econstructor; eauto with bijection.
      + by eapply M'.
    - (* red_comma *)
      eexists. exists m1, b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split; econstructor; simpl; eauto.
      econstructor; eauto.
      inv H6; reflexivity.
    - (* red_paren *)
      eapply sem_cast_biject in H0; eauto with bijection; decomp.
      eexists. exists m1, b, E0.
      split; auto.
      split; first by apply list_forall2_refl.
      split; econstructor; simpl; eauto with bijection.
      + econstructor; eauto with bijection.
    - (* red_builtin *)
      rename M' into M1'.
      eapply cast_arguments_biject in H0; eauto with bijection;
        last by eapply biject_exprlist_symm; eauto; rewrite mi_fwd; eapply option_inverse_symm; eapply M1'.
      decomp.
      edestruct (Hextcall_biject ef); eauto. decomp. rename x0 into M2', x2 into m2.
      edestruct (biject_symm_exists M1' ) as (M1 & ? & ? & ? & ?); eauto with bijection.
      edestruct (mapping_inverse_exists M2') as (M2 & ?).
      have Hevolve: mapping_evolve M1 M2 by eauto with bijection.
      eexists _, m2, (Build_bisim_params M2 ), tra'.
      split; auto.
      + intros C C' k1 k2  _ _ ? ? ? .
        eapply biject_context_evolve; eauto.
        simpl in *.
        rewrite mi_fwd.
        inv H19.
        rewrite -mi_bwd0.
        by inv H8.
      + split; first by apply list_forall2_refl.
        split; econstructor; simpl; eauto.
        * econstructor.
          eapply biject_value_evolve with (f := m_fwd M1);  last by inv Hevolve.
          by eauto with bijection.
        * inv mcse_env; [econstructor 1| econstructor 2]; eauto with bijection.
        * econstructor; simpl; eauto with bijection.
          ** eapply symbols_biject_evolve; eauto with bijection.
               by inv Hp; apply globalenv_wf; eauto.
          ** move => i def /rm_globals0.
             destruct b. simpl in *.
             rewrite mi_fwd.
             intros HH.
             inv H17.
             inv H19.
             inv Hevolve.
             simpl in *.
             apply H17.
             by rewrite -mi_bwd0.
          ** move => i def /rm_globals'0.
             destruct b. simpl in *.
             inv H19. inv H17.
             inv Hevolve.
             simpl in *.
             rewrite mi_fwd mi_bwd1.
             eapply H17.
        * eapply biject_econt_evolve with (f := m_fwd M1); eauto with bijection.
          by inv Hevolve.
          eapply biject_econt_incr2 with (T__env := R__env b); eauto with bijection.
          ** inversion 1; subst; [econstructor 1| econstructor 2]; eauto with bijection.
          ** inv H17.
             rewrite -mi_bwd0.
             rewrite -mi_fwd.
             eauto with bijection.
  Qed.
  Next Obligation. (* callred fwd *)
    clean.
    inv H1.
    inv H2.
    inversion mcse_mem.
    simpl in *.
    repeat inv_biject_expr.
    edestruct cast_arguments_biject as (vargs' & Hargs & Hcastargs); eauto with bijection.
    unfold find_funct, find_funct_ptr in *.
    repeat option_cases. autoinj.
    edestruct Programs.match_program_genv_def as (i & def' & Hsymb & Hsymb' & Hdef' & Hmatch); eauto; [destruct Hp; eauto| eapply Heq|].
    have Hs: (i = id__callee) by eapply (genv_vars_inj (genv_genv (Csem.globalenv p))); eauto. subst.
    inv Hmatch.
    inv H2.
    rename f' into f'__callee.
    have Hfindfunc: find_funct (Csem.globalenv p') v' = Some (Ctypes.Internal f'__callee).
    {
      inv H8. unfold find_funct, find_funct_ptr, find_def in *.
      goal_unmatch; last by congruence.
      have Hb: b0 = b2 by erewrite rm_globals0 in H10; eauto; autoinj.
      by subst b2; rewrite Hdef'; eauto.
    }
    inv H8.
    exists vargs', f'__callee, b.
    do 3 (split; auto).
    - econstructor; eauto.
    - split.
      econstructor; simpl; eauto.
      + econstructor; eauto.
      + econstructor; eauto.
        * have Hb: b0 = b2 by erewrite rm_globals0 in H10; eauto; autoinj.
            by subst.
        * inv H3; by [inv H1|].
  Qed.
  Next Obligation. (* callred bwd *)
    clean.
    inv H1.
    inv H2.
    inversion mcse_mem.
    simpl in *.
    repeat inv_biject_expr.
    edestruct biject_symm_exists as (M' & Hmax1 & Hmax2 & Hinv); eauto; decomp.
    exploit symbols_biject_symm; eauto; intros Hsymbols';
      match goal with |[H: mapping_inverse _ _|-_] => inversion H end.
          (*repeat match goal with |[Hval: biject_value (m_fwd ?M) ?x ?y ,  Hmap: mapping_inverse ?M _ |- _]  =>
                               eapply biject_value_inv_mapping in Hval; eauto end.*)
    edestruct cast_arguments_biject as (vargs' & Hargs & Hcastargs); eauto with bijection;
      try by eapply biject_exprlist_symm; eauto with bijection ext; rewrite -mi_bwd; apply (bp_mapping b).

    unfold find_funct, find_funct_ptr in *.
    repeat option_cases. autoinj.
    edestruct Programs.match_program_genv_def_inv as (i & def' & Hsymb & Hsymb' & Hdef' & Hmatch); eauto; [destruct Hp; eauto| eapply Heq|].
    inv Hmatch.

    have Hfindfunc: find_funct (Csem.globalenv p) v = Some f1.
    {
      inv H2. unfold find_funct, find_funct_ptr, find_def in *.
      goal_unmatch; last by congruence.
      have Hb0: m_fwd (bp_mapping b) b0 = Some b0 by eapply rm_globals'0; eauto.
      have Heq': b1 = b0 by eapply mapping_inj; eauto. subst b1.
        by rewrite Hdef'.
    }
    inv H11.

    have Hs: (i = id__callee) by eapply (genv_vars_inj (genv_genv (Csem.globalenv p'))); eauto.
    subst i.
    rename f into f__callee.
    exists vargs', f__callee, b.
    split; auto.
    inv H2.
    split; auto.
    - rewrite mi_fwd.
      eapply list_forall2_inv; eauto; first by destruct M'; simpl; intros; eauto with bijection.
    - split; auto.
      + econstructor; simpl; eauto.
      + split; econstructor; simpl; eauto.
        * econstructor; eauto.
        * rewrite mi_fwd.
          eapply list_forall2_inv; eauto; first by destruct M'; simpl; intros; eauto with bijection.
        * have Heq': b1 = b0 by eapply mapping_inj; eauto. by subst b1.
        * inv H12; by [inv H3|].
  Qed.

  Require Import Behaviors.

  Definition ts : transformation_spec p p' (precond refparams) (postcond refparams) (spec refparams).
    inv Hp.
    constructor; auto.
    constructor; auto.
  Defined.

  Definition is_simulation:
    Def.Simulation p p' (precond refparams) (postcond refparams) (P__state p) (P'__state p')
                   (Lockstep.BisimR bparams)
                   (spec refparams) (Logic.eq) ts.
    constructor; eauto.

  Theorem behavior_preservation:
    forall beh,
      Behaviors.program_behaves (semantics p) beh ->
      exists beh',
        program_behavior_match Logic.eq Logic.eq beh beh'  /\
        Behaviors.program_behaves (semantics p') beh'.
  Proof.
    intros beh H.
    eapply behavior_preserved__fwd with (T__event := fun x => x); eauto.
    - move => ? ? ? -> -> ; eauto.
    - econstructor.
      + econstructor.

End Step.