(* Functional implementation of Salsa20 whose
   structure matches the one of tweetnacl.c implementation,
   plus proof of coorrectness wrt Salsa20.v

   Lennart Beringer, June 2015*)
(*Processing time for this file: approx 13mins*)
Require Import VST.floyd.proofauto.
Local Open Scope logic.
Require Import List. Import ListNotations.
(*Require Import general_lemmas.

Require Import split_array_lemmas.*)
Require Import ZArith.
Local Open Scope Z.
Require Import tweetnacl20140427.tweetNaclBase.
Require Import tweetnacl20140427.Salsa20.
Require Import tweetnacl20140427.verif_salsa_base.
Require Import tweetnacl20140427.tweetnaclVerifiableC.
Require Import tweetnacl20140427.Snuffle.
Require Import tweetnacl20140427.spec_salsa.

Require Import tweetnacl20140427.verif_fcore_loop1.
Require Import tweetnacl20140427.verif_fcore_loop2.
Require Import tweetnacl20140427.verif_fcore_loop3.

Require Import tweetnacl20140427.verif_fcore_epilogue_htrue.
Require Import tweetnacl20140427.verif_fcore_epilogue_hfalse.

Opaque littleendian_invert. Opaque Snuffle.Snuffle.

Lemma HFalse_inv16_char: forall l xs ys,
  HFalse_inv l 16 xs ys ->
  Zlength xs = 16 -> Zlength ys=16 ->
  exists sum, Some sum = sumlist xs ys /\
  l = QuadChunks2ValList (map littleendian_invert sum).
Proof. intros. destruct H.
 destruct (listGE16 l) as
  [v0 [v1 [v2 [v3 [v4 [v5 [v6 [v7 [v8 [v9 [v10 [v11 [v12 [v13 [v14 [v15 [t1 [T1 L1]]]]]]]]]]]]]]]]]]. lia.
 rewrite H in L1; simpl in L1.
 destruct (listGE16 t1) as
  [v16 [v17 [v18 [v19 [v20 [v21 [v22 [v23 [v24 [v25 [v26 [v27 [v28 [v29 [v30 [v31 [t2 [T2 L2]]]]]]]]]]]]]]]]]]. lia.
 rewrite L1 in L2; simpl in L2.
 destruct (listGE16 t2) as
  [v32 [v33 [v34 [v35 [v36 [v37 [v38 [v39 [v40 [v41 [v42 [v43 [v44 [v45 [v46 [v47 [t3 [T3 L3]]]]]]]]]]]]]]]]]]. lia.
 rewrite L2 in L3; simpl in L3.
 destruct (listGE16 t3) as
  [v48 [v49 [v50 [v51 [v52 [v53 [v54 [v55 [v56 [v57 [v58 [v59 [v60 [v61 [v62 [v63 [t4 [T4 L4]]]]]]]]]]]]]]]]]]. lia.
 rewrite L3 in L4; simpl in L4.
 apply Zlength_nil_inv in L4. subst t3 t4 t2 t1. clear L1 L2 L3 H. simpl in T1.
 destruct (listD16 _ H0) as
  [x0 [x1 [x2 [x3 [x4 [x5 [x6 [x7 [x8 [x9 [x10 [x11 [x12 [x13 [x14 [x15 A1]]]]]]]]]]]]]]]].
 destruct (listD16 _ H1) as
  [y0 [y1 [y2 [y3 [y4 [y5 [y6 [y7 [y8 [y9 [y10 [y11 [y12 [y13 [y14 [y15 B1]]]]]]]]]]]]]]]].
subst l xs ys.
eexists; split. reflexivity.
unfold Znth in H2. simpl.
destruct (H2 0) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 1) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 2) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 3) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 4) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 5) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 6) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 7) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 8) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 9) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 10) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 11) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 12) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 13) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 14) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 15) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
reflexivity.
Qed.

Lemma TP C1 C2 C3 C4 N1 N2 N3 N4 intsums OUT: Zlength intsums = 16 -> Zlength OUT = 32 ->
  hPosLoop3 4 (hPosLoop2 4 intsums (C1, C2, C3, C4) (N1, N2, N3, N4)) OUT =
 QuadByte2ValList (littleendian_invert (Int.sub (Znth 0 intsums)  (littleendian C1))) ++
 QuadByte2ValList (littleendian_invert (Int.sub (Znth 5 intsums)  (littleendian C2))) ++
 QuadByte2ValList (littleendian_invert (Int.sub (Znth 10 intsums) (littleendian C3))) ++
 QuadByte2ValList (littleendian_invert (Int.sub (Znth 15 intsums) (littleendian C4))) ++
 QuadByte2ValList (littleendian_invert (Int.sub (Znth 6 intsums)  (littleendian N1))) ++
 QuadByte2ValList (littleendian_invert (Int.sub (Znth 7 intsums)  (littleendian N2))) ++
 QuadByte2ValList (littleendian_invert (Int.sub (Znth 8 intsums)  (littleendian N3))) ++
 QuadByte2ValList (littleendian_invert (Int.sub (Znth 9 intsums)  (littleendian N4))).
Proof. intros.
rewrite Zlength_length in H, H0. simpl in H, H0.
destruct intsums; simpl in H. lia. rename i into v0.
destruct intsums; simpl in H. lia. rename i into v1.
destruct intsums; simpl in H. lia. rename i into v2.
destruct intsums; simpl in H. lia. rename i into v3.
destruct intsums; simpl in H. lia. rename i into v4.
destruct intsums; simpl in H. lia. rename i into v5.
destruct intsums; simpl in H. lia. rename i into v6.
destruct intsums; simpl in H. lia. rename i into v7.
destruct intsums; simpl in H. lia. rename i into v8.
destruct intsums; simpl in H. lia. rename i into v9.
destruct intsums; simpl in H. lia. rename i into v10.
destruct intsums; simpl in H. lia. rename i into v11.
destruct intsums; simpl in H. lia. rename i into v12.
destruct intsums; simpl in H. lia. rename i into v13.
destruct intsums; simpl in H. lia. rename i into v14.
destruct intsums; simpl in H. lia. rename i into v15.
destruct intsums; simpl in H. 2: lia. clear H. simpl.
unfold Znth. simpl.
destruct OUT; simpl in H0. lia. rename v into u0.
destruct OUT; simpl in H0. lia. rename v into u1.
destruct OUT; simpl in H0. lia. rename v into u2.
destruct OUT; simpl in H0. lia. rename v into u3.
destruct OUT; simpl in H0. lia. rename v into u4.
destruct OUT; simpl in H0. lia. rename v into u5.
destruct OUT; simpl in H0. lia. rename v into u6.
destruct OUT; simpl in H0. lia. rename v into u7.
destruct OUT; simpl in H0. lia. rename v into u8.
destruct OUT; simpl in H0. lia. rename v into u9.
destruct OUT; simpl in H0. lia. rename v into u10.
destruct OUT; simpl in H0. lia. rename v into u11.
destruct OUT; simpl in H0. lia. rename v into u12.
destruct OUT; simpl in H0. lia. rename v into u13.
destruct OUT; simpl in H0. lia. rename v into u14.
destruct OUT; simpl in H0. lia. rename v into u15.
destruct OUT; simpl in H0. lia. rename v into u16.
destruct OUT; simpl in H0. lia. rename v into u17.
destruct OUT; simpl in H0. lia. rename v into u18.
destruct OUT; simpl in H0. lia. rename v into u19.
destruct OUT; simpl in H0. lia. rename v into u20.
destruct OUT; simpl in H0. lia. rename v into u21.
destruct OUT; simpl in H0. lia. rename v into u22.
destruct OUT; simpl in H0. lia. rename v into u23.
destruct OUT; simpl in H0. lia. rename v into u24.
destruct OUT; simpl in H0. lia. rename v into u25.
destruct OUT; simpl in H0. lia. rename v into u26.
destruct OUT; simpl in H0. lia. rename v into u27.
destruct OUT; simpl in H0. lia. rename v into u28.
destruct OUT; simpl in H0. lia. rename v into u29.
destruct OUT; simpl in H0. lia. rename v into u30.
destruct OUT; simpl in H0. lia. rename v into u31.
destruct OUT; simpl in H0. 2: lia. clear H0. simpl. reflexivity. lia. lia.
Qed.

Definition HTrue_inv intsums xs ys:Prop:=
Zlength intsums = 16 /\
        (forall j, 0 <= j < 16 ->
           exists xj, exists yj,
           Znth j (map Vint xs) = Vint xj /\
           Znth j (map Vint ys) = Vint yj /\
           Znth j (map Vint intsums) = Vint (Int.add yj xj)).

Lemma HTrue_inv_char l xs ys: Zlength xs = 16 -> Zlength ys=16 ->
      HTrue_inv l xs ys -> Some l = sumlist xs ys.
Proof. rewrite sumlist_symm. intros LX LY [H L].
 destruct (listD16 _ LX) as
  [x0 [x1 [x2 [x3 [x4 [x5 [x6 [x7 [x8 [x9 [x10 [x11 [x12 [x13 [x14 [x15 A1]]]]]]]]]]]]]]]].
 destruct (listD16 _ LY) as
  [y0 [y1 [y2 [y3 [y4 [y5 [y6 [y7 [y8 [y9 [y10 [y11 [y12 [y13 [y14 [y15 B1]]]]]]]]]]]]]]]].
 destruct (listD16 _ H) as
  [z0 [z1 [z2 [z3 [z4 [z5 [z6 [z7 [z8 [z9 [z10 [z11 [z12 [z13 [z14 [z15 C1]]]]]]]]]]]]]]]].
subst xs ys l.
unfold Znth in L.
destruct (L 0) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 1) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 2) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 3) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 4) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 5) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 6) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 7) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 8) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 9) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 10) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 11) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 12) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 13) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 14) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 15) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q. reflexivity.
Qed.

Definition fcore_EpiloguePOST t y x w nonce out c k h OUT
  (data : SixteenByte * SixteenByte * (SixteenByte * SixteenByte)) :=
match data with ((Nonce, C), K) =>
EX xs:_, EX ys:_,
PROP (ys = prepare_data data /\ Snuffle 20 ys = Some xs)
LOCAL (lvar _t (tarray tuint 4) t;
       lvar _y (tarray tuint 16) y; lvar _x (tarray tuint 16) x;
       lvar _w (tarray tuint 16) w; temp _in nonce; temp _out out; temp _c c;
       temp _k k; temp _h (Vint (Int.repr h)))
  SEP (CoreInSEP data (nonce, c, k);
       data_at Tsh (tarray tuint 16) (map Vint ys) y;
       data_at_ Tsh (tarray tuint 4) t; data_at_ Tsh (tarray tuint 16) w;
       if Int.eq (Int.repr h) Int.zero
         then EX l:_,
          !!HFalse_inv l 16 xs ys &&
          (data_at Tsh (tarray tuchar 64) l out *
           data_at Tsh (tarray tuint 16) (map Vint xs) x)
         else EX intsums:_, !!(HTrue_inv intsums xs ys) &&
            (data_at Tsh (tarray tuchar 32)
               (hPosLoop3 4 (hPosLoop2 4 intsums C Nonce) OUT) out
             * data_at Tsh (tarray tuint 16)
                 (map Vint (hPosLoop2 4 intsums C Nonce)) x))
end.

Opaque Snuffle. Opaque hPosLoop2. Opaque hPosLoop3.

Lemma HTruePOST F t y x w nonce out c k h snuffleRes l data OUT:
      Snuffle 20 l = Some snuffleRes ->
      Int.eq (Int.repr h) Int.zero = false ->
      l = prepare_data data ->
      F |-- (data_at_ Tsh (tarray tuint 4) t * data_at_ Tsh (tarray tuint 16) w)%logic ->
      HTruePostCond F t y x w nonce out c k h snuffleRes l data OUT
