Require Import Verse.
Import VerseNotations.
Require Import Verse.Arch.C.

Require Import Vector.
Import VectorNotations.

Definition iterType := Array 10 hostE Word16.
Section TestFunction.

  Variable variable : VariableT.
  Arguments variable [k] _.
  (* The parameters of the function *)
  Variable num : variable Word16.
  Variable arr      : variable (Array 3 littleE Word16).
  Definition parameters := [Var num; Var arr].

  (* The local variables *)

  Definition locals : list (some type) := [ ]%list.

  (* The temp register *)
  Variable tmp       : variable Word16.
  Variable double    : variable Word32.

  Definition registers := [Var tmp; Var double].

  Definition test : iterator iterType variable.
    verse
      {|
        (* Try out all operators *)
        setup   := [
                    MOVE tmp TO arr[- 1 -];
                    num ::= tmp + Ox "abcd";
                      num ::= tmp - num ;
                      num      ::= tmp      * arr[-1-] ;
                      num      ::= arr[-1-] / tmp ;
                      arr[-1-] ::= tmp      | num ;
                      num      ::= tmp      & arr[-1-];
                      num      ::= tmp      ^ num ;

                      (* binary update *)
                      num ::=+ tmp;
                      num ::=- arr[-1-];
                      num ::=* Ox "1234";
                      num ::=/ tmp;
                      num ::=| tmp;
                      num ::=& tmp;
                      num ::=^ tmp;

                      (* Unary operators *)
                      num      ::=~ tmp;
                      tmp      ::=  arr[-1-] <<  42;
                      tmp      ::=  arr[-1-] >>  42;
                      num      ::=  tmp     <<< 42;
                      arr[-1-] ::=  tmp     >>> 42;

                      (* Unary update operators *)
                      tmp      ::=<<  (42%nat);
                      tmp      ::=>>  (42%nat);
                      num      ::=<<< (42%nat);
                      arr[-1-] ::=>>> (42%nat);
                      double   ::=<<< (42%nat)
                  ]%list;
        process    := fun msg => [num ::=  tmp + msg[-1-] ]%list;
        finalise := [ ]%list
      |}.
  Defined.

End TestFunction.

Require Import String.

Definition regVars := (-cr uint16_t "temp", cr uint32_t "double"-).

Definition code : Doc + {Compile.CompileError}.
  Compile.iterator iterType "testFunction" parameters locals registers.
  assignRegisters regVars.
  statements test.
Defined.

Definition pgm : string := tryLayout code.


Require Import bedrock2.NotationsCustomEntry.

Import Syntax Syntax.Coercions BinInt String List.ListNotations.
Local Open Scope string_scope. Local Open Scope Z_scope. Local Open Scope list_scope.

Definition indirect_add := func! (a, b, c) {
  store(a, load(b) + load(c))
}.

Definition indirect_add_twice := func! (a, b) {
  indirect_add(a, a, b);
  indirect_add(a, a, b)
}.

Require Import bedrock2.WeakestPrecondition.
Require Import coqutil.Word.Interface coqutil.Map.Interface bedrock2.Map.SeparationLogic.
Require Import coqutil.Tactics.fwd.
Require Import bedrock2.Map.DisjointUnion.
Require Import bedrock2.HeapletwiseHyps.
Require Import bedrock2.PurifySep.
Require Import bedrock2.Semantics bedrock2.FE310CSemantics.

Require bedrock2.WeakestPreconditionProperties.
From coqutil.Tactics Require Import letexists eabstract.
Require Import bedrock2.ProgramLogic bedrock2.Scalars bedrock2.Array.

Section WithParameters.
  Context {word: word.word 32} {mem: map.map word Byte.byte}.
  Context {word_ok: word.ok word} {mem_ok: map.ok mem}.

  Definition f (a b : word) := word.add (word.add a b) b.

  Local Notation "m =* P" := (P%sep m) (at level 70, only parsing). (* experiment *)
  Instance spec_of_indirect_add : spec_of "indirect_add" :=
    fnspec! "indirect_add" a b c / va Ra vb Rb vc Rc,
    { requires t m :=
        m =* scalar b vb * Rb /\
        m =* scalar c vc * Rc /\
        (* Note: the surviving frame needs to go last for heapletwise callers to work! *)
        m =* scalar a va * Ra;
      ensures t' m' :=
        t = t' /\
        m' =* scalar a (word.add vb vc) * Ra }.
  Instance spec_of_indirect_add_twice : spec_of "indirect_add_twice" :=
    fnspec! "indirect_add_twice" a b / va vb R,
    { requires t m := m =* scalar a va * scalar b vb * R;
      ensures t' m' := t=t' /\ m' =* scalar a (f va vb) * scalar b vb * R }.

  Lemma indirect_add_ok : program_logic_goal_for_function! indirect_add.
  Proof.
    straightline.
    straightline.
    straightline.
    straightline.
    straightline.
    straightline.
    straightline.
    straightline.
    straightline.
    straightline.
    straightline.
    repeat straightline.
    eauto.
    Qed.

  Lemma indirect_add_twice_ok : program_logic_goal_for_function! indirect_add_twice.
  Proof.
    repeat straightline.
    straightline_call.
    { split; [ecancel_assumption|]. split; ecancel_assumption. }
    repeat straightline.
    straightline_call.
    { split; [ecancel_assumption|]. split; ecancel_assumption. }
    repeat straightline.
    { cbv [f]. ecancel_assumption. }
  Qed.

  Example link_both : spec_of_indirect_add_twice (("indirect_add_twice",indirect_add_twice)::("indirect_add",indirect_add)::nil).
  Proof. auto using indirect_add_twice_ok, indirect_add_ok. Qed.

  (*
  Require Import bedrock2.ToCString bedrock2.PrintString coqutil.Macros.WithBaseName.
  Goal True. print_string (c_module &[,indirect_add_twice; indirect_add]). Abort.
  *)

  Definition indirect_add_three := func! (a, b, c) {
    indirect_add(a, a, b);
    indirect_add(a, a, c)
  }.

  Definition g (a b c : word) := word.add (word.add a b) c.
  Instance spec_of_indirect_add_three : spec_of "indirect_add_three" :=
    fnspec! "indirect_add_three" a b c / va vb vc Rb R,
    { requires t m := m =* scalar a va * scalar c vc * R /\ m =* scalar b vb * Rb;
      ensures t' m' := t=t' /\ m' =* scalar a (g va vb vc) * scalar c vc * R }.

  Lemma indirect_add_three_ok : program_logic_goal_for_function! indirect_add_three.
  Proof.
    repeat straightline.
    straightline_call.
    { split; [ecancel_assumption|]. split; ecancel_assumption. }
    repeat straightline.
    straightline_call.
    { split; [ecancel_assumption|]. split; ecancel_assumption. }
    repeat straightline.
    { cbv [g]. ecancel_assumption. }
  Qed.

  Definition indirect_add_three' := func! (out, a, b, c) {
    stackalloc 4 as v;
    indirect_add(v, a, b);
    indirect_add(out, v, c)
  }.

  Instance spec_of_indirect_add_three' : spec_of "indirect_add_three'" :=
    fnspec! "indirect_add_three'" out a b c / vout va vb vc Ra Rb Rc R,
    { requires t m :=
        m =* scalar out vout * R /\
        m =* scalar a va * Ra /\
        m =* scalar b vb * Rb /\
        m =* scalar c vc * Rc;
      ensures t' m' := t=t' /\ m' =* scalar out (g va vb vc) * R }.

  Lemma indirect_add_three'_ok : program_logic_goal_for_function! indirect_add_three'.
  Proof.
    repeat straightline.
    (* note: we want to introduce only one variable for stack contents
     * and use it in a all separation-logic facts in the symbolic state *)

    repeat match goal with
           | H : _ |- _ =>
               seprewrite_in_by scalar_of_bytes H
                 ltac:(Lia.lia);
                 let x := fresh "x" in
                 set (word.of_Z _) as x in H; clearbody x; move x at top
           end.
    clear dependent mStack.

    (*
H1 : (scalar a0 x ⋆ (scalar out vout ⋆ R))%sep m2
H2 : (scalar a0 x0 ⋆ (scalar a va ⋆ Ra))%sep m2
H3 : (scalar a0 x1 ⋆ (scalar b vb ⋆ Rb))%sep m2
H4 : (scalar a0 x2 ⋆ (scalar c vc ⋆ Rc))%sep m2
     *)

    straightline_call.
    { split; [ecancel_assumption|].
      split; [ecancel_assumption|].
      exact H1. }

    repeat straightline.
    (*
H15 : (scalar a0 (word.add va vb) ⋆ (scalar out vout ⋆ R))%sep a2
     *)
    (* H15 is an updated version of H1,
       but we really wanted to carry over H2,H3, and H4 as well *)
  Abort.

  Lemma anybytes4_to_scalar: forall a (m: mem),
      anybytes a 4 m -> exists v, with_mem m (scalar a v).
  Proof.
    intros.
    eapply anybytes_to_array_1 in H. fwd.
    eapply scalar_of_bytes in Hp0. 2: rewrite Hp1; reflexivity.
    eauto.
  Qed.

  Lemma scalar_to_anybytes4: forall a (m: mem) v,
      scalar a v m -> anybytes a 4 m.
  Proof.
    intros. eapply scalar_to_anybytes in H. exact H.
  Qed.

  Lemma sep_call: forall funs f t m args
      (calleePre: Prop)
      (calleePost callerPost: trace -> mem -> list word -> Prop),
      (* definition-site format: *)
      (calleePre -> call funs f t m args calleePost) ->
      (* use-site format: *)
      (calleePre /\ forall t' m' rets, calleePost t' m' rets -> callerPost t' m' rets) ->
      (* conclusion: *)
      call funs f t m args callerPost.
  Proof.
    intros. destruct H0. eapply WeakestPreconditionProperties.Proper_call; eauto.
  Qed.

  Lemma purify_scalar: forall (a v: word), purify (scalar a v) True.
  Proof. unfold purify. intros. constructor. Qed.
  Hint Resolve purify_scalar: purify.

  Ltac straightline_stackalloc ::= fail.
  Ltac straightline_stackdealloc ::= fail.

  Ltac straightline_call ::=
    lazymatch goal with
    | |- WeakestPrecondition.call ?functions ?callee _ _ _ _ =>
        let callee_spec := lazymatch constr:(_:spec_of callee) with ?s => s end in
        let Hcall := lazymatch goal with H: callee_spec functions |- _ => H end in
        eapply sep_call; [ eapply Hcall | ]
    end.

  Ltac same_pred_and_addr P Q ::=
    lazymatch P with
    | ?pred ?addr ?val1 =>
        lazymatch Q with
        | pred addr ?val2 => idtac
        end
    end.

  Ltac step := first [ heapletwise_step | straightline ].

  (* trying again with non-separating conjunction *)
  Lemma indirect_add_three'_ok : program_logic_goal_for_function! indirect_add_three'.
  Proof.
    repeat step.
    lazymatch goal with
    | H: anybytes _ _ _ |- _ => eapply anybytes4_to_scalar in H; destruct H as (? & H)
    end.
