Require Import Recdef.
Require Import VST.floyd.proofauto.
Local Open Scope logic.
Require Import List. Import ListNotations.
Require Import sha.general_lemmas.
Require Import ZArith.
Local Open Scope Z.
Require Import tweetnacl20140427.Salsa20.
Require Import tweetnacl20140427.tweetNaclBase.
Require Export tweetnacl20140427.verif_salsa_base.

Require Import tweetnacl20140427.tweetnaclVerifiableC.
Require Import tweetnacl20140427.Snuffle.
Require Import VST.floyd.library.

Global Open Scope funspec_scope.

Definition CoreInSEP (data : SixteenByte * SixteenByte * (SixteenByte * SixteenByte))
                     (v: val * val * val) : mpred :=
  match data with (Nonce, C, K) =>
  match v with (n, c, k) =>
   ((SByte Nonce n) * (SByte C c) * (ThirtyTwoByte K k))%logic
  end end.

Definition prepare_data
           (data : SixteenByte * SixteenByte * (SixteenByte * SixteenByte)) :=
match data with ((Nonce, C), K) =>
  match Nonce with (N1, N2, N3, N4) =>
  match C with (C1, C2, C3, C4) =>
  match K with ((K1, K2, K3, K4), (L1, L2, L3, L4)) =>
      map littleendian [C1; K1; K2; K3; K4; C2; N1; N2; N3; N4; C3; L1; L2; L3; L4; C4]
  end end end
end.

Lemma prepare_data_length x: length (prepare_data x) = 16%nat.
Proof. destruct x as [[s0 s1] [s2 s3]]. simpl.
  destruct s0 as [[[? ?] ?] ?].
  destruct s1 as [[[? ?] ?] ?].
  destruct s2 as [[[? ?] ?] ?].
  destruct s3 as [[[? ?] ?] ?]. reflexivity.
Qed.

Definition sumlist := combinelist _ Int.add.

Definition sumlist_Some:= combinelist _ Int.add.

Definition sumlist_SomeInv:= combinelist_SomeInv _ Int.add.

Definition sumlist_length:= combinelist_length _ Int.add.

Definition sumlist_symm:= combinelist_symm _ Int.add Int.add_commut.

Definition sumlist_char_nth:= combinelist_char_nth _ Int.add.

Definition sumlist_char_Znth:= combinelist_char_Znth _ Int.add.

Definition Snuffle20 x := bind (Snuffle 20 x) (fun y => sumlist y x).

Lemma Snuffle20_length s l: Snuffle20 s = Some l -> length s = 16%nat -> length l = 16%nat.
Proof. unfold Snuffle20, bind; intros. remember (Snuffle 20 s).
  destruct o; simpl.
    symmetry in Heqo. symmetry in H; rewrite sumlist_symm in H.
      rewrite (sumlist_length _ _ _ H).
      apply (Snuffle_length _ _ _ Heqo H0). inv H.
Qed.

Definition fcore_result h data l :=
  match Snuffle20 (prepare_data data)
  with None => False
     | Some x =>
             if Int.eq (Int.repr h) Int.zero
             then l=QuadChunks2ValList (map littleendian_invert x)
             else match data with ((Nonce, C), K) =>
                    match Nonce with (N1, N2, N3, N4) =>
                    match C with (C1, C2, C3, C4) =>
                    l = QuadByte2ValList (littleendian_invert (Int.sub (Znth 0 x)  (littleendian C1))) ++
                    QuadByte2ValList (littleendian_invert (Int.sub (Znth 5 x)  (littleendian C2))) ++
                    QuadByte2ValList (littleendian_invert (Int.sub (Znth 10 x) (littleendian C3))) ++
                    QuadByte2ValList (littleendian_invert (Int.sub (Znth 15 x) (littleendian C4))) ++
                    QuadByte2ValList (littleendian_invert (Int.sub (Znth 6 x)  (littleendian N1))) ++
                    QuadByte2ValList (littleendian_invert (Int.sub (Znth 7 x)  (littleendian N2))) ++
                    QuadByte2ValList (littleendian_invert (Int.sub (Znth 8 x)  (littleendian N3))) ++
                    QuadByte2ValList (littleendian_invert (Int.sub (Znth 9 x)  (littleendian N4)))
                    end end end
  end.

Definition OutLen h := if Int.eq (Int.repr h) Int.zero then 64 else 32.

Definition fcorePOST_SEP h data d l out :=
  (CoreInSEP data d *
  data_at Tsh (tarray tuchar (OutLen h)) l out)%logic.

Definition f_core_POST d out h (data: SixteenByte * SixteenByte * (SixteenByte * SixteenByte) ) :=
EX l:_,
   PROP (fcore_result h data l)
   LOCAL ()
   SEP (fcorePOST_SEP h data d l out).

Definition core_spec :=
  DECLARE _core
   WITH c : val, k:val, h:Z,
        nonce:val, out:val, OUT:list val,
        data : SixteenByte * SixteenByte * (SixteenByte * SixteenByte)
   PRE [ tptr tuchar, tptr tuchar, tptr tuchar, tptr tuchar, tint ]
      PROP ()
      PARAMS (out; nonce; k; c; Vint (Int.repr h)) GLOBALS ()
      SEP (CoreInSEP data (nonce, c, k);
           data_at Tsh (tarray tuchar (OutLen h)) OUT out)
  POST [ tvoid ] (f_core_POST (nonce, c, k) out h data).

Definition ld32_spec :=
  DECLARE _ld32
   WITH x : val, B:QuadByte
   PRE [ tptr tuchar ]
      PROP ()
      PARAMS (x) GLOBALS ()
      SEP (data_at Tsh (tarray tuchar 4) (QuadByte2ValList B) x)
  POST [ tuint ]
     PROP ()
     LOCAL (temp ret_temp (Vint (littleendian B)))
     SEP (QByte B x).

Definition st32_spec :=
  DECLARE _st32
   WITH x : val, u:int
   PRE [ tptr tuchar, tuint ]
      PROP ()
      PARAMS (x; Vint u) GLOBALS ()
      SEP (data_at_ Tsh (tarray tuchar 4) x)
  POST [ tvoid ]
     PROP ()
     LOCAL ()
     SEP (QByte (littleendian_invert u) x).

Definition L32_spec :=
  DECLARE _L32
   WITH x : int, c: int
   PRE [ tuint, tint ]
      PROP (0 < Int.signed c < 32) (*yes, c=Int.zero needs to be ruled out - it leads to undefined behaviour in the shift-right operation*)
      PARAMS (Vint x; Vint c) GLOBALS ()
      SEP ()
  POST [ tuint ]
     PROP ()
     LOCAL (temp ret_temp (Vint (Int.rol x c)))
     SEP ().

Definition bigendian64 (b c:QuadByte): int64 :=
  match b, c with (b0, b1, b2, b3), (c0, c1, c2, c3) =>
  Int64.repr
   (       Byte.unsigned c3 +
    2^8  * Byte.unsigned c2 +
    2^16 * Byte.unsigned c1 +
    2^24 * Byte.unsigned c0 +
    2^32 * Byte.unsigned b3 +
    2^40 * Byte.unsigned b2 +
    2^48 * Byte.unsigned b1 +
    2^56 * Byte.unsigned b0
    )
  end.

Definition dl64_spec :=
  DECLARE _dl64
   WITH x : val, B:QuadByte, C: QuadByte
   PRE [ tptr tuchar ]
      PROP ()
      PARAMS (x) GLOBALS ()
      SEP (data_at Tsh (tarray tuchar 8) (QuadByte2ValList B++QuadByte2ValList C) x)
  POST [ tulong ]
     PROP ()
     LOCAL (temp ret_temp (Vlong (bigendian64 B C)))
     SEP (data_at Tsh (tarray tuchar 8) (QuadByte2ValList B++QuadByte2ValList C) x).

Definition bigendian64_invert (w:int64) : QuadByte * QuadByte:=
    let w3 := Int64.unsigned w in
  let b3 := w3 / (2^56) in
    let w2 := Z.modulo w3 (2^56) in
  let b2 := w2 / (2^48) in
    let w1 := Z.modulo w2 (2^48) in
  let b1 := w1 / (2^40) in
    let w0 := Z.modulo w1 (2^40) in
  let b0 := w0 / (2^32) in
    let u3 := Z.modulo w0 (2^32) in
  let c3 := u3 / (2^24) in
    let u2 := Z.modulo u3 (2^24) in
  let c2 := u2 / (2^16) in
    let u1 := Z.modulo u2 (2^16) in
  let c1 := u1 / (2^8) in
    let c0 := Z.modulo u1 (2^8) in
  ((Byte.repr b3, Byte.repr b2, Byte.repr b1, Byte.repr b0),
   (Byte.repr c3, Byte.repr c2, Byte.repr c1, Byte.repr c0)).

Lemma bigendian64_inv: forall b c: QuadByte, bigendian64_invert (bigendian64 b c) = (b,c).
Proof. destruct b as [[[b3 b2] b1] b0]. destruct c as [[[c3 c2] c1] c0].
  unfold bigendian64_invert, bigendian64.
  destruct (Byte.unsigned_range_2 b0). destruct (Byte.unsigned_range_2 b1).
  destruct (Byte.unsigned_range_2 b2). destruct (Byte.unsigned_range_2 b3).
  destruct (Byte.unsigned_range_2 c0). destruct (Byte.unsigned_range_2 c1).
  destruct (Byte.unsigned_range_2 c2). destruct (Byte.unsigned_range_2 c3).
  assert (2 ^ 8 * Byte.unsigned c1 <= 2 ^ 8 * Byte.max_unsigned).
               apply Zmult_le_compat_l; trivial; compute; congruence.
  assert (2 ^ 16 * Byte.unsigned c2 <= 2 ^ 16 * Byte.max_unsigned).
               apply Zmult_le_compat_l; trivial; compute; congruence.
  assert (2 ^ 24 * Byte.unsigned c3 <= 2 ^ 24 * Byte.max_unsigned).
               apply Zmult_le_compat_l; trivial; compute; congruence.
  assert (2 ^ 32 * Byte.unsigned b0 <= 2 ^ 32 * Byte.max_unsigned).
               apply Zmult_le_compat_l; trivial; compute; congruence.
  assert (2 ^ 40 * Byte.unsigned b1 <= 2 ^ 40 * Byte.max_unsigned).
               apply Zmult_le_compat_l; trivial; compute; congruence.
  assert (2 ^ 48 * Byte.unsigned b2 <= 2 ^ 48 * Byte.max_unsigned).
               apply Zmult_le_compat_l; trivial; compute; congruence.
  assert (2 ^ 56 * Byte.unsigned b3 <= 2 ^ 56 * Byte.max_unsigned).
               apply Zmult_le_compat_l; trivial; compute; congruence.
  assert (0 <= 2 ^ 8 * Byte.unsigned c1). apply Z.mul_nonneg_cancel_l; trivial; compute; congruence.
  assert (0 <= 2 ^ 16 * Byte.unsigned c2). apply Z.mul_nonneg_cancel_l; trivial; compute; congruence.
  assert (0 <= 2 ^ 24 * Byte.unsigned c3). apply Z.mul_nonneg_cancel_l; trivial; compute; congruence.
  assert (0 <= 2 ^ 32 * Byte.unsigned b0). apply Z.mul_nonneg_cancel_l; trivial; compute; congruence.
  assert (0 <= 2 ^ 40 * Byte.unsigned b1). apply Z.mul_nonneg_cancel_l; trivial; compute; congruence.
  assert (0 <= 2 ^ 48 * Byte.unsigned b2). apply Z.mul_nonneg_cancel_l; trivial; compute; congruence.
  assert (0 <= 2 ^ 56 * Byte.unsigned b3). apply Z.mul_nonneg_cancel_l; trivial; compute; congruence.
  rewrite Int64.unsigned_repr.
  2:{ split. clear H0 H2 H4 H6 H8 H10 H12 H14.
             apply OMEGA2; trivial.
             apply OMEGA2; trivial.
             apply OMEGA2; trivial.
             apply OMEGA2; trivial.
             apply OMEGA2; trivial.
             apply OMEGA2; trivial.
             apply OMEGA2; trivial.
            eapply Z.le_trans. apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; eassumption.
            unfold Int64.max_unsigned; simpl. lia.
  }
  assert (Arith1: 0 <= Byte.unsigned c0 + 2 ^ 8 * Byte.unsigned c1 + 2 ^ 16 * Byte.unsigned c2 +
          2 ^ 24 * Byte.unsigned c3 + 2 ^ 32 * Byte.unsigned b0 + 2 ^ 40 * Byte.unsigned b1 +
          2 ^ 48 * Byte.unsigned b2 < 2 ^ 56).
  {
              split. apply OMEGA2; trivial. apply OMEGA2; trivial. apply OMEGA2; trivial. apply OMEGA2; trivial. apply OMEGA2; trivial. apply OMEGA2; trivial.
              assert (Byte.unsigned c0 + 2 ^ 8 * Byte.unsigned c1 + 2 ^ 16 * Byte.unsigned c2
                      + 2 ^ 24 * Byte.unsigned c3 + 2 ^ 32 * Byte.unsigned b0
                      + 2 ^ 40 * Byte.unsigned b1 + 2 ^ 48 * Byte.unsigned b2 <= 2 ^ 56 -1). 2: lia.
              eapply Z.le_trans. apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption. apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption. apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption. simpl. lia. }
  erewrite <- (Zmod_unique _ (2^56) (Byte.unsigned b3) _ Arith1); [ | rewrite Z.add_comm; trivial].

  assert (Arith2: 0 <= Byte.unsigned c0 + 2 ^ 8 * Byte.unsigned c1 + 2 ^ 16 * Byte.unsigned c2 +
          2 ^ 24 * Byte.unsigned c3 + 2 ^ 32 * Byte.unsigned b0 + 2 ^ 40 * Byte.unsigned b1 < 2 ^ 48).
  {            split. apply OMEGA2; trivial. apply OMEGA2; trivial. apply OMEGA2; trivial. apply OMEGA2; trivial. apply OMEGA2; trivial.
              assert (Byte.unsigned c0 + 2 ^ 8 * Byte.unsigned c1 + 2 ^ 16 * Byte.unsigned c2
                      + 2 ^ 24 * Byte.unsigned c3 + 2 ^ 32 * Byte.unsigned b0
                      + 2 ^ 40 * Byte.unsigned b1 <= 2 ^ 48 -1). 2: lia.
              eapply Z.le_trans. apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption. apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption. apply Z.add_le_mono; try eassumption. simpl. lia. }
  erewrite <- (Zmod_unique _ (2^48) (Byte.unsigned b2) _ Arith2); [ | rewrite Z.add_comm; trivial].

  assert (Arith3: 0 <= Byte.unsigned c0 + 2 ^ 8 * Byte.unsigned c1 + 2 ^ 16 * Byte.unsigned c2 +
          2 ^ 24 * Byte.unsigned c3 + 2 ^ 32 * Byte.unsigned b0 < 2 ^ 40).
  {            split. apply OMEGA2; trivial. apply OMEGA2; trivial.  apply OMEGA2; trivial.  apply OMEGA2; trivial.
              assert (Byte.unsigned c0 + 2 ^ 8 * Byte.unsigned c1 + 2 ^ 16 * Byte.unsigned c2
                      + 2 ^ 24 * Byte.unsigned c3 + 2 ^ 32 * Byte.unsigned b0 <= 2 ^ 40 -1). 2: lia.
              eapply Z.le_trans. apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption. apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption. simpl. lia. }
  erewrite <- (Zmod_unique _ (2^40) (Byte.unsigned b1) _ Arith3); [ | rewrite Z.add_comm; trivial].

  assert (Arith4: 0 <= Byte.unsigned c0 + 2 ^ 8 * Byte.unsigned c1 + 2 ^ 16 * Byte.unsigned c2 +
          2 ^ 24 * Byte.unsigned c3 < 2 ^ 32).
  {            split. apply OMEGA2; trivial. apply OMEGA2; trivial. apply OMEGA2; trivial.
              assert (Byte.unsigned c0 + 2 ^ 8 * Byte.unsigned c1 + 2 ^ 16 * Byte.unsigned c2
                      + 2 ^ 24 * Byte.unsigned c3 <= 2 ^ 32 -1). 2: lia.
              eapply Z.le_trans. apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption. apply Z.add_le_mono; try eassumption. simpl. lia. }
  erewrite <- (Zmod_unique _ (2^32) (Byte.unsigned b0) _ Arith4); [ | rewrite Z.add_comm; trivial].

  assert (Arith5: 0 <= Byte.unsigned c0 + 2 ^ 8 * Byte.unsigned c1 + 2 ^ 16 * Byte.unsigned c2 < 2 ^ 24).
  {            split. apply OMEGA2; trivial. apply OMEGA2; trivial.
              assert (Byte.unsigned c0 + 2 ^ 8 * Byte.unsigned c1 + 2 ^ 16 * Byte.unsigned c2 <= 2 ^ 24 -1). 2: lia.
              eapply Z.le_trans. apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption. simpl. lia. }
  erewrite <- (Zmod_unique _ (2^24) (Byte.unsigned c3) _ Arith5); [ | rewrite Z.add_comm; trivial].

  assert (Arith6: 0 <= Byte.unsigned c0 + 2 ^ 8 * Byte.unsigned c1 < 2 ^ 16).
  {          split. apply OMEGA2; trivial.
              assert (Byte.unsigned c0 + 2 ^ 8 * Byte.unsigned c1 <= 2 ^ 16 -1). 2: lia.
              eapply Z.le_trans. apply Z.add_le_mono; try eassumption.
              simpl. lia. }
  erewrite <- (Zmod_unique _ (2^16) (Byte.unsigned c2) _ Arith6); [ | rewrite Z.add_comm; trivial].

  erewrite <- (Zmod_unique _ (2^8) (Byte.unsigned c1)).
     3: { rewrite Z.add_comm. reflexivity. }
     2: apply Byte.unsigned_range.

  erewrite <- (Zdiv_unique _ _ (Byte.unsigned b3)); [
       clear Arith1; rewrite Byte.repr_unsigned
     | apply Arith1
     | rewrite (*(Z.mul_comm (2^56)),*) Z.add_comm; reflexivity].

  erewrite <- (Zdiv_unique _ _ (Byte.unsigned b2)); [
       clear Arith2; rewrite Byte.repr_unsigned
     | apply Arith2
     | rewrite (*(Z.mul_comm (2^48)),*) Z.add_comm; reflexivity].

  erewrite <- (Zdiv_unique _ _ (Byte.unsigned b1)); [
       clear Arith3; rewrite Byte.repr_unsigned
     | apply Arith3
     | rewrite (*(Z.mul_comm (2^40)),*) Z.add_comm; reflexivity].

  erewrite <- (Zdiv_unique _ _ (Byte.unsigned b0)); [
       clear Arith4; rewrite Byte.repr_unsigned
     | apply Arith4
     | rewrite (*(Z.mul_comm (2^32)),*) Z.add_comm; reflexivity].

  erewrite <- (Zdiv_unique _ _ (Byte.unsigned c3)); [
       clear Arith5; rewrite Byte.repr_unsigned
     | apply Arith5
     | rewrite (*(Z.mul_comm (2^24)),*) Z.add_comm; reflexivity].

  erewrite <- (Zdiv_unique _ _ (Byte.unsigned c2)); [
       clear Arith6; rewrite Byte.repr_unsigned
     | apply Arith6
     | rewrite (*(Z.mul_comm (2^16)),*) Z.add_comm; reflexivity].

  erewrite <- (Zdiv_unique _ _ (Byte.unsigned c1)); [
       rewrite 2 Byte.repr_unsigned; trivial
     | apply Byte.unsigned_range
     | rewrite (*(Z.mul_comm (2^8)),*) Z.add_comm; reflexivity].
