From mathcomp Require Import
     all_ssreflect
     finmap.

Require Import Relations.

From AUChain Require Import
     Network
     Protocol
     GlobalState
     Blocks
     Messages
     MessageTuple
     Parameters
     BlockTree
     LocalState
     StateMonad.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** * Schedule
      This file contains the semantics for an execution of the protocol.
**)

Definition upd_local (p: Party) (l: LocalState) (N: GlobalState) : GlobalState :=
  N[[state_map := setf (state_map N) p l ]].

(** Handy functions for using the network functionality to broadcast
    several messages. **)
Definition flood_msgs (msgs : Messages) (N : GlobalState) : GlobalState :=
  foldr flood_msg N msgs.

Definition flood_msgs_adv (msgs : seq (Message * DelayMap)) (N : GlobalState) : GlobalState :=
  foldr (fun ' (m , ϕ) => flood_msg_adv m ϕ) N msgs.

(** Our development is parameterised by a map deciding the honesty of
    parties. **)
Parameter CorruptionStatus : Party -> Honesty.

(** The adversary is modelled as two functions:
    1) Decides how the adversary acts when baking.
    2) Decides how the adversary acts when recieving
       messages. *)
Parameter AdversarialBake:
  Slot ->
  History ->
  MessagePool ->
  State AdversarialState (seq (Message * DelayMap)).

Parameter AdversarialRcv:
  Messages ->
  Slot ->
  History ->
  MessagePool ->
  State AdversarialState (seq (Message * DelayMap)).

Parameter TxSelection : Slot -> Party -> Transactions.

(** We translate the map of honesty a boolean value. **)
Definition is_corrupt p : bool := CorruptionStatus p == Corrupt.
Definition is_honest p : bool := CorruptionStatus p == Honest.

(** If the party is honest an honest step is taken with the correct
    messages. Otherwise will the [AdversarialStep] function be called with
    the correct inputs and the world updated accordingly to this.  **)
Definition party_bake_step_world (p : Party) (N : GlobalState) : GlobalState :=
  if (state_map N).[? p] is Some l
  then if ~~(is_corrupt p)
       then let '(n_msgs, new_ls) := honest_bake (t_now N) (TxSelection (t_now N) p) l
            in flood_msgs n_msgs (upd_local p new_ls N)
       else let '(n_msgs, adv_state') := AdversarialBake (t_now N) (history N) (msg_buff N) (adv_state N)
            in (flood_msgs_adv n_msgs N)[[adv_state := adv_state']]
  else N.

(** If the party is honest he calls the honest recieve functions.
    Otherwise the [AdversarialRcv] function.  **)
Definition party_rcv_step_world (p : Party) (N : GlobalState) : GlobalState :=
  if (state_map N).[? p] is Some l
  then let '(msgs, N') := fetch_msgs p N in
       if ~~(is_corrupt p)
       then let '(_, new_ls) := honest_rcv msgs (t_now N') l
            in (upd_local p new_ls N')
       else let '(n_msgs, adv_state') := AdversarialRcv msgs (t_now N') (history N') (msg_buff N') (adv_state N')
            in (flood_msgs_adv n_msgs N')[[adv_state := adv_state']]
  else N.

Definition inc_round (N : GlobalState) : GlobalState :=
  N[[t_now := S (t_now N)]].

(** ** Definition: Related states **)

Reserved Notation "A ⤳ B" (at level 80, no associativity).

Notation "N '@' p" := (progress N = p) (at level 20).

Inductive SingleStep: GlobalState -> GlobalState -> Prop :=
(* Delivering messages to all parties *)
| Deliver : forall N, N @ Ready -> N ⤳
                 (foldr party_rcv_step_world N (exec_order N))[[progress := Delivered]]
(* Executing all party concurrenctly *)
| Bake : forall N, N @ Delivered -> N ⤳
              (foldr party_bake_step_world N (exec_order N))[[progress := Baked]]
