(* *********************************************************************)
(*                                                                     *)
(*              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 GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Dynamic semantics for the Compcert C language *)

Require Import Coqlib.
Require Import Errors.
Require Import Maps.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import AST.
Require Import Memory.
Require Import Events.
Require Import Globalenvs.
Require Import Csyntax.
Require Import Smallstep.

(** * Semantics of type-dependent operations *)

(** Semantics of casts.  [sem_cast v1 t1 t2 = Some v2] if value [v1],
  viewed with static type [t1], can be cast to type [t2],
  resulting in value [v2].  *)

Definition cast_int_int (sz: intsize) (sg: signedness) (i: int) : int :=
  match sz, sg with
  | I8, Signed => Int.sign_ext 8 i
  | I8, Unsigned => Int.zero_ext 8 i
  | I16, Signed => Int.sign_ext 16 i
  | I16, Unsigned => Int.zero_ext 16 i
  | I32, _ => i
  | IBool, _ => if Int.eq i Int.zero then Int.zero else Int.one
  end.

Definition cast_int_float (si : signedness) (i: int) : float :=
  match si with
  | Signed => Float.floatofint i
  | Unsigned => Float.floatofintu i
  end.

Definition cast_float_int (si : signedness) (f: float) : option int :=
  match si with
  | Signed => Float.intoffloat f
  | Unsigned => Float.intuoffloat f
  end.

Definition cast_float_float (sz: floatsize) (f: float) : float :=
  match sz with
  | F32 => Float.singleoffloat f
  | F64 => f
  end.

Function sem_cast (v: val) (t1 t2: type) : option val :=
  match classify_cast t1 t2 with
  | cast_case_neutral =>
      match v with
      | Vint _ | Vptr _ _ => Some v
      | _ => None
      end
  | cast_case_i2i sz2 si2 =>
      match v with
      | Vint i => Some (Vint (cast_int_int sz2 si2 i))
      | _ => None
      end
  | cast_case_f2f sz2 =>
      match v with
      | Vfloat f => Some (Vfloat (cast_float_float sz2 f))
      | _ => None
      end
  | cast_case_i2f si1 sz2 =>
      match v with
      | Vint i => Some (Vfloat (cast_float_float sz2 (cast_int_float si1 i)))
      | _ => None
      end
  | cast_case_f2i sz2 si2 =>
      match v with
      | Vfloat f =>
          match cast_float_int si2 f with
          | Some i => Some (Vint (cast_int_int sz2 si2 i))
          | None => None
          end
      | _ => None
      end
  | cast_case_ip2bool =>
      match v with
      | Vint i => Some (Vint (cast_int_int IBool Signed i))
      | Vptr _ _ => Some (Vint Int.one)
      | _ => None
      end
  | cast_case_f2bool =>
      match v with
      | Vfloat f =>
          Some(Vint(if Float.cmp Ceq f Float.zero then Int.zero else Int.one))
      | _ => None
      end
  | cast_case_struct id1 fld1 id2 fld2 =>
      if ident_eq id1 id2 && fieldlist_eq fld1 fld2 then Some v else None
  | cast_case_union id1 fld1 id2 fld2 =>
      if ident_eq id1 id2 && fieldlist_eq fld1 fld2 then Some v else None
  | cast_case_void =>
      Some v
  | cast_case_default =>
      None
  end.

(** Interpretation of values as truth values.
  Non-zero integers, non-zero floats and non-null pointers are
  considered as true.  The integer zero (which also represents
  the null pointer) and the float 0.0 are false. *)

Function bool_val (v: val) (t: type) : option bool :=
  match v, t with
  | Vint n, (Tint _ _ _ | Tpointer _ _ | Tarray _ _ _ | Tfunction _ _) => Some (negb (Int.eq n Int.zero))
  | Vptr b ofs, (Tint _ _ _ | Tpointer _ _ | Tarray _ _ _ | Tfunction _ _) => Some true
  | Vfloat f, Tfloat sz _ => Some (negb(Float.cmp Ceq f Float.zero))
  | _, _ => None
  end.

(** The following [sem_] functions compute the result of an operator
  application.  Since operators are overloaded, the result depends
  both on the static types of the arguments and on their run-time values.
  For binary operations, the "usual binary conversions", adapted to a 32-bit
  platform, state that:
- If both arguments are of integer type, an integer operation is performed.
  For operations that behave differently at unsigned and signed types
  (e.g. division, modulus, comparisons), the unsigned operation is selected
  if at least one of the arguments is of type "unsigned int32", otherwise
  the signed operation is performed.
- If both arguments are of float type, a float operation is performed.
  We choose to perform all float arithmetic in double precision,
  even if both arguments are single-precision floats.
- If one argument has integer type and the other has float type,
  we convert the integer argument to float, then perform the float operation.
 *)

Function sem_neg (v: val) (ty: type) : option val :=
  match classify_neg ty with
  | neg_case_i sg =>
      match v with
      | Vint n => Some (Vint (Int.neg n))
      | _ => None
      end
  | neg_case_f =>
      match v with
      | Vfloat f => Some (Vfloat (Float.neg f))
      | _ => None
      end
  | neg_default => None
  end.

Function sem_notint (v: val) (ty: type): option val :=
  match classify_notint ty with
  | notint_case_i sg =>
      match v with
      | Vint n => Some (Vint (Int.xor n Int.mone))
      | _ => None
      end
  | notint_default => None
  end.

Function sem_notbool (v: val) (ty: type) : option val :=
  match classify_bool ty with
  | bool_case_ip =>
      match v with
      | Vint n => Some (Val.of_bool (Int.eq n Int.zero))
      | Vptr _ _ => Some Vfalse
      | _ => None
      end
  | bool_case_f =>
      match v with
      | Vfloat f => Some (Val.of_bool (Float.cmp Ceq f Float.zero))
      | _ => None
      end
  | bool_default => None
  end.

Function sem_add (v1:val) (t1:type) (v2: val) (t2:type) : option val :=
  match classify_add t1 t2 with
  | add_case_ii sg =>                   (**r integer addition *)
      match v1, v2 with
      | Vint n1, Vint n2 => Some (Vint (Int.add n1 n2))
      | _,  _ => None
      end
  | add_case_ff =>                      (**r float addition *)
      match v1, v2 with
      | Vfloat n1, Vfloat n2 => Some (Vfloat (Float.add n1 n2))
      | _,  _ => None
      end
  | add_case_if sg =>                   (**r int plus float *)
      match v1, v2 with
      | Vint n1, Vfloat n2 => Some (Vfloat (Float.add (cast_int_float sg n1) n2))
      | _, _ => None
      end
  | add_case_fi sg =>                   (**r float plus int *)
      match v1, v2 with
      | Vfloat n1, Vint n2 => Some (Vfloat (Float.add n1 (cast_int_float sg n2)))
      | _, _ => None
      end
  | add_case_pi ty _ =>                 (**r pointer plus integer *)
      match v1,v2 with
      | Vptr b1 ofs1, Vint n2 =>
        Some (Vptr b1 (Int.add ofs1 (Int.mul (Int.repr (sizeof ty)) n2)))
      | _,  _ => None
      end
  | add_case_ip ty _ =>                 (**r integer plus pointer *)
      match v1,v2 with
      | Vint n1, Vptr b2 ofs2 =>
        Some (Vptr b2 (Int.add ofs2 (Int.mul (Int.repr (sizeof ty)) n1)))
      | _,  _ => None
      end
  | add_default => None
end.

Function sem_sub (v1:val) (t1:type) (v2: val) (t2:type) : option val :=
  match classify_sub t1 t2 with
  | sub_case_ii sg =>            (**r integer subtraction *)
      match v1,v2 with
      | Vint n1, Vint n2 => Some (Vint (Int.sub n1 n2))
      | _,  _ => None
      end
  | sub_case_ff =>               (**r float subtraction *)
      match v1,v2 with
      | Vfloat f1, Vfloat f2 => Some (Vfloat(Float.sub f1 f2))
      | _,  _ => None
      end
  | sub_case_if sg =>            (**r int minus float *)
      match v1, v2 with
      | Vint n1, Vfloat n2 => Some (Vfloat (Float.sub (cast_int_float sg n1) n2))
      | _, _ => None
      end
  | sub_case_fi sg =>            (**r float minus int *)
      match v1, v2 with
      | Vfloat n1, Vint n2 => Some (Vfloat (Float.sub n1 (cast_int_float sg n2)))
      | _, _ => None
      end
  | sub_case_pi ty =>            (**r pointer minus integer *)
      match v1,v2 with
      | Vptr b1 ofs1, Vint n2 =>
            Some (Vptr b1 (Int.sub ofs1 (Int.mul (Int.repr (sizeof ty)) n2)))
      | _,  _ => None
      end
  | sub_case_pp ty =>          (**r pointer minus pointer *)
      match v1,v2 with
      | Vptr b1 ofs1, Vptr b2 ofs2 =>
          if zeq b1 b2 then
            if Int.eq (Int.repr (sizeof ty)) Int.zero then None
            else Some (Vint (Int.divu (Int.sub ofs1 ofs2) (Int.repr (sizeof ty))))
          else None
      | _, _ => None
      end
  | sub_default => None
  end.

Function sem_mul (v1:val) (t1:type) (v2: val) (t2:type) : option val :=
 match classify_mul t1 t2 with
  | mul_case_ii sg =>
      match v1,v2 with
      | Vint n1, Vint n2 => Some (Vint (Int.mul n1 n2))
      | _,  _ => None
      end
  | mul_case_ff =>
      match v1,v2 with
      | Vfloat f1, Vfloat f2 => Some (Vfloat (Float.mul f1 f2))
      | _,  _ => None
      end
  | mul_case_if sg =>
      match v1, v2 with
      | Vint n1, Vfloat n2 => Some (Vfloat (Float.mul (cast_int_float sg n1) n2))
      | _, _ => None
      end
  | mul_case_fi sg =>
      match v1, v2 with
      | Vfloat n1, Vint n2 => Some (Vfloat (Float.mul n1 (cast_int_float sg n2)))
      | _, _ => None
      end
  | mul_default =>
      None
end.

Function sem_div (v1:val) (t1:type) (v2: val) (t2:type) : option val :=
   match classify_div t1 t2 with
  | div_case_ii Unsigned =>
      match v1,v2 with
      | Vint n1, Vint n2 =>
          if Int.eq n2 Int.zero then None else Some (Vint (Int.divu n1 n2))
      | _,_ => None
      end
  | div_case_ii Signed =>
      match v1,v2 with
       | Vint n1, Vint n2 =>
          if Int.eq n2 Int.zero
          || Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone
          then None else Some (Vint(Int.divs n1 n2))
      | _,_ => None
      end
  | div_case_ff =>
      match v1,v2 with
      | Vfloat f1, Vfloat f2 => Some (Vfloat(Float.div f1 f2))
      | _,  _ => None
      end
  | div_case_if sg =>
      match v1, v2 with
      | Vint n1, Vfloat n2 => Some (Vfloat (Float.div (cast_int_float sg n1) n2))
      | _, _ => None
      end
  | div_case_fi sg =>
      match v1, v2 with
      | Vfloat n1, Vint n2 => Some (Vfloat (Float.div n1 (cast_int_float sg n2)))
      | _, _ => None
      end
  | div_default =>
      None
end.

Function sem_mod (v1:val) (t1:type) (v2: val) (t2:type) : option val :=
  match classify_binint t1 t2 with
  | binint_case_ii Unsigned =>
      match v1, v2 with
      | Vint n1, Vint n2 =>
          if Int.eq n2 Int.zero then None else Some (Vint (Int.modu n1 n2))
      | _, _ => None
      end
  | binint_case_ii Signed =>
      match v1,v2 with
      | Vint n1, Vint n2 =>
          if Int.eq n2 Int.zero
          || Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone
          then None else Some (Vint (Int.mods n1 n2))
      | _, _ => None
      end
  | binint_default =>
      None
  end.

Function sem_and (v1:val) (t1:type) (v2: val) (t2:type) : option val :=
  match classify_binint t1 t2 with
  | binint_case_ii sg =>
      match v1, v2 with
      | Vint n1, Vint n2 => Some (Vint(Int.and n1 n2))
      | _, _ => None
      end
  | binint_default => None
  end.

Function sem_or (v1:val) (t1:type) (v2: val) (t2:type) : option val :=
  match classify_binint t1 t2 with
  | binint_case_ii sg =>
      match v1, v2 with
      | Vint n1, Vint n2 => Some (Vint(Int.or n1 n2))
      | _, _ => None
      end
  | binint_default => None
  end.

Function sem_xor (v1:val) (t1:type) (v2: val) (t2:type) : option val :=
  match classify_binint t1 t2 with
  | binint_case_ii sg =>
      match v1, v2 with
      | Vint n1, Vint n2 => Some (Vint(Int.xor n1 n2))
      | _, _ => None
      end
  | binint_default => None
  end.

