Require Export P05.
(*
Lemma replace_cequiv: forall (c1 c2:com),
  cequiv c1 (constfold_0plus c1) -> cequiv c2 (constfold_0plus c2) ->
  cequiv ((constfold_0plus c1);; (constfold_0plus c2))
    (constfold_0plus (c1;; c2)).
Proof.
  intros.
  unfold constfold_0plus. simpl.
  destruct c1.
  Case "c1=SKIP".
    simpl.
    assert (H1: cequiv (SKIP;; (constfold_0plus c2)) (SKIP;; c2)).
    apply CSeq_congruence. apply refl_cequiv. apply sym_cequiv. assumption.
    assert (H2: cequiv (SKIP;; c2) (optimize_0plus_com c2)).
    assert (H3: cequiv (SKIP;;c2) c2).
    unfold cequiv. split. apply skip_left. apply skip_left.
    apply trans_cequiv with (c2:=c2). assumption. apply optimize_0plus_com_sound.
    unfold constfold_0plus in H1. apply trans_cequiv with (c2:=(SKIP;; c2)). assumption. assumption.
  Case "c1 = ::=".
    destruct c2.
    SCase "c2 = SKIP".
      assert (H1: cequiv ((i ::= a);;SKIP) ((constfold_0plus (i ::= a));; (constfold_0plus SKIP))).
        apply CSeq_congruence. assumption. assumption.
      assert (H2: cequiv ((i ::= a);;SKIP) (i ::= a)).
        apply skip_right.
      apply sym_cequiv in H1.
      apply trans_cequiv with (c2:=((i ::= a);; SKIP)).
      unfold constfold_0plus in H1. assumption.
      assert (H3: cequiv (i ::= a) (optimize_0plus_com (i ::= a))).
        apply optimize_0plus_com_sound.
      apply trans_cequiv with (c2:=(i ::= a)).
      assumption. assumption.
    SCase "c2 = ::=".
      simpl. apply refl_cequiv.
    SCase "c2 = ;;".
      simpl. destruct c2_1;
        apply refl_cequiv;
        destruct c2_2; apply refl_cequiv.
          apply refl_cequiv.
          apply refl_cequiv.
  Case "c1 = ;;".
    destruct c2.
    SCase "c2 = SKIP".
      simpl. destruct c1_1.
      SSCase "c1_1 = SKIP".
        assert (H1: cequiv (optimize_0plus_com c1_2;; SKIP) (optimize_0plus_com c1_2)).
          apply skip_right.
        assert (H2: cequiv (optimize_0plus_com c1_2) (optimize_0plus_com SKIP;; optimize_0plus_com c1_2)).
          assert (H3: cequiv (optimize_0plus_com SKIP;; optimize_0plus_com c1_2)
            (SKIP;; optimize_0plus_com c1_2)).
            apply CSeq_congruence. apply sym_cequiv in H0. assumption. apply refl_cequiv.
        assert (H4: cequiv (SKIP;; optimize_0plus_com c1_2) (optimize_0plus_com c1_2)).
          apply skip_left.
        apply sym_cequiv. apply trans_cequiv with (c2:= (SKIP;; optimize_0plus_com c1_2)).
        assumption. assumption.
        apply trans_cequiv with (c2:=(optimize_0plus_com c1_2)).
        assumption. assumption.
      SSCase "c1_1 = :=".
        destruct c1_2.
          simpl. apply refl_cequiv.
          simpl. apply CSeq_congruence.
*)

Lemma constfold_0plus_sound:
  ctrans_sound constfold_0plus.
Proof.
  unfold ctrans_sound. intros c.
  induction c.
  Case "SKIP".
    unfold constfold_0plus. simpl. apply refl_cequiv.
  Case "::=".
    apply CAss_congruence. unfold aequiv. intro st.
    induction a; try auto;
      simpl; destruct (fold_constants_aexp a1); destruct (fold_constants_aexp a2);
        try (rewrite IHa1; rewrite IHa2; auto); try destruct n; auto.
  Case ";;".
    destruct c1.
    SCase "c1 = SKIP".
      unfold constfold_0plus in IHc2.
      assert (H:cequiv c2 (fold_constants_com c2)).
      apply fold_constants_com_sound.
      assert (H1: cequiv (SKIP;;c2) c2).
      unfold cequiv. split. apply skip_left. apply skip_left.
      apply trans_cequiv with (c2:=c2). assumption. apply optimize_0plus_com_sound.
    SCase "c1 = ::=".
    destruct c2.
      SSCase "c2 = SKIP".
      assert (H1: cequiv ((i ::= a);;SKIP) ((constfold_0plus (i ::= a));; (constfold_0plus SKIP))).
        apply CSeq_congruence. assumption. assumption.
      assert (H2: cequiv ((i ::= a);;SKIP) (i ::= a)).
        apply skip_right.
      apply sym_cequiv in H1.
      apply trans_cequiv with (c2:=((i ::= a);; SKIP)).
      unfold constfold_0plus in H1. apply refl_cequiv.
      assert (H3: cequiv (i ::= a) (optimize_0plus_com (i ::= a))).
        apply optimize_0plus_com_sound.
      apply trans_cequiv with (c2:=(i ::= a)).
      assumption. assumption.
      SSCase "c2 = ::=".
        unfold constfold_0plus. simpl. unfold constfold_0plus in *.
        apply CSeq_congruence. assumption. assumption.
      SSCase "c2 = ;;".
        unfold constfold_0plus. simpl.
        destruct c2_1.
        SSSCase "c2_1 = SKIP".
          simpl.
          assert (H: cequiv (SKIP;; c2_2) (optimize_0plus_com c2_2)).
           assert (H1:  cequiv (SKIP;; c2_2) c2_2). apply skip_left.
           assert (H2: cequiv c2_2 (optimize_0plus_com c2_2)). apply optimize_0plus_com_sound.
           apply trans_cequiv with (c2:=c2_2). assumption. assumption.
          apply CSeq_congruence. unfold constfold_0plus in IHc1. assumption. assumption.
        SSSCase "c2_1 = ::=".
          destruct c2_2.
          SSSSCase "c2_2 = SKIP".
            assert (H: cequiv (i0 ::= a0;; SKIP) (i0 ::= a0)).
              apply skip_right.
            assert (H1: cequiv (i0 ::= a0) (optimize_0plus_com (i0 ::= a0))).
              apply optimize_0plus_com_sound.
            apply CSeq_congruence. unfold constfold_0plus in IHc1. assumption.
            apply trans_cequiv with (c2:=(i0 ::= a0)). assumption. assumption.
          SSSSCase "c2_2 = ::=". simpl. apply CSeq_congruence.
            unfold constfold_0plus in *. assumption. assumption.
          SSSSCase "c2_2 = ;;".

    assert (H: cequiv (c1;; c2) ((constfold_0plus c1);; (constfold_0plus c2))).
      apply CSeq_congruence. assumption. assumption.
    assert (H1: cequiv ((constfold_0plus c1);; (constfold_0plus c2)) (constfold_0plus (c1;; c2))).
     destruct c1. unfold constfold_0plus. simpl.
        SCase "SKIP".
          assert (H1: cequiv (SKIP;; (constfold_0plus c2)) (SKIP;; c2)).
            apply CSeq_congruence. apply refl_cequiv. apply sym_cequiv. assumption.
          assert (H2: cequiv (SKIP;; c2) (optimize_0plus_com c2)).
            assert (H3: cequiv (SKIP;;c2) c2).
              unfold cequiv. split. apply skip_left. apply skip_left.
            apply trans_cequiv with (c2:=c2). assumption. apply optimize_0plus_com_sound.
            unfold constfold_0plus in H1. apply trans_cequiv with (c2:=(SKIP;; c2)). assumption.
            assumption.
        SCase "::=".

        assert (H1: cequiv (SKIP;; optimize_0plus_com (fold_constants_com c2)) c2).

    destruct c1.
      assert (H1: cequiv (SKIP;;c2) c2).
      unfold cequiv. split. apply skip_left. apply skip_left.
      apply trans_cequiv with (c2:=c2). assumption. apply optimize_0plus_com_sound.
      SCase "::=".
        destruct c2.
          SSCase "c2=SKIP".
          assert (H:cequiv (i::=a) (optimize_0plus_com (i::=a))).
          apply optimize_0plus_com_sound.
          assert (H1: cequiv (i::=a;;SKIP) (i::=a)).
          unfold cequiv. split. apply skip_right. apply skip_right.
          apply trans_cequiv with (c2:=(i::=a)). assumption. assumption.
        SSCase "c2 = ::=".
          unfold constfold_0plus in IHc1. simpl in IHc1.
          unfold constfold_0plus in IHc2. simpl in IHc2. simpl.
          apply CSeq_congruence. assumption. assumption.
        simpl.
      apply optimize_0plus_com_sound.
      assert (H:cequiv c2 (fold_constants_com c2)).
      apply fold_constants_com_sound.
      assert (H1: cequiv (SKIP;;c2) c2).
      unfold cequiv. split. apply skip_left. apply skip_left.
      apply trans_cequiv with (c2:=c2). assumption. apply optimize_0plus_com_sound.
    assert (H: cequiv ((constfold_0plus c1);;(constfold_0plus c2)) (constfold_0plus (c1;; c2))).
    unfold constfold_0plus. simpl.
    induction c1.
    SCase "c1=SKIP". simpl.
      unfold constfold_0plus in IHc2.
      assert (H:cequiv c2 (fold_constants_com c2)).
      apply fold_constants_com_sound.
      assert (H1: cequiv (SKIP;;c2) c2).
      unfold cequiv. split. apply skip_left. apply skip_left.
      apply trans_cequiv with (c2:=c2). assumption. apply optimize_0plus_com_sound.
    assumption.

