Require Export CFGinnermost CFGgeneral.

(** * Prerequisites **)

(** ** Definition **)

Definition head_exits_edge `{redCFG} h h' q : Prop
  := (exited h' q /\ ~ loop_contains h' h).

Lemma head_exits_edge_spec :
  forall `{redCFG} h h' q, head_exits_edge h h' q -> exists p, exit_edge h' p q.
Proof.
  intros. unfold head_exits_edge in H0. decide (exited h' q); cbn;eauto.
  decide (exited h' q /\ ~ loop_contains h' h);[|congruence]. destructH. contradiction.
Qed.

Lemma head_exits_edge_spec_iff :
  forall `{redCFG} h h' q, head_exits_edge h h' q <-> (exists p, exit_edge h' p q) /\ ~ loop_contains h' h.
Proof.
  intros. unfold head_exits_edge. decide (exited h' q /\ ~ loop_contains h' h).
  - split;intros;firstorder.
  - split;intros;[congruence|]. simpl_dec' n.
Qed.

Lemma head_exits_path `{redCFG} h p q :
  head_exits_edge h p q -> exists π, Path a_edge__P p q π.
Proof.
  intros. cbn.
  eapply head_exits_edge_spec in H0.
  destructH.
  copy H0 Hexit.
  unfold exit_edge in H0. destructH.
  eapply loop_reachs_member in H1.
  destructH.
  exists (q :: π).
  eapply exit_a_edge in Hexit.
  econstructor;eauto.
Qed.

Lemma head_exits_in_path_head_incl `{redCFG} qh ql π
      (Hπ : Path (edge__P ∪ (head_exits_edge qh)) root ql π)
  : exists ϕ, Path edge__P root ql ϕ /\ forall (h : Lab), loop_contains h ql -> h ∈ ϕ -> h ∈ π.
Proof.
  remember ql as ql'.
  setoid_rewrite Heqql' at 2.
  assert (deq_loop ql' ql) as Hdeq by (subst;eapply deq_loop_refl).
  clear Heqql'.
  revert dependent ql.
  induction Hπ;intros;cbn;eauto.
  - eexists;split;econstructor;eauto. inversion H1;subst;auto. inversion H2.
  - unfold_edge_op' H0. destruct H0.
    + specialize (IHHπ b). exploit IHHπ;[eapply deq_loop_refl|]. destructH.
      exists (c :: ϕ). split;[econstructor;eauto|].
      intros. cbn in H2. destruct H2;eauto.
      eapply Hdeq in H1.
      decide (h = c);[left;auto|].
      eapply preds_in_same_loop in H1;eauto.
    + eapply head_exits_path in H0 as Hψ. destruct Hψ as [ψ Hψ].
      specialize (IHHπ c). exploit IHHπ.
      * eapply head_exits_edge_spec in H0. destructH.
        eapply deq_loop_trans;[eapply deq_loop_exiting;eauto|eapply deq_loop_exited;eauto].
      * destructH.
        eexists. split;[eauto using path_app',subgraph_path'|].
        intros.
        eapply in_app_or in H2. destruct H2.
        -- left.

           eapply head_exits_edge_spec in H0. destructH.
           decide (c = h);[auto|].
           eapply acyclic_parallel_exit_path in Hψ;eauto.
           ++ eapply loop_contains_trans in H1;eauto.
              eapply Hdeq in H1.
              unfold exit_edge in H0. destructH. contradiction.
           ++ destruct Hψ;cbn in *;destruct H2. 1-3: contradiction. auto.
        -- right;eauto using tl_incl. eapply IHHπ1. eapply Hdeq;auto. eapply tl_incl. auto.
Qed.

Lemma head_exits_back_edge `{redCFG} ql qh h :
  ((edge__P ∪ (head_exits_edge h)) ∖ (a_edge__P ∪ (head_exits_edge h))) ql qh <-> ql ↪ qh.
Proof.
  unfold back_edge.
  unfold_edge_op. split;intros.
  - destructH. destruct H1;[eauto|].
    simpl_dec' H2. destructH. contradiction.
  - destructH. split_conj;[left;auto|].
    decide (exited ql qh /\ ~ loop_contains ql h);[|cbn;auto].
    exfalso.
    unfold exited in a.
    destructH' a.
    eapply no_exit_head;eauto.
    exists ql. unfold back_edge;conv_bool. unfold_edge_op. eauto.
    contradict n. destruct n;[contradiction|]. firstorder.
Qed.

Lemma head_exits_no_self_loop `{redCFG} h p q : head_exits_edge h p q -> p <> q.
Proof.
  intros. eapply head_exits_edge_spec in H0.
  destructH.
  unfold exit_edge in H0. destructH.
  eapply loop_contains_loop_head in H1.
  eapply loop_contains_self in H1.
  intro N;subst.
  contradiction.
Qed.

Lemma head_exits_same_connected `{redCFG} h p q π
      (Hpath : Path (a_edge__P ∪ (head_exits_edge h)) p q π)
  : exists ϕ, Path a_edge__P p q ϕ.
Proof.
  induction Hpath;cbn;eauto.
  - eexists. econstructor.
  - destructH. unfold_edge_op' H0. destruct H0.
    + eexists. econstructor;eauto.
    + eapply head_exits_path in H0. destructH.
      eexists; eauto using path_app'.
Qed.

Lemma head_exits_same_connected' `{redCFG} h p q π
      (Hpath : Path (edge__P ∪ (head_exits_edge h)) p q π)
  : exists ϕ, Path edge__P p q ϕ.
Proof.
  induction Hpath;cbn;eauto.
  - eexists. econstructor.
  - destructH. unfold_edge_op' H0. destruct H0.
    + eexists. econstructor;eauto.
    + eapply head_exits_path in H0. destructH.
      eapply subgraph_path' in H0;eauto.
      eexists; eauto using path_app'.
Qed.

(** ** head exits have no influence on loop containment or exits **)

Lemma head_exits_loop_equivalence `{redCFG} qh h p
  : loop_contains h p <-> loop_contains' ((edge__P ∪ (head_exits_edge qh))) (a_edge__P ∪ (head_exits_edge qh)) h p.
Proof.
  split;intros.
  - unfold loop_contains'. unfold loop_contains in H0.
    destructH.
    exists p0, π.
    split_conj.
    + eapply head_exits_back_edge;eauto.
    + clear - H0.
      induction H0;econstructor;eauto. unfold_edge_op. left;auto.
    + auto.
  - copy H0 H0'.
    unfold loop_contains. unfold loop_contains' in H0.
    destructH.
    assert (Path (edge__P ∪ (head_exits_edge qh)) p p0 π -> h ∉ tl (rev π)
            -> loop_contains h p0
            -> exists π0, Path edge__P p p0 π0 /\ h ∉ tl (rev π0)).
    {
      clear. intros.
      induction H0.
      - exists ([a]). split;eauto. econstructor.
      - exploit' IHPath.
        + cbn in *. contradict H1.
          destr_r' π; subst π. 1: inversion H0.
          rewrite rev_rcons. cbn. rewrite rev_rcons in H1. cbn in *.
          eapply in_or_app. left;auto.
        + unfold_edge_op' H3. destruct H3.
          * exploit IHPath.
            {
              eapply preds_in_same_loop;eauto.
              contradict H1. subst.
              cbn. destr_r' π;subst π. 1: inversion H0. rewrite rev_rcons. cbn. eapply in_or_app. right;firstorder.
            }
            destructH.
            exists (c :: π0). split;[econstructor;eauto|].
            contradict IHPath1.
            destr_r' π0;subst π0. 1: inversion IHPath0.
            cbn. rewrite rev_rcons. cbn.
            rewrite <-cons_rcons_assoc in IHPath1.
            rewrite rev_rcons in IHPath1. cbn in *.
            eapply In_rcons in IHPath1. destruct IHPath1;auto.
            subst h. exfalso. contradict H1.
            destr_r' π;subst π. 1: inversion H0.
            cbn. rewrite rev_rcons. cbn. eapply in_or_app. right;firstorder.
          * eapply head_exits_edge_spec in H3 as Hexit. destruct Hexit as [qe Hexit].
            assert (loop_contains h b) as Hloop.
            {
              eapply deq_loop_exiting;eauto.
              eapply deq_loop_exited;eauto.
            }
            exploit IHPath.
            destructH.
            eapply head_exits_path in H3. destructH.
            exists (π1 ++ tl π0).
            split.
            -- eapply subgraph_path' in H3; [eapply path_app'|];eauto.
            -- intro N. rewrite rev_app_distr in N.
               enough (h ∉ rev π1).
               {
                 destr_r' π0;subst π0. 1: inversion IHPath0. rename l into π0.
                 destruct π0;cbn in N;eapply H4;[eapply tl_incl;auto|].
                 cbn in *. rewrite rev_rcons in N,IHPath1.
                 cbn in *.
                 eapply in_app_or in N. destruct N;[exfalso;apply IHPath1|contradiction].
                 eapply in_or_app. left;auto.
               }
               rewrite <-in_rev.
               clear - H3 Hexit H2 Hloop.
               decide (h = c).
               {
                 subst.
                 exfalso.
                 eapply no_exit_head;eauto using loop_contains_loop_head.
               }
               inversion H3;subst.
               ++ cbn. firstorder.
               ++ cbn. simpl_dec. split;[auto|].
                  intro Hin.
                  eapply acyclic_path_stays_in_loop in Hin;auto;cycle 1.
                  ** eauto.
                  ** unfold exit_edge in Hexit. destructH. eapply loop_contains_self.
                     eapply loop_contains_loop_head;eauto.
                  ** eapply a_edge_incl in H1.
                     eapply exit_pred_loop;eauto.
                  ** eapply loop_contains_Antisymmetric in Hin. exploit Hin. subst.
                     unfold exit_edge in Hexit; destructH; contradiction.
    }
    exists p0.
    exploit H2.
    {
      rewrite head_exits_back_edge in H1. eapply loop_contains_ledge;eauto.
    }
    destructH.
    eexists;split;eauto.
    eapply head_exits_back_edge;eauto.
Qed.

Lemma head_exits_exit_edge `{redCFG} qh h p q
      (Hexit : exit_edge' (edge__P ∪ (head_exits_edge qh)) (a_edge__P ∪ (head_exits_edge qh)) h p q)
  : exists p', exit_edge h p' q.
Proof.
  unfold exit_edge' in *. destructH.
  unfold_edge_op' Hexit3.
  destruct Hexit3.
  - exists p. unfold exit_edge. split_conj.
    1,2: rewrite head_exits_loop_equivalence;eauto.
    auto.
  - eapply head_exits_edge_spec in H0.
    destructH. exists p0.
    unfold exit_edge in *. destructH.
    split_conj;eauto.
    + eapply loop_contains_trans;eauto. eapply head_exits_loop_equivalence;eauto.
    + rewrite head_exits_loop_equivalence;eauto.
Qed.

(** * redCFG Instance for the head_exit CFG *)

Instance head_exits_CFG `(redCFG) qh
  : redCFG (fun x y => decision ((edge__P ∪ (head_exits_edge qh)) x y)) root
           (fun x y => decision ((a_edge__P ∪ (head_exits_edge qh)) x y)).
Proof.
econstructor;intros;
  repeat rewrite is_true2_decision in *.
{ (* loop_head_dom *)
  unfold Dom. intros π Hpath.
  rewrite head_exits_back_edge in H0.
  eapply loop_contains_ledge in H0.
  eapply head_exits_in_path_head_incl in Hpath;eauto.
  destructH.
  eapply dom_loop in Hpath0 as Hpath';eauto.
}
{ (* a_edge_incl *)
  eapply union_subgraph.
  - exact a_edge_incl.
  - firstorder.
}
{ (* a_edge_acyclic *)
  unfold acyclic. intros p q π Hedge Hπ. eapply head_exits_same_connected in Hπ. destructH.
  unfold union_edge in Hedge; conv_bool. destruct Hedge as [Hedge|Hedge].
  - eapply a_edge_acyclic; eauto.
  - eapply head_exits_no_self_loop in Hedge as Hnself.
    eapply head_exits_path in Hedge. destructH. eapply path_path_acyclic;eauto.
}
{ (* reachability *)
  specialize a_reachability as H0. eapply subgraph_path in H0;eauto.
  unfold sub_graph,union_edge. firstorder.
}
{ (* single_exit *)
  repeat rewrite is_true2_decision in *.
  fold_lp_cont'.
  assert (loop_contains h p /\ loop_contains h' p) as [Hloop Hloop'].
  {
    unfold exit_edge' in *. do 2 destructH.
    split; eapply head_exits_loop_equivalence; eauto.
  }
  eapply loop_contains_either in Hloop;eauto.
  destruct Hloop.
  - eapply head_exits_exit_edge in H0.
    eapply head_exits_exit_edge in H1.
    do 2 destructH.
    eapply single_exit;eauto.
    unfold exit_edge in *.
    do 2 destructH.
    split;auto.
    eapply loop_contains_trans;eauto.
  - eapply head_exits_exit_edge in H0.
    eapply head_exits_exit_edge in H1.
    do 2 destructH.
    eapply single_exit;cycle 1; eauto.
    unfold exit_edge in *.
    do 2 destructH.
    split;auto.
    eapply loop_contains_trans;eauto.
}
{ (* no_head_exit *)
  repeat rewrite is_true2_decision in *.
  fold_lp_cont'.
  intro N. destructH.
  eapply head_exits_exit_edge in H0. destructH.
  eapply no_exit_head;eauto.
  unfold loop_head.
  exists p0.
  eapply head_exits_back_edge;eauto.
}
{ (* exit_pred_loop *)
  repeat rewrite is_true2_decision in *.
  fold_lp_cont'.
  eapply head_exits_exit_edge in H0. destructH.
  unfold_edge_op' H1.
  destruct H1.
  - copy H1 Hedge. eapply exit_edge_pred_exiting in H1;eauto.
    apply (exit_pred_loop (q:=q)) in H1;eauto.
    rewrite <-head_exits_loop_equivalence;eauto.
  - eapply head_exits_edge_spec in H1.
    destructH.
    copy H0 Hexit.
    unfold exit_edge in H0.
    destructH.
    eapply exit_edge_pred_exiting in H1;eauto.
    eapply single_exit in Hexit;eauto. subst.
    rewrite <-head_exits_loop_equivalence.
    eauto using loop_contains_self, loop_contains_loop_head.
}
{
  intro Heq.
  eapply no_self_loops;eauto. subst. unfold_edge_op' H0.
  unfold toBool in *.
  decide (edge__P p p \/ head_exits_edge qh p p). 2:congruence.
  destruct o;[auto|].
  eapply head_exits_edge_spec in H1. destructH.
  unfold exit_edge in H1. destructH.
  exfalso. contradict H1. eauto using loop_contains_loop_head,loop_contains_self.
}
{
  intro N. eapply root_no_pred.
  unfold toBool in N.
  decide ((edge__P ∪ head_exits_edge qh) p root);[clear N;rename u into N|congruence].
  unfold_edge_op' N. destruct N.
  - eauto.
  - eapply head_exits_edge_spec in H0. destructH. unfold exit_edge in H0.
    exfalso.
    destructH.
    eapply root_no_pred;eauto.
}
Qed.

(** * The head exit property **)

(* We need LOCAL head exits and also a local headexits property, bc
 * otherwise every loop head becomes a loop_split of itself and any exit in the imploded graph *)
Definition head_exits_property `(C : redCFG) qh := forall h p q, exit_edge h p q -> ~ loop_contains h qh
                                                            -> edge__P h q.

Local Arguments exit_edge {_ _ _ _} (_).
Local Arguments edge__P {_ _ _ _} (_).
Local Arguments a_edge__P {_ _ _ _} (_).
Local Arguments loop_contains {_ _ _ _} _.

Lemma head_exits_property_satisfied `(C : redCFG) qh : head_exits_property (head_exits_CFG C qh) qh.
Proof.
  unfold head_exits_property.
  intros h p q Hexit Hloop.
  eapply decision_prop_iff.
  unfold exit_edge in Hexit.
  fold (edge__P (head_exits_CFG C qh)) in Hexit.
  do 2 rewrite <-loop_contains'_basic in Hexit. fold_lp_cont'.
  unfold edge__P,a_edge__P in Hexit. repeat rewrite is_true2_decision in Hexit.
  fold (edge__P C) in Hexit. fold (a_edge__P C) in Hexit.
  eapply head_exits_exit_edge in Hexit.
  destructH.
  right. unfold head_exits_edge.
  split.
  - eexists;eauto.
  - contradict Hloop. rewrite <-loop_contains'_basic.
    unfold edge__P,a_edge__P. repeat rewrite is_true2_decision.
    fold (edge__P C);fold (a_edge__P C).
    eapply head_exits_loop_equivalence. auto.
Qed.

Lemma head_exits_property_a_edge `{C : redCFG} qh
  : head_exits_property C qh -> forall h p q : Lab, exit_edge _ h p q -> ~ loop_contains C h qh -> a_edge h q = true.
Proof.
  intros.
  eapply H in H0 as H2.
  - decide (a_edge h q = true);[auto|exfalso].
    eapply no_exit_head;eauto. unfold loop_head.
    exists h. unfold back_edge. unfold_edge_op. split;auto.
Qed.

(** * Properties of head exit CFGs **)

Local Arguments loop_contains {_ _ _ _} _.

Lemma head_exits_loop_contains_iff `(C : redCFG) (h p q : Lab)
  : loop_contains C h q <-> loop_contains (head_exits_CFG C p) h q.
Proof.
  setoid_rewrite <-loop_contains'_basic at 2.
  unfold edge__P,a_edge__P.
  repeat rewrite is_true2_decision.
  fold (edge__P C);fold (a_edge__P C).
  eapply head_exits_loop_equivalence.
Qed.

Lemma head_exits_deq_loop_inv1 `(C : redCFG) (h p q : Lab)
  : deq_loop (C:=C) p q -> deq_loop (C:=head_exits_CFG C h) p q.
Proof.
  intros.
  unfold deq_loop in *.
  setoid_rewrite <-head_exits_loop_contains_iff.
  eauto.
Qed.

Lemma head_exits_deq_loop_inv2 `(C : redCFG) (h p q : Lab)
  : deq_loop (C:=head_exits_CFG C h) p q -> deq_loop (C:=C) p q.
Proof.
  unfold deq_loop.
  setoid_rewrite <-head_exits_loop_contains_iff.
  eauto.
Qed.

Lemma head_exits_exited_inv1 `(C : redCFG) (qh h p : Lab)
  : exited (C:=C) h p -> exited (C:=head_exits_CFG C qh) h p.
Proof.
  unfold exited, exit_edge.
  setoid_rewrite <-head_exits_loop_contains_iff.
  intros. destructH.
  exists p0. split_conj;eauto.
  eapply decision_prop_iff.
  eapply union_subgraph1;auto.
Qed.

Lemma head_exits_exited_inv2 `(C : redCFG) (qh h p : Lab)
  : exited (C:=head_exits_CFG C qh) h p -> exited (C:=C) h p.
Proof.
  unfold exited, exit_edge.
  setoid_rewrite <-head_exits_loop_contains_iff.
  intros. destructH.
  unfold_edge_op' H3. rewrite is_true2_decision in H3.  destruct H3.
  - exists p0. split_conj;eauto.
  - eapply head_exits_edge_spec in H. destructH. exists p1.
    replace p0 with h in *.
    + unfold exit_edge in H. destructH. split_conj; eauto.
    + eapply exit_edge_unique_diff_head;eauto.
Qed.


From CryptolToCoq Require Import CryptolPrimitivesForSAWCore.
From CryptolToCoq Require Import CryptolPrimitivesForSAWCoreExtra.

From S2N Require Import Embedding.
From S2N Require Import Pointed.

From mathcomp Require Import tuple.

Import CryptolPrimitives.

Definition cry_handshake : Type
  := (seq 32 bool * seq 32 bool).

Record Handshake := MkHandshake
  {
    handshakeType : 32.-tuple bool;
    messageNumber : 32.-tuple bool;
  }.

Global Instance Embedding_Handshake
    : Embedding cry_handshake Handshake :=
    {|
      toAbstract :=
        fun '(a, b) =>
          {|
            handshakeType := toAbstract a; (* Cryptol sorts the fields *)
            messageNumber := toAbstract b;
          |}
      ;
      toConcrete :=
        fun c =>
          ( toConcrete (handshakeType c)
            , toConcrete (messageNumber c)
          )
      ;
    |}.

Global Instance Pointed_Handshake : Pointed Handshake :=
  {|
    pointed :=
      {|
        handshakeType := pointed;
        messageNumber := pointed;
      |};
  |}.


From Relational Require Import OrderEnrichedCategory.

(*In this file we devise a relative monad morphism Id -> M having the unit of M as carrier*)

Section InitialMonad.
  Notation η N := (ord_relmon_unit N).
  Notation dnib N := (ord_relmon_bind N).

(*First we remark that J is a J-relative monad*)
  Context {I C : ord_category}
          {J : ord_functor I C}.

  Program Definition initRmon : ord_relativeMonad J :=
    mkOrdRelativeMonad J _ _ _ _ _ _.
  Next Obligation.
    apply Id.
  Defined.
  Next Obligation.
    cbv. rewrite ord_cat_law2. reflexivity.
  Qed.

(*And J is in fact initial *)
  Context (M : ord_relativeMonad J).

  Definition trivialPhi :
  natIso J (ord_functor_comp J (ord_functor_id C)) :=
    natIso_sym (ord_functor_unit_right J).

  Program Definition etaAsRmm :
  relativeMonadMorphism _ trivialPhi initRmon M :=
    mkRelMonMorph (ord_functor_id C) trivialPhi initRmon M _ _ _.
  Next Obligation.
    apply (η M).
  Defined.
  Next Obligation.
    cbv. rewrite ord_cat_law2. rewrite ord_relmon_law2.
    reflexivity.
  Qed.

End InitialMonad.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.
Require Import Coq.Vectors.Fin.

Require Import Blech.Bishop.
Require Import Blech.Category.
Require Import Blech.Groupoid.
Require Blech.Reflect.

Import CategoryNotations.
Import GroupoidNotations.
Import BishopNotations.

Open Scope category_scope.
Open Scope bishop_scope.

#[local]
Obligation Tactic := Reflect.category_simpl.

(* I need a better name perhaps *)
#[program]
Definition Fin (n: nat): Groupoid := {|
  C := {|
    Obj := t n ;
    Mor A B := (A = B) ;
    Mor_Setoid _ _ := {| equiv _ _ := True |} ;
  |} ;
|}.

Next Obligation.
Proof.
  exists.
  all: exists.
Defined.


(* *********************************************************************)
(*                                                                     *)
(*              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 PPC generation: auxiliary results. *)

Require Import Coqlib.
Require Import Errors.
Require Import Maps.
Require Import AST.
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 Conventions.
Require Import Asmgenproof0.

(** * Properties of low half/high half decomposition *)

Lemma low_high_u:
  forall n, Int.or (Int.shl (high_u n) (Int.repr 16)) (low_u n) = n.
Proof.
  intros. unfold high_u, low_u.
  rewrite Int.shl_rolm. rewrite Int.shru_rolm.
  rewrite Int.rolm_rolm.
  change (Int.modu (Int.add (Int.sub (Int.repr (Z_of_nat Int.wordsize)) (Int.repr 16))
                            (Int.repr 16))
                   (Int.repr (Z_of_nat Int.wordsize)))
    with (Int.zero).
  rewrite Int.rolm_zero. rewrite <- Int.and_or_distrib.
  exact (Int.and_mone n).
  apply int_wordsize_divides_modulus. reflexivity. reflexivity.
Qed.

Lemma low_high_u_xor:
  forall n, Int.xor (Int.shl (high_u n) (Int.repr 16)) (low_u n) = n.
Proof.
  intros. unfold high_u, low_u.
  rewrite Int.shl_rolm. rewrite Int.shru_rolm.
  rewrite Int.rolm_rolm.
  change (Int.modu (Int.add (Int.sub (Int.repr (Z_of_nat Int.wordsize)) (Int.repr 16))
                            (Int.repr 16))
                   (Int.repr (Z_of_nat Int.wordsize)))
    with (Int.zero).
  rewrite Int.rolm_zero. rewrite <- Int.and_xor_distrib.
  exact (Int.and_mone n).
  apply int_wordsize_divides_modulus. reflexivity. reflexivity.
Qed.

Lemma low_high_s:
  forall n, Int.add (Int.shl (high_s n) (Int.repr 16)) (low_s n) = n.
Proof.
  intros.
  rewrite Int.shl_mul_two_p.
  unfold high_s.
  rewrite <- (Int.divu_pow2 (Int.sub n (low_s n)) (Int.repr 65536) (Int.repr 16)).
  2: reflexivity.
  change (two_p (Int.unsigned (Int.repr 16))) with 65536.
  set (x := Int.sub n (low_s n)).
  assert (x = Int.add (Int.mul (Int.divu x (Int.repr 65536)) (Int.repr 65536))
                      (Int.modu x (Int.repr 65536))).
    apply Int.modu_divu_Euclid. vm_compute; congruence.
  assert (Int.modu x (Int.repr 65536) = Int.zero).
    unfold Int.modu, Int.zero. decEq.
    change 0 with (0 mod 65536).
    change (Int.unsigned (Int.repr 65536)) with 65536.
    apply Int.eqmod_mod_eq. omega.
    unfold x, low_s. eapply Int.eqmod_trans.
    apply Int.eqmod_divides with Int.modulus.
    unfold Int.sub. apply Int.eqm_unsigned_repr_l. apply Int.eqm_refl.
    exists 65536. compute; auto.
    replace 0 with (Int.unsigned n - Int.unsigned n) by omega.
    apply Int.eqmod_sub. apply Int.eqmod_refl. apply Int.eqmod_sign_ext'.
    compute; auto.
  rewrite H0 in H. rewrite Int.add_zero in H.
  rewrite <- H. unfold x. rewrite Int.sub_add_opp. rewrite Int.add_assoc.
  rewrite (Int.add_commut (Int.neg (low_s n))). rewrite <- Int.sub_add_opp.
  rewrite Int.sub_idem. apply Int.add_zero.
Qed.

Lemma add_zero_symbol_address:
  forall (ge: genv) id ofs,
  Val.add Vzero (Genv.symbol_address ge id ofs) = Genv.symbol_address ge id ofs.
Proof.
  unfold Genv.symbol_address; intros. destruct (Genv.find_symbol ge id); auto.
  simpl. rewrite Int.add_zero; auto.
Qed.

Lemma low_high_half_zero:
  forall (ge: genv) id ofs,
  Val.add (Val.add Vzero (high_half ge id ofs)) (low_half ge id ofs) =
  Genv.symbol_address ge id ofs.
Proof.
  intros. rewrite Val.add_assoc. rewrite low_high_half. apply add_zero_symbol_address.
Qed.

(** Useful properties of the GPR0 registers. *)

Lemma gpr_or_zero_not_zero:
  forall rs r, r <> GPR0 -> gpr_or_zero rs r = rs#r.
Proof.
  intros. unfold gpr_or_zero. case (ireg_eq r GPR0); tauto.
Qed.
Lemma gpr_or_zero_zero:
  forall rs, gpr_or_zero rs GPR0 = Vzero.
Proof.
  intros. reflexivity.
Qed.
Hint Resolve gpr_or_zero_not_zero gpr_or_zero_zero: asmgen.

Lemma ireg_of_not_GPR0:
  forall m r, ireg_of m = OK r -> IR r <> IR GPR0.
Proof.
  intros. erewrite <- ireg_of_eq; eauto with asmgen.
Qed.
Hint Resolve ireg_of_not_GPR0: asmgen.

Lemma ireg_of_not_GPR0':
  forall m r, ireg_of m = OK r -> r <> GPR0.
Proof.
  intros. generalize (ireg_of_not_GPR0 _ _ H). congruence.
Qed.
Hint Resolve ireg_of_not_GPR0': asmgen.

(** Useful simplification tactic *)

Ltac Simplif :=
  ((rewrite nextinstr_inv by eauto with asmgen)
  || (rewrite nextinstr_inv1 by eauto with asmgen)
  || (rewrite Pregmap.gss)
  || (rewrite nextinstr_pc)
  || (rewrite Pregmap.gso by eauto with asmgen)); auto with asmgen.

Ltac Simpl := repeat Simplif.

(** * Correctness of PowerPC constructor functions *)

Section CONSTRUCTORS.

Variable ge: genv.
Variable fn: function.

(** Properties of comparisons. *)

Lemma compare_float_spec:
  forall rs v1 v2,
  let rs1 := nextinstr (compare_float rs v1 v2) in
     rs1#CR0_0 = Val.cmpf Clt v1 v2
  /\ rs1#CR0_1 = Val.cmpf Cgt v1 v2
  /\ rs1#CR0_2 = Val.cmpf Ceq v1 v2
  /\ forall r', r' <> CR0_0 -> r' <> CR0_1 -> r' <> CR0_2 -> r' <> CR0_3 -> r' <> PC -> rs1#r' = rs#r'.
Proof.
  intros. unfold rs1.
  split. reflexivity.
  split. reflexivity.
  split. reflexivity.
  intros. unfold compare_float. Simpl.
Qed.

Lemma compare_sint_spec:
  forall rs v1 v2,
  let rs1 := nextinstr (compare_sint rs v1 v2) in
     rs1#CR0_0 = Val.cmp Clt v1 v2
  /\ rs1#CR0_1 = Val.cmp Cgt v1 v2
  /\ rs1#CR0_2 = Val.cmp Ceq v1 v2
  /\ forall r', r' <> CR0_0 -> r' <> CR0_1 -> r' <> CR0_2 -> r' <> CR0_3 -> r' <> PC -> rs1#r' = rs#r'.
Proof.
  intros. unfold rs1.
  split. reflexivity.
  split. reflexivity.
  split. reflexivity.
  intros. unfold compare_sint. Simpl.
Qed.

Lemma compare_uint_spec:
  forall rs m v1 v2,
  let rs1 := nextinstr (compare_uint rs m v1 v2) in
     rs1#CR0_0 = Val.cmpu (Mem.valid_pointer m) Clt v1 v2
  /\ rs1#CR0_1 = Val.cmpu (Mem.valid_pointer m) Cgt v1 v2
  /\ rs1#CR0_2 = Val.cmpu (Mem.valid_pointer m) Ceq v1 v2
  /\ forall r', r' <> CR0_0 -> r' <> CR0_1 -> r' <> CR0_2 -> r' <> CR0_3 -> r' <> PC -> rs1#r' = rs#r'.
Proof.
  intros. unfold rs1.
  split. reflexivity.
  split. reflexivity.
  split. reflexivity.
  intros. unfold compare_uint. Simpl.
Qed.

(** Loading a constant. *)

Lemma loadimm_correct:
  forall r n k rs m,
  exists rs',
     exec_straight ge fn (loadimm r n k) rs m  k rs' m
  /\ rs'#r = Vint n
  /\ forall r': preg, r' <> r -> r' <> PC -> rs'#r' = rs#r'.
Proof.
  intros. unfold loadimm.
  case (Int.eq (high_s n) Int.zero).
  (* addi *)
  econstructor; split. apply exec_straight_one. simpl; eauto. auto.
  rewrite Int.add_zero_l. intuition Simpl.
  (* addis *)
  generalize (Int.eq_spec (low_s n) Int.zero); case (Int.eq (low_s n) Int.zero); intro.
  econstructor; split. apply exec_straight_one. simpl; eauto. auto.
  rewrite <- H. rewrite Int.add_commut. rewrite low_high_s.
  intuition Simpl.
  (* addis + ori *)
  econstructor; split. eapply exec_straight_two.
  simpl; eauto. simpl; eauto. auto. auto.
  split. Simpl. rewrite Int.add_zero_l. unfold Val.or. rewrite low_high_u. auto.
  intros; Simpl.
Qed.

(** Add integer immediate. *)

Lemma addimm_correct:
  forall r1 r2 n k rs m,
  r1 <> GPR0 ->
  r2 <> GPR0 ->
  exists rs',
     exec_straight ge fn (addimm r1 r2 n k) rs m  k rs' m
  /\ rs'#r1 = Val.add rs#r2 (Vint n)
  /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'.
Proof.
  intros. unfold addimm.
  (* addi *)
  case (Int.eq (high_s n) Int.zero).
  econstructor; split. apply exec_straight_one.
  simpl. rewrite gpr_or_zero_not_zero; eauto.
  reflexivity.
  intuition Simpl.
  (* addis *)
  generalize (Int.eq_spec (low_s n) Int.zero); case (Int.eq (low_s n) Int.zero); intro.
  econstructor; split. apply exec_straight_one.
  simpl. rewrite gpr_or_zero_not_zero; auto. auto.
  split. Simpl.
  generalize (low_high_s n). rewrite H1. rewrite Int.add_zero. congruence.
  intros; Simpl.
  (* addis + addi *)
  econstructor; split. eapply exec_straight_two.
  simpl. rewrite gpr_or_zero_not_zero; eauto.
  simpl. rewrite gpr_or_zero_not_zero; eauto.
  auto. auto.
  split. Simpl. rewrite Val.add_assoc. simpl. rewrite low_high_s. auto.
  intros; Simpl.
Qed.

(** And integer immediate. *)

Lemma andimm_base_correct:
  forall r1 r2 n k (rs : regset) m,
  r2 <> GPR0 ->
  let v := Val.and rs#r2 (Vint n) in
  exists rs',
     exec_straight ge fn (andimm_base r1 r2 n k) rs m  k rs' m
  /\ rs'#r1 = v
  /\ rs'#CR0_2 = Val.cmp Ceq v Vzero
  /\ forall r', data_preg r' = true -> r' <> r1 -> rs'#r' = rs#r'.
Proof.
  intros. unfold andimm_base.
  case (Int.eq (high_u n) Int.zero).
  (* andi *)
  exists (nextinstr (compare_sint (rs#r1 <- v) v Vzero)).
  generalize (compare_sint_spec (rs#r1 <- v) v Vzero).
  intros [A [B [C D]]].
  split. apply exec_straight_one. reflexivity. reflexivity.
  split. rewrite D; auto with asmgen. Simpl.
  split. auto.
  intros. rewrite D; auto with asmgen. Simpl.
  (* andis *)
  generalize (Int.eq_spec (low_u n) Int.zero);
  case (Int.eq (low_u n) Int.zero); intro.
  exists (nextinstr (compare_sint (rs#r1 <- v) v Vzero)).
  generalize (compare_sint_spec (rs#r1 <- v) v Vzero).
  intros [A [B [C D]]].
  split. apply exec_straight_one. simpl.
  generalize (low_high_u n). rewrite H0. rewrite Int.or_zero.
  intro. rewrite H1. reflexivity. reflexivity.
  split. rewrite D; auto with asmgen. Simpl.
  split. auto.
  intros. rewrite D; auto with asmgen. Simpl.
  (* loadimm + and *)
  generalize (loadimm_correct GPR0 n (Pand_ r1 r2 GPR0 :: k) rs m).
  intros [rs1 [EX1 [RES1 OTHER1]]].
  exists (nextinstr (compare_sint (rs1#r1 <- v) v Vzero)).
  generalize (compare_sint_spec (rs1#r1 <- v) v Vzero).
  intros [A [B [C D]]].
  split. eapply exec_straight_trans. eexact EX1.
  apply exec_straight_one. simpl. rewrite RES1.
  rewrite (OTHER1 r2). reflexivity. congruence. congruence.
  reflexivity.
  split. rewrite D; auto with asmgen. Simpl.
  split. auto.
  intros. rewrite D; auto with asmgen. Simpl.
Qed.

Lemma andimm_correct:
  forall r1 r2 n k (rs : regset) m,
  r2 <> GPR0 ->
  exists rs',
     exec_straight ge fn (andimm r1 r2 n k) rs m  k rs' m
  /\ rs'#r1 = Val.and rs#r2 (Vint n)
  /\ forall r', data_preg r' = true -> r' <> r1 -> rs'#r' = rs#r'.
Proof.
  intros. unfold andimm. destruct (is_rlw_mask n).
  (* turned into rlw *)
  econstructor; split. eapply exec_straight_one.
  simpl. rewrite Val.rolm_zero. eauto. auto.
  intuition Simpl.
  (* andimm_base *)
  destruct (andimm_base_correct r1 r2 n k rs m) as [rs' [A [B [C D]]]]; auto.
  exists rs'; auto.
Qed.

(** Or integer immediate. *)

Lemma orimm_correct:
  forall r1 (r2: ireg) n k (rs : regset) m,
  let v := Val.or rs#r2 (Vint n) in
  exists rs',
     exec_straight ge fn (orimm r1 r2 n k) rs m  k rs' m
  /\ rs'#r1 = v
  /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'.
Proof.
  intros. unfold orimm.
  case (Int.eq (high_u n) Int.zero).
  (* ori *)
  exists (nextinstr (rs#r1 <- v)).
  split. apply exec_straight_one. reflexivity. reflexivity.
  intuition Simpl.
  (* oris *)
  generalize (Int.eq_spec (low_u n) Int.zero);
  case (Int.eq (low_u n) Int.zero); intro.
  exists (nextinstr (rs#r1 <- v)).
  split. apply exec_straight_one. simpl.
  generalize (low_high_u n). rewrite H. rewrite Int.or_zero.
  intro. rewrite H0. reflexivity. reflexivity.
  intuition Simpl.
  (* oris + ori *)
  econstructor; split. eapply exec_straight_two; simpl; reflexivity.
  intuition Simpl.
  rewrite Val.or_assoc. simpl. rewrite low_high_u. reflexivity.
Qed.

(** Xor integer immediate. *)

Lemma xorimm_correct:
  forall r1 (r2: ireg) n k (rs : regset) m,
  let v := Val.xor rs#r2 (Vint n) in
  exists rs',
     exec_straight ge fn (xorimm r1 r2 n k) rs m  k rs' m
  /\ rs'#r1 = v
  /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'.
Proof.
  intros. unfold xorimm.
  case (Int.eq (high_u n) Int.zero).
  (* xori *)
  exists (nextinstr (rs#r1 <- v)).
  split. apply exec_straight_one. reflexivity. reflexivity.
  intuition Simpl.
  (* xoris *)
  generalize (Int.eq_spec (low_u n) Int.zero);
  case (Int.eq (low_u n) Int.zero); intro.
  exists (nextinstr (rs#r1 <- v)).
  split. apply exec_straight_one. simpl.
  generalize (low_high_u n). rewrite H. rewrite Int.or_zero.
  intro. rewrite H0. reflexivity. reflexivity.
  intuition Simpl.
  (* xoris + xori *)
  econstructor; split. eapply exec_straight_two; simpl; reflexivity.
  intuition Simpl.
  rewrite Val.xor_assoc. simpl. rewrite low_high_u_xor. reflexivity.
Qed.

(** Rotate and mask. *)

Lemma rolm_correct:
  forall r1 r2 amount mask k (rs : regset) m,
  r1 <> GPR0 ->
  exists rs',
     exec_straight ge fn (rolm r1 r2 amount mask k) rs m  k rs' m
  /\ rs'#r1 = Val.rolm rs#r2 amount mask
  /\ forall r', data_preg r' = true -> r' <> r1 -> rs'#r' = rs#r'.
Proof.
  intros. unfold rolm. destruct (is_rlw_mask mask).
  (* rlwinm *)
  econstructor; split. eapply exec_straight_one; simpl; eauto.
  intuition Simpl.
  (* rlwinm ; andimm *)
  set (rs1 := nextinstr (rs#r1 <- (Val.rolm rs#r2 amount Int.mone))).
  destruct (andimm_base_correct r1 r1 mask k rs1 m) as [rs' [A [B [C D]]]]; auto.
  exists rs'.
  split. eapply exec_straight_step; eauto. auto. auto.
  split. rewrite B. unfold rs1. rewrite nextinstr_inv; auto with asmgen.
  rewrite Pregmap.gss. destruct (rs r2); simpl; auto.
  unfold Int.rolm. rewrite Int.and_assoc.
  decEq; decEq; decEq. rewrite Int.and_commut. apply Int.and_mone.
  intros. rewrite D; auto. unfold rs1; Simpl.
Qed.

(** Indexed memory loads. *)

Lemma accessind_load_correct:
  forall (A: Type) (inj: A -> preg)
       (instr1: A -> constant -> ireg -> instruction)
       (instr2: A -> ireg -> ireg -> instruction)
       (base: ireg) ofs rx chunk v (rs: regset) m k,
  (forall rs m r1 cst r2,
   exec_instr ge fn (instr1 r1 cst r2) rs m = load1 ge chunk (inj r1) cst r2 rs m) ->
  (forall rs m r1 r2 r3,
   exec_instr ge fn (instr2 r1 r2 r3) rs m = load2 chunk (inj r1) r2 r3 rs m) ->
  Mem.loadv chunk m (Val.add rs#base (Vint ofs)) = Some v ->
  base <> GPR0 -> inj rx <> PC ->
  exists rs',
     exec_straight ge fn (accessind instr1 instr2 base ofs rx k) rs m k rs' m
  /\ rs'#(inj rx) = v
  /\ forall r, r <> PC -> r <> inj rx -> r <> GPR0 -> rs'#r = rs#r.
Proof.
  intros. unfold accessind. destruct (Int.eq (high_s ofs) Int.zero).
- econstructor; split. apply exec_straight_one.
  rewrite H. unfold load1. rewrite gpr_or_zero_not_zero by auto. simpl.
  rewrite H1. eauto. unfold nextinstr. repeat Simplif.
  split. unfold nextinstr. repeat Simplif.
  intros. repeat Simplif.
- exploit (loadimm_correct GPR0 ofs); eauto. intros [rs' [P [Q R]]].
  econstructor; split. eapply exec_straight_trans. eexact P.
  apply exec_straight_one. rewrite H0. unfold load2. rewrite Q, R by auto with asmgen.
  rewrite H1. reflexivity. unfold nextinstr. repeat Simplif.
  split. repeat Simplif.
  intros. repeat Simplif.
Qed.

Lemma loadind_correct:
  forall (base: ireg) ofs ty dst k (rs: regset) m v c,
  loadind base ofs ty dst k = OK c ->
  Mem.loadv (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) = Some v ->
  base <> GPR0 ->
  exists rs',
     exec_straight ge fn c rs m k rs' m
  /\ rs'#(preg_of dst) = v
  /\ forall r, r <> PC -> r <> preg_of dst -> r <> GPR0 -> rs'#r = rs#r.
Proof.
  unfold loadind; intros. destruct ty; try discriminate; destruct (preg_of dst); inv H; simpl in H0.
  apply accessind_load_correct with (inj := IR) (chunk := Mint32); auto with asmgen.
  apply accessind_load_correct with (inj := FR) (chunk := Mfloat64); auto with asmgen.
  apply accessind_load_correct with (inj := FR) (chunk := Mfloat32); auto with asmgen.
  apply accessind_load_correct with (inj := IR) (chunk := Many32); auto with asmgen.
  apply accessind_load_correct with (inj := FR) (chunk := Many64); auto with asmgen.
Qed.

(** Indexed memory stores. *)

Lemma accessind_store_correct:
  forall (A: Type) (inj: A -> preg)
       (instr1: A -> constant -> ireg -> instruction)
       (instr2: A -> ireg -> ireg -> instruction)
       (base: ireg) ofs rx chunk (rs: regset) m m' k,
  (forall rs m r1 cst r2,
   exec_instr ge fn (instr1 r1 cst r2) rs m = store1 ge chunk (inj r1) cst r2 rs m) ->
  (forall rs m r1 r2 r3,
   exec_instr ge fn (instr2 r1 r2 r3) rs m = store2 chunk (inj r1) r2 r3 rs m) ->
  Mem.storev chunk m (Val.add rs#base (Vint ofs)) (rs (inj rx)) = Some m' ->
  base <> GPR0 -> inj rx <> PC -> inj rx <> GPR0 ->
  exists rs',
     exec_straight ge fn (accessind instr1 instr2 base ofs rx k) rs m k rs' m'
  /\ forall r, r <> PC -> r <> GPR0 -> rs'#r = rs#r.
Proof.
  intros. unfold accessind. destruct (Int.eq (high_s ofs) Int.zero).
- econstructor; split. apply exec_straight_one.
  rewrite H. unfold store1. rewrite gpr_or_zero_not_zero by auto. simpl.
  rewrite H1. eauto. unfold nextinstr. repeat Simplif.
  intros. repeat Simplif.
- exploit (loadimm_correct GPR0 ofs); eauto. intros [rs' [P [Q R]]].
  econstructor; split. eapply exec_straight_trans. eexact P.
  apply exec_straight_one. rewrite H0. unfold store2.
  rewrite Q. rewrite R by auto with asmgen. rewrite R by auto.
  rewrite H1. reflexivity. unfold nextinstr. repeat Simplif.
  intros. repeat Simplif.
Qed.

Lemma storeind_correct:
  forall (base: ireg) ofs ty src k (rs: regset) m m' c,
  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' ->
  base <> GPR0 ->
  exists rs',
     exec_straight ge fn c rs m k rs' m'
  /\ forall r, r <> PC -> r <> GPR0 -> rs'#r = rs#r.
Proof.
  unfold storeind; intros.
  assert (preg_of src <> GPR0) by auto with asmgen.
  destruct ty; try discriminate; destruct (preg_of src) ; inv H; simpl in H0.
  apply accessind_store_correct with (inj := IR) (chunk := Mint32); auto with asmgen.
  apply accessind_store_correct with (inj := FR) (chunk := Mfloat64); auto with asmgen.
  apply accessind_store_correct with (inj := FR) (chunk := Mfloat32); auto with asmgen.
  apply accessind_store_correct with (inj := IR) (chunk := Many32); auto with asmgen.
  apply accessind_store_correct with (inj := FR) (chunk := Many64); auto with asmgen.
Qed.

(** Float comparisons. *)

Lemma floatcomp_correct:
  forall cmp (r1 r2: freg) k rs m,
  exists rs',
     exec_straight ge fn (floatcomp cmp r1 r2 k) rs m k rs' m
  /\ rs'#(reg_of_crbit (fst (crbit_for_fcmp cmp))) =
       (if snd (crbit_for_fcmp cmp)
        then Val.cmpf cmp rs#r1 rs#r2
        else Val.notbool (Val.cmpf cmp rs#r1 rs#r2))
  /\ forall r',
       r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 ->
       r' <> CR0_2 -> r' <> CR0_3 -> rs'#r' = rs#r'.
Proof.
  intros.
  generalize (compare_float_spec rs rs#r1 rs#r2).
  intros [A [B [C D]]].
  set (rs1 := nextinstr (compare_float rs rs#r1 rs#r2)) in *.
  assert ((cmp = Ceq \/ cmp = Cne \/ cmp = Clt \/ cmp = Cgt)
          \/ (cmp = Cle \/ cmp = Cge)).
    case cmp; tauto.
  unfold floatcomp.  elim H; intro; clear H.
  exists rs1.
  split. destruct H0 as [EQ|[EQ|[EQ|EQ]]]; subst cmp;
  apply exec_straight_one; reflexivity.
  split.
  destruct H0 as [EQ|[EQ|[EQ|EQ]]]; subst cmp; simpl; auto.
  rewrite Val.negate_cmpf_eq. auto.
  auto.
  (* two instrs *)
  exists (nextinstr (rs1#CR0_3 <- (Val.cmpf cmp rs#r1 rs#r2))).
  split. elim H0; intro; subst cmp.
  apply exec_straight_two with rs1 m.
  reflexivity. simpl.
  rewrite C; rewrite A. rewrite Val.or_commut. rewrite <- Val.cmpf_le.
  reflexivity. reflexivity. reflexivity.
  apply exec_straight_two with rs1 m.
  reflexivity. simpl.
  rewrite C; rewrite B. rewrite Val.or_commut. rewrite <- Val.cmpf_ge.
  reflexivity. reflexivity. reflexivity.
  split. elim H0; intro; subst cmp; simpl.
  reflexivity.
  reflexivity.
  intros. Simpl.
Qed.

(** Translation of conditions. *)

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

Lemma transl_cond_correct_1:
  forall cond args k rs m c,
  transl_cond cond args k = OK c ->
  exists rs',
     exec_straight ge fn c rs m k rs' m
  /\ rs'#(reg_of_crbit (fst (crbit_for_cond cond))) =
       (if snd (crbit_for_cond cond)
        then Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)
        else Val.notbool (Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)))
  /\ forall r, data_preg r = true -> rs'#r = rs#r.
Proof.
  intros.
Opaque Int.eq.
  unfold transl_cond in H; destruct cond; ArgsInv; simpl.
  (* Ccomp *)
  fold (Val.cmp c0 (rs x) (rs x0)).
  destruct (compare_sint_spec rs (rs x) (rs x0)) as [A [B [C D]]].
  econstructor; split.
  apply exec_straight_one. simpl; reflexivity. reflexivity.
  split.
  case c0; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto.
  auto with asmgen.
  (* Ccompu *)
  fold (Val.cmpu (Mem.valid_pointer m) c0 (rs x) (rs x0)).
  destruct (compare_uint_spec rs m (rs x) (rs x0)) as [A [B [C D]]].
  econstructor; split.
  apply exec_straight_one. simpl; reflexivity. reflexivity.
  split.
  case c0; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto.
  auto with asmgen.
  (* Ccompimm *)
  fold (Val.cmp c0 (rs x) (Vint i)).
  destruct (Int.eq (high_s i) Int.zero); inv EQ0.
  destruct (compare_sint_spec rs (rs x) (Vint i)) as [A [B [C D]]].
  econstructor; split.
  apply exec_straight_one. simpl; reflexivity. reflexivity.
  split.
  case c0; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto.
  auto with asmgen.
  destruct (loadimm_correct GPR0 i (Pcmpw x GPR0 :: k) rs m) as [rs1 [EX1 [RES1 OTH1]]].
  destruct (compare_sint_spec rs1 (rs x) (Vint i)) as [A [B [C D]]].
  assert (SAME: rs1 x = rs x) by (apply OTH1; eauto with asmgen).
  exists (nextinstr (compare_sint rs1 (rs1 x) (Vint i))).
  split. eapply exec_straight_trans. eexact EX1.
  apply exec_straight_one. simpl. rewrite RES1; rewrite SAME; auto.
  reflexivity.
  split. rewrite SAME.
  case c0; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto.
  intros. rewrite SAME; rewrite D; auto with asmgen.
  (* Ccompuimm *)
  fold (Val.cmpu (Mem.valid_pointer m) c0 (rs x) (Vint i)).
  destruct (Int.eq (high_u i) Int.zero); inv EQ0.
  destruct (compare_uint_spec rs m (rs x) (Vint i)) as [A [B [C D]]].
  econstructor; split.
  apply exec_straight_one. simpl; reflexivity. reflexivity.
  split.
  case c0; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto.
  auto with asmgen.
  destruct (loadimm_correct GPR0 i (Pcmplw x GPR0 :: k) rs m) as [rs1 [EX1 [RES1 OTH1]]].
  destruct (compare_uint_spec rs1 m (rs x) (Vint i)) as [A [B [C D]]].
  assert (SAME: rs1 x = rs x) by (apply OTH1; eauto with asmgen).
  exists (nextinstr (compare_uint rs1 m (rs1 x) (Vint i))).
  split. eapply exec_straight_trans. eexact EX1.
  apply exec_straight_one. simpl. rewrite RES1; rewrite SAME; auto.
  reflexivity.
  split. rewrite SAME.
  case c0; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto.
  intros. rewrite SAME; rewrite D; auto with asmgen.
  (* Ccompf *)
  fold (Val.cmpf c0 (rs x) (rs x0)).
  destruct (floatcomp_correct c0 x x0 k rs m) as [rs' [EX [RES OTH]]].
  exists rs'. split. auto.
  split. apply RES.
  auto with asmgen.
  (* Cnotcompf *)
  rewrite Val.notbool_negb_3. rewrite Val.notbool_idem4.
  fold (Val.cmpf c0 (rs x) (rs x0)).
  destruct (floatcomp_correct c0 x x0 k rs m) as [rs' [EX [RES OTH]]].
  exists rs'. split. auto.
  split. rewrite RES. destruct (snd (crbit_for_fcmp c0)); auto.
  auto with asmgen.
  (* Cmaskzero *)
  destruct (andimm_base_correct GPR0 x i k rs m) as [rs' [A [B [C D]]]].
  eauto with asmgen.
  exists rs'. split. assumption.
  split. rewrite C. destruct (rs x); auto.
  auto with asmgen.
  (* Cmasknotzero *)
  destruct (andimm_base_correct GPR0 x i k rs m) as [rs' [A [B [C D]]]].
  eauto with asmgen.
  exists rs'. split. assumption.
  split. rewrite C. destruct (rs x); auto.
  fold (option_map negb (Some (Int.eq (Int.and i0 i) Int.zero))).
  rewrite Val.notbool_negb_3. rewrite Val.notbool_idem4. auto.
  auto with asmgen.
Qed.

Lemma transl_cond_correct_2:
  forall cond args k rs m b c,
  transl_cond cond args k = OK c ->
  eval_condition cond (map rs (map preg_of args)) m = Some b ->
  exists rs',
     exec_straight ge fn c rs m k rs' m
  /\ rs'#(reg_of_crbit (fst (crbit_for_cond cond))) =
       (if snd (crbit_for_cond cond)
        then Val.of_bool b
        else Val.notbool (Val.of_bool b))
  /\ forall r, data_preg r = true -> rs'#r = rs#r.
Proof.
  intros.
  replace (Val.of_bool b)
  with (Val.of_optbool (eval_condition cond rs ## (preg_of ## args) m)).
  eapply transl_cond_correct_1; eauto.
  rewrite H0; auto.
Qed.

Lemma transl_cond_correct_3:
  forall cond args k ms sp rs m b m' c,
  transl_cond cond args k = OK c ->
  agree ms sp rs ->
  eval_condition cond (map ms args) m = Some b ->
  Mem.extends m m' ->
  exists rs',
     exec_straight ge fn c rs m' k rs' m'
  /\ rs'#(reg_of_crbit (fst (crbit_for_cond cond))) =
       (if snd (crbit_for_cond cond)
        then Val.of_bool b
        else Val.notbool (Val.of_bool b))
  /\ agree ms sp rs'.
Proof.
  intros.
  exploit transl_cond_correct_2. eauto.
    eapply eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto.
  intros [rs' [A [B C]]].
  exists rs'; split. eauto. split. auto. apply agree_exten with rs; auto.
Qed.

(** Translation of condition operators *)

Remark add_carry_eq0:
  forall i,
  Vint (Int.add (Int.add (Int.sub Int.zero i) i)
                (Int.add_carry Int.zero (Int.xor i Int.mone) Int.one)) =
  Val.of_bool (Int.eq i Int.zero).
Proof.
  intros. rewrite <- Int.sub_add_l. rewrite Int.add_zero_l.
  rewrite Int.sub_idem. rewrite Int.add_zero_l. fold (Int.not i).
  predSpec Int.eq Int.eq_spec i Int.zero.
  subst i. reflexivity.
  unfold Val.of_bool, Vfalse. decEq.
  unfold Int.add_carry. rewrite Int.unsigned_zero. rewrite Int.unsigned_one.
  apply zlt_true.
  generalize (Int.unsigned_range (Int.not i)); intro.
  assert (Int.unsigned (Int.not i) <> Int.modulus - 1).
    red; intros.
    assert (Int.repr (Int.unsigned (Int.not i)) = Int.mone).
Local Transparent Int.repr.
      rewrite H1. apply Int.mkint_eq. reflexivity.
   rewrite Int.repr_unsigned in H2.
   assert (Int.not (Int.not i) = Int.zero).
   rewrite H2. apply Int.mkint_eq; reflexivity.
  rewrite Int.not_involutive in H3.
  congruence.
  omega.
Qed.

Remark add_carry_ne0:
  forall i,
  Vint (Int.add (Int.add i (Int.xor (Int.add i Int.mone) Int.mone))
                (Int.add_carry i Int.mone Int.zero)) =
  Val.of_bool (negb (Int.eq i Int.zero)).
Proof.
  intros. fold (Int.not (Int.add i Int.mone)). rewrite Int.not_neg.
  rewrite (Int.add_commut  (Int.neg (Int.add i Int.mone))).
  rewrite <- Int.sub_add_opp. rewrite Int.sub_add_r. rewrite Int.sub_idem.
  rewrite Int.add_zero_l. rewrite Int.add_neg_zero. rewrite Int.add_zero_l.
Transparent Int.eq.
  unfold Int.add_carry, Int.eq.
  rewrite Int.unsigned_zero.  rewrite Int.unsigned_mone.
  unfold negb, Val.of_bool, Vtrue, Vfalse.
  destruct (zeq (Int.unsigned i) 0); decEq.
  apply zlt_true. omega.
  apply zlt_false. generalize (Int.unsigned_range i). omega.
Qed.

Lemma transl_cond_op_correct:
  forall cond args r k rs m c,
  transl_cond_op cond args r k = OK c ->
  exists rs',
     exec_straight ge fn c rs m k rs' m
  /\ rs'#(preg_of r) = Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)
  /\ forall r', data_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r'.
Proof.
  intros until args. unfold transl_cond_op.
  destruct (classify_condition cond args); intros; monadInv H; simpl;
  erewrite ! ireg_of_eq; eauto.
(* eq 0 *)
  econstructor; split.
  eapply exec_straight_two; simpl; reflexivity.
  split. Simpl. destruct (rs x0); simpl; auto.
  apply add_carry_eq0.
  intros; Simpl.
(* ne 0 *)
  econstructor; split.
  eapply exec_straight_two; simpl; reflexivity.
  rewrite gpr_or_zero_not_zero; eauto with asmgen.
  split. Simpl. destruct (rs x0); simpl; auto.
  apply add_carry_ne0.
  intros; Simpl.
(* ge 0 *)
  econstructor; split.
  eapply exec_straight_two; simpl; reflexivity.
  split. Simpl. rewrite Val.rolm_ge_zero. auto.
  intros; Simpl.
(* lt 0 *)
  econstructor; split.
  apply exec_straight_one; simpl; reflexivity.
  split. Simpl. rewrite Val.rolm_lt_zero. auto.
  intros; Simpl.
(* default *)
  set (bit := fst (crbit_for_cond c)) in *.
  set (isset := snd (crbit_for_cond c)) in *.
  set (k1 :=
        Pmfcrbit x bit ::
        (if isset
         then k
         else Pxori x x (Cint Int.one) :: k)).
  generalize (transl_cond_correct_1 c rl k1 rs m c0 EQ0).
  fold bit; fold isset.
  intros [rs1 [EX1 [RES1 AG1]]].
  destruct isset.
  (* bit set *)
  econstructor; split.  eapply exec_straight_trans. eexact EX1.
  unfold k1. apply exec_straight_one; simpl; reflexivity.
  intuition Simpl.
  (* bit clear *)
  econstructor; split.  eapply exec_straight_trans. eexact EX1.
  unfold k1. eapply exec_straight_two; simpl; reflexivity.
  intuition Simpl.
  rewrite RES1. destruct (eval_condition c rs ## (preg_of ## rl) m). destruct b; auto. auto.
Qed.

(** Translation of arithmetic operations. *)

Ltac TranslOpSimpl :=
  econstructor; split;
  [ apply exec_straight_one; [simpl; eauto | reflexivity]
  | split; intros; Simpl; fail ].

Lemma transl_op_correct_aux:
  forall op args res k (rs: regset) m v c,
  transl_op op args res k = OK c ->
  eval_operation ge (rs#GPR1) op (map rs (map preg_of args)) m = Some v ->
  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.
Proof.
Opaque Int.eq.
  intros. unfold transl_op in H; destruct op; ArgsInv; simpl in H0; try (inv H0); try TranslOpSimpl.
  (* Omove *)
  destruct (preg_of res) eqn:RES; destruct (preg_of m0) eqn:ARG; inv H.
  TranslOpSimpl.
  TranslOpSimpl.
  (* Ointconst *)
  destruct (loadimm_correct x i k rs m) as [rs' [A [B C]]].
  exists rs'. auto with asmgen.
  (* Oaddrsymbol *)
  set (v' := Genv.symbol_address ge i i0).
  destruct (symbol_is_small_data i i0) eqn:SD; [ | destruct (symbol_is_rel_data i i0) ].
  (* small data *)
Opaque Val.add.
  econstructor; split. apply exec_straight_one; simpl; reflexivity.
  split. Simpl. rewrite small_data_area_addressing by auto. apply add_zero_symbol_address.
  intros; Simpl.
  (* relative data *)
  econstructor; split. eapply exec_straight_two; simpl; reflexivity.
  split. Simpl. rewrite gpr_or_zero_not_zero by eauto with asmgen. Simpl.
  apply low_high_half_zero.
  intros; Simpl.
  (* absolute data *)
  econstructor; split. eapply exec_straight_two; simpl; reflexivity.
  split. Simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen. Simpl.
  apply low_high_half_zero.
  intros; Simpl.
  (* Oaddrstack *)
  destruct (addimm_correct x GPR1 i k rs m) as [rs' [EX [RES OTH]]]; eauto with asmgen.
  exists rs'; auto with asmgen.
  (* Oaddimm *)
  destruct (addimm_correct x0 x i k rs m) as [rs' [A [B C]]]; eauto with asmgen.
  exists rs'; auto with asmgen.
  (* Oaddsymbol *)
  destruct (symbol_is_small_data i i0) eqn:SD; [ | destruct (symbol_is_rel_data i i0) ].
  (* small data *)
  econstructor; split. eapply exec_straight_two; simpl; reflexivity.
  split. Simpl. rewrite (Val.add_commut (rs x)). f_equal.
  rewrite small_data_area_addressing by auto. apply add_zero_symbol_address.
  intros; Simpl.
  (* relative data *)
  econstructor; split. eapply exec_straight_trans.
  eapply exec_straight_two; simpl; reflexivity.
  eapply exec_straight_two; simpl; reflexivity.
  split. assert (GPR0 <> x0) by (apply sym_not_equal; eauto with asmgen).
  Simpl. rewrite ! gpr_or_zero_zero. rewrite ! gpr_or_zero_not_zero by eauto with asmgen. Simpl.
  rewrite low_high_half_zero. auto.
  intros; Simpl.
  (* absolute data *)
  econstructor; split. eapply exec_straight_two; simpl; reflexivity.
  split. Simpl. rewrite ! gpr_or_zero_not_zero by (eauto with asmgen). Simpl.
  rewrite Val.add_assoc. rewrite (Val.add_commut (rs x)). rewrite low_high_half. auto.
  intros; Simpl.
  (* Osubimm *)
  case (Int.eq (high_s i) Int.zero).
  TranslOpSimpl.
  destruct (loadimm_correct GPR0 i (Psubfc x0 x GPR0 :: k) rs m) as [rs1 [EX [RES OTH]]].
  econstructor; split.
  eapply exec_straight_trans. eexact EX. apply exec_straight_one; simpl; reflexivity.
  split. Simpl. rewrite RES. rewrite OTH; eauto with asmgen.
  intros; Simpl.
  (* Omulimm *)
  case (Int.eq (high_s i) Int.zero).
  TranslOpSimpl.
  destruct (loadimm_correct GPR0 i (Pmullw x0 x GPR0 :: k) rs m) as [rs1 [EX [RES OTH]]].
  econstructor; split.
  eapply exec_straight_trans. eexact EX. apply exec_straight_one; simpl; reflexivity.
  split. Simpl. rewrite RES. rewrite OTH; eauto with asmgen.
  intros; Simpl.
  (* Odivs *)
  replace v with (Val.maketotal (Val.divs (rs x) (rs x0))).
  TranslOpSimpl.
  rewrite H1; auto.
  (* Odivu *)
  replace v with (Val.maketotal (Val.divu (rs x) (rs x0))).
  TranslOpSimpl.
  rewrite H1; auto.
  (* Oand *)
  set (v' := Val.and (rs x) (rs x0)) in *.
  pose (rs1 := rs#x1 <- v').
  destruct (compare_sint_spec rs1 v' Vzero) as [A [B [C D]]].
  econstructor; split. apply exec_straight_one; simpl; reflexivity.
  split. rewrite D; auto with asmgen. unfold rs1; Simpl.
  intros. rewrite D; auto with asmgen. unfold rs1; Simpl.
  (* Oandimm *)
  destruct (andimm_correct x0 x i k rs m) as [rs' [A [B C]]]; eauto with asmgen.
  (* Oorimm *)
  destruct (orimm_correct x0 x i k rs m) as [rs' [A [B C]]].
  exists rs'; auto with asmgen.
  (* Oxorimm *)
  destruct (xorimm_correct x0 x i k rs m) as [rs' [A [B C]]].
  exists rs'; auto with asmgen.
  (* Onor *)
  replace (Val.notint (rs x))
     with (Val.notint (Val.or (rs x) (rs x))).
  TranslOpSimpl.
  destruct (rs x); simpl; auto. rewrite Int.or_idem. auto.
  (* Oshrximm *)
  econstructor; split.
  eapply exec_straight_two; simpl; reflexivity.
  split. Simpl. apply Val.shrx_carry. auto.
  intros; Simpl.
  (* Orolm *)
  destruct (rolm_correct x0 x i i0 k rs m) as [rs' [A [B C]]]; eauto with asmgen.
  (* Ointoffloat *)
  replace v with (Val.maketotal (Val.intoffloat (rs x))).
  TranslOpSimpl.
  rewrite H1; auto.
  (* Ointuoffloat *)
  replace v with (Val.maketotal (Val.intuoffloat (rs x))).
  TranslOpSimpl.
  rewrite H1; auto.
  (* Ofloatofint *)
  replace v with (Val.maketotal (Val.floatofint (rs x))).
  TranslOpSimpl.
  rewrite H1; auto.
  (* Ofloatofintu *)
  replace v with (Val.maketotal (Val.floatofintu (rs x))).
  TranslOpSimpl.
  rewrite H1; auto.
  (* Ocmp *)
  destruct (transl_cond_op_correct c0 args res k rs m c) as [rs' [A [B C]]]; auto.
  exists rs'; auto with asmgen.
Qed.

Lemma transl_op_correct:
  forall op args res k ms sp rs m v m' c,
  transl_op op args res k = OK c ->
  agree ms sp rs ->
  eval_operation ge sp op (map ms args) m = Some v ->
  Mem.extends m m' ->
  exists rs',
     exec_straight ge fn c rs m' k rs' m'
  /\ agree (Regmap.set res v (Mach.undef_regs (destroyed_by_op op) ms)) sp rs'
  /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r.
Proof.
  intros.
  exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eauto.
  intros [v' [A B]].  rewrite (sp_val _ _ _ H0) in A.
  exploit transl_op_correct_aux; eauto. intros [rs' [P [Q R]]].
  rewrite <- Q in B.
  exists rs'; split. eexact P.
  split. apply agree_set_undef_mreg with rs; auto.
  auto.
Qed.

(** Translation of memory accesses *)

Lemma transl_memory_access_correct:
  forall (P: regset -> Prop) mk1 mk2 addr args temp k c (rs: regset) a m m',
  transl_memory_access mk1 mk2 addr args temp k = OK c ->
  eval_addressing ge (rs#GPR1) addr (map rs (map preg_of args)) = Some a ->
  temp <> GPR0 ->
  (forall cst (r1: ireg) (rs1: regset) k,
    Val.add (gpr_or_zero rs1 r1) (const_low ge cst) = a ->
    (forall r, r <> PC -> r <> temp -> r <> GPR0 -> rs1 r = rs r) ->
    exists rs',
        exec_straight ge fn (mk1 cst r1 :: k) rs1 m k rs' m' /\ P rs') ->
  (forall (r1 r2: ireg) (rs1: regset) k,
    Val.add rs1#r1 rs1#r2 = a ->
    (forall r, r <> PC -> r <> temp -> r <> GPR0 -> rs1 r = rs r) ->
    exists rs',
        exec_straight ge fn (mk2 r1 r2 :: k) rs1 m k rs' m' /\ P rs') ->
  exists rs',
      exec_straight ge fn c rs m k rs' m' /\ P rs'.
Proof.
  intros until m'; intros TR ADDR TEMP MK1 MK2.
  unfold transl_memory_access in TR; destruct addr; ArgsInv; simpl in ADDR; inv ADDR.
  (* Aindexed *)
  case (Int.eq (high_s i) Int.zero).
  (* Aindexed short *)
  apply MK1. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto.
  (* Aindexed long *)
  set (rs1 := nextinstr (rs#temp <- (Val.add (rs x) (Vint (Int.shl (high_s i) (Int.repr 16)))))).
  exploit (MK1 (Cint (low_s i)) temp rs1 k).
    simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen.
    unfold rs1; Simpl. rewrite Val.add_assoc.
Transparent Val.add.
    simpl. rewrite low_high_s. auto.
    intros; unfold rs1; Simpl.
  intros [rs' [EX' AG']].
  exists rs'. split. apply exec_straight_step with rs1 m.
  simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto.
  auto. auto.
  (* Aindexed2 *)
  apply MK2; auto.
  (* Aglobal *)
  destruct (symbol_is_small_data i i0) eqn:SISD; [ | destruct (symbol_is_rel_data i i0) ]; inv TR.
  (* Aglobal from small data *)
  apply MK1. unfold const_low. rewrite small_data_area_addressing by auto.
  apply add_zero_symbol_address.
  auto.
  (* Aglobal from relative data *)
  set (rs1 := nextinstr (rs#temp <- (Val.add Vzero (high_half ge i i0)))).
  set (rs2 := nextinstr (rs1#temp <- (Genv.symbol_address ge i i0))).
  exploit (MK1 (Cint Int.zero) temp rs2).
    simpl. rewrite gpr_or_zero_not_zero by eauto with asmgen.
    unfold rs2. Simpl. rewrite Val.add_commut. apply add_zero_symbol_address.
    intros; unfold rs2, rs1; Simpl.
  intros [rs' [EX' AG']].
  exists rs'; split. apply exec_straight_step with rs1 m; auto.
  apply exec_straight_step with rs2 m; auto. simpl. unfold rs2.
  rewrite gpr_or_zero_not_zero by eauto with asmgen. f_equal. f_equal. f_equal.
  unfold rs1; Simpl. apply low_high_half_zero.
  eexact EX'. auto.
  (* Aglobal from absolute data *)
  set (rs1 := nextinstr (rs#temp <- (Val.add Vzero (high_half ge i i0)))).
  exploit (MK1 (Csymbol_low i i0) temp rs1).
    simpl. rewrite gpr_or_zero_not_zero by eauto with asmgen.
    unfold rs1. Simpl. apply low_high_half_zero.
    intros; unfold rs1; Simpl.
  intros [rs' [EX' AG']].
  exists rs'; split. apply exec_straight_step with rs1 m; auto.
  eexact EX'. auto.
  (* Abased *)
  destruct (symbol_is_small_data i i0) eqn:SISD; [ | destruct (symbol_is_rel_data i i0) ].
  (* Abased from small data *)
  set (rs1 := nextinstr (rs#GPR0 <- (Genv.symbol_address ge i i0))).
  exploit (MK2 x GPR0 rs1 k).
    unfold rs1; Simpl. apply Val.add_commut.
    intros. unfold rs1; Simpl.
  intros [rs' [EX' AG']].
  exists rs'; split. apply exec_straight_step with rs1 m.
  unfold exec_instr. rewrite gpr_or_zero_zero. f_equal. unfold rs1. f_equal. f_equal.
  unfold const_low. rewrite small_data_area_addressing; auto.
  apply add_zero_symbol_address.
  reflexivity.
  assumption. assumption.
  (* Abased from relative data *)
  set (rs1 := nextinstr (rs#GPR0 <- (rs#x))).
  set (rs2 := nextinstr (rs1#temp <- (Val.add Vzero (high_half ge i i0)))).
  set (rs3 := nextinstr (rs2#temp <- (Genv.symbol_address ge i i0))).
  exploit (MK2 temp GPR0 rs3).
    f_equal. unfold rs3; Simpl. unfold rs3, rs2, rs1; Simpl.
    intros. unfold rs3, rs2, rs1; Simpl.
  intros [rs' [EX' AG']].
  exists rs'. split. eapply exec_straight_trans with (rs2 := rs3) (m2 := m).
  apply exec_straight_three with rs1 m rs2 m; auto.
  simpl. unfold rs3. f_equal. f_equal. f_equal. rewrite gpr_or_zero_not_zero by auto.
  unfold rs2; Simpl. apply low_high_half_zero.
  eexact EX'. auto.
  (* Abased absolute *)
  set (rs1 := nextinstr (rs#temp <- (Val.add (rs x) (high_half ge i i0)))).
  exploit (MK1 (Csymbol_low i i0) temp rs1 k).
    simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen.
    unfold rs1. Simpl.
    rewrite Val.add_assoc. rewrite low_high_half. apply Val.add_commut.
    intros; unfold rs1; Simpl.
  intros [rs' [EX' AG']].
  exists rs'. split. apply exec_straight_step with rs1 m.
  unfold exec_instr. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto.
  assumption. assumption.
  (* Ainstack *)
  destruct (Int.eq (high_s i) Int.zero); inv TR.
  apply MK1. simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto.
  set (rs1 := nextinstr (rs#temp <- (Val.add rs#GPR1 (Vint (Int.shl (high_s i) (Int.repr 16)))))).
  exploit (MK1 (Cint (low_s i)) temp rs1 k).
    simpl. rewrite gpr_or_zero_not_zero; auto.
    unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss.
    rewrite Val.add_assoc. simpl. rewrite low_high_s. auto.
    congruence.
    intros. unfold rs1. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto.
  intros [rs' [EX' AG']].
  exists rs'. split. apply exec_straight_step with rs1 m.
  unfold exec_instr. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto.
  assumption. assumption.
Qed.

(** Translation of loads *)

Lemma transl_load_correct:
  forall chunk addr args dst k c (rs: regset) m a v,
  transl_load chunk addr args dst k = OK c ->
  eval_addressing ge (rs#GPR1) 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 dst) = v
  /\ forall r, r <> PC -> r <> GPR12 -> r <> GPR0 -> r <> preg_of dst -> rs' r = rs r.
Proof.
  intros.
  assert (BASE: forall mk1 mk2 k' chunk' v',
  transl_memory_access mk1 mk2 addr args GPR12 k' = OK c ->
  Mem.loadv chunk' m a = Some v' ->
  (forall cst (r1: ireg) (rs1: regset),
    exec_instr ge fn (mk1 cst r1) rs1 m =
    load1 ge chunk' (preg_of dst) cst r1 rs1 m) ->
  (forall (r1 r2: ireg) (rs1: regset),
    exec_instr ge fn (mk2 r1 r2) rs1 m =
    load2 chunk' (preg_of dst) r1 r2 rs1 m) ->
  exists rs',
     exec_straight ge fn c rs m k' rs' m
  /\ rs'#(preg_of dst) = v'
  /\ forall r, r <> PC -> r <> GPR12 -> r <> GPR0 -> r <> preg_of dst -> rs' r = rs r).
  {
  intros. eapply transl_memory_access_correct; eauto. congruence.
  intros. econstructor; split. apply exec_straight_one.
  rewrite H4. unfold load1. rewrite H6. rewrite H3. eauto.
  unfold nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso; auto with asmgen.
  intuition Simpl.
  intros. econstructor; split. apply exec_straight_one.
  rewrite H5. unfold load2. rewrite H6. rewrite H3. eauto.
  unfold nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso; auto with asmgen.
  intuition Simpl.
  }
  destruct chunk; monadInv H.
- (* Mint8signed *)
  assert (exists v1, Mem.loadv Mint8unsigned m a = Some v1 /\ v = Val.sign_ext 8 v1).
  {
    destruct a; simpl in *; try discriminate.
    rewrite Mem.load_int8_signed_unsigned in H1.
    destruct (Mem.load Mint8unsigned m b (Int.unsigned i)); simpl in H1; inv H1.
    exists v0; auto.
  }
  destruct H as [v1 [LD SG]]. clear H1.
  exploit BASE; eauto; erewrite ireg_of_eq by eauto; auto.
  intros [rs1 [A [B C]]].
  econstructor; split.
  eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. auto.
  split. Simpl. congruence. intros. Simpl.
- (* Mint8unsigned *)
  eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mint816signed *)
  eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mint16unsigned *)
  eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mint32 *)
  eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mfloat32 *)
  eapply BASE; eauto; erewrite freg_of_eq by eauto; auto.
- (* Mfloat64 *)
  eapply BASE; eauto; erewrite freg_of_eq by eauto; auto.
Qed.

(** Translation of stores *)

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#GPR1) 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, r <> PC -> r <> GPR0 -> preg_notin r (destroyed_by_store chunk addr) -> rs' r = rs r.
Proof.
Local Transparent destroyed_by_store.
  intros.
  assert (TEMP0: int_temp_for src = GPR11 \/ int_temp_for src = GPR12).
    unfold int_temp_for. destruct (mreg_eq src R12); auto.
  assert (TEMP1: int_temp_for src <> GPR0).
    destruct TEMP0; congruence.
  assert (TEMP2: IR (int_temp_for src) <> preg_of src).
    unfold int_temp_for. destruct (mreg_eq src R12).
    subst src; simpl; congruence.
    change (IR GPR12) with (preg_of R12). red; intros; elim n.
    eapply preg_of_injective; eauto.
  assert (BASE: forall mk1 mk2 chunk',
  transl_memory_access mk1 mk2 addr args (int_temp_for src) k = OK c ->
  Mem.storev chunk' m a (rs (preg_of src)) = Some m' ->
  (forall cst (r1: ireg) (rs1: regset),
    exec_instr ge fn (mk1 cst r1) rs1 m =
    store1 ge chunk' (preg_of src) cst r1 rs1 m) ->
  (forall (r1 r2: ireg) (rs1: regset),
    exec_instr ge fn (mk2 r1 r2) rs1 m =
    store2 chunk' (preg_of src) r1 r2 rs1 m) ->
  exists rs',
     exec_straight ge fn c rs m k rs' m'
  /\ forall r, r <> PC -> r <> GPR0 -> r <> GPR11 /\ r <> GPR12 -> rs' r = rs r).
  {
  intros. eapply transl_memory_access_correct; eauto.
  intros. econstructor; split. apply exec_straight_one.
  rewrite H4. unfold store1. rewrite H6. rewrite H7; auto with asmgen. rewrite H3. eauto. auto.
  intros; Simpl. apply H7; auto. destruct TEMP0; destruct H10; congruence.
  intros. econstructor; split. apply exec_straight_one.
  rewrite H5. unfold store2. rewrite H6. rewrite H7; auto with asmgen. rewrite H3. eauto. auto.
  intros; Simpl. apply H7; auto. destruct TEMP0; destruct H10; congruence.
  }
  destruct chunk; monadInv H.
- (* Mint8signed *)
  assert (Mem.storev Mint8unsigned m a (rs (preg_of src)) = Some m').
    rewrite <- H1. destruct a; simpl; auto. symmetry. apply Mem.store_signed_unsigned_8.
  clear H1. eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mint8unsigned *)
  eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mint16signed *)
  assert (Mem.storev Mint16unsigned m a (rs (preg_of src)) = Some m').
    rewrite <- H1. destruct a; simpl; auto. symmetry. apply Mem.store_signed_unsigned_16.
  clear H1. eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mint16unsigned *)
  eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mint32 *)
  eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mfloat32 *)
  eapply BASE; eauto; erewrite freg_of_eq by eauto; auto.
- (* Mfloat64 *)
  eapply BASE; eauto; erewrite freg_of_eq by eauto; auto.
Qed.

End CONSTRUCTORS.


(** a naive functional representation of an array *)
(* (C) J. Pichon - see LICENSE.txt *)

(* this works well when there are few updates *)
Module Type Index_Sig.
Parameter Index : Type.
Parameter index_eqb : Index -> Index -> bool.
Parameter Value : Type.
End Index_Sig.

Module Make (X : Index_Sig).
  Import X.

Inductive array : Type :=
| A_init : Value -> array
| A_update : Index -> Value -> array -> array.

Definition make (v : Value) : array :=
  A_init v.

Fixpoint get (arr : array) (idx : Index) : Value :=
  match arr with
  | A_init a => a
  | A_update idx' a arr' =>
    if index_eqb idx idx' then a
    else get arr' idx
  end.

Definition set (arr : array) (idx : Index) (a : Value) : array :=
  A_update idx a arr.

End Make.


Definition ignore (n:nat) := tt.
Lemma ignore_S x : ignore (S x) = ignore x. exact eq_refl. Qed.
Create HintDb ignore discriminated.
Hint Rewrite ignore_S : ignore.

Goal ignore  125 = tt. Time autorewrite with ignore. exact eq_refl. Time Qed.
Goal ignore  250 = tt. Time autorewrite with ignore. exact eq_refl. Time Qed.
Goal ignore  500 = tt. Time autorewrite with ignore. exact eq_refl. Time Qed.
Goal ignore 1000 = tt. Time autorewrite with ignore. exact eq_refl. Time Qed.

(* same as create_rewrite_ignore.v *)
(* Finished transaction in 0.109 secs (0.072u,0.036s) (successful)
Finished transaction in 0.067 secs (0.056u,0.01s) (successful)
Finished transaction in 0.202 secs (0.201u,0.s) (successful)
Finished transaction in 0.171 secs (0.17u,0.s) (successful)
Finished transaction in 0.753 secs (0.742u,0.006s) (successful)
Finished transaction in 0.667 secs (0.664u,0.s) (successful)
Finished transaction in 2.939 secs (2.892u,0.033s) (successful)
Finished transaction in 2.678 secs (2.667u,0.s) (successful) *)


Require Import set.
Require Import empty.

Inductive Unit : Type := unit.

Definition singleton (x:set) : set := mkset Unit (fun _ => x).

Notation "{ x }" := (singleton x).

Notation "1" := {0}.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Set Implicit Arguments.
Unset Strict Implicit.
Require Export Sgroup_cat.
Section Lemmas.
Variable E : SGROUP.

Lemma SGROUP_assoc :
 forall x y z : E,
 Equal (sgroup_law _ (sgroup_law _ x y) z)
   (sgroup_law _ x (sgroup_law _ y z)).
intros x y z; try assumption.
apply (sgroup_assoc_prf E x y z); auto with algebra.
Qed.

Lemma SGROUP_comp :
 forall x x' y y' : E,
 Equal x x' -> Equal y y' -> Equal (sgroup_law _ x y) (sgroup_law _ x' y').
unfold sgroup_law in |- *; auto with algebra.
Qed.
Variable F : SGROUP.
Variable f : Hom E F.

Lemma SGROUP_hom_prop :
 forall x y : E, Equal (f (sgroup_law _ x y)) (sgroup_law _ (f x) (f y)).
intros x y; try assumption.
apply (sgroup_hom_prf f).
Qed.
End Lemmas.
Hint Resolve SGROUP_assoc SGROUP_comp SGROUP_hom_prop: algebra.


Require Import VST.veric.base.
Require Import VST.msl.msl_standard.
Require Import Coq.Relations.Relations.

Definition deterministic_rel {T} (R: relation T) :=
  forall s s' s'', R s s' /\ R s s'' -> s'=s''.

Definition pfunc T R := T -> option R.

Definition address := nat.

Inductive val : Type :=
| Vint : nat -> val
| Vptr : address -> val
| Vundef.

(* Generic Operational Semantics *)
Class GenericSemantics
  (W : Type) (* Worlds *)
  (V : relation W -> Prop) (* Primitive commands *)
  (G : pfunc W val -> Prop) (* Primitive expressions *)
  : Type := mkGenericSem {
}.

Section Expressions.
Variables
  (W : Type)
  (G : pfunc W val -> Prop) (* Primitive expressions *).

Inductive unop := UNeg.

Inductive binop := BAdd.

Inductive expr : Type :=
| EVal : forall (v : val), expr
| EUnop : forall (op : unop) (e : expr), expr
| EBinop : forall (op : binop) (e1 e2 : expr), expr
| EPrim : forall (f : pfunc W val), expr.

Definition is_true (v : val) :=
  exists n, (v = Vint n \/ v = Vptr n) /\ n <> O.

Lemma is_true_dec : forall v, {is_true v} + {~ is_true v}.
Proof.
unfold is_true; intros.
destruct v.
destruct (eq_nat_dec n O).
right; intros Contra.
destruct Contra as [n' [H H0]]. inv H.
inv H1. exfalso; auto.
inv H1.
left; eexists; split; eauto.
destruct (eq_nat_dec a 0).
right; intros Contra; auto.
destruct Contra as [n'' [H H0]]. inv H.
inv H1. inv H1. exfalso; auto.
left; eexists; split; eauto.
right; intros Contra.
destruct Contra as [n' [H H0]]. inv H; inv H1.
Qed.

Definition unopDenote (op : unop) (v : val) : val :=
  match op, is_true_dec v with
    | UNeg, left _ => Vint 0
    | UNeg, right _ => Vint 1
  end.

Definition binopDenote (op : binop) (v1 v2 : val) :=
  match op, v1, v2 with
    | BAdd, (Vint n), (Vint m) => Vint (n+m)%nat
    | BAdd, (Vptr p), (Vint n) => Vptr (p+n)%nat
    | _, _, _ => Vundef
  end.

Fixpoint expr_wellformed (e : expr) : Prop :=
  match e with
    | EVal _ => True
    | EUnop _ e => expr_wellformed e
    | EBinop _ e1 e2 => expr_wellformed e1 /\ expr_wellformed e2
    | EPrim f => G f
  end.

Fixpoint exprEval' (e : expr) : W -> option val := fun w =>
  match e with
    | EVal v => Some v
    | EUnop op e' =>
      let v := exprEval' e' w in
        match v with
          | Some v' => Some (unopDenote op v')
          | None => None
        end
    | EBinop op e1 e2 =>
      let v1 := exprEval' e1 w in
      let v2 := exprEval' e2 w in
        match v1, v2 with
          | Some v1', Some v2' => Some (binopDenote op v1' v2')
          | _, _ => None
        end
    | EPrim f => f w
  end.

Definition exprEval (e : expr) (w : W) (v : val) :=
  expr_wellformed e /\ exprEval' e w = Some v.

Fixpoint pure_expr (e : expr) :=
  match e with
    | EVal v => True
    | EUnop op e' => pure_expr e'
    | EBinop op e1 e2 => pure_expr e1 /\ pure_expr e2
    | EPrim _ => False
  end.

Lemma pure_exprEval : forall e w w' b1 b2,
  pure_expr e
  -> exprEval e w b1
  -> exprEval e w' b2
  -> b1=b2.
Proof.
intros.
revert b1 b2 H H0 H1.
induction e; intros; inv H0; inv H1; simpl in * |-; try congruence.
case_eq (exprEval' e w); intros. rewrite H1 in H3; inv H3.
case_eq (exprEval' e w'); intros. rewrite H3 in H4; inv H4.
f_equal; apply IHe; auto||split; auto.
rewrite H3 in H4; inv H4.
rewrite H1 in H3; inv H3.
case_eq (exprEval' e1 w); intros. rewrite H1 in H3; inv H3.
case_eq (exprEval' e2 w); intros. rewrite H3 in H6; inv H6.
case_eq (exprEval' e1 w'); intros. rewrite H5 in H4; inv H4.
case_eq (exprEval' e2 w'); intros. rewrite H4 in H7; inv H7.
destruct H; destruct H2; destruct H0.
f_equal. apply IHe1; auto||split; auto.
         apply IHe2; auto||split; auto.
rewrite H4 in *; congruence.
rewrite H5 in *; congruence.
rewrite H3 in *; congruence.
rewrite H1 in *; congruence.
inv H.
Qed.

Lemma pure_expr_safe : forall e w,
  pure_expr e
  -> exists b, exprEval e w b.
Proof.
induction e; intros.
eexists; split; simpl; eauto.
simpl in *.
destruct (IHe w H) as [b [? ?]].
exists (unopDenote op b). split; simpl; auto||rewrite H1; auto.
simpl in *. destruct H.
destruct (IHe1 w H) as [b1 [? ?]].
destruct (IHe2 w H0) as [b2 [? ?]].
exists (binopDenote op b1 b2).
  split; simpl; auto||rewrite H2; rewrite H4; auto.
simpl in H; inv H.
Qed.

Lemma pure_expr_dec : forall e, {pure_expr e} + {~ pure_expr e}.
Proof.
intros.
induction e.
left; simpl; auto.
inv IHe.
left; simpl; auto.
right; simpl; auto.
inv IHe1; inv IHe2.
left; simpl; auto.
right; simpl; auto.
intros [? ?]; apply H0; auto.
right; simpl; auto.
intros [? ?]; apply H; auto.
right; simpl; auto.
intros [? ?]; apply H; auto.
right; auto.
Qed.
End Expressions.
Arguments exprEval' [W] _ _.
Arguments exprEval [W] _ _ _ _.
Arguments EUnop [W] _ _.
Arguments EUnop [W] _ _.
Arguments EBinop [W] _ _ _.
Arguments EPrim [W] _.

Section ExpressionErasure.
Variables
  (W S' : Type)
  (G : pfunc W val -> Prop)
  (F : pfunc S' val -> Prop)
  (GF : pfunc W val -> pfunc S' val -> Prop)

  (world_erase : W -> S')

  (primexpr_erasure : forall g f b1 b2 w s (Hgf : GF g f),
    world_erase w = s
    -> exprEval G (EPrim g) w b1
    -> exprEval F (EPrim f) s b2
    -> b1=b2)

  (primexpr_safety : forall g f b1 w s,
    GF g f
    -> world_erase w = s
    -> exprEval G (EPrim g) w b1
    -> exists b2, exprEval F (EPrim f) s b2).

Inductive expr_erase : expr W -> expr S' -> Prop :=
| erase_EVal : forall v,
     expr_erase (EVal _ v) (EVal _ v)
| erase_EUnop : forall op e e',
     expr_erase e e'
     -> expr_erase (EUnop op e) (EUnop op e')
| erase_EBinop : forall op e1 e2 e1' e2',
     expr_erase e1 e1'
     -> expr_erase e2 e2'
     -> expr_erase (EBinop op e1 e2) (EBinop op e1' e2')
| erase_EPrim : forall g f,
     GF g f
     -> expr_erase (EPrim g) (EPrim f).

Lemma expr_erase_pure_expr : forall e e',
  expr_erase e e'
  -> pure_expr _ e
  -> pure_expr _ e'.
Proof.
intros.
induction H; auto.
inv H0.
simpl; split; auto.
Qed.

Lemma expr_erasure : forall e e' w b1 b2,
  expr_erase e e'
  -> exprEval G e w b1
  -> exprEval F e' (world_erase w) b2
  -> b1=b2.
Proof.
intros.
revert b1 b2 H0 H1.
induction H; intros.
inv H0; inv H1; simpl in *; congruence.
inv H0; inv H1; simpl in *.
case_eq (exprEval' e w); intros. rewrite H1 in H3; inv H3.
case_eq (exprEval' e' (world_erase w)); intros. rewrite H3 in H4; inv H4.
f_equal. apply IHexpr_erase; auto||split; auto.
rewrite H3 in *; congruence.
rewrite H1 in *; congruence.
destruct H1; destruct H2; simpl in *.
case_eq (exprEval' e1 w); intros.
case_eq (exprEval' e2 w); intros.
rewrite H5 in *; rewrite H6 in *; inv H3.
case_eq (exprEval' e1' (world_erase w)); intros.
case_eq (exprEval' e2' (world_erase w)); intros.
rewrite H3 in *; rewrite H7 in *; inv H4.
destruct H1; destruct H2.
f_equal. apply IHexpr_erase1; auto||split; auto.
         apply IHexpr_erase2; auto||split; auto.
rewrite H3 in *. rewrite H7 in *. congruence.
rewrite H3 in *. congruence.
rewrite H5 in *. rewrite H6 in *. congruence.
rewrite H5 in *. congruence.
eapply primexpr_erasure; eauto.
Qed.

Lemma expr_safety : forall e e' w b1,
  expr_erase e e'
  -> exprEval G e w b1
  -> exists b2, exprEval F e' (world_erase w) b2.
Proof.
intros.
revert b1 H0.
induction H; simpl; intros.
eexists; eauto.
inv H0. simpl in *.
case_eq (exprEval' e w); intros.
rewrite H0 in H2.
assert (exprEval G e w v). split; auto.
destruct (IHexpr_erase v H3) as [b2 [? ?]].
exists (unopDenote op b2).
split; eauto.
simpl; rewrite H5; auto.
rewrite H0 in H2; inv H2.
inv H1; simpl in *.
case_eq (exprEval' e1 w); case_eq (exprEval' e2 w); intros.
rewrite H1 in *; rewrite H4 in *.
destruct H2.
destruct (IHexpr_erase1 v0). split; auto.
destruct (IHexpr_erase2 v). split; auto.
destruct H6; destruct H7.
exists (binopDenote op x x0); split; auto.
simpl. split; auto.
simpl. rewrite H9; rewrite H8. auto.
rewrite H4 in H3; rewrite H1 in H3; congruence.
rewrite H4 in H3; congruence.
rewrite H4 in H3; congruence.
eapply primexpr_safety; eauto.
Qed.
End ExpressionErasure.
Arguments expr_erase [W S'] _ _ _.

(* Here we define the syntax and operational semantics of generic semantics. *)
Section GenericSemanticsElaboration.
Context {W V G} `{GS : GenericSemantics W V G}.

Inductive stmt : Type :=
| Sprimcom: forall (u: relation W), stmt
| Sskip
| Sseq: forall (s1 s2: stmt), stmt
| Sifte: forall (e: expr W) (s1 s2: stmt), stmt
| Swhile: forall (e: expr W) (s: stmt), stmt.

Inductive ctl : Type := Kstop | Kseq: forall (s: stmt) (k: ctl), ctl.

Inductive step : W -> ctl -> W -> ctl -> Prop :=
| step_Sprimcom: forall v (w w': W) (k: ctl),
     V v
     -> v w w'
     -> step w (Kseq (Sprimcom v) k) w' k
| step_Sskip: forall w (k: ctl),
     step w (Kseq Sskip k) w k
| step_Sseq: forall (s1 s2: stmt) w (k: ctl),
     step w (Kseq (Sseq s1 s2) k) w (Kseq s1 (Kseq s2 k))
| step_Sifte_true: forall (e: expr W) (v: val) (s1 s2: stmt) (w: W) (k: ctl),
     exprEval G e w v
     -> is_true v
     -> step w (Kseq (Sifte e s1 s2) k) w (Kseq s1 k)
| step_Sifte_false: forall (e: expr W) (v: val) (s1 s2: stmt) (w: W) (k: ctl),
     exprEval G e w v
     -> ~is_true v
     -> step w (Kseq (Sifte e s1 s2) k) w (Kseq s2 k)
| step_Swhile: forall (s: stmt) e w (k: ctl),
     step w (Kseq (Swhile e s) k)
          w (Kseq (Sifte e (Sseq s (Swhile e s)) Sskip) k).

(* The usual closures and definition of safety *)
Inductive step_star : W -> ctl -> W -> ctl -> Prop :=
| step_star0: forall w k, step_star w k w k
| step_starN: forall w k w'' k'' w' k', step w k w'' k'' -> step_star w'' k'' w' k'
     -> step_star w k w' k'.

Inductive stepN : nat -> W -> ctl -> W -> ctl -> Prop :=
| stepN_0: forall w k, stepN O w k w k
| stepN_S: forall n w k w' k' w'' k'',
     step w k w' k'
     -> stepN n w' k' w'' k''
     -> stepN (S n) w k w'' k''.

Inductive immed_safe : W -> ctl -> Prop :=
| immed_safe0: forall w,
     immed_safe w Kstop
| immed_safe1: forall w k w' k',
     step w k w' k'
     -> immed_safe w k.

Definition safe w k := forall w'' k'', step_star w k w'' k'' -> immed_safe w'' k''.

(* Step Lemmas *)
Lemma step_step_star : forall w k w' k',
  step w k w' k'
  -> step_star w k w' k'.
Proof.
intros; repeat econstructor; eauto.
Qed.

Lemma step_star_trans : forall w k w'' k'' w' k',
  step_star w k w'' k''
  -> step_star w'' k'' w' k'
  -> step_star w k w' k'.
Proof.
intros; induction H; auto.
generalize (IHstep_star H0); intro.
econstructor; eauto.
Qed.

Lemma step_star_stepN : forall w k w'' k'',
  step_star w k w'' k'' <-> exists n, stepN n w k w'' k''.
Proof.
intros; split; intros.
match goal with [H : step_star _ _ _ _ |- _] => induction H end.
eexists; econstructor.
destruct IHstep_star as [n ?]. exists (S n). econstructor; eauto.
destruct H as [n ?].
induction H.
econstructor.
econstructor; eauto.
Qed.

Lemma step_nprimcom_det : forall w k w' k' w'' k'',
  (forall u k', k <> Kseq (Sprimcom u) k')
  -> step w k w' k'
  -> step w k w'' k''
  -> w'=w'' /\ k'=k''.
Proof.
intros.
destruct k. inv H0.
destruct s; try solve
  [exfalso; apply (H u k); auto
  |inv H0; inv H1; split; auto].
inv H0; inv H1; split;
destruct H8; destruct H9; congruence.
Qed.

Lemma step_safe : forall w k w' k', safe w k -> step w k w' k' -> safe w' k'.
Proof.
unfold safe.
let H := fresh "H" in intros ? ? ? ? H; intros;
  apply H; eapply step_starN; eauto.
Qed.

Definition config_det w k := forall w' k' w'' k'',
  step w k w' k' -> step w k w'' k'' -> w'=w'' /\ k'=k''.

Lemma step_safe' : forall w k w' k',
  safe w' k' -> step w k w' k' -> config_det w k -> safe w k.
Proof.
unfold safe, config_det; intros.
inv H2.
eapply immed_safe1; eauto.
destruct (H1 w' k' w''0 k''0 H0 H3); subst.
apply H; eauto.
Qed.

Lemma safe_seq_assoc: forall w k c1 c2,
  safe w (Kseq c1 (Kseq c2 k)) -> safe w (Kseq (Sseq c1 c2) k).
Proof.
unfold safe; intros.
remember (Kseq (Sseq c1 c2) k).
inv H0; subst.
repeat econstructor; eauto.
inv H1.
auto.
Qed.

Lemma step_compatible : forall c w w' k,
  step w (Kseq c Kstop) w' Kstop -> step w (Kseq c k) w' k.
Proof.
intros. inv H; econstructor; eauto.
Qed.
End GenericSemanticsElaboration.

(* Stratified Semantics -- the "product" of two generic semantics. *)
(* We use S' instead of S to avoid problems with Datatypes.S. *)
Class StratifiedSemantics {W V G S' U F}
                          `{WVG : GenericSemantics W V G}
                           (* The abstract semantics *)
                          `{S'UF : GenericSemantics S' U F}
                           (* The concrete semantics *)
                           (world_erase : W -> S')
                           (* An erasure function mapping worlds to states *)
                           (VU : relation W -> relation S' -> Prop)
                           (* Acceptable primitive command pairs *)
                           (GF : pfunc W val -> pfunc S' val -> Prop)
                           (* Acceptable primitive expression pairs *)
                           : Type := mkStratifiedSemantics {

  (* These axioms just enforce that VU and GF are subsets of the products
     V x U and G x F. *)
  ss_VU_wellformed : forall v u,
    VU v u
    -> V v /\ U u;

  ss_GF_wellformed : forall g f,
    GF g f
    -> G g /\ F f;

  (* Erasure and safety of primitive commands *)
  ss_primcom_erasure : forall v u w w' s s',
    VU v u
    -> world_erase w = s
    -> v w w'
    -> u s s'
    -> world_erase w' = s';

  ss_primcom_safety : forall v u w w' s,
    VU v u
    -> world_erase w = s
    -> v w w'
    -> exists s', u s s';

  (* Ditto for primitive expressions *)
  ss_primexpr_erasure : forall g f b1 b2 w s (Hgf : GF g f),
    world_erase w = s
    -> exprEval G (EPrim g) w b1
    -> exprEval F (EPrim f) s b2
    -> b1=b2;

  ss_primexpr_saftey : forall g f b1 w s,
    GF g f
    -> world_erase w = s
    -> exprEval G (EPrim g) w b1
    -> exists b2, exprEval F (EPrim f) s b2
}.

Section UnpackStratifiedSemantics.
Context {W V G S' U F world_erase VU GF}
        `{SS : StratifiedSemantics W V G S' U F world_erase VU GF}.

Lemma VU_wellformed : forall v u,
    VU v u
    -> V v /\ U u.
Proof. inversion SS; auto. Qed.

Lemma GF_wellformed : forall g f,
    GF g f
    -> G g /\ F f.
Proof. inversion SS; auto. Qed.

Lemma primcom_erasure : forall v u w w' s s',
    VU v u
    -> world_erase w = s
    -> v w w'
    -> u s s'
    -> world_erase w' = s'.
Proof. inversion SS; auto. Qed.

Lemma primcom_safety : forall v u w w' s,
    VU v u
    -> world_erase w = s
    -> v w w'
    -> exists s', u s s'.
Proof. inversion SS; auto. Qed.

Lemma primexpr_erasure : forall g f b1 b2 w s,
    GF g f
    -> world_erase w = s
    -> exprEval G (EPrim g) w b1
    -> exprEval F (EPrim f) s b2
    -> b1=b2.
Proof. inversion SS; auto. Qed.

Lemma primexpr_safety : forall g f b1 w s,
    GF g f
    -> world_erase w = s
    -> exprEval G (EPrim g) w b1
    -> exists b2, exprEval F (EPrim f) s b2.
Proof. inversion SS; auto. Qed.
End UnpackStratifiedSemantics.

(* Corollaries of primitive erasure in the context of a stratified semantics (WVG, S'UF) *)
Section ErasureCorollaries.
Context
  {W V G S' U F world_erase VU GF}
  `{SS : StratifiedSemantics W V G S' U F world_erase VU GF}.

(* Syntax erasure *)
Inductive stmt_erase : @stmt W -> @stmt S' -> Prop :=
| erase_SPrimcom: forall v u,
     VU v u
     -> stmt_erase (Sprimcom v) (Sprimcom u)
| erase_SSkip: stmt_erase Sskip Sskip
| erase_SSeq: forall c1 c1' c2 c2',
     stmt_erase c1 c1'
     -> stmt_erase c2 c2'
     -> stmt_erase (Sseq c1 c2) (Sseq c1' c2')
| erase_SIfte: forall e e' c1 c2 c1' c2',
     expr_erase GF e e'
     -> stmt_erase c1 c1'
     -> stmt_erase c2 c2'
     -> stmt_erase (Sifte e c1 c2) (Sifte e' c1' c2')
| erase_SWhile: forall e e' c c',
     expr_erase GF e e'
     -> stmt_erase c c'
     -> stmt_erase (Swhile e c) (Swhile e' c').

Inductive ctl_erase : @ctl W -> @ctl S' -> Prop :=
| erase_KStop: ctl_erase Kstop Kstop
| erase_KSeq: forall c c' k k',
     stmt_erase c c'
     -> ctl_erase k k'
     -> ctl_erase (Kseq c k) (Kseq c' k').

(* Corollaries of primitive command erasure and safety *)
Lemma stratified_expr_erasure : forall e e' w b1 b2,
  expr_erase GF e e'
  -> exprEval G e w b1
  -> exprEval F e' (world_erase w) b2
  -> b1=b2.
Proof.
intros.
generalize primexpr_erasure; intros.
eapply expr_erasure; eauto.
Qed.

Lemma stratified_expr_safety : forall e e' w b1,
  expr_erase GF e e'
  -> exprEval G e w b1
  -> exists b2, exprEval F e' (world_erase w) b2.
Proof.
intros.
generalize primexpr_safety; intro.
eapply expr_safety; eauto.
Qed.

Lemma step_erasure : forall (w w': W) (s s': S') k_w k_w' k_s k_s',
  world_erase w = s
  -> ctl_erase k_w k_s
  -> @step _ V G w k_w w' k_w'
  -> @step _ U F s k_s s' k_s'
  -> world_erase w' = s' /\ ctl_erase k_w' k_s'.
Proof.
intros; split; intros.
inv H0; inv H1; inv H2; inv H3; auto; eapply primcom_erasure; eauto.
inv H0; inv H1; inv H2; inv H3; repeat constructor; auto.
assert (v = v0) by (eapply stratified_expr_erasure; eauto); subst; contradiction.
assert (v = v0) by (eapply stratified_expr_erasure; eauto); subst; contradiction.
Qed.

Lemma step_safety : forall w w' s k_w k_w' k_s,
  world_erase w = s
  -> ctl_erase k_w k_s
  -> @step _ V G w k_w w' k_w'
  -> exists s', exists k_s', @step _ U F s k_s s' k_s'.
Proof.
intros.
destruct H0. inv H1.
inv H1. inv H0.
destruct (primcom_safety _ _ _ _ _ H1 (refl_equal _) H9).
destruct (VU_wellformed _ _ H1).
repeat eexists; econstructor; eauto.
inv H0; repeat eexists; econstructor.
inv H0; repeat eexists; econstructor.
inv H0.
assert (exprEval F e' (world_erase w') v).
  destruct (stratified_expr_safety _ _ _ _ H4 H6).
  generalize (stratified_expr_erasure _ _ _ _ _ H4 H6 H); intro.
  rewrite H0; auto.
repeat eexists; econstructor; eauto.
inversion H0; subst.
assert (exprEval F e' (world_erase w') v).
  destruct (stratified_expr_safety _ _ _ _ H4 H6).
  generalize (stratified_expr_erasure _ _ _ _ _ H4 H6 H); intro.
  rewrite H1; auto.
exists (world_erase w'); exists (Kseq c2' k'); econstructor; eauto.
inv H0; repeat eexists; econstructor.
Qed.

Lemma step_star_erasure : forall w w' s k_w k_w' k_s,
  world_erase w = s
  -> ctl_erase k_w k_s
  -> @step_star _ V G w k_w w' k_w'
  -> exists s', exists k_s',
        @step_star _ U F s k_s s' k_s'
        /\ world_erase w' = s' /\ ctl_erase k_w' k_s'.
Proof.
intros.
revert s k_s H H0.
induction H1.
repeat eexists; eauto. subst. econstructor; eauto.
intros.
destruct (step_safety _ _ _ _ _ _ H0 H2 H) as [s' [k_s' H5]].
destruct (step_erasure _ _ _ _ _ _ _ _ H0 H2 H H5).
generalize (IHstep_star s' k_s' H3 H4); intros [s'' [k_s'' [? [? ?]]]].
assert (@step_star _ U F s k_s s'' k_s'') by (eapply step_starN; eauto).
exists s''; exists k_s''. split; auto.
Qed.
End ErasureCorollaries.

(* Stratified Semantics with Separation -- this is where put everything together. *)
Class StratifiedSemanticsWithSeparation
  {W V G S' U F world_erase VU GF}
  `{StratifiedSemantics W V G S' U F world_erase VU GF}
  {A}
  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}
   (* NOTE: Perhaps we also want   CA: Canc_alg A   *)
  (projA : W -> A)
  (* Projection function mapping worlds to elements of A *)
  (H : pfunc A val -> Prop)
  (* Set of primitive expressions on A -- we need these in order
     to use [assert_expr]-style predicates in our separation
     logic. *)
  (HG : pfunc A val -> pfunc W val -> Prop)
  (* Acceptable primitive expression pairs on A and W *)
  : Type := {

   sss_HG_wellformed : forall h g,
     HG h g
     -> H h /\ G g;

   sss_primexpr_erasure : forall w a g h b1 b2,
    HG h g
    -> projA w = a
    -> exprEval H (EPrim h) a b1
    -> exprEval G (EPrim g) w b2
    -> b1=b2;

   sss_primexpr_safety : forall w a g h b1,
    HG h g
    -> projA w = a
    -> exprEval H (EPrim h) a b1
    -> exists b2, exprEval G (EPrim g) w b2
}.

Section UnpackStratifiedSemanticsWithSeparation.
Context
{W V G S' U F world_erase VU GF A projA H HG}
`{SSS : StratifiedSemanticsWithSeparation W V G S' U F world_erase VU GF A projA H HG}.

Lemma HG_wellformed : forall h g,
     HG h g
     -> H h /\ G g.
Proof. inversion SSS; auto. Qed.

Lemma sep_primexpr_erasure : forall w a g h b1 b2,
  HG h g
  -> projA w = a
  -> exprEval H (EPrim h) a b1
  -> exprEval G (EPrim g) w b2
  -> b1=b2.
Proof. inversion SSS; auto. Qed.

Lemma sep_primexpr_safety : forall w a g h b1,
  HG h g
  -> projA w = a
  -> exprEval H (EPrim h) a b1
  -> exists b2, exprEval G (EPrim g) w b2.
Proof. inversion SSS; auto. Qed.
End UnpackStratifiedSemanticsWithSeparation.

Section SepErasureCorollaries.
Context
{W V G S' U F world_erase VU GF A projA H HG}
`{SSS : StratifiedSemanticsWithSeparation W V G S' U F world_erase VU GF A projA H HG}.

Lemma sep_expr_erasure : forall e e' w b1 b2,
  expr_erase HG e e'
  -> exprEval H e (projA w) b1
  -> exprEval G e' w b2
  -> b1=b2.
Proof.
intros.
revert b1 b2 H2 H3.
induction H1; intros.
inv H2; inv H3; simpl in *; congruence.
inv H2; inv H3; simpl in *.
case_eq (exprEval' e (projA w)); intros. rewrite H3 in H5; inv H5.
case_eq (exprEval' e' w); intros. rewrite H5 in H6; inv H6.
f_equal. apply IHexpr_erase; auto||split; auto.
rewrite H5 in *; congruence.
rewrite H3 in *; congruence.
destruct H2; destruct H3; simpl in *.
case_eq (exprEval' e1 (projA w)); intros.
case_eq (exprEval' e2 (projA w)); intros.
rewrite H5 in *; rewrite H6 in *; inv H3.
case_eq (exprEval' e1' w); intros.
case_eq (exprEval' e2' w); intros.
rewrite H3 in *; rewrite H9 in *; inv H4.
destruct H1. inv H2.
f_equal. apply IHexpr_erase1; auto||split; auto.
         apply IHexpr_erase2; auto||split; auto.
rewrite H3 in *. rewrite H9 in *. congruence.
rewrite H3 in *. congruence.
rewrite H5 in *. rewrite H6 in *. congruence.
rewrite H5 in *. congruence.
eapply sep_primexpr_erasure; eauto.
Qed.

Lemma sep_expr_safety : forall e e' w b1,
  expr_erase HG e e'
  -> exprEval H e (projA w) b1
  -> exists b2, exprEval G e' w b2.
Proof.
intros.
revert b1 H2.
induction H1; simpl; intros.
eexists; eauto.
inv H2. simpl in *.
case_eq (exprEval' e (projA w)); intros.
rewrite H2 in H4.
assert (exprEval H e (projA w) v). split; auto.
destruct (IHexpr_erase v H5) as [b2 [? ?]].
exists (unopDenote op b2).
split; eauto.
simpl; rewrite H7; auto.
rewrite H2 in H4; inv H4.
inv H2; simpl in *.
case_eq (exprEval' e1 (projA w)); case_eq (exprEval' e2 (projA w)); intros.
rewrite H2 in *; rewrite H4 in *.
destruct H1.
destruct (IHexpr_erase1 v0). split; auto.
destruct (IHexpr_erase2 v). split; auto.
destruct H6; destruct H7.
exists (binopDenote op x x0); split; auto.
simpl. split; auto.
simpl. rewrite H9; rewrite H8. auto.
rewrite H4 in H3; rewrite H2 in H3; congruence.
rewrite H4 in H3; congruence.
rewrite H4 in H3; congruence.
eapply sep_primexpr_safety; eauto.
Qed.
End SepErasureCorollaries.