Require Import msl.msl_standard.
Require Import msl.Coqlib2.
Require Import veric.shares.

Section UNPROVABLE.

Variable wishes_eq_horses : False.

Lemma unrel_glb:
 forall a b,
    Share.unrel a b = Share.unrel a (Share.glb a b).
contradiction wishes_eq_horses.
Qed.

Lemma share_rel_unrel':
  forall r sh,
    Share.rel r (Share.unrel r sh) = Share.glb r sh.
Proof.
contradiction wishes_eq_horses.
Qed.

Lemma share_sub_Lsh:
forall sh, identity (Share.unrel Share.Rsh sh) -> join_sub sh Share.Lsh.
Proof.
 intros.
 rewrite (Share.decompose_Rsh sh) in H.
 remember (decompose sh).
 symmetry in Heqp. destruct p as [sh1 sh2].
 simpl in H.
 apply identity_share_bot in H. subst.
 generalize (top_correct' sh1);intro.
 destruct H.
 exists (Share.recompose (x, Share.bot)).
 rewrite Share.Lsh_recompose.
 assert (sh = Share.recompose (sh1, Share.bot)).
  rewrite <- Heqp. rewrite Share.recompose_decompose. trivial.
 rewrite H0.
 eapply Share.decompose_join.
 rewrite Share.decompose_recompose. f_equal.
 rewrite Share.decompose_recompose. f_equal.
 rewrite Share.decompose_recompose. f_equal.
 split. trivial.
 split. apply Share.glb_bot. apply Share.lub_bot.
Qed.

Lemma join_splice2_aux:
forall a1 a2 a3 b1 b2 b3,
Share.lub (Share.rel Share.Lsh (Share.lub a1 a2)) (Share.rel Share.Rsh (Share.lub b1 b2))
= Share.lub (Share.rel Share.Lsh a3) (Share.rel Share.Rsh b3) ->
Share.lub a1 a2 = a3 /\ Share.lub b1 b2 = b3.
Proof with try tauto.
 intros. rewrite Share.lub_rel_recompose in H.
 generalize (Share.decompose_recompose (Share.lub a1 a2, Share.lub b1 b2));intro.
 rewrite H in H0.
 rewrite Share.lub_rel_recompose in H0.
 rewrite Share.decompose_recompose in H0.
 split;congruence.
Qed.

Lemma share_rel_unrel:
  forall r sh,
    join_sub sh r ->
    Share.rel r (Share.unrel r sh) = sh.
Proof.
intros.
rewrite share_rel_unrel'.
destruct H as [a [H H0]].
subst r.
rewrite Share.glb_commute.
rewrite Share.distrib1.
rewrite H.
rewrite Share.lub_bot.
apply Share.glb_idem.
Qed.

Lemma glb_rel_Lsh_Rsh:
 forall a b, Share.glb (Share.rel Share.Lsh a) (Share.rel Share.Rsh b) = Share.bot.
Proof.
intros.
assert (H := rel_leq Share.Lsh a).
assert (H0 := rel_leq Share.Rsh b).
apply leq_join_sub in H.
apply leq_join_sub in H0.
forget (Share.rel Share.Lsh a) as aL.
forget (Share.rel Share.Rsh b) as bR.
apply Share.ord_antisym; [ | apply Share.bot_correct].
rewrite <- glb_Lsh_Rsh.
forget Share.Lsh as L.
forget Share.Rsh as R.
apply glb_less_both; auto.
Qed.

Lemma glb_Rsh_rel_Lsh_sh:
 forall sh,
  Share.glb Share.Rsh (Share.rel Share.Lsh sh) = Share.bot.
Proof.
intros.
destruct (Share.split Share.top) eqn:?.
unfold Share.Rsh, Share.Lsh. rewrite Heqp; simpl.
rewrite Share.glb_commute.
destruct (rel_join t t t0 _ (split_join _ _ _ Heqp)).
clear - H Heqp.
pose proof (rel_leq t t0).
rewrite <- leq_join_sub in H0.
rewrite Share.ord_spec1 in H0.
rewrite H0 in H.
rewrite <- Share.glb_assoc in H.
rewrite <- Share.rel_preserves_glb in H.
pose proof (rel_leq t (Share.glb t t0)).
apply leq_join_sub in H1.
apply Share.ord_spec1 in H1. rewrite <- H1 in H.
clear H1.
pose proof bot_identity. rewrite <- H in H1.
apply (rel_nontrivial) in H1.
destruct H1.
apply split_nontrivial' in Heqp; auto.
apply identity_share_bot in Heqp.
apply Share.nontrivial in Heqp; contradiction.
clear H.
apply identity_share_bot in H1.
clear - H1.
pose proof (rel_leq t sh).
forget (Share.rel t sh) as b.
destruct H as [a [? ?]].
subst t.
rewrite Share.glb_commute in H1; rewrite Share.distrib1 in H1.
rewrite Share.glb_commute in H1.
pose proof (Share.lub_upper1 (Share.glb b t0) (Share.glb t0 a)).
rewrite H1 in H0.
apply Share.ord_antisym; auto.
apply Share.bot_correct.
Qed.

Lemma right_nonempty_readable:
  forall rsh sh, sepalg.nonidentity sh <->
     readable_share (Share.splice rsh sh).
Proof.
intros.
unfold readable_share, Share.splice.
unfold nonempty_share,nonidentity.
assert (identity sh <-> identity (Share.glb Share.Rsh (Share.lub (Share.rel Share.Lsh rsh) (Share.rel Share.Rsh sh))));
  [ | intuition].
split; intro.
*
apply identity_share_bot in H. subst.
rewrite Share.rel_bot1.
rewrite Share.lub_bot.
rewrite glb_Rsh_rel_Lsh_sh.
apply bot_identity.
*
rewrite Share.distrib1 in H.
rewrite glb_Rsh_rel_Lsh_sh in H.
rewrite Share.lub_commute, Share.lub_bot in H.
assert (identity (Share.glb (Share.rel Share.Rsh Share.top) (Share.rel Share.Rsh sh)))
  by (rewrite Share.rel_top1; auto).
clear H.
rewrite <- Share.rel_preserves_glb in H0.
rewrite Share.glb_commute, Share.glb_top in H0.
apply rel_nontrivial in H0.
destruct H0; auto.
unfold Share.Rsh in H.
destruct (Share.split Share.top) eqn:?; simpl in *.
apply split_nontrivial' in Heqp; auto.
apply top_share_nonidentity in Heqp.
contradiction.
Qed.

Lemma writable_share_right: forall sh, writable_share sh -> Share.unrel Share.Rsh sh = Share.top.
Proof.
 intros.
 apply Share.contains_Rsh_e.
 apply H.
Qed.

Lemma unrel_bot:
 forall sh, nonidentity sh -> Share.unrel sh Share.bot = Share.bot.
Proof.
intros.
rewrite <- (Share.rel_bot1 sh) at 1.
rewrite Share.unrel_rel; auto.
Qed.

Lemma join_splice2_aux1:
  forall a1 a2 b1 b2,
  Share.lub (Share.rel Share.Lsh (Share.glb a1 a2)) (Share.rel Share.Rsh (Share.glb b1 b2)) = Share.bot ->
  Share.glb a1 a2 = Share.bot /\ Share.glb b1 b2 = Share.bot.
Proof. intros.
  rewrite !Share.rel_preserves_glb in H.
  apply lub_bot_e in H; destruct H.
  rewrite <- Share.rel_preserves_glb in H, H0.
  pose proof (rel_nontrivial Share.Lsh (Share.glb a1 a2)).
  rewrite H in H1. specialize (H1 bot_identity). clear H.
  pose proof (rel_nontrivial Share.Rsh (Share.glb b1 b2)).
  rewrite H0 in H. specialize (H bot_identity). clear H0.
  destruct H1. contradiction (Lsh_nonidentity H0).
  destruct H. contradiction (Rsh_nonidentity H).
  apply identity_share_bot in H.
  apply identity_share_bot in H0.
  auto.
Qed.

Lemma join_splice:
  forall a1 a2 a3 b1 b2 b3,
 sepalg.join a1 a2 a3 ->
 sepalg.join b1 b2 b3 ->
 sepalg.join (Share.splice a1 b1)  (Share.splice a2 b2)  (Share.splice a3 b3).
Proof.
intros.
unfold Share.splice.
destruct H, H0.
split.
*
rewrite Share.distrib1.
do 2 rewrite (Share.glb_commute (Share.lub _ _)).
rewrite Share.distrib1.
rewrite Share.distrib1.
rewrite !(Share.glb_commute (Share.rel _ a2)).
rewrite !(Share.glb_commute (Share.rel _ b2)).
rewrite <- !Share.rel_preserves_glb.
rewrite H,H0.
rewrite !Share.rel_bot1.
rewrite (Share.lub_commute Share.bot).
rewrite !Share.lub_bot.
rewrite Share.glb_commute.
rewrite !glb_rel_Lsh_Rsh.
apply Share.lub_bot.
*
subst a3 b3.
rewrite !Share.rel_preserves_lub.
forget (Share.rel Share.Lsh a1) as La1.
forget (Share.rel Share.Rsh b1) as Rb1.
forget (Share.rel Share.Lsh a2) as La2.
forget (Share.rel Share.Rsh b2) as Rb2.
rewrite !Share.lub_assoc.
f_equal.
rewrite Share.lub_commute.
rewrite !Share.lub_assoc.
f_equal.
apply Share.lub_commute.
Qed.

Lemma splice_bot2:
 forall sh, Share.splice sh Share.bot = Share.rel Share.Lsh sh.
Proof.
intros.
unfold Share.splice.
rewrite Share.rel_bot1.
rewrite Share.lub_bot.
auto.
Qed.

Lemma splice_unrel_unrel:
  forall sh,
   Share.splice (Share.unrel Share.Lsh sh) (Share.unrel Share.Rsh sh) = sh.
Proof.
intros.
unfold Share.splice.
rewrite !share_rel_unrel'.
rewrite share_distrib2'.
rewrite Share.lub_idem.
rewrite lub_Lsh_Rsh.
rewrite (Share.glb_commute Share.top).
rewrite Share.glb_top.
rewrite <- Share.glb_assoc.
rewrite (Share.lub_commute sh).
rewrite share_distrib1'.
rewrite (Share.glb_commute Share.Rsh).
rewrite glb_Lsh_Rsh.
rewrite (Share.lub_commute Share.bot), Share.lub_bot.
rewrite Share.glb_idem.
rewrite (Share.glb_commute sh).
rewrite <- Share.lub_assoc.
rewrite Share.glb_commute.
rewrite Share.lub_commute.
rewrite Share.glb_absorb.
auto.
Qed.

Lemma join_splice2:
  forall a1 a2 a3 b1 b2 b3 : Share.t,
  join (Share.splice a1 b1) (Share.splice a2 b2) (Share.splice a3 b3) ->
  join a1 a2 a3 /\ join b1 b2 b3.
Proof.
intros.
unfold Share.splice in H.
destruct H.
unfold join, Share.Join_ba.
assert ((Share.glb a1 a2 = Share.bot /\ Share.glb b1 b2 = Share.bot)
         /\ (Share.lub a1 a2 = a3 /\ Share.lub b1 b2 = b3)); [ | intuition].
split.
*
clear - H.
rewrite share_distrib1' in H.
rewrite (Share.lub_commute (Share.glb _ _)) in H.
rewrite Share.lub_assoc in H.
rewrite <- (Share.lub_assoc (Share.glb (Share.rel Share.Lsh _) _)) in H.
rewrite (Share.lub_commute (Share.lub _ _)) in H.
rewrite <- Share.lub_assoc in H.
rewrite <- !Share.rel_preserves_glb in H.
rewrite (Share.glb_commute (Share.rel Share.Rsh _)) in H.
rewrite !glb_rel_Lsh_Rsh in H.
rewrite (Share.lub_commute Share.bot), !Share.lub_bot in H.
rewrite Share.lub_commute in H.
apply join_splice2_aux1; auto.
*
clear - H0.
rewrite Share.lub_assoc in H0.
rewrite (Share.lub_commute (Share.rel Share.Rsh _)) in H0.
rewrite <- !Share.lub_assoc in H0.
rewrite <- Share.rel_preserves_lub in H0.
rewrite Share.lub_assoc in H0.
rewrite <- Share.rel_preserves_lub in H0.
rewrite (Share.lub_commute b2) in H0.
apply join_splice2_aux; auto.
Qed.

Lemma nonidentity_rel_Lsh: forall t, nonidentity (Share.rel Share.Lsh t) -> nonidentity t.
Proof.
  intros.
  rewrite <- splice_bot2 in H.
  intro.
  apply H; clear H.
  intros ? ? ?.
  rewrite <- (splice_unrel_unrel a), <- (splice_unrel_unrel b) in H |- *.
  forget (Share.unrel Share.Lsh a) as sh0.
  forget (Share.unrel Share.Rsh a) as sh1.
  forget (Share.unrel Share.Lsh b) as sh2.
  forget (Share.unrel Share.Rsh b) as sh3.
  apply join_splice2 in H.
  destruct H.
  apply H0 in H.
  apply bot_identity in H1.
  subst.
  auto.
Qed.

Lemma readable_share_unrel_Rsh: forall sh, readable_share sh <-> nonunit (Share.unrel Share.Rsh sh).
unfold readable_share in *.
Proof.
intros.
unfold nonempty_share.
transitivity (nonidentity (Share.unrel Share.Rsh sh)).
unfold nonidentity.
split; intro; contradict H.
apply identity_share_bot in H.
rewrite <- share_rel_unrel'.
rewrite H.
rewrite Share.rel_bot1.
apply bot_identity.
rewrite <- share_rel_unrel' in H.
apply rel_nontrivial in H.
destruct H; auto.
elimtype False.
apply identity_share_bot in H.
unfold Share.Rsh in H.
destruct (Share.split Share.top) eqn:?. simpl in H. subst.
apply split_nontrivial' in Heqp.
apply identity_share_bot in Heqp.
apply Share.nontrivial; auto.
right.
apply bot_identity.
split.
apply nonidentity_nonunit.
intro.
hnf in H|-*; intro.
apply identity_share_bot in H0.
rewrite H0 in H.
apply (H Share.top).
red.
apply bot_join_eq.
Qed.

End UNPROVABLE.


Require Import Lia.
Require Import RelationClasses.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Loc.

Require Import Event.
Require Import Time.
From PromisingLib Require Import Language.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.

Require Import AMemory.
Require Import ALocal.
Require Import AThread.

Set Implicit Arguments.

Lemma promise_step_promise_consistent
      lc1 mem1 loc from to msg lc2 mem2 kind
      (STEP: ALocal.promise_step lc1 mem1 loc from to msg lc2 mem2 kind)
      (CONS: Local.promise_consistent lc2):
  Local.promise_consistent lc1.
Proof.
  inv STEP. ii.
  destruct (Memory.op_kind_is_cancel kind) eqn:KIND.
  - destruct kind; ss. inv PROMISE.
    destruct (Memory.get loc0 ts promises2) as [[]|] eqn:GET2.
    + dup GET2. revert GET0.
      erewrite Memory.remove_o; eauto. condtac; ss. i.
      rewrite PROMISE0 in *. inv GET0. eauto.
    + revert GET2. erewrite Memory.remove_o; eauto. condtac; ss; i.
      * des. subst. exploit Memory.remove_get0; eauto. i. des. congr.
      * congr.
  - exploit AMemory.promise_get1_promise; eauto. i. des.
    inv MSG_LE. exploit CONS; eauto.
Qed.

Lemma read_step_promise_consistent
      lc1 mem1 loc to val released ord lc2
      (STEP: Local.read_step lc1 mem1 loc to val released ord lc2)
      (CONS: Local.promise_consistent lc2):
  Local.promise_consistent lc1.
Proof.
  inv STEP. ii. exploit CONS; eauto. i.
  eapply TimeFacts.le_lt_lt; eauto. ss.
  etrans; [|apply Time.join_l]. etrans; [|apply Time.join_l]. refl.
Qed.

Lemma fulfill_unset_promises
      loc from ts msg
      promises1 promises2
      l t f m
      (FULFILL: Memory.remove promises1 loc from ts msg promises2)
      (TH1: Memory.get l t promises1 = Some (f, m))
      (TH2: Memory.get l t promises2 = None):
  l = loc /\ t = ts /\ f = from /\ Message.le msg m.
Proof.
  revert TH2. erewrite Memory.remove_o; eauto. condtac; ss; [|congr].
  des. subst. exploit Memory.remove_get0; eauto. i. des.
  rewrite GET in TH1. inv TH1.
  esplits; eauto. refl.
Qed.

Lemma write_step_promise_consistent
      lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind
      (STEP: ALocal.write_step lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind)
      (CONS: Local.promise_consistent lc2):
  Local.promise_consistent lc1.
Proof.
  inv STEP. inv WRITE. ii.
  exploit AMemory.promise_get1_promise; eauto.
  { inv PROMISE; ss. }
  i. des. inv MSG_LE.
  destruct (Memory.get loc0 ts promises2) as [[]|] eqn:X.
  - dup X. revert X0.
    erewrite Memory.remove_o; eauto. condtac; ss; i.
    rewrite GET in *. inv X0.
    apply CONS in X. eapply TimeFacts.le_lt_lt; eauto.
    s. etrans; [|apply Time.join_l]. refl.
  - exploit fulfill_unset_promises; eauto. i. des. subst.
    apply WRITABLE.
Qed.

Lemma fence_step_promise_consistent
      lc1 sc1 mem1 ordr ordw lc2 sc2
      (STEP: Local.fence_step lc1 sc1 ordr ordw lc2 sc2)
      (WF: Local.wf lc1 mem1)
      (CONS: Local.promise_consistent lc2):
  Local.promise_consistent lc1.
Proof.
  inv STEP. ii.
  exploit CONS; eauto. i.
  eapply TimeFacts.le_lt_lt; eauto.
  cut (TView.le (Local.tview lc1)
                (TView.write_fence_tview (TView.read_fence_tview (Local.tview lc1) ordr) sc1 ordw)).
  { i. inv H. apply CUR. }
  etrans.
  - eapply TViewFacts.write_fence_tview_incr. apply WF.
  - eapply TViewFacts.write_fence_tview_mon; try refl; try apply WF.
    eapply TViewFacts.read_fence_tview_incr. apply WF.
Qed.

Lemma ordering_relaxed_dec
      ord:
  Ordering.le ord Ordering.relaxed \/ Ordering.le Ordering.strong_relaxed ord.
Proof. destruct ord; auto. Qed.

Lemma step_promise_consistent
      lang pf e th1 th2
      (STEP: @AThread.step lang pf e th1 th2)
      (CONS: Local.promise_consistent (Thread.local th2))
      (WF1: Local.wf (Thread.local th1) (Thread.memory th1))
      (SC1: Memory.closed_timemap (Thread.sc th1) (Thread.memory th1))
      (MEM1: Memory.closed (Thread.memory th1)):
  Local.promise_consistent (Thread.local th1).
Proof.
  inv STEP; [inv STEP0|inv STEP0; inv LOCAL]; ss.
  - eapply promise_step_promise_consistent; eauto.
  - eapply read_step_promise_consistent; eauto.
  - eapply write_step_promise_consistent; eauto.
  - eapply read_step_promise_consistent; eauto.
    eapply write_step_promise_consistent; eauto.
  - eapply fence_step_promise_consistent; eauto.
  - eapply fence_step_promise_consistent; eauto.
Qed.

Lemma rtc_all_step_promise_consistent
      lang th1 th2
      (STEP: rtc (@AThread.all_step lang) th1 th2)
      (CONS: Local.promise_consistent (Thread.local th2))
      (WF1: Local.wf (Thread.local th1) (Thread.memory th1))
      (SC1: Memory.closed_timemap (Thread.sc th1) (Thread.memory th1))
      (MEM1: Memory.closed (Thread.memory th1)):
  Local.promise_consistent (Thread.local th1).
Proof.
  revert_until STEP. induction STEP; auto. i.
  inv H. inv USTEP. exploit AThread.step_future; eauto. i. des.
  eapply step_promise_consistent; eauto.
Qed.

Lemma rtc_tau_step_promise_consistent
      lang th1 th2
      (STEP: rtc (@AThread.tau_step lang) th1 th2)
      (CONS: Local.promise_consistent (Thread.local th2))
      (WF1: Local.wf (Thread.local th1) (Thread.memory th1))
      (SC1: Memory.closed_timemap (Thread.sc th1) (Thread.memory th1))
      (MEM1: Memory.closed (Thread.memory th1)):
  Local.promise_consistent (Thread.local th1).
Proof.
  eapply rtc_all_step_promise_consistent; cycle 1; eauto.
  eapply rtc_implies; [|eauto].
  apply tau_union.
Qed.

Lemma consistent_promise_consistent
      lang th
      (CONS: @AThread.consistent lang th)
      (WF: Local.wf (Thread.local th) (Thread.memory th))
      (SC: Memory.closed_timemap (Thread.sc th) (Thread.memory th))
      (MEM: Memory.closed (Thread.memory th)):
  Local.promise_consistent (Thread.local th).
Proof.
  destruct th. ss.
  exploit Memory.cap_exists; eauto. i. des.
  exploit Memory.cap_closed; eauto. i.
  exploit Local.cap_wf; eauto. i.
  exploit Memory.max_full_timemap_exists; try apply x0. i. des.
  hexploit Memory.max_full_timemap_closed; eauto. i.
  exploit CONS; eauto. s. i. des.
  - inv FAILURE. des. inv FAILURE; inv STEP. inv LOCAL. inv LOCAL0.
    hexploit rtc_tau_step_promise_consistent; try exact STEPS; eauto.
  - hexploit rtc_tau_step_promise_consistent; try exact STEPS; eauto.
    ii. rewrite PROMISES, Memory.bot_get in *. congr.
Qed.

Lemma promise_consistent_promise_read
      lc1 mem1 loc to val ord released lc2
      f t v r
      (STEP: Local.read_step lc1 mem1 loc to val released ord lc2)
      (PROMISE: Memory.get loc t (Local.promises lc1) = Some (f, Message.full v r))
      (CONS: Local.promise_consistent lc2):
  Time.lt to t.
Proof.
  inv STEP. exploit CONS; eauto. s. intro x.
  apply TimeFacts.join_lt_des in x. des.
  apply TimeFacts.join_lt_des in AC. des.
  revert BC0. unfold View.singleton_ur_if. condtac; ss.
  - unfold TimeMap.singleton, LocFun.add. condtac; ss.
  - unfold TimeMap.singleton, LocFun.add. condtac; ss.
Qed.

Lemma promise_consistent_promise_write
      lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind
      f t v r
      (STEP: Local.write_step lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind)
      (PROMISE: Memory.get loc t (Local.promises lc1) = Some (f, Message.full v r))
      (CONS: Local.promise_consistent lc2):
  Time.le to t.
Proof.
  destruct (Memory.get loc t (Local.promises lc2)) as [[]|] eqn:X.
  - inv STEP. inv WRITE. ss.
    dup X. revert X0.
    erewrite Memory.remove_o; eauto. condtac; ss. i. guardH o.
    exploit Memory.promise_get1_promise; try exact PROMISE; eauto.
    { inv PROMISE0; ss. }
    i. des. inv MSG_LE.
    rewrite X0 in *. inv GET.
    exploit CONS; eauto. intro x. ss.
    apply TimeFacts.join_lt_des in x. des.
    left. revert BC. unfold TimeMap.singleton, LocFun.add. condtac; ss.
  - inv STEP. inv WRITE.
    exploit Memory.promise_get1_promise; eauto.
    { inv PROMISE0; ss. }
    i. des. inv MSG_LE.
    exploit fulfill_unset_promises; eauto. i. des. subst. refl.
Qed.


From compcert Require Export Clightdefs.
Require Export VST.veric.base.
Require Export VST.veric.SeparationLogic.
Require Export VST.msl.Extensionality.
Require Export compcert.lib.Coqlib.
Require Export VST.msl.Coqlib2 VST.veric.coqlib4 VST.floyd.coqlib3.
Require Export VST.floyd.functional_base.
Import LiftNotation.

Lemma force_Vint:  forall i, force_int (Vint i) = i.
Proof.  reflexivity. Qed.
Hint Rewrite force_Vint : norm.

Lemma is_int_dec i s v: {is_int i s v} + {~ is_int i s v}.
Proof. destruct v; simpl; try solve [right; intros N; trivial].
destruct i.
+ destruct s.
    * destruct (zle Byte.min_signed (Int.signed i0)); [| right; lia].
      destruct (zle (Int.signed i0) Byte.max_signed). left; lia. right; lia.
    * destruct (zle (Int.unsigned i0) Byte.max_unsigned). left; lia. right; lia.
+ destruct s.
    * destruct (zle (-32768) (Int.signed i0)); [| right; lia].
      destruct (zle (Int.signed i0) 32767). left; lia. right; lia.
    * destruct (zle (Int.unsigned i0) 65535). left; lia. right; lia.
+ left; trivial.
+ destruct (Int.eq_dec i0 Int.zero); subst. left; left; trivial.
    destruct (Int.eq_dec i0 Int.one); subst. left; right; trivial.
    right. intros N; destruct N; contradiction.
Defined.

Lemma tc_val_dec t v: {tc_val t v} + {~ tc_val t v}.
Proof. destruct t; simpl.
+ right; intros N; trivial.
+ apply is_int_dec.
+ apply is_long_dec.
+ destruct f. apply is_single_dec. apply is_float_dec.
+ destruct ((eqb_type t Ctypes.Tvoid &&
    eqb_attr a
      {| attr_volatile := false; attr_alignas := Some log2_sizeof_pointer |})%bool).
  apply is_pointer_or_integer_dec.
  apply is_pointer_or_null_dec.
+ apply is_pointer_or_null_dec.
+ apply is_pointer_or_null_dec.
+ apply isptr_dec.
+ apply isptr_dec.
Defined.

Lemma sem_add_pi_ptr:
   forall {cs: compspecs}  t p i si,
    isptr p ->
    match si with
    | Signed => Int.min_signed <= i <= Int.max_signed
    | Unsigned => 0 <= i <= Int.max_unsigned
    end ->
    Cop.sem_add_ptr_int cenv_cs t si p (Vint (Int.repr i)) = Some (offset_val (sizeof t * i) p).
Proof.
  intros. destruct p; try contradiction.
  unfold offset_val, Cop.sem_add_ptr_int.
  unfold Cop.ptrofs_of_int, Ptrofs.of_ints, Ptrofs.of_intu, Ptrofs.of_int.
  f_equal. f_equal. f_equal.
  destruct si; rewrite <- ptrofs_mul_repr;  f_equal.
  rewrite Int.signed_repr by lia; auto.
  rewrite Int.unsigned_repr by lia; auto.
Qed.
Hint Rewrite @sem_add_pi_ptr using (solve [auto with norm]) : norm.

Lemma sem_cast_i2i_correct_range: forall sz s v,
  is_int sz s v -> sem_cast_i2i sz s v = Some v.
Proof.
  intros.
  destruct sz, s, v; try solve [inversion H]; simpl;
  f_equal; f_equal; try apply sign_ext_inrange; try apply zero_ext_inrange; eauto.
  + simpl in H; destruct H; subst; reflexivity.
  + simpl in H; destruct H; subst; reflexivity.
Qed.
Hint Rewrite sem_cast_i2i_correct_range using (solve [auto with norm]) : norm.

Lemma sem_cast_neutral_ptr:
  forall p, isptr p -> sem_cast_pointer p = Some p.
Proof. intros. destruct p; try contradiction; reflexivity. Qed.
Hint Rewrite sem_cast_neutral_ptr using (solve [auto with norm]): norm.

Lemma sem_cast_neutral_Vint: forall v,
  sem_cast_pointer (Vint v) = Some (Vint v).
Proof.
  intros. reflexivity.
Qed.
Hint Rewrite sem_cast_neutral_Vint : norm.

Definition isVint v := match v with Vint _ => True | _ => False end.

Lemma is_int_is_Vint: forall i s v, is_int i s v -> isVint v.
Proof. intros.
 destruct i,s,v; simpl; intros; auto.
Qed.

Lemma is_int_I32_Vint: forall s v, is_int I32 s (Vint v).
Proof.
intros.
hnf. auto.
Qed.
#[export] Hint Resolve is_int_I32_Vint : core.

Lemma sem_cast_neutral_int: forall v,
  isVint v ->
  sem_cast_pointer v = Some v.
Proof.
destruct v; simpl; intros; try contradiction; auto.
Qed.

Hint Rewrite sem_cast_neutral_int using
  (auto;
   match goal with H: is_int ?i ?s ?v |- isVint ?v => apply (is_int_is_Vint i s v H) end) : norm.

Lemma sizeof_tuchar: forall {cs: compspecs}, sizeof tuchar = 1%Z.
Proof. reflexivity. Qed.
Hint Rewrite @sizeof_tuchar: norm.

Hint Rewrite Z.mul_1_l Z.mul_1_r Z.add_0_l Z.add_0_r Z.sub_0_r : norm.

Hint Rewrite eval_id_same : norm.
Hint Rewrite eval_id_other using solve [clear; intro Hx; inversion Hx] : norm.
Hint Rewrite Int.sub_idem Int.sub_zero_l  Int.add_neg_zero : norm.
Hint Rewrite Ptrofs.sub_idem Ptrofs.sub_zero_l  Ptrofs.add_neg_zero : norm.

Lemma eval_expr_Etempvar:
  forall {cs: compspecs}  i t, eval_expr (Etempvar i t) = eval_id i.
Proof. reflexivity.
Qed.
Hint Rewrite @eval_expr_Etempvar : eval.

Lemma eval_expr_binop: forall {cs: compspecs}  op a1 a2 t, eval_expr (Ebinop op a1 a2 t) =
          `(eval_binop op (typeof a1) (typeof a2)) (eval_expr a1) (eval_expr a2).
Proof. reflexivity. Qed.
Hint Rewrite @eval_expr_binop : eval.

Lemma eval_expr_unop: forall {cs: compspecs} op a1 t, eval_expr (Eunop op a1 t) =
          lift1 (eval_unop op (typeof a1)) (eval_expr a1).
Proof. reflexivity. Qed.
Hint Rewrite @eval_expr_unop : eval.

#[export] Hint Resolve  eval_expr_Etempvar : core.

Lemma eval_expr_Etempvar' : forall {cs: compspecs}  i t, eval_id i = eval_expr (Etempvar i t).
Proof. intros. symmetry; auto.
Qed.
#[export] Hint Resolve  eval_expr_Etempvar' : core.

Hint Rewrite Int.add_zero  Int.add_zero_l Int.sub_zero_l : norm.
Hint Rewrite Ptrofs.add_zero  Ptrofs.add_zero_l Ptrofs.sub_zero_l : norm.

Lemma eval_var_env_set:
  forall i t j v (rho: environ), eval_var i t (env_set rho j v) = eval_var i t rho.
Proof. reflexivity. Qed.
Hint Rewrite eval_var_env_set : norm.

Lemma eval_expropt_Some: forall {cs: compspecs}  e, eval_expropt (Some e) = `Some (eval_expr e).
Proof. reflexivity. Qed.
Lemma eval_expropt_None: forall  {cs: compspecs} , eval_expropt None = `None.
Proof. reflexivity. Qed.
Hint Rewrite @eval_expropt_Some @eval_expropt_None : eval.

Lemma deref_noload_tarray:
  forall ty n, deref_noload (tarray ty n) = (fun v => v).
Proof.
 intros. extensionality v. reflexivity.
Qed.
Hint Rewrite deref_noload_tarray : norm.

Lemma deref_noload_Tarray:
  forall ty n a, deref_noload (Tarray ty n a) = (fun v => v).
Proof.
 intros. extensionality v. reflexivity.
Qed.
Hint Rewrite deref_noload_Tarray : norm.

Lemma flip_lifted_eq:
  forall (v1: environ -> val) (v2: val),
    `eq v1 `(v2) = `(eq v2) v1.
Proof.
intros. unfold_lift. extensionality rho. apply prop_ext; split; intro; auto.
Qed.
Hint Rewrite flip_lifted_eq : norm.

Lemma isptr_is_pointer_or_null:
  forall v, isptr v -> is_pointer_or_null v.
Proof. intros. destruct v; inv H; simpl; auto.
Qed.
#[export] Hint Resolve isptr_is_pointer_or_null : core.

Definition add_ptr_int  {cs: compspecs}  (ty: type) (v: val) (i: Z) : val :=
           eval_binop Cop.Oadd (tptr ty) tint v (Vint (Int.repr i)).

Lemma add_ptr_int_offset:
  forall  {cs: compspecs}  t v n,
  repable_signed (sizeof t) ->
  repable_signed n ->
  add_ptr_int t v n = offset_val (sizeof t * n) v.
Abort. (* broken in CompCert 2.7 *)

Lemma typed_false_cmp:
  forall op i j ,
   typed_false tint (force_val (sem_cmp op tint tint (Vint i) (Vint j))) ->
   Int.cmp (negate_comparison op) i j = true.
Proof.
intros.
unfold sem_cmp in H.
unfold Cop.classify_cmp in H. simpl in H.
rewrite Int.negate_cmp.
unfold both_int, force_val, typed_false, strict_bool_val, sem_cast, classify_cast, tint in H.
destruct Archi.ptr64 eqn:Hp; simpl in H.
destruct (Int.cmp op i j); inv H; auto.
destruct (Int.cmp op i j); inv H; auto.
Qed.

Lemma typed_true_cmp:
  forall op i j,
   typed_true tint (force_val (sem_cmp op tint tint (Vint i) (Vint j))) ->
   Int.cmp op i j = true.
Proof.
intros.
unfold sem_cmp in H.
unfold Cop.classify_cmp in H. simpl in H.
unfold both_int, force_val, typed_false, strict_bool_val, sem_cast, classify_cast, tint in H.
destruct Archi.ptr64 eqn:Hp; simpl in H.
destruct (Int.cmp op i j); inv H; auto.
destruct (Int.cmp op i j); inv H; auto.
Qed.

Definition Zcmp (op: comparison) : Z -> Z -> Prop :=
 match op with
 | Ceq => eq
 | Cne => (fun i j => i<>j)
 | Clt => Z.lt
 | Cle => Z.le
 | Cgt => Z.gt
 | Cge => Z.ge
 end.

Lemma int_cmp_repr:
 forall op i j, repable_signed i -> repable_signed j ->
   Int.cmp op (Int.repr i) (Int.repr j) = true ->
   Zcmp op i j.
Proof.
intros.
unfold Int.cmp, Int.eq, Int.lt in H1.
replace (if zeq (Int.unsigned (Int.repr i)) (Int.unsigned (Int.repr j))
             then true else false)
 with (if zeq i j then true else false) in H1.
2:{
destruct (zeq i j); destruct (zeq (Int.unsigned (Int.repr i)) (Int.unsigned (Int.repr j)));
 auto.
subst. contradiction n; auto.
clear - H H0 e n.
apply Int.signed_repr in H. rewrite Int.signed_repr_eq in H.
apply Int.signed_repr in H0; rewrite Int.signed_repr_eq in H0.
contradiction n; clear n.
repeat rewrite Int.unsigned_repr_eq in e.
 match type of H with
           | context [if ?a then _ else _] => destruct a
           end;
 match type of H0 with
           | context [if ?a then _ else _] => destruct a
           end; lia.
}
unfold Zcmp.
rewrite (Int.signed_repr _ H) in H1; rewrite (Int.signed_repr _ H0) in H1.
repeat match type of H1 with
           | context [if ?a then _ else _] => destruct a
           end; try lia;
 destruct op; auto; simpl in *; try discriminate; lia.
Qed.

Lemma typed_false_cmp_repr:
  forall op i j,
   repable_signed i -> repable_signed j ->
   typed_false tint (force_val (sem_cmp op tint tint
                              (Vint (Int.repr i))
                              (Vint (Int.repr j)) )) ->
   Zcmp (negate_comparison op) i j.
Proof.
 intros.
 apply typed_false_cmp in H1.
 apply int_cmp_repr; auto.
Qed.

Lemma typed_true_cmp_repr:
  forall op i j,
   repable_signed i -> repable_signed j ->
   typed_true tint (force_val (sem_cmp op tint tint
                              (Vint (Int.repr i))
                              (Vint (Int.repr j)) )) ->
   Zcmp op i j.
Proof.
 intros.
 apply typed_true_cmp in H1.
 apply int_cmp_repr; auto.
Qed.

Ltac intcompare H :=
 (apply typed_false_cmp_repr in H || apply typed_true_cmp_repr in H);
   [ simpl in H | auto; unfold repable_signed, Int.min_signed, Int.max_signed in *; lia .. ].

Lemma isptr_deref_noload:
 forall t p, access_mode t = By_reference -> isptr (deref_noload t p) = isptr p.
Proof.
intros.
unfold deref_noload. rewrite H. reflexivity.
Qed.
Hint Rewrite isptr_deref_noload using reflexivity : norm.

Definition headptr (v: val): Prop :=
  exists b,  v = Vptr b Ptrofs.zero.

Lemma headptr_isptr: forall v,
  headptr v -> isptr v.
Proof.
  intros.
  destruct H as [b ?].
  subst.
  hnf; auto.
Qed.
#[export] Hint Resolve headptr_isptr : core.

Lemma headptr_offset_zero: forall v,
  headptr (offset_val 0 v) <->
  headptr v.
Proof.
  split; intros.
  + destruct H as [b ?]; subst.
    destruct v; try solve [inv H].
    simpl in H.
    remember (Ptrofs.add i (Ptrofs.repr 0)).
    inversion H; subst.
    rewrite Ptrofs.add_zero in H2; subst.
    hnf; eauto.
  + destruct H as [b ?]; subst.
    exists b.
    reflexivity.
Qed.

(* Equality proofs for all constants from the Compcert Int, Int64, Ptrofs modules: *)

Lemma typed_false_ptr:
  forall {t a v},  typed_false (Tpointer t a) v -> v=nullval.
Proof.
unfold typed_false, strict_bool_val, nullval; simpl; intros.
destruct Archi.ptr64 eqn:Hp;
destruct v; try discriminate; f_equal.
first [pose proof (Int64.eq_spec i Int64.zero);
          destruct (Int64.eq i Int64.zero)
       | pose proof (Int.eq_spec i Int.zero);
         destruct (Int.eq i Int.zero)];
      subst; auto; discriminate.
Qed.

Lemma typed_true_ptr:
  forall {t a v},  typed_true (Tpointer t a) v -> isptr v.
Proof.
unfold typed_true, strict_bool_val; simpl; intros.
destruct v; try discriminate; simpl; auto;
destruct Archi.ptr64; try discriminate;
 revert H; simple_if_tac; intros; discriminate.
Qed.

Lemma int_cmp_repr':
 forall op i j, repable_signed i -> repable_signed j ->
   Int.cmp op (Int.repr i) (Int.repr j) = false ->
   Zcmp (negate_comparison op) i j.
Proof.
intros.
apply int_cmp_repr; auto.
rewrite Int.negate_cmp.
rewrite H1; reflexivity.
Qed.

Lemma typed_false_of_bool:
 forall x, typed_false tint (Val.of_bool x) -> (x=false).
Proof.
unfold typed_false; simpl.
unfold strict_bool_val, Val.of_bool; simpl.
destruct x; simpl; intros; [inversion H | auto].
Qed.

Lemma typed_true_of_bool:
 forall x, typed_true tint (Val.of_bool x) -> (x=true).
Proof.
unfold typed_true; simpl.
unfold strict_bool_val, Val.of_bool; simpl.
destruct x; simpl; intros; [auto | inversion H].
Qed.

Lemma typed_false_tint:
 Archi.ptr64=false ->
 forall v, typed_false tint v -> v=nullval.
Proof.
intros.
 hnf in H0. destruct v; inv H0.
 destruct (Int.eq i Int.zero) eqn:?; inv H2.
 apply int_eq_e in Heqb. subst.
 inv H; reflexivity.
Qed.

Lemma typed_false_tlong:
 Archi.ptr64=true ->
 forall v, typed_false tlong v -> v=nullval.
Proof.
intros. unfold nullval. rewrite H.
 hnf in H0. destruct v; inv H0.
pose proof (Int64.eq_spec i Int64.zero).
 destruct (Int64.eq i Int64.zero); inv H2.
reflexivity.
Qed.

Lemma typed_true_e:
 forall t v, typed_true t v -> v<>nullval.
Proof.
intros.
 intro Hx. subst.
 hnf in H. unfold nullval, strict_bool_val in H.
 destruct Archi.ptr64, t; discriminate.
Qed.

Lemma typed_false_tint_Vint:
  forall v, typed_false tint (Vint v) -> v = Int.zero.
Proof.
intros.
unfold typed_false, strict_bool_val in H. simpl in H.
pose proof (Int.eq_spec v Int.zero).
destruct (Int.eq v Int.zero); auto. inv H.
Qed.

Lemma typed_true_tint_Vint:
  forall v, typed_true tint (Vint v) -> v <> Int.zero.
Proof.
intros.
unfold typed_true, strict_bool_val in H. simpl in H.
pose proof (Int.eq_spec v Int.zero).
destruct (Int.eq v Int.zero); auto. inv H.
Qed.

Lemma typed_true_tlong_Vlong:
  forall v, typed_true tlong (Vlong v) -> v <> Int64.zero.
Proof.
intros.
unfold typed_true, strict_bool_val in H. simpl in H.
pose proof (Int64.eq_spec v Int64.zero).
destruct (Int64.eq v Int64.zero); auto. inv H.
Qed.

Ltac intro_redundant P :=
 match goal with H: P |- _ => idtac end.

Ltac fancy_intro_discriminate H := idtac.

Ltac fancy_intro aggressive :=
 lazymatch goal with |- ~ _ => red | _ => idtac end;
 lazymatch goal with
 | |- ?P -> _ => match type of P with Prop => idtac end
 end;
 tryif
 lazymatch goal with |- ?P -> _ =>
     lazymatch P with
     | ptr_eq ?v1 ?v2 => intro_redundant (v1=v2)
     | Vint ?x = Vint ?y => constr_eq x y + intro_redundant (x=y)
     | tc_val ?ty ?v =>
         lazymatch ty with
         | Tint ?sz ?sg _ => intro_redundant(is_int sz sg v)
         | Tlong _ _ => intro_redundant(is_long v)
         | Tfloat F32 _ => intro_redundant(is_single v)
         | Tfloat F64 _ => intro_redundant(is_float v)
         | Tpointer _ _ =>
           tryif (unify ty int_or_ptr_type)
           then intro_redundant (is_pointer_or_integer v)
           else intro_redundant (is_pointer_or_null v)
         | Tarray _ _ _ =>  intro_redundant (is_pointer_or_null v)
         | Tfunction _ _ _ =>  intro_redundant (is_pointer_or_null v)
         | _ =>  intro_redundant (isptr v)
         end
     | ?x = ?y => constr_eq x y + intro_redundant P
     | _ => intro_redundant P + unify P True
    end
   end
   then intros _
   else
 let H := fresh in
 intro H;
 try simple apply ptr_eq_e in H;
 try simple apply Vint_inj in H;
 try lazymatch type of H with
 | tc_val _ _ => unfold tc_val in H; try change (eqb_type _ _) with false in H; cbv iota in H
 | ?x = ?y => tryif constr_eq aggressive true
                     then first [subst x | subst y
                                    | is_var x; rewrite H
                                    | is_var y; rewrite <- H
                                    | try fancy_intro_discriminate H]
                     else (try fancy_intro_discriminate H)
 | headptr (_ ?x) => let Hx1 := fresh "HP" x in
                     let Hx2 := fresh "P" x in
                       rename H into Hx1;
                       pose proof headptr_isptr _ Hx1 as Hx2
 | headptr ?x => let Hx1 := fresh "HP" x in
                 let Hx2 := fresh "P" x in
                   rename H into Hx1;
                   pose proof headptr_isptr _ Hx1 as Hx2
 | isptr ?x => let Hx := fresh "P" x in rename H into Hx
 | is_pointer_or_null ?x => let Hx := fresh "PN" x in rename H into Hx
 | typed_false _ _ =>
        first [simple apply typed_false_of_bool in H
               | apply typed_false_tint_Vint in H
               | apply (typed_false_tint (eq_refl _)) in H
               | apply (typed_false_tlong (eq_refl _)) in H
               | apply typed_false_ptr in H
               | idtac ]
 | typed_true _ _ =>
        first [simple apply typed_true_of_bool in H
               | apply typed_true_tint_Vint in H
               | apply typed_true_tlong_Vlong in H
               | apply typed_true_ptr in H
               | idtac ]
 end.

Ltac fancy_intros aggressive :=
 repeat lazymatch goal with
  | |- (_ <= _ < _) -> _ => fancy_intro aggressive
  | |- (_ < _ <= _) -> _ => fancy_intro aggressive
  | |- (_ <= _ <= _) -> _ => fancy_intro aggressive
  | |- (_ < _ < _) -> _ => fancy_intro aggressive
  | |- (?A /\ ?B) -> ?C => apply (@and_ind A B C) (* For some reason "apply and_ind" doesn't work the same *)
  | |- _ -> _ => fancy_intro aggressive
  end.

Ltac fold_types :=
 fold noattr tuint tint tschar tuchar;
 repeat match goal with
 | |- context [Tpointer ?t noattr] =>
      change (Tpointer t noattr) with (tptr t)
 | |- context [Tarray ?t ?n noattr] =>
      change (Tarray t n noattr) with (tarray t n)
 end.

Ltac fold_types1 :=
  match goal with |- _ -> ?A =>
  let a := fresh "H" in set (a:=A); fold_types; subst a
  end.

Lemma is_int_Vbyte: forall c, is_int I8 Signed (Vbyte c).
Proof.
intros. simpl. normalize. rewrite Int.signed_repr by rep_lia. rep_lia.
Qed.
#[export] Hint Resolve is_int_Vbyte : core.


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

(** Recognition of combined operations, addressing modes and conditions
  during the [CSE] phase. *)

Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Op.
Require Import CSEdomain.

Definition valnum := positive.

Section COMBINE.

Variable get: valnum -> option rhs.

Function combine_compimm_ne_0 (x: valnum) : option(condition * list valnum) :=
  match get x with
  | Some(Op (Ocmp c) ys) => Some (c, ys)
  | Some(Op (Oandimm n) ys) => Some (Cmasknotzero n, ys)
  | _ => None
  end.

Function combine_compimm_eq_0 (x: valnum) : option(condition * list valnum) :=
  match get x with
  | Some(Op (Ocmp c) ys) => Some (negate_condition c, ys)
  | Some(Op (Oandimm n) ys) => Some (Cmaskzero n, ys)
  | _ => None
  end.

Function combine_compimm_eq_1 (x: valnum) : option(condition * list valnum) :=
  match get x with
  | Some(Op (Ocmp c) ys) => Some (c, ys)
  | _ => None
  end.

Function combine_compimm_ne_1 (x: valnum) : option(condition * list valnum) :=
  match get x with
  | Some(Op (Ocmp c) ys) => Some (negate_condition c, ys)
  | _ => None
  end.

Function combine_cond (cond: condition) (args: list valnum) : option(condition * list valnum) :=
  match cond, args with
  | Ccompimm Cne n, x::nil =>
      if Int.eq_dec n Int.zero then combine_compimm_ne_0 x
      else if Int.eq_dec n Int.one then combine_compimm_ne_1 x
      else None
  | Ccompimm Ceq n, x::nil =>
      if Int.eq_dec n Int.zero then combine_compimm_eq_0 x
      else if Int.eq_dec n Int.one then combine_compimm_eq_1 x
      else None
  | Ccompuimm Cne n, x::nil =>
      if Int.eq_dec n Int.zero then combine_compimm_ne_0 x
      else if Int.eq_dec n Int.one then combine_compimm_ne_1 x
      else None
  | Ccompuimm Ceq n, x::nil =>
      if Int.eq_dec n Int.zero then combine_compimm_eq_0 x
      else if Int.eq_dec n Int.one then combine_compimm_eq_1 x
      else None
  | _, _ => None
  end.

Function combine_addr (addr: addressing) (args: list valnum) : option(addressing * list valnum) :=
  match addr, args with
  | Aindexed n, x::nil =>
      match get x with
      | Some(Op (Olea a) ys) => Some(offset_addressing_total a n, ys)
      | _ => None
      end
  | _, _ => None
  end.

Function combine_op (op: operation) (args: list valnum) : option(operation * list valnum) :=
  match op, args with
  | Olea addr, _ =>
      match combine_addr addr args with
      | Some(addr', args') => Some(Olea addr', args')
      | None => None
      end
  | Oandimm n, x :: nil =>
      match get x with
      | Some(Op (Oandimm m) ys) => Some(Oandimm (Int.and m n), ys)
      | _ => None
      end
  | Oorimm n, x :: nil =>
      match get x with
      | Some(Op (Oorimm m) ys) => Some(Oorimm (Int.or m n), ys)
      | _ => None
      end
  | Oxorimm n, x :: nil =>
      match get x with
      | Some(Op (Oxorimm m) ys) => Some(Oxorimm (Int.xor m n), ys)
      | _ => None
      end
  | Ocmp cond, _ =>
      match combine_cond cond args with
      | Some(cond', args') => Some(Ocmp cond', args')
      | None => None
      end
  | _, _ => None
  end.

End COMBINE.


Require Import yarn_config.
Require Import Omega.
Require Import env_desc.
Require Import Reals.
Open Scope R_scope.
Open Scope Z_scope.
Open Scope positive_scope.

Definition a_yarn_config: YarnConfig.
Proof.
unshelve refine (
  mk_yarn_config
    (yarn_nodemanager_container__manager_thread__count.mk            false   20%positive _ )
    (yarn_nodemanager_localizer_client_thread__count.mk            false   5%positive _ )
    (yarn_nodemanager_localizer_fetch_thread__count.mk            false   4%positive _ )
    (yarn_nodemanager_recovery_compaction__interval__secs.mk            false   3600%positive _ )
    (yarn_nodemanager_resource_cpu__vcores.mk            false   8%positive _ )
    (yarn_nodemanager_resource_memory__mb.mk false 8192%positive _ )
    (yarn_nodemanager_resource_percentage__physical__cpu__limit.mk            false   100%positive _ )
    (yarn_nodemanager_vmem__check__enabled.mk            false  true _ )
    (yarn_resourcemanager_admin_client_thread__count.mk            false   1%positive _ )
    (yarn_resourcemanager_amlauncher_thread__count.mk            false   50%positive _ )
    (yarn_resourcemanager_client_thread__count.mk            false   50%positive _ )
    (yarn_resourcemanager_resource__tracker_client_thread__count.mk            false   50%positive _ )
    (yarn_resourcemanager_scheduler_class.mk            false   "org.apache.hadoop.yarn.server.resourcemanager.scheduler.capacity.CapacityScheduler" _ )
    (yarn_resourcemanager_scheduler_client_thread__count.mk            false   50%positive _ )
    (yarn_resourcemanager_store_class.mk            false   "org.apache.hadoop.yarn.server.resourcemanager.recovery.FileSystemRMStateStore" _ )
    (yarn_scheduler_increment__allocation__mb.mk            false   1%positive _ )
    (yarn_scheduler_maximum__allocation__mb.mk            false   8192%positive _ )
    (yarn_scheduler_maximum__allocation__vcores.mk            false   32%positive _ )
    (yarn_scheduler_minimum__allocation__mb.mk            false   1024%positive _ )
    (yarn_scheduler_minimum__allocation__vcores.mk            false   1%positive _ )
    (yarn_sharedcache_admin_thread__count.mk            false   1%positive _ )
    (yarn_sharedcache_client__server_thread__count.mk            false   50%positive _ )
    (yarn_sharedcache_enabled.mk            false   false _ )
    _
    _
    _
); try (exact I); try compute; try reflexivity; auto.
Qed.


From iris.proofmode Require Import tactics monpred.
From iris.base_logic Require Import base_logic.
From iris.base_logic.lib Require Import invariants cancelable_invariants na_invariants.

From iris.bi Require Import ascii.

Set Default Proof Using "Type".
Unset Printing Use Implicit Types. (* FIXME: remove once we drop support for Coq <=8.11. *)

Section base_logic_tests.
  Context {M : ucmraT}.
  Implicit Types P Q R : uPred M.

  Lemma test_random_stuff (P1 P2 P3 : nat -> uPred M) :
    |- forall (x y : nat) a b,
      x ≡ y ->
      <#> (uPred_ownM (a ⋅ b) -*
      (exists y1 y2 c, P1 ((x + y1) + y2) /\ True /\ <#> uPred_ownM c) -*
      <#> |> (forall z, P2 z ∨ True -> P2 z) -*
      |> (forall n m : nat, P1 n -> <#> (True /\ P2 n -> <#> (⌜n = n⌝ <-> P3 n))) -*
      |> ⌜x = 0⌝ \/ exists x z, |> P3 (x + z) ** uPred_ownM b ** uPred_ownM (core b)).
  Proof.
    iIntros (i [|j] a b ?) "!> [Ha Hb] H1 #H2 H3"; setoid_subst.
    { iLeft. by iNext. }
    iRight.
    iDestruct "H1" as (z1 z2 c) "(H1&_&#Hc)".
    iPoseProof "Hc" as "foo".
    iRevert (a b) "Ha Hb". iIntros (b a) "Hb {foo} Ha".
    iAssert (uPred_ownM (a ⋅ core a)) with "[Ha]" as "[Ha #Hac]".
    { by rewrite cmra_core_r. }
    iIntros "{$Hac $Ha}".
    iExists (S j + z1), z2.
    iNext.
    iApply ("H3" $! _ 0 with "[$]").
    - iSplit. done. iApply "H2". iLeft. iApply "H2". by iRight.
    - done.
  Qed.

  Lemma test_iFrame_pure (x y z : M) :
    ✓ x -> ⌜y ≡ z⌝ |-@{uPredI M} ✓ x /\ ✓ x /\ y ≡ z.
  Proof. iIntros (Hv) "Hxy". by iFrame (Hv) "Hxy". Qed.

  Lemma test_iAssert_modality P : (|==> False) -* |==> P.
  Proof. iIntros. iAssert False%I with "[> - //]" as %[]. Qed.

  Lemma test_iStartProof_1 P : P -* P.
  Proof. iStartProof. iStartProof. iIntros "$". Qed.
  Lemma test_iStartProof_2 P : P -* P.
  Proof. iStartProof (uPred _). iStartProof (uPredI _). iIntros "$". Qed.
  Lemma test_iStartProof_3 P : P -* P.
  Proof. iStartProof (uPredI _). iStartProof (uPredI _). iIntros "$". Qed.
  Lemma test_iStartProof_4 P : P -* P.
  Proof. iStartProof (uPredI _). iStartProof (uPred _). iIntros "$". Qed.
End base_logic_tests.

Section iris_tests.
  Context `{!invG Σ, !cinvG Σ, !na_invG Σ}.
  Implicit Types P Q R : iProp Σ.

  Lemma test_masks  N E P Q R :
    ↑N ⊆ E ->
    (True -* P -* inv N Q -* True -* R) -* P -* |> Q ={E}=* R.
  Proof.
    iIntros (?) "H HP HQ".
    iApply ("H" with "[% //] [$] [> HQ] [> //]").
    by iApply inv_alloc.
  Qed.

  Lemma test_iInv_0 N P: inv N (<pers> P) ={⊤}=* |> P.
  Proof.
    iIntros "#H".
    iInv N as "#H2". Show.
    iModIntro. iSplit; auto.
  Qed.

  Lemma test_iInv_0_with_close N P: inv N (<pers> P) ={⊤}=* |> P.
  Proof.
    iIntros "#H".
    iInv N as "#H2" "Hclose". Show.
    iMod ("Hclose" with "H2").
    iModIntro. by iNext.
  Qed.

  Lemma test_iInv_1 N E P:
    ↑N ⊆ E ->
    inv N (<pers> P) ={E}=* |> P.
  Proof.
    iIntros (?) "#H".
    iInv N as "#H2".
    iModIntro. iSplit; auto.
  Qed.

  Lemma test_iInv_2 γ p N P:
    cinv N γ (<pers> P) ** cinv_own γ p ={⊤}=* cinv_own γ p ** |> P.
  Proof.
    iIntros "(#?&?)".
    iInv N as "(#HP&Hown)". Show.
    iModIntro. iSplit; auto with iFrame.
  Qed.

  Lemma test_iInv_2_with_close γ p N P:
    cinv N γ (<pers> P) ** cinv_own γ p ={⊤}=* cinv_own γ p ** |> P.
  Proof.
    iIntros "(#?&?)".
    iInv N as "(#HP&Hown)" "Hclose". Show.
    iMod ("Hclose" with "HP").
    iModIntro. iFrame. by iNext.
  Qed.

  Lemma test_iInv_3 γ p1 p2 N P:
    cinv N γ (<pers> P) ** cinv_own γ p1 ** cinv_own γ p2
      ={⊤}=* cinv_own γ p1 ** cinv_own γ p2  ** |> P.
  Proof.
    iIntros "(#?&Hown1&Hown2)".
    iInv N with "[Hown2 //]" as "(#HP&Hown2)".
    iModIntro. iSplit; auto with iFrame.
  Qed.

  Lemma test_iInv_4 t N E1 E2 P:
    ↑N ⊆ E2 ->
    na_inv t N (<pers> P) ** na_own t E1 ** na_own t E2
         |- |={⊤}=> na_own t E1 ** na_own t E2  ** |> P.
  Proof.
    iIntros (?) "(#?&Hown1&Hown2)".
    iInv N as "(#HP&Hown2)". Show.
    iModIntro. iSplitL "Hown2"; auto with iFrame.
  Qed.

  Lemma test_iInv_4_with_close t N E1 E2 P:
    ↑N ⊆ E2 ->
    na_inv t N (<pers> P) ** na_own t E1 ** na_own t E2
         |- |={⊤}=> na_own t E1 ** na_own t E2  ** |> P.
  Proof.
    iIntros (?) "(#?&Hown1&Hown2)".
    iInv N as "(#HP&Hown2)" "Hclose". Show.
    iMod ("Hclose" with "[HP Hown2]").
    { iFrame. done. }
    iModIntro. iFrame. by iNext.
  Qed.

  (* test named selection of which na_own to use *)
  Lemma test_iInv_5 t N E1 E2 P:
    ↑N ⊆ E2 ->
    na_inv t N (<pers> P) ** na_own t E1 ** na_own t E2
      ={⊤}=* na_own t E1 ** na_own t E2  ** |> P.
  Proof.
    iIntros (?) "(#?&Hown1&Hown2)".
    iInv N with "Hown2" as "(#HP&Hown2)".
    iModIntro. iSplitL "Hown2"; auto with iFrame.
  Qed.

  Lemma test_iInv_6 t N E1 E2 P:
    ↑N ⊆ E1 ->
    na_inv t N (<pers> P) ** na_own t E1 ** na_own t E2
      ={⊤}=* na_own t E1 ** na_own t E2  ** |> P.
  Proof.
    iIntros (?) "(#?&Hown1&Hown2)".
    iInv N with "Hown1" as "(#HP&Hown1)".
    iModIntro. iSplitL "Hown1"; auto with iFrame.
  Qed.

  (* test robustness in presence of other invariants *)
  Lemma test_iInv_7 t N1 N2 N3 E1 E2 P:
    ↑N3 ⊆ E1 ->
    inv N1 P ** na_inv t N3 (<pers> P) ** inv N2 P ** na_own t E1 ** na_own t E2
      ={⊤}=* na_own t E1 ** na_own t E2 ** |> P.
  Proof.
    iIntros (?) "(#?&#?&#?&Hown1&Hown2)".
    iInv N3 with "Hown1" as "(#HP&Hown1)".
    iModIntro. iSplitL "Hown1"; auto with iFrame.
  Qed.

  (* iInv should work even where we have "inv N P" in which P contains an evar *)
  Lemma test_iInv_8 N : ∃ P, inv N P ={⊤}=* P ≡ True /\ inv N P.
  Proof.
    eexists. iIntros "#H".
    iInv N as "HP". iFrame "HP". auto.
  Qed.

  (* test selection by hypothesis name instead of namespace *)
  Lemma test_iInv_9 t N1 N2 N3 E1 E2 P:
    ↑N3 ⊆ E1 ->
    inv N1 P ** na_inv t N3 (<pers> P) ** inv N2 P ** na_own t E1 ** na_own t E2
      ={⊤}=* na_own t E1 ** na_own t E2 ** |> P.
  Proof.
    iIntros (?) "(#?&#HInv&#?&Hown1&Hown2)".
    iInv "HInv" with "Hown1" as "(#HP&Hown1)".
    iModIntro. iSplitL "Hown1"; auto with iFrame.
  Qed.

  (* test selection by hypothesis name instead of namespace *)
  Lemma test_iInv_10 t N1 N2 N3 E1 E2 P:
    ↑N3 ⊆ E1 ->
    inv N1 P ** na_inv t N3 (<pers> P) ** inv N2 P ** na_own t E1 ** na_own t E2
      ={⊤}=* na_own t E1 ** na_own t E2 ** |> P.
  Proof.
    iIntros (?) "(#?&#HInv&#?&Hown1&Hown2)".
    iInv "HInv" as "(#HP&Hown1)".
    iModIntro. iSplitL "Hown1"; auto with iFrame.
  Qed.

  (* test selection by ident name *)
  Lemma test_iInv_11 N P: inv N (<pers> P) ={⊤}=* |> P.
  Proof.
    let H := iFresh in
    (iIntros H; iInv H as "#H2"). auto.
  Qed.

  (* error messages *)
  Check "test_iInv_12".
  Lemma test_iInv_12 N P: inv N (<pers> P) ={⊤}=* True.
  Proof.
    iIntros "H".
    Fail iInv 34 as "#H2".
    Fail iInv nroot as "#H2".
    Fail iInv "H2" as "#H2".
    done.
  Qed.

  (* test destruction of existentials when opening an invariant *)
  Lemma test_iInv_13 N:
    inv N (∃ (v1 v2 v3 : nat), emp ** emp ** emp) ={⊤}=* |> emp.
  Proof.
    iIntros "H"; iInv "H" as (v1 v2 v3) "(?&?&_)".
    eauto.
  Qed.

  Theorem test_iApply_inG `{!inG Σ A} γ (x x' : A) :
    x' ≼ x ->
    own γ x -* own γ x'.
  Proof. intros. by iApply own_mono. Qed.
End iris_tests.

Section monpred_tests.
  Context `{!invG Σ}.
  Context {I : biIndex}.
  Local Notation monPred := (monPred I (iPropI Σ)).
  Local Notation monPredI := (monPredI I (iPropI Σ)).
  Implicit Types P Q R : monPred.
  Implicit Types 𝓟 𝓠 𝓡 : iProp Σ.

  Check "test_iInv".
  Lemma test_iInv N E 𝓟 :
    ↑N ⊆ E ->
    ⎡inv N 𝓟⎤ |-@{monPredI} |={E}=> emp.
  Proof.
    iIntros (?) "Hinv".
    iInv N as "HP". Show.
    iFrame "HP". auto.
  Qed.

  Check "test_iInv_with_close".
  Lemma test_iInv_with_close N E 𝓟 :
    ↑N ⊆ E ->
    ⎡inv N 𝓟⎤ |-@{monPredI} |={E}=> emp.
  Proof.
    iIntros (?) "Hinv".
    iInv N as "HP" "Hclose". Show.
    iMod ("Hclose" with "HP"). auto.
  Qed.

End monpred_tests.

(** Test specifically if certain things parse correctly. *)
Section parsing_tests.
Context {PROP : bi}.
Implicit Types P : PROP.

Lemma test_bi_emp_valid : |-@{PROP} True.
Proof. naive_solver. Qed.

Lemma test_bi_emp_valid_parens : (|-@{PROP} True) /\ ((|-@{PROP} True)).
Proof. naive_solver. Qed.

Lemma test_bi_emp_valid_parens_space_open : ( |-@{PROP} True).
Proof. naive_solver. Qed.

Lemma test_bi_emp_valid_parens_space_close : (|-@{PROP} True ).
Proof. naive_solver. Qed.

Lemma test_entails_annot_sections P :
  (P |-@{PROP} P) /\ (|-@{PROP}) P P /\
  (P -|-@{PROP} P) /\ (-|-@{PROP}) P P.
Proof. naive_solver. Qed.

Lemma test_entails_annot_sections_parens P :
  ((P |-@{PROP} P)) /\ ((|-@{PROP})) P P /\
  ((P -|-@{PROP} P)) /\ ((-|-@{PROP})) P P.
Proof. naive_solver. Qed.

Lemma test_entails_annot_sections_space_open P :
  ( P |-@{PROP} P) /\
  ( P -|-@{PROP} P).
Proof. naive_solver. Qed.

Lemma test_entails_annot_sections_space_close P :
  (P |-@{PROP} P ) /\ (|-@{PROP} ) P P /\
  (P -|-@{PROP} P ) /\ (-|-@{PROP} ) P P.
Proof. naive_solver. Qed.

Check "p1".
Lemma p1 : forall P, True -> P |- P.
Proof.
  Unset Printing Notations. Show. Set Printing Notations.
Abort.

Check "p2".
Lemma p2 : forall P, True /\ (P |- P).
Proof.
  Unset Printing Notations. Show. Set Printing Notations.
Abort.

Check "p3".
Lemma p3 : exists P, P |- P.
Proof.
  Unset Printing Notations. Show. Set Printing Notations.
Abort.

Check "p4".
Lemma p4 : |-@{PROP} exists (x : nat), ⌜x = 0⌝.
Proof.
  Unset Printing Notations. Show. Set Printing Notations.
Abort.

Check "p5".
Lemma p5 : |-@{PROP} exists (x : nat), ⌜forall y : nat, y = y⌝.
Proof.
  Unset Printing Notations. Show. Set Printing Notations.
Abort.

Check "p6".
Lemma p6 : exists! (z : nat), |-@{PROP} exists (x : nat), ⌜forall y : nat, y = y⌝ ** ⌜z = 0⌝.
Proof.
  Unset Printing Notations. Show. Set Printing Notations.
Abort.

Check "p7".
Lemma p7 : forall (a : nat), a = 0 -> forall y, True |-@{PROP} ⌜y >= 0⌝.
Proof.
  Unset Printing Notations. Show. Set Printing Notations.
Abort.

Check "p8".
Lemma p8 : forall (a : nat), a = 0 -> forall y, |-@{PROP} ⌜y >= 0⌝.
Proof.
  Unset Printing Notations. Show. Set Printing Notations.
Abort.

Check "p9".
Lemma p9 : forall (a : nat), a = 0 -> forall y : nat, |-@{PROP} forall z : nat, ⌜z >= 0⌝.
Proof.
  Unset Printing Notations. Show. Set Printing Notations.
Abort.

Set Printing Notations.

End parsing_tests.


Require Import List.
Import ListNotations.
Require Import String.

(* Borrow from CompCert *)
Require Import Coqlib.
Require Import Bitvectors.

Require Import AST.
Require Import Semantics.
Require Import Utils.
Require Import Builtins.
Require Import BuiltinSem.
Require Import Values.

Require Import EvalTac.

Require Import HMAC.
Require Import HMACSpec.

(* TODO: here will be a proof about HMAC *)
(* relating the cryptol implementation to the spec *)

Definition lzero := EList ((ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 0)) nil)) (TCon (TC (TCNum 8)) nil)) :: nil).

Definition t := TCon (TC (TCNum 1)) nil.

Definition call_hmac_on_zero := EApp (EApp (ETApp (ETApp (EVar hmacSHA256) t) t) lzero) lzero.

Lemma eval_hmac_sha256 :
  exists v,
    eval_expr ge empty call_hmac_on_zero v.
Proof.

  eexists.
  e. e. e. e.
  g.
  e. e. e. e.
  e. e. e. e. e. e.
  e. e. e. e. e.
  e. e. e.
  e. do 10 e.
  e. e. e.
  e. e. e. e. e.
  e. e. e. e. e. e. g.
  e. e. e. e. e. e. e. e. e. e.
  repeat e. repeat e.

Admitted.


Require Import Infrastructure.
Require Import SourceProperty.
Require Import LR.
Require Import Assumed.
Require Import TargetProperty.
Require Import Disjoint.

(* ********************************************************************** *)
(** * Coercion Compatibility *)

Lemma E_coercion2 : forall A1 A2 A0 c p d d' e1 e2,
    sub d' A1 A2 c ->
    same_stctx d d' ->
    swfte d ->
    rel_d d p ->
    E A0 (mtsubst_in_sty p A1) e2 e1 ->
    E A0 (mtsubst_in_sty p A2) e2 (exp_capp c e1).
Proof with eauto.
  introv ? ? ? ? EH.
  apply E_sym in EH.
  apply E_sym.
  eapply E_coercion1...
Qed.

Lemma coercion_compatibility1 : forall A0 A1 A2 c D G e1 e2,
    sub D A1 A2 c ->
    swfte D ->
    E_open D G e1 e2 A1 A0 ->
    E_open D G (exp_capp c e1) e2 A2 A0.
Proof with eauto using subtype_well_type, swft_wft, E_coercion1.
  introv Sub Uniq H.
  destruct H as (? & ? & ? & ? & EH).

  lets (? & ?): sub_regular Sub.

  splits...
  introv RelD RelG.
  specializes EH RelD RelG.
  autorewrite with lr_rewrite...
Qed.

Lemma coercion_compatibility2 : forall A0 A1 A2 c D G e1 e2,
    sub D A1 A2 c ->
    swfte D ->
    E_open D G e1 e2 A0 A1 ->
    E_open D G e1 (exp_capp c e2) A0 A2.
Proof with eauto using subtype_well_type, swft_wft, E_coercion2.
  introv Sub Uniq H.
  destruct H as (? & ? & ? & ? & EH).

  lets (? & ?): sub_regular Sub.

  splits...
  introv RelD RelG.
  specializes EH RelD RelG.
  autorewrite with lr_rewrite...
Qed.

Hint Extern 1 (swfte ?E) =>
  match goal with
  | H: has_type _ _ _ _ _ _ |- _ => apply (proj2 (proj2 (proj2 (styping_regular _ _ _ _ _ _ H))))
  end.

Hint Extern 1 (swft ?A ?B) =>
  match goal with
  | H: has_type _ _ _ _ _ _ |- _ => apply (proj1 (proj2 (proj2 (styping_regular _ _ _ _ _ _ H))))
  end.

Lemma disjoint_compatibility : forall Δ Γ E1 e1 A1 E2 e2 A2 dir dir',
    has_type Δ Γ E1 dir A1 e1 ->
    has_type Δ Γ E2 dir' A2 e2 ->
    disjoint Δ A1 A2 ->
    E_open Δ Γ e1 e2 A1 A2.
Proof with eauto using swft_wft, swfe_wfe, elaboration_well_type, swft_from_swfe, mtsubst_swft, uniq_from_swfte.
  introv Ty1 Ty2 Dis.
  splits...
  introv RelD RelG.
  forwards (? & ?): rel_d_uniq RelD.
  forwards : rel_d_same RelD...
  forwards Ty3 : elaboration_well_type Ty1...
  forwards Ty4 : elaboration_well_type Ty2...
  forwards (Ty5 & ?) : subst_close RelD RelG Ty3.
  forwards (? & Ty6) : subst_close RelD RelG Ty4.
  splits...
  lets (v1 & ? & ?) : normalization Ty5.
  lets (v2 & ? & ?) : normalization Ty6.
  exists v1 v2.
  splits...
  eapply disjoint_value...
  apply preservation_multi_step with (e := msubst_in_exp g1 (mtsubst_in_exp p e1))...
  apply preservation_multi_step with (e := msubst_in_exp g2 (mtsubst_in_exp p e2))...
Qed.

(* ********************************************************************** *)
(** * Pair compatibility *)

Lemma pair_compatibility : forall D G e1 e2 e1' e2' A B A' B',
    E_open D G e1 e1' A A' ->
    E_open D G e2 e2' B B' ->
    swfte D ->
    disjoint D A B' ->
    disjoint D A' B ->
    E_open D G (exp_pair e1 e2) (exp_pair e1' e2') (sty_and A B) (sty_and A' B').
Proof with eauto using preservation_multi_step.
  introv EH1 EH2 Wfte Dis1 Dis2.

  destruct EH1 as (? & ? & ? & ? & EH1).
  destruct EH2 as (? & ? & ? & ? & EH2).

  splits; simpls...
  introv RelD RelG.
  specializes EH1 RelD RelG.
  specializes EH2 RelD RelG.

  destruct EH1 as (? & ? & ? & ? & v1 & v1' & ? & ? & ? & ? & VH1).
  destruct EH2 as (? & ? & ? & ? & v2 & v2' & ? & ? & ? & ? & VH2).

  splits; autorewrite with lr_rewrite; simpls...

  exists (exp_pair v1 v2) (exp_pair v1' v2').
  splits...

  apply V_andl...
  splits...
  apply V_andr...
  splits...
  eapply disjoint_value...
  apply V_andr...
  splits...
  eapply disjoint_value...
  eapply disjoint_symmetric...
Qed.