assert (H: cequiv ((constfold_0plus c1);;(constfold_0plus c2)) (constfold_0plus (c1;; c2))).

    split.
      SCase "->".
        intros. inversion H. subst. unfold constfold_0plus.
        destruct c1. simpl. unfold constfold_0plus in H5. simpl in H5. simpl.
    unfold constfold_0plus.
    destruct c1.
    SCase "c1=SKIP". simpl.
      unfold constfold_0plus in IHc2.
      assert (H:cequiv c2 (fold_constants_com c2)).
      apply fold_constants_com_sound.
      assert (H1: cequiv (SKIP;;c2) c2).
      unfold cequiv. split. apply skip_left. apply skip_left.
      apply trans_cequiv with (c2:=c2). assumption. assumption.
    SCase "c1 = ::=".
      simpl. destruct c2.
        SSCase "c2=SKIP".
          assert (H:cequiv (i::=a) (optimize_0plus_com (i::=a))).
          apply optimize_0plus_com_sound.
          assert (H1: cequiv (i::=a;;SKIP) (i::=a)).
          unfold cequiv. split. apply skip_right. apply skip_right.
          apply trans_cequiv with (c2:=(i::=a)). assumption. assumption.
        SSCase "c2 = ::=".
          unfold constfold_0plus in IHc1. simpl in IHc1.
          unfold constfold_0plus in IHc2. simpl in IHc2. simpl.
          apply CSeq_congruence. assumption. assumption.
        SSCase "c2 = ;;".
          destruct c2_1.
          SSSCase "c2_1 = SKIP".
            unfold constfold_0plus. simpl.
            unfold constfold_0plus in IHc1. simpl in IHc1.
            unfold constfold_0plus in IHc2. simpl in IHc2.
            apply CSeq_congruence. assumption. assumption.
          SSSCase "c2_1 = ::=".
          unfold constfold_0plus in IHc1. simpl in IHc1.
          unfold constfold_0plus in IHc2.
          unfold constfold_0plus. simpl.
          destruct c2_2.
            SSSSCase "c2_2 = SKIP". simpl.
              apply CSeq_congruence. assumption. assumption.
            SSSSCase "c2_2 = ::=".
              simpl. apply CSeq_congruence. assumption. assumption.
            SSSSCase "c2_2 = ;;". simpl.

    simpl.