Qed.

Definition ts64_spec :=
  DECLARE _ts64
   WITH x : val, u:int64
   PRE [ tptr tuchar, tulong ]
      PROP ()
      PARAMS (x; Vlong u) GLOBALS ()
      SEP (data_at_ Tsh (tarray tuchar 8) x)
  POST [ tvoid ]
     PROP ()
     LOCAL ()
     SEP (let (B, C) := bigendian64_invert u in
          data_at Tsh (tarray tuchar 8) (QuadByte2ValList B++QuadByte2ValList C) x).

Definition crypto_core_salsa20_spec :=
  DECLARE _crypto_core_salsa20_tweet
   WITH c : val, k:val,
        nonce:val, out:val,
        data : SixteenByte * SixteenByte * (SixteenByte * SixteenByte)
   PRE [ tptr tuchar, tptr tuchar, tptr tuchar, tptr tuchar ]
      PROP ()
      PARAMS (out; nonce; k; c) GLOBALS ()
      SEP ( CoreInSEP data (nonce, c, k);
            data_at_ Tsh (tarray tuchar 64) out)
  POST [ tint ]
       EX res:_,
       PROP (Snuffle20 (prepare_data data) = Some res)
       LOCAL (temp ret_temp (Vint (Int.repr 0)))
       SEP (CoreInSEP data (nonce, c, k);
            data_at Tsh (tarray tuchar 64) (QuadChunks2ValList (map littleendian_invert res)) out).

Definition hSalsaOut x :=
           QuadByte2ValList (littleendian_invert (Znth 0  x)) ++
           QuadByte2ValList (littleendian_invert (Znth 5  x)) ++
           QuadByte2ValList (littleendian_invert (Znth 10 x)) ++
           QuadByte2ValList (littleendian_invert (Znth 15 x)) ++
           QuadByte2ValList (littleendian_invert (Znth 6  x)) ++
           QuadByte2ValList (littleendian_invert (Znth 7  x)) ++
           QuadByte2ValList (littleendian_invert (Znth 8  x)) ++
           QuadByte2ValList (littleendian_invert (Znth 9  x)).

Definition crypto_core_hsalsa20_spec :=
  DECLARE _crypto_core_hsalsa20_tweet
   WITH c : val, k:val,
        nonce:val, out:val, OUT: list val,
        data : SixteenByte * SixteenByte * (SixteenByte * SixteenByte)
   PRE [ tptr tuchar, tptr tuchar, tptr tuchar,tptr tuchar ]
      PROP ()
      PARAMS (out; nonce; k; c) GLOBALS ()
      SEP (CoreInSEP data (nonce, c, k);
           data_at Tsh (tarray tuchar 32) OUT out)
  POST [ tint ]
       EX res:list int,
       PROP (Snuffle 20 (prepare_data data) = Some res)
       LOCAL (temp ret_temp (Vint (Int.repr 0)))
       SEP (CoreInSEP data (nonce, c, k); data_at Tsh (tarray tuchar 32) (hSalsaOut res) out).

Parameter SIGMA: SixteenByte.
Definition Sigma_vector : val -> mpred :=
  data_at Tsh (tarray tuchar 16) (SixteenByte2ValList SIGMA).

Fixpoint ZZ (zbytes: list byte) (n: nat): int * list byte :=
  match n with
   O => (Int.one, zbytes)
  | S k => match ZZ zbytes k with (u,zb) =>
             let v := (Int.unsigned u + (Byte.unsigned (Znth (Z.of_nat k+8) zb)))
             in (Int.shru (Int.repr v) (Int.repr 8),
                 upd_Znth (Z.of_nat k+8) zb (Byte.repr (Z.modulo v 256))) end

  end.

Fixpoint ZCont (r: nat) (zcont: list byte): list byte :=
  match r with
     O => zcont
   | S n => let zb := ZCont n zcont in
            let zz := ZZ zb (8:nat) in snd zz
  end.

Lemma ZCont0 bytes: ZCont O bytes = bytes. reflexivity. Qed.
Lemma ZContS bytes n: ZCont (S n) bytes = snd (ZZ (ZCont n bytes) 8). reflexivity. Qed.

Definition bytes_at x q i mbytes :=
match x with
  Vint _ => repeat (Byte.zero) (Z.to_nat i)
| _ => sublist q (q+i) mbytes
end.

Lemma Zlength_bytes_at x q i mbytes : 0<=q -> 0 <= i ->
  q + i <= Zlength mbytes -> Zlength (bytes_at x q i mbytes) = i.
Proof. intros. destruct x; simpl; try rewrite Zlength_sublist; try lia.
  rewrite Zlength_repeat; lia.
Qed.

Definition bxorlist := combinelist _ Byte.xor.
Definition Bl2VL (l: list byte) := map Vint (map Int.repr (map Byte.unsigned l)).

Definition message_at (mCont: list byte) (m:val): mpred :=
  match m with
    Vint i => !!(i=Int.zero) && emp
  | Vptr b z => data_at Tsh (tarray tuchar (Zlength mCont)) (Bl2VL mCont) m
  | _ => FF
  end.

Inductive CONTENT SIGMA K (mInit:val) (mCont zbytes:list byte): nat -> list byte -> list byte -> Prop :=
  CONT_zero: CONTENT SIGMA K mInit mCont  zbytes O zbytes nil
| CONT_succ: forall n zN resN ,
             CONTENT SIGMA K mInit mCont zbytes n zN resN ->
             forall d,
             SixteenByte2ValList d = Bl2VL (ZCont n zbytes) ->
             forall snuff srbytes Xor,
             Snuffle20 (prepare_data (d, SIGMA, K)) = Some snuff ->
             QuadChunks2ValList (map littleendian_invert snuff) =
                map Vint (map Int.repr (map Byte.unsigned srbytes)) ->
             bxorlist (bytes_at mInit (Z.of_nat n * 64) 64 mCont) srbytes = Some Xor ->
             CONTENT SIGMA K mInit mCont zbytes (S n) (snd (ZZ zN (8:nat))) (resN++Xor).

Lemma CONT_Zlength SIGMA K mInit mCont zbytes:
  forall n zB x,
   CONTENT SIGMA K mInit mCont zbytes n zB x ->
   Zlength x = (Z.of_nat n * 64)%Z.
Proof.
  induction n; intros; inv H. reflexivity.
  rewrite Zlength_app. erewrite IHn. 2: eassumption.
  unfold bxorlist in H5.
  apply combinelist_Zlength in H5. destruct H5. rewrite H, <- H0; clear H H0.
  apply Snuffle20_length in H3.
  specialize (QuadChunk2ValList_ZLength(map littleendian_invert snuff)).
  rewrite H4; clear H4. repeat rewrite Zlength_map. intros H; rewrite H; clear H.
  rewrite Zlength_correct, H3; clear H3. simpl.
  rewrite Pos2Z.inj_mul, Zpos_P_of_succ_nat, <- Zmult_succ_l_reverse. trivial.
  apply prepare_data_length.
Qed.

Lemma CONTCONT SIGMA K mInit mCont zbytes:
  forall n zB x,
   CONTENT SIGMA K mInit mCont zbytes n zB x ->
   ZCont n zbytes = zB.
Proof.
  induction n; intros; inv H.
  apply ZCont0.
  rewrite ZContS. erewrite IHn. 2: eassumption. trivial.
Qed.

Lemma ZZ_Zlength: forall n zbytes u U, ZZ zbytes n = (u,U) ->
      Zlength zbytes=16 -> Z.of_nat n <= 8 -> Zlength U = 16.
Proof. induction n; simpl; intros.
+ inv H. trivial.
+ remember (ZZ zbytes n). destruct p. symmetry in Heqp. inv H.
  rewrite Zpos_P_of_succ_nat in H1.
  apply IHn in Heqp; trivial; clear IHn.
  rewrite upd_Znth_Zlength; trivial.
  lia.
  lia.
Qed.

Lemma Zlength_ZCont: forall n zbytes, Zlength zbytes = 16 -> Zlength (ZCont n zbytes) = 16.
Proof.
  induction n; intros. rewrite ZCont0. trivial.
  rewrite ZContS. specialize (ZZ_Zlength 8 (ZCont n zbytes)); intros.
  remember (ZZ (ZCont n zbytes) 8). destruct p; simpl.
  apply (H0 _ _ (eq_refl _ )).
  apply IHn; trivial. simpl; lia.
Qed.

Lemma SixteenByte2ValList_exists bytes: Zlength bytes = 16 ->
  exists d, SixteenByte2ValList d = map Vint (map Int.repr (map Byte.unsigned bytes)).
Proof. intros.
  apply listD16 in H.
  destruct H as [v0 [v1 [v2 [v3 [v4 [v5 [v6 [v7 [v8
        [v9 [v10 [v11 [v12 [v13 [v14 [v15 V]]]]]]]]]]]]]]]].
  subst; simpl.
  exists ((v0, v1, v2, v3), (v4, v5, v6, v7), (v8, v9, v10, v11), (v12, v13, v14, v15)).
  rewrite SixteenByte2ValList_char. reflexivity.
Qed.

