Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import omega.Omega.
Require Import Setoid.
Require Import ZArith.
Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.
Local Open Scope struct_scope.
Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.
Require Import depoolContract.DePoolFunc.
Require Import depoolContract.DePoolConsts.
Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Scenarios.ScenarioCommon.
Import DePoolSpec.LedgerClass.SolidityNotations.
Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.
Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100.
Module Scenario2  (dc : DePoolConstsTypesSig XTypesSig StateMonadSig).
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig dc.
Import dc.
Module ScenarioCommon := ScenarioCommon dc.
Import ScenarioCommon.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Lemma Scenario_OrdinaryStakeLose_byValidator: forall
                        (minStake validatorAssurance proxyCode validatorWallet   participantRewardFraction : Z)
                        (proxyCode : TvmCell)
                        (now_constructor msg_pubkey_constructor : Z)
                        (NetParams_init : NetParams)
                        (stake :Z )
                        (NetParams_addOrdinaryStake :  NetParams)
                        (now_addOrdinaryStake msg_value_addOrdinaryStake msg_sender_addOrdinaryStake : Z)
                        (now_round1  msg_value_round1 msg_sender_round1 : Z)
                        (NetParams_round1 :  NetParams)
                        (queryId0 validatorKey stakeAt maxFactor adnlAddr : Z)
                        ( signature : XList XInteger8 )
                        (now_participateInElections  msg_value_participateInElections msg_sender_participateInElections : Z)
                        (NetParams_participateInElections :  NetParams)
                        (queryId comment elector : Z)
                        (now_onStakeAccept  msg_value_onStakeAccept msg_sender_onStakeAccept : Z)
                        (NetParams_onStakeAccept :  NetParams)
                        (now_toWaitingIfValidatorWinElections  msg_value_toWaitingIfValidatorWinElections msg_sender_toWaitingIfValidatorWinElections : Z)
                        (NetParams_toWaitingIfValidatorWinElections :  NetParams)
                        (now_onSuccessToRecoverStake  msg_value_onSuccessToRecoverStake msg_sender_onSuccessToRecoverStake : Z)
                        (NetParams_onSuccessToRecoverStake :  NetParams)
                        (now_toWaitingReward  msg_value_toWaitingReward msg_sender_toWaitingReward : Z)
                        (NetParams_toWaitingReward :  NetParams),
let l_init_NetParams := withNetParams default NetParams_init in
let l_init := {$ l_init_NetParams With (VMState_ι_now,   now_constructor);
                                       (VMState_ι_msg_pubkey,   msg_pubkey_constructor)$} in
let l_constructor:= exec_state (DePoolContract_Ф_Constructor6 minStake validatorAssurance proxyCode validatorWallet   participantRewardFraction  ) l_init in
let (r, l_fin) := run  (modify (fun l => withNetParams l NetParams_addOrdinaryStake) >>
                        modify (fun l => {$ l With (VMState_ι_now,   now_addOrdinaryStake);
                                                   (VMState_ι_msg_value , msg_value_addOrdinaryStake);
                                                   (VMState_ι_msg_sender , msg_sender_addOrdinaryStake) $}) >>
                        do _ ← DePoolContract_Ф_addOrdinaryStake'' stake ??;
                        modify (fun l => withNetParams l NetParams_round1) >>
                        modify (fun l => {$ l With (VMState_ι_now,          now_round1);
                                                   (VMState_ι_msg_value ,   msg_value_round1);
                                                   (VMState_ι_msg_sender ,  msg_sender_round1) $}) >>
                        do _ ← DePoolContract_Ф_ticktock ??;
                        modify (fun l => withNetParams l NetParams_participateInElections) >>
                        modify (fun l => {$ l With (VMState_ι_now,          now_participateInElections);
                                                   (VMState_ι_msg_value ,   msg_value_participateInElections);
                                                   (VMState_ι_msg_sender ,  msg_sender_participateInElections) $}) >>
                        do _ ← DePoolContract_Ф_participateInElections'' queryId0 validatorKey stakeAt maxFactor adnlAddr signature ??;
                        modify (fun l => withNetParams l NetParams_onStakeAccept) >>
                        modify (fun l => {$ l With (VMState_ι_now,          now_onStakeAccept);
                                                   (VMState_ι_msg_value ,   msg_value_onStakeAccept);
                                                   (VMState_ι_msg_sender ,  msg_sender_onStakeAccept) $}) >>
                        do _ ← DePoolContract_Ф_onStakeAccept queryId comment elector ??;
                        modify (fun l => withNetParams l NetParams_toWaitingIfValidatorWinElections) >>
                        modify (fun l => {$ l With (VMState_ι_now,          now_toWaitingIfValidatorWinElections);
                                                   (VMState_ι_msg_value ,   msg_value_toWaitingIfValidatorWinElections);
                                                   (VMState_ι_msg_sender ,  msg_sender_toWaitingIfValidatorWinElections) $}) >>
                        do _ ← DePoolContract_Ф_ticktock ??;
                        modify (fun l => withNetParams l NetParams_onSuccessToRecoverStake) >>
                        modify (fun l => {$ l With (VMState_ι_now,          now_onSuccessToRecoverStake);
                                                   (VMState_ι_msg_value ,   msg_value_onSuccessToRecoverStake);
                                                   (VMState_ι_msg_sender ,  msg_sender_onSuccessToRecoverStake) $}) >>
                        do _ ← DePoolContract_Ф_onSuccessToRecoverStake queryId elector ??;
                        modify (fun l => withNetParams l NetParams_toWaitingReward) >>
                        modify (fun l => {$ l With (VMState_ι_now,          now_toWaitingReward);
                                                   (VMState_ι_msg_value ,   msg_value_toWaitingReward);
                                                   (VMState_ι_msg_sender ,  msg_sender_toWaitingReward) $}) >>
                        do _ ← DePoolContract_Ф_ticktock ?;
                        $ I )  l_constructor in errorValueIsValue r = true ->
msg_sender_addOrdinaryStake = validatorWallet ->
(now_round1 >=? NetParams_round1 ->> NetParams_ι_utime_until - NetParams_round1 ->> NetParams_ι_electionsStartBefore) = true ->
((negb (tvm_hash (NetParams_init ->> NetParams_ι_curValidatorData) =? tvm_hash (NetParams_round1 ->> NetParams_ι_curValidatorData))) &&
(negb (tvm_hash (NetParams_init ->> NetParams_ι_prevValidatorData) =? tvm_hash (NetParams_round1 ->> NetParams_ι_curValidatorData))))%bool= true ->
(stake >=? validatorAssurance) = true ->
( tvm_hash  (NetParams_round1 ->> NetParams_ι_curValidatorData)  =?  tvm_hash  (NetParams_toWaitingIfValidatorWinElections ->> NetParams_ι_prevValidatorData))  = true ->
(now_toWaitingIfValidatorWinElections >=? NetParams_toWaitingIfValidatorWinElections ->> NetParams_ι_utime_until - NetParams_toWaitingIfValidatorWinElections ->> NetParams_ι_electionsStartBefore) = true ->
(negb (0 =? tvm_hash ((NetParams_toWaitingIfValidatorWinElections ->> NetParams_ι_curValidatorData)))) = true ->
((negb (tvm_hash ((NetParams_toWaitingReward ->> NetParams_ι_curValidatorData)) =? tvm_hash ((NetParams_round1 ->> NetParams_ι_curValidatorData)))) &&
(negb (tvm_hash ((NetParams_toWaitingReward ->> NetParams_ι_prevValidatorData)) =? tvm_hash ((NetParams_round1 ->> NetParams_ι_curValidatorData)))))%bool= false ->
(now_toWaitingReward >=? NetParams_toWaitingReward ->> NetParams_ι_utime_since + NetParams_round1 ->> NetParams_ι_stakeHeldFor + DePoolLib_ι_ELECTOR_UNFREEZE_LAG) = true ->
(msg_value_onSuccessToRecoverStake + DePoolLib_ι_PROXY_FEE >=? stake) = true ->
 let optRound := eval_state ( ↓ ( RoundsBase_Ф_fetchRound queryId ) ) l_fin in
 let round := maybeGet optRound in
 let stakes :=  round ->> RoundsBase_ι_Round_ι_stakes in
 let optStake := stakes ->fetch validatorWallet in
 let current_stakes := maybeGet optStake in
 round ->> RoundsBase_ι_Round_ι_stake = stake
 /\ current_stakes ->> RoundsBase_ι_StakeValue_ι_ordinary  = stake.
Proof.

Abort.
End Scenario2.


Require Import VST.msl.seplog.
Require Import VST.msl.sepalg.
Require Import VST.msl.psepalg.
Require Import VST.msl.alg_seplog_direct.
Require Import RamifyCoq.msl_ext.abs_addr.
Require Import RamifyCoq.msl_ext.seplog.
Require Import RamifyCoq.msl_ext.overlapping_direct.
Require Import RamifyCoq.msl_ext.alg_seplog_direct.
Require Import RamifyCoq.msl_ext.ramify_tactics.
Require Import RamifyCoq.heap_model_direct.SeparationAlgebra.
Require Import RamifyCoq.heap_model_direct.mapsto.
Require Import VST.msl.msl_direct.
Require Import VST.msl.predicates_sa.

Instance Ndirect : NatDed (pred world) := algNatDed world.
Instance Sdirect : SepLog (pred world) := algSepLog world.
Instance Cldirect : ClassicalSep (pred world) := algClassicalSep world.
Instance CSLdirect : CorableSepLog (pred world) := algCorableSepLog world.
Instance PSLdirect : PreciseSepLog (pred world) := algPreciseSepLog world.
Instance OSLdirect : OverlapSepLog (pred world) := algOverlapSepLog world.
Instance DSLdirect : DisjointedSepLog (pred world) := algDisjointedSepLog world.

Instance MSLdirect : MapstoSepLog AbsAddr_world mapsto.
Proof.
  apply mkMapstoSepLog.
  apply mapsto__precise.
Defined.

Instance sMSLdirect : StaticMapstoSepLog AbsAddr_world mapsto.
Proof.
  apply mkStaticMapstoSepLog; simpl; intros.
  + hnf in H. simpl in H. unfold adr_conflict in H. destruct (eq_nat_dec p p).
    - inversion H.
    - exfalso; tauto.
  + apply mapsto_conflict.
    unfold adr_conflict in H.
    destruct (eq_nat_dec p1 p2); congruence.
  + apply disj_mapsto_.
    unfold adr_conflict in H.
    destruct (eq_nat_dec p1 p2); congruence.
Defined.

Instance nMSLdirect : NormalMapstoSepLog AbsAddr_world mapsto.
Proof.
  apply mkNormalMapstoSepLog.
  apply mapsto_inj.
Defined.


(* *********************************************************************)
(*                                                                     *)
(*              The L2C verified compiler                              *)
(*                                                                     *)
(*            L2C Group, Tsinghua University                           *)
(*                                                                     *)
(*  Copyright Tsinghua University.  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.                                                         *)
(*                                                                     *)
(* *********************************************************************)

Require Import Coqlib.
Require Import AST.
Require Import Errors.
Require Import Memdata.
Require Import Lint.
Require Import Integers.
Require Import Ctypes.
Require Import Cltypes.

Definition sizeof_fld(fld: fieldlist):=
  align (sizeof_struct fld 0) (alignof_fields fld).

Lemma sizeof_fld_pos:
  forall fld, 0 <= sizeof_fld fld.
Proof.
  unfold sizeof_fld. intros.
  apply Zle_trans with (sizeof_struct fld 0); try omega.
  apply sizeof_struct_incr; auto.
  apply align_le. apply alignof_fields_pos.
Qed.

Lemma field_offset_in_range_simpl:
  forall id fld delta ty,
  field_offset id fld = OK delta ->
  field_type id fld = OK ty ->
  0 <= delta /\ delta + sizeof ty <= sizeof_fld fld.
Proof.
  intros.
  apply field_offset_in_range with (sid:=xH) (ty:=ty) in H; auto.
Qed.

Lemma field_offset_unsigned_repr:
  forall id fld z ty,
  field_offset id fld = OK z ->
  field_type id fld = OK ty ->
  sizeof_fld fld <= Int.max_unsigned ->
  Int.unsigned (Int.repr z) = z.
Proof.
  intros.
  eapply field_offset_in_range_simpl in H; eauto.
  generalize (sizeof_pos ty); intros.
  rewrite Int.unsigned_repr; try omega.
Qed.

Lemma field_offset_rec_type_exists:
  forall fld fid ofs pos,
  field_offset_rec fid fld pos = OK ofs ->
  exists ty, field_type fid fld = OK ty.
Proof.
  induction fld; simpl; intros.
  inv H.
  destruct (ident_eq _ _); eauto.
Qed.

Lemma field_offset_type_exists:
  forall fld fid ofs,
  field_offset fid fld = OK ofs ->
  exists ty, field_type fid fld = OK ty.
Proof.
  unfold field_offset. intros.
  eapply field_offset_rec_type_exists; eauto.
Qed.

Lemma field_type_offset_rec_exists:
  forall fld fid ty pos,
  field_type fid fld = OK ty ->
  exists ofs, field_offset_rec fid fld pos = OK ofs.
Proof.
  induction fld; simpl; intros.
  congruence.
  destruct (ident_eq fid i).
  inv H. eauto.
  eapply IHfld; eauto.
Qed.

Lemma field_type_offset_exists:
  forall fld fid ty,
  field_type fid fld = OK ty ->
  exists ofs, field_offset fid fld = OK ofs.
Proof.
  unfold field_offset. intros.
  eapply field_type_offset_rec_exists; eauto.
Qed.

Definition fieldlist_of(vas: list (ident*type)): fieldlist :=
  fold_right (fun p=> Fcons (fst p) (snd p)) Fnil vas.

Lemma fieldlist_list_in:
  forall al id ty,
  field_type id (fieldlist_of al) = OK ty ->
  In (id, ty) al.
Proof.
  induction al; simpl; intros.
  inv H.
  destruct a. simpl in *.
  compare id i; intros.
  subst. rewrite peq_true in *. inv H; auto.
  rewrite peq_false in *; eauto.
Qed.

Lemma list_in_fieldlist:
  forall al id ty,
  In (id, ty) al ->
  list_norepet (map fst al) ->
  field_type id (fieldlist_of al) = OK ty.
Proof.
  induction al; intros.
  +inv H.
  +inv H0. destruct H; subst; simpl.
   -rewrite peq_true; auto.
   -assert(id <> fst a).
      apply in_map with _ _ fst _ _ in H; eauto.
      simpl in H. red; intros. subst. auto.
    repeat rewrite peq_false; auto.
Qed.

Lemma fieldlist_list_in_offset_exists:
  forall al id pos,
  In id (map fst al) ->
  exists delta, field_offset_rec id (fieldlist_of al) pos = OK delta.
Proof.
  induction al; simpl; intros.
  +inv H.
  +destruct H; subst; simpl.
   -rewrite peq_true; eauto.
   -destruct (ident_eq id (fst a)) eqn:?; eauto.
Qed.

Lemma fieldlist_list_id_in:
  forall al id delta pos,
  field_offset_rec id (fieldlist_of al) pos = OK delta ->
  In id (map fst al).
Proof.
  induction al; simpl; intros.
  inv H.
  compare id (fst a); intros.
  subst. rewrite peq_true in *. inv H; auto.
  rewrite peq_false in *; eauto.
Qed.

Lemma fieldlist_list_notin:
  forall al id pos msg,
  field_offset_rec id (fieldlist_of al) pos = Error msg ->
  ~ In id (map fst al).
Proof.
  induction al; simpl; intros; auto.
  compare (fst a) id; intros; subst.
  rewrite peq_true in H. inv H.
  rewrite peq_false in H; auto.
  red. intros. destruct H0; auto.
  eapply IHal; eauto.
Qed.

