Require Import DataTypes Useful Channel Cache Compatible L1 Coq.Logic.Classical
Coq.Relations.Operators_Properties Coq.Relations.Relation_Operators List MsiState L1.
(*Require List.*)

Module Type LatestValueAxioms (dt: DataTypes) (ch: ChannelPerAddr dt).
  Import dt ch.

  Axiom toChild: forall {n a t p m}, defined n -> defined p ->
                   parent n p ->
                   mark mch p n a t m -> from m = MsiState.In -> dataM m = data p a t.
  Axiom fromParent: forall {n a t p m}, defined n -> defined p ->
                      parent n p ->
                      recv mch p n a t m -> from m = MsiState.In -> data n a (S t) = dataM m.
  Axiom toParent: forall {n a t c m}, defined n -> defined c ->
                     parent c n ->
                     mark mch c n a t m -> slt Sh (from m) -> dataM m = data c a t.
  Axiom fromChild: forall {n a t c m}, defined n -> defined c ->
                     parent c n ->
                     recv mch c n a t m -> slt Sh (from m) -> data n a (S t) = dataM m.

  Axiom initLatest: forall a, data hier a 0 = initData a /\ state hier a 0 = Mo.

  Axiom deqImpData: forall {a n t i}, defined n -> deqR a n i t ->
                                    desc (reqFn a n i) = St ->
                                    data n a (S t) = dataQ (reqFn a n i).

  Axiom changeData:
    forall {n a t}, defined n ->
      data n a (S t) <> data n a t ->
      (exists m, (exists p, defined p /\ parent n p /\ recv mch p n a t m /\ from m = MsiState.In) \/
                 (exists c, defined c /\ parent c n /\ recv mch c n a t m /\
                            slt Sh (from m))) \/
      exists i, deqR a n i t /\ desc (reqFn a n i) = St.

  Axiom deqImpNoSend: forall {c a i t}, defined c -> deqR a c i t ->
                                      forall {m p}, defined p ->
                                                    ~ mark mch c p a t m.
End LatestValueAxioms.

