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

Local Open Scope Z_scope.

Section SpecLow.

  Definition data_create_spec0 (g_rd: Pointer) (data_addr: Z64) (map_addr: Z64) (g_data: Pointer) (g_src: Pointer) (adt: RData) : option (RData * Z64) :=
    match g_rd, data_addr, map_addr, g_data, g_src with
    | (_g_rd_base, _g_rd_ofst), VZ64 _data_addr, VZ64 _map_addr, (_g_data_base, _g_data_ofst), (_g_src_base, _g_src_ofst) =>
      rely is_int (4 - 1);
      rely is_int64 _map_addr;
      rely is_int64 (4 - 1);
      when adt == table_walk_lock_unlock_spec (_g_rd_base, _g_rd_ofst) (VZ64 _map_addr) (VZ64 (4 - 1)) adt;
      when'' _g_llt_base, _g_llt_ofst == get_wi_g_llt_spec  adt;
      rely is_int _g_llt_ofst;
      when' _index == get_wi_index_spec  adt;
      rely is_int64 _index;
      when _t'7 == is_null_spec (_g_llt_base, _g_llt_ofst) adt;
      rely is_int _t'7;
      if (_t'7 =? 1) then
        let _ret := 1 in
        Some (adt, (VZ64 _ret))
      else
        when'' _ll_table_base, _ll_table_ofst, adt == granule_map_spec (_g_llt_base, _g_llt_ofst) 5 adt;
        rely is_int _ll_table_ofst;
        when' _pte_val == pgte_read_spec (_ll_table_base, _ll_table_ofst) (VZ64 _index) adt;
        rely is_int64 _pte_val;
        rely is_int64 (Z.land _pte_val 504403158265495552);
        rely is_int64 ((Z.land _pte_val 504403158265495552) / 72057594037927936);
        if (negb (((Z.land _pte_val 504403158265495552) / 72057594037927936) =? 0)) then
          let _ret := 1 in
          when adt == buffer_unmap_spec (_ll_table_base, _ll_table_ofst) adt;
          when adt == granule_unlock_spec (_g_llt_base, _g_llt_ofst) adt;
          Some (adt, (VZ64 _ret))
        else
          when'' _data_base, _data_ofst, adt == granule_map_spec (_g_data_base, _g_data_ofst) 1 adt;
          rely is_int _data_ofst;
          when adt == ns_granule_map_spec 0 (_g_src_base, _g_src_ofst) adt;
          when _ns_access_ok, adt == ns_buffer_read_data_spec 0 (_data_base, _data_ofst) adt;
          rely is_int _ns_access_ok;
          when adt == ns_buffer_unmap_spec 0 adt;
          if (_ns_access_ok =? 0) then
            when adt == granule_memzero_mapped_spec (_data_base, _data_ofst) adt;
            let _ret := 1 in
            when adt == buffer_unmap_spec (_data_base, _data_ofst) adt;
            when adt == buffer_unmap_spec (_ll_table_base, _ll_table_ofst) adt;
            when adt == granule_unlock_spec (_g_llt_base, _g_llt_ofst) adt;
            Some (adt, (VZ64 _ret))
          else
            rely is_int64 (1 * 72057594037927936);
            rely is_int64 (Z.lor (1 * 72057594037927936) _data_addr);
            let _pte_val := (Z.lor (1 * 72057594037927936) _data_addr) in
            when adt == pgte_write_spec (_ll_table_base, _ll_table_ofst) (VZ64 _index) (VZ64 _pte_val) adt;
            rely is_int64 _data_addr;
            when adt == set_mapping_spec (VZ64 _map_addr) (VZ64 _data_addr) adt;
            when adt == granule_get_spec (_g_llt_base, _g_llt_ofst) adt;
            let _ret := 0 in
            when adt == buffer_unmap_spec (_data_base, _data_ofst) adt;
            when adt == buffer_unmap_spec (_ll_table_base, _ll_table_ofst) adt;
            when adt == granule_unlock_spec (_g_llt_base, _g_llt_ofst) adt;
            Some (adt, (VZ64 _ret))
     end
    .

End SpecLow.


Require Import Rel.Definitions.
Require Import LibReflect LibList.
Require Import Util.Wf_natnat.
Require Import Lang.Static.
Require Import Lang.BindingsFacts.
Require Import Lang.StaticFacts.
Set Implicit Arguments.

Implicit Types EV HV : Set.

Section section_X_weaken_aux.

Local Hint Extern 1 => match goal with
| [ |- ?n ⊨ ?X ≈ᵢ ?X ] => repeat iintro ; apply auto_contr_id
| [ |- ?n ⊨ ?X ⇔ ?X ] => apply auto_contr_id
| [ |- Acc lt' (_, _) ] => try lt'_solve
end.

Fixpoint
  X_weaken_𝓾_aux
  (n : nat)
  (EV HV : Set)
  (Ξ Ξ' : XEnv EV HV)
  (Wf_ΞΞ' : wf_XEnv (Ξ & Ξ'))
  (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig)
  (ρ₁ ρ₂ : HV → hd0) (ρ : HV → IRel 𝓣_Sig)
  (ξ₁ ξ₂ : list var)
  (t₁ t₂ : tm0) (ψ : IRel 𝓣_Sig) l₁ l₂ (ε : ef EV HV ∅)
  (Wf_ε : wf_ef Ξ ε)
  (W : Acc lt' (n, 0))
  {struct W} :
  (n ⊨
    𝓾⟦ Ξ ⊢ ε ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂ ⇔
    𝓾⟦ (Ξ & Ξ') ⊢ ε ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂)

with
  X_weaken_𝓤_aux
  (n : nat)
  (EV HV : Set)
  (Ξ Ξ' : XEnv EV HV)
  (Wf_ΞΞ' : wf_XEnv (Ξ & Ξ'))
  (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig)
  (ρ₁ ρ₂ : HV → hd0) (ρ : HV → IRel 𝓣_Sig)
  (ξ₁ ξ₂ : list var)
  (t₁ t₂ : tm0) (ψ : IRel 𝓣_Sig) l₁ l₂ (𝓔 : eff EV HV ∅)
  (Wf_𝓔 : wf_eff Ξ 𝓔)
  (W : Acc lt' (n, size_eff 𝓔))
  {struct W} :
  (n ⊨
    𝓤⟦ Ξ ⊢ 𝓔 ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂ ⇔
    𝓤⟦ (Ξ & Ξ') ⊢ 𝓔 ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂)

with
  X_weaken_𝓥_aux
  (n : nat)
  (EV HV : Set)
  (Ξ Ξ' : XEnv EV HV)
  (Wf_ΞΞ' : wf_XEnv (Ξ & Ξ'))
  (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig)
  (ρ₁ ρ₂ : HV → hd0) (ρ : HV → IRel 𝓣_Sig)
  (ξ₁ ξ₂ : list var)
  (v₁ v₂ : val0) (T : ty EV HV ∅)
  (Wf_T : wf_ty Ξ T)
  (W : Acc lt' (n, size_ty T))
  {struct W} :
  (n ⊨
    𝓥⟦ Ξ ⊢ T ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ v₁ v₂ ⇔
    𝓥⟦ (Ξ & Ξ') ⊢ T ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ v₁ v₂)
.

Proof.

{
destruct ε as [ α | [ p | [ | X ] ] ] ; simpl.
+ auto_contr.
+ auto_contr.
+ auto_contr.
+ inversion Wf_ε as [ | ? [ ? HX | ] ] ; subst.
  repeat (apply auto_contr_exists ; intro).
  apply auto_contr_conj ; [ apply auto_contr_id | ].
  apply auto_contr_conj ; [ apply auto_contr_id | ].
  apply auto_contr_conj ; [ apply auto_contr_id | ].
  apply auto_contr_conj ; [ | apply auto_contr_id ].
  repeat (apply auto_contr_exists ; intro).
  apply auto_contr_conj ; [ apply auto_contr_id | ].
  repeat (apply auto_contr_exists ; intro).
  isplit ; iintro' H.
  - idestruct H as BindsX H ; isplit.
    * clear - BindsX HX Wf_ΞΞ'.
      iintro_prop ; ielim_prop BindsX.
      apply binds_concat_left ; [ apply BindsX | ].
      clear - Wf_ΞΞ' HX.
      apply wf_XEnv_ok in Wf_ΞΞ'.
      eapply ok_concat_indom_l ; eauto.
    * later_shift.
      ielim_prop BindsX.
      apply wf_XEnv_concat_inv_l in Wf_ΞΞ' as Wf_Ξ.
      specialize (binds_wf Wf_Ξ BindsX) as Wf_T𝓔.
      erewrite <- I_iff_elim_M ; [ apply H | clear H ].
      apply 𝓗_Fun'_nonexpansive ; repeat iintro ; [auto|].
      eapply I_iff_transitive ; [ | apply fold_𝓥𝓤_in_𝓣 ].
      eapply I_iff_transitive ; [ apply I_iff_symmetric ; apply fold_𝓥𝓤_in_𝓣 | ].
      apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro ; crush.
  - idestruct H as BindsX H.
    assert (binds X (x8, x9) Ξ) as BindsX'.
    { clear - BindsX HX Wf_ΞΞ'.
      ielim_prop BindsX.
      eapply binds_concat_left_inv ; [ apply BindsX | ].
      apply wf_XEnv_ok in Wf_ΞΞ'.
      eapply ok_concat_indom_l ; eauto.
    }
    isplit ; [crush|].
    later_shift.
    apply wf_XEnv_concat_inv_l in Wf_ΞΞ' as Wf_Ξ.
    specialize (binds_wf Wf_Ξ BindsX') as Wf_T𝓔.
    erewrite I_iff_elim_M ; [ apply H | clear H ].
    apply 𝓗_Fun'_nonexpansive ; repeat iintro ; [auto|].
    eapply I_iff_transitive ; [ | apply fold_𝓥𝓤_in_𝓣 ].
    eapply I_iff_transitive ; [ apply I_iff_symmetric ; apply fold_𝓥𝓤_in_𝓣 | ].
    apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro ; crush.
}

{
destruct 𝓔 ; simpl ; [auto|].
inversion Wf_𝓔 ; auto_contr ; auto.
}

{
destruct T ; simpl.
+ crush.
+ inversion Wf_T.
  auto_contr.
  - apply X_weaken_𝓥_aux ; auto.
  - apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro ; crush.
+ inversion Wf_T.
  auto_contr.
  apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro ; [|auto].
  rewrite EV_map_XEnv_concat.
  apply X_weaken_𝓥_aux ; [|crush|crush].
  rewrite <- EV_map_XEnv_concat.
  apply EV_map_wf_XEnv ; assumption.
+ inversion Wf_T.
  auto_contr.
  apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro ; [|auto].
  rewrite HV_map_XEnv_concat.
  apply X_weaken_𝓥_aux ; [|crush|crush].
  rewrite <- HV_map_XEnv_concat.
  apply HV_map_wf_XEnv ; assumption.
}

Qed.

End section_X_weaken_aux.

Section section_X_weaken.

Context (n : nat).
Context (EV HV : Set).
Context (Ξ Ξ' : XEnv EV HV).
Context (Wf_ΞΞ' : wf_XEnv (Ξ & Ξ')).
Context (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig).
Context (ρ₁ ρ₂ : HV → hd0) (ρ : HV → IRel 𝓣_Sig).

Hint Resolve lt'_wf.

Lemma X_weaken_𝓥 T (Wf_T : wf_ty Ξ T) ξ₁ ξ₂ v₁ v₂ :
n ⊨ 𝓥⟦ Ξ ⊢ T ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ v₁ v₂ ⇔
    𝓥⟦ (Ξ & Ξ') ⊢ T ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ v₁ v₂.
Proof.
apply X_weaken_𝓥_aux ; auto.
Qed.

Lemma X_weaken_𝓤 𝓔 (Wf_𝓔 : wf_eff Ξ 𝓔) ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂ :
n ⊨ 𝓤⟦ Ξ ⊢ 𝓔 ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂ ⇔
    𝓤⟦ (Ξ & Ξ') ⊢ 𝓔 ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂.
Proof.
apply X_weaken_𝓤_aux ; auto.
Qed.

Hint Resolve X_weaken_𝓥 X_weaken_𝓤.

Lemma X_weaken_𝓣 T (Wf_T : wf_ty Ξ T) 𝓔 (Wf_𝓔 : wf_eff Ξ 𝓔) ξ₁ ξ₂ t₁ t₂ :
n ⊨ 𝓣⟦ Ξ ⊢ T # 𝓔 ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ⇔
    𝓣⟦ (Ξ & Ξ') ⊢ T # 𝓔 ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂.
Proof.
apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro ; auto.
Qed.

End section_X_weaken.


(* -*- mode: coq; coq-prog-args: ("-indices-matter") -*- *)
(* File reduced by coq-bug-finder from original input, then from 11678 lines to 11330 lines, then from 10721 lines to 9544 lines, then from 9549 lines to 794 lines, then from 810 lines to 785 lines, then from 628 lines to 246 lines, then from 220 lines to 89 lines, then from 80 lines to 47 lines *)
(* coqc version trunk (August 2014) compiled on Aug 22 2014 4:17:28 with OCaml 4.01.0
   coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (a67cc6941434124465f20b14a1256f2ede31a60e) *)

Set Implicit Arguments.
Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
Arguments idpath {A a} , [A] a.
Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := match p with idpath => u end.
Local Set Primitive Projections.
Record prod (A B : Type) := pair { fst : A ; snd : B }.
Notation "x * y" := (prod x y) : type_scope.
Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.
Axiom path_prod : forall {A B : Type} (z z' : A * B), (fst z = fst z') -> (snd z = snd z') -> (z = z').
Axiom transport_path_prod : forall A B (P : A * B -> Type) (x y : A * B) (HA : fst x = fst y) (HB : snd x = snd y) Px,
                              transport P (path_prod _ _ HA HB) Px
                              = transport (fun x => P (x, snd y)) HA (transport (fun y => P (fst x, y)) HB Px).
Goal forall (T0 : Type) (snd1 snd0 f : T0) (p : @paths T0 f snd0)
            (f0 : T0) (p1 : @paths T0 f0 snd1) (T1 : Type)
            (fst1 fst0 : T1) (p0 : @paths T1 fst0 fst0) (p2 : @paths T1 fst1 fst1)
            (T : Type) (x2 : T) (T2 : Type) (T3 : forall (_ : T2) (_ : T2), Type)
            (x' : forall (_ : T1) (_ : T), T2) (m : T3 (x' fst1 x2) (x' fst0 x2)),
       @paths (T3 (x' fst1 x2) (x' fst0 x2))
              (@transport (prod T1 T0)
                          (fun x : prod T1 T0 =>
                             T3 (x' fst1 x2) (x' (fst x) x2))
                          (@pair T1 T0 fst0 f) (@pair T1 T0 fst0 snd0)
                          (@path_prod T1 T0 (@pair T1 T0 fst0 f)
                                      (@pair T1 T0 fst0 snd0) p0 p)
                          (@transport (prod T1 T0)
                                      (fun x : prod T1 T0 =>
                                         T3 (x' (fst x) x2) (x' fst0 x2))
                                      (@pair T1 T0 fst1 f0) (@pair T1 T0 fst1 snd1)
                                      (@path_prod T1 T0 (@pair T1 T0 fst1 f0)
                                                  (@pair T1 T0 fst1 snd1) p2 p1) m)) m.
  intros.
  match goal with
    | [ |- context[transport ?P (path_prod ?x ?y ?HA ?HB) ?Px] ]
      => rewrite (transport_path_prod P x y HA HB Px)
  end || fail "bad".
  Undo.
  Set Printing All.
  rewrite transport_path_prod. (* Toplevel input, characters 15-43:
Error:
In environment
T0 : Type
snd1 : T0
snd0 : T0
f : T0
p : @paths T0 f snd0
f0 : T0
p1 : @paths T0 f0 snd1
T1 : Type
fst1 : T1
fst0 : T1
p0 : @paths T1 fst0 fst0
p2 : @paths T1 fst1 fst1
T : Type
x2 : T
T2 : Type
T3 : forall (_ : T2) (_ : T2), Type
x' : forall (_ : T1) (_ : T), T2
m : T3 (x' fst1 x2) (x' fst0 x2)
Unable to unify "?25 (@pair ?23 ?24 (fst ?27) (snd ?27))" with
"?25 ?27".
 *)


Require Import VST.floyd.proofauto.
Require Import hmacdrbg.HMAC_DRBG_algorithms.
Require Import hmacdrbg.HMAC_DRBG_common_lemmas.
Require Import hmacdrbg.spec_hmac_drbg.

Lemma ReseedRes: forall X r v, @return_value_relate_result X r (Vint v) -> Int.eq v (Int.repr (-20864)) = false.
Proof. intros.
  unfold return_value_relate_result in H.
  destruct r. inversion H; reflexivity.
  destruct e; inversion H; try reflexivity.
  apply Int.eq_false. eapply ENT_GenErrAx.
Qed.

Lemma hmac_interp_empty d r: hmac_interp d r |-- md_empty r.
Proof.
destruct d; simpl. auto.
eapply derives_trans. apply md_relate_full. apply md_full_empty.
apply md_full_empty.
Qed.

Lemma instantiate256_reseed d s pr_flag rc ri (ZLc'256F : (Zlength d >? 256) = false):
      instantiate_function_256 s pr_flag  d =
      mbedtls_HMAC256_DRBG_reseed_function s (HMAC256DRBGabs initial_key initial_value rc 48 pr_flag ri) d.
Proof. intros.
  unfold instantiate_function_256; simpl.
  rewrite ZLc'256F, andb_negb_r.
  assert (MaxString': Zlength d >? max_personalization_string_length = false).
  { apply Zgt_is_gt_bool_f. apply Zgt_is_gt_bool_f in ZLc'256F.
    unfold max_personalization_string_length. lia. }
  rewrite MaxString' in *; trivial.
Qed.


From iris.base_logic.lib Require Export fancy_updates.
From iris.program_logic Require Export language.
From iris.bi Require Export weakestpre.
From iris.proofmode Require Import base tactics classes.
Set Default Proof Using "Type".
Import uPred.

Class irisG (Λ : language) (Σ : gFunctors) := IrisG {
  iris_invG :> invG Σ;

  (** The state interpretation is an invariant that should hold in between each
  step of reduction. Here [Λstate] is the global state, [list Λobservation] are
  the remaining observations, and [nat] is the number of forked-off threads
  (not the total number of threads, which is one higher because there is always
  a main thread). *)
  state_interp : state Λ → list (observation Λ) → nat → iProp Σ;

  (** A fixed postcondition for any forked-off thread. For most languages, e.g.
  heap_lang, this will simply be [True]. However, it is useful if one wants to
  keep track of resources precisely, as in e.g. Iron. *)
  fork_post : val Λ → iProp Σ;
}.
Global Opaque iris_invG.

Definition wp_pre `{irisG Λ Σ} (s : stuckness)
    (wp : coPset -c> expr Λ -c> (val Λ -c> iProp Σ) -c> iProp Σ) :
    coPset -c> expr Λ -c> (val Λ -c> iProp Σ) -c> iProp Σ := λ E e1 Φ,
  match to_val e1 with
  | Some v => |={E}=> Φ v
  | None => ∀ σ1 κ κs n,
     state_interp σ1 (κ ++ κs) n ={E,∅}=∗
       ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
       ∀ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ ={∅,∅,E}▷=∗
         state_interp σ2 κs (length efs + n) ∗
         wp E e2 Φ ∗
         [∗ list] i ↦ ef ∈ efs, wp ⊤ ef fork_post
  end%I.

Local Instance wp_pre_contractive `{irisG Λ Σ} s : Contractive (wp_pre s).
Proof.
  rewrite /wp_pre=> n wp wp' Hwp E e1 Φ.
  repeat (f_contractive || f_equiv); apply Hwp.
Qed.

Definition wp_def `{irisG Λ Σ} (s : stuckness) :
  coPset → expr Λ → (val Λ → iProp Σ) → iProp Σ := fixpoint (wp_pre s).
Definition wp_aux `{irisG Λ Σ} : seal (@wp_def Λ Σ _). by eexists. Qed.
Instance wp' `{irisG Λ Σ} : Wp Λ (iProp Σ) stuckness := wp_aux.(unseal).
Definition wp_eq `{irisG Λ Σ} : wp = @wp_def Λ Σ _ := wp_aux.(seal_eq).

Section wp.
Context `{irisG Λ Σ}.
Implicit Types s : stuckness.
Implicit Types P : iProp Σ.
Implicit Types Φ : val Λ → iProp Σ.
Implicit Types v : val Λ.
Implicit Types e : expr Λ.

(* Weakest pre *)
Lemma wp_unfold s E e Φ :
  WP e @ s; E {{ Φ }} ⊣⊢ wp_pre s (wp (PROP:=iProp Σ)  s) E e Φ.
Proof. rewrite wp_eq. apply (fixpoint_unfold (wp_pre s)). Qed.

Global Instance wp_ne s E e n :
  Proper (pointwise_relation _ (dist n) ==> dist n) (wp (PROP:=iProp Σ) s E e).
Proof.
  revert e. induction (lt_wf n) as [n _ IH]=> e Φ Ψ HΦ.
  rewrite !wp_unfold /wp_pre.
  (* FIXME: figure out a way to properly automate this proof *)
  (* FIXME: reflexivity, as being called many times by f_equiv and f_contractive
  is very slow here *)
  do 24 (f_contractive || f_equiv). apply IH; first lia.
  intros v. eapply dist_le; eauto with lia.
Qed.
Global Instance wp_proper s E e :
  Proper (pointwise_relation _ (≡) ==> (≡)) (wp (PROP:=iProp Σ) s E e).
Proof.
  by intros Φ Φ' ?; apply equiv_dist=>n; apply wp_ne=>v; apply equiv_dist.
Qed.

Lemma wp_value' s E Φ v : Φ v ⊢ WP of_val v @ s; E {{ Φ }}.
Proof. iIntros "HΦ". rewrite wp_unfold /wp_pre to_of_val. auto. Qed.
Lemma wp_value_inv' s E Φ v : WP of_val v @ s; E {{ Φ }} ={E}=∗ Φ v.
Proof. by rewrite wp_unfold /wp_pre to_of_val. Qed.

Lemma wp_strong_mono s1 s2 E1 E2 e Φ Ψ :
  s1 ⊑ s2 → E1 ⊆ E2 →
  WP e @ s1; E1 {{ Φ }} -∗ (∀ v, Φ v ={E2}=∗ Ψ v) -∗ WP e @ s2; E2 {{ Ψ }}.
Proof.
  iIntros (? HE) "H HΦ". iLöb as "IH" forall (e E1 E2 HE Φ Ψ).
  rewrite !wp_unfold /wp_pre.
  destruct (to_val e) as [v|] eqn:?.
  { iApply ("HΦ" with "[> -]"). by iApply (fupd_mask_mono E1 _). }
  iIntros (σ1 κ κs n) "Hσ". iMod (fupd_intro_mask' E2 E1) as "Hclose"; first done.
  iMod ("H" with "[$]") as "[% H]".
  iModIntro. iSplit; [by destruct s1, s2|]. iIntros (e2 σ2 efs Hstep).
  iMod ("H" with "[//]") as "H". iIntros "!> !>".
  iMod "H" as "(Hσ & H & Hefs)".
  iMod "Hclose" as "_". iModIntro. iFrame "Hσ". iSplitR "Hefs".
  - iApply ("IH" with "[//] H HΦ").
  - iApply (big_sepL_impl with "Hefs"); iIntros "!#" (k ef _).
    iIntros "H". iApply ("IH" with "[] H"); auto.
Qed.

Lemma fupd_wp s E e Φ : (|={E}=> WP e @ s; E {{ Φ }}) ⊢ WP e @ s; E {{ Φ }}.
Proof.
  rewrite wp_unfold /wp_pre. iIntros "H". destruct (to_val e) as [v|] eqn:?.
  { by iMod "H". }
  iIntros (σ1 κ κs n) "Hσ1". iMod "H". by iApply "H".
Qed.
Lemma wp_fupd s E e Φ : WP e @ s; E {{ v, |={E}=> Φ v }} ⊢ WP e @ s; E {{ Φ }}.
Proof. iIntros "H". iApply (wp_strong_mono s s E with "H"); auto. Qed.

Lemma wp_atomic s E1 E2 e Φ `{!Atomic (stuckness_to_atomicity s) e} :
  (|={E1,E2}=> WP e @ s; E2 {{ v, |={E2,E1}=> Φ v }}) ⊢ WP e @ s; E1 {{ Φ }}.
Proof.
  iIntros "H". rewrite !wp_unfold /wp_pre.
  destruct (to_val e) as [v|] eqn:He.
  { by iDestruct "H" as ">>> $". }
  iIntros (σ1 κ κs n) "Hσ". iMod "H". iMod ("H" $! σ1 with "Hσ") as "[$ H]".
  iModIntro. iIntros (e2 σ2 efs Hstep).
  iMod ("H" with "[//]") as "H". iIntros "!>!>".
  iMod "H" as "(Hσ & H & Hefs)". destruct s.
  - rewrite !wp_unfold /wp_pre. destruct (to_val e2) as [v2|] eqn:He2.
    + iDestruct "H" as ">> $". by iFrame.
    + iMod ("H" $! _ [] with "[$]") as "[H _]". iDestruct "H" as %(? & ? & ? & ? & ?).
      by edestruct (atomic _ _ _ _ _ Hstep).
  - destruct (atomic _ _ _ _ _ Hstep) as [v <-%of_to_val].
    iMod (wp_value_inv' with "H") as ">H".
    iModIntro. iFrame "Hσ Hefs". by iApply wp_value'.
Qed.

Lemma wp_step_fupd s E1 E2 e P Φ :
  to_val e = None → E2 ⊆ E1 →
  (|={E1,E2}▷=> P) -∗ WP e @ s; E2 {{ v, P ={E1}=∗ Φ v }} -∗ WP e @ s; E1 {{ Φ }}.
Proof.
  rewrite !wp_unfold /wp_pre. iIntros (-> ?) "HR H".
  iIntros (σ1 κ κs n) "Hσ". iMod "HR". iMod ("H" with "[$]") as "[$ H]".
  iIntros "!>" (e2 σ2 efs Hstep). iMod ("H" $! e2 σ2 efs with "[% //]") as "H".
  iIntros "!>!>". iMod "H" as "(Hσ & H & Hefs)".
  iMod "HR". iModIntro. iFrame "Hσ Hefs".
  iApply (wp_strong_mono s s E2 with "H"); [done..|].
  iIntros (v) "H". by iApply "H".
Qed.

Lemma wp_bind K `{!LanguageCtx K} s E e Φ :
  WP e @ s; E {{ v, WP K (of_val v) @ s; E {{ Φ }} }} ⊢ WP K e @ s; E {{ Φ }}.
Proof.
  iIntros "H". iLöb as "IH" forall (E e Φ). rewrite wp_unfold /wp_pre.
  destruct (to_val e) as [v|] eqn:He.
  { apply of_to_val in He as <-. by iApply fupd_wp. }
  rewrite wp_unfold /wp_pre fill_not_val //.
  iIntros (σ1 κ κs n) "Hσ". iMod ("H" with "[$]") as "[% H]". iModIntro; iSplit.
  { iPureIntro. destruct s; last done.
    unfold reducible in *. naive_solver eauto using fill_step. }
  iIntros (e2 σ2 efs Hstep).
  destruct (fill_step_inv e σ1 κ e2 σ2 efs) as (e2'&->&?); auto.
  iMod ("H" $! e2' σ2 efs with "[//]") as "H". iIntros "!>!>".
  iMod "H" as "(Hσ & H & Hefs)".
  iModIntro. iFrame "Hσ Hefs". by iApply "IH".
Qed.

Lemma wp_bind_inv K `{!LanguageCtx K} s E e Φ :
  WP K e @ s; E {{ Φ }} ⊢ WP e @ s; E {{ v, WP K (of_val v) @ s; E {{ Φ }} }}.
Proof.
  iIntros "H". iLöb as "IH" forall (E e Φ). rewrite !wp_unfold /wp_pre.
  destruct (to_val e) as [v|] eqn:He.
  { apply of_to_val in He as <-. by rewrite !wp_unfold /wp_pre. }
  rewrite fill_not_val //.
  iIntros (σ1 κ κs n) "Hσ". iMod ("H" with "[$]") as "[% H]". iModIntro; iSplit.
  { destruct s; eauto using reducible_fill. }
  iIntros (e2 σ2 efs Hstep).
  iMod ("H" $! (K e2) σ2 efs with "[]") as "H"; [by eauto using fill_step|].
  iIntros "!>!>". iMod "H" as "(Hσ & H & Hefs)".
  iModIntro. iFrame "Hσ Hefs". by iApply "IH".
Qed.

(** * Derived rules *)
Lemma wp_mono s E e Φ Ψ : (∀ v, Φ v ⊢ Ψ v) → WP e @ s; E {{ Φ }} ⊢ WP e @ s; E {{ Ψ }}.
Proof.
  iIntros (HΦ) "H"; iApply (wp_strong_mono with "H"); auto.
  iIntros (v) "?". by iApply HΦ.
Qed.
Lemma wp_stuck_mono s1 s2 E e Φ :
  s1 ⊑ s2 → WP e @ s1; E {{ Φ }} ⊢ WP e @ s2; E {{ Φ }}.
Proof. iIntros (?) "H". iApply (wp_strong_mono with "H"); auto. Qed.
Lemma wp_stuck_weaken s E e Φ :
  WP e @ s; E {{ Φ }} ⊢ WP e @ E ?{{ Φ }}.
Proof. apply wp_stuck_mono. by destruct s. Qed.
Lemma wp_mask_mono s E1 E2 e Φ : E1 ⊆ E2 → WP e @ s; E1 {{ Φ }} ⊢ WP e @ s; E2 {{ Φ }}.
Proof. iIntros (?) "H"; iApply (wp_strong_mono with "H"); auto. Qed.
Global Instance wp_mono' s E e :
  Proper (pointwise_relation _ (⊢) ==> (⊢)) (wp (PROP:=iProp Σ) s E e).
Proof. by intros Φ Φ' ?; apply wp_mono. Qed.

Lemma wp_value s E Φ e v : IntoVal e v → Φ v ⊢ WP e @ s; E {{ Φ }}.
Proof. intros <-. by apply wp_value'. Qed.
Lemma wp_value_fupd' s E Φ v : (|={E}=> Φ v) ⊢ WP of_val v @ s; E {{ Φ }}.
Proof. intros. by rewrite -wp_fupd -wp_value'. Qed.
Lemma wp_value_fupd s E Φ e v `{!IntoVal e v} :
  (|={E}=> Φ v) ⊢ WP e @ s; E {{ Φ }}.
Proof. intros. rewrite -wp_fupd -wp_value //. Qed.
Lemma wp_value_inv s E Φ e v : IntoVal e v → WP e @ s; E {{ Φ }} ={E}=∗ Φ v.
Proof. intros <-. by apply wp_value_inv'. Qed.

Lemma wp_frame_l s E e Φ R : R ∗ WP e @ s; E {{ Φ }} ⊢ WP e @ s; E {{ v, R ∗ Φ v }}.
Proof. iIntros "[? H]". iApply (wp_strong_mono with "H"); auto with iFrame. Qed.
Lemma wp_frame_r s E e Φ R : WP e @ s; E {{ Φ }} ∗ R ⊢ WP e @ s; E {{ v, Φ v ∗ R }}.
Proof. iIntros "[H ?]". iApply (wp_strong_mono with "H"); auto with iFrame. Qed.

Lemma wp_frame_step_l s E1 E2 e Φ R :
  to_val e = None → E2 ⊆ E1 →
  (|={E1,E2}▷=> R) ∗ WP e @ s; E2 {{ Φ }} ⊢ WP e @ s; E1 {{ v, R ∗ Φ v }}.
Proof.
  iIntros (??) "[Hu Hwp]". iApply (wp_step_fupd with "Hu"); try done.
  iApply (wp_mono with "Hwp"). by iIntros (?) "$$".
Qed.
Lemma wp_frame_step_r s E1 E2 e Φ R :
  to_val e = None → E2 ⊆ E1 →
  WP e @ s; E2 {{ Φ }} ∗ (|={E1,E2}▷=> R) ⊢ WP e @ s; E1 {{ v, Φ v ∗ R }}.
Proof.
  rewrite [(WP _ @ _; _ {{ _ }} ∗ _)%I]comm; setoid_rewrite (comm _ _ R).
  apply wp_frame_step_l.
Qed.
Lemma wp_frame_step_l' s E e Φ R :
  to_val e = None → ▷ R ∗ WP e @ s; E {{ Φ }} ⊢ WP e @ s; E {{ v, R ∗ Φ v }}.
Proof. iIntros (?) "[??]". iApply (wp_frame_step_l s E E); try iFrame; eauto. Qed.
Lemma wp_frame_step_r' s E e Φ R :
  to_val e = None → WP e @ s; E {{ Φ }} ∗ ▷ R ⊢ WP e @ s; E {{ v, Φ v ∗ R }}.
Proof. iIntros (?) "[??]". iApply (wp_frame_step_r s E E); try iFrame; eauto. Qed.

Lemma wp_wand s E e Φ Ψ :
  WP e @ s; E {{ Φ }} -∗ (∀ v, Φ v -∗ Ψ v) -∗ WP e @ s; E {{ Ψ }}.
Proof.
  iIntros "Hwp H". iApply (wp_strong_mono with "Hwp"); auto.
  iIntros (?) "?". by iApply "H".
Qed.
Lemma wp_wand_l s E e Φ Ψ :
  (∀ v, Φ v -∗ Ψ v) ∗ WP e @ s; E {{ Φ }} ⊢ WP e @ s; E {{ Ψ }}.
Proof. iIntros "[H Hwp]". iApply (wp_wand with "Hwp H"). Qed.
Lemma wp_wand_r s E e Φ Ψ :
  WP e @ s; E {{ Φ }} ∗ (∀ v, Φ v -∗ Ψ v) ⊢ WP e @ s; E {{ Ψ }}.
Proof. iIntros "[Hwp H]". iApply (wp_wand with "Hwp H"). Qed.
End wp.

(** Proofmode class instances *)
Section proofmode_classes.
  Context `{irisG Λ Σ}.
  Implicit Types P Q : iProp Σ.
  Implicit Types Φ : val Λ → iProp Σ.

  Global Instance frame_wp p s E e R Φ Ψ :
    (∀ v, Frame p R (Φ v) (Ψ v)) →
    Frame p R (WP e @ s; E {{ Φ }}) (WP e @ s; E {{ Ψ }}).
  Proof. rewrite /Frame=> HR. rewrite wp_frame_l. apply wp_mono, HR. Qed.

  Global Instance is_except_0_wp s E e Φ : IsExcept0 (WP e @ s; E {{ Φ }}).
  Proof. by rewrite /IsExcept0 -{2}fupd_wp -except_0_fupd -fupd_intro. Qed.

  Global Instance elim_modal_bupd_wp p s E e P Φ :
    ElimModal True p false (|==> P) P (WP e @ s; E {{ Φ }}) (WP e @ s; E {{ Φ }}).
  Proof.
    by rewrite /ElimModal intuitionistically_if_elim
      (bupd_fupd E) fupd_frame_r wand_elim_r fupd_wp.
  Qed.

  Global Instance elim_modal_fupd_wp p s E e P Φ :
    ElimModal True p false (|={E}=> P) P (WP e @ s; E {{ Φ }}) (WP e @ s; E {{ Φ }}).
  Proof.
    by rewrite /ElimModal intuitionistically_if_elim
      fupd_frame_r wand_elim_r fupd_wp.
  Qed.

  Global Instance elim_modal_fupd_wp_atomic p s E1 E2 e P Φ :
    Atomic (stuckness_to_atomicity s) e →
    ElimModal True p false (|={E1,E2}=> P) P
            (WP e @ s; E1 {{ Φ }}) (WP e @ s; E2 {{ v, |={E2,E1}=> Φ v }})%I.
  Proof.
    intros. by rewrite /ElimModal intuitionistically_if_elim
      fupd_frame_r wand_elim_r wp_atomic.
  Qed.

  Global Instance add_modal_fupd_wp s E e P Φ :
    AddModal (|={E}=> P) P (WP e @ s; E {{ Φ }}).
  Proof. by rewrite /AddModal fupd_frame_r wand_elim_r fupd_wp. Qed.

  Global Instance elim_acc_wp {X} E1 E2 α β γ e s Φ :
    Atomic (stuckness_to_atomicity s) e →
    ElimAcc (X:=X) (fupd E1 E2) (fupd E2 E1)
            α β γ (WP e @ s; E1 {{ Φ }})
            (λ x, WP e @ s; E2 {{ v, |={E2}=> β x ∗ (γ x -∗? Φ v) }})%I.
  Proof.
    intros ?. rewrite /ElimAcc.
    iIntros "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]".
    iApply (wp_wand with "[Hinner Hα]"); first by iApply "Hinner".
    iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose".
  Qed.

  Global Instance elim_acc_wp_nonatomic {X} E α β γ e s Φ :
    ElimAcc (X:=X) (fupd E E) (fupd E E)
            α β γ (WP e @ s; E {{ Φ }})
            (λ x, WP e @ s; E {{ v, |={E}=> β x ∗ (γ x -∗? Φ v) }})%I.
  Proof.
    rewrite /ElimAcc.
    iIntros "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]".
    iApply wp_fupd.
    iApply (wp_wand with "[Hinner Hα]"); first by iApply "Hinner".
    iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose".
  Qed.
End proofmode_classes.


Require Import Coq.Bool.Sumbool.
Require Import Coq.Logic.Eqdep_dec.
Require Import Crypto.Reflection.SmartMap.
Require Import Crypto.Reflection.Relations.
Require Import Crypto.Reflection.Syntax.
Require Import Crypto.Reflection.Named.Syntax.
Require Import Crypto.Reflection.Named.ContextDefinitions.
Require Import Crypto.Reflection.Named.ContextProperties.
Require Import Crypto.Reflection.Named.ContextProperties.SmartMap.
Require Import Crypto.Reflection.Named.Wf.
Require Import Crypto.Reflection.Named.MapCast.
Require Import Crypto.Util.PointedProp.
Require Import Crypto.Util.ZUtil.
Require Import Crypto.Util.Bool.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.Prod.
Require Import Crypto.Util.Sigma.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.Tactics.DestructHead.

Local Open Scope nexpr_scope.
Section language.
  Context {base_type_code : Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}
          {Name : Type}
          {interp_base_type_bounds : base_type_code -> Type}
          (interp_op_bounds : forall src dst, op src dst -> interp_flat_type interp_base_type_bounds src -> interp_flat_type interp_base_type_bounds dst)
          (pick_typeb : forall t, interp_base_type_bounds t -> base_type_code).
  Local Notation pick_type t v := (SmartFlatTypeMap pick_typeb (t:=t) v).
  Context (cast_op : forall t tR (opc : op t tR) args_bs,
              op (pick_type _ args_bs) (pick_type _ (interp_op_bounds t tR opc args_bs)))
          {BoundsContext : Context Name interp_base_type_bounds}
          (BoundsContextOk : ContextOk BoundsContext)
          {interp_base_type : base_type_code -> Type}
          (interp_op : forall src dst,
              op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst)
          {FullContext : Context Name (fun t => { b : interp_base_type_bounds t & interp_base_type (pick_typeb t b) }%type)}
          (FullContextOk : ContextOk FullContext)
          {Context : Context Name interp_base_type}
          (ContextOk : ContextOk Context)
          (base_type_dec : DecidableRel (@eq base_type_code))
          (Name_dec : DecidableRel (@eq Name)).

  Local Notation mapf_cast := (@mapf_cast _ op Name _ interp_op_bounds pick_typeb cast_op BoundsContext).
  Local Notation map_cast := (@map_cast _ op Name _ interp_op_bounds pick_typeb cast_op BoundsContext).

  Local Ltac handle_options_step :=
    match goal with
    | _ => progress inversion_option
    | [ H : ?x = Some _ |- context[?x] ] => rewrite H
    | [ H : ?x = None |- context[?x] ] => rewrite H
    | [ H : ?x = Some _, H' : context[?x] |- _ ] => rewrite H in H'
    | [ H : ?x = None, H' : context[?x] |- _ ] => rewrite H in H'
    | [ H : Some _ <> None \/ _ |- _ ] => clear H
    | [ H : Some ?x <> Some ?y |- _ ] => assert (x <> y) by congruence; clear H
    | [ H : None <> Some _ |- _ ] => clear H
    | [ H : Some _ <> None |- _ ] => clear H
    | [ H : ?x <> ?x \/ _ |- _ ] => destruct H; [ exfalso; apply H; reflexivity | ]
    | [ H : _ \/ None = Some _ |- _ ] => destruct H; [ | exfalso; clear -H; congruence ]
    | [ H : _ \/ Some _ = None |- _ ] => destruct H; [ | exfalso; clear -H; congruence ]
    | [ H : ?x = Some ?y, H' : ?x = Some ?y' |- _ ]
      => assert (y = y') by congruence; (subst y' || subst y)
    | _ => progress simpl @option_map
    | _ => progress unfold option_map in *
    end.

  Local Ltac handle_lookupb_step_extra := fail.
  Local Ltac handle_lookupb_step :=
    let do_eq_dec dec t t' :=
        first [ constr_eq t t'; fail 1
              | lazymatch goal with
                | [ H : t = t' |- _ ] => fail 1
                | [ H : t <> t' |- _ ] => fail 1
                | [ H : t = t' -> False |- _ ] => fail 1
                | _ => destruct (dec t t')
                end ] in
    let do_type_dec := do_eq_dec base_type_dec in
    match goal with
    | _ => progress unfold dec in *
    | _ => handle_options_step
    (* preprocess *)
    | [ H : context[lookupb (extend _ _ _) _] |- _ ]
      => first [ rewrite (fun C => lookupb_extend C base_type_dec Name_dec) in H by assumption
               | setoid_rewrite (fun C => lookupb_extend C base_type_dec Name_dec) in H; [ | assumption.. ] ]
    | [ |- context[lookupb (extend _ _ _) _] ]
      => first [ rewrite (fun C => lookupb_extend C base_type_dec Name_dec) by assumption
               | setoid_rewrite (fun C => lookupb_extend C base_type_dec Name_dec); [ | assumption.. ] ]
    | _ => progress subst
    (* handle multiple hypotheses *)
    | [ H : find_Name _ ?n ?N = Some ?t', H'' : context[find_Name_and_val _ _ ?t ?n ?N ?x ?default] |- _ ]
      => do_type_dec t t'
    (* clear the default value *)
    | [ H : context[find_Name_and_val ?tdec ?ndec ?t ?n (T:=?T) ?N ?V ?default] |- _ ]
      => lazymatch default with None => fail | _ => idtac end;
         rewrite find_Name_and_val_split in H
    (* generic handlers *)
    | [ H : find_Name _ ?n ?N = Some ?t', H' : ?t <> ?t', H'' : context[find_Name_and_val _ _ ?t ?n ?N ?x ?default] |- _ ]
      => erewrite find_Name_and_val_wrong_type in H'' by eassumption
    | [ H : context[find_Name _ _ (SmartFlatTypeMapInterp2 _ _ _)] |- _ ]
      => rewrite find_Name_SmartFlatTypeMapInterp2 with (base_type_code_dec:=base_type_dec) in H
    | [ H : find_Name_and_val _ _ _ _ _ _ _ = None |- _ ]
      => apply find_Name_and_val_None_iff in H
    | _ => progress handle_lookupb_step_extra
    (* destructers *)
    | [ |- context[find_Name_and_val ?tdec ?ndec ?t ?n ?N ?V ?default] ]
      => destruct (find_Name_and_val tdec ndec t n N V default) eqn:?
    | [ H : context[match find_Name_and_val ?tdec ?ndec ?t ?n ?N ?V ?default with _ => _ end] |- _ ]
      => destruct (find_Name_and_val tdec ndec t n N V default) eqn:?
    | [ H : context[match find_Name ?ndec ?n ?N with _ => _ end] |- _ ]
      => destruct (find_Name ndec n N) eqn:?
    | [ H : context[match base_type_dec ?x ?y with _ => _ end] |- _ ]
      => destruct (base_type_dec x y)
    | [ H : context[match Name_dec ?x ?y with _ => _ end] |- _ ]
      => destruct (Name_dec x y)
    end.

  Local Ltac handle_exists_in_goal :=
    lazymatch goal with
    | [ |- exists v, Some ?k = Some v /\ @?B v ]
      => exists k; split; [ reflexivity | ]
    | [ |- exists v, Some ?k = Some v ]
      => exists k; reflexivity
    | [ |- (exists v, None = Some v /\ @?B v) ]
      => exfalso
    | [ |- ?A /\ (exists v, Some ?k = Some v /\ @?B v) ]
      => cut (A /\ B k); [ clear; solve [ intuition eauto ] | cbv beta ]
    | [ |- ?A /\ (exists v, None = Some v /\ @?B v) ]
      => exfalso
    end.
  Local Ltac specializer_t_step :=
    match goal with
    | [ H : ?T, H' : ?T |- _ ] => clear H
    | [ H : forall x, Some _ = Some x -> _ |- _ ] => specialize (H _ eq_refl)
    | [ H : ?x = Some _, IH : forall a b c, ?x = Some _ -> _ |- _ ]
      => specialize (IH _ _ _ H)
    | [ H : ?x = Some _, IH : forall a b, ?x = Some _ -> _ |- _ ]
      => specialize (IH _ _ H)
    | [ H : ?x = Some _, IH : forall a, ?x = Some _ -> _ |- _ ]
      => specialize (IH _ H)
    | [ H : forall t n x y z, lookupb ?ctx n = _ -> _, H' : lookupb ?ctx ?n' = _ |- _ ]
      => specialize (H _ _ _ _ _ H')
    | [ H : forall t n x y, lookupb ?ctx n = _ -> _, H' : lookupb ?ctx ?n' = _ |- _ ]
      => specialize (H _ _ _ _ H')
    | [ H : forall t n v, lookupb ?ctx n = _ -> _, H' : lookupb ?ctx ?n' = _ |- _ ]
      => specialize (H _ _ _ H')
    | _ => progress specialize_by auto
    end.

  Local Ltac break_t_step :=
    first [ progress subst
          | progress destruct_head'_ex
          | progress destruct_head'_and
          | progress inversion_option
          | progress inversion_prod
          | progress inversion_sigma
          | progress autorewrite with push_prop_of_option in *
          | progress break_match_hyps ].

  Local Ltac do_specialize_IHe_step :=
    match goal with
    | [ IH : context[mapf_cast _ ?e], H' : mapf_cast ?ctx ?e = _ |- _ ]
      => let check_tac _ := (rewrite H' in IH) in
         first [ specialize (IH ctx); check_tac ()
               | specialize (fun a => IH a ctx); check_tac ()
               | specialize (fun a b => IH a b ctx); check_tac () ]
    | [ H : forall x y z w, Some _ = Some _ -> _ |- _ ]
      => first [ specialize (H _ _ _ _ eq_refl)
               | specialize (fun x y => H x y _ _ eq_refl) ]
    | [ H : forall x y z, Some _ = Some _ -> _ |- _ ]
      => first [ specialize (H _ _ _ eq_refl)
               | specialize (fun x => H x _ _ eq_refl) ]
    | [ H : forall x y, Some _ = Some _ -> _ |- _ ]
      => first [ specialize (H _ _ eq_refl)
               | specialize (fun x => H x _ eq_refl) ]
    | _ => progress specialize_by_assumption
    | [ H : forall a b, prop_of_option (Named.wff a ?e) -> _, H' : prop_of_option (Named.wff _ ?e) |- _ ]
      => specialize (fun b => H _ b H')
    | [ H : forall b v, _ -> prop_of_option (Named.wff b ?e) |- prop_of_option (Named.wff ?ctx ?e) ]
      => specialize (H ctx)
    | [ H : forall b v, _ -> _ -> prop_of_option (Named.wff b ?e) |- prop_of_option (Named.wff ?ctx ?e) ]
      => specialize (H ctx)
    | [ H : forall a b, _ -> _ -> _ -> prop_of_option (Named.wff b ?e) |- prop_of_option (Named.wff ?ctx ?e) ]
      => specialize (fun a => H a ctx)
    | [ H : forall a b, prop_of_option (Named.wff a ?e) -> _, H' : forall v, prop_of_option (Named.wff _ ?e) |- _ ]
      => specialize (fun b v => H _ b (H' v))
    end.
  Ltac do_specialize_IHe := repeat do_specialize_IHe_step.

  Definition make_fContext_value {t} {b : interp_flat_type interp_base_type_bounds t}
             (v : interp_flat_type interp_base_type (pick_type t b))
    : interp_flat_type
        (fun t => { b : interp_base_type_bounds t & interp_base_type (pick_typeb t b)})
        t
    := SmartFlatTypeMapUnInterp2
         (fun t b (v : interp_flat_type _ (Tbase _))
          => existT (fun b => interp_base_type (pick_typeb t b)) b v)
         v.

  Local Ltac t_step :=
    first [ progress intros
          | progress simpl in *
          | break_t_step
          | handle_lookupb_step
          | handle_exists_in_goal
          | apply conj
          | solve [ auto | exfalso; auto ]
          | specializer_t_step
          | progress do_specialize_IHe
          | match goal with
            | [ IH : forall v, _ -> ?T, v' : interp_flat_type _ _ |- ?T ]
              => apply (IH (make_fContext_value v')); clear IH
            end ].
  Local Ltac t := repeat t_step.

  Lemma find_Name_and_val_make_fContext_value_Some {T}
        {N : interp_flat_type (fun _ : base_type_code => Name) T}
        {B : interp_flat_type interp_base_type_bounds T}
        {V : interp_flat_type interp_base_type (pick_type T B)}
        {n : Name}
        {t : base_type_code}
        {v : { b : interp_base_type_bounds t & interp_base_type (pick_typeb t b)}}
        {b}
        (Hn : find_Name Name_dec n N = Some t)
        (Hf : find_Name_and_val base_type_dec Name_dec t n N (make_fContext_value V) None = Some v)
        (Hb : find_Name_and_val base_type_dec Name_dec t n N B None = Some b)
        (N' := SmartFlatTypeMapInterp2 (var'':=fun _ => Name) (f:=pick_typeb) (fun _ _ n => n) _ N)
    : b = projT1 v /\ find_Name_and_val base_type_dec Name_dec (pick_typeb t (projT1 v)) n N' V None = Some (projT2 v).
  Proof.
    eapply (find_Name_and_val_SmartFlatTypeMapUnInterp2_Some_Some base_type_dec Name_dec (h:=@projT1 _ _) (i:=@projT2 _ _) (f:=pick_typeb) (g:=fun _ => existT _));
      auto.
  Qed.

  Local Ltac handle_lookupb_step_extra ::=
        lazymatch goal with
        | [ H : find_Name _ ?n ?N = Some ?t,
                H' : find_Name_and_val _ _ ?t ?n ?N (@make_fContext_value ?T ?B ?v) None = Some ?v',
                     H'' : find_Name_and_val _ _ ?t ?n ?N ?B None = Some _
            |- _ ]
          => pose proof (find_Name_and_val_make_fContext_value_Some H H' H''); clear H'
        end.

  Lemma wff_mapf_cast
        {t} (e:exprf base_type_code op Name t)
    : forall
        (fValues:FullContext)
        (newValues:Context)
        (varBounds:BoundsContext)
        {b} e' (He':mapf_cast varBounds e = Some (existT _ b e'))
        (Hwf : prop_of_option (Named.wff fValues e))
        (Hctx:forall {t} n v,
            lookupb (t:=t) fValues n = Some v
            -> lookupb (t:=t) varBounds n = Some (projT1 v)
               /\ lookupb (t:=pick_typeb t (projT1 v)) newValues n = Some (projT2 v)),
      prop_of_option (Named.wff newValues e').
  Proof. induction e; t. Qed.

  Lemma wf_map_cast
        {t} (e:expr base_type_code op Name t)
        (input_bounds : interp_flat_type interp_base_type_bounds (domain t))
    : forall
        (fValues:FullContext)
        (newValues:Context)
        (varBounds:BoundsContext)
        {b} e' (He':map_cast varBounds e input_bounds = Some (existT _ b e'))
        (Hwf : Named.wf fValues e)
        (Hctx:forall {t} n v,
            lookupb (t:=t) fValues n = Some v
            -> lookupb (t:=t) varBounds n = Some (projT1 v)
               /\ lookupb (t:=pick_typeb t (projT1 v)) newValues n = Some (projT2 v)),
      Named.wf newValues e'.
  Proof.
    unfold Named.wf, map_cast, option_map, interp; simpl; intros.
    repeat first [ progress subst
                 | progress inversion_option
                 | progress inversion_sigma
                 | progress break_match_hyps
                 | progress destruct_head' sigT
                 | progress simpl in * ].
    match goal with v : _ |- _ => specialize (Hwf (make_fContext_value v)) end.
    eapply wff_mapf_cast; eauto; [].
    t.
  Qed.
End language.


Require Import Lia.
Require Import RelationClasses.

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

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

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

Require Import PromiseConsistent.

Require Import SimCommon.

Set Implicit Arguments.

Module PromotionProgress.
  Import SimCommon.

  Lemma progress_read_aux
        l view released b ts
        (RELEASED: View.le released view):
    sim_view l view (View.join (View.join view (View.singleton_ur_if b l ts)) released).
  Proof.
    destruct b; ss.
    - unfold View.singleton_ur, TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find.
      econs; ss; ii.
      + unfold TimeMap.join. condtac; ss.
        apply TimeFacts.antisym.
        * etrans; eauto using Time.join_l.
        * inv RELEASED.
          repeat eapply Time.join_spec; eauto using Time.bot_spec; try refl.
      + unfold TimeMap.join. condtac; ss.
        apply TimeFacts.antisym.
        * etrans; eauto using Time.join_l.
        * inv RELEASED.
          repeat eapply Time.join_spec; eauto using Time.bot_spec; try refl.
    - unfold View.singleton_rw, TimeMap.bot, TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find.
      econs; ss; ii.
      + unfold TimeMap.join.
        apply TimeFacts.antisym.
        * etrans; eauto using Time.join_l.
        * inv RELEASED.
          repeat eapply Time.join_spec; eauto using Time.bot_spec; try refl.
      + unfold TimeMap.join. condtac; ss.
        apply TimeFacts.antisym.
        * etrans; eauto using Time.join_l.
        * inv RELEASED.
          repeat eapply Time.join_spec; eauto using Time.bot_spec; try refl.
  Qed.

  Lemma progress_read
        l lc1 mem1 from val released ord
        (WF1: Local.wf lc1 mem1)
        (MEM1: Memory.closed mem1)
        (LATEST: Memory.get l (Memory.max_ts l mem1) mem1 = Some (from, Message.concrete val released))
        (SAFE: View.le (View.unwrap released) (TView.cur (Local.tview lc1))):
    exists lc2,
      <<STEP: Local.read_step lc1 mem1 l (Memory.max_ts l mem1) val released ord lc2>> /\
      <<LC: sim_local l lc1 lc2>>.
  Proof.
    esplits.
    - econs; eauto; try refl.
      econs; i; eapply Memory.max_ts_spec2; apply WF1.
    - econs; try refl. econs; ss.
      + eapply progress_read_aux.
        condtac; ss. apply View.bot_spec.
      + eapply progress_read_aux.
        condtac; ss; eauto using View.bot_spec.
        etrans; eauto. apply WF1.
  Qed.

  Lemma progress_write_aux l view ts:
    sim_view l view (View.join view (View.singleton_ur l ts)).
  Proof.
    unfold View.singleton_ur, TimeMap.singleton, LocFun.init,
    LocFun.add, LocFun.find, View.join, TimeMap.join.
    econs; ss; ii.
    - condtac; ss.
      apply TimeFacts.antisym; try apply Time.join_l.
      apply Time.join_spec; try refl.
      apply Time.bot_spec.
    - condtac; ss.
      apply TimeFacts.antisym; try apply Time.join_l.
      apply Time.join_spec; try refl.
      apply Time.bot_spec.
  Qed.

  Lemma progress_write
        l lc1 sc1 mem1 val releasedm ord
        (WF1: Local.wf lc1 mem1)
        (SC1: Memory.closed_timemap sc1 mem1)
        (MEM1: Memory.closed mem1)
        (WF_REL: View.opt_wf releasedm)
        (CLOSED_REL: Memory.closed_opt_view releasedm mem1)
        (PROMISES1: forall to, Memory.get l to (Local.promises lc1) = None)
        (SAFE1: View.le (View.unwrap releasedm) (TView.cur (Local.tview lc1))):
    exists released lc2 sc2 mem2,
      <<STEP: Local.write_step lc1 sc1 mem1 l (Memory.max_ts l mem1) (Time.incr (Memory.max_ts l mem1))
                               val releasedm released ord lc2 sc2 mem2 Memory.op_kind_add>> /\
      <<LC: sim_local l lc1 lc2>> /\
      <<SC: sc1 = sc2>> /\
      <<MEM: sim_memory l mem1 mem2>> /\
      <<PROMISES2: forall to, Memory.get l to (Local.promises lc2) = None>> /\
      <<SAFE2: View.le (View.unwrap released) (TView.cur (Local.tview lc2))>>.
  Proof.
    exploit (@progress_write_step lc1 sc1 mem1 l (Time.incr (Memory.max_ts l mem1)) val releasedm ord); eauto.
    { apply Time.incr_spec. }
    { ii. rewrite PROMISES1 in GET. ss. }
    i. des.
    destruct lc1, lc2. ss.
    replace promises0 with promises in *; cycle 1.
    { apply Memory.ext. i.
      inv x0. inv WRITE. inv PROMISE. ss. inv LC2.
      erewrite (@Memory.remove_o promises2); eauto. condtac; ss.
      - des. subst.
        exploit Memory.add_get0; try exact PROMISES. i. des. ss.
      - erewrite (@Memory.add_o promises1); eauto. condtac; ss.
    }
    esplits; eauto.
    - econs; try refl. ss.
      inv x0. inv LC2. ss.
      econs; ss; eauto using progress_write_aux; i.
      unfold LocFun.add. condtac; ss.
    - inv x0. ss.
    - inv x0. inv WRITE. inv PROMISE. ss.
      econs; i.
      + erewrite Memory.add_o; eauto. condtac; ss.
        * des. ss.
        * esplits; eauto. refl.
      + revert GET_TGT. erewrite Memory.add_o; eauto. condtac; ss; i.
        * des. ss.
        * esplits; eauto. refl.
    - inv x0. inv LC2. ss.
      unfold TView.write_released. condtac; ss; try apply View.bot_spec.
      apply View.join_spec.
      + etrans; eauto. apply View.join_l.
      + unfold LocFun.add. condtac; ss.
        condtac; ss; try refl.
        apply View.join_spec; try apply View.join_r.
        etrans; try eapply WF1. apply View.join_l.
  Qed.
End PromotionProgress.


Require Import Coqlib.
Require Import AST.
Require Import Globalenvs.
Require Import Events.
Require Import Smallstep.
Require Import Asm.
Require Import Integers.
Require Import Maps.
Require Import Errors.
Require Import Machregs.

Require Import ProofIrrelevance.

Require Import PeekLiveness.
Require Import SplitLib.
Require Import FindInstrLib.
Require Import StepLib.
Require Import SameBlockLib.
Require Import PeekTactics.
Require Import PregTactics.
Require Import AsmCallingConv.
Require Import Union.
Require Import StepIn.
Require Import PeekLivenessProof.
Require Import Use.
Require Import PeekLib.
Require Import StepEquiv. (* Where rewrite is defined *)
Require Import ProgPropDec.
Require Import ForwardJumps.
Require Import Zlen.

Require Import AsmBits.
Require Import MemoryAxioms.

Require Import Peephole.
Require Import PeepholeLib.
Require Import PeepholeDec.

Require Import ValEq.
Require Import MemEq.

Section PRESERVATION.

Variable rwr: rewrite.

Variable prog: program.
Variable tprog: program.
Hypothesis TRANSF: transf_program rwr prog = OK tprog.
Hypothesis CALLING_CONV : calling_conv_correct_bits prog.
Let ge := Genv.globalenv prog.
Let tge := Genv.globalenv tprog.

Definition outside_range := PeepholeDec.outside_range rwr prog.
Definition in_transf := PeepholeDec.in_transf rwr prog.
Definition at_entry := PeepholeDec.at_entry rwr prog.
Definition match_states := PeepholeDec.match_states rwr prog.
Definition transf_index := PeepholeLib.transf_index rwr prog.
Definition transf_idx_end := PeepholeLib.transf_idx_end rwr prog.

Lemma match_states_match_live :
  forall s1 s2,
    match_states s1 s2 ->
    outside_range s1 ->
    match_live liveness_fun_f prog s1 s2.
Proof.
  intros.
  inv H.
  * simpl. intros. split; auto.
    break_and; auto.
    split; break_and; auto.
    split; auto.
    split; auto.
    intros. apply H5. unfold ge in *.
    unify_PC. unify_psur. assumption.
  * assert (at_entry (State_bits rs m md)).
      econstructor; eauto.
      apply at_entry_not_out in H.
      apply H in H0. inv_false.
  * assert (in_transf (State_bits rsl' m' md')).
    econstructor. Focus 3. apply H4.
    Focus 3. apply H5. eauto. eauto.
    eauto. eauto.
    app outside_not_in H0.
    apply H0 in H. inv_false.
  * simpl. intros. split; auto.
    break_and; eauto.
    split; break_and; auto.
    split; auto.
    split; auto.
    intros.
    apply H4. unfold ge in *. unify_PC. unify_psur.
    replace (Int.intval) with (Int.unsigned) in * by auto.
    rewrite Int.unsigned_zero in *. unfold ge in *.
    assumption.
Qed.

Lemma function_blocks_same :
  forall b,
    Genv.find_funct_ptr (Genv.globalenv prog) b = None ->
    Genv.find_funct_ptr (Genv.globalenv tprog) b = None.
Proof.
  intros.
  unfold transf_program in *.
  repeat break_match_hyp; try congruence.
  inversion TRANSF.
  destruct (Genv.find_funct_ptr
              (Genv.globalenv (transform_program (transf_fundef rwr) prog)) b) eqn:?; try reflexivity.

  app Genv.find_funct_ptr_rev_transf Heqo0.
  break_and. congruence.
Qed.

Lemma is_global_translated :
  forall b ofs,
    is_global (Genv.globalenv prog) b ofs <->
    is_global (Genv.globalenv tprog) b ofs.
Proof.
  intros. split; intros.
  - unfold is_global in *.
    break_or.
    * left. unfold in_code_range in *.
      break_match_hyp; try inv_false.
      app functions_translated Heqo.
      collapse_match.
      break_match_hyp. simpl.
      destruct f0. simpl.
      unfold Zlen.zlen. rewrite length_pres.
      unfold Zlen.zlen in *.
      simpl in *. omega.
      simpl. omega.
    * right.
      unfold in_var_range in *.
      break_match_hyp; try inv_false.
      erewrite varinfo_preserved; eauto.
      collapse_match. omega.
  - unfold is_global in *.
    break_or.
    * left.
      unfold in_code_range in *.
      break_match. app functions_translated Heqo.
      rewrite Heqo in H0.

      unfold transf_fundef in *.
      destruct f; simpl in *.
      destruct f; simpl in *.
      unfold zlen in *.
      rewrite length_pres in H0.
      assumption.
      assumption.

      app function_blocks_same Heqo.
      rewrite Heqo in *. inv_false.
    * right.
      unfold in_var_range in *.
      erewrite <- varinfo_preserved; eauto.
Qed.

Lemma global_perms_translated :
  forall m,
    global_perms (Genv.globalenv prog) m ->
    global_perms (Genv.globalenv tprog) m.
Proof.
  intros. unfold global_perms in *.
  intros. eapply H.
  rewrite is_global_translated. eauto.
Qed.

(* MOVE THESE TO MEMORY AXIOMS *)
Axiom md_ec'_ge :
  forall md ge1 ge2 ef vargs m t vl m',
    external_call' ef ge1 vargs m t vl m' ->
    external_call' ef ge2 vargs m t vl m' ->
    md_ec' md ef ge1 vargs m t vl m' = md_ec' md ef ge2 vargs m t vl m'.

Axiom md_ec_ge :
  forall md ge1 ge2 ef vargs m t vl m',
    external_call ef ge1 vargs m t vl m' ->
    external_call ef ge2 vargs m t vl m' ->
    md_ec md ef ge1 vargs m t vl m' = md_ec md ef ge2 vargs m t vl m'.

Lemma step_outside :
  forall st t st',
    step_bits (Genv.globalenv prog) st t st' ->
    outside_range st ->
    step_bits (Genv.globalenv tprog) st t st'.
Proof.
  intros. inv_step H.
  * subst st. subst st'.
    app functions_translated H5.
    destruct f. simpl in *.
    app instrs_translated H6.
    econstructor; eauto.
    destruct i; simpl in H7; simpl;
    try assumption;
    repeat break_match_hyp;
    try (erewrite symbol_address_pres; eauto);
    simpl; eauto;
    try find_rewrite; simpl; eauto;
    try eapply exec_load_bits_pres; eauto;
    try eapply exec_store_bits_pres; eauto;
    try eapply exec_big_load_bits_pres; eauto;
    try eapply exec_big_store_bits_pres; eauto;
    try erewrite eval_addrmode_no_ptr_pres; eauto;
    try eapply goto_label_pres; eauto;
    try find_rewrite; eauto; unfold is_label_instr in *; eauto.
    erewrite <- eval_addrmode_bits_pres in Heqo; eauto.
    rewrite Heqo. eauto.
    erewrite <- eval_addrmode_bits_pres in Heqo; eauto.
    rewrite Heqo. eauto.

    app list_nth_z_in Heqo.
    find_rewrite. eauto.

    eapply global_perms_translated; eauto.

  * subst st. subst st'.
    app functions_translated H3.
    destruct f; simpl in *.
    app instrs_translated H4.

    erewrite md_ec'_ge.
    eapply exec_step_builtin_bits; eauto.
    inv H5.
    eapply external_call_symbols_preserved_gen in H14.
    econstructor; eauto.
    intros. unfold Senv.find_symbol.
    simpl. eapply symbols_preserved; eauto.
    intros. unfold Senv.public_symbol. simpl.
    eapply public_symbols_preserved; eauto.
    intros. unfold Senv.block_is_volatile. simpl.
    unfold Genv.block_is_volatile.
    erewrite varinfo_preserved. unfold ge.
    reflexivity. eauto.
    eapply global_perms_translated; eauto.
    assumption.
    eapply external_call_symbols_preserved'; eauto.
    intros. erewrite symbols_preserved; eauto.
    intros. erewrite public_symbols_preserved; eauto.
    intros. erewrite varinfo_preserved; eauto.

  * subst st. subst st'.
    app functions_translated H5.
    destruct f; simpl in *.
    app instrs_translated H6.
    app eval_annot_args_bits_pres H7.
    name H8 Horig_call.
    eapply external_call_symbols_preserved_gen in H8; try (intros; apply symbols_preserved).
    instantiate (1 := (Genv.globalenv tprog)) in H8.
    erewrite md_ec_ge; try instantiate (1 := (Genv.globalenv tprog)); eauto.
    eapply exec_step_annot_bits; eauto.
    eapply global_perms_translated; eauto.
    intros. unfold Senv.public_symbol. simpl.
    intros. eapply symbols_preserved; eauto.
    eapply public_symbols_preserved; eauto.
    intros. unfold Senv.block_is_volatile. simpl.
    unfold Genv.block_is_volatile.
    erewrite varinfo_preserved.
    reflexivity.
    exact TRANSF.

  * subst st. subst st'.
    app functions_translated H3.
    unfold transf_fundef in H3.
    name H5 Horig_call.

    eapply external_call_symbols_preserved' in H5; try (intros; apply symbols_preserved).
    erewrite md_ec'_ge;
      try instantiate (1 := Genv.globalenv tprog);
      try instantiate (1 := Genv.globalenv tprog) in H5;
      eauto.

    eapply exec_step_external_bits; eauto.
    eapply global_perms_translated; eauto.
    intros. unfold Senv.public_symbol. simpl.
    intros. eapply symbols_preserved; eauto.
    eapply public_symbols_preserved; eauto.
    intros. erewrite varinfo_preserved.
    reflexivity. exact TRANSF.
Qed.

Lemma measure_decr_entry_in :
  forall s s' t,
    at_entry s ->
    in_transf s' ->
    step_bits (Genv.globalenv prog) s t s' ->
    (measure rwr (transf_idx_end s') s' < measure rwr (transf_idx_end s) s)%nat.
Proof.
  name (measure_decr rwr) mdr.

  intros.
  app transf_step_same_block H1.
  destruct s. destruct s'.
  inv H. inv H0. inv H1.
  inv H. inv H0.
  repeat unify_PC.
  repeat unify_psur.
  assert (at_entry (State_bits rsl m1 md)).
  econstructor; eauto.
  app transf_step_same_block H11.
  inv H11.
  inv H1. inv H6.

  NP _app star_step_in_same_block star. subst b1.

  repeat unify_PC. repeat unify_psur.
  eapply transf_range_unique in H10; try eapply H8; eauto.
  break_and. subst j.
  assert (in_transf (State_bits rs' m' md')).
  econstructor; eauto.
  rewrite H5. eauto.

  name (conj H1 H12) Hstin.
  rewrite <- st_in_eq in Hstin.
  app star_step_in_in' Hstin.

  unfold transf_idx_end. unfold PeepholeLib.transf_idx_end.
  repeat collapse_match.
  inv Hstin. inv H13.
  repeat unify_PC. repeat unify_psur.
  unfold fundef in *.
  inv H8. repeat break_and.
  unfold fundef in *.
  repeat collapse_match.

  unfold transf_code in H15.
  rewrite H8 in H15.
  app split_pat_spec H8.
  break_match_hyp.
  eapply mdr; eauto.
  split. eapply has_no_PC_overflow; eauto.
  unfold transf_program in *.
  repeat break_match_hyp; inversion TRANSF; eauto.
  app is_proper_check_sound Heqb0.
  break_and.
  unfold is_proper_rewrite_location in *.
  repeat break_and.
  unfold not_after_label. intros.
  econstructor; eauto;
  inv H46;
  inv H41;
  repeat unify_PC;
  repeat unify_psur;
  repeat unify_find_funct_ptr;
  simpl in H30;
  eapply list_eq_middle_therefore_eq in H13; eauto;
  eapply list_eq_middle_therefore_eq in H30; eauto;
  repeat break_and;
  subst;
  eauto;
  eapply list_eq_middle_therefore_eq in H30; congruence.

  exists 0.
  econstructor; eauto.
  omega.

  name (find_nonempty rwr) fn.
  destruct (find rwr); try congruence.
  rewrite zlen_cons. name (zlen_nonneg _ c4) zlnc. omega.

  exists ofs.
  econstructor; eauto.
  omega.

  rewrite H8 in H15.
  eapply list_neq in H15. inv_false.
  apply (not_same rwr).

Qed.

Lemma in_transf_in_code :
  forall st i j,
    in_transf st ->
    transf_index st i j ->
    in_code i (find rwr) ge st.
Proof.
  intros. inv H.
  unfold transf_index in H0.
  unfold PeepholeLib.transf_index in *.
  specialize (H0 _ _ _ eq_refl).
  name (conj H6 H5) Hstin.
  rewrite <- st_in_eq in Hstin.
  app star_step_in_in' Hstin.
  inv Hstin. inv H8.
  assert (at_entry (State_bits rsl m md)) by (econstructor; eauto).
  app transf_step_same_block H4.
  inv H4.
  inv H11. inv H12.
  repeat unify_PC.
  repeat unify_psur.
  app star_step_in_same_block H6.
  subst.

  specialize (H0 _ _ _ H13 H14).
  eapply transf_range_unique in H0; try apply H3.
  break_and. subst.
  rewrite <- H9.
  econstructor.
  Focus 2.
  econstructor; eauto.
  omega.
Qed.

Lemma measure_decr_rewr :
  forall s1 s1' t i,
    in_transf s1' ->
    transf_index s1' i (i + zlen (find rwr)) ->
    in_transf s1 ->
    transf_index s1 i (i + zlen (find rwr)) ->
    step_bits (Genv.globalenv prog) s1 t s1' ->
    ((measure rwr (i + zlen (find rwr))) s1' < (measure rwr (i + zlen (find rwr))) s1)%nat.
Proof.
  intros.
  eapply (measure_decr rwr); eauto.
  Focus 2. app in_transf_in_code H1.
  inv H1. eauto.
  Focus 2. app in_transf_in_code H.
  inv H. eauto.

  split.
  unfold transf_program in TRANSF.
  repeat break_match_hyp; inversion TRANSF.
  auto.

  unfold not_after_label.
  intros. subst.

  unfold transf_index in H2.
  unfold PeepholeLib.transf_index in H2.

  specialize (H2 _ _ _ eq_refl _ _ _ H5 H6).
  inv H2.
  unify_find_funct_ptr.
  break_and.
  unfold transf_code in H4.
  rewrite H2 in H4.
  app split_pat_spec H2.
  eapply list_eq_middle_therefore_eq in H2; try omega.
  break_and. subst.

  break_match_hyp.
  Focus 2. eapply list_neq in H4. inv_false.
  apply (not_same rwr).

  app is_proper_check_sound Heqb0.
  break_and.

  unfold is_proper_rewrite_location in H12.
  repeat break_and; eauto.
Qed.

Lemma in_transf_step_match :
  forall sl sl' sr,
    match_states sl sr ->
    in_transf sl ->
    in_transf sl' ->
    step_bits (Genv.globalenv prog) sl E0 sl' ->
    match_states sl' sr.
Proof.

  intros.
  name H Hmatch.
  inv H.
  * app outside_not_in H6.
    app H6 H0. inv_false.
  * assert (at_entry (State_bits rs m md)).
      econstructor; eauto.
    app at_entry_not_in H.
    app H H0. inv_false.
  * destruct sl'.

    assert (step_in (Int.unsigned i) (find rwr) (Genv.globalenv prog) (State_bits rsl' m' md') E0 (State_bits r m a)).
    {
      econstructor; eauto.
      name (conj H9 H8) Hstin.
      rewrite <- st_in_eq in Hstin.
      app star_step_in_in' Hstin.

      app transf_step_same_block H2.
      assert (Hentry : at_entry (State_bits rsl ml md)) by (econstructor; eauto).
      app transf_step_same_block H7.

      inv H8. inv H2.
      repeat match goal with
               | [ H : State_bits _ _ _ = State_bits _ _ _ |- _ ] => inv H
             end;
        repeat unify_PC;
        repeat unify_psur.
      inv H1.
      assert (Hentry2 : at_entry (State_bits rsl m md)) by (econstructor; eauto).
      name (conj H26 H25) Hstin.
      rewrite <- st_in_eq in Hstin.
      app star_step_in_in' Hstin.
      app transf_step_same_block H24.
      inv H18.
      inv H24. inv H8. inv H18.
      inv H15.
      repeat match goal with
               | [ H : State _ _ = State _ _ |- _ ] => inv H
             end;
        repeat unify_PC;
        repeat unify_psur.

      app star_step_in_same_block H26.
      subst b0.

      app star_step_in_same_block H9. subst b2.

      inv H7. inv H9. inv H21.
        repeat unify_PC;
        repeat unify_psur.

        eapply transf_range_unique in H23; try apply H6.
        break_and. congruence.

        right. econstructor; eauto.

    }

    eapply inside; try eapply star_right;
    try apply H9; try apply H2; try apply H7; eauto.

  * inv H0.
    app transf_step_same_block H14.
    inv H14.
    find_inversion. find_inversion.
    repeat unify_PC. repeat unify_psur.
    app star_step_in_same_block H16.
    subst b1. inv H13.

    unify_find_funct_ptr.

    right. econstructor; eauto.
Qed.

Lemma zlen_same :
  zlen (find rwr) = zlen (repl rwr).
Proof.
  unfold zlen. rewrite (len_same rwr).
  reflexivity.
Qed.

Lemma at_entry_match :
  forall rs m md rs' m' md',
    at_entry (State_bits rs m md) ->
    match_states (State_bits rs m md) (State_bits rs' m' md') ->
    (forall reg, In reg (live_in rwr) ->
                 val_eq (rs reg) (rs' reg)) /\ mem_eq md m m'.
Proof.
  intros.
  inv H0.
  * app at_entry_not_out H.
    app H H10. inv_false.
  * split; eauto.
    intros.
    apply H11.
    inv H10. break_and.
    unfold transf_code in H4.
    assert (c1 ++ find rwr ++ c2 <> c1 ++ repl rwr ++ c2).
    apply list_neq. apply (not_same rwr).
    repeat break_match_hyp; try congruence.
    inv H2.
    unfold is_proper_location_check in Heqb0.
    repeat break_match_hyp; try congruence.
    Focus 2.
    inv H2. app split_pat_spec Heqo.
    congruence.
    repeat break_and.
    unfold liveness_check_correct in l0.
    repeat break_and.
    app i2 H0.
    unfold liveness_fun_f.
    repeat unify_find_funct_ptr.
    rewrite p1.
    app split_pat_spec Heqo.
    rewrite Heqo. rewrite Heqo0.
    rewrite H3. eauto.
  * assert (in_transf (State_bits rs m md)).
    econstructor; try apply H11; eauto.
    app at_entry_not_in H.
    app H H0. inv_false.
  * inv H. unify_PC.
    unify_psur.
    inv H5. unify_find_funct_ptr.
Qed.

Lemma transf_did_happen :
  forall b f x y,
    Genv.find_funct_ptr ge b = Some (Internal f) ->
    transf_range rwr prog b x y ->
    transf_code rwr (fn_code f) <> fn_code f.
Proof.
  intros. inv H0.
  unfold ge in *. unfold fundef in *.
  unify_find_funct_ptr.
  simpl. break_and.
  rewrite H1.
  app split_pat_spec H0.
  rewrite H0.
  apply list_neq.
  name (not_same rwr) ns. congruence.
Qed.

Lemma entry_or_in_range :
  forall rs m md bits b i x y,
    (at_entry (State_bits rs m md) \/ in_transf (State_bits rs m md)) ->
    rs PC = Values.Vint bits ->
    psur md bits = Some (b,i) ->
    transf_range rwr prog b x y ->
    x <= Int.unsigned i < y.
Proof.
  intros. break_or.
  inv H3.
  unify_PC. unify_psur.
  eapply transf_range_unique in H2; try eapply H8.
  break_and. subst.
  inv H8. rewrite H2.
  rewrite zlen_app.
  name (zlen_find rwr) zlnf. omega.
  inv H3.
  assert (at_entry (State_bits rsl m0 md0)) by (econstructor; eauto).
  app transf_step_same_block H9.
  inv H9. inv H4. inv H5.
  repeat unify_PC.
  repeat unify_psur.
  app star_step_in_same_block H11. subst b1.
  name (conj H4 H10) Hstin.
  rewrite <- st_in_eq in Hstin.
  app star_step_in_in' Hstin.
  inv Hstin. inv H9.
  repeat unify_PC.
  repeat unify_psur.
  eapply transf_range_unique in H8; try eapply H2.
  break_and. subst.
  inv H2. repeat unify_PC. repeat unify_psur.
  unfold ge in *.
  repeat unify_find_funct_ptr.
  rewrite zlen_app. name (zlen_find rwr) zlnf.

  omega.
Qed.

(* TODO: Move somewhere higher up *)
Lemma at_code_in_range :
  forall z c ofs prog rs m md bits b i,
    no_PC_overflow_prog prog ->
    at_code z c ofs (Genv.globalenv prog) (State_bits rs m md) ->
    rs PC = Values.Vint bits ->
    psur md bits = Some (b,i) ->
    in_code_range (Genv.globalenv prog) b i.
Proof.
  intros. inv H0. unfold in_code_range.
  unfold fundef in *.
  unify_PC. unify_psur.
  collapse_match.
  find_rewrite.
  repeat rewrite zlen_app.
  name (zlen_nonneg _ c) zlnc.
  name (zlen_nonneg _ c1) zlnc1.
  name (zlen_nonneg _ c2) zlnc2.

  unfold no_PC_overflow_prog in H.
  assert (code_of_prog (fn_code fd) prog0).
  unfold code_of_prog. NP _app Genv.find_funct_ptr_inversion Genv.find_funct_ptr.
  destruct fd. eauto.
  NP1 _app H code_of_prog.
  unfold no_PC_overflow in *.

  assert (zlen c1 + ofs >= 0 /\ zlen c1 + ofs < zlen (fn_code fd)). {
    split; try omega. rewrite H15. repeat rewrite zlen_app. omega. }
                                                                    app in_range_find_instr H3.

  app H0 H3; omega.
Qed.

Lemma straightlineish_single_exit :
  forall rs m md rs' m' md' instr,
    step_t (instr :: nil) ge (State_bits rs m md) E0 (State_bits rs' m' md') ->
    forall z ofs,
      at_code z (find rwr) ofs ge (State_bits rs m md) ->
      rs' PC = (nextinstr rs) PC ->
      (in_transf (State_bits rs m md) \/ at_entry (State_bits rs m md)) ->
      outside_range (State_bits rs' m' md') ->
      forall bits b i,
        rs PC = Values.Vint bits ->
        psur md bits = Some (b,i) ->
        transf_range rwr prog b z (z + zlen (find rwr)) ->
        exists bits' i',
          rs' PC = Values.Vint bits' /\
          psur md' bits' = Some (b,i') /\
          Int.unsigned i' = z + zlen (find rwr).
Proof.
  intros.
  assert (z <= Int.unsigned i < z + zlen (find rwr)).
  {
    eapply entry_or_in_range; eauto. break_or; eauto.
  }
  preg_simpl_hyp H1. rewrite H4 in H1.
  simpl in H1.

  NP _app step_t_md_extends step_t.
  NP _app step_t_md step_t; try congruence.
  NP _app step_t_gp step_t; try congruence.
  repeat break_and.
  app psur_add_one H5.

  eexists; eexists; split; eauto; split; eauto.

  name H6 Htransf_range. inv H6.
  assert (Hrange : Int.unsigned i >= 0 /\ Int.unsigned i < zlen (c1 ++ find rwr ++ c2)).
  repeat rewrite zlen_app. name (zlen_find rwr) zlnf.
  name (zlen_nonneg _ c2) zlnc. name (zlen_nonneg _ c1) zlnc1. omega.
  rewrite in_range_find_instr in Hrange.
  break_exists.
  unfold Int.add.
  rewrite Int.unsigned_one.

  erewrite unsigned_repr_PC; eauto.
  Focus 2. unfold transf_program in *. repeat break_match_hyp; inversion TRANSF; eauto.
  Focus 2. left. replace (Int.unsigned i + 1 - 1) with (Int.unsigned i) by omega.
  simpl. repeat break_and.
  NP _app split_pat_spec split_pat. subst c. eauto.

  inv H3.
  break_exists. break_and.
  repeat unify_PC.
  repeat unify_psur.
  simpl in *. unfold ge in *. unfold fundef in *.
  repeat unify_find_funct_ptr.
  destruct H17.
  Focus 2. app transf_did_happen Htransf_range.
  simpl in Htransf_range. congruence.

  repeat break_exists.
  break_and.
  eapply transf_range_unique in H15; try eapply Htransf_range.
  break_and. subst.

  unfold Int.add in H17. rewrite Int.unsigned_one in H17.
  erewrite unsigned_repr_PC in H17; eauto.

  omega.

  eapply has_no_PC_overflow; eauto.

  left. replace (Int.unsigned i + 1 - 1) with (Int.unsigned i) by omega.
  simpl. break_and.
  NP _app split_pat_spec split_pat. subst c. eauto.

  eapply at_code_in_range; eauto.
  eapply has_no_PC_overflow; eauto.
  app step_t_to_at_code_0 H10.
  inv H10.
  repeat unify_PC. repeat unify_psur.
  eapply in_range_PC; eauto.
  eapply has_no_PC_overflow; eauto.
  rewrite H21. rewrite H28.
  rewrite find_instr_append_head by omega.
  simpl. reflexivity.
Qed.

Lemma jump_to_label_contra :
  forall rs m rs' m' instr md md',
    step_t (instr :: nil) ge (State_bits rs m md) E0 (State_bits rs' m' md') ->
    forall z ofs bits b i fd,
      at_code z (find rwr) ofs ge (State_bits rs m md) ->
      rs PC = Values.Vint bits ->
      psur md bits = Some (b,i) ->
      transf_range rwr prog b z (z + zlen (find rwr)) ->
      Genv.find_funct_ptr ge b = Some (Internal fd) ->
      (exists jmp l, goto_label_bits md fd l b rs m = Nxt rs' m' md' /\
      find_instr (Int.unsigned i) (fn_code fd) = Some jmp /\
      is_label_instr jmp l) ->
      (in_transf (State_bits rs m md) \/ at_entry (State_bits rs m md)) ->
      outside_range (State_bits rs' m' md') ->
      False.
Proof.
  intros.
  repeat break_exists.
  repeat break_and.
  unfold goto_label_bits in *.
  repeat break_match_hyp; try state_inv.

  assert (HnoPC : no_PC_overflow_prog prog) by (
  eapply has_no_PC_overflow; eauto).

  assert (psur md' i0 = Some (b,Int.repr z0)). {
  NP _app step_t_md step_t; try congruence.
  NP _app step_t_gp step_t; try congruence.
  repeat break_and.
  erewrite weak_valid_pointer_sur; eauto.
  split; eauto.
  NP1 _app global_perms_valid_globals global_perms.
  unfold valid_globals in *.
  eapply Memory.Mem.weak_valid_pointer_spec. right.
  NP _app label_pos_find_instr label_pos.
  erewrite unsigned_repr_PC; eauto.
  erewrite <- (unsigned_repr_PC _ _ (z0-1)); eauto.
  eapply H11.
  NP _app label_pos_find_instr label_pos.
  unfold is_global. left.
  unfold in_code_range. collapse_match.
  apex in_range_find_instr Heqo.
  erewrite unsigned_repr_PC; eauto.
  omega.
  }

  assert (z <= Int.unsigned i < z + zlen (find rwr)).
  {
    inv H1.
    eapply entry_or_in_range; eauto; break_or; eauto.
  }

  name H3 Htransf.
  inv H3. repeat break_and.
  name H13 Htc.
  unfold transf_code in H13.
  rewrite H12 in H13. break_match_hyp.
  Focus 2. app transf_did_happen Htransf. simpl in Htransf. congruence.
  app is_proper_check_sound Heqb0.
  repeat break_and. unfold is_proper_rewrite_location in *.
  repeat break_and.
  unfold ge in *. unfold fundef in *.
  repeat unify_find_funct_ptr.
  simpl in *.
  app split_pat_spec H12. subst c.

  assert (z0 < zlen c1 \/ z0 >= zlen (c1 ++ find rwr)).
  {
    inv H7. preg_simpl_hyp H30. inv H30.
    break_exists. break_and.
    inv H1.
    repeat unify_PC. repeat unify_psur.
    unfold ge in *. unfold fundef in *.
    repeat unify_find_funct_ptr.

    destruct H12. Focus 2. app transf_did_happen Htransf.
    simpl in Htransf. congruence.
    repeat break_exists.
    repeat break_and.
    eapply transf_range_unique in H1; try apply Htransf.
    break_and. subst.
    assert (Int.unsigned (Int.repr z0) = z0).
    erewrite unsigned_repr_PC; eauto.
    unfold transf_program in TRANSF.
    repeat break_match_hyp; inversion TRANSF; eauto.
    app label_pos_find_instr Heqo.
    rewrite H1 in *. omega.
  }
  destruct H12.
  eapply no_labels_jump_out_contra_c1; eauto; try omega.
  eapply no_labels_jump_out_contra_c2; eauto; try omega.

Qed.

Lemma straightline_step_t_nextinstr :
  forall i ge rs m md t rs' m' md',
    straightline i ->
    step_t (i :: nil) ge (State_bits rs m md) t (State_bits rs' m' md') ->
    rs' PC = nextinstr rs PC.
Proof.
  intros.
  copy H0. inv H1.
  inv H10. inv H4.
  app straightline_step_t H0.
  break_instr_exec i;
    preg_simpl;
    try reflexivity;
    try inv_false;
    repeat break_match;
    preg_simpl;
    try congruence.
  simpl in Heqo.
  inv Heqo.
Qed.

Lemma single_exit :
  forall rs m rs' m' bits b i x y md md',
    (in_transf (State_bits rs m md) \/ at_entry (State_bits rs m md)) ->
    outside_range (State_bits rs' m' md') ->
    step_bits (Genv.globalenv prog) (State_bits rs m md) E0 (State_bits rs' m' md') ->
    rs PC = Values.Vint bits ->
    psur md bits = Some (b,i) ->
    transf_range rwr prog b x y ->
    exists bits' i',
      rs' PC = Values.Vint bits' /\
      psur md' bits' = Some (b,i') /\
      Int.unsigned i' = y.
Proof.
  intros.
  assert (exists ofs, at_code x (find rwr) ofs ge (State_bits rs m md)).
  {
    break_or. eapply in_transf_in_code in H5.
    Focus 2. unfold transf_index. unfold PeepholeLib.transf_index.
    intros. inv H.
    repeat unify_PC. repeat unify_psur. apply H4.
    inv H5. eexists; apply H6.
    inv H5. repeat unify_PC.
    repeat unify_psur.
    eapply transf_range_unique in H4; try eapply H10.
    break_and. subst.
    inv H10. exists 0.
    rewrite H4. econstructor; eauto. omega.
    name (zlen_find rwr) zln. omega.
    simpl. break_and. app split_pat_spec H3.
  }

  assert (y = x + zlen (find rwr)).
  {
    inv H4.
    rewrite zlen_app.
    reflexivity.
  }
  subst y.
  break_exists.
  app step_at_step_t H5.
  break_and.
  rewrite find_instr_in in H7.
  break_exists.
  name (instr_class x1) ic.
  name (forward_find rwr) ff.
  unfold only_forward_jumps in ff.
  repeat break_and.
  unfold no_calls in *.
  unfold no_trace_code in *.
  destruct ic;
    try destruct H11;
    try destruct H11;
    app H9 H7;
    try app H8 H;
    try app H8 H12;
    try congruence;
    try solve [app no_trace_trace H7; try inv_false].

  NP _app straightlineish_single_exit outside_range; eauto.
  inv H4.
  NP _app straightline_step_t step_t.
  NP _app straightline_step_t_nextinstr step_t.

  name H6 Hat. inv H6.
  app step_t_labeled_jump H5.
  break_or.

  app jump_to_label_contra H14. inv_false.
  repeat unify_PC. repeat unify_psur. apply H4.

  app straightlineish_single_exit H6; inv H14.
  reflexivity.
  repeat unify_PC.
  eauto.
Qed.

Lemma star_step_md_extends :
  forall ge s1 s2 t,
    star step_bits ge s1 t s2 ->
    forall rs m md rs' m' md',
    s1 = State_bits rs m md ->
    s2 = State_bits rs' m' md' ->
    md_extends md md'.
Proof.
  induction 1; intros.
  subst. inv H0. econstructor; eauto.
  subst. destruct s2.
  app md_extends_step H.
  eapply ex_trans; eauto.
Qed.

Lemma step_through_transf_same_block :
  forall rs m bits b i x y rs' m' b' i' bits' md md',
    at_entry (State_bits rs m md) ->
    rs PC = Values.Vint bits ->
    psur md bits = Some (b,i) ->
    transf_range rwr prog b x y ->
    step_through x (find rwr) ge (State_bits rs m md) E0 (State_bits rs' m' md') ->
    rs' PC = Values.Vint bits' ->
    psur md' bits' = Some (b',i') ->
    b = b'.
Proof.
  intros.
  inv H3.
  app transf_step_same_block H7. inv H7.
  repeat match goal with
           | [ H : State_bits _ _ _ = State_bits _ _ _ |- _ ] => inv H
         end.
  repeat unify_PC. repeat unify_psur.
  reflexivity.
  assert (t1 = E0).
  {
    destruct t1; simpl in H6. reflexivity.
    inv H6.
  }
  subst t1. simpl in H6.
  assert (t2 = E0).
  {
    destruct t2; simpl in H6. reflexivity.
    inv H6.
  }
  subst t2. simpl in H6.
  assert (t3 = E0).
  {
    destruct t3; simpl in H6. reflexivity.
    inv H6.
  }
  subst t3.
  destruct (stB). destruct stC.
  name H2 Htransf. inv H2.
  inv H7. break_and.
  repeat unify_PC. repeat unify_psur. simpl.
  assert (in_transf (State_bits r0 m1 a0)).
  {
    econstructor; eauto.
    rewrite H18. rewrite H2.
    replace (zlen c1 + 0) with (zlen c1) by omega.
    apply Htransf.
    name H10 Hstin.
    rewrite st_in_eq in H10. break_and.
    rewrite H18. rewrite H2.
    replace (zlen c1 + 0) with (zlen c1) by omega.
    eauto.
    rewrite H18. rewrite H2.
    replace (zlen c1 + 0) with (zlen c1) by omega.
    rewrite st_in_eq in H10. break_and.
    eauto.
  }
  app transf_step_same_block H15.
  inv H15.
  repeat match goal with
           | [ H : State_bits _ _ _ = State_bits _ _ _ |- _ ] => inv H
         end.
  repeat unify_PC.
  repeat unify_psur.
  app transf_step_same_block H9.
  inv H9.
  repeat match goal with
           | [ H : State_bits _ _ _ = State_bits _ _ _ |- _ ] => inv H
         end.
  repeat unify_PC.
  repeat unify_psur.
  rewrite st_in_eq in H10.
  break_and.
  repeat unify_PC. repeat unify_psur.
  symmetry.

  eapply star_step_in_same_block; eauto.

Qed.

Lemma match_entry_match_live :
  forall rs m rs' m' bits b i md md',
    at_entry (State_bits rs m md) ->
    match_states (State_bits rs m md) (State_bits rs' m' md') ->
    rs PC = Values.Vint bits ->
    psur md bits = Some (b,i) ->
    (forall r, In r (liveness_fun_f ge b (Int.unsigned i)) ->
               val_eq (rs r) (rs' r) /\ mem_eq md m m').
Proof.
  intros rs m rs' m' bits b i md md' Hat Hmatch HPC Hpsur.
  inv Hmatch; repeat unify_PC; repeat unify_psur; eauto.
  assert (in_transf (State_bits rs m md)).
  econstructor; try apply H9; try apply H7; eauto.

  app at_entry_not_in Hat. app Hat H. inv_false.
Qed.

Lemma match_exit :
  forall z rsl ml rsr mr ml' mr' rsl' rsr' b ofs bits mdl mdr mdl' mdr',
    match_states (State_bits rsl ml mdl) (State_bits rsr mr mdr)->
    rsl PC = Values.Vint bits ->
    psur mdl bits = Some (b,ofs) ->
    Int.unsigned ofs = z + 0 ->
    step_through z (find rwr) (Genv.globalenv prog) (State_bits rsl ml mdl) E0 (State_bits rsl' ml' mdl') ->
    step_through z (repl rwr) (Genv.globalenv tprog) (State_bits rsr mr mdr) E0 (State_bits rsr' mr' mdr') ->
    ((forall r, In r (live_out rwr) -> val_eq (rsl' r) (rsr' r)) /\ mem_eq mdl' ml' mr' /\ mdl = mdr) ->
    genv_equiv_code z (Genv.globalenv prog) (Genv.globalenv tprog) b (find rwr) (repl rwr) ->
    transf_range rwr prog b z (z + zlen (find rwr)) ->
    match_states (State_bits rsl' ml' mdl') (State_bits rsr' mr' mdr').
Proof.
  intros.
  assert (HPC : In PC (live_out rwr)) by (apply (PC_live_out rwr)).
  (* need a state right prior to rs m, in order to use single exit *)
  assert (exists rsi mi mdi, (at_entry (State_bits rsi mi mdi) \/ in_transf (State_bits rsi mi mdi)) /\
                         step_bits ge (State_bits rsi mi mdi) E0 (State_bits rsl' ml' mdl')).
  {

    inv H3. exists rsl. exists ml. exists mdl.
    split; auto. left. econstructor; eauto.
    rewrite H2. instantiate (1 := z + zlen (find rwr)).
    inv H7; econstructor; eauto. omega.
    destruct stC. exists r. exists m. exists a.
    rewrite H8.
    destruct t1; simpl in H8; try solve [inv H8].
    destruct t2; simpl in H8; try solve [inv H8].
    destruct t3; simpl in H8; try solve [inv H8].
    simpl in H8. rewrite H8 in *.
    unfold ge. unfold fundef in *.
    split; auto.
    destruct stB.
    right. econstructor; eauto.
    rewrite H2. instantiate (1 := z + zlen (find rwr)).
    inv H7; econstructor; eauto. omega.
    rewrite st_in_eq in H12. break_and.
    rewrite H2. replace (z + 0) with z by omega.
    assumption.
    rewrite st_in_eq in H12. break_and.
    rewrite H2. replace (z + 0) with z by omega.
    simpl.
    assumption.
  }
  break_exists. break_exists. break_and.

  app step_through_at_end H3.
  inv H3.
  destruct fd.

  repeat break_and. subst.

  assert (mdl' = mdr'). {
    app (steps_pres_find rwr) H10. break_and.
    app (steps_pres_repl rwr) H4. break_and.
    congruence.
    eapply no_PC_ovf_tprog; eauto.
    inv H13; eauto.
    unfold transf_program in TRANSF;
    repeat break_match_hyp;
    inversion TRANSF; eauto.
    inv H10; eauto.
  } idtac.
  subst.

  assert (at_entry (State_bits rsl ml mdr)). {
    econstructor. eauto.
    eauto. rewrite H2. replace (zlen c0 + 0) with (zlen c0) by omega.
    eassumption.
  } idtac.

  app step_through_transf_same_block H10. subst.

  (* Construct the match_states relation here *)
  eapply outside; eauto.

  * name (H5 PC HPC) Hrsr'PC.
    rewrite H14 in Hrsr'PC. simpl in Hrsr'PC. congruence.

  * econstructor; eauto.
    eexists. split.
    eassumption. simpl.
    simpl. left. eexists; eexists.
    split; eauto. omega.

  *

  name H7 Htransf.
  inv H7. break_and.
  name H13 Htc.
  unfold transf_code in H13.

  rewrite H7 in H13.
  break_match_hyp.
  Focus 2.
  app transf_did_happen Htransf. simpl in Htransf.
  rewrite H13 in Htransf. congruence.
  NP _app is_proper_check_sound is_proper_location_check.
  unfold is_proper_rewrite_location in *.
  repeat break_and.
  unfold liveness_check_correct in *.
  repeat break_and.

  intro.
  unfold liveness_fun_f.
  repeat collapse_match.
  NP _app split_pat_spec split_pat.
  subst c.
  collapse_match.
  rewrite H19.
  rewrite H16.
  intros.

  assert (In r (live_out rwr ++ pres rwr)).
  {

    apply H34.
    rewrite zlen_app.
    assumption.
  }

  rewrite in_app in *. break_or.
  apply H5. auto.
  rewrite <- zlen_app in H7.
  rewrite <- H35 in H7 by auto.

  name (steps_pres_find rwr) spf.
  name (steps_pres_repl rwr) spr.

  unfold step_through_preserve in *.
  app step_through_at H4.
  app step_through_at H12.
  assert (Hnpc : no_PC_overflow_prog prog).
  {
    unfold transf_program in TRANSF;
    repeat break_match_hyp;
    inversion TRANSF; eauto.
  }
  assert (Hnpc' : no_PC_overflow_prog tprog).
  {
    eapply no_PC_ovf_tprog; eauto.
  }

  name (spf _ _ _ _ _ _ _ _ _ Hnpc H12 H39) spf''.
  name (spr _ _ _ _ _ _ _ _ _ Hnpc' H4 H37) spr''.
  repeat break_and. clear H43. clear H41.
  rename H42 into spf'.
  rename H40 into spr'.
  rewrite <- spf' by eauto.
  rewrite <- spr' by eauto.

  assert (Hlve : forall r0 : preg,
            In r0 (liveness_fun_f (Genv.globalenv prog) b0 (Int.unsigned ofs)) ->
            val_eq (rsl r0) (rsr r0)).
  {
    eapply match_entry_match_live; eauto.
  }
  apply Hlve. unfold liveness_fun_f.
  repeat collapse_match.
  match goal with
    | [ H : Int.unsigned ofs = _ |- _ ] => rewrite H
  end.
  replace (zlen c0 + 0) with (zlen c0) by omega.
  congruence.

  *

  assert (no_ptr_regs rsr /\ no_ptr_mem mr).
  {
    inv H;break_and; split; auto;
    eapply no_ptr_mem_eq; eauto.
  }

  eapply no_ptr_preserved_step_through; eauto.

Qed.

Lemma step_through_match :
  forall z st st' str,
    at_entry st ->
    step_through z (find rwr) (Genv.globalenv prog) st E0 st' ->
    match_states st str ->
    exists str',
      plus step_bits (Genv.globalenv tprog) str E0 str' /\
      match_states st' str'.
Proof.
  intros.
  name (steps_equiv_live rwr) selr.
  destruct st'.
  unfold step_through_equiv_live in selr.
  assert (at_code z (find rwr) 0 (Genv.globalenv prog) st).
  {
    inv H0; eauto.
  }

  name H2 Hat_code.
  inv H2.
  assert (genv_equiv_code (zlen c0) (Genv.globalenv prog) (Genv.globalenv tprog) b (find rwr) (repl rwr)).
  {
    econstructor; eauto;
    repeat unify_find_funct_ptr;
    simpl in *.

    erewrite functions_translated in H9; eauto.
    subst c.
    inversion H9. inversion H. inversion H16.
    subst.
    unify_PC. unify_psur. break_and.
        app split_pat_spec H2. simpl in H9.
        unify_find_funct_ptr.
    rewrite H13. rewrite H4.
    replace (zlen c0) with (zlen c2) by omega.
    rewrite nat_zlen.
    eapply pat_at_n_sane.
    inv H. inv H14.
    unify_PC. unify_psur.
    erewrite functions_translated in H9; eauto.
    repeat unify_find_funct_ptr.
    inv H15. inv H9.
    break_and.

    NP _app split_pat_spec split_pat. subst.
    unify_find_funct_ptr.
    eapply list_eq_middle_therefore_eq in H13; try omega.
    break_and. subst.
    rewrite H9.

    rewrite nat_zlen.
    repeat rewrite firstn_len.
    reflexivity.
  }

  assert (exists (s : signature) (c : code), Genv.find_funct_ptr (Genv.globalenv tprog) b = Some (Internal {| fn_sig := s; fn_code := c |})).
  {
    destruct fd.
    eexists. eexists. erewrite functions_translated; eauto.
    simpl. reflexivity.
  }

  assert (no_PC_overflow_prog prog).
  {
    unfold transf_program in TRANSF.
    repeat break_match_hyp; inversion TRANSF; eauto.
  }

  name H0 Hst_thru_left.
  destruct str.
  app at_entry_match H1.
  break_and.

  assert (t = a0). {
    simpl.
    inv H11; auto.
    assert (in_transf (State_bits rs m0 t)).
    econstructor; try apply H23; eauto.
    app at_entry_not_in H.
    app H H11. inv_false.
  } subst.

  eapply selr with (rsr := r0) in H0;
    try solve [eapply no_PC_ovf_tprog; eauto];
    eauto.

  Focus 2.
  (* clear -TRANSF H. *)
  P inv at_entry.
  P inv PeepholeLib.transf_range.
  break_and.
  unfold transf_code in *.
  NP1 app_new split_pat_spec (Some (c2, c3)).
  subst.
  assert (c2 ++ find rwr ++ c3 <> c2 ++ repl rwr ++ c3).
  eapply list_neq.
  eapply (not_same rwr).
  repeat (break_match_hyp; try congruence); [].
  NP app_new is_proper_check_sound is_proper_location_check.
  break_and.
  unfold is_proper_rewrite_location in *.
  repeat break_and.
  apply mk_not_after_label_in_code.
  unfold not_after_label.
  intros.
  repeat match goal with
           | [ H : State_bits _ _ _ = State_bits _ _ _ |- _ ] => inv H
           | [ H : Some _ = Some _ |- _ ] => inv H
         end.
  unify_stuff.
  inv Hat_code.
  unify_stuff.
  P1 _simpl fn_code.
  assert (zlen c0 = zlen c2) by omega.
  assert (zlen c5 = zlen c2) by omega.
  eapply list_eq_middle_therefore_eq in H4.
  repeat break_and.
  subst c5.
  subst c6.
  split.
  assumption.
  auto.
  auto.

  repeat break_exists. repeat break_and.

  exists (State_bits x1 x2 a).

  split.

  eapply step_through_plus_step; eauto.

  eapply match_exit; eauto.
  destruct fd.
  inv H. repeat unify_PC.
  repeat unify_psur.

  rewrite H5 in H21.
  inv H21.

  inv H. repeat unify_PC. repeat unify_psur.
  econstructor; eauto.
  omega. rewrite zlen_app. omega.
  inv H11; eauto.
  intros.
  exploit symbol_address_pres; eauto.

  assert (global_perms (Genv.globalenv prog) m0).
  inv H0.
  app step_gp H14.
  tauto.
  destruct stB.
  app step_gp H16.
  tauto.
  apply global_perms_translated.
  eapply global_perms_mem_eq; eauto.
Qed.

Lemma step_out :
  forall sl sl' sr t,
    match_states sl sr ->
    step_bits (Genv.globalenv prog) sl t sl' ->
    in_transf sl ->
    outside_range sl' ->
    exists sr',
      plus step_bits (Genv.globalenv tprog) sr E0 sr' /\ match_states sl' sr'.
Proof.
  intros.
  (* Here we appeal to the correctness of symbolic evaluation *)
  (* what does that look like? *)
  inv H.
  * (* contradiction *)
    eapply outside_not_in in H6; eauto.
    app H6 H1. inv_false.

  * (* contradiction *)

    assert (at_entry (State_bits rs m md)).
      econstructor; eauto.

      eapply at_entry_not_in in H; eauto.
      app H H1. inv_false.

  * (* interesting case *)

    name (steps_equiv_live rwr) selr.
    name (steps_pres_find rwr) spf.
    name (steps_pres_repl rwr) spr.

    assert (t = E0).
      eapply no_trace_step; eauto.
    subst.

    destruct sl'.

    assert (Hat_entry : at_entry (State_bits rsl ml md)) by (econstructor; eauto).

    assert (Hat_code: at_code (Int.unsigned i) (find rwr) 0 (Genv.globalenv prog) (State_bits rsl ml md)).
    {
      inv H6. rewrite H14. break_and.
      econstructor; eauto. omega.
      name (zlen_find rwr) zlnf.
      omega. simpl.
      app split_pat_spec H6.
    }

    assert (Hat_end: at_code_end (Int.unsigned i) (find rwr) (Genv.globalenv prog) (State_bits r m a)).
    {
      app transf_step_same_block H0.
      inv H0. find_inversion. find_inversion.
      app transf_step_same_block H7.
      inv H7.
      find_inversion. find_inversion.
      repeat unify_PC. repeat unify_psur.
      app star_step_in_same_block H9. subst b0.
      name H6 Htransf_range.
      inv H6.
      rewrite H13.
      econstructor; eauto.
      rewrite <- H13.

      app single_exit H;
        repeat break_and.

      repeat unify_PC.
      repeat unify_psur.
      rewrite zlen_app in H21. omega.

      repeat break_and.
      app split_pat_spec H6.
    }

    assert (Hst_thru: step_through (Int.unsigned i) (find rwr) (Genv.globalenv prog) (State_bits rsl ml md) E0 (State_bits r m a)).
    {
      replace E0 with (E0 ** E0 ** E0) by (simpl; auto).
      eapply st_thru_mult_step; eauto.
      rewrite st_in_eq. split. eauto.
      eauto.
    }

    app step_through_match Hst_thru; eauto.
    eapply entry; eauto.

  * (* contradiction *)
    simpl.
    inv H1.
    app transf_step_same_block H14.
    inv H14. find_inversion. find_inversion.
    repeat unify_PC. repeat unify_psur.
    app star_step_in_same_block H16.
    subst b1.
    inv H13. unify_find_funct_ptr.
    right. econstructor; eauto.
Qed.

Lemma match_not_in :
  forall sl sl' sr sr' t,
    outside_range sl ->
    match_states sl sr ->
    step_bits (Genv.globalenv prog) sl t sl' ->
    step_bits (Genv.globalenv prog) sr t sr' ->
    outside_range sl' ->
    match_live liveness_fun_f prog sl' sr' ->
    match_states sl' sr'.
Proof.
  intros. name H Hout_start. name H3 Hout_end.
  inv H0.
  * unfold match_live in H4. destruct sl'. destruct sr'.
    inv H3.
    specialize (H4 _ _ _ H15 H14).
    repeat break_and.
    subst a.
    eapply outside; eauto.

    exploit (H13 PC).
    unfold transf_program in TRANSF.
    repeat break_match_hyp; inversion TRANSF.
    eapply PC_always_live; eauto. destruct u. eassumption.
    intros.
    rewrite H14 in H12.
    simpl in H12. congruence.
  * assert (at_entry (State_bits rs m md)).
      econstructor; eauto.
    app at_entry_not_out H0.
    app H0 H. inv_false.
  * assert (in_transf (State_bits rsl' m' md')) by (
      econstructor; try apply H5; eauto).
    app inside_not_out H0.
    app H0 H. inv_false.
  * unfold match_live in H4. destruct sl'. destruct sr'.
    inv H3.
    specialize (H4 _ _ _ H14 H13).
    repeat break_and.
    subst a.
    eapply outside; eauto.
    exploit (H12 PC).
    unfold transf_program in TRANSF.
    repeat break_match_hyp; inversion TRANSF.
    eapply PC_always_live; eauto.
    destruct u. eassumption.
    intros. rewrite H13 in H11. simpl in H11. congruence.
Qed.

Lemma match_at_entry :
  forall sl sl' sr sr' t,
    outside_range sl ->
    match_states sl sr ->
    step_bits (Genv.globalenv prog) sl t sl' ->
    step_bits (Genv.globalenv prog) sr t sr' ->
    at_entry sl' ->
    match_live liveness_fun_f prog sl' sr' ->
    match_states sl' sr'.
Proof.
  intros. name H Houtside. name H3 Hat_entry.
  inv H0.
  * unfold match_live in H4. destruct sl'. destruct sr'.
    inv H3.
    specialize (H4 _ _ _ H15 H14).
    repeat break_and.
    name H16 Htransf_range. inv H16.
    eapply entry; eauto.
    exploit (H13 PC).
    unfold transf_program in TRANSF.
    repeat break_match_hyp; inversion TRANSF.
    eapply PC_always_live; eauto. destruct u.
    eassumption.
    intros. rewrite H14 in H12. simpl in H12. congruence.
  * assert (at_entry (State_bits rs m md)) by (
      econstructor; eauto).
    app at_entry_not_out H0.
    app H0 H. inv_false.
  * assert (in_transf (State_bits rsl' m' md')) by (
      econstructor; try apply H11; try apply H9; eauto).
    app outside_not_in Houtside.
    app Houtside H0. inv_false.
  * unfold match_live in H4. destruct sl'. destruct sr'.
    inv H3.
    specialize (H4 _ _ _ H14 H13).
    repeat break_and.

    name H15 Htransf_range. inv H15.
    eapply entry; eauto.
    exploit (H12 PC).
    unfold transf_program in TRANSF.
    repeat break_match_hyp; inversion TRANSF.
    eapply PC_always_live; eauto.
    destruct u. eassumption.
    intros. rewrite H13 in H11. simpl in H11. congruence.
Qed.

Lemma step_out_at_entry :
  forall sl sl' sr t,
    match_states sl sr ->
    step_bits (Genv.globalenv prog) sl t sl' ->
    at_entry sl ->
    outside_range sl' ->
    exists sr',
      plus step_bits (Genv.globalenv tprog) sr E0 sr' /\ match_states sl' sr'.
Proof.
  intros.
  app at_entry_at_code H1.
  app no_trace_entry_step H0. subst t.
  eapply step_through_match; eauto.
  econstructor; eauto.

  inv H1. destruct sl'.
  name H3 Hat_entry.
  inv H3. repeat unify_PC. repeat unify_psur.
  app single_exit H0.
  repeat break_and.
  econstructor; eauto.
  inv H14.
  rewrite zlen_app in H16.
  omega.
Qed.

Lemma entry_step_in :
  forall s1 s2 s1',
    match_states s1 s2 ->
    at_entry s1 ->
    step_bits (Genv.globalenv prog) s1 E0 s1' ->
    in_transf s1' ->
    match_states s1' s2.
Proof.
  intros.
  inv H.
  * app at_entry_not_out H0.
    app H0 H6. inv_false.
  * app transf_step_same_block H1.
    inv H1. find_inversion.
    repeat unify_PC.
    repeat unify_psur.
    eapply inside; try apply star_refl; eauto.

    inv H2.
    assert (at_entry (State_bits rsl m md)) by (econstructor; eauto).
    app transf_step_same_block H17.
    inv H17. find_inversion. find_inversion.
    repeat unify_PC. repeat unify_psur.

    app star_step_in_same_block H19. subst b0.

    eapply transf_range_unique in H6; try apply H16.
    break_and. rewrite H6.

    name (conj H3 H18) Hstin.
    rewrite <- st_in_eq in Hstin.
    app star_step_in_in' Hstin.

  * assert (in_transf (State_bits rsl' m' md')) by (
    econstructor; try apply H7; eauto).
    app at_entry_not_in H0.
    app H0 H. inv_false.
  * inv H0. unify_PC. unify_psur.
    inv H13. unify_find_funct_ptr.
Qed.

End PRESERVATION.