Require Import FiatFormal.Language.Preservation.
Require Export FiatFormal.Language.Step.
Require Export FiatFormal.Language.SubstExpExp.
Require Export FiatFormal.Language.SubstTypeExp.
Require Import FiatFormal.Language.TyJudge.
Require Export FiatFormal.Language.Exp.

(********************************************************************)
(* Big Step Evaluation
   This is also called 'Natural Semantics'.
   It provides a relation between the expression to be reduced
   and its final value.
 *)
Inductive EVAL : exp -> exp -> Prop :=
 | EVDone
   :  forall v2
   ,  wnfX v2
   -> EVAL v2 v2.

Hint Constructors EVAL.

(* A terminating big-step evaluation always produces a wnf.
   The fact that the evaluation terminated is implied by the fact
   that we have a finite proof of EVAL to pass to this lemma.
 *)
Lemma eval_produces_wnfX
 :  forall x1 v1
 ,  EVAL   x1 v1
 -> wnfX  v1.
Proof.
 intros. induction H; eauto.
Qed.
Hint Resolve eval_produces_wnfX.

(********************************************************************)
(* Convert a big-step evaluation into a list of small steps. *)
(* Lemma steps_of_eval *)
(*  :  forall x1 t1 x2 *)
(*  ,  TYPE nil nil x1 t1 *)
(*  -> EVAL  x1 x2 *)
(*  -> STEPS x1 x2. *)
(* Proof. *)
(*  intros x1 t1 v2 HT HE. gen t1. *)

(*  (* Induction over the form of (EVAL x1 x2) *) *)
(*  induction HE. *)
(*  Case "EVDone". *)
(*   intros. apply ESNone. *)

(*  (* Case "EVLAMAPP". *) *)
(*  (*  intros. inverts HT. *) *)
(*  (*  lets E1: IHHE1 H3. clear IHHE1. *) *)
(*  (*  lets T1: preservation_steps H3 E1. inverts keep T1. *) *)
(*  (*  lets T2: subst_type_value H4 H5. *) *)
(*  (*   simpl in T2. *) *)
(*  (*  lets E2: IHHE2 T2. *) *)
(*  (*  eapply ESAppend. *) *)
(*  (*   apply steps_APP1. eauto. *) *)
(*  (*  eapply ESAppend. *) *)
(*  (*   eapply ESStep. *) *)
(*  (*    eapply ESLAMAPP. auto. *) *)

(*  Case "EVLamApp". *)
(*   intros. inverts HT. *)
(*   lets E1: IHHE1 H3. *)
(*   lets E2: IHHE2 H5. *)
(*   lets T1: preservation_steps H3 E1. inverts keep T1. *)
(*   lets T2: preservation_steps H5 E2. *)
(*   lets T3: subst_value_value H8 T2. *)
(*   lets E3: IHHE3 T3. *)
(*   eapply ESAppend. *)
(*     eapply steps_app1. eauto. *)
(*    eapply ESAppend. *)
(*     eapply steps_app2. eauto. eauto. *)
(*    eapply ESAppend. *)
(*     eapply ESStep. *)
(*      eapply ESLamApp. eauto. *)
(*    eauto. *)
(* Qed. *)

(* (********************************************************************) *)
(* (* Convert a list of small steps to a big-step evaluation. The main *)
(*    part of this is the expansion lemma, which we use to build up the *)
(*    overall big-step evaluation one small-step at a time. The other *)
(*   lemmas are used to feed it small-steps. *)
(*  *) *)

(* (* Given an existing big-step evalution, we can produce a new one *)
(*    that does an extra step before returning the original value. *)
(*  *) *)
(* Lemma eval_expansion *)
(*  :  forall ke te x1 t1 x2 v3 *)
(*  ,  TYPE ke te x1 t1 *)
(*  -> STEP x1 x2 -> EVAL x2 v3 *)
(*  -> EVAL x1 v3. *)
(* Proof. *)
(*  intros. gen ke te t1 v3. *)

(*  (* Induction over the form of (STEP x1 x2) *) *)
(*  induction H0; intros. *)

(*  Case "XApp". *)
(*   SCase "value app". *)
(*    eapply EVLamApp. *)
(*    eauto. *)
(*    inverts H. *)
(*    apply EVDone. auto. auto. *)

(*   SCase "x1 steps". *)
(*    inverts H. inverts H1. *)
(*     inverts H. *)
(*     eapply EVLamApp; eauto. *)

(*   SCase "x2 steps". *)
(*    inverts H1. inverts H2. *)
(*    inverts H1. *)
(*    eapply EVLamApp; eauto. *)

(*  (* Case "XAPP". *) *)
(*  (*  SCase "type app". *) *)
(*  (*   eapply EVLAMAPP. *) *)
(*  (*   eauto. *) *)
(*  (*   inverts H. *) *)
(*  (*   auto. *) *)

(*  (*  SCase "x1 steps". *) *)
(*  (*   inverts H. inverts H1. *) *)
(*  (*    inverts H. *) *)
(*  (*    eapply EVLAMAPP; eauto. *) *)
(* Qed. *)

(* (* Convert a list of small steps to a big-step evaluation. *) *)
(* Lemma eval_of_stepsl *)
(*  :  forall x1 t1 v2 *)
(*  ,  TYPE nil nil x1 t1 *)
(*  -> STEPSL x1 v2 -> value v2 *)
(*  -> EVAL   x1 v2. *)
(* Proof. *)
(*  intros. *)
(*  induction H0. *)

(*  Case "ESLNone". *)
(*    apply EVDone. inverts H1. auto. *)

(*  Case "ESLCons". *)
(*   eapply eval_expansion. *)
(*    eauto. eauto. *)
(*    apply IHSTEPSL. *)
(*    eapply preservation. eauto. auto. auto. *)
(* Qed. *)

(* (* Convert a multi-step evaluation to a big-step evaluation. *)
(*    We use stepsl_of_steps to flatten out the append constructors *)
(*    in the multi-step evaluation, leaving a list of individual *)
(*    small-steps. *)
(*  *) *)
(* Lemma eval_of_steps *)
(*  :  forall x1 t1 v2 *)
(*  ,  TYPE nil nil x1 t1 *)
(*  -> STEPS x1 v2 -> value v2 *)
(*  -> EVAL  x1 v2. *)
(* Proof. *)
(*  intros. *)
(*  eapply eval_of_stepsl; eauto. *)
(*  apply  stepsl_of_steps; auto. *)
(* Qed. *)


Require Export Coq.Program.Equality.
Require Export Coq.Program.Tactics.
Require Export DeclarationEvaluation.
Require Export DeclarationTyping.

(******************************************************************************)
(* Weakening lemmas                                                           *)
(******************************************************************************)

Lemma PTyping_domainEnv_subhvl_tm {Γ p T Δ} :
  PTyping Γ p T Δ → subhvl_tm (domainEnv Δ).
