(** VCFloat: A Unified Coq Framework for Verifying C Programs with
 Floating-Point Computations. Application to SAR Backprojection.

 Version 1.0 (2015-12-04)

 Copyright (C) 2015 Reservoir Labs Inc.
 All rights reserved.

 This file, which is part of VCFloat, is free software. You can
 redistribute it and/or modify it under the terms of the GNU General
 Public License as published by the Free Software Foundation, either
 version 3 of the License (GNU GPL v3), or (at your option) any later
 version. A verbatim copy of the GNU GPL v3 is included in gpl-3.0.txt.

 This file is distributed in the hope that it will be useful, but
 WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See LICENSE for
 more details about the use and redistribution of this file and the
 whole VCFloat library.

 This work is sponsored in part by DARPA MTO as part of the Power
 Efficiency Revolution for Embedded Computing Technologies (PERFECT)
 program (issued by DARPA/CMO under Contract No: HR0011-12-C-0123). The
 views and conclusions contained in this work are those of the authors
 and should not be interpreted as representing the official policies,
 either expressly or implied, of the DARPA or the
 U.S. Government. Distribution Statement "A" (Approved for Public
 Release, Distribution Unlimited.)

 If you are using or modifying VCFloat in your work, please consider
 citing the following paper:

 Tahina Ramananandro, Paul Mountcastle, Benoit Meister and Richard
 Lethin.
 A Unified Coq Framework for Verifying C Programs with Floating-Point
 Computations.
 In CPP (5th ACM/SIGPLAN conference on Certified Programs and Proofs)
 2016.

 VCFloat requires third-party libraries listed in ACKS along with their
 copyright information.

 VCFloat depends on third-party libraries listed in ACKS along with
 their copyright and licensing information.
*)
(**
Author: Tahina Ramananandro <ramananandro@reservoir.com>

VCFloat: automatic translation of a CompCert Clight floating-point
expression into a real-number expression with all rounding error terms
and their correctness proofs.
**)

Require Import Lia.
From vcfloat Require Export FPCore. (* FPLang Rounding FPLangOpt.*)
Require compcert.common.AST compcert.common.Values.
Require Import compcert.lib.Floats.
Import Binary BinPos.

Inductive val_inject: Values.val -> forall ty, ftype ty -> Prop :=
| val_inject_single (f: ftype Tsingle):
    val_inject (Values.Vsingle f) Tsingle f
| val_inject_double f:
    val_inject (Values.Vfloat f) Tdouble f
.

Lemma val_inject_single_inv (f1: float32) (f2: ftype Tsingle):
  val_inject (Values.Vsingle f1) Tsingle f2 ->
  f1 = f2.
Proof.
  inversion 1; subst.
  revert H2.
  apply Eqdep_dec.inj_pair2_eq_dec; auto.
  apply type_eq_dec.
Qed.

Lemma val_inject_double_inv f1 f2:
  val_inject (Values.Vfloat f1) Tdouble f2 ->
  f1 = f2.
Proof.
  inversion 1; subst.
  revert H2.
  apply Eqdep_dec.inj_pair2_eq_dec; auto.
  apply type_eq_dec.
Qed.

Definition val_injectb v ty (f: ftype ty): bool :=
  match v with
    | Values.Vsingle f' =>
      type_eqb Tsingle ty && binary_float_eqb f' f
    | Values.Vfloat f' =>
      type_eqb Tdouble ty && binary_float_eqb f' f
    | _ => false
  end.

Lemma val_injectb_inject v ty f:
  val_injectb v ty f = true <-> val_inject v ty f.
Proof.
  unfold val_injectb.
  destruct v;
  (try (split; (try congruence); inversion 1; fail));
  rewrite Bool.andb_true_iff.
  {
    destruct (type_eqb Tdouble ty) eqn:EQ.
    {
      rewrite type_eqb_eq in EQ.
      subst.
      rewrite binary_float_eqb_eq.
      split.
      {
        destruct 1; subst.
        constructor.
      }
      intros; eauto using val_inject_double_inv.
    }
    split; try intuition congruence.
    inversion 1; subst.
    apply type_eqb_eq in H3.
    congruence.
  }
  destruct (type_eqb Tsingle ty) eqn:EQ.
  {
    rewrite type_eqb_eq in EQ.
    subst.
    rewrite binary_float_eqb_eq.
    split.
    {
      destruct 1; subst.
      constructor.
    }
    intros; eauto using val_inject_single_inv.
  }
  split; try intuition congruence.
  inversion 1; subst.
  apply type_eqb_eq in H3.
  congruence.
Qed.

Lemma conv_nan_ex:
  { conv_nan: forall ty1 ty2,
                binary_float (fprec ty1) (femax ty1) -> (* guaranteed to be a nan, if this is not a nan then any result will do *)
                nan_payload (fprec ty2) (femax ty2)
  |
  conv_nan Tsingle Tdouble = Floats.Float.of_single_nan
  /\
  conv_nan Tdouble Tsingle = Floats.Float.to_single_nan
  }.
Proof.
  eapply exist.
  Unshelve.
  {
    shelve.
  }
  intros ty1 ty2.
  destruct (type_eq_dec ty1 Tsingle).
  {
    subst.
    destruct (type_eq_dec ty2 Tdouble).
    {
      subst.
      exact Floats.Float.of_single_nan.
    }
    auto using any_nan.
  }
  destruct (type_eq_dec ty1 Tdouble).
  {
    subst.
    destruct (type_eq_dec ty2 Tsingle).
    {
      subst.
      exact Floats.Float.to_single_nan.
    }
    intros.
    auto using any_nan.
  }
  intros.
  auto using any_nan.
  Unshelve.
  split; reflexivity.
Defined.

Definition conv_nan := let (c, _) := conv_nan_ex in c.

Lemma single_double_ex (U: _ -> Type):
  (forall ty, U ty) ->
  forall s: U Tsingle,
  forall d: U Tdouble,
    {
      f: forall ty, U ty |
      f Tsingle = s /\
      f Tdouble = d
    }.
Proof.
  intro ref.
  intros.
  esplit.
  Unshelve.
  shelve.
  intro ty.
  destruct (type_eq_dec ty Tsingle).
  {
    subst.
    exact s.
  }
  destruct (type_eq_dec ty Tdouble).
  {
    subst.
    exact d.
  }
  apply ref.
  Unshelve.
  split; reflexivity.
Defined.

Definition single_double (U: _ -> Type)
           (f_: forall ty, U ty)
           (s: U Tsingle)
           (d: U Tdouble)
:
  forall ty, U ty :=
  let (f, _) := single_double_ex U f_ s d in f.

Definition binop_nan :  forall ty, binary_float (fprec ty) (femax ty) ->
       binary_float (fprec ty) (femax ty) ->
       nan_payload (fprec ty) (femax ty) :=
  single_double
    (fun ty =>
       binary_float (fprec ty) (femax ty) ->
       binary_float (fprec ty) (femax ty) ->
       nan_payload (fprec ty) (femax ty))
     (fun ty  _ _ => any_nan ty)
     Floats.Float32.binop_nan
     Floats.Float.binop_nan.

Definition abs_nan :=
  single_double
    (fun ty =>
       binary_float (fprec ty) (femax ty) ->
       nan_payload (fprec ty) (femax ty))
     (fun ty  _ => any_nan ty)
     Floats.Float32.abs_nan
     Floats.Float.abs_nan.

Definition opp_nan :=
  single_double
    (fun ty =>
       binary_float (fprec ty) (femax ty) ->
       nan_payload (fprec ty) (femax ty))
     (fun ty  _ => any_nan ty)
     Floats.Float32.neg_nan
     Floats.Float.neg_nan.

Module FMA_NAN.
(* some of these definitions adapted from [the open-source part of] CompCert  *)
Import ZArith. Import Coq.Lists.List.

(** Transform a Nan payload to a quiet Nan payload. *)

Definition quiet_nan_payload (t: type) (p: positive) :=
  Z.to_pos (Zbits.P_mod_two_p (Pos.lor p ((Zaux.iter_nat xO (Z.to_nat (fprec t - 2)) 1%positive))) (Z.to_nat (fprec t - 1))).

Lemma quiet_nan_proof (t: type): forall p, Binary.nan_pl (fprec t) (quiet_nan_payload t p) = true.
Proof.
intros.
pose proof (fprec_gt_one t).
 apply normalized_nan; auto; lia.
Qed.

Definition quiet_nan (t: type) (sp: bool * positive) : {x : ftype t | Binary.is_nan _ _ x = true} :=
  let (s, p) := sp in
  exist _ (Binary.B754_nan (fprec t) (femax t) s (quiet_nan_payload t p) (quiet_nan_proof t p)) (eq_refl true).

Definition default_nan (t: type) := (fst Archi.default_nan_64, iter_nat (Z.to_nat (fprec t - 2)) _ xO xH).

Inductive NAN_SCHEME := NAN_SCHEME_ARM | NAN_SCHEME_X86 | NAN_SCHEME_RISCV.

Definition the_nan_scheme : NAN_SCHEME.
Transparent Archi.choose_nan_64.
try (unify Archi.choose_nan_64 Archi.default_nan_64; exact NAN_SCHEME_RISCV);
try (unify Archi.choose_nan_64 (fun l => match l with nil => Archi.default_nan_64 | n::_ => n end);
      exact NAN_SCHEME_X86);