Function sem_shl (v1:val) (t1:type) (v2: val) (t2:type) : option val :=
  match classify_shift t1 t2 with
  | shift_case_ii sg =>
      match v1, v2 with
      | Vint n1, Vint n2 =>
         if Int.ltu n2 Int.iwordsize then Some (Vint(Int.shl n1 n2)) else None
      | _, _ => None
      end
  | shift_default => None
  end.

Function sem_shr (v1: val) (t1: type) (v2: val) (t2: type): option val :=
  match classify_shift t1 t2 with
  | shift_case_ii Unsigned =>
      match v1,v2 with
      | Vint n1, Vint n2 =>
          if Int.ltu n2 Int.iwordsize then Some (Vint (Int.shru n1 n2)) else None
      | _,_ => None
      end
   | shift_case_ii Signed =>
      match v1,v2 with
      | Vint n1,  Vint n2 =>
          if Int.ltu n2 Int.iwordsize then Some (Vint (Int.shr n1 n2)) else None
      | _,  _ => None
      end
   | shift_default =>
      None
   end.

Function sem_cmp_mismatch (c: comparison): option val :=
  match c with
  | Ceq =>  Some Vfalse
  | Cne =>  Some Vtrue
  | _   => None
  end.

Function sem_cmp (c:comparison)
                  (v1: val) (t1: type) (v2: val) (t2: type)
                  (m: mem): option val :=
  match classify_cmp t1 t2 with
  | cmp_case_ii Signed =>
      match v1,v2 with
      | Vint n1, Vint n2 => Some (Val.of_bool (Int.cmp c n1 n2))
      | _,  _ => None
      end
  | cmp_case_ii Unsigned =>
      match v1,v2 with
      | Vint n1, Vint n2 => Some (Val.of_bool (Int.cmpu c n1 n2))
      | _,  _ => None
      end
  | cmp_case_pp =>
      match v1,v2 with
      | Vint n1, Vint n2 => Some (Val.of_bool (Int.cmpu c n1 n2))
      | Vptr b1 ofs1,  Vptr b2 ofs2  =>
          if Mem.valid_pointer m b1 (Int.unsigned ofs1)
          && Mem.valid_pointer m b2 (Int.unsigned ofs2) then
            if zeq b1 b2
            then Some (Val.of_bool (Int.cmpu c ofs1 ofs2))
            else sem_cmp_mismatch c
          else None
      | Vptr b ofs, Vint n =>
          if Int.eq n Int.zero then sem_cmp_mismatch c else None
      | Vint n, Vptr b ofs =>
          if Int.eq n Int.zero then sem_cmp_mismatch c else None
      | _,  _ => None
      end
  | cmp_case_ff =>
      match v1,v2 with
      | Vfloat f1, Vfloat f2 => Some (Val.of_bool (Float.cmp c f1 f2))
      | _,  _ => None
      end
  | cmp_case_if sg =>
      match v1, v2 with
      | Vint n1, Vfloat n2 => Some (Val.of_bool (Float.cmp c (cast_int_float sg n1) n2))
      | _, _ => None
      end
  | cmp_case_fi sg =>
      match v1, v2 with
      | Vfloat n1, Vint n2 => Some (Val.of_bool (Float.cmp c n1 (cast_int_float sg n2)))
      | _, _ => None
      end
  | cmp_default => None
  end.

Definition sem_unary_operation
            (op: unary_operation) (v: val) (ty: type): option val :=
  match op with
  | Onotbool => sem_notbool v ty
  | Onotint => sem_notint v ty
  | Oneg => sem_neg v ty
  end.

Definition sem_binary_operation
    (op: binary_operation)
    (v1: val) (t1: type) (v2: val) (t2:type)
    (m: mem): option val :=
  match op with
  | Oadd => sem_add v1 t1 v2 t2
  | Osub => sem_sub v1 t1 v2 t2
  | Omul => sem_mul v1 t1 v2 t2
  | Omod => sem_mod v1 t1 v2 t2
  | Odiv => sem_div v1 t1 v2 t2
  | Oand => sem_and v1 t1 v2 t2
  | Oor  => sem_or v1 t1 v2 t2
  | Oxor  => sem_xor v1 t1 v2 t2
  | Oshl => sem_shl v1 t1 v2 t2
  | Oshr  => sem_shr v1 t1 v2 t2
  | Oeq => sem_cmp Ceq v1 t1 v2 t2 m
  | One => sem_cmp Cne v1 t1 v2 t2 m
  | Olt => sem_cmp Clt v1 t1 v2 t2 m
  | Ogt => sem_cmp Cgt v1 t1 v2 t2 m
  | Ole => sem_cmp Cle v1 t1 v2 t2 m
  | Oge => sem_cmp Cge v1 t1 v2 t2 m
  end.

Definition sem_incrdecr (id: incr_or_decr) (v: val) (ty: type) :=
  match id with
  | Incr => sem_add v ty (Vint Int.one) type_int32s
  | Decr => sem_sub v ty (Vint Int.one) type_int32s
  end.

(** Common-sense relations between boolean operators *)

Lemma cast_bool_bool_val:
  forall v t,
  sem_cast v t (Tint IBool Signed noattr) =
  match bool_val v t with None => None | Some b => Some(Val.of_bool b) end.
Proof.
  intros. unfold sem_cast, bool_val. destruct t; simpl; destruct v; auto.
  destruct (Int.eq i0 Int.zero); auto.
  destruct (Float.cmp Ceq f0 Float.zero); auto.
  destruct (Int.eq i Int.zero); auto.
  destruct (Int.eq i Int.zero); auto.
  destruct (Int.eq i Int.zero); auto.
Qed.

Lemma notbool_bool_val:
  forall v t,
  sem_notbool v t =
  match bool_val v t with None => None | Some b => Some(Val.of_bool (negb b)) end.
Proof.
  assert (CB: forall i s a, classify_bool (Tint i s a) = bool_case_ip).
    intros. destruct i; auto. destruct s; auto.
  intros. unfold sem_notbool, bool_val. destruct t; try rewrite CB; simpl; destruct v; auto.
  destruct (Int.eq i0 Int.zero); auto.
  destruct (Float.cmp Ceq f0 Float.zero); auto.
  destruct (Int.eq i Int.zero); auto.
  destruct (Int.eq i Int.zero); auto.
  destruct (Int.eq i Int.zero); auto.
Qed.

(** * Operational semantics *)

(** The semantics uses two environments.  The global environment
  maps names of functions and global variables to memory block references,
  and function pointers to their definitions.  (See module [Globalenvs].) *)

Definition genv := Genv.t fundef type.

(** The local environment maps local variables to block references and types.
  The current value of the variable is stored in the associated memory
  block. *)

Definition env := PTree.t (block * type). (* map variable -> location & type *)

Definition empty_env: env := (PTree.empty (block * type)).

(** [deref_loc ty m b ofs t v] computes the value of a datum
  of type [ty] residing in memory [m] at block [b], offset [ofs].
  If the type [ty] indicates an access by value, the corresponding
  memory load is performed.  If the type [ty] indicates an access by
  reference, the pointer [Vptr b ofs] is returned.  [v] is the value
  returned, and [t] the trace of observables (nonempty if this is
  a volatile access). *)

Inductive deref_loc {F V: Type} (ge: Genv.t F V) (ty: type) (m: mem) (b: block) (ofs: int) : trace -> val -> Prop :=
  | deref_loc_value: forall chunk v,
      access_mode ty = By_value chunk ->
      type_is_volatile ty = false ->
      Mem.loadv chunk m (Vptr b ofs) = Some v ->
      deref_loc ge ty m b ofs E0 v
  | deref_loc_volatile: forall chunk t v,
      access_mode ty = By_value chunk -> type_is_volatile ty = true ->
      volatile_load ge chunk m b ofs t v ->
      deref_loc ge ty m b ofs t v
  | deref_loc_reference:
      access_mode ty = By_reference ->
      deref_loc ge ty m b ofs E0 (Vptr b ofs)
  | deref_loc_copy:
      access_mode ty = By_copy ->
      deref_loc ge ty m b ofs E0 (Vptr b ofs).