|-- fcore_EpiloguePOST t y x w nonce out c k h OUT data.
Proof. intros.
unfold HTruePostCond, fcore_EpiloguePOST.
destruct data as [[? ?] [? ?]].
Exists snuffleRes l.
rewrite H0, <- H1, H. clear - H2.
Time normalize. (*1.4*)
 Exists intsums.
 go_lowerx. (* must do this explicitly because it's not an ENTAIL *)
 Time entailer!; auto. (*6.8*)
Qed.

Lemma HFalsePOST F t y x w nonce out c k h snuffleRes l data OUT:
      Snuffle 20 l = Some snuffleRes ->
      Int.eq (Int.repr h) Int.zero = true ->
      l = prepare_data data ->
      F |-- ((CoreInSEP data (nonce, c,k) * data_at_ Tsh (tarray tuint 4) t *
             data_at_ Tsh (tarray tuint 16) w))%logic ->
      HFalsePostCond F t y x w nonce out c k h snuffleRes l
     |-- fcore_EpiloguePOST t y x w nonce out c k h OUT data.
Proof. intros.
unfold HFalsePostCond, fcore_EpiloguePOST.
destruct data as [[? ?] [? ?]].
Exists snuffleRes l.
rewrite H0, <- H1, H. clear - H2.
go_lowerx. (* must do this explicitly because it's not an ENTAIL *)
Time entailer!. (*3.4*)
Intros intsums. Exists intsums; entailer!. apply H2.
Qed.

Opaque HTruePostCond. Opaque HFalsePostCond.

Lemma core_spec_ok: semax_body SalsaVarSpecs SalsaFunSpecs
       f_core core_spec.
Proof. unfold core_spec, f_core_POST.
start_function. abbreviate_semax.
rename v_t into t.
rename v_y into y.
rename v_x into x.
rename v_w into w.
freeze [0;1;2;3;4] FR1.
Time assert_PROP (Zlength OUT = Z.max 0 (OutLen h)) as ZL_OUT by entailer!.
rewrite Z.max_r in ZL_OUT.
2:{ unfold OutLen. simple_if_tac; lia. }
(* apply semax_seq with (Q:=fcore_EpiloguePOST t y x w nonce out c k h OUT data). *)
thaw FR1. freeze [0;1;3;5] FR2.
eapply semax_seq.
apply (f_core_loop1 Espec (FRZL FR2) c k h nonce out w x y t data); trivial.
(*/FOR(i,16) y[i] = x[i]*)
Intros xInit. red in H. rename H into XInit.
thaw FR2. freeze [0;2;3;5] FR3.
subst MORE_COMMANDS; unfold abbreviate.
eapply semax_seq.
apply (f_core_loop2 _ (FRZL FR3) c k h nonce out w x y t data); trivial.
    (* mkConciseDelta SalsaVarSpecs SalsaFunSpecs f_core Delta.*)

    Intros YS.
    destruct H as [? [? [? [? [? [? [? [? ?]]]]]]]].
    assert (L31: Zlength (x3 ++ x1) = 16) by (rewrite H1; reflexivity).
    rewrite Zlength_app, H3 in L31. destruct x1. 2:{ rewrite Zlength_cons', Z.add_assoc in L31. specialize (Zlength_nonneg x1); intros; lia. }
    rewrite app_nil_r in *. clear L31; subst x0. clear H3 H1 x3.
    assert (LX: Zlength xInit = 16).
      rewrite XInit. rewrite upd_upto_Zlength; trivial. simpl; lia.
    rewrite <- H0, Zlength_app, H2 in LX. destruct x2. 2:{ rewrite Zlength_cons', Z.add_assoc in LX. specialize (Zlength_nonneg x2); intros; lia. }
    rewrite app_nil_r in *. clear LX; subst YS. rename H2 into xInit_Zlength.

    rewrite upd_upto_char in XInit. 2: reflexivity.
    destruct data as [[Nonce C] [Key1 Key2]].
    destruct Nonce as [[[N1 N2] N3] N4].
    destruct C as [[[C1 C2] C3] C4].
    destruct Key1 as [[[K1 K2] K3] K4].
    destruct Key2 as [[[L1 L2] L3] L4].

    thaw FR3. subst xInit.
    freeze [2;3;5] FR4.
    remember [C1; K1; K2; K3; K4; C2; N1; N2; N3; N4; C3; L1; L2; L3; L4; C4] as xInit.
    forward_seq.
    eapply semax_post_flipped'.
    apply (f_core_loop3 _ (FRZL FR4) c k h nonce out w x y t (map littleendian xInit)).
    intros. apply andp_left2. apply derives_refl.
    Intros snuffleRes. rename H into RES.

    freeze [0;1;2;3] FR5.
    Time forward_if (fcore_EpiloguePOST t y x w nonce out c k h OUT
               ((N1, N2, N3, N4), (C1, C2, C3, C4), ((K1, K2, K3, K4), (L1, L2, L3, L4)))). (*4.8*)
    - (*apply typed_true_tint_Vint in H.*)
      assert (HOUTLEN: OutLen h = 32). unfold OutLen. rewrite Int.eq_false; trivial.
      thaw FR5. thaw FR4. rewrite HOUTLEN in *. freeze [3;4] FR6.
      force_sequential.
      eapply semax_post_flipped'.
      eapply (verif_fcore_epilogue_htrue Espec (FRZL FR6) t y x w nonce out c k h
                     OUT snuffleRes (map littleendian xInit)
                     (((N1, N2, N3, N4), (C1, C2, C3, C4)), (K1, K2, K3, K4, (L1, L2, L3, L4)))).
        apply andp_left2.
        apply HTruePOST; trivial. rewrite Int.eq_false; trivial.
        subst xInit; reflexivity.
        thaw FR6. cancel.
    - (*unfold typed_false in H. simpl in H. inversion H. apply negb_false_iff in H1. clear H.*)
      assert (HOUTLEN: OutLen h = 64). unfold OutLen; rewrite H; trivial.
      thaw FR5. thaw FR4. rewrite HOUTLEN in *. freeze [1;3;4] FR6.
      drop_LOCAL 0%nat.
      eapply semax_post_flipped'.
      apply (verif_fcore_epilogue_hfalse Espec (FRZL FR6)
            t y x w nonce out c k h OUT).
      apply andp_left2.
        apply HFalsePOST; trivial. rewrite H. trivial. subst; trivial.
        thaw FR6. cancel.
-
   clear - ZL_OUT. clearbody Delta_specs.
   set (data :=(N1, N2, N3, N4, (C1, C2, C3, C4),
  (K1, K2, K3, K4, (L1, L2, L3, L4)))).
  change (N1, N2, N3, N4, (C1, C2, C3, C4),
             (K1, K2, K3, K4, (L1, L2, L3, L4))) with data.
   destruct data as [[Nonce C] [Key1 Key2]].
   unfold fcore_EpiloguePOST.
    Intros snuffleRes ys. subst ys.
    destruct (Int.eq (Int.repr h) Int.zero) eqn:hh.
 + Intros l. Exists l. rename H into H99. entailer!.
    rewrite Zlength_map in H1.
    specialize (Snuffle_length _ _ _  H0 (prepare_data_length _ )); intros L.
    unfold fcore_result.
    unfold Snuffle20, bind. rewrite H0; clear H0.
        destruct (HFalse_inv16_char _ _ _ H99) as [sums [SUMS1 SUMS2]].
          rewrite Zlength_correct, L; reflexivity. trivial.
        rewrite <- SUMS1, <- SUMS2. rewrite hh. auto.
        unfold fcorePOST_SEP, OutLen.
        rewrite hh. auto.
  +  Intros intsums.   unfold fcorePOST_SEP.
      Exists (hPosLoop3 4 (hPosLoop2 4 intsums C Nonce) OUT).
      rename H into H99. entailer!.    unfold fcore_result.
    unfold Snuffle20, bind. rewrite H0.
      apply HTrue_inv_char in H99. rewrite <- H99.
      rewrite hh.
    rewrite Zlength_map in H1.
    specialize (Snuffle_length _ _ _  H0 (prepare_data_length _ )); intros L.
      destruct Nonce as [[[? ?] ?] ?]. destruct C as [[[? ?] ?] ?].
     auto.
      rewrite <- TP with (OUT:=OUT).
      unfold fcorePOST_SEP, OutLen. auto.
       rewrite Zlength_correct, (sumlist_length _ _ _ H99), prepare_data_length; trivial.
        rewrite ZL_OUT. unfold OutLen; rewrite hh. trivial.
    specialize (Snuffle_length _ _ _  H0 (prepare_data_length _ )); intros L.
        rewrite Zlength_correct, L; reflexivity.
        rewrite Zlength_correct, prepare_data_length; reflexivity.
     unfold OutLen. rewrite hh. auto.
Time Qed. (*20 versus 58*)


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

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

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*  Z_to_Q.v                                                                *)
(*                                                                          *)
(*  Details of the coercion between integers and rationals                  *)
(*                                                                          *)
(*                                                                          *)
(*  Samuel Boutin                                                           *)
(*  Coq V5.10                                                               *)
(*  June  1995                                                              *)
(*                                                                          *)
(*                                                                          *)
(****************************************************************************)
(*                              Z_to_Q.v                                    *)
(****************************************************************************)

Require Import quotient.
Require Import subset.
Require Import HS.
Require Import AC.
Require Import intnumbers.
Require Import rational_defs.

Section Integers_are_Rationals.

Require Import productSyntax.

Open Scope INT_scope.

Lemma one_is_a_denominator : 1 <= 1.

red in |- *; simpl in |- *.
rewrite (Reduce_prop Z_typ Z_rel).
red in |- *; simpl in |- *.
rewrite (Reduce_prop Z_typ Z_rel).
red in |- *; simpl in |- *.
apply le_n; auto.
Qed.

Definition fromZ_to_Q (x : Z) : Q := |(x, %+ (1) one_is_a_denominator) |q.

End Integers_are_Rationals.
(*
Grammar rational final :=
[ "{" integer:expr($c) "}" ] -> [<<(fromZ_to_Q $c)>>].
*)


Require Import Infrastructure.
Require Import SourceProperty.
Require Import LR.
Require Import Compatibility.

(* BEGIN_FUNDAMENTAL *)
Theorem fundamental_prop:  forall Δ Γ E A e e' dir,
    has_type Δ Γ E dir A e ->
    has_type Δ Γ E dir A e' ->
    E_open Δ Γ e e' A A.
Proof with eauto using swft_wft, swfe_wfe, elaboration_well_type, subtype_well_type, swft_from_swfe, swfe_notin.
  introv Ty1. gen e'.
  induction Ty1; introv Ty2.

  - Case "top".

    apply top_compatibility...
  - Case "lit".
    inverts Ty2.
    apply lit_compatibility...

  - Case "var".
    inverts Ty2.
    apply var_compatibility...

  - Case "app".
    inverts Ty2 as.
    introv Ty1 Ty2.
    lets H: inference_unique Ty1_1 Ty1.
    inverts H.
    forwards : IHTy1_1...
    forwards : IHTy1_2...
    eapply app_compatibility...

  - Case "merge".
    inverts Ty2 as Ty1 Ty2 ?.
    forwards : IHTy1_1 Ty1.
    forwards : IHTy1_2 Ty2.
    eapply pair_compatibility...

  - Case "anno".
    inverts Ty2.
    eapply IHTy1...

  - Case "tabs".
    inverts Ty2.
    pick_fresh X.
    eapply tabs_compatibility...
    forwards : H0...
    assert (Wfte : swfte ([(X, A)] ++ DD))...
    inverts Wfte...

  - Case "tapp".
    inverts Ty2.
    forwards Eq : inference_unique Ty1 H5.
    inverts Eq.
    forwards : IHTy1...
    eapply tapp_compatibility...

  - Case "rcd".
    inverts Ty2.
    forwards : IHTy1...
    apply record_compatibility...

  - Case "proj".
    inverts Ty2.
    forwards : IHTy1...
    apply record_compatibility in H...

  - Case "abs".
    inverts Ty2.
    pick_fresh x.
    forwards Imp : H8 x...
    forwards Imp2 : H1 Imp...
    eapply abs_compatibility...
    eapply uniq_from_swfte...
    inverts H2.

  - Case "capp".
    inverts Ty2.
    inverts Ty1.
    lets : inference_unique Ty1 H1.
    substs.
    forwards : IHTy1 H1.
    eapply coercion_compatibility1...
    eapply coercion_compatibility2...
Qed.

(* ********************************************************************** *)
(** * Expression contexts *)

(* Context replacement is not substitution, ott has difficulity generating correct definition *)

Inductive CTyp : CC -> stctx -> sctx -> dirflag -> sty -> stctx -> sctx -> dirflag -> sty -> cc -> Prop :=    (* defn CTyp *)
 | CTyp_empty1 : forall (DD:stctx) (GG:sctx) (A:sty),
     lc_sty A ->
     CTyp C_Empty DD GG Inf A DD GG Inf A cc_empty
 | CTyp_empty2 : forall (DD:stctx) (GG:sctx) (A:sty),
     lc_sty A ->
     CTyp C_Empty DD GG Chk A DD GG Chk A cc_empty
 | CTyp_appL1 : forall (CC5:CC) (ee2:sexp) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (A2:sty) (cc5:cc) (e:exp) (A1:sty),
     CTyp CC5 DD GG Inf A DD' GG' Inf (sty_arrow A1 A2) cc5 ->
     has_type DD' GG' ee2 Chk A1 e ->
     CTyp (C_AppL CC5 ee2) DD GG Inf A DD' GG' Inf A2 (cc_appL cc5 e)
 | CTyp_appL2 : forall (CC5:CC) (ee2:sexp) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (A2:sty) (cc5:cc) (e:exp) (A1:sty),
     CTyp CC5 DD GG Chk A DD' GG' Inf (sty_arrow A1 A2) cc5 ->
     has_type DD' GG' ee2 Chk A1 e ->
     CTyp (C_AppL CC5 ee2) DD GG Chk A DD' GG' Inf A2 (cc_appL cc5 e)
 | CTyp_appR1 : forall (ee1:sexp) (CC5:CC) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (A2:sty) (e:exp) (cc5:cc) (A1:sty),
     CTyp CC5 DD GG Inf A DD' GG' Chk A1 cc5 ->
     has_type DD' GG' ee1 Inf (sty_arrow A1 A2) e ->
     CTyp (C_AppRd ee1 CC5) DD GG Inf A DD' GG' Inf A2 (cc_appR e cc5)
 | CTyp_appR2 : forall (ee1:sexp) (CC5:CC) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (A2:sty) (e:exp) (cc5:cc) (A1:sty),
     CTyp CC5 DD GG Chk A DD' GG' Chk A1 cc5 ->
     has_type DD' GG' ee1 Inf (sty_arrow A1 A2) e ->
     CTyp (C_AppRd ee1 CC5) DD GG Chk A DD' GG' Inf A2 (cc_appR e cc5)
 | CTyp_mergeL1 : forall (CC5:CC) (ee2:sexp) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (A1 A2:sty) (cc5:cc) (e:exp),
     CTyp CC5 DD GG Inf A DD' GG' Inf A1 cc5 ->
     has_type DD' GG' ee2 Inf A2 e ->
     disjoint DD' A1 A2 ->
     CTyp (C_MergeL CC5 ee2) DD GG Inf A DD' GG' Inf (sty_and A1 A2) (cc_pairL cc5 e)
 | CTyp_mergeL2 : forall (CC5:CC) (ee2:sexp) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (A1 A2:sty) (cc5:cc) (e:exp),
     CTyp CC5 DD GG Chk A DD' GG' Inf A1 cc5 ->
     has_type DD' GG' ee2 Inf A2 e ->
     disjoint DD' A1 A2 ->
     CTyp (C_MergeL CC5 ee2) DD GG Chk A DD' GG' Inf (sty_and A1 A2) (cc_pairL cc5 e)
 | CTyp_mergeR1 : forall (ee1:sexp) (CC5:CC) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (A1 A2:sty) (e:exp) (cc5:cc),
     CTyp CC5 DD GG Inf A DD' GG' Inf A2 cc5 ->
     has_type DD' GG' ee1 Inf A1 e ->
     disjoint DD' A1 A2 ->
     CTyp (C_MergeR ee1 CC5) DD GG Inf A DD' GG' Inf (sty_and A1 A2) (cc_pairR e cc5)
 | CTyp_mergeR2 : forall (ee1:sexp) (CC5:CC) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (A1 A2:sty) (e:exp) (cc5:cc),
     CTyp CC5 DD GG Chk A DD' GG' Inf A2 cc5 ->
     has_type DD' GG' ee1 Inf A1 e ->
     disjoint DD' A1 A2 ->
     CTyp (C_MergeR ee1 CC5) DD GG Chk A DD' GG' Inf (sty_and A1 A2) (cc_pairR e cc5)
 | CTyp_rcd1 : forall (l:i) (CC5:CC) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (B:sty) (cc5:cc),
     CTyp CC5 DD GG Inf A DD' GG' Inf B cc5 ->
     CTyp (C_Rcd l CC5) DD GG Inf A DD' GG' Inf (sty_rcd l B) cc5
 | CTyp_rcd2 : forall (l:i) (CC5:CC) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (B:sty) (cc5:cc),
     CTyp CC5 DD GG Chk A DD' GG' Inf B cc5 ->
     CTyp (C_Rcd l CC5) DD GG Chk A DD' GG' Inf (sty_rcd l B) cc5
 | CTyp_proj1 : forall (CC5:CC) (l:i) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (B:sty) (cc5:cc),
     CTyp CC5 DD GG Inf A DD' GG' Inf (sty_rcd l B) cc5 ->
     CTyp (C_Proj CC5 l) DD GG Inf A DD' GG' Inf B cc5
 | CTyp_proj2 : forall (CC5:CC) (l:i) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (B:sty) (cc5:cc),
     CTyp CC5 DD GG Chk A DD' GG' Inf (sty_rcd l B) cc5 ->
     CTyp (C_Proj CC5 l) DD GG Chk A DD' GG' Inf B cc5
 | CTyp_anno1 : forall (CC5:CC) (A:sty) (DD:stctx) (GG:sctx) (B:sty) (DD':stctx) (GG':sctx) (cc5:cc),
     CTyp CC5 DD GG Inf B DD' GG' Chk A cc5 ->
     CTyp (C_Anno CC5 A) DD GG Inf B DD' GG' Inf A cc5
 | CTyp_anno2 : forall (CC5:CC) (A:sty) (DD:stctx) (GG:sctx) (B:sty) (DD':stctx) (GG':sctx) (cc5:cc),
     CTyp CC5 DD GG Chk B DD' GG' Chk A cc5 ->
     CTyp (C_Anno CC5 A) DD GG Chk B DD' GG' Inf A cc5
 | CTyp_abs1 : forall (x:expvar) (CC5:CC) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (A1 A2:sty) (cc5:cc),
     CTyp CC5 DD GG Inf A DD'  (( x ~ A1 )++ GG' )  Chk A2 cc5 ->
     swft DD' A1 ->
     swfte DD' ->
     x `notin` dom GG' ->
     CTyp (C_Lam x CC5) DD GG Inf A DD' GG' Chk (sty_arrow A1 A2) (cc_lam x cc5)
 | CTyp_abs2 : forall (x:expvar) (CC5:CC) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (A1 A2:sty) (cc5:cc),
     CTyp CC5 DD GG Chk A DD'  (( x ~ A1 )++ GG' )  Chk A2 cc5 ->
     swft DD' A1 ->
     swfte DD' ->
     x `notin` dom GG' ->
     CTyp (C_Lam x CC5) DD GG Chk A DD' GG' Chk (sty_arrow A1 A2) (cc_lam x cc5)
 | CTyp_tabs1 : forall X (L:vars) (B:sty) (CC5:CC) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (B':sty) (cc5:cc),
     CTyp CC5 DD GG Inf A  (( X ~ B )++ DD' )  GG' Inf  ( open_sty_wrt_sty B' (sty_var_f X) )  cc5   ->
     swft DD' B ->
     swfe DD' GG' ->
     swfte DD' ->
     X `notin` dom GG' ->
     X `notin` dom DD' ->
     X `notin` fv_sty_in_sty B' ->
     X `notin` fv_sty_in_sty B' ->
     CTyp (C_tabs X B CC5) DD GG Inf A DD' GG' Inf (sty_all B B') (cc_tabs X cc5)
 | CTyp_tabs2 : forall X (L:vars) (B:sty) (CC5:CC) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (B':sty) (cc5:cc),
     CTyp CC5 DD GG Chk A  (( X ~ B )++ DD' )  GG' Inf  ( open_sty_wrt_sty B' (sty_var_f X) )  cc5   ->
     swft DD' B ->
     swfe DD' GG' ->
     swfte DD' ->
     X `notin` dom GG' ->
     X `notin` dom DD' ->
     X `notin` fv_sty_in_sty B' ->
     X `notin` fv_sty_in_sty B' ->
     CTyp (C_tabs X B CC5) DD GG Chk A DD' GG' Inf (sty_all B B') (cc_tabs X cc5)
 | CTyp_tapp1 : forall (CC5:CC) (B:sty) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (A2:sty) (cc5:cc) (A1:sty),
     CTyp CC5 DD GG Inf A DD' GG' Inf (sty_all A1 A2) cc5 ->
     swfte DD' ->
     swft DD' B ->
     disjoint DD' B A1 ->
     mono  B  ->
     CTyp (C_tapp CC5 B) DD GG Inf A DD' GG' Inf  (open_sty_wrt_sty  A2   B )  (cc_tapp cc5  (sty2ty  B ) )
 | CTyp_tapp2 : forall (CC5:CC) (B:sty) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (A2:sty) (cc5:cc) (A1:sty),
     CTyp CC5 DD GG Chk A DD' GG' Inf (sty_all A1 A2) cc5 ->
     swfte DD' ->
     swft DD' B ->
     disjoint DD' B A1 ->
     mono  B  ->
     CTyp (C_tapp CC5 B) DD GG Chk A DD' GG' Inf  (open_sty_wrt_sty  A2   B )  (cc_tapp cc5  (sty2ty  B ) ).

Hint Constructors CTyp.

(** ** Context replacement *)

Fixpoint appctx (ctx : cc) (t : exp) : exp :=
  match ctx with
  | cc_empty => t
  | cc_lam x c => exp_abs (close_exp_wrt_exp x (appctx c t))
  | cc_tabs X c => exp_tabs (close_exp_wrt_ty X (appctx c t))
  | cc_tapp c T => exp_tapp (appctx c t) T
  | cc_appL c t2 => exp_app (appctx c t) t2
  | cc_appR t1 c => exp_app t1 (appctx c t)
  | cc_pairL c t2 => exp_pair (appctx c t) t2
  | cc_pairR t1 c => exp_pair t1 (appctx c t)
  | cc_co co c => exp_capp co (appctx c t)
  end.

(* BEGIN_CONGRUENCE *)
Lemma congruence : forall Δ Δ' Γ Γ' E1 E2 A A' e1 e2 dir dir' C c,
    CTyp C Δ Γ dir A Δ' Γ' dir' A' c ->
    has_type Δ Γ E1 dir A e1 ->
    has_type Δ Γ E2 dir A e2 ->
    E_open Δ Γ e1 e2 A A ->
    E_open Δ' Γ' (appctx c e1) (appctx c e2) A' A'.
Proof with eauto.
  introv Ctx.
  gen E1 E2 e1 e2.
  induction Ctx; introv Ty1 Ty2 EH; simpls...

  - Case "appL1".
    lets : IHCtx Ty1 Ty2 EH...
    lets : fundamental_prop H H.
    eapply app_compatibility...

  - Case "appL2".
    lets : IHCtx Ty1 Ty2 EH...
    lets : fundamental_prop H H.
    eapply app_compatibility...

  - Case "appR1".
    lets : IHCtx Ty1 Ty2 EH...
    lets : fundamental_prop H H.
    eapply app_compatibility...

  - Case "appR2".
    lets : IHCtx Ty1 Ty2 EH...
    lets : fundamental_prop H H.
    eapply app_compatibility...

  - Case "mergeL1".
    lets : IHCtx Ty1 Ty2 EH...
    lets : fundamental_prop H H.
    eapply pair_compatibility...

  - Case "mergeL2".
    lets : IHCtx Ty1 Ty2 EH...
    lets : fundamental_prop H H.
    eapply pair_compatibility...

  - Case "mergeR1".
    lets : IHCtx Ty1 Ty2 EH...
    lets : fundamental_prop H H.
    eapply pair_compatibility...

  - Case "mergeR2".
    lets : IHCtx Ty1 Ty2 EH...
    lets : fundamental_prop H H.
    eapply pair_compatibility...

  - Case "rcd1".
    lets : IHCtx Ty1 Ty2 EH...
    apply record_compatibility...

  - Case "rcd2".
    lets : IHCtx Ty1 Ty2 EH...
    apply record_compatibility...

  - Case "proj1".
    lets : IHCtx Ty1 Ty2 EH...
    lets HH : record_compatibility...
    apply HH in H...

  - Case "proj2".
    lets : IHCtx Ty1 Ty2 EH...
    lets HH : record_compatibility...
    apply HH in H...

  - Case "abs1".
    lets : IHCtx Ty1 Ty2 EH...
    apply abs_compatibility with (x := x)...
    rewrite fv_exp_in_exp_close_exp_wrt_exp...
    rewrite fv_exp_in_exp_close_exp_wrt_exp...
    repeat rewrite~ open_exp_wrt_exp_close_exp_wrt_exp.

  - Case "abs2".
    lets : IHCtx Ty1 Ty2 EH...
    apply abs_compatibility with (x := x)...
    rewrite fv_exp_in_exp_close_exp_wrt_exp...
    rewrite fv_exp_in_exp_close_exp_wrt_exp...
    repeat rewrite open_exp_wrt_exp_close_exp_wrt_exp...

  - Case "tabs1".
    lets : IHCtx Ty1 Ty2 EH...
    apply tabs_compatibility with (X := X)...
    rewrite fv_ty_in_exp_close_exp_wrt_ty...
    rewrite fv_ty_in_exp_close_exp_wrt_ty...
    repeat rewrite~ open_exp_wrt_ty_close_exp_wrt_ty...

  - Case "tabs2".
    lets : IHCtx Ty1 Ty2 EH...
    apply tabs_compatibility with (X := X)...
    rewrite fv_ty_in_exp_close_exp_wrt_ty...
    rewrite fv_ty_in_exp_close_exp_wrt_ty...
    repeat rewrite~ open_exp_wrt_ty_close_exp_wrt_ty...

  - Case "tapp".
    lets : IHCtx Ty1 Ty2 EH...
    eapply tapp_compatibility...

  - Case "tapp".
    lets : IHCtx Ty1 Ty2 EH...
    eapply tapp_compatibility...

Qed.

Definition kleene_equiv t1 t2 :=
  exists k, t1 ->* (exp_lit k) /\ t2 ->* (exp_lit k).

Definition ctx_equiv Δ Γ E1 E2 A := forall e1 e2 dir dir' C c,
    has_type Δ Γ E1 dir A e1 ->
    has_type Δ Γ E2 dir A e2 ->
    CTyp C Δ Γ dir A nil nil dir' sty_nat c ->
    kleene_equiv (appctx c e1) (appctx c e2).

(* BEGIN_ADEQUACY *)
Lemma adequacy : forall e1 e2,
    E_open nil nil e1 e2 sty_nat sty_nat ->
    kleene_equiv e1 e2.
Proof with eauto.
  introv EH.
  destruct EH as (WF1 & WF2 & ? & ? & EH).
  specializes EH rel_d_empty rel_g_empty...
  simpls...
  destruct EH as (? & ? & ? & ? & ? & ? & ? & ? & ? & ? & VH)...
  destruct VH...
  unfolds.
  exists n...
Qed.

(* BEGIN_COHERENCE *)
Theorem coherence : forall Δ Γ E A,
    ctx_equiv Δ Γ E E A.
Proof with eauto.
  intros.
  unfolds.
  introv Ty1 Ty2 Ctx.
  lets H : fundamental_prop Ty1 Ty2.
  lets HH : congruence Ctx Ty1 Ty2 H.
  apply adequacy in HH...
Qed.


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

(** Correctness proof for operator strength reduction. *)

Require Import Coqlib Compopts.
Require Import Integers Floats Values Memory Globalenvs Events.
Require Import Op Registers RTL ValueDomain ValueAOp ValueAnalysis.
Require Import ConstpropOp.

Local Transparent Archi.ptr64.

Section STRENGTH_REDUCTION.

Variable bc: block_classification.
Variable ge: genv.
Hypothesis GENV: genv_match bc ge.
Variable sp: block.
Hypothesis STACK: bc sp = BCstack.
Variable ae: AE.t.
Variable e: regset.
Variable m: mem.
Hypothesis MATCH: ematch bc e ae.

Lemma match_G:
  forall r id ofs,
  AE.get r ae = Ptr(Gl id ofs) -> Val.lessdef e#r (Genv.symbol_address ge id ofs).
Proof.
  intros. apply vmatch_ptr_gl with bc; auto. rewrite <- H. apply MATCH.
Qed.

Lemma match_S:
  forall r ofs,
  AE.get r ae = Ptr(Stk ofs) -> Val.lessdef e#r (Vptr sp ofs).
Proof.
  intros. apply vmatch_ptr_stk with bc; auto. rewrite <- H. apply MATCH.
Qed.

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

Ltac SimplVM :=
  match goal with
  | [ H: vmatch _ ?v (I ?n) |- _ ] =>
      let E := fresh in
      assert (E: v = Vint n) by (inversion H; auto);
      rewrite E in *; clear H; SimplVM
  | [ H: vmatch _ ?v (L ?n) |- _ ] =>
      let E := fresh in
      assert (E: v = Vlong n) by (inversion H; auto);
      rewrite E in *; clear H; SimplVM
  | [ H: vmatch _ ?v (F ?n) |- _ ] =>
      let E := fresh in
      assert (E: v = Vfloat n) by (inversion H; auto);
      rewrite E in *; clear H; SimplVM
  | [ H: vmatch _ ?v (FS ?n) |- _ ] =>
      let E := fresh in
      assert (E: v = Vsingle n) by (inversion H; auto);
      rewrite E in *; clear H; SimplVM
  | [ H: vmatch _ ?v (Ptr(Gl ?id ?ofs)) |- _ ] =>
      let E := fresh in
      assert (E: Val.lessdef v (Genv.symbol_address ge id ofs)) by (eapply vmatch_ptr_gl; eauto);
      clear H; SimplVM
  | [ H: vmatch _ ?v (Ptr(Stk ?ofs)) |- _ ] =>
      let E := fresh in
      assert (E: Val.lessdef v (Vptr sp ofs)) by (eapply vmatch_ptr_stk; eauto);
      clear H; SimplVM
  | _ => idtac
  end.

Lemma const_for_result_correct:
  forall a op v,
  const_for_result a = Some op ->
  vmatch bc v a ->
  exists v', eval_operation ge (Vptr sp Ptrofs.zero) op nil m = Some v' /\ Val.lessdef v v'.
Proof.
  unfold const_for_result; intros; destruct a; inv H; SimplVM.
- (* integer *)
  exists (Vint n); auto.
- (* long *)
  exists (Vlong n); auto.
- (* float *)
  destruct (Compopts.generate_float_constants tt); inv H2. exists (Vfloat f); auto.
- (* single *)
  destruct (Compopts.generate_float_constants tt); inv H2. exists (Vsingle f); auto.
- (* pointer *)
  destruct p; try discriminate; SimplVM.
  + (* global *)
    inv H2. exists (Genv.symbol_address ge id ofs); auto.
  + (* stack *)
    inv H2. exists (Vptr sp ofs); split; auto. simpl. rewrite Ptrofs.add_zero_l; auto.
Qed.

Lemma eval_static_shift_correct: forall s v a,
  eval_shift s (Vint v) a = Vint (eval_static_shift s v a).
Proof.
  intros; destruct s; simpl; rewrite ? a32_range; auto.
Qed.

Lemma eval_static_shiftl_correct: forall s v a,
  eval_shiftl s (Vlong v) a = Vlong (eval_static_shiftl s v a).
Proof.
  intros; destruct s; simpl; rewrite ? a64_range; auto.
Qed.

Lemma eval_static_extend_correct: forall x v a,
  eval_extend x (Vint v) a = Vlong (eval_static_extend x v a).
Proof.
  unfold eval_extend, eval_static_extend; intros; destruct x; simpl; rewrite ? a64_range; auto.
Qed.

Lemma cond_strength_reduction_correct:
  forall cond args vl,
  vl = map (fun r => AE.get r ae) args ->
  let (cond', args') := cond_strength_reduction cond args vl in
  eval_condition cond' e##args' m = eval_condition cond e##args m.
Proof.
  intros until vl. unfold cond_strength_reduction.
  case (cond_strength_reduction_match cond args vl); simpl; intros; InvApproxRegs; SimplVM.
- apply Val.swap_cmp_bool.
- auto.
- apply Val.swap_cmpu_bool.
- auto.
- rewrite eval_static_shift_correct; auto.
- rewrite eval_static_shift_correct; auto.
- apply Val.swap_cmpl_bool.
- auto.
- apply Val.swap_cmplu_bool.
- auto.
- rewrite eval_static_shiftl_correct; auto.
- rewrite eval_static_shiftl_correct; auto.
- destruct (Float.eq_dec n1 Float.zero).
  subst n1. simpl. destruct (e#r2); simpl; auto. rewrite Float.cmp_swap. auto.
  simpl. rewrite H1; auto.
- destruct (Float.eq_dec n2 Float.zero).
  subst n2. simpl. auto.
  simpl. rewrite H1; auto.
- destruct (Float.eq_dec n1 Float.zero).
  subst n1. simpl. destruct (e#r2); simpl; auto. rewrite Float.cmp_swap. auto.
  simpl. rewrite H1; auto.
- destruct (Float.eq_dec n2 Float.zero); simpl; auto.
  subst n2; auto.
  rewrite H1; auto.
- destruct (Float32.eq_dec n1 Float32.zero).
  subst n1. simpl. destruct (e#r2); simpl; auto. rewrite Float32.cmp_swap. auto.
  simpl. rewrite H1; auto.
- destruct (Float32.eq_dec n2 Float32.zero).
  subst n2. simpl. auto.
  simpl. rewrite H1; auto.
- destruct (Float32.eq_dec n1 Float32.zero).
  subst n1. simpl. destruct (e#r2); simpl; auto. rewrite Float32.cmp_swap. auto.
  simpl. rewrite H1; auto.
- destruct (Float32.eq_dec n2 Float32.zero); simpl; auto.
  subst n2; auto.
  rewrite H1; auto.
- auto.
Qed.

Lemma make_cmp_base_correct:
  forall c args vl,
  vl = map (fun r => AE.get r ae) args ->
  let (op', args') := make_cmp_base c args vl in
  exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some v
         /\ Val.lessdef (Val.of_optbool (eval_condition c e##args m)) v.
Proof.
  intros. unfold make_cmp_base.
  generalize (cond_strength_reduction_correct c args vl H).
  destruct (cond_strength_reduction c args vl) as [c' args']. intros EQ.
  econstructor; split. simpl; eauto. rewrite EQ. auto.
Qed.

Lemma make_cmp_correct:
  forall c args vl,
  vl = map (fun r => AE.get r ae) args ->
  let (op', args') := make_cmp c args vl in
  exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some v
         /\ Val.lessdef (Val.of_optbool (eval_condition c e##args m)) v.
Proof.
  intros c args vl.
  assert (Y: forall r, vincl (AE.get r ae) (Uns Ptop 1) = true ->
             e#r = Vundef \/ e#r = Vint Int.zero \/ e#r = Vint Int.one).
  { intros. apply vmatch_Uns_1 with bc Ptop. eapply vmatch_ge. eapply vincl_ge; eauto. apply MATCH. }
  unfold make_cmp. case (make_cmp_match c args vl); intros.
- unfold make_cmp_imm_eq.
  destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1.
+ simpl in H; inv H. InvBooleans. subst n.
  exists (e#r1); split; auto. simpl.
  exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto.
+ destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0.
* simpl in H; inv H. InvBooleans. subst n.
  exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl.
  exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto.
* apply make_cmp_base_correct; auto.
- unfold make_cmp_imm_ne.
  destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0.
+ simpl in H; inv H. InvBooleans. subst n.
  exists (e#r1); split; auto. simpl.
  exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto.
+ destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1.
* simpl in H; inv H. InvBooleans. subst n.
  exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl.
  exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto.
* apply make_cmp_base_correct; auto.
- unfold make_cmp_imm_eq.
  destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1.
+ simpl in H; inv H. InvBooleans. subst n.
  exists (e#r1); split; auto. simpl.
  exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto.
+ destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0.
* simpl in H; inv H. InvBooleans. subst n.
  exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl.
  exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto.
* apply make_cmp_base_correct; auto.
- unfold make_cmp_imm_ne.
  destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0.
+ simpl in H; inv H. InvBooleans. subst n.
  exists (e#r1); split; auto. simpl.
  exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto.
+ destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1.
* simpl in H; inv H. InvBooleans. subst n.
  exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl.
  exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto.
* apply make_cmp_base_correct; auto.
- apply make_cmp_base_correct; auto.
Qed.

Lemma make_select_correct:
  forall c ty r1 r2 args vl,
  vl = map (fun r => AE.get r ae) args ->
  let (op', args') := make_select c ty r1 r2 args vl in
  exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some v
         /\ Val.lessdef (Val.select (eval_condition c e##args m) e#r1 e#r2 ty) v.
Proof.
  unfold make_select; intros.
  destruct (resolve_branch (eval_static_condition c vl)) as [b|] eqn:RB.
- exists (if b then e#r1 else e#r2); split.
+ simpl. destruct b; auto.
+ destruct (eval_condition c e##args m) as [b'|] eqn:EC; simpl; auto.
  assert (b = b').
  { eapply resolve_branch_sound; eauto.
    rewrite <- EC. apply eval_static_condition_sound with bc.
    subst vl. exact (aregs_sound _ _ _ args MATCH). }
  subst b'. apply Val.lessdef_normalize.
- generalize (cond_strength_reduction_correct c args vl H).
  destruct (cond_strength_reduction c args vl) as [cond' args']; intros EQ.
  econstructor; split. simpl; eauto. rewrite EQ; auto.
Qed.

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

Lemma make_shlimm_correct:
  forall n r1 r2,
  e#r2 = Vint n ->
  let (op, args) := make_shlimm n r1 r2 in
  exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shl e#r1 (Vint n)) v.
Proof.
Local Opaque mk_amount32.
  intros; unfold make_shlimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shl_zero. auto.
  destruct (Int.ltu n Int.iwordsize) eqn:L.
  econstructor; split. simpl. eauto. rewrite mk_amount32_eq; auto.
  econstructor; split. simpl. eauto. rewrite H; auto.
Qed.

Lemma make_shrimm_correct:
  forall n r1 r2,
  e#r2 = Vint n ->
  let (op, args) := make_shrimm n r1 r2 in
  exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shr e#r1 (Vint n)) v.
Proof.
  intros; unfold make_shrimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shr_zero. auto.
  destruct (Int.ltu n Int.iwordsize) eqn:L.
  econstructor; split. simpl. eauto. rewrite mk_amount32_eq; auto.
  econstructor; split. simpl. eauto. rewrite H; auto.
Qed.

Lemma make_shruimm_correct:
  forall n r1 r2,
  e#r2 = Vint n ->
  let (op, args) := make_shruimm n r1 r2 in
  exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shru e#r1 (Vint n)) v.
Proof.
  intros; unfold make_shruimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shru_zero. auto.
  destruct (Int.ltu n Int.iwordsize) eqn:L.
  econstructor; split. simpl. eauto. rewrite mk_amount32_eq; auto.
  econstructor; split. simpl. eauto. rewrite H; auto.
Qed.

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

Lemma make_divimm_correct:
  forall n r1 r2 v,
  Val.divs e#r1 e#r2 = Some v ->
  e#r2 = Vint n ->
  let (op, args) := make_divimm n r1 r2 in
  exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w.
Proof.
  intros; unfold make_divimm.
  predSpec Int.eq Int.eq_spec n Int.one; intros. subst. rewrite H0 in H.
  destruct (e#r1) eqn:?;
    try (rewrite Val.divs_one in H; exists (Vint i); split; simpl; try rewrite Heqv0; auto);
    inv H; auto.
  destruct (Int.is_power2 n) eqn:?.
  destruct (Int.ltu i (Int.repr 31)) eqn:?.
  exists v; split; auto. simpl. eapply Val.divs_pow2; eauto. congruence.
  exists v; auto.
  exists v; auto.
Qed.

Lemma make_divuimm_correct:
  forall n r1 r2 v,
  Val.divu e#r1 e#r2 = Some v ->
  e#r2 = Vint n ->
  let (op, args) := make_divuimm n r1 r2 in
  exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w.
Proof.
  intros; unfold make_divuimm.
  predSpec Int.eq Int.eq_spec n Int.one; intros. subst. rewrite H0 in H.
  destruct (e#r1) eqn:?;
    try (rewrite Val.divu_one in H; exists (Vint i); split; simpl; try rewrite Heqv0; auto);
    inv H; auto.
  destruct (Int.is_power2 n) eqn:?.
  econstructor; split. simpl; eauto.
  rewrite mk_amount32_eq by (eapply Int.is_power2_range; eauto).
  rewrite H0 in H. erewrite Val.divu_pow2 by eauto. auto.
  exists v; auto.
Qed.

Lemma make_andimm_correct:
  forall n r x,
  vmatch bc e#r x ->
  let (op, args) := make_andimm n r x in
  exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.and e#r (Vint n)) v.
Proof.
  intros; unfold make_andimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (Vint Int.zero); split; auto. destruct (e#r); simpl; auto. rewrite Int.and_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.mone; intros.
  subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.and_mone; auto.
  destruct (match x with Uns _ k => Int.eq (Int.zero_ext k (Int.not n)) Int.zero
                       | _ => false end) eqn:UNS.
  destruct x; try congruence.
  exists (e#r); split; auto.
  inv H; auto. simpl. replace (Int.and i n) with i; auto.
  generalize (Int.eq_spec (Int.zero_ext n0 (Int.not n)) Int.zero); rewrite UNS; intro EQ.
  Int.bit_solve. destruct (zlt i0 n0).
  replace (Int.testbit n i0) with (negb (Int.testbit Int.zero i0)).
  rewrite Int.bits_zero. simpl. rewrite andb_true_r. auto.
  rewrite <- EQ. rewrite Int.bits_zero_ext by lia. rewrite zlt_true by auto.
  rewrite Int.bits_not by auto. apply negb_involutive.
  rewrite H6 by auto. auto.
  econstructor; split; eauto. auto.
Qed.

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

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

Lemma make_addlimm_correct:
  forall n r,
  let (op, args) := make_addlimm n r in
  exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.addl e#r (Vlong n)) v.
Proof.
  intros. unfold make_addlimm.
  predSpec Int64.eq Int64.eq_spec n Int64.zero; intros.
  subst. exists (e#r); split; auto.
  destruct (e#r); simpl; auto; rewrite ? Int64.add_zero, ? Ptrofs.add_zero; auto.
  exists (Val.addl e#r (Vlong n)); split; auto.
Qed.

Lemma make_shllimm_correct:
  forall n r1 r2,
  e#r2 = Vint n ->
  let (op, args) := make_shllimm n r1 r2 in
  exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shll e#r1 (Vint n)) v.
Proof.
Local Opaque mk_amount64.
  intros; unfold make_shllimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (e#r1); split; auto. destruct (e#r1); simpl; auto.
  unfold Int64.shl'. rewrite Z.shiftl_0_r, Int64.repr_unsigned. auto.
  destruct (Int.ltu n Int64.iwordsize') eqn:L.
  econstructor; split. simpl. eauto. rewrite mk_amount64_eq; auto.
  econstructor; split. simpl. eauto. rewrite H; auto.
Qed.

Lemma make_shrlimm_correct:
  forall n r1 r2,
  e#r2 = Vint n ->
  let (op, args) := make_shrlimm n r1 r2 in
  exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shrl e#r1 (Vint n)) v.
Proof.
  intros; unfold make_shrlimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (e#r1); split; auto. destruct (e#r1); simpl; auto.
  unfold Int64.shr'. rewrite Z.shiftr_0_r, Int64.repr_signed. auto.
  destruct (Int.ltu n Int64.iwordsize') eqn:L.
  econstructor; split. simpl. eauto. rewrite mk_amount64_eq; auto.
  econstructor; split. simpl. eauto. rewrite H; auto.
Qed.

Lemma make_shrluimm_correct:
  forall n r1 r2,
  e#r2 = Vint n ->
  let (op, args) := make_shrluimm n r1 r2 in
  exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shrlu e#r1 (Vint n)) v.
Proof.
  intros; unfold make_shrluimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (e#r1); split; auto. destruct (e#r1); simpl; auto.
  unfold Int64.shru'. rewrite Z.shiftr_0_r, Int64.repr_unsigned. auto.
  destruct (Int.ltu n Int64.iwordsize') eqn:L.
  econstructor; split. simpl. eauto. rewrite mk_amount64_eq; auto.
  econstructor; split. simpl. eauto. rewrite H; auto.
Qed.

Lemma make_mullimm_correct:
  forall n r1 r2,
  e#r2 = Vlong n ->
  let (op, args) := make_mullimm n r1 r2 in
  exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mull e#r1 (Vlong n)) v.
Proof.
  intros; unfold make_mullimm.
  predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. subst.
  exists (Vlong Int64.zero); split; auto. destruct (e#r1); simpl; auto. rewrite Int64.mul_zero; auto.
  predSpec Int64.eq Int64.eq_spec n Int64.one; intros. subst.
  exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int64.mul_one; auto.
  destruct (Int64.is_power2' n) eqn:?; intros.
  econstructor; split. simpl; eauto.
  rewrite mk_amount64_eq by (eapply Int64.is_power2'_range; eauto).
  destruct (e#r1); simpl; auto.
  erewrite Int64.is_power2'_range by eauto.
  erewrite Int64.mul_pow2' by eauto. auto.
  econstructor; split; eauto. simpl; rewrite H; auto.
Qed.

Lemma make_divlimm_correct:
  forall n r1 r2 v,
  Val.divls e#r1 e#r2 = Some v ->
  e#r2 = Vlong n ->
  let (op, args) := make_divlimm n r1 r2 in
  exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w.
Proof.
  intros; unfold make_divlimm.
  destruct (Int64.is_power2' n) eqn:?. destruct (Int.ltu i (Int.repr 63)) eqn:?.
  rewrite H0 in H. econstructor; split. simpl; eauto. eapply Val.divls_pow2; eauto. auto.
  exists v; auto.
  exists v; auto.
Qed.

Lemma make_divluimm_correct:
  forall n r1 r2 v,
  Val.divlu e#r1 e#r2 = Some v ->
  e#r2 = Vlong n ->
  let (op, args) := make_divluimm n r1 r2 in
  exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w.
Proof.
  intros; unfold make_divluimm.
  destruct (Int64.is_power2' n) eqn:?.
  econstructor; split. simpl; eauto.
  rewrite mk_amount64_eq by (eapply Int64.is_power2'_range; eauto).
  rewrite H0 in H. destruct (e#r1); inv H. destruct (Int64.eq n Int64.zero); inv H2.
  simpl.
  erewrite Int64.is_power2'_range by eauto.
  erewrite Int64.divu_pow2' by eauto.  auto.
  exists v; auto.
Qed.

Lemma make_andlimm_correct:
  forall n r x,
  let (op, args) := make_andlimm n r x in
  exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.andl e#r (Vlong n)) v.
Proof.
  intros; unfold make_andlimm.
  predSpec Int64.eq Int64.eq_spec n Int64.zero; intros.
  subst n. exists (Vlong Int64.zero); split; auto. destruct (e#r); simpl; auto. rewrite Int64.and_zero; auto.
  predSpec Int64.eq Int64.eq_spec n Int64.mone; intros.
  subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int64.and_mone; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_orlimm_correct:
  forall n r,
  let (op, args) := make_orlimm n r in
  exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.orl e#r (Vlong n)) v.
Proof.
  intros; unfold make_orlimm.
  predSpec Int64.eq Int64.eq_spec n Int64.zero; intros.
  subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int64.or_zero; auto.
  predSpec Int64.eq Int64.eq_spec n Int64.mone; intros.
  subst n. exists (Vlong Int64.mone); split; auto. destruct (e#r); simpl; auto. rewrite Int64.or_mone; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_xorlimm_correct:
  forall n r,
  let (op, args) := make_xorlimm n r in
  exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.xorl e#r (Vlong n)) v.
Proof.
  intros; unfold make_xorlimm.
  predSpec Int64.eq Int64.eq_spec n Int64.zero; intros.
  subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int64.xor_zero; auto.
  predSpec Int64.eq Int64.eq_spec n Int64.mone; intros.
  subst n. exists (Val.notl e#r); split; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_mulfimm_correct:
  forall n r1 r2,
  e#r2 = Vfloat n ->
  let (op, args) := make_mulfimm n r1 r1 r2 in
  exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulf e#r1 e#r2) v.
Proof.
  intros; unfold make_mulfimm.
  destruct (Float.eq_dec n (Float.of_int (Int.repr 2))); intros.
  simpl. econstructor; split. eauto. rewrite H; subst n.
  destruct (e#r1); simpl; auto. rewrite Float.mul2_add; auto.
  simpl. econstructor; split; eauto.
Qed.

Lemma make_mulfimm_correct_2:
  forall n r1 r2,
  e#r1 = Vfloat n ->
  let (op, args) := make_mulfimm n r2 r1 r2 in
  exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulf e#r1 e#r2) v.
Proof.
  intros; unfold make_mulfimm.
  destruct (Float.eq_dec n (Float.of_int (Int.repr 2))); intros.
  simpl. econstructor; split. eauto. rewrite H; subst n.
  destruct (e#r2); simpl; auto. rewrite Float.mul2_add; auto.
  rewrite Float.mul_commut; auto.
  simpl. econstructor; split; eauto.
Qed.

Lemma make_mulfsimm_correct:
  forall n r1 r2,
  e#r2 = Vsingle n ->
  let (op, args) := make_mulfsimm n r1 r1 r2 in
  exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulfs e#r1 e#r2) v.
Proof.
  intros; unfold make_mulfsimm.
  destruct (Float32.eq_dec n (Float32.of_int (Int.repr 2))); intros.
  simpl. econstructor; split. eauto. rewrite H; subst n.
  destruct (e#r1); simpl; auto. rewrite Float32.mul2_add; auto.
  simpl. econstructor; split; eauto.
Qed.

Lemma make_mulfsimm_correct_2:
  forall n r1 r2,
  e#r1 = Vsingle n ->
  let (op, args) := make_mulfsimm n r2 r1 r2 in
  exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulfs e#r1 e#r2) v.
Proof.
  intros; unfold make_mulfsimm.
  destruct (Float32.eq_dec n (Float32.of_int (Int.repr 2))); intros.
  simpl. econstructor; split. eauto. rewrite H; subst n.
  destruct (e#r2); simpl; auto. rewrite Float32.mul2_add; auto.
  rewrite Float32.mul_commut; auto.
  simpl. econstructor; split; eauto.
Qed.

Lemma make_zext_correct:
  forall s r x,
  vmatch bc e#r x ->
  let (op, args) := make_zext s r x in
  exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.zero_ext s e#r) v.
Proof.
  intros; unfold make_zext. destruct (vincl x (Uns Ptop s)) eqn:INCL.
- exists e#r; split; auto.
  assert (V: vmatch bc e#r (Uns Ptop s)).
  { eapply vmatch_ge; eauto. apply vincl_ge; auto. }
  inv V; simpl; auto. rewrite is_uns_zero_ext in H4 by auto. rewrite H4; auto.
- econstructor; split; simpl; eauto.
Qed.

Lemma make_sext_correct:
  forall s r x,
  vmatch bc e#r x ->
  let (op, args) := make_sext s r x in
  exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.sign_ext s e#r) v.
Proof.
  intros; unfold make_sext. destruct (vincl x (Sgn Ptop s)) eqn:INCL.
- exists e#r; split; auto.
  assert (V: vmatch bc e#r (Sgn Ptop s)).
  { eapply vmatch_ge; eauto. apply vincl_ge; auto. }
  inv V; simpl; auto. rewrite is_sgn_sign_ext in H4 by auto. rewrite H4; auto.
- econstructor; split; simpl; eauto.
Qed.

Lemma op_strength_reduction_correct:
  forall op args vl v,
  vl = map (fun r => AE.get r ae) args ->
  eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v ->
  let (op', args') := op_strength_reduction op args vl in
  exists w, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some w /\ Val.lessdef v w.
Proof.
  intros until v; unfold op_strength_reduction;
  case (op_strength_reduction_match op args vl); simpl; intros.
- (* add 1 *)
  rewrite Val.add_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_addimm_correct; auto.
- (* add 2 *)
  InvApproxRegs; SimplVM; inv H0. apply make_addimm_correct; auto.
- (* addshift *)
  InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shift_correct. apply make_addimm_correct; auto.
- (* sub *)
  InvApproxRegs; SimplVM; inv H0. rewrite Val.sub_add_opp. apply make_addimm_correct; auto.
- (* subshift *)
  InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shift_correct, Val.sub_add_opp. apply make_addimm_correct; auto.
- (* mul 1 *)
  rewrite Val.mul_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_mulimm_correct; auto.
- (* mul 2*)
  InvApproxRegs; SimplVM; inv H0. apply make_mulimm_correct; auto.
- (* divs *)
  assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto.
  apply make_divimm_correct; auto.
- (* divu *)
  assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto.
  apply make_divuimm_correct; auto.
- (* and 1 *)
  rewrite Val.and_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto.
- (* and 2 *)
  InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto.
- (* andshift *)
  InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shift_correct. apply make_andimm_correct; auto.
- (* andimm *)
  inv H; inv H0. apply make_andimm_correct; auto.
- (* or 1 *)
  rewrite Val.or_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_orimm_correct; auto.
- (* or 2 *)
  InvApproxRegs; SimplVM; inv H0. apply make_orimm_correct; auto.
- (* orshift *)
  InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shift_correct. apply make_orimm_correct; auto.
- (* xor 1 *)
  rewrite Val.xor_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_xorimm_correct; auto.
- (* xor 2 *)
  InvApproxRegs; SimplVM; inv H0. apply make_xorimm_correct; auto.
- (* xorshift *)
  InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shift_correct. apply make_xorimm_correct; auto.
- (* bic *)
  InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto.
- (* bicshift *)
  InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shift_correct. apply make_andimm_correct; auto.
- (* orn *)
  InvApproxRegs; SimplVM; inv H0. apply make_orimm_correct; auto.
- (* ornshift *)
  InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shift_correct. apply make_orimm_correct; auto.
- (* eor *)
  InvApproxRegs; SimplVM; inv H0. apply make_xorimm_correct; auto.
- (* eorshift *)
  InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shift_correct. apply make_xorimm_correct; auto.
- (* shl *)
  InvApproxRegs; SimplVM; inv H0. apply make_shlimm_correct; auto.
- (* shr *)
  InvApproxRegs; SimplVM; inv H0. apply make_shrimm_correct; auto.
- (* shru *)
  InvApproxRegs; SimplVM; inv H0. apply make_shruimm_correct; auto.
- (* zext *)
  InvApproxRegs; SimplVM; inv H0. apply make_zext_correct; auto.
- (* sext *)
  InvApproxRegs; SimplVM; inv H0. apply make_sext_correct; auto.
- (* addl 1 *)
  rewrite Val.addl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_addlimm_correct; auto.
- (* addl 2 *)
  InvApproxRegs; SimplVM; inv H0. apply make_addlimm_correct; auto.
- (* addshift *)
  InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shiftl_correct. apply make_addlimm_correct; auto.
- (* addext *)
  InvApproxRegs; SimplVM; inv H0. rewrite eval_static_extend_correct. apply make_addlimm_correct; auto.
- (* subl *)
  InvApproxRegs; SimplVM; inv H0. rewrite Val.subl_addl_opp. apply make_addlimm_correct; auto.
- (* sublshift *)
  InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shiftl_correct, Val.subl_addl_opp. apply make_addlimm_correct; auto.
- (* sublextend *)
  InvApproxRegs; SimplVM; inv H0. rewrite eval_static_extend_correct, Val.subl_addl_opp. apply make_addlimm_correct; auto.
- (* mull 1 *)
  rewrite Val.mull_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_mullimm_correct; auto.
- (* mull 2 *)
  InvApproxRegs; SimplVM; inv H0. apply make_mullimm_correct; auto.
- (* divl *)
  assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto.
  apply make_divlimm_correct; auto.
- (* divlu *)
  assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto.
  apply make_divluimm_correct; auto.
- (* andl 1 *)
  rewrite Val.andl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_andlimm_correct; auto.
- (* andl 2 *)
  InvApproxRegs; SimplVM; inv H0. apply make_andlimm_correct; auto.
- (* andlshift *)
  InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shiftl_correct. apply make_andlimm_correct; auto.
- (* andlimm *)
  inv H; inv H0. apply make_andlimm_correct; auto.
- (* orl 1 *)
  rewrite Val.orl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_orlimm_correct; auto.
- (* orl 2 *)
  InvApproxRegs; SimplVM; inv H0. apply make_orlimm_correct; auto.
- (* orlshift *)
  InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shiftl_correct. apply make_orlimm_correct; auto.
- (* xorl 1 *)
  rewrite Val.xorl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_xorlimm_correct; auto.
- (* xorl 2 *)
  InvApproxRegs; SimplVM; inv H0. apply make_xorlimm_correct; auto.
- (* xorlshift *)
  InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shiftl_correct. apply make_xorlimm_correct; auto.
- (* bicl *)
  InvApproxRegs; SimplVM; inv H0. apply make_andlimm_correct; auto.
- (* biclshift *)
  InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shiftl_correct. apply make_andlimm_correct; auto.
- (* ornl *)
  InvApproxRegs; SimplVM; inv H0. apply make_orlimm_correct; auto.
- (* ornlshift *)
  InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shiftl_correct. apply make_orlimm_correct; auto.
- (* eorl *)
  InvApproxRegs; SimplVM; inv H0. apply make_xorlimm_correct; auto.
- (* eorlshift *)
  InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shiftl_correct. apply make_xorlimm_correct; auto.
- (* shll *)
  InvApproxRegs; SimplVM; inv H0. apply make_shllimm_correct; auto.
- (* shrl *)
  InvApproxRegs; SimplVM; inv H0. apply make_shrlimm_correct; auto.
- (* shrlu *)
  InvApproxRegs; SimplVM; inv H0. apply make_shrluimm_correct; auto.
- (* cond *)
  inv H0. apply make_cmp_correct; auto.
- (* select *)
  inv H0. apply make_select_correct; congruence.
- (* mulf 1 *)
  InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfimm_correct; auto.
- (* mulf 2 *)
  InvApproxRegs; SimplVM; inv H0. fold (Val.mulf (Vfloat n1) e#r2).
  rewrite <- H2. apply make_mulfimm_correct_2; auto.
- (* mulfs 1 *)
  InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfsimm_correct; auto.
- (* mulfs 2 *)
  InvApproxRegs; SimplVM; inv H0. fold (Val.mulfs (Vsingle n1) e#r2).
  rewrite <- H2. apply make_mulfsimm_correct_2; auto.
- (* default *)
  exists v; auto.
Qed.

Lemma addr_strength_reduction_correct:
  forall addr args vl res,
  vl = map (fun r => AE.get r ae) args ->
  eval_addressing ge (Vptr sp Ptrofs.zero) addr e##args = Some res ->
  let (addr', args') := addr_strength_reduction addr args vl in
  exists res', eval_addressing ge (Vptr sp Ptrofs.zero) addr' e##args' = Some res' /\ Val.lessdef res res'.
Proof.
  intros until res. unfold addr_strength_reduction.
  destruct (addr_strength_reduction_match addr args vl); simpl;
  intros VL EA; InvApproxRegs; SimplVM; try (inv EA).
- econstructor; split; eauto. inv H0; simpl; auto. rewrite H2.
  unfold Genv.symbol_address. destruct (Genv.find_symbol ge symb); auto.
- rewrite Ptrofs.add_zero_l. econstructor; split; eauto.
  inv H0; auto. rewrite H2; auto.
- rewrite Ptrofs.add_zero_l. econstructor; split; eauto.
  inv H; auto. rewrite H3; auto.
- rewrite Ptrofs.add_zero_l. econstructor; split; eauto.
  inv H0; auto. rewrite H3. rewrite Ptrofs.add_commut; auto.
- econstructor; split; eauto. rewrite Val.addl_commut. auto.
- econstructor; split; eauto.
- rewrite Ptrofs.add_zero_l. rewrite a64_range. econstructor; split; eauto.
  inv H; auto. rewrite H3; auto.
- rewrite a64_range. econstructor; split; eauto.
- rewrite Ptrofs.add_zero_l, eval_static_extend_correct.
  econstructor; split; eauto. inv H; auto. rewrite H3; auto.
- rewrite eval_static_extend_correct.
  econstructor; split; eauto.
- exists res; auto.
Qed.

End STRENGTH_REDUCTION.


Require Import ConcurExec.
Require Import Morphisms.
Require Import ProofAutomation.
Require Import Helpers.ListStuff.
Require Import List.
Require Import Omega.

Import ListNotations.

Global Set Implicit Arguments.
Global Generalizable All Variables.

(** Inclusion of traces across state abstraction *)

Section StateAbstraction.

  Variable OpLo : Type -> Type.

  Variable StateLo : Type.
  Variable StateHi : Type.
  Variable absR : StateLo -> StateHi -> Prop.

  Variable lo_step : OpSemantics OpLo StateLo.
  Variable hi_step : OpSemantics OpLo StateHi.

  Hint Constructors exec_tid.

  Definition op_abs := forall T (op : OpLo T) s1 s1' s2 tid r evs,
    absR s1 s2 ->
    lo_step op tid s1 r s1' evs ->
      exists s2',
        absR s1' s2' /\
        hi_step op tid s2 r s2' evs.

  Variable op_abs_holds : op_abs.

  Theorem atomic_exec_abs : forall `(p : proc OpLo T) s1 s1' s2 tid r evs,
    absR s1 s2 ->
    atomic_exec lo_step p tid s1 r s1' evs ->
      exists s2',
        absR s1' s2' /\
        atomic_exec hi_step p tid s2 r s2' evs.
  Proof.
    intros.
    generalize dependent s2.
    induct H0; eauto.
    - edestruct IHatomic_exec1; intuition eauto.
      edestruct IHatomic_exec2; intuition eauto.
    - eapply op_abs_holds in H; eauto; deex.
      eexists; eauto.
    - edestruct IHatomic_exec; intuition eauto.
  Qed.

  Theorem exec_tid_abs : forall `(p : proc OpLo T) s1 s1' s2 tid res spawned evs,
    absR s1 s2 ->
    exec_tid lo_step tid s1 p s1' res spawned evs ->
      exists s2',
        absR s1' s2' /\
        exec_tid hi_step tid s2 p s2' res spawned evs.
  Proof.
    intros.
    induct H0; eauto.
    - eapply op_abs_holds in H0; eauto; deex.
      eexists; eauto.
    - eapply atomic_exec_abs in H0; eauto; deex.
      eexists; eauto.
  Qed.

  Theorem trace_incl_abs :
    forall s1 s2 (ts : threads_state OpLo) tr,
      absR s1 s2 ->
      exec lo_step s1 ts tr ->
      exec hi_step s2 ts tr.
  Proof.
    intros.
    generalize dependent s2.
    induct H0; eauto.
    - eapply exec_tid_abs in H3; propositional; eauto.
  Qed.

End StateAbstraction.


From Tealeaves.Classes Require Export
  Functor
  Monad
  Decorated.Functor
  Decorated.Monad
  Traversable.Functor
  Traversable.Monad
  DT.Functor
  DT.Monad.

From Tealeaves.Classes.Kleisli Require Export
  Monad
  Decorated.Functor
  Decorated.Monad
  Traversable.Functor
  Traversable.Monad
  DT.Functor
  DT.Monad.

Import Monoid.Notations.
Import Product.Notations.
Import Functor.Notations.
Import Kleisli.Monad.Notations.
Import Kleisli.Decorated.Monad.Notations.
Import Kleisli.Traversable.Monad.Notations.
Import Kleisli.DT.Monad.Notations.
Import Comonad.Notations.

#[local] Generalizable Variables A B C.

Module Operations.
  Section with_kleisli.

    Context
      (W : Type)
      (T : Type -> Type)
      `{Binddt W T T}
      `{Return T}.

    #[export] Instance Join_Binddt: Join T := fun A => binddt T (fun A => A) (B := A) (A := T A) (extract (W ×)).
    #[export] Instance Decorate_Binddt: Decorate W T := fun A => binddt T (fun A => A) (ret T).
    #[export] Instance Dist_Binddt: Dist T := fun G _ _ _ A => binddt T G (fmap G (ret T) ∘ extract (W ×)).

  End with_kleisli.
End Operations.

Import Operations.

Section with_monad.

  Context
    (W : Type)
    (T : Type -> Type)
    `{Kleisli.DT.Monad.Monad W T}.

  Import DT.Monad.Derived.

  (** *** Monad instance *)
  (******************************************************************************)
  Lemma ret_natural : Natural (@ret T _).
  Proof.
    constructor.
    - typeclasses eauto.
    - typeclasses eauto.
    - intros. unfold_ops @Fmap_Binddt.
      rewrite (kdtm_binddt0 W T _ _ (G := fun A => A)).
      reflexivity.
  Qed.

  Lemma join_natural : Natural (@join T _).
  Proof.
    constructor.
    - typeclasses eauto.
    - typeclasses eauto.
    - intros.
      unfold_ops @Fmap_compose.
      unfold_ops @Fmap_Binddt.
      unfold_ops @Join_Binddt.
      do 4 change (binddt T (fun A0 : Type => A0) ?f) with (bindd T (T := T) f).
      unfold_compose_in_compose.
      rewrite (kmond_bindd2_T W T). (* left *)
      rewrite (kmond_bindd2_T W T). (* right *)
      rewrite (Decorated.Monad.Derived.dm_kleisli_star2 T).
      reassociate -> near (extract (W ×)).
      rewrite (Derived.dm_kleisli_star1 T).
      fequal.
      rewrite cokleisli_id_l.
      reflexivity.
  Qed.

  Lemma join_ret : `(join T ∘ ret T = @id (T A)).
  Proof.
    intros.
    unfold_ops @Join_Binddt.
    unfold_compose_in_compose.
    rewrite (kdtm_binddt0 W T _ _ (G := fun A => A)).
    now rewrite bimonad_baton.
  Qed.

  Lemma join_fmap_ret : `(join T ∘ fmap T (ret T) = @id (T A)).
  Proof.
    intros.
    unfold_ops @Fmap_Binddt.
    unfold_ops @Join_Binddt.
    unfold_compose_in_compose.
    change (binddt T (fun A0 : Type => A0) (extract (prod W) (A := T A)))
      with (fmap (fun A => A) (binddt T (fun A0 : Type => A0) (extract (prod W) (A := T A)))).
    rewrite (kdtm_binddt2 W T _ _ _ (G1 := fun A => A) (G2 := fun A => A)).
    rewrite (dtm_kleisli_70 W T).
    rewrite <- (natural (ϕ := @extract (W ×) _)).
    change (fmap (fun A => A) ?f) with f.
    rewrite <- (kdtm_binddt1 W T).
    fequal. now rewrite Mult_compose_identity1.
    now rewrite Mult_compose_identity1.
  Qed.

  Lemma join_join :
    `(join T ∘ join T (A := T A) = join T ∘ fmap T (join T)).
  Proof.
    intros.
    unfold_ops @Join_Binddt.
    unfold_compose_in_compose.
    unfold compose at 4. (* hidden  *)
    rewrite (binddt_fmap T (fun A => A) _ _ _ (extract (W ×)) (binddt T (fun A0 : Type => A0) (extract (prod W)))).
    do 3 change (binddt T (fun A0 : Type => A0) ?f) with (bindd T (T := T) f).
    (* Merge LHS *)
    rewrite (kmond_bindd2 T).
    fequal. ext [w a]. cbn.
    now rewrite preincr_extract2.
  Qed.

  #[local] Instance: Classes.Monad.Monad T :=
    {| mon_ret_natural := ret_natural;
       mon_join_natural := join_natural;
       mon_join_ret := join_ret;
       mon_join_fmap_ret := join_fmap_ret;
       mon_join_join := join_join;
    |}.

  (** *** Decorated functor instance *)
  (******************************************************************************)
  Lemma dec_dec : forall (A : Type),
      dec T ∘ dec T = fmap T (cojoin (W ×)) ∘ dec T (A := A).
  Proof.
    intros.
    unfold_ops @Decorate_Binddt.
    change (fmap T (coμ (prod W) (A := A)))
      with (fmap (fun A => A) (fmap T (coμ (A := A) (prod W)))).
    rewrite (fmap_binddt T (fun A => A)); try typeclasses eauto.
    do 3 change (binddt T (fun A0 : Type => A0) ?f) with (bindd T (T := T) f).
    (* Merge LHS *)
    rewrite (kmond_bindd2 T).
    fequal.
    change (ret T) with (ret T ∘ (@id (W * A))) at 2.
    rewrite (Derived.dm_kleisli_star1 T).
    change (fmap (fun A => A) ?f) with f.
    rewrite (natural (ϕ := @ret T _ )).
    change (fmap (fun A => A) ?f) with f.
    ext [w a]. cbn. reflexivity.
  Qed.

  Lemma dec_extract : forall (A : Type),
      fmap T (extract (W ×)) ∘ dec T = @id (T A).
  Proof.
    intros.
    unfold_ops @Decorate_Binddt.
    unfold_ops @Fmap_Binddt.
    do 2 change (binddt T (fun A0 : Type => A0) ?f) with (bindd T (T := T) f).
    rewrite (kmond_bindd2 T).
    rewrite (Derived.dm_kleisli_star2 T).
    rewrite Monad.ToFunctor.kcompose01.
    change (ret T (A := W * A)) with (ret T ∘ @id (W * A)).
    reassociate <-. change (?g ∘ id) with g.
    rewrite (natural (ϕ := @ret T _ )).
    apply (kmond_bindd1 T).
  Qed.

  Lemma dec_natural : Natural (@dec W T _).
  Proof.
    constructor.
    - typeclasses eauto.
    - typeclasses eauto.
    - intros. unfold_ops @Fmap_compose.
      unfold_ops @Fmap_Binddt.
      unfold_ops @Decorate_Binddt.
      do 2 change (binddt T (fun A0 : Type => A0) ?f) with (bindd T (T := T) f).
      rewrite (kmond_bindd2 T).
      rewrite (kmond_bindd2 T).
      fequal.
      change (ret T (A := W * A)) with (ret T ∘ @id (W * A)).
      rewrite (Derived.dm_kleisli_star5 T).
      reassociate -> near (extract (W ×)).
      rewrite (Derived.dm_kleisli_star1 T).
      now rewrite cokcompose_misc1.
  Qed.

  #[local] Instance: Decorated.Functor.DecoratedFunctor W T :=
    {| dfun_dec_natural := dec_natural;
       dfun_dec_dec := dec_dec;
       dfun_dec_extract := dec_extract;
    |}.

  (** *** Decorated monad instance *)
  (******************************************************************************)
  Lemma dmon_ret_ : forall (A : Type),
      dec T ∘ ret T = ret T ∘ pair Ƶ (B:=A).
  Proof.
    intros.
    unfold_ops @Decorate_Binddt.
    change (binddt T (fun A0 : Type => A0) ?f) with (bindd T (T := T) f).
    now rewrite (kmond_bindd0 T).
  Qed.

  Lemma dmon_join_ : forall (A : Type),
      dec T ∘ join T (A:=A) = join T ∘ fmap T (shift T) ∘ dec T ∘ fmap T (dec T).
  Proof.
    intros. unfold shift, strength.
    unfold_ops @Decorate_Binddt.
    unfold_ops @Fmap_Binddt.
    unfold_ops @Join_Binddt.
    repeat change (binddt T (fun A0 : Type => A0) ?f) with (bindd T (T := T) f).
    unfold_compose_in_compose.
    repeat rewrite (kmond_bindd2 T).
    fequal. reassociate -> near (extract (W ×)).
    rewrite (Derived.dm_kleisli_star1 T).
    rewrite (Derived.dm_kleisli_star1 T).
    rewrite cokcompose_misc1.
    rewrite cokleisli_id_l.
    rewrite (Derived.dm_kleisli_star2 T).
    ext [w t].
    unfold Monad.kcompose.
    rewrite (Monad.kmon_bind0 T).
    unfold compose; cbn.
    compose near t on right.
    rewrite (kmond_bindd2 T).
    compose near t on right.
    rewrite (kmond_bindd2 T).
    fequal. ext [w' a].
    cbn. compose near (w', a) on right.
    rewrite (kmond_bindd0 T).
    unfold compose. cbn.
    compose near (w', a) on right.
    rewrite preincr_ret.
    unfold compose; cbn.
    compose near (id w, (w', a)) on right.
    rewrite (kmond_bindd0 T).
    rewrite preincr_ret.
    reflexivity.
  Qed.

  #[local] Instance: Decorated.Monad.DecoratedMonad W T :=
    {| dmon_ret := dmon_ret_;
       dmon_join := dmon_join_;
    |}.

  (** *** Traversable functor instance *)
  (******************************************************************************)
  Lemma dist_natural_T : forall (G : Type -> Type) (H2 : Fmap G) (H3 : Pure G) (H4 : Mult G),
      Applicative G -> Natural (@dist T _ G H2 H3 H4).
  Proof.
    intros. constructor.
    - typeclasses eauto.
    - typeclasses eauto.
    - intros.
      unfold_ops @Fmap_compose @Dist_Binddt @Fmap_Binddt.
      change_left (fmap G (fmap T f) ∘ bindt T G (fmap G (ret T))).
      rewrite (fmap_bindt T G).
      rewrite (fun_fmap_fmap G).
      (* RHS *)
      change_right (
          bindt T G (fmap G (ret T)) ∘
            bind T (ret T ∘ fmap G f)).
      rewrite (bindt_bind T G).
      reassociate <- on right.
      rewrite (ktm_bindt0 T); [|assumption].
      rewrite (fun_fmap_fmap G).
      rewrite (natural (ϕ := @ret T _)).
      reflexivity.
  Qed.

  Lemma dist_morph_T : forall (G1 G2 : Type -> Type) (H2 : Fmap G1) (H3 : Pure G1) (H4 : Mult G1) (H5 : Fmap G2)
                         (H6 : Pure G2) (H7 : Mult G2) (ϕ : forall A : Type, G1 A -> G2 A),
      ApplicativeMorphism G1 G2 ϕ -> forall A : Type, dist T G2 ∘ fmap T (ϕ A) = ϕ (T A) ∘ dist T G1.
  Proof.
    introv morph. inversion morph.
    intros.
    unfold_ops @Dist_Binddt @Fmap_Binddt.
    change (fmapdt T G2 (extract (prod W)) ∘ fmap T (ϕ A)
            = ϕ (T A) ∘ traverse T G1 (@id (G1 A))).
    change (@Fmap_Binddt T W H0 H)
      with (@Derived.Fmap_Fmapdt T W _).
    rewrite (Derived.fmapdt_fmap T G2).
    rewrite (trf_traverse_morphism T).
    rewrite <- (natural (ϕ := @extract (W ×) _)).
    reflexivity.
  Qed.

  Lemma dist_unit_T : forall A : Type,
      dist T (fun A0 : Type => A0) = @id (T A).
  Proof.
    intros. unfold_ops @Dist_Binddt.
    apply (kdtm_binddt1 W T).
  Qed.

  Lemma dist_linear_T : forall (G1 : Type -> Type) (H2 : Fmap G1) (H3 : Pure G1) (H4 : Mult G1),
      Applicative G1 ->
      forall (G2 : Type -> Type) (H6 : Fmap G2) (H7 : Pure G2) (H8 : Mult G2),
        Applicative G2 -> forall A : Type, dist T (G1 ∘ G2) (A := A) = fmap G1 (dist T G2) ∘ dist T G1.
  Proof.
    intros. unfold_ops @Dist_Binddt.
    rewrite (kdtm_binddt2 W T); try typeclasses eauto.
    fequal.
    rewrite (kcompose_dtm_33 W T).
    change (fmap G1 (ret T (A := G2 A))) with (fmap G1 (ret T) ∘ @id (G1 (G2 A))).
    rewrite (Derived.kcompose_tm31 (fmap G2 (ret T))).
    reflexivity.
  Qed.

  #[export] Instance: Traversable.Functor.TraversableFunctor T :=
    {| dist_natural := dist_natural_T;
       dist_morph := dist_morph_T;
       dist_unit := dist_unit_T;
       dist_linear := dist_linear_T;
    |}.

  (** *** Decorated Traversable functor instance *)
  (******************************************************************************)
  Lemma dtfun_compat_T : forall (G : Type -> Type) (H2 : Fmap G) (H3 : Pure G) (H4 : Mult G),
      Applicative G -> forall A : Type,
        dist T G ∘ fmap T (strength G) ∘ dec (A := G A) T = fmap G (dec T) ∘ dist T G.
  Proof.
    intros. unfold_ops @Dist_Binddt @Fmap_Binddt @Decorate_Binddt.
    change (fmapdt T G (extract (prod W)) ∘ fmapd T (strength G ∘ extract (prod W)) ∘ fmapd T (@id (W * G A)) =
              fmap G (fmapd T id) ∘ fmapdt T G (extract (prod W))).
    rewrite (fmapdt_fmapd T G).
    rewrite (fmapdt_fmapd T G).
    rewrite (fmapd_fmapdt T G).
    rewrite (cobind_id (W ×)).
    rewrite (fun_fmap_id G).
    fequal. ext [w a].
    reflexivity.
  Qed.

  #[export] Instance: DT.Functor.DecoratedTraversableFunctor W T :=
    {| dtfun_compat := dtfun_compat_T;
    |}.

  (** *** Traversable monad instance *)
  (******************************************************************************)
  Lemma trvmon_ret_T : forall (G : Type -> Type) (H3 : Fmap G) (H4 : Pure G) (H5 : Mult G),
      Applicative G -> forall A : Type, dist T G ∘ ret T (A := G A) = fmap G (ret T).
  Proof.
    intros. unfold_ops @Dist_Binddt @Fmap_Binddt.
    rewrite (kdtm_binddt0 W T); [|assumption].
    ext a. reflexivity.
  Qed.

  Lemma trvmon_join_T : forall (G : Type -> Type) (H3 : Fmap G) (H4 : Pure G) (H5 : Mult G),
      Applicative G -> forall A : Type, dist T G ∘ join T = fmap G (join T) ∘ dist (T ∘ T) G (A := A).
  Proof.
    intros.
    unfold_ops @Dist_compose.
    unfold_ops @Dist_Binddt @Fmap_Binddt @Join_Binddt.
    change_left (bindt T G (fmap G (ret T)) ∘ bind T (@id (T (G A)))).
    change_right (fmap G (bind T (@id (T A)))
                    ∘ (bindt T G (fmap G (ret T))
                         ∘ bind T (ret T ∘ bindt T G (fmap G (ret T))))).
    rewrite (bindt_bind T G).
    rewrite (bindt_bind T G).
    reassociate <-. rewrite (ktm_bindt0 T); [|typeclasses eauto].
    rewrite (bind_bindt T G).
    reassociate <- on right.
    rewrite (fun_fmap_fmap G).
    rewrite (kmon_bind0 T).
    rewrite (fun_fmap_id G).
    reflexivity.
  Qed.

  #[export] Instance: Traversable.Monad.TraversableMonad T :=
    {| trvmon_ret := trvmon_ret_T;
      trvmon_join := trvmon_join_T;
    |}.

  (** *** Decorated Traversable monad instance *)
  (******************************************************************************)
  #[export] Instance: DT.Monad.DecoratedTraversableMonad W T :=
    ltac:(constructor; typeclasses eauto).

End with_monad.

#[local] Generalizable Variables T W.

Module AlgebraicToKleisli.

  Context
    `{Monoid W}
    `{fmapT : Fmap T}
    `{distT : Dist T}
    `{joinT : Join T}
    `{decorateT : Decorate W T}
    `{Return T}
    `{! Classes.DT.Monad.DecoratedTraversableMonad W T}.

  #[local] Instance binddt' : Binddt W T T := ToKleisli.Binddt_ddj T.

  Definition fmap' : Fmap T := Derived.Fmap_Binddt T.
  Definition join' : Join T := Operations.Join_Binddt W T.
  Definition decorate' : Decorate W T := Operations.Decorate_Binddt W T.
  Definition dist' : Dist T := Operations.Dist_Binddt W T.

  Goal fmapT = fmap'.
  Proof.
    unfold fmap'. unfold_ops @Derived.Fmap_Binddt.
    unfold binddt, binddt'.
    unfold_ops @ToKleisli.Binddt_ddj.
    ext A B f.
    unfold_ops @Fmap_I.
    rewrite (dist_unit T).
    change (?f ∘ id) with f.
    do 2 rewrite <- (fun_fmap_fmap T).
    do 2 reassociate <- on right.
    rewrite (mon_join_fmap_ret T).
    change (id ∘ ?f) with f.
    reassociate -> on right.
    rewrite (dfun_dec_extract W T).
    reflexivity.
  Qed.

  Goal forall G `{Applicative G}, @distT G _ _ _ = @dist' G _ _ _.
  Proof.
    intros.
    unfold dist'. unfold_ops @Operations.Dist_Binddt.
    unfold binddt, binddt'.
    unfold_ops @ToKleisli.Binddt_ddj.
    ext A.
    rewrite <- (fun_fmap_fmap T).
    unfold_compose_in_compose.
    reassociate <- on right.
    reassociate -> near (fmap T (fmap G (ret T (A := A)))).
    change (fmap T (fmap G (ret T (A := A))))
      with ((fmap (T ○ G) (ret T (A := A)))).
    rewrite <- (natural (ϕ := @dist T _ G _ _ _)).
    unfold_ops @Fmap_compose.
    reassociate <- on right.
    rewrite (fun_fmap_fmap G).
    rewrite (mon_join_fmap_ret T).
    rewrite (fun_fmap_id G).
    reassociate -> on right.
    rewrite (dfun_dec_extract W T).
    reflexivity.
  Qed.

  Goal joinT = join'.
  Proof.
    unfold join'. unfold_ops @Operations.Join_Binddt.
    unfold binddt, binddt'.
    unfold_ops @ToKleisli.Binddt_ddj.
    ext A.
    rewrite (dist_unit T).
    reassociate -> on right.
    rewrite (dfun_dec_extract W T).
    reflexivity.
  Qed.

  Goal decorateT = decorate'.
  Proof.
    unfold decorate'. unfold_ops @Operations.Decorate_Binddt.
    unfold binddt, binddt'.
    unfold_ops @ToKleisli.Binddt_ddj @Fmap_I.
    ext A.
    rewrite (dist_unit T).
    change (?f ∘ id) with f.
    rewrite (mon_join_fmap_ret T).
    reflexivity.
  Qed.

End AlgebraicToKleisli.

Module KleisliToAlgebraic.

  Context
    `{binddtT : Binddt W T T}
    `{Monoid W}
    `{Return T}
    `{! Classes.Kleisli.DT.Monad.Monad W T}.

  #[local] Instance fmap' : Fmap T := Derived.Fmap_Binddt T.
  #[local] Instance dist' : Dist T := Operations.Dist_Binddt W T.
  #[local] Instance join' : Join T := Operations.Join_Binddt W T.
  #[local] Instance decorate' : Decorate W T := Operations.Decorate_Binddt W T.

  Definition binddt' : Binddt W T T := ToKleisli.Binddt_ddj T.

  Import Derived.

  Goal forall G `{Applicative G}, @binddtT G _ _ _ = @binddt' G _ _ _ .
  Proof.
    intros.
    unfold binddt'. unfold_ops @ToKleisli.Binddt_ddj.
    ext A B f.
    unfold fmap at 2, fmap', Fmap_Binddt.
    unfold dist, dist', Dist_Binddt.
    unfold dec, decorate', Decorate_Binddt.
    change_right (fmap G (join T) ∘ bindt T G (fmap G (ret T))
                    ∘ fmap T f ∘ bindd T (ret T)).
    reassociate -> on right.
    unfold fmap'.
    change (@Fmap_Binddt T W _ _) with (@Derived.Fmap_Bindd T _ W _).
    rewrite (Derived.fmap_bindd T).
    reassociate -> on right.
    unfold_compose_in_compose.
    rewrite (Derived.bindt_bindd T G).
    reassociate <- on right.
    Set Keyed Unification.
    rewrite (Kleisli.DT.Monad.Derived.bindt_fmap T G).
    Unset Keyed Unification.
    rewrite (ktm_bindt0 T); [| assumption].
    unfold join, join'; unfold_ops @Operations.Join_Binddt.
    unfold compose at 2.
    rewrite (kdtm_binddt2 W T _ _ _ (G1 := G) (G2 := fun A => A)).
    change_left (binddt T G f).
    fequal. now rewrite Mult_compose_identity1.
    change (extract (A := ?A) (W ×)) with (id ∘ extract (A := A) (W ×)).
    rewrite (Derived.dtm_kleisli_37 W T (A := A) (C := B) (B := T B) (G2 := fun A => A)).
    rewrite (@Traversable.Monad.Derived.kcompose_tm21 T _ _ _ G); [|assumption].
    rewrite (fun_fmap_id G).
    reflexivity.
  Qed.

End KleisliToAlgebraic.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*              Layers of VMM                                          *)
(*                                                                     *)
(*          Refinement proof for PTIntro layer                         *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

(** This file provide the contextual refinement proof between MAL layer and MPTIntro layer*)
Require Import PTIntroGenDef.
Require Export PTIntroGenAccessorDef.

(** * Definition of the refinement relation*)
Section Refinement.

  Section WITHMEM.

    Context `{Hstencil: Stencil}.
    Context `{Hmem: Mem.MemoryModel}.
    Context `{Hmwd: UseMemWithData mem}.

    Require Import LoadStoreSem1.
    Require Import XOmega.
    Require Import HostAccess1.
    Require Import GuestAccessIntel1.
    Require Import HostAccess2.
    Require Import LoadStoreGeneral.

    Notation lLoad := (fun F V => exec_loadex1 (F:=F) (V:=V)).
    Notation hLoad := (fun F V => exec_loadex2 (F:=F) (V:=V)).

    Lemma load_correct:
      load_accessor_sim_def HDATAOps LDATAOps (one_crel HDATA LDATA) hLoad lLoad.
    Proof.
      unfold load_accessor_sim_def. intros.
      pose proof H2 as Hmatch.
      inv H2. inv match_extcall_states.

      unfold exec_loadex2 in *.
      unfold exec_loadex1.
      unfold exec_host_load1, exec_host_load2 in *. inv H4.
      exploit (eval_addrmode_correct ge1 ge2 a); eauto. intros HW.
      Local Opaque Z.sub.
      simpl in *. revert H1. inv match_related. subrewrite''. intros HLoad.
      destruct (eval_addrmode ge1 a rs1) eqn: Hev; contra_inv.
      - (* addr is Vint*)
        inv HW. destruct (ihost d2) eqn:HPH; contra_inv.
        destruct (pg d2) eqn:HPE; contra_inv.
        destruct (ikern d2) eqn:HPK; contra_inv.
        specialize (valid_PT refl_equal).
        + (* host *)
          generalize match_match; intros HM. inv match_match.
          inv H1. inv relate_PT_re.
          * (* PT = -1 *)
            rewrite <- H7 in valid_PT; omega.
          * assert (HFB: Genv.find_symbol ge2 PTPool_LOC = Some b).
            {
              inv H0. congruence.
            }
            rewrite HFB. lift_trivial. subrewrite'.
            assert (valid_PT': 0 <= PT d1 < 64) by omega.
            specialize (H5 _ valid_PT').
            set (pt := (ZMap.get (PT d1) (ptpool d1))) in *. inv H5.
            assert (HI: 0<= PDX (Int.unsigned i) <= PDX Int.max_unsigned).
            {
              specialize (Int.unsigned_range_2 i).
              clear. unfold PDX. Local Transparent Z.sub.
              xomega. Local Opaque Z.sub.
            }
            specialize (H7 _ HI).
            destruct H7 as [v[HLD [_ HP]]].
            assert (HI1: 0<= PTX (Int.unsigned i) <= PTX Int.max_unsigned).
            {
              unfold PTX; change ((Int.max_unsigned / 4096) mod 1024) with 1023.
              specialize (Z_mod_lt (Int.unsigned i/PgSize) one_k).
              omega.
            }
            (*unfold PMap, ZMap.t, PMap.t in *.*)
            inv HP; try rewrite <- H9 in HLoad; try rewrite <- H5 in HLoad; contra_inv.
            pose proof relate_PMap_re as HPP.
            inv HPP. specialize (H9 _ valid_PT' _ HI pi pdx).
            rewrite H5 in H9. specialize (H9 refl_equal _ HI1).
            destruct H9 as [v1[HLD1 HP]].
            rewrite Int.unsigned_repr; [|rewrite_omega].
            rewrite HLD, H7.
            rewrite Z_div_plus_full_l; [|omega].
            rewrite (Zdiv_small PT_PERM_PTU); [|omega].
            rewrite Z.add_0_r. rewrite HLD1. clear HLD1.
            destruct (zle (Int.unsigned i mod 4096) (4096 - size_chunk chunk)); contra_inv.
            destruct (Zdivide_dec (align_chunk chunk) (Int.unsigned i mod 4096)
                                  (Memdata.align_chunk_pos chunk)); contra_inv.
            inv HP; try rewrite <- H11 in HLoad; contra_inv.
            {
              change (Int.unsigned Int.zero mod 4096) with 0; simpl.
              eapply pagefault_correct; eauto.
            }
            {
              rewrite <- H9 in HLoad; contra_inv. rewrite H12.
              assert (HW1: (padr * PgSize + v) mod PgSize = v mod PgSize).
              {
                rewrite Zplus_mod.
                rewrite Z_mod_mult.
                rewrite Z.add_0_l.
                apply Zmod_mod.
              }
              assert (HW2: (padr * PgSize + v) / PgSize = padr).
              {
                rewrite Z_div_plus_full_l; [|omega].
                rewrite (Zdiv_small v). omega.
                functional inversion H11; subst; omega.
              }
              rewrite HW1, HW2.
              functional inversion H11; rewrite <- H13 in HLoad; contra_inv;
              (rewrite Zmod_small; trivial; [|omega]; simpl;
               eapply exec_flatmem_load_correct; eauto).
            }
        + (* guest *)
          eapply guest_intel_load_correct1; eauto.
      - (* adr is (b,ofs) *)
        inv HW; subdestruct; eapply loadl_correct; eauto.
    Qed.

  End WITHMEM.

End Refinement.


Require Import VST.floyd.proofauto.
Require Import sll_singleton.
From SSL_VST Require Import core.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition malloc_spec :=
  DECLARE _malloc
        WITH t: type
        PRE [ tuint ]
        PROP()
        PARAMS(Vint (Int.repr (sizeof t)))
        SEP()
        POST [tptr tvoid] EX p:_,
        PROP()
        RETURN(p)
        SEP(data_at_ Tsh t p).

Inductive sll_card : Set :=
    | sll_card_0 : sll_card
    | sll_card_1 : sll_card -> sll_card.

Fixpoint sll (x: val) (s: (list Z)) (self_card: sll_card) {struct self_card} : mpred := match self_card with
    | sll_card_0  =>  !!((x : val) = nullval) && !!((s : list Z) = ([] : list Z)) && emp
    | sll_card_1 _alpha_513 =>
      EX v : Z,
      EX s1 : (list Z),
      EX nxt : val,
 !!(Int.min_signed <= v <= Int.max_signed) && !!(is_pointer_or_null nxt) && !!(~ ((x : val) = nullval)) && !!((s : list Z) = (([(v : Z)] : list Z) ++ (s1 : list Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 2) [(inl ((Vint (Int.repr v)) : val)); (inr (nxt : val))] (x : val)) * (sll (nxt : val) (s1 : list Z) (_alpha_513 : sll_card))
end.

Definition sll_singleton_spec :=
  DECLARE _sll_singleton
   WITH x: val, p: val, a: val
   PRE [ tint, (tptr (Tunion _sslval noattr)) ]
   PROP( ssl_is_valid_int((x : val)); is_pointer_or_null((p : val)); is_pointer_or_null((a : val)) )
   PARAMS(x; p)
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [(inr (a : val))] (p : val)))
   POST[ tvoid ]
   EX y: val,
   EX elems: (list Z),
   EX _alpha_514: sll_card,
   PROP( ((elems : list Z) = ([(force_signed_int (x : val))] : list Z)); is_pointer_or_null((y : val)) )
   LOCAL()
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [(inr (y : val))] (p : val)); (sll (y : val) (elems : list Z) (_alpha_514 : sll_card))).

Lemma sll_x_valid_pointerP x s self_card: sll x s self_card |-- valid_pointer x. Proof. destruct self_card; simpl; entailer;  entailer!; eauto. Qed.
Hint Resolve sll_x_valid_pointerP : valid_pointer.
Lemma sll_local_factsP x s self_card :
  sll x s self_card|-- !!(((((x : val) = nullval)) -> (self_card = sll_card_0))/\(((~ ((x : val) = nullval))) -> (exists _alpha_513, self_card = sll_card_1 _alpha_513))/\is_pointer_or_null((x : val))).
 Proof.  destruct self_card;  simpl; entailer; saturate_local; apply prop_right; eauto. Qed.
Hint Resolve sll_local_factsP : saturate_local.
Lemma unfold_sll_card_0  (x: val) (s: (list Z)) : sll x s (sll_card_0 ) =  !!((x : val) = nullval) && !!((s : list Z) = ([] : list Z)) && emp. Proof. auto. Qed.
Lemma unfold_sll_card_1 (_alpha_513 : sll_card) (x: val) (s: (list Z)) : sll x s (sll_card_1 _alpha_513) =
      EX v : Z,
      EX s1 : (list Z),
      EX nxt : val,
 !!(Int.min_signed <= v <= Int.max_signed) && !!(is_pointer_or_null nxt) && !!(~ ((x : val) = nullval)) && !!((s : list Z) = (([(v : Z)] : list Z) ++ (s1 : list Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 2) [(inl ((Vint (Int.repr v)) : val)); (inr (nxt : val))] (x : val)) * (sll (nxt : val) (s1 : list Z) (_alpha_513 : sll_card)). Proof. auto. Qed.
Definition Gprog : funspecs :=
  ltac:(with_library prog [sll_singleton_spec; malloc_spec]).

Lemma body_sll_singleton : semax_body Vprog Gprog f_sll_singleton sll_singleton_spec.
Proof.
start_function.
ssl_open_context.
assert_PROP (isptr p). { entailer!. }
try rename a into a2.
forward.
forward_call (tarray (Tunion _sslval noattr) 2).
Intros y2.
assert_PROP (isptr y2). { entailer!. }
forward.
forward.
forward.
forward; entailer!.
Exists (y2 : val).
Exists ([(x : Z)] : list Z).
Exists (sll_card_1 (sll_card_0  : sll_card) : sll_card).
ssl_entailer.
rewrite (unfold_sll_card_1 (sll_card_0  : sll_card)) at 1.
Exists (x : Z).
Exists ([] : list Z).
Exists nullval.
ssl_entailer.
rewrite (unfold_sll_card_0 ) at 1.
ssl_entailer.

Qed.