try (let p := constr:(Archi.choose_nan_64) in
      let p := eval red in p in
      match p with _ (fun p => negb (Pos.testbit p 51)) _ => idtac end;
      exact NAN_SCHEME_ARM).
Opaque Archi.choose_nan_64.
Defined.

Definition ARMchoose_nan (is_signaling: positive -> bool)
                      (default: bool * positive)
                      (l0: list (bool * positive)) : bool * positive :=
  let fix choose_snan (l1: list (bool * positive)) :=
    match l1 with
    | nil =>
        match l0 with nil => default | n :: _ => n end
    | ((s, p) as n) :: l1 =>
        if is_signaling p then n else choose_snan l1
    end
  in choose_snan l0.

Definition choose_nan (t: type) : list (bool * positive) -> bool * positive :=
 match the_nan_scheme with
 | NAN_SCHEME_RISCV => fun _ => default_nan t
 | NAN_SCHEME_X86 => fun l => match l with nil => default_nan t | n :: _ => n end
 | NAN_SCHEME_ARM => ARMchoose_nan (fun p => negb (Pos.testbit p (Z.to_N (fprec t - 2))))
                                          (default_nan t)
 end.

Definition cons_pl {t: type} (x : ftype t) (l : list (bool * positive)) :=
match x with
| Binary.B754_nan _ _ s p _ => (s, p) :: l
| _ => l
end.

Definition fma_nan_1 (t: type) (x y z: ftype t) : {x : ftype t | @Binary.is_nan (fprec t) (femax t) x = true} :=
  let '(a, b, c) := Archi.fma_order x y z in
  quiet_nan t (choose_nan t (cons_pl a (cons_pl b (cons_pl c nil)))).

Definition fma_nan_pl (t: type) (x y z: ftype t) : {x : ftype t | Binary.is_nan _ _ x = true} :=
  match x, y with
  | Binary.B754_infinity _ _ _, Binary.B754_zero _ _ _ | Binary.B754_zero _ _ _, Binary.B754_infinity _ _ _ =>
      if Archi.fma_invalid_mul_is_nan
      then quiet_nan t (choose_nan t (default_nan t :: cons_pl z nil))
      else fma_nan_1 t x y z
  | _, _ =>
      fma_nan_1 t x y z
  end.

End FMA_NAN.

#[export] Instance nans: Nans :=
  {
    conv_nan := conv_nan;
    plus_nan := binop_nan;
    mult_nan := binop_nan;
    div_nan := binop_nan;
    abs_nan := abs_nan;
    opp_nan := opp_nan;
    sqrt_nan := (fun ty _ => any_nan ty);
    fma_nan := FMA_NAN.fma_nan_pl
  }.

Lemma val_inject_eq_rect_r v ty1 e:
  val_inject v ty1 e ->
  forall ty2 (EQ: ty2 = ty1),
    val_inject v ty2 (eq_rect_r _ e EQ).
Proof.
  intros.
  subst.
  assumption.
Qed.

Lemma val_inject_single_inv_r v f:
  val_inject v Tsingle f ->
  v = Values.Vsingle f.
Proof.
  inversion 1; subst.
  apply val_inject_single_inv in H.
  congruence.
Qed.

Lemma val_inject_double_inv_r v f:
  val_inject v Tdouble f ->
  v = Values.Vfloat f.
Proof.
  inversion 1; subst.
  apply val_inject_double_inv in H.
  congruence.
Qed.

(** Why do we need this rewrite hint database?
   You might think that all of this could be accomplished with "change"
   instead of "rewrite".  But if you do that, then Qed takes forever. *)
Lemma Float32_add_rewrite: Float32.add = @BPLUS _ Tsingle.
Proof. reflexivity. Qed.
#[export] Hint Rewrite Float32_add_rewrite : float_elim.
Lemma Float32_sub_rewrite: Float32.sub = @BMINUS _ Tsingle.
Proof. reflexivity. Qed.
#[export] Hint Rewrite Float32_sub_rewrite : float_elim.
Lemma Float32_mul_rewrite: Float32.mul = @BMULT _ Tsingle.
Proof. reflexivity. Qed.
#[export] Hint Rewrite Float32_mul_rewrite : float_elim.
Lemma Float32_div_rewrite: Float32.div = @BDIV _ Tsingle.
Proof. reflexivity. Qed.
#[export] Hint Rewrite Float32_div_rewrite : float_elim.
Lemma Float32_neg_rewrite: Float32.neg = @BOPP _ Tsingle.
Proof. reflexivity. Qed.
#[export] Hint Rewrite Float32_neg_rewrite : float_elim.
Lemma Float32_abs_rewrite: Float32.abs = @BABS _ Tsingle.
Proof. reflexivity. Qed.
#[export] Hint Rewrite Float32_abs_rewrite : float_elim.

Lemma Float_add_rewrite: Float.add = @BPLUS _ Tdouble.
Proof. reflexivity. Qed.
#[export] Hint Rewrite Float_add_rewrite : float_elim.
Lemma Float_sub_rewrite: Float.sub = @BMINUS _ Tdouble.
Proof. reflexivity. Qed.
#[export] Hint Rewrite Float_sub_rewrite : float_elim.
Lemma Float_mul_rewrite: Float.mul = @BMULT _ Tdouble.
Proof. reflexivity. Qed.
#[export] Hint Rewrite Float_mul_rewrite : float_elim.
Lemma Float_div_rewrite: Float.div = @BDIV _ Tdouble.
Proof. reflexivity. Qed.
#[export] Hint Rewrite Float_div_rewrite : float_elim.
Lemma Float_neg_rewrite: Float.neg = @BOPP _ Tdouble.
Proof. reflexivity. Qed.
#[export] Hint Rewrite Float_neg_rewrite : float_elim.
Lemma Float_abs_rewrite: Float.abs = @BABS _ Tdouble.
Proof. reflexivity. Qed.
#[export] Hint Rewrite Float_abs_rewrite : float_elim.

Lemma float_of_single_eq: Float.of_single = @cast _ Tdouble Tsingle.
Proof. reflexivity. Qed.

Lemma float32_to_double_eq: Float32.to_double = @cast _ Tdouble Tsingle.
Proof. reflexivity. Qed.
Lemma float32_of_float_eq: Float32.of_double = @cast _ Tsingle Tdouble.
Proof. reflexivity. Qed.
Lemma float_to_single_eq: Float.to_single = @cast _ Tsingle Tdouble.
Proof. reflexivity. Qed.
#[export] Hint Rewrite float_of_single_eq float32_to_double_eq
          float32_of_float_eq float_to_single_eq : float_elim.

Import Float_notations.

Lemma B754_finite_ext:
  forall prec emax s m e p1 p2,
    Binary.B754_finite prec emax s m e p1 = Binary.B754_finite prec emax s m e p2.
Proof.
intros.
f_equal.
apply Classical_Prop.proof_irrelevance.
Qed.

Import Integers.

Ltac canonicalize_float_constant x :=
match x with
| Float32.of_bits (Int.repr ?a) =>
  const_Z a;
  let x' := constr:(Bits.b32_of_bits a) in
  let y := eval compute in x' in
 match y with
   | Binary.B754_finite _ _ ?s ?m ?e _ =>
     let z := constr:(b32_B754_finite s m e (@eq_refl bool true))
      in change x with x';
        replace x' with z by (apply B754_finite_ext; reflexivity)
   | Binary.B754_zero _ _ ?s =>
       let z := constr:(b32_B754_zero s) in
       change x with z
  end
| Float.of_bits (Int64.repr ?a) =>
  const_Z a;
  let x' := constr:(Bits.b64_of_bits a) in
  let y := eval compute in x' in
 match y with
   | Binary.B754_finite _ _ ?s ?m ?e _ =>
     let z := constr:(b64_B754_finite s m e (@eq_refl bool true))
      in change x with x';
        replace x' with z by (apply B754_finite_ext; reflexivity)
   | Binary.B754_zero _ _ ?s =>
       let z := constr:(b64_B754_zero s) in
       change x with z
  end
end.