Definition ContSpec bInit SIGMA K mInit mCont zbytes  srbytes :=
    let n:= (Int64.unsigned bInit) / 64 in
    if zeq ((Int64.unsigned bInit) mod 64) 0
    then exists zbytesR, CONTENT SIGMA K mInit mCont zbytes (Z.to_nat n) zbytesR srbytes
    else exists zN resN d snuff bytes lastbytes(*zbytes*),
         CONTENT SIGMA K mInit mCont zbytes (Z.to_nat n) zN resN /\
             SixteenByte2ValList d = Bl2VL (ZCont (Z.to_nat n) zbytes) /\
             Snuffle20 (prepare_data (d, SIGMA, K)) = Some snuff /\
             QuadChunks2ValList (map littleendian_invert snuff) =
                map Vint (map Int.repr (map Byte.unsigned bytes)) /\
             bxorlist (bytes_at mInit (n * 64) ((Int64.unsigned bInit) mod 64) mCont)
                                (sublist 0 ((Int64.unsigned bInit) mod 64) bytes) = Some lastbytes /\
             (*zbytesR = (snd (ZZ zN (8:nat)))/\*) srbytes = (resN++lastbytes).

(*TODO: refine non-zero-case of this spec, relating COUT to mCont and K and Nonce*)
Definition crypto_stream_xor_postsep b (Nonce:SixteenByte) K mCont cLen nonce c m :=
  ((if Int64.eq b Int64.zero
   then data_at_ Tsh (Tarray tuchar cLen noattr) c
   else (EX COUT:_, !!(exists zbytes, match Nonce with (Nnc0, Nnc1, _, _) =>
                SixteenByte2ValList
                  (Nnc0, Nnc1, (Byte.zero, Byte.zero, Byte.zero, Byte.zero),
                           (Byte.zero, Byte.zero, Byte.zero, Byte.zero)) =
                map Vint (map Int.repr (map Byte.unsigned zbytes))
                /\  ContSpec b SIGMA K m mCont zbytes COUT end)
           && data_at Tsh (Tarray tuchar cLen noattr) (Bl2VL COUT) c))
                    * SByte Nonce nonce
                    * message_at mCont m)%logic.

(*Precondition length mCont = Int64.unsigned b comes from textual spec in
  https://download.libsodium.org/doc/advanced/salsa20.html
  TODO: support the following part of the tetxual spec:
      m and c can point to the same address (in-place encryption/decryption).
     If they don't, the regions should not overlap.*)
Definition crypto_stream_salsa20_xor_spec :=
  DECLARE _crypto_stream_salsa20_tweet_xor
   WITH c : val, k:val, m:val, nonce:val, b:int64,
        Nonce : SixteenByte, K: SixteenByte * SixteenByte,
        mCont: list byte, gv: globals
   PRE [ tptr tuchar, tptr tuchar, tulong,
         tptr tuchar, tptr tuchar]
      PROP (Zlength mCont = Int64.unsigned b)
      PARAMS (c; m; Vlong b; nonce; k) GLOBALS (gv)
      SEP ( SByte Nonce nonce;
            data_at_ Tsh (Tarray tuchar (Int64.unsigned b) noattr) c;
            ThirtyTwoByte K k;
            Sigma_vector (gv _sigma);
            message_at mCont m
            (*data_at Tsh (tarray tuchar (Zlength mCont)) (Bl2VL mCont) m*))
  POST [ tint ]
       PROP ()
       LOCAL (temp ret_temp (Vint (Int.repr 0)))
       SEP (Sigma_vector (gv _sigma); ThirtyTwoByte K k;
            crypto_stream_xor_postsep b Nonce K mCont (Int64.unsigned b) nonce c m).

Definition f_crypto_stream_xsalsa20_tweet_xor_spec :=
  DECLARE _crypto_stream_salsa20_tweet_xor
   WITH c : val, k:val, nonce:val, m:val, d:int64, mCont: list byte,
        Nonce : SixteenByte, Nonce2 : SixteenByte, K: SixteenByte * SixteenByte,
        gv: globals
   PRE [ tptr tuchar, tptr tuchar, tulong, tptr tuchar, tptr tuchar]
      PROP (Zlength mCont = Int64.unsigned d)
      PARAMS (c; m; Vlong d; nonce; k) GLOBALS (gv)
      SEP ( SByte Nonce nonce; SByte Nonce2 (offset_val 16 nonce);
            data_at_ Tsh (Tarray tuchar (Int64.unsigned d) noattr) c;
            ThirtyTwoByte K k;
            message_at mCont m;
            Sigma_vector (gv _sigma)
            (*data_at Tsh (tarray tuchar (Zlength mCont)) (Bl2VL mCont) m*))
  POST [ tint ]
       PROP ()
       LOCAL (temp ret_temp (Vint (Int.repr 0)))
       SEP (Sigma_vector (gv _sigma);
            EX HSalsaRes:_, crypto_stream_xor_postsep d Nonce2 HSalsaRes
              mCont (Int64.unsigned d)
              (offset_val 16 nonce) c m;
            data_at Tsh (Tarray tuchar 16 noattr) (SixteenByte2ValList Nonce) nonce;
            ThirtyTwoByte K k).

Definition f_crypto_stream_xsalsa20_tweet_spec :=
  DECLARE _crypto_stream_xsalsa20_tweet
   WITH c : val, k:val, nonce:val, d:int64,
        Nonce : SixteenByte, Nonce2 : SixteenByte, K: SixteenByte * SixteenByte,
        gv: globals
   PRE [ tptr tuchar, tulong, tptr tuchar, tptr tuchar]
      PROP ()
      PARAMS (c; Vlong d; nonce; k) GLOBALS (gv)
      SEP ( SByte Nonce nonce; SByte Nonce2 (offset_val 16 nonce);
            data_at_ Tsh (Tarray tuchar (Int64.unsigned d) noattr) c;
            ThirtyTwoByte K k;
            Sigma_vector (gv _sigma)
            (*data_at Tsh (tarray tuchar (Zlength mCont)) (Bl2VL mCont) m*))
  POST [ tint ]
       PROP ()
       LOCAL (temp ret_temp (Vint (Int.repr 0)))
       SEP (Sigma_vector (gv _sigma);
            EX HSalsaRes:_, crypto_stream_xor_postsep d Nonce2 HSalsaRes
              (repeat Byte.zero (Z.to_nat (Int64.unsigned d))) (Int64.unsigned d)
              (offset_val 16 nonce) c nullval;
            data_at Tsh (Tarray tuchar 16 noattr) (SixteenByte2ValList Nonce) nonce;
            ThirtyTwoByte K k).
(*            crypto_stream_xor_postsep d Nonce K (repeat Byte.zero (Z.to_nat (Int64.unsigned d))) (Int64.unsigned d) nonce c k nullval). *)