destruct c2. simpl.
      unfold cequiv. split. intros. inversion H. subst. inversion H2. subst. assumption.
      intros. apply E_Seq with (st':=st). apply E_Skip. assumption.
      assert (H:cequiv (i::=a) (optimize_0plus_com (i ::= a))).
      apply optimize_0plus_com_sound.
      assert (H1: cequiv (SKIP;; i::= a) (i::=a)).
      unfold cequiv. split. apply skip_left. apply skip_left.
      apply trans_cequiv with (c2:= (i ::= a)). assumption. assumption.
      assert (H1: cequiv (SKIP;; c2_1;; c2_2) (c2_1;; c2_2)).
        unfold cequiv. split. apply skip_left. apply skip_left.
      apply trans_cequiv with (c2:= (c2_1;; c2_2)). assumption.
      assert (H:cequiv (c2_1;; c2_2) (optimize_0plus_com (c2_1;; c2_2))). apply optimize_0plus_com_sound. assumption.
      simpl. unfold cequiv. split. intros.
      inversion H. subst. inversion H2. subst.
      assert (
      replace (optimize_0plus_aexp a) with a. assumption.
        apply

unfold constfold_0plus in IHc1. simpl in IHc1. SKIP apply E_Seq in H.
      replace (SKIP;; SKIP) with SKIP. apply refl_cequiv.
        apply skip_left.
Qed.


Require Import List.
Import ListNotations.
Require Import StructTact.StructTactics.
Require Import StructTact.Update.

Require Import Chord.Chord.

Require Import Chord.SystemReachable.
Require Import Chord.SystemLemmas.

Set Bullet Behavior "Strict Subproofs".

Lemma do_delayed_queries_ptr :
  forall h st st' ms ts cts,
    do_delayed_queries h st = (st', ms, ts, cts) ->
    ptr st' = ptr st.
Proof.
  intros.
  unfold do_delayed_queries, clear_delayed_queries in *.
  break_match; find_inversion; auto.
Qed.

Ltac simpler := repeat (repeat find_inversion; subst; simpl in *); auto.
Lemma handle_msg_ptr :
  forall h h' st m st' ms ts cts,
    handle_msg h h' st m = (st', ms, ts, cts) ->
    ptr st' = ptr st.
Proof.
  intros.
  unfold handle_msg in *.
  repeat (break_match; simpler);
    unfold handle_query_res in *; repeat (break_match; simpler);
    unfold handle_query_req_busy in *; repeat (break_match; simpler);
    unfold handle_stabilize in *; repeat (break_match; simpler);
    unfold schedule_rectify_with in *; repeat (break_match; simpler);
    unfold end_query in *; repeat (break_match; simpler);
    unfold handle_rectify in *; repeat (break_match; simpler);
    unfold start_query in *; repeat (break_match; simpler).
Qed.

(*
This is a very good and easy invariant.  At a node h, ptr st is a copy
of a pointer to h. It's set when the node starts up and never changed
anywhere.

USED: In phase two.
*)
Lemma ptr_correct :
  forall gst h st,
    reachable_st gst ->
    sigma gst h = Some st ->
    ptr st = make_pointer h.
Proof.
  intros. induct_reachable_st.
  - intros.
    unfold initial_st in *.
    find_apply_lem_hyp sigma_initial_st_start_handler; simpl in *; auto. subst.
    unfold start_handler in *. repeat break_match; simpl; auto.
  - intros. invcs H0; auto.
    + update_destruct; subst; rewrite_update; auto.
      now find_inversion.
    + update_destruct; subst; rewrite_update; auto.
      find_inversion.
      unfold timeout_handler, timeout_handler_eff in *.
      break_match.
      * unfold tick_handler in *. break_match; simpl in *; try solve_by_inversion.
        break_if; simpl in *; try solve_by_inversion.
        unfold add_tick, start_query in *.
        repeat break_let.
        subst. find_inversion.
        repeat break_match; simpl in *;
          find_inversion; simpl; auto.
      * unfold do_rectify in *. simpl in *.
        break_match; simpl in *; try solve_by_inversion;
        break_match; simpl in *; try solve_by_inversion;
        break_match; simpl in *; try solve_by_inversion.
        unfold start_query, update_pred in *;
          repeat break_match; simpl in *; find_inversion; simpl; auto.
      * simpl in *. find_inversion. auto.
      * unfold request_timeout_handler in *.
        repeat break_match; simpl in *; try solve_by_inversion.
        subst. unfold update_pred, handle_query_timeout, do_delayed_queries in *.
        repeat break_match; simpl in *; try find_inversion; simpl in *; auto;
          repeat find_rewrite || find_injection;
          simpl; eauto;
            unfold start_query in *;
          repeat break_match; try find_inversion; simpl in *; auto.
    + update_destruct; subst; rewrite_update; auto.
      find_inversion.
      unfold recv_handler in *. repeat break_let. find_inversion.
      find_apply_lem_hyp do_delayed_queries_ptr.
      repeat find_rewrite.
      find_apply_lem_hyp handle_msg_ptr.
      repeat find_rewrite. auto.
Qed.


From Autosubst Require Import Autosubst.
From iris.algebra Require Export list.
From iris.proofmode Require Import proofmode.
From self.prob_lang Require Import metatheory primitive_laws.
From self.prelude Require Import asubst properness.
From self.logrel Require Import model.
From self.typing Require Import types.

(** * Interpretation of types *)
Section semtypes.
  Context `{!prelogrelGS Σ}.

  Program Definition ctx_lookup (x : var) : listO (lrelC Σ) -n> (lrelC Σ)
    := λne Δ, (from_option id lrel_true (Δ !! x))%I.
  Next Obligation.
    intros x n Δ Δ' HΔ.
    destruct (Δ !! x) as [P|] eqn:HP; cbn in *.
    - eapply (Forall2_lookup_l _ _ _ x P) in HΔ; last done.
      destruct HΔ as (Q & HQ & HΔ).
      rewrite HQ /= //.
    - destruct (Δ' !! x) as [Q|] eqn:HQ; last reflexivity.
      eapply (Forall2_lookup_r _ _ _ x Q) in HΔ; last done.
      destruct HΔ as (P & HP' & HΔ). exfalso.
      rewrite HP in HP'. inversion HP'.
  Qed.

  Program Fixpoint interp (τ : type) : listO (lrelC Σ) -n> lrelC Σ :=
    match τ as _ return listO (lrelC Σ) -n> lrelC Σ with
    | TUnit => λne _, lrel_unit
    | TInt => λne _, lrel_int
    | TBool => λne _, lrel_bool
    | TProd τ1 τ2 => λne Δ, lrel_prod (interp τ1 Δ) (interp τ2 Δ)
    | TSum τ1 τ2 => λne Δ, lrel_sum (interp τ1 Δ) (interp τ2 Δ)
    | TArrow τ1 τ2 => λne Δ, lrel_arr (interp τ1 Δ) (interp τ2 Δ)
    | TRec τ' => λne Δ, lrel_rec (λne τ, interp τ' (τ::Δ))
    | TVar x => ctx_lookup x
    | TForall τ' => λne Δ, lrel_forall (λ τ, interp τ' (τ::Δ))
    | TExists τ' => λne Δ, lrel_exists (λ τ, interp τ' (τ::Δ))
    | TRef τ => λne Δ, lrel_ref (interp τ Δ)
    | TTape => λne Δ, lrel_tape
    end.
  Solve Obligations with (intros I τ τ' n Δ Δ' HΔ' ??; try solve_proper).
  Next Obligation.
    intros I τ τ' n Δ Δ' HΔ' ??.
    apply lrel_rec_ne=> X /=.
    apply I. by f_equiv.
  Defined.

  Lemma unboxed_type_sound τ Δ v v' :
    UnboxedType τ →
    interp τ Δ v v' -∗ ⌜val_is_unboxed v ∧ val_is_unboxed v'⌝.
  Proof.
    induction 1; simpl;
    first [iDestruct 1 as (? ?) "[% [% ?]]"
          |iDestruct 1 as (?) "[% %]"
          |iIntros "[% %]"];
    simplify_eq/=; eauto with iFrame.
  Qed.

  Lemma eq_type_sound τ Δ v v' :
    EqType τ →
    interp τ Δ v v' -∗ ⌜v = v'⌝.
  Proof.
    intros Hτ; revert v v'; induction Hτ; iIntros (v v') "#H1 /=".
    - by iDestruct "H1" as %[-> ->].
    - by iDestruct "H1" as (n) "[% %]"; subst.
    - by iDestruct "H1" as (b) "[% %]"; subst.
    - iDestruct "H1" as (?? ??) "[% [% [H1 H2]]]"; simplify_eq/=.
      rewrite IHHτ1 IHHτ2.
      by iDestruct "H1" as "%"; iDestruct "H2" as "%"; subst.
    - iDestruct "H1" as (??) "[H1|H1]".
      + iDestruct "H1" as "[% [% H1]]"; simplify_eq/=.
        rewrite IHHτ1. by iDestruct "H1" as "%"; subst.
      + iDestruct "H1" as "[% [% H1]]"; simplify_eq/=.
        rewrite IHHτ2. by iDestruct "H1" as "%"; subst.
  Qed.

  Lemma unboxed_type_eq τ Δ v1 v2 w1 w2 :
    UnboxedType τ →
    interp τ Δ v1 v2 -∗
    interp τ Δ w1 w2 -∗
    |={⊤}=> ⌜v1 = w1 ↔ v2 = w2⌝.
  Proof.
    intros Hunboxed.
    cut (EqType τ ∨ (∃ τ', τ = TRef τ') ∨ τ = TTape).
    { intros [Hτ | [[τ' ->] | ->]].
      - rewrite !eq_type_sound //.
        iIntros "% %". iModIntro.
        iPureIntro. naive_solver.
      - rewrite /lrel_car /=.
        iDestruct 1 as (l1 l2 -> ->) "Hl".
        iDestruct 1 as (r1 r2 -> ->) "Hr".
        destruct (decide (l1 = r1)); subst.
        + destruct (decide (l2 = r2)); subst; first by eauto.
          iInv (logN.@(r1, l2)) as (v1 v2) "(>Hr1 & >Hr2 & Hinv1)".
          iInv (logN.@(r1, r2)) as (w1 w2) "(>Hr1' & >Hr2' & Hinv2)".
          iExFalso. by iDestruct (ghost_map_elem_valid_2 with "Hr1 Hr1'") as %[].
        + destruct (decide (l2 = r2)); subst; last first.
          { iModIntro. iPureIntro. naive_solver. }
          iInv (logN.@(r1, r2)) as (v1 v2) "(>Hr1 & >Hr2 & Hinv1)".
          iInv (logN.@(l1, r2)) as (w1 w2) "(>Hr1' & >Hr2' & Hinv2)".
          iExFalso. by iDestruct (ghost_map_elem_valid_2 with "Hr2 Hr2'") as %[].       - rewrite /lrel_car /=.
        iDestruct 1 as (l1 l2 -> ->) "Hl".
        iDestruct 1 as (r1 r2 -> ->) "Hr".
        destruct (decide (l1 = r1)); subst.
        + destruct (decide (l2 = r2)); subst; first by eauto.
          iInv (logN.@(r1, l2)) as "> (Hr1 & Hl2)".
          iInv (logN.@(r1, r2)) as "> (Hr1' & Hr2')".
          iExFalso. by iDestruct (ghost_map_elem_valid_2 with "Hr1 Hr1'") as %[].
        + destruct (decide (l2 = r2)); subst; last first.
          { iModIntro. iPureIntro. naive_solver. }
          iInv (logN.@(r1, r2)) as "> (Hr1 & Hr2)".
          iInv (logN.@(l1, r2)) as "> (Hl1 & Hr2')".
          iExFalso. by iDestruct (ghost_map_elem_valid_2 with "Hr2 Hr2'") as %[]. }
    by apply unboxed_type_ref_or_eqtype.
  Qed.

End semtypes.

(** ** Properties of the type inrpretation w.r.t. the substitutions *)
Section interp_ren.
  Context `{!prelogrelGS Σ}.
  Implicit Types Δ : list (lrel Σ).

  (* TODO: why do I need to unfold lrel_car here? *)
  Lemma interp_ren_up (Δ1 Δ2 : list (lrel Σ)) τ τi :
    interp τ (Δ1 ++ Δ2) ≡ interp (τ.[upn (length Δ1) (ren (+1))]) (Δ1 ++ τi :: Δ2).
  Proof.
    revert Δ1 Δ2. induction τ => Δ1 Δ2; simpl; eauto;
    try by
      (intros ? ?; unfold lrel_car; simpl; properness; repeat f_equiv=>//).
    - apply fixpoint_proper=> τ' w1 w2 /=.
      unfold lrel_car. simpl.
      properness; auto. apply (IHτ (_ :: _)).
    - intros v1 v2; unfold lrel_car; simpl;
        simpl; properness; auto.
      rewrite /lrel_car /=. properness; auto.
      apply refines_proper=> //. apply (IHτ (_ :: _)).
    - intros ??; unfold lrel_car; simpl; properness; auto. apply (IHτ (_ :: _)).
    - intros v1 v2; simpl.
      rewrite iter_up. case_decide; simpl; properness.
      { by rewrite !lookup_app_l. }
      change (bi_ofeO (uPredI (iResUR Σ))) with (uPredO (iResUR Σ)).
      rewrite !lookup_app_r; [|lia..].
      assert (∀ x, (length Δ1 + S (x - length Δ1) - length Δ1) = S (x - length Δ1)) as Hwat.
      { lia. }
      rewrite Hwat. simpl. done.
  Qed.

  Lemma interp_ren A Δ (Γ : gmap string type) :
    ((λ τ, interp τ (A::Δ)) <$> ⤉Γ) ≡ ((λ τ, interp τ Δ) <$> Γ).
  Proof.
    rewrite -map_fmap_compose => x /=.
    rewrite !lookup_fmap.
    destruct (Γ !! x); auto; simpl. f_equiv.
    symmetry. apply (interp_ren_up []).
  Qed.

  Lemma interp_weaken (Δ1 Π Δ2 : list (lrel Σ)) τ :
    interp (τ.[upn (length Δ1) (ren (+ length Π))]) (Δ1 ++ Π ++ Δ2)
    ≡ interp τ (Δ1 ++ Δ2).
  Proof.
    revert Δ1 Π Δ2. induction τ=> Δ1 Π Δ2; simpl; eauto;
    try by
      (intros ? ?; simpl; unfold lrel_car; simpl; repeat f_equiv =>//).
    - apply fixpoint_proper=> τi ?? /=.
      unfold lrel_car; simpl.
      properness; auto. apply (IHτ (_ :: _)).
    - intros ??; simpl; unfold lrel_car; simpl;
      properness; auto.
      rewrite /lrel_car /=. properness; auto.
      apply refines_proper=> //. apply (IHτ (_ :: _)).
    - intros ??; unfold lrel_car; simpl; properness; auto.
        by apply (IHτ (_ :: _)).
    - intros ??; simpl; properness; auto.
      rewrite iter_up; case_decide; properness; simpl.
      { by rewrite !lookup_app_l. }
      rewrite !lookup_app_r ;[| lia ..]. do 3 f_equiv. lia.
  Qed.

  Lemma interp_subst_up (Δ1 Δ2 : list (lrel Σ)) τ τ' :
    interp τ (Δ1 ++ interp τ' Δ2 :: Δ2)
    ≡ interp (τ.[upn (length Δ1) (τ' .: ids)]) (Δ1 ++ Δ2).
  Proof.
    revert Δ1 Δ2; induction τ=> Δ1 Δ2; simpl; eauto;
    try by
      (intros ? ?; unfold lrel_car; simpl; properness; repeat f_equiv=>//).
    - apply fixpoint_proper=> τi ?? /=.
      unfold lrel_car. simpl.
      properness; auto. apply (IHτ (_ :: _)).
    - intros ??. unfold lrel_car; simpl;
      properness; auto.
      rewrite /lrel_car /=. properness; auto.
      apply refines_proper=>//. apply (IHτ (_ :: _)).
    - intros ??; unfold lrel_car; simpl; properness; auto. apply (IHτ (_ :: _)).
    - intros w1 w2; simpl.
      rewrite iter_up; case_decide; simpl; properness.
      { by rewrite !lookup_app_l. }
      rewrite !lookup_app_r; [|lia..].
      case EQ: (_ - length Δ1)=> [|n]; simpl.
      { symmetry.
        pose (HW := interp_weaken [] Δ1 Δ2 τ' w1 w2).
        etrans; last by apply HW.
        asimpl. reflexivity. }
      rewrite !lookup_app_r; [|lia ..]. repeat f_equiv. lia.
  Qed.

  Lemma interp_subst Δ2 τ τ' :
    interp τ (interp τ' Δ2 :: Δ2) ≡ interp (τ.[τ'/]) Δ2.
  Proof. apply (interp_subst_up []). Qed.
End interp_ren.

(** * Interpretation of the environments *)
Section env_typed.
  Context `{!prelogrelGS Σ}.
  Implicit Types A B : lrel Σ.
  Implicit Types Γ : gmap string (lrel Σ).

  (** Substitution [vs] is well-typed w.r.t. [Γ] *)
  Definition env_ltyped2 (Γ : gmap string (lrel Σ))
    (vs : gmap string (val*val)) : iProp Σ :=
    ([∗ map] i ↦ A;vv ∈ Γ;vs, lrel_car A vv.1 vv.2)%I.

  Notation "⟦ Γ ⟧*" := (env_ltyped2 Γ).

  (* TODO: make a separate instance for big_sepM2 *)
  Global Instance env_ltyped2_ne n :
    Proper (dist n ==> (=) ==> dist n) env_ltyped2.
  Proof.
    intros Γ Γ' HΓ ? vvs ->. apply big_sepM2_ne_2; [done..|solve_proper].
  Qed.

  Global Instance env_ltyped2_proper :
    Proper ((≡) ==> (=) ==> (≡)) env_ltyped2.
  Proof. solve_proper_from_ne. Qed.

  Lemma env_ltyped2_lookup Γ vs x A :
    Γ !! x = Some A →
    ⟦ Γ ⟧* vs -∗ ∃ v1 v2, ⌜ vs !! x = Some (v1,v2) ⌝ ∧ A v1 v2.
  Proof.
    intros ?. rewrite /env_ltyped2 big_sepM2_lookup_l //.
    iDestruct 1 as ([v1 v2] ?) "H". eauto with iFrame.
  Qed.

  Lemma env_ltyped2_insert Γ vs x A v1 v2 :
    A v1 v2 -∗ ⟦ Γ ⟧* vs -∗
    ⟦ (binder_insert x A Γ) ⟧* (binder_insert x (v1,v2) vs).
  Proof.
    destruct x as [|x]=> /=; first by auto.
    rewrite /env_ltyped2. iIntros "HA HΓ".
    now iApply (big_sepM2_insert_2 with "[HA] [HΓ]").
  Qed.

  Lemma env_ltyped2_empty :
    ⊢ ⟦ ∅ ⟧* ∅.
  Proof. apply (big_sepM2_empty' _). Qed.

  Lemma env_ltyped2_empty_inv vs :
    ⟦ ∅ ⟧* vs -∗ ⌜vs = ∅⌝.
  Proof. apply big_sepM2_empty_r. Qed.

  Global Instance env_ltyped2_persistent Γ vs : Persistent (⟦ Γ ⟧* vs).
  Proof. apply _. Qed.
End env_typed.

Notation "⟦ Γ ⟧*" := (env_ltyped2 Γ).

(** * The semantic typing judgement *)
Section bin_log_related.
  Context `{!prelogrelGS Σ}.

  Definition bin_log_related (E : coPset)
             (Δ : list (lrel Σ)) (Γ : stringmap type)
             (e e' : expr) (τ : type) : iProp Σ :=
    (∀ vs, ⟦ (λ τ, interp τ Δ) <$> Γ ⟧* vs -∗
           REL (subst_map (fst <$> vs) e)
            << (subst_map (snd <$> vs) e') @ E : (interp τ Δ))%I.

End bin_log_related.

Notation "'{' E ';' Δ ';' Γ '}' ⊨ e '≤log≤' e' : τ" :=
  (bin_log_related E Δ Γ e%E e'%E (τ)%ty)
  (at level 100, E at next level, Δ at next level, Γ at next level, e, e' at next level,
   τ at level 200,
   format "'[hv' '{' E ';'  Δ ';'  Γ '}'  ⊨  '/  ' e  '/' '≤log≤'  '/  ' e'  :  τ ']'").
Notation "'{' Δ ';' Γ '}' ⊨ e '≤log≤' e' : τ" :=
  (bin_log_related ⊤ Δ Γ e%E e'%E (τ)%ty)
  (at level 100, Δ at next level, Γ at next level, e, e' at next level,
   τ at level 200,
   format "'[hv' '{' Δ ';'  Γ '}'  ⊨  '/  ' e  '/' '≤log≤'  '/  ' e'  :  τ ']'").


(* ** AES-NI *)
(* From eclib/AES.ec *)

(* ** Imports and settings *)

From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp Require Import word_ssrZ word.
Require Import word.
Require Import Psatz ZArith utils.
Import Utf8.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import ssrnat.

Local Open Scope Z_scope.

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

Definition Sbox (v1 : u8) : u8 :=
  wrepr U8 match toword v1 with
  | 0 => 99    | 1 => 124   | 2 => 119   | 3 => 123   | 4 => 242
  | 5 => 107   | 6 => 111   | 7 => 197   | 8 => 48    | 9 => 1
  | 10 => 103  | 11 => 43   | 12 => 254  | 13 => 215  | 14 => 171
  | 15 => 118  | 16 => 202  | 17 => 130  | 18 => 201  | 19 => 125
  | 20 => 250  | 21 => 89   | 22 => 71   | 23 => 240  | 24 => 173
  | 25 => 212  | 26 => 162  | 27 => 175  | 28 => 156  | 29 => 164
  | 30 => 114  | 31 => 192  | 32 => 183  | 33 => 253  | 34 => 147
  | 35 => 38   | 36 => 54   | 37 => 63   | 38 => 247  | 39 => 204
  | 40 => 52   | 41 => 165  | 42 => 229  | 43 => 241  | 44 => 113
  | 45 => 216  | 46 => 49   | 47 => 21   | 48 => 4    | 49 => 199
  | 50 => 35   | 51 => 195  | 52 => 24   | 53 => 150  | 54 => 5
  | 55 => 154  | 56 => 7    | 57 => 18   | 58 => 128  | 59 => 226
  | 60 => 235  | 61 => 39   | 62 => 178  | 63 => 117  | 64 => 9
  | 65 => 131  | 66 => 44   | 67 => 26   | 68 => 27   | 69 => 110
  | 70 => 90   | 71 => 160  | 72 => 82   | 73 => 59   | 74 => 214
  | 75 => 179  | 76 => 41   | 77 => 227  | 78 => 47   | 79 => 132
  | 80 => 83   | 81 => 209  | 82 => 0    | 83 => 237  | 84 => 32
  | 85 => 252  | 86 => 177  | 87 => 91   | 88 => 106  | 89 => 203
  | 90 => 190  | 91 => 57   | 92 => 74   | 93 => 76   | 94 => 88
  | 95 => 207  | 96 => 208  | 97 => 239  | 98 => 170  | 99 => 251
  | 100 => 67  | 101 => 77  | 102 => 51  | 103 => 133 | 104 => 69
  | 105 => 249 | 106 => 2   | 107 => 127 | 108 => 80  | 109 => 60
  | 110 => 159 | 111 => 168 | 112 => 81  | 113 => 163 | 114 => 64
  | 115 => 143 | 116 => 146 | 117 => 157 | 118 => 56  | 119 => 245
  | 120 => 188 | 121 => 182 | 122 => 218 | 123 => 33  | 124 => 16
  | 125 => 255 | 126 => 243 | 127 => 210 | 128 => 205 | 129 => 12
  | 130 => 19  | 131 => 236 | 132 => 95  | 133 => 151 | 134 => 68
  | 135 => 23  | 136 => 196 | 137 => 167 | 138 => 126 | 139 => 61
  | 140 => 100 | 141 => 93  | 142 => 25  | 143 => 115 | 144 => 96
  | 145 => 129 | 146 => 79  | 147 => 220 | 148 => 34  | 149 => 42
  | 150 => 144 | 151 => 136 | 152 => 70  | 153 => 238 | 154 => 184
  | 155 => 20  | 156 => 222 | 157 => 94  | 158 => 11  | 159 => 219
  | 160 => 224 | 161 => 50  | 162 => 58  | 163 => 10  | 164 => 73
  | 165 => 6   | 166 => 36  | 167 => 92  | 168 => 194 | 169 => 211
  | 170 => 172 | 171 => 98  | 172 => 145 | 173 => 149 | 174 => 228
  | 175 => 121 | 176 => 231 | 177 => 200 | 178 => 55  | 179 => 109
  | 180 => 141 | 181 => 213 | 182 => 78  | 183 => 169 | 184 => 108
  | 185 => 86  | 186 => 244 | 187 => 234 | 188 => 101 | 189 => 122
  | 190 => 174 | 191 => 8   | 192 => 186 | 193 => 120 | 194 => 37
  | 195 => 46  | 196 => 28  | 197 => 166 | 198 => 180 | 199 => 198
  | 200 => 232 | 201 => 221 | 202 => 116 | 203 => 31  | 204 => 75
  | 205 => 189 | 206 => 139 | 207 => 138 | 208 => 112 | 209 => 62
  | 210 => 181 | 211 => 102 | 212 => 72  | 213 => 3   | 214 => 246
  | 215 => 14  | 216 => 97  | 217 => 53  | 218 => 87  | 219 => 185
  | 220 => 134 | 221 => 193 | 222 => 29  | 223 => 158 | 224 => 225
  | 225 => 248 | 226 => 152 | 227 => 17  | 228 => 105 | 229 => 217
  | 230 => 142 | 231 => 148 | 232 => 155 | 233 => 30  | 234 => 135
  | 235 => 233 | 236 => 206 | 237 => 85  | 238 => 40  | 239 => 223
  | 240 => 140 | 241 => 161 | 242 => 137 | 243 => 13  | 244 => 191
  | 245 => 230 | 246 => 66  | 247 => 104 | 248 => 65  | 249 => 153
  | 250 => 45  | 251 => 15  | 252 => 176 | 253 => 84  | 254 => 187
  | 255 => 22  | _ => 0
  end.

Definition InvSbox (v1 : u8) :=
  wrepr U8 match toword v1 with
  | 0 => 82    | 1 => 9     | 2 => 106   | 3 => 213   | 4 => 48
  | 5 => 54    | 6 => 165   | 7 => 56    | 8 => 191   | 9 => 64
  | 10 => 163  | 11 => 158  | 12 => 129  | 13 => 243  | 14 => 215
  | 15 => 251  | 16 => 124  | 17 => 227  | 18 => 57   | 19 => 130
  | 20 => 155  | 21 => 47   | 22 => 255  | 23 => 135  | 24 => 52
  | 25 => 142  | 26 => 67   | 27 => 68   | 28 => 196  | 29 => 222
  | 30 => 233  | 31 => 203  | 32 => 84   | 33 => 123  | 34 => 148
  | 35 => 50   | 36 => 166  | 37 => 194  | 38 => 35   | 39 => 61
  | 40 => 238  | 41 => 76   | 42 => 149  | 43 => 11   | 44 => 66
  | 45 => 250  | 46 => 195  | 47 => 78   | 48 => 8    | 49 => 46
  | 50 => 161  | 51 => 102  | 52 => 40   | 53 => 217  | 54 => 36
  | 55 => 178  | 56 => 118  | 57 => 91   | 58 => 162  | 59 => 73
  | 60 => 109  | 61 => 139  | 62 => 209  | 63 => 37   | 64 => 114
  | 65 => 248  | 66 => 246  | 67 => 100  | 68 => 134  | 69 => 104
  | 70 => 152  | 71 => 22   | 72 => 212  | 73 => 164  | 74 => 92
  | 75 => 204  | 76 => 93   | 77 => 101  | 78 => 182  | 79 => 146
  | 80 => 108  | 81 => 112  | 82 => 72   | 83 => 80   | 84 => 253
  | 85 => 237  | 86 => 185  | 87 => 218  | 88 => 94   | 89 => 21
  | 90 => 70   | 91 => 87   | 92 => 167  | 93 => 141  | 94 => 157
  | 95 => 132  | 96 => 144  | 97 => 216  | 98 => 171  | 99 => 0
  | 100 => 140 | 101 => 188 | 102 => 211 | 103 => 10  | 104 => 247
  | 105 => 228 | 106 => 88  | 107 => 5   | 108 => 184 | 109 => 179
  | 110 => 69  | 111 => 6   | 112 => 208 | 113 => 44  | 114 => 30
  | 115 => 143 | 116 => 202 | 117 => 63  | 118 => 15  | 119 => 2
  | 120 => 193 | 121 => 175 | 122 => 189 | 123 => 3   | 124 => 1
  | 125 => 19  | 126 => 138 | 127 => 107 | 128 => 58  | 129 => 145
  | 130 => 17  | 131 => 65  | 132 => 79  | 133 => 103 | 134 => 220
  | 135 => 234 | 136 => 151 | 137 => 242 | 138 => 207 | 139 => 206
  | 140 => 240 | 141 => 180 | 142 => 230 | 143 => 115 | 144 => 150
  | 145 => 172 | 146 => 116 | 147 => 34  | 148 => 231 | 149 => 173
  | 150 => 53  | 151 => 133 | 152 => 226 | 153 => 249 | 154 => 55
  | 155 => 232 | 156 => 28  | 157 => 117 | 158 => 223 | 159 => 110
  | 160 => 71  | 161 => 241 | 162 => 26  | 163 => 113 | 164 => 29
  | 165 => 41  | 166 => 197 | 167 => 137 | 168 => 111 | 169 => 183
  | 170 => 98  | 171 => 14  | 172 => 170 | 173 => 24  | 174 => 190
  | 175 => 27  | 176 => 252 | 177 => 86  | 178 => 62  | 179 => 75
  | 180 => 198 | 181 => 210 | 182 => 121 | 183 => 32  | 184 => 154
  | 185 => 219 | 186 => 192 | 187 => 254 | 188 => 120 | 189 => 205
  | 190 => 90  | 191 => 244 | 192 => 31  | 193 => 221 | 194 => 168
  | 195 => 51  | 196 => 136 | 197 => 7   | 198 => 199 | 199 => 49
  | 200 => 177 | 201 => 18  | 202 => 16  | 203 => 89  | 204 => 39
  | 205 => 128 | 206 => 236 | 207 => 95  | 208 => 96  | 209 => 81
  | 210 => 127 | 211 => 169 | 212 => 25  | 213 => 181 | 214 => 74
  | 215 => 13  | 216 => 45  | 217 => 229 | 218 => 122 | 219 => 159
  | 220 => 147 | 221 => 201 | 222 => 156 | 223 => 239 | 224 => 160
  | 225 => 224 | 226 => 59  | 227 => 77  | 228 => 174 | 229 => 42
  | 230 => 245 | 231 => 176 | 232 => 200 | 233 => 235 | 234 => 187
  | 235 => 60  | 236 => 131 | 237 => 83  | 238 => 153 | 239 => 97
  | 240 => 23  | 241 => 43  | 242 => 4   | 243 => 126 | 244 => 186
  | 245 => 119 | 246 => 214 | 247 => 38  | 248 => 225 | 249 => 105
  | 250 => 20  | 251 => 99  | 252 => 85  | 253 => 33  | 254 => 12
  | 255 => 125 | _ => 0
  end.

(* NOTE: SubWord clashes with subword *)
Definition SubWord (v1 : u32) :=
  make_vec U32 (map Sbox (split_vec U8 v1)).
Definition InvSubWord (v1 : u32) :=
  make_vec U32 (map InvSbox (split_vec U8 v1)).
Definition RotWord (v1 : u32) :=
  make_vec U32 [:: (subword (1 * U8) U8 v1); subword (2 * U8) U8 v1; subword (3 * U8) U8 v1; subword (0 * U8) U8 v1].

Definition to_matrix (s : u128) :=
  let s_ := fun i j => (subword (i * U8) U8 (subword (j * U32) U32 s)) in
  (s_ 0 0, s_ 0 1, s_ 0 2, s_ 0 3,
    s_ 1 0, s_ 1 1, s_ 1 2, s_ 1 3,
    s_ 2 0, s_ 2 1, s_ 2 2, s_ 2 2,
    s_ 3 0, s_ 3 1, s_ 3 2, s_ 3 3)%nat.

Definition to_state (m : u8 * u8 * u8 * u8 * u8 * u8 * u8 * u8 * u8 * u8 * u8 * u8 * u8 * u8 * u8 * u8) :=
  let '(s00, s01, s02, s03,
        s10, s11, s12, s13,
        s20, s21, s22, s23,
        s30, s31, s32, s33) := m in
  let c0 := make_vec U32 [:: s00; s10; s20; s30] in
  let c1 := make_vec U32 [:: s01; s11; s21; s31] in
  let c2 := make_vec U32 [:: s02; s12; s22; s32] in
  let c3 := make_vec U32 [:: s03; s13; s23; s33] in
  make_vec U128 [:: c0; c1; c2; c3].

Definition SubBytes (s : u128) :=
  make_vec U128 (map SubWord (split_vec U32 s)).
Definition InvSubBytes (s : u128) :=
  make_vec U128 (map InvSubWord (split_vec U32 s)).

Definition ShiftRows (s : u128) :=
 let '(s00, s01, s02, s03,
       s10, s11, s12, s13,
       s20, s21, s22, s23,
       s30, s31, s32, s33) := to_matrix s in
 to_state (s00, s01, s02, s03,
           s11, s12, s13, s10,
           s22, s23, s20, s21,
           s33, s30, s31, s32).

Definition InvShiftRows (s : u128) :=
 let '(s00, s01, s02, s03,
       s11, s12, s13, s10,
       s22, s23, s20, s21,
       s33, s30, s31, s32) := to_matrix s in
 to_state
    (s00, s01, s02, s03,
     s10, s11, s12, s13,
     s20, s21, s22, s23,
     s30, s31, s32, s33).

(* TODO: Implement these *)
Parameter MixColumns : u128 -> u128.
Parameter InvMixColumns : u128 -> u128.

Definition wAESDEC (state rkey : u128) :=
  let state := InvShiftRows state in
  let state := InvSubBytes state in
  let state := InvMixColumns state in
  wxor state rkey.

Definition wAESDECLAST (state rkey : u128) :=
  let state := InvShiftRows state in
  let state := InvSubBytes state in
  wxor state rkey.

Definition wAESENC (state rkey : u128) :=
  let state := ShiftRows state in
  let state := SubBytes state in
  let state := MixColumns state in
  wxor state rkey.

Definition wAESENCLAST (state rkey : u128) :=
  let state := ShiftRows state in
  let state := SubBytes state in
  wxor state rkey.

Notation wAESIMC := InvMixColumns.

Definition wAESKEYGENASSIST (v1 : u128) (v2 : u8) :=
  let rcon := zero_extend U32 v2 in
  let x1 := subword (1 * U32) U32 v1 in
  let x3 := subword (3 * U32) U32 v1 in
  let y0 := SubWord x1 in
  let y1 := wxor (RotWord (SubWord x1)) rcon in
  let y2 := SubWord x3 in
  let y3 := wxor (RotWord (SubWord x3)) rcon in
  make_vec U128 [:: y0; y1; y2; y3].

Definition wAESENC_ (state rkey: u128) :=
  let state := SubBytes state in
  let state := ShiftRows state in
  let state := MixColumns state in
  wxor state rkey.

Definition wAESENCLAST_ (state rkey: u128) :=
  let state := SubBytes state in
  let state := ShiftRows state in
  wxor state rkey.

Definition wAESDEC_ (state rkey: u128) :=
  let state := InvShiftRows state in
  let state := InvSubBytes state in
  let state := wxor state rkey in
  InvMixColumns state.


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

(** Correctness proof for constant propagation (processor-dependent part). *)

Require Import Coqlib.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
Require Import Events.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import ConstpropOp.
Require Import Constprop.

(** * Correctness of the static analysis *)

Section ANALYSIS.

Variable ge: genv.
Variable sp: val.

(** We first show that the dataflow analysis is correct with respect
  to the dynamic semantics: the approximations (sets of values)
  of a register at a program point predicted by the static analysis
  are a superset of the values actually encountered during concrete
  executions.  We formalize this correspondence between run-time values and
  compile-time approximations by the following predicate. *)

Definition val_match_approx (a: approx) (v: val) : Prop :=
  match a with
  | Unknown => True
  | I p => v = Vint p
  | F p => v = Vfloat p
  | G symb ofs => v = symbol_address ge symb ofs
  | S ofs => v = Val.add sp (Vint ofs)
  | _ => False
  end.

Inductive val_list_match_approx: list approx -> list val -> Prop :=
  | vlma_nil:
      val_list_match_approx nil nil
  | vlma_cons:
      forall a al v vl,
      val_match_approx a v ->
      val_list_match_approx al vl ->
      val_list_match_approx (a :: al) (v :: vl).

Ltac SimplVMA :=
  match goal with
  | H: (val_match_approx (I _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (F _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (G _ _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (S _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | _ =>
      idtac
  end.

Ltac InvVLMA :=
  match goal with
  | H: (val_list_match_approx nil ?vl) |- _ =>
      inv H
  | H: (val_list_match_approx (?a :: ?al) ?vl) |- _ =>
      inv H; SimplVMA; InvVLMA
  | _ =>
      idtac
  end.

(** We then show that [eval_static_operation] is a correct abstract
  interpretations of [eval_operation]: if the concrete arguments match
  the given approximations, the concrete results match the
  approximations returned by [eval_static_operation]. *)

Lemma eval_static_condition_correct:
  forall cond al vl m b,
  val_list_match_approx al vl ->
  eval_static_condition cond al = Some b ->
  eval_condition cond vl m = Some b.
Proof.
  intros until b.
  unfold eval_static_condition.
  case (eval_static_condition_match cond al); intros;
  InvVLMA; simpl; congruence.
Qed.

Remark shift_symbol_address:
  forall symb ofs n,
  symbol_address ge symb (Int.add ofs n) = Val.add (symbol_address ge symb ofs) (Vint n).
Proof.
  unfold symbol_address; intros. destruct (Genv.find_symbol ge symb); auto.
Qed.

Lemma eval_static_addressing_correct:
  forall addr al vl v,
  val_list_match_approx al vl ->
  eval_addressing ge sp addr vl = Some v ->
  val_match_approx (eval_static_addressing addr al) v.
Proof.
  intros until v. unfold eval_static_addressing.
  case (eval_static_addressing_match addr al); intros;
  InvVLMA; simpl in *; FuncInv; try subst v; auto.
  rewrite shift_symbol_address; auto.
  rewrite Val.add_assoc. auto.
  repeat rewrite shift_symbol_address. auto.
  fold (Val.add (Vint n1) (symbol_address ge id ofs)).
  repeat rewrite shift_symbol_address. repeat rewrite Val.add_assoc. rewrite Val.add_permut. auto.
  repeat rewrite Val.add_assoc. decEq; simpl. rewrite Int.add_assoc. auto.
  fold (Val.add (Vint n1) (Val.add sp (Vint ofs))).
  rewrite Val.add_assoc. rewrite Val.add_permut. rewrite Val.add_assoc.
  simpl. rewrite Int.add_assoc; auto.
  rewrite shift_symbol_address. auto.
  rewrite Val.add_assoc. auto.
  rewrite shift_symbol_address. auto.
  rewrite shift_symbol_address. rewrite Int.mul_commut; auto.
Qed.

Lemma eval_static_operation_correct:
  forall op al vl m v,
  val_list_match_approx al vl ->
  eval_operation ge sp op vl m = Some v ->
  val_match_approx (eval_static_operation op al) v.
Proof.
  intros until v.
  unfold eval_static_operation.
  case (eval_static_operation_match op al); intros;
  InvVLMA; simpl in *; FuncInv; try subst v; auto.
  destruct (propagate_float_constants tt); simpl; auto.
  rewrite Int.sub_add_opp. rewrite shift_symbol_address. rewrite Val.sub_add_opp. auto.
  destruct (Int.eq n2 Int.zero). inv H0.
    destruct (Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone); inv H0; simpl; auto.
  destruct (Int.eq n2 Int.zero); inv H0; simpl; auto.
  destruct (Int.eq n2 Int.zero). inv H0.
    destruct (Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone); inv H0; simpl; auto.
  destruct (Int.eq n2 Int.zero); inv H0; simpl; auto.
  destruct (Int.ltu n2 Int.iwordsize); simpl; auto.
  destruct (Int.ltu n Int.iwordsize); simpl; auto.
  destruct (Int.ltu n2 Int.iwordsize); simpl; auto.
  destruct (Int.ltu n Int.iwordsize); simpl; auto.
  destruct (Int.ltu n (Int.repr 31)); inv H0. simpl; auto.
  destruct (Int.ltu n2 Int.iwordsize); simpl; auto.
  destruct (Int.ltu n Int.iwordsize); simpl; auto.
  destruct (Int.ltu n Int.iwordsize); simpl; auto.
  eapply eval_static_addressing_correct; eauto.
  unfold eval_static_intoffloat.
  destruct (Float.intoffloat n1) eqn:?; simpl in H0; inv H0.
  simpl; auto.
  destruct (propagate_float_constants tt); simpl; auto.
  unfold eval_static_condition_val. destruct (eval_static_condition c vl0) as [b|] eqn:?.
  rewrite (eval_static_condition_correct _ _ _ m _ H Heqo).
  destruct b; simpl; auto.
  simpl; auto.
Qed.

(** * Correctness of strength reduction *)

(** We now show that strength reduction over operators and addressing
  modes preserve semantics: the strength-reduced operations and
  addressings evaluate to the same values as the original ones if the
  actual arguments match the static approximations used for strength
  reduction. *)

Section STRENGTH_REDUCTION.

Variable app: D.t.
Variable rs: regset.
Variable m: mem.
Hypothesis MATCH: forall r, val_match_approx (approx_reg app r) rs#r.

Ltac InvApproxRegs :=
  match goal with
  | [ H: _ :: _ = _ :: _ |- _ ] =>
        injection H; clear H; intros; InvApproxRegs
  | [ H: ?v = approx_reg app ?r |- _ ] =>
        generalize (MATCH r); rewrite <- H; clear H; intro; InvApproxRegs
  | _ => idtac
  end.

Lemma cond_strength_reduction_correct:
  forall cond args vl,
  vl = approx_regs app args ->
  let (cond', args') := cond_strength_reduction cond args vl in
  eval_condition cond' rs##args' m = eval_condition cond rs##args m.
Proof.
  intros until vl. unfold cond_strength_reduction.
  case (cond_strength_reduction_match cond args vl); simpl; intros; InvApproxRegs; SimplVMA.
  rewrite H0. apply Val.swap_cmp_bool.
  rewrite H. auto.
  rewrite H0. apply Val.swap_cmpu_bool.
  rewrite H. auto.
  auto.
Qed.

Lemma addr_strength_reduction_correct:
  forall addr args vl,
  vl = approx_regs app args ->
  let (addr', args') := addr_strength_reduction addr args vl in
  eval_addressing ge sp addr' rs##args' = eval_addressing ge sp addr rs##args.
Proof.
  intros until vl. unfold addr_strength_reduction.
  destruct (addr_strength_reduction_match addr args vl); simpl; intros; InvApproxRegs; SimplVMA.
  rewrite shift_symbol_address; congruence.
  rewrite H. rewrite Val.add_assoc; auto.
  rewrite H; rewrite H0. repeat rewrite shift_symbol_address. auto.
  rewrite H; rewrite H0. rewrite Int.add_assoc. rewrite Int.add_permut. repeat rewrite shift_symbol_address.
  rewrite Val.add_assoc. rewrite Val.add_permut. auto.
  rewrite H; rewrite H0. repeat rewrite Val.add_assoc. rewrite Int.add_assoc. auto.
  rewrite H; rewrite H0. repeat rewrite Val.add_assoc. rewrite Val.add_permut.
  rewrite Int.add_assoc. auto.
  rewrite H0. rewrite shift_symbol_address. repeat rewrite Val.add_assoc.
  decEq; decEq. apply Val.add_commut.
  rewrite H. rewrite shift_symbol_address. repeat rewrite Val.add_assoc.
  rewrite (Val.add_permut (rs#r1)). decEq; decEq. apply Val.add_commut.
  rewrite H0. rewrite Val.add_assoc. rewrite Val.add_permut. auto.
  rewrite H. rewrite Val.add_assoc. auto.
  rewrite H; rewrite H0. rewrite Int.add_assoc. repeat rewrite shift_symbol_address. auto.
  rewrite H0. rewrite shift_symbol_address. rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut.
  rewrite H. auto.
  rewrite H. rewrite shift_symbol_address. auto.
  rewrite H. rewrite shift_symbol_address. rewrite Int.mul_commut; auto.
  auto.
Qed.

Lemma make_addimm_correct:
  forall n r,
  let (op, args) := make_addimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.add rs#r (Vint n)) v.
Proof.
  intros. unfold make_addimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst. exists (rs#r); split; auto. destruct (rs#r); simpl; auto; rewrite Int.add_zero; auto.
  exists (Val.add rs#r (Vint n)); auto.
Qed.

Lemma make_shlimm_correct:
  forall n r1,
  let (op, args) := make_shlimm n r1 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shl rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_shlimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shl_zero. auto.
  econstructor; split. simpl. eauto. auto.
Qed.

Lemma make_shrimm_correct:
  forall n r1,
  let (op, args) := make_shrimm n r1 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shr rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_shrimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shr_zero. auto.
  econstructor; split; eauto. simpl. auto.
Qed.

Lemma make_shruimm_correct:
  forall n r1,
  let (op, args) := make_shruimm n r1 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shru rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_shruimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shru_zero. auto.
  econstructor; split; eauto. simpl. congruence.
Qed.

Lemma make_mulimm_correct:
  forall n r1,
  let (op, args) := make_mulimm n r1 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.mul rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_mulimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (Vint Int.zero); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.one; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_one; auto.
  destruct (Int.is_power2 n) eqn:?; intros.
  rewrite (Val.mul_pow2 rs#r1 _ _ Heqo). apply make_shlimm_correct; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_divimm_correct:
  forall n r1 r2 v,
  Val.divs rs#r1 rs#r2 = Some v ->
  rs#r2 = Vint n ->
  let (op, args) := make_divimm n r1 r2 in
  exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w.
Proof.
  intros; unfold make_divimm.
  destruct (Int.is_power2 n) eqn:?.
  destruct (Int.ltu i (Int.repr 31)) eqn:?.
  exists v; split; auto. simpl. eapply Val.divs_pow2; eauto. congruence.
  exists v; auto.
  exists v; auto.
Qed.

Lemma make_divuimm_correct:
  forall n r1 r2 v,
  Val.divu rs#r1 rs#r2 = Some v ->
  rs#r2 = Vint n ->
  let (op, args) := make_divuimm n r1 r2 in
  exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w.
Proof.
  intros; unfold make_divuimm.
  destruct (Int.is_power2 n) eqn:?.
  replace v with (Val.shru rs#r1 (Vint i)).
  eapply make_shruimm_correct; eauto.
  eapply Val.divu_pow2; eauto. congruence.
  exists v; auto.
Qed.

Lemma make_moduimm_correct:
  forall n r1 r2 v,
  Val.modu rs#r1 rs#r2 = Some v ->
  rs#r2 = Vint n ->
  let (op, args) := make_moduimm n r1 r2 in
  exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w.
Proof.
  intros; unfold make_moduimm.
  destruct (Int.is_power2 n) eqn:?.
  exists v; split; auto. simpl. decEq. eapply Val.modu_pow2; eauto. congruence.
  exists v; auto.
Qed.

Lemma make_andimm_correct:
  forall n r,
  let (op, args) := make_andimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.and rs#r (Vint n)) v.
Proof.
  intros; unfold make_andimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (Vint Int.zero); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.mone; intros.
  subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_mone; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_orimm_correct:
  forall n r,
  let (op, args) := make_orimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.or rs#r (Vint n)) v.
Proof.
  intros; unfold make_orimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.mone; intros.
  subst n. exists (Vint Int.mone); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_mone; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_xorimm_correct:
  forall n r,
  let (op, args) := make_xorimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.xor rs#r (Vint n)) v.
Proof.
  intros; unfold make_xorimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.xor_zero; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma op_strength_reduction_correct:
  forall op args vl v,
  vl = approx_regs app args ->
  eval_operation ge sp op rs##args m = Some v ->
  let (op', args') := op_strength_reduction op args vl in
  exists w, eval_operation ge sp op' rs##args' m = Some w /\ Val.lessdef v w.
Proof.
  intros until v; unfold op_strength_reduction;
  case (op_strength_reduction_match op args vl); simpl; intros.
(* sub *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. rewrite Val.sub_add_opp. apply make_addimm_correct; auto.
(* mul *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_mulimm_correct; auto.
(* divs *)
  assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto.
  apply make_divimm_correct; auto.
(* divu *)
  assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto.
  apply make_divuimm_correct; auto.
(* modu *)
  assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto.
  apply make_moduimm_correct; auto.
(* and *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_andimm_correct; auto.
(* or *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_orimm_correct; auto.
(* xor *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_xorimm_correct; auto.
(* shl *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_shlimm_correct; auto.
(* shr *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_shrimm_correct; auto.
(* shru *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_shruimm_correct; auto.
(* lea *)
  generalize (addr_strength_reduction_correct addr args0 vl0 H).
  destruct (addr_strength_reduction addr args0 vl0) as [addr' args'].
  intro EQ. exists v; split; auto. simpl. congruence.
(* cond *)
  generalize (cond_strength_reduction_correct c args0 vl0 H).
  destruct (cond_strength_reduction c args0 vl0) as [c' args']; intros.
  rewrite <- H1 in H0; auto. econstructor; split; eauto.
(* default *)
  exists v; auto.
Qed.

End STRENGTH_REDUCTION.

End ANALYSIS.