Require Import Bool Arith List Omega ListSet.
Require Import Recdef Morphisms.
Require Import Program.Tactics.
Require Import Relation_Operators.
Require FMapList.
Require FMapFacts.
Require Import Classical.
Require Import Coq.Classes.RelationClasses.
Require Import OrderedType OrderedTypeEx DecidableType.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Sorting.Permutation.
Import ListNotations.
Require Import SImpECommon.

(*******************************************************************************
*
* SYNTAX
*
*******************************************************************************)

Section Syntax.
  Definition enclave : Type := nat.
  Inductive mode : Type :=
  | Normal : mode
  | Encl : enclave -> mode.

  Inductive exp : Type :=
  | Enat : nat -> exp
  | Evar : var -> exp
  | Eadd : exp -> exp -> exp
  | Eloc : location -> exp
  | Ederef : exp -> exp
  | Elambda : mode -> com -> exp

  with com : Type :=
  | Cskip : com
  | Cassign : var -> exp -> com
  | Cdeclassify : var -> exp -> com
  | Cupdate : exp -> exp -> com
  | Coutput : exp -> sec_level -> com
  | Ccall : exp -> com
  | Cenclave : enclave -> com -> com
  | Cseq : list com -> com
  | Cif : exp -> com -> com -> com
  | Cwhile : exp -> com -> com.

  Inductive val : Type :=
  | Vlambda : mode -> com -> val
  | Vnat : nat -> val
  | Vloc : location -> val.

  Function forall_subexp (e: exp) (P: exp -> Prop) : Prop :=
    P e /\
    match e with
    | Eadd e1 e2 => forall_subexp e1 P /\ forall_subexp e2 P
    | Ederef e' => forall_subexp e' P
    | Elambda _ c => forall_subexp' c P
    | _ => True
    end
  with forall_subexp' (c: com) (P: exp -> Prop) : Prop :=
    match c with
    | Cassign _ e => forall_subexp e P
    | Cdeclassify _ e => forall_subexp e P
    | Cupdate e1 e2 => forall_subexp e1 P /\ forall_subexp e2 P
    | Ccall e => forall_subexp e P
    | Cenclave _ c' => forall_subexp' c' P
    | Cseq cs => fold_left (fun acc c => forall_subexp' c P /\ acc) cs True
    | Cif e c1 c2 =>
      forall_subexp e P /\ forall_subexp' c1 P /\ forall_subexp' c2 P
    | Cwhile e c' => forall_subexp e P /\ forall_subexp' c' P
    | _ => True
    end.

  Definition exp_novars (e: exp) : Prop :=
    forall_subexp e (fun e =>
                       match e with
                       | Evar _ => False
                       | _ => True
                       end).

End Syntax.

Section Induction.
  Variable P : com -> Type.
  Variable P0: exp -> Type.

  Inductive Forall' (Q : com -> Type) : list com -> Type :=
  | Forall_nil' : Forall' Q nil
  | Forall_cons' : forall x l, Q x -> Forall' Q l -> Forall' Q (x::l).

  Hypothesis Enat_case : forall n, P0 (Enat n).
  Hypothesis Evar_case : forall x, P0 (Evar x).
  Hypothesis Eadd_case : forall e1 e2,
      P0 e1 -> P0 e2 -> P0 (Eadd e1 e2).
  Hypothesis Eloc_case : forall l, P0 (Eloc l).
  Hypothesis Ederef_case : forall e,
      P0 e -> P0 (Ederef e).
  Hypothesis Elambda_case : forall md c,
      P c -> P0 (Elambda md c).

  Hypothesis Cskip_case : P Cskip.
  Hypothesis Cassign_case : forall x e,
      P0 e -> P (Cassign x e).
  Hypothesis Cdeclassify_case : forall x e,
      P0 e -> P (Cdeclassify x e).
  Hypothesis Cupdate_case : forall e1 e2,
      P0 e1 -> P0 e2 -> P (Cupdate e1 e2).
  Hypothesis Coutput_case : forall e sl,
      P0 e -> P (Coutput e sl).
  Hypothesis Ccall_case : forall e,
      P0 e -> P (Ccall e).
  Hypothesis Cenclave_case : forall enc c,
      P c -> P (Cenclave enc c).
  Hypothesis Cseq_case : forall coms,
      Forall' P coms -> P (Cseq coms).
  Hypothesis Cif_case : forall e c1 c2,
      P0 e -> P c1 -> P c2 -> P (Cif e c1 c2).
  Hypothesis Cwhile_case : forall e c,
      P0 e -> P c -> P (Cwhile e c).

  Fixpoint com_rect' (c: com) : P c :=
    match c with
    | Cskip => Cskip_case
    | Cassign x e => Cassign_case x e (exp_rect' e)
    | Cdeclassify x e => Cdeclassify_case x e (exp_rect' e)
    | Cupdate e1 e2 => Cupdate_case e1 e2 (exp_rect' e1) (exp_rect' e2)
    | Coutput e sl => Coutput_case e sl (exp_rect' e)
    | Ccall e => Ccall_case e (exp_rect' e)
    | Cenclave enc c => Cenclave_case enc c (com_rect' c)
    | Cseq coms =>
      Cseq_case coms
                ((fix com_list_rect (coms: list com) : Forall' P coms :=
                    match coms with
                    | [] => Forall_nil' P
                    | h :: t => Forall_cons' P h t (com_rect' h) (com_list_rect t)
                    end) coms)
    | Cif e c1 c2 =>
      Cif_case e c1 c2 (exp_rect' e) (com_rect' c1) (com_rect' c2)
    | Cwhile e c => Cwhile_case e c (exp_rect' e) (com_rect' c)
    end

  with
  exp_rect' (e: exp) : P0 e :=
    match e with
    | Enat n => Enat_case n
    | Evar x => Evar_case x
    | Eadd e1 e2 => Eadd_case e1 e2 (exp_rect' e1) (exp_rect' e2)
    | Eloc l => Eloc_case l
    | Ederef e => Ederef_case e (exp_rect' e)
    | Elambda md c => Elambda_case md c (com_rect' c)
    end.

End Induction.

Section Decidability.

  Ltac auto_decide :=
    try match goal with
        | [x : nat, y : nat |- _] => destruct (Nat.eq_dec x y)
        | [x : var, y : var |- _] => destruct (Nat.eq_dec x y)
        | [x : enclave, y : enclave |- _] => destruct (Nat.eq_dec x y)
        | [x : location, y : location |- _] => destruct (Nat.eq_dec x y)
        | _ => idtac
        end; [left; now subst | right; congruence].

   Ltac easy_dec :=
     subst; auto; right; congruence.

  Lemma mode_decidable : forall m1 m2 : mode, {m1 = m2} + {m1 <> m2}.
  Proof.
    intros; destruct m1; destruct m2; try (right; discriminate).
    - left; auto.
    - destruct (Nat.eq_dec e e0); [left; now subst | right; congruence].
  Qed.

   Lemma exp_decidable : forall (e1 e2 : exp), {e1 = e2} + {e1 <> e2}.
  Proof.
    intro.
    induction e1 using exp_rect' with
    (P := fun c1 =>
            forall c2, {c1 = c2} + {c1 <> c2}); intros.
    1-6: destruct e2; try (right; discriminate).
    7-14,16: destruct c2; try (right; discriminate).
    1-2, 4: auto_decide.
    - destruct IHe1_1 with e2_1; destruct IHe1_2 with e2_2; easy_dec.
    - destruct IHe1 with e2; easy_dec.
    - destruct IHe1 with c0; destruct (mode_decidable md m); easy_dec.
    - auto.
    - destruct IHe1 with e; subst; [auto_decide | right; congruence].
    - destruct IHe1 with e; subst; [auto_decide | right; congruence].
    - destruct IHe1_1 with e; destruct IHe1_2 with e0; easy_dec.
    - destruct s; destruct sl; destruct IHe1 with e; easy_dec.
    - destruct IHe1 with e; easy_dec.
    - destruct IHe1 with c2; subst; [auto_decide | right; congruence].
    - generalize l; induction coms; intros; destruct l0; try (right; discriminate); auto.
      inversion X; subst.
      destruct X0 with c; try (right; congruence).
      apply IHcoms with (l := l0) in X1.
      destruct X1; subst.
      + left; inversion e0; subst; auto.
      + right; congruence.
    - destruct IHe1 with e; destruct IHe0 with c2; easy_dec.
    - destruct c0; try (right; discriminate).
      destruct IHe1 with e; destruct IHe0 with c0_1; destruct IHe2 with c0_2; easy_dec.
  Qed.

  Lemma com_decidable : forall (c1 c2 : com), {c1 = c2} + {c1 <> c2}.
  Proof.
    intro.
    induction c1 using com_rect' with
    (P0 := fun e1 =>
             forall e2, {e1 = e2} + {e1 <> e2}); intros.
    1-2, 4-6: destruct e2; try (right; discriminate).
    7-16: destruct c2; try (right; discriminate).
    1-3: auto_decide.
    - destruct IHc1 with e2; easy_dec.
    - destruct IHc1 with c; destruct (mode_decidable md m); easy_dec.
    - destruct e0; try (right; discriminate);
        destruct IHc1 with e0_1; destruct IHc0 with e0_2; easy_dec.
    - auto.
    - destruct IHc1 with e0; subst; [auto_decide | right; congruence].
    - destruct IHc1 with e0; subst; [auto_decide | right; congruence].
    - destruct IHc1 with e; destruct IHc0 with e0; easy_dec.
    - destruct s; destruct sl; destruct IHc1 with e0; easy_dec.
    - destruct IHc1 with e0; easy_dec.
    - destruct IHc1 with c2; subst; [auto_decide | right; congruence].
    - generalize l; induction coms; intros; destruct l0; try (right; discriminate); auto.
      inversion X; subst.
      destruct X0 with c; try (right; congruence).
      apply IHcoms with (l := l0) in X1.
      destruct X1; subst.
      + left; inversion e0; subst; auto.
      + right; congruence.
    - destruct IHc1_1 with e0; destruct IHc1_2 with c2_1; destruct IHc1_3 with c2_2; easy_dec.
    - destruct IHc1 with e0; destruct IHc0 with c2; easy_dec.
  Qed.

  Lemma val_decidable : forall (v1 v2 : val), {v1 = v2} + {v1 <> v2}.
  Proof.
    intro.
    induction v1; intros; destruct v2; try (right; discriminate); try auto_decide.
    destruct (mode_decidable m m0); destruct (com_decidable c c0); easy_dec.
  Qed.

  Lemma prog_decidable : forall p1 p2 : (com + exp), {p1 = p2} + {p1 <> p2}.
  Proof.
    intros; destruct p1; destruct p2; try (right; discriminate);
      [destruct (com_decidable c c0) | destruct (exp_decidable e e0)]; easy_dec.
  Qed.

  Lemma mode_prog_decidable : forall ep1 ep2 : (mode * (com + exp)), {ep1 = ep2} + {ep1 <> ep2}.
  Proof.
    intros; destruct ep1, ep2; destruct (mode_decidable m m0); destruct (prog_decidable s s0);
      easy_dec.
  Qed.

End Decidability.

(*******************************************************************************
*
* ENCLAVE EQUIVALENCE
*
*******************************************************************************)

Section Enclave_Equiv.
  Fixpoint chi (c : com) : set (mode * (com + exp)) :=
  let chi_exp :=
      (fix chi_exp (e : exp) : set (mode * (com + exp)) :=
         match e with
         | Eadd e1 e2 => set_union mode_prog_decidable (chi_exp e1) (chi_exp e2)
         | Ederef e1 => chi_exp e1
         | Elambda Normal c => chi c
         | Elambda m _ => set_add mode_prog_decidable (m, inr e) nil
         | _ => nil
         end)

  in
  match c with
  | Cassign _ e => chi_exp e
  | Cdeclassify _ e => chi_exp e
  | Cupdate e1 e2 => set_union mode_prog_decidable (chi_exp e1) (chi_exp e2)
  | Coutput e _ => chi_exp e
  | Ccall e => chi_exp e
  | Cenclave enc c1 => set_add mode_prog_decidable (Encl enc, inl c1) nil
  | Cseq c_lst => fold_left (fun acc elt => set_union mode_prog_decidable (chi elt) acc) c_lst nil
  | Cif e c1 c2 => set_union mode_prog_decidable (chi_exp e)
                            (set_union mode_prog_decidable (chi c1) (chi c2))
  | _ => nil
  end.

  Definition enc_equiv (c1 c2 : com) := chi c1 = chi c2 -> Prop.

End Enclave_Equiv.

(*******************************************************************************
*
* SEMANTICS
*
*******************************************************************************)

Section Semantics.
  Definition reg : Type := register val.
  Definition reg_init : reg := fun x => Vnat 0.
  Definition mem : Type := memory val.
  Definition loc_mode : Type := location -> mode.

  Inductive event : Type :=
  | Decl : exp -> mem -> event
  | Mem : mem -> event
  | Out : sec_level -> val -> event
  | Update : mem -> location -> val -> event
  | Assign : reg -> var -> val -> event
  | ANonEnc : com -> event
  | AEnc : forall c c' : com, enc_equiv c c'-> event
  | Emp: event.
  Definition trace : Type := list event.
  (* Adding empty to the front of a trace doesn't change it *)
  Axiom emp_eq : forall t,
      Emp :: t = t.

  Definition mode_access_ok (md: mode) (d: loc_mode) (l: location) :=
    let lmd := d l in
    match lmd with
    | Normal => True
    | Encl _ => md = lmd
    end.

  Definition econfig : Type := exp * reg * mem.
  Definition ecfg_exp (ecfg: econfig) : exp :=
    match ecfg with (e, _, _) => e end.
  Definition ecfg_reg (ecfg: econfig) : reg :=
    match ecfg with (_, r, _) => r end.
  Definition ecfg_update_exp (ecfg: econfig) (e: exp) : econfig :=
    match ecfg with (_, r, m) => (e, r, m) end.
  Definition esemantics : Type := mode -> loc_mode -> econfig -> val -> Prop.

  Inductive estep : esemantics :=
  | Estep_nat : forall md d ecfg n,
      ecfg_exp ecfg = Enat n ->
      estep md d ecfg (Vnat n)
  | Estep_loc : forall md d ecfg l,
      ecfg_exp ecfg = Eloc l ->
      estep md d ecfg (Vloc l)
  | Estep_lambda : forall md d ecfg c,
      ecfg_exp ecfg = Elambda md c ->
      estep md d ecfg (Vlambda md c)
  | Estep_var : forall md d ecfg x v,
      ecfg_exp ecfg = Evar x ->
      ecfg_reg ecfg x = v ->
      estep md d ecfg v
  | Estep_add : forall md d ecfg e1 e2 n1 n2,
      ecfg_exp ecfg = Eadd e1 e2 ->
      estep md d (ecfg_update_exp ecfg e1) (Vnat n1) ->
      estep md d (ecfg_update_exp ecfg e2) (Vnat n2) ->
      estep md d ecfg (Vnat (n1 + n2))
  | Estep_deref : forall md d ecfg e r m l v,
      ecfg = (Ederef e, r, m) ->
      estep md d (e, r, m) (Vloc l) ->
      m l = v ->
      mode_access_ok md d l ->
      estep md d ecfg v.
  Hint Constructors estep.

  (* Semantics for commands. *)
  Definition cconfig : Type := com * reg * mem              .
  Definition cterm : Type := reg * mem              .
  Definition ccfg_com (ccfg: cconfig) : com :=
    match ccfg with (c, _, _) => c end.
  Definition ccfg_reg (ccfg: cconfig) : reg :=
    match ccfg with (_, r, _) => r end.
  Definition ccfg_mem (ccfg: cconfig) : mem :=
    match ccfg with (_, _, m) => m end.
  Definition ccfg_update_mem (ccfg: cconfig) (l: location) (v: val) : mem :=
    fun loc => if loc =? l then v
               else (ccfg_mem ccfg) loc.
  Definition ccfg_update_reg (ccfg: cconfig) (x: var) (v: val) : reg :=
    fun var => if var =? x then v
               else (ccfg_reg ccfg) var.
  Definition ccfg_to_ecfg (e: exp) (ccfg : cconfig) : econfig :=
    (e, (ccfg_reg ccfg), (ccfg_mem ccfg)).
  Definition ccfg_update_com (c: com) (ccfg : cconfig) : cconfig :=
    (c, (ccfg_reg ccfg), (ccfg_mem ccfg)).
  Definition csemantics : Type := mode -> loc_mode -> cconfig -> cterm -> trace -> Prop.

  Inductive cstep : csemantics :=
  | Cstep_skip : forall md d ccfg,
      ccfg_com ccfg = Cskip ->
      cstep md d ccfg (ccfg_reg ccfg, ccfg_mem ccfg) []
  | Cstep_assign : forall md d ccfg x e v r',
      ccfg_com ccfg = Cassign x e ->
      estep md d (ccfg_to_ecfg e ccfg) v ->
      r' = ccfg_update_reg ccfg x v ->
      cstep md d ccfg (r', ccfg_mem ccfg) [Assign (ccfg_reg ccfg) x v]
  | Cstep_declassify : forall md d ccfg x e v r',
      ccfg_com ccfg = Cdeclassify x e ->
      exp_novars e ->
      estep md d (ccfg_to_ecfg e ccfg) v ->
      r' = ccfg_update_reg ccfg x v ->
      cstep md d ccfg (r', ccfg_mem ccfg) [Decl e (ccfg_mem ccfg)]
  | Cstep_update : forall md d ccfg e1 e2 l v m',
      ccfg_com ccfg = Cupdate e1 e2 ->
      estep md d (ccfg_to_ecfg e1 ccfg) (Vloc l) ->
      estep md d (ccfg_to_ecfg e2 ccfg) v ->
      m' = ccfg_update_mem ccfg l v ->
      cstep md d ccfg (ccfg_reg ccfg, m') [Update (ccfg_mem ccfg) l v]
  | Cstep_output : forall md d ccfg e sl v,
      ccfg_com ccfg = Coutput e sl ->
      estep md d (ccfg_to_ecfg e ccfg) v ->
      sl = L \/ sl = H ->
      cstep md d ccfg (ccfg_reg ccfg, ccfg_mem ccfg) [Mem (ccfg_mem ccfg); Out sl v]
  | Cstep_call : forall md d ccfg e c r' m' tr,
      ccfg_com ccfg = Ccall e ->
      estep md d (ccfg_to_ecfg e ccfg) (Vlambda md c) ->
      cstep md d (ccfg_update_com c ccfg) (r', m') tr ->
      cstep md d ccfg (r', m') tr
  | Cstep_enclave : forall md d ccfg enc c r' m' tr,
    md = Normal ->
    ccfg_com ccfg = Cenclave enc c ->
    cstep (Encl enc) d (c, ccfg_reg ccfg, ccfg_mem ccfg) (r', m') tr ->
    cstep md d ccfg (r', m') tr
  | Cstep_seq_nil : forall md d ccfg,
      ccfg_com ccfg = Cseq [] ->
      cstep md d ccfg (ccfg_reg ccfg, ccfg_mem ccfg) []
  | Cstep_seq_hd : forall md d ccfg hd tl r m tr r' m' tr' t,
      ccfg_com ccfg = Cseq (hd::tl) ->
      cstep md d (ccfg_update_com hd ccfg) (r, m) tr ->
      cstep md d (Cseq tl, r, m) (r', m') tr' ->
      t = tr ++ tr' ->
      cstep md d ccfg (r', m') t
  | Cstep_if : forall md d ccfg e c1 c2 r' m' tr,
      ccfg_com ccfg = Cif e c1 c2 ->
      estep md d (ccfg_to_ecfg e ccfg) (Vnat 1) ->
      cstep md d (ccfg_update_com c1 ccfg) (r', m') tr ->
      cstep md d ccfg (r', m') tr
  | Cstep_else : forall md d ccfg e c1 c2 r' m' tr,
      ccfg_com ccfg = Cif e c1 c2 ->
      estep md d (ccfg_to_ecfg e ccfg) (Vnat 0) ->
      cstep md d (ccfg_update_com c2 ccfg) (r', m') tr ->
      cstep md d ccfg (r', m') tr
  | Cstep_while_t : forall md d ccfg e c r m tr r' m' tr',
      ccfg_com ccfg = Cwhile e c ->
      estep md d (ccfg_to_ecfg e ccfg) (Vnat 1) ->
      cstep md d (ccfg_update_com c ccfg) (r, m) tr ->
      cstep md d (Cwhile e c,r,m) (r', m') tr' ->
      cstep md d ccfg (r', m') (tr++tr')
  | Cstep_while_f : forall md d ccfg e c,
      ccfg_com ccfg = Cwhile e c ->
      estep md d (ccfg_to_ecfg e ccfg) (Vnat 0) ->
      cstep md d ccfg (ccfg_reg ccfg, ccfg_mem ccfg) []
  .
  Hint Constructors cstep.

  Inductive cstep_n_chaos : csemantics :=
  | Nchaos_cstep : forall md d ccfg cterm t,
      cstep md d ccfg cterm t -> cstep_n_chaos md d ccfg cterm t
  | Nchaos_chaos : forall d ccfg cterm c' t' (HEncEq : enc_equiv (ccfg_com ccfg) c'),
      cstep Normal d (c', ccfg_reg ccfg, ccfg_mem ccfg) cterm t' ->
      cstep_n_chaos Normal d ccfg cterm
                    (Mem (ccfg_mem ccfg) :: AEnc (ccfg_com ccfg) c' HEncEq :: t').
End Semantics.

(*******************************************************************************
*
* TYPING
*
*******************************************************************************)

Section Typing.

  Inductive ref_type : Set :=
  | Mut
  | Immut.

  Inductive base_type : Type :=
  | Tnat : base_type
  | Tref : type -> mode -> ref_type -> base_type
  | Tlambda (G: var -> option type) (p: sec_level) (md: mode) (G': var -> option type) : base_type

  with type : Type :=
       | Typ : base_type -> sec_level -> type.

  Definition context : Type := var -> option type.
  Parameter Loc_Contxt : location -> option (type * ref_type).

  Lemma var_in_dom_dec : forall (G : context) x, {exists t, G x = Some t} + {G x = None}.
  Proof.
    intros. destruct G. simpl.
    left; now exists t. right; auto.
  Qed.

  Lemma loc_in_dom_dec : forall l, {exists t rt, Loc_Contxt l = Some (t, rt)}
                                     + {Loc_Contxt l = None}.
  Proof.
    intros. simpl. destruct (Loc_Contxt l). destruct p.
    left; exists t; exists r; auto. right; auto.
  Qed.

  Definition forall_loc (P: location -> type -> ref_type -> Prop) : Prop :=
    forall l t rt, Loc_Contxt l = Some (t, rt) -> P l t rt.

  Definition forall_dom (G: context) (P: var -> type -> Prop) : Prop :=
       forall x t, G x = Some t -> P x t.

  Inductive type_le : type -> type -> Prop :=
  | Type_le : forall s1 s2 p1 p2,
      base_type_le s1 s2 ->
      sec_level_le p1 p2 ->
      type_le (Typ s1 p1) (Typ s2 p2)

  with base_type_le : base_type -> base_type -> Prop :=
  | Base_type_le_refl : forall s, base_type_le s s
  | Base_type_le_lambda : forall G1 G1' G2 G2' p1 p2 md,
      sec_level_le p2 p1 ->
      context_le G2 G1 ->
      context_le G1' G2' ->
      base_type_le (Tlambda G1 p1 md G1')
                   (Tlambda G2 p2 md G2')

  with context_le : context -> context -> Prop :=
  (* for right now, let's not assume that the domains are equal *)
  | Context_le : forall G1 G2,
      (forall x t,
          G1 x = Some t ->
          (* G2 must either not use the variable or have a greater type *)
          (G2 x = None \/ exists t', G2 x = Some t' /\ type_le t t')) ->
      (forall x t',
          G2 x = Some t' -> exists t, G1 x = Some t /\ type_le t t') ->
      context_le G1 G2.

  Lemma context_le_refl : forall G, context_le G G.
  Proof.
    intros. apply Context_le. intros. right; exists t; destruct t; auto.
    split; auto. apply Type_le. apply Base_type_le_refl. apply sec_level_le_refl.
    intros; exists t'; split; auto; destruct t'; auto.
    apply Type_le. apply Base_type_le_refl. apply sec_level_le_refl.
  Qed.

  Definition is_var_low_context (G: context) : Prop :=
    forall_dom G (fun _ t => let (_, p) := t in p = L).

  Function loc_in_exp (e: exp) (l: location) : Prop :=
    match e with
    | Eloc l' => l = l'
    | Ederef e' => loc_in_exp e' l
    | Eadd e1 e2 => loc_in_exp e1 l \/ loc_in_exp e2 l
    | _ => False
    end.

  Definition exp_locs_immutable (e: exp) :=
    forall_subexp e (fun e =>
                       match e with
                       | Eloc n => set_In n (immutable_locs g0)
                       | _ => True
                       end).

  Axiom Loc_Contxt_wt : forall d,
    forall_loc (fun l t _ =>
                  let (_, p) := t in
                  (p = H -> d l <> Normal)).

  Inductive val_type : mode -> context -> loc_mode -> val -> type -> Prop :=
  | VTnat: forall md g d n q,
      val_type md g d (Vnat n) (Typ Tnat q)
  | VTloc: forall md g d l md' t rt q,
      d l = md' ->
      Loc_Contxt l = Some (t, rt) ->
      val_type md g d (Vloc l) (Typ (Tref t md' rt) q)
  | VTlambda : forall md g d c p g' g'' q md0,
      com_type p md g' d c g'' ->
      val_type md0 g d (Vlambda md c) (Typ (Tlambda g' p md g'') q)
  | VTvar : forall md g d x r bt p v,
      g x = Some (Typ bt p) ->
      r x = v ->
      val_type md g d v (Typ bt p)
  | VTmem : forall md g d md' p rt q m l v bt,
      m l = v ->
      val_type md g d (Vloc l) (Typ (Tref (Typ bt p) md' rt) q) ->
      val_type md g d v (Typ bt (sec_level_join p q))
  | VTbinop : forall md g d n1 n2 p q op,
      val_type md g d (Vnat n1) (Typ Tnat p) ->
      val_type md g d (Vnat n2) (Typ Tnat q) ->
      val_type md g d (Vnat (op n1 n2)) (Typ Tnat (sec_level_join p q))

  with exp_type : mode -> context -> loc_mode -> exp -> type -> Prop :=
  | ETnat : forall md g d n,
      exp_type md g d (Enat n) (Typ Tnat (L))
  | ETvar : forall md g d x t,
      g x = Some t ->
      exp_type md g d (Evar x) t
  | ETloc : forall md g d l md' t rt,
      d l = md' ->
      Loc_Contxt l = Some (t, rt) ->
      exp_type md g d (Eloc l) (Typ (Tref t md' rt) (L))
  | ETderef : forall md g d e md' s p rt q,
      exp_type md g d e (Typ (Tref (Typ s p) md' rt) q) ->
      md' = Normal \/ md' = md ->
      exp_type md g d (Ederef e) (Typ s (sec_level_join p q))
  | ETlambda : forall md g d c p g' g'',
      com_type p md g' d c g''->
      exp_type md g d (Elambda md c) (Typ (Tlambda g' p md g'') (L))
  | ETadd : forall md g d e1 e2 p q,
      exp_type md g d e1 (Typ Tnat p) ->
      exp_type md g d e2 (Typ Tnat q) ->
      exp_type md g d (Eadd e1 e2) (Typ Tnat (sec_level_join p q))

  with com_type : sec_level -> mode -> context -> loc_mode -> com -> context -> Prop :=
  | CTskip : forall pc md g d,
      com_type pc md g d Cskip g
  | CTassign : forall pc md g d x e s p q vc',
      exp_type md g d e (Typ s p) ->
      q = sec_level_join p pc ->
      sec_level_le q (L) \/ md <> Normal ->
      vc' = (fun y => if y =? x then Some (Typ s q) else g y) ->
      com_type pc md g d (Cassign x e) (vc')
  | CTdeclassify : forall md g d x e s p vc',
      exp_type md g d e (Typ s p) ->
      exp_novars e ->
      exp_locs_immutable e ->
      vc' = (fun y => if y =? x then Some (Typ s (L)) else g y) ->
      com_type (L) md g d (Cdeclassify x e) (vc')
  | CToutput : forall pc md g d e l s p,
      exp_type md g d e (Typ s p) ->
      sec_level_le (sec_level_join p pc) l ->
      com_type pc md g d (Coutput e l) g
  | CTupdate : forall pc md g d e1 e2 s p md' q p',
      exp_type md g d e1 (Typ (Tref (Typ s p) md' Mut) q) ->
      exp_type md g d e2 (Typ s p') ->
      sec_level_le (sec_level_join (sec_level_join p' q) pc) p ->
      md' = Normal \/ md' = md ->
      com_type pc md g d (Cupdate e1 e2) g
  | Tifelse : forall pc md g d e c1 c2 pc' p g',
      com_type pc' md g d c1 g' ->
      com_type pc' md g d c2 g' ->
      exp_type md g d e (Typ Tnat p) ->
      sec_level_le (sec_level_join pc p) pc' ->
      sec_level_le p (L) \/ md <> Normal ->
      com_type pc md g d (Cif e c1 c2) g'
  | Tenclave : forall pc g d c i c' g',
      c = Cenclave i c' ->
      com_type pc (Encl i) g d c' g' ->
      is_var_low_context g' ->
      com_type pc Normal g d c g'
  | Twhile : forall pc md g d c e p pc',
      exp_type md g d e (Typ Tnat p) ->
      com_type pc' md g d c g ->
      sec_level_le (sec_level_join pc p) pc' ->
      sec_level_le p L \/ md <> Normal ->
      com_type pc md g d (Cwhile e c) g
  | Tseq : forall pc md g d c rest g' gn,
      com_type pc md g d c g' ->
      com_type pc md g' d (Cseq rest) gn ->
      com_type pc md g d (Cseq (c :: rest)) gn
  | Tseqnil : forall pc md g d,
      com_type pc md g d (Cseq []) g
  | Tcall : forall pc md G d e Gm Gp Gout q p,
      exp_type md G d e (Typ (Tlambda Gm p md Gp) q) ->
      sec_level_le (sec_level_join pc q) p ->
      context_le G Gm ->
      context_le Gp Gout ->
      forall_dom G (fun x t => (Gp x = None) -> Gout x = Some t) ->
      com_type pc md G d (Ccall e) Gout.

  Axiom subsumption : forall pc1 pc2 md d G1 G1' G2 G2' c,
      com_type pc1 md G1 d c G1' ->
      sec_level_le pc2 pc1 ->
      context_le G2 G1 ->
      context_le G1' G2' ->
      com_type pc2 md G2 d c G2'.

  Hint Constructors exp_type.
  Hint Constructors val_type.
  Hint Constructors com_type.
End Typing.

Section Initial_State.
  Parameter minit : mem.

  Definition meminit_wf minit d := forall l,
      match minit l with
      | Vlambda md c => exists Gm p Gp q rt,
                        Loc_Contxt l = Some (Typ (Tlambda Gm p md Gp) q, rt) /\
                        com_type p md Gm d c Gp
      | Vloc l => False
      | Vnat n => exists q rt, Loc_Contxt l = Some (Typ (Tnat) q, rt)
      end.

  Axiom wf_minit : forall d, meminit_wf minit d.

  Axiom Initial_State : forall d r' m',
      exists c md tr, cstep md d (c,reg_init,minit) (r',m') tr.
End Initial_State.

Section Axioms.
  (* These next four axioms follow from the statement of initial state above *)
  Axiom No_Pointers : forall (m: mem) l l', m l <> Vloc l'.

  Axiom Reg_Exp_Lambda : forall (r : reg) d x md c G Gm Gp p q,
      r x = Vlambda md c /\ G x = Some (Typ (Tlambda Gm p md Gp) q)
      <-> exists md', exp_type md' G d (Elambda md c)
                                 (Typ (Tlambda Gm p md Gp) L).

  Axiom Reg_Exp_Loc : forall (r : reg) d x l G s p md' rt q,
      r x = Vloc l /\ G x = Some (Typ (Tref (Typ s p) md' rt) q) <->
      exists md,
        exp_type md G d (Eloc l) (Typ (Tref (Typ s p) md' rt) L) /\ d l = md'.

  Axiom Mem_Exp_Lambda : forall (m : mem) d l md c G Gm Gp p q rt,
      m l = Vlambda md c /\ Loc_Contxt l = Some (Typ (Tlambda Gm p md Gp) q, rt) <->
      minit l = Vlambda md c \/
      (exists md',
          exp_type md' G d (Elambda md c) (Typ (Tlambda Gm p md Gp) L)).
End Axioms.


(* ------------------------------------------------------- *)
(** #

#
        The double time redundancy (DTR) transformation
#
#
-   Properties of memory block sub-part called rhsPar

          Dmitry Burlyaev - Pascal Fradet - 2015
#
#                                           *)
(* ------------------------------------------------------- *)
(*Add LoadPath "..\..\Common\".
        Require Import CirReflect .
Add LoadPath "..\..\TMRProof\".
Add LoadPath "..\". *)
Add LoadPath "..\..\Common\".
Add LoadPath "..\..\TMRProof\".
Add LoadPath "..\Transf\".

Require Import dtrTransform.

Set Implicit Arguments.

(* ##################################################################### *)
(** Properties of sub-circuit of Memory Block called rhsPar w/o Glitches *)
(* ##################################################################### *)

(* State before/after for both cycles w/o errors *)
Lemma step_rhs: forall si_I sav_I rol_I fai_I rO_I sav2_I t rhs2,
                step rhsPar {si_I,{{{ sav_I, rol_I},fai_I},{rO_I,sav2_I}}} t rhs2
             -> let rNew:= if ((beq_buset_t sav2_I (~?))&&(beq_buset_t si_I (~0))&&(beq_buset_t rO_I (~0))) then (~0)
                           else if (beq_buset_t sav2_I (~?))  then (~?)
                           else if (beq_buset_t sav2_I (~1)) then si_I
                           else rO_I in
                t= {{ {{sav_I,rol_I}, fai_I}, si_I}, rNew} /\ rhs2 = rhsPar.
Proof.
introv H.
assert ( F:  fstep rhsPar {si_I, {sav_I, rol_I, fai_I, {rO_I, sav2_I}}}  =
             Some ({{ {{sav_I,rol_I}, fai_I}, si_I},
                      if ((beq_buset_t sav2_I (~?))&&(beq_buset_t si_I (~0))
                      &&(beq_buset_t rO_I (~0))) then (~0)
                      else if (beq_buset_t sav2_I (~?))  then (~?)
                      else if (beq_buset_t sav2_I (~1)) then si_I
                      else rO_I},rhsPar)) by
(Destruct_s sav2_I; destruct x; cbn; Destruct_s sav_I;  Destruct_s rol_I;
Destruct_s fai_I; Destruct_s si_I; Destruct_s rO_I;
destruct x; destruct x0; destruct x1 ; destruct x2; destruct x3;
vm_compute; try easy).
eapply fstep_imp_detstep in F; Simpl.
Qed.


Require Import LayerDeps.
Require Import Ident.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import BaremoreHandler.Spec.
Require Import RmiAux.Spec.
Require Import BaremoreSMC.Spec.
Require Import RmiAux2.Spec.

Local Open Scope Z_scope.

Section Layer.

  Context `{real_params: RealParams}.

  Section InvDef.

    Record high_level_invariant (adt: RData) :=
      mkInvariants { }.

    Global Instance RmiAux2_ops : CompatDataOps RData :=
      {
        empty_data := empty_adt;
        high_level_invariant := high_level_invariant;
        low_level_invariant := fun (b: block) (d: RData) => True;
        kernel_mode adt := True
      }.

  End InvDef.

  Section InvInit.

    Global Instance RmiAux2_prf : CompatData RData.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

  End InvInit.

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

  Section InvProof.

    Global Instance init_rec_regs_inv: PreservesInvariants init_rec_regs_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance init_rec_rvic_state_inv: PreservesInvariants init_rec_rvic_state_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance rec_granule_measure_inv: PreservesInvariants rec_granule_measure_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance shiftl_inv: PreservesInvariants shiftl_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rd_par_base_inv: PreservesInvariants get_rd_par_base_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance addr_to_idx_inv: PreservesInvariants addr_to_idx_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance el3_sync_lel_inv: PreservesInvariants el3_sync_lel_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rvic_result_target_inv: PreservesInvariants set_rvic_result_target_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rec_sysregs_inv: PreservesInvariants set_rec_sysregs_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance validate_realm_params_inv: PreservesInvariants validate_realm_params_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_psci_result_forward_psci_call_inv: PreservesInvariants get_psci_result_forward_psci_call_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance granule_refcount_inc_inv: PreservesInvariants granule_refcount_inc_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_realm_params_measurement_algo_inv: PreservesInvariants get_realm_params_measurement_algo_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance ns_buffer_read_rec_run_inv: PreservesInvariants ns_buffer_read_rec_run_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance granule_put_inv: PreservesInvariants granule_put_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance smc_mark_realm_inv: PreservesInvariants smc_mark_realm_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rd_state_inv: PreservesInvariants set_rd_state_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance entry_is_table_inv: PreservesInvariants entry_is_table_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rec_pstate_inv: PreservesInvariants get_rec_pstate_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance atomic_granule_put_release_inv: PreservesInvariants atomic_granule_put_release_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rec_run_gprs_inv: PreservesInvariants get_rec_run_gprs_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rec_ptimer_asserted_inv: PreservesInvariants set_rec_ptimer_asserted_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_timer_asserted_inv: PreservesInvariants get_timer_asserted_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_realm_params_inv: PreservesInvariants get_realm_params_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rec_rec_idx_inv: PreservesInvariants get_rec_rec_idx_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rec_run_is_emulated_mmio_inv: PreservesInvariants get_rec_run_is_emulated_mmio_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance read_reg_inv: PreservesInvariants read_reg_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance granule_refcount_dec_inv: PreservesInvariants granule_refcount_dec_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance interrupt_bitmap_dword_inv: PreservesInvariants interrupt_bitmap_dword_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rd_measurement_algo_inv: PreservesInvariants set_rd_measurement_algo_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rec_ptimer_masked_inv: PreservesInvariants get_rec_ptimer_masked_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance measurement_extend_data_header_inv: PreservesInvariants measurement_extend_data_header_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance granule_lock_inv: PreservesInvariants granule_lock_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance ns_buffer_unmap_inv: PreservesInvariants ns_buffer_unmap_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance granule_memzero_mapped_inv: PreservesInvariants granule_memzero_mapped_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance ptr_eq_inv: PreservesInvariants ptr_eq_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rec_common_sysregs_inv: PreservesInvariants get_rec_common_sysregs_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance is_addr_in_par_rec_inv: PreservesInvariants is_addr_in_par_rec_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rd_state_inv: PreservesInvariants get_rd_state_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rec_par_base_inv: PreservesInvariants set_rec_par_base_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance esr_sixty_four_inv: PreservesInvariants esr_sixty_four_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rvic_mask_bits_inv: PreservesInvariants get_rvic_mask_bits_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance run_realm_inv: PreservesInvariants run_realm_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rec_params_flags_inv: PreservesInvariants get_rec_params_flags_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_timer_masked_inv: PreservesInvariants get_timer_masked_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_target_rec_inv: PreservesInvariants get_target_rec_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_psci_result_forward_psci_call_inv: PreservesInvariants set_psci_result_forward_psci_call_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_g_rtt_refcount_inv: PreservesInvariants get_g_rtt_refcount_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance esr_srt_inv: PreservesInvariants esr_srt_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rec_pstate_inv: PreservesInvariants set_rec_pstate_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rec_pc_inv: PreservesInvariants get_rec_pc_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rd_par_end_inv: PreservesInvariants get_rd_par_end_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance is_rec_valid_inv: PreservesInvariants is_rec_valid_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance granule_get_inv: PreservesInvariants granule_get_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rd_par_base_inv: PreservesInvariants set_rd_par_base_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_realm_params_par_size_inv: PreservesInvariants get_realm_params_par_size_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance buffer_unmap_inv: PreservesInvariants buffer_unmap_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance access_len_inv: PreservesInvariants access_len_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance enter_rmm_inv: PreservesInvariants enter_rmm_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_g_rec_rd_inv: PreservesInvariants get_g_rec_rd_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_realm_params_rtt_addr_inv: PreservesInvariants get_realm_params_rtt_addr_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rec_ptimer_masked_inv: PreservesInvariants set_rec_ptimer_masked_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rd_g_rec_list_inv: PreservesInvariants set_rd_g_rec_list_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rd_par_end_inv: PreservesInvariants set_rd_par_end_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance sysreg_read_inv: PreservesInvariants sysreg_read_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance granule_set_state_inv: PreservesInvariants granule_set_state_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance null_ptr_inv: PreservesInvariants null_ptr_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance timer_is_masked_inv: PreservesInvariants timer_is_masked_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rd_g_rtt_inv: PreservesInvariants set_rd_g_rtt_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_ns_state_inv: PreservesInvariants get_ns_state_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_g_rec_rd_inv: PreservesInvariants set_g_rec_rd_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rec_vtimer_masked_inv: PreservesInvariants set_rec_vtimer_masked_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_wi_g_llt_inv: PreservesInvariants get_wi_g_llt_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rec_run_esr_inv: PreservesInvariants set_rec_run_esr_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance granule_map_inv: PreservesInvariants granule_map_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rvic_result_ns_notify_inv: PreservesInvariants set_rvic_result_ns_notify_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance realm_get_rec_entry_inv: PreservesInvariants realm_get_rec_entry_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_ns_state_inv: PreservesInvariants set_ns_state_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rec_g_rec_inv: PreservesInvariants get_rec_g_rec_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rec_run_gprs_inv: PreservesInvariants set_rec_run_gprs_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rec_run_hpfar_inv: PreservesInvariants set_rec_run_hpfar_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_psci_result_x0_inv: PreservesInvariants get_psci_result_x0_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rec_runnable_inv: PreservesInvariants set_rec_runnable_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_psci_result_x1_inv: PreservesInvariants get_psci_result_x1_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance interrupt_bit_inv: PreservesInvariants interrupt_bit_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_psci_result_x2_inv: PreservesInvariants get_psci_result_x2_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance find_lock_granule_inv: PreservesInvariants find_lock_granule_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance is_null_inv: PreservesInvariants is_null_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rec_rvic_enabled_inv: PreservesInvariants get_rec_rvic_enabled_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance assert_cond_inv: PreservesInvariants assert_cond_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_target_rec_inv: PreservesInvariants set_target_rec_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance pgte_read_inv: PreservesInvariants pgte_read_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rd_g_rec_list_inv: PreservesInvariants get_rd_g_rec_list_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rec_vtimer_masked_inv: PreservesInvariants get_rec_vtimer_masked_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_wi_g_llt_inv: PreservesInvariants set_wi_g_llt_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rec_last_run_info_esr_inv: PreservesInvariants get_rec_last_run_info_esr_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance measurement_finish_inv: PreservesInvariants measurement_finish_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rec_g_rec_list_inv: PreservesInvariants get_rec_g_rec_list_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance esr_is_write_inv: PreservesInvariants esr_is_write_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_psci_result_x3_inv: PreservesInvariants get_psci_result_x3_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_wi_index_inv: PreservesInvariants get_wi_index_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_wi_index_inv: PreservesInvariants set_wi_index_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_timer_masked_inv: PreservesInvariants set_timer_masked_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance mpidr_to_rec_idx_inv: PreservesInvariants mpidr_to_rec_idx_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance granule_unlock_inv: PreservesInvariants granule_unlock_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance emulate_timer_ctl_read_inv: PreservesInvariants emulate_timer_ctl_read_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance exit_rmm_inv: PreservesInvariants exit_rmm_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance measurement_extend_data_inv: PreservesInvariants measurement_extend_data_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance ESR_EL2_SYSREG_IS_WRITE_inv: PreservesInvariants ESR_EL2_SYSREG_IS_WRITE_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance barrier_inv: PreservesInvariants barrier_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance access_mask_inv: PreservesInvariants access_mask_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance esr_sign_extend_inv: PreservesInvariants esr_sign_extend_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rec_dispose_pending_inv: PreservesInvariants set_rec_dispose_pending_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rd_g_rtt_inv: PreservesInvariants get_rd_g_rtt_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rec_last_run_info_esr_inv: PreservesInvariants set_rec_last_run_info_esr_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rvic_result_x0_inv: PreservesInvariants set_rvic_result_x0_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance granule_memzero_inv: PreservesInvariants granule_memzero_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance test_bit_acquire_64_inv: PreservesInvariants test_bit_acquire_64_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_psci_result_forward_x1_inv: PreservesInvariants set_psci_result_forward_x1_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rec_regs_inv: PreservesInvariants get_rec_regs_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_psci_result_forward_x3_inv: PreservesInvariants get_psci_result_forward_x3_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rec_rvic_inv: PreservesInvariants get_rec_rvic_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance realm_set_rec_entry_inv: PreservesInvariants realm_set_rec_entry_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_psci_result_forward_x2_inv: PreservesInvariants get_psci_result_forward_x2_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_psci_result_forward_x1_inv: PreservesInvariants get_psci_result_forward_x1_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rec_run_exit_reason_inv: PreservesInvariants set_rec_run_exit_reason_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance ESR_EL2_SYSREG_ISS_RT_inv: PreservesInvariants ESR_EL2_SYSREG_ISS_RT_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance atomic_granule_put_inv: PreservesInvariants atomic_granule_put_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance ns_buffer_read_rec_params_inv: PreservesInvariants ns_buffer_read_rec_params_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance find_lock_three_delegated_granules_inv: PreservesInvariants find_lock_three_delegated_granules_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance atomic_bit_set_release_64_inv: PreservesInvariants atomic_bit_set_release_64_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance read_idreg_inv: PreservesInvariants read_idreg_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rec_par_end_inv: PreservesInvariants get_rec_par_end_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rec_g_rd_inv: PreservesInvariants set_rec_g_rd_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_realm_params_par_base_inv: PreservesInvariants get_realm_params_par_base_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance measurement_start_inv: PreservesInvariants measurement_start_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_psci_result_x0_inv: PreservesInvariants set_psci_result_x0_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_mapping_inv: PreservesInvariants set_mapping_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rec_pc_inv: PreservesInvariants set_rec_pc_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rec_regs_inv: PreservesInvariants set_rec_regs_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rec_runnable_inv: PreservesInvariants get_rec_runnable_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance ns_granule_map_inv: PreservesInvariants ns_granule_map_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rec_sysregs_inv: PreservesInvariants get_rec_sysregs_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rec_vtimer_asserted_inv: PreservesInvariants set_rec_vtimer_asserted_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rec_run_emulated_write_val_inv: PreservesInvariants set_rec_run_emulated_write_val_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rec_run_far_inv: PreservesInvariants set_rec_run_far_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance mpidr_is_valid_inv: PreservesInvariants mpidr_is_valid_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rec_run_emulated_read_val_inv: PreservesInvariants get_rec_run_emulated_read_val_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rec_g_rec_list_inv: PreservesInvariants set_rec_g_rec_list_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rec_vtimer_inv: PreservesInvariants get_rec_vtimer_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_rec_par_end_inv: PreservesInvariants set_rec_par_end_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance granule_get_state_inv: PreservesInvariants granule_get_state_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rec_ptimer_inv: PreservesInvariants get_rec_ptimer_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_bitmap_loc_inv: PreservesInvariants get_bitmap_loc_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance smc_mark_nonsecure_inv: PreservesInvariants smc_mark_nonsecure_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_realm_params_rec_list_addr_inv: PreservesInvariants get_realm_params_rec_list_addr_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance set_g_rtt_rd_inv: PreservesInvariants set_g_rtt_rd_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance atomic_bit_clear_release_64_inv: PreservesInvariants atomic_bit_clear_release_64_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance ns_buffer_read_data_inv: PreservesInvariants ns_buffer_read_data_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance pgte_write_inv: PreservesInvariants pgte_write_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance is_addr_in_par_inv: PreservesInvariants is_addr_in_par_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance sysreg_write_inv: PreservesInvariants sysreg_write_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance find_granule_inv: PreservesInvariants find_granule_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rec_par_base_inv: PreservesInvariants get_rec_par_base_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rec_g_rd_inv: PreservesInvariants get_rec_g_rd_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance init_rec_read_only_inv: PreservesInvariants init_rec_read_only_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_locked_granule_inv: PreservesInvariants get_locked_granule_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance get_rvic_pending_bits_inv: PreservesInvariants get_rvic_pending_bits_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance find_lock_unused_granule_inv: PreservesInvariants find_lock_unused_granule_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance entry_to_phys_inv: PreservesInvariants entry_to_phys_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance stage2_tlbi_ipa_inv: PreservesInvariants stage2_tlbi_ipa_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance atomic_granule_get_inv: PreservesInvariants atomic_granule_get_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance user_step_inv: PreservesInvariants user_step_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance link_table_inv: PreservesInvariants link_table_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance timer_condition_met_inv: PreservesInvariants timer_condition_met_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance addr_is_level_aligned_inv: PreservesInvariants addr_is_level_aligned_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

  End InvProof.

  Section LayerDef.

    Definition RmiAux2_fresh : compatlayer (cdata RData) :=
      _init_rec_regs ↦ gensem init_rec_regs_spec
        ⊕ _init_rec_rvic_state ↦ gensem init_rec_rvic_state_spec
        ⊕ _rec_granule_measure ↦ gensem rec_granule_measure_spec
      .

    Definition RmiAux2_passthrough : compatlayer (cdata RData) :=
      _shiftl ↦ gensem shiftl_spec
        ⊕ _get_rd_par_base ↦ gensem get_rd_par_base_spec
        ⊕ _addr_to_idx ↦ gensem addr_to_idx_spec
        ⊕ _el3_sync_lel ↦ gensem el3_sync_lel_spec
        ⊕ _set_rvic_result_target ↦ gensem set_rvic_result_target_spec
        ⊕ _set_rec_sysregs ↦ gensem set_rec_sysregs_spec
        ⊕ _validate_realm_params ↦ gensem validate_realm_params_spec
        ⊕ _get_psci_result_forward_psci_call ↦ gensem get_psci_result_forward_psci_call_spec
        ⊕ _granule_refcount_inc ↦ gensem granule_refcount_inc_spec
        ⊕ _get_realm_params_measurement_algo ↦ gensem get_realm_params_measurement_algo_spec
        ⊕ _ns_buffer_read_rec_run ↦ gensem ns_buffer_read_rec_run_spec
        ⊕ _granule_put ↦ gensem granule_put_spec
        ⊕ _smc_mark_realm ↦ gensem smc_mark_realm_spec
        ⊕ _set_rd_state ↦ gensem set_rd_state_spec
        ⊕ _entry_is_table ↦ gensem entry_is_table_spec
        ⊕ _get_rec_pstate ↦ gensem get_rec_pstate_spec
        ⊕ _atomic_granule_put_release ↦ gensem atomic_granule_put_release_spec
        ⊕ _get_rec_run_gprs ↦ gensem get_rec_run_gprs_spec
        ⊕ _set_rec_ptimer_asserted ↦ gensem set_rec_ptimer_asserted_spec
        ⊕ _get_timer_asserted ↦ gensem get_timer_asserted_spec
        ⊕ _get_realm_params ↦ gensem get_realm_params_spec
        ⊕ _get_rec_rec_idx ↦ gensem get_rec_rec_idx_spec
        ⊕ _get_rec_run_is_emulated_mmio ↦ gensem get_rec_run_is_emulated_mmio_spec
        ⊕ _read_reg ↦ gensem read_reg_spec
        ⊕ _granule_refcount_dec ↦ gensem granule_refcount_dec_spec
        ⊕ _interrupt_bitmap_dword ↦ gensem interrupt_bitmap_dword_spec
        ⊕ _set_rd_measurement_algo ↦ gensem set_rd_measurement_algo_spec
        ⊕ _get_rec_ptimer_masked ↦ gensem get_rec_ptimer_masked_spec
        ⊕ _measurement_extend_data_header ↦ gensem measurement_extend_data_header_spec
        ⊕ _granule_lock ↦ gensem granule_lock_spec
        ⊕ _ns_buffer_unmap ↦ gensem ns_buffer_unmap_spec
        ⊕ _granule_memzero_mapped ↦ gensem granule_memzero_mapped_spec
        ⊕ _ptr_eq ↦ gensem ptr_eq_spec
        ⊕ _get_rec_common_sysregs ↦ gensem get_rec_common_sysregs_spec
        ⊕ _is_addr_in_par_rec ↦ gensem is_addr_in_par_rec_spec
        ⊕ _get_rd_state ↦ gensem get_rd_state_spec
        ⊕ _set_rec_par_base ↦ gensem set_rec_par_base_spec
        ⊕ _esr_sixty_four ↦ gensem esr_sixty_four_spec
        ⊕ _get_rvic_mask_bits ↦ gensem get_rvic_mask_bits_spec
        ⊕ _run_realm ↦ gensem run_realm_spec
        ⊕ _get_rec_params_flags ↦ gensem get_rec_params_flags_spec
        ⊕ _get_timer_masked ↦ gensem get_timer_masked_spec
        ⊕ _get_target_rec ↦ gensem get_target_rec_spec
        ⊕ _set_psci_result_forward_psci_call ↦ gensem set_psci_result_forward_psci_call_spec
        ⊕ _get_g_rtt_refcount ↦ gensem get_g_rtt_refcount_spec
        ⊕ _esr_srt ↦ gensem esr_srt_spec
        ⊕ _set_rec_pstate ↦ gensem set_rec_pstate_spec
        ⊕ _get_rec_pc ↦ gensem get_rec_pc_spec
        ⊕ _get_rd_par_end ↦ gensem get_rd_par_end_spec
        ⊕ _is_rec_valid ↦ gensem is_rec_valid_spec
        ⊕ _granule_get ↦ gensem granule_get_spec
        ⊕ _set_rd_par_base ↦ gensem set_rd_par_base_spec
        ⊕ _get_realm_params_par_size ↦ gensem get_realm_params_par_size_spec
        ⊕ _buffer_unmap ↦ gensem buffer_unmap_spec
        ⊕ _access_len ↦ gensem access_len_spec
        ⊕ _enter_rmm ↦ gensem enter_rmm_spec
        ⊕ _get_g_rec_rd ↦ gensem get_g_rec_rd_spec
        ⊕ _get_realm_params_rtt_addr ↦ gensem get_realm_params_rtt_addr_spec
        ⊕ _set_rec_ptimer_masked ↦ gensem set_rec_ptimer_masked_spec
        ⊕ _set_rd_g_rec_list ↦ gensem set_rd_g_rec_list_spec
        ⊕ _set_rd_par_end ↦ gensem set_rd_par_end_spec
        ⊕ _sysreg_read ↦ gensem sysreg_read_spec
        ⊕ _granule_set_state ↦ gensem granule_set_state_spec
        ⊕ _null_ptr ↦ gensem null_ptr_spec
        ⊕ _timer_is_masked ↦ gensem timer_is_masked_spec
        ⊕ _set_rd_g_rtt ↦ gensem set_rd_g_rtt_spec
        ⊕ _get_ns_state ↦ gensem get_ns_state_spec
        ⊕ _set_g_rec_rd ↦ gensem set_g_rec_rd_spec
        ⊕ _set_rec_vtimer_masked ↦ gensem set_rec_vtimer_masked_spec
        ⊕ _get_wi_g_llt ↦ gensem get_wi_g_llt_spec
        ⊕ _set_rec_run_esr ↦ gensem set_rec_run_esr_spec
        ⊕ _granule_map ↦ gensem granule_map_spec
        ⊕ _set_rvic_result_ns_notify ↦ gensem set_rvic_result_ns_notify_spec
        ⊕ _realm_get_rec_entry ↦ gensem realm_get_rec_entry_spec
        ⊕ _set_ns_state ↦ gensem set_ns_state_spec
        ⊕ _get_rec_g_rec ↦ gensem get_rec_g_rec_spec
        ⊕ _set_rec_run_gprs ↦ gensem set_rec_run_gprs_spec
        ⊕ _set_rec_run_hpfar ↦ gensem set_rec_run_hpfar_spec
        ⊕ _get_psci_result_x0 ↦ gensem get_psci_result_x0_spec
        ⊕ _set_rec_runnable ↦ gensem set_rec_runnable_spec
        ⊕ _get_psci_result_x1 ↦ gensem get_psci_result_x1_spec
        ⊕ _interrupt_bit ↦ gensem interrupt_bit_spec
        ⊕ _get_psci_result_x2 ↦ gensem get_psci_result_x2_spec
        ⊕ _find_lock_granule ↦ gensem find_lock_granule_spec
        ⊕ _is_null ↦ gensem is_null_spec
        ⊕ _get_rec_rvic_enabled ↦ gensem get_rec_rvic_enabled_spec
        ⊕ _assert_cond ↦ gensem assert_cond_spec
        ⊕ _set_target_rec ↦ gensem set_target_rec_spec
        ⊕ _pgte_read ↦ gensem pgte_read_spec
        ⊕ _get_rd_g_rec_list ↦ gensem get_rd_g_rec_list_spec
        ⊕ _get_rec_vtimer_masked ↦ gensem get_rec_vtimer_masked_spec
        ⊕ _set_wi_g_llt ↦ gensem set_wi_g_llt_spec
        ⊕ _get_rec_last_run_info_esr ↦ gensem get_rec_last_run_info_esr_spec
        ⊕ _measurement_finish ↦ gensem measurement_finish_spec
        ⊕ _get_rec_g_rec_list ↦ gensem get_rec_g_rec_list_spec
        ⊕ _esr_is_write ↦ gensem esr_is_write_spec
        ⊕ _get_psci_result_x3 ↦ gensem get_psci_result_x3_spec
        ⊕ _get_wi_index ↦ gensem get_wi_index_spec
        ⊕ _set_wi_index ↦ gensem set_wi_index_spec
        ⊕ _set_timer_masked ↦ gensem set_timer_masked_spec
        ⊕ _mpidr_to_rec_idx ↦ gensem mpidr_to_rec_idx_spec
        ⊕ _granule_unlock ↦ gensem granule_unlock_spec
        ⊕ _emulate_timer_ctl_read ↦ gensem emulate_timer_ctl_read_spec
        ⊕ _exit_rmm ↦ gensem exit_rmm_spec
        ⊕ _measurement_extend_data ↦ gensem measurement_extend_data_spec
        ⊕ _ESR_EL2_SYSREG_IS_WRITE ↦ gensem ESR_EL2_SYSREG_IS_WRITE_spec
        ⊕ _barrier ↦ gensem barrier_spec
        ⊕ _access_mask ↦ gensem access_mask_spec
        ⊕ _esr_sign_extend ↦ gensem esr_sign_extend_spec
        ⊕ _set_rec_dispose_pending ↦ gensem set_rec_dispose_pending_spec
        ⊕ _get_rd_g_rtt ↦ gensem get_rd_g_rtt_spec
        ⊕ _set_rec_last_run_info_esr ↦ gensem set_rec_last_run_info_esr_spec
        ⊕ _set_rvic_result_x0 ↦ gensem set_rvic_result_x0_spec
        ⊕ _granule_memzero ↦ gensem granule_memzero_spec
        ⊕ _test_bit_acquire_64 ↦ gensem test_bit_acquire_64_spec
        ⊕ _set_psci_result_forward_x1 ↦ gensem set_psci_result_forward_x1_spec
        ⊕ _get_rec_regs ↦ gensem get_rec_regs_spec
        ⊕ _get_psci_result_forward_x3 ↦ gensem get_psci_result_forward_x3_spec
        ⊕ _get_rec_rvic ↦ gensem get_rec_rvic_spec
        ⊕ _realm_set_rec_entry ↦ gensem realm_set_rec_entry_spec
        ⊕ _get_psci_result_forward_x2 ↦ gensem get_psci_result_forward_x2_spec
        ⊕ _get_psci_result_forward_x1 ↦ gensem get_psci_result_forward_x1_spec
        ⊕ _set_rec_run_exit_reason ↦ gensem set_rec_run_exit_reason_spec
        ⊕ _ESR_EL2_SYSREG_ISS_RT ↦ gensem ESR_EL2_SYSREG_ISS_RT_spec
        ⊕ _atomic_granule_put ↦ gensem atomic_granule_put_spec
        ⊕ _ns_buffer_read_rec_params ↦ gensem ns_buffer_read_rec_params_spec
        ⊕ _find_lock_three_delegated_granules ↦ gensem find_lock_three_delegated_granules_spec
        ⊕ _atomic_bit_set_release_64 ↦ gensem atomic_bit_set_release_64_spec
        ⊕ _read_idreg ↦ gensem read_idreg_spec
        ⊕ _get_rec_par_end ↦ gensem get_rec_par_end_spec
        ⊕ _set_rec_g_rd ↦ gensem set_rec_g_rd_spec
        ⊕ _get_realm_params_par_base ↦ gensem get_realm_params_par_base_spec
        ⊕ _measurement_start ↦ gensem measurement_start_spec
        ⊕ _set_psci_result_x0 ↦ gensem set_psci_result_x0_spec
        ⊕ _set_mapping ↦ gensem set_mapping_spec
        ⊕ _set_rec_pc ↦ gensem set_rec_pc_spec
        ⊕ _set_rec_regs ↦ gensem set_rec_regs_spec
        ⊕ _get_rec_runnable ↦ gensem get_rec_runnable_spec
        ⊕ _ns_granule_map ↦ gensem ns_granule_map_spec
        ⊕ _get_rec_sysregs ↦ gensem get_rec_sysregs_spec
        ⊕ _set_rec_vtimer_asserted ↦ gensem set_rec_vtimer_asserted_spec
        ⊕ _set_rec_run_emulated_write_val ↦ gensem set_rec_run_emulated_write_val_spec
        ⊕ _set_rec_run_far ↦ gensem set_rec_run_far_spec
        ⊕ _mpidr_is_valid ↦ gensem mpidr_is_valid_spec
        ⊕ _get_rec_run_emulated_read_val ↦ gensem get_rec_run_emulated_read_val_spec
        ⊕ _set_rec_g_rec_list ↦ gensem set_rec_g_rec_list_spec
        ⊕ _get_rec_vtimer ↦ gensem get_rec_vtimer_spec
        ⊕ _set_rec_par_end ↦ gensem set_rec_par_end_spec
        ⊕ _granule_get_state ↦ gensem granule_get_state_spec
        ⊕ _get_rec_ptimer ↦ gensem get_rec_ptimer_spec
        ⊕ _get_bitmap_loc ↦ gensem get_bitmap_loc_spec
        ⊕ _smc_mark_nonsecure ↦ gensem smc_mark_nonsecure_spec
        ⊕ _get_realm_params_rec_list_addr ↦ gensem get_realm_params_rec_list_addr_spec
        ⊕ _set_g_rtt_rd ↦ gensem set_g_rtt_rd_spec
        ⊕ _atomic_bit_clear_release_64 ↦ gensem atomic_bit_clear_release_64_spec
        ⊕ _ns_buffer_read_data ↦ gensem ns_buffer_read_data_spec
        ⊕ _pgte_write ↦ gensem pgte_write_spec
        ⊕ _is_addr_in_par ↦ gensem is_addr_in_par_spec
        ⊕ _sysreg_write ↦ gensem sysreg_write_spec
        ⊕ _find_granule ↦ gensem find_granule_spec
        ⊕ _get_rec_par_base ↦ gensem get_rec_par_base_spec
        ⊕ _get_rec_g_rd ↦ gensem get_rec_g_rd_spec
        ⊕ _init_rec_read_only ↦ gensem init_rec_read_only_spec
        ⊕ _get_locked_granule ↦ gensem get_locked_granule_spec
        ⊕ _get_rvic_pending_bits ↦ gensem get_rvic_pending_bits_spec
        ⊕ _find_lock_unused_granule ↦ gensem find_lock_unused_granule_spec
        ⊕ _entry_to_phys ↦ gensem entry_to_phys_spec
        ⊕ _stage2_tlbi_ipa ↦ gensem stage2_tlbi_ipa_spec
        ⊕ _atomic_granule_get ↦ gensem atomic_granule_get_spec
        ⊕ _user_step ↦ gensem user_step_spec
        ⊕ _link_table ↦ gensem link_table_spec
        ⊕ _timer_condition_met ↦ gensem timer_condition_met_spec
        ⊕ _addr_is_level_aligned ↦ gensem addr_is_level_aligned_spec
      .

    Definition RmiAux2 := RmiAux2_fresh ⊕ RmiAux2_passthrough.

  End LayerDef.

End Layer.


Require Import compcert.common.AST.
Require Import compcert.common.Events.
Require Import compcert.common.Globalenvs.
Require Import compcert.common.Memory.
Require Import compcert.common.Values.
Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Integers.
Require Import compcert.lib.Maps.
Require Import Seccompconf.

Set Implicit Arguments.

Inductive alu_safe : Type :=
  | Aaddimm: int -> alu_safe
  | Asubimm: int -> alu_safe
  | Amulimm: int -> alu_safe
  | Aandimm: int -> alu_safe
  | Aorimm: int -> alu_safe
  | Axorimm: int -> alu_safe
  | Aadd: alu_safe
  | Asub: alu_safe
  | Amul: alu_safe
  | Aand: alu_safe
  | Aor: alu_safe
  | Axor: alu_safe
  | Aneg: alu_safe
  .

Inductive alu_div : Type :=
  | Adivimm: int -> alu_div
  | Amodimm: int -> alu_div
  | Adiv: alu_div
  | Amod: alu_div
  .

Inductive alu_shift : Type :=
  | Alshimm: int -> alu_shift
  | Arshimm: int -> alu_shift
  | Alsh: alu_shift
  | Arsh: alu_shift
  .

Inductive condition : Type :=
  | Jgtimm: int -> condition
  | Jgeimm: int -> condition
  | Jeqimm: int -> condition
  | Jsetimm: int -> condition
  | Jgt: condition
  | Jge: condition
  | Jeq: condition
  | Jset: condition
  .

Inductive instruction : Type :=
  | Salu_safe: alu_safe -> instruction
      (** A <- arithmetic *)
  | Salu_div: alu_div -> instruction
      (** A <- arithmetic *)
  | Salu_shift: alu_shift -> instruction
      (** A <- arithmetic *)
  | Sld_w_abs: int -> instruction
      (** A <- seccomp_bpf_load(k), access struct seccomp_data *)
  | Sld_w_len: instruction
      (** A <- sizeof(struct seccomp_data) *)
  | Sldx_w_len: instruction
      (** X <- sizeof(struct seccomp_data) *)
  | Sld_imm: int -> instruction
      (** A <- k *)
  | Sldx_imm: int -> instruction
      (** X <- k *)
  | Sld_mem: int -> instruction
      (** A <- [k] *)
  | Sldx_mem: int -> instruction
      (** X <- [k] *)
  | Sst: int -> instruction
      (** [k] <- A *)
  | Sstx: int -> instruction
      (** [k] <- X *)
  | Sjmp_ja: int -> instruction
  | Sjmp_jc: condition -> byte -> byte -> instruction
  | Smisc_tax: instruction
      (** X <- A *)
  | Smisc_txa: instruction
      (** A <- X *)
  | Sret_k: int -> instruction
      (** ret k **)
  | Sret_a: instruction
      (** ret A **)
  .

Definition code := list instruction.

Section PROGRAM.

Definition function := code.

Definition fundef := AST.fundef function.

Definition program := AST.program fundef unit.

End PROGRAM.

Section SEMANTICS.

Definition genv := Genv.t fundef unit.

Inductive state : Type :=
  | State:
    forall (a: int)              (**r accumulator *)
           (x: int)              (**r index register *)
           (sm: ZMap.t val)      (**r scratch memory *)
           (f: function)         (**r current function *)
           (c: code)             (**r current program point *)
           (p: block)            (**r input packet *)
           (m: mem),             (**r memory state *)
    state
  | Callstate:
    forall (fd: fundef)          (**r calling function *)
           (p: block)            (**r input packet *)
           (m: mem),             (**r memory state *)
    state
  | Returnstate:
    forall (v: int)              (**r local return value *)
           (m: mem),             (**r memory state *)
    state
  .

Definition eval_alu_safe (op: alu_safe) (a: int) (x: int): int :=
  match op with
  | Aaddimm k => Int.add a k
  | Asubimm k => Int.sub a k
  | Amulimm k => Int.mul a k
  | Aandimm k => Int.and a k
  | Aorimm k => Int.or a k
  | Axorimm k => Int.xor a k
  | Aadd => Int.add a x
  | Asub => Int.sub a x
  | Amul => Int.mul a x
  | Aand => Int.and a x
  | Aor => Int.or a x
  | Axor => Int.xor a x
  | Aneg => Int.neg a
  end.

Definition eval_alu_div (op: alu_div) (a: int) (x: int): int :=
  match op with
  | Adivimm k => Int.divu a k
  | Amodimm k => Int.modu a k
  | Adiv => Int.divu a x
  | Amod => Int.modu a x
  end.

Definition eval_alu_shift (op: alu_shift) (a: int) (x: int): int :=
  match op with
  | Alshimm k => Int.shl a k
  | Arshimm k => Int.shru a k
  | Alsh => Int.shl a x
  | Arsh => Int.shru a x
  end.

Definition eval_cond (cond: condition) (a: int) (x: int): bool :=
  match cond with
  | Jsetimm k => negb (Int.eq (Int.and a k) Int.zero)
    (* A & k *)
  | Jgtimm k => Int.cmpu Cgt a k
    (* A > k *)
  | Jgeimm k => Int.cmpu Cge a k
    (* A >= k *)
  | Jeqimm k => Int.eq a k
    (* A == k *)
  | Jset => negb (Int.eq (Int.and a x) Int.zero)
    (* A & X *)
  | Jgt => Int.cmpu Cgt a x
    (* A > X *)
  | Jge => Int.cmpu Cge a x
    (* A >= X *)
  | Jeq => Int.eq a x
    (* A == X *)
  end.

Inductive step (ge: genv) : state -> trace -> state -> Prop :=
  | exec_Salu_safe:
      forall op a x sm f b p m,
      let a' := eval_alu_safe op a x in
      step ge (State a x sm f (Salu_safe op :: b) p m)
        E0 (State a' x sm f b p m)
  (* NB: could return 0 for div by zero *)
  | exec_Salu_div:
      forall op a x sm f b p m,
      let a' := eval_alu_div op a x in
      step ge (State a x sm f (Salu_div op :: b) p m)
        E0 (State a' x sm f b p m)
  | exec_Salu_shift:
      forall op a x sm f b p m,
      let a' := eval_alu_shift op a x in
      step ge (State a x sm f (Salu_shift op :: b) p m)
        E0 (State a' x sm f b p m)
  | exec_Sjmp_ja:
      forall a x sm f k b p m,
      let off := Int.unsigned k in
      off < (list_length_z b) ->
      step ge (State a x sm f (Sjmp_ja k :: b) p m)
        E0 (State a x sm f (skipn (nat_of_Z off) b) p m)
  | exec_Sjmp_jc:
      forall cond jt jf a x sm f b p m,
      let off := Byte.unsigned (if (eval_cond cond a x) then jt else jf) in
      off < (list_length_z b) ->
      step ge (State a x sm f (Sjmp_jc cond jt jf :: b) p m)
        E0 (State a x sm f (skipn (nat_of_Z off) b) p m)
  | exec_Sld_w_abs:
      forall a a' k x sm f b p m,
      let off := Int.unsigned k in
      off < sizeof_seccomp_data ->
      off mod 4 = 0 ->
      Mem.load Mint32 m p off = Some (Vint a') ->
      step ge (State a x sm f (Sld_w_abs k :: b) p m)
        E0 (State a' x sm f b p m)
  | exec_Sld_w_len:
      forall a x sm f b p m,
      let a' := Int.repr sizeof_seccomp_data in
      step ge (State a x sm f (Sld_w_len :: b) p m)
        E0 (State a' x sm f b p m)
  | exec_Sldx_w_len:
      forall a x sm f b p m,
      let x' := Int.repr sizeof_seccomp_data in
      step ge (State a x sm f (Sldx_w_len :: b) p m)
        E0 (State a x' sm f b p m)
  | exec_Sld_imm:
      forall a x sm f k b p m,
      step ge (State a x sm f (Sld_imm k :: b) p m)
        E0 (State k x sm f b p m)
  | exec_Sldx_imm:
      forall a x sm f k b p m,
      step ge (State a x sm f (Sldx_imm k :: b) p m)
        E0 (State a k sm f b p m)
  | exec_Sld_mem:
      forall a a' k x sm f b p m,
      let idx := Int.unsigned k in
      idx < seccomp_memwords ->
      ZMap.get idx sm = Vint a' ->
      step ge (State a x sm f (Sld_mem k :: b) p m)
        E0 (State a' x sm f b p m)
  | exec_Smisc_tax:
      forall a x sm f b p m,
      step ge (State a x sm f (Smisc_tax :: b) p m)
        E0 (State a a sm f b p m)
  | exec_Smisc_txa:
      forall a x sm f b p m,
      step ge (State a x sm f (Smisc_txa :: b) p m)
        E0 (State x x sm f b p m)
  | exec_Sret_a:
      forall a x sm f b p m,
      step ge (State a x sm f (Sret_a :: b) p m)
        E0 (Returnstate a m)
  | exec_Sret_k:
      forall a x sm f k b p m,
      step ge (State a x sm f (Sret_k k :: b) p m)
        E0 (Returnstate k m)
  | exec_call:
      forall f p m,
      step ge (Callstate (Internal f) p m)
        E0 (State Int.zero Int.zero (ZMap.init Vundef) f f p m)
  .

Inductive initial_state (p: program): state -> Prop :=
  | initial_state_intro: forall b fd m0 m1 m2 pkt,
    let ge := Genv.globalenv p in
    Genv.init_mem p = Some m0 ->
    Genv.find_symbol ge p.(prog_main) = Some b ->
    Genv.find_funct_ptr ge b = Some fd ->
    Mem.alloc m0 0 sizeof_seccomp_data = (m1, pkt) ->
    Mem.storebytes m1 pkt 0 (Memdata.inj_bytes seccomp_data) = Some m2 ->
    initial_state p (Callstate fd pkt m2).

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

End SEMANTICS.


(*
 * © 2020 XXX.
 *
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     List.

From SPICY Require Import
     MyPrelude
     Maps
     ChMaps
     Messages
     ModelCheck
     Keys
     Automation
     Tactics
     Simulation
     AdversaryUniverse

     ModelCheck.UniverseEqAutomation
     ModelCheck.ProtocolAutomation
     ModelCheck.SafeProtocol
     ModelCheck.ProtocolFunctions
.

From SPICY Require IdealWorld RealWorld.

Import IdealWorld.IdealNotations
       RealWorld.RealWorldNotations
       SimulationAutomation.

From Frap Require Import Sets.

Module Foo <: Sets.EMPTY.
End Foo.
Module Export SN := Sets.SetNotations(Foo).

Set Implicit Arguments.

Open Scope protocol_scope.

Module SecureDNSProtocol.

  (* Start with two users, as that is the minimum for any interesting protocol *)
  Notation USR1 := 0.
  Notation USR2 := 1.
  Notation USR3 := 2.

  Parameter names : NatMap.t nat.

  Section IW.
    Import IdealWorld.

    (* Set up initial communication channels so each user can talk directly to the other *)
    Notation pCH12 := 0.
    Notation pCH21 := 1.
    Notation pCH23 := 2.
    Notation pCH32 := 3.
    Notation CH12  := (# pCH12).
    Notation CH21  := (# pCH21).
    Notation CH23  := (# pCH23).
    Notation CH32  := (# pCH32).

    (* This is the initial channel vector, each channel should be represented and start with
     * no messages.
     *)
    Notation empty_chs := (#0 #+ (CH12, []) #+ (CH21, []) #+ (CH23, []) #+ (CH32, [])).

    Notation PERMS1 := ($0 $+ (pCH12, writer) $+ (pCH21, reader)).
    Notation PERMS2 := ($0 $+ (pCH12, reader) $+ (pCH21, writer) $+ (pCH23, writer) $+ (pCH32, reader)).
    Notation PERMS3 := ($0 $+ (pCH23, reader) $+ (pCH32, writer)).

    Fixpoint idealServer (n : nat) {t} (r : << t >>) (c : cmd t) : cmd t :=
      match n with
      | 0   => @Return t r
      | S i => (r' <- c ; idealServer i r' c)
      end.

    (* Fill in the users' protocol specifications here, adding additional users as needed.
     * Note that all users must return an element of the same type, and that type needs to
     * be one of: ...
     *)
    Notation ideal_users :=
      [
        (* Authorative DNS Server Specification *)
        mkiUsr USR1 PERMS1
               (
                 @idealServer 1 (Base Nat) 1
                              (
                                m <- @Recv Nat CH21
                                ; let ip := match names $? extractContent m with
                                            | None   => 0
                                            | Some a => a
                                            end
                                  in
                                  _ <- Send (Content ip) CH12
                                ; @Return (Base Nat) ip
                              )
               )
        ;

      (* Secure DNS Cache Specification *)
      mkiUsr USR2 PERMS2
             (
               req <- @Recv Nat CH32
               ; _ <- Send (Content (extractContent req)) CH21
               ; ip1 <- @Recv Nat CH12
               ; _ <- Send (Content (extractContent ip1)) CH23
               ; @Return (Base Nat) (extractContent ip1)
             )
        ;

      (* DNS Client Specification *)
      mkiUsr USR3 PERMS3
             (
               _ <- Send (Content 0) CH32
               ; ip1 <- @Recv Nat CH23
               ; @Return (Base Nat) (extractContent ip1)
             )
      ].

    (* This is where the entire specification universe gets assembled.  It is unlikely anything
     * will need to change here.
     *)
    Definition ideal_univ_start :=
      mkiU empty_chs ideal_users.

  End IW.

  Section RW.
    Import RealWorld.

    (* Key management needs to be bootstrapped.  Since all honest users must only send signed
     * messages, we need some way of initially distributing signing keys in order to be able
     * to begin secure communication.  This is analagous in the real world where we need to
     * have some sort of trust relationship in order to distribute trusted keys.
     *
     * Here, each user has a public asymmetric signing key.
     *)
    Notation KID1 := 0.
    Notation KID2 := 1.
    Notation KID3 := 2.
    Notation KID4 := 3.
    Notation KID5 := 4.
    Notation KID6 := 5.

    Notation KEYS := [ skey KID1 ; ekey KID2 ; skey KID3 ; ekey KID4 ; skey KID5 ; ekey KID6 ].

    Notation KEYS1 := ($0 $+ (KID1, true) $+ (KID2, true) $+ (KID3, false) $+ (KID4, false)).
    Notation KEYS2 := ($0 $+ (KID1, false) $+ (KID2, false)
                        $+ (KID3, true) $+ (KID4, true)
                        $+ (KID5, false) $+ (KID6, false)).
    Notation KEYS3 := ($0 $+ (KID3, false) $+ (KID4, false) $+ (KID5, true) $+ (KID6, true)).

    Fixpoint realServer (n : nat) {t} (r : << t >>) (c : user_cmd t) : user_cmd t :=
      match n with
      | 0   => @Return t r
      | S i => (r' <- c ; realServer i r' c)
      end.

    Notation real_users :=
      [
        (* Authoritative DNS server implementation *)
        MkRUserSpec USR1 KEYS1
                    (
                      @realServer 1 (Base Nat) 1
                                  ( c <- @Recv Nat (SignedEncrypted KID3 KID2 true)
                                    ; m <- Decrypt c
                                    ; let ip := match names $? (extractContent m) with
                                                | None   => 0
                                                | Some a => a
                                                end
                                      in ipC <- SignEncrypt KID1 KID4 USR2 (message.Content ip)
                                    ; _ <- Send USR2 ipC
                                    ; @Return (Base Nat) ip
                                  )
                    )
        ;

      (* Secure DNS Cache implementation *)
      MkRUserSpec USR2 KEYS2
                  (
                    reqc <- @Recv Nat (SignedEncrypted KID5 KID4 true)
                    ; req <- Decrypt reqc
                    ; c1 <- SignEncrypt KID3 KID2 USR1 (message.Content (extractContent req))
                    ; _ <- Send USR1 c1
                    ; hostC <- @Recv Nat (SignedEncrypted KID1 KID4 true)
                    ; host <- Decrypt hostC
                    ; c2 <- SignEncrypt KID3 KID6 USR3 (message.Content (extractContent host))
                    ; _ <- Send USR3 c2
                    ; @Return (Base Nat) (extractContent host)
                  )
        ;

      (* DNS Client implementation *)
      MkRUserSpec USR3 KEYS3
                  (
                    c <- SignEncrypt KID5 KID4 USR2 (message.Content 0)
                    ; _ <- Send USR2 c
                    ; hostC <- @Recv Nat (SignedEncrypted KID3 KID6 true)
                    ; host <- Decrypt hostC
                    ; @Return (Base Nat) (extractContent host)
                  )
      ].

    (* Here is where we put the implementation universe together.  Like above, it is
     * unlikely anything will need to change here.
     *)
    Definition real_univ_start :=
      mkrU (mkKeys KEYS) real_users.
  End RW.

  (* These are here to help the proof automation.  Don't change. *)
  #[export] Hint Unfold
       real_univ_start
       ideal_univ_start
    : user_build.

  #[export] Hint Extern 0 (IdealWorld.lstep_universe _ _ _) =>
    progress(autounfold with user_build; simpl) : core.

End SecureDNSProtocol.


(*
	coqtop -R ../../../kami/Kami Kami -R $PWD BK
*)

Require Import Bool String List Arith.
Require Import Kami.
Require Import Lib.Indexer Lib.Struct.
Require Import Bsvtokami.
Require Import MiniRiscvMMode.
Require Import Kami.Duplicate.

Require Import FunctionalExtensionality.

Set Implicit Arguments.

Definition spec := ProcMMode'modules (mkMiniRiscvMMode "spec" ($$(natToWord 1 0))%kami ($$ (natToWord 1 0))%kami ($$ (natToWord 1 0))%kami).
Definition impl := ProcMMode'modules (mkMiniRiscvMMode "impl" ($$(natToWord 1 0))%kami ($$ (natToWord 1 0))%kami ($$ (natToWord 1 0))%kami).

Check spec.
Check impl.

Compute (map (fun reg => (attrName reg)) (getRegInits (spec))).

Hint Unfold spec impl: ModuleDefs.

Definition spec_impl_ruleMap (_: RegsT): string -> option string :=
  fun regname => Some regname.

Compute 1.

Lemma spec_ModEquiv:
  ModPhoasWf spec.
Proof. kequiv. Qed.
Hint Resolve spec_ModEquiv.

Compute 2.

Lemma impl_ModEquiv:
  ModPhoasWf impl.
Proof. kequiv. Qed.
Hint Resolve impl_ModEquiv.

Compute 3.

Require Import Kami.Wf.
Require Import Lib.Reflection.
Require Import Lib.StringEq.

Definition Is_true (b : bool) :=
  match b with
  | true => True
  | false => False
  end.

Theorem eqb_a_a:
  (forall a : bool, Is_true (eqb a a)).
Proof.
  intros a.
  case a.
    simpl. exact I.
    simpl. exact I.
Qed.

Theorem spec_impl_refinement:
  impl <<== spec.
Proof.
  (* repeat autounfold with ModuleDefs. *)
  apply traceRefines_inlining_left.
  apply impl_ModEquiv.
  kinline_compute.
  noDup_tac.
  remember (inlineF impl) as im eqn:Heq.
  repeat autounfold with ModuleDefs in Heq.

  cbv [string_eq attrName withPrefix append prefixSymbol] in Heq.
  cbv [inlineF inline inlineDms inlineDms'
               inlineDmToMod inlineDmToRules inlineDmToRule
               inlineDmToDms inlineDmToDm inlineDm
               filterDms filter
               noInternalCalls noCalls
               noCallsRules noCallsDms noCallDm isLeaf
               getBody inlineArg
               appendAction getAttribute
               makeModule makeModule' max plus
	       ] in Heq.

  cbv [getDefsBodies namesOf filter map app attrName string_eq ascii_eq] in Heq.
  rewrite eqb_reflx in Heq.
  rewrite andb_diag in Heq.

  cbv [getDefsBodies namesOf filter map app attrName string_eq ascii_eq andb orb negb] in Heq.

  cbv [inlineF inline inlineDms inlineDms'
               inlineDmToMod inlineDmToRules inlineDmToRule
               inlineDmToDms inlineDmToDm inlineDm
               filterDms filter
               noInternalCalls noCalls
               noCallsRules noCallsDms noCallDm isLeaf
               getBody inlineArg
               appendAction getAttribute
               makeModule makeModule' max plus
               getRegInits getDefs getDefsBodies getRules namesOf
               map app attrName attrType
               getCalls getCallsR getCallsM getCallsA
	       ] in Heq.

  cbv [inlineF inline inlineDms inlineDms'
               inlineDmToMod inlineDmToRules inlineDmToRule
               inlineDmToDms inlineDmToDm inlineDm
               filterDms filter
               noInternalCalls noCalls
               noCallsRules noCallsDms noCallDm isLeaf
               getBody inlineArg
               appendAction getAttribute
               makeModule makeModule' max plus
               getRegInits getDefs getDefsBodies getRules namesOf
               map app attrName attrType
               getCalls getCallsR getCallsM getCallsA
               ret arg fst snd projT1 projT2
               string_in string_eq ascii_eq
               eqb existsb andb orb negb] in Heq.

  (* kinline_left implInlined. *)

  kdecompose_nodefs spec_impl_regMap spec_impl_ruleMap.
Qed.