(* 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                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(* The cartesian product and its properties *)

Require Import Sets.
Require Import Axioms.

(* This definition of the ordered pair is slightly different from *)
(* the usual one, since we want it to work in an intuisionistic   *)
(* setting. Works the same, neitherless. The soundness proofs are *)
(* unpleasant.                                                    *)

Definition Couple (E E' : Ens) := Paire (Sing E) (Paire Vide (Sing E')).

Theorem Couple_inj_left :
 forall A A' B B' : Ens, EQ (Couple A A') (Couple B B') -> EQ A B.
unfold Couple in |- *; simpl in |- *.
simple induction 1.
intros HA HB; elim (HA true).
intros x; elim x; simpl in |- *; simple induction 1; intros H3 H4;
 elim (H3 true); simpl in |- *; intros xx; elim xx;
 simpl in |- *; auto with zfc.
elim (H4 false); simpl in |- *.
simple induction x0; simpl in |- *.
intros.
cut (EQ (Sing B') Vide).
simpl in |- *.
simple induction 1.
intros yy; elim (yy true).
simple induction x1.

apply EQ_tran with A; auto with zfc.

intros; cut (EQ (Sing B') Vide).
simpl in |- *.
simple induction 1.
intros yy; elim (yy true).
simple induction x1.

apply EQ_tran with A; auto with zfc.

intros yy.
elim (HB true); simpl in |- *.
simple induction x0.
change (EQ (Sing A) (Sing B) -> EQ A B) in |- *; intros EE.
apply IN_Sing_EQ.
apply IN_sound_right with (Sing A); auto with zfc.
change (EQ (Paire Vide (Sing A')) (Sing B) -> EQ A B) in |- *.
intros zz.
elimtype F.
apply (not_EQ_Sing_Vide A').
apply EQ_tran with B.
apply IN_Sing_EQ.
apply IN_sound_right with (Paire Vide (Sing A')); auto with zfc.
apply EQ_sym; apply IN_Sing_EQ;
 apply IN_sound_right with (Paire Vide (Sing A'));
 auto with zfc.

Qed.

Theorem Couple_inj_right :
 forall A A' B B' : Ens, EQ (Couple A A') (Couple B B') -> EQ A' B'.
unfold Couple in |- *; simpl in |- *.
simple induction 1; intros H1 H2.
elim (H1 false).
intros bb1; elim bb1.
intros HF.
change (EQ (Paire Vide (Sing A')) (Sing B)) in HF.
cut F.
simple induction 1.
apply (not_EQ_Vide_Sing A').
apply EQ_tran with B.
apply IN_Sing_EQ; apply IN_sound_right with (Paire Vide (Sing A'));
 auto with zfc.
apply EQ_sym; apply IN_Sing_EQ;
 apply IN_sound_right with (Paire Vide (Sing A'));
 auto with zfc.
change (EQ (Paire Vide (Sing A')) (Paire Vide (Sing B')) -> EQ A' B') in |- *.
intros HP; cut (EQ (Sing A') (Sing B')).
intros; auto with zfc.
cut (IN (Sing A') (Paire Vide (Sing B'))).
intros HI; elim (Paire_IN Vide (Sing B') (Sing A') HI).
intros; cut F.
simple induction 1.
apply not_EQ_Sing_Vide with A'; assumption.
trivial with zfc.
apply IN_sound_right with (Paire Vide (Sing A')); auto with zfc.

Qed.

(* Here we cheat. It is easier to define the cartesian product using    *)
(* the type theoretical product, i.e. we here use non set-theoretical   *)
(* constructions. We could however use the usual definitions.           *)

Definition Prod (E E' : Ens) : Ens :=
  match E, E' with
  | sup A f, sup A' f' =>
      sup _
        (fun c : prod_t A A' =>
         match c with
         | pair_t a a' => Couple (f a) (f' a')
         end)
  end.

Hint Resolve Paire_sound_left Paire_sound_right: zfc.

Theorem Couple_sound_left :
 forall A A' B : Ens, EQ A A' -> EQ (Couple A B) (Couple A' B).
 unfold Couple in |- *; intros; auto with zfc.
Qed.

Theorem Couple_sound_right :
 forall A B B' : Ens, EQ B B' -> EQ (Couple A B) (Couple A B').
 unfold Couple in |- *; intros; auto with zfc.
Qed.

Theorem Couple_IN_Prod :
 forall E1 E2 E1' E2' : Ens,
 IN E1' E1 -> IN E2' E2 -> IN (Couple E1' E2') (Prod E1 E2).
simple induction E1; intros A1 f1 r1; simple induction E2; intros A2 f2 r2.
intros E1' E2' i1 i2.
elim (IN_EXType (sup A1 f1) E1').
intros x e1; simpl in x.
elim (IN_EXType (sup A2 f2) E2').
intros x0 e2; simpl in x.
apply IN_sound_left with (Couple (pi2 (sup A1 f1) x) (pi2 (sup A2 f2) x0));
 auto with zfc.
apply EQ_tran with (Couple (pi2 (sup A1 f1) x) E2'); auto with zfc.
apply Couple_sound_right.
auto with zfc.

apply Couple_sound_left; auto with zfc.

simpl in |- *.
simpl in |- *.
exists (pair_t _ _ x x0).
simpl in |- *.
split.
simple induction x1; simpl in |- *.
exists true; simpl in |- *.
split.
simple induction x2; simpl in |- *.
exists true; auto with zfc.

exists true; auto with zfc.

simple induction y; exists true; auto with zfc.

exists false; simpl in |- *.
split.
simple induction x2.
exists true; simpl in |- *; auto with zfc.
split.
simple induction x3.

simple induction y.

exists false; auto with zfc.

simple induction y; simpl in |- *.
exists true; auto with zfc.

exists false; auto with zfc.

simple induction y; simpl in |- *.
exists true; auto with zfc.

exists false; auto with zfc.

auto with zfc.

auto with zfc.
Qed.

Theorem Couple_Prod_IN :
 forall E1 E2 E1' E2' : Ens,
 IN (Couple E1' E2') (Prod E1 E2) -> IN E1' E1 /\ IN E2' E2.
simple induction E1; intros A1 f1 r1; simple induction E2; intros A2 f2 r2.
intros E1' E2' i.
elim (IN_EXType (Prod (sup A1 f1) (sup A2 f2)) (Couple E1' E2') i).
intros xx; elim xx; intros a1 a2 e.
change (EQ (Couple E1' E2') (Couple (f1 a1) (f2 a2))) in e.
cut (EQ E1' (f1 a1)).
cut (EQ E2' (f2 a2)).
intros e1 e2.
split.
apply IN_sound_left with (f1 a1); auto with zfc; simpl in |- *; exists a1;
 auto with zfc.
apply IN_sound_left with (f2 a2); auto with zfc; simpl in |- *; exists a2;
 auto with zfc.
apply Couple_inj_right with (A := E1') (B := f1 a1); auto with zfc.
apply Couple_inj_left with E2' (f2 a2); auto with zfc.
Qed.

Theorem IN_Prod_EXType :
 forall E E' E'' : Ens,
 IN E'' (Prod E E') ->
 EXType _ (fun A : Ens => EXType _ (fun B : Ens => EQ (Couple A B) E'')).
simple induction E; intros A f r; simple induction E'; intros A' f' r'.
intros; elim (IN_EXType (Prod (sup A f) (sup A' f')) E'').
simple induction x.
intros; exists (f a); exists (f' b); auto with zfc.
auto with zfc.
Qed.


(* 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                                                     *)

Require Import Peano_dec.
Require Import Transitive_Closure.
Require Import Union.
Require Import Termes.
Require Import Conv.

  Definition ord_norm1 := union _ subterm (transp _ red1).
  Definition ord_norm := clos_trans _ ord_norm1.

  Hint Unfold ord_norm1 ord_norm: coc.

  Lemma subterm_ord_norm : forall a b : term, subterm a b -> ord_norm a b.
auto 10 with coc sets.
Qed.

  Hint Resolve subterm_ord_norm: coc.

  Lemma red_red1_ord_norm :
   forall a b : term, red a b -> forall c : term, red1 b c -> ord_norm c a.
red in |- *.
simple induction 1; intros; auto with coc sets.
apply t_trans with N; auto with coc sets.
Qed.

  Lemma wf_subterm : well_founded subterm.
red in |- *.
simple induction a; intros; apply Acc_intro; intros.
inversion_clear H; inversion_clear H0.

inversion_clear H; inversion_clear H0.

inversion_clear H1; inversion_clear H2; auto with coc sets.

inversion_clear H1; inversion_clear H2; auto with coc sets.

inversion_clear H1; inversion_clear H2; auto with coc sets.
Qed.

  Lemma wf_ord_norm1 : forall t : term, sn t -> Acc ord_norm1 t.
unfold ord_norm1 in |- *.
intros.
apply Acc_union; auto with coc sets.
exact commut_red1_subterm.

intros.
apply wf_subterm.
Qed.

  Theorem wf_ord_norm : forall t : term, sn t -> Acc ord_norm t.
unfold ord_norm in |- *.
intros.
apply Acc_clos_trans.
apply wf_ord_norm1; auto with coc sets.
Qed.

  Definition norm_body (a : term) (norm : term -> term) :=
    match a with
    | Srt s => Srt s
    | Ref n => Ref n
    | Abs T t => Abs (norm T) (norm t)
    | App u v =>
        match norm u return term with
        | Abs _ b => norm (subst (norm v) b)
        | t => App t (norm v)
        end
    | Prod T U => Prod (norm T) (norm U)
    end.

  Definition compute_nf :
   forall t : term, sn t -> {u : term | red t u &  normal u}.
Proof.
intros.
elimtype (Acc ord_norm t).
clear H t.
intros [s| n| T t| u v| T U] _ norm_rec.
exists (Srt s); auto with coc.
red in |- *; red in |- *; intros.
inversion_clear H.

exists (Ref n); auto with coc.
red in |- *; red in |- *; intros.
inversion_clear H.

elim norm_rec with T; auto with coc; intros T' redT nT.
elim norm_rec with t; auto with coc; intros t' redt nt.
exists (Abs T' t'); auto with coc.
red in |- *; red in |- *; intros.
inversion_clear H.
elim nT with M'; trivial.
elim nt with M'; trivial.

elim norm_rec with v; auto with coc; intros v' redv nv.
elim norm_rec with u; auto with coc.
intros [s| n| T t| a b| T U] redu nu.
exists (App (Srt s) v'); auto with coc.
red in |- *; red in |- *; intros.
inversion_clear H.
inversion_clear H0.
elim nv with N2; trivial.

exists (App (Ref n) v'); auto with coc.
red in |- *; red in |- *; intros.
inversion_clear H.
inversion_clear H0.
elim nv with N2; trivial.

elim norm_rec with (subst v' t).
intros t' redt nt.
exists t'; trivial.
apply trans_red_red with (subst v' t); auto with coc.
apply trans_red with (App (Abs T t) v'); auto with coc.

apply red_red1_ord_norm with (App (Abs T t) v'); auto with coc.

exists (App (App a b) v'); auto with coc.
red in |- *; red in |- *; intros.
inversion_clear H.
elim nu with N1; trivial.
elim nv with N2; trivial.

exists (App (Prod T U) v'); auto with coc.
red in |- *; red in |- *; intros.
inversion_clear H.
elim nu with N1; trivial.
elim nv with N2; trivial.

elim norm_rec with T; auto with coc; intros T' redT nT.
elim norm_rec with U; auto with coc; intros U' redU nU.
exists (Prod T' U'); auto with coc.
red in |- *; red in |- *; intros.
inversion_clear H.
elim nT with N1; trivial.
elim nU with N2; trivial.

apply wf_ord_norm; auto with coc.
Defined.

  Definition eqterm : forall u v : term, {u = v} + {u <> v}.
Proof.
decide equality.
decide equality.
apply eq_nat_dec.
Defined.

  Definition is_conv :
   forall u v : term, sn u -> sn v -> {conv u v} + {~ conv u v}.
Proof.
intros u v snu snv.
elim compute_nf with (1 := snu); intros u' redu nu.
elim compute_nf with (1 := snv); intros v' redv nv.
elim eqterm with u' v'; [ intros same_nf | intros diff_nf ].
left.
apply trans_conv_conv with u'; auto with coc.
rewrite same_nf; apply sym_conv; auto with coc.

right; red in |- *; intro; apply diff_nf.
elim church_rosser with u' v'; auto with coc; intros.
rewrite (red_normal u' x); auto with coc.
rewrite (red_normal v' x); auto with coc.

apply trans_conv_conv with v; auto with coc.
apply trans_conv_conv with u; auto with coc.
apply sym_conv; auto with coc.
Defined.


(** Beginning of the file for GV definitions as described in

    Philip Wadler. 2012. Propositions as sessions. In Proceedings of the 17th
    ACM SIGPLAN international conference on Functional programming (ICFP '12).
    ACM, New York, NY, USA, 273-286. DOI=10.1145/2364527.2364568
    http://doi.acm.org/10.1145/2364527.2364568

    which is based on ``Classic GV'' by Simon Gay and Vasco Vasconcelos in

    Simon J. Gay and Vasco T. Vasconcelos. 2010. Linear type theory for
    asynchronous session types. J. Funct. Program. 20, 1 (January 2010),19-50.
    DOI=10.1017/S0956796809990268 http://dx.doi.org/10.1017/S0956796809990268

*)
Require Import Metatheory Coq.Program.Tactics Program.Equality.
Set Implicit Arguments.

(** The notion of kind is borrowed from

    Karl Mazurak, Jianzhou Zhao, and Steve Zdancewic. 2010. Lightweight linear
    types in system f°. In Proceedings of the 5th ACM SIGPLAN workshop on
    Types in language design and implementation (TLDI '10). ACM, New York, NY,
    USA, 77-88. DOI=10.1145/1708016.1708027
    http://doi.acm.org/10.1145/1708016.1708027

    but there is no subsumption rule here. In other words, kinds are just a
    mechanism by which to classify types. The rationale for including kinds is
    to allow a later extension to a System F-pop inspired language.

    In lemmas and theorems, k is used to range over kinds.
*)
Inductive kind : Set :=
  | lin : kind (* linear *)
  | un : kind (* unlimited *).

(** [typ] is ranged over by T, U and V. It differs slightly from the
    definition given in Wadler's paper in the following ways:

      * Session types are defined within this inductive type rather than
        mutually; a technical convenience since Coq mutually inductive
        types can be tricky to manipulate,
      * Choice and branch are binary; this matches the intuition of tensor
        product which is defined as binary and also maps better to the CP
        with and plus constructs which are also binary
*)
Inductive typ : Set :=
(* Session types section *)
  | typ_soutput : typ -> typ -> typ
  | typ_sinput : typ -> typ -> typ
  | typ_schoice : typ -> typ -> typ
  | typ_sbranch : typ -> typ -> typ
  | typ_oend : typ (* output end *)
  | typ_iend : typ (* input end *)
(* Other non-session GV types *)
  | typ_tensor :  typ -> typ -> typ
  | typ_labs : typ -> typ -> typ
  | typ_abs : typ -> typ -> typ
  | typ_unit : typ (* always unlimited *).

(** The notation for sessions has been altered from the standard presentation
    to fit within allowable notations in Coq.
*)
Notation "'!' T '#' S" := (typ_soutput T S) (at level 68,
                                             right associativity) : gv_scope.
Notation "'?' T '#' S" := (typ_sinput T S) (at level 68, right associativity).
Notation "S1 '<+>' S2" := (typ_schoice S1 S2) (at level 68,
                                               right associativity)
                                              : gv_scope.
Notation "S1 <&> S2" := (typ_sbranch S1 S2) (at level 68,
                                             right associativity) : gv_scope.
Notation "T ⊸ U" := (typ_labs T U) (at level 68, right associativity)
                                   : gv_scope.
Notation "T ⟶ U" := (typ_abs T U) (at level 68, right associativity)
                                  : gv_scope.
Notation "T <x> U" := (typ_tensor T U) (at level 68, right associativity)
                                     : gv_scope.
Delimit Scope gv_scope with gv.
Open Scope gv_scope.

(** [ty] as defined above is more general than the types handled by GV; the
    types are considered session types and so could, for example, appear in
    branch or choice constructs (e.g. a regular function type). To prevent
    this, a predicate [is_session] is defined over [typ] constructors to
    restrict where certain constructors may occur.

    S range over session types.
*)
Inductive is_session : typ -> Prop :=
  | is_output : forall (T: typ) S
                       (IS: is_session S),
                  is_session (! T # S)
  | is_input : forall (T: typ) S
                      (IS: is_session S),
                 is_session (? T # S)
  | is_choice : forall S1 S2 (IS1: is_session S1) (IS2: is_session S2),
                  is_session (S1 <+> S2)
  | is_branch : forall S1 S2 (IS1: is_session S1) (IS2: is_session S2),
                  is_session (S1 <&> S2)
  | is_oend : is_session typ_oend
  | is_iend : is_session typ_iend.

Hint Constructors is_session.

(** Well-formed types are types with the correct kind annotations. *)
Inductive wf_typ : typ -> kind -> Prop :=
(* Session types section *)
  | wf_output : forall k T S (WFT: wf_typ T k) (WFS: wf_typ S lin)
                       (IS: is_session S),
                  wf_typ (! T # S) lin
  | wf_input : forall k T S (WFT: wf_typ T k) (WFS: wf_typ S lin)
                      (IS: is_session S),
                 wf_typ (? T # S) lin
  | wf_choice : forall S1 S2 (WFS1: wf_typ S1 lin) (WFS2: wf_typ S2 lin)
                       (IS1: is_session S1) (IS2: is_session S2),
                  wf_typ (S1 <+> S2) lin
  | wf_branch : forall S1 S2 (WFS1: wf_typ S1 lin) (WFS2: wf_typ S2 lin)
                       (IS1: is_session S1) (IS2: is_session S2),
                  wf_typ (S1 <&> S2) lin
  | wf_oend : wf_typ typ_oend lin (* output end *)
  | wf_iend : wf_typ typ_iend lin (* input end *)
(* Other non-session GV types *)
  | wf_tensor : forall kt ku T U (WFT: wf_typ T kt) (WFU: wf_typ U ku),
                  wf_typ (T <x> U) lin
  | wf_labs : forall kt ku T U (WFT: wf_typ T kt) (WFU: wf_typ U ku),
                wf_typ (T ⊸ U) lin
  | wf_abs : forall kt ku T U (WFT: wf_typ T kt) (WFU: wf_typ U ku),
               wf_typ (T ⟶ U) un
  | wf_unit : wf_typ typ_unit un.

Hint Constructors wf_typ.

(** Define a duality relation on session types to specify that two session
    types are dual to each other.

    The computational view of duality cannot be used in the well-typed term
    relation because the proof of duality cannot be inferred for an arbitrary
    session type argument.
*)
Inductive are_dual : typ -> typ -> Prop :=
  | output_dual : forall k T (WFT: wf_typ T k) S S' (DU: are_dual S S'),
                    are_dual (! T # S) (? T # S')
  | input_dual : forall k T (WFT: wf_typ T k) S S' (DU: are_dual S S'),
                   are_dual (? T # S) (! T # S')
  | choice_dual : forall S1 S2 S1' S2'
                         (DU1: are_dual S1 S1') (DU2: are_dual S2 S2'),
                    are_dual (S1 <+> S2) (S1' <&> S2')
  | branch_dual : forall S1 S2 S1' S2'
                         (DU1: are_dual S1 S1') (DU2: are_dual S2 S2'),
                    are_dual (S1 <&> S2) (S1' <+> S2')
  | oend_dual : are_dual typ_oend typ_iend
  | iend_dual : are_dual typ_iend typ_oend.

Hint Constructors are_dual.

(** Only called on a session type. *)
Fixpoint dual_session (T:typ) :=
  match T with
    | ! A # B => ? A # (dual_session B)
    | ? A # B => ! A # (dual_session B)
    | A <+> B => (dual_session A) <&> (dual_session B)
    | A <&> B => (dual_session A) <+> (dual_session B)
    | typ_iend => typ_oend
    | typ_oend => typ_iend
    | _ => T
  end.

(** Define a label type for binary branch and choice. *)
Inductive label : Set :=
  | lb_inr : label
  | lb_inl : label.

Inductive var : Set :=
  | bvar : nat -> var
  | fvar : atom -> var.

Coercion bvar : nat >-> var.
Coercion fvar : atom >-> var.

(** Define the terms of GV. We follow the approach in the UPenn Metatheory
    library, defining free variables as atoms and bound variables as de
    Bruijn indices.

*)
Inductive term : Set :=
  | tm_var : var -> term
  | tm_unit : term
  | tm_weak : var -> term -> term
  | tm_abs : typ -> term -> term
  | tm_iabs : term -> term (* introduction rule for unlimited abstraction. *)
  | tm_eabs : term -> term (* elimination rule for unlimited abstraction. *)
  | tm_app : term -> term -> term
  | tm_pair : term -> term -> term
  | tm_let : typ -> typ -> term -> term -> term
  | tm_send : term -> term -> term
  | tm_recv : term -> term
  | tm_select : label -> term -> term
  | tm_case : term -> term -> term -> term
  | tm_connect : typ -> term -> term -> term
  | tm_end : term -> term.

Coercion tm_var : var >-> term.

Notation "λ! M" := (tm_iabs M) (at level 68, right associativity) : gv_scope.
Notation "λ? M" := (tm_eabs M) (at level 68, right associativity) : gv_scope.

(** In the style of ``Engineering Formal Metatheory'' we define
    substitution of expressions for atoms and opening of expressions with
    bound variables.
*)

(** The following definition of substitution for a free variable assumes the
    term to be substituted is locally closed.
*)
Fixpoint subst (x: atom) (u: term) (t: term) : term :=
  match t with
  | tm_var (fvar y) => if x == y then u else (tm_var y)
  | tm_weak v m => tm_weak v (subst x u m)
  | tm_abs T b => tm_abs T (subst x u b)
  | tm_iabs M => tm_iabs (subst x u M)
  | tm_eabs M => tm_eabs (subst x u M)
  | tm_app m n => tm_app (subst x u m) (subst x u n)
  | tm_pair p q => tm_pair (subst x u p) (subst x u q)
  | tm_let T U m n => tm_let T U (subst x u m) (subst x u n)
  | tm_send m n => tm_send (subst x u m) (subst x u n)
  | tm_recv m => tm_recv (subst x u m)
  | tm_select l m => tm_select l (subst x u m)
  | tm_case m nl nr
    => tm_case (subst x u m) (subst x u nl) (subst x u nr)
  | tm_connect T m n => tm_connect T (subst x u m) (subst x u n)
  | tm_end m => tm_end (subst x u m)
  | _ => t
  end.

Notation "[ x ~> u ] t" := (subst x u t) (at level 68) : gv_scope.

(** Opening a term t is replacing an unbound variable with index k with term
    u. Assume u is locally closed and is only substituted once if it contains
    free variables.
*)
Fixpoint open_rec (k: nat) (u: term) (t: term) :=
  match t with
  | tm_var (bvar n) => if k == n then u else (tm_var n)
  | tm_weak v m => tm_weak v (open_rec k u m)
  | tm_abs T b => tm_abs T (open_rec (S k) u b)
  | tm_iabs M => tm_iabs (open_rec k u M)
  | tm_eabs M => tm_eabs (open_rec k u M)
  | tm_app m n => tm_app (open_rec k u m) (open_rec k u n)
  | tm_pair p q => tm_pair (open_rec k u p) (open_rec k u q)
  | tm_let T U m n
    => tm_let T U (open_rec k u m) (open_rec (S (S k)) u n)
  | tm_send m n => tm_send (open_rec k u m) (open_rec k u n)
  | tm_recv m => tm_recv (open_rec k u m)
  | tm_select l m => tm_select l (open_rec k u m)
  | tm_case m nl nr
    => tm_case (open_rec k u m) (open_rec (S k) u nl) (open_rec (S k) u nr)
  | tm_connect T m n
    => tm_connect T (open_rec (S k) u m) (open_rec (S k) u n)
  | tm_end m => tm_end (open_rec k u m)
  | _ => t
  end.

Notation "{ k ~> u } t" := (open_rec k u t) (at level 68,
                                             right associativity) : gv_scope.

(** Opening a term t is replacing the unbound variable with index 0 with term
    u. Assume u is locally closed and is only substituted once if it contains
    free variables.
*)
Definition open t u := open_rec 0 u t.

Hint Unfold open.

Fixpoint GVFV (t: term) :=
  match t with
  | tm_var (fvar y) => singleton y
  | tm_weak (fvar y) m => singleton y `union` GVFV m
  | tm_weak _ m => GVFV m
  | tm_abs T b => GVFV b
  | tm_iabs m => GVFV m
  | tm_eabs m => GVFV m
  | tm_app m n => GVFV m `union` GVFV n
  | tm_pair p q => GVFV p `union` GVFV q
  | tm_let T U m n => GVFV m `union` GVFV n
  | tm_send m n => GVFV m `union` GVFV n
  | tm_recv m => GVFV m
  | tm_select l m => GVFV m
  | tm_case m nl nr => GVFV m `union` GVFV nl `union` GVFV nr
  | tm_connect T m n => GVFV m `union` GVFV n
  | tm_end m => GVFV m
  | _ => empty
  end.

(** A locally closed term has no unbounded variables. Note also using
    cofinite quantification with binding constructs. *)
Inductive lc : term -> Prop :=
  | lc_var : forall (x:atom), lc (tm_var x)
  | lc_unit : lc tm_unit
  | lc_weak : forall (x:atom) M (MLC: lc M), lc (tm_weak x M)
  | lc_abs : forall (L:atoms) k T M
                    (WFT: wf_typ T k)
                    (CO: forall (x:atom), x `notin` L -> lc (open M x)),
               lc (tm_abs T M)
  | lc_app : forall M N (MLC: lc M) (NLC: lc N), lc (tm_app M N)
  | lc_iabs : forall M (MLC: lc M), lc (λ! M)
  | lc_eabs : forall M (MLC: lc M), lc (λ? M)
  | lc_pair : forall M N (MLC: lc M) (NLC: lc N), lc (tm_pair M N)
  | lc_let : forall (L:atoms) T U M N
                    (WF: wf_typ (T <x> U) lin)
                    (MLC: lc M)
                    (NCO: forall (x y:atom)
                                 (XL: x `notin` L)
                                 (YL: y `notin` L `union` singleton x),
                            lc ({1 ~> x} (open N y))),
               lc (tm_let T U M N)
  | lc_send : forall M N (MLC: lc M) (NLC: lc N), lc (tm_send M N)
  | lc_recv : forall M (MLC: lc M), lc (tm_recv M)
  | lc_select : forall lbl M (LCM: lc M), lc (tm_select lbl M)
  | lc_case : forall (L:atoms) M NL NR (MLC: lc M)
                     (NLCO: forall (x:atom), x `notin` L -> lc (open NL x))
                     (NRCO: forall (x:atom), x `notin` L -> lc (open NR x)),
                lc (tm_case M NL NR)
  | lc_connect : forall (L:atoms) T M N
                        (WFT: wf_typ T lin)
                        (MCO: forall (x:atom), x `notin` L -> lc (open M x))
                        (NCO: forall (x:atom), x `notin` L -> lc (open N x)),
                   lc (tm_connect T M N)
  | lc_end : forall M (MLC: lc M), lc (tm_end M).

Hint Constructors lc.

(** Typing environments are lists of (atom,typ) pairs. *)
Definition tenv := list (atom * typ).

Definition un_env (G : tenv) : Prop :=
  forall x (IN: x `in` dom G),
    exists T, wf_typ T un /\ binds x T G.

(** To get Coq to accept the '~' notation used here, we need to make sure t
    and T are parsed as identifiers.

    Reserved Notation "G |- t ~ T" (at level 68, t ident, T ident).

    Inductive wt_tm : tenv -> term -> forall k, typ k -> Prop :=
      | wt_tm_unid : forall x T, (x ~ inr T) |- x ~ T
    where "G '|-' t ~ T" := (wt_tm G t T) : gv_scope.

    However, I'm going to adopt the ∈ notation below since it will be easier
    to differentiate between the environment notation.
*)
Reserved Notation "Φ ⊢ t ∈ T" (at level 69).

Inductive wt_tm : tenv -> term -> typ -> Prop :=
  | wt_tm_id : forall k T x (WFT: wf_typ T k), x ~ T ⊢ x ∈ T
  | wt_tm_unit : nil ⊢ tm_unit ∈ typ_unit
  | wt_tm_weaken : forall Φ x N k T U
                          (WFT: wf_typ T un) (WFU: wf_typ U k)
                          (UN: uniq (x ~ T ++ Φ))
                          (WT: Φ ⊢ N ∈ U),
                     x ~ T ++ Φ ⊢ (tm_weak x N) ∈ U
  | wt_tm_labs : forall (L: atoms) Φ T U M
                        (WF: wf_typ (T ⊸ U) lin)
                        (UN: uniq Φ)
                        (WT: forall (x:atom),
                               x `notin` L ->
                               x ~ T ++ Φ ⊢ (open M x) ∈ U),
                   Φ ⊢ tm_abs T M ∈ T ⊸ U
  | wt_tm_lapp : forall Φ Ψ T U M N
                        (WF: wf_typ (T ⊸ U) lin)
                        (UN: uniq (Φ ++ Ψ))
                        (WTM: Φ ⊢ M ∈ T ⊸ U) (WTN: Ψ ⊢ N ∈ T),
                   Φ ++ Ψ ⊢ (tm_app M N) ∈ U
  | wt_tm_iabs : forall Φ T U M
                       (WF: wf_typ (T ⟶ U) un)
                       (UN: uniq Φ)
                       (WT: Φ ⊢ M ∈ T ⊸ U) (UL: un_env Φ),
                  Φ ⊢ λ! M ∈ T ⟶ U
  | wt_tm_eabs : forall Φ T U M
                       (WF: wf_typ (T ⊸ U) lin)
                       (UN: uniq Φ)
                       (WT: Φ ⊢ M ∈ T ⟶ U),
                  Φ ⊢ λ? M ∈ T ⊸ U
  | wt_tm_pair : forall Φ Ψ T U M N
                        (WF: wf_typ (T <x> U) lin)
                        (UN: uniq (Φ ++ Ψ))
                        (WTM: Φ ⊢ M ∈ T) (WTN: Ψ ⊢ N ∈ U),
                   Φ ++ Ψ ⊢ (tm_pair M N) ∈ T <x> U
  | wt_tm_let :
      forall (L:atoms) Φ Ψ kv T U V M N
             (WF: wf_typ (T <x> U) lin) (WFV: wf_typ V kv)
             (UN: uniq (Φ ++ Ψ))
             (WTM: Φ ⊢ M ∈ T <x> U)
             (WTN: forall (x y:atom)
                          (XL: x `notin` L)
                          (YL: y `notin` L `union` singleton x),
                     x ~ T ++ y ~ U ++ Ψ ⊢ ({1 ~> x} (open N y)) ∈ V),
        Φ ++ Ψ ⊢ (tm_let T U M N) ∈ V
  | wt_tm_send : forall Φ Ψ M T N S
                        (WF: wf_typ (! T # S) lin)
                        (UN: uniq (Φ ++ Ψ))
                        (WTM: Φ ⊢ M ∈ T) (WTN: Ψ ⊢ N ∈ ! T # S),
                   Φ ++ Ψ ⊢ tm_send M N ∈ S
  | wt_tm_recv : forall Φ M T S
                        (WF: wf_typ (? T # S) lin)
                        (UN: uniq Φ)
                        (WT: Φ ⊢ M ∈ ? T # S),
                   Φ ⊢ tm_recv M ∈ typ_tensor T S
  | wt_tm_l_select : forall Φ M S1 S2 (UN: uniq Φ)
                            (WF: wf_typ (S1 <+> S2) lin)
                            (WT: Φ ⊢ M ∈ (S1 <+> S2)),
                       Φ ⊢ tm_select lb_inl M ∈ S1
  | wt_tm_r_select : forall Φ M S1 S2
                            (UN: uniq Φ)
                            (WF: wf_typ (S1 <+> S2) lin)
                            (WT: Φ ⊢ M ∈ (S1 <+> S2)),
                       Φ ⊢ tm_select lb_inr M ∈ S2
  | wt_tm_case : forall (L:atoms) Φ Ψ M NL NR S1 S2 kt T
                        (UN: uniq (Φ ++ Ψ))
                        (WF: wf_typ (S1 <&> S2) lin)
                        (WFT: wf_typ T kt)
                        (WTM: Φ ⊢ M ∈ (S1 <&> S2))
                        (WTNL: forall (x:atom) (NLH: x `notin` L),
                                 x ~ S1 ++ Ψ ⊢ (open NL x) ∈ T)
                        (WTNR: forall (x:atom) (NL: x `notin` L),
                                 x ~ S2 ++ Ψ ⊢ (open NR x) ∈ T),
                   Φ ++ Ψ ⊢ (tm_case M NL NR) ∈ T
  | wt_tm_connect : forall (L:atoms) Φ Ψ M N S S' kt T
                           (UN: uniq (Φ ++ Ψ))
                           (DU: are_dual S S')
                           (WF: wf_typ T kt)
                           (WTM: forall (x:atom) (NL: x `notin` L),
                                   x ~ S ++ Φ ⊢ (open M x) ∈ typ_oend)
                           (WTN: forall (x:atom) (NL: x `notin` L),
                                   x ~ S' ++ Ψ ⊢ (open N x) ∈ T),
                      Φ ++ Ψ ⊢ (tm_connect S M N) ∈ T
  | wt_tm_end : forall Φ M
                       (UN: uniq Φ)
                       (WT: Φ ⊢ M ∈ typ_iend),
                  Φ ⊢ tm_end M ∈ typ_unit
where "Φ ⊢ t ∈ T" := (wt_tm Φ t T) : gv_scope.

Hint Constructors wt_tm.


Require Import VST.msl.msl_direct.
Require Import FunctionalExtensionality.
Require Import RamifyCoq.msl_ext.ramify_tactics.
Require Import RamifyCoq.msl_ext.overlapping_direct.
Require Import RamifyCoq.heap_model_direct.SeparationAlgebra.

Definition mapsto (x y: adr) : pred world :=
  fun w => x <> 0 /\
    (forall a, a <> x -> lookup_fpm w a = None) /\
    lookup_fpm w x = Some y.

Lemma join_sub_mapsto: forall w1 w2 x y, join_sub w1 w2 -> (mapsto x y * TT)%pred w1 -> (mapsto x y * TT)%pred w2.
Proof.
  intros. destruct_sepcon H0 h. destruct H as [w3 ?]. try_join h2 w3 m. exists h1, m. split; auto.
Qed.

Lemma mapsto_unique: forall x a b w, ~ (mapsto x a * mapsto x b)%pred w.
Proof.
  repeat intro. destruct_sepcon H h. destruct H0 as [? [? ?]]. destruct H1 as [? [? ?]]. destruct h1 as [f1 m1].
  destruct h2 as [f2 m2]. destruct w as [fw mw]. hnf in *. simpl in *. specialize (H x). rewrite H3 in *. rewrite H5 in *.
  inversion H. inversion H9.
Qed.

Lemma mapsto__precise: forall p, precise (EX  v : adr, mapsto p v).
Proof.
  intros.
  repeat intro.
  destruct H1 as [w3 ?], H2 as [w4 ?]; destruct H as [? [? [? ?]]], H0 as [? [? [? ?]]].
  destruct w1 as [v1 f1]; destruct w2 as [v2 f2]; destruct w3 as [v3 f3]; destruct w4 as [v4 f4]; destruct w as [v f].
  hnf in H1, H2; simpl in *. apply exist_ext. extensionality mm. destruct (eq_dec mm p).
  + subst. specialize (H1 p). specialize (H2 p). rewrite H4 in *. rewrite H6 in *. inversion H1.
    - subst. inversion H2.
      * rewrite H10, H12. auto.
      * subst. rewrite <- H8 in H2. rewrite <- H11 in H2. hnf in H2. inversion H2. subst. inversion H15.
    - subst. rewrite <- H8 in H1. rewrite <- H9 in H1. hnf in H1. inversion H1. subst. inversion H13.
  + specialize (H3 mm n). specialize (H5 mm n). rewrite H3, H5. auto.
Qed.

Lemma mapsto_conflict: forall p1 p2 v1 v2, p1 = p2 -> mapsto p1 v1 * mapsto p2 v2 |-- FF.
Proof.
  intros.
  subst.
  intro w. apply mapsto_unique.
Qed.

Lemma disj_mapsto_: forall p1 p2, p1 <> p2 -> disjointed (EX v1: adr, mapsto p1 v1) (EX v2: adr, mapsto p2 v2).
Proof.
  intros.
  hnf. intros. destruct H2 as [v1 ?]. destruct H3 as [v2 ?].
  generalize H2; intro Hx. generalize H3; intro Hy.
  destruct h12 as [f12 x12] eqn:? . hnf in H2. simpl in H2. destruct H2 as [? [? ?]].
  destruct h23 as [f23 x23] eqn:? . hnf in H3. simpl in H3. destruct H3 as [? [? ?]].
  remember (fun xx : adr => if eq_nat_dec xx p1 then Some v1 else (if eq_nat_dec xx p2 then Some v2 else None)) as f.
  assert (finMap f). {
    exists (p1 :: p2 :: nil). intro z. intros. rewrite Heqf. destruct (eq_nat_dec z p1).
    + subst. exfalso. apply H8. apply in_eq.
    + destruct (eq_nat_dec z p2).
      - subst. exfalso. apply H8. apply in_cons, in_eq.
      - trivial.
  } remember (exist (finMap (B:=adr)) f H8) as ff.
  assert (join h12 h23 ff). {
    rewrite Heqw, Heqw0, Heqff. hnf; simpl. rewrite Heqf. intro z. destruct (eq_nat_dec z p1).
    + rewrite e in *. rewrite H5. generalize (H6 p1 H); intro HS. rewrite HS. constructor.
    + destruct (eq_nat_dec z p2).
      - rewrite e in *. rewrite H7. generalize (H4 p2 n); intro HS. rewrite HS. constructor.
      - specialize (H4 z n). specialize (H6 z n0). rewrite H4, H6. constructor.
  } rewrite <- Heqw0 in *. rewrite <- Heqw in *.
  assert (emp h2). {
    apply join_sub_joins_identity with h23.
    + exists h3; auto.
    + try_join h2 h23 t. exists t; auto.
  } elim_emp_direct.
  split; auto. exists ff; auto.
Qed.

Lemma mapsto_inj: forall p v1 v2, mapsto p v1 && mapsto p v2 |-- !! (v1 = v2).
Proof.
  intros; simpl; intro w; intros. destruct H.
  destruct H as [? [? ?]]. destruct H0 as [? [? ?]]. rewrite H2 in H4.
  inversion H4. subst; auto.
Qed.


(** * Mutable map whose lookup operation provides a default value.*)

(* begin hide *)
Set Implicit Arguments.
Set Contextual Implicit.

From Coq Require Import Morphisms.

From ExtLib Require Import
     Core.RelDec.

From ExtLib.Structures Require
     Maps.

From Paco Require Import paco.

From ITree Require Import
     Basics.HeterogeneousRelations
     ITree
     ITreeFacts
     Eq.Paco2
     Events.State
     Events.StateFacts
     Events.MapDefault.

Import ITree.Basics.Basics.Monads.
Import Structures.Maps.
(* end hide *)

Section MapFacts.

  Variables (K V : Type).
  Context {map : Type}.
  Context {M : Map K V map}.
  Context {MOk: MapOk eq M}.
  Context {Kdec: @RelDec K eq}.
  Context {KdecOk: RelDec_Correct Kdec}.

  (* Should move to extlib *)
  Lemma lookup_add_eq: forall k v s, lookup k (add k v s) = Some v.
  Proof.
    intros.
    rewrite mapsto_lookup; apply mapsto_add_eq.
    Unshelve.
    2: typeclasses eauto.
  Qed.

  (* Should move to extlib *)
  Lemma lookup_add_neq: forall k k' v s, k' <> k -> lookup k (add k' v s) = lookup k s.
  Proof.
    intros.
    generalize (@mapsto_add_neq _ _ _ eq _ _ s k' v k H); clear H; intros H.
    setoid_rewrite <- mapsto_lookup in H.
    destruct (lookup k s) as [v' |] eqn:EQ.
    - specialize (H v').
      apply H; auto.
    - destruct (lookup k (add k' v s)) as [v' |] eqn:EQ'; [| reflexivity].
      specialize (H v').
      symmetry; apply H; auto.
  Qed.

  (* Should move to extlib *)
  Lemma lookup_remove_eq:
    forall k s, lookup k (remove k s) = None.
  Proof.
    intros.
    match goal with
      |- ?x = _ => destruct x eqn:EQ
    end; [| reflexivity].
    rewrite mapsto_lookup in EQ.
    exfalso; eapply mapsto_remove_eq; eauto.
  Qed.

  (* Should move to extlib *)
  Lemma lookup_remove_neq:
    forall k k' s, k <> k' -> lookup k (remove k' s) = lookup k s.
  Proof.
    intros.
    match goal with
      |- ?x = _ => destruct x eqn:EQ
    end.
    - rewrite mapsto_lookup in EQ.
      apply mapsto_remove_neq in EQ; auto.
      symmetry; rewrite mapsto_lookup; eauto.
    -  match goal with
         |- _ = ?x => destruct x eqn:EQ'
       end; auto.
       rewrite mapsto_lookup in EQ'.
       eapply mapsto_remove_neq in EQ'; eauto.
       rewrite <- mapsto_lookup in EQ'.
       rewrite EQ in EQ'; inv EQ'.
       Unshelve.
       all: typeclasses eauto.
  Qed.

  Global Instance eq_map_refl {d} : Reflexive (@eq_map _ _ _ _ d).
  Proof.
    red. intros. unfold eq_map. tauto.
  Qed.

  Global Instance eq_map_sym {d} : Symmetric (@eq_map _ _ _ _ d).
  Proof.
    repeat intro.
    unfold eq_map in H.
    rewrite H.
    reflexivity.
  Qed.

  Global Instance eq_map_trans {d} : Transitive (@eq_map _ _ _ _ d).
  Proof.
    repeat intro.
    unfold eq_map in *.
    rewrite H. rewrite H0. reflexivity.
  Qed.

  Section Relations.
  Context {R1 R2 : Type}.
  Variable RR : R1 -> R2 -> Prop.

  Definition map_default_eq d {E}
    : (stateT map (itree E) R1) -> (stateT map (itree E) R2) -> Prop :=
    fun t1 t2 => forall s1 s2, (@eq_map _ _ _ _ d) s1 s2 -> eutt (prod_rel (@eq_map _ _ _ _ d) RR) (t1 s1) (t2 s2).

  End Relations.

  Lemma eq_map_add:
    forall (d : V) (s1 s2 : map) (k : K) (v : V), (@eq_map _ _ _ _ d) s1 s2 -> (@eq_map _ _ _ _ d) (add k v s1) (add k v s2).
  Proof.
    intros d s1 s2 k v H.
    unfold eq_map in *.
    intros k'.
    destruct (rel_dec_p k k').
    - subst.
      unfold lookup_default in *.
      rewrite 2 lookup_add_eq; reflexivity.
    - unfold lookup_default in *.
      rewrite 2 lookup_add_neq; auto.
  Qed.

  Lemma eq_map_remove:
    forall (d : V) (s1 s2 : map) (k : K), (@eq_map _ _ _ _ d) s1 s2 -> (@eq_map _ _ _ _ d) (remove k s1) (remove k s2).
  Proof.
    intros d s1 s2 k H.
    unfold eq_map in *; intros k'.
    unfold lookup_default.
    destruct (rel_dec_p k k').
    - subst; rewrite 2 lookup_remove_eq; auto.
    - rewrite 2 lookup_remove_neq; auto.
      apply H.
  Qed.

  Lemma handle_map_eq :
    forall d E X (s1 s2 : map) (m : mapE K d X),
      (@eq_map _ _ _ _ d) s1 s2 ->
      eutt (prod_rel (@eq_map _ _ _ _ d) eq) (handle_map m s1) ((handle_map m s2) : itree E (map * X)).
  Proof.
    intros.
    destruct m; cbn; red; apply eqit_Ret; constructor; cbn; auto.
    - apply eq_map_add. assumption.
    - apply eq_map_remove. assumption.
  Qed.

  Global Instance Proper_handle_map {E R}  d :
    Proper (eq ==> map_default_eq eq d) (@handle_map _ _ _ _ E d R).
  Proof.
    repeat intro.
    subst.
    apply handle_map_eq.
    assumption.
  Qed.

  (* This lemma states that the operations provided by [handle_map] respect
     the equivalence on the underlying map interface *)
  Lemma interp_map_id d {E X} (t : itree (mapE K d +' E) X) :
    map_default_eq eq d (interp_map t) (interp_map t).
  Proof.
    unfold map_default_eq, interp_map; intros.
    revert t s1 s2 H.
    ginit.
    pcofix CH.
    intros.
    repeat rewrite unfold_interp_state. unfold _interp_state.
    destruct (observe t).
    - gstep. constructor. constructor; auto.
    - gstep. constructor. gbase. apply CH. assumption.
    - guclo eqit_clo_bind. econstructor.
      unfold pure_state.
      destruct e.
      + cbn. eapply eqit_mon; [ exact (fun x => x) .. | | apply handle_map_eq; assumption ].
        auto. auto. intros.  apply PR.
      + cbn. apply eqit_Vis. intros.  apply eqit_Ret. constructor; auto.
      + intros. destruct u1. destruct u2. cbn.
        destruct H as [H1 H2]; cbn in H1, H2; subst.
        gstep; constructor.
        gbase. apply CH. assumption.
  Qed.

  Global Instance interp_map_proper {R E d} {RR : R -> R -> Prop} :
    Proper ((eutt RR) ==> (@map_default_eq _ _ RR d E)) (@interp_map _ _ _ _ E d R).
  Proof.
    unfold map_default_eq, interp_map.
    repeat intro.
    revert x y H s1 s2 H0.
    einit.
    ecofix CH.
    intros.
    rewrite! unfold_interp_state.
    punfold H0. red in H0.
    revert s1 s2 H1.
    induction H0; intros; subst; simpl; pclearbot.
    - eret.
    - etau.
    - ebind.
      apply pbc_intro_h with (RU := prod_rel (@eq_map _ _ _ _ d) eq).
      { (* SAZ: I must be missing some lemma that should solve this case *)
        unfold case_. unfold Case_sum1, case_sum1.
        destruct e. apply handle_map_eq. assumption.
        unfold pure_state.
        pstep. econstructor. intros. constructor. pfold. econstructor. constructor; auto.
      }
      intros. destruct H as [HH1 ->].
      estep; constructor. ebase.
    - rewrite tau_euttge, unfold_interp_state.
      eauto.
    - rewrite tau_euttge, unfold_interp_state.
      eauto.
  Qed.

End MapFacts.


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

Local Open Scope Z_scope.

Section SpecLow.

  Definition rvic_set_pending_spec0 (rvic: Pointer) (intid: Z64) (adt: RData) : option RData :=
    match rvic, intid with
    | (_rvic_base, _rvic_ofst), VZ64 _intid =>
      when'' _t'1_base, _t'1_ofst == get_rvic_pending_bits_spec (_rvic_base, _rvic_ofst) adt;
      rely is_int _t'1_ofst;
      rely is_int64 _intid;
      when adt == rvic_set_flag_spec (VZ64 _intid) (_t'1_base, _t'1_ofst) adt;
      Some adt
     end
    .

End SpecLow.


(**************************  uc/OS-II  *******************************)
(*************************** OS_CORE.C *******************************)
(**Proof of Internal Fucntion: void OS_EventTaskWait(OS_EVENT* pevent) **)
(**************************** Code:***********************************)
(*
Void ·OS_EventTaskWait·(⌞pevent @ OS_EVENT∗⌟)··{
       ⌞ ⌟;

1       OSTCBCur′→OSTCBEventPtr =ₑ pevent′;ₛ
2       OSRdyTbl′[OSTCBCur′→OSTCBY] =ₑ
                 OSRdyTbl′[OSTCBCur′→OSTCBY] &ₑ (∼OSTCBCur′→OSTCBBitX);ₛ
3       If (OSRdyTbl′[OSTCBCur′→OSTCBY] ==ₑ ′0)
        {
4           OSRdyGrp′ =ₑ OSRdyGrp′ &ₑ (∼OSTCBCur′→OSTCBBitY)
        };ₛ
5       pevent′→OSEventTbl[OSTCBCur′→OSTCBY] =ₑ
               pevent′→OSEventTbl[OSTCBCur′→OSTCBY] |ₑ OSTCBCur′→OSTCBBitX;ₛ
6       pevent′→OSEventGrp =ₑ pevent′→OSEventGrp |ₑ OSTCBCur′→OSTCBBitY;ₛ
7       RETURN
}·.
*)

(* Require Import ucert. *)
Require Import ucos_include.
Require Import OSETWaitPure.
Open Scope code_scope.

Lemma OSEventTaskWait_proof:
    forall tid vl p r ll,
      Some p =
      BuildPreI os_internal OS_EventTaskWait
                  vl ll OS_EventTaskWaitPre tid ->
      Some r =
      BuildRetI os_internal OS_EventTaskWait vl ll OS_EventTaskWaitPost tid ->
      exists t d1 d2 s,
        os_internal OS_EventTaskWait = Some (t, d1, d2, s) /\
        {|OS_spec , GetHPrio, OSLInv, I, r, Afalse|}|- tid {{p}} s {{Afalse}}.
Proof.
  init_spec.
  hoare unfold.

  hoare forward.
  hoare unfold.

  lets Hi3: range_ostcby H.
  destruct Hi3 as [Hi3 Hi2].
  assert (Z.to_nat (Int.unsigned i3) < length v'0)%nat.
  {
    rewrite H8.
    unfold OS_RDY_TBL_SIZE.

    apply z_le_7_imp_n;auto.
    omega.
  }

  lets Hx: array_int8u_nth_lt_len H2 H12.
  Import DeprecatedTactic.
  mytac.
  hoare forward.
  go.
  (* simpl;splits;pauto. *)

  rewrite H8.
  unfold OS_RDY_TBL_SIZE.
  simpl Z.of_nat.
  auto.

(* ** ac:   Locate array_type_vallist_match_imp_rule_type_val_match. *)
  Import symbolic_lemmas.

  eapply array_type_vallist_match_imp_rule_type_val_match.
  rewrite H8.
  unfold OS_RDY_TBL_SIZE.

  apply z_le_7_imp_n;auto.
  omega.
  auto.

  go.
  (* simpl;splits;pauto. *)
  unfold val_inj.
  unfold and.
  rewrite H27.
  auto.

  go.
  (* simpl;splits;pauto. *)
  unfold OS_RDY_TBL_SIZE.
  simpl Z.of_nat.
  auto.
  rewrite H8.
  unfold OS_RDY_TBL_SIZE.
  simpl Z.of_nat.
  auto.
  (*
  Focus 2.
  hoare lift 8%nat pre.
  apply backward_rule1 with Afalse.
  intros.

  sep remember (1::nil)%nat in H2.
  simpl in H2.
  mytac;auto.
  apply pfalse_rule.
   *)
  unfold AOSRdyGrp.
  hoare forward.
  (* simpl;splits;pauto. *)
  go.
  rewrite H27.

  rewrite <- update_nth_val_length_eq.
  rewrite H8.
  unfold OS_RDY_TBL_SIZE.
  simpl Z.of_nat.
  auto.
  rewrite len_lt_update_get_eq.
  rewrite H27.
  simpl.
  rtmatch_solve.
  apply int_lemma1;auto.
  rewrite H8.
  unfold OS_RDY_TBL_SIZE.
  simpl Z.of_nat.
  auto.
  rewrite H27.
  rewrite len_lt_update_get_eq.
  simpl.
(* ** ac:   Locate "$". *)
  Local Open Scope int_scope.
  destruct (Int.eq (x&ᵢInt.not i2) ($ 0));auto.
  rewrite H8.
  unfold OS_RDY_TBL_SIZE.
  simpl Z.of_nat.
  auto.

  eapply forward_rule2.
  hoare forward.

  go.
  (* simpl;splits;pauto. *)
  unfold val_inj.
  unfold and.

  destruct v'1;tryfalse.
  auto.
  intros.
  apply H29.
  apply disj_rule;pure intro.
  clear  H35 H33 H34.

  assert (Z.to_nat (Int.unsigned i3) < length v'4)%nat.
  rewrite H9.
  unfold OS_EVENT_TBL_SIZE.
  apply z_le_7_imp_n;auto.
  omega.
  lets Hx:array_int8u_nth_lt_len H4 H33.
  mytac.
  hoare forward.
  go.
  (* simpl;splits;pauto. *)
  rewrite H9.
  unfold OS_EVENT_TBL_SIZE.
  simpl Z.of_nat.
  auto.
  rewrite H34.
  simpl.
  rtmatch_solve.
  go.
  (* simpl;splits;pauto. *)
  rewrite H34.
  simpl.
  auto.
  go.
  (* simpl;splits;pauto. *)

  eapply eq_int;auto.
  rewrite H9.
  unfold OS_EVENT_TBL_SIZE.
  simpl Z.of_nat.
  auto.

  hoare forward.
  go.
  go.

  hoare forward.
  simpl;auto.
  simpl;auto.
  2:simpl;auto.
  2:auto.
  4:simpl;auto.
  5:auto.
  6:simpl;auto.
  splits;auto.
  eapply nth_val'_imp_nth_val_int;eauto.
  simpl.

  rewrite <- unsigned_to_z_eq.
  rewrite unsigned_to_z_eq.
  rewrite H27.

  simpl.
  auto.
  rewrite unsigned_to_z_eq.
  eapply nth_val'_imp_nth_val_int;eauto.
  splits;auto.
  rewrite <- unsigned_to_z_eq.
  rewrite unsigned_to_z_eq.
  rewrite H34.
  simpl.
  auto.
  split;auto.
  rewrite H27.
  simpl.
  rewrite H27 in H30.
  rewrite len_lt_update_get_eq in H30.
  assert (Int.eq (x &ᵢInt.not i2) ($ 0) =true).
  clear -H30.
  simpl in H30.
  simpl.
  destruct (Int.eq (x &ᵢInt.not i2) ($ 0));tryfalse;auto.

  eapply event_wait_rl_tbl_grp';eauto.
  rewrite H8.
  simpl;auto.
  unfold and.
  unfold val_inj.
  rewrite H27.
  eapply idle_in_rtbl_hold;eauto.

  rtmatch_solve.
  apply int_lemma1;auto.
  split.
  rewrite H27.

  eapply array_type_vallist_match_int8u_update_hold;eauto.
  omega.
  rewrite H27.

  rewrite <- update_nth_val_length_eq.
  auto.
  go.

  rewrite H34.
  eapply event_wait_rl_tbl_grp;eauto.
  simpl;auto.
  apply array_type_vallist_match_hold;auto.
  rewrite H34.
  rtmatch_solve.
  apply int_unsigned_or_prop;auto.
  simpl;splits;auto.
  rtmatch_solve.
  rtmatch_solve.
  apply int_unsigned_or_prop';auto.
  pauto.
  pauto.
  pauto.

  (*------------------------------*)

  assert (Z.to_nat (Int.unsigned i3) < length v'4)%nat.
  rewrite H9.
  unfold OS_EVENT_TBL_SIZE.
  apply z_le_7_imp_n;auto.
  omega.
  lets Hx:array_int8u_nth_lt_len H4 H31.
  mytac.
  hoare forward.
  go.
  rewrite H9.
  unfold OS_EVENT_TBL_SIZE.
  simpl Z.of_nat.
  auto.
  rewrite H32.
  simpl.
  rtmatch_solve.
  go.
  rewrite H32.
  simpl.
  auto.
  go.

  eapply eq_int;auto.
  rewrite H9.
  unfold OS_EVENT_TBL_SIZE.
  simpl Z.of_nat.
  auto.

  hoare forward.
  go.
  go.

  hoare forward.
   simpl;auto.
  simpl;auto.
  2:simpl;auto.
  2:auto.
  4:simpl;auto.
  5:auto.
  6:simpl;auto.
  splits;auto.
  eapply nth_val'_imp_nth_val_int;eauto.
  simpl.

  rewrite <- unsigned_to_z_eq.
  rewrite unsigned_to_z_eq.
  rewrite H27.

  simpl.
  auto.
  rewrite unsigned_to_z_eq.
  eapply nth_val'_imp_nth_val_int;eauto.
  splits;auto.
  rewrite <- unsigned_to_z_eq.
  rewrite unsigned_to_z_eq.
  rewrite H32.
  simpl.
  auto.
  split;auto.
  rewrite H27.
  simpl.
  rewrite H27 in H30.
  rewrite len_lt_update_get_eq in H30.
  assert (Int.eq (x &ᵢInt.not i2) ($ 0) = false).
  clear -H30.
  simpl in H30.
  destruct H30.
  simpl in H.
  destruct (Int.eq (x &ᵢInt.not i2) ($ 0));tryfalse;auto.
  simpl in H.
  destruct (Int.eq (x &ᵢInt.not i2) ($ 0));tryfalse;auto.

  eapply event_wait_rl_tbl_grp'';eauto.
  rewrite H8.
  simpl;auto.
  unfold and.
  unfold val_inj.
  rewrite H27.
  eapply idle_in_rtbl_hold;eauto.

  rtmatch_solve.
  split.
  rewrite H27.

  eapply array_type_vallist_match_int8u_update_hold;eauto.
  omega.
  rewrite H27.

  rewrite <- update_nth_val_length_eq.
  auto.
  go.
  simpl.
  rewrite H32.
  eapply event_wait_rl_tbl_grp;eauto.
  simpl;auto.
  apply array_type_vallist_match_hold;auto.
  rewrite H32.
  rtmatch_solve.
  apply int_unsigned_or_prop;auto.
  simpl;splits;auto.
  rtmatch_solve.
  rtmatch_solve.
  apply int_unsigned_or_prop';auto.
  pauto.
  pauto.
  pauto.

Qed.


From iris.algebra Require Export ofe.
From iris Require Import options.

Record solution (F : oFunctor) := Solution {
  solution_car :> ofeT;
  solution_cofe : Cofe solution_car;
  solution_iso :> ofe_iso (oFunctor_apply F solution_car) solution_car;
}.
Existing Instance solution_cofe.

Module solver. Section solver.
Context (F : oFunctor) `{Fcontr : oFunctorContractive F}.
Context `{Fcofe : ∀ (T : ofeT) `{!Cofe T}, Cofe (oFunctor_apply F T)}.
Context `{Finh : Inhabited (oFunctor_apply F unitO)}.
Notation map := (oFunctor_map F).

Fixpoint A' (k : nat) : { C : ofeT & Cofe C } :=
  match k with
  | 0 => existT (P:=Cofe) unitO _
  | S k => existT (P:=Cofe) (@oFunctor_apply F (projT1 (A' k)) (projT2 (A' k))) _
  end.
Notation A k := (projT1 (A' k)).
Local Instance A_cofe k : Cofe (A k) := projT2 (A' k).

Fixpoint f (k : nat) : A k -n> A (S k) :=
  match k with 0 => OfeMor (λ _, inhabitant) | S k => map (g k,f k) end
with g (k : nat) : A (S k) -n> A k :=
  match k with 0 => OfeMor (λ _, ()) | S k => map (f k,g k) end.
Definition f_S k (x : A (S k)) : f (S k) x = map (g k,f k) x := eq_refl.
Definition g_S k (x : A (S (S k))) : g (S k) x = map (f k,g k) x := eq_refl.
Arguments f : simpl never.
Arguments g : simpl never.

Lemma gf {k} (x : A k) : g k (f k x) ≡ x.
Proof using Fcontr.
  induction k as [|k IH]; simpl in *; [by destruct x|].
  rewrite -oFunctor_map_compose -{2}[x]oFunctor_map_id.
  by apply (contractive_proper map).
Qed.
Lemma fg {k} (x : A (S (S k))) : f (S k) (g (S k) x) ≡{k}≡ x.
Proof using Fcontr.
  induction k as [|k IH]; simpl.
  - rewrite f_S g_S -{2}[x]oFunctor_map_id -oFunctor_map_compose.
    apply (contractive_0 map).
  - rewrite f_S g_S -{2}[x]oFunctor_map_id -oFunctor_map_compose.
    by apply (contractive_S map).
Qed.

Record tower := {
  tower_car k :> A k;
  g_tower k : g k (tower_car (S k)) ≡ tower_car k
}.
Instance tower_equiv : Equiv tower := λ X Y, ∀ k, X k ≡ Y k.
Instance tower_dist : Dist tower := λ n X Y, ∀ k, X k ≡{n}≡ Y k.
Definition tower_ofe_mixin : OfeMixin tower.
Proof.
  split.
  - intros X Y; split; [by intros HXY n k; apply equiv_dist|].
    intros HXY k; apply equiv_dist; intros n; apply HXY.
  - intros k; split.
    + by intros X n.
    + by intros X Y ? n.
    + by intros X Y Z ?? n; trans (Y n).
  - intros k X Y HXY n; apply dist_S.
    by rewrite -(g_tower X) (HXY (S n)) g_tower.
Qed.
Definition T : ofeT := OfeT tower tower_ofe_mixin.

Program Definition tower_chain (c : chain T) (k : nat) : chain (A k) :=
  {| chain_car i := c i k |}.
Next Obligation. intros c k n i ?; apply (chain_cauchy c n); lia. Qed.
Program Definition tower_compl : Compl T := λ c,
  {| tower_car n := compl (tower_chain c n) |}.
Next Obligation.
  intros c k; apply equiv_dist=> n.
  by rewrite (conv_compl n (tower_chain c k))
    (conv_compl n (tower_chain c (S k))) /= (g_tower (c _) k).
Qed.
Global Program Instance tower_cofe : Cofe T := { compl := tower_compl }.
Next Obligation.
  intros n c k; rewrite /= (conv_compl n (tower_chain c k)).
  apply (chain_cauchy c); lia.
Qed.

Fixpoint ff {k} (i : nat) : A k -n> A (i + k) :=
  match i with 0 => cid | S i => f (i + k) ◎ ff i end.
Fixpoint gg {k} (i : nat) : A (i + k) -n> A k :=
  match i with 0 => cid | S i => gg i ◎ g (i + k) end.
Lemma ggff {k i} (x : A k) : gg i (ff i x) ≡ x.
Proof using Fcontr. induction i as [|i IH]; simpl; [done|by rewrite (gf (ff i x)) IH]. Qed.
Lemma f_tower k (X : tower) : f (S k) (X (S k)) ≡{k}≡ X (S (S k)).
Proof using Fcontr. intros. by rewrite -(fg (X (S (S k)))) -(g_tower X). Qed.
Lemma ff_tower k i (X : tower) : ff i (X (S k)) ≡{k}≡ X (i + S k).
Proof using Fcontr.
  intros; induction i as [|i IH]; simpl; [done|].
  by rewrite IH Nat.add_succ_r (dist_le _ _ _ _ (f_tower _ X)); last lia.
Qed.
Lemma gg_tower k i (X : tower) : gg i (X (i + k)) ≡ X k.
Proof. by induction i as [|i IH]; simpl; [done|rewrite g_tower IH]. Qed.

Instance tower_car_ne k : NonExpansive (λ X, tower_car X k).
Proof. by intros X Y HX. Qed.
Definition project (k : nat) : T -n> A k := OfeMor (λ X : T, tower_car X k).

Definition coerce {i j} (H : i = j) : A i -n> A j :=
  eq_rect _ (λ i', A i -n> A i') cid _ H.
Lemma coerce_id {i} (H : i = i) (x : A i) : coerce H x = x.
Proof. unfold coerce. by rewrite (proof_irrel H (eq_refl i)). Qed.
Lemma coerce_proper {i j} (x y : A i) (H1 H2 : i = j) :
  x = y → coerce H1 x = coerce H2 y.
Proof. by destruct H1; rewrite !coerce_id. Qed.
Lemma g_coerce {k j} (H : S k = S j) (x : A (S k)) :
  g j (coerce H x) = coerce (Nat.succ_inj _ _ H) (g k x).
Proof. by assert (k = j) by lia; subst; rewrite !coerce_id. Qed.
Lemma coerce_f {k j} (H : S k = S j) (x : A k) :
  coerce H (f k x) = f j (coerce (Nat.succ_inj _ _ H) x).
Proof. by assert (k = j) by lia; subst; rewrite !coerce_id. Qed.
Lemma gg_gg {k i i1 i2 j} : ∀ (H1: k = i + j) (H2: k = i2 + (i1 + j)) (x: A k),
  gg i (coerce H1 x) = gg i1 (gg i2 (coerce H2 x)).
Proof.
  intros ? -> x. assert (i = i2 + i1) as -> by lia. revert j x H1.
  induction i2 as [|i2 IH]; intros j X H1; simplify_eq/=;
    [by rewrite coerce_id|by rewrite g_coerce IH].
Qed.
Lemma ff_ff {k i i1 i2 j} : ∀ (H1: i + k = j) (H2: i1 + (i2 + k) = j) (x: A k),
  coerce H1 (ff i x) = coerce H2 (ff i1 (ff i2 x)).
Proof.
  intros ? <- x. assert (i = i1 + i2) as -> by lia.
  induction i1 as [|i1 IH]; simplify_eq/=;
    [by rewrite coerce_id|by rewrite coerce_f IH].
Qed.

Definition embed_coerce {k} (i : nat) : A k -n> A i :=
  match le_lt_dec i k with
  | left H => gg (k-i) ◎ coerce (eq_sym (Nat.sub_add _ _ H))
  | right H => coerce (Nat.sub_add k i (Nat.lt_le_incl _ _ H)) ◎ ff (i-k)
  end.
Lemma g_embed_coerce {k i} (x : A k) :
  g i (embed_coerce (S i) x) ≡ embed_coerce i x.
Proof using Fcontr.
  unfold embed_coerce; destruct (le_lt_dec (S i) k), (le_lt_dec i k); simpl.
  - symmetry; by erewrite (@gg_gg _ _ 1 (k - S i)); simpl.
  - exfalso; lia.
  - assert (i = k) by lia; subst.
    rewrite (ff_ff _ (eq_refl (1 + (0 + k)))) /= gf.
    by rewrite (gg_gg _ (eq_refl (0 + (0 + k)))).
  - assert (H : 1 + ((i - k) + k) = S i) by lia.
    rewrite (ff_ff _ H) /= -{2}(gf (ff (i - k) x)) g_coerce.
    by erewrite coerce_proper by done.
Qed.
Program Definition embed (k : nat) (x : A k) : T :=
  {| tower_car n := embed_coerce n x |}.
Next Obligation. intros k x i. apply g_embed_coerce. Qed.
Instance: Params (@embed) 1 := {}.
Instance embed_ne k : NonExpansive (embed k).
Proof. by intros n x y Hxy i; rewrite /= Hxy. Qed.
Definition embed' (k : nat) : A k -n> T := OfeMor (embed k).
Lemma embed_f k (x : A k) : embed (S k) (f k x) ≡ embed k x.
Proof.
  rewrite equiv_dist=> n i; rewrite /embed /= /embed_coerce.
  destruct (le_lt_dec i (S k)), (le_lt_dec i k); simpl.
  - assert (H : S k = S (k - i) + (0 + i)) by lia; rewrite (gg_gg _ H) /=.
    by erewrite g_coerce, gf, coerce_proper by done.
  - assert (S k = 0 + (0 + i)) as H by lia.
    rewrite (gg_gg _ H); simplify_eq/=.
    by rewrite (ff_ff _ (eq_refl (1 + (0 + k)))).
  - exfalso; lia.
  - assert (H : (i - S k) + (1 + k) = i) by lia; rewrite (ff_ff _ H) /=.
    by erewrite coerce_proper by done.
Qed.
Lemma embed_tower k (X : T) : embed (S k) (X (S k)) ≡{k}≡ X.
Proof.
  intros i; rewrite /= /embed_coerce.
  destruct (le_lt_dec i (S k)) as [H|H]; simpl.
  - rewrite -(gg_tower i (S k - i) X).
    apply (_ : Proper (_ ==> _) (gg _)); by destruct (eq_sym _).
  - rewrite (ff_tower k (i - S k) X). by destruct (Nat.sub_add _ _ _).
Qed.

Program Definition unfold_chain (X : T) : chain (oFunctor_apply F T) :=
  {| chain_car n := map (project n,embed' n) (X (S n)) |}.
Next Obligation.
  intros X n i Hi.
  assert (∃ k, i = k + n) as [k ?] by (exists (i - n); lia); subst; clear Hi.
  induction k as [|k IH]; simpl; first done.
  rewrite -IH -(dist_le _ _ _ _ (f_tower (k + n) _)); last lia.
  rewrite f_S -oFunctor_map_compose.
  by apply (contractive_ne map); split=> Y /=; rewrite ?g_tower ?embed_f.
Qed.
Definition unfold (X : T) : oFunctor_apply F T := compl (unfold_chain X).
Instance unfold_ne : NonExpansive unfold.
Proof.
  intros n X Y HXY. by rewrite /unfold (conv_compl n (unfold_chain X))
    (conv_compl n (unfold_chain Y)) /= (HXY (S n)).
Qed.

Program Definition fold (X : oFunctor_apply F T) : T :=
  {| tower_car n := g n (map (embed' n,project n) X) |}.
Next Obligation.
  intros X k. apply (_ : Proper ((≡) ==> (≡)) (g k)).
  rewrite g_S -oFunctor_map_compose.
  apply (contractive_proper map); split=> Y; [apply embed_f|apply g_tower].
Qed.
Instance fold_ne : NonExpansive fold.
Proof. by intros n X Y HXY k; rewrite /fold /= HXY. Qed.

Theorem result : solution F.
Proof using Type*.
  refine (Solution F T _ (OfeIso (OfeMor fold) (OfeMor unfold) _ _)).
  - move=> X /=. rewrite equiv_dist=> n k; rewrite /unfold /fold /=.
    rewrite -g_tower -(gg_tower _ n); apply (_ : Proper (_ ==> _) (g _)).
    trans (map (ff n, gg n) (X (S (n + k)))).
    { rewrite /unfold (conv_compl n (unfold_chain X)).
      rewrite -(chain_cauchy (unfold_chain X) n (S (n + k))) /=; last lia.
      rewrite -(dist_le _ _ _ _ (f_tower (n + k) _)); last lia.
      rewrite f_S -!oFunctor_map_compose; apply (contractive_ne map); split=> Y.
      + rewrite /embed' /= /embed_coerce.
        destruct (le_lt_dec _ _); simpl; [exfalso; lia|].
        by rewrite (ff_ff _ (eq_refl (S n + (0 + k)))) /= gf.
      + rewrite /embed' /= /embed_coerce.
        destruct (le_lt_dec _ _); simpl; [|exfalso; lia].
        by rewrite (gg_gg _ (eq_refl (0 + (S n + k)))) /= gf. }
    assert (∀ i k (x : A (S i + k)) (H : S i + k = i + S k),
      map (ff i, gg i) x ≡ gg i (coerce H x)) as map_ff_gg.
    { intros i; induction i as [|i IH]; intros k' x H; simpl.
      { by rewrite coerce_id oFunctor_map_id. }
      rewrite oFunctor_map_compose g_coerce; apply IH. }
    assert (H: S n + k = n + S k) by lia.
    rewrite (map_ff_gg _ _ _ H).
    apply (_ : Proper (_ ==> _) (gg _)); by destruct H.
  - intros X; rewrite equiv_dist=> n /=.
    rewrite /unfold /= (conv_compl' n (unfold_chain (fold X))) /=.
    rewrite g_S -!oFunctor_map_compose -{2}[X]oFunctor_map_id.
    apply (contractive_ne map); split => Y /=.
    + rewrite f_tower. apply dist_S. by rewrite embed_tower.
    + etrans; [apply embed_ne, equiv_dist, g_tower|apply embed_tower].
Qed.
End solver. End solver.


(****************************************************************************)
(* Copyright 2021 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Coq.NArith.NArith.

Lemma apply_if {A B} (f : A -> B) (b : bool) x y : f (if b then x else y) = if b then f x else f y.
Proof. destruct b; reflexivity. Qed.

Lemma fst_if {A B} (b : bool) (x y : A * B) : fst (if b then x else y) = if b then fst x else fst y.
Proof. apply apply_if. Qed.
Lemma snd_if {A B} (b : bool) (x y : A * B) : snd (if b then x else y) = if b then snd x else snd y.
Proof. apply apply_if. Qed.
Hint Rewrite @fst_if @snd_if using solve [eauto] : tuple_if.

Lemma tup_if {A B} (b : bool) (x y: A) (z w: B) : (if b then x else y, if b then z else w) = if b then (x,z) else (y, w).
Proof. destruct b; reflexivity. Qed.
Hint Rewrite @tup_if using solve [eauto] : tuple_if.

Lemma apply_if_ext_1 {A B C} (f : A -> B -> C) (b : bool) x y z : f (if b then x else y) z = if b then f x z else f y z.
Proof. destruct b; reflexivity. Qed.

Lemma if_true_rew {A} (x: bool) (z: A) P Q: (x = true -> P = Q) ->
    (if x then P else z) = (if x then Q else z).
Proof. intros; destruct x; [ apply H | ]; reflexivity. Qed.

Lemma to_nat_if (b: bool) x y : N.to_nat (if b then x else y) = if b then (N.to_nat x) else (N.to_nat y).
Proof. now destruct b. Qed.
Hint Rewrite to_nat_if : Nnat.


From Coq Require Import List.
From MetaCoq.Template Require Import All.

Import ListNotations.
Import MCMonadNotation.
Open Scope bs_scope.
Definition qlist := Eval compute in match <% list %> with
    | tInd ind _ => ind.(inductive_mind)
    | _ => (MPfile nil, ""%bs)
    end.

Definition refresh_sort t :=
  match t with
  | tSort s =>
      match s with
      | Universe.lProp => tSort Universe.lProp
      | Universe.lSProp => tSort Universe.lSProp
      | Universe.lType _ => tSort Universes.fresh_universe
      end
  | _ => t
  end.

Definition refresh_arity s :=
  let (ctx, concl) := decompose_prod_assum [] s in
  it_mkProd_or_LetIn ctx (refresh_sort concl).

  Definition mind_body_to_entry :=
  fun decl : mutual_inductive_body =>
  {|
  mind_entry_record := None;
  mind_entry_finite := Finite;
  mind_entry_params :=
      match hd_error (ind_bodies decl) with
      | Some i0 =>
          List.rev
          (let typ := decompose_prod (ind_type i0) in
              let (a, b) := typ in
              (fun p : list aname × list term =>
              let (a0, b0) := p in
              (fun (names : list aname) (types : list term) (_ : term) =>
              let names0 := firstn (ind_npars decl) names in
              let types0 := firstn (ind_npars decl) types in
              map (fun '(x, ty) => vass x ty) (combine names0 types0)) a0 b0)
              a b)
      | None => []
      end;
  mind_entry_inds :=
      map
      (fun X : one_inductive_body =>
          match X with
          | {|
              ind_name := ind_name;
              ind_indices := ind_indices;
              ind_sort := ind_sort;
              ind_type := ind_type;
              ind_kelim := ind_kelim;
              ind_ctors := ind_ctors;
              ind_projs := ind_projs;
              ind_relevance := ind_relevance
          |} =>
              {|
              mind_entry_typename := ind_name;
              mind_entry_arity := refresh_arity (remove_arity (ind_npars decl) ind_type);
              mind_entry_consnames :=
                  map (fun x : constructor_body => cstr_name x) ind_ctors;
              mind_entry_lc :=
                  map
                  (fun x : constructor_body =>
                      remove_arity (ind_npars decl) (cstr_type x)) ind_ctors
              |}
          end) (ind_bodies decl);
  mind_entry_universes := universes_entry_of_decl (ind_universes decl);
  mind_entry_template := false;
  mind_entry_variance := option_map (map Some) (ind_variance decl);
  mind_entry_private := None
  |}.

Unset MetaCoq Strict Unquote Universe Mode.
MetaCoq Run (tmQuoteInductive qlist >>= fun mib =>
  let entry := mind_body_to_entry mib in
  entry <- tmEval all entry;;
  tmPrint entry ;;
  tmMkInductive true entry).


(* *********************************************************************)
(*                                                                     *)
(*              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 constant propagation. *)

Require Import Coqlib.
Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Events.
Require Import Memory.
Require Import Globalenvs.
Require Import Smallstep.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import Lattice.
Require Import Kildall.
Require Import ConstpropOp.
Require Import Constprop.
Require Import ConstpropOpproof.

Section PRESERVATION.

Variable prog: program.
Let tprog := transf_program prog.
Let ge := Genv.globalenv prog.
Let tge := Genv.globalenv tprog.
Let gapp := make_global_approx (PTree.empty _) prog.(prog_defs).

(** * Correctness of the static analysis *)

Section ANALYSIS.

Variable sp: val.

Definition regs_match_approx (a: D.t) (rs: regset) : Prop :=
  forall r, val_match_approx ge sp (D.get r a) rs#r.

Lemma regs_match_approx_top:
  forall rs, regs_match_approx D.top rs.
Proof.
  intros. red; intros. simpl. rewrite PTree.gempty.
  unfold Approx.top, val_match_approx. auto.
Qed.

Lemma val_match_approx_increasing:
  forall a1 a2 v,
  Approx.ge a1 a2 -> val_match_approx ge sp a2 v -> val_match_approx ge sp a1 v.
Proof.
  intros until v.
  intros [A|[B|C]].
  subst a1. simpl. auto.
  subst a2. simpl. tauto.
  subst a2. auto.
Qed.

Lemma regs_match_approx_increasing:
  forall a1 a2 rs,
  D.ge a1 a2 -> regs_match_approx a2 rs -> regs_match_approx a1 rs.
Proof.
  unfold D.ge, regs_match_approx. intros.
  apply val_match_approx_increasing with (D.get r a2); auto.
Qed.

Lemma regs_match_approx_update:
  forall ra rs a v r,
  val_match_approx ge sp a v ->
  regs_match_approx ra rs ->
  regs_match_approx (D.set r a ra) (rs#r <- v).
Proof.
  intros; red; intros. rewrite Regmap.gsspec.
  case (peq r0 r); intro.
  subst r0. rewrite D.gss. auto.
  rewrite D.gso; auto.
Qed.

Lemma approx_regs_val_list:
  forall ra rs rl,
  regs_match_approx ra rs ->
  val_list_match_approx ge sp (approx_regs ra rl) rs##rl.
Proof.
  induction rl; simpl; intros.
  constructor.
  constructor. apply H. auto.
Qed.

(** The correctness of the static analysis follows from the results
  of module [ConstpropOpproof] and the fact that the result of
  the static analysis is a solution of the forward dataflow inequations. *)

Lemma analyze_correct_1:
  forall f pc rs pc' i,
  f.(fn_code)!pc = Some i ->
  In pc' (successors_instr i) ->
  regs_match_approx (transfer gapp f pc (analyze gapp f)!!pc) rs ->
  regs_match_approx (analyze gapp f)!!pc' rs.
Proof.
  intros until i. unfold analyze.
  caseEq (DS.fixpoint (successors f) (transfer gapp f)
                      ((fn_entrypoint f, D.top) :: nil)).
  intros approxs; intros.
  apply regs_match_approx_increasing with (transfer gapp f pc approxs!!pc).
  eapply DS.fixpoint_solution; eauto.
  unfold successors_list, successors. rewrite PTree.gmap1. rewrite H0. auto.
  auto.
  intros. rewrite PMap.gi. apply regs_match_approx_top.
Qed.

Lemma analyze_correct_3:
  forall f rs,
  regs_match_approx (analyze gapp f)!!(f.(fn_entrypoint)) rs.
Proof.
  intros. unfold analyze.
  caseEq (DS.fixpoint (successors f) (transfer gapp f)
                      ((fn_entrypoint f, D.top) :: nil)).
  intros approxs; intros.
  apply regs_match_approx_increasing with D.top.
  eapply DS.fixpoint_entry; eauto. auto with coqlib.
  apply regs_match_approx_top.
  intros. rewrite PMap.gi. apply regs_match_approx_top.
Qed.

(** eval_static_load *)

Definition mem_match_approx (m: mem) : Prop :=
  forall id il b,
  gapp!id = Some il -> Genv.find_symbol ge id = Some b ->
  Genv.load_store_init_data ge m b 0 il /\
  Mem.valid_block m b /\
  (forall ofs, ~Mem.perm m b ofs Max Writable).

Lemma eval_load_init_sound:
  forall chunk m b il base ofs pos v,
  Genv.load_store_init_data ge m b base il ->
  Mem.load chunk m b ofs = Some v ->
  ofs = base + pos ->
  val_match_approx ge sp (eval_load_init chunk pos il) v.
Proof.
  induction il; simpl; intros.
(* base case il = nil *)
  auto.
(* inductive case *)
  destruct a.
  (* Init_int8 *)
  destruct H. destruct (zeq pos 0). subst.  rewrite Zplus_0_r in H0.
  destruct chunk; simpl; auto.
  rewrite Mem.load_int8_signed_unsigned in H0. rewrite H in H0. simpl in H0.
  inv H0. decEq. apply Int.sign_ext_zero_ext. compute; auto.
  congruence.
  eapply IHil; eauto. omega.
  (* Init_int16 *)
  destruct H. destruct (zeq pos 0). subst.  rewrite Zplus_0_r in H0.
  destruct chunk; simpl; auto.
  rewrite Mem.load_int16_signed_unsigned in H0. rewrite H in H0. simpl in H0.
  inv H0. decEq. apply Int.sign_ext_zero_ext. compute; auto.
  congruence.
  eapply IHil; eauto. omega.
  (* Init_int32 *)
  destruct H. destruct (zeq pos 0). subst.  rewrite Zplus_0_r in H0.
  destruct chunk; simpl; auto.
  congruence.
  eapply IHil; eauto. omega.
  (* Init_float32 *)
  destruct H. destruct (zeq pos 0). subst.  rewrite Zplus_0_r in H0.
  destruct chunk; simpl; auto. destruct (propagate_float_constants tt); simpl; auto.
  congruence.
  eapply IHil; eauto. omega.
  (* Init_float64 *)
  destruct H. destruct (zeq pos 0). subst.  rewrite Zplus_0_r in H0.
  destruct chunk; simpl; auto. destruct (propagate_float_constants tt); simpl; auto.
  congruence.
  eapply IHil; eauto. omega.
  (* Init_space *)
  eapply IHil; eauto. omega.
  (* Init_symbol *)
  destruct H as [[b' [A B]] C].
  destruct (zeq pos 0). subst.  rewrite Zplus_0_r in H0.
  destruct chunk; simpl; auto.
  unfold symbol_address. rewrite A. congruence.
  eapply IHil; eauto. omega.
Qed.

Lemma eval_static_load_sound:
  forall chunk m addr vaddr v,
  Mem.loadv chunk m vaddr = Some v ->
  mem_match_approx m ->
  val_match_approx ge sp addr vaddr ->
  val_match_approx ge sp (eval_static_load gapp chunk addr) v.
Proof.
  intros. unfold eval_static_load. destruct addr; simpl; auto.
  destruct (gapp!i) as [il|] eqn:?; auto.
  red in H1. subst vaddr. unfold symbol_address in H.
  destruct (Genv.find_symbol ge i) as [b'|] eqn:?; simpl in H; try discriminate.
  exploit H0; eauto. intros [A [B C]].
  eapply eval_load_init_sound; eauto.
  red; auto.
Qed.

Lemma mem_match_approx_store:
  forall chunk m addr v m',
  mem_match_approx m ->
  Mem.storev chunk m addr v = Some m' ->
  mem_match_approx m'.
Proof.
  intros; red; intros. exploit H; eauto. intros [A [B C]].
  destruct addr; simpl in H0; try discriminate.
  exploit Mem.store_valid_access_3; eauto. intros [P Q].
  split. apply Genv.load_store_init_data_invariant with m; auto.
  intros. eapply Mem.load_store_other; eauto. left; red; intro; subst b0.
  eapply C. apply Mem.perm_cur_max. eapply P. instantiate (1 := Int.unsigned i).
  generalize (size_chunk_pos chunk). omega.
  split. eauto with mem.
  intros; red; intros. eapply C. eapply Mem.perm_store_2; eauto.
Qed.

Lemma mem_match_approx_alloc:
  forall m lo hi b m',
  mem_match_approx m ->
  Mem.alloc m lo hi = (m', b) ->
  mem_match_approx m'.
Proof.
  intros; red; intros. exploit H; eauto. intros [A [B C]].
  split. apply Genv.load_store_init_data_invariant with m; auto.
  intros. eapply Mem.load_alloc_unchanged; eauto.
  split. eauto with mem.
  intros; red; intros. exploit Mem.perm_alloc_inv; eauto.
  rewrite zeq_false. apply C. eapply Mem.valid_not_valid_diff; eauto with mem.
Qed.

Lemma mem_match_approx_free:
  forall m lo hi b m',
  mem_match_approx m ->
  Mem.free m b lo hi = Some m' ->
  mem_match_approx m'.
Proof.
  intros; red; intros. exploit H; eauto. intros [A [B C]].
  split. apply Genv.load_store_init_data_invariant with m; auto.
  intros. eapply Mem.load_free; eauto.
  destruct (zeq b0 b); auto. subst b0.
  right. destruct (zlt lo hi); auto.
  elim (C lo). apply Mem.perm_cur_max.
  exploit Mem.free_range_perm; eauto. instantiate (1 := lo); omega.
  intros; eapply Mem.perm_implies; eauto with mem.
  split. eauto with mem.
  intros; red; intros. eapply C. eauto with mem.
Qed.

Lemma mem_match_approx_extcall:
  forall ef vargs m t vres m',
  mem_match_approx m ->
  external_call ef ge vargs m t vres m' ->
  mem_match_approx m'.
Proof.
  intros; red; intros. exploit H; eauto. intros [A [B C]].
  split. apply Genv.load_store_init_data_invariant with m; auto.
  intros. eapply external_call_readonly; eauto.
  split. eapply external_call_valid_block; eauto.
  intros; red; intros. elim (C ofs). eapply external_call_max_perm; eauto.
Qed.

(* Show that mem_match_approx holds initially *)

Definition global_approx_charact (g: genv) (ga: global_approx) : Prop :=
  forall id il b,
  ga!id = Some il ->
  Genv.find_symbol g id = Some b ->
  Genv.find_var_info g b = Some (mkglobvar tt il true false).

Lemma make_global_approx_correct:
  forall gdl g ga,
  global_approx_charact g ga ->
  global_approx_charact (Genv.add_globals g gdl) (make_global_approx ga gdl).
Proof.
  induction gdl; simpl; intros.
  auto.
  destruct a as [id gd]. apply IHgdl.
  red; intros.
  assert (EITHER: id0 = id /\ gd = Gvar(mkglobvar tt il true false)
               \/ id0 <> id /\ ga!id0 = Some il).
  destruct gd.
  rewrite PTree.grspec in H0. destruct (PTree.elt_eq id0 id); [discriminate|auto].
  destruct (gvar_readonly v && negb (gvar_volatile v)) eqn:?.
  rewrite PTree.gsspec in H0. destruct (peq id0 id).
  inv H0. left. split; auto.
  destruct v; simpl in *.
  destruct gvar_readonly; try discriminate.
  destruct gvar_volatile; try discriminate.
  destruct gvar_info. auto.
  auto.
  rewrite PTree.grspec in H0. destruct (PTree.elt_eq id0 id); [discriminate|auto].

  unfold Genv.add_global, Genv.find_symbol, Genv.find_var_info in *;
  simpl in *.
  destruct EITHER as [[A B] | [A B]].
  subst id0. rewrite PTree.gss in H1. inv H1. rewrite ZMap.gss. auto.
  rewrite PTree.gso in H1; auto. destruct gd. eapply H; eauto.
  rewrite ZMap.gso. eapply H; eauto.
  exploit Genv.genv_symb_range; eauto. unfold ZIndexed.t. omega.
Qed.

Theorem mem_match_approx_init:
  forall m, Genv.init_mem prog = Some m -> mem_match_approx m.
Proof.
  intros.
  assert (global_approx_charact ge gapp).
    unfold ge, gapp.   unfold Genv.globalenv.
    apply make_global_approx_correct.
    red; intros. rewrite PTree.gempty in H0; discriminate.
  red; intros.
  exploit Genv.init_mem_characterization.
  unfold ge in H0. eapply H0; eauto. eauto.
  unfold Genv.perm_globvar; simpl.
  intros [A [B C]].
  split. auto. split. eapply Genv.find_symbol_not_fresh; eauto.
  intros; red; intros. exploit B; eauto. intros [P Q]. inv Q.
Qed.

End ANALYSIS.

(** * Correctness of the code transformation *)

(** We now show that the transformed code after constant propagation
  has the same semantics as the original code. *)

Lemma symbols_preserved:
  forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
Proof.
  intros; unfold ge, tge, tprog, transf_program.
  apply Genv.find_symbol_transf.
Qed.

Lemma varinfo_preserved:
  forall b, Genv.find_var_info tge b = Genv.find_var_info ge b.
Proof.
  intros; unfold ge, tge, tprog, transf_program.
  apply Genv.find_var_info_transf.
Qed.

Lemma functions_translated:
  forall (v: val) (f: fundef),
  Genv.find_funct ge v = Some f ->
  Genv.find_funct tge v = Some (transf_fundef gapp f).
Proof.
  intros.
  exact (Genv.find_funct_transf (transf_fundef gapp) _ _ H).
Qed.

Lemma function_ptr_translated:
  forall (b: block) (f: fundef),
  Genv.find_funct_ptr ge b = Some f ->
  Genv.find_funct_ptr tge b = Some (transf_fundef gapp f).
Proof.
  intros.
  exact (Genv.find_funct_ptr_transf (transf_fundef gapp) _ _ H).
Qed.

Lemma sig_function_translated:
  forall f,
  funsig (transf_fundef gapp f) = funsig f.
Proof.
  intros. destruct f; reflexivity.
Qed.

Definition regs_lessdef (rs1 rs2: regset) : Prop :=
  forall r, Val.lessdef (rs1#r) (rs2#r).

Lemma regs_lessdef_regs:
  forall rs1 rs2, regs_lessdef rs1 rs2 ->
  forall rl, Val.lessdef_list rs1##rl rs2##rl.
Proof.
  induction rl; constructor; auto.
Qed.

Lemma set_reg_lessdef:
  forall r v1 v2 rs1 rs2,
  Val.lessdef v1 v2 -> regs_lessdef rs1 rs2 -> regs_lessdef (rs1#r <- v1) (rs2#r <- v2).
Proof.
  intros; red; intros. repeat rewrite Regmap.gsspec.
  destruct (peq r0 r); auto.
Qed.

Lemma init_regs_lessdef:
  forall rl vl1 vl2,
  Val.lessdef_list vl1 vl2 ->
  regs_lessdef (init_regs vl1 rl) (init_regs vl2 rl).
Proof.
  induction rl; simpl; intros.
  red; intros. rewrite Regmap.gi. auto.
  inv H. red; intros. rewrite Regmap.gi. auto.
  apply set_reg_lessdef; auto.
Qed.

Lemma transf_ros_correct:
  forall sp ros rs rs' f approx,
  regs_match_approx sp approx rs ->
  find_function ge ros rs = Some f ->
  regs_lessdef rs rs' ->
  find_function tge (transf_ros approx ros) rs' = Some (transf_fundef gapp f).
Proof.
  intros. destruct ros; simpl in *.
  generalize (H r); intro MATCH. generalize (H1 r); intro LD.
  destruct (rs#r); simpl in H0; try discriminate.
  destruct (Int.eq_dec i Int.zero); try discriminate.
  inv LD.
  assert (find_function tge (inl _ r) rs' = Some (transf_fundef gapp f)).
    simpl. rewrite <- H4. simpl. rewrite dec_eq_true. apply function_ptr_translated. auto.
  destruct (D.get r approx); auto.
  predSpec Int.eq Int.eq_spec i0 Int.zero; intros; auto.
  simpl in *. unfold symbol_address in MATCH. rewrite symbols_preserved.
  destruct (Genv.find_symbol ge i); try discriminate.
  inv MATCH. apply function_ptr_translated; auto.
  rewrite symbols_preserved. destruct (Genv.find_symbol ge i); try discriminate.
  apply function_ptr_translated; auto.
Qed.

Lemma const_for_result_correct:
  forall a op sp v m,
  const_for_result a = Some op ->
  val_match_approx ge sp a v ->
  eval_operation tge sp op nil m = Some v.
Proof.
  unfold const_for_result; intros.
  destruct a; inv H; simpl in H0.
  simpl. congruence.
  destruct (generate_float_constants tt); inv H2.  simpl. congruence.
  simpl. subst v. unfold symbol_address. rewrite symbols_preserved. auto.
  simpl. congruence.
Qed.

Inductive match_pc (f: function) (app: D.t): nat -> node -> node -> Prop :=
  | match_pc_base: forall n pc,
      match_pc f app n pc pc
  | match_pc_nop: forall n pc s pcx,
      f.(fn_code)!pc = Some (Inop s) ->
      match_pc f app n s pcx ->
      match_pc f app (Datatypes.S n) pc pcx
  | match_pc_cond: forall n pc cond args s1 s2 b,
      f.(fn_code)!pc = Some (Icond cond args s1 s2) ->
      eval_static_condition cond (approx_regs app args) = Some b ->
      match_pc f app (Datatypes.S n) pc (if b then s1 else s2).

Lemma match_successor_rec:
  forall f app n pc, match_pc f app n pc (successor_rec n f app pc).
Proof.
  induction n; simpl; intros.
  apply match_pc_base.
  destruct (fn_code f)!pc as [i|] eqn:?; try apply match_pc_base.
  destruct i; try apply match_pc_base.
  eapply match_pc_nop; eauto.
  destruct (eval_static_condition c (approx_regs app l)) as [b|] eqn:?.
  eapply match_pc_cond; eauto.
  apply match_pc_base.
Qed.

Lemma match_successor:
  forall f app pc, match_pc f app num_iter pc (successor f app pc).
Proof.
  unfold successor; intros. apply match_successor_rec.
Qed.

Section BUILTIN_STRENGTH_REDUCTION.
Variable app: D.t.
Variable sp: val.
Variable rs: regset.
Hypothesis MATCH: forall r, val_match_approx ge sp (approx_reg app r) rs#r.

Lemma annot_strength_reduction_correct:
  forall targs args targs' args' eargs,
  annot_strength_reduction app targs args = (targs', args') ->
  eventval_list_match ge eargs (annot_args_typ targs) rs##args ->
  exists eargs',
  eventval_list_match ge eargs' (annot_args_typ targs') rs##args'
  /\ annot_eventvals targs' eargs' = annot_eventvals targs eargs.
Proof.
  induction targs; simpl; intros.
- inv H. simpl. exists eargs; auto.
- destruct a.
  + destruct args as [ | arg args0]; simpl in H0; inv H0.
    destruct (annot_strength_reduction app targs args0) as [targs'' args''] eqn:E.
    exploit IHtargs; eauto. intros [eargs'' [A B]].
    assert (DFL:
      exists eargs',
      eventval_list_match ge eargs' (annot_args_typ (AA_arg ty :: targs'')) rs##(arg :: args'')
      /\ annot_eventvals (AA_arg ty :: targs'') eargs' = ev1 :: annot_eventvals targs evl).
    {
      exists (ev1 :: eargs''); split.
      simpl; constructor; auto. simpl. congruence.
    }
    destruct ty; destruct (approx_reg app arg) as [] eqn:E2; inv H; auto;
    exists eargs''; split; auto; simpl; f_equal; auto;
    generalize (MATCH arg); rewrite E2; simpl; intros E3;
    rewrite E3 in H5; inv H5; auto.
  + destruct (annot_strength_reduction app targs args) as [targs'' args''] eqn:E.
    inv H.
    exploit IHtargs; eauto. intros [eargs'' [A B]].
    exists eargs''; simpl; split; auto. congruence.
  + destruct (annot_strength_reduction app targs args) as [targs'' args''] eqn:E.
    inv H.
    exploit IHtargs; eauto. intros [eargs'' [A B]].
    exists eargs''; simpl; split; auto. congruence.
Qed.

Lemma builtin_strength_reduction_correct:
  forall ef args m t vres m',
  external_call ef ge rs##args m t vres m' ->
  let (ef', args') := builtin_strength_reduction app ef args in
  external_call ef' ge rs##args' m t vres m'.
Proof.
  intros until m'. functional induction (builtin_strength_reduction app ef args); intros; auto.
+ generalize (MATCH r1); rewrite e1; simpl; intros E. simpl in H.
  unfold symbol_address in E. destruct (Genv.find_symbol ge symb) as [b|] eqn:?; rewrite E in H.
  rewrite volatile_load_global_charact. exists b; auto.
  inv H.
+ generalize (MATCH r1); rewrite e1; simpl; intros E. simpl in H.
  unfold symbol_address in E. destruct (Genv.find_symbol ge symb) as [b|] eqn:?; rewrite E in H.
  rewrite volatile_store_global_charact. exists b; auto.
  inv H.
+ inv H. exploit annot_strength_reduction_correct; eauto.
  intros [eargs' [A B]].
  rewrite <- B. econstructor; eauto.
Qed.

End BUILTIN_STRENGTH_REDUCTION.

(** The proof of semantic preservation is a simulation argument
  based on "option" diagrams of the following form:
<<
                 n
       st1 --------------- st2
        |                   |
       t|                   |t or (? and n' < n)
        |                   |
        v                   v
       st1'--------------- st2'
                 n'
>>
  The left vertical arrow represents a transition in the
  original RTL code.  The top horizontal bar is the [match_states]
  invariant between the initial state [st1] in the original RTL code
  and an initial state [st2] in the transformed code.
  This invariant expresses that all code fragments appearing in [st2]
  are obtained by [transf_code] transformation of the corresponding
  fragments in [st1].  Moreover, the values of registers in [st1]
  must match their compile-time approximations at the current program
  point.
  These two parts of the diagram are the hypotheses.  In conclusions,
  we want to prove the other two parts: the right vertical arrow,
  which is a transition in the transformed RTL code, and the bottom
  horizontal bar, which means that the [match_state] predicate holds
  between the final states [st1'] and [st2']. *)

Inductive match_stackframes: stackframe -> stackframe -> Prop :=
   match_stackframe_intro:
      forall res sp pc rs f rs',
      regs_lessdef rs rs' ->
      (forall v, regs_match_approx sp (analyze gapp f)!!pc (rs#res <- v)) ->
    match_stackframes
        (Stackframe res f sp pc rs)
        (Stackframe res (transf_function gapp f) sp pc rs').

Inductive match_states: nat -> state -> state -> Prop :=
  | match_states_intro:
      forall s sp pc rs m f s' pc' rs' m' app n
           (MATCH1: regs_match_approx sp app rs)
           (MATCH2: regs_match_approx sp (analyze gapp f)!!pc rs)
           (GMATCH: mem_match_approx m)
           (STACKS: list_forall2 match_stackframes s s')
           (PC: match_pc f app n pc pc')
           (REGS: regs_lessdef rs rs')
           (MEM: Mem.extends m m'),
      match_states n (State s f sp pc rs m)
                    (State s' (transf_function gapp f) sp pc' rs' m')
  | match_states_call:
      forall s f args m s' args' m'
           (GMATCH: mem_match_approx m)
           (STACKS: list_forall2 match_stackframes s s')
           (ARGS: Val.lessdef_list args args')
           (MEM: Mem.extends m m'),
      match_states O (Callstate s f args m)
                    (Callstate s' (transf_fundef gapp f) args' m')
  | match_states_return:
      forall s v m s' v' m'
           (GMATCH: mem_match_approx m)
           (STACKS: list_forall2 match_stackframes s s')
           (RES: Val.lessdef v v')
           (MEM: Mem.extends m m'),
      list_forall2 match_stackframes s s' ->
      match_states O (Returnstate s v m)
                    (Returnstate s' v' m').

Lemma match_states_succ:
  forall s f sp pc2 rs m s' rs' m' pc1 i,
  f.(fn_code)!pc1 = Some i ->
  In pc2 (successors_instr i) ->
  regs_match_approx sp (transfer gapp f pc1 (analyze gapp f)!!pc1) rs ->
  mem_match_approx m ->
  list_forall2 match_stackframes s s' ->
  regs_lessdef rs rs' ->
  Mem.extends m m' ->
  match_states O (State s f sp pc2 rs m)
                (State s' (transf_function gapp f) sp pc2 rs' m').
Proof.
  intros.
  assert (regs_match_approx sp (analyze gapp f)!!pc2 rs).
    eapply analyze_correct_1; eauto.
  apply match_states_intro with (app := (analyze gapp f)!!pc2); auto.
  constructor.
Qed.

Lemma transf_instr_at:
  forall f pc i,
  f.(fn_code)!pc = Some i ->
  (transf_function gapp f).(fn_code)!pc = Some(transf_instr gapp f (analyze gapp f) pc i).
Proof.
  intros. simpl. unfold transf_code. rewrite PTree.gmap. rewrite H. auto.
Qed.

Ltac TransfInstr :=
  match goal with
  | H: (PTree.get ?pc (fn_code ?f) = Some ?instr) |- _ =>
      generalize (transf_instr_at _ _ _ H); simpl
  end.

(** The proof of simulation proceeds by case analysis on the transition
  taken in the source code. *)

Lemma transf_step_correct:
  forall s1 t s2,
  step ge s1 t s2 ->
  forall n1 s1' (MS: match_states n1 s1 s1'),
  (exists n2, exists s2', step tge s1' t s2' /\ match_states n2 s2 s2')
  \/ (exists n2, n2 < n1 /\ t = E0 /\ match_states n2 s2 s1')%nat.
Proof.
  induction 1; intros; inv MS; try (inv PC; try congruence).

  (* Inop, preserved *)
  rename pc'0 into pc. TransfInstr; intro.
  left; econstructor; econstructor; split.
  eapply exec_Inop; eauto.
  eapply match_states_succ; eauto. simpl; auto.
  unfold transfer; rewrite H. auto.

  (* Inop, skipped over *)
  rewrite H0 in H; inv H.
  right; exists n; split. omega. split. auto.
  apply match_states_intro with app; auto.
  eapply analyze_correct_1; eauto. simpl; auto.
  unfold transfer; rewrite H0. auto.

  (* Iop *)
  rename pc'0 into pc. TransfInstr.
  set (app_before := (analyze gapp f)#pc).
  set (a := eval_static_operation op (approx_regs app_before args)).
  set (app_after := D.set res a app_before).
  assert (VMATCH: val_match_approx ge sp a v).
    eapply eval_static_operation_correct; eauto.
    apply approx_regs_val_list; auto.
  assert (MATCH': regs_match_approx sp app_after rs#res <- v).
    apply regs_match_approx_update; auto.
  assert (MATCH'': regs_match_approx sp (analyze gapp f) # pc' rs # res <- v).
    eapply analyze_correct_1 with (pc := pc); eauto. simpl; auto.
    unfold transfer; rewrite H. auto.
  destruct (const_for_result a) as [cop|] eqn:?; intros.
  (* constant is propagated *)
  left; econstructor; econstructor; split.
  eapply exec_Iop; eauto.
  eapply const_for_result_correct; eauto.
  apply match_states_intro with app_after; auto.
  apply match_successor.
  apply set_reg_lessdef; auto.
  (* operator is strength-reduced *)
  exploit op_strength_reduction_correct. eexact MATCH2. reflexivity. eauto.
  fold app_before.
  destruct (op_strength_reduction op args (approx_regs app_before args)) as [op' args'].
  intros [v' [EV' LD']].
  assert (EV'': exists v'', eval_operation ge sp op' rs'##args' m' = Some v'' /\ Val.lessdef v' v'').
  eapply eval_operation_lessdef; eauto. eapply regs_lessdef_regs; eauto.
  destruct EV'' as [v'' [EV'' LD'']].
  left; econstructor; econstructor; split.
  eapply exec_Iop; eauto.
  erewrite eval_operation_preserved. eexact EV''. exact symbols_preserved.
  apply match_states_intro with app_after; auto.
  apply match_successor.
  apply set_reg_lessdef; auto. eapply Val.lessdef_trans; eauto.

  (* Iload *)
  rename pc'0 into pc. TransfInstr.
  set (ap1 := eval_static_addressing addr
               (approx_regs (analyze gapp f) # pc args)).
  set (ap2 := eval_static_load gapp chunk ap1).
  assert (VM1: val_match_approx ge sp ap1 a).
    eapply eval_static_addressing_correct; eauto.
    eapply approx_regs_val_list; eauto.
  assert (VM2: val_match_approx ge sp ap2 v).
    eapply eval_static_load_sound; eauto.
  destruct (const_for_result ap2) as [cop|] eqn:?; intros.
  (* constant-propagated *)
  left; econstructor; econstructor; split.
  eapply exec_Iop; eauto. eapply const_for_result_correct; eauto.
  eapply match_states_succ; eauto. simpl; auto.
  unfold transfer; rewrite H. apply regs_match_approx_update; auto.
  apply set_reg_lessdef; auto.
  (* strength-reduced *)
  generalize (addr_strength_reduction_correct ge sp (analyze gapp f)!!pc rs
                  MATCH2 addr args (approx_regs (analyze gapp f) # pc args) (refl_equal _)).
  destruct (addr_strength_reduction addr args (approx_regs (analyze gapp f) # pc args)) as [addr' args'].
  rewrite H0. intros P.
  assert (ADDR': exists a', eval_addressing ge sp addr' rs'##args' = Some a' /\ Val.lessdef a a').
    eapply eval_addressing_lessdef; eauto. eapply regs_lessdef_regs; eauto.
  destruct ADDR' as [a' [A B]].
  assert (C: eval_addressing tge sp addr' rs'##args' = Some a').
    rewrite <- A. apply eval_addressing_preserved. exact symbols_preserved.
  exploit Mem.loadv_extends; eauto. intros [v' [D E]].
  left; econstructor; econstructor; split.
  eapply exec_Iload; eauto.
  eapply match_states_succ; eauto. simpl; auto.
  unfold transfer; rewrite H. apply regs_match_approx_update; auto.
  apply set_reg_lessdef; auto.

  (* Istore *)
  rename pc'0 into pc. TransfInstr.
  generalize (addr_strength_reduction_correct ge sp (analyze gapp f)!!pc rs
                  MATCH2 addr args (approx_regs (analyze gapp f) # pc args) (refl_equal _)).
  destruct (addr_strength_reduction addr args (approx_regs (analyze gapp f) # pc args)) as [addr' args'].
  intros P Q. rewrite H0 in P.
  assert (ADDR': exists a', eval_addressing ge sp addr' rs'##args' = Some a' /\ Val.lessdef a a').
    eapply eval_addressing_lessdef; eauto. eapply regs_lessdef_regs; eauto.
  destruct ADDR' as [a' [A B]].
  assert (C: eval_addressing tge sp addr' rs'##args' = Some a').
    rewrite <- A. apply eval_addressing_preserved. exact symbols_preserved.
  exploit Mem.storev_extends; eauto. intros [m2' [D E]].
  left; econstructor; econstructor; split.
  eapply exec_Istore; eauto.
  eapply match_states_succ; eauto. simpl; auto.
  unfold transfer; rewrite H. auto.
  eapply mem_match_approx_store; eauto.

  (* Icall *)
  rename pc'0 into pc.
  exploit transf_ros_correct; eauto. intro FIND'.
  TransfInstr; intro.
  left; econstructor; econstructor; split.
  eapply exec_Icall; eauto. apply sig_function_translated; auto.
  constructor; auto. constructor; auto.
  econstructor; eauto.
  intros. eapply analyze_correct_1; eauto. simpl; auto.
  unfold transfer; rewrite H.
  apply regs_match_approx_update; auto. simpl. auto.
  apply regs_lessdef_regs; auto.

  (* Itailcall *)
  exploit Mem.free_parallel_extends; eauto. intros [m2' [A B]].
  exploit transf_ros_correct; eauto. intros FIND'.
  TransfInstr; intro.
  left; econstructor; econstructor; split.
  eapply exec_Itailcall; eauto. apply sig_function_translated; auto.
  constructor; auto.
  eapply mem_match_approx_free; eauto.
  apply regs_lessdef_regs; auto.

  (* Ibuiltin *)
  rename pc'0 into pc.
Opaque builtin_strength_reduction.
  exploit builtin_strength_reduction_correct; eauto.
  TransfInstr.
  destruct (builtin_strength_reduction (analyze gapp f)#pc ef args) as [ef' args'].
  intros P Q.
  exploit external_call_mem_extends; eauto.
  instantiate (1 := rs'##args'). apply regs_lessdef_regs; auto.
  intros [v' [m2' [A [B [C D]]]]].
  left; econstructor; econstructor; split.
  eapply exec_Ibuiltin. eauto.
  eapply external_call_symbols_preserved; eauto.
  exact symbols_preserved. exact varinfo_preserved.
  eapply match_states_succ; eauto. simpl; auto.
  unfold transfer; rewrite H.
  apply regs_match_approx_update; auto. simpl; auto.
  eapply mem_match_approx_extcall; eauto.
  apply set_reg_lessdef; auto.

  (* Icond, preserved *)
  rename pc'0 into pc. TransfInstr.
  generalize (cond_strength_reduction_correct ge sp (analyze gapp f)#pc rs m
                    MATCH2 cond args (approx_regs (analyze gapp f) # pc args) (refl_equal _)).
  destruct (cond_strength_reduction cond args (approx_regs (analyze gapp f) # pc args)) as [cond' args'].
  intros EV1 TCODE.
  left; exists O; exists (State s' (transf_function gapp f) sp (if b then ifso else ifnot) rs' m'); split.
  destruct (eval_static_condition cond (approx_regs (analyze gapp f) # pc args)) eqn:?.
  assert (eval_condition cond rs ## args m = Some b0).
    eapply eval_static_condition_correct; eauto. eapply approx_regs_val_list; eauto.
  assert (b = b0) by congruence. subst b0.
  destruct b; eapply exec_Inop; eauto.
  eapply exec_Icond; eauto.
  eapply eval_condition_lessdef with (vl1 := rs##args'); eauto. eapply regs_lessdef_regs; eauto. congruence.
  eapply match_states_succ; eauto.
  destruct b; simpl; auto.
  unfold transfer; rewrite H. auto.

  (* Icond, skipped over *)
  rewrite H1 in H; inv H.
  assert (eval_condition cond rs ## args m = Some b0).
    eapply eval_static_condition_correct; eauto. eapply approx_regs_val_list; eauto.
  assert (b = b0) by congruence. subst b0.
  right; exists n; split. omega. split. auto.
  assert (MATCH': regs_match_approx sp (analyze gapp f) # (if b then ifso else ifnot) rs).
    eapply analyze_correct_1; eauto. destruct b; simpl; auto.
    unfold transfer; rewrite H1; auto.
  econstructor; eauto. constructor.

  (* Ijumptable *)
  rename pc'0 into pc.
  assert (A: (fn_code (transf_function gapp f))!pc = Some(Ijumptable arg tbl)
             \/ (fn_code (transf_function gapp f))!pc = Some(Inop pc')).
  TransfInstr. destruct (approx_reg (analyze gapp f) # pc arg) eqn:?; auto.
  generalize (MATCH2 arg). unfold approx_reg in Heqt. rewrite Heqt. rewrite H0.
  simpl. intro EQ; inv EQ. rewrite H1. auto.
  assert (B: rs'#arg = Vint n).
  generalize (REGS arg); intro LD; inv LD; congruence.
  left; exists O; exists (State s' (transf_function gapp f) sp pc' rs' m'); split.
  destruct A. eapply exec_Ijumptable; eauto. eapply exec_Inop; eauto.
  eapply match_states_succ; eauto.
  simpl. eapply list_nth_z_in; eauto.
  unfold transfer; rewrite  H; auto.

  (* Ireturn *)
  exploit Mem.free_parallel_extends; eauto. intros [m2' [A B]].
  left; exists O; exists (Returnstate s' (regmap_optget or Vundef rs') m2'); split.
  eapply exec_Ireturn; eauto. TransfInstr; auto.
  constructor; auto.
  eapply mem_match_approx_free; eauto.
  destruct or; simpl; auto.

  (* internal function *)
  exploit Mem.alloc_extends. eauto. eauto. apply Zle_refl. apply Zle_refl.
  intros [m2' [A B]].
  simpl. unfold transf_function.
  left; exists O; econstructor; split.
  eapply exec_function_internal; simpl; eauto.
  simpl. econstructor; eauto.
  apply analyze_correct_3; auto.
  apply analyze_correct_3; auto.
  eapply mem_match_approx_alloc; eauto.
  instantiate (1 := f). constructor.
  apply init_regs_lessdef; auto.

  (* external function *)
  exploit external_call_mem_extends; eauto.
  intros [v' [m2' [A [B [C D]]]]].
  simpl. left; econstructor; econstructor; split.
  eapply exec_function_external; eauto.
  eapply external_call_symbols_preserved; eauto.
  exact symbols_preserved. exact varinfo_preserved.
  constructor; auto.
  eapply mem_match_approx_extcall; eauto.

  (* return *)
  inv H4. inv H1.
  left; exists O; econstructor; split.
  eapply exec_return; eauto.
  econstructor; eauto. constructor. apply set_reg_lessdef; auto.
Qed.

Lemma transf_initial_states:
  forall st1, initial_state prog st1 ->
  exists n, exists st2, initial_state tprog st2 /\ match_states n st1 st2.
Proof.
  intros. inversion H.
  exploit function_ptr_translated; eauto. intro FIND.
  exists O; exists (Callstate nil (transf_fundef gapp f) nil m0); split.
  econstructor; eauto.
  apply Genv.init_mem_transf; auto.
  replace (prog_main tprog) with (prog_main prog).
  rewrite symbols_preserved. eauto.
  reflexivity.
  rewrite <- H3. apply sig_function_translated.
  constructor.
  eapply mem_match_approx_init; eauto.
  constructor. constructor. apply Mem.extends_refl.
Qed.

Lemma transf_final_states:
  forall n st1 st2 r,
  match_states n st1 st2 -> final_state st1 r -> final_state st2 r.
Proof.
  intros. inv H0. inv H. inv STACKS. inv RES. constructor.
Qed.

(** The preservation of the observable behavior of the program then
  follows. *)

Theorem transf_program_correct:
  forward_simulation (RTL.semantics prog) (RTL.semantics tprog).
Proof.
  eapply Forward_simulation with (fsim_order := lt); simpl.
  apply lt_wf.
  eexact transf_initial_states.
  eexact transf_final_states.
  fold ge; fold tge. intros.
    exploit transf_step_correct; eauto.
    intros [ [n2 [s2' [A B]]] | [n2 [A [B C]]]].
    exists n2; exists s2'; split; auto. left; apply plus_one; auto.
    exists n2; exists s2; split; auto. right; split; auto. subst t; apply star_refl.
  eexact symbols_preserved.
Qed.

End PRESERVATION.