Lemma field_type_notin_app:
  forall l1 l2 id,
  ~ In id (map fst l1) ->
  field_type id (fieldlist_of (l1++l2)) = field_type id (fieldlist_of l2).
Proof.
  induction l1; simpl; intros; eauto.
  rewrite peq_false; auto.
Qed.

Lemma fieldlist_list_notin_inv:
  forall al id pos,
  ~ In id (map fst al) ->
  exists msg, field_offset_rec id (fieldlist_of al) pos = Error msg.
Proof.
  induction al; simpl; intros; eauto.
  rewrite peq_false; auto.
Qed.

Lemma field_type_offset_error_rec:
  forall fld id msg1 pos,
  field_type id fld = Error msg1 ->
  exists msg2, field_offset_rec id fld pos = Error msg2.
Proof.
  induction fld; simpl; intros; eauto.
  destruct (ident_eq _ _); try congruence.
  eauto.
Qed.

Lemma field_type_offset_error:
  forall fld id msg1,
  field_type id fld = Error msg1 ->
  exists msg2, field_offset id fld = Error msg2.
Proof.
  intros. apply field_type_offset_error_rec with msg1; auto.
Qed.

Lemma field_type_ok_app:
  forall l1 l2 id ty,
  field_type id (fieldlist_of l1) = OK ty ->
  field_type id (fieldlist_of (l1 ++ l2))  = OK ty.
Proof.
  induction l1; simpl; intros.
  congruence.

  destruct a; simpl in *.
  compare id i; intros ; subst.
  rewrite peq_true in *; auto.
  rewrite peq_false in *; auto.
Qed.

Lemma field_offset_rec_fieldlist_of_notin_app_cons:
  forall id ty l1 l2 z,
  ~ In id (map fst l1) ->
  field_offset_rec id (fieldlist_of (l1 ++ (id, ty) :: l2)) z = OK (align (sizeof_struct (fieldlist_of l1) z) (alignof ty)).
Proof.
  induction l1; simpl; intros; auto.
  +rewrite peq_true; auto.
  +rewrite peq_false; auto.
Qed.

Lemma sizeof_struct_fieldlist_of_app_cons:
  forall l id ty z,
  sizeof_struct (fieldlist_of (l ++ (id, ty) :: nil)) z =
  align (sizeof_struct (fieldlist_of l) z) (alignof ty) + sizeof ty.
Proof.
  induction l; simpl; auto.
Qed.

Definition access_mode (ty: type) : mode :=
  match ty with
  | Tint I8 Signed => By_value Mint8signed
  | Tint I8 Unsigned => By_value Mint8unsigned
  | Tint I16 Signed => By_value Mint16signed
  | Tint I16 Unsigned => By_value Mint16unsigned
  | Tint I32 _ => By_value Mint32
  | Tint IBool _ => By_value Mint8unsigned
  | Tfloat F32 => By_value Mfloat32
  | Tfloat F64 => By_value Mfloat64
  | Tvoid => By_nothing
  | Tpointer _ => By_nothing
  | Tarray _ _ _ => By_reference
  | Tfunction _ _ _ => By_nothing
  | Tstruct _ _ => By_copy
end.

Definition typeof_array(t: type): res (type*Z) :=
  match t with
  | Tarray _ ty num => OK (ty,num)
  | _ => Error (MSG "Not Tarray " :: nil)
  end.

Definition fieldof_struct(t: type): res fieldlist :=
  match t with
  | Tstruct _ fld => OK fld
  | _ => Error (MSG "Not Tstruct " :: nil)
  end.

Lemma access_mode_eq:
  forall t, (exists c, access_mode t = By_value c) \/ access_mode t = By_copy \/ access_mode t = By_reference ->
  access_mode t = Cltypes.access_mode t.
Proof.
  destruct t; simpl; intros; auto;
  destruct H as [? | [? | ?]]; inv H; inv H0.
Qed.

Lemma sizeof_chunk_eq:
  forall t chunk,
  access_mode t = By_value chunk ->
  size_chunk chunk = sizeof t.
Proof.
  destruct t; intros; inv H; simpl; auto.
  destruct i; destruct s; inv H1; auto.
  destruct f; inv H1; auto.
Qed.

Lemma alignof_chunk_eq:
  forall ty chunk,
  access_mode ty = By_value chunk ->
  alignof ty = align_chunk chunk.
Proof.
  induction ty; simpl; intros; try congruence; auto.
  destruct i,s; inv H; auto.
  destruct f; inv H; auto.
Qed.

Lemma field_type_alignof_le:
  forall i f t,
  field_type i f = OK t ->
  alignof t <= alignof_fields f.
Proof.
  induction f; simpl; intros.
  congruence.
  destruct (ident_eq _ _).
  +inv H. apply zmax_l_le. omega.
  +apply zmax_r_le. auto.
Qed.

Lemma field_type_alignof:
  forall i f t,
  field_type i f = OK t ->
  (alignof t | alignof_fields f).
Proof.
  intros. generalize (alignof_1248 t).
  generalize (alignof_fields_1248 f).
  apply field_type_alignof_le in H. intros.
  destruct H0 as [ | [ | [ | ]]]; destruct H1 as [ | [ | [ | ]]];
  rewrite H0,H1 in *; try omega; try (exists 1; omega; fail);
  try (exists 2; omega; fail) .
  exists 4; omega. exists 8. omega. exists 4. omega.
Qed.

Definition is_arystr(t: type): bool :=
  match t with
  | Tarray _ _ _ => true
  | Tstruct _ _ => true
  | _ => false
  end.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export terms2.
Require Export terms_tacs.
Require Export tactics2.

(* ------ binary and ------ *)

Definition mk_uand {p} (A B : @NTerm p) :=
  match newvars2 [A,B] with
    | (vx,vy) =>
      mk_isect mk_base vx
               (mk_isect (mk_halts (mk_var vx)) vy
                         (mk_isaxiom (mk_var vx) A B))
  end.

Lemma isprog_vars_uand {o} :
  forall (A B : @NTerm o) vs,
    isprog_vars vs (mk_uand A B) <=> (isprog_vars vs A # isprog_vars vs B).
Proof.
  introv.
  unfold mk_uand.
  remember (newvars2 [A,B]); repnd.
  apply newvars2_prop2 in Heqp; simpl in Heqp.
  allrw app_nil_r; allrw in_app_iff; allrw not_over_or; repnd.
  repeat (rw <- @isprog_vars_isect_iff).
  rw @isprog_vars_isaxiom.
  rw @isprog_vars_halts.
  allrw <- @isprog_vars_var_iff; simpl; split; intro k; repnd; dands; auto.
  repeat (apply isprog_vars_cons_if2 in k3; auto).
  repeat (apply isprog_vars_cons_if2 in k; auto).
  repeat (apply isprog_vars_cons; auto).
  repeat (apply isprog_vars_cons; auto).
Qed.

Lemma wf_uand {o} :
  forall a b : @NTerm o, wf_term (mk_uand a b) <=> (wf_term a # wf_term b).
Proof.
  introv.
  unfold mk_uand.
  remember (newvars2 [a,b]); repnd.
  apply newvars2_prop2 in Heqp; simpl in Heqp.
  allrw app_nil_r; allrw in_app_iff; allrw not_over_or; repnd.
  allrw <- @wf_isect_iff.
  rw <- @wf_halts_iff.
  rw @wf_isaxiom; split; sp.
Qed.

(* ------ free vars ------ *)

Lemma free_vars_lam {o} :
  forall v b, free_vars (@mk_lam o v b) = remove_nvars [v] (free_vars b).
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_isect {o} :
  forall a v b, free_vars (@mk_isect o a v b) = free_vars a ++ (remove_nvars [v] (free_vars b)).
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_function {o} :
  forall a v b, free_vars (@mk_function o a v b) = free_vars a ++ (remove_nvars [v] (free_vars b)).
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_product {o} :
  forall a v b, free_vars (@mk_product o a v b) = free_vars a ++ (remove_nvars [v] (free_vars b)).
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_tunion {o} :
  forall a v b, free_vars (@mk_tunion o a v b) = free_vars a ++ (remove_nvars [v] (free_vars b)).
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_cbv {o} :
  forall a v b, free_vars (@mk_cbv o a v b) = free_vars a ++ (remove_nvars [v] (free_vars b)).
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_base {o} :
  free_vars (@mk_base o) = [].
Proof.
  introv; simpl; sp.
Qed.

Lemma free_vars_axiom {o} :
  @free_vars o mk_axiom = [].
Proof.
  introv; simpl; sp.
Qed.

Lemma free_vars_approx {o} :
  forall a b, free_vars (@mk_approx o a b) = free_vars a ++ free_vars b.
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_isaxiom {o} :
  forall a b c, free_vars (@mk_isaxiom o a b c) = free_vars a ++ free_vars b ++ free_vars c.
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_equality {o} :
  forall a b c, free_vars (@mk_equality o a b c) = free_vars a ++ free_vars b ++ free_vars c.
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_tequality {o} :
  forall a b, free_vars (@mk_tequality o a b) = free_vars a ++ free_vars b.
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_apply {o} :
  forall a b, free_vars (@mk_apply o a b) = free_vars a ++ free_vars b.
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_union {o} :
  forall a b : @NTerm o, free_vars (mk_union a b) = free_vars a ++ free_vars b.
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_eunion {o} :
  forall a b : @NTerm o, free_vars (mk_eunion a b) = free_vars a ++ free_vars b.
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_halts {o} :
  forall a, free_vars (@mk_halts o a) = free_vars a.
Proof.
  introv.
  unfold mk_halts.
  rw @free_vars_approx.
  rw @free_vars_cbv.
  rw @free_vars_axiom.
  rw remove_nvars_nil_r; rw app_nil_r; simpl; sp.
Qed.

Lemma free_vars_uand {o} :
  forall A B, free_vars (@mk_uand o A B) = free_vars A ++ free_vars B.
Proof.
  introv.
  unfold mk_uand.

  remember (newvars2 [A,B]); repnd.
  apply newvars2_prop2 in Heqp; simpl in Heqp.
  repeat (rw app_nil_r in Heqp); repeat (rw in_app_iff in Heqp).
  repeat (rw not_over_or in Heqp); repnd.

  repeat rw @free_vars_isect.

  rw @free_vars_halts.
  rw @free_vars_base.
  rw @free_vars_isaxiom; simpl.
  repeat (rw remove_nvars_cons_r; boolvar; allrw not_over_or; repnd; spFalseHyp).
  rw remove_nvars_app_l; simpl.
  rw remove_nvars_app_r.
  repeat (rw remove_nvars_cons_l_weak; sp).
Qed.

Lemma free_vars_decide {o} :
  forall (a : @NTerm o) v1 b1 v2 b2,
    free_vars (mk_decide a v1 b1 v2 b2)
    = free_vars a
                ++ remove_nvars [v1] (free_vars b1)
                ++ remove_nvars [v2] (free_vars b2).
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_spread {o} :
  forall (a : @NTerm o) v1 v2 b,
    free_vars (mk_spread a v1 v2 b)
    = free_vars a ++ remove_nvars [v1,v2] (free_vars b).
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_unit {o} :
  @free_vars o mk_unit = [].
Proof.
  unfold mk_unit, mk_true.
  rw @free_vars_approx; rw @free_vars_axiom; auto.
Qed.

Lemma free_vars_bool {o} :
  @free_vars o mk_bool = [].
Proof.
  unfold mk_bool.
  rw @free_vars_union.
  rw @free_vars_unit; auto.
Qed.


Require Import Ensembles.
Require Import syntax.
Require Import infrastructure.
Require Import infrastructure_props.
Require Import analysis.
Require Import typings.
Require Import static.
Require Import List.
Require Import Arith.
Require Import tactics.
Require Import monad.
Require Import events.
Require Import Metatheory.
Require Import genericvalues.
Require Import alist.
Require Import Memory.
Require Import Integers.
Require Import Coqlib.
Require Import targetdata.
Require Import AST.
Require Import Maps.
Require Import opsem.
Require Import vellvm_tactics.
Require Import util.

(***********************************************************)
(* This file proves the properties of operational semantics. *)

Module OpsemProps. Section OpsemProps.

Context `{GVsSig : GenericValues}.

Export Opsem.

Notation GVs := GVsSig.(GVsT).
Notation "gv @ gvs" :=
  (GVsSig.(instantiate_gvs) gv gvs) (at level 43, right associativity).
Notation "$ gv # t $" := (GVsSig.(gv2gvs) gv t) (at level 41).

(***********************************************************)
(* Properties of updating locals after calls. *)
Lemma func_callUpdateLocals_is_returnUpdateLocals :
  forall TD rid noret0 tailc0 rt va fid lp Result lc lc' gl,
  @returnUpdateLocals GVsSig TD
    (insn_call rid noret0 tailc0 rt va fid lp) Result lc lc' gl =
  callUpdateLocals TD rt noret0 rid (Some Result) lc' lc gl.
Proof.
  intros.
  unfold returnUpdateLocals.
  unfold callUpdateLocals.
  destruct noret0; auto.
Qed.

Lemma proc_callUpdateLocals_is_id : forall TD rt rid noret0 lc lc' gl lc'',
  @callUpdateLocals GVsSig TD rt noret0 rid None lc' lc gl = Some lc'' ->
  lc' = lc'' /\ noret0 = true.
Proof.
  intros.
  unfold callUpdateLocals in H.
  destruct noret0; inversion H; auto.
Qed.

(***********************************************************)
(* Properties of sop_star *)
Lemma sInsn__implies__sop_star : forall cfg state state' tr,
  @sInsn GVsSig cfg state state' tr ->
  sop_star cfg state state' tr.
Proof.
  intros cfg state state' tr HdsInsn.
  rewrite <- E0_right.
  eauto.
Qed.

Lemma sop_star_trans : forall cfg state1 state2 state3 tr12 tr23,
  @sop_star GVsSig cfg state1 state2 tr12 ->
  sop_star cfg state2 state3 tr23 ->
  sop_star cfg state1 state3 (Eapp tr12 tr23).
Proof.
  intros cfg state1 state2 state3 tr12 tr23 Hdsop12 Hdsop23.
  generalize dependent state3.
  generalize dependent tr23.
  induction Hdsop12; intros; auto.
    rewrite Eapp_assoc. eauto.
Qed.

(***********************************************************)
(* Properties of sop_plus *)
Lemma sInsn__implies__sop_plus : forall cfg state state' tr,
  @sInsn GVsSig cfg state state' tr ->
  sop_plus cfg state state' tr.
Proof.
  intros cfg state state' tr HdsInsn.
  rewrite <- E0_right.
  eauto.
Qed.

Lemma sop_plus__implies__sop_star : forall cfg state state' tr,
  @sop_plus GVsSig cfg state state' tr ->
  sop_star cfg state state' tr.
Proof.
  intros cfg state state' tr Hdsop_plus.
  inversion Hdsop_plus; subst; eauto.
Qed.

Hint Resolve sInsn__implies__sop_star sInsn__implies__sop_plus
  sop_plus__implies__sop_star.

Lemma sop_plus_star__implies__sop_plus: forall cfg S1 S2 S3 tr1 tr2,
  sop_plus cfg S1 S2 tr1 ->
  @sop_star GVsSig cfg S2 S3 tr2 ->
  sop_plus cfg S1 S3 (tr1 ** tr2).
Proof.
  induction 1; intros; auto.
    rewrite Eapp_assoc; auto.
    econstructor; eauto.
    eapply sop_star_trans; eauto.
Qed.

Lemma sop_star_plus__implies__sop_plus: forall cfg S1 S2 S3 tr1 tr2,
  @sop_star GVsSig cfg S1 S2 tr1 ->
  sop_plus cfg S2 S3 tr2 ->
  sop_plus cfg S1 S3 (tr1 ** tr2).
Proof.
  induction 1; intros; auto.
    apply IHsop_star in H1.
    rewrite Eapp_assoc; auto.
    econstructor; eauto.
Qed.

Lemma sop_step_plus__implies__sop_plus: forall cfg S1 S2 S3 tr1 tr2,
  sInsn cfg S1 S2 tr1 ->
  @sop_plus GVsSig cfg S2 S3 tr2 ->
  sop_plus cfg S1 S3 (tr1 ** tr2).
Proof.
  intros. inv H0.
  econstructor; eauto.
Qed.

(***********************************************************)
(* Properties of sop_diverges *)
Lemma sop_diverging_trans : forall cfg state tr1 state' tr2,
  @sop_star GVsSig cfg state state' tr1 ->
  sop_diverges cfg state' tr2 ->
  sop_diverges cfg state (Eappinf tr1 tr2).
Proof.
  intros cfg state tr1 state' tr2 state_dsop_state' state'_dsop_diverges.
  generalize dependent tr2.
  (sop_star_cases (induction state_dsop_state') Case); intros; auto.
  Case "sop_star_cons".
    rewrite Eappinf_assoc. eauto.
Qed.

Lemma sop_star_diverges'__sop_diverges': forall cfg IS1 IS2 tr1 tr2,
  @sop_star GVsSig cfg IS1 IS2 tr1 ->
  sop_diverges' cfg IS2 tr2 ->
  sop_diverges' cfg IS1 (Eappinf tr1 tr2).
Proof.
  induction 1; intros; auto.
    apply IHsop_star in H1.
    rewrite Eappinf_assoc.
    econstructor; eauto.
Qed.

Lemma sop_plus_diverges'__sop_diverges': forall cfg IS1 IS2 tr1 tr2,
  @sop_plus GVsSig cfg IS1 IS2 tr1 ->
  sop_diverges' cfg IS2 tr2 ->
  sop_diverges' cfg IS1 (Eappinf tr1 tr2).
Proof.
  intros. inv H.
  eapply sop_star_diverges'__sop_diverges' in H2; eauto.
  rewrite Eappinf_assoc.
  econstructor; eauto.
Qed.

Lemma sop_star_diverges__sop_diverges: forall cfg IS1 IS2 tr1 tr2,
  @sop_star GVsSig cfg IS1 IS2 tr1 ->
  sop_diverges cfg IS2 tr2 ->
  sop_diverges cfg IS1 (Eappinf tr1 tr2).
Proof.
  induction 1; intros; auto.
    apply IHsop_star in H1.
    rewrite Eappinf_assoc.
    rewrite <- E0_right at 1.
    econstructor; eauto.
Qed.

Lemma sop_diverges__sop_diverges': forall cfg IS tr,
  @sop_diverges GVsSig cfg IS tr -> sop_diverges' cfg IS tr.
Proof.
  cofix CIH.
  intros.
  inv H.
  inv H0.
  assert (sop_diverges cfg state0 (tr3***tr2)) as J.
    clear CIH.
    eapply sop_star_diverges__sop_diverges; eauto.
  apply CIH in J. clear CIH.
  rewrite Eappinf_assoc.
  econstructor; eauto.
Qed.

Lemma sop_diverges'__sop_diverges: forall cfg IS tr,
  sop_diverges' cfg IS tr -> @sop_diverges GVsSig cfg IS tr.
Proof.
  cofix CIH.
  intros.
  inv H.
  apply CIH in H1. clear CIH.
  econstructor; eauto.
Qed.

Lemma sop_star_diverges__sop_diverges_coind: forall cfg IS1 IS2 tr1 tr2,
  Opsem.sop_star cfg IS1 IS2 tr1 ->
  @Opsem.sop_diverges GVsSig cfg IS2 tr2 ->
  Opsem.sop_diverges cfg IS1 (Eappinf tr1 tr2).
Proof.
  intros.
  inv H0.
  rewrite <- Eappinf_assoc.
  eapply sop_diverges_intro; eauto.
  eapply sop_star_plus__implies__sop_plus; eauto.
Qed.

Lemma sop_star_diverges'__sop_diverges'_coind: forall cfg IS1 IS2 tr1 tr2,
  Opsem.sop_star cfg IS1 IS2 tr1 ->
  @Opsem.sop_diverges' GVsSig cfg IS2 tr2 ->
  Opsem.sop_diverges' cfg IS1 (Eappinf tr1 tr2).
Proof.
  cofix CIH.
  intros.
  inv H0.
  inv H.
    clear CIH.
    rewrite <- Eappinf_assoc.
    econstructor; eauto.

    assert (sop_diverges' cfg state0 (tr4 *** tr0 *** tr3)) as J.
      rewrite <- Eappinf_assoc.
      eapply CIH; eauto.
      eapply sop_star_trans; eauto.
    clear CIH.
    rewrite Eappinf_assoc.
    eapply sop_diverges_intro'; eauto.
Qed.

Section SOP_WF_DIVERGES.

Context `{Measure: Type}.
Context `{R:Measure -> Measure -> Prop}.
Context `{Hwf_founded_R: well_founded R}.

Lemma sop_wf_diverges__inv: forall m1 cfg S1 Tr
  (Hdiv: sop_wf_diverges Measure R cfg m1 S1 Tr),
  exists S2, exists m2, exists tr, exists Tr',
    @sop_plus GVsSig cfg S1 S2 tr /\
    sop_wf_diverges Measure R cfg m2 S2 Tr' /\
    Tr = Eappinf tr Tr'.
Proof.
  intro m1. pattern m1.
  apply (well_founded_ind Hwf_founded_R); intros.
  inv Hdiv.
    exists state2. exists m2. exists tr1. exists tr2.
    split; auto.

    apply H in H2; auto.
    destruct H2 as [S2 [m2' [tr [Tr' [J1 [J2 J3]]]]]]; subst.
    exists S2. exists m2'. exists (Eapp tr1 tr). exists Tr'.
    split.
      eapply sop_star_plus__implies__sop_plus; eauto.
    split; auto.
      rewrite Eappinf_assoc; auto.