(*
mCombined is the full memory, and its first split into mStack and the rest is unique,
but that rest can be split in 4 different ways:
  H3 : m0 |= scalar out vout
  H4 : m1 |= R
  H5 : m2 |= scalar a va
  H6 : m3 |= Ra
  H2 : m6 |= scalar b vb
  H9 : m7 |= Rb
  H7 : m4 |= scalar c vc
  H8 : m5 |= Rc
  H1 : mStack |= scalar a0 x
  H10 : (((m4 \*/ m5) \=/ (m6 \*/ m7)) \=/ ((m2 \*/ m3) \=/ (m0 \*/ m1))) \*/ mStack =
        mCombined
*)
    straightline_call.

    step. step. step. (* <-- note how this canceling step discards all aliased memory:
       ((((m4 \*/ m5) \=/ (m6 \*/ m7)) \=/ ((m2 \*/ m3) \=/ (m0 \*/ m1))) \*/ mStack)
       becomes
       (m3 \*/ mStack) *)
    step. step. step. step. step. step. step. step. step. step. step.
    repeat step.
    straightline_call.
    repeat step.
    match goal with
    | H: with_mem _ (scalar _ (word.add va vb)) |- _ => eapply scalar_to_anybytes4 in H
    end.
    (* TODO automate *)
    rename D0 into Di.
    rewrite (mmap.du_comm m9 m1) in Di.
    rewrite <- mmap.du_assoc in Di.
    pose proof Di as Dii.
    unfold mmap.du in Di at 1. fwd.
    do 2 eexists.
    split; [eassumption | ].
    split. {
      eapply split_du. simpl. eassumption.
    }
    clear Di.
    repeat step.
    unfold g.
    repeat step.
  Qed.

  (* let's see how this would look like with an alternate spec of [indirect_add] *)

  Remove Hints spec_of_indirect_add : typeclass_instances.
  Instance spec_of_indirect_add_gen : spec_of "indirect_add" :=
    fnspec! "indirect_add" a b c / va Ra vb Rb vc Rc,
    { requires t m := m =* scalar a va * Ra /\ m =* scalar b vb * Rb /\ m =* scalar c vc * Rc;
      ensures t' m' := t=t' /\
        forall va Ra, m =* scalar a va * Ra -> m' =* scalar a (word.add vb vc) * Ra }.

  Lemma indirect_add_gen_ok : program_logic_goal_for_function! indirect_add.
  Proof.
    repeat straightline.
    (* This goal is unprovable as shown.
       It could be made provable by revealing how the memory was updated
         by modifying the straightline rule for store.
       I don't know how I would do this systematically for non-leaf functions, though. *)
 Abort.

  (* an potential alternative to changing this spec would be to
     - prove  wp.call (post:=p) /\ wp.call(post=q) -> wp.call (post:=p/\q)
     - instantiate the spec of indirect_add multiple times at the call site
       (existentials in postcondition are duplicated for each instantiation)
     but for now, let's prototype with changed spec:
  *)

  Lemma indirect_add_three'_ok' : program_logic_goal_for_function! indirect_add_three'.
  Proof.
    repeat straightline.
    (* note: we want to introduce only one variable for stack contents
     * and use it in a all separation-logic facts in the symbolic state.
     * here we get away with doing it wrong anyway. *)

    repeat match goal with
           | H : _ |- _ =>
               seprewrite_in_by scalar_of_bytes H
                 ltac:(Lia.lia);
                 let x := fresh "x" in
                 set (word.of_Z _) as x in H; clearbody x; move x at top
           end.
    clear dependent mStack.

    straightline_call.
    (*
    { split; [exact H1|split]; ecancel_assumption. }
    repeat straightline.
    rename a2 into m.
    (*
H15 : forall (va0 : word) (Ra : mem -> Prop),
      (scalar a0 va0 ⋆ Ra)%sep m2 -> (scalar a0 (word.add va vb) ⋆ Ra)%sep m
     *)
    eapply H15 in H1.
    eapply H15 in H2.
    eapply H15 in H3.
    eapply H15 in H4.
    clear H15.

    straightline_call.
    { split; [>|split]; try ecancel_assumption. }
    repeat straightline.
    rename a3 into m'.
    (*
H15 : forall (va0 : word) (Ra : mem -> Prop),
      (scalar out va0 ⋆ Ra)%sep m ->
      (scalar out (word.add (word.add va vb) vc) ⋆ Ra)%sep m'
     *)
    specialize (H15 _ _ ltac:(ecancel_assumption)).

    (* unrelated: stack deallocation proof, would need scalar-to-bytes lemma *)
    *)
  Abort.

End WithParameters.


Require Import Ssreflect.ssreflect Ssreflect.ssrbool Ssreflect.ssrnat Ssreflect.eqtype Ssreflect.seq Ssreflect.finfun Ssreflect.tuple Ssreflect.fintype.
Require Import x86proved.bitsrep x86proved.charge.ilogic.
Require Import x86proved.x86.program x86proved.x86.programassem x86proved.x86.imp x86proved.x86.call.
Require Import x86proved.cursor x86proved.safe x86proved.x86.instrrules.
Require Import x86proved.x86.reg x86proved.x86.instr x86proved.x86.instrsyntax x86proved.x86.macros Coq.Strings.Ascii x86proved.bitsops x86proved.bitsprops x86proved.bitsopsprops.
Require Import x86proved.x86.screenspec x86proved.x86.screenimp x86proved.x86.lifeimp.

Open Scope instr_scope.
Local Transparent ILFun_Ops.

Definition codeAddr: DWORD := #x"00300000".
Definition bufAddr : DWORD := #x"00400000".
Definition vesaAddr: DWORD := #x"f0000000".
Definition white   : DWORD := #x"ffffffff".

Definition prog : program :=
  (LOCAL buf;
  clsProg;;
  copyBuf screenBase buf;;
  MOV ECX, 20;;  MOV EDX, 40;;  makeGlider buf;;
  MOV ECX, 50;;  MOV EDX, 15;;  makeGlider buf;;
  MOV ECX, 5;;   MOV EDX, 5;;  makePulsar buf;;
  copyBuf buf screenBase;;

  LOCAL busy;
    busy:;;
      delay;;
      oneStepScreen screenBase buf;;
      copyBuf buf screenBase;;
      JMP busy;;
  buf:;
  ) (* ++ nseq (numCols*numRows*2) #0 *).

Compute assembleToString codeAddr prog.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import AbsAccessor.Spec.
Require Import RealmSyncHandlerAux.Specs.get_write_value.
Require Import RealmSyncHandlerAux.LowSpecs.get_write_value.
Require Import RealmSyncHandlerAux.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       esr_srt_spec
       access_mask_spec
       get_rec_regs_spec
    .

  Lemma get_write_value_spec_exists:
    forall habd  labd rec esr res
      (Hspec: get_write_value_spec rec esr habd = Some res)
      (Hrel: relate_RData habd labd),
      get_write_value_spec0 rec esr labd = Some res.
  Proof.
    Local Opaque ptr_eq.
    intros. destruct Hrel. destruct rec.
    unfold get_write_value_spec, get_write_value_spec0 in *.
    repeat autounfold in *. simpl in *.
    hsimpl_hyp Hspec; inv Hspec; simpl_query_oracle; extract_prop_dec;
      repeat destruct_con; simpl in *; srewrite; repeat simpl_update_reg;
        repeat (simpl_htarget; grewrite; simpl in *; try solve_bool_range); try reflexivity.
  Qed.

End Refine.


Require Import Common Computation Ensembles.
Require Import ADT.ADTSig ADT.Core ADTRefinement.Core.

(** Definitions for integrating [refineADT] into the setoid rewriting
    framework. *)

Instance refineConstructor_refl rep Dom
: Reflexive (@refineConstructor rep rep eq Dom).
Proof.
  intro; simpl; intros; subst; econstructor; eauto.
Qed.

Instance refineMethod_refl rep Dom Cod
: Reflexive (@refineMethod rep rep eq Dom Cod).
Proof.
  intro; simpl; unfold refine; intros; subst;
  repeat econstructor; try destruct v; eauto.
Qed.

Global Instance refineADT_PreOrder Sig : PreOrderT (refineADT (Sig := Sig)).
Proof.
  split; compute in *.
  - intro x; destruct x.
    econstructor 1 with
    (AbsR := @eq Rep);
      try reflexivity.
  - intros x y z H H'.
    destruct H as [AbsR ? ?].
    destruct H' as [AbsR' ? ?]; simpl in *.
    econstructor 1 with
      (AbsR := fun x z => exists y, AbsR x y /\ AbsR' y z);
      simpl in *; intros.
    + destruct_ex; intuition; rewrite_rev_hyp; eauto.
      autorewrite with refine_monad; f_equiv; unfold pointwise_relation;
      intros; econstructor; inversion_by computes_to_inv;
      eauto.
    + destruct_ex; intuition; rewrite_rev_hyp; eauto.
      autorewrite with refine_monad; f_equiv; unfold pointwise_relation.
      intros; rewrite refine_split_ex; autorewrite with refine_monad;
      f_equiv; unfold pointwise_relation; intros;
      autorewrite with refine_monad; simpl; f_equiv.
Qed.

(*Add Parametric Relation Sig : (ADT Sig) refineADT
    reflexivity proved by reflexivity
    transitivity proved by transitivity
      as refineADT_rel.*)

(** Refining the representation type is a valid refinement, as long as
    the new methods are valid refinements.

    If we had dependent setoid relations in [Type], then we could
    write

<<
Add Parametric Morphism : @Build_ADT
  with signature
  (fun oldM newM => newM -> Comp oldM)
    ==> arrow
    ==> arrow
    ==> (pointwise_relation _ (@refineConstructor _ _ _))
    ==> (pointwise_relation _ (@refineMethod _ _ _))
    ==> refineADT
    as refineADT_Build_ADT.
Proof.
  ...
Qed.
>>

    But, alas, Matthieu is still working on those.  So the rewrite
    machinery won't work very well when we're switching reps, and
    we'll instead have to use [etransitivity] and [apply] the
    [refineADT_Build_ADT_Rep] lemma to switch representations.

    The statement of [refineADT_Build_ADT_Rep] mimics the notation for
    registering [Parametric Morphism]s so that it will be easy to
    integrate if dependent setoid relations are added.

 *)

Lemma refineADT_Build_ADT_Rep Sig oldRep newRep
      (AbsR : oldRep -> newRep -> Prop)
:
  (@respectful_heteroT
     (forall idx, constructorType oldRep (ConstructorDom Sig idx))
     (forall idx, constructorType newRep (ConstructorDom Sig idx))
     (fun oldConstrs =>
        (forall idx,
           methodType oldRep (fst (MethodDomCod Sig idx)) (snd (MethodDomCod Sig idx)))
        -> ADT Sig)
     (fun newConstrs =>
        (forall idx,
           methodType newRep (fst (MethodDomCod Sig idx)) (snd (MethodDomCod Sig idx)))
        -> ADT Sig)
     (fun oldConstrs newConstrs =>
        forall mutIdx,
          @refineConstructor oldRep newRep AbsR
                         _
                         (oldConstrs mutIdx)
                         (newConstrs mutIdx))
     (fun x y => @respectful_heteroT
                   (forall idx, methodType oldRep _ _)
                   (forall idx, methodType newRep _ _)
                   (fun _ => ADT Sig)
                   (fun _ => ADT Sig)
                   (fun obs obs' =>
                      forall obsIdx : MethodIndex Sig,
                        @refineMethod oldRep newRep AbsR
                                        (fst (MethodDomCod Sig obsIdx))
                                        (snd (MethodDomCod Sig obsIdx))
                                        (obs obsIdx)
                                        (obs' obsIdx))
                   (fun obs obs' => refineADT)))
    (@Build_ADT Sig oldRep)
    (@Build_ADT Sig newRep).
Proof.
  unfold Proper, respectful_heteroT; intros.
  let A := match goal with |- refineADT ?A ?B => constr:(A) end in
  let B := match goal with |- refineADT ?A ?B => constr:(B) end in
  eapply (@refinesADT Sig A B AbsR);
    unfold id, pointwise_relation in *; simpl in *; intros; eauto.
Qed.

(** Thankfully, we can register a number of different refinements
    which follow from [refineADT_Build_ADT_Rep] as [Parametric
    Morphism]s... or we could, if [refineADT] were in [Prop]. *)

(** Refining Methods is a valid ADT refinement. *)

Lemma refineADT_Build_ADT_Method rep Sig cs
: forall ms ms',
    (forall idx, @refineMethod _ _ eq
                                 (fst (MethodDomCod Sig idx))
                                 (snd (MethodDomCod Sig idx))
                                 (ms idx) (ms' idx))
    -> refineADT (@Build_ADT Sig rep cs ms) (@Build_ADT Sig rep cs ms').
Proof.
  intros; eapply refineADT_Build_ADT_Rep; eauto; reflexivity.
Qed.

(** Refining Constructors is also a valid ADT refinement. *)

Lemma refineADT_Build_ADT_Constructors rep Sig ms
: forall cs cs',
    (forall idx, @refineConstructor _ _ eq
                                (ConstructorDom Sig idx)
                                (cs idx) (cs' idx))
    -> refineADT (@Build_ADT Sig rep cs ms) (@Build_ADT Sig rep cs' ms).
Proof.
  intros; eapply refineADT_Build_ADT_Rep; eauto; reflexivity.
Qed.

(** Refining observers and mutators at the same time is also a valid
    refinement. [BD: I've come to the conclusion that smaller
    refinement steps are better, so using the previous refinements
    should be the preferred mode. ]*)

Lemma refineADT_Build_ADT_Both rep Sig
: forall ms ms',
    (forall idx, @refineMethod _ _ eq
                                 (fst (MethodDomCod Sig idx))
                                 (snd (MethodDomCod Sig idx))
                                 (ms idx) (ms' idx))
    -> forall cs cs',
         (forall idx, @refineConstructor _ _ eq
                                     (ConstructorDom Sig idx)
                                     (cs idx) (cs' idx))
         -> refineADT (@Build_ADT Sig rep cs ms) (@Build_ADT Sig rep cs' ms').
Proof.
  intros; eapply refineADT_Build_ADT_Rep; eauto; reflexivity.
Qed.

(* If [refineADT] lived in [Prop], we'd be able to register
   refineADT_Build_ADT_Both as a morphism.

Add Parametric Morphism Sig rep
: (@Build_ADT Sig rep)
    with signature
    (fun mut mut' =>
       forall idx, @refineConstructor _ _ eq
                                   (ConstructorDom Sig idx)
                                   (mut idx) (mut' idx))
      ==> (fun obs obs' =>
       forall idx, @refineMethod _ _ eq
                                   (fst (MethodDomCod Sig idx))
                                   (snd (MethodDomCod Sig idx))
                                   (obs idx) (obs' idx))
      ==> refineADT
      as refineADT_Build_ADT_Both.
Proof.
  intros; eapply refineADT_Build_ADT_Rep; eauto; reflexivity.
Qed.*)


Set Implicit Arguments.

Section ADTValue.

  Variable ADTValue : Type.

  Require Import Platform.Cito.Semantics.
  Require Import Platform.Cito.SemanticsUtil.
  Require Import Coq.Lists.List.

  Notation make_triples := (@make_triples ADTValue).

  Require Import Platform.Cito.WordMap.
  Import WordMap.
  Require Import Platform.Cito.WordMapFacts.

  Lemma separated_Equal : forall h1 h2 a b,
    WordMap.Equal h1 h2
    -> Semantics.separated (ADTValue := ADTValue) h1 a b
    -> Semantics.separated h2 a b.
    unfold Semantics.separated; intuition.
    right; intro; apply H1.
    eapply In_m; eauto.
  Qed.

  Require Import Bedrock.sep.Locals.

  Lemma good_inputs_Equal : forall A h1 h2 pairs,
    WordMap.Equal (elt := A) h1 h2
    -> Semantics.good_inputs h1 pairs
    -> Semantics.good_inputs h2 pairs.
    unfold Semantics.good_inputs; intuition.
    eapply Forall_weaken; [ | eassumption ].
    unfold Semantics.word_adt_match; intros.
    destruct x; simpl in *.
    destruct v; auto.
    erewrite <- find_m; eauto.
  Qed.

  Hint Constructors Semantics.RunsTo.

  Lemma store_out_Equal : forall triples h1 h2,
    WordMap.Equal h1 h2
    -> WordMap.Equal
    (fold_left (Semantics.store_out (ADTValue:=ADTValue)) triples h1)
    (fold_left (Semantics.store_out (ADTValue:=ADTValue)) triples h2).
    induction triples; simpl; intuition.
    apply IHtriples.
    unfold Semantics.store_out.
    destruct a; simpl.
    destruct ADTIn; auto.
    destruct ADTOut; auto.
    apply add_m; auto.
    apply remove_m; auto.
  Qed.

  Notation heap_upd_option := (@heap_upd_option ADTValue).

  Lemma heap_upd_option_Equal : forall h1 h2 a b,
    WordMap.Equal h1 h2
    -> WordMap.Equal (heap_upd_option h1 a b) (heap_upd_option h2 a b).
    unfold Semantics.heap_upd_option; intros.
    destruct b; auto.
    apply add_m; auto.
  Qed.

  Ltac t :=
    repeat match goal with
             | [ x := _ |- _ ] => subst x
             | [ H : forall h : WordMap.t _, _, H' : WordMap.Equal _ _ |- _ ] =>
               apply H in H'; clear H;
                 destruct H'; intuition
           end; eauto.

  Require Import Bedrock.Programming.

  Lemma RunsTo_Equal : forall env s st st',
    Semantics.RunsTo (ADTValue := ADTValue) env s st st'
    -> forall h, WordMap.Equal (snd st) h
      -> exists h', WordMap.Equal (snd st') h'
        /\ Semantics.RunsTo (ADTValue := ADTValue) env s (fst st, h) (fst st', h').
    induction 1; intuition eauto.

    t.
    t.
    t.
    t.
    t.

    t.
    simpl in *.
    descend; eauto.
    change (fst v) with (fst (fst v, h)) at 2.
    eapply RunsToCallInternal; eauto.

    t.
    descend; eauto.
    change (fst v) with (fst (fst v, h)) at 2.
    eapply RunsToCallForeign; eauto.
    simpl; eapply good_inputs_Equal; eauto.
    simpl; eapply separated_Equal; eauto.
    apply store_out_Equal; auto.
    simpl.
    apply heap_upd_option_Equal.
    apply store_out_Equal; auto.

    simpl.
    descend; eauto.
    change h with (snd (fst v, h)) at 2.
    change (fst v) with (fst (fst v, h)) at 2.
    eauto.

    t.
    descend; eauto; econstructor.
  Qed.

  Lemma Safe_Equal : forall env s vs h h',
    Semantics.Safe (ADTValue := ADTValue) env s (vs, h)
    -> WordMap.Equal h h'
    -> Semantics.Safe env s (vs, h').
    intros.
    apply (Safe_coind (fun s st =>
      exists h, WordMap.Equal h (snd st)
        /\ Semantics.Safe env s (fst st, h))); eauto; intuition idtac;
    try match goal with
          | [ H : Logic.ex _ |- _ ] => destruct H; intuition idtac
        end.

    inversion_clear H3; eauto.

    inversion_clear H4.
    eapply RunsTo_Equal in H2.
    destruct H2; intuition idtac.
    apply H5 in H6.
    descend; eauto.
    apply Equal_sym; auto.
    apply Equal_sym; auto.

    inversion_clear H3; simpl in *; intuition subst.
    eauto.
    eauto.

    intros.
    destruct H1; intuition.
    inversion H3; clear H3.

    subst loop0 loop1.
    subst.
    left; intuition.
    eauto.
    simpl in *.
    eapply RunsTo_Equal in H1.
    destruct H1; intuition idtac.
    apply H8 in H4.
    descend; eauto.
    apply Equal_sym; auto.
    apply Equal_sym; auto.

    subst loop0 loop1.
    subst.
    right; intuition.

    inversion_clear H3; simpl in *.
    subst vs0 heap fs.
    subst; simpl in *.
    eauto 10.
    subst vs0 heap fs.
    subst; simpl in *.
    right; descend; eauto.
    eapply good_inputs_Equal; eauto.

    inversion_clear H4.
    tauto.
  Qed.

  Notation store_out := (@store_out ADTValue).

  Lemma fold_weaken : forall k v ls h1 h2,
    WordMap.MapsTo k v (fold_left store_out ls h1)
    -> (forall k' v', WordMap.MapsTo k' v' h1 -> WordMap.MapsTo k' v' h2)
    -> WordMap.MapsTo k v (fold_left store_out ls h2).
    induction ls; simpl; intuition.
    eapply IHls; eauto.
    unfold Semantics.store_out; intros.
    destruct a; simpl in *.
    destruct ADTIn; auto.
    destruct ADTOut; auto.
    apply add_mapsto_iff;
      apply add_mapsto_iff in H1; intuition subst.
    eauto.

    apply remove_mapsto_iff;
      apply remove_mapsto_iff in H1; intuition subst.
    eauto.
  Qed.

  Notation store_pair := (@store_pair ADTValue).

  Lemma fold_fwd : forall k v ls h,
    WordMap.MapsTo k v (fold_left store_pair ls h)
    -> WordMap.MapsTo k v h
    \/ List.In (k, ADT v) ls.
    induction ls; simpl; intuition.
    apply IHls in H; intuition.
    unfold SemanticsUtil.store_pair in H0; simpl in H0.
    destruct b; simpl in *; auto.
    apply add_mapsto_iff in H0; intuition subst.
    eauto.
  Qed.

  Lemma foldp_bwd : forall k ls h,
    WordMap.In k h \/ (exists v, List.In (k, ADT v) ls)
    -> WordMap.In k (fold_left store_pair ls h).
    induction ls; simpl; intuition; try destruct b; intuition.
    firstorder.
    Focus 2.
    destruct H0; intuition; try discriminate.
    eauto.
    eapply IHls.
    unfold SemanticsUtil.store_pair; simpl.
    simpl.
    left.
    apply add_in_iff.
    auto.
    destruct H0; intuition.
    injection H0; clear H0; intros; subst.
    apply IHls.
    unfold SemanticsUtil.store_pair; simpl.
    simpl.
    left.
    apply add_in_iff.
    auto.
    eauto.
  Qed.

  Lemma foldp_fwd : forall k ls h,
    WordMap.In k (fold_left store_pair ls h)
    -> WordMap.In k h \/ (exists v, List.In (k, ADT v) ls).
    induction ls; simpl; intuition.
    apply IHls in H; clear IHls; intuition.
    unfold SemanticsUtil.store_pair in H0; simpl in H0.
    destruct b; simpl; auto.
    simpl in H0.
    apply add_in_iff in H0; intuition subst.
    eauto.
    destruct H0.
    eauto.
  Qed.

  Require Import Platform.PreAutoSep.

  Lemma fold_fwd' : forall k v ls h,
    WordMap.MapsTo k v (fold_left store_out ls h)
    -> (WordMap.MapsTo k v h /\ forall a o, ~List.In {| Word := k; ADTIn := ADT a; ADTOut := o |} ls)
    \/ exists a, List.In {| Word := k; ADTIn := ADT a; ADTOut := Some v |} ls.
    induction ls; simpl; intuition.
    apply IHls in H; intuition.

    unfold Semantics.store_out in H; simpl in H.
    destruct a; simpl in *.
    destruct ADTIn.
    left; intuition eauto.
    discriminate.
    destruct ADTOut.
    apply add_mapsto_iff in H; intuition subst.
    eauto.
    left; intuition.
    eauto 2.
    apply remove_mapsto_iff in H; intuition subst.
    left; intuition.
    eauto 2.
    destruct H0.
    eauto.
  Qed.

  Require Import Platform.Cito.WordMap.
  Import WordMap.
  Require Import Platform.Cito.WordMapFacts.

  Lemma heap_merge_store_out :
    forall h pairs outs,
      good_inputs h pairs ->
      let h1 := make_heap pairs in
      let triples := make_triples pairs outs in
      WordMap.Equal (update (diff h h1) (fold_left store_out triples h1))
      (fold_left store_out triples h).
    simpl; intros.
    apply Equal_mapsto_iff; intuition.

    apply update_mapsto_iff in H0; intuition.

    eapply fold_weaken; eauto.
    intros.
    destruct H.
    apply fold_fwd in H0; intuition.
    apply empty_mapsto_iff in H3; tauto.
    eapply Forall_forall in H; try apply H3.
    hnf in H; simpl in H.
    apply WordMap.find_2; auto.

    apply diff_mapsto_iff in H0; intuition subst.

    Lemma In_make_heap' : forall k pairs h,
      WordMap.In (elt:=ADTValue) k (fold_left store_pair pairs h)
      -> WordMap.In k h \/ exists a, List.In (k, ADT a) pairs.
      induction pairs; simpl; intuition.
      apply IHpairs in H; intuition.
      unfold SemanticsUtil.store_pair in H0; simpl in H0.
      destruct b; auto.
      apply add_in_iff in H0; intuition subst.
      eauto.
      destruct H0; intuition subst.
      eauto.
    Qed.

    Lemma In_make_heap : forall k pairs,
      WordMap.In (elt:=ADTValue) k (make_heap pairs)
      -> exists a, List.In (k, ADT a) pairs.
      intros.
      apply In_make_heap' in H; intuition eauto.
      apply empty_in_iff in H0; tauto.
    Qed.

    Lemma keep_when_agrees : forall k e pairs h outs,
      ~WordMap.In k (make_heap pairs)
      -> WordMap.MapsTo k e h
      -> WordMap.MapsTo k e (fold_left store_out (make_triples pairs outs) h).
      induction pairs; destruct outs; simpl; intuition.
      apply IHpairs; clear IHpairs; intros.
      apply H.
      unfold make_heap.
      apply foldp_bwd; right.
      apply In_make_heap in H1; destruct H1; intuition subst.
      simpl; eauto.
      unfold Semantics.store_out; simpl.
      destruct a; simpl in *.
      destruct v; auto.
      destruct o.
      apply WordMap.add_2; auto.
      intro; subst.
      exfalso.
      apply H.
      apply foldp_bwd; simpl; eauto.
      apply WordMap.remove_2; auto.
      intro; subst.
      exfalso.
      apply H.
      apply foldp_bwd; simpl; eauto.
    Qed.

    eapply keep_when_agrees; eauto.

    apply fold_fwd' in H0; intuition idtac.

    Focus 2.
    destruct H1.
    destruct H.

    apply update_mapsto_iff; left.

    Lemma get_pair : forall k x e pairs outs h,
      Semantics.disjoint_ptrs pairs
      -> List.In {| Word := k; ADTIn := ADT x; ADTOut := Some e |} (make_triples pairs outs)
      -> WordMap.MapsTo k e (fold_left store_out (make_triples pairs outs) h).
      induction pairs; destruct outs; simpl; intuition.
      simpl in *; intuition.
      injection H1; clear H1; intros; subst.
      assert (WordMap.MapsTo k e (store_out h {| Word := k; ADTIn := ADT x; ADTOut := Some e |})).
      unfold Semantics.store_out; simpl.
      apply WordMap.add_1; auto.
      generalize dependent (store_out h {| Word := k; ADTIn := ADT x; ADTOut := Some e |}).
      assert (forall v, ~List.In (k, ADT v) pairs).
      intuition.
      hnf in H.
      simpl in H.
      inversion_clear H.
      apply H1.
      change k with (fst (k, ADT v)).
      apply in_map.
      apply filter_In; tauto.
      generalize dependent H0.
      clear.
      generalize dependent outs.
      induction pairs; destruct outs; simpl; intuition.
      apply IHpairs; eauto.
      unfold Semantics.store_out; simpl.
      destruct a; simpl in *.
      destruct v; auto.
      destruct o.
      apply WordMap.add_2; auto.
      intro; subst; eauto.
      apply WordMap.remove_2; auto.
      intro; subst; eauto.

      apply IHpairs.
      hnf in H.
      simpl in H.
      destruct b; simpl in *; auto.
      inversion H; auto.
      auto.
    Qed.

    eapply get_pair; eauto.

    case_eq (WordMap.mem k (make_heap pairs)); intros.

    apply update_mapsto_iff; left; intuition.

    Lemma get_pair' : forall k e pairs outs h,
      Semantics.disjoint_ptrs pairs
      -> WordMap.MapsTo k e h
      -> (forall a o, ~List.In {| Word := k; ADTIn := ADT a; ADTOut := o |} (make_triples pairs outs))
      -> WordMap.MapsTo k e (fold_left store_out (make_triples pairs outs) h).
      induction pairs; destruct outs; simpl; intuition.
      apply IHpairs.
      hnf in H.
      simpl in H.
      destruct b; simpl in H; auto.
      inversion H; auto.
      simpl.
      unfold Semantics.store_out; simpl.
      destruct b; auto.
      destruct o; simpl in *.
      apply WordMap.add_2; auto.
      intro; subst; eauto.
      apply WordMap.remove_2; auto.
      intro; subst; eauto.
      simpl in *.
      eauto.
    Qed.

    apply get_pair'; auto.
    destruct H; auto.
    apply WordMap.mem_2 in H1.
    apply In_make_heap in H1; destruct H1.
    destruct H.
    eapply Forall_forall in H; [ | eassumption ].
    hnf in H; simpl in H.
    apply WordMap.find_1 in H0.
    rewrite H0 in H; injection H; clear H; intros; subst.

    unfold make_heap.

    Lemma grab_it : forall k x pairs h,
      List.In (k, ADT x) pairs
      -> Semantics.disjoint_ptrs pairs
      -> WordMap.MapsTo k x (fold_left store_pair pairs h).
      induction pairs; simpl; intuition; try destruct b; intuition.
      injection H1; clear H1; intros; subst.
      hnf in H0.
      simpl in H0.
      inversion_clear H0.
      generalize dependent H.
      clear IHpairs H1.
      assert (WordMap.MapsTo k x (store_pair h (k, ADT x))).
      unfold SemanticsUtil.store_pair; simpl.
      apply WordMap.add_1; auto.
      generalize dependent (store_pair h (k, ADT x)).
      induction pairs; simpl in *; intuition; try destruct b; intuition.
      simpl in *; intuition subst.
      apply IHpairs.
      unfold SemanticsUtil.store_pair; simpl.
      apply WordMap.add_2; auto.
      auto.

      apply IHpairs; auto.
      hnf in H0.
      simpl in H0.
      inversion_clear H0; auto.
    Qed.

    apply grab_it; auto.

    apply update_mapsto_iff; right; intuition.
    apply diff_mapsto_iff; intuition.
    apply not_mem_in_iff in H3; tauto.
    assert (~WordMap.In k (make_heap pairs)).
    intro.
    apply not_mem_in_iff in H4; tauto.
    clear H1.
    apply H4; clear H4.

    Lemma i_didn't_do_it : forall k ls h,
      (forall a o, ~List.In {| Word := k; ADTIn := ADT a; ADTOut := o |} ls)
      -> WordMap.In k (fold_left store_out ls h)
      -> WordMap.In k h.
      induction ls; simpl; intuition.
      apply IHls in H0; eauto.
      unfold Semantics.store_out in H0.
      destruct a; simpl in *.
      destruct ADTIn; auto.
      destruct ADTOut.
      apply add_in_iff in H0; intuition subst.
      exfalso; eauto.
      apply remove_in_iff in H0; intuition subst.
    Qed.

    eapply i_didn't_do_it; eauto.
  Qed.

  Local Hint Constructors NoDup.

  Theorem In_InA : forall A x ls,
                     List.In x ls -> SetoidList.InA (WordMap.eq_key (elt:=A)) x ls.
    induction ls; simpl; intuition.
  Qed.

  Theorem NoDupA_NoDup : forall A ls,
                           SetoidList.NoDupA (WordMap.eq_key (elt:=A)) ls -> NoDup ls.
    induction 1; eauto.
    constructor; auto.
    intro; apply H.
    eauto using In_InA.
  Qed.

  Theorem In_InA' : forall A x ls,
                      List.In x ls -> SetoidList.InA (WordMap.eq_key_elt (elt:=A)) x ls.
    induction ls; simpl; intuition.
    subst; constructor; hnf; auto.
  Qed.

  Theorem InA_In : forall A x ls,
                     SetoidList.InA (WordMap.eq_key_elt (elt:=A)) x ls -> List.In x ls.
    induction 1; simpl; intuition idtac.
    destruct x, y; simpl in *.
    hnf in H; simpl in *; intuition subst.
    tauto.
  Qed.

  Lemma preserve_store : forall k v pairs h,
    List.Forall (fun p => match snd p with
                            | SCA _ => True
                            | ADT _ => ~WordMap.In (fst p) h
                          end) pairs
    -> NoDup (List.map fst (List.filter (fun p => is_adt (snd p)) pairs))
    -> WordMap.MapsTo k v h
    -> WordMap.MapsTo k v (fold_left store_pair pairs h).
    induction pairs; simpl in *; intuition.
    destruct b as [w | a]; simpl in *.
    inversion_clear H; simpl in *.
    apply IHpairs; auto.

    simpl in *.
    inversion_clear H; simpl in *.
    inversion_clear H0.
    apply IHpairs; auto.
    unfold SemanticsUtil.store_pair; simpl.
    eapply Forall_forall; intros.
    case_eq (snd x); intuition idtac.
    eapply Forall_forall in H3; [ | eassumption ].
    rewrite H5 in *.
    apply add_in_iff in H6; intuition subst.
    apply H.
    apply in_map.
    apply filter_In; intuition idtac.
    unfold is_adt.
    unfold WordMap.key in *.
    rewrite H5; reflexivity.
    unfold SemanticsUtil.store_pair; simpl.
    apply add_mapsto_iff.
    right; intuition subst.
    apply H2.
    exists v; auto.
  Qed.

  Lemma keep_key : forall w a1 pairs,
    List.In (w, ADT a1) pairs
    -> List.In w (List.map fst (List.filter
      (fun p : W * Value ADTValue =>
        match snd p with
          | SCA _ => false
          | ADT _ => true
        end) pairs)).
    induction pairs; simpl; intuition (subst; simpl in *); intuition idtac.
    destruct b; simpl in *; intuition.
  Qed.

  Lemma store_keys : forall k v pairs h,
    WordMap.MapsTo k v (fold_left store_pair pairs h)
    -> List.In (k, ADT v) pairs \/ WordMap.MapsTo k v h.
    induction pairs; simpl; intuition idtac.
    apply IHpairs in H; intuition idtac.
    unfold SemanticsUtil.store_pair in H0; simpl in H0.
    destruct b; auto.
    apply add_mapsto_iff in H0; intuition subst; auto.
  Qed.

  Lemma store_keys'' : forall k v pairs h,
    WordMap.MapsTo k v h
    -> ~ List.In k (List.map fst (List.filter (fun p => is_adt (snd p)) pairs))
    -> WordMap.MapsTo k v (fold_left store_pair pairs h).
    induction pairs; simpl; intuition (try discriminate; eauto);
      unfold is_adt in *; simpl in *.

    destruct b; auto.
    simpl in *; intuition subst.
    apply IHpairs; auto.
    unfold SemanticsUtil.store_pair; simpl.
    apply add_mapsto_iff; auto.
  Qed.

  Lemma store_keys' : forall k v pairs h,
    List.In (k, ADT v) pairs
    -> NoDup (List.map fst (List.filter (fun p => is_adt (snd p)) pairs))
    -> WordMap.MapsTo k v (fold_left store_pair pairs h).
    induction pairs; simpl; intuition (try discriminate; eauto); destruct b; intuition (try discriminate; eauto);
      unfold is_adt in *; simpl in *.

    injection H1; clear H1; intros; subst.
    inversion_clear H0.
    apply store_keys''; auto.
    unfold SemanticsUtil.store_pair; simpl.
    apply add_mapsto_iff; auto.

    inversion_clear H0; eauto.
  Qed.

End ADTValue.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall P Q A B C Dprime Pprime Cprime Dprimeprime Pprimeprime Z Zprime T : Universe, ((wd_ P Q /\ (wd_ T Z /\ (wd_ T Zprime /\ (wd_ T Pprimeprime /\ (wd_ B Cprime /\ (wd_ Cprime Dprimeprime /\ (wd_ B Dprimeprime /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Zprime Z /\ (wd_ B Pprimeprime /\ (wd_ B Z /\ (wd_ Cprime Pprimeprime /\ (wd_ B Pprime /\ (wd_ Dprime B /\ (wd_ Zprime B /\ (wd_ Cprime C /\ (wd_ A Dprime /\ (wd_ Pprime Cprime /\ (col_ A B Zprime /\ (col_ Cprime Pprimeprime T /\ (col_ Cprime Pprimeprime B /\ (col_ B T Pprimeprime /\ (col_ Zprime T Z /\ (col_ B C Z /\ (col_ Cprime Dprimeprime Pprimeprime /\ (col_ B Cprime A /\ col_ B Dprime Pprime)))))))))))))))))))))))))))) -> col_ B Cprime Dprimeprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import type.

Lemma t_eq_dec : forall (n : nat) (x y : t n), {x = y} + {x <> y}.
Proof. Time repeat decide equality. (* does nothing *)
Abort.


Require Import Coq.Strings.String.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.Carriers.
Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.Equality.

Module opt.
  Section syntax.
    Context {T : Type}.

    Inductive item :=
    | Terminal (_ : T)
    | NonTerminal (nt : String.string) (_ : nat).

    Definition production := list item.
    Definition productions := list production.
  End syntax.

  Global Arguments item : clear implicits.
  Global Arguments production : clear implicits.
  Global Arguments productions : clear implicits.

  Section semantics.
    Context {Char : Type} {T : Type}.

    Class compile_item_data :=
      { on_terminal : (Char -> bool) -> T;
        nonterminal_names : list String.string;
        invalid_nonterminal : String.string }.

    Context {cidata : compile_item_data}.
    Definition compile_nonterminal nt
      := List.first_index_default (string_beq nt) (List.length nonterminal_names) nonterminal_names.
    Definition compile_item (expr : Core.item Char) : opt.item T
      := match expr with
         | Core.Terminal ch => Terminal (on_terminal ch)
         | Core.NonTerminal nt => NonTerminal nt (compile_nonterminal nt)
         end.

    Definition compile_production (expr : Core.production Char) : opt.production T
      := List.map compile_item expr.

    Definition compile_productions (expr : Core.productions Char) : opt.productions T
      := List.map compile_production expr.

    Definition compile_grammar (G : pregrammar' Char) : list (productions T)
      := List.map compile_productions (List.map snd (pregrammar_productions G)).
  End semantics.

  Global Arguments compile_item_data : clear implicits.

  Lemma eq_compile_nonterminal {Char T} (G : pregrammar' Char)
        {cidata : @compile_item_data Char T}
        (Hci : nonterminal_names = pregrammar_nonterminals G)
    : forall nt, compile_nonterminal nt = default_of_nonterminal (G:=G) nt.
  Proof.
    destruct cidata; simpl in *; subst; reflexivity.
  Qed.
End opt.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*              Object Primitives                                      *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

Require Import Coqlib.
Require Import Maps.
Require Import AuxStateDataType.
Require Import FlatMemory.
Require Import AbstractDataType.
Require Import Integers.
Require Import Values.
Require Import Constant.
Require Import RealParams.
Require Import CalRealIDPDE.
Require Import CalRealInitPTE.
Require Import CalRealPTPool.
Require Import CalRealPT.
Require Import CalRealSMSPool.
Require Import CalRealProcModule.
Require Import CalRealIntelModule.
Require Import liblayers.compat.CompatGenSem.

Section OBJ_EPT.

  Context `{real_params: RealParams}.

  (** primitive: set value of n-th entry of guest page table layer *)
  (** construct nested page table, with the last layer mapping to undef addr *)
  Function setEPML4_spec (pml4: Z) (adt: RData) : option RData :=
    match (ikern adt, pg adt, ihost adt) with
      | (true, true, true) =>
        if zle_le 0 pml4 (EPT_PML4_INDEX Int.max_unsigned) then
          let ept' := ZMap.set pml4 (EPML4EValid (ZMap.init EPDPTEUndef)) (ept adt) in
          Some adt {ept : ept'}
        else None
      | _ => None
    end.

  Function setEPDPTE_spec (pml4 pdpt: Z) (adt: RData) : option RData :=
    match (ikern adt, pg adt, ihost adt) with
      | (true, true, true) =>
        if zle_le 0 pml4 (EPT_PML4_INDEX Int.max_unsigned) then
          if zle_le 0 pdpt (EPT_PDPT_INDEX Int.max_unsigned) then
            match ZMap.get pml4 (ept adt) with
              | EPML4EValid epdpt =>
                let pdpte' := ZMap.set pdpt (EPDPTEValid (ZMap.init EPDTEUndef)) epdpt in
                let ept' := ZMap.set pml4 (EPML4EValid pdpte') (ept adt) in
	        Some adt {ept : ept'}
              | _ => None
            end
          else None
        else None
      | _ => None
    end.

  Function setEPDTE_spec (pml4 pdpt pdir: Z) (adt: RData) : option RData :=
    match (ikern adt, pg adt, ihost adt) with
      | (true, true, true) =>
        if zle_le 0 pml4 (EPT_PML4_INDEX Int.max_unsigned) then
          if zle_le 0 pdpt (EPT_PDPT_INDEX Int.max_unsigned) then
            if zle_le 0 pdir (EPT_PDIR_INDEX Int.max_unsigned) then
              match ZMap.get pml4 (ept adt) with
                | EPML4EValid epdpt =>
                  match ZMap.get pdpt epdpt with
                    | EPDPTEValid epdt =>
                      let epdt' := ZMap.set pdir (EPDTEValid (ZMap.init EPTEUndef)) epdt in
                      let pdpte' := ZMap.set pdpt (EPDPTEValid epdt') epdpt in
                      let ept' := ZMap.set pml4 (EPML4EValid pdpte') (ept adt) in
	              Some adt {ept : ept'}
                    | _ => None
                  end
                    | _ => None
                  end
            else None
          else None
        else None
      | _ => None
    end.

  Function getEPTE_spec (pml4 pdpt pdir ptab: Z) (adt: RData) : option Z :=
    match (ikern adt, pg adt, ihost adt) with
      | (true, true, true) =>
        if zle_le 0 pml4 (EPT_PML4_INDEX Int.max_unsigned) then
          if zle_le 0 pdpt (EPT_PDPT_INDEX Int.max_unsigned) then
            if zle_le 0 pdir (EPT_PDIR_INDEX Int.max_unsigned) then
              if zle_le 0 ptab (EPT_PTAB_INDEX Int.max_unsigned) then
                  match ZMap.get pml4 (ept adt) with
                    | EPML4EValid epdpt =>
                      match ZMap.get pdpt epdpt with
                        | EPDPTEValid epdt =>
                          match ZMap.get pdir epdt with
                            | EPDTEValid eptab =>
                              match ZMap.get ptab eptab with
                                | EPTEValid hpa => Some hpa
                                | _ => None
                              end
                            | _ => None
                          end
                        | _ => None
                      end
                    | _ => None
                  end
                else None
              else None
            else None
          else None
      | _ => None
    end.

  Function setEPTE_spec (pml4 pdpt pdir ptab hpa: Z) (adt: RData): option RData :=
    match (ikern adt, pg adt, ihost adt) with
      | (true, true, true) =>
        if zle_le 0 pml4 (EPT_PML4_INDEX Int.max_unsigned) then
          if zle_le 0 pdpt (EPT_PDPT_INDEX Int.max_unsigned) then
            if zle_le 0 pdir (EPT_PDIR_INDEX Int.max_unsigned) then
              if zle_le 0 ptab (EPT_PTAB_INDEX Int.max_unsigned) then
                match ZMap.get pml4 (ept adt) with
                  | EPML4EValid epdpt =>
                    match ZMap.get pdpt epdpt with
                      | EPDPTEValid epdt =>
                        match ZMap.get pdir epdt with
                          | EPDTEValid eptab =>
                            let eptab' := ZMap.set ptab (EPTEValid hpa) eptab in
                            let epdt' := ZMap.set pdir (EPDTEValid eptab') epdt in
                            let pdpte' := ZMap.set pdpt (EPDPTEValid epdt') epdpt in
                            let ept' := ZMap.set pml4 (EPML4EValid pdpte') (ept adt) in
                            Some adt {ept : ept'}
                          | _ => None
                        end
                      | _ => None
                    end
                  | _ => None
                end
              else None
            else None
          else None
        else None
      | _ => None
    end.

  Definition EPT_PTAB_INDEX' (i:Z) := i mod five_one_two.
  Definition EPT_PDIR_INDEX' (i:Z) := (i/ five_one_two) mod five_one_two.
  Definition EPT_PDPT_INDEX' (i:Z) := (i/ (five_one_two * five_one_two)) mod five_one_two.
  Definition EPT_PML4_INDEX' (i:Z) := (i/ (five_one_two * five_one_two *
                                           five_one_two)) mod five_one_two.

(*
/*
 * Get the last level's EPT page structure entry for the guest address gpa.
 */
static gcc_inline uint64_t
ept_get_page_entry(uintptr_t gpa)
{
	return ept.ptab[EPT_PDPT_INDEX(gpa)][EPT_PDIR_INDEX(gpa)][EPT_PTAB_INDEX(gpa)];
}*)

  Function ept_get_page_entry_spec (gpa: Z) (adt: RData) : option Z :=
    match (ikern adt, pg adt, ihost adt) with
      | (true, true, true) =>
        if zle_lt 0 gpa maxpage then
          let pml4 := EPT_PML4_INDEX' gpa in
          let pdpt := EPT_PDPT_INDEX' gpa in
          let pdir := EPT_PDIR_INDEX' gpa in
          let ptab := EPT_PTAB_INDEX' gpa in
          match ZMap.get pml4 (ept adt) with
            | EPML4EValid epdpt =>
              match ZMap.get pdpt epdpt with
                | EPDPTEValid epdt =>
                  match ZMap.get pdir epdt with
                    | EPDTEValid eptab =>
                      match ZMap.get ptab eptab with
                        | EPTEValid hpa => Some hpa
                        | _ => None
                      end
                    | _ => None
                  end
                | _ => None
              end
            | _ => None
          end
        else None
      | _ => None
    end.

(*
/*
 * Set the last level's EPT page structure entry for the guest address gpa.
 */
static gcc_inline void
ept_set_page_entry(uintptr_t gpa, uint64_t val)
{
	ept.ptab[EPT_PDPT_INDEX(gpa)][EPT_PDIR_INDEX(gpa)][EPT_PTAB_INDEX(gpa)] = val;
}
*)
  Function ept_set_page_entry_spec (gpa hpa : Z) (adt: RData) : option RData :=
    match (ikern adt, pg adt, ihost adt) with
      | (true, true, true) =>
        if zle_lt 0 gpa maxpage then
          if zle_lt 0 hpa maxpage then
            let pml4 := EPT_PML4_INDEX' gpa in
            let pdpt := EPT_PDPT_INDEX' gpa in
            let pdir := EPT_PDIR_INDEX' gpa in
            let ptab := EPT_PTAB_INDEX' gpa in
            match ZMap.get pml4 (ept adt) with
              | EPML4EValid epdpt =>
                match ZMap.get pdpt epdpt with
                  | EPDPTEValid epdt =>
                    match ZMap.get pdir epdt with
                      | EPDTEValid eptab =>
                        let eptab' := ZMap.set ptab (EPTEValid hpa) eptab in
                        let epdt' := ZMap.set pdir (EPDTEValid eptab') epdt in
                        let pdpte' := ZMap.set pdpt (EPDPTEValid epdt') epdpt in
                        let ept' := ZMap.set pml4 (EPML4EValid pdpte') (ept adt) in
                        Some adt {ept: ept'}
                      | _ => None
                    end
                  | _ => None
                end
              | _ => None
            end
          else None
        else None
      | _ => None
    end.

(*
/*
 * Add page structures which map the guest physical address gpa to the host
 * physical address hpa.
 */
int
ept_add_mapping(uintptr_t gpa, uint64_t hpa, uint32_t mem_type) // I change the type of mem_type
{
    ept.ptab[EPT_PDPT_INDEX(gpa)][EPT_PDIR_INDEX(gpa)][EPT_PTAB_INDEX(gpa)] = (hpa & EPT_ADDR_MASK) |
			EPT_PG_IGNORE_PAT | EPT_PG_EX | EPT_PG_WR | EPT_PG_RD |
			EPT_PG_MEMORY_TYPE(mem_type);

    EPT_DEBUG("Add 4KB mapping: gpa 0x%08x ==> hpa 0x%llx.\n", gpa, hpa);

	return 0;
}

#define	EPT_ADDR_MASK			((uint32_t)-1 << 12)
#define	EPT_PG_RD			(1 << 0)
#define	EPT_PG_WR			(1 << 1)
#define	EPT_PG_EX			(1 << 2)
#define	EPT_PG_IGNORE_PAT		(1 << 6)
#define	EPT_PG_MEMORY_TYPE(x)		((x) << 3)

*)

  Function ept_add_mapping_spec (gpa hpa : Z) (memtype: Z) (adt: RData) : option (RData * Z) :=
    match (ikern adt, pg adt, ihost adt) with
      | (true, true, true) =>
        if zle_lt 0 gpa maxpage then
          if zle_lt 0 hpa maxpage then
            if zle_lt 0 memtype 4096 then
              let pml4 := EPT_PML4_INDEX' gpa in
              let pdpt := EPT_PDPT_INDEX' gpa in
              let pdir := EPT_PDIR_INDEX' gpa in
              let ptab := EPT_PTAB_INDEX' gpa in
              match ZMap.get pml4 (ept adt) with
                | EPML4EValid epdpt =>
                  match ZMap.get pdpt epdpt with
                    | EPDPTEValid epdt =>
                      match ZMap.get pdir epdt with
                        | EPDTEValid eptab =>
                          let va := Z.lor (Z.lor (Z.land hpa EPT_ADDR_MASK) EPT_PG_IGNORE_PAT_or_PERM)
                                          (Z.shiftl memtype EPT_PG_MEMORY_TYPE) in
                          let eptab' := ZMap.set ptab (EPTEValid va) eptab in
                          let epdt' := ZMap.set pdir (EPDTEValid eptab') epdt in
                          let pdpte' := ZMap.set pdpt (EPDPTEValid epdt') epdpt in
                          let ept' := ZMap.set pml4 (EPML4EValid pdpte') (ept adt) in
                          Some (adt {ept: ept'}, 0)
                        | _ => None
                      end
                    | _ => None
                  end
                | _ => None
              end
            else None
          else None
        else None
      | _ => None
    end.

(*

/*
 * Invalidate the EPT TLB.
 */
void
ept_invalidate_mappings(uint64_t pml4ept)
{
	invept(INVEPT_TYPE_SINGLE_CONTEXT, EPTP(pml4ept));
}
 *)
  Function ept_invalidate_mappings_spec (adt: RData) :=
    match (ikern adt, ihost adt) with
      | (true, true) => Some 0
      | _ => None
    end.

(*
/*
 * Convert the guest physical address to the host physical address.
 */

#define EPT_PAGE_OFFSET(gpa)		((gpa) & EPT_ADDR_OFFSET_MASK)
#define EPT_ADDR_OFFSET_MASK		((1 << 12) - 1)

uint64_t
ept_gpa_to_hpa(uintptr_t gpa)
{
    uint64_t entry;

    entry = ept_get_page_entry(gpa);

    if (!(entry & (EPT_PG_RD | EPT_PG_WR | EPT_PG_EX)))
        return 0;

    return ((entry & EPT_ADDR_MASK) | EPT_PAGE_OFFSET(gpa));
}*)

  Function ept_gpa_to_hpa_spec (gpa: Z) (adt: RData) : option Z :=
    match ept_get_page_entry_spec gpa adt with
      | Some hpa =>
        if zle_le 0 hpa Int.max_unsigned then
          if zeq (Z.land hpa EPTEPERM) 0 then (Some 0)
          else let va := Z.lor (Z.land hpa EPT_ADDR_MASK)
                             (Z.land gpa EPT_ADDR_OFFSET_MASK) in
             Some va
        else None
      | _ => None
    end.

(*
int
ept_mmap(uintptr_t gpa, uint64_t hpa, uint8_t mem_type)
{
	uint64_t pg_entry;

	/*
	 * XXX: ASSUME 4KB pages are used in both the EPT and the host page
	 *      structures.
	 */
	KERN_ASSERT(gpa == ROUNDDOWN(gpa, PAGESIZE));
	KERN_ASSERT(hpa == ROUNDDOWN(hpa, PAGESIZE));

	pg_entry = ept_get_page_entry(gpa);

	if (((pg_entry) & (EPT_PG_RD | EPT_PG_WR | EPT_PG_EX)))
	{
		KERN_WARN("Guest page 0x%08x is already mapped to 0x%llx.\n",
			  gpa, (pg_entry & EPT_ADDR_MASK));
		return 1;
	}

	return ept_add_mapping(gpa, hpa, mem_type);
}*)

  Function ept_mmap_spec (gpa hpa : Z) (memtype: Z) (adt: RData) : option (RData * Z) :=
    match ept_get_page_entry_spec gpa adt with
      | Some hpa' =>
        if (zle_le 0 hpa' Int.max_unsigned) then
              if zle_lt 0 memtype 4096 then

                (if zeq (Z.land hpa' EPTEPERM) 0
                 then ept_add_mapping_spec gpa hpa memtype adt
                 else Some (adt, 1))
              else None
        else None
      | _ => None
    end.

(*
/*
 * Set the access permission of the guest physical address gpa.
 */
void
ept_set_permission(uintptr_t gpa, uint32_t perm): Change the type of perm
{
	uint64_t entry;

	entry = ept_get_page_entry(gpa);

	ept_set_page_entry(gpa, (entry & ~(uint64_t) 0x7) | (perm & 0x7));

	return;
}*)

  Function ept_set_permission_spec (gpa perm: Z) (adt: RData) : option RData :=
    match ept_get_page_entry_spec gpa adt with
      | Some hpa' =>
        if (zle_le 0 hpa' Int.max_unsigned) then
        (let hpa := Z.lor (Z.land hpa' EPT_NO_PERM)
                         (Z.land perm EPTEPERM) in
        ept_set_page_entry_spec gpa hpa adt)
        else None
      | _ => None
    end.

  Function ept_init_spec (mbi_adr:Z) (adt: RData) : option RData :=
    match (init adt, pg adt, ikern adt, ihost adt, ipt adt) with
      | (false, false, true, true, true) =>
        Some adt {vmxinfo: real_vmxinfo} {pg: true} {LAT: real_LAT (LAT adt)} {nps: real_nps}
             {AC: real_AC} {init: true} {PT: 0} {ptpool: real_pt (ptpool adt)}
             {idpde: real_idpde (idpde adt)}
             {smspool: real_smspool (smspool adt)}
             {abtcb: ZMap.set 0 (AbTCBValid RUN (-1)) (real_abtcb (abtcb adt))}
             {abq: real_abq (abq adt)} {cid: 0} {syncchpool: real_syncchpool (syncchpool adt)}
             {ept: real_ept (ept adt)}
      | _ => None
    end.

End OBJ_EPT.

Require Import liblayers.compat.CompatGenSem.
Require Import liblayers.compat.CompatLayers.
Require Import CommonTactic.
Require Import RefinementTactic.
Require Import PrimSemantics.
Require Import AuxLemma.

Section OBJ_SIM.

  Context `{data : CompatData RData}.
  Context `{data0 : CompatData RData}.

  Context `{Hstencil: Stencil}.
  Context `{Hmem: Mem.MemoryModel}.
  Context `{Hmwd: UseMemWithData mem}.

  Notation HDATAOps := (cdata (cdata_prf := data) RData).
  Notation LDATAOps := (cdata (cdata_prf := data0) RData).

  Context `{rel_prf: CompatRel _ (memory_model_ops:= memory_model_ops) _
                               (stencil_ops:= stencil_ops) HDATAOps LDATAOps}.

  Section EPT_GET_PAGE_ENTRY_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_ept}.

    Lemma ept_get_page_entry_exist:
      forall s habd labd gpa hpa f,
        ept_get_page_entry_spec gpa habd = Some hpa
        -> relate_AbData s f habd labd
        -> ept_get_page_entry_spec gpa labd = Some hpa.
    Proof.
      unfold ept_get_page_entry_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_ept_eq; eauto. intros.
      revert H. subrewrite.
    Qed.

  End EPT_GET_PAGE_ENTRY_SIM.

  Section EPT_SET_PAGE_ENTRY_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_ept}.

    Lemma ept_set_page_entry_exist:
      forall s habd habd' labd gpa hpa' f,
        ept_set_page_entry_spec gpa hpa' habd = Some habd'
        -> relate_AbData s f habd labd
        -> exists labd', ept_set_page_entry_spec gpa hpa' labd = Some labd'
                         /\ relate_AbData s f habd' labd'.
    Proof.
      unfold ept_set_page_entry_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_ept_eq; eauto. intros.
      revert H. subrewrite. subdestruct.
      inv HQ; refine_split'; trivial.

      apply relate_impl_ept_update. assumption.
    Qed.

  End EPT_SET_PAGE_ENTRY_SIM.

  Section EPT_ADD_MAPPING_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2 : relate_impl_ept}.

    Lemma ept_add_mapping_exist:
      forall s habd habd' labd gpa hpa' memtype n f,
        ept_add_mapping_spec gpa hpa' memtype habd = Some (habd', n)
        -> relate_AbData s f habd labd
        -> exists labd', ept_add_mapping_spec gpa hpa' memtype labd = Some (labd', n)
                         /\ relate_AbData s f habd' labd'.
    Proof.
      Local Opaque Z.shiftl.

      unfold ept_add_mapping_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_ept_eq; eauto. intros.
      revert H. subrewrite. subdestruct.
      inv HQ; refine_split'; trivial.

      apply relate_impl_ept_update. assumption.
    Qed.

    Context {mt1: match_impl_iflags}.
    Context {mt2: match_impl_ept}.

    Lemma ept_add_mapping_match:
      forall s d d' m gpa hpa' memtype n f,
        ept_add_mapping_spec gpa hpa' memtype d = Some (d', n)
        -> match_AbData s d m f
        -> match_AbData s d' m f.
    Proof.
      unfold ept_add_mapping_spec; intros. subdestruct; inv H; trivial.
      eapply match_impl_ept_update. assumption.
    Qed.

    Context {inv: PreservesInvariants (HD:= data) ept_add_mapping_spec}.
    Context {inv0: PreservesInvariants (HD:= data0) ept_add_mapping_spec}.

    Lemma ept_add_mapping_sim :
      forall id,
        sim (crel RData RData) (id ↦ gensem ept_add_mapping_spec)
            (id ↦ gensem ept_add_mapping_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      exploit ept_add_mapping_exist; eauto 1; intros [labd' [HP HM]].
      match_external_states_simpl.
      eapply ept_add_mapping_match; eauto.
    Qed.

  End EPT_ADD_MAPPING_SIM.

  Section EPT_GPA_TO_HPA_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2 : relate_impl_ept}.

    Lemma ept_gpa_to_hpa_exist:
      forall s habd labd gpa va f,
        ept_gpa_to_hpa_spec gpa habd = Some va
        -> relate_AbData s f habd labd
        -> ept_gpa_to_hpa_spec gpa labd = Some va.
    Proof.
      Local Opaque Z.land Z.lor.

      unfold ept_gpa_to_hpa_spec. intros.
      destruct (ept_get_page_entry_spec gpa habd) eqn:Hdestruct; try discriminate.
      exploit ept_get_page_entry_exist; eauto. intros.
      revert H. subrewrite.
    Qed.

  End EPT_GPA_TO_HPA_SIM.

  Section EPT_MMAP_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2 : relate_impl_ept}.

    Lemma ept_mmap_exist:
      forall s habd habd' labd gpa hpa' memtype n f,
        ept_mmap_spec gpa hpa' memtype habd = Some (habd', n)
        -> relate_AbData s f habd labd
        -> exists labd', ept_mmap_spec gpa hpa' memtype labd = Some (labd', n)
                         /\ relate_AbData s f habd' labd'.
    Proof.
      Local Opaque Z.land.

      unfold ept_mmap_spec; intros.
      destruct (ept_get_page_entry_spec gpa habd) eqn:Hdestruct; try discriminate.
      exploit ept_get_page_entry_exist; eauto. intros.
      revert H. subrewrite. subdestruct.

      - eapply ept_add_mapping_exist; eassumption.
      - inv HQ; refine_split'; trivial.
    Qed.

  End EPT_MMAP_SIM.

  Section EPT_SET_PERMISSION_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2 : relate_impl_ept}.

    Lemma ept_set_permission_exist:
      forall s habd habd' labd gpa perm f,
        ept_set_permission_spec gpa perm habd = Some habd'
        -> relate_AbData s f habd labd
        -> exists labd', ept_set_permission_spec gpa perm labd = Some labd'
                         /\ relate_AbData s f habd' labd'.
    Proof.
      Local Opaque Z.land Z.lor.

      unfold ept_set_permission_spec; intros.
      destruct (ept_get_page_entry_spec gpa habd) eqn:Hdestruct; try discriminate.
      exploit ept_get_page_entry_exist; eauto. intros.
      subrewrite'. subdestruct.

      eapply ept_set_page_entry_exist; eassumption.
    Qed.

  End EPT_SET_PERMISSION_SIM.

  Section EPT_INIT_SIM.

    Context `{real_params: RealParams}.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_ipt}.
    Context {re3: relate_impl_LAT}.
    Context {re4: relate_impl_nps}.
    Context {re5: relate_impl_init}.
    Context {re6: relate_impl_PT}.
    Context {re7: relate_impl_ptpool}.
    Context {re8: relate_impl_idpde}.
    Context {re9: relate_impl_smspool}.
    Context {re10: relate_impl_abtcb}.
    Context {re11: relate_impl_abq}.
    Context {re12: relate_impl_cid}.
    Context {re13: relate_impl_syncchpool}.
    Context {re14: relate_impl_vmxinfo}.
    Context {re15: relate_impl_ept}.
    Context {re16: relate_impl_AC}.

    Lemma ept_init_exist:
      forall s habd habd' labd mbi_adr f,
        ept_init_spec mbi_adr habd = Some habd'
        -> relate_AbData s f habd labd
        -> exists labd', ept_init_spec mbi_adr labd = Some labd'
                         /\ relate_AbData s f habd' labd'.
    Proof.
      unfold ept_init_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_ipt_eq; eauto.
      exploit relate_impl_init_eq; eauto.
      exploit relate_impl_LAT_eq; eauto.
      exploit relate_impl_ptpool_eq; eauto.
      exploit relate_impl_idpde_eq; eauto.
      exploit relate_impl_cid_eq; eauto.
      exploit relate_impl_abq_eq; eauto.
      exploit relate_impl_abtcb_eq; eauto.
      exploit relate_impl_syncchpool_eq; eauto.
      exploit relate_impl_vmxinfo_eq; eauto.
      exploit relate_impl_smspool_eq; eauto.
      exploit relate_impl_ept_eq; eauto. intros.
      revert H. subrewrite. subdestruct.
      inv HQ; refine_split'; trivial.

      apply relate_impl_ept_update.
      apply relate_impl_syncchpool_update.
      apply relate_impl_cid_update.
      apply relate_impl_abq_update.
      apply relate_impl_abtcb_update.
      apply relate_impl_smspool_update.
      apply relate_impl_idpde_update.
      apply relate_impl_ptpool_update.
      apply relate_impl_PT_update.
      apply relate_impl_init_update.
      apply relate_impl_AC_update.
      apply relate_impl_nps_update.
      apply relate_impl_LAT_update.
      apply relate_impl_pg_update.
      apply relate_impl_vmxinfo_update.
      assumption.
    Qed.

    Context {mt1: match_impl_iflags}.
    Context {mt2: match_impl_ipt}.
    Context {mt3: match_impl_LAT}.
    Context {mt4: match_impl_nps}.
    Context {mt5: match_impl_init}.
    Context {mt6: match_impl_PT}.
    Context {mt7: match_impl_ptpool}.
    Context {mt8: match_impl_idpde}.
    Context {mt9: match_impl_smspool}.
    Context {mt10: match_impl_abtcb}.
    Context {mt11: match_impl_abq}.
    Context {mt12: match_impl_cid}.
    Context {mt13: match_impl_syncchpool}.
    Context {mt14: match_impl_vmxinfo}.
    Context {mt15: match_impl_ept}.
    Context {mt16: match_impl_AC}.

    Lemma ept_init_match:
      forall s d d' m  mbi_adr f,
        ept_init_spec mbi_adr d = Some d'
        -> match_AbData s d m f
        -> match_AbData s d' m f.
    Proof.
      unfold ept_init_spec; intros. subdestruct. inv H.
      eapply match_impl_ept_update.
      eapply match_impl_syncchpool_update.
      eapply match_impl_cid_update.
      eapply match_impl_abq_update.
      eapply match_impl_abtcb_update.
      eapply match_impl_smspool_update.
      eapply match_impl_idpde_update.
      eapply match_impl_ptpool_update.
      eapply match_impl_PT_update.
      eapply match_impl_init_update.
      eapply match_impl_AC_update.
      eapply match_impl_nps_update.
      eapply match_impl_LAT_update.
      eapply match_impl_pg_update.
      eapply match_impl_vmxinfo_update.
      assumption.
    Qed.

    Context {inv: PreservesInvariants (HD:= data) ept_init_spec}.
    Context {inv0: PreservesInvariants (HD:= data0) ept_init_spec}.

    Lemma ept_init_sim :
      forall id,
        sim (crel RData RData) (id ↦ gensem ept_init_spec)
            (id ↦ gensem ept_init_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      exploit ept_init_exist; eauto 1; intros [labd' [HP HM]].
      match_external_states_simpl.
      eapply ept_init_match; eauto.
    Qed.

  End EPT_INIT_SIM.

  Section EPT_INV_SIM.

    Context {re1: relate_impl_iflags}.

    Lemma ept_invalidate_mappings_exists:
      forall habd labd z s f,
        ept_invalidate_mappings_spec habd = Some z ->
        relate_AbData s f habd labd ->
        ept_invalidate_mappings_spec labd = Some z.
    Proof.
      unfold ept_invalidate_mappings_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      revert H. subrewrite.
    Qed.

    Lemma ept_invalidate_mappings_sim:
      forall id,
        sim (crel RData RData) (id ↦ gensem ept_invalidate_mappings_spec)
            (id ↦ gensem ept_invalidate_mappings_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      match_external_states_simpl.
      erewrite ept_invalidate_mappings_exists; eauto.
      reflexivity.
    Qed.

  End EPT_INV_SIM.

End OBJ_SIM.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  Defining type safety, page 67.

*)

Set Implicit Arguments.
Require Export LanguageModuleDef.
Require Export StaticSemanticsKindingAndContextWellFormedness.
Require Export StaticSemanticsKindingAndContextWellFormednessLemmas.
Require Export TermWeakeningProof.
Require Export Tacticals.

(* May need some lemmas from the 3 case. *)

Lemma A_3_Heap_Weakening_1_strengthen_quantification:
  forall (u u' : Upsilon) (g g': Gamma),
    U.extends u u' = true ->
    G.extends g g' = true ->
    WFC ddot u' g' ->
    forall (h : Heap) (g'' : Gamma),
      htyp u g h g'' ->
      htyp u' g' h g''.
Proof.
  intros u u' g g' uext gext WFCder h g'' htypder.
  htyp_ind_cases (induction htypder) Case; try solve[crush].
  Case "htyp u g h ([(x, tau)] ++ g')".
   apply htyp_xv with (h':= h') (v:= v); try assumption.
   apply IHhtypder in uext; try assumption.
   apply A_2_Term_Weakening_3 with (u:= u') (g:= g') ; try assumption.
   admit.
   apply U.extends_refl.
   admit.
   apply G.extends_refl.
   admit.
Admitted.

(* Correct. *)

Lemma A_3_Heap_Weakening_2:
  forall (u : Upsilon) (h : H),
    refp h u ->
    forall (h' : H),
      refp (h ++ h') u.
Proof.
  intros u h refpder.
  refp_ind_cases (induction refpder) Case.
  Case  "refp h []".
   intros.
   constructor.
  Case "refp h ([(x, p, tau')] ++ u)".
   intros.
   apply refp_pack
   with (tau:= tau) (alpha:= alpha) (k:= k) (v:= v) (v':= v'); try assumption.
   apply getH_Some_weakening; try assumption.
   apply refp_weakening; try assumption.
Qed.