Require Import Coq.Lists.List.
Require Import Coq.ZArith.BinInt.

Open Scope list_scope.
Open Scope Z_scope.

Import ListNotations.

Inductive Direction :=
    | forward (n : Z)
    | down (n : Z)
    | up (n : Z)
    .

Definition example_data := [ forward 5 ; down 5 ; forward 8 ; up 3 ; down 8 ; forward 2 ].
Definition data := [ forward 4 ; forward 6 ; down 8 ; forward 3 ; forward 9 ; down 7 ; down 7 ; down 1 ; forward 1 ; forward 5 ; up 4 ; forward 3 ; forward 9 ; forward 5 ; down 8 ; forward 6 ; forward 8 ; up 4 ; forward 1 ; forward 4 ; up 3 ; down 2 ; down 2 ; up 8 ; forward 9 ; down 5 ; down 6 ; down 4 ; forward 1 ; forward 7 ; down 1 ; forward 2 ; down 7 ; down 6 ; forward 3 ; forward 1 ; down 7 ; forward 3 ; up 7 ; up 1 ; forward 6 ; down 8 ; down 4 ; down 1 ; down 7 ; forward 9 ; down 2 ; forward 9 ; up 4 ; down 7 ; forward 9 ; forward 9 ; up 4 ; up 7 ; up 2 ; forward 1 ; down 9 ; forward 2 ; forward 8 ; forward 5 ; down 9 ; forward 5 ; up 1 ; forward 8 ; down 6 ; down 1 ; down 1 ; down 8 ; down 6 ; down 4 ; down 6 ; forward 7 ; forward 5 ; forward 4 ; up 8 ; up 4 ; forward 6 ; forward 9 ; forward 6 ; down 2 ; up 8 ; forward 3 ; forward 8 ; down 5 ; forward 1 ; down 6 ; down 7 ; up 4 ; down 8 ; forward 6 ; up 4 ; forward 7 ; down 8 ; down 8 ; down 2 ; down 8 ; up 7 ; forward 7 ; forward 6 ; down 2 ; forward 9 ; down 7 ; down 4 ; forward 1 ; up 9 ; down 6 ; up 7 ; down 6 ; down 2 ; down 2 ; forward 3 ; down 8 ; forward 4 ; down 7 ; down 2 ; up 8 ; down 6 ; forward 2 ; forward 2 ; down 6 ; up 6 ; down 7 ; up 5 ; up 4 ; up 9 ; forward 9 ; forward 7 ; down 4 ; down 4 ; up 5 ; down 2 ; forward 3 ; down 9 ; down 5 ; forward 8 ; up 3 ; forward 7 ; forward 9 ; down 3 ; forward 1 ; up 1 ; forward 5 ; down 8 ; down 2 ; forward 3 ; down 6 ; down 8 ; up 9 ; down 9 ; forward 4 ; up 5 ; forward 8 ; forward 7 ; forward 7 ; down 3 ; down 5 ; forward 8 ; down 1 ; down 2 ; forward 2 ; up 9 ; down 3 ; down 9 ; forward 2 ; down 4 ; up 9 ; up 3 ; down 1 ; down 1 ; forward 6 ; down 5 ; down 9 ; forward 2 ; up 5 ; forward 3 ; down 1 ; down 7 ; forward 1 ; forward 1 ; down 7 ; up 3 ; up 1 ; up 6 ; forward 9 ; up 1 ; down 8 ; down 5 ; up 6 ; up 2 ; down 8 ; forward 3 ; forward 1 ; down 7 ; up 1 ; down 9 ; down 9 ; up 8 ; forward 4 ; up 8 ; forward 8 ; down 5 ; forward 5 ; forward 2 ; forward 1 ; forward 5 ; down 8 ; forward 6 ; forward 8 ; down 5 ; forward 8 ; up 1 ; up 9 ; up 7 ; down 5 ; down 9 ; up 4 ; down 7 ; up 8 ; up 3 ; forward 6 ; down 9 ; forward 4 ; down 4 ; forward 2 ; forward 3 ; down 4 ; down 5 ; down 3 ; forward 9 ; forward 5 ; forward 9 ; forward 4 ; down 5 ; down 7 ; down 5 ; forward 8 ; up 5 ; down 2 ; forward 3 ; forward 4 ; down 5 ; up 8 ; forward 5 ; down 2 ; up 4 ; down 5 ; down 2 ; forward 1 ; up 3 ; down 6 ; down 8 ; down 3 ; forward 1 ; up 5 ; forward 1 ; down 3 ; forward 4 ; down 6 ; forward 8 ; forward 4 ; forward 1 ; down 8 ; down 2 ; forward 8 ; down 5 ; forward 2 ; forward 2 ; down 9 ; forward 1 ; forward 8 ; up 1 ; forward 1 ; down 1 ; down 7 ; down 4 ; up 4 ; down 3 ; forward 1 ; forward 9 ; down 9 ; up 6 ; up 8 ; down 2 ; down 2 ; down 3 ; forward 2 ; forward 9 ; down 1 ; up 9 ; down 3 ; down 9 ; down 1 ; down 7 ; forward 9 ; forward 7 ; down 5 ; down 2 ; down 9 ; down 2 ; down 7 ; up 7 ; down 2 ; up 3 ; up 5 ; forward 8 ; up 7 ; forward 1 ; down 9 ; down 9 ; down 1 ; forward 6 ; down 7 ; up 4 ; up 4 ; down 9 ; up 5 ; up 8 ; down 3 ; down 5 ; forward 6 ; up 3 ; down 8 ; down 5 ; forward 9 ; up 6 ; forward 9 ; forward 5 ; up 6 ; up 9 ; down 2 ; up 5 ; forward 9 ; down 1 ; up 1 ; down 9 ; forward 4 ; forward 4 ; forward 8 ; down 5 ; down 3 ; down 7 ; forward 5 ; down 6 ; forward 3 ; down 5 ; down 5 ; up 5 ; forward 8 ; forward 1 ; forward 2 ; forward 6 ; up 1 ; down 5 ; down 4 ; up 5 ; forward 3 ; forward 2 ; forward 2 ; forward 2 ; forward 7 ; forward 8 ; down 2 ; up 8 ; forward 4 ; down 4 ; forward 7 ; down 6 ; down 7 ; forward 5 ; down 5 ; forward 1 ; down 8 ; forward 6 ; down 1 ; forward 3 ; up 3 ; down 7 ; down 2 ; up 4 ; down 3 ; up 2 ; up 8 ; down 2 ; forward 5 ; forward 3 ; down 9 ; down 9 ; up 2 ; forward 6 ; forward 9 ; down 1 ; forward 6 ; down 4 ; up 2 ; down 7 ; down 3 ; down 3 ; forward 2 ; down 5 ; down 9 ; down 7 ; forward 7 ; forward 9 ; up 8 ; down 8 ; down 3 ; up 5 ; down 9 ; forward 8 ; forward 8 ; down 1 ; forward 5 ; forward 2 ; forward 7 ; down 9 ; down 7 ; forward 6 ; up 9 ; forward 3 ; forward 5 ; up 7 ; down 9 ; forward 9 ; forward 4 ; forward 5 ; forward 9 ; forward 8 ; forward 1 ; forward 2 ; forward 8 ; down 7 ; forward 3 ; up 2 ; up 7 ; forward 1 ; forward 3 ; forward 9 ; up 3 ; down 2 ; forward 3 ; forward 6 ; forward 3 ; forward 3 ; forward 3 ; forward 1 ; forward 1 ; up 5 ; down 5 ; up 5 ; down 5 ; down 5 ; forward 8 ; forward 1 ; down 4 ; forward 7 ; down 6 ; down 1 ; down 2 ; down 2 ; down 6 ; up 8 ; forward 3 ; forward 2 ; up 8 ; up 2 ; forward 1 ; forward 6 ; forward 5 ; forward 6 ; forward 7 ; down 8 ; forward 1 ; down 4 ; forward 2 ; up 4 ; forward 4 ; down 1 ; forward 5 ; down 7 ; forward 7 ; up 7 ; forward 1 ; down 2 ; forward 8 ; forward 5 ; up 8 ; up 8 ; up 2 ; down 9 ; forward 2 ; down 4 ; down 3 ; down 5 ; down 5 ; down 2 ; up 5 ; forward 6 ; up 7 ; forward 8 ; up 7 ; down 4 ; forward 1 ; down 3 ; forward 2 ; forward 1 ; down 2 ; up 7 ; forward 5 ; up 8 ; up 1 ; down 4 ; forward 6 ; down 4 ; up 9 ; forward 5 ; down 2 ; down 7 ; down 7 ; forward 4 ; forward 4 ; forward 9 ; down 1 ; forward 6 ; forward 1 ; up 9 ; forward 4 ; forward 4 ; forward 8 ; forward 3 ; forward 4 ; down 3 ; up 5 ; up 1 ; forward 3 ; down 6 ; down 4 ; down 2 ; forward 3 ; forward 8 ; up 6 ; up 3 ; forward 8 ; down 3 ; down 6 ; forward 1 ; up 7 ; down 4 ; down 5 ; up 7 ; forward 3 ; up 4 ; forward 9 ; forward 6 ; down 3 ; forward 4 ; down 6 ; forward 1 ; forward 6 ; forward 4 ; forward 2 ; forward 1 ; forward 3 ; forward 1 ; down 1 ; down 9 ; down 5 ; down 7 ; down 4 ; down 8 ; up 1 ; down 6 ; down 1 ; forward 4 ; down 9 ; up 9 ; down 6 ; forward 6 ; forward 8 ; up 7 ; forward 4 ; down 3 ; forward 9 ; forward 6 ; forward 8 ; down 1 ; up 2 ; down 2 ; down 8 ; forward 4 ; down 9 ; down 3 ; forward 5 ; down 9 ; down 4 ; up 5 ; down 8 ; down 4 ; down 9 ; up 4 ; down 5 ; down 7 ; down 3 ; up 1 ; up 1 ; down 4 ; down 6 ; forward 8 ; down 8 ; down 6 ; forward 6 ; forward 9 ; forward 3 ; forward 3 ; down 2 ; down 4 ; forward 3 ; up 5 ; up 3 ; down 5 ; down 1 ; forward 5 ; forward 7 ; forward 1 ; forward 4 ; forward 5 ; forward 1 ; down 7 ; down 8 ; up 9 ; down 8 ; down 5 ; up 3 ; down 5 ; down 5 ; forward 8 ; down 2 ; forward 7 ; forward 7 ; down 1 ; forward 2 ; forward 7 ; forward 5 ; down 6 ; forward 5 ; down 5 ; forward 4 ; down 8 ; forward 7 ; up 5 ; forward 5 ; down 7 ; down 7 ; up 4 ; forward 8 ; up 1 ; forward 3 ; forward 7 ; down 2 ; forward 1 ; down 4 ; up 8 ; forward 3 ; forward 1 ; forward 6 ; forward 3 ; up 4 ; forward 3 ; down 3 ; forward 7 ; forward 9 ; forward 8 ; down 6 ; down 8 ; up 6 ; down 9 ; forward 7 ; forward 1 ; up 4 ; forward 5 ; forward 8 ; down 7 ; down 9 ; up 6 ; up 6 ; forward 9 ; down 1 ; forward 8 ; down 9 ; down 5 ; forward 6 ; forward 1 ; down 4 ; forward 8 ; down 9 ; down 4 ; forward 5 ; forward 7 ; forward 3 ; down 2 ; forward 6 ; forward 3 ; forward 8 ; down 1 ; down 5 ; up 6 ; down 2 ; down 1 ; up 3 ; down 7 ; up 1 ; forward 8 ; down 6 ; down 6 ; forward 8 ; up 3 ; forward 8 ; up 3 ; forward 3 ; forward 7 ; forward 1 ; down 1 ; up 5 ; forward 5 ; forward 9 ; forward 5 ; forward 1 ; forward 4 ; down 8 ; forward 2 ; up 3 ; forward 3 ; down 9 ; forward 2 ; forward 6 ; forward 3 ; up 8 ; up 1 ; down 6 ; forward 3 ; down 4 ; down 5 ; forward 6 ; forward 9 ; down 4 ; down 9 ; down 7 ; down 1 ; up 3 ; up 6 ; forward 4 ; forward 5 ; down 1 ; forward 3 ; up 5 ; forward 7 ; down 9 ; forward 5 ; down 5 ; down 1 ; down 1 ; down 1 ; up 8 ; down 4 ; down 9 ; forward 5 ; down 5 ; up 5 ; up 3 ; forward 1 ; forward 7 ; down 2 ; forward 6 ; forward 5 ; up 4 ; up 4 ; forward 1 ; down 7 ; down 8 ; up 3 ; down 3 ; up 4 ; forward 2 ; up 4 ; up 4 ; forward 8 ; forward 1 ; forward 2 ; forward 7 ; down 6 ; forward 8 ; forward 9 ; forward 6 ; forward 9 ; down 3 ; up 3 ; forward 5 ; down 1 ; forward 1 ; forward 4 ; forward 2 ; down 6 ; up 7 ; forward 9 ; down 2 ; up 5 ; forward 6 ; down 9 ; down 6 ; down 8 ; forward 2 ; down 7 ; forward 6 ; down 8 ; forward 3 ; forward 7 ; forward 6 ; down 7 ; down 6 ; forward 5 ; up 8 ; forward 6 ; down 1 ; up 9 ; forward 6 ; down 6 ; down 5 ; down 6 ; up 2 ; down 3 ; down 7 ; down 3 ; forward 4 ; up 9 ; up 2 ; forward 1 ; forward 7 ; forward 7 ; forward 9 ; forward 8 ; forward 7 ; down 3 ; forward 4 ; forward 8 ; down 9 ; forward 2 ; forward 2 ; up 9 ; up 7 ; forward 2 ; down 8 ; down 3 ; down 1 ; forward 1 ; forward 3 ; down 2 ; forward 7 ; up 4 ; down 7 ; down 1 ; forward 8 ; forward 2 ; up 1 ; down 5 ; forward 8 ; up 5 ; up 7 ; forward 4 ; forward 7 ; up 4 ; up 3 ; forward 5 ; forward 9 ; forward 1 ; forward 3 ; down 9 ; up 2 ; forward 8 ; down 3 ; forward 3 ; forward 2 ; down 8 ; down 2 ; down 3 ; forward 1 ; up 7 ; down 1 ; forward 3 ; forward 8 ; down 3 ; down 9 ; up 1 ; down 9 ; up 7 ; up 7 ; forward 7 ; forward 7 ; up 8 ; down 2 ; down 7 ; down 1 ; forward 5 ; forward 5 ; forward 7 ; down 8 ; forward 5 ; down 9 ; down 8 ; forward 3 ; up 9 ; forward 3 ; up 6 ; forward 7 ; up 7 ; forward 3 ; forward 2 ; down 1 ; down 4 ; forward 1 ; forward 8 ; up 5 ; down 5 ; up 1 ; down 5 ; up 1 ; up 6 ; forward 5 ; forward 5 ; down 3 ; down 3 ; forward 2 ; up 3 ; up 2 ; down 6 ; down 5 ; down 1 ; down 1 ; up 6 ; forward 2 ; forward 2 ; up 4 ; up 6 ; up 6 ; down 8 ; up 2 ; forward 4 ; down 3 ; forward 3 ; up 4 ; down 5 ; forward 6 ; forward 7 ; up 6 ; down 3 ; down 7 ; up 4 ; down 2 ; up 2 ; forward 1 ; down 8 ; down 1 ; down 1 ; up 9 ; down 1 ; down 1 ; up 1 ; forward 8 ; forward 4 ; down 4 ; forward 1 ; down 4 ; up 7 ; forward 7 ; forward 3 ; down 4 ; forward 9 ; forward 1 ; down 3 ; down 2 ; forward 7 ; up 1 ; forward 3 ; up 3 ; down 3 ; down 7 ; up 3 ; up 4 ; forward 7 ; down 2 ; up 2 ; down 9 ; up 1 ; forward 3 ; up 8 ; up 8 ; down 8 ; down 1 ; up 8 ; up 4 ; down 6 ; forward 8 ].

