Require Export Arith.EqNat.
Require Export Arith.Le.
Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Program.Equality.
Require Import Coq.Lists.List.
Require Import Psatz.
Require Import Coq.Arith.Compare_dec.
Import ListNotations.

Require Import vars.
Require Import env.
Require Import tactics.
Require Import qualifiers.
Require Import lambda_star.

Require Import NatSets.
Require Import setfacts.
Import NatSet.F.

Import OpeningNotations.
Local Open Scope opening.

Import QualNotations.
Local Open Scope qualifiers.

(* ### Infrastructure for examples file ### *)

(* iterating over each hypothesis once, inspired by https://stackoverflow.com/a/46536938: *)
(* marker for iterating over hypotheses *)
Inductive ltac_Mark : Type :=
| ltac_mark : ltac_Mark.

(* apply tac over all the premises in the goal until the marker*)
Ltac repeat_until_mark tac :=
  lazymatch goal with
  | [ |- ltac_Mark -> _ ] => intros _
  | [ |- _ ] => tac (); repeat_until_mark tac
  end.

(* apply tac on each hypothesis exactly once *)
Ltac for_each_hyp tac :=
  (* prepend the marker to the goal *)
  generalize (ltac_mark : ltac_Mark);
  repeat match goal with (* move all hypotheses from the context to the goal *)
  | [ H : _ |- _ ] => revert H
  end;
  (* successively move each hypothesis back into the context, applying tac on the way *)
  repeat_until_mark ltac:(fun _ => lazymatch goal with
                                   | [ |- ?F -> _ ] => intro; tac F
                                   | _ => intro
                                   end).

(* if an encountered hypothesis is a closed_qual, then invert it *)
Ltac try_invert_closed_qual F :=
  match F with
  | closed_qual _ _ _ _ =>
    match goal with
    | [ H : F |- _ ] => inversion H; subst
    end
  | _ => idtac
  end.

(* invert all the closed_qual hypotheses, exposing the bounds *)
Ltac closed_qual_invert := for_each_hyp try_invert_closed_qual.

Ltac set_simpl :=
  match goal with
  | [ |- context[union {}N ?s] ] => rewrite (@empty_union_left s); try set_simpl
  | [ |- context[union ?s {}N] ] => rewrite (@empty_union_right s); try set_simpl
  | [ H :  context[union {}N ?s] |- _ ] => rewrite (@empty_union_left s) in H; try set_simpl
  | [ H :  context[union ?s {}N] |- _ ] => rewrite (@empty_union_right s) in H; try set_simpl
  | [ |- context[inter {}N ?s] ] => rewrite (@inter_empty_left s); try set_simpl
  | [ |- context[inter ?s {}N] ] => rewrite (@inter_empty_right s); try set_simpl
  | [ H :  context[inter {}N ?s] |- _ ] => rewrite (@inter_empty_left s) in H; try set_simpl
  | [ H :  context[inter ?s {}N] |- _ ] => rewrite (@inter_empty_right s) in H; try set_simpl
  | [ |-  context[inter (singleton ?x) (singleton ?x)]  ] => rewrite (@inter_singleton_eq x); try set_simpl
  | [ |-  context[inter (singleton ?x) (singleton ?y)]  ] => rewrite (@inter_singleton_neq x y); try set_simpl
  | [ H : context[inter (singleton ?x) (singleton ?x)] |- _ ] => rewrite (@inter_singleton_eq x) in H; try set_simpl
  | [ H : context[inter (singleton ?x) (singleton ?y)] |- _ ] => rewrite (@inter_singleton_neq x y) in H; try set_simpl
  | [ |-  context[inter ?s (singleton ?y)] ] => erewrite (@bound_disjoint s y); eauto; try set_simpl
  | [ |- context[remove ?n (singleton ?n)] ] => rewrite (@remove_singleton_empty n); try set_simpl
  | [ H : context[remove ?n (singleton ?n)] |- _ ] => rewrite (@remove_singleton_empty n) in H; try set_simpl
  | [ |- context[remove ?n (singleton ?m)] ] => try (rewrite (@remove_singleton_inv n m); auto); try set_simpl
  | [ H : context[remove ?n (singleton ?m)] |- _ ] => try (rewrite (@remove_singleton_inv n m) in H; auto); try set_simpl
  | [ |- context[remove ?n {}N] ] => rewrite (@remove_empty n); try set_simpl
  | [ H : context[remove ?n {}N] |- _ ] => rewrite (@remove_empty n) in H; try set_simpl
  | [ H : context[remove ?n (union ?s1 ?s2)] |- _ ] => rewrite (@remove_union_dist n s1 s2) in H; try set_simpl
  | [ |- context[remove ?n (union ?s1 ?s2)] ] => rewrite (@remove_union_dist n s1 s2); try set_simpl
  end.

Ltac bound_simpl := try set_simpl;
  match goal with
  | [ |- context[bound (union _ _)] ] => rewrite union_bound_max'; try bound_simpl
  | [ |- context[bound (singleton _)] ] => rewrite bound_singleton; try bound_simpl
  | [ |- context[bound {}N] ] => rewrite bound_empty; try bound_simpl
  end.

Ltac closed_qual_solve :=
  match goal with
  | [ |- closed_qual _ _ _ ∅ ] => try solve [constructor; bound_simpl; lia]
  | [ |- closed_qual _ _ _ (_ ⋓ _) ] => try solve [apply closed_qual_qqplus; closed_qual_solve]
  | [ |- closed_qual _ _ _ (_ ⊔ _) ] => try solve [apply closed_qual_qlub; closed_qual_solve]
  | [ |- closed_qual _ _ _ (_ ⋒ _) ] => try solve [apply closed_qual_qqcap; closed_qual_solve]
  | [ |- closed_qual _ _ _ (_ ⊓ _) ] => try solve [apply closed_qual_qqcap; closed_qual_solve]
  | [ |- closed_qual _ _ _ (_ ⊕ _) ] => try solve [apply closed_qual_qplus; simpl; try lia; closed_qual_solve]
  | [ |- closed_qual _ _ _ (just_fv _) ] => try solve [apply just_fv_closed; simpl; lia | closed_qual_solve]
  | [ H : closed_qual _ _ _ ?q |- closed_qual _ _ _ ?q  ] => try solve [simpl in *; eapply closed_qual_monotone; eauto; try lia | (closed_qual_solve)]
  | [ H : has_type _ ?q _ _ _ _ |- closed_qual _ _ _ ?q  ] => try solve [apply has_type_closed in H; intuition; simpl in *; eapply closed_qual_monotone; eauto | (closed_qual_solve)]
  | [ H : has_type _ _ _ _ _ ?q |- closed_qual _ _ _ ?q  ] => try solve [apply has_type_closed in H; intuition; simpl in *; eapply closed_qual_monotone; eauto | (closed_qual_solve)]
  | [ H : stp _ _ _ ?q _ _ |- closed_qual _ _ _ ?q  ] => try solve [apply stp_closed in H; intuition; simpl in *; eapply closed_qual_monotone; eauto | (closed_qual_solve)]
  | [ H : stp _ _ _ _ _ ?q |- closed_qual _ _ _ ?q  ] => try solve [apply stp_closed in H; intuition; simpl in *; eapply closed_qual_monotone; eauto | (closed_qual_solve)]
  | [ H : qstp _ _ ?q _  |- closed_qual _ _ _ ?q  ] => try solve [apply qstp_closed in H; intuition; simpl in *; eapply closed_qual_monotone; eauto | (closed_qual_solve)]
  | [ H : qstp _ _ _ ?q  |- closed_qual _ _ _ ?q  ] => try solve [apply qstp_closed in H; intuition; simpl in *; eapply closed_qual_monotone; eauto | (closed_qual_solve)]
  | [ H1 : ?q ⊑ ?q', H2 : closed_qual _ _ _ ?q' |- closed_qual _ _ _ ?q ] => try solve [apply (closed_qual_sub H2 H1)]
  | [ |- closed_qual _ _ _ _ ] => try solve [simpl; constructor; bound_simpl; lia]
  end.

Ltac closed_ty_solve :=
  match goal with
  | [ H : closed_ty _ _ _ ?T |- closed_ty _ _ _ ?T  ] => try solve [simpl in *; eapply closed_ty_monotone; eauto; try lia | (closed_ty_solve)]
  | [ H : has_type _ _ _ _ ?T _ |- closed_ty _ _ _ ?T  ] => try solve [apply has_type_closed in H; intuition; simpl in *; eapply closed_ty_monotone; eauto | (closed_ty_solve)]
  | [ H : stp _ _ ?T _ _ _ |- closed_ty _ _ _ ?T  ] => try solve [apply stp_closed in H; intuition; simpl in *; eapply closed_ty_monotone; eauto | (closed_ty_solve)]
  | [ H : stp _ _ _ _ ?T _ |- closed_ty _ _ _ ?T  ] => try solve [apply stp_closed in H; intuition; simpl in *; eapply closed_ty_monotone; eauto | (closed_ty_solve)]
  | [ |- closed_ty _ _ _ (TFun _ _ _ _) ] => try solve [simpl; constructor; try closed_qual_solve; closed_ty_solve]
  | [ |- closed_ty _ _ _ (TRef _) ] => try solve [simpl; constructor; try closed_qual_solve; closed_ty_solve]
  | [ |- closed_ty _ _ _ _ ] => try solve [simpl; constructor; try closed_qual_solve]
  end.

Ltac closed_tm_solve :=
  match goal with
  | [ H : closed_tm _ _ _ ?T |- closed_tm _ _ _ ?T  ] => try solve [simpl in *; eapply closed_tm_monotone; eauto; try lia | (closed_tm_solve)]
  | [ H : has_type _ _ _ ?T _ _ |- closed_tm _ _ _ ?T  ] => try solve [apply has_type_closed in H; intuition; simpl in *; eapply closed_tm_monotone; eauto | (closed_tm_solve)]
  | [ |- closed_tm _ _ _ (tabs _) ] => try solve [simpl; constructor; try lia; closed_tm_solve]
  | [ |- closed_tm _ _ _ (tapp _) ] => try solve [simpl; constructor; try lia; closed_tm_solve]
  | [ |- closed_tm _ _ _ (tref _) ] => try solve [simpl; constructor; try lia; closed_tm_solve]
  | [ |- closed_tm _ _ _ (tderef _) ] => try solve [simpl; constructor; try lia; closed_tm_solve]
  | [ |- closed_tm _ _ _ (tassign _ _) ] => try solve [simpl; constructor; try lia; closed_tm_solve]
  | [ |- closed_tm _ _ _ _ ] => try solve [simpl; constructor; try lia; closed_tm_solve]
  end.

Lemma open_qual_empty_id : forall k q, [[ k ~> q]]ᵈ ∅ = ∅.
  intros. destruct q. compute. rewrite NatSetFacts.empty_b. auto.
Qed.

Lemma has_type_open_tm_id : forall {Γ φ Σ t T d k t'}, has_type Γ φ Σ t T d -> open_rec_tm k t' t = t.
  intros. apply has_type_closed in H. intuition. eapply closed_tm_open_id; eauto. lia.
Qed.

Lemma has_type_open_ty_id : forall {Γ φ Σ t T d k q}, has_type Γ φ Σ t T d -> open_rec_ty k q T = T.
  intros. apply has_type_closed in H. intuition. eapply closed_ty_open_id; eauto. lia.
Qed.

Lemma has_type_open_qual_id1 : forall {Γ φ Σ t T d k q}, has_type Γ φ Σ t T d -> open_qual k q φ = φ.
  intros. apply has_type_closed in H. intuition. eapply closed_qual_open_id; eauto. lia.
Qed.

Lemma has_type_open_qual_id2 : forall {Γ φ Σ t T d k q}, has_type Γ φ Σ t T d -> open_qual k q d = d.
  intros. apply has_type_closed in H. intuition. eapply closed_qual_open_id; eauto. lia.
Qed.

Lemma stp_open_ty_id1 : forall {Γ Σ T d S q k q'}, stp Γ Σ S q T d -> open_rec_ty k q' S = S.
  intros. apply stp_closed in H. intuition. eapply closed_ty_open_id; eauto. lia.
Qed.

Lemma stp_open_ty_id2 : forall {Γ Σ T d S q k q'}, stp Γ Σ S q T d -> open_rec_ty k q' T = T.
  intros. apply stp_closed in H. intuition. eapply closed_ty_open_id; eauto. lia.
Qed.

Lemma stp_open_qual_id1 : forall {Γ Σ T d S q k q'}, stp Γ Σ S q T d -> open_qual k q' q = q.
  intros. apply stp_closed in H. intuition. eapply closed_qual_open_id; eauto. lia.
Qed.

Lemma stp_open_qual_id2 : forall {Γ Σ T d S q k q'}, stp Γ Σ S q T d -> open_qual k q' d = d.
  intros. apply stp_closed in H. intuition. eapply closed_qual_open_id; eauto. lia.
Qed.

Lemma qstp_open_qual_id1 : forall {Γ Σ d q k q'}, qstp Γ Σ q d -> open_qual k q' q = q.
  intros. apply qstp_closed in H. intuition. eapply closed_qual_open_id; eauto. lia.
Qed.

Lemma qstp_open_qual_id2 : forall {Γ Σ d q k q'}, qstp Γ Σ q d -> open_qual k q' d = d.
  intros. apply qstp_closed in H. intuition. eapply closed_qual_open_id; eauto. lia.
Qed.

Lemma mem_singleton' : forall {n}, mem n (singleton n) = true.
  intros. rewrite mem_singleton. rewrite <- beq_nat_refl. auto.
Qed.

Lemma mem_singleton_neq : forall {m n}, m <> n -> mem n (singleton m) = false.
  intros. rewrite mem_singleton. rewrite Nat.eqb_neq. auto.
Qed.

Lemma unopen_subqual : forall {x q2 df l}, closed_qual 2 x l q2 -> closed_qual 0 x l df ->
  openq (just_fv x) (just_fv (S x)) q2 ⊑ df ⊔ (just_fv (S x)) -> openq ∅ ∅ q2 ⊑ df.
  intros. unfold openq in *. destruct q2. destruct df. simpl in *.
  inversion H. subst. inversion H0. subst.
  assert (H8' : bound t0 <= S x). lia.
  assert (H11' : bound t3 <= S x). lia. clear H8. clear H11. rename H8' into H8. rename H11' into H11.
  apply bound_le_mem_false in H8, H11, H9.
  destruct (NatSet.F.mem 0 t1) eqn:Hmem; simpl in *; intuition.
  destruct (mem 1 (union (remove 0 t1) {}N)) eqn:Hmem'; rewrite <- NatSetFacts.not_mem_iff in H8, H11, H9.
  * rewrite <- NatSetFacts.mem_iff in Hmem'. repeat rewrite empty_union_right in *.
    repeat rewrite empty_union_right in H1. simpl in *; intuition.
    intros z Hz. assert (Hz' : In z (union (union t0 (singleton x)) (singleton (S x)))). fnsetdec.
    apply H2 in Hz'. apply union_1 in Hz'. intuition. apply NatSetFacts.singleton_iff in H3. subst.
    contradiction.
  * simpl in H1. intuition. repeat rewrite empty_union_right in *.
    rewrite empty_union_right in H1. simpl. intuition; fnsetdec.
  * destruct (mem 1 t1) eqn:Hmem1; simpl in *.
    ** repeat rewrite empty_union_right in *. intuition; try fnsetdec.
       intros z Hz. assert (Hz' : In z (union t0 (singleton (S x)))). fnsetdec.
       apply H2 in Hz'. apply union_1 in Hz'. intuition. apply NatSetFacts.singleton_iff in H3. subst.
       rewrite <- NatSetFacts.not_mem_iff in H8. contradiction.
    ** intuition; try fnsetdec. rewrite <- NatSetFacts.not_mem_iff in H11, H8.
       intros z Hz. assert (Hz' : In z (union t3 (singleton (S x))) ). fnsetdec.
       apply union_1 in Hz'. intuition. apply NatSetFacts.singleton_iff in H3. subst. contradiction.
Qed.

Lemma saturated_singleton : forall {x Γ Σ b T}, indexr x Γ = Some (b, T, ∅) -> saturated Γ Σ (just_fv x).
  intros. unfold saturated. intros y Hmem. rewrite just_fv_mem_iff in Hmem. subst.
  econstructor; eauto.
Qed.

Ltac opening :=
  match goal with
  | [ H : closed_tm 0 _ _ ?t |- context[@open_tm' _ ?G ?t] ] => erewrite @closed_tm_open'_id with (t:=t); eauto; try opening
  | [ H : closed_ty 0 _ _ ?t |- context[@open_ty' _ _ ?t] ] => erewrite @closed_ty_open'_id with (T:=t); eauto; try opening
  | [ H : closed_qual 0 _ _ ?q |- context[@openq' _ ?G ?q] ] => erewrite @closed_qual_open'_id with (d:=q); eauto; try opening
  | [ |- context[@open_tm' ?T ?G (tvar (varB 0))] ] => rewrite (open_tm'_bv0 T G); try opening
  (* | [ |- context[@open_tm' ?T ?G (tvar (varB 1))] ] => rewrite (open_tm'_bv1 T G); try opening *)
  | [ |- context[@openq' ?T ?G (qset ?X (singleton 0) ?Y)] ] => rewrite (openq'_bv0 T G X Y); try opening
  (* | [ |- context[@openq' ?T ?G (qset ?X (singleton 1) ?Y)] ] => rewrite (openq'_bv1 T G X Y); try opening *)
  | [ |- context[@openq' _ _ _] ] => unfold openq'; unfold openq; try opening
  | [ |- context[@openq _ _] ] => unfold openq; try opening
  | [ |- context[@open_tm' _ _ _] ] => unfold open_tm'; try opening
  | [ |- context[@open_ty' _ _ _] ] => unfold open_ty'; unfold open_ty; try opening
  | [ |- context[@open_ty _ _] ] => unfold open_ty; try opening
  | [ |- context[open_qual _ _ (_ ⋓ _)] ] => rewrite open_qual_qqplus_dist; try opening
  | [ |- context[open_qual _ _ (_ ⊔ _)] ] => rewrite open_qual_qlub_dist; try opening
  | [ |- context[open_qual ?i ?d (just_fv ?x)] ] => rewrite (open_qual_just_fv i d x); try opening
  | [ |- context[open_qual ?i ?d (just_loc ?x)] ] => rewrite (open_qual_just_loc i d x); try opening
  | [ H : closed_qual 0 _ _ ?q |- context[open_qual _ _ ?q] ] => erewrite @closed_qual_open_id with (d:=q); eauto; try opening
  | [ H : has_type _ ?q _ _ _ _ |- context[open_qual _ _ ?q] ] => erewrite @has_type_open_qual_id1 with (φ:=q); eauto; try opening
  | [ H : has_type _ _ _ _ _ ?q |- context[open_qual _ _ ?q] ] => erewrite @has_type_open_qual_id2 with (d:=q); eauto; try opening
  | [ H : stp _ _ _ ?q _ _  |- context[open_qual _ _ ?q] ] => erewrite @stp_open_qual_id1 with (q:=q); eauto; try opening
  | [ H : stp _ _ _ _ _ ?q  |- context[open_qual _ _ ?q] ] => erewrite @stp_open_qual_id2 with (d:=q); eauto; try opening
  | [ H : qstp _ _ ?q _  |- context[open_qual _ _ ?q] ] => erewrite @qstp_open_qual_id1 with (q:=q); eauto; try opening
  | [ H : qstp _ _ _ ?q  |- context[open_qual _ _ ?q] ] => erewrite @qstp_open_qual_id2 with (d:=q); eauto; try opening
  | [ |- context[open_qual ?i ?d (just_bv ?i)] ] => try rewrite (@open_qual_just_bv i d); try opening
  | [ |- context[open_qual ?j ?d (just_bv ?i)] ] => try rewrite (@open_qual_just_bv_skip i j d); try lia; try opening
  | [ |- context[open_qual ?j ?d ∅] ] => try rewrite (@open_qual_empty_id j d); try lia; try opening
  (* | [ |- context[open_qual _ _ _] ] => simpl; try opening *)
  | [ H : closed_ty 0 _ _ ?x |- context[open_rec_ty _ _ ?x] ] => erewrite @closed_ty_open_id with (T:=x); eauto; try lia; try opening
  | [ H : has_type _ _ _ _ ?x _ |- context[open_rec_ty _ _ ?x] ] => erewrite @has_type_open_ty_id with (T:=x); eauto; try lia; try opening
  | [ H : stp _ _ ?x _ _ _ |- context[open_rec_ty _ _ ?x] ] => erewrite @stp_open_ty_id1 with (S:=x); eauto; try lia; try opening
  | [ H : stp _ _ _ _ ?x _ |- context[open_rec_ty _ _ ?x] ] => erewrite @stp_open_ty_id2 with (T:=x); eauto; try lia; try opening
  | [ |- context[open_rec_ty _ _ (TFun _ _ _ _)] ] => simpl; try opening
  | [ |- context[open_rec_ty _ _ (TRef _)] ] => simpl; try opening
  | [ |- context[open_rec_ty _ _ _] ] => simpl
  | [ H : closed_tm 0 _ _ ?x |- context[open_rec_tm _ _ ?x] ] => erewrite @closed_tm_open_id with (t:=x); eauto; try lia; try opening
  | [ H : has_type _ _ _ ?x _ _  |- context[open_rec_tm _ _ ?x] ] => erewrite @has_type_open_tm_id with (t:=x); eauto; try lia; try opening
  | [ |- context[open_rec_tm ?i ?x (tvar (varB ?i))] ] => rewrite (open_rec_tm_bv i x); try opening
  | [ |- context[open_rec_tm ?j ?x (tvar (varB ?i))] ] => rewrite (open_rec_tm_bv_skip j i x); try opening
  | [ |- context[open_rec_tm _ _ (tabs _)] ] => simpl; try opening
  | [ |- context[open_rec_tm _ _ (tapp _ _)] ] => simpl; try opening
  | [ |- context[open_rec_tm _ _ (tref _)] ] => simpl; try opening
  | [ |- context[open_rec_tm _ _ (tderef _)] ] => simpl; try opening
  | [ |- context[open_rec_tm _ _ (tassign _ _)] ] => simpl; try opening
  | [ |- context[open_rec_tm _ _ _] ] => simpl
  end.

Ltac qual_destruct :=
  match goal with
  | [ H : qual |- _ ] => destruct H; try clear H; try qual_destruct
  (* | [ H : closed_qual _ _ _ (qset _ _ _) |- _ ] => destruct H; try qual_destruct *)
  end.

Ltac subqual :=
  match goal with
  | [ |- openq _ _ _ ⊑ _ ] => try solve [try opening; try qual_destruct; simpl in *; try set_simpl; intuition; try fnsetdec]
  | [ |- _ ⊑ _ ] => try solve [try qual_destruct; simpl in *; try set_simpl; intuition; try fnsetdec]
  end.

Ltac set_bool_simpl :=
  match goal with
  |  [ |- context[mem ?n {}N] ] => rewrite (NatSetFacts.empty_b n); try set_bool_simpl
  |  [ |- context[mem ?n (singleton ?n)] ] => rewrite mem_singleton'; try set_bool_simpl
  |  [ |- context[mem ?n (singleton ?m)] ] => try (rewrite mem_singleton_neq; auto); try set_bool_simpl
  |  [ |- context[mem ?n (union ?s1 ?s2)]] => rewrite (NatSetProperties.FM.union_b s1 s2 n); try set_bool_simpl
  |  [ |- context[mem ?n (remove ?x ?s)]]  => rewrite (NatSetFacts.remove_b s x n); try set_bool_simpl
  |  [ |- context[NatSetFacts.eqb ?n ?x]]  => rewrite (@natset_eqb x n); try set_bool_simpl
  end.

Ltac lookup_solve :=
  match goal with
  | [ |- (if (beq_nat ?n ?n) then _ else _) = _ ] => rewrite <- beq_nat_refl; auto; try lookup_solve
  | [ |- (if (beq_nat ?n ?m) then _ else _) = _ ] =>
      let H := fresh "H" in
      destruct (beq_nat n m) eqn:H;
      try apply beq_nat_true in H;
      try apply beq_nat_false in H;
      try lia; lookup_solve
  | [ |- Some (_, _, _) = Some (_,_,_) ] => try solve [repeat f_equal; auto; qual_destruct; closed_qual_invert; simpl; f_equal; try set_simpl; try fnsetdec; try bound_simpl; try lia]
  end.

Ltac lookup :=
  match goal with
  | [ |- (@indexr _ _ _) = _ ] => try solve [lookup_solve | simpl; lookup_solve]
  end.

Ltac saturated_solve :=
  match goal with
  | [ |- saturated _ _ (just_loc _) ]                      => apply saturated_just_loc
  | [ |- saturated _ _ ∅ ]                               => apply saturated_empty
  | [ |- saturated [] _ _ ]                                => try solve [apply saturated_empty_tenv; closed_qual_solve]
  | [ H : saturated ?G ?S ?q |- saturated ?G ?S ?q ]       => apply H
  | [ H : saturated ?G ?S ?q |- saturated (_ :: _) ?S ?q ] => try solve [apply saturated_cons; saturated_solve]
  | [ H : saturated ?G ?S ?q |- saturated (_ ++ _) ?S ?q ] => try solve [apply saturated_app; saturated_solve]
  | [ |- saturated _ _ (just_fv _) ]                       => try solve [eapply saturated_singleton; lookup]
  | [ |- saturated _ _ (_ ⊔ _) ]                           => try solve [apply saturated_qqplus; saturated_solve]
  | [ |- saturated _ _ (_ ⋓ _) ]                           => try solve [apply saturated_qqplus; saturated_solve]
  | [ |- saturated _ _ (_ ⊓ _) ]                           => try solve [apply saturated_qqcap; saturated_solve]
  | [ |- saturated _ _ (_ ⋒ _) ]                           => try solve [apply saturated_qqcap; saturated_solve]
  | [ |- saturated _ _ (_ ⊕ _)]                            => try solve [eapply saturated_qplus; try lookup; try closed_qual_solve; saturated_solve]
  | [ |- saturated _ _ (openq _ _ ∅)]                    => try solve [opening; apply saturated_empty]
  | [ |- saturated _ _ (openq _ _ _)]                      => try solve [apply saturated_openq; try closed_qual_solve; saturated_solve]
  | [ |- saturated _ _ ([[_ ~> _ ]]ᵈ ([[_ ~> _ ]]ᵈ ∅))]  => try solve [opening; apply saturated_empty]
  | [ |- saturated _ _ ([[_ ~> _ ]]ᵈ _)]                   => try solve [apply saturated_open_qual; saturated_solve]
  end.

Ltac subtyping k :=
  match goal with
  | [ |- (stp _ _ _ _ _ _) ] => try solve [repeat (constructor ; k () )]
  end.

Ltac cleanup := repeat (try set_simpl; try opening; try set_bool_simpl; simpl).

Ltac crush :=
  try solve [closed_qual_solve];
  try solve [closed_ty_solve];
  try solve [closed_tm_solve];
  try solve [subqual];
  try solve [simpl; qdec];
  try solve [simpl; fnsetdec];
  try solve [lookup];
  try solve [saturated_solve];
  try solve [subtyping ltac:(fun _ => repeat crush; try cleanup)];
  try solve intuition;
  try solve lia.

Ltac ccrush := repeat (crush; try cleanup).

Ltac unfold_open :=
  try unfold openq'; try unfold openq; try unfold open_tm'; try unfold open_ty'; try unfold open_ty.

Tactic Notation "unfold_open" "in" hyp(H) :=
  try unfold openq' in H; try unfold openq in H; try unfold open_tm' in H; try unfold open_ty' in H; try unfold open_ty in *.

(* Deal with cases where applying t_var might stumble. (Seems not needed in lambda_star_lazy systems) *)
(* Ltac TVAR :=
  match goal with
  | [ |- has_type _ _ _ (tvar (varF ?x)) _ (_ ⊕ ?x) ] => apply t_var
  | [ |- has_type _ _ _ (tvar (varF ?x)) _ (qset (singleton ?x) {}N {}N) ] => replace (qset (singleton x) {}N {}N) with (∅ ⊕ x); try TVAR
  | [ |- has_type _ _ _ (tvar (varF ?x)) _ (just_fv ?x) ] => rewrite <- qplus_empty; try TVAR
  end. *)


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

(** * rZ

Pierre Letouzey & Laurent Thery

We define signed variable as follows:

We first define [rNat] as an abbreviation for positive (from fast_integer)
and [rZ] as an inductive type with 2 constructors:

- [rZPlus: rNat ->rZ]
- [rZMinus: rNat ->rZ]

We define usual operations on [rZ], i.e., equality, comparison, etc.

At the end we define functional arrays that will be used in implementation
*)

From Stalmarck Require Import sTactic.
From Coq Require Import Relation_Definitions.
From Coq Require Import ZArith.
From Coq Require Import Inverse_Image.
From Coq Require Import Inclusion.
From Coq Require Import Wf_nat.
From Coq Require Import List.

Definition rNat := positive.

Definition zero := 1%positive.

Definition rnext : rNat -> rNat := Pos.succ.

(** rZ are signed rNat *)
Inductive rZ : Set :=
  | rZPlus : rNat -> rZ
  | rZMinus : rNat -> rZ.

(** We single out zero as being intepreted as True *)
Definition rZTrue := rZPlus zero.

Definition rZFalse := rZMinus zero.

(** Complementary *)
Definition rZComp (r : rZ) : rZ :=
  match r with
  | rZPlus m => rZMinus m
  | rZMinus m => rZPlus m
  end.

Theorem rZCompInv : forall m : rZ, rZComp (rZComp m) = m.
Proof.
intros m; case m; simpl in |- *; auto with stalmarck.
Qed.

(** Comparison function *)
Definition rlt (a b : rNat) : Prop :=
  Pcompare a b Datatypes.Eq = Datatypes.Lt.

(** Decidability over rNat *)
Definition rNatDec : forall n m : rNat, {n = m} + {n <> m}.
intros n m; generalize (nat_of_P_lt_Lt_compare_morphism n m);
 generalize (nat_of_P_gt_Gt_compare_morphism n m);
 generalize (Pcompare_Eq_eq n m); case (Pcompare n m Datatypes.Eq).
intros H' H'0 H'1; left; auto with stalmarck.
intros H' H'0 H'1; right; red in |- *; intros H1;
 absurd (nat_of_P n < nat_of_P m); auto with stalmarck.
rewrite <- H1; auto with arith stalmarck.
intros H' H'0 H'1; right; red in |- *; intros H1;
 absurd (nat_of_P n > nat_of_P m); auto with stalmarck.
rewrite <- H1; auto with arith stalmarck.
Defined.

(** Order is decidable *)
Definition rltDec : forall m n : rNat, {rlt m n} + {rlt n m \/ m = n}.
intros n m; generalize (nat_of_P_lt_Lt_compare_morphism n m);
 generalize (nat_of_P_gt_Gt_compare_morphism n m);
 generalize (Pcompare_Eq_eq n m); case (Pcompare n m Datatypes.Eq).
intros H' H'0 H'1; right; right; auto with stalmarck.
intros H' H'0 H'1; left; unfold rlt in |- *.
apply nat_of_P_lt_Lt_compare_complement_morphism; auto with stalmarck.
intros H' H'0 H'1; right; left; unfold rlt in |- *.
apply nat_of_P_lt_Lt_compare_complement_morphism; auto with stalmarck.
apply H'0; auto with stalmarck.
Defined.

(** An alternative version *)
Definition rltEDec : forall m n : rNat, {rlt m n} + {rlt n m} + {m = n}.
intros n m; generalize (nat_of_P_lt_Lt_compare_morphism n m);
 generalize (nat_of_P_gt_Gt_compare_morphism n m);
 generalize (Pcompare_Eq_eq n m); case (Pcompare n m Datatypes.Eq).
intros H' H'0 H'1; right; auto with stalmarck.
intros H' H'0 H'1; left; left; unfold rlt in |- *.
apply nat_of_P_lt_Lt_compare_complement_morphism; auto with stalmarck.
intros H' H'0 H'1; left; right; unfold rlt in |- *.
apply nat_of_P_lt_Lt_compare_complement_morphism; auto with stalmarck.
apply H'0; auto with stalmarck.
Defined.

(** Some properties of rlt *)
Theorem rltDef2 : forall m n : rNat, rlt m n -> m <> n.
Proof.
unfold rlt in |- *; intros m n H'; red in |- *; intros H'0;
 rewrite <- H'0 in H'; rewrite Pcompare_refl in H';
 discriminate.
Qed.

Theorem rltTrans : transitive rNat rlt.
Proof.
red in |- *; unfold rlt in |- *; intros x y z H1 H2.
apply nat_of_P_lt_Lt_compare_complement_morphism.
apply Nat.lt_trans with (nat_of_P y); apply nat_of_P_lt_Lt_compare_morphism; auto with stalmarck.
Qed.

Theorem rltNotRefl : forall a : rNat, ~ rlt a a.
Proof.
intros a; unfold rlt in |- *; rewrite Pcompare_refl; red in |- *; intros;
 discriminate.
Qed.

#[export] Hint Resolve rltNotRefl : stalmarck.

Theorem rnextRlt : forall m : rNat, rlt m (rnext m).
Proof.
intros m; unfold rlt, rnext in |- *.
apply nat_of_P_lt_Lt_compare_complement_morphism.
rewrite Pplus_one_succ_r; rewrite nat_of_P_plus_morphism;
 unfold nat_of_P in |- *; simpl in |- *; rewrite Nat.add_comm;
 simpl in |- *; auto with arith stalmarck.
Qed.

#[export] Hint Resolve rnextRlt : stalmarck.

Theorem rnextNotZero : forall m : rNat, rlt zero (rnext m).
Proof.
intros m; unfold nat_of_P, rnext, rlt in |- *; elim m; simpl in |- *; auto with stalmarck.
Qed.

#[export] Hint Resolve rnextNotZero : stalmarck.

(** Maximun of two rNat *)
Definition rmax : rNat -> rNat -> rNat.
intros n m; case (rltDec n m); intros Rlt0.
exact m.
exact n.
Defined.

Lemma rmaxRlt : forall n m p : rNat, rlt m n -> rlt p n -> rlt (rmax m p) n.
Proof.
intros n m p; unfold rmax in |- *; case (rltDec m p); auto with stalmarck.
Qed.

Lemma rmaxRltLeft : forall n m p : rNat, rlt (rmax m p) n -> rlt m n.
Proof.
intros n m p; unfold rmax in |- *; case (rltDec m p); auto with stalmarck; intros Rlt0.
intros Rlt1; apply rltTrans with (y := p); auto with stalmarck.
Qed.

Lemma rmaxRltRight : forall n m p : rNat, rlt (rmax m p) n -> rlt p n.
Proof.
intros n m p; unfold rmax in |- *; case (rltDec m p); auto with stalmarck; intros Rlt0.
Casec Rlt0; intros Rlt0; auto with stalmarck.
intros Rlt1; apply rltTrans with (y := m); auto with stalmarck.
rewrite <- Rlt0; auto with stalmarck.
Qed.

(** Properties of rnext *)
Lemma rNextS : forall n : rNat, nat_of_P (rnext n) = S (nat_of_P n).
Proof.
intros n; unfold rnext, nat_of_P in |- *; simpl in |- *.
rewrite Pmult_nat_succ_morphism; auto with stalmarck.
Qed.

Theorem rNextInv : forall n m : rNat, rlt n (rnext m) -> n = m \/ rlt n m.
Proof.
intros n m H'.
generalize (nat_of_P_lt_Lt_compare_morphism _ _ H').
rewrite rNextS.
intros H'0; case (proj1 (Nat.lt_eq_cases _ _) (proj1 (Nat.lt_succ_r _ _) H'0)).
intros H'1; right; red in |- *;
 apply nat_of_P_lt_Lt_compare_complement_morphism;
 auto with stalmarck.
intros H'1; left; apply nat_of_P_inj; auto with stalmarck.
Qed.

Lemma rltTransRnext1 :
 forall n m p : rNat, rlt n (rnext m) -> rlt m p -> rlt n p.
Proof.
intros n m p H' H'0; case (rNextInv n m); auto with stalmarck.
intros H'1; rewrite H'1; auto with stalmarck.
intros H'1; apply rltTrans with (y := m); auto with stalmarck.
Qed.

Lemma rltTransRnext2 :
 forall n m p : rNat, rlt n m -> rlt m (rnext p) -> rlt n p.
Proof.
intros n m p H' H'0; case (rNextInv m p); auto with stalmarck.
intros H'1; rewrite <- H'1; auto with stalmarck.
intros H'1; apply rltTrans with (y := m); auto with stalmarck.
Qed.

Lemma rltRnext2Inv : forall n m : rNat, rlt (rnext n) (rnext m) -> rlt n m.
Proof.
intros n m H'; case (rNextInv (rnext n) m); auto with stalmarck.
intros H'0; rewrite <- H'0; auto with stalmarck.
intros H'1; apply rltTrans with (y := rnext n); auto with stalmarck.
Qed.

Lemma rnextMono : forall m n : rNat, rlt m n -> rlt (rnext m) (rnext n).
Proof.
intros m n H'.
case (rltDec (rnext m) n); intros Rlt0; auto with stalmarck.
apply rltTrans with (y := n); auto with stalmarck.
case Rlt0; intros Rlt1.
elim (rNextInv n m); auto with stalmarck; intros Rlt2; absurd (rlt m m); auto with stalmarck.
rewrite Rlt2 in H'; auto with stalmarck.
apply rltTrans with (y := n); auto with stalmarck.
rewrite <- Rlt1; auto with stalmarck.
Qed.

#[export] Hint Resolve rnextMono : stalmarck.

Lemma rltRmaxLeft : forall n m : rNat, rlt n (rnext (rmax n m)).
Proof.
intros n m; unfold rmax in |- *; case (rltDec n m); auto with stalmarck; intros Rlt0.
apply rltTrans with (y := m); auto with stalmarck.
Qed.

Lemma rltRmaxRight : forall n m : rNat, rlt m (rnext (rmax n m)).
Proof.
intros n m; unfold rmax in |- *; case (rltDec n m); auto with stalmarck; intros Rlt0.
Casec Rlt0; intros Rlt0; auto with stalmarck.
apply rltTrans with (y := n); auto with stalmarck.
rewrite <- Rlt0; auto with stalmarck.
Qed.

#[export] Hint Resolve rltRmaxLeft rltRmaxRight : stalmarck.

Theorem rltAntiSym : forall a b : rNat, rlt a b -> ~ rlt b a.
Proof.
intros a b H'; red in |- *; intros H'0; absurd (rlt a a); auto with stalmarck.
apply rltTrans with (y := b); auto with stalmarck.
Qed.

(** The equality on rZ is decidable *)
Definition rZDec : forall a b : rZ, {a = b} + {a <> b}.
intros a b; case a; case b;
 try (intros; right; red in |- *; intros; discriminate);
 intros a' b'; case (rNatDec a' b'); intros Eq1;
 try (left; rewrite Eq1; auto with stalmarck; fail); auto with stalmarck; intros;
 right; red in |- *; intros Eq2; apply Eq1; inversion Eq2;
 auto with stalmarck.
Defined.

(** Absolute value *)
Definition valRz (a : rZ) :=
  match a with
  | rZPlus b => b
  | rZMinus b => b
  end.

(** Order on rZ *)
Definition rZlt (a b : rZ) := rlt (valRz a) (valRz b).

(** Equality on rZ, two elements sont eqRz if they have same rNat *)
Definition eqRz (a b : rZ) := valRz a = valRz b.

#[export] Hint Unfold eqRz rZlt : stalmarck.

(** Basic properties of eqRz and rZlt *)
Theorem eqrZRefl : reflexive rZ eqRz.
Proof.
red in |- *; intros a; case a; simpl in |- *; auto with stalmarck.
Qed.

#[export] Hint Resolve eqrZRefl : stalmarck.

Theorem eqrZSym : symmetric rZ eqRz.
Proof.
red in |- *; intros a b; case a; case b; simpl in |- *; auto with stalmarck.
Qed.

#[export] Hint Resolve eqrZSym : stalmarck.

Theorem eqrZTrans : transitive rZ eqRz.
Proof.
red in |- *; auto with stalmarck.
unfold eqRz in |- *; intros x y z H'; rewrite H'; auto with stalmarck.
Qed.

#[export] Hint Resolve eqrZTrans : stalmarck.

Definition rZltDec : forall a b : rZ, {rZlt a b} + {rZlt b a \/ eqRz a b}.
intros a b; exact (rltDec (valRz a) (valRz b)).
Defined.

Definition rZltEDec : forall a b : rZ, {rZlt a b} + {rZlt b a} + {eqRz a b}.
intros a b; exact (rltEDec (valRz a) (valRz b)); auto with stalmarck.
Defined.

Theorem rZltEqComp :
 forall a b c d : rZ, rZlt a b -> eqRz a c -> eqRz b d -> rZlt c d.
Proof.
intros a b c d; unfold rZlt, eqRz in |- *; case a; case b; case c; case d;
 simpl in |- *; intros a' b' c' d' H'0 H'1 H'2; try rewrite <- H'1;
 try rewrite <- H'2; auto with stalmarck.
Qed.

Theorem rZltDef2 : forall a b : rZ, rZlt a b -> ~ eqRz a b.
Proof.
intros a b H; unfold eqRz in |- *; apply rltDef2; auto with stalmarck.
Qed.
#[export] Hint Resolve rZltDef2 : stalmarck.

Theorem rZltTrans : transitive rZ rZlt.
Proof.
red in |- *.
intros x y z H' H'0; red in |- *; apply rltTrans with (y := valRz y); auto with stalmarck.
Qed.

#[export] Hint Resolve rZltTrans : stalmarck.

Theorem rZltNotRefl : forall a : rZ, ~ rZlt a a.
Proof.
intros a; unfold rZlt in |- *; auto with stalmarck.
Qed.

#[export] Hint Resolve rZltNotRefl : stalmarck.

Theorem rZltAntiSym : forall a b : rZ, rZlt a b -> ~ rZlt b a.
Proof.
intros a b H'; red in |- *; intros H'0; absurd (rZlt a a); auto with stalmarck.
apply rZltTrans with (y := b); auto with stalmarck.
Qed.

#[export] Hint Resolve rZltAntiSym : stalmarck.

Theorem NotEqComp : forall a : rZ, a <> rZComp a.
Proof.
intros a; case a; red in |- *; intros H'; discriminate.
Qed.

#[export] Hint Resolve NotEqComp : stalmarck.

Theorem eqRzComp : forall a : rZ, eqRz a (rZComp a).
Proof.
intros a; case a; auto with stalmarck.
Qed.

#[export] Hint Resolve eqRzComp : stalmarck.

Theorem valRzComp : forall a : rZ, valRz (rZComp a) = valRz a.
Proof.
intros a; case a; auto with stalmarck.
Qed.

Theorem rZCompInvol : forall a : rZ, a = rZComp (rZComp a).
Proof.
intros a; case a; simpl in |- *; auto with stalmarck.
Qed.

#[export] Hint Resolve rZCompInvol : stalmarck.

Theorem rZCompEq : forall a b : rZ, rZComp a = rZComp b -> a = b.
Proof.
intros a b; case a; case b; simpl in |- *; auto with stalmarck; intros a' b' H; inversion H;
 auto with stalmarck.
Qed.

(** Minimum of two rZ, if they are equal we choose arbitrary the second one *)
Definition min (a b : rZ) : rZ :=
  match rZltDec a b with
  | left _ => a
  | right _ => b
  end.

(** Maximum of two rZ, if they are equal we choose arbitrary the first one *)
Definition max (a b : rZ) : rZ :=
  match rZltDec a b with
  | left _ => b
  | right _ => a
  end.

(** Same basic properties of min and max *)
Theorem minProp1 : forall a b : rZ, rZlt a b -> min a b = a.
Proof.
intros a b; unfold min in |- *; case (rZltDec a b); simpl in |- *; auto with stalmarck.
intros H'; case H'; intros H'0 H'1.
absurd (rZlt b a); auto with stalmarck.
absurd (eqRz a b); auto with stalmarck.
Qed.

Theorem minProp2 : forall a b : rZ, rZlt b a -> min a b = b.
Proof.
intros a b; unfold min in |- *; case (rZltDec a b); simpl in |- *; auto with stalmarck.
intros H'0 H'1; absurd (rZlt b a); auto with stalmarck.
Qed.

Theorem minProp3 : forall a b : rZ, rZlt a b -> min b a = a.
Proof.
intros a b; unfold min in |- *; case (rZltDec b a); simpl in |- *; auto with stalmarck.
intros H'0 H'1; absurd (rZlt b a); auto with stalmarck.
Qed.

Theorem minProp4 : forall a b : rZ, rZlt b a -> min b a = b.
Proof.
intros a b; unfold min in |- *; case (rZltDec b a); simpl in |- *; auto with stalmarck.
intros H'; case H'; intros H'0 H'1.
absurd (rZlt b a); auto with stalmarck.
absurd (eqRz b a); auto with stalmarck.
Qed.

Theorem minProp5 : forall a b : rZ, eqRz a b -> min a b = b.
Proof.
intros a b; unfold min in |- *; case (rZltDec a b); simpl in |- *; auto with stalmarck.
intros H'0 H'1; absurd (eqRz a b); auto with stalmarck.
Qed.

Theorem minProp6 : forall a b : rZ, eqRz a b -> min b a = a.
Proof.
intros a b; unfold min in |- *; case (rZltDec b a); simpl in |- *; auto with stalmarck.
intros H' H'0; absurd (eqRz b a); auto with stalmarck.
Qed.

Theorem maxProp1 : forall a b : rZ, rZlt a b -> max a b = b.
Proof.
intros a b; unfold max in |- *; case (rZltDec a b); simpl in |- *; auto with stalmarck.
intros H'; case H'; intros H'0 H'1.
absurd (rZlt b a); auto with stalmarck.
absurd (eqRz a b); auto with stalmarck.
Qed.

Theorem maxProp2 : forall a b : rZ, rZlt b a -> max a b = a.
Proof.
intros a b; unfold max in |- *; case (rZltDec a b); simpl in |- *; auto with stalmarck.
intros H'0 H'1; absurd (rZlt b a); auto with stalmarck.
Qed.

Theorem maxProp3 : forall a b : rZ, rZlt a b -> max b a = b.
Proof.
intros a b; unfold max in |- *; case (rZltDec b a); simpl in |- *; auto with stalmarck.
intros H'0 H'1; absurd (rZlt b a); auto with stalmarck.
Qed.

Theorem maxProp4 : forall a b : rZ, rZlt b a -> max b a = a.
Proof.
intros a b; unfold max in |- *; case (rZltDec b a); simpl in |- *; auto with stalmarck.
intros H'; case H'; intros H'0 H'1.
absurd (rZlt b a); auto with stalmarck.
absurd (eqRz b a); auto with stalmarck.
Qed.

Theorem maxProp5 : forall a b : rZ, eqRz a b -> max a b = a.
Proof.
intros a b; unfold max in |- *; case (rZltDec a b); simpl in |- *; auto with stalmarck.
intros H' H'0; absurd (eqRz a b); auto with stalmarck.
Qed.

Theorem maxProp6 : forall a b : rZ, eqRz a b -> max b a = b.
Proof.
intros a b; unfold max in |- *; case (rZltDec b a); simpl in |- *; auto with stalmarck.
intros H' H'0; absurd (eqRz b a); auto with stalmarck.
Qed.

(** Check if two rZ are equal *)
Definition rZSignDec :
  forall a b : rZ, {a = b} + {a = rZComp b} + {~ eqRz a b}.
intros a b; case a; case b; intros a' b'; case (rNatDec a' b'); simpl in |- *;
 auto with stalmarck; intros Eqa'b'.
left; left; rewrite Eqa'b'; auto with stalmarck.
left; right; rewrite Eqa'b'; auto with stalmarck.
left; right; rewrite Eqa'b'; auto with stalmarck.
left; left; rewrite Eqa'b'; auto with stalmarck.
Defined.

(** Lift every function of rNat-> rZ to a function rZ -> rZ
   that is compatible with the complement *)
Definition liftRz (f : rNat -> rZ) (a : rZ) :=
  match a with
  | rZPlus a' => f a'
  | rZMinus a' => rZComp (f a')
  end.

(** Given a:rZ and b:rNat produces an rZ that has the same sign than
   a but the same rNat than b *)
Definition samePol (a : rZ) (b : rNat) := liftRz (fun a : rNat => rZPlus b) a.

(** Comparison between an rZ and an rNat *)
Definition rVlt (a : rZ) (b : rNat) := rlt (valRz a) b.

(** Comparison is compatible with the complement *)
Theorem rVltrZComp :
 forall (a : rZ) (b : rNat), rVlt a b -> rVlt (rZComp a) b.
Proof.
intros a b; case a; simpl in |- *; auto with stalmarck.
Qed.

#[export] Hint Resolve rVltrZComp : stalmarck.

(** Given a:rZ and b:rZ produces an rZ that has the same sign than
   sign(a)*sign(b) but the same rNat than b *)
Definition samePolRz (a b : rZ) := liftRz (fun c : rNat => b) a.

(** Some properties of samePolRz *)
Theorem samePolRzValRz :
 forall (p : rZ) (q : rNat), valRz (samePolRz p (rZPlus q)) = q.
Proof.
intros p; case p; simpl in |- *; auto with stalmarck.
Qed.

Theorem samePolRzEqRz : forall p q : rZ, eqRz (samePolRz p q) q.
Proof.
intros p; case p; auto with stalmarck.
Qed.

Theorem samePolRzRvlt :
 forall (p q : rZ) (r : rNat), rVlt p r -> rVlt (samePolRz q p) r.
Proof.
intros p q r; case q; auto with stalmarck.
Qed.

Theorem samePolRzInvRvlt :
 forall (p q : rZ) (r : rNat), rVlt (samePolRz q p) r -> rVlt p r.
Proof.
intros p q r; case q; simpl in |- *; auto with stalmarck.
intros H' H'0; replace p with (rZComp (rZComp p)); auto with stalmarck.
Qed.

Theorem samePolRzsamePolRz : forall p q : rZ, samePolRz p (samePolRz p q) = q.
Proof.
intros p; case p; auto with stalmarck.
Qed.

Theorem samePolSamePolRz :
 forall (p q : rZ) (r : rNat),
 samePol (samePolRz p q) r = samePolRz p (samePol q r).
Proof.
intros p q; case p; case q; auto with stalmarck.
Qed.

Theorem samePolRzComp :
 forall p q : rZ, rZComp (samePolRz p q) = samePolRz p (rZComp q).
Proof.
intros p q; case p; case q; simpl in |- *; auto with stalmarck.
Qed.

(**
 Definition of function arrays on an arbitrary type A, using
 positive numbers as indexes
*)
Section rA.
Variable A : Type.
(* Usual binary tree *)

Inductive rTree : Type :=
  | rEmpty : rTree
  | rSplit : option A -> rTree -> rTree -> rTree.
(* We use the positive number as a path in the tree to retrieve
   a value *)

Fixpoint rTreeGet (t : rTree) (r : rNat) {struct r} :
 option A :=
  match r, t with
  | _, rEmpty => None
  | xH, rSplit a _ _ => a
  | xO p, rSplit _ t' _ => rTreeGet t' p
  | xI p, rSplit _ _ t' => rTreeGet t' p
  end.
(* To update a Tree we modify the branch designated by the number *)

Fixpoint rTreeSet (t : rTree) (r : rNat) {struct r} :
 A -> rTree :=
  fun a : A =>
  match r, t with
  | xH, rEmpty => rSplit (Some a) rEmpty rEmpty
  | xO p, rEmpty => rSplit (None) (rTreeSet rEmpty p a) rEmpty
  | xI p, rEmpty => rSplit (None) rEmpty (rTreeSet rEmpty p a)
  | xH, rSplit _ t'1 t'2 => rSplit (Some a) t'1 t'2
  | xO p, rSplit b t'1 t'2 => rSplit b (rTreeSet t'1 p a) t'2
  | xI p, rSplit b t'1 t'2 => rSplit b t'1 (rTreeSet t'2 p a)
  end.
(* Standard properties for the Set and Get function *)

Theorem rTreeDef1 :
 forall (t : rTree) (m : rNat) (v : A),
 rTreeGet (rTreeSet t m v) m = Some v.
Proof.
intros t m; generalize t; Elimc m; simpl in |- *; clear t.
intros p H' t v; case t; auto with stalmarck.
intros p H' t v; case t; auto with stalmarck.
intros t v; case t; auto with stalmarck.
Qed.

Theorem rTreeDef2 :
 forall (t : rTree) (m1 m2 : rNat) (v : A),
 m1 <> m2 -> rTreeGet (rTreeSet t m1 v) m2 = rTreeGet t m2.
Proof.
intros t m; generalize t; Elimc m; simpl in |- *; clear t.
intros p H' t m2 v; case m2; simpl in |- *; case t; auto with stalmarck.
intros p0 H'0; rewrite H'; auto with stalmarck.
elim p0; simpl in |- *; auto with stalmarck.
Contradict H'0; rewrite H'0; auto with stalmarck.
intros a r1 r2 p0 H'0; rewrite H'; auto with stalmarck.
Contradict H'0; rewrite H'0; auto with stalmarck.
intros p0 H'0; elim p0; simpl in |- *; auto with stalmarck.
intros p H' t m2 v; case m2; simpl in |- *; case t; auto with stalmarck.
intros p0 H'0; elim p0; simpl in |- *; auto with stalmarck.
intros p0 H'0; rewrite H'; auto with stalmarck.
elim p0; simpl in |- *; auto with stalmarck.
Contradict H'0; rewrite H'0; auto with stalmarck.
intros a r1 r2 p0 H'0; rewrite H'; auto with stalmarck.
Contradict H'0; rewrite H'0; auto with stalmarck.
intros t m2 v; case m2; simpl in |- *; auto with stalmarck.
case t; intros p H'; elim p; simpl in |- *; auto with stalmarck.
case t; intros p H'; elim p; simpl in |- *; auto with stalmarck.
intros H'; Contradict H'; auto with stalmarck.
Qed.

(** We turn our rTree into a function array using a default function *)
Inductive rArray : Type :=
    rArrayMake : rTree -> (rNat -> A) -> rArray.

Definition rArrayGet (ar : rArray) (r : rNat) :=
  match ar with
  | rArrayMake t f => match rTreeGet t r with
                      | Some a => a
                      | _ => f r
                      end
  end.

Definition rArraySet (ar : rArray) (r : rNat) (v : A) :=
  match ar with
  | rArrayMake t f => rArrayMake (rTreeSet t r v) f
  end.
(* We get the standard properties *)

Theorem rArrayDef1 :
 forall (Ar : rArray) (m : rNat) (v : A), rArrayGet (rArraySet Ar m v) m = v.
Proof.
intros Ar m v; case Ar; simpl in |- *.
intros r a; rewrite (rTreeDef1 r m v); auto with stalmarck.
Qed.

Theorem rArrayDef2 :
 forall (Ar : rArray) (m1 m2 : rNat) (v : A),
 m1 <> m2 -> rArrayGet (rArraySet Ar m1 v) m2 = rArrayGet Ar m2.
Proof.
intros Ar m1 m2 v H'; case Ar; simpl in |- *.
intros r a; rewrite (rTreeDef2 r m1 m2 v); auto with stalmarck.
Qed.

(** Empty array with default value *)
Definition rArrayInit (f : rNat -> A) := rArrayMake rEmpty f.

Theorem rArrayDef :
 forall (m : rNat) (f : rNat -> A), rArrayGet (rArrayInit f) m = f m.
Proof.
intros m f; simpl in |- *; auto with stalmarck.
elim m; simpl in |- *; auto with stalmarck.
Qed.

End rA.


Require Export Coq.ZArith.ZArith.
Require Export Coq.Lists.List. Import ListNotations.
Require Import coqutil.Tactics.rdelta.
Require Import coqutil.Tactics.destr.
Require Import coqutil.Z.prove_Zeq_bitwise.
Require Import coqutil.Tactics.Tactics.
Require Import coqutil.Tactics.fwd.
Require Export riscv.Spec.Decode.
Require Export riscv.Utility.Encode.
Require Export riscv.Utility.Utility.
Require Import riscv.Proofs.DecodeByExtension.

Local Open Scope Z_scope.

Ltac isConst x :=
  lazymatch x with
  | ?a ^ ?b => isConst a; isConst b
  | ?a - ?b => isConst a; isConst b
  | - ?a => isConst a
  | Z.max ?a ?b => isConst a; isConst b
  | _ => let x' := rdelta x in
         lazymatch isZcst x' with
         | true => idtac
         end
  end.

Lemma verify_decode: forall iset inst,
    supportsF iset = false ->
    verify (decode iset inst) iset \/ decode iset inst = InvalidInstruction inst.
Proof.
  intros. rewrite <- decode_seq_correct.
  assert (bitwidth iset = 2 ^ 5 \/ bitwidth iset = 2 ^ 6) as bw_cases. {
    destruct iset; cbn; auto.
  }
  assert (bitSlice inst 25 26 = 0 -> bitSlice inst 20 26 < bitwidth iset). {
    intros.
    rewrite bitSlice_alt in *. 2-3: cbv; intuition congruence.
    unfold bitSlice' in *.
    Z.div_mod_to_equations.
    Lia.lia.
  }
  assert (signExtend 32 (BinInt.Z.shiftl (bitSlice inst 12 32) 12) mod 2 ^ 12 = 0). {
    unfold signExtend.
    rewrite Z.shiftl_mul_pow2 by (cbv; discriminate 1).
    Z.div_mod_to_equations.
    Lia.lia.
  }
  assert (signExtend 13
   (Z.shiftl (bitSlice inst 31 32) 12 <|> BinInt.Z.shiftl (bitSlice inst 25 31) 5 <|>
    Z.shiftl (bitSlice inst 8 12) 1 <|> BinInt.Z.shiftl (bitSlice inst 7 8) 11) mod 2 = 0). {
    eapply mod20_bitSlice.
    prove_Zeq_bitwise.
  }
  assert (signExtend 21
   (BinInt.Z.shiftl (bitSlice inst 31 32) 20 <|> BinInt.Z.shiftl (bitSlice inst 21 31) 1 <|>
    BinInt.Z.shiftl (bitSlice inst 20 21) 11 <|> BinInt.Z.shiftl (bitSlice inst 12 20) 12)
   mod 2 = 0). {
    eapply mod20_bitSlice.
    prove_Zeq_bitwise.
  }
  unfold decode_seq.
  repeat destruct_one_match; fwd.
  all: (right; reflexivity) || left.
  all: try match goal with
           | H': supportsF _ = true |- _ => exfalso; congruence
           end.
  all: unfold verify, verify_iset.
  all: split;
    [|repeat match goal with
             | H: bitwidth _ = _ |- _ => unfold bitwidth in H
             end;
      unfold supportsM, supportsA, supportsF in *;
      destruct iset; try intuition congruence].
  all: match goal with
       | |- respects_bounds _ (_ ?d) => remember d as r in *; revert dependent r; intro r
       end.
  all: cbv beta zeta delta [decodeI decodeM decodeA decodeF
                            decodeI64 decodeM64 decodeA64 decodeF64
                            decodeCSR
                            isValidI isValidM isValidA isValidF
                            isValidI64 isValidM64 isValidA64 isValidF64
                            isValidCSR].
  all: loop INil.
  all: intros; subst.
  all: match goal with
       | H: ?x = ?x |- _ => clear H
       | H: false = true |- _ => discriminate H
       end.
  all: cbv beta iota zeta delta [respects_bounds apply_InstructionMapper Verifier
         map_Invalid map_R map_R_atomic map_I map_I_shift_57 map_I_shift_66
         map_I_system map_S map_SB map_U map_UJ map_Fence map_FenceI
         verify_Invalid verify_R verify_R_atomic verify_I verify_I_shift_57 verify_I_shift_66
         verify_I_system verify_S verify_SB verify_U verify_UJ verify_Fence verify_FenceI
         machineIntToShamt id
       ].
  all: repeat match goal with
              | |- 0 <= bitSlice _ _ _ < _ => eapply bitSlice_bounds
              | |- _ <= signExtend _ _ < _ => eapply signExtend_bounds; cbv; discriminate 1
              | |- _ /\ _ => split
              | |- ?x <= ?y => isConst x; isConst y; cbv; discriminate 1
              | |- ?x < ?y => isConst x; isConst y; reflexivity
              | |- 0 <= bitSlice _ _ _ => eapply bitSlice_nonneg
              | |- bitSlice _ _ _ < 2 ^ _ => eapply bitSlice_upper_bound
              | |- _ < bitwidth ?iset => replace (bitwidth iset) with 64;
                                         [ change 64 with (2 ^ 6) ]
              | |- _ => auto 3
              end.
Qed.


From mathcomp Require Import all_ssreflect.
Set Bullet Behavior "Strict Subproofs".
Require Import Types.

 (** Instructions for a machine to determine recursive inhabitation targets **)
Section RecursiveTargetsMachineInstuctions.
  Variable Constructor: ctor.

  Inductive Instruction: Type :=
  | AddSplitsWithSrcsToCtxt of (@IT Constructor * seq (@IT Constructor) * seq (seq (seq (@IT Constructor) * @IT Constructor)))
  | SplitType of (@IT Constructor).

  Inductive Result: Type :=
  | LengthGroupedSourceTargetPairs of seq (seq (seq (@IT Constructor) * @IT Constructor)).

  (** Enable mathcomp functionalities on instructions **)
  Section InstructionMathcompInstances.
    Fixpoint Instruction2tree (i: Instruction):
      GenTree.tree (@IT Constructor + (seq (@IT Constructor) + seq (seq (seq (@IT Constructor) * @IT Constructor)))) :=
      match i with
      | AddSplitsWithSrcsToCtxt (A, Srcs, Ctxt) =>
        GenTree.Node 0 [:: GenTree.Leaf (inl A);
                          GenTree.Leaf (inr (inl Srcs));
                          GenTree.Leaf (inr (inr Ctxt))]
      | SplitType A => GenTree.Node 1 [:: GenTree.Leaf (inl A) ]
      end.

    Fixpoint Result2tree (r: Result): GenTree.tree (seq (seq (seq (@IT Constructor) * @IT Constructor))) :=
      match r with
      | LengthGroupedSourceTargetPairs Ctxt => GenTree.Node 0 [:: (GenTree.Leaf Ctxt) ]
      end.

    Fixpoint tree2Instruction (t: GenTree.tree (@IT Constructor + (seq (@IT Constructor) + seq (seq (seq (@IT Constructor) * @IT Constructor))))): option Instruction :=
      match t with
      | GenTree.Node n args =>
        match n, args with
        | 0, [:: GenTree.Leaf (inl A); GenTree.Leaf (inr (inl Srcs)); GenTree.Leaf (inr (inr Ctxt))] =>
          Some (AddSplitsWithSrcsToCtxt (A, Srcs, Ctxt))
        | 1, [:: GenTree.Leaf (inl A)] => Some (SplitType A)
        | _, _ => None
        end
      | _ => None
      end.

    Fixpoint tree2Result (t: GenTree.tree (seq (seq (seq (@IT Constructor) * @IT Constructor)))): option Result :=
      match t with
      | GenTree.Node n args =>
        match n, args with
        | 0, [:: GenTree.Leaf Ctxt] => Some (LengthGroupedSourceTargetPairs Ctxt)
        | _, _ => None
        end
      | _ => None
      end.

    Lemma pcan_Instructiontree: pcancel Instruction2tree tree2Instruction.
    Proof. by case => //= [] [] [] //=. Qed.

    Lemma pcan_Resulttree: pcancel Result2tree tree2Result.
    Proof. by case => //= []. Qed.

    Definition Instruction_eqMixin := PcanEqMixin pcan_Instructiontree.
    Canonical Instruction_eqType := EqType Instruction Instruction_eqMixin.
    Definition Instruction_choiceMixin := PcanChoiceMixin pcan_Instructiontree.
    Canonical Instruction_choiceType := ChoiceType Instruction Instruction_choiceMixin.
    Definition Instruction_countMixin := PcanCountMixin pcan_Instructiontree.
    Canonical Instruction_countType := CountType Instruction Instruction_countMixin.
    Definition Result_eqMixin := PcanEqMixin pcan_Resulttree.
    Canonical Result_eqType := EqType Result Result_eqMixin.
    Definition Result_choiceMixin := PcanChoiceMixin pcan_Resulttree.
    Canonical Result_choiceType := ChoiceType Result Result_choiceMixin.
    Definition Result_countMixin := PcanCountMixin pcan_Resulttree.
    Canonical Result_countType := CountType Result Result_countMixin.
  End InstructionMathcompInstances.
End RecursiveTargetsMachineInstuctions.

Arguments Instruction [Constructor].
Arguments AddSplitsWithSrcsToCtxt [Constructor].
Arguments SplitType [Constructor].
Hint Constructors Instruction.

Arguments Result [Constructor].
Arguments LengthGroupedSourceTargetPairs [Constructor].
Hint Constructors Result.

Notation "[ 'split' A ]" := (SplitType A) (at level 0): it_scope.
Notation "[ 'add_splits_with_srcs' Srcs => A  'to' Ctxt ]" :=
  (AddSplitsWithSrcsToCtxt (A, Srcs, Ctxt)) (at level 0): it_scope.
Notation "[ 'splits' Delta ]" := (LengthGroupedSourceTargetPairs Delta) (at level 0): it_scope.

(** A machine to determine recursive inhabitation targets **)
Reserved Notation "A '~~>' B" (at level 70, no associativity).
Section RecursiveTargetsMachine.
  Variable Constructor: ctor.

  Definition addToHead {T: Type} (x: T) (xss: seq (seq T)): seq (seq T) :=
    match xss with
    | [::] => [:: [:: x]]
    | [:: xs & xss] => [:: [:: x & xs] & xss]
    end.

  (** Semantics of the recursive target machine **)
  Inductive Semantics : @Instruction Constructor -> @Result Constructor -> Prop :=
  | step__split : forall A Delta,
      [add_splits_with_srcs [::] => A to [:: [::]] ] ~~> [splits Delta ] ->
      [split A ] ~~> [splits Delta ]
  | step__splitCtor : forall c A Gamma Delta,
      [add_splits_with_srcs Gamma => Ctor c A to Delta ] ~~> [splits (addToHead (Gamma, Ctor c A) Delta) ]
  | step__splitProd : forall A B Gamma Delta,
      [add_splits_with_srcs Gamma => A \times B to Delta ] ~~> [splits (addToHead (Gamma, A \times B) Delta) ]
  | step__splitArr : forall A B Gamma Delta Delta',
      [add_splits_with_srcs [:: A & Gamma] => B to Delta ] ~~> [splits Delta' ] ->
      [add_splits_with_srcs Gamma => A -> B to Delta ]
        ~~> [splits if isOmega B then Delta else [:: [:: (Gamma, A -> B)] & Delta'] ]
  | step__splitOmega: forall Gamma Delta,
      [add_splits_with_srcs Gamma => Omega to Delta ] ~~> [splits Delta ]
  | step__splitInterCtor: forall c A B Gamma Delta Delta',
      [add_splits_with_srcs Gamma => B to Delta ] ~~> [splits Delta' ] ->
      [add_splits_with_srcs Gamma => (Ctor c A) \cap B to Delta ]
        ~~> [splits (addToHead (Gamma, Ctor c A) Delta') ]
  | step__splitInterProd: forall A1 A2 B Gamma Delta Delta',
      [add_splits_with_srcs Gamma => B to Delta ] ~~> [splits Delta' ] ->
      [add_splits_with_srcs Gamma => (A1 \times A2) \cap B to Delta ]
        ~~> [splits (addToHead (Gamma, A1 \times A2) Delta') ]
  | step__splitInterArr: forall A1 A2 B Gamma Gamma' Delta1 Delta2 Delta3,
      [add_splits_with_srcs Gamma => B to Delta1 ] ~~> [splits [:: Gamma' & Delta2] ] ->
      [add_splits_with_srcs [:: A1 & Gamma] => A2 to Delta2 ] ~~> [splits Delta3 ] ->
      [add_splits_with_srcs Gamma => (A1 -> A2) \cap B to Delta1 ]
        ~~> [splits if isOmega A2 then [:: Gamma' & Delta2] else [:: [:: (Gamma, A1 -> A2) & Gamma'] & Delta3] ]
  | step__splitInterAssoc: forall A1 A2 B Gamma Delta Delta',
      [add_splits_with_srcs Gamma => A1 \cap (A2 \cap B) to Delta ] ~~> [splits Delta' ] ->
      [add_splits_with_srcs Gamma => (A1 \cap A2) \cap B to Delta ] ~~> [splits Delta' ]
  | step__splitInterOmega: forall B Gamma Delta Delta',
      [add_splits_with_srcs Gamma => B to Delta ] ~~> [splits Delta' ] ->
      [add_splits_with_srcs Gamma => Omega \cap B to Delta ] ~~> [splits Delta' ]
  where "p1 ~~> p2" := (Semantics p1 p2).

  Definition premisses_Semantics {i} {p} (s: i ~~> p) :=
    let diag i p :=
        match i, p with
        | [split A], [splits Delta]  =>
          forall (X: Result -> Prop),
            (forall Delta', [add_splits_with_srcs [::] => A to [:: [::]] ] ~~> [splits Delta' ] ->
                          X [splits Delta']) ->
            X [splits Delta]
        | [add_splits_with_srcs Gamma => Ctor c A to Delta ], [splits Delta'] =>
          forall (X: Result -> Prop),
            X [splits (addToHead (Gamma, Ctor c A) Delta) ] ->
            X [splits Delta']
        | [add_splits_with_srcs Gamma => A \times B to Delta ], [splits Delta] =>
          forall (X: Result -> Prop),
            X [splits (addToHead (Gamma, A \times B) Delta) ] ->
            X [splits Delta]
        | [add_splits_with_srcs Gamma => A -> B to Delta ], [splits Delta] =>

            ~~> [splits if isOmega B then Delta else [:: [:: (Gamma, A -> B)] & Delta'] ]
        | [add_splits_with_srcs Gamma => Omega to Delta ] ~~> [splits Delta ]
        | [add_splits_with_srcs Gamma => (Ctor c A) \cap B to Delta ]
            ~~> [splits (addToHead (Gamma, Ctor c A) Delta') ]
        | [add_splits_with_srcs Gamma => (A1 \times A2) \cap B to Delta ]
            ~~> [splits (addToHead (Gamma, A1 \times A2) Delta') ]
        | [add_splits_with_srcs Gamma => (A1 -> A2) \cap B to Delta1 ]
            ~~> [splits if isOmega A2 then [:: Gamma' & Delta2] else [:: [:: (Gamma, A1 -> A2) & Gamma'] & Delta3] ]
        |  [add_splits_with_srcs Gamma => (A1 \cap A2) \cap B to Delta ] ~~> [splits Delta' ]
        | [add_splits_with_srcs Gamma => Omega \cap B to Delta ] ~~> [splits Delta' ]
        | _, _  => True
        end in
    match s in i ~~> p return diag i p with
    | step__split A Delta prf => fun X k => k Delta prf
    | step__splitCtor c A Gamma Delta => fun X k => k
    | _ => I
    end.

End RecursiveTargetsMachine.

Arguments Semantics [Constructor].
Arguments step__split [Constructor A Delta].
Arguments step__splitCtor [Constructor c A Gamma Delta].
Arguments step__splitProd [Constructor A B Gamma Delta].
Arguments step__splitArr [Constructor A B Gamma Delta Delta'].
Arguments step__splitOmega [Constructor Gamma Delta].
Arguments step__splitInterCtor [Constructor c A B Gamma Delta Delta'].
Arguments step__splitInterProd [Constructor A1 A2 B Gamma Delta Delta'].
Arguments step__splitInterArr [Constructor A1 A2 B Gamma Gamma' Delta1 Delta2 Delta3].
Arguments step__splitInterAssoc [Constructor A1 A2 B Gamma Delta Delta'].
Arguments step__splitInterOmega [Constructor B Gamma Delta Delta'].
Hint Constructors Semantics.
Notation "p1 ~~> p2" := (Semantics p1 p2).

Arguments premisses_Semantics [Constructor] [i p].

Ltac foo :=
  match goal with
  |[ x : Result |- _ ~~> ?x -> _] =>
   let stp := fresh "step" in
   let r := fresh "result" in
   move: x => [] r stp; apply: (premisses_Semantics stp); eauto; move: r
  | [|- _ ~~> _ -> _] =>
    let stp := fresh "step" in
    move => stp; apply: (premisses_Semantics stp); eauto; move: stp
  | [|- forall _, _] =>
    let x := fresh "x" in
    move => x; foo; move: x
  | [|- _] => idtac
  end.

Section RecursiveTargetsMachineSpec.
  Variable Constructor: ctor.
  Implicit Type p: @Instruction Constructor.
  Implicit Type r: @Result Constructor.

  Lemma Semantics_functional: forall p r1 r2, p ~~> r1 -> p ~~> r2 -> r1 = r2.
  Proof.
    move => p r1 r2 pr1.
    move: r2.
    elim: p r1 / pr1 => //.
    - foo.
    - foo.
    - foo.
      move => ?.
      move => ?.
      move => ?.move => ?.
      move => [] r stp.
      apply: (premisses_Semantics stp).

      move => ? ? ? ? [] ? pr2.
        by apply: (premisses_Semantics pr2); eauto.
    - move => ? ? ? ? [] ? pr2.
        by apply: (premisses_Semantics pr2).
    -
    -


Require Import Fiat.Parsers.StringLike.Core.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Fiat.Parsers.Reachable.ParenBalanced.Core.
Require Import Fiat.Parsers.Refinement.BinOpBrackets.ParenBalanced.
Require Import Fiat.Common.

Set Implicit Arguments.

Section helpers.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}.
  Context {pdata : paren_balanced_hiding_dataT Char}.

  Local Ltac induction_str_len str :=
    let len := fresh "len" in
    set (len := length str);
      generalize (eq_refl : length str = len);
      clearbody len; revert str;
      induction len; intros str ?.

  Local Ltac t :=
    repeat match goal with
             | [ |- ?x = ?x ] => reflexivity
             | [ H : is_true false |- _ ] => solve [ inversion H ]
             | [ H : false = true |- _ ] => solve [ inversion H ]
             | _ => progress rewrite ?take_length, ?drop_length
             | [ H : _ |- _ ] => progress rewrite ?take_length, ?drop_length, ?drop_take, ?drop_0, ?NPeano.Nat.sub_0_r, ?NPeano.Nat.sub_1_r in H
             | [ H : ?x = 0, H' : context[?x] |- _ ] => rewrite H in H'
             | [ H : length ?str = 0, H' : is_true (take _ (drop _ ?str) ~= [ _ ])%string_like |- _ ]
               => apply length_singleton in H'
             | [ H : get 0 _ = None |- _ ] => apply no_first_char_empty in H
             | _ => progress simpl in *
             | _ => progress subst
             | _ => setoid_rewrite Bool.andb_true_iff
             | [ H : (_ && _ = true)%bool |- _ ] => apply Bool.andb_true_iff in H
             | _ => progress specialize_by omega
             | _ => progress specialize_by assumption
             | _ => progress split_and
             | [ |- context[if ?e then _ else _] ] => destruct e eqn:?
             | [ H : context[if ?e then _ else _] |- _ ] => destruct e eqn:?
             | _ => solve [ eauto with nocore ]
             | [ H : context[drop _ (drop _ _)] |- _ ] => setoid_rewrite drop_drop in H
             | [ |- appcontext[match get 0 (take _ _) with _ => _ end] ] => rewrite !get_take_lt by omega
             | [ H : context[(_ + 1)%nat] |- _ ] => setoid_rewrite NPeano.Nat.add_1_r in H
             | [ |- context[get 0 ?str] ] => erewrite (proj1 (get_0 str _)) by eassumption
             | [ |- context[get 0 (take 0 ?str)] ] => rewrite (has_first_char_nonempty (take 0 str))
                                                     by (rewrite take_length; reflexivity)
             | [ H : context[Compare_dec.zerop ?x] |- _ ] => destruct (Compare_dec.zerop x)
             | _ => progress intros
             | _ => omega
             | [ H : context[match get 0 ?str with _ => _ end] |- _ ] => destruct (get 0 str) eqn:?
             | _ => progress unfold is_true in *
           end.

  Lemma paren_balanced_hiding'_prefix (str : String) (n n' level : nat)
        (H_hiding : paren_balanced_hiding' (take n str) level)
        (H_hiding_prefix : paren_balanced' (take n' str) level)
        {ch}
        (Hlt : n' < n)
        (H_ch : (take 1 (drop n' str) ~= [ ch ])%string_like)
        (H_bin_op : is_bin_op ch)
  : False.
  Proof.
    generalize dependent level.
    generalize dependent n'.
    generalize dependent n.
    induction_str_len str.
    { t. }
    { specialize (IHlen (drop 1 str)).
      specialize_by ltac:(rewrite drop_length; omega).
      intros ?????.
      rewrite paren_balanced_hiding'_recr, paren_balanced'_recr.
      unfold paren_balanced_hiding'_step, paren_balanced'_step.
      destruct n' as [|n'].
      { t. }
      { specialize (IHlen (pred n) n').
        t. } }
  Qed.
End helpers.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*                  Xavier Leroy, INRIA Paris                          *)
(*                                                                     *)
(*  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 x86-64 generation: main proof. *)

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

Definition match_prog (p: Mach.program) (tp: Asm.program) :=
  match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp.

Lemma transf_program_match:
  forall p tp, transf_program p = OK tp -> match_prog p tp.
Proof.
  intros. eapply match_transform_partial_program; eauto.
Qed.

Section PRESERVATION.
Context `{external_calls_prf: ExternalCalls}.

Local Existing Instance mem_accessors_default.

Variable prog: Mach.program.
Variable tprog: Asm.program.
Hypothesis TRANSF: match_prog prog tprog.
Let ge := Genv.globalenv prog.
Let tge := Genv.globalenv tprog.

Lemma symbols_preserved:
  forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
Proof (Genv.find_symbol_match TRANSF).

Lemma senv_preserved:
  Senv.equiv ge tge.
Proof (Genv.senv_match TRANSF).

Lemma genv_next_preserved:
  Genv.genv_next tge = Genv.genv_next ge.
Proof. apply senv_preserved. Qed.

Lemma functions_translated:
  forall b f,
  Genv.find_funct_ptr ge b = Some f ->
  exists tf,
  Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf.
Proof (Genv.find_funct_ptr_transf_partial TRANSF).

Lemma functions_transl:
  forall fb f tf,
  Genv.find_funct_ptr ge fb = Some (Internal f) ->
  transf_function f = OK tf ->
  Genv.find_funct_ptr tge fb = Some (Internal tf).
Proof.
  intros. exploit functions_translated; eauto. intros [tf' [A B]].
  monadInv B. rewrite H0 in EQ; inv EQ; auto.
Qed.

(** * Properties of control flow *)

Lemma transf_function_no_overflow:
  forall f tf,
  transf_function f = OK tf -> list_length_z (fn_code tf) <= Ptrofs.max_unsigned.
Proof.
  intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x))); monadInv EQ0.
  omega.
Qed.

Lemma exec_straight_exec:
  forall fb f c ep tf tc c' rs m rs' m',
  transl_code_at_pc ge (rs PC) fb f c ep tf tc ->
  exec_straight tge tf tc rs m c' rs' m' ->
  plus step tge (State rs m) E0 (State rs' m').
Proof.
  intros. inv H.
  eapply exec_straight_steps_1; eauto.
  eapply transf_function_no_overflow; eauto.
  eapply functions_transl; eauto.
Qed.

Lemma exec_straight_at:
  forall fb f c ep tf tc c' ep' tc' rs m rs' m',
  transl_code_at_pc ge (rs PC) fb f c ep tf tc ->
  transl_code f c' ep' = OK tc' ->
  exec_straight tge tf tc rs m tc' rs' m' ->
  transl_code_at_pc ge (rs' PC) fb f c' ep' tf tc'.
Proof.
  intros. inv H.
  exploit exec_straight_steps_2; eauto.
  eapply transf_function_no_overflow; eauto.
  eapply functions_transl; eauto.
  intros [ofs' [PC' CT']].
  rewrite PC'. constructor; auto.
Qed.

(** The following lemmas show that the translation from Mach to Asm
  preserves labels, in the sense that the following diagram commutes:
<<
                          translation
        Mach code ------------------------ Asm instr sequence
            |                                          |
            | Mach.find_label lbl       find_label lbl |
            |                                          |
            v                                          v
        Mach code tail ------------------- Asm instr seq tail
                          translation
>>
  The proof demands many boring lemmas showing that Asm constructor
  functions do not introduce new labels.

  In passing, we also prove a "is tail" property of the generated Asm code.
*)

Section TRANSL_LABEL.

Remark mk_mov_label:
  forall rd rs k c, mk_mov rd rs k = OK c -> tail_nolabel k c.
Proof.
  unfold mk_mov; intros.
  destruct rd; try discriminate; destruct rs; TailNoLabel.
Qed.
Hint Resolve mk_mov_label: labels.

Remark mk_shrximm_label:
  forall n k c, mk_shrximm n k = OK c -> tail_nolabel k c.
Proof.
  intros. monadInv H; TailNoLabel.
Qed.
Hint Resolve mk_shrximm_label: labels.

Remark mk_shrxlimm_label:
  forall n k c, mk_shrxlimm n k = OK c -> tail_nolabel k c.
Proof.
  intros. monadInv H. destruct (Int.eq n Int.zero); TailNoLabel.
Qed.
Hint Resolve mk_shrxlimm_label: labels.

Remark mk_intconv_label:
  forall f r1 r2 k c, mk_intconv f r1 r2 k = OK c ->
  (forall r r', nolabel (f r r')) ->
  tail_nolabel k c.
Proof.
  unfold mk_intconv; intros. TailNoLabel.
Qed.
Hint Resolve mk_intconv_label: labels.

Remark mk_storebyte_label:
  forall addr r k c, mk_storebyte addr r k = OK c -> tail_nolabel k c.
Proof.
  unfold mk_storebyte; intros. TailNoLabel.
Qed.
Hint Resolve mk_storebyte_label: labels.

Remark loadind_label:
  forall base ofs ty dst k c,
  loadind base ofs ty dst k = OK c ->
  tail_nolabel k c.
Proof.
  unfold loadind; intros. destruct ty; try discriminate; destruct (preg_of dst); TailNoLabel.
Qed.

Remark storeind_label:
  forall base ofs ty src k c,
  storeind src base ofs ty k = OK c ->
  tail_nolabel k c.
Proof.
  unfold storeind; intros. destruct ty; try discriminate; destruct (preg_of src); TailNoLabel.
Qed.

Remark mk_setcc_base_label:
  forall xc rd k,
  tail_nolabel k (mk_setcc_base xc rd k).
Proof.
  intros. destruct xc; simpl; destruct (ireg_eq rd RAX); TailNoLabel.
Qed.

Remark mk_setcc_label:
  forall xc rd k,
  tail_nolabel k (mk_setcc xc rd k).
Proof.
  intros. unfold mk_setcc. destruct (Archi.ptr64 || low_ireg rd).
  apply mk_setcc_base_label.
  eapply tail_nolabel_trans. apply mk_setcc_base_label. TailNoLabel.
Qed.

Remark mk_jcc_label:
  forall xc lbl' k,
  tail_nolabel k (mk_jcc xc lbl' k).
Proof.
  intros. destruct xc; simpl; TailNoLabel.
Qed.

Remark transl_cond_label:
  forall cond args k c,
  transl_cond cond args k = OK c ->
  tail_nolabel k c.
Proof.
  unfold transl_cond; intros.
  destruct cond; TailNoLabel.
  destruct (Int.eq_dec n Int.zero); TailNoLabel.
  destruct (Int64.eq_dec n Int64.zero); TailNoLabel.
  destruct c0; simpl; TailNoLabel.
  destruct c0; simpl; TailNoLabel.
  destruct c0; simpl; TailNoLabel.
  destruct c0; simpl; TailNoLabel.
Qed.

Remark transl_op_label:
  forall op args r k c,
  transl_op op args r k = OK c ->
  tail_nolabel k c.
Proof.
  unfold transl_op; intros. destruct op; TailNoLabel.
  destruct (Int.eq_dec n Int.zero); TailNoLabel.
  destruct (Int64.eq_dec n Int64.zero); TailNoLabel.
  destruct (Float.eq_dec n Float.zero); TailNoLabel.
  destruct (Float32.eq_dec n Float32.zero); TailNoLabel.
  destruct (normalize_addrmode_64 x) as [am' [delta|]]; TailNoLabel.
  eapply tail_nolabel_trans. eapply transl_cond_label; eauto. eapply mk_setcc_label.
Qed.

Remark transl_load_label:
  forall chunk addr args dest k c,
  transl_load chunk addr args dest k = OK c ->
  tail_nolabel k c.
Proof.
  intros. monadInv H. destruct chunk; TailNoLabel.
Qed.

Remark transl_store_label:
  forall chunk addr args src k c,
  transl_store chunk addr args src k = OK c ->
  tail_nolabel k c.
Proof.
  intros. monadInv H. destruct chunk; TailNoLabel.
Qed.

Lemma transl_instr_label:
  forall f i ep k c,
  transl_instr f i ep k = OK c ->
  match i with Mlabel lbl => c = Plabel lbl :: k | _ => tail_nolabel k c end.
Proof.
Opaque loadind.
  unfold transl_instr; intros; destruct i; TailNoLabel.
  eapply loadind_label; eauto.
  eapply storeind_label; eauto.
  eapply loadind_label; eauto.
  eapply tail_nolabel_trans; eapply loadind_label; eauto.
  eapply transl_op_label; eauto.
  eapply transl_load_label; eauto.
  eapply transl_store_label; eauto.
  destruct s0; TailNoLabel.
  destruct s0; TailNoLabel.
  eapply tail_nolabel_trans. eapply transl_cond_label; eauto. eapply mk_jcc_label.
Qed.

Lemma transl_instr_label':
  forall lbl f i ep k c,
  transl_instr f i ep k = OK c ->
  find_label lbl c = if Mach.is_label lbl i then Some k else find_label lbl k.
Proof.
  intros. exploit transl_instr_label; eauto.
  destruct i; try (intros [A B]; apply B).
  intros. subst c. simpl. auto.
Qed.

Lemma transl_code_label:
  forall lbl f c ep tc,
  transl_code f c ep = OK tc ->
  match Mach.find_label lbl c with
  | None => find_label lbl tc = None
  | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_code f c' false = OK tc'
  end.
Proof.
  induction c; simpl; intros.
  inv H. auto.
  monadInv H. rewrite (transl_instr_label' lbl _ _ _ _ _ EQ0).
  generalize (Mach.is_label_correct lbl a).
  destruct (Mach.is_label lbl a); intros.
  subst a. simpl in EQ. exists x; auto.
  eapply IHc; eauto.
Qed.

Lemma transl_find_label:
  forall lbl f tf,
  transf_function f = OK tf ->
  match Mach.find_label lbl f.(Mach.fn_code) with
  | None => find_label lbl tf.(fn_code) = None
  | Some c => exists tc, find_label lbl tf.(fn_code) = Some tc /\ transl_code f c false = OK tc
  end.
Proof.
  intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x))); inv EQ0.
  monadInv EQ. simpl. eapply transl_code_label; eauto. rewrite transl_code'_transl_code in EQ0; eauto.
Qed.

End TRANSL_LABEL.

(** A valid branch in a piece of Mach code translates to a valid ``go to''
  transition in the generated PPC code. *)

Lemma find_label_goto_label:
  forall f tf lbl rs m c' b ofs,
  Genv.find_funct_ptr ge b = Some (Internal f) ->
  transf_function f = OK tf ->
  rs PC = Vptr b ofs ->
  Mach.find_label lbl f.(Mach.fn_code) = Some c' ->
  exists tc', exists rs',
    goto_label tge tf lbl rs m = Next rs' m
  /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc'
  /\ forall r, r <> PC -> rs'#r = rs#r.
Proof.
  intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2.
  intros [tc [A B]].
  exploit label_pos_code_tail; eauto. instantiate (1 := 0).
  intros [pos' [P [Q R]]].
  exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))).
  split. unfold goto_label. rewrite P. rewrite H1. erewrite functions_transl; eauto.
  split. rewrite Pregmap.gss. constructor; auto.
  rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q.
  auto. omega.
  generalize (transf_function_no_overflow _ _ H0). omega.
  intros. apply Pregmap.gso; auto.
Qed.

(** Existence of return addresses *)

Lemma return_address_exists:
  forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) ->
  exists ra, return_address_offset f c ra.
Proof.
  intros. eapply Asmgenproof0.return_address_exists; eauto.
- intros. exploit transl_instr_label; eauto.
  destruct i; try (intros [A B]; apply A). intros. subst c0. repeat constructor.
- intros. monadInv H0.
  destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x))); inv EQ0.
  monadInv EQ. rewrite transl_code'_transl_code in EQ0.
  exists x; exists true; split; auto. unfold fn_code. repeat constructor.
- exact transf_function_no_overflow.
Qed.

(** * Proof of semantic preservation *)

(** Semantic preservation is proved using simulation diagrams
  of the following form.
<<
           st1 --------------- st2
            |                   |
           t|                  *|t
            |                   |
            v                   v
           st1'--------------- st2'
>>
  The invariant is the [match_states] predicate below, which includes:
- The PPC code pointed by the PC register is the translation of
  the current Mach code sequence.
- Mach register values and PPC register values agree.
*)

Section WITHINITSPRA.

Variables init_sp init_ra: val.

Inductive match_states: Mach.state -> Asm.state -> Prop :=
  | match_states_intro:
      forall s fb sp c ep ms m m' rs f tf tc
        (STACKS: match_stack ge s)
        (FIND: Genv.find_funct_ptr ge fb = Some (Internal f))
        (MEXT: Mem.extends m m')
        (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc)
        (AG: agree ms sp rs)
        (AXP: ep = true -> rs#RAX = parent_sp init_sp s),
      match_states (Mach.State s fb sp c ms m)
                   (Asm.State rs m')
  | match_states_call:
      forall s fb ms m m' rs
        (STACKS: match_stack ge s)
        (MEXT: Mem.extends m m')
        (AG: agree ms (parent_sp init_sp s) rs)
        (ATPC: rs PC = Vptr fb Ptrofs.zero)
        (ATLR: rs RA = parent_ra init_ra s),
      match_states (Mach.Callstate s fb ms m)
                   (Asm.State rs m')
  | match_states_return:
      forall s ms m m' rs
        (STACKS: match_stack ge s)
        (MEXT: Mem.extends m m')
        (AG: agree ms (parent_sp init_sp s) rs)
        (RA_VUNDEF: rs RA = Vundef)
        (ATPC: rs PC = parent_ra init_ra s),
      match_states (Mach.Returnstate s ms m)
                   (Asm.State rs m').

Lemma exec_straight_steps:
  forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2,
  match_stack ge s ->
  Mem.extends m2 m2' ->
  Genv.find_funct_ptr ge fb = Some (Internal f) ->
  transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc ->
  (forall k c (TR: transl_instr f i ep k = OK c),
   exists rs2,
       exec_straight tge tf c rs1 m1' k rs2 m2'
    /\ agree ms2 sp rs2
    /\ (it1_is_parent ep i = true -> rs2#RAX = parent_sp init_sp s)) ->
  exists st',
  plus step tge (State rs1 m1') E0 st' /\
  match_states (Mach.State s fb sp c ms2 m2) st'.
Proof.
  intros. inversion H2. subst. monadInv H7.
  exploit H3; eauto. intros [rs2 [A [B C]]].
  exists (State rs2 m2'); split.
  eapply exec_straight_exec; eauto.
  econstructor; eauto. eapply exec_straight_at; eauto.
Qed.

Lemma exec_straight_steps_goto:
  forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c',
  match_stack ge s ->
  Mem.extends m2 m2' ->
  Genv.find_funct_ptr ge fb = Some (Internal f) ->
  Mach.find_label lbl f.(Mach.fn_code) = Some c' ->
  transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc ->
  it1_is_parent ep i = false ->
  (forall k c (TR: transl_instr f i ep k = OK c),
   exists jmp, exists k', exists rs2,
       exec_straight tge tf c rs1 m1' (jmp :: k') rs2 m2'
    /\ agree ms2 sp rs2
    /\ exec_instr tge tf jmp rs2 m2' = goto_label tge tf lbl rs2 m2') ->
  exists st',
  plus step tge (State rs1 m1') E0 st' /\
  match_states (Mach.State s fb sp c' ms2 m2) st'.
Proof.
  intros. inversion H3. subst. monadInv H9.
  exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]].
  generalize (functions_transl _ _ _ H7 H8); intro FN.
  generalize (transf_function_no_overflow _ _ H8); intro NOOV.
  exploit exec_straight_steps_2; eauto.
  intros [ofs' [PC2 CT2]].
  exploit find_label_goto_label; eauto.
  intros [tc' [rs3 [GOTO [AT' OTH]]]].
  exists (State rs3 m2'); split.
  eapply plus_right'.
  eapply exec_straight_steps_1; eauto.
  econstructor; eauto.
  eapply find_instr_tail. eauto.
  rewrite C. eexact GOTO.
  traceEq.
  econstructor; eauto.
  apply agree_exten with rs2; auto with asmgen.
  congruence.
Qed.

(** We need to show that, in the simulation diagram, we cannot
  take infinitely many Mach transitions that correspond to zero
  transitions on the PPC side.  Actually, all Mach transitions
  correspond to at least one Asm transition, except the
  transition from [Mach.Returnstate] to [Mach.State].
  So, the following integer measure will suffice to rule out
  the unwanted behaviour. *)

Definition measure (s: Mach.state) : nat :=
  match s with
  | Mach.State _ _ _ _ _ _ => 0%nat
  | Mach.Callstate _ _ _ _ => 0%nat
  | Mach.Returnstate _ _ _ => 1%nat
  end.

(** This is the simulation diagram.  We prove it by case analysis on the Mach transition. *)

Hypothesis init_sp_not_vundef: init_sp <> Vundef.
Hypothesis init_ra_not_vundef: init_ra <> Vundef.

Hypothesis init_sp_type: Val.has_type init_sp Tptr.
Hypothesis init_ra_type: Val.has_type init_ra Tptr.

Theorem step_simulation:
  forall S1 t S2, Mach.step init_sp init_ra return_address_offset ge S1 t S2 ->
  forall S1' (MS: match_states S1 S1'),
  (exists S2', plus step tge S1' t S2' /\ match_states S2 S2')
  \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat.
Proof.
  induction 1; intros; inv MS.

- (* Mlabel *)
  left; eapply exec_straight_steps; eauto; intros.
  monadInv TR. econstructor; split. apply exec_straight_one. simpl; eauto. auto.
  split. apply agree_nextinstr; auto. simpl; congruence.

- (* Mgetstack *)
  unfold load_stack in H.
  exploit Mem.loadv_extends; eauto. intros [v' [A B]].
  rewrite (sp_val _ _ _ AG) in A.
  left; eapply exec_straight_steps; eauto. intros. simpl in TR.
  exploit loadind_correct; eauto. intros [rs' [P [Q R]]].
  exists rs'; split. eauto.
  split. eapply agree_set_mreg; eauto. congruence.
  simpl; congruence.

- (* Msetstack *)
  unfold store_stack in H.
  assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto.
  exploit Mem.storev_extends; eauto. intros [m2' [A B]].
  left; eapply exec_straight_steps; eauto.
  rewrite (sp_val _ _ _ AG) in A. intros. simpl in TR.
  exploit storeind_correct; eauto. intros [rs' [P Q]].
  exists rs'; split. eauto.
  split. eapply agree_undef_regs; eauto.
  simpl; intros. rewrite Q; auto with asmgen.
Local Transparent destroyed_by_setstack.
  destruct ty; simpl; intuition congruence.

- (* Mgetparam *)
  assert (f0 = f) by congruence; subst f0.
  unfold load_stack in *.
  exploit Mem.loadv_extends. eauto. eexact H0. auto.
  intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A.
  exploit (lessdef_parent_sp init_sp); eauto. clear B; intros B; subst parent'.
  exploit Mem.loadv_extends. eauto. eexact H1. auto.
  intros [v' [C D]].
Opaque loadind.
  left; eapply exec_straight_steps; eauto; intros.
  assert (DIFF: negb (mreg_eq dst AX) = true -> IR RAX <> preg_of dst).
    intros. change (IR RAX) with (preg_of AX). red; intros.
    unfold proj_sumbool in H1. destruct (mreg_eq dst AX); try discriminate.
    elim n. eapply preg_of_injective; eauto.
  destruct ep; simpl in TR.
(* RAX contains parent *)
  exploit loadind_correct. eexact TR.
  instantiate (2 := rs0). rewrite AXP; eauto.
  intros [rs1 [P [Q R]]].
  exists rs1; split. eauto.
  split. eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto.
  simpl; intros. rewrite R; auto.
(* RAX does not contain parent *)
  monadInv TR.
  exploit loadind_correct. eexact EQ0. eauto. intros [rs1 [P [Q R]]]. simpl in Q.
  exploit loadind_correct. eexact EQ. instantiate (2 := rs1). rewrite Q. eauto.
  intros [rs2 [S [T U]]].
  exists rs2; split. eapply exec_straight_trans; eauto.
  split. eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto.
  simpl; intros. rewrite U; auto.

- (* Mop *)
  assert (eval_operation tge sp op rs##args m = Some v).
    rewrite <- H. apply eval_operation_preserved. exact symbols_preserved.
  exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eexact H0.
  intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A.
  left; eapply exec_straight_steps; eauto; intros. simpl in TR.
  exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]].
  assert (S: Val.lessdef v (rs2 (preg_of res))) by (eapply Val.lessdef_trans; eauto).
  exists rs2; split. eauto.
  split. eapply agree_set_undef_mreg; eauto.
  simpl; congruence.

- (* Mload *)
  assert (eval_addressing tge sp addr rs##args = Some a).
    rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
  exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.
  intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.
  exploit Mem.loadv_extends; eauto. intros [v' [C D]].
  left; eapply exec_straight_steps; eauto; intros. simpl in TR.
  exploit transl_load_correct; eauto. intros [rs2 [P [Q R]]].
  exists rs2; split. eauto.
  split. eapply agree_set_undef_mreg; eauto. congruence.
  simpl; congruence.

- (* Mstore *)
  assert (eval_addressing tge sp addr rs##args = Some a).
    rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
  exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.
  intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.
  assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto.
  exploit Mem.storev_extends; eauto. intros [m2' [C D]].
  left; eapply exec_straight_steps; eauto.
  intros. simpl in TR.
  exploit transl_store_correct; eauto. intros [rs2 [P Q]].
  exists rs2; split. eauto.
  split. eapply agree_undef_regs; eauto.
  simpl; congruence.

- (* Mcall *)
  assert (f0 = f) by congruence.  subst f0.
  inv AT.
  assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned).
    eapply transf_function_no_overflow; eauto.
  destruct ros as [rf|fid]; simpl in H; monadInv H5.
+ (* Indirect call *)
  assert (rs rf = Vptr f' Ptrofs.zero).
    destruct (rs rf); try discriminate.
    revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence.
  assert (rs0 x0 = Vptr f' Ptrofs.zero).
    exploit ireg_val; eauto. rewrite H5; intros LD; inv LD; auto.
  generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1.
  assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x).
    econstructor; eauto.
  exploit return_address_offset_correct; eauto. intros; subst ra.
  left; econstructor; split.
  apply plus_one. eapply exec_step_internal. eauto.
  eapply functions_transl; eauto. eapply find_instr_tail; eauto.
  simpl. eauto.
  econstructor; eauto.
  econstructor; eauto.
  eapply agree_sp_def; eauto.
  eapply agree_sp_type; eauto.
  simpl. eapply agree_exten; eauto. intros. Simplifs.
  Simplifs. rewrite <- H2. auto.
+ (* Direct call *)
  generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1.
  assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x).
    econstructor; eauto.
  exploit return_address_offset_correct; eauto. intros; subst ra.
  left; econstructor; split.
  apply plus_one. eapply exec_step_internal. eauto.
  eapply functions_transl; eauto. eapply find_instr_tail; eauto.
  simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. eauto.
  econstructor; eauto.
  econstructor; eauto.
  eapply agree_sp_def; eauto.
  eapply agree_sp_type; eauto.
  simpl. eapply agree_exten; eauto. intros. Simplifs.
  Simplifs. rewrite <- H2. auto.

- (* Mtailcall *)
  assert (f0 = f) by congruence.  subst f0.
  inv AT.
  assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned).
    eapply transf_function_no_overflow; eauto.
  rewrite (sp_val _ _ _ AG) in *. unfold load_stack in *.
  exploit Mem.loadv_extends. eauto. eexact H1. auto. simpl. intros [parent' [A B]].
  exploit Mem.loadv_extends. eauto. eexact H2. auto. simpl. intros [ra' [C D]].
  exploit (lessdef_parent_sp init_sp); eauto. intros. subst parent'. clear B.
  exploit (lessdef_parent_ra init_ra); eauto. intros. subst ra'. clear D.
  exploit Mem.free_parallel_extends; eauto. intros [m2' [E F]].
  destruct ros as [rf|fid]; simpl in H; monadInv H7.
+ (* Indirect call *)
  assert (rs rf = Vptr f' Ptrofs.zero).
    destruct (rs rf); try discriminate.
    revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence.
  assert (rs0 x0 = Vptr f' Ptrofs.zero).
    exploit ireg_val; eauto. rewrite H7; intros LD; inv LD; auto.
  generalize (code_tail_next_int _ _ _ _ NOOV H8). intro CT1.
  left; econstructor; split.
  eapply plus_left. eapply exec_step_internal. eauto.
  eapply functions_transl; eauto. eapply find_instr_tail; eauto.
  simpl. replace (chunk_of_type Tptr) with Mptr in * by (unfold Tptr, Mptr; destruct Archi.ptr64; auto).
  rewrite C. rewrite A. rewrite <- (sp_val _ _ _ AG). rewrite E. eauto.
  apply star_one. eapply exec_step_internal.
  transitivity (Val.offset_ptr rs0#PC Ptrofs.one). auto. rewrite <- H4. simpl. eauto.
  eapply functions_transl; eauto. eapply find_instr_tail; eauto.
  simpl. eauto. traceEq.
  econstructor; eauto.
  apply agree_set_other; auto. apply agree_nextinstr. apply agree_set_other; auto.
  eapply agree_change_sp; eauto. eapply parent_sp_def; eauto.
  eapply parent_sp_type; eauto.
  Simplifs. rewrite Pregmap.gso; auto.
  generalize (preg_of_not_SP rf). rewrite (ireg_of_eq _ _ EQ1). congruence.
+ (* Direct call *)
  generalize (code_tail_next_int _ _ _ _ NOOV H8). intro CT1.
  left; econstructor; split.
  eapply plus_left. eapply exec_step_internal. eauto.
  eapply functions_transl; eauto. eapply find_instr_tail; eauto.
  simpl. replace (chunk_of_type Tptr) with Mptr in * by (unfold Tptr, Mptr; destruct Archi.ptr64; auto).
  rewrite C. rewrite A. rewrite <- (sp_val _ _ _ AG). rewrite E. eauto.
  apply star_one. eapply exec_step_internal.
  transitivity (Val.offset_ptr rs0#PC Ptrofs.one). auto. rewrite <- H4. simpl. eauto.
  eapply functions_transl; eauto. eapply find_instr_tail; eauto.
  simpl. eauto. traceEq.
  econstructor; eauto.
  apply agree_set_other; auto. apply agree_nextinstr. apply agree_set_other; auto.
  eapply agree_change_sp; eauto. eapply parent_sp_def; eauto.
  eapply parent_sp_type; eauto.
  rewrite Pregmap.gss. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. auto.

- (* Mbuiltin *)
  inv AT. monadInv H4.
  exploit functions_transl; eauto. intro FN.
  generalize (transf_function_no_overflow _ _ H3); intro NOOV.
  exploit builtin_args_match; eauto. intros [vargs' [P Q]].
  exploit external_call_mem_extends; eauto.
  intros [vres' [m2' [A [B [C D]]]]].
  left. econstructor; split. apply plus_one.
  eapply exec_step_builtin. eauto. eauto.
  eapply find_instr_tail; eauto.
  erewrite <- sp_val by eauto.
  eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved.
  eapply external_call_symbols_preserved; eauto. apply senv_preserved. auto.
  eauto.
  econstructor; eauto.
  instantiate (2 := tf); instantiate (1 := x).
  unfold nextinstr_nf, nextinstr. rewrite Pregmap.gss.
  rewrite undef_regs_other. rewrite set_res_other. rewrite undef_regs_other_2.
  rewrite <- H1. simpl. econstructor; eauto.
  eapply code_tail_next_int; eauto.
  rewrite preg_notin_charact. intros. auto with asmgen.
  auto with asmgen.
  simpl; intros. intuition congruence.
  apply agree_nextinstr_nf. eapply agree_set_res; auto.
  eapply agree_undef_regs; eauto. intros; apply undef_regs_other_2; auto.
  congruence.

- (* Mgoto *)
  assert (f0 = f) by congruence. subst f0.
  inv AT. monadInv H4.
  exploit find_label_goto_label; eauto. intros [tc' [rs' [GOTO [AT2 INV]]]].
  left; exists (State rs' m'); split.
  apply plus_one. econstructor; eauto.
  eapply functions_transl; eauto.
  eapply find_instr_tail; eauto.
  simpl; eauto.
  econstructor; eauto.
  eapply agree_exten; eauto with asmgen.
  congruence.

- (* Mcond true *)
  assert (f0 = f) by congruence. subst f0.
  exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC.
  left; eapply exec_straight_steps_goto; eauto.
  intros. simpl in TR.
  destruct (transl_cond_correct tge tf cond args _ _ rs0 m' TR)
  as [rs' [A [B C]]].
  rewrite EC in B.
  destruct (testcond_for_condition cond); simpl in *.
(* simple jcc *)
  exists (Pjcc c1 lbl); exists k; exists rs'.
  split. eexact A.
  split. eapply agree_exten; eauto.
  simpl. rewrite B. auto.
(* jcc; jcc *)
  destruct (eval_testcond c1 rs') as [b1|] eqn:TC1;
  destruct (eval_testcond c2 rs') as [b2|] eqn:TC2; inv B.
  destruct b1.
  (* first jcc jumps *)
  exists (Pjcc c1 lbl); exists (Pjcc c2 lbl :: k); exists rs'.
  split. eexact A.
  split. eapply agree_exten; eauto.
  simpl. rewrite TC1. auto.
  (* second jcc jumps *)
  exists (Pjcc c2 lbl); exists k; exists (nextinstr rs').
  split. eapply exec_straight_trans. eexact A.
  eapply exec_straight_one. simpl. rewrite TC1. auto. auto.
  split. eapply agree_exten; eauto.
  intros; Simplifs.
  simpl. rewrite eval_testcond_nextinstr. rewrite TC2.
  destruct b2; auto || discriminate.
(* jcc2 *)
  destruct (eval_testcond c1 rs') as [b1|] eqn:TC1;
  destruct (eval_testcond c2 rs') as [b2|] eqn:TC2; inv B.
  destruct (andb_prop _ _ H3). subst.
  exists (Pjcc2 c1 c2 lbl); exists k; exists rs'.
  split. eexact A.
  split. eapply agree_exten; eauto.
  simpl. rewrite TC1; rewrite TC2; auto.

- (* Mcond false *)
  exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC.
  left; eapply exec_straight_steps; eauto. intros. simpl in TR.
  destruct (transl_cond_correct tge tf cond args _ _ rs0 m' TR)
  as [rs' [A [B C]]].
  rewrite EC in B.
  destruct (testcond_for_condition cond); simpl in *.
(* simple jcc *)
  econstructor; split.
  eapply exec_straight_trans. eexact A.
  apply exec_straight_one. simpl. rewrite B. eauto. auto.
  split. apply agree_nextinstr. eapply agree_exten; eauto.
  simpl; congruence.
(* jcc ; jcc *)
  destruct (eval_testcond c1 rs') as [b1|] eqn:TC1;
  destruct (eval_testcond c2 rs') as [b2|] eqn:TC2; inv B.
  destruct (orb_false_elim _ _ H1); subst.
  econstructor; split.
  eapply exec_straight_trans. eexact A.
  eapply exec_straight_two. simpl. rewrite TC1. eauto. auto.
  simpl. rewrite eval_testcond_nextinstr. rewrite TC2. eauto. auto. auto.
  split. apply agree_nextinstr. apply agree_nextinstr. eapply agree_exten; eauto.
  simpl; congruence.
(* jcc2 *)
  destruct (eval_testcond c1 rs') as [b1|] eqn:TC1;
  destruct (eval_testcond c2 rs') as [b2|] eqn:TC2; inv B.
  exists (nextinstr rs'); split.
  eapply exec_straight_trans. eexact A.
  apply exec_straight_one. simpl.
  rewrite TC1; rewrite TC2.
  destruct b1. simpl in *. subst b2. auto. auto.
  auto.
  split. apply agree_nextinstr. eapply agree_exten; eauto.
  rewrite H1; congruence.

- (* Mjumptable *)
  assert (f0 = f) by congruence. subst f0.
  inv AT. monadInv H6.
  exploit functions_transl; eauto. intro FN.
  generalize (transf_function_no_overflow _ _ H5); intro NOOV.
  set (rs1 := rs0 #RAX <- Vundef #RDX <- Vundef).
  exploit (find_label_goto_label f tf lbl rs1); eauto.
  intros [tc' [rs' [A [B C]]]].
  exploit ireg_val; eauto. rewrite H. intros LD; inv LD.
  left; econstructor; split.
  apply plus_one. econstructor; eauto.
  eapply find_instr_tail; eauto.
  simpl. rewrite <- H9.  unfold Mach.label in H0; unfold label; rewrite H0. eexact A.
  econstructor; eauto.
Transparent destroyed_by_jumptable.
  apply agree_undef_regs with rs0; auto.
  simpl; intros. destruct H8. rewrite C by auto with asmgen. unfold rs1; Simplifs.
  congruence.

- (* Mreturn *)
  assert (f0 = f) by congruence. subst f0.
  inv AT.
  assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned).
    eapply transf_function_no_overflow; eauto.
  rewrite (sp_val _ _ _ AG) in *. unfold load_stack in *.
  replace (chunk_of_type Tptr) with Mptr in * by (unfold Tptr, Mptr; destruct Archi.ptr64; auto).
  exploit Mem.loadv_extends. eauto. eexact H0. auto. simpl. intros [parent' [A B]].
  exploit (lessdef_parent_sp init_sp); eauto. intros. subst parent'. clear B.
  exploit Mem.loadv_extends. eauto. eexact H1. auto. simpl. intros [ra' [C D]].
  exploit (lessdef_parent_ra init_ra); eauto. intros. subst ra'. clear D.
  exploit Mem.free_parallel_extends; eauto. intros [m2' [E F]].
  monadInv H6.
  exploit code_tail_next_int; eauto. intro CT1.
  left; econstructor; split.
  eapply plus_left. eapply exec_step_internal. eauto.
  eapply functions_transl; eauto. eapply find_instr_tail; eauto.
  simpl. rewrite C. rewrite A. rewrite <- (sp_val _ _ _ AG). rewrite E. eauto.
  apply star_one. eapply exec_step_internal.
  transitivity (Val.offset_ptr rs0#PC Ptrofs.one). auto. rewrite <- H3. simpl. eauto.
  eapply functions_transl; eauto. eapply find_instr_tail; eauto.
  simpl. eauto. traceEq.
  constructor; auto.
  apply agree_set_other; auto.
  apply agree_set_other; auto. apply agree_nextinstr. apply agree_set_other; auto.
  eapply agree_change_sp; eauto. eapply parent_sp_def; eauto.
  eapply parent_sp_type; eauto.

- (* internal function *)
  exploit functions_translated; eauto. intros [tf [A B]]. monadInv B.
  generalize EQ; intros EQ'. monadInv EQ'.
  destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x0))); inv EQ1.
  monadInv EQ0. rewrite transl_code'_transl_code in EQ1.
  unfold store_stack in *.
  exploit Mem.alloc_extends. eauto. eauto. apply Zle_refl. apply Zle_refl.
  intros [m1' [C D]].
  exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto.
  intros [m2' [F G]].
  exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto.
  intros [m3' [P Q]].
  left; econstructor; split.
  apply plus_one. econstructor; eauto.
  simpl. rewrite Ptrofs.unsigned_zero. simpl. eauto.
  simpl. rewrite C. simpl in F, P.
  replace (chunk_of_type Tptr) with Mptr in F, P by (unfold Tptr, Mptr; destruct Archi.ptr64; auto).
  rewrite (sp_val _ _ _ AG) in F. rewrite F.
  rewrite ATLR. rewrite P. eauto.
  econstructor; eauto.
  unfold nextinstr. rewrite Pregmap.gss. repeat rewrite Pregmap.gso; auto with asmgen.
  rewrite ATPC. simpl. constructor; eauto.
  unfold fn_code. eapply code_tail_next_int. simpl in g. omega.
  constructor.
  apply agree_nextinstr. eapply agree_change_sp; eauto.
Transparent destroyed_at_function_entry.
  apply agree_undef_regs with rs0; eauto.
  simpl; intros. apply Pregmap.gso; auto with asmgen. tauto.
  congruence.
  constructor.
  intros. Simplifs. eapply agree_sp; eauto.

- (* external function *)
  exploit functions_translated; eauto.
  intros [tf [A B]]. simpl in B. inv B.
  exploit extcall_arguments_match; eauto.
  intros [args' [C D]].
  exploit external_call_mem_extends; eauto.
  intros [res' [m2' [P [Q [R S]]]]].
  left; econstructor; split.
  apply plus_one. eapply exec_step_external; eauto.
  {
    destruct STACK as (m_ & FEA & t_ & res'_ & m'_ & EC).
    inv AG.
    exploit EraseArgs.free_extcall_args_parallel_extends.
    eapply Val.lessdef_refl.
    eassumption. eauto.
    intros (m'_0 & FEA' & EXT).
    esplit. rewrite agree_sp. split; eauto.
    exploit external_call_mem_extends. eexact EC. eauto. eauto.
    intros (vres' & m2'0 & EC' & LDres & EXT' & UNCH).
    repeat eexists.
    eapply external_call_symbols_preserved; eauto.
    exact senv_preserved.
  }
  { (* rs SP Tint *)
    erewrite agree_sp by eauto.
    eapply parent_sp_type; eauto.
  }
  { (* rs RA Tint *)
    rewrite ATLR.
    eapply parent_ra_type; eauto.
  }
  { (* rs SP not Vundef *)
    erewrite agree_sp by eauto.
    eapply parent_sp_def; eauto.
  }
  { (* rs RA not Vundef *)
    rewrite ATLR.
    eapply parent_ra_def; eauto.
  }
  eapply external_call_symbols_preserved; eauto. apply senv_preserved. auto.
  econstructor; eauto.
  unfold loc_external_result.
  apply agree_set_other; auto.
  apply agree_set_other; auto. apply agree_set_pair; auto.

- (* return *)
  inv STACKS. simpl in *.
  right. split. omega. split. auto.
  econstructor; eauto. rewrite ATPC; eauto. congruence.
Qed.

End WITHINITSPRA.

Lemma transf_initial_states:
  forall st1, Mach.initial_state prog st1 ->
  exists st2, Asm.initial_state tprog st2 /\ match_states Vnullptr Vnullptr st1 st2.
Proof.
  intros. inversion H. unfold ge0 in *.
  econstructor; split.
  econstructor.
  eapply (Genv.init_mem_transf_partial TRANSF); eauto.
  replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero)
     with (Vptr fb Ptrofs.zero).
  econstructor; eauto.
  constructor.
  apply Mem.extends_refl.
  split. reflexivity. simpl.
  unfold Vnullptr; destruct Archi.ptr64; congruence.
  eapply parent_sp_type. apply Val.Vnullptr_has_type. constructor.
  intros. rewrite Regmap.gi. auto.
  unfold Genv.symbol_address.
  rewrite (match_program_main TRANSF).
  rewrite symbols_preserved.
  unfold ge; rewrite H1. auto.
  Unshelve. eauto.
Qed.

Lemma transf_final_states:
  forall st1 st2 r,
  match_states Vnullptr Vnullptr st1 st2 -> Mach.final_state st1 r -> Asm.final_state st2 r.
Proof.
  intros. inv H0. inv H. constructor. auto.
  assert (r0 = AX).
  { unfold loc_result in H1; destruct Archi.ptr64; compute in H1; congruence. }
  subst r0.
  generalize (preg_val _ _ _ AX AG). rewrite H2. intros LD; inv LD. auto.
Qed.

Theorem transf_program_correct:
  forward_simulation (Mach.semantics return_address_offset prog) (Asm.semantics tprog).
Proof.
  eapply forward_simulation_star with (measure := measure).
  apply senv_preserved.
  eexact transf_initial_states.
  eexact transf_final_states.
  intros. apply step_simulation; auto.
  unfold Vnullptr; destruct Archi.ptr64; congruence.
  unfold Vnullptr; destruct Archi.ptr64; congruence.
  apply Val.Vnullptr_has_type.
  apply Val.Vnullptr_has_type.
Qed.

End PRESERVATION.