(** Symmetrically, [assign_loc ty m b ofs v t m'] returns the
  memory state after storing the value [v] in the datum
  of type [ty] residing in memory [m] at block [b], offset [ofs].
  This is allowed only if [ty] indicates an access by value or by copy.
  [m'] is the updated memory state and [t] the trace of observables
  (nonempty if this is a volatile store). *)

Inductive assign_loc {F V: Type} (ge: Genv.t F V) (ty: type) (m: mem) (b: block) (ofs: int):
                                            val -> trace -> mem -> Prop :=
  | assign_loc_value: forall v chunk m',
      access_mode ty = By_value chunk ->
      type_is_volatile ty = false ->
      Mem.storev chunk m (Vptr b ofs) v = Some m' ->
      assign_loc ge ty m b ofs v E0 m'
  | assign_loc_volatile: forall v chunk t m',
      access_mode ty = By_value chunk -> type_is_volatile ty = true ->
      volatile_store ge chunk m b ofs v t m' ->
      assign_loc ge ty m b ofs v t m'
  | assign_loc_copy: forall b' ofs' bytes m',
      access_mode ty = By_copy ->
      (alignof ty | Int.unsigned ofs') -> (alignof ty | Int.unsigned ofs) ->
      b' <> b \/ Int.unsigned ofs' = Int.unsigned ofs
              \/ Int.unsigned ofs' + sizeof ty <= Int.unsigned ofs
              \/ Int.unsigned ofs + sizeof ty <= Int.unsigned ofs' ->
      Mem.loadbytes m b' (Int.unsigned ofs') (sizeof ty) = Some bytes ->
      Mem.storebytes m b (Int.unsigned ofs) bytes = Some m' ->
      assign_loc ge ty m b ofs (Vptr b' ofs') E0 m'.

(** Allocation of function-local variables.
  [alloc_variables e1 m1 vars e2 m2] allocates one memory block
  for each variable declared in [vars], and associates the variable
  name with this block.  [e1] and [m1] are the initial local environment
  and memory state.  [e2] and [m2] are the final local environment
  and memory state. *)

Inductive alloc_variables: env -> mem ->
                           list (ident * type) ->
                           env -> mem -> Prop :=
  | alloc_variables_nil:
      forall e m,
      alloc_variables e m nil e m
  | alloc_variables_cons:
      forall e m id ty vars m1 b1 m2 e2,
      Mem.alloc m 0 (sizeof ty) = (m1, b1) ->
      alloc_variables (PTree.set id (b1, ty) e) m1 vars e2 m2 ->
      alloc_variables e m ((id, ty) :: vars) e2 m2.

(** Initialization of local variables that are parameters to a function.
  [bind_parameters e m1 params args m2] stores the values [args]
  in the memory blocks corresponding to the variables [params].
  [m1] is the initial memory state and [m2] the final memory state. *)

Inductive bind_parameters {F V: Type} (ge: Genv.t F V) (e: env):
                           mem -> list (ident * type) -> list val ->
                           mem -> Prop :=
  | bind_parameters_nil:
      forall m,
      bind_parameters ge e m nil nil m
  | bind_parameters_cons:
      forall m id ty params v1 vl b m1 m2,
      PTree.get id e = Some(b, ty) ->
      assign_loc ge ty m b Int.zero v1 E0 m1 ->
      bind_parameters ge e m1 params vl m2 ->
      bind_parameters ge e m ((id, ty) :: params) (v1 :: vl) m2.

(** Return the list of blocks in the codomain of [e], with low and high bounds. *)

Definition block_of_binding (id_b_ty: ident * (block * type)) :=
  match id_b_ty with (id, (b, ty)) => (b, 0, sizeof ty) end.

Definition blocks_of_env (e: env) : list (block * Z * Z) :=
  List.map block_of_binding (PTree.elements e).

(** Selection of the appropriate case of a [switch], given the value [n]
  of the selector expression. *)

Fixpoint select_switch (n: int) (sl: labeled_statements)
                       {struct sl}: labeled_statements :=
  match sl with
  | LSdefault _ => sl
  | LScase c s sl' => if Int.eq c n then sl else select_switch n sl'
  end.

(** Turn a labeled statement into a sequence *)

Fixpoint seq_of_labeled_statement (sl: labeled_statements) : statement :=
  match sl with
  | LSdefault s => s
  | LScase c s sl' => Ssequence s (seq_of_labeled_statement sl')
  end.

Section SEMANTICS.

Variable ge: genv.

(** [type_of_global b] returns the type of the global variable or function
  at address [b]. *)

Definition type_of_global (b: block) : option type :=
  match Genv.find_var_info ge b with
  | Some gv => Some gv.(gvar_info)
  | None =>
      match Genv.find_funct_ptr ge b with
      | Some fd => Some(type_of_fundef fd)
      | None => None
      end
  end.

(** ** Reduction semantics for expressions *)

Section EXPR.

Variable e: env.

(** The semantics of expressions follows the popular Wright-Felleisen style.
  It is a small-step semantics that reduces one redex at a time.
  We first define head reductions (at the top of an expression, then
  use reduction contexts to define reduction within an expression. *)

(** Head reduction for l-values. *)

Inductive lred: expr -> mem -> expr -> mem -> Prop :=
  | red_var_local: forall x ty m b,
      e!x = Some(b, ty) ->
      lred (Evar x ty) m
           (Eloc b Int.zero ty) m
  | red_var_global: forall x ty m b,
      e!x = None ->
      Genv.find_symbol ge x = Some b ->
      type_of_global b = Some ty ->
      lred (Evar x ty) m
           (Eloc b Int.zero ty) m
  | red_deref: forall b ofs ty1 ty m,
      lred (Ederef (Eval (Vptr b ofs) ty1) ty) m
           (Eloc b ofs ty) m
  | red_field_struct: forall b ofs id fList a f ty m delta,
      field_offset f fList = OK delta ->
      lred (Efield (Eval (Vptr b ofs) (Tstruct id fList a)) f ty) m
           (Eloc b (Int.add ofs (Int.repr delta)) ty) m
  | red_field_union: forall b ofs id fList a f ty m,
      lred (Efield (Eval (Vptr b ofs) (Tunion id fList a)) f ty) m
           (Eloc b ofs ty) m.

(** Head reductions for r-values *)

Inductive rred: expr -> mem -> trace -> expr -> mem -> Prop :=
  | red_rvalof: forall b ofs ty m t v,
      deref_loc ge ty m b ofs t v ->
      rred (Evalof (Eloc b ofs ty) ty) m
         t (Eval v ty) m
  | red_addrof: forall b ofs ty1 ty m,
      rred (Eaddrof (Eloc b ofs ty1) ty) m
        E0 (Eval (Vptr b ofs) ty) m
  | red_unop: forall op v1 ty1 ty m v,
      sem_unary_operation op v1 ty1 = Some v ->
      rred (Eunop op (Eval v1 ty1) ty) m
        E0 (Eval v ty) m
  | red_binop: forall op v1 ty1 v2 ty2 ty m v,
      sem_binary_operation op v1 ty1 v2 ty2 m = Some v ->
      rred (Ebinop op (Eval v1 ty1) (Eval v2 ty2) ty) m
        E0 (Eval v ty) m
  | red_cast: forall ty v1 ty1 m v,
      sem_cast v1 ty1 ty = Some v ->
      rred (Ecast (Eval v1 ty1) ty) m
        E0 (Eval v ty) m
  | red_condition: forall v1 ty1 r1 r2 ty b m,
      bool_val v1 ty1 = Some b ->
      rred (Econdition (Eval v1 ty1) r1 r2 ty) m
        E0 (Eparen (if b then r1 else r2) ty) m
  | red_sizeof: forall ty1 ty m,
      rred (Esizeof ty1 ty) m
        E0 (Eval (Vint (Int.repr (sizeof ty1))) ty) m
  | red_alignof: forall ty1 ty m,
      rred (Ealignof ty1 ty) m
        E0 (Eval (Vint (Int.repr (alignof ty1))) ty) m
  | red_assign: forall b ofs ty1 v2 ty2 m v t m',
      sem_cast v2 ty2 ty1 = Some v ->
      assign_loc ge ty1 m b ofs v t m' ->
      rred (Eassign (Eloc b ofs ty1) (Eval v2 ty2) ty1) m
         t (Eval v ty1) m'
  | red_assignop: forall op b ofs ty1 v2 ty2 tyres m t v1,
      deref_loc ge ty1 m b ofs t v1 ->
      rred (Eassignop op (Eloc b ofs ty1) (Eval v2 ty2) tyres ty1) m
         t (Eassign (Eloc b ofs ty1)
                    (Ebinop op (Eval v1 ty1) (Eval v2 ty2) tyres) ty1) m
  | red_postincr: forall id b ofs ty m t v1 op,
      deref_loc ge ty m b ofs t v1 ->
      op = match id with Incr => Oadd | Decr => Osub end ->
      rred (Epostincr id (Eloc b ofs ty) ty) m
         t (Ecomma (Eassign (Eloc b ofs ty)
                           (Ebinop op (Eval v1 ty) (Eval (Vint Int.one) type_int32s) (typeconv ty))
                           ty)
                   (Eval v1 ty) ty) m
  | red_comma: forall v ty1 r2 ty m,
      typeof r2 = ty ->
      rred (Ecomma (Eval v ty1) r2 ty) m
        E0 r2 m
  | red_paren: forall v1 ty1 ty m v,
      sem_cast v1 ty1 ty = Some v ->
      rred (Eparen (Eval v1 ty1) ty) m
        E0 (Eval v ty) m.

(** Head reduction for function calls.
    (More exactly, identification of function calls that can reduce.) *)

Inductive cast_arguments: exprlist -> typelist -> list val -> Prop :=
  | cast_args_nil:
      cast_arguments Enil Tnil nil
  | cast_args_cons: forall v ty el targ1 targs v1 vl,
      sem_cast v ty targ1 = Some v1 -> cast_arguments el targs vl ->
      cast_arguments (Econs (Eval v ty) el) (Tcons targ1 targs) (v1 :: vl).

Inductive callred: expr -> fundef -> list val -> type -> Prop :=
  | red_Ecall: forall vf tyf tyargs tyres el ty fd vargs,
      Genv.find_funct ge vf = Some fd ->
      cast_arguments el tyargs vargs ->
      type_of_fundef fd = Tfunction tyargs tyres ->
      classify_fun tyf = fun_case_f tyargs tyres ->
      callred (Ecall (Eval vf tyf) el ty)
              fd vargs ty.

(** Reduction contexts.  In accordance with C's nondeterministic semantics,
  we allow reduction both to the left and to the right of a binary operator.
  To enforce C's notion of sequence point, reductions within a conditional
  [a ? b : c] can only take place in [a], not in [b] nor [c];
  and reductions within a sequence [a, b] can only take place in [a], not in [b].

  Reduction contexts are represented by functions [C] from expressions to expressions,
  suitably constrained by the [context from to C] predicate below.
  Contexts are "kinded" with respect to l-values and r-values:
  [from] is the kind of the hole in the context and [to] is the kind of
  the term resulting from filling the hole.
*)

Inductive kind : Type := LV | RV.

Inductive context: kind -> kind -> (expr -> expr) -> Prop :=
  | ctx_top: forall k,
      context k k (fun x => x)
  | ctx_deref: forall k C ty,
      context k RV C -> context k LV (fun x => Ederef (C x) ty)
  | ctx_field: forall k C f ty,
      context k RV C -> context k LV (fun x => Efield (C x) f ty)
  | ctx_rvalof: forall k C ty,
      context k LV C -> context k RV (fun x => Evalof (C x) ty)
  | ctx_addrof: forall k C ty,
      context k LV C -> context k RV (fun x => Eaddrof (C x) ty)
  | ctx_unop: forall k C op ty,
      context k RV C -> context k RV (fun x => Eunop op (C x) ty)
  | ctx_binop_left: forall k C op e2 ty,
      context k RV C -> context k RV (fun x => Ebinop op (C x) e2 ty)
  | ctx_binop_right: forall k C op e1 ty,
      context k RV C -> context k RV (fun x => Ebinop op e1 (C x) ty)
  | ctx_cast: forall k C ty,
      context k RV C -> context k RV (fun x => Ecast (C x) ty)
  | ctx_condition: forall k C r2 r3 ty,
      context k RV C -> context k RV (fun x => Econdition (C x) r2 r3 ty)
  | ctx_assign_left: forall k C e2 ty,
      context k LV C -> context k RV (fun x => Eassign (C x) e2 ty)
  | ctx_assign_right: forall k C e1 ty,
      context k RV C -> context k RV (fun x => Eassign e1 (C x) ty)
  | ctx_assignop_left: forall k C op e2 tyres ty,
      context k LV C -> context k RV (fun x => Eassignop op (C x) e2 tyres ty)
  | ctx_assignop_right: forall k C op e1 tyres ty,
      context k RV C -> context k RV (fun x => Eassignop op e1 (C x) tyres ty)
  | ctx_postincr: forall k C id ty,
      context k LV C -> context k RV (fun x => Epostincr id (C x) ty)
  | ctx_call_left: forall k C el ty,
      context k RV C -> context k RV (fun x => Ecall (C x) el ty)
  | ctx_call_right: forall k C e1 ty,
      contextlist k C -> context k RV (fun x => Ecall e1 (C x) ty)
  | ctx_comma: forall k C e2 ty,
      context k RV C -> context k RV (fun x => Ecomma (C x) e2 ty)
  | ctx_paren: forall k C ty,
      context k RV C -> context k RV (fun x => Eparen (C x) ty)

with contextlist: kind -> (expr -> exprlist) -> Prop :=
  | ctx_list_head: forall k C el,
      context k RV C -> contextlist k (fun x => Econs (C x) el)
  | ctx_list_tail: forall k C e1,
      contextlist k C -> contextlist k (fun x => Econs e1 (C x)).

(** In a nondeterministic semantics, expressions can go wrong according
  to one reduction order while being defined according to another.
  Consider for instance [(x = 1) + (10 / x)] where [x] is initially [0].
  This expression goes wrong if evaluated right-to-left, but is defined
  if evaluated left-to-right.  Since our compiler is going to pick one
  particular evaluation order, we must make sure that all orders are safe,
  i.e. never evaluate a subexpression that goes wrong.

  Being safe is a stronger requirement than just not getting stuck during
  reductions.  Consider [f() + (10 / x)], where [f()] does not terminate.
  This expression is never stuck because the evaluation of [f()] can make
  infinitely many transitions.  Yet it contains a subexpression [10 / x]
  that can go wrong if [x = 0], and the compiler may choose to evaluate
  [10 / x] first, before calling [f()].

  Therefore, we must make sure that not only an expression cannot get stuck,
  but none of its subexpressions can either.  We say that a subexpression
  is not immediately stuck if it is a value (of the appropriate kind)
  or it can reduce (at head or within). *)

Inductive imm_safe: kind -> expr -> mem -> Prop :=
  | imm_safe_val: forall v ty m,
      imm_safe RV (Eval v ty) m
  | imm_safe_loc: forall b ofs ty m,
      imm_safe LV (Eloc b ofs ty) m
  | imm_safe_lred: forall to C e m e' m',
      lred e m e' m' ->
      context LV to C ->
      imm_safe to (C e) m
  | imm_safe_rred: forall to C e m t e' m',
      rred e m t e' m' ->
      context RV to C ->
      imm_safe to (C e) m
  | imm_safe_callred: forall to C e m fd args ty,
      callred e fd args ty ->
      context RV to C ->
      imm_safe to (C e) m.

(* An expression is not stuck if none of the potential redexes contained within
   is immediately stuck. *)
(*
Definition not_stuck (e: expr) (m: mem) : Prop :=
  forall k C e' ,
  context k RV C -> e = C e' -> not_imm_stuck k e' m.
*)
End EXPR.

(** ** Transition semantics. *)

(** Continuations describe the computations that remain to be performed
    after the statement or expression under consideration has
    evaluated completely. *)

Inductive cont: Type :=
  | Kstop: cont
  | Kdo: cont -> cont       (**r [Kdo k] = after [x] in [x;] *)
  | Kseq: statement -> cont -> cont    (**r [Kseq s2 k] = after [s1] in [s1;s2] *)
  | Kifthenelse: statement -> statement -> cont -> cont     (**r [Kifthenelse s1 s2 k] = after [x] in [if (x) { s1 } else { s2 }] *)
  | Kwhile1: expr -> statement -> cont -> cont      (**r [Kwhile1 x s k] = after [x] in [while(x) s] *)
  | Kwhile2: expr -> statement -> cont -> cont      (**r [Kwhile x s k] = after [s] in [while (x) s] *)
  | Kdowhile1: expr -> statement -> cont -> cont    (**r [Kdowhile1 x s k] = after [s] in [do s while (x)] *)
  | Kdowhile2: expr -> statement -> cont -> cont    (**r [Kdowhile2 x s k] = after [x] in [do s while (x)] *)
  | Kfor2: expr -> statement -> statement -> cont -> cont   (**r [Kfor2 e2 e3 s k] = after [e2] in [for(e1;e2;e3) s] *)
  | Kfor3: expr -> statement -> statement -> cont -> cont   (**r [Kfor3 e2 e3 s k] = after [s] in [for(e1;e2;e3) s] *)
  | Kfor4: expr -> statement -> statement -> cont -> cont   (**r [Kfor3 e2 e3 s k] = after [e3] in [for(e1;e2;e3) s] *)
  | Kswitch1: labeled_statements -> cont -> cont     (**r [Kswitch1 ls k] = after [e] in [switch(e) { ls }] *)
  | Kswitch2: cont -> cont       (**r catches [break] statements arising out of [switch] *)
  | Kreturn: cont -> cont        (**r [Kreturn k] = after [e] in [return e;] *)
  | Kcall: function ->           (**r calling function *)
           env ->                (**r local env of calling function *)
           (expr -> expr) ->     (**r context of the call *)
           type ->               (**r type of call expression *)
           cont -> cont.

(** Pop continuation until a call or stop *)

Fixpoint call_cont (k: cont) : cont :=
  match k with
  | Kstop => k
  | Kdo k => k
  | Kseq s k => call_cont k
  | Kifthenelse s1 s2 k => call_cont k
  | Kwhile1 e s k => call_cont k
  | Kwhile2 e s k => call_cont k
  | Kdowhile1 e s k => call_cont k
  | Kdowhile2 e s k => call_cont k
  | Kfor2 e2 e3 s k => call_cont k
  | Kfor3 e2 e3 s k => call_cont k
  | Kfor4 e2 e3 s k => call_cont k
  | Kswitch1 ls k => call_cont k
  | Kswitch2 k => call_cont k
  | Kreturn k => call_cont k
  | Kcall _ _ _ _ _ => k
  end.

Definition is_call_cont (k: cont) : Prop :=
  match k with
  | Kstop => True
  | Kcall _ _ _ _ _ => True
  | _ => False
  end.

(** Execution states of the program are grouped in 4 classes corresponding
  to the part of the program we are currently executing.  It can be
  a statement ([State]), an expression ([ExprState]), a transition
  from a calling function to a called function ([Callstate]), or
  the symmetrical transition from a function back to its caller
  ([Returnstate]). *)

Inductive state: Type :=
  | State                               (**r execution of a statement *)
      (f: function)
      (s: statement)
      (k: cont)
      (e: env)
      (m: mem) : state
  | ExprState                           (**r reduction of an expression *)
      (f: function)
      (r: expr)
      (k: cont)
      (e: env)
      (m: mem) : state
  | Callstate                           (**r calling a function *)
      (fd: fundef)
      (args: list val)
      (k: cont)
      (m: mem) : state
  | Returnstate                         (**r returning from a function *)
      (res: val)
      (k: cont)
      (m: mem) : state
  | Stuckstate.                         (**r undefined behavior occurred *)

(** Find the statement and manufacture the continuation
  corresponding to a label. *)

Fixpoint find_label (lbl: label) (s: statement) (k: cont)
                    {struct s}: option (statement * cont) :=
  match s with
  | Ssequence s1 s2 =>
      match find_label lbl s1 (Kseq s2 k) with
      | Some sk => Some sk
      | None => find_label lbl s2 k
      end
  | Sifthenelse a s1 s2 =>
      match find_label lbl s1 k with
      | Some sk => Some sk
      | None => find_label lbl s2 k
      end
  | Swhile a s1 =>
      find_label lbl s1 (Kwhile2 a s1 k)
  | Sdowhile a s1 =>
      find_label lbl s1 (Kdowhile1 a s1 k)
  | Sfor a1 a2 a3 s1 =>
      match find_label lbl a1 (Kseq (Sfor Sskip a2 a3 s1) k) with
      | Some sk => Some sk
      | None =>
          match find_label lbl s1 (Kfor3 a2 a3 s1 k) with
          | Some sk => Some sk
          | None => find_label lbl a3 (Kfor4 a2 a3 s1 k)
          end
      end
  | Sswitch e sl =>
      find_label_ls lbl sl (Kswitch2 k)
  | Slabel lbl' s' =>
      if ident_eq lbl lbl' then Some(s', k) else find_label lbl s' k
  | _ => None
  end

with find_label_ls (lbl: label) (sl: labeled_statements) (k: cont)
                    {struct sl}: option (statement * cont) :=
  match sl with
  | LSdefault s => find_label lbl s k
  | LScase _ s sl' =>
      match find_label lbl s (Kseq (seq_of_labeled_statement sl') k) with
      | Some sk => Some sk
      | None => find_label_ls lbl sl' k
      end
  end.

(** We separate the transition rules in two groups:
- one group that deals with reductions over expressions;
- the other group that deals with everything else: statements, function calls, etc.

This makes it easy to express different reduction strategies for expressions:
the second group of rules can be reused as is. *)

Inductive estep: state -> trace -> state -> Prop :=

  | step_lred: forall C f a k e m a' m',
      lred e a m a' m' ->
      context LV RV C ->
      estep (ExprState f (C a) k e m)
         E0 (ExprState f (C a') k e m')

  | step_rred: forall C f a k e m t a' m',
      rred a m t a' m' ->
      context RV RV C ->
      estep (ExprState f (C a) k e m)
          t (ExprState f (C a') k e m')

  | step_call: forall C f a k e m fd vargs ty,
      callred a fd vargs ty ->
      context RV RV C ->
      estep (ExprState f (C a) k e m)
         E0 (Callstate fd vargs (Kcall f e C ty k) m)

  | step_stuck: forall C f a k e m K,
      context K RV C -> ~(imm_safe e K a m) ->
      estep (ExprState f (C a) k e m)
         E0 Stuckstate.

Inductive sstep: state -> trace -> state -> Prop :=

  | step_do_1: forall f x k e m,
      sstep (State f (Sdo x) k e m)
         E0 (ExprState f x (Kdo k) e m)
  | step_do_2: forall f v ty k e m,
      sstep (ExprState f (Eval v ty) (Kdo k) e m)
         E0 (State f Sskip k e m)

  | step_seq:  forall f s1 s2 k e m,
      sstep (State f (Ssequence s1 s2) k e m)
         E0 (State f s1 (Kseq s2 k) e m)
  | step_skip_seq: forall f s k e m,
      sstep (State f Sskip (Kseq s k) e m)
         E0 (State f s k e m)
  | step_continue_seq: forall f s k e m,
      sstep (State f Scontinue (Kseq s k) e m)
         E0 (State f Scontinue k e m)
  | step_break_seq: forall f s k e m,
      sstep (State f Sbreak (Kseq s k) e m)
         E0 (State f Sbreak k e m)

  | step_ifthenelse_1: forall f a s1 s2 k e m,
      sstep (State f (Sifthenelse a s1 s2) k e m)
         E0 (ExprState f a (Kifthenelse s1 s2 k) e m)
  | step_ifthenelse_2:  forall f v ty s1 s2 k e m b,
      bool_val v ty = Some b ->
      sstep (ExprState f (Eval v ty) (Kifthenelse s1 s2 k) e m)
         E0 (State f (if b then s1 else s2) k e m)

  | step_while: forall f x s k e m,
      sstep (State f (Swhile x s) k e m)
        E0 (ExprState f x (Kwhile1 x s k) e m)
  | step_while_false: forall f v ty x s k e m,
      bool_val v ty = Some false ->
      sstep (ExprState f (Eval v ty) (Kwhile1 x s k) e m)
        E0 (State f Sskip k e m)
  | step_while_true: forall f v ty x s k e m ,
      bool_val v ty = Some true ->
      sstep (ExprState f (Eval v ty) (Kwhile1 x s k) e m)
        E0 (State f s (Kwhile2 x s k) e m)
  | step_skip_or_continue_while: forall f s0 x s k e m,
      s0 = Sskip \/ s0 = Scontinue ->
      sstep (State f s0 (Kwhile2 x s k) e m)
        E0 (State f (Swhile x s) k e m)
  | step_break_while: forall f x s k e m,
      sstep (State f Sbreak (Kwhile2 x s k) e m)
        E0 (State f Sskip k e m)

  | step_dowhile: forall f a s k e m,
      sstep (State f (Sdowhile a s) k e m)
        E0 (State f s (Kdowhile1 a s k) e m)
  | step_skip_or_continue_dowhile: forall f s0 x s k e m,
      s0 = Sskip \/ s0 = Scontinue ->
      sstep (State f s0 (Kdowhile1 x s k) e m)
         E0 (ExprState f x (Kdowhile2 x s k) e m)
  | step_dowhile_false: forall f v ty x s k e m,
      bool_val v ty = Some false ->
      sstep (ExprState f (Eval v ty) (Kdowhile2 x s k) e m)
         E0 (State f Sskip k e m)
  | step_dowhile_true: forall f v ty x s k e m,
      bool_val v ty = Some true ->
      sstep (ExprState f (Eval v ty) (Kdowhile2 x s k) e m)
         E0 (State f (Sdowhile x s) k e m)
  | step_break_dowhile: forall f a s k e m,
      sstep (State f Sbreak (Kdowhile1 a s k) e m)
         E0 (State f Sskip k e m)

  | step_for_start: forall f a1 a2 a3 s k e m,
      a1 <> Sskip ->
      sstep (State f (Sfor a1 a2 a3 s) k e m)
         E0 (State f a1 (Kseq (Sfor Sskip a2 a3 s) k) e m)
  | step_for: forall f a2 a3 s k e m,
      sstep (State f (Sfor Sskip a2 a3 s) k e m)
         E0 (ExprState f a2 (Kfor2 a2 a3 s k) e m)
  | step_for_false: forall f v ty a2 a3 s k e m,
      bool_val v ty = Some false ->
      sstep (ExprState f (Eval v ty) (Kfor2 a2 a3 s k) e m)
         E0 (State f Sskip k e m)
  | step_for_true: forall f v ty a2 a3 s k e m,
      bool_val v ty = Some true ->
      sstep (ExprState f (Eval v ty) (Kfor2 a2 a3 s k) e m)
         E0 (State f s (Kfor3 a2 a3 s k) e m)
  | step_skip_or_continue_for3: forall f x a2 a3 s k e m,
      x = Sskip \/ x = Scontinue ->
      sstep (State f x (Kfor3 a2 a3 s k) e m)
         E0 (State f a3 (Kfor4 a2 a3 s k) e m)
  | step_break_for3: forall f a2 a3 s k e m,
      sstep (State f Sbreak (Kfor3 a2 a3 s k) e m)
         E0 (State f Sskip k e m)
  | step_skip_for4: forall f a2 a3 s k e m,
      sstep (State f Sskip (Kfor4 a2 a3 s k) e m)
         E0 (State f (Sfor Sskip a2 a3 s) k e m)

  | step_return_0: forall f k e m m',
      Mem.free_list m (blocks_of_env e) = Some m' ->
      sstep (State f (Sreturn None) k e m)
         E0 (Returnstate Vundef (call_cont k) m')
  | step_return_1: forall f x k e m,
      sstep (State f (Sreturn (Some x)) k e m)
         E0 (ExprState f x (Kreturn k) e  m)
  | step_return_2:  forall f v1 ty k e m v2 m',
      sem_cast v1 ty f.(fn_return) = Some v2 ->
      Mem.free_list m (blocks_of_env e) = Some m' ->
      sstep (ExprState f (Eval v1 ty) (Kreturn k) e m)
         E0 (Returnstate v2 (call_cont k) m')
  | step_skip_call: forall f k e m m',
      is_call_cont k ->
      f.(fn_return) = Tvoid ->
      Mem.free_list m (blocks_of_env e) = Some m' ->
      sstep (State f Sskip k e m)
         E0 (Returnstate Vundef k m')

  | step_switch: forall f x sl k e m,
      sstep (State f (Sswitch x sl) k e m)
         E0 (ExprState f x (Kswitch1 sl k) e m)
  | step_expr_switch: forall f n ty sl k e m,
      sstep (ExprState f (Eval (Vint n) ty) (Kswitch1 sl k) e m)
         E0 (State f (seq_of_labeled_statement (select_switch n sl)) (Kswitch2 k) e m)
  | step_skip_break_switch: forall f x k e m,
      x = Sskip \/ x = Sbreak ->
      sstep (State f x (Kswitch2 k) e m)
         E0 (State f Sskip k e m)
  | step_continue_switch: forall f k e m,
      sstep (State f Scontinue (Kswitch2 k) e m)
         E0 (State f Scontinue k e m)

  | step_label: forall f lbl s k e m,
      sstep (State f (Slabel lbl s) k e m)
         E0 (State f s k e m)

  | step_goto: forall f lbl k e m s' k',
      find_label lbl f.(fn_body) (call_cont k) = Some (s', k') ->
      sstep (State f (Sgoto lbl) k e m)
         E0 (State f s' k' e m)

  | step_internal_function: forall f vargs k m e m1 m2,
      list_norepet (var_names (fn_params f) ++ var_names (fn_vars f)) ->
      alloc_variables empty_env m (f.(fn_params) ++ f.(fn_vars)) e m1 ->
      bind_parameters ge e m1 f.(fn_params) vargs m2 ->
      sstep (Callstate (Internal f) vargs k m)
         E0 (State f f.(fn_body) k e m2)

  | step_external_function: forall ef targs tres vargs k m vres t m',
      external_call ef  ge vargs m t vres m' ->
      sstep (Callstate (External ef targs tres) vargs k m)
          t (Returnstate vres k m')

  | step_returnstate: forall v f e C ty k m,
      sstep (Returnstate v (Kcall f e C ty k) m)
         E0 (ExprState f (C (Eval v ty)) k e m).

Definition step (S: state) (t: trace) (S': state) : Prop :=
  estep S t S' \/ sstep S t S'.

End SEMANTICS.

(** * Whole-program semantics *)

(** Execution of whole programs are described as sequences of transitions
  from an initial state to a final state.  An initial state is a [Callstate]
  corresponding to the invocation of the ``main'' function of the program
  without arguments and with an empty continuation. *)

Inductive initial_state (p: program): state -> Prop :=
  | initial_state_intro: forall b f m0,
      let ge := Genv.globalenv p in
      Genv.init_mem p = Some m0 ->
      Genv.find_symbol ge p.(prog_main) = Some b ->
      Genv.find_funct_ptr ge b = Some f ->
      type_of_fundef f = Tfunction Tnil type_int32s ->
      initial_state p (Callstate f nil Kstop m0).

(** A final state is a [Returnstate] with an empty continuation. *)

Inductive final_state: state -> int -> Prop :=
  | final_state_intro: forall r m,
      final_state (Returnstate (Vint r) Kstop m) r.

(** Wrapping up these definitions in a small-step semantics. *)

Definition semantics (p: program) :=
  Semantics step (initial_state p) final_state (Genv.globalenv p).

(** This semantics has the single-event property. *)

Lemma semantics_single_events:
  forall p, single_events (semantics p).
Proof.
  intros; red; intros. destruct H.
  set (ge := globalenv (semantics p)) in *.
  assert (DEREF: forall chunk m b ofs t v, deref_loc ge chunk m b ofs t v -> (length t <= 1)%nat).
    intros. inv H0; simpl; try omega. inv H3; simpl; try omega.
  assert (ASSIGN: forall chunk m b ofs t v m', assign_loc ge chunk m b ofs v t m' -> (length t <= 1)%nat).
    intros. inv H0; simpl; try omega. inv H3; simpl; try omega.
  inv H; simpl; try omega. inv H0; eauto; simpl; try omega.
  inv H; simpl; try omega. eapply external_call_trace_length; eauto.
Qed.


Require Export
        Fiat.QueryStructure.Specification.Representation.QueryStructureNotations
        Fiat.QueryStructure.Specification.Operations.Query.
Require Import Coq.Lists.List
        Coq.Arith.Compare_dec
        Coq.Bool.Bool
        Coq.Strings.String
        Fiat.Common.BoolFacts
        Fiat.Common.List.PermutationFacts
        Fiat.Common.List.ListMorphisms
        Fiat.QueryStructure.Specification.Operations.FlattenCompList
        Fiat.Common.Ensembles.EnsembleListEquivalence
        Fiat.QueryStructure.Implementation.Operations.General.QueryRefinements
        Fiat.Common.IterateBoundedIndex
        Fiat.Common.List.ListFacts
        Fiat.Common.LogicFacts
        Fiat.Common.DecideableEnsembles
        Fiat.Computation.Refinements.Iterate_Decide_Comp
        Fiat.Computation.Refinements.General
        Fiat.QueryStructure.Specification.Constraints.tupleAgree
        Fiat.QueryStructure.Specification.Operations.Mutate.

Import Lists.List.ListNotations.

Unset Implicit Arguments.

Local Transparent Count Query_For.

Section ConstraintCheckRefinements.
  Hint Resolve crossConstr.
  Hint Unfold SatisfiesCrossRelationConstraints
       SatisfiesAttributeConstraints
       SatisfiesTupleConstraints.

  Fixpoint List_Query_eqT
           (attrlist : list Type)
    : Type
    := match attrlist with
       | [ ] => unit
       | attr :: attrlist' =>
         prod (Query_eq attr) (List_Query_eqT attrlist')
       end.

  Fixpoint Tuple_Agree_eq'
           {h : RawHeading}
           {attrlist : list (Attributes h)}
           (attr_eq_dec : List_Query_eqT (map (Domain h) attrlist))
           (tup tup' : @RawTuple h)
    : bool :=
    match attrlist return List_Query_eqT (map (Domain h) attrlist) ->
                          bool with
    | [ ] => fun _ => true
    |  attr :: attrlist' =>
       fun attr_eq_dec' =>
         if @A_eq_dec _ (fst attr_eq_dec') (GetAttributeRaw tup attr) (GetAttributeRaw tup' attr)
         then Tuple_Agree_eq' (snd attr_eq_dec') tup tup'
         else false
    end attr_eq_dec.

  Class List_Query_eq (As : list Type) :=
    { As_Query_eq : List_Query_eqT As}.

  Definition Tuple_Agree_eq {h} (attrlist : list (Attributes h))
          (attr_eq_dec : List_Query_eq (map (Domain h) attrlist)) tup tup' :=
    @Tuple_Agree_eq' h attrlist (@As_Query_eq _ attr_eq_dec) tup tup'.

  Lemma Tuple_Agree_eq_dec h attrlist attr_eq_dec (tup tup' : @RawTuple h) :
    tupleAgree tup tup' attrlist <->
    Tuple_Agree_eq attrlist attr_eq_dec tup tup' = true.
  Proof.
    destruct attr_eq_dec.
    induction attrlist; unfold tupleAgree in *; simpl in *; simpl;
    intuition;
    unfold Tuple_Agree_eq in *; simpl in *; find_if_inside; simpl; subst; eauto;
    try (eapply IHattrlist; eauto; fail);
    discriminate.
  Qed.

  Lemma Tuple_Agree_eq_dec' h attrlist attr_eq_dec (tup tup' : @RawTuple h) :
    ~ tupleAgree tup tup' attrlist <->
    Tuple_Agree_eq attrlist attr_eq_dec tup tup' = false.
  Proof.
    destruct attr_eq_dec.
    induction attrlist; unfold tupleAgree in *; simpl in *; simpl;
    intuition;
    unfold Tuple_Agree_eq in *; simpl in *; intuition;
    find_if_inside; simpl; subst; eauto.
    try (eapply IHattrlist; intros; eapply H).
    intros; intuition; subst; auto.
    eapply IHattrlist; intros; eauto.
  Qed.

  Definition Tuple_Agree_dec h attrlist
             (attr_eq_dec : List_Query_eq (map (Domain h) attrlist)) (tup tup' : @RawTuple h)
    : {tupleAgree tup tup' attrlist} + {~ tupleAgree tup tup' attrlist}.
  Proof.
    case_eq (Tuple_Agree_eq attrlist attr_eq_dec tup tup').
    left; eapply Tuple_Agree_eq_dec; eauto.
    right; eapply Tuple_Agree_eq_dec'; eauto.
  Defined.

  Lemma tupleAgree_sym :
    forall (heading: Heading) tup1 tup2 attrs,
      @tupleAgree heading tup1 tup2 attrs <-> @tupleAgree heading tup2 tup1 attrs.
  Proof.
    intros; unfold tupleAgree;
    split; intros; rewrite H; eauto.
  Qed.

  (* Consequences of ith_replace_BoundIndex_neq and ith_replace_BoundIndex_eq on updates *)

  Lemma refine_SatisfiesAttributeConstraints_self
    : forall (qsSchema : RawQueryStructureSchema)
             (Ridx : Fin.t _)
             (tup : @RawTuple (rawSchemaHeading (GetNRelSchema (qschemaSchemas qsSchema) Ridx))),
      refine {b | decides b (SatisfiesAttributeConstraints Ridx tup )}
             match (attrConstraints (GetNRelSchema (qschemaSchemas qsSchema) _)) with
               Some Constr => {b | decides b (Constr tup) }
             | None => ret true
             end.
  Proof.
    unfold SatisfiesAttributeConstraints.
    intros; match goal with
              |- context [attrConstraints ?A] => destruct (attrConstraints A)
            end;
    eauto using decides_True.
    reflexivity.
  Qed.

  Lemma refine_SatisfiesTupleConstraints_self
    : forall (qsSchema : RawQueryStructureSchema)
             (Ridx : Fin.t _)
             (tup tup' : @RawTuple (rawSchemaHeading (GetNRelSchema (qschemaSchemas qsSchema) Ridx))),
      refine {b | decides b (SatisfiesTupleConstraints Ridx tup tup')}
             match (tupleConstraints (GetNRelSchema (qschemaSchemas qsSchema) _)) with
               Some Constr => {b | decides b (Constr tup tup') }
             | None => ret true
             end.
  Proof.
    unfold SatisfiesTupleConstraints.
    intros; match goal with
              |- context [tupleConstraints ?A] => destruct (tupleConstraints A)
            end;
    eauto using decides_True.
    reflexivity.
  Qed.

  Lemma refine_SatisfiesTupleConstraints_Constr
    : forall (qsSchema : QueryStructureSchema)
             (qs : QueryStructure qsSchema)
             (Ridx : Fin.t _)
             (tup : @RawTuple (rawSchemaHeading (GetNRelSchema (qschemaSchemas qsSchema) Ridx))),
      refine {b | decides
                    b
                    (forall tup',
                        GetRelation qs Ridx tup'
                        -> SatisfiesTupleConstraints
                             Ridx
                             tup
                             (indexedElement tup'))}
             match (tupleConstraints (GetNRelSchema (qschemaSchemas qsSchema) _)) with
               Some Constr =>
               {b | decides b (forall tup',
                                  GetRelation qs Ridx tup'
                                  -> Constr tup (indexedElement tup'))}
             | None => ret true
             end.
  Proof.
    unfold SatisfiesTupleConstraints.
    intros; match goal with
              |- context [tupleConstraints ?A] => destruct (tupleConstraints A)
            end;
    eauto using decides_True.
    reflexivity.
    apply decides_2_True.
  Qed.

  Lemma refine_SatisfiesTupleConstraints_Constr'
    : forall (qsSchema : QueryStructureSchema)
             (qs : QueryStructure qsSchema)
             (Ridx : Fin.t _)
             (tup : @RawTuple (rawSchemaHeading (GetNRelSchema (qschemaSchemas qsSchema) Ridx))),
      refine {b | decides b
                          (forall tup',
                              GetRelation qs Ridx tup'
                              -> SatisfiesTupleConstraints Ridx (indexedElement tup') tup)}
             match tupleConstraints (GetNRelSchema (qschemaSchemas qsSchema) _) with
               Some Constr =>
               {b | decides b (forall tup',
                                  GetRelation qs Ridx tup'
                                  -> Constr (indexedElement tup') tup)}
             | None => ret true
             end.
  Proof.
    unfold SatisfiesTupleConstraints.
    intros; match goal with
              |- context [tupleConstraints ?A] => destruct (tupleConstraints A)
            end;
    eauto using decides_True.
    reflexivity.
    apply decides_2_True.
  Qed.

  Lemma refine_SatisfiesCrossConstraints_Constr
    : forall (qsSchema : QueryStructureSchema)
             (qs : QueryStructure qsSchema)
             (Ridx : Fin.t _)
             (tup : @RawTuple (rawSchemaHeading (GetNRelSchema (qschemaSchemas qsSchema) Ridx))),
      refine
        (@Iterate_Decide_Comp _
                              (fun Ridx' =>
                                 SatisfiesCrossRelationConstraints
                                   Ridx Ridx' tup
                                   (GetRelation qs Ridx')))
        (@Iterate_Decide_Comp_opt _ (fun Ridx' =>
                                      match (BuildQueryStructureConstraints qsSchema Ridx Ridx') with
                                      | Some CrossConstr =>
                                        Some (CrossConstr tup (GetRelation qs Ridx'))
                                      | None => None
                                      end)) .
  Proof.
    intros.
    setoid_rewrite <- refine_Iterate_Decide_Comp.
    unfold SatisfiesCrossRelationConstraints; f_equiv.
    apply functional_extensionality; intros.
    destruct BuildQueryStructureConstraints; reflexivity.
  Qed.

  Lemma refine_SatisfiesTupleConstraints
    : forall (qsSchema : RawQueryStructureSchema)
             (qs : UnConstrQueryStructure qsSchema)
             (Ridx : Fin.t _)
             (tup : @RawTuple (rawSchemaHeading (GetNRelSchema (qschemaSchemas qsSchema) Ridx))),
      refine {b | decides
                    b
                    (forall tup',
                        GetUnConstrRelation qs Ridx tup'
                        -> SatisfiesTupleConstraints
                             Ridx
                             tup
                             (indexedElement tup'))}
             match (tupleConstraints (GetNRelSchema (qschemaSchemas qsSchema) _)) with
               Some Constr =>
               {b | decides b (forall tup',
                                  GetUnConstrRelation qs Ridx tup'
                                  -> Constr tup (indexedElement tup'))}
             | None => ret true
             end.
  Proof.
    unfold SatisfiesTupleConstraints.
    intros; match goal with
              |- context [tupleConstraints ?A] => destruct (tupleConstraints A)
            end;
    eauto using decides_True.
    reflexivity.
    apply decides_2_True.
  Qed.

  Lemma refine_SatisfiesTupleConstraints'
    : forall (qsSchema : RawQueryStructureSchema)
             (qs : UnConstrQueryStructure qsSchema)
             (Ridx : Fin.t _)
             (tup : @RawTuple (rawSchemaHeading (GetNRelSchema (qschemaSchemas qsSchema) Ridx))),
      refine {b | decides b
                          (forall tup',
                              GetUnConstrRelation qs Ridx tup'
                              -> SatisfiesTupleConstraints Ridx (indexedElement tup') tup)}
             match tupleConstraints (GetNRelSchema (qschemaSchemas qsSchema) _) with
               Some Constr =>
               {b | decides b (forall tup',
                                  GetUnConstrRelation qs Ridx tup'
                                  -> Constr (indexedElement tup') tup)}
             | None => ret true
             end.
  Proof.
    unfold SatisfiesTupleConstraints.
    intros; match goal with
              |- context [tupleConstraints ?A] => destruct (tupleConstraints A)
            end;
    eauto using decides_True.
    reflexivity.
    apply decides_2_True.
  Qed.

  Lemma refine_SatisfiesCrossConstraints
    : forall (qsSchema : RawQueryStructureSchema)
             (qs : UnConstrQueryStructure qsSchema)
             (Ridx : Fin.t _)
             (tup : @RawTuple (rawSchemaHeading (GetNRelSchema (qschemaSchemas qsSchema) Ridx))),
      refine
        (@Iterate_Decide_Comp _
                              (fun Ridx' =>
                                 SatisfiesCrossRelationConstraints
                                   Ridx Ridx' tup
                                   (GetUnConstrRelation qs Ridx')))
        (@Iterate_Decide_Comp_opt _ (fun Ridx' =>
                                      match (BuildQueryStructureConstraints qsSchema Ridx Ridx') with
                                      | Some CrossConstr =>
                                        Some (CrossConstr tup (GetUnConstrRelation qs Ridx'))
                                      | None => None
                                      end)) .
  Proof.
    intros.
    setoid_rewrite <- refine_Iterate_Decide_Comp.
    unfold SatisfiesCrossRelationConstraints; f_equiv.
    apply functional_extensionality; intros.
    destruct BuildQueryStructureConstraints; reflexivity.
  Qed.

  Lemma refine_SatisfiesCrossConstraints'_Constr
    : forall (qsSchema : QueryStructureSchema)
             (qs : QueryStructure qsSchema)
             (Ridx : Fin.t _)
             tup idx,
      refine
        (@Iterate_Decide_Comp _
                              (fun Ridx' =>
                Ridx' <> Ridx
                -> forall tup',
                     (GetRelation qs Ridx') tup'
                     -> SatisfiesCrossRelationConstraints
                          Ridx' Ridx (indexedElement tup')
                          (EnsembleInsert
                             {| elementIndex := idx;
                                indexedElement := tup |}
                             (GetRelation qs Ridx))))
             (@Iterate_Decide_Comp_opt _
                                        (fun Ridx' =>
                                           if (fin_eq_dec Ridx Ridx') then
                                             None
                                           else
                                             match (BuildQueryStructureConstraints qsSchema Ridx' Ridx) with
                                               | Some CrossConstr =>
                                                 Some (
                                                     forall tup',
                                                       (GetRelation qs Ridx') tup'
                                                       -> CrossConstr (indexedElement tup') (
                                                                        (EnsembleInsert
                                                                           {| elementIndex := idx;
                                                                              indexedElement := tup |}
                                                                           (GetRelation qs Ridx))))
                                               | None => None
                                      end)).
  Proof.
    intros.
    setoid_rewrite <- refine_Iterate_Decide_Comp.
    unfold SatisfiesCrossRelationConstraints.
    apply refine_Iterate_Decide_Comp_equiv; simpl; intros.
    simpl in *; destruct (fin_eq_dec Ridx idx0); subst.
    congruence.
    destruct (BuildQueryStructureConstraints qsSchema idx0 Ridx); eauto.
    simpl in *; destruct (fin_eq_dec Ridx idx0); subst; eauto.
    destruct (BuildQueryStructureConstraints qsSchema idx0 Ridx); eauto.
  Qed.

  Lemma refine_SatisfiesCrossConstraints'
  : forall qsSchema qs Ridx tup,
    forall idx,
      refine
        (@Iterate_Decide_Comp _
                              (fun Ridx' =>
                Ridx' <> Ridx
                -> forall tup',
                     (GetUnConstrRelation qs Ridx') tup'
                     -> SatisfiesCrossRelationConstraints
                          Ridx' Ridx (indexedElement tup')
                          (EnsembleInsert
                             {| elementIndex := idx;
                                indexedElement := tup |}
                             (GetUnConstrRelation qs Ridx))))
             (@Iterate_Decide_Comp_opt _
                                        (fun Ridx' =>
                                           if (fin_eq_dec Ridx Ridx') then
                                             None
                                           else
                                             match (BuildQueryStructureConstraints qsSchema Ridx' Ridx) with
                                               | Some CrossConstr =>
                                                 Some (
                                                     forall tup',
                                                       (GetUnConstrRelation qs Ridx') tup'
                                                       -> CrossConstr (indexedElement tup') (
                                                                        (EnsembleInsert
                                                                           {| elementIndex := idx;
                                                                              indexedElement := tup |}
                                                                           (GetUnConstrRelation qs Ridx))))
                                               | None => None
                                      end)).
  Proof.
    intros.
    setoid_rewrite <- refine_Iterate_Decide_Comp.
    unfold SatisfiesCrossRelationConstraints.
    apply refine_Iterate_Decide_Comp_equiv; simpl; intros.
    destruct (fin_eq_dec Ridx idx0); subst.
    congruence.
    destruct (BuildQueryStructureConstraints qsSchema idx0 Ridx); eauto.
    intro; eapply H.
    destruct (fin_eq_dec Ridx idx0); subst; eauto.
    destruct (BuildQueryStructureConstraints qsSchema idx0 Ridx); eauto.
  Qed.

  Lemma tupleAgree_refl :
    forall (h : RawHeading)
           (tup : @RawTuple h)
           (attrlist : list (Attributes h)),
      tupleAgree tup tup attrlist.
  Proof.
    unfold tupleAgree; auto.
  Qed.

  Lemma refine_tupleAgree_refl_True :
    forall (h : RawHeading)
           (tup : @RawTuple h)
           (attrlist attrlist' : list (Attributes h)),
      refine {b |
              decides b (tupleAgree tup tup attrlist'
                         -> tupleAgree tup tup attrlist)}
             (ret true).
  Proof.
    unfold refine; intros;  computes_to_inv.
    subst; computes_to_econstructor; simpl; auto using tupleAgree_refl.
  Qed.

  Lemma refine_SatisfiesCrossConstraints_Pre (Q : Prop)
    : forall (qsSchema : RawQueryStructureSchema) qs
             (Ridx :Fin.t _)
             (tup : @RawTuple _),
      refine
        (@Iterate_Decide_Comp_Pre _
                                  (fun Ridx' =>
                                     SatisfiesCrossRelationConstraints
                                       Ridx Ridx' tup
                                       (GetUnConstrRelation qs Ridx')) Q)
        (@Iterate_Decide_Comp_opt_Pre _
                                       (fun Ridx' =>
                                          match (BuildQueryStructureConstraints qsSchema Ridx Ridx') with
                                          | Some CrossConstr =>
                                            Some (CrossConstr tup (GetUnConstrRelation qs Ridx'))
                                          | None => None
                                          end) Q) .
  Proof.
    intros.
    setoid_rewrite <- refine_Iterate_Decide_Comp_Pre.
    unfold SatisfiesCrossRelationConstraints; f_equiv.
    apply functional_extensionality; intros.
    destruct BuildQueryStructureConstraints; reflexivity.
  Qed.

  Lemma DeletePrimaryKeysOK {qsSchema}
    : forall (qs : UnConstrQueryStructure qsSchema)
             (Ridx :Fin.t _)
             DeletedTuples
             attrlist1 attrlist2,
      refine {b | (forall tup tup',
                      elementIndex tup <> elementIndex tup'
                      -> GetUnConstrRelation qs Ridx tup
                      -> GetUnConstrRelation qs Ridx tup'
                      -> (FunctionalDependency_P attrlist1 attrlist2 (indexedElement tup) (indexedElement tup')))
                  -> decides b (Mutate.MutationPreservesTupleConstraints
                                  (EnsembleDelete (GetUnConstrRelation qs Ridx) DeletedTuples)
                                  (FunctionalDependency_P attrlist1 attrlist2)
             )}
             (ret true).
  Proof.
    unfold Mutate.MutationPreservesTupleConstraints, FunctionalDependency_P;
    intros * v Comp_v;  computes_to_inv; subst.
    computes_to_constructor; simpl.
    intros.
    unfold EnsembleDelete in *; destruct H1; destruct H2; eauto.
  Qed.

  Local Transparent Count.

  Lemma In_UnConstrQuery_In {qsSchema} {A}
    : forall (qs : UnConstrQueryStructure qsSchema) Ridx bod results,
      UnConstrQuery_In qs Ridx bod ↝ results
      -> forall (a : A), List.In a results ->
                         exists (tup' : IndexedRawTuple) results',
                           Ensembles.In _ (GetUnConstrRelation qs Ridx) tup'
                           /\ bod (indexedElement tup') ↝ results'
                           /\ List.In a results'.
  Proof.
    unfold UnConstrQuery_In, QueryResultComp; intros;
    computes_to_inv.
    unfold UnIndexedEnsembleListEquivalence in *; destruct_ex; intuition; subst.
    rewrite map_map in H'.
    remember (GetUnConstrRelation qs Ridx); clear Heqi;
    revert i a results H0 H' H H3;
    induction x; simpl in *; intros;
    computes_to_inv; subst.
    - simpl in H0; intuition.
    - apply in_app_or in H0; intuition.
      exists a; exists v; intuition; try eapply H; eauto.
      inversion H3; subst.
      destruct (IHx (fun tup => tup <> a /\ i tup) _ _ H1 H''); eauto.
      unfold Ensembles.In; intros; intuition; subst; eauto.
      eapply H in H6; intuition.
      apply H4; apply in_map; auto.
      apply H; intuition.
      destruct_ex; intuition.
      eexists x0, x1; intuition.
      apply H2.
  Qed.

  Lemma In_UnConstrQuery_In' {qsSchema} {A}
    : forall (qs : UnConstrQueryStructure qsSchema) Ridx
             (bod : RawTuple -> Comp (list A))
             results
             (a : A) (tup' : IndexedRawTuple),
      Ensembles.In _ (GetUnConstrRelation qs Ridx) tup'
      -> (forall results', bod (indexedElement tup') ↝ results'
                           -> List.In a results')
      -> UnConstrQuery_In qs Ridx bod ↝ results
      -> List.In a results.
  Proof.
    unfold UnConstrQuery_In, QueryResultComp, Ensembles.In; intros.
    computes_to_inv.
    unfold UnIndexedEnsembleListEquivalence in *; destruct_ex; intuition; subst.
    rewrite map_map in H1'.
    remember (GetUnConstrRelation qs Ridx); clear Heqi;
    revert i a results H H0 H1 H1' H4;
    induction x; simpl in *; intros;
    computes_to_inv; subst.
    - simpl in *; intuition; eapply H1; eauto.
    - apply H1 in H; intuition; subst; apply in_or_app; eauto.
      right; inversion H4; subst.
      eapply (IHx (fun tup => tup <> a /\ i tup)); eauto.
      intuition; subst; eauto.
      apply H5; eauto using in_map.
      apply H1; eauto.
      unfold Ensembles.In; intuition; intros; eauto.
      rewrite H1 in H7; intuition.
      subst; eauto using in_map.
      apply H1; eauto.
  Qed.

  Lemma DeleteForeignKeysCheck {qsSchema}
    : forall (qs : UnConstrQueryStructure qsSchema)
             (Ridx Ridx' :Fin.t _)
             (DeletedTuples : Ensemble (RawTuple ))
             (Delete_dec : DecideableEnsemble DeletedTuples)
             (attr : Attributes _)
             (attr' : Attributes _)
             (tupmap : Domain _ attr
                       -> Domain _ attr')
             (AgreeDelete : forall tup tup',
                 tupleAgree tup tup' [attr] ->
                 DeletedTuples tup ->
                 DeletedTuples tup')
             (attr_eq_dec : Query_eq (Domain _ attr))
             (P : Prop)
             (ForeignKey_P_P :
                P -> (forall tup' : IndexedRawTuple,
                         GetUnConstrRelation qs Ridx' tup' ->
                         ForeignKey_P attr' attr tupmap (indexedElement tup')
                                      (GetUnConstrRelation qs Ridx)))
             (tup_map_inj : forall a a', tupmap a = tupmap a' -> a = a'),
      refine {b' |
              P ->
              decides b'
                      (MutationPreservesCrossConstraints
                         (GetUnConstrRelation qs Ridx')
                         (EnsembleDelete (GetUnConstrRelation qs Ridx) DeletedTuples)
                         (ForeignKey_P attr' attr tupmap))}
             (x <- Count (For (UnConstrQuery_In
                                 qs Ridx'
                                 (fun tup' =>
                                    UnConstrQuery_In
                                      qs Ridx
                                      (fun tup =>
                                         Where (DeletedTuples tup)
                                               Where (tupmap (GetAttributeRaw tup attr) = GetAttributeRaw tup' attr')
                                               Return ()))));
              ret (match x with
                     0  => true
                   | S _ => false
                   end)).
  Proof.
    simpl; unfold ForeignKey_P; intros.
    intros v Comp_v.
    computes_to_inv; destruct_ex; split_and.
    unfold Count in *;  computes_to_inv.
    destruct v0; simpl in *; subst;  computes_to_inv; subst;
    computes_to_constructor; simpl; unfold not;
    unfold MutationPreservesCrossConstraints; intros.
    - destruct (ForeignKey_P_P H _ H0) as [tup2 [In_tup2 Agree_tup2] ].
      eexists; intuition eauto.
      unfold EnsembleDelete; constructor; unfold In; intros; eauto.
      unfold Complement, Ensembles.In, not; intros.
      unfold Query_For in *;  computes_to_inv.
      rewrite Permutation_nil in Comp_v; symmetry in Comp_v'0; eauto.
      apply (fun x => In_UnConstrQuery_In' _ _ _ _ () _ H0 x Comp_v).
      intros results' H3;
        apply (fun x => In_UnConstrQuery_In' _ _ _ _ () _ In_tup2 x H3).
      intros results'0 H5.
      unfold Query_Where in H5; computes_to_inv;
      simpl in *; intuition.
      computes_to_inv; split_and.
      simpl in H4.
      unfold QSGetNRelSchema, GetNRelSchema in Agree_tup2; simpl in *.
      rewrite Agree_tup2 in H4; pose proof (H4 (refl_equal _)) as H';
      computes_to_inv; simpl in *; subst; simpl; eauto.
      apply Return_inv in H'; subst; simpl; intuition.
      rewrite Comp_v'; destruct v1; try discriminate; reflexivity.
    - unfold Query_For in *;  computes_to_inv.
      eapply In_UnConstrQuery_In with (a := tt) in Comp_v; destruct_ex;
      intuition.
      pose proof (H3 _ H2); pose proof (H0 _ H2); destruct_ex;
      intuition.
      eapply In_UnConstrQuery_In with (a := tt) in H1; destruct_ex;
      intuition.
      unfold EnsembleDelete in *; inversion H5; subst;
      unfold Ensembles.In, Complement, In in *.
      unfold Query_Where in H1; computes_to_inv;  intuition.
      case_eq (@dec _ _ Delete_dec (indexedElement x3)); intros.
      + apply Delete_dec in H1; pose proof (H13 H1) as H'.
        computes_to_inv; split_and.
        unfold indexedTuple in *.
        destruct (A_eq_dec (GetAttributeRaw (indexedElement x3) attr)
                           (GetAttributeRaw (indexedElement x1) attr)).
        * rewrite e in *; setoid_rewrite <- H9 in H15; subst;
          pose proof (H15 (refl_equal _)) as e'; computes_to_inv; simpl in *; subst.
          apply H12; eapply AgreeDelete; eauto.
          unfold tupleAgree; simpl; intros attr'' In_attr''; destruct In_attr'';
          [rewrite H17 in *; eauto | intuition ].
        * rewrite H16 in H11; simpl in *; eauto.
          intros;
            unfold QSGetNRelSchema, GetNRelSchema in *; simpl in *;
            setoid_rewrite <- H17 in H9; eauto.
      + rewrite H14 in H11; simpl in *; eauto.
        intros H'; apply dec_decides_P in H'; congruence.
      + eapply Permutation_in; symmetry in Comp_v'; simpl; eauto.
        destruct v1; simpl in *;
        [ discriminate | destruct u; eauto].
  Qed.

  Lemma InsertForeignKeysCheck {qsSchema}
    : forall
      (qs : UnConstrQueryStructure qsSchema)
      (Ridx Ridx' :Fin.t _)
      (attr : Attributes _)
      (attr' : Attributes _)
      (tupmap : Domain _ attr' -> Domain _ attr)
      tup
      (ForeignKey_P_P :
         (forall tup' : IndexedRawTuple,
             GetUnConstrRelation qs Ridx tup' ->
             ForeignKey_P attr attr' tupmap (indexedElement tup')
                          (GetUnConstrRelation qs Ridx'))),
      Ridx <> Ridx'
      -> refine {b' |
                 decides b'
                         (forall tup',
                             (GetUnConstrRelation qs Ridx) tup' ->
                             ForeignKey_P attr attr' tupmap
                                          (indexedElement tup')
                                          (EnsembleInsert tup (GetUnConstrRelation qs Ridx')))}
                (ret true).
  Proof.
    intros; apply refine_pick_val; simpl; intros.
    unfold ForeignKey_P in *.
    destruct (ForeignKey_P_P _ H0) as [tup'' [In_tup'' ?] ];
      exists tup''; unfold EnsembleInsert; intuition.
  Qed.

End ConstraintCheckRefinements.

Lemma In_flatten_CompList {A} :
  forall (P : Ensemble A)
         (P_dec : forall a, P a \/ ~ P a)
         (il : list (@IndexedElement A))
         (l : list A)
         (a : A),
    List.In a l
    -> flatten_CompList
         (map
            (fun x1 : IndexedElement =>
               Where (P (indexedElement x1))
                     Return (indexedElement x1) ) il) ↝ l
    -> exists a', List.In a' il /\ indexedElement a' = a.
Proof.
  induction il; simpl; intros;  computes_to_inv; subst; simpl in *; intuition.
  apply in_app_or in H; intuition.
  unfold Query_Where in H0; computes_to_inv; intuition.
  destruct (P_dec (indexedElement a)).
  apply H in H0; unfold Query_Return in *; computes_to_inv; subst;
  simpl in H; exists a; simpl in H1; intuition; eauto.
  apply H2 in H0; subst; simpl in *; contradiction.
  destruct (IHil _ _ H1 H0') as [a' [In_a' a'_eq] ]; exists a'; split; eauto.
Qed.

Lemma For_computes_to_In :
  forall {heading} P,
    (forall a, P a \/ ~ P a) ->
    forall seq ens,
      computes_to (For (QueryResultComp (heading := heading) ens
                                        (fun tup => Where (P tup) Return tup))) seq ->
      forall x,
        List.In x seq -> (P x /\ (exists x0, ens x0 /\ indexedRawTuple x0 = x)).
Proof.
  unfold refine, decides;
  unfold Query_For, QueryResultComp; intros * excl;
  induction seq as [ | head seq' IH ]; intros.

  exfalso; intuition.

  computes_to_inv.

  pose proof (permutation_cons_in H') as in_x0.
  apply in_split in in_x0.
  destruct in_x0 as [ x0_before [ x0_after ? ] ]; subst.
  symmetry in H'. apply Permutation_cons_app_inv in H'.

  unfold UnIndexedEnsembleListEquivalence in H; destruct_ex; intuition; subst.

  rewrite map_map in H'0.
  destruct (flatten_CompList_app_cons_inv _ excl _ _ _ _ H'0) as [ x1_before [ x1_middle [ head' [ x1_after (_eq & in_orig & before & middle & after) ] ] ] ]; subst.

  unfold boxed_option in middle; simpl in middle.
  eapply Bind_inv in middle.
  destruct middle as [head'' (middle1 & middle2)].
  apply Pick_inv in middle1.
  apply Bind_inv in middle2.
  destruct middle1 as ( spec1 & spec2 ).
  destruct middle2 as [ nil' (ret_nil & ret_cons) ].
  apply Return_inv in ret_nil; subst.
  rewrite app_nil_r in *; subst.
  apply Return_inv in ret_cons; subst.

  rewrite singleton_neq_nil in spec2.
  destruct (excl (indexedRawTuple head')) as [ H'' | H'' ]; try solve [exfalso; intuition].
  specialize (spec1 H'').

  apply Return_inv in spec1.
  injection spec1; intros; subst.

  destruct H0.

  - subst x; eauto.
  - pose proof (flatten_CompList_app _ _ _ _ before after) as flatten_app.
    eapply IH; try assumption.
    computes_to_econstructor; [ | computes_to_constructor; symmetry; eassumption ].
    computes_to_econstructor.
    pose proof (EnsembleListEquivalence_slice x1_before x1_middle x1_after).
    instantiate (2 := (fun x0 : IndexedRawTuple => ens x0 /\ ~ List.In x0 x1_middle)).
    eapply PickComputes with (a := map indexedElement (x1_before ++ x1_after)).
    econstructor; split; eauto; intuition.
    destruct (H1 ens).
    unfold EnsembleListEquivalence; split; eauto using NoDup_IndexedElement.
    eapply H5; eauto.
    unfold Ensembles.In; split.
    eapply H; apply in_app_or in H2; intuition.
    intros; apply NoDup_IndexedElement in H3; eapply NoDup_app_inv'; eauto using in_app_or.
    repeat rewrite map_app in *; eauto using NoDup_slice.
    unfold boxed_option in *.
    rewrite !map_app, !map_map.
    apply flatten_app.

  - rewrite map_map in H'0.
    destruct (In_flatten_CompList P excl x0 (x0_before ++ head :: x0_after) x) as [x1 [In_x1 x1_eq] ];
      eauto.
    eapply Permutation_in with (l := head :: (x0_before ++ x0_after)).
    eapply Permutation_middle.
    simpl in *; intuition; right; eauto using Permutation_in.
    exists x1; split; eauto.
    apply H; eauto.
Qed.

Lemma UnIndexedEnsembleListEquivalence_eqv {A}
  : forall ens l,
    @UnIndexedEnsembleListEquivalence A ens l ->
    exists l',
      EnsembleListEquivalence ens l' /\ l = map indexedElement l'.
Proof.
  unfold UnIndexedEnsembleListEquivalence, EnsembleListEquivalence; intros.
  destruct_ex; intuition.
  exists x; intuition; eauto using NoDup_IndexedElement.
Qed.

Lemma For_computes_to_nil :
  forall {heading} P,
  forall ens,
    computes_to (For (QueryResultComp (heading := heading) ens
                                      (fun tup => Where (P tup) Return tup))) [] ->
    forall x,
      ens x -> ~ (P (indexedRawTuple x)).
Proof.
  unfold refine, decides, Count, Query_For, QueryResultComp; intros **.
  computes_to_inv.
  symmetry in H'; apply Permutation_nil in H'; subst.
  apply UnIndexedEnsembleListEquivalence_eqv in H; destruct_ex; intuition; subst.

  apply H2 in H0.
  apply in_split in H0.
  destruct H0 as [ x1_before [ x1_after _eq ] ]; subst.
  rewrite map_map in H'0.
  eapply (@FlattenCompList.flatten_CompList_nil _ P); unfold boxed_option; eauto; intuition.
Qed.

Lemma decidable_excl :
  forall {A : Type} (P : Ensemble A) (P_dec : DecideableEnsemble P),
    (forall (a: A), P a \/ ~ P a).
Proof.
  intros ??? a.
  destruct (dec a) eqn:eqdec;
    [ rewrite dec_decides_P in eqdec | rewrite Decides_false in eqdec ]; intuition.
Qed.

Lemma refine_constraint_check_into_QueryResultComp :
  forall heading R P' P
         (P_dec : DecideableEnsemble P),
    Same_set _ (fun tup => P (indexedElement tup)) P'
    -> refine
         (Pick (fun (b : bool) =>
                  decides b
                          (exists tup2: @IndexedRawTuple heading,
                              (R tup2 /\ P' tup2))))
         (Bind
            (Count (For (QueryResultComp R (fun tup => Where (P tup) Return tup))))
            (fun count => ret (negb (beq_nat count 0)))).
Proof.
  Local Transparent Count.
  unfold refine, Count, UnConstrQuery_In;
    intros * excl * P_iff_P' pick_comp ** .
  computes_to_inv; subst.

  computes_to_constructor.

  destruct (Datatypes.length v0) eqn:eq_length;
    destruct v0 as [ | head tail ]; simpl in *; try discriminate; simpl.

  pose proof (For_computes_to_nil _ R H).
  rewrite not_exists_forall; intro a; rewrite not_and_implication; intros.
  unfold not; intros; eapply H0; eauto; apply P_iff_P'; eauto.

  apply For_computes_to_In with (x := head) in H; try solve [intuition].
  destruct H as ( p & [ x0 ( in_ens & _eq ) ] ); subst.
  eexists; split; eauto; apply P_iff_P'; eauto.

  apply decidable_excl; assumption.
Qed.

Lemma refine_constraint_check_into_query' :
  forall {schm tbl} (c : UnConstrQueryStructure schm) P' P
         (P_dec : DecideableEnsemble P),
    Same_set _ (fun tup => P (indexedElement tup)) P'
    -> refine
         (Pick (fun (b : bool) =>
                  decides b
                          (exists tup2: @IndexedRawTuple _,
                              (GetUnConstrRelation c tbl tup2 /\ P' tup2))))
         (Bind
            (Count (For (UnConstrQuery_In c tbl (fun tup => Where (P tup) Return tup))))
            (fun count => ret (negb (beq_nat count 0)))).
Proof.
  intros; rewrite refine_constraint_check_into_QueryResultComp; eauto.
  reflexivity.
Qed.

Corollary refine_constraint_check_into_query :
  forall {schm tbl} P (c : UnConstrQueryStructure schm)
         (P_dec : DecideableEnsemble P),
    refine
      (Pick (fun (b : bool) =>
               decides b
                       (exists tup2: @IndexedRawTuple _,
                           (GetUnConstrRelation c tbl tup2 /\ P (indexedRawTuple tup2)))))
      (Bind
         (Count (For (UnConstrQuery_In c tbl (fun tup => Where (P tup) Return tup))))
         (fun count => ret (negb (beq_nat count 0)))).
Proof.
  intros.
  setoid_rewrite refine_constraint_check_into_query'; eauto.
  reflexivity.
  unfold Same_set, Included; intuition.
Qed.

Lemma refine_constraint_check_into_query'' :
  forall heading R P' P
         (P_dec : DecideableEnsemble P),
    Same_set _ (fun tup => P (indexedElement tup)) P'
    -> refine
         (Pick (fun (b : bool) =>
                  decides b
                          (exists tup2: @IndexedRawTuple heading,
                              (R tup2 /\ P' tup2))))
         (Bind
            (Count (For (QueryResultComp R (fun tup => Where (P tup) Return tup))))
            (fun count => ret (negb (beq_nat count 0)))).
Proof.
  Local Transparent Count.
  unfold refine, Count, UnConstrQuery_In;
    intros * excl * P_iff_P' pick_comp ** .
  computes_to_inv; subst.

  computes_to_constructor.

  destruct (Datatypes.length v0) eqn:eq_length;
    destruct v0 as [ | head tail ]; simpl in *; try discriminate; simpl.

  pose proof (For_computes_to_nil _ R H).
  rewrite not_exists_forall; intro a; rewrite not_and_implication; intros.
  unfold not; intros; eapply H0; eauto; apply P_iff_P'; eauto.

  apply For_computes_to_In with (x := head) in H; try solve [intuition].
  destruct H as ( p & [ x0 ( in_ens & _eq ) ] ); subst.
  eexists; split; eauto; apply P_iff_P'; eauto.

  apply decidable_excl; assumption.
Qed.

Definition refine_foreign_key_check_into_query {schm tbl} :=
  @refine_constraint_check_into_query schm tbl.

Lemma refine_functional_dependency_check_into_query :
  forall {schm : RawQueryStructureSchema}
         {tbl}
         (ref : @RawTuple (@GetNRelSchemaHeading _ (qschemaSchemas schm) tbl))
         args1
         args2
         (c : UnConstrQueryStructure schm),
    DecideableEnsemble (fun x : RawTuple => tupleAgree_computational ref x args1 /\
                                            ~ tupleAgree_computational ref x args2) ->
    ((forall tup' : IndexedRawTuple,
         GetUnConstrRelation c tbl tup'
         -> FunctionalDependency_P args2 args1 ref (indexedElement tup'))
     <-> (forall tup',
             ~ (GetUnConstrRelation c tbl tup'
                /\ tupleAgree ref (indexedElement tup') args1
                /\ ~ tupleAgree ref (indexedElement tup') args2))) ->
    refine
      (Pick (fun (b : bool) =>
               decides b
                       (forall tup',
                           GetUnConstrRelation c tbl tup' ->
                           FunctionalDependency_P args2 args1 ref (indexedElement tup'))))
      (Bind (Count
               For (UnConstrQuery_In c tbl
                                     (fun tup =>
                                        Where (tupleAgree_computational ref tup args1 /\
                                               ~ tupleAgree_computational ref tup args2)
                                              Return tup)))
            (fun count => ret (beq_nat count 0))).
Proof.
  intros * is_dec ** .

  setoid_replace (forall tup', GetUnConstrRelation c tbl tup' ->
                               tupleAgree ref (indexedElement tup') args1
                               -> tupleAgree ref (indexedElement tup') args2)
  with           (forall tup', ~ (GetUnConstrRelation c tbl tup' /\
                                  tupleAgree ref (indexedElement tup') args1 /\
                                  ~ tupleAgree ref (indexedElement tup') args2)); eauto.

  setoid_rewrite refine_decide_negation.
  setoid_rewrite (tupleAgree_equivalence ref).

  setoid_rewrite (@refine_constraint_check_into_query _ _
                                                      (fun x => tupleAgree_computational ref x args1 /\
                                                                          ~ tupleAgree_computational ref x args2)); try assumption.

  Opaque Query_For Count.
  simplify with monad laws.
  setoid_rewrite negb_involutive.
  reflexivity.
Qed.

Lemma refine_functional_dependency_check_into_query' :
  forall {schm : RawQueryStructureSchema}
         {tbl}
         ref
         args1
         args2
         (c : UnConstrQueryStructure schm),
    DecideableEnsemble (fun x => tupleAgree_computational x ref args1 /\
                                         ~ tupleAgree_computational x ref args2) ->
    ((forall tup' ,
         GetUnConstrRelation c tbl tup'
         -> FunctionalDependency_P args2 args1 (indexedElement tup') ref)
     <-> (forall tup',
             ~ (GetUnConstrRelation c tbl tup'
                /\ tupleAgree (indexedElement tup') ref args1
                /\ ~ tupleAgree (indexedElement tup') ref args2))) ->
    refine
      (Pick (fun (b : bool) =>
               decides b
                       (forall tup',
                           GetUnConstrRelation c tbl tup' ->
                           FunctionalDependency_P args2 args1 (indexedElement tup') ref)))
      (Bind (Count
               For (UnConstrQuery_In c tbl
                                     (fun tup =>
                                        Where (tupleAgree_computational tup ref args1 /\
                                               ~ tupleAgree_computational tup ref args2)
                                              Return tup)))
            (fun count => ret (beq_nat count 0))).
Proof.
  intros * is_dec ** .

  setoid_replace (forall tup', GetUnConstrRelation c tbl tup' ->
                               tupleAgree (indexedElement tup') ref args1
                               -> tupleAgree (indexedElement tup') ref args2)
  with           (forall tup', ~ (GetUnConstrRelation c tbl tup' /\
                                  tupleAgree (indexedElement tup') ref args1 /\
                                  ~ tupleAgree (indexedElement tup') ref args2)); eauto.

  setoid_rewrite refine_decide_negation.
  setoid_rewrite tupleAgree_equivalence.
  setoid_rewrite (@refine_constraint_check_into_query _ _
                                                      (fun x => tupleAgree_computational x ref args1 /\
                                                                          ~ tupleAgree_computational x ref args2)); try assumption.

  Opaque Query_For Count.
  simplify with monad laws.
  setoid_rewrite negb_involutive.
  reflexivity.
Qed.

 Theorem FunctionalDependency_symmetry
  : forall A H (f : _ -> _ -> Comp A) (P : _ -> Prop) attrlist1 attrlist2 n,
    refine (x1 <- {b | decides b
                               (forall tup' : @IndexedRawTuple H,
                                   P tup'
                                   -> FunctionalDependency_P attrlist1 attrlist2 n (indexedElement tup'))};
            x2 <- {b | decides b (forall tup' : @IndexedRawTuple H,
                                     P tup'
                                     -> FunctionalDependency_P attrlist1 attrlist2 (indexedElement tup') n)};
            f x1 x2)
           (x1 <- {b | decides b (forall tup' : @IndexedRawTuple H,
                                     P tup'
                                     -> FunctionalDependency_P attrlist1 attrlist2 n (indexedElement tup'))};
            f x1 x1).
Proof.
  unfold refine, FunctionalDependency_P; intros.
  computes_to_inv; firstorder.
  computes_to_inv; firstorder.
  repeat (computes_to_econstructor; eauto).
  destruct v0; simpl in *; unfold tupleAgree in *; intros; eauto.
  erewrite H0; eauto; intros; rewrite H2; eauto.
  unfold not; intros; eapply H0; intros.
  rewrite H1; eauto; intros; rewrite H3; eauto.
Qed.

Theorem FunctionalDependency_symmetry'
  : forall H P attrlist1 attrlist2 n b',
    decides b'
            (forall tup' : @IndexedRawTuple H,
                P tup'
                -> FunctionalDependency_P attrlist1 attrlist2 n (indexedElement tup'))
    -> refine {b | decides b (forall tup' : @IndexedRawTuple H,
                                 P tup'
                                 -> FunctionalDependency_P attrlist1 attrlist2 (indexedElement tup') n)}
                  (ret b').
Proof.
  unfold FunctionalDependency_P; intros.
  refine pick val b'.
  reflexivity.
  destruct b'; simpl in *; unfold tupleAgree in *; intros; eauto.
  erewrite H0; eauto; intros; rewrite H1; eauto.
  unfold not; intros; eapply H0; intros.
  rewrite H1; eauto; intros; rewrite H2; eauto.
Qed.

Lemma if_duplicate_cond_eq {A}
  : forall (i : bool) (t e : A),
    (if i then (if i then t else e) else e) = if i then t else e.
Proof.
  destruct i; reflexivity.
Qed.

Global Instance nil_List_Query_eq :
  List_Query_eq [] :=
  { As_Query_eq := tt  }.

Global Instance cons_List_Query_eq
       {A : Type}
       {As : list Type}
       {A_Query_eq : Query_eq A}
       {As_Query_eq' : List_Query_eq As}
  :
    List_Query_eq (A :: As) :=
  { As_Query_eq := (A_Query_eq, As_Query_eq) }.

Theorem UniqueAttribute_symmetry
  : forall A (f : _ -> _ -> Comp A) H (P : _ -> Prop) attr n,
    refine (b1 <- {b | decides b
                               (forall tup' : @IndexedRawTuple H,
                                   P tup'
                                   -> UniqueAttribute' attr n (indexedElement tup'))};
           b2 <- {b | decides b (forall tup' : @IndexedRawTuple H,
                                     P tup'
                                     -> UniqueAttribute' attr (indexedElement tup') n)}; f b1 b2)
           (b1 <- {b | decides b
                               (forall tup' : @IndexedRawTuple H,
                                   P tup'
                                   -> UniqueAttribute' attr n (indexedElement tup'))}; f b1 b1).
Proof.
  unfold refine, UniqueAttribute'; intros.
  computes_to_inv; firstorder.
  repeat (computes_to_econstructor; eauto).
  destruct v0; simpl in *; unfold not in *; intros; eauto.
Qed.

Lemma refine_uniqueness_check_into_query' :
  forall {schm : RawQueryStructureSchema}
         idx
         tup
         attr
         (c : UnConstrQueryStructure schm),
    Query_eq (Domain (GetNRelSchemaHeading (qschemaSchemas schm) idx) attr)
    -> refine
      {b | decides b
                   (forall tup' : @IndexedRawTuple _,
                       GetUnConstrRelation c idx tup'
                       -> UniqueAttribute' attr tup (indexedElement tup'))}
      (c <- (Count
               For (UnConstrQuery_In c idx
                                     (fun tup' =>
                                        Where (GetAttributeRaw tup attr
                                               = GetAttributeRaw tup' attr)
                                              Return tup')));
            (ret (beq_nat c 0))).
Proof.
  intros.
  setoid_replace (forall tup', GetUnConstrRelation c idx tup' ->
                               UniqueAttribute' attr tup (indexedElement tup'))
with           (forall tup', ~ (GetUnConstrRelation c idx tup' /\
                                GetAttributeRaw tup attr = GetAttributeRaw  (indexedElement tup') attr)) by
      (unfold UniqueAttribute'; intuition eauto).
  setoid_rewrite refine_decide_negation.
  rewrite (@refine_constraint_check_into_query _ _
                                                      (fun tup' => GetAttributeRaw tup attr = GetAttributeRaw tup' attr)) by eauto with typeclass_instances.
  simplify with monad laws.
  setoid_rewrite negb_involutive.
  reflexivity.
Qed.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RVIC2.Spec.
Require Import RVIC.Spec.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition validate_and_lookup_target_spec0 (rec: Pointer) (target: Z64) (intid: Z64) (adt: RData) : option (RData * Z64) :=
    match rec, target, intid with
    | (_rec_base, _rec_ofst), VZ64 _target, VZ64 _intid =>
      rely is_int64 _target;
      when _target_valid == rvic_target_is_valid_spec (VZ64 _target) adt;
      rely is_int _target_valid;
      if (_target_valid =? 0) then
        Some (adt, (VZ64 1))
      else
        rely is_int64 _intid;
        when _t'4 == is_trusted_intid_spec (VZ64 _intid) adt;
        rely is_int _t'4;
        if (_t'4 =? 0) then
          when _t'6 == is_untrusted_intid_spec (VZ64 _intid) adt;
          rely is_int _t'6;
          let _t'5 := (_t'6 =? 0) in
          if _t'5 then
            Some (adt, (VZ64 1))
          else
            when adt == find_lock_map_target_rec_spec (_rec_base, _rec_ofst) (VZ64 _target) adt;
            when'' _t'2_base, _t'2_ofst == get_target_rec_spec  adt;
            rely is_int _t'2_ofst;
            when _t'3 == is_null_spec (_t'2_base, _t'2_ofst) adt;
            rely is_int _t'3;
            if (_t'3 =? 1) then
              Some (adt, (VZ64 1))
            else
              Some (adt, (VZ64 0))
        else
          let _t'5 := 0 in
          when adt == find_lock_map_target_rec_spec (_rec_base, _rec_ofst) (VZ64 _target) adt;
          when'' _t'2_base, _t'2_ofst == get_target_rec_spec  adt;
          rely is_int _t'2_ofst;
          when _t'3 == is_null_spec (_t'2_base, _t'2_ofst) adt;
          rely is_int _t'3;
          if (_t'3 =? 1) then
            Some (adt, (VZ64 1))
          else
            Some (adt, (VZ64 0))
     end
    .

End SpecLow.