Fixpoint position (x y : Z) (data : list Direction) :=
    match data with
    | [] => x * y
    | (forward n) :: l => position (x + n) y l
    | (down n) :: l => position x (y + n) l
    | (up n) :: l => position x (y - n) l
    end.

Definition part1 := position 0 0 data.

Fixpoint position_aim (x y aim : Z) (data : list Direction) :=
    match data with
    | [] => x * y
    | (forward n) :: l => position_aim (x + n) (y + n*aim) aim l
    | (down n) :: l => position_aim x y (aim + n) l
    | (up n) :: l => position_aim x y (aim - n) l
    end.

Definition part2 := position_aim 0 0 0 data.

Compute part1.
Compute part2.


From iris.proofmode Require Import tactics.
From machine_program_logic.program_logic Require Import weakestpre.
From HypVeri.lang Require Import lang.
From HypVeri Require Import big_sepFM machine_extra.
From HypVeri.algebra Require Import base base_extra mem mailbox trans.
From HypVeri.logrel Require Import big_sepSS.
Import uPred.

Section slice_trans.
  Context `{hypconst:HypervisorConstants}.
  Context `{vmG: !gen_VMG Σ}.
  Context (Φ : (gmap Addr transaction) -> VMID -> VMID -> iProp Σ).

  Definition trans_preserve_slice i j (trans trans': (gmap Addr transaction)):=
    filter (λ kv, kv.2.1.1.1.1 = i ∧ kv.2.1.1.1.2 = j) trans
                        = filter (λ kv, kv.2.1.1.1.1 = i ∧ kv.2.1.1.1.2 = j) trans'.

  Class SliceTransWf :=
    {
      slice_trans_valid : ∀ i j trans trans',
        trans_preserve_slice i j trans trans'-> (Φ trans i j ⊣⊢ Φ trans' i j)
    }.

End slice_trans.

Global Arguments SliceTransWf {_} {_} _.
Global Arguments slice_trans_valid {_} {_} _ {_} {_} {_} {_} {_} _.
Global Hint Mode SliceTransWf + + ! : typeclass_instances.

Section slice_rxs.
  Context `{hypconst:HypervisorConstants}.
  Context `{vmG: !gen_VMG Σ}.
  Context (Φ :VMID -> option (Word * VMID)-> VMID -> iProp Σ).

  Class SliceRxsWf :=
    {
      slice_rxs_empty : ∀ i j, Φ i None j ⊣⊢ True;
      slice_rxs_sym : ∀ i os k k',
        (match os with
         | None => True
         | Some (_,j) => j ≠ V0 ->  Φ i os k ⊣⊢ Φ i os k'
         end);
    }.

End slice_rxs.

Global Arguments SliceRxsWf {_} {_} _.
Global Arguments slice_rxs_empty {_} {_} _ {_} _ _.
Global Arguments slice_rxs_sym {_} {_} _ {_} {_} {_} _ _.
Global Hint Mode SliceRxsWf + + ! : typeclass_instances.

