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

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

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

Lemma ireg_of_not_R14':
  forall m r, ireg_of m = OK r -> r <> IR14.
Proof.
  intros. generalize (ireg_of_not_R14 _ _ H). congruence.
Qed.
Hint Resolve ireg_of_not_R14': 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 ARM constructor functions *)

Section CONSTRUCTORS.

Variable ge: genv.
Variable fn: function.

(** Decomposition of an integer constant *)

Lemma decompose_int_rec_or:
  forall N n p x, List.fold_left Int.or (decompose_int_rec N n p) x = Int.or x n.
Proof.
  induction N; intros; simpl.
  predSpec Int.eq Int.eq_spec n Int.zero; simpl.
  subst n. rewrite Int.or_zero. auto.
  auto.
  predSpec Int.eq Int.eq_spec (Int.and n (Int.shl (Int.repr 3) p)) Int.zero.
  auto.
  simpl. rewrite IHN. rewrite Int.or_assoc. decEq. rewrite <- Int.and_or_distrib.
  rewrite Int.or_not_self. apply Int.and_mone.
Qed.

Lemma decompose_int_rec_xor:
  forall N n p x, List.fold_left Int.xor (decompose_int_rec N n p) x = Int.xor x n.
Proof.
  induction N; intros; simpl.
  predSpec Int.eq Int.eq_spec n Int.zero; simpl.
  subst n. rewrite Int.xor_zero. auto.
  auto.
  predSpec Int.eq Int.eq_spec (Int.and n (Int.shl (Int.repr 3) p)) Int.zero.
  auto.
  simpl. rewrite IHN. rewrite Int.xor_assoc. decEq. rewrite <- Int.and_xor_distrib.
  rewrite Int.xor_not_self. apply Int.and_mone.
Qed.

Lemma decompose_int_rec_add:
  forall N n p x, List.fold_left Int.add (decompose_int_rec N n p) x = Int.add x n.
Proof.
  induction N; intros; simpl.
  predSpec Int.eq Int.eq_spec n Int.zero; simpl.
  subst n. rewrite Int.add_zero. auto.
  auto.
  predSpec Int.eq Int.eq_spec (Int.and n (Int.shl (Int.repr 3) p)) Int.zero.
  auto.
  simpl. rewrite IHN. rewrite Int.add_assoc. decEq. rewrite Int.add_and.
  rewrite Int.or_not_self. apply Int.and_mone. apply Int.and_not_self.
Qed.

Remark decompose_int_rec_nil:
  forall N n p, decompose_int_rec N n p = nil -> n = Int.zero.
Proof.
  intros. generalize (decompose_int_rec_or N n p Int.zero). rewrite H. simpl.
  rewrite Int.or_commut; rewrite Int.or_zero; auto.
Qed.

Lemma decompose_int_general:
  forall (f: val -> int -> val) (g: int -> int -> int),
  (forall v1 n2 n3, f (f v1 n2) n3 = f v1 (g n2 n3)) ->
  (forall n1 n2 n3, g (g n1 n2) n3 = g n1 (g n2 n3)) ->
  (forall n, g Int.zero n = n) ->
  (forall N n p x, List.fold_left g (decompose_int_rec N n p) x = g x n) ->
  forall n v,
  List.fold_left f (decompose_int n) v = f v n.
Proof.
  intros f g DISTR ASSOC ZERO DECOMP.
  assert (A: forall l x y, g x (fold_left g l y) = fold_left g l (g x y)).
    induction l; intros; simpl. auto. rewrite IHl. decEq. rewrite ASSOC; auto.
  assert (B: forall l v n, fold_left f l (f v n) = f v (fold_left g l n)).
    induction l; intros; simpl.
    auto.
    rewrite IHl. rewrite DISTR. decEq. decEq. auto.
  intros. unfold decompose_int.
  destruct (decompose_int_rec 12 n Int.zero) eqn:?.
  simpl. exploit decompose_int_rec_nil; eauto. congruence.
  simpl. rewrite B. decEq.
  generalize (DECOMP 12%nat n Int.zero Int.zero).
  rewrite Heql. simpl. repeat rewrite ZERO. auto.
Qed.

Lemma decompose_int_or:
  forall n v,
  List.fold_left (fun v i => Val.or v (Vint i)) (decompose_int n) v = Val.or v (Vint n).
Proof.
  intros. apply decompose_int_general with (f := fun v n => Val.or v (Vint n)) (g := Int.or).
  intros. rewrite Val.or_assoc. auto.
  apply Int.or_assoc.
  intros. rewrite Int.or_commut. apply Int.or_zero.
  apply decompose_int_rec_or.
Qed.

Lemma decompose_int_bic:
  forall n v,
  List.fold_left (fun v i => Val.and v (Vint (Int.not i))) (decompose_int n) v = Val.and v (Vint (Int.not n)).
Proof.
  intros. apply decompose_int_general with (f := fun v n => Val.and v (Vint (Int.not n))) (g := Int.or).
  intros. rewrite Val.and_assoc. simpl. decEq. decEq. rewrite Int.not_or_and_not. auto.
  apply Int.or_assoc.
  intros. rewrite Int.or_commut. apply Int.or_zero.
  apply decompose_int_rec_or.
Qed.

Lemma decompose_int_xor:
  forall n v,
  List.fold_left (fun v i => Val.xor v (Vint i)) (decompose_int n) v = Val.xor v (Vint n).
Proof.
  intros. apply decompose_int_general with (f := fun v n => Val.xor v (Vint n)) (g := Int.xor).
  intros. rewrite Val.xor_assoc. auto.
  apply Int.xor_assoc.
  intros. rewrite Int.xor_commut. apply Int.xor_zero.
  apply decompose_int_rec_xor.
Qed.

Lemma decompose_int_add:
  forall n v,
  List.fold_left (fun v i => Val.add v (Vint i)) (decompose_int n) v = Val.add v (Vint n).
Proof.
  intros. apply decompose_int_general with (f := fun v n => Val.add v (Vint n)) (g := Int.add).
  intros. rewrite Val.add_assoc. auto.
  apply Int.add_assoc.
  intros. rewrite Int.add_commut. apply Int.add_zero.
  apply decompose_int_rec_add.
Qed.

Lemma decompose_int_sub:
  forall n v,
  List.fold_left (fun v i => Val.sub v (Vint i)) (decompose_int n) v = Val.sub v (Vint n).
Proof.
  intros. apply decompose_int_general with (f := fun v n => Val.sub v (Vint n)) (g := Int.add).
  intros. repeat rewrite Val.sub_add_opp. rewrite Val.add_assoc. decEq. simpl. decEq.
  rewrite Int.neg_add_distr; auto.
  apply Int.add_assoc.
  intros. rewrite Int.add_commut. apply Int.add_zero.
  apply decompose_int_rec_add.
Qed.