(*TODO: support the following part of the tetxual spec:
      m and c can point to the same address (in-place encryption/decryption).
     If they don't, the regions should not overlap.*)
Definition f_crypto_stream_salsa20_tweet_spec :=
  DECLARE _crypto_stream_salsa20_tweet
   WITH c : val, k:val, nonce:val, d:int64,
        Nonce : SixteenByte, K: SixteenByte * SixteenByte,
        (*mCont: list byte, *) gv: globals
   PRE [ tptr tuchar, tulong, tptr tuchar, tptr tuchar]
      PROP ((*Zlength mCont = Int64.unsigned b*))
      PARAMS (c; Vlong d; nonce; k) GLOBALS (gv)
      SEP ( SByte Nonce nonce;
            data_at_ Tsh (Tarray tuchar (Int64.unsigned d) noattr) c;
            ThirtyTwoByte K k;
            Sigma_vector (gv _sigma)
            (*data_at Tsh (tarray tuchar (Zlength mCont)) (Bl2VL mCont) m*))
  POST [ tint ]
       PROP ()
       LOCAL (temp ret_temp (Vint (Int.repr 0)))
       SEP (Sigma_vector (gv _sigma);
            ThirtyTwoByte K k;
            crypto_stream_xor_postsep d Nonce K (repeat Byte.zero (Z.to_nat (Int64.unsigned d))) (Int64.unsigned d) nonce c nullval).

Definition vn_spec :=
  DECLARE _vn
  WITH x:val, y:val, n:Z, xsh: share, ysh: share, xcont:list byte, ycont:list byte
  PRE [ tptr tuchar, tptr tuchar, tint]
    PROP (readable_share xsh; readable_share ysh; 0<=n<= Int.max_unsigned)
    PARAMS (x; y; Vint (Int.repr n)) GLOBALS ()
    SEP (data_at xsh (Tarray tuchar n noattr) (map Vint (map Int.repr (map Byte.unsigned xcont))) x;
         data_at ysh (Tarray tuchar n noattr) (map Vint (map Int.repr (map Byte.unsigned ycont))) y)
  POST [tint]
    PROP ()
    LOCAL (temp ret_temp (Vint (Int.repr (if list_eq_dec Byte.eq_dec xcont ycont then 0 else -1))))
    SEP (data_at xsh (Tarray tuchar n noattr) (map Vint (map Int.repr (map Byte.unsigned xcont))) x;
         data_at ysh (Tarray tuchar n noattr) (map Vint (map Int.repr (map Byte.unsigned ycont))) y).

Definition verify16_spec :=
  DECLARE _crypto_verify_16_tweet
  WITH x:val, y:val, n:Z, xsh: share, ysh: share, xcont:list byte, ycont:list byte
  PRE [ tptr tuchar, tptr tuchar]
    PROP (readable_share xsh; readable_share ysh)
    PARAMS (x; y) GLOBALS ()
    SEP (data_at xsh (Tarray tuchar 16 noattr) (map Vint (map Int.repr (map Byte.unsigned xcont))) x;
         data_at ysh (Tarray tuchar 16 noattr) (map Vint (map Int.repr (map Byte.unsigned ycont))) y)
  POST [tint]
    PROP ()
    LOCAL (temp ret_temp (Vint (Int.repr (if list_eq_dec Byte.eq_dec xcont ycont then 0 else -1))))
    SEP (data_at xsh (Tarray tuchar 16 noattr) (map Vint (map Int.repr (map Byte.unsigned xcont))) x;
         data_at ysh (Tarray tuchar 16 noattr) (map Vint (map Int.repr (map Byte.unsigned ycont))) y).

Definition verify32_spec :=
  DECLARE _crypto_verify_32_tweet
  WITH x:val, y:val, n:Z, xsh: share, ysh: share, xcont:list byte, ycont:list byte
  PRE [tptr tuchar, tptr tuchar]
    PROP (readable_share xsh; readable_share ysh)
    PARAMS (x; y) GLOBALS ()
    SEP (data_at xsh (Tarray tuchar 32 noattr) (map Vint (map Int.repr (map Byte.unsigned xcont))) x;
         data_at ysh (Tarray tuchar 32 noattr) (map Vint (map Int.repr (map Byte.unsigned ycont))) y)
  POST [tint]
    PROP ()
    LOCAL (temp ret_temp (Vint (Int.repr (if list_eq_dec Byte.eq_dec xcont ycont then 0 else -1))))
    SEP (data_at xsh (Tarray tuchar 32 noattr) (map Vint (map Int.repr (map Byte.unsigned xcont))) x;
         data_at ysh (Tarray tuchar 32 noattr) (map Vint (map Int.repr (map Byte.unsigned ycont))) y).

Definition SalsaVarSpecs : varspecs := (_sigma, tarray tuchar 16)::nil.

Definition SalsaFunSpecs : funspecs :=
  ltac:(with_library prog (core_spec :: ld32_spec :: L32_spec::st32_spec::dl64_spec::ts64_spec::
                           crypto_core_salsa20_spec::crypto_core_hsalsa20_spec::
                           crypto_stream_salsa20_xor_spec::f_crypto_stream_salsa20_tweet_spec::
                           verify32_spec::verify16_spec::vn_spec::nil)).


Require Import Utf8.
Require Import FunctionalExtensionality.
Require Import Arith.
Require Import NArith.
Require Import ZArith.
Require Import Picinae_i386.
Require Import strncmp_i386.

Import X86Notations.
Open Scope N.

(* Use a flat memory model for these proofs. *)
Definition fh := htotal.

(* The x86 lifter models non-writable code. *)
Theorem strncmp_nwc: forall s2 s1, strncmp_i386 s1 = strncmp_i386 s2.
Proof. reflexivity. Qed.

(* Example #1: Type safety *)
Theorem strncmp_welltyped: welltyped_prog x86typctx strncmp_i386.
Proof.
  Picinae_typecheck.
Qed.

Definition ret_invs (esp0:N) (m0 m : addr -> N) (a:addr) (s:store) :=
  match a with
  |  0 => Some True
  |  4 => Some ((m Ⓓ[ esp0 mod 2 ^ 32 ]) = (m0 Ⓓ[ esp0 mod 2 ^ 32 ]))
  |  87 => Some ((m Ⓓ[ esp0 mod 2 ^ 32 ]) = (m0 Ⓓ[ esp0 mod 2 ^ 32 ]))
  |  116 => Some ((m Ⓓ[ esp0 mod 2 ^ 32 ]) = (m0 Ⓓ[ esp0 mod 2 ^ 32 ]))
  | _ => None
  end.

Definition ret_post (esp0:N) (m0 m : addr -> N) (_:exit) (s:store) :=
  (m Ⓓ[ esp0 mod 2 ^ 32 ]) = (m0 Ⓓ[ esp0 mod 2 ^ 32 ]).

Definition strncmp_ret_invset esp0 m0 m :=
  invs (ret_invs esp0 m0 m) (ret_post esp0 m0 m).

(* Strncmp does not modify the return address *)
Theorem strncmp_preserves_ret:
  forall s esp0 m0 m n s' s1 x'
  (MDL0: models x86typctx s)
  (MEM0: s V_MEM32 = Ⓜm0)
  (MEM1: s1 V_MEM32 = Ⓜm)
  (XP0: exec_prog fh strncmp_i386 0 s n s' x'),
  (m Ⓓ[ esp0 mod 2 ^ 32 ]) = (m0 Ⓓ[ esp0 mod 2 ^ 32 ]).
Proof.
  intros.
  (*
  eapply prove_invs. exact XP0.

  reflexivity.

  intros.
  assert (MDL: models x86typctx s0).
    eapply preservation_exec_prog. exact MDL0. apply strncmp_welltyped. exact XP.

  destruct_inv 32 PRE.

  Local Ltac step := time x86_step.

  all: repeat step.
  *)
Admitted.

(* Example #3: Architectural calling convention compliance *)
Theorem strncmp_preserves_readable:
  forall s n s' x,
  exec_prog fh strncmp_i386 0 s n s' x -> s' A_READ = s A_READ.
Proof.
  intros. eapply noassign_prog_same; [|eassumption].
  prove_noassign.
Qed.

(* strncmp restores ESP on exit *)
Definition esp_invs (esp0:N) (a:addr) (s:store) :=
  match a with
  | 0 => Some (s R_ESP = Ⓓ esp0 /\ 24 <= esp0)
  (* 0x40c00000: PUSH EBP *)
  (* 0x40c00001: PUSH EDI *)
  (* 0x40c00002: PUSH ESI *)
  (* 0x40c00003: PUSH EBX *)
  (* 0x40c00004: SUB ESP,0x8 *)
  | 7 => Some (s R_ESP = Ⓓ (esp0 ⊖ 24) /\ 24 <= esp0)

  | 73 => Some (s R_ESP = Ⓓ (esp0 ⊖ 24) /\ 24 <= esp0)

  | 134 => Some (s R_ESP = Ⓓ (esp0 ⊖ 24) /\ 24 <= esp0)
  (* 0x40c00086: ADD ESP,0x8 *)
  (* 0x40c0008b: POP EBX *)
  (* 0x40c0008c: POP ESI *)
  (* 0x40c0008d: POP EDI *)
  (* 0x40c0008e: POP EBP *)
  | 143 => Some (s R_ESP = Ⓓ (esp0 mod 2 ^ 32) /\ 24 <= esp0)
  (* 0x40c0008f: RET  *)

  | 144 => Some (s R_ESP = Ⓓ (esp0 ⊖ 24) /\ 24 <= esp0)
  (* 0x40c00090: ADD ESP,0x8 *)
  (* 0x40c00095: POP EBX *)
  (* 0x40c00096: POP ESI *)
  (* 0x40c00097: POP EDI *)
  (* 0x40c00098: POP EBP *)
  | 153 => Some (s R_ESP = Ⓓ (esp0 mod 2 ^ 32) /\ 24 <= esp0)
  (* 0x40c00099: RET  *)
  | _ => None
  end.

(* Next, we define the post-condition we wish to prove: *)
Definition esp_post (esp0:N) (_:exit) (s:store) := s R_ESP = Ⓓ (esp0 ⊕ 4).

(* The invariant set and post-condition are combined into a single invariant-set
   using the "invs" function. *)
Definition strncmp_esp_invset esp0 :=
  invs (esp_invs esp0) (esp_post esp0).

(* Asserts that this invariant-set is satisfied at all points *)
Theorem strncmp_preserves_esp:
  forall s esp0 mem n s' x'
         (MDL0: models x86typctx s)
         (ESP0: s R_ESP = Ⓓ esp0 /\ 24 <= esp0) (MEM0: s V_MEM32 = Ⓜ mem)
         (RET: strncmp_i386 s (mem Ⓓ[esp0 mod 2 ^ 32]) = None)
         (XP0: exec_prog fh strncmp_i386 0 s n s' x'),
  trueif_inv (strncmp_esp_invset esp0 strncmp_i386 x' s').
Proof.
  intros.
  eapply prove_invs. exact XP0.
  exact ESP0.

  intros.
  assert (MDL: models x86typctx s1).
    eapply preservation_exec_prog. exact MDL0. apply strncmp_welltyped. exact XP.
  rewrite (strncmp_nwc s1) in RET.

  destruct_inv 32 PRE.

  Local Ltac step := time x86_step.

  all: destruct PRE as [PRE PRE0]; repeat step.

  (* Address 7 *)
  split.
  repeat rewrite <- N.sub_add_distr.
  psimpl.
  rewrite N.add_comm.
  rewrite N.add_sub_swap.
  psimpl.
  reflexivity.

  apply PRE0.
  apply PRE0.

  (* Address 73 *)
  split. reflexivity. apply PRE0.
  split. reflexivity. apply PRE0.
  split. reflexivity. apply PRE0.
  split. reflexivity. apply PRE0.
  split. reflexivity. apply PRE0.

  (* Address 134 *)
  split. reflexivity. apply PRE0.
  split. reflexivity. apply PRE0.
  split. reflexivity. apply PRE0.
  split. reflexivity. apply PRE0.

  (* Address 143 *)
  split.
  rewrite <- N.add_sub_swap.
  psimpl.
  reflexivity.

  apply PRE0.
  apply PRE0.

  (* Post Condition *)
  apply nextinv_ret.
  rewrite (strncmp_nwc s1 _).
  rewrite (strncmp_preserves_ret s esp0 mem m n s' s1 x').
  apply RET.
  apply MDL0.
  apply MEM0.
  apply Hsv.
  apply XP0.
  unfold esp_post.
  reflexivity.

  (* Address 153 *)
  split.
  rewrite <- N.add_sub_swap.
  psimpl.
  reflexivity.

  apply PRE0.
  apply PRE0.

  (* Post Condition *)
  apply nextinv_ret.
  rewrite (strncmp_nwc s1 _).
  rewrite (strncmp_preserves_ret s esp0 mem m n s' s1 x').
  apply RET.
  apply MDL0.
  apply MEM0.
  apply Hsv.
  apply XP0.
  unfold esp_post.
  reflexivity.
Qed.


Require Import sflib.

Require Import Axioms.
Require Import Basic.
Require Import DataStructure.
Require Import Loc.
Require Import Language.

Require Import Coqlib.
Require Import Time.
Require Import Event.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.
Require Import MsgMapping.
Require Import DelaySet.
Require Import NPConfiguration.
Require Import NPBehavior.

(** * Whole Program Simulation *)

(** This file defines the whole program simulation (or global simulation) [glob_sim]
    between the target and source programs on the non-preemptive semantics *)

(** The theorem [glob_sim_implies_refinement] in this file
    shows that, if the whole target and source programs are simulated,
    they have refinement relation *)

(** The theorem [glob_sim_implies_refinement] in this file
    corresponds to the step 4 in Figure 6 (Our proof path) in our paper *)

CoInductive glob_sim_state: Ordering.LocOrdMap -> NPConfiguration.t -> NPConfiguration.t -> Prop :=
| glob_sim_state_intro
    lo npc_tgt npc_src
    (CUR_TID_EQ: (Configuration.tid (NPConfiguration.cfg npc_tgt)) = (Configuration.tid (NPConfiguration.cfg npc_src)))
    (TAU_STEP:
       forall npc_tgt'
              (TGT_TAU: NPConfiguration.step MachineEvent.silent lo npc_tgt npc_tgt'),
       exists npc_src',
         rtc (NPConfiguration.step MachineEvent.silent lo) npc_src npc_src' /\
         glob_sim_state lo npc_tgt' npc_src')
    (OUT_STEP:
       forall npc_tgt' e
              (TGT_OUT: NPConfiguration.step (MachineEvent.syscall e) lo npc_tgt npc_tgt'),
       exists npc_src' npc_src'',
         rtc (NPConfiguration.step MachineEvent.silent lo) npc_src npc_src' /\
         NPConfiguration.step (MachineEvent.syscall e) lo npc_src' npc_src'' /\
         glob_sim_state lo npc_tgt' npc_src'')
    (SW_STEP:
       forall npc_tgt'
              (TGT_SW: NPConfiguration.step MachineEvent.switch lo npc_tgt npc_tgt'),
       exists npc_src0 npc_src',
         rtc (NPConfiguration.step MachineEvent.silent lo) npc_src npc_src0 /\
         NPConfiguration.step MachineEvent.switch lo npc_src0 npc_src' /\
         glob_sim_state lo npc_tgt' npc_src')
    (DONE_STEP:
       forall
         (TGT_DONE: NPConfiguration.is_done npc_tgt),
       exists npc_src',
         rtc (NPConfiguration.step MachineEvent.silent lo) npc_src npc_src' /\
         NPConfiguration.is_done npc_src')
    (ABORT_STEP:
       forall
         (TGT_ABORT: NPConfiguration.is_abort npc_tgt lo),
       exists npc_src',
         rtc (NPConfiguration.step MachineEvent.silent lo) npc_src npc_src' /\
         NPConfiguration.is_abort npc_src' lo)
  :
    glob_sim_state lo npc_tgt npc_src.

(** ** Global Simulation for Whole Program Transition *)
Definition glob_sim (lang: language) (lo: Ordering.LocOrdMap) (fs: list Language.fid) (ctid: IdentMap.key)
       (code_t code_s: Language.syntax lang): Prop :=
  forall npc_tgt
         (TGT_INIT: NPConfiguration.init fs code_t ctid = Some npc_tgt),
  exists npc_src, NPConfiguration.init fs code_s ctid = Some npc_src /\
                  glob_sim_state lo npc_tgt npc_src.

(** ** Global simulation implies refinement proof *)
Lemma prefix_tau_np_behav_construct:
  forall n npc npc' lo n0 b
    (TAU_STEPS: rtcn (NPConfiguration.step MachineEvent.silent lo) n npc npc')
    (CONT_BEHAV: NPconf_behaviors npc' lo n0 b),
  exists n', NPconf_behaviors npc lo n' b.
Proof.
  induction n; intros.
  - inv TAU_STEPS. eauto.
  - inv TAU_STEPS.
    eapply IHn in A23; eauto.
    destruct A23.
    exists (S x). eapply behaviors_tau; eauto.
Qed.

Lemma sw_np_behav_construct:
  forall npc npc' lo b n
         (SW_STEP: NPConfiguration.step MachineEvent.switch lo npc npc')
         (CONT_BEHAV: NPconf_behaviors npc' lo n b),
    NPconf_behaviors npc lo (S n) b.
Proof.
  ii. econs; eauto.
Qed.

Lemma glob_sim_state_implies_refinement:
  forall n b
         (npc_tgt npc_src: NPConfiguration.t) (lo: Ordering.LocOrdMap)
         (TGT_BEHAV: NPconf_behaviors npc_tgt lo n b)
         (GLOB_SIM_STATE: glob_sim_state lo npc_tgt npc_src),
  exists n', NPconf_behaviors npc_src lo n' b.
Proof.
  induction n; intros.
  - inv TGT_BEHAV. exists 0%nat. econstructor; eauto.
  - inv GLOB_SIM_STATE.
    inv TGT_BEHAV.
    {
      (* abort *)
      clear TAU_STEP OUT_STEP SW_STEP DONE_STEP.
      eapply ABORT_STEP in IS_ABORT; eauto.
      clear - IS_ABORT.
      destruct IS_ABORT as (npc_src' & Htau_steps & His_abort).
      eapply rtc_rtcn in Htau_steps.
      destruct Htau_steps as (n & Htau_steps).
      eapply prefix_tau_np_behav_construct with (n0 := 1%nat); eauto.
      econstructor; eauto.
    }
    {
      (* done *)
      clear TAU_STEP OUT_STEP SW_STEP ABORT_STEP.
      eapply DONE_STEP in IS_DONE; eauto.
      clear - IS_DONE.
      destruct IS_DONE as (npc_src' & Htau_steps & His_done).
      eapply rtc_rtcn in Htau_steps.
      destruct Htau_steps as (n & Htau_steps).
      eapply prefix_tau_np_behav_construct with (n0 := 1%nat); eauto.
      econstructor; eauto.
    }
    {
      (* output *)
      clear TAU_STEP SW_STEP DONE_STEP ABORT_STEP.
      eapply OUT_STEP in STEP; eauto.
      destruct STEP as (npc_src' & npc_src'' & Htau_steps & Hout_step & Hglob_sim_state).
      eapply rtc_rtcn in Htau_steps.
      destruct Htau_steps as (n' & Htau_steps).
      eapply IHn in Hglob_sim_state; eauto.
      destruct Hglob_sim_state as (n'' & Hglob_sim_state).
      eapply prefix_tau_np_behav_construct with (n0 := S n'') (npc' := npc_src'); eauto.
      eapply behaviors_out; eauto.
    }
    {
      (* tau or switch *)
      destruct STEP as [Htau_step | Hsw_step].
      {
        (* tau *)
        clear OUT_STEP SW_STEP DONE_STEP ABORT_STEP.
        eapply TAU_STEP in Htau_step; eauto.
        destruct Htau_step as (npc_src' & Htau_steps & Hglob_sim_state).
        eapply rtc_rtcn in Htau_steps.
        destruct Htau_steps as (n' & Htau_steps).
        eapply IHn in Hglob_sim_state; eauto.
        destruct Hglob_sim_state as (n'' & Hcont_behav).
        eapply prefix_tau_np_behav_construct with (n0 := n'') (npc' := npc_src'); eauto.
      }
      {
        (* switch *)
        clear TAU_STEP OUT_STEP DONE_STEP ABORT_STEP.
        eapply SW_STEP in Hsw_step; eauto.
        destruct Hsw_step as (npc_src' & Hsw_step & Hglob_sim_state).
        des.
        eapply IHn in Hglob_sim_state1; eauto.
        destruct Hglob_sim_state1 as (n' & Hcont_behav).
        exploit sw_np_behav_construct; eauto. ii.
        eapply rtc_rtcn in Hglob_sim_state. des.
        eapply prefix_tau_np_behav_construct; eauto.
      }
    }
Qed.

(** ** Global simulation implies refinement *)
Theorem glob_sim_implies_refinement
        (lang: language) (fs: list Language.fid) (code_t code_s: Language.syntax lang) (ctid: IdentMap.key)
        (lo: Ordering.LocOrdMap) (b: list VisibleEvent.t)
        (GLOB_SIM: glob_sim lang lo fs ctid code_t code_s)
        (TGT_BEHAV: NPprog_behaviors fs code_t ctid lo b):
  NPprog_behaviors fs code_s ctid lo b.
Proof.
  intros.
  inv TGT_BEHAV.
  unfold glob_sim in *.
  destruct H as (npc_tgt & H_tgt_init & H_tgt_behav).
  eapply GLOB_SIM in H_tgt_init; eauto.
  destruct H_tgt_init as (npc_src & H_src_init & H_src_behav).
  unfold NPprog_behaviors.
  eapply glob_sim_state_implies_refinement in H_src_behav; eauto.
  destruct H_src_behav as (n' & H_src_behav).
  exists n', npc_src.
  split; eauto.
Qed.


Require Import Coq.Program.Basics.
Require Import Coq.Strings.String.
Require Import Setoid.
Require Import ZArith.
Require Import Psatz.
Require Import Coq.Program.Equality.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import seq ssreflect ssrbool ssrnat eqtype.

Require Import FinProof.All.
Require Import FinProof.CommonInstances.

Require Import UMLang.ExecGenerator.
Require Import UMLang.ExecGen.GenFlags.
Require Import UMLang.ExecGen.ExecGenDefs.
Require Import UMLang.All.

Require Import UrsusStdLib.Solidity.All.

Require Import UrsusTVM.Solidity.All.

Import UrsusNotations.
Local Open Scope ursus_scope.
Local Open Scope usolidity_scope.
Local Open Scope struct_scope.
Local Open Scope N_scope.
Local Open Scope string_scope.
Local Open Scope xlist_scope.

Require Import Logic.FunctionalExtensionality.
From QuickChick Require Import QuickChick.
Import QcDefaultNotation. Open Scope qc_scope.
Import GenLow GenHigh.
Set Warnings "-extraction-opaque-accessed,-extraction".

Require Import CommonQCEnvironment.
Require Import MTS.Props.
Require Import CommonForProps.

Require Import  SetcodeMultisig.

Definition MTS_1_propb l
        (dest :  address)
        (value :  uint128)
        (bounce :  boolean)
        (allBalance :  boolean)
        (payload :  cell_)
        (stateInit :  optional TvmCell)
        (mpk: uint256)
        (acc: bool)
        (pk: uint256)
        timestamp
        now: bool :=
let v0 := {$$ VMStateDefault with VMState_ι_msg_pubkey := mpk $$} in
let v1 := {$$ v0 with VMState_ι_accepted := acc $$} in
let v2 := {$$ v1 with VMState_ι_msg_pubkey := mpk $$} in
let v3 := {$$ v2 with VMState_ι_now := now $$} in
let v4 := {$$ v3 with VMState_ι_timestamp := timestamp $$} in

MTS_1 (quickFixState {$$
        {$$ LedgerDefault with Ledger_MainState := l $$}
                            with Ledger_VMState := v4 $$})
      dest value bounce allBalance payload stateInit ? .

(* OK *)
QuickCheck MTS_1_propb.

Definition MTS_2_propb l id
        (dest :  address)
        (value :  uint128)
        (bounce :  boolean)
        (allBalance :  boolean)
        (payload :  cell_)
        (stateInit :  optional TvmCell)
        (mpk: uint256)
        (acc: bool)
        (pk: uint256)
        timestamp
        now: bool :=
let v0 := {$$ VMStateDefault with VMState_ι_msg_pubkey := mpk $$} in
let v1 := {$$ v0 with VMState_ι_accepted := acc $$} in
let v2 := {$$ v1 with VMState_ι_msg_pubkey := mpk $$} in
let v3 := {$$ v2 with VMState_ι_now := now $$} in
let v4 := {$$ v3 with VMState_ι_timestamp := timestamp $$} in

MTS_2 (quickFixState {$$
        {$$ LedgerDefault with Ledger_MainState := l $$}
                            with Ledger_VMState := v4 $$})
      id dest value bounce allBalance payload stateInit ? .

(* OK *)
QuickCheck MTS_2_propb.

Definition MTS_3_propb l
        (dest :  address)
        (value :  uint128)
        (bounce :  boolean)
        (allBalance :  boolean)
        (payload :  cell_)
        (stateInit :  optional TvmCell)
        (mpk: uint256)
        (acc: bool)
        (pk: uint256)
        timestamp
        now: bool :=
let v0 := {$$ VMStateDefault with VMState_ι_msg_pubkey := mpk $$} in
let v1 := {$$ v0 with VMState_ι_accepted := acc $$} in
let v2 := {$$ v1 with VMState_ι_msg_pubkey := mpk $$} in
let v3 := {$$ v2 with VMState_ι_now := now $$} in
let v4 := {$$ v3 with VMState_ι_timestamp := timestamp $$} in

MTS_3 (quickFixState {$$
        {$$ LedgerDefault with Ledger_MainState := l $$}
                            with Ledger_VMState := v4 $$})
        dest value bounce allBalance payload stateInit ? .

(* OK *)
QuickCheck MTS_3_propb.

Definition MTS_4_propb l id
        (dest :  address)
        (value :  uint128)
        (bounce :  boolean)
        (allBalance :  boolean)
        (payload :  cell_)
        (stateInit :  optional TvmCell)
        (mpk: uint256)
        (acc: bool)
        (pk: uint256)
        timestamp
        now: bool :=
let v0 := {$$ VMStateDefault with VMState_ι_msg_pubkey := mpk $$} in
let v1 := {$$ v0 with VMState_ι_accepted := acc $$} in
let v2 := {$$ v1 with VMState_ι_msg_pubkey := mpk $$} in
let v3 := {$$ v2 with VMState_ι_now := now $$} in
let v4 := {$$ v3 with VMState_ι_timestamp := timestamp $$} in

MTS_4 (quickFixState {$$
        {$$ LedgerDefault with Ledger_MainState := l $$}
                            with Ledger_VMState := v4 $$})
        id dest value bounce allBalance payload stateInit ? .

(* OK *)
QuickCheck MTS_4_propb.

Definition MTS_5_propb l id
        (dest :  address)
        (value :  uint128)
        (bounce :  boolean)
        (allBalance :  boolean)
        (payload :  cell_)
        (stateInit :  optional TvmCell)
        (mpk: uint256)
        (acc: bool)
        (pk: uint256)
        timestamp
        now: bool :=
let v0 := {$$ VMStateDefault with VMState_ι_msg_pubkey := mpk $$} in
let v1 := {$$ v0 with VMState_ι_accepted := acc $$} in
let v2 := {$$ v1 with VMState_ι_msg_pubkey := mpk $$} in
let v3 := {$$ v2 with VMState_ι_now := now $$} in
let v4 := {$$ v3 with VMState_ι_timestamp := timestamp $$} in

MTS_5 (quickFixState {$$
        {$$ LedgerDefault with Ledger_MainState := l $$}
                            with Ledger_VMState := v4 $$})
        id dest value bounce allBalance payload stateInit ? .

(* OK *)
QuickCheck MTS_5_propb.

Definition MTS_6_3_propb l
                (dest :  address)
                (value :  uint128)
                (bounce :  boolean)
                (allBalance :  boolean)
                (payload :  cell_)
                (stateInit :  optional TvmCell)
                (mpk: uint256)
                (acc: bool)
                timestamp
        now: bool :=
let v0 := {$$ VMStateDefault with VMState_ι_msg_pubkey := mpk $$} in
let v1 := {$$ v0 with VMState_ι_accepted := acc $$} in
let v2 := {$$ v1 with VMState_ι_msg_pubkey := mpk $$} in
let v3 := {$$ v2 with VMState_ι_now := now $$} in
let v4 := {$$ v3 with VMState_ι_timestamp := timestamp $$} in
let custodians : XHMap uint256 uint8 := getPruvendoRecord _m_custodians l in
let custodians' := if hmapIsMember mpk custodians then custodians
else xHMapInsert mpk (Build_XUBInteger (length_ custodians)) custodians in

MTS_6_3 (quickFixState {$$
        {$$ LedgerDefault with Ledger_MainState :=
                {$$ l with  _m_custodians := custodians' $$}
        $$}with Ledger_VMState := v4 $$})
        dest value bounce allBalance payload stateInit  ? .

(* OK *)
QuickCheck MTS_6_3_propb.

Definition MTS_7_propb l
              (dest :  address)
              (value :  uint128)
              (bounce :  boolean)
              (allBalance :  boolean)
              (payload :  cell_)
              (stateInit :  optional TvmCell)
              (mpk: uint256)
              (acc: bool)
              timestamp
        now: bool :=
let v0 := {$$ VMStateDefault with VMState_ι_msg_pubkey := mpk $$} in
let v1 := {$$ v0 with VMState_ι_accepted := acc $$} in
let v2 := {$$ v1 with VMState_ι_msg_pubkey := mpk $$} in
let v3 := {$$ v2 with VMState_ι_now := now $$} in
let v4 := {$$ v3 with VMState_ι_timestamp := timestamp $$} in
MTS_7 (quickFixState {$$
        {$$ LedgerDefault with Ledger_MainState := l $$}
                            with Ledger_VMState := v4 $$})
        dest value bounce allBalance payload stateInit ? .

(* OK *)
QuickCheck MTS_7_propb.


Require Import String.
Require Import Functors.
Require Import MonadLib.
Require Import Names.
Require Import PNames.
Require Import EffPure.
Require Import EffExcept.
Require Import EffReader.
Require Import Bool.
Require Import Lambda.
Require Import Exception.
Require Import Lambda_Bool.
Require Import Lambda_Exception.
Require Import ESoundER.

Section Test_Section.

  Definition D := BType :+: LType.
  Definition E (A : Set) := Bool :+: Lambda D A :+: ExceptE D.

  Global Instance Fun_E : forall (A : Set),
    Functor (E A).
  Proof.
    eauto with typeclass_instances.
  Defined.

  Definition V := StuckValue :+: BoolValue :+: (ClosValue E).

  Variable MT : Set -> Set.
  Context `{Fail_MT : FailMonad MT}.
  Context {Inj_MT : InjMonad MT}.
  Context {Reasonable_MT : Reasonable_Monad MT}.
  Context {MT_eq_dec : forall (A : Set) (mta : MT A),
    {exists a, mta = return_ a} + {mta = fail}}.

  Variable ME : Set -> Set.
  Context `{Mon_ME : Environment ME (list (Value V))}.
  Context {Fail_ME : FailMonad ME}.
  Context {FailEnvM : FailEnvironmentMonad (Env (Value V)) ME}.
  Context {Exception_ME : Exception ME Datatypes.unit}.
  Context {Reasonable_ME : Reasonable_Monad ME}.

  Definition EQV_E (A B : Set) := (Bool_eqv E A B)
    ::+:: (Lambda_eqv D E A B) ::+:: (Exception_eqv D E A B).

  Definition WFV := (WFValue_VB D V (list (Names.DType D))) ::+::
    (WFValue_Clos D E MT V EQV_E _).

  Definition WFVM := (WFValueM_base D V MT ME _ WFV)
    ::+:: (WFValueM_Environment (TypContextCE := GammaTypContextCE _) D MT V ME _ WFV)
    ::+:: (WFValueM_Bot D V MT ME _)
    ::+:: (WFValueM_Except (TypContextCE := GammaTypContextCE _) D V MT ME _).

  Instance eval_alg : FAlgebra EvalName (Exp (E nat)) (evalMR V ME) (E nat).
  Proof.
    eauto 250 with typeclass_instances.
  Defined.

  Instance typeof_alg : forall T, FAlgebra TypeofName T (typeofR D MT) (E (DType D)).
  Proof.
    intros; eauto 150 with typeclass_instances.
  Defined.

  Instance eqv_soundness_X_alg eval_rec :
    iPAlgebra soundness_X'_Name
    (soundness_X'_P D V E MT ME _ EQV_E WFVM (fun e => typeof _ _ MT (proj1_sig e)) eval_rec
      (f_algebra (FAlgebra := typeof_alg _))
      (f_algebra (FAlgebra := eval_alg))) (EQV_E _ _).
  Proof.
    apply iPAlgebra_Plus.
    apply eqv_soundness_X'_Bool_eqv with (WFV := WFV) (TypContextCE := GammaTypContextCE _)
      (Fail_MT := Fail_MT) (monad := monad0) (Sub_BType_D := _)
      (Sub_StuckValue_V := _) (Sub_BoolValue_V := _)
      (eq_DType_DT := _); intros; eauto 550 with typeclass_instances.
    apply iPAlgebra_Plus.
    apply eqv_soundness_X'_Lambda_eqv with (WFV := WFV) (TypContextCE := GammaTypContextCE _)
      (Fail_MT := Fail_MT) (Environment_ME := Mon_ME) (Sub_LType_D := _)
      (Sub_StuckValue_V := _) (Sub_ClosValue_V := _)
      (eq_DType_DT := _); intros; eauto 550 with typeclass_instances.
    apply eqv_soundness_X'_Except_eqv with (TypContextCE := GammaTypContextCE _)
      (Fail_MT := Fail_MT) (Exception_ME := Exception_ME) (eq_DType_DT := _);
      intros; eauto 550 with typeclass_instances.
  Qed.

  Variable local_throw : forall (A : Set) f t,
    local f (throw t) = throw t (A := A).
  Variable local_catch : forall (A : Set) e h f,
    local f (catch (A := A) e h) = catch (local f e) (fun t => local f (h t)).

  Variable catch_fail : forall (A : Set) h,
    catch (A := A) fail h = fail.
  Context {fail_neq_throw : forall A,
    fail (M := ME) <> throw (A := A) tt}.

  Context {ME_eq_dec' : forall (A : Set) (mte : ME A) (gamma'' : list (Names.Value V)),
    (exists a : A,
      local (fun _ => gamma'') mte = return_ a) \/
    (local (fun _ => gamma'') mte = fail) \/
    (local (fun _ => gamma'') mte = throw tt)}.

    Context {throw_neq_fail : forall A t,
      throw (A := A) t <> fail (M := ME)}.

  Instance Except_Sound_X_WFVM :
    iPAlgebra Except_Sound_X_Name (Except_Sound_X_P D V MT ME WFV) WFVM.
  Proof.
    eauto 850 with typeclass_instances.
  Qed.

  Theorem eval_Sound :
    forall (n : nat) Sigma gamma gamma' gamma'' e' e'',
      E_eqvC E EQV_E gamma' gamma e'' e' ->
      forall (WF_gamma : forall n b, lookup gamma' n = Some b ->
        exists T, lookup gamma b = Some T)
      (WF_gamma'' : WF_Environment _ _ _ WFV Sigma gamma'' gamma)
      (WF_gamma2 : List.length gamma = List.length gamma')
      (WF_gamma' : forall n b, lookup gamma' n = Some b -> b = n)
      (WF_Sigma : Gamma _ Sigma = gamma) (T : DType D),
      typeof D (E (DType D)) MT (proj1_sig e') = return_ T ->
      (local (M := ME) (fun _ => gamma'') (bevalM V E ME n e'') = fail) \/
      (exists t, local (M := ME) (fun _ => gamma'') (bevalM V E ME n e'') = throw t) \/
        exists v : Value V,
          local (M := ME) (fun _ => gamma'') (bevalM V E ME n e'') =
          return_ (M := ME) v /\ WFValueC _ _ _ WFV Sigma v T.
  Proof.
    intros.
    apply Except_Sound_X with (EQV_E := EQV_E) (WFVM' := WFVM) (Mon_MT := monad)
      (Typeof_E := typeof_alg) (gamma := gamma) (gamma' := gamma') (e' := e');
      eauto 250 with typeclass_instances.
  Qed.

  Open Scope string_scope.

  Eval compute in ("Type Soundness for Bool + Lambda + Exception Proven!").

End Test_Section.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


Require Import
        FJ.Base
        FJ.Syntax
        FJ.Semantics.AuxiliarDefinitions
        FJ.Typing
        FJ.Tactics
        FJ.Typechecker.MethodTypechecker.
(*
Definition ClassOkDec : forall (n : nat) CT (C : ClassName), {{CD | ClassOk CT CD}}.
  refine (fun n CT C =>
            match MapsToDec C CT with
            | !! => ??
            | [|| CD ||] =>
              match fieldsDec n CT (cextends CD) with
              | !! => ??
              | [|| fs ||] =>
                match Forall2_partial (MethodOkDec n CT (cname CD)) (values (cmethods CD)) with
                | ?? => ??
                | Found _ mds _ => Found _ CD _
                end
              end
            end) ; simpl in *.
  eapply T_Class with (ms := cmethods CD) ; eauto.
*)


(******************************************************************************)
(** * C11 is weaker than IMM_S   *)
(******************************************************************************)

Require Import Classical Peano_dec.
From hahn Require Import Hahn.

Require Import Events.
Require Import Execution.
Require Import Execution_eco.
Require Import imm_bob imm_s_ppo.
Require Import imm_s_hb.
Require Import imm_s C11.

Set Implicit Arguments.
Remove Hints plus_n_O.

Section C11_TO_IMM_S.

Variable G : execution.

(******************************************************************************)
(** relations are contained in the corresponding ones **  *)
(******************************************************************************)

Lemma s_imm_consistentimplies_c11_consistent (WF: Wf G) sc
      (IPC : imm_s.imm_psc_consistent G sc) :
  c11_consistent G.
Proof using.
  cdes IPC. cdes IC. red. splits; auto.
Qed.

End C11_TO_IMM_S.


Require Import Coq.omega.Omega.
Require Import Platform.AutoSep Platform.Malloc Coq.Arith.Arith.
Require Import Platform.Cito.GeneralTactics.
Require Import Platform.Cito.MyMalloc.

Definition my_freeS : spec := SPEC("ptr") reserving 8
  PRE[V] Ex ls, array_with_size ls (V "ptr") * mallocHeap 0
  POST[_] mallocHeap 0.

Definition m := bimport[["malloc"!"free" @ [freeS] ]] bmodule "my_free" {{
  bfunction "free"("ptr", "len", "tmp") [my_freeS]
    "tmp" <- "ptr" - 4;;
    "len" <-* "tmp";;
    "len" <- "len" + 2;;
    "tmp" <- "ptr" - 8;;
    Call "malloc"!"free"(0, "tmp", "len")
    [PRE[_, _] mallocHeap 0
     POST[_] mallocHeap 0 ];;
    Return 0
  end
}}.

Set Printing Coercions.

Lemma wplus_ne : forall (a b c : W), a <> b -> a ^- c <> b ^- c.
  intros; destruct (weq (a ^- c) (b ^- c)); eauto.
Qed.

Lemma wminus_0_eq : forall (a b : W), a ^- b = natToW 0 -> a = b.
  intros.
  destruct (weq a b).
  eauto.
  contradict H.
  replace (natToW 0) with (b ^- b).
  eapply wplus_ne; eauto.
  words.
Qed.

Lemma wordToNat_natToW : forall n, goodSize n -> wordToNat (natToW n) = n.
  intros; eapply wordToNat_natToWord_idempotent; eauto.
Qed.

Lemma wminus_wplus : forall a b : W, a ^- b ^+ b = a.
  intros; words.
Qed.

Lemma plus_minus : forall a b, a + b - b = a.
  intros; intuition.
Qed.

Theorem ok : moduleOk m.
  vcgen; unfold array_with_size.
  sep_auto.
  sep_auto.
  sep_auto.
  sep_auto.
  Lemma buf_2_bwd : forall p len, (2 <= len)%nat -> p =?> 2 * (p ^+ $8) =?> (len - 2) ===> p =?> len.
    destruct len; simpl; intros; try omega.
    destruct len; simpl; intros; try omega.
    sepLemma; eapply allocated_shift_base; [ words | intuition ].
  Qed.
  Lemma consume_the_array : forall ls p, array ls p ===> p =?> length ls.
    intros; apply ptsto32m_allocated.
  Qed.
  Definition hints : TacPackage.
    prepare tt buf_2_bwd.
  Defined.
  Definition hints2 : TacPackage.
    prepare consume_the_array tt.
  Defined.
  post.
  evaluate auto_ext.
  descend.
  step hints.
  intro.
  eapply wminus_0_eq in H8.
  eauto.
  rewrite wordToNat_natToW.
  eauto.
  eauto.
  assert (2 <= wordToNat (natToW (Datatypes.length x2 + 2)))%nat.
  rewrite wordToNat_natToW.
  eauto.
  eauto.
  step hints.
  rewrite wminus_wplus.
  rewrite wordToNat_natToW.
  rewrite plus_minus.
  step hints2.
  eauto.
  step auto_ext.
  descend.
  step auto_ext.
  step auto_ext.
  step auto_ext.
  step auto_ext.
  step auto_ext.
  step auto_ext.
  step auto_ext.
  words.
  step auto_ext.
  sep_auto.
  sep_auto.
  sep_auto.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              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 the [RRE] pass. *)

Require Import Axioms.
Require Import Coqlib.
Require Import AST.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
Require Import Events.
Require Import Smallstep.
Require Import Op.
Require Import Locations.
Require Import Conventions.
Require Import Linear.
Require Import RRE.

Section WITHMEM.
Context `{Hcc: CompilerConfiguration}.

(** * Operations over equations *)

Lemma find_reg_containing_sound:
  forall s r eqs, find_reg_containing s eqs = Some r -> In (mkeq r s) eqs.
Proof.
  induction eqs; simpl; intros.
  congruence.
  destruct (slot_eq (e_slot a) s). inv H. left; destruct a; auto. right; eauto.
Qed.

Definition equations_hold (ls: locset) (eqs: equations) : Prop :=
  forall e, In e eqs -> ls (S (e_slot e)) = ls (R (e_reg e)).

Lemma nil_hold:
  forall ls, equations_hold ls nil.
Proof.
  red; intros; contradiction.
Qed.

Lemma In_kill_loc:
  forall e l eqs,
  In e (kill_loc l eqs) ->
  In e eqs /\ Loc.diff (S (e_slot e)) l /\ Loc.diff (R (e_reg e)) l.
Proof.
  induction eqs; simpl kill_loc; simpl In; intros.
  tauto.
  destruct (Loc.diff_dec (S (e_slot a)) l).
  destruct (Loc.diff_dec (R (e_reg a)) l).
  simpl in H.  intuition congruence.
  simpl in H.  intuition.
  simpl in H.  intuition.
Qed.

Lemma kill_loc_hold:
  forall ls eqs l v,
  equations_hold ls eqs ->
  equations_hold (Locmap.set l v ls) (kill_loc l eqs).
Proof.
  intros; red; intros.
  exploit In_kill_loc; eauto. intros [A [B C]].
  repeat rewrite Locmap.gso; auto; apply Loc.diff_sym; auto.
Qed.

Lemma In_kill_locs:
  forall e ll eqs,
  In e (kill_locs ll eqs) ->
  In e eqs /\ Loc.notin (S (e_slot e)) ll /\ Loc.notin (R (e_reg e)) ll.
Proof.
Opaque Loc.diff.
  induction ll; simpl; intros.
  tauto.
  exploit IHll; eauto. intros [A [B C]]. exploit In_kill_loc; eauto. intros [D [E F]].
  tauto.
Qed.

Lemma kill_locs_hold:
  forall ll ls eqs,
  equations_hold ls eqs ->
  equations_hold (Locmap.undef ll ls) (kill_locs ll eqs).
Proof.
  intros; red; intros. exploit In_kill_locs; eauto. intros [A [B C]].
  repeat rewrite Locmap.guo; auto.
Qed.

Lemma kill_temps_hold:
  forall ls eqs,
  equations_hold ls eqs ->
  equations_hold (LTL.undef_temps ls) (kill_temps eqs).
Proof.
  exact (kill_locs_hold temporaries).
Qed.

Lemma kill_at_move_hold:
  forall ls eqs,
  equations_hold ls eqs ->
  equations_hold (undef_setstack ls) (kill_at_move eqs).
Proof.
  exact (kill_locs_hold destroyed_at_move).
Qed.

Lemma kill_at_op_hold:
  forall op ls eqs,
  equations_hold ls eqs ->
  equations_hold (undef_op op ls) (kill_op op eqs).
Proof.
  intros op.
  destruct op; exact kill_temps_hold || exact kill_at_move_hold.
Qed.

Lemma eqs_getstack_hold:
  forall rs r s eqs,
  equations_hold rs eqs ->
  equations_hold (Locmap.set (R r) (rs (S s)) rs)
                 (mkeq r s :: kill_loc (R r) eqs).
Proof.
Transparent Loc.diff.
  intros; red; intros. simpl in H0; destruct H0.
  subst e. simpl. rewrite Locmap.gss; rewrite Locmap.gso; auto. red; auto.
  exploit In_kill_loc; eauto. intros [D [E F]].
  repeat rewrite Locmap.gso. auto.
  apply Loc.diff_sym; auto. apply Loc.diff_sym; auto.
Qed.

Lemma eqs_movestack_hold:
  forall rs r s eqs,
  equations_hold rs eqs ->
  equations_hold (Locmap.set (R r) (rs (S s)) (undef_setstack rs))
                 (kill_at_move (mkeq r s :: kill_loc (R r) eqs)).
Proof.
  unfold undef_setstack, kill_at_move; intros; red; intros.
  exploit In_kill_locs; eauto. intros [A [B C]].
  simpl in A; destruct A.
  subst e. rewrite Locmap.gss. rewrite Locmap.gso. apply Locmap.guo. auto.
  simpl; auto.
  exploit In_kill_loc; eauto. intros [D [E F]].
  repeat rewrite Locmap.gso. repeat rewrite Locmap.guo; auto.
  apply Loc.diff_sym; auto. apply Loc.diff_sym; auto.
Qed.

Lemma eqs_setstack_hold:
  forall rs r s eqs,
  equations_hold rs eqs ->
  equations_hold (Locmap.set (S s) (rs (R r)) (undef_setstack rs))
                 (kill_at_move (mkeq r s :: kill_loc (S s) eqs)).
Proof.
  unfold undef_setstack, kill_at_move; intros; red; intros.
  exploit In_kill_locs; eauto. intros [A [B C]].
  simpl in A; destruct A.
  subst e. rewrite Locmap.gss. rewrite Locmap.gso. rewrite Locmap.guo. auto.
  auto. simpl. destruct s; auto.
  exploit In_kill_loc; eauto. intros [D [E F]].
  repeat rewrite Locmap.gso. repeat rewrite Locmap.guo; auto.
  apply Loc.diff_sym; auto. apply Loc.diff_sym; auto.
Qed.

Lemma locmap_set_reg_same:
  forall rs r,
  Locmap.set (R r) (rs (R r)) rs = rs.
Proof.
  intros. apply extensionality; intros.
  destruct (Loc.eq x (R r)).
  subst x. apply Locmap.gss.
  apply Locmap.gso. apply Loc.diff_reg_right; auto.
Qed.

(** * Agreement between values of locations *)

(** Values of locations may differ between the original and transformed
  program: after a [Lgetstack] is optimized to a [Lop Omove],
  the values of [destroyed_at_move] temporaries differ.  This
  can only happen in parts of the code where the [safe_move_insertion]
  function returns [true].  *)

Definition agree (sm: bool) (rs rs': locset) : Prop :=
  forall l, sm = false \/ Loc.notin l destroyed_at_move -> rs' l = rs l.

Lemma agree_false:
  forall rs rs',
  agree false rs rs' <-> rs' = rs.
Proof.
  intros; split; intros.
  apply extensionality; intros. auto.
  subst rs'. red; auto.
Qed.

Lemma agree_slot:
  forall sm rs rs' s,
  agree sm rs rs' -> rs' (S s) = rs (S s).
Proof.
Transparent Loc.diff.
  intros. apply H. right. simpl; destruct s; tauto.
Qed.

Lemma agree_reg:
  forall sm rs rs' r,
  agree sm rs rs' ->
  sm = false \/ ~In r destroyed_at_move_regs -> rs' (R r) = rs (R r).
Proof.
  intros. apply H. destruct H0; auto. right.
  simpl in H0; simpl; intuition congruence.
Qed.

Lemma agree_regs:
  forall sm rs rs' rl,
  agree sm rs rs' ->
  sm = false \/ list_disjoint rl destroyed_at_move_regs -> reglist rs' rl = reglist rs rl.
Proof.
  induction rl; intros; simpl.
  auto.
  decEq. apply agree_reg with sm. auto.
    destruct H0. auto. right. eapply list_disjoint_notin; eauto with coqlib.
  apply IHrl; auto. destruct H0; auto. right. eapply list_disjoint_cons_left; eauto.
Qed.

Lemma agree_set:
  forall sm rs rs' l v,
  agree sm rs rs' ->
  agree sm (Locmap.set l v rs) (Locmap.set l v rs').
Proof.
  intros; red; intros.
  unfold Locmap.set.
  destruct (Loc.eq l l0). auto.
  destruct (Loc.overlap l l0). auto.
  apply H; auto.
Qed.

Lemma agree_undef_move_1:
  forall sm rs rs',
  agree sm rs rs' ->
  agree true rs (undef_setstack rs').
Proof.
  intros. unfold undef_setstack. red; intros.
  destruct H0. congruence. rewrite Locmap.guo; auto.
Qed.

Remark locmap_undef_equal:
  forall x ll rs rs',
  (forall l, Loc.notin l ll -> rs' l = rs l) ->
  Locmap.undef ll rs' x = Locmap.undef ll rs x.
Proof.
  induction ll; intros; simpl.
  apply H. simpl. auto.
  apply IHll. intros. unfold Locmap.set.
  destruct (Loc.eq a l). auto. destruct (Loc.overlap a l) eqn:?. auto.
  apply H. simpl. split; auto. apply Loc.diff_sym. apply Loc.non_overlap_diff; auto.
Qed.

Lemma agree_undef_move_2:
  forall sm rs rs',
  agree sm rs rs' ->
  agree false (undef_setstack rs) (undef_setstack rs').
Proof.
  intros. rewrite agree_false.
  apply extensionality; intros. unfold undef_setstack. apply locmap_undef_equal. auto.
Qed.

Lemma agree_undef_temps:
  forall sm rs rs',
  agree sm rs rs' ->
  agree false (LTL.undef_temps rs) (LTL.undef_temps rs').
Proof.
  intros. rewrite agree_false.
  apply extensionality; intros. unfold LTL.undef_temps. apply locmap_undef_equal.
  intros. apply H. right. simpl in H0; simpl; tauto.
Qed.

Lemma agree_undef_op:
  forall op sm rs rs',
  agree sm rs rs' ->
  agree false (undef_op op rs) (undef_op op rs').
Proof.
  intros op.
  destruct op; exact agree_undef_temps || exact agree_undef_move_2.
Qed.

Lemma transl_find_label:
  forall lbl c eqs,
  find_label lbl (transf_code eqs c) =
  option_map (transf_code nil) (find_label lbl c).
Proof.
  induction c; simpl; intros.
  auto.
  destruct a; simpl; auto.
  destruct (is_incoming s); simpl; auto.
  destruct (contains_equation s m eqs); auto.
  destruct (find_reg_containing s eqs); simpl; auto.
  destruct (safe_move_insertion c); simpl; auto.
  destruct (peq lbl l); simpl; auto.
Qed.

(** * Semantic preservation *)

Section PRESERVATION.

Variable prog: program.
Let tprog := transf_program prog.

Let ge := Genv.globalenv prog.
Let tge := Genv.globalenv tprog.

Lemma functions_translated:
  forall v f,
  Genv.find_funct ge v = Some f ->
  Genv.find_funct tge v = Some (transf_fundef f).
Proof (@Genv.find_funct_transf _ _ _ transf_fundef prog).

Lemma function_ptr_translated:
  forall v f,
  Genv.find_funct_ptr ge v = Some f ->
  Genv.find_funct_ptr tge v = Some (transf_fundef f).
Proof (@Genv.find_funct_ptr_transf _ _ _ transf_fundef prog).

Lemma symbols_preserved:
  forall id,
  Genv.find_symbol tge id = Genv.find_symbol ge id.
Proof (@Genv.find_symbol_transf _ _ _ transf_fundef prog).

Lemma varinfo_preserved:
  forall b, Genv.find_var_info tge b = Genv.find_var_info ge b.
Proof (@Genv.find_var_info_transf _ _ _ transf_fundef prog).

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

Lemma find_function_translated:
  forall ros rs fd,
  find_function ge ros rs = Some fd ->
  find_function tge ros rs = Some (transf_fundef fd).
Proof.
  intros. destruct ros; simpl in *.
  apply functions_translated; auto.
  rewrite symbols_preserved. destruct (Genv.find_symbol ge i).
  apply function_ptr_translated; auto.
  congruence.
Qed.

Inductive match_frames: stackframe -> stackframe -> Prop :=
  | match_frames_intro:
      forall f sp rs c,
      match_frames (Stackframe f sp rs c)
                   (Stackframe (transf_function f) sp rs (transf_code nil c)).

Inductive match_states: state -> state -> Prop :=
  | match_states_regular:
      forall sm stk f sp c rs m stk' rs' eqs
        (STK: list_forall2 match_frames stk stk')
        (EQH: equations_hold rs' eqs)
        (AG: agree sm rs rs')
        (SAFE: sm = false \/ safe_move_insertion c = true),
      match_states (State stk f sp c rs m)
                   (State stk' (transf_function f) sp (transf_code eqs c) rs' m)
  | match_states_call:
      forall stk f rs m stk'
        (STK: list_forall2 match_frames stk stk'),
      match_states (Callstate stk f rs m)
                   (Callstate stk' (transf_fundef f) rs m)
  | match_states_return:
      forall stk rs m stk'
        (STK: list_forall2 match_frames stk stk'),
      match_states (Returnstate stk rs m)
                   (Returnstate stk' rs m).

Definition measure (S: state) : nat :=
  match S with
  | State s f sp c rs m => List.length c
  | _ => 0%nat
  end.

Remark match_parent_locset:
  forall stk stk',
  list_forall2 match_frames stk stk' ->
  return_regs (parent_locset stk') = return_regs (parent_locset stk).
Proof.
  intros. inv H; auto. inv H0; auto.
Qed.

Theorem transf_step_correct:
  forall S1 t S2, step ge S1 t S2 ->
  forall S1' (MS: match_states S1 S1'),
  (exists S2', step tge S1' t S2' /\ match_states S2 S2')
  \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat.
Proof.
Opaque destroyed_at_move_regs.
  induction 1; intros; inv MS; simpl.
(** getstack *)
  simpl in SAFE.
  assert (SAFE': sm = false \/ ~In r destroyed_at_move_regs /\ safe_move_insertion b = true).
    destruct (in_dec mreg_eq r destroyed_at_move_regs); simpl in SAFE; intuition congruence.
  destruct (is_incoming sl) eqn:?.
  (* incoming, stays as getstack *)
  assert (UGS: forall rs, undef_getstack sl rs = Locmap.set (R IT1) Vundef rs).
    destruct sl; simpl in Heqb0; discriminate || auto.
  left; econstructor; split. constructor.
  repeat rewrite UGS.
  apply match_states_regular with sm. auto.
  apply kill_loc_hold. apply kill_loc_hold; auto.
  rewrite (agree_slot _ _ _ sl AG). apply agree_set. apply agree_set. auto.
  tauto.
  (* not incoming *)
  assert (UGS: forall rs, undef_getstack sl rs = rs).
    destruct sl; simpl in Heqb0; discriminate || auto.
  unfold contains_equation.
  destruct (in_dec eq_equation (mkeq r sl) eqs); simpl.
  (* eliminated *)
  right.  split. omega. split. auto. rewrite UGS.
  exploit EQH; eauto. simpl. intro EQ.
  assert (EQ1: rs' (S sl) = rs (S sl)) by (eapply agree_slot; eauto).
  assert (EQ2: rs' (R r) = rs (R r)) by (eapply agree_reg; eauto; tauto).
  rewrite <- EQ1; rewrite EQ; rewrite EQ2. rewrite locmap_set_reg_same.
  apply match_states_regular with sm; auto; tauto.
  (* found an equation *)
  destruct (find_reg_containing sl eqs) as [r'|] eqn:?.
  exploit EQH. eapply find_reg_containing_sound; eauto.
  simpl; intro EQ.
  (* turned into a move *)
  destruct (safe_move_insertion b) eqn:?.
  left; econstructor; split. constructor. simpl; eauto.
  rewrite UGS. rewrite <- EQ.
  apply match_states_regular with true; auto.
  apply eqs_movestack_hold; auto.
  rewrite (agree_slot _ _ _ sl AG). apply agree_set. eapply agree_undef_move_1; eauto.
  (* left as a getstack *)
  left; econstructor; split. constructor.
  repeat rewrite UGS.
  apply match_states_regular with sm. auto.
  apply eqs_getstack_hold; auto.
  rewrite (agree_slot _ _ _ sl AG). apply agree_set. auto.
  intuition congruence.
  (* no equation, left as a getstack *)
  left; econstructor; split. constructor.
  repeat rewrite UGS.
  apply match_states_regular with sm. auto.
  apply eqs_getstack_hold; auto.
  rewrite (agree_slot _ _ _ sl AG). apply agree_set. auto.
  tauto.

(* setstack *)
  left; econstructor; split. constructor.
  apply match_states_regular with false; auto.
  apply eqs_setstack_hold; auto.
  rewrite (agree_reg _ _ _ r AG). apply agree_set. eapply agree_undef_move_2; eauto.
  simpl in SAFE. destruct (in_dec mreg_eq r destroyed_at_move_regs); simpl in SAFE; intuition congruence.

(* op *)
  left; econstructor; split. constructor.
  instantiate (1 := v). rewrite <- H.
  rewrite (agree_regs _ _ _ args AG).
  apply eval_operation_preserved. exact symbols_preserved.
  simpl in SAFE. destruct (list_disjoint_dec mreg_eq args destroyed_at_move_regs); simpl in SAFE; intuition congruence.
  apply match_states_regular with false; auto.
  apply kill_loc_hold; apply kill_at_op_hold; auto.
  apply agree_set. eapply agree_undef_op; eauto.

(* load *)
  left; econstructor; split.
  econstructor.  instantiate (1 := a).  rewrite <- H.
  rewrite (agree_regs _ _ _ args AG).
  apply eval_addressing_preserved.  exact symbols_preserved.
  simpl in SAFE. destruct (list_disjoint_dec mreg_eq args destroyed_at_move_regs); simpl in SAFE; intuition congruence.
  eauto.
  apply match_states_regular with false; auto.
  apply kill_loc_hold; apply kill_temps_hold; auto.
  apply agree_set. eapply agree_undef_temps; eauto.

(* store *)
Opaque list_disjoint_dec.
  simpl in SAFE.
  assert (sm = false \/ ~In src destroyed_at_move_regs /\ list_disjoint args destroyed_at_move_regs).
    destruct SAFE. auto. right.
    destruct (list_disjoint_dec mreg_eq (src :: args) destroyed_at_move_regs); try discriminate.
    split. eapply list_disjoint_notin; eauto with coqlib. eapply list_disjoint_cons_left; eauto.
  left; econstructor; split.
  econstructor.  instantiate (1 := a).  rewrite <- H.
  rewrite (agree_regs _ _ _ args AG).
  apply eval_addressing_preserved.  exact symbols_preserved.
  tauto.
  rewrite (agree_reg _ _ _ src AG).
  eauto.
  tauto.
  apply match_states_regular with false; auto.
  apply kill_temps_hold; auto.
  eapply agree_undef_temps; eauto.

(* call *)
  simpl in SAFE. assert (sm = false) by intuition congruence.
  subst sm. rewrite agree_false in AG. subst rs'.
  left; econstructor; split.
  constructor. eapply find_function_translated; eauto.
  symmetry; apply sig_preserved.
  constructor. constructor; auto. constructor.

(* tailcall *)
  simpl in SAFE. assert (sm = false) by intuition congruence.
  subst sm. rewrite agree_false in AG. subst rs'.
  left; econstructor; split.
  constructor. eapply find_function_translated; eauto.
  symmetry; apply sig_preserved. eauto.
  rewrite (match_parent_locset _ _ STK). constructor; auto.

(* builtin *)
  left; econstructor; split.
  constructor.
  rewrite (agree_regs _ _ _ args AG).
  eapply external_call_symbols_preserved; eauto.
  exact symbols_preserved. exact varinfo_preserved.
  simpl in SAFE. destruct (list_disjoint_dec mreg_eq args destroyed_at_move_regs); simpl in SAFE; intuition congruence.
  apply match_states_regular with false; auto.
  apply kill_loc_hold; apply kill_temps_hold; auto.
  apply agree_set. eapply agree_undef_temps; eauto.

(* annot *)
  simpl in SAFE. assert (sm = false) by intuition congruence.
  subst sm. rewrite agree_false in AG. subst rs'.
  left; econstructor; split.
  econstructor. eapply external_call_symbols_preserved; eauto.
  exact symbols_preserved. exact varinfo_preserved.
  apply match_states_regular with false; auto.
  rewrite agree_false; auto.

(* label *)
  left; econstructor; split. constructor.
  apply match_states_regular with false; auto.
  apply nil_hold.
  simpl in SAFE. destruct SAFE. subst sm. auto. congruence.

(* goto *)
  generalize (transl_find_label lbl (fn_code f) nil).  rewrite H. simpl. intros.
  left; econstructor; split. constructor; eauto.
  apply match_states_regular with false; auto.
  apply nil_hold.
  simpl in SAFE. destruct SAFE. subst sm. auto. congruence.

(* cond true *)
  generalize (transl_find_label lbl (fn_code f) nil).  rewrite H0. simpl. intros.
  left; econstructor; split.
  apply exec_Lcond_true; auto.
  rewrite (agree_regs _ _ _ args AG). auto.
  simpl in SAFE. destruct (list_disjoint_dec mreg_eq args destroyed_at_move_regs); simpl in SAFE; intuition congruence.
  eauto.
  apply match_states_regular with false; auto.
  apply nil_hold.
  eapply agree_undef_temps; eauto.

(* cond false *)
  left; econstructor; split. apply exec_Lcond_false; auto.
  rewrite (agree_regs _ _ _ args AG). auto.
  simpl in SAFE. destruct (list_disjoint_dec mreg_eq args destroyed_at_move_regs); simpl in SAFE; intuition congruence.
  apply match_states_regular with false; auto.
  apply kill_temps_hold; auto.
  eapply agree_undef_temps; eauto.

(* jumptable *)
  generalize (transl_find_label lbl (fn_code f) nil).  rewrite H1. simpl. intros.
  left; econstructor; split. econstructor; eauto.
  rewrite (agree_reg _ _ _ arg AG). auto.
  simpl in SAFE. destruct (in_dec mreg_eq arg destroyed_at_move_regs); simpl in SAFE; intuition congruence.
  apply match_states_regular with false; auto.
  apply nil_hold.
  eapply agree_undef_temps; eauto.

(* return *)
  simpl in SAFE. destruct SAFE; try discriminate. subst sm. rewrite agree_false in AG. subst rs'.
  left; econstructor; split.
  constructor. simpl. eauto.
  rewrite (match_parent_locset _ _ STK).
  constructor; auto.

(* internal *)
  left; econstructor; split.
  constructor. simpl; eauto.
  simpl. apply match_states_regular with false; auto. apply nil_hold. rewrite agree_false; auto.

(* external *)
  left; econstructor; split.
  econstructor. eapply external_call_symbols_preserved; eauto.
  exact symbols_preserved. exact varinfo_preserved.
  auto. eauto.
  constructor; auto.

(* return *)
  inv STK. inv H1. left; econstructor; split. constructor.
  apply match_states_regular with false; auto.
  apply nil_hold.
  rewrite agree_false; auto.
Qed.

Lemma transf_initial_states:
  forall st1, initial_state prog st1 ->
  exists st2, initial_state tprog st2 /\ match_states st1 st2.
Proof.
  intros. inversion H.
  econstructor; split.
  econstructor.
  apply Genv.init_mem_transf; eauto.
  rewrite symbols_preserved. eauto.
  apply function_ptr_translated; eauto.
  rewrite sig_preserved. auto.
  econstructor; eauto. constructor.
Qed.

Lemma transf_final_states:
  forall st1 st2 r,
  match_states st1 st2 -> final_state st1 r -> final_state st2 r.
Proof.
  intros. inv H0. inv H. inv STK. econstructor. auto.
Qed.

Theorem transf_program_correct:
  forward_simulation (Linear.semantics prog) (Linear.semantics tprog).
Proof.
  eapply forward_simulation_opt.
  eexact symbols_preserved.
  eexact transf_initial_states.
  eexact transf_final_states.
  eexact transf_step_correct.
Qed.

End PRESERVATION.

End WITHMEM.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*         Xavier Leroy, Collège de France and 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.     *)
(*                                                                     *)
(* *********************************************************************)

Require Import Coqlib.
Require Import AST Integers Floats.
Require Import Values Memory Globalenvs.
Require Import Op RTL.
Require Import NeedDomain.

(** Neededness analysis for AArch64 operators *)

Definition needs_of_shift (s: shift) (a: amount32) (nv: nval) :=
  match s with
  | Slsl => shlimm nv a
  | Sasr => shrimm nv a
  | Slsr => shruimm nv a
  | Sror => ror nv a
  end.

Definition zero_ext' (s: Z) (nv: nval) :=
  if zle 0 s then zero_ext s nv else default nv.
Definition sign_ext' (s: Z) (nv: nval) :=
  if zlt 0 s then sign_ext s nv else default nv.

Definition op1 (nv: nval) := nv :: nil.
Definition op2 (nv: nval) := nv :: nv :: nil.
Definition op1shift (s: shift) (a: amount32) (nv: nval) :=
  needs_of_shift s a nv :: nil.
Definition op2shift (s: shift) (a: amount32) (nv: nval) :=
  nv :: needs_of_shift s a nv :: nil.

Definition needs_of_condition (cond: condition): list nval := nil.

Definition needs_of_operation (op: operation) (nv: nval): list nval :=
  match op with
  | Omove => nv :: nil
  | Ointconst _ => nil
  | Olongconst _ => nil
  | Ofloatconst _ => nil
  | Osingleconst _ => nil
  | Oaddrsymbol _ _ => nil
  | Oaddrstack _ => nil
  | Oshift s a => op1shift s a nv
  | Oadd | Osub | Omul => op2 (modarith nv)
  | Oaddshift s a | Osubshift s a => op2shift s a (modarith nv)
  | Oaddimm _ => op1 (modarith nv)
  | Oneg => op1 (modarith nv)
  | Onegshift s a => op1shift s a (modarith nv)
  | Omuladd | Omulsub =>
      let n := modarith nv in n :: n :: n :: nil
  | Odiv | Odivu => op2 (default nv)
  | Oand | Oor | Oxor => op2 (bitwise nv)
  | Oandshift s a | Oorshift s a | Oxorshift s a =>  op2shift s a (bitwise nv)
  | Oandimm  n => op1 (andimm nv n)
  | Oorimm n => op1 (orimm nv n)
  | Oxorimm n => op1 (bitwise nv)
  | Onot => op1 (bitwise nv)
  | Onotshift s a => needs_of_shift s a (bitwise nv) :: nil
  | Obic | Oorn | Oeqv =>
      let n := bitwise nv in n :: bitwise n :: nil
  | Obicshift s a | Oornshift s a | Oeqvshift s a =>
      let n := bitwise nv in n :: needs_of_shift s a (bitwise n) :: nil
  | Oshl | Oshr | Oshru => op2 (default nv)
  | Oshrximm _ => op1 (default nv)
  | Ozext s => op1 (zero_ext' s nv)
  | Osext s => op1 (sign_ext' s nv)
  | Oshlzext s a => op1 (zero_ext' s (shlimm nv a))
  | Oshlsext s a => op1 (sign_ext' s (shlimm nv a))
  | Ozextshr a s => op1 (shruimm (zero_ext' s nv) a)
  | Osextshr a s => op1 (shrimm (sign_ext' s nv) a)

  | Oshiftl _ _ | Oextend _ _ => op1 (default nv)
  | Omakelong  | Olowlong  | Ohighlong => op1 (default nv)
  | Oaddl | Osubl | Omull => op2 (default nv)
  | Oaddlshift _ _ | Oaddlext _ _ | Osublshift _ _ | Osublext _ _ => op2 (default nv)
  | Oaddlimm _ => op1 (default nv)
  | Onegl => op1 (default nv)
  | Oneglshift _ _ => op1 (default nv)
  | Omulladd | Omullsub => let n := default nv in n :: n :: n :: nil
  | Omullhs | Omullhu | Odivl | Odivlu => op2 (default nv)
  | Oandl | Oorl | Oxorl | Obicl | Oornl | Oeqvl => op2 (default nv)
  | Oandlshift _ _ | Oorlshift _ _  | Oxorlshift _ _
  | Obiclshift _ _ | Oornlshift _ _ | Oeqvlshift _ _ => op2 (default nv)
  | Oandlimm _ | Oorlimm _ | Oxorlimm _ => op1 (default nv)
  | Onotl => op1 (default nv)
  | Onotlshift _ _ => op1 (default nv)
  | Oshll | Oshrl | Oshrlu => op2 (default nv)
  | Oshrlximm _ => op1 (default nv)
  | Ozextl _ | Osextl _
  | Oshllzext _ _ | Oshllsext _ _ | Ozextshrl _ _ | Osextshrl _ _ => op1 (default nv)
  | Onegf | Oabsf => op1 (default nv)
  | Oaddf | Osubf | Omulf | Odivf => op2 (default nv)
  | Onegfs | Oabsfs => op1 (default nv)
  | Oaddfs | Osubfs | Omulfs | Odivfs => op2 (default nv)
  | Ofloatofsingle | Osingleoffloat => op1 (default nv)
  | Ointoffloat | Ointuoffloat | Ofloatofint | Ofloatofintu => op1 (default nv)
  | Olongoffloat | Olonguoffloat | Ofloatoflong | Ofloatoflongu => op1 (default nv)
  | Ointofsingle | Ointuofsingle | Osingleofint | Osingleofintu => op1 (default nv)
  | Olongofsingle | Olonguofsingle | Osingleoflong | Osingleoflongu => op1 (default nv)
  | Ocmp c => needs_of_condition c
  | Osel c ty => nv :: nv :: needs_of_condition c
  end.

Definition operation_is_redundant (op: operation) (nv: nval): bool :=
  match op with
  | Ozext s => zle 0 s && zero_ext_redundant s nv
  | Osext s => zlt 0 s && sign_ext_redundant s nv
  | Oandimm n => andimm_redundant nv n
  | Oorimm n => orimm_redundant nv n
  | _ => false
  end.

Ltac InvAgree :=
  match goal with
  | [H: vagree_list nil _ _ |- _ ] => inv H; InvAgree
  | [H: vagree_list (_::_) _ _ |- _ ] => inv H; InvAgree
  | _ => idtac
  end.

Ltac TrivialExists :=
  match goal with
  | [ |- exists v, Some ?x = Some v /\ _ ] => exists x; split; auto
  | _ => idtac
  end.

Lemma shift_sound:
  forall v w s a x,
  vagree v w (needs_of_shift s a x) ->
  vagree (eval_shift s v a) (eval_shift s w a) x.
Proof.
  intros until x; destruct s; simpl; intros.
- apply shlimm_sound; auto.
- apply shruimm_sound; auto.
- apply shrimm_sound; auto.
- apply ror_sound; auto.
Qed.

Lemma zero_ext'_sound:
  forall v w x n,
  vagree v w (zero_ext' n x) ->
  vagree (Val.zero_ext n v) (Val.zero_ext n w) x.
Proof.
  unfold zero_ext'; intros. destruct (zle 0 n).
- apply zero_ext_sound; auto.
- assert (E: x = Nothing \/ Val.lessdef v w) by (destruct x; auto).
  destruct E. subst x; simpl; auto. apply vagree_lessdef; apply Val.zero_ext_lessdef; auto.
Qed.

Lemma sign_ext'_sound:
  forall v w x n,
  vagree v w (sign_ext' n x) ->
  vagree (Val.sign_ext n v) (Val.sign_ext n w) x.
Proof.
  unfold sign_ext'; intros. destruct (zlt 0 n).
- apply sign_ext_sound; auto.
- assert (E: x = Nothing \/ Val.lessdef v w) by (destruct x; auto).
  destruct E. subst x; simpl; auto. apply vagree_lessdef; apply Val.sign_ext_lessdef; auto.
Qed.

Section SOUNDNESS.

Variable ge: genv.
Variable sp: block.
Variables m m': mem.
Hypothesis PERM: forall b ofs k p, Mem.perm m b ofs k p -> Mem.perm m' b ofs k p.

Lemma needs_of_condition_sound:
  forall cond args b args',
  eval_condition cond args m = Some b ->
  vagree_list args args' (needs_of_condition cond) ->
  eval_condition cond args' m' = Some b.
Proof.
  intros. unfold needs_of_condition in H0.
  eapply default_needs_of_condition_sound; eauto.
Qed.

Lemma needs_of_operation_sound:
  forall op args v nv args',
  eval_operation ge (Vptr sp Ptrofs.zero) op args m = Some v ->
  vagree_list args args' (needs_of_operation op nv) ->
  nv <> Nothing ->
  exists v',
     eval_operation ge (Vptr sp Ptrofs.zero) op args' m' = Some v'
  /\ vagree v v' nv.
Proof.
  unfold needs_of_operation; intros; destruct op; try (eapply default_needs_of_operation_sound; eauto; fail);
  simpl in *; FuncInv; InvAgree; TrivialExists.
- apply shift_sound; auto.
- apply add_sound; auto.
- apply add_sound; auto using shift_sound.
- apply add_sound; auto with na.
- apply neg_sound; auto.
- apply neg_sound; auto using shift_sound.
- apply sub_sound; auto.
- apply sub_sound; auto using shift_sound.
- apply mul_sound; auto.
- apply add_sound; auto. apply mul_sound; rewrite modarith_idem; auto.
- apply sub_sound; auto. apply mul_sound; rewrite modarith_idem; auto.
- apply and_sound; auto.
- apply and_sound; auto using shift_sound.
- apply andimm_sound; auto.
- apply or_sound; auto.
- apply or_sound; auto using shift_sound.
- apply orimm_sound; auto.
- apply xor_sound; auto.
- apply xor_sound; auto using shift_sound.
- apply xor_sound; auto with na.
- apply notint_sound; auto.
- apply notint_sound; auto using shift_sound.
- apply and_sound; auto. apply notint_sound; rewrite bitwise_idem; auto.
- apply and_sound; auto. apply notint_sound; rewrite bitwise_idem; auto using shift_sound.
- apply or_sound; auto. apply notint_sound; rewrite bitwise_idem; auto.
- apply or_sound; auto. apply notint_sound; rewrite bitwise_idem; auto using shift_sound.
- apply xor_sound; auto. apply notint_sound; rewrite bitwise_idem; auto.
- apply xor_sound; auto. apply notint_sound; rewrite bitwise_idem; auto using shift_sound.
- apply zero_ext'_sound; auto.
- apply sign_ext'_sound; auto.
- apply shlimm_sound; apply zero_ext'_sound; auto.
- apply shlimm_sound; apply sign_ext'_sound; auto.
- apply zero_ext'_sound; apply shruimm_sound; auto.
- apply sign_ext'_sound; apply shrimm_sound; auto.
- destruct (eval_condition cond args m) as [b|] eqn:EC.
  erewrite needs_of_condition_sound by eauto.
  apply select_sound; auto.
  simpl; auto with na.
Qed.

Lemma operation_is_redundant_sound:
  forall op nv arg1 args v arg1' args',
  operation_is_redundant op nv = true ->
  eval_operation ge (Vptr sp Ptrofs.zero) op (arg1 :: args) m = Some v ->
  vagree_list (arg1 :: args) (arg1' :: args') (needs_of_operation op nv) ->
  vagree v arg1' nv.
Proof.
  intros. destruct op; simpl in *; try discriminate; inv H1; FuncInv; subst.
- apply andimm_redundant_sound; auto.
- apply orimm_redundant_sound; auto.
- InvBooleans. unfold zero_ext' in H5; rewrite zle_true in H5 by auto.
  apply zero_ext_redundant_sound; auto.
- InvBooleans. unfold sign_ext' in H5; rewrite zlt_true in H5 by auto.
  apply sign_ext_redundant_sound; auto.
Qed.

End SOUNDNESS.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall Qprime Cprime P Q Aprime C A : Universe, ((wd_ Qprime Cprime /\ (wd_ Cprime P /\ (wd_ P Q /\ (wd_ Qprime Q /\ (wd_ Qprime P /\ (wd_ Cprime Q /\ (wd_ Aprime P /\ (wd_ Q Aprime /\ (wd_ Aprime A /\ (wd_ Cprime C /\ (wd_ P A /\ (wd_ P C /\ (wd_ C A /\ (wd_ Cprime Aprime /\ (col_ P Q C /\ (col_ Aprime P A /\ col_ Cprime P C)))))))))))))))) -> col_ Q Cprime P)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall P Q A B C Aprime Cprime T : Universe, ((wd_ P Q /\ (wd_ P Aprime /\ (wd_ P B /\ (wd_ P Cprime /\ (wd_ A Aprime /\ (wd_ A C /\ (wd_ A B /\ (wd_ C Cprime /\ (wd_ Aprime Cprime /\ (wd_ T B /\ (wd_ Q A /\ (wd_ P A /\ (wd_ T P /\ (wd_ C P /\ (wd_ Q T /\ (col_ P Q Aprime /\ (col_ P Q B /\ (col_ P Q Cprime /\ (col_ T C Cprime /\ (col_ B C Cprime /\ (col_ P Q C /\ col_ A B C))))))))))))))))))))) -> col_ C Cprime P)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

(***********************************************************************
    Proof of Bertrand's conjecture: Factorial.v
                                         Laurent.Thery@inria.fr (2002)
  *********************************************************************)

From Coq Require Import Arith.

(**  	Factorial*)

Fixpoint factorial (n : nat) : nat :=
  match n with
  | O => 1
  | S n' => n * factorial n'
  end.

Theorem lt_factorial_O : forall n : nat, 0 < factorial n.
Proof.
intros n; elim n; simpl in |- *; auto with arith.
Qed.
#[export] Hint Resolve lt_factorial_O: arith.


(** * Morphisms for predicates over observations. *)
Require Import Ssreflect.ssreflect Ssreflect.ssrfun Ssreflect.ssrbool Ssreflect.eqtype Ssreflect.fintype Ssreflect.finfun Ssreflect.seq Ssreflect.tuple.
Require Import x86proved.bitsrep x86proved.x86.ioaction.
Require Import x86proved.opred.core.
Require Import x86proved.common_tactics.
(** We want access to the relations about lists in any file that might fold [catOP] *)
Require Export x86proved.list_relations.
Require Import Coq.Setoids.Setoid Coq.Classes.RelationClasses Coq.Classes.Morphisms.

Generalizable All Variables.
Set Implicit Arguments.

Local Transparent ILFun_Ops ILPre_Ops osepILogicOps osepILogic lentails ltrue lfalse limpl land lor lforall lexists.
Local Transparent catOP eq_opred.

Local Ltac t :=
  do ![ move => ?
      | progress destruct_head_hnf ex
      | progress destruct_head_hnf and
      | progress destruct_head_hnf or
      | progress subst
      | esplit
      | by hyp_apply *
      | by left; hyp_apply *
      | by right; hyp_apply * ].

Add Parametric Morphism : catOP with signature lentails ==> lentails ==> lentails as catOP_entails_m.
Proof. t. Qed.

Add Parametric Morphism : catOP with signature lequiv ==> lequiv ==> lequiv as catOP_equiv_m.
Proof. t. Qed.

Lemma foldr_catOP_map_respects_lentails {T} o0 f g (ls : seq T)
      (H : forall x, f x |-- g x)
: foldr catOP o0 (map f ls) |-- foldr catOP o0 (map g ls).
Proof.
  change ((pointwise_relation T (@lentails OPred _))%signature f g) in H.
  by rewrite -> H.
Qed.


Definition eq_dec T := forall l r : T, { l = r } + { l <> r }.

Ltac dedec dec :=
  match goal with
  | |- ?Y =>
      match Y with
        context f [dec ?l ?r] => destruct (dec l r)
      end
  | X : _ |- _ =>
      match type of X with
      | context [dec ?l ?r] =>
          destruct (dec l r)
      end
  end.