Module LatestValueTheorems (dt: DataTypes) (ch: ChannelPerAddr dt) (c: BehaviorAxioms dt ch)
       (l1: L1Axioms dt) (comp: CompatBehavior dt ch) (lv: LatestValueAxioms dt ch): L1Theorems dt l1.
  Module mbt := mkBehaviorTheorems dt ch c.
  Module cbt := mkCompat dt ch comp c.
  Import dt ch c l1 comp lv mbt cbt.

  Theorem uniqM:
    forall {c a t}, defined c ->
      leaf c ->
      state c a t = Mo -> forall {co}, defined co -> leaf co -> c <> co -> state co a t = MsiState.In.
  Proof.
    intros c a t defC leaf_c cM co defCo leaf_co c_ne_co.
    pose proof (noLeafsDesc leaf_c leaf_co c_ne_co) as desc1.
    assert (co_ne_c: co <> c) by auto.
    pose proof (noLeafsDesc leaf_co leaf_c co_ne_c) as desc2.
    pose proof (@nonDescCompat c co defC defCo desc1 desc2 a t) as st.
    rewrite cM in st.
    unfold sle in *; destruct (state co a t); firstorder.
  Qed.

  Theorem parentLeafFalse: forall {c p}, leaf c -> parent p c -> False.
  Proof.
    intros c p leafC p_c.
    unfold leaf in *; unfold parent in *.
    destruct c.
    destruct l0.
    unfold List.In in *.
    assumption.
    assumption.
  Qed.

  Theorem leafGood: forall {p n a t}, defined p -> defined n -> parent n p ->
                                      slt MsiState.In (dir p n a t) -> slt (state n a t) Mo ->
                                      forall {c i},
                                        defined c ->
                                        deqR a c i t -> desc (reqFn a c i) = St ->
                                        False.
  Proof.
    unfold not; intros p n a t defP defN n_p pGtI nLtM c i defC deqSt isSt.
    pose proof (deqLeaf deqSt) as leafC.
    pose proof (processDeq deqSt) as st; simpl in st.
    destruct (classic (descendent c p)) as [c_p | c_ne_p].
    destruct (classic (descendent c n)) as [c_n | c_ne_n].
    pose proof (@descSle c n defC defN c_n a t) as low.
    rewrite isSt in st.
    rewrite st in low.
    apply (slt_slei_false nLtM low).
    pose proof (clos_rt_rtn1 Tree parent c p c_p) as trans.
    destruct trans.
    apply (parentLeafFalse leafC n_p).
    pose proof (clos_rtn1_rt Tree parent c y trans) as c_y.
    pose proof (rt_step Tree parent y z H) as y_z.
    pose proof (rt_trans Tree parent y z hier y_z defP) as defY.
    clear trans y_z; fold descendent in *.
    assert (y_ne_n: n = y -> False).
    intros y_eq_n.
    rewrite y_eq_n in *.
    firstorder.
    pose proof (compatible defP a t defY H) as [_ good].
    specialize (good n defN y_ne_n n_p).
    pose proof (@descSle c y defC defY c_y a t) as low.
    rewrite isSt in st.
    rewrite st in low.
    pose proof (conservative defP defY H a t) as stuff.
    unfold sle in *; destruct (dir z y a t); destruct (dir z n a t);
    destruct (state y a t); auto.
    assert (sec: ~ descendent p c).
    unfold not; intros p_c.
    pose proof (clos_rt_rtn1 Tree parent p c p_c) as trans.
    destruct trans.
    firstorder.
    apply (parentLeafFalse leafC H).
    pose proof (@nonDescCompat c p defC defP c_ne_p sec a t) as contra.
    rewrite isSt in st.
    rewrite st in contra.
    pose proof (compatible defP a t defN n_p) as [good _].
    destruct (dir p n a t); destruct (state p a t); unfold slt in *; unfold sle in *;
    auto.
  Qed.

  Theorem leafGood2: forall {p n a t}, defined p -> defined n -> parent n p ->
                                       forall {m}, mark mch p n a t m ->
                                                   forall {c i},
                                                     defined c ->
                                                     deqR a c i t -> desc (reqFn a c i) = St ->
                                                     False.
  Proof.
    unfold not; intros p n a t defP defN n_p m markm c i defC deqSt isSt.
    pose proof (pSendUpgrade defP defN n_p markm) as dir_n_lt_M.
    pose proof (sendCCond defP defN n_p markm) as [st_hg othersCompat].
    pose proof (sendmChange (dt defP defN n_p) markm) as rew.
    rewrite <- rew in *; clear rew.
    pose proof (deqLeaf deqSt) as leafC.
    pose proof (processDeq deqSt) as st; simpl in st.
    destruct (classic (descendent c p)) as [c_p | c_ne_p].
    destruct (classic (descendent c n)) as [c_n | c_ne_n].
    pose proof (@descSle c n defC defN c_n a t) as low.
    pose proof (conservative defP defN n_p a t) as sth.
    rewrite isSt in st.
    rewrite st in *.
    destruct (state n a t); destruct (dir p n a t); destruct (dir p n a (S t));
    unfold sle in *; unfold slt in *; auto.
    pose proof (clos_rt_rtn1 Tree parent c p c_p) as trans.
    destruct trans.
    apply (parentLeafFalse leafC n_p).
    pose proof (clos_rtn1_rt Tree parent c y trans) as c_y.
    pose proof (rt_step Tree parent y z H) as y_z.
    pose proof (rt_trans Tree parent y z hier y_z defP) as defY.
    clear trans y_z; fold descendent in *.
    assert (y_ne_n: y = n -> False).
    intros y_eq_n.
    rewrite y_eq_n in *.
    firstorder.
    specialize (othersCompat y defY y_ne_n H).
    pose proof (@descSle c y defC defY c_y a t) as low.
    pose proof (conservative defP defY H a t) as stuff.
    rewrite isSt in st.
    rewrite st in *.
    unfold sle in *; unfold slt in *; destruct (dir z n a (S t)); destruct (dir z n a t);
    destruct (dir z y a t); destruct (state y a t); auto.
    assert (sec: ~ descendent p c).
    unfold not; intros p_c.
    pose proof (clos_rt_rtn1 Tree parent p c p_c) as trans.
    destruct trans.
    firstorder.
    apply (parentLeafFalse leafC H).
    pose proof (@nonDescCompat c p defC defP c_ne_p sec a t) as contra.
    rewrite isSt in st.
    rewrite st in contra.
    unfold sle in *; unfold slt in *; destruct (dir p n a t); destruct (dir p n a (S t));
    destruct (state p a t); auto.
  Qed.

  Theorem leafGood3: forall {p n a t}, defined p -> defined n -> parent n p ->
                                       forall {m}, mark mch n p a t m ->
                                                   forall {c i},
                                                     defined c ->
                                                     deqR a c i t -> desc (reqFn a c i) = St ->
                                                     False.
  Proof.
    unfold not; intros p n a t defP defN n_p m markm c i defC deqSt isSt.
    destruct (classic (c = n)) as [eq|notEq].
    rewrite eq in *.
    apply (deqImpNoSend defN deqSt defP markm).
    destruct (classic (descendent c n)) as [c_n | c_no_n].
    pose proof (@sendPCond n a t p defN defP n_p m markm) as dirLower.
    pose proof (allDirLower defN dirLower notEq c_n) as condToM.
    pose proof (cSendDowngrade defP defN n_p markm) as dgd.
    pose proof (sendmChange (st defP defN n_p) markm) as stEq.
    rewrite stEq in dgd.
    pose proof (processDeq deqSt) as eqSth; simpl in *.
    rewrite isSt in eqSth.
    rewrite eqSth in *.
    destruct (state n a t); destruct (to m); unfold slt in *; unfold sle in *; auto.
    assert (n_no_c: ~ descendent n c).
    unfold not; intros n_c.
    pose proof (clos_rt_rtn1 Tree parent n c n_c) as trans.
    destruct trans.
    assert (n = n) by reflexivity; firstorder.
    pose proof (deqLeaf deqSt) as leaf_z.
    unfold parent in *; unfold leaf in *. destruct z. destruct l0.
    unfold List.In in H. assumption.
    assumption.
    pose proof (@nonDescCompat n c defN defC n_no_c c_no_n a t) as stNow.
    pose proof (cSendDowngrade defP defN n_p markm) as dgd.
    pose proof (processDeq deqSt) as eqSth; simpl in *;
    rewrite isSt in eqSth.
    rewrite eqSth in *.
    unfold sle in *; unfold slt in *; destruct (state n a t); destruct (state n a (S t));
    auto.
  Qed.

  Theorem allLatestValue:
    forall {a t n}, defined n ->
                    sle Sh (state n a t) ->
                    (forall {c}, defined c -> parent c n -> sle (dir n c a t) Sh) ->
                    (data n a t = initData a /\
                     forall {ti}, 0 <= ti < t ->
                                  forall {ci ii}, defined ci ->
                                                  ~ (deqR a ci ii ti /\
                                                     desc (reqFn a ci ii) = St)) \/
    (exists cb ib tb, defined cb /\ tb < t /\ deqR a cb ib tb /\ desc (reqFn a cb ib) = St /\
                      data n a t = dataQ (reqFn a cb ib) /\
                      forall {ti}, tb < ti < t ->
                                   forall {ci ii},
                                     defined ci ->
                                     ~ (deqR a ci ii ti /\
                                        desc (reqFn a ci ii) = St)
    ).
    Proof.
      intros a.
      pose (fun t => forall n,
              defined n ->
                    sle Sh (state n a t) ->
                    (forall {c}, defined c -> parent c n -> sle (dir n c a t) Sh) ->
                    (data n a t = initData a /\
                     forall {ti}, 0 <= ti < t ->
                                  forall {ci ii}, defined ci ->
                                                  ~ (deqR a ci ii ti /\
                                                     desc (reqFn a ci ii) = St)) \/
    (exists cb ib tb, defined cb /\ tb < t /\ deqR a cb ib tb /\ desc (reqFn a cb ib) = St /\
                      data n a t = dataQ (reqFn a cb ib) /\
                      forall {ti}, tb < ti < t ->
                                   forall {ci ii},
                                     defined ci ->
                                     ~ (deqR a ci ii ti /\
                                        desc (reqFn a ci ii) = St)
           )) as P.
      pose proof (initLatest a) as [hierInit hierM].
      apply (@ind P).
      unfold P in *; clear P.
      intros n defN stCond dirCond.
      destruct (classic (n = hier)) as [eq|notEq].
      rewrite eq.
      rewrite hierInit.
      constructor. constructor. reflexivity.
      intros ti [_ bad].
      assert (f: False) by omega.
      firstorder.
      pose proof (rt_refl Tree parent hier) as defHier.
      pose proof (@initCompat hier) as dir0.
      pose proof (clos_rt_rtn1 Tree parent n hier defN) as trans.
      pose proof @conservative as cons.
      pose proof @descSle as descSle.
      unfold defined in *.
      destruct trans.
      firstorder.
      pose proof (clos_rtn1_rt Tree parent n y trans) as n_y.
      pose proof (rt_step Tree parent y z H) as defY.
      clear dirCond trans; fold descendent in *.
      specialize (dir0 y defHier defY H a).
      pose proof (cons z y defHier defY H a 0) as sleUse.
      pose proof @descSle n y defN defY n_y a 0 as contra.
      rewrite dir0 in sleUse.
      unfold sle in *; destruct (state n a 0); destruct (state y a 0); firstorder.

      unfold P in *; clear P.
      intros t SIHt n defN condSt condDir.

      destruct (classic (sle Sh (state n a t) /\
                         forall c, defined c -> parent c n -> sle (dir n c a t) Sh))
               as [[condSt' condDir']|prevNotLatest].

      assert (triv: t <= t) by omega.
      specialize (SIHt t triv n defN condSt' condDir'); clear triv.

      assert (noneElse: forall co, defined co -> leaf co -> co <> n -> sle (state co a t) Sh).
      intros co defCo leafco co_ne_n.
      destruct (classic (descendent co n)) as [desc|noDesc].
      apply (allDirLower defN condDir' co_ne_n desc).

      assert (not_n_co: ~ descendent n co).
      unfold not; intros n_co.
      assert (no_co_parent: forall p, ~ parent p co) by
          (unfold not; intros p p_co; unfold leaf in *; unfold parent in *;
                                      unfold List.In in *; destruct co; destruct l0; auto).
      pose proof (clos_rt_rtn1 Tree parent n co n_co) as trans.
      destruct trans.
      assert (n = n) by reflexivity; firstorder.
      firstorder.

      pose proof (@nonDescCompat n co defN defCo not_n_co noDesc a t) as condState.
      destruct (state n a t); unfold sle in *; destruct (state co a t); auto.

      assert (noStore: forall co, defined co ->
                                  co <> n -> forall i,
                                               ~ (deqR a co i t /\
                                                  desc (reqFn a co i) = St
             )).
      unfold not; intros co defCo co_ne_n i [deqSt isSt].
      pose proof (deqLeaf deqSt) as leafCo.
      specialize (noneElse co defCo leafCo co_ne_n).
      pose proof (processDeq deqSt) as use; simpl in use.
      rewrite isSt in use.
      rewrite use in noneElse; unfold sle in *; auto.

      destruct (classic (exists i, deqR a n i t /\
               desc (reqFn a n i) = St)) as [[i [deqSt isSt]] | noNStore].

      pose proof (deqImpData defN deqSt) as st.
      rewrite isSt in st.
      rewrite st.
      assert (triv: t < S t) by omega.
      assert (triv2: forall ti, t < ti < S t -> False) by (intros ti cond; omega).
      right.
      exists n; exists i; exists t.
      generalize defN triv deqSt isSt st triv2; clear; firstorder.
      reflexivity.

      assert (good: forall c i, defined c ->
                                ~ (deqR a c i t /\
                                   desc (reqFn a c i) = St)).
      unfold not. intros c i defC [deqc isSt].
      destruct (classic (c = n)) as [eq|notEq].
      rewrite eq in *; generalize noNStore deqc isSt; clear; firstorder.
      generalize noStore defC notEq deqc isSt; clear; firstorder.

      destruct (classic (data n a (S t) = data n a t)) as [dataEq| dataNeq].
      rewrite dataEq.

      destruct SIHt as [[initi condInit]|[resti condResti]].
      left.
      constructor. assumption.
      intros ti cond.
      assert (cases: 0 <= ti < t \/ ti = t) by omega.
      destruct cases as [ind|rew].
      specialize (condInit ti ind).
      assumption.
      rewrite rew.
      assumption.

      destruct condResti as [ib [tb [defCb [tb_lt_t [deqSt [isSt [dEq rest]]]]]]].
      right.
      exists resti; exists ib; exists tb.
      constructor. assumption.
      constructor.
      omega.
      constructor.
      assumption.
      constructor.
      assumption.
      constructor.
      assumption.
      intros ti cond.
      assert (cases: tb < ti < t \/ ti = t) by omega.
      destruct cases as [ind|rew].

      apply (rest ti ind).
      rewrite rew.
      assumption.

      pose proof (changeData defN dataNeq) as someChange.
      destruct someChange as [[m [[p [defP [n_p [recvm mIn]]]] |
                                  [c [defC [c_n [recvm mNotIn]]]]]] | bad].

      pose proof (cRecvmCond defP defN n_p recvm) as currSt.
      rewrite <- currSt in condSt'; rewrite mIn in condSt'.
      unfold sle in condSt'; firstorder.

      pose proof (recvmCond defN defC c_n recvm) as currSt.
      specialize (condDir' c defC c_n).
      rewrite currSt in mNotIn.
      pose proof (slt_slei_false mNotIn condDir') as f.
      firstorder.

      generalize noNStore bad; clear; firstorder.

      destruct (classic (state n a t = MsiState.In \/ exists c, defined c /\ parent c n /\
                                                       slt Sh (dir n c a t)))
               as [hard | easy].
      clear prevNotLatest.

      destruct hard as [stIn | [c [defC [c_n dirM]]]].

      assert (lt: slt (state n a t) (state n a (S t))) by
          (rewrite stIn; unfold sle in *; unfold slt in *; destruct (state n a (S t));
           auto).
      assert (chnge: state n a (S t) <> state n a t) by
          (destruct (state n a (S t)); destruct (state n a t); unfold slt in *;
                                                               unfold sle in *;
                                                               auto; discriminate).
      destruct (classic (exists p, defined p /\ parent n p)) as [[p [defP n_p]] | noP].
      pose proof (change (st defP defN n_p) chnge) as [[m markm] | [m recvm]].
      pose proof (cSendDowngrade defP defN n_p markm) as contra.
      pose proof (slt_slti_false lt contra) as f.
      firstorder.

      pose proof (recvImpMark recvm) as [ts [ts_le_t markm]].
      pose proof (@pSendNonI p n defP defN n_p m ts t a markm recvm) as pHigh.
      pose proof (@cRecvNonM p n defP defN n_p m ts t a markm recvm) as cLow.
      assert (cLow1: forall t0, ts < t0 <= t -> slt (state n a t0) Mo) by
          ( intros t0 cond; assert (H: ts <= t0 <= t) by omega; apply (cLow t0 H)).
      assert (cLow2: slt (state n a ts) Mo) by (assert (H: ts <= ts <= t) by omega;
                                                apply (cLow ts H)).

      assert (noDeq1: forall t0, ts < t0 <= t ->
                                 forall c i, defined c -> ~ (deqR a c i t0
                                                            /\
                                                            desc (reqFn a c i) = St)).
      intros t0 cond.
      specialize (pHigh t0 cond).
      specialize (cLow1 t0 cond).
      pose proof (@leafGood p n a t0 defP defN n_p pHigh cLow1) as H.
      generalize H; clear; firstorder.

      pose proof (@leafGood2 p n a ts defP defN n_p m markm) as noDeq2.

      assert (goodT: forall t0, ts <= t0 <= t ->
                                forall c i, defined c -> ~ (deqR a c i t0 /\
                                                            desc (reqFn a c i) = St)).
      intros t0 cond.
      assert (H: ts < t0 <= t \/ t0 = ts) by omega.
      destruct H as [c1|c2].
      apply (noDeq1 t0 c1).
      rewrite c2 in *.
      generalize noDeq2; clear; firstorder.

      pose proof (cRecvmCond defP defN n_p recvm) as stEq.
      rewrite <- stEq in stIn.
      pose proof (fromParent defN defP n_p recvm stIn) as dataEq.
      pose proof (toChild defN defP n_p markm stIn) as dataEq2.
      rewrite <- dataEq in dataEq2.
      rewrite dataEq2.

      pose proof (sendCCond defP defN n_p markm) as [one two].
      pose proof (pSendUpgrade defP defN n_p markm) as upg.
      pose proof (sendmChange (dt defP defN n_p) markm) as ch.
      rewrite ch in upg.
      assert (p1: sle Sh (state p a ts)) by
          ( unfold sle in *; unfold slt in *; destruct (to m); destruct (state p a ts);
            destruct (dir p n a ts); auto).
      assert (p2: forall c', defined c' -> parent c' p ->
                         sle (dir p c' a ts) Sh).
      intros c' defC' c'_p.

      destruct (classic (c' = n)) as [eq|not].
      pose proof (cRecvRespPrevState defP defN n_p recvm markm) as stDir.
      rewrite <- stEq in stDir.
      rewrite stIn in stDir.
      rewrite eq.
      rewrite <- stDir.
      unfold sle; auto.

      specialize (two c' defC' not c'_p).
      unfold sle in *; unfold slt in *; destruct (to m); destruct (dir p n a ts);
      destruct (dir p c' a ts); auto.

      specialize (SIHt ts ts_le_t p defP p1 p2).
      destruct (SIHt) as [[initi condInit] | [resti condRest]].
      left.
      constructor. assumption.

      intros ti cond; assert (H: 0 <= ti < ts \/ ts <= ti <= t ) by omega;
      destruct H as [ind|tough].

      apply (condInit ti ind).
      apply (goodT ti tough).

      right.
      destruct condRest as [ib [tb [defCb [tb_lt_ts [deqSt [isSt [dtEq rest]]]]]]].
      exists resti; exists ib; exists tb.
      constructor. assumption. constructor.
      assert (tb < S t) by omega. assumption.
      constructor. assumption.
      constructor. assumption.
      constructor. assumption.
      intros ti cond; assert (H: tb < ti < ts \/ ts <= ti <= t) by omega;
      destruct H as [ind|tough].
      apply (rest ti ind).
      apply (goodT ti tough).

      assert (contra: forall p, defined p -> ~ parent n p) by firstorder.
      specialize (@noParentSame n a t defN contra).
      firstorder.

      specialize (condDir c defC c_n).

      assert (gt: slt (dir n c a (S t)) (dir n c a t)) by
          (unfold slt in *; unfold sle in *; destruct (dir n c a (S t));
           destruct (dir n c a t); auto; discriminate).
      assert (chnge: dir n c a (S t) <> dir n c a t) by
          (destruct (dir n c a (S t)); destruct (dir n c a t); unfold slt in *;
                                                               unfold sle in *;
                                                               auto; discriminate).

      pose proof (change (dt defN defC c_n) chnge) as [[m markm] | [m recvm]].
      pose proof (pSendUpgrade defN defC c_n markm) as contra.
      pose proof (slt_slti_false gt contra) as f.
      firstorder.

      pose proof (recvImpMark recvm) as [ts [ts_le_t markm]].
      pose proof (@pRecvNonI n c defN defC c_n m ts t a markm recvm) as pHigh.
      pose proof (@cSendNonM n c defN defC c_n m ts t a markm recvm) as cLow.
      assert (pHigh1: forall t0, ts < t0 <= t -> slt MsiState.In (dir n c a t0)) by
          ( intros t0 cond; assert (H: ts <= t0 <= t) by omega; apply (pHigh t0 H)).
      assert (pHigh2: slt MsiState.In (dir n c a ts)) by (assert (H: ts <= ts <= t) by omega;
                                                apply (pHigh ts H)).

      assert (noDeq1: forall t0, ts < t0 <= t ->
                                 forall c i, defined c -> ~ (deqR a c i t0 /\
                                                             desc (reqFn a c i) = St)).
      intros t0 cond.
      specialize (cLow t0 cond).
      specialize (pHigh1 t0 cond).
      pose proof (@leafGood n c a t0 defN defC c_n pHigh1 cLow) as H.
      generalize H; clear; firstorder.

      pose proof (@leafGood3 n c a ts defN defC c_n m markm) as noDeq2.

      assert (goodT: forall t0, ts <= t0 <= t ->
                                forall c i, defined c -> ~ (deqR a c i t0 /\
                                                            desc (reqFn a c i) = St)).
      intros t0 cond.
      assert (H: ts < t0 <= t \/ t0 = ts) by omega.
      destruct H as [c1|c2].
      apply (noDeq1 t0 c1).
      rewrite c2 in *.
      generalize noDeq2; clear; firstorder.

      pose proof (recvmCond defN defC c_n recvm) as stEq.
      rewrite <- stEq in dirM.
      pose proof (fromChild defN defC c_n recvm dirM) as dataEq.
      pose proof (toParent defN defC c_n markm dirM) as dataEq2.
      rewrite <- dataEq in dataEq2.
      rewrite dataEq2.

      pose proof (@sendPCond c a ts n defC defN c_n m markm) as sth.
      pose proof (recvmChange (dt defN defC c_n) recvm) as ch.
      rewrite ch in condDir.
      pose proof (cSendDowngrade defN defC c_n markm) as dwn.

      assert (p2: forall c0, defined c0 -> parent c0 c -> sle (dir c c0 a ts) Sh).
      intros c0 defC0 c0_c; specialize (sth c0 defC0 c0_c);
      destruct (to m); destruct (dir c c0 a ts); unfold sle in *; unfold slt in *;
      auto.

      assert (p1: sle Sh (state c a ts)) by
          ( unfold sle in *; unfold slt in *; destruct (state c a (S ts));
            destruct (state c a ts); auto).

      specialize (SIHt ts ts_le_t c defC p1 p2).

      destruct SIHt as [[initi condInit] | [resti condRest]].
      left.
      constructor. assumption.
      intros ti cond; assert (H: 0 <= ti < ts \/ ts <= ti <= t ) by omega;
      destruct H as [ind|tough].

      apply (condInit ti ind).
      apply (goodT ti tough).

      right.
      destruct condRest as [ib [tb [defCb [tb_lt_ts [deqSt [isSt [dtEq rest]]]]]]].
      exists resti; exists ib; exists tb.
      constructor. assumption. constructor.
      assert (tb < S t) by omega. assumption.
      constructor. assumption.
      constructor. assumption.
      constructor. assumption.
      intros ti cond; assert (H: tb < ti < ts \/ ts <= ti <= t) by omega;
     destruct H as [ind|tough].
      apply (rest ti ind).
      apply (goodT ti tough).

      assert (ex: forall c, defined c -> parent c n -> ~ slt Sh (dir n c a t)) by
          firstorder.
      assert (ex': forall c, defined c -> parent c n -> sle (dir n c a t) Sh) by
          ( intros c defC c_n; unfold sle in *; specialize (ex c defC c_n);
            unfold slt in *; destruct (dir n c a t); auto).
      assert (ex2: state n a t <> MsiState.In) by firstorder.
      assert (ex2': sle Sh (state n a t)) by (destruct (state n a t); unfold sle in *;
                                                                      auto).
      firstorder.

    Qed.

  Theorem latestValue:
  forall {c a t},
    defined c ->
    leaf c ->
    sle Sh (state c a t) ->
    (data c a t = initData a /\
     forall {ti}, 0 <= ti < t -> forall {ci ii},
                                   defined ci ->
                                   ~ (deqR a ci ii ti /\
                                      desc (reqFn a ci ii) = St)) \/
    (exists cb ib tb, defined cb /\ tb < t /\ deqR a cb ib tb /\ desc (reqFn a cb ib) = St /\
                      data c a t = dataQ (reqFn a cb ib) /\
                      forall {ti}, tb < ti < t ->
                                   forall {ci ii},
                                     defined ci ->
                                     ~ (deqR a ci ii ti /\
                                        desc (reqFn a ci ii) = St)
    ).
  Proof.
    intros c a t cDef leafC more.
    assert (cond: forall {c'}, defined c' -> parent c' c -> sle (dir c c' a t) Sh).
    intros c' defC' c'_c; unfold leaf in *; unfold parent in *.
    destruct c.
    destruct l0.
    unfold List.In in *.
    firstorder.
    firstorder.
    pose proof (allLatestValue cDef more cond) as useful.
    assumption.
  Qed.

  Definition deqOrNot := l1.deqOrNot.
End LatestValueTheorems.


Require Import Relations.
Require Import NArith.
Require Import PArith.
Require Import ZArith.
Require Import Lia.
Require Import FMapPositive.
Require Import FSetPositive.
Require Import EquivDec.
Require Import sflib.
Require Import PacoNotation.
Require Import HahnRelationsBasic.
Require Import HahnSets.

Require Import PromisingArch.lib.Basic.
Require Import PromisingArch.lib.HahnRelationsMore.
Require Import PromisingArch.lib.Order.
Require Import PromisingArch.lib.Time.
Require Import PromisingArch.lib.Lang.

Set Implicit Arguments.

Create HintDb tso discriminated.

Module Label.
  Inductive t :=
  | read (loc:Loc.t) (val:Val.t)
  | write (loc:Loc.t) (val:Val.t)
  | update (loc:Loc.t) (vold vnew:Val.t)
  | barrier (b:Barrier.t)
  | flush (loc:Loc.t)
  | flushopt (loc:Loc.t)
  .
  Hint Constructors t : tso.

  Definition is_read (label:t): bool :=
    match label with
    | read _ _ => true
    | _ => false
    end.

  Definition is_reading (loc:Loc.t) (label:t): bool :=
    match label with
    | read loc' _ => loc' == loc
    | _ => false
    end.

  Definition is_reading_val (loc:Loc.t) (val:Val.t) (label:t): bool :=
    match label with
    | read loc' val' => (loc' == loc) && (val' == val)
    | _ => false
    end.

  Definition is_write (label:t): bool :=
    match label with
    | write _ _ => true
    | _ => false
    end.

  Definition is_writing_cl (loc:Loc.t) (label:t): bool :=
    match label with
    | write loc' _ => Loc.cl loc loc'
    | _ => false
    end.

  Definition is_update (label:t): bool :=
    match label with
    | update _ _ _ => true
    | _ => false
    end.

  Definition is_flush (label:t): bool :=
    match label with
    | flush _ => true
    | _ => false
    end.

  Definition is_flushing (loc:Loc.t) (label:t): bool :=
    match label with
    | flush loc' => loc' == loc
    | _ => false
    end.

  Definition is_flushing_cl (loc:Loc.t) (label:t): bool :=
    match label with
    | flush loc' => Loc.cl loc loc'
    | _ => false
    end.

  Definition is_flushopt (label:t): bool :=
    match label with
    | flushopt _ => true
    | _ => false
    end.

  Definition is_flushopting (loc:Loc.t) (label:t): bool :=
    match label with
    | flushopt loc' => loc' == loc
    | _ => false
    end.

  Definition is_flushopting_cl (loc:Loc.t) (label:t): bool :=
    match label with
    | flushopt loc' => Loc.cl loc loc'
    | _ => false
    end.

  Definition is_kinda_read (label:t): bool :=
    match label with
    | read _ _ => true
    | update _ _ _ => true
    | _ => false
    end.

  Definition is_kinda_reading (loc:Loc.t) (label:t): bool :=
    match label with
    | read loc' _ => loc' == loc
    | update loc' _ _ => loc' == loc
    | _ => false
    end.

  Definition is_kinda_reading_val (loc:Loc.t) (val:Val.t) (label:t): bool :=
    match label with
    | read loc' val' => (loc' == loc) && (val' == val)
    | update loc' val' _ => (loc' == loc) && (val' == val)
    | _ => false
    end.

  Definition is_kinda_write (label:t): bool :=
    match label with
    | write _ _ => true
    | update _ _ _ => true
    | _ => false
    end.

  Definition is_kinda_writing (loc:Loc.t) (label:t): bool :=
    match label with
    | write loc' _ => loc' == loc
    | update loc' _ _ => loc' == loc
    | _ => false
    end.

  Definition is_kinda_writing_val (loc:Loc.t) (val:Val.t) (label:t): bool :=
    match label with
    | write loc' val' => (loc' == loc) && (val' == val)
    | update loc' _ val' => (loc' == loc) && (val' == val)
    | _ => false
    end.

  Definition is_kinda_writing_cl (loc:Loc.t) (label:t): bool :=
    match label with
    | write loc' _ => Loc.cl loc loc'
    | update loc' _ _ => Loc.cl loc loc'
    | _ => false
    end.

  Definition is_access (label:t): bool :=
    match label with
    | read _ _ => true
    | write _ _ => true
    | update _ _ _ => true
    | _ => false
    end.

  Definition is_accessing (loc:Loc.t) (label:t): bool :=
    match label with
    | read loc' _ => loc' == loc
    | write loc' _ => loc' == loc
    | update loc' _ _ => loc' == loc
    | _ => false
    end.

  Definition is_accessing_cl (loc:Loc.t) (label:t): bool :=
    match label with
    | read loc' _ => Loc.cl loc loc'
    | write loc' _ => Loc.cl loc loc'
    | update loc' _ _ => Loc.cl loc loc'
    | _ => false
    end.

  Definition is_barrier (label:t): bool :=
    match label with
    | barrier b => true
    | _ => false
    end.

  Definition is_barrier_c (c:Barrier.t -> bool) (label:t): bool :=
    match label with
    | barrier b => c b
    | _ => false
    end.

  Definition is_kinda_write_flush (label:t): bool :=
    match label with
    | write _ _ => true
    | update _ _ _ => true
    | flush _ => true
    | _ => false
    end.

  Definition is_persist (label:t): bool :=
    match label with
    | flush _ => true
    | flushopt _ => true
    | _ => false
    end.

  Definition is_persisting (loc:Loc.t) (label:t): bool :=
    match label with
    | flush loc' => loc' == loc
    | flushopt loc' => loc' == loc
    | _ => false
    end.

  Definition is_persisting_cl (loc:Loc.t) (label:t): bool :=
    match label with
    | flush loc' => Loc.cl loc loc'
    | flushopt loc' => Loc.cl loc loc'
    | _ => false
    end.

  Definition is_access_persist (label:t): bool :=
    match label with
    | read _ _ => true
    | write _ _ => true
    | update _ _ _ => true
    | flush _ => true
    | flushopt _ => true
    | _ => false
    end.

  Definition is_access_persisting (loc:Loc.t) (label:t): bool :=
    match label with
    | read loc' _ => loc' == loc
    | write loc' _ => loc' == loc
    | update loc' _ _ => loc' == loc
    | flush loc' => loc' == loc
    | flushopt loc' => loc' == loc
    | _ => false
    end.

  Definition is_kinda_write_persist (label:t): bool :=
    match label with
    | write _ _ => true
    | update _ _ _ => true
    | flush _ => true
    | flushopt _ => true
    | _ => false
    end.

  Definition is_persist_barrier (label:t): bool :=
    match label with
    | update _ _ _ => true
    | barrier b => orb (Barrier.is_mfence b) (Barrier.is_sfence b)
    | _ => false
    end.

  Lemma kinda_reading_is_kinda_read
        loc l
        (RD: is_kinda_reading loc l):
    is_kinda_read l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma kinda_reading_is_accessing
        loc l
        (RD: is_kinda_reading loc l):
    is_accessing loc l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma read_is_kinda_reading loc val:
    is_kinda_reading loc (read loc val).
  Proof.
    s. destruct (equiv_dec loc loc); ss. exfalso. apply c. ss.
  Qed.

  Lemma read_is_reading_val loc val:
    is_reading_val loc val (read loc val).
  Proof.
    s. destruct (equiv_dec loc loc); destruct (equiv_dec val val); ss; exfalso.
    all: apply c; ss.
  Qed.

  Lemma read_is_kinda_reading_val loc val:
    is_kinda_reading_val loc val (read loc val).
  Proof.
    s. destruct (equiv_dec loc loc); destruct (equiv_dec val val); ss; exfalso.
    all: apply c; ss.
  Qed.

  Lemma kinda_read_exists_loc_val
        l
        (RD: is_kinda_read l):
    exists loc val,
      is_kinda_reading_val loc val l.
  Proof.
    destruct l; ss.
    - exists loc. exists val.
      destruct (equiv_dec loc loc); destruct (equiv_dec val val); ss; try by exfalso; apply c; ss.
    - exists loc. exists vold.
      destruct (equiv_dec loc loc); destruct (equiv_dec vold vold); ss; try by exfalso; apply c; ss.
  Qed.

  Lemma kinda_reading_exists_val
        loc l
        (RDING: is_kinda_reading loc l):
    exists val,
      is_kinda_reading_val loc val l.
  Proof.
    destruct l; ss; destruct (equiv_dec loc0 loc); ss.
    - eexists val. destruct (equiv_dec val val); ss. exfalso. apply c. ss.
    - eexists vold. destruct (equiv_dec vold vold); ss. exfalso. apply c. ss.
  Qed.

  Lemma reading_val_is_reading
        loc val l
        (RDING: is_reading_val loc val l):
    is_reading loc l.
  Proof.
    destruct l; ss; destruct (equiv_dec loc0 loc); ss.
  Qed.

  Lemma reading_is_read
        loc l
        (RDING: is_reading loc l):
    is_read l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma kinda_reading_val_is_kinda_reading
        loc val l
        (RDING: is_kinda_reading_val loc val l):
    is_kinda_reading loc l.
  Proof.
    destruct l; ss; destruct (equiv_dec loc0 loc); ss.
  Qed.

  Lemma kinda_writing_is_kinda_write
        loc l
        (WR: is_kinda_writing loc l):
    is_kinda_write l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma read_is_kinda_read
        l
        (RD: is_read l):
    is_kinda_read l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma kinda_read_is_access
        l
        (WR: is_kinda_read l):
    is_access l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma write_is_kinda_write
        l
        (WR: is_write l):
    is_kinda_write l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma writing_cl_is_write
        loc l
        (LABEL: is_writing_cl loc l):
    is_write l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma kinda_write_is_access
        l
        (WR: is_kinda_write l):
    is_access l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma kinda_writing_is_accessing
        loc l
        (WR: is_kinda_writing loc l):
    is_accessing loc l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma write_is_kinda_writing loc val:
    is_kinda_writing loc (write loc val).
  Proof.
    s. destruct (equiv_dec loc loc); ss. exfalso. apply c. ss.
  Qed.

  Lemma write_is_kinda_writing_val loc val:
    is_kinda_writing_val loc val (write loc val).
  Proof.
    s. destruct (equiv_dec loc loc); destruct (equiv_dec val val); ss; exfalso.
    all: apply c; ss.
  Qed.

  Lemma kinda_write_exists_loc_val
        l
        (WR: is_kinda_write l):
    exists loc val,
      is_kinda_writing_val loc val l.
  Proof.
    destruct l; ss.
    - exists loc. exists val.
      destruct (equiv_dec loc loc); destruct (equiv_dec val val); ss; try by exfalso; apply c; ss.
    - exists loc. exists vnew.
      destruct (equiv_dec loc loc); destruct (equiv_dec vnew vnew); ss; try by exfalso; apply c; ss.
  Qed.

  Lemma kinda_writing_exists_val
        loc l
        (WRING: is_kinda_writing loc l):
    exists val,
      is_kinda_writing_val loc val l.
  Proof.
    destruct l; ss; destruct (equiv_dec loc0 loc); ss.
    - eexists val. destruct (equiv_dec val val); ss. exfalso. apply c. ss.
    - eexists vnew. destruct (equiv_dec vnew vnew); ss. exfalso. apply c. ss.
  Qed.

  Lemma kinda_writing_val_is_kinda_writing
        loc val l
        (RDING: is_kinda_writing_val loc val l):
    is_kinda_writing loc l.
  Proof.
    destruct l; ss; destruct (equiv_dec loc0 loc); ss.
  Qed.

  Lemma update_is_kinda_reading loc vold vnew:
    is_kinda_reading loc (update loc vold vnew).
  Proof.
    s. destruct (equiv_dec loc loc); ss. exfalso. apply c. ss.
  Qed.

  Lemma update_is_kinda_writing loc vold vnew:
    is_kinda_writing loc (update loc vold vnew).
  Proof.
    s. destruct (equiv_dec loc loc); ss. exfalso. apply c. ss.
  Qed.

  Lemma update_is_kinda_writing_val loc vold vnew:
    is_kinda_writing_val loc vnew (update loc vold vnew).
  Proof.
    s. destruct (equiv_dec loc loc); destruct (equiv_dec vnew vnew); ss; exfalso.
    all: apply c; ss.
  Qed.

  Lemma accessing_is_access
        loc l
        (RD: is_accessing loc l):
    is_access l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma read_is_accessing loc val:
    is_accessing loc (read loc val).
  Proof.
    s. destruct (equiv_dec loc loc); ss. exfalso. apply c. ss.
  Qed.

  Lemma write_is_accessing loc val:
    is_accessing loc (write loc val).
  Proof.
    s. destruct (equiv_dec loc loc); ss. exfalso. apply c. ss.
  Qed.

  Lemma update_is_accessing loc vold vnew:
    is_accessing loc (update loc vold vnew).
  Proof.
    s. destruct (equiv_dec loc loc); ss. exfalso. apply c. ss.
  Qed.

  Lemma kinda_writing_same_loc loc1 loc2 l
    (W1: is_kinda_writing loc1 l)
    (W2: is_kinda_writing loc2 l):
    loc1 = loc2.
  Proof.
    destruct l; ss.
    - destruct (equiv_dec loc loc1); ss. inv e. destruct (equiv_dec loc1 loc2); ss.
    - destruct (equiv_dec loc loc1); ss. inv e. destruct (equiv_dec loc1 loc2); ss.
  Qed.

  Lemma flushopting_is_flushopt
        loc l
        (RD: is_flushopting loc l):
    is_flushopt l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma flushing_is_flush
        loc l
        (RD: is_flushing loc l):
    is_flush l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma flushopt_is_flushopting loc:
    is_flushopting loc (flushopt loc).
  Proof.
    s. destruct (equiv_dec loc loc); ss. exfalso. apply c. ss.
  Qed.

  Lemma persisting_is_persist
        loc l
        (RD: is_persisting loc l):
    is_persist l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma flush_is_persist
        l
        (LABEL: is_flush l):
    is_persist l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma flushopt_is_persist
        l
        (LABEL: is_flushopt l):
    is_persist l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma access_is_access_persist
        l
        (LABEL: is_access l):
    is_access_persist l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma persist_is_kinda_write_persist
        l
        (LABEL: is_persist l):
    is_kinda_write_persist l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma kinda_write_flush_is_kinda_write_persist
        l
        (LABEL: is_kinda_write_flush l):
    is_kinda_write_persist l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma kinda_write_persist_is_access_persist
        l
        (LABEL: is_kinda_write_persist l):
    is_access_persist l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma flushing_is_persisting
        loc l
        (LABEL: is_flushing loc l):
    is_persisting loc l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma flushopting_is_persisting
        loc l
        (LABEL: is_flushopting loc l):
    is_persisting loc l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma persisting_is_access_persisting
        loc l
        (LABEL: is_persisting loc l):
    is_access_persisting loc l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma accessing_is_access_persisting
        loc l
        (LABEL: is_accessing loc l):
    is_access_persisting loc l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma mfence_is_persist_barrier
        l
        (LABEL: Label.is_barrier_c Barrier.is_mfence l):
    is_persist_barrier l.
  Proof.
    destruct l; ss. unfold orb. condtac; ss.
  Qed.

  Lemma sfence_is_persist_barrier
        l
        (LABEL: Label.is_barrier_c Barrier.is_sfence l):
    is_persist_barrier l.
  Proof.
    destruct l; ss. unfold orb. condtac; ss.
  Qed.

  Lemma accessing_cl_is_access
        loc l
        (LABEL: is_accessing_cl loc l):
    is_access l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma flushing_cl_is_flush
        loc l
        (LABEL: is_flushing_cl loc l):
    is_flush l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma flushopting_cl_is_flushopt
        loc l
        (LABEL: is_flushopting_cl loc l):
    is_flushopt l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma flushing_cl_is_persisting_cl
        loc l
        (LABEL: is_flushing_cl loc l):
    is_persisting_cl loc l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma flushopting_cl_is_persisting_cl
        loc l
        (LABEL: is_flushopting_cl loc l):
    is_persisting_cl loc l.
  Proof.
    destruct l; ss.
  Qed.

  Lemma persisting_cl_inv
        loc l
        (LABEL: Label.is_persisting_cl loc l):
    exists loc0,
      <<PERSISTING: Label.is_persisting loc0 l>> /\
      <<CL: Loc.cl loc loc0>>.
  Proof.
    destruct l; ss; esplits; eauto; destruct (equiv_dec loc0 loc0); ss; exfalso; apply c; ss.
  Qed.

  Hint Resolve
       read_is_reading_val reading_val_is_reading reading_is_read
       kinda_reading_is_kinda_read read_is_kinda_read kinda_read_is_access kinda_reading_is_accessing read_is_kinda_reading read_is_kinda_reading_val kinda_read_exists_loc_val kinda_reading_exists_val kinda_reading_val_is_kinda_reading
       kinda_writing_is_kinda_write write_is_kinda_write kinda_write_is_access kinda_writing_is_accessing write_is_kinda_writing write_is_kinda_writing_val kinda_write_exists_loc_val kinda_writing_exists_val kinda_writing_val_is_kinda_writing
       update_is_kinda_reading update_is_kinda_writing update_is_kinda_writing_val
       accessing_is_access read_is_accessing write_is_accessing update_is_accessing
       kinda_writing_same_loc
       access_is_access_persist
       flushopting_is_flushopt flushing_is_flush flushopt_is_flushopting
       persisting_is_persist flush_is_persist flushopt_is_persist persist_is_kinda_write_persist
       kinda_write_flush_is_kinda_write_persist kinda_write_persist_is_access_persist
       flushing_is_persisting flushopting_is_persisting persisting_is_access_persisting accessing_is_access_persisting
       mfence_is_persist_barrier sfence_is_persist_barrier
       writing_cl_is_write accessing_cl_is_access
       flushing_cl_is_flush flushing_cl_is_persisting_cl
       flushopting_cl_is_flushopt flushopting_cl_is_persisting_cl
    : tso.
End Label.

Module ALocal.
  Inductive t := mk {
    labels: list Label.t;
  }.
  Hint Constructors t : tso.

  Definition init: t := mk [].

  Definition next_eid (eu:t): nat :=
    List.length eu.(labels).

  Inductive step (event:Event.t (A:=unit)) (alocal1:t) (alocal2:t): Prop :=
  | step_internal
      (EVENT: event = Event.internal)
      (ALOCAL: alocal2 =
               mk
                 alocal1.(labels))
  | step_read
      rmw_fail vloc res ord
      (EVENT: event = Event.read false rmw_fail ord vloc (ValA.mk _ res tt))
      (ALOCAL: alocal2 =
               mk
                 (alocal1.(labels) ++ [Label.read vloc.(ValA.val) res]))
  | step_write
      vloc vval ord
      (EVENT: event = Event.write false ord vloc vval (ValA.mk _ 0 tt))
      (ALOCAL: alocal2 =
               mk
                 (alocal1.(labels) ++ [Label.write vloc.(ValA.val) vval.(ValA.val)]))
  | step_update
      vloc voldv vnewv ordr ordw
      (EVENT: event = Event.rmw ordr ordw vloc voldv vnewv)
      (ALOCAL: alocal2 =
               mk
                 (alocal1.(labels) ++ [Label.update vloc.(ValA.val) voldv.(ValA.val) vnewv.(ValA.val)]))
  | step_mfence
      b
      (EVENT: event = Event.barrier b)
      (BARRIER: Barrier.is_mfence b)
      (ALOCAL: alocal2 =
               mk
                 (alocal1.(labels) ++ [Label.barrier b]))
  | step_sfence
      b
      (EVENT: event = Event.barrier b)
      (BARRIER: Barrier.is_sfence b)
      (ALOCAL: alocal2 =
               mk
                 (alocal1.(labels) ++ [Label.barrier b]))
  | step_flush
      vloc
      (EVENT: event = Event.flush vloc)
      (ALOCAL: alocal2 =
               mk
                 (alocal1.(labels) ++ [Label.flush vloc.(ValA.val)]))
  | step_flushopt
      vloc
      (EVENT: event = Event.flushopt vloc)
      (ALOCAL: alocal2 =
               mk
                 (alocal1.(labels) ++ [Label.flushopt vloc.(ValA.val)]))
  .
  Hint Constructors step : tso.

  Inductive le (alocal1 alocal2:t): Prop :=
  | le_intro
      (LABELS: exists l, alocal2.(labels) = alocal1.(labels) ++ l)
  .
  Hint Constructors le : tso.

  Global Program Instance le_preorder: PreOrder le.
  Next Obligation.
    ii. econs.
    all: try by exists []; rewrite List.app_nil_r.
    all: try by apply inclusion_refl.
  Qed.
  Next Obligation.
    ii. inv H; inv H0. econs.
    all: try by eapply inclusion_trans; eauto.
    des. rewrite LABELS0, LABELS. rewrite <- List.app_assoc. eexists; eauto.
  Qed.
End ALocal.

Module AExecUnit.
  Inductive t := mk {
    state: State.t (A:=unit);
    local: ALocal.t;
  }.
  Hint Constructors t : tso.

  Inductive step (eu1 eu2:t): Prop :=
  | step_intro
      e
      (STATE: State.step e eu1.(state) eu2.(state))
      (LOCAL: ALocal.step e eu1.(local) eu2.(local))
  .
  Hint Constructors step : tso.

  Inductive label_is (labels:list Label.t) (pred:Label.t -> Prop) (iid:nat): Prop :=
  | label_is_intro
      l
      (EID: List.nth_error labels iid = Some l)
      (LABEL: pred l)
  .
  Hint Constructors label_is : tso.

  Definition wf_rmap (rmap: RMap.t (A:=unit)) (labels:list Label.t): Prop := True.
  Hint Unfold wf_rmap : tso.

  Inductive wf (aeu:t): Prop :=
  | wf_intro
      (REG: wf_rmap aeu.(state).(State.rmap) aeu.(local).(ALocal.labels))
  .
  Hint Constructors wf : tso.

  Lemma label_is_lt
        labels pred iid
        (LABEL: label_is labels pred iid):
    iid < length labels.
  Proof.
    inv LABEL. apply List.nth_error_Some. congr.
  Qed.

  Lemma label_is_mon
        labels1 labels2 pred:
    label_is labels1 pred <1= label_is (labels1 ++ labels2) pred.
  Proof.
    ii. inv PR. econs; eauto.
    rewrite List.nth_error_app1; ss.
    apply List.nth_error_Some. congr.
  Qed.

  Lemma union_mon
        A
        (p1 p2 q1 q2: A -> Prop)
        (P: p1 <1= p2)
        (Q: q1 <1= q2):
    (p1 ∪₁ q1) <1= (p2 ∪₁ q2).
  Proof.
    ii. inv PR.
    - left. eauto.
    - right. eauto.
  Qed.

  Lemma times_mon
        A
        (p1 p2 q1 q2: A -> Prop)
        (P: p1 <1= p2)
        (Q: q1 <1= q2):
    p1 × q1 <2= p2 × q2.
  Proof.
    ii. inv PR. econs; eauto.
  Qed.

  Lemma wf_init stmts: wf (mk (State.init stmts) ALocal.init).
  Proof.
    econs; ss.
  Qed.

  Lemma step_future
        eu1 eu2
        (WF: wf eu1)
        (STEP: step eu1 eu2):
    <<WF: wf eu2>> /\
    <<LE: ALocal.le eu1.(local) eu2.(local)>>.
  Proof.
    destruct eu1 as [state1 local1].
    destruct eu2 as [state2 local2].
    inv STEP. ss.
    inv STATE; inv LOCAL; inv EVENT; ss;
      repeat match goal with
             | [|- context[bot × _]] => rewrite cross_bot_l
             | [|- context[_ ∪ bot]] => rewrite union_bot_r
             end.
    - splits.
      + inv WF. econs; ss.
      + destruct local1. refl.
    - splits.
      + inv WF. econs; ss.
      + destruct local1. refl.
    - splits.
      + inv WF. econs; ss.
      + econs; ss. eauto.
    - splits.
      + inv WF. econs; ss.
      + econs; ss. eauto.
    - splits.
      + inv WF. econs; ss.
      + econs; ss. eauto.
    - splits.
      + inv WF. econs; ss.
      + econs; ss. eauto.
    - splits.
      + inv WF. econs; ss.
      + econs; ss. eauto.
    - splits.
      + inv WF. econs; ss.
      + econs; ss. eauto.
    - splits.
      + inv WF. econs; ss.
      + destruct local1. refl.
    - splits.
      + inv WF. econs; ss.
      + econs; ss. eauto.
    - splits.
      + inv WF. econs; ss.
      + econs; ss. eauto.
  Qed.

  Lemma rtc_step_future
        eu1 eu2
        (WF: wf eu1)
        (STEP: rtc step eu1 eu2):
    <<WF: wf eu2>> /\
    <<LE: ALocal.le eu1.(local) eu2.(local)>>.
  Proof.
    revert WF. induction STEP; eauto.
    - esplits; eauto. refl.
    - i. exploit step_future; eauto. i. des.
      exploit IHSTEP; eauto. i. des.
      esplits; ss. etrans; eauto.
  Qed.
End AExecUnit.

Definition eidT := (Id.t * nat)%type.

Module Execution.
  Inductive t := mk {
    labels: IdMap.t (list Label.t);
    co: relation eidT;
    rf: relation eidT;
    pf: relation eidT;
  }.
  Hint Constructors t : tso.

  Definition label (eid:eidT) (ex:t): option Label.t :=
    match IdMap.find (fst eid) ex.(labels) with
    | None => None
    | Some labels => List.nth_error labels (snd eid)
    end.

  Definition eids (ex:t): list eidT :=
    IdMap.fold
      (fun tid local eids => (List.map (fun i => (tid, i)) (List.seq 0 (List.length local))) ++ eids)
      ex.(labels)
      [].

  Lemma eids_spec ex:
    <<LABEL: forall eid, label eid ex <> None <-> List.In eid (eids ex)>> /\
    <<NODUP: List.NoDup (eids ex)>>.
  Proof.
    generalize (PositiveMap.elements_3w (labels ex)). intro NODUP.
    hexploit SetoidList.NoDupA_rev; eauto.
    { apply IdMap.eqk_equiv. }
    intro NODUP_REV. splits.
    - (* LABEL *)
      i. destruct eid. unfold label, eids. s.
      rewrite IdMap.fold_1, <- List.fold_left_rev_right, IdMap.elements_spec.
      rewrite SetoidList_findA_rev; eauto; cycle 1.
      { apply eq_equivalence. }
      { apply []. }
      revert NODUP_REV. induction (List.rev (IdMap.elements (labels ex))); ss.
      destruct a. i. inv NODUP_REV. s. rewrite List.in_app_iff, <- IHl; ss.
      match goal with
      | [|- context[if ?c then true else false]] => destruct c
      end; ss; i; cycle 1.
      { econs; eauto. i. des; ss.
        apply List.in_map_iff in H. des. inv H. congr.
      }
      inv e. rewrite List.nth_error_Some, List.in_map_iff.
      econs; i; des.
      + left. esplits; eauto. apply HahnList.in_seq0_iff. ss.
      + inv H. apply HahnList.in_seq0_iff. ss.
      + revert H.
        match goal with
        | [|- context[match ?f with Some _ => _ | None => _ end]] => destruct f eqn:FIND
        end; ss.
        apply SetoidList.findA_NoDupA in FIND; ss; cycle 1.
        { apply eq_equivalence. }
        exfalso. apply H1. revert FIND. clear. induction l; i; inv FIND.
        * destruct a. ss. des. inv H0. left. ss.
        * right. apply IHl. ss.
    - (* NODUP *)
      unfold eids. rewrite IdMap.fold_1, <- List.fold_left_rev_right.
      revert NODUP_REV. induction (List.rev (IdMap.elements (labels ex))); ss. i.
      inv NODUP_REV. destruct a. s.
      apply HahnList.nodup_app. splits; eauto.
      + apply FinFun.Injective_map_NoDup.
        * ii. inv H. ss.
        * apply List.seq_NoDup.
      + ii. apply List.in_map_iff in IN1. des. subst.
        apply H1. revert IN2. clear. induction l; ss.
        i. apply List.in_app_iff in IN2. des.
        * apply List.in_map_iff in IN2. des. inv IN2. left. ss.
        * right. eauto.
  Qed.

  Inductive label_is (ex:t) (pred:Label.t -> Prop) (eid:eidT): Prop :=
  | label_is_intro
      l
      (EID: label eid ex = Some l)
      (LABEL: pred l)
  .
  Hint Constructors label_is : tso.

  Inductive label_rel (ex:t) (rel:relation Label.t) (eid1 eid2:eidT): Prop :=
  | label_rel_intro
      l1 l2
      (EID1: label eid1 ex = Some l1)
      (EID2: label eid2 ex = Some l2)
      (LABEL: rel l1 l2)
  .
  Hint Constructors label_rel : tso.

  Inductive label_is_rel (ex: t) (pred: Label.t -> Prop) (eid1 eid2: eidT): Prop :=
  | label_is_rel_intro
      l1 l2
      (EID1: label eid1 ex = Some l1)
      (EID2: label eid2 ex = Some l2)
      (LABEL1: pred l1)
      (LABEL2: pred l2)
  .
  Hint Constructors label_is_rel : tso.

  Inductive label_loc (x y:Label.t): Prop :=
  | label_loc_intro
      loc
      (X: Label.is_accessing loc x)
      (Y: Label.is_accessing loc y)
  .
  Hint Constructors label_loc : tso.

  Inductive label_cl (x y:Label.t): Prop :=
  | label_cl_intro
      loc loc'
      (X: Label.is_access_persisting loc x)
      (Y: Label.is_access_persisting loc' y)
      (CL: Loc.cl loc loc')
  .
  Hint Constructors label_cl : tso.

  Lemma label_is_mon
        exec p1 p2 eid
        (PREL: p1 <1= p2)
        (P1: label_is exec p1 eid):
    label_is exec p2 eid.
  Proof.
    destruct P1; eauto with tso.
  Qed.

  (* let obs = rfe | fre | co *)
  (* let dob = ((W U U U R); po; (W U U U R)) \ (W × R) ~~~> ([R]; po; [W U U U R]) U ([W U U U R]; po; [W]) *)
  (* let bob = [W U U U R]; po; [MF]; po; [W U U U R] *)
  (* let fob =
      | [W U U U R]; po; [FL]
      | ([U U R] U ([W]; po; [MF U SF])); po; [FO]
      | [W]; (po; [FL])?; po_cl; [FO]
  *)
  (* let ob = obs | dob | bob | fob | pf | fp *)

  (* irrefl po?; rf as corw *)
  (* irrefl po; fr as cowr *)
  (* acyclic ob as external *)

  (* let per = pf; ([FL] U ([FO]; po; [MF U SF U U])) *)

  (* P = dom(per) *)
  (* forall l, exists w, M(l)=Val(w) /\ (P x {w})&Loc <= co? *)

  Inductive po (eid1 eid2:eidT): Prop :=
  | po_intro
      (TID: fst eid1 = fst eid2)
      (N: snd eid1 < snd eid2)
  .
  Hint Constructors po : tso.

  Global Program Instance po_trans: Transitive po.
  Next Obligation.
    ii. destruct x, y, z. inv H. inv H0. ss. subst. econs; ss. lia.
  Qed.

  Inductive po_adj (eid1 eid2:eidT): Prop :=
  | po_adj_intro
      (TID: fst eid1 = fst eid2)
      (N: snd eid2 = S (snd eid1))
  .
  Hint Constructors po_adj : tso.

  Lemma po_adj_po:
    po_adj ⊆ po.
  Proof.
    ii. destruct x, y. inv H. ss. subst. econs; ss.
  Qed.

  Lemma po_po_adj:
    po = po^? ⨾ po_adj.
  Proof.
    funext. i. funext. i. propext. econs; i.
    - inv H. destruct x, x0. ss. subst.
      destruct n0; [lia|].
      exists (t1, n0). splits; ss. inv N; [left|right]; eauto with tso.
    - inv H. des. inv H0.
      + apply po_adj_po. ss.
      + etrans; eauto. apply po_adj_po. ss.
  Qed.

  Lemma po_po_adj_weak:
    (Execution.po ⨾ Execution.po_adj) ⊆ Execution.po.
  Proof.
    rewrite po_po_adj at 2. apply inclusion_seq_mon; ss.
    econs 2. ss.
  Qed.

  Inductive i (eid1 eid2:eidT): Prop :=
  | i_intro
      (TID: fst eid1 = fst eid2)
  .
  Hint Constructors i : tso.

  Inductive e (eid1 eid2:eidT): Prop :=
  | e_intro
      (TID: fst eid1 <> fst eid2)
  .
  Hint Constructors e : tso.

  Definition po_loc (ex:t): relation eidT := po ∩ ex.(label_rel) label_loc.

  Definition fr (ex:t): relation eidT :=
    (ex.(rf)⁻¹ ⨾ ex.(co)) ∪
    ((ex.(label_rel) label_loc) ∩
     ((ex.(label_is) Label.is_kinda_read) \₁ codom_rel ex.(rf)) × (ex.(label_is) Label.is_kinda_write)).
  Definition fre (ex:t): relation eidT := (fr ex) ∩ e.

  Definition rfi (ex:t): relation eidT := ex.(rf) ∩ i.
  Definition rfe (ex:t): relation eidT := ex.(rf) ∩ e.

  Definition cowr (ex:t): relation eidT := po ⨾ (fr ex).
  Definition corw (ex:t): relation eidT := po^? ⨾ ex.(rf).

  Definition obs (ex:t): relation eidT := (rfe ex) ∪ (fre ex) ∪ ex.(co).

  Definition dob (ex:t): relation eidT :=
    (⦗ex.(label_is) Label.is_kinda_read⦘ ⨾
     po ⨾
     ⦗ex.(label_is) Label.is_access⦘) ∪
    (⦗ex.(label_is) Label.is_access⦘ ⨾
     po ⨾
     ⦗ex.(label_is) Label.is_kinda_write⦘).

  Definition bob (ex:t): relation eidT :=
    ⦗ex.(label_is) Label.is_access⦘ ⨾
     po ⨾
     ⦗ex.(label_is) (Label.is_barrier_c Barrier.is_mfence)⦘ ⨾
     po ⨾
     ⦗ex.(label_is) Label.is_access⦘.

  Definition po_cl (ex:t): relation eidT := po ∩ ex.(label_rel) label_cl.

  Definition no_pf (ex:t) (loc:Loc.t) (eid:eidT): Prop :=
    forall eid2
           (LABEL: ex.(Execution.label_is) (Label.is_kinda_writing loc) eid2)
           (PF: ex.(Execution.pf) eid2 eid),
      False.

  Inductive fp_uninit (ex:t) (eid1 eid2:eidT): Prop :=
  | fp_uninit_intro
      loc
      (PERSIST: ex.(Execution.label_is) (Label.is_persisting_cl loc) eid1)
      (WRITE: ex.(Execution.label_is) (Label.is_kinda_writing loc) eid2)
      (NOPF: no_pf ex loc eid1)
  .
  Hint Constructors fp_uninit.

  Definition fp (ex:t): relation eidT :=
    (ex.(pf)⁻¹ ⨾ ex.(co)) ∪ (fp_uninit ex).

  Definition fob (ex:t): relation eidT :=
    (⦗ex.(label_is) Label.is_access⦘ ⨾
     po ⨾
     ⦗ex.(label_is) Label.is_flush⦘) ∪
    ((⦗ex.(label_is) Label.is_kinda_read⦘ ∪
      (⦗ex.(label_is) Label.is_write⦘ ⨾
       po ⨾
       (⦗ex.(label_is) (Label.is_barrier_c Barrier.is_mfence)⦘ ∪
        ⦗ex.(label_is) (Label.is_barrier_c Barrier.is_sfence)⦘)))⨾
     po ⨾
     ⦗ex.(label_is) Label.is_flushopt⦘) ∪
    (⦗ex.(label_is) Label.is_write⦘ ⨾
     (po ⨾
      ⦗ex.(label_is) Label.is_flush⦘)^? ⨾
     (po_cl ex) ⨾
     ⦗ex.(label_is) Label.is_flushopt⦘).

  Definition ob (ex:t): relation eidT :=
    (obs ex) ∪ (dob ex) ∪ (bob ex) ∪ (fob ex) ∪ (pf ex) ∪ (fp ex).

  Definition per (ex:t): relation eidT :=
    ex.(pf) ⨾
    (⦗ex.(label_is) Label.is_flush⦘ ∪
     (⦗ex.(label_is) Label.is_flushopt⦘ ⨾
      po ⨾
      ⦗ex.(label_is) Label.is_persist_barrier⦘)).

  Ltac obtac :=
    repeat
      (try match goal with
           | [H: Execution.ob _ _ _ |- _] => inv H
           | [H: Execution.obs _ _ _ |- _] => inv H
           | [H: Execution.dob _ _ _ |- _] => inv H
           | [H: Execution.bob _ _ _ |- _] => inv H
           | [H: Execution.fob _ _ _ |- _] => inv H
           | [H: Execution.fr _ _ _ |- _] => inv H
           | [H: Execution.fre _ _ _ |- _] => inv H
           | [H: Execution.rfe _ _ _ |- _] => inv H
           | [H: Execution.fp _ _ _ |- _] => inv H
           | [H: Execution.fp_uninit _ _ _ |- _] => inv H
           | [H: Execution.per _ _ _ |- _] => inv H
           | [H: (_⨾ _) _ _ |- _] => inv H
           | [H: ⦗_⦘ _ _ |- _] => inv H
           | [H: (_ ∪ _) _ _ |- _] => inv H
           | [H: (_ ∩ _) _ _ |- _] => inv H
           | [H: (_ × _) _ _ |- _] => inv H
           | [H: (minus_rel _ _) _ |- _] => inv H
           | [H: Execution.label_is _ _ _ |- _] => inv H
           | [H: Execution.label_rel _ _ _ _ |- _] => inv H
           | [H: Execution.label_loc _ _ |- _] => inv H
           | [H: Execution.label_cl _ _ |- _] => inv H
           end;
       des).

  Ltac simtac :=
  repeat match goal with
           | [H: _ |- (_⨾ _) _ _] => econs
           | [H: _ |- ⦗Execution.label_is _ _⦘ _ _] => econs; eauto with tso
           | [H: _ |- Execution.label_is _ _ _] => eauto with tso
           | [H: _ |- Execution.label_rel _ _ _ _] => econs; eauto with tso
           | [H: _ |- rc _ _ /\ _] => econs; eauto
           | [H: _ |- Execution.po _ _ /\ _] => econs; eauto
           | [H: _ |- _ /\ Execution.po _ _] => econs; eauto
           | [H: _ |- Execution.po_cl _ _ _ /\ _] => econs; eauto
           | [H: _ |- Execution.pf _ _ _ /\ _] => econs; eauto
           | [H: _ |- ⦗Execution.label_is _ _⦘ _ _ /\ _] => econs; econs; eauto with tso
           | [H: _ |- Execution.fp_uninit _ _ _] => econs; eauto with tso
          end.

  Ltac labtac :=
    repeat match goal with
            | [H1: Execution.label ?eid ?ex = Some (_ _ _),
              H2: Execution.label ?eid ?ex = Some (_ _ _) |- _] =>
              rewrite H1 in H2; inv H2
            | [H1: Execution.label ?eid ?ex = Some (_ _ _ _),
              H2: Execution.label ?eid ?ex = Some (_ _ _) |- _] =>
              rewrite H1 in H2; inv H2
            | [H1: Execution.label ?eid ?ex = Some (_ _ _),
              H2: Execution.label ?eid ?ex = Some ?l2 |- _] =>
              rewrite H1 in H2; inv H2
            | [H1: Execution.label ?eid ?ex = Some (_ _ _ _),
              H2: Execution.label ?eid ?ex = Some ?l2 |- _] =>
              rewrite H1 in H2; inv H2
            | [H1: Execution.label ?eid ?ex = Some ?l1,
              H2: Execution.label ?eid ?ex = Some ?l2 |- _] =>
              rewrite H1 in H2; inv H2
            end; ss.

  Lemma fob_persist
        ex
        eid1 eid2
        (FOB: (fob ex) eid1 eid2):
    ex.(label_is) Label.is_persist eid2.
  Proof.
    obtac; simtac.
  Qed.

End Execution.

Ltac obtac := Execution.obtac.
Ltac simtac := Execution.simtac.
Ltac labtac := Execution.labtac.

Inductive tid_lift (tid:Id.t) (rel:relation nat) (eid1 eid2:eidT): Prop :=
| tid_lift_intro
    (TID1: fst eid1 = tid)
    (TID1: fst eid2 = tid)
    (REL: rel (snd eid1) (snd eid2))
.
Hint Constructors tid_lift : tso.

Lemma tid_lift_incl
      tid rel1 rel2
      (REL: rel1 ⊆ rel2):
  tid_lift tid rel1 ⊆ tid_lift tid rel2.
Proof.
  ii. inv H. econs; eauto.
Qed.

Inductive tid_join (rels: IdMap.t (relation nat)) (eid1 eid2:eidT): Prop :=
| tid_join_intro
    tid rel
    (RELS: IdMap.find tid rels = Some rel)
    (REL: tid_lift tid rel eid1 eid2)
.
Hint Constructors tid_join : tso.

Module Valid.
  Inductive pre_ex (p:program) (ex:Execution.t) := mk_pre_ex {
    aeus: IdMap.t AExecUnit.t;

    AEUS: IdMap.Forall2
            (fun tid stmts aeu =>
               rtc AExecUnit.step
                   (AExecUnit.mk (State.init stmts) ALocal.init)
                   aeu)
            p aeus;
    LABELS: ex.(Execution.labels) = IdMap.map (fun aeu => aeu.(AExecUnit.local).(ALocal.labels)) aeus;
  }.
  Hint Constructors pre_ex : tso.

  Definition co1 (ex: Execution.t) :=
    forall eid1 eid2,
      (exists loc,
          <<LABEL: ex.(Execution.label_is) (Label.is_kinda_writing loc) eid1>> /\
          <<LABEL: ex.(Execution.label_is) (Label.is_kinda_writing loc) eid2>>) ->
      (eid1 = eid2 \/ ex.(Execution.co) eid1 eid2 \/ ex.(Execution.co) eid2 eid1).

  Definition co2 (ex: Execution.t) :=
    forall eid1 eid2,
      ex.(Execution.co) eid1 eid2 ->
      exists loc,
        <<LABEL: ex.(Execution.label_is) (Label.is_kinda_writing loc) eid1>> /\
        <<LABEL: ex.(Execution.label_is) (Label.is_kinda_writing loc) eid2>>.

  Definition rf1 (ex: Execution.t) :=
    forall eid1 loc val
       (LABEL: ex.(Execution.label_is) (Label.is_kinda_reading_val loc val) eid1),
      (<<NORF: ~ codom_rel ex.(Execution.rf) eid1>> /\ <<VAL: val = Val.default>>) \/
      (exists eid2,
          <<LABEL: ex.(Execution.label_is) (Label.is_kinda_writing_val loc val) eid2>> /\
          <<RF: ex.(Execution.rf) eid2 eid1>>).

  Definition rf2 (ex: Execution.t) :=
    forall eid1 eid2 (RF: ex.(Execution.rf) eid2 eid1),
    exists loc val,
      <<READ: ex.(Execution.label_is) (Label.is_kinda_reading_val loc val) eid1>> /\
      <<WRITE: ex.(Execution.label_is) (Label.is_kinda_writing_val loc val) eid2>>.

  Definition rf_wf (ex: Execution.t) := functional (ex.(Execution.rf))⁻¹.

  Definition pf1 (ex: Execution.t):=
    forall eid1 loc
           (LABEL: ex.(Execution.label_is) (Label.is_persisting_cl loc) eid1),
      <<NOPF: Execution.no_pf ex loc eid1>> \/
      (exists eid2,
          <<LABEL: ex.(Execution.label_is) (Label.is_kinda_writing loc) eid2>> /\
          <<PF: ex.(Execution.pf) eid2 eid1>>).

  Definition pf2 (ex: Execution.t) :=
    forall eid1 eid2 (PF: ex.(Execution.pf) eid2 eid1),
      exists loc,
      <<PERSIST: ex.(Execution.label_is) (Label.is_persisting_cl loc) eid1>> /\
      <<WRITE: ex.(Execution.label_is) (Label.is_kinda_writing loc) eid2>>.

  Inductive persisted_event (ex:Execution.t) (loc:Loc.t) (eid:eidT) :=
  | persisted_event_intro
    (EID: ex.(Execution.label_is) (Label.is_kinda_writing loc) eid)
    (DOM: dom_rel (Execution.per ex) eid)
  .
  Hint Constructors persisted_event : tso.

  Inductive persisted_loc (ex:Execution.t) (loc:Loc.t) (val:Val.t): Prop :=
  | persisted_loc_uninit
      (UNINIT: val = Val.default)
      (NPER: forall eid (PEID: persisted_event ex loc eid), False)
  | persisted_loc_init
      eid
      (EID: ex.(Execution.label_is) (Label.is_kinda_writing_val loc val) eid)
      (PER: forall eid0 (PEID: persisted_event ex loc eid0), ex.(Execution.co)^? eid0 eid)
  .
  Hint Constructors persisted_loc : tso.

  Definition persisted ex smem :=
    forall loc, persisted_loc ex loc (smem loc).

  Inductive ex (p:program) (ex:Execution.t) := mk_ex {
    PRE: pre_ex p ex;
    CO1: co1 ex;
    CO2: co2 ex;
    RF1: rf1 ex;
    RF2: rf2 ex;
    RF_WF: rf_wf ex;
    PF1: pf1 ex;
    PF2: pf2 ex;
    COWR: irreflexive (Execution.cowr ex);
    CORW: irreflexive (Execution.corw ex);
    EXTERNAL: acyclic (Execution.ob ex);
  }.
  Hint Constructors ex : tso.
  Coercion PRE: ex >-> pre_ex.

  Definition is_terminal
             p ex (EX: pre_ex p ex): Prop :=
    forall tid aeu (FIND: IdMap.find tid EX.(aeus) = Some aeu),
      State.is_terminal aeu.(AExecUnit.state).

  Lemma po_label_pre
        p exec
        eid1 eid2 label2
        (PRE: pre_ex p exec)
        (PO: Execution.po eid1 eid2)
        (LABEL: Execution.label eid2 exec = Some label2):
    exists label1, <<LABEL: Execution.label eid1 exec = Some label1>>.
  Proof.
    destruct eid1, eid2. inv PO. ss. subst.
    revert LABEL. unfold Execution.label.
    rewrite PRE.(LABELS), ? IdMap.map_spec. s.
    destruct (IdMap.find t0 PRE.(aeus)) eqn:LOCAL; ss.
    generalize (PRE.(AEUS) t0). rewrite LOCAL. intro X. inv X. des.
    i. exploit List.nth_error_Some. rewrite LABEL. intros [X _]. exploit X; [congr|]. clear X. i.
    generalize (List.nth_error_Some t.(AExecUnit.local).(ALocal.labels) n). intros [_ X]. hexploit X; [lia|]. i.
    destruct (List.nth_error t.(AExecUnit.local).(ALocal.labels) n); ss. eauto.
  Qed.

  Lemma po_label
        p exec
        eid1 eid2 label2
        (EX: ex p exec)
        (PO: Execution.po eid1 eid2)
        (LABEL: Execution.label eid2 exec = Some label2):
    exists label1, <<LABEL: Execution.label eid1 exec = Some label1>>.
  Proof.
    inv EX. eapply po_label_pre; eauto.
  Qed.

  Lemma po_irrefl:
    forall eid (PO: Execution.po eid eid), False.
  Proof.
    ii. inv PO. lia.
  Qed.

  Lemma coi_is_po
        p exec
        eid1 eid2
        (EX: ex p exec)
        (RF: exec.(Execution.co) eid1 eid2)
        (I: Execution.i eid1 eid2):
    Execution.po eid1 eid2.
  Proof.
    destruct eid1 as [tid1 iid1].
    destruct eid2 as [tid2 iid2].
    inv I. ss. subst.
    destruct (lt_eq_lt_dec iid2 iid1); ss.
    exfalso. eapply EX.(EXTERNAL). apply t_step_rt. esplits.
    { left. left. left. left. left. right. eauto. }
    exploit EX.(CO2); eauto. i. des. inv LABEL. inv LABEL0.
    destruct s.
    + econs 1.  left. left. left. left. right. right. econs. esplits.
      * econs; eauto with tso.
      * econs. esplits; cycle 1.
        { econs; eauto with tso. }
        eauto with tso.
    + subst. econs 2.
  Qed.

  Lemma rfi_is_po
        p exec
        eid1 eid2
        (EX: ex p exec)
        (RF: exec.(Execution.rf) eid1 eid2)
        (I: Execution.i eid1 eid2):
    Execution.po eid1 eid2.
  Proof.
    destruct eid1 as [tid1 iid1].
    destruct eid2 as [tid2 iid2].
    inv I. ss. subst. econs; ss.
    destruct (le_lt_dec iid2 iid1); ss.
    exfalso. eapply EX.(CORW). econs. econs; [|by eauto].
    apply Nat.le_lteq in l. des.
    - econs 2. ss.
    - econs 1. eauto.
  Qed.

  Lemma coherence_ww
        p exec
        eid1 eid2 loc
        (EX: ex p exec)
        (EID1: exec.(Execution.label_is) (Label.is_kinda_writing loc) eid1)
        (EID2: exec.(Execution.label_is) (Label.is_kinda_writing loc) eid2)
        (PO: Execution.po eid1 eid2):
    exec.(Execution.co) eid1 eid2.
  Proof.
    inv EID1. inv EID2. exploit EX.(CO1).
    { obtac. esplits; econs; [exact EID| |exact EID0|]; eauto. }
    i. des; ss.
    { subst. apply po_irrefl in PO. inv PO. }
    exfalso. eapply EX.(EXTERNAL). apply t_step_rt. esplits.
    - left. left. left. left. left. right. eauto.
    - econs. left. left. left. left. right. right. econs. esplits.
      + econs; eauto with tso.
      + econs. esplits; eauto. econs; eauto with tso.
  Qed.

  Lemma coherence_wr
        p exec
        eid1 eid2 loc
        (EX: ex p exec)
        (EID1: exec.(Execution.label_is) (Label.is_kinda_writing loc) eid1)
        (EID2: exec.(Execution.label_is) (Label.is_kinda_reading loc) eid2)
        (PO: Execution.po eid1 eid2):
    exists eid3,
      <<RF: exec.(Execution.rf) eid3 eid2>> /\
      <<CO: exec.(Execution.co)^? eid1 eid3>>.
  Proof.
    inv EID1. inv EID2.
    inversion LABEL0. apply Label.kinda_reading_exists_val in H0. des.
    exploit EX.(RF1).
    { instantiate (1 := eid2). econs; eauto. }
    i. des.
    { exfalso. eapply EX.(COWR). econs; econs; [by eauto|].
      right. econs.
      - econs; eauto with tso.
      - econs; econs; eauto with tso.
    }
    esplits; eauto.
    exploit EX.(CO1).
    { obtac. esplits; econs; [exact EID| |exact EID1|]; eauto with tso. }
    i. des; subst; ss.
    { refl. }
    { econs 2. ss. }
    exfalso. eapply EX.(COWR). econs; econs; [by eauto|].
    econs; eauto. econs; eauto.
  Qed.

  Lemma coherence_rr
        p exec
        eid1 eid2 eid3 loc
        (EX: ex p exec)
        (EID1: exec.(Execution.label_is) (Label.is_kinda_reading loc) eid1)
        (EID2: exec.(Execution.label_is) (Label.is_kinda_reading loc) eid2)
        (EID3: exec.(Execution.label_is) (Label.is_kinda_writing loc) eid3)
        (RF: exec.(Execution.rf) eid3 eid1)
        (PO: Execution.po eid1 eid2):
    exists eid4,
      <<RF: exec.(Execution.rf) eid4 eid2>> /\
      <<CO: exec.(Execution.co)^? eid3 eid4>>.
  Proof.
    inv EID1. inv EID2. inv EID3.
    destruct eid1 as [tid1 iid1].
    destruct eid2 as [tid2 iid2].
    destruct eid3 as [tid3 iid3].
    inversion PO. ss. subst.
    inv LABEL0. apply Label.kinda_reading_exists_val in H0. des.
    destruct (tid2 == tid3).
    - inv e. exploit rfi_is_po; eauto with tso. intro X. inv X. ss. subst.
      (* po-wr -> co?; rf *)
      exploit EX.(RF1); eauto with tso. i. des.
      + exfalso. exploit EX.(COWR); eauto. instantiate (1 := (tid3, iid3)). econs; esplits.
        * etrans; eauto. econs; ss.
        * right. econs.
          -- econs; eauto with tso.
          -- econs; eauto with tso. econs; eauto with tso.
      + inv LABEL0. rename eid2 into eid4. exploit EX.(CO1).
        { obtac. esplits; econs; [exact EID1| |exact EID2|]; eauto with tso. }
        intro X. rewrite <- or_assoc in X. destruct X; [by esplits; eauto|].
        exfalso. exploit EX.(COWR); eauto. instantiate (1 := (tid3, iid3)). econs; esplits.
        { etrans; eauto. econs; ss. }
        left. econs; eauto.
    - (* ob-wr -> co?; rf *)
      exploit EX.(RF1); eauto with tso. i. des.
      + exfalso. exploit EX.(EXTERNAL); eauto. instantiate (1 := (tid3, iid3)).
        apply t_step_rt. econs; eauto. esplits; [|etrans; [econs|econs]].
        * repeat left. econs; eauto with tso.
        * left. left. left. left. right. left. econs. esplits.
          -- econs; eauto with tso.
          -- econs. esplits; eauto. econs; eauto with tso.
        * left. left. left. left. left. left. right. split; ss. right. econs.
          -- econs; eauto with tso.
          -- econs; eauto with tso. econs; eauto with tso.
      + inv LABEL0. rename eid2 into eid4. exploit EX.(CO1).
        { obtac. esplits; econs; [exact EID1| |exact EID2|]; eauto with tso. }
        intro X. rewrite <- or_assoc in X. destruct X; [by esplits; eauto|].
        exfalso. exploit EX.(EXTERNAL); eauto. instantiate (1 := (tid3, iid3)).
        apply t_step_rt. econs; eauto. esplits; [|etrans; [econs|econs]].
        * repeat left. econs; eauto with tso.
        * left. left. left. left. right. left. econs. esplits.
          -- econs; eauto with tso.
          -- econs. esplits; eauto. econs; eauto with tso.
        * left. left. left. left. left. left. right. split; ss. econs. econs. econs; eauto.
  Qed.

  Lemma coherence_rw
        p exec
        eid1 eid2 eid3 loc
        (EX: ex p exec)
        (EID1: exec.(Execution.label_is) (Label.is_kinda_reading loc) eid1)
        (EID2: exec.(Execution.label_is) (Label.is_kinda_writing loc) eid2)
        (EID3: exec.(Execution.label_is) (Label.is_kinda_writing loc) eid3)
        (RF1: exec.(Execution.rf) eid3 eid1)
        (PO: Execution.po eid1 eid2):
    exec.(Execution.co) eid3 eid2.
  Proof.
    inv EID1. inv EID2. inv EID3.
    exploit EX.(CO1).
    { obtac. esplits; econs; [exact EID0| |exact EID1|]; eauto. }
    i. rewrite <- or_assoc in x0. destruct x0; [|done]. inv H.
    { exfalso. eapply EX.(CORW). econs; eauto. }
    destruct (fst eid1 == fst eid3).
    - (* rfi *)
      exfalso. eapply EX.(CORW). econs. instantiate (1 := eid1). esplits; [|by eauto].
      right. rewrite PO.
      inv PO. inv e. rewrite TID in H1. eapply coi_is_po in H0; eauto with tso.
    - (* rfe *)
      exfalso. eapply EX.(EXTERNAL). apply t_step_rt. esplits.
      { repeat left. econs; eauto with tso. }
      etrans.
      + instantiate (1 := eid2). econs. left. left. left. left. right. left. econs. econs.
        * econs; eauto with tso.
        * econs; eauto. econs; eauto. econs; eauto with tso.
      + econs. left. left. left. left. left. right. eauto.
  Qed.

  Lemma rf_inv_write
        p exec
        eid1 eid2 loc val
        (EX: ex p exec)
        (EID2: exec.(Execution.label_is) (Label.is_kinda_reading_val loc val) eid2)
        (RF3: exec.(Execution.rf) eid1 eid2):
    <<LABEL: exec.(Execution.label_is) (Label.is_kinda_writing_val loc val) eid1>>.
  Proof.
    exploit EX.(RF1); eauto. i. des.
    - contradict NORF. econs. eauto.
    - exploit EX.(RF_WF); [exact RF3|exact RF|]. i. subst. eauto.
  Qed.

  Lemma barrier_ob
        p exec
        eid1 eid2
        (EX: pre_ex p exec)
        (CO2: co2 exec)
        (RF2: rf2 exec)
        (PF2: pf2 exec)
        (EID1: Execution.label_is exec Label.is_barrier eid1)
        (OB: Execution.ob exec eid1 eid2):
    False.
  Proof.
    inv EID1. destruct l; ss. unfold co2, rf2 in *.
    obtac; labtac; ss.
    - exploit RF2; eauto. i. des. obtac. labtac.
    - exploit RF2; eauto. i. des. obtac. labtac.
    - exploit CO2; eauto. i. des. obtac. labtac.
    - exploit PF2; eauto. i. des. obtac. labtac.
    - exploit PF2; eauto. i. des. obtac. labtac.
  Qed.

  Lemma ob_label
        p exec
        eid1 eid2
        (PRE: pre_ex p exec)
        (CO2: co2 exec)
        (RF2: rf2 exec)
        (PF2: pf2 exec)
        (OB: Execution.ob exec eid1 eid2)
        (EID1: Execution.label eid1 exec = None):
    False.
  Proof.
    unfold co2, rf2 in *.
    obtac.
    all: try congr.
    - exploit RF2. eauto. i. des. inv WRITE. inv READ.
      destruct l; ss. destruct l0; ss. congr. congr.
      destruct l0; ss. congr. congr.
    - exploit RF2. eauto. i. des. inv WRITE. inv READ.
      destruct l; ss. destruct l0; ss. congr. congr.
      destruct l0; ss. congr. congr.
    - exploit CO2; eauto. i. des. obtac. congr.
    - exploit PF2; eauto. i. des. obtac. congr.
    - exploit PF2; eauto. i. des. obtac. congr.
  Qed.

  Lemma ob_cycle
        p exec eid
        (PRE: pre_ex p exec)
        (CO2: co2 exec)
        (RF2: rf2 exec)
        (PF2: pf2 exec)
        (CYCLE: (Execution.ob exec)⁺ eid eid):
    exists eid_nb,
      (Execution.ob exec ∩ (Execution.label_is_rel exec Label.is_access_persist))⁺ eid_nb eid_nb.
  Proof.
    exploit minimalize_cycle; eauto.
    { instantiate (1 := Execution.label_is exec Label.is_access_persist).
      i. destruct (Execution.label b exec) eqn:LABEL.
      - destruct t; try by contradict H1; econs; eauto.
        exfalso. eapply barrier_ob; eauto with tso.
      - exfalso. eapply ob_label; eauto.
    }
    i. des.
    - esplits. eapply clos_trans_mon; eauto. s. i. des.
      econs; ss. inv H0. inv H1. econs; eauto.
    - destruct (Execution.label a exec) eqn:LABEL.
      + destruct t; try by contradict x0; econs; eauto.
        exfalso. eapply barrier_ob; eauto with tso.
      + exfalso. eapply ob_label; eauto.
  Qed.

  Lemma ob_read_read_po
        p ex
        eid1 eid2
        (PRE: pre_ex p ex)
        (CO2: co2 ex)
        (RF2: rf2 ex)
        (PF2: pf2 ex)
        (OB: Execution.ob ex eid1 eid2)
        (EID1: ex.(Execution.label_is) Label.is_read eid1)
        (EID2: ex.(Execution.label_is) Label.is_read eid2):
    Execution.po eid1 eid2.
  Proof.
    inv EID1. inv EID2.
    destruct l; ss. destruct l0; ss.
    obtac; labtac.
    - exploit RF2; eauto. i. des.
      inv WRITE. labtac.
    - exploit CO2; eauto. i. des.
      obtac. labtac.
    - exploit CO2; eauto. i. des.
      obtac. labtac.
    - etrans; eauto.
    - exploit PF2; eauto. i. des.
      obtac. labtac.
    - exploit PF2; eauto. i. des.
      obtac. labtac.
  Qed.

  Lemma persist_ob_write
        ex
        eid1 eid2
        (CO2: co2 ex)
        (RF2: rf2 ex)
        (PF2: pf2 ex)
        (OB: Execution.ob ex eid1 eid2)
        (EID1: ex.(Execution.label_is) Label.is_persist eid1):
    ex.(Execution.label_is) Label.is_kinda_write eid2.
  Proof.
    obtac; labtac.
    all: try by destruct l1; ss.
    all: try by destruct l2; ss.
    - exploit RF2; eauto. i. des.
      obtac. labtac. destruct l0; ss.
    - exploit RF2; eauto. i. des.
      obtac. labtac. destruct l1; ss.
    - exploit CO2; eauto. i. des.
      obtac. labtac. destruct l1; ss.
    - exploit PF2; eauto. i. des.
      obtac. labtac. destruct l0; ss.
    - exploit CO2; eauto. i. des.
      obtac. simtac.
    - simtac.
  Qed.

  Lemma ob_persist_spec
        ex
        eid1 eid2
        (CO2: co2 ex)
        (RF2: rf2 ex)
        (PF2: pf2 ex)
        (OB: Execution.ob ex eid1 eid2)
        (EID1: ex.(Execution.label_is) Label.is_persist eid2):
    <<ACCESS: ex.(Execution.label_is) Label.is_access eid1>>.
  Proof.
    inv OB; cycle 1.
    { obtac.
      - exploit CO2; eauto. i. des.
        obtac. labtac. destruct l0; ss; congr.
      - destruct l; destruct l1; ss; congr.
    }
    inv H; cycle 1.
    { exploit PF2; eauto. i. des.
      obtac. econs; eauto with tso.
    }
    inv H0; cycle 1.
    { obtac; econs; eauto with tso. }
    obtac; labtac.
    all: try by destruct l1; ss.
    all: try by destruct l2; ss.
    - exploit RF2; eauto. i. des.
      obtac. labtac. destruct l1; ss.
    - exploit CO2; eauto. i. des.
      obtac. labtac. destruct l0; ss.
    - exploit CO2; eauto. i. des.
      obtac. labtac. destruct l0; ss.
  Qed.
End Valid.

Coercion Valid.PRE: Valid.ex >-> Valid.pre_ex.


Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq fintype finfun.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import Bool.
Require Import Zbool.
Require Import BinPos.
Require Import eq_dec.

Require Import Globalenvs.
Require Import Memory.
Require Import Values.
Require Import Maps.

Require Import Axioms.

Require Import sepcomp. Import SepComp.

Require Import pred_lemmas.
Require Import seq_lemmas.
Require Import inj_lemmas.
Require Import join_sm.

(* nwp = no wild pointers *)

Definition nwp_aux m (IN OUT : block -> bool) :=
  forall b ofs,
  IN b ->
  Mem.perm m b ofs Cur Readable ->
  forall b' ofs' n,
    ZMap.get ofs (Mem.mem_contents m) !! b = Pointer b' ofs' n ->
    OUT b'.

Definition nwp m := [fun bs => nwp_aux m bs bs].

Lemma nwp_REACH_closed1 bs m :
  nwp m bs ->
  REACH_closed m bs.
Proof.
move=> A; rewrite/REACH_closed=> b; rewrite REACHAX=> [][]L B.
elim: L b B=> //; first by move=> b; rewrite reach_reach'.
move=> [b' ofs'] L' IH b; rewrite reach_reach'=> /=.
move: {A}(A b' ofs').
case: (ZMap.get _ _ !! _)=> // b'' n n' A []B []C.
rewrite -reach_reach'; move/(IH _)=> D.
by move: (A D C b'' n n' erefl); rewrite -B.
Qed.

Lemma nwp_REACH_closed2 bs m :
  REACH_closed m bs ->
  nwp m bs.
Proof.
rewrite/REACH_closed=> A b ofs B C b' ofs' n D; apply: A.
by rewrite REACHAX; exists [:: (b,ofs)]; rewrite reach_reach' /= D.
Qed.

Lemma REACH_closedP bs m : REACH_closed m bs <-> nwp m bs.
Proof.
split; first by apply: nwp_REACH_closed2.
by apply: nwp_REACH_closed1.
Qed.

(* nwp_aux is invariant over disjoint memory updates -- phi2 is the frame *)

Lemma nwp_aux_pre phi1 phi1' phi2 m :
  nwp_aux m phi1 phi2 ->
  {subset phi1' <= phi1} ->
  nwp_aux m phi1' phi2.
Proof.
move=> A sub b ofs B C b' ofs' n D.
by move: (sub _ B); move/(A b ofs); move/(_ C b' ofs' n D).
Qed.

Lemma nwp_aux_post phi1 phi2 phi2' m :
  nwp_aux m phi1 phi2 ->
  {subset phi2 <= phi2'} ->
  nwp_aux m phi1 phi2'.
Proof.
move=> A sub b ofs B C b' ofs' n D.
by apply: sub; apply: (A _ _ B C b' ofs' n D).
Qed.

Lemma nwp_aux_update phi1 phi2 m m' :
  (forall b, phi2 b=true -> Mem.valid_block m b) ->
  nwp_aux m phi2 (fun b => phi1 b || phi2 b) ->
  Mem.unchanged_on (fun b ofs => phi2 b) m m' ->
  nwp_aux m' phi1 (fun b => phi1 b || phi2 b) ->
  nwp_aux m' phi2 (fun b => phi1 b || phi2 b).
Proof.
move=> val A unch C b ofs D E b' ofs' n F.
have G: Mem.perm m b ofs Cur Readable.
  by case: unch; move/(_ b ofs Cur Readable D (val _ D))=> ->.
apply: (A b ofs D G b' ofs' n).
by case: unch=> _; move/(_ _ _ D G)=> <-.
Qed.

Lemma nwp_unchanged_on m m' bs :
  nwp m bs ->
  mem_forward m m' ->
  Mem.unchanged_on (fun b ofs => bs b) m m' ->
  (forall b, bs b -> Mem.valid_block m b) ->
  nwp m' bs.
Proof.
by move=> A B C D; apply nwp_aux_update
  with (phi1 := fun b => false) (phi2 := bs) (m := m).
Qed.

Lemma nwp_union phi1 phi2 m :
  nwp_aux m phi1 (fun b => phi1 b || phi2 b) ->
  nwp_aux m phi2 (fun b => phi1 b || phi2 b) ->
  nwp m (fun b => phi1 b || phi2 b).
Proof.
move=> A B b ofs; move/orP; case=> C D b' ofs' n E.
by apply: (A b ofs C D b' ofs' n E).
by apply: (B b ofs C D b' ofs' n E).
Qed.

Lemma nwp_aux_update_spec1 priv1 pub1 priv2 pub2 m m' :
  let phi1 := fun b => priv1 b || pub1 b || pub2 b in
  let phi2 := fun b => priv2 b in
  (forall b, phi2 b=true -> Mem.valid_block m b) ->
  nwp m (fun b => phi1 b || phi2 b) ->
  Mem.unchanged_on (fun b ofs => phi2 b) m m' ->
  nwp m' phi1 ->
  nwp m' (fun b => phi1 b || phi2 b).
Proof.
move=> phi1 phi2 A B C D.
have X: nwp_aux m phi2 (fun b : block => phi1 b || phi2 b).
  apply nwp_aux_pre with (phi1 := (fun b => phi1 b || phi2 b))=> //.
  by move=> b; rewrite/in_mem/= => ->; apply/orP; right.
have Y: nwp_aux m' phi1 (fun b : block => phi1 b || phi2 b).
  apply nwp_aux_post with (phi2 := phi1)=> //.
  by move=> b; rewrite/in_mem/= => ->; apply/orP; left.
move: (@nwp_aux_update phi1 phi2 m m' A X C Y)=> E.
by apply: (nwp_union Y E).
Qed.

Lemma nwp_aux_update_spec2 loc1 frgn1 loc2 frgn2 m m' :
  let phi1 := fun b => loc1 b || frgn1 b || frgn2 b in
  let phi2 := fun b => loc2 b && ~~frgn1 b in
  (forall b, phi2 b=true -> Mem.valid_block m b) ->
  nwp m (fun b => phi1 b || phi2 b) ->
  Mem.unchanged_on (fun b ofs => phi2 b) m m' ->
  nwp m' phi1 ->
  nwp m' (fun b => phi1 b || phi2 b).
Proof.
move=> phi1 phi2 A B C D.
have X: nwp_aux m phi2 (fun b : block => phi1 b || phi2 b).
  apply nwp_aux_pre with (phi1 := (fun b => phi1 b || phi2 b))=> //.
  by move=> b; rewrite/in_mem/= => ->; apply/orP; right.
have Y: nwp_aux m' phi1 (fun b : block => phi1 b || phi2 b).
  apply nwp_aux_post with (phi2 := phi1)=> //.
  by move=> b; rewrite/in_mem/= => ->; apply/orP; left.
move: (@nwp_aux_update phi1 phi2 m m' A X C Y)=> E.
by apply: (nwp_union Y E).
Qed.

Lemma nwp_aux_update_spec3 phi1 phi1' phi2 m m' :
  (forall b, phi2 b=true -> Mem.valid_block m b) ->
  nwp_aux m phi2 (fun b => phi1 b || phi2 b) ->
  Mem.unchanged_on (fun b ofs => phi2 b) m m' ->
  (forall b, phi1 b=true -> phi1' b=true) ->
  nwp_aux m' phi1' (fun b => phi1' b || phi2 b) ->
  nwp_aux m' phi2 (fun b => phi1' b || phi2 b).
Proof.
move=> A B C D E.
apply: (nwp_aux_update (m:=m))=> //.
apply: (nwp_aux_post (phi2:=(fun b => phi1 b || phi2 b)))=> //.
move=> b; rewrite/in_mem/=; case F: (phi1 b)=> //= X.
by apply/orP; left; apply: (D _ F).
by apply/orP; right.
Qed.

Lemma nwp_aux_update_spec4 loc1 loc1' frgn1 loc2 frgn2 m m' :
  let phi1 := fun b => loc1 b || frgn1 b || frgn2 b in
  let phi1' := fun b => loc1' b || frgn1 b || frgn2 b in
  let phi2 := fun b => loc2 b && ~~frgn1 b in
  (forall b, phi1 b -> phi1' b) ->
  (forall b, phi2 b=true -> Mem.valid_block m b) ->
  nwp m (fun b => phi1 b || phi2 b) ->
  Mem.unchanged_on (fun b ofs => phi2 b) m m' ->
  nwp m' phi1' ->
  nwp m' (fun b => phi1' b || phi2 b).
Proof.
move=> phi1 phi1' phi2 A B C D E.
have X: nwp_aux m phi2 (fun b : block => phi1 b || phi2 b).
  apply nwp_aux_pre with (phi1 := (fun b => phi1 b || phi2 b))=> //.
  by move=> b; rewrite/in_mem/= => ->; apply/orP; right.
have Y: nwp_aux m' phi1' (fun b : block => phi1' b || phi2 b).
  apply nwp_aux_post with (phi2 := phi1')=> //.
  by move=> b; rewrite/in_mem/= => ->; apply/orP; left.
move: (@nwp_aux_update_spec3 phi1 phi1' phi2 m m' B X D A Y)=> F.
by apply: (nwp_union Y F).
Qed.

Lemma nwp_aux_update_spec5 loc1 loc1' frgn1 loc2 frgn2 m m' :
  let phi1 := fun b => loc1 b || (frgn1 b && frgn2 b) in
  let phi1' := fun b => loc1' b || (frgn1 b && frgn2 b) in
  let phi2 := fun b => loc2 b && ~~frgn1 b in
  (forall b, phi1 b -> phi1' b) ->
  (forall b, phi2 b=true -> Mem.valid_block m b) ->
  nwp m (fun b => phi1 b || phi2 b) ->
  Mem.unchanged_on (fun b ofs => phi2 b) m m' ->
  nwp m' phi1' ->
  nwp m' (fun b => phi1' b || phi2 b).
Proof.
move=> phi1 phi1' phi2 A B C D E.
have X: nwp_aux m phi2 (fun b : block => phi1 b || phi2 b).
  apply nwp_aux_pre with (phi1 := (fun b => phi1 b || phi2 b))=> //.
  by move=> b; rewrite/in_mem/= => ->; apply/orP; right.
have Y: nwp_aux m' phi1' (fun b : block => phi1' b || phi2 b).
  apply nwp_aux_post with (phi2 := phi1')=> //.
  by move=> b; rewrite/in_mem/= => ->; apply/orP; left.
move: (@nwp_aux_update_spec3 phi1 phi1' phi2 m m' B X D A Y)=> F.
by apply: (nwp_union Y F).
Qed.

Lemma join_sm_REACH_closed mu1 mu1' mu2 m1 m1' :
  Mem.unchanged_on (fun b ofs =>
    locBlocksSrc mu2 b && ~~frgnBlocksSrc mu1 b) m1 m1' ->
  (forall b,
     frgnBlocksSrc mu1 b ->
     locBlocksSrc mu2 b || frgnBlocksSrc mu2 b) ->
  intern_incr mu1 mu1' ->
  smvalid_src mu2 m1 ->
  REACH_closed m1 (vis (join_sm mu1 mu2)) ->
  REACH_closed m1' (vis mu1') ->
  REACH_closed m1' (vis (join_sm mu1' mu2)).
Proof.
rewrite !REACH_closedP.
move=> A contain B valid.
rewrite/vis/join_sm/=/in_mem/= => C D.
set phi1 := (fun b =>
  locBlocksSrc mu1 b || frgnBlocksSrc mu1 b).
set phi1' := (fun b =>
  locBlocksSrc mu1' b || frgnBlocksSrc mu1 b).
set phi2 := (fun b => locBlocksSrc mu2 b && ~~frgnBlocksSrc mu1 b).
have val: forall b, phi2 b = true -> Mem.valid_block m1 b.
  rewrite/phi2=> b; move/andP=> []X Y.
  by move: (valid b); rewrite/DOM/DomSrc X; apply.
set phi0 := fun b => locBlocksSrc mu1 b || locBlocksSrc mu2 b
               || frgnBlocksSrc mu1 b && frgnBlocksSrc mu2 b.
have sub: forall b, phi1 b = true -> phi1' b = true.
  rewrite/phi1/phi1'=> b; case/orP=> X.
  by case: B=> _ []_ []; move/(_ b); rewrite X=> Y _; rewrite Y.
  by rewrite X; apply/orP; right.
have sub':
  forall b,
    locBlocksSrc mu1 b || locBlocksSrc mu2 b
      || frgnBlocksSrc mu1 b && frgnBlocksSrc mu2 b ->
    locBlocksSrc mu1 b || frgnBlocksSrc mu1 b
      || locBlocksSrc mu2 b && ~~ frgnBlocksSrc mu1 b.
  move=> b.
  case: (locBlocksSrc mu1 b)=> //=.
  case: (locBlocksSrc mu2 b)=> //=.
  case: (frgnBlocksSrc mu1 b)=> //.
  by move/andP=> []->.
have X: nwp_aux m1 phi2 (fun b : block => phi1 b || phi2 b).
  apply: (nwp_aux_pre (phi1 := phi0)).
  apply: (nwp_aux_post (phi2 := phi0))=> //.
  move=> b; rewrite/phi2/phi0/in_mem/=.
  by move/andP=> []-> _; apply/orP; left; apply/orP; right.
have eq: (frgnBlocksSrc mu1=frgnBlocksSrc mu1').
  by case: B=> _ []_ []_ []_ []_ []_ []->.
have Y: nwp_aux m1' phi1' (fun b : block => phi1' b || phi2 b).
  apply: (nwp_aux_pre
    (phi1 := (fun b => locBlocksSrc mu1' b || frgnBlocksSrc mu1' b))).
  apply: (nwp_aux_post
    (phi2 := (fun b => locBlocksSrc mu1' b || frgnBlocksSrc mu1' b)))=> //.
  by move=> b; rewrite/phi1'/phi2/in_mem/= eq=> ->.
  by move=> b; rewrite/phi1'/in_mem/= eq.
move: (@nwp_aux_update_spec3 phi1 phi1' phi2 m1 m1' val X A sub Y)=> E.
apply: (nwp_aux_pre (phi1 := fun b => phi1' b || phi2 b)).
apply: (nwp_aux_post (phi2 := fun b => phi1' b || phi2 b))=> //.
by apply: nwp_union.
move=> b; rewrite/in_mem/=/phi1'/phi2.
case U: (locBlocksSrc mu1' b)=> //=.
rewrite eq; case V: (frgnBlocksSrc mu1' b)=> //=.
by move=> _; apply: contain; rewrite eq.
move=> b; rewrite/in_mem/=/phi1'/phi2.
case: (locBlocksSrc mu1' b)=> //=.
case: (locBlocksSrc mu2)=> //=.
move=> _.
by case: (frgnBlocksSrc mu1 b).
rewrite eq.
by move/andP=> [] -> _.
Qed.

Lemma join_sm_REACH_closed' mu1 mu1' mu2 m1 m1' :
  DisjointLS mu1 mu2 ->
  Mem.unchanged_on (fun b ofs => vis mu1 b = false) m1 m1' ->
  (forall b,
     frgnBlocksSrc mu1 b ->
     locBlocksSrc mu2 b || frgnBlocksSrc mu2 b) ->
  intern_incr mu1 mu1' ->
  smvalid_src mu2 m1 ->
  REACH_closed m1 (vis (join_sm mu1 mu2)) ->
  REACH_closed m1' (vis mu1') ->
  REACH_closed m1' (vis (join_sm mu1' mu2)).
Proof.
move=> A B C D E F G.
have unch:
  Mem.unchanged_on (fun b ofs =>
    locBlocksSrc mu2 b && ~~frgnBlocksSrc mu1 b) m1 m1'.
  apply mem_unchanged_on_sub with (Q:=(fun b ofs => vis mu1 b=false))=> //.
  move=> b _; rewrite/vis.
  case H: (locBlocksSrc mu2 b)=> //=.
  case I: (frgnBlocksSrc mu1 b)=> //=.
  move: A; move/(DisjointP _); move/(_ b); rewrite H.
  by case=> //; case: (locBlocksSrc mu1 b).
by apply: (join_sm_REACH_closed unch C D E F G).
Qed.

Lemma join_all_REACH_closed
      (mu_trash mu mu' : Inj.t) (mus : seq Inj.t) m1 m1' :
  DisjointLS mu mu_trash ->
  All (DisjointLS mu) [seq Inj.mu x | x <- mus] ->
  Mem.unchanged_on (fun b ofs => vis mu b = false) m1 m1' ->
  (forall b,
     frgnBlocksSrc mu b ->
     let mu_rest := join_all mu_trash mus
     in locBlocksSrc mu_rest b || frgnBlocksSrc mu_rest b) ->
  intern_incr mu mu' ->
  smvalid_src mu_trash m1 ->
  All (fun mu0 => smvalid_src mu0 m1) [seq Inj.mu x | x <- mus] ->
  REACH_closed m1 (vis (join_all mu_trash (mu :: mus))) ->
  REACH_closed m1' (vis mu') ->
  REACH_closed m1' (vis (join_all mu_trash (mu' :: mus))).
Proof.
move=> /= A B C D E F G H I.
have disj: DisjointLS mu (join_all mu_trash mus).
  by apply: join_all_disjoint_src; split.
have val: smvalid_src (join_all mu_trash mus) m1.
  apply: join_all_valid_src=> //.
  by move: G; rewrite -All_comp3.
by apply: (join_sm_REACH_closed' disj C D E val H I).
Qed.

Lemma reach_trans m B L0 L1 b0 ofs0 b1 :
  reach m B (L0 ++ [::(b0,ofs0)]) b1 ->
  reach m B L1 b0 ->
  reach m B (L0 ++ [::(b0,ofs0) & L1]) b1.
Proof.
elim: L0 b0 ofs0 b1 L1.
move=> b0 ofs0 b1 L1 /=; inversion 1; subst=> A.
by eapply reach_cons; eauto.
case=> bb ofss L IH b0 ofs0 b1; inversion 1; subst=> /= A.
by eapply reach_cons; eauto.
Qed.

Lemma notin_REACHP m B b :
  b \notin REACH m B ->
  forall l, ~reach m B l b.
Proof.
move/negP=> H l H2; apply: H.
by rewrite /is_true /in_mem; rewrite /= REACHAX; exists l.
Qed.

Lemma valid_dec m b : Mem.valid_block m b -> valid_block_dec m b.
Proof. by rewrite /is_left; case l: (valid_block_dec m b). Qed.

Lemma valid_dec' m b : valid_block_dec m b -> Mem.valid_block m b.
Proof. by rewrite /is_left; case l: (valid_block_dec m b). Qed.

Section reach_upd.

Variable B : block -> bool.

Variable E : block -> Z -> bool.

Variable m1 m1' : mem.

Variable VIS' : block -> bool.

Variable E_sub : forall b ofs, E b ofs -> VIS' b.

Variable localloc_sub : {subset freshloc m1 m1' <= VIS'}.

Lemma reach_upd_inE b :
  b \notin REACH m1 B ->
  b \in REACH m1' B ->
  Mem.unchanged_on (fun b ofs => E b ofs=false) m1 m1' ->
  exists b0 ofs L, [/\ reach m1' B L b, List.In (b0,ofs) L & VIS' b0].
Proof.
rewrite /is_true /in_mem /= => H; rewrite REACHAX=> [][]L rch unch.
elim: L b H rch.
move=> b H; inversion 1; subst; move: {H}(negP H)=> H.
have H3: forall l, ~ reach m1 B l b.
{ by apply: notin_REACHP; apply/negP; apply: H. }
by elimtype False; apply: (H3 [::]); apply: reach_nil.
case=> b0 ofs0 L IH b H; inversion 1; subst.
have H7: forall l, ~ reach m1 B l b by apply: notin_REACHP.
case get: (ZMap.get ofs0 (Mem.mem_contents m1) !! b0)=> [||b' off' n'].
exists b0,ofs0,[::(b0,ofs0) & L]; split=> //; first by left.
case e: (E b0 ofs0); first by apply: (E_sub e).
case f: (valid_block_dec m1 b0)=> [valid|nvalid].
have H5': Mem.perm m1 b0 ofs0 Cur Readable.
{ case: unch; move/(_ _ _ _ _ e valid); case/(_ Cur Readable)=> E1 E2.
  by move=> _; apply: E2. }
by case: unch=> _; move/(_ _ _ e H5'); rewrite H6 get.
apply: localloc_sub; apply/andP; split=> //.
have X: Mem.valid_block m1' b0.
{ by move: H5; apply: Mem.perm_valid_block. }
by move: X; move/valid_dec.
by apply/negP; move/valid_dec'=> X; clear f; apply: nvalid.
exists b0,ofs0,[::(b0,ofs0) & L]; split=> //; first by left.
case e: (E b0 ofs0); first by apply: (E_sub e).
case f: (valid_block_dec m1 b0)=> [valid|nvalid].
have H5': Mem.perm m1 b0 ofs0 Cur Readable.
{ case: unch; move/(_ _ _ _ _ e valid); case/(_ Cur Readable)=> E1 E2.
  by move=> _; apply: E2. }
by case: unch=> _; move/(_ _ _ e H5'); rewrite H6 get.
apply: localloc_sub; apply/andP; split=> //.
have X: Mem.valid_block m1' b0.
{ by move: H5; apply: Mem.perm_valid_block. }
by move: X; move/valid_dec.
by apply/negP; move/valid_dec'=> X; clear f; apply: nvalid.
case p: (Mem.perm_dec m1 b0 ofs0 Cur Readable)=> [prm|nprm].

{ case e: (eq_dec (b,off) (b',off'))=> [pf|pf].
  inversion pf; subst; clear e pf.
  case f: (REACH m1 B b0).
  move: f; rewrite REACHAX; case=> L0 rch0.
  elimtype False; apply: (H7 [::(b0,ofs0) & L0]).
  by apply: (reach_cons _ _ _ _ _ _ _ _ rch0 prm get).
  have H8: ~~ REACH m1 B b0=true by apply/negP; rewrite f.
  case: (IH _ H8 H3)=> bM []offM []L0 []rch' inL0 inE.
  exists bM,offM,[::(b0,ofs0) & L0]; split=> //.
  by eapply reach_cons; eauto.
  by right.

  exists b0,ofs0,[::(b0,ofs0) & L]; split=> //; first by left.
  case f: (E b0 ofs0); first by apply: (E_sub f).
  case g: (valid_block_dec m1 b0)=> [valid|nvalid].
  have H5': Mem.perm m1 b0 ofs0 Cur Readable.
  { case: unch; move/(_ _ _ _ _ f valid); case/(_ Cur Readable)=> E1 E2.
    by move=> _; apply: E2. }
  case: unch=> _; move/(_ _ _ f H5'); rewrite H6 get=> H8.
  by move: pf e; case: H8=> -> -> _ pf; elimtype False; apply: pf.
  apply: localloc_sub; apply/andP; split=> //.
  have X: Mem.valid_block m1' b0.
  { by move: H5; apply: Mem.perm_valid_block. }
  by move: X; move/valid_dec.
  by apply/negP; move/valid_dec'=> X; clear g; apply: nvalid. }

{ exists b0,ofs0,[::(b0,ofs0) & L]; split=> //; first by left.
  case f: (E b0 ofs0); first by apply: (E_sub f).
  case g: (valid_block_dec m1 b0)=> [valid|nvalid].
  have H5': Mem.perm m1 b0 ofs0 Cur Readable.
  { case: unch; move/(_ _ _ _ _ f valid); case/(_ Cur Readable)=> E1 E2.
    by move=> _; apply: E2. }
  by clear p; elimtype False; apply: nprm.
  apply: localloc_sub; apply/andP; split=> //.
  have X: Mem.valid_block m1' b0.
  { by move: H5; apply: Mem.perm_valid_block. }
  by move: X; move/valid_dec.
  by apply/negP; move/valid_dec'=> X; clear g; apply: nvalid. }
Qed.

Lemma reach_split m X (Y : block -> bool) l1 l2 b0 ofs b :
  Y b0 ->
  reach m X ((l1 ++ [::(b0,ofs)]) ++ l2) b ->
  reach m Y (l1 ++ [::(b0,ofs)]) b.
Proof.
elim: l1 b=> //=.
move=> b H; inversion 1; subst; apply: reach_cons; eauto.
by apply: reach_nil.
case=> b1 ofs1 L IH b H; inversion 1; subst.
by apply: reach_cons; eauto.
Qed.

Lemma reach_upd b :
  b \notin REACH m1 B ->
  b \in REACH m1' B ->
  Mem.unchanged_on (fun b ofs => E b ofs=false) m1 m1' ->
  b \in REACH m1' VIS'.
Proof.
move=> H H2 H3; case: (reach_upd_inE H H2 H3).
move=> b0 []ofs []L []rch inL inE.
rewrite /in_mem /= /is_true REACHAX.
have [L0 [L1 L_eq]]: exists l0 l1, L = (l0 ++ [::(b0,ofs)]) ++ l1.
{ clear - inL; elim: L inL=> // a L IH /=; case.
  by move=> ->; exists [::],L.
  by case/IH=> l0 []l1 ->; exists [::a & l0],l1. }
exists (L0++[::(b0,ofs)]); move: rch; rewrite L_eq.
by apply: reach_split.
Qed.

End reach_upd.