(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Adam Koprowski, 2006-04-27

Some computability results instantiated for horpo.
*)

Set Implicit Arguments.

From CoLoR Require Import RelExtras ListExtras Computability Horpo.
From Coq Require Import Setoid Morphisms.

Module HorpoComp (S : TermsSig.Signature)
  (Prec : Horpo.Precedence with Module S := S).

  Module Export Comp := Computability.Computability S Prec.

  Import List.

  Definition horpo_lt := transp horpo.
  Definition horpo_mul_lt := MultisetLT horpo.

  Notation "X << Y" := (horpo_lt X Y) (at level 55).
  Definition Htrans := clos_trans horpo.

  Definition Terms := list Term.
  Definition CompH := Computable horpo.
  Definition CompTerms (Ts: Terms) := AllComputable horpo Ts.
  Definition CompSubst (G: Subst) := forall Q, In (Some Q) G -> CompH Q.

  Definition WFterms := { Ts: Terms | CompTerms Ts }.
  Definition WFterms_to_mul (Ts: WFterms) := list2multiset (proj1_sig Ts).
  Coercion WFterms_to_mul: WFterms >-> Multiset.
  Definition H_WFterms_lt (M N: WFterms) := horpo_mul_lt M N.

  #[global] Hint Unfold horpo_lt horpo_mul_lt CompH CompTerms : horpo.

  Lemma horpo_comp_imp_acc M : CompH M -> AccR horpo M.

  Proof. intro Mcomp. apply comp_imp_acc; eauto with horpo. Qed.

  Lemma horpo_comp_step_comp M N : CompH M -> M >> N -> CompH N.

  Proof.
    intros Mcomp MN.
    unfold CompH; apply comp_step_comp with M; eauto with horpo.
  Qed.

  Lemma horpo_comp_manysteps_comp M N : CompH M -> M >>* N -> CompH N.

  Proof.
    intros Mcomp M_N.
    unfold CompH; apply comp_manysteps_comp with M; eauto with horpo.
  Qed.

  Lemma horpo_comp_pflat N Ns : isPartialFlattening Ns N -> algebraic N ->
    AllComputable horpo Ns -> CompH N.

  Proof.
    intros NsN Nnorm NsC; unfold CompH. apply comp_pflat with Ns; trivial.
  Qed.

  Lemma horpo_neutral_comp_step : forall M, algebraic M -> isNeutral M ->
    (CompH M <-> (forall N, M >> N -> CompH N)).

  Proof.
    intros M Mneutral; unfold CompH.
    apply neutral_comp_step; eauto with horpo.
  Qed.

  Lemma CompH_morph_aux : forall x1 x2 : Term, x1 ~ x2 -> CompH x1 -> CompH x2.

  Proof.
    intros t t' teqt' H_t.
    unfold CompH.
    apply Computable_morph_aux with t; eauto with horpo.
  Qed.

  Global Instance CompH_morph : Proper (terms_conv ==> iff) CompH.

  Proof.
    intros; split; apply CompH_morph_aux; auto using terms_conv_sym.
  Qed.

  Lemma horpo_comp_conv: forall M M', CompH M -> M ~ M' -> CompH M'.

  Proof. intros. rewrite <- H0; trivial. Qed.

  Lemma horpo_var_comp : forall M, isVar M -> CompH M.

  Proof.
    intros M Mvar; unfold CompH. apply var_comp; eauto with horpo.
  Qed.

  Lemma horpo_comp_abs : forall M (Mabs: isAbs M), algebraic M ->
    (forall G (cs: correct_subst (absBody Mabs) G) T,
      isSingletonSubst T G -> CompH T ->
      CompH (subst cs)) -> CompH M.

  Proof.
    intros M Mnorm Mabs H; unfold CompH. eapply comp_abs; eauto with horpo.
  Qed.

  Lemma horpo_comp_lift : forall N, CompH N -> CompH (lift N 1).

  Proof.
    intros.
    setoid_replace (lift N 1) with N using relation terms_conv; trivial.
    apply terms_conv_sym; apply terms_lift_conv.
  Qed.

  Lemma horpo_comp_app : forall M (Mapp: isApp M),
    CompH (appBodyL Mapp) -> CompH (appBodyR Mapp) -> CompH M.

  Proof.
    intros M Mapp Ml Mr; unfold CompH. apply comp_app with Mapp; trivial.
  Qed.

  Lemma horpo_comp_algebraic : forall M, CompH M -> algebraic M.

  Proof. intros. apply comp_algebraic with horpo; trivial. Qed.

  Lemma horpo_comp_units_comp M :
    (forall N, isAppUnit N M -> CompH N) -> CompH M.

  Proof. intro Munits; unfold CompH. apply comp_units_comp; trivial. Qed.

End HorpoComp.


Require Import Libs.
Require Import AST.
Require Import Setoid.
Require Import Memory.
Require Import ArithClasses.
Require Import Memtype.
Require Import Memdata.
Require Import Values.
Require Import Relation_Operators.
Require Import Operators_Properties.
Require Import Morphisms.
Set Implicit Agruments.

Tactic Notation "rewrite_Heq_do" :=
  repeat
    match goal with
      | H : ?TRM = Some _ |- context[?TRM] =>
        rewrite H
      | H : ?TRM = None |- context[?TRM] =>
        rewrite H
    end; simpl_do.

Module ExtraLemma(CM:MEM).
  Lemma load_store: forall (m1 m2 m1' m2': CM.mem) mc b i v,
    CM.store mc m1 b i v = Some m1' ->
    CM.store mc m2 b i v = Some m2' ->
    CM.load mc m1' b i = CM.load mc m2' b i.
  Proof.
    intros * STORE1 STORE2.
    edestruct (CM.load_store_similar _ _ _ _ _ _ STORE1) as [v1 [LOAD1 _]]; eauto.
    edestruct (CM.load_store_similar _ _ _ _ _ _ STORE2) as [v2 [LOAD2 ?]]; eauto.
    rewrite LOAD1, LOAD2.
    apply CM.load_loadbytes in LOAD1.
    apply CM.load_loadbytes in LOAD2.
    destruct LOAD1 as [bytes1 [LB1 DEC1]].
    destruct LOAD2 as [bytes2 [LB2 DEC2]].
    pose proof (CM.loadbytes_store_same _ _ _ _ _ _ STORE1).
    pose proof (CM.loadbytes_store_same _ _ _ _ _ _ STORE2).
    congruence.
  Qed.
End ExtraLemma.

Require Import Cminor.