Qed.

Lemma sop_wf_diverges__sop_diverges: forall cfg m IS tr,
  sop_wf_diverges Measure R cfg m IS tr ->@sop_diverges GVsSig cfg IS tr.
Proof.
  cofix CIH.
  intros.
  inv H.
    apply sop_wf_diverges__inv in H1; auto.
    destruct H1 as [S2 [m2' [tr [Tr' [J1 [J2 J3]]]]]]; subst.
    econstructor; eauto.

    apply sop_wf_diverges__inv in H2; auto.
    destruct H2 as [S2 [m2' [tr [Tr' [J1 [J2 J3]]]]]]; subst.
    rewrite <- Eappinf_assoc.
    econstructor; eauto using sop_star_plus__implies__sop_plus.
Qed.

End SOP_WF_DIVERGES.

(***********************************************************)
(** big-step convergence -> small-step convergence *)

(** First, by mutual induction, we prove that bInsn, bops and
    bFdef imply small-step semantics. *)

Definition bInsn__implies__sop_plus_prop cfg state state' tr
  (db:@bInsn GVsSig cfg state state' tr) :=
  forall S TD Ps gl fs F B cs tmn lc als Mem B' cs' tmn' lc' als' Mem' ECs,
  cfg = (mkbCfg S TD Ps gl fs F) ->
  state = (mkbEC B cs tmn lc als Mem) ->
  state' = (mkbEC B' cs' tmn' lc' als' Mem') ->
  sop_plus (mkCfg S TD Ps gl fs)
           (mkState ((mkEC F B cs tmn lc als)::ECs) Mem)
           (mkState ((mkEC F B' cs' tmn' lc' als')::ECs) Mem') tr.
Definition bops__implies__sop_star_prop cfg state state' tr
  (db:@bops GVsSig cfg state state' tr) :=
  forall S TD Ps gl fs F B cs tmn lc als Mem B' cs' tmn' lc' als' Mem' ECs,
  cfg = (mkbCfg S TD Ps gl fs F) ->
  state = (mkbEC B cs tmn lc als Mem) ->
  state' = (mkbEC B' cs' tmn' lc' als' Mem') ->
  sop_star (mkCfg S TD Ps gl fs)
           (mkState ((mkEC F B cs tmn lc als)::ECs) Mem)
           (mkState ((mkEC F B' cs' tmn' lc' als')::ECs) Mem') tr.
Definition bFdef__implies__sop_star_prop fv rt lp S TD Ps lc gl fs Mem lc'
als' Mem' B'' rid oResult tr
(db:@bFdef GVsSig fv rt lp S TD Ps lc gl fs Mem lc' als' Mem' B'' rid oResult tr)
  :=
  match oResult with
  | Some Result => forall ECs fptrs,
    getOperandValue TD fv lc gl = Some fptrs ->
    exists fptr, exists fa, exists fid, exists la, exists va, exists lb,
    exists l', exists ps', exists cs', exists tmn', exists gvs, exists lc0,
    fptr @ fptrs /\
    lookupFdefViaPtr Ps fs fptr =
      Some (fdef_intro (fheader_intro fa rt fid la va) lb) /\
    getEntryBlock (fdef_intro (fheader_intro fa rt fid la va) lb) =
      Some (l', stmts_intro ps' cs' tmn') /\
    params2GVs TD lp lc gl = Some gvs /\
    initLocals TD la gvs = Some lc0 /\
    sop_star (mkCfg S TD Ps gl fs)
      (mkState ((mkEC (fdef_intro (fheader_intro fa rt fid la va) lb)
                              (l', stmts_intro ps' cs' tmn') cs' tmn'
                              lc0 nil)::ECs) Mem)
      (mkState ((mkEC (fdef_intro (fheader_intro fa rt fid la va) lb)
                               B'' nil (insn_return rid rt Result) lc'
                               als')::ECs) Mem')
      tr
  | None => forall ECs fptrs,
    getOperandValue TD fv lc gl = Some fptrs ->
    exists fptr, exists fa, exists fid, exists la, exists va, exists lb,
    exists l', exists ps', exists cs', exists tmn', exists gvs, exists lc0,
    fptr @ fptrs /\
    lookupFdefViaPtr Ps fs fptr =
      Some (fdef_intro (fheader_intro fa rt fid la va) lb) /\
    getEntryBlock (fdef_intro (fheader_intro fa rt fid la va) lb) =
      Some (l', stmts_intro ps' cs' tmn') /\
    params2GVs TD lp lc gl = Some gvs /\
    initLocals TD la gvs = Some lc0 /\
    sop_star (mkCfg S TD Ps gl fs)
      (mkState ((mkEC (fdef_intro (fheader_intro fa rt fid la va) lb)
                              (l', stmts_intro ps' cs' tmn') cs' tmn'
                              lc0 nil)::ECs) Mem)
      (mkState ((mkEC (fdef_intro (fheader_intro fa rt fid la va) lb)
                               B'' nil (insn_return_void rid) lc'
                               als')::ECs) Mem')
      tr
  end
  .

Ltac app_inv :=
  match goal with
  | [ H: ?f _ _ _ _ _ _ = ?f _ _ _ _ _ _ |- _ ] => inv H
  | [ H: ?f _ _ _ _ _ = ?f _ _ _ _ _ |- _ ] => inv H
  | [ H: ?f _ _ = ?f _ _ |- _ ] => inv H
  end.

Lemma b__implies__s:
  (forall cfg state state' t db,
     @bInsn__implies__sop_plus_prop cfg state state' t db) /\
  (forall cfg state state' t db,
     @bops__implies__sop_star_prop cfg state state' t db) /\
  (forall fv rt lp S TD Ps lc gl fs Mem lc' als' Mem' B'' rid oret tr db,
     @bFdef__implies__sop_star_prop fv rt lp S TD Ps lc gl fs Mem lc' als'
       Mem' B'' rid oret tr db).
Proof.
(b_mutind_cases
  apply b_mutind with
    (P  := bInsn__implies__sop_plus_prop)
    (P0 := bops__implies__sop_star_prop)
    (P1 := bFdef__implies__sop_star_prop)
    Case);
  unfold bInsn__implies__sop_plus_prop,
         bops__implies__sop_star_prop,
         bFdef__implies__sop_star_prop;
  intros; subst; simpl; repeat app_inv; eauto.
  Case "bCall".
    inversion b; subst.
    SCase "bFdef_func".
    assert (Hlookup:=H0).
    apply H with (ECs:=(mkEC F0 B0
                         ((insn_call rid noret0 ca rt1 va1 fv lp)::cs')
                         tmn0 lc0 als0)::ECs) in H0; auto. clear H.
    destruct H0 as [fptr' [fa0 [fid0 [la0 [va0 [lb0 [l0 [ps0 [cs0 [tmn0' [gvs0
      [lc0' [J1 [J2 [J3 [J4 [J5 J6]]]]]]]]]]]]]]]]].
    rewrite <- E0_left.
    apply sop_plus_cons with
     (state2:=mkState ((mkEC (fdef_intro (fheader_intro fa0 rt fid0 la0 va0) lb0)
                             (l0, stmts_intro ps0 cs0 tmn0') cs0 tmn0' lc0' nil)::
                        (mkEC F0 B0
                          ((insn_call rid noret0 ca rt1 va1 fv lp)::cs')
                          tmn0 lc0 als0)::ECs) Mem1); eauto.
    rewrite <- E0_right.
    apply sop_star_trans with
     (state2:=mkState ((mkEC (fdef_intro (fheader_intro fa0 rt fid0 la0 va0) lb0)
                               (l'', stmts_intro ps'' cs''
                                (insn_return Rid rt Result)) nil
                                (insn_return Rid rt Result) lc'
                                als')::
                        (mkEC F0 B0
                          ((insn_call rid noret0 ca rt1 va1 fv lp)::cs')
                          tmn0 lc0 als0)::ECs) Mem'); auto.
      apply sInsn__implies__sop_star.
        apply sReturn; auto.
          erewrite func_callUpdateLocals_is_returnUpdateLocals; eauto.

    SCase "bFdef_proc".
    assert (Hlookup:=H0).
    apply H with (ECs:=(mkEC F0 B0
                         ((insn_call rid noret0 ca rt1 va1 fv lp)::cs')
                         tmn0 lc0 als0)::ECs) in H0; auto. clear H.
    destruct H0 as [fptr' [fa0 [fid0 [la0 [va0 [lb0 [l0 [ps0 [cs0 [tmn0' [gvs0
      [lc0'' [J1 [J2 [J3 [J4 [J5 J6]]]]]]]]]]]]]]]]].
    rewrite <- E0_left.
    apply sop_plus_cons with
     (state2:=mkState ((mkEC (fdef_intro (fheader_intro fa0 rt fid0 la0 va0) lb0)
                            (l0, stmts_intro ps0 cs0 tmn0') cs0 tmn0' lc0'' nil)::
                        (mkEC F0 B0
                         ((insn_call rid noret0 ca rt1 va1 fv lp)::cs')
                         tmn0 lc0 als0)::ECs) Mem1); eauto.
    rewrite <- E0_right.
    apply proc_callUpdateLocals_is_id in e0.
    destruct e0; subst.
    apply sop_star_trans with
     (state2:=mkState ((mkEC (fdef_intro (fheader_intro fa0 rt fid0 la0 va0) lb0)
                               (l'', stmts_intro ps'' cs'' (insn_return_void Rid))
                                nil (insn_return_void Rid) lc' als')::
                        (mkEC F0 B0
                         ((insn_call rid true ca rt1 va1 fv lp)::cs')
                         tmn0 lc'0 als0)::ECs) Mem'); auto.

  Case "bops_cons".
    destruct S2 as [b3 cs3 tmn3 lc3 als3].
    apply sop_star_trans with
      (state2:=mkState ((mkEC F b3 cs3 tmn3 lc3 als3)::ECs) bMem0); auto.

  Case "bFdef_func".
    rewrite H0 in e. inv e. exists fptr. exists fa. exists fid. exists la.
    exists va. exists lb. exists l'. exists ps'. exists cs'. exists tmn'.
    exists gvs. exists lc0. repeat (split; auto).

  Case "bFdef_proc".
   rewrite H0 in e. inv e. exists fptr. exists fa. exists fid. exists la.
    exists va. exists lb. exists l'. exists ps'. exists cs'. exists tmn'.
    exists gvs. exists lc0. repeat (split; auto).
Qed.

Lemma bInsn__implies__sop_plus : forall tr S TD Ps gl fs F B cs tmn lc als Mem B'
    cs' tmn' lc' als' Mem' ECs,
  @bInsn GVsSig (mkbCfg S TD Ps gl fs F) (mkbEC B cs tmn lc als Mem)
    (mkbEC B' cs' tmn' lc' als' Mem') tr ->
  sop_plus (mkCfg S TD Ps gl fs)
           (mkState ((mkEC F B cs tmn lc als)::ECs) Mem)
           (mkState ((mkEC F B' cs' tmn' lc' als')::ECs) Mem') tr.
Proof.
  destruct b__implies__s as [J _]. intros.
  unfold bInsn__implies__sop_plus_prop in J. eapply J; eauto.
Qed.

Lemma bInsn__implies__sop_star : forall tr S TD Ps gl fs F B cs tmn lc als Mem B'
    cs' tmn' lc' als' Mem' ECs,
  @bInsn GVsSig (mkbCfg S TD Ps gl fs F) (mkbEC B cs tmn lc als Mem)
    (mkbEC B' cs' tmn' lc' als' Mem') tr ->
  sop_star (mkCfg S TD Ps gl fs)
           (mkState ((mkEC F B cs tmn lc als)::ECs) Mem)
           (mkState ((mkEC F B' cs' tmn' lc' als')::ECs) Mem') tr.
Proof.
  intros. eapply bInsn__implies__sop_plus in H; eauto.
Qed.

Lemma bops__implies__sop_star : forall tr S TD Ps gl fs F B cs tmn lc als Mem B'
    cs' tmn' lc' als' Mem' ECs,
  @bops GVsSig (mkbCfg S TD Ps gl fs F) (mkbEC B cs tmn lc als Mem)
    (mkbEC B' cs' tmn' lc' als' Mem') tr ->
  sop_star (mkCfg S TD Ps gl fs)
           (mkState ((mkEC F B cs tmn lc als)::ECs) Mem)
           (mkState ((mkEC F B' cs' tmn' lc' als')::ECs) Mem') tr.
Proof.
  destruct b__implies__s as [_ [J _]]. intros.
  unfold bops__implies__sop_star_prop in J. eapply J; eauto.
Qed.

Lemma bFdef_func__implies__sop_star : forall fv rt lp S TD Ps ECs lc gl fs
    Mem lc' als' Mem' B'' rid Result tr fptrs,
  @bFdef GVsSig fv rt lp S TD Ps lc gl fs Mem lc' als' Mem' B'' rid
    (Some Result) tr ->
  getOperandValue TD fv lc gl = Some fptrs ->
  exists fptr, exists fa, exists fid, exists la, exists va, exists lb,
  exists l', exists ps', exists cs', exists tmn', exists gvs, exists lc0,
  fptr @ fptrs /\
  lookupFdefViaPtr Ps fs fptr =
    Some (fdef_intro (fheader_intro fa rt fid la va) lb) /\
  getEntryBlock (fdef_intro (fheader_intro fa rt fid la va) lb) =
    Some (l', stmts_intro ps' cs' tmn') /\
  params2GVs TD lp lc gl = Some gvs /\
  initLocals TD la gvs = Some lc0 /\
  sop_star (mkCfg S TD Ps gl fs)
    (mkState ((mkEC (fdef_intro (fheader_intro fa rt fid la va) lb)
                             (l', stmts_intro ps' cs' tmn') cs' tmn' lc0
                             nil)::ECs) Mem)
    (mkState ((mkEC (fdef_intro (fheader_intro fa rt fid la va) lb)
                             B'' nil (insn_return rid rt Result) lc'
                             als')::ECs) Mem')
    tr.
Proof.
  intros fv rt lp S TD Ps ECs lc gl fs Mem0 lc' als' Mem' B'' rid Result tr
    fptrs H H1.
  destruct b__implies__s as [_ [_ J]].
  assert (K:=@J fv rt lp S TD Ps lc gl fs Mem0 lc' als' Mem' B'' rid
    (Some Result) tr H ECs fptrs H1); auto.
Qed.

Lemma bFdef_proc__implies__sop_star : forall fv rt lp S TD Ps ECs lc gl fs
    Mem lc' als' Mem' B'' rid tr fptrs,
  @bFdef GVsSig fv rt lp S TD Ps lc gl fs  Mem lc' als' Mem' B'' rid None tr ->
  getOperandValue TD fv lc gl = Some fptrs ->
  exists fptr, exists fa, exists fid, exists la, exists va, exists lb,
  exists l', exists ps', exists cs', exists tmn', exists gvs, exists lc0,
  fptr @ fptrs /\
  lookupFdefViaPtr Ps fs fptr =
    Some (fdef_intro (fheader_intro fa rt fid la va) lb) /\
  getEntryBlock (fdef_intro (fheader_intro fa rt fid la va) lb) =
    Some (l', stmts_intro ps' cs' tmn') /\
  params2GVs TD lp lc gl = Some gvs /\
  initLocals TD la gvs = Some lc0 /\
  sop_star (mkCfg S TD Ps gl fs)
    (mkState ((mkEC (fdef_intro (fheader_intro fa rt fid la va) lb)
                            (l', stmts_intro ps' cs' tmn') cs' tmn' lc0
                            nil)::ECs) Mem)
    (mkState ((mkEC (fdef_intro (fheader_intro fa rt fid la va) lb)
                             B'' nil (insn_return_void rid) lc'
                             als')::ECs) Mem')
    tr.
Proof.
  intros fv rt lp S TD Ps ECs lc gl fs Mem0 lc' als' Mem' B'' rid tr fptrs H H1.
  destruct b__implies__s as [_ [_ J]].
  assert (K:=@J fv rt lp S TD Ps lc gl fs Mem0 lc' als' Mem' B'' rid None tr
    H ECs fptrs H1); auto.
Qed.

(** Then we prove that the whole program holds the same property. *)

Lemma b_genInitState_inv : forall S main Args initmem S0 TD Ps gl fs F B cs tmn
  lc als M,
 @b_genInitState GVsSig S main Args initmem =
   Some (mkbCfg S0 TD Ps gl fs F, mkbEC B cs tmn lc als M) ->
 s_genInitState S main Args initmem =
   Some (mkCfg S0 TD Ps gl fs, mkState ((mkEC F B cs tmn lc als)::nil) M).
Proof.
  intros.
  unfold b_genInitState in H.
  remember (s_genInitState S main Args initmem) as R.
  destruct R as [[]|]; tinv H. destruct c; tinv H. destruct s; tinv H.
  destruct ECS0; tinv H. destruct e; tinv H. destruct ECS0; inv H; auto.
Qed.

Lemma b_converges__implies__s_converges : forall sys main VarArgs tr rg,
  @b_converges GVsSig sys main VarArgs tr rg ->
  s_converges sys main VarArgs tr rg.
Proof.
  intros sys main VarArgs tr rg Hdb_converges.
  inversion Hdb_converges; subst. destruct cfg, IS, FS.
  match goal with
  | H: b_genInitState _ _ _ _ = _ |- _ =>
    apply b_genInitState_inv in H; simpl in H
  end.
  eapply s_converges_intro; eauto.
    apply bops__implies__sop_star; eauto.
    simpl. auto.
Qed.

(***********************************************************)
(** big-step divergence -> small-step divergence *)

(** First,we prove that bInsn, bops and bFdef imply small-step semantics,
    by nested coinduction. *)

Lemma bFdefInf_bopInf__implies__sop_diverges :
   forall (fv : value) (rt : typ) (lp : params) (S : system)
     (TD : TargetData) (Ps : products) (ECs : list ExecutionContext)
     (lc : GVsMap) (gl fs : GVMap) (Mem0 : mem) (tr : traceinf)
     (fid : id) (fa : fnattrs) (lc1 : GVsMap) (l' : l)
     (ps' : phinodes) (cs' : cmds) (tmn' : terminator)
     (la : args) (va : varg) (lb : blocks) (gvs : list GVs)
     (fptrs0 : GVs) (fptr : GenericValue),
   fptr @ fptrs0 ->
   lookupFdefViaPtr Ps fs fptr =
   ret fdef_intro (fheader_intro fa rt fid la va) lb ->
   getEntryBlock (fdef_intro (fheader_intro fa rt fid la va) lb) =
   ret (l', stmts_intro ps' cs' tmn') ->
   params2GVs TD lp lc gl = ret gvs ->
   initLocals TD la gvs = ret lc1 ->
   bopInf (mkbCfg S TD Ps gl fs (fdef_intro (fheader_intro fa rt fid la va) lb))
     {|
     bCurBB := (l', stmts_intro ps' cs' tmn');
     bCurCmds := cs';
     bTerminator := tmn';
     bLocals := lc1;
     bAllocas := nil;
     bMem := Mem0 |} tr ->
   getOperandValue TD fv lc gl = ret fptrs0 ->
   sop_diverges (mkCfg S TD Ps gl fs)
     {|
     ECS := {|
            CurFunction := fdef_intro (fheader_intro fa rt fid la va) lb;
            CurBB := (l', stmts_intro ps' cs' tmn');
            CurCmds := cs';
            Terminator := tmn';
            Locals := lc1;
            Allocas := nil |} :: ECs;
     Mem := Mem0 |} tr.
Proof.
  cofix CIH_bFdefInf.

  assert (forall S tr TD Ps gl fs F B cs tmn lc als Mem ECs,
    @bInsnInf GVsSig (mkbCfg S TD Ps gl fs F) (mkbEC B cs tmn lc als Mem) tr ->
    sop_diverges (mkCfg S TD Ps gl fs)
                 (mkState ((mkEC F B cs tmn lc als)::ECs) Mem) tr)
    as bInsnInf__implies__sop_diverges.
    cofix CIH_bInsnInf.
    intros S tr TD Ps gl fs F B cs tmn lc als Mem ECs HbInsnInf.

    inversion HbInsnInf; subst.
    rewrite <- E0_left_inf.
    assert (HbFdefInf:=H12).
    inversion H12; subst.
    apply sop_diverges_intro with
      (state2:=mkState ((mkEC (fdef_intro (fheader_intro fa rt fid la va)lb)
                               ((l', stmts_intro ps' cs' tmn')) cs' tmn' lc1
                               nil)::
                        (mkEC F B
                          ((insn_call rid noret0 ca rt1 va1 fv lp)::cs0)
                          tmn lc als)::ECs) Mem);
      try solve [clear CIH_bFdefInf CIH_bInsnInf; eauto].
      inv HbFdefInf.
      eapply CIH_bFdefInf with (fid:=fid)(l':=l')(ps':=ps')(cs':=cs')(tmn':=tmn')
        (fa:=fa)(la:=la)(va:=va)(lb:=lb)(gvs:=gvs)(lc1:=lc1)(fptr:=fptr)(fv:=fv)
        (lp:=lp)(lc:=lc)(fptrs0:=fptrs) in H5; eauto.

  assert (forall S tr TD Ps gl fs F B cs tmn lc als Mem ECs,
    @bopInf GVsSig (mkbCfg S TD Ps gl fs F) (mkbEC B cs tmn lc als Mem) tr ->
    sop_diverges (mkCfg S TD Ps gl fs)
                 (mkState ((mkEC F B cs tmn lc als)::ECs) Mem) tr)
    as bopInf__implies__sop_diverges.
    cofix CIH_bopInf.
    intros S tr TD Ps gl fs F B cs tmn lc als Mem ECs HbopInf.
    inversion HbopInf; subst.
    Case "bopInf_insn".
      eapply bInsnInf__implies__sop_diverges in H; eauto.
    Case "bopInf_cons".
      destruct state2.
      apply bInsn__implies__sop_plus with (ECs:=ECs) in H.
      inversion H; subst.
      SCase "dsop_plus_cons".
        apply CIH_bopInf with (ECs:=ECs) in H0. clear CIH_bopInf.
        eapply sop_diverges_intro; eauto.

  intros fv rt lp S TD Ps ECs lc gl fs Mem0 tr fid fa lc1 l' ps' cs' tmn' la va
    lb gvs fptrs0 fptr Hin Hlookup HgetEntryBlock Hp2gvs Hinit HbFdefInf Hget.
  inversion HbFdefInf; subst; eauto.
Qed.

Lemma bFdefInf__implies__sop_diverges : forall fv rt lp S TD Ps ECs lc gl fs Mem
    tr fptrs,
  bFdefInf fv rt lp S TD Ps lc gl fs Mem tr ->
  getOperandValue TD fv lc gl = Some fptrs ->
  exists fptr, exists fa, exists fid, exists la, exists va, exists lb,
  exists l', exists ps', exists cs', exists tmn', exists gvs, exists lc0,
  fptr @ fptrs /\
  lookupFdefViaPtr Ps fs fptr =
    Some (fdef_intro (fheader_intro fa rt fid la va) lb) /\
  getEntryBlock (fdef_intro (fheader_intro fa rt fid la va) lb) =
    Some (l', stmts_intro ps' cs' tmn') /\
  params2GVs TD lp lc gl = Some gvs /\
  initLocals TD la gvs = Some lc0 /\
  sop_diverges (mkCfg S TD Ps gl fs)
    (mkState ((mkEC (fdef_intro (fheader_intro fa rt fid la va) lb)
              (l', stmts_intro ps' cs' tmn') cs' tmn' lc0 nil)::ECs) Mem)
    tr.
Proof.
  intros fv rt lp S TD Ps ECs lc gl fs Mem0 tr fptrs HdbFdefInf Hget.
  inv HdbFdefInf; subst.
  exists fptr. exists fa. exists fid. exists la. exists va. exists lb. exists l'.
  exists ps'. exists cs'. exists tmn'. exists gvs. exists lc1.
  rewrite Hget in H. inv H.
  repeat (split; auto).
    eapply bFdefInf_bopInf__implies__sop_diverges; eauto.
Qed.

Lemma bInsnInf__implies__sop_diverges : forall S tr TD Ps gl fs F B cs tmn lc als
  Mem ECs,
  @bInsnInf GVsSig (mkbCfg S TD Ps gl fs F) (mkbEC B cs tmn lc als Mem) tr ->
  sop_diverges (mkCfg S TD Ps gl fs)
    (mkState ((mkEC F B cs tmn lc als)::ECs) Mem) tr.
Proof.
  cofix CIH_bInsnInf.
  intros S tr TD Ps gl fs F B cs tmn lc als Mem ECs HbInsnInf.

  inversion HbInsnInf; subst.
  rewrite <- E0_left_inf.
  assert (HbFdefInf:=H12).
  inversion H12; subst.
  apply sop_diverges_intro with
    (state2:=mkState ((mkEC (fdef_intro (fheader_intro fa rt fid la va)lb)
                             (l', stmts_intro ps' cs' tmn') cs' tmn' lc1
                             nil)::
                      (mkEC F B
                        ((insn_call rid noret0 ca rt1 va1 fv lp)::cs0)
                        tmn lc als)::ECs) Mem);
    try solve [clear CIH_bInsnInf; eauto].
    eapply bFdefInf_bopInf__implies__sop_diverges with (l':=l')(ps':=ps')
      (cs':=cs')(tmn':=tmn')(la:=la)(va:=va)(lb:=lb)(fa:=fa)(gvs:=gvs)(lc1:=lc1)
      in H5; eauto.
Qed.

Lemma bopInf__implies__sop_diverges : forall S tr TD Ps gl fs F B cs tmn lc als
  Mem ECs,
  @bopInf GVsSig (mkbCfg S TD Ps gl fs F) (mkbEC B cs tmn lc als Mem) tr ->
  sop_diverges (mkCfg S TD Ps gl fs)
    (mkState ((mkEC F B cs tmn lc als)::ECs) Mem) tr.
Proof.
  cofix CIH_bopInf.
  intros S tr TD Ps gl fs F B cs tmn lc als Mem ECs HbopInf.
  inversion HbopInf; subst.
  Case "bopInf_insn".
    eapply bInsnInf__implies__sop_diverges in H; eauto.
  Case "bopInf_cons".
    destruct state2.
    apply bInsn__implies__sop_plus with (ECs:=ECs) in H.
    inversion H; subst.
    SCase "dsop_plus_cons".
      apply CIH_bopInf with (ECs:=ECs) in H0. clear CIH_bopInf.
      eapply sop_diverges_intro; eauto.
Qed.

(** Then we prove that the whole program holds the same property. *)

Lemma b_diverges__implies__s_diverges : forall sys main VarArgs tr,
  @b_diverges GVsSig sys main VarArgs tr ->
  s_diverges sys main VarArgs tr.
Proof.
  intros sys main VarArgs tr Hdb_diverges.
  inversion Hdb_diverges; subst.
  destruct cfg. destruct IS.
  apply b_genInitState_inv in H.
  eapply s_diverges_intro; eauto.
  apply bopInf__implies__sop_diverges; eauto.
Qed.

(***********************************************************)
(* Inversion of operations *)
Lemma BOP_inversion : forall TD lc gl b s v1 v2 gv2,
  BOP TD lc gl b s v1 v2 = Some gv2 ->
  exists gvs1, exists gvs2,
    getOperandValue TD v1 lc gl = Some gvs1 /\
    getOperandValue TD v2 lc gl = Some gvs2 /\
    GVsSig.(lift_op2) (mbop TD b s) gvs1 gvs2 (typ_int s) = Some gv2.
Proof.
  intros TD lc gl b s v1 v2 gv2 HBOP.
  unfold BOP in HBOP.
  remember (getOperandValue TD v1 lc gl) as ogv1.
  destruct ogv1; try solve [inversion HBOP].
  remember (getOperandValue TD v2 lc gl) as ogv2.
  destruct ogv2; inv HBOP.
  eauto.
Qed.

Lemma FBOP_inversion : forall TD lc gl b fp v1 v2 gv,
  FBOP TD lc gl b fp v1 v2 = Some gv ->
  exists gv1, exists gv2,
    getOperandValue TD v1 lc gl = Some gv1 /\
    getOperandValue TD v2 lc gl = Some gv2 /\
    GVsSig.(lift_op2) (mfbop TD b fp) gv1 gv2 (typ_floatpoint fp) = Some gv.
Proof.
  intros TD lc gl b fp v1 v2 gv HFBOP.
  unfold FBOP in HFBOP.
  remember (getOperandValue TD v1 lc gl) as ogv1.
  destruct ogv1; try solve [inversion HFBOP].
  remember (getOperandValue TD v2 lc gl) as ogv2.
  destruct ogv2; inv HFBOP.
  eauto.
Qed.

Lemma CAST_inversion : forall TD lc gl op t1 v1 t2 gv,
  CAST TD lc gl op t1 v1 t2 = Some gv ->
  exists gv1,
    getOperandValue TD v1 lc gl = Some gv1 /\
    GVsSig.(lift_op1) (mcast TD op t1 t2) gv1 t2 = Some gv.
Proof.
  intros TD lc gl op t1 v1 t2 gv HCAST.
  unfold CAST in HCAST.
  remember (getOperandValue TD v1 lc gl) as ogv1.
  destruct ogv1; inv HCAST.
  eauto.
Qed.

Lemma TRUNC_inversion : forall TD lc gl op t1 v1 t2 gv,
  TRUNC TD lc gl op t1 v1 t2 = Some gv ->
  exists gv1,
    getOperandValue TD v1 lc gl = Some gv1 /\
    GVsSig.(lift_op1) (mtrunc TD op t1 t2) gv1 t2 = Some gv.
Proof.
  intros TD lc gl op t1 v1 t2 gv HTRUNC.
  unfold TRUNC in HTRUNC.
  remember (getOperandValue TD v1 lc gl) as ogv1.
  destruct ogv1; inv HTRUNC.
  eauto.
Qed.

Lemma EXT_inversion : forall TD lc gl op t1 v1 t2 gv,
  EXT TD lc gl op t1 v1 t2 = Some gv ->
  exists gv1,
    getOperandValue TD v1 lc gl = Some gv1 /\
    GVsSig.(lift_op1) (mext TD op t1 t2) gv1 t2 = Some gv.
Proof.
  intros TD lc gl op t1 v1 t2 gv HEXT.
  unfold EXT in HEXT.
  remember (getOperandValue TD v1 lc gl) as ogv1.
  destruct ogv1; inv HEXT.
  eauto.
Qed.

Lemma ICMP_inversion : forall TD lc gl cond t v1 v2 gv,
  ICMP TD lc gl cond t v1 v2 = Some gv ->
  exists gv1, exists gv2,
    getOperandValue TD v1 lc gl = Some gv1 /\
    getOperandValue TD v2 lc gl = Some gv2 /\
    GVsSig.(lift_op2) (micmp TD cond t) gv1 gv2 (typ_int 1%nat) = Some gv.
Proof.
  intros TD lc gl cond0 t v1 v2 gv HICMP.
  unfold ICMP in HICMP.
  remember (getOperandValue TD v1 lc gl) as ogv1.
  destruct ogv1; try solve [inversion HICMP].
  remember (getOperandValue TD v2 lc gl) as ogv2.
  destruct ogv2; inv HICMP.
  eauto.
Qed.

Lemma FCMP_inversion : forall TD lc gl cond fp v1 v2 gv,
  FCMP TD lc gl cond fp v1 v2 = Some gv ->
  exists gv1, exists gv2,
    getOperandValue TD v1 lc gl = Some gv1 /\
    getOperandValue TD v2 lc gl = Some gv2 /\
    GVsSig.(lift_op2) (mfcmp TD cond fp) gv1 gv2 (typ_int 1%nat) = Some gv.
Proof.
  intros TD lc gl cond0 fp v1 v2 gv HFCMP.
  unfold FCMP in HFCMP.
  remember (getOperandValue TD v1 lc gl) as ogv1.
  destruct ogv1; try solve [inversion HFCMP].
  remember (getOperandValue TD v2 lc gl) as ogv2.
  destruct ogv2; inv HFCMP.
  eauto.
Qed.

(***********************************************************)
(* Equivalence of operations *)
Lemma const2GV_eqAL : forall c gl1 gl2 TD,
  eqAL _ gl1 gl2 ->
  @const2GV GVsSig TD gl1 c = const2GV TD gl2 c.
Proof.
  intros. unfold const2GV.
  destruct const2GV_eqAL_aux.
  erewrite H0; eauto.
Qed.

Lemma getOperandValue_eqAL : forall lc1 gl lc2 v TD,
  eqAL _ lc1 lc2 ->
  @getOperandValue GVsSig TD v lc1 gl = getOperandValue TD v lc2 gl.
Proof.
  intros lc1 gl lc2 v TD HeqAL.
  unfold getOperandValue in *.
  destruct v; auto.
Qed.

Lemma BOP_eqAL : forall lc1 gl lc2 bop0 sz0 v1 v2 TD,
  eqAL _ lc1 lc2 ->
  @BOP GVsSig TD lc1 gl bop0 sz0 v1 v2 = BOP TD lc2 gl bop0 sz0 v1 v2.
Proof.
  intros lc1 gl lc2 bop0 sz0 v1 v2 TD HeqEnv.
  unfold BOP in *.
  rewrite getOperandValue_eqAL with (lc2:=lc2)(v:=v1); auto.
  rewrite getOperandValue_eqAL with (lc2:=lc2)(v:=v2); auto.
Qed.

Lemma FBOP_eqAL : forall lc1 gl lc2 fbop0 fp0 v1 v2 TD,
  eqAL _ lc1 lc2 ->
  @FBOP GVsSig TD lc1 gl fbop0 fp0 v1 v2 = FBOP TD lc2 gl fbop0 fp0 v1 v2.
Proof.
  intros lc1 gl lc2 fbop0 fp0 v1 v2 TD HeqEnv.
  unfold FBOP in *.
  rewrite getOperandValue_eqAL with (lc2:=lc2)(v:=v1); auto.
  rewrite getOperandValue_eqAL with (lc2:=lc2)(v:=v2); auto.
Qed.

Lemma CAST_eqAL : forall lc1 gl lc2 op t1 v1 t2 TD,
  eqAL _ lc1 lc2 ->
  @CAST GVsSig TD lc1 gl op t1 v1 t2 = CAST TD lc2 gl op t1 v1 t2.
Proof.
  intros lc1 gl lc2 op t1 v1 t2 TD HeqAL.
  unfold CAST in *.
  rewrite getOperandValue_eqAL with (lc2:=lc2)(v:=v1); auto.
Qed.

Lemma TRUNC_eqAL : forall lc1 gl lc2 op t1 v1 t2 TD,
  eqAL _ lc1 lc2 ->
  @TRUNC GVsSig TD lc1 gl op t1 v1 t2 = TRUNC TD lc2 gl op t1 v1 t2.
Proof.
  intros lc1 gl lc2 op t1 v1 t2 TD HeqAL.
  unfold TRUNC in *.
  rewrite getOperandValue_eqAL with (lc2:=lc2)(v:=v1); auto.
Qed.

Lemma EXT_eqAL : forall lc1 gl lc2 op t1 v1 t2 TD,
  eqAL _ lc1 lc2 ->
  @EXT GVsSig TD lc1 gl op t1 v1 t2 = EXT TD lc2 gl op t1 v1 t2.
Proof.
  intros lc1 gl lc2 op t1 v1 t2 TD HeqAL.
  unfold EXT in *.
  rewrite getOperandValue_eqAL with (lc2:=lc2)(v:=v1); auto.
Qed.

Lemma ICMP_eqAL : forall lc1 gl lc2 cond t v1 v2 TD,
  eqAL _ lc1 lc2 ->
  @ICMP GVsSig TD lc1 gl cond t v1 v2 = ICMP TD lc2 gl cond t v1 v2.
Proof.
  intros lc1 gl lc2 cond0 t v1 v2 TD HeqAL.
  unfold ICMP in *.
  rewrite getOperandValue_eqAL with (lc2:=lc2)(v:=v1); auto.
  rewrite getOperandValue_eqAL with (lc2:=lc2)(v:=v2); auto.
Qed.

Lemma FCMP_eqAL : forall lc1 gl lc2 cond fp v1 v2 TD,
  eqAL _ lc1 lc2 ->
  @FCMP GVsSig TD lc1 gl cond fp v1 v2 = FCMP TD lc2 gl cond fp v1 v2.
Proof.
  intros lc1 gl lc2 cond0 fp v1 v2 TD HeqAL.
  unfold FCMP in *.
  rewrite getOperandValue_eqAL with (lc2:=lc2)(v:=v1); auto.
  rewrite getOperandValue_eqAL with (lc2:=lc2)(v:=v2); auto.
Qed.

Lemma values2GVs_eqAL : forall l0 lc1 gl lc2 TD,
  eqAL _ lc1 lc2 ->
  @values2GVs GVsSig TD l0 lc1 gl = values2GVs TD l0 lc2 gl.
Proof.
  induction l0 as [|[s v] l0]; intros lc1 gl lc2 TD HeqAL; simpl; auto.
    rewrite getOperandValue_eqAL with (lc2:=lc2)(v:=v); auto.
    erewrite IHl0; eauto.
Qed.

Lemma eqAL_callUpdateLocals : forall TD noret0 rid oResult lc1 lc2 gl lc1'
  lc2' rt,
  eqAL _ lc1 lc1' ->
  eqAL _ lc2 lc2' ->
  match (@callUpdateLocals GVsSig TD rt noret0 rid oResult lc1 lc2 gl,
         callUpdateLocals TD rt noret0 rid oResult lc1' lc2' gl) with
  | (Some lc, Some lc') => eqAL _ lc lc'
  | (None, None) => True
  | _ => False
  end.
Proof.
  intros TD noret0 rid oResult lc1 lc2 gl lc1' lc2' rt H1 H2.
    unfold callUpdateLocals.
    destruct noret0; auto.
      destruct oResult; simpl; auto.
        destruct v as [i0|c]; simpl.
          rewrite H2.
          destruct (lookupAL _ lc2' i0); auto using eqAL_updateAddAL.

          destruct (@const2GV GVsSig TD gl c); auto using eqAL_updateAddAL.
      destruct oResult; simpl; auto.
        destruct v as [i0|c]; simpl.
          rewrite H2.
          destruct (lookupAL _ lc2' i0); auto.
          destruct (GVsSig.(lift_op1) (fit_gv TD rt) g rt);
            auto using eqAL_updateAddAL.

          destruct (@const2GV GVsSig TD gl c); auto using eqAL_updateAddAL.
          destruct (GVsSig.(lift_op1) (fit_gv TD rt) g rt);
            auto using eqAL_updateAddAL.
Qed.

Lemma eqAL_getIncomingValuesForBlockFromPHINodes : forall TD ps B gl lc lc',
  eqAL _ lc lc' ->
  @getIncomingValuesForBlockFromPHINodes GVsSig TD ps B gl lc =
  getIncomingValuesForBlockFromPHINodes TD ps B gl lc'.
Proof.
  induction ps; intros; simpl; auto.
    destruct a; auto.
    destruct (getValueViaBlockFromValuels l0 B); auto.
    destruct v; simpl; erewrite IHps; eauto.
      rewrite H. auto.
Qed.

Lemma eqAL_updateValuesForNewBlock : forall vs lc lc',
  eqAL _ lc lc' ->
  eqAL _ (@updateValuesForNewBlock GVsSig vs lc)(updateValuesForNewBlock vs lc').
Proof.
  induction vs; intros; simpl; auto.
    destruct a; auto using eqAL_updateAddAL.
Qed.

Lemma eqAL_switchToNewBasicBlock : forall TD B1 B2 gl lc lc',
  eqAL _ lc lc' ->
  match (@switchToNewBasicBlock GVsSig TD B1 B2 gl lc,
         switchToNewBasicBlock TD B1 B2 gl lc') with
  | (Some lc1, Some lc1') => eqAL _ lc1 lc1'
  | (None, None) => True
  | _ => False
  end.
Proof.
  intros.
  unfold switchToNewBasicBlock.
  erewrite eqAL_getIncomingValuesForBlockFromPHINodes; eauto.
  destruct
    (getIncomingValuesForBlockFromPHINodes TD (getPHINodesFromBlock B1) B2 gl
    lc'); auto using eqAL_updateValuesForNewBlock.
Qed.

Lemma eqAL_switchToNewBasicBlock' : forall TD B1 B2 gl lc lc' lc1,
  eqAL _ lc lc' ->
  @switchToNewBasicBlock GVsSig TD B1 B2 gl lc = Some lc1 ->
  exists lc1', switchToNewBasicBlock TD B1 B2 gl lc' = Some lc1' /\
               eqAL _ lc1 lc1'.
Proof.
  intros.
  assert (J:=@eqAL_switchToNewBasicBlock TD B1 B2 gl lc lc' H).
  rewrite H0 in J.
  destruct (switchToNewBasicBlock TD B1 B2 gl lc'); try solve [inversion J].
  exists g. auto.
Qed.

Lemma eqAL_params2GVs : forall lp TD lc gl lc',
  eqAL _ lc lc' ->
  @params2GVs GVsSig TD lp lc gl = params2GVs TD lp lc' gl.
Proof.
  induction lp; intros; simpl; auto.
    destruct a.
    destruct v; simpl.
      rewrite H. erewrite IHlp; eauto.
      erewrite IHlp; eauto.
Qed.

Lemma eqAL_exCallUpdateLocals : forall TD noret0 rid oResult lc lc' rt,
  eqAL _ lc lc' ->
  match (@exCallUpdateLocals GVsSig TD rt noret0 rid oResult lc,
         exCallUpdateLocals TD rt noret0 rid oResult lc') with
  | (Some lc1, Some lc1') => eqAL _ lc1 lc1'
  | (None, None) => True
  | _ => False
  end.
Proof.
  intros TD noret0 rid oResult lc lc' rt H1.
    unfold exCallUpdateLocals.
    destruct noret0; auto.
    destruct oResult; auto.
    destruct (fit_gv TD rt g); auto using eqAL_updateAddAL.
Qed.

Lemma eqAL_callUpdateLocals' : forall TD ft noret0 rid oResult lc1 lc2 gl lc1'
    lc2' lc,
  eqAL _ lc1 lc1' ->
  eqAL _ lc2 lc2' ->
  @callUpdateLocals GVsSig TD ft noret0 rid oResult lc1 lc2 gl = Some lc ->
  exists lc',
    callUpdateLocals TD ft noret0 rid oResult lc1' lc2' gl = Some lc' /\
    eqAL _ lc lc'.
Proof.
  intros TD ft noret0 rid oResult lc1 lc2 gl lc1' lc2' lc H H0 H1.
  assert (J:=@eqAL_callUpdateLocals TD noret0 rid oResult lc1 lc2 gl lc1' lc2'
    ft H H0).
  rewrite H1 in J.
  destruct (callUpdateLocals TD ft noret0 rid oResult lc1' lc2' gl);
    try solve [inversion J].
  exists g. auto.
Qed.

Lemma eqAL_exCallUpdateLocals' : forall TD ft noret0 rid oResult lc lc' lc0,
  eqAL _ lc lc' ->
  @exCallUpdateLocals GVsSig TD ft noret0 rid oResult lc = Some lc0 ->
  exists lc0', exCallUpdateLocals TD ft noret0 rid oResult lc' = Some lc0' /\
               eqAL _ lc0 lc0'.
Proof.
  intros TD ft noret0 rid oResult lc lc' lc0 H H0.
  assert (J:=@eqAL_exCallUpdateLocals TD noret0 rid oResult lc lc' ft H).
  rewrite H0 in J.
  destruct (exCallUpdateLocals TD ft noret0 rid oResult lc');
    try solve [inversion J].
  exists g. auto.
Qed.

Lemma getIncomingValuesForBlockFromPHINodes_eq :
  forall ps TD l1 ps1 cs1 tmn1 ps2 cs2 tmn2,
  @getIncomingValuesForBlockFromPHINodes GVsSig TD ps
    (l1, stmts_intro ps1 cs1 tmn1) =
  getIncomingValuesForBlockFromPHINodes TD ps (l1, stmts_intro ps2 cs2 tmn2).
Proof.
  induction ps; intros; auto.
    simpl.
    erewrite IHps; eauto.
Qed.

Lemma switchToNewBasicBlock_eq :
  forall TD B l1 ps1 cs1 tmn1 ps2 cs2 tmn2 gl lc,
  @switchToNewBasicBlock GVsSig TD B (l1, stmts_intro ps1 cs1 tmn1) gl lc =
  switchToNewBasicBlock TD B (l1, stmts_intro ps2 cs2 tmn2) gl lc.
Proof.
  intros.
  unfold switchToNewBasicBlock.
  erewrite getIncomingValuesForBlockFromPHINodes_eq; eauto.
Qed.

(***********************************************************)
(* Uniqueness of operations *)
Lemma exCallUpdateLocals_uniq : forall TD rt noret0 rid oresult lc lc',
  uniq lc ->
  @exCallUpdateLocals GVsSig TD rt noret0 rid oresult lc = Some lc' ->
  uniq lc'.
Proof.
  intros.
  unfold exCallUpdateLocals in H0.
  destruct noret0; auto.
    inversion H0; subst; auto.

    destruct oresult; try solve [inversion H0].
    destruct (fit_gv TD rt g); inversion H0; subst.
      apply updateAddAL_uniq; auto.
Qed.

Lemma callUpdateLocals_uniq : forall TD rt noret0 rid oresult lc lc' gl lc'',
  uniq lc ->
  @callUpdateLocals GVsSig TD rt noret0 rid oresult lc lc' gl = Some lc'' ->
  uniq lc''.
Proof.
  intros.
  unfold callUpdateLocals in H0.
  destruct noret0; auto.
    destruct oresult; try solve [inversion H0; subst; auto].
    destruct (getOperandValue TD v lc' gl); inversion H0; subst; auto.

    destruct oresult; try solve [inversion H0; subst; auto].
    destruct (getOperandValue TD v lc' gl); tinv H0.
    destruct (lift_op1 _ (fit_gv TD rt) g rt); inv H0.
      apply updateAddAL_uniq; auto.
Qed.

Lemma updateValuesForNewBlock_uniq : forall l0 lc,
  uniq lc ->
  uniq (@updateValuesForNewBlock GVsSig l0 lc).
Proof.
  induction l0; intros lc Uniqc; simpl; auto.
    destruct a; apply updateAddAL_uniq; auto.
Qed.

Lemma switchToNewBasicBlock_uniq : forall TD B1 B2 gl lc lc',
  uniq lc ->
  @switchToNewBasicBlock GVsSig TD B1 B2 gl lc = Some lc' ->
  uniq lc'.
Proof.
  intros TD B1 B2 gl lc lc' Uniqc H.
  unfold switchToNewBasicBlock in H.
  destruct (getIncomingValuesForBlockFromPHINodes TD (getPHINodesFromBlock B1)
    B2 gl lc); inversion H; subst.
  apply updateValuesForNewBlock_uniq; auto.
Qed.

Lemma initializeFrameValues_init : forall TD la l0 lc,
  @_initializeFrameValues GVsSig TD la l0 nil = Some lc ->
  uniq lc.
Proof.
  induction la; intros; simpl in *; auto.
    inv H. auto.

    destruct a as [[t ?] id0].
    destruct l0.
      remember (@_initializeFrameValues GVsSig TD la nil nil) as R.
      destruct R; tinv H.
      destruct (gundef TD t); inv H; eauto using updateAddAL_uniq.

      remember (@_initializeFrameValues GVsSig TD la l0 nil) as R.
      destruct R; tinv H.
      destruct (GVsSig.(lift_op1) (fit_gv TD t) g t); inv H;
        eauto using updateAddAL_uniq.
Qed.

Lemma initLocals_uniq : forall TD la ps lc,
  @initLocals GVsSig TD la ps = Some lc -> uniq lc.
Proof.
  intros la ps.
  unfold initLocals.
  apply initializeFrameValues_init; auto.
Qed.

Lemma updateValuesForNewBlock_spec4 : forall rs lc id1 gv,
  lookupAL _ rs id1 = Some gv ->
  lookupAL _ (@updateValuesForNewBlock GVsSig rs lc) id1 = Some gv.
Proof.
  induction rs; intros; simpl in *.
    inversion H.

    destruct a.
    destruct (id1==a); subst.
      inversion H; subst. apply lookupAL_updateAddAL_eq; auto.
      rewrite <- lookupAL_updateAddAL_neq; auto.
Qed.

(***********************************************************)
(* Properties of initLocals and initializeFrameValues *)
Lemma initLocals_spec : forall TD la gvs id1 lc,
  In id1 (getArgsIDs la) ->
  @initLocals GVsSig TD la gvs = Some lc ->
  exists gv, lookupAL _ lc id1 = Some gv.
Proof.
  unfold initLocals.
  induction la; intros; simpl in *.
    inversion H.

    destruct a as [[t c] id0].
    simpl in H.
    destruct H as [H | H]; subst; simpl.
      destruct gvs.
        remember (@_initializeFrameValues GVsSig TD la nil nil) as R1.
        destruct R1; tinv H0.
        remember (gundef TD t) as R2.
        destruct R2; inv H0.
        eauto using lookupAL_updateAddAL_eq.

        remember (@_initializeFrameValues GVsSig TD la gvs nil) as R1.
        destruct R1; tinv H0.
        destruct (GVsSig.(lift_op1) (fit_gv TD t) g t); inv H0.
        eauto using lookupAL_updateAddAL_eq.

      destruct (eq_atom_dec id0 id1); subst.
        destruct gvs.
          remember (@_initializeFrameValues GVsSig TD la nil nil) as R1.
          destruct R1; tinv H0.
          remember (gundef TD t) as R2.
          destruct R2; inv H0.
          eauto using lookupAL_updateAddAL_eq.

          remember (@_initializeFrameValues GVsSig TD la gvs nil) as R1.
          destruct R1; tinv H0.
          destruct (GVsSig.(lift_op1) (fit_gv TD t) g t); inv H0.
          eauto using lookupAL_updateAddAL_eq.

        destruct gvs.
          remember (@_initializeFrameValues GVsSig TD la nil nil) as R1.
          destruct R1; tinv H0.
          remember (gundef TD t) as R2.
          destruct R2; inv H0.
          symmetry in HeqR1.
          eapply IHla in HeqR1; eauto.
          destruct HeqR1 as [gv HeqR1].
          rewrite <- lookupAL_updateAddAL_neq; eauto.

          remember (@_initializeFrameValues GVsSig TD la gvs nil) as R1.
          destruct R1; tinv H0.
          destruct (GVsSig.(lift_op1) (fit_gv TD t) g t); inv H0.
          symmetry in HeqR1.
          eapply IHla in HeqR1; eauto.
          destruct HeqR1 as [gv HeqR1].
          rewrite <- lookupAL_updateAddAL_neq; eauto.
Qed.

Lemma In_initializeFrameValues__In_getArgsIDs: forall
  (TD : TargetData) (la : args) (gvs : list (GVsT GVsSig)) (id1 : atom)
  (lc : Opsem.GVsMap) (gv : GVsT GVsSig) acc,
  Opsem._initializeFrameValues TD la gvs acc = ret lc ->
  lookupAL (GVsT GVsSig) lc id1 = ret gv ->
  In id1 (getArgsIDs la) \/ id1 `in` dom acc.
Proof.
  induction la as [|[]]; simpl; intros.
    inv H.
    right. apply lookupAL_Some_indom in H0; auto.

    destruct p.
    destruct gvs.
      inv_mbind.
      destruct (id_dec i0 id1); subst; auto.
      rewrite <- lookupAL_updateAddAL_neq in H0; auto.
      eapply IHla in H0; eauto.
      destruct H0 as [H0 | H0]; auto.

      inv_mbind.
      destruct (id_dec i0 id1); subst; auto.
      rewrite <- lookupAL_updateAddAL_neq in H0; auto.
      eapply IHla in H0; eauto.
      destruct H0 as [H0 | H0]; auto.
Qed.

Lemma In_initLocals__In_getArgsIDs : forall TD la gvs id1 lc gv,
  @Opsem.initLocals GVsSig TD la gvs = Some lc ->
  lookupAL _ lc id1 = Some gv ->
  In id1 (getArgsIDs la).
Proof.
  unfold Opsem.initLocals.
  intros.
  eapply In_initializeFrameValues__In_getArgsIDs in H; eauto.
  destruct H as [H | H]; auto.
    fsetdec.
Qed.

Lemma dom_initializeFrameValues: forall
  (TD : TargetData) (la : args) gvs lc acc,
  @Opsem._initializeFrameValues GVsSig TD la gvs acc = ret lc ->
  (forall i0, i0 `in` dom lc -> i0 `in` dom acc \/ In i0 (getArgsIDs la)).
Proof.
  induction la as [|[[]]]; simpl; intros.
    inv H. auto.

    destruct gvs.
      inv_mbind'.
      rewrite updateAddAL_dom_eq in H0.
      assert (i1 `in` (dom g) \/ i1 = i0) as J.
        fsetdec.
      destruct J as [J | J]; subst; auto.
        symmetry in HeqR.
        apply IHla with (i0:=i1) in HeqR; auto.
        destruct HeqR as [HeqR | HeqR]; auto.

      inv_mbind'.
      rewrite updateAddAL_dom_eq in H0.
      assert (i1 `in` (dom g0) \/ i1 = i0) as J.
        fsetdec.
      destruct J as [J | J]; subst; auto.
        symmetry in HeqR.
        apply IHla with (i0:=i1) in HeqR; auto.
        destruct HeqR as [HeqR | HeqR]; auto.
Qed.

Lemma NotIn_getArgsIDs__NotIn_initializeFrameValues: forall
  (TD : TargetData) (la : args) gvs (id1 : atom) lc acc,
  @Opsem._initializeFrameValues GVsSig TD la gvs acc = ret lc ->
  ~ In id1 (getArgsIDs la) /\ id1 `notin` dom acc ->
  lookupAL _ lc id1 = None.
Proof.
  induction la as [|[]]; simpl; intros.
    inv H.
    destruct H0.
    apply notin_lookupAL_None; auto.

    destruct H0 as [H1 H2].
    assert (i0 <> id1 /\ ~ In id1 (getArgsIDs la)) as J.
      split; intro; subst; contradict H1; auto.
    destruct J as [J1 J2].
    destruct p.
    destruct gvs.
      inv_mbind'.
      rewrite <- lookupAL_updateAddAL_neq; auto.
      apply notin_lookupAL_None; auto.
      intro J. symmetry in HeqR.
      apply dom_initializeFrameValues with (i0:=id1) in HeqR; auto.
      destruct HeqR; auto.

      inv_mbind'.
      rewrite <- lookupAL_updateAddAL_neq; auto.
      eapply IHla; eauto.
Qed.

Lemma NotIn_getArgsIDs__NotIn_initLocals : forall TD la gvs id1 lc,
  @Opsem.initLocals GVsSig TD la gvs = Some lc ->
  ~ In id1 (getArgsIDs la) ->
  lookupAL _ lc id1 = None.
Proof.
  unfold Opsem.initLocals.
  intros.
  eapply NotIn_getArgsIDs__NotIn_initializeFrameValues in H; eauto.
Qed.

(***********************************************************)
(* Properties of updateValuesForNewBlock *)
Lemma updateValuesForNewBlock_spec6 : forall lc rs id1 gvs
  (Hlk : lookupAL _ (@updateValuesForNewBlock GVsSig rs lc) id1 = ret gvs)
  (Hin : id1 `in` (dom rs)),
  lookupAL _ rs id1 = Some gvs.
Proof.
  induction rs; simpl; intros.
    fsetdec.

    destruct a.
    assert (id1 = i0 \/ id1 `in` dom rs) as J. fsetdec.
    destruct J as [J | J]; subst.
      rewrite lookupAL_updateAddAL_eq in Hlk; auto. inv Hlk.
      destruct (@eq_dec atom (EqDec_eq_of_EqDec atom EqDec_atom) i0 i0); auto.
        contradict n; auto.

      destruct (@eq_dec atom (EqDec_eq_of_EqDec atom EqDec_atom) id1 i0);
        subst; eauto.
        rewrite lookupAL_updateAddAL_eq in Hlk; auto.
        rewrite <- lookupAL_updateAddAL_neq in Hlk; eauto.
Qed.

Lemma updateValuesForNewBlock_spec7 : forall lc rs id1 gvs
  (Hlk : lookupAL _ (@updateValuesForNewBlock GVsSig rs lc) id1 = ret gvs)
  (Hnotin : id1 `notin` (dom rs)),
  lookupAL _ lc id1 = ret gvs.
Proof.
  induction rs; simpl; intros; auto.
    destruct a.

    destruct_notin.
    rewrite <- lookupAL_updateAddAL_neq in Hlk; eauto.
Qed.

Lemma updateValuesForNewBlock_spec6' : forall lc rs id1
  (Hin : id1 `in` (dom rs)),
  lookupAL _ (@updateValuesForNewBlock GVsSig rs lc) id1 = lookupAL _ rs id1.
Proof.
  induction rs; simpl; intros.
    fsetdec.

    destruct a.
    assert (id1 = a \/ id1 `in` dom rs) as J. fsetdec.
    destruct J as [J | J]; subst.
      rewrite lookupAL_updateAddAL_eq.
      destruct (@eq_dec atom (EqDec_eq_of_EqDec atom EqDec_atom) a a); auto.
        contradict n; auto.

      destruct (@eq_dec atom (EqDec_eq_of_EqDec atom EqDec_atom) id1 a);
        subst; eauto.
        rewrite lookupAL_updateAddAL_eq; auto.
        rewrite <- lookupAL_updateAddAL_neq; eauto.
Qed.

Lemma updateValuesForNewBlock_spec7' : forall lc rs id1
  (Hin : id1 `notin` (dom rs)),
  lookupAL _ (@updateValuesForNewBlock GVsSig rs lc) id1 = lookupAL _ lc id1.
Proof.
  induction rs; simpl; intros; auto.
    destruct a. destruct_notin.
    rewrite <- lookupAL_updateAddAL_neq; eauto.
Qed.

Lemma updateValuesForNewBlock_sim : forall id0 lc lc'
  (Heq : forall id' : id,
        id' <> id0 ->
        lookupAL _ lc id' = lookupAL GVs lc' id')
  g0 g
  (EQ : forall id' : id,
       id' <> id0 ->
       lookupAL _ g0 id' = lookupAL _ g id'),
  forall id', id' <> id0 ->
   lookupAL _ (updateValuesForNewBlock g0 lc) id' =
   lookupAL _ (updateValuesForNewBlock g lc') id'.
Proof.
  intros.
  destruct (AtomSetProperties.In_dec id' (dom g0)).
    rewrite updateValuesForNewBlock_spec6'; auto.
    destruct (AtomSetProperties.In_dec id' (dom g)).
      rewrite updateValuesForNewBlock_spec6'; auto.

      apply notin_lookupAL_None in n.
      erewrite <- EQ in n; eauto.
      apply indom_lookupAL_Some in i0.
      destruct i0 as [gv0 i0].
      rewrite i0 in n. congruence.

    rewrite updateValuesForNewBlock_spec7'; auto.
    destruct (AtomSetProperties.In_dec id' (dom g)).
      apply notin_lookupAL_None in n.
      erewrite EQ in n; eauto.
      apply indom_lookupAL_Some in i0.
      destruct i0 as [gv0 i0].
      rewrite i0 in n. congruence.

      rewrite updateValuesForNewBlock_spec7'; auto.
Qed.

Lemma updateValuesForNewBlock_spec5: forall lc1' lc2' i0
  (Hlk: lookupAL _ lc1' i0 = lookupAL _ lc2' i0) lc2
  (Hlk: merror = lookupAL _ lc2 i0),
  lookupAL _ lc1' i0 =
    lookupAL _ (@Opsem.updateValuesForNewBlock GVsSig lc2 lc2') i0.
Proof.
  induction lc2 as [|[]]; simpl; intros; auto.
    destruct (i0 == a); try congruence.
    rewrite <- lookupAL_updateAddAL_neq; auto.
Qed.

(***********************************************************)
(* Properties of getIncomingValuesForBlockFromPHINodes *)
Lemma getIncomingValuesForBlockFromPHINodes_spec6 : forall TD b gl lc ps' rs id1
  (HeqR1 : ret rs = @getIncomingValuesForBlockFromPHINodes GVsSig TD ps' b gl lc)
  (Hin : In id1 (getPhiNodesIDs ps')),
  id1 `in` dom rs.
Proof.
  induction ps'; simpl; intros.
    inv Hin.

    destruct a. destruct b. simpl in *.
    inv_mbind. inv HeqR1.
    destruct Hin as [Hin | Hin]; subst; simpl; auto.
Qed.

Lemma getIncomingValuesForBlockFromPHINodes_spec7 : forall TD b gl lc ps' rs id1
  (HeqR1 : ret rs = @getIncomingValuesForBlockFromPHINodes GVsSig TD ps' b gl lc)
  (Hin : id1 `in` dom rs),
  In id1 (getPhiNodesIDs ps').
Proof.
  induction ps'; simpl; intros.
    inv HeqR1. fsetdec.

    destruct a as [i0 ?]. destruct b as [l2 ? ? ?]. simpl in *.
    inv_mbind. inv HeqR1. simpl in *.
    assert (id1 = i0 \/ id1 `in` dom l1) as J. fsetdec.
    destruct J as [J | J]; subst; eauto.
Qed.

Lemma getIncomingValuesForBlockFromPHINodes_spec8 : forall TD b gl lc ps' rs id1
  (HeqR1 : ret rs = @getIncomingValuesForBlockFromPHINodes GVsSig TD ps' b gl lc)
  (Hnotin : ~ In id1 (getPhiNodesIDs ps')),
  id1 `notin` dom rs.
Proof.
  intros.
  intro J. apply Hnotin.
  eapply getIncomingValuesForBlockFromPHINodes_spec7 in HeqR1; eauto.
Qed.

Lemma getIncomingValuesForBlockFromPHINodes_spec9: forall TD gl lc b id0 gvs0
  ps' l0,
  ret l0 = @Opsem.getIncomingValuesForBlockFromPHINodes GVsSig TD ps' b gl lc ->
  id0 `in` dom l0 ->
  lookupAL _ l0 id0 = ret gvs0 ->
  exists id1, exists t1, exists vls1, exists v, exists n,
    In (insn_phi id1 t1 vls1) ps' /\
    nth_error vls1 n = Some (v, getBlockLabel b) /\
    Opsem.getOperandValue TD v lc gl= Some gvs0.
Proof.
  induction ps' as [|[i0 t l0]]; simpl; intros.
    inv H. fsetdec.

    inv_mbind. simpl in *.
    destruct (id0 == i0); subst.
      destruct b. simpl in *.
      symmetry in HeqR.
      apply getValueViaLabelFromValuels__nth_list_value_l in HeqR; auto.
      destruct HeqR as [n HeqR].
      destruct (@eq_dec atom (EqDec_eq_of_EqDec atom EqDec_atom) i0 i0);
        try congruence.
      inv H1.
      exists i0. exists t. exists l0. exists v. exists n.
      split; auto.

      apply IHps' in H1; auto; try fsetdec.
      destruct H1 as [id1 [t1 [vls1 [v' [n' [J1 [J2 J3]]]]]]].
      exists id1. exists t1. exists vls1. exists v'. exists n'.
      split; auto.
Qed.

Lemma getIncomingValuesForBlockFromPHINodes_spec9': forall TD gl lc b id0 gvs0
  ps' l0,
  ret l0 = @Opsem.getIncomingValuesForBlockFromPHINodes GVsSig TD ps' b gl lc ->
  id0 `in` dom l0 ->
  lookupAL _ l0 id0 = ret gvs0 ->
  exists t1, exists vls1, exists v,
    In (insn_phi id0 t1 vls1) ps' /\
    getValueViaLabelFromValuels vls1 (getBlockLabel b) = Some v /\
    Opsem.getOperandValue TD v lc gl= Some gvs0.
Proof.
  induction ps' as [|[i0 t l0]]; simpl; intros.
    inv H. fsetdec.

    inv_mbind. simpl in *.
    destruct (id0 == i0); subst.
      destruct b. simpl in *.
      symmetry in HeqR.
      inv H1.
      exists t. exists l0. exists v.
      split; auto.

      apply IHps' in H1; auto; try fsetdec.
      destruct H1 as [t1 [vls1 [v' [J1 [J2 J3]]]]].
      exists t1. exists vls1. exists v'.
      split; auto.
Qed.

(***********************************************************)
(* Properties of bop *)
Lemma bops_trans : forall cfg state1 state2 state3 tr1 tr2,
  @bops GVsSig cfg state1 state2 tr1 ->
  bops cfg state2 state3 tr2 ->
  bops cfg state1 state3 (Eapp tr1 tr2).
Proof.
  intros cfg state1 state2 state3 tr1 tr2 H.
  generalize dependent state3.
  generalize dependent tr2.
  induction H; intros; auto.
    rewrite Eapp_assoc. eauto.
Qed.

Lemma bInsn__bops : forall cfg state1 state2 tr,
  @bInsn GVsSig cfg state1 state2 tr ->
  bops cfg state1 state2 tr.
Proof.
  intros.
  rewrite <- E0_right.
  eauto.
Qed.

Lemma bInsn__inv : forall cfg B1 c cs tmn3 lc1 als1 Mem1 B2 tmn4 lc2 als2
  Mem2 tr,
  @bInsn GVsSig cfg (mkbEC B1 (c::cs) tmn3 lc1 als1 Mem1)
    (mkbEC B2 cs tmn4 lc2 als2 Mem2) tr ->
  B1 = B2 /\ tmn3 = tmn4.
Proof.
  intros.
  inversion H; subst; repeat (split; auto).
Qed.

Lemma bInsn_Call__inv : forall cfg B1 c cs tmn3 lc1 als1 Mem1 B2 tmn4 lc2 als2
  Mem2 tr,
  @bInsn GVsSig cfg
    (mkbEC B1 (c::cs) tmn3 lc1 als1 Mem1) (mkbEC B2 cs tmn4 lc2 als2 Mem2) tr ->
  Instruction.isCallInst c = true ->
  B1 = B2 /\ tmn3 = tmn4 /\ als1 = als2.
Proof.
  intros.
  inversion H; subst; try solve [inversion H0 | repeat (split; auto)].
Qed.

(* preservation of uniqueness and inclusion for bop *)

Definition bInsn_preservation_prop cfg state1 state2 tr
  (db:@bInsn GVsSig cfg state1 state2 tr) :=
  forall S los nts Ps gl fs F B cs tmn lc als Mem cs' tmn' B' lc' als' Mem',
  cfg = (mkbCfg S (los, nts) Ps gl fs F) ->
  state1 = (mkbEC B cs tmn lc als Mem) ->
  uniqSystem S ->
  blockInSystemModuleFdef B S (module_intro los nts Ps) F ->
  state2 = (mkbEC B' cs' tmn' lc' als' Mem') ->
  blockInSystemModuleFdef B' S (module_intro los nts Ps) F.
Definition bops_preservation_prop cfg state1 state2 tr
  (db:@bops GVsSig cfg state1 state2 tr) :=
  forall S los nts Ps gl fs F B cs tmn lc als Mem B' cs' tmn' lc' als' Mem',
  cfg = (mkbCfg S (los, nts) Ps gl fs F) ->
  state1 = (mkbEC B cs tmn lc als Mem) ->
  state2 = (mkbEC B' cs' tmn' lc' als' Mem') ->
  uniqSystem S ->
  blockInSystemModuleFdef B S (module_intro los nts Ps) F ->
  blockInSystemModuleFdef B' S (module_intro los nts Ps) F.
Definition bFdef_preservation_prop fv rt lp S TD Ps lc gl fs Mem lc' als'
 Mem' B' Rid oResult tr
 (db:@bFdef GVsSig fv rt lp S TD Ps lc gl fs Mem lc' als' Mem' B' Rid oResult tr)
  :=
  forall los nts,
  TD = (los, nts) ->
  uniqSystem S ->
  moduleInSystem (module_intro los nts Ps) S ->
  exists fptrs, exists fptr, exists F,
    getOperandValue TD fv lc gl = Some fptrs /\
    fptr @ fptrs /\
    lookupFdefViaPtr Ps fs fptr = Some F /\
    uniqFdef F /\
    blockInSystemModuleFdef B' S (module_intro los nts Ps) F.

Lemma b_preservation :
  (forall cfg state1 state2 tr db,
     @bInsn_preservation_prop cfg state1 state2 tr db) /\
  (forall cfg state1 state2 tr db,
     @bops_preservation_prop cfg state1 state2 tr  db) /\
  (forall fv rt lp S TD Ps lc gl fs Mem lc' als' Mem' B' Rid oResult tr db,
    @bFdef_preservation_prop fv rt lp S TD Ps lc gl fs Mem lc' als' Mem' B' Rid
      oResult tr db).
Proof.
(b_mutind_cases
  apply b_mutind with
    (P  := bInsn_preservation_prop)
    (P0 := bops_preservation_prop)
    (P1 := bFdef_preservation_prop) Case);
  unfold bInsn_preservation_prop,
         bops_preservation_prop,
         bFdef_preservation_prop; intros; subst; repeat app_inv; auto.
Case "bBranch".
  apply andb_true_iff in H2.
  destruct H2.
  eapply andb_true_iff.
  split; auto.
    assert (uniqFdef F0) as UniqF0.
      eapply uniqSystem__uniqFdef with (S:=S0); eauto.
    symmetry in e0.
    destruct (isGVZero (los, nts) c);
      apply lookupBlockViaLabelFromFdef_inv in e0; auto.

Case "bBranch_uncond".
  apply andb_true_iff in H2.
  destruct H2.
  eapply andb_true_iff.
  split; auto.
    assert (uniqFdef F0) as UniqF0.
      eapply uniqSystem__uniqFdef with (S:=S0); eauto.
    symmetry in e.
    apply lookupBlockViaLabelFromFdef_inv in e; auto.

Case "bops_cons".
  destruct S2 as [b2 cs2 tmn2 lc2 als2 M2].
  eapply H with (cs0:=cs)(lc0:=lc)(als0:=als)(gl0:=gl)(fs0:=fs)(Mem:=Mem0)
    (B':=b2)(lc':=lc2)(cs':=cs2)(tmn':=tmn2)(als':=als2)(Mem':=M2) in H5; eauto.

Case "bFdef_func".
  exists fptrs. exists fptr.
  exists (fdef_intro (fheader_intro fa rt fid la va) lb).
  split; auto.
  split; auto.
  split; auto.
  split.
    eapply lookupFdefViaPtr_uniq; eauto.
    eapply H with (lc'0:=lc')(cs'0:=nil)(als'0:=als')(Mem'0:=Mem');
      eauto using entryBlockInSystemBlockFdef''.

Case "bFdef_proc".
  exists fptrs. exists fptr.
  exists (fdef_intro (fheader_intro fa rt fid la va) lb).
  split; auto.
  split; auto.
  split; auto.
  split.
    eapply lookupFdefViaPtr_uniq; eauto.
    eapply H; eauto using entryBlockInSystemBlockFdef''.
Qed.

Lemma bInsn_preservation : forall tr S los nts Ps F cs tmn lc als
  gl fs Mem cs' tmn' lc' als' Mem' B B',
  @bInsn GVsSig (mkbCfg S (los, nts) Ps gl fs F)
    (mkbEC B cs tmn lc als Mem)
    (mkbEC B' cs' tmn' lc' als' Mem') tr ->
  uniqSystem S ->
  blockInSystemModuleFdef B S (module_intro los nts Ps) F ->
  blockInSystemModuleFdef B' S (module_intro los nts Ps) F.
Proof.
  intros.
  destruct b_preservation as [J _].
  unfold bInsn_preservation_prop in J.
  eapply J; eauto.
Qed.

Lemma bops_preservation : forall tr S los nts Ps F B cs tmn lc als gl
    fs Mem B' cs' tmn' lc' als' Mem',
  @bops GVsSig (mkbCfg S (los, nts) Ps gl fs F)
    (mkbEC B cs tmn lc als Mem) (mkbEC B' cs' tmn' lc' als' Mem')
    tr ->
  uniqSystem S ->
  blockInSystemModuleFdef B S (module_intro los nts Ps) F ->
  blockInSystemModuleFdef B' S (module_intro los nts Ps) F.
Proof.
  intros.
  destruct b_preservation as [_ [J _]].
  unfold bops_preservation_prop in J.
  eapply J; eauto.
Qed.

Lemma bFdef_preservation : forall fv rt lp S los nts Ps lc gl fs Mem lc'
    als' Mem' B' Rid oResult tr,
  @bFdef GVsSig fv rt lp S (los, nts) Ps lc gl fs Mem lc' als' Mem' B' Rid
    oResult tr ->
  uniqSystem S ->
  moduleInSystem (module_intro los nts Ps) S ->
  exists fptrs, exists fptr, exists F,
    getOperandValue (los, nts) fv lc gl = Some fptrs /\
    fptr @ fptrs /\
    lookupFdefViaPtr Ps fs fptr = Some F /\
    uniqFdef F /\
    blockInSystemModuleFdef B' S (module_intro los nts Ps) F.
Proof.
  intros.
  destruct b_preservation as [_ [_ J]].
  unfold bFdef_preservation_prop in J.
  eapply J; eauto.
Qed.

End OpsemProps. End OpsemProps.


Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Relations.Relation_Operators.
Require Import List.

Require Export Syntax.

Reserved Notation " P '/' cfg '==>' cfg' " (at level 40).

Inductive step (P : program) : configuration -> configuration -> Prop :=
(***************)
(* Parallelism *)
(***************)
  | EvalAsyncLeft :
      forall H H' V V' n n' T1 T1' T2 e,
        P / (H, V, n, T1) ==>
          (H', V', n', T1') ->
        P / (H, V, n, T_Async T1 T2 e) ==>
          (H', V', n', T_Async T1' T2 e)
  | EvalAsyncRight :
      forall H H' V V' n n' T1 T2 T2' e,
        P / (H, V, n, T2) ==>
          (H', V', n', T2') ->
        P / (H, V, n, T_Async T1 T2 e) ==>
          (H', V', n', T_Async T1 T2' e)
  | EvalAsyncJoin :
      forall H V n e1 T2 Ls e,
        threads_done(T_Thread Ls e1) ->
        threads_done(T2) ->
        P / (H, V, n, T_Async (T_Thread Ls e1) T2 e) ==>
          (H, V, n, T_Thread Ls e)
  | EvalSpawn :
      forall H V n e1 e2 e3 Ls,
        P / (H, V, n, T_Thread Ls (EPar e1 e2 e3)) ==>
          (H, V, n, T_Async (T_Thread Ls e1) (T_Thread nil e2) e3)
  | EvalSpawnContext :
      forall H V n ctx e e1 e2 e3 Ls,
        is_econtext ctx ->
        P / (H, V, n, T_Thread Ls e) ==>
          (H, V, n, T_Async (T_Thread Ls e1) (T_Thread nil e2) e3) ->
        P / (H, V, n, T_Thread Ls (ctx e)) ==>
          (H, V, n, T_Async (T_Thread Ls e1) (T_Thread nil e2) (ctx e3))
(*****************)
(* Single thread *)
(*****************)
  | EvalContext :
      forall H H' V V' n n' ctx e e' Ls Ls',
        is_econtext ctx ->
        P / (H, V, n, T_Thread Ls e) ==>
          (H', V', n', T_Thread Ls' e') ->
        P / (H, V, n, T_Thread Ls (ctx e)) ==>
          (H', V', n', T_Thread Ls' (ctx e'))
  | EvalVar :
      forall H V n x v Ls,
        V x = Some v ->
        P / (H, V, n, T_Thread Ls (EVar (DV x))) ==>
          (H, V, n, T_Thread Ls (EVal v))
  | EvalConsume :
      forall H V n x v Ls,
        V x = Some v ->
        P / (H, V, n, T_Thread Ls (EConsume (DV x))) ==>
          (H, extend V x VNull, n, T_Thread Ls (EVal v))
  | EvalCast :
      forall H V n v t Ls,
        P / (H, V, n, T_Thread Ls (ECast t (EVal v))) ==>
          (H, V, n, T_Thread Ls (EVal v))
  | EvalNew :
      forall H V n c i fs RL ms Ls,
        classLookup P c = (Some (Cls c i fs ms)) ->
        declsToRegionLocks fs RL ->
        P / (H, V, n, T_Thread Ls (ENew c)) ==>
          (heapExtend H (c, declsToFields fs, RL),
           V, n, T_Thread Ls (EVal (VLoc (length H))))
  | EvalCall :
      forall H V n x l m v c mtds y body t t' Ls,
        V x = Some (VLoc l) ->
        (exists F RL, heapLookup H l = Some (c, F, RL)) ->
        methods P (TClass c) = Some mtds ->
        methodLookup mtds m = Some (Method m (y, t) t' body) ->
        P / (H, V, n, T_Thread Ls (ECall (DV x) m (EVal v))) ==>
          (H, extend (extend V (dthis, n) (VLoc l)) (DVar n, n) v, S n,
           T_Thread Ls (subst y (DVar n, n) (subst this (dthis, n) (sigma n body))))
  | EvalSelect :
      forall H V n x l f c F RL v Ls,
        V x = Some (VLoc l) ->
        heapLookup H l = Some (c, F, RL) ->
        F f = Some v ->
        P / (H, V, n, T_Thread Ls (ESelect (DV x) f)) ==>
          (H, V, n, T_Thread Ls (EVal v))
  | EvalConsumeField :
      forall H V n x l f c F RL v Ls,
        V x = Some (VLoc l) ->
        heapLookup H l = Some (c, F, RL) ->
        F f = Some v ->
        P / (H, V, n, T_Thread Ls (EConsumeField (DV x) f)) ==>
          (heapUpdate H l (c, extend F f VNull, RL), V, n, T_Thread Ls (EVal v))
  | EvalUpdate :
      forall H V n x l f v c F RL Ls,
        V x = Some (VLoc l) ->
        heapLookup H l = Some (c, F, RL) ->
        P / (H, V, n, T_Thread Ls (EUpdate (DV x) f (EVal v))) ==>
          (heapUpdate H l (c, extend F f v, RL), V, n, T_Thread Ls (EVal VNull))
  | EvalLet :
      forall H V n frame x v body Ls,
        P / (H, V, n, T_Thread Ls (ELet x frame (EVal v) body)) ==>
          (H, extend V (DVar n, frame) v, S n, T_Thread Ls ((subst x (DVar n, frame) body)))
  | EvalAssert :
      forall H V n x y l e Ls,
        V x = Some (VLoc l) ->
        V y = Some (VLoc l) ->
        P / (H, V, n, T_Thread Ls (EAssert (DV x) (DV y) e)) ==>
          (H, V, n, T_Thread Ls e)
(***********)
(* Locking *)
(***********)
  | EvalWlock :
      forall H V n x r l e c F RL Ls,
        V x = Some (VLoc l) ->
        heapLookup H l = Some (c, F, RL) ->
        RL r = Some (LReaders 0) ->
        ~ In (l, r) Ls ->
        P / (H, V, n, T_Thread Ls (EWlock (DV x) r e)) ==>
          (heapUpdate H l (c, F, extend RL r LLocked), V, n, T_Thread ((l, r) :: Ls) (EWlocked (l, r) e))
  | EvalWlock_Reentrant :
      forall H V n x r l e c F RL Ls,
        V x = Some (VLoc l) ->
        heapLookup H l = Some (c, F, RL) ->
        RL r = Some LLocked ->
        In (l, r) Ls ->
        P / (H, V, n, T_Thread Ls (EWlock (DV x) r e)) ==>
          (H, V, n, T_Thread Ls e)
  | EvalWlock_Release :
      forall H V n r l v c F RL Ls,
        heapLookup H l = Some (c, F, RL) ->
        RL r = Some LLocked ->
        In (l, r) Ls ->
        P / (H, V, n, T_Thread Ls (EWlocked (l, r) (EVal v))) ==>
          (heapUpdate H l (c, F, extend RL r (LReaders 0)), V, n, T_Thread (remove id_eq_dec (l, r) Ls) (EVal v))
  | EvalRlock :
      forall H V n x r l m e c F RL Ls,
        V x = Some (VLoc l) ->
        heapLookup H l = Some (c, F, RL) ->
        RL r = Some (LReaders m) ->
        P / (H, V, n, T_Thread Ls (ERlock (DV x) r e)) ==>
          (heapUpdate H l (c, F, extend RL r (LReaders (S m))), V, n, T_Thread Ls (ERlocked (l, r) e))
  | EvalRlock_Reentrant :
      forall H V n x r l e c F RL Ls,
        V x = Some (VLoc l) ->
        heapLookup H l = Some (c, F, RL) ->
        RL r = Some LLocked ->
        In (l, r) Ls ->
        P / (H, V, n, T_Thread Ls (ERlock (DV x) r e)) ==>
          (H, V, n, T_Thread Ls e)
  | EvalRlock_Release :
      forall H V n r l m v c F RL Ls,
        heapLookup H l = Some (c, F, RL) ->
        RL r = Some (LReaders m) ->
        P / (H, V, n, T_Thread Ls (ERlocked (l, r) (EVal v))) ==>
          (heapUpdate H l (c, F, extend RL r (LReaders (pred m))), V, n, T_Thread Ls (EVal v))
(**************)
(* Exceptions *)
(**************)
  | EvalEXN_AsyncLeft :
      forall H V n T1 T2 e,
        threads_exn(T1) ->
        P / (H, V, n, T_Async T1 T2 e) ==>
          (H, V, n, T_EXN (leftmost_locks T1))
  | EvalEXN_AsyncRight :
      forall H V n T1 T2 e,
        threads_exn(T2) ->
        P / (H, V, n, T_Async T1 T2 e) ==>
          (H, V, n, T_EXN (leftmost_locks T1))
  | EvalEXN_Context :
      forall ctx H V n e Ls,
        is_econtext ctx ->
        P / (H, V, n, T_Thread Ls e) ==>
           (H, V, n, T_EXN Ls) ->
        P / (H, V, n, T_Thread Ls (ctx e)) ==>
          (H, V, n, T_EXN Ls)
  | EvalEXN_Call :
      forall H V n x m v Ls,
        V x = Some VNull ->
        P / (H, V, n, T_Thread Ls (ECall (DV x) m (EVal v))) ==>
          (H, V, n, T_EXN Ls)
  | EvalEXN_Select :
      forall H V n x f Ls,
        V x = Some VNull ->
        P / (H, V, n, T_Thread Ls (ESelect (DV x) f)) ==>
          (H, V, n, T_EXN Ls)
  | EvalEXN_ConsumeField :
      forall H V n x f Ls,
        V x = Some VNull ->
        P / (H, V, n, T_Thread Ls (EConsumeField (DV x) f)) ==>
          (H, V, n, T_EXN Ls)
  | EvalEXN_Update :
      forall H V n x f v Ls,
        V x = Some VNull ->
        P / (H, V, n, T_Thread Ls (EUpdate (DV x) f (EVal v))) ==>
          (H, V, n, T_EXN Ls)
  | EvalEXN_WLock :
      forall H V n x r e Ls,
        V x = Some VNull ->
        P / (H, V, n, T_Thread Ls (EWlock (DV x) r e)) ==>
          (H, V, n, T_EXN Ls)
  | EvalEXN_RLock :
      forall H V n x r e Ls,
        V x = Some VNull ->
        P / (H, V, n, T_Thread Ls (ERlock (DV x) r e)) ==>
          (H, V, n, T_EXN Ls)
  | EvarEXN_AssertL :
      forall H V n x y e Ls,
        V x = Some VNull ->
        P / (H, V, n, T_Thread Ls (EAssert (DV x) (DV y) e)) ==>
          (H, V, n, T_EXN Ls)
  | EvarEXN_AssertR :
      forall H V n x y e Ls,
        V y = Some VNull ->
        P / (H, V, n, T_Thread Ls (EAssert (DV x) (DV y) e)) ==>
          (H, V, n, T_EXN Ls)
  | EvarEXN_Assert :
      forall H V n x y l1 l2 e Ls,
        V x = Some (VLoc l1) ->
        V y = Some (VLoc l2) ->
        l1 <> l2 ->
        P / (H, V, n, T_Thread Ls (EAssert (DV x) (DV y) e)) ==>
          (H, V, n, T_EXN Ls)

  where " P '/' cfg '==>' cfg' " := (step P cfg cfg').

Hint Constructors step.

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "EvalAsyncLeft"
  | Case_aux c "EvalAsyncRight"
  | Case_aux c "EvalAsyncJoin"
  | Case_aux c "EvalSpawn"
  | Case_aux c "EvalSpawnContext"

  | Case_aux c "EvalContext"
  | Case_aux c "EvalVar"
  | Case_aux c "EvalConsume"
  | Case_aux c "EvalNew"
  | Case_aux c "EvalCall"
  | Case_aux c "EvalSelect"
  | Case_aux c "EvalConsumeField"
  | Case_aux c "EvalUpdate"
  | Case_aux c "EvalLet"
  | Case_aux c "EvalAssert"

  | Case_aux c "EvalWlock"
  | Case_aux c "EvalWlock_Reentrant"
  | Case_aux c "EvalWlock_Release"
  | Case_aux c "EvalRlock"
  | Case_aux c "EvalRlock_Reentrant"
  | Case_aux c "EvalRlock_Release"

  | Case_aux c "EvalEXN_AsyncLeft"
  | Case_aux c "EvalEXN_AsyncRight"
  | Case_aux c "EvalEXN_Context"
  | Case_aux c "EvalEXN_Call"
  | Case_aux c "EvalEXN_Select"
  | Case_aux c "EvalEXN_Update"
  | Case_aux c "EvalEXN_Assert"
  ].

Definition multistep (P : program) := clos_refl_trans_1n configuration (step P).
Notation " P '/' cfg '==>*' cfg' " := (multistep P cfg cfg') (at level 40).

Inductive cfg_blocked : configuration -> Prop :=
  | Blocked_Deadlock :
      forall H V n T1 T2 e,
        cfg_blocked (H, V, n, T1) ->
        cfg_blocked (H, V, n, T2) ->
        cfg_blocked (H, V, n, T_Async T1 T2 e)
  | Blocked_Left :
      forall H V n T1 T2 e,
        cfg_blocked (H, V, n, T1) ->
        threads_done T2 ->
        cfg_blocked (H, V, n, T_Async T1 T2 e)
  | Blocked_Right :
      forall H V n T1 T2 e,
        threads_done T1 ->
        cfg_blocked (H, V, n, T2) ->
        cfg_blocked (H, V, n, T_Async T1 T2 e)
  | Blocked_WW :
      forall H V n x r e l c F RL Ls,
        V x = Some (VLoc l) ->
        heapLookup H l = Some (c, F, RL) ->
        RL r = Some LLocked ->
        ~ In (l, r) Ls ->
        cfg_blocked (H, V, n, T_Thread Ls (EWlock (DV x) r e))
  | Blocked_WR :
      forall H V n x r e l c F RL m Ls,
        V x = Some (VLoc l) ->
        heapLookup H l = Some (c, F, RL) ->
        RL r = Some (LReaders m) ->
        m > 0 ->
        cfg_blocked (H, V, n, T_Thread Ls (EWlock (DV x) r e))
  | Blocked_RW :
      forall H V n x r e l c F RL Ls,
        V x = Some (VLoc l) ->
        heapLookup H l = Some (c, F, RL) ->
        RL r = Some LLocked ->
        ~ In (l, r) Ls ->
        cfg_blocked (H, V, n, T_Thread Ls (ERlock (DV x) r e))
  | Blocked_Context :
      forall H V n ctx e Ls,
        is_econtext ctx ->
        cfg_blocked (H, V, n, T_Thread Ls e) ->
        cfg_blocked (H, V, n, T_Thread Ls (ctx e)).