(* When messages are delivered and  *)
| NextRound : forall N, N @ Baked -> N ⤳ (inc_round (round_tick N))[[progress := Ready]]
(* Permuting parties leads to related states *)
| PermParties : forall N ps, perm_eq (exec_order N) ps -> N ⤳ N[[exec_order := ps]]
(* Permuting message buffer leads to related states  *)
| PermMsgs : forall N mb, perm_eq (msg_buff N) mb -> N ⤳ N[[msg_buff := mb]]
where "N ⤳ N'" := (SingleStep N N').

(** BigStep semantics are just the reflexive transitive closure of the
    SingleStep relation **)
Definition BigStep (N N' : GlobalState) := clos_refl_trans_n1 GlobalState SingleStep N N'.

Notation "N '⇓' N'" := (BigStep N N') (at level 20).
Notation "N '⇓[' s ']' N'" := (N ⇓ N' /\ (s + t_now N) = (t_now N')) (at level 20).
Notation "N '⇓^+' N'" := (N ⇓ N' /\ t_now N < t_now N') (at level 20).


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Fixpoint F (n:nat) : False := F (match F n with end).

(* de Bruijn mix-up *)
(* If accepted, Eval compute in f 0. loops *)
Definition f :=
  let f (f1 f2:nat->nat) := f1 in
  let _ := 0 in
  let _ := 0 in
  let g (f1 f2:nat->nat) := f2 in
  let h := f in (* h = Rel 4 *)
  fix F (n:nat) : nat :=
  h F S n. (* here Rel 4 = g *)


(** printing ⊢#    %\vdash_{\#}%    #⊢##     *)
(** printing ⊢##   %\vdash_{\#\#}%  #⊢&#35&#35#  *)
(** printing ⊢##v  %\vdash_{\#\#v}% #⊢&#35&#35v# *)
(** printing ⊢!    %\vdash_!%       #⊢!#         *)
(** remove printing ~ *)

(** This module reasons about the precise types of variables in inert contexts. *)

Set Implicit Arguments.

Require Import Coq.Program.Equality.
Require Import Definitions RecordAndInertTypes.

(** * Precise Typing

    Precise typing is used to reason about the types of variables and values.
    Precise typing does not "modify" a variable's or value's type through subtyping.
    - For values, precise typing allows to only retrieve the "immediate" type of the value.
      It types objects with recursive types, and functions with dependent-function types. #
#
      For example, if a value is the object [nu(x: {a: T}){a = x.a}], the only way to type
      the object through precise typing is [G ⊢! nu(x: {a: T}){a = x.a}: mu(x: {a: T})].
    - For variables, we start out with a type [T=G(x)] (the type to which the variable is
      bound in [G]). Then we use precise typing to additionally deconstruct [T]
      by using recursion elimination and intersection elimination. #
#
      For example, if [G(x)=mu(x: {a: T} /\ {B: S..U})], then we can derive the following
      precise types for [x]:               #
#
      [G ⊢! x: mu(x: {a: T} /\ {B: S..U})] #
#
      [G ⊢! x: {a: T} /\ {B: S..U}]        #
#
      [G ⊢! x: {a: T}]                    #
#
      [G ⊢! x: {B: S..U}].                *)

(** ** Precise typing for values *)
Reserved Notation "G '⊢!v' v ':' T" (at level 40, v at level 59).

Inductive ty_val_p : ctx -> val -> typ -> Prop :=

(** [G, x: T ⊢ t^x: U^x]       #
#
    [x fresh]                  #
#
    [――――――――――――――――――――――――] #
#
    [G ⊢! lambda(T)t: forall(T) U]     *)
| ty_all_intro_p : forall L G T t U,
    (forall x, x \notin L ->
      G & x ~ T ⊢ open_trm x t : open_typ x U) ->
    G ⊢!v val_lambda T t : typ_all T U

(** [G, x: T^x ⊢ ds^x :: T^x]   #
#
    [x fresh]                   #
#
    [―――――――――――――――――――――――]   #
#
    [G ⊢! nu(T)ds :: mu(T)]        *)
| ty_new_intro_p : forall L G T ds,
    (forall x, x \notin L ->
      G & (x ~ open_typ x T) /- open_defs x ds :: open_typ x T) ->
    G ⊢!v val_new T ds : typ_bnd T

where "G '⊢!v' v ':' T" := (ty_val_p G v T).

Hint Constructors ty_val_p.

(** * Precise Flow *)
(** We use the precise flow relation to reason about the relations between
    the precise type of a variable [G ⊢! x: T] and the type that the variable
    is bound to in the context [G(x)=T'].#
#
    If [G(x) = T], the [precise_flow] relation describes all the types [U] that [x] can
    derive through precise typing ([⊢!] (see paper)).
    If [precise_flow x G T U], denoted as [G ⊢ x: T ⪼ U],
    then [G(x) = T] and [G ⊢! x: U].   #
#
    For example, if [G(x) = mu(x: {a: T} /\ {B: S..U})], then we can derive the following
    precise flows for [x]:                                                  #
#
    [G ⊢! x: mu(x: {a: T} /\ {B: S..U}) ⪼ mu(x: {a: T} /\ {B: S..U}]         #
#
    [G ⊢! x: mu(x: {a: T} /\ {B: S..U}) ⪼ {a: T} /\ {B: S..U}]               #
#
    [G ⊢! x: mu(x: {a: T} /\ {B: S..U}) ⪼ {a: T}]                           #
#
    [G ⊢! x: mu(x: {a: T} /\ {B: S..U}) ⪼ {B: S..U}]. *)

Reserved Notation "G '⊢!' x ':' T '⪼' U" (at level 40, x at level 59).

Inductive precise_flow : var -> ctx -> typ -> typ -> Prop :=

(** [G(x) = T]       #
#
    [ok G]           #
#
    [――――――――――――――] #
#
    [G ⊢! x: T ⪼ T] *)
  | pf_bind : forall x G T,
      binds x T G ->
      G ⊢! x: T ⪼ T

(** [G ⊢! x: T ⪼ mu(U)] #
#
    [――――――――――――――――――] #
#
    [G ⊢! x: T ⪼ U^x]       *)
  | pf_open : forall x G T U,
      G ⊢! x: T ⪼ typ_bnd U ->
      G ⊢! x: T ⪼ open_typ x U

(** [G ⊢! x: T ⪼ U1 /\ U2]   #
#
    [――――――――――――――――――――]   #
#
    [G ⊢! x: T ⪼ U1]        *)
  | pf_and1 : forall x G T U1 U2,
      G ⊢! x: T ⪼ typ_and U1 U2 ->
      G ⊢! x: T ⪼ U1

(** [G ⊢! x: T ⪼ U1 /\ U2]   #
#
    [――――――――――――――――――――]   #
#
    [G ⊢! x: T ⪼ U2]        *)
  | pf_and2 : forall x G T U1 U2,
      G ⊢! x: T ⪼ typ_and U1 U2 ->
      G ⊢! x: T ⪼ U2

where "G '⊢!' x ':' T '⪼' U" := (precise_flow x G T U).

Hint Constructors precise_flow.

(** ** Precise Flow Lemmas *)

(** If [G ⊢! x: T ⪼ U] then [G(x) = T]. *)
Lemma pf_binds: forall G x T U,
    G ⊢! x: T ⪼ U ->
    binds x T G.
Proof.
  introv Pf. induction Pf; auto.
Qed.

(** If [G(x) = forall(S)T], then [x]'s precise type can be only [forall(S)T]. *)
Lemma precise_flow_all_inv : forall x G S T U,
    G ⊢! x: typ_all S T ⪼ U ->
    U = typ_all S T.
Proof.
  introv Hpf.
  dependent induction Hpf; auto;
    specialize (IHHpf S T eq_refl); inversion IHHpf.
Qed.

(** The precise type of a value is inert. *)
Lemma precise_inert_typ : forall G v T,
    G ⊢!v v : T ->
    inert_typ T.
Proof.
  introv Ht. inversions Ht; constructor; rename T0 into T.
  pick_fresh z. assert (Hz: z \notin L) by auto.
  match goal with
  | [H: forall x, _ \notin _ -> _,
     Hz: ?z \notin _ |- _] =>
    specialize (H z Hz);
      pose proof (ty_defs_record_type H);
      assert (Hz': z \notin fv_typ T) by auto;
      apply* record_type_open
  end.
Qed.

(** The following two lemmas say that the type to which a variable is bound in an inert context is inert. *)
Lemma binds_inert : forall G x T,
    binds x T G ->
    inert G ->
    inert_typ T.
Proof.
  introv Bi HiG. induction HiG.
  - false * binds_empty_inv.
  - destruct (binds_push_inv Bi).
    + destruct H1. subst. assumption.
    + destruct H1. apply (IHHiG H2).
Qed.

(** See [binds_inert]. *)
Lemma pf_inert_T : forall G x T U,
    inert G ->
    G ⊢! x: T ⪼ U ->
    inert_typ T.
Proof.
  introv Hi Pf. induction Pf; eauto.
  apply (binds_inert H Hi).
Qed.

(** See [inert_typ_bnd_record] *)
Lemma pf_rcd_T : forall G x T U,
    inert G ->
    G ⊢! x: (typ_bnd T) ⪼ U ->
    record_type T.
Proof.
  introv Hi Pf. apply (pf_inert_T Hi) in Pf; inversions Pf; assumption.
Qed.

(** If [G(x) = mu(x: T)], then [x]'s precise type can be only [mu(x: T)]
     or a record type. *)
Lemma pf_bnd_same_or_rcd : forall G x T U,
    inert G ->
    G ⊢! x: typ_bnd T ⪼ U ->
    U = typ_bnd T \/ record_type U.
Proof.
  introv Hi Pf.
  dependent induction Pf; try solve [left*]; right.
  - specialize (IHPf T Hi eq_refl). destruct IHPf as [eq | r].
    * apply open_record_type.
      inversion eq. apply* pf_rcd_T.
    * inversion r. inversion H.
  - destruct (IHPf T Hi eq_refl) as [F | Hr]. inversion F.
    inversion Hr. inversions H.
    exists ls. assumption.
  - destruct (IHPf T Hi eq_refl) as [F | Hr]. inversion F.
    inversion Hr. inversions H.
    eexists. apply* rt_one.
Qed.

(** If [x]'s precise type is [mu(x: U)], then [G(x) = mu(x: U)] *)
Lemma pf_inert_bnd_U: forall G x T U,
    inert G ->
    G ⊢! x: T ⪼ typ_bnd U ->
    T = typ_bnd U.
Proof.
  introv Hi Pf.
  lets HT: (pf_inert_T Hi Pf).
  destruct HT.
  - apply precise_flow_all_inv in Pf. congruence.
  - destruct (pf_bnd_same_or_rcd Hi Pf) as [Heq | Hr].
    + auto.
    + inversion Hr. inversion H0.
Qed.

(** If [x]'s precise type is a field or type declaration, then [G(x)] is
    a recursive type. *)
Lemma pf_inert_rcd_U: forall G x T D,
    inert G ->
    G ⊢! x: T ⪼ typ_rcd D ->
    exists U, T = typ_bnd U.
Proof.
  introv Hi Pf.
  lets HT: (pf_inert_T Hi Pf).
  destruct HT.
  - apply precise_flow_all_inv in Pf. congruence.
  - exists* T.
Qed.

(** If [x]'s precise type is a record type, then [G(x)] is a recursive type. *)
Lemma pf_inert_rcd_typ_U: forall G x T Ds,
    inert G ->
    G ⊢! x: T ⪼ Ds ->
    record_type Ds ->
    exists U, T = typ_bnd U.
Proof.
  introv Hi Pf Hr.
  lets HT: (pf_inert_T Hi Pf).
  destruct HT.
  - apply precise_flow_all_inv in Pf. subst.
    inversion Hr. inversion H.
  - exists* T.
Qed.

(** The following two lemmas express that if [x]'s precise type is a function type,
    then [G(x)] is the same function type. *)
Lemma pf_inert_lambda_U : forall x G S T U,
    inert G ->
    G ⊢! x: U ⪼ typ_all S T ->
    U = typ_all S T.
Proof.
  introv Hi Pf.
  lets Hiu: (pf_inert_T Hi Pf).
  destruct Hiu.
  - apply precise_flow_all_inv in Pf. congruence.
  - destruct (pf_bnd_same_or_rcd Hi Pf) as [H1 | H1]; inversions H1.
    inversion H0.
Qed.

(** See [pf_inert_lambda_U]. *)
Lemma inert_precise_all_inv : forall x G S T U,
    inert G ->
    G ⊢! x : U ⪼ typ_all S T ->
    binds x (typ_all S T) G.
Proof.
  introv Hi Htyp. lets H: (pf_inert_lambda_U Hi Htyp). subst.
  apply* pf_binds.
Qed.

(** In an inert context, the precise type of a variable
    cannot be bottom. *)
Lemma pf_bot_false : forall G x T,
    inert G ->
    G ⊢! x: T ⪼ typ_bot ->
    False.
Proof.
  introv Hi Pf.
  lets HT: (pf_inert_T Hi Pf). destruct HT.
  - apply precise_flow_all_inv in Pf. congruence.
  - destruct (pf_bnd_same_or_rcd Hi Pf); inversion H0. inversion H1.
Qed.

(** In an inert context, the precise type of
    a variable cannot be type selection. *)
Lemma pf_psel_false : forall G T x y A,
    inert G ->
    G ⊢! x: T ⪼ typ_sel y A ->
    False.
Proof.
  introv Hi Pf.
  lets HT: (pf_inert_T Hi Pf). destruct HT.
  - apply precise_flow_all_inv in Pf. congruence.
  - destruct (pf_bnd_same_or_rcd Hi Pf); inversion H0. inversion H1.
Qed.

(** If [G(x) = mu(T)], and [G ⊢! x: ... /\ D /\ ...], then [T^x = ... /\ D /\ ...]. *)
Lemma pf_record_sub : forall x G T T' D,
    inert G ->
    G ⊢! x: typ_bnd T ⪼ T' ->
    record_has T' D ->
    record_has (open_typ x T) D.
Proof.
  introv Hi Pf Hr. dependent induction Pf; auto.
  - inversions Hr.
  - apply (pf_inert_bnd_U Hi) in Pf. congruence.
Qed.

(** If [G(x) = mu(S)] and [G ⊢! x: D], where [D] is a field or type declaration,
    then [S^x = ... /\ D /\ ...]. *)
Lemma precise_flow_record_has: forall S G x D,
    inert G ->
    G ⊢! x: typ_bnd S ⪼ typ_rcd D ->
    record_has (open_typ x S) D.
Proof.
  introv Hi Pf. apply* pf_record_sub.
Qed.

(** If
    - [G ⊢! x: mu(T) ⪼ {A: T1..T1}]
    - [G ⊢! x: mu(T) ⪼ {A: T2..T2}]
    then [T1 = T2]. *)
Lemma pf_record_unique_tight_bounds_rec : forall G x T A T1 T2,
    inert G ->
    G ⊢! x: typ_bnd T ⪼ typ_rcd (dec_typ A T1 T1) ->
    G ⊢! x: typ_bnd T ⪼ typ_rcd (dec_typ A T2 T2) ->
    T1 = T2.
Proof.
  introv Hi Pf1 Pf2.
  pose proof (precise_flow_record_has Hi Pf1) as H1.
  pose proof (precise_flow_record_has Hi Pf2) as H2.
  eapply unique_rcd_typ; eauto.
  apply open_record_type; apply* pf_rcd_T.
Qed.

(** If
    - [G ⊢! x: T ⪼ {A: T1..T1}]
    - [G ⊢! x: T ⪼ {A: T2..T2}]
    then [T1 = T2]. *)(** *)
Lemma pf_inert_unique_tight_bounds : forall G x T T1 T2 A,
    inert G ->
    G ⊢! x: T ⪼ typ_rcd (dec_typ A T1 T1) ->
    G ⊢! x: T ⪼ typ_rcd (dec_typ A T2 T2) ->
    T1 = T2.
Proof.
  introv Hi Pf1 Pf2.
  pose proof (pf_inert_rcd_U Hi Pf1) as [?U ?H]; subst.
  apply* pf_record_unique_tight_bounds_rec.
Qed.

(** The type to which a variable is bound in an environment is unique. *)
Lemma x_bound_unique: forall G x T1 T2 U1 U2,
    G ⊢! x: T1 ⪼ U1 ->
    G ⊢! x: T2 ⪼ U2 ->
    T1 = T2.
Proof.
  introv Pf1 Pf2.
  apply pf_binds in Pf1.
  apply pf_binds in Pf2.
  apply (binds_functional Pf1 Pf2).
Qed.

(** If a typing context is inert, then the variables in its domain are distinct. #
#
    Note: [ok] is defined in [TLC.LibEnv.v]. *)
Lemma inert_ok : forall G,
    inert G ->
    ok G.
Proof.
  introv Hi. induction Hi; auto.
Qed.

Hint Resolve inert_ok.

(** If [G ⊢! x: {A: S..U}] then [S = U]. *)
Lemma pf_dec_typ_inv : forall G x T A S U,
    inert G ->
    G ⊢! x: T ⪼ typ_rcd (dec_typ A S U) ->
    S = U.
Proof.
  introv Hi Pf. destruct (pf_inert_rcd_U Hi Pf) as [V H]. subst.
  destruct (pf_bnd_same_or_rcd Hi Pf); try congruence.
  destruct H as [?ls ?H]. inversions H. inversions* H1.
Qed.

(** Precise typing implies general typing. *)
(** - for variables *)
Lemma precise_to_general: forall G x T U,
    G ⊢! x : T ⪼ U ->
    G ⊢ trm_var (avar_f x) : U.
Proof.
  intros. induction H; intros; subst; eauto.
Qed.

(** - for values *)
Lemma precise_to_general_v: forall G v T,
    G ⊢!v v : T ->
    G ⊢ trm_val v: T.
Proof.
  intros. induction H; intros; subst; eauto.
Qed.


From iris.base_logic.lib Require Export fancy_updates wsat.
From iris.proofmode Require Import base tactics classes.
From mwp Require Import mwp mwp_adequacy mwp_lifting.
From iris.program_logic Require Export ectxi_language ectx_language language.
From mwp.prelude Require Import base.

Section mwp_indexed_step_fupd.
  Context {Λ Σ} `{!invG Σ} (mwpD_SI : state Λ → iProp Σ).

  Typeclasses Transparent mwpC_state_interp mwpC_modality.

  Program Definition mwpd_indexed_step_fupd : mwpData Λ Σ :=
    {| mwpD_state_interp := mwpD_SI;
       mwpD_Extra := [Prod];
       mwpD_modality_index := [Prod nat];
       mwpD_modality_bind_condition k k' f Ξ :=
         k = k' + (f tt) ∧ Ξ = λ _, id;
       mwpD_modality k E n Φ := (|={E}[∅]▷=>^k |={E}=> Φ tt)%I;
    |}.

  Global Instance mwpC_indexed_step_fupd : mwpC mwpd_indexed_step_fupd.
  Proof.
    split.
    - intros idx E m n P Q HPQ; simpl.
      induction idx; simpl; first by apply fupd_ne.
      by rewrite IHidx.
    - iIntros (idx E1 E2 n P Q HE) "HPQ HP"; simpl.
      iSpecialize ("HPQ" $! tt); simpl.
      iInduction idx as [] "IH"; simpl.
      + iApply fupd_wand_l; iFrame. by iApply fupd_mask_mono.
      + iApply step_fupd_mask_mono; last (iMod "HP"; iModIntro); try set_solver.
        iNext. iMod "HP"; iModIntro.
        iApply ("IH" with "HPQ HP").
    - intros idx E n P; simpl.
      induction idx; simpl; first done.
      iIntros "HP". iApply (step_fupd_wand with "HP []").
      iApply IHidx.
    - intros idx idx' f.
      intros E n m P ? [-> ->]; simpl in *.
      induction idx'; simpl.
      + induction (f tt) as [|z]; simpl; first by iIntros ">>?".
        iIntros ">>H"; iModIntro; iNext; iMod "H"; iModIntro.
        by iApply IHz; iModIntro.
      + iIntros ">H"; iModIntro; iNext; iMod "H"; iModIntro.
        by iApply IHidx'.
  Qed.

  Global Instance mwp_indexed_step_fupd_is_outer_fupd idx :
    mwpMIsOuterModal mwpd_indexed_step_fupd idx (λ E _ P, |={E}=> P)%I.
  Proof.
    rewrite /mwpMIsOuterModal /mwpC_modality /mwpD_modality /=.
    iIntros (E n P) "H".
    destruct idx; simpl; by iMod "H".
  Qed.

  Global Instance mwp_indexed_step_fupd_is_outer_bupd idx :
    mwpMIsOuterModal mwpd_indexed_step_fupd idx (λ _ _ P, |==> P)%I.
  Proof.
    rewrite /mwpMIsOuterModal /mwpC_modality /mwpD_modality /=.
    iIntros (E n P) "H".
    destruct idx; simpl; by iMod "H".
  Qed.

  Global Instance mwp_indexed_step_fupd_is_outer_except_0 idx :
    mwpMIsOuterModal mwpd_indexed_step_fupd idx (λ _ _ P, ◇ P)%I.
  Proof.
    rewrite /mwpMIsOuterModal /mwpC_modality /mwpD_modality /=.
    iIntros (E n P) "H".
    destruct idx; simpl; by iMod "H".
  Qed.

  Global Instance mwp_indexed_step_fupd_is_inner_fupd idx :
    mwpMIsInnerModal mwpd_indexed_step_fupd idx (λ E _ P, |={E}=> P)%I.
  Proof.
    rewrite /mwpMIsInnerModal /mwpC_modality /mwpD_modality /=.
    iIntros (E n P) "H".
    iInduction idx as [] "IH"; simpl; first by iMod "H".
    iMod "H"; iModIntro; iNext; iMod "H"; iModIntro.
    by iApply "IH".
  Qed.

  Global Instance mwp_indexed_step_fupd_is_inner_bupd idx :
    mwpMIsInnerModal mwpd_indexed_step_fupd idx (λ _ _ P, |==> P)%I.
  Proof.
    rewrite /mwpMIsInnerModal /mwpC_modality /mwpD_modality /=.
    iIntros (E n P) "H".
    iInduction idx as [] "IH"; simpl; first by iMod "H".
    iMod "H"; iModIntro; iNext; iMod "H"; iModIntro.
    by iApply "IH".
  Qed.

  Global Instance mwp_indexed_step_fupd_is_inner_except_0 idx :
    mwpMIsInnerModal mwpd_indexed_step_fupd idx (λ _ _ P, ◇ P)%I.
  Proof.
    rewrite /mwpMIsInnerModal /mwpC_modality /mwpD_modality /=.
    iIntros (E n P) "H".
    iInduction idx as [] "IH"; simpl; first by repeat iMod "H".
    iMod "H"; iModIntro; iNext; iMod "H"; iModIntro.
    by iApply "IH".
  Qed.

  Global Instance mwp_indexed_step_fupd_AlwaysSupportsShift idx :
    idx ≤ 1 →
    mwpMAlwaysSupportsShift mwpd_indexed_step_fupd idx.
  Proof.
    rewrite /mwpMSupportsAtomicShift /mwpC_modality /mwpD_modality /=.
    iIntros (Hidx n E1 E2 P) "H".
    destruct idx as [|[]]; simpl; last lia.
    - by repeat iMod "H".
    - repeat iMod "H". iModIntro. iNext.
      by repeat iMod "H".
  Qed.

  Global Program Instance mwp_indexed_step_fupd_SplitForStep idx :
    mwpMSplitForStep mwpd_indexed_step_fupd idx :=
    {|
      mwpM_split_for_step_M1 E P := |={E, ∅}=> P;
      mwpM_split_for_step_M2 E P := |={∅, E}=> P;
    |}%I.
  Next Obligation.
  Proof.
    iIntros (idx n E P) "HP /=".
    rewrite /mwpC_modality /mwpD_modality /=.
    destruct idx as [|]; simpl.
    - by repeat iMod "HP".
    - by repeat iMod "HP"; iModIntro; iNext; iMod "HP"; iModIntro.
  Qed.
  Next Obligation.
  Proof.
    iIntros (idx E P Q) "HPQ HP /=".
    by iMod "HP"; iModIntro; iApply "HPQ".
  Qed.
  Next Obligation.
  Proof.
    iIntros (idx E P Q) "HPQ HP /=".
    iMod "HP"; iModIntro. by iApply "HPQ".
  Qed.

  Lemma mwp_indexed_step_fupd_bind K `{!LanguageCtx K} k k' E e Φ :
    MWP@{mwpd_indexed_step_fupd, k } e @ E {{ v; m,
      MWP@{mwpd_indexed_step_fupd, k' } K (of_val v) @ E {{ w; n, Φ w (m + n) }} }}
    ⊢ MWP@{mwpd_indexed_step_fupd, k + k' } K e @ E {{ (λ v n _, Φ v n) }}.
  Proof.
    iIntros "H".
    iApply (mwp_bind _ _ _ _ _ (λ _, id)); last eauto.
    rewrite /mwpC_modality_bind_condition /=; split; [lia|done].
  Qed.

  Lemma mwpC_indexed_step_fupd_modality_le k k' E n Φ:
    k' ≤ k →
    mwpC_modality mwpd_indexed_step_fupd k' E n Φ
    ⊢ mwpC_modality mwpd_indexed_step_fupd k E n Φ.
  Proof.
    iIntros (Hk) "H".
    rewrite /mwpC_modality /=.
    replace k with (k' + (k - k')) by lia.
    rewrite -step_fupdN_plus.
    iApply step_fupdN_mono; last eauto.
    by iIntros "?"; iApply step_fupdN_intro.
  Qed.

  Lemma mwp_indexed_step_fupd_index_intro k k' E e Φ :
    k' ≤ k →
    MWP@{mwpd_indexed_step_fupd, k' } e @ E {{ Φ }}
    ⊢ MWP@{mwpd_indexed_step_fupd, k } e @ E {{ Φ }}.
  Proof.
    iIntros (?) "H".
    rewrite mwp_eq /mwp_def.
    iIntros (σ1 σ2 v n Hr) "Hi".
    iApply (mwpC_indexed_step_fupd_modality_le); first done.
    iApply "H"; eauto.
  Qed.

  Lemma mwp_indexed_step_fupd_index_step_fupd k k' E e Φ :
    (|={E}[∅]▷=>^k' MWP@{mwpd_indexed_step_fupd, k } e @ E {{ Φ }})%I
    ⊢ MWP@{mwpd_indexed_step_fupd, k' + k } e @ E {{ Φ }}.
  Proof.
    iIntros "H".
    rewrite mwp_eq /mwp_def.
    iIntros (σ1 σ2 v n Hr) "Hi".
    iApply step_fupdN_plus.
    iApply (step_fupdN_wand with "H").
    iIntros "H".
    iApply "H"; eauto.
  Qed.

End mwp_indexed_step_fupd.

Section lifting.

Context {Λ Σ} `{!invG Σ} (mwpD_SI : state Λ → iProp Σ).
Implicit Types v : val Λ.
Implicit Types e : expr Λ.
Implicit Types σ : state Λ.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val Λ → nat → iProp Σ.

Local Instance : mwpC (mwpd_indexed_step_fupd mwpD_SI) := mwpC_indexed_step_fupd mwpD_SI.
Local Instance : ∀ idx, mwpMSplitForStep (mwpd_indexed_step_fupd mwpD_SI) idx :=
  mwp_indexed_step_fupd_SplitForStep mwpD_SI.

Typeclasses Transparent mwpC_state_interp mwpD_state_interp mwpC_modality.

Lemma mwp_fupd_lift_step idx E Φ e1 :
  to_val e1 = None →
    (∀ σ1, mwpD_SI σ1 -∗
      |={E, ∅}=>
     ∀ e2 σ2,
         ⌜prim_step e1 σ1 [] e2 σ2 []⌝ ={∅, E}=∗
            (mwpD_SI σ2 ∗ MWP@{mwpd_indexed_step_fupd mwpD_SI, idx}
                    e2 @ E {{ w; n, Φ w (S n) }}))
    ⊢ MWP@{mwpd_indexed_step_fupd mwpD_SI, idx} e1 @ E {{ (λ v n _, Φ v n) }}.
Proof.
  by intros;
    iApply (mwp_lift_step
              (mwpd_indexed_step_fupd mwpD_SI) idx E (λ v n _, Φ v n) e1).
Qed.

Lemma mwp_indexed_step_fupd_lift_pure_step idx E Φ e1 :
  to_val e1 = None →
  (∀ σ1 e2 σ2, prim_step e1 σ1 [] e2 σ2 [] → σ1 = σ2) →
  (∀ σ1 e2 σ2,
      ⌜prim_step e1 σ1 [] e2 σ2 []⌝ →
      MWP@{mwpd_indexed_step_fupd mwpD_SI, idx}
        e2 @ E {{ w; n, Φ w (S n) }})
    ⊢ MWP@{mwpd_indexed_step_fupd mwpD_SI, idx} e1 @ E {{ λ v n _, Φ v n }}.
Proof.
  iIntros(??) "H".
  iApply (mwp_lift_pure_step
            (mwpd_indexed_step_fupd mwpD_SI) idx E (λ v n _, Φ v n) e1);
    simpl; eauto.
  by iApply fupd_mask_intro_subseteq; first set_solver.
Qed.

Lemma mwp_indexed_step_fupd_lift_atomic_step idx E Φ e1 :
  to_val e1 = None →
  Atomic StronglyAtomic e1 →
   (∀ σ1, mwpD_SI σ1 ={E, ∅}=∗
        ∀ v2 σ2,
            ⌜prim_step e1 σ1 [] (of_val v2) σ2 []⌝
             ={∅, E}=∗ (mwpD_SI σ2 ∗ |={E}[∅]▷=>^idx |={E}=> Φ v2 1))
    ⊢ MWP@{mwpd_indexed_step_fupd mwpD_SI, idx } e1 @ E {{ λ v n _, Φ v n }}.
Proof.
  iIntros (??).
  by iApply (mwp_lift_atomic_step
               (mwpd_indexed_step_fupd mwpD_SI) idx E (λ v n _, Φ v n) e1).
Qed.

Lemma mwp_indexed_step_fupd_lift_atomic_det_step idx E Φ e1 :
  to_val e1 = None →
  Atomic StronglyAtomic e1 →
  (∀ σ1, mwpD_SI σ1 ={E, ∅}=∗
     (∃ v2 σ2,
         ⌜∀ e2' σ2', prim_step e1 σ1 [] e2' σ2' [] →
                     σ2 = σ2' ∧ to_val e2' = Some v2⌝ ∧
                     |={∅, E}=> mwpD_SI σ2 ∗ |={E}[∅]▷=>^idx |={E}=> Φ v2 1))
    ⊢ MWP@{mwpd_indexed_step_fupd mwpD_SI, idx } e1 @ E {{ λ v n _, Φ v n }}.
Proof.
  by iIntros (??);
  iApply (mwp_lift_atomic_det_step
            (mwpd_indexed_step_fupd mwpD_SI) idx E (λ v n _, Φ v n) e1).
Qed.

Lemma mwp_indexed_step_fupd_lift_pure_det_step idx E Φ e1 e2 :
  to_val e1 = None →
  (∀ σ1 e2' σ2, prim_step e1 σ1 [] e2' σ2 [] → σ1 = σ2 ∧ e2 = e2')→
  MWP@{mwpd_indexed_step_fupd mwpD_SI, idx} e2 @ E {{ v; n, Φ v (S n) }}
  ⊢ MWP@{mwpd_indexed_step_fupd mwpD_SI, idx} e1 @ E {{ λ v n _, Φ v n }}.
Proof.
  iIntros(??) "H".
  iApply (mwp_lift_pure_det_step
            (mwpd_indexed_step_fupd mwpD_SI) idx E (λ v n _, Φ v n) e1);
    simpl; eauto.
  by iApply fupd_mask_intro_subseteq; first set_solver.
Qed.

Lemma mwp_indexed_step_fupd_pure_step `{!Inhabited (state Λ)} idx E e1 e2 φ n Φ :
  PureExec φ n e1 e2 →
  φ →
  MWP@{mwpd_indexed_step_fupd mwpD_SI, idx}
    e2 @ E {{ v ; m, Φ v (n + m) }}
  ⊢ MWP@{mwpd_indexed_step_fupd mwpD_SI, idx} e1 @ E {{ λ v n _, Φ v n }}.
Proof.
  iIntros (Hexec Hφ) "Hic".
  iApply (mwp_pure_step (mwpd_indexed_step_fupd mwpD_SI) idx); eauto.
  clear Hexec.
  iInduction n as [] "IH" forall (Φ); simpl; auto.
  iApply fupd_mask_intro_subseteq; first set_solver.
  iApply ("IH" $! (λ w k, Φ w (S k)) with "Hic").
Qed.

End lifting.

Section mwp_ectx_lifting.

Context {Λ : ectxLanguage}.
Context {Σ} `{!invG Σ} (mwpD_SI : state Λ → iProp Σ).
Implicit Types v : val Λ.
Implicit Types e : expr Λ.
Implicit Types σ : state Λ.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val Λ → nat → iProp Σ.

Typeclasses Transparent mwpC_state_interp mwpD_state_interp mwpC_modality.

Lemma mwp_indexed_step_fupd_lift_head_step idx E Φ e1 :
  to_val e1 = None →
  sub_redexes_are_values e1 →
   (∀ σ1, mwpD_SI σ1 ={E, ∅}=∗
        ∀ e2 σ2,
            ⌜head_step e1 σ1 [] e2 σ2 []⌝ ={∅, E}=∗
             (mwpD_SI σ2 ∗ MWP@{mwpd_indexed_step_fupd mwpD_SI, idx}
                     e2 @ E {{ w; n, Φ w (S n) }}))
    ⊢ MWP@{mwpd_indexed_step_fupd mwpD_SI, idx} e1 @ E {{ λ v n _, Φ v n }}.
Proof.
  by intros;
    iApply (mwp_lift_head_step
              (mwpd_indexed_step_fupd mwpD_SI) idx E (λ v n _, Φ v n) e1).
Qed.

Lemma mwp_indexed_step_fupd_lift_pure_head_step idx E Φ e1 :
  to_val e1 = None →
  sub_redexes_are_values e1 →
  (∀ σ1 e2 σ2, head_step e1 σ1 [] e2 σ2 [] → σ1 = σ2) →
  (∀ σ1 e2 σ2,
      ⌜head_step e1 σ1 [] e2 σ2 []⌝ →
      MWP@{mwpd_indexed_step_fupd mwpD_SI, idx}
        e2 @ E {{ w; n, Φ w (S n) }})
    ⊢ MWP@{mwpd_indexed_step_fupd mwpD_SI, idx} e1 @ E {{ λ v n _, Φ v n }}.
Proof.
  iIntros(???) "H".
  iApply (mwp_lift_pure_head_step
            (mwpd_indexed_step_fupd mwpD_SI) idx E (λ v n _, Φ v n) e1);
    simpl; eauto.
  by iApply fupd_mask_intro_subseteq; first set_solver.
Qed.

Lemma mwp_indexed_step_fupd_lift_atomic_head_step idx E Φ e1 :
  to_val e1 = None →
  sub_redexes_are_values e1 →
  Atomic StronglyAtomic e1 →
   (∀ σ1, mwpD_SI σ1 ={E, ∅}=∗
     ∀ v2 σ2,
       ⌜head_step e1 σ1 [] (of_val v2) σ2 []⌝ ={∅, E}=∗
          (mwpD_SI σ2 ∗ |={E}[∅]▷=>^idx |={E}=> Φ v2 1))
     ⊢ MWP@{mwpd_indexed_step_fupd mwpD_SI, idx } e1 @ E {{ λ v n _, Φ v n }}.
Proof.
  by intros;
    iApply (mwp_lift_atomic_head_step
              (mwpd_indexed_step_fupd mwpD_SI) idx E (λ v n _, Φ v n) e1).
Qed.

Lemma mwp_indexed_step_fupd_lift_pure_det_head_step idx E Φ e1 e2 :
  to_val e1 = None →
  sub_redexes_are_values e1 →
  (∀ σ1 e2' σ2, head_step e1 σ1 [] e2' σ2 [] → σ1 = σ2 ∧ e2 = e2')→
  MWP@{mwpd_indexed_step_fupd mwpD_SI, idx} e2 @ E {{ v; n, Φ v (S n) }}
  ⊢ MWP@{mwpd_indexed_step_fupd mwpD_SI, idx} e1 @ E {{ λ v n _, Φ v n }}.
Proof.
  iIntros(???) "H".
  iApply (mwp_lift_pure_det_head_step
            (mwpd_indexed_step_fupd mwpD_SI) idx E (λ v n _, Φ v n) e1);
    simpl; eauto.
  by iApply fupd_mask_intro_subseteq; first set_solver.
Qed.

End mwp_ectx_lifting.

Section mwp_ectxi_lifting.

Context {Λ : ectxiLanguage}.
Context {Σ} `{!invG Σ} (mwpD_SI : state Λ → iProp Σ).

Implicit Types P : iProp Σ.
Implicit Types Φ : (val Λ) → nat → iProp Σ.
Implicit Types v : (val Λ).
Implicit Types e : (expr Λ).

Typeclasses Transparent mwpC_state_interp mwpD_state_interp mwpC_modality.

Lemma mwp_indexed_step_fupd_lift_head_step' idx E Φ e1 :
  to_val e1 = None →
  (∀ Ki e', e1 = fill_item Ki e' → is_Some (to_val e')) →
   (∀ σ1, mwpD_SI σ1 ={E, ∅}=∗
        (∀ e2 σ2,
            ⌜head_step e1 σ1 [] e2 σ2 []⌝ ={∅, E}=∗
             (mwpD_SI σ2 ∗ MWP@{mwpd_indexed_step_fupd mwpD_SI, idx}
                     e2 @ E {{ w; n, Φ w (S n) }})))
     ⊢ MWP@{mwpd_indexed_step_fupd mwpD_SI, idx} e1 @ E {{ λ v n _, Φ v n }}.
Proof.
  by iIntros (??);
    iApply (mwp_lift_head_step'
              (mwpd_indexed_step_fupd mwpD_SI) idx E (λ v n _, Φ v n) e1).
Qed.

Lemma mwp_indexed_step_fupd_lift_pure_head_step' idx E Φ e1 :
  to_val e1 = None →
  (∀ Ki e', e1 = fill_item Ki e' → is_Some (to_val e')) →
  (∀ σ1 e2 σ2, head_step e1 σ1 [] e2 σ2 [] → σ1 = σ2) →
   (∀ σ1 e2 σ2,
       ⌜head_step e1 σ1 [] e2 σ2 []⌝ →
       MWP@{mwpd_indexed_step_fupd mwpD_SI, idx}
         e2 @ E {{ w; n, Φ w (S n) }})
     ⊢ MWP@{mwpd_indexed_step_fupd mwpD_SI, idx} e1 @ E {{ λ v n _, Φ v n }}.
Proof.
  iIntros (???) "?".
  iApply (mwp_lift_pure_head_step'
            (mwpd_indexed_step_fupd mwpD_SI) idx E (λ v n _, Φ v n) e1); eauto.
  simpl. by iApply fupd_mask_intro_subseteq; first set_solver.
Qed.

Lemma mwp_indexed_step_fupd_lift_atomic_head_step' idx E Φ e1:
  to_val e1 = None →
  (∀ Ki e', e1 = fill_item Ki e' → is_Some (to_val e')) →
  Atomic StronglyAtomic e1 →
   (∀ σ1, mwpD_SI σ1 ={E, ∅}=∗
      (∀ v2 σ2,
          ⌜head_step e1 σ1 [] (of_val v2) σ2 []⌝ ={∅, E}=∗
           (mwpD_SI σ2 ∗ |={E}[∅]▷=>^idx |={E}=> Φ v2 1)))
    ⊢ MWP@{mwpd_indexed_step_fupd mwpD_SI, idx } e1 @ E {{ λ v n _, Φ v n }}.
Proof.
  iIntros (???).
  by iApply (mwp_lift_atomic_head_step'
               (mwpd_indexed_step_fupd mwpD_SI) idx E (λ v n _, Φ v n) e1).
Qed.

Lemma mwp_indexed_step_fupd_lift_pure_det_head_step' idx E Φ e1 e2 :
  to_val e1 = None →
  (∀ Ki e', e1 = fill_item Ki e' → is_Some (to_val e')) →
  (∀ σ1 e2' σ2, head_step e1 σ1 [] e2' σ2 [] → σ1 = σ2 ∧ e2 = e2') →
  MWP@{mwpd_indexed_step_fupd mwpD_SI, idx} e2 @ E {{ v; n, Φ v (S n) }}
  ⊢ MWP@{mwpd_indexed_step_fupd mwpD_SI, idx} e1 @ E {{ λ v n _, Φ v n }}.
Proof.
  iIntros (???) "?".
  iApply (mwp_lift_pure_det_head_step'
            (mwpd_indexed_step_fupd mwpD_SI) idx E (λ v n _, Φ v n) e1); eauto.
  simpl. by iApply fupd_mask_intro_subseteq; first set_solver.
Qed.

End mwp_ectxi_lifting.

Section basmwp_soundness.
Context {Λ Σ} `{!invG Σ} (mwpD_SI : state Λ → iProp Σ).

Typeclasses Transparent mwpC_state_interp mwpC_modality.

Lemma mwp_indexed_step_fupd_adequacy_basic idx E e σ Φ :
  mwpD_SI σ ∗ MWP@{mwpd_indexed_step_fupd mwpD_SI, idx } e @ E {{ Φ }} -∗
    ∀ (rd : Reds e σ),
      |={E}[∅]▷=>^idx
        |={E}=> mwpD_SI (end_state rd) ∗ Φ (end_val rd) (nstps rd) tt.
Proof.
  iApply (mwp_adequacy_basic (mwpd_indexed_step_fupd mwpD_SI) idx E e σ Φ).
 Qed.

End basmwp_soundness.

Section soundness.
Context {Λ Σ} `{!invPreG Σ} {SI_data : Type} (mwpD_SI : SI_data → state Λ → iProp Σ).

Typeclasses Transparent mwpC_state_interp mwpC_modality.

Program Instance indexed_step_fupd_Initialization SSI `{!InitData SSI} idx :
  Initialization
    unit
    (λ H : invG_pack Σ SI_data, mwpd_indexed_step_fupd (mwpD_SI (PIG_cnt H)))
    (λ H, @mwpC_indexed_step_fupd Λ Σ _ (mwpD_SI (PIG_cnt H)))
    (λ _, idx) :=
{|
  initialization_modality Hi P := |={⊤}=> P;
  initialization_seed_for_modality _ := wsat ∗ ownE ⊤;
  initialization_seed_for_state_interp x := SSI (PIG_cnt x);
  initialization_residue _ := ▷ wsat ∗ ▷ ownE ⊤;
  initialization_elim_laters := 1;
  initialization_mwpCM_soundness_arg := unit;
  initialization_mwpCM_soundness_laters _ _ := S (S idx);
  initialization_modality_initializer _ _ := True;
  initialization_mwpCM_soundness_fun _ := tt;
  initialization_Ex_conv _ x := x;
|}%I.
Next Obligation.
Proof.
  intros; simpl.
  iApply (init_data (λ x, _ ∗ SSI (PIG_cnt x)))%I.
Qed.
Next Obligation.
Proof.
  iIntros (? ? _ P Hi) "[Hs HE] HP".
  rewrite uPred_fupd_eq /uPred_fupd_def.
  iMod ("HP" with "[$]") as "(Hs & HE & HP)".
  iModIntro. rewrite -!bi.later_sep.
  iMod "Hs"; iMod "HE"; iMod "HP". iNext.
  iFrame.
Qed.
Next Obligation.
Proof.
  iIntros (?? idx Hi P E n _) "[[Hs HE] [_ HP]]".
  iNext.
  rewrite /mwpC_modality /mwpD_modality /=.
  rewrite uPred_fupd_eq /uPred_fupd_def /=.
  replace ⊤ with ((⊤ ∖ E) ∪ E) by by rewrite difference_union_L; set_solver.
  iDestruct (ownE_op with "HE") as "[_ HE]"; first set_solver.
  iInduction idx as [] "IH".
  { iMod ("HP" with "[$Hs $HE]") as "(Hs & HE & HP)".
    by iMod "HP". }
  simpl.
  iMod ("HP" with "[$Hs $HE]") as "(Hs & HE & HP)".
  iMod "HP"; iMod "Hs"; iMod "HE".
  iNext.
  iMod ("HP" with "[$Hs $HE]") as "(Hs & HE & HP)".
  iMod "HP"; iMod "Hs"; iMod "HE".
  iApply ("IH" with "Hs HP HE").
Qed.

Lemma mwp_indexed_step_fupd_adequacy
      SSI `{!InitData SSI} (idx : nat) E e σ (Ψ : val Λ → nat → Prop):
  (∀ (Hcnd : invG_pack Σ SI_data),
      SSI (PIG_cnt Hcnd) ⊢
       |={⊤}=> (mwpD_SI (PIG_cnt Hcnd) σ ∗
                MWP@{mwpd_indexed_step_fupd (mwpD_SI (PIG_cnt Hcnd)), idx }
                e @ E {{ v ; n, ⌜Ψ v n⌝ }}))
  → ∀ (rd : Reds e σ), Ψ (end_val rd) (@nstps Λ _ _ rd).
Proof.
  intros Hic rd.
  apply (mwp_adequacy
           _ _ _ _ (indexed_step_fupd_Initialization SSI idx) E e σ (λ v n _, Ψ v n) tt).
  by iIntros (?) "?"; iMod (Hic with "[$]") as "[$ $]".
Qed.

End soundness.


Require Import VST.floyd.proofauto.
Local Open Scope logic.
Require Import Coq.Lists.List. Import ListNotations.
Require Import sha.general_lemmas.

Require Import tweetnacl20140427.split_array_lemmas.
Require Import ZArith.
Require Import tweetnacl20140427.tweetNaclBase.
Require Import tweetnacl20140427.Salsa20.
Require Import tweetnacl20140427.verif_salsa_base.
Require Import tweetnacl20140427.tweetnaclVerifiableC.
Require Import tweetnacl20140427.Snuffle.
Require Import tweetnacl20140427.spec_salsa. Opaque Snuffle.Snuffle.
Require Import tweetnacl20140427.verif_crypto_stream_salsa20_xor.

Lemma crypto_stream_salsa20_tweet_ok: semax_body SalsaVarSpecs (*(crypto_stream_salsa20_xor_spec::*)SalsaFunSpecs
      f_crypto_stream_salsa20_tweet
      f_crypto_stream_salsa20_tweet_spec.
Proof.
start_function.
abbreviate_semax.
forward_call (c, k, nullval, nonce, d, Nonce, K, list_repeat (Z.to_nat (Int64.unsigned d)) Byte.zero, gv).
{ simpl; entailer!. }
apply Zlength_list_repeat. apply Int64.unsigned_range.

forward.
Qed.

(*The crypto_stream function*)
Lemma crypto_stream_xsalsa20_tweet_ok:
      semax_body SalsaVarSpecs SalsaFunSpecs
      f_crypto_stream_xsalsa20_tweet
      f_crypto_stream_xsalsa20_tweet_spec.
Proof.
start_function. unfold data_at_, field_at_. simpl.
unfold Sigma_vector.
forward_call (gv _sigma, k, nonce, v_s,
        default_val (tarray tuchar 32),
        ((Nonce, SIGMA), K)).
{ unfold CoreInSEP, SByte. cancel. }
Intros v.
unfold CoreInSEP, SByte, Sigma_vector. normalize.
assert_PROP (isptr nonce) as PN by entailer!.
assert (exists HSalsaRes, hSalsaOut v =
   match HSalsaRes with (q1, q2) =>
     SixteenByte2ValList q1 ++ SixteenByte2ValList q2
   end).
{ unfold hSalsaOut.
  exists ((littleendian_invert (Znth 0 v),
           littleendian_invert (Znth 5 v),
           littleendian_invert (Znth 10 v),
           littleendian_invert (Znth 15 v)),
          (littleendian_invert (Znth 6 v),
           littleendian_invert (Znth 7 v),
           littleendian_invert (Znth 8 v),
           littleendian_invert (Znth 9 v))).
  do 2 rewrite SixteenByte2ValList_char. repeat rewrite <- app_assoc. trivial. }
destruct H0 as [HSalsaRes HS]. rewrite HS.
forward_call (c, v_s, offset_val 16 nonce, d, Nonce2, HSalsaRes, gv).
{ unfold SByte, Sigma_vector, ThirtyTwoByte.
  destruct HSalsaRes as [q1 q2]. cancel. }
forward.
unfold ThirtyTwoByte. entailer.
 Exists HSalsaRes. entailer. cancel.
destruct HSalsaRes as [q1 q2]. cancel.
Qed.

(*The crypto_stream_xor function*)
Lemma crypto_stream_xsalsa20_tweet_xor_ok:
      semax_body SalsaVarSpecs SalsaFunSpecs
      f_crypto_stream_xsalsa20_tweet_xor
      f_crypto_stream_xsalsa20_tweet_xor_spec.
Proof.
start_function.
rename v_s into s. rename H into mLen. unfold data_at_, field_at_. simpl.
unfold Sigma_vector.
forward_call (gv _sigma, k, nonce, s,
        default_val (tarray tuchar 32),
        ((Nonce, SIGMA), K)).
{ unfold CoreInSEP, SByte. cancel. }
Intros v.
unfold CoreInSEP, SByte, Sigma_vector. normalize.
assert_PROP (isptr nonce) as PN by entailer!.
assert (exists HSalsaRes, hSalsaOut v =
   match HSalsaRes with (q1, q2) =>
     SixteenByte2ValList q1 ++ SixteenByte2ValList q2
   end).
{ exists ((littleendian_invert (Znth 0 v),
           littleendian_invert (Znth 5 v),
           littleendian_invert (Znth 10 v),
           littleendian_invert (Znth 15 v)),
          (littleendian_invert (Znth 6 v),
           littleendian_invert (Znth 7 v),
           littleendian_invert (Znth 8 v),
           littleendian_invert (Znth 9 v))).
  do 2 rewrite SixteenByte2ValList_char. repeat rewrite <- app_assoc. trivial. }
destruct H0 as [[q1 q2] HS]. rewrite HS.
forward_call (c, s, m, offset_val 16 nonce, d, Nonce2, (q1,q2), mCont, gv).
{ unfold SByte, Sigma_vector, data_at_. cancel. }
forward.
Exists (q1, q2). unfold ThirtyTwoByte. entailer!.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
Require Import Coqlib.
Require Import Errors.
Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import MemoryExtra.
Require Import EventsExtra.
Require Import GlobalenvsExtra.
Require Import Locations.
Require Import DataType.
Require Import LAsm.
Require Import CDataTypes.
Require Import AsmExtra.
Require Clight.
Require Import Smallstep.
Require Import ClightBigstep.
Require Import Cop.
Require Import PCurID.
Require Import PAbQueue.
Require Export CurIDGen.
Require Import PAbQueueCode.
Require Import ZArith.Zwf.
Require Import EventsExtra.
Require Import GlobalenvsExtra.
Require Import Smallstep.
Require Import Op.
Require Import Values.
Require Import MemoryExtra.
Require Import Maps.
Require Import Heap.
Require Import RefinementTactic.
Require Import AuxLemma.
Require Import LayerTemplate2.
Require Import Implementation.
Require Import SeparateCompiler.
Require Import ClightImplemExtra.
Require Import LayerDefinition.
Require Import RealParams.
Require Import CInitSpecsMPTOp.
Require Import CInitSpecsMPTCommon.
Require Import CInitSpecsMPTBit.
Require Import CInitSpecsproc.

Open Local Scope string_scope.
Open Local Scope error_monad_scope.

Module CURIDGENIMPL.
  Export CurIDGen.CURIDGEN.

  Lemma hprim_finite_type:
    forall
      (Q: PCURID.primOp -> Prop)
      (Q_dec: forall p, {Q p} + {~ Q p}),
      {forall p, Q p} + {~ forall p, Q p}.
  Proof with (try (right; eauto; fail)).
    intros.
    destruct (Q_dec PCURID.PAlloc)...
    destruct (Q_dec PCURID.PFree)...
    destruct (Q_dec PCURID.PSetPT)...
    destruct (Q_dec PCURID.PPTRead)...
    destruct (Q_dec PCURID.PPTResv)...
    destruct (Q_dec PCURID.PKCtxtNew)...
    destruct (Q_dec PCURID.PThreadFree)...
    destruct (Q_dec PCURID.PKCtxtSwitch)...
    destruct (Q_dec PCURID.PGetState)...
    destruct (Q_dec PCURID.PSetState)...
    destruct (Q_dec PCURID.PDeQueue)...
    destruct (Q_dec PCURID.PEnQueue)...
    destruct (Q_dec PCURID.PQueueRmv)...
    destruct (Q_dec PCURID.PGetCurID)...
    destruct (Q_dec PCURID.PSetCurID)...
    destruct (Q_dec PCURID.PPTIn)...
    destruct (Q_dec PCURID.PPTOut)...
    destruct (Q_dec PCURID.PTrapIn)...
    destruct (Q_dec PCURID.PTrapOut)...
    destruct (Q_dec PCURID.PHostIn)...
    destruct (Q_dec PCURID.PHostOut)...
    destruct (Q_dec PCURID.PTrapGet)...
    destruct (Q_dec PCURID.PTrapRet)...
    destruct (Q_dec PCURID.PTDQueueInit)...
    left; destruct p; assumption.
  Defined.

  Section WithPrimitives.

  Context `{real_params: RealParams}.

    Notation HDATA := (PCURID.AbData(PgSize:=PgSize) (num_proc:=num_proc)(kern_low:=kern_low)
                                    (kern_high:=kern_high) (maxpage:=maxpage) (num_chan := num_chan)).
    Notation LDATA := (PABQUEUE.AbData(PgSize:=PgSize)(num_proc:=num_proc) (kern_low:=kern_low)
                                      (kern_high:=kern_high) (maxpage:=maxpage) (num_chan := num_chan)).

    Notation Hfundef := (Asm.fundef (external_function:= PCURID.primOp)).
    Notation Lfundef := (Asm.fundef (external_function:= PABQUEUE.primOp)).

    Notation funkind := (funkind (low:= PABQUEUE.primOp) Asm.code (Clight.fundef (external_function := PABQUEUE.primOp))).

    Definition source_implem_extfuns (p: PCURID.primOp): funkind :=
      match p with
        | PCURID.PAlloc => Code _ (AST.External PABQUEUE.PAlloc)
        | PCURID.PFree => Code _ (AST.External PABQUEUE.PFree)
        | PCURID.PSetPT => Code _ (AST.External PABQUEUE.PSetPT)
        | PCURID.PPTRead => Code _ (AST.External PABQUEUE.PPTRead)
        | PCURID.PPTResv => Code _ (AST.External PABQUEUE.PPTResv)
        | PCURID.PKCtxtNew => Code _ (AST.External PABQUEUE.PKCtxtNew)
        | PCURID.PThreadFree => Code _ (AST.External PABQUEUE.PThreadFree)
        | PCURID.PKCtxtSwitch => Code _ (AST.External PABQUEUE.PKCtxtSwitch)
        | PCURID.PGetState => Code _ (AST.External PABQUEUE.PGetState)
        | PCURID.PSetState => Code _ (AST.External PABQUEUE.PSetState)
        | PCURID.PDeQueue => Code _ (AST.External PABQUEUE.PDeQueue)
        | PCURID.PEnQueue => Code _ (AST.External PABQUEUE.PEnQueue)
        | PCURID.PQueueRmv => Code _ (AST.External PABQUEUE.PQueueRmv)
        | PCURID.PGetCurID => SourceFun (Clight.Internal PABQUEUECODE.f_get_curid) (AST.Internal nil)
        | PCURID.PSetCurID => SourceFun (Clight.Internal PABQUEUECODE.f_set_curid) (AST.Internal nil)
        | PCURID.PPTIn => Code _ (AST.External PABQUEUE.PPTIn)
        | PCURID.PPTOut => Code _ (AST.External PABQUEUE.PPTOut)
        | PCURID.PTrapIn => Code _ (AST.External PABQUEUE.PTrapIn)
        | PCURID.PTrapOut => Code _ (AST.External PABQUEUE.PTrapOut)
        | PCURID.PHostIn => Code _ (AST.External PABQUEUE.PHostIn)
        | PCURID.PHostOut => Code _ (AST.External PABQUEUE.PHostOut)
        | PCURID.PTrapGet => Code _ (AST.External PABQUEUE.PTrapGet)
        | PCURID.PTrapRet => Code _ (AST.External PABQUEUE.PTrapRet)
        | PCURID.PTDQueueInit => Code _ (AST.External PABQUEUE.PTDQueueInit)
      end.

    Notation varkind := (varkind unit Ctypes.type).

    Definition source_implem_new_globs : list (ident * option (globdef funkind varkind)) :=
        (CURID_LOC, Some (Gvar (mkglobvar (SourceVar tint tt) (wrap_init_data 1) false)))
        :: nil.

    Let NOREPET: list_norepet (CURID_LOC :: nil).
    Proof.
      case_eq (list_norepet_dec peq (CURID_LOC :: nil)); try discriminate; tauto.
    Qed.

    Definition source_implem : source_implem Asm.code unit PCURID.primOp (low := PABQUEUE.primOp) (Clight.fundef (external_function := PABQUEUE.primOp)) Ctypes.type.
    Proof.
      split.
       exact source_implem_extfuns.
       exact source_implem_new_globs.
    Defined.

    Let im : implem Asm.code unit PCURID.primOp (low := PABQUEUE.primOp) := implem_of_source_implem transf_clight_fundef Cshmgen.transl_globvar source_implem.

    Notation Hprogram := (Asm.program (external_function:= PCURID.primOp)).
    Notation Lprogram := (Asm.program (external_function:= PABQUEUE.primOp)).

    Let Im_get_curid: Lfundef := transf_source_fun' transf_clight_fundef (source_implem_extfuns PCURID.PGetCurID).
    Let Im_set_curid: Lfundef := transf_source_fun' transf_clight_fundef (source_implem_extfuns PCURID.PSetCurID).

    Notation new_glbl := (new_glbl CURID_LOC).

    Let impl_glbl :  list (ident * option (globdef Lfundef unit)) := nil.

    (* This is basically an axiom that can be easily checked because PCURID.primOp is a finite type. However, in practice, generation of CertiKOS code will be very slow because compilation will have to occur twice, one for this check, and a second independently for the generation of the actual code. *)

    Lemma extfun_compilation_succeeds_dec:
      {forall p clight asmfallback,
        source_implem_extfuns p = SourceFun clight asmfallback ->
        exists asm, transf_clight_fundef clight = OK asm} +
      {~ forall p clight asmfallback,
        source_implem_extfuns p = SourceFun clight asmfallback ->
        exists asm, transf_clight_fundef clight = OK asm}.
    Proof.
      apply hprim_finite_type.
      intro.
      destruct (source_implem_extfuns p); try (left; discriminate).
      case_eq (transf_clight_fundef sf).
       left. intros. inv H0. eauto.
      intros. right. intro. exploit H0; eauto. destruct 1. congruence.
    Defined.

    Hypothesis extfun_compilation_succeeds:
      forall p clight asmfallback,
        source_implem_extfuns p = SourceFun clight asmfallback ->
        exists asm, transf_clight_fundef clight = OK asm.

    Section WithProg.

    Variable prog: Hprogram.

    Definition tprog: Lprogram := Implementation.transf_program im prog.

    Let TRANSF: CURIDGEN.transf_program Im_get_curid Im_set_curid CURID_LOC impl_glbl prog = OK tprog.
    Proof.
      unfold tprog.
      unfold Asm.program, Asm.fundef.
      generalize (transf_program_eq im prog).
      intros.
      rewrite <- H.
      unfold transf_program.
      simpl.
      f_equal.
      apply FunctionalExtensionality.functional_extensionality.
      destruct x; simpl.
       reflexivity.
      destruct p; reflexivity.
    Qed.

    Hypothesis prog_nonempty:
      prog_defs_names prog <> nil.

    Hypothesis prog_main_valid:
      ~ Plt' (prog_main prog) (prog_first_symbol prog).

    Hypothesis prog_first_valid:
      ~ Plt' (prog_first_symbol prog) (get_next_symbol (map fst source_implem_new_globs)).

    Let VALID_LOC: (CURID_LOC <> (prog_main prog)).
    Proof.
      intro.
      exploit (get_next_symbol_prop CURID_LOC (map fst (source_implem_new_globs))).
      simpl; tauto.
      eapply Ple_not_Plt.
      apply Ple_Ple'.
      eapply Ple'_trans.
      apply not_Plt'_Ple'.
      eassumption.
      apply not_Plt'_Ple'.
      congruence.
    Qed.

    Notation ge := (Genv.globalenv prog).
    Notation tge := (Genv.globalenv tprog).

    Let NEW_INJ:  (forall s', Genv.find_symbol ge s' <> None ->
                                     ~ In s' (map fst new_glbl)).
    Proof.
      change new_glbl with (implem_new_globs im).
      eapply new_ids_fresh.
      assumption.
    Qed.

    Let sprog : Clight.program (external_function := PABQUEUE.primOp) := source_program_only source_implem prog.
    Let sge := Genv.globalenv sprog.

    Let tsprog_strong : {tsprog | transf_clight_program sprog = OK tsprog}.
    Proof.
      case_eq (transf_clight_program sprog); eauto.
      intros. exfalso.
      refine (_ (Implementation.compilation_succeeds
                    transf_clight_fundef
                    Cshmgen.transl_globvar
                    source_implem _ _ _
                    prog)).
      destruct 1.
      exploit (transf_clight_fundef_to_program (external_function := PABQUEUE.primOp)); eauto.
      unfold sprog in H.
      congruence.
      assumption.
      simpl. destruct 1; try discriminate. destruct H0; try discriminate.
      unfold Cshmgen.transl_globvar. eauto.
    Qed.

    Let tsprog := let (p, _) := tsprog_strong in p.

    Let tsprog_prop : transf_clight_program sprog = OK tsprog.
    Proof.
      unfold tsprog.
      destruct tsprog_strong.
      assumption.
    Qed.

    Let tsge := Genv.globalenv tsprog.

    Lemma curid_loc_prop:
      forall b0,
        Genv.find_symbol tge CURID_LOC = Some b0 ->
        Genv.find_symbol sge CURID_LOC = Some b0 /\
        Clight.type_of_global sge b0 = Some tint.
    Proof.
      intros.
      refine (_ (find_new_var_prop _ _ source_implem NOREPET _ NEW_INJ
                                   CURID_LOC
                                   (mkglobvar (SourceVar tint tt) (wrap_init_data 1) false)
                                   _ (refl_equal _) H)).
      destruct 1.
      split; auto.
      unfold Clight.type_of_global.
      unfold sge, sprog.
      rewrite H1.
      reflexivity.
      simpl; tauto.
    Qed.

    Let well_idglob_impl_glbl: Genv.well_idglob_list impl_glbl = true.
    Proof. reflexivity. Qed.

    Let CURID_LOC_not_in: ~ In CURID_LOC (prog_defs_names prog).
    Proof.
      intro. exploit Genv.find_symbol_exists_ex; eauto. destruct 1.
      assert (Genv.find_symbol ge CURID_LOC <> None) by congruence.
      eapply NEW_INJ; eauto.
      simpl; tauto.
    Qed.

    Lemma tprog_first_next:
      prog_first_symbol tprog = get_first_symbol (map fst source_implem_new_globs) /\
      prog_next_symbol  tprog = prog_next_symbol prog.
    Proof.
      change (get_first_symbol (map fst source_implem_new_globs)) with (implem_first_symbol im).
      unfold tprog.
      apply transf_program_first_next_symbol.
      assumption.
      assumption.
      discriminate.
    Qed.

    Lemma tprog_main_valid:
      ~ Plt' (prog_main tprog) (prog_first_symbol tprog).
    Proof.
      Opaque Plt'.
      simpl.
      destruct tprog_first_next.
      rewrite H.
      apply Ple'_not_Plt'.
      eapply Ple'_trans.
      apply first_le_next.
      discriminate.
      eapply Ple'_trans.
      apply not_Plt'_Ple'.
      eassumption.
      apply not_Plt'_Ple'.
      assumption.
    Qed.

    Lemma tprog_nonempty:
      prog_defs_names tprog <> nil.
    Proof.
      apply transf_program_nonempty.
      assumption.
    Qed.

    Context `{PageFaultHandler_LOC: ident}.

    Section WITHMEM.

      Local Instance HdataOp:AbstractDataOps HDATA:= (PCURID.abstract_data (Hnpc:= Hnpc)).

      Context {mem__H} {mem__L}
              `{Hlmmh: !LayerMemoryModel HDATA mem__H}
              `{Hlmml: !LayerMemoryModel LDATA mem__L}
              `{Hlmi: !LayerMemoryInjections HDATA LDATA mem__H mem__L}.

      Instance HLayer: LayerDefinition (layer_mem:= Hlmmh) HDATA PCURID.primOp mem__H :=
        PCURID.layer_def (Hnpc:=Hnpc)(PgSize:=PgSize) (num_proc:=num_proc)(HPS4:=HPS4)(Hlow:=Hlow)(Hhigh:=Hhigh)
                         (kern_low:=kern_low) (kern_high:=kern_high) (maxpage:=maxpage) (real_abtcb := real_abtcb)
                         (real_nps:=real_nps) (real_AT := real_AT)(real_ptp:=real_ptp)(real_pt:=real_pt)
                         (real_ptb:= real_ptb) (real_free_pt:= real_free_pt) (STACK_LOC:= STACK_LOC)
                         (num_chan:= num_chan) (real_abq:= real_abq) (Hnchan:= Hnchan).

      Instance LLayer: LayerDefinition (layer_mem:= Hlmml) LDATA PABQUEUE.primOp mem__L :=
        PABQUEUE.layer_def (Hnpc:=Hnpc)(PgSize:=PgSize) (num_proc:=num_proc)(HPS4:=HPS4)(Hlow:=Hlow)(Hhigh:=Hhigh)
                           (kern_low:=kern_low) (kern_high:=kern_high) (maxpage:=maxpage) (real_abtcb := real_abtcb)
                           (real_nps:=real_nps) (real_AT := real_AT)(real_ptp:=real_ptp)(real_pt:=real_pt)
                           (real_ptb:= real_ptb) (real_free_pt:= real_free_pt) (STACK_LOC:= STACK_LOC)
                           (num_chan:= num_chan) (real_abq:= real_abq) (Hnchan:= Hnchan).

      Notation LLoad := (PABQUEUE.exec_loadex (PgSize:=PgSize)(NPT_LOC:= NPT_LOC) (PageFaultHandler_LOC:= PageFaultHandler_LOC)).
      Notation LStore := (PABQUEUE.exec_storeex (PgSize:=PgSize)(NPT_LOC:= NPT_LOC) (PageFaultHandler_LOC:= PageFaultHandler_LOC)).
      Notation HLoad := (PCURID.exec_loadex (PgSize:=PgSize)(NPT_LOC:= NPT_LOC) (PageFaultHandler_LOC:= PageFaultHandler_LOC)).
      Notation HStore := (PCURID.exec_storeex (PgSize:=PgSize)(NPT_LOC:= NPT_LOC) (PageFaultHandler_LOC:= PageFaultHandler_LOC)).

      Notation lstep := (PABQUEUE.step (NPT_LOC:=NPT_LOC) (PageFaultHandler_LOC:= PageFaultHandler_LOC) (HPS4:= HPS4)
                                       (real_nps:= real_nps) (real_AT:= real_AT) (Hlow:= Hlow) (Hhigh:= Hhigh)
                                       (real_ptp := real_ptp) (real_pt:= real_pt) (Hnpc := Hnpc) (real_ptb:= real_ptb)
                                       (real_free_pt:= real_free_pt) (STACK_LOC:= STACK_LOC)(real_abtcb:=real_abtcb)
                                       (Hnchan := Hnchan) (real_abq:= real_abq)).

      Notation LADT := PABQUEUE.ADT.

      Let get_curid_spec:
        forall r' b m'0 b1 r sig,
          r' PC = Vptr b Int.zero
          -> Genv.find_funct_ptr tge b = Some (Im_get_curid)
          -> Genv.find_funct_ptr ge b = Some (External PCURID.PGetCurID)
          -> Genv.find_symbol tge CURID_LOC = Some b1
          -> Mem.load Mint32 m'0 b1 0 = Some (Vint r)
          -> PABQUEUE.ikern (LADT (Mem.get_abstract_data m'0)) = true
          -> PABQUEUE.pe (LADT (Mem.get_abstract_data m'0)) = true
          -> PABQUEUE.ihost (LADT (Mem.get_abstract_data m'0)) = true
          -> Mem.tget m'0 b1 = Some Tag_global
          -> sig = mksignature nil (Some Tint)
          -> (forall b o, r' ESP = Vptr b o -> Mem.tget m'0 b = Some Tag_stack)
          -> r' ESP <> Vundef
          -> r' RA  <> Vundef
          -> asm_invariant tge (State r' m'0)
          -> extcall_arguments r' m'0 sig nil
          -> exists f' m0' r_,
               inject_incr (Mem.flat_inj (Mem.nextblock m'0)) f'
               /\ Memtype.Mem.inject f' m'0 m0'
               /\ Mem.nextblock m'0 <= Mem.nextblock m0'
               /\ plus lstep tge (State r' m'0) E0 (State r_ m0')
               /\ r_ # (loc_external_result sig) = (Vint r)
               /\ r_ PC = r' RA
               /\ r_ # ESP = r' # ESP
               /\ (forall l,
                     ~In (Locations.R l) Conventions1.temporaries -> ~In (Locations.R l) Conventions1.destroyed_at_call
                     -> Val.lessdef (r' (preg_of l)) (r_ (preg_of l))).
        Proof.
          intros.
          exploit curid_loc_prop; eauto.
          destruct 1.
          exploit (ClightImplemExtra.bigstep_clight_to_lsem
                     PCURID.primOp
                     (exec_load := LLoad)
                     (exec_store := LStore)
                     (primitive_call := PABQUEUE.primitive_call)
                     (is_primitive_call := PABQUEUE.is_primitive_call)
                     (kernel_mode := PABQUEUE.kernel_mode)
                  ).
          apply PABQUEUE.exec_load_exec_loadex.
          apply PABQUEUE.exec_store_exec_storeex.
          apply PABQUEUE.extcall_not_primitive.
          apply PABQUEUE.primitive_kernel_mode.
          3: eassumption.
          assumption.
          assumption.
          2: eassumption.
          5: eassumption.
          9: eassumption.
          7: reflexivity.
          intros; eapply PABQUEUECODE.get_curid_correct; eauto.
          assumption.
          assumption.
          assumption.
          assumption.
          assumption.
          unfold PABQUEUE.kernel_mode.
          destruct (PABQUEUE.INV (Mem.get_abstract_data m'0)).
          auto.
          destruct 1 as [? [? [? [? [? [? [? [? [? [? ?]]]]]]]]]].
          inv H20.
          eauto 11.
        Qed.

    Let set_curid_spec:
      forall r' b m'0 b0 m0 i sig,
          r' PC = Vptr b Int.zero
          -> Genv.find_funct_ptr tge b = Some (Im_set_curid)
          -> Genv.find_funct_ptr ge b = Some (External PCURID.PSetCurID)
          -> Genv.find_symbol tge CURID_LOC = Some b0
          -> Mem.store Mint32 m'0 b0 0 (Vint i) = Some m0
          -> PABQUEUE.ikern (LADT (Mem.get_abstract_data m'0)) = true
          -> PABQUEUE.pe (LADT (Mem.get_abstract_data m'0)) = true
          -> PABQUEUE.ihost (LADT (Mem.get_abstract_data m'0)) = true
          -> Mem.tget m'0 b0 = Some Tag_global
          -> sig = mksignature (Tint::nil) None
          -> (forall b o, r' ESP = Vptr b o -> Mem.tget m'0 b = Some Tag_stack)
          -> r' ESP <> Vundef
          -> r' RA  <> Vundef
          -> asm_invariant tge (State r' m'0)
          -> extcall_arguments r' m'0 sig (Vint i:: nil)
          -> exists f' m0' r_,
               inject_incr (Mem.flat_inj (Mem.nextblock m0)) f'
               /\ Memtype.Mem.inject f' m0 m0'
               /\ Mem.nextblock m0 <= Mem.nextblock m0'
               /\ plus lstep tge (State r' m'0) E0 (State r_ m0')
               /\ True
               /\ r_ PC = r' RA
               /\ r_ # ESP = r' # ESP
               /\ (forall l,
                     ~In (Locations.R l) Conventions1.temporaries -> ~In (Locations.R l) Conventions1.destroyed_at_call
                     -> Val.lessdef (r' (preg_of l)) (r_ (preg_of l))).
    Proof.
      intros.
      exploit curid_loc_prop; eauto.
      destruct 1.
      exploit (ClightImplemExtra.bigstep_clight_to_lsem
                 PCURID.primOp
                 (exec_load := LLoad)
                 (exec_store := LStore)
                 (primitive_call := PABQUEUE.primitive_call)
                 (is_primitive_call := PABQUEUE.is_primitive_call)
                 (kernel_mode := PABQUEUE.kernel_mode)
              ).
      apply PABQUEUE.exec_load_exec_loadex.
      apply PABQUEUE.exec_store_exec_storeex.
      apply PABQUEUE.extcall_not_primitive.
      apply PABQUEUE.primitive_kernel_mode.
      3: eassumption.
      assumption.
      assumption.
      2: eassumption.
      5: eassumption.
      9: eassumption.
      7: reflexivity.
      intros; eapply PABQUEUECODE.set_curid_correct; eauto.
      assumption.
      assumption.
      assumption.
      assumption.
      assumption.
      unfold PABQUEUE.kernel_mode.
      destruct (PABQUEUE.INV (Mem.get_abstract_data m'0)).
      auto.
      destruct 1 as [? [? [? [? [? [? [? [? [? [? ?]]]]]]]]]].
      rewrite (Mem.nextblock_store _ _ _ _ _ _ H3).
      eauto 11.
    Qed.

    Theorem transf_program_correct:
      Smallstep.backward_simulation
          (PCURID.semantics (NPT_LOC:= NPT_LOC) (PgSize:=PgSize) (PageFaultHandler_LOC:= PageFaultHandler_LOC)
                            (real_AT:= real_AT) (real_nps:= real_nps) (Hmem:= Hlmmh) (HPS4:= HPS4) (Hnpc:= Hnpc)
                            (Hlow := Hlow) (Hhigh:= Hhigh) (real_ptp:= real_ptp) (real_pt:= real_pt) (real_abq:= real_abq)
                            (real_ptb:= real_ptb) (real_free_pt:= real_free_pt) (STACK_LOC:= STACK_LOC)
                            (num_chan:= num_chan) (real_abtcb:= real_abtcb) (Hnchan:= Hnchan) prog)
          (PABQUEUE.semantics (NPT_LOC:= NPT_LOC) (PgSize:=PgSize) (PageFaultHandler_LOC:= PageFaultHandler_LOC)
                              (real_AT:= real_AT) (real_nps:= real_nps) (Hmem:= Hlmml) (HPS4:= HPS4)
                              (Hlow := Hlow) (Hhigh:= Hhigh) (real_ptp:= real_ptp) (real_pt:= real_pt)
                              (Hnpc:= Hnpc) (real_ptb:= real_ptb) (real_free_pt:= real_free_pt) (STACK_LOC:= STACK_LOC)
                              (real_abtcb:= real_abtcb) (Hnchan:= Hnchan) (real_abq:= real_abq) tprog).
    Proof.
      eapply CURIDGEN.transf_program_correct; simpl; eauto.
      Grab Existential Variables.
      omega.
    Qed.

    End WITHMEM.

    End WithProg.

 End WithPrimitives.

End CURIDGENIMPL.


From Perennial.goose_lang Require Import prelude.
From Perennial.goose_lang Require Export ffi.grove_prelude.
From Perennial.program_proof Require Import proof_prelude.
From Perennial.program_proof.ctrexample Require Import interface.
From Perennial.program_proof Require Import marshal_proof.
From Goose.github_com.mit_pdos.gokv.ctrexample Require Import client.
From Perennial.program_proof.grove_shared Require Import urpc_proof.
From Perennial.program_proof.ctrexample Require Import wpc_proofmode.

Section client_proof.

Context `{!heapGS Σ}.
Context `{!filesysG Σ}.
Context `{!inG Σ mono_natUR}.
Context `{!urpcregG Σ}.

Lemma wpc_ClientMain γurpc_gn γ :
  is_CtrServer_urpc γurpc_gn γ -∗
    counter_lb γ 0 -∗
    WP main #()
  {{
      v, True
  }}.
Proof.
  iIntros "#Hsrv #Hlb".
  wp_lam.
  wp_pures.
  wp_apply (wp_MakeClient).
  iIntros (cl_ptr) "Hcl".
  wp_pures.
  wp_apply (wp_ref_to).
  { eauto. }
  iIntros (localBound_ptr) "HlocalBound".
  wp_pures.

  iAssert (∃ x, counter_lb γ x ∗ localBound_ptr ↦[uint64T] #(U64 x))%I with "[HlocalBound Hlb]" as "HH".
  {
    iExists 0%nat. iFrame "#∗".
  }
  wp_forBreak.
  wp_pures.

  iClear "Hlb".
  iDestruct "HH" as (localBound) "[#Hlb HlocalBound]".

  wp_apply (wp_ref_of_zero).
  { done. }
  iIntros (rep) "Hrep".
  wp_pures.
  wp_apply (wp_NewSlice _ _ byteT).
  iIntros (empty_req) "Hempty_sl".

  iDestruct (is_slice_to_small with "Hempty_sl") as "Hempty_sl".
  wp_apply (wp_Client__Call with "[] [$Hcl $Hrep $Hempty_sl]").
  { iDestruct "Hsrv" as "[$ _]". }
  {
    instantiate (1:=(λ l, ∃ (x:nat), ⌜has_encoding l [EncUInt64 (U64 x)] ∧ localBound ≤ x⌝ ∗ counter_lb γ x)%I).
    iModIntro.
    iModIntro.
    simpl.
    iIntros (x) "Hctr".
    rewrite /counter_own /counter_lb.
    iDestruct (own_valid_2 with "Hctr Hlb") as %Hineq.
    (* FIXME: Q: what is setoid_rewrite, and why does it work when rewrite does not? *)
    setoid_rewrite mono_nat_both_valid in Hineq.
    rewrite mono_nat_auth_lb_op.
    iDestruct (own_op with "Hctr") as "[Hctr #Hlb2]".
    iDestruct (own_update with "Hctr") as ">$".
    { apply mono_nat_update. word. }
    iModIntro.
    iIntros.
    iExists x.
    unfold counter_lb.
    iFrame "#".
    iPureIntro.
    split.
    { done. }
    lia.
  }
  iIntros (err) "(Hcl & Hreq & Hrep)".
  wp_pures.
  wp_if_destruct.
  {
    iLeft. iModIntro.
    iSplitL ""; first done.
    iFrame "∗#".
    iExists _; iFrame "∗#".
  }
  destruct err.
  {
    exfalso.
    destruct c; done.
  }
  iNamed "Hrep".
  iDestruct "Hrep" as "(Hrep & Hrep_sl & HPost)".
  iDestruct "HPost" as (x) "[[%HencPost %Hlb2] Hlb2]".
  wp_pures.
  wp_load.
  wp_apply (wp_new_dec with "[Hrep_sl]").
  { done. }
  { done. }
  iIntros (dec) "Hdec".
  wp_pures.
  wp_apply (wp_Dec__GetInt with "Hdec").
  iIntros "Hdec".
  wp_pures.
  wp_load.
  wp_pures.
  wp_apply (wp_Assert).
  {
    apply bool_decide_eq_true.
    (* FIXME: overflow related *)
    admit.
  }
  wp_pures.
  wp_store.
  iModIntro.
  iLeft.
  iSplitL ""; first done.
  iFrame.
  iExists _; iFrame "∗#".
Admitted.

End client_proof.


Require Import RelationClasses.
Require Import Bool.
Require Import List.

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

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

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

Require Import FulfillStep.
Require Import SimMemory.
Require Import SimPromises.

Require Import Syntax.
Require Import Semantics.

Set Implicit Arguments.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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