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.goose_lang.ffi Require Export grove_ffi_time_axiom.
From Perennial.base_logic.lib Require Import ghost_var.
From Goose.github_com.mit_pdos.gokv Require Import minlease.
From iris.bi.lib Require Import fixpoint.
From Perennial.base_logic Require Import lib.saved_prop.
From Perennial.program_proof Require Import std_proof.

Section proof.

Context `{!heapGS Σ}.
Context `{!ghost_varG Σ u64}.
Context `{!ghost_varG Σ ()}.
Context `{!savedPropG Σ }.

Context {γtime:gname}.

Notation is_time_lb := (is_time_lb γtime).
Notation own_time := (own_time γtime).

(* Q is the lease obligation *)
Definition underLease (N:namespace) (leaseExpiration:u64) (P:iProp Σ) (Q:iProp Σ) : iProp Σ :=
  ∃ γprop γpostLeastTok,
  saved_prop_own γprop (DfracOwn (1/2)) P ∗
  inv N (∃ P',
    saved_prop_own γprop (DfracOwn (1/2)) P' ∗
    (P' ∗ (P' -∗ Q) ∨ is_time_lb leaseExpiration ∗ ghost_var γpostLeastTok 1 ())
  ).

(* Doesn't seem useful
Lemma underLease_mono P' P Q e N :
  (P -∗ P') -∗
  (P' -∗ Q) -∗
  underLease N e P Q -∗
  underLease N e P' Q
.
Proof.
Admitted. *)

Lemma lease_acc_update N e P Q :
  underLease N e P Q -∗
  £ 1 -∗
  £ 1 -∗
  ∀ (t:u64),
  ⌜int.nat t < int.nat e⌝ →
  own_time t ={↑N,∅}=∗
  (P ∗ (∀ P', P' -∗ (P' -∗ Q) ={∅,↑N}=∗ own_time t ∗ underLease N e P' Q))
.
Proof.
  iIntros "Hlease Hlc Hlc2".
  iIntros (?) "%Hineq Htime".
  iDestruct "Hlease" as (γprop ?) "[Hprop #Hinv]".
  iInv "Hinv" as "Hi" "Hclose".
  iMod (lc_fupd_elim_later with "Hlc Hi") as "Hi".
  iDestruct "Hi" as (?) "[Hprop2 Hi]".
  iDestruct (saved_prop_agree with "Hprop Hprop2") as "#Hagree1".
  iMod (lc_fupd_elim_later with "Hlc2 Hagree1") as "#Hagree".
  replace (↑N ∖ ↑N) with (∅:coPset) by set_solver.
  iModIntro.
  iDestruct "Hi" as "[[HP HQwand]|[Hbad HpostLeastTok]]"; last first.
  {
    iDestruct (mono_nat_lb_own_valid with "Htime Hbad") as %[_ Hbad].
    exfalso.
    word.
  }
  iSplitL "HP".
  {
    by iRewrite "Hagree".
  }
  iIntros (R) "HR HRwandQ".
  iMod (saved_prop_update_2 R with "Hprop Hprop2") as "[Hprop Hprop2]".
  { apply Qp.half_half. }
  iFrame "Htime".
  iMod ("Hclose" with "[HRwandQ HR Hprop2]").
  {
    iNext.
    iExists _; iFrame "Hprop2".
    iLeft.
    iFrame.
  }
  iModIntro.
  iExists _, _; iFrame "∗#".
Qed.

Definition postLease (N:namespace) (leaseExpiration:u64) (Q:iProp Σ) : iProp Σ :=
  is_time_lb leaseExpiration ={↑N}=∗ ▷ Q
.

Lemma lease_alloc e Q N P :
  P -∗ (P -∗ Q) ={↑N}=∗
  underLease N e P Q ∗
  postLease N e Q
.
Proof.
  iIntros "HP Hwand".
  iMod (saved_prop_alloc P (DfracOwn 1)) as (γprop) "[Hprop Hprop2]".
  { done. }
  iMod (ghost_var_alloc ()) as (γpostLeaseTok) "HpostLeaseTok".
  iAssert (|={↑N}=>
  inv N (∃ P',
    saved_prop_own γprop (DfracOwn (1/2)) P' ∗
    (P' ∗ (P' -∗ Q) ∨ is_time_lb e ∗ ghost_var γpostLeaseTok 1 ())
  ))%I with "[HP Hwand Hprop2]" as ">#Hinv".
  {
    iMod (inv_alloc with "[-]") as "$"; last done.
    iNext.
    iExists _; iFrame "Hprop2".
    iLeft. iFrame.
  }
  iModIntro.
  iSplitL "Hprop".
  {
    iExists _, _; iFrame "∗#".
  }
  iIntros "Hlb".
  iInv "Hinv" as "Hi" "Hclose".
  iDestruct "Hi" as (?) "[Hprop HP]".
  iDestruct "HP" as "[HP |[_ >Hbad]]"; last first.
  {
    iDestruct (ghost_var_valid_2 with "Hbad HpostLeaseTok") as %[Hbad _].
    exfalso.
    done.
  }
  iDestruct "HP" as "[HP HPwand]".
  iDestruct (later_wand with "HPwand") as "HPwand".
  iMod ("Hclose" with "[Hprop HpostLeaseTok Hlb]").
  {
    iExists _; iFrame.
    iRight.
    iFrame.
  }
  iApply "HPwand".
  done.
Qed.

(* P are resources you can access and modify at the moment you check that the
   lease is unexpired.
 *)

Definition own_Server s γ : iProp Σ :=
  ∃ (v:u64),
  "Hval" ∷ s ↦[Server :: "val"] #v ∗
  "Hauth" ∷ ghost_var γ (1/2) v
.

Definition LEASE_EXP := U64 10.

Definition minleaseN := nroot .@ "minlease".

Definition is_Server s γ : iProp Σ :=
  ∃ mu,
  "#Hmu" ∷ readonly (s ↦[Server :: "mu"] mu) ∗
  "#HleaseExpiration" ∷ readonly (s ↦[Server :: "leaseExpiration"] #LEASE_EXP) ∗
  "#HmuInv" ∷ is_lock minleaseN mu (own_Server s γ)
.

Lemma wp_Put s (v:u64) γ Φ :
is_Server s γ -∗
(|={⊤,∅}=> ∃ (oldv:u64), ghost_var γ (1/2) oldv ∗
(ghost_var γ (1/2) v ={∅,⊤}=∗ Φ #()) )-∗
  WP Server__Put #s #v {{ Φ }}
.
Proof.
  iIntros "Hsrv Hupd".
  iNamed "Hsrv".
  wp_lam.
  wp_pures.
  wp_loadField.
  wp_apply (acquire_spec with "HmuInv").
  iIntros "[Hlocked Hown]".
  iNamed "Hown".
  wp_pures.
  wp_storeField.
  wp_loadField.

  iApply fupd_wp.
  iMod "Hupd" as (?) "[Hval2 Hupd]".
  iMod (ghost_var_update_2 with "Hauth Hval2") as "[Hauth Hval2]".
  { apply Qp.half_half. }
  iMod ("Hupd" with "Hval2") as "HΦ".
  iModIntro.
  wp_apply (release_spec with "[-HΦ]").
  {
    iFrame "HmuInv Hlocked".
    iNext.
    repeat iExists _; iFrame "∗#%".
  }
  wp_pures.
  by iFrame.
Qed.

Lemma wp_Get s γ Φ :
is_Server s γ -∗
(|={⊤,∅}=> ∃ (v:u64), ghost_var γ (1/2) v ∗
(ghost_var γ (1/2) v ={∅,⊤}=∗ Φ #v) )-∗
  WP Server__Get #s {{ Φ }}
.
Proof.
  iIntros "Hsrv Hupd".
  iNamed "Hsrv".
  wp_lam.
  wp_pures.
  wp_loadField.
  wp_apply (acquire_spec with "HmuInv").
  iIntros "[Hlocked Hown]".
  iNamed "Hown".
  wp_pures.
  wp_loadField.
  wp_loadField.

  iApply fupd_wp.
  iMod "Hupd" as (?) "[Hval2 Hupd]".
  iDestruct (ghost_var_valid_2 with "Hauth Hval2") as %[_ ->].
  iMod ("Hupd" with "Hval2") as "HΦ".
  iModIntro.
  wp_apply (release_spec with "[-HΦ]").
  {
    iFrame "HmuInv Hlocked".
    iNext.
    repeat iExists _; iFrame "∗#%".
  }
  wp_pures.
  by iFrame.
Qed.

Lemma wp_StartServer γ :
  {{{
      "Hlease" ∷ underLease minleaseN LEASE_EXP (ghost_var γ (1/2) (U64 0)) (∃ (v:u64), (ghost_var γ (1/2) v)) ∗
      "Hauth" ∷ ghost_var γ (1/2) (U64 0)
  }}}
    StartServer #()
  {{{
        s, RET #s; is_Server s γ
  }}}
.
Proof.
  iIntros (Φ) "Hpre HΦ".
  iNamed "Hpre".
  wp_lam.
  wp_apply (wp_allocStruct).
  { repeat constructor. }
  iIntros (?) "Hl".
  iDestruct (struct_fields_split with "Hl") as "HH".
  iNamed "HH".
  wp_pures.
  wp_apply (wp_new_free_lock).
  iIntros (mu) "HmuInv".
  wp_storeField.
  wp_storeField.
  wp_storeField.
  iMod (readonly_alloc_1 with "mu") as "#Hmu".
  iMod (readonly_alloc_1 with "leaseExpiration") as "#HleaseExpiration".

  iAssert (|={⊤}=> is_Server l γ)%I with "[-HΦ Hlease]" as ">#Hsrv".
  {
    repeat iExists _.
    iFrame "∗#%".
    iDestruct (alloc_lock with "HmuInv [-]") as "$".
    iNext.
    repeat iExists _; iFrame "∗#%".
  }

  wp_apply (wp_fork with "[-HΦ]").
  {
    iNext.
    wp_pure1_credit "Hlc1".
    wp_pure1_credit "Hlc2".
    wp_pures.
    iAssert  ( ∃ v,
      "Hlease" ∷ underLease minleaseN LEASE_EXP (ghost_var γ (1 / 2) v%Z)
               (∃ v' : u64, ghost_var γ (1 / 2) v')
               )%I with "[Hlease]" as "HH" .
    { iExists _. iFrame. }
    wp_forBreak_cond.
    wp_pures.
    wp_lam.
    iClear "Hmu HleaseExpiration".
    iNamed "Hsrv".
    wp_loadField.
    wp_apply (acquire_spec with "HmuInv").
    iIntros "[Hlocked Hown]".
    wp_pures.
    wp_apply (wp_GetTimeRange γtime).
    iIntros (low high t) "%Hineq1 %Hineq2 Htime".
    iNamed "HH".

    destruct (decide (int.nat LEASE_EXP < int.nat high)).
    2:{ (* case: lease is not expired *)
      iDestruct (lease_acc_update with "Hlease Hlc1 Hlc2") as "HH".
      iDestruct ("HH" $! t with "[%] Htime") as "HH".
      { word. }
      iMod (fupd_mask_subseteq _) as "Hmask"; last iMod "HH".
      { set_solver. }
      iNamed "Hown".
      iDestruct "HH" as "[Hval2 HcloseLease]".
      iDestruct (ghost_var_valid_2 with "Hauth Hval2") as %[_ ->].
      iMod (ghost_var_update_2 (word.add v 1) with "Hauth Hval2") as "[Hauth Hval2]".
      { apply Qp.half_half. }

      iMod ("HcloseLease" $!_ with "Hval2 []") as "[Htime Hlease]".
      {
        iIntros. iExists _; iFrame.
      }
      iMod "Hmask".
      iModIntro.
      iFrame "Htime".
      wp_pure1_credit "Hlc1".
      wp_pure1_credit "Hlc2".
      wp_loadField.
      wp_pures.
      wp_bind (If (#(bool_decide _)) _ _).
      wp_if_destruct.
      1:{
        exfalso.
        word.
      }
      wp_loadField.
      wp_apply (wp_SumAssumeNoOverflow).
      iIntros "%Hoverflow".
      wp_storeField.
      wp_loadField.
      wp_apply (release_spec with "[-Hlease Hlc1 Hlc2]").
      {
        iFrame "HmuInv Hlocked".
        repeat iExists _; iFrame "∗#%".
      }
      wp_pures.
      iLeft.
      iModIntro.
      iSplitR; first done.
      iFrame.
      iExists _.
      iFrame.
    }
    (* Otherwise, lease has expired *)
    iModIntro.
    iFrame.
    wp_pures.
    wp_loadField.
    wp_pures.
    wp_bind (If (#(bool_decide _)) _ _).
    wp_if_destruct.
    2:{ exfalso. word. }
    wp_loadField.
    wp_apply (release_spec with "[-Hlease]").
    {
      iFrame "HmuInv Hlocked". iFrame.
    }
    wp_pures.
    iRight.
    iModIntro.
    done.
  }
  wp_pures.
  iModIntro.
  iApply "HΦ".
  done.
Qed.

Lemma wp_client s γ :
  {{{
      "#Hsrv" ∷ is_Server s γ ∗
      "HpostLease" ∷ postLease minleaseN LEASE_EXP (∃ (v':u64), ghost_var γ (1/2) v')
  }}}
    client #s
  {{{
      RET #(); True
  }}}
.
Proof.
  iIntros (Φ) "Hpre HΦ".
  iNamed "Hpre".
  wp_call.
  wp_forBreak.
  wp_pures.
  wp_apply (wp_GetTimeRange γtime).
  iIntros (low high t Hineq1 Hineq) "Htime".

  iAssert (_) with "Hsrv" as "Hsrv2".
  iNamed "Hsrv2".

  destruct (decide (int.nat LEASE_EXP < int.nat low)).
  {
    iDestruct (mono_nat_lb_own_get with "Htime") as "#Hlb".
    unfold postLease.
    iMod (fupd_mask_subseteq _) as "Hmask";
      last iMod ("HpostLease" with "[Hlb]") as "HpostLease".
    { set_solver. }
    { iApply mono_nat_lb_own_le; last iFrame "#". word. }
    iMod "Hmask" as "_".
    iModIntro.
    iFrame "Htime".
    wp_pures.
    iDestruct "HpostLease" as (?) "Hghost".
    wp_loadField.
    wp_pures.
    wp_if_destruct.
    2:{ exfalso. word. }
    iModIntro.
    iRight.
    iSplitR; first done.
    wp_pures.
    wp_apply (wp_Get with "Hsrv").
    iApply fupd_mask_intro.
    { set_solver. }
    iIntros "Hmask".
    iExists _; iFrame.
    iIntros "Hvar".
    iMod "Hmask" as "_".
    iModIntro.
    wp_pures.
    wp_apply wp_SumAssumeNoOverflow.
    iIntros (HnoOverflow).
    wp_pures.
    wp_apply (wp_Put with "Hsrv").
    iApply fupd_mask_intro.
    { set_solver. }
    iIntros "Hmask".
    iExists _; iFrame.
    iIntros "Hvar".
    iMod "Hmask" as "_".
    iModIntro.
    wp_pures.
    wp_apply (wp_Get with "Hsrv").
    iApply fupd_mask_intro.
    { set_solver. }
    iIntros "Hmask".
    iExists _; iFrame.
    iIntros "Hvar".
    iMod "Hmask" as "_".
    iModIntro.
    wp_pures.
    wp_apply (wp_Assert).
    { apply bool_decide_true. done. }
    wp_pures.
    iModIntro.
    by iApply "HΦ".
  }
  { (* loop and wait for server's lease to expire *)
    iFrame "Htime".
    iModIntro.
    wp_pures.
    wp_loadField.
    wp_pures.
    wp_if_destruct.
    { exfalso. word. }
    wp_loadField.
    wp_apply wp_Sleep.
    wp_pures.
    iLeft.
    iFrame.
    done.
  }
Qed.

Lemma wp_main :
  {{{
       True
  }}}
    main #()
  {{{
        RET #(); True
  }}}
.
Proof using Type* γtime.
  iIntros (Φ) "_ HΦ".
  wp_lam.
  iMod (ghost_var_alloc (U64 0)) as (γ) "[Hvar Hvar2]".
  iApply fupd_wp.
  iMod (fupd_mask_subseteq (↑minleaseN)) as "Hmask".
  { set_solver. }
  iMod (lease_alloc LEASE_EXP (∃ v:u64, ghost_var γ (1/2) v) with "Hvar2 []") as "[Hlease HpostLease]".
  { iIntros. iExists _; iFrame. }
  iMod "Hmask".
  iModIntro.
  wp_apply (wp_StartServer with "[$Hlease $Hvar]").
  iIntros (s) "#Hsrv".
  wp_pures.
  wp_apply (wp_client with "[$Hsrv $HpostLease]").
  wp_pures.
  iModIntro.
  by iApply "HΦ".
Qed.

End proof.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Correctness proof for IA32 generation: auxiliary results. *)

Require Import Coqlib.
Require Import AST.
Require Import Errors.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
Require Import Op.
Require Import Locations.
Require Import Mach.
Require Import Asm.
Require Import Asmgen.
Require Import Asmgenproof0.
Require Import Conventions.

Open Local Scope error_monad_scope.

(** * Correspondence between Mach registers and IA32 registers *)

Lemma agree_nextinstr_nf:
  forall ms sp rs,
  agree ms sp rs -> agree ms sp (nextinstr_nf rs).
Proof.
  intros. unfold nextinstr_nf. apply agree_nextinstr.
  apply agree_undef_nondata_regs. auto.
  intro. simpl. ElimOrEq; auto.
Qed.

(** Useful properties of the PC register. *)

Lemma nextinstr_nf_inv:
  forall r rs,
  match r with PC => False | CR _ => False | _ => True end ->
  (nextinstr_nf rs)#r = rs#r.
Proof.
  intros. unfold nextinstr_nf. rewrite nextinstr_inv.
  simpl. repeat rewrite Pregmap.gso; auto;
  red; intro; subst; contradiction.
  red; intro; subst; contradiction.
Qed.

Lemma nextinstr_nf_inv1:
  forall r rs,
  data_preg r = true -> (nextinstr_nf rs)#r = rs#r.
Proof.
  intros. apply nextinstr_nf_inv. destruct r; auto || discriminate.
Qed.

Lemma nextinstr_nf_set_preg:
  forall rs m v,
  (nextinstr_nf (rs#(preg_of m) <- v))#PC = Val.add rs#PC Vone.
Proof.
  intros. unfold nextinstr_nf.
  transitivity (nextinstr (rs#(preg_of m) <- v) PC). auto.
  apply nextinstr_set_preg.
Qed.

(** Useful simplification tactic *)

Ltac Simplif :=
  match goal with
  | [ |- nextinstr_nf _ _ = _ ] =>
      ((rewrite nextinstr_nf_inv by auto with asmgen)
       || (rewrite nextinstr_nf_inv1 by auto with asmgen)); auto
  | [ |- nextinstr _ _ = _ ] =>
      ((rewrite nextinstr_inv by auto with asmgen)
       || (rewrite nextinstr_inv1 by auto with asmgen)); auto
  | [ |- Pregmap.get ?x (Pregmap.set ?x _ _) = _ ] =>
      rewrite Pregmap.gss; auto
  | [ |- Pregmap.set ?x _ _ ?x = _ ] =>
      rewrite Pregmap.gss; auto
  | [ |- Pregmap.get _ (Pregmap.set _ _ _) = _ ] =>
      rewrite Pregmap.gso by (auto with asmgen); auto
  | [ |- Pregmap.set _ _ _ _ = _ ] =>
      rewrite Pregmap.gso by (auto with asmgen); auto
  end.

Ltac Simplifs := repeat Simplif.

(** * Correctness of IA32 constructor functions *)

Section CONSTRUCTORS.

Variable ge: genv.
Variable fn: function.

(** Smart constructor for moves. *)

Lemma mk_mov_correct:
  forall rd rs k c rs1 m,
  mk_mov rd rs k = OK c ->
  exists rs2,
     exec_straight ge fn c rs1 m k rs2 m
  /\ rs2#rd = rs1#rs
  /\ forall r, data_preg r = true -> r <> rd -> rs2#r = rs1#r.
Proof.
  unfold mk_mov; intros.
  destruct rd; try (monadInv H); destruct rs; monadInv H.
(* mov *)
  econstructor. split. apply exec_straight_one. simpl. eauto. auto.
  split. Simplifs. intros; Simplifs.
(* movd *)
  econstructor. split. apply exec_straight_one. simpl. eauto. auto.
  split. Simplifs. intros; Simplifs.
Qed.

(** Properties of division *)

Remark divs_mods_exist:
  forall v1 v2,
  match Val.divs v1 v2, Val.mods v1 v2 with
  | Some _, Some _ => True
  | None, None => True
  | _, _ => False
  end.
Proof.
  intros. unfold Val.divs, Val.mods. destruct v1; auto. destruct v2; auto.
  destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); auto.
Qed.

Remark divu_modu_exist:
  forall v1 v2,
  match Val.divu v1 v2, Val.modu v1 v2 with
  | Some _, Some _ => True
  | None, None => True
  | _, _ => False
  end.
Proof.
  intros. unfold Val.divu, Val.modu. destruct v1; auto. destruct v2; auto.
  destruct (Int.eq i0 Int.zero); auto.
Qed.

(** Smart constructor for [shrx] *)

Lemma mk_shrximm_correct:
  forall n k c (rs1: regset) v m,
  mk_shrximm n k = OK c ->
  Val.shrx (rs1#EAX) (Vint n) = Some v ->
  exists rs2,
     exec_straight ge fn c rs1 m k rs2 m
  /\ rs2#EAX = v
  /\ forall r, data_preg r = true -> r <> EAX -> r <> ECX -> rs2#r = rs1#r.
Proof.
  unfold mk_shrximm; intros. inv H.
  exploit Val.shrx_shr; eauto. intros [x [y [A [B C]]]].
  inversion B; clear B; subst y; subst v; clear H0.
  set (tnm1 := Int.sub (Int.shl Int.one n) Int.one).
  set (x' := Int.add x tnm1).
  set (rs2 := nextinstr (compare_ints (Vint x) (Vint Int.zero) rs1 m)).
  set (rs3 := nextinstr (rs2#ECX <- (Vint x'))).
  set (rs4 := nextinstr (if Int.lt x Int.zero then rs3#EAX <- (Vint x') else rs3)).
  set (rs5 := nextinstr_nf (rs4#EAX <- (Val.shr rs4#EAX (Vint n)))).
  assert (rs3#EAX = Vint x). unfold rs3. Simplifs.
  assert (rs3#ECX = Vint x'). unfold rs3. Simplifs.
  exists rs5. split.
  apply exec_straight_step with rs2 m. simpl. rewrite A. simpl. rewrite Int.and_idem. auto. auto.
  apply exec_straight_step with rs3 m. simpl.
  change (rs2 EAX) with (rs1 EAX). rewrite A. simpl.
  rewrite (Int.add_commut Int.zero tnm1). rewrite Int.add_zero. auto. auto.
  apply exec_straight_step with rs4 m. simpl.
  rewrite Int.lt_sub_overflow. unfold rs4. destruct (Int.lt x Int.zero); simpl; auto.
  unfold rs4. destruct (Int.lt x Int.zero); simpl; auto.
  apply exec_straight_one. auto. auto.
  split. unfold rs5. Simplifs. unfold rs4. rewrite nextinstr_inv; auto with asmgen.
  destruct (Int.lt x Int.zero). rewrite Pregmap.gss. rewrite A; auto. rewrite A; rewrite H; auto.
  intros. unfold rs5. Simplifs. unfold rs4. Simplifs.
  transitivity (rs3#r). destruct (Int.lt x Int.zero). Simplifs. auto.
  unfold rs3. Simplifs. unfold rs2. Simplifs.
  unfold compare_ints. Simplifs.
Qed.

(** Smart constructor for integer conversions *)

Lemma mk_intconv_correct:
  forall mk sem rd rs k c rs1 m,
  mk_intconv mk rd rs k = OK c ->
  (forall c rd rs r m,
   exec_instr ge c (mk rd rs) r m = Next (nextinstr (r#rd <- (sem r#rs))) m) ->
  exists rs2,
     exec_straight ge fn c rs1 m k rs2 m
  /\ rs2#rd = sem rs1#rs
  /\ forall r, data_preg r = true -> r <> rd -> r <> EAX -> rs2#r = rs1#r.
Proof.
  unfold mk_intconv; intros. destruct (low_ireg rs); monadInv H.
  econstructor. split. apply exec_straight_one. rewrite H0. eauto. auto.
  split. Simplifs. intros. Simplifs.
  econstructor. split. eapply exec_straight_two.
  simpl. eauto. apply H0. auto. auto.
  split. Simplifs. intros. Simplifs.
Qed.

(** Smart constructor for small stores *)

Lemma addressing_mentions_correct:
  forall a r (rs1 rs2: regset),
  (forall (r': ireg), r' <> r -> rs1 r' = rs2 r') ->
  addressing_mentions a r = false ->
  eval_addrmode ge a rs1 = eval_addrmode ge a rs2.
Proof.
  intros until rs2; intro AG. unfold addressing_mentions, eval_addrmode.
  destruct a. intros. destruct (orb_false_elim _ _ H). unfold proj_sumbool in *.
  decEq. destruct base; auto. apply AG. destruct (ireg_eq r i); congruence.
  decEq. destruct ofs as [[r' sc] | ]; auto. rewrite AG; auto. destruct (ireg_eq r r'); congruence.
Qed.

Lemma mk_smallstore_correct:
  forall chunk sto addr r k c rs1 m1 m2,
  mk_smallstore sto addr r k = OK c ->
  Mem.storev chunk m1 (eval_addrmode ge addr rs1) (rs1 r) = Some m2 ->
  (forall c r addr rs m,
   exec_instr ge c (sto addr r) rs m = exec_store ge chunk m addr rs r nil) ->
  exists rs2,
     exec_straight ge fn c rs1 m1 k rs2 m2
  /\ forall r, data_preg r = true -> r <> EAX /\ r <> ECX -> rs2#r = rs1#r.
Proof.
  unfold mk_smallstore; intros.
  remember (low_ireg r) as low. destruct low.
(* low reg *)
  monadInv H. econstructor; split. apply exec_straight_one. rewrite H1.
  unfold exec_store. rewrite H0. eauto. auto.
  intros; Simplifs.
(* high reg *)
   remember (addressing_mentions addr EAX) as mentions. destruct mentions; monadInv H.
(* EAX is mentioned. *)
  assert (r <> ECX). red; intros; subst r; discriminate.
  set (rs2 := nextinstr (rs1#ECX <- (eval_addrmode ge addr rs1))).
  set (rs3 := nextinstr (rs2#EAX <- (rs1 r))).
  econstructor; split.
  apply exec_straight_three with rs2 m1 rs3 m1.
  simpl. auto.
  simpl. replace (rs2 r) with (rs1 r). auto. symmetry. unfold rs2; Simplifs.
  rewrite H1. unfold exec_store. simpl. rewrite Int.add_zero.
  change (rs3 EAX) with (rs1 r).
  change (rs3 ECX) with (eval_addrmode ge addr rs1).
  replace (Val.add (eval_addrmode ge addr rs1) (Vint Int.zero))
     with (eval_addrmode ge addr rs1).
  rewrite H0. eauto.
  destruct (eval_addrmode ge addr rs1); simpl in H0; try discriminate.
  simpl. rewrite Int.add_zero; auto.
  auto. auto. auto.
  intros. destruct H3. Simplifs. unfold rs3; Simplifs. unfold rs2; Simplifs.
(* EAX is not mentioned *)
  set (rs2 := nextinstr (rs1#EAX <- (rs1 r))).
  econstructor; split.
  apply exec_straight_two with rs2 m1.
  simpl. auto.
  rewrite H1. unfold exec_store.
  rewrite (addressing_mentions_correct addr EAX rs2 rs1); auto.
  change (rs2 EAX) with (rs1 r). rewrite H0. eauto.
  intros. unfold rs2; Simplifs.
  auto. auto.
  intros. destruct H2. simpl. Simplifs. unfold rs2; Simplifs.
Qed.

(** Accessing slots in the stack frame *)

Lemma loadind_correct:
  forall (base: ireg) ofs ty dst k (rs: regset) c m v,
  loadind base ofs ty dst k = OK c ->
  Mem.loadv (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) = Some v ->
  exists rs',
     exec_straight ge fn c rs m k rs' m
  /\ rs'#(preg_of dst) = v
  /\ forall r, data_preg r = true -> r <> preg_of dst -> rs'#r = rs#r.
Proof.
  unfold loadind; intros.
  set (addr := Addrmode (Some base) None (inl (ident * int) ofs)) in *.
  assert (eval_addrmode ge addr rs = Val.add rs#base (Vint ofs)).
    unfold addr. simpl. rewrite Int.add_commut; rewrite Int.add_zero; auto.
  exists (nextinstr_nf (rs#(preg_of dst) <- v)); split.
- destruct ty; try discriminate; destruct (preg_of dst); inv H; simpl in H0;
  apply exec_straight_one; auto; simpl; unfold exec_load; rewrite H1, H0; auto.
- intuition Simplifs.
Qed.

Lemma storeind_correct:
  forall (base: ireg) ofs ty src k (rs: regset) c m m',
  storeind src base ofs ty k = OK c ->
  Mem.storev (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) (rs#(preg_of src)) = Some m' ->
  exists rs',
     exec_straight ge fn c rs m k rs' m'
  /\ forall r, data_preg r = true -> preg_notin r (destroyed_by_setstack ty) -> rs'#r = rs#r.
Proof.
Local Transparent destroyed_by_setstack.
  unfold storeind; intros.
  set (addr := Addrmode (Some base) None (inl (ident * int) ofs)) in *.
  assert (eval_addrmode ge addr rs = Val.add rs#base (Vint ofs)).
    unfold addr. simpl. rewrite Int.add_commut; rewrite Int.add_zero; auto.
  destruct ty; try discriminate; destruct (preg_of src); inv H; simpl in H0;
  (econstructor; split;
  [apply exec_straight_one; [simpl; unfold exec_store; rewrite H1, H0; eauto|auto]
  |simpl; intros; unfold undef_regs; repeat Simplifs]).
Qed.

(** Translation of addressing modes *)

Lemma transl_addressing_mode_correct:
  forall addr args am (rs: regset) v,
  transl_addressing addr args = OK am ->
  eval_addressing ge (rs ESP) addr (List.map rs (List.map preg_of args)) = Some v ->
  Val.lessdef v (eval_addrmode ge am rs).
Proof.
  assert (A: forall n, Int.add Int.zero n = n).
    intros. rewrite Int.add_commut. apply Int.add_zero.
  assert (B: forall n i, (if Int.eq i Int.one then Vint n else Vint (Int.mul n i)) = Vint (Int.mul n i)).
    intros. predSpec Int.eq Int.eq_spec i Int.one.
    subst i. rewrite Int.mul_one. auto. auto.
  assert (C: forall v i,
    Val.lessdef (Val.mul v (Vint i))
               (if Int.eq i Int.one then v else Val.mul v (Vint i))).
    intros. predSpec Int.eq Int.eq_spec i Int.one.
    subst i. destruct v; simpl; auto. rewrite Int.mul_one; auto.
    destruct v; simpl; auto.
  unfold transl_addressing; intros.
  destruct addr; repeat (destruct args; try discriminate); simpl in H0; inv H0.
(* indexed *)
  monadInv H. rewrite (ireg_of_eq _ _ EQ). simpl. rewrite A; auto.
(* indexed2 *)
  monadInv H. rewrite (ireg_of_eq _ _ EQ); rewrite (ireg_of_eq _ _ EQ1). simpl.
  rewrite Val.add_assoc; auto.
(* scaled *)
  monadInv H. rewrite (ireg_of_eq _ _ EQ). unfold eval_addrmode.
  rewrite Val.add_permut. simpl. rewrite A. apply Val.add_lessdef; auto.
(* indexed2scaled *)
  monadInv H. rewrite (ireg_of_eq _ _ EQ); rewrite (ireg_of_eq _ _ EQ1); simpl.
  apply Val.add_lessdef; auto. apply Val.add_lessdef; auto.
(* global *)
  inv H. simpl. unfold Genv.symbol_address.
  destruct (Genv.find_symbol ge i); simpl; auto. repeat rewrite Int.add_zero. auto.
(* based *)
  monadInv H. rewrite (ireg_of_eq _ _ EQ). simpl.
  unfold Genv.symbol_address. destruct (Genv.find_symbol ge i); simpl; auto.
  rewrite Int.add_zero. rewrite Val.add_commut. auto.
(* basedscaled *)
  monadInv H. rewrite (ireg_of_eq _ _ EQ). unfold eval_addrmode.
  rewrite (Val.add_commut Vzero). rewrite Val.add_assoc. rewrite Val.add_permut.
  apply Val.add_lessdef; auto. destruct (rs x); simpl; auto. rewrite B. simpl.
  rewrite Int.add_zero. auto.
(* instack *)
  inv H; simpl. rewrite A; auto.
Qed.

(** Processor conditions and comparisons *)

Lemma compare_ints_spec:
  forall rs v1 v2 m,
  let rs' := nextinstr (compare_ints v1 v2 rs m) in
     rs'#ZF = Val.cmpu (Mem.valid_pointer m) Ceq v1 v2
  /\ rs'#CF = Val.cmpu (Mem.valid_pointer m) Clt v1 v2
  /\ rs'#SF = Val.negative (Val.sub v1 v2)
  /\ rs'#OF = Val.sub_overflow v1 v2
  /\ (forall r, data_preg r = true -> rs'#r = rs#r).
Proof.
  intros. unfold rs'; unfold compare_ints.
  split. auto.
  split. auto.
  split. auto.
  split. auto.
  intros. Simplifs.
Qed.

Lemma int_signed_eq:
  forall x y, Int.eq x y = zeq (Int.signed x) (Int.signed y).
Proof.
  intros. unfold Int.eq. unfold proj_sumbool.
  destruct (zeq (Int.unsigned x) (Int.unsigned y));
  destruct (zeq (Int.signed x) (Int.signed y)); auto.
  elim n. unfold Int.signed. rewrite e; auto.
  elim n. apply Int.eqm_small_eq; auto with ints.
  eapply Int.eqm_trans. apply Int.eqm_sym. apply Int.eqm_signed_unsigned.
  rewrite e. apply Int.eqm_signed_unsigned.
Qed.

Lemma int_not_lt:
  forall x y, negb (Int.lt y x) = (Int.lt x y || Int.eq x y).
Proof.
  intros. unfold Int.lt. rewrite int_signed_eq. unfold proj_sumbool.
  destruct (zlt (Int.signed y) (Int.signed x)).
  rewrite zlt_false. rewrite zeq_false. auto. omega. omega.
  destruct (zeq (Int.signed x) (Int.signed y)).
  rewrite zlt_false. auto. omega.
  rewrite zlt_true. auto. omega.
Qed.

Lemma int_lt_not:
  forall x y, Int.lt y x = negb (Int.lt x y) && negb (Int.eq x y).
Proof.
  intros. rewrite <- negb_orb. rewrite <- int_not_lt. rewrite negb_involutive. auto.
Qed.

Lemma int_not_ltu:
  forall x y, negb (Int.ltu y x) = (Int.ltu x y || Int.eq x y).
Proof.
  intros. unfold Int.ltu, Int.eq.
  destruct (zlt (Int.unsigned y) (Int.unsigned x)).
  rewrite zlt_false. rewrite zeq_false. auto. omega. omega.
  destruct (zeq (Int.unsigned x) (Int.unsigned y)).
  rewrite zlt_false. auto. omega.
  rewrite zlt_true. auto. omega.
Qed.

Lemma int_ltu_not:
  forall x y, Int.ltu y x = negb (Int.ltu x y) && negb (Int.eq x y).
Proof.
  intros. rewrite <- negb_orb. rewrite <- int_not_ltu. rewrite negb_involutive. auto.
Qed.

Lemma testcond_for_signed_comparison_correct:
  forall c v1 v2 rs m b,
  Val.cmp_bool c v1 v2 = Some b ->
  eval_testcond (testcond_for_signed_comparison c)
                (nextinstr (compare_ints v1 v2 rs m)) = Some b.
Proof.
  intros. generalize (compare_ints_spec rs v1 v2 m).
  set (rs' := nextinstr (compare_ints v1 v2 rs m)).
  intros [A [B [C [D E]]]].
  destruct v1; destruct v2; simpl in H; inv H.
  unfold eval_testcond. rewrite A; rewrite B; rewrite C; rewrite D.
  simpl. unfold Val.cmp, Val.cmpu.
  rewrite Int.lt_sub_overflow.
  destruct c; simpl.
  destruct (Int.eq i i0); auto.
  destruct (Int.eq i i0); auto.
  destruct (Int.lt i i0); auto.
  rewrite int_not_lt. destruct (Int.lt i i0); simpl; destruct (Int.eq i i0); auto.
  rewrite (int_lt_not i i0). destruct (Int.lt i i0); destruct (Int.eq i i0); reflexivity.
  destruct (Int.lt i i0); reflexivity.
Qed.

Lemma testcond_for_unsigned_comparison_correct:
  forall c v1 v2 rs m b,
  Val.cmpu_bool (Mem.valid_pointer m) c v1 v2 = Some b ->
  eval_testcond (testcond_for_unsigned_comparison c)
                (nextinstr (compare_ints v1 v2 rs m)) = Some b.
Proof.
  intros. generalize (compare_ints_spec rs v1 v2 m).
  set (rs' := nextinstr (compare_ints v1 v2 rs m)).
  intros [A [B [C [D E]]]].
  unfold eval_testcond. rewrite A; rewrite B. unfold Val.cmpu, Val.cmp.
  destruct v1; destruct v2; simpl in H; inv H.
(* int int *)
  destruct c; simpl; auto.
  destruct (Int.eq i i0); reflexivity.
  destruct (Int.eq i i0); auto.
  destruct (Int.ltu i i0); auto.
  rewrite int_not_ltu. destruct (Int.ltu i i0); simpl; destruct (Int.eq i i0); auto.
  rewrite (int_ltu_not i i0). destruct (Int.ltu i i0); destruct (Int.eq i i0); reflexivity.
  destruct (Int.ltu i i0); reflexivity.
(* int ptr *)
  destruct (Int.eq i Int.zero) eqn:?; try discriminate.
  destruct c; simpl in *; inv H1.
  rewrite Heqb1; reflexivity.
  rewrite Heqb1; reflexivity.
(* ptr int *)
  destruct (Int.eq i0 Int.zero) eqn:?; try discriminate.
  destruct c; simpl in *; inv H1.
  rewrite Heqb1; reflexivity.
  rewrite Heqb1; reflexivity.
(* ptr ptr *)
  simpl.
  fold (Mem.weak_valid_pointer m b0 (Int.unsigned i)) in *.
  fold (Mem.weak_valid_pointer m b1 (Int.unsigned i0)) in *.
  destruct (eq_block b0 b1).
  destruct (Mem.weak_valid_pointer m b0 (Int.unsigned i) &&
            Mem.weak_valid_pointer m b1 (Int.unsigned i0)); inversion H1.
  destruct c; simpl; auto.
  destruct (Int.eq i i0); reflexivity.
  destruct (Int.eq i i0); auto.
  destruct (Int.ltu i i0); auto.
  rewrite int_not_ltu. destruct (Int.ltu i i0); simpl; destruct (Int.eq i i0); auto.
  rewrite (int_ltu_not i i0). destruct (Int.ltu i i0); destruct (Int.eq i i0); reflexivity.
  destruct (Int.ltu i i0); reflexivity.
  destruct (Mem.valid_pointer m b0 (Int.unsigned i) &&
            Mem.valid_pointer m b1 (Int.unsigned i0)); try discriminate.
  destruct c; simpl in *; inv H1; reflexivity.
Qed.

Lemma compare_floats_spec:
  forall rs n1 n2,
  let rs' := nextinstr (compare_floats (Vfloat n1) (Vfloat n2) rs) in
     rs'#ZF = Val.of_bool (negb (Float.cmp Cne n1 n2))
  /\ rs'#CF = Val.of_bool (negb (Float.cmp Cge n1 n2))
  /\ rs'#PF = Val.of_bool (negb (Float.cmp Ceq n1 n2 || Float.cmp Clt n1 n2 || Float.cmp Cgt n1 n2))
  /\ (forall r, data_preg r = true -> rs'#r = rs#r).
Proof.
  intros. unfold rs'; unfold compare_floats.
  split. auto.
  split. auto.
  split. auto.
  intros. Simplifs.
Qed.

Lemma compare_floats32_spec:
  forall rs n1 n2,
  let rs' := nextinstr (compare_floats32 (Vsingle n1) (Vsingle n2) rs) in
     rs'#ZF = Val.of_bool (negb (Float32.cmp Cne n1 n2))
  /\ rs'#CF = Val.of_bool (negb (Float32.cmp Cge n1 n2))
  /\ rs'#PF = Val.of_bool (negb (Float32.cmp Ceq n1 n2 || Float32.cmp Clt n1 n2 || Float32.cmp Cgt n1 n2))
  /\ (forall r, data_preg r = true -> rs'#r = rs#r).
Proof.
  intros. unfold rs'; unfold compare_floats32.
  split. auto.
  split. auto.
  split. auto.
  intros. Simplifs.
Qed.

Definition eval_extcond (xc: extcond) (rs: regset) : option bool :=
  match xc with
  | Cond_base c =>
      eval_testcond c rs
  | Cond_and c1 c2 =>
      match eval_testcond c1 rs, eval_testcond c2 rs with
      | Some b1, Some b2 => Some (b1 && b2)
      | _, _ => None
      end
  | Cond_or c1 c2 =>
      match eval_testcond c1 rs, eval_testcond c2 rs with
      | Some b1, Some b2 => Some (b1 || b2)
      | _, _ => None
      end
  end.

Definition swap_floats {A: Type} (c: comparison) (n1 n2: A) : A :=
  match c with
  | Clt | Cle => n2
  | Ceq | Cne | Cgt | Cge => n1
  end.

Lemma testcond_for_float_comparison_correct:
  forall c n1 n2 rs,
  eval_extcond (testcond_for_condition (Ccompf c))
               (nextinstr (compare_floats (Vfloat (swap_floats c n1 n2))
                                          (Vfloat (swap_floats c n2 n1)) rs)) =
  Some(Float.cmp c n1 n2).
Proof.
  intros.
  generalize (compare_floats_spec rs (swap_floats c n1 n2) (swap_floats c n2 n1)).
  set (rs' := nextinstr (compare_floats (Vfloat (swap_floats c n1 n2))
                                        (Vfloat (swap_floats c n2 n1)) rs)).
  intros [A [B [C D]]].
  unfold eval_extcond, eval_testcond. rewrite A; rewrite B; rewrite C.
  destruct c; simpl.
(* eq *)
  rewrite Float.cmp_ne_eq.
  caseEq (Float.cmp Ceq n1 n2); intros.
  auto.
  simpl. destruct (Float.cmp Clt n1 n2 || Float.cmp Cgt n1 n2); auto.
(* ne *)
  rewrite Float.cmp_ne_eq.
  caseEq (Float.cmp Ceq n1 n2); intros.
  auto.
  simpl. destruct (Float.cmp Clt n1 n2 || Float.cmp Cgt n1 n2); auto.
(* lt *)
  rewrite <- (Float.cmp_swap Cge n1 n2).
  rewrite <- (Float.cmp_swap Cne n1 n2).
  simpl.
  rewrite Float.cmp_ne_eq. rewrite Float.cmp_le_lt_eq.
  caseEq (Float.cmp Clt n1 n2); intros; simpl.
  caseEq (Float.cmp Ceq n1 n2); intros; simpl.
  elimtype False. eapply Float.cmp_lt_eq_false; eauto.
  auto.
  destruct (Float.cmp Ceq n1 n2); auto.
(* le *)
  rewrite <- (Float.cmp_swap Cge n1 n2). simpl.
  destruct (Float.cmp Cle n1 n2); auto.
(* gt *)
  rewrite Float.cmp_ne_eq. rewrite Float.cmp_ge_gt_eq.
  caseEq (Float.cmp Cgt n1 n2); intros; simpl.
  caseEq (Float.cmp Ceq n1 n2); intros; simpl.
  elimtype False. eapply Float.cmp_gt_eq_false; eauto.
  auto.
  destruct (Float.cmp Ceq n1 n2); auto.
(* ge *)
  destruct (Float.cmp Cge n1 n2); auto.
Qed.

Lemma testcond_for_neg_float_comparison_correct:
  forall c n1 n2 rs,
  eval_extcond (testcond_for_condition (Cnotcompf c))
               (nextinstr (compare_floats (Vfloat (swap_floats c n1 n2))
                                          (Vfloat (swap_floats c n2 n1)) rs)) =
  Some(negb(Float.cmp c n1 n2)).
Proof.
  intros.
  generalize (compare_floats_spec rs (swap_floats c n1 n2) (swap_floats c n2 n1)).
  set (rs' := nextinstr (compare_floats (Vfloat (swap_floats c n1 n2))
                                        (Vfloat (swap_floats c n2 n1)) rs)).
  intros [A [B [C D]]].
  unfold eval_extcond, eval_testcond. rewrite A; rewrite B; rewrite C.
  destruct c; simpl.
(* eq *)
  rewrite Float.cmp_ne_eq.
  caseEq (Float.cmp Ceq n1 n2); intros.
  auto.
  simpl. destruct (Float.cmp Clt n1 n2 || Float.cmp Cgt n1 n2); auto.
(* ne *)
  rewrite Float.cmp_ne_eq.
  caseEq (Float.cmp Ceq n1 n2); intros.
  auto.
  simpl. destruct (Float.cmp Clt n1 n2 || Float.cmp Cgt n1 n2); auto.
(* lt *)
  rewrite <- (Float.cmp_swap Cge n1 n2).
  rewrite <- (Float.cmp_swap Cne n1 n2).
  simpl.
  rewrite Float.cmp_ne_eq. rewrite Float.cmp_le_lt_eq.
  caseEq (Float.cmp Clt n1 n2); intros; simpl.
  caseEq (Float.cmp Ceq n1 n2); intros; simpl.
  elimtype False. eapply Float.cmp_lt_eq_false; eauto.
  auto.
  destruct (Float.cmp Ceq n1 n2); auto.
(* le *)
  rewrite <- (Float.cmp_swap Cge n1 n2). simpl.
  destruct (Float.cmp Cle n1 n2); auto.
(* gt *)
  rewrite Float.cmp_ne_eq. rewrite Float.cmp_ge_gt_eq.
  caseEq (Float.cmp Cgt n1 n2); intros; simpl.
  caseEq (Float.cmp Ceq n1 n2); intros; simpl.
  elimtype False. eapply Float.cmp_gt_eq_false; eauto.
  auto.
  destruct (Float.cmp Ceq n1 n2); auto.
(* ge *)
  destruct (Float.cmp Cge n1 n2); auto.
Qed.

Lemma testcond_for_float32_comparison_correct:
  forall c n1 n2 rs,
  eval_extcond (testcond_for_condition (Ccompfs c))
               (nextinstr (compare_floats32 (Vsingle (swap_floats c n1 n2))
                                            (Vsingle (swap_floats c n2 n1)) rs)) =
  Some(Float32.cmp c n1 n2).
Proof.
  intros.
  generalize (compare_floats32_spec rs (swap_floats c n1 n2) (swap_floats c n2 n1)).
  set (rs' := nextinstr (compare_floats32 (Vsingle (swap_floats c n1 n2))
                                        (Vsingle (swap_floats c n2 n1)) rs)).
  intros [A [B [C D]]].
  unfold eval_extcond, eval_testcond. rewrite A; rewrite B; rewrite C.
  destruct c; simpl.
(* eq *)
  rewrite Float32.cmp_ne_eq.
  caseEq (Float32.cmp Ceq n1 n2); intros.
  auto.
  simpl. destruct (Float32.cmp Clt n1 n2 || Float32.cmp Cgt n1 n2); auto.
(* ne *)
  rewrite Float32.cmp_ne_eq.
  caseEq (Float32.cmp Ceq n1 n2); intros.
  auto.
  simpl. destruct (Float32.cmp Clt n1 n2 || Float32.cmp Cgt n1 n2); auto.
(* lt *)
  rewrite <- (Float32.cmp_swap Cge n1 n2).
  rewrite <- (Float32.cmp_swap Cne n1 n2).
  simpl.
  rewrite Float32.cmp_ne_eq. rewrite Float32.cmp_le_lt_eq.
  caseEq (Float32.cmp Clt n1 n2); intros; simpl.
  caseEq (Float32.cmp Ceq n1 n2); intros; simpl.
  elimtype False. eapply Float32.cmp_lt_eq_false; eauto.
  auto.
  destruct (Float32.cmp Ceq n1 n2); auto.
(* le *)
  rewrite <- (Float32.cmp_swap Cge n1 n2). simpl.
  destruct (Float32.cmp Cle n1 n2); auto.
(* gt *)
  rewrite Float32.cmp_ne_eq. rewrite Float32.cmp_ge_gt_eq.
  caseEq (Float32.cmp Cgt n1 n2); intros; simpl.
  caseEq (Float32.cmp Ceq n1 n2); intros; simpl.
  elimtype False. eapply Float32.cmp_gt_eq_false; eauto.
  auto.
  destruct (Float32.cmp Ceq n1 n2); auto.
(* ge *)
  destruct (Float32.cmp Cge n1 n2); auto.
Qed.

Lemma testcond_for_neg_float32_comparison_correct:
  forall c n1 n2 rs,
  eval_extcond (testcond_for_condition (Cnotcompfs c))
               (nextinstr (compare_floats32 (Vsingle (swap_floats c n1 n2))
                                            (Vsingle (swap_floats c n2 n1)) rs)) =
  Some(negb(Float32.cmp c n1 n2)).
Proof.
  intros.
  generalize (compare_floats32_spec rs (swap_floats c n1 n2) (swap_floats c n2 n1)).
  set (rs' := nextinstr (compare_floats32 (Vsingle (swap_floats c n1 n2))
                                          (Vsingle (swap_floats c n2 n1)) rs)).
  intros [A [B [C D]]].
  unfold eval_extcond, eval_testcond. rewrite A; rewrite B; rewrite C.
  destruct c; simpl.
(* eq *)
  rewrite Float32.cmp_ne_eq.
  caseEq (Float32.cmp Ceq n1 n2); intros.
  auto.
  simpl. destruct (Float32.cmp Clt n1 n2 || Float32.cmp Cgt n1 n2); auto.
(* ne *)
  rewrite Float32.cmp_ne_eq.
  caseEq (Float32.cmp Ceq n1 n2); intros.
  auto.
  simpl. destruct (Float32.cmp Clt n1 n2 || Float32.cmp Cgt n1 n2); auto.
(* lt *)
  rewrite <- (Float32.cmp_swap Cge n1 n2).
  rewrite <- (Float32.cmp_swap Cne n1 n2).
  simpl.
  rewrite Float32.cmp_ne_eq. rewrite Float32.cmp_le_lt_eq.
  caseEq (Float32.cmp Clt n1 n2); intros; simpl.
  caseEq (Float32.cmp Ceq n1 n2); intros; simpl.
  elimtype False. eapply Float32.cmp_lt_eq_false; eauto.
  auto.
  destruct (Float32.cmp Ceq n1 n2); auto.
(* le *)
  rewrite <- (Float32.cmp_swap Cge n1 n2). simpl.
  destruct (Float32.cmp Cle n1 n2); auto.
(* gt *)
  rewrite Float32.cmp_ne_eq. rewrite Float32.cmp_ge_gt_eq.
  caseEq (Float32.cmp Cgt n1 n2); intros; simpl.
  caseEq (Float32.cmp Ceq n1 n2); intros; simpl.
  elimtype False. eapply Float32.cmp_gt_eq_false; eauto.
  auto.
  destruct (Float32.cmp Ceq n1 n2); auto.
(* ge *)
  destruct (Float32.cmp Cge n1 n2); auto.
Qed.

Remark swap_floats_commut:
  forall (A B: Type) c (f: A -> B) x y, swap_floats c (f x) (f y) = f (swap_floats c x y).
Proof.
  intros. destruct c; auto.
Qed.

Remark compare_floats_inv:
  forall vx vy rs r,
  r <> CR ZF -> r <> CR CF -> r <> CR PF -> r <> CR SF -> r <> CR OF ->
  compare_floats vx vy rs r = rs r.
Proof.
  intros.
  assert (DFL: undef_regs (CR ZF :: CR CF :: CR PF :: CR SF :: CR OF :: nil) rs r = rs r).
    simpl. Simplifs.
  unfold compare_floats; destruct vx; destruct vy; auto. Simplifs.
Qed.

Remark compare_floats32_inv:
  forall vx vy rs r,
  r <> CR ZF -> r <> CR CF -> r <> CR PF -> r <> CR SF -> r <> CR OF ->
  compare_floats32 vx vy rs r = rs r.
Proof.
  intros.
  assert (DFL: undef_regs (CR ZF :: CR CF :: CR PF :: CR SF :: CR OF :: nil) rs r = rs r).
    simpl. Simplifs.
  unfold compare_floats32; destruct vx; destruct vy; auto. Simplifs.
Qed.

Lemma transl_cond_correct:
  forall cond args k c rs m,
  transl_cond cond args k = OK c ->
  exists rs',
     exec_straight ge fn c rs m k rs' m
  /\ match eval_condition cond (map rs (map preg_of args)) m with
     | None => True
     | Some b => eval_extcond (testcond_for_condition cond) rs' = Some b
     end
  /\ forall r, data_preg r = true -> rs'#r = rs r.
Proof.
  unfold transl_cond; intros.
  destruct cond; repeat (destruct args; try discriminate); monadInv H.
(* comp *)
  simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1).
  econstructor. split. apply exec_straight_one. simpl. eauto. auto.
  split. destruct (Val.cmp_bool c0 (rs x) (rs x0)) eqn:?; auto.
  eapply testcond_for_signed_comparison_correct; eauto.
  intros. unfold compare_ints. Simplifs.
(* compu *)
  simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1).
  econstructor. split. apply exec_straight_one. simpl. eauto. auto.
  split. destruct (Val.cmpu_bool (Mem.valid_pointer m) c0 (rs x) (rs x0)) eqn:?; auto.
  eapply testcond_for_unsigned_comparison_correct; eauto.
  intros. unfold compare_ints. Simplifs.
(* compimm *)
  simpl. rewrite (ireg_of_eq _ _ EQ). destruct (Int.eq_dec i Int.zero).
  econstructor; split. apply exec_straight_one. simpl; eauto. auto.
  split. destruct (rs x); simpl; auto. subst. rewrite Int.and_idem.
  eapply testcond_for_signed_comparison_correct; eauto.
  intros. unfold compare_ints. Simplifs.
  econstructor; split. apply exec_straight_one. simpl; eauto. auto.
  split. destruct (Val.cmp_bool c0 (rs x) (Vint i)) eqn:?; auto.
  eapply testcond_for_signed_comparison_correct; eauto.
  intros. unfold compare_ints. Simplifs.
(* compuimm *)
  simpl. rewrite (ireg_of_eq _ _ EQ).
  econstructor. split. apply exec_straight_one. simpl. eauto. auto.
  split. destruct (Val.cmpu_bool (Mem.valid_pointer m) c0 (rs x) (Vint i)) eqn:?; auto.
  eapply testcond_for_unsigned_comparison_correct; eauto.
  intros. unfold compare_ints. Simplifs.
(* compf *)
  simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1).
  exists (nextinstr (compare_floats (swap_floats c0 (rs x) (rs x0)) (swap_floats c0 (rs x0) (rs x)) rs)).
  split. apply exec_straight_one.
  destruct c0; simpl; auto.
  unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats_inv; auto with asmgen.
  split. destruct (rs x); destruct (rs x0); simpl; auto.
  repeat rewrite swap_floats_commut. apply testcond_for_float_comparison_correct.
  intros. Simplifs. apply compare_floats_inv; auto with asmgen.
(* notcompf *)
  simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1).
  exists (nextinstr (compare_floats (swap_floats c0 (rs x) (rs x0)) (swap_floats c0 (rs x0) (rs x)) rs)).
  split. apply exec_straight_one.
  destruct c0; simpl; auto.
  unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats_inv; auto with asmgen.
  split. destruct (rs x); destruct (rs x0); simpl; auto.
  repeat rewrite swap_floats_commut. apply testcond_for_neg_float_comparison_correct.
  intros. Simplifs. apply compare_floats_inv; auto with asmgen.
(* compfs *)
  simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1).
  exists (nextinstr (compare_floats32 (swap_floats c0 (rs x) (rs x0)) (swap_floats c0 (rs x0) (rs x)) rs)).
  split. apply exec_straight_one.
  destruct c0; simpl; auto.
  unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats32_inv; auto with asmgen.
  split. destruct (rs x); destruct (rs x0); simpl; auto.
  repeat rewrite swap_floats_commut. apply testcond_for_float32_comparison_correct.
  intros. Simplifs. apply compare_floats32_inv; auto with asmgen.
(* notcompfs *)
  simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1).
  exists (nextinstr (compare_floats32 (swap_floats c0 (rs x) (rs x0)) (swap_floats c0 (rs x0) (rs x)) rs)).
  split. apply exec_straight_one.
  destruct c0; simpl; auto.
  unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats32_inv; auto with asmgen.
  split. destruct (rs x); destruct (rs x0); simpl; auto.
  repeat rewrite swap_floats_commut. apply testcond_for_neg_float32_comparison_correct.
  intros. Simplifs. apply compare_floats32_inv; auto with asmgen.
(* maskzero *)
  simpl. rewrite (ireg_of_eq _ _ EQ).
  econstructor. split. apply exec_straight_one. simpl; eauto. auto.
  split. destruct (rs x); simpl; auto.
  generalize (compare_ints_spec rs (Vint (Int.and i0 i)) Vzero m).
  intros [A B]. rewrite A. unfold Val.cmpu; simpl. destruct (Int.eq (Int.and i0 i) Int.zero); auto.
  intros. unfold compare_ints. Simplifs.
(* masknotzero *)
  simpl. rewrite (ireg_of_eq _ _ EQ).
  econstructor. split. apply exec_straight_one. simpl; eauto. auto.
  split. destruct (rs x); simpl; auto.
  generalize (compare_ints_spec rs (Vint (Int.and i0 i)) Vzero m).
  intros [A B]. rewrite A. unfold Val.cmpu; simpl. destruct (Int.eq (Int.and i0 i) Int.zero); auto.
  intros. unfold compare_ints. Simplifs.
Qed.

Remark eval_testcond_nextinstr:
  forall c rs, eval_testcond c (nextinstr rs) = eval_testcond c rs.
Proof.
  intros. unfold eval_testcond. repeat rewrite nextinstr_inv; auto with asmgen.
Qed.

Remark eval_testcond_set_ireg:
  forall c rs r v, eval_testcond c (rs#(IR r) <- v) = eval_testcond c rs.
Proof.
  intros. unfold eval_testcond. repeat rewrite Pregmap.gso; auto with asmgen.
Qed.

Lemma mk_setcc_base_correct:
  forall cond rd k rs1 m,
  exists rs2,
  exec_straight ge fn (mk_setcc_base cond rd k) rs1 m k rs2 m
  /\ rs2#rd = Val.of_optbool(eval_extcond cond rs1)
  /\ forall r, data_preg r = true -> r <> EAX /\ r <> ECX -> r <> rd -> rs2#r = rs1#r.
Proof.
  intros. destruct cond; simpl in *.
- (* base *)
  econstructor; split.
  apply exec_straight_one. simpl; eauto. auto.
  split. Simplifs. intros; Simplifs.
- (* or *)
  assert (Val.of_optbool
    match eval_testcond c1 rs1 with
    | Some b1 =>
        match eval_testcond c2 rs1 with
        | Some b2 => Some (b1 || b2)
        | None => None
        end
    | None => None
    end =
    Val.or (Val.of_optbool (eval_testcond c1 rs1)) (Val.of_optbool (eval_testcond c2 rs1))).
  destruct (eval_testcond c1 rs1). destruct (eval_testcond c2 rs1).
  destruct b; destruct b0; auto.
  destruct b; auto.
  auto.
  rewrite H; clear H.
  destruct (ireg_eq rd EAX).
  subst rd. econstructor; split.
  eapply exec_straight_three.
  simpl; eauto.
  simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. eauto.
  simpl; eauto.
  auto. auto. auto.
  intuition Simplifs.
  econstructor; split.
  eapply exec_straight_three.
  simpl; eauto.
  simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. eauto.
  simpl. eauto.
  auto. auto. auto.
  split. Simplifs. rewrite Val.or_commut. decEq; Simplifs.
  intros. destruct H0; Simplifs.
- (* and *)
  assert (Val.of_optbool
    match eval_testcond c1 rs1 with
    | Some b1 =>
        match eval_testcond c2 rs1 with
        | Some b2 => Some (b1 && b2)
        | None => None
        end
    | None => None
    end =
    Val.and (Val.of_optbool (eval_testcond c1 rs1)) (Val.of_optbool (eval_testcond c2 rs1))).
  {
    destruct (eval_testcond c1 rs1). destruct (eval_testcond c2 rs1).
    destruct b; destruct b0; auto.
    destruct b; auto.
    auto.
  }
  rewrite H; clear H.
  destruct (ireg_eq rd EAX).
  subst rd. econstructor; split.
  eapply exec_straight_three.
  simpl; eauto.
  simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. eauto.
  simpl; eauto.
  auto. auto. auto.
  intuition Simplifs.
  econstructor; split.
  eapply exec_straight_three.
  simpl; eauto.
  simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. eauto.
  simpl. eauto.
  auto. auto. auto.
  split. Simplifs. rewrite Val.and_commut. decEq; Simplifs.
  intros. destruct H0; Simplifs.
Qed.

Lemma mk_setcc_correct:
  forall cond rd k rs1 m,
  exists rs2,
  exec_straight ge fn (mk_setcc cond rd k) rs1 m k rs2 m
  /\ rs2#rd = Val.of_optbool(eval_extcond cond rs1)
  /\ forall r, data_preg r = true -> r <> EAX /\ r <> ECX -> r <> rd -> rs2#r = rs1#r.
Proof.
  intros. unfold mk_setcc. destruct (low_ireg rd).
- apply mk_setcc_base_correct.
- exploit mk_setcc_base_correct. intros [rs2 [A [B C]]].
  econstructor; split. eapply exec_straight_trans. eexact A. apply exec_straight_one.
    simpl. eauto. simpl. auto.
  intuition Simplifs.
Qed.

(** Translation of arithmetic operations. *)

Ltac ArgsInv :=
  match goal with
  | [ H: Error _ = OK _ |- _ ] => discriminate
  | [ H: match ?args with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct args; ArgsInv
  | [ H: bind _ _ = OK _ |- _ ] => monadInv H; ArgsInv
  | [ H: match _ with left _ => _ | right _ => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv
  | [ H: match _ with true => _ | false => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv
  | [ H: ireg_of _ = OK _ |- _ ] => simpl in *; rewrite (ireg_of_eq _ _ H) in *; clear H; ArgsInv
  | [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in *; clear H; ArgsInv
  | _ => idtac
  end.

Ltac TranslOp :=
  econstructor; split;
  [ apply exec_straight_one; [ simpl; eauto | auto ]
  | split; [ Simplifs | intros; Simplifs ]].

Lemma transl_op_correct:
  forall op args res k c (rs: regset) m v,
  transl_op op args res k = OK c ->
  eval_operation ge (rs#ESP) op (map rs (map preg_of args)) m = Some v ->
  exists rs',
     exec_straight ge fn c rs m k rs' m
  /\ Val.lessdef v rs'#(preg_of res)
  /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r.
Proof.
Transparent destroyed_by_op.
  intros until v; intros TR EV.
  assert (SAME:
  (exists rs',
     exec_straight ge fn c rs m k rs' m
  /\ rs'#(preg_of res) = v
  /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r) ->
  exists rs',
     exec_straight ge fn c rs m k rs' m
  /\ Val.lessdef v rs'#(preg_of res)
  /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r).
  {
    intros [rs' [A [B C]]]. subst v. exists rs'; auto.
  }

  destruct op; simpl in TR; ArgsInv; simpl in EV; try (inv EV); try (apply SAME; TranslOp; fail).
(* move *)
  exploit mk_mov_correct; eauto. intros [rs2 [A [B C]]].
  apply SAME. exists rs2. eauto.
(* intconst *)
  apply SAME. destruct (Int.eq_dec i Int.zero). subst i. TranslOp. TranslOp.
(* floatconst *)
  apply SAME. destruct (Float.eq_dec f Float.zero). subst f. TranslOp. TranslOp.
(* singleconst *)
  apply SAME. destruct (Float32.eq_dec f Float32.zero). subst f. TranslOp. TranslOp.
(* cast8signed *)
  apply SAME. eapply mk_intconv_correct; eauto.
(* cast8unsigned *)
  apply SAME. eapply mk_intconv_correct; eauto.
(* cast16signed *)
  apply SAME. eapply mk_intconv_correct; eauto.
(* cast16unsigned *)
  apply SAME. eapply mk_intconv_correct; eauto.
(* mulhs *)
  apply SAME. TranslOp. destruct H1. Simplifs.
(* mulhu *)
  apply SAME. TranslOp. destruct H1. Simplifs.
(* div *)
  apply SAME.
  specialize (divs_mods_exist (rs EAX) (rs ECX)). rewrite H0.
  destruct (Val.mods (rs EAX) (rs ECX)) as [vr|] eqn:?; intros; try contradiction.
  TranslOp. change (rs#EDX<-Vundef ECX) with (rs#ECX). rewrite H0; rewrite Heqo. eauto.
  auto. auto.
  simpl in H3. destruct H3; Simplifs.
(* divu *)
  apply SAME.
  specialize (divu_modu_exist (rs EAX) (rs ECX)). rewrite H0.
  destruct (Val.modu (rs EAX) (rs ECX)) as [vr|] eqn:?; intros; try contradiction.
  TranslOp. change (rs#EDX<-Vundef ECX) with (rs#ECX). rewrite H0; rewrite Heqo. eauto.
  auto. auto.
  simpl in H3. destruct H3; Simplifs.
(* mod *)
  apply SAME.
  specialize (divs_mods_exist (rs EAX) (rs ECX)). rewrite H0.
  destruct (Val.divs (rs EAX) (rs ECX)) as [vr|] eqn:?; intros; try contradiction.
  TranslOp. change (rs#EDX<-Vundef ECX) with (rs#ECX). rewrite H0; rewrite Heqo. eauto.
  auto. auto.
  simpl in H3. destruct H3; Simplifs.
(* modu *)
  apply SAME.
  specialize (divu_modu_exist (rs EAX) (rs ECX)). rewrite H0.
  destruct (Val.divu (rs EAX) (rs ECX)) as [vr|] eqn:?; intros; try contradiction.
  TranslOp. change (rs#EDX<-Vundef ECX) with (rs#ECX). rewrite H0; rewrite Heqo. eauto.
  auto. auto.
  simpl in H3. destruct H3; Simplifs.
(* shrximm *)
  apply SAME. eapply mk_shrximm_correct; eauto.
(* lea *)
  exploit transl_addressing_mode_correct; eauto. intros EA.
  TranslOp. rewrite nextinstr_inv; auto with asmgen. rewrite Pregmap.gss; auto.
(* intoffloat *)
  apply SAME. TranslOp. rewrite H0; auto.
(* floatofint *)
  apply SAME. TranslOp. rewrite H0; auto.
(* intofsingle *)
  apply SAME. TranslOp. rewrite H0; auto.
(* singleofint *)
  apply SAME. TranslOp. rewrite H0; auto.
(* condition *)
  exploit transl_cond_correct; eauto. intros [rs2 [P [Q R]]].
  exploit mk_setcc_correct; eauto. intros [rs3 [S [T U]]].
  exists rs3.
  split. eapply exec_straight_trans. eexact P. eexact S.
  split. rewrite T. destruct (eval_condition c0 rs ## (preg_of ## args) m).
  rewrite Q. auto.
  simpl; auto.
  intros. transitivity (rs2 r); auto.
Qed.

(** Translation of memory loads. *)

Lemma transl_load_correct:
  forall chunk addr args dest k c (rs: regset) m a v,
  transl_load chunk addr args dest k = OK c ->
  eval_addressing ge (rs#ESP) addr (map rs (map preg_of args)) = Some a ->
  Mem.loadv chunk m a = Some v ->
  exists rs',
     exec_straight ge fn c rs m k rs' m
  /\ rs'#(preg_of dest) = v
  /\ forall r, data_preg r = true -> r <> preg_of dest -> rs'#r = rs#r.
Proof.
  unfold transl_load; intros. monadInv H.
  exploit transl_addressing_mode_correct; eauto. intro EA.
  assert (EA': eval_addrmode ge x rs = a). destruct a; simpl in H1; try discriminate; inv EA; auto.
  set (rs2 := nextinstr_nf (rs#(preg_of dest) <- v)).
  assert (exec_load ge chunk m x rs (preg_of dest) = Next rs2 m).
    unfold exec_load. rewrite EA'. rewrite H1. auto.
  assert (rs2 PC = Val.add (rs PC) Vone).
    transitivity (Val.add ((rs#(preg_of dest) <- v) PC) Vone).
    auto. decEq. apply Pregmap.gso; auto with asmgen.
  exists rs2. split.
  destruct chunk; ArgsInv; apply exec_straight_one; auto.
  split. unfold rs2. rewrite nextinstr_nf_inv1. Simplifs. apply preg_of_data.
  intros. unfold rs2. Simplifs.
Qed.

Lemma transl_store_correct:
  forall chunk addr args src k c (rs: regset) m a m',
  transl_store chunk addr args src k = OK c ->
  eval_addressing ge (rs#ESP) addr (map rs (map preg_of args)) = Some a ->
  Mem.storev chunk m a (rs (preg_of src)) = Some m' ->
  exists rs',
     exec_straight ge fn c rs m k rs' m'
  /\ forall r, data_preg r = true -> preg_notin r (destroyed_by_store chunk addr) -> rs'#r = rs#r.
Proof.
  unfold transl_store; intros. monadInv H.
  exploit transl_addressing_mode_correct; eauto. intro EA.
  assert (EA': eval_addrmode ge x rs = a). destruct a; simpl in H1; try discriminate; inv EA; auto.
  rewrite <- EA' in H1. destruct chunk; ArgsInv.
(* int8signed *)
  eapply mk_smallstore_correct; eauto.
  intros. simpl. unfold exec_store.
  destruct (eval_addrmode ge addr0 rs0); simpl; auto. rewrite Mem.store_signed_unsigned_8; auto.
(* int8unsigned *)
  eapply mk_smallstore_correct; eauto.
(* int16signed *)
  econstructor; split.
  apply exec_straight_one. simpl. unfold exec_store.
  replace (Mem.storev Mint16unsigned m (eval_addrmode ge x rs) (rs x0))
     with (Mem.storev Mint16signed m (eval_addrmode ge x rs) (rs x0)).
  rewrite H1. eauto.
  destruct (eval_addrmode ge x rs); simpl; auto. rewrite Mem.store_signed_unsigned_16; auto.
  auto.
  intros. Simplifs.
(* int16unsigned *)
  econstructor; split.
  apply exec_straight_one. simpl. unfold exec_store. rewrite H1. eauto. auto.
  intros. Simplifs.
(* int32 *)
  econstructor; split.
  apply exec_straight_one. simpl. unfold exec_store. rewrite H1. eauto. auto.
  intros. Simplifs.
(* float32 *)
  econstructor; split.
  apply exec_straight_one. simpl. unfold exec_store. rewrite H1. eauto. auto.
  intros. Transparent destroyed_by_store. simpl in H2. simpl. Simplifs.
(* float64 *)
  econstructor; split.
  apply exec_straight_one. simpl. unfold exec_store. rewrite H1. eauto. auto.
  intros. Simplifs.
Qed.

End CONSTRUCTORS.


(*
 * © 2020 Massachusetts Institute of Technology.
 * MIT Proprietary, Subject to FAR52.227-11 Patent Rights - Ownership by the Contractor (May 2014)
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     Eqdep
     List
     Lia.

From SPICY Require Import
     MyPrelude
     Maps
     ChMaps
     Messages
     Keys
     Automation
     Tactics
     Simulation
     SyntacticallySafe
     AdversaryUniverse

     ModelCheck.Commutation
     ModelCheck.InvariantSearch
     ModelCheck.ProtocolFunctions
     ModelCheck.ModelCheck
     ModelCheck.SilentStepElimination
     ModelCheck.SteppingTactics
     ModelCheck.UniverseInversionLemmas
.

From protocols Require Import
     PGP.

From SPICY Require IdealWorld RealWorld.

Import IdealWorld.IdealNotations
       RealWorld.RealWorldNotations
       SimulationAutomation.

Set Implicit Arguments.

Open Scope protocol_scope.

Module PGPProtocolSecure <: AutomatedSafeProtocolSS.

  Import PGPProtocol.

  Definition t__hon := Nat.
  Definition t__adv := Unit.
  Definition b := tt.
  Definition iu0  := ideal_univ_start.
  Definition ru0  := real_univ_start.

  #[export] Hint Unfold t__hon t__adv b ru0 iu0 ideal_univ_start real_univ_start : core.

  Lemma finitelyRuns : exists n, runningTimeMeasure ru0 n.
  Proof.
    autounfold; simpl.
    eexists.
    econstructor; simpl; find_runtime.

    Unshelve.
    all: exact 0.
  Qed.

  Lemma typechecks : syntactically_safe_U ru0.
  Proof.
    unfold syntactically_safe_U; intros.
    autounfold
    ; subst
    ; simpl in *.

    unfold compute_ids; simpl.

    focus_user; simpl
    ; try solve [ do 2 eexists; split
                  ; [ unshelve (repeat typechecks1)
                      ; match goal with
                        | [ |- bool ] => exact true
                        | [ |- list safe_typ ] => exact []
                        end
                    | repeat verify_context_soundness ] ].

    Unshelve.
    all : exact TyDontCare.
  Qed.

  Lemma summarizable : exists summaries, summarize_univ ru0 summaries.
  Proof.
    autounfold; unfold summarize_univ; simpl; intros.
    unshelve (
        eexists; intros; focus_user; simpl
        ; (exists useless_summary; split; [ build_summary |]; eauto using useless_summary_summarizes)
      ) ; exact $0.
  Qed.

  Lemma lameness : @lameAdv t__adv b (RealWorld.adversary ru0).
  Proof.
    unfold lameAdv; autounfold; simpl; eauto.
  Qed.

  Import Gen Tacs.

  Locate safety_inv.

  Set Ltac Profiling.

  Lemma safe_invariant :
    invariantFor
      {| Initial := {(ru0, iu0, true)}; Step := @stepSS t__hon t__adv  |}
      (@noresends_inv t__hon t__adv).
  Proof.
    unfold invariantFor
    ; unfold Initial, Step
    ; intros
    ; simpl in *
    ; split_ors
    ; try contradiction
    ; subst.

    autounfold in H0
    ; unfold fold_left, fst, snd in *.
    unfold real_users, ideal_users, mkrUsr, userProto, userKeys, userId, mkiUsr in *; rwuf.

    time (
        repeat transition_system_step
      ).

    Unshelve.
    all: eauto.
  Qed.

  Show Ltac Profile.

  Lemma U_good : @universe_starts_sane _ Unit b ru0.
  Proof.
    autounfold;
      unfold universe_starts_sane; simpl.
    repeat (apply conj); intros; eauto.
    - focus_user; auto.
    - econstructor.
    - unfold AdversarySafety.keys_honest; rewrite Forall_natmap_forall; intros.
      unfold mkrUsr; simpl.
      rewrite !findUserKeys_add_reduce, findUserKeys_empty_is_empty; eauto.
    - unfold lameAdv; simpl; eauto.
  Qed.

  Lemma universe_starts_safe : universe_ok ru0.
  Proof.
    pose proof (adversary_is_lame_adv_univ_ok_clauses U_good).

    unfold universe_ok
    ; autounfold
    ; simpl
    ; intuition eauto
    .

    - econstructor; eauto.
    - unfold keys_and_permissions_good; solve_simple_maps; intuition eauto.
      solve_simple_maps; eauto.

      rewrite Forall_natmap_forall; intros.

      solve_simple_maps; simpl
      ; unfold permission_heap_good; intros;
        solve_simple_maps; solve_concrete_maps; eauto.

    - unfold user_cipher_queues_ok.
      rewrite Forall_natmap_forall; intros.
      focus_user
      ; simpl in *; econstructor; eauto.

    - unfold honest_nonces_ok, honest_user_nonces_ok, honest_nonces_ok
      ; repeat simple apply conj
      ; intros
      ; clean_map_lookups
      ; intros
      ; focus_user
      ; try contradiction; try discriminate; simpl;
        repeat (apply conj); intros; clean_map_lookups; eauto.

    - unfold honest_users_only_honest_keys; intros.
      focus_user;
        subst;
        simpl in *;
        clean_map_lookups;
        unfold mkrUsr; simpl;
          rewrite !findUserKeys_add_reduce, findUserKeys_empty_is_empty;
          eauto;
          simpl in *;
          solve_concrete_perm_merges;
          solve_concrete_maps;
          solve_simple_maps;
          eauto.
  Qed.
End PGPProtocolSecure.

(* Module ProtoCorrect := SSProtocolSimulates (PGPProtocolSecure). *)
(* Print Assumptions ProtoCorrect.protocol_with_adversary_could_generate_spec. *)


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import CtxtSwitchAux.Spec.
Require Import AbsAccessor.Spec.
Require Import CtxtSwitch.Specs.restore_ns_state.
Require Import CtxtSwitch.LowSpecs.restore_ns_state.
Require Import CtxtSwitch.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       restore_ns_state_sysreg_state_spec
       get_ns_state_spec
       sysreg_write_spec
    .

  Lemma restore_realm_state_spec_exists:
    forall habd habd'  labd
      (Hspec: restore_ns_state_spec  habd = Some habd')
      (Hrel: relate_RData habd labd),
    exists labd', restore_ns_state_spec0  labd = Some labd' /\ relate_RData habd' labd'.
  Proof.
    Local Opaque ptr_eq.
    intros. destruct Hrel.
    unfold restore_ns_state_spec, restore_ns_state_spec0 in *.
    repeat autounfold in *. simpl in *.
    hsimpl_hyp Hspec; inv Hspec; simpl_query_oracle; extract_prop_dec;
      repeat destruct_con; bool_rel; simpl in *; srewrite;
        repeat (simpl_htarget; grewrite; simpl in * ).
    destruct regs_is_int64_dec in *. autounfold in e. repeat rewrite e.
    repeat simpl_update_reg.
    eexists; split. reflexivity. constructor. reflexivity.
    inv C.
  Qed.

End Refine.


Require
  MathClasses.theory.rings MathClasses.categories.varieties.
Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.universal_algebra.

Definition op := False.

Definition sig: Signature := Build_Signature False False (False_rect _).

Definition Laws (_: EqEntailment sig): Prop := False.

Definition theory: EquationalTheory := Build_EquationalTheory sig Laws.

Let carriers := False_rect _: sorts sig → Type.

#[global]
Instance: `{Equiv (carriers a)}.
Proof. intros []. Qed.

#[global]
Instance implementation: AlgebraOps sig carriers := λ o, False_rect _ o.

Global Instance: Algebra sig _.
Proof. constructor; intuition. Qed.

#[global]
Instance variety: InVariety theory carriers.
Proof. constructor; intuition. Qed.

Definition Object := varieties.Object theory.
Definition object: Object := varieties.object theory carriers.


Require Import Coq.Strings.String.
Require Import bedrock2.Syntax.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import coqutil.Map.Interface coqutil.Map.Properties.
Require Import coqutil.Word.Interface coqutil.Word.Properties.
Require Import coqutil.Datatypes.PropSet.
Require Import Coq.Lists.List. (* after SeparationLogic *)
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Translation.Proofs.Equivalence.
Require Import Crypto.Bedrock.Field.Translation.Proofs.UsedVarnames.
Require Import Crypto.Bedrock.Field.Translation.Proofs.VarnameSet.
Require Import Crypto.Bedrock.Field.Common.Tactics.
Require Import Crypto.Bedrock.Field.Common.Util.
Require Import Crypto.Language.API.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.Tactics.DestructHead.

Import API.Compilers.
Import ListNotations Types.Notations.

Section OnlyDiffer.
  Context
    {width BW word mem locals env ext_spec varname_gen error}
   `{parameters_sentinel : @parameters width BW word mem locals env ext_spec varname_gen error}.
  Context {ok : ok}.
  Local Existing Instance Types.rep.Z.

  Lemma equiv_Z_only_differ_iff1
        {listZ : rep.rep base_listZ}
        locals1 locals2 vset (varname : base_ltype base_Z) s x :
    map.only_differ locals1 vset locals2 ->
    disjoint vset (varname_set_base varname) ->
    Lift1Prop.iff1
      (rep.equiv x (rep.rtype_of_ltype varname) s locals1)
      (rep.equiv x (rep.rtype_of_ltype varname) s locals2).
  Proof.
    cbn [varname_set_base
           rep.varname_set rep.equiv rep.rtype_of_ltype rep.Z].
    cbv [WeakestPrecondition.dexpr].
    rewrite <-disjoint_singleton_r_iff by eauto using string_dec.
    split; intros; sepsimpl; subst; eexists; sepsimpl; eauto;
      eapply expr_untouched; eauto using @only_differ_sym with typeclass_instances.
  Qed.

  Lemma equiv_Z_only_differ_undef {listZ:rep.rep base_listZ} :
    forall x y s locals locals' vset,
      map.only_differ locals vset locals' ->
      map.undef_on locals vset ->
      Lift1Prop.impl1
        (equivalent_base (t:=base_Z) x y s locals)
        (equivalent_base x y s locals').
  Proof.
    cbv [equivalent_base rep.equiv rep.Z WeakestPrecondition.dexpr].
    repeat intro; sepsimpl; subst; eexists; sepsimpl; eauto.
    eauto using expr_only_differ_undef.
  Qed.

  Section Local.
    Local Existing Instance rep.listZ_local.

    Lemma equiv_listZ_only_differ_local : forall
          locals1 locals2 vset (varnames : base_ltype base_listZ) s x (mem : mem),
      map.only_differ locals1 vset locals2 ->
      disjoint vset (varname_set_base varnames) ->
      rep.equiv x (rep.rtype_of_ltype varnames) s locals1 mem ->
      rep.equiv x (rep.rtype_of_ltype varnames) s locals2 mem.
    Proof.
      intros *.
      cbn [rep.equiv rep.rtype_of_ltype rep.listZ_local
                     varname_set rep.varname_set].
      rewrite !Forall.Forall2_map_r_iff.
      revert x; induction varnames; intros;
        match goal with H : Forall2 _ _ _ |- _ =>
                        inversion H; subst; clear H end;
        [ solve [eauto] | ].
      cbn [fold_right] in *; cbv [emp] in *. cleanup.
      constructor.
      { eapply equiv_Z_only_differ_iff1;
          cbn [rep.equiv rep.Z]; cbv [emp];
            destruct_head'_and;
            eauto using @only_differ_sym with typeclass_instances.
        cbv [varname_set rep.varname_set rep.Z] in *.
        match goal with H : disjoint _ _ |- _ =>
                        apply disjoint_union_r_iff in H;
                          cleanup
        end. eauto. }
      { apply IHvarnames; eauto.
        match goal with H : disjoint _ _ |- _ =>
                        apply disjoint_union_r_iff in H;
                          cleanup
        end. eauto. }
    Qed.

    Lemma equiv_listZ_only_differ_local_iff1
          locals1 locals2 vset (varnames : base_ltype base_listZ) s x :
      map.only_differ locals1 vset locals2 ->
      disjoint vset (varname_set_base varnames) ->
      Lift1Prop.iff1
        (rep.equiv x (rep.rtype_of_ltype varnames) s locals1)
        (rep.equiv x (rep.rtype_of_ltype varnames) s locals2).
    Proof.
      cbv [Lift1Prop.iff1]; split; intros;
        eapply equiv_listZ_only_differ_local;
        eauto using @only_differ_sym with typeclass_instances.
    Qed.

    Lemma equiv_listZ_only_differ_undef_local :
      forall x y s locals locals' vset,
        map.only_differ locals vset locals' ->
        map.undef_on locals vset ->
        Lift1Prop.impl1
          (equivalent_base (t:=base_listZ) x y s locals)
          (equivalent_base x y s locals').
    Proof.
      cbn [equivalent_base rep.equiv rep.listZ_local]; intros; sepsimpl.
      repeat intro; sepsimpl.
      eapply Forall.Forall2_Proper_impl;
        try eassumption; try reflexivity; repeat intro.
      eapply (equiv_Z_only_differ_undef (listZ:=rep.listZ_local)); eauto.
    Qed.
  End Local.

  Section InMemory.
    Local Existing Instance rep.listZ_mem.

    Lemma equiv_listZ_only_differ_mem
          locals1 locals2 vset (varnames : base_ltype base_listZ) s x :
          forall (mem : mem),
      map.only_differ locals1 vset locals2 ->
      disjoint vset (varname_set_base varnames) ->
      rep.equiv x (rep.rtype_of_ltype varnames) s locals1 mem ->
      rep.equiv x (rep.rtype_of_ltype varnames) s locals2 mem.
    Proof.
      intros *.
      cbn [rep.equiv rep.rtype_of_ltype rep.listZ_mem
                     varname_set rep.varname_set].
      intros.
      repeat match goal with
               H : Lift1Prop.ex1 _ _ |- Lift1Prop.ex1 _ _ =>
               let x := fresh in
               destruct H as [x ?]; exists x
             end.
      eapply Proper_sep_iff1; [ | reflexivity | eassumption ].
      cancel.
      eapply equiv_Z_only_differ_iff1; eauto using @only_differ_sym with typeclass_instances.
    Qed.

    Lemma equiv_listZ_only_differ_mem_iff1
          locals1 locals2 vset (varnames : base_ltype base_listZ) s x :
      map.only_differ locals1 vset locals2 ->
      disjoint vset (varname_set_base varnames) ->
      Lift1Prop.iff1
        (rep.equiv x (rep.rtype_of_ltype varnames) s locals1)
        (rep.equiv x (rep.rtype_of_ltype varnames) s locals2).
    Proof.
      cbv [Lift1Prop.iff1]; split; intros;
        eapply equiv_listZ_only_differ_mem;
        eauto using @only_differ_sym with typeclass_instances.
    Qed.

    Lemma equiv_listZ_only_differ_undef_mem :
      forall x y s locals locals' vset,
        map.only_differ locals vset locals' ->
        map.undef_on locals vset ->
        Lift1Prop.impl1
          (equivalent_base
             (t:=base_listZ) (listZ:=rep.listZ_mem)
             x y s locals)
          (equivalent_base x y s locals').
    Proof.
      cbn [equivalent_base rep.equiv rep.listZ_mem]; intros; sepsimpl.
      repeat intro; sepsimpl. eexists.
      repeat intro; sepsimpl. eexists.
      eapply Proper_sep_impl1; [ | reflexivity | eassumption ].
      repeat intro; sepsimpl; eauto.
      eapply (equiv_Z_only_differ_undef (listZ:=rep.listZ_mem)); eauto.
    Qed.

    Lemma equiv_nil_iff1 y s : forall (locals : locals),
      Lift1Prop.iff1
        (rep.equiv (rep:=rep.listZ_mem) [] y s locals)
        (Lift1Prop.ex1
           (fun x => rep.equiv (rep:=rep.Z) x y tt locals)).
    Proof.
      cbn [rep.equiv rep.listZ_mem rep.Z].
      intro; split; intros;
        repeat match goal with
               | _ => progress subst
               | _ => progress cbn [Array.array map] in *
               | _ => progress sepsimpl
               | H : map _ _ = [] |- _ =>
                 apply map_eq_nil in H
               | _ => rewrite word.of_Z_unsigned in *
               | |- _ /\ _ => split
               | |- Lift1Prop.ex1 _ _ => eexists
               | |- emp _ _ => cbv [emp]
               | _ => solve [apply word.unsigned_range]
               | _ => solve [eauto using map_nil]
               end.
    Qed.

    Lemma varname_set_listonly_listexcl {t} (names : _ t) :
      sameset
        (varname_set_base names)
        (union (varname_set_listonly names)
               (varname_set_listexcl names)).
    Proof.
      induction t;
        cbn [fst snd varname_set_base varname_set_listexcl
                 varname_set_listonly];
        break_match; intros;
          rewrite ?union_empty_l, ?union_empty_r;
          try reflexivity; [ ].
      rewrite IHt1, IHt2.
      clear. firstorder idtac.
    Qed.

    Lemma varname_set_listexcl_subset {t} (names : base_ltype t) :
      subset (varname_set_listexcl names) (varname_set_base names).
    Proof.
      rewrite varname_set_listonly_listexcl.
      clear. firstorder idtac.
    Qed.
  End InMemory.

  Section Generic.
    Context {listZ : rep.rep base_listZ}
            (equiv_listZ_only_differ_undef :
               forall x y s locals1 locals2 vset,
                 map.only_differ locals1 vset locals2 ->
                 map.undef_on locals1 vset ->
                 Lift1Prop.impl1
                   (rep.equiv (rep:=listZ) x y s locals1)
                   (rep.equiv x y s locals2))
            (equiv_listZ_only_differ :
               forall
                 locals1 locals2 vset
                 (varnames : base_ltype base_listZ) s x mem,
                 map.only_differ locals1 vset locals2 ->
                 disjoint vset (varname_set_base varnames) ->
                 rep.equiv x (rep.rtype_of_ltype varnames) s locals1 mem ->
                 rep.equiv x (rep.rtype_of_ltype varnames) s locals2 mem).

    Lemma equivalent_only_differ {t}
          locals1 locals2 vset (varnames : base_ltype t) s x :
      map.only_differ locals1 vset locals2 ->
      disjoint vset (varname_set_base varnames) ->
      forall mem,
        equivalent_base x (base_rtype_of_ltype varnames) s locals1 mem ->
        equivalent_base x (base_rtype_of_ltype varnames) s locals2 mem.
    Proof.
      intros Hdiffer Hexcl.
      induction t;
        cbn [fst snd rtype_of_ltype varname_set_base equivalent_base] in *;
        intros; break_match; destruct_head'_and; try tauto.
      { (* base case *)
        eapply equiv_Z_only_differ_iff1; eauto using @only_differ_sym with typeclass_instances. }
      { (* prod case *)
        match goal with H : disjoint _ (union _ _) |- _ =>
                        apply disjoint_union_r_iff in H
        end.
        cleanup.
        eapply Proper_sep_impl1; [ | | eassumption]; repeat intro; eauto.
        { apply IHt1; eauto. }
        { apply IHt2; eauto. } }
      { (* list case *)
        eapply equiv_listZ_only_differ; eauto. }
    Qed.

    Lemma equivalent_only_differ_iff1 {t}
          locals1 locals2 vset (varnames : base_ltype t) s x :
      map.only_differ locals1 vset locals2 ->
      disjoint vset (varname_set_base varnames) ->
      Lift1Prop.iff1
        (equivalent_base x (base_rtype_of_ltype varnames) s locals1)
        (equivalent_base x (base_rtype_of_ltype varnames) s locals2).
    Proof.
      repeat intro. split; intros.
      all:eapply equivalent_only_differ; eauto using @only_differ_sym with typeclass_instances.
    Qed.

    Lemma equivalent_args_only_differ {t}
          locals1 locals2 vset
          (argnames : type.for_each_lhs_of_arrow ltype t)
          s x :
      map.only_differ locals1 vset locals2 ->
      disjoint vset (varname_set_args argnames) ->
      let argvalues :=
          type.map_for_each_lhs_of_arrow
            rtype_of_ltype argnames in
      forall m,
        equivalent_args x argvalues s locals1 m ->
        equivalent_args x argvalues s locals2 m.
    Proof.
      induction t;
        cbv [Lift1Prop.iff1];
        cbn [fst snd rtype_of_ltype varname_set_args
                 type.map_for_each_lhs_of_arrow
                 equivalent_args];
        intros; break_match; cbn [fst snd] in *;
          try tauto; [ ].
      intros; cleanup; subst.
      repeat match goal with
             | |- _ /\ _ => split
             | |- exists _, _ => eexists
             | _ => solve [eauto]
             end;
        [ eapply Proper_sep_iff1;
          [ eapply equivalent_only_differ_iff1
          | reflexivity | eassumption ] | eapply IHt2 ];
        eauto using @only_differ_sym with typeclass_instances.
      all:match goal with
          | H : disjoint _ (union _ _) |- _ =>
            apply disjoint_union_r_iff in H;
              cleanup; eauto
          end.
    Qed.

    Lemma equivalent_only_differ_undef {t} :
      forall locals1 locals2 vset x y s,
        map.only_differ locals1 vset locals2 ->
        map.undef_on locals1 vset ->
        Lift1Prop.impl1
          (equivalent_base (t:=t) x y s locals1)
          (equivalent_base x y s locals2).
    Proof.
      induction t;
        cbn [equivalent_base];
        break_match; intros; try reflexivity; [ | | ].
      { eapply equiv_Z_only_differ_undef; eauto. }
      { apply Proper_sep_impl1; eauto. }
      { eapply equiv_listZ_only_differ_undef; eauto. }
    Qed.
  End Generic.
End OnlyDiffer.
Global Hint Resolve
     equiv_listZ_only_differ_undef_local
     equiv_listZ_only_differ_undef_mem
     equiv_listZ_only_differ_local
     equiv_listZ_only_differ_mem : equiv.

Section ContextEquivalence.
  Context
    {width BW word mem locals env ext_spec varname_gen error}
   `{parameters_sentinel : @parameters width BW word mem locals env ext_spec varname_gen error}.
  Context {ok : ok}.
  Local Existing Instance Types.rep.Z.

  Section Local.
    Local Existing Instance Types.rep.listZ_local.

    (* 3-way equivalence (for single elements of the context list G
       from wf3 preconditions) *)
    Definition equiv3 {var1}
               (locals : Interface.map.rep (map:=locals))
               (x : {t : API.type
                         & (var1 t * API.interp_type t * ltype t)%type})
      : Prop :=
      match x with
      | existT (type.base b) (w, x, y) =>
        locally_equivalent x (base_rtype_of_ltype y) locals
      | existT (type.arrow _ _) _ => False (* no functions allowed *)
      end.

    Definition context_equiv {var1} G locals
      : Prop := Forall (equiv3 (var1:= var1) locals) G.

    Fixpoint context_varname_set {var1}
             (G : list {t : API.type & (var1 t * API.interp_type t * ltype t)%type})
      : PropSet.set string :=
      match G with
      | (existT (type.base b) (w, x, y)) :: G' =>
        union (varname_set y) (context_varname_set G')
      |  _ => PropSet.empty_set (* no functions allowed *)
      end.

    Lemma varname_set_local x :
      sameset
        (rep.varname_set (rep:=rep.listZ_local) x)
        (of_list x).
    Proof.
      apply sameset_iff.
      cbn [rep.varname_set rep.listZ_local rep.Z].
      induction x; cbn [fold_right of_list In];
        [ solve [firstorder idtac] | ].
      intros. cbv [of_list] in *.
      rewrite <-IHx. firstorder idtac.
    Qed.
  End Local.

  Lemma equivalent_not_in_context {var1} locals1 locals2 vset x :
    map.only_differ locals1 vset locals2 ->
    disjoint vset (@context_varname_set var1 (x :: nil)) ->
    equiv3 locals1 x ->
    equiv3 locals2 x.
  Proof.
    intros; cbv [equiv3 context_varname_set locally_equivalent] in *.
    destruct x as [x [ [? ?] ?] ]; destruct x; [ | tauto ].
    eapply equivalent_only_differ; eauto with equiv.
    match goal with H : _ |- _ =>
                    apply disjoint_union_r_iff in H end.
    cleanup; eauto.
  Qed.

  Lemma equivalent_not_in_context_forall {var1} locals1 locals2 vset G :
    map.only_differ locals1 vset locals2 ->
    disjoint vset (@context_varname_set var1 G) ->
    Forall (equiv3 locals1) G ->
    Forall (equiv3 locals2) G.
  Proof.
    induction G; intros; constructor;
      repeat match goal with
             | _ => progress cbn [context_varname_set equiv3] in *
             | _ => progress break_match_hyps
             | H : disjoint _ (union _ _) |- _ =>
               apply disjoint_union_r_iff in H; cleanup
             | H : Forall _ (_ :: _) |- _ =>
               inversion H; subst; clear H
             | _ => tauto
             | _ => eapply equivalent_only_differ;
                      solve [eauto with equiv]
             end.
  Qed.
End ContextEquivalence.