Proof.
  induction 1; isimpl; eauto with infra.
Qed.
Hint Resolve PTyping_domainEnv_subhvl_tm : infra shift subst wf.

Lemma PTyping_bindPat_domainEnv {Γ p T Δ} :
  PTyping Γ p T Δ → bindPat p = domainEnv Δ.
Proof.
  induction 1; isimpl; try congruence; eauto.
Qed.

Lemma shift_etvar_ptyping {Γ1 p T Δ} (wt: PTyping Γ1 p T Δ) :
  ∀ {c Γ2}, shift_etvar c Γ1 Γ2 →
    PTyping Γ2 (tshiftPat c p) (tshiftTy c T) (tshiftEnv c Δ).
Proof.
  induction wt; isimpl; econstructor; isimpl;
    autorewrite with weaken_shift; eauto with shift.
Qed.

Lemma shift_etvar_typing {Γ1 t T} (wt: Typing Γ1 t T) :
  ∀ {c Γ2}, shift_etvar c Γ1 Γ2 → Typing Γ2 (tshiftTm c t) (tshiftTy c T).
Proof.
  induction wt; isimpl; econstructor;
    eauto using shift_etvar_ptyping with shift.
  - rewrite (PTyping_bindPat_domainEnv H); isimpl;
    autorewrite  with weaken_shift; eauto with shift.
Qed.

Lemma shift_evar_ptyping {Γ1 p T Δ} (wp: PTyping Γ1 p T Δ) :
  ∀ {c Γ2}, shift_evar c Γ1 Γ2 → PTyping Γ2 p T Δ.
Proof.
  induction wp; simpl; econstructor; eauto with infra.
Qed.

Lemma shift_evar_typing {Γ1 t T} (wt: Typing Γ1 t T) :
  ∀ {c Γ2}, shift_evar c Γ1 Γ2 → Typing Γ2 (shiftTm c t) T.
Proof.
  induction wt; simpl; econstructor; eauto using shift_evar_ptyping with shift.
  - rewrite (PTyping_bindPat_domainEnv H); isimpl; eauto with shift.
Qed.

Lemma weaken_typing {Γ} Δ : ∀ {t T}, Typing Γ t T →
  Typing (appendEnv Γ Δ) (weakenTm t (domainEnv Δ)) (weakenTy T (domainEnv Δ)).
Proof.
  induction Δ; simpl;
    eauto using shift_evar_typing, shift_etvar_typing with shift.
Qed.

Lemma shift_value {t} :
  ∀ {c}, Value t → Value (shiftTm c t).
Proof.
  induction t; simpl; intros; try contradiction; destruct_conjs; auto.
Qed.

Lemma tshift_value {t} :
  ∀ {c}, Value t → Value (tshiftTm c t).
Proof.
  induction t; simpl; intros; try contradiction; destruct_conjs; auto.
Qed.

Lemma weaken_value u :
  ∀ {t}, Value t → Value (weakenTm t u).
Proof.
  induction u as [|[]]; simpl; auto using shift_value, tshift_value.
Qed.

(******************************************************************************)
(* Well-formedness                                                            *)
(******************************************************************************)

Lemma typing_wf {Γ t T} (wt: Typing Γ t T) : wfTy (domainEnv Γ) T.
Proof.
  induction wt; isimpl; eauto with infra.
Qed.

(******************************************************************************)
(* Substitution lemmas                                                        *)
(******************************************************************************)

Lemma subst_etvar_ptyping {Γ S Γ1 p T Δ}
  (wfS: wfTy (domainEnv Γ) S) (wt: PTyping Γ1 p T Δ) :
  ∀ {X Γ2}, subst_etvar Γ S X Γ1 Γ2 →
     PTyping Γ2 (tsubstPat X S p) (tsubstTy X S T) (tsubstEnv X S Δ).
Proof.
  induction wt; simpl; intros; isimpl; econstructor; eauto with subst.
  - rewrite weakenPat_tsubstPat, weakenTy_tsubstTy; isimpl; eauto with subst.
Qed.

Lemma subst_etvar_typing {Γ S Γ1 t T} (wS: wfTy (domainEnv Γ) S)
  (wt: Typing Γ1 t T) :
  ∀ {X Γ2}, subst_etvar Γ S X Γ1 Γ2 →
     Typing Γ2 (tsubstTm X S t) (tsubstTy X S T).
Proof.
  induction wt; simpl; intros;
    try (isimpl; econstructor; eauto with infra; fail).
  - simpl; eapply T_Abs; eauto with infra.
    (* Urgs, ugly. *)
    replace (tsubstTy X S T2) with (tsubstTy (XS tm X) S T2)
      by apply tsubstTy_tm; eauto with infra.
  - eapply T_Let; eauto using subst_etvar_ptyping with infra.
    rewrite (PTyping_bindPat_domainEnv H); isimpl;
      autorewrite with weaken_subst; eauto with subst.
Qed.

Lemma subst_evar_ptyping {Γ s S} (wts: Typing Γ s S)
  {Γ1 p T Δ} (wtp: PTyping Γ1 p T Δ) :
  ∀ {x Γ2}, subst_evar Γ S s x Γ1 Γ2 → PTyping Γ2 p T Δ.
Proof.
  induction wtp; simpl; econstructor; eauto with subst.
Qed.

Lemma subst_evar_lookup_evar {Γ s S x Γ1 Γ2} (ws: Typing Γ s S)
  (esub: subst_evar Γ S s x Γ1 Γ2) :
  ∀ {y T}, lookup_evar Γ1 y T → Typing Γ2 (substIndex x s y) T.
Proof.
  induction esub; inversion 1; subst; simpl;
    eauto using T_Var, shift_evar_typing, shift_etvar_typing with subst.
Qed.

Lemma subst_evar_typing {Γ s S Γ1 t T} (ws: Typing Γ s S) (wt: Typing Γ1 t T) :
  ∀ {x Γ2}, subst_evar Γ S s x Γ1 Γ2 → Typing Γ2 (substTm x s t) T.
Proof.
  induction wt; simpl; eauto using subst_evar_lookup_evar;
    econstructor; eauto using subst_evar_ptyping with subst.
  - rewrite (PTyping_bindPat_domainEnv H); eauto with subst.
Qed.

(******************************************************************************)
(* Progress                                                                   *)
(******************************************************************************)

Lemma can_form_tarr {Γ t T1 T2} (v: Value t) (wt: Typing Γ t (tarr T1 T2)) :
  ∃ t2, t = abs T1 t2.
Proof.
  depind wt; try contradiction; exists t; reflexivity.
Qed.

Lemma can_form_tall {Γ t T} (v: Value t) (wt: Typing Γ t (tall T)) :
  ∃ t1, t = tabs t1.
Proof.
  depind wt; try contradiction; exists t; reflexivity.
