Set Implicit Arguments.

Require Import RelationClasses.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.
From PromisingLib Require Import Language.
From PromisingLib Require Import Axioms.

From PromisingLib Require Import Event.

Require Import FoldN.
Require Import Knowledge.

Require Import Sequential.
Require Import FlagAux.
Require Import SimAux.
Require Import SeqAux.
Require Import Opt2.

Require Import ITreeLang.

Require Import DeadStoreElim.
Require Import DeadStoreElimProof1.

Section MATCH.

  Ltac dest_loc l1 l2 :=
    destruct (Loc.eqb l1 l2) eqn:LOC;
    [rewrite Loc.eqb_eq in LOC; clarify; try rewrite Loc.eqb_refl; ss |
     hexploit LOC; intros DIFFL; rewrite Loc.eqb_sym in LOC; try rewrite LOC; apply Loc.eqb_neq in DIFFL; ss].

  Let O2: Opt2.t := DSE_opt2.

  Let bot := Opt2.bot O2.
  Let init := Opt2.bot2 O2.
  Let data_meet := @meet2 O2.
  Let data_le := @le2 O2.
  Let inst_gd := @inst_gd O2.
  Let GD := GD O2.

  Definition to_deferred0: Three -> Flag.t :=
    fun t =>
      match t with
      | none
      | half => false
      | full => true
      end.

  Definition to_deferred: GD -> Flags.t :=
    fun data => (fun l => to_deferred0 (data l)).

  Lemma to_deferred0_bot: to_deferred0 (Opt2.bot O2) = false.
  Proof. ss. Qed.

  Lemma to_deferred_bot: to_deferred (Opt2.bot2 O2) = Flags.bot.
  Proof. ss. Qed.

  Lemma to_deferred0_mon: forall mp0 mp1 (LE: le mp0 mp1), Flag.le (to_deferred0 mp0) (to_deferred0 mp1).
  Proof. i. destruct mp0, mp1; ss. Qed.

  Lemma to_deferred_mon: forall mp0 mp1 (LE: data_le mp0 mp1), Flags.le (to_deferred mp0) (to_deferred mp1).
  Proof. ii. apply to_deferred0_mon. apply LE. Qed.

  Lemma to_deferred_na_sound:
    forall (i: Inst.t) mp src_m val
      (NA: is_na_inst i)
    ,
      Flags.le (to_deferred (inst_gd i mp))
               (Flags.join (to_deferred mp) (update_mem_na val i src_m).(SeqMemory.flags)).
  Proof.
    ii. destruct i; ss.
    all: unfold inst_gd, Opt2.inst_gd, mk_global, to_deferred, Flags.join; ss.
    1,2,6,7: apply Flag.join_ge_l.
    - rewrite update_load_ord1; auto. 2: destruct ord; ss. dest_loc rhs loc. apply Flag.join_ge_l.
    - rewrite update_store_ord1; auto. dest_loc lhs loc.
      + unfold Flags.update. rewrite Loc.eq_dec_eq. destruct (to_deferred0 (mp loc)); ss.
      + apply Flag.join_ge_l.
    - des.
      + rewrite update_read_ord1; auto. dest_loc loc0 loc.
        hexploit (ord_inv2 ordw); i; des.
        * rewrite update_store_ord1; auto. rewrite Loc.eqb_sym; rewrite LOC. apply Flag.join_ge_l.
        * rewrite update_store_ord2; auto. rewrite Loc.eqb_sym; rewrite LOC. apply Flag.join_ge_l.
        * rewrite update_store_ord3; auto. rewrite Loc.eqb_sym; rewrite LOC.
          etrans. 2: apply Flag.join_ge_l. apply to_deferred0_mon. apply rel_flag_le.
      + rewrite update_store_ord1; auto. hexploit (ord_inv1' ordr); i; des.
        * rewrite update_read_ord1; auto. dest_loc loc0 loc. apply Flag.join_ge_l.
        * rewrite update_read_ord2; auto. dest_loc loc0 loc.
          etrans. 2: apply Flag.join_ge_l. apply to_deferred0_mon. apply acq_flag_le.
  Qed.

  Definition match_cell (data: Three) (sv tv: Const.t) (sf tf: Flag.t) :=
    match data with
    | none =>
      (sv = tv) /\ (sf = tf)
    | half =>
      (sf = false) -> ((sv = tv) /\ (sf = tf))
    | full =>
      True
    end.

  Definition match_mem (data: GD) (sm tm: SeqMemory.t) :=
    forall l, match_cell (data l)
                    (sm.(SeqMemory.value_map) l) (tm.(SeqMemory.value_map) l)
                    (sm.(SeqMemory.flags) l) (tm.(SeqMemory.flags) l).

  Lemma mcell_refl:
    forall d v f, match_cell d v v f f.
  Proof. i. unfold match_cell. des_ifs. Qed.

  Lemma mm_refl:
    forall d m, match_mem d m m.
  Proof. unfold match_mem. i. apply mcell_refl. Qed.

  Lemma mcell_bot:
    forall sv tv sf tf (MCELL: match_cell bot sv tv sf tf), (sv = tv) /\ (sf = tf).
  Proof.
    ii. unfold match_cell in MCELL. ss.
  Qed.

  Lemma mm_bot: forall sm tm (MM: match_mem init sm tm), sm = tm.
  Proof.
    i. unfold match_mem in MM. unfold match_cell in MM.
    destruct sm, tm. f_equal; extensionality l; specialize MM with l; ss; des; auto.
  Qed.

  Lemma mcell_mon:
    forall sv tv sf tf d0 d1
      (LE: le d0 d1)
      (MCELL: match_cell d0 sv tv sf tf)
    ,
      match_cell d1 sv tv sf tf.
  Proof.
    i. unfold match_cell in *. des_ifs.
  Qed.

  Lemma mm_mon:
    forall sm tm mp0 mp1
      (LE: data_le mp0 mp1)
      (MM: match_mem mp0 sm tm)
    ,
      match_mem mp1 sm tm.
  Proof.
    i. unfold match_mem in *. i. eapply mcell_mon; eauto. eapply LE.
  Qed.

  Lemma mm_na:
    forall (i: Inst.t) data sm tm
      (MM: match_mem (inst_gd i data) sm tm)
      (NA: is_na_inst i)
      val usm utm
      (USM: usm = update_mem_na val i sm)
      (UTM: utm = update_mem_na val i tm)
    ,
      match_mem data usm utm.
  Proof.
    i. clarify. unfold inst_gd, Opt2.inst_gd, mk_global in MM. destruct i; ss; clarify.
    - hexploit (ord_inv1 ord); i. des.
      2: destruct ord; ss.
      rewrite update_load_ord1f in MM; auto.
      eapply mm_mon. 2: eapply MM. ii. dest_loc rhs p. refl.
    - hexploit (ord_inv2 ord); i. des.
      2,3: destruct ord; ss.
      rewrite update_store_ord1f in MM; auto.
      ii. ss. unfold ValueMap.write, Flags.update. dest_loc lhs l.
      + rewrite ! Loc.eq_dec_eq. apply mcell_refl.
      + rewrite ! Loc.eq_dec_neq; auto. unfold match_mem in MM. specialize MM with l.
        rewrite Loc.eqb_sym in LOC. rewrite LOC in MM. auto.
    - des.
      + hexploit (ord_inv1' ordr); i. des.
        2:{ destruct ordr; ss. }
        rewrite update_read_ord1f in MM; auto.
        eapply mm_mon. 2: eapply MM. ii. dest_loc loc p. rewrite Loc.eqb_sym in LOC.
        hexploit (ord_inv2 ordw); i. des.
        * rewrite update_store_ord1; auto. rewrite LOC. refl.
        * rewrite update_store_ord2; auto. rewrite LOC. refl.
        * rewrite update_store_ord3; auto. rewrite LOC. apply rel_flag_le.
      + hexploit (ord_inv1' ordr); i. des.
        * rewrite update_read_ord1f in MM; auto. ii. unfold match_mem in MM. specialize MM with l.
          rewrite update_store_ord1 in MM; auto. dest_loc loc l. unfold match_cell. des_ifs.
        * rewrite update_read_ord2f in MM; auto. ii. unfold match_mem in MM. specialize MM with l.
          rewrite update_store_ord1 in MM; auto. unfold match_cell. dest_loc loc l; des_ifs.
  Qed.

  Lemma mm_load_same:
    forall lhs rhs ord mp src_m tgt_m
      (MM: match_mem (inst_gd (Inst.load lhs rhs ord) mp) src_m tgt_m)
    ,
      SeqMemory.read rhs src_m = SeqMemory.read rhs tgt_m.
  Proof.
    i. unfold inst_gd, Opt2.inst_gd, mk_global, match_mem in MM. specialize MM with rhs. ss.
    hexploit (ord_inv1 ord); i. des.
    - rewrite update_load_ord1 in MM; auto. rewrite Loc.eqb_refl in MM. ss. des; auto.
    - rewrite update_load_ord2 in MM; auto. rewrite Loc.eqb_refl in MM. ss. des; auto.
  Qed.

  Lemma mm_read_same:
    forall lhs loc rmw ordr ordw mp src_m tgt_m
      (MM: match_mem (inst_gd (Inst.update lhs loc rmw ordr ordw) mp) src_m tgt_m)
    ,
      SeqMemory.read loc src_m = SeqMemory.read loc tgt_m.
  Proof.
    i. unfold inst_gd, Opt2.inst_gd, mk_global, match_mem in MM. specialize MM with loc. ss.
    hexploit (ord_inv1' ordr); i. des.
    - rewrite update_read_ord1 in MM; auto. rewrite Loc.eqb_refl in MM. ss. des; auto.
    - rewrite update_read_ord2 in MM; auto. rewrite Loc.eqb_refl in MM. ss. des; auto.
  Qed.

  Lemma loc_eqb_is_dec:
    forall a b, Loc.eqb a b = LocSet.Facts.eq_dec a b.
  Proof.
    i. dest_loc a b; auto.
    - unfold proj_sumbool. rewrite Loc.eq_dec_eq; auto.
    - unfold proj_sumbool. rewrite Loc.eq_dec_neq; auto.
  Qed.

  Ltac unfold_flags := unfold Flags.update, Flags.add, Flags.sub, Flags.sub_opt, Flags.meet, Flags.join, Flags.minus.
  Ltac unfold_many := unfold_flags; unfold ValueMap.write, ValueMap.acquire, Perms.acquired.

  Lemma mm_load_at:
    forall mp p src_m tgt_m lhs rhs ord
      (MM : match_mem (inst_gd (Inst.load lhs rhs ord) mp) src_m tgt_m)
      val ev
      (EVENT: ev = ProgramEvent.read rhs val ord)
      (ATOMIC: is_atomic_event ev)
      i_tgt o p1 mem_tgt
      (INPUT: SeqEvent.wf_input ev i_tgt)
      (OUTPUT: Oracle.wf_output ev o)
      (STEP_TGT: SeqEvent.step i_tgt o p tgt_m p1 mem_tgt)
    ,
    exists (i_src : SeqEvent.input) (mem_src : SeqMemory.t),
      SeqEvent.step i_src o p src_m p1 mem_src /\
      SeqEvent.input_match (to_deferred (inst_gd (Inst.load lhs rhs ord) mp)) (to_deferred mp) i_src i_tgt /\
      SeqEvent.wf_input ev i_src /\
      match_mem mp mem_src mem_tgt.
  Proof.
    i. subst ev. hexploit (ord_inv1 ord). i; des.
    { hexploit step_rlx; eauto. ss. destruct ord; ss. i; des.
      do 2 eexists. split; eauto.
      hexploit red_rlx_full. 6: eapply STEP_TGT. 2: eapply ATOMIC. 1,2,3,4: ss. destruct ord; ss. i; des.
      hexploit red_rlx_full. 6: eapply STEP_SRC. 2: eapply ATOMIC. 1,2,3,4: ss. destruct ord; ss. i; des.
      clear PERM0. subst i_src i_tgt p1. rewrite OO in OO0. inv OO0. inv EVACC; inv EVACC0.
      unfold inst_gd, Opt2.inst_gd, mk_global in *. ss.
      rewrite update_load_ord1f in *; auto. splits; ss.
      - econs; ss; eauto.
        { unfold match_mem in MM; specialize MM with rhs. rewrite Loc.eqb_refl in MM. ss; des. rewrite MM; rewrite MM0.
          econs; ss; eauto; try refl.
          unfold to_deferred. rewrite Loc.eqb_refl. ss. rewrite flag_join_bot_r. refl.
        }
        { econs; eauto. refl. }
        { econs; eauto. ii. unfold to_deferred. destruct (Loc.eqb rhs loc); ss. refl. }
      - destruct mem_src, mem_tgt. ss. rewrite MEMV, MEMF, MEMV0, MEMF0; clear MEMV MEMF MEMV0 MEMF0.
        unfold_many.
        ii. ss. unfold match_mem in MM; specialize MM with l. depgen MM. clear.
        rewrite Loc.eqb_sym. rewrite loc_eqb_is_dec. des_ifs.
        i. ss. des. apply mcell_refl.
    }
    { hexploit step_acq; eauto. ss. i; des.
      do 2 eexists. split; eauto.
      hexploit red_acq_full. 6: eapply STEP_TGT. 2: eapply ATOMIC. 1,2,3,4: ss. i; des.
      hexploit red_acq_full. 6: eapply STEP_SRC. 2: eapply ATOMIC. 1,2,3,4: ss. i; des.
      clear PERM0. subst i_src i_tgt p1. rewrite OO in OO0. inv OO0. inv EVACC; inv EVACC0.
      unfold inst_gd, Opt2.inst_gd, mk_global in *. ss.
      rewrite update_load_ord2f in *; auto. splits; ss.
      - econs; ss; eauto.
        { unfold match_mem in MM; specialize MM with rhs. rewrite Loc.eqb_refl in MM. ss; des. rewrite MM; rewrite MM0.
          econs; ss; eauto; try refl.
          unfold to_deferred. rewrite Loc.eqb_refl. ss. rewrite flag_join_bot_r. refl.
        }
        2:{ econs; eauto. refl. }
        { econs; eauto. ii. unfold to_deferred. unfold_flags. unfold match_mem in MM. specialize MM with loc.
          rewrite Loc.eqb_sym in *. rewrite loc_eqb_is_dec in *. depgen MM. clear; i.
          des_ifs. ss. unfold match_cell in MM. des_ifs; des; ss.
          - rewrite flag_join_bot_r. rewrite MM0; refl.
          - destruct (SeqMemory.flags src_m loc) eqn:SRCF, (SeqMemory.flags tgt_m loc) eqn:TGTF; ss. hexploit MM; auto; i; des; clarify.
          - destruct (mp loc); ss.
        }
      - destruct mem_src, mem_tgt. ss. rewrite MEMV, MEMF, MEMV0, MEMF0; clear MEMV MEMF MEMV0 MEMF0.
        unfold_many.
        ii. ss. unfold match_mem in MM; specialize MM with l. depgen MM. clear.
        rewrite Loc.eqb_sym. rewrite loc_eqb_is_dec. des_ifs; i; ss.
        1,2: apply mcell_refl.
        + eapply mcell_mon; eauto. apply acq_flag_le.
        + destruct (mp l) eqn:MPL; ss; des. all: split; auto. apply MM in H. des; auto.
    }
  Qed.

  Lemma mm_store_at:
    forall mp p src_m tgt_m lhs rhs ord
      (MM: match_mem (inst_gd (Inst.store lhs rhs ord) mp) src_m tgt_m)
      val ev
      (EVENT: ev = ProgramEvent.write lhs val ord)
      (ATOMIC: is_atomic_event ev)
      i_tgt o p1 mem_tgt
      (INPUT: SeqEvent.wf_input ev i_tgt)
      (OUTPUT: Oracle.wf_output ev o)
      (STEP_TGT: SeqEvent.step i_tgt o p tgt_m p1 mem_tgt)
    ,
    exists (i_src : SeqEvent.input) (mem_src : SeqMemory.t),
      SeqEvent.step i_src o p src_m p1 mem_src /\
      SeqEvent.input_match (to_deferred (inst_gd (Inst.store lhs rhs ord) mp)) (to_deferred mp) i_src i_tgt /\
      SeqEvent.wf_input ev i_src /\
      match_mem mp mem_src mem_tgt.
  Proof.
    i. subst ev. hexploit (ord_inv2 ord). i; des.
    { destruct ord; ss. }
    { hexploit step_rlx; eauto. ss. destruct ord; ss. i; des.
      do 2 eexists. split; eauto.
      hexploit red_rlx_full. 6: eapply STEP_TGT. 2: eapply ATOMIC. 1,2,3,4: ss. destruct ord; ss. i; des.
      hexploit red_rlx_full. 6: eapply STEP_SRC. 2: eapply ATOMIC. 1,2,3,4: ss. destruct ord; ss. i; des.
      clear PERM0. subst i_src i_tgt p1. rewrite OO in OO0. inv OO0. inv EVACC; inv EVACC0.
      unfold inst_gd, Opt2.inst_gd, mk_global in *. ss.
      rewrite update_store_ord2f in *; auto. splits; ss.
      - econs; ss; eauto.
        { unfold match_mem in MM; specialize MM with lhs. rewrite Loc.eqb_refl in MM. ss; des. rewrite MM; rewrite MM0.
          econs; ss; eauto; try refl.
          unfold to_deferred. rewrite Loc.eqb_refl. ss. rewrite flag_join_bot_r. refl.
        }
        { econs; eauto. refl. }
        { econs; eauto. ii. unfold to_deferred. destruct (Loc.eqb lhs loc); ss. refl. }
      - destruct mem_src, mem_tgt. ss. rewrite MEMV, MEMF, MEMV0, MEMF0; clear MEMV MEMF MEMV0 MEMF0.
        unfold_many.
        ii. ss. unfold match_mem in MM; specialize MM with l. depgen MM. clear.
        rewrite Loc.eqb_sym. rewrite loc_eqb_is_dec. des_ifs.
        i. ss. des. apply mcell_refl.
    }
    { hexploit step_rel; eauto. ss. i; des.
      do 2 eexists. split; eauto.
      hexploit red_rel_full. 6: eapply STEP_TGT. 2: eapply ATOMIC. 1,2,3,4: ss. i; des.
      hexploit red_rel_full. 6: eapply STEP_SRC. 2: eapply ATOMIC. 1,2,3,4: ss. i; des.
      clear PERM0. subst i_src i_tgt p1. rewrite OO in OO0. inv OO0. inv EVACC; inv EVACC0.
      unfold inst_gd, Opt2.inst_gd, mk_global in *. ss.
      rewrite update_store_ord3f in *; auto. splits; ss.
      - econs; ss; eauto.
        { unfold match_mem in MM; specialize MM with lhs. rewrite Loc.eqb_refl in MM. ss; des. rewrite MM; rewrite MM0.
          econs; ss; eauto; try refl.
          unfold to_deferred. rewrite Loc.eqb_refl. ss. rewrite flag_join_bot_r. refl.
        }
        { econs; eauto. refl. }
        { econs; eauto.
          { i. unfold_many. unfold match_mem in MM. specialize MM with loc. rewrite Loc.eqb_sym in MM. rewrite loc_eqb_is_dec in MM.
            des_ifs; ss. refl. unfold to_deferred in UNDEFERRED. destruct (mp loc); ss.
            - des. rewrite MM. refl.
            - des. rewrite MM. refl.
          }
          ii. unfold to_deferred. unfold_flags. unfold match_mem in MM. specialize MM with loc.
          rewrite Loc.eqb_sym in *. rewrite loc_eqb_is_dec in *. depgen MM. clear; i.
          des_ifs. ss. unfold match_cell in MM. des_ifs; des; ss.
          - rewrite flag_join_bot_r. rewrite MM0. apply Flag.join_ge_l.
          - destruct (SeqMemory.flags src_m loc) eqn:SRCF, (SeqMemory.flags tgt_m loc) eqn:TGTF; ss. hexploit MM; auto; i; des; clarify.
          - destruct (mp loc); ss.
            destruct (SeqMemory.flags src_m loc) eqn:SRCF, (SeqMemory.flags tgt_m loc) eqn:TGTF; ss.
        }
      - destruct mem_src, mem_tgt. ss. rewrite MEMV, MEMF, MEMV0, MEMF0; clear MEMV MEMF MEMV0 MEMF0.
        unfold_many.
        ii. ss. unfold match_mem in MM; specialize MM with l. depgen MM. clear.
        rewrite Loc.eqb_sym. rewrite loc_eqb_is_dec. des_ifs; i; ss.
        1: apply mcell_refl.
        destruct (mp l) eqn:MPL; ss; des. all: split; auto.
    }
  Qed.

  Lemma mm_update_failure_at:
    forall lhs loc rmw ordr ordw mp p src_m tgt_m
      (MM: match_mem (inst_gd (Inst.update lhs loc rmw ordr ordw) mp) src_m tgt_m)
      val ev
      (EVENT: ev = ProgramEvent.read loc val ordr)
      (ATOMIC: is_atomic_event ev)
      i_tgt o p1 mem_tgt
      (INPUT: SeqEvent.wf_input ev i_tgt)
      (OUTPUT: Oracle.wf_output ev o)
      (STEP_TGT: SeqEvent.step i_tgt o p tgt_m p1 mem_tgt)
    ,
    exists (i_src : SeqEvent.input) (mem_src : SeqMemory.t),
      SeqEvent.step i_src o p src_m p1 mem_src /\
      SeqEvent.input_match (to_deferred (inst_gd (Inst.update lhs loc rmw ordr ordw) mp)) (to_deferred mp) i_src i_tgt /\
      SeqEvent.wf_input ev i_src /\
      match_mem mp mem_src mem_tgt.
  Proof.
    i. subst ev. hexploit (ord_inv1' ordr). i; des.
    { destruct ordr; ss. }
    hexploit (ord_inv1 ordr). i; des.
    { hexploit step_rlx; eauto. ss. destruct ordr; ss. i; des.
      do 2 eexists. split; eauto.
      hexploit red_rlx_full. 6: eapply STEP_TGT. 2: eapply ATOMIC. 1,2,3,4: ss. destruct ordr; ss. i; des.
      hexploit red_rlx_full. 6: eapply STEP_SRC. 2: eapply ATOMIC. 1,2,3,4: ss. destruct ordr; ss. i; des.
      clear PERM0. subst i_src i_tgt p1. rewrite OO in OO0. inv OO0. inv EVACC; inv EVACC0.
      unfold inst_gd, Opt2.inst_gd, mk_global in *. ss.
      rewrite update_read_ord2f in *; auto. splits; ss.
      - econs; ss; eauto.
        { unfold match_mem in MM; specialize MM with loc. rewrite Loc.eqb_refl in MM. ss; des. rewrite MM; rewrite MM0.
          econs; ss; eauto; try refl.
          unfold to_deferred. rewrite Loc.eqb_refl. ss. rewrite flag_join_bot_r. refl.
        }
        2:{ econs; eauto. refl. }
        { econs; eauto. ii. unfold to_deferred. unfold match_mem in MM. specialize MM with loc0.
          destruct (Loc.eqb loc loc0) eqn:LOC; ss.
          hexploit (ord_inv2 ordw). i; des.
          - rewrite update_store_ord1 in *; auto. rewrite LOC in *. apply to_deferred0_mon. apply acq_flag_le.
          - rewrite update_store_ord2 in *; auto. rewrite LOC in *. apply to_deferred0_mon. apply acq_flag_le.
          - rewrite update_store_ord3 in *; auto. rewrite LOC in *. apply to_deferred0_mon.
            etrans. eapply acq_flag_le. apply rel_flag_le.
        }
      - destruct mem_src, mem_tgt. ss. rewrite MEMV, MEMF, MEMV0, MEMF0; clear MEMV MEMF MEMV0 MEMF0.
        unfold_many.
        ii. ss. unfold match_mem in MM; specialize MM with l. depgen MM. clear.
        rewrite Loc.eqb_sym. rewrite loc_eqb_is_dec. des_ifs; i; ss; des.
        + apply mcell_refl.
        + eapply mcell_mon; eauto. apply Loc.eqb_neq in n. rewrite Loc.eqb_sym in n. hexploit (ord_inv2 ordw). i; des.
          * rewrite update_store_ord1; auto. rewrite n. apply acq_flag_le.
          * rewrite update_store_ord2; auto. rewrite n. apply acq_flag_le.
          * rewrite update_store_ord3; auto. rewrite n. etrans. eapply acq_flag_le. apply rel_flag_le.
    }
    { hexploit step_acq; eauto. ss. i; des.
      do 2 eexists. split; eauto.
      hexploit red_acq_full. 6: eapply STEP_TGT. 2: eapply ATOMIC. 1,2,3,4: ss. i; des.
      hexploit red_acq_full. 6: eapply STEP_SRC. 2: eapply ATOMIC. 1,2,3,4: ss. i; des.
      clear PERM0. subst i_src i_tgt p1. rewrite OO in OO0. inv OO0. inv EVACC; inv EVACC0.
      unfold inst_gd, Opt2.inst_gd, mk_global in *. ss.
      rewrite update_read_ord2f in *; auto. splits; ss.
      - econs; ss; eauto.
        { unfold match_mem in MM; specialize MM with loc. rewrite Loc.eqb_refl in MM. ss; des. rewrite MM; rewrite MM0.
          econs; ss; eauto; try refl.
          unfold to_deferred. rewrite Loc.eqb_refl. ss. rewrite flag_join_bot_r. refl.
        }
        2:{ econs; eauto. refl. }
        { econs; eauto. ii. unfold to_deferred. unfold match_mem in MM. specialize MM with loc0.
          unfold_flags. rewrite Loc.eqb_sym in *. rewrite loc_eqb_is_dec in *. depgen MM. clear; i.
          des_ifs. ss. apply Loc.eqb_neq in n. rewrite Loc.eqb_sym in n. rename n into LOC.
          hexploit (ord_inv2 ordw). i; des.
          - rewrite update_store_ord1 in *; auto. rewrite LOC in *. destruct (mp loc0) eqn:MPL; ss; des.
            + rewrite flag_join_bot_r. rewrite MM0. refl.
            + rewrite flag_join_bot_r. match goal with | [|- _ (Flag.le ?a ?b)] => destruct a; destruct b; ss end. hexploit MM; auto; i; des; clarify.
            + rewrite flag_join_bot_r. match goal with | [|- _ (Flag.le ?a ?b)] => destruct a; destruct b; ss end. hexploit MM; auto; i; des; clarify.
          - rewrite update_store_ord2 in *; auto. rewrite LOC in *. destruct (mp loc0) eqn:MPL; ss; des.
            + rewrite flag_join_bot_r. rewrite MM0. refl.
            + rewrite flag_join_bot_r. match goal with | [|- _ (Flag.le ?a ?b)] => destruct a; destruct b; ss end. hexploit MM; auto; i; des; clarify.
            + rewrite flag_join_bot_r. match goal with | [|- _ (Flag.le ?a ?b)] => destruct a; destruct b; ss end. hexploit MM; auto; i; des; clarify.
          - rewrite update_store_ord3 in *; auto. rewrite LOC in *. destruct (mp loc0) eqn:MPL; ss; des.
            + rewrite flag_join_bot_r. rewrite MM0. refl.
            + rewrite flag_join_bot_r. rewrite MM0. refl.
            + rewrite flag_join_bot_r. match goal with | [|- _ (Flag.le ?a ?b)] => destruct a; destruct b; ss end. hexploit MM; auto; i; des; clarify.
        }
      - destruct mem_src, mem_tgt. ss. rewrite MEMV, MEMF, MEMV0, MEMF0; clear MEMV MEMF MEMV0 MEMF0.
        unfold_many.
        ii. ss. unfold match_mem in MM; specialize MM with l. depgen MM. clear.
        rewrite Loc.eqb_sym. rewrite loc_eqb_is_dec. des_ifs; i; ss; des.
        1,2: apply mcell_refl.
        + eapply mcell_mon; eauto. apply Loc.eqb_neq in n. rewrite Loc.eqb_sym in n. hexploit (ord_inv2 ordw). i; des.
          * rewrite update_store_ord1; auto. rewrite n. apply acq_flag_le.
          * rewrite update_store_ord2; auto. rewrite n. apply acq_flag_le.
          * rewrite update_store_ord3; auto. rewrite n. etrans. eapply acq_flag_le. apply rel_flag_le.
        + apply Loc.eqb_neq in n. rewrite Loc.eqb_sym in n. hexploit (ord_inv2 ordw). i; des.
          * rewrite update_store_ord1 in *; auto. rewrite n in *. destruct (mp l) eqn:MPL; ss; i; des; auto. apply MM in H0; des; auto.
          * rewrite update_store_ord2 in *; auto. rewrite n in *. destruct (mp l) eqn:MPL; ss; i; des; auto. apply MM in H0; des; auto.
          * rewrite update_store_ord3 in *; auto. rewrite n in *. destruct (mp l) eqn:MPL; ss; i; des; auto.
    }
  Qed.

  Lemma mm_update_success_at:
    forall lhs loc rmw ordr ordw mp p src_m tgt_m
      (MM: match_mem (inst_gd (Inst.update lhs loc rmw ordr ordw) mp) src_m tgt_m)
      valr valw ev
      (EVENT: ev = ProgramEvent.update loc valr valw ordr ordw)
      (ATOMIC: is_atomic_event ev)
      i_tgt o p1 mem_tgt
      (INPUT: SeqEvent.wf_input ev i_tgt)
      (OUTPUT: Oracle.wf_output ev o)
      (STEP_TGT: SeqEvent.step i_tgt o p tgt_m p1 mem_tgt)
    ,
    exists (i_src : SeqEvent.input) (mem_src : SeqMemory.t),
      SeqEvent.step i_src o p src_m p1 mem_src /\
      SeqEvent.input_match (to_deferred (inst_gd (Inst.update lhs loc rmw ordr ordw) mp)) (to_deferred mp) i_src i_tgt /\
      SeqEvent.wf_input ev i_src /\
      match_mem mp mem_src mem_tgt.
  Proof.
    i. subst ev. hexploit (ord_inv1' ordr). i; des.
    { destruct ordr; ss. }
    hexploit (ord_inv1 ordr). i; des.
    { hexploit (ord_inv2 ordw). i; des.
      { apply andb_prop in ATOMIC. des. destruct ordw; ss. }
      { hexploit step_rlx; eauto. ss. destruct ordr; ss. destruct ordw; ss. i; des.
        do 2 eexists. split; eauto.
        hexploit red_rlx_full. 6: eapply STEP_TGT. 2: eapply ATOMIC. 1,2,3,4: ss. destruct ordr; ss. destruct ordw; ss. i; des.
        hexploit red_rlx_full. 6: eapply STEP_SRC. 2: eapply ATOMIC. 1,2,3,4: ss. destruct ordr; ss. destruct ordw; ss. i; des.
        clear PERM0. subst i_src i_tgt p1. rewrite OO in OO0. inv OO0. inv EVACC; inv EVACC0.
        unfold inst_gd, Opt2.inst_gd, mk_global in *. ss.
        rewrite update_read_ord2f in *; auto. splits; ss.
        - econs; ss; eauto.
          { unfold match_mem in MM; specialize MM with loc. rewrite Loc.eqb_refl in MM. ss; des. rewrite MM; rewrite MM0.
            econs; ss; eauto; try refl.
            unfold to_deferred. rewrite Loc.eqb_refl. ss. rewrite flag_join_bot_r. refl.
          }
          2:{ econs; eauto. refl. }
          { econs; eauto. ii. unfold to_deferred. unfold match_mem in MM. specialize MM with loc0.
            destruct (Loc.eqb loc loc0) eqn:LOC; ss.
            rewrite update_store_ord2 in *; auto. rewrite LOC in *; ss.
            apply to_deferred0_mon. apply acq_flag_le.
          }
        - destruct mem_src, mem_tgt. ss. rewrite MEMV, MEMF, MEMV0, MEMF0; clear MEMV MEMF MEMV0 MEMF0.
          unfold_many.
          ii. ss. unfold match_mem in MM; specialize MM with l. rewrite update_store_ord2 in *; auto. depgen MM. clear.
          rewrite Loc.eqb_sym. rewrite ! loc_eqb_is_dec. des_ifs; i; ss; des.
          + apply mcell_refl.
          + eapply mcell_mon; eauto. apply acq_flag_le.
      }
      { hexploit step_rel; eauto. ss. destruct ordr; ss. i; des.
        do 2 eexists. split; eauto.
        hexploit red_rel_full. 6: eapply STEP_TGT. 2: eapply ATOMIC. 1,2,3,4: ss. destruct ordr; ss. i; des.
        hexploit red_rel_full. 6: eapply STEP_SRC. 2: eapply ATOMIC. 1,2,3,4: ss. destruct ordr; ss. i; des.
        clear PERM0. subst i_src i_tgt p1. rewrite OO in OO0. inv OO0. inv EVACC; inv EVACC0.
        unfold inst_gd, Opt2.inst_gd, mk_global in *. ss.
        rewrite update_read_ord2f in *; auto. splits; ss.
        - econs; ss; eauto.
          { unfold match_mem in MM; specialize MM with loc. rewrite Loc.eqb_refl in MM. ss; des. rewrite MM; rewrite MM0.
            econs; ss; eauto; try refl.
            unfold to_deferred. rewrite Loc.eqb_refl. ss. rewrite flag_join_bot_r. refl.
          }
          { econs; eauto. refl. }
          { econs; eauto.
            { i. unfold_many. unfold match_mem in MM. specialize MM with loc0.
              rewrite update_store_ord3 in *; auto.
              rewrite Loc.eqb_sym in *. rewrite loc_eqb_is_dec in MM. depgen UNDEFERRED. depgen MM.
              clear. des_ifs; i; ss. refl. unfold to_deferred in UNDEFERRED.
              destruct (mp loc0) eqn:MPL; ss; des.
              - rewrite MM; refl.
              - rewrite MM; refl.
            }
            ii. unfold to_deferred. unfold_flags. unfold match_mem in MM. specialize MM with loc0.
            rewrite update_store_ord3 in *; auto.
            rewrite Loc.eqb_sym in *. rewrite loc_eqb_is_dec in *. depgen MM. clear; i.
            des_ifs. ss. destruct (mp loc0) eqn:MPL; ss; des.
            - rewrite MM0. refl.
            - rewrite MM0. refl.
            - destruct (SeqMemory.flags src_m loc0), (SeqMemory.flags tgt_m loc0); ss.
          }
        - destruct mem_src, mem_tgt. ss. rewrite MEMV, MEMF, MEMV0, MEMF0; clear MEMV MEMF MEMV0 MEMF0.
          unfold_many.
          ii. ss. unfold match_mem in MM; specialize MM with l. rewrite update_store_ord3 in *; auto.
          depgen MM. clear. rewrite Loc.eqb_sym. rewrite loc_eqb_is_dec. des_ifs; i; ss.
          1: apply mcell_refl.
          destruct (mp l) eqn:MPL; ss; des. all: split; auto.
      }
    }
    { hexploit (ord_inv2 ordw). i; des.
      { apply andb_prop in ATOMIC. des. destruct ordw; ss. }
      { hexploit step_acq; eauto. ss. destruct ordw; ss. i; des.
        do 2 eexists. split; eauto.
        hexploit red_acq_full. 6: eapply STEP_TGT. 2: eapply ATOMIC. 1,2,3,4: ss. destruct ordw; ss. i; des.
        hexploit red_acq_full. 6: eapply STEP_SRC. 2: eapply ATOMIC. 1,2,3,4: ss. destruct ordw; ss. i; des.
        clear PERM0. subst i_src i_tgt p1. rewrite OO in OO0. inv OO0. inv EVACC; inv EVACC0.
        unfold inst_gd, Opt2.inst_gd, mk_global in *. ss.
        rewrite update_read_ord2f in *; auto. splits; ss.
        - econs; ss; eauto.
          { unfold match_mem in MM; specialize MM with loc. rewrite Loc.eqb_refl in MM. ss; des. rewrite MM; rewrite MM0.
            econs; ss; eauto; try refl.
            unfold to_deferred. rewrite Loc.eqb_refl. ss. rewrite flag_join_bot_r. refl.
          }
          2:{ econs; eauto. refl. }
          { econs; eauto. ii. unfold to_deferred. unfold match_mem in MM. specialize MM with loc0.
            unfold_flags. rewrite update_store_ord2 in *; auto.
            rewrite Loc.eqb_sym in *. rewrite loc_eqb_is_dec in *. depgen MM. clear; i.
            des_ifs. ss. destruct (mp loc0) eqn:MPL; ss; des; auto.
            all: rewrite flag_join_bot_r.
            1: rewrite MM0; refl.
            all: match goal with | [|- _ (_ ?a ?b)] => destruct a; destruct b; ss; auto end; hexploit MM; auto; i; des; auto.
          }
        - destruct mem_src, mem_tgt. ss. rewrite MEMV, MEMF, MEMV0, MEMF0; clear MEMV MEMF MEMV0 MEMF0.
          unfold_many.
          ii. ss. unfold match_mem in MM; specialize MM with l. rewrite update_store_ord2 in *; auto.
          depgen MM. clear. rewrite Loc.eqb_sym. rewrite loc_eqb_is_dec. des_ifs; i; ss; des.
          1,2: apply mcell_refl.
          + eapply mcell_mon; eauto. apply acq_flag_le.
          + destruct (mp l) eqn:MPL; ss; i; des; auto. apply MM in H; des; auto.
      }
      { hexploit step_acq_rel; eauto. ss. i; des.
        do 2 eexists. split; eauto.
        hexploit red_acq_rel_full. 6: eapply STEP_TGT. 2: eapply ATOMIC. 1,2,3,4: ss. i; des.
        hexploit red_acq_rel_full. 6: eapply STEP_SRC. 2: eapply ATOMIC. 1,2,3,4: ss. i; des.
        clear PERM0. subst i_src i_tgt p1. rewrite OO in OO0. inv OO0. inv EVACC; inv EVACC0.
        unfold inst_gd, Opt2.inst_gd, mk_global in *. ss.
        rewrite update_read_ord2f in *; auto. splits; ss.
        - econs; ss; eauto.
          { unfold match_mem in MM; specialize MM with loc. rewrite Loc.eqb_refl in MM. ss; des. rewrite MM; rewrite MM0.
            econs; ss; eauto; try refl.
            unfold to_deferred. rewrite Loc.eqb_refl. ss. rewrite flag_join_bot_r. refl.
          }
          { econs; eauto. ii. unfold to_deferred. unfold match_mem in MM. specialize MM with loc0.
            unfold_flags. rewrite update_store_ord3 in *; auto.
            rewrite Loc.eqb_sym in *. rewrite loc_eqb_is_dec in *. depgen MM. clear; i.
            des_ifs. ss. destruct (mp loc0) eqn:MPL; ss; des; auto.
            all: rewrite flag_join_bot_r.
            1,2: rewrite MM0; refl.
            match goal with | [|- _ (_ ?a ?b)] => destruct a; destruct b; ss; auto end; hexploit MM; auto; i; des; auto.
          }
          { econs; eauto.
            { i. unfold_many. unfold match_mem in MM. specialize MM with loc0.
              rewrite update_store_ord3 in *; auto.
              rewrite Loc.eqb_sym in *. rewrite loc_eqb_is_dec in MM. depgen UNDEFERRED. depgen MM.
              clear. des_ifs; i; ss. 1,2,4: refl. unfold to_deferred in UNDEFERRED.
              destruct (mp loc0) eqn:MPL; ss; des.
              - rewrite MM; refl.
              - rewrite MM; refl.
            }
            ii. unfold to_deferred. unfold_flags. unfold match_mem in MM. specialize MM with loc0.
            instantiate (1:=(to_deferred mp)). unfold to_deferred.
            rewrite update_store_ord3 in *; auto.
            rewrite Loc.eqb_sym in *. rewrite loc_eqb_is_dec in *. depgen MM. clear; i.
            des_ifs; ss. refl. destruct (mp loc0) eqn:MPL; ss; des.
            - rewrite MM0. refl.
            - rewrite MM0. refl.
            - destruct (SeqMemory.flags src_m loc0), (SeqMemory.flags tgt_m loc0); ss.
          }
        - destruct mem_src, mem_tgt. ss. rewrite MEMV, MEMF, MEMV0, MEMF0; clear MEMV MEMF MEMV0 MEMF0.
          unfold_many.
          ii. ss. unfold match_mem in MM; specialize MM with l. rewrite update_store_ord3 in *; auto.
          depgen MM. clear. rewrite Loc.eqb_sym. rewrite loc_eqb_is_dec. des_ifs; i; ss; des.
          1,2: apply mcell_refl.
          + destruct (mp l) eqn:MPL; ss; i; des; auto.
          + destruct (mp l) eqn:MPL; ss; i; des; auto.
      }
    }
  Qed.

  Lemma mm_fence:
    forall ordr ordw mp p src_m tgt_m
      (MM: match_mem (inst_gd (Inst.fence ordr ordw) mp) src_m tgt_m)
      ev
      (EVENT: ev = ProgramEvent.fence ordr ordw)
      (ATOMIC: is_atomic_event ev)
      i_tgt o p1 mem_tgt
      (INPUT: SeqEvent.wf_input ev i_tgt)
      (OUTPUT: Oracle.wf_output ev o)
      (STEP_TGT: SeqEvent.step i_tgt o p tgt_m p1 mem_tgt)
    ,
    exists (i_src : SeqEvent.input) (mem_src : SeqMemory.t),
      SeqEvent.step i_src o p src_m p1 mem_src /\
      SeqEvent.input_match (to_deferred (inst_gd (Inst.fence ordr ordw) mp)) (to_deferred mp) i_src i_tgt /\
      SeqEvent.wf_input ev i_src /\
      match_mem mp mem_src mem_tgt.
  Proof.
    i. subst ev. hexploit (ord_inv3 ordr). i; des.
    { hexploit (ord_inv3' ordw). i; des.
      { hexploit step_rlx2; eauto. ss. destruct ordr, ordw; ss. destruct ordw; ss. i; des.
        do 2 eexists. split; eauto.
        hexploit red_rlx2_full. 6: eapply STEP_TGT. 2: eapply ATOMIC. 1,2,3,4: ss. destruct ordr, ordw; ss. destruct ordw; ss. i; des.
        hexploit red_rlx2_full. 6: eapply STEP_SRC. 2: eapply ATOMIC. 1,2,3,4: ss. destruct ordr, ordw; ss. destruct ordw; ss. i; des.
        clear PERM0. subst i_src i_tgt p1. rewrite OO in OO0. inv OO0.
        unfold inst_gd, Opt2.inst_gd, mk_global in *. ss.
        rewrite update_fence_r_ord1f in *; auto. splits; ss.
        - econs; ss; eauto.
          { econs; eauto. refl. }
          { econs; eauto. refl. }
          { econs; eauto. ii. unfold to_deferred. unfold match_mem in MM. specialize MM with loc.
            rewrite update_fence_w_ord1 in *; auto. refl.
          }
        - destruct mem_src, mem_tgt.
          ii. ss. unfold match_mem in MM; specialize MM with l. ss.
          rewrite update_fence_w_ord1 in *; auto.
      }
      { hexploit step_rel2; eauto. ss. destruct ordr, ordw; ss. destruct ordw; ss. i; des.
        do 2 eexists. split; eauto.
        hexploit red_rel2_full. 6: eapply STEP_TGT. 2: eapply ATOMIC. 1,2,3,4: ss. destruct ordr, ordw; ss. destruct ordw; ss. i; des.
        hexploit red_rel2_full. 6: eapply STEP_SRC. 2: eapply ATOMIC. 1,2,3,4: ss. destruct ordr, ordw; ss. destruct ordw; ss. i; des.
        clear PERM0. subst i_src i_tgt p1. rewrite OO in OO0. inv OO0.
        unfold inst_gd, Opt2.inst_gd, mk_global in *. ss.
        rewrite update_fence_r_ord1f in *; auto. splits; ss.
        - econs; ss; eauto.
          { econs; eauto. refl. }
          { econs; eauto. refl. }
          { econs; eauto.
            { i. unfold match_mem in MM. specialize MM with loc.
              rewrite update_fence_w_ord2 in *; auto.
              depgen UNDEFERRED. depgen MM.
              clear. i; ss. unfold to_deferred in UNDEFERRED.
              destruct (mp loc) eqn:MPL; ss; des.
              - rewrite MM; refl.
              - rewrite MM; refl.
            }
            ii. unfold to_deferred. unfold_flags. unfold match_mem in MM. specialize MM with loc.
            rewrite update_fence_w_ord2 in *; auto. depgen MM. clear; i.
            destruct (mp loc) eqn:MPL; ss; des.
            - rewrite MM0. refl.
            - rewrite MM0. refl.
            - destruct (SeqMemory.flags src_m loc), (SeqMemory.flags tgt_m loc); ss.
          }
        - destruct mem_src, mem_tgt. ss. rewrite MEMV, MEMF, MEMV0, MEMF0; clear MEMV MEMF MEMV0 MEMF0.
          ii. ss. unfold match_mem in MM; specialize MM with l. rewrite update_fence_w_ord2 in *; auto.
          depgen MM. clear. i; ss.
          destruct (mp l) eqn:MPL; ss; des. all: split; auto.
      }
      { hexploit step_acq_rel2; eauto. ss. destruct ordw; ss. destruct ordw; ss. i; des.
        do 2 eexists. split; eauto.
        hexploit red_acq_rel2_full. 6: eapply STEP_TGT. 2: eapply ATOMIC. 1,2,3,4: ss. 1,2: destruct ordw; ss. i; des.
        hexploit red_acq_rel2_full. 6: eapply STEP_SRC. 2: eapply ATOMIC. 1,2,3,4: ss. 1,2: destruct ordw; ss. i; des.
        clear PERM0. subst i_src i_tgt p1. rewrite OO in OO0. inv OO0.
        unfold inst_gd, Opt2.inst_gd, mk_global in *. ss.
        rewrite update_fence_r_ord1f in *; auto. splits; ss.
        - econs; ss; eauto.
          { econs; eauto. refl. }
          { econs; eauto. ii. unfold to_deferred. unfold match_mem in MM. specialize MM with loc.
            unfold_flags. rewrite update_fence_w_ord3 in *; auto. depgen MM. clear; i.
            destruct (mp loc); ss; des. all: rewrite flag_join_bot_r.
            all: rewrite MM0; refl.
          }
          { econs; eauto.
            { i. unfold_many. unfold match_mem in MM. specialize MM with loc.
              rewrite update_fence_w_ord3 in *; auto. depgen UNDEFERRED. depgen MM. clear; i.
              unfold to_deferred in *. destruct (mp loc); ss; des.
              all: rewrite MM; refl.
            }
            ii. unfold to_deferred. unfold_flags. unfold match_mem in MM. specialize MM with loc.
            instantiate (1:=(to_deferred mp)). unfold to_deferred.
            rewrite update_fence_w_ord3 in *; auto. depgen MM. clear; i.
            destruct (mp loc) eqn:MPL; ss; des. all: rewrite MM0; refl.
          }
        - destruct mem_src, mem_tgt. ss. rewrite MEMV, MEMF, MEMV0, MEMF0; clear MEMV MEMF MEMV0 MEMF0.
          unfold_many.
          ii. ss. unfold match_mem in MM; specialize MM with l. rewrite update_fence_w_ord3 in *; auto.
          depgen MM. clear; i. destruct (mp l) eqn:MPL; ss; des. all: split; auto. all: rewrite MM; refl.
      }
    }
    { hexploit (ord_inv3' ordw). i; des.
      { hexploit step_acq2; eauto. ss. destruct ordr, ordw; ss. destruct ordw; ss. i; des.
        do 2 eexists. split; eauto.
        hexploit red_acq2_full. 6: eapply STEP_TGT. 2: eapply ATOMIC. 1,2,3,4: ss. destruct ordr, ordw; ss. destruct ordw; ss. i; des.
        hexploit red_acq2_full. 6: eapply STEP_SRC. 2: eapply ATOMIC. 1,2,3,4: ss. destruct ordr, ordw; ss. destruct ordw; ss. i; des.
        clear PERM0. subst i_src i_tgt p1. rewrite OO in OO0. inv OO0.
        unfold inst_gd, Opt2.inst_gd, mk_global in *. ss.
        rewrite update_fence_r_ord2f in *; auto. splits; ss.
        - econs; ss; eauto.
          { econs; eauto. refl. }
          2:{ econs; eauto. refl. }
          { econs; eauto. unfold to_deferred. ii. unfold_flags. unfold match_mem in MM; specialize MM with loc.
            rewrite update_fence_w_ord1 in *; auto. depgen MM. clear; i.
            destruct (mp loc); ss; des. all: rewrite flag_join_bot_r. all: try by (rewrite MM0; refl).
            all: match goal with | [|- _ (_ ?a ?b)] => destruct a, b; ss end.
            all: hexploit MM; auto; i; des; clarify.
          }
        - destruct mem_src, mem_tgt. ss. rewrite MEMV, MEMF, MEMV0, MEMF0; clear MEMV MEMF MEMV0 MEMF0.
          ii. ss. unfold_many. unfold match_mem in MM; specialize MM with l.
          rewrite update_fence_w_ord1 in *; auto. depgen MM. clear; i.
          destruct (mp l); ss; des.
          + rewrite MM, MM0. split; refl.
          + i. apply MM in H; des; auto. rewrite H, H0. auto.
      }
      { hexploit step_acq_rel2; eauto. ss. destruct ordw; ss. destruct ordw; ss. i; des.
        do 2 eexists. split; eauto.
        hexploit red_acq_rel2_full. 6: eapply STEP_TGT. 2: eapply ATOMIC. 1,2,3,4: ss. 1,2: destruct ordw; ss. i; des.
        hexploit red_acq_rel2_full. 6: eapply STEP_SRC. 2: eapply ATOMIC. 1,2,3,4: ss. 1,2: destruct ordw; ss. i; des.
        clear PERM0. subst i_src i_tgt p1. rewrite OO in OO0. inv OO0.
        unfold inst_gd, Opt2.inst_gd, mk_global in *. ss.
        rewrite update_fence_r_ord2f in *; auto. splits; ss.
        - econs; ss; eauto.
          { econs; eauto. refl. }
          { econs; eauto. ii. unfold to_deferred. unfold match_mem in MM. specialize MM with loc.
            unfold_flags. rewrite update_fence_w_ord2 in *; auto. depgen MM. clear; i.
            destruct (mp loc); ss; des. all: rewrite flag_join_bot_r.
            all: try (rewrite MM0; refl).
            destruct (SeqMemory.flags src_m loc) eqn:SMF, (SeqMemory.flags tgt_m loc) eqn: TMF; ss. hexploit MM; auto; i; des; clarify.
          }
          { econs; eauto.
            { i. unfold_many. unfold match_mem in MM. specialize MM with loc.
              rewrite update_fence_w_ord2 in *; auto. depgen UNDEFERRED. depgen MM. clear; i.
              unfold to_deferred in *. destruct (mp loc); ss; des.
              all: rewrite MM; refl.
            }
            ii. unfold to_deferred. unfold_flags. unfold match_mem in MM. specialize MM with loc.
            rewrite update_fence_w_ord2 in *; auto.
            instantiate (1:=(to_deferred mp)). unfold to_deferred.
            depgen MM. clear; i.
            destruct (mp loc) eqn:MPL; ss; des. all: try (rewrite MM0; refl).
            destruct (SeqMemory.flags src_m loc) eqn:SMF, (SeqMemory.flags tgt_m loc) eqn: TMF; ss.
          }
        - destruct mem_src, mem_tgt. ss. rewrite MEMV, MEMF, MEMV0, MEMF0; clear MEMV MEMF MEMV0 MEMF0.
          unfold_many.
          ii. ss. unfold match_mem in MM; specialize MM with l. rewrite update_fence_w_ord2 in *; auto.
          depgen MM. clear; i. destruct (mp l) eqn:MPL; ss; des. all: split; auto. all: rewrite MM; refl.
      }
      { hexploit step_acq_rel2; eauto. ss. destruct ordw; ss. destruct ordw; ss. i; des.
        do 2 eexists. split; eauto.
        hexploit red_acq_rel2_full. 6: eapply STEP_TGT. 2: eapply ATOMIC. 1,2,3,4: ss. 1,2: destruct ordw; ss. i; des.
        hexploit red_acq_rel2_full. 6: eapply STEP_SRC. 2: eapply ATOMIC. 1,2,3,4: ss. 1,2: destruct ordw; ss. i; des.
        clear PERM0. subst i_src i_tgt p1. rewrite OO in OO0. inv OO0.
        unfold inst_gd, Opt2.inst_gd, mk_global in *. ss.
        rewrite update_fence_r_ord2f in *; auto. splits; ss.
        - econs; ss; eauto.
          { econs; eauto. refl. }
          { econs; eauto. ii. unfold to_deferred. unfold match_mem in MM. specialize MM with loc.
            unfold_flags. rewrite update_fence_w_ord3 in *; auto. depgen MM. clear; i.
            destruct (mp loc); ss; des. all: rewrite flag_join_bot_r.
            all: rewrite MM0; refl.
          }
          { econs; eauto.
            { i. unfold_many. unfold match_mem in MM. specialize MM with loc.
              rewrite update_fence_w_ord3 in *; auto. depgen UNDEFERRED. depgen MM. clear; i.
              unfold to_deferred in *. destruct (mp loc); ss; des.
              all: rewrite MM; refl.
            }
            ii. unfold to_deferred. unfold_flags. unfold match_mem in MM. specialize MM with loc.
            instantiate (1:=(to_deferred mp)). unfold to_deferred.
            rewrite update_fence_w_ord3 in *; auto. depgen MM. clear; i.
            destruct (mp loc) eqn:MPL; ss; des. all: rewrite MM0; refl.
          }
        - destruct mem_src, mem_tgt. ss. rewrite MEMV, MEMF, MEMV0, MEMF0; clear MEMV MEMF MEMV0 MEMF0.
          unfold_many.
          ii. ss. unfold match_mem in MM; specialize MM with l. rewrite update_fence_w_ord3 in *; auto.
          depgen MM. clear; i. destruct (mp l) eqn:MPL; ss; des. all: split; auto. all: rewrite MM; refl.
      }
    }
  Qed.

  Lemma mm_syscall:
    forall lhs rhses mp p src_m tgt_m
      (MM: match_mem (inst_gd (Inst.syscall lhs rhses) mp) src_m tgt_m)
      ev sev
      (EVENT: ev = ProgramEvent.syscall sev)
      (ATOMIC: is_atomic_event ev)
      i_tgt o p1 mem_tgt
      (INPUT: SeqEvent.wf_input ev i_tgt)
      (OUTPUT: Oracle.wf_output ev o)
      (STEP_TGT: SeqEvent.step i_tgt o p tgt_m p1 mem_tgt)
    ,
    exists (i_src : SeqEvent.input) (mem_src : SeqMemory.t),
      SeqEvent.step i_src o p src_m p1 mem_src /\
      SeqEvent.input_match (to_deferred (inst_gd (Inst.syscall lhs rhses) mp)) (to_deferred mp) i_src i_tgt /\
      SeqEvent.wf_input ev i_src /\
      match_mem mp mem_src mem_tgt.
  Proof.
    i. subst ev.
    hexploit step_acq_rel2; eauto. ss. i; des.
    do 2 eexists. split; eauto.
    hexploit red_acq_rel2_full. 6: eapply STEP_TGT. 2: eapply ATOMIC. 1,2,3,4: ss. i; des.
    hexploit red_acq_rel2_full. 6: eapply STEP_SRC. 2: eapply ATOMIC. 1,2,3,4: ss. i; des.
    clear PERM0. subst i_src i_tgt p1. rewrite OO in OO0. inv OO0.
    unfold inst_gd, Opt2.inst_gd, mk_global in *. ss.
    apply mm_bot in MM. subst tgt_m. splits; ss.
    - econs; ss; eauto.
      { econs; eauto. refl. }
      { econs; eauto. ii. unfold to_deferred. unfold_flags. ss. rewrite flag_join_bot_r. refl. }
      { econs; eauto.
        { i. unfold_many. refl. }
        ii. refl.
      }
    - destruct mem_src, mem_tgt. ss. rewrite MEMV, MEMF, MEMV0, MEMF0; clear MEMV MEMF MEMV0 MEMF0.
      unfold_many.
      ii. ss. apply mcell_refl.
  Qed.

  Lemma mm_at:
    forall mp p src_m tgt_m inst
      (MM: match_mem (inst_gd inst mp) src_m tgt_m)
      ev
      (EVENT: match_inst_pe inst ev)
      (ATOMIC: is_atomic_event ev)
      i_tgt o p1 mem_tgt
      (INPUT: SeqEvent.wf_input ev i_tgt)
      (OUTPUT: Oracle.wf_output ev o)
      (STEP_TGT: SeqEvent.step i_tgt o p tgt_m p1 mem_tgt)
    ,
    exists (i_src : SeqEvent.input) (mem_src : SeqMemory.t),
      SeqEvent.step i_src o p src_m p1 mem_src /\
      SeqEvent.input_match (to_deferred (inst_gd inst mp)) (to_deferred mp) i_src i_tgt /\
      SeqEvent.wf_input ev i_src /\
      match_mem mp mem_src mem_tgt.
  Proof.
    i. destruct ev; try by ss. all: inv EVENT.
    eapply mm_load_at; eauto. eapply mm_update_failure_at; eauto.
    eapply mm_store_at; eauto. eapply mm_update_success_at; eauto.
    eapply mm_fence; eauto. eapply mm_syscall; eauto.
  Qed.

End MATCH.


(*TODO: These imports should be pared down*)
Require Import FSets.
Require FSetAVL.
Require Import Coqlib.
Require Import Errors.
Require Import compcert.lib.Ordered.
Require Import AST.
Require Import Maps.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
Require Import Events.

Require Import Ctypes.
Require Import Cop.

Require Import VST.sepcomp.mem_lemmas.
Require Import VST.sepcomp.reach.

(** Properties of values obtained by casting to a given type. *)

Inductive val_casted: val -> type -> Prop :=
  | val_casted_int: forall sz si attr n,
      cast_int_int sz si n = n ->
      val_casted (Vint n) (Tint sz si attr)
  | val_casted_float: forall sz attr n,
      cast_float_float sz n = n ->
      val_casted (Vfloat n) (Tfloat sz attr)
  | val_casted_long: forall si attr n,
      val_casted (Vlong n) (Tlong si attr)
  | val_casted_ptr_ptr: forall b ofs ty attr,
      val_casted (Vptr b ofs) (Tpointer ty attr)
  | val_casted_int_ptr: forall n ty attr,
      val_casted (Vint n) (Tpointer ty attr)
  | val_casted_ptr_int: forall b ofs si attr,
      val_casted (Vptr b ofs) (Tint I32 si attr)
  | val_casted_ptr_cptr: forall b ofs id attr,
      val_casted (Vptr b ofs) (Tcomp_ptr id attr)
  | val_casted_int_cptr: forall n id attr,
      val_casted (Vint n) (Tcomp_ptr id attr)
  | val_casted_struct: forall id fld attr b ofs,
      val_casted (Vptr b ofs) (Tstruct id fld attr)
  | val_casted_union: forall id fld attr b ofs,
      val_casted (Vptr b ofs) (Tunion id fld attr)
  | val_casted_void: forall v,
      val_casted v Tvoid.

Definition val_casted_func (v : val) (t : type) : bool :=
  match v, t with
    | Vint n, Tint sz si attr =>
      if Int.eq_dec (cast_int_int sz si n) n then true
      else false
    | Vfloat n, Tfloat sz attr =>
      if Float.eq_dec (cast_float_float sz n) n then true
      else false
    | Vlong n, Tlong si attr => true
    | Vptr b ofs, Tpointer ty attr => true
    | Vint n, Tpointer ty attr => true
    | Vptr b ofs, Tint I32 si attr => true
    | Vptr b ofs, Tcomp_ptr id attr => true
    | Vint n, Tcomp_ptr id attr => true
    | Vptr b ofs, Tstruct id flt attr => true
    | Vptr b ofs, Tunion id flt attr => true
    | _, Tvoid => true
    | _, _ => false
  end.

Lemma val_casted_funcI v t :
  val_casted v t ->
  val_casted_func v t=true.
Proof.
destruct 1; simpl; auto.
rewrite H. case_eq (Int.eq_dec n n); auto.
rewrite H. case_eq (Float.eq_dec n n); auto.
destruct v; auto.
Qed.

Lemma val_casted_funcE v t :
  val_casted_func v t=true ->
  val_casted v t.
Proof.
destruct v; destruct t; simpl; try solve[inversion 1;econstructor; eauto].
case_eq (Int.eq_dec (cast_int_int i0 s i) i). intros e _ _.
constructor; auto. intros n _; inversion 1.
case_eq (Float.eq_dec (cast_float_float f0 f) f). intros e _ _.
constructor; auto. intros n _; inversion 1.
destruct i0; try inversion 1. constructor.
Qed.

Lemma val_casted_funcP v t :
  val_casted_func v t=true <-> val_casted v t.
Proof.
split; [apply val_casted_funcE|apply val_casted_funcI].
Qed.

Remark cast_int_int_idem:
  forall sz sg i, cast_int_int sz sg (cast_int_int sz sg i) = cast_int_int sz sg i.
Proof.
  intros. destruct sz; simpl; auto.
  destruct sg; [apply Int.sign_ext_idem|apply Int.zero_ext_idem]; compute; intuition congruence.
  destruct sg; [apply Int.sign_ext_idem|apply Int.zero_ext_idem]; compute; intuition congruence.
  destruct (Int.eq i Int.zero); auto.
Qed.

Remark cast_float_float_idem:
  forall sz f, cast_float_float sz (cast_float_float sz f) = cast_float_float sz f.
Proof.
  intros; destruct sz; simpl.
  apply Float.singleoffloat_idem; auto.
  auto.
Qed.

Lemma cast_val_is_casted:
  forall v ty ty' v', sem_cast v ty ty' = Some v' -> val_casted v' ty'.
Proof.
  unfold sem_cast; intros. destruct ty'; simpl in *.
(* void *)
  constructor.
(* int *)
  destruct i; destruct ty; simpl in H; try discriminate; destruct v; inv H.
  constructor. apply (cast_int_int_idem I8 s).
  constructor. apply (cast_int_int_idem I8 s).
  destruct (cast_float_int s f0); inv H1.   constructor. apply (cast_int_int_idem I8 s).
  constructor. apply (cast_int_int_idem I16 s).
  constructor. apply (cast_int_int_idem I16 s).
  destruct (cast_float_int s f0); inv H1.   constructor. apply (cast_int_int_idem I16 s).
  constructor. auto.
  constructor.
  constructor. auto.
  destruct (cast_float_int s f0); inv H1. constructor. auto.
  constructor. auto.
  constructor.
  constructor; auto.
  constructor.
  constructor; auto.
  constructor; auto.
  constructor; auto.
  constructor; auto.
  constructor. simpl. destruct (Int.eq i0 Int.zero); auto.
  constructor. simpl. destruct (Int64.eq i Int64.zero); auto.
  constructor. simpl. destruct (Float.cmp Ceq f0 Float.zero); auto.
  constructor. simpl. destruct (Int.eq i Int.zero); auto.
  constructor; auto.
  constructor. simpl. destruct (Int.eq i Int.zero); auto.
  constructor; auto.
  constructor. simpl. destruct (Int.eq i Int.zero); auto.
  constructor; auto.
  constructor. simpl. destruct (Int.eq i0 Int.zero); auto.
  constructor; auto.
(* long *)
  destruct ty; try discriminate.
  destruct v; inv H. constructor.
  destruct v; inv H. constructor.
  destruct v; try discriminate. destruct (cast_float_long s f0); inv H. constructor.
  destruct v; inv H. constructor.
  destruct v; inv H. constructor.
  destruct v; inv H. constructor.
  destruct v; inv H. constructor.
(* float *)
  destruct ty; simpl in H; try discriminate; destruct v; inv H.
  constructor. unfold cast_float_float, cast_int_float.
  destruct f; destruct s; auto.
  rewrite Float.singleofint_floatofint. apply Float.singleoffloat_idem.
  rewrite Float.singleofintu_floatofintu. apply Float.singleoffloat_idem.
  constructor. unfold cast_float_float, cast_long_float.
  destruct f; destruct s; auto. apply Float.singleoflong_idem. apply Float.singleoflongu_idem.
  constructor. apply cast_float_float_idem.
(* pointer *)
  destruct ty; simpl in H; try discriminate; destruct v; inv H; try constructor.
(* impossible cases *)
  discriminate.
  discriminate.
(* structs *)
  destruct ty; try discriminate; destruct v; try discriminate.
  destruct (ident_eq i0 i && fieldlist_eq f0 f); inv H; constructor.
(* unions *)
  destruct ty; try discriminate; destruct v; try discriminate.
  destruct (ident_eq i0 i && fieldlist_eq f0 f); inv H; constructor.
(* comp_ptr *)
  destruct ty; simpl in H; try discriminate; destruct v; inv H; constructor.
Qed.

Lemma val_casted_load_result:
  forall v ty chunk,
  val_casted v ty -> access_mode ty = By_value chunk ->
  Val.load_result chunk v = v.
Proof.
  intros. inversion H; clear H; subst v ty; simpl in H0.
  destruct sz.
  destruct si; inversion H0; clear H0; subst chunk; simpl in *; congruence.
  destruct si; inversion H0; clear H0; subst chunk; simpl in *; congruence.
  clear H1. inv H0. auto.
  inversion H0; clear H0; subst chunk. simpl in *.
  destruct (Int.eq n Int.zero); subst n; reflexivity.
  destruct sz; inversion H0; clear H0; subst chunk; simpl in *; congruence.
  inv H0; auto.
  inv H0; auto.
  inv H0; auto.
  inv H0; auto.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
Qed.

Lemma cast_val_casted:
  forall v ty, val_casted v ty -> sem_cast v ty ty = Some v.
Proof.
  intros. inversion H; clear H; subst v ty; unfold sem_cast; simpl; auto.
  destruct sz; congruence.
  congruence.
  unfold proj_sumbool; repeat rewrite dec_eq_true; auto.
  unfold proj_sumbool; repeat rewrite dec_eq_true; auto.
Qed.

Lemma val_casted_inject:
  forall f v v' ty,
  val_inject f v v' -> val_casted v ty -> val_casted v' ty.
Proof.
  intros. inv H; auto.
  inv H0; constructor.
  inv H0; constructor.
Qed.

Inductive val_casted_list: list val -> typelist -> Prop :=
  | vcl_nil:
      val_casted_list nil Tnil
  | vcl_cons: forall v1 vl ty1 tyl,
      val_casted v1 ty1 -> val_casted_list vl tyl ->
      val_casted_list (v1 :: vl) (Tcons  ty1 tyl).

Lemma val_casted_list_params:
  forall params vl,
  val_casted_list vl (type_of_params params) ->
  list_forall2 val_casted vl (map snd params).
Proof.
  induction params; simpl; intros.
  inv H. constructor.
  destruct a as [id ty]. inv H. constructor; auto.
Qed.

Fixpoint val_casted_list_func (vs : list val) (ts : typelist) : bool :=
  match vs, ts with
    | nil, Tnil => true
    | v1 :: vl, Tcons ty1 tyl =>
      val_casted_func v1 ty1 && val_casted_list_func vl tyl
    | _, _ => false
  end.

Lemma val_casted_list_funcP vs ts :
  val_casted_list_func vs ts=true <-> val_casted_list vs ts.
Proof.
revert ts; induction vs. destruct ts; simpl; auto.
split; auto. intros _. constructor.
split; auto. inversion 1. inversion 1.
split; auto. destruct ts; simpl; auto.
inversion 1. rewrite andb_true_iff. intros [H1 H2]. constructor.
apply val_casted_funcE in H1; auto. rewrite <-IHvs; auto.
inversion 1; subst. simpl. rewrite andb_true_iff; split.
apply val_casted_funcI; auto. rewrite IHvs; auto.
Qed.

Lemma val_casted_inj (j : meminj) v1 v2 tv :
  val_inject j v1 v2 ->
  val_casted v1 tv ->
  val_casted v2 tv.
Proof.
inversion 1; subst; auto.
inversion 1; subst; auto; try solve[constructor; auto].
inversion 1; constructor.
Qed.

Lemma val_casted_list_inj (j : meminj) vs1 vs2 ts :
  val_list_inject j vs1 vs2 ->
  val_casted_list vs1 ts ->
  val_casted_list vs2 ts.
Proof.
intros H1; revert vs1 vs2 H1; induction ts; simpl; intros vs1 vs2 H1 H2.
revert H2 H1; inversion 1; subst. inversion 1; subst. constructor.
revert H2 H1; inversion 1; subst. inversion 1; subst. constructor.
eapply val_casted_inj; eauto.
eapply IHts; eauto.
Qed.

Definition val_has_type_func (v : val) (t : typ) : bool :=
  match v with
    | Vundef => true
    | Vint _ => match t with
                  | AST.Tint => true
                  | _ => false
                end
    | Vlong _ => match t with
                 | AST.Tlong => true
                 | _ => false
               end
    | Vfloat f => match t with
                    | AST.Tfloat => true
                    | Tsingle => if Float.is_single_dec f then true else false
                    | _ => false
                  end
    | Vptr _ _ => match t with
                    | AST.Tint => true
                    | _ => false
                  end
  end.

Lemma val_has_type_funcP v t :
  Val.has_type v t <-> (val_has_type_func v t=true).
Proof.
split.
induction v; auto.
simpl. destruct t; auto.
simpl. destruct t; auto.
simpl. destruct t; auto. destruct (Float.is_single_dec f); auto.
simpl. destruct t; auto.
induction v; simpl; auto.
destruct t; auto; try inversion 1.
destruct t; auto; try inversion 1.
destruct t; auto; try solve[inversion 1].
destruct (Float.is_single_dec f); try solve[inversion 1|auto].
destruct t; auto. inversion 1. inversion 1. inversion 1.
Qed.

Fixpoint val_has_type_list_func (vl : list val) (tyl : list typ) : bool :=
  match vl, tyl with
    | nil, nil => true
    | v :: vl', ty :: tyl' => val_has_type_func v ty
                              && val_has_type_list_func vl' tyl'
    | nil, _ :: _ => false
    | _ :: _, nil => false
  end.

Lemma val_has_type_list_func_charact vl tyl :
  Val.has_type_list vl tyl <-> (val_has_type_list_func vl tyl=true).
Proof.
revert tyl; induction vl.
destruct tyl. simpl. split; auto. simpl. split; auto. inversion 1.
intros. destruct tyl. simpl. split; auto. inversion 1.
simpl. split. intros [H H2].
+ rewrite andb_true_iff. split.
  rewrite <-val_has_type_funcP; auto.
  rewrite <-IHvl; auto.
+ rewrite andb_true_iff. intros [H H2]. split.
  rewrite val_has_type_funcP; auto.
  rewrite IHvl; auto.
Qed.

Fixpoint tys_nonvoid (tyl : typelist) :=
  match tyl with
    | Tnil => true
    | Tcons Tvoid tyl' => false
    | Tcons _ tyl' => tys_nonvoid tyl'
  end.

Fixpoint vals_defined (vl : list val) :=
  match vl with
    | nil => true
    | Vundef :: _ => false
    | _ :: vl' => vals_defined vl'
  end.

Lemma vals_inject_defined (vl1 vl2 : list val) (j : meminj) :
  val_list_inject j vl1 vl2 ->
  vals_defined vl1=true ->
  vals_defined vl2=true.
Proof.
revert vl2; induction vl1; simpl. destruct vl2; try solve[inversion 1|auto].
intros vl2; inversion 1; subst. destruct a; try solve[inversion 1].
inv H. inv H5. simpl. intros X. rewrite (IHvl1 vl'); auto.
inv H. inv H5. simpl. intros X. rewrite (IHvl1 vl'); auto.
inv H. inv H5. simpl. intros X. rewrite (IHvl1 vl'); auto.
inv H. inv H5. simpl. intros X. rewrite (IHvl1 vl'); auto.
Qed.

Lemma valinject_hastype':
  forall (j : meminj) (v v' : val),
    val_inject j v v' ->
    v <> Vundef ->
    forall T : typ, Val.has_type v T -> Val.has_type v' T.
Proof.
  intros.
  induction H; auto.
  elim H0; auto.
Qed.

Lemma val_list_inject_hastype j vl1 vl2 tys :
  val_list_inject j vl1 vl2 ->
  vals_defined vl1=true ->
  val_has_type_list_func vl1 tys=true ->
  val_has_type_list_func vl2 tys=true.
Proof.
revert vl2 tys. induction vl1. inversion 1. solve[destruct tys; simpl; auto].
intros H tys H1 H2 H3. inv H1.
assert (def: vals_defined vl1=true).
{ inv H2. revert H0. destruct a; auto. congruence. }
simpl. destruct tys. simpl in H3; congruence.
rewrite andb_true_iff. split.
rewrite <-val_has_type_funcP. eapply valinject_hastype'; eauto.
simpl in H2. intros contra. rewrite contra in H2. congruence.
inv H3. rewrite andb_true_iff in H0.
  destruct H0 as [H0 _]. solve[rewrite val_has_type_funcP; auto].
eapply (IHvl1 vl'); eauto.
inv H3. rewrite H0. rewrite andb_true_iff in H0.
  solve[destruct H0 as [_ ->]; auto].
Qed.

Lemma val_list_inject_defined j vl1 vl2 :
  val_list_inject j vl1 vl2 ->
  vals_defined vl1=true ->
  vals_defined vl2=true.
Proof.
revert vl2. induction vl1; simpl.
+ intros vl2; inversion 1; auto.
+ intros vl2; inversion 1; subst. inv H.
simpl. intros H8.
assert (def1: vals_defined vl1=true).
{ destruct a; try solve[congruence]. }
revert H2 H8. inversion 1; auto. subst. congruence.
Qed.

(*TODO: put these in Events.v*)
Fixpoint encode_longs (tyl : list typ) (vl : list val) :=
  match tyl with
    | nil => nil
    | AST.Tlong :: tyl' =>
      match vl with
        | nil => nil
        | Vlong n :: vl' => Vint (Int64.hiword n) :: Vint (Int64.loword n)
                            :: encode_longs tyl' vl'
        | Vundef :: vl' => Vundef :: Vundef :: encode_longs tyl' vl'
        | _ :: vl' => Vundef :: Vundef :: encode_longs tyl' vl'
      end
    | t :: tyl' =>
      match vl with
        | nil => nil
        | v :: vl' => v :: encode_longs tyl' vl'
      end
  end.

Fixpoint encode_typs (tyl : list typ) : list typ :=
  match tyl with
    | nil => nil
    | AST.Tlong :: tyl' => AST.Tint :: AST.Tint :: encode_typs tyl'
    | t :: tyl' => t :: encode_typs tyl'
  end.

Lemma encode_longs_has_type tyl vl :
  Val.has_type_list vl tyl ->
  Val.has_type_list (encode_longs tyl vl) (encode_typs tyl).
Proof.
revert vl; induction tyl. simpl; auto.
destruct vl. intros; contradiction. intros [H H2]. simpl.
destruct a; try solve[split; auto].
destruct v; simpl; auto.
Qed.

Lemma decode_encode_longs tyl vl :
  Val.has_type_list vl tyl ->
  decode_longs tyl (encode_longs tyl vl) = vl.
Proof.
revert tyl; induction vl.
destruct tyl. simpl; auto.
destruct t; simpl; auto.
destruct tyl. simpl. inversion 1. inversion 1; subst. clear H.
simpl. destruct t; auto; try rewrite IHvl; auto.
destruct a; simpl; try solve[inv H0].
rewrite IHvl; auto.
rewrite IHvl; auto. f_equal.
rewrite Int64.ofwords_recompose; auto.
Qed.

Lemma encode_longs_inject:
  forall (f : meminj) (tyl : list typ) (vl1 vl2 : list val),
  val_list_inject f vl1 vl2 ->
  val_list_inject f (encode_longs tyl vl1) (encode_longs tyl vl2).
Proof.
intros until vl2; intros H; revert tyl; induction H; simpl.
destruct tyl; simpl; [solve[constructor]|]. solve[destruct t; auto].
destruct tyl; simpl; [solve[constructor]|]. destruct t.
solve[constructor; auto].
solve[constructor; auto].
inv H. solve[auto]. constructor; auto. solve[auto]. solve[auto].
destruct v'; solve[auto|constructor; auto].
solve[constructor; auto].
Qed.

Fixpoint getBlocks' (vl : list val) (b0 : block) :=
  match vl with
    | nil => false
    | Vptr b _ :: vl' => eq_block b b0 || getBlocks' vl' b0
    | _ :: vl' => getBlocks' vl' b0
  end.

Lemma getBlocks_getBlocks' vl b0 : getBlocks vl b0 = getBlocks' vl b0.
Proof.
induction vl; simpl; auto.
destruct a; auto. unfold getBlocks. simpl.
destruct (eq_block b b0); simpl; auto.
rewrite <-IHvl. unfold getBlocks.
destruct (
     in_dec eq_block b0
       (fold_right
          (fun (v : val) (L : list block) =>
           match v with
           | Vundef => L
           | Vint _ => L
           | Vlong _ => L
           | Vfloat _ => L
           | Vptr b' _ => b' :: L
           end) nil vl)
); auto.
Qed.

Lemma getBlocks_encode_longs tys vals b :
  getBlocks (encode_longs tys vals) b=true ->
  getBlocks vals b=true.
Proof.
  rewrite !getBlocks_getBlocks'.
  revert tys; induction vals; simpl; auto. destruct tys. simpl; auto.
  solve[destruct t; simpl; auto].
  destruct tys. simpl; congruence.
  simpl. destruct t; destruct a; simpl; intros; try solve[eapply IHvals; eauto].
  rewrite orb_true_iff in H. destruct H. rewrite H; auto.
    rewrite orb_true_iff. right. solve[eapply IHvals; eauto].
  rewrite orb_true_iff in H. destruct H. rewrite H; auto.
    rewrite orb_true_iff. right. solve[eapply IHvals; eauto].
  rewrite orb_true_iff. right. solve[eapply IHvals; eauto].
  rewrite orb_true_iff in H. destruct H. rewrite H; auto.
    rewrite orb_true_iff. right. solve[eapply IHvals; eauto].
Qed.

Lemma val_casted_has_type a t :
  tys_nonvoid (Tcons t Tnil) = true ->
  val_casted_func a t = true ->
  val_has_type_func a (typ_of_type t) = true.
Proof.
intros H0 H.
apply val_casted_funcE in H.
induction H; try solve[auto].
destruct H. destruct sz. simpl.
generalize (Float.singleoffloat_is_single n0).
destruct (Float.is_single_dec (Float.singleoffloat n0)); auto. auto.
simpl in H0. congruence.
Qed.

Lemma val_casted_has_type_list vals tys :
  tys_nonvoid tys = true ->
  val_casted_list_func vals tys = true ->
  val_has_type_list_func vals (typlist_of_typelist tys) = true.
Proof.
revert vals; induction tys. simpl. intros vals.
destruct vals. simpl; auto. simpl. solve[inversion 2].
simpl; intros vals; revert tys IHtys; induction vals. simpl.
  intros; congruence.
simpl; intros. rewrite andb_true_iff in H0; destruct H0 as [H0 H2].
assert (H3: tys_nonvoid tys = true).
{ destruct t; solve[congruence|auto]. }
rewrite andb_true_iff. split; auto.
apply val_casted_has_type; auto. destruct t; auto.
Qed.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
Require Epsilon.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import ssrZ ZArith_ext seq_ext uniq_tac machine_int multi_int.
Require Import encode_decode integral_type.
Import MachineInt.
Require Import mips_bipl mips_seplog mips_tactics mips_syntax mips_mint.
Import mips_bipl.expr_m.
Require Import simu.
Import simu.simu_m.
Require Import multi_double_u_prg multi_double_u_triple.

Local Open Scope zarith_ext_scope.
Local Open Scope machine_int_scope.
Local Open Scope heap_scope.
Local Open Scope assoc_scope.
Local Open Scope uniq_scope.
Local Open Scope simu_scope.

(** x <- x * 2, x unsigned *)

Lemma pfwd_sim_double_u (x : bipl.var.v) (d : assoc.t) (rk rx a0 a1 a2 a3 : reg) :
  uniq(rk, rx, a0, a1, a2, a3, r0) ->
  disj (mints_regs (assoc.cdom d)) (a0 :: a1 :: a2 :: a3 :: nil) ->
  x \notin assoc.dom d -> unsign rk rx \notin assoc.cdom d ->
  (x <- var_e x \* nat_e 2)%pseudo_expr%pseudo_cmd
    <=p( state_mint (x |=> unsign rk rx \U+ d), fun s st h =>
         ([ x ]_ s)%pseudo_expr < 2 ^^ ('|u2Z ([ rk ]_st)%asm_expr| * 32 - 1))
  multi_double_u rk rx a0 a1 a2 a3.
Proof.
move=> Haux Hd Hd' Hd''.
rewrite /pfwd_sim.
move=> s st h [s_st_h x_k] s' exec_pseudo st' h' exec_mips.
have d_unchanged : forall v r, assoc.get v d = Some r ->
    disj (mint_regs r) (mips_frame.modified_regs (multi_double_u rk rx a0 a1 a2 a3)).
  move=> v r Hvr; rewrite [mips_frame.modified_regs _]/=; Disj_remove_dup.
  apply (disj_incl_LR Hd); last by apply incl_refl_Permutation; PermutProve.
  exact/incP/inc_mint_regs/(assoc.get_Some_in_cdom _ v).
set k := '|u2Z ([rk ]_ st)%asm_expr|.
move/multi_double_u_triple : (Haux).
move/(_ '|u2Z ([rk ]_ st)%asm_expr| ([rx ]_ st)%asm_expr
  (state_mint_head_unsign_fit _ _ _ _ _ _ _ s_st_h) (Z2ints 32 k ([var_e x ]e_ s)%pseudo_expr)).
rewrite size_Z2ints.
move/(_ Logic.eq_refl) => hoare_triple_double_u.

have [st'' [h'' exec_mips_proj]] : exists st'' h'',
  (Some (st, heap.proj h (heap.dom (heap_mint (unsign rk rx) st h)))
  -- multi_double_u rk rx a0 a1 a2 a3 ---> Some (st'', h''))%mips_cmd.
  exists st', (heap.proj h' (heap.dom (heap_mint (unsign rk rx) st h))).
  move/mips_syntax.triple_exec_proj : hoare_triple_double_u; apply => //.
  split; first by [].
  split; first by rewrite Z_of_nat_Zabs_nat //; apply min_u2Z.
  rewrite /heap_cut heap.proj_dom_proj.
  apply (state_mint_var_mint _ _ _ _ x (unsign rk rx)) in s_st_h; last by assoc_get_Some.
  rewrite /var_mint in s_st_h.
  by case: s_st_h => _ [_ ?].

set postcond := (fun s h => exists _, _) in hoare_triple_double_u.
have {hoare_triple_double_u}hoare_triple_post_condition : ( postcond ** assert_m.TT)%asm_assert
     st' h'.
    move: (mips_frame.frame_rule_R _ _ _ hoare_triple_double_u assert_m.TT (assert_m.inde_TT _) (mips_frame.inde_cmd_mult_TT _)).
    move/mips_seplog.hoare_prop_m.soundness.
    rewrite /while.hoare_semantics.
    move/(_ st h) => Hdouble_u.
    lapply Hdouble_u; last first.
      exists (heap_mint (unsign rk rx) st h), (h \D\ heap.dom (heap_mint (unsign rk rx) st h)).
      split; first by apply heap.disj_difs', seq_ext.inc_refl.
      split.
        apply heap.union_difsK => //; by apply heap.inclu_proj.
      split; last by [].
      split; first by [].
      split.
      rewrite Z_of_nat_Zabs_nat //; by apply min_u2Z.
      move: (state_mint_var_mint _ s st h x (unsign rk rx) s_st_h).
        rewrite assoc.get_union_sing_eq.
        case/(_ refl_equal) => ? ? ?; tauto.
    move=> {Hdouble_u} [Hdouble_u Hdouble_u'].
    by move: {Hdouble_u'}(Hdouble_u' _ _ exec_mips).
split.
- move=> y ry y_ry.
  have [yx | yx] : y \in assoc.dom d \/ y = x.
    case/assoc.get_union_Some_inv : y_ry => y_ry.
    * by case/assoc.get_sing_inv : y_ry => -> _; right.
    * by apply assoc.get_Some_in_dom in y_ry; left.
  + (* y \in assoc.dom d *) have x_y : y <> x.
      move=> ?; subst y; by rewrite yx in Hd'.
    move: {s_st_h}(proj1 s_st_h _ _ y_ry) (proj2 s_st_h) => s_st_h1 s_st_h2.
    have y_unchanged : ([ y ]_s = [ y ]_s')%pseudo_expr.
      Var_unchanged. rewrite /= mem_seq1; exact/negP/eqP.
    case: (mips_syntax.exec_deter_proj _ _ _ _ _ exec_mips
      (heap.dom (heap_mint (unsign rk rx) st h)) _ _ exec_mips_proj) => H4 [H5 H_h_h'].
    have <- : heap_mint ry st h = heap_mint ry st' h'.
      apply (heap_mint_state_invariant (heap_mint (unsign rk rx) st h) y s) => //.
      move=> rx0 Hrx0; Reg_unchanged.
      apply (@disj_not_In _ (mint_regs ry)); last by [].
      apply/disj_sym/(d_unchanged y).
      by rewrite -y_ry assoc.get_union_sing_neq.
      apply s_st_h2 with y x => //.
      by rewrite assoc.get_union_sing_eq.
    move: s_st_h1; apply var_mint_invariant.
    move=> rx0 Hrx0; Reg_unchanged.
    apply (@disj_not_In _ (mint_regs ry)); last by [].
    apply/disj_sym/(d_unchanged y) => //.
    by rewrite -y_ry assoc.get_union_sing_neq.
    Var_unchanged; rewrite /= mem_seq1; exact/negP/eqP.
  + (* yx : y = x *) subst y.
    have ? : ry = unsign rk rx.
      rewrite assoc.get_union_sing_eq in y_ry.
      by case: y_ry.
    subst ry.
    set vx := u2Z ([ rx ]_ st)%asm_expr.
    set k' := '| u2Z ([ rk ]_ st')%asm_expr |.
    set vx' := u2Z ([ rx ]_ st')%asm_expr.
  move: (state_mint_var_mint _ s st h x (unsign rk rx) s_st_h).
    rewrite assoc.get_union_sing_eq.
    case/(_ refl_equal) => X1 X2 X3.
    case : hoare_triple_post_condition => h1 [h2 [Hdisj [Hunion [[A' [Hmul2_1 [Hmul2_2 [Hmul2_3 [Hmul2_4 Hmul2_5]]]]] HTT]]]].

    have k_k' : k = k' by rewrite /k /k' Hmul2_3 Z_of_nat_Zabs_nat //; apply min_u2Z.
    subst k'.
    apply mkVarUnsign.
    + by rewrite -k_k' Hmul2_2.
    + split.
      - move/syntax_m.seplog_m.semop_prop_m.exec_cmd0_inv : exec_pseudo.
        case/syntax_m.seplog_m.exec0_assign_inv => _ -> /=.
        syntax_m.seplog_m.assert_m.expr_m.Store_upd.
        apply mulZ_ge0 => //; tauto.
      - move/syntax_m.seplog_m.semop_prop_m.exec_cmd0_inv : exec_pseudo.
        case/syntax_m.seplog_m.exec0_assign_inv => _ -> /=.
        syntax_m.seplog_m.assert_m.expr_m.Store_upd.
        rewrite /ZIT.mul mulZC.
        case : (ltnP 0 k) => Hk'; last first.
          rewrite leqn0 in Hk'. move/eqP in Hk'.
          rewrite -/k Hk' ZbetaE mul0n /= in X2.
          have {}X2 : ([x]_s = 0)%pseudo_expr by lia.
          rewrite X2 mulZ0; by apply Zbeta_gt0.
        - rewrite -k_k' ZbetaE (_ : k * 32 = S (k * 32 - 1))%nat; last first.
            by rewrite -subSn // ?subn1 // muln_gt0 Hk'.
          rewrite ZpowerS; exact/ltZ_pmul2l.
    + apply mapstos_inv_list2heap in Hmul2_4 => //; last first.
        by rewrite [eval _ _]/= Hmul2_2 Hmul2_1.
      rewrite u2Z_shrl' in Hmul2_4; last by repeat constructor.
      rewrite /= Hmul2_2 in Hmul2_4.
      rewrite /heap_cut Hunion Hmul2_4.
      move/syntax_m.seplog_m.semop_prop_m.exec_cmd0_inv : exec_pseudo.
      case/syntax_m.seplog_m.exec0_assign_inv => _ -> /=.
      syntax_m.seplog_m.assert_m.expr_m.Store_upd.
      rewrite lSum_Z2ints_pos // [ ( [ _ ]e_ _ )%pseudo_expr ]/= in Hmul2_5.
      rewrite /ZIT.mul mulZC.
      case: (zerop k) => Hk'.
      - rewrite -k_k' Hk' Z2ints_0 /= /heap_cut heap.proj_nil.
        split; last by [].
        move/assert_m.mapstos_inv_addr : X3 => /=.
        by rewrite Hmul2_2.
      - have Htmp : u2Z ([a2 ]_st')%asm_expr = 0.
          have Htmp1 : 2 * ([ x ]_ s)%pseudo_expr < 2 ^^ (k * 32).
            rewrite (_ : k * 32 = S (k * 32 - 1))%nat; last first.
              move/ltP in Hk'.
              by rewrite -subSn // ?subn1 // muln_gt0 Hk'.
            rewrite ZpowerS; exact/ltZ_pmul2l.
          rewrite -Hmul2_5 in Htmp1.
          move: (min_u2Z ([a2]_st')%asm_expr).
          case/leZ_eqVlt => Htmp2 //.
          rewrite addZC mulnC in Htmp1. (* TODO *)
          move/(poly_Zlt1_inv _ _ _ (min_lSum _ _) (min_u2Z _) (expZ_ge0 _)) : Htmp1 => Htmp1.
          rewrite Htmp1 in Htmp2; by move/ltZZ : Htmp2.
        rewrite -Hmul2_5.
        rewrite Htmp.
        rewrite mul0Z addZ0.
        rewrite Z_of_nat_Zabs_nat in Hmul2_3.
        rewrite Hmul2_3.
        rewrite -Z2ints_lSum.
        rewrite /heap_cut.
        rewrite Hmul2_2.
        have <- : heap.dom (list2heap '|vx / 4| A') = iota '|vx / 4| k.
          by rewrite dom_list2heap Hmul2_1.
        rewrite heap.proj_union_L_dom; last by rewrite -Hmul2_4.
        rewrite heap.proj_itself.
        apply mapstos_list2heap.
        + rewrite Z_of_nat_Zabs_nat //; last first.
            apply Z_div_pos => //; by apply min_u2Z.
          rewrite -Zdivide_Zdiv_eq //.
          by rewrite -Hmul2_2.
          move/assert_m.mapstos_inv_addr : X3.
          by apply Zmod_divide.
        + rewrite /vx in X1.
          rewrite [eval _ _]/= Hmul2_2; lia.
        + by [].
        + by apply min_u2Z.
- apply (state_mint_part2_one_variable_unsign _ _ _ _ _ _ _ _ _ s_st_h).
  + move=> t x0 Ht Hx0.
    Reg_unchanged. simpl mips_frame.modified_regs.
    case/assoc.in_cdom_union_inv : Ht => Ht.
    * rewrite assoc.cdom_sing /= seq.mem_seq1 in Ht.
      move/eqP : Ht => Ht; subst t.
      apply (@disj_not_In _ (mint_regs (unsign rk rx))); last by [].
      simpl.
      Disj_remove_dup.
      by Disj_uniq r0.
    * apply (@disj_not_In _ (mint_regs t)); last by [].
      Disj_remove_dup.
      apply/disj_sym/(disj_incl_LR Hd); last by apply incl_refl_Permutation; PermutProve.
      exact/incP/inc_mint_regs.
  + move: (mips_syntax.exec_deter_proj _ _ _ _ _ exec_mips _ _ _ exec_mips_proj); tauto.
  + exact: (mips_syntax.dom_heap_invariant _ _ _ _ _ exec_mips).
Qed.


Require Import Kami.Syntax Kami.PPlusProperties.
Require Import Kami.Notations.
Require Import Kami.Compiler.CompilerSimpleSem.
Require Import Kami.Compiler.CompilerSimple.
Require Import Kami.Compiler.CompilerProps.
Require Import Kami.Compiler.Compiler.

Lemma RME_Simple_RME_Equiv map:
  forall old upds,
    Sem_RmeSimple (RmeSimple_of_RME map) (old, upds) ->
    SemRegMapExpr map (old, upds).
Proof.
  induction map; intros; try (inv H; EqDep_subst).
  - econstructor 1; eauto.
  - econstructor 2; eauto.
  - econstructor 3; eauto.
  - econstructor 4; eauto.
Qed.

Lemma CA_Simple_CA_Equiv {k : Kind} (ca : CompActionT type (RegsT * list RegsT) k) :
  forall regMap calls val,
    SemCompActionSimple (CompActionSimple_of_CA ca) regMap calls val ->
    SemCompActionT ca regMap calls val.
Proof.
  induction ca; intros; try ((inv H0 || inv H); EqDep_subst).
  - econstructor 1; eauto.
  - econstructor 2; eauto.
  - econstructor 3; eauto.
  - econstructor 4; eauto.
  - econstructor 5; eauto.
  - econstructor 6; eauto using RME_Simple_RME_Equiv.
  - econstructor 7; eauto.
    destruct regMap; inv HRegMapWf; econstructor; eauto using RME_Simple_RME_Equiv.
  - econstructor 8; eauto.
  - inv HSemCompActionSimple; simpl in *; EqDep_subst; rewrite unifyWO in *.
    inv HSemCompActionSimple_a; simpl in *; EqDep_subst.
    inv HRegMapWf; inv H0; EqDep_subst.
    econstructor 9; eauto using RME_Simple_RME_Equiv.
  - inv HSemCompActionSimple; simpl in *; EqDep_subst; rewrite unifyWO in *.
    inv HSemCompActionSimple_a; EqDep_subst.
    destruct regMap_a; inv HRegMapWf; inv H0; EqDep_subst.
    + inv HUpdate; EqDep_subst.
      econstructor 10; eauto using RME_Simple_RME_Equiv.
      * econstructor; eauto.
        econstructor; eauto using RME_Simple_RME_Equiv.
      * econstructor 10; eauto using RME_Simple_RME_Equiv.
        econstructor; eauto.
        eapply SemUpdRegMapFalse; eauto using RME_Simple_RME_Equiv.
    + econstructor 11; eauto using RME_Simple_RME_Equiv.
      econstructor; eauto using RME_Simple_RME_Equiv.
  - inv HSemCompActionSimple; simpl in *; EqDep_subst; rewrite unifyWO in *.
    inv HSemCompActionSimple_a; EqDep_subst.
    destruct regMap_a; inv HRegMapWf; inv H0; EqDep_subst;[|discriminate].
    econstructor 12; eauto.
    econstructor; eauto using RME_Simple_RME_Equiv.
  - inv HSemCompActionSimple; simpl in *; EqDep_subst; rewrite unifyWO in *.
    inv HSemCompActionSimple_a; EqDep_subst.
    destruct regMap_a; inv HRegMapWf; inv H0; EqDep_subst;[discriminate|].
    econstructor 13; eauto using RME_Simple_RME_Equiv.
    econstructor; eauto using RME_Simple_RME_Equiv.
  - inv HSemCompActionSimple; simpl in *; EqDep_subst; rewrite unifyWO in *.
    inv HSemCompActionSimple_a; simpl in *; EqDep_subst.
    inv HRegMapWf; destruct regMap_a.
    inv H0.
    econstructor 14; eauto using RME_Simple_RME_Equiv.
  - inv HSemCompActionSimple; simpl in *; EqDep_subst; rewrite unifyWO in *.
    inv HSemCompActionSimple_a; simpl in *; EqDep_subst.
    inv HRegMapWf; destruct regMap_a.
    econstructor 15; eauto using RME_Simple_RME_Equiv.
    inv H0.
    apply RME_Simple_RME_Equiv; auto.
Qed.

Lemma CA_Simple_Trace_CA_Trace_Equiv (ca : RegsT -> CompActionT type (RegsT * list RegsT) Void) :
  forall regInits o lupds lcalls,
    SemCompActionSimple_Trace regInits (fun s => CompActionSimple_of_CA (ca s)) o lupds lcalls ->
    SemCompTrace regInits ca o lupds lcalls.
Proof.
  induction 1;[econstructor 1 | econstructor 2]; eauto using CA_Simple_CA_Equiv.
Qed.

Lemma CompActionSimpleTraceEquiv (b : BaseModule) (lrf : list RegFileBase) o :
  let m := inlineAll_All_mod (mergeSeparatedSingle b lrf) in
  let regInits := (getRegisters b) ++ (concat (map getRegFileRegisters lrf)) in
  forall rules lupds lcalls
         (HWfMod : WfMod type (mergeSeparatedSingle b lrf))
         (HNoSelfCallsBase : NoSelfCallBaseModule b),
    SubList rules (getRules b) ->
    SemCompActionSimple_Trace regInits (fun s => CompActionSimple_of_CA
                                            (compileRulesRf type (s, nil)
                                                            rules lrf)) o lupds lcalls ->
    (forall upds u, In upds lupds -> In u upds -> (NoDup (map fst u)) /\
                                                  SubList (getKindAttr u) (getKindAttr o)) /\
    exists (lss : list (list (list FullLabel))),
      Forall2 (fun x y => x = (map getLabelUpds y)) lupds lss /\
      (forall x, In x lss -> (map Rle (map fst (rev rules))) = getLabelExecs (concat x)) /\
      Forall2 (fun x y => x = concat (map getLabelCalls (rev y))) lcalls lss /\
      Trace m o (concat lss).
Proof.
  intros; eapply CompTraceEquiv; eauto using CA_Simple_Trace_CA_Trace_Equiv.
Qed.