(**  unary logical relation **)
Section logrel.
  Context `{hypconst:HypervisorConstants}.
  Context `{hypparams:!HypervisorParameters}.
  Context `{vmG: !gen_VMG Σ}.

  Definition set_of_vmids : gset VMID := (list_to_set list_of_vmids).
  Definition lift_option_gmap`{Countable K} {V: Type} (m: gmap K V) := (λ v, Some v) <$> m.
  Definition pages_in_trans (trans: gmap Word transaction) : gset PID :=
    pages_in_trans' (lift_option_gmap trans).

  Definition trans_ps_disj trans := inv_trans_ps_disj' (lift_option_gmap trans).

  Definition pgt (ps: gset PID) q (vo: VMID) (be: bool) : iProp Σ :=
    [∗ set] p ∈ ps, p -@{q}O> vo ∗ p -@{q}E> be.

  Definition pgt_full ps vo be := pgt ps 1 vo be.
  Definition pgt_3_4 ps vo be : iProp Σ := pgt ps (1/4) vo be ∗ pgt ps (1/2) vo be.
  Definition pgt_1_4 ps vo be : iProp Σ := pgt ps (1/4) vo be.

  (** definitions **)

   (* [transaction_pagetable_entries_transferred] : For donation, the half of transaction entries that are kept by sender in case
      of sharing and lending are also be passed around between the sender and the receiver, as retrieval in this case also requires
      full entries.
      Pagetable entries are transferred along as both sender and receiver could be the exclusive owner of those pages. *)
  Definition transaction_pagetable_entries_transferred i (trans: gmap Addr transaction) : iProp Σ:=
    big_sepFM trans (λ kv, (kv.2.1.1.1.1 = i ∨ kv.2.1.1.1.2 = i) ∧ kv.2.1.2 = Donation) (λ k v, k -{1/4}>t v.1 ∗ pgt_1_4 v.1.1.2 v.1.1.1.1 true)%I.

  (* [retrieval entries]: half of all retrieval entries of i-related transactions are required.
     For transactions where i is the sender, we need the corresponding retrieval entries to check if it is allowed for i to reclaim,
     for the cases when i is the receiver, they are required so that i can retrieve or relinquish *)
  (* There are also some cases when we need the second half, as in those cases we may update/remove the retrival state *)
  (* XXX: How to relate retrieval and transaction entries? Using option(frac_agree transaction,option bool)? or is it unnecessary? *)
  Definition retrievable_transaction_transferred i (trans: gmap Addr transaction) : iProp Σ:=
    (big_sepFM trans (λ kv, kv.2.1.1.1.1 = i ∨ kv.2.1.1.1.2 = i) (λ k v, k -{1/2}>re v.2 )%I) ∗
    (big_sepFM trans (λ kv, (kv.2.1.1.1.1 = i ∨ kv.2.1.1.1.2 = i) ∧ kv.2.2 = false) (λ k v, k -{1/4}>t v.1 ∗ k -{1/2}>re v.2)%I).

  (* [transaction_pagetable_entries_owned]: transaction and page table entries that are owned initially by i,
     i.e. they are not transferred by VMProp, so we doesn't need to take care of them when reasoning the primary VM.
     As the invoker of sharing and lending transactions, i always has the ownership of involved pages.
     Therefore, i ownes these pagetable entries even if they are in some transactions.
     Furthermore, since it is suffice for the receiver to retrieve or relinquish with half of transacitons entries,
     while the sender needs full to reclaim, we let i always own half and only pass the otner half around with VMProp*)
  (* [TODO] relation to [pagetable_entries_excl_owned] *)
  Definition transaction_pagetable_entries_owned i (trans: gmap Addr transaction) : iProp Σ:=
    big_sepFM trans (λ kv, kv.2.1.1.1.1 = i ∧ kv.2.1.2 ≠ Donation) (λ k v, k -{1/4}>t v.1 ∗ pgt_1_4 v.1.1.2 v.1.1.1.1 (bool_decide (v.1.2 ≠ Sharing)))%I.

  Context (i : (leibnizO VMID)).

  (* [TODO] *)
  Definition retrieved_transaction_owned i (trans: gmap Addr transaction) : iProp Σ:=
    (big_sepFM trans (λ kv, kv.2.1.1.1.2 = i ∧ kv.2.2 = true) (λ k v, k -{1/4}>t v.1 ∗ k -{1/2}>re v.2)%I).

  Program Definition interp_execute: iPropO Σ :=
   (⌜i ≠ V0⌝ -∗
        (VMProp_holds i (1/2)%Qp -∗ WP ExecI @ i {{(λ _, True )}}))%I.

  (* [pagetable_entries_excl_owned]: For pages that are exclusively accessible and owned by i, i keeps the entries. *)
  Definition pagetable_entries_excl_owned (i:VMID) (ps: gset PID) := pgt ps 1 i true.

  (* [transaction_hpool_global_transferred]: All of half of transactions, as we don't know which one would be used by i. *)
  (* We need the pure proposition to ensure all transaction entries are transferred.
     Only half is needed so that the invokers can remember transactions by keeping the other half.*)
  Definition transaction_hpool_global_transferred (trans: gmap Addr transaction) : iProp Σ:=
    ∃ hpool,  ⌜hpool ∪ dom trans = valid_handles⌝ ∗ fresh_handles 1 hpool
       ∗ ([∗ map] h ↦ tran ∈ trans, h -{1/2}>t tran.1 ∗ pgt_3_4 tran.1.1.2 tran.1.1.1.1 (bool_decide (tran.1.2 ≠ Sharing))).

  (* [transferred_memory_pages]: some memory points-to predicates are transferred by VMProp.
      NOTE: we exclude the case when the type of transaction is lending and has been retrieved,
      as the associated memory pages in this case is exclusively owned by the receiver*)
  Definition transferred_memory_pages (trans : gmap Word transaction) :=
    pages_in_trans (filter (λ kv, (kv.2.1.1.1.1 = i ∨ kv.2.1.1.1.2 = i) ∧ ¬(kv.2.2 = true ∧ kv.2.1.2 = Lending)) trans).

  (* [retrieved_lending_memory_pages]: the memory of these pages are owned by the receiver *)
  Definition retrieved_lending_memory_pages (trans : gmap Word transaction) :=
    pages_in_trans (filter (λ kv, kv.2.1.1.1.2 = i ∧ (kv.2.2 = true ∧ kv.2.1.2 = Lending)) trans).

  (* [accessible_in_trans_memory_pages] (maybe) accessible memory pages associated with transactions *)
  Definition accessible_in_trans_memory_pages (trans : gmap Word transaction) :=
    pages_in_trans (filter (λ kv, (kv.2.1.1.1.1 = i ∧ ¬(kv.2.2 = true ∧ kv.2.1.2 = Lending)) ∨ kv.2.1.1.1.2 = i) trans).

  (* [currently_accessible_in_trans_memory_pages] currently accessible memory pages associated with transactions *)
  Definition currently_accessible_in_trans_memory_pages (trans : gmap Word transaction) :=
    pages_in_trans (filter (λ kv, (kv.2.1.1.1.1 = i ∧ kv.2.1.2 = Sharing) ∨ (kv.2.1.1.1.2 = i ∧ kv.2.2 = true)) trans).

  Definition trans_rel_wand (P : gmap Word transaction -d> iPropO Σ) (trans trans': gmap Word transaction ): iProp Σ:=
    □(P trans -∗ P trans').

  Definition trans_rel_eq (P : gmap Word transaction -> gset PID) (trans trans': gmap Word transaction ): Prop:=
    P trans = P trans'.

  Definition rx_state_match i os : iProp Σ :=
    match os with
    | None => RX_state@i := None ∗ ∃p_rx, RX@ i := p_rx ∗ (∃ mem_rx, memory_page p_rx mem_rx)
    | Some s => RX_state{1/2}@i := Some(s)
    end.

  Definition rx_states_global (rxs: gmap VMID (option (Word*VMID))) : iProp Σ :=
    [∗ map]i ↦ os ∈ rxs, rx_state_match i os.

  Definition rx_state_get (i:VMID) (rxs: gmap VMID (option (Word*VMID))) :iProp Σ:=
    ∀ rs, ⌜rxs !! i = Some rs⌝ -∗ RX_state@i := rs.

  (* (* [TODO] *) *)
  (* Definition return_reg_rx i (rs : option (Word * VMID)) (rxs :gmap VMID (option(Word*VMID))): iProp Σ:= *)
  (*   ((R0 @@ V0 ->r encode_hvc_func(Yield) ∨ *)
  (*     R0 @@ V0 ->r encode_hvc_func(Wait) ∗ ⌜rs = None⌝) *)
  (*    ∗ rx_states_global (delete i rxs) *)
  (*    ∗ R1 @@ V0 ->r encode_vmid(i) ∗ ∃ r2, R2 @@ V0 ->r r2) ∨ *)
  (*   (R0 @@ V0 ->r encode_hvc_func(Send) *)
  (*     ∗ ∃ l j, RX_state{1/2}@j := Some(l,i) ∗ (∃ p_rx, RX@ j := p_rx ∗ ∃ mem_rx, memory_page p_rx mem_rx) *)
  (*     ∗ rx_states_global (<[j:=Some(l,i)]>(delete i rxs)) ∗ ⌜rxs !! j = Some None⌝ *)
  (*     ∗ (∃r1, R1 @@ V0 ->r r1 ∗ ⌜decode_vmid r1 = Some j⌝) ∗  R2 @@ V0 ->r l). *)

  Definition only (trans: gmap Word transaction) := (filter (λ (kv :Word*transaction), (kv.2.1.1.1.1 = i ∨ kv.2.1.1.1.2 = i)) trans).

  Definition except (trans: gmap Word transaction) := (filter (λ (kv :Word*transaction), ¬(kv.2.1.1.1.1 = i ∨ kv.2.1.1.1.2 = i)) trans).

  (* [trans_rel_secondary] relates [trans], the transactions at the beginning of the proof, and
                [trans'], those at the point of switching to i. These assumptions are (I believe) necessary to prove FTLR.
                Moreover, they are provable because of that fact that i as the invoker is the only vm can manipulate
                the state of some transactions, and since, i is not scheduled during the time between starting pvm
                and switching to i, states of those transactions are immutable. *)
  Definition trans_rel_secondary (i:VMID) (trans trans': gmap Word transaction): Prop :=
    (λ tran, tran.1) <$> filter (λ kv, (kv.2.1.1.1.1 = i ∧ kv.2.1.2 ≠ Donation)) trans' =
    (λ tran, tran.1) <$> filter (λ kv, (kv.2.1.1.1.1 = i ∧ kv.2.1.2 ≠ Donation)) trans
    ∧
    (filter (λ kv, (kv.2.1.1.1.2 = i ∧ kv.2.2 = true)) trans') =
    (filter (λ kv, (kv.2.1.1.1.2 = i ∧ kv.2.2 = true)) trans).
  (* Definition trans_rel_pre (i:VMID) (trans trans': gmap Word transaction): Prop := *)
  (*   dom (filter (λ kv, (kv.2.1.1.1.1 = i ∧ kv.2.1.2 ≠ Donation)) trans') *)
  (*     ⊆ dom (filter (λ kv, (kv.2.1.1.1.1 = i ∧ kv.2.1.2 ≠ Donation)) trans) *)
  (*   ∧ *)
  (*   dom (filter (λ kv, (kv.2.1.1.1.2 = i ∧ kv.2.2 = true)) trans') *)
  (*   ⊆ dom (filter (λ kv, (kv.2.1.1.1.2 = i ∧ kv.2.2 = true)) trans). *)

(* Section vmprop. *)
(*   Context `{HypervisorConstants}. *)
(*   Context `{!HypervisorParameters}. *)
(*   Context `{vmG: !gen_VMG Σ}. *)
  (* Context (i : VMID). *)
  Context (Φ_t : (gmap Addr transaction) -> VMID -> VMID -> iProp Σ).
  Context (Φ_r : VMID -> option (Word * VMID)-> VMID -> iProp Σ).

  Definition rx_states_transferred (rxs: gmap VMID (option (Word*VMID))) : iProp Σ :=
    [∗ map]i ↦ os ∈ rxs, match os with
                           | None => True
                           | Some s => Φ_r i os V0
                          end.

  Definition rx_states_owned (rxs: gmap VMID (option (Word*VMID))) : iProp Σ :=
    [∗ map]i ↦ os ∈ rxs, match os with
                           | None => True
                           | Some s => if bool_decide (s.2 = V0) then Φ_r i os i else True
                          end.

  Definition return_reg_rx i (rs : option (Word * VMID)) (rxs :gmap VMID (option(Word*VMID))): iProp Σ:=
    ((R0 @@ V0 ->r encode_hvc_func(Yield) ∨
      R0 @@ V0 ->r encode_hvc_func(Wait) ∗ ⌜rs = None⌝)
     ∗ rx_states_global (delete i rxs)
     ∗ R1 @@ V0 ->r encode_vmid(i) ∗ ∃ r2, R2 @@ V0 ->r r2) ∨
    (R0 @@ V0 ->r encode_hvc_func(Send)
      ∗ ∃ l j, Φ_r j (Some (l,i)) V0
      ∗ rx_states_global (<[j:=Some(l,i)]>(delete i rxs)) ∗ ⌜rxs !! j = Some None⌝
      ∗ (∃r1, R1 @@ V0 ->r r1 ∗ ⌜decode_vmid r1 = Some j⌝) ∗  R2 @@ V0 ->r l).

  Definition vmprop_zero_pre (Ψ: (gmap Word transaction) -d> iPropO Σ) : (gmap Word transaction) -d> (gmap VMID (option(Word * VMID))) -d> iPropO Σ :=
    λ trans rxs, (∃ (trans' :gmap Word transaction) rs',
                     let trans_ret := (only trans') ∪ (except trans) in
                           ⌜dom (only trans') ## dom (except trans)⌝ ∗
                           ⌜∀ x, x ≠ i -> trans_rel_secondary x trans trans_ret⌝ ∗
                           transaction_hpool_global_transferred (trans_ret) ∗
                           big_sepSS_singleton set_of_vmids i (Φ_t trans_ret) ∗
                           rx_state_match i rs' ∗ Φ_r i rs' V0 ∗
                           return_reg_rx i rs' rxs ∗
                           VMProp i (Ψ trans_ret) (1/2)%Qp)%I.

  Definition vmprop_unknown_pre
    (Ψ :(gmap Word transaction) -d> iPropO Σ) : (gmap Word transaction) -d> iPropO Σ :=
   λ trans, (∃ (trans' : gmap Word transaction) (rxs : gmap VMID (option(Word * VMID))),
               ⌜trans_rel_secondary i trans trans'⌝ ∗
               (* transaction and pagetable entries *)
               transaction_hpool_global_transferred trans' ∗
               big_sepSS_singleton set_of_vmids i (Φ_t trans') ∗
               (∃ r0, R0 @@ V0 ->r r0 ∗ ⌜decode_hvc_func r0 = Some Run⌝) ∗ (∃ r1, R1 @@ V0 ->r r1 ∗ ⌜decode_vmid r1 = Some i⌝)∗ (∃ r2, R2 @@ V0 ->r r2) ∗
               (∀ rs : option (Addr * VMID), ⌜rxs !! i = Some rs⌝ -∗ rx_state_match i rs ∗ Φ_r i rs i) ∗
               (* rx pages for all other VMs *)
               (rx_states_global (delete i rxs)) ∗ ⌜is_total_gmap rxs⌝ ∗
               (* if i yielding, we give following resources back to pvm *)
               VMProp V0 (vmprop_zero_pre Ψ trans' rxs) (1/2)%Qp)%I.

  Local Instance vmprop_unknown_pre_contractive : Contractive (vmprop_unknown_pre).
  Proof.
    rewrite /vmprop_unknown_pre => n vmprop_unknown vmprop_unknown' Hvmprop_unknown trans /=.
    do 13 f_equiv.
    rewrite /VMProp /=.
    do 6 f_equiv.
    f_contractive.
    rewrite /vmprop_zero_pre.
    do 10 f_equiv.
    rewrite /VMProp.
    repeat f_equiv.
  Qed.

  Definition vmprop_unknown:= fixpoint (vmprop_unknown_pre).

  Definition vmprop_zero := vmprop_zero_pre vmprop_unknown.

  Lemma vmprop_unknown_eq trans: vmprop_unknown trans ⊣⊢
    (∃ (trans' : gmap Word transaction) (rxs : gmap VMID (option(Word * VMID))),
               ⌜trans_rel_secondary i trans trans'⌝ ∗
               (* transaction and pagetable entries *)
               transaction_hpool_global_transferred trans' ∗
               big_sepSS_singleton set_of_vmids i (Φ_t trans') ∗
               (∃ r0, R0 @@ V0 ->r r0 ∗ ⌜decode_hvc_func r0 = Some Run⌝) ∗ (∃ r1, R1 @@ V0 ->r r1 ∗ ⌜decode_vmid r1 = Some i⌝)∗ (∃ r2, R2 @@ V0 ->r r2) ∗
               (∀ rs : option (Addr * VMID), ⌜rxs !! i = Some rs⌝ -∗ rx_state_match i rs ∗ Φ_r i rs i) ∗
               (* rx pages for all other VMs *)
               (rx_states_global (delete i rxs)) ∗ ⌜is_total_gmap rxs⌝ ∗
               (* if i yielding, we give following resources back to pvm *)
          VMProp V0 (vmprop_zero trans' rxs) (1/2)%Qp)%I.
  Proof.
    rewrite /vmprop_unknown.
    apply (fixpoint_unfold vmprop_unknown_pre).
  Qed.

  (* Definition vmprop_zero_pre (Ψ: (gmap Word transaction) -d> iPropO Σ) : (gmap Word transaction) -d> (gmap VMID (option(Word*VMID))) -d> iPropO Σ := *)
  (*   λ trans rxs, (∃ trans' rs', *)
  (*                    let trans_ret := (only trans') ∪ (except trans) in *)
  (*                          ⌜dom (only trans') ## dom (except trans)⌝ ∗ *)
  (*                          ⌜∀ x, x ≠ i -> trans_rel_secondary x trans trans_ret⌝ ∗ *)
  (*                          (* transaction and pagetable entries *) *)
  (*                          transaction_hpool_global_transferred trans_ret ∗ *)
  (*                          transaction_pagetable_entries_transferred i trans_ret ∗ *)
  (*                          retrievable_transaction_transferred i trans_ret ∗ *)
  (*                          (* memory *) *)
  (*                          (∃ mem_trans, memory_pages (transferred_memory_pages trans_ret) mem_trans) ∗ *)
  (*                          (RX_state@i:= rs') ∗ (∃p_rx, RX@i := p_rx ∗ (∃ mem_rx, memory_page p_rx mem_rx)) ∗ *)
  (*                          return_reg_rx i rs' rxs ∗ *)
  (*                          VMProp i (Ψ trans_ret) (1/2)%Qp)%I. *)

  (* Definition vmprop_unknown_pre (Φ: (gmap Word transaction) -d> iPropO Σ) : (gmap Word transaction) -d> iPropO Σ := *)
  (*  λ trans, (∃ (trans' : gmap Word transaction) (rxs : gmap VMID (option(Word * VMID))), *)
  (*              ⌜trans_rel_secondary i trans trans'⌝ ∗ *)
  (*              (* transaction and pagetable entries *) *)
  (*              transaction_hpool_global_transferred trans' ∗ *)
  (*              transaction_pagetable_entries_transferred i trans' ∗ *)
  (*              retrievable_transaction_transferred i trans' ∗ *)
  (*              (* memory *) *)
  (*              (∃ mem_trans, memory_pages (transferred_memory_pages trans') mem_trans) ∗ *)
  (*              (∃ r0, R0 @@ V0 ->r r0 ∗ ⌜decode_hvc_func r0 = Some Run⌝) ∗ (∃ r1, R1 @@ V0 ->r r1 ∗ ⌜decode_vmid r1 = Some i⌝)∗ (∃ r2, R2 @@ V0 ->r r2) ∗ *)
  (*              (rx_state_get i rxs ∗ (∃p_rx, RX@i := p_rx ∗ (∃ mem_rx, memory_page p_rx mem_rx))) ∗ *)
  (*              (* rx pages for all other VMs *) *)
  (*              rx_states_global (delete i rxs) ∗ ⌜is_total_gmap rxs⌝ ∗ *)
  (*              (* if i yielding, we give following resources back to pvm *) *)
  (*              VMProp V0 (vmprop_zero_pre Φ trans' rxs) (1/2)%Qp)%I. *)

  (* Local Instance vmprop_unknown_pre_contractive : Contractive (vmprop_unknown_pre). *)
  (* Proof. *)
  (*   rewrite /vmprop_unknown_pre => n vmprop_unknown vmprop_unknown' Hvmprop_unknown trans /=. *)
  (*   do 15 f_equiv. *)
  (*   rewrite /VMProp /=. *)
  (*   do 6 f_equiv. *)
  (*   f_contractive. *)
  (*   rewrite /vmprop_zero_pre. *)
  (*   do 12 f_equiv. *)
  (*   rewrite /VMProp. *)
  (*   repeat f_equiv. *)
  (*   (* apply Hvmprop_unknown. *) *)
  (* Qed. *)

  (* Definition vmprop_unknown := fixpoint (vmprop_unknown_pre). *)

  (* Definition vmprop_zero := vmprop_zero_pre vmprop_unknown. *)

  (* Lemma vmprop_unknown_eq trans : vmprop_unknown trans ⊣⊢ *)
  (*   (∃ (trans' : gmap Word transaction) (rxs : gmap VMID (option(Word * VMID))), *)
  (*              ⌜trans_rel_secondary i trans trans'⌝ ∗ *)
  (*              (* transaction and pagetable entries *) *)
  (*              transaction_hpool_global_transferred trans' ∗ *)
  (*              transaction_pagetable_entries_transferred i trans' ∗ *)
  (*              retrievable_transaction_transferred i trans' ∗ *)
  (*              (* memory *) *)
  (*              (∃ mem_trans, memory_pages (transferred_memory_pages trans') mem_trans) ∗ *)
  (*              (∃ r0, R0 @@ V0 ->r r0 ∗ ⌜decode_hvc_func r0 = Some Run⌝) ∗ (∃ r1, R1 @@ V0 ->r r1 ∗ ⌜decode_vmid r1 = Some i⌝)∗ (∃ r2, R2 @@ V0 ->r r2) ∗ *)
  (*              (rx_state_get i rxs ∗ (∃p_rx, RX@i := p_rx ∗ (∃ mem_rx, memory_page p_rx mem_rx))) ∗ *)
  (*              (* rx pages for all other VMs *) *)
  (*              rx_states_global (delete i rxs) ∗ ⌜is_total_gmap rxs⌝ ∗ *)
  (*              (* if i yielding, we give following resources back to pvm *) *)
  (*              VMProp V0 (vmprop_zero trans' rxs) (1/2)%Qp)%I. *)
  (*   Proof. *)
  (*     rewrite /vmprop_unknown. *)
  (*     apply (fixpoint_unfold vmprop_unknown_pre). *)
  (*   Qed. *)

  Definition transferred_memory_slice (trans : gmap Addr transaction) (i: VMID) (j:VMID): iProp Σ:=
    big_sepFM trans (λ kv, (kv.2.1.1.1.1 = i ∧ kv.2.1.1.1.2 = j) ∧ ¬(kv.2.2 = true ∧ kv.2.1.2 = Lending)) (λ _ tran, (∃ mem , memory_pages tran.1.1.2 mem)%I).

  Definition retrievable_transaction_transferred_slice (trans : gmap Addr transaction) (i:VMID) (j: VMID) : iProp Σ :=
    (big_sepFM trans (λ kv, kv.2.1.1.1.1 = i ∧ kv.2.1.1.1.2 = j) (λ k v, k -{1/2}>re v.2 )%I) ∗
    (big_sepFM trans (λ kv, (kv.2.1.1.1.1 = i ∧ kv.2.1.1.1.2 = j) ∧ kv.2.2 = false) (λ k v, k -{1/4}>t v.1 ∗ k -{1/2}>re v.2)%I).

  Definition transaction_pagetable_entries_transferred_slice (trans: gmap Addr transaction) (i: VMID) (j: VMID) : iProp Σ :=
    big_sepFM trans (λ kv, (kv.2.1.1.1.1 = i ∧ kv.2.1.1.1.2 = j) ∧ kv.2.1.2 = Donation) (λ k v, k -{1/4}>t v.1 ∗ pgt_1_4 v.1.1.2 v.1.1.1.1 true)%I.

  Definition slice_transfer_all :=
    (λ trans i j, transaction_pagetable_entries_transferred_slice trans i j
                ∗ retrievable_transaction_transferred_slice trans i j
                ∗ transferred_memory_slice trans i j)%I.

  Definition slice_rx_state (j : VMID) (os : option (Word * VMID)) : iProp Σ :=
    (RX_state{1/2}@j := os) ∗ ∃ p_rx, RX@ j := p_rx ∗ (∃ mem_rx, memory_page p_rx mem_rx).

  Definition interp_access p_tx p_rx ps_acc trans: iPropO Σ:=
    (
      (* exclusively owned pages are pages i has access to, but ain't in any transactions related to i. *)
      (* [ps_oea], we exclude all pages involved in in-flight transactions,
       NOTE: it has to be (currently_accessible_in_trans_memory_pages)*)
      let ps_oea := ps_acc ∖ {[p_rx;p_tx]} ∖ (currently_accessible_in_trans_memory_pages trans) in
      ⌜∀ k j trans, (k = i ∨ j = i) -> Φ_t trans k j ⊣⊢ slice_transfer_all trans k j⌝ ∗
      ⌜∀ os, (match os with
                 | None => True
                 | _ => Φ_r i os i ⊣⊢ slice_rx_state i os
                end)⌝ ∗
      ⌜∀ os, (match os with
                 | None => True
                 | _ => Φ_r i os V0 ⊣⊢ slice_rx_state i os
                end)⌝ ∗
      ⌜∀ k os, (match os with
          | None => True
          | Some (_, j) => j = i -> Φ_r k os V0 ⊣⊢ slice_rx_state k os
          end)⌝ ∗
      ⌜∀ i j, Φ_r i None j ⊣⊢ True⌝ ∗
      (* registers *)
      (∃ regs, ⌜is_total_gmap regs⌝ ∗ [∗ map] r ↦ w ∈ regs, r @@ i ->r w) ∗
      (* TX page and its memory *)
      (tx_page i p_tx ∗ ∃ mem_tx, memory_page p_tx mem_tx) ∗
      rx_page i p_rx ∗
      (* access *)
      i -@A> ps_acc ∗
      ⌜{[p_tx;p_rx]} ⊆ ps_acc⌝ ∗ ⌜currently_accessible_in_trans_memory_pages trans ⊆ ps_acc ∖ {[p_tx;p_rx]}⌝ ∗
      pagetable_entries_excl_owned i ps_oea ∗
      transaction_pagetable_entries_owned i trans ∗
      retrieved_transaction_owned i trans ∗
      (∃ mem_oea, memory_pages (ps_oea ∪ (retrieved_lending_memory_pages trans)) mem_oea) ∗
      VMProp i (vmprop_unknown trans) (1/2)%Qp
    )%I.

End logrel.


Set Warnings "-notation-overridden".

From Equations Require Import Equations.
Unset Equations With Funext.

Require Import Category.Lib.
Require Import Category.Theory.
Require Import Category.Instance.Coq.

Require Import Embed.Theory.Functor.Void.
Require Import Embed.Theory.Functor.Refined.Def.
Require Import Embed.Theory.Functor.Refined.Iso.

Require Import Embed.Theory.Btree.
Require Import Embed.Theory.Btree.Functor.
Require Import Embed.Theory.Btree.Monad.

Require Import Embed.Theory.Btree.Refined.Iso.
Require Import Embed.Theory.Btree.Refined.Leaves.
Require Import Embed.Theory.Btree.Refined.Join.

Generalizable All Variables.
Set Universe Polymorphism.
Set Nested Proofs Allowed.

Lemma iso_refined_btree_void_ret {A} (x : @btree A)
  (pf : iso_refined (void[btree_Functor] x) (bnil ())) :
    { y | ret y = x}.
destruct x.
exact (exist _ a eq_refl).
unfold void in pf.
simpl in pf.
unfold ret_btree in pf.
rewrite fmap_btree_equation_2 in pf.
pose (not_iso_refined_bcons_bnil (fmap_btree (λ _ : A, ()) x1) (fmap_btree (λ _ : A, ()) x2)).
destruct (f pf).
Qed.

Lemma iso_refined_btree_void_ret_join {A} (x : @btree (@btree A))
  (pf : iso_refined (void x) (ret tt)) :
  ret (join x) = x.
destruct x.

reflexivity.

rewrite join_btree_equation_2.
destruct (iso_refined_btree_void_ret (bcons x1 x2) pf).
simpl in e.
unfold ret_btree in e.
discriminate.
Qed.

Lemma iso_refined_btree_void_join (x : @btree (@btree 1)) (y : @btree 1)
  (pf : iso_refined (join[btree_Functor] x) y) (A : Type) :
    @refined (Compose btree_Functor btree_Functor) x A ≅ refined y A.
pose (pf A).
exact (iso_compose _ (piso_refined_btree x)).
Defined.


Set Implicit Arguments.

Require Import AutoSep.

Definition NameNotInImports name imports :=
  fold_left
    (fun (b : bool) (p : string * string * assert) =>
       let '(m, _, _) := p in
       (b || (if string_dec m name then true else false))%bool)
    imports false = false.

Definition fst_2 A B C (x : A * B * C) := fst (fst x).
Notation fst2 := (@fst_2 _ _ _).

Lemma NotIn_NameNotInImports : forall imps mn, ~ In mn (map fst2 imps) -> NameNotInImports mn imps.
  clear.
  unfold NameNotInImports.
  induction imps; simpl; intros.
  eauto.
  destruct a; destruct p; simpl in *.
  destruct (string_dec s mn).
  contradict H.
  eauto.
  eapply IHimps.
  intuition.
Qed.

Definition f mod_name (mOpt : option (LabelMap.t unit))
           (p : string * assert *
                (forall imports : LabelMap.t assert,
                   importsGlobal imports -> cmd imports mod_name)) :=
  let '(modl, _, _) := p in
  match mOpt with
    | Some m =>
      let k := (modl, Local 0) in
      if LabelMap.mem (elt:=unit) k m
      then None
      else Some (LabelMap.add k tt m)
    | None => None
  end.

Definition NoDupFuncNames' init mod_name funcs :=
  match fold_left (@f mod_name) funcs (Some init)
  with
    | Some _ => True
    | None => False
  end.

Definition NoDupFuncNames := NoDupFuncNames' (LabelMap.empty unit).

Lemma NoDup_NoDupFuncNames' :
  forall mod_name funcs init,
    let names := map (fun f => fst (fst f)) funcs in
    NoDup names ->
    (forall x, List.In x names -> LabelMap.mem (elt := unit) (x, Local 0) init = false) ->
    @NoDupFuncNames' init mod_name funcs.
Proof.
  induction funcs; simpl; intuition.
  compute; eauto.
  unfold NoDupFuncNames' in *; simpl in *.
  erewrite H0 by eauto.
  eapply IHfuncs.
  inversion H; subst; eauto.
  intros.
  erewrite LabelFacts.add_neq_b.
  eapply H0.
  eauto.
  intuition.
  injection H2; intros.
  subst.
  inversion H; subst.
  contradiction.
Qed.

Lemma NoDup_NoDupFuncNames : forall mod_name funcs, NoDup (map (fun f => fst (fst f)) funcs) -> @NoDupFuncNames mod_name funcs.
  intros.
  eapply NoDup_NoDupFuncNames'.
  eauto.
  intros.
  eauto.
Qed.


Require Import Coq.Strings.String.
Require Import Coq.Lists.List.

Require Import MirrorSolve.FirstOrder.

Require Import MetaCoq.Template.All.
Require Import MirrorSolve.Reflection.Core.
Set Universe Polymorphism.

Require Import MirrorSolve.HLists.

MetaCoq Quote Definition c_True := True.
MetaCoq Quote Definition c_False := False.
MetaCoq Quote Definition c_eq := @eq.
MetaCoq Quote Definition c_not := @not.
MetaCoq Quote Definition c_or := @or.
MetaCoq Quote Definition c_and := @and.

Definition app_ty_info (f: term -> term) (x: predicate term) : predicate term :=
  {| puinst := x.(puinst); pparams := map f x.(pparams); pcontext := x.(pcontext); preturn := f x.(preturn) |}.

Definition app_branch (f: term -> term) (x: branch term) : branch term :=
  {| bcontext := x.(bcontext); bbody := f x.(bbody) |}.

Fixpoint dec_vars (d: nat) (t: term) : term :=
  match t with
  | tRel n => if (Nat.leb d n) then tRel (n - 1) else tRel n
  | tCast from kind to =>
    tCast (dec_vars d from) kind (dec_vars d to)
  | tProd na ty body =>
    let d' :=
      match na.(binder_name) with
      | nAnon => d
      | _ => S d
      end in
    tProd na (dec_vars d ty) (dec_vars d' body)
  | tLambda na ty body =>
    tLambda na (dec_vars d ty) (dec_vars (S d) body)
  | tLetIn na def def_ty body =>
    tLetIn na (dec_vars d def) (dec_vars d def_ty) (dec_vars (S d) body)
  | tApp f args =>
    tApp (dec_vars d f) (map (dec_vars d) args)
  | tCase c_info type_info discr branches =>
    tCase c_info (app_ty_info (dec_vars d) type_info) (dec_vars d discr) (List.map (app_branch (dec_vars d)) branches)
  | tProj proj t0 => tProj proj (dec_vars d t0)
  | _ => t
  end.

Fixpoint reindex_vars (t: term) : term :=
  match t with
  | tCast from kind to =>
    tCast (reindex_vars from) kind (reindex_vars to)
  | tProd na ty body =>
    let bod' := reindex_vars body in
    let bod'' :=
      match na.(binder_name) with
      | nAnon => dec_vars 0 bod'
      | _ => bod'
      end in
    tProd na (reindex_vars ty) bod''
  | tLambda na ty body =>
    tLambda na (reindex_vars ty) (reindex_vars body)
  | tLetIn na def def_ty body =>
    tLetIn na (reindex_vars def) (reindex_vars def_ty) (reindex_vars body)
  | tApp f args =>
    tApp (reindex_vars f) (map reindex_vars args)
  | tCase c_info type_info discr branches =>
    tCase c_info (app_ty_info reindex_vars type_info) (reindex_vars discr) (List.map (app_branch reindex_vars) branches)
  | tProj proj t0 => tProj proj (reindex_vars t0)
  | _ => t
  end.

Section ExtractFM.
  Variable (s: signature).
  Variable (m: model s).

  Variable (extract_t2tm : forall c, term -> list (option ({srt & (tm s c srt)})) -> option ({srt & (tm s c srt)})).
  Variable (extract_t2rel : forall c, term -> list (option ({srt & (tm s c srt)})) -> option (fm s c)).
  Variable (extract_t2srt : term -> option (sig_sorts s)).

  Variable (sort_eq_dec: EquivDec.EqDec (sig_sorts s) eq).

  Equations extract_var (c: ctx s) (n: nat) : option ({srt & var s c srt}) by struct c :=
    extract_var (Snoc _ _ ty) 0 := Some (ty; VHere _ _ ty);
    extract_var (Snoc _ c _) (S n) :=
      match extract_var c n with
      | Some (ty; v') => Some (ty; VThere _ _ _ _ v')
      | None => None
      end;
    extract_var SLNil _ := None.

  Fixpoint extract_t2tm' (c: ctx s) (t: term) : option ({srt & tm s c srt}) :=
    match t with
    | tRel n =>
      match extract_var c n with
      | Some (ty; v) => Some (ty; TVar v)
      | None => None
      end
    | tApp f es => extract_t2tm c t (map (extract_t2tm' c) es)
    | _ => extract_t2tm c t []
    end.

  Obligation Tactic := intros.
  Equations extract_t2fm (c: ctx s) (t: term) : option (fm _ c) by struct t :=
    extract_t2fm c t :=
      if eq_term t c_True then Some FTrue else
      if eq_term t c_False then Some FFalse else
      match t with
      | tApp f es =>
        if eq_term f c_eq then
          match es with
          | _ :: tl :: tr :: _ =>
            match extract_t2tm' c tl, extract_t2tm' c tr with
            | Some l, Some r =>
              let (sl, el) := l in
              let (sr, er) := r in
                match sort_eq_dec sl sr with
                | left HEq =>
                  Some (FEq el (eq_rect_r _ er HEq))
                | _ => None
                end
            | _, _ => None
            end
          | _ => None
          end
        else if eq_term f c_or then
          match es with
          | tl :: tr :: _ =>
            match extract_t2fm c tl, extract_t2fm c tr with
            | Some l, Some r => Some (@FOr _ c l r)
            | _, _ => None
            end
          | _ => None
          end
        else if eq_term f c_and then
          match es with
          | tl :: tr :: _ =>
            match extract_t2fm c tl, extract_t2fm c tr with
            | Some l, Some r => Some (@FAnd _ c l r)
            | _, _ => None
            end
          | _ => None
          end
        else if eq_term f c_not then
          match es with
          | x :: _ =>
            match extract_t2fm c x with
            | Some x' => Some (FNeg _ x')
            | None => None
            end
          | _ => None
          end
        else
          extract_t2rel c t (map (extract_t2tm' c) es)
      | tProd ba_name pre pst =>
        match ba_name.(binder_name) with
        | nAnon =>
          match extract_t2fm c pre, extract_t2fm c pst with
          | Some el, Some er => Some (FImpl el er)
          | _, _ => None
          end
        | nNamed _ =>
          let srt := extract_t2srt pre in
          match srt with
          | Some srt =>
            let c' := Snoc _ c srt in
            let inner := extract_t2fm c' pst in
            match inner with
            | Some fm => Some (FForall _ fm)
            | None => None
            end

          | None => None
          end
        end
      | _ =>
        extract_t2rel c t []
      end.

  Definition extract_fm t := extract_t2fm (SLNil _) (reindex_vars t).

  (* Some light tests *)
  Variable (c: ctx s).

  MetaCoq Quote Definition test_1 := (False -> True).
  MetaCoq Quote Definition test_2 := (True = False -> False).
  MetaCoq Quote Definition test_3 := (~ ~ False).
  MetaCoq Quote Definition test_4 := (False /\ True).
  MetaCoq Quote Definition test_5 := (forall (x y: unit), x = y -> y = x).
  MetaCoq Quote Definition test_6 := (forall (x: unit), True \/ False \/ ~ True).

  (*
  Eval vm_compute in extract_fm test_1.
  Eval vm_compute in extract_fm test_2.
  Eval vm_compute in extract_fm test_3.
  Eval vm_compute in extract_fm test_4.
  Eval vm_compute in extract_fm test_5.
  Eval vm_compute in extract_fm test_6. *)

End ExtractFM.

Section DenoteFM.

  Variable (s: signature).
  Variable (m: model s).

  Variable (sorts_eq_dec: EquivDec.EqDec (s.(sig_sorts)) eq).

  Notation res_ty := (option ({ty & mod_sorts s m ty})).
  Notation env_ty c := (valu s m c).

  Variable (denote_tm : term -> list res_ty -> res_ty).
  Variable (denote_rel: term -> list res_ty -> Prop).
  Variable (reify_srt : term -> option (s.(sig_sorts))).

  Fixpoint denote_var {c} (env: env_ty c) (n: nat) : res_ty :=
    match env, n with
    | VSnoc _ _ _ x, 0 => Some (_; x)
    | VSnoc _ _ env' _, S n' => denote_var env' n'
    | VEmp, _ => None
    end.

  Fixpoint denote_tm' {c} (env: env_ty c) (t: term) : res_ty :=
    match t with
    | tRel n =>
      match denote_var env n with
      | Some (ty; r) => Some (ty; r)
      | None => None
      end
    | tApp f es => denote_tm t (map (denote_tm' env) es)
    | _ => denote_tm t []
    end.

  Obligation Tactic := intros.
  Equations denote_t2fm {c} (env: env_ty c) (t: term) : Prop by struct t :=
    denote_t2fm env t :=
      if eq_term t c_True then True else
      if eq_term t c_False then False else
      match t with
      | tApp f es =>
        if eq_term f c_eq then
          match es with
          | _ :: tl :: tr :: _ =>
            match denote_tm' env tl, denote_tm' env tr with
            | Some l, Some r =>
              let (tl, el) := l in
              let (tr, er) := r in
                match sorts_eq_dec tl tr with
                | left HEq =>
                  (el = (eq_rect_r _ er HEq))
                | _ => False
                end
            | _, _ => False
            end
          | _ => False
          end
        else if eq_term f c_or then
          match es with
          | tl :: tr :: _ => denote_t2fm env tl \/ denote_t2fm env tr
          | _ => False
          end
        else if eq_term f c_and then
          match es with
          | tl :: tr :: _ => denote_t2fm env tl /\ denote_t2fm env tr
          | _ => False
          end
        else if eq_term f c_not then
          match es with
          | x :: _ => ~ denote_t2fm env x
          | _ => False
          end
        else
          denote_rel t (map (denote_tm' env) es)
      | tProd ba_name pre pst =>
        match ba_name.(binder_name) with
        | nAnon => denote_t2fm env pre -> denote_t2fm env pst
        | nNamed _ =>
          match reify_srt pre with
          | Some ty' =>
            forall x: (mod_sorts s m ty'),
              denote_t2fm (VSnoc _ _ ty' c env x) pst
          | None => False
          end
        end
      | _ => denote_rel t []
      end.

  Definition denote_fm t := denote_t2fm (VEmp _ _) (reindex_vars t).

  (* Eval vm_compute in denote_fm test_1.
  Eval vm_compute in denote_fm test_2.
  Eval vm_compute in denote_fm test_3.
  Eval vm_compute in denote_fm test_4.
  Eval vm_compute in denote_fm test_5.
  Eval vm_compute in denote_fm test_6. *)
End DenoteFM.


Require Import AutoSep.

Set Implicit Arguments.

Section TopLevel.

  Variable vars : list string.

  Variable var : option string.

  Definition is_state sp vs : HProp :=
    locals vars vs 0 (sp ^+ $8).

  Definition new_pre : assert :=
    x ~> ExX, Ex vs,
    ![^[is_state x#Sp vs] * #0]x.

  Require Import Semantics.

  Definition runs_to x_pre x :=
    forall specs other vs,
      interp specs (![is_state x_pre#Sp vs * other ] x_pre) ->
      Regs x Sp = x_pre#Sp /\
      interp specs (![is_state (Regs x Sp) (upd_option vs var x_pre#Rv) * other ] (fst x_pre, x)).

  Definition post (pre : assert) :=
    st ~> Ex st_pre,
    pre (fst st, st_pre) /\
    [| runs_to (fst st, st_pre) (snd st) |].

  Definition imply (pre new_pre: assert) := forall specs x, interp specs (pre x) -> interp specs (new_pre x).

  Definition syn_req :=
    match var with
      | Some x => List.In x vars
      | None => True
    end.

  Definition verifCond pre := imply pre new_pre :: syn_req :: nil.

  Variable imports : LabelMap.t assert.

  Variable imports_global : importsGlobal imports.

  Variable modName : string.

  Definition Strline := Straightline_ imports modName.

  Definition SaveRv lv := Strline (IL.Assign lv (RvLval (LvReg Rv)) :: nil).

  Definition vars_start := 4 * 2.
  Definition var_slot x := LvMem (Sp + (vars_start + variablePosition vars x)%nat)%loc.

  Definition Skip := Straightline_ imports modName nil.

  Definition body :=
    match var with
      | None => Skip
      | Some x => SaveRv (var_slot x)
    end.

  Require Import Wrap.

  Definition compile : cmd imports modName.
    refine (Wrap imports imports_global modName body post verifCond _ _).

    Lemma postOk : forall specs pre x,
      interp specs (Postcondition (body pre) x)
      -> imply pre new_pre
      -> syn_req
      -> exists x0, interp specs (pre (fst x, x0))
        /\ runs_to (fst x, x0) (snd x).
      intros.
      unfold syn_req, body, runs_to in *.
      destruct var; simpl in *; post.

      Focus 2.
      Transparent evalInstrs.
      simpl in H2.
      Opaque evalInstrs.
      injection H2; clear H2; intros; subst.
      descend; eauto.

      Opaque mult.

      Lemma evalInstrs_write_var : forall sm x s,
        evalInstrs sm x (Assign (var_slot s) Rv :: nil)
        = evalInstrs sm x (Assign (LvMem (Imm ((Regs x Sp ^+ natToW vars_start) ^+ natToW (variablePosition vars s)))) Rv :: nil).
        Transparent evalInstrs.
        simpl.
        intros.
        replace (Regs x Sp ^+ natToW (vars_start + variablePosition vars s))
          with (Regs x Sp ^+ natToW vars_start ^+ natToW (variablePosition vars s)); auto.
        rewrite natToW_plus.
        words.
        Opaque evalInstrs.
      Qed.

      rewrite evalInstrs_write_var in *.
      generalize H2; intro Hs.
      apply H0 in Hs; clear H0; post.
      clear_fancy.
      unfold vars_start in H3.
      change (4 * 2) with 8 in *.
      descend.
      eauto.
      clear H.
      unfold is_state in H0.
      evaluate auto_ext.
      destruct x; simpl in *.
      intuition.
      unfold is_state.
      step auto_ext.
    Qed.

    abstract (unfold verifCond; wrap0;
      match goal with
        | [ H : interp _ _ |- _ ] =>
          apply postOk in H; post; descend; eauto
      end).

    Lemma verifCondOk : forall pre,
      imply pre new_pre
      -> syn_req
      -> vcs (VerifCond (body pre)).
      unfold syn_req, body; intros.
      destruct var; wrap0.
      rewrite evalInstrs_write_var in *.
      apply H in H1; clear H; post.
      unfold is_state in H.
      unfold vars_start in *.
      change (4 * 2) with 8 in *.
      clear_fancy.
      evaluate auto_ext.
      Transparent evalInstrs.
      discriminate.
      Opaque evalInstrs.
    Qed.

    abstract (unfold verifCond; wrap0; eauto using verifCondOk).
 Defined.

End TopLevel.


Require Import Recdef.
Require Import VST.floyd.proofauto.
Local Open Scope logic.
Require Import List. Import ListNotations.

Require Import tweetnacl20140427.split_array_lemmas.
Require Import ZArith.
Local Open Scope Z.
Require Import tweetnacl20140427.tweetNaclBase.
Require Import tweetnacl20140427.Salsa20.
Require Import tweetnacl20140427.tweetnaclVerifiableC.
Require Import tweetnacl20140427.verif_salsa_base.

Require Import tweetnacl20140427.spec_salsa. Opaque Snuffle.Snuffle. Opaque fcore_result.

Definition X_content (x: SixteenByte * SixteenByte * (SixteenByte * SixteenByte))
                     (i:Z) (l:list val) : Prop :=
    l = upd_upto x (Z.to_nat i) (repeat Vundef 16).

Lemma XcontUpdate Nonce C Key1 Key2 i l
      (I: 0 <= i < 4)
      (L: X_content (Nonce, C, (Key1, Key2)) i l):
X_content (Nonce, C, (Key1, Key2)) (i + 1)
  (upd_Znth (11 + i)
     (upd_Znth (6 + i)
        (upd_Znth (1 + i)
           (upd_Znth (5 * i) l
              (Vint (littleendian (Select16Q C i))))
           (Vint (littleendian (Select16Q Key1 i))))
        (Vint (littleendian (Select16Q Nonce i))))
     (Vint (littleendian (Select16Q Key2 i)))).
Proof. unfold X_content in *.
  rewrite (Z.add_comm _ 1), Z2Nat.inj_add; try lia. simpl.
  rewrite Z2Nat.id; try lia. subst l; reflexivity.
Qed.

(*Issue : writing the lemma using the Delta := func_typcontext ...
  @semax CompSepcs Espec Delta ...
  leads to failure - but only 40 lines down, in the call to forward_call,
  where check_Delta now fails since it introduces a Delta0.
  I think we need to complement the line (
    Delta := @abbreviate tycontext (mk_tycontext _ _ _ _ _) |- _ => ...
  in checkDelta (checkDeltaOLD) with a second option,
  Delta := func_tycontext ... =>.
  Note that
  1. rerunning abbreviate_semax at that place (before calling forward_call)
     does not resolve the situation
  2. In the master-branch, we actually could write the lemma using Delta :=,
     so this is really an issue ith the new_compcert branch*)

Lemma f_core_loop1 (Espec : OracleKind) FR c k h nonce out w x y t
(data : SixteenByte * SixteenByte * (SixteenByte * SixteenByte))
(*(Delta := func_tycontext f_core SalsaVarSpecs SalsaFunSpecs) *):
@semax CompSpecs Espec
  (func_tycontext f_core SalsaVarSpecs SalsaFunSpecs nil) (*Delta*)
  (PROP  ()
   LOCAL  (lvar _t (tarray tuint 4) t; lvar _y (tarray tuint 16) y;
           lvar _x (tarray tuint 16) x; lvar _w (tarray tuint 16) w;
           temp _out out; temp _in nonce; temp _k k;
           temp _c c; temp _h (Vint (Int.repr h)))
   SEP  (FR; data_at_ Tsh (tarray tuint 16) x;
         CoreInSEP data (nonce, c, k)))

  (Sfor (Sset _i (Econst_int (Int.repr 0) tint))
     (Ebinop Olt (Etempvar _i tint) (Econst_int (Int.repr 4) tint) tint)
     (Ssequence
        (Ssequence
           (Scall (Some _t'1)
              (Evar _ld32
                 (Tfunction (Tcons (tptr tuchar) Tnil) tuint cc_default))
              [Ebinop Oadd (Etempvar _c (tptr tuchar))
                 (Ebinop Omul (Econst_int (Int.repr 4) tint)
                    (Etempvar _i tint) tint) (tptr tuchar)])
           (Sassign
              (Ederef
                 (Ebinop Oadd (Evar _x (tarray tuint 16))
                    (Ebinop Omul (Econst_int (Int.repr 5) tint)
                       (Etempvar _i tint) tint) (tptr tuint)) tuint)
              (Etempvar _t'1 tuint)))
        (Ssequence
           (Ssequence
              (Scall (Some _t'2)
                 (Evar _ld32
                    (Tfunction (Tcons (tptr tuchar) Tnil) tuint cc_default))
                 [Ebinop Oadd (Etempvar _k (tptr tuchar))
                    (Ebinop Omul (Econst_int (Int.repr 4) tint)
                       (Etempvar _i tint) tint) (tptr tuchar)])
              (Sassign
                 (Ederef
                    (Ebinop Oadd (Evar _x (tarray tuint 16))
                       (Ebinop Oadd (Econst_int (Int.repr 1) tint)
                          (Etempvar _i tint) tint) (tptr tuint)) tuint)
                 (Etempvar _t'2 tuint)))
           (Ssequence
              (Ssequence
                 (Scall (Some _t'3)
                    (Evar _ld32
                       (Tfunction (Tcons (tptr tuchar) Tnil) tuint cc_default))
                    [Ebinop Oadd (Etempvar _in (tptr tuchar))
                       (Ebinop Omul (Econst_int (Int.repr 4) tint)
                          (Etempvar _i tint) tint) (tptr tuchar)])
                 (Sassign
                    (Ederef
                       (Ebinop Oadd (Evar _x (tarray tuint 16))
                          (Ebinop Oadd (Econst_int (Int.repr 6) tint)
                             (Etempvar _i tint) tint) (tptr tuint)) tuint)
                    (Etempvar _t'3 tuint)))
              (Ssequence
                 (Scall (Some _t'4)
                    (Evar _ld32
                       (Tfunction (Tcons (tptr tuchar) Tnil) tuint cc_default))
                    [Ebinop Oadd
                       (Ebinop Oadd (Etempvar _k (tptr tuchar))
                          (Econst_int (Int.repr 16) tint) (tptr tuchar))
                       (Ebinop Omul (Econst_int (Int.repr 4) tint)
                          (Etempvar _i tint) tint) (tptr tuchar)])
                 (Sassign
                    (Ederef
                       (Ebinop Oadd (Evar _x (tarray tuint 16))
                          (Ebinop Oadd (Econst_int (Int.repr 11) tint)
                             (Etempvar _i tint) tint) (tptr tuint)) tuint)
                    (Etempvar _t'4 tuint))))))
     (Sset _i
        (Ebinop Oadd (Etempvar _i tint) (Econst_int (Int.repr 1) tint) tint)))
  (normal_ret_assert (
PROP  ()
   LOCAL  (temp _i (Vint (Int.repr 4)); lvar _t (tarray tuint 4) t;
   lvar _y (tarray tuint 16) y; lvar _x (tarray tuint 16) x;
   lvar _w (tarray tuint 16) w; temp _out out; temp _in nonce; temp _k k; temp _c c;
   temp _h (Vint (Int.repr h)))
   SEP  (FR;
         EX  l : list val, !!X_content data 4 l &&
                 data_at Tsh (tarray tuint 16) l x;
         CoreInSEP data (nonce, c, k)))).
Proof. intros. abbreviate_semax.
Time forward_for_simple_bound 4 (EX i:Z,
   PROP  ()
   LOCAL  (
   lvar _t (tarray tuint 4) t; lvar _y (tarray tuint 16) y;
   lvar _x (tarray tuint 16) x; lvar _w (tarray tuint 16) w;
   temp _out out; temp _in nonce; temp _k k; temp _c c; temp _h (Vint (Int.repr h)))
   SEP  (FR;
         EX l:_, !!(X_content data i l) && data_at Tsh (tarray tuint 16) l x;
         CoreInSEP data (nonce, c, k))). (*0.8 versus 2.1*)
{ Exists (repeat Vundef 16). Time entailer!. (*1.3 versus 4.2*) }
{ rename H into I.

  destruct data as ((Nonce, C), Key). unfold CoreInSEP.
  unfold SByte at 2. Intros X0; rename H into X0cont.

  freeze [0;2;4] FR1.
  freeze [0;1] FR2.

  assert (C16:= SixteenByte2ValList_Zlength C).
  remember (SplitSelect16Q C i) as FB; destruct FB as (Front, Back).
  Time assert_PROP (isptr c /\ field_compatible (Tarray tuchar 16 noattr) [] c) as FCc by entailer!. (*2.1 versus 3.7*)
  destruct FCc as [Pc FC]; apply isptrD in Pc; destruct Pc as [cb [coff CP]]; rewrite CP in *.
  destruct (Select_SplitSelect16Q_Zlength _ _ _ _ HeqFB I) as [FL _].

  rewrite (split3_data_at_Tarray_tuchar Tsh 16 (Zlength (QuadChunks2ValList Front))
        (Zlength (QuadChunks2ValList Front) + Zlength (QuadChunks2ValList [Select16Q C i])));
    repeat rewrite QuadChunk2ValList_ZLength;
    try rewrite FL; try rewrite <- C1; try rewrite Zlength_cons, Zlength_nil; try solve[simpl; lia].
  rewrite Zminus_plus. change (Z.succ 0) with 1. repeat rewrite Z.mul_1_r.
  rewrite (Select_SplitSelect16Q C i _ _ HeqFB) at 2.
  rewrite field_address0_offset by auto with field_compatible.
  rewrite field_address0_offset by auto with field_compatible. simpl.
  autorewrite with sublist.
  rewrite sublist_app2; (*. (4 * Zlength Front) (4 + 4 * Zlength Front)); *)
    repeat rewrite QuadChunk2ValList_ZLength; repeat rewrite FL.
    2: lia.
  rewrite Zminus_diag. rewrite Z.add_simpl_l. repeat rewrite Z.mul_1_l.
  Intros.
  freeze [1;3;0] FR3.
  rewrite (sublist0_app1 4), (sublist_same 0 4); try rewrite <- QuadByteValList_ZLength; try lia.

  (*Issue this is where the call fails if we use abbreviation Delta := ... in the statement of the lemma*)

  Time forward_call (offset_val (4 * i) (Vptr cb coff), Select16Q C i). (*3.4 versus 15.4*)
  (*{ goal automatically discharged versus 4.2 }*)

  thaw FR3.
  apply semax_pre with (P':=
  (PROP  ()
   LOCAL  ( temp _t'1 (Vint (littleendian (Select16Q C i)));
   temp _i (Vint (Int.repr i));
   lvar _t (tarray tuint 4) t; lvar _y (tarray tuint 16) y;
   lvar _x (tarray tuint 16) x; lvar _w (tarray tuint 16) w;
   temp _out out; temp _in nonce;temp _k k;
   temp _c c; temp _h (Vint (Int.repr h)))
   SEP
   (FRZL FR2; data_at Tsh (Tarray tuchar 16 noattr) (SixteenByte2ValList C) c))).
  { rewrite (Select_SplitSelect16Q C i _ _ HeqFB). unfold QByte.
    rewrite (split3_data_at_Tarray_tuchar Tsh 16 (Zlength (QuadChunks2ValList Front)) (Zlength (QuadChunks2ValList Front)+4)); trivial;
    repeat rewrite Zlength_app;
    repeat rewrite QuadChunk2ValList_ZLength;
(*    repeat rewrite FL; try rewrite BL; *)
    try rewrite <- QuadByteValList_ZLength; try rewrite Z.mul_1_r; try lia.
     2: destruct (Select_SplitSelect16Q_Zlength _ _ _ _ HeqFB I) as [_ BL]; rewrite FL, BL; lia.
    autorewrite with sublist.
    rewrite CP in *.
    rewrite field_address0_offset by auto with field_compatible.
    rewrite field_address0_offset by auto with field_compatible.
    Time entailer!. (*7.8*)
    simpl.
    rewrite app_nil_r.
    apply sepcon_derives. autorewrite with sublist.
      rewrite sublist_app2; repeat rewrite QuadChunk2ValList_ZLength; repeat rewrite FL; try lia.
      repeat rewrite Zminus_diag. rewrite Z.add_simpl_l.
      rewrite sublist_app1; try rewrite <- QuadByteValList_ZLength; try lia.
      rewrite sublist_same; try rewrite <- QuadByteValList_ZLength; try lia.
    rewrite Z.mul_1_l. apply derives_refl.
    rewrite sublist_app2; repeat rewrite QuadChunk2ValList_ZLength; repeat rewrite FL; try lia.
    repeat rewrite Z.add_simpl_l, app_nil_r in *.
    autorewrite with norm. apply derives_refl.
 }

  (*Store into x[...]*)
  thaw FR2.
  freeze [0;2] FR4.
  Time forward. (*2.5 versus 5.8*)

  destruct Key as [Key1 Key2].
  thaw FR4.
  Opaque ThirtyTwoByte.
  thaw FR1.
  freeze [0;1;3;4] FR5. Transparent ThirtyTwoByte.
  Time assert_PROP (field_compatible (Tarray tuchar 32 noattr) [] k) as FCK32
    by (unfold ThirtyTwoByte; entailer!). (*1.1 versus 5.1*)
  erewrite ThirtyTwoByte_split16; trivial. unfold SByte at 1. Opaque ThirtyTwoByte.
  simpl.
(*  Time normalize. (*2.2 versus 3.8*) *)
  Time assert_PROP (field_compatible (Tarray tuchar 16 noattr) [] k) as FCK16 by entailer!. (*1 versus 4.7*)
  assert (K1_16:= SixteenByte2ValList_Zlength Key1).
  remember (SplitSelect16Q Key1 i) as FB_K1. destruct FB_K1 as (Front_K1, Back_K1).
(*  rewrite (Select_SplitSelect16Q Key1 i _ _ HeqFB_K1).*)
  erewrite Select_Unselect_Tarray_at. (*; repeat rewrite <- K1_16; trivial.*)
    2: symmetry; apply (Select_SplitSelect16Q Key1 i _ _ HeqFB_K1).
    2: assumption.
    2: rewrite <- (Select_SplitSelect16Q Key1 i _ _ HeqFB_K1), <- K1_16; trivial.
    2: rewrite <- (Select_SplitSelect16Q Key1 i _ _ HeqFB_K1), <- K1_16; cbv; trivial.
  unfold Select_at. simpl. rewrite app_nil_r. flatten_sepcon_in_SEP.
  Intros.
  freeze FR6 := (Unselect_at _ _ _ _ _) (SByte _ _) (FRZL FR5).
  (*assert (FrontBackK1:= (Select_SplitSelect16Q_Zlength _ _ _ _ HeqFB_K1 I)) as [FLK BLK].*)
  rewrite <- QuadByteValList_ZLength. (*rewrite Z.mul_1_l. *)
  rewrite  QuadChunk2ValList_ZLength.
  destruct (Select_SplitSelect16Q_Zlength _ _ _ _ HeqFB_K1 I) as [FLK _]; rewrite FLK.

  Time forward_call (offset_val (4 * i) k,
                 Select16Q Key1 i). (*8.9 versus 19.5; both were 3-4 secs faster befor tick elimination etc*)

  thaw  FR6.
  apply semax_pre with (P':=
  (PROP  ()
   LOCAL  (temp _t'2 (Vint (littleendian (Select16Q Key1 i)));
   temp _i (Vint (Int.repr i));
   lvar _t (tarray tuint 4) t; lvar _y (tarray tuint 16) y;
   lvar _x (tarray tuint 16) x; lvar _w (tarray tuint 16) w; temp _in nonce;
   temp _out out; temp _c c; temp _k k; temp _h (Vint (Int.repr h)))
   SEP  (FRZL FR5; ThirtyTwoByte (Key1,Key2) k))).
  { erewrite ThirtyTwoByte_split16; trivial.
    repeat rewrite  <- QuadByteValList_ZLength; repeat rewrite QuadChunk2ValList_ZLength.
    Time entailer!. (*4.4 versus 6.6*)
    unfold SByte. rewrite (Select_SplitSelect16Q _ _ _ _ HeqFB_K1) in *.
    erewrite Select_Unselect_Tarray_at with (data:= QuadChunks2ValList Front_K1 ++
       QuadChunks2ValList [Select16Q Key1 (Zlength Front)(*i*)] ++ QuadChunks2ValList Back_K1); try reflexivity.
    + unfold QByte, Select_at. simpl. repeat rewrite app_nil_r.
      unfold Unselect_at.
      rewrite  QuadChunk2ValList_ZLength.
      rewrite <- QuadByteValList_ZLength, FLK. cancel.
    + assumption.
    + rewrite <- K1_16; assumption.
    + rewrite <- K1_16. cbv; trivial.
  }

  (*Store into x[...]*)
  thaw FR5.
  freeze [0;1;2;4] FR6.
  Time forward. (*2.8 versus 7.8*)

  (*Load nonce*)
  thaw FR6. freeze [0;2;3;4] FR7.
  unfold SByte at 1; simpl.
  assert (N16:= SixteenByte2ValList_Zlength Nonce).
  remember (SplitSelect16Q Nonce i) as FB_N; destruct FB_N as (Front_N, BACK_N).
    rewrite (Select_SplitSelect16Q _ i _ _ HeqFB_N) in *.
  Time assert_PROP (field_compatible (Tarray tuchar 16 noattr) [] nonce) as FCN by entailer!. (*1.2 versus 6.8*)
  erewrite Select_Unselect_Tarray_at with (d:=nonce); try reflexivity; try assumption.
  2: solve [rewrite <- N16; trivial].
  2: solve [rewrite <- N16; cbv; trivial].
  Intros.
  freeze FR8 := (Unselect_at _ _ _ _ _) (FRZL _).
  unfold Select_at. simpl. rewrite app_nil_r.
  rewrite <- QuadByteValList_ZLength. (*rewrite Z.mul_1_l.  simpl.*)
  rewrite  QuadChunk2ValList_ZLength.
  destruct (Select_SplitSelect16Q_Zlength _ _ _ _ HeqFB_N I) as [FrontN _]; rewrite FrontN.
  (*destruct (Select_SplitSelect16Q_Zlength _ _ _ _ HeqFB_N I) as [FrontN BackN].*)

  Time forward_call (offset_val (4 * i) nonce,
                 Select16Q Nonce i). (*11.7 versus 21*)

  thaw FR8.
  apply semax_pre with (P':=
  (PROP  ()
   LOCAL  (
   temp _t'3 (Vint (littleendian (Select16Q Nonce i)));
   temp _i (Vint (Int.repr i));
   lvar _t (tarray tuint 4) t; lvar _y (tarray tuint 16) y;
   lvar _x (tarray tuint 16) x; lvar _w (tarray tuint 16) w; temp _out out; temp _in nonce;
   temp _k k; temp _c c; temp _h (Vint (Int.repr h)))
   SEP (FRZL FR7; SByte Nonce nonce))).
  { Time entailer!. (*1.8 versus 9.5*)

    (*Apart from the unfold QByte, the next 9 lines are exactly as above, inside the function call*)
    unfold SByte. rewrite (Select_SplitSelect16Q _ _ _ _ HeqFB_N) in *.
    erewrite Select_Unselect_Tarray_at; try reflexivity; try assumption.
    + unfold QByte, Select_at. simpl. rewrite app_nil_r. cancel.
      rewrite <- QuadByteValList_ZLength. (*rewrite Z.mul_1_l. simpl.*)
      rewrite  QuadChunk2ValList_ZLength.
      (*destruct (Select_SplitSelect16Q_Zlength _ _ _ _ HeqFB_N I) as [FrontN _]; rewrite FrontN; cancel.*)
      rewrite FrontN; cancel.
    + rewrite <- N16; trivial.
    + rewrite <- N16; cbv; trivial. }

  (*Store into x[...]*)
  thaw FR7. freeze [0;1;2;4] FR9.
  Time forward. (*3.2 versus 15*)

  (*Load Key2*)
  thaw FR9. freeze [0;1;3;4] FR10.
  rewrite ThirtyTwoByte_split16; trivial. simpl. Intros.
  unfold SByte at 2.
  assert (K2_16:= SixteenByte2ValList_Zlength Key2).
  Time assert_PROP (isptr k/\ field_compatible (Tarray tuchar 16 noattr) [] (offset_val 16 k))
     as Pk_FCK2 by entailer!. (*1.4 versus 6.6*)
  destruct Pk_FCK2 as [Pk FCK2]; apply isptrD in Pk; destruct Pk as [kb [koff Pk]]; rewrite Pk in *.
  remember (SplitSelect16Q Key2 i) as FB_K2; destruct FB_K2 as (Front_K2, Back_K2).
  rewrite (Select_SplitSelect16Q _ i _ _ HeqFB_K2) in *.
  erewrite Select_Unselect_Tarray_at with (d:=offset_val 16 (Vptr kb koff)); try reflexivity; try assumption.
  2: solve [rewrite <- K2_16; trivial]. 2: solve [rewrite <- K2_16; cbv; trivial].
  Intros.
  Time normalize. (*1.4 versus 6.6*)
  unfold Select_at. simpl. rewrite app_nil_r.
  repeat rewrite <- QuadByteValList_ZLength.
  rewrite QuadChunk2ValList_ZLength.
  freeze FR11 := (Unselect_at _ _ _ _ _) (SByte _ _) (FRZL FR10).
  Time forward_call (Vptr kb
           (Ptrofs.add (Ptrofs.add koff (Ptrofs.repr 16)) (Ptrofs.repr (4 * Zlength Front_K2))),
                 Select16Q Key2 i). (*8.9 versus 20.5 SLOW*)
  { destruct (Select_SplitSelect16Q_Zlength _ _ _ _ HeqFB_K2 I) as [FK2 _]; rewrite FK2.
     apply prop_right; simpl. unfold Ptrofs.of_ints; simpl. autorewrite with norm. auto. }

  thaw FR11.
  apply semax_pre with (P':=
  (PROP  ()
   LOCAL  (
   temp _t'4 (Vint (littleendian (Select16Q Key2 i)));
   temp _i (Vint (Int.repr i));
   lvar _t (tarray tuint 4) t; lvar _y (tarray tuint 16) y;
   lvar _x (tarray tuint 16) x; lvar _w (tarray tuint 16) w; temp _in nonce;
   temp _out out; temp _c c; temp _k k; temp _h (Vint (Int.repr h)))
   SEP  (FRZL FR10; ThirtyTwoByte (Key1,Key2) k))).
  { rewrite Pk in *. erewrite ThirtyTwoByte_split16 by assumption.
    Time entailer!. (*4.6 versus 7.4*)
    simpl. cancel.

    (*Apart from the unfold QByte, the next 9 lines are exactly as above, inside the function call*)
    unfold SByte. rewrite (Select_SplitSelect16Q _ _ _ _ HeqFB_K2) in *.
    erewrite Select_Unselect_Tarray_at; try reflexivity; try assumption.
    + unfold QByte, Select_at. simpl. repeat rewrite app_nil_r. cancel.
      rewrite <- QuadByteValList_ZLength. (*rewrite Z.mul_1_l. simpl.*)
      rewrite  QuadChunk2ValList_ZLength. rewrite Ptrofs.add_assoc. rewrite ptrofs_add_repr. cancel.
    + rewrite <- K2_16; assumption.
    + rewrite <- K2_16; cbv; trivial. }

  (*Store into x[...]*)
  thaw FR10. freeze [0;1;2;4] FR11.
  Time forward. (*4.3 versus 14.7*) clear FL.

  Time entailer!. (*4.9 versus 16.1*)  remember (Zlength Front_K1) as i.
  Exists (upd_Znth (11 + i)
     (upd_Znth (6 + i)
        (upd_Znth (1 + i)
           (upd_Znth (5 * i) X0
              (Vint (littleendian (Select16Q C i))))
           (Vint (littleendian (Select16Q Key1 i))))
        (Vint (littleendian (Select16Q Nonce i))))
     (Vint (littleendian (Select16Q Key2 i)))).
  Time entailer!. (*2 versus 2.8  - penalty*)
    clear - X0cont I. apply XcontUpdate; trivial.

  thaw FR11. simpl. Time cancel. (*0.3*)
 }
apply andp_left2; apply derives_refl.
Time Qed. (*VST 20.: 5.5s*) (* 19.046 secs (17.109u,0.015s) (successful)*)

Lemma XX data l: X_content data 4 l ->
  l = match data with ((Nonce, C), (Key1, Key2)) =>
          match Nonce with (N1, N2, N3, N4) =>
          match C with (C1, C2, C3, C4) =>
          match Key1 with (K1, K2, K3, K4) =>
          match Key2 with (L1, L2, L3, L4) =>
      map Vint (map littleendian [C1; K1; K2; K3;
                                  K4; C2; N1; N2;
                                  N3; N4; C3; L1;
                                  L2; L3; L4; C4])
      end end end end end.
Proof.
intros. red in H. subst l.
apply upd_upto_char. reflexivity.
Qed.


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

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

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

Set Implicit Arguments.

Section IssueStepHelper.

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

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

Notation "'E'" := G.(acts_set).
Notation "'R'" := (fun a => is_true (is_r lab a)).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'F'" := (fun a => is_true (is_f lab a)).
Notation "'Loc_' l" := (fun x => loc lab x = Some l) (at level 1).
Notation "'Tid_' t" := (fun x => tid x = t) (at level 1).
Notation "'W_'" := (fun l => W ∩₁ Loc_ l).
(* Notation "'RW'" := (fun x => R x \/ W x). *)
Notation "'FR'" := (fun x => F x \/ R x).
Notation "'FW'" := (fun x => F x \/ W x).

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

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

Variable IMMCON : imm_consistent G sc.

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

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

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

Variable PC : Configuration.t.
Hypothesis THREAD : forall e (ACT : E e) (NINIT : ~ is_init e),
    exists langst, IdentMap.find (tid e) PC.(Configuration.threads) = Some langst.

Variable smode : sim_mode.
Hypothesis SC_REQ :
  smode = sim_normal ->
  forall (l : Loc.t),
    max_value f_to (S_tm G l (covered T)) (LocFun.find l PC.(Configuration.sc)).

Variable thread : thread_id.
Variable local : Local.t.
Hypothesis SIM_PROM     : sim_prom     G sc T   f_to f_from thread local.(Local.promises).
Hypothesis SIM_RES_PROM : sim_res_prom G    T S f_to f_from thread local.(Local.promises).

Hypothesis CLOSED_SC : Memory.closed_timemap PC.(Configuration.sc) PC.(Configuration.memory).

Hypothesis PROM_DISJOINT :
  forall thread' langst' local'
         (TNEQ : thread <> thread')
         (TID' : IdentMap.find thread' PC.(Configuration.threads) =
                 Some (langst', local')),
  forall loc to,
    Memory.get loc to local .(Local.promises) = None \/
    Memory.get loc to local'.(Local.promises) = None.

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

Hypothesis INHAB      : Memory.inhabited (Configuration.memory PC).
Hypothesis CLOSED_MEM : Memory.closed (Configuration.memory PC).
Hypothesis PLN_RLX_EQ : pln_rlx_eq local.(Local.tview).
Hypothesis MEM_CLOSE : memory_close local.(Local.tview) PC.(Configuration.memory).

Hypothesis RESERVED_TIME:
  reserved_time G T S f_to f_from smode PC.(Configuration.memory).

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

Hypothesis SIM_MEM : sim_mem G sc T f_to f_from thread local PC.(Configuration.memory).
Hypothesis SIM_TVIEW : sim_tview G sc (covered T) f_to local.(Local.tview) thread.
Hypothesis RMWREX : dom_rel rmw ⊆₁ R_ex lab.

Lemma issue_step_helper_next w wnext valw locw ordw langst
      (TID : IdentMap.find (tid w) PC.(Configuration.threads) = Some (langst, local))
      (NWEX : ~ W_ex w)
      (NISSB : ~ issued T w)
      (ISSUABLE : issuable G sc T w)
      (NEXT : dom_sb_S_rfrmw G (mkETC T S) rfi (eq w) wnext)
      (LOC : loc lab w = Some locw)
      (VAL : val lab w = Some valw)
      (ORD : mod lab w = ordw)
      (WTID : thread = tid w) :
  let promises := local.(Local.promises) in
  let memory   := PC.(Configuration.memory) in
  let sc_view  := PC.(Configuration.sc) in
  let covered' := if Rel w then covered T ∪₁ eq w else covered T in
  let T'       := mkTC covered' (issued T ∪₁ eq w) in
  let S'       := S ∪₁ eq w ∪₁ dom_sb_S_rfrmw G (mkETC T S) rfi (eq w) in
  exists p_rel,
    rfrmw_prev_rel G sc T f_to f_from PC.(Configuration.memory) w locw p_rel /\
    (⟪ FOR_ISSUE :
         exists f_to' f_from',
           let rel'' :=
               if is_rel lab w
               then (TView.cur (Local.tview local))
               else (TView.rel (Local.tview local) locw)
           in
           let rel' := (View.join (View.join rel'' p_rel.(View.unwrap))
                                  (View.singleton_ur locw (f_to' w))) in
           ⟪ RELWFEQ : View.pln rel' = View.rlx rel' ⟫ /\
           ⟪ REL_VIEW_LT : Time.lt (View.rlx rel'' locw) (f_to' w) ⟫ /\
           ⟪ REL_VIEW_LE : Time.le (View.rlx rel'  locw) (f_to' w) ⟫ /\

           ⟪ REQ_TO : forall e (SE : S e), f_to' e = f_to e ⟫ /\
           ⟪ REQ_FROM : forall e (SE : S e), f_from' e = f_from e ⟫ /\
           ⟪ ISSEQ_TO   : forall e (ISS: issued T e), f_to' e = f_to e ⟫ /\
           ⟪ ISSEQ_FROM : forall e (ISS: issued T e), f_from' e = f_from e ⟫ /\
           ⟪ FTOWNBOT     : f_to' w <> Time.bot ⟫ /\
           ⟪ FTOWNEXTNBOT : f_to' wnext <> Time.bot ⟫ /\
           << FTONEXTNEQ  : f_to' w <> f_to' wnext >> /\

           exists promises_add memory_add promises_rel promises_add2 memory',
             ⟪ PADD :
                 Memory.add local.(Local.promises) locw (f_from' w) (f_to' w)
                            (Message.full valw (Some rel')) promises_add ⟫ /\
             ⟪ MADD :
                 Memory.add memory locw (f_from' w) (f_to' w)
                            (Message.full valw (Some rel')) memory_add ⟫ /\

             ⟪ PEQ :
                 if Rel w
                 then Memory.remove promises_add locw (f_from' w) (f_to' w)
                                    (Message.full valw (Some rel')) promises_rel
                 else promises_rel = promises_add ⟫ /\

             ⟪ PADD2 :
                 Memory.add promises_rel locw (f_from' wnext) (f_to' wnext)
                            Message.reserve promises_add2 ⟫ /\
             ⟪ MADD2 :
                 Memory.add memory_add locw (f_from' wnext) (f_to' wnext)
                            Message.reserve memory' ⟫ /\

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

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

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

             ⟪ RESERVED_TIME :
                 reserved_time G T' S' f_to' f_from' smode memory' ⟫ /\

             ⟪ MEM_PROMISE :
                 Memory.promise (Local.promises local) memory locw (f_from' w) (f_to' w)
                                (Message.full valw (Some rel'))
                                promises_add memory_add Memory.op_kind_add ⟫ /\

             ⟪ MEM_PROMISE2 :
                 Memory.promise promises_rel memory_add locw (f_from' wnext) (f_to' wnext)
                                Message.reserve
                                promises_add2 memory' Memory.op_kind_add ⟫ /\

             ⟪ OLD_PROM_IN_NEW_PROM : Memory.le (Local.promises local) promises_add2 ⟫ /\
             ⟪ NEW_PROM_IN_MEM      : Memory.le promises_add2 memory' ⟫ /\

             let tview' := if is_rel lab w
                           then TView.write_tview
                                  (Local.tview local) sc_view locw
                                  (f_to' w) (Event_imm_promise.wmod ordw)
                           else (Local.tview local) in
             let local' := Local.mk tview' promises_add2 in
             let threads' :=
                 IdentMap.add (tid w)
                              (langst, local')
                              (Configuration.threads PC) in

             ⟪ THREAD : forall e (ACT : E e) (NINIT : ~ is_init e),
                 exists langst, IdentMap.find (tid e) threads' = Some langst ⟫ /\

             ⟪ SC_REQ : smode = sim_normal ->
                        forall (l : Loc.t),
                          max_value
                            f_to' (S_tm G l covered') (LocFun.find l sc_view) ⟫ /\
             ⟪ CLOSED_SC : Memory.closed_timemap sc_view memory' ⟫ /\

             ⟪ PROM_IN_MEM :
                 forall thread' langst local
                        (TID : IdentMap.find thread' threads' = Some (langst, local)),
                   Memory.le (Local.promises local) memory' ⟫ /\

             ⟪ SIM_PROM     : sim_prom G sc T' f_to' f_from' (tid w) promises_add2  ⟫ /\
             ⟪ SIM_RES_PROM : sim_res_prom G T' S' f_to' f_from' (tid w) promises_add2  ⟫ /\

             ⟪ PROM_DISJOINT :
                 forall thread' langst' local'
                        (TNEQ : tid w <> thread')
                        (TID' : IdentMap.find thread' threads' =
                                Some (langst', local')),
                 forall loc to,
                   Memory.get loc to promises_add2 = None \/
                   Memory.get loc to (Local.promises local') = None ⟫ /\

             ⟪ SIM_MEM     : sim_mem G sc T' f_to' f_from' (tid w) local' memory' ⟫ /\
             ⟪ SIM_RES_MEM : sim_res_mem G T' S' f_to' f_from' (tid w) local' memory' ⟫ /\
             ⟪ NOWLOC : Rel w -> Memory.nonsynch_loc locw (Local.promises local') ⟫
     ⟫).
Proof using All.
  assert (tc_coherent G sc T) as TCCOH by apply ETCCOH.
  assert (complete G) as COMPL by apply IMMCON.
  assert (sc_per_loc G) as SPL by (apply coherence_sc_per_loc; apply IMMCON).

  assert (NSW : ~ S w).
  { intros HH. apply NWEX. apply ETCCOH. by split. }

  assert (S ⊆₁ E ∩₁ W) as SEW.
  { apply set_subset_inter_r. split; [by apply ETCCOH|].
    apply (reservedW WF ETCCOH). }
  assert (E w /\ W w) as [EW WW] by (by apply ISSUABLE).
  assert (~ covered T w) as NCOVB.
  { intros AA. apply NISSB. eapply w_covered_issued; eauto. by split. }
  assert (~ is_init w) as WNINIT.
  { intros HH. apply NCOVB. eapply init_covered; eauto. by split. }

  forward (eapply dom_sb_S_rfrmw_single_props with (w:=w) (wnext:=wnext)); eauto.
  intros HH. desc.
  assert (w <> wnext) as WNEXTNEQ.
  { intros HH. subst. eapply WF.(co_irr); eauto. }

  subst.
  edestruct exists_time_interval_for_issue_next as [p_rel [PREL HH]]; eauto.
  red in HH. desc. exists p_rel. splits; eauto.
  exists f_to', f_from'. splits; eauto.
  exists promises_add, memory_add, promises_rel.
  exists promises', memory'.

  assert (Time.lt (f_to' w) (f_to' wnext)) as FLT.
  { eapply f_to_co_mon; eauto; basic_solver. }

  set (rel'' :=
        if is_rel lab w
        then (TView.cur (Local.tview local))
        else (TView.rel (Local.tview local) locw)).
  set (rel' := (View.join (View.join rel'' p_rel.(View.unwrap))
                          (View.singleton_ur locw (f_to' w)))).

  set (S':=S ∪₁ eq w ∪₁ dom_sb_S_rfrmw G (mkETC T S) rfi (eq w)).
  assert (S ⊆₁ S') as SINS by (unfold S'; eauto with hahn).
  assert (S' ⊆₁ E ∩₁ W) as SEW'.
  { subst S'. rewrite SEW at 1. unionL; eauto with hahn.
    { unfolder. ins. desf. }
    intros x HH.
    assert (x = wnext); subst.
    2: by split.
    eapply dom_sb_S_rfrmwf; eauto. }
  assert (S' w) as SW'.
  { red. basic_solver. }
  assert (S' wnext) as SWNEXT'.
  { red. basic_solver. }

  assert (Memory.le promises_add memory_add) as PP'.
  { eapply memory_le_add2; eauto. }
  assert (Memory.le promises' memory') as PP.
  { eapply memory_le_add2. 2,3: by eauto.
    destruct (Rel w); subst; auto.
    etransitivity; [|by apply PP'].
    eapply memory_remove_le; eauto. }

  assert (forall thread' langst' local' (TNEQ : tid w <> thread')
                 (TID' : IdentMap.find thread' (Configuration.threads PC) =
                         Some (langst', local')),
             Memory.get locw (f_to' w) (Local.promises local') = None) as NINTER.
  (* TODO: Move to IssueInterval.v? *)
  { ins.
    destruct (Memory.get locw (f_to' w) (Local.promises local')) eqn:HH; auto.
    exfalso. destruct p as [from].
    eapply PROM_IN_MEM in HH; eauto.
    set (AA := HH). apply Memory.get_ts in AA.
    destruct AA as [|AA]; desc; eauto.
    apply DISJOINT in HH.
    apply HH with (x:=f_to' w); constructor; simpls; try reflexivity.
    apply FCOH0; auto. }

  assert (forall thread' langst' local' (TNEQ : tid w <> thread')
                 (TID' : IdentMap.find thread' (Configuration.threads PC) =
                         Some (langst', local')),
             Memory.get locw (f_to' wnext) (Local.promises local') = None) as NINTER'.
  (* TODO: Move to IssueInterval.v? *)
  { ins.
    destruct (Memory.get locw (f_to' wnext) (Local.promises local')) eqn:HH; auto.
    exfalso. destruct p as [from].
    eapply PROM_IN_MEM in HH; eauto.
    set (AA := HH). apply Memory.get_ts in AA.
    destruct AA as [|AA]; desc; eauto.
    apply DISJOINT' in HH.
    apply HH with (x:=f_to' wnext); constructor; simpls; try reflexivity.
    apply FCOH0; auto. }

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

  (* assert (Memory.le promises'' promises') as LEPADD. *)
  (* { destruct (Rel w) eqn:RELB; subst; [|reflexivity]. *)
  (*   eapply memory_remove_le; eauto. } *)

  (* assert (Memory.le promises'' memory') as NEW_PROM_IN_MEM. *)
  (* { etransitivity; eauto. } *)

  (* assert (forall l to from msg  *)
  (*                (NEQ : l <> locw \/ to <> f_to w), *)
  (*            Memory.get l to promises_cancel = Some (from, msg) <-> *)
  (*            Memory.get l to local.(Local.promises) = Some (from, msg)) *)
  (*   as NOTNEWC. *)
  (* { ins. erewrite Memory.remove_o; eauto. *)
  (*   rewrite loc_ts_eq_dec_neq; auto. } *)

  assert (forall l to from msg
                 (NEQ  : l <> locw \/ to <> f_to' w)
                 (NEQ' : l <> locw \/ to <> f_to' wnext),
             Memory.get l to memory' = Some (from, msg) <->
             Memory.get l to PC.(Configuration.memory) = Some (from, msg))
    as NOTNEWM.
  { ins. repeat (erewrite Memory.add_o; eauto; rewrite loc_ts_eq_dec_neq; auto). }

  assert (forall l to from msg
                 (NEQ  : l <> locw \/ to <> f_to' w)
                 (NEQ' : l <> locw \/ to <> f_to' wnext),
             Memory.get l to promises_rel = Some (from, msg) <->
             Memory.get l to local.(Local.promises) = Some (from, msg))
    as NOTNEWR.
  { ins.
    destruct (Rel w); subst.
    erewrite Memory.remove_o; eauto; rewrite loc_ts_eq_dec_neq; auto.
    all: erewrite Memory.add_o; eauto; rewrite loc_ts_eq_dec_neq; auto. }

  assert (forall l to from msg
                 (NEQ  : l <> locw \/ to <> f_to' w)
                 (NEQ' : l <> locw \/ to <> f_to' wnext),
             Memory.get l to promises' = Some (from, msg) <->
             Memory.get l to local.(Local.promises) = Some (from, msg))
    as NOTNEWA.
  { ins.
    erewrite Memory.add_o; eauto; rewrite loc_ts_eq_dec_neq; auto. }

  assert (~ Rel w ->
          Memory.get locw (f_to' w) promises' =
          Some (f_from' w, Message.full valw (Some rel')))
    as INP''.
  { ins. destruct (Rel w); subst; [by desf|].
    erewrite Memory.add_o; eauto. rewrite loc_ts_eq_dec_neq; eauto.
    erewrite Memory.add_o; eauto. by rewrite loc_ts_eq_dec_eq. }

  assert (RESGET' :
            Memory.get locw (f_to' wnext) promises' =
            Some (f_from' wnext, Message.reserve)).
  { by erewrite Memory.add_o; eauto; rewrite loc_ts_eq_dec_eq. }

  (* assert (RESGET : *)
  (*           Memory.get locw (f_to' wnext) promises'' = *)
  (*           Some (f_from' wnext, Message.reserve)). *)
  (* { destruct (Rel w) eqn:RELB; subst. *)
  (*   erewrite Memory.remove_o; eauto. rewrite loc_ts_eq_dec_neq; eauto. *)
  (*   all: by erewrite Memory.add_o; eauto; rewrite loc_ts_eq_dec_eq. } *)

  assert (PROMGET :
            Memory.get locw (f_to' w) promises' = None \/
            exists rel,
              Memory.get locw (f_to' w) promises' =
              Some (f_from' w, Message.full valw rel)).
  { erewrite Memory.add_o; eauto. rewrite loc_ts_eq_dec_neq; eauto.
    destruct (Rel w) eqn:RELB; subst.
    { erewrite Memory.remove_o; eauto. rewrite loc_ts_eq_dec_eq; eauto. }
    erewrite Memory.add_o; eauto. rewrite loc_ts_eq_dec_eq; eauto. }

  assert (Memory.le (Local.promises local) promises_add) as OLD_PROM_IN_PROM_ADD.
  { eapply memory_add_le; eauto. }

  assert (Memory.le (Local.promises local) promises') as OLD_PROM_IN_PROM_REL.
  { etransitivity; [|by eapply memory_add_le; eauto].
    destruct (Rel w); subst; auto.
    red. ins. erewrite Memory.remove_o; eauto.
    destruct (loc_ts_eq_dec (loc, to) (locw, f_to' w)) as [|NN].
    2: { rewrite loc_ts_eq_dec_neq; auto. }
    desc. simpls. subst. exfalso.
    apply Memory.add_get0 in PADD.
    clear -PADD LHS. desc. rewrite PADD in LHS. inv LHS. }

  splits; eauto.
  1,2: econstructor; eauto; ins.
  { inv MSG. clear MSG.
    set (AA:=GET). apply DISJOINT' in AA.
    rewrite FWWNEXTEQ in AA.
    set (BB:=GET). apply Memory.get_ts in BB.
    destruct BB as [|BB]; desc; eauto.
    destruct (TimeFacts.le_lt_dec (f_to' wnext) to').
    { eapply AA with (x:=f_to' wnext); constructor; simpls; auto. reflexivity. }
    eapply AA with (x:=to'); constructor; simpls; auto; try reflexivity.
    apply Time.le_lteq. eauto. }
  { rewrite FWWNEXTEQ.
    erewrite Memory.add_o; eauto. rewrite loc_ts_eq_dec_eq. eauto. }
  { ins.
    destruct (Ident.eq_dec (tid e) (tid w)) as [EQ|NEQ].
    { rewrite EQ. rewrite IdentMap.gss.
      eexists. eauto. }
    rewrite IdentMap.gso; auto. }
  { intros QQ l.
    assert (max_value f_to' (S_tm G l (covered T)) (LocFun.find l (Configuration.sc PC))) as BB.
    { eapply sc_view_f_issued; eauto. }
    destruct (Rel w); auto.
    eapply max_value_same_set.
    { apply BB. }
    eapply s_tm_n_f_steps.
    { apply TCCOH. }
    { clear. basic_solver. }
    intros a [HB|HB] HH AA.
    { eauto. }
    subst. clear -WW AA. type_solver. }
  { ins.
    destruct (Ident.eq_dec thread' (tid w)) as [EQ|NEQ].
    { subst. rewrite IdentMap.gss in TID0.
      inv TID0; simpls; clear TID0. }
    red; ins; rewrite IdentMap.gso in TID0; auto.
    erewrite Memory.add_o; eauto.
    destruct (loc_ts_eq_dec (loc, to) (locw, f_to' wnext)) as [[A B]|LL'].
    { simpls; rewrite A in *; rewrite B in *; subst.
      exfalso. erewrite NINTER' in LHS; eauto. inv LHS. }
    rewrite (loc_ts_eq_dec_neq LL').
    erewrite Memory.add_o; eauto.
    destruct (loc_ts_eq_dec (loc, to) (locw, f_to' w)) as [[A B]|LL].
    { simpls; rewrite A in *; rewrite B in *; subst.
      exfalso. erewrite NINTER in LHS; eauto. inv LHS. }
    rewrite (loc_ts_eq_dec_neq LL).
    eapply PROM_IN_MEM in LHS; eauto. }
  { simpls. red. ins.
    destruct (loc_ts_eq_dec (l, to) (locw, f_to' wnext)) as [[A' B']|LL'].
    { simpls; rewrite A' in *; rewrite B' in *.
      exfalso. rewrite RESGET' in PROM. inv PROM. }
    erewrite Memory.add_o in PROM; eauto. rewrite (loc_ts_eq_dec_neq LL') in PROM.
    destruct (loc_ts_eq_dec (l, to) (locw, f_to' w)) as [[A' B']|LL].
    { simpls; rewrite A' in *; rewrite B' in *.
      destruct (Rel w) eqn:RELB; subst.
      { erewrite Memory.remove_o in PROM; eauto.
        rewrite (loc_ts_eq_dec_eq locw (f_to' w)) in PROM. inv PROM. }
      erewrite Memory.add_o in PROM; eauto.
      rewrite (loc_ts_eq_dec_eq locw (f_to' w)) in PROM.
      inv PROM. exists w. splits; eauto. by right. }
    eapply NOTNEWR in PROM; eauto.
    edestruct SIM_PROM as [b H]; eauto; desc.
    exists b; splits; auto.
    { by left. }
    { assert (W b) as WB by (eapply issuedW; eauto).
      destruct (Rel w) eqn:RELB; auto.
      intros [HH|HH]; desf. }
    { by rewrite ISSEQ_FROM. }
    { by rewrite ISSEQ_TO. }
    eapply sim_mem_helper_f_issued with (f_to:=f_to); eauto. }
  { simpls. red. ins.
    destruct (loc_ts_eq_dec (l, to) (locw, f_to' wnext)) as [[A' B']|LL'].
    { simpls; rewrite A' in *; rewrite B' in *.
      rewrite RESGET' in RES. inv RES.
      exists wnext. splits; eauto.
      intros [HH|HH]; subst; eauto. }
    erewrite Memory.add_o in RES; eauto. rewrite (loc_ts_eq_dec_neq LL') in RES.
    destruct (loc_ts_eq_dec (l, to) (locw, f_to' w)) as [[A' B']|LL].
    { simpls; rewrite A' in *; rewrite B' in *.
      destruct (Rel w) eqn:RELB; subst.
      erewrite Memory.remove_o in RES; eauto.
      2: erewrite Memory.add_o in RES; eauto.
      all: rewrite (loc_ts_eq_dec_eq locw (f_to' w)) in RES; inv RES. }
    apply NOTNEWR in RES; auto.
    edestruct SIM_RES_PROM as [b H]; eauto; desc.
    exists b. splits; auto.
    { intros [A|A]; desf. }
    { rewrite REQ_FROM; auto. }
    rewrite REQ_TO; auto. }
  { ins.
    rewrite IdentMap.gso in TID'; auto.
    destruct (loc_ts_eq_dec (loc, to) (locw, (f_to' w))) as [EQ|NEQ]; simpls.
    { desc. subst. right.
      destruct (Memory.get locw (f_to' w) (Local.promises local')) eqn: HH; auto.
      exfalso.
      erewrite NINTER in HH; eauto. inv HH. }
    destruct (loc_ts_eq_dec (loc, to) (locw, (f_to' wnext))) as [EQ|NEQ']; simpls.
    { desc. subst. right.
      destruct (Memory.get locw (f_to' wnext) (Local.promises local')) eqn: HH; auto.
      exfalso.
      erewrite NINTER' in HH; eauto. inv HH. }
    edestruct (PROM_DISJOINT TNEQ TID') as [HH|HH]; eauto.
    left.
    destruct (Memory.get loc to promises') eqn:BB; auto.
    destruct p. eapply NOTNEWA in BB; eauto. desf. }
  { red. ins.
    destruct ISSB as [ISSB|]; subst.
    { edestruct SIM_MEM as [rel_opt HH]; eauto. simpls. desc.
      exists rel_opt. unnw.
      destruct (loc_ts_eq_dec (l, f_to' b) (locw, (f_to' w))) as [EQ|NEQ]; simpls; desc; subst.
      { exfalso.
        assert (b = w); [|by desf].
        eapply f_to_eq; try apply FCOH0; eauto.
        { red. by rewrite LOC. }
        do 2 left. by apply ETCCOH.(etc_I_in_S). }
      destruct (loc_ts_eq_dec (l, f_to' b) (locw, (f_to' wnext))) as [EQ|NEQ'];
        simpls; desc; subst.
      { exfalso.
        assert (b = wnext); [|by desf].
        eapply f_to_eq; try apply FCOH0; eauto.
        { red. by rewrite WNEXTLOC. }
        do 2 left. by apply ETCCOH.(etc_I_in_S). }
      erewrite Memory.add_o with (mem2:=memory'); eauto.
      erewrite Memory.add_o with (mem2:=memory_add); eauto.
      rewrite !loc_ts_eq_dec_neq; auto.
      splits; eauto.
      { rewrite ISSEQ_TO; auto. rewrite ISSEQ_FROM; auto. }
      { rewrite ISSEQ_FROM; auto. eapply sim_mem_helper_f_issued; eauto. }
      intros AA BB.
      assert (~ covered T b) as NCOVBB.
      { intros HH. apply BB. generalize HH. clear. basic_solver. }
      specialize (HH1 AA NCOVBB).
      desc. splits; auto.
      { apply NOTNEWA; auto.
        rewrite ISSEQ_TO; auto. rewrite ISSEQ_FROM; auto. }
      eexists. splits; eauto.
      2: { destruct HH2 as [[CC DD]|CC]; [left|right].
           { split; eauto. intros [y HH]. destruct_seq_l HH as OO.
             destruct OO as [OO|]; subst.
             { apply CC. exists y. apply seq_eqv_l. by split. }
             apply NISSB. eapply rfrmw_I_in_I; eauto. exists b.
             apply seqA. apply seq_eqv_r. by split. }
           desc. exists p. splits; auto.
           { by left. }
           eexists. splits; eauto.
           destruct (classic (l = locw)) as [|LNEQ]; subst; auto.
           2: { apply NOTNEWM.
                1,2: by left.
                rewrite ISSEQ_TO; auto. rewrite ISSEQ_FROM; auto. }
           assert (S' p) as SPP.
           { do 2 left. by apply ETCCOH.(etc_I_in_S). }
           assert (loc lab p = Some locw) as PLOC.
           { rewrite <- LOC0. by apply WF.(wf_rfrmwl). }
           apply NOTNEWM.
           3: { rewrite ISSEQ_TO; auto. rewrite ISSEQ_FROM; auto. }
           all: right; intros HH.
           all: eapply f_to_eq in HH; eauto; subst; auto.
           { red. by rewrite LOC. }
           red. by rewrite WNEXTLOC. }
      destruct (Rel w) eqn:RELW; auto.
      2: by rewrite ISSEQ_TO.
      assert (wmod (mod lab w) = Ordering.acqrel) as MM.
      { clear -RELW. mode_solver. }
      rewrite MM.
      unfold TView.rel, TView.write_tview.
      arewrite (Ordering.le Ordering.acqrel Ordering.acqrel = true) by reflexivity.
      destruct (classic (l = locw)) as [|LNEQ]; subst.
      2: { unfold LocFun.add. rewrite Loc.eq_dec_neq; auto. by rewrite ISSEQ_TO. }
      exfalso.
      assert (E b) as EB by (eapply issuedE; eauto).
      assert (W b) as WB by (eapply issuedW; eauto).
      assert ((⦗E⦘ ⨾ same_tid ⨾ ⦗E⦘) w b) as ST.
      { apply seq_eqv_lr. by splits. }
      apply tid_sb in ST. destruct ST as [[[|ST]|ST]|[AI BI]]; subst; auto.
      2: { apply NCOVBB. apply ISSUABLE. exists w. apply seq_eqv_r. split; auto.
           apply sb_to_w_rel_in_fwbob. apply seq_eqv_r. split; auto. by split. }
      assert (issuable G sc T b) as IB by (eapply issued_in_issuable; eauto).
      apply NCOVB. apply IB. exists b. apply seq_eqv_r. split; auto.
      apply sb_from_w_rel_in_fwbob; auto. apply seq_eqv_lr. splits; auto.
      all: split; auto. red. by rewrite LOC. }
    assert (Some l = Some locw) as QQ.
    { by rewrite <- LOC0. }
    inv QQ.
    eexists. splits; eauto.
    { erewrite Memory.add_o; eauto; rewrite loc_ts_eq_dec_neq; eauto.
      erewrite Memory.add_o; eauto. rewrite loc_ts_eq_dec_eq; eauto. }
    { apply HELPER. }
    { apply RELWFEQ. }
    { eapply Memory.add_closed_timemap; eauto. }
    intros _ NT.
    clear PROMGET.
    destruct (Rel b); desf.
    { exfalso. apply NT. by right. }
    splits.
    { erewrite Memory.add_o; eauto; rewrite loc_ts_eq_dec_neq; eauto.
      erewrite Memory.add_o; eauto. rewrite loc_ts_eq_dec_eq; eauto. }
    exists p_rel. splits; eauto. left.
    cdes PREL. destruct PREL1; desc.
    2: { exfalso. apply NWEX. red. generalize INRMW. clear. basic_solver. }
    split; auto.
    intros [a HH].
    apply seq_eqv_l in HH. destruct HH as [[HH|] RFRMW]; subst; eauto.
    { apply NINRMW. generalize HH RFRMW. clear. basic_solver 10. }
    eapply wf_rfrmw_irr; eauto. }
  { red. ins.
    assert (b <> w /\ ~ issued T b) as [BNEQ NISSBB].
    { generalize NISSB0. clear. basic_solver. }
    destruct RESB as [[SB|]|HH]; subst.
    2: by desf.
    { unnw.
      erewrite Memory.add_o with (mem2:=memory'); eauto.
      destruct (loc_ts_eq_dec (l, f_to' b) (locw, (f_to' w))) as [PEQ'|PNEQ];
        simpls; desc; subst.
      { exfalso. apply BNEQ.
        eapply f_to_eq with (f_to:=f_to'); eauto. red.
          by rewrite LOC. }
      destruct (loc_ts_eq_dec (l, f_to' b) (locw, (f_to' wnext))) as [PEQ'|PNEQ'];
        simpls; desc; subst.
      { exfalso. eapply f_to_eq with (I:=S') in PEQ'0; subst; eauto.
          by red; rewrite WNEXTLOC. }
      edestruct SIM_RES_MEM with (b:=b); eauto; unnw.
      rewrite (loc_ts_eq_dec_neq PNEQ').
      erewrite Memory.add_o with (mem2:=memory_add); eauto.
      rewrite (loc_ts_eq_dec_neq PNEQ).
      rewrite REQ_TO; auto. rewrite REQ_FROM; auto. }
    assert (b = wnext); subst.
    { eapply dom_sb_S_rfrmw_single; eauto. }
    assert (Some l = Some locw) as LL.
    { by rewrite <- LOC0. }
    inv LL.
    splits; ins.
    erewrite Memory.add_o; eauto. by rewrite loc_ts_eq_dec_eq. }
  intros WREL. red. ins. destruct msg; auto.
  rewrite WREL in PEQ.
  exfalso.
  erewrite Memory.add_o in GET; eauto.
  destruct (loc_ts_eq_dec (locw, t) (locw, f_to' wnext)) as [AA|NEQ']; simpls.
  { desc; subst.
    rewrite (loc_ts_eq_dec_eq locw (f_to' wnext)) in GET. inv GET. }
  rewrite (loc_ts_eq_dec_neq NEQ') in GET.
  destruct (loc_ts_eq_dec (locw, t) (locw, f_to' w)) as [AA|NEQ]; simpls.
  { desc; subst.
    erewrite Memory.remove_o in GET; eauto.
    rewrite (loc_ts_eq_dec_eq locw (f_to' w)) in GET. inv GET. }
  apply NOTNEWR in GET; auto.
  eapply SIM_PROM in GET. desc; subst.
  assert (E b) as EB.
  { eapply issuedE; eauto. }
  assert (W b) as WB.
  { eapply issuedW; eauto. }
  assert ((⦗E⦘ ⨾ same_tid ⨾ ⦗E⦘) b w) as HH.
  { apply seq_eqv_lr. splits; auto. }
  apply tid_sb in HH. destruct HH as [[[HH|HH]|HH]|[AA BB]]; subst; auto.
  2: { apply NCOVB. eapply dom_W_Rel_sb_loc_I_in_C; eauto.
       exists b. apply seq_eqv_l. split; [by split|].
       apply seqA.
       do 2 (apply seq_eqv_r; split; auto).
       split; auto. red. rewrite LOC. auto. }
  apply NCOV. apply ISSUABLE. exists w. apply seq_eqv_r. split; auto.
  apply sb_to_w_rel_in_fwbob. apply seq_eqv_r.
  do 2 (split; auto).
Qed.

End IssueStepHelper.