Qed.

Lemma can_form_tprod {Γ t T1 T2} (v: Value t) (wt: Typing Γ t (tprod T1 T2)) :
  ∃ t1 t2, t = prod t1 t2 ∧ Typing Γ t1 T1 ∧ Typing Γ t2 T2.
Proof.
  depind wt; try contradiction; exists t1, t2; auto.
Qed.

Lemma matching_defined {Γ p T1 Δ} (wp: PTyping Γ p T1 Δ) :
  ∀ {t1}, Value t1 → Typing Γ t1 T1 → ∀ t2, ∃ t2', Match p t1 t2 t2'.
Proof.
  induction wp; intros t1 v1 wt1 t2.
  - exists (substTm X0 t1 t2).
    refine M_Var.
  - destruct (can_form_tprod v1 wt1) as (t11 & t12 & eq & wt11 & wt12); subst.
    destruct v1 as [v11 v12].
    apply (weaken_typing Δ1) in wt12.
    assert (val12' : Value (weakenTm t12 (domainEnv Δ1)))
       by (apply weaken_value; auto).
    destruct (IHwp2 (weakenTm t12 (domainEnv Δ1)) val12' wt12 t2) as [t2' m2].
    destruct (IHwp1 _ v11 wt11 t2') as [t2'' m1].
    rewrite <- (PTyping_bindPat_domainEnv wp1) in m2.
    exists t2''.
    exact (M_Prod m2 m1).
Qed.

Lemma progress {t U} (wt: Typing empty t U) :
  Value t ∨ ∃ t', red t t'.
Proof with destruct_conjs; subst; eauto using red.
  depind wt; simpl; auto.
  - inversion H.
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct IHwt2 as [v2|[t2' r2]]...
    destruct (can_form_tarr v1 wt1)...
  - destruct IHwt as [vt|[t1' r1]]...
    destruct (can_form_tall vt wt)...
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct IHwt2 as [v2|[t2' r2]]...
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct (matching_defined H v1 wt1 t2)...
Qed.

(******************************************************************************)
(* Preservation                                                               *)
(******************************************************************************)

Lemma local_preservation_lett {p t1 t2 t2'} (m: Match p t1 t2 t2') :
  ∀ {Γ T1 T2 Δ}, PTyping Γ p T1 Δ → Typing Γ t1 T1 →
    Typing (appendEnv Γ Δ) t2 (weakenTy T2 (domainEnv Δ)) →
    Typing Γ t2' T2.
Proof.
  induction m; intros Γ T1 T2 Δ wp wt1 wt2.
  - dependent destruction wp; simpl in *.
    eauto using subst_evar_typing with infra.
  - dependent destruction wp.
    dependent destruction wt1.
    rewrite (PTyping_bindPat_domainEnv wp1) in *.
    rewrite appendEnv_assoc, domainEnv_appendEnv, <- weakenTy_append in wt2.
    eauto using weaken_typing.
Qed.

Lemma preservation {Γ t U} (wt: Typing Γ t U) :
  ∀ {t'}, red t t' → Typing Γ t' U.
Proof.
  induction wt; intros t' r; inversion r; subst; eauto using Typing.
  - dependent destruction wt1; eauto using subst_evar_typing with subst.
  - dependent destruction wt; eauto using subst_etvar_typing with subst.
  - eauto using local_preservation_lett.
Qed.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition handle_id_sysreg_trap_spec0 (rec: Pointer) (esr: Z64) (adt: RData) : option RData :=
    match rec, esr with
    | (_rec_base, _rec_ofst), VZ64 _esr =>
      rely is_int64 (Z.land _esr 4193310);
      rely is_int (Z.land _esr 4193310);
      let _idreg := (Z.land _esr 4193310) in
      let _mask := 0 in
      rely is_int64 _esr;
      when _t'1 == ESR_EL2_SYSREG_IS_WRITE_spec (VZ64 _esr) adt;
      rely is_int _t'1;
      rely is_int (1 - _t'1);
      when adt == assert_cond_spec (1 - _t'1) adt;
      if (_idreg =? 3276812) then
        let _mask := 255 in
        when _t'2 == ESR_EL2_SYSREG_ISS_RT_spec (VZ64 _esr) adt;
        rely is_int _t'2;
        rely is_int _idreg;
        when' _t'3 == read_idreg_spec _idreg adt;
        rely is_int64 _t'3;
        rely is_int64 (18446744073709551615 - _mask);
        rely is_int64 (Z.land _t'3 (18446744073709551615 - _mask));
        when adt == set_rec_regs_spec (_rec_base, _rec_ofst) _t'2 (VZ64 (Z.land _t'3 (18446744073709551615 - _mask))) adt;
        Some adt
      else
        when _t'2 == ESR_EL2_SYSREG_ISS_RT_spec (VZ64 _esr) adt;
        rely is_int _t'2;
        rely is_int _idreg;
        when' _t'3 == read_idreg_spec _idreg adt;
        rely is_int64 _t'3;
        rely is_int64 (18446744073709551615 - _mask);
        rely is_int64 (Z.land _t'3 (18446744073709551615 - _mask));
        when adt == set_rec_regs_spec (_rec_base, _rec_ofst) _t'2 (VZ64 (Z.land _t'3 (18446744073709551615 - _mask))) adt;
        Some adt
     end
    .

End SpecLow.


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

Require Import Coq.Classes.RelationClasses.
Require Import Program.

From Fairness Require Import Axioms.
From Fairness Require Export ITreeLib FairBeh FairSim NatStructs.
From Fairness Require Import pind LPCM World WFLib.
From Fairness Require Export Mod ModSimNoSync ModSimStutter.

Set Implicit Arguments.

Section GENORDER.
  Context `{M: URA.t}.

  Variable state_src: Type.
  Variable state_tgt: Type.

  Variable _ident_src: ID.
  Let ident_src := @ident_src _ident_src.
  Variable _ident_tgt: ID.
  Let ident_tgt := @ident_tgt _ident_tgt.

  Variable wf_src: WF.
  Variable wf_tgt: WF.

  Let srcE := programE _ident_src state_src.
  Let tgtE := programE _ident_tgt state_tgt.

  Let shared := shared state_src state_tgt _ident_src _ident_tgt wf_src wf_tgt.
  Let shared_rel: Type := shared -> Prop.
  Variable I: shared -> URA.car -> Prop.

  Let A R0 R1 := (bool * bool * URA.car * (itree srcE R0) * (itree tgtE R1) * shared)%type.
  Let wf_stt {R0 R1} := @ord_tree_WF (A R0 R1).

  Variant _geno
          (tid: thread_id) R_src R_tgt (RR: R_src -> R_tgt -> URA.car -> shared_rel)
          (geno: bool -> bool -> URA.car -> ((@wf_stt R_src R_tgt).(T) * itree srcE R_src) -> itree tgtE R_tgt -> shared_rel)
    :
    bool -> bool -> URA.car -> ((@wf_stt R_src R_tgt).(T) * itree srcE R_src) -> itree tgtE R_tgt -> shared_rel :=
  | geno_ret
      f_src f_tgt r_ctx o o0
      ths im_src im_tgt st_src st_tgt
      r_src r_tgt
      (LT: wf_stt.(lt) o0 o)
      (GENO: RR r_src r_tgt r_ctx (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, Ret r_src) (Ret r_tgt) (ths, im_src, im_tgt, st_src, st_tgt)

  | geno_tauL
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      itr_src itr_tgt
      (GENO: geno true f_tgt r_ctx (o, itr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, Tau itr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  | geno_chooseL
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      X ktr_src itr_tgt
      (GENO: exists x, geno true f_tgt r_ctx (o, ktr_src x) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, trigger (Choose X) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  | geno_rmwL
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      X rmw ktr_src itr_tgt
      (GENO: geno true f_tgt r_ctx (o, ktr_src (snd (rmw st_src) : X)) itr_tgt (ths, im_src, im_tgt, fst (rmw st_src), st_tgt))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, trigger (Rmw rmw) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  | geno_tidL
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      ktr_src itr_tgt
      (GENO: geno true f_tgt r_ctx (o, ktr_src tid) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, trigger (GetTid) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  | geno_UB
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      ktr_src itr_tgt
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, trigger (Undefined) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  | geno_fairL
      f_src f_tgt r_ctx o
      ths im_src0 im_tgt st_src st_tgt
      f ktr_src itr_tgt
      (GENO: exists im_src1,
             (<<FAIR: fair_update im_src0 im_src1 (prism_fmap inrp f)>>) /\
               (<<GENO: geno true f_tgt r_ctx (o, ktr_src tt) itr_tgt (ths, im_src1, im_tgt, st_src, st_tgt)>>))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, trigger (Fair f) >>= ktr_src) itr_tgt (ths, im_src0, im_tgt, st_src, st_tgt)

  | geno_tauR
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      itr_src itr_tgt
      (GENO: geno f_src true r_ctx (o, itr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, itr_src) (Tau itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | geno_chooseR
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      X itr_src ktr_tgt
      (GENO: forall x, geno f_src true r_ctx (o, itr_src) (ktr_tgt x) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, itr_src) (trigger (Choose X) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | geno_rmwR
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      X rmw itr_src ktr_tgt
      (GENO: geno f_src true r_ctx (o, itr_src) (ktr_tgt (snd (rmw st_tgt) : X)) (ths, im_src, im_tgt, st_src, fst (rmw st_tgt)))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, itr_src) (trigger (Rmw rmw) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | geno_tidR
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      itr_src ktr_tgt
      (GENO: geno f_src true r_ctx (o, itr_src) (ktr_tgt tid) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, itr_src) (trigger (GetTid) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | geno_fairR
      f_src f_tgt r_ctx o
      ths im_src im_tgt0 st_src st_tgt
      f itr_src ktr_tgt
      (GENO: forall im_tgt1 (FAIR: fair_update im_tgt0 im_tgt1 (prism_fmap inrp f)),
          (<<GENO: geno f_src true r_ctx (o, itr_src) (ktr_tgt tt) (ths, im_src, im_tgt1, st_src, st_tgt)>>))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, itr_src) (trigger (Fair f) >>= ktr_tgt) (ths, im_src, im_tgt0, st_src, st_tgt)

  | geno_observe
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      fn args ktr_src ktr_tgt
      (GENO: forall ret,
             geno true true r_ctx (o, ktr_src ret) (ktr_tgt ret) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, trigger (Observe fn args) >>= ktr_src) (trigger (Observe fn args) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)

  | geno_call
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      fn args ktr_src itr_tgt
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, trigger (Call fn args) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)

  | geno_yieldR
      f_src f_tgt r_ctx0 o0
      ths0 im_src0 im_tgt0 st_src0 st_tgt0
      r_own r_shared
      ktr_src ktr_tgt
      (INV: I (ths0, im_src0, im_tgt0, st_src0, st_tgt0) r_shared)
      (VALID: URA.wf (r_shared ⋅ r_own ⋅ r_ctx0))
      o1
      (STUTTER: wf_stt.(lt) o1 o0)
      (GENO: forall ths1 im_src1 im_tgt1 st_src1 st_tgt1 r_shared1 r_ctx1
               (INV: I (ths1, im_src1, im_tgt1, st_src1, st_tgt1) r_shared1)
               (VALID: URA.wf (r_shared1 ⋅ r_own ⋅ r_ctx1))
               im_tgt2
               (TGT: fair_update im_tgt1 im_tgt2 (prism_fmap inlp (tids_fmap tid ths1))),
          (<<GENO: geno f_src true r_ctx1 (o1, trigger (Yield) >>= ktr_src) (ktr_tgt tt) (ths1, im_src1, im_tgt2, st_src1, st_tgt1)>>))
    :
    _geno tid RR geno f_src f_tgt r_ctx0 (o0, trigger (Yield) >>= ktr_src) (trigger (Yield) >>= ktr_tgt) (ths0, im_src0, im_tgt0, st_src0, st_tgt0)

  | geno_yieldL
      f_src f_tgt r_ctx o0
      ths im_src0 im_tgt st_src st_tgt
      ktr_src itr_tgt
      (GENO: exists im_src1 o1,
          (<<FAIR: fair_update im_src0 im_src1 (prism_fmap inlp (tids_fmap tid ths))>>) /\
            (<<GENO: geno true f_tgt r_ctx (o1, ktr_src tt) itr_tgt (ths, im_src1, im_tgt, st_src, st_tgt)>>))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o0, trigger (Yield) >>= ktr_src) itr_tgt (ths, im_src0, im_tgt, st_src, st_tgt)

  | geno_progress
      r_ctx o
      ths im_src im_tgt st_src st_tgt
      itr_src itr_tgt
      (GENO: ModSimNoSync.lsim I tid RR false false r_ctx itr_src itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _geno tid RR geno true true r_ctx (o, itr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  .

  Definition geno (tid: thread_id)
             R_src R_tgt (RR: R_src -> R_tgt -> URA.car -> shared_rel):
    bool -> bool -> URA.car -> (wf_stt.(T) * itree srcE R_src) -> itree tgtE R_tgt -> shared_rel :=
    pind6 (_geno tid RR) top6.

  Lemma geno_mon tid R0 R1 (RR: R0 -> R1 -> URA.car -> shared_rel): monotone6 (_geno tid RR).
  Proof.
    ii. inv IN; try (econs; eauto; fail).
    { des. econs; eauto. }
    { des. econs; eauto. }
    { econs; eauto. i. eapply LE. eapply GENO. eauto. }
    { econs; eauto. i. specialize (GENO _ _ _ _ _ _ _ INV0 VALID0 _ TGT). des. esplits; eauto. }
    { des. econs; esplits; eauto. }
  Qed.

  Local Hint Constructors _geno: core.
  Local Hint Unfold geno: core.
  Local Hint Resolve geno_mon: paco.

  Lemma geno_ord_weak
        tid R0 R1 (LRR: R0 -> R1 -> URA.car -> shared_rel)
        ps pt r_ctx src tgt (shr: shared) o0 o1
        (LT: wf_stt.(lt) o0 o1)
        (GENO: geno tid LRR ps pt r_ctx (o0, src) tgt shr)
    :
    geno tid LRR ps pt r_ctx (o1, src) tgt shr.
  Proof.
    remember (o0, src) as osrc.
    move GENO before tid. revert_until GENO.
    pattern ps, pt, r_ctx, osrc, tgt, shr.
    revert ps pt r_ctx osrc tgt shr GENO. apply pind6_acc.
    intros rr DEC IH. clear DEC. intros ps pt r_ctx osrc tgt shr GENO.
    i; clarify.
    eapply pind6_unfold in GENO; eauto with paco.
    inv GENO.

    { eapply pind6_fold. eapply geno_ret; eauto. }
    { eapply pind6_fold. eapply geno_tauL; eauto.
      destruct GENO0 as [GENO IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind6_fold. eapply geno_chooseL; eauto.
      des. destruct GENO0 as [GENO IND]. eapply IH in IND; eauto. esplits; eauto.
      split; ss; eauto.
    }
    { eapply pind6_fold. eapply geno_rmwL; eauto.
      destruct GENO0 as [GENO IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind6_fold. eapply geno_tidL; eauto.
      destruct GENO0 as [GENO IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind6_fold. eapply geno_UB; eauto. }
    { eapply pind6_fold. eapply geno_fairL; eauto.
      des. destruct GENO as [GENO IND]. eapply IH in IND; eauto. esplits; eauto.
      split; ss; eauto.
    }

    { eapply pind6_fold. eapply geno_tauR; eauto.
      destruct GENO0 as [GENO IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind6_fold. eapply geno_chooseR; eauto.
      i. specialize (GENO0 x).
      destruct GENO0 as [GENO IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind6_fold. eapply geno_rmwR; eauto.
      destruct GENO0 as [GENO IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind6_fold. eapply geno_tidR; eauto.
      destruct GENO0 as [GENO IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind6_fold. eapply geno_fairR; eauto.
      i. specialize (GENO0 _ FAIR).
      destruct GENO0 as [GENO IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind6_fold. eapply geno_observe; eauto.
      i. specialize (GENO0 ret).
      destruct GENO0 as [GENO IND]. eapply IH in IND; eauto. split; ss.
    }

    { eapply pind6_fold. eapply geno_call; eauto. }

    { eapply pind6_fold. eapply geno_yieldR; eauto.
      i. specialize (GENO0 _ _ _ _ _ _ _ INV0 VALID0 _ TGT). des. esplits; eauto.
      destruct GENO0 as [GENO IND]. eapply IH in IND; eauto. split; ss.
    }

    { eapply pind6_fold. eapply geno_yieldL; eauto.
      des. esplits; eauto.
      eapply upind6_mon; eauto. ss.
    }

    { eapply pind6_fold. eapply geno_progress; eauto. }

  Qed.

  Lemma nosync_geno
        tid R0 R1 (RR: R0 -> R1 -> URA.car -> shared_rel)
        ps pt r_ctx src tgt shr
        (LSIM: ModSimNoSync.lsim I tid RR ps pt r_ctx src tgt shr)
    :
    exists o, geno tid RR ps pt r_ctx (o, src) tgt shr.
  Proof.
    punfold LSIM.
    pattern R0, R1, RR, ps, pt, r_ctx, src, tgt, shr.
    revert R0 R1 RR ps pt r_ctx src tgt shr LSIM. apply pind9_acc.
    intros rr DEC IH. clear DEC. intros R0 R1 RR ps pt r_ctx src tgt shr LSIM.
    eapply pind9_unfold in LSIM; eauto with paco.
    set (fzero:= fun _: (A R0 R1) => @ord_tree_base (A R0 R1)). set (one:= ord_tree_cons fzero).
    inv LSIM.

    { exists one. eapply pind6_fold. eapply geno_ret; eauto.
      instantiate (1:=fzero (ps, pt, r_ctx, Ret r_src, Ret r_tgt, (ths, im_src, im_tgt, st_src, st_tgt))); ss.
    }

    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des.
      exists o. eapply pind6_fold. eapply geno_tauL; eauto. split; ss.
    }
    { des. destruct LSIM0 as [LSIM IND]. eapply IH in IND. des.
      exists o. eapply pind6_fold. eapply geno_chooseL; eauto. eexists. split; ss. eauto.
    }
    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des.
      exists o. eapply pind6_fold. eapply geno_rmwL; eauto. split; ss.
    }
    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des.
      exists o. eapply pind6_fold. eapply geno_tidL; auto. split; ss.
    }
    { exists one. eapply pind6_fold. eapply geno_UB; eauto. }
    { des. destruct LSIM as [LSIM IND]. eapply IH in IND. des.
      exists o. eapply pind6_fold. eapply geno_fairL; eauto. esplits; eauto. split; ss.
    }

    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des. exists o.
      eapply pind6_fold. eapply geno_tauR; eauto. ss.
    }

    { hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs. eapply IH in SAT.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           geno tid RR ps pt rs (o, src) tgt shr).
        eauto.
      }
      intro JOIN. des. exists o1.
      eapply pind6_fold. eapply geno_chooseR.
      i. specialize (LSIM0 x). destruct LSIM0 as [LSIM IND].
      specialize (JOIN (ps, true, r_ctx, src, (ktr_tgt x), (ths, im_src, im_tgt, st_src, st_tgt))).
      destruct JOIN; auto. des. split; ss.
      eapply geno_ord_weak; eauto.
    }

    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des. exists o.
      eapply pind6_fold. eapply geno_rmwR; eauto. ss.
    }
    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des. exists o.
      eapply pind6_fold. eapply geno_tidR; eauto. ss.
    }

    { hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs. eapply IH in SAT.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           geno tid RR ps pt rs (o, src) tgt shr).
        eauto.
      }
      intro JOIN. des. exists o1.
      eapply pind6_fold. eapply geno_fairR.
      i. specialize (LSIM0 _ FAIR). destruct LSIM0 as [LSIM IND].
      specialize (JOIN (ps, true, r_ctx, src, (ktr_tgt ()), (ths, im_src, im_tgt1, st_src, st_tgt))).
      destruct JOIN; auto. des. split; ss.
      eapply geno_ord_weak; eauto.
    }

    { hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs. eapply IH in SAT.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           geno tid RR ps pt rs (o, src) tgt shr).
        eauto.
      }
      intro JOIN. des. exists o1.
      eapply pind6_fold. eapply geno_observe.
      i. specialize (LSIM0 ret). destruct LSIM0 as [LSIM IND].
      specialize (JOIN (true, true, r_ctx, ktr_src ret, ktr_tgt ret, (ths, im_src, im_tgt, st_src, st_tgt))).
      destruct JOIN; auto. des. split; ss.
      eapply geno_ord_weak; eauto.
    }

    { hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs. eapply IH in SAT.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           geno tid RR ps pt rs (o, src) tgt shr).
        eauto.
      }
      intro JOIN. des.
      set (fo1:= fun _: A R0 R1 => o1). exists (ord_tree_cons fo1).
      eapply pind6_fold. eapply geno_call.
    }

    { hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs. eapply IH in SAT.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           geno tid RR ps pt rs (o, src) tgt shr).
        eauto.
      }
      intro JOIN. des.
      set (fo1:= fun _: A R0 R1 => o1). exists (ord_tree_cons fo1).
      eapply pind6_fold. eapply geno_yieldR.
      1,2: eauto.
      { instantiate (1:=fo1 (ps, pt, r_ctx, (x <- trigger Yield;; ktr_src x), (x <- trigger Yield;; ktr_tgt x), (ths0, im_src0, im_tgt0, st_src0, st_tgt0))). ss.
      }
      i. specialize (LSIM0 _ _ _ _ _ _ _ INV0 VALID0 _ TGT). destruct LSIM0 as [LSIM IND].
      specialize (JOIN (ps, true, r_ctx1, (x <- trigger Yield;; ktr_src x), ktr_tgt (), (ths1, im_src1, im_tgt2, st_src1, st_tgt1))).
      destruct JOIN; auto. des. subst fo1. ss. split; ss. eapply geno_ord_weak; eauto.
    }

    { des. destruct LSIM as [LSIM IND]. eapply IH in IND. des. exists o.
      eapply pind6_fold. eapply geno_yieldL; eauto. esplits; eauto.
      split; ss. eauto.
    }

    { exists one. eapply pind6_fold. eapply geno_progress. pclearbot. auto. }

  Qed.

End GENORDER.
#[export] Hint Constructors _geno: core.
#[export] Hint Unfold geno: core.
#[export] Hint Resolve geno_mon: paco.

Section PROOF.

  Context `{M: URA.t}.

  Variable state_src: Type.
  Variable state_tgt: Type.

  Variable _ident_src: ID.
  Let ident_src := @ident_src _ident_src.
  Variable _ident_tgt: ID.
  Let ident_tgt := @ident_tgt _ident_tgt.

  Variable wf_src: WF.
  Variable wf_tgt: WF.

  Let srcE := programE _ident_src state_src.
  Let tgtE := programE _ident_tgt state_tgt.

  Let shared :=
    (TIdSet.t *
       (@imap ident_src wf_src) *
       (@imap ident_tgt wf_tgt) *
       state_src *
       state_tgt)%type.

  Let shared_rel: Type := shared -> Prop.

  Variable I: shared -> URA.car -> Prop.

  Definition lift_wf (wf: WF): WF := sum_WF wf (option_WF wf).

  Definition mk_o (wf: WF) R (o: wf.(T)) (ps: bool) (itr_src: itree srcE R): (lift_wf wf).(T) :=
    if ps
    then match (observe itr_src) with
         | VisF (((|Yield)|)|)%sum _ => (inr (Some o))
         | _ => (inr None)
         end
    else match (observe itr_src) with
         | VisF (((|Yield)|)|)%sum _ => (inl o)
         | _ => (inr None)
         end.

  Let A R0 R1 := (bool * bool * URA.car * (itree srcE R0) * (itree tgtE R1) * shared)%type.
  Let wf_ot R0 R1 := @ord_tree_WF (A R0 R1).
  Let wf_stt R0 R1 := lift_wf (@wf_ot R0 R1).

  Lemma nosync_implies_stutter
        tid
        R0 R1 (LRR: R0 -> R1 -> URA.car -> shared_rel)
        ps pt r_ctx src tgt
        (shr: shared)
        (LSIM: ModSimNoSync.lsim I tid LRR ps pt r_ctx src tgt shr)
    :
    exists (o: (@wf_stt R0 R1).(T)),
      ModSimStutter.lsim (wf_stt) I tid LRR ps pt r_ctx (o, src) tgt shr.
  Proof.
    eapply nosync_geno in LSIM. des.
    exists (mk_o (@wf_ot R0 R1) o ps src).
    ginit. eapply cpn6_wcompat. eapply lsim_mon.
    revert_until LRR. gcofix CIH; i.
    remember (o, src) as osrc.
    move LSIM before CIH. revert_until LSIM.
    pattern ps, pt, r_ctx, osrc, tgt, shr.
    revert ps pt r_ctx osrc tgt shr LSIM. apply pind6_acc.
    intros rr DEC IH. clear DEC. intros ps pt r_ctx osrc tgt shr LSIM.
    intros src o Eosrc. clarify.
    eapply pind6_unfold in LSIM; eauto with paco.
    inv LSIM.

    { guclo lsim_indC_spec. econs 1; eauto.
      instantiate (1:=(inl o1)). ss.
      unfold mk_o. des_ifs. all: econs 3.
    }

    { destruct GENO as [GENO IND]. eapply IH in IND; eauto.
      guclo lsim_indC_spec. econs 2; eauto.
      guclo lsim_ord_weakC_spec. econs; eauto.
      unfold mk_o. des_ifs; try reflexivity.
      - right. ss. do 2 econs.
      - right. ss. do 2 econs.
    }
    { des. destruct GENO as [GENO IND]. eapply IH in IND; eauto.
      guclo lsim_indC_spec. econs 3; eauto. exists x.
      guclo lsim_ord_weakC_spec. econs; eauto.
      unfold mk_o. des_ifs; try reflexivity.
      - right. ss. do 2 econs.
      - right. ss. do 2 econs.
    }
    { destruct GENO as [GENO IND]. eapply IH in IND; eauto.
      guclo lsim_indC_spec. econs 4; eauto.
      guclo lsim_ord_weakC_spec. econs; eauto.
      unfold mk_o. des_ifs; try reflexivity.
      - right. ss. do 2 econs.
      - right. ss. do 2 econs.
    }
    { destruct GENO as [GENO IND]. eapply IH in IND; eauto.
      guclo lsim_indC_spec. econs 5; eauto.
      guclo lsim_ord_weakC_spec. econs; eauto.
      unfold mk_o. des_ifs; try reflexivity.
      - right. ss. do 2 econs.
      - right. ss. do 2 econs.
    }
    { guclo lsim_indC_spec. econs 6; eauto. }
    { des. destruct GENO0 as [GENO IND]. eapply IH in IND; eauto.
      guclo lsim_indC_spec. econs 7; eauto. esplits; eauto.
      guclo lsim_ord_weakC_spec. econs; eauto.
      unfold mk_o. des_ifs; try reflexivity.
      - right. ss. do 2 econs.
      - right. ss. do 2 econs.
    }

    { destruct GENO as [GENO IND]. eapply IH in IND; eauto.
      guclo lsim_indC_spec. econs 8; eauto.
    }
    { guclo lsim_indC_spec. econs 9; eauto. i. specialize (GENO x).
      destruct GENO as [GENO IND]. eapply IH in IND; eauto.
    }
    { destruct GENO as [GENO IND]. eapply IH in IND; eauto.
      guclo lsim_indC_spec. econs 10; eauto.
    }
    { destruct GENO as [GENO IND]. eapply IH in IND; eauto.
      guclo lsim_indC_spec. econs 11; eauto.
    }
    { guclo lsim_indC_spec. econs 12; eauto. i. specialize (GENO _ FAIR).
      destruct GENO as [GENO IND]. eapply IH in IND; eauto.
    }

    { guclo lsim_indC_spec. econs 13; eauto. i. specialize (GENO ret).
      destruct GENO as [GENO IND]. eapply IH in IND; eauto.
      guclo lsim_ord_weakC_spec. econs; eauto.
      unfold mk_o. ss. des_ifs; try reflexivity.
      - right. ss. do 2 econs.
      - right. ss. do 2 econs.
    }

    { guclo lsim_indC_spec. econs 14. }

    { guclo lsim_indC_spec. econs 15; eauto.
      2:{ i. specialize (GENO _ _ _ _ _ _ _ INV0 VALID0 _ TGT). des.
          destruct GENO as [GENO IND]. eapply IH in IND; eauto.
          esplits.
          guclo lsim_resetC_spec. econs; eauto.
      }
      unfold mk_o; ss. rewrite !bind_trigger. ss.
      des_ifs.
      - do 2 econs. auto.
      - econs. auto.
    }

    { des. destruct GENO0 as [GENO IND]. eapply IH in IND; eauto.
      guclo lsim_indC_spec. econs 16; eauto.
    }

    { eapply nosync_geno in GENO. des.
      guclo lsim_ord_weakC_spec. econs.
      instantiate (1:=mk_o (@wf_ot R0 R1) o0 false src).
      gfinal. right. pfold. eapply pind6_fold. econs 17. right. eapply CIH. auto.
      ss. des_ifs; try reflexivity. right. ss. do 2 econs.
    }

  Qed.

End PROOF.

Section MODSIM.

  Lemma nosync_implies_stutter_mod
        md_src md_tgt
        (MDSIM: ModSimNoSync.ModSim.mod_sim md_src md_tgt)
    :
    ModSimStutter.ModSim.mod_sim md_src md_tgt.
  Proof.
    inv MDSIM.
    set (_ident_src := Mod.ident md_src). set (_ident_tgt := Mod.ident md_tgt).
    set (state_src := Mod.state md_src). set (state_tgt := Mod.state md_tgt).
    set (srcE := programE _ident_src state_src).
    set (tgtE := programE _ident_tgt state_tgt).
    set (ident_src := @ident_src _ident_src).
    set (ident_tgt := @ident_tgt _ident_tgt).
    set (shared := (TIdSet.t * (@imap ident_src wf_src) * (@imap ident_tgt wf_tgt) * state_src * state_tgt)%type).
    set (wf_stt:=fun R0 R1 => lift_wf (@ord_tree_WF (bool * bool * URA.car * (itree srcE R0) * (itree tgtE R1) * shared)%type)).
    econs; eauto. instantiate (1:=wf_stt).
    i. specialize (init im_tgt). des. rename init0 into funs. exists I. esplits; eauto.
    i. specialize (funs fn args). des_ifs.
    unfold ModSimNoSync.local_sim in funs.
    ii. specialize (funs _ _ _ _ _ _ _ INV tid _ THS VALID _ UPD).
    des. esplits; eauto. instantiate (1:=inr None).
    i. specialize (funs1 _ _ _ _ _ _ _ INV1 VALID1 _ TGT).
    des. esplits; eauto. i. specialize (LSIM fs ft).
    eapply nosync_implies_stutter in LSIM. des.
    eapply stutter_ord_weak. 2: eapply LSIM.
    clear. destruct o.
    { right. econs. }
    destruct t.
    { right. do 2 econs. }
    { left. auto. }
  Qed.

End MODSIM.

Section USERSIM.

  Lemma nosync_implies_stutter_user
        md_src md_tgt p_src p_tgt
        (MDSIM: ModSimNoSync.UserSim.sim md_src md_tgt p_src p_tgt)
    :
    ModSimStutter.UserSim.sim md_src md_tgt p_src p_tgt.
  Proof.
    inv MDSIM.
    set (_ident_src := Mod.ident md_src). set (_ident_tgt := Mod.ident md_tgt).
    set (state_src := Mod.state md_src). set (state_tgt := Mod.state md_tgt).
    set (srcE := programE _ident_src state_src).
    set (tgtE := programE _ident_tgt state_tgt).
    set (ident_src := @ident_src _ident_src).
    set (ident_tgt := @ident_tgt _ident_tgt).
    set (shared := (TIdSet.t * (@imap ident_src wf_src) * (@imap ident_tgt wf_tgt) * state_src * state_tgt)%type).
    set (wf_stt:=fun R0 R1 => lift_wf (@ord_tree_WF (bool * bool * URA.car * (itree srcE R0) * (itree tgtE R1) * shared)%type)).
    econs; eauto. instantiate (1:=wf_stt).
    i. specialize (funs im_tgt). des. exists I. esplits; eauto.
    instantiate (1:=NatMap.map (fun _ => inr None) p_src).
    eapply nm_find_some_implies_forall4.
    { apply nm_forall2_wf_pair. eapply list_forall3_implies_forall2_2; eauto. clear. i. des. des_ifs. des; clarify. }
    { apply nm_forall2_wf_pair. eapply list_forall3_implies_forall2_3; eauto. clear. i. des. des_ifs. des; clarify. }
    { unfold nm_wf_pair. unfold key_set. rewrite nm_map_unit1_map_eq. ss. }
    i. eapply nm_forall3_implies_find_some in SIM; eauto.
    unfold ModSimNoSync.local_sim_init in SIM. unfold local_sim_init.
    i. specialize (SIM _ _ _ _ _ _ _ INV VALID _ FAIR). des. esplits; eauto.
    i. specialize (SIM0 fs ft). eapply nosync_implies_stutter in SIM0. des.
    rewrite NatMapP.F.map_o in FIND4. unfold option_map in FIND4. des_ifs.
    eapply stutter_ord_weak. 2: eapply SIM0.
    clear. destruct o.
    { right. econs. }
    destruct t.
    { right. do 2 econs. }
    { left. auto. }
  Qed.

End USERSIM.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export DistributedReferenceCounting.machine2.invariant5.
Require Export DistributedReferenceCounting.machine2.invariant7.

Unset Standard Proposition Elimination Names.

(* changes:
   In safety1 and safety2, I had to use
   sigma_but_strictly_positive, instead of sigma_strictly_positive.

   In safety2, the case ~s2=owner should not be isolated
*)

Lemma direct_son_is_positive :
 forall c : Config,
 legal c ->
 forall s : Site,
 direct_son c s ->
 (Int (rt c s) + reduce Message dec_count (bm c s owner) +
  reduce Message copy_count (bm c owner s) -
  reduce Message new_inc_count (bm c s owner) > 0)%Z.

Proof.
  intros.
  elim H0.
  intros.
  rewrite H2; unfold Int in |- *.
  generalize (not_inc_dec_in (bm c s0 owner) H3); intro.
  generalize (copy_count_is_positive (bm c owner s0)).
  intro.
  generalize (dec_count_is_positive (bm c s0 owner)); intro.
  cut (reduce Message new_inc_count (bm c s0 owner) = 0%Z).
  intro.
  omega.

  generalize H4.
  elim (bm c s0 owner).
  simpl in |- *; auto.

  intro.
  case d.
  simpl in |- *.
  intros.
  rewrite H7.
  auto.

  intro.
  generalize (H8 s1).
  intuition.

  intros.
  elim (H8 s1); simpl in |- *.
  left; auto.

  simpl in |- *; intros.
  rewrite H7.
  omega.

  intro.
  generalize (H8 s1).
  intuition.
Qed.

Remark add_reduce : forall x : Z, (x > 0)%Z -> (x + 1 - 1 > 0)%Z.
Proof.
  intro; omega.
Qed.

Lemma safety1 :
 forall c : Config,
 legal c ->
 forall s : Site, s <> owner -> rt c s = true -> (st c owner > 0)%Z.

Proof.
  intros.
  rewrite (invariant4 c H).
  rewrite other_definition_for_sigma_receive_table.
  rewrite <- sigma_same_table.
  rewrite <- sigma_same_table.
  rewrite <- sigma_same_table2.
  unfold Z_id in |- *.
  unfold fun_minus in |- *.
  unfold fun_sum in |- *.
  rewrite sigma_sigma_but_owner.
  rewrite owner_rt_true.
  rewrite empty_q_to_me.
  simpl in |- *.
  simpl in |- *.
  elim (direct_or_indirect_son1 c s H0 H1); intro.
  unfold sigma_table_but_owner in |- *.
  apply add_reduce.
  apply sigma_but_strictly_positive with (x := s).
  apply in_s_LS.

  auto.

  intro; apply invariant5; auto.

  apply direct_son_is_positive; auto.

  apply add_reduce.
  elim (parent_invariant c H s b).
  intros.
  decompose [and] H2.
  unfold sigma_table_but_owner in |- *.
  apply sigma_but_strictly_positive with (x := x).
  apply in_s_LS.

  elim H3.
  intros; auto.

  intro; apply invariant5; auto.

  apply direct_son_is_positive; auto.

  auto.

  auto.
Qed.

Lemma safety2 :
 forall c : Config,
 legal c ->
 forall s1 s2 : Site,
 In_queue Message copy (bm c s1 s2) -> (st c owner > 0)%Z.
Proof.
  intros.
  elim (decide_inc_dec_in_queue c s2); intro.
  elim a; intros.
  apply safety1 with (s := x).
  auto.

  apply (not_owner_inc3 c s2 owner H x).
  apply inc_dec_in; auto.

  generalize (inc_dec_in x (bm c s2 owner) p).
  intro.
  generalize (not_owner_inc3 c s2 owner H x H1).
  intro.
  generalize (positive_st c x s2 H2 H H1).
  intro.
  generalize (st_rt c x H H2 H3).
  auto.

  case (eq_site_dec s1 owner); intro.
  rewrite (invariant4 c H).
  rewrite other_definition_for_sigma_receive_table.
  rewrite <- sigma_same_table.
  rewrite <- sigma_same_table.
  rewrite <- sigma_same_table2.
  unfold Z_id in |- *.
  unfold fun_minus in |- *.
  unfold fun_sum in |- *.
  rewrite sigma_sigma_but_owner.
  rewrite owner_rt_true.
  rewrite empty_q_to_me.
  simpl in |- *.
  apply add_reduce.
  unfold sigma_table_but_owner in |- *.
  apply sigma_but_strictly_positive with (x := s2).
  apply in_s_LS.

  unfold not in |- *; intro; generalize H0.
  rewrite e; rewrite H1; rewrite empty_q_to_me; simpl in |- *.
  auto.

  auto.

  intro; apply invariant5; auto.

  generalize (dec_count_is_positive (bm c s2 owner)); intro.
  cut (Int (rt c s2) >= 0)%Z.
  intro.
  cut (reduce Message new_inc_count (bm c s2 owner) = 0%Z).
  intro.
  cut (reduce Message copy_count (bm c owner s2) > 0)%Z.
  intro.
  omega.

  apply reduce_in_queue_strictly_positive with (x := copy).
  intro; unfold copy_count in |- *.
  case a; intros.
  omega.

  omega.

  omega.

  exact eq_message_dec.

  unfold copy_count in |- *; simpl in |- *.
  omega.

  rewrite <- e; auto.

  generalize (not_inc_dec_in (bm c s2 owner) b).
  intros.
  apply reduce_in_queue_null.
  intro.
  case x; simpl in |- *; intros.
  auto.

  elim (H3 s); auto.

  auto.

  unfold Int in |- *.
  case (eq_bool_dec (rt c s2)).
  intro.
  rewrite e0; simpl in |- *; omega.

  intro; rewrite e0; simpl in |- *; omega.

  auto.

  auto.

  apply safety1 with (s := s1).
  auto.

  auto.

  apply st_rt.
  auto.

  auto.

  rewrite invariant2.
  unfold sigma_rooted in |- *.
  apply sigma2_strictly_positive with (x := s1) (y := s2).
  exact eq_site_dec.

  apply in_s_LS.

  apply in_s_LS.

  unfold rooted in |- *; intros.
  apply reduce_positive_or_null.
  intros.
  apply rooted_fun_positive_or_null.

  unfold rooted in |- *.
  apply reduce_in_queue_strictly_positive with (x := copy).
  intro.
  apply rooted_fun_positive_or_null.

  exact eq_message_dec.

  unfold rooted_fun in |- *.
  case (eq_site_dec s1 s1); intro.
  omega.

  elim n0.
  auto.

  auto.

  auto.

  auto.
Qed.