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

(** Correctness proof for PPC generation: auxiliary results. *)

Require Import Coqlib.
Require Import Errors.
Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
Require Import Op.
Require Import Locations.
Require Import Mach.
Require Import Asm.
Require Import Asmgen.
Require Import Conventions.
Require Import Asmgenproof0.

(** * Properties of low half/high half decomposition *)

Lemma high_half_zero:
  forall v, Val.add (high_half v) Vzero = high_half v.
Proof.
  intros. generalize (high_half_type v).
  rewrite Val.add_commut.
  case (high_half v); simpl; intros; try contradiction.
  auto.
  rewrite Int.add_commut; rewrite Int.add_zero; auto.
  rewrite Int.add_zero; auto.
Qed.

Lemma low_high_u:
  forall n, Int.or (Int.shl (high_u n) (Int.repr 16)) (low_u n) = n.
Proof.
  intros. unfold high_u, low_u.
  rewrite Int.shl_rolm. rewrite Int.shru_rolm.
  rewrite Int.rolm_rolm.
  change (Int.modu (Int.add (Int.sub (Int.repr (Z_of_nat Int.wordsize)) (Int.repr 16))
                            (Int.repr 16))
                   (Int.repr (Z_of_nat Int.wordsize)))
    with (Int.zero).
  rewrite Int.rolm_zero. rewrite <- Int.and_or_distrib.
  exact (Int.and_mone n).
  apply int_wordsize_divides_modulus. reflexivity. reflexivity.
Qed.

Lemma low_high_u_xor:
  forall n, Int.xor (Int.shl (high_u n) (Int.repr 16)) (low_u n) = n.
Proof.
  intros. unfold high_u, low_u.
  rewrite Int.shl_rolm. rewrite Int.shru_rolm.
  rewrite Int.rolm_rolm.
  change (Int.modu (Int.add (Int.sub (Int.repr (Z_of_nat Int.wordsize)) (Int.repr 16))
                            (Int.repr 16))
                   (Int.repr (Z_of_nat Int.wordsize)))
    with (Int.zero).
  rewrite Int.rolm_zero. rewrite <- Int.and_xor_distrib.
  exact (Int.and_mone n).
  apply int_wordsize_divides_modulus. reflexivity. reflexivity.
Qed.

Lemma low_high_s:
  forall n, Int.add (Int.shl (high_s n) (Int.repr 16)) (low_s n) = n.
Proof.
  intros.
  rewrite Int.shl_mul_two_p.
  unfold high_s.
  rewrite <- (Int.divu_pow2 (Int.sub n (low_s n)) (Int.repr 65536) (Int.repr 16)).
  2: reflexivity.
  change (two_p (Int.unsigned (Int.repr 16))) with 65536.
  set (x := Int.sub n (low_s n)).
  assert (x = Int.add (Int.mul (Int.divu x (Int.repr 65536)) (Int.repr 65536))
                      (Int.modu x (Int.repr 65536))).
    apply Int.modu_divu_Euclid. vm_compute; congruence.
  assert (Int.modu x (Int.repr 65536) = Int.zero).
    unfold Int.modu, Int.zero. decEq.
    change 0 with (0 mod 65536).
    change (Int.unsigned (Int.repr 65536)) with 65536.
    apply Int.eqmod_mod_eq. omega.
    unfold x, low_s. eapply Int.eqmod_trans.
    apply Int.eqmod_divides with Int.modulus.
    unfold Int.sub. apply Int.eqm_unsigned_repr_l. apply Int.eqm_refl.
    exists 65536. compute; auto.
    replace 0 with (Int.unsigned n - Int.unsigned n) by omega.
    apply Int.eqmod_sub. apply Int.eqmod_refl. apply Int.eqmod_sign_ext'.
    compute; auto.
  rewrite H0 in H. rewrite Int.add_zero in H.
  rewrite <- H. unfold x. rewrite Int.sub_add_opp. rewrite Int.add_assoc.
  rewrite (Int.add_commut (Int.neg (low_s n))). rewrite <- Int.sub_add_opp.
  rewrite Int.sub_idem. apply Int.add_zero.
Qed.

(** Useful properties of the GPR0 registers. *)

Lemma gpr_or_zero_not_zero:
  forall rs r, r <> GPR0 -> gpr_or_zero rs r = rs#r.
Proof.
  intros. unfold gpr_or_zero. case (ireg_eq r GPR0); tauto.
Qed.
Lemma gpr_or_zero_zero:
  forall rs, gpr_or_zero rs GPR0 = Vzero.
Proof.
  intros. reflexivity.
Qed.
Hint Resolve gpr_or_zero_not_zero gpr_or_zero_zero: asmgen.

Lemma ireg_of_not_GPR0:
  forall m r, ireg_of m = OK r -> IR r <> IR GPR0.
Proof.
  intros. erewrite <- ireg_of_eq; eauto with asmgen.
Qed.
Hint Resolve ireg_of_not_GPR0: asmgen.

Lemma ireg_of_not_GPR0':
  forall m r, ireg_of m = OK r -> r <> GPR0.
Proof.
  intros. generalize (ireg_of_not_GPR0 _ _ H). congruence.
Qed.
Hint Resolve ireg_of_not_GPR0': asmgen.

(** Useful simplification tactic *)

Ltac Simplif :=
  ((rewrite nextinstr_inv by eauto with asmgen)
  || (rewrite nextinstr_inv1 by eauto with asmgen)
  || (rewrite Pregmap.gss)
  || (rewrite nextinstr_pc)
  || (rewrite Pregmap.gso by eauto with asmgen)); auto with asmgen.

Ltac Simpl := repeat Simplif.

(** * Correctness of PowerPC constructor functions *)

Section CONSTRUCTORS.

Variable ge: genv.
Variable fn: code.

(** Properties of comparisons. *)

Lemma compare_float_spec:
  forall rs v1 v2,
  let rs1 := nextinstr (compare_float rs v1 v2) in
     rs1#CR0_0 = Val.cmpf Clt v1 v2
  /\ rs1#CR0_1 = Val.cmpf Cgt v1 v2
  /\ rs1#CR0_2 = Val.cmpf Ceq v1 v2
  /\ forall r', r' <> CR0_0 -> r' <> CR0_1 -> r' <> CR0_2 -> r' <> CR0_3 -> r' <> PC -> rs1#r' = rs#r'.
Proof.
  intros. unfold rs1.
  split. reflexivity.
  split. reflexivity.
  split. reflexivity.
  intros. unfold compare_float. Simpl.
Qed.

Lemma compare_sint_spec:
  forall rs v1 v2,
  let rs1 := nextinstr (compare_sint rs v1 v2) in
     rs1#CR0_0 = Val.cmp Clt v1 v2
  /\ rs1#CR0_1 = Val.cmp Cgt v1 v2
  /\ rs1#CR0_2 = Val.cmp Ceq v1 v2
  /\ forall r', r' <> CR0_0 -> r' <> CR0_1 -> r' <> CR0_2 -> r' <> CR0_3 -> r' <> PC -> rs1#r' = rs#r'.
Proof.
  intros. unfold rs1.
  split. reflexivity.
  split. reflexivity.
  split. reflexivity.
  intros. unfold compare_sint. Simpl.
Qed.

Lemma compare_uint_spec:
  forall rs m v1 v2,
  let rs1 := nextinstr (compare_uint rs m v1 v2) in
     rs1#CR0_0 = Val.cmpu (Mem.valid_pointer m) Clt v1 v2
  /\ rs1#CR0_1 = Val.cmpu (Mem.valid_pointer m) Cgt v1 v2
  /\ rs1#CR0_2 = Val.cmpu (Mem.valid_pointer m) Ceq v1 v2
  /\ forall r', r' <> CR0_0 -> r' <> CR0_1 -> r' <> CR0_2 -> r' <> CR0_3 -> r' <> PC -> rs1#r' = rs#r'.
Proof.
  intros. unfold rs1.
  split. reflexivity.
  split. reflexivity.
  split. reflexivity.
  intros. unfold compare_uint. Simpl.
Qed.

(** Loading a constant. *)

Lemma loadimm_correct:
  forall r n k rs m,
  exists rs',
     exec_straight ge fn (loadimm r n k) rs m  k rs' m
  /\ rs'#r = Vint n
  /\ forall r': preg, r' <> r -> r' <> PC -> rs'#r' = rs#r'.
Proof.
  intros. unfold loadimm.
  case (Int.eq (high_s n) Int.zero).
  (* addi *)
  econstructor; split. apply exec_straight_one. simpl; eauto. auto.
  rewrite Int.add_zero_l. intuition Simpl.
  (* addis *)
  generalize (Int.eq_spec (low_s n) Int.zero); case (Int.eq (low_s n) Int.zero); intro.
  econstructor; split. apply exec_straight_one. simpl; eauto. auto.
  rewrite <- H. rewrite Int.add_commut. rewrite low_high_s.
  intuition Simpl.
  (* addis + ori *)
  econstructor; split. eapply exec_straight_two.
  simpl; eauto. simpl; eauto. auto. auto.
  split. Simpl. rewrite Int.add_zero_l. unfold Val.or. rewrite low_high_u. auto.
  intros; Simpl.
Qed.

(** Add integer immediate. *)

Lemma addimm_correct:
  forall r1 r2 n k rs m,
  r1 <> GPR0 ->
  r2 <> GPR0 ->
  exists rs',
     exec_straight ge fn (addimm r1 r2 n k) rs m  k rs' m
  /\ rs'#r1 = Val.add rs#r2 (Vint n)
  /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'.
Proof.
  intros. unfold addimm.
  (* addi *)
  case (Int.eq (high_s n) Int.zero).
  econstructor; split. apply exec_straight_one.
  simpl. rewrite gpr_or_zero_not_zero; eauto.
  reflexivity.
  intuition Simpl.
  (* addis *)
  generalize (Int.eq_spec (low_s n) Int.zero); case (Int.eq (low_s n) Int.zero); intro.
  econstructor; split. apply exec_straight_one.
  simpl. rewrite gpr_or_zero_not_zero; auto. auto.
  split. Simpl.
  generalize (low_high_s n). rewrite H1. rewrite Int.add_zero. congruence.
  intros; Simpl.
  (* addis + addi *)
  econstructor; split. eapply exec_straight_two.
  simpl. rewrite gpr_or_zero_not_zero; eauto.
  simpl. rewrite gpr_or_zero_not_zero; eauto.
  auto. auto.
  split. Simpl. rewrite Val.add_assoc. simpl. rewrite low_high_s. auto.
  intros; Simpl.
Qed.

(** And integer immediate. *)

Lemma andimm_base_correct:
  forall r1 r2 n k (rs : regset) m,
  r2 <> GPR0 ->
  let v := Val.and rs#r2 (Vint n) in
  exists rs',
     exec_straight ge fn (andimm_base r1 r2 n k) rs m  k rs' m
  /\ rs'#r1 = v
  /\ rs'#CR0_2 = Val.cmp Ceq v Vzero
  /\ forall r', data_preg r' = true -> r' <> r1 -> rs'#r' = rs#r'.