Module FromCminorEnv(N:NUMERICAL)(CM:MEM)<:(BASEMEM(N)).
  Import N.
  Existing Instance Numerical_Num.

  (* we define a way to inject the memory model of Cminor inside the
     one of Loops, modulo a reasonable expression of the result of an
     alias analysis *)

  Module EL := ExtraLemma(CM).
  Hint Resolve EL.load_store.

  (* a pointer is a block and an offset *)
  Definition ptr := (block * int)%type.

  (* it can be directly injected inside Cminor values *)
  Definition val_of_ptr (p:ptr) : val:=
    let (b, ofs) := p in Vptr b ofs.

  Coercion val_of_ptr: ptr >-> val.

  Hint Unfold val_of_ptr: no_coerc.

  Implicit Type p: ptr.
  Implicit Type mc chunk: memory_chunk.
  Implicit Type b: block.
  Implicit Type i: ident.

  (* location can be either a pointer or a variable in the
     environment. This will allow to represent a local variable as an
     array of size 1 *)

  Inductive location : Type :=
  | LPtr: ptr -> location
  | LVar: ident -> location.
  Implicit Type l:location.

  Definition LPtr' := LPtr.
  Definition LVar' := LVar.
  Coercion LPtr' : ptr >-> location.
  Coercion LVar' : ident >-> location.

  Hint Unfold LPtr' LVar': no_coerc.
  Ltac no_coerc:= autounfold with no_coerc in *.

  (* two location are "non interfering" (result of alias analysis)
     when accessed according to the memory chunks *)

  Inductive non_interfering:
    location -> memory_chunk -> location -> memory_chunk -> Prop :=

  (** a pointer (in the memory) and an ident (in the local store) are
     non interfering*)
  | NI_pv: forall p mc1 i mc2,
    non_interfering p mc1 i mc2
  | NI_vp: forall i mc1 p mc2,
    non_interfering i mc1 p mc2

  (** two different variables do not interfere *)
  | NI_var: forall i1 mc1 i2 mc2, i1 <> i2 ->
    non_interfering i1 mc1 i2 mc2

  (** two pointers in different blocks do not interfere *)
  | NI_diff_block:
    forall b1 b2 ofs1 ofs2 mc1 mc2, b1 <> b2 ->
      non_interfering (LPtr (b1, ofs1)) mc1 (LPtr (b2, ofs2)) mc2

  (** when in the same block, two pointers are non interfering when the
     corresponding locations do not overlap*)
  | NI_12: forall b ofs1 ofs2 mc1 mc2, (** ptr1 before ptr2 *)
    Int.signed ofs1 + (size_chunk mc1) <= Int.signed ofs2 ->
    non_interfering (LPtr (b, ofs1)) mc1 (LPtr (b, ofs2)) mc2
  | NI_21: forall b ofs1 ofs2 mc1 mc2, (** ptr2 before ptr1*)
    Int.signed ofs2 + (size_chunk mc2) <= Int.signed ofs1 ->
    non_interfering (LPtr (b, ofs1)) mc1 (LPtr (b, ofs2)) mc2.

  (* a memory layout maps the array vision to the low level one

   * a "type" is given to each array (all accesses to any cell of this
     array will be done via this type)

   * each cell_id (array * list int) is mapped to a location

   * this mapping is non interfering
   *)

  Definition Correct_Layout chunk_of_array flatten_access :=
      (* the layout is non interfering *)
      forall ci1 ci2 mc1 mc2 l1 l2,
        ci1 <> ci2 ->

        chunk_of_array ci1.(array) = Some mc1 ->
        chunk_of_array ci2.(array) = Some mc2 ->

        flatten_access ci1 = Some l1 ->
        flatten_access ci2 = Some l2 ->

        non_interfering l1 mc1 l2 mc2.

  Record memory_layout : Type := mkLayout {
    chunk_of_array: Array_Id -> option memory_chunk; (* type of each array *)
    flatten_access: Cell_Id Num -> option location; (* where is each cell maps in memory*)
    correct_layout: Correct_Layout chunk_of_array flatten_access
  }.

  Hint Unfold Correct_Layout.

  (* a "memory" for loops is then a Cminor memory, plus a Cminor
     environment, and a layout *)

  (* Coq's kernel does not allow to use an inductive definition as a
     required field of a module. This explains why we go through an
     intermediate Memory' definition*)

  Record Memory': Type := mkMem {
    ll_mem: CM.mem;
    ll_env: env;
    layout: memory_layout}.
  Definition Memory := Memory'.
  Implicit Type mem: Memory.

  Definition Value := val.

  Definition layout' (mem:Memory) := layout mem.
  Coercion layout': Memory >-> memory_layout.
  Hint Unfold layout': no_coerc.

  Definition read mem ci : option val:=
    do mc <- mem.(chunk_of_array) ci.(array);
    do l <- mem.(flatten_access) ci;
    match l with
      | LPtr p => CM.loadv mc mem.(ll_mem) p
      | LVar i => mem.(ll_env) ! i
    end.

  Definition write mem ci v : option Memory :=
    do mc <- mem.(chunk_of_array) ci.(array);
    do l <- mem.(flatten_access) ci;
    match l with
      | LPtr p =>
        do nm <- CM.storev mc mem.(ll_mem) p v;
        Some {| ll_mem := nm;
                ll_env := mem.(ll_env);
                layout := mem.(layout)|}
      | LVar i =>
        (** we need to check that i already existed in the
           environment, to avoid creating new variables *)
        do _ <- mem.(ll_env) ! i;
        Some {| ll_mem := mem.(ll_mem);
                ll_env := PTree.set i v  mem.(ll_env);
                layout := mem.(layout)|}
    end.

  Ltac destr_ptrs :=
    repeat match goal with | p : ptr |- _ => destruct p end.

  Ltac mymonadInv H :=
    let rec aux _ :=
      monadInv H; try
        match type of H with
          | context[match ?l with
                      | LPtr _ => _
                      | LVar _ => _
                    end] =>
          let p := fresh "p" in let i := fresh "i" in
          destruct l as [p| i]; try aux tt
        end in
     aux tt; destr_ptrs; simpl in *; rewrite_Heq_do.

  (* two memories are of "same layout" if you can go from one to the
     other trough a sequence or [write] (since it's a refl *sym* trans
     closure, it's a slightly bigger equivalence class)*)

  Inductive sml_aux: relation Memory :=
  |SMTA_intro: forall mem1 mem2 ci v,
    write mem1 ci v = Some mem2 ->
    sml_aux mem1 mem2.

  Definition same_memory_layout: relation Memory :=
    clos_refl_sym_trans_1n _ sml_aux.

  Hint Constructors clos_refl_sym_trans_1n.

  Instance Equiv_smt: Equivalence same_memory_layout.
  Proof.
    unfold same_memory_layout.
    destruct (clos_rst_is_equiv _ sml_aux). unfold reflexive, transitive, symmetric in *.
    prove_equiv; intros; rewrite <- (clos_rst_rst1n_iff) in *; eauto.
  Qed.

  (* you don't change the layout of a memory by writing in it *)
  Lemma write_keep_layout:
    forall mem1 mem2 ci v, write mem1 ci v = Some mem2 -> same_memory_layout mem1 mem2.
  Proof.
    intros * WRITE.
    econstructor; auto.
    left. econstructor. eauto.
  Qed.

(*  Ltac prog_match_loc_aux TERM :=
    match TERM with
      | context[match ?X with |LPtr _ => _ | LVar _ =>  _ end] =>
        let p := fresh "p" in let i := fresh "i" in
        destruct X as [p|i] _eqn
    end.

  Ltac prog_match_location :=
    match goal with
      | H : ?TERM |- _ =>
        prog_match_loc_aux TERM
      | |- ?TERM =>
        prog_match_loc_aux TERM
    end.*)

  Lemma sml_aux_same_layout:
    forall mem1 mem2, sml_aux mem1 mem2 \/ sml_aux mem2 mem1 ->
      layout mem1 = layout mem2.
  Proof.
    intros * [H|H]; inv H;
    mymonadInv H0; auto.
  Qed.

  Lemma same_layout_same_layout:
    forall mem1 mem2, same_memory_layout mem1 mem2 -> layout mem1 = layout mem2.
  Proof.
    intros * SMT. induction SMT; auto.
    rewrite <- IHSMT.
    apply sml_aux_same_layout; auto.
  Qed.

  Lemma write_same_layout:
    forall mem1 mem2 ci v, same_memory_layout mem1 mem2 ->
    (is_some (write mem1 ci v) -> is_some (write mem2 ci v)).
  Proof.
    intros * SMT. revert ci v. induction SMT; intros * ISSOME'. auto.

    apply IHSMT. clear IHSMT.
    inversion ISSOME' as [m ISSOME]. clear ISSOME'. clean.
    pose proof (sml_aux_same_layout _ _ H) as SML.

    unfold write in *; no_coerc;
    rewrite SML in *;
    unfold CM.storev in *;
    mymonadInv ISSOME.

    (* write in memory *)
    edestruct (CM.valid_access_store) as [m VAS];[|rewrite VAS; simpl_do; auto].
    destruct H as [H | H]; inv H; mymonadInv H0; simpl in *;
    eauto using CM.store_valid_access_1,
      CM.store_valid_access_2, CM.store_valid_access_3.

    (* write in store *)

    destruct H as [H | H]; inv H; mymonadInv H0; auto.
    dest i0 == i; subst.
    rewrite PTree.gss; simpl_do; auto.
    rewrite PTree.gso; auto; simpl_do; rewrite_Heq_do; auto.

    dest i0 == i; subst; rewrite_Heq_do; auto.
    rewrite PTree.gso in Heq_do1; auto; simpl_do; rewrite_Heq_do; auto.
  Qed.

  Definition read_write mem ci v : option val :=
    do mem' <- write mem ci v;
    read mem' ci.

  (* two memories with same layout are readable at the same locations *)

  Lemma read_same_layout:
    forall mem1 mem2 ci, same_memory_layout mem1 mem2 ->
    is_some (read mem1 ci) -> is_some (read mem2 ci).
  Proof.
    intros * SMT. revert ci.
    induction SMT; intros * ISSOME'; auto.
    pose proof sml_aux_same_layout _ _ H as SML.
    apply IHSMT; clear IHSMT. clear dependent z.
    inversion ISSOME' as [m ISSOME]; clear ISSOME'. clean.
    unfold read in *. no_coerc. rewrite SML in *.
    mymonadInv ISSOME.

    (* write in memory *)
    edestruct (CM.valid_access_load) as [v HREW]; [| rewrite HREW; auto].
    apply CM.load_valid_access in ISSOME.
    destruct H as [H | H]; inv H; mymonadInv H0; simpl in *;
    eauto using CM.store_valid_access_1,
      CM.store_valid_access_2, CM.store_valid_access_3.

    (* write in store *)
    destruct H as [H | H]; inv H; mymonadInv H0; simpl in *; clean;
    dest i0 == i; subst.
    rewrite PTree.gss; auto.
    rewrite PTree.gso; auto.
    rewrite PTree.gss in ISSOME; auto.
    rewrite PTree.gso in ISSOME; auto.
  Qed.

  Lemma rws: forall mem1 mem2 ci v,
    same_memory_layout mem1 mem2 ->
    read_write mem1 ci v = read_write mem2 ci v.
  Proof.
    intros * SMT.
    unfold read_write.
    pose proof (same_layout_same_layout mem1 mem2 SMT) as SML.
    destruct (write mem1 ci v) as [m'|] _eqn; simpl_do.

    assert (is_some (write mem2 ci v)).
      eapply write_same_layout; eauto. auto.
    inversion H as [m'0 ISSOME]; clear H. simpl_do. clean.
    unfold write in*; unfold read in *. no_coerc. rewrite SML in *.
    mymonadInv Heqo; mymonadInv ISSOME; simpl in *. eauto.
    repeat rewrite PTree.gss; auto.

    destruct (write mem2 ci v) as [m'|] _eqn; simpl_do; auto.
    assert (is_some (write mem1 ci v)). symmetry in SMT.
     eapply write_same_layout; eauto. auto.
    inv H; congruence.
  Qed.

  Lemma rwo: forall mem1 mem2 ci1 ci2 v, write mem1 ci1 v = Some mem2 -> ci1 <> ci2 ->
    read mem2 ci2 = read mem1 ci2.
  Proof.
    intros * WRITE NEQ.
    unfold read, write in *.
    mymonadInv WRITE; simpl in *; clean;
    unfold CM.storev, CM.loadv in *; no_coerc;
    prog_dos; try destruct l; try destruct l0; destr_ptrs; simpl_do; eauto;
    destruct mem1; simpl in *;
    destruct layout0; simpl in *;
    specialize (correct_layout0 _ _ _ _ _ _ NEQ Heq_do Heq_do2 Heq_do0 Heq_do3);
    inv correct_layout0;

    try eapply CM.load_store_other; eauto.

    rewrite PTree.gso; auto.

  Qed.

End FromCminorEnv.


(*======================================================================================
  Instruction codec
  ======================================================================================*)
Require Import ssreflect ssrfun seq ssrbool ssrnat fintype.
Add LoadPath "..".
Require Import bitsrep bitsprops bitsops eqtype tuple.
Require Import Coq.Strings.String.
Require Import cast codec bitscodec.
Require Import instr encdechelp reg.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(*---------------------------------------------------------------------------
    Casts for datatypes used in instructions
  ---------------------------------------------------------------------------*)
Definition unSrcR : CAST Reg Src.
apply: MakeCast SrcR (fun s => if s is SrcR r then Some r else None) _.
by elim; congruence. Defined.

Definition unSrcI : CAST DWORD Src.
apply: MakeCast SrcI (fun s => if s is SrcI i then Some i else None) _.
by elim; congruence. Defined.

Definition unRegMemR d : CAST (DWORDorBYTEReg d) (RegMem d).
apply: MakeCast (RegMemR d) (fun rm => if rm is RegMemR r then Some r else None) _.
by elim; congruence. Defined.

Definition unShiftCountCL : CAST unit ShiftCount.
apply: MakeCast (fun _=>ShiftCountCL) (fun c => if c is ShiftCountCL then Some tt else None) _.
elim; congruence.
Defined.

Definition unShiftCountI : CAST BYTE ShiftCount.
apply: MakeCast ShiftCountI (fun c => if c is ShiftCountI b then Some b else None) _.
elim; congruence.
Defined.

Definition unJmpTgtI : CAST Tgt JmpTgt.
apply: MakeCast JmpTgtI (fun t => if t is JmpTgtI d then Some d else None) _.
elim; elim; congruence. Defined.

Definition unJmpTgtRM : CAST (RegMem true) JmpTgt.
apply: (MakeCast (fun (rm:RegMem true) => match rm with RegMemR r => JmpTgtR r | RegMemM m => JmpTgtM m end)
  (fun i => match i with JmpTgtR r => Some (RegMemR true r) | JmpTgtM m => Some (RegMemM true m) | _ => None end) _).
elim => //. move => m. elim => // ms. by move => [<-].
by move => r y [<-].
Defined.

Require Import bitsopsprops.
Definition unTgt : CAST DWORD Tgt.
apply: MakeCast mkTgt
                (fun t => let: mkTgt d := t in Some d) _.
by move => [d] y [<-].
Defined.

Definition unSrcRM : CAST (RegMem true) Src.
apply: MakeCast
  (fun (rm: RegMem true) => match rm with RegMemR r => SrcR r | RegMemM m => SrcM m end)
  (fun i => match i with SrcR r => Some (RegMemR true r) | SrcM m => Some (RegMemM _ m)
                       | _ => None
            end) _.
elim => //; by move => ? ? [<-]. Defined.

(*---------------------------------------------------------------------------
    Casts and codecs for bit-encoded types e.g. registers, scales, conditions
  ---------------------------------------------------------------------------*)
Definition regCast : CAST (BITS 3) Reg.
apply: MakeCast (fun x => decReg x) (fun x => Some (encReg x)) _.
move => x y [<-]; by rewrite encRegK. Defined.
Definition regCodec   : Codec Reg   := bitsCodec 3 ~~> regCast.

Definition opCast : CAST (BITS 3) BinOp.
apply: MakeCast (fun x => decBinOp x) (fun x => Some (encBinOp x)) _.
move => x y [<-]; by rewrite encBinOpK. Defined.
Definition opCodec    : Codec BinOp   := bitsCodec 3 ~~> opCast.

Definition shiftOpCast : CAST (BITS 3) ShiftOp.
apply: MakeCast (fun x => decShiftOp x) (fun x => Some (encShiftOp x)) _.
move => x y [<-]; by rewrite encShiftOpK. Defined.
Definition shiftOpCodec : Codec ShiftOp   := bitsCodec 3 ~~> shiftOpCast.

Definition bitOpCast : CAST (BITS 2) BitOp.
apply: MakeCast (fun x => decBitOp x) (fun x => Some (encBitOp x)) _.
move => x y [<-]; by rewrite encBitOpK. Defined.
Definition bitOpCodec : Codec BitOp   := bitsCodec 2 ~~> bitOpCast.

Definition optionalNonSPregCast : CAST (BITS 3) (option NonSPReg).
apply: MakeCast (fun (x: BITS 3) => decNonSPReg x) (fun x =>
  if x is Some r then Some (encNonSPReg r) else Some #b"100") _.
elim => //.
+ move => x y [<-]. by rewrite encNonSPRegK.
+ by move => y [<-]. Defined.
Definition optionalNonSPRegCodec : Codec (option NonSPReg) :=
  bitsCodec 3 ~~> optionalNonSPregCast.

Definition nonSPregCast : CAST (BITS 3) NonSPReg.
apply: MakeCast (fun x => if decNonSPReg x is Some y then y else EAX)
                (fun y => Some (encNonSPReg y)) _.
move => x y [<-]. by rewrite encNonSPRegK. Defined.

Definition nonBPnonSPRegCodec : Codec NonSPReg :=
    #b"000" .$ always EAX
||| #b"001" .$ always ECX
||| #b"010" .$ always EDX
||| #b"011" .$ always EBX
||| #b"110" .$ always ESI
||| #b"111" .$ always EDI.

Definition nonSPRegCodec : Codec NonSPReg :=
    nonBPnonSPRegCodec
||| #b"101" .$ always EBP.

Definition byteRegCast : CAST (BITS 3) BYTEReg.
apply: MakeCast (fun x => decBYTEReg x) (fun x => Some (encBYTEReg x)) _.
move => x y [<-]; by rewrite encBYTERegK. Defined.
Definition byteRegCodec : Codec BYTEReg := bitsCodec 3 ~~> byteRegCast.

Definition dwordorbyteRegCodec dword : Codec (DWORDorBYTEReg dword) :=
  if dword as dword return Codec (DWORDorBYTEReg dword)
  then regCodec
  else byteRegCodec.

Definition scaleCast : CAST (BITS 2) Scale.
apply: MakeCast decScale (fun x => Some (encScale x)) _.
move => x y [<-]; by rewrite encScaleK. Defined.
Definition scaleCodec : Codec Scale := bitsCodec 2 ~~> scaleCast.

Definition conditionCast : CAST (BITS 3) Condition.
apply: MakeCast decCondition (fun x => Some (encCondition x)) _.
move => x y [<-]; by rewrite encConditionK. Defined.
Definition conditionCodec : Codec Condition := bitsCodec 3 ~~> conditionCast.

Hint Rewrite domConstSeq domSeq domCast domAlt domEmp domSym domAny : dom.

Lemma totalScale : total scaleCodec. Proof. apply totalCast => //. apply totalBITS. Qed.
Lemma totalReg : total regCodec. Proof. apply totalCast => //. apply totalBITS. Qed.
Lemma totaloptionalNonSPReg : total optionalNonSPRegCodec. Proof. apply totalCast => //.
apply totalBITS. case => //. Qed.
Lemma totalOp : total opCodec. Proof. apply totalCast => //. apply totalBITS. Qed.
Lemma totalShiftOp : total shiftOpCodec. Proof. apply totalCast => //. apply totalBITS. Qed.
Lemma totalbyteReg : total byteRegCodec. Proof. apply totalCast => //. apply totalBITS. Qed.
Lemma totaldwordorbyteReg d : total (dwordorbyteRegCodec d).
Proof. destruct d. apply totalReg. apply totalbyteReg. Qed.

Definition SIB := (Reg * option (NonSPReg * Scale))%type.

Definition SIBCast : CAST (Scale * option NonSPReg * Reg) SIB.
apply: MakeCast (fun p => let: (sc,o,r) := p
                 in (r, if o is Some ix then Some(ix,sc) else None))
                (fun p => let: (base, o) := p
                 in if o is Some(ix,sc) then Some(sc, Some ix, base)
                                        else Some(S1, None, base)) _.
move => [r' o'] [[sc o] r].
case: o' => //.
+ by move => [? ?] [-> <- ->].
+ by move => [<- <- <-].
Defined.

Definition SIBCodec : Codec SIB := scaleCodec $ optionalNonSPRegCodec $ regCodec ~~> SIBCast.

Lemma totalSIB : total SIBCodec.
Proof. rewrite /SIBCodec. apply totalCast. apply totalSeq. apply totalSeq.
apply totalScale. apply totaloptionalNonSPReg. apply totalReg.
rewrite /castIsTotal.  move => [r o]. destruct o => //. by destruct p.
Qed.

Definition dispOffsetSIBCast dword : CAST (SIB * DWORD) (RegMem dword).
apply: MakeCast (fun p => RegMemM dword (mkMemSpec (Some p.1) p.2))
  (fun rm => if rm is RegMemM (mkMemSpec (Some sib) offset) then Some(sib,offset) else None) _.
elim => //. elim => //. elim => //. move => [x y] z [x' y']. by move => [-> ->]. Defined.

Definition dispOffsetCast dword : CAST (NonSPReg * DWORD) (RegMem dword).
apply: (MakeCast (fun p => RegMemM dword (mkMemSpec (Some (nonSPReg p.1,None)) p.2))
  (fun rm => if rm is RegMemM (mkMemSpec (Some (nonSPReg base,None)) offset) then Some(base,offset) else None) _).
elim => //. elim => //. elim => //. move => [x y] z [x' y'].
case: x => // r. case: y => //. by move => [-> ->]. Defined.

Definition dispOffsetNoBaseCast dword : CAST DWORD (RegMem dword).
apply: MakeCast (fun offset => RegMemM dword (mkMemSpec None offset))
                (fun rm => if rm is RegMemM (mkMemSpec None offset)
                           then Some offset else None) _.
elim => //. elim => //. by elim => // ? ? [->]. Defined.

Definition RegMemCodec T (regOrOpcodeCodec : Codec T) dword : Codec (T * RegMem dword) :=
    #b"00" .$ regOrOpcodeCodec $ SIBRM .$ (SIBCodec $ always #0 ~~> dispOffsetSIBCast dword)
||| #b"00" .$ regOrOpcodeCodec $ (nonBPnonSPRegCodec $ always #0 ~~> dispOffsetCast dword)
||| #b"00" .$ regOrOpcodeCodec $ (#b"101" .$ DWORDCodec ~~> dispOffsetNoBaseCast dword)
||| #b"01" .$ regOrOpcodeCodec $ SIBRM .$ (SIBCodec $ shortDWORDCodec ~~> dispOffsetSIBCast dword)
||| #b"01" .$ regOrOpcodeCodec $ (nonSPRegCodec $ shortDWORDCodec ~~> dispOffsetCast dword)
||| #b"10" .$ regOrOpcodeCodec $ (SIBRM .$ SIBCodec $ DWORDCodec ~~> dispOffsetSIBCast dword)
||| #b"10" .$ regOrOpcodeCodec $ (nonSPRegCodec $ DWORDCodec ~~> dispOffsetCast dword)
||| #b"11" .$ regOrOpcodeCodec $ (dwordorbyteRegCodec dword ~~> unRegMemR dword).

(*
Lemma totalRegMemCodec T (c: Codec T) d : total c -> total (RegMemCodec c d).
Proof. move => tc. rewrite /total/RegMemCodec.
autorewrite with dom.
move => [x rm].
destruct rm.
(* Register *)
simpl. by rewrite totaldwordorbyteReg tc.
(* MemSpec *)
destruct ms.
case sib => [[base optix] |].
(* Has a SIB *)
+ case: optix => [[index sc] |].
  - simpl.
    rewrite /SIBCodec.
    case E: (offset == #0). rewrite (eqP E)/=. rewrite tc/=.
    destruct base; autorewrite with dom; simpl;
      by rewrite totalScale totaloptionalNonSPReg totalReg/=.
    destruct base; autorewrite with dom; simpl.
      rewrite totalScale totaloptionalNonSPReg totalDWORD totalReg tc /=.
      by rewrite !orbT !orbF.
    rewrite totalScale totaloptionalNonSPReg totalReg totalDWORD tc/=.
      by rewrite !orbT !orbF.
simpl.
simpl. rewrite totalDWORD/=. rewrite /SIBCodec.
autorewrite with dom. simpl.
case E: (offset == #0). simpl. by rewrite tc totalReg.
rewrite tc totalReg. simpl. by rewrite !orbT !orbF.
case E: (offset == #0). simpl. by rewrite tc totalDWORD.
(* Has no SIB  *)
by rewrite /= tc totalDWORD.
Qed.
*)

Definition RegMemOpCodec (op: BITS 3) dword :=
  RegMemCodec (Const op) dword ~~> sndUnitCast _.

Definition RegMemOpDepCodec (op: BITS 3) :=
  BoolDep (fun d => RegMemCodec (Const op) d ~~> sndUnitCast _).

Definition unDstSrcRMR d : CAST (DWORDorBYTEReg d * RegMem d) (DstSrc d).
apply: (MakeCast
       (fun p => match p.2 with RegMemR y => DstSrcRR d p.1 y
                              | RegMemM y => DstSrcRM d p.1 y end)
       (fun ds => match ds with DstSrcRR x y => Some (x,RegMemR _ y)
                              | DstSrcRM x y => Some (x,RegMemM _ y)
                              | _ => None end) _).
by elim => // ? ? [? ?] [<-] <-. Defined.

Definition unDstSrcMRR d : CAST (DWORDorBYTEReg d * RegMem d) (DstSrc d).
apply: (MakeCast
       (fun p => match p.2 with RegMemR y => DstSrcRR d y p.1
                              | RegMemM y => DstSrcMR d y p.1 end)
       (fun ds => match ds with DstSrcRR x y => Some (y, RegMemR _ x)
                              | DstSrcMR x y => Some (y, RegMemM _ x)
                              | _ => None end) _).
by elim => // ? ? [? ?] [<-] <-. Defined.

Definition unDstSrcMRI d : CAST (RegMem d * DWORDorBYTE d) (DstSrc d).
apply: (MakeCast
       (fun p => match p.1 with RegMemR y => (DstSrcRI d y p.2)
                             | RegMemM y => (DstSrcMI d y p.2) end)
       (fun ds => match ds with DstSrcRI x y => Some (RegMemR _ x, y)
                              | DstSrcMI x y => Some (RegMemM _ x, y)
                              | _ => None end) _).
move => ds [rm c].
elim: ds => //. by move => ? ? [<- ->]. by move => ? ? [<- ->]. Defined.

(*---------------------------------------------------------------------------
    Casts for instructions
  ---------------------------------------------------------------------------*)
Definition unPUSH : CAST Src Instr.
apply: MakeCast PUSH (fun i => if i is PUSH s then Some s else None) _.
by elim; congruence. Defined.

Definition unINCD : CAST (RegMem true) Instr.
apply: MakeCast (UOP true OP_INC)
                (fun i => if i is UOP true OP_INC rm then Some rm else None) _.
elim => //. elim => //. elim => //. by move => ? ? [->]. Defined.

Definition unDECD : CAST (RegMem true) Instr.
apply: MakeCast (UOP true OP_DEC)
                (fun i => if i is UOP true OP_DEC rm then Some rm else None) _.
elim => //. elim => //. elim => //. by move => ? ? [->]. Defined.

Definition unPOP : CAST (RegMem true) Instr.
apply: MakeCast POP (fun i => if i is POP d then Some d else None) _.
elim => //. by move => d rm [->]. Defined.

Definition unINC : CAST {d:bool & RegMem d} Instr.
apply: (MakeCast (fun (p:{d:bool & RegMem d}) => let: existT d v := p in UOP d OP_INC v)
                 (fun i => if i is UOP d OP_INC v then Some (existT _ d v) else None) _).
elim => //. elim => op src [y z]; destruct op => // [H]; by inversion H. Defined.

Definition unDEC : CAST {d:bool & RegMem d} Instr.
apply: (MakeCast (fun (p:{d:bool & RegMem d}) => let: existT d v := p in UOP d OP_DEC v)
                 (fun i => if i is UOP d OP_DEC v then Some (existT _ d v) else None) _).
elim => //. elim => op src [y z]; destruct op => // [H]; by inversion H. Defined.

Definition unNOT : CAST {d:bool & RegMem d} Instr.
apply: (MakeCast (fun (p:{d:bool & RegMem d}) => let: existT d v := p in UOP d OP_NOT v)
                 (fun i => if i is UOP d OP_NOT v then Some (existT _ d v) else None) _).
elim => //. elim => op src [y z]; destruct op => // [H]; by inversion H. Defined.

Definition unNEG : CAST {d:bool & RegMem d} Instr.
apply: (MakeCast (fun (p:{d:bool & RegMem d}) => let: existT d v := p in UOP d OP_NEG v)
                 (fun i => if i is UOP d OP_NEG v then Some (existT _ d v) else None) _).
elim => //. elim => op src [y z]; destruct op => // [H]; by inversion H. Defined.

Definition unIMUL : CAST (Reg * RegMem true) Instr.
apply: (MakeCast (fun p => IMUL p.1 p.2)
                 (fun i => if i is IMUL dst src then Some (dst,src) else None) _).
elim => //. by move => dst src [dst' src'] [<-] ->.  Defined.

Definition unIN : CAST (bool*BYTE) Instr.
apply: MakeCast (fun p => IN p.1 p.2) (fun i => if i is IN d p then Some(d,p) else None) _.
by elim => // ? ? [? ?] [-> ->]. Defined.

Definition unOUT : CAST (bool*BYTE) Instr.
apply: MakeCast (fun p => OUT p.1 p.2) (fun i => if i is OUT d p then Some(d,p) else None) _.
by elim => // ? ?  [? ?] [-> ->]. Defined.

Definition unLEA : CAST (Reg * RegMem true) Instr.
apply: MakeCast (fun p => LEA p.1 p.2) (fun i => if i is LEA x y then Some(x,y) else None) _.
by elim => // ? ? [? ?] [-> ->]. Defined.

Definition unXCHG : CAST (DWORDorBYTEReg true * RegMem true) Instr.
apply: MakeCast (fun p => XCHG true p.1 p.2) (fun i => if i is XCHG true x y then Some(x,y) else None) _.
elim => //. elim => //. by move => r s [r' s'] [<-] ->. Defined.

Definition unXCHGB : CAST (DWORDorBYTEReg false * RegMem false) Instr.
apply: MakeCast (fun p => XCHG false p.1 p.2) (fun i => if i is XCHG false x y then Some(x,y) else None) _.
elim => //. elim => //. by move => r s [r' s'] [<-] ->. Defined.

Definition unMUL : CAST {d:bool & RegMem d} Instr.
apply: (MakeCast (fun (p:{d:bool & RegMem d}) => let: existT d v := p in MUL v)
                 (fun i => if i is MUL d v then Some (existT _ d v) else None) _).
elim => //. elim => src [y z] [H] H'; by inversion H'.
Defined.

Definition unRET : CAST WORD Instr.
apply: MakeCast RETOP (fun i => if i is RETOP w then Some w else None) _.
elim; congruence. Defined.

Definition unJMP : CAST JmpTgt Instr.
apply: MakeCast JMPrel (fun i => if i is JMPrel t then Some t else None) _.
elim; congruence. Defined.

Definition unCALL : CAST JmpTgt Instr.
apply: MakeCast CALLrel (fun i => if i is CALLrel t then Some t else None) _.
elim; congruence. Defined.

Definition isCMC : CAST unit Instr.
apply: MakeCast (fun _ => CMC) (fun i => if i is CMC then Some tt else None) _; by elim; elim.
Defined.

Definition isCLC : CAST unit Instr.
apply: MakeCast (fun _ => CLC) (fun i => if i is CLC then Some tt else None) _; by elim; elim.
Defined.

Definition isSTC : CAST unit Instr.
apply: MakeCast (fun _ => STC) (fun i => if i is STC then Some tt else None) _; by elim; elim.
Defined.

Definition isHLT : CAST unit Instr.
apply: MakeCast (fun _ => HLT) (fun i => if i is HLT then Some tt else None) _; by elim; elim.
Defined.

Definition unBOP : CAST (BinOp * {d:bool & DstSrc d}) Instr.
apply: (MakeCast (fun (p:BinOp * {d:bool & DstSrc d}) => let: existT d v := p.2 in BOP d p.1 v)
                 (fun i => if i is BOP d op v then Some (op, existT _ d v) else None) _).
elim => //. elim => op src [op' [y z]] [->] H' H; by inversion H. Defined.

Require Import Coq.Program.Equality.
Definition unBOPMRI : CAST ({d:bool & (BinOp * RegMem d * DWORDorBYTE d)%type}) Instr.
apply: (MakeCast (fun (p:{d:bool & (BinOp * RegMem d * DWORDorBYTE d)%type}) =>
  let: existT d (op,rm,c) := p in
    match rm with RegMemR y => BOP d op (DstSrcRI d y c)
                | RegMemM y => BOP d op (DstSrcMI d y c) end)
                 (fun i =>
                  match i with BOP d op (DstSrcRI y c) => Some (existT _ d (op,RegMemR _ y,c))
                             | BOP d op (DstSrcMI y c) => Some (existT _ d (op,RegMemM _ y,c))
                             | _ => None end) _).
elim => //.
move => d.
move => op.
elim => //.
+ move => dst c [d' [[op' rm] c']]. move => [H1 H2 H3 H4]. subst.
by dependent destruction H4.
+ move => dst c [d' [[op' rm] c']]. move => [H1 H2 H3 H4]. subst.
by dependent destruction H4.
Defined.

Definition BOPCodecRMR : Codec {d: bool & DstSrc d} :=
  BoolDep (fun d =>
    RegMemCodec (dwordorbyteRegCodec d) d ~~> unDstSrcRMR d).
Definition BOPCodecMRR : Codec {d: bool & DstSrc d} :=
  BoolDep (fun d =>
    RegMemCodec (dwordorbyteRegCodec d) d ~~> unDstSrcMRR d).

Definition MOVCodecMRI : Codec {d: bool & DstSrc d} :=
  BoolDep (fun d =>
    RegMemOpCodec #0 d $ DWORDorBYTECodec d ~~> unDstSrcMRI d).

Definition BOPCodecMRI : Codec Instr :=
  BoolDep (fun d =>
    RegMemCodec opCodec d $ DWORDorBYTECodec d) ~~> unBOPMRI.

Definition unMOVZX : CAST (Reg * RegMem true) Instr.
apply: MakeCast (fun p => MOVX false true p.1 p.2) (fun i => if i is MOVX false true x y then Some(x,y) else None) _.
elim => //. elim => //. elim => //. by move => ? ? [? ?] [-> ->]. Defined.

Definition unMOVZXB : CAST (Reg * RegMem false) Instr.
apply: MakeCast (fun p => MOVX false false p.1 p.2) (fun i => if i is MOVX false false x y then Some(x,y) else None) _.
elim => //. elim => //. elim => //. by move => ? ? [? ?] [-> ->]. Defined.

Definition unMOVSX : CAST (Reg * RegMem true) Instr.
apply: MakeCast (fun p => MOVX true true p.1 p.2) (fun i => if i is MOVX true true x y then Some(x,y) else None) _.
elim => //. elim => //. elim => //. by move => ? ? [? ?] [-> ->]. Defined.

Definition unMOVSXB : CAST (Reg * RegMem false) Instr.
apply: MakeCast (fun p => MOVX true false p.1 p.2) (fun i => if i is MOVX true false x y then Some(x,y) else None) _.
elim => //. elim => //. elim => //. by move => ? ? [? ?] [-> ->]. Defined.

Definition unMOV : CAST ({d:bool & DstSrc d}) Instr.
apply: (MakeCast (fun (p:{d:bool & DstSrc d}) => let: existT d v := p in MOVOP d v)
                 (fun i => if i is MOVOP d v then Some (existT _ d v) else None) _).
elim => // d ds [y z] H. by inversion H. Defined.

Definition unMOVRI : CAST (Reg*DWORD) Instr.
apply: (MakeCast
  (fun p => MOVOP true (DstSrcRI _ p.1 p.2)) (fun i => if i is MOVOP true (DstSrcRI r d) then Some (r,d) else None) _).
elim => //. elim => //. elim => //. by move => ? ? [? ?] [-> ->].
Defined.

Definition unSHIFT : CAST ({d:bool & (ShiftOp * RegMem d)%type} * ShiftCount) Instr.
apply: (MakeCast (fun (p:{d:bool & (ShiftOp * RegMem d)%type} * ShiftCount) =>
                  let: (existT d (op, v), count) := p in SHIFTOP d op v count)
                 (fun i => if i is SHIFTOP d op v count then Some (existT _ d (op,v), count) else None) _).
elim => //. move => d op dst count [c count']. move => [H1 H2]. by subst.
Defined.

Definition unJCC : CAST (Condition*bool*Tgt) Instr.
apply: MakeCast (fun p => let: (c,d,t) := p in JCCrel c (negb d) t)
                (fun i => if i is JCCrel c d t then Some(c,negb d,t) else None) _.
Proof. elim => //. move => cc cv tgt [[cc' cv'] tgt']. move => [-> <- ->].
by rewrite negbK. Defined.

Definition TgtCodec : Codec Tgt := DWORDCodec ~~> unTgt.
Definition ShortTgtCodec : Codec Tgt := shortDWORDCodec ~~> unTgt.

Definition unTESTOP : CAST (Reg * RegMem true) Instr.
apply: (MakeCast (fun p => TESTOP true p.2 (RegImmR true p.1))
                (fun i => if i is TESTOP true y (RegImmR x) then Some(x,y) else None) _).
elim => //. elim => //. move => dst src [dst' src']. case src => // r. by move => [-> ->].
Defined.

Definition unTESTOPB : CAST (BYTEReg * RegMem false) Instr.
apply: (MakeCast (fun p => TESTOP false p.2 (RegImmR false p.1))
                (fun i => if i is TESTOP false y (RegImmR x) then Some(x,y) else None) _).
elim => //. elim => //. move => dst src [dst' src']. case src => // r. by move => [-> ->].
Defined.

Definition unTESTOPI : CAST (RegMem true * DWORD) Instr.
apply: (MakeCast (fun p => TESTOP true p.1 (RegImmI true p.2))
                (fun i => if i is TESTOP true x (RegImmI d) then Some(x,d) else None) _).
elim => //. elim => //. move => dst src [dst' src']. case src => // r. by move => [-> ->].
Defined.

Definition unTESTOPBI : CAST (RegMem false * BYTE) Instr.
apply: (MakeCast (fun p => TESTOP false p.1 (RegImmI false p.2))
                (fun i => if i is TESTOP false x (RegImmI d) then Some(x,d) else None) _).
elim => //. elim => //. move => dst src [dst' src']. case src => // r. by move => [-> ->].
Defined.

Definition unBITOPR : CAST (BitOp * (Reg * RegMem true)) Instr.
apply: (MakeCast (fun p => let: (op,(r,rm)) := p in BITOP op rm (inl r))
                (fun i => if i is BITOP op y (inl r) then Some(op,(r,y)) else None) _).
elim => //. move => op dst src [op' [dst' src']]. case src => // r. by move => [-> -> ->].
Defined.

Definition unBITOPI : CAST (BitOp * RegMem true * BYTE) Instr.
apply: (MakeCast (fun p => let: (op,rm,b) := p in BITOP op rm (inr b))
                (fun i => if i is BITOP op y (inr b) then Some(op,y,b) else None) _).
elim => //. move => op dst src [[op' dst'] src']. case src => // r. by move => [-> -> ->].
Defined.

Definition unEAXimm : CAST (DWORDorBYTE true) (DstSrc true).
apply: (MakeCast
       (fun c => DstSrcRI true EAX c)
       (fun ds => if ds is DstSrcRI EAX y then Some y else None) _).
elim => //. elim => //. elim => //. by move => c y [->]. Defined.

Definition unALimm : CAST (DWORDorBYTE false) (DstSrc false).
apply: (MakeCast
       (fun c => DstSrcRI false AL c)
       (fun ds => if ds is DstSrcRI AL y then Some y else None) _).
elim => //. elim => //. by move => c y [->].
Defined.

Definition EAXimmCodec : Codec {d: bool & DstSrc d} :=
  BoolDep (fun d => DWORDorBYTECodec d ~~> if d then unEAXimm else unALimm).

Definition unBOPMRId : CAST (BinOp * RegMem true * DWORD) Instr.
apply: (MakeCast (fun (p:BinOp * RegMem true * DWORD) =>
  let: (op,rm,c) := p in
    match rm with RegMemR y => BOP true op (DstSrcRI true y c)
                | RegMemM y => BOP true op (DstSrcMI true y c) end)
                 (fun i =>
                  match i with BOP true op (DstSrcRI y c) => Some (op,RegMemR _ y,c)
                             | BOP true op (DstSrcMI y c) => Some (op,RegMemM _ y,c)
                             | _ => None end) _).
elim => //.
elim => //.
move => op.
elim => //.
+ move => dst c [[op' rm] c']. move => [H2 H3 H4]. by subst.
+ move => dst c [[op' rm] c']. move => [H2 H3 H4]. by subst.
Defined.

Definition InstrCodec : Codec Instr :=
(* Unary operations *)
    droplsb #x"FE" .$ RegMemOpDepCodec #0 ~~> unINC
||| droplsb #x"FE" .$ RegMemOpDepCodec #1 ~~> unDEC
||| droplsb #x"F6" .$ RegMemOpDepCodec #2 ~~> unNOT
||| droplsb #x"F6" .$ RegMemOpDepCodec #3 ~~> unNEG
||| INCPREF .$ regCodec ~~> unRegMemR true ~~> unINCD
||| DECPREF .$ regCodec ~~> unRegMemR true ~~> unDECD
(* Binary operations *)
||| #b"00" .$ opCodec $ #b"10" .$ EAXimmCodec ~~> unBOP
||| #b"00" .$ opCodec $ #b"00" .$ BOPCodecMRR ~~> unBOP
||| #b"00" .$ opCodec $ #b"01" .$ BOPCodecRMR ~~> unBOP
||| droplsb #x"80" .$ BOPCodecMRI
||| #x"83" .$ RegMemCodec opCodec true $ shortDWORDCodec ~~> unBOPMRId
(* MOV operationsl *)
||| droplsb #x"8A" .$ BOPCodecRMR ~~> unMOV
||| droplsb #x"88" .$ BOPCodecMRR ~~> unMOV
||| MOVIMMPREF .$ regCodec $ DWORDCodec ~~> unMOVRI
||| droplsb #x"C6" .$ MOVCodecMRI ~~> unMOV
(* IMUL and MUL *)
||| #x"0F" .$ #x"AF" .$ RegMemCodec regCodec _ ~~> unIMUL
||| droplsb #x"F6" .$ RegMemOpDepCodec #4 ~~> unMUL
(* IN and OUT *)
||| droplsb #x"E4" .$ Any $ BYTECodec ~~> unIN
||| droplsb #x"E6" .$ Any $ BYTECodec ~~> unOUT
(* LEA *)
||| #x"8D" .$ RegMemCodec regCodec _ ~~> unLEA
(* XCHG *)
||| #b"10010" .$ always (EAX:Reg) $ (regCodec ~~> unRegMemR true) ~~> unXCHG
||| #x"86" .$ RegMemCodec byteRegCodec _ ~~> unXCHGB
||| #x"87" .$ RegMemCodec regCodec _ ~~> unXCHG
(* PUSH *)
||| #x"68" .$ DWORDCodec ~~> unSrcI ~~> unPUSH
||| #x"6A" .$ shortDWORDCodec ~~> unSrcI ~~> unPUSH
||| #b"01010" .$ regCodec ~~> unSrcR ~~> unPUSH
||| #x"FF" .$ RegMemOpCodec #6 _ ~~> unSrcRM ~~> unPUSH
(* POP *)
||| #x"8F" .$ RegMemOpCodec #0 _ ~~> unPOP
||| #b"01011" .$ regCodec ~~> unRegMemR true ~~> unPOP
(* RET *)
||| #x"C3" .$ always #0 ~~> unRET
||| #x"C2" .$ WORDCodec ~~> unRET
(* Nullary operations *)
||| #x"F4" ~~> isHLT
||| #x"F5" ~~> isCMC
||| #x"F8" ~~> isCLC
||| #x"F9" ~~> isSTC
(* MOVX *)
||| #x"0F" .$ #x"B6" .$ RegMemCodec regCodec false ~~> unMOVZXB
||| #x"0F" .$ #x"B7" .$ RegMemCodec regCodec true ~~> unMOVZX
||| #x"0F" .$ #x"BE" .$ RegMemCodec regCodec false ~~> unMOVSXB
||| #x"0F" .$ #x"BF" .$ RegMemCodec regCodec true ~~> unMOVSX
(* SHIFTOP *)
||| droplsb #x"C0" .$ (BoolDep (RegMemCodec shiftOpCodec)) $ (BYTECodec ~~> unShiftCountI) ~~> unSHIFT
||| droplsb #x"D0" .$ (BoolDep (RegMemCodec shiftOpCodec)) $ (always #1 ~~> unShiftCountI) ~~> unSHIFT
||| droplsb #x"D2" .$ (BoolDep (RegMemCodec shiftOpCodec)) $ (Emp ~~> unShiftCountCL) ~~> unSHIFT
(* BITOP *)
||| #x"0F" .$ BITOPPREF .$ bitOpCodec $ BITOPSUFF .$ (RegMemCodec regCodec true) ~~> unBITOPR
||| #x"0F" .$ #x"BA" .$ RegMemCodec (#b"1" .$ bitOpCodec) true $ BYTECodec ~~> unBITOPI
(* TESTOP *)
||| #x"A8" .$ (always AL ~~> unRegMemR false) $ BYTECodec ~~> unTESTOPBI
||| #x"A9" .$ (always (EAX:Reg) ~~> unRegMemR true) $ DWORDCodec ~~> unTESTOPI
||| #x"F6" .$ RegMemOpCodec #0 false $ BYTECodec ~~> unTESTOPBI
||| #x"F7" .$ RegMemOpCodec #0 true $ DWORDCodec ~~> unTESTOPI
||| #x"84" .$ RegMemCodec byteRegCodec false ~~> unTESTOPB
||| #x"85" .$ RegMemCodec regCodec true ~~> unTESTOP
(* JMP *)
||| #x"E9" .$ DWORDCodec ~~> unTgt ~~> unJmpTgtI ~~> unJMP
||| #x"EB" .$ ShortTgtCodec ~~> unJmpTgtI ~~> unJMP
||| #x"FF" .$ RegMemOpCodec #4 true ~~> unJmpTgtRM ~~> unJMP
(* CALL *)
||| #x"E8" .$ DWORDCodec ~~> unTgt ~~> unJmpTgtI ~~> unCALL
||| #x"FF" .$ RegMemOpCodec #2 true ~~> unJmpTgtRM ~~> unCALL
(* JCC *)
||| #x"0F" .$ JCC32PREF .$ conditionCodec $ Any $ TgtCodec ~~> unJCC
||| JCC8PREF .$ conditionCodec $ Any $ ShortTgtCodec  ~~> unJCC
.

Require Import codecregex div.

(* Various facts about the instruction codec that can be determined statically.
   - it's non-ambiguous
   - the maximum number of bits (currently 88)
   - hence, it's finite
   - the number of bits is always divisible by 8
*)

Lemma InstrCodecIsNonAmbiguous : NonAmbiguous InstrCodec.
Proof. by vm_compute. Qed.

Definition MaxBits := Eval vm_compute in Option.default 0 (maxSize InstrCodec).

Lemma InstrCodecMaxBits : maxSize InstrCodec = Some MaxBits.
Proof. by vm_compute. Qed.

Lemma InstrCodecFinite : finiteCodec InstrCodec.
Proof.  by rewrite /finiteCodec InstrCodecMaxBits. Qed.

Lemma InstrCodecAlignment : forall l x, interp InstrCodec l x -> 8 %| size l.
Proof. move => l x I.
have byteAligned: all (fun x => 8 %| x) (sizes InstrCodec)
  by vm_compute.
apply: sizesProp I. apply: InstrCodecFinite. apply byteAligned. Qed.

Corollary encInstrAligned : forall l x, enc InstrCodec x = Some l -> 8 %| size l.
Proof. move => l x ENC. apply encSound in ENC. by apply: InstrCodecAlignment ENC. Qed.

Require Import bitreader monad cursor.

Corollary InstrCodecRoundtrip l cursor cursor' e x:
  enc InstrCodec x = Some l ->
  apart (size l) cursor cursor' ->
  runBitReader (codecToBitReader MaxBits InstrCodec) cursor (l++e) = Some(cursor', e, Some x).
Proof. move => ENC AP.
have CC := codecToFiniteBitReaderRoundtrip _ _ InstrCodecMaxBits AP ENC.
have CS := codecToBitReaderSound. apply: CC.
apply nonAmbiguousDet. apply InstrCodecIsNonAmbiguous. Qed.

Require Import reader.
Corollary InstrCodecRoundtripReader (pc:DWORD) cursor' bits x:
  enc InstrCodec x = Some bits ->
  apart ((size bits) %/ 8) pc cursor' ->
  8 %| size bits /\
  runReader (bitReaderToReader (codecToBitReader MaxBits InstrCodec) nil) pc
    (fromBin bits).2 = Some(cursor',nil,(nil,Some x)).
Proof. move => ENC AP. have CC := InstrCodecRoundtrip nil ENC.
have ALIGN:=encInstrAligned ENC.
case E: (fromBin bits) => [resbits bytes].
have: toBin bytes = bits /\ resbits = nil.
destruct (size_fromBin E) as [E1 E2].
rewrite (eqP ALIGN) in E1.
destruct resbits => //. split => //.
have H := toBinFromBin E. by rewrite cats0 in H. move => [H1 H2]. subst.
have BRR := @bitReaderToReader_correct _ (codecToBitReader MaxBits InstrCodec)
  bytes nil pc (fromByteCursor cursor') (Some x).
case EC: (fromByteCursor pc) => [p |]//. specialize (CC p (fromByteCursor cursor')).
  have AP': apart (size (toBin bytes)) (fromByteCursor pc) (fromByteCursor cursor').
  have AP1 := apart_widen 3 AP. rewrite divnK in AP1. by apply AP1. done.
  rewrite -EC in CC.
specialize (CC AP'). rewrite cats0 in CC. specialize (BRR CC).
  destruct BRR as [resbytes [resbits' [H3 H4]]].
  split => //. simpl snd. destruct resbits' => //. rewrite H3.
  rewrite /bitCursorAndBitsToByteCursor.
  have H: (toBin resbytes) = nil by destruct (toBin resbytes) => //.
  destruct resbytes => //.
  destruct cursor' => //. by rewrite /fromByteCursor/widenCursor high_catB.
  simpl in H. have SR: (size (rev b)) = 8. by rewrite size_rev size_tuple.
  destruct (rev b) => //.
Qed.

Instance readOptionInstr : Reader (option Instr) :=
  let! (resbits, i) = bitReaderToReader (codecToBitReader MaxBits InstrCodec) nil;
  retn i.

Instance readInstr : Reader Instr :=
  let! pc = readCursor;
  if pc is mkCursor p
  then
    let! r = readOptionInstr;
    if r is Some i then retn i else retn BADINSTR
  else
    retn BADINSTR.

Require Import writer monadinst.
Fixpoint writeBytes (s: seq BYTE) : WriterTm unit :=
  if s is b::rest
  then do! writeNext b; writeBytes rest
  else retn tt.

Instance writeBytesI : Writer (seq BYTE) := writeBytes.

(* NOTE: we don't have a Roundtrip instance for Instr because the
   encoding/decoding don't proceed in lock-step, as required by simrw.
  Instead, we use explicit correctness lemma in programassemcorrect.
*)
Instance encodeInstr : Writer Instr := fun instr =>
  let! pc = getWCursor;
  if pc is mkCursor p then
    if enc InstrCodec instr is Some bs
    then writeNext (fromBin bs).2
    else writerFail
  else writerFail.

Lemma writeBytesSkipFree xs : writerTmSkipFree (writeBytes xs).
Proof. induction xs => //. Qed.

(*
Module Examples.

Require Import instrsyntax. Open Scope instr_scope.
Compute bytesToHex (snd (fromBin (if enc InstrCodec
  (BOP _ OP_ADD (DstSrcMI true (mkMemSpec (Some (nonSPReg EBX, Some(EDX,S4))) (#x"12345678")) (#x"87654321":DWORD))) is Some bs then bs else nil))).

End Examples.
*)


Require Import Bank.

From Verdi Require Import
  Verdi
  HandlerMonad
  LabeledNet.

From InfSeqExt Require Import
  infseq
  classical.

Local Arguments update {_} {_} _ _ _ _ _ : simpl never.

Set Bullet Behavior "Strict Subproofs".

Lemma In_split_not_In :
  forall A (p : A) p' xs ys zs,
    In p (xs ++ p' :: ys) ->
    ~ In p (zs ++ xs ++ ys) ->
    p = p'.
Proof using.
  intros. find_apply_lem_hyp in_app_iff. simpl in *.
  intuition ; find_false ; apply in_app_iff
            ; right ; apply in_app_iff ; auto.
Qed.

Lemma option_eq_dec : forall {T : Type} (T_eq_dec : forall t1 t2 : T, {t1 = t2} + {t1 <> t2}),
  forall l1 l2 : option T, {l1 = l2} + {l1 <> l2}.
Proof.
  repeat decide equality.
Qed.

Definition label_eq_dec :
  forall x y : label,
    {x = y} + {x <> y}.
Proof using.
  decide equality; apply fin_eq_dec.
Qed.

Ltac basic_unfold :=
  repeat ( unfold step_async_init,
                  unlabeled_input_handlers, unlabeled_net_handlers,
                  lb_net_handlers, lb_input_handlers,
                  net_handlers, input_handlers in *
         ; repeat break_let).

Ltac handler_unfold :=
  repeat (monad_unfold; unfold NetHandler, ServerNetHandler, AgentNetHandler,
                               IOHandler, AgentIOHandler, ServerIOHandler in *).

Ltac simplify_bank_handlers :=
  repeat ( basic_unfold ; handler_unfold ; unfold InitState in *
         ; repeat break_match ; simpl in *)
  ; try solve_by_inversion
  ; repeat ( repeat (find_inversion ; intuition)
           ; subst_max ; simpl in * ; intuition)
  ; repeat clean.

Definition initialized_network (net:network) :=
  exists tr, step_async_star step_async_init net tr.

Definition initialized_eventseq (s:infseq (event network label (name * (input + list output)))) :=
  event_step_star step_async step_async_init (hd s) /\
  lb_step_execution lb_step_async s.

Lemma initialized_event_network :
  forall (e:event network label (name * (input + list output))),
    event_step_star step_async step_async_init e ->
    initialized_network (evt_a e).
Proof using.
  intuition. find_apply_lem_hyp refl_trans_1n_n1_trace.
  destruct e. simpl in *.
  prep_induction H. induction H ; intuition ; subst_max.
  - exists []. constructor.
  - unfold initialized_network in *. break_exists.
    exists (x ++ cs'). apply RT1n_step with (y := x') ; intuition.
Qed.

Lemma initialized_eventseq_network :
  forall s,
    initialized_eventseq s ->
    always (now (fun e => initialized_network (evt_a e))) s.
Proof using.
  unfold initialized_eventseq. intuition.
  pose proof (step_async_star_lb_step_execution H0 H1).
  generalize dependent H. clear H0 H1. generalize dependent s.
  cofix c. destruct s. constructor.
  - apply always_now in H. simpl in *. apply initialized_event_network ; intuition.
  - apply c. simpl. apply always_tl in H. simpl in H. apply H.
Qed.

Lemma IOHandler_labels :
  forall n ni s s' l os ms,
    IOHandler n ni s = (l, os, s', ms) ->
    (exists id:ClientId,
      (l = Ready /\ ms = [] /\
                   (s' = s /\ os = [] \/
                    s' = agent fail /\ os = [(netO id Failed)] \/
                    s' = agent wait /\ os = [(netO id Ignore)])) \/
      (exists r : ReqMsg,
        l = Waiting /\ os = [] /\ s' = agent wait /\
                       ms = [(Server, (netM id (req r)))])) \/
    (l = Nop /\ os = [] /\ ms = [] /\ s = s').
Proof using.
  intros. simplify_bank_handlers ; left ; exists c ; intuition
                                 ; right ; eexists ; intuition.
Qed.

Lemma NetHandler_labels :
  forall dst src nm s s' l os ms,
    NetHandler dst src nm s = (l, os, s', ms) ->
    (exists id : ClientId,
      (l = Ready /\ ms = [] /\
                   ((s = s' /\ os = []) \/
                    (s' = agent fail /\ os = [(netO id Failed)]) \/
                    (exists a v,
                      s' = agent pass /\ os = [(netO id (Passed a v))]))) \/
      (exists r : RespMsg,
        l = Processed /\ os = [] /\ ms = [(Agent, netM id (resp r))])) \/
    (l = Nop /\ os = [] /\ ms = [] /\ s = s').
Proof using.
  intros. simplify_bank_handlers ; left ; exists c ;  intuition
                                 ; first ( left ; intuition ; right ; right
                                                ; repeat eexists )
                                 ; right ; repeat eexists.
Qed.

Lemma step_star_consistent_state :
  forall net,
    initialized_network net ->
    (exists astate, nwState net Agent = agent astate) /\
    (exists sstate, nwState net Server = server sstate) /\
    (forall sstate, nwState net Agent <> server sstate) /\
    (forall astate, nwState net Server <> agent astate).
Proof using.
  intros net Hstar. unfold initialized_network in *. break_exists_name tr.
  find_apply_lem_hyp refl_trans_1n_n1_trace.
  prep_induction Hstar. induction Hstar.
  - intuition ; break_exists ; subst_max ; simplify_bank_handlers ; eauto.
  - intuition ; subst_max ; invcs H0 ; simplify_bank_handlers
                ; unfold update ; simpl ; eauto
                ; repeat break_exists ; unfold update in * ; simpl in * ; discriminate.
Qed.

Definition message_enables_label p l :=
  forall net,
    initialized_network net ->
    In p (nwPackets net) ->
    lb_step_ex lb_step_async l net.

Definition message_delivered_label p l :=
  forall l' net net' tr,
    initialized_network net ->
    lb_step_async net l' net' tr ->
    In p (nwPackets net) ->
    ~ In p (nwPackets net') ->
    l = l'.

Lemma messages_trigger_labels :
  forall l p,
    message_enables_label p l ->
    message_delivered_label p l ->
    forall s,
      initialized_eventseq s ->
      In p (nwPackets (evt_a (hd s))) ->
      weak_until (now (enabled lb_step_async l))
                 (now (occurred l))
                 s.
Proof using.
    intros l p Henables Hdelivered. cofix c. intros.
    assert (H' := H). apply initialized_eventseq_network in H.
    destruct s,e. simpl in *. destruct (label_eq_dec l evt_l) ; subst_max.
    - apply W0. easy.
    - apply W_tl ; simpl.
      + apply always_now in H. simpl in H.
        unfold message_enables_label, initialized_network in *.
        unfold enabled. simpl. break_exists. now eauto.
      + apply c ; unfold initialized_eventseq in * ; break_and ; invcs H2 ; intuition.
        * unfold event_step_star in *. unfold bank_multi_params.
          rewrite H6. apply (step_async_star_lb_step_reachable H1 H5).
        * destruct (In_dec packet_eq_dec
                           p (nwPackets (LabeledNet.evt_a e'))) ; intuition.
          unfold message_delivered_label, message_enables_label in *.
          apply always_now in H. simpl in H. intuition.
          pose proof (Hdelivered evt_l evt_a (LabeledNet.evt_a e') tr). intuition.
Admitted. (* WHY??!! ... *)

Lemma message_labels_eventually_occur :
  forall l p,
    l <> label_silent ->
    message_enables_label p l ->
    message_delivered_label p l ->
    forall s,
      initialized_eventseq s ->
      weak_fairness lb_step_async label_silent s ->
      lb_step_execution lb_step_async s ->
      In p (nwPackets (evt_a (hd s))) ->
      eventually (now (occurred l)) s.
Proof using.
    intros.
    find_eapply_lem_hyp messages_trigger_labels ; eauto.
    find_apply_lem_hyp weak_until_until_or_always.
    intuition.
    - now eauto using until_eventually.
    - find_apply_lem_hyp always_continuously.
      eapply_prop_hyp weak_fairness continuously; auto.
      destruct s. now find_apply_lem_hyp always_now.
Qed.


Require Import Coq.Arith.Peano_dec.
Require Import Coq.Structures.OrderedType.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Sets.Ensembles.
Require Import Ascii.
Require Import Coq.ZArith.Znat.
Require Import Coq.Program.Equality.

Add LoadPath "." as Top0.
Require Import Top0.Tactics.
Require Import Top0.Keys.
Require Import Top0.Definitions.
Require Import Top0.Nameless.
Require Import Top0.CorrectnessLemmas.
Require Import Top0.AdditionalLemmas.
Require Import Top0.Environment.
Require Import Top0.Heap.
Require Import Top0.Determinism.
Require Import Top0.Axioms.

Require Import Omega.

Module TypeSoundness.

  Import Heap.
  Import Environment.

Module RMapOrdProp := FMapFacts.OrdProperties R.

Lemma subst_rho_open_close_rgn :
  forall rho n w v' rho' r r0 x,
    lc_type_rgn r0 ->
    find_R w rho = Some v' ->
    fold_subst_rgn rho r = fold_subst_rgn rho' (closing_rgn_in_rgn2 n x r0) ->
    fold_subst_rgn rho' (opening_rgn_in_rgn2 n (Rgn2_Const true true v') (closing_rgn_in_rgn2 n x r0)) =
    fold_subst_rgn rho (opening_rgn_in_rgn2 n (mk_rgn_type w) r).
Proof.
  intros rho n w v' rho' r r0 x Hlc1 HF H.
  unfold rgn2_in_typ in r.
  unfold rgn2_in_typ in r0.
  unfold rgn2_in_exp in w.
  dependent induction r; dependent induction Hlc1; simpl in *.
  - repeat rewrite subst_rho_rgn_const in *. auto.
  - destruct (RMapP.eq_dec r0 x); subst; simpl in *.
    + rewrite subst_rho_index in H. rewrite subst_rho_rgn_const in H. inversion H.
    + auto.
  - auto.
  - destruct (RMapP.eq_dec r x); subst; simpl in *.
    + rewrite subst_rho_index in H.
      destruct (subst_rho_fvar_1 rho n0) as [[v H0] | H0];
      rewrite H0 in H; inversion H.
    + auto.
  - rewrite subst_rho_index in H. rewrite subst_rho_rgn_const in H. inversion H.
  - destruct (RMapP.eq_dec r x); subst; simpl in *.
    + repeat rewrite subst_rho_index in H. inversion H; subst.
      rewrite NPeano.Nat.eqb_refl.
      rewrite subst_rho_rgn_const.
      dependent induction w; simpl.
      * inversion HF; subst.
        rewrite subst_rho_rgn_const.
        reflexivity.
      * inversion HF. symmetry.
        apply subst_rho_fvar_2. now simpl.
    + rewrite subst_rho_index in H.
      destruct (subst_rho_fvar_1 rho' r) as [[v H0] | H0];
      rewrite H0 in H; inversion H.
Qed.

Lemma subst_rho_open_close_sa:
  forall rho n w v' rho' sa sa1 x,
    lc_type_sa sa ->
    find_R w rho = Some v' ->
    fold_subst_sa rho sa1 = fold_subst_sa rho' (closing_rgn_in_sa2 n x sa) ->
    fold_subst_sa rho' (opening_rgn_in_sa2 n (Rgn2_Const true true v') (closing_rgn_in_sa2 n x sa)) =
    fold_subst_sa rho (opening_rgn_in_sa2 n (mk_rgn_type w) sa1).
Proof.
  intros rho n w v' rho' sa sa1 x Hlc HF H.
  unfold fold_subst_sa.
  inversion Hlc; subst; induction sa1;
  unfold fold_subst_sa in H; inversion H; simpl in *;
  erewrite subst_rho_open_close_rgn; eauto.
Qed.

Lemma subst_rho_open_close_eps:
  forall rho n w v' rho' e e1 x,
    lc_type_eps e ->
    find_R w rho = Some v' ->
    fold_subst_eps rho e1 = fold_subst_eps rho' (closing_rgn_in_eps2 n x e) ->
    fold_subst_eps rho' (opening_rgn_in_eps2 n (Rgn2_Const true true v') (closing_rgn_in_eps2 n x e)) =
    fold_subst_eps rho (opening_rgn_in_eps2 n (mk_rgn_type w) e1).
Proof.
  intros rho n w v' rho' e e1 x  Hcl1 HF H.
  apply Extensionality_Ensembles.
  unfold Same_set, Included.
  split; intros; unfold In in *.
  - unfold fold_subst_eps.  unfold fold_subst_eps in H0.
    unfold opening_rgn_in_eps2, closing_rgn_in_eps2. unfold opening_rgn_in_eps2, closing_rgn_in_eps2 in H0.
    destruct H0 as [sa [[sa' [[sa'' [H2 H3]] H4]] H5]].
    rewrite <- H5. rewrite <- H4. rewrite <- H3.
    inversion Hcl1. destruct (H0 sa'').

    assert (fold_subst_sa rho sa = fold_subst_sa rho' (closing_rgn_in_sa2 n x sa'') /\ e1 sa /\ e sa'')
      by (eapply subst_rho_eps_aux_1; eauto).

    assert(H' : fold_subst_sa rho' (opening_rgn_in_sa2 n (Rgn2_Const true true v')
                  (closing_rgn_in_sa2 n x sa'')) =
                fold_subst_sa rho (opening_rgn_in_sa2 n (mk_rgn_type w) sa))
    by (apply subst_rho_open_close_sa; auto; intuition).
    rewrite H'.
    exists (opening_rgn_in_sa2 n (mk_rgn_type w) sa).
    intuition.
    exists sa.
    split; [ assumption | reflexivity].
 - unfold fold_subst_eps.  unfold fold_subst_eps in H0.
   unfold opening_rgn_in_eps2, closing_rgn_in_eps2. unfold opening_rgn_in_eps2, closing_rgn_in_eps2 in H0.
   destruct H0 as [sa [[sa' [H1 H2]] H3]].
   rewrite <- H3. rewrite <- H2.
   exists (opening_rgn_in_sa2 n (Rgn2_Const true true v') (closing_rgn_in_sa2 n x sa)).
   inversion Hcl1. destruct (H0 sa).
   split.
   + exists (closing_rgn_in_sa2 n x sa).  split; [ | reflexivity].
     exists sa. split; [ | reflexivity].
     apply subst_rho_eps_aux_1 with (sa := sa') (sa':=sa) in H; auto.
   + eapply subst_rho_open_close_sa; eauto.
     apply subst_rho_eps_aux_1 with (sa := sa') (sa':=sa) in H; auto.
     destruct H as [A [B C]]; auto.
Qed.

Lemma subst_rho_open_close :
  forall rho w v' rho' x tyr0 tyr,
    lc_type tyr0 ->
    find_R w rho = Some v' ->
    subst_rho rho' (close_var x tyr0) = subst_rho rho tyr ->
    subst_rho rho' (open (mk_rgn_type (Rgn2_Const true false v')) (close_var x tyr0)) =
    subst_rho rho (open (mk_rgn_type w) tyr).
Proof.
  unfold open, close_var.
  intros rho w v' rho' x tyr0 tyr Hcl1 HF.
  generalize dependent 0.
  generalize dependent tyr. generalize dependent tyr0.
  induction tyr0; induction tyr; intros n;
  simpl;
  repeat (rewrite subst_rho_natural ||
                  rewrite subst_rho_boolean ||
                  rewrite subst_rho_unit ||
                  rewrite subst_rho_forallrgn ||
                  rewrite subst_rho_effect ||
                  rewrite subst_rho_pair
         );
  try (solve [intro Z; inversion Z | intro Y; reflexivity | intro X; assumption |
              intros; rewrite subst_rho_tyref in H; inversion H |
              intros; rewrite subst_rho_arrow in H; inversion H ]).
  - inversion Hcl1; subst.
    intros. f_equal; inversion H.
    + erewrite <- IHtyr0_1; eauto.
    + erewrite <- IHtyr0_2; eauto.
  - intro. symmetry in H. rewrite  subst_rho_tyref in H.
    rewrite  subst_rho_tyref in H. inversion H as [ [HR1 HR2] ].
    repeat rewrite subst_rho_tyref. f_equal.
    + erewrite subst_rho_open_close_rgn; eauto. now inversion Hcl1.
    + erewrite IHtyr0; eauto. now inversion Hcl1.
  - intro. symmetry in H. rewrite  subst_rho_arrow in H.
    rewrite  subst_rho_tyref in H. now inversion H.
  - intro.  rewrite  subst_rho_tyref in H. rewrite  subst_rho_arrow in H. now inversion H.
  - repeat rewrite subst_rho_arrow. intro Z. inversion Z.
    f_equal.
    + rewrite <- IHtyr0_1; auto. now inversion Hcl1.
    + apply subst_rho_open_close_eps; [ now inversion Hcl1 | assumption | now inversion Z].
    + rewrite <- IHtyr0_2; auto. now inversion Hcl1.
    + apply subst_rho_open_close_eps; [ now inversion Hcl1 | assumption | now inversion Z].
    + rewrite <- IHtyr0_3; auto. now inversion Hcl1.
  - repeat rewrite subst_rho_forallrgn.
    intro Z; inversion Z.
     f_equal.
    + apply subst_rho_open_close_eps; [ now inversion Hcl1 | assumption | now inversion Z].
    + rewrite <- IHtyr0; auto. now inversion Hcl1.
Qed.

Lemma ty_sound_var :
  forall x v stty rho env ctxt t,
  TcEnv (stty, rho, env, ctxt) ->
  find_E x env = Some v -> find_T x ctxt = Some t ->
  TcVal (stty, v, subst_rho rho t).
Proof.
  intros x v stty rho env ctxt t HTcEnv FindEnv FindCtxt. (* Hclosed. *)
  inversion_clear HTcEnv as [? ? ? ? HBst HFwd HBack HTc].
  destruct (HFwd x v FindEnv) as [y FindEnv'].
  rewrite FindEnv' in FindCtxt. inversion FindCtxt; subst.
  eapply HTc; [eexact FindEnv | eexact FindEnv' ]. (*| assumption]. *)
Qed.

Lemma ty_sound_closure:
  forall stty rgns env rho ctxt f x ec ee tyx tyc effc effe,
    TcRho (rho, rgns) ->
    TcInc (ctxt, rgns)->
    TcEnv (stty, rho, env, ctxt) ->
    TcExp (ctxt, rgns,  Mu f x ec ee, Ty2_Arrow tyx effc tyc effe Ty2_Effect, Empty_Static_Action) ->
    TcVal (stty, Cls (env, rho,  Mu f x ec ee),  subst_rho rho (Ty2_Arrow tyx effc tyc effe Ty2_Effect)).
Proof.
  intros; econstructor; eauto.
Qed.

Lemma ty_sound_region_closure:
  forall stty rgns env rho ctxt x er tyr effr,
    TcRho (rho, rgns) ->
    TcInc (ctxt, rgns) ->
    TcEnv (stty, rho, env,ctxt) ->
    TcExp (ctxt, rgns, Lambda x er, Ty2_ForallRgn (close_var_eff x effr) (close_var x tyr),  Empty_Static_Action) ->
    TcVal (stty, Cls (env, rho, Lambda x er), subst_rho rho (Ty2_ForallRgn (close_var_eff x effr) (close_var x tyr))).
Proof.
  intros. econstructor; eauto.
Qed.

Lemma weakening_trans :
   forall stty stty' stty'',
     (forall (l : ST.key) (t : tau),
        ST.find (elt:=tau) l stty = Some t -> ST.find (elt:=tau) l stty' = Some t) ->
     (forall (l : ST.key) (t : tau),
        ST.find (elt:=tau) l stty' = Some t -> ST.find (elt:=tau) l stty'' = Some t) ->
     (forall (l : ST.key) (t : tau),
        ST.find (elt:=tau) l stty = Some t -> ST.find (elt:=tau) l stty'' = Some t).
Proof.
  intros stty stty' stty'' Weak Weak'.
  intros l t ?. apply Weak'. now apply Weak.
Qed.

Lemma bound_var_is_fresh :
  forall rho rgns  x,
    TcRho (rho, rgns) -> not_set_elem rgns x -> ~ R.In (elt:=Region) x rho.
Proof.
  intros rho rgns x H1 H2.
  inversion H1; subst.
  unfold not_set_elem in H2. unfold Ensembles.Complement in H2.
  unfold not. intro.
  apply RMapP.in_find_iff in H.
  apply H2.
  eapply H0; eassumption.
Qed.

Lemma ty_sound:
  forall e env rho hp hp' v dynamic_eff,
    (hp, env, rho, e) ⇓ (hp', v, dynamic_eff) ->
    forall stty ctxt rgns t static_eff,
      TcHeap (hp, stty) ->
      TcRho (rho, rgns) ->
      TcEnv (stty, rho, env, ctxt) ->
      TcExp (ctxt, rgns, e, t, static_eff) ->
      exists stty',
        (forall l t', ST.find l stty = Some t' -> ST.find l stty' = Some t')
         /\ TcHeap (hp', stty')
         /\ TcVal (stty', v, subst_rho rho t).
Proof.
  intros e env rho hp hp'  v dynamic_eff D.
  dynamic_cases (dependent induction D) Case;
  intros stty ctxt rgns t static_eff Hhp Hrho Henv Hexp;
  inversion Hexp; subst.
  Case "cnt n".
    exists stty; (split; [| split]; auto). rewrite subst_rho_natural.
    econstructor; eassumption.
  Case "bool b".
    exists stty;  (split; [| split]; auto). rewrite subst_rho_boolean.
    econstructor; eassumption.
  Case "var x".
    exists stty; (split; [| split]; auto).
    eapply ty_sound_var; eassumption.
  Case "mu_abs".
    exists stty; (split; [| split]; auto).
    eapply ty_sound_closure; try (solve [eassumption]). auto.
    assert (TcInc (ctxt, rgns)) by admit.
    auto.
  Case "rgn_abs".
    exists stty;  (split; [| split]; auto).
    eapply ty_sound_region_closure; try (solve [eassumption]). auto.
    assert (TcInc (ctxt, rgns)) by admit.
    auto.
  Case "mu_app".
    edestruct IHD1 as [sttym [Weak1 [TcHeap1 TcVal_mu]]]; eauto.
    edestruct IHD2 as [sttya [Weaka [TcHeapa TcVal_arg]]]; eauto.
    eapply ext_stores__env; eauto.
    inversion TcVal_mu as [ | | | ? ? ? ? ? ? ? ?  TcRho_rho' TcEnv_env' TcExp_abs | | |] ; subst.
    inversion TcExp_abs as [ | |  | ? ? ? ? ? ? ? ? ? ? ? ? TcExp_ec TcExp_ee | | | | | | | | | | | | | | | | | | | | | ]; subst.
    rewrite <- H5 in TcVal_mu.
    do 2 rewrite subst_rho_arrow in H5. inversion H5.
    assert (SubstEq1: subst_rho rho' tyx = subst_rho rho tya) by assumption.
    assert (SubstEq2: subst_rho rho' tyc = subst_rho rho t) by assumption.
    rewrite <- SubstEq1 in TcVal_arg.
    unfold update_rec_E, update_rec_T in *.
    edestruct IHD3 as [sttyb [Weakb [TcHeapb TcVal_res]]]; eauto.
    SCase "TcEnv".
     apply update_env. apply update_env. eapply ext_stores__env; eauto.
     eapply ext_stores__val; eauto. eassumption.
     exists sttyb; intuition.
  Case "rgn_app".
    edestruct IHD1 as [sttyl [Weak1 [TcHeap1 TcVal_lam]]]; eauto.
    inversion TcVal_lam as  [ | | | ? ? ? ? ? ? ?  TcRho_rho' TcInc'  TcEnv_env' TcExp_lam | | |]; subst.
    inversion TcExp_lam as [ | | | | ? ? ? ? ? ? ? ? ? TcExp_eb | | | | | | | | | | | | | | | | | | | |  ]; subst.
    edestruct IHD2 as [sttyr [Weak2 [TcHeap2 TcVal_res]]]; eauto using update_env, ext_stores__env.
    apply update_rho. assumption. assumption. eapply extended_rho; eauto.
    exists sttyr; intuition.
    rewrite subst_rho_forallrgn in H5.
    rewrite subst_rho_forallrgn in H5.
    inversion H5.
    unfold update_R in TcVal_res.
    simpl in TcVal_res. rewrite subst_add_comm in TcVal_res.
    SCase "abstraction body is well typed".
    unfold subst_in_type in TcVal_res.
    rewrite SUBST_AS_CLOSE_OPEN in TcVal_res; auto.
    erewrite subst_rho_open_close in TcVal_res; eauto.
    SCase "bound variable is free".
    eapply bound_var_is_fresh; eauto.
  Case "eff_app".
    edestruct IHD1 as [sttym [Weak1 [TcHeap1 TcVal_mu]]]; eauto.
    edestruct IHD2 as [sttya [Weaka [TcHeapa TcVal_arg]]]; eauto using ext_stores__env.
    inversion TcVal_mu as  [ | | | ? ? ? ? ? ? ? TcRho_rho' TcInc' TcEnv_env' TcExp_abs | | |]; subst.
    inversion TcExp_abs as [ | | | | ? ? ? ? ? ? ? ? ? TcExp_eb | | | | | | | | | | | | | | | | | | | |  ]; subst.
    edestruct IHD3 as [sttyb [Weakb [TcHeapb TcVal_res]]]; eauto.
    SCase "Extended Env".
      apply update_env.
      SSCase "TcEnv". apply update_env.
        SSSCase "Extended". eapply ext_stores__env; eauto.
        SSSCase "Extended TcVal". rewrite <- H4 in TcVal_mu.  eapply ext_stores__val; eauto.
      SSCase "TcVal". do 2 rewrite subst_rho_arrow in H4.
          inversion H4.
          assert (SubstEq: subst_rho rho' tyx = subst_rho rho tya) by assumption.
          rewrite <- SubstEq in TcVal_arg.  eassumption.
    exists sttyb. intuition.
    rewrite subst_rho_effect. rewrite subst_rho_effect in TcVal_res.
    assumption.
  Case "par_pair".
    edestruct IHD3 as [sttym [Weak1 [TcHeap1 TcVal_app1]]]; eauto.
    edestruct IHD4 as [sttya [Weaka [TcHeapa TcVal_app2]]]; eauto.
    (*inversion TcVal_app1 as [A B [C D HRApp1] | | | | | |]; subst.
    inversion TcVal_app2 as [A B [C D HRApp2] | | | | | |]; subst.*)
    exists (Functional_Map_Union sttya sttym). intuition.
    SCase "Weakening".
      apply UnionStoreTyping; [apply Weaka | apply Weak1]; auto.
    SCase "TcHeap".
      eapply UnionTcHeap with (theta1:=theta1) (theta2:=theta2); eauto.
    SCase "TcVal".
      rewrite subst_rho_pair.
      econstructor; [eapply TcValExtended_2 | eapply TcValExtended_1]; eauto.
  Case "cond_true".
    edestruct IHD1 as [sttyb [Weakb [TcHeapvb TcVal_e0]]]; eauto.
    edestruct IHD2 as [stty1 [Weak1 [TcHeapv1 TcVal_e1]]];
      eauto using ext_stores__env.
    exists stty1. intuition.
  Case "cond_false".
    edestruct IHD1 as [sttyb [Weakb [TcHeapvb TcVal_e0]]]; eauto.
    edestruct IHD2 as [stty2 [Weak2 [TcHeapv2 TcVal_e2]]];
      eauto using ext_stores__env.
    exists stty2. intuition.
  Case "new_ref e".
    destruct IHD with (stty := stty)
                      (ctxt := ctxt)
                      (rgns := rgns)
                      (t := t0)
                      (static_eff := veff)
      as [sttyv [Weakv [TcHeapv TcVal_v]]]; eauto.
    assert (find_H (r, allocate_H heap' r) heap' = None)
      by (apply allocate_H_fresh).
    exists (update_ST ((r, allocate_H heap' r), subst_rho rho t0) sttyv); split; [ | split].
    SCase "Extended stores".
      intros k' t' STfind. destruct k' as [r' l'].
      destruct (eq_nat_dec r r'); destruct (eq_nat_dec (allocate_H heap' r) l'); subst.
      SSCase "New address must be fresh, prove by contradiction".
        apply Weakv in STfind.
        inversion_clear TcHeapv as [? ? ?  STfind_Hfind ?].
        destruct (STfind_Hfind (r', allocate_H heap' r') t' STfind) as [x F].
        assert (C : None = Some x) by (rewrite <- F; rewrite <- H0; reflexivity).
        discriminate.
      SSCase "Existing addresses are well-typed 1".
        apply ST_diff_key_2; [ simpl; intuition; apply n; congruence | now apply Weakv in STfind ].
      SSCase "Existing addresses are well-typed 2".
        apply ST_diff_key_2; [ simpl; intuition; apply n; congruence | now apply Weakv in STfind ].
      SSCase "Existing addresses are well-typed 3".
        apply ST_diff_key_2; [simpl; intuition; apply n; congruence | now apply Weakv ].
    SCase "Heap typeness".
      apply update_heap_fresh; eauto.
      remember (find_ST (r, allocate_H heap' r) sttyv) as to; symmetry in Heqto.
      destruct to as [ t | ].
      SSCase "New address must be fresh, prove by contradiction".
        inversion_clear TcHeapv as [? ? ? STfind_Hfind ?].
        destruct (STfind_Hfind (r, allocate_H heap' r) t Heqto) as [? ex].
        rewrite H0 in ex. discriminate.
      SSCase "Heap typeness is preserved".
         reflexivity.
    SCase "Loc is well-typed".
       simpl in H; inversion H; subst.
       rewrite subst_rho_tyref. unfold mk_rgn_type. rewrite subst_rho_rgn_const.
       econstructor. apply ST_same_key_1.
       intro.
       eapply TcVal_implies_closed in TcVal_v; eauto.
  Case "get_ref e".
    destruct IHD with (hp'0 := hp')
                      (v := Loc (Rgn2_Const true false s) l)
                      (stty := stty)
                      (rgns := rgns)
                      (ctxt := ctxt)
                      (t := Ty2_Ref (mk_rgn_type ((Rgn2_Const true false s))) t)
                      (static_eff := aeff)
                      (dynamic_eff := aacts)
    as [sttyv [Weakv [TcHeapv TcVal_v]]]; eauto.
    exists sttyv. split; [ | split].
    SCase "HeapTyping extends".
      apply Weakv.
    SCase "Heap is well typed".
      apply TcHeapv.
    SCase "Value is well-typed".
      inversion_clear TcHeapv as [? ? ? ? HeapTcVal]. eapply HeapTcVal; eauto.
      inversion TcVal_v; subst; simpl in H; inversion H; subst.
      rewrite subst_rho_tyref in H7. inversion H7. subst.
      assumption.
  Case "set_ref e1 e2".
    destruct IHD1 with (hp' := heap')
                       (v := Loc (Rgn2_Const true false s) l)
                       (stty := stty)
                       (ctxt := ctxt)
                       (rgns := rgns)
                       (t := Ty2_Ref (mk_rgn_type ((Rgn2_Const true false s))) t0)
                       (static_eff := aeff)
                       (dynamic_eff := aacts)
       as [sttya [Weaka [TcHeapa TcVal_a]]]; eauto.
    destruct IHD2 with (stty := sttya)
                       (ctxt := ctxt)
                       (rgns := rgns)
                       (t := t0)
                       (static_eff := veff)
      as [sttyv [Weakv [TcHeapv TcVal_v]]]; eauto using ext_stores__env.
    exists sttyv. split; [ | split].
    SCase "HeapTyping extends".
      eapply weakening_trans; eauto.
    SCase "New heap is well typed".
      apply update_heap_exists with (t:= subst_rho rho t0).
      { assumption. }
      { apply Weakv. inversion TcVal_a; subst.
        simpl in H; inversion H; subst.
        rewrite subst_rho_tyref in H4. inversion H4. subst.
        assumption. }
      { assumption. }
    SCase "Result value is well-typed".
      rewrite subst_rho_unit. constructor.
  Case "nat_plus x y".
    edestruct IHD1 as [sttyx [Weakx [TcHeapvx TcVal_x]]]; eauto.
    edestruct IHD2 as [sttyy [Weaky [TcHeapvy TcVal_y]]];
      eauto using ext_stores__env.
    exists sttyy. intuition. rewrite subst_rho_natural. constructor.
  Case "nat_minus x y".
    edestruct IHD1 as [sttyx [Weakx [TcHeapvx TcVal_x]]]; eauto.
    edestruct IHD2 as [sttyy [Weaky [TcHeapvy TcVal_y]]];
      eauto using ext_stores__env.
    exists sttyy. intuition. rewrite subst_rho_natural. constructor.
  Case "nat_times x y".
    edestruct IHD1 as [sttyx [Weakx [TcHeapvx TcVal_x]]]; eauto.
    edestruct IHD2 as [sttyy [Weaky [TcHeapvy TcVal_y]]];
      eauto using ext_stores__env.
    exists sttyy. intuition. rewrite subst_rho_natural. constructor.
  Case "bool_eq x y".
    edestruct IHD1 as [sttyx [Weakx [TcHeapvx TcVal_x]]]; eauto.
    edestruct IHD2 as [sttyy [Weaky [TcHeapvy TcVal_y]]];
      eauto using ext_stores__env.
    exists sttyy. intuition. rewrite subst_rho_boolean. constructor.
  Case "alloc_abs".
    exists stty. intuition. rewrite subst_rho_effect. constructor.
  Case "read_abs".
    exists stty. intuition. rewrite subst_rho_effect. constructor.
  Case "write_abs".
    exists stty. intuition. rewrite subst_rho_effect. constructor.
  Case "read_conc".
    exists stty. intuition.
    assert (hp = hp') by (eapply EmptyTracePreservesHeap_1; eauto; reflexivity); now subst.
    rewrite subst_rho_effect. constructor.
  Case "write_conc".
    exists stty. intuition.
    assert (hp = hp') by (eapply EmptyTracePreservesHeap_1; eauto; reflexivity); now subst.
    rewrite subst_rho_effect. constructor.
  Case "eff_concat". exists stty. intuition. rewrite subst_rho_effect. constructor.
  Case "eff_top". exists stty. intuition. rewrite subst_rho_effect. constructor.
  Case "eff_empty". exists stty. intuition. rewrite subst_rho_effect. constructor.
Admitted.

End TypeSoundness.


(*
 * Coq code for "Certified Assembly Programming with Embedded Code Pointers"
 *
 * XCAP
 *
 * (for Coq version 8)
 *)

Require Import ZArith.
Require Import Eqdep.
Require Import Map.
Require Import Mapt.
Require Import tm.
Require Import tylist.
Require Import axiom.
Require Import propx.
Require Import seplogic.

Open Scope Z_scope.

Set Implicit Arguments.
Unset Strict Implicit.

Definition Itp P Si := OK nil Si P.

Notation "[[ P ]]. Si" := (Itp P Si) (at level 130).

Notation ItP := (fun a Si S => [[a S]].Si) (only parsing).

Notation "[[ a ]] Si" := ((fun a Si S => [[a S]].Si) a Si) (at level 130).

Notation Subsume :=
  (fun a a' =>
   forall Si S,
   (fun a Si S => [[a S]].Si) a Si S ->
   (fun a' Si S => [[a' S]].Si) a' Si S) (only parsing).

Notation "p ==>xcap q" :=
  ((fun a a' =>
    forall Si S,
    (fun a Si S => [[a S]].Si) a Si S ->
    (fun a' Si S => [[a' S]].Si) a' Si S) p q)
  (at level 130, right associativity).
Notation "p ==> q" := (p ==>xcap q) (at level 130, right associativity).

Inductive InstrSeq : Set := instr  : Instr -> InstrSeq
                          | instr' : Instr -> Word -> InstrSeq
                          | iseq   : Instr -> InstrSeq -> InstrSeq.

Definition CodeHeap := Map.Map Label InstrSeq.

Fixpoint Di (l : Label) (i : InstrSeq) (H : Heap) (lpc : Label) {struct i} : Prop :=
  match i with
    instr c => Dc H l c lpc
  | instr' c npc => Dc H l c npc /\ npc = lpc
  | iseq c i => exists npc, Dc H l c npc /\ Di npc i H lpc
  end.

Definition DC C H := (forall l i, Map.lookup C l i -> exists lpc, Di l i H lpc)
                  /\ (forall l, Map.in_dom H l ->
                        exists l', exists i, exists lpc,
                          Di l' i H lpc /\ l' <= l < lpc).

Inductive WFiseq : CdHpSpec -> Assertion -> InstrSeq -> Prop :=
  | wfiseq  : forall Si a c I a',
                (a ==> (fun s => Ex s' .
 <<Next c s s'>> ./\ a' s')) ->
                WFiseq Si a' I                         -> WFiseq Si a (iseq c I)
  | wfjcc   : forall Si a cc f I a' a'',
                ((fun s => <<~(Fcc (_F s) cc)>> ./\ a s) ==> a'') ->
                ((fun s => <<Fcc (_F s) cc>> ./\ a s) ==> a') ->
                lookup Si f a' -> WFiseq Si a'' I
                                              -> WFiseq Si a (iseq (jcc cc f) I)
  | wfjmpi  : forall Si a f a', lookup Si f a' -> (a ==> a')
                                           -> WFiseq Si a (instr (jmp (word f)))
  | wfjmpr  : forall Si a r,
                (a ==> fun S => extv _ _ (eq_rect _ _
                                  (cptr _ (_R S r) (var _ _) ./\ var _ _ S)
                                  _ (eq_tplus_tO _)))
                                            -> WFiseq Si a (instr (jmp (reg r)))
  | wfcalli : forall Si a f fret a', lookup Si f a' ->
                (a ==> (fun s => Ex s'.
                                   <<Next (push (word fret)) s s'>> ./\ a' s'))
                                    -> WFiseq Si a (instr' (call (word f)) fret)
  | wfcallr : forall Si a r fret,
                (a ==> (fun S => extv _ _ (eq_rect _ _
                                  (cptr _ (_R S r) (var _ _) ./\
                                   Ex s'.
                                     <<Next (push (word fret)) S s'>> ./\ var _ _ s')
                                  _ (eq_tplus_tO _))))
                                            -> WFiseq Si a (instr' (call (reg r)) fret)
  | wfret   : forall Si a,
                (a ==> (fun S => Ex fret.
                                   <<Map.lookup (_H S) (_R S esp) fret>> ./\
                                  extv _ _ (eq_rect _ _
                                  (cptr _ fret (var _ _) ./\
                                   Ex s'.
                                     <<Next pop' S s'>> ./\ var _ _ s')
                                  _ (eq_tplus_tO _))))
                                            -> WFiseq Si a (instr ret)
  | wfecp   : forall Si a f a' a'' I, WFiseq Si a' I -> lookup Si f a'' ->
               ((fun s => cptr _ f a'' ./\ a s) ==> a')         -> WFiseq Si a I.

Notation "Si |-xcap{ a } i" := (WFiseq Si a i) (at level 130).
Notation "Si |-{ a } i" := (Si |-xcap{ a}i) (at level 130).

Inductive WFcode : CdHpSpec -> CodeHeap -> CdHpSpec -> Prop :=
  | wfcdhp : forall Si Si' C,
               (forall l a, lookup Si' l a
                  -> exists I, Map.lookup C l I /\ (Si' |-{ a}I))
                                                              -> WFcode Si C Si'
  | wflink :
      forall Si1 Si2 Si'1 Si'2 C1 C2 Si Si',
      WFcode Si1 C1 Si'1 ->
      WFcode Si2 C2 Si'2 ->
      Map.disjoint C1 C2 ->
      subseteq Si1 (merge Si1 Si2) ->
      subseteq Si2 (merge Si1 Si2) ->
      (forall l, merge Si1 Si2 l = Si l) ->
      (forall l, merge Si'1 Si'2 l = Si' l)   -> WFcode Si (Map.merge C1 C2) Si'.

Notation "Si |-xcap C :: Si'" := (WFcode Si C Si') (at level 130).
Notation "Si |- C :: Si'" := (Si |-xcap C :: Si') (at level 130).

Definition WFprogram Si a (P : Program) :=
  let (s, pc) := P in let (HR, F) := s in let (H, R) := HR in exists C, exists i,
  (Si |- C :: Si) /\ (Si |-{a} i) /\
  [[star (fun H => <<(exists npc, Di pc i H npc) /\ DC C H>>)
         (fun H => a (H, R, F)) H]]. Si.

Notation "Si |-xcap[ a ] P" := (WFprogram Si a P) (at level 130).
Notation "Si |-[ a ] P" := (Si |-xcap[ a]P) (at level 130).

Lemma disjoint_uH_disjoint_2 : forall H H' H'' l w,
  uH H' H'' l w -> Map.disjoint H H' -> Map.disjoint H H''.
intros.
destruct H0.
 destruct H2.
 unfold Map.disjoint.
 intro.
 generalize (H1 a).
destruct (H a); auto.
 destruct (Z_eq_dec l a).
 rewrite e in H0.
 destruct H0.
rewrite H0.
 tauto.
 rewrite (H3 a n).
 auto.
Qed.

Lemma disjoint_uH_merge_uH : forall h1 h2 h3 l w,
  Map.disjoint h1 h2 -> uH h2 h3 l w -> uH (Map.merge h1 h2) (Map.merge h1 h3) l w.
intros.
 destruct H0.
 destruct H1.
split.
 generalize H0.
 unfold Map.in_dom, Map.merge.
 destruct (h1 l).
intro.
 exists w0.
 auto.
 auto.
split.
 generalize H1.
 unfold Map.lookup, Map.merge.
 generalize (H l).
destruct (h1 l).
 destruct H0.
 rewrite H0.
 tauto.
auto.
intros.
 generalize (H2 _ H3).
 unfold Map.merge.
 generalize (H l).
destruct (h1 l).
 destruct H0.
 rewrite H0.
 tauto.
intros.
 rewrite H5.
 auto.
Qed.

Lemma InstrSeqWeakening : forall Si Si' a a' I,
                            (Si |-{a'} I) -> (subseteq Si Si') -> (a ==> a')
                                                                -> (Si' |-{a} I).
intros; move H after Si'; generalize a H0 H1; clear a H0 H1.
induction H; intros.
apply wfiseq with a'.
auto.
apply IHWFiseq; auto.
apply wfjcc with a' a''; intros.
apply H.
unfold Itp in *.
dest H5.
apply ok_and_i; auto.
apply H0.
unfold Itp in *.
dest H5.
apply ok_and_i; auto.
unfold subseteq in H3.
unfold lookup in *.
generalize (H3 f).
rewrite H1.
auto.
auto.
apply wfjmpi with a'.
unfold lookup in *.
generalize (H1 f).
rewrite H.
auto.
auto.
apply wfjmpr.
intros.
generalize (H Si0 S (H1 Si0 S H2)).
simpl.
auto.
apply wfcalli with a'.
unfold lookup in *.
generalize (H1 f).
rewrite H.
auto.
auto.
apply wfcallr.
intros.
generalize (H Si0 S (H1 Si0 S H2)).
simpl.
auto.
apply wfret.
intros.
generalize (H Si0 S (H1 Si0 S H2)).
simpl.
auto.
apply wfecp with f a' a''.
apply IHWFiseq.
auto.
auto.
inversion H0.
generalize (H2 f).
rewrite H5.
auto.
intros.
unfold lookup.
auto.
intros.
apply H1.
auto.
unfold Itp.
apply ok_and_i.
apply (ok_and_e1 _ _ _ _ H4).
apply H3.
apply (ok_and_e2 _ _ _ _ H4).
Qed.

Lemma CodeHeapTyping :
 forall C Si l a,
 (Si |- C :: Si) ->
 lookup Si l a -> exists I : _, Map.lookup C l I /\ (Si |-{ a}I).
intros.
generalize l a H0.
clear l a H0.
induction H.
intros.
destruct (H l a H0).
split with x.
auto.
intros.
unfold lookup in H6.
rewrite <- (H5 l) in H6.
destruct (mergelookup H6).
destruct (IHWFcode1 l a H7).
split with x.
destruct H8.
split.
unfold Map.lookup, Map.merge in |- *.
unfold Map.lookup in H8.
rewrite H8.
auto.
apply InstrSeqWeakening with Si'1 a.
auto.
unfold subseteq in |- *.
intro.
rewrite <- (H5 a0).
unfold merge in |- *.
destruct (Si'1 a0).
auto.
auto.
auto.
destruct (IHWFcode2 l a H7).
destruct H8.
split with x.
split.
unfold Map.lookup, Map.merge in |- *.
unfold Map.disjoint in H1.
generalize (H1 l).
destruct (C1 l).
unfold Map.lookup in H8.
rewrite H8.
tauto.
unfold Map.lookup in H8.
rewrite H8.
auto.
apply InstrSeqWeakening with Si'2 a.
auto.
unfold subseteq in |- *.
intro.
rewrite <- (H5 a0).
unfold merge in |- *.
generalize (IHWFcode2 a0).
unfold lookup.
destruct (Si'2 a0).
intros.
generalize (IHWFcode1 a0).
unfold lookup in |- *.
destruct (Si'1 a0).
intros.
destruct (H11 a2).
auto.
destruct H12.
destruct (H10 a1).
auto.
destruct H14.
unfold Map.lookup in H12.
unfold Map.lookup in H14.
generalize (H1 a0).
rewrite H12.
rewrite H14.
tauto.
auto.
auto.
auto.
Qed.

Theorem Soundness :
 forall Si a P,
 (Si |-[ a]P) ->
 exists a' : _, (exists P' : _, (P |--> P') /\ (Si |-[ a']P')).
intros.
destruct P.
destruct s.
destruct p.
rename w into pc.
destruct H.
destruct H.
rename x into c.
rename x0 into i.
destruct H.
destruct H0.
destv H1 ch.
destv H1 m.
dest H1.
dest H2.
dest H2.
destruct H2.
induction H0.
clear IHWFiseq.
generalize (H0 Si (m, r, e) H3).
intro.
dest H6.
exists a'.
simpl in H2.
destruct H2.
destruct H2.
destruct x0.
destruct p.
exists ((Map.merge ch h0, r0, e0), x1).
split.
apply stp_iseq with c0.
apply Dc_mono with ch.
auto.
dest H1.
rewrite H8.
unfold Map.subseteq, Map.merge.
intro.
destruct (ch a0); auto.
dest H1.
dest H6.
rewrite H8.
generalize (okvalid _ _ H6).
intro.
inversion H10.
apply stp_add; auto.
apply stp_sub; auto.
apply stp_mov; auto.
apply stp_movrm with w; auto.
 apply Map.lookup_disj_merge_lookup_2; auto.
 rewrite <- H17.
 auto.
apply stp_movm; auto.
 apply disjoint_uH_merge_uH; auto.
apply stp_cmp; auto.
apply stp_push; auto.
 apply disjoint_uH_merge_uH; auto.
apply stp_pop with w R''; auto.
 apply Map.lookup_disj_merge_lookup_2; auto.
  rewrite <- H15.
 auto.
apply stp_pop'; auto.
apply stp_int; auto.
exists c.
 exists I.
 split.
 auto.
 split.
 auto.
 unfold Itp.
 unfold star.
 existsx ch.
 existsx h0.
 splitx.
 propx.
 split; auto.
 dest H1.
 dest H6.
 generalize (okvalid _ _ H6).
 intro.
 inversion H10.
  rewrite <- H16.
 auto.
  rewrite <- H16.
 auto.
  rewrite <- H17.
 auto.
  rewrite <- H17.
 auto.
  apply disjoint_uH_disjoint_2 with m (Ra r0 d) (Ro r0 o); auto.
  rewrite <- H17.
 auto.
  apply disjoint_uH_disjoint_2 with m (r esp-4) (Ro r o); auto.
  rewrite <- H15.
 auto.
  rewrite <- H17.
 auto.
  rewrite <- H16.
 auto.
 splitx.
 propx.
 split; auto.
 exists x.
 auto.
 dest H6.
 auto.
(* jcc *)
destruct (Fcc_dec e cc).
exists a'.
 exists (h, r, e, f).
 split.
 destruct H2.
 destruct H2.
 apply stp_jcc with cc x0; auto.
 dest H1.
 rewrite H10.
 apply Dc_mono with ch; auto.
 apply Map.subseteq_merge.
 exists c.
 destruct (CodeHeapTyping H H6).
 exists x0.
 destruct H9.
 split.
 auto.
 split.
 auto.
 unfold Itp, star.
 existsx ch.
 existsx m.
 splitx.
 auto.
 splitx.
 propx.
 split; auto.
 generalize H4.
 intro.
 destruct H11.
 auto.
 apply H5.
 unfold Itp.
 splitx.
 propx.
 auto.
 auto.
exists a''.
 destruct H2.
 destruct H2.
 exists (h, r, e, x0).
 split.
 apply stp_jcc' with cc f; auto.
 dest H1.
 rewrite H10.
 apply Dc_mono with ch; auto.
 apply Map.subseteq_merge.
 exists c.
 exists I.
 split.
 auto.
 split.
 auto.
 unfold Itp, star.
 existsx ch.
 existsx m.
 splitx.
 auto.
 splitx.
 propx.
 split; auto.
 exists x.
 auto.
 apply H0.
 unfold Itp.
 splitx.
 propx.
 auto.
 auto.
(* jmp f *)
exists a'.
 destruct (CodeHeapTyping H H0).
 destruct H6.
 exists (h, r, e, f).
 cut (Ro r (word f)=f); auto.
 intro.
 split.
 rewrite <- H8.
 apply stp_jmp with x.
 dest H1.
 rewrite H9.
 apply Dc_mono with ch; auto.
 apply Map.subseteq_merge.
 exists c.
 exists x0.
 split.
 auto.
 split.
 auto.
 unfold Itp, star.
 existsx ch.
 existsx m.
 splitx.
 auto.
 splitx.
 propx.
 split; auto.
 unfold DC in H4.
 destruct H4.
 auto.
 apply H5.
 auto.
(* jmp r *)
generalize (H0 _ _ H3).
 simpl.
 intro.
 destv H5 a'.
 simpl in H5.
 exists a'.
 exists (h, r, e, Ro r (reg r0)).
 split.
 apply stp_jmp with x.
 dest H1.
 rewrite H6.
 apply Dc_mono with ch; auto.
 apply Map.subseteq_merge.
 exists c.
 dest H5.
 rewrite (ext_eq _ _ (fun x : State => a' x) a') in H5; auto.
 generalize (okvalid _ _ H5).
 simpl.
 intro.
 destruct (CodeHeapTyping H H7).
 destruct H8.
 exists x0.
 split.
 auto.
 split.
 rewrite (ext_eq _ _ (fun x : State => a' x) a') in H9; auto.
 unfold Itp, star.
 existsx ch.
 existsx m.
 splitx.
 auto.
 splitx.
 propx.
 split; auto.
 destruct H4.
 auto.
 auto.
(* calli *)
exists a'.
 dest H1.
 generalize (H5 _ _ H3).
 intro.
 dest H7.
 clear H5.
 dest H7.
 destruct x0.
 destruct p.
 exists (Map.merge ch h0, r0, e0, f).
 split.
 cut (Ro r (word f)=f); auto.
 intro.
 rewrite <- H8.
 apply stp_call with fret.
 rewrite H6.
 apply Dc_mono with ch; auto.
 unfold Di in H2.
 destruct H2.
 auto.
 apply Map.subseteq_merge.
 des H5.
 inversion H5.
 apply stp_push; auto.
 rewrite H6.
  apply disjoint_uH_merge_uH; auto.
 exists c.
 destruct (CodeHeapTyping H H0).
 destruct H8.
 exists x0.
 split.
 auto.
 split.
 auto.
 unfold Itp, star.
 existsx ch.
 existsx h0.
 splitx.
 propx.
 split; auto.
 des H5.
 inversion H5.
 apply disjoint_uH_disjoint_2 with m (r esp-4) (Ro r (word fret)); auto.
 splitx.
 propx.
 split; auto.
 destruct H4.
 auto.
 auto.
(* callr *)
dest H1.
 generalize (H0 _ _ H3).
 clear H0.
 intro.
 destv H0 a'.
 simpl in H0.
rewrite (ext_eq _ _ (fun x : State => a' x) a') in H0; auto.
 dest H0.
 dest H6.
destruct x0.
 destruct p.
 dest H6.
 des H6.
inversion H6.
 clear H6.
 exists a'.
 exists (Map.merge ch h0, r1, e0, (Ro r (reg r0))).
split.
 apply stp_call with fret.
 rewrite H5.
 apply Dc_mono with ch; auto.
unfold Di in H2.
 destruct H2.
 auto.
  apply Map.subseteq_merge.
apply stp_push; auto.
 rewrite H5.
 apply disjoint_uH_merge_uH; auto.
exists c.
 des H0.
 simpl in H0.
rewrite (ext_eq _ _ (fun S : State => a' S) a') in H0; auto.
destruct (CodeHeapTyping H H0).
 destruct H6.
 exists x0.
 split.
 auto.
split.
 auto.
 unfold Itp, star.
 existsx ch.
 existsx h0.
 splitx.
 propx.
 split; auto.
 apply disjoint_uH_disjoint_2 with m (r esp-4) (Ro r (word fret)); auto.
splitx.
 propx.
 split; auto.
 destruct H4.
 auto.
 auto.
(* ret *)
dest H1.
 generalize (H0 _ _ H3).
 clear H0.
 intro.
 destv H0 fret.
 dest H0.
des H0.
 destv H6 a'.
 simpl in H6.
dest H6.
des H6.
 simpl in H6.
rewrite (ext_eq _ _ (fun S : State => a' S) a') in H6; auto.
dest H7.
 destruct x0.
 destruct p.
 dest H7.
des H7.
 inversion H7.
 exists a'.
 exists (Map.merge ch h0, r0, e0, fret).
split.
 rewrite H5.
 apply stp_ret with x.
unfold Di in H2.
 auto.
 apply Dc_mono with ch; auto.
 apply Map.subseteq_merge.
apply Map.lookup_disj_merge_lookup_2; auto.
rewrite <- H13.
 apply stp_pop'; auto.
exists c.
 destruct (CodeHeapTyping H H6).
 destruct H18.
 exists x0.
 split.
 auto.
split.
 auto.
 unfold Itp, star.
 existsx ch.
 existsx h0.
 splitx.
 propx.
 split; auto.
rewrite <- H13.
 auto.
 splitx.
 propx.
 split; auto.
 destruct H4.
 auto.
 auto.
(* ECP *)
apply IHWFiseq; auto.
apply H6.
 unfold Itp.
 splitx.
 apply ok_cptr_i.
 auto.
auto.
Qed.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import BaremoreSMC.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition granule_delegate_ops_spec (g: Pointer) (addr: Z64) (adt: RData) : option RData :=
    match addr with
    | VZ64 addr =>
      let gidx := offset g in
      rely is_int64 addr;
      rely (peq (base g) ginfo_loc);
      rely (gidx =? __addr_to_gidx addr);
      rely is_gidx gidx;
      rely Z.land (r_scr_el3 (cpu_regs (priv adt))) SCR_WORLD_MASK =? SCR_REALM_WORLD;
      when adt == query_oracle adt;
      let gn := (gs (share adt)) @ gidx in
      rely prop_dec ((buffer (priv adt)) @ SLOT_DELEGATED = None);
      rely prop_dec (glock gn = Some CPU_ID);
      rely prop_dec (gtype gn = GRANULE_STATE_NS);
      rely prop_dec ((gpt_lk (share adt)) @ gidx = None);
      rely prop_dec ((gpt (share adt)) @ gidx = false);
      let e1 := EVT CPU_ID (ACQ_GPT gidx) in
      let e2 := EVT CPU_ID (REL_GPT gidx true) in
      let g' := gn {ginfo: (ginfo gn) {g_tag: GRANULE_STATE_DELEGATED}}
                   {gnorm: zero_granule_data_normal}
                   {grec: zero_granule_data_rec} in
      let regs' := (cpu_regs (priv adt)) {r_x0: 0} {r_x1: addr} {r_esr_el3: ESR_EC_SMC} in
      let e' := EVT CPU_ID (REL gidx g') in
      Some adt {log: e' :: e2 :: e1 :: (log adt)}
           {share: (share adt) {gs: (gs (share adt)) # gidx == (g' {gtype: GRANULE_STATE_DELEGATED} {glock: None})}
                               {gpt: (gpt (share adt)) # gidx == true}}
           {priv: (priv adt) {cpu_regs: regs'}}
    end.

End Spec.


(* Semi-branching directed apartness *)

From bisimulations Require Import prelude.
From bisimulations Require Import system.
From bisimulations Require Import relations.
From bisimulations Require Import paths.

Section DirectedBranchingApart.
Context `{ReflSystem : @refl_system X System}.

Notation Downstream_property l R p1 p2 := ((Downstream_property l (LL_RR_coRR_relation p1 p2) R)).

(* db_dapart a b := a can do something b can't do *)
Inductive db_dapart : X → X → Prop :=
  | Fwd l p1 p2 q : can_step l p1 p2 → Downstream_property l db_dapart p1 p2 q → db_dapart p1 q.
Hint Constructors db_dapart : hints.

Theorem db_dapart_strong_ind :
  ∀ P : X → X → Prop,
    (∀ l (p1 p2 q : X),
      can_step l p1 p2 →
      Downstream_property l (rel_join db_dapart P) p1 p2 q →
      P p1 q) →
    ∀ p1 q1 : X, db_dapart p1 q1 → P p1 q1.
Proof.
  intros P CaseFwd.
  fix IH 3.
  intros p1 q1 H.
  inv H as [l p1' p2 q1' Hs_p1_p2 HQ].
  eapply CaseFwd; try done.
  intros q2 Hq12 q3 Hq23.
  destruct (HQ q2 Hq12 q3 Hq23) as [Ha_p1_q2|[Ha_p2_q3|Ha_q3_p2]];
    [left|right;left|right;right]; split; eauto.
Qed.

Theorem db_dapart_strong_ind' :
  ∀ P : X → X → Prop,
    (∀ l (p1 p2 q : X), can_step l p1 p2 → Downstream_property l P p1 p2 q → P p1 q) →
    ∀ p1 q1 : X, db_dapart p1 q1 → P p1 q1.
Proof.
  intros P CaseFwd.
  eapply db_dapart_strong_ind; eauto.
  intros; eapply CaseFwd; try done.
  eapply Downstream_property_closed_implication;
    [eapply LL_RR_coRR_relation_MBRT| |done].
  unfold rel_join. tauto.
Qed.

Lemma Downstream_property_closed_rel_join {R1 R2 : relation X} {l p1 p2 q1} :
  Downstream_property l (rel_join R1 R2) p1 p2 q1 →
  Downstream_property l R1 p1 p2 q1.
Proof. eapply Downstream_property_closed_implication; [eapply LL_RR_coRR_relation_MBRT|]. by intros p q []. Qed.

Instance db_dapart_extend_forward_one {p1} :
  Proper (can_step silent ==> impl) (db_dapart p1).
Proof.
  intros q1 q2 Hs_q1_q2 H.
  inv H.
  eapply Fwd; try done.
  eapply Downstream_property_closed_down; eauto using rtc_once.
Qed.

Instance db_dapart_extend_forward {p1} :
  Proper (rtc (can_step silent) ==> impl) (db_dapart p1).
Proof.
  intros q1.
  eapply rtc_ind_r; [done|].
  intros q2 q3 _ Hs_q2_q3 IH H.
  specialize (IH H).
  by eapply db_dapart_extend_forward_one.
Qed.

Instance db_dapart_extend_backwards_one :
  Proper (can_step silent ==> eq ==> flip impl) db_dapart.
Proof.
  intros p1 p2 Hs_p1_p2 q1 q1' <- Ha_p2_q1.
  eapply Fwd; try done.
  intros q2 Hq12 q3 Hq23.
  right. left.
  by eapply db_dapart_extend_forward; [eapply rtc_r|].
Qed.

Instance db_dapart_extend_backwards :
  Proper (rtc (can_step silent) ==> eq ==> flip impl) db_dapart.
Proof.
  intros p2 p3 Hs_p2_p3 q1 q2 <- Ha.
  revert p2 Hs_p2_p3.
  eapply rtc_ind_l; [done|].
  intros p1 p2 Hp12 Hp23.
  by eapply db_dapart_extend_backwards_one.
Qed.

End DirectedBranchingApart.