Ltac canonicalize_float_constants :=
  repeat
    match goal with
    | |- context [Binary.B754_finite 24 128 ?s ?m ?e ?p] =>
         let x := constr:(Binary.B754_finite 24 128 s m e p) in
         let e' := eval compute in e in
         let z := constr:(b32_B754_finite s m e' (@eq_refl bool true)) in
         replace x with z by (apply B754_finite_ext; reflexivity)
    | |- context [Binary.B754_finite 53 1024 ?s ?m ?e ?p] =>
         let x := constr:(Binary.B754_finite 53 1024 s m e p) in
         let e' := eval compute in e in
         let z := constr:(b64_B754_finite s m e' (@eq_refl bool true)) in
         replace x with z by (apply B754_finite_ext; reflexivity)
    | |- context [Float32.of_bits (Int.repr ?a)] =>
     canonicalize_float_constant constr:(Float32.of_bits (Int.repr a))
    | |- context [Float.of_bits (Int64.repr ?a)] =>
     canonicalize_float_constant constr:(Float.of_bits (Int64.repr a))
    end.


Require Import ModelProperties.
Require Import AuxiliaryLemmas.

Section addUsrGrpToAclIsSecure.

Lemma AddUsrGrpToAclPSS :
 forall (s t : SFSstate) (u : SUBJECT),
 SecureState s -> TransFunc u s AddUsrGrpToAcl t -> SecureState t.
StartPSS.
inversion H.
unfold SecureState in |- *.
BreakSS.
split.
unfold DACSecureState in |- *.
simpl in |- *.
intros.
elim (OBJeq_dec o o0).
intro.
rewrite <- a.
cut (fsecmat (secmat s) o = None).
intro.
rewrite H6.
eauto.

unfold fsecmat in |- *.
auto.

intro.
cut
 (match fsecmat (secmat s) o0 with
  | Some y => set_In u0 (ActReaders y) -> PreDACRead s u0 o0
  | None => True
  end /\
  match fsecmat (secmat s) o0 with
  | Some y => set_In u0 (ActWriters y) -> PreDACWrite s u0 o0
  | None => True
  end).
elim (fsecmat (secmat s) o0).
unfold PreDACRead, PreDACWrite, addUsrGrpToAcl_acl in |- *.
simpl in |- *.
elim (facl (acl s) o).
intro.
replace
 (facl
    (set_add ACLeq_dec
       (o,
       acldata (owner a) (group a) (set_add SUBeq_dec ru (UsersReaders a))
         (set_add GRPeq_dec rg (GroupReaders a))
         (set_add SUBeq_dec wu (UsersWriters a))
         (set_add GRPeq_dec wg (GroupWriters a))
         (set_add SUBeq_dec pu (UsersOwners a))
         (set_add GRPeq_dec pg (GroupOwners a)))
       (set_remove ACLeq_dec (o, a) (acl s))) o0) with
 (facl (acl s) o0).
elim (facl (acl s) o0).
auto.

auto.

unfold facl in |- *.
auto.

auto.

trivial.

split.
apply ReadWriteImpRead.
auto.

apply ReadWriteImpWrite.
auto.

auto.

Qed.

Lemma AddUsrGrpToAclPSP :
 forall (s t : SFSstate) (u : SUBJECT),
 StarProperty s -> TransFunc u s AddUsrGrpToAcl t -> StarProperty t.
StartPSP.
inversion H; auto.
Qed.

Lemma AddUsrGrpToAclPCP :
 forall s t : SFSstate, PreservesControlProp s AddUsrGrpToAcl t.
intros; unfold PreservesControlProp in |- *; intros Sub TF; inversion TF;
 unfold ControlProperty in |- *.
inversion H.
split.
intros.
split.
intro.
inversion H6.
simpl in H8.
elim (OBJeq_dec o o0); intro.
rewrite <- a; auto.

cut (y = z).
intro.
cut False.
tauto.

rewrite H10 in H9; inversion H9; auto.

cut (facl (addUsrGrpToAcl_acl s o ru wu pu rg wg pg) o0 = facl (acl s) o0).
intro H10; rewrite H10 in H8; rewrite H7 in H8; injection H8; auto.

symmetry  in |- *.
unfold addUsrGrpToAcl_acl in |- *.
elim (facl (acl s) o).
intro; unfold facl in |- *; apply AddRemEq.
auto.

auto.

simpl in H8.
elim (OBJeq_dec o o0); intro.
rewrite <- a; auto.

cut (y = z).
intro.
cut False.
tauto.

rewrite H10 in H9; inversion H9; auto.

cut (facl (addUsrGrpToAcl_acl s o ru wu pu rg wg pg) o0 = facl (acl s) o0).
intro H10; rewrite H10 in H8; rewrite H7 in H8; injection H8; auto.

symmetry  in |- *.
unfold addUsrGrpToAcl_acl in |- *.
elim (facl (acl s) o).
intro; unfold facl in |- *; apply AddRemEq.
auto.

auto.

intro;
 absurd
  (MACObjCtrlAttrHaveChanged s
     (mkSFS (groups s) (primaryGrp s) (subjectSC s)
        (AllGrp s) (RootGrp s) (SecAdmGrp s) (objectSC s)
        (addUsrGrpToAcl_acl s o ru wu pu rg wg pg)
        (secmat s) (files s) (directories s)) o0);
 auto.

intros;
 absurd
  (MACSubCtrlAttrHaveChanged s
     (mkSFS (groups s) (primaryGrp s) (subjectSC s)
        (AllGrp s) (RootGrp s) (SecAdmGrp s) (objectSC s)
        (addUsrGrpToAcl_acl s o ru wu pu rg wg pg)
        (secmat s) (files s) (directories s)) u0);
 auto.

Qed.

End addUsrGrpToAclIsSecure.

Hint Resolve AddUsrGrpToAclPSS AddUsrGrpToAclPSP AddUsrGrpToAclPCP.


(* GENERIC *)

Require Export MinBFTcount_gen2_request.
Require Export MinBFTcount_gen2_reply.
Require Export MinBFTcount_gen2_prepare.
Require Export MinBFTcount_gen2_commit.
Require Export MinBFTcount_gen2_accept.
Require Export MinBFTcount_gen2_debug.

Section MinBFTcount_gen2.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc                 : DTimeContext        }.
  Context { minbft_context      : MinBFT_context      }.
  Context { m_initial_keys      : MinBFT_initial_keys }.
  Context { u_initial_keys      : USIG_initial_keys   }.
  Context { usig_hash           : USIG_hash           }.
  Context { minbft_auth         : MinBFT_auth         }.

  Context { ti : TrustedInfo }.

  Lemma cexec_increases :
    forall {eo     : EventOrdering}
           (e      : Event)
           (s      : Rep)
           (s1     : _)
           (s2     : _)
           (subs1  : n_procs _)
           (subs2  : n_procs _),
      ~ In MAINname (get_names subs1)
      -> wf_procs subs1
      -> are_procs_n_procs subs1
      -> M_run_ls_on_this_one_event (MinBFTlocalSys_newP s s1 subs1) e
         = Some (MinBFTlocalSys_newP s s2 subs2)
      -> cexec s1 = cexec s2
         \/
         exists r l,
           cexec s2 = S (cexec s1)
           /\ In (send_accept (accept r (cexec s2)) l)
                 (M_output_ls_on_this_one_event (MinBFTlocalSys_newP s s1 subs1) e).
  Proof.
    introv ni wf aps h.
    remember (trigger e) as trig; symmetry in Heqtrig; destruct trig.
    { destruct d; simpl in *.
      { eapply cexec_increases_request; eauto. }
      { eapply cexec_increases_reply; eauto. }
      { eapply cexec_increases_prepare; eauto. }
      { eapply cexec_increases_commit; eauto. }
      { eapply cexec_increases_accept; eauto. }
      { eapply cexec_increases_debug; eauto. } }
    { apply map_option_Some in h; exrepnd; rev_Some; minbft_simp.
      unfold trigger_op in *; rewrite Heqtrig in *; simpl in *; ginv. }
    { apply map_option_Some in h; exrepnd; rev_Some; minbft_simp.
      unfold trigger_op in *; rewrite Heqtrig in *; simpl in *; ginv. }
  Qed.

  Lemma operation_inc_counter_ls_step :
    forall {eo    : EventOrdering}
           (e     : Event)
           (r     : Request)
           (i     : nat)
           (l     : list name)
           (s     : Rep)
           (ls    : MinBFTls)
           (subs  : n_procs _),
      lower_head 1 subs = true
      -> ~ In MAINname (get_names subs)
      -> wf_procs subs
      -> are_procs_n_procs subs
      -> M_run_ls_before_event (MinBFTlocalSysP s subs) e = Some ls
      -> In (send_accept (accept r (S i)) l) (M_output_ls_on_this_one_event ls e)
      -> i = 0
         \/
         exists r' l' e' ls',
           e' ⊏ e
           /\ M_run_ls_before_event (MinBFTlocalSysP s subs) e' = Some ls'
           /\ In (send_accept (accept r' i) l') (M_output_ls_on_this_one_event ls' e').
  Proof.
    introv low ni wf aps eqls out.
    applydup M_run_ls_before_event_ls_is_minbftP in eqls; exrepnd; subst; auto.
    applydup accepted_if_executed_previous_step in out; ginv.

    clear r l out eqls0.
    revert s s0 subs subs' low ni wf aps eqls.

    induction e as [e ind] using predHappenedBeforeInd;[]; introv low ni wf aps eqls.
    rewrite M_run_ls_before_event_unroll in eqls.
    destruct (dec_isFirst e) as [d|d]; ginv; minbft_simp.

    { apply eq_MinBFTlocalSys_newP_implies in eqls; repnd; subst; tcsp. }

    apply map_option_Some in eqls; exrepnd; rev_Some.
    applydup M_run_ls_before_event_ls_is_minbftP in eqls1; exrepnd; subst; auto.

    dup eqls1 as eqBef.
    eapply ind in eqls1; eauto 3 with eo; clear ind;[].
    applydup similar_subs_preserves_get_names in eqls2.
    apply cexec_increases in eqls0; eauto 3 with comp minbft;
      try (complete (rewrite <- eqls3; auto));[].
    repndors; exrepnd; tcsp;
      try (complete (left; congruence));
      try (complete (right; minbft_finish_eexists));[].

    right.
    exists r' l' e' ls'; dands; auto; eauto 3 with eo; try congruence.
  Qed.

  Lemma operation_inc_counter_ls :
    forall {eo    : EventOrdering}
           (e     : Event)
           (r     : Request)
           (i1 i2 : nat)
           (l     : list name)
           (s     : Rep)
           (ls    : MinBFTls)
           (subs  : n_procs _),
      lower_head 1 subs = true
      -> ~ In MAINname (get_names subs)
      -> wf_procs subs
      -> are_procs_n_procs subs
      -> M_run_ls_before_event (MinBFTlocalSysP s subs) e = Some ls
      -> In (send_accept (accept r i2) l) (M_output_ls_on_this_one_event ls e)
      -> i1 < i2
      -> 0 < i1
      -> exists r' l' e' ls',
          e' ⊏ e
          /\ M_run_ls_before_event (MinBFTlocalSysP s subs) e' = Some ls'
          /\ In (send_accept (accept r' i1) l') (M_output_ls_on_this_one_event ls' e').
  Proof.
    intros eo e r i1 i2; revert e r.
    induction i2; introv low ni wf aps eqls out lti lti0; try omega;[].
    apply lt_n_Sm_le in lti.

    eapply operation_inc_counter_ls_step in out; eauto;[].
    repndors; subst; try omega.
    exrepnd.

    apply le_lt_or_eq in lti; repndors; subst; try (complete minbft_finish_eexists);[].

    eapply IHi2 in out1; eauto; try omega.
    exrepnd.
    exists r'0 l'0 e'0 ls'0; dands; auto; eauto 3 with eo.
  Qed.

  Definition lower_headF k {n} (f : Rep -> n_procs n) :=
    forall r, lower_head k (f r) = true.

  Definition not_in_namesF (cn : CompName) {n} (f : Rep -> n_procs n) :=
    forall r, ~ In MAINname (get_names (f r)).

  Definition wf_procsF {n} (f : Rep -> n_procs n) :=
    forall r, wf_procs (f r).

  Definition are_procs_n_procsF {n} (f : Rep -> n_procs n) :=
    forall r, are_procs_n_procs (f r).

  Lemma operation_inc_counter :
    forall {eo    : EventOrdering}
           (e     : Event)
           (r     : Request)
           (i1 i2 : nat)
           (l     : list name)
           (subs  : Rep -> n_procs _),
      lower_headF 1 subs
      -> not_in_namesF MAINname subs
      -> wf_procsF subs
      -> are_procs_n_procsF subs
      -> is_replica e
      -> In (send_accept (accept r i2) l) (M_output_sys_on_event (MinBFTsysP subs) e)
      -> i1 < i2
      -> 0 < i1
      -> exists r' l' e',
          e' ⊏ e
          /\ In (send_accept (accept r' i1) l') (M_output_sys_on_event (MinBFTsysP subs) e').
  Proof.
    introv low ni wf aps isr h lti lti0.
    unfold M_output_sys_on_event in *.
    unfold MinBFTsysP, is_replica in *; exrepnd.
    rewrite isr0 in *; simpl in *.

    apply M_output_ls_on_event_as_run in h; exrepnd.
    eapply operation_inc_counter_ls in h0; eauto.
    exrepnd.
    applydup local_implies_loc in h2 as eqloc.
    exists r' l' e'; dands; auto.
    rewrite eqloc.
    rewrite isr0.

    apply M_output_ls_on_event_as_run.
    eexists; dands; eauto.
  Qed.

  Lemma accepted_counter_positive :
    forall {eo    : EventOrdering}
           (e     : Event)
           (r     : Request)
           (i     : nat)
           (l     : list name)
           (subs  : Rep -> n_procs _),
      lower_headF 1 subs
      -> not_in_namesF MAINname subs
      -> wf_procsF subs
      -> are_procs_n_procsF subs
      -> is_replica e
      -> In (send_accept (accept r i) l) (M_output_sys_on_event (MinBFTsysP subs) e)
      -> 0 < i.
  Proof.
    introv low ni wf aps isrep out.
    unfold M_output_sys_on_event in *.
    unfold MinBFTsysP, is_replica in *; exrepnd.
    rewrite isrep0 in *; simpl in *.
    apply M_output_ls_on_event_implies_run in out; exrepnd.
    applydup M_run_ls_before_event_ls_is_minbftP in out1; exrepnd; subst; eauto.
    eapply accepted_if_executed_previous_step in out0; subst; omega.
  Qed.
  Hint Resolve accepted_counter_positive : minbft.

  Lemma M_output_ls_on_input_is_committed_implies :
    forall u c ls,
      M_run_ls_on_input (LOGlocalSys u) LOGname (is_committed_in c) = (ls, Some (log_out true))
      -> is_committed c u = true
         /\ ls = LOGlocalSys u.
  Proof.
    introv out.
    unfold M_run_ls_on_input, on_comp in out; simpl in *.
    unfold M_run_sm_on_input in out; simpl in *.
    unfold M_on_decr, M_break in out; simpl in *; minbft_simp.
    inversion out; auto.
  Qed.

End MinBFTcount_gen2.


Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Import Fiat.Parsers.ContextFreeGrammar.ValidReflective.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Parsers.CorrectnessBaseTypes.
Require Import Fiat.Parsers.SimpleRecognizer.
Require Import Fiat.Parsers.SimpleRecognizerCorrect.
Require Import Fiat.Parsers.RecognizerPreOptimized.
Require Import Fiat.Parsers.Splitters.RDPList.
Require Import Fiat.Parsers.GenericRecognizerOptimized.
Require Import Fiat.Parsers.GenericRecognizerOptimizedTactics.
Require Import Fiat.Common.

Section recursive_descent_parser.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char}
          {G : pregrammar Char}.
  Context (Hvalid : is_true (grammar_rvalid G)).

  Let predata := @rdp_list_predata _ G.
  Local Existing Instance predata.

  Context {splitdata : @split_dataT Char _ _}.

  Let data : boolean_parser_dataT :=
    {| split_data := splitdata |}.
  Let optdata : boolean_parser_dataT :=
    {| split_data := optsplitdata |}.
  Local Existing Instance data.

  Let rdata' : @parser_removal_dataT' _ G predata := rdp_list_rdata'.
  Local Existing Instance rdata'.

  Local Arguments minus !_ !_.
  Local Arguments min !_ !_.

  Definition parse_nonterminal_opt'0
             (str : String)
             (nt : String.string)
  : { b : _ | b = parse_nonterminal (data := optdata) str nt }.
  Proof.
    exact (@parse_nonterminal_opt _ _ G Hvalid _ simple_gendata str nt).
  Defined.

  Definition parse_nonterminal_opt'1
             (str : String)
             (nt : String.string)
  : { b : _ | b = parse_nonterminal (data := optdata) str nt }.
  Proof.
    let c := constr:(parse_nonterminal_opt'0 str nt) in
    let h := head c in
    let p := (eval cbv [proj1_sig h] in (proj1_sig c)) in
    sigL_transitivity p; [ | abstract exact (proj2_sig c) ].

    let T := match goal with |- @sig ?A _ => A end in
    evar (b' : T).
    sigL_transitivity b'; subst b'.
    Focus 2.
    { let gendata := match goal with |- context[@parse_nonterminal_opt _ _ _ _ _ ?gendata] => head gendata end in
      cbv [parse_nonterminal_opt gendata].
      cbv [GenericBaseTypes.parse_nt_T GenericBaseTypes.parse_item_T GenericBaseTypes.parse_production_T GenericBaseTypes.parse_productions_T GenericBaseTypes.ret_Terminal_false GenericBaseTypes.ret_Terminal_true GenericBaseTypes.ret_NonTerminal_false GenericBaseTypes.ret_NonTerminal_true GenericBaseTypes.ret_production_cons GenericBaseTypes.ret_orb_production GenericBaseTypes.ret_orb_production_base GenericBaseTypes.ret_production_nil_true GenericBaseTypes.ret_production_nil_false GenericBaseTypes.ret_orb_productions GenericBaseTypes.ret_orb_productions_base GenericBaseTypes.ret_nt GenericBaseTypes.ret_nt_invalid].
      reflexivity. }
    Unfocus.

    eexists; reflexivity.
  Defined.

  Definition parse_nonterminal_opt
             (str : String)
             (nt : String.string)
  : { b : _ | b = parse_nonterminal (data := optdata) str nt }.
  Proof.
    let c := constr:(parse_nonterminal_opt'1 str nt) in
    let h := head c in
    let impl := (eval cbv [h proj1_sig] in (proj1_sig c)) in
    (exists impl);
      abstract (exact (proj2_sig c)).
  Defined.

  Lemma parse_nonterminal_opt_eq
        {HSLP : StringLikeProperties Char}
        {splitdata_correct : @boolean_parser_completeness_dataT' _ _ _ G data}
        (str : String)
        (nt : String.string)
    : @GenericCorrectnessBaseTypes.parse_nt_is_correct _ _ _ _ _ simple_gencdata2 str (of_nonterminal nt) (GenericRecognizerMin.parse_nonterminal str nt) (proj1_sig (parse_nonterminal_opt str nt)).
  Proof.
    let p := match goal with |- context[proj1_sig ?p] => p end in
    rewrite (proj2_sig p).
    refine (proj2 (@parse_nonterminal_optdata_eq _ _ _ G splitdata simple_gendata simple_gencdata2 _ _ str nt _ ) _).
    unfold parse_nonterminal.
    exact (GenericRecognizerMin.parse_nonterminal_correct (gcdata := simple_gencdata2) str nt).
  Qed.
End recursive_descent_parser.


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 RmiSMC.Spec.
Require Import PSCIHandler.Spec.
Require Import CtxtSwitchAux.Spec.

Local Open Scope Z_scope.

Section Layer.

  Context `{real_params: RealParams}.

  Section InvDef.

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

    Global Instance CtxtSwitchAux_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 CtxtSwitchAux_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 save_sysreg_state_inv: PreservesInvariants save_sysreg_state_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance restore_sysreg_state_inv: PreservesInvariants restore_sysreg_state_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance save_ns_state_sysreg_state_inv: PreservesInvariants save_ns_state_sysreg_state_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance restore_ns_state_sysreg_state_inv: PreservesInvariants restore_ns_state_sysreg_state_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance shiftl_inv: PreservesInvariants shiftl_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_rec_sysregs_inv: PreservesInvariants set_rec_sysregs_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 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_granule_undelegate_inv: PreservesInvariants smc_granule_undelegate_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 smc_rec_destroy_inv: PreservesInvariants smc_rec_destroy_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_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 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 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 esr_sixty_four_inv: PreservesInvariants esr_sixty_four_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_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 granule_get_inv: PreservesInvariants granule_get_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 set_rec_ptimer_masked_inv: PreservesInvariants set_rec_ptimer_masked_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 get_ns_state_inv: PreservesInvariants get_ns_state_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_ns_state_inv: PreservesInvariants set_ns_state_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 get_psci_result_x1_inv: PreservesInvariants get_psci_result_x1_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 psci_rsi_inv: PreservesInvariants psci_rsi_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 assert_cond_inv: PreservesInvariants assert_cond_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_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 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 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 granule_memzero_inv: PreservesInvariants granule_memzero_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_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 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 smc_realm_activate_inv: PreservesInvariants smc_realm_activate_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 smc_granule_delegate_inv: PreservesInvariants smc_granule_delegate_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 get_rec_run_emulated_read_val_inv: PreservesInvariants get_rec_run_emulated_read_val_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 get_rec_ptimer_inv: PreservesInvariants get_rec_ptimer_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance smc_rec_create_inv: PreservesInvariants smc_rec_create_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 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 smc_realm_create_inv: PreservesInvariants smc_realm_create_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 smc_realm_destroy_inv: PreservesInvariants smc_realm_destroy_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 CtxtSwitchAux_fresh : compatlayer (cdata RData) :=
      _save_sysreg_state ↦ gensem save_sysreg_state_spec
        ⊕ _restore_sysreg_state ↦ gensem restore_sysreg_state_spec
        ⊕ _save_ns_state_sysreg_state ↦ gensem save_ns_state_sysreg_state_spec
        ⊕ _restore_ns_state_sysreg_state ↦ gensem restore_ns_state_sysreg_state_spec
      .

    Definition CtxtSwitchAux_passthrough : compatlayer (cdata RData) :=
      _shiftl ↦ gensem shiftl_spec
        ⊕ _addr_to_idx ↦ gensem addr_to_idx_spec
        ⊕ _el3_sync_lel ↦ gensem el3_sync_lel_spec
        ⊕ _set_rec_sysregs ↦ gensem set_rec_sysregs_spec
        ⊕ _get_psci_result_forward_psci_call ↦ gensem get_psci_result_forward_psci_call_spec
        ⊕ _granule_refcount_inc ↦ gensem granule_refcount_inc_spec
        ⊕ _ns_buffer_read_rec_run ↦ gensem ns_buffer_read_rec_run_spec
        ⊕ _granule_put ↦ gensem granule_put_spec
        ⊕ _smc_granule_undelegate ↦ gensem smc_granule_undelegate_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
        ⊕ _smc_rec_destroy ↦ gensem smc_rec_destroy_spec
        ⊕ _get_rec_run_gprs ↦ gensem get_rec_run_gprs_spec
        ⊕ _set_rec_ptimer_asserted ↦ gensem set_rec_ptimer_asserted_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
        ⊕ _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
        ⊕ _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
        ⊕ _esr_sixty_four ↦ gensem esr_sixty_four_spec
        ⊕ _run_realm ↦ gensem run_realm_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
        ⊕ _granule_get ↦ gensem granule_get_spec
        ⊕ _buffer_unmap ↦ gensem buffer_unmap_spec
        ⊕ _access_len ↦ gensem access_len_spec
        ⊕ _enter_rmm ↦ gensem enter_rmm_spec
        ⊕ _set_rec_ptimer_masked ↦ gensem set_rec_ptimer_masked_spec
        ⊕ _sysreg_read ↦ gensem sysreg_read_spec
        ⊕ _granule_set_state ↦ gensem granule_set_state_spec
        ⊕ _null_ptr ↦ gensem null_ptr_spec
        ⊕ _get_ns_state ↦ gensem get_ns_state_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_ns_state ↦ gensem set_ns_state_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
        ⊕ _get_psci_result_x1 ↦ gensem get_psci_result_x1_spec
        ⊕ _get_psci_result_x2 ↦ gensem get_psci_result_x2_spec
        ⊕ _find_lock_granule ↦ gensem find_lock_granule_spec
        ⊕ _psci_rsi ↦ gensem psci_rsi_spec
        ⊕ _is_null ↦ gensem is_null_spec
        ⊕ _assert_cond ↦ gensem assert_cond_spec
        ⊕ _pgte_read ↦ gensem pgte_read_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
        ⊕ _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
        ⊕ _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
        ⊕ _granule_memzero ↦ gensem granule_memzero_spec
        ⊕ _get_rec_regs ↦ gensem get_rec_regs_spec
        ⊕ _get_psci_result_forward_x3 ↦ gensem get_psci_result_forward_x3_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
        ⊕ _read_idreg ↦ gensem read_idreg_spec
        ⊕ _get_rec_par_end ↦ gensem get_rec_par_end_spec
        ⊕ _smc_realm_activate ↦ gensem smc_realm_activate_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
        ⊕ _smc_granule_delegate ↦ gensem smc_granule_delegate_spec
        ⊕ _set_rec_run_far ↦ gensem set_rec_run_far_spec
        ⊕ _get_rec_run_emulated_read_val ↦ gensem get_rec_run_emulated_read_val_spec
        ⊕ _get_rec_vtimer ↦ gensem get_rec_vtimer_spec
        ⊕ _get_rec_ptimer ↦ gensem get_rec_ptimer_spec
        ⊕ _smc_rec_create ↦ gensem smc_rec_create_spec
        ⊕ _set_g_rtt_rd ↦ gensem set_g_rtt_rd_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
        ⊕ _smc_realm_create ↦ gensem smc_realm_create_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
        ⊕ _smc_realm_destroy ↦ gensem smc_realm_destroy_spec
        ⊕ _timer_condition_met ↦ gensem timer_condition_met_spec
        ⊕ _addr_is_level_aligned ↦ gensem addr_is_level_aligned_spec
      .

    Definition CtxtSwitchAux := CtxtSwitchAux_fresh ⊕ CtxtSwitchAux_passthrough.

  End LayerDef.

End Layer.


(*
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     List
     Lia.

From SPICY Require Import
     MyPrelude
     Maps
     Messages
     Keys
     Tactics
     RealWorld
     SafeProtocol
     SafetyAutomation
     Simulation

     Theory.InvariantsTheory
     Theory.KeysTheory

     ModelCheck.ModelCheck
     ModelCheck.LabelsAlign
     ModelCheck.ProtocolFunctions
     ModelCheck.RealWorldStepLemmas
     ModelCheck.SilentStepElimination
     ModelCheck.SteppingTactics
     ModelCheck.UniverseInversionLemmas
.

Import SafetyAutomation Gen.

Set Implicit Arguments.

Lemma lookup_in_merge_perm :
  forall kid (m m' : key_perms),
    m $k++ m' $? kid = match m $? kid with
                       | Some p => match m' $? kid with
                                  | Some p' => Some (greatest_permission p p')
                                  | None => Some p
                                  end
                       | None => m' $? kid
                       end.
Proof.
  intros; cases (m $? kid); cases (m' $? kid); solve_perm_merges.
Qed.

Section RW.
  Import RealWorld.

  Fixpoint compute_na {t} (cmd: user_cmd t) : sigT user_cmd :=
    match cmd with
    | Bind c _ => compute_na c
    | c => existT _ _ c
    end.

  Lemma compute_na_correct :
    forall t (cmd : user_cmd t) t__n (cmd__n : user_cmd t__n),
      compute_na cmd = existT _ _ cmd__n
      -> nextAction cmd cmd__n.
  Proof.
    induct cmd
    ; try solve [ unfold compute_na; simpl; intros; invert H; econstructor; eauto ].

    intros.
    constructor.
    simpl in H0; eauto.
  Qed.

  Lemma invert_na :
    forall t (cmd : user_cmd t) t__n (cmd__n : user_cmd t__n),
      nextAction cmd cmd__n
      -> compute_na cmd = existT _ _ cmd__n
        /\ projT1 (compute_na cmd) = t__n.
  Proof.

    induct cmd
    ; try solve [ intros; unfold compute_na; invert H; split; eauto ].

    intros; induct H; eauto.
    intros; invert H0; eauto.
  Qed.

End RW.

Inductive NoSilent {A B} (uid : user_id) (U : RealWorld.universe A B) : Prop :=
| Stuck :
    (forall U', ~ indexedRealStep uid Silent U U')
    -> NoSilent uid U.

Definition honest_heaps_sane {A} (usrs : honest_users A) (cs : ciphers) (gks : keys) :=
  forall uid u,
    usrs $? uid = Some u
    -> (forall cid, List.In cid u.(c_heap) -> In cid cs)
    /\ (forall kid kp, u.(key_heap) $? kid = Some kp -> In kid gks)
.

Lemma step_didnt_appear :
  forall {A B C} suid lbl bd bd',

    step_user lbl suid bd bd'
    -> forall cs cs' (usrs usrs': honest_users A) (adv adv' : user_data B) gks gks'
        (cmd cmd' : user_cmd C) uid1 ks ks' qmsgs qmsgs' mycs mycs' ms
        froms froms' sents sents' cur_n cur_n' cmdc,

      bd = (usrs, adv, cs, gks, ks, qmsgs ++ ms, mycs, froms, sents, cur_n, cmd)
      -> bd' = (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', cmd')
      -> suid = Some uid1
      -> lbl = Silent
      -> usrs $? uid1 = Some {| key_heap := ks;
                               protocol := cmdc;
                               msg_heap := qmsgs ++ ms;
                               c_heap   := mycs;
                               from_nons := froms;
                               sent_nons := sents;
                               cur_nonce := cur_n |}
      -> forall usrs'' (adv'' : user_data B) cs'' gks'',
          usrs'' $? uid1 = Some {| key_heap := ks;
                                   protocol := cmdc;
                                   msg_heap := qmsgs;
                                   c_heap   := mycs;
                                   from_nons := froms;
                                   sent_nons := sents;
                                   cur_nonce := cur_n |}
          -> (forall uid u, usrs'' $? uid = Some u -> exists u', usrs $? uid = Some u')
          -> (forall cid c, cs'' $? cid = Some c -> cs $? cid = Some c)
          -> (forall cid c, cs $? cid = Some c -> cs'' $? cid = Some c \/ cs'' $? cid = None)
          -> (forall kid k, gks $? kid = Some k -> gks'' $? kid = Some k \/ gks'' $? kid = None)
          -> (forall kid k, gks'' $? kid = Some k -> gks $? kid = Some k)
          -> honest_heaps_sane usrs'' cs'' gks''
          -> exists bd'',
              step_user Silent suid
                        (usrs'', adv'', cs'', gks'', ks, qmsgs, mycs, froms, sents, cur_n, cmd)
                        bd''.
Proof.
  Local Ltac process_stuff :=
    repeat
      match goal with
      | [ H : honest_heaps_sane ?usrs ?cs ?gks, USR : ?usrs $? _ = Some _ |- _ ] =>
        specialize (H _ _ USR)
        ; simpl in H
        ; destruct H
      | [ H : ?m $? _ = Some _, FN : (forall _ _, ?m $? _ = Some _ -> _) |- _ ] =>
        apply FN in H
      | [ H : List.In _ ?l, FN : (forall _, List.In _ ?l -> _) |- _ ] =>
        apply FN in H
      end
    ; split_ors
    ; clean_map_lookups
    ; trivial.

  induction 1; inversion 1; inversion 1
  ; intros
  ; subst
  ; try discriminate
  ; try solve [ eexists; econstructor; eauto ]
  ; eauto.

  - eapply IHstep_user in H27; eauto.
    split_ex; eauto.
    dt x.
    eexists; econstructor; eauto.
  - eexists; eapply StepEncrypt with (c_id0 := next_key cs''); eauto using Maps.next_key_not_in
    ; process_stuff.

  - eexists; econstructor; trivial.
    process_stuff; split_ors; clean_map_lookups; eauto.
    process_stuff; split_ors; clean_map_lookups; eauto.
    process_stuff; split_ors; clean_map_lookups; eauto.
    all: eauto.
  - eexists; eapply StepSign with (c_id0 := next_key cs''); eauto using Maps.next_key_not_in
    ; process_stuff.
  - eexists; econstructor; eauto
    ; process_stuff.
  - eexists; eapply StepGenerateKey with (k_id0 := next_key gks''); eauto using Maps.next_key_not_in.

    Unshelve.
    auto.
Qed.

Lemma silent_step_then_silent_step_inv :
  forall {A B} suid lbl bd bd',

    step_user lbl suid bd bd'
    -> forall cs cs' (usrs usrs': honest_users A) (adv adv' : user_data B) gks gks'
        (cmd cmd' : user_cmd (Base A)) uid1 ks ks' qmsgs qmsgs' mycs mycs'
        froms froms' sents sents' cur_n cur_n' cmdc,

      bd = (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
      -> bd' = (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', cmd')
      -> suid = Some uid1
      -> lbl = Silent
      -> usrs $? uid1 = Some {| key_heap := ks;
                               protocol := cmdc;
                               msg_heap := qmsgs;
                               c_heap   := mycs;
                               from_nons := froms;
                               sent_nons := sents;
                               cur_nonce := cur_n |}

      -> forall uid2 bd2 bd2' cmd2 ks2 qmsgs2 mycs2 froms2 sents2 cur_n2 usrs'' cmdc' ud2,

          step_user Silent (Some uid2)
                    (usrs'', adv', cs', gks', ks2, qmsgs2, mycs2, froms2, sents2, cur_n2, cmd2)
                    bd2'
          -> uid1 <> uid2
          -> usrs $? uid2 = Some ud2
          -> bd2 = build_data_step (mkUniverse usrs adv cs gks) ud2
          -> usrs' $? uid2 = Some {| key_heap := ks2;
                                    protocol := cmd2;
                                    msg_heap := qmsgs2;
                                    c_heap   := mycs2;
                                    from_nons := froms2;
                                    sent_nons := sents2;
                                    cur_nonce := cur_n2 |}
          -> usrs'' = usrs' $+ (uid1, {| key_heap := ks';
                                        protocol := cmdc';
                                        msg_heap := qmsgs';
                                        c_heap   := mycs';
                                        from_nons := froms';
                                        sent_nons := sents';
                                        cur_nonce := cur_n' |})
          -> honest_heaps_sane usrs cs gks
          -> exists bd2'',
              step_user Silent (Some uid2) bd2 bd2''
.
Proof.
  induction 1; inversion 1; inversion 1; intros; subst
  ; autorewrite with find_user_keys in *
  ; try discriminate
  ; try solve [
          dt bd2'; clean_map_lookups
          ; eapply step_didnt_appear with (ms := [])
          ; try rewrite app_nil_r
          ; simpl; eauto
          ; intros
          ; clean_map_lookups
          ; trivial
          ; destruct (uid1 ==n uid); subst; clean_map_lookups; eauto].

  - eapply IHstep_user in H28; eauto.

  - dt bd2'; clean_map_lookups
    ; eapply step_didnt_appear with (ms := [])
    ; try rewrite app_nil_r
    ; simpl; eauto.

    clean_map_lookups; trivial.

    intros; destruct (uid1 ==n uid); subst; clean_map_lookups; eauto.
    intros; destruct (c_id ==n cid); subst; clean_map_lookups; eauto.
    intros; destruct (c_id ==n cid); subst; clean_map_lookups; eauto.

  - dt bd2'; clean_map_lookups
    ; eapply step_didnt_appear with (ms := [])
    ; try rewrite app_nil_r
    ; simpl; eauto.

    clean_map_lookups; trivial.

    intros; destruct (uid1 ==n uid); subst; clean_map_lookups; eauto.
    intros; destruct (c_id ==n cid); subst; clean_map_lookups; eauto.
    intros; destruct (c_id ==n cid); subst; clean_map_lookups; eauto.

  - dt bd2'; clean_map_lookups
    ; eapply step_didnt_appear with (ms := [])
    ; try rewrite app_nil_r
    ; simpl; eauto.

    clean_map_lookups; trivial.

    intros; destruct (uid1 ==n uid); subst; clean_map_lookups; eauto.
    intros; destruct (k_id ==n kid); subst; clean_map_lookups; eauto.
    intros; destruct (k_id ==n kid); subst; clean_map_lookups; eauto.
Qed.

Lemma NoSilent_no_indexed_silent_step :
  forall A B uid (U : RealWorld.universe A B),
    NoSilent uid U
    -> forall U',
      ~ indexedRealStep uid Silent U U'.
Proof.
  invert 1; intros; eauto.
Qed.

Definition propNoSilent {A B} (U U' : RealWorld.universe A B) :=
  forall uid, NoSilent uid U -> NoSilent uid U'.

Lemma all_users_NoSilent_no_indexed_silent_step :
  forall A B uid (U : RealWorld.universe A B),
    (forall uid ud, U.(RealWorld.users) $? uid = Some ud -> NoSilent uid U)
    -> forall U',
      ~ indexedRealStep uid Silent U U'.
Proof.
  intros.
  unfold not; intros.
  generalize H0; invert H0.
  apply H in H1.
  eapply NoSilent_no_indexed_silent_step; eauto.
Qed.

Lemma silent_step_nochange_other_user_inv :
  forall {A B C} suid lbl bd bd',
    step_user lbl suid bd bd'
    -> forall cs cs' (usrs usrs': honest_users A) (adv adv' : user_data B) gks gks'
        (cmd cmd' : user_cmd C) ks ks' qmsgs qmsgs' mycs mycs'
        froms froms' sents sents' cur_n cur_n',
      bd = (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
      -> bd' = (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', cmd')
      -> lbl = Silent
      -> forall cmdc u_id1 u_id2 ud2,
          suid = Some u_id1
          -> u_id1 <> u_id2
          -> usrs $? u_id1 = Some {| key_heap := ks;
                                    protocol := cmdc;
                                    msg_heap := qmsgs;
                                    c_heap   := mycs;
                                    from_nons := froms;
                                    sent_nons := sents;
                                    cur_nonce := cur_n |}
          -> usrs' $? u_id2 = Some ud2
          -> usrs $? u_id2 = Some ud2.
Proof.
  induction 1; inversion 1; inversion 1
  ; intros; subst
  ; try discriminate
  ; try solve [ clean_map_lookups; trivial ]
  ; eauto.
Qed.

Lemma propNoSilent_silent_step :
  forall A B (U U': RealWorld.universe A B) uid,
    indexedRealStep uid Silent U U'
    -> honest_heaps_sane U.(users) U.(all_ciphers) U.(all_keys)
    -> propNoSilent U U'.
Proof.
  unfold propNoSilent; intros.
  invert H1.
  constructor; unfold not; intros.

  destruct (uid ==n uid0); subst.

  apply H2 in H; auto.

  invert H; invert H1.
  destruct U, userData, userData0.
  unfold build_data_step, buildUniverse in *; simpl in *; clean_map_lookups.

  pose proof (silent_step_then_silent_step_inv H4).
  pose proof (silent_step_nochange_other_user_inv H4).

  specialize (H6 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ eq_refl eq_refl eq_refl).
  specialize (H6 _ _ _ _ eq_refl n H3 H).

  specialize (H1 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ eq_refl eq_refl eq_refl eq_refl H3).
  specialize (H1 _ _ _ _ _ _ _ _ _ _ _ _ _ H5 n H6 eq_refl H eq_refl).

  specialize (H1 H0).

  split_ex.
  dt x.
  eapply H2.
  econstructor; simpl; eauto.
Qed.

Lemma ssteps_inv_silent :
  forall A B st st',
    (@stepSS A B) ^* st st'
    -> forall (U U' : RealWorld.universe A B) uid U__i b,
      st = (U,U__i,b)
      -> indexedRealStep uid Silent U U'
      -> (forall uid' U', uid' > uid -> ~ indexedRealStep uid' Silent U U')
      -> exists U__r,
          indexedRealStep uid Silent U U__r
          /\ (  st' = (U,U__i,b)
               \/  (stepSS (t__adv := B) ^* (U__r,U__i,b) st')
            )
          /\ ( honest_heaps_sane U.(users) U.(all_ciphers) U.(all_keys)
            -> propNoSilent U U__r ).
Proof.
  intros.
  subst; invert H.
  - eexists; eauto 8 using propNoSilent_silent_step.
  - invert H0; repeat equality1.
    invert H.
    + apply indexedModelStep_user_step in H6; split_ex; split_ors; subst.
      * destruct ( uid ==n u_id ); subst.
        clear H1 H4.

        eexists; repeat simple apply conj; eauto using propNoSilent_silent_step.
        exfalso.

        destruct (le_gt_dec u_id uid).
        assert (uid > u_id) by lia.
        eapply H5; eauto.
        eapply H2; eauto.

      * invert H; invert H4.
        exfalso.
        clean_map_lookups
        ; pose proof (user_step_label_deterministic _ _ _ _ _ _ _ _ _ H7 H8); discriminate.

    + eapply H4 in H1; contradiction.
Qed.

Lemma ssteps_inv_labeled :
  forall A B st st' ru,
    (forall uid U', ~ @indexedRealStep A B uid Silent ru U')
    -> (@stepSS A B) ^* st st'
    -> labels_align st
    -> forall iu b,
        st = (ru,iu,b)
        -> st = st'
          \/ exists uid ru' iu0 iu' ra ia,
            indexedRealStep uid (Action ra) ru ru'
            /\ (indexedIdealStep uid Silent) ^* iu iu0
            /\ indexedIdealStep uid (Action ia) iu0 iu'
            /\ action_matches (RealWorld.all_ciphers ru) (RealWorld.all_keys ru) (uid,ra) ia
            /\ (@stepSS A B) ^* (ru',iu',b) st'.
Proof.
  intros; subst.
  invert H0; clear_mislabeled_steps; eauto.
  right.

  invert H2; repeat equality1.
  invert H0.
  - exfalso; eapply H; eauto.
  - invert H6; try contradiction.
    clear_mislabeled_steps.
    eauto 12.
Qed.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsRef1.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition table_map2_spec (g_rd: Pointer) (map_addr: Z64) (level: Z64) (adt: RData) : option (RData * Z64) :=
    match map_addr, level with
    | VZ64 map_addr, VZ64 level =>
      rely is_int64 map_addr; rely (level >=? 3); rely is_int64 level;
      let idx0 := __addr_to_idx map_addr 0 in
      let idx1 := __addr_to_idx map_addr 1 in
      let idx2 := __addr_to_idx map_addr 2 in
      let idx3 := __addr_to_idx map_addr 3 in
      let ret_idx := (if level =? 1 then idx0 else if level =? 2 then idx1 else if level =? 3 then idx2 else idx3) in
      rely (peq (base g_rd) ginfo_loc);
      rely prop_dec ((buffer (priv adt)) @ SLOT_RD = None);
      rely prop_dec ((buffer (priv adt)) @ SLOT_TABLE = None);
      let rd_gidx := (offset g_rd) in
      let grd := (gs (share adt)) @ rd_gidx in
      rely (g_tag (ginfo grd) =? GRANULE_STATE_RD);
      rely prop_dec (glock grd = Some CPU_ID);
      let root_gidx := (g_rtt (gnorm grd)) in
      rely is_gidx rd_gidx; rely is_gidx root_gidx;
      when adt == query_oracle adt;
      let adt := adt {log: EVT CPU_ID (RTT_WALK root_gidx map_addr 2) :: log adt} in
      (* hold root lock *)
      let groot := (gs (share adt)) @ root_gidx in
      rely (tbl_level (gaux groot) =? 0);
      rely prop_dec (glock groot = None);
      rely (g_tag (ginfo groot) =? GRANULE_STATE_TABLE);
      rely (gtype groot =? GRANULE_STATE_TABLE);
      (* walk deeper root *)
      let entry0 := (g_data (gnorm groot)) @ idx0 in
      rely is_int64 entry0;
      let phys0 := __entry_to_phys entry0 3 in
      let lv1_gidx := __addr_to_gidx phys0 in
      if (__entry_is_table entry0) && (GRANULE_ALIGNED phys0) && (is_gidx lv1_gidx) then
        (* level 1 valid, hold level 1 lock *)
        let glv1 := (gs (share adt)) @ lv1_gidx in
        rely prop_dec (glock glv1 = None);
        rely (tbl_level (gaux glv1) =? 1);
        (* walk deeper level 1 *)
        rely (g_tag (ginfo glv1) =? GRANULE_STATE_TABLE);
        rely (gtype glv1 =? GRANULE_STATE_TABLE);
        let entry1 := (g_data (gnorm glv1)) @ idx1 in
        rely is_int64 entry1;
        let phys1 := __entry_to_phys entry1 3 in
        let lv2_gidx := __addr_to_gidx phys1 in
        if (__entry_is_table entry1) && (GRANULE_ALIGNED phys1) && (is_gidx lv2_gidx) then
          (* level 2 valid, hold level 2 lock *)
          let glv2 := (gs (share adt)) @ lv2_gidx in
          rely (tbl_level (gaux glv2) =? 2);
          rely prop_dec (glock glv2 = None);
          if level =? 3 then
            (* walk until level 2 *)
            let adt :=  adt {priv: (priv adt) {wi_llt: lv2_gidx} {wi_index: idx2}} in
            map_table lv2_gidx idx2 level adt
          else
            (* walk deeper level 2 *)
            rely (g_tag (ginfo glv2) =? GRANULE_STATE_TABLE);
            rely (gtype glv2 =? GRANULE_STATE_TABLE);
            let entry2 := (g_data (gnorm glv2)) @ idx2 in
            rely is_int64 entry2;
            let phys2 := __entry_to_phys entry2 3 in
            let lv3_gidx := __addr_to_gidx phys2 in
            if (__entry_is_table entry2) && (GRANULE_ALIGNED phys2) && (is_gidx lv3_gidx) then
              (* level 2 valid, hold level 2 lock *)
              let adt := adt {log: EVT CPU_ID (REL lv2_gidx glv2 {glock: Some CPU_ID}) :: EVT CPU_ID (ACQ lv3_gidx) :: log adt} in
              let glv3 := (gs (share adt)) @ lv3_gidx in
              rely prop_dec (glock glv3 = None);
              rely (tbl_level (gaux glv3) =? 3);
              if level =? 4 then
                (* walk until level 3 *)
                let adt :=  adt {priv: (priv adt) {wi_llt: lv3_gidx} {wi_index: idx3}} in
                map_table lv3_gidx idx3 level adt
              else (* can't be other level *)
                None
            else
              (* level 3 invalid *)
              Some (adt {log: EVT CPU_ID (REL lv2_gidx glv2 {glock: Some CPU_ID}) :: log adt}
                        {priv: (priv adt) {wi_llt: 0} {wi_index: ret_idx}}, VZ64 1)
        else
          (* level 2 invalid *)
          Some (adt {priv: (priv adt) {wi_llt: 0} {wi_index: ret_idx}}, VZ64 1)
      else
        (* level 1 invalid *)
        Some (adt {priv: (priv adt) {wi_llt: 0} {wi_index: ret_idx}}, VZ64 1)
  end.

End Spec.


(* ssreflect *)

Require Import ssreflect ssrbool ssrfun seq eqtype fintype.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import pos.
Require Import compcert_linking.
Require Import linking_proof.
Require Import context_equiv.
Require Import simulations.
Require Import rc_semantics.
Require Import nucular_semantics.
Require Import closed_simulations_lemmas.
Require Import safe_clight_rc.
Require Import Asm_coop.
Require Import Asm_nucular.
Require Import CompositionalCompiler.

(** * Contextual Equivalence for CompCert Clight->x86 Asm *)

(** Notations and convenient definitions: *)

Notation Clight_module := (program Clight.fundef Ctypes.type).
Notation Asm_module := (Asm_comp.program).

Definition mk_src_sem (p : Clight_module) :=
  let ge := Genv.globalenv p in
  @Modsem.mk Clight.fundef Ctypes.type ge Clight_coop.CL_core (Clight_eff.CL_eff_sem1 hf).

Definition mk_tgt_sem (tp : Asm_module) :=
  let tge := Genv.globalenv tp in
  @Modsem.mk Asm_comp.fundef unit tge Asm_coop.state (Asm_eff.Asm_eff_sem hf).

(** Apply the contextual equivalence functor from [linking/context_equiv.v] to
[linking/linking_proof.v]. *)

Module CE := ContextEquiv LinkingSimulation.

Lemma compcert_equiv
(** There are [N] modules. *)
  (N : pos)

(** Source and target modules. ['I_N -> A], for [A : Type], is the type of finite
  functions from [{0..N-1}] to [A]. *)
  (source_modules : 'I_N -> Clight_module)
  (target_modules : 'I_N -> Asm_module)

(** The function [plt] maps a subset of the possible function names to the
  modules in which they are defined. *)
  (plt : ident -> option 'I_N)

(** The entry point *)
  (main : val) :

(** Wrap the source and target modules as 'Modsem's (as in Section 3). *)
  let sems_S (ix : 'I_N) := mk_src_sem (source_modules ix) in
  let sems_T (ix : 'I_N) := mk_tgt_sem (target_modules ix) in
  let prog_S := Prog.mk sems_S main in
  let prog_T := Prog.mk sems_T main in

(** [ge_top] and the two [domeq_*] hypotheses below constrain the source--target
  global envs. of the modules in [sems_S] and [sems_T] to have equal domain, as
  explained in Section 3. *)
  forall ge_top : ge_ty,
  forall domeq_S : (forall ix : 'I_N, genvs_domain_eq ge_top (sems_S ix).(Modsem.ge)),

(** No module defines the same module twice. *)
  forall lnr : (forall ix : 'I_N, list_norepet (map fst (prog_defs (source_modules ix)))),

(** The target modules are (independently) compiled from the respective
  source modules ([transf_clight_program] compiles Clight programs to Asm). *)
  forall transf :
    (forall ix : 'I_N, transf_clight_program (source_modules ix)
                     = Errors.OK (target_modules ix)),

(** All of the above together imply that [prog_S] and [prog_T] are contextually
  equivalent. *)
  Equiv_ctx ge_top plt prog_S prog_T.

Proof.
move=> sems_S sems_T prog_S prog_T ge_top deqS lnr transf.
have find_syms :
  forall (i : 'I_N) (id : ident) (bf : block),
  Genv.find_symbol (Modsem.ge (sems_S i)) id = Some bf ->
  Genv.find_symbol (Modsem.ge (sems_T i)) id = Some bf.
{ move=> idx id bf; rewrite /sems_S /sems_T /=; move: (transf idx)=> H.
  by apply transf_clight_program_preserves_syms with (s := id) in H; rewrite H. }
apply: CE.equiv=> //.
by move=> ix; apply: Clight_RC.
by move=> ix; apply: Asm_is_nuc.
move=> ix; rewrite /Prog.sems/= => m m' m'' ge c c' c'' /= H H2.
by eapply asm_step_det; eauto.
move=> ix; move: (transf ix)=> H.
by eapply transf_clight_program_correct in H; eauto.
Qed.

Module PR := ProgRefines LinkingSimulation.

Lemma compcert_refines
  (N : pos)
  (source_modules : 'I_N -> Clight_module)
  (target_modules : 'I_N -> Asm_module)
  (plt : ident -> option 'I_N)
  (main : val) :
  let sems_S (ix : 'I_N) := mk_src_sem (source_modules ix) in
  let sems_T (ix : 'I_N) := mk_tgt_sem (target_modules ix) in
  let prog_S := Prog.mk sems_S main in
  let prog_T := Prog.mk sems_T main in
  forall ge_top : ge_ty,
  forall domeq_S : (forall ix : 'I_N, genvs_domain_eq ge_top (sems_S ix).(Modsem.ge)),
  forall lnr : (forall ix : 'I_N, list_norepet (map fst (prog_defs (source_modules ix)))),
  forall transf :
    (forall ix : 'I_N, transf_clight_program (source_modules ix)
                     = Errors.OK (target_modules ix)),
  forall EM : ClassicalFacts.excluded_middle,
  Prog_refines ge_top plt prog_S prog_T.
Proof.
move=> sems_S sems_T prog_S prog_T ge_top deqS lnr transf EM.
have find_syms :
  forall (i : 'I_N) (id : ident) (bf : block),
  Genv.find_symbol (Modsem.ge (sems_S i)) id = Some bf ->
  Genv.find_symbol (Modsem.ge (sems_T i)) id = Some bf.
{ move=> idx id bf; rewrite /sems_S /sems_T /=; move: (transf idx)=> H.
  by apply transf_clight_program_preserves_syms with (s := id) in H; rewrite H. }
apply: PR.refines=> //.
by move=> ix; apply: Clight_RC.
by move=> ix; apply: Asm_is_nuc.
move=> ix; rewrite /Prog.sems/= => m m' m'' ge c c' c'' /= H H2.
by eapply asm_step_det; eauto.
move=> ix; move: (transf ix)=> H.
by eapply transf_clight_program_correct in H; eauto.
Qed.


Require Import concurrency.dry_machine.
Require Import concurrency.erased_machine.
Require Import concurrency.threads_lemmas.
Require Import concurrency.permissions.
Require Import concurrency.semantics.
Require Import concurrency.concurrent_machine.
Require Import compcert.common.Globalenvs.
Require Import compcert.lib.Axioms.
From mathcomp.ssreflect Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq fintype finfun.
Set Implicit Arguments.

Import Concur.

Module Type MachinesSig.
  Declare Module SEM: Semantics.

  Module DryMachine := DryMachineShell SEM.
  Module ErasedMachine := ErasedMachineShell SEM.

  Module DryConc := CoarseMachine mySchedule DryMachine.
  Module FineConc := FineMachine mySchedule DryMachine.
  (** SC machine*)
  Module SC := FineMachine mySchedule ErasedMachine.

  Import DryMachine ThreadPool.
  Global Ltac pf_cleanup :=
    repeat match goal with
           | [H1: invariant ?X, H2: invariant ?X |- _] =>
             assert (H1 = H2) by (by eapply proof_irr);
               subst H2
           | [H1: mem_compatible ?TP ?M, H2: mem_compatible ?TP ?M |- _] =>
             assert (H1 = H2) by (by eapply proof_irr);
               subst H2
           | [H1: is_true (leq ?X ?Y), H2: is_true (leq ?X ?Y) |- _] =>
             assert (H1 = H2) by (by eapply proof_irr); subst H2
           | [H1: containsThread ?TP ?M, H2: containsThread ?TP ?M |- _] =>
             assert (H1 = H2) by (by eapply proof_irr); subst H2
           | [H1: containsThread ?TP ?M,
                  H2: containsThread (@updThreadC _ ?TP _ _) ?M |- _] =>
             apply cntUpdateC' in H2;
               assert (H1 = H2) by (by eapply cnt_irr); subst H2
           | [H1: containsThread ?TP ?M,
                  H2: containsThread (@updThread _ ?TP _ _ _) ?M |- _] =>
             apply cntUpdate' in H2;
               assert (H1 = H2) by (by eapply cnt_irr); subst H2
           end.

End MachinesSig.

Module Type AsmContext (SEM : Semantics)
       (Machines : MachinesSig with Module SEM := SEM).

  Import Machines.
  Parameter initU: mySchedule.schedule.

  Parameter init_mem : option Memory.Mem.mem.
  Definition init_perm  :=
    match init_mem with
    | Some m => Some (getCurPerm m, empty_map)
    | None => None
    end.

  Parameter the_ge : SEM.G.

  Definition coarse_semantics:=
    DryConc.MachineSemantics initU init_perm.

  Definition fine_semantics:=
    FineConc.MachineSemantics initU init_perm.

  Definition sc_semantics :=
    SC.MachineSemantics initU None.

  Definition tpc_init f arg := initial_core coarse_semantics the_ge f arg.
  Definition tpf_init f arg := initial_core fine_semantics the_ge f arg.
  Definition sc_init f arg := initial_core sc_semantics the_ge f arg.

End AsmContext.