(** * Equivalence up to taus *)

(** Abbreviated as [eutt]. *)

(** We consider [Tau] as an "internal step", that should not be
   visible to the outside world, so adding or removing [Tau]
   constructors from an itree should produce an equivalent itree.

   We must be careful because there may be infinite sequences of
   taus (i.e., [spin]). Here we shall only allow inserting finitely
   many [Tau]s between any two visible steps ([Ret] or [Vis]), so that
   [spin] is only related to itself. This ensures that equivalence
   up to taus is transitive (and in fact an equivalence relation).
 *)

(** A rewrite hint database named [itree] is available via the tactic
    [autorewrite with itree] as a custom simplifier of expressions using
    mainly [Ret], [Tau], [Vis], [ITree.bind] and [ITree.Interp.Interp.interp].
 *)

(** This file contains only the definition of the [eutt] relation.
    Theorems about [eutt] are split in two more modules:

    - [ITree.Eq.UpToTausCore] proves that [eutt] is reflexive, symmetric,
      and that [ITree.Eq.Eqit.eq_itree] is a subrelation of [eutt].
      Equations for [ITree.Core.ITreeDefinition] combinators which only rely on
      those properties can also be found here.

    - [ITree.Eq.UpToTausEquivalence] proves that [eutt] is transitive,
      and, more generally, contains theorems for up-to reasoning in
      coinductive proofs.
 *)

(** Splitting things this way makes the library easier to build in parallel.
 *)

(* begin hide *)
From Coq Require Import Setoid Morphisms Relations.
From Paco Require Import paco.

From ITree Require Import
     Basics.Tacs
     Core.ITreeDefinition
     Eq.Eqit
     Eq.Paco2
     Eq.Shallow.

#[local] Open Scope itree_scope.
(* end hide *)

(** ** gpaco
*)

Tactic Notation "gpaco_" :=
  match goal with
  | [|- context[gpaco2]] => eapply gpaco2_gpaco; [eauto with paco|]
  end.
Ltac gpaco := repeat red; under_forall ltac:(gpaco_).

(**** END ****)

Section EUTTG.

Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop).

Definition transU := @eqit_trans_clo E R1 R2 RR true true true true.
Definition transD := @eqit_trans_clo E R1 R2 RR true true false false.
Definition bindC := @eqit_bind_clo E R1 R2 true true.

Definition euttVC gH r :=
  gupaco2 (eqit_ RR true true id) transD (transU (r \2/ gH)).

Variant euttG rH rL gL gH t1 t2 : Prop :=
| euttG_intro
    (IN: gpaco2 (@eqit_ E R1 R2 RR true true (euttVC gH)) transD (transU rH \2/ rL) gL t1 t2)
.

Hint Unfold transU transD bindC euttVC : itree.
Hint Constructors euttG : itree.

Lemma transD_mon r1 r2 t1 t2
      (IN: transD r1 t1 t2)
      (LE: r1 <2= r2):
  transD r2 t1 t2.
Proof. eapply eqitC_mon, LE; eauto. Qed.

Lemma transU_mon r1 r2 t1 t2
      (IN: transU r1 t1 t2)
      (LE: r1 <2= r2):
  transU r2 t1 t2.
Proof.
  destruct IN. econstructor; eauto.
Qed.

Lemma transDleU: transD <3= transU.
Proof.
  intros. destruct PR. econstructor; eauto using eqit_mon.
Qed.

Lemma transD_compose:
  compose transD transD <3= transD.
Proof.
  intros. destruct PR. destruct REL.
  econstructor; try eapply eqit_trans; eauto; auto_ctrans.
Qed.

Lemma transU_compose:
  compose transU transU <3= transU.
Proof.
  intros. destruct PR. destruct REL.
  econstructor; try eapply eqit_trans; eauto; auto_ctrans.
Qed.

Lemma transD_id: id <3= transD.
Proof. intros. econstructor; try reflexivity; auto_ctrans. Qed.

Lemma transU_id: id <3= transU.
Proof. intros. econstructor; try reflexivity; auto_ctrans. Qed.

Hint Resolve transD_mon transU_mon : paco.

Lemma euttVC_mon gH:
  monotone2 (euttVC gH).
Proof.
  red; intros.
  eapply gupaco2_mon; eauto. intros.
  eapply transU_mon; eauto. intros.
  destruct PR0; eauto.
Qed.
Hint Resolve euttVC_mon : paco.

Lemma euttVC_compat gH:
  compose transD (euttVC gH) <3= compose (euttVC gH) transD.
Proof.
  intros. gclo. eapply transD_mon; eauto. intros.
  eapply gupaco2_mon; eauto. intros.
  eapply transU_mon; eauto. intros.
  destruct PR2; eauto.
  left. econstructor; try reflexivity; auto_ctrans.
Qed.
Hint Resolve euttVC_compat : paco.

Lemma euttVC_id gH:
  id <3= euttVC gH.
Proof.
  intros. gbase. econstructor; try reflexivity; auto_ctrans.
Qed.
Hint Resolve euttVC_id : paco.

End EUTTG.

#[global] Hint Unfold transU transD bindC euttVC : itree.
#[global] Hint Constructors euttG : itree.
#[global] Hint Resolve transD_mon transU_mon : paco.
#[global] Hint Resolve euttVC_mon : paco.
#[global] Hint Resolve euttVC_compat : paco.
#[global] Hint Resolve transD_id transU_id euttVC_id : paco.

#[global]
Instance geuttG_cong_euttge {E R1 R2 RR} gH r g:
  Proper (euttge eq ==> euttge eq ==> flip impl)
         (gpaco2 (@eqit_ E R1 R2 RR true true (euttVC RR gH)) (transD RR) r g).
Proof.
  repeat intro. guclo eqit_clo_trans. econstructor; eauto; auto_ctrans.
Qed.

#[global]
Instance geuttG_cong_eq {E R1 R2 RR} gH r g:
  Proper (eq_itree eq ==> eq_itree eq ==> flip impl)
         (gpaco2 (@eqit_ E R1 R2 RR true true (euttVC RR gH)) (transD RR) r g).
Proof.
  repeat intro. eapply geuttG_cong_euttge;
    [ eapply eq_sub_euttge; eassumption .. | eauto with itree ].
Qed.

Lemma eqit_ret_gen {E R1 R2 RR} t v
      (IN: @eqit E R1 R2 RR true true t (Ret v)):
  eqit RR true false t (Ret v).
Proof.
  punfold IN. pstep. red in IN |- *. simpl in *.
  remember (RetF v) as ot.
  hinduction IN before RR; intros; subst; try inv Heqot; eauto with itree.
Qed.

Section EUTTG_Properties1.

Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop).

Local Notation euttG := (@euttG E R1 R2 RR).

Lemma rclo_transD r:
  rclo2 (transD RR) r <2= @transD E R1 R2 RR r.
Proof.
  intros. induction PR; eauto with paco.
  destruct IN. apply H in REL. destruct REL.
  econstructor; try apply REL; try eapply eqit_trans; eauto; auto_ctrans.
Qed.

Lemma rclo_flip clo (r: itree E R1 -> itree E R2 -> Prop)
      (MON: monotone2 clo):
  flip (rclo2 (fun x : itree E R2 -> itree E R1 -> Prop => flip (clo (flip x))) (flip r)) <2= rclo2 clo r.
Proof.
  intros. induction PR; eauto with paco.
  apply rclo2_clo; eauto.
Qed.

Lemma transD_flip r:
  flip (transD (flip RR) (flip r)) <2= @transD E _ _ RR r.
Proof.
  unfold flip. intros. destruct PR. econstructor; eauto.
Qed.

Lemma transU_flip r:
  flip (transU (flip RR) (flip r)) <2= @transU E R1 R2 RR r.
Proof.
  unfold flip. intros. destruct PR. econstructor; eauto.
Qed.

Lemma euttVC_flip gH r:
  flip (euttVC (flip RR) (flip gH) (flip r)) <2= @euttVC E R1 R2 RR gH r.
Proof.
  pcofix CIH. intros. gunfold PR.
  gclo. apply rclo_transD.
  eapply rclo_flip; eauto with paco.
  eapply rclo2_mon_gen; eauto; intros.
  { eapply transD_flip. eauto. }
  destruct PR0; cycle 1.
  { gbase. destruct H; eauto using transU_flip with itree. }
  gstep. apply eqitF_flip.
  eapply eqitF_mono; eauto with paco. intros.
  gbase. eapply CIH.
  eapply gupaco2_mon; eauto. intros.
  destruct PR1; eauto.
Qed.

Lemma euttG_flip gH r:
  flip (gupaco2 (eqit_ (flip RR) true true (euttVC (flip RR) (flip gH))) (transD (flip RR)) (flip r)) <2=
  gupaco2 (@eqit_ E R1 R2 RR true true (euttVC RR gH)) (transD RR) r.
Proof.
  pcofix CIH; intros.
  destruct PR. econstructor.
  eapply rclo_flip; eauto with paco.
  eapply rclo2_mon_gen; [ eauto using transD_flip with itree .. | ]. intros.
  destruct PR; [ | eauto with itree ].
  left. punfold H. pstep. apply eqitF_flip.
  eapply eqitF_mono; eauto with paco; intros.
  - eapply euttVC_flip. apply PR.
  - apply rclo_flip; eauto with paco.
    eapply rclo2_mon_gen; [ eauto using transD_flip with paco itree .. | ].
    intros. right. left. destruct PR0.
    + eapply CIH. red. eauto with paco.
    + apply CIH0. destruct H0; eauto.
Qed.

Lemma transD_dist:
  forall r1 r2, @transD E R1 R2 RR (r1 \2/ r2) <2= (transD RR r1 \2/ transD RR r2).
Proof. apply eqitC_dist. Qed.

Lemma transU_dist:
  forall r1 r2, @transU E R1 R2 RR (r1 \2/ r2) <2= (transU RR r1 \2/ transU RR r2).
Proof.
  intros. destruct PR. destruct REL; [left|right]; eauto with itree.
Qed.

Lemma transU_dist_rev:
  forall r1 r2, (transU RR r1 \2/ transU RR r2) <2= @transU E R1 R2 RR (r1 \2/ r2).
Proof.
  intros. destruct PR, H; eauto with itree.
Qed.