Lemma iterate_op_correct:
  forall op1 op2 (f: val -> int -> val) (rs: regset) (r: ireg) m v0 n k,
  (forall (rs:regset) n,
    exec_instr ge fn (op2 (SOimm n)) rs m =
    Next (nextinstr (rs#r <- (f (rs#r) n))) m) ->
  (forall n,
    exec_instr ge fn (op1 (SOimm n)) rs m =
    Next (nextinstr (rs#r <- (f v0 n))) m) ->
  exists rs',
     exec_straight ge fn (iterate_op op1 op2 (decompose_int n) k) rs m  k rs' m
  /\ rs'#r = List.fold_left f (decompose_int n) v0
  /\ forall r': preg, r' <> r -> r' <> PC -> rs'#r' = rs#r'.
Proof.
  intros until k; intros SEM2 SEM1.
  unfold iterate_op.
  destruct (decompose_int n) as [ | i tl] eqn:?.
  unfold decompose_int in Heql. destruct (decompose_int_rec 12%nat n Int.zero); congruence.
  revert k. pattern tl. apply List.rev_ind.
  (* base case *)
  intros; simpl. econstructor.
  split. apply exec_straight_one. rewrite SEM1. reflexivity. reflexivity.
  intuition Simpl.
  (* inductive case *)
  intros.
  rewrite List.map_app. simpl. rewrite app_ass. simpl.
  destruct (H (op2 (SOimm x) :: k)) as [rs' [A [B C]]].
  econstructor.
  split. eapply exec_straight_trans. eexact A. apply exec_straight_one.
  rewrite SEM2. reflexivity. reflexivity.
  split. rewrite fold_left_app; simpl. Simpl. rewrite B. auto.
  intros; 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.
  destruct (NPeano.leb (length (decompose_int n)) (length (decompose_int (Int.not n)))).
  (* mov - orr* *)
  replace (Vint n) with (List.fold_left (fun v i => Val.or v (Vint i)) (decompose_int n) Vzero).
  apply iterate_op_correct.
  auto.
  intros; simpl. rewrite Int.or_commut; rewrite Int.or_zero; auto.
  rewrite decompose_int_or. simpl. rewrite Int.or_commut; rewrite Int.or_zero; auto.
  (* mvn - bic* *)
  replace (Vint n) with (List.fold_left (fun v i => Val.and v (Vint (Int.not i))) (decompose_int (Int.not n)) (Vint Int.mone)).
  apply iterate_op_correct.
  auto.
  intros. simpl. rewrite Int.and_commut; rewrite Int.and_mone; auto.
  rewrite decompose_int_bic. simpl. rewrite Int.not_involutive. rewrite Int.and_commut. rewrite Int.and_mone; auto.
Qed.

(** Add integer immediate. *)

Lemma addimm_correct:
  forall r1 r2 n k rs m,
  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.
  destruct (NPeano.leb (length (decompose_int n)) (length (decompose_int (Int.neg n)))).
  (* add - add* *)
  replace (Val.add (rs r2) (Vint n))
     with (List.fold_left (fun v i => Val.add v (Vint i)) (decompose_int n) (rs r2)).
  apply iterate_op_correct.
  auto.
  auto.
  apply decompose_int_add.
  (* sub - sub* *)
  replace (Val.add (rs r2) (Vint n))
     with (List.fold_left (fun v i => Val.sub v (Vint i)) (decompose_int (Int.neg n)) (rs r2)).
  apply iterate_op_correct.
  auto.
  auto.
  rewrite decompose_int_sub. apply Val.sub_opp_add.
Qed.

(* And integer immediate *)

Lemma andimm_correct:
  forall r1 r2 n k rs m,
  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': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'.
Proof.
  intros. unfold andimm.
  (* andi *)
  case (is_immed_arith n).
  exists (nextinstr (rs#r1 <- (Val.and rs#r2 (Vint n)))).
  split. apply exec_straight_one; auto.
  split. rewrite nextinstr_inv; auto with asmgen. apply Pregmap.gss.
  intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto.
  (* bic - bic* *)
  replace (Val.and (rs r2) (Vint n))
     with (List.fold_left (fun v i => Val.and v (Vint (Int.not i))) (decompose_int (Int.not n)) (rs r2)).
  apply iterate_op_correct.
  auto.
  auto.
  rewrite decompose_int_bic. rewrite Int.not_involutive. auto.
Qed.

(** Reverse sub immediate *)

Lemma rsubimm_correct:
  forall r1 r2 n k rs m,
  exists rs',
     exec_straight ge fn (rsubimm r1 r2 n k) rs m  k rs' m
  /\ rs'#r1 = Val.sub (Vint n) rs#r2
  /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'.
Proof.
  intros. unfold rsubimm.
  (* rsb - add* *)
  replace (Val.sub (Vint n) (rs r2))
     with (List.fold_left (fun v i => Val.add v (Vint i)) (decompose_int n) (Val.neg (rs r2))).
  apply iterate_op_correct.
  auto.
  intros. simpl. destruct (rs r2); auto. simpl. rewrite Int.sub_add_opp.
  rewrite Int.add_commut; auto.
  rewrite decompose_int_add.
  destruct (rs r2); simpl; auto. rewrite Int.sub_add_opp. rewrite Int.add_commut; auto.
Qed.

(** Or immediate *)

Lemma orimm_correct:
  forall r1 r2 n k rs m,
  exists rs',
     exec_straight ge fn (orimm r1 r2 n k) rs m  k rs' m
  /\ rs'#r1 = Val.or rs#r2 (Vint n)
  /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'.
Proof.
  intros. unfold orimm.
  (* ori - ori* *)
  replace (Val.or (rs r2) (Vint n))
     with (List.fold_left (fun v i => Val.or v (Vint i)) (decompose_int n) (rs r2)).
  apply iterate_op_correct.
  auto.
  auto.
  apply decompose_int_or.
Qed.

(** Xor immediate *)

Lemma xorimm_correct:
  forall r1 r2 n k rs m,
  exists rs',
     exec_straight ge fn (xorimm r1 r2 n k) rs m  k rs' m
  /\ rs'#r1 = Val.xor rs#r2 (Vint n)
  /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'.
Proof.
  intros. unfold xorimm.
  (* xori - xori* *)
  replace (Val.xor (rs r2) (Vint n))
     with (List.fold_left (fun v i => Val.xor v (Vint i)) (decompose_int n) (rs r2)).
  apply iterate_op_correct.
  auto.
  auto.
  apply decompose_int_xor.
Qed.

(** Indexed memory loads. *)

Lemma indexed_memory_access_correct:
  forall (P: regset -> Prop) (mk_instr: ireg -> int -> instruction)
         (mk_immed: int -> int) (base: ireg) n k (rs: regset) m m',
  (forall (r1: ireg) (rs1: regset) n1 k,
    Val.add rs1#r1 (Vint n1) = Val.add rs#base (Vint n) ->
    (forall (r: preg), r <> PC -> r <> IR14 -> rs1 r = rs r) ->
    exists rs',
    exec_straight ge fn (mk_instr r1 n1 :: k) rs1 m k rs' m' /\ P rs') ->
  exists rs',
     exec_straight ge fn
        (indexed_memory_access mk_instr mk_immed base n k) rs m
        k rs' m'
  /\ P rs'.
Proof.
  intros until m'; intros SEM.
  unfold indexed_memory_access.
  destruct (Int.eq n (mk_immed n)).
- apply SEM; auto.
- destruct (addimm_correct IR14 base (Int.sub n (mk_immed n)) (mk_instr IR14 (mk_immed n) :: k) rs m)
  as (rs1 & A & B & C).
  destruct (SEM IR14 rs1 (mk_immed n) k) as (rs2 & D & E).
  rewrite B. rewrite Val.add_assoc. f_equal. simpl.
  rewrite Int.sub_add_opp. rewrite Int.add_assoc.
  rewrite (Int.add_commut (Int.neg (mk_immed n))).
  rewrite Int.add_neg_zero. rewrite Int.add_zero. auto.
  auto with asmgen.
  exists rs2; split; auto. eapply exec_straight_trans; eauto.
Qed.

Lemma loadind_int_correct:
  forall (base: ireg) ofs dst (rs: regset) m v k,
  Mem.loadv Mint32 m (Val.add rs#base (Vint ofs)) = Some v ->
  exists rs',
     exec_straight ge fn (loadind_int base ofs dst k) rs m k rs' m
  /\ rs'#dst = v
  /\ forall r, r <> PC -> r <> IR14 -> r <> dst -> rs'#r = rs#r.
Proof.
  intros; unfold loadind_int. apply indexed_memory_access_correct; intros.
  econstructor; split.
  apply exec_straight_one. simpl. unfold exec_load. rewrite H0; rewrite H; eauto. auto.
  split. Simpl. intros; Simpl.
Qed.

(*
Lemma loadind_float_correct:
  forall (base: ireg) ofs dst (rs: regset) m v k,
  Mem.loadv Mfloat64al32 m (Val.add rs#base (Vint ofs)) = Some v ->
  exists rs',
     exec_straight ge fn (loadind_float base ofs dst k) rs m k rs' m
  /\ rs'#dst = v
  /\ forall r, r <> PC -> r <> IR14 -> r <> dst -> rs'#r = rs#r.
Proof.
  intros; unfold loadind_float. apply indexed_memory_access_correct; intros.
  econstructor; split.
  apply exec_straight_one. simpl. unfold exec_load. rewrite H0; rewrite H; eauto. auto.
  split. Simpl. intros; Simpl.
Qed.
*)

Lemma loadind_correct:
  forall (base: ireg) ofs ty dst k c (rs: regset) m v,
  loadind base ofs ty dst k = OK c ->
  Mem.loadv (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) = Some v ->
  exists rs',
     exec_straight ge fn c rs m k rs' m
  /\ rs'#(preg_of dst) = v
  /\ forall r, r <> PC -> r <> IR14 -> r <> preg_of dst -> rs'#r = rs#r.
Proof.
  unfold loadind; intros.
  destruct ty; monadInv H.
- (* int *)
  erewrite ireg_of_eq by eauto. apply loadind_int_correct; auto.
- (* float *)
  erewrite freg_of_eq by eauto. simpl in H0.
  apply indexed_memory_access_correct; intros.
  econstructor; split.
  apply exec_straight_one. simpl. unfold exec_load. rewrite H. rewrite H0. eauto. auto.
  split. Simpl. intros; Simpl.
- (* single *)
  erewrite freg_of_eq by eauto. simpl in H0.
  apply indexed_memory_access_correct; intros.
  econstructor; split.
  apply exec_straight_one. simpl. unfold exec_load. rewrite H. rewrite H0. eauto. auto.
  split. Simpl. intros; Simpl.
Qed.

(** Indexed memory stores. *)

(*
Lemma storeind_int_correct:
  forall (base: ireg) ofs (src: ireg) (rs: regset) m m' k,
  Mem.storev Mint32 m (Val.add rs#base (Vint ofs)) (rs#src) = Some m' ->
  src <> IR14 ->
  exists rs',
     exec_straight ge fn (storeind_int src base ofs k) rs m k rs' m'
  /\ forall r, r <> PC -> r <> IR14 -> rs'#r = rs#r.
Proof.
  intros; unfold storeind_int. apply indexed_memory_access_correct; intros.
  econstructor; split.
  apply exec_straight_one. simpl. unfold exec_store.
  rewrite H1. rewrite H2; auto with asmgen. rewrite H; eauto. auto.
  intros; Simpl.
Qed.

Lemma storeind_float_correct:
  forall (base: ireg) ofs (src: freg) (rs: regset) m m' k,
  Mem.storev Mfloat64al32 m (Val.add rs#base (Vint ofs)) (rs#src) = Some m' ->
  exists rs',
     exec_straight ge fn (storeind_float src base ofs k) rs m k rs' m'
  /\ forall r, r <> PC -> r <> IR14 -> rs'#r = rs#r.
Proof.
  intros; unfold storeind_float. apply indexed_memory_access_correct; intros.
  econstructor; split.
  apply exec_straight_one. simpl. unfold exec_store.
  rewrite H0. rewrite H1; auto with asmgen. rewrite H; eauto. auto.
  intros; Simpl.
Qed.
*)

Lemma storeind_correct:
  forall (base: ireg) ofs ty src k c (rs: regset) m m',
  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' ->
  exists rs',
     exec_straight ge fn c rs m k rs' m'
  /\ forall r, r <> PC -> r <> IR14 -> preg_notin r (destroyed_by_setstack ty) -> rs'#r = rs#r.
Proof.
  unfold storeind; intros.
  destruct ty; monadInv H; simpl in H0.
- (* int *)
  erewrite ireg_of_eq  in H0 by eauto.
  apply indexed_memory_access_correct; intros.
  econstructor; split.
  apply exec_straight_one. simpl. unfold exec_store.
  rewrite H. rewrite H1; auto with asmgen. rewrite H0; eauto.
  assert (IR x <> IR IR14) by eauto with asmgen. congruence.
  auto. intros; Simpl.
- (* float *)
  erewrite freg_of_eq  in H0 by eauto.
  apply indexed_memory_access_correct; intros.
  econstructor; split.
  apply exec_straight_one. simpl. unfold exec_store.
  rewrite H. rewrite H1; auto with asmgen. rewrite H0; eauto.
  auto. intros; Simpl.
- (* single *)
  erewrite freg_of_eq  in H0 by eauto.
  apply indexed_memory_access_correct; intros.
  econstructor; split.
  apply exec_straight_one. simpl. unfold exec_store.
  rewrite H. rewrite H1; auto with asmgen. rewrite H0; eauto.
  auto. intros; Simpl.
Qed.

(** Translation of shift immediates *)

Lemma transl_shift_correct:
  forall s (r: ireg) (rs: regset),
  eval_shift_op (transl_shift s r) rs = eval_shift s (rs#r).
Proof.
  intros. destruct s; simpl; auto.
Qed.

Lemma transl_shift_addr_correct:
  forall s (r: ireg) (rs: regset),
  eval_shift_addr (transl_shift_addr s r) rs = eval_shift s (rs#r).
Proof.
  intros. destruct s; simpl; auto.
Qed.

(** Translation of conditions *)

Lemma compare_int_spec:
  forall rs v1 v2 m,
  let rs1 := nextinstr (compare_int rs v1 v2 m) in
     rs1#CReq = (Val.cmpu (Mem.valid_pointer m) Ceq v1 v2)
  /\ rs1#CRne = (Val.cmpu (Mem.valid_pointer m) Cne v1 v2)
  /\ rs1#CRhs = (Val.cmpu (Mem.valid_pointer m) Cge v1 v2)
  /\ rs1#CRlo = (Val.cmpu (Mem.valid_pointer m) Clt v1 v2)
  /\ rs1#CRhi = (Val.cmpu (Mem.valid_pointer m) Cgt v1 v2)
  /\ rs1#CRls = (Val.cmpu (Mem.valid_pointer m) Cle v1 v2)
  /\ rs1#CRge = (Val.cmp Cge v1 v2)
  /\ rs1#CRlt = (Val.cmp Clt v1 v2)
  /\ rs1#CRgt = (Val.cmp Cgt v1 v2)
  /\ rs1#CRle = (Val.cmp Cle v1 v2)
  /\ forall r', data_preg r' = true -> rs1#r' = rs#r'.
Proof.
  intros. unfold rs1. intuition; try reflexivity.
  unfold compare_int. Simpl.
Qed.

Lemma compare_float_spec:
  forall rs v1 v2,
  let rs' := nextinstr (compare_float rs v1 v2) in
     rs'#CReq = (Val.cmpf Ceq v1 v2)
  /\ rs'#CRne = (Val.cmpf Cne v1 v2)
  /\ rs'#CRmi = (Val.cmpf Clt v1 v2)
  /\ rs'#CRpl = (Val.notbool (Val.cmpf Clt v1 v2))
  /\ rs'#CRhi = (Val.notbool (Val.cmpf Cle v1 v2))
  /\ rs'#CRls = (Val.cmpf Cle v1 v2)
  /\ rs'#CRge = (Val.cmpf Cge v1 v2)
  /\ rs'#CRlt = (Val.notbool (Val.cmpf Cge v1 v2))
  /\ rs'#CRgt = (Val.cmpf Cgt v1 v2)
  /\ rs'#CRle = (Val.notbool (Val.cmpf Cgt v1 v2))
  /\ forall r', data_preg r' = true -> rs'#r' = rs#r'.
Proof.
  intros. unfold rs'. intuition; try reflexivity.
  unfold compare_float. Simpl.
Qed.

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
  | [ H: match _ with true => _ | false => assertion_failed end = OK _ |- _ ] => monadInv H
  end);
  subst;
  repeat (match goal with
  | [ H: ireg_of ?x = OK ?y |- _ ] => simpl in *; rewrite (ireg_of_eq _ _ H) in *
  | [ H: freg_of ?x = OK ?y |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in *
  end).

Lemma transl_cond_correct:
  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
  /\ match eval_condition cond (map rs (map preg_of args)) m with
     | Some b => rs'#(CR (crbit_for_cond cond)) = Val.of_bool b
     | None => True
     end
  /\ forall r, data_preg r = true -> rs'#r = rs r.
Proof.
  intros until c; intros TR.
  assert (MATCH: forall v ob,
           v = Val.of_optbool ob ->
           match ob with Some b => v = Val.of_bool b | None => True end).
    intros. subst v. destruct ob; auto.
  assert (MATCH2: forall cmp v1 v2 v,
           v = Val.cmpu (Mem.valid_pointer m) cmp v1 v2 ->
           cmp = Ceq \/ cmp = Cne ->
           match Val.cmp_bool cmp v1 v2 with
           | Some b => v = Val.of_bool b
           | None => True
           end).
     intros. destruct v1; simpl; auto; destruct v2; simpl; auto.
     unfold Val.cmpu, Val.cmpu_bool in H. subst v. destruct H0; subst cmp; auto.

  unfold transl_cond in TR; destruct cond; ArgsInv.
- (* Ccomp *)
  generalize (compare_int_spec rs (rs x) (rs x0) m).
  intros (C1 & C2 & C3 & C4 & C5 & C6 & C7 & C8 & C9 & C10 & C).
  econstructor.
  split. apply exec_straight_one. simpl. eauto. auto.
  split. destruct c0; (apply MATCH; assumption) || (apply MATCH2; auto).
  auto.
- (* Ccompu *)
  generalize (compare_int_spec rs (rs x) (rs x0) m).
  intros (C1 & C2 & C3 & C4 & C5 & C6 & C7 & C8 & C9 & C10 & C).
  econstructor.
  split. apply exec_straight_one. simpl. eauto. auto.
  split. destruct c0; (apply MATCH; assumption) || (apply MATCH2; auto).
  auto.
- (* Ccompshift *)
  generalize (compare_int_spec rs (rs x) (eval_shift s (rs x0)) m).
  intros (C1 & C2 & C3 & C4 & C5 & C6 & C7 & C8 & C9 & C10 & C).
  econstructor.
  split. apply exec_straight_one. simpl. eauto. auto.
  rewrite transl_shift_correct.
  split. destruct c0; (apply MATCH; assumption) || (apply MATCH2; auto).
  auto.
- (* Ccompushift *)
  generalize (compare_int_spec rs (rs x) (eval_shift s (rs x0)) m).
  intros (C1 & C2 & C3 & C4 & C5 & C6 & C7 & C8 & C9 & C10 & C).
  econstructor.
  split. apply exec_straight_one. simpl. eauto. auto.
  rewrite transl_shift_correct.
  split. destruct c0; (apply MATCH; assumption) || (apply MATCH2; auto).
  auto.
- (* Ccompimm *)
  destruct (is_immed_arith i).
  generalize (compare_int_spec rs (rs x) (Vint i) m).
  intros (C1 & C2 & C3 & C4 & C5 & C6 & C7 & C8 & C9 & C10 & C).
  econstructor.
  split. apply exec_straight_one. simpl. eauto. auto.
  split. destruct c0; (apply MATCH; assumption) || (apply MATCH2; auto).
  auto.
  exploit (loadimm_correct IR14). intros [rs' [P [Q R]]].
  generalize (compare_int_spec rs' (rs x) (Vint i) m).
  intros (C1 & C2 & C3 & C4 & C5 & C6 & C7 & C8 & C9 & C10 & C).
  econstructor.
  split. eapply exec_straight_trans. eexact P. apply exec_straight_one. simpl.
  rewrite Q. rewrite R; eauto with asmgen. auto.
  split. destruct c0; (apply MATCH; assumption) || (apply MATCH2; auto).
  intros. rewrite C; auto with asmgen.
- (* Ccompuimm *)
  destruct (is_immed_arith i).
  generalize (compare_int_spec rs (rs x) (Vint i) m).
  intros (C1 & C2 & C3 & C4 & C5 & C6 & C7 & C8 & C9 & C10 & C).
  econstructor.
  split. apply exec_straight_one. simpl. eauto. auto.
  split. destruct c0; (apply MATCH; assumption) || (apply MATCH2; auto).
  auto.
  exploit (loadimm_correct IR14). intros [rs' [P [Q R]]].
  generalize (compare_int_spec rs' (rs x) (Vint i) m).
  intros (C1 & C2 & C3 & C4 & C5 & C6 & C7 & C8 & C9 & C10 & C).
  econstructor.
  split. eapply exec_straight_trans. eexact P. apply exec_straight_one. simpl.
  rewrite Q. rewrite R; eauto with asmgen. auto.
  split. destruct c0; (apply MATCH; assumption) || (apply MATCH2; auto).
  intros. rewrite C; auto with asmgen.
- (* Ccompf *)
  generalize (compare_float_spec rs (rs x) (rs x0)).
  intros (C1 & C2 & C3 & C4 & C5 & C6 & C7 & C8 & C9 & C10 & C).
  econstructor.
  split. apply exec_straight_one. simpl. eauto. auto.
  split. case c0; apply MATCH; assumption.
  auto.
- (* Cnotcompf *)
  generalize (compare_float_spec rs (rs x) (rs x0)).
  intros (C1 & C2 & C3 & C4 & C5 & C6 & C7 & C8 & C9 & C10 & C).
  econstructor.
  split. apply exec_straight_one. simpl. eauto. auto.
  split. rewrite <- Val.negate_cmpf_ne in C2. rewrite <- Val.negate_cmpf_eq in C1.
  destruct c0; apply MATCH; simpl; rewrite Val.notbool_negb_3; auto.
  auto.
- (* Ccompfzero *)
  generalize (compare_float_spec rs (rs x) (Vfloat Float.zero)).
  intros (C1 & C2 & C3 & C4 & C5 & C6 & C7 & C8 & C9 & C10 & C).
  econstructor.
  split. apply exec_straight_one. simpl. eauto. auto.
  split. case c0; apply MATCH; assumption.
  auto.
- (* Cnotcompf *)
  generalize (compare_float_spec rs (rs x) (Vfloat Float.zero)).
  intros (C1 & C2 & C3 & C4 & C5 & C6 & C7 & C8 & C9 & C10 & C).
  econstructor.
  split. apply exec_straight_one. simpl. eauto. auto.
  split. rewrite <- Val.negate_cmpf_ne in C2. rewrite <- Val.negate_cmpf_eq in C1.
  destruct c0; apply MATCH; simpl; rewrite Val.notbool_negb_3; auto.
  auto.
Qed.

(** Translation of arithmetic operations. *)

Ltac TranslOpSimpl :=
  econstructor; split;
  [ apply exec_straight_one; [simpl; eauto | reflexivity ]
  | split; [try rewrite transl_shift_correct; repeat Simpl | intros; repeat Simpl] ].

Lemma transl_op_correct_same:
  forall op args res k c (rs: regset) m v,
  transl_op op args res k = OK c ->
  eval_operation ge rs#IR13 op (map rs (map preg_of args)) m = Some v ->
  match op with Ocmp _ => False | _ => True end ->
  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.
  intros until v; intros TR EV NOCMP.
  unfold transl_op in TR; destruct op; ArgsInv; simpl in EV; inv EV; try (TranslOpSimpl; fail).
  (* Omove *)
  exists (nextinstr (rs#(preg_of res) <- (rs#(preg_of m0)))).
  split.
  destruct (preg_of res) eqn:RES; try discriminate;
  destruct (preg_of m0) eqn:ARG; inv TR.
  apply exec_straight_one; auto.
  apply exec_straight_one; auto.
  intuition Simpl.
  (* Ointconst *)
  generalize (loadimm_correct x i k rs m). intros [rs' [A [B C]]].
  exists rs'; auto with asmgen.
  (* Oaddrstack *)
  generalize (addimm_correct x IR13 i k rs m).
  intros [rs' [EX [RES OTH]]].
  exists rs'; auto with asmgen.
  (* Oaddimm *)
  generalize (addimm_correct x x0 i k rs m).
  intros [rs' [A [B C]]].
  exists rs'; auto with asmgen.
  (* Orsbimm *)
  generalize (rsubimm_correct x x0 i k rs m).
  intros [rs' [A [B C]]].
  exists rs'; auto with asmgen.
  (* Omul *)
  destruct (negb (ireg_eq x x0)).
  TranslOpSimpl.
  destruct (negb (ireg_eq x x1)).
  rewrite Val.mul_commut. TranslOpSimpl.
  econstructor; split.
  eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto.
  intuition Simpl.
  (* Omla *)
  destruct (negb (ireg_eq x x0)).
  TranslOpSimpl.
  destruct (negb (ireg_eq x x1)).
  rewrite Val.mul_commut. TranslOpSimpl.
  econstructor; split.
  eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto.
  intuition Simpl.
  (* divs *)
  econstructor. split. apply exec_straight_one. simpl. rewrite H0. reflexivity. auto.
  intuition Simpl.
  (* divu *)
  econstructor. split. apply exec_straight_one. simpl. rewrite H0. reflexivity. auto.
  intuition Simpl.
  (* Oandimm *)
  generalize (andimm_correct x x0 i k rs m).
  intros [rs' [A [B C]]].
  exists rs'; auto with asmgen.
  (* Oorimm *)
  generalize (orimm_correct x x0 i k rs m).
  intros [rs' [A [B C]]].
  exists rs'; auto with asmgen.
  (* Oxorimm *)
  generalize (xorimm_correct x x0 i k rs m).
  intros [rs' [A [B C]]].
  exists rs'; auto with asmgen.
  (* Oshrximm *)
  exploit Val.shrx_shr; eauto. intros [n [i' [ARG1 [ARG2 RES]]]].
  injection ARG2; intro ARG2'; subst i'; clear ARG2.
  set (islt := Int.lt n Int.zero) in *.
  set (rs1 := nextinstr (compare_int rs (Vint n) (Vint Int.zero) m)).
  assert (OTH1: forall r', data_preg r' = true -> rs1#r' = rs#r').
    generalize (compare_int_spec rs (Vint n) (Vint Int.zero) m).
    fold rs1. intros [A B]. intuition.
  exploit (addimm_correct IR14 x0 (Int.sub (Int.shl Int.one i) Int.one)).
  intros [rs2 [EXEC2 [RES2 OTH2]]].
  set (rs3 := nextinstr (if islt then rs2 else rs2#IR14 <- (Vint n))).
  set (rs4 := nextinstr (rs3#x <- (Val.shr rs3#IR14 (Vint i)))).
  exists rs4; split.
  apply exec_straight_step with rs1 m.
  simpl. rewrite ARG1. auto. auto.
  eapply exec_straight_trans. eexact EXEC2.
  apply exec_straight_two with rs3 m.
  simpl. rewrite OTH2; eauto with asmgen.
    change (rs1 CRge) with (Val.cmp Cge (Vint n) (Vint Int.zero)).
    unfold Val.cmp, Val.cmp_bool. change (Int.cmp Cge n Int.zero) with (negb islt).
    rewrite OTH2; eauto with asmgen. rewrite OTH1. rewrite ARG1.
    unfold rs3. case islt; reflexivity.
    rewrite <- (ireg_of_eq _ _ EQ1). auto with asmgen.
    auto.
    unfold rs3. destruct islt; auto. auto.
    split. unfold rs4; Simpl. unfold rs3. destruct islt.
    Simpl. rewrite RES2. unfold rs1. Simpl.
    Simpl. congruence.
    intros. unfold rs4, rs3; Simpl. destruct islt; Simpl; rewrite OTH2; auto with asmgen.
  (* intoffloat *)
  econstructor; split. apply exec_straight_one; simpl. rewrite H0; simpl. eauto. auto.
Transparent destroyed_by_op.
  simpl. intuition Simpl.
  (* intuoffloat *)
  econstructor; split. apply exec_straight_one; simpl. rewrite H0; simpl. eauto. auto.
  simpl. intuition Simpl.
  (* floatofint *)
  econstructor; split. apply exec_straight_one; simpl. rewrite H0; simpl. eauto. auto.
  intuition Simpl.
  (* floatofintu *)
  econstructor; split. apply exec_straight_one; simpl. rewrite H0; simpl. eauto. auto.
  intuition Simpl.
  (* Ocmp *)
  contradiction.
Qed.

Lemma transl_op_correct:
  forall op args res k c (rs: regset) m v,
  transl_op op args res k = OK c ->
  eval_operation ge rs#IR13 op (map rs (map preg_of args)) m = Some v ->
  exists rs',
     exec_straight ge fn c rs m k rs' m
  /\ Val.lessdef v rs'#(preg_of res)
  /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs'#r = rs#r.
Proof.
  intros.
  assert (EITHER: match op with Ocmp _ => False | _ => True end \/ exists cmp, op = Ocmp cmp).
    destruct op; auto. right; exists c0; auto.
  destruct EITHER as [A | [cmp A]].
  exploit transl_op_correct_same; eauto. intros [rs' [P [Q R]]].
  subst v. exists rs'; eauto.
  (* Ocmp *)
  subst op. simpl in H. monadInv H. simpl in H0. inv H0.
  rewrite (ireg_of_eq _ _ EQ).
  exploit transl_cond_correct; eauto. instantiate (1 := rs). instantiate (1 := m). intros [rs1 [A [B C]]].
  set (rs2 := nextinstr (rs1#x <- (Vint Int.zero))).
  set (rs3 := nextinstr (match rs2#(crbit_for_cond cmp) with
             | Vint n => if Int.eq n Int.zero then rs2 else rs2#x <- Vone
             | _      => rs2#x <- Vundef
             end)).
  exists rs3; split.
  eapply exec_straight_trans. eexact A. apply exec_straight_two with rs2 m.
  auto.
  simpl. unfold rs3. destruct (rs2 (crbit_for_cond cmp)); auto. destruct (Int.eq i Int.zero); auto.
  auto. unfold rs3.  destruct (rs2 (crbit_for_cond cmp)); auto. destruct (Int.eq i Int.zero); auto.
  split. unfold rs3. Simpl.
  replace (rs2 (crbit_for_cond cmp)) with (rs1 (crbit_for_cond cmp)).
  destruct (eval_condition cmp rs##(preg_of##args) m) as [[]|]; simpl in *.
  rewrite B. simpl. rewrite Int.eq_false. Simpl. apply Int.one_not_zero.
  rewrite B. simpl. rewrite Int.eq_true. unfold rs2. Simpl.
  auto.
  destruct cmp; reflexivity.
  intros. transitivity (rs2 r).
  unfold rs3. destruct (rs2 (crbit_for_cond cmp)); Simpl. destruct (Int.eq i Int.zero); auto; Simpl.
  unfold rs2. Simpl.
Qed.

(** Translation of loads and stores. *)

Remark val_add_add_zero:
  forall v1 v2, Val.add v1 v2 = Val.add (Val.add v1 v2) (Vint Int.zero).
Proof.
  intros. destruct v1; destruct v2; simpl; auto; rewrite Int.add_zero; auto.
Qed.

Lemma transl_memory_access_correct:
  forall (P: regset -> Prop) (mk_instr_imm: ireg -> int -> instruction)
         (mk_instr_gen: option (ireg -> shift_addr -> instruction))
         (mk_immed: int -> int)
         addr args k c (rs: regset) a m m',
  transl_memory_access mk_instr_imm mk_instr_gen mk_immed addr args k = OK c ->
  eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some a ->
  (forall (r1: ireg) (rs1: regset) n k,
    Val.add rs1#r1 (Vint n) = a ->
    (forall (r: preg), r <> PC -> r <> IR14 -> rs1 r = rs r) ->
    exists rs',
    exec_straight ge fn (mk_instr_imm r1 n :: k) rs1 m k rs' m' /\ P rs') ->
  match mk_instr_gen with
  | None => True
  | Some mk =>
      (forall (r1: ireg) (sa: shift_addr) k,
      Val.add rs#r1 (eval_shift_addr sa rs) = a ->
       exists rs',
      exec_straight ge fn (mk r1 sa :: k) rs m k rs' m' /\ P rs')
  end ->
  exists rs',
    exec_straight ge fn c rs m k rs' m' /\ P rs'.
Proof.
  intros until m'; intros TR EA MK1 MK2.
  unfold transl_memory_access in TR; destruct addr; ArgsInv; simpl in EA; inv EA.
  (* Aindexed *)
  apply indexed_memory_access_correct. exact MK1.
  (* Aindexed2 *)
  destruct mk_instr_gen as [mk | ]; monadInv TR. apply MK2.
  simpl. erewrite ! ireg_of_eq; eauto.
  (* Aindexed2shift *)
  destruct mk_instr_gen as [mk | ]; monadInv TR. apply MK2.
  erewrite ! ireg_of_eq; eauto. rewrite transl_shift_addr_correct. auto.
  (* Ainstack *)
  inv TR. apply indexed_memory_access_correct. exact MK1.
Qed.

Lemma transl_load_int_correct:
  forall mk_instr is_immed dst addr args k c (rs: regset) a chunk m v,
  transl_memory_access_int mk_instr is_immed dst addr args k = OK c ->
  eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some a ->
  Mem.loadv chunk m a = Some v ->
  (forall (r1 r2: ireg) (sa: shift_addr) (rs1: regset),
    exec_instr ge fn (mk_instr r1 r2 sa) rs1 m =
    exec_load chunk (Val.add rs1#r2 (eval_shift_addr sa rs1)) r1 rs1 m) ->
  exists rs',
      exec_straight ge fn c rs m k rs' m
   /\ rs'#(preg_of dst) = v
   /\ forall r, data_preg r = true -> r <> preg_of dst -> rs'#r = rs#r.
Proof.
  intros. monadInv H. erewrite ireg_of_eq by eauto.
  eapply transl_memory_access_correct; eauto.
  intros; simpl. econstructor; split. apply exec_straight_one.
  rewrite H2. unfold exec_load. simpl eval_shift_addr. rewrite H. rewrite H1. eauto. auto.
  split. Simpl. intros; Simpl.
  simpl; intros.
  econstructor; split. apply exec_straight_one.
  rewrite H2. unfold exec_load. rewrite H. rewrite H1. eauto. auto.
  split. Simpl. intros; Simpl.
Qed.

Lemma transl_load_float_correct:
  forall mk_instr is_immed dst addr args k c (rs: regset) a chunk m v,
  transl_memory_access_float mk_instr is_immed dst addr args k = OK c ->
  eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some a ->
  Mem.loadv chunk m a = Some v ->
  (forall (r1: freg) (r2: ireg) (n: int) (rs1: regset),
    exec_instr ge fn (mk_instr r1 r2 n) rs1 m =
    exec_load chunk (Val.add rs1#r2 (Vint n)) r1 rs1 m) ->
  exists rs',
      exec_straight ge fn c rs m k rs' m
   /\ rs'#(preg_of dst) = v
   /\ forall r, data_preg r = true -> r <> preg_of dst -> rs'#r = rs#r.
Proof.
  intros. monadInv H. erewrite freg_of_eq by eauto.
  eapply transl_memory_access_correct; eauto.
  intros; simpl. econstructor; split. apply exec_straight_one.
  rewrite H2. unfold exec_load. rewrite H. rewrite H1. eauto. auto.
  split. Simpl. intros; Simpl.
  simpl; auto.
Qed.

Lemma transl_store_int_correct:
  forall mr mk_instr is_immed src addr args k c (rs: regset) a chunk m m',
  transl_memory_access_int mk_instr is_immed src addr args k = OK c ->
  eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some a ->
  Mem.storev chunk m a rs#(preg_of src) = Some m' ->
  (forall (r1 r2: ireg) (sa: shift_addr) (rs1: regset),
    exec_instr ge fn (mk_instr r1 r2 sa) rs1 m =
    exec_store chunk (Val.add rs1#r2 (eval_shift_addr sa rs1)) r1 rs1 m) ->
  exists rs',
      exec_straight ge fn c rs m k rs' m'
   /\ forall r, data_preg r = true -> preg_notin r mr -> rs'#r = rs#r.
Proof.
  intros. monadInv H. erewrite ireg_of_eq in * by eauto.
  eapply transl_memory_access_correct; eauto.
  intros; simpl. econstructor; split. apply exec_straight_one.
  rewrite H2. unfold exec_store. simpl eval_shift_addr. rewrite H. rewrite H3; eauto with asmgen.
  rewrite H1. eauto. auto.
  intros; Simpl.
  simpl; intros.
  econstructor; split. apply exec_straight_one.
  rewrite H2. unfold exec_store. rewrite H. rewrite H1. eauto. auto.
  intros; Simpl.
Qed.

Lemma transl_store_float_correct:
  forall mr mk_instr is_immed src addr args k c (rs: regset) a chunk m m',
  transl_memory_access_float mk_instr is_immed src addr args k = OK c ->
  eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some a ->
  Mem.storev chunk m a rs#(preg_of src) = Some m' ->
  (forall (r1: freg) (r2: ireg) (n: int) (rs1: regset),
    exec_instr ge fn (mk_instr r1 r2 n) rs1 m =
    exec_store chunk (Val.add rs1#r2 (Vint n)) r1 rs1 m) ->
  exists rs',
      exec_straight ge fn c rs m k rs' m'
   /\ forall r, data_preg r = true -> preg_notin r mr -> rs'#r = rs#r.
Proof.
  intros. monadInv H. erewrite freg_of_eq in * by eauto.
  eapply transl_memory_access_correct; eauto.
  intros; simpl. econstructor; split. apply exec_straight_one.
  rewrite H2. unfold exec_store. rewrite H. rewrite H3; auto with asmgen. rewrite H1. eauto. auto.
  intros; Simpl.
  simpl; auto.
Qed.

Lemma transl_load_correct:
  forall chunk addr args dst k c (rs: regset) a m v,
  transl_load chunk addr args dst k = OK c ->
  eval_addressing ge (rs#SP) 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, data_preg r = true -> r <> preg_of dst -> rs'#r = rs#r.
Proof.
  intros. destruct chunk; simpl in H.
  eapply transl_load_int_correct; eauto.
  eapply transl_load_int_correct; eauto.
  eapply transl_load_int_correct; eauto.
  eapply transl_load_int_correct; eauto.
  eapply transl_load_int_correct; eauto.
  discriminate.
  eapply transl_load_float_correct; eauto.
  apply Mem.loadv_float64al32 in H1. eapply transl_load_float_correct; eauto.
  eapply transl_load_float_correct; eauto.
Qed.

Lemma transl_store_correct:
  forall chunk addr args src k c (rs: regset) a m m',
  transl_store chunk addr args src k = OK c ->
  eval_addressing ge (rs#SP) 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, data_preg r = true -> preg_notin r (destroyed_by_store chunk addr) -> rs'#r = rs#r.
Proof.
  intros. destruct chunk; simpl in H.
- 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 transl_store_int_correct; eauto.
- eapply transl_store_int_correct; eauto.
- 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 transl_store_int_correct; eauto.
- eapply transl_store_int_correct; eauto.
- eapply transl_store_int_correct; eauto.
- discriminate.
- unfold transl_memory_access_float in H. monadInv H. rewrite (freg_of_eq _ _ EQ) in *.
  eapply transl_memory_access_correct; eauto.
  intros. econstructor; split. apply exec_straight_one.
  simpl. unfold exec_store. rewrite H. rewrite H2; eauto with asmgen.
  rewrite H1. eauto. auto. intros. Simpl.
  simpl; auto.
- apply Mem.storev_float64al32 in H1. eapply transl_store_float_correct; eauto.
- eapply transl_store_float_correct; eauto.
Qed.

End CONSTRUCTORS.


(** * Terminal Object **)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Generalizable All Variables.

Set Primitive Projections.
Set Universe Polymorphism.

Require Import COC.Base.Main.
From COC.Cons Require Import Initial Terminal Product Coproduct Equalizer Coequalizer.

(** Initial and Terminal **)
Program Definition terminal_from_initial (C: Category)(i: Initial C): Terminal C^op :=
  [Terminal by (initial_univ i)].
Next Obligation.
  now apply initial_uniqueness.
Qed.

Program Definition initial_from_terminal (C: Category)(t: Terminal C): Initial C^op :=
  [Initial by (terminal_univ t)].
Next Obligation.
  now apply terminal_uniqueness.
Qed.

(** Product and Coproduct **)
Program Definition coproduct_from_product (C: Category)(X Y: C)(P: Product C X Y)
  : Coproduct C^op X Y :=
  [Coproduct by (fun (Z: C) f g => [f , g to P])
   with pi1_{P}, pi2_{P}].
Next Obligation.
  - now apply product_universality_1.
  - now apply product_universality_2.
  - now apply product_uniqueness.
Qed.

Program Definition product_from_coproduct (C: Category)(X Y: C)(CP: Coproduct C X Y)
  : Product C^op X Y :=
  [Product by (fun (Z: C) f g => [f , g from CP])
   with in1_{CP}, in2_{CP}].
Next Obligation.
  - now apply coproduct_universality_1.
  - now apply coproduct_universality_2.
  - now apply coproduct_uniqueness.
Qed.

(** Equalizer and Coequalizer **)
Program Definition coequalizer_from_equalizer (C: Category)(X Y: C)(f g: C X Y)(eq: Equalizer f g)
  : Coequalizer (C:=C^op) f g :=
  [Coequalizer by fun (Z: C)(h: C Z X)(Heq: f \o h == g \o h) =>
                    equalizer_univ eq Heq
   with equalizer_map eq].
Next Obligation.
  - now apply equalize.
  - now apply equalizer_universality.
  - now apply equalizer_uniqueness.
Qed.

Program Definition equalizer_from_coequalizer (C: Category)(X Y: C)(f g: C X Y)(coeq: Coequalizer f g)
  : Equalizer (C:=C^op) f g :=
  [Equalizer by fun (Z: C)(k: C Y Z)(Heq: k \o f == k \o g) =>
                    coequalizer_univ coeq Heq
   with coequalizer_map coeq].
Next Obligation.
  - now apply coequalize.
  - now apply coequalizer_universality.
  - now apply coequalizer_uniqueness.
Qed.


Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.
Require Import RamifyCoq.lib.Coqlib.
Require Import RamifyCoq.lib.Ensembles_ext.
Require Import RamifyCoq.lib.EquivDec_ext.
Require Import Coq.Lists.List.
Require Import RamifyCoq.msl_ext.ramification_lemmas.
Require Import RamifyCoq.graph.graph_model.
Require Import RamifyCoq.graph.path_lemmas.
Require Import RamifyCoq.graph.graph_gen.
Require Import RamifyCoq.graph.graph_relation.
Require Import RamifyCoq.graph.subgraph2.
Require Import RamifyCoq.graph.reachable_ind.
Require Import RamifyCoq.graph.spanning_tree.
Require Import RamifyCoq.graph.BiGraph.
Require Import RamifyCoq.graph.MathGraph.
Require Import RamifyCoq.graph.FiniteGraph.
Require Import RamifyCoq.msl_application.Graph.
Require Import RamifyCoq.msl_application.GraphBi.
Require Import RamifyCoq.msl_application.GraphBi_Mark.
Require RamifyCoq.graph.weak_mark_lemmas.
Import RamifyCoq.graph.weak_mark_lemmas.WeakMarkGraph.

(* TODO: Put some pure lemmas into some file like: graph/bi_spanning. *)

Instance MGS: MarkGraphSetting bool.
  apply (Build_MarkGraphSetting bool
          (eq true));
  intros.
  + destruct x; [left | right]; congruence.
Defined.

Section SPATIAL_GRAPH_DISPOSE_BI.

  Context {pSGG_Bi: pPointwiseGraph_Graph_Bi}.
  Context {sSGG_Bi: sPointwiseGraph_Graph_Bi bool unit}.

  Existing Instances maGraph biGraph finGraph.

  Local Open Scope logic.
  Local Coercion Graph_LGraph: Graph >-> LGraph.
  Local Coercion LGraph_SGraph: LGraph >-> SGraph.
  Local Identity Coercion Graph_GeneralGraph: Graph >-> GeneralGraph.
  Local Identity Coercion LGraph_LabeledGraph: LGraph >-> LabeledGraph.
  Local Identity Coercion SGraph_PointwiseGraph: SGraph >-> PointwiseGraph.
  Local Coercion pg_lg: LabeledGraph >-> PreGraph.

  Notation Graph := (@Graph pSGG_Bi bool unit unit).

  Lemma vgamma_is_true: forall (g : Graph) (x l r : addr), vgamma g x = (true, l, r) -> marked g x.
  Proof. intros. simpl in H. simpl. destruct (vlabel g x) eqn:? . auto. inversion H. Qed.

  Lemma vgamma_is_false: forall (g : Graph) (x l r : addr), vgamma g x = (false, l, r) -> unmarked g x.
  Proof.
    intros. simpl in H. hnf. unfold Ensembles.In. simpl. intro.
    destruct (vlabel g x) eqn:? . inversion H. simpl in H0. inversion H0.
  Qed.

  Lemma edge_spanning_tree_left_null:
    forall (g: Graph) x d l r, vvalid g x -> vgamma g x = (d, l, r) -> (marked g) l ->
                               edge_spanning_tree g (x, L) (Graph_gen_left_null g x).
  Proof.
    intros. assert (l = dst g (x, L)) by (simpl in H0; inversion H0; auto).
    hnf. change (lg_gg g) with (g: LGraph). destruct (node_pred_dec (marked g) (dst g (x, L))). 2: subst l; exfalso; auto.
    split.
    + hnf. simpl. split; [| split; [|split; [| split]]]; [tauto | tauto | tauto | | ].
      - intros. unfold updateEdgeFunc.
        destruct (equiv_dec (x, L) e); intuition.
      - right. unfold updateEdgeFunc.
        destruct (equiv_dec (x, L) (x, L)); intuition.
        * apply (valid_not_null g) in H3; auto. reflexivity.
        * apply (@left_valid _ _ _ _ _ _ g (biGraph g)) in H; auto.
    + simpl. tauto.
  Qed.

  Lemma graph_gen_left_null_ramify:
    forall (g: Graph) (x : addr) d (l r : addr),
      vvalid g x -> vgamma g x = (d, l, r) ->
      (reachable_vertices_at x g : pred) |-- vertex_at x (d, l, r) * (vertex_at x (d, null, r) -* vertices_at (reachable g x) (Graph_gen_left_null g x)).
  Proof.
    intros.
    replace (@vertex_at _ _ _ _ _ SGP x (d, l, r)) with (graph_vcell g x).
    2: {
      unfold graph_vcell; simpl.
      simpl in H0; rewrite H0; auto.
    }
    replace (@vertex_at _ _ _ _ _ SGP x (d, null, r)) with (graph_vcell (Graph_gen_left_null g x) x).
    2: {
      unfold graph_vcell; simpl.
      unfold updateEdgeFunc.
      destruct_eq_dec (x, L) (x, L). 2: exfalso; auto.
      destruct_eq_dec (x, L) (x, R). inversion H2.
      simpl in H0; inversion H0; auto.
    }
    apply vertices_at_ramif_1; auto.
    eexists; split; [| split].
    + apply Ensemble_join_Intersection_Complement.
      - unfold Included, Ensembles.In; intros; subst; apply reachable_by_refl; auto.
      - intros; destruct_eq_dec x x0; auto.
    + apply Ensemble_join_Intersection_Complement.
      - unfold Included, Ensembles.In; intros; subst; apply reachable_by_refl; auto.
      - intros; destruct_eq_dec x x0; auto.
    + rewrite vertices_identical_spec.
      simpl; intros.
      change (lg_gg g) with (g: LGraph).
      rewrite Intersection_spec in H1.
      destruct H1; unfold Complement, Ensembles.In in H2.
      simpl. unfold updateEdgeFunc.
      destruct_eq_dec (x, L) (x0, L).
      - inversion H3. exfalso; auto.
      - destruct_eq_dec (x, L) (x0, R). inversion H4. auto.
  Qed.

  Lemma graph_gen_left_null_ramify_weak:
    forall (g: Graph) (x : addr) d (l r : addr),
      vvalid g x -> vgamma g x = (d, l, r) ->
      (reachable_vertices_at x g : pred) |-- vertex_at x (d, l, r) * (vertex_at x (d, null, r) -* (reachable_vertices_at x (Graph_gen_left_null g x) * TT)).
  Proof.
    intros. pose proof (graph_gen_left_null_ramify g x d l r H H0).
    apply log_normalize.sepcon_weaken with (vertex_at x (d, null, r) -* vertices_at (reachable g x) (Graph_gen_left_null g x)); auto.
    apply wand_derives; auto. unfold reachable_vertices_at.
    cut ((vertices_at (reachable g x) (Graph_gen_left_null g x) : pred)
                     |-- vertices_at (reachable (Graph_gen_left_null g x) x)
                     (Graph_gen_left_null g x) * TT). auto. unfold vertices_at.
    apply iter_sepcon.pred_sepcon_prop_true_weak.
    - apply Graph_reachable_dec, weak_valid_vvalid_dec. right.
      unfold Graph_gen_left_null. simpl. apply H.
    - intro y. unfold Graph_gen_left_null. simpl.
      apply is_partial_graph_reachable, pregraph_gen_dst_is_partial_graph.
      apply invalid_null.
  Qed.

  Lemma graph_ramify_aux1_left: forall (g: Graph) x d l r,
      vvalid g x -> vgamma g x = (d, l, r) ->
      (reachable_vertices_at x g : pred) |-- reachable_vertices_at l g *
      (ALL  g' : Graph , !!spanning_tree g l g' --> (vertices_at (reachable g l) g' -* vertices_at (reachable g x) g')).
  Proof.
    intros. eapply vertices_at_ramif_xQ; auto.
    eexists; split; [| split].
    + eapply Prop_join_reachable_left; eauto.
    + intros. eapply Prop_join_reachable_left; eauto.
    + intros; rewrite vertices_identical_spec.
      intros.
      rewrite Intersection_spec in H2. unfold Complement, Ensembles.In in H2.
      destruct H2. simpl. f_equal; [f_equal |].
      - apply vlabel_eq. destruct H1. specialize (H1 x0).
        pose proof reachable_by_is_reachable g l x0 (unmarked g).
        tauto.
      - destruct H1 as [_ [? _]]. hnf in H1. simpl in H1.
        unfold predicate_weak_evalid in H1. destruct H1 as [_ [? [_ ?]]].
        specialize (H1 (x0, L)). specialize (H4 (x0, L)).
        assert (src g (x0, L) = x0)
          by (apply (@left_sound _ _ _ _ _ _ g (biGraph g) x0); apply reachable_foot_valid in H2; auto).
        change (lg_gg g) with (g: LGraph) in *.
        rewrite H5 in *.
        assert (evalid g (x0, L) /\ ~ g |= l ~o~> x0 satisfying (unmarked g)). {
          split.
          + apply reachable_foot_valid in H2.
            apply (@left_valid _ _ _ _ _ _ g (biGraph g)); auto.
          + intro; apply H3; apply reachable_by_is_reachable in H6; auto.
        } apply H4; intuition.
      - destruct H1 as [_ [? _]]. hnf in H1. simpl in H1.
        unfold predicate_weak_evalid in H1. destruct H1 as [_ [? [_ ?]]].
        specialize (H1 (x0, R)). specialize (H4 (x0, R)).
        assert (src g (x0, R) = x0)
          by (apply (@right_sound _ _ _ _ _ _ g (biGraph g) x0); apply reachable_foot_valid in H2; auto).
        change (lg_gg g) with (g: LGraph) in *.
        rewrite H5 in *.
        assert (evalid g (x0, R) /\ ~ g |= l ~o~> x0 satisfying (unmarked g)). {
          split.
          + apply reachable_foot_valid in H2.
            apply (@right_valid _ _ _ _ _ _ g (biGraph g)); auto.
          + intro; apply H3; apply reachable_by_is_reachable in H6; auto.
        } apply H4; intuition.
  Qed.

  Lemma totally_unmarked_root_ST_reachable_eq: forall (g1 g2: Graph) root,
      totally_unmarked g1 root -> spanning_tree g1 root g2 ->
      vertices_at (reachable g1 root) g2 = reachable_vertices_at root g2.
  Proof.
    intros. apply vertices_at_Same_set. rewrite Same_set_spec. hnf.
    apply spanning_tree_totally_unmarked_root_reachable; auto. intros.
    apply Graph_reachable_by_dec, weak_valid_vvalid_dec; right; auto.
  Qed.

  Lemma totally_unmarked_parent_ST_reachable_eq: forall (g1 g2: Graph) x l r,
      vvalid g1 x -> vgamma g1 x = (true, l, r) -> totally_unmarked g1 l ->
      spanning_tree g1 l g2 ->
      vertices_at (reachable g1 x) g2 = reachable_vertices_at x g2.
  Proof.
    intros. apply vertices_at_Same_set. rewrite Same_set_spec. hnf.
    assert (l = dst (lg_gg g1) (x, L)) by (simpl in H0; inversion H0; auto).
    apply spanning_tree_totally_unmarked_parent_reachable with (e := (x, L));
      auto; try rewrite <- H3; auto.
      - hnf. split.
        + apply (@left_valid _ _ _ _ _ _ g1 (biGraph g1)); auto.
        + apply (@left_sound _ _ _ _ _ _ g1 (biGraph g1) x); auto.
      - apply vgamma_is_true in H0. auto.
      - intros; apply Graph_reachable_by_dec, weak_valid_vvalid_dec; right; auto.
  Qed.
(*
  Lemma graph_ramify_aux1_left_weak: forall (g: Graph) x l r,
      vvalid g x -> vgamma g x = (true, l, r) -> totally_unmarked g l ->
      (reachable_vertices_at x g : pred) |-- reachable_vertices_at l g *
      (ALL  g' : Graph , !!spanning_tree g l g' --> (reachable_vertices_at l g' -* reachable_vertices_at x g')).
  Proof.
    intros. pose proof (@graph_ramify_aux1_left g x true l r H H0).
    eapply log_normalize.sepcon_weaken. 2: apply H2. clear H2.
    apply allp_derives. intros p. destruct p as [? g2]. simpl.
    rewrite <- imp_andp_adjoint. apply derives_extract_prop'. intros.
    rewrite prop_imp; auto. apply wand_derives.
    - rewrite <- totally_unmarked_root_ST_reachable_eq; auto.
    - rewrite (totally_unmarked_parent_ST_reachable_eq _ _ _ l r); auto.
  Qed.
*)
  Lemma edge_spanning_tree_left_vvalid: forall (g1 g2: Graph) x n,
      vvalid g1 x -> edge_spanning_tree g1 (x, L) g2 -> (vvalid g1 n <-> vvalid g2 n).
  Proof.
    intros. apply (edge_spanning_tree_vvalid g1 g2 (x, L) n); auto.
  Qed.

  Lemma edge_spanning_tree_right_vvalid: forall (g1 g2: Graph) x n,
      vvalid g1 x -> edge_spanning_tree g1 (x, R) g2 -> (vvalid g1 n <-> vvalid g2 n).
  Proof.
    intros. apply (edge_spanning_tree_vvalid g1 g2 (x, R) n); auto.
  Qed.

  Lemma edge_spanning_tree_left_reachable_vvalid: forall (g1 g2: Graph) x d l r,
      vvalid g1 x -> vgamma g1 x = (d, l, r) -> edge_spanning_tree g1 (x, L) g2 -> Included (reachable g1 x) (vvalid g2).
  Proof.
    intros. assert (x = src g1 (x, L)) by (symmetry; apply (@left_sound _ _ _ _ _ _ g1 (biGraph g1) x); auto).
    rewrite H2. apply edge_spanning_tree_reachable_vvalid; auto.
  Qed.

  Lemma edge_spanning_tree_left_vgamma: forall (g1 g2: Graph) x l r,
      vvalid g1 x -> vgamma g1 x = (true, l, r) -> edge_spanning_tree g1 (x, L) g2 -> exists l', vgamma g2 x = (true, l', r).
  Proof.
    intros. simpl. exists (dst g2 (x, L)).
    assert (Hvg2: vvalid g2 x) by (rewrite <- edge_spanning_tree_left_vvalid; eauto).
    unfold edge_spanning_tree in H1.
    change (lg_gg g1) with (g1: LGraph) in H1.
    destruct (node_pred_dec (marked g1) (dst g1 (x, L))).
    + destruct H1 as [[_ [_ [_ [? _]]]] ?]. simpl in H0, H2. inversion H0.
      rewrite H4. symmetry in H4. rewrite H2 in H4.
      change (lg_gg g2) with (g2: LGraph) in H4.
      rewrite <- H4. f_equal. symmetry. apply H1.
      - intro. inversion H3.
      - apply (@right_valid _ _ _ _ _ _ g1 (biGraph g1)) in H; auto.
      - apply (@right_valid _ _ _ _ _ _ g2 (biGraph g2)) in Hvg2; auto.
    + destruct H1 as [? [[_ [_ [_ ?]]] _]].
      assert (marked g1 x) by (simpl in *; inversion H0; auto).
      assert (~ g1 |= dst g1 (x, L) ~o~> x satisfying (unmarked g1)) by (intro HS; apply reachable_by_foot_prop in HS; auto).
      assert (marked g2 x) by (specialize (H1 x); tauto).
      simpl in H5. rewrite <- H5. f_equal.
      simpl in H2. unfold predicate_weak_evalid in H2.
      simpl in H0. inversion H0. symmetry.
      change (lg_gg g1) with (g1: LGraph) in *.
      change (lg_gg g2) with (g2: LGraph) in *.
      apply H2; split.
      - apply (@right_valid _ _ _ _ _ _ g1 (biGraph g1) x); auto.
      - rewrite (@right_sound _ _ _ _ _ _ g1 (biGraph g1) x); auto.
      - apply (@right_valid _ _ _ _ _ _ g2 (biGraph g2) x); auto.
      - rewrite (@right_sound _ _ _ _ _ _ g2 (biGraph g2) x); auto.
  Qed.

  Lemma spanning_tree_left_reachable:
    forall (g1 g2: Graph) x l r,
      vvalid g1 x -> vgamma g1 x = (true, l, r) ->
      spanning_tree g1 l g2 -> Included (reachable g2 r) (reachable g1 x).
  Proof.
    intros. intro v. unfold Ensembles.In . intros.
    assert (X: ReachDecidable g1 l (unmarked g1)). {
      apply Graph_reachable_by_dec.
      apply weak_valid_vvalid_dec.
      apply (gamma_left_weak_valid g1 x true l r); auto.
    } destruct (X v).
    + apply reachable_by_is_reachable in r0. apply edge_reachable_by with l; auto.
      split; [|split]; auto.
      - apply reachable_head_valid in r0. auto.
      - simpl in H0. inversion H0. exists (x, L); auto.
        * apply (@left_valid _ _ _ _ _ _ g1 (biGraph g1)); auto.
        * apply (@left_sound _ _ _ _ _ _ g1 (biGraph g1)); auto.
    + apply edge_reachable_by with r; auto.
      - split; [|split]; auto.
        * apply reachable_head_valid in H2.
          rewrite (spanning_tree_vvalid g1 l g2); auto.
        * rewrite (gamma_step g1 x true l r); auto.
      - apply (spanning_tree_not_reachable g1 l g2 r v) in H2; auto.
        rewrite reachable_by_eq_partialgraph_reachable in H2.
        destruct H1 as [? [? ?]]. rewrite <- H3 in H2.
        rewrite <- reachable_by_eq_partialgraph_reachable in H2.
        apply reachable_by_is_reachable in H2. apply H2.
  Qed.

  Lemma edge_spanning_tree_left_reachable:
    forall (g1 g2: Graph) x l r,
      vvalid g1 x -> vgamma g1 x = (true, l, r) ->
      edge_spanning_tree g1 (x, L) g2 -> Included (reachable g2 r) (reachable g1 x).
  Proof.
    intros. assert (Hv: vvalid g2 r -> vvalid g1 r). {
      intros. rewrite (edge_spanning_tree_left_vvalid g1 g2 x r); auto.
    } hnf in H1.
    assert (l = dst g1 (x, L))
      by (simpl in H0; inversion H0; auto).
    change (lg_gg g1) with (g1: LGraph) in *.
    rewrite <- H2 in H1. destruct (node_pred_dec (marked g1) l).
    + destruct H1 as [[? [? [? [? ?]]]] ?]. intro v. unfold Ensembles.In .
      intros. apply edge_reachable_by with r; auto.
      - split; [|split]; auto.
        * apply Hv. apply reachable_head_valid in H8; auto.
        * rewrite (gamma_step g1 x true l r); auto.
      - change (g1 |= r ~o~> v satisfying (fun _ : addr => True))
        with (reachable g1 r v).
        rewrite reachable_ind_reachable in H8. clear H0. induction H8.
        * rewrite reachable_ind_reachable. constructor. rewrite H1; auto.
        * destruct H0 as [? [? ?]]. apply edge_reachable with y.
          apply IHreachable. rewrite H1; auto.
          split; [|split]; [rewrite H1; auto .. |]. rewrite step_spec in H10 |- *.
          destruct H10 as [e [? [? ?]]]. exists e.
          assert (e <> (x, L)) by (intro; subst; destruct H6; [|destruct H2]; auto).
          specialize (H3 _ H13). specialize (H4 _ H13). specialize (H5 _ H13).
          subst x0. subst y. intuition.
    + apply (spanning_tree_left_reachable g1 g2 x l r); auto.
  Qed.

  Lemma Prop_join_EST_right: forall (g1 g2: Graph) x l r,
      vvalid g1 x -> vgamma g1 x = (true, l, r) ->
      edge_spanning_tree g1 (x, L) g2 ->
      Prop_join (reachable g2 r)
                (Intersection _ (reachable g1 x) (Complement addr (reachable g2 r)))
                (reachable g1 x).
  Proof.
    intros. apply Ensemble_join_Intersection_Complement.
    + eapply edge_spanning_tree_left_reachable; eauto.
    + intros.
      destruct (edge_spanning_tree_left_vgamma g1 g2 x l r H H0 H1) as [l' ?].
      apply gamma_right_weak_valid in H2.
      - apply decidable_prop_decidable, Graph_reachable_dec,
        weak_valid_vvalid_dec; auto.
      - apply (edge_spanning_tree_left_reachable_vvalid g1 g2 x true l r); auto.
        unfold Ensembles.In . apply reachable_by_refl; auto.
  Qed.

  Lemma graph_ramify_aux1_right: forall (g1 g2: Graph) x l r,
      vvalid g1 x -> vgamma g1 x = (true, l, r) ->
      edge_spanning_tree g1 (x, L) g2 ->
      (vertices_at (reachable g1 x) g2: pred) |-- reachable_vertices_at r g2 *
      (ALL  g' : Graph ,
                !!spanning_tree g2 r g' -->
                  (vertices_at (reachable g2 r) g' -*
                               vertices_at (reachable g1 x) g')).
  Proof.
    intros. eapply vertices_at_ramif_xQ; auto.
    eexists; split; [| split].
    + eapply Prop_join_EST_right; eauto.
    + intros. eapply Prop_join_EST_right; eauto.
    + intros; rewrite vertices_identical_spec.
      intros. simpl.
      rewrite Intersection_spec in H3; unfold Complement, Ensembles.In in H3.
      destruct H3. f_equal; [f_equal |].
      - apply vlabel_eq. destruct H2 as [? _]. specialize (H2 x0).
        pose proof reachable_by_is_reachable g2 r x0 (unmarked g2).
        tauto.
      - destruct H2 as [_ [? _]]. hnf in H2. simpl in H2.
        unfold predicate_weak_evalid in H2. destruct H2 as [_ [? [_ ?]]].
        specialize (H2 (x0, L)). specialize (H5 (x0, L)).
        assert (src g2 (x0, L) = x0).
        1: {
          apply (@left_sound _ _ _ _ _ _ g2 (biGraph g2) x0).
          rewrite <- (edge_spanning_tree_left_vvalid g1 g2 x x0 H H1).
          apply reachable_foot_valid in H3; auto.
        }
        change (lg_gg g2) with (g2: LGraph) in *.
        rewrite H6 in *.
        assert (evalid g2 (x0, L) /\ ~ g2 |= r ~o~> x0 satisfying (unmarked g2)). {
          split.
          + apply reachable_foot_valid in H3.
            apply (@left_valid _ _ _ _ _ _ g2 (biGraph g2)).
            rewrite <- (edge_spanning_tree_left_vvalid g1 g2 x); eauto.
          + intro; apply H4; apply reachable_by_is_reachable in H7; auto.
        } apply H5; intuition.
      - destruct H2 as [_ [? _]]. hnf in H2. simpl in H2.
        unfold predicate_weak_evalid in H2. destruct H2 as [_ [? [_ ?]]].
        specialize (H2 (x0, R)). specialize (H5 (x0, R)).
        assert (src g2 (x0, R) = x0).
        1: {
          apply (@right_sound _ _ _ _ _ _ g2 (biGraph g2) x0).
          rewrite <- (edge_spanning_tree_left_vvalid g1 g2 x x0 H H1).
          apply reachable_foot_valid in H3; auto.
        }
        change (lg_gg g2) with (g2: LGraph) in *.
        rewrite H6 in *.
        assert (evalid g2 (x0, R) /\ ~ g2 |= r ~o~> x0 satisfying (unmarked g2)). {
          split.
          + apply reachable_foot_valid in H3.
            apply (@right_valid _ _ _ _ _ _ g2 (biGraph g2)).
            rewrite <- (edge_spanning_tree_left_vvalid g1 g2 x); eauto.
          + intro; apply H4; apply reachable_by_is_reachable in H7; auto.
        } apply H5; intuition.
  Qed.

  Lemma graph_gen_right_null_ramify: forall (g1 g2: Graph) (x : addr) d (l r : addr),
      vvalid g1 x -> vgamma g2 x = (d, l, r) ->
      (vertices_at (reachable g1 x) g2 : pred) |--
                  vertex_at x (d, l, r) * (vertex_at x (d, l, null) -* vertices_at (reachable g1 x) (Graph_gen_right_null g2 x)).
  Proof.
    intros.
    replace (@vertex_at _ _ _ _ _ SGP x (d, l, r)) with (graph_vcell g2 x).
    2: {
      unfold graph_vcell; simpl.
      simpl in H0; rewrite H0; auto.
    }
    replace (@vertex_at _ _ _ _ _ SGP x (d, l, null)) with (graph_vcell (Graph_gen_right_null g2 x) x).
    2: {
      unfold graph_vcell; simpl.
      unfold updateEdgeFunc.
      destruct_eq_dec (x, R) (x, L). inversion H1.
      destruct_eq_dec (x, R) (x, R). 2: exfalso; apply H2; auto.
      simpl in H0; inversion H0; auto.
    }
    apply vertices_at_ramif_1; auto.
    eexists; split; [| split].
    + apply Ensemble_join_Intersection_Complement.
      - unfold Included, Ensembles.In; intros; subst; apply reachable_by_refl; auto.
      - intros; destruct_eq_dec x x0; auto.
    + apply Ensemble_join_Intersection_Complement.
      - unfold Included, Ensembles.In; intros; subst; apply reachable_by_refl; auto.
      - intros; destruct_eq_dec x x0; auto.
    + rewrite vertices_identical_spec.
      simpl; intros.
      change (lg_gg g2) with (g2: LGraph).
      rewrite Intersection_spec in H1.
      destruct H1; unfold Complement, Ensembles.In in H2.
      simpl. unfold updateEdgeFunc.
      destruct_eq_dec (x, R) (x0, L).
      - inversion H3.
      - destruct_eq_dec (x, R) (x0, R).
        * inversion H4. exfalso; auto.
        * auto.
  Qed.

  Lemma graph_gen_right_null_ramify_weak: forall (g2: Graph) (x : addr) d (l r : addr),
      vvalid g2 x -> vgamma g2 x = (d, l, r) ->
      (reachable_vertices_at x g2 : pred) |-- vertex_at x (d, l, r) * (vertex_at x (d, l, null) -* (reachable_vertices_at x (Graph_gen_right_null g2 x) * TT)).
  Proof.
    intros. pose proof (graph_gen_right_null_ramify g2 g2 x d l r H H0).
    apply log_normalize.sepcon_weaken with (vertex_at x (d, l, null) -* vertices_at (reachable g2 x) (Graph_gen_right_null g2 x)); auto.
    apply wand_derives; auto. unfold reachable_vertices_at.
    cut ((vertices_at (reachable g2 x) (Graph_gen_right_null g2 x): pred)
           |-- vertices_at (reachable (Graph_gen_right_null g2 x) x)
           (Graph_gen_right_null g2 x) * TT). auto. unfold vertices_at.
    apply iter_sepcon.pred_sepcon_prop_true_weak.
    - apply Graph_reachable_dec, weak_valid_vvalid_dec. right.
      unfold Graph_gen_left_null. simpl. apply H.
    - intro y. unfold Graph_gen_left_null. simpl.
      apply is_partial_graph_reachable, pregraph_gen_dst_is_partial_graph.
      apply invalid_null.
  Qed.

  Lemma edge_spanning_tree_right_null:
    forall (g: Graph) x d l r, vvalid g x -> vgamma g x = (d, l, r) -> (marked g) r ->
                               edge_spanning_tree g (x, R) (Graph_gen_right_null g x).
  Proof.
    intros. assert (r = dst g (x, R)) by (simpl in H0; inversion H0; auto).
    hnf.
    change (lg_gg g) with (g: LGraph). destruct (node_pred_dec (marked g) (dst g (x, R))). 2: subst r; exfalso; auto.
    split.
    + hnf. simpl. split; [| split; [|split; [| split]]]; [tauto | tauto | tauto | | ].
      - intros. unfold updateEdgeFunc.
        destruct (equiv_dec (x, R) e); intuition.
      - right. split; auto. unfold updateEdgeFunc.
        destruct (equiv_dec (x, R) (x, R)); intuition.
        * apply (valid_not_null g) in H3; auto. reflexivity.
        * split; auto. apply (@right_valid _ _ _ _ _ _ g (biGraph g)) in H; auto.
    + simpl. tauto.
  Qed.

  Lemma edge_spanning_tree_spanning_tree: forall (g g1 g2 g3 : Graph) x l r,
      vvalid g x -> vvalid g1 x -> vvalid g2 x ->
      vgamma g x = (false, l, r) ->
      vgamma g1 x = (true, l, r) ->
      mark1 x g g1 ->
      edge_spanning_tree g1 (x, L) g2 ->
      edge_spanning_tree g2 (x, R) g3 ->
      spanning_tree g x g3.
  Proof.
    intros.
    apply (spanning_list_spanning_tree2 _ g1 _ _ (x, L) (x, R)); auto; intros.
    + intro. inversion H7.
    + pose proof (only_two_edges x e H). simpl in H7 |-* .
      split; intros.
      - destruct H8 as [? | [? | ?]]; [subst e..|exfalso; auto].
        * split; [|intuition]. apply (@left_valid _ _ _ _ _ _ g (biGraph g)); auto.
        * split; [|intuition]. apply (@right_valid _ _ _ _ _ _ g (biGraph g)); auto.
      - destruct H8. intuition.
    + apply Graph_reachable_by_dec. apply weak_valid_vvalid_dec. pose proof H3.
      simpl in H3. inversion H3. subst l.
      apply (gamma_left_weak_valid g1 x true (dst g1 (x, L)) r); auto.
    + unfold unmarked. rewrite negateP_spec. unfold marked. simpl. simpl in H2.
      inversion H2.
      change (lg_gg g) with (g: LGraph).
      rewrite H8. intuition.
    + apply spanning_list_cons with g2; auto.
      apply spanning_list_cons with g3; auto.
      apply spanning_list_nil. auto.
  Qed.

End SPATIAL_GRAPH_DISPOSE_BI.


From sflib Require Import sflib.
From Paco Require Import paco.
Require Import Coq.Classes.RelationClasses Lia Program.
From Fairness Require Export
     ITreeLib WFLib FairBeh Mod pind Axioms
     Linking SCM Red IRed.
From PromisingSEQ Require Import View.
From Ordinal Require Export ClassicalHessenberg.
From Fairness Require Import NatStructsLow.

Set Implicit Arguments.

Module AbsLock.

  Definition lock_fun
    : ktree (programE thread_id (bool * NatMap.t unit)%type) unit unit :=
    fun _ =>
      _ <- trigger Yield;;
      tid <- trigger (GetTid);;
      '(own, ts) <- trigger (Get id);;
      let ts := NatMap.add tid tt ts in
      _ <- trigger (Put (own, ts));;
      _ <- (ITree.iter
             (fun (_: unit) =>
                _ <- trigger Yield;;
                '(own, ts) <- trigger (Get id);;
                if (Bool.eqb own true)
                then Ret (inl tt)
                else Ret (inr tt)) tt);;
      '(_, ts) <- trigger (Get id);;
      let ts := NatMap.remove tid ts in
      _ <- trigger (Put (true, ts));;
      _ <- trigger (Fair (fun i => if tid_dec i tid then Flag.success
                               else if (NatMapP.F.In_dec ts i) then Flag.fail
                                    else Flag.emp));;
      _ <- trigger Yield;;
      Ret tt.

  Definition unlock_fun
    : ktree (programE thread_id (bool * NatMap.t unit)%type) unit unit :=
    fun _ =>
      _ <- trigger Yield;;
      '(own, ts) <- trigger (Get id);;
      if (Bool.eqb own true)
      then _ <- trigger (Put (false, ts));; _ <- trigger Yield;; Ret tt
      else UB.

  Definition mod: Mod.t :=
    Mod.mk
      (false, NatMap.empty unit)
      (Mod.get_funs [("lock", Mod.wrap_fun lock_fun);
                     ("unlock", Mod.wrap_fun unlock_fun)]).

End AbsLock.

Module AbsLockW.

  Definition st := (((bool * View.t) * bool) * NatMap.t unit)%type.

  Definition lock_fun
    : ktree (programE thread_id st) View.t View.t :=
    fun tvw =>
      _ <- trigger Yield;;
      tid <- trigger (GetTid);;
      '(own_lvw, ts) <- trigger (Get id);;
      let ts := NatMap.add tid tt ts in
      _ <- trigger (Put (own_lvw, ts));;
      _ <- (ITree.iter
             (fun (_: unit) =>
                _ <- trigger Yield;;
                '(((own, _), _), _) <- trigger (Get id);;
                match own with
                | true => Ret (inl tt)
                | false => Ret (inr tt)
                end)
             tt);;
      '(((_, tvw_lock), ing), ts) <- trigger (Get id);;
      if (ing: bool)
      (* then UB *)
      then trigger (Choose (void)) >>= (Empty_set_rect _)
      else
        let ts := NatMap.remove tid ts in
        '(exist _ tvw' _) <- trigger (Choose (sig (fun tvw' => View.le (View.join tvw tvw_lock) tvw')));;
        (* to prove weak mem ticket lock, needs to store tvw_lock, not tvw';
           this is related to now_serving's points_to's V and Q, which is not updated at lock
         *)
        _ <- trigger (Put (((true, tvw_lock), false), ts));;
        _ <- trigger (Fair (fun i => if tid_dec i tid then Flag.success
                                 else if (NatMapP.F.In_dec ts i) then Flag.fail
                                      else Flag.emp));;
        _ <- trigger Yield;;
        Ret tvw'.

  Definition unlock_fun
    : ktree (programE thread_id st) View.t View.t :=
    fun tvw =>
      _ <- trigger Yield;;
      '(((own, lvw), ing), ts) <- trigger (Get id);;
      if (excluded_middle_informative (View.le lvw tvw))
      then
        match own, ing with
        | true, false =>
            _ <- trigger (Put (((own, lvw), true), ts));;
            _ <- trigger Yield;;
            '(((_, _), _), ts) <- trigger (Get id);;
            (* tvw_V <- trigger (Choose (View.t));; *)
            '(exist _ tvw_V _) <- trigger (Choose (sig (fun tvw' => View.le tvw tvw')));;
            _ <- trigger (Put (((false, tvw_V), false), ts));;
            (* '(exist _ tvw' _) <- trigger (Choose (sig (fun tvw' => View.le (View.join tvw tvw_V) tvw')));; *)
            '(exist _ tvw' _) <- trigger (Choose (sig (fun tvw' => View.le tvw_V tvw')));;
            _ <- trigger Yield;;
            Ret tvw'
        | _, _ => UB
        end
      else UB.

  Definition mod: Mod.t :=
    Mod.mk
      (((false, View.bot), false), NatMap.empty unit)
      (Mod.get_funs [("lock", Mod.wrap_fun lock_fun);
                     ("unlock", Mod.wrap_fun unlock_fun)]).

End AbsLockW.

(* Module FairLock. *)
(*   Definition lock_fun: WMod.function bool unit void := *)
(*     WMod.mk_fun *)
(*       tt *)
(*       (fun (_: unit) st next => *)
(*          match st with *)
(*          | true => next = WMod.disabled *)
(*          | false => next = WMod.normal true tt (sum_fmap_l (fun _ => Flag.fail)) *)
(*          end). *)

(*   Definition unlock_fun: WMod.function bool unit void := *)
(*     WMod.mk_fun *)
(*       tt *)
(*       (fun (_: unit) st next => *)
(*          match st with *)
(*          | false => next = WMod.stuck *)
(*          | true => next = WMod.normal false tt (sum_fmap_l (fun _ => Flag.emp)) *)
(*          end). *)

(*   Definition wmod: WMod.t := *)
(*     WMod.mk *)
(*       false *)
(*       [("lock", lock_fun); *)
(*        ("unlock", unlock_fun) *)
(*       ]. *)

(*   Definition mod: Mod.t := *)
(*     WMod.interp_mod wmod. *)
(* End FairLock. *)

(* From Fairness Require Export WMM. *)

(* Module FairLockW. *)
(*   Definition lock_fun: WMod.function (option View.t) unit void := *)
(*     WMod.mk_fun *)
(*       tt *)
(*       (fun (tvw: View.t) st next => *)
(*          match st with *)
(*          | None => next = WMod.disabled *)
(*          | Some tvw_lock => *)
(*              next = WMod.normal None (View.join tvw tvw_lock) (sum_fmap_l (fun _ => Flag.fail)) *)
(*          end). *)

(*   Definition unlock_fun: WMod.function (option View.t) unit void := *)
(*     WMod.mk_fun *)
(*       tt *)
(*       (fun (tvw: View.t) st next => *)
(*          match st with *)
(*          | Some _ => next = WMod.stuck *)
(*          | None => next = WMod.normal (Some tvw) tvw (sum_fmap_l (fun _ => Flag.emp)) *)
(*          end). *)

(*   Definition wmod: WMod.t := *)
(*     WMod.mk *)
(*       (Some View.bot) *)
(*       [("lock", lock_fun); *)
(*        ("unlock", unlock_fun) *)
(*       ]. *)

(*   Definition mod: Mod.t := *)
(*     WMod.interp_mod wmod. *)
(* End FairLockW. *)


Require Import Io.All.
Require Model.
Require Import Semantics.

Module C.
  Module DeadLockFree.
    Inductive t {E S A} (m : Model.t E S) (s : S) (x : C.t E A) : Prop :=
    | New :
      (exists p, exists v, C.Last.Eval.t p x v) \/
        (exists c, exists x', exists s', C.Step.t m c s x x' s') ->
      (forall c x' s', C.Step.t m c s x x' s' -> t m s' x') ->
      t m s x.
  End DeadLockFree.
End C.

Module Choose.
  Module DeadLockFree.
    Inductive t {E S A} (m : Model.t E S) (s : S) (x : Choose.t E A) : Prop :=
    | New :
      (exists p, exists v, Choose.Last.Eval.t p x v) \/
        (exists c, exists x', exists s', Choose.Step.t m c s x x' s') ->
      (forall c x' s', Choose.Step.t m c s x x' s' -> t m s' x') ->
      t m s x.
  End DeadLockFree.
End Choose.


Require Import Coq.Lists.List.
Require Import Coq.Bool.Bool.
Require Import NetCore.NetCoreEval.
Require Import Common.Types.
Require Import Classifier.Classifier.
Require Import Word.WordInterface.
Require Import Pattern.Pattern.
(* TODO: MJR Move 'switchId' from messagesDef so that we don't have to include this whole thing *)
Require Import OpenFlow.OpenFlow0x01Types.
Require Import NetCore.NetCoreTypes.
Require Import Network.NetworkPacket.

Set Implicit Arguments.

Import ListNotations.

Fixpoint desugar_pred (p : predicate) := match p with
  | DlSrc eth => PrHdr (Pattern.dlSrc eth)
  | DlDst eth => PrHdr (Pattern.dlDst eth)
  (* | DlTyp typ => PrHdr (Pattern.dlType typ) *)
  (* | DlVlan (Some vlan) => PrHdr (Pattern.dlVlan vlan) *)
  (* | DlVlan None => PrHdr (Pattern.dlVlan VLAN_NONE) *)
  (* | NwProto proto => PrHdr (Pattern.nwProto proto) *)
  | Switch sw => PrOnSwitch sw
  | InPort pt => PrHdr (Pattern.inPort pt)
  | And p1 p2 =>
      (* de Morgan's law *)
      PrNot (PrOr (PrNot (desugar_pred p1)) (PrNot (desugar_pred p2)))
  | Or p1 p2 => PrOr (desugar_pred p1) (desugar_pred p2)
  | Not p => PrNot (desugar_pred p)
  | All => PrAll
  | NoPackets => PrNone
end.

Definition desugar_action (a : action) :=
  match a with
    | To p => Forward unmodified (PhysicalPort  p)
    | ToAll => Forward unmodified AllPorts
    | GetPacket f => ActGetPkt (MkId 0)
  end.

Fixpoint desugar_actions acts :=
  match acts with
    | [] => []
    | a :: acts => (desugar_action a) :: desugar_actions acts
end.

Fixpoint desugar_pol' p pr :=
  match p with
    | Policy pred act => PoAtom (desugar_pred (And pred pr)) (desugar_actions act)
    | Par p1 p2 => PoUnion (desugar_pol' p1 pr) (desugar_pol' p2 pr)
    (* | Restrict p pr' => desugar_pol' p (And pr' pr) *)
  end.

Definition desugar_pol (p : policy) := desugar_pol' p All.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsRef2.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition table_destroy3_spec0 (g_rd: Pointer) (map_addr: Z64) (rtt_addr: Z64) (level: Z64) (adt: RData) : option (RData * Z64) :=
    match g_rd, map_addr, rtt_addr, level with
    | (_g_rd_base, _g_rd_ofst), VZ64 _map_addr, VZ64 _rtt_addr, VZ64 _level =>
      rely is_int64 _map_addr;
      rely is_int64 _rtt_addr;
      rely is_int64 _level;
      when' _t'1, adt == table_destroy2_spec (_g_rd_base, _g_rd_ofst) (VZ64 _map_addr) (VZ64 _rtt_addr) (VZ64 _level) adt;
      rely is_int64 _t'1;
      Some (adt, (VZ64 _t'1))
     end
    .

End SpecLow.


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

Set Implicit Arguments.
Unset Strict Implicit.
Require Export Ring_cat.
(** Title "The category of integral domains." *)
Section Objects.

Definition idomain_prop (R : CRING) :=
  forall x y : R,
  ~ Equal x (monoid_unit R) ->
  ~ Equal y (monoid_unit R) -> ~ Equal (ring_mult x y) (monoid_unit R).

Record idomain_on (R : cring) : Type :=  {idomain_prf : idomain_prop R}.

Record idomain : Type :=
  {idomain_ring :> cring; idomain_on_def :> idomain_on idomain_ring}.
Coercion Build_idomain : idomain_on >-> idomain.

Definition INTEGRAL_DOMAIN :=
  full_subcat (C:=CRING) (C':=idomain) idomain_ring.
End Objects.