Proof.
  intros. unfold andimm_base.
  case (Int.eq (high_u n) Int.zero).
  (* andi *)
  exists (nextinstr (compare_sint (rs#r1 <- v) v Vzero)).
  generalize (compare_sint_spec (rs#r1 <- v) v Vzero).
  intros [A [B [C D]]].
  split. apply exec_straight_one. reflexivity. reflexivity.
  split. rewrite D; auto with asmgen. Simpl.
  split. auto.
  intros. rewrite D; auto with asmgen. Simpl.
  (* andis *)
  generalize (Int.eq_spec (low_u n) Int.zero);
  case (Int.eq (low_u n) Int.zero); intro.
  exists (nextinstr (compare_sint (rs#r1 <- v) v Vzero)).
  generalize (compare_sint_spec (rs#r1 <- v) v Vzero).
  intros [A [B [C D]]].
  split. apply exec_straight_one. simpl.
  generalize (low_high_u n). rewrite H0. rewrite Int.or_zero.
  intro. rewrite H1. reflexivity. reflexivity.
  split. rewrite D; auto with asmgen. Simpl.
  split. auto.
  intros. rewrite D; auto with asmgen. Simpl.
  (* loadimm + and *)
  generalize (loadimm_correct GPR0 n (Pand_ r1 r2 GPR0 :: k) rs m).
  intros [rs1 [EX1 [RES1 OTHER1]]].
  exists (nextinstr (compare_sint (rs1#r1 <- v) v Vzero)).
  generalize (compare_sint_spec (rs1#r1 <- v) v Vzero).
  intros [A [B [C D]]].
  split. eapply exec_straight_trans. eexact EX1.
  apply exec_straight_one. simpl. rewrite RES1.
  rewrite (OTHER1 r2). reflexivity. congruence. congruence.
  reflexivity.
  split. rewrite D; auto with asmgen. Simpl.
  split. auto.
  intros. rewrite D; auto with asmgen. Simpl.
Qed.

Lemma andimm_correct:
  forall r1 r2 n k (rs : regset) m,
  r2 <> GPR0 ->
  exists rs',
     exec_straight ge fn (andimm r1 r2 n k) rs m  k rs' m
  /\ rs'#r1 = Val.and rs#r2 (Vint n)
  /\ forall r', data_preg r' = true -> r' <> r1 -> rs'#r' = rs#r'.
Proof.
  intros. unfold andimm. destruct (is_rlw_mask n).
  (* turned into rlw *)
  econstructor; split. eapply exec_straight_one.
  simpl. rewrite Val.rolm_zero. eauto. auto.
  intuition Simpl.
  (* andimm_base *)
  destruct (andimm_base_correct r1 r2 n k rs m) as [rs' [A [B [C D]]]]; auto.
  exists rs'; auto.
Qed.

(** Or integer immediate. *)

Lemma orimm_correct:
  forall r1 (r2: ireg) n k (rs : regset) m,
  let v := Val.or rs#r2 (Vint n) in
  exists rs',
     exec_straight ge fn (orimm r1 r2 n k) rs m  k rs' m
  /\ rs'#r1 = v
  /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'.
Proof.
  intros. unfold orimm.
  case (Int.eq (high_u n) Int.zero).
  (* ori *)
  exists (nextinstr (rs#r1 <- v)).
  split. apply exec_straight_one. reflexivity. reflexivity.
  intuition Simpl.
  (* oris *)
  generalize (Int.eq_spec (low_u n) Int.zero);
  case (Int.eq (low_u n) Int.zero); intro.
  exists (nextinstr (rs#r1 <- v)).
  split. apply exec_straight_one. simpl.
  generalize (low_high_u n). rewrite H. rewrite Int.or_zero.
  intro. rewrite H0. reflexivity. reflexivity.
  intuition Simpl.
  (* oris + ori *)
  econstructor; split. eapply exec_straight_two; simpl; reflexivity.
  intuition Simpl.
  rewrite Val.or_assoc. simpl. rewrite low_high_u. reflexivity.
Qed.

(** Xor integer immediate. *)

Lemma xorimm_correct:
  forall r1 (r2: ireg) n k (rs : regset) m,
  let v := Val.xor rs#r2 (Vint n) in
  exists rs',
     exec_straight ge fn (xorimm r1 r2 n k) rs m  k rs' m
  /\ rs'#r1 = v
  /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'.
Proof.
  intros. unfold xorimm.
  case (Int.eq (high_u n) Int.zero).
  (* xori *)
  exists (nextinstr (rs#r1 <- v)).
  split. apply exec_straight_one. reflexivity. reflexivity.
  intuition Simpl.
  (* xoris *)
  generalize (Int.eq_spec (low_u n) Int.zero);
  case (Int.eq (low_u n) Int.zero); intro.
  exists (nextinstr (rs#r1 <- v)).
  split. apply exec_straight_one. simpl.
  generalize (low_high_u n). rewrite H. rewrite Int.or_zero.
  intro. rewrite H0. reflexivity. reflexivity.
  intuition Simpl.
  (* xoris + xori *)
  econstructor; split. eapply exec_straight_two; simpl; reflexivity.
  intuition Simpl.
  rewrite Val.xor_assoc. simpl. rewrite low_high_u_xor. reflexivity.
Qed.

(** Rotate and mask. *)

Lemma rolm_correct:
  forall r1 r2 amount mask k (rs : regset) m,
  r1 <> GPR0 ->
  exists rs',
     exec_straight ge fn (rolm r1 r2 amount mask k) rs m  k rs' m
  /\ rs'#r1 = Val.rolm rs#r2 amount mask
  /\ forall r', data_preg r' = true -> r' <> r1 -> rs'#r' = rs#r'.
Proof.
  intros. unfold rolm. destruct (is_rlw_mask mask).
  (* rlwinm *)
  econstructor; split. eapply exec_straight_one; simpl; eauto.
  intuition Simpl.
  (* rlwinm ; andimm *)
  set (rs1 := nextinstr (rs#r1 <- (Val.rolm rs#r2 amount Int.mone))).
  destruct (andimm_base_correct r1 r1 mask k rs1 m) as [rs' [A [B [C D]]]]; auto.
  exists rs'.
  split. eapply exec_straight_step; eauto. auto. auto.
  split. rewrite B. unfold rs1. rewrite nextinstr_inv; auto with asmgen.
  rewrite Pregmap.gss. destruct (rs r2); simpl; auto.
  unfold Int.rolm. rewrite Int.and_assoc.
  decEq; decEq; decEq. rewrite Int.and_commut. apply Int.and_mone.
  intros. rewrite D; auto. unfold rs1; Simpl.
Qed.

(** Indexed memory loads. *)

Lemma loadind_correct:
  forall (base: ireg) ofs ty dst k (rs: regset) m v c,
  loadind base ofs ty dst k = OK c ->
  Mem.loadv (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) = Some v ->
  base <> GPR0 ->
  exists rs',
     exec_straight ge fn c rs m k rs' m
  /\ rs'#(preg_of dst) = v
  /\ forall r, r <> PC -> r <> preg_of dst -> r <> GPR0 -> rs'#r = rs#r.
Proof.
Opaque Int.eq.
  unfold loadind; intros. destruct ty; monadInv H; simpl in H0.
(* integer *)
  rewrite (ireg_of_eq _ _ EQ).
  destruct (Int.eq (high_s ofs) Int.zero).
  (* one load *)
  econstructor; split. apply exec_straight_one. simpl.
  unfold load1. rewrite gpr_or_zero_not_zero; auto. simpl. rewrite H0. eauto. auto.
  intuition Simpl.
  (* loadimm + load *)
  exploit (loadimm_correct GPR0 ofs); eauto. intros [rs' [A [B C]]].
  exists (nextinstr (rs'#x <- v)); split.
  eapply exec_straight_trans. eexact A. apply exec_straight_one; auto.
  simpl. unfold load2. rewrite C; auto with asmgen. rewrite B. rewrite H0. auto.
  intuition Simpl.
(* float *)
  rewrite (freg_of_eq _ _ EQ).
  destruct (Int.eq (high_s ofs) Int.zero).
  (* one load *)
  econstructor; split. apply exec_straight_one. simpl.
  unfold load1. rewrite gpr_or_zero_not_zero; auto. simpl. rewrite H0. eauto. auto.
  intuition Simpl.
  (* loadimm + load *)
  exploit (loadimm_correct GPR0 ofs); eauto. intros [rs' [A [B C]]].
  exists (nextinstr (rs'#x <- v)); split.
  eapply exec_straight_trans. eexact A. apply exec_straight_one; auto.
  simpl. unfold load2. rewrite C; auto with asmgen. rewrite B. rewrite H0. auto.
  intuition Simpl.
Qed.

(** Indexed memory stores. *)

Lemma storeind_correct:
  forall (base: ireg) ofs ty src k (rs: regset) m m' c,
  storeind src base ofs ty k = OK c ->
  Mem.storev (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) (rs#(preg_of src)) = Some m' ->
  base <> GPR0 ->
  exists rs',
     exec_straight ge fn c rs m k rs' m'
  /\ forall r, r <> PC -> r <> GPR0 -> rs'#r = rs#r.
Proof.
  unfold storeind; intros.
  assert (preg_of src <> GPR0) by auto with asmgen.
  destruct ty; monadInv H; simpl in H0.
(* integer *)
  rewrite (ireg_of_eq _ _ EQ) in *.
  destruct (Int.eq (high_s ofs) Int.zero).
  (* one store *)
  econstructor; split. apply exec_straight_one. simpl.
  unfold store1. rewrite gpr_or_zero_not_zero; auto. simpl. rewrite H0. eauto. auto.
  intros; Simpl.
  (* loadimm + store *)
  exploit (loadimm_correct GPR0 ofs); eauto. intros [rs' [A [B C]]].
  exists (nextinstr rs'); split.
  eapply exec_straight_trans. eexact A. apply exec_straight_one; auto.
  simpl. unfold store2. rewrite B. rewrite ! C; auto with asmgen. rewrite H0. auto.
  intuition Simpl.
(* float *)
  rewrite (freg_of_eq _ _ EQ) in *.
  destruct (Int.eq (high_s ofs) Int.zero).
  (* one store *)
  econstructor; split. apply exec_straight_one. simpl.
  unfold store1. rewrite gpr_or_zero_not_zero; auto. simpl. rewrite H0. eauto. auto.
  intuition Simpl.
  (* loadimm + store *)
  exploit (loadimm_correct GPR0 ofs); eauto. intros [rs' [A [B C]]].
  exists (nextinstr rs'); split.
  eapply exec_straight_trans. eexact A. apply exec_straight_one; auto.
  simpl. unfold store2. rewrite B. rewrite ! C; auto with asmgen. rewrite H0. auto.
  intuition Simpl.
Qed.

(** Float comparisons. *)

Lemma floatcomp_correct:
  forall cmp (r1 r2: freg) k rs m,
  exists rs',
     exec_straight ge fn (floatcomp cmp r1 r2 k) rs m k rs' m
  /\ rs'#(reg_of_crbit (fst (crbit_for_fcmp cmp))) =
       (if snd (crbit_for_fcmp cmp)
        then Val.cmpf cmp rs#r1 rs#r2
        else Val.notbool (Val.cmpf cmp rs#r1 rs#r2))
  /\ forall r',
       r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 ->
       r' <> CR0_2 -> r' <> CR0_3 -> rs'#r' = rs#r'.
Proof.
  intros.
  generalize (compare_float_spec rs rs#r1 rs#r2).
  intros [A [B [C D]]].
  set (rs1 := nextinstr (compare_float rs rs#r1 rs#r2)) in *.
  assert ((cmp = Ceq \/ cmp = Cne \/ cmp = Clt \/ cmp = Cgt)
          \/ (cmp = Cle \/ cmp = Cge)).
    case cmp; tauto.
  unfold floatcomp.  elim H; intro; clear H.
  exists rs1.
  split. destruct H0 as [EQ|[EQ|[EQ|EQ]]]; subst cmp;
  apply exec_straight_one; reflexivity.
  split.
  destruct H0 as [EQ|[EQ|[EQ|EQ]]]; subst cmp; simpl; auto.
  rewrite Val.negate_cmpf_eq. auto.
  auto.
  (* two instrs *)
  exists (nextinstr (rs1#CR0_3 <- (Val.cmpf cmp rs#r1 rs#r2))).
  split. elim H0; intro; subst cmp.
  apply exec_straight_two with rs1 m.
  reflexivity. simpl.
  rewrite C; rewrite A. rewrite Val.or_commut. rewrite <- Val.cmpf_le.
  reflexivity. reflexivity. reflexivity.
  apply exec_straight_two with rs1 m.
  reflexivity. simpl.
  rewrite C; rewrite B. rewrite Val.or_commut. rewrite <- Val.cmpf_ge.
  reflexivity. reflexivity. reflexivity.
  split. elim H0; intro; subst cmp; simpl.
  reflexivity.
  reflexivity.
  intros. Simpl.
Qed.

(** Translation of conditions. *)

Ltac ArgsInv :=
  repeat (match goal with
  | [ H: Error _ = OK _ |- _ ] => discriminate
  | [ H: match ?args with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct args
  | [ H: bind _ _ = OK _ |- _ ] => monadInv H
  | [ H: match _ with left _ => _ | right _ => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv
  | [ H: match _ with true => _ | false => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv
  end);
  subst;
  repeat (match goal with
  | [ H: ireg_of _ = OK _ |- _ ] => simpl in *; rewrite (ireg_of_eq _ _ H) in *
  | [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in *
  end).

Lemma transl_cond_correct_1:
  forall cond args k rs m c,
  transl_cond cond args k = OK c ->
  exists rs',
     exec_straight ge fn c rs m k rs' m
  /\ rs'#(reg_of_crbit (fst (crbit_for_cond cond))) =
       (if snd (crbit_for_cond cond)
        then Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)
        else Val.notbool (Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)))
  /\ forall r, data_preg r = true -> rs'#r = rs#r.
Proof.
  intros.
Opaque Int.eq.
  unfold transl_cond in H; destruct cond; ArgsInv; simpl.
  (* Ccomp *)
  fold (Val.cmp c0 (rs x) (rs x0)).
  destruct (compare_sint_spec rs (rs x) (rs x0)) as [A [B [C D]]].
  econstructor; split.
  apply exec_straight_one. simpl; reflexivity. reflexivity.
  split.
  case c0; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto.
  auto with asmgen.
  (* Ccompu *)
  fold (Val.cmpu (Mem.valid_pointer m) c0 (rs x) (rs x0)).
  destruct (compare_uint_spec rs m (rs x) (rs x0)) as [A [B [C D]]].
  econstructor; split.
  apply exec_straight_one. simpl; reflexivity. reflexivity.
  split.
  case c0; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto.
  auto with asmgen.
  (* Ccompimm *)
  fold (Val.cmp c0 (rs x) (Vint i)).
  destruct (Int.eq (high_s i) Int.zero); inv EQ0.
  destruct (compare_sint_spec rs (rs x) (Vint i)) as [A [B [C D]]].
  econstructor; split.
  apply exec_straight_one. simpl; reflexivity. reflexivity.
  split.
  case c0; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto.
  auto with asmgen.
  destruct (loadimm_correct GPR0 i (Pcmpw x GPR0 :: k) rs m) as [rs1 [EX1 [RES1 OTH1]]].
  destruct (compare_sint_spec rs1 (rs x) (Vint i)) as [A [B [C D]]].
  assert (SAME: rs1 x = rs x) by (apply OTH1; eauto with asmgen).
  exists (nextinstr (compare_sint rs1 (rs1 x) (Vint i))).
  split. eapply exec_straight_trans. eexact EX1.
  apply exec_straight_one. simpl. rewrite RES1; rewrite SAME; auto.
  reflexivity.
  split. rewrite SAME.
  case c0; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto.
  intros. rewrite SAME; rewrite D; auto with asmgen.
  (* Ccompuimm *)
  fold (Val.cmpu (Mem.valid_pointer m) c0 (rs x) (Vint i)).
  destruct (Int.eq (high_u i) Int.zero); inv EQ0.
  destruct (compare_uint_spec rs m (rs x) (Vint i)) as [A [B [C D]]].
  econstructor; split.
  apply exec_straight_one. simpl; reflexivity. reflexivity.
  split.
  case c0; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto.
  auto with asmgen.
  destruct (loadimm_correct GPR0 i (Pcmplw x GPR0 :: k) rs m) as [rs1 [EX1 [RES1 OTH1]]].
  destruct (compare_uint_spec rs1 m (rs x) (Vint i)) as [A [B [C D]]].
  assert (SAME: rs1 x = rs x) by (apply OTH1; eauto with asmgen).
  exists (nextinstr (compare_uint rs1 m (rs1 x) (Vint i))).
  split. eapply exec_straight_trans. eexact EX1.
  apply exec_straight_one. simpl. rewrite RES1; rewrite SAME; auto.
  reflexivity.
  split. rewrite SAME.
  case c0; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto.
  intros. rewrite SAME; rewrite D; auto with asmgen.
  (* Ccompf *)
  fold (Val.cmpf c0 (rs x) (rs x0)).
  destruct (floatcomp_correct c0 x x0 k rs m) as [rs' [EX [RES OTH]]].
  exists rs'. split. auto.
  split. apply RES.
  auto with asmgen.
  (* Cnotcompf *)
  rewrite Val.notbool_negb_3. rewrite Val.notbool_idem4.
  fold (Val.cmpf c0 (rs x) (rs x0)).
  destruct (floatcomp_correct c0 x x0 k rs m) as [rs' [EX [RES OTH]]].
  exists rs'. split. auto.
  split. rewrite RES. destruct (snd (crbit_for_fcmp c0)); auto.
  auto with asmgen.
  (* Cmaskzero *)
  destruct (andimm_base_correct GPR0 x i k rs m) as [rs' [A [B [C D]]]].
  eauto with asmgen.
  exists rs'. split. assumption.
  split. rewrite C. destruct (rs x); auto.
  auto with asmgen.
  (* Cmasknotzero *)
  destruct (andimm_base_correct GPR0 x i k rs m) as [rs' [A [B [C D]]]].
  eauto with asmgen.
  exists rs'. split. assumption.
  split. rewrite C. destruct (rs x); auto.
  fold (option_map negb (Some (Int.eq (Int.and i0 i) Int.zero))).
  rewrite Val.notbool_negb_3. rewrite Val.notbool_idem4. auto.
  auto with asmgen.
Qed.

Lemma transl_cond_correct_2:
  forall cond args k rs m b c,
  transl_cond cond args k = OK c ->
  eval_condition cond (map rs (map preg_of args)) m = Some b ->
  exists rs',
     exec_straight ge fn c rs m k rs' m
  /\ rs'#(reg_of_crbit (fst (crbit_for_cond cond))) =
       (if snd (crbit_for_cond cond)
        then Val.of_bool b
        else Val.notbool (Val.of_bool b))
  /\ forall r, data_preg r = true -> rs'#r = rs#r.
Proof.
  intros.
  replace (Val.of_bool b)
  with (Val.of_optbool (eval_condition cond rs ## (preg_of ## args) m)).
  eapply transl_cond_correct_1; eauto.
  rewrite H0; auto.
Qed.

Lemma transl_cond_correct_3:
  forall cond args k ms sp rs m b m' c,
  transl_cond cond args k = OK c ->
  agree ms sp rs ->
  eval_condition cond (map ms args) m = Some b ->
  Mem.extends m m' ->
  exists rs',
     exec_straight ge fn c rs m' k rs' m'
  /\ rs'#(reg_of_crbit (fst (crbit_for_cond cond))) =
       (if snd (crbit_for_cond cond)
        then Val.of_bool b
        else Val.notbool (Val.of_bool b))
  /\ agree ms sp rs'.
Proof.
  intros.
  exploit transl_cond_correct_2. eauto.
    eapply eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto.
  intros [rs' [A [B C]]].
  exists rs'; split. eauto. split. auto. apply agree_exten with rs; auto.
Qed.

(** Translation of condition operators *)

Remark add_carry_eq0:
  forall i,
  Vint (Int.add (Int.add (Int.sub Int.zero i) i)
                (Int.add_carry Int.zero (Int.xor i Int.mone) Int.one)) =
  Val.of_bool (Int.eq i Int.zero).
Proof.
  intros. rewrite <- Int.sub_add_l. rewrite Int.add_zero_l.
  rewrite Int.sub_idem. rewrite Int.add_zero_l. fold (Int.not i).
  predSpec Int.eq Int.eq_spec i Int.zero.
  subst i. reflexivity.
  unfold Val.of_bool, Vfalse. decEq.
  unfold Int.add_carry. rewrite Int.unsigned_zero. rewrite Int.unsigned_one.
  apply zlt_true.
  generalize (Int.unsigned_range (Int.not i)); intro.
  assert (Int.unsigned (Int.not i) <> Int.modulus - 1).
    red; intros.
    assert (Int.repr (Int.unsigned (Int.not i)) = Int.mone).
Local Transparent Int.repr.
      rewrite H1. apply Int.mkint_eq. reflexivity.
   rewrite Int.repr_unsigned in H2.
   assert (Int.not (Int.not i) = Int.zero).
   rewrite H2. apply Int.mkint_eq; reflexivity.
  rewrite Int.not_involutive in H3.
  congruence.
  omega.
Qed.

Remark add_carry_ne0:
  forall i,
  Vint (Int.add (Int.add i (Int.xor (Int.add i Int.mone) Int.mone))
                (Int.add_carry i Int.mone Int.zero)) =
  Val.of_bool (negb (Int.eq i Int.zero)).
Proof.
  intros. fold (Int.not (Int.add i Int.mone)). rewrite Int.not_neg.
  rewrite (Int.add_commut  (Int.neg (Int.add i Int.mone))).
  rewrite <- Int.sub_add_opp. rewrite Int.sub_add_r. rewrite Int.sub_idem.
  rewrite Int.add_zero_l. rewrite Int.add_neg_zero. rewrite Int.add_zero_l.
Transparent Int.eq.
  unfold Int.add_carry, Int.eq.
  rewrite Int.unsigned_zero.  rewrite Int.unsigned_mone.
  unfold negb, Val.of_bool, Vtrue, Vfalse.
  destruct (zeq (Int.unsigned i) 0); decEq.
  apply zlt_true. omega.
  apply zlt_false. generalize (Int.unsigned_range i). omega.
Qed.

Lemma transl_cond_op_correct:
  forall cond args r k rs m c,
  transl_cond_op cond args r k = OK c ->
  exists rs',
     exec_straight ge fn c rs m k rs' m
  /\ rs'#(preg_of r) = Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)
  /\ forall r', data_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r'.
Proof.
  intros until args. unfold transl_cond_op.
  destruct (classify_condition cond args); intros; monadInv H; simpl;
  erewrite ! ireg_of_eq; eauto.
(* eq 0 *)
  econstructor; split.
  eapply exec_straight_two; simpl; reflexivity.
  split. Simpl. destruct (rs x0); simpl; auto.
  apply add_carry_eq0.
  intros; Simpl.
(* ne 0 *)
  econstructor; split.
  eapply exec_straight_two; simpl; reflexivity.
  rewrite gpr_or_zero_not_zero; eauto with asmgen.
  split. Simpl. destruct (rs x0); simpl; auto.
  apply add_carry_ne0.
  intros; Simpl.
(* ge 0 *)
  econstructor; split.
  eapply exec_straight_two; simpl; reflexivity.
  split. Simpl. rewrite Val.rolm_ge_zero. auto.
  intros; Simpl.
(* lt 0 *)
  econstructor; split.
  apply exec_straight_one; simpl; reflexivity.
  split. Simpl. rewrite Val.rolm_lt_zero. auto.
  intros; Simpl.
(* default *)
  set (bit := fst (crbit_for_cond c)) in *.
  set (isset := snd (crbit_for_cond c)) in *.
  set (k1 :=
        Pmfcrbit x bit ::
        (if isset
         then k
         else Pxori x x (Cint Int.one) :: k)).
  generalize (transl_cond_correct_1 c rl k1 rs m c0 EQ0).
  fold bit; fold isset.
  intros [rs1 [EX1 [RES1 AG1]]].
  destruct isset.
  (* bit set *)
  econstructor; split.  eapply exec_straight_trans. eexact EX1.
  unfold k1. apply exec_straight_one; simpl; reflexivity.
  intuition Simpl.
  (* bit clear *)
  econstructor; split.  eapply exec_straight_trans. eexact EX1.
  unfold k1. eapply exec_straight_two; simpl; reflexivity.
  intuition Simpl.
  rewrite RES1. destruct (eval_condition c rs ## (preg_of ## rl) m). destruct b; auto. auto.
Qed.

(** Translation of arithmetic operations. *)

Ltac TranslOpSimpl :=
  econstructor; split;
  [ apply exec_straight_one; [simpl; eauto | reflexivity]
  | split; intros; Simpl; fail ].

Lemma transl_op_correct_aux:
  forall op args res k (rs: regset) m v c,
  transl_op op args res k = OK c ->
  eval_operation ge (rs#GPR1) op (map rs (map preg_of args)) m = Some v ->
  exists rs',
     exec_straight ge fn c rs m k rs' m
  /\ rs'#(preg_of res) = v
  /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r.
Proof.
Opaque Int.eq.
  intros. unfold transl_op in H; destruct op; ArgsInv; simpl in H0; try (inv H0); try TranslOpSimpl.
  (* Omove *)
  destruct (preg_of res) eqn:RES; destruct (preg_of m0) eqn:ARG; inv H.
  TranslOpSimpl.
  TranslOpSimpl.
  (* Ointconst *)
  destruct (loadimm_correct x i k rs m) as [rs' [A [B C]]].
  exists rs'. auto with asmgen.
  (* Oaddrsymbol *)
  change (symbol_address ge i i0) with (symbol_offset ge i i0).
  set (v' := symbol_offset ge i i0).
  destruct (symbol_is_small_data i i0) eqn:SD.
  (* small data *)
  econstructor; split. apply exec_straight_one; simpl; reflexivity.
  split. Simpl. rewrite (small_data_area_addressing _ _ _ SD). unfold v', symbol_offset.
  destruct (Genv.find_symbol ge i); auto. rewrite Int.add_zero; auto.
  intros; Simpl.
  (* not small data *)
Opaque Val.add.
  econstructor; split. eapply exec_straight_two; simpl; reflexivity.
  split. Simpl. rewrite gpr_or_zero_zero.
  rewrite gpr_or_zero_not_zero; eauto with asmgen. Simpl.
  rewrite (Val.add_commut Vzero). rewrite high_half_zero.
  rewrite Val.add_commut. rewrite low_high_half. auto.
  intros; Simpl.
  (* Oaddrstack *)
  destruct (addimm_correct x GPR1 i k rs m) as [rs' [EX [RES OTH]]]; eauto with asmgen.
  exists rs'; auto with asmgen.
  (* Oaddimm *)
  destruct (addimm_correct x0 x i k rs m) as [rs' [A [B C]]]; eauto with asmgen.
  exists rs'; auto with asmgen.
  (* Osubimm *)
  case (Int.eq (high_s i) Int.zero).
  TranslOpSimpl.
  destruct (loadimm_correct GPR0 i (Psubfc x0 x GPR0 :: k) rs m) as [rs1 [EX [RES OTH]]].
  econstructor; split.
  eapply exec_straight_trans. eexact EX. apply exec_straight_one; simpl; reflexivity.
  split. Simpl. rewrite RES. rewrite OTH; eauto with asmgen.
  intros; Simpl.
  (* Omulimm *)
  case (Int.eq (high_s i) Int.zero).
  TranslOpSimpl.
  destruct (loadimm_correct GPR0 i (Pmullw x0 x GPR0 :: k) rs m) as [rs1 [EX [RES OTH]]].
  econstructor; split.
  eapply exec_straight_trans. eexact EX. apply exec_straight_one; simpl; reflexivity.
  split. Simpl. rewrite RES. rewrite OTH; eauto with asmgen.
  intros; Simpl.
  (* Odivs *)
  replace v with (Val.maketotal (Val.divs (rs x) (rs x0))).
  TranslOpSimpl.
  rewrite H1; auto.
  (* Odivu *)
  replace v with (Val.maketotal (Val.divu (rs x) (rs x0))).
  TranslOpSimpl.
  rewrite H1; auto.
  (* Oand *)
  set (v' := Val.and (rs x) (rs x0)) in *.
  pose (rs1 := rs#x1 <- v').
  destruct (compare_sint_spec rs1 v' Vzero) as [A [B [C D]]].
  econstructor; split. apply exec_straight_one; simpl; reflexivity.
  split. rewrite D; auto with asmgen. unfold rs1; Simpl.
  intros. rewrite D; auto with asmgen. unfold rs1; Simpl.
  (* Oandimm *)
  destruct (andimm_correct x0 x i k rs m) as [rs' [A [B C]]]; eauto with asmgen.
  (* Oorimm *)
  destruct (orimm_correct x0 x i k rs m) as [rs' [A [B C]]].
  exists rs'; auto with asmgen.
  (* Oxorimm *)
  destruct (xorimm_correct x0 x i k rs m) as [rs' [A [B C]]].
  exists rs'; auto with asmgen.
  (* Onor *)
  replace (Val.notint (rs x))
     with (Val.notint (Val.or (rs x) (rs x))).
  TranslOpSimpl.
  destruct (rs x); simpl; auto. rewrite Int.or_idem. auto.
  (* Oshrximm *)
  econstructor; split.
  eapply exec_straight_two; simpl; reflexivity.
  split. Simpl. apply Val.shrx_carry. auto.
  intros; Simpl.
  (* Orolm *)
  destruct (rolm_correct x0 x i i0 k rs m) as [rs' [A [B C]]]; eauto with asmgen.
  (* Ointoffloat *)
  replace v with (Val.maketotal (Val.intoffloat (rs x))).
  TranslOpSimpl.
  rewrite H1; auto.
  (* Ocmp *)
  destruct (transl_cond_op_correct c0 args res k rs m c) as [rs' [A [B C]]]; auto.
  exists rs'; auto with asmgen.
Qed.

Lemma transl_op_correct:
  forall op args res k ms sp rs m v m' c,
  transl_op op args res k = OK c ->
  agree ms sp rs ->
  eval_operation ge sp op (map ms args) m = Some v ->
  Mem.extends m m' ->
  exists rs',
     exec_straight ge fn c rs m' k rs' m'
  /\ agree (Regmap.set res v (Mach.undef_regs (destroyed_by_op op) ms)) sp rs'
  /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r.
Proof.
  intros.
  exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eauto.
  intros [v' [A B]].  rewrite (sp_val _ _ _ H0) in A.
  exploit transl_op_correct_aux; eauto. intros [rs' [P [Q R]]].
  rewrite <- Q in B.
  exists rs'; split. eexact P.
  split. apply agree_set_undef_mreg with rs; auto.
  auto.
Qed.

(** Translation of memory accesses *)

Lemma transl_memory_access_correct:
  forall (P: regset -> Prop) mk1 mk2 addr args temp k c (rs: regset) a m m',
  transl_memory_access mk1 mk2 addr args temp k = OK c ->
  eval_addressing ge (rs#GPR1) addr (map rs (map preg_of args)) = Some a ->
  temp <> GPR0 ->
  (forall cst (r1: ireg) (rs1: regset) k,
    Val.add (gpr_or_zero rs1 r1) (const_low ge cst) = a ->
    (forall r, r <> PC -> r <> temp -> rs1 r = rs r) ->
    exists rs',
        exec_straight ge fn (mk1 cst r1 :: k) rs1 m k rs' m' /\ P rs') ->
  (forall (r1 r2: ireg) (rs1: regset) k,
    Val.add rs1#r1 rs1#r2 = a ->
    (forall r, r <> PC -> r <> temp -> rs1 r = rs r) ->
    exists rs',
        exec_straight ge fn (mk2 r1 r2 :: k) rs1 m k rs' m' /\ P rs') ->
  exists rs',
      exec_straight ge fn c rs m k rs' m' /\ P rs'.
Proof.
  intros until m'; intros TR ADDR TEMP MK1 MK2.
  unfold transl_memory_access in TR; destruct addr; ArgsInv; simpl in ADDR; inv ADDR.
  (* Aindexed *)
  case (Int.eq (high_s i) Int.zero).
  (* Aindexed short *)
  apply MK1. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto.
  (* Aindexed long *)
  set (rs1 := nextinstr (rs#temp <- (Val.add (rs x) (Vint (Int.shl (high_s i) (Int.repr 16)))))).
  exploit (MK1 (Cint (low_s i)) temp rs1 k).
    simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen.
    unfold rs1; Simpl. rewrite Val.add_assoc.
Transparent Val.add.
    simpl. rewrite low_high_s. auto.
    intros; unfold rs1; Simpl.
  intros [rs' [EX' AG']].
  exists rs'. split. apply exec_straight_step with rs1 m.
  simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto.
  auto. auto.
  (* Aindexed2 *)
  apply MK2; auto.
  (* Aglobal *)
  destruct (symbol_is_small_data i i0) eqn:SISD; inv TR.
  (* Aglobal from small data *)
  apply MK1. simpl. rewrite small_data_area_addressing; auto.
  unfold symbol_address, symbol_offset.
  destruct (Genv.find_symbol ge i); auto. rewrite Int.add_zero. auto.
  auto.
  (* Aglobal general case *)
  set (rs1 := nextinstr (rs#temp <- (const_high ge (Csymbol_high i i0)))).
  exploit (MK1 (Csymbol_low i i0) temp rs1 k).
    simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen.
    unfold rs1. Simpl.
    unfold const_high, const_low.
    rewrite Val.add_commut. rewrite low_high_half. auto.
    intros; unfold rs1; Simpl.
  intros [rs' [EX' AG']].
  exists rs'. split. apply exec_straight_step with rs1 m.
  unfold exec_instr. rewrite gpr_or_zero_zero.
  rewrite Val.add_commut. unfold const_high.
  rewrite high_half_zero.
  reflexivity. reflexivity.
  assumption. assumption.
  (* Abased *)
  set (rs1 := nextinstr (rs#temp <- (Val.add (rs x) (const_high ge (Csymbol_high i i0))))).
  exploit (MK1 (Csymbol_low i i0) temp rs1 k).
    simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen.
    unfold rs1. Simpl.
    rewrite Val.add_assoc.
    unfold const_high, const_low.
    symmetry. rewrite Val.add_commut. f_equal. f_equal.
    rewrite Val.add_commut. rewrite low_high_half. auto.
    intros; unfold rs1; Simpl.
  intros [rs' [EX' AG']].
  exists rs'. split. apply exec_straight_step with rs1 m.
  unfold exec_instr. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto.
  assumption. assumption.
  (* Ainstack *)
  destruct (Int.eq (high_s i) Int.zero); inv TR.
  apply MK1. simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto.
  set (rs1 := nextinstr (rs#temp <- (Val.add rs#GPR1 (Vint (Int.shl (high_s i) (Int.repr 16)))))).
  exploit (MK1 (Cint (low_s i)) temp rs1 k).
    simpl. rewrite gpr_or_zero_not_zero; auto.
    unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss.
    rewrite Val.add_assoc. simpl. rewrite low_high_s. auto.
    congruence.
    intros. unfold rs1. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto.
  intros [rs' [EX' AG']].
  exists rs'. split. apply exec_straight_step with rs1 m.
  unfold exec_instr. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto.
  assumption. assumption.
Qed.

(** Translation of loads *)

Lemma transl_load_correct:
  forall chunk addr args dst k c (rs: regset) m a v,
  transl_load chunk addr args dst k = OK c ->
  eval_addressing ge (rs#GPR1) addr (map rs (map preg_of args)) = Some a ->
  Mem.loadv chunk m a = Some v ->
  exists rs',
     exec_straight ge fn c rs m k rs' m
  /\ rs'#(preg_of dst) = v
  /\ forall r, r <> PC -> r <> GPR12 -> r <> preg_of dst -> rs' r = rs r.
Proof.
  intros.
  assert (BASE: forall mk1 mk2 k' chunk' v',
  transl_memory_access mk1 mk2 addr args GPR12 k' = OK c ->
  Mem.loadv chunk' m a = Some v' ->
  (forall cst (r1: ireg) (rs1: regset),
    exec_instr ge fn (mk1 cst r1) rs1 m =
    load1 ge chunk' (preg_of dst) cst r1 rs1 m) ->
  (forall (r1 r2: ireg) (rs1: regset),
    exec_instr ge fn (mk2 r1 r2) rs1 m =
    load2 chunk' (preg_of dst) r1 r2 rs1 m) ->
  exists rs',
     exec_straight ge fn c rs m k' rs' m
  /\ rs'#(preg_of dst) = v'
  /\ forall r, r <> PC -> r <> GPR12 -> r <> preg_of dst -> rs' r = rs r).
  {
  intros. eapply transl_memory_access_correct; eauto. congruence.
  intros. econstructor; split. apply exec_straight_one.
  rewrite H4. unfold load1. rewrite H6. rewrite H3. eauto.
  unfold nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso; auto with asmgen.
  intuition Simpl.
  intros. econstructor; split. apply exec_straight_one.
  rewrite H5. unfold load2. rewrite H6. rewrite H3. eauto.
  unfold nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso; auto with asmgen.
  intuition Simpl.
  }
  destruct chunk; monadInv H.
- (* Mint8signed *)
  assert (exists v1, Mem.loadv Mint8unsigned m a = Some v1 /\ v = Val.sign_ext 8 v1).
  {
    destruct a; simpl in *; try discriminate.
    rewrite Mem.load_int8_signed_unsigned in H1.
    destruct (Mem.load Mint8unsigned m b (Int.unsigned i)); simpl in H1; inv H1.
    exists v0; auto.
  }
  destruct H as [v1 [LD SG]]. clear H1.
  exploit BASE; eauto; erewrite ireg_of_eq by eauto; auto.
  intros [rs1 [A [B C]]].
  econstructor; split.
  eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. auto.
  split. Simpl. congruence. intros. Simpl.
- (* Mint8unsigned *)
  eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mint816signed *)
  eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mint16unsigned *)
  eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mint32 *)
  eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mfloat32 *)
  eapply BASE; eauto; erewrite freg_of_eq by eauto; auto.
- (* Mfloat64 *)
  apply Mem.loadv_float64al32 in H1. eapply BASE; eauto; erewrite freg_of_eq by eauto; auto.
- (* Mfloat64al32 *)
  eapply BASE; eauto; erewrite freg_of_eq by eauto; auto.
Qed.

(** Translation of stores *)

Lemma transl_store_correct:
  forall chunk addr args src k c (rs: regset) m a m',
  transl_store chunk addr args src k = OK c ->
  eval_addressing ge (rs#GPR1) addr (map rs (map preg_of args)) = Some a ->
  Mem.storev chunk m a (rs (preg_of src)) = Some m' ->
  exists rs',
     exec_straight ge fn c rs m k rs' m'
  /\ forall r, r <> PC -> preg_notin r (destroyed_by_store chunk addr) -> rs' r = rs r.
Proof.
Local Transparent destroyed_by_store.
  intros.
  assert (TEMP0: int_temp_for src = GPR11 \/ int_temp_for src = GPR12).
    unfold int_temp_for. destruct (mreg_eq src R12); auto.
  assert (TEMP1: int_temp_for src <> GPR0).
    destruct TEMP0; congruence.
  assert (TEMP2: IR (int_temp_for src) <> preg_of src).
    unfold int_temp_for. destruct (mreg_eq src R12).
    subst src; simpl; congruence.
    change (IR GPR12) with (preg_of R12). red; intros; elim n.
    eapply preg_of_injective; eauto.
  assert (BASE: forall mk1 mk2 chunk',
  transl_memory_access mk1 mk2 addr args (int_temp_for src) k = OK c ->
  Mem.storev chunk' m a (rs (preg_of src)) = Some m' ->
  (forall cst (r1: ireg) (rs1: regset),
    exec_instr ge fn (mk1 cst r1) rs1 m =
    store1 ge chunk' (preg_of src) cst r1 rs1 m) ->
  (forall (r1 r2: ireg) (rs1: regset),
    exec_instr ge fn (mk2 r1 r2) rs1 m =
    store2 chunk' (preg_of src) r1 r2 rs1 m) ->
  exists rs',
     exec_straight ge fn c rs m k rs' m'
  /\ forall r, r <> PC -> r <> GPR11 /\ r <> GPR12 -> rs' r = rs r).
  {
  intros. eapply transl_memory_access_correct; eauto.
  intros. econstructor; split. apply exec_straight_one.
  rewrite H4. unfold store1. rewrite H6. rewrite H7; auto with asmgen. rewrite H3. eauto. auto.
  intros; Simpl. apply H7; auto. destruct TEMP0; destruct H9; congruence.
  intros. econstructor; split. apply exec_straight_one.
  rewrite H5. unfold store2. rewrite H6. rewrite H7; auto with asmgen. rewrite H3. eauto. auto.
  intros; Simpl. apply H7; auto. destruct TEMP0; destruct H9; congruence.
  }
  destruct chunk; monadInv H.
- (* Mint8signed *)
  assert (Mem.storev Mint8unsigned m a (rs (preg_of src)) = Some m').
    rewrite <- H1. destruct a; simpl; auto. symmetry. apply Mem.store_signed_unsigned_8.
  clear H1. eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mint8unsigned *)
  eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mint16signed *)
  assert (Mem.storev Mint16unsigned m a (rs (preg_of src)) = Some m').
    rewrite <- H1. destruct a; simpl; auto. symmetry. apply Mem.store_signed_unsigned_16.
  clear H1. eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mint16unsigned *)
  eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mint32 *)
  eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mfloat32 *)
  rewrite (freg_of_eq _ _ EQ) in H1.
  eapply transl_memory_access_correct. eauto. eauto. eauto.
  intros. econstructor; split. apply exec_straight_one.
  simpl. unfold store1. rewrite H. rewrite H2; auto with asmgen. rewrite H1. eauto. auto.
Local Transparent destroyed_by_store.
  simpl; intros. destruct H4 as [A [B C]]. Simpl. apply H2; auto with asmgen. destruct TEMP0; congruence.
  intros. econstructor; split. apply exec_straight_one.
  simpl. unfold store2. rewrite H. rewrite H2; auto with asmgen. rewrite H1. eauto. auto.
  simpl; intros. destruct H4 as [A [B C]]. Simpl. apply H2; auto with asmgen. destruct TEMP0; congruence.
- (* Mfloat64 *)
  apply Mem.storev_float64al32 in H1. eapply BASE; eauto; erewrite freg_of_eq by eauto; auto.
- (* Mfloat64al32 *)
  eapply BASE; eauto; erewrite freg_of_eq by eauto; auto.
Qed.

End CONSTRUCTORS.


(*
 * Copyright (c) 2017-present,
 * Programming Research Laboratory (ROPAS), Seoul National University, Korea
 * This software is distributed under the term of the BSD-3 clause license.
 *)
(** Lattice constructor: powerset.  *)

Set Implicit Arguments.

Require Import ZArith.
Require Import Morphisms SetoidList.
Require Import hpattern vgtac.
Require Import VocabA DFSetAVL DLat.

Module Type POW (A : KEY).
  Include LAT.
  Definition elt : Type := A.t.
  Parameter empty : t.
  Parameter is_empty : t -> bool.
  Parameter add : elt -> t -> t.
  Parameter add_mor : Proper (A.eq ==> eq ==> eq) add.
  Parameter mem : elt -> t -> bool.
  Parameter mem_mor : Proper (A.eq ==> eq ==> Logic.eq) mem.
  Parameter mem_join_false :
    forall l s1 s2 (Hl : mem l (join s1 s2) = false),
      mem l s1 = false /\ mem l s2 = false.
  Parameter mem_join_false_inv :
    forall l s1 s2 (H1 : mem l s1 = false) (H2 : mem l s2 = false),
      mem l (join s1 s2) = false.
  Parameter mem_add_false :
    forall l l' s (Hl : mem l (add l' s) = false), ~ (A.eq l l').
  Parameter le_mem_false :
    forall l ls ls' (Hsubset : le ls' ls) (Hmem : mem l ls = false),
      mem l ls' = false.
  Parameter le_mem_true :
    forall l ls ls' (Hsubset : le ls' ls) (Hmem : mem l ls' = true),
      mem l ls = true.
  Parameter singleton : elt -> t.
  Parameter singleton_1 :
    forall e1 e2 (Heq : A.eq e1 e2), mem e1 (singleton e2) = true.
  Parameter singleton_2 :
    forall e1 e2 (Hmem : mem e1 (singleton e2) = true), A.eq e1 e2.
  Parameter remove : elt -> t -> t.
  Parameter union : t -> t -> t.
  Parameter union_small_big : t -> t -> t.
  Parameter intersect : t -> t -> t.
  Parameter diff : t -> t -> t.
  Parameter subset : t -> t -> bool.
  Parameter filter : (elt -> bool) -> t -> t.
  Parameter fold : forall a, (elt -> a -> a) -> t -> a -> a.
  Parameter iter : (elt -> unit) -> t -> unit.
  Parameter elements : t -> list elt.
  Parameter cardinal : t -> nat.
  Parameter choose : t -> option elt.
  Parameter choose_only : t -> option elt.
  Parameter choose_only_1 :
    forall s e (Hce : choose_only s = Some e), elements s = cons e nil.
  Parameter choose_only_2 :
    forall l1 l2 l' (Hco : choose_only l' = Some l1) (Hmem : mem l2 l' = true),
      A.eq l1 l2.
  Parameter for_all : (elt -> unit) -> (elt -> bool) -> t -> bool.
  Parameter for_all_1 :
    forall k s print f (Hk: mem k s) (Hf: compat_bool A.eq f)
           (Hfor_all: for_all print f s = true),
      f k = true.
End POW.

Module Pow (A : KEY) <: LAT <: POW A.

Module SS := FSetAVL'.Make A.

Definition elt : Type := A.t.
Definition t : Type := SS.t.

(** * Lattice operations *)

Definition le (x y : t) : Prop := SS.Subset x y.

Definition eq (x y : t) : Prop := SS.eq x y.

Lemma le_refl : forall (x y : t) (Heq : eq x y), le x y.
Proof. unfold le, eq; i; intros e Hx. by apply Heq. Qed.

Lemma le_antisym : forall (x y : t) (le1 : le x y) (le2 : le y x), eq x y.
Proof. unfold le, eq; i; intro e; split; [apply le1|apply le2]. Qed.

Lemma le_trans : forall (x y z : t) (le1 : le x y) (le2 : le y z), le x z.
Proof. unfold le; i; intros e Hx; apply le2; by apply le1. Qed.

Lemma eq_refl : forall (x : t), eq x x.
Proof. by apply SS.eq_refl. Qed.

Lemma eq_sym : forall (x y : t) (Heq : eq x y), eq y x.
Proof. by apply SS.eq_sym. Qed.

Lemma eq_trans : forall (x y z : t) (eq1 : eq x y) (eq2 : eq y z), eq x z.
Proof. by apply SS.eq_trans. Qed.

Definition le_dec (x y : t) : {le x y} + {~ le x y}.
refine ((if physical_eq x y as c return
            physical_eq x y = c -> {le x y} + {~ le x y}
         then fun Hc => left _ else
           fun _ =>
             (if SS.subset x y as Bsub return
                 SS.subset x y = Bsub -> {le x y} + {~ le x y} then
                fun Hsub => left _
              else
                fun Hsub => right _) Logic.eq_refl) Logic.eq_refl); unfold le.
+ apply physical_eq_prop in Hc; subst; apply le_refl; by apply eq_refl.
+ by eauto using SS.subset_2.
+ i; apply SS.subset_1 in FH; by vauto.
Qed.

Definition eq_dec (x y : t) : {eq x y} + {~ eq x y}.
refine (match le_dec x y, le_dec y x with
          | left H1, left H2 => left _
          | _, _ => right _
        end).
- auto using le_antisym.
- intro; elim f. auto using le_refl, eq_sym.
- intro; elim f. auto using le_refl.
Qed.

Definition bot : t := SS.empty.

Lemma bot_prop : forall (x : t), le bot x.
Proof.
unfold le; i; destruct x.
apply SS.subset_2; unfold SS.subset, SS.MSet.subset; done.
Qed.

Definition join (x y : t) : t :=
  if le_dec x y then y else
  if le_dec y x then x else
    SS.union x y.

Lemma join_left : forall (x y : t), le x (join x y).
Proof.
  intros; unfold join.
  destruct (le_dec x y); auto.
  destruct (le_dec y x); [apply le_refl; apply eq_refl|].
  unfold le, SS.Subset. apply SS.union_2.
Qed.

Lemma join_right : forall (x y : t), le y (join x y).
Proof.
  intros; unfold join.
  destruct (le_dec x y); [apply le_refl; apply eq_refl|].
  destruct (le_dec y x); auto.
  unfold le, SS.Subset. apply SS.union_3.
Qed.

Lemma join_lub : forall (x y u : t) (Hx : le x u) (Hy : le y u), le (join x y) u.
Proof.
  i; unfold join; repeat dest_if_dec.
  unfold le, SS.Subset; intros a Hu.
  apply SS.union_1 in Hu; destruct Hu; auto using Hx, Hy.
Qed.

Definition meet (x y : t) : t :=
  if le_dec x y then x else
  if le_dec y x then y else
    SS.inter x y.

Lemma meet_left : forall (x y : t), le (meet x y) x.
Proof.
  intros; unfold meet.
  destruct (le_dec x y); [apply le_refl; apply eq_refl|].
  destruct (le_dec y x); auto.
  unfold le, SS.Subset. apply SS.inter_1.
Qed.

Lemma meet_right : forall (x y : t), le (meet x y) y.
Proof.
  intros; unfold meet.
  destruct (le_dec x y); auto.
  destruct (le_dec y x); [apply le_refl; apply eq_refl|].
  unfold le, SS.Subset. apply SS.inter_2.
Qed.

Lemma meet_glb : forall (x y l : t) (Hx : le l x) (Hy : le l y), le l (meet x y).
Proof.
  i; unfold meet; repeat dest_if_dec.
  unfold le, SS.Subset; intros a Hu.
  apply SS.inter_3; auto using Hx, Hy.
Qed.

Definition widen (x y : t) : t :=
  if structural_eq x y then x else
    SS.union x y.

Definition narrow (x y : t) : t :=
  if structural_eq x y then x else
    SS.inter x y.

Include JoinMeetProp.

(** * Functions for set *)

Definition empty : t := bot.

Definition is_empty := SS.is_empty.

Definition add (e : A.t) (x : t) : t := SS.add e x.

Lemma add_mor' : Proper (A.eq ==> le ==> le) add.
Proof. by apply SS.SF.add_s_m_Proper. Qed.

Lemma add_mor : Proper (A.eq ==> eq ==> eq) add.
Proof. by apply SS.SF.add_m. Qed.

Definition mem := SS.mem.

Definition elements := SS.elements.

Lemma mem_elements_1: forall (s : t) (x : elt) (Hin : In x (elements s)),
               mem x s = true.
Proof.
unfold mem, elements; i. rewrite SS.SF.elements_b.
induction (SS.elements s).
- inversion Hin.
- inversion Hin.
  + subst. s. apply Bool.orb_true_iff. left. unfold SS.SF.eqb.
    destruct (SS.E.eq_dec x x); [by auto|elim n; by apply SS.E.eq_refl].
  + s. apply Bool.orb_true_iff. right. by apply IHl.
Qed.

Lemma mem_elements_2: forall (s : t) (x : elt) (Hmem : mem x s = true),
                        exists x', A.eq x' x /\ In x' (elements s).
Proof.
unfold mem, elements. i. rewrite SS.SF.elements_b in Hmem.
induction (SS.elements s).
- by simpl in Hmem.
- simpl in Hmem. apply Bool.orb_true_iff in Hmem. destruct Hmem as [Hhd|Htl].
  + s. unfold SS.SF.eqb in Hhd. destruct (SS.E.eq_dec x a); [|by auto].
    exists a. split; [by apply A.eq_sym|by auto].
  + s. apply existsb_exists in Htl. destruct Htl as [x' [Hx'_in Hx'_eqb]].
    unfold SS.SF.eqb in Hx'_eqb. destruct (SS.E.eq_dec x x'); [|by auto].
    exists x'. split; [by apply A.eq_sym|by right].
Qed.

Lemma mem_monotone1 :
  forall k1 k2 (Hk : A.eq k1 k2) s1 s2 (Hs : le s1 s2) (Hmem : mem k1 s1 = true),
    mem k2 s2 = true.
Proof.
unfold le, mem; i.
apply SS.mem_1, SS.In_1 with k1; [by auto|]; apply Hs; by apply SS.mem_2.
Qed.

Lemma mem_monotone2 :
  forall k1 k2 (Hk : A.eq k1 k2) s1 s2 (Hs : le s1 s2) (Hmem : mem k2 s2 = false),
    mem k1 s1 = false.
Proof.
unfold mem; i.
apply SS.SF.not_mem_iff; apply SS.SF.not_mem_iff in Hmem.
intro Hmem'; elim Hmem.
apply SS.mem_2; apply SS.mem_1 in Hmem'.
eapply mem_monotone1; [by apply Hk|by apply Hs|by apply Hmem'].
Qed.

Lemma mem_mor : Proper (A.eq ==> eq ==> Logic.eq) mem.
Proof.
unfold Proper, respectful, eq, mem.
intros a1 a2 Ha s1 s2 Heq.
apply SS.SF.mem_m; [by auto|by apply Heq].
Qed.

Lemma mem_join_false :
  forall l s1 s2 (Hl : mem l (join s1 s2) = false),
    mem l s1 = false /\ mem l s2 = false.
Proof.
unfold mem, join; i.
destruct (le_dec s1 s2).
- split; [|by auto].
  unfold le in l0.
  apply SS.MF.not_mem_iff.
  apply SS.MF.not_mem_iff in Hl.
  intro; elim Hl.
  by apply l0.
- destruct (le_dec s2 s1).
  + split; [by auto|].
    unfold le in l0.
    apply SS.MF.not_mem_iff.
    apply SS.MF.not_mem_iff in Hl.
    intro; elim Hl.
    by apply l0.
  + rewrite SS.SF.union_b in Hl.
    by apply Bool.orb_false_iff.
Qed.

Lemma mem_join_false_inv :
  forall l s1 s2 (H1 : mem l s1 = false) (H2 : mem l s2 = false),
    mem l (join s1 s2) = false.
Proof.
i; unfold join.
destruct (le_dec s1 s2); [|destruct (le_dec s2 s1)]; unfold le in *.
- by auto.
- by auto.
- rewrite SS.SF.union_b; apply Bool.orb_false_iff; by auto.
Qed.

Lemma mem_join_left :
  forall l s1 s2 (Hs : mem l s1 = true), mem l (join s1 s2) = true.
Proof.
i. unfold join.
dest_if_dec; [eapply mem_monotone1; [by apply A.eq_refl|by apply l0|by auto]|].
dest_if_dec. eapply mem_monotone1; [by apply A.eq_refl| |by apply Hs].
intros a Ha; by apply SS.union_2.
Qed.

Lemma mem_join_right :
  forall l s1 s2 (Hs : mem l s2 = true), mem l (join s1 s2) = true.
Proof.
i. unfold join. dest_if_dec.
dest_if_dec; [eapply mem_monotone1; [by apply A.eq_refl|by apply l0|by auto]|].
 eapply mem_monotone1; [by apply A.eq_refl| |by apply Hs].
intros a Ha; by apply SS.union_3.
Qed.

Lemma mem_add_false :
  forall l l' s (Hl : mem l (add l' s) = false), ~ (A.eq l l').
Proof.
i; apply SS.MF.not_mem_iff in Hl; elim Hl.
apply SS.MF.add_iff.
left. by apply A.eq_sym.
Qed.

Lemma le_mem_false :
  forall l ls ls' (Hsubset : le ls' ls) (Hmem : mem l ls = false),
    mem l ls' = false.
Proof.
unfold le, mem; i.
apply SS.MF.not_mem_iff; intro Hmem'.
apply SS.MF.not_mem_iff in Hmem; elim Hmem.
by apply Hsubset.
Qed.

Lemma le_mem_true :
  forall l ls ls' (Hsubset : le ls' ls) (Hmem : mem l ls' = true),
    mem l ls = true.
Proof.
unfold le, mem; i.
apply SS.MF.mem_iff.
apply SS.MF.mem_iff in Hmem.
by apply Hsubset.
Qed.

Lemma mem_add_1 : forall l1 l2 s (Hl : A.eq l1 l2), mem l1 (add l2 s) = true.
Proof.
unfold mem, add; i. apply SS.MF.mem_iff.
apply SS.add_1. by apply A.eq_sym.
Qed.

Lemma mem_add_2 :
  forall l1 l2 s (Hl : not (A.eq l1 l2)), mem l1 (add l2 s) = mem l1 s.
Proof.
unfold mem, add; i. rewrite SS.SF.add_neq_b; [by auto|].
intro. elim Hl. by apply A.eq_sym.
Qed.

Lemma mem_add_3 :
  forall l1 l2 s (Hmem : mem l1 s = true), mem l1 (add l2 s) = true.
Proof.
i. destruct (A.eq_dec l1 l2); [by apply mem_add_1|by rewrite mem_add_2].
Qed.

Lemma empty_1 : forall e, mem e empty = false.
Proof. unfold mem, empty, bot. by apply SS.SF.empty_b. Qed.

Definition singleton (e : A.t) : t := SS.singleton e.

Lemma singleton_1 :
  forall e1 e2 (Heq : A.eq e1 e2), mem e1 (singleton e2) = true.
Proof.
unfold mem, singleton.
i. apply SS.OrigS.mem_1.
apply SS.OrigS.singleton_2.
by apply A.eq_sym.
Qed.

Lemma singleton_2 :
  forall e1 e2 (Hmem : mem e1 (singleton e2) = true), A.eq e1 e2.
Proof.
unfold mem, singleton. i.
by apply A.eq_sym, SS.OrigS.singleton_1, SS.OrigS.mem_2.
Qed.

Definition singleton_mor : Proper (A.eq ==> eq) singleton.
Proof.
intros a1 a2 Ha k; split; intros Hk.
- apply SS.MSF.P.Dec.F.mem_2.
  apply SS.MSF.P.Dec.F.mem_1 in Hk.
  apply singleton_2 in Hk.
  apply singleton_1.
  by apply A.eq_trans with a1.
- apply SS.MSF.P.Dec.F.mem_2.
  apply SS.MSF.P.Dec.F.mem_1 in Hk.
  apply singleton_2 in Hk.
  apply singleton_1.
  apply A.eq_trans with a2; [by auto|by apply A.eq_sym].
Qed.

Definition remove (e : A.t) (x : t) : t := SS.remove e x.
Definition union := SS.union.
Definition union_small_big small big := SS.fold SS.add small big.
Definition intersect := SS.inter.
Definition diff := SS.diff.
Definition subset := SS.subset.

Definition filter (f : A.t -> bool) (x : t) : t := SS.filter f x.

Lemma filter1 :
  forall x s f (Hf : Proper (A.eq ==> Logic.eq) f) (Hmem : mem x s = true)
     (Hx : f x = true),
    mem x (filter f s) = true.
Proof.
unfold mem, filter; i.
rewrite SS.mem_1; [by auto|].
eapply SS.filter_3; [by apply Hf|by apply SS.mem_2|by auto].
Qed.

Lemma filter2 :
  forall x s f (Hf : Proper (A.eq ==> Logic.eq) f) (Hx : f x = false),
    mem x (filter f s) = false.
Proof.
unfold mem, filter; i.
apply Bool.not_true_is_false; intro Hmem.
eapply Bool.eq_true_false_abs; [|by apply Hx].
eapply SS.filter_2; [by apply Hf|by apply SS.mem_2, Hmem].
Qed.

Definition fold := SS.fold.

Lemma fold_left_prsv (T U : Type) (P : T -> Prop) f :
  forall (Hf : forall e x (Hx : P x), P (f x e)) (l : list U) x (Hx : P x),
    P (fold_left f l x).
Proof.
induction l.
- by auto.
- s. i. apply IHl. apply Hf. by apply Hx.
Qed.

Lemma fold_left_prsv_strong (T U : Type) (P : T -> Prop) (Q : U -> Prop) f :
  forall (Hf : forall e (He : Q e) x (Hx : P x), P (f x e))
     (l : list U) (HQall : forall x : U, In x l -> Q x) x (Hx : P x),
    P (fold_left f l x).
Proof.
induction l.
- by auto.
- s. i. apply IHl.
  + i; apply HQall; by right.
  + apply Hf; [apply HQall; by left|by auto].
Qed.

Lemma fold_left_prsv2 (T1 T2 U : Type) (P : T1 -> T2 -> Prop) f1 f2:
  forall (Hf : forall v1 v2 (Hv : P v1 v2) (e : U), P (f1 v1 e) (f2 v2 e))
         l v1 v2 (Hv : P v1 v2),
    P (List.fold_left f1 l v1) (List.fold_left f2 l v2).
Proof.
induction l.
- by auto.
- s. i. apply IHl. apply Hf. by apply Hv.
Qed.

Lemma fold_2 (T : Type) (P Q: T -> Prop) f :
  forall e s (Hmem : mem e s = true)
         (He : forall (x : T) (Hx : P x), Q (f e x))
         (HP : forall e' (x : T) (Hx : P x), P (f e' x))
         (HQ : forall e' (x : T) (Hx : Q x), Q (f e' x))
         (Hf_eq : forall e1 e2 (He1 : A.eq e1 e2) (x : T) (He1 : Q (f e1 x)),
                    Q (f e2 x))
         (x : T) (Hx : P x),
    Q (fold f s x).
Proof.
unfold fold. intros. rewrite SS.fold_1.
apply mem_elements_2 in Hmem. destruct Hmem as [e' [Heq Hin]].
generalize dependent x. unfold elements in Hin. induction (SS.elements s).
- inversion Hin.
- s. inversion Hin.
  + subst. i. apply fold_left_prsv; [i; by apply HQ|].
    eapply Hf_eq; [apply A.eq_sym; by apply Heq|]; by auto.
  + i. apply IHl; [by auto|]. by apply HP.
Qed.

Lemma a_eq_equiv : Equivalence A.eq.
Proof.
constructor.
intros ?; by apply A.eq_refl.
intros ? ?; by apply A.eq_sym.
intros ? ? ?; by apply A.eq_trans.
Qed.

Lemma fold_2_strong (T : Type) (P Q: T -> Prop) f :
  forall e s (Hmem : mem e s = true)
         (He : forall (x : T) (Hx : P x), Q (f e x))
         (HP : forall e' (He' : ~ A.eq e e') (x : T) (Hx : P x), P (f e' x))
         (HQ : forall e' (He' : ~ A.eq e e') (x : T) (Hx : Q x), Q (f e' x))
         (Hf_eq : forall e1 e2 (He1 : A.eq e1 e2) (x : T) (He1 : Q (f e1 x)),
                    Q (f e2 x))
         (x : T) (Hx : P x),
    Q (fold f s x).
Proof.
unfold fold; i. rewrite SS.fold_1.
apply mem_elements_2 in Hmem. destruct Hmem as [e' [Heq Hin]].
unfold elements in Hin. assert (Hnodup := SS.elements_3w s).
generalize dependent x. induction (SS.elements s).
- inversion Hin.
- s. inversion Hin.
  + subst; i; apply fold_left_prsv_strong with (Q := fun e => ~ A.eq e' e).
    * i; apply HQ; [i; elim He0; by apply A.eq_trans with e|by auto].
    * i; inversion Hnodup; subst; elim H2.
      apply InA_eqA with x0; [by apply a_eq_equiv|by apply A.eq_sym|].
      apply In_InA; [by apply a_eq_equiv|by auto].
    * eapply Hf_eq; [apply A.eq_sym; by apply Heq|]; by auto.
  + i. apply IHl; [by auto|by inversion Hnodup|].
    apply HP; [|by auto]; i; inversion Hnodup; subst; elim H2.
    apply InA_eqA with e'; [by apply a_eq_equiv|by apply A.eq_trans with e|].
    apply In_InA; [by apply a_eq_equiv|by auto].
Qed.

Lemma fold_1 (T : Type) (P : T -> Prop) f :
  forall e s (Hmem : mem e s = true)
         (He : forall (x : T), P (f e x))
         (Hf_mono : forall e' (x : T) (Hx : P x), P (f e' x))
         (Hf_eq : forall e1 e2 (He1 : A.eq e1 e2) (x : T) (He1 : P (f e1 x)),
                    P (f e2 x))
         (x : T),
    P (fold f s x).
Proof.
i. apply fold_2 with (P:=fun _ => True) (e:=e) (s:=s); by auto.
Qed.

Lemma fold_3 (T : Type) (P : T -> Prop) f :
  forall s
         (Hf_mono : forall e x (He : mem e s = true) (Hx : P x), P (f e x))
         (x : T) (Hx : P x),
    P (fold f s x).
Proof.
unfold fold. i. rewrite SS.fold_1.
assert (forall e x (He : In e (SS.elements s)) (Hx : P x), P (f e x))
  as Hf_mono'
; [i; apply Hf_mono; [by apply mem_elements_1|by auto]|].
generalize x Hx Hf_mono'. clear x Hx Hf_mono'. induction (SS.elements s).
- by auto.
- s. i. apply IHl.
  + apply Hf_mono'; by auto.
  + i. apply Hf_mono'; by auto.
Qed.

Lemma fold2_1 :
  forall T (P : T -> T -> Prop)
         (P_trans : forall x y z, P x y -> P y z -> P x z)
         f f' i
         (Hf_ext : forall e x, P x (f e x))
         (Hff' : forall e x1 x2 (Hi : P i x1) (Hx : P x1 x2),
                   P (f e x1) (f' e x2))
         s (x1 x2 : T) (Hi : P i x1) (Hx : P x1 x2),
    P (fold f s x1) (fold f' s x2).
Proof.
unfold fold. i. do 2 rewrite SS.fold_1.
generalize x1 x2 Hi Hx; clear x1 x2 Hi Hx.
induction (SS.elements s); i; s.
- by apply Hx.
- apply IHl.
  + eapply P_trans; [by apply Hi|by apply Hf_ext].
  + by apply Hff'.
Qed.

Lemma fold2_3 :
  forall T Q (P : T -> Q -> Prop)
    f1 f2 (Hf : forall e1 e2 (He : A.eq e1 e2) t1 t2 (Ht : P t1 t2),
              P (f1 e1 t1) (f2 e2 t2))
    s1 s2 (Hs : eq s1 s2) i1 i2 (Hi : P i1 i2),
  P (fold f1 s1 i1) (fold f2 s2 i2).
Proof.
unfold fold. i. do 2 rewrite SS.fold_1. apply SS.elements_eq in Hs.
generalize i1 i2 Hi; clear i1 i2 Hi.
induction Hs.
- by auto.
- s; i; apply IHHs. by apply Hf.
Qed.

Lemma fold2_4 :
  forall T Q (P : T -> Q -> Prop)
     f1 f2 (Hf : forall e t1 t2 (Ht : P t1 t2), P (f1 e t1) (f2 e t2))
     s i1 i2 (Hi : P i1 i2),
  P (fold f1 s i1) (fold f2 s i2).
Proof.
unfold fold. i. do 2 rewrite SS.fold_1.
generalize i1 i2 Hi; clear i1 i2 Hi.
induction (SS.elements s).
- by auto.
- s; i; apply IHl; by apply Hf.
Qed.

Lemma fold2_5' :
  forall T Q (P : T -> Q -> Prop)
     (l : list elt) f1 f2
     (Hf : forall e (He : In e l) t1 t2 (Ht : P t1 t2),
         P (f1 e t1) (f2 e t2))
     i1 i2 (Hi : P i1 i2),
  P (fold_left (fun a e => f1 e a) l i1) (fold_left (fun a e => f2 e a) l i2).
Proof.
induction l.
- by auto.
- s; i; apply IHl.
  + i. apply Hf; [by right|by auto].
  + apply Hf; [by left|by auto].
Qed.

Lemma fold2_5 :
  forall T Q (P : T -> Q -> Prop)
     s f1 f2
     (Hf : forall e (He : mem e s = true) t1 t2 (Ht : P t1 t2),
         P (f1 e t1) (f2 e t2))
     i1 i2 (Hi : P i1 i2),
  P (fold f1 s i1) (fold f2 s i2).
Proof.
unfold fold. i. do 2 rewrite SS.fold_1.
apply fold2_5'; [|by auto].
i. apply Hf; [by apply mem_elements_1|by auto].
Qed.

Lemma fold2_2 :
  forall T (P : T -> T -> Prop)
    f1 f2 (Hf : forall e1 e2 (He : A.eq e1 e2) t1 t2 (Ht : P t1 t2),
              P (f1 e1 t1) (f2 e2 t2))
    s1 s2 (Hs : eq s1 s2) i1 i2 (Hi : P i1 i2),
  P (fold f1 s1 i1) (fold f2 s2 i2).
Proof. i; by apply fold2_3. Qed.

Lemma fold_mor (T : Type) :
  forall (teq : relation T) (teq_equiv : DLat.zb_equiv teq),
    let feq f1 f2 :=
      forall x1 x2 (Hx : A.eq x1 x2) acc1 acc2 (Hacc : teq acc1 acc2),
        teq (f1 x1 acc1) (f2 x2 acc2) in
    Proper (feq ==> eq ==> teq ==> teq) (@fold T).
Proof.
i; intros f1 f2 Hf s1 s2 Hs i1 i2 Hi.
apply fold2_2; [by apply Hf|by auto|by auto].
Qed.

Definition iter (f : A.t -> unit) (s : t) : unit :=
  SS.fold (fun x acc => (fun _ => acc) (f x)) s tt.

Lemma elements_eq :
  forall ls1 ls2 (Heq : eq ls1 ls2),
    eqlistA A.eq (elements ls1) (elements ls2).
Proof. by apply SS.elements_eq. Qed.

Definition cardinal := SS.cardinal.

Definition choose := SS.choose.

Lemma choose_mor : Proper (eq ==> opt_eq A.eq) choose.
Proof. by apply SS.choose_mor. Qed.

Definition choose_only := SS.choose_only.

Lemma choose_only_mor : Proper (eq ==> opt_eq A.eq) choose_only.
Proof. by apply SS.choose_only_mor. Qed.

Lemma choose_only_1 :
  forall s e (Hce : choose_only s = Some e), elements s = cons e nil.
Proof. by apply SS.choose_only_1. Qed.

Lemma choose_only_2 :
  forall l1 l2 l' (Hco : choose_only l' = Some l1) (Hmem : mem l2 l' = true),
    A.eq l1 l2.
Proof. by apply SS.choose_only_2. Qed.

Definition for_all := SS.for_all'.

Definition for_all_1 :
  forall k s print f (Hk: mem k s) (Hf: compat_bool A.eq f)
         (Hfor_all: for_all print f s = true),
    f k = true.
Proof.
i. rewrite SS.for_all'_1 in Hfor_all.
apply SS.for_all_2 in Hfor_all; [|by auto].
apply Hfor_all. by apply SS.OrigS.mem_2.
Qed.

End Pow.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Category.
Require Import Blech.Functor.
Require Import Blech.Category.Bsh.
Require Import Blech.Category.Funct.
Require Import Blech.Category.Prod.
Require Import Blech.Category.CoPSh.
Require Import Blech.Category.Op.
Require Import Blech.Functor.Curry.
Require Blech.Reflect.

Import CategoryNotations.
Import FunctorNotations.
Import BishopNotations.
Import ProdNotations.
Import OpNotations.

Open Scope category_scope.
Open Scope bishop_scope.

#[local]
Obligation Tactic := Reflect.category_simpl.

#[program]
 Definition CoYo C: Funct (C ᵒᵖ) (CoPSh C) := curry {|
  op (ab: (C ᵒᵖ) * C) := C (fst ab) (snd ab) /~ Mor_Setoid _ _ : Bsh ;
  map _ _ '(a, b) (f: C _ _) := (b: C _ _) ∘ f ∘ (a : C _ _) ;
|}.

Next Obligation.
Proof.
  cbn in *.
  intros ? ? p.
  rewrite p.
  reflexivity.
Qed.

Next Obligation.
Proof.
  exists.
  all: cbn.
  - intros.
    Reflect.category.
    reflexivity.
  - intros.
    Reflect.category.
    reflexivity.
  - intros ? ? ? ? [p q] ?.
    cbn in *.
    rewrite p, q.
    reflexivity.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj5synthconj2 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus Zero (mult lv0 lv1)) (mult lv1 lv0)).
Admitted.
QuickChick conj5synthconj2.


(* Tree on Ssreflect *)
Require Import
Ssreflect.ssreflect
Ssreflect.ssrfun
Ssreflect.ssrbool
Ssreflect.eqtype
Ssreflect.ssrnat
Ssreflect.seq.

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

Delimit Scope tree_scope with tree.
Open Scope tree_scope.

(** * Definition of [tree] and [forest] *)
Inductive tree (T: Type) :=
| node (x: T)(c: forest T)
with
forest (T: Type) :=
| leaf
| sibl (t: tree T)(f: forest T).
Arguments leaf {T}.

(** ** Notations *)
Infix "-:" := node (at level 60, no associativity): tree_scope.
Notation "[*]" := leaf: tree_scope.
Infix "~+" := sibl (at level 60, right associativity): tree_scope.
Notation "[~ X + .. + Y ~]" := (X ~+ ( .. (Y ~+ [*]) ..)) (at level 60, right associativity): tree_scope.

(** ** Induction principles  *)
Scheme tree_forest_ind := Induction for tree Sort Prop
  with forest_tree_ind := Induction for forest Sort Prop.
Scheme tree_forest_rec := Induction for tree Sort Set
  with forest_tree_rec := Induction for forest Sort Set.
Scheme tree_forest_rect := Induction for tree Sort Type
  with forest_tree_rect := Induction for forest Sort Type.

(** *** Mutual Induction Principle *)
Combined Scheme tree_forest_mut_ind from
         tree_forest_ind, forest_tree_ind.

(** ** map function  *)

Fixpoint map_tree {A B: Type}(F: A -> B)(t: tree A): tree B :=
  let (x, f) := t in F x -: map_forest F f with
map_forest {A B: Type}(F: A -> B)(f: forest A): forest B :=
  if f is t ~+ f' then map_tree F t ~+ map_forest F f' else [*].

(** * Traverse [tree] and [forest] by pre- and post- order *)
Section Traverse.

  Variables (T: Type).
  Implicit Type t : tree T.
  Implicit Type f : forest T.

  Fixpoint size_tree t: nat :=
    match t with
      | x -: f => (size_forest f).+1
    end with
  size_forest f: nat :=
    match f with
      | [*] => 0
      | t ~+ f => size_tree t + size_forest f
    end.

  Lemma size_tree_ltn0 t:
    0 < size_tree t.
  Proof.
    by move: t => [x f] //.
  Qed.

  Lemma size_forest0leaf f:
    size_forest f = 0 -> f = [*].
  Proof.
    move: f => [| t f] //= Heq.
    by move: Heq (ltn_addr (size_forest f) (size_tree_ltn0 t)) => <-; rewrite ltnn.
  Qed.

  Fixpoint cat_forest f1 f2 :=
    match f1 with
      | [*] => f2
      | t ~+ f => t ~+ (cat_forest f f2)
    end.
  Infix "+++" := cat_forest (at level 50, left associativity).

  Lemma cat_forest_leaf f:
    f +++ [*] = f.
  Proof.
    by elim: f => [| t f /= ->] //.
  Qed.

  Lemma cat_forest_app f1 f2 f3:
    (f1 +++ f2) +++ f3 = f1 +++ (f2 +++ f3).
  Proof.
    by elim: f1 => [| t f /= ->] //.
  Qed.

  Fixpoint rev_tree t :=
    match t with
      | x -: f => x -: rev_forest f
    end with
  rev_forest f :=
    match f with
      | [*] => [*]
      | t ~+ f => rev_forest f +++ (rev_tree t ~+[*])
    end.

  Lemma cat_rev_forest f1 f2:
    rev_forest (f1 +++ f2) = rev_forest f2 +++ rev_forest f1.
  Proof.
    by elim: f1 => [/= | t f /= ->] //;
      rewrite ?cat_forest_leaf ?cat_forest_app.
  Qed.

  Lemma rev_rev_id:
    (forall t, rev_tree (rev_tree t) = t)
    /\(forall f, rev_forest (rev_forest f) = f).
  Proof.
    apply: tree_forest_mut_ind.
    by move => a c //= ->.
    done.
    by move => t Heqt f Heqf //=; rewrite cat_rev_forest /= Heqt Heqf.
  Qed.

  Fixpoint preorder_tree t :=
    let: x -: f := t in [:: x & preorder_forest f ]
  with preorder_forest f :=
    if f is t ~+ f
    then preorder_tree t ++ preorder_forest f
    else [::].

  Lemma preorder_f_forest_cat f1 f2:
      preorder_forest (f1 +++ f2) = preorder_forest f1 ++ preorder_forest f2.
  Proof.
    by elim: f1 => [| t f /= ->] //; rewrite catA.
  Qed.

  Fixpoint postorder_tree t :=
    let: x -: f := t in rcons (postorder_forest f) x
  with postorder_forest f :=
    if f is t ~+ f
    then postorder_tree t ++ postorder_forest f
    else [::].

  Lemma pre_rev_eq_rev_post:
    (forall t, preorder_tree (rev_tree t) = rev (postorder_tree t))/\
    (forall f, preorder_forest (rev_forest f) = rev (postorder_forest f)).
  Proof.
    apply: tree_forest_mut_ind => [x c /= -> || /= t Heqt f Heqf] //;
      first by rewrite rev_rcons.
    by rewrite rev_cat -Heqt -Heqf preorder_f_forest_cat //= catA cats0.
  Qed.

  Lemma pre_rev_eq_rev_post_tree t:
    preorder_tree (rev_tree t) = rev (postorder_tree t).
  Proof.
    apply pre_rev_eq_rev_post.
  Qed.

  Lemma pre_rev_eq_rev_post_forest f:
    preorder_forest (rev_forest f) = rev (postorder_forest f).
  Proof.
    apply pre_rev_eq_rev_post.
  Qed.

End Traverse.

Infix "+++" := cat_forest (at level 50, left associativity).

Lemma tree_forest_mut_rect:
  forall (T: Type)(P : tree T -> Type) (Q : forest T -> Type),
    (forall (x : T) (c : forest T), Q c -> P (node x c)) ->
    Q leaf ->
    (forall t, P t -> forall f, Q f -> Q (sibl t f)) ->
    (forall t, P t) * (forall f, Q f).
Proof.
  move => T P Q IHn IHl IHs.
  exact (tree_forest_rect IHn IHl IHs, forest_tree_rect IHn IHl IHs).
Qed.

Section EqTree.

  Variable T: eqType.
  Implicit Type t : tree T.
  Implicit Type f : forest T.

  Fixpoint eqtree t1 t2 :=
    match t1, t2 with
      | x1-:c1, x2-:c2 => (x1 == x2) && (eqforest c1 c2)
    end with
  eqforest f1 f2 :=
    match f1, f2 with
      | [*], [*] => true
      | t1 ~+ f1, t2 ~+ f2 => (eqtree t1 t2) && (eqforest f1 f2)
      | _, _ => false
    end.

  Lemma eqtreeP_eqforestP:
    (Equality.axiom eqtree)*(Equality.axiom eqforest).
  Proof.
    apply: tree_forest_mut_rect
    => [x f IHf [x' f'] | [| t f] | t IHt f IHf [|t' f']] /=; try by constructor.
    - case: (x =P x') => [<- | Hneq]; last by right; case.
        by case: (IHf f') => [<- | Hneq] /=; [ left | right; case ].
    - move: (IHt t') => [<- | Hneq]; last by right; case.
        by move: (IHf f') => [<- | Hneq]; [left | right; case].
  Qed.

  Definition eqtreeP: Equality.axiom eqtree := fst eqtreeP_eqforestP.
  Definition eqforestP: Equality.axiom eqforest := snd eqtreeP_eqforestP.

  Canonical tree_eqMixin := EqMixin eqtreeP.
  Canonical tree_eqType :=  Eval hnf in EqType (tree T) (EqMixin eqtreeP).

  Lemma eqtreeE : eqtree = eq_op.
  Proof.
      by [].
  Qed.

  Canonical forest_eqMixin := EqMixin eqforestP.
  Canonical forest_eqType := Eval hnf in EqType (forest T) forest_eqMixin.

  Lemma eqforestE : eqforest = eq_op.
  Proof.
      by [].
  Qed.

  Lemma eqtree_node x1 x2 f1 f2:
    (x1 -: f1 == x2 -: f2) = (x1 == x2) && (f1 == f2).
  Proof.
      by [].
  Qed.

  Lemma eqforest_sibl t1 t2 f1 f2:
    (t1 ~+ f1 == t2 ~+ f2) = (t1 == t2) && (f1 == f2).
  Proof.
      by [].
  Qed.

  Fixpoint mem_tree (t: tree T): pred T :=
    match t with
      | node y f => xpredU1 y (mem_forest f)
    end
  with mem_forest (f: forest T): pred T :=
    match f with
      | leaf => xpred0
      | sibl t f => xpredU (mem_tree t) (mem_forest f)
    end.

  Definition eqtree_class := tree T.
  Identity Coercion tree_of_eqtree : eqtree_class >-> tree.

  Coercion pred_of_eq_tree (t : eqtree_class) : pred_class := [eta mem_tree t].
  Canonical tree_predType := @mkPredType T (tree T) pred_of_eq_tree.
  Canonical mem_tree_predType := mkPredType mem_tree.

  Definition eqforest_class := forest T.
  Identity Coercion forest_of_eqforest : eqforest_class >-> forest.

  Coercion pred_of_eq_forest (f : eqforest_class) : pred_class := [eta mem_forest f].
  Canonical forest_predType := @mkPredType T (forest T) pred_of_eq_forest.
  Canonical mem_forest_predType := mkPredType mem_forest.

  Lemma in_node y f x:
    (x \in node y f) = (x == y) || (x \in f).
  Proof.
    by [].
  Qed.

  Lemma in_leaf x:
    (x \in leaf) = false.
  Proof.
    by [].
  Qed.

  Lemma in_sibl x t f:
    (x \in sibl t f) = (x \in t) || (x \in f).
  Proof.
    by [].
  Qed.

  Lemma mem_tree1 x y:
    (x \in node y leaf) = (x == y).
  Proof.
    by rewrite in_node orbF //.
  Qed.

  Let inE := (mem_tree1, in_node, inE).

  Lemma mem_f_cat x f1 f2 :
    (x \in f1 +++ f2) = (x \in f1) || (x \in f2).
  Proof.
    elim: f1 => [//=| t f /= Heq].
    by rewrite in_sibl in_sibl Heq orbA //=.
  Qed.

End EqTree.
Definition inE := (mem_tree1, in_node, inE).

Section TravIn.

  Variables (T: eqType).
  Implicit Type t : tree T.
  Implicit Type f : forest T.

  Lemma traverse_correct_pre:
    (forall t x, (x \in t) == (x \in preorder_tree t))/\
    (forall f x, (x \in f) == (x \in preorder_forest f)).
  Proof.
    apply tree_forest_mut_ind.
    - move=> x f Heq y.
      by rewrite in_node in_cons; move: (Heq y) => /eqP ->.
    - move=> x //=.
    - move=> t Heqt f Heqf x /=.
      by rewrite in_sibl mem_cat; move: (Heqt x) (Heqf x) => /eqP -> /eqP ->.
  Qed.

  Theorem traverse_correct_pre_tree t x:
    (x \in t) == (x \in preorder_tree t).
  Proof.
    move: t x; apply traverse_correct_pre.
  Qed.

  Lemma traverse_correct_post:
    (forall t x, (x \in t) == (x \in postorder_tree t))/\
    (forall f x, (x \in f) == (x \in postorder_forest f)).
  Proof.
    apply tree_forest_mut_ind.
    - move=> x f Heq y.
      by rewrite in_node mem_rcons; move: (Heq y) => /eqP ->.
    - move=> x //=.
    - move=> t Heqt f Heqf x.
      by rewrite in_sibl mem_cat; move: (Heqt x) (Heqf x) => /eqP -> /eqP ->.
  Qed.

  Theorem traverse_correct_post_tree t x:
    (x \in t) == (x \in postorder_tree t).
  Proof.
    move: t x; apply traverse_correct_post.
  Qed.

End TravIn.


From iris.base_logic Require Import cancelable_invariants.
From iris_ni.logrel Require Import types.
From iris_ni.program_logic Require Import dwp heap_lang_lifting.
From iris.proofmode Require Import proofmode.
From iris.heap_lang Require Import lang proofmode.
From iris_ni.proofmode Require Import dwp_tactics.
From iris_ni.logrel Require Import interp.
From iris_ni.examples Require Import par value_dep various (* for oneshot *).

Definition thread1 : val :=
  λ: "out_low" "out_high" "rec",
    if: ~ is_classified "rec"
    then "out_low" <- read_dep "rec"
    else "out_high" <- read_dep "rec".

Definition thread2 : val :=
  λ: "ch" "rec",
    store_dep "rec" (!"ch");;
    declassify "rec" #0.

Definition prog : val := λ: "data" "out_low" "out_high",
  let: "rec" := (ref #true, ref "data") in
  thread1 "out_low" "out_high" "rec" ||| thread2 "out_high" "rec";;
  classify "rec";;
  store_dep "rec" (!"out_high").

Section proof.
  Context `{!heapDG Σ, !cinvG Σ, !valueDepG Σ, !spawnG Σ, !oneshotG Σ}.

  Definition glinv γ γs :=
    (∃ α, classification γ α (1/2) ∗
     ((pending γs ∗ ⌜α = High⌝) ∨ (shot γs ∗ ⌜α = Low⌝)))%I.

  Definition N := nroot.@"blabla".

  (* We verify that the thread that does the "dumping out" in a loop is secure,
    under the monotonicity assumption. *)
  Lemma thread1_spec γi p γ γs out_low1 out_low2 out_high1 out_high2 rec1 rec2 ξ :
    ⟦ tref (tint Low) ⟧ ξ out_low1 out_low2 -∗
    ⟦ tref (tint High) ⟧ ξ out_high1 out_high2 -∗
    value_dependent γ (tint Low) ξ rec1 rec2 -∗
    cinv N γi (glinv γ γs) -∗
    cinv_own γi p -∗
    DWP thread1 out_low1 out_high1 rec1 & thread1 out_low2 out_high2 rec2
        : λ _ _, cinv_own γi p.
  Proof.
    iIntros "#HoutL #HoutH #Hvd #Hinv Hp". dwp_rec. dwp_pures.
    dwp_bind (is_classified _) (is_classified _).
    iApply (is_classified_spec with "Hvd").
    iIntros (α b) "Ha".
    iCinv "Hinv" "Hp" as (β) "[>Hc Hi]" "Hcl".
    iDestruct (classification_auth_agree with "Ha Hc") as %<-.
    iFrame "Ha". iDestruct "Hi" as ">[[Htok %]|[#Htok %]]"; simplify_eq/=.
    - iMod ("Hcl" with "[Htok Hc]") as "_".
      { iNext. iExists _. iFrame. iLeft. eauto with iFrame. }
      iModIntro. iIntros (Hfoo). assert (b = true) as ->.
      { destruct b; naive_solver. }
      iSimpl. dwp_pures. dwp_bind (read_dep _) (read_dep _).
      iApply (read_spec with "Hvd").
      iIntros (α v1 v2) "Ha #Hv".
      iCinv "Hinv" "Hp" as (β) "[>Hc Hi]" "Hcl".
      iFrame "Ha".
      iMod ("Hcl" with "[Hi Hc]") as "_".
      { iNext. iExists _. iFrame. }
      iModIntro. iApply dwp_wand; [iApply logrel_store; first done|].
      + iApply dwp_value; eauto with iFrame.
      + iApply dwp_value. iModIntro.
        destruct α; simpl; last by eauto with iFrame.
        rewrite left_id. iApply (interp_sub_mono with "Hv"). by constructor.
      + iIntros (??) "_". done.
    - iMod ("Hcl" with "[Htok Hc]") as "_".
      { iNext. iExists _. iFrame. iRight. eauto with iFrame. }
      iModIntro. iIntros (Hfoo). destruct b.
      { iSimpl. dwp_pures. dwp_bind (read_dep _) (read_dep _).
      iApply (read_spec with "Hvd").
      iIntros (α v1 v2) "Ha #Hv". iFrame "Ha".
      iModIntro. iApply dwp_wand; [iApply logrel_store; first done|].
        + iApply dwp_value; eauto with iFrame.
        + iApply dwp_value. iModIntro.
          iApply (interp_sub_mono with "Hv"). by constructor.
        + iIntros (??) "_". done.  }
      dwp_pures.
      dwp_bind (read_dep _) (read_dep _).
      iApply (read_spec with "Hvd").
      iIntros (α v1 v2) "Ha #Hv".
      iCinv "Hinv" "Hp" as (β) "[>Hc Hi]" "Hcl".
      iDestruct "Hi" as ">[[Htok2 %]|[_ %]]"; simplify_eq/=.
      { iExFalso. iApply (shot_not_pending with "Htok Htok2"). }
      iDestruct (classification_auth_agree with "Ha Hc") as %->.
      iFrame "Ha".
      iMod ("Hcl" with "[Htok Hc]") as "_".
      { iNext. iExists _. iFrame. iRight. eauto with iFrame. }
      iModIntro.
      iApply dwp_wand; [iApply logrel_store; first done|];
        try iApply dwp_value; eauto with iFrame.
  Qed.

  Lemma thread2_spec γi p γ γs ch1 ch2 rec1 rec2 ξ :
    ⟦ tref (tint High) ⟧ ξ ch1 ch2 -∗
    value_dependent γ (tint Low) ξ rec1 rec2 -∗
    cinv N γi (glinv γ γs) -∗
    cinv_own γi p -∗
    classification γ High (1/2) -∗
    DWP thread2 ch1 rec1 & thread2 ch2 rec2 :
      λ _ _, cinv_own γi p ∗ classification γ Low (1/2).
  Proof.
    iIntros "#Hch #Hvd #Hinv Hp Hc2".
    dwp_rec. dwp_pures. dwp_bind (! _)%E (! _)%E.
    iApply dwp_wand.
    { iApply (logrel_deref with "[Hch]"). by iApply dwp_value. }
    iIntros (v1 v2) "#Hv". dwp_bind (store_dep _ _) (store_dep _ _).
    iApply (store_spec with "Hvd"). iIntros (α) "Ha".
    iDestruct (classification_auth_agree with "Ha Hc2") as %->.
    iFrame "Ha". iModIntro. iSimpl. rewrite left_id. iFrame "Hv".
    dwp_pures.
    iApply (declassify_spec with "Hvd [] Hc2").
    { rewrite !interp_eq. iExists 0,0. by eauto. }
    iSimpl. iIntros "Ha Hc2".
    iCinv "Hinv" "Hp" as (α') "[>Hc1 >Hi]" "Hcl".
    iDestruct (classification_auth_agree with "Ha Hc1") as %<-.
    iCombine "Hc1 Hc2" as "Hc".
    iMod (classification_update Low with "Ha Hc") as "[$ [Hc1 Hc2]]".
    iDestruct "Hi" as "[[Htok %]|[Htok %]]"; simplify_eq/=.
    iMod (shoot with "Htok") as "#Htok".
    iMod ("Hcl" with "[-Hc2 Hp]") as "_".
    { iNext. iExists _. iFrame. eauto with iFrame. }
    iModIntro. iFrame "Hc2". eauto with iFrame.
  Qed.

  Lemma proof out_low1 out_low2 out_high1 out_high2 dat1 dat2 ξ :
    ⟦ tref (tint Low) ⟧ ξ out_low1 out_low2 -∗
    ⟦ tref (tint High) ⟧ ξ out_high1 out_high2 -∗
    ⟦ tint High ⟧ ξ dat1 dat2 -∗
    DWP (prog dat1 out_low1 out_high1) &
        (prog dat2 out_low2 out_high2) : ⟦ tunit ⟧ ξ.
  Proof.
    iIntros "#HoutL #HoutH #Hdat".
    dwp_rec. dwp_pures.

    dwp_bind (ref _)%E (ref _)%E.
    iApply dwp_alloc. iIntros (rd1 rd2) "Hrd1 Hrd2". iNext.

    dwp_bind (ref _)%E (ref _)%E.
    iApply dwp_alloc. iIntros (is_classified1 is_classified2) "Hc1 Hc2". iNext.

    iMod (make_value_dependent (tint Low) with "Hrd1 Hrd2 Hc1 Hc2 []")
      as (γ) "[#Hvd Hc]".
    { simpl. rewrite left_id. iExact "Hdat". }
    iClear "Hdat". iDestruct "Hc" as "[Hc1 Hc2]".
    dwp_pures.
    iMod new_pending as (γs) "Hpend".

    iMod (cinv_alloc _ N (glinv γ γs) with "[-Hc2]") as (γi) "[#Hinv [Hp1 Hp2]]".
    { iNext. iExists _. iFrame. iLeft. eauto with iFrame. }
    dwp_bind (par _ _) (par _ _).
    iApply (dwp_par _ _ with "[Hp1] [Hc2 Hp2]").
    - (* Thread 1 *) iApply (thread1_spec with "HoutL HoutH Hvd Hinv Hp1").
    - (* Thread 2 *) iApply (thread2_spec with "HoutH Hvd Hinv Hp2 Hc2").
    - (* Finally *)
      iIntros (z1 z2 r1 r2) "Hp1 [Hp2 Hc2]". iCombine "Hp1 Hp2" as "Hp".
      iNext. dwp_pures. clear z1 z2 r1 r2.
      iMod (cinv_cancel with "Hinv Hp") as (β) "[>Hc1 >Hi]"; first done.
      iDestruct "Hi" as "[[Htok2 %]|[_ %]]"; simplify_eq/=.
      { iExFalso. by iDestruct (classification_agree with "Hc1 Hc2") as %?. }
      iCombine "Hc1 Hc2" as "Hc".
      dwp_bind (classify _) (classify _).
      iApply (classify_spec with "Hvd Hc").
      iIntros "Hauth Hc".
      iMod (classification_update High with "Hauth Hc") as "[$ Hc]".
      iModIntro. dwp_pures.
      dwp_bind (! _)%E (! _)%E. iApply dwp_wand; [iApply logrel_deref|].
      { iApply dwp_value. eauto. }
      iIntros (v1 v2) "Hv".
      iApply (store_spec with "Hvd"). iIntros (α) "Hauth".
      iDestruct (classification_auth_agree with "Hauth Hc") as %->.
      iModIntro. eauto with iFrame.
  Qed.

End proof.