Variant transL (r: itree E R1 -> itree E R2 -> Prop) (t1: itree E R1) (t2: itree E R2) : Prop :=
| transL_intro t' RR1
               (EQL: eqit RR1 true true t1 t')
               (EQR: r t' t2)
               (LERR: forall x x' y, RR1 x x' -> RR x' y -> RR x y)
  : transL r t1 t2
.
Hint Constructors transL : itree.

Lemma transD_transL r:
  transD RR (transL r) <2= transL (transD RR r).
Proof.
  intros. destruct PR, REL.
  econstructor; [|econstructor|]; try apply EQR.
  - eapply eqit_trans.
    + apply euttge_sub_eutt. eauto.
    + eauto.
  - reflexivity.
  - eauto.
  - auto_ctrans.
  - auto_ctrans.
  - auto_ctrans.
Qed.

Lemma transLleU: transL <3= transU RR.
Proof.
  intros. destruct PR. econstructor; eauto. reflexivity. auto_ctrans.
Qed.

Lemma transL_closed vclo r
      (MON: monotone2 vclo)
      (COMP: wcompatible2 (eqit_ RR true true vclo) (transD RR))
      (CLOV: forall r (CLOL: transL r <2= r), transL (vclo r) <2= vclo r)
      (CLOL: transL r <2= r)
      (CLOD: transD RR r <2= r):
  transL (gupaco2 (eqit_ RR true true vclo) (transD RR) r)
  <2= gupaco2 (eqit_ RR true true vclo) (transD RR) r.
Proof.
  pcofix CIH. intros t1 t2 [].
  apply gpaco2_dist in EQR; eauto with paco.
  destruct EQR; cycle 1.
  { gbase. apply rclo_transD in H. destruct H. eauto 6 with itree. }
  assert (REL: paco2 (eqit_ RR true true vclo) r t' t2).
  { eapply paco2_mon; eauto. intros.
    apply rclo_transD in PR. apply CLOD.
    eapply transD_mon; eauto. intros. destruct PR0; eauto.
  }
  clear H.

  punfold EQL. red in EQL. punfold REL. red in REL. genobs t1 ot1. genobs t' ot'.
  hinduction EQL before CIH; intros; subst.
  - remember (RetF r2) as ot. genobs t2 ot2.
    hinduction REL0 before CIH; intros; subst; try inv Heqot.
    + gstep. red. simpobs. eauto with itree.
    + gclo. econstructor; auto_ctrans_eq.
      * rewrite (simpobs Heqot1). reflexivity.
      * rewrite (simpobs Heqot2), tau_euttge. reflexivity.
  - pclearbot. apply eqit_Tau_r in REL. rewrite Heqot' in REL, REL0. clear m2 Heqot'.
    genobs t' ot'. genobs t2 ot2.
    hinduction REL0 before CIH; intros; subst.
    + apply eqit_ret_gen in REL0.
      gclo. econstructor.
      * eapply eqit_trans; [rewrite (simpobs Heqot1); reflexivity|].
        eapply eqit_trans; [rewrite tau_euttge; reflexivity|].
        eauto.
      * rewrite (simpobs Heqot2). reflexivity.
      * gstep. econstructor. eauto.
      * auto_ctrans.
      * auto_ctrans.
    + gstep. red. simpobs. econstructor. gbase.
      destruct REL.
      * eapply CIH. econstructor; [|eauto using paco2_mon with paco|].
        -- eapply eqit_trans; [apply REL0|]. rewrite tau_eutt. reflexivity.
        -- auto_ctrans.
      * eapply CIH0. apply CLOL. econstructor; [|eauto|].
        -- eapply eqit_trans; [apply REL0|]. rewrite tau_eutt. reflexivity.
        -- auto_ctrans.
    + punfold REL0. red in REL0. simpl in *.
      remember (VisF e k1) as ot. genobs m1 ot2.
      hinduction REL0 before CIH; intros; try discriminate.
      * inv_Vis. pclearbot. gstep. red. do 2 (simpobs; econstructor; eauto). intros.
        eapply MON; [|intros; gbase; eapply CIH; eauto].
        eapply CLOV.
        { intros. destruct PR, EQR.
          econstructor; [|eauto|]; eauto using eqit_trans; auto_ctrans. }
        econstructor; [ eauto with itree | | auto ].
        eapply MON; eauto. intros.
        econstructor; try reflexivity; auto_ctrans.
        gfinal. destruct PR; eauto.
      * gclo; econstructor; auto_ctrans_eq; try reflexivity.
        rewrite (simpobs Heqot1), tau_euttge. reflexivity.
    + eapply IHREL0; try eapply eqit_trans; auto_ctrans_eq.
      rewrite <-itree_eta, tau_eutt. reflexivity.
    + gclo; econstructor; auto_ctrans_eq; try reflexivity.
      rewrite (simpobs Heqot2), tau_euttge. reflexivity.
  - remember (VisF e k2) as ot. genobs t2 ot2.
    hinduction REL0 before CIH; intros; subst; try discriminate.
    + inv_Vis. pclearbot. gstep. red. simpobs. econstructor; eauto. intros.
      eapply MON; [|intros; gbase; eapply CIH; eauto].
      eapply CLOV.
      { intros. destruct PR, EQR.
        econstructor; swap 1 2; eauto using eqit_trans; auto_ctrans. }
      econstructor; [ eauto with itree | | auto ].
      eapply MON; eauto. intros.
      econstructor; auto_ctrans_eq; try reflexivity.
      gfinal. destruct PR; eauto.
    + gclo; econstructor; auto_ctrans_eq; try reflexivity.
      rewrite (simpobs Heqot2), tau_euttge. reflexivity.
  - gclo; econstructor; auto_ctrans_eq; try reflexivity.
    rewrite (simpobs Heqot1), tau_euttge. reflexivity.
  - clear t' Heqot'. remember (TauF t2) as ot. genobs t0 ot0.
    hinduction REL before EQL; intros; subst; try inv Heqot; eauto; cycle 1.
    + gclo; econstructor; auto_ctrans_eq; try reflexivity.
      rewrite (simpobs Heqot0), tau_euttge. reflexivity.
    + destruct REL; cycle 1.
      * gbase. apply CLOL. econstructor; [ eauto with itree | | auto ].
        apply CLOD. econstructor; auto_ctrans_eq; try reflexivity.
        rewrite (simpobs Heqot0), tau_euttge. reflexivity.
      * eapply IHEQL; eauto.
        simpobs. econstructor; eauto.
        punfold H.
Qed.

Lemma euttVC_transL gH r:
  transL (euttVC RR gH r) <2= euttVC RR gH r.
Proof.
  intros. eapply transL_closed; eauto using transU_compose, transLleU, transDleU with paco.
Qed.

End EUTTG_Properties1.

Section EUTTG_Properties2.

Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop).

Local Notation euttG := (@euttG E R1 R2 RR).

Lemma euttVC_transU gH r
      (CLOR: transU RR r <2= r):
  transU RR (euttVC RR gH r) <2= @euttVC E _ _ RR gH r.
Proof.
  intros. destruct PR.
  eapply euttVC_transL; eauto using transLleU, transDleU with paco.
  econstructor; eauto.
  eapply euttVC_flip. unfold flip.
  eapply euttVC_transL; eauto using transLleU, transDleU, transU_flip with paco.
  econstructor; eauto.
  apply euttVC_flip. eauto.
Qed.

Lemma euttG_transU_aux gH r
      (CLOR: transU RR r <2= r):
  transU RR (gupaco2 (eqit_ RR true true (euttVC RR gH)) (transD RR) r) <2=
  gupaco2 (@eqit_ E R1 R2 RR true true (euttVC RR gH)) (transD RR) r.
Proof.
  intros. destruct PR.
  eapply transL_closed; eauto using euttVC_transL, transLleU, transDleU with paco.
  econstructor; eauto.
  apply euttG_flip. unfold flip.
  eapply transL_closed;
   [ eauto using euttVC_transL, transLleU, transDleU, transU_flip with paco itree .. | ].
  econstructor; eauto using euttG_flip with itree.
Qed.

Lemma euttVC_gen gH r:
  transU RR (gupaco2 (eqit_ RR true true (euttVC RR gH)) (transD RR) (transU RR (r \2/ gH)))
  <2= @euttVC E R1 R2 RR gH r.
Proof.
  intros. eapply euttG_transU_aux in PR; eauto using transU_compose.
  revert x0 x1 PR. pcofix CIH. intros.
  gunfold PR. apply rclo_transD in PR.
  gclo. eapply transD_mon; eauto. intros.
  destruct PR0; eauto with paco.
  gstep. red in H |- *. induction H; auto with itree.
  - econstructor. gbase. eapply CIH.
    eapply gupaco2_mon; eauto. intros.
    destruct PR0; eauto.
  - econstructor. intros. gbase. eapply CIH.
    red in REL. gupaco. eapply gupaco2_mon_gen; eauto with paco; intros.
    + eapply eqitF_mono; eauto with paco.
    + eapply euttG_transU_aux; eauto using transU_compose with paco.
      eapply transU_mon; eauto. intros.
      destruct PR1; [|eauto 7 with paco].
      eapply gupaco2_mon; eauto. intros.
      destruct PR1; eauto.
Qed.

Lemma euttG_gen rH rL gL gH:
  euttG rH rL (gL \2/ (transU RR rH \2/ rL)) gH <2= euttG rH rL gL gH.
Proof.
  intros. destruct PR. econstructor.
  eapply gpaco2_gen_guard. eauto.
Qed.

Lemma euttG_cofix_aux: forall rH rL gL gH x,
    (x <2= euttG rH rL (gL \2/ x) (gH \2/ x)) -> (x <2= euttG rH rL gL gH).
Proof.
  intros. apply euttG_gen.
  econstructor. revert x0 x1 PR. pcofix CIH.
  intros t1 t2 PR. apply H in PR. destruct PR as [IN]. revert t1 t2 IN.
  pcofix CIH. intros.
  apply gpaco2_dist in IN; eauto with paco.
  destruct IN; cycle 1.
  { apply rclo_transD in H0; eauto with paco.
    gclo. eapply transD_mon; eauto with paco.
  }
  assert (LEM: upaco2 (eqit_ RR true true (euttVC RR (gH \2/ x)))
                      (rclo2 (transD RR) ((gL \2/ x) \2/ (transU RR rH \2/ rL)))
               <2= gpaco2 (eqit_ RR true true (euttVC RR gH)) (transD RR) r0 r0).
  { intros m1 m2 [REL|REL].
    - gbase. apply CIH1.
      gpaco. gfinal. right.
      eapply paco2_mon; eauto. intros.
      apply rclo_transD in PR. gclo. eapply transD_mon; eauto. intros. gbase.
      repeat destruct PR0 as [PR0|PR0]; eauto.
    - apply rclo_transD in REL. gclo. eapply transD_mon; eauto. intros. gbase.
      repeat destruct PR as [PR|PR]; eauto.
  }

  punfold H0. gstep. red in H0 |- *.
  induction H0; auto 3 with itree.
  red in REL. econstructor. intros.
  eapply gupaco2_mon; eauto. intros.
  apply transU_dist in PR. destruct PR; eauto using transU_mon.
  eapply transU_mon; eauto. intros; destruct PR; eauto with paco.
Qed.

End EUTTG_Properties2.

Section EUTTG_principles.

Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop).

Local Notation euttG := (@euttG E R1 R2 RR).

(* Make new hypotheses *)

Lemma euttG_cofix rH rL gL gH x
      (OBG: forall gL' (INCL: gL <2= gL') (CIHL: x <2= gL') gH' (INCH: gH <2= gH') (CIHH: x <2= gH'), x <2= euttG rH rL gL' gH'):
    x <2= euttG rH rL gL gH.
Proof.
  eapply euttG_cofix_aux; intros.
  eapply OBG; eauto.
Qed.

Lemma euttG_accF rH rL gL gH X (f : X -> _) (g : X -> _)
    (OBJ: forall gL' (INCL: gL <2= gL') (CIHL: forall x : X, gL' (f x) (g x)) gH' (INCH: gH <2= gH') (CIHH: forall x : X, gH' (f x) (g x)), forall x : X, euttG rH rL gL' gH' (f x) (g x)):
    forall x : X, euttG rH rL gL gH (f x) (g x).
Proof.
  intros x.
  apply euttG_cofix with (x := fun a b => exists x, a = (f x) /\ b = (g x)); [ | eauto ].
  intros. destruct PR as [? [-> ->]]. apply OBJ; eauto.
Qed.

(* Process itrees *)

Lemma euttG_ret: forall rH rL gL gH v1 v2,
  RR v1 v2 -> euttG rH rL gL gH (Ret v1) (Ret v2).
Proof.
  econstructor. gstep. econstructor. eauto.
Qed.

Lemma euttG_bind: forall rH rL gL gH t1 t2,
  bindC (euttG rH rL gL gH) t1 t2 -> euttG rH rL gL gH t1 t2.
Proof.
  econstructor. guclo eqit_clo_bind.
  destruct H. econstructor; eauto.
  intros. edestruct REL; eauto.
Qed.

Lemma euttG_transD: forall rH rL gL gH t1 t2,
  transD RR (euttG rH rL gL gH) t1 t2 -> euttG rH rL gL gH t1 t2.
Proof.
  econstructor. guclo eqit_clo_trans.
  destruct H. econstructor; eauto.
  edestruct REL; eauto.
Qed.

(* Drop weak hypotheses for general rewriting *)

Lemma euttG_transU rH rL gL gH t1 t2:
  transU RR (euttG rH rH rH gH) t1 t2 -> euttG rH rL gL gH t1 t2.
Proof.
  intros. apply euttG_gen.
  cut (gupaco2 (eqit_ RR true true (euttVC RR gH)) (transD RR) (transU RR rH) t1 t2).
  { intros. econstructor. eapply gpaco2_mon; eauto. }
  eapply euttG_transU_aux; eauto using transU_compose.
  eapply transU_mon; eauto. intros. destruct PR.
  eapply gpaco2_mon; eauto; intros;
    repeat destruct PR as [PR|PR]; eauto using transU_id.
Qed.

Lemma euttG_drop rH rL gL gH t1 t2:
  euttG rH rH rH gH t1 t2 -> euttG rH rL gL gH t1 t2.
Proof.
  intros. apply euttG_gen. destruct H. econstructor.
  eapply gpaco2_mon; intros; eauto; [destruct PR|]; eauto using transU_id.
Qed.

(* Make a weakly guarded progress *)

Lemma euttG_tau: forall rH rL gL gH t1 t2,
  euttG rH gL gL gH t1 t2 -> euttG rH rL gL gH (Tau t1) (Tau t2).
Proof.
  intros. apply euttG_gen. destruct H. econstructor.
  gstep. econstructor.
  eapply gpaco2_mon; eauto; intros; repeat destruct PR as [PR|PR]; eauto.
Qed.

(* Make a strongly guarded progress *)

Lemma euttG_vis: forall rH rL gL gH u (e: E u) k1 k2,
  (forall v, euttG gH gH gH gH (k1 v) (k2 v)) -> euttG rH rL gL gH (Vis e k1) (Vis e k2).
Proof.
  econstructor. gstep. econstructor. intros.
  specialize (H v). destruct H.
  apply euttVC_gen. econstructor; auto_ctrans_eq; try reflexivity.
  eapply gpaco2_mon_gen; eauto; intros; repeat destruct PR as [PR|PR];
    eauto using gpaco2_clo, transDleU, transU_mon with paco.
Qed.

Lemma euttG_vis_gen rH rL gL gH u1 (e1: E u1) u2 (e2 : E u2) k1 k2 (p : u1 = u2)
  : eqeq E p e1 e2 -> pweqeq (euttG gH gH gH gH) p k1 k2 ->
    euttG rH rL gL gH (Vis e1 k1) (Vis e2 k2).
Proof.
  econstructor. gstep. apply (eqitF_VisF_gen p); auto. destruct p; cbn in *; intros.
  specialize (H0 x). destruct H0.
  apply euttVC_gen. econstructor; auto_ctrans_eq; try reflexivity.
  eapply gpaco2_mon_gen; eauto; intros; repeat destruct PR as [PR|PR];
    eauto using gpaco2_clo, transDleU, transU_mon with paco.
Qed.

(* Use available hypotheses *)

Lemma euttG_base: forall rH rL gL gH t1 t2,
  rH t1 t2 \/ rL t1 t2 -> euttG rH rL gL gH t1 t2.
Proof.
  intros. econstructor. gbase.
  destruct H; eauto using transU_id.
Qed.

(**
   Correctness
 **)

Lemma euttG_le_eutt:
  euttG bot2 bot2 bot2 bot2 <2= eutt RR.
Proof.
  intros. destruct PR.
  assert(paco2 (eqit_ RR true true (euttVC RR bot2)) bot2 x0 x1).
  { eapply gpaco2_init; eauto with paco.
    eapply gpaco2_mon; eauto; intros;
      repeat destruct PR as [PR|PR]; destruct PR; contradiction.
  }
  clear IN.
  revert x0 x1 H. pcofix CIH. intros.
  punfold H. pstep. unfold_eqit.
  induction H; pclearbot; auto with itree.
  econstructor; intros. specialize (REL v).
  right. apply CIH.
  ginit. gupaco. eapply gupaco2_mon_gen; eauto with paco; intros.
  - eapply eqitF_mono; eauto with paco.
  - apply euttG_transU_aux.
    { intros. destruct PR0; contradiction. }
    eapply transU_mon; eauto. intros.
    pclearbot. gfinal. eauto.
Qed.

Lemma eutt_le_euttG rH rL gL gH:
  eutt RR <2= euttG rH rL gL gH.
Proof.
  intros. econstructor. econstructor. apply rclo2_base. left.
  eapply paco2_mon_bot; eauto; intros.
  eapply eqitF_mono; eauto with paco.
Qed.

End EUTTG_principles.

Ltac apply_paco_acc CIH unpack_goal unpack_hyp :=
  apply euttG_accF;
  let gL' := fresh "gL'" in
  let INCL := fresh "INCL" in
  let CIHL := fresh CIH "L" in
  let gH' := fresh "gH'" in
  let INCH := fresh "INCH" in
  let CIHH := fresh CIH "H" in
  intros gL' INCL CIHL gH' INCH CIHH;
  unpack_goal tt;
  unpack_hyp CIHL;
  unpack_hyp CIHH.

Ltac ecofix CIH := pcofix_with ltac:(apply_paco_acc CIH).

Ltac einit := repeat red; under_forall ltac:(eapply euttG_le_eutt; eauto with paco itree).
Ltac efinal := repeat red; under_forall ltac:(eapply eutt_le_euttG; eauto with paco itree).
Ltac ebase := repeat red; under_forall ltac:(eapply euttG_base; eauto with paco itree).
Ltac eret := repeat red; under_forall ltac:(eapply euttG_ret; eauto with paco itree).
Ltac etau := repeat red; under_forall ltac:(eapply euttG_tau; eauto with paco itree).
Ltac evis := repeat red; under_forall ltac:(eapply euttG_vis; eauto with paco itree).
Ltac estep := first [eret|etau|evis].
Ltac ebind := repeat red; under_forall ltac:(eapply euttG_bind; eauto with paco itree).
Ltac edrop := repeat red; under_forall ltac:(eapply euttG_drop; eauto with paco itree).

Global Hint Resolve euttG_ret : paco.
Global Hint Resolve euttG_tau : paco.
Global Hint Resolve euttG_vis : paco.
Global Hint Resolve euttG_base : paco.
Global Hint Resolve euttG_le_eutt: paco.

#[global]
Instance euttG_reflexive {E R} rH rL gL gH:
  Reflexive (@euttG E R R eq rH rL gL gH).
Proof.
  red; intros. efinal. reflexivity.
Qed.

#[global]
Instance euttG_cong_eutt {E R1 R2 RR} rH gH:
  Proper (eutt eq ==> eutt eq ==> flip impl)
         (@euttG E R1 R2 RR rH rH rH gH).
Proof.
  repeat intro. eapply euttG_transU. econstructor; auto_ctrans_eq; eauto.
Qed.

#[global]
Instance euttG_cong_euttge {E R1 R2 RR} rH rL gL gH:
  Proper (euttge eq ==> euttge eq ==> flip impl)
         (@euttG E R1 R2 RR rH rL gL gH).
Proof.
  repeat intro. eapply euttG_transD. econstructor; auto_ctrans_eq; eauto.
Qed.

#[global]
Instance euttG_cong_eq {E R1 R2 RR} rH rL gL gH:
  Proper (eq_itree eq ==> eq_itree eq ==> flip impl)
         (@euttG E R1 R2 RR rH rL gL gH).
Proof.
  repeat intro. eapply euttG_cong_euttge; eauto; apply eq_sub_euttge; eauto.
Qed.

#[global]
Instance eutt_cong_eutt {E R1 R2 RR}:
  Proper (eutt eq ==> eutt eq ==> flip impl)
         (@eqit E R1 R2 RR true true).
Proof.
  einit. intros. rewrite H0, H1. efinal.
Qed.

#[global]
Instance eutt_cong_euttge {E R1 R2 RR}:
  Proper (euttge eq ==> euttge eq ==> flip impl)
         (@eqit E R1 R2 RR true true).
Proof.
  einit. intros. rewrite H0, H1. efinal.
Qed.

#[global]
Instance eutt_cong_eq {E R1 R2 RR}:
  Proper (eq_itree eq ==> eq_itree eq ==> flip impl)
         (@eqit E R1 R2 RR true true).
Proof.
  einit. intros. rewrite H0, H1. efinal.
Qed.

#[global]
Instance eutt_cong_eutt' {E R1 R2 RR} :
  Proper (eutt eq ==> eutt eq ==> flip impl) (@eutt E R1 R2 RR).
Proof.
  apply eutt_cong_eutt.
Qed.

(* Specialization of [eutt_clo_bind] to the recurrent case where [UU := eq]
   in order to avoid having to provide the relation manually everytime *)
Lemma eutt_eq_bind : forall E R1 R2 RR U (t: itree E U) (k1: U -> itree E R1) (k2: U -> itree E R2),
    (forall u, eutt RR (k1 u) (k2 u)) -> eutt RR (ITree.bind t k1) (ITree.bind t k2).
Proof.
  intros.
  apply eutt_clo_bind with (UU := Logic.eq); [reflexivity |].
  intros ? ? ->; apply H.
Qed.

(* Further specialization for [RR := eq] *)
Lemma eutt_eq_bind' {E U R} (t1 t2: itree E U) (k1 k2: U -> itree E R):
  t1 ≈ t2 ->
  (forall u, (k1 u) ≈ (k2 u)) ->
  (ITree.bind t1 k1) ≈ (ITree.bind t2 k2).
Proof.
  intros -> Hk. now apply eutt_eq_bind.
Qed.

(* Exposing a version specialized to [eutt] so that users don't have to know about [eqit] *)
Lemma eutt_Ret :
  forall E (R1 R2 : Type) (RR : R1 -> R2 -> Prop) r1 r2, RR r1 r2 <-> eutt (E := E) RR (Ret r1) (Ret r2).
Proof.
  intros; apply eqit_Ret.
Qed.

(* [eutt] can be thought as the elementary block of a relational program logic.
   The following few lemmas give elementary logical rules to compose proofs.
 *)
Lemma eutt_conj {E} {R S} {RS RS'} :
  forall (t : itree E R) (s : itree E S),
    eutt RS  t s ->
    eutt RS' t s ->
    eutt (RS /2\ RS') t s.
Proof.
  repeat red.
  einit. ecofix CIH. intros * EQ EQ'.
  rewrite itree_eta, (itree_eta s).
  punfold EQ; punfold EQ'; red in EQ; red in EQ'.
  genobs t ot; genobs s os.
  hinduction EQ before CIHH; subst; intros; pclearbot; simpl.

  - estep; split; auto.
    inv EQ'; auto.
  - estep; ebase; right; eapply CIHL; eauto.
    rewrite <- tau_eutt.
    rewrite <- (tau_eutt m2); auto with itree.
  - assert (EE := eqitF_inv_VisF _ _ _ _ _ EQ'); pclearbot.
    eapply euttG_vis; ebase; left; apply CIHH; auto with itree.
  - eapply fold_eqitF in EQ'; eauto.
    assert (t ≈ Tau t1) by (rewrite itree_eta, <- Heqot; reflexivity).
    rewrite H in EQ'.
    apply eqit_inv_Tau_l in EQ'.
    subst; specialize (IHEQ _ _ eq_refl eq_refl).
    punfold EQ'; red in EQ'.
    specialize (IHEQ EQ').
    rewrite eqit_Tau_l; [|reflexivity].
    rewrite (itree_eta t1).
    eapply IHEQ.
  - subst; cbn.
    rewrite tau_euttge.
    rewrite (itree_eta t2); eapply IHEQ; eauto.
    eapply fold_eqitF in EQ'; eauto.
    assert (s ≈ Tau t2).
    rewrite (itree_eta s), <- Heqos; reflexivity.
    rewrite tau_eutt in H.
    assert (eutt RS' t t2).
    rewrite <- H; auto.
    punfold H0.
Qed.

Lemma eutt_disj_l {E} {R S} {RS RS'} :
  forall (t : itree E R) (s : itree E S),
    eutt RS t s ->
    eutt (RS \2/ RS') t s.
Proof.
  intros.
  eapply eqit_mon with (RR := RS); eauto.
Qed.

Lemma eutt_disj_r {E} {R S} {RS RS'} :
  forall (t : itree E R) (s : itree E S),
    eutt RS' t s ->
    eutt (RS \2/ RS') t s.
Proof.
  intros.
  eapply eqit_mon with (RR := RS'); eauto.
Qed.

Lemma eutt_equiv {E} {R S} {RS RS'} :
  forall (t : itree E R) (s : itree E S),
    (HeterogeneousRelations.eq_rel RS RS') ->
    eutt RS t s <-> eutt RS' t s.
Proof.
  intros * EQ; split; intros EUTT; eapply eqit_mon; try apply EUTT; eauto.
  all:apply EQ.
Qed.

(* Rewriting equivalent simulation relations under [eq_itree] and [eutt] *)
#[global]
Instance eq_itree_Proper_R {E : Type -> Type} {R1 R2:Type}
  : Proper ((@HeterogeneousRelations.eq_rel R1 R2) ==> Logic.eq ==> Logic.eq ==> iff) (@eq_itree E R1 R2).
Proof.
  repeat intro; subst.
  unfold eq_itree; rewrite H; reflexivity.
Qed.

#[global]
Instance eutt_Proper_R {E : Type -> Type} {R1 R2:Type}
  : Proper  ((@HeterogeneousRelations.eq_rel R1 R2) ==> eq ==> eq ==> iff) (@eutt E R1 R2).
Proof.
  repeat intro; subst.
  unfold eutt; rewrite H; reflexivity.
Qed.

(* Stronger subrelation result which applies for [eutt RR t t]. This is
   relevant for post-conditions *)
Lemma eutt_sub_self {E R} (R1 R2: R -> R -> Prop) (t: itree E R):
  (forall r, R1 r r -> R2 r r) ->
  eutt R1 t t ->
  eutt R2 t t.
Proof.
  intros Hrel; revert t. ginit. gcofix CIH; intros t Heutt.
  punfold Heutt; red in Heutt.
  remember t as t' in Heutt at 2. assert (Ht': t' ≈ t) by now subst. clear Heqt'.
  rewrite (itree_eta t). rewrite (itree_eta t), (itree_eta t') in Ht'.
  revert Ht'. induction Heutt; clear t; intros Heq.
  - apply eutt_inv_Ret in Heq; subst.
    gstep; constructor; auto.
  - apply eqit_inv_Tau in Heq.
    gstep; constructor. gfinal; left. eapply CIH.
    rewrite <- Heq at 2. now pclearbot.
  - gstep; constructor. intros v. eapply eqit_inv_Vis in Heq.
    gfinal; left. apply CIH. specialize (REL v).
    rewrite <- Heq at 2. now pclearbot.
  - rewrite tau_euttge, (itree_eta t1). apply IHHeutt.
    rewrite tau_euttge in Heq. rewrite <- itree_eta; auto.
  - apply IHHeutt. rewrite tau_euttge in Heq. rewrite <- itree_eta; auto.
Qed.


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

(** Abstract domain for neededness analysis *)

Require Import Coqlib.
Require Import Maps.
Require Import IntvSets.
Require Import AST.
Require Import Zbits.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
Require Import Events.
Require Import Lattice.
Require Import Registers.
Require Import ValueDomain.
Require Import Op.
Require Import RTL.

(** * Neededness for values *)

Inductive nval : Type :=
  | Nothing              (**r value is entirely unused *)
  | I (m: int)           (**r only need the bits that are 1 in [m] *)
  | All.                 (**r every bit of the value is used *)

Definition eq_nval (x y: nval) : {x=y} + {x<>y}.
Proof.
  decide equality. apply Int.eq_dec.
Defined.

(** ** Agreement between two values relative to a need. *)

Definition iagree (p q mask: int) : Prop :=
  forall i, 0 <= i < Int.zwordsize -> Int.testbit mask i = true ->
            Int.testbit p i = Int.testbit q i.

Fixpoint vagree (v w: val) (x: nval) {struct x}: Prop :=
  match x with
  | Nothing => True
  | I m =>
      match v, w with
      | Vint p, Vint q => iagree p q m
      | Vint p, _ => False
      | _, _ => True
      end
  | All => Val.lessdef v w
  end.

Lemma vagree_same: forall v x, vagree v v x.
Proof.
  intros. destruct x; simpl; auto; destruct v; auto. red; auto.
Qed.

Lemma vagree_lessdef: forall v w x, Val.lessdef v w -> vagree v w x.
Proof.
  intros. inv H. apply vagree_same. destruct x; simpl; auto.
Qed.

Lemma lessdef_vagree: forall v w, vagree v w All -> Val.lessdef v w.
Proof.
  intros. simpl in H. auto.
Qed.

Hint Resolve vagree_same vagree_lessdef lessdef_vagree: na.

Inductive vagree_list: list val -> list val -> list nval -> Prop :=
  | vagree_list_nil: forall nvl,
      vagree_list nil nil nvl
  | vagree_list_default: forall v1 vl1 v2 vl2,
      vagree v1 v2 All -> vagree_list vl1 vl2 nil ->
      vagree_list (v1 :: vl1) (v2 :: vl2) nil
  | vagree_list_cons: forall v1 vl1 v2 vl2 nv1 nvl,
      vagree v1 v2 nv1 -> vagree_list vl1 vl2 nvl ->
      vagree_list (v1 :: vl1) (v2 :: vl2) (nv1 :: nvl).

Lemma lessdef_vagree_list:
  forall vl1 vl2, vagree_list vl1 vl2 nil -> Val.lessdef_list vl1 vl2.
Proof.
  induction vl1; intros; inv H; constructor; auto with na.
Qed.

Lemma vagree_lessdef_list:
  forall vl1 vl2, Val.lessdef_list vl1 vl2 -> forall nvl, vagree_list vl1 vl2 nvl.
Proof.
  induction 1; intros.
  constructor.
  destruct nvl; constructor; auto with na.
Qed.

Hint Resolve lessdef_vagree_list vagree_lessdef_list: na.

(** ** Ordering and least upper bound between value needs *)

Inductive nge: nval -> nval -> Prop :=
  | nge_nothing: forall x, nge All x
  | nge_all: forall x, nge x Nothing
  | nge_int: forall m1 m2,
      (forall i, 0 <= i < Int.zwordsize -> Int.testbit m2 i = true -> Int.testbit m1 i = true) ->
      nge (I m1) (I m2).

Lemma nge_refl: forall x, nge x x.
Proof.
  destruct x; constructor; auto.
Qed.

Hint Constructors nge: na.
Hint Resolve nge_refl: na.

Lemma nge_trans: forall x y, nge x y -> forall z, nge y z -> nge x z.
Proof.
  induction 1; intros w VG; inv VG; eauto with na.
Qed.

Lemma nge_agree:
  forall v w x y, nge x y -> vagree v w x -> vagree v w y.
Proof.
  induction 1; simpl; auto.
- destruct v; auto with na.
- destruct v, w; intuition. red; auto.
Qed.

Definition nlub (x y: nval) : nval :=
  match x, y with
  | Nothing, _ => y
  | _, Nothing => x
  | I m1, I m2 => I (Int.or m1 m2)
  | _, _ => All
  end.

Lemma nge_lub_l:
  forall x y, nge (nlub x y) x.
Proof.
  unfold nlub; destruct x, y; auto with na.
  constructor. intros. autorewrite with ints; auto. rewrite H0; auto.
Qed.

Lemma nge_lub_r:
  forall x y, nge (nlub x y) y.
Proof.
  unfold nlub; destruct x, y; auto with na.
  constructor. intros. autorewrite with ints; auto. rewrite H0. apply orb_true_r; auto.
Qed.

(** ** Properties of agreement between integers *)

Lemma iagree_refl:
  forall p m, iagree p p m.
Proof.
  intros; red; auto.
Qed.

Remark eq_same_bits:
  forall i x y, x = y -> Int.testbit x i = Int.testbit y i.
Proof.
  intros; congruence.
Qed.

Lemma iagree_and_eq:
  forall x y mask,
  iagree x y mask <-> Int.and x mask = Int.and y mask.
Proof.
  intros; split; intros.
- Int.bit_solve. specialize (H i H0).
  destruct (Int.testbit mask i).
  rewrite ! andb_true_r; auto.
  rewrite ! andb_false_r; auto.
- red; intros. exploit (eq_same_bits i); eauto; autorewrite with ints; auto.
  rewrite H1. rewrite ! andb_true_r; auto.
Qed.

Lemma iagree_mone:
  forall p q, iagree p q Int.mone -> p = q.
Proof.
  intros. rewrite iagree_and_eq in H. rewrite ! Int.and_mone in H. auto.
Qed.

Lemma iagree_zero:
  forall p q, iagree p q Int.zero.
Proof.
  intros. rewrite iagree_and_eq. rewrite ! Int.and_zero; auto.
Qed.

Lemma iagree_and:
  forall x y n m,
  iagree x y (Int.and m n) -> iagree (Int.and x n) (Int.and y n) m.
Proof.
  intros. rewrite iagree_and_eq in *. rewrite ! Int.and_assoc.
  rewrite (Int.and_commut n). auto.
Qed.

Lemma iagree_not:
  forall x y m, iagree x y m -> iagree (Int.not x) (Int.not y) m.
Proof.
  intros; red; intros; autorewrite with ints; auto. f_equal; auto.
Qed.

Lemma iagree_not':
  forall x y m, iagree (Int.not x) (Int.not y) m -> iagree x y m.
Proof.
  intros. rewrite <- (Int.not_involutive x). rewrite <- (Int.not_involutive y).
  apply iagree_not; auto.
Qed.

Lemma iagree_or:
  forall x y n m,
  iagree x y (Int.and m (Int.not n)) -> iagree (Int.or x n) (Int.or y n) m.
Proof.
  intros. apply iagree_not'. rewrite ! Int.not_or_and_not. apply iagree_and.
  apply iagree_not; auto.
Qed.

Lemma iagree_bitwise_binop:
  forall sem f,
  (forall x y i, 0 <= i < Int.zwordsize ->
       Int.testbit (f x y) i = sem (Int.testbit x i) (Int.testbit y i)) ->
  forall x1 x2 y1 y2 m,
  iagree x1 y1 m -> iagree x2 y2 m -> iagree (f x1 x2) (f y1 y2) m.
Proof.
  intros; red; intros. rewrite ! H by auto. f_equal; auto.
Qed.

Lemma iagree_shl:
  forall x y m n,
  iagree x y (Int.shru m n) -> iagree (Int.shl x n) (Int.shl y n) m.
Proof.
  intros; red; intros. autorewrite with ints; auto.
  destruct (zlt i (Int.unsigned n)).
- auto.
- generalize (Int.unsigned_range n); intros.
  apply H. omega. rewrite Int.bits_shru by omega.
  replace (i - Int.unsigned n + Int.unsigned n) with i by omega.
  rewrite zlt_true by omega. auto.
Qed.

Lemma iagree_shru:
  forall x y m n,
  iagree x y (Int.shl m n) -> iagree (Int.shru x n) (Int.shru y n) m.
Proof.
  intros; red; intros. autorewrite with ints; auto.
  destruct (zlt (i + Int.unsigned n) Int.zwordsize).
- generalize (Int.unsigned_range n); intros.
  apply H. omega. rewrite Int.bits_shl by omega.
  replace (i + Int.unsigned n - Int.unsigned n) with i by omega.
  rewrite zlt_false by omega. auto.
- auto.
Qed.

Lemma iagree_shr_1:
  forall x y m n,
  Int.shru (Int.shl m n) n = m ->
  iagree x y (Int.shl m n) -> iagree (Int.shr x n) (Int.shr y n) m.
Proof.
  intros; red; intros. rewrite <- H in H2. rewrite Int.bits_shru in H2 by auto.
  rewrite ! Int.bits_shr by auto.
  destruct (zlt (i + Int.unsigned n) Int.zwordsize).
- apply H0; auto. generalize (Int.unsigned_range n); omega.
- discriminate.
Qed.

Lemma iagree_shr:
  forall x y m n,
  iagree x y (Int.or (Int.shl m n) (Int.repr Int.min_signed)) ->
  iagree (Int.shr x n) (Int.shr y n) m.
Proof.
  intros; red; intros. rewrite ! Int.bits_shr by auto.
  generalize (Int.unsigned_range n); intros.
  set (j := if zlt (i + Int.unsigned n) Int.zwordsize
            then i + Int.unsigned n
            else Int.zwordsize - 1).
  assert (0 <= j < Int.zwordsize).
  { unfold j; destruct (zlt (i + Int.unsigned n) Int.zwordsize); omega. }
  apply H; auto. autorewrite with ints; auto. apply orb_true_intro.
  unfold j; destruct (zlt (i + Int.unsigned n) Int.zwordsize).
- left. rewrite zlt_false by omega.
  replace (i + Int.unsigned n - Int.unsigned n) with i by omega.
  auto.
- right. reflexivity.
Qed.

Lemma iagree_rol:
  forall p q m amount,
  iagree p q (Int.ror m amount) ->
  iagree (Int.rol p amount) (Int.rol q amount) m.
Proof.
  intros. assert (Int.zwordsize > 0) by (compute; auto).
  red; intros. rewrite ! Int.bits_rol by auto. apply H.
  apply Z_mod_lt; auto.
  rewrite Int.bits_ror.
  replace (((i - Int.unsigned amount) mod Int.zwordsize + Int.unsigned amount)
   mod Int.zwordsize) with i. auto.
  apply eqmod_small_eq with Int.zwordsize; auto.
  apply eqmod_trans with ((i - Int.unsigned amount) + Int.unsigned amount).
  apply eqmod_refl2; omega.
  eapply eqmod_trans. 2: apply eqmod_mod; auto.
  apply eqmod_add.
  apply eqmod_mod; auto.
  apply eqmod_refl.
  apply Z_mod_lt; auto.
  apply Z_mod_lt; auto.
Qed.

Lemma iagree_ror:
  forall p q m amount,
  iagree p q (Int.rol m amount) ->
  iagree (Int.ror p amount) (Int.ror q amount) m.
Proof.
  intros. rewrite ! Int.ror_rol_neg by apply int_wordsize_divides_modulus.
  apply iagree_rol.
  rewrite Int.ror_rol_neg by apply int_wordsize_divides_modulus.
  rewrite Int.neg_involutive; auto.
Qed.

Lemma eqmod_iagree:
  forall m x y,
  eqmod (two_p (Int.size m)) x y ->
  iagree (Int.repr x) (Int.repr y) m.
Proof.
  intros. set (p := Z.to_nat (Int.size m)).
  generalize (Int.size_range m); intros RANGE.
  assert (EQ: Int.size m = Z.of_nat p). { symmetry; apply Z2Nat.id. omega. }
  rewrite EQ in H; rewrite <- two_power_nat_two_p in H.
  red; intros. rewrite ! Int.testbit_repr by auto.
  destruct (zlt i (Int.size m)).
  eapply same_bits_eqmod; eauto. omega.
  assert (Int.testbit m i = false) by (eapply Int.bits_size_2; omega).
  congruence.
Qed.

Definition complete_mask (m: int) := Int.zero_ext (Int.size m) Int.mone.

Lemma iagree_eqmod:
  forall x y m,
  iagree x y (complete_mask m) ->
  eqmod (two_p (Int.size m)) (Int.unsigned x) (Int.unsigned y).
Proof.
  intros. set (p := Z.to_nat (Int.size m)).
  generalize (Int.size_range m); intros RANGE.
  assert (EQ: Int.size m = Z.of_nat p). { symmetry; apply Z2Nat.id. omega. }
  rewrite EQ; rewrite <- two_power_nat_two_p.
  apply eqmod_same_bits. intros. apply H. omega.
  unfold complete_mask. rewrite Int.bits_zero_ext by omega.
  rewrite zlt_true by omega. rewrite Int.bits_mone by omega. auto.
Qed.

Lemma complete_mask_idem:
  forall m, complete_mask (complete_mask m) = complete_mask m.
Proof.
  unfold complete_mask; intros. destruct (Int.eq_dec m Int.zero).
+ subst m; reflexivity.
+ assert (Int.unsigned m <> 0).
  { red; intros; elim n. rewrite <- (Int.repr_unsigned m). rewrite H; auto. }
  assert (0 < Int.size m).
  { apply Zsize_pos'. generalize (Int.unsigned_range m); omega. }
  generalize (Int.size_range m); intros.
  f_equal. apply Int.bits_size_4. tauto.
  rewrite Int.bits_zero_ext by omega. rewrite zlt_true by omega.
  apply Int.bits_mone; omega.
  intros. rewrite Int.bits_zero_ext by omega. apply zlt_false; omega.
Qed.

(** ** Abstract operations over value needs. *)

Ltac InvAgree :=
  simpl vagree in *;
  repeat (
  auto || exact Logic.I ||
  match goal with
  | [ H: False |- _ ] => contradiction
  | [ H: match ?v with Vundef => _ | Vint _ => _ | Vlong _ => _ | Vfloat _ => _ | Vsingle _ => _ | Vptr _ _ => _ end |- _ ] => destruct v
  | [ |- context [if Archi.ptr64 then _ else _] ] => destruct Archi.ptr64 eqn:?
  end).

(** And immediate, or immediate *)

Definition andimm (x: nval) (n: int) :=
  match x with
  | Nothing => Nothing
  | I m => I (Int.and m n)
  | All => I n
  end.

Lemma andimm_sound:
  forall v w x n,
  vagree v w (andimm x n) ->
  vagree (Val.and v (Vint n)) (Val.and w (Vint n)) x.
Proof.
  unfold andimm; intros; destruct x; simpl in *; unfold Val.and.
- auto.
- InvAgree. apply iagree_and; auto.
- InvAgree. rewrite iagree_and_eq in H. rewrite H; auto.
Qed.

Definition orimm (x: nval) (n: int) :=
  match x with
  | Nothing => Nothing
  | I m => I (Int.and m (Int.not n))
  | _ => I (Int.not n)
  end.

Lemma orimm_sound:
  forall v w x n,
  vagree v w (orimm x n) ->
  vagree (Val.or v (Vint n)) (Val.or w (Vint n)) x.
Proof.
  unfold orimm; intros; destruct x; simpl in *.
- auto.
- unfold Val.or; InvAgree. apply iagree_or; auto.
- InvAgree. simpl. apply Val.lessdef_same. f_equal. apply iagree_mone.
  apply iagree_or. rewrite Int.and_commut. rewrite Int.and_mone. auto.
Qed.

(** Bitwise operations: and, or, xor, not *)

Definition bitwise (x: nval) := x.

Remark bitwise_idem: forall nv, bitwise (bitwise nv) = bitwise nv.
Proof. auto. Qed.

Lemma vagree_bitwise_binop:
  forall f,
  (forall p1 p2 q1 q2 m,
     iagree p1 q1 m -> iagree p2 q2 m -> iagree (f p1 p2) (f q1 q2) m) ->
  forall v1 w1 v2 w2 x,
  vagree v1 w1 (bitwise x) -> vagree v2 w2 (bitwise x) ->
  vagree (match v1, v2 with Vint i1, Vint i2 => Vint(f i1 i2) | _, _ => Vundef end)
         (match w1, w2 with Vint i1, Vint i2 => Vint(f i1 i2) | _, _ => Vundef end)
         x.
Proof.
  unfold bitwise; intros. destruct x; simpl in *.
- auto.
- InvAgree.
- inv H0; auto. inv H1; auto. destruct w1; auto.
Qed.

Lemma and_sound:
  forall v1 w1 v2 w2 x,
  vagree v1 w1 (bitwise x) -> vagree v2 w2 (bitwise x) ->
  vagree (Val.and v1 v2) (Val.and w1 w2) x.
Proof (vagree_bitwise_binop Int.and (iagree_bitwise_binop andb Int.and Int.bits_and)).

Lemma or_sound:
  forall v1 w1 v2 w2 x,
  vagree v1 w1 (bitwise x) -> vagree v2 w2 (bitwise x) ->
  vagree (Val.or v1 v2) (Val.or w1 w2) x.
Proof (vagree_bitwise_binop Int.or (iagree_bitwise_binop orb Int.or Int.bits_or)).

Lemma xor_sound:
  forall v1 w1 v2 w2 x,
  vagree v1 w1 (bitwise x) -> vagree v2 w2 (bitwise x) ->
  vagree (Val.xor v1 v2) (Val.xor w1 w2) x.
Proof (vagree_bitwise_binop Int.xor (iagree_bitwise_binop xorb Int.xor Int.bits_xor)).

Lemma notint_sound:
  forall v w x,
  vagree v w (bitwise x) -> vagree (Val.notint v) (Val.notint w) x.
Proof.
  intros. rewrite ! Val.not_xor. apply xor_sound; auto with na.
Qed.

(** Shifts and rotates *)

Definition shlimm (x: nval) (n: int) :=
  match x with
  | Nothing => Nothing
  | I m => I (Int.shru m n)
  | All => I (Int.shru Int.mone n)
  end.

Lemma shlimm_sound:
  forall v w x n,
  vagree v w (shlimm x n) ->
  vagree (Val.shl v (Vint n)) (Val.shl w (Vint n)) x.
Proof.
  unfold shlimm; intros. unfold Val.shl.
  destruct (Int.ltu n Int.iwordsize).
  destruct x; simpl in *.
- auto.
- InvAgree. apply iagree_shl; auto.
- InvAgree. apply Val.lessdef_same. f_equal. apply iagree_mone. apply iagree_shl; auto.
- destruct v; auto with na.
Qed.

Definition shruimm (x: nval) (n: int) :=
  match x with
  | Nothing => Nothing
  | I m => I (Int.shl m n)
  | All => I (Int.shl Int.mone n)
  end.

Lemma shruimm_sound:
  forall v w x n,
  vagree v w (shruimm x n) ->
  vagree (Val.shru v (Vint n)) (Val.shru w (Vint n)) x.
Proof.
  unfold shruimm; intros. unfold Val.shru.
  destruct (Int.ltu n Int.iwordsize).
  destruct x; simpl in *.
- auto.
- InvAgree. apply iagree_shru; auto.
- InvAgree. apply Val.lessdef_same. f_equal. apply iagree_mone. apply iagree_shru; auto.
- destruct v; auto with na.
Qed.

Definition shrimm (x: nval) (n: int) :=
  match x with
  | Nothing => Nothing
  | I m => I (let m' := Int.shl m n in
              if Int.eq_dec (Int.shru m' n) m
              then m'
              else Int.or m' (Int.repr Int.min_signed))
  | All => I (Int.or (Int.shl Int.mone n) (Int.repr Int.min_signed))
  end.

Lemma shrimm_sound:
  forall v w x n,
  vagree v w (shrimm x n) ->
  vagree (Val.shr v (Vint n)) (Val.shr w (Vint n)) x.
Proof.
  unfold shrimm; intros. unfold Val.shr.
  destruct (Int.ltu n Int.iwordsize).
  destruct x; simpl in *.
- auto.
- InvAgree.
  destruct (Int.eq_dec (Int.shru (Int.shl m n) n) m).
  apply iagree_shr_1; auto.
  apply iagree_shr; auto.
- InvAgree. apply Val.lessdef_same. f_equal. apply iagree_mone. apply iagree_shr. auto.
- destruct v; auto with na.
Qed.

Definition rol (x: nval) (amount: int) :=
  match x with
  | Nothing => Nothing
  | I m => I (Int.ror m amount)
  | All => All
  end.

Lemma rol_sound:
  forall v w x n,
  vagree v w (rol x n) ->
  vagree (Val.rol v (Vint n)) (Val.rol w (Vint n)) x.
Proof.
  unfold rol, Val.rol; intros.
  destruct x; simpl in *.
- auto.
- InvAgree. apply iagree_rol; auto.
- inv H; auto.
Qed.

Definition ror (x: nval) (amount: int) :=
  match x with
  | Nothing => Nothing
  | I m => I (Int.rol m amount)
  | All => All
  end.

Lemma ror_sound:
  forall v w x n,
  vagree v w (ror x n) ->
  vagree (Val.ror v (Vint n)) (Val.ror w (Vint n)) x.
Proof.
  unfold ror, Val.ror; intros.
  destruct x; simpl in *.
- auto.
- InvAgree. apply iagree_ror; auto.
- inv H; auto.
Qed.

Definition rolm (x: nval) (amount mask: int) := rol (andimm x mask) amount.

Lemma rolm_sound:
  forall v w x amount mask,
  vagree v w (rolm x amount mask) ->
  vagree (Val.rolm v amount mask) (Val.rolm w amount mask) x.
Proof.
  unfold rolm; intros.
  assert (X: forall u, Val.rolm u amount mask = Val.and (Val.rol u (Vint amount)) (Vint mask)).
  { destruct u; auto. }
  rewrite ! X.
  apply andimm_sound. apply rol_sound. auto.
Qed.

(** Modular arithmetic operations: add, mul, opposite.
    (But not subtraction because of the pointer - pointer case. *)

Definition modarith (x: nval) :=
  match x with
  | Nothing => Nothing
  | I m => I (complete_mask m)
  | All => All
  end.

Lemma add_sound:
  forall v1 w1 v2 w2 x,
  vagree v1 w1 (modarith x) -> vagree v2 w2 (modarith x) ->
  vagree (Val.add v1 v2) (Val.add w1 w2) x.
Proof.
  unfold modarith; intros. destruct x; simpl in *.
- auto.
- unfold Val.add; InvAgree.
  apply eqmod_iagree. apply eqmod_add; apply iagree_eqmod; auto.
- inv H; auto. inv H0; auto. destruct w1; auto.
Qed.

Remark modarith_idem: forall nv, modarith (modarith nv) = modarith nv.
Proof.
  destruct nv; simpl; auto. f_equal; apply complete_mask_idem.
Qed.

Lemma mul_sound:
  forall v1 w1 v2 w2 x,
  vagree v1 w1 (modarith x) -> vagree v2 w2 (modarith x) ->
  vagree (Val.mul v1 v2) (Val.mul w1 w2) x.
Proof.
  unfold mul, add; intros. destruct x; simpl in *.
- auto.
- unfold Val.mul; InvAgree. apply eqmod_iagree. apply eqmod_mult; apply iagree_eqmod; auto.
- inv H; auto. inv H0; auto. destruct w1; auto.
Qed.

Lemma neg_sound:
  forall v w x,
  vagree v w (modarith x) ->
  vagree (Val.neg v) (Val.neg w) x.
Proof.
  intros; destruct x; simpl in *.
- auto.
- unfold Val.neg; InvAgree.
  apply eqmod_iagree. apply eqmod_neg. apply iagree_eqmod; auto.
- inv H; simpl; auto.
Qed.

(** Conversions: zero extension, sign extension, single-of-float *)

Definition zero_ext (n: Z) (x: nval) :=
  match x with
  | Nothing => Nothing
  | I m => I (Int.zero_ext n m)
  | All => I (Int.zero_ext n Int.mone)
  end.

Lemma zero_ext_sound:
  forall v w x n,
  vagree v w (zero_ext n x) ->
  0 <= n ->
  vagree (Val.zero_ext n v) (Val.zero_ext n w) x.
Proof.
  unfold zero_ext; intros.
  destruct x; simpl in *.
- auto.
- unfold Val.zero_ext; InvAgree.
  red; intros. autorewrite with ints; try omega.
  destruct (zlt i1 n); auto. apply H; auto.
  autorewrite with ints; try omega. rewrite zlt_true; auto.
- unfold Val.zero_ext; InvAgree; auto. apply Val.lessdef_same. f_equal.
  Int.bit_solve; try omega. destruct (zlt i1 n); auto. apply H; auto.
  autorewrite with ints; try omega. apply zlt_true; auto.
Qed.

Definition sign_ext (n: Z) (x: nval) :=
  match x with
  | Nothing => Nothing
  | I m => I (Int.or (Int.zero_ext n m) (Int.shl Int.one (Int.repr (n - 1))))
  | All => I (Int.zero_ext n Int.mone)
  end.

Lemma sign_ext_sound:
  forall v w x n,
  vagree v w (sign_ext n x) ->
  0 < n < Int.zwordsize ->
  vagree (Val.sign_ext n v) (Val.sign_ext n w) x.
Proof.
  unfold sign_ext; intros. destruct x; simpl in *.
- auto.
- unfold Val.sign_ext; InvAgree.
  red; intros. autorewrite with ints; try omega.
  set (j := if zlt i1 n then i1 else n - 1).
  assert (0 <= j < Int.zwordsize).
  { unfold j; destruct (zlt i1 n); omega. }
  apply H; auto.
  autorewrite with ints; try omega. apply orb_true_intro.
  unfold j; destruct (zlt i1 n).
  left. rewrite zlt_true; auto.
  right. rewrite Int.unsigned_repr. rewrite zlt_false by omega.
  replace (n - 1 - (n - 1)) with 0 by omega. reflexivity.
  generalize Int.wordsize_max_unsigned; omega.
- unfold Val.sign_ext; InvAgree; auto. apply Val.lessdef_same. f_equal.
  Int.bit_solve; try omega.
  set (j := if zlt i1 n then i1 else n - 1).
  assert (0 <= j < Int.zwordsize).
  { unfold j; destruct (zlt i1 n); omega. }
  apply H; auto. rewrite Int.bits_zero_ext; try omega.
  rewrite zlt_true. apply Int.bits_mone; auto.
  unfold j. destruct (zlt i1 n); omega.
Qed.

(** The needs of a memory store concerning the value being stored. *)

Definition store_argument (chunk: memory_chunk) :=
  match chunk with
  | Mint8signed | Mint8unsigned => I (Int.repr 255)
  | Mint16signed | Mint16unsigned => I (Int.repr 65535)
  | _ => All
  end.

Lemma store_argument_sound:
  forall chunk v w,
  vagree v w (store_argument chunk) ->
  list_forall2 memval_lessdef (encode_val chunk v) (encode_val chunk w).
Proof.
  intros.
  assert (UNDEF: list_forall2 memval_lessdef
                     (list_repeat (size_chunk_nat chunk) Undef)
                     (encode_val chunk w)).
  {
     rewrite <- (encode_val_length chunk w).
     apply repeat_Undef_inject_any.
  }
  assert (SAME: forall vl1 vl2,
                vl1 = vl2 ->
                list_forall2 memval_lessdef vl1 vl2).
  {
     intros. subst vl2. revert vl1. induction vl1; constructor; auto.
     apply memval_lessdef_refl.
  }

  intros. unfold store_argument in H; destruct chunk.
- InvAgree. apply SAME. simpl; f_equal. apply encode_int_8_mod.
  change 8 with (Int.size (Int.repr 255)). apply iagree_eqmod; auto.
- InvAgree. apply SAME. simpl; f_equal. apply encode_int_8_mod.
  change 8 with (Int.size (Int.repr 255)). apply iagree_eqmod; auto.
- InvAgree. apply SAME. simpl; f_equal. apply encode_int_16_mod.
  change 16 with (Int.size (Int.repr 65535)). apply iagree_eqmod; auto.
- InvAgree. apply SAME. simpl; f_equal. apply encode_int_16_mod.
  change 16 with (Int.size (Int.repr 65535)). apply iagree_eqmod; auto.
- apply encode_val_inject. rewrite val_inject_id; auto.
- apply encode_val_inject. rewrite val_inject_id; auto.
- apply encode_val_inject. rewrite val_inject_id; auto.
- apply encode_val_inject. rewrite val_inject_id; auto.
- apply encode_val_inject. rewrite val_inject_id; auto.
- apply encode_val_inject. rewrite val_inject_id; auto.
Qed.

Lemma store_argument_load_result:
  forall chunk v w,
  vagree v w (store_argument chunk) ->
  Val.lessdef (Val.load_result chunk v) (Val.load_result chunk w).
Proof.
  unfold store_argument; intros; destruct chunk;
  auto using Val.load_result_lessdef; InvAgree; simpl.
- apply sign_ext_sound with (v := Vint i) (w := Vint i0) (x := All) (n := 8).
  auto. compute; auto.
- apply zero_ext_sound with (v := Vint i) (w := Vint i0) (x := All) (n := 8).
  auto. omega.
- apply sign_ext_sound with (v := Vint i) (w := Vint i0) (x := All) (n := 16).
  auto. compute; auto.
- apply zero_ext_sound with (v := Vint i) (w := Vint i0) (x := All) (n := 16).
  auto. omega.
Qed.

(** The needs of a comparison *)

Definition maskzero (n: int) := I n.

Lemma maskzero_sound:
  forall v w n b,
  vagree v w (maskzero n) ->
  Val.maskzero_bool v n = Some b ->
  Val.maskzero_bool w n = Some b.
Proof.
  unfold maskzero; intros.
  unfold Val.maskzero_bool; InvAgree; try discriminate.
  inv H0. rewrite iagree_and_eq in H. rewrite H. auto.
Qed.

(** The needs of a select *)

Lemma normalize_sound:
  forall v w x ty,
  vagree v w x ->
  vagree (Val.normalize v ty) (Val.normalize w ty) x.
Proof.
  intros. destruct x; simpl in *.
- auto.
- unfold Val.normalize. destruct v.
  auto.
  destruct w; try contradiction. destruct ty; auto.
  destruct ty; auto.
  destruct ty; auto.
  destruct ty; auto.
  destruct ty; destruct Archi.ptr64; auto.
- apply Val.normalize_lessdef; auto.
Qed.

Lemma select_sound:
  forall ob v1 v2 w1 w2 ty x,
  vagree v1 w1 x -> vagree v2 w2 x ->
  vagree (Val.select ob v1 v2 ty) (Val.select ob w1 w2 ty) x.
Proof.
  unfold Val.select; intros. destruct ob as [b|]; auto with na.
  apply normalize_sound. destruct b; auto.
Qed.

(** The default abstraction: if the result is unused, the arguments are
  unused; otherwise, the arguments are needed in full. *)

Definition default (x: nval) :=
  match x with
  | Nothing => Nothing
  | _ => All
  end.

Section DEFAULT.

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

Let valid_pointer_inj:
  forall b1 ofs b2 delta,
  inject_id b1 = Some(b2, delta) ->
  Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true ->
  Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true.
Proof.
  unfold inject_id; intros. inv H. rewrite Ptrofs.add_zero.
  rewrite Mem.valid_pointer_nonempty_perm in *. eauto.
Qed.

Let weak_valid_pointer_inj:
  forall b1 ofs b2 delta,
  inject_id b1 = Some(b2, delta) ->
  Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true ->
  Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true.
Proof.
  unfold inject_id; intros. inv H. rewrite Ptrofs.add_zero.
  rewrite Mem.weak_valid_pointer_spec in *.
  rewrite ! Mem.valid_pointer_nonempty_perm in *.
  destruct H0; [left|right]; eauto.
Qed.

Let weak_valid_pointer_no_overflow:
  forall b1 ofs b2 delta,
  inject_id b1 = Some(b2, delta) ->
  Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true ->
  0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned.
Proof.
  unfold inject_id; intros. inv H. rewrite Z.add_0_r. apply Ptrofs.unsigned_range_2.
Qed.

Let valid_different_pointers_inj:
  forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2,
  b1 <> b2 ->
  Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true ->
  Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true ->
  inject_id b1 = Some (b1', delta1) ->
  inject_id b2 = Some (b2', delta2) ->
  b1' <> b2' \/
  Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)).
Proof.
  unfold inject_id; intros. left; congruence.
Qed.

Lemma default_needs_of_condition_sound:
  forall cond args1 b args2,
  eval_condition cond args1 m1 = Some b ->
  vagree_list args1 args2 nil ->
  eval_condition cond args2 m2 = Some b.
Proof.
  intros. apply eval_condition_inj with (f := inject_id) (m1 := m1) (vl1 := args1); auto.
  apply val_inject_list_lessdef. apply lessdef_vagree_list. auto.
Qed.

Lemma default_needs_of_operation_sound:
  forall op args1 v1 args2 nv,
  eval_operation ge (Vptr sp Ptrofs.zero) op args1 m1 = Some v1 ->
  vagree_list args1 args2 nil
  \/ vagree_list args1 args2 (default nv :: nil)
  \/ vagree_list args1 args2 (default nv :: default nv :: nil) ->
  nv <> Nothing ->
  exists v2,
     eval_operation ge (Vptr sp Ptrofs.zero) op args2 m2 = Some v2
  /\ vagree v1 v2 nv.
Proof.
  intros. assert (default nv = All) by (destruct nv; simpl; congruence).
  rewrite H2 in H0.
  assert (Val.lessdef_list args1 args2).
  {
    destruct H0. auto with na.
    destruct H0. inv H0; constructor; auto with na.
    inv H0; constructor; auto with na. inv H8; constructor; auto with na.
  }
  exploit (@eval_operation_inj _ _ _ _ ge ge inject_id).
  eassumption. auto. auto. auto.
  instantiate (1 := op). intros. apply val_inject_lessdef; auto.
  apply val_inject_lessdef. instantiate (1 := Vptr sp Ptrofs.zero). instantiate (1 := Vptr sp Ptrofs.zero). auto.
  apply val_inject_list_lessdef; eauto.
  eauto.
  intros (v2 & A & B). exists v2; split; auto.
  apply vagree_lessdef. apply val_inject_lessdef. auto.
Qed.

End DEFAULT.

(** ** Detecting operations that are redundant and can be turned into a move *)

Definition andimm_redundant (x: nval) (n: int) :=
  match x with
  | Nothing => true
  | I m => Int.eq_dec (Int.and m (Int.not n)) Int.zero
  | _ => false
  end.

Lemma andimm_redundant_sound:
  forall v w x n,
  andimm_redundant x n = true ->
  vagree v w (andimm x n) ->
  vagree (Val.and v (Vint n)) w x.
Proof.
  unfold andimm_redundant; intros. destruct x; try discriminate.
- simpl; auto.
- InvBooleans. simpl in *; unfold Val.and; InvAgree.
  red; intros. exploit (eq_same_bits i1); eauto.
  autorewrite with ints; auto. rewrite H2; simpl; intros.
  destruct (Int.testbit n i1) eqn:N; try discriminate.
  rewrite andb_true_r. apply H0; auto. autorewrite with ints; auto.
  rewrite H2, N; auto.
Qed.

Definition orimm_redundant (x: nval) (n: int) :=
  match x with
  | Nothing => true
  | I m => Int.eq_dec (Int.and m n) Int.zero
  | _ => false
  end.

Lemma orimm_redundant_sound:
  forall v w x n,
  orimm_redundant x n = true ->
  vagree v w (orimm x n) ->
  vagree (Val.or v (Vint n)) w x.
Proof.
  unfold orimm_redundant; intros. destruct x; try discriminate.
- auto.
- InvBooleans. simpl in *; unfold Val.or; InvAgree.
  apply iagree_not'. rewrite Int.not_or_and_not.
  apply (andimm_redundant_sound (Vint (Int.not i)) (Vint (Int.not i0)) (I m) (Int.not n)).
  simpl. rewrite Int.not_involutive. apply proj_sumbool_is_true. auto.
  simpl. apply iagree_not; auto.
Qed.

Definition rolm_redundant (x: nval) (amount mask: int) :=
  Int.eq_dec amount Int.zero && andimm_redundant x mask.

Lemma rolm_redundant_sound:
  forall v w x amount mask,
  rolm_redundant x amount mask = true ->
  vagree v w (rolm x amount mask) ->
  vagree (Val.rolm v amount mask) w x.
Proof.
  unfold rolm_redundant; intros; InvBooleans. subst amount. rewrite Val.rolm_zero.
  apply andimm_redundant_sound; auto.
  assert (forall n, Int.ror n Int.zero = n).
  { intros. rewrite Int.ror_rol_neg by apply int_wordsize_divides_modulus.
    rewrite Int.neg_zero. apply Int.rol_zero. }
  unfold rolm, rol, andimm in *. destruct x; auto.
  rewrite H in H0. auto.
  rewrite H in H0. auto.
Qed.

Definition zero_ext_redundant (n: Z) (x: nval) :=
  match x with
  | Nothing => true
  | I m => Int.eq_dec (Int.zero_ext n m) m
  | _ => false
  end.

Lemma zero_ext_redundant_sound:
  forall v w x n,
  zero_ext_redundant n x = true ->
  vagree v w (zero_ext n x) ->
  0 <= n ->
  vagree (Val.zero_ext n v) w x.
Proof.
  unfold zero_ext_redundant; intros. destruct x; try discriminate.
- auto.
- simpl in *; InvAgree. simpl. InvBooleans. rewrite <- H.
  red; intros; autorewrite with ints; try omega.
  destruct (zlt i1 n). apply H0; auto.
  rewrite Int.bits_zero_ext in H3 by omega. rewrite zlt_false in H3 by auto. discriminate.
Qed.

Definition sign_ext_redundant (n: Z) (x: nval) :=
  match x with
  | Nothing => true
  | I m => Int.eq_dec (Int.zero_ext n m) m
  | _ => false
  end.

Lemma sign_ext_redundant_sound:
  forall v w x n,
  sign_ext_redundant n x = true ->
  vagree v w (sign_ext n x) ->
  0 < n ->
  vagree (Val.sign_ext n v) w x.
Proof.
  unfold sign_ext_redundant; intros. destruct x; try discriminate.
- auto.
- simpl in *; InvAgree. simpl. InvBooleans. rewrite <- H.
  red; intros; autorewrite with ints; try omega.
  destruct (zlt i1 n). apply H0; auto.
  rewrite Int.bits_or; auto. rewrite H3; auto.
  rewrite Int.bits_zero_ext in H3 by omega. rewrite zlt_false in H3 by auto. discriminate.
Qed.

(** * Neededness for register environments *)

Module NVal <: SEMILATTICE.

  Definition t := nval.
  Definition eq (x y: t) := (x = y).
  Definition eq_refl: forall x, eq x x := (@eq_refl t).
  Definition eq_sym: forall x y, eq x y -> eq y x := (@eq_sym t).
  Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z := (@eq_trans t).
  Definition beq (x y: t) : bool := proj_sumbool (eq_nval x y).
  Lemma beq_correct: forall x y, beq x y = true -> eq x y.
  Proof. unfold beq; intros. InvBooleans. auto. Qed.
  Definition ge := nge.
  Lemma ge_refl: forall x y, eq x y -> ge x y.
  Proof. unfold eq, ge; intros. subst y. apply nge_refl. Qed.
  Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
  Proof. unfold ge; intros. eapply nge_trans; eauto. Qed.
  Definition bot : t := Nothing.
  Lemma ge_bot: forall x, ge x bot.
  Proof. intros. constructor. Qed.
  Definition lub := nlub.
  Lemma ge_lub_left: forall x y, ge (lub x y) x.
  Proof nge_lub_l.
  Lemma ge_lub_right: forall x y, ge (lub x y) y.
  Proof nge_lub_r.
End NVal.

Module NE := LPMap1(NVal).

Definition nenv := NE.t.

Definition nreg (ne: nenv) (r: reg) := NE.get r ne.

Definition eagree (e1 e2: regset) (ne: nenv) : Prop :=
  forall r, vagree e1#r e2#r (NE.get r ne).

Lemma nreg_agree:
  forall rs1 rs2 ne r, eagree rs1 rs2 ne -> vagree rs1#r rs2#r (nreg ne r).
Proof.
  intros. apply H.
Qed.

Hint Resolve nreg_agree: na.

Lemma eagree_ge:
  forall e1 e2 ne ne',
  eagree e1 e2 ne -> NE.ge ne ne' -> eagree e1 e2 ne'.
Proof.
  intros; red; intros. apply nge_agree with (NE.get r ne); auto. apply H0.
Qed.

Lemma eagree_bot:
  forall e1 e2, eagree e1 e2 NE.bot.
Proof.
  intros; red; intros. rewrite NE.get_bot. exact Logic.I.
Qed.

Lemma eagree_same:
  forall e ne, eagree e e ne.
Proof.
  intros; red; intros. apply vagree_same.
Qed.

Lemma eagree_update_1:
  forall e1 e2 ne v1 v2 nv r,
  eagree e1 e2 ne -> vagree v1 v2 nv -> eagree (e1#r <- v1) (e2#r <- v2) (NE.set r nv ne).
Proof.
  intros; red; intros. rewrite NE.gsspec. rewrite ! PMap.gsspec.
  destruct (peq r0 r); auto.
Qed.

Lemma eagree_update:
  forall e1 e2 ne v1 v2 r,
  vagree v1 v2 (nreg ne r) ->
  eagree e1 e2 (NE.set r Nothing ne) ->
  eagree (e1#r <- v1) (e2#r <- v2) ne.
Proof.
  intros; red; intros. specialize (H0 r0). rewrite NE.gsspec in H0.
  rewrite ! PMap.gsspec. destruct (peq r0 r).
  subst r0. auto.
  auto.
Qed.

Lemma eagree_update_dead:
  forall e1 e2 ne v1 r,
  nreg ne r = Nothing ->
  eagree e1 e2 ne -> eagree (e1#r <- v1) e2 ne.
Proof.
  intros; red; intros. rewrite PMap.gsspec.
  destruct (peq r0 r); auto. subst. unfold nreg in H. rewrite H. red; auto.
Qed.

(** * Neededness for memory locations *)

Inductive nmem : Type :=
  | NMemDead
  | NMem (stk: ISet.t) (gl: PTree.t ISet.t).

(** Interpretation of [nmem]:
- [NMemDead]: all memory locations are unused (dead).  Acts as bottom.
- [NMem stk gl]: all memory locations are used, except:
  - the stack locations whose offset is in the interval [stk]
  - the global locations whose offset is in the corresponding entry of [gl].
*)

Section LOCATIONS.

Variable ge: genv.
Variable sp: block.

Inductive nlive: nmem -> block -> Z -> Prop :=
  | nlive_intro: forall stk gl b ofs
      (STK: b = sp -> ~ISet.In ofs stk)
      (GL: forall id iv,
           Genv.find_symbol ge id = Some b ->
           gl!id = Some iv ->
           ~ISet.In ofs iv),
      nlive (NMem stk gl) b ofs.

(** All locations are live *)

Definition nmem_all := NMem ISet.empty (PTree.empty _).

Lemma nlive_all: forall b ofs, nlive nmem_all b ofs.
Proof.
  intros; constructor; intros.
  apply ISet.In_empty.
  rewrite PTree.gempty in H0; discriminate.
Qed.

(** Add a range of live locations to [nm].  The range starts at
  the abstract pointer [p] and has length [sz]. *)

Definition nmem_add (nm: nmem) (p: aptr) (sz: Z) : nmem :=
  match nm with
  | NMemDead => nmem_all       (**r very conservative, should never happen *)
  | NMem stk gl =>
      match p with
      | Gl id ofs =>
          match gl!id with
          | Some iv => NMem stk (PTree.set id (ISet.remove (Ptrofs.unsigned ofs) (Ptrofs.unsigned ofs + sz) iv) gl)
          | None => nm
          end
      | Glo id =>
          NMem stk (PTree.remove id gl)
      | Stk ofs =>
          NMem (ISet.remove (Ptrofs.unsigned ofs) (Ptrofs.unsigned ofs + sz) stk) gl
      | Stack =>
          NMem ISet.empty gl
      | _ => nmem_all
      end
  end.

Lemma nlive_add:
  forall bc b ofs p nm sz i,
  genv_match bc ge ->
  bc sp = BCstack ->
  pmatch bc b ofs p ->
  Ptrofs.unsigned ofs <= i < Ptrofs.unsigned ofs + sz ->
  nlive (nmem_add nm p sz) b i.
Proof.
  intros. unfold nmem_add. destruct nm. apply nlive_all.
  inv H1; try (apply nlive_all).
  - (* Gl id ofs *)
    assert (Genv.find_symbol ge id = Some b) by (eapply H; eauto).
    destruct gl!id as [iv|] eqn:NG.
  + constructor; simpl; intros.
    congruence.
    assert (id0 = id) by (eapply Genv.genv_vars_inj; eauto). subst id0.
    rewrite PTree.gss in H5. inv H5. rewrite ISet.In_remove.
    intros [A B]. elim A; auto.
  + constructor; simpl; intros.
    congruence.
    assert (id0 = id) by (eapply Genv.genv_vars_inj; eauto). subst id0.
    congruence.
  - (* Glo id *)
    assert (Genv.find_symbol ge id = Some b) by (eapply H; eauto).
    constructor; simpl; intros.
    congruence.
    assert (id0 = id) by (eapply Genv.genv_vars_inj; eauto). subst id0.
    rewrite PTree.grs in H5. congruence.
  - (* Stk ofs *)
    constructor; simpl; intros.
    rewrite ISet.In_remove. intros [A B]. elim A; auto.
    assert (bc b = BCglob id) by (eapply H; eauto). congruence.
  - (* Stack *)
    constructor; simpl; intros.
    apply ISet.In_empty.
    assert (bc b = BCglob id) by (eapply H; eauto). congruence.
Qed.

Lemma incl_nmem_add:
  forall nm b i p sz,
  nlive nm b i -> nlive (nmem_add nm p sz) b i.
Proof.
  intros. inversion H; subst. unfold nmem_add; destruct p; try (apply nlive_all).
- (* Gl id ofs *)
  destruct gl!id as [iv|] eqn:NG.
  + split; simpl; intros. auto.
    rewrite PTree.gsspec in H1. destruct (peq id0 id); eauto. inv H1.
    rewrite ISet.In_remove. intros [P Q]. eelim GL; eauto.
  + auto.
- (* Glo id *)
  split; simpl; intros. auto.
  rewrite PTree.grspec in H1. destruct (PTree.elt_eq id0 id). congruence. eauto.
- (* Stk ofs *)
  split; simpl; intros.
  rewrite ISet.In_remove. intros [P Q]. eelim STK; eauto.
  eauto.
- (* Stack *)
  split; simpl; intros.
  apply ISet.In_empty.
  eauto.
Qed.

(** Remove a range of locations from [nm], marking these locations as dead.
  The range starts at the abstract pointer [p] and has length [sz]. *)

Definition nmem_remove (nm: nmem) (p: aptr) (sz: Z) : nmem :=
  match nm with
  | NMemDead => NMemDead
  | NMem stk gl =>
    match p with
    | Gl id ofs =>
        let iv' :=
        match gl!id with
        | Some iv => ISet.add (Ptrofs.unsigned ofs) (Ptrofs.unsigned ofs + sz) iv
        | None    => ISet.interval (Ptrofs.unsigned ofs) (Ptrofs.unsigned ofs + sz)
        end in
        NMem stk (PTree.set id iv' gl)
    | Stk ofs =>
        NMem (ISet.add (Ptrofs.unsigned ofs) (Ptrofs.unsigned ofs + sz) stk) gl
    | _ => nm
    end
  end.

Lemma nlive_remove:
  forall bc b ofs p nm sz b' i,
  genv_match bc ge ->
  bc sp = BCstack ->
  pmatch bc b ofs p ->
  nlive nm b' i ->
  b' <> b \/ i < Ptrofs.unsigned ofs \/ Ptrofs.unsigned ofs + sz <= i ->
  nlive (nmem_remove nm p sz) b' i.
Proof.
  intros. inversion H2; subst. unfold nmem_remove; inv H1; auto.
- (* Gl id ofs *)
  set (iv' := match gl!id with
                  | Some iv =>
                      ISet.add (Ptrofs.unsigned ofs) (Ptrofs.unsigned ofs + sz) iv
                  | None =>
                      ISet.interval (Ptrofs.unsigned ofs)
                        (Ptrofs.unsigned ofs + sz)
              end).
  assert (Genv.find_symbol ge id = Some b) by (eapply H; eauto).
  split; simpl; auto; intros.
  rewrite PTree.gsspec in H6. destruct (peq id0 id).
+ inv H6. destruct H3. congruence. destruct gl!id as [iv0|] eqn:NG.
  unfold iv'; rewrite ISet.In_add. intros [P|P]. omega. eelim GL; eauto.
  unfold iv'; rewrite ISet.In_interval. omega.
+ eauto.
- (* Stk ofs *)
  split; simpl; auto; intros. destruct H3.
  elim H3. subst b'. eapply bc_stack; eauto.
  rewrite ISet.In_add. intros [P|P]. omega. eapply STK; eauto.
Qed.

(** Test (conservatively) whether some locations in the range delimited
  by [p] and [sz] can be live in [nm]. *)

Definition nmem_contains (nm: nmem) (p: aptr) (sz: Z) :=
  match nm with
  | NMemDead => false
  | NMem stk gl =>
      match p with
      | Gl id ofs =>
          match gl!id with
          | Some iv => negb (ISet.contains (Ptrofs.unsigned ofs) (Ptrofs.unsigned ofs + sz) iv)
          | None => true
          end
      | Stk ofs =>
          negb (ISet.contains (Ptrofs.unsigned ofs) (Ptrofs.unsigned ofs + sz) stk)
      | _ => true  (**r conservative answer *)
      end
  end.

Lemma nlive_contains:
  forall bc b ofs p nm sz i,
  genv_match bc ge ->
  bc sp = BCstack ->
  pmatch bc b ofs p ->
  nmem_contains nm p sz = false ->
  Ptrofs.unsigned ofs <= i < Ptrofs.unsigned ofs + sz ->
  ~(nlive nm b i).
Proof.
  unfold nmem_contains; intros. red; intros L; inv L.
  inv H1; try discriminate.
- (* Gl id ofs *)
  assert (Genv.find_symbol ge id = Some b) by (eapply H; eauto).
  destruct gl!id as [iv|] eqn:HG; inv H2.
  destruct (ISet.contains (Ptrofs.unsigned ofs) (Ptrofs.unsigned ofs + sz) iv) eqn:IC; try discriminate.
  rewrite ISet.contains_spec in IC. eelim GL; eauto.
- (* Stk ofs *)
  destruct (ISet.contains (Ptrofs.unsigned ofs) (Ptrofs.unsigned ofs + sz) stk) eqn:IC; try discriminate.
  rewrite ISet.contains_spec in IC. eelim STK; eauto. eapply bc_stack; eauto.
Qed.

(** Kill all stack locations between 0 and [sz], and mark everything else
  as live.  This reflects the effect of freeing the stack block at
  a [Ireturn] or [Itailcall] instruction. *)

Definition nmem_dead_stack (sz: Z) :=
  NMem (ISet.interval 0 sz) (PTree.empty _).

Lemma nlive_dead_stack:
  forall sz b' i, b' <> sp \/ ~(0 <= i < sz) -> nlive (nmem_dead_stack sz) b' i.
Proof.
  intros; constructor; simpl; intros.
- rewrite ISet.In_interval. intuition.
- rewrite PTree.gempty in H1; discriminate.
Qed.

(** Least upper bound *)

Definition nmem_lub (nm1 nm2: nmem) : nmem :=
  match nm1, nm2 with
  | NMemDead, _ => nm2
  | _, NMemDead => nm1
  | NMem stk1 gl1, NMem stk2 gl2 =>
      NMem (ISet.inter stk1 stk2)
           (PTree.combine
                (fun o1 o2 =>
                  match o1, o2 with
                  | Some iv1, Some iv2 => Some(ISet.inter iv1 iv2)
                  | _, _ => None
                  end)
                gl1 gl2)
  end.

Lemma nlive_lub_l:
  forall nm1 nm2 b i, nlive nm1 b i -> nlive (nmem_lub nm1 nm2) b i.
Proof.
  intros. inversion H; subst. destruct nm2; simpl. auto.
  constructor; simpl; intros.
- rewrite ISet.In_inter. intros [P Q]. eelim STK; eauto.
- rewrite PTree.gcombine in H1 by auto.
  destruct gl!id as [iv1|] eqn:NG1; try discriminate;
  destruct gl0!id as [iv2|] eqn:NG2; inv H1.
  rewrite ISet.In_inter. intros [P Q]. eelim GL; eauto.
Qed.

Lemma nlive_lub_r:
  forall nm1 nm2 b i, nlive nm2 b i -> nlive (nmem_lub nm1 nm2) b i.
Proof.
  intros. inversion H; subst. destruct nm1; simpl. auto.
  constructor; simpl; intros.
- rewrite ISet.In_inter. intros [P Q]. eelim STK; eauto.
- rewrite PTree.gcombine in H1 by auto.
  destruct gl0!id as [iv1|] eqn:NG1; try discriminate;
  destruct gl!id as [iv2|] eqn:NG2; inv H1.
  rewrite ISet.In_inter. intros [P Q]. eelim GL; eauto.
Qed.

(** Boolean-valued equality test *)

Definition nmem_beq (nm1 nm2: nmem) : bool :=
  match nm1, nm2 with
  | NMemDead, NMemDead => true
  | NMem stk1 gl1, NMem stk2 gl2 => ISet.beq stk1 stk2 && PTree.beq ISet.beq gl1 gl2
  | _, _ => false
  end.

Lemma nmem_beq_sound:
  forall nm1 nm2 b ofs,
  nmem_beq nm1 nm2 = true ->
  (nlive nm1 b ofs <-> nlive nm2 b ofs).
Proof.
  unfold nmem_beq; intros.
  destruct nm1 as [ | stk1 gl1]; destruct nm2 as [ | stk2 gl2]; try discriminate.
- split; intros L; inv L.
- InvBooleans. rewrite ISet.beq_spec in H0. rewrite PTree.beq_correct in H1.
  split; intros L; inv L; constructor; intros.
+ rewrite <- H0. eauto.
+ specialize (H1 id). rewrite H2 in H1. destruct gl1!id as [iv1|] eqn: NG; try contradiction.
  rewrite ISet.beq_spec in H1. rewrite <- H1. eauto.
+ rewrite H0. eauto.
+ specialize (H1 id). rewrite H2 in H1. destruct gl2!id as [iv2|] eqn: NG; try contradiction.
  rewrite ISet.beq_spec in H1. rewrite H1. eauto.
Qed.

End LOCATIONS.

(** * The lattice for dataflow analysis *)

Module NA <: SEMILATTICE.

  Definition t := (nenv * nmem)%type.

  Definition eq (x y: t) :=
    NE.eq (fst x) (fst y) /\
    (forall ge sp b ofs, nlive ge sp (snd x) b ofs <-> nlive ge sp (snd y) b ofs).

  Lemma eq_refl: forall x, eq x x.
  Proof.
    unfold eq; destruct x; simpl; split. apply NE.eq_refl. tauto.
  Qed.
  Lemma eq_sym: forall x y, eq x y -> eq y x.
  Proof.
    unfold eq; destruct x, y; simpl. intros [A B].
    split. apply NE.eq_sym; auto.
    intros. rewrite B. tauto.
  Qed.
  Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
  Proof.
    unfold eq; destruct x, y, z; simpl. intros [A B] [C D]; split.
    eapply NE.eq_trans; eauto.
    intros. rewrite B; auto.
  Qed.

  Definition beq (x y: t) : bool :=
    NE.beq (fst x) (fst y) && nmem_beq (snd x) (snd y).

  Lemma beq_correct: forall x y, beq x y = true -> eq x y.
  Proof.
    unfold beq, eq; destruct x, y; simpl; intros. InvBooleans. split.
    apply NE.beq_correct; auto.
    intros. apply nmem_beq_sound; auto.
  Qed.

  Definition ge (x y: t) : Prop :=
    NE.ge (fst x) (fst y) /\
    (forall ge sp b ofs, nlive ge sp (snd y) b ofs -> nlive ge sp (snd x) b ofs).

  Lemma ge_refl: forall x y, eq x y -> ge x y.
  Proof.
    unfold eq, ge; destruct x, y; simpl. intros [A B]; split.
    apply NE.ge_refl; auto.
    intros. apply B; auto.
  Qed.
  Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
  Proof.
    unfold ge; destruct x, y, z; simpl. intros [A B] [C D]; split.
    eapply NE.ge_trans; eauto.
    auto.
  Qed.

  Definition bot : t := (NE.bot, NMemDead).

  Lemma ge_bot: forall x, ge x bot.
  Proof.
    unfold ge, bot; destruct x; simpl. split.
    apply NE.ge_bot.
    intros. inv H.
  Qed.

  Definition lub (x y: t) : t :=
    (NE.lub (fst x) (fst y), nmem_lub (snd x) (snd y)).

  Lemma ge_lub_left: forall x y, ge (lub x y) x.
  Proof.
    unfold ge; destruct x, y; simpl; split.
    apply NE.ge_lub_left.
    intros; apply nlive_lub_l; auto.
  Qed.
  Lemma ge_lub_right: forall x y, ge (lub x y) y.
  Proof.
    unfold ge; destruct x, y; simpl; split.
    apply NE.ge_lub_right.
    intros; apply nlive_lub_r; auto.
  Qed.

End NA.


Require Import extraInv.
Local Open Scope Z.

Definition cond8 :=
 ctrlState1.[of_Z timer1]<>ctrlWaiting /\ ctrlState1.[of_Z timer1]<>ctrlDrying.


From stdpp Require Import countable.
From stdpp Require Import gmap.
From iris.algebra Require Export cmra.
From iris.algebra Require Import proofmode_classes updates frac.
From iris.algebra Require Import agree.
From iris.prelude Require Import options.

(*
==========
Heap CMRA
==========

Here we define the CMRA we'll use to construct the "points-to" ghost state
that will be built-in to the program logic, in the sense that its meaning is
tied to the physical state of the program by the program logic definition itself.

Ordinarily you wouldn't build a CMRA "by hand" like this, but instead would use
the various combinators provided by Iris. In fact, there's a library called
gen_heap built on top of the auth RA (and a few others) that works well for the
purpose in simp_lang. However, by building it up ourselves it's easier to show
how all the pieces fit together and reduce the amount of magic.

The downside to constructing the RA by hand is that this file has a subsantial
amount of proof.

This library is parameterized over arbitrary types of keys (`K`) and values
(`V`), although we will only use it for `loc` and `val` of simp_lang.
Mathematically, we can think of this RA as having elements of the form `Auth m`
and `Frag m` where `m : gmap K V`, which stand for "authorative ownership" and
"fragmentary ownership". The idea is that there is a single `Auth σ` that holds
the true, physical heap, while `Frag m` will be owned by threads and gives the
right to read/modify a part of the heap. We'll also have a special `⊥` (invalid)
element to represent compositions that don't make sense.

These have the following composition/validity properties:

- `Auth m ⋅ Auth m' = ⊥` (there's only one auth)
- `Frag m ⋅ Frag m' = m ∪ m' if m and m' are disjoint (##ₘ)
- `✓ (Auth m ⋅ Frag m') ↔ m' ⊆ m (fragments always agree with the authoritative copy)

An important special case is `Frag {[k := v]}`, fragmentary ownership of a
singleton. This is like a points-to fact, and in fact `l ↦ v` will be *defined* as
`own (Frag {[l := v]})`.

This CMRA permits the following important *local updates* and validity rules, which are
"frame-preserving updates". `x ~~> y` is defined to be `∀ z, ✓ (x ⋅ z) → ✓ (y ⋅
z)`, which means that we can replace x with y locally and preserve global
validity.

- `Auth m ~~> Auth (<[k := v]> m) ⋅ Frag {[k := v]` if `m !! k = None`
- `Auth m ⋅ Frag {[k := v]} ~~> Auth (<[k := v']> m) ⋅ Frag {[k := v']}`

|*)

Section heap_map.
  Context {K: Type}
    `{EqDecision0: !EqDecision K}
    `{Countable0: !Countable K}
    {V: Type} `{EqDecision V}.

  Record auth_map_val :=
    { auth: option (gmap K V);
      frag: gmap K V;
    }.

  (** The carrier for the CMRA we're defining. We will define something that
  looks like a PCM (partial commutative monoid), with a partial composition
  operation that returns `Invalid` when composition doesn't make sense. We need
  to do this to fit into Iris's algebraic structure for resource, called a CMRA,
  which isntead has a notion of composing elements and a predicate for valid
  elements.  The difference is important for higher-order ghost state, but this
  is not a higher-order CMRA (that is, it doesn't depend on `iProp`). *)
  Inductive heap_map :=
  | Ok (v: auth_map_val)
  | Invalid.

  Canonical Structure heap_mapO := leibnizO heap_map.

  Global Instance heap_map_inhabited : Inhabited heap_map := populate Invalid.
  Local Lemma gmap_eq_dec : EqDecision (gmap K V).
  Proof using All. apply _. Qed.
  Global Instance auth_map_eq_dec : EqDecision auth_map_val.
  Proof using All. solve_decision. Qed.
  Global Instance heap_map_eq_dec : EqDecision heap_map.
  Proof using All. solve_decision. Qed.

  Global Instance heap_map_Ok_inj : Inj (=) (=) Ok.
  Proof. by injection 1. Qed.

  (** An element is valid if it's Ok v and the fragment is contained in the
  auth. This ensures that fragments really agree with the global auth state. *)
  Local Instance heap_map_valid_instance : Valid heap_map := λ hm,
    match hm with
    | Ok {| auth := Some m; frag := m' |} => m' ⊆ m
    | Ok {| auth := None; frag := m' |} => True
    | Invalid => False
    end.

  (** In a PCM there would be a unit for composition ε and `∀ x, x ⋅ ε = x`.
  Instead of a global unit, a CMRA requires one more piece: a partial core or
  `pcore`, that (might) give a unit for each element - the might is the
  "partial" in the name. The `pcore` is used to model the persistently modality
  (□P). It won't be relevant to our example, but this CMRA has a unit and we can
  use it to give a total pcore, which turns out to simplify some proofs later.
  *)
  Instance heap_map_unit : Unit heap_map := Ok {| auth := None; frag := ∅ |}.
  Local Instance heap_map_pcore_instance : PCore heap_map := λ _, Some ε.

  (** Composition has two facets: the auth part of a heap does not compose
  (there's only one auth), while fragments compose via disjoint union. Other
  combinations result in `Invalid`. *)
  Local Instance heap_map_op_instance : Op heap_map := λ hm1 hm2,
      match hm1, hm2 with
      | Ok {| auth := Some m1; frag := m1' |},
        Ok {| auth := Some m2; frag := m2' |} =>
        Invalid
      | Ok {| auth := Some m1; frag := m1' |},
        Ok {| auth := None; frag := m2' |} =>
          if decide (m1' ##ₘ m2') then
            Ok {| auth := Some m1; frag := m1' ∪ m2' |}
          else Invalid
      | Ok {| auth := None; frag := m1' |},
        Ok {| auth := mm2; frag := m2' |} =>
          if decide (m1' ##ₘ m2') then
            Ok {| auth := mm2; frag := m1' ∪ m2' |}
          else Invalid
      | Invalid, _ => Invalid
      | _, Invalid => Invalid
      end.

  Lemma heap_map_unit_ok (hm: heap_map) : ε ⋅ hm = hm.
  Proof.
    rewrite /ε /heap_map_unit.
    rewrite /op /heap_map_op_instance.
    destruct hm as [[[m|] m'] | ]; auto.
    - rewrite -> decide_True by apply map_disjoint_empty_l.
      rewrite map_empty_union //.
    - rewrite -> decide_True by apply map_disjoint_empty_l.
      rewrite map_empty_union //.
  Qed.

  Definition Auth (m: gmap K V) : heap_map := Ok {| auth := Some m; frag := ∅ |}.
  Definition Frag (m: gmap K V) : heap_map := Ok {| auth := None; frag := m |}.

  Lemma heap_map_frag_op (m1 m2: gmap K V) :
    m1 ##ₘ m2 →
    Frag m1 ⋅ Frag m2 = Frag (m1 ∪ m2).
  Proof.
    intros Hdisj.
    rewrite /op /heap_map_op_instance /=.
    rewrite decide_True //.
  Qed.

  Lemma heap_map_auth_op (m1 m2: gmap K V) :
    Auth m1 ⋅ Auth m2 = Invalid.
  Proof.
    rewrite /op /heap_map_op_instance //=.
  Qed.

  Local Lemma heap_map_op_auth_frag (m m': gmap K V) :
    Auth m ⋅ Frag m' = Ok {| auth := Some m; frag := m'; |}.
  Proof.
    rewrite /op /heap_map_op_instance /=.
    rewrite decide_True.
    - rewrite map_empty_union //.
    - apply map_disjoint_empty_l.
  Qed.

  Ltac map_solver :=
    repeat match goal with
      | H: context[_ ##ₘ _] |- _ => rewrite map_disjoint_dom in H
      | |- context[_ ##ₘ _] => rewrite map_disjoint_dom
      | H: context[dom (_ ∪ _)] |- _ => rewrite dom_union_L in H
      | |- context[dom (_ ∪ _)] => rewrite dom_union_L
      | _ => rewrite map_union_assoc
      end;
    set_solver.

  (*|
Below we need to prove that the composition operation and validity predicate
respect all the algebraic laws of a CMRA.
  |*)

  Local Instance heap_map_op_comm : Comm (=) (op: heap_map → heap_map → heap_map).
  Proof.
    intros hm1 hm2.
    rewrite /op /heap_map_op_instance.
    destruct hm1 as [[[m1|] m1']|], hm2 as [[[m2|] m2']|];
      simpl; auto;
      repeat (destruct (decide _);
              destruct_and?; subst);
      try map_solver.
    all: rewrite map_union_comm //.
  Qed.

  Local Instance heap_map_op_assoc : Assoc (=) (op: heap_map → heap_map → heap_map).
  Proof.
    intros hm1 hm2 hm3.
    rewrite /op /heap_map_op_instance.
    destruct hm1 as [[[m1|] m1']|], hm2 as [[[m2|] m2']|], hm3 as [[[m3|] m3']|];
      simpl; auto;
      repeat (destruct (decide _);
              destruct_and?; subst);
      try map_solver.
  Qed.

  Lemma heap_map_valid_op : ∀ (x y: heap_map), ✓ (x ⋅ y) → ✓ x.
  Proof.
    intros [[mm1 m1']|] [[mm2 m2']|];
      rewrite /valid /heap_map_valid_instance /=;
      rewrite /op /heap_map_op_instance /=;
      auto.
    - destruct mm1 as [m1|], mm2 as [m2|]; intuition eauto.
      revert H; destruct (decide _); intuition eauto.
      rewrite map_subseteq_spec in H.
      apply map_subseteq_spec.
      intros k v Hlookup.
      apply H.
      rewrite lookup_union_l //.
      apply map_disjoint_dom in m.
      apply elem_of_dom_2 in Hlookup.
      apply not_elem_of_dom.
      set_solver.
    - destruct mm1 as [m1|]; intuition eauto.
  Qed.

  Definition heap_map_ra_mixin : RAMixin heap_map.
  Proof.
    (* Several obligations are proven due to the above [Local Instance]s. Most
    of the remaining ones are about `pcore`, and are quite simple since it is
    total. *)
    split; try apply _.
    - intros hm1 hm2 chm1; rewrite leibniz_equiv_iff; intros <-.
      rewrite /pcore /heap_map_pcore_instance /=.
      intros [=]; subst.
      eexists; eauto.
    - intros hm1 chm1.
      rewrite /pcore /heap_map_pcore_instance.
      intros [=]; subst.
      rewrite heap_map_unit_ok //.
    - intros hm1 chm1.
      rewrite /pcore /heap_map_pcore_instance.
      rewrite leibniz_equiv_iff //.
    - intros ??? Hincl.
      rewrite /pcore /heap_map_pcore_instance => [= <-].
      eexists; intuition eauto.
      exists ε; rewrite heap_map_unit_ok //.
    - apply heap_map_valid_op.
  Qed.
  Canonical Structure heap_mapR := discreteR heap_map heap_map_ra_mixin.

  Global Instance heap_map_cmra_discrete : CmraDiscrete heap_mapR.
  Proof. apply discrete_cmra_discrete. Qed.

  Global Instance heap_map_cmra_total : CmraTotal heap_mapR.
  Proof. intros hm. auto. Qed.

  (** This is the key lemma for creating this RA in the first place. *)
  Lemma heap_map_auth_valid m : ✓ (Auth m).
  Proof.
    rewrite /valid /heap_map_valid_instance /Auth.
    apply map_empty_subseteq.
  Qed.

  Lemma heap_map_auth_frag_valid m m' : ✓ (Auth m ⋅ Frag m') ↔ m' ⊆ m.
  Proof.
    rewrite heap_map_op_auth_frag.
    rewrite /valid //=.
  Qed.

  Lemma heap_map_auth_other_valid m hm :
    ✓ (Auth m ⋅ hm) ↔ ∃ m', hm = Frag m' ∧ m' ⊆ m.
  Proof.
    split.
    - rewrite /valid /heap_map_valid_instance.
      rewrite /Auth.
      destruct hm as [[mm' m'']|]; simpl; try solve [ intuition idtac ].
      destruct mm' as [m'|]; simpl; try solve [ intuition idtac ].
      rewrite /op /=.
      rewrite -> decide_True by apply map_disjoint_empty_l.
      rewrite map_empty_union.
      intros Hsub.
      rewrite /Frag. eexists; split; eauto.
    - intros [m' [-> Hsub]].
      rewrite heap_map_auth_frag_valid //.
  Qed.

  Lemma heap_map_frag_frag_valid m m' :
    ✓ (Frag m ⋅ Frag m') ↔ m ##ₘ m'.
  Proof.
    split.
    - rewrite /Frag /valid /heap_map_valid_instance /=.
      rewrite /op /=.
      destruct (decide _); intuition eauto.
    - intros.
      rewrite heap_map_frag_op //.
  Qed.

  Lemma heap_map_auth_frag_other_valid m m' hm :
    ✓ (Auth m ⋅ Frag m' ⋅ hm) ↔ ∃ m'', hm = Frag m'' ∧ m' ∪ m'' ⊆ m ∧ m' ##ₘ m''.
  Proof.
    split.
    - intros Hval.
      assert (✓ (Auth m ⋅ hm)).
      { rewrite -assoc_L (comm _ (Frag m')) assoc_L in Hval.
        apply cmra_valid_op_l in Hval; auto. }
      apply heap_map_auth_other_valid in H as [m'' [-> Hsub]].
      assert (m' ##ₘ m'').
      { rewrite -assoc_L in Hval; apply cmra_valid_op_r in Hval.
        apply heap_map_frag_frag_valid in Hval; auto. }
      rewrite -assoc_L in Hval.
      rewrite heap_map_frag_op // in Hval.
      apply heap_map_auth_frag_valid in Hval.
      eexists; intuition eauto.
    - intros [m'' (-> & Hsub & Hdisj)].
      rewrite -assoc_L heap_map_frag_op //.
      apply heap_map_auth_frag_valid; auto.
  Qed.

  (** This local update permits allocating a points-to fact for a fresh
  address. It's the key lemma for reasoning about allocating new references. *)
  Lemma heap_map_alloc_update m k v :
    m !! k = None →
    Auth m ~~> Auth (<[k := v]> m) ⋅ Frag {[k := v]}.
  Proof.
    intros Hnotin.
    assert (m ##ₘ {[k := v]}).
    { apply map_disjoint_dom.
      apply not_elem_of_dom in Hnotin.
      set_solver. }
    apply cmra_discrete_update.
    intros hm'; rewrite heap_map_auth_other_valid.
    intros [m' [-> Hsub]].
    assert ({[k := v]} ##ₘ m').
    { apply map_disjoint_dom in H. apply map_disjoint_dom.
      apply not_elem_of_dom in Hnotin.
      apply subseteq_dom in Hsub.
      set_solver. }
    rewrite -assoc_L.
    rewrite heap_map_frag_op //.
    - apply heap_map_auth_frag_valid.
      rewrite insert_union_singleton_l.
      apply map_union_mono_l; auto.
  Qed.

  (** This lemma relates owning a fragment to the authoritative element. It is
  specialized to a singleton fragment since that's how we'll eventually use this
  RA in proofs. It's the key lemma to reasoning about loading a value with a
  points-to fact. *)
  Lemma heap_map_singleton_valid k v m :
    ✓ (Auth m ⋅ Frag {[k := v]}) →
    m !! k = Some v.
  Proof.
    rewrite heap_map_auth_frag_valid.
    intros Hlookup%map_singleton_subseteq_l; auto.
  Qed.

  (** This local update permits updating the value of a key using a fragment.
  It's the key lemma for storing using a points-to fact. *)
  Lemma heap_map_modify_update m k v v' :
    Auth m ⋅ Frag {[k := v]} ~~> Auth (<[k := v']> m) ⋅ Frag {[k := v']}.
  Proof.
    apply cmra_discrete_update.
    intros hm.
    rewrite ?heap_map_auth_frag_other_valid.
    intros [m'' (-> & Hsub & Hdisj)].
    exists m''; intuition eauto.
    - rewrite insert_union_singleton_l.
      apply map_union_mono_l.
      apply map_subseteq_spec => k' v'' Hlookup.
      rewrite map_subseteq_spec in Hsub.
      apply Hsub.
      rewrite lookup_union_r //.
      apply lookup_singleton_None.
      apply map_disjoint_dom in Hdisj.
      apply elem_of_dom_2 in Hlookup.
      set_solver.
    - apply map_disjoint_dom.
      apply map_disjoint_dom in Hdisj.
      set_solver.
  Qed.

End heap_map.

Arguments heap_map K {EqDecision0 Countable0} V.
Arguments heap_mapR K {EqDecision0 Countable0} V.


From ExtLib Require Export
     Functor
     List
     Traversable
     Monad
     OptionMonad.
From Coq Require Export
     Basics
     Bool
     Ascii
     Orders
     Mergesort
     String
     List
     ZArith.
Export
  FunctorNotation
  MonadNotation
  IfNotations.
Open Scope lazy_bool_scope.
Open Scope monad_scope.
Open Scope program_scope.

Inductive json :=
  JSON__Object : list (string * json) -> json
| JSON__Array  : list json            -> json
| JSON__String : string               -> json
| JSON__Number : Z                    -> json
| JSON__True
| JSON__False
| JSON__Null.

Definition get_json' (k : string) (j : json) : option json :=
  if j is JSON__Object l
  then snd <$> find (eqb k ∘ fst) l
  else None.

Definition get_json (k : string) (j : json) : json :=
  if get_json' k j is Some j then j else JSON__Null.

Definition get_Z (k : string) (j : json) : option Z :=
  if get_json k j is JSON__Number z then Some z else None.

Definition get_N (k : string) (j : json) : option N :=
  z <- get_Z k j;;
  if z is Zneg _
  then None
  else Some (Z.to_N z).

Definition get_string (k : string) (j : json) : option string :=
  if get_json k j is JSON__String str then Some str else None.

Definition get_bool (k : string) (j : json) : option bool :=
  match get_json k j with
  | JSON__True  => Some true
  | JSON__False => Some false
  | _         => None
  end.

Definition get_list {T} (f : json -> option T) (j : json) : option (list T) :=
  if j is JSON__Array l
  then sequence (map f l)
  else None.

Definition get_nth (n : nat) (j : json) : option json :=
  if j is JSON__Array l
  then nth_error l n
  else None.


Require Import list_examples.

Definition head_def := FunDef "head" ["x"]
  (SReturn ("x"->>"val")).

Inductive head_spec : Spec kcfg :=
  head_claim : forall p H x l, heap_fun head_spec nil
  head_def [Int p]
    (asP H (rep_list (x::l) p))
    (fun r => constraint (r=x) :* litP H).

Lemma head_proof : sound kstep head_spec.
Proof. list_solver. Qed.