(** 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.


(*
 * 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.


From iris.proofmode Require Import base proofmode classes.
From transfinite.base_logic.lib Require Export fancy_updates.
From melocoton Require Import stdpp_extra language_commons.
From melocoton.language Require Export language weakestpre.
(* FIXME: If we import iris.bi.weakestpre earlier texan triples do not
   get pretty-printed correctly. *)
From iris.bi Require Export weakestpre.
From iris.prelude Require Import options.
Import uPred.

Section wp.
Context `{SI:indexT, !langG val Λ Σ, !invG Σ}.
Implicit Types P : iProp Σ.
Implicit Types Φ : val → iProp Σ.
Implicit Types v : val.
Implicit Types e : expr Λ.
Implicit Types Ψ : protocol val Σ.
Implicit Types prog : lang_prog Λ.
Implicit Types pe : prog_environ Λ Σ.

Definition program_fulfills
  (Ψin : protocol val Σ) (p : mixin_prog (func Λ)) (Ψshould : protocol val Σ) : iProp Σ :=
  ∀ s vv Φ, Ψshould s vv Φ -∗ ⌜p !! s <> None⌝ ∗ WP (of_class _ (ExprCall s vv)) @ ⟨p, Ψin⟩; ⊤ {{ Φ }}.

Definition env_fulfills
  (p:prog_environ Λ Σ) (Ψshould : protocol val Σ) := program_fulfills p.(penv_proto) p.(penv_prog) Ψshould.

Notation "Ψin '|-' p '::' Ψshould" := (program_fulfills Ψin p Ψshould) (at level 25, p, Ψshould at level 26) : bi_scope.

Definition spec_union (p1 p2 : protocol val Σ) : protocol val Σ :=
  λ s vv Φ, (p1 s vv Φ ∨ p2 s vv Φ)%I.
Definition spec_inters (p1 p2 : protocol val Σ) : protocol val Σ :=
  λ s vv Φ, (p1 s vv Φ ∧ p2 s vv Φ)%I.

Class can_link (Ψ1 Ψ2 Ψaxiom Ψres : protocol val Σ) (p1 p2 p3 : lang_prog Λ) : Prop := {
  p1_p2_disjoint : dom p1 ## dom p2;
  Ψres_is_union : ⊢ (∀ s vv Φ, Ψres s vv Φ -∗ (spec_union Ψ1 Ψ2) s vv Φ)%I;
  Ψaxiom_is_axiomatic : ⊢ (∀ s vv Φ, Ψaxiom s vv Φ -∗ ⌜s ∉ dom p3⌝)%I;
  p1_satisfies_Ψ1 : ⊢ (spec_union Ψ2 Ψaxiom |- p1 :: Ψ1)%I;
  p2_satisfies_Ψ2 : ⊢ (spec_union Ψ1 Ψaxiom |- p2 :: Ψ2)%I;
  p3_is_union : p3 = (union_with (λ _ _ : func Λ, None) p1 p2);
}.

Definition pairwise {X} (A:list X) (Ψ : X -> X -> Prop) :=
  forall i j, i <> j -> match (nth_error A i, nth_error A j) with
      (Some a, Some b) => Ψ a b
     | _ => True end.

Definition spec_union_list (P : list (protocol val Σ)) : protocol val Σ :=
  λ s vv Φ, (∃ i, match nth_error P i with Some pp => pp s vv Φ | _ => ⌜False⌝ end)%I.
Definition spec_union_list_except k (P : list (protocol val Σ)) : protocol val Σ :=
  λ s vv Φ, (∃ i, ⌜i <> k⌝ ∗ match nth_error P i with Some pp => pp s vv Φ | _ => ⌜False⌝ end)%I.

Fixpoint union_map_list (P : list (lang_prog Λ)) : lang_prog Λ := match P with
  nil => ∅
 | x::xr => union_with (λ _ _ : func Λ, None) x (union_map_list xr)
end.

Lemma pairwise_subset {X} H (a : list X) x : pairwise (x::a) H -> pairwise a H.
Proof.
  intros HH i j Hne.
  specialize (HH (S i) (S j)). cbn in HH.
  apply HH. congruence.
Qed.

Lemma union_map_list_spec x y (P:list (lang_prog Λ)) :
  (pairwise P (fun p1 p2 => dom p1 ## dom p2)) ->
  ((union_map_list P) !! x = Some y <-> ∃ k, In k P ∧ k !! x = Some y).
Proof.
  intros Hdis.
  revert x y.
  induction P; intros x y; first split; cbn.
  - rewrite lookup_empty. intros H; congruence.
  - intros (? & [] & ?).
  - rewrite lookup_union_with.
    destruct (a !! x) as [va|] eqn:Hva;
    destruct (union_map_list P !! x) as [vP|] eqn:HvP; cbn; split; try congruence.
    + intros _. apply IHP in HvP; last by eapply pairwise_subset.
      destruct HvP as (k & (pos & Hpos)%In_nth_error & Heq).
      specialize (Hdis 0 (S pos)); cbn in Hdis. rewrite Hpos in Hdis.
      exfalso. assert (0 ≠ S pos) as Hne by lia. specialize (Hdis Hne).
      rewrite  elem_of_disjoint in Hdis. eapply Hdis.
      all: by eapply elem_of_dom_2.
    + injection 1; intros ->. exists a; repeat split; by try left.
    + intros (k & [-> | Hk] & Heq); first congruence.
      exfalso. assert (∃ k : lang_prog Λ, In k P ∧ k !! x = Some y) as H by by exists k.
      apply IHP in H; first congruence. by eapply pairwise_subset.
    + apply IHP in HvP; last by eapply pairwise_subset.
      destruct HvP as (k & ? & ?).
      injection 1; intros ->. exists k; repeat split; eauto.
    + intros (k & [-> | Hk] & Heq); first congruence.
      assert (∃ k : lang_prog Λ, In k P ∧ k !! x = Some y) as H by by exists k.
      apply IHP in H; last by eapply pairwise_subset. congruence.
    + intros (k & [-> | Hk] & Heq); first congruence.
      assert (∃ k : lang_prog Λ, In k P ∧ k !! x = Some y) as H by by exists k.
      apply IHP in H; last by eapply pairwise_subset. congruence.
Qed.

Lemma union_map_subset A p :
  (pairwise A (fun p1 p2 => dom p1 ## dom p2)) -> p ∈ A → p ⊆ union_map_list A.
Proof.
  intros Hdis H. apply map_subseteq_spec.
  intros i x Hin.
  apply union_map_list_spec; first done.
  exists p. split; eauto. by apply elem_of_list_In.
Qed.

Class can_link_all
    (Ψaxiom Ψres : protocol val Σ) (pres : lang_prog Λ)
    (A : list (prod (protocol val Σ) (lang_prog Λ))) := {
  all_disjoint : pairwise (map snd A) (fun p1 p2 => dom p1 ## dom p2);
  Ψres_is_big_union : ⊢ (∀ s vv Φ, Ψres s vv Φ -∗ (spec_union_list (map fst A)) s vv Φ)%I;
  Ψaxiom_is_axiomatic_all : ⊢ (∀ s vv Φ, Ψaxiom s vv Φ -∗ ⌜s ∉ dom pres⌝)%I;
  pres_is_union : pres = union_map_list (map snd A);
  one_spec := fun i => spec_union (spec_union_list_except i (map fst A)) Ψaxiom;
  all_satisfy_spec : ∀ i, match (nth_error A i) with None => True |
      Some (Ψi, pi) =>  ⊢ (one_spec i |- pi :: Ψi)%I end
}.

#[global]
Instance can_link_can_link_all Ψaxiom Ψres pres Ψ1 Ψ2 p1 p2 : can_link Ψ1 Ψ2 Ψaxiom Ψres p1 p2 pres
  -> can_link_all Ψaxiom Ψres pres [(Ψ1,p1); (Ψ2,p2)].
Proof.
  intros [H1 H2 H3 H4 H5 H6]; split; cbn.
  - intros [|[|[|i]]] [|[|[|j]]] H; cbn; easy.
  - iIntros (s vv Φ) "Hres". iPoseProof H2 as "H2".
    iDestruct ("H2" $! s vv Φ with "Hres") as "[H2'|H2']".
    + iExists 0; cbn; done.
    + iExists 1; cbn; done.
  - done.
  - rewrite H6. apply map_eq. intros i. rewrite ! lookup_union_with. rewrite lookup_empty.
    destruct (p1 !! i), (p2 !! i); done.
  - intros [|[|[|i]]]; cbn; try done.
    all: iIntros (s vv Φ) "Hres"; cbn.
    1: iPoseProof H4 as "H"; iSpecialize ("H" $! s vv Φ with "Hres").
    2: iPoseProof H5 as "H"; iSpecialize ("H" $! s vv Φ with "Hres").
    all: iDestruct "H" as "[$ HWP]".
    all: iApply wp_proto_mono; last iApply "HWP".
    all: cbn; intros s' vv' Φ'; iIntros "[H|H]".
    2,4: by iRight. all: iLeft.
    1: iExists 1. 2: iExists 0.
    all: iSplitR; first done. all: done.
Qed.

Lemma wp_link_execs Ψaxiom Ψres (pres : gmap string (Λ.(func))) A :
  can_link_all Ψaxiom Ψres pres A
  -> ⊢ ∀ e Φ i, match (nth_error A i) with None => ⌜False⌝ |
          Some (Ψi, pi) => WP e @ ⟨pi, spec_union (spec_union_list_except i (map fst A)) Ψaxiom ⟩; ⊤ {{ Φ }} end
     -∗ WP e @ ⟨pres, Ψaxiom⟩; ⊤ {{ Φ }}.
Proof.
  intros [Hdis HΨres Haxiom -> one_spec' Hsatis].
  iLöb as "IHe". iIntros (e Φ i).
  destruct (nth_error A i) as [[Ψi pi]|] eqn:Heq; last (iIntros "%H"; done).
  rewrite !wp_unfold /wp_pre /=.
  iIntros "H %σ Hσ".
  - iSpecialize ("H" $! σ with "Hσ").
    iMod "H".
    iDestruct "H" as "[(%x & -> & Hσ & H)|[(%s' & %vv' & %K & %HeqK & %H2 & >(%Ξ & Hσ & [HΨ|HΨ] & H3))|(%HH & H3)]]".
    * iModIntro. iLeft. iExists _. iFrame. iPureIntro. done.
    * iDestruct "HΨ" as "(%kidx & %Hknei & HΨ)". rewrite nth_error_map.
      destruct (nth_error A kidx) as [[Ψc pc]|] eqn:Heqk; cbn; last iPure "HΨ" as [].
      specialize (Hsatis kidx). rewrite Heqk in Hsatis.
      iPoseProof (Hsatis) as "Hsatis".
      iDestruct ("Hsatis" $! s' vv' Ξ with "HΨ")as "(%HNone & HΨ)".
      rewrite wp_unfold /wp_pre /=.
      iSpecialize ("HΨ" $! σ with "Hσ").
      iMod "HΨ" as "[(%x & %Heqx & Hσ & H)|[(%s'2 & %vv'2 & %K'2 & %HeqK2 & %H''2 & >(%Ξ' & Hσ & HΨ' & H3'))|(%HH2&H3')]]".
      -- exfalso. apply of_class_inj in Heqx. congruence.
      -- exfalso. assert (K'2 = empty_ectx) as ->.
         2: { rewrite fill_empty in HeqK2. apply of_class_inj in HeqK2. assert (s'2 = s') as -> by congruence; congruence. }
         destruct (fill_class K'2 (of_class Λ (ExprCall s'2 vv'2))) as [H1|[x Hx]].
         { eexists. rewrite <- HeqK2. by rewrite to_of_class. }
        { done. }
          { exfalso. unfold to_val in Hx. rewrite to_of_class in Hx; congruence. }
     -- destruct HH2 as (e' & σ' & (KK & e1' & e2' & Heq2 & -> & Hstep)%prim_step_inv).
          destruct (fill_class KK e1') as [->|[x Hx]].
         { eexists. rewrite <- Heq2. by rewrite to_of_class. }
         2: { apply val_head_stuck in Hstep. congruence. }
         rewrite ! fill_empty in Heq2. subst e1'.
         apply call_head_step in Hstep.
         destruct Hstep as (Fn & Heqp2' & He2' & -> ). iRight. iRight.
         assert (union_map_list (map snd A) !! s' = Some Fn) as Heqs'.
         { apply union_map_list_spec; first done. exists pc; repeat split; try done.
           apply in_map_iff. exists ((Ψc,pc)); repeat split. by eapply nth_error_In. }
         iModIntro. iSplit; first iPureIntro.
         { do 2 eexists. rewrite HeqK. econstructor; first done. 1:done.
           apply call_head_step. exists Fn. repeat split; try done. }
         subst e. iIntros (? ? (e'2 & -> & (Fn3 & Heqp3' & He3' & ->)%call_head_step)%head_reducible_prim_step_ctx).
         2: { do 2 eexists.
              apply call_head_step. exists Fn. repeat split; try done. }
         rewrite Heqs' in Heqp3'. assert (e'2 = e2') as -> by congruence.
         iSpecialize ("H3'" $! σ e2').
         assert (prim_step pc (of_class Λ (ExprCall s' vv')) σ e2' σ) as Hstep2.
         { apply head_prim_step. apply call_head_step. eexists; repeat split; done. }
         iSpecialize ("H3'" $! Hstep2). iMod "H3'". iModIntro. iNext.
         iMod "H3'" as "(? & H3')". iModIntro. iFrame.
         iApply wp_bind. iApply (wp_wand with "[H3']").
         { iApply ("IHe" $! _ _ kidx). rewrite Heqk. iApply "H3'". }
         iIntros (r) "Hr". iSpecialize ("H3" $! r with "Hr"). iApply ("IHe" $! _ _ i). rewrite Heq. done.
    * iRight. iLeft. iModIntro. do 3 iExists _; iSplitR; first done.
      destruct (union_map_list (map snd A) !! s') as [v|] eqn:Heqv.
      { iExFalso. iDestruct (Haxiom $! s' vv' Ξ with "HΨ") as "%Hfalse". exfalso.
        apply Hfalse. eapply elem_of_dom_2. done. }
      cbn. iSplitR; first done. iModIntro. iExists Ξ. iFrame. iNext.
      iIntros (r) "Hr". iSpecialize ("H3" with "Hr"). iApply ("IHe" $! _ _ i). by rewrite Heq.
    * iModIntro. iRight. iRight.
      iSplitR.
      { iPureIntro. eapply reducible_mono; last done.
        apply union_map_subset; first done. apply elem_of_list_In.
        apply in_map_iff. exists ((Ψi, pi)); split; eauto.
        by eapply nth_error_In. }
      iIntros (σ' e' Hstep%prim_step_inv).
      iSpecialize ("H3" $! σ' e').
      destruct Hstep as (K & e1' & e2' & -> & -> & H).
      assert (prim_step pi (fill K e1') σ (fill K e2') σ') as Hstep.
      { econstructor. 1-2:done. destruct (to_class e1') as [[]|] eqn:Heqe1.
        - exfalso. eapply val_head_step. apply of_to_class in Heqe1. erewrite Heqe1. done.
        - apply of_to_class in Heqe1. subst e1'.
          destruct HH as (? & σ'2 & (e2'' & -> & (K2 & eK1 & eK2 & Heq1 & -> & HHstep)%prim_step_inv)%fill_step_inv).
          2: unfold to_val; by rewrite to_of_class.
          assert (K2 = empty_ectx) as ->.
          1: { destruct (fill_class' K2 eK1) as [|[vv Hvv]].
               1: eexists; rewrite <- Heq1; by rewrite to_of_class.
               1: done.
               exfalso. apply of_to_class in Hvv. subst eK1. eapply val_head_step. done. }
          rewrite fill_empty in Heq1. subst eK1. apply call_head_step in H, HHstep.
          destruct H as (FN1 & HFN1 &Happy1 & ->).
          destruct HHstep as (FN2 & HFN2 &Happy2 & ->).
          apply union_map_list_spec in HFN1; last done. destruct HFN1 as (? & [[ΨΨ kk] [<- (kki & Hkki)%In_nth_error]]%in_map_iff & HFN1).
          cbn in HFN1. destruct (decide (kki = i)) as [-> | Hcontr].
          1: apply call_head_step; exists FN2; repeat split; try congruence.
          exfalso. specialize (Hdis kki i Hcontr). rewrite ! nth_error_map in Hdis.
          rewrite Hkki in Hdis. rewrite Heq in Hdis. cbn in Hdis. rewrite elem_of_disjoint in Hdis.
          eapply Hdis; eapply elem_of_dom_2; done.
        - by eapply head_step_no_call. }
      iDestruct ("H3" $! Hstep) as ">H3". iModIntro. iNext.
      iMod "H3" as "(Hσ & HWP)". iModIntro. iFrame. iApply ("IHe" $! _ _ i). rewrite Heq. done.
Qed.

Lemma wp_link_progs Ψaxiom Ψres (pres : gmap string (Λ.(func))) A :
  can_link_all Ψaxiom Ψres pres A
 -> ⊢ Ψaxiom |- pres :: Ψres.
Proof.
  intros [Hdis HΨres Haxiom -> one_spec' Hsatis].
  iIntros (s vv Φ) "H". iPoseProof HΨres as "HΨres".
    iDestruct ("HΨres" with "H") as "[%x Hx]".
    erewrite nth_error_map.
    destruct (nth_error A x) as [[Ψi pi]|] eqn:Heq; last by iExFalso. cbn.
    specialize (Hsatis x) as Hsatis2.
    rewrite Heq in Hsatis2. iDestruct (Hsatis2 $! s vv Φ with "Hx") as "[%Hx1 Hx2]".
    destruct (union_map_list (map snd A) !! s) eqn:Hl2.
  - iSplitR; first done. unshelve iApply (wp_link_execs _ _ _ _ $! _ _ x). 3: by split. rewrite Heq. done.
  - exfalso. destruct (pi !! s) as [f|] eqn:Heqpi; try congruence.
    assert (∃ k, In k ((map snd A)) ∧ k !! s = Some f) as HH.
    + exists pi; repeat split; try done. apply in_map_iff. exists (Ψi,pi).
      repeat split; try done. eapply nth_error_In. done.
    + apply union_map_list_spec in HH; try congruence. done.
Qed.

End wp.


Require Import String.
Require Import Coq.ZArith.ZArith.
Require Import coqutil.Z.Lia.
Require Import Coq.Lists.List. Import ListNotations.
Require Import Kami.Lib.Word.
Require Import Kami.Ex.IsaRv32 riscv.Spec.Decode.
Require Import riscv.Utility.Encode.
Require Import coqutil.Word.LittleEndian.
Require Import coqutil.Word.Properties.
Require Import coqutil.Map.Interface.
Require Import coqutil.Tactics.Tactics.
Require Import coqutil.Tactics.rdelta.
Require Import processor.KamiWord.
Require Import riscv.Utility.Utility.
Require Import riscv.Utility.runsToNonDet.
Require Import riscv.Spec.Primitives.
Require Import riscv.Spec.MetricPrimitives.
Require Import riscv.Spec.Machine.
Require riscv.Platform.Memory.
Require Import riscv.Spec.PseudoInstructions.
Require Import riscv.Proofs.EncodeBound.
Require Import riscv.Proofs.DecodeEncode.
Require Import riscv.Platform.Run.
Require Import riscv.Utility.MkMachineWidth.
Require Import riscv.Utility.Monads. Import MonadNotations.
Require Import coqutil.Datatypes.PropSet.
Require Import riscv.Platform.RiscvMachine.
Require Import riscv.Platform.MetricRiscvMachine.
Require Import riscv.Platform.MinimalMMIO.
Require Import riscv.Platform.MetricMinimalMMIO.
Require Import riscv.Platform.FE310ExtSpec.

Require Import Kami.Syntax Kami.Semantics Kami.Tactics.
Require Import Kami.Ex.MemTypes Kami.Ex.SC Kami.Ex.SCMMInl Kami.Ex.SCMMInv.

Require Export processor.KamiProc.
Require Import processor.Consistency.
Require Import processor.KamiRiscvStep.

Lemma get_of_list_not_In:
  forall (key: Type) (key_dec: forall k1 k2: key, {k1 = k2} + {k1 <> k2})
         (value: Type) (map: map.map key value),
    map.ok map ->
    forall (l: list (key * value)) k,
      ~ In k (List.map fst l) ->
      map.get (map.of_list l) k = None.
Proof.
  induction l as [|[k v] l]; simpl; intros;
    [rewrite map.get_empty; reflexivity|].
  destruct (key_dec k k0).
  - intuition idtac.
  - rewrite map.get_put_diff by auto.
    apply IHl; intuition idtac.
Qed.

Lemma alignedXAddrsRange_zero_bound_in:
  forall n a,
    (wordToN a < N.of_nat n)%N -> In a (alignedXAddrsRange 0 n).
Proof.
  induction n; [blia|].
  intros.
  assert (wordToN a = N.of_nat n \/ wordToN a < N.of_nat n)%N by blia.
  clear H; destruct H0.
  - unfold alignedXAddrsRange; fold alignedXAddrsRange.
    left; apply wordToN_inj.
    rewrite H.
    change (0 + n)%nat with n.
    pose proof (wordToN_bound a); rewrite H in H0.
    rewrite <-wordToN_NToWord_2 with (sz:= Z.to_nat width) (n:= N.of_nat n) by assumption.
    rewrite NToWord_nat, Nnat.Nat2N.id; reflexivity.
  - right; auto.
Qed.

Section Equiv.
  Context {Registers: map.map Z word}
          {mem: map.map word byte}.

  Local Notation M := (free action result).
  Local Notation RiscvMachine := MetricRiscvMachine.
  Local Existing Instance MetricMinimalMMIO.IsRiscvMachine.
  Local Existing Instance MetricMinimalMMIOSatisfiesPrimitives.

  (** * Processor, software machine, and states *)

  Variable (instrMemSizeLg memSizeLg: Z).
  Hypotheses (Hinstr1: 3 <= instrMemSizeLg)
             (Hinstr2: instrMemSizeLg <= width - 2)
             (Hkmem1: 2 + instrMemSizeLg < memSizeLg)
             (Hkmem2: memSizeLg <= width)
             (* 16 used to be disjoint to MMIO addresses.
              * [Hkmem2] is meaningless assuming this [Hkmemdisj]
              * but still having that in context ease some proofs. *)
             (Hkmemdisj: memSizeLg <= 16).
  Local Notation Hinstr := (conj Hinstr1 Hinstr2).

  Variable (memInit: Vec (ConstT (Bit BitsPerByte)) (Z.to_nat memSizeLg)).
  Definition kamiMemInit := ConstVector memInit.
  Local Definition kamiProc :=
    @KamiProc.proc instrMemSizeLg memSizeLg Hinstr kamiMemInit
                   (kami_AbsMMIO (Z.to_N memSizeLg)).

  (* redefine mcomp_sat to simplify for the case where no answer is returned *)
  Local Notation mcomp_sat_unit m initialL post :=
    (mcomp_sat m initialL (fun (_: unit) => post)).

  Context (Registers_ok: map.ok Registers)
          (mem_ok: map.ok mem).

  Local Notation states_related :=
    (@states_related Registers mem instrMemSizeLg memSizeLg Hinstr1 Hinstr2).
  Local Notation kamiStep :=
    (@kamiStep _ _ Hinstr1 Hinstr2 memInit).

  Arguments Z.add: simpl never.

  Lemma KamiLabelR_unique: forall {klbl t t'},
      KamiLabelR klbl t ->
      KamiLabelR klbl t' ->
      t = t'.
  Proof.
    intros. inversion H; inversion H0; clear H H0; subst.
    + reflexivity.
    + rewrite H4 in H1. exfalso. eapply FMap.M.add_empty_neq. eassumption.
    + rewrite H1 in H5. exfalso. eapply FMap.M.add_empty_neq. eassumption.
    + simpl in *. rewrite H1 in H5.
      apply (f_equal (FMap.M.find "mmioExec"%string)) in H5.
      do 2 rewrite FMap.M.find_add_1 in H5.
      apply Option.eq_of_eq_Some in H5.
      apply Eqdep.EqdepTheory.inj_pair2 in H5.
      inversion H5; subst; clear H5.
      reflexivity.
  Qed.

  Inductive KamiLabelSeqR: list LabelT -> list Event -> Prop :=
  | KamiSeqNil: KamiLabelSeqR nil nil
  | KamiSeqCons:
      forall klseq t,
        KamiLabelSeqR klseq t ->
        forall klbl nt,
          KamiLabelR klbl nt ->
          KamiLabelSeqR (klbl :: klseq) (nt ++ t).

  (** * Rephrasing single step soundness in a more readable way *)

  Definition KState: Type := KamiMachine * list LabelT.

  Inductive kstep1: KState -> KState -> Prop :=
  | KStep: forall (m1: KamiMachine) (t1: list LabelT) kupd klbl,
      Step kamiProc m1 kupd klbl ->
      kstep1 (m1, t1) (FMap.M.union kupd m1, klbl :: t1).

  Definition CState: Type := RiscvMachine.

  Definition cstep1(m1: CState)(P: CState -> Prop): Prop := mcomp_sat_unit (run1 iset) m1 P.

  Inductive related: KState -> CState -> Prop :=
  | Related: forall km kt eventTrace rm,
      Kami.Semantics.reachable km kamiProc ->
      states_related (km, eventTrace) rm ->
      KamiLabelSeqR kt eventTrace ->
      related (km, kt) rm.

  Theorem kstep1_sound: forall ks1 ks2 rs1 P,
      related ks1 rs1 ->
      kstep1 ks1 ks2 ->
      cstep1 rs1 P ->
      related ks2 rs1 \/
      exists rs2, related ks2 rs2 /\ P rs2.
  Proof.
    intros.
    pose proof (KamiRiscvStep.kamiStep_sound instrMemSizeLg memSizeLg Hinstr1 Hinstr2
      Hkmem1 Hkmem2 Hkmemdisj memInit Registers_ok mem_ok) as Q.
    unfold cstep1, kamiStep in *.
    inversion H. inversion H0. subst. inversion H8. subst. clear H H0 H8.
    specialize Q with (1 := H2) (3 := H3) (4 := H1).
    edestruct Q as [A | A]; clear Q.
    - eauto.
    - left. destruct A as [Q1 Q2]. econstructor.
      + unfold reachable in *.
        destruct H2 as [sigma H2]. inversion H2. subst; clear H2.
        eexists. constructor. eapply Multi; eassumption.
      + eassumption.
      + inversion H4; subst; clear H4.
        * change (KamiLabelSeqR [klbl] ([] ++ [])).
          eapply KamiSeqCons. 1: exact KamiSeqNil.
          eapply KamiSilent. assumption.
        * inversion Q1. clear Q1. subst.
          change (nt ++ t) with ([] ++ nt ++ t).
          repeat eapply KamiSeqCons; try assumption. constructor. assumption.
    - right. destruct A as [rs2 [tNew' [A [B C]]]].
      exists rs2. split. 2: exact C.
      econstructor. 2: exact B.
      + unfold reachable in *.
        destruct H2 as [sigma H2]. inversion H2. subst; clear H2.
        eexists. constructor. eapply Multi; eassumption.
      + eapply KamiSeqCons; eassumption.
  Qed.

  (** * Multistep and Behavior soundness *)

  Inductive ksteps: KState -> KState -> Prop :=
  | KSteps: forall m1 t1 m2 tNew,
      Multistep kamiProc m1 m2 tNew ->
      ksteps (m1, t1) (m2, tNew ++ t1).

  (* Can't use this one here because we're not doing a simulation from Kami to compiler *)
  Definition csteps: CState -> (CState -> Prop) -> Prop := runsTo cstep1.

  Definition calways{State: Type}(Step: State -> (State -> Prop) -> Prop)(s: State)(P: State -> Prop): Prop :=
    P s /\ forall s', P s' -> Step s' P.

  (* Can't use this one here because we don't really have a `kstep: KState -> KState -> Prop` that
     we lift with *, but Kami requires its own ksteps (its own "star") *)
  Definition kalways0{State: Type}(Step: State -> State -> Prop)(s: State)(P: State -> Prop): Prop :=
    P s /\ forall s1 s2, P s1 -> Step s1 s2 -> P s2.

  Definition kalways{State: Type}(Stepstar: State -> State -> Prop)(s: State)(P: State -> Prop): Prop :=
    forall s', Stepstar s s' -> P s'.

  Theorem ksteps_sound: forall (inv: CState -> Prop) ks1 rs1,
      related ks1 rs1 ->
      calways cstep1 rs1 inv ->
      kalways ksteps ks1 (fun ks2 => exists rs2, related ks2 rs2 /\ inv rs2).
  Proof.
    unfold calways, kalways.
    intros. destruct H0. inversion H1. subst. clear H1. revert H3 rs1 t1 H0 H.
    induction 1; intros.
    - subst. exists rs1. split; assumption.
    - specialize IHMultistep with (1 := H0) (2 := H).
      destruct IHMultistep as [rs2 [A B]].
      edestruct kstep1_sound.
      + exact A.
      + econstructor. eassumption.
      + eapply H2. exact B.
      + eauto.
      + eauto.
  Qed.

  Definition KamiImplMachine: Type := RegsT.

  (* When running the processor on an FPGA, this memory module will be implemented in some
     trusted Verilog code, and will forward requests either to a DRAM or to a source
     from which the program to run can be loaded at startup.
     This source could be a connection to a host computer, an SD card, a ROM, ...
     In any case, we model this in Kami as a huge register file.
     Therefore, a faithful Verilog implementation will have to make sure that all in-range
     addresses behave like memory, including the ones from which the program is loaded.
     One possible implementation would be this:
     For each address which is designated as a "program load address", also have DRAM for it,
     as well as an extra "initialized bit", which is set to false initially.
     Whenever such an address is loaded, if the initialized bit is set, the value from the
     DRAM is returned, otherwise the value from the program source is loaded, stored into
     DRAM, and the bit is set to 1.
     Whenever such an address is stored, the initialized bit is set, and the value is stored
     into DRAM.
     For the proofs, we model this component as a huge register file where the addresses
     designated as "program load adddresses" are initialized to [prog], and the other
     addresses are initialized to zero.
     We'll use the convention that "program load addresses" are from 0 to 4*2^instrMemSizeLg,
     and that the data memory goes from 4*2^instrMemSizeLg to dataMemSize
     because then we don't have to pass the base program load address to this definition,
     and to serve load/store requests in the Kami model, we can just ignore the upper bits
     and use the lower bits to index into the Vector.
   *)

  Definition mm: Modules := Kami.Ex.SC.mm
                              (existT _ rv32DataBytes eq_refl)
                              kamiMemInit (kami_AbsMMIO (Z.to_N memSizeLg)).
  Definition p4mm: Modules := p4mm Hinstr kamiMemInit (kami_AbsMMIO (Z.to_N memSizeLg)).

  Fixpoint setRegsInit (kinits: kword 5 -> kword width) (n: nat): Registers :=
    match n with
    | O => map.put map.empty 0 $0
    | S n' => map.put (setRegsInit kinits n') (Z.of_nat n) (kinits $n)
    end.

  Definition riscvRegsInit: Registers :=
    setRegsInit (evalConstT (rfInit procInit)) 31.
  Lemma regs_related_riscvRegsInit:
    regs_related (evalConstT (rfInit procInit)) riscvRegsInit.
  Proof.
    red; intros.

    clear -Registers_ok.
    pose proof (wordToN_bound w).
    change (NatLib.Npow2 (BinInt.Z.to_nat 5)) with 32%N in H.
    assert (wordToN w = 0 \/ wordToN w = 1 \/ wordToN w = 2 \/ wordToN w = 3 \/
            wordToN w = 4 \/ wordToN w = 5 \/ wordToN w = 6 \/ wordToN w = 7 \/
            wordToN w = 8 \/ wordToN w = 9 \/ wordToN w = 10 \/ wordToN w = 11 \/
            wordToN w = 12 \/ wordToN w = 13 \/ wordToN w = 14 \/ wordToN w = 15 \/
            wordToN w = 16 \/ wordToN w = 17 \/ wordToN w = 18 \/ wordToN w = 19 \/
            wordToN w = 20 \/ wordToN w = 21 \/ wordToN w = 22 \/ wordToN w = 23 \/
            wordToN w = 24 \/ wordToN w = 25 \/ wordToN w = 26 \/ wordToN w = 27 \/
            wordToN w = 28 \/ wordToN w = 29 \/ wordToN w = 30 \/ wordToN w = 31)%N
      by abstract blia.
    clear H.
    repeat match goal with
           | H: _ \/ _ |- _ => destruct H
           end.

    all: match goal with
         | H: wordToN _ = ?n |- _ =>
           change n with (wordToN (sz:= 5) $(N.to_nat n)) in H;
             apply wordToN_inj in H; subst; simpl
         end.
    all: cbv [riscvRegsInit setRegsInit].
    all: repeat rewrite map.get_put_diff by discriminate.
    all: rewrite map.get_put_same.
    all: reflexivity.
  Qed.

  Lemma riscvRegsInit_sound:
    forall reg, 0 < reg < 32 -> map.get riscvRegsInit reg <> None.
  Proof.
    intros.
    assert (reg = 1 \/ reg = 2 \/ reg = 3 \/
            reg = 4 \/ reg = 5 \/ reg = 6 \/ reg = 7 \/
            reg = 8 \/ reg = 9 \/ reg = 10 \/ reg = 11 \/
            reg = 12 \/ reg = 13 \/ reg = 14 \/ reg = 15 \/
            reg = 16 \/ reg = 17 \/ reg = 18 \/ reg = 19 \/
            reg = 20 \/ reg = 21 \/ reg = 22 \/ reg = 23 \/
            reg = 24 \/ reg = 25 \/ reg = 26 \/ reg = 27 \/
            reg = 28 \/ reg = 29 \/ reg = 30 \/ reg = 31)
      by abstract blia.
    clear H.
    repeat match goal with
           | H: _ \/ _ |- _ => destruct H
           end.

    all: subst.
    all: cbv [riscvRegsInit setRegsInit].
    all: repeat rewrite map.get_put_diff by discriminate.
    all: rewrite map.get_put_same.
    all: discriminate.
  Qed.

  Definition riscvMemInit : mem := map.of_list (List.map
    (fun i : nat =>
      (word.of_Z (Z.of_nat i),
       byte.of_Z (uwordToZ (evalConstT kamiMemInit $i))))
    (seq 0 (2 ^ Z.to_nat memSizeLg))).

  Instance kword32: coqutil.Word.Interface.word 32 := KamiWord.word 32.
  Instance kword32_ok: word.ok kword32. eapply KamiWord.ok. reflexivity. Qed.
  Lemma riscvMemInit_get_None:
    forall addr,
      (kunsigned addr <? 2 ^ memSizeLg) = false ->
      map.get riscvMemInit addr = None.
  Proof.
    intros.
    apply get_of_list_not_In; [exact (@weq (Z.to_nat width))|assumption|].

    intro Hx.
    apply in_map_iff in Hx; destruct Hx as [[addr' v] [? Hx]].
    simpl in H0; subst.
    apply in_map_iff in Hx; destruct Hx as [n [? ?]].
    inversion H0; subst; clear H0.
    apply in_seq in H1; destruct H1 as [_ ?]; simpl in H0.

    apply Nat2Z.inj_lt in H0.
    rewrite N_Z_nat_conversions.Nat2Z.inj_pow in H0.
    rewrite Z2Nat.id in H0 by blia.
    simpl in H0.

    match type of H with
    | (?x <? ?y) = false => destruct (Z.ltb_spec x y); [discriminate|clear H]
    end.
    change kunsigned with (word.unsigned (width:= width)) in H1.
    change kofZ with (word.of_Z (width:= width)) in H1.
    rewrite word.unsigned_of_Z in H1.
    cbv [word.wrap] in H1.
    rewrite Z.mod_small in H1
      by (split; [blia|];
          eapply Z.lt_le_trans; [eassumption|];
          apply Z.pow_le_mono_r; blia).
    blia.
  Qed.

  Lemma mem_related_riscvMemInit : mem_related _ (evalConstT kamiMemInit) riscvMemInit.
  Proof.
    cbv [mem_related riscvMemInit].
    intros addr.
    case (kunsigned addr <? 2 ^ memSizeLg) eqn:H.
    2: { apply riscvMemInit_get_None; assumption. }
    assert (#addr < 2 ^ Z.to_nat memSizeLg)%nat.
    { rewrite <-wordToN_to_nat.
      apply Nat2Z.inj_lt.
      rewrite N_nat_Z, N_Z_nat_conversions.Nat2Z.inj_pow.
      rewrite Z2Nat.id by blia.
      apply Z.ltb_lt; assumption.
    }
    erewrite Properties.map.get_of_list_In_NoDup; trivial.
    1: eapply NoDup_nth_error; intros i j ?.
    2: eapply (nth_error_In _ (wordToNat addr)).

    { rewrite map_map; cbn; cbv [kofZ].
      clear dependent addr.
      rewrite !map_length, seq_length in H1.
      rewrite (@map_nth_error _ _ _ _ _ i).
      2: etransitivity; [eapply nth_error_nth'|];
           rewrite ?seq_length, ?seq_nth; trivial.
      destruct (lt_dec j (2^Z.to_nat memSizeLg)).
      { rewrite (@map_nth_error _ _ _ _ _ j).
        2: etransitivity; [eapply nth_error_nth'|];
            rewrite ?seq_length, ?seq_nth; trivial.
        intros HX.
        injection HX; clear HX; intros HX.
        eapply (f_equal (@wordToZ _)) in HX.
        pose proof Z.pow_le_mono_r 2 memSizeLg 31 eq_refl ltac:(blia);
        pose proof N_Z_nat_conversions.Z2Nat.inj_pow 2 memSizeLg ltac:(blia) ltac:(blia);
        change (Z.to_nat 2) with 2%nat in *.
        rewrite 2wordToZ_ZToWord'' in HX; try split;
         change (BinInt.Z.of_nat (Pos.to_nat 32) - 1) with 31;
         blia. }
      { rewrite (proj2 (nth_error_None _ _)); try congruence.
        rewrite map_length, seq_length; blia. } }
    { replace (evalZeroExtendTrunc (BinInt.Z.to_nat memSizeLg) addr)
        with (natToWord (Z.to_nat memSizeLg) (wordToNat addr)).
      2: {
        cbv [evalZeroExtendTrunc].
        destruct (lt_dec _ _); [exfalso; apply Z2Nat.inj_lt in l; blia|].
        apply wordToNat_inj.
        rewrite wordToNat_natToWord_eqn.
        rewrite wordToNat_split1.
        cbv [eq_rec_r eq_rec]; rewrite wordToNat_eq_rect.
        reflexivity.
      }
      rewrite (@map_nth_error _ _ _ _ _ (wordToNat addr)).
      2: {
        etransitivity; [eapply nth_error_nth'|].
        all : rewrite ?seq_length, ?seq_nth; trivial.
      }
      do 2 f_equal.
      eapply word.unsigned_inj.
      rewrite word.unsigned_of_Z.
      cbv [word.wrap]; rewrite <-word.wrap_unsigned; f_equal.
      unfold word.unsigned, word, wordW, KamiWord.word, kword, kunsigned.
      rewrite wordToN_nat, nat_N_Z; reflexivity.
    }
    Unshelve. all: exact O.
  Qed.

  Lemma states_related_init:
    states_related
      (initRegs (getRegInits (proc Hinstr kamiMemInit (kami_AbsMMIO (Z.to_N memSizeLg)))), [])
      {| getMachine :=
           {| RiscvMachine.getRegs := riscvRegsInit;
              RiscvMachine.getPc := word.of_Z 0;
              RiscvMachine.getNextPc := word.of_Z 4;
              RiscvMachine.getMem := riscvMemInit;
              RiscvMachine.getXAddrs := kamiXAddrs instrMemSizeLg;
              RiscvMachine.getLog := nil; (* <-- intended to be nil *) |};
         getMetrics := MetricLogging.EmptyMetricLog; |}.
  Proof.
    econstructor; try reflexivity.
    - econstructor.
    - eapply pRegsToT_init.
    - intros; discriminate.
    - split; reflexivity.
    - apply regs_related_riscvRegsInit.
    - apply mem_related_riscvMemInit.
  Qed.

  Lemma equivalentLabel_preserves_KamiLabelR:
    forall l1 l2,
      equivalentLabel (liftToMap1 (@idElementwise _)) l1 l2 ->
      forall l,
        KamiLabelR l2 l -> KamiLabelR l1 l.
  Proof.
    intros.
    destruct l1 as [ann1 ds1 cs1], l2 as [ann2 ds2 cs2].
    destruct H as [? [? ?]]; simpl in *.
    rewrite SemFacts.liftToMap1_idElementwise_id in H, H1; subst.
    inversion_clear H0; subst.
    - apply KamiSilent; assumption.
    - eapply KamiMMIO; eauto.
  Qed.

  Lemma equivalentLabelSeq_preserves_KamiLabelSeqR:
    forall t1 t2,
      equivalentLabelSeq (liftToMap1 (@idElementwise _)) t1 t2 ->
      forall t,
        KamiLabelSeqR t2 t ->
        KamiLabelSeqR t1 t.
  Proof.
    induction 1; intros; [assumption|].
    inversion_clear H1.
    constructor; auto.
    eapply equivalentLabel_preserves_KamiLabelR; eauto.
  Qed.

  Lemma riscv_init_memory_undef_on_MMIO:
    map.undef_on riscvMemInit isMMIOAddr.
  Proof.
    cbv [map.undef_on map.agree_on]; intros.
    cbv [elem_of] in H.
    pose proof (mmio_mem_disjoint _ Hkmemdisj _ H); clear H.
    rewrite map.get_empty.
    apply riscvMemInit_get_None.
    destruct (Z.ltb_spec (kunsigned k) (2 ^ memSizeLg)); intuition idtac.
  Qed.

  Lemma mmio_init_xaddrs_disjoint:
    disjoint (of_list (kamiXAddrs instrMemSizeLg)) isMMIOAddr.
  Proof.
    cbv [disjoint of_list elem_of]; intros.
    pose proof (mmio_mem_disjoint _ Hkmemdisj x).
    destruct (Z.ltb_spec (kunsigned x) (2 ^ memSizeLg)).
    - right; intro Hx; auto.
    - left; intro Hx.
      apply kamiXAddrs_isXAddr1_bound in Hx.
      apply N2Z.inj_lt in Hx.
      rewrite NatLib.Z_of_N_Npow2 in Hx.
      assert (2 ^ BinInt.Z.of_nat (2 + Z.to_nat instrMemSizeLg) < 2 ^ memSizeLg)
        by (apply Z.pow_lt_mono_r; blia).
      cbv [kunsigned] in *.
      blia.
  Qed.

  Lemma riscv_to_kamiImplProcessor:
    forall (traceProp: list Event -> Prop)
           (* --- hypotheses which will be proven by the compiler --- *)
           (RvInv: RiscvMachine -> Prop)
           (establishRvInv:
              forall (m0RV: RiscvMachine),
                m0RV.(RiscvMachine.getMem) = riscvMemInit ->
                m0RV.(RiscvMachine.getPc) = word.of_Z 0 ->
                m0RV.(RiscvMachine.getNextPc) = word.of_Z 4 ->
                (forall a: word,
                    0 <= word.unsigned a < 2 ^ (2 + instrMemSizeLg) ->
                    In a m0RV.(RiscvMachine.getXAddrs)) ->
                disjoint (of_list m0RV.(RiscvMachine.getXAddrs)) isMMIOAddr ->
                (forall reg, 0 < reg < 32 -> map.get m0RV.(getRegs) reg <> None) ->
                m0RV.(getLog) = nil ->
                RvInv m0RV)
           (preserveRvInv:
              forall (m: RiscvMachine), RvInv m -> mcomp_sat_unit (run1 iset) m RvInv)
           (useRvInv:
              forall (m: RiscvMachine),
                RvInv m -> exists t, traces_related t m.(getLog) /\
                                     traceProp t),
    (* --- final end to end theorem will start here --- *)
    forall (t: list LabelT) (mFinal: KamiImplMachine),
      Behavior p4mm mFinal t ->
      (* --- conclusion ---
         The trace produced by the kami implementation can be mapped to an MMIO trace
         (this guarantees that the only external behavior of the kami implementation is MMIO)
         and moreover, this MMIO trace satisfies some desirable property. *)
      exists (t': list Event), KamiLabelSeqR t t' /\ traceProp t'.
  Proof.
    intros.
    pose proof (@proc_correct instrMemSizeLg memSizeLg Hinstr kamiMemInit) as P.
    unfold traceRefines in P.
    specialize P with (1 := H).
    destruct P as (mFinal' & t' & B & E).
    inversion_clear B.
    edestruct ksteps_sound as (rs2 & Rel & Inv). 2: unfold calways; split.
    - econstructor.
      + eapply Kami.SemFacts.reachable_init.
      + eapply states_related_init.
      + eapply KamiSeqNil.
    - eapply establishRvInv; try reflexivity.
      all: cbv [getXAddrs getMachine]; intros.
      + apply alignedXAddrsRange_zero_bound_in.
        apply N2Z.inj_lt.
        rewrite nat_N_Z.
        cbv [instrMemSize].
        rewrite N_Z_nat_conversions.Nat2Z.inj_pow.
        rewrite Nat2Z.inj_add, Z2Nat.id by blia.
        apply H0.
      + apply mmio_init_xaddrs_disjoint.
      + apply riscvRegsInit_sound; assumption.
    - exact preserveRvInv.
    - econstructor. exact HMultistepBeh.
    - specialize (useRvInv _ Inv).
      inversion Rel. subst. clear Rel.
      simpl in useRvInv.
      destruct useRvInv as (t''' & R' & p).
      eexists. split; [|exact p].
      rewrite app_nil_r in H5.
      inversion H3. subst. clear H3.
      eapply equivalentLabelSeq_preserves_KamiLabelSeqR.
      1: eassumption.
      pose proof (traces_related_unique R' H4). subst t'''.
      assumption.
  Qed.

End Equiv.


From iris.proofmode Require Import proofmode.
From iris.algebra Require Import auth csum frac agree.
From iris.bi Require Import fractional.
From lrust.lifetime Require Import na_borrow.
From lrust.typing Require Import typing.
From lrust.typing.lib.refcell Require Import refcell.
From iris.prelude Require Import options.

Definition refcell_refN := refcellN .@ "ref".

Section ref.
  Context `{!typeGS Σ, !refcellG Σ}.

  (* The Rust type looks as follows (after some unfolding):

     pub struct Ref<'b, T: ?Sized + 'b> {
       value: &'b T,
       borrow: &'b Cell<BorrowFlag>,
     }
  *)

  Program Definition ref (α : lft) (ty : type) :=
    tc_opaque
    {| ty_size := 2;
       ty_own tid vl :=
         match vl return _ with
         | [ #(LitLoc lv);  #(LitLoc lrc) ] =>
           ∃ ν q γ β ty', ty.(ty_shr) (α ⊓ ν) tid lv ∗
             α ⊑ β ∗ &na{β, tid, refcell_invN}(refcell_inv tid lrc γ β ty') ∗
             q.[ν] ∗ own γ (◯ reading_stR q ν)
         | _ => False
         end;
       ty_shr κ tid l :=
          ∃ ν q γ β ty' (lv lrc : loc),
             κ ⊑ ν ∗ &frac{κ} (λ q, l↦∗{q} [ #lv; #lrc]) ∗
             ▷ ty.(ty_shr) (α ⊓ ν) tid lv ∗
             ▷ (α ⊑ β) ∗ ▷ &na{β, tid, refcell_invN}(refcell_inv tid lrc γ β ty') ∗
             &na{κ, tid, refcell_refN}(own γ (◯ reading_stR q ν)) |}%I.
  Next Obligation. iIntros (???[|[[]|][|[[]|][]]]) "?"; auto. Qed.
  Next Obligation.
    iIntros (α ty E κ l tid q ?) "#LFT Hb Htok".
    iMod (bor_exists with "LFT Hb") as (vl) "Hb"; first done.
    iMod (bor_sep with "LFT Hb") as "[H↦ Hb]"; first done.
    iMod (bor_fracture (λ q, l ↦∗{q} vl)%I with "LFT H↦") as "#H↦"; first done.
    destruct vl as [|[[|lv|]|][|[[|lrc|]|][]]];
      try by iMod (bor_persistent with "LFT Hb Htok") as "[>[] _]".
    iMod (bor_exists with "LFT Hb") as (ν) "Hb"; first done.
    iMod (bor_exists with "LFT Hb") as (q') "Hb"; first done.
    iMod (bor_exists with "LFT Hb") as (γ) "Hb"; first done.
    iMod (bor_exists with "LFT Hb") as (β) "Hb"; first done.
    iMod (bor_exists with "LFT Hb") as (ty') "Hb"; first done.
    iMod (bor_sep with "LFT Hb") as "[Hshr Hb]"; first done.
    iMod (bor_persistent with "LFT Hshr Htok") as "[#Hshr Htok]"; first done.
    iMod (bor_sep with "LFT Hb") as "[Hαβ Hb]"; first done.
    iMod (bor_persistent with "LFT Hαβ Htok") as "[#Hαβ Htok]"; first done.
    iMod (bor_sep with "LFT Hb") as "[Hinv Hb]"; first done.
    iMod (bor_persistent with "LFT Hinv Htok") as "[#Hinv $]"; first done.
    iMod (bor_sep with "LFT Hb") as "[Hκν Hb]"; first done.
    iDestruct (frac_bor_lft_incl with "LFT [> Hκν]") as "#Hκν".
    { iApply bor_fracture; try done. by rewrite Qp_mul_1_r. }
    iMod (bor_na with "Hb") as "#Hb"; first done. eauto 20.
  Qed.
  Next Obligation.
    iIntros (??????) "#? H". iDestruct "H" as (ν q γ β ty' lv lrc) "H".
    iExists _, _, _, _, _, _, _. iDestruct "H" as "#(? & ? & $ & $ & $ & ?)".
    iSplit; last iSplit.
    - by iApply lft_incl_trans.
    - by iApply frac_bor_shorten.
    - by iApply na_bor_shorten.
  Qed.

  Global Instance ref_wf α ty `{!TyWf ty} : TyWf (ref α ty) :=
    { ty_lfts := [α]; ty_wf_E := ty_wf_E ty ++ ty_outlives_E ty α }.

  Global Instance ref_type_contractive α : TypeContractive (ref α).
  Proof. solve_type_proper. Qed.
  Global Instance ref_ne α : NonExpansive (ref α).
  Proof. apply type_contractive_ne, _. Qed.

  Global Instance ref_mono E L :
    Proper (flip (lctx_lft_incl E L) ==> subtype E L ==> subtype E L) ref.
  Proof.
    iIntros (α1 α2 Hα ty1 ty2 Hty qmax qL) "HL".
    iDestruct (Hty with "HL") as "#Hty". iDestruct (Hα with "HL") as "#Hα".
    iIntros "!> #HE". iDestruct ("Hα" with "HE") as %Hα1α2.
    iDestruct ("Hty" with "HE") as "(%&#Ho&#Hs)". iSplit; [|iSplit; iModIntro].
    - done.
    - iIntros (tid [|[[]|][|[[]|][]]]) "H"=>//=.
      iDestruct "H" as (ν q' γ β ty') "(#Hshr & #H⊑ & #Hinv & Htok & Hown)".
      iExists ν, q', γ, β, ty'. iFrame "∗#". iSplit.
      + iApply ty_shr_mono; last by iApply "Hs".
        iApply lft_intersect_mono; first by iApply lft_incl_syn_sem. iApply lft_incl_refl.
      + iApply lft_incl_trans; first by iApply lft_incl_syn_sem. done.
    - iIntros (κ tid l) "H /=". iDestruct "H" as (ν q' γ β ty' lv lrc) "H".
      iExists ν, q', γ, β, ty', lv, lrc. iDestruct "H" as "#($&$&?&?&$&$)". iSplit.
      + iApply ty_shr_mono; last by iApply "Hs".
        iApply lft_intersect_mono; first by iApply lft_incl_syn_sem. iApply lft_incl_refl.
      + iApply lft_incl_trans; first by iApply lft_incl_syn_sem. done.
  Qed.
  Global Instance ref_mono_flip E L :
    Proper (lctx_lft_incl E L ==> flip (subtype E L) ==> flip (subtype E L)) ref.
  Proof. intros ??????. by apply ref_mono. Qed.
  Lemma ref_mono' E L α1 α2 ty1 ty2 :
    lctx_lft_incl E L α2 α1 → subtype E L ty1 ty2 →
    subtype E L (ref α1 ty1) (ref α2 ty2).
  Proof. intros. by eapply ref_mono. Qed.
  Global Instance ref_proper E L :
    Proper (lctx_lft_eq E L ==> eqtype E L ==> eqtype E L) ref.
  Proof. intros ??[]?? EQ. split; apply ref_mono'; try done; apply EQ. Qed.
  Lemma ref_proper' E L α1 α2 ty1 ty2 :
    lctx_lft_eq E L α1 α2 → eqtype E L ty1 ty2 →
    eqtype E L (ref α1 ty1) (ref α2 ty2).
  Proof. intros. by eapply ref_proper. Qed.
End ref.

Global Hint Resolve refcell_mono' refcell_proper' : lrust_typing.