From iris.proofmode Require Import proofmode.
From lrust.lang.lib Require Import memcpy.
From lrust.typing Require Export type.
From lrust.typing Require Import util uninit type_context programs.
From iris.prelude Require Import options.

Section own.
  Context `{!typeGS Σ}.

  Definition freeable_sz (n : nat) (sz : nat) (l : loc) : iProp Σ :=
    match sz, n return _ with
    | 0%nat, _ => True
    | _, 0%nat => False
    | sz, n => †{pos_to_Qp (Pos.of_nat sz) / pos_to_Qp (Pos.of_nat n)}l…sz
    end%I.
  Global Arguments freeable_sz : simpl never.

  Global Instance freeable_sz_timeless n sz l : Timeless (freeable_sz n sz l).
  Proof. destruct sz, n; apply _. Qed.

  Lemma freeable_sz_full n l : freeable_sz n n l ⊣⊢ †{1}l…n ∨ ⌜Z.of_nat n = 0⌝.
  Proof.
    destruct n as [|n].
    - iSplit; iIntros "H /="; auto.
    - assert (Z.of_nat (S n) = 0 ↔ False) as -> by done. rewrite right_id.
      by rewrite /freeable_sz Qp_div_diag.
  Qed.

  Lemma freeable_sz_full_S n l : freeable_sz (S n) (S n) l ⊣⊢ †{1}l…(S n).
  Proof. rewrite freeable_sz_full. iSplit; auto. iIntros "[$|%]"; done. Qed.

  Lemma freeable_sz_split n sz1 sz2 l :
    freeable_sz n sz1 l ∗ freeable_sz n sz2 (l +ₗ sz1) ⊣⊢
                freeable_sz n (sz1 + sz2) l.
  Proof.
    destruct sz1; [|destruct sz2;[|rewrite /freeable_sz plus_Sn_m; destruct n]].
    - by rewrite left_id shift_loc_0.
    - by rewrite right_id Nat.add_0_r.
    - iSplit.
      + by iIntros "[[]?]".
      + by iIntros "[]".
    - rewrite heap_freeable_op_eq. f_equiv; [|done..].
      by rewrite -Qp_div_add_distr pos_to_Qp_add -Nat2Pos.inj_add.
  Qed.

  (* Make sure 'simpl' doesn't unfold. *)
  Global Opaque freeable_sz.

  Program Definition own_ptr (n : nat) (ty : type) :=
    {| ty_size := 1;
       ty_own tid vl :=
         match vl return _ with
         | [ #(LitLoc l) ] =>
         (* We put a later in front of the †{q}, because we cannot use
            [ty_size_eq] on [ty] at step index 0, which would in turn
            prevent us to prove [subtype_own].

            Since this assertion is timeless, this should not cause
            problems. *)
           ▷ (l ↦∗: ty.(ty_own) tid ∗ freeable_sz n ty.(ty_size) l)
         | _ => False
         end%I;
       ty_shr κ tid l :=
         (∃ l':loc, &frac{κ}(λ q', l ↦{q'} #l') ∗
            □ (∀ F q, ⌜↑shrN ∪ ↑lftN ⊆ F⌝ -∗ q.[κ] ={F}[F∖↑shrN]▷=∗
                            ty.(ty_shr) κ tid l' ∗ q.[κ]))%I |}.
  Next Obligation. by iIntros (q ty tid [|[[]|][]]) "H". Qed.
  Next Obligation.
    move=>n ty N κ l tid ?? /=. iIntros "#LFT Hshr Htok".
    iMod (bor_exists with "LFT Hshr") as (vl) "Hb"; first solve_ndisj.
    iMod (bor_sep with "LFT Hb") as "[Hb1 Hb2]"; first solve_ndisj.
    destruct vl as [|[[|l'|]|][]];
      try (iMod (bor_persistent with "LFT Hb2 Htok") as "[>[]_]"; solve_ndisj).
    iFrame. iExists l'. rewrite heap_mapsto_vec_singleton.
    rewrite bi.later_sep.
    iMod (bor_sep with "LFT Hb2") as "[Hb2 _]"; first solve_ndisj.
    iMod (bor_fracture (λ q, l ↦{q} #l')%I with "LFT Hb1") as "$"; first solve_ndisj.
    iApply delay_sharing_later; done.
  Qed.
  Next Obligation.
    intros _ ty κ κ' tid l. iIntros "#Hκ #H".
    iDestruct "H" as (l') "[Hfb #Hvs]".
    iExists l'. iSplit; first by iApply (frac_bor_shorten with "[]"). iIntros "!> %F %q % Htok".
    iApply (step_fupd_mask_mono F _ (F∖↑shrN)); [solve_ndisj..|].
    iMod (lft_incl_acc with "Hκ Htok") as (q') "[Htok Hclose]"; first solve_ndisj.
    iMod ("Hvs" with "[%] Htok") as "Hvs'"; first solve_ndisj. iModIntro. iNext.
    iMod "Hvs'" as "[Hshr Htok]". iMod ("Hclose" with "Htok") as "$".
    by iApply (ty.(ty_shr_mono) with "Hκ").
  Qed.

  Global Instance own_ptr_wf n ty `{!TyWf ty} : TyWf (own_ptr n ty) :=
    { ty_lfts := ty_lfts ty; ty_wf_E := ty_wf_E ty }.

  Lemma own_type_incl n m ty1 ty2 :
    ▷ ⌜n = m⌝ -∗ ▷ type_incl ty1 ty2 -∗ type_incl (own_ptr n ty1) (own_ptr m ty2).
  Proof.
    iIntros "#Heq (#Hsz & #Ho & #Hs)". iSplit; first done. iSplit; iModIntro.
    - iIntros (?[|[[| |]|][]]) "H"; try done. simpl.
      iDestruct "H" as "[Hmt H†]". iNext. iDestruct ("Hsz") as %<-.
      iDestruct "Heq" as %->. iFrame. iApply (heap_mapsto_pred_wand with "Hmt").
      iApply "Ho".
    - iIntros (???) "H". iDestruct "H" as (l') "[Hfb #Hvs]".
      iExists l'. iFrame. iIntros "!>". iIntros (F' q) "% Htok".
      iMod ("Hvs" with "[%] Htok") as "Hvs'"; first done. iModIntro. iNext.
      iMod "Hvs'" as "[Hshr $]". iApply ("Hs" with "Hshr").
  Qed.

  Global Instance own_mono E L n :
    Proper (subtype E L ==> subtype E L) (own_ptr n).
  Proof.
    intros ty1 ty2 Hincl. iIntros (qmax qL) "HL".
    iDestruct (Hincl with "HL") as "#Hincl".
    iClear "∗". iIntros "!> #HE".
    iApply own_type_incl; first by auto. iApply "Hincl"; auto.
  Qed.
  Lemma own_mono' E L n1 n2 ty1 ty2 :
    n1 = n2 → subtype E L ty1 ty2 → subtype E L (own_ptr n1 ty1) (own_ptr n2 ty2).
  Proof. intros -> *. by apply own_mono. Qed.
  Global Instance own_proper E L n :
    Proper (eqtype E L ==> eqtype E L) (own_ptr n).
  Proof. intros ??[]; split; by apply own_mono. Qed.
  Lemma own_proper' E L n1 n2 ty1 ty2 :
    n1 = n2 → eqtype E L ty1 ty2 → eqtype E L (own_ptr n1 ty1) (own_ptr n2 ty2).
  Proof. intros -> *. by apply own_proper. Qed.

  Global Instance own_type_contractive n : TypeContractive (own_ptr n).
  Proof. solve_type_proper. Qed.

  Global Instance own_ne n : NonExpansive (own_ptr n).
  Proof. apply type_contractive_ne, _. Qed.

  Global Instance own_send n ty :
    Send ty → Send (own_ptr n ty).
  Proof.
    iIntros (Hsend tid1 tid2 [|[[| |]|][]]) "H"; try done.
    iDestruct "H" as "[Hm $]". iNext. iApply (heap_mapsto_pred_wand with "Hm").
    iIntros (vl) "?". by iApply Hsend.
  Qed.

  Global Instance own_sync n ty :
    Sync ty → Sync (own_ptr n ty).
  Proof.
    iIntros (Hsync κ tid1 tid2 l) "H". iDestruct "H" as (l') "[Hm #Hshr]".
    iExists _. iFrame "Hm". iModIntro. iIntros (F q) "% Htok".
    iMod ("Hshr" with "[] Htok") as "Hfin"; first done. iModIntro. iNext.
    iMod "Hfin" as "{Hshr} [Hshr $]". by iApply Hsync.
  Qed.
End own.

Section box.
  Context `{!typeGS Σ}.

  Definition box ty := own_ptr ty.(ty_size) ty.

  Lemma box_type_incl ty1 ty2 :
    ▷ type_incl ty1 ty2 -∗ type_incl (box ty1) (box ty2).
  Proof.
    iIntros "#Hincl". iApply own_type_incl; last done.
    iDestruct "Hincl" as "(? & _ & _)". done.
  Qed.

  Global Instance box_mono E L :
    Proper (subtype E L ==> subtype E L) box.
  Proof.
    intros ty1 ty2 Hincl. iIntros (qmax qL) "HL".
    iDestruct (Hincl with "HL") as "#Hincl".
    iClear "∗". iIntros "!> #HE".
    iApply box_type_incl. iApply "Hincl"; auto.
  Qed.
  Lemma box_mono' E L ty1 ty2 :
    subtype E L ty1 ty2 → subtype E L (box ty1) (box ty2).
  Proof. intros. by apply box_mono. Qed.
  Global Instance box_proper E L :
    Proper (eqtype E L ==> eqtype E L) box.
  Proof. intros ??[]; split; by apply box_mono. Qed.
  Lemma box_proper' E L ty1 ty2 :
    eqtype E L ty1 ty2 → eqtype E L (box ty1) (box ty2).
  Proof. intros. by apply box_proper. Qed.

  Global Instance box_type_contractive : TypeContractive box.
  Proof. solve_type_proper. Qed.

  Global Instance box_ne : NonExpansive box.
  Proof. apply type_contractive_ne, _. Qed.
End box.

Section util.
  Context `{!typeGS Σ}.

  Lemma ownptr_own n ty tid v :
    (own_ptr n ty).(ty_own) tid [v] ⊣⊢
       ∃ (l : loc) (vl : vec val ty.(ty_size)),
         ⌜v = #l⌝ ∗ ▷ l ↦∗ vl ∗ ▷ ty.(ty_own) tid vl ∗ ▷ freeable_sz n ty.(ty_size) l.
  Proof.
    iSplit.
    - iIntros "Hown". destruct v as [[|l|]|]; try done.
      iExists l. iDestruct "Hown" as "[Hown $]". rewrite heap_mapsto_ty_own.
      iDestruct "Hown" as (vl) "[??]". eauto with iFrame.
    - iIntros "Hown". iDestruct "Hown" as (l vl) "(% & ? & ? & ?)". subst v.
      iFrame. iExists _. iFrame.
  Qed.

  Lemma ownptr_uninit_own n m tid v :
    (own_ptr n (uninit m)).(ty_own) tid [v] ⊣⊢
         ∃ (l : loc) (vl' : vec val m), ⌜v = #l⌝ ∗ ▷ l ↦∗ vl' ∗ ▷ freeable_sz n m l.
  Proof.
    rewrite ownptr_own. apply bi.exist_proper=>l. iSplit.
    (* FIXME: The goals here look rather confusing:  One cannot tell that we are looking at
       a statement in Iris; the top-level → could just as well be a Coq implication. *)
    - iIntros "H". iDestruct "H" as (vl) "(% & Hl & _ & $)". subst v.
      iExists vl. iSplit; done.
    - iIntros "H". iDestruct "H" as (vl) "(% & Hl & $)". subst v.
      iExists vl. rewrite /= vec_to_list_length.
      eauto with iFrame.
  Qed.
End util.

Section typing.
  Context `{!typeGS Σ}.

  (** Typing *)
  Lemma write_own {E L} ty ty' n :
    ty.(ty_size) = ty'.(ty_size) → ⊢ typed_write E L (own_ptr n ty') ty (own_ptr n ty).
  Proof.
    rewrite typed_write_eq. iIntros (Hsz) "!>".
    iIntros ([[]|] tid F qmax qL ?) "_ _ $ Hown"; try done.
    rewrite /= Hsz. iDestruct "Hown" as "[H↦ $]". iDestruct "H↦" as (vl) "[>H↦ Hown]".
    iDestruct (ty_size_eq with "Hown") as "#>%". iExists _, _. iFrame "H↦". auto.
  Qed.

  Lemma read_own_copy E L ty n :
    Copy ty → ⊢ typed_read E L (own_ptr n ty) ty (own_ptr n ty).
  Proof.
    rewrite typed_read_eq. iIntros (Hsz) "!>".
    iIntros ([[|l|]|] tid F qmax qL ?) "_ _ $ $ Hown"; try done.
    iDestruct "Hown" as "[H↦ H†]". iDestruct "H↦" as (vl) "[>H↦ #Hown]".
    iExists l, _, _. iFrame "∗#". iSplitR; first done. iIntros "!> Hl !>".
    iExists _. auto.
  Qed.

  Lemma read_own_move E L ty n :
    ⊢ typed_read E L (own_ptr n ty) ty (own_ptr n $ uninit ty.(ty_size)).
  Proof.
    rewrite typed_read_eq. iModIntro.
    iIntros ([[|l|]|] tid F qmax qL ?) "_ _ $ $ Hown"; try done.
    iDestruct "Hown" as "[H↦ H†]". iDestruct "H↦" as (vl) "[>H↦ Hown]".
    iDestruct (ty_size_eq with "Hown") as "#>%".
    iExists l, vl, _. iFrame "∗#". iSplitR; first done. iIntros "!> Hl !> !>".
    iExists _. iFrame. done.
  Qed.

  Lemma type_new_instr {E L} (n : Z) :
    0 ≤ n →
    ⊢ let n' := Z.to_nat n in
      typed_instruction_ty E L [] (new [ #n ]%E) (own_ptr n' (uninit n')).
  Proof.
    iIntros (? tid qmax) "#LFT #HE $ $ _".
    iApply wp_new; try done. iModIntro.
    iIntros (l) "(H† & Hlft)". rewrite tctx_interp_singleton tctx_hasty_val.
    iNext. rewrite freeable_sz_full Z2Nat.id //. iFrame.
    iExists (repeat #☠ (Z.to_nat n)). iFrame. by rewrite /= repeat_length.
  Qed.

  Lemma type_new {E L C T} (n' : nat) x (n : Z) e :
    Closed (x :b: []) e →
    0 ≤ n →
    n' = Z.to_nat n →
    (∀ (v : val),
        typed_body E L C ((v ◁ own_ptr n' (uninit n')) :: T) (subst' x v e)) -∗
    typed_body E L C T (let: x := new [ #n ] in e).
  Proof. iIntros. subst. iApply type_let; [by apply type_new_instr|solve_typing..]. Qed.

  Lemma type_new_subtype ty E L C T x (n : Z) e :
    Closed (x :b: []) e →
    0 ≤ n →
    let n' := Z.to_nat n in
    subtype E L (uninit n') ty →
    (∀ (v : val), typed_body E L C ((v ◁ own_ptr n' ty) :: T) (subst' x v e)) -∗
    typed_body E L C T (let: x := new [ #n ] in e).
  Proof.
    iIntros (????) "Htyp". iApply type_let; [by apply type_new_instr|solve_typing|].
    iIntros (v). iApply typed_body_mono; last iApply "Htyp"; try done.
    by apply (tctx_incl_frame_r _ [_] [_]), subtype_tctx_incl, own_mono.
  Qed.

  Lemma type_delete_instr {E L} ty (n : Z) p :
    Z.of_nat (ty.(ty_size)) = n →
    ⊢ typed_instruction E L [p ◁ own_ptr ty.(ty_size) ty] (delete [ #n; p])%E (λ _, []).
  Proof.
    iIntros (<- tid qmax) "#LFT #HE $ $ Hp". rewrite tctx_interp_singleton.
    wp_bind p. iApply (wp_hasty with "Hp"). iIntros ([[]|]) "_ Hown"; try done.
    iDestruct "Hown" as "[H↦: >H†]". iDestruct "H↦:" as (vl) "[>H↦ Hown]".
    iDestruct (ty_size_eq with "Hown") as "#>EQ".
    iDestruct "EQ" as %<-. iApply (wp_delete with "[-]"); auto.
    - iFrame "H↦". by iApply freeable_sz_full.
    - rewrite /tctx_interp /=; auto.
  Qed.

  Lemma type_delete {E L} ty C T T' (n' : nat) (n : Z)  p e :
    Closed [] e →
    tctx_extract_hasty E L p (own_ptr n' ty) T T' →
    n = n' → Z.of_nat (ty.(ty_size)) = n →
    typed_body E L C T' e -∗
    typed_body E L C T (delete [ #n; p ] ;; e).
  Proof.
    iIntros (?? -> Hlen) "?". iApply type_seq; [by apply type_delete_instr| |done].
    by rewrite (inj _ _ _ Hlen).
  Qed.

  Lemma type_letalloc_1 {E L} ty C T T' (x : string) p e :
    Closed [] p → Closed (x :b: []) e →
    tctx_extract_hasty E L p ty T T' →
    ty.(ty_size) = 1%nat →
    (∀ (v : val), typed_body E L C ((v ◁ own_ptr 1 ty)::T') (subst x v e)) -∗
    typed_body E L C T (letalloc: x <- p in e).
  Proof.
    iIntros (??? Hsz) "**". iApply type_new.
    - rewrite /Closed /=. rewrite !andb_True.
      eauto 10 using is_closed_weaken with set_solver.
    - done.
    - solve_typing.
    - iIntros (xv) "/=". rewrite -Hsz.
      assert (subst x xv (x <- p ;; e)%E = (xv <- p ;; subst x xv e)%E) as ->.
      { (* TODO : simpl_subst should be able to do this. *)
        unfold subst=>/=. repeat f_equal.
        - by rewrite bool_decide_true.
        - eapply is_closed_subst; first done. set_solver. }
      iApply type_assign; [|solve_typing|by eapply write_own|solve_typing].
      apply subst_is_closed; last done. apply is_closed_of_val.
  Qed.

  Lemma type_letalloc_n {E L} ty ty1 ty2 C T T' (x : string) p e :
    Closed [] p → Closed (x :b: []) e →
    tctx_extract_hasty E L p ty1 T T' →
    (⊢ typed_read E L ty1 ty ty2) →
    (∀ (v : val),
        typed_body E L C ((v ◁ own_ptr (ty.(ty_size)) ty)::(p ◁ ty2)::T') (subst x v e)) -∗
    typed_body E L C T (letalloc: x <-{ty.(ty_size)} !p in e).
  Proof.
    iIntros. iApply type_new.
    - rewrite /Closed /=. rewrite !andb_True.
      eauto 10 using is_closed_of_val, is_closed_weaken with set_solver.
    - lia.
    - done.
    - iIntros (xv) "/=".
      assert (subst x xv (x <-{ty.(ty_size)} !p ;; e)%E =
              (xv <-{ty.(ty_size)} !p ;; subst x xv e)%E) as ->.
      { (* TODO : simpl_subst should be able to do this. *)
        unfold subst=>/=. repeat f_equal.
        - eapply (is_closed_subst []); last set_solver. apply is_closed_of_val.
        - by rewrite bool_decide_true.
        - eapply is_closed_subst; first done. set_solver. }
      rewrite Nat2Z.id. iApply type_memcpy.
      + apply subst_is_closed; last done. apply is_closed_of_val.
      + solve_typing.
      + (* TODO: Doing "eassumption" here shows that unification takes *forever* to fail.
           I guess that's caused by it trying to unify typed_read and typed_write,
           but considering that the Iris connectives are all sealed, why does
           that take so long? *)
        by eapply (write_own ty (uninit _)).
      + solve_typing.
      + done.
      + done.
  Qed.
End typing.

Global Hint Resolve own_mono' own_proper' box_mono' box_proper'
             write_own read_own_copy : lrust_typing.
(* By setting the priority high, we make sure copying is tried before
   moving. *)
Global Hint Resolve read_own_move | 100 : lrust_typing.


Require Import UFO.Rel.Definitions_closed.
Require Import UFO.Lang.Static.

Set Implicit Arguments.

Implicit Types EV LV V L : Set.

Notation subst_ef δ ρ ε := (
  EV_bind_ef δ (LV_bind_ef ρ ε)
).

Notation subst_eff δ ρ E := (
  EV_bind_eff δ (LV_bind_eff ρ E)
).

Notation subst_ty δ ρ T := (
  EV_bind_ty δ (LV_bind_ty ρ T)
).

Notation subst_md δ ρ γ t := (
  V_bind_md γ (EV_bind_md δ (LV_bind_md ρ t))
).

Notation subst_ktx δ ρ γ K := (
  V_bind_ktx γ (EV_bind_ktx δ (LV_bind_ktx ρ K))
).

Notation subst_val δ ρ γ t := (
  V_bind_val γ (EV_bind_val δ (LV_bind_val ρ t))
).

Notation subst_tm δ ρ γ t := (
  V_bind_tm γ (EV_bind_tm δ (LV_bind_tm ρ t))
).

Section section_𝜩𝑷𝜞.
Context (EV LV V : Set).
Implicit Type (Ξ : XEnv EV LV).
Implicit Type (Γ : V → ty ∅ EV LV ∅).
Implicit Type (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig).
Implicit Type (ρ₁ ρ₂ : LV → lbl0) (ρ : LV → IRel 𝓣_Sig).
Implicit Type (γ₁ γ₂ : V → val0).

Definition 𝜞 Ξ Γ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ γ₁ γ₂ :=
∀ᵢ x, 𝓥⟦ Ξ ⊢ Γ x ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ (γ₁ x) (γ₂ x).

Definition 𝜩 Ξ ξ₁ ξ₂ := dom Ξ \c from_list ξ₁ ∧ dom Ξ \c from_list ξ₂.

Definition δ_is_closed ξ₁ ξ₂ δ : IProp := ∀ᵢ α, 𝓤_is_closed ξ₁ ξ₂ (δ α).

Definition ρ₁ρ₂_are_closed ξ₁ ξ₂ ρ₁ ρ₂ : Prop :=
∀ α X,
(ρ₁ α = lbl_id (lid_f X) → X ∈ from_list ξ₁) ∧
(ρ₂ α = lbl_id (lid_f X) → X ∈ from_list ξ₂).

End section_𝜩𝑷𝜞.

Notation "'𝜞⟦' Ξ ⊢ Γ ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ" := (𝜞 Ξ Γ δ₁ δ₂ δ ρ₁ ρ₂ ρ)
(at level 25, Ξ at level 0, Γ at level 0,
δ₁ at level 0, δ₂ at level 0, δ at level 0,
ρ₁ at level 0, ρ₂ at level 0, ρ at level 0).

Section section_EV_LV_V_open.
Context (EV LV V : Set).
Context (Ξ : XEnv EV LV).
Context (Γ : V → ty ∅ EV LV ∅).

Definition 𝓣_EV_LV_V_open (T : ty ∅ EV LV ∅) (E : eff ∅ EV LV ∅) (t₁ t₂ : tm EV LV V ∅) : IProp :=
  ∀ᵢ ξ₁ ξ₂ δ₁ δ₂ δ ρ₁ ρ₂ ρ γ₁ γ₂,
  (𝜩 Ξ ξ₁ ξ₂)ᵢ ⇒
  δ_is_closed ξ₁ ξ₂ δ ⇒
  (ρ₁ρ₂_are_closed ξ₁ ξ₂ ρ₁ ρ₂)ᵢ ⇒
  𝜞⟦ Ξ ⊢ Γ ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ γ₁ γ₂ ⇒
  𝓣⟦ Ξ ⊢ T # E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ
    ξ₁ ξ₂
    (subst_tm δ₁ ρ₁ γ₁ t₁)
    (subst_tm δ₂ ρ₂ γ₂ t₂).

Definition 𝓥_EV_LV_V_open (T : ty ∅ EV LV ∅) v₁ v₂ : IProp :=
  ∀ᵢ ξ₁ ξ₂ δ₁ δ₂ δ ρ₁ ρ₂ ρ γ₁ γ₂,
  (𝜩 Ξ ξ₁ ξ₂)ᵢ ⇒
  δ_is_closed ξ₁ ξ₂ δ ⇒
  (ρ₁ρ₂_are_closed ξ₁ ξ₂ ρ₁ ρ₂)ᵢ ⇒
  𝜞⟦ Ξ ⊢ Γ ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ γ₁ γ₂ ⇒
  𝓥⟦ Ξ ⊢ T ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ
    ξ₁ ξ₂
    (subst_val δ₁ ρ₁ γ₁ v₁)
    (subst_val δ₂ ρ₂ γ₂ v₂).

Definition 𝓜_EV_LV_V_open (σ : ms ∅ EV LV ∅) (ℓ : lbl LV ∅) m₁ m₂ : IProp :=
  ∀ᵢ ξ₁ ξ₂ δ₁ δ₂ δ ρ₁ ρ₂ ρ γ₁ γ₂,
  (𝜩 Ξ ξ₁ ξ₂)ᵢ ⇒
  δ_is_closed ξ₁ ξ₂ δ ⇒
  (ρ₁ρ₂_are_closed ξ₁ ξ₂ ρ₁ ρ₂)ᵢ ⇒
  𝜞⟦ Ξ ⊢ Γ ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ γ₁ γ₂ ⇒
  𝓜⟦ Ξ ⊢ σ ^ ℓ ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ
    ξ₁ ξ₂
    (subst_md δ₁ ρ₁ γ₁ m₁)
    (subst_md δ₂ ρ₂ γ₂ m₂).

Definition 𝓚_EV_LV_V_open (Ta Tb : ty ∅ EV LV ∅) (Ea Eb : eff ∅ EV LV ∅) K₁ K₂ : IProp :=
  ∀ᵢ ξ₁ ξ₂ δ₁ δ₂ δ ρ₁ ρ₂ ρ γ₁ γ₂,
  (𝜩 Ξ ξ₁ ξ₂)ᵢ ⇒
  δ_is_closed ξ₁ ξ₂ δ ⇒
  (ρ₁ρ₂_are_closed ξ₁ ξ₂ ρ₁ ρ₂)ᵢ ⇒
  𝜞⟦ Ξ ⊢ Γ ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ γ₁ γ₂ ⇒
  𝓚⟦ Ξ ⊢ Ta # Ea ⇢ Tb # Eb ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ
    ξ₁ ξ₂
    (subst_ktx δ₁ ρ₁ γ₁ K₁)
    (subst_ktx δ₂ ρ₂ γ₂ K₂).

Definition 𝓗_EV_LV_V_open (Ta Tb : ty ∅ EV LV ∅) (Ea Eb : eff ∅ EV LV ∅) r₁ r₂ : IProp :=
  ∀ᵢ ξ₁ ξ₂ δ₁ δ₂ δ ρ₁ ρ₂ ρ γ₁ γ₂,
  (𝜩 Ξ ξ₁ ξ₂)ᵢ ⇒
  δ_is_closed ξ₁ ξ₂ δ ⇒
  (ρ₁ρ₂_are_closed ξ₁ ξ₂ ρ₁ ρ₂)ᵢ ⇒
  𝜞⟦ Ξ ⊢ Γ ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ γ₁ γ₂ ⇒
  𝓗⟦ Ξ ⊢ Ta # Ea ⇢ Tb # Eb ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ
    ξ₁ ξ₂
    (subst_tm δ₁ ρ₁ (V_shift_val ∘ γ₁) r₁)
    (subst_tm δ₂ ρ₂ (V_shift_val ∘ γ₂) r₂).

End section_EV_LV_V_open.

Notation "⟦ Ξ Γ ⊢ t₁ '≼ˡᵒᵍ' t₂ : T # E ⟧" := (𝓣_EV_LV_V_open Ξ Γ T E t₁ t₂)
  (at level 1, Ξ at level 0, Γ at level 0, t₁ at level 0, t₂ at level 0, T at level 0).

Notation "⟦ Ξ Γ ⊢ v₁ '≼ˡᵒᵍᵥ' v₂ : T ⟧" := (𝓥_EV_LV_V_open Ξ Γ T v₁ v₂)
  (at level 1, Ξ at level 0, Γ at level 0, v₁ at level 0, v₂ at level 0).

Notation "⟦ Ξ Γ ⊢ m₁ '≼ˡᵒᵍₘ' m₂ : σ ^ ℓ ⟧" := (𝓜_EV_LV_V_open Ξ Γ σ ℓ m₁ m₂)
  (at level 1, Ξ at level 0, Γ at level 0, m₁ at level 0, m₂ at level 0, σ at level 0).

Notation "⟦ Ξ Γ ⊢ K₁ '≼ˡᵒᵍ' K₂ : Ta # Ea ⇢ Tb # Eb ⟧" :=
  (𝓚_EV_LV_V_open Ξ Γ Ta Tb Ea Eb K₁ K₂)
  (at level 1, Ξ at level 0, Γ at level 0, K₁ at level 0, K₂ at level 0, Ta at level 0, Tb at level 0).

Definition 𝓣_eq_EV_LV_V_open
(EV LV V : Set) (Ξ : XEnv EV LV) (Γ : V → ty ∅ EV LV ∅)
(T : ty ∅ EV LV ∅) (E : eff ∅ EV LV ∅) (t₁ t₂ : tm EV LV V ∅) : IProp :=
⟦ Ξ Γ ⊢ t₁ ≼ˡᵒᵍ t₂ : T # E ⟧ ∧ᵢ ⟦ Ξ Γ ⊢ t₂ ≼ˡᵒᵍ t₁ : T # E ⟧.

Notation "⟦ Ξ Γ ⊢ t₁ '≈ˡᵒᵍ' t₂ : T # E ⟧" := (𝓣_eq_EV_LV_V_open Ξ Γ T E t₁ t₂)
  (at level 1, Ξ at level 0, Γ at level 0, t₁ at level 0, t₂ at level 0, T at level 0).

Section section_EV_LV_V_L_open.
Context (EV LV V L : Set).
Context (Π : LEnv EV LV L).
Context (Γ : V → ty ∅ EV LV L).

Definition 𝓣_EV_LV_V_L_open T E t₁ t₂ : IProp :=
∀ᵢ Ξ f,
(XLEnv Ξ Π f)ᵢ ⇒
⟦ Ξ (L_bind_ty f ∘ Γ) ⊢ (L_bind_tm f t₁) ≼ˡᵒᵍ (L_bind_tm f t₂) :
  (L_bind_ty f T) # (L_bind_eff f E) ⟧.

Definition 𝓥_EV_LV_V_L_open T v₁ v₂ : IProp :=
∀ᵢ Ξ f,
(XLEnv Ξ Π f)ᵢ ⇒
⟦ Ξ (L_bind_ty f ∘ Γ) ⊢ (L_bind_val f v₁) ≼ˡᵒᵍᵥ (L_bind_val f v₂) :
  (L_bind_ty f T) ⟧.

Definition 𝓜_EV_LV_V_L_open σ ℓ m₁ m₂ : IProp :=
∀ᵢ Ξ f,
(XLEnv Ξ Π f)ᵢ ⇒
⟦ Ξ (L_bind_ty f ∘ Γ) ⊢ (L_bind_md f m₁) ≼ˡᵒᵍₘ (L_bind_md f m₂) :
  (L_bind_ms f σ) ^ (L_bind_lbl f ℓ) ⟧.

Definition 𝓚_EV_LV_V_L_open Ta Tb Ea Eb K₁ K₂ : IProp :=
∀ᵢ Ξ f,
(XLEnv Ξ Π f)ᵢ ⇒
⟦ Ξ (L_bind_ty f ∘ Γ) ⊢ (L_bind_ktx f K₁) ≼ˡᵒᵍ (L_bind_ktx f K₂) :
  (L_bind_ty f Ta) # (L_bind_eff f Ea) ⇢ (L_bind_ty f Tb) # (L_bind_eff f Eb) ⟧.

End section_EV_LV_V_L_open.

Notation "【 Π Γ ⊢ t₁ '≼ˡᵒᵍ' t₂ : T # E 】" := (𝓣_EV_LV_V_L_open Π Γ T E t₁ t₂)
  (Π at level 0, Γ at level 0, t₁ at level 0, t₂ at level 0, T at level 0).

Notation "【 Π Γ ⊢ v₁ '≼ˡᵒᵍᵥ' v₂ : T 】" := (𝓥_EV_LV_V_L_open Π Γ T v₁ v₂)
  (Π at level 0, Γ at level 0, v₁ at level 0, v₂ at level 0).

Notation "【 Π Γ ⊢ m₁ '≼ˡᵒᵍₘ' m₂ : σ ^ ℓ 】" := (𝓜_EV_LV_V_L_open Π Γ σ ℓ m₁ m₂)
  (Π at level 0, Γ at level 0, m₁ at level 0, m₂ at level 0, σ at level 0).

Notation "【 Π Γ ⊢ K₁ '≼ˡᵒᵍ' K₂ : Ta # Ea ⇢ Tb # Eb 】" :=
  (𝓚_EV_LV_V_L_open Π Γ Ta Tb Ea Eb K₁ K₂)
  (Π at level 0, Γ at level 0, K₁ at level 0, K₂ at level 0, Ta at level 0, Tb at level 0).

Definition 𝓣_eq_EV_LV_V_L_open
(EV LV V L : Set) (Π : LEnv EV LV L) (Γ : V → ty ∅ EV LV L) T E t₁ t₂ : IProp :=
【 Π Γ ⊢ t₁ ≼ˡᵒᵍ t₂ : T # E 】 ∧ᵢ 【 Π Γ ⊢ t₂ ≼ˡᵒᵍ t₁ : T # E 】.

Notation "【 Π Γ ⊢ t₁ '≈ˡᵒᵍ' t₂ : T # E 】" := (𝓣_eq_EV_LV_V_L_open Π Γ T E t₁ t₂)
  (Π at level 0, Γ at level 0, t₁ at level 0, t₂ at level 0, T at level 0).


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 Spec.

  Definition rec_destroy_ops_spec (g_rec: Pointer) (adt: RData) : option RData :=
    rely (peq (base g_rec) ginfo_loc);
    let rec_gidx := (offset g_rec) in
    rely is_gidx rec_gidx;
    let gn := (gs (share adt)) @ rec_gidx in
    rely (g_tag (ginfo gn) =? GRANULE_STATE_REC);
    rely (gtype gn =? GRANULE_STATE_REC);
    rely prop_dec (glock gn = Some CPU_ID);
    rely prop_dec (gref gn = None);
    rely (g_inited (gro gn));
    rely prop_dec ((buffer (priv adt)) @ SLOT_REC = None);
    rely prop_dec ((buffer (priv adt)) @ SLOT_REC_LIST = None);
    let rd_gidx := g_rd (ginfo gn) in
    let rec_list_gidx := g_rec_rec_list (grec gn) in
    let rec_idx := g_rec_idx (gro gn) in
    rely is_int64 rec_idx; rely is_gidx rd_gidx; rely is_gidx rec_list_gidx;
    let gn_recl := (gs (share adt)) @ rec_list_gidx in
    let gn_rd := (gs (share adt)) @ rd_gidx in
    rely (gtype gn_recl =? GRANULE_STATE_REC_LIST);
    rely (gtype gn_rd =? GRANULE_STATE_RD);
    rely (gcnt gn_rd >? 0);
    let gn_recl' := gn_recl {gnorm: (gnorm gn_recl) {g_data: (g_data (gnorm gn_recl)) # rec_idx == 0}} in
    let gn_rec' := gn {ginfo: (ginfo gn) {g_rd: 0} {g_tag: GRANULE_STATE_DELEGATED}}
                      {gnorm: zero_granule_data_normal} {grec: zero_granule_data_rec} in
    let gn_rd' := gn_rd {gcnt: (gcnt gn_rd) - 1} in
    let e := EVT CPU_ID (RECL rec_list_gidx rec_idx UNSET_RECL) in
    let e' := EVT CPU_ID (REL rec_gidx gn_rec') in
    let e'' := EVT CPU_ID (DEC_RD_GCNT rd_gidx) in
    Some adt {log: e'' :: e' :: e :: log adt}
             {share: (share adt) {gs: (gs (share adt)) # rec_list_gidx == gn_recl'
                                                       # rec_gidx == (gn_rec' {glock: None} {gtype: GRANULE_STATE_DELEGATED})
                                                       # rd_gidx == gn_rd'}}.

End Spec.


Require Import RelationClasses.
Require Import List.

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

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

From PromisingLib Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import MemoryFacts.
Require Import MemoryDomain.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.

Require Import FulfillStep.

Require Import SimMemory.
Require Import SimPromises.

Set Implicit Arguments.

Inductive sim_local (pview:SimPromises.t) (lc_src lc_tgt:Local.t): Prop :=
| sim_local_intro
    (TVIEW: TView.le (Local.tview lc_src) (Local.tview lc_tgt))
    (PROMISES: SimPromises.sem pview SimPromises.bot (Local.promises lc_src) (Local.promises lc_tgt))
.

Global Program Instance sim_local_PreOrder: PreOrder (sim_local SimPromises.bot).
Next Obligation.
  econs; try refl. apply SimPromises.sem_bot.
Qed.
Next Obligation.
  ii. inv H. inv H0. econs; try etrans; eauto.
  apply SimPromises.sem_bot_inv in PROMISES; auto.
  apply SimPromises.sem_bot_inv in PROMISES0; auto.
  rewrite PROMISES, PROMISES0. apply SimPromises.sem_bot.
Qed.

Lemma sim_local_nonsynch_loc
      pview loc lc_src lc_tgt
      (SIM: sim_local pview lc_src lc_tgt)
      (NONSYNCH: Memory.nonsynch_loc loc (Local.promises lc_tgt)):
  Memory.nonsynch_loc loc (Local.promises lc_src).
Proof.
  inv SIM. inv PROMISES.
  ii. destruct msg; ss.
  destruct (Memory.get loc t (Local.promises lc_tgt)) as [[? []]|] eqn:GET_TGT.
  - exploit NONSYNCH; eauto. ss. i. subst.
    exploit LE; eauto. intro X. rewrite GET in X. inv X.
    unfold SimPromises.none_if, SimPromises.none_if_released. condtac; ss.
  - exploit LE; eauto. s. i. congr.
  - exploit LE; eauto. s. i. congr.
  - exploit COMPLETE; eauto. rewrite SimPromises.bot_spec. ss.
Qed.

Lemma sim_local_nonsynch
      pview lc_src lc_tgt
      (SIM: sim_local pview lc_src lc_tgt)
      (NONSYNCH: Memory.nonsynch (Local.promises lc_tgt)):
  Memory.nonsynch (Local.promises lc_src).
Proof.
  ii. eapply sim_local_nonsynch_loc; eauto.
Qed.

Lemma sim_local_memory_bot
      pview lc_src lc_tgt
      (SIM: sim_local pview lc_src lc_tgt)
      (BOT: (Local.promises lc_tgt) = Memory.bot):
  (Local.promises lc_src) = Memory.bot.
Proof.
  inv SIM. inv PROMISES. rewrite BOT in *.
  apply Memory.ext. i. rewrite Memory.bot_get.
  destruct (Memory.get loc ts (Local.promises lc_src)) eqn:GET_SRC; ss.
  destruct p.
  exploit COMPLETE; eauto.
  - apply Memory.bot_get.
  - rewrite SimPromises.bot_spec. ss.
Qed.

Lemma sim_local_promise
      pview
      lc1_src mem1_src
      lc1_tgt mem1_tgt
      lc2_tgt mem2_tgt
      loc from to msg kind
      (STEP_TGT: Local.promise_step lc1_tgt mem1_tgt loc from to msg lc2_tgt mem2_tgt kind)
      (LOCAL1: sim_local pview lc1_src lc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists lc2_src mem2_src,
    <<STEP_SRC: Local.promise_step lc1_src mem1_src loc from to (SimPromises.none_if loc to pview msg) lc2_src mem2_src (SimPromises.kind_transf loc to pview kind)>> /\
    <<LOCAL2: sim_local pview lc2_src lc2_tgt>> /\
    <<MEM2: sim_memory mem2_src mem2_tgt>>.
Proof.
  inv LOCAL1. inv STEP_TGT.
  exploit SimPromises.promise; eauto.
  { apply WF1_SRC. }
  { apply WF1_TGT. }
  i. des.
  exploit sim_memory_closed_message; eauto. i.
  exploit Memory.promise_future; try apply PROMISE_SRC; try apply WF1_SRC; eauto.
  { unfold SimPromises.none_if, SimPromises.none_if_released.
    destruct msg; try condtac; eauto. }
  i. des.
  esplits; eauto.
  - econs; eauto. SimPromises.none_if_tac. eauto.
  - econs; eauto.
Qed.

Lemma sim_local_promise_bot
      lc1_src mem1_src
      lc1_tgt mem1_tgt
      lc2_tgt mem2_tgt
      loc from to msg kind
      (STEP_TGT: Local.promise_step lc1_tgt mem1_tgt loc from to msg lc2_tgt mem2_tgt kind)
      (LOCAL1: sim_local SimPromises.bot lc1_src lc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists lc2_src mem2_src,
    <<STEP_SRC: Local.promise_step lc1_src mem1_src loc from to msg lc2_src mem2_src kind>> /\
    <<LOCAL2: sim_local SimPromises.bot lc2_src lc2_tgt>> /\
    <<MEM2: sim_memory mem2_src mem2_tgt>>.
Proof.
  exploit sim_local_promise; eauto.
  rewrite SimPromises.none_if_bot.
  rewrite SimPromises.kind_transf_bot. ss.
Qed.

Lemma sim_local_read
      pview
      lc1_src mem1_src
      lc1_tgt mem1_tgt
      lc2_tgt
      loc ts val released_tgt ord_src ord_tgt
      (STEP_TGT: Local.read_step lc1_tgt mem1_tgt loc ts val released_tgt ord_tgt lc2_tgt)
      (LOCAL1: sim_local pview lc1_src lc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt)
      (ORD: Ordering.le ord_src ord_tgt):
  exists released_src lc2_src,
    <<REL: View.opt_le released_src released_tgt>> /\
    <<STEP_SRC: Local.read_step lc1_src mem1_src loc ts val released_src ord_src lc2_src>> /\
    <<LOCAL2: sim_local pview lc2_src lc2_tgt>>.
Proof.
  inv LOCAL1. inv STEP_TGT.
  exploit sim_memory_get; try apply GET; eauto. i. des.
  inv MSG. esplits; eauto.
  - econs; eauto; (try etrans; eauto).
    eapply TViewFacts.readable_mon; eauto. apply TVIEW.
  - econs; eauto. s. apply TViewFacts.read_tview_mon; auto.
    + apply WF1_TGT.
    + inv MEM1_TGT. exploit CLOSED; eauto. i. des. inv MSG_WF. auto.
Qed.

Lemma sim_local_fulfill
      pview
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt sc2_tgt
      loc from to val releasedm_src releasedm_tgt released ord_src ord_tgt
      (RELM_LE: View.opt_le releasedm_src releasedm_tgt)
      (RELM_WF: View.opt_wf releasedm_src)
      (RELM_CLOSED: Memory.closed_opt_view releasedm_src mem1_src)
      (WF_RELM_TGT: View.opt_wf releasedm_tgt)
      (ORD: Ordering.le ord_src ord_tgt)
      (PVIEW: SimPromises.mem loc to pview = false \/ Ordering.le ord_tgt Ordering.plain)
      (STEP_TGT: fulfill_step lc1_tgt sc1_tgt loc from to val releasedm_tgt released ord_tgt lc2_tgt sc2_tgt)
      (LOCAL1: sim_local pview lc1_src lc1_tgt)
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC1_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists lc2_src sc2_src,
    <<STEP_SRC: fulfill_step lc1_src sc1_src loc from to val releasedm_src (SimPromises.none_if_released loc to pview released) ord_src lc2_src sc2_src>> /\
    <<LOCAL2: sim_local (SimPromises.unset loc to pview) lc2_src lc2_tgt>> /\
    <<SC2: TimeMap.le sc2_src sc2_tgt>>.
Proof.
  guardH PVIEW.
  inv STEP_TGT.
  assert (RELT_LE:
   View.opt_le
     (TView.write_released (Local.tview lc1_src) sc1_src loc to releasedm_src ord_src)
     (TView.write_released (Local.tview lc1_tgt) sc2_tgt loc to releasedm_tgt ord_tgt)).
  { apply TViewFacts.write_released_mon; ss.
    - apply LOCAL1.
    - apply WF1_TGT.
  }
  assert (RELT_WF:
   View.opt_wf (TView.write_released (Local.tview lc1_src) sc1_src loc to releasedm_src ord_src)).
  { unfold TView.write_released. condtac; econs.
    repeat (try condtac; viewtac; try apply WF1_SRC).
  }
  exploit SimPromises.remove; try exact REMOVE;
    try exact MEM1; try apply LOCAL1; eauto.
  i. des. esplits.
  - econs; eauto.
    + SimPromises.none_if_tac.
      * unguardH PVIEW. des; ss. unfold TView.write_released. condtac; [|refl].
        destruct ord_src, ord_tgt; inv ORD; inv PVIEW; inv COND0.
      * etrans; eauto.
    + SimPromises.none_if_tac; viewtac.
    + eapply TViewFacts.writable_mon; try exact WRITABLE; eauto. apply LOCAL1.
  - econs; eauto. s. apply TViewFacts.write_tview_mon; auto.
    + apply LOCAL1.
    + apply WF1_TGT.
  - ss.
Qed.

Lemma sim_local_fulfill_bot
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt sc2_tgt
      loc from to val releasedm_src releasedm_tgt released ord_src ord_tgt
      (RELM_LE: View.opt_le releasedm_src releasedm_tgt)
      (RELM_WF: View.opt_wf releasedm_src)
      (RELM_CLOSED: Memory.closed_opt_view releasedm_src mem1_src)
      (WF_RELM_TGT: View.opt_wf releasedm_tgt)
      (ORD: Ordering.le ord_src ord_tgt)
      (STEP_TGT: fulfill_step lc1_tgt sc1_tgt loc from to val releasedm_tgt released ord_tgt lc2_tgt sc2_tgt)
      (LOCAL1: sim_local SimPromises.bot lc1_src lc1_tgt)
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC1_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists lc2_src sc2_src,
    <<STEP_SRC: fulfill_step lc1_src sc1_src loc from to val releasedm_src released ord_src lc2_src sc2_src>> /\
    <<LOCAL2: sim_local SimPromises.bot lc2_src lc2_tgt>> /\
    <<SC2: TimeMap.le sc2_src sc2_tgt>>.
Proof.
  exploit sim_local_fulfill; eauto.
  { rewrite SimPromises.bot_spec. intuition. }
  i. des. esplits; eauto.
  rewrite SimPromises.unset_bot in *; ss.
Qed.

Lemma sim_local_promise_not_lower
      pview
      lc1_src
      lc1_tgt mem1_tgt loc from to msg_tgt lc1 mem2_tgt kind
      (LOCAL: sim_local pview lc1_src lc1_tgt)
      (STEP: Local.promise_step lc1_tgt mem1_tgt loc from to msg_tgt lc1 mem2_tgt kind)
      (KIND: negb (Memory.op_kind_is_lower kind)):
  SimPromises.mem loc to pview = false.
Proof.
  destruct (SimPromises.mem loc to pview) eqn:X; ss.
  inv LOCAL. inv PROMISES. exploit PVIEW; eauto. i. des.
  inv STEP. inv PROMISE; ss.
  - exploit Memory.add_get0; try exact PROMISES; eauto. i. des. congr.
  - exploit Memory.split_get0; try exact PROMISES; eauto. i. des. congr.
  - exploit Memory.remove_get0; try exact PROMISES; eauto. i. des. congr.
Qed.

Lemma sim_local_write
      pview
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt sc2_tgt mem2_tgt
      loc from to val releasedm_src releasedm_tgt released_tgt ord_src ord_tgt kind
      (RELM_LE: View.opt_le releasedm_src releasedm_tgt)
      (RELM_SRC_WF: View.opt_wf releasedm_src)
      (RELM_SRC_CLOSED: Memory.closed_opt_view releasedm_src mem1_src)
      (RELM_TGT_WF: View.opt_wf releasedm_tgt)
      (RELM_TGT_CLOSED: Memory.closed_opt_view releasedm_tgt mem1_tgt)
      (ORD: Ordering.le ord_src ord_tgt)
      (PVIEW: SimPromises.mem loc to pview = false \/
              Ordering.le ord_tgt Ordering.plain \/
              Ordering.le Ordering.strong_relaxed ord_tgt)
      (STEP_TGT: Local.write_step lc1_tgt sc1_tgt mem1_tgt loc from to val releasedm_tgt released_tgt ord_tgt lc2_tgt sc2_tgt mem2_tgt kind)
      (LOCAL1: sim_local pview lc1_src lc1_tgt)
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC1_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists released_src lc2_src sc2_src mem2_src,
    <<STEP_SRC: Local.write_step lc1_src sc1_src mem1_src loc from to val releasedm_src
                                 released_src
                                 ord_src lc2_src sc2_src mem2_src
                                 (SimPromises.kind_transf loc to pview kind)>> /\
    <<REL2: View.opt_le released_src released_tgt>> /\
    <<LOCAL2: sim_local (SimPromises.unset loc to pview) lc2_src lc2_tgt>> /\
    <<SC2: TimeMap.le sc2_src sc2_tgt>> /\
    <<MEM2: sim_memory mem2_src mem2_tgt>>.
Proof.
  guardH PVIEW.
  exploit write_promise_fulfill; eauto. i. des.
  exploit Local.promise_step_future; eauto. i. des.
  exploit sim_local_promise; eauto. i. des.
  exploit Local.promise_step_future; eauto. i. des.
  exploit sim_local_fulfill; try apply STEP2;
    try apply LOCAL2; try apply MEM2; eauto.
  { eapply Memory.future_closed_opt_view; eauto. }
  { unguardH PVIEW. des; intuition.
    exploit Local.write_step_strong_relaxed; eauto. i.
    left. eapply sim_local_promise_not_lower; try exact STEP1; eauto.
  }
  i. des.
  exploit promise_fulfill_write_sim_memory; try exact STEP_SRC; try exact STEP_SRC0; eauto.
  { i. hexploit ORD0; eauto.
    eapply sim_local_nonsynch_loc; eauto.
  }
  i. des. subst. esplits; eauto.
  - apply TViewFacts.write_released_mon; ss;
      try apply LOCAL1; try apply WF1_TGT.
  - etrans; eauto.
Qed.

Lemma sim_local_write_bot
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt sc2_tgt mem2_tgt
      loc from to val releasedm_src releasedm_tgt released_tgt ord_src ord_tgt kind
      (RELM_LE: View.opt_le releasedm_src releasedm_tgt)
      (RELM_SRC_WF: View.opt_wf releasedm_src)
      (RELM_SRC_CLOSED: Memory.closed_opt_view releasedm_src mem1_src)
      (RELM_TGT_WF: View.opt_wf releasedm_tgt)
      (RELM_TGT_CLOSED: Memory.closed_opt_view releasedm_tgt mem1_tgt)
      (ORD: Ordering.le ord_src ord_tgt)
      (STEP_TGT: Local.write_step lc1_tgt sc1_tgt mem1_tgt loc from to val releasedm_tgt released_tgt ord_tgt lc2_tgt sc2_tgt mem2_tgt kind)
      (LOCAL1: sim_local SimPromises.bot lc1_src lc1_tgt)
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC1_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists released_src lc2_src sc2_src mem2_src,
    <<STEP_SRC: Local.write_step lc1_src sc1_src mem1_src loc from to val releasedm_src
                                 released_src
                                 ord_src lc2_src sc2_src mem2_src
                                 kind>> /\
    <<REL2: View.opt_le released_src released_tgt>> /\
    <<LOCAL2: sim_local SimPromises.bot lc2_src lc2_tgt>> /\
    <<SC2: TimeMap.le sc2_src sc2_tgt>> /\
    <<MEM2: sim_memory mem2_src mem2_tgt>>.
Proof.
  hexploit sim_local_write; eauto.
  { rewrite SimPromises.bot_spec. intuition. }
  i. des. esplits; eauto.
  - rewrite SimPromises.kind_transf_bot in *. eauto.
  - rewrite SimPromises.unset_bot in *; ss.
Qed.

Lemma sim_local_write_na
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt sc2_tgt mem2_tgt
      loc from to val ord_src ord_tgt msgs kinds kind
      (ORD: Ordering.le ord_src ord_tgt)
      (STEP_TGT: Local.write_na_step lc1_tgt sc1_tgt mem1_tgt loc from to val ord_tgt lc2_tgt sc2_tgt mem2_tgt msgs kinds kind)
      (LOCAL1: sim_local SimPromises.bot lc1_src lc1_tgt)
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC1_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists lc2_src sc2_src mem2_src,
    <<STEP_SRC: Local.write_na_step lc1_src sc1_src mem1_src loc from to val ord_src lc2_src sc2_src mem2_src msgs kinds kind>> /\
    <<LOCAL2: sim_local SimPromises.bot lc2_src lc2_tgt>> /\
    <<SC2: TimeMap.le sc2_src sc2_tgt>> /\
    <<MEM2: sim_memory mem2_src mem2_tgt>>.
Proof.
  inv STEP_TGT.
  exploit SimPromises.write_na;
    try apply WRITE; try apply LOCAL1; try apply WF1_SRC; try apply WF1_TGT; eauto.
  i. des.
  esplits; eauto. econs; s; eauto.
  apply TViewFacts.write_tview_mon; try apply LOCAL1; eauto. apply WF1_TGT.
Qed.

Lemma sim_local_update
      pview
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt
      lc3_tgt sc3_tgt mem3_tgt
      loc ts1 val1 released1_tgt ord1_src ord1_tgt
      from2 to2 val2 released2_tgt ord2_src ord2_tgt kind
      (STEP1_TGT: Local.read_step lc1_tgt mem1_tgt loc ts1 val1 released1_tgt ord1_tgt lc2_tgt)
      (STEP2_TGT: Local.write_step lc2_tgt sc1_tgt mem1_tgt loc from2 to2 val2 released1_tgt released2_tgt ord2_tgt lc3_tgt sc3_tgt mem3_tgt kind)
      (LOCAL1: sim_local pview lc1_src lc1_tgt)
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC1_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt)
      (ORD1: Ordering.le ord1_src ord1_tgt)
      (ORD2: Ordering.le ord2_src ord2_tgt)
      (PVIEW: SimPromises.mem loc to2 pview = false \/
              Ordering.le ord2_tgt Ordering.plain \/
              Ordering.le Ordering.strong_relaxed ord2_tgt):
  exists released1_src released2_src lc2_src lc3_src sc3_src mem3_src,
    <<REL1: View.opt_le released1_src released1_tgt>> /\
    <<REL2: View.opt_le released2_src released2_tgt>> /\
    <<STEP1_SRC: Local.read_step lc1_src mem1_src loc ts1 val1 released1_src ord1_src lc2_src>> /\
    <<STEP2_SRC: Local.write_step lc2_src sc1_src mem1_src loc from2 to2 val2 released1_src released2_src ord2_src lc3_src sc3_src mem3_src
                                  (SimPromises.kind_transf loc to2 pview kind)>> /\
    <<LOCAL3: sim_local (SimPromises.unset loc to2 pview) lc3_src lc3_tgt>> /\
    <<SC3: TimeMap.le sc3_src sc3_tgt>> /\
    <<MEM3: sim_memory mem3_src mem3_tgt>>.
Proof.
  guardH PVIEW.
  exploit Local.read_step_future; eauto. i. des.
  exploit sim_local_read; eauto. i. des.
  exploit Local.read_step_future; eauto. i. des.
  hexploit sim_local_write; eauto. i. des.
  esplits; eauto.
Qed.

Lemma sim_local_update_bot
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt
      lc3_tgt sc3_tgt mem3_tgt
      loc ts1 val1 released1_tgt ord1_src ord1_tgt
      from2 to2 val2 released2_tgt ord2_src ord2_tgt kind
      (STEP1_TGT: Local.read_step lc1_tgt mem1_tgt loc ts1 val1 released1_tgt ord1_tgt lc2_tgt)
      (STEP2_TGT: Local.write_step lc2_tgt sc1_tgt mem1_tgt loc from2 to2 val2 released1_tgt released2_tgt ord2_tgt lc3_tgt sc3_tgt mem3_tgt kind)
      (LOCAL1: sim_local SimPromises.bot lc1_src lc1_tgt)
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC1_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt)
      (ORD1: Ordering.le ord1_src ord1_tgt)
      (ORD2: Ordering.le ord2_src ord2_tgt):
  exists released1_src released2_src lc2_src lc3_src sc3_src mem3_src,
    <<REL1: View.opt_le released1_src released1_tgt>> /\
    <<REL2: View.opt_le released2_src released2_tgt>> /\
    <<STEP1_SRC: Local.read_step lc1_src mem1_src loc ts1 val1 released1_src ord1_src lc2_src>> /\
    <<STEP2_SRC: Local.write_step lc2_src sc1_src mem1_src loc from2 to2 val2 released1_src released2_src ord2_src lc3_src sc3_src mem3_src kind>> /\
    <<LOCAL3: sim_local SimPromises.bot lc3_src lc3_tgt>> /\
    <<SC3: TimeMap.le sc3_src sc3_tgt>> /\
    <<MEM3: sim_memory mem3_src mem3_tgt>>.
Proof.
  exploit Local.read_step_future; eauto. i. des.
  exploit sim_local_read; eauto. i. des.
  exploit Local.read_step_future; eauto. i. des.
  hexploit sim_local_write_bot; eauto. i. des.
  esplits; eauto.
Qed.

Lemma sim_local_fence
      pview
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt sc2_tgt
      ordr_src ordw_src
      ordr_tgt ordw_tgt
      (STEP_TGT: Local.fence_step lc1_tgt sc1_tgt ordr_tgt ordw_tgt lc2_tgt sc2_tgt)
      (LOCAL1: sim_local pview lc1_src lc1_tgt)
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (ORDR: Ordering.le ordr_src ordr_tgt)
      (ORDW: Ordering.le ordw_src ordw_tgt):
  exists lc2_src sc2_src,
    <<STEP_SRC: Local.fence_step lc1_src sc1_src ordr_src ordw_src lc2_src sc2_src>> /\
    <<LOCAL2: sim_local pview lc2_src lc2_tgt>> /\
    <<SC2: TimeMap.le sc2_src sc2_tgt>>.
Proof.
  inv STEP_TGT. esplits; eauto.
  - econs; eauto. i. eapply sim_local_nonsynch; eauto.
    i. eapply sim_local_memory_bot; eauto. eapply PROMISES.
    subst. destruct ordw_tgt; ss.
  - econs; try apply LOCAL1. s.
    apply TViewFacts.write_fence_tview_mon; auto; try refl.
    apply TViewFacts.read_fence_tview_mon; auto; try refl.
    + apply LOCAL1.
    + apply WF1_TGT.
    + eapply TViewFacts.read_fence_future; apply WF1_SRC.
  - apply TViewFacts.write_fence_sc_mon; auto; try refl.
    apply TViewFacts.read_fence_tview_mon; auto; try refl.
    + apply LOCAL1.
    + apply WF1_TGT.
Qed.

Lemma sim_local_promise_consistent
      pview
      lc_src lc_tgt
      (LOCAL: sim_local pview lc_src lc_tgt)
      (CONS_TGT: Local.promise_consistent lc_tgt):
  <<CONS_SRC: Local.promise_consistent lc_src>>.
Proof.
  inv LOCAL. inv PROMISES. ii.
  destruct (Memory.get loc ts (Local.promises lc_tgt)) as [[]|] eqn:GETP.
  - exploit LE; eauto. intros x. rewrite PROMISE in x. inv x.
    destruct (classic (t0 = Message.reserve)); subst; ss.
    exploit CONS_TGT; eauto; ss. i.
    eapply TimeFacts.le_lt_lt; eauto.
    inv TVIEW. inv CUR. eauto.
  - exploit COMPLETE; eauto. intros x.
    rewrite MemoryDomain.bot_spec in x. ss.
Qed.

Lemma sim_local_failure
      pview
      lc1_src lc1_tgt
      (STEP_TGT: Local.failure_step lc1_tgt)
      (LOCAL1: sim_local pview lc1_src lc1_tgt):
  <<STEP_SRC: Local.failure_step lc1_src>>.
Proof.
  inv STEP_TGT.
  hexploit sim_local_promise_consistent; eauto.
Qed.

Lemma sim_local_is_racy
      pview
      lc1_src mem1_src
      lc1_tgt mem1_tgt
      loc to ord_src ord_tgt
      (RACE_TGT: Local.is_racy lc1_tgt mem1_tgt loc to ord_tgt)
      (LOCAL1: sim_local pview lc1_src lc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (ORD: Ordering.le ord_src ord_tgt):
  <<RACE_SRC: Local.is_racy lc1_src mem1_src loc to ord_src>>.
Proof.
  inv RACE_TGT.
  exploit sim_memory_get; eauto. i. des.
  exploit SimPromises.get_None; [apply LOCAL1|..]; eauto. i. des.
  econs; eauto.
  - eapply TViewFacts.racy_view_mon; eauto. apply LOCAL1.
  - inv MSG; ss.
  - i. exploit MSG2; try by destruct ord_src, ord_tgt; inv ORD.
    i. subst. inv MSG. ss.
Qed.

Lemma sim_local_racy_read
      pview
      lc1_src mem1_src
      lc1_tgt mem1_tgt
      loc to val ord_src ord_tgt
      (STEP_TGT: Local.racy_read_step lc1_tgt mem1_tgt loc to val ord_tgt)
      (LOCAL1: sim_local pview lc1_src lc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (ORD: Ordering.le ord_src ord_tgt):
  <<STEP_SRC: Local.racy_read_step lc1_src mem1_src loc to val ord_src>>.
Proof.
  inv STEP_TGT.
  exploit sim_local_is_racy; eauto.
Qed.

Lemma sim_local_racy_write
      pview
      lc1_src mem1_src
      lc1_tgt mem1_tgt
      loc to ord_src ord_tgt
      (STEP_TGT: Local.racy_write_step lc1_tgt mem1_tgt loc to ord_tgt)
      (LOCAL1: sim_local pview lc1_src lc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (ORD: Ordering.le ord_src ord_tgt):
  <<STEP_SRC: Local.racy_write_step lc1_src mem1_src loc to ord_src>>.
Proof.
  inv STEP_TGT.
  exploit sim_local_is_racy; eauto. i. des.
  hexploit sim_local_promise_consistent; eauto.
Qed.

Lemma sim_local_racy_update
      pview
      lc1_src mem1_src
      lc1_tgt mem1_tgt
      loc to ordr_src ordw_src ordr_tgt ordw_tgt
      (STEP_TGT: Local.racy_update_step lc1_tgt mem1_tgt loc to ordr_tgt ordw_tgt)
      (LOCAL1: sim_local pview lc1_src lc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (ORDR: Ordering.le ordr_src ordr_tgt)
      (ORDW: Ordering.le ordw_src ordw_tgt):
  <<STEP_SRC: Local.racy_update_step lc1_src mem1_src loc to ordr_src ordw_src>>.
Proof.
  inv STEP_TGT; try by hexploit sim_local_promise_consistent; eauto.
  exploit sim_local_is_racy; eauto. i. des.
  hexploit sim_local_promise_consistent; eauto.
Qed.

Lemma sim_local_program_step
      lang
      th1_src
      th1_tgt th2_tgt e_tgt
      (STEP_TGT: @Thread.program_step lang e_tgt th1_tgt th2_tgt)
      (WF1_SRC: Local.wf (Thread.local th1_src) (Thread.memory th1_src))
      (WF1_TGT: Local.wf (Thread.local th1_tgt) (Thread.memory th1_tgt))
      (SC1_SRC: Memory.closed_timemap (Thread.sc th1_src) (Thread.memory th1_src))
      (SC1_TGT: Memory.closed_timemap (Thread.sc th1_tgt) (Thread.memory th1_tgt))
      (MEM1_SRC: Memory.closed (Thread.memory th1_src))
      (MEM1_TGT: Memory.closed (Thread.memory th1_tgt))
      (STATE: (Thread.state th1_src) = (Thread.state th1_tgt))
      (LOCAL: sim_local SimPromises.bot (Thread.local th1_src) (Thread.local th1_tgt))
      (SC: TimeMap.le (Thread.sc th1_src) (Thread.sc th1_tgt))
      (MEM: sim_memory (Thread.memory th1_src) (Thread.memory th1_tgt)):
  exists e_src th2_src,
    <<STEP_SRC: @Thread.program_step lang e_src th1_src th2_src>> /\
    <<EVENT: ThreadEvent.get_machine_event e_src = ThreadEvent.get_machine_event e_tgt>> /\
    <<STATE: (Thread.state th2_src) = (Thread.state th2_tgt)>> /\
    <<LOCAL: sim_local SimPromises.bot (Thread.local th2_src) (Thread.local th2_tgt)>> /\
    <<SC: TimeMap.le (Thread.sc th2_src) (Thread.sc th2_tgt)>> /\
    <<MEM: sim_memory (Thread.memory th2_src) (Thread.memory th2_tgt)>>.
Proof.
  destruct th1_src. ss. subst. inv STEP_TGT; ss.
  inv LOCAL0; ss.
  - esplits; (try by econs; [|econs 1]; eauto); ss.
  - exploit sim_local_read; eauto; try refl. i. des.
    esplits; (try by econs; [|econs 2]; eauto); ss.
  - hexploit sim_local_write_bot; eauto; try refl; try by viewtac. i. des.
    esplits; (try by econs; [|econs 3]; eauto); ss.
  - exploit Local.read_step_future; eauto. i. des.
    exploit sim_local_read; eauto; try refl. i. des.
    exploit Local.read_step_future; eauto. i. des.
    hexploit sim_local_write_bot; eauto; try refl; try by viewtac. i. des.
    esplits; (try by econs; [|econs 4]; eauto); ss.
  - exploit sim_local_fence; eauto; try refl. i. des.
    esplits; (try by econs; [|econs 5]; eauto); ss.
  - exploit sim_local_fence; eauto; try refl. i. des.
    esplits; (try by econs; [|econs 6]; eauto); ss.
  - exploit sim_local_failure; eauto. i. des.
    esplits; (try by econs; [|econs 7]; eauto); ss.
  - exploit sim_local_write_na; eauto; try refl. i. des.
    esplits; (try by econs; [|econs 8]; eauto); ss.
  - exploit sim_local_racy_read; eauto; try refl. i. des.
    esplits; (try by econs; [|econs 9]; eauto); ss.
  - exploit sim_local_racy_write; eauto; try refl. i. des.
    esplits; (try by econs; [|econs 10]; eauto); ss.
  - exploit sim_local_racy_update; eauto; try refl. i. des.
    esplits; (try by econs; [|econs 11]; eauto); ss.
Qed.

Lemma sim_local_lower_src
      pview1
      lc1_src sc1_src mem1_src
      lc1_tgt mem1_tgt
      lc2_src mem2_src
      loc from to val released
      (LOCAL1: sim_local pview1 lc1_src lc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (MEM1_SRC: Memory.closed mem1_src)
      (STEP_SRC: Local.promise_step lc1_src mem1_src loc from to (Message.concrete val None) lc2_src mem2_src (Memory.op_kind_lower (Message.concrete val released))):
  <<LOCAL2: exists pview2, sim_local pview2 lc2_src lc1_tgt>> /\
  <<MEM2: sim_memory mem2_src mem1_tgt>> /\
  <<WF2_SRC: Local.wf lc2_src mem2_src>>.
Proof.
  splits.
  - inv STEP_SRC. inv PROMISE.
    exists (match Memory.get loc to (Local.promises lc1_tgt) with
       | Some _ => SimPromises.set loc to pview1
       | None => pview1
       end).
    inv LOCAL1. econs; ss. inv PROMISES0. econs; ss.
    + ii.
      exploit LE; eauto. intros x.
      exploit Memory.lower_get0; try exact PROMISES; eauto. i.
      erewrite Memory.lower_o; eauto.
      unfold SimPromises.none_if, SimPromises.none_if_released.
      destruct (Memory.get loc to (Local.promises lc1_tgt)) eqn:TGT.
      * rewrite SimPromises.set_o. condtac; ss.
        { des. subst. condtac; ss; cycle 1.
          { revert COND0. condtac; ss. des; congr. }
          rewrite GET in x. inv x. destruct msg; ss. inv H1; ss.
        }
        { guardH o. condtac.
          { revert COND0. condtac; ss.
            { des. subst. unguardH o. des; congr. }
            guardH o0. i.
            rewrite x. repeat f_equal. SimPromises.none_if_tac.
          }
          rewrite x. repeat f_equal. SimPromises.none_if_tac.
          revert COND0. condtac; ss.
        }
      * condtac; ss. des. subst. congr.
    + i. revert MEM0. condtac; ss; cycle 1.
      { eapply PVIEW. }
      rewrite SimPromises.set_o. condtac; ss; cycle 1.
      { eapply PVIEW. }
      i. des. subst. destruct p.
      exploit LE; eauto. ss. i.
      exploit Memory.lower_get0; try exact PROMISES; eauto. i. des.
      destruct t0; ss; try congr; eauto.
    + i. revert SRC. erewrite Memory.lower_o; eauto. condtac; ss.
      * i. des. inv SRC. eapply COMPLETE; eauto.
        hexploit Memory.lower_get0; try exact PROMISES; eauto. i. des. eauto.
      * i. eapply COMPLETE; eauto.
  - etrans; [|eauto]. inv STEP_SRC. inv PROMISE. eapply lower_sim_memory; eauto.
  - eapply Local.promise_step_future; eauto.
Qed.

Lemma sim_local_nonsynch_src
      pview
      lang st sc
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      (LOCAL1: sim_local pview lc1_src lc1_tgt)
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (LOCAL1_SRC: Local.wf lc1_src mem1_src)
      (LOCAL2_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists pview2 lc2_src mem2_src,
    <<STEP_SRC: rtc (@Thread.tau_step lang)
                    (Thread.mk lang st lc1_src sc mem1_src)
                    (Thread.mk lang st lc2_src sc mem2_src)>> /\
    <<NONSYNCH2: Memory.nonsynch (Local.promises lc2_src)>> /\
    <<LOCAL2: sim_local pview2 lc2_src lc1_tgt>> /\
    <<MEM2: sim_memory mem2_src mem1_tgt>>.
Proof.
  inversion LOCAL1_SRC.
  destruct FINITE. rename x into dom.
  assert (FINITE' : forall (loc : Loc.t) (from to : Time.t) (msg : Message.t),
             Memory.get loc to (Local.promises lc1_src) = Some (from, msg) ->
             (match msg with
              | Message.concrete _ (Some _) => True
              | _ => False
              end) ->
             In (loc, to) dom).
  { ii. eapply H. eauto. }
  clear H. move dom after lc1_src. revert_until dom. revert pview.
  induction dom.
  { esplits; eauto. ii. destruct msg; ss. destruct released; ss.
    exfalso. eapply FINITE'; eauto. ss.
  }
  destruct a as [loc to]. i.
  destruct (Memory.get loc to (Local.promises lc1_src)) as [[? []]|] eqn:X; cycle 1.
  { eapply IHdom; eauto. i. exploit FINITE'; eauto. intros x. inv x; ss.
    inv H1. rewrite X in H. inv H. inv H0. }
  { eapply IHdom; eauto. i. exploit FINITE'; eauto. intros x. inv x; ss.
    inv H1. rewrite X in H. inv H. inv H0. }
  { eapply IHdom; eauto. i. exploit FINITE'; eauto. intros x. inv x; ss.
    inv H1. congr. }
  destruct released; cycle 1.
  { eapply IHdom; eauto. i. exploit FINITE'; eauto. intros x. inv x; ss.
    inv H1. rewrite H in X. inv X. ss. }
  exploit MemoryFacts.promise_exists_None; eauto.
  { eapply MemoryFacts.released_time_lt; [by apply MEM1_SRC|]. apply LOCAL1_SRC. eauto. }
  i. des.
  exploit Memory.promise_future; try exact x0; try apply LOCAL1_SRC; eauto. i. des.
  exploit sim_local_lower_src; eauto. i. des.
  exploit IHdom; eauto.
  { eapply Memory.future_closed_timemap; eauto. }
  { eapply TView.future_closed; eauto. }
  { s. i. inv x0. revert H.
    erewrite Memory.lower_o; eauto. condtac; ss.
    - i. des. inv H. ss.
    - guardH o. i. exploit FINITE'; eauto. intros x. des; ss. inv x.
      unguardH o. des; congr.
  }
  i. des. esplits; try exact NONSYNCH2; eauto.
  econs 2; eauto. econs.
  - econs. econs 1. econs; eauto.
  - ss.
Qed.


Require Import erasure.
Require Import IndependenceCommon.

Theorem newFastForward : forall H T H' T' TID x M' E s2 d s1' p M,
         heap_lookup x H = None -> decompose M' E new ->
         spec_multistep H (tUnion T (tSingleton(TID,unlocked nil,s2,M'))) H'
                        (tUnion T' (tSingleton(TID,unlocked(s1'++[nAct M' E d x]),s2,M))) ->
         exists H'' T'',
           spec_multistep H (tUnion T (tSingleton(TID,unlocked nil,s2,M'))) H''
                         (tUnion T'' (tSingleton(TID,unlocked [nAct M' E d x],s2,fill E (ret (fvar x))))) /\
           spec_multistep H'' (tUnion T'' (tSingleton(TID,unlocked [nAct M' E d x],s2,fill E (ret (fvar x)))))
                          H' (tUnion T' (tSingleton(TID,unlocked(s1'++[nAct M' E d x]),s2,M)))  /\
           spec_multistep (Heap.extend x (sempty COMMIT) H p) T
                          (replace x (sempty COMMIT) H'') T'' /\
           heap_lookup x H'' = Some(sempty SPEC).
Proof.
  intros. dependent induction H2.
  {apply UnionEqTID in x. invertHyp. inv H2. invertListNeq. }
  {startIndCase. destructThread x1. exMid TID H9.
   {apply UnionEqTID in H5. invertHyp. econstructor. exists T. split. econstructor.
    eapply SNew with (x:=x0)(p:=p). eauto. simpl. constructor.
    split. inv H3;try solve[falseDecomp].
    {inv H14; falseDecomp. }
    {simpl in *. copy H2. firstActTac H2. inv H2. proofsEq d d0. proofsEq p p0. eassumption. }
    split. erewrite replaceExtendOverwrite. constructor. rewrite lookupExtend. auto.
   }
   {apply UnionNeqTID in x. invertHyp. copy H3. eapply specStepNoneIVar in H3; eauto.
    Focus 3. solveSet. Focus 2. rewrite H4. solveSet. left. invUnion. right. simpl; auto.
    Focus 2. auto. eapply IHspec_multistep with(p:=H3)in H1. Focus 2. eassumption.
    Focus 2. auto. Focus 3. auto. invertHyp. exists x. exists x1. split. rewrite H11.
    unfoldTac. rewrite UnionSwap. econstructor. eapply specStepChangeUnused. eauto.
    unfoldTac. rewrite <- UnionSwap. eassumption. split. eassumption. split.
    rewrite H11. clear H11 H4. inv H12.
    {econstructor. eapply SBasicStep; eauto. proofsEq p H3. eassumption. }
    {econstructor. eapply SFork. auto. proofsEq p H3. eauto. }
    {destruct (beq_nat x2 x0) eqn:eq. apply beq_nat_true in eq. subst. rewrite H0 in H23.
     inv H23. apply beq_nat_false in eq. econstructor. eapply SGet with(x:=x2); auto.
     erewrite lookupExtendNeq; eauto. erewrite <- extendReplaceSwitch; eauto. }
    {destruct (beq_nat x2 x0) eqn:eq. apply beq_nat_true in eq. subst.
     rewrite H0 in H23. inv H23. apply beq_nat_false in eq. econstructor. eapply SPut with(x:=x2).
     erewrite lookupExtendNeq; eauto. auto. erewrite <- extendReplaceSwitch; eauto. }
    {destruct (beq_nat x2 x0)eqn:eq. apply beq_nat_true in eq. subst.
     copy H3. erewrite lookupExtend in H4. inv H4. apply beq_nat_false in eq.
     econstructor. eapply SNew with(x:=x2). auto. erewrite extendExtendSwitch. eassumption. }
    {econstructor. eapply SSpec; eauto. proofsEq p H3. eassumption. }
    auto. rewrite H4. rewrite UnionSubtract. unfoldTac. rewrite UnionSwap; eauto.
   }
  }
  Grab Existential Variables. eapply lookupExtendNeq; eauto.
Qed.

Theorem stepReplaceEmpty : forall H T t H' t' x,
                             heap_lookup x H = Some(sempty SPEC) ->
                             heap_lookup x H' = Some(sempty SPEC) ->
                             spec_step H T t H' T t' ->
                             spec_step (replace x (sempty COMMIT) H) T t
                                       (replace x (sempty COMMIT) H') T t'.
Proof.
  intros. inv H2; auto.
  {destruct (beq_nat x0 x) eqn:eq.
   {apply beq_nat_true in eq. subst. rewrite H3 in H0. inv H0. }
   {eapply SGet with(x:=x0). apply beq_nat_false in eq. rewrite lookupReplaceNeq; eauto.
    rewrite lookupReplaceSwitch. auto. apply beq_nat_false in eq. auto. }
  }
  {destruct (beq_nat x0 x) eqn:eq.
   {apply beq_nat_true in eq. subst. erewrite HeapLookupReplace in H1; eauto. inv H1. }
   {apply beq_nat_false in eq. eapply SPut. erewrite lookupReplaceNeq; eauto.
    erewrite lookupReplaceSwitch; eauto. }
  }
  {destruct (beq_nat x0 x) eqn:eq.
   {apply beq_nat_true in eq. subst. copy p. rewrite H2 in H0. inv H0. }
   {apply beq_nat_false in eq. eapply SNew; eauto. erewrite extendReplaceSwitch; eauto. }
  }
  Grab Existential Variables. rewrite lookupReplaceNeq; eauto.
Qed.

Theorem smultiReplaceEmpty : forall H T T' H' x,
                             heap_lookup x H = Some(sempty SPEC) ->
                             heap_lookup x H' = Some(sempty SPEC) ->
                             spec_multistep H T H' T' ->
                             spec_multistep (replace x (sempty COMMIT) H) T
                                       (replace x (sempty COMMIT) H') T'.
Proof.
  intros. induction H2.
  {constructor. }
  {copy H. apply specStepSingleton in H3. invertHyp. copy H.
   eapply specStepEmptyIVar' in H; eauto. eapply stepReplaceEmpty in H3; eauto.
   econstructor. eauto. auto. }
Qed.

Theorem newSimPureStepsEmpty : forall H T H' T' TID x M' E d N N' N'' s2 s1',
       eraseTrm s1' N' N'' ->
       heap_lookup x H = Some(sempty SPEC) ->
       heap_lookup x H' = Some(sempty SPEC)->
       spec_multistep H (tUnion T (tSingleton(TID,unlocked[nAct M' E d x],s2,N))) H'
                      (tUnion T' (tSingleton(TID,unlocked(s1'++[nAct M' E d x]),s2,N'))) ->
       exists H'' T'',
         spec_multistep H (tUnion T (tSingleton(TID,unlocked[nAct M' E d x],s2,N)))
                        H'' (tUnion T'' (tSingleton(TID,unlocked[nAct M' E d x],s2,N''))) /\
         spec_multistep H'' (tUnion T'' (tSingleton(TID,unlocked[nAct M' E d x],s2,N'')))
                        H' (tUnion T' (tSingleton(TID,unlocked(s1'++[nAct M' E d x]),s2,N'))) /\
         spec_multistep (replace x (sempty COMMIT) H) T
                        (replace x (sempty COMMIT)H'') T'' /\
         heap_lookup x H'' = Some(sempty SPEC).
Proof.
  intros. dependent induction H3.
  {apply UnionEqTID in x. invertHyp. inv H. destruct s1'; inv H5; try invertListNeq.
   inv H0; try invertListNeq. repeat econstructor. eauto. }
  {startIndCase. destructThread x1. exMid H10 TID.
   {apply UnionEqTID in x. invertHyp. inversion H4; subst.
    {eapply IHspec_multistep in H1;[idtac|eauto|idtac|auto|auto|auto|auto]; auto.
     invertHyp. econstructor. econstructor. split. econstructor. eapply SBasicStep; eauto.
     eassumption. split; auto. }
    {copy H3. nonEmptyStackTac H3. invertHyp. apply eraseTrmApp in H0. inv H0.
     do 4 econstructor. simpl in *. econstructor. eapply SFork; eauto. eassumption.
     split. constructor. auto. }
    {copy H3. nonEmptyStackTac H3. invertHyp. apply eraseTrmApp in H0. inv H0.
     do 4 econstructor. simpl in *. destruct (beq_nat x x0) eqn:eq. apply beq_nat_true in eq.
     subst. rewrite H15 in H1. inv H1. apply beq_nat_false in eq. econstructor.
     eapply SGet with(x:=x); eauto. simpl in *. eassumption. split. constructor. auto. }
    {copy H3. nonEmptyStackTac H3. invertHyp. apply eraseTrmApp in H0. inv H0.
     do 4 econstructor. simpl in *. destruct (beq_nat x x0) eqn:eq. apply beq_nat_true in eq.
     subst. eapply smultiEmptyFull in H5. Focus 3. eauto. Focus 2. rewrite H15 in H1.
     inv H1. erewrite HeapLookupReplace; eauto. contradiction.
     apply beq_nat_false in eq. econstructor. eapply SPut with(x:=x); eauto. simpl in *.
     eassumption. split. constructor. auto. }
    {copy H3. nonEmptyStackTac H3. invertHyp. apply eraseTrmApp in H0. inv H0.
     do 4 econstructor. simpl in *. destruct (beq_nat x x0) eqn:eq. apply beq_nat_true in eq.
     subst. copy p. rewrite H0 in H1. inv H1. apply beq_nat_false in eq. econstructor.
     eapply SNew with(x:=x); eauto. simpl in *. eassumption. split. constructor. auto. }
    {copy H3. nonEmptyStackTac H3. invertHyp. apply eraseTrmApp in H0. inv H0.
     do 4 econstructor. econstructor. eapply SSpec; eauto. simpl in *. eassumption.
     split. constructor. auto. }
   }
   {apply UnionNeqTID in x; auto. invertHyp. copy H4. eapply specStepEmptyIVar' in H4; eauto. copy H4.
    eapply IHspec_multistep in H4;[idtac|eauto|idtac|auto|idtac|auto|auto].
    Focus 2. auto. invertHyp. econstructor. econstructor. split. rewrite H12.
    unfoldTac. rewrite UnionSwap. econstructor. eapply specStepChangeUnused; eauto.
    unfoldTac. rewrite UnionSwap. eauto. split; auto. split. rewrite H12.
    econstructor. eapply stepReplaceEmpty. eauto. eapply H14.  eapply specStepChangeUnused; eauto.
    eauto. eauto. rewrite H5. rewrite UnionSubtract. unfoldTac. rewrite UnionSwap; eauto. }
  }
Qed.

Theorem newSimActionStepsEmpty : forall H T H' T' TID x M' E d N N' H'' T'' N'' s2 s1 s1' a,
       eraseTrm (s1'++[a]) N' N'' ->
       heap_lookup x H = Some(sempty SPEC) ->
       heap_lookup x H' = Some(sempty SPEC) ->
       spec_multistep H'' (tUnion T'' (tSingleton(TID,unlocked [nAct M' E d x],s2,N'')))
                      H (tUnion T (tSingleton(TID,unlocked(s1++[nAct M' E d x]),s2,N))) ->
       spec_multistep H (tUnion T (tSingleton(TID,unlocked(s1++[nAct M' E d x]),s2,N))) H'
                      (tUnion T' (tSingleton(TID,unlocked(s1'++[a]++[nAct M' E d x]),s2,N'))) ->
       spec_multistep (replace x (sempty COMMIT) H)
                      (tUnion T (tSingleton(TID,unlocked s1,nAct M' E d x::s2,N)))
                      (replace x (sempty COMMIT) H')
                      (tUnion T' (tSingleton(TID,unlocked (s1'++[a]), nAct M' E d x::s2,N'))).
Proof.
  intros. dependent induction H4; intros.
  {apply UnionEqTID in x. invertHyp. inv H.
   replace[a;nAct M' E d x0] with ([a]++[nAct M' E d x0]) in H6; auto.
   rewrite app_assoc in H6. apply app_inj_tail in H6. invertHyp. rewrite H2 in H1.
   inv H1. constructor. }
  {startIndCase. destructThread x1. exMid H11 TID.
   {apply UnionEqTID in x. invertHyp. inv H7. copy H5. eapply specStepEmptyIVar' in H5; eauto.
    inversion H6; subst.
    {copy H3. eapply stackNonNil in H3; eauto. destruct s1. exfalso. apply H3. auto.
     econstructor. eapply SBasicStep; eauto. constructor. eapply IHspec_multistep; eauto.
     eapply spec_multi_trans. eauto. econstructor. eapply SBasicStep; eauto. constructor.
     intros c. subst. apply eraseTrmApp in H0. inv H0; inv H16; falseDecomp. }
    {econstructor. eapply SFork; eauto. simpl. unfoldTac. rewrite coupleUnion.
     rewrite Union_associative. rewrite UnionSwap. eapply IHspec_multistep; eauto.
     Focus 2. rewrite <- Union_associative. rewrite <- coupleUnion. rewrite couple_swap.
     unfold numForks. simpl. simpl. eauto. rewrite numForksDistribute. simpl. rewrite <- plus_assoc.
     rewrite <- plus_comm. simpl. rewrite plus_comm. reflexivity. eapply spec_multi_trans.
     eassumption. econstructor. eapply SFork; eauto. rewrite <- Union_associative. rewrite <- coupleUnion.
     rewrite couple_swap. simpl. rewrite numForksDistribute. simpl. rewrite <- plus_assoc.
     rewrite plus_comm. simpl. rewrite plus_comm. constructor. }
    {destruct(beq_nat x x0) eqn:eq.
     {apply beq_nat_true in eq. subst. heapsDisagree. }
     {apply beq_nat_false in eq. apply neqSym in eq. lookupTac.
      eapply IHspec_multistep in H7;[idtac|eauto|idtac|auto|auto|auto|auto|auto]; auto.
      econstructor. eapply SGet with(x:=x); auto. rewrite lookupReplaceNeq; eauto.
      rewrite lookupReplaceSwitch; auto. eassumption. eapply spec_multi_trans. eassumption.
      econstructor. eapply SGet with(x:=x); eauto. constructor. simpl. eauto. }
    }
    {destruct (beq_nat x x0) eqn:eq. apply beq_nat_true in eq. subst. rewrite H16 in H1.
     inv H1. eapply smultiEmptyFull in H4; eauto. contradiction. erewrite HeapLookupReplace; eauto.
     apply beq_nat_false in eq. apply neqSym in eq. lookupTac.
     eapply IHspec_multistep in H7;[idtac|eauto|idtac|auto|auto|auto|auto|auto]; auto.
     econstructor. eapply SPut with(x:=x).
     rewrite lookupReplaceNeq; eauto. auto. rewrite lookupReplaceSwitch; auto. simpl.
     eassumption. eapply spec_multi_trans. eassumption. econstructor. eapply SPut with(x:=x).
     eauto. auto. constructor. simpl. reflexivity. }
    {destruct (beq_nat x x0) eqn:eq. apply beq_nat_true in eq. subst. copy p. rewrite H7 in H1.
     inv H1. apply beq_nat_false in eq. apply neqSym in eq. lookupTac.
     eapply IHspec_multistep in H7;[idtac|eauto|idtac|auto|auto|auto|auto|auto]; auto.
     econstructor. eapply SNew with(x:=x).
     auto. erewrite extendReplaceSwitch; eauto. eapply spec_multi_trans. eassumption.
     econstructor. eapply SNew with(x:=x); eauto. constructor. simpl. auto. }
    {econstructor. eapply SSpec; eauto. unfoldTac. rewrite coupleUnion. rewrite Union_associative.
     rewrite <- UnionSwap. eapply IHspec_multistep; eauto. Focus 2. rewrite <- Union_associative.
     rewrite <- coupleUnion.  rewrite couple_swap. reflexivity. eapply spec_multi_trans.
     eassumption. econstructor. eapply SSpec; eauto. rewrite <- Union_associative. rewrite <- coupleUnion.
     rewrite couple_swap. constructor. }
   }
   {apply UnionNeqTID in x; auto. invertHyp.  copy H5. eapply specStepEmptyIVar' in H5; eauto.
    copy H5. eapply IHspec_multistep in H5;[idtac|eauto|idtac|auto|auto|auto|auto|auto]; auto.
    rewrite H13. unfoldTac. rewrite UnionSwap. econstructor. eapply stepReplaceEmpty. eauto.
    eapply H15. eapply specStepChangeUnused; eauto. unfoldTac. rewrite UnionSwap; eauto.
    eapply spec_multi_trans. eassumption. rewrite H13. unfoldTac. rewrite UnionSwap.
    econstructor. eapply specStepChangeUnused; eauto. unfoldTac. rewrite UnionSwap. constructor.
    rewrite H6. rewrite UnionSubtract. unfoldTac. rewrite UnionSwap; eauto. }
  }
  Grab Existential Variables. rewrite lookupReplaceNeq; eauto.
Qed.

Theorem smultiFullIVar : forall T' x H H' ds tid M T S sc,
         spec_multistep H T H' T' ->
         heap_lookup x H = Some(sfull sc ds S tid M) ->
         exists ds', heap_lookup x H' =
                     Some(sfull sc ds' S tid M).
Proof.
  intros. genDeps{sc; ds; S; tid; M}. induction H0; intros.
  {eauto. }
  {eapply specStepFullIVar in H; eauto. invertHyp. eauto. }
Qed.

Theorem specStepEmptyIVarOr : forall x H H' H'' T T' t t' s s' ds M t0,
                              heap_lookup x H = Some(sempty s) ->
                              spec_step H T (tSingleton t) H' T t' ->
                              spec_multistep H' (tUnion T t') H'' T' ->
                              heap_lookup x H'' = Some(sfull s ds s' t0 M) ->
                              (heap_lookup x H' = Some(sempty s) \/
                               exists ds', heap_lookup x H' = Some(sfull s ds' s' t0 M)).
Proof.
  intros. inversion H1; subst; eauto.
  {destruct (beq_nat x x0)eqn:eq.
   {apply beq_nat_true in eq. subst. rewrite H5 in H0. inv H0. }
   {apply beq_nat_false in eq. rewrite lookupReplaceNeq; eauto. }
  }
  {destruct (beq_nat x x0)eqn:eq.
   {apply beq_nat_true in eq. subst. rewrite H5 in H0. inv H0.
    eapply smultiFullIVar in H2; eauto. Focus 2. erewrite HeapLookupReplace; eauto.
    invertHyp. rewrite H3 in H0. inv H0. right. exists nil. erewrite HeapLookupReplace; eauto. }
   {apply beq_nat_false in eq. rewrite lookupReplaceNeq; eauto. }
  }
  { destruct (beq_nat x x0)eqn:eq.
   {apply beq_nat_true in eq. subst. copy p. rewrite H4 in H0. inv H0. }
   {apply beq_nat_false in eq. left. apply lookupExtendNeq; auto. }
  }
Qed.

Theorem stepReplaceSpecFull : forall H T H' t t' ds ds' x M' TID,
                   heap_lookup x H = Some(sfull SPEC ds SPEC TID M') ->
                   heap_lookup x H' = Some(sfull SPEC ds' SPEC TID M') ->
                   spec_step H T t H' T t' ->
                   spec_step (replace x (sfull COMMIT ds SPEC TID M') H) T t
                                  (replace x (sfull COMMIT ds' SPEC TID M') H') T t'.
Proof.
  intros. inv H2.
  {rewrite H0 in H1. inv H1. eauto. }
  {rewrite H0 in H1. inv H1; eauto. }
  {varsEq x x0. rewrite H0 in H3. inv H3. erewrite HeapLookupReplace in H1; eauto. inv H1.
   eapply SGet; eauto. erewrite HeapLookupReplace; eauto. repeat rewrite replaceOverwrite.
   auto. eapply SGet; eauto. rewrite lookupReplaceNeq; eauto. rewrite lookupReplaceSwitch; eauto.
   erewrite lookupReplaceNeq in H1; eauto. rewrite H0 in H1. inv H1. auto. }
  {varsEq x x0. heapsDisagree. rewrite lookupReplaceNeq in H1; eauto. rewrite H1 in H0.
   inv H0. eapply SPut; eauto. rewrite lookupReplaceNeq; eauto.
   rewrite lookupReplaceSwitch; eauto. }
  {varsEq x x0. heapsDisagree. eapply SNew; eauto. erewrite extendReplaceSwitch; eauto.
   erewrite lookupExtendNeq in H1; eauto. inv H1. auto. }
  {rewrite H0 in H1; inv H1; eauto. }
  Grab Existential Variables. rewrite lookupReplaceNeq; eauto.
Qed.

Theorem smultiReplaceSpecFull : forall H T H' T' ds ds' x M' TID,
                   heap_lookup x H = Some(sfull SPEC ds SPEC TID M') ->
                   heap_lookup x H' = Some(sfull SPEC ds' SPEC TID M') ->
                   spec_multistep H T H' T' ->
                   spec_multistep (replace x (sfull COMMIT ds SPEC TID M') H) T
                                  (replace x (sfull COMMIT ds' SPEC TID M') H') T'.
Proof.
  intros. genDeps{ds; ds'}. induction H2; intros.
  {rewrite H1 in H0. inv H0. constructor. }
  {copy H. eapply specStepFullIVar in H; eauto. invertHyp.
   eapply stepReplaceSpecFull in H3; eauto. econstructor. eassumption.
   eapply IHspec_multistep; eauto. }
Qed.

Theorem subtractSingle' : forall (A:Type) (x:A) T,
                            In A T x ->
                            Union A (Subtract A T x) (Single A x) = T.
Proof.
  induction T; intros.
  {inversion H. }
  {inversion H; subst.
   {simpl. destruct (classicT(x=x)).
    {rewrite Union_commutative. simpl. auto. }
    {simpl. rewrite IHT; eauto. inversion H. contradiction. auto. }
   }
   {simpl. destruct (classicT(a=x)).
    {subst. rewrite Union_commutative. simpl. auto. }
    {simpl. rewrite IHT; eauto. }
   }
  }
Qed.

Theorem newSimPureStepsFull' : forall H T H' T' TID x M' E d M'' t0 ds ds' N N' N'' s2 s1',
       eraseTrm s1' N' N'' ->
       heap_lookup x H = Some(sfull SPEC ds SPEC t0 M'') ->
       heap_lookup x H' = Some(sfull SPEC ds' SPEC t0 M'')->
       spec_multistep H (tUnion T (tSingleton(TID,unlocked[nAct M' E d x],s2,N))) H'
                      (tUnion T' (tSingleton(TID,unlocked(s1'++[nAct M' E d x]),s2,N'))) ->
       exists H'' T'',
         spec_multistep H (tUnion T (tSingleton(TID,unlocked[nAct M' E d x],s2,N)))
                        H'' (tUnion T'' (tSingleton(TID,unlocked[nAct M' E d x],s2,N''))) /\
         spec_multistep H'' (tUnion T'' (tSingleton(TID,unlocked[nAct M' E d x],s2,N'')))
                        H' (tUnion T' (tSingleton(TID,unlocked(s1'++[nAct M' E d x]),s2,N'))) /\
         exists ds'',
         spec_multistep (replace x (sfull COMMIT ds SPEC t0 M'') H) T
                        (replace x (sfull COMMIT ds'' SPEC t0 M'')H'') T'' /\
          heap_lookup x H'' = Some(sfull SPEC ds'' SPEC t0 M'').
Proof.
  intros. genDeps{ds; ds'}. dependent induction H3; intros.
  {apply UnionEqTID in x. invertHyp. inv H. destruct s1'; inv H5; try invertListNeq.
   inv H0; try invertListNeq. rewrite H1 in H2. inv H2. do 6 econstructor. constructor.
   eauto. }
  {startIndCase. destructThread x1. exMid TID H10.
   {apply UnionEqTID in x. invertHyp. inversion H1; subst.
    {eapply IHspec_multistep in H4;[idtac|eauto|idtac|eauto|eauto|eauto|eauto]. Focus 2. auto.
     invertHyp. econstructor. econstructor. split. econstructor. eapply SBasicStep; eauto.
     eauto. split; auto. econstructor. split. eauto. eauto. }
    {copy H3. nonEmptyStackTac H3. invertHyp. apply eraseTrmApp in H0. inv H0. do 4 econstructor.
     econstructor. eapply SFork; eauto. eassumption. econstructor. split. constructor. eauto. }
    {copy H3. nonEmptyStackTac H3. invertHyp. apply eraseTrmApp in H0. inv H0. do 4 econstructor.
     econstructor. eapply SGet; eauto. eassumption. econstructor. split. constructor. eauto. }
    {copy H3. nonEmptyStackTac H3. invertHyp. apply eraseTrmApp in H0. inv H0. do 4 econstructor.
     econstructor. eapply SPut; eauto. eassumption. econstructor. split. constructor. eauto. }
    {copy H3. nonEmptyStackTac H3. invertHyp. apply eraseTrmApp in H0. inv H0. do 4 econstructor.
     econstructor. eapply SNew; eauto. eassumption. econstructor. split. constructor. eauto. }
    {copy H3. nonEmptyStackTac H3. invertHyp. apply eraseTrmApp in H0. inv H0. do 4 econstructor.
     econstructor. eapply SSpec; eauto. eassumption. econstructor. split. constructor. eauto. }
   }
   {copy H4. copy H1. eapply specStepFullIVar in H1; eauto. invertHyp.
    apply UnionNeqTID in x. invertHyp. copy H13. eapply IHspec_multistep in H13; eauto.
    invertHyp. econstructor. econstructor. split. takeTStep. eauto. split; auto.
    econstructor. split. Focus 2. eauto. rewrite H14. econstructor.
    eapply stepReplaceSpecFull. eauto. eapply H15. eapply specStepChangeUnused; eauto.
    eauto. rewrite H1. rewrite UnionSubtract. unfoldTac; rewrite UnionSwap; eauto. auto. }
  }
Qed.

Theorem newSimPureStepsFull : forall H T H' T' TID x M' E d M'' t0 ds' N N' N'' s2 s1',
       eraseTrm s1' N' N'' ->
       heap_lookup x H = Some(sempty SPEC) ->
       heap_lookup x H' = Some(sfull SPEC ds' SPEC t0 M'')->
       spec_multistep H (tUnion T (tSingleton(TID,unlocked[nAct M' E d x],s2,N))) H'
                      (tUnion T' (tSingleton(TID,unlocked(s1'++[nAct M' E d x]),s2,N'))) ->
       (exists H'' T'',
         spec_multistep H (tUnion T (tSingleton(TID,unlocked[nAct M' E d x],s2,N)))
                        H'' (tUnion T'' (tSingleton(TID,unlocked[nAct M' E d x],s2,N''))) /\
         spec_multistep H'' (tUnion T'' (tSingleton(TID,unlocked[nAct M' E d x],s2,N'')))
                        H' (tUnion T' (tSingleton(TID,unlocked(s1'++[nAct M' E d x]),s2,N'))) /\
         spec_multistep (replace x (sempty COMMIT) H) T
                        (replace x (sempty COMMIT)H'') T'' /\
          heap_lookup x H'' = Some(sempty SPEC)) \/
       (exists H'' T'' ds'',
         spec_multistep H (tUnion T (tSingleton(TID,unlocked[nAct M' E d x],s2,N)))
                        H'' (tUnion T'' (tSingleton(TID,unlocked[nAct M' E d x],s2,N''))) /\
         spec_multistep H'' (tUnion T'' (tSingleton(TID,unlocked[nAct M' E d x],s2,N'')))
                        H' (tUnion T' (tSingleton(TID,unlocked(s1'++[nAct M' E d x]),s2,N'))) /\
         spec_multistep (replace x (sempty COMMIT) H) T
                        (replace x (sfull COMMIT ds'' SPEC t0 M'')H'') T'' /\
          heap_lookup x H'' = Some(sfull SPEC ds'' SPEC t0 M'')).
Proof.
  intros. dependent induction H3.
  {rewrite H1 in H2. inv H2. }
  {startIndCase. destructThread x1. exMid H10 TID.
   {apply UnionEqTID in x. invertHyp. inversion H4; subst.
    {eapply IHspec_multistep in H1;[idtac|eauto|idtac|auto|auto|auto|auto]. Focus 2. auto.
     inv H1.
     {invertHyp. left. econstructor. econstructor. split. econstructor. eapply SBasicStep; eauto.
      eassumption. split; auto. }
     {right. invertHyp. econstructor. econstructor. econstructor. split. econstructor.
      eapply SBasicStep; eauto. eauto. eauto. }
    }
    {copy H3. nonEmptyStackTac H3. invertHyp. apply eraseTrmApp in H0. inv H0. do 4 econstructor.
     constructor. split. simpl in *. econstructor. eapply SFork; eauto. eassumption.
     split. constructor. eauto. }
    {copy H3. nonEmptyStackTac H3. invertHyp. apply eraseTrmApp in H0. inv H0. do 4 econstructor.
     constructor. split. simpl in *. econstructor. eapply SGet; eauto. eassumption.
     split. constructor. eauto. }
    {copy H3. nonEmptyStackTac H3. invertHyp. apply eraseTrmApp in H0. inv H0. do 4 econstructor.
     constructor. split. simpl in *. econstructor. eapply SPut; eauto. eassumption.
     split. constructor. eauto. }
    {copy H3. nonEmptyStackTac H3. invertHyp. apply eraseTrmApp in H0. inv H0. do 4 econstructor.
     constructor. split. simpl in *. econstructor. eapply SNew; eauto. eassumption.
     split. constructor. eauto. }
    {copy H3. nonEmptyStackTac H3. invertHyp. apply eraseTrmApp in H0. inv H0. do 4 econstructor.
     constructor. split. simpl in *. econstructor. eapply SSpec; eauto. eassumption.
     split. constructor. eauto. }
   }
   {copy H4. eapply specStepEmptyIVarOr in H4; eauto. inv H4.
    {copy H12. eapply IHspec_multistep in H12; eauto. inv H12.
     {apply UnionNeqTID in x. invertHyp. left. econstructor. econstructor.
      split. takeTStep. eassumption. split. assumption. split. rewrite H17. econstructor.
      eapply stepReplaceEmpty. auto. eapply H4. eapply specStepChangeUnused. eauto.
      eauto. eauto. eauto. }
     {apply UnionNeqTID in x; auto. invertHyp. right. econstructor. econstructor. econstructor.
      split. takeTStep. eauto. split; eauto. split. Focus 2. eauto. rewrite H17. clear H15 H17.
      inversion H5; subst.
      {econstructor. eapply SBasicStep; eauto. auto. }
      {econstructor. eapply SFork; eauto. eauto. }
      {varsEq x x0. heapsDisagree. econstructor. eapply SGet; eauto.
       rewrite lookupReplaceNeq; eauto. rewrite lookupReplaceSwitch; eauto. }
      {varsEq x x0. erewrite HeapLookupReplace in H4; eauto. inv H4. econstructor.
       eapply SPut; eauto. rewrite lookupReplaceNeq; eauto. rewrite lookupReplaceSwitch; eauto. }
      {varsEq x x0. heapsDisagree. econstructor. eapply SNew; eauto.
       erewrite extendReplaceSwitch; eauto. }
      {econstructor. eapply SSpec; eauto. eauto. }
     }
     {proveUnionEq x. rewrite UnionSubtract. rewrite UnionSwap; auto.
      apply UnionNeqTID in x. invertHyp. rewrite H14. solveSet. auto. }
    }
    {invertHyp. apply UnionNeqTID in x. invertHyp. rewrite H12 in H3. unfoldTac.
     rewrite UnionSwap in H3. eapply newSimPureStepsFull' in H3. invertHyp.
     right. econstructor. econstructor. econstructor. split. takeTStep.
     rewrite UnionSwap. rewrite subtractSingle'. rewrite H12.
     rewrite UnionSwap. eassumption. rewrite H12. solveSet. split; auto.
     split. Focus 2. eassumption. rewrite H13. clear H12 H13.
     inv H5; try solve[heapsDisagree].
     {varsEq x4 x0. heapsDisagree. erewrite lookupReplaceNeq in H4; eauto.
      heapsDisagree. }
     {varsEq x4 x0. erewrite HeapLookupReplace in H4; eauto. inv H4.
      econstructor. eapply SPut; eauto. erewrite HeapLookupReplace; eauto.
      rewrite replaceOverwrite. rewrite replaceOverwrite in H16.
      apply UnionNeqTID in H6; auto. invertHyp. rewrite H4.
      rewrite UnionSubtract. eauto. rewrite lookupReplaceNeq in H4; auto.
      heapsDisagree. }
     {varsEq x4 x0. heapsDisagree. erewrite lookupExtendNeq in H4; eauto. inv H4. }
     {eauto. }
     {eauto. }
     {eauto. }
     {auto. }
    }
   }
  }
  Grab Existential Variables. rewrite lookupReplaceNeq; eauto.
Qed.

Theorem smultiReplaceEmptyFull : forall H T H' T' ds' x M' TID,
                   heap_lookup x H = Some(sempty SPEC) ->
                   heap_lookup x H' = Some(sfull SPEC ds' SPEC TID M') ->
                   spec_multistep H T H' T' ->
                   spec_multistep (replace x (sempty COMMIT) H) T
                                  (replace x (sfull COMMIT ds' SPEC TID M') H') T'.
Proof.
  intros. genDeps{ds'}. induction H2; intros.
  {rewrite H1 in H0. inv H0. }
  {copy H. apply specStepSingleton in H. invertHyp. copy H3.
   eapply specStepEmptyIVarOr in H3; eauto. inv H3.
   {econstructor. eapply stepReplaceEmpty; eauto. eauto. }
   {invertHyp. inversion H; subst; try solve[heapsDisagree].
    {varsEq x2 x. heapsDisagree. rewrite lookupReplaceNeq in H3; eauto.
     heapsDisagree. }
    {varsEq x2 x. rewrite H5 in H0. inv H0. econstructor. eapply SPut with(d:=d);eauto.
     erewrite HeapLookupReplace; eauto. rewrite replaceOverwrite.
     copy H2. eapply smultiFullIVar in H2. Focus 2. erewrite HeapLookupReplace; eauto.
     invertHyp. rewrite H4 in H1. inv H1. lookupTac. eapply smultiReplaceSpecFull in H0.
     Focus 2. eassumption. Focus 2. eassumption. rewrite replaceOverwrite in H0.
     eassumption. rewrite lookupReplaceNeq in H3; eauto. heapsDisagree. }
    {varsEq x2 x. heapsDisagree. erewrite lookupExtendNeq in H3; eauto. inv H3. }
   }
  }
Qed.

Theorem newSimActionStepsFullFull : forall H T H' T' TID x ds ds' t0 M'' M' E d N N' H'' T'' N'' s2 s1 s1' a,
       eraseTrm (s1'++[a]) N' N'' ->
       heap_lookup x H = Some(sfull SPEC ds SPEC t0 M'') ->
       heap_lookup x H' = Some(sfull SPEC ds' SPEC t0 M'') ->
       spec_multistep H'' (tUnion T'' (tSingleton(TID,unlocked [nAct M' E d x],s2,N'')))
                      H (tUnion T (tSingleton(TID,unlocked(s1++[nAct M' E d x]),s2,N))) ->
       spec_multistep H (tUnion T (tSingleton(TID,unlocked(s1++[nAct M' E d x]),s2,N))) H'
                      (tUnion T' (tSingleton(TID,unlocked(s1'++[a]++[nAct M' E d x]),s2,N'))) ->
       spec_multistep (replace x (sfull COMMIT ds SPEC t0 M'') H)
                      (tUnion T (tSingleton(TID,unlocked s1,nAct M' E d x::s2,N)))
                      (replace x (sfull COMMIT ds' SPEC t0 M'') H')
                      (tUnion T' (tSingleton(TID,unlocked (s1'++[a]), nAct M' E d x::s2,N'))).
Proof.
  intros. genDeps{ds; ds'}. dependent induction H4; intros.
  {apply UnionEqTID in x. invertHyp. inv H.
   replace [a; nAct M' E d x0] with ([a]++[nAct M' E d x0]) in H6; auto.
   rewrite app_assoc in H6. apply app_inj_tail in H6. invertHyp. inv H5. rewrite H1 in H2.
   inv H2. constructor. }
  {startIndCase. destructThread x1. exMid TID H11.
   {apply UnionEqTID in x. invertHyp. inversion H1; subst.
    {copy H3. eapply stackNonNil in H3. destruct s1. exfalso. apply H3. auto.
     econstructor. eapply SBasicStep; eauto. constructor.
     eapply IHspec_multistep; eauto.  eapply spec_multi_trans. eassumption.
     econstructor. eapply SBasicStep; eauto. constructor. eauto. intros c. subst.
     apply eraseTrmApp in H0. inv H0; inv H17; falseDecomp. }
    {econstructor. eapply SFork; eauto. simpl. unfoldTac. rewrite coupleUnion.
     rewrite Union_associative. rewrite UnionSwap. eapply IHspec_multistep; eauto.
     Focus 2. rewrite <- Union_associative. rewrite <- coupleUnion.
     rewrite couple_swap. unfold numForks. simpl. simpl. eauto.
     rewrite numForksDistribute. simpl. rewrite <- plus_assoc.
     rewrite <- plus_comm. simpl. rewrite plus_comm. reflexivity.
     eapply spec_multi_trans. eassumption. econstructor. eapply SFork; eauto.
     rewrite <- Union_associative. rewrite <- coupleUnion. rewrite couple_swap.
     simpl. rewrite numForksDistribute. simpl. rewrite <- plus_assoc.
     rewrite plus_comm. simpl. rewrite plus_comm. constructor. }
    {varsEq x0 x.
     {rewrite H17 in H5. inv H5. econstructor. eapply SGet; eauto.
      erewrite HeapLookupReplace; eauto. rewrite replaceOverwrite. lookupTac.
      eapply IHspec_multistep in H5; eauto. rewrite replaceOverwrite in H5. eauto.
      eapply spec_multi_trans. eauto. econstructor. eapply SGet; eauto. constructor.
      simpl. auto. }
     {lookupTac. eapply IHspec_multistep in H8; eauto. econstructor.
      eapply SGet; eauto. rewrite lookupReplaceNeq; eauto.
      rewrite lookupReplaceSwitch. eassumption. auto. eapply spec_multi_trans.
      eassumption. econstructor. eapply SGet; eauto. simpl. constructor. simpl.
      auto. }
    }
    {varsEq x0 x. heapsDisagree. lookupTac. eapply IHspec_multistep in H8; eauto.
     econstructor. eapply SPut; eauto. rewrite lookupReplaceNeq; eauto.
     rewrite lookupReplaceSwitch; eauto. eapply spec_multi_trans. eassumption.
     econstructor. eapply SPut; eauto. constructor. simpl. auto. }
    {varsEq x0 x. heapsDisagree. lookupTac. eapply IHspec_multistep in H8; eauto.
     econstructor. eapply SNew; eauto. erewrite extendReplaceSwitch; eauto.
     eapply spec_multi_trans. eassumption. econstructor. eapply SNew; eauto.
     constructor. simpl; auto. }
    {econstructor. eapply SSpec; eauto. unfoldTac. rewrite coupleUnion.
     rewrite Union_associative. rewrite <-UnionSwap. eapply IHspec_multistep; eauto.
     Focus 2. rewrite <- Union_associative. rewrite <- coupleUnion.
     rewrite couple_swap. reflexivity. eapply spec_multi_trans. eassumption.
     econstructor. eapply SSpec; eauto. rewrite <- Union_associative.
     rewrite <- coupleUnion. rewrite couple_swap. constructor. }
   }
   {apply UnionNeqTID in H7; auto. invertHyp. copy H1. copy H7.
    eapply specStepFullIVar in H7; eauto. invertHyp.
    eapply stepReplaceSpecFull in H1; eauto. takeTStep.
    eapply IHspec_multistep; eauto. eapply spec_multi_trans. eassumption. rewrite H13.
    rewrite UnionSwap. econstructor. eapply specStepChangeUnused. eauto. unfoldTac.
    rewrite UnionSwap. constructor. proveUnionEq x. rewrite UnionSubtract.
    unfoldTac. rewrite UnionSwap. auto. rewrite H13. solveSet. }
  }
  Grab Existential Variables. rewrite lookupReplaceNeq; eauto.
Qed.

Theorem newSimActionStepsEmptyFull : forall H T H' T' TID x ds' t0 M'' M' E d N N' H'' T'' N'' s2 s1 s1' a,
       eraseTrm (s1'++[a]) N' N'' ->
       heap_lookup x H = Some(sempty SPEC) ->
       heap_lookup x H' = Some(sfull SPEC ds' SPEC t0 M'') ->
       spec_multistep H'' (tUnion T'' (tSingleton(TID,unlocked [nAct M' E d x],s2,N'')))
                      H (tUnion T (tSingleton(TID,unlocked(s1++[nAct M' E d x]),s2,N))) ->
       spec_multistep H (tUnion T (tSingleton(TID,unlocked(s1++[nAct M' E d x]),s2,N))) H'
                      (tUnion T' (tSingleton(TID,unlocked(s1'++[a]++[nAct M' E d x]),s2,N'))) ->
       spec_multistep (replace x (sempty COMMIT) H)
                      (tUnion T (tSingleton(TID,unlocked s1,nAct M' E d x::s2,N)))
                      (replace x (sfull COMMIT ds' SPEC t0 M'') H')
                      (tUnion T' (tSingleton(TID,unlocked (s1'++[a]), nAct M' E d x::s2,N'))).
Proof.
  intros. genDeps{ds'}. dependent induction H4; intros.
  {rewrite H1 in H2. inv H2. }
  {startIndCase. destructThread x1. exMid TID H11.
   {apply UnionEqTID in x. invertHyp. copy H1. copy H2.
    eapply specStepEmptyIVarOr in H8; eauto. inv H8.
    {inversion H2; subst.
     {copy H3. eapply stackNonNil in H3. destruct s1. exfalso. apply H3. auto.
      econstructor. eapply SBasicStep; eauto. constructor.
      eapply IHspec_multistep; eauto. eapply spec_multi_trans. eassumption.
      econstructor. eapply SBasicStep; eauto. constructor. eauto. intros c. subst.
      apply eraseTrmApp in H0. inv H0; inv H19; falseDecomp. }
     {econstructor. eapply SFork; eauto. simpl. unfoldTac. rewrite coupleUnion.
      rewrite Union_associative. rewrite UnionSwap. eapply IHspec_multistep; eauto.
      Focus 2. rewrite <- Union_associative. rewrite <- coupleUnion.
      rewrite couple_swap. unfold numForks. simpl. simpl. eauto.
      rewrite numForksDistribute. simpl. rewrite <- plus_assoc. rewrite <- plus_comm.
      simpl. rewrite plus_comm. reflexivity. eapply spec_multi_trans.
      eassumption. econstructor. eapply SFork; eauto. rewrite <- Union_associative.
      rewrite <- coupleUnion. rewrite couple_swap. simpl. rewrite numForksDistribute.
      simpl. rewrite <- plus_assoc. rewrite plus_comm. simpl. rewrite plus_comm.
      constructor. }
     {varsEq x0 x. heapsDisagree. econstructor. eapply SGet; eauto.
      rewrite lookupReplaceNeq; eauto. lookupTac.
      eapply IHspec_multistep in H10; eauto. rewrite lookupReplaceSwitch; auto.
      eassumption. eapply spec_multi_trans. eassumption. econstructor.
      eapply SGet; eauto. simpl. constructor. reflexivity. }
     {varsEq x0 x. erewrite HeapLookupReplace in H9; eauto. inv H9. econstructor.
      eapply SPut; eauto. rewrite lookupReplaceNeq; eauto. lookupTac.
      eapply IHspec_multistep in H10; eauto. rewrite lookupReplaceSwitch; auto.
      eassumption. eapply spec_multi_trans. eassumption. econstructor.
      eapply SPut; eauto. simpl. constructor. reflexivity. }
     {varsEq x0 x. heapsDisagree. econstructor. eapply SNew; eauto. lookupTac.
      eapply IHspec_multistep in H10; eauto. erewrite extendReplaceSwitch; eauto.
      eapply spec_multi_trans. eassumption. econstructor. eapply SNew; eauto. simpl.
      constructor. reflexivity. }
    {econstructor. eapply SSpec; eauto. unfoldTac. rewrite coupleUnion.
     rewrite Union_associative. rewrite <- UnionSwap. eapply IHspec_multistep; eauto.
     Focus 2. rewrite <- Union_associative. rewrite <- coupleUnion.
     rewrite couple_swap. reflexivity. eapply spec_multi_trans. eassumption.
     econstructor. eapply SSpec; eauto. rewrite <- Union_associative.
     rewrite <- coupleUnion. rewrite couple_swap. constructor. }
    }
    {invertHyp. inversion H2; subst; try solve[heapsDisagree].
     {varsEq x1 x0. erewrite HeapLookupReplace in H8; eauto. inv H8. heapsDisagree.
      rewrite lookupReplaceNeq in H8; eauto. heapsDisagree. }
     {varsEq x1 x0. erewrite HeapLookupReplace in H8; eauto. inv H8. simpl in *.
      rewrite app_comm_cons in H4. eapply newSimActionStepsFullFull in H4; eauto.
      econstructor. eapply SPut; eauto. erewrite HeapLookupReplace; eauto.
      rewrite replaceOverwrite. rewrite replaceOverwrite in H4. eassumption.
      erewrite HeapLookupReplace; eauto. eapply spec_multi_trans. eassumption.
      econstructor. eapply SPut; eauto. constructor.
      rewrite lookupReplaceNeq in H8; eauto. heapsDisagree. }
     {varsEq x1 x0. heapsDisagree. erewrite lookupExtendNeq in H8; eauto. inv H8. }
    }
   }
   {apply UnionNeqTID in x; auto. copy H1. copy H2.
    eapply specStepEmptyIVarOr in H2; eauto. inv H2.
    {copy H14.  eapply IHspec_multistep in H14; eauto. invertHyp. takeTStep.
     econstructor. eapply specStepChangeUnused. eapply stepReplaceEmpty.
     eauto. eapply H2. eauto. unfoldTac. rewrite UnionSwap. eassumption.
     eapply spec_multi_trans. eassumption. invertHyp. takeTStep. constructor.
     invertHyp. rewrite H15. rewrite UnionSubtract. unfoldTac. rewrite UnionSwap.
     auto. }
    {inversion H13; subst; try solve[invertHyp; heapsDisagree].
     {varsEq x1 x0; invertHyp. heapsDisagree. rewrite lookupReplaceNeq in H15; auto.
      heapsDisagree. }
     {varsEq x1 x0. inv H14. erewrite HeapLookupReplace in H2; eauto. inv H2.
      invertHyp. takeTStep. rewrite H2 in H4. rewrite UnionSwap in H4.
      eapply newSimActionStepsFullFull in H4; eauto. Focus 2.
      erewrite HeapLookupReplace; eauto. Focus 2. eapply spec_multi_trans.
      eassumption. rewrite H11. rewrite UnionSwap. econstructor. eapply SPut; eauto.
      rewrite UnionSubtract. unfoldTac. rewrite UnionSwap. constructor.
      econstructor. eapply SPut; eauto. erewrite HeapLookupReplace; eauto.
      rewrite replaceOverwrite. rewrite replaceOverwrite in H4. rewrite H2.
      rewrite UnionSubtract. unfoldTac. rewrite UnionSwap. eassumption.
      invertHyp. rewrite lookupReplaceNeq in H15; eauto. heapsDisagree. }
     {varsEq x1 x0. heapsDisagree. invertHyp. erewrite lookupExtendNeq in H15; eauto.
      inv H15. }
    }
   }
  }
  Grab Existential Variables. rewrite lookupReplaceNeq; eauto.
Qed.


From refinedc.typing Require Import typing.
From refinedc.project.learning.src.solswitch Require Import generated_code.
From refinedc.project.learning.src.solswitch Require Import generated_spec.
Set Default Proof Using "Type".

(* Generated from [src/solswitch.c]. *)
Section proof_SML_isSafetyVoltageCondExists.
  Context `{!typeG Σ} `{!globalG Σ}.

  (* Typing proof for [SML_isSafetyVoltageCondExists]. *)
  Lemma type_SML_isSafetyVoltageCondExists (global_curTime : loc) :
    global_locs !! "curTime" = Some global_curTime →
    global_initialized_types !! "curTime" = Some (GT nat (λ 'global_time, (global_time @ (int (u16))) : type)%I) →
    ⊢ typed_function (impl_SML_isSafetyVoltageCondExists global_curTime) type_of_SML_isSafetyVoltageCondExists.
  Proof.
    Open Scope printing_sugar.
    start_function "SML_isSafetyVoltageCondExists" ([[[[[state msg] conversionEnded] voltage] p] global_time]) => arg_solenoidSwitchingParams_ptr arg_isConversionEnded local_uniqueSafetyVoltage.
    prepare_parameters (state msg conversionEnded voltage p global_time).
    split_blocks ((
      ∅
    )%I : gmap label (iProp Σ)) ((
      ∅
    )%I : gmap label (iProp Σ)).
    - repeat liRStep; liShow.
      all: print_typesystem_goal "SML_isSafetyVoltageCondExists" "#0".
    Unshelve. all: li_unshelve_sidecond; sidecond_hook; prepare_sideconditions; normalize_and_simpl_goal; try solve_goal; unsolved_sidecond_hook.
    all: try destruct state; tauto.
    all: print_sidecondition_goal "SML_isSafetyVoltageCondExists".
    Unshelve. all: try done; try apply: inhabitant; print_remaining_shelved_goal "SML_isSafetyVoltageCondExists".
  Qed.
End proof_SML_isSafetyVoltageCondExists.