Require Import Lia.
Require Import Relations.
Require Import Logic.FunctionalExtensionality.
Require Import Lists.List.
Import ListNotations.
Require Import String.
Require Import Cop.Copland.
Import Copland.Term.
Require Import Utils.Utilities.

Module Manifest.

(** ****************************
  * FORMALIZATION OF ATTESTATION PROTOCOL NEGOTIATION
  By: Anna Fritz and
      Dr. Perry Alexander
  Date: January 6th, 2023
************************************)

(** * Manifests
    [Manifest] defines a single attestation manger and its interconnections.
    Information includes:
  asps:  a list of ASPs (measurement operations the AM can preform),
  M : can measure relation (other AMs the current AM knows of),
  C : context relation (other AMs the current AM depends on),
  Policy : local policy specific to the current AM.
           Minimally includes privacy policy and may possibly include selection policy
  Other information not necessary for reasoning includes:
  [key] simulates public key
  [address] simulates address information and
  [tpm] simulates cruft necessary to initialize its TPM
*)
Record Manifest := {

   asps : list ASP ;
   K : list Plc ;
   C : list Plc ;
   Policy : ASP -> Plc -> Prop ;

(*
   ; key : string
   ; address : nat
   ; tpm_init : nat
*)
 }.

(** [Environment] is a set of AM's each defined by a [Manifest].
  The domain of an [Environment] provides names for each [Manifest].
  Names should be the hash of their public key, but this restriction
  is not enforced here.
*)

Definition Environment : Type :=  Plc -> (option Manifest).

Definition e_empty : Environment := (fun _ => None).

Definition e_update (m : Environment) (x : Plc) (v : (option Manifest)) :=
  fun x' => if plc_dec x x' then v else m x'.

Theorem e_update_reduce: forall m x v y, x<>y -> (e_update m x v) y = m y.
Proof.
  intros m x v y H; unfold e_update.
  destruct (plc_dec x y).
  + contradiction.
  + auto.
Qed.

(** A [System] is all attestation managers in the enviornement *)

Definition System := list Environment.

(** ****************************
  * REASONING ABOUT MANIFESTS
*****************************)

(** Within the enviornment [e], does the AM at place [k] have ASP [a]? *)

Definition hasASPe(k:Plc)(e:Environment)(a:ASP):Prop :=
match (e k) with
| None => False
| Some m => In a m.(asps)
end.

(** Within the system [s], does the AM located at place [k] have ASP [a]? *)

Fixpoint hasASPs(k:Plc)(s:System)(a:ASP):Prop :=
    match s with
    | [] => False
    | s1 :: s2 => (hasASPe k s1 a) \/ (hasASPs k s2 a)
    end.

(** Proof that hasASPe is decidable. This means, for any enviornment [e]
   either the ASP [a] is present or it's not. *)

Theorem hasASPe_dec: forall k e a, {hasASPe k e a}+{~hasASPe k e a}.
Proof.
  intros k e a.
  unfold hasASPe.
  destruct (e k).
  + induction (asps m).
  ++ auto.
  ++ inverts IHl.
  +++ simpl. left. right. apply H.
  +++ simpl. assert (asp_dec : {a = a0} + {a<>a0}).
           { repeat decide equality. }
      inverts asp_dec.
  ++++ left. auto.
  ++++ right. unfold not. intros. inverts H1; auto.
  + auto.
Defined.

(** prove hasASPs is decidable. This means, for any system [s]
   either the ASP [a] is present or it's not. *)

Theorem hasASPs_dec: forall k e a, {hasASPs k e a}+{~hasASPs k e a}.
Proof.
  intros k e a.
  induction e.
  + simpl in *. right. unfold not. intros. apply H.
  + simpl in *. pose proof hasASPe_dec k a0 a. inverts H.
  ++ left. left. apply H0.
  ++ inverts IHe.
  +++ left. right. apply H.
  +++ right. unfold not. intros. inverts H1; auto.
Defined.

(** Determine if manifest [k] from [e] knows how to
   communicate from [k] to [p]
*)

Definition knowsOfe(k:Plc)(e:Environment)(p:Plc):Prop :=
match (e k) with
| None => False
| Some m => In p m.(K)
end.

Print System.
Print Environment.

(** Determine if place [k] within the system [s] knows of [p] *)

Fixpoint knowsOfs(k:Plc)(s:System)(p:Plc):Prop :=
match s with
| [] => False
| s1 :: ss => (knowsOfe k s1 p) \/ (knowsOfs k ss p)
end.
(* need this second k to change.... *)

(** Prove knowsOfe is decidable. This means, for any enviornment [e]
   either the current place [p] is aware of place [p] or it's not.  *)

Theorem knowsOfe_dec:forall k e p, {(knowsOfe k e p)}+{~(knowsOfe k e p)}.
Proof.
  intros k e p.
  unfold knowsOfe.
  destruct (e k); auto.
  + induction (K m).
  ++ auto.
  ++ assert (H: {p = a} + {p <> a}). {repeat decide equality. }
     inversion H.
  +++ simpl. left. auto.
  +++ simpl. inverts IHl; auto. right. unfold not. intros. inverts H2; auto.
Defined.

(** decidability of knowsOfs. For any system [s], either [k] knows
   of [p] within the system or they do not. *)

Theorem knowsOfs_dec:forall k s p, {(knowsOfs k s p)}+{~(knowsOfs k s p)}.
Proof.
    intros k s p.
    induction s; simpl in *.
    + right. unfold not. intros. inversion H.
    + pose proof knowsOfe_dec k a p. inverts H.
    ++ left. left. apply H0.
    ++ inverts IHs.
    +++ left. right. apply H.
    +++ right. unfold not. intros. inversion H1; auto.
Defined.

(** Determine if place [k] within the environment [e]
    depends on place [p] (the context relation) *)
Definition dependsOne (k:Plc)(e:Environment)(p:Plc):Prop :=
match (e k) with
| None => False
| Some m => In p m.(C)
end.

(** Determine if place [k] within the system [s] depends on place [p] (the context relation) *)

Fixpoint dependsOns (k:Plc)(s:System)(p:Plc):Prop :=
match s with
| [] => False
| s1 :: ss => (dependsOne k s1 p) \/ (dependsOns k ss p)
end.

(** decidability of dependsOne. For any enviornment [e], either the AM at place
   [k] depends on something at place [p] or it does not. *)

Theorem dependsOne_dec : forall k e p, {(dependsOne k e p)}+{~(dependsOne k e p)}.
Proof.
  intros k e p.
  unfold dependsOne.
  destruct (e k).
  +  induction (C m).
  ++ auto.
  ++ simpl. inversion IHl.
  +++  auto.
  +++ assert (H': {a = p } + { a <> p}). {repeat decide equality. } inversion H'.
  ++++ left. left. apply H0.
  ++++ right. unfold not. intros. inversion H1; auto.
  + auto.
Defined.

(** decidability of dependsOns. For any system [s], either the AM at place [k] depends on something at place [p] or it does not. *)

Theorem dependsOns_dec : forall k s p, {dependsOns k s p} + {~ dependsOns k s p}.
Proof.
  intros. induction s.
  + simpl. auto.
  + simpl. pose proof dependsOne_dec k a p. inversion IHs.
  ++ left. right. apply H0.
  ++ inversion H.
  +++ left. left. apply H1.
  +++ right. unfold not. intros. inversion H2; auto.
Defined.

(** ***************************
    * EXECUTABILITY
*****************************)

(** Is term [t] exectuable on the attestation manager named [k] in
    environment [e]?  Are ASPs available at the right attesation managers
    and are necessary communications allowed? *)

Fixpoint executable(t:Term)(k:Plc)(e:Environment):Prop :=
match t with
| asp a  => hasASPe k e a
| att p t => knowsOfe k e p -> executable t p e
| lseq t1 t2 => executable t1 k e /\ executable t2 k e
| bseq _ t1 t2 => executable t1 k e /\ executable t2 k e
| bpar _ t1 t2 => executable t1 k e /\ executable t2 k e
end.

(* Ltac right_dest_contr H := right; unfold not; intros H; destruct H; contradiction.
Ltac right_dest_inverts := right; unfold not; intros H; inverts H. *)

(** executability of a term is decidable *)

Theorem executable_dec:forall t k e,{(executable t k e)}+{~(executable t k e)}.
intros.  generalize k. induction t; intros.
+ unfold executable. apply hasASPe_dec.
+ simpl. pose proof knowsOfe_dec k0 e p. destruct H.
++ destruct (IHt p).
+++ left; auto.
+++ right. unfold not. intros; auto.
++ destruct (IHt p).
+++ left; auto.
+++ left. intros. congruence.
+ simpl. specialize IHt1 with k0. specialize IHt2 with k0.
  destruct IHt1,IHt2; try right_dest_contr H.
++ left. split ; assumption.
+ simpl. specialize IHt1 with k0. specialize IHt2 with k0. destruct IHt1,IHt2; try right_dest_contr H.
++ left. split ; assumption.
+ simpl. specialize IHt1 with k0. specialize IHt2 with k0. destruct IHt1,IHt2; try right_dest_contr H.
++  left. split ; assumption.
Defined.

(** Is term [t] executable on the attestation mnanager named [k] in
  system [s]?  Are ASPs available at the right attestation managers
  and are necessary communications allowed? *)
Fixpoint executables(t:Term)(k:Plc)(s:System):Prop :=
  match t with
  | asp a  => hasASPs k s a
  | att p t => knowsOfs k s p -> executables t p s
  | lseq t1 t2 => executables t1 k s /\ executables t2 k s
  | bseq _ t1 t2 => executables t1 k s /\ executables t2 k s
  | bpar _ t1 t2 => executables t1 k s /\ executables t2 k s
end.

Ltac prove_exec :=
    match goal with
    | |- {executables (asp _) _ _} + {_} => unfold executables; apply hasASPs_dec
    | IHt1 : _ , IHt2 : _ |- {executables _ ?k ?s} + {_} => simpl; specialize IHt1 with k s; specialize IHt2 with k s; destruct IHt1,IHt2 ; try( left; split ; assumption)
    end.

Theorem executables_dec : forall t k s, {executables t k s} + {~executables t k s}.
Proof.
intros.  generalize k s. induction t; intros; try prove_exec; try right_dest_contr H.
+ simpl. destruct (IHt p s0).
++ auto.
++ pose proof knowsOfs_dec k0 s0 p. destruct H.
+++ right. unfold not; intros. intuition.
+++ left. intros. congruence.
Defined.

(******************************
*        POLICY
*******************************)

(** Check environment [e] and see if place [p] has some policy
 *  where the Policy allows p to run a. *)
Definition checkASPPolicy(p:Plc)(e:Environment)(a:ASP):Prop :=
match (e p) with (* Look for p in the environment *)
| None => False
| Some m => (Policy m a p) (* Policy from m allows p to run a *)
end.

(** Recursive policy check. *)
Fixpoint checkTermPolicy(t:Term)(k:Plc)(e:Environment):Prop :=
  match t with
  | asp a  => checkASPPolicy k e a
  | att r t0 => checkTermPolicy t0 k e
  | lseq t1 t2 => checkTermPolicy t1 k e /\ checkTermPolicy t2 k e
  | bseq _ t1 t2 => checkTermPolicy t1 k e /\ checkTermPolicy t2 k e
  | bpar _ t1 t2 => checkTermPolicy t1 k e /\ checkTermPolicy t2 k e
  end.

(** Proving policy check is decidable.
  * This is true if ASP policy is decidable. *)
Theorem checkTermPolicy_dec:forall t k e,
    (forall p0 a0, {(checkASPPolicy p0 e a0)} + {~(checkASPPolicy p0 e a0)}) ->
    {(checkTermPolicy t k e)}+{~(checkTermPolicy t k e)}.
Proof.
  intros t k e.
  intros H.
  induction t.
  + simpl. apply H.
  + simpl. assumption.
  + simpl; destruct IHt1,IHt2.
  ++ left. split; assumption.
  ++ right_dest_contr H'.
  ++ right_dest_contr H'.
  ++ right_dest_contr H'.
  + simpl; destruct IHt1,IHt2.
  ++ left. split; assumption.
  ++ right_dest_contr H'.
  ++ right_dest_contr H'.
  ++ right_dest_contr H'.
  + simpl; destruct IHt1,IHt2.
  ++ left. split; assumption.
  ++ right_dest_contr H'.
  ++ right_dest_contr H'.
  ++ right_dest_contr H'.
Defined.

(** ***************************
 * SOUND
 *****************************)

(** Soundness is executability and policy adherence *)

Definition sound (t:Term)(k:Plc)(e:Environment) :=
  (executable t k e) /\ (checkTermPolicy t k e).

(** Prove soundness is decidable with the assumption necessary for policy
 * adherence decidability.
 *)

 Theorem sound_dec: forall t p e,
 (forall p0 a0, {(checkASPPolicy p0 e a0)} + {~(checkASPPolicy p0 e a0)})
 -> {sound t p e}+{~(sound t p e)}.
Proof.
  intros t p e.
  intros H.
  unfold sound.
  assert ({executable t p e}+{~(executable t p e)}). apply executable_dec.
  assert ({checkTermPolicy t p e}+{~(checkTermPolicy t p e)}). { apply checkTermPolicy_dec. intros. apply H. }
  destruct H0,H1.
  + left. split; assumption.
  + right_dest_contr H'.
  + right_dest_contr H'.
  + right_dest_contr H'.
Defined.

(** ***************************
 * EXAMPLE SYSTEM
 *****************************)

(** Motivated by the Flexible Mechanisms for Remote Attestation,
 * we have three present parties in this attestation scheme.
 * These are used for example purposes.
 *)

Notation P0 := "P0"%string.
Notation P1 := "P1"%string.
Notation P2 := "P2"%string.

(** Introducing three asps for testing purposes. *)
Notation aVC :=
  (ASPC ALL EXTD (asp_paramsC "aVC"%string ["x"%string] P1 P1)).
Notation aHSH :=
  (ASPC ALL EXTD (asp_paramsC "aHSH"%string ["x"%string] P1 P1)).
Notation aSFS :=
  (ASPC ALL EXTD (asp_paramsC "aSFS"%string ["x"%string] P2 P2)).

(** Below are relational definitions of Policy. Within the definition, we
 * list each ASP on the AM and state who can recieve a measurement of said
 * ASP (ie doesn't expose sensitive information in the context).
 *
 * The relying party (P0) has no measurement to write policy over.
 * P1 can share the measurement aHSH and aVC with P0
 * P2 can share a measurement using aSFS with P1
*)

Inductive tar_Policy : ASP -> Plc -> Prop :=
| p_aHSH : tar_Policy aHSH P2
| p_SIG : forall p, tar_Policy SIG p.

Inductive P0_Policy : ASP -> Plc -> Prop :=.

Inductive P1_Policy : ASP -> Plc -> Prop :=
| aVC_p: P1_Policy aVC P0
| aHSH_p: P1_Policy aHSH P0.

Inductive P2_Policy : ASP -> Plc -> Prop :=
| aSFS_pL: P2_Policy aSFS P1.

Global Hint Constructors P0_Policy : core.
Global Hint Constructors P1_Policy : core.
Global Hint Constructors P2_Policy : core.

(** Definition of environments for use in examples and proofs.
 * Note there are 3 communicating peer's present...
 * P0, P1, and P2.
 *)

Definition e0 := e_empty.
Definition e_P0 :=
    e_update e_empty P0 (Some {| asps := []; K:= [P1] ; C := [] ; Policy := P0_Policy |}).
Definition e_P1 :=
    e_update e_P0 P1 (Some {| asps := [aVC;  aHSH]; K:= [P2] ; C := [] ; Policy := P1_Policy|}).
Definition e_P2 :=
    e_update e_P1 P2 (Some {| asps := [aSFS] ; K:= [] ; C := [P1] ; Policy := P2_Policy |}).

(** In our example, the system includes the relying party, the target,
 * and the appraiser
 *)

Definition example_sys_1 := [e_P0; e_P1; e_P2].

(** ***************************
  * EXAMPLE SYSTEM PROPERTIES
  *****************************)

(** Prove the P0 knows of P1 in P0's enviornment *)

Example ex1: knowsOfe P0 e_P0 P1.
Proof. unfold knowsOfe. simpl. left. reflexivity. Qed.

(** relying party does not have the ASP aVC *)

Example ex2: hasASPe P0 e_P0 aVC -> False.
Proof. unfold hasASPe. simpl. intros. inverts H. Qed.

(** Prove the P1 can generate a term with aHSH within the system *)

Example ex3: hasASPs P1 (example_sys_1) aVC.
Proof. simpl. unfold hasASPe. simpl. auto. Qed.

(** the P0 knows of the target within system 1
 *)

Example ex4: knowsOfs P0 example_sys_1 P1.
Proof.
unfold knowsOfs. simpl. left. unfold knowsOfe. simpl.  auto.
Qed.

(** the P0 does not directly know of the appraiser
 *)

Example ex5: knowsOfe P0 e_P2 P2 -> False.
Proof.
  unfold knowsOfe. simpl. intros. destruct H. inversion H. assumption.
Qed.

(** the P0 does not knows of the P2 within the system...
 * should be that P0 knows of P1 and P1
 * knows of P2....
 *)

Example ex6: knowsOfs P0 example_sys_1 P2 -> False.
Proof.
unfold knowsOfs. simpl. unfold knowsOfe. simpl. intros. inverts H. inverts H0. inverts H. apply H. inverts H0. destruct H. inverts H. apply H. destruct H. inverts H. inverts H0. apply H0. apply H.
Qed.

(** if the P0 was it's own system, it would still be aware of
 *  P1 *)

Example ex7: knowsOfs P0 [e_P0] P1.
Proof.
unfold knowsOfs,knowsOfe. simpl. auto.
Qed.

(** Proof tactic for executability
 *)
Ltac prove_exec' :=
    simpl; auto; match goal with
                 | |- hasASPe _ _ _ => cbv; left; reflexivity
                 | |- knowsOfe _ _ _ => unfold knowsOfe; simpl; left; reflexivity
                 | |- _ /\ _ => split; prove_exec'
                 | |- ?A => idtac A
                 end.

(** Is asp aVC executable on the P1 in the P1s's
 * enviornement?
 *)

Example ex8: (executable (asp aVC) P1 e_P1).
Proof. prove_exec'. Qed.

(** aSFS is not executable on P1 even if in P2's environment
 *)

Example ex9: (executable (asp aSFS) P1 e_P2) -> False.
Proof.
  intros Hcontra; cbv in *; destruct Hcontra. inverts H. destruct H. inverts H. apply H.
Qed.

(** two aHSH operations are executable on the P1
 *)

Example ex10: (executable (lseq (asp aHSH) (asp aHSH)) P1 e_P1).
Proof. prove_exec'; cbv; auto. Qed.

(** the relying party can ask the target to run aVC and signature
 * operations within system 1
 *)

Example ex11: (executables (lseq (asp aVC) (att P1 (lseq (asp aHSH) (asp aHSH)))) P1 example_sys_1).
Proof.
  prove_exec'; cbv; auto. intros. split; auto.
Qed.

(* A few decidability proofs... useful later*)
Theorem string_dec: forall (s s':string), {s=s'}+{s<>s'}.
Proof.
  intros s s'.
  repeat decide equality.
Defined.

Theorem plc_dec: forall (p p':Plc),{p=p'}+{p<>p'}.
Proof.
  intros p p'.
  apply string_dec.
Defined.

(** A proof that [tar_Policy] is decidable.  If we can show all policies are
* decidable, life is good.  This is a start.
*)
Theorem tar_Policy_dec: forall (asp:ASP)(plc:Plc), {(tar_Policy asp plc)}+{~(tar_Policy asp plc)}.
Proof.
  intros asp.
  intros plc.
  destruct asp.
  + right_dest_inverts.
  + right_dest_inverts.
  + pose proof ASP_dec (ASPC s f a) aHSH.
    pose proof plc_dec plc P2.
    destruct H; destruct H0.
  ++ subst. left. rewrite e. apply p_aHSH.
  ++ right. rewrite e. unfold not in *. intros Hneg. apply n. inversion Hneg. reflexivity.
  ++ right. unfold not in *. intros Hneg. apply n. inversion Hneg. reflexivity.
  ++ right. unfold not in *. intros Hneg. apply n. inversion Hneg. reflexivity.
  + left. apply p_SIG.
  + right_dest_inverts.
Defined.

(* Policy P0 is decidable *)
Theorem P0_Policy_dec: forall (asp:ASP)(plc:Plc), {(P0_Policy asp plc)}+{~(P0_Policy asp plc)}.
Proof.
  intros asp; intros plc; destruct asp; right_dest_inverts.
Defined.

(* Policy P1 is decidable *)
Theorem P1_Policy_dec: forall (asp:ASP)(plc:Plc), {(P1_Policy asp plc)}+{~(P1_Policy asp plc)}.
  intros asp.
  intros plc.
  destruct asp.
  + right_dest_inverts.
  + right_dest_inverts.
  + pose proof ASP_dec (ASPC s f a) aHSH.
    pose proof ASP_dec (ASPC s f a) aVC.
    pose proof plc_dec plc P0.
    destruct H; destruct H0; destruct H1; subst.
  ++ rewrite e in e1. inversion e1.
  ++ rewrite e in e1. inversion e1.
  ++ rewrite e. auto.
  ++ right_dest_inverts. contradiction. contradiction.
  ++ rewrite e. left. auto.
  ++ right_dest_inverts; contradiction.
  ++ right_dest_inverts; contradiction.
  ++ right_dest_inverts; contradiction.
  + right_dest_inverts.
  + right_dest_inverts.
Defined.

(* Policy P2 is decidable *)
Theorem P2_Policy_dec: forall (asp:ASP)(plc:Plc), {(P2_Policy asp plc)}+{~(P2_Policy asp plc)}.
Proof.
  intros asp.
  intros plc.
  destruct asp.
  + right_dest_inverts.
  + right_dest_inverts.
  + pose proof ASP_dec (ASPC s f a) aSFS.
    pose proof plc_dec plc P1.
    destruct H,H0.
  ++ left. subst. rewrite e. auto.
  ++ right_dest_inverts; contradiction.
  ++ right_dest_inverts; contradiction.
  ++ right_dest_inverts; contradiction.
  + right_dest_inverts.
  + right_dest_inverts.
Defined.

Ltac map_update_eq := unfold e_P2; apply e_update_reduce; unfold not; intros Hneg; rewrite Hneg in *; contradiction.

(* With Policy, we can now prove the system (e_P2) is sound. *)
Theorem sound_local_policies: (forall p0 a0, {(checkASPPolicy p0 e_P2 a0)} + {~(checkASPPolicy p0 e_P2 a0)}).
Proof.
  intros p a.
  pose proof plc_dec p P0.
  pose proof plc_dec p P1.
  pose proof plc_dec p P2.
  destruct H, H0, H1.
  + rewrite e in e1. inversion e1.
  + rewrite e in e1. inversion e1.
  + rewrite e in e1. inversion e1.
  + rewrite e. unfold checkASPPolicy. simpl. apply P0_Policy_dec.
  + rewrite e in e1. inversion e1.
  + rewrite e. unfold checkASPPolicy. simpl. apply P1_Policy_dec.
  + rewrite e. unfold checkASPPolicy. simpl. apply P2_Policy_dec.
  + right. unfold checkASPPolicy.
   assert (H: e_P2 p = e_P1 p). { map_update_eq. }
   assert (H0: e_P1 p = e_P0 p). { map_update_eq. }
   assert (H1: e_P0 p = e_empty p). { map_update_eq. }
   unfold not. intros Hneg. rewrite <- H in *. rewrite <- H0 in *. rewrite H1 in *. auto.
Defined.

(* Proof that the system described by e_P2 is sound. *)
Theorem sound_system_dec: forall t p, {sound t p e_P2}+{~(sound t p e_P2)}.
Proof.
  intros t p.
  apply sound_dec.
  intros p0 a0.
  apply sound_local_policies.
Defined.

Compute sound_system_dec (asp aHSH) P1.
Compute sound_system_dec (asp aSFS) P2.

End Manifest.

(* END OF FILE *)


From ITree Require Import ITree.
From compcert Require Import Maps AST Values Memory Globalenvs Ctypes.
From compcert Require Coqlib Clight Clightdefs.
From Paco Require Import paco.

Require Import Arith ZArith Bool.
Require Import String List Lia.

Require Import sflib.
Require Import Axioms StdlibExt IntegersExt ITreeTac.

Require Import SysSem.
Require Import IPModel DiscreteTimeModel IntByteModel.
Require Import OSModel OSNodes.
Require Import ProgSem CProgEventSem.
Require Import ProgSim CProgSimLemmas.
Require Import RTSysEnv MWITree.

(* Require Import SystemParams. *)
(* Require Import SystemDefs ITreeSpec. *)
(* Require Import SystemEventSem. *)
Require Import config_prm main_prm SystemProgs.
Require Import ctrl.
Require Import VerifProgBase.
Require Import VerifMainUtil.
Require Import PALSSystem.

Require Import AcStSystem.
Require Import LinkController.
Require Import SpecController.
Require Import VerifController_Base.

Import Clight Clightdefs.
Import ITreeNotations.
Import ActiveStandby.

Import CtrlState.

Set Nested Proofs Allowed.
(* Arguments app : simpl nomatch. *)
Local Transparent Archi.ptr64.
Local Opaque Z.of_nat Z.to_nat.

(* Arguments Nat.mul: simpl never. *)
Arguments Nat.mul: simpl never.

Opaque globalenv.

Local Open Scope Z.

Fixpoint adv_qidx_n (n: nat) (i:Z): Z :=
  match n with
  | O => i
  | S n' => adv_qidx (adv_qidx_n n' i)
  end.

Lemma range_adv_qidx_n_prec
  : forall n i
      (RANGE_I: 0 <= i < 4),
    0 <= adv_qidx_n n i < 4.
Proof.
  i. destruct n; ss.
  apply range_qrange_sanitize_prec.
Qed.

Section VERIF_FUNC.
  Variable tid: nat.
  Variable cprog: Clight.program.
  Variable r: nat -> itree progE unit -> Clight.state -> Prop.

  Hypothesis CTRL_TASK_ID: (tid = 1 \/ tid = 2)%nat.
  (* Hypothesis CPROG_EQ: __guard__ (cprog = prog_ctrl (Z.of_nat tid)). *)
  (* Notation prog := (prog_of_clight (prog_ctrl (Z.of_nat tid))). *)
  Notation prog := (prog_of_clight cprog).
  Notation ge := (globalenv cprog).

  Hypothesis GENV_PROPS
    : genv_props ge
                 (main_gvar_ilist tid ++ ctrl_gvar_ilist)
                 (main_gfun_ilist ++ ctrl_gfun_ilist)
                 (main_cenv_ilist ++ ctrl_cenv_ilist).

  Local Opaque idx_qs idx_aqi.
  Definition idx_addq: nat := idx_qs + (idx_aqi + 30) * 3 + 30.

  (* Ltac step_fptr_tac := *)
  (*   match goal with *)
  (*   | |- context [Evar ?fid] => *)
  (*     hexploit (in_gfun_ilist fid); [sIn|]; []; *)
  (*     i; des; *)
  (*     econs; [ss| eval_comput | eval_comput | eauto | ss] *)
  (*   end. *)

  Inductive addq_linv
            (itr0: itree progE unit) (m0: mem)
            b_cst id_dev md tout qb qe q
            (i: nat) (itr: itree progE unit)
            (le: PTree.t val) (m: mem): Prop :=
    AddqLoopInv
      st csr
      v_d1 v_d2 v_d3
      (ITR_INVAR: itr = itr0)
      (MEM_INVAR: m = m0)
      (STATE: st = mk md tout qb qe q)
      (RES_EQ: try_add_queue st id_dev =
               try_add_queue_loop st id_dev (3 - i) csr)
      (* (CURSOR: csr = qrange_sanitize (qb + Z.of_nat i)) *)
      (CURSOR: csr = adv_qidx_n i (qrange_sanitize qb))
      (* qrange_sanitize (qb + Z.of_nat i)) *)
      (LENV_EQUIV:
         lenv_equiv le
                    [(_id_dev, Vint (Int.repr id_dev));
                    (_st, Vptr b_cst Ptrofs.zero);
                    (_qb, Vint (Int.repr qb));
                    (_qe, Vint (Int.repr qe));
                    (_q, Vptr b_cst (Ptrofs.repr 4));
                    (_csr, Vint (Int.repr csr));
                    (_i, Vint (Int.repr (Z.of_nat i)));
                    (_tid, v_d1); (_t'3, v_d2); (_t'2, v_d3);
                    (_t'1, Vint (Int.repr (qrange_sanitize qb)))])
  .

  Lemma sim_try_add_queue
        (itr: itree progE unit)
        (m: mem) (k: cont) (idx_ret: nat)
        st id_dev b_cst
        (CALL_CONT: is_call_cont k)
        (WF_ST: CtrlState.wf st)
        (MEM_CST: mem_cst_blk m st b_cst)
        (* (MEM_MSTORE: Mem_inbox m b_mst ofs_inb inb) *)
        (* (RANGE_OFS_HB: 0 <= ofs_inb <= Ptrofs.max_unsigned) *)
        (RANGE_ID_DEV: IntRange.sintz8 id_dev)
        (SIM_RET:
           forall m' st'
             (ST': st' = try_add_queue st id_dev)
             (MEM_CST: mem_cst_blk m' st' b_cst)
             (MEM_CH_BLK: mem_changed_block b_cst m m')
           ,
           paco3 (_sim_itree prog) r
                 idx_ret itr
                 (Returnstate Vundef k m'))
    : paco3 (_sim_itree prog) r
            (idx_ret + idx_addq)%nat itr
            (Callstate (Internal f_try_add_queue)
                       [Vptr b_cst Ptrofs.zero;
                       Vint (Int.repr id_dev)] k m).
  Proof.
    unfold idx_addq.
    start_func.
    { econs. }
    ss.

    fw. clear STEP_ENTRY.
    fw.
    destruct st as [md tout qb qe q].
    fw.
    { econs.
      eval_comput.
      rewrite Ptrofs.add_zero_l.
      repr_tac. s.
      erewrite Mem.loadbytes_load; cycle 1.
      { s. apply MEM_CST. }
      { ss. solve_divide. }
      rewrite decode_val_signed_byte. s.
      rewrite sign_ext_byte_range.
      2: { apply Byte.signed_range. }
      rewrite Byte.signed_repr.
      2: { inv WF_ST. ss. }
      reflexivity.
    }
    upd_lenv.
    fw. fw. fw.
    { econs. eval_comput.
      repr_tac. s.
      rewrite Ptrofs.add_zero_l.
      repr_tac.
      erewrite Mem.loadbytes_load; cycle 1.
      { s. apply MEM_CST. }
      { ss. solve_divide. }
      rewrite decode_val_signed_byte. s.
      rewrite sign_ext_byte_range.
      2: { apply Byte.signed_range. }
      rewrite Byte.signed_repr.
      2: { inv WF_ST. ss. }
      reflexivity.
    }
    upd_lenv.
    fw. fw. fw.
    { econs. eval_comput.
      rewrite Ptrofs.add_zero_l.
      repr_tac. s. reflexivity.
    }
    upd_lenv.

    fw. fw. fw. fw.
    { step_fptr_tac. }

    red_idx (idx_ret + 3 * (idx_aqi + 30) + 15 + idx_qs)%nat.
    eapply sim_qrange_sanitize.
    { ss. }
    { inv WF_ST. range_stac. }

    fw. upd_lenv.
    fw. fw.
    { econs. eval_comput.
      rewrite sign_ext_byte_range.
      2: { apply range_qrange_sanitize. }
      reflexivity.
    }
    upd_lenv.

    fw. fw. fw.
    { econs. eval_comput. reflexivity. }
    upd_lenv.
    fw.

    eapply simple_for_loop
      with
        (i_max := 3%nat) (idx_each := (idx_aqi + 30)%nat)
        (idx0 := (idx_ret + 5)%nat)
        (loop_inv := addq_linv itr m b_cst id_dev
                               md tout qb qe q).
    { econs; eauto. ss. }
    { range_stac. }
    { nia. }
    { (* loop body *)
      clear le LENV_EQUIV.
      i. inv LINV.

      pose (cursor := adv_qidx_n i (qrange_sanitize qb)).
      fold cursor in LENV_EQUIV, RES_EQ.

      fw. fw. fw.
      { econs.
        - eval_comput.
          repr_tac.
          replace 3 with (Z.of_nat 3) by ss.
          rewrite <- Nat2Z_inj_ltb.
          destruct (Nat.ltb_spec i 3); ss.
          exfalso. nia.
        - ss.
      }
      rewrite Int.eq_false by ss. s.

      assert (CURSOR_SMALL: 0 <= cursor < 4).
      { apply range_adv_qidx_n_prec.
        apply range_qrange_sanitize_prec. }
      assert (BYTE_4_AUX: 4 < Byte.max_signed) by ss.

      assert (ADV_QIDX_SMALL: (0 <= adv_qidx cursor < 4)).
      { apply range_adv_qidx_prec. }

      fw. fw. fw.
      { econs.
        - eval_comput.
          rewrite Int_eq_repr_signed; cycle 1.
          { range_stac. }
          { inv WF_ST. range_stac. }
          reflexivity.
        - rewrite bool_val_of_bool.
          reflexivity.
      }

      replace (3 - i)%nat with (S (3 - (S i))) in RES_EQ by nia.
      simpl in RES_EQ.

      destruct (Z.eqb_spec cursor qe) as [CEQ|CNE]; ss.
      { (* reached end_of_queue *)
        guardH CEQ.
        fw.

        assert (STORE_BYTE: exists m',
                   Mem.store
                     Mint8signed m b_cst (4 + cursor)
                     (Vint (Int.repr id_dev)) = Some m').
        { apply inhabited_sig_to_exists.
          econs.
          apply Mem.valid_access_store.
          rr. split; ss.
          2: { apply Z.divide_1_l. }
          ii. apply MEM_CST. nia. }
        des.

        fw.
        { econs.
          - eval_comput.
            repr_tac.
            rewrite Z.mul_1_l. reflexivity.
          - eval_comput.
            reflexivity.
          - ss.
          - eval_comput.
            repr_tac.
            rewrite sign_ext_byte_range by ss.
            eauto.
        }
        fw. fw. fw. fw.
        { step_fptr_tac. }

        red_idx (idx1 - idx_aqi - 15 + idx_aqi)%nat.
        eapply sim_adv_qidx; eauto.
        { eapply GENV_PROPS. }
        { ss. }
        { range_stac. }
        fw. upd_lenv.

        assert (STORE_F:
                  exists m_f, Mem.store Mint8signed
                                   m' b_cst 3 (Vint (Int.repr (adv_qidx cursor))) = Some m_f).
        { apply inhabited_sig_to_exists.
          econs.
          apply Mem.valid_access_store.
          rr. split; ss.
          2: { apply Z.divide_1_l. }
          ii.
          eapply Mem.perm_store_1; eauto.
          apply MEM_CST. nia. }
        des.

        fw. fw.
        { econs.
          - eval_comput.
            repr_tac. s.
            rewrite Ptrofs.add_zero_l.
            reflexivity.
          - eval_comput. reflexivity.
          - ss.
          - eval_comput.
            rewrite sign_ext_byte_range by range_stac.
            repr_tac.
            eauto.
        }
        fw. fw. fw. fw.

        assert (MEM_UNCH_TOT:
                  mem_unchanged_except
                    (fun b ofs => b = b_cst /\
                               (ofs = 3 \/ 4 <= ofs < 8))
                    m m_f).
        { eapply Mem.unchanged_on_trans.
          - eapply Mem.store_unchanged_on; eauto.
            s. ii. des. nia.
          - eapply Mem.store_unchanged_on; eauto.
            s. ii. des. nia.
        }

        red_idx idx_ret.
        eapply SIM_RET; eauto.
        - rewrite RES_EQ.
          inv MEM_CST.
          econs; ss.
          + erewrite Mem.loadbytes_unchanged_on; eauto.
            s. nia.
          + erewrite Mem.loadbytes_unchanged_on; eauto.
            s. nia.
          + erewrite Mem.loadbytes_unchanged_on; eauto.
            s. nia.
          + apply Mem.loadbytes_store_same in STORE_F. ss.
            rewrite STORE_F.
            unfold encode_int. ss.
            rewrite rev_if_be_single. ss.
            rewrite Int.unsigned_repr by range_stac.
            reflexivity.
          + eapply Mem.loadbytes_unchanged_on.
            { eapply store_unchanged_on'; eauto. }
            { i. unfold mem_range. ss. nia. }

            eapply (set_queue_mem cursor id_dev); eauto.
          + ii.
            eapply Mem.perm_store_1; eauto.
            eapply Mem.perm_store_1; eauto.
        - eapply Mem.unchanged_on_implies; eauto.
          s. ii. des; ss.
      }

      (* not reached the end yet *)
      fw. fw.

      assert (NCSR: exists ncsr, Z.of_nat ncsr = cursor).
      { exists (Z.to_nat cursor). nia. }
      des.

      hexploit (nth_error_Some2 _ q ncsr).
      { inv WF_ST. nia. }
      i. des. renames e1 NTH_EX into q_c Q_C.

      assert (RANGE_Q_C: IntRange.sintz8 q_c).
      { inv WF_ST.
        rewrite Forall_forall in RANGE_QUEUE.
        apply RANGE_QUEUE.
        eapply nth_error_In; eauto. }

      fw.
      { econs. eval_comput.
        repr_tac.
        rewrite Z.mul_1_l.

        erewrite Mem.loadbytes_load; cycle 1.
        { s.
          erewrite loadbytes_nth_error; eauto.
          - eapply mem_cst_q; eauto.
          - s. apply map_nth_error_iff.
            esplits; eauto.
        }
        { s. solve_divide. }
        { rewrite decode_val_signed_byte.
          rewrite Byte.signed_repr by ss.
          rewrite sign_ext_byte_range by ss.
          reflexivity. }
      }
      upd_lenv.
      fw. fw. fw.
      { econs.
        - eval_comput.
          rewrite Int_eq_repr_signed by range_stac.
          reflexivity.
        - rewrite bool_val_of_bool. reflexivity.
      }

      unfold get_queue in RES_EQ.
      erewrite nth_error_nth in RES_EQ.
      2: { rewrite <- NCSR.
           rewrite Nat2Z.id. eauto. }

      destruct (Z.eqb_spec q_c id_dev) as [EQ_CUR | NEQ_CUR].
      { (* id_dev already in queue *)
        guardH EQ_CUR.
        fw. fw. fw.

        red_idx idx_ret.
        eapply SIM_RET; eauto.
        - rewrite RES_EQ. ss.
        - apply Mem.unchanged_on_refl.
      }

      fw. fw. fw.
      { step_fptr_tac. }

      red_idx (idx1 - idx_aqi - 15 + idx_aqi)%nat.
      eapply sim_adv_qidx.
      { apply GENV_PROPS. }
      { ss. }
      { range_stac. }
      fw. upd_lenv.
      fw. fw.
      { econs. eval_comput.
        rewrite sign_ext_byte_range by range_stac.
        reflexivity. }
      upd_lenv.

      fw.
      { econs. eauto. }
      repeat (rewrite <- Nat.add_assoc; ss).
      fw.
      { econs. eval_comput.
        repr_tac.
        replace (Z.of_nat i + 1) with (Z.of_nat (S i)) by nia.
        reflexivity. }
      fw. upd_lenv.

      red_idx (idx1 - (idx_aqi + 30))%nat.
      eapply SIM_NEXT.
      econs; eauto.
    }

    clear le LENV_EQUIV.
    i. inv LINV_END.
    fw. fw. fw.
    { econs.
      - eval_comput.
        repr_tac.
        replace (Z.of_nat 3) with 3 by ss.
        rewrite Z.ltb_irrefl. ss.
      - ss.
    }

    rewrite Int.eq_true by ss. s.
    fw. fw.
    red_idx (idx_ret + 1)%nat.
    fw.

    red_idx idx_ret.
    eapply SIM_RET; eauto.
    - rewrite RES_EQ. ss.
    - apply Mem.unchanged_on_refl.
  Qed.

  Definition idx_rel: nat := idx_qs + 50.

  Lemma sim_try_release
        (itr: itree progE unit)
        (m: mem) (k: cont) (idx_ret: nat)
        st id_dev b_cst
        (CALL_CONT: is_call_cont k)
        (WF_ST: CtrlState.wf st)
        (MEM_CST: mem_cst_blk m st b_cst)
        (RANGE_ID_DEV: IntRange.sintz8 id_dev)
        (* (MEM_MSTORE: Mem_inbox m b_mst ofs_inb inb) *)
        (* (RANGE_OFS_HB: 0 <= ofs_inb <= Ptrofs.max_unsigned) *)
        (SIM_RET:
           forall m' st'
             (ST': st' = try_release st id_dev)
             (MEM_CST: mem_cst_blk m' st' b_cst)
             (MEM_CH_BLK: mem_changed_block b_cst m m')
           ,
           paco3 (_sim_itree prog) r
                 idx_ret itr
                 (Returnstate Vundef k m'))
    : paco3 (_sim_itree prog) r
            (idx_ret + idx_rel)%nat itr
            (Callstate (Internal f_try_release)
                       [Vptr b_cst Ptrofs.zero;
                       Vint (Int.repr id_dev)] k m).
  Proof.
    unfold idx_rel.
    start_func.
    { econs. }
    ss.

    fw. clear STEP_ENTRY.
    fw.
    destruct st as [md tout qb qe q].
    fw.
    { econs.
      eval_comput.
      rewrite Ptrofs.add_zero_l.
      repr_tac. s.
      erewrite Mem.loadbytes_load; cycle 1.
      { s. apply MEM_CST. }
      { ss. solve_divide. }
      rewrite decode_val_signed_byte. s.
      rewrite sign_ext_byte_range.
      2: { apply Byte.signed_range. }
      rewrite Byte.signed_repr.
      2: { inv WF_ST. ss. }
      reflexivity.
    }
    upd_lenv.
    fw. fw. fw.
    { econs. eval_comput.
      repr_tac. s.
      rewrite Ptrofs.add_zero_l.
      repr_tac.
      erewrite Mem.loadbytes_load; cycle 1.
      { s. apply MEM_CST. }
      { ss. solve_divide. }
      rewrite decode_val_signed_byte. s.
      rewrite sign_ext_byte_range.
      2: { apply Byte.signed_range. }
      rewrite Byte.signed_repr.
      2: { inv WF_ST. ss. }
      reflexivity.
    }
    upd_lenv.
    fw. fw. fw.
    { econs. eval_comput.
      repr_tac. s.
      rewrite Ptrofs.add_zero_l.
      repr_tac.
      erewrite Mem.loadbytes_load; cycle 1.
      { s. apply MEM_CST. }
      { ss. solve_divide. }
      rewrite decode_val_signed_byte. s.
      rewrite sign_ext_byte_range.
      2: { apply Byte.signed_range. }
      rewrite Byte.signed_repr.
      2: { inv WF_ST. ss. }
      reflexivity.
    }
    upd_lenv.

    fw. fw. fw.
    { econs. eval_comput.
      rewrite Ptrofs.add_zero_l.
      repr_tac. s. reflexivity.
    }
    upd_lenv.

    fw. fw. fw.
    { econs.
      - eval_comput.
        inv WF_ST.
        rewrite Int_eq_repr_signed by range_stac.
        reflexivity.
      - rewrite bool_val_of_bool. reflexivity.
    }

    destruct (Z.eqb_spec qb qe).
    { s.
      (* destruct (Z.ltb_spec 0 tout). *)
      (* 2: { (* do nothing *) *)
      fw.
      { econs. eval_comput. reflexivity. }
      upd_lenv.
      fw. fw.
      { econs.
        - eval_comput. reflexivity.
        - ss. }
      rewrite Int.eq_true by ss. s.
      fw.

      red_idx idx_ret.
      eapply SIM_RET; eauto.
      apply Mem.unchanged_on_refl.
    }

    s.
    fw. fw.
    { step_fptr_tac. }

    red_idx (idx_ret + 20 + idx_qs)%nat.
    eapply sim_qrange_sanitize.
    { ss. }
    { inv WF_ST. range_stac. }

    fw. upd_lenv.
    fw.

    generalize (range_qrange_sanitize_prec qb).
    intros RANGE_QS_QB.
    assert (BMAX_AUX_4: 4 < Byte.max_signed) by ss.

    hexploit (nth_error_Some2 _ q (Z.to_nat (qrange_sanitize qb))).
    { inv WF_ST. nia. }
    intros (q_n & Q_N).

    assert (RANGE_Q_N: IntRange.sintz8 q_n).
    { inv WF_ST.
      rewrite Forall_forall in RANGE_QUEUE.
      apply RANGE_QUEUE.
      eapply nth_error_In; eauto. }

    fw.
    { econs. eval_comput.
      repr_tac.
      rewrite Z.mul_1_l.

      erewrite Mem.loadbytes_load; cycle 1.
      { s.
        erewrite loadbytes_nth_error; eauto.
        { apply MEM_CST. }
        { apply map_nth_error. s. eauto. }
        rewrite Z2Nat.id by nia.
        ss.
      }
      { s. solve_divide. }
      s.
      rewrite decode_byte.
      rewrite sign_ext_byte_range_u by ss.
      rewrite Int_eq_repr_signed; cycle 1.
      { range_stac. }
      { range_stac. }
      instantiate (1:= if (q_n =? id_dev) then Vtrue else Vfalse).
      destruct (Z.eqb_spec q_n id_dev); ss.
    }

    upd_lenv.
    fw.

    unfold get_queue in SIM_RET.
    erewrite nth_error_nth in SIM_RET.
    2: { eauto. }

    destruct (Z.eqb_spec q_n id_dev).
    2: { (* do nothing *)
      fw.
      { econs.
        - eval_comput. ss.
        - ss.
      }
      rewrite Int.eq_true by ss. s.
      fw.

      red_idx idx_ret.
      eapply SIM_RET; eauto.
      apply Mem.unchanged_on_refl.
    }

    (* update timeout *)
    fw.
    { econs.
      - eval_comput. reflexivity.
      - ss. }
    rewrite Int.eq_false by ss. s.

    assert (STORE_F:
              exists m_f, Mem.store Mint8signed
                               m b_cst 1 (Vint (Int.repr 1)) = Some m_f).
    { apply inhabited_sig_to_exists.
      econs.
      apply Mem.valid_access_store.
      rr. split; ss.
      2: { apply Z.divide_1_l. }
      ii. apply MEM_CST. nia. }
    des.

    fw. fw.
    { econs.
      - eval_comput.
        repr_tac0; cycle 1.
        { range_stac. }
        { inv WF_ST. range_stac. }
        reflexivity.
      - s. rewrite bool_val_of_bool.
        reflexivity.
    }

    destruct (Z.ltb_spec 0 tout).
    2: {
      fw.
      { econs. eval_comput. reflexivity. }
      upd_lenv.

      fw. fw.
      { econs.
        - eval_comput. reflexivity.
        - ss.
      }
      rewrite Int.eq_true. s.

      fw.
      red_idx idx_ret.
      eapply SIM_RET; eauto.
      apply Mem.unchanged_on_refl.
    }

    destruct (Z.ltb_spec tout MAX_TIMEOUT).
    2: {
      ss.
      fw.
      { econs. eval_comput.
        inv WF_ST.
        repr_tac.
        fold MAX_TIMEOUT.
        instantiate (1:= Vfalse).
        destruct (Z.ltb_spec tout MAX_TIMEOUT); ss.
        exfalso. nia.
      }
      fw. upd_lenv.
      fw.
      { econs.
        - eval_comput. ss.
        - ss.
      }
      rewrite Int.eq_true. s.
      fw.
      red_idx idx_ret.
      eapply SIM_RET; eauto.
      apply Mem.unchanged_on_refl.
    }

    fw.
    { econs. eval_comput.
      inv WF_ST.
      repr_tac.
      fold MAX_TIMEOUT.
      destruct (Z.ltb_spec tout MAX_TIMEOUT); ss.
      exfalso. nia.
    }
    rewrite Int.eq_false by ss.
    upd_lenv.

    fw. fw.
    { econs.
      - eval_comput. ss.
      - ss.
    }
    rewrite Int.eq_false by ss. s.

    fw.
    { econs.
      - eval_comput.
        repr_tac. s.
        rewrite Ptrofs.add_zero_l. ss.
      - eval_comput. ss.
      - s. ss.
      - eval_comput.
        rewrite sign_ext_byte_range by ss.
        repr_tac. eauto.
    }

    fw.
    red_idx idx_ret.
    eapply SIM_RET; eauto.
    - inv MEM_CST.
      hexploit store_unchanged_on'; eauto. i.

      econs; ss.
      + eapply Mem.loadbytes_unchanged_on; eauto.
        unfold mem_range. ii. nia.
      + apply Mem.loadbytes_store_same in STORE_F. ss.
      + eapply Mem.loadbytes_unchanged_on; eauto.
        unfold mem_range. ii. nia.
      + eapply Mem.loadbytes_unchanged_on; eauto.
        unfold mem_range. ii. nia.
      + eapply Mem.loadbytes_unchanged_on; eauto.
        unfold mem_range. ii. nia.
      + ii. eapply Mem.perm_store_1; eauto.
    - eapply Mem.store_unchanged_on; eauto.
  Qed.

  Definition idx_appdev: nat := idx_addq + idx_rel + 20.

  Lemma sim_apply_devmsg
        (itr: itree progE unit)
        (m: mem) (k: cont) (idx_ret: nat)
        st id_dev ment
        b_cst b_mst ofs_inb
        (BLOCKS_DIFF: b_cst <> b_mst)
        (CALL_CONT: is_call_cont k)
        (WF_ST: CtrlState.wf st)
        (MEM_CST: mem_cst_blk m st b_cst)
        (MEM_MSTORE: Mem_msg_entry m b_mst ofs_inb id_dev ment)
        (ID_DEV_UBND: (id_dev < num_tasks)%nat)
        (RANGE_OFS_INB: 0 <= ofs_inb <= 4 + inb_sz)
        (* (RANGE_OFS_HB: 0 <= ofs_inb + Z.of_nat (mentry_nsz * id_dev) <= Ptrofs.max_unsigned) *)
        (SIM_RET:
           forall m' st'
             (ST': st' = apply_devmsg st (Z.of_nat id_dev) ment)
             (MEM_CST: mem_cst_blk m' st' b_cst)
             (MEM_CH_BLK: mem_changed_block b_cst m m')
           ,
           paco3 (_sim_itree prog) r
                 idx_ret itr
                 (Returnstate Vundef k m'))
    : paco3 (_sim_itree prog) r
            (idx_ret + idx_appdev)%nat itr
            (Callstate (Internal f_apply_devmsg)
                       [ Vptr b_cst Ptrofs.zero;
                       Vint (IntNat.of_nat id_dev);
                       Vptr b_mst (Ptrofs.repr (ofs_inb + Z.of_nat (mentry_nsz * id_dev)))] k m).
  Proof.
    unfold idx_appdev.

    start_func.
    { econs. }
    ss.

    hexploit (in_cenv_ilist _msg_entry_t); [sIn|].
    intros CO_MENTRY.

    hexploit Mem_msg_entry_inv2; eauto. i. des.

    generalize (within_inb_nsz2 id_dev); eauto.
    intro RANGE_MENTRY_AUX.
    pose proof ptr_range_mstore as PRANGE_MSTORE.
    replace (Z.of_nat (4 + inb_nsz + inb_nsz)) with
        (4 + inb_sz + inb_sz) in PRANGE_MSTORE by ss.

    fw. fw.
    { hexploit (RANGE_MENTRY_AUX O); eauto.
      { nia. }
      rewrite Nat.add_0_r. intro AUX.
      clear RANGE_MENTRY_AUX.

      econs.
      - eval_comput.
        rewrite CO_MENTRY. s.
        unfold align_attr. s.
        unfold Coqlib.align. s.
        repr_tac.
        rewrite Z.add_0_r.
        rewrite MENT_RCV.
        instantiate (1:= if ment then Vtrue else Vfalse).
        destruct ment; ss.
      - instantiate (1:= if ment then true else false).
        destruct ment; ss.
    }

    destruct ment as [msg_dev|].
    2: { (* do nothing *)
      fw.
      red_idx idx_ret.
      eapply SIM_RET; eauto.
      apply Mem.unchanged_on_refl.
    }

    hexploit MENT_CONT; eauto.
    clear MENT_CONT. intro MENT_CONT.

    hexploit Mem.loadbytes_length; eauto.
    rewrite Nat2Z.id.
    intro LEN_INJ_MSG.

    destruct msg_dev as [| mdev_h mdev_t]; ss.

    replace (Z.of_nat 8) with (1 + 7) in MENT_CONT by ss.
    eapply Mem_loadbytes_split' with (n1:= 1) in MENT_CONT; try nia.
    rewrite rw_cons_app in MENT_CONT.
    replace (Z.to_nat 1) with 1%nat in MENT_CONT by ss.
    rewrite firstn_app_exact in MENT_CONT by ss.
    rewrite skipn_app_exact in MENT_CONT by ss.
    des.

    fw. fw.
    { econs.
      eval_comput.
      instantiate (1:= Vint (Int.repr (Byte.signed mdev_h))).

      rewrite CO_MENTRY. s.
      unfold align_attr. s.
      unfold Coqlib.align. s.

      hexploit (RANGE_MENTRY_AUX O); eauto.
      { nia. }
      rewrite Nat.add_0_r. intro AUX0.
      hexploit (RANGE_MENTRY_AUX 1%nat); eauto.
      { unfold mentry_nsz. nia. }
      intro AUX1.

      repr_tac.
      erewrite Mem.loadbytes_load; cycle 1.
      { s. rewrite Z.add_0_r.
        apply MENT_CONT. }
      { s. solve_divide. }
      s.
      rewrite decode_byte.
      rewrite <- (Byte.repr_signed mdev_h).
      rewrite sign_ext_byte_range_u.
      2: { apply Byte.signed_range. }
      rewrite sign_ext_byte_range.
      2: { apply Byte.signed_range. }
      rewrite Byte.signed_repr.
      2: { apply Byte.signed_range. }
      ss.
    }
    upd_lenv.

    fw. fw.
    { econs.
      - eval_comput.
        rewrite Int_eq_repr_signed; cycle 1.
        { generalize (Byte.signed_range mdev_h).
          range_stac. }
        { range_stac. }
        reflexivity.
      - rewrite bool_val_of_bool. reflexivity.
    }

    destruct (Z.eqb_spec (Byte.signed mdev_h) 1).
    - fw.
      { step_fptr_tac. }

      red_idx (idx_ret + 10 + idx_addq)%nat.
      unfold IntNat.of_nat.

      assert (RANGE_ID_DEV: IntRange.sintz8 (Z.of_nat id_dev)).
      { pose proof range_num_tasks as RANGE_NT.
        range_stac. }

      rewrite sign_ext_byte_range by range_stac.
      eapply sim_try_add_queue; eauto.
      { ss. }

      clear MEM_CST. i.
      fw. fw.

      red_idx idx_ret.
      eapply SIM_RET; eauto.
    - fw.
      { step_fptr_tac. }

      red_idx (idx_ret + 10 + idx_rel)%nat.
      unfold IntNat.of_nat.

      assert (RANGE_ID_DEV: IntRange.sintz8 (Z.of_nat id_dev)).
      { pose proof range_num_tasks as RANGE_NT.
        range_stac. }

      rewrite sign_ext_byte_range by range_stac.
      eapply sim_try_release; eauto.
      { ss. }

      clear MEM_CST. i.
      fw. fw.

      red_idx idx_ret.
      eapply SIM_RET; eauto.
  Qed.

  Definition idx_redto: nat := idx_aqi + 50.

  Lemma sim_reduce_timeout
        (itr: itree progE unit)
        (m: mem) (k: cont) (idx_ret: nat)
        st b_cst
        (CALL_CONT: is_call_cont k)
        (WF_ST: CtrlState.wf st)
        (MEM_CST: mem_cst_blk m st b_cst)
        (SIM_RET:
           forall m' st'
             (ST': st' = reduce_timeout st)
             (MEM_CST: mem_cst_blk m' st' b_cst)
             (MEM_CH_BLK: mem_changed_block b_cst m m')
           ,
           paco3 (_sim_itree prog) r
                 idx_ret itr
                 (Returnstate Vundef k m'))
    : paco3 (_sim_itree prog) r
            (idx_ret + idx_redto)%nat itr
            (Callstate (Internal f_reduce_timeout)
                       [Vptr b_cst Ptrofs.zero] k m).
  Proof.
    unfold idx_redto.
    start_func.
    { econs. }
    ss.

    fw. clear STEP_ENTRY.
    fw.
    destruct st as [md tout qb qe q].
    fw.
    { econs.
      eval_comput.
      rewrite Ptrofs.add_zero_l.
      repr_tac. s.
      erewrite Mem.loadbytes_load; cycle 1.
      { s. apply MEM_CST. }
      { ss. solve_divide. }
      rewrite decode_val_signed_byte. s.
      rewrite sign_ext_byte_range.
      2: { apply Byte.signed_range. }
      rewrite Byte.signed_repr.
      2: { inv WF_ST. ss. }
      reflexivity.
    }
    upd_lenv.
    fw. fw. fw.
    { econs. eval_comput.
      repr_tac. s.
      rewrite Ptrofs.add_zero_l.
      repr_tac.
      erewrite Mem.loadbytes_load; cycle 1.
      { s. apply MEM_CST. }
      { ss. solve_divide. }
      rewrite decode_val_signed_byte. s.
      rewrite sign_ext_byte_range.
      2: { apply Byte.signed_range. }
      rewrite Byte.signed_repr.
      2: { inv WF_ST. ss. }
      reflexivity.
    }
    upd_lenv.

    fw. fw.
    { econs.
      - eval_comput.
        rewrite Int_eq_repr_signed; cycle 1.
        { inv WF_ST. range_stac. }
        { range_stac. }
        ss.
      - rewrite bool_val_of_bool. reflexivity.
    }
    destruct (Z.eqb_spec tout 1).
    { (* tout = 1 *)
      fw.

      assert (STORE1: exists m1,
                 Mem.store Mint8signed m b_cst 1
                           (Vint (Int.repr 0)) = Some m1).
      { apply inhabited_sig_to_exists.
        econs.
        apply Mem.valid_access_store.
        rr. split; ss.
        2: { apply Z.divide_1_l. }
        ii. apply MEM_CST. nia. }
      des.

      fw.
      { econs.
        - eval_comput.
          repr_tac. s.
          rewrite Ptrofs.add_zero_l. reflexivity.
        - eval_comput. ss.
        - s. ss.
        - eval_comput.
          rewrite sign_ext_byte_range.
          2: { range_stac. }
          repr_tac.
          eauto.
      }

      fw. fw. fw.
      { step_fptr_tac. }

      red_idx (idx_ret + 30 + idx_aqi)%nat.
      eapply sim_adv_qidx; eauto.
      { apply GENV_PROPS. }
      { ss. }
      { inv WF_ST. range_stac. }
      fw. upd_lenv.

      fw.

      assert (STORE2: exists m2,
                 Mem.store Mint8signed m1 b_cst 2
                           (Vint (Int.repr (adv_qidx qb))) = Some m2).
      { apply inhabited_sig_to_exists.
        econs.
        apply Mem.valid_access_store.
        rr. split; ss.
        2: { apply Z.divide_1_l. }
        ii. eapply Mem.perm_store_1; eauto.
        apply MEM_CST. nia. }
      des.

      fw.
      { econs.
        - eval_comput.
          repr_tac. s.
          rewrite Ptrofs.add_zero_l. reflexivity.
        - eval_comput. reflexivity.
        - ss.
        - eval_comput.
          rewrite sign_ext_byte_range.
          2: { apply range_adv_qidx. }
          repr_tac.
          eauto.
      }

      fw.
      red_idx idx_ret.

      assert (MEM_UNCH: mem_unchanged_except
                          (fun b ofs => b = b_cst /\
                                     (ofs = 1 \/ ofs = 2))
                          m m2).
      { eapply Mem.unchanged_on_trans with (m2:= m1).
        - eapply Mem.store_unchanged_on; eauto.
          s. ii. nia.
        - eapply Mem.store_unchanged_on; eauto.
          s. ii. nia. }

      eapply SIM_RET; eauto.
      - inv MEM_CST.
        econs; ss.
        + eapply Mem.loadbytes_unchanged_on; eauto.
          s. ii. nia.
        + eapply Mem.loadbytes_unchanged_on.
          { eapply store_unchanged_on'; eauto. }
          { unfold mem_range. s. i. nia. }
          eapply Mem.loadbytes_store_same in STORE1. ss.
        + eapply Mem.loadbytes_store_same in STORE2. ss.
          rewrite STORE2.
          unfold encode_int. s.
          rewrite rev_if_be_single.
          unfold inj_bytes. s.
          do 3 f_equal.
          symmetry.
          apply signed_byte_int_unsigned_repr_eq.
        + eapply Mem.loadbytes_unchanged_on; eauto.
          s. ii. nia.
        + eapply Mem.loadbytes_unchanged_on; eauto.
          s. ii. nia.
        + ii. eapply Mem.perm_store_1; eauto.
          eapply Mem.perm_store_1; eauto.
      - eapply Mem.unchanged_on_implies; eauto.
        ii. des; ss.
    }

    fw.
    { econs.
      - eval_comput.
        inv WF_ST.
        repr_tac. ss.
      - rewrite bool_val_of_bool. ss.
    }

    destruct (Z.ltb_spec 1 tout).
    { (* 1 < tout *)

      assert (STORE1: exists m1,
                 Mem.store Mint8signed m b_cst 1
                           (Vint (Int.repr (tout - 1))) = Some m1).
      { apply inhabited_sig_to_exists.
        econs.
        apply Mem.valid_access_store.
        rr. split; ss.
        2: { apply Z.divide_1_l. }
        ii. apply MEM_CST. nia. }
      des.

      fw.
      { econs.
        - eval_comput.
          repr_tac. s.
          rewrite Ptrofs.add_zero_l. reflexivity.
        - eval_comput. ss.
        - s. ss.
        - eval_comput.
          inv WF_ST.
          repr_tac.
          rewrite sign_ext_byte_range.
          2: { range_stac. }
          eauto.
      }

      fw.
      red_idx idx_ret.

      hexploit store_unchanged_on'; eauto.
      s. unfold mem_range. intro MEM_UNCH.

      eapply SIM_RET; eauto.
      - inv MEM_CST.
        econs; ss.
        + eapply Mem.loadbytes_unchanged_on; eauto.
          s. ii. nia.
        + eapply Mem.loadbytes_store_same in STORE1.
          ss. rewrite STORE1.
          unfold encode_int. s.
          rewrite rev_if_be_single.
          unfold inj_bytes. s.
          do 3 f_equal.
          symmetry.
          apply signed_byte_int_unsigned_repr_eq.
        + eapply Mem.loadbytes_unchanged_on; eauto.
          s. ii. nia.
        + eapply Mem.loadbytes_unchanged_on; eauto.
          s. ii. nia.
        + eapply Mem.loadbytes_unchanged_on; eauto.
          s. ii. nia.
        + ii. eapply Mem.perm_store_1; eauto.
      - eapply Mem.unchanged_on_implies; eauto.
        ii. des; ss.
    }

    (* do nothing *)
    fw.
    red_idx idx_ret.
    eapply SIM_RET; eauto.
    eapply Mem.unchanged_on_refl.
  Qed.

  Local Opaque idx_appdev idx_redto.
  Definition idx_updq: nat := (idx_appdev + 20) * 3 + idx_redto + 20.

  Inductive updq_linv
            (itr0: itree progE unit) (m0: mem)
            st inb b_cst b_mst ofs_inb
            (* md tout qb qe q *)
            (i: nat) (itr: itree progE unit)
            (le: PTree.t val) (m: mem): Prop :=
    UpdqLoopInv
      st1 v_d1 v_d2
      (ITR_INVAR: itr = itr0)
      (* (MEM_INVAR: m = m0) *)
      (WF_ST1: wf st1)
      (MEM_CST: mem_cst_blk m st1 b_cst)
      (MEM_CH_BLK: mem_changed_block b_cst m0 m)
      (RES_EQ: update_queue st inb =
               reduce_timeout (update_queue_loop
                                 inb (imap (fun n _ => Z.of_nat n) (3 + i) (repeat tt (3 - i))) st1))
      (LENV_EQUIV:
         lenv_equiv le
                    [(_inbox, Vptr b_mst (Ptrofs.repr ofs_inb));
                    (_st, Vptr b_cst Ptrofs.zero);
                    (_devmsg, v_d1);
                    (_i, Vint (IntNat.of_nat i)); (_id_dev, v_d2)])
  .

  Lemma sim_update_queue
        (itr: itree progE unit)
        (m: mem) (k: cont) (idx_ret: nat)
        st inb
        b_cst b_mst ofs_inb
        (BLOCKS_DIFF: b_cst <> b_mst)
        (CALL_CONT: is_call_cont k)
        (WF_ST: CtrlState.wf st)
        (MEM_CST: mem_cst_blk m st b_cst)
        (MEM_INB: Mem_inbox m b_mst ofs_inb inb)
        (RANGE_OFS_HB: 0 <= ofs_inb <= 4 + inb_sz)
        (SIM_RET:
           forall m' st'
             (ST': st' = update_queue st inb)
             (MEM_CST: mem_cst_blk m' st' b_cst)
             (MEM_CH_BLK: mem_changed_block b_cst m m')
           ,
           paco3 (_sim_itree prog) r
                 idx_ret itr
                 (Returnstate Vundef k m'))
    : paco3 (_sim_itree prog) r
            (idx_ret + idx_updq)%nat itr
            (Callstate (Internal f_update_queue)
                       [Vptr b_cst Ptrofs.zero;
                       Vptr b_mst (Ptrofs.repr ofs_inb)] k m).
  Proof.
    unfold idx_updq.
    start_func.
    { econs. }
    ss.

    fw. fw. fw. fw.
    { econs. eval_comput. ss. }
    upd_lenv.

    fw.

    hexploit (in_cenv_ilist _inbox_t); [sIn|].
    intros CO_INBOX.
    hexploit (in_cenv_ilist _msg_entry_t); [sIn|].
    intros CO_MENTRY.

    assert (BYTE_RANGE_AUX: 6 < Byte.max_signed) by ss.

    eapply simple_for_loop with
        (i_max := 3%nat) (idx_each := (idx_appdev + 20)%nat)
        (idx0 := 0%nat)
        (loop_inv := updq_linv itr m st inb
                               b_cst b_mst ofs_inb).
    { econs; eauto.
      eapply Mem.unchanged_on_refl. }
    { range_stac. }
    { nia. }
    { (* loop body *)
      clear le LENV_EQUIV MEM_CST.
      i. inv LINV.

      fw. fw. fw.
      { econs.
        - eval_comput. repr_tac.
          replace 3 with (Z.of_nat 3) by ss.
          rewrite <- Nat2Z_inj_ltb.
          destruct (Nat.ltb_spec i 3).
          2: { exfalso. nia. }
          reflexivity.
        - ss.
      }

      rewrite Int.eq_false by ss. s.
      fw. fw. fw.
      { econs. eval_comput.
        repr_tac.
        replace 3 with (Z.of_nat 3) by ss.
        rewrite <- Nat2Z.inj_add.
        rewrite sign_ext_byte_range.
        2: { range_stac. }
        reflexivity.
      }
      upd_lenv.

      fw. fw. fw.
      { econs.
        eval_comput.
        rewrite CO_INBOX. s.
        unfold align_attr. s.
        unfold Coqlib.align. s.
        change main_prm._msg_entry_t with _msg_entry_t.
        rewrite CO_MENTRY. s.
        rewrite Ptrofs.add_zero.

        repr_tac.

        pose proof (within_inb_nsz2 (3 + i)) as WITHIN_INB_AUX.
        pose proof ptr_range_mstore as PRANGE_MSTORE.

        hexploit (WITHIN_INB_AUX O).
        { unfold num_tasks. ss. nia. }
        { nia. }
        intro AUX_ZERO.

        repr_tac0; cycle 1.
        { nia. }
        { nia. }

        rewrite <- Nat2Z.inj_mul.
        reflexivity.
      }
      upd_lenv.

      fw. fw.
      { step_fptr_tac. }

      rewrite sign_ext_byte_range by range_stac.
      red_idx (idx1 - 15 - idx_appdev + idx_appdev)%nat.

      r in MEM_INB. des.
      hexploit (nth_error_Some2 _ inb (3 + i)).
      { rewrite NUM_ENTRIES.
        unfold num_tasks. ss. nia. }
      i. des. renames e1 NTH_EX into ment MENT.

      rewrite iForall_nth in MSG_ENTRIES.
      specialize (MSG_ENTRIES (3 + i)%nat).
      rewrite MENT in MSG_ENTRIES.
      rewrite Nat.add_comm in MENT. ss.

      eapply sim_apply_devmsg; eauto.
      { ss. }
      { eapply Mem_msg_entry_unch.
        { eauto. }
        eapply Mem.unchanged_on_implies.
        { eapply MEM_CH_BLK. }
        i. des. subst.
        clear - BLOCKS_DIFF.
        congruence.
      }
      { unfold num_tasks. ss. nia. }

      rename MEM_CH_BLK into MEM_CH_BLK1.
      clear MEM_CST. i.

      red_idx (idx1 - (idx_appdev + 15))%nat.
      fw. fw.
      { econs. eauto. }
      fw.
      { econs. eval_comput.
        repr_tac.
        replace 1 with (Z.of_nat 1) by ss.
        rewrite <- Nat2Z.inj_add.
        reflexivity.
      }
      upd_lenv.

      fw.
      red_idx (idx1 - (idx_appdev + 20))%nat.

      assert (WF_ST': wf st').
      { subst st'.
        apply wf_apply_devmsg; eauto.
        range_stac. }

      eapply SIM_NEXT.
      econs; eauto.
      - eapply Mem.unchanged_on_trans; eauto.
      - rewrite RES_EQ. s.
        replace (3 - i)%nat with (S (2 - i))%nat by nia.
        s. rewrite Nat2Z.id.
        erewrite nth_error_nth.
        2: { rewrite Nat.add_comm in MENT. ss. eauto. }
        rewrite <- ST'. reflexivity.
      - replace (Z.of_nat (i + 1)) with (Z.of_nat (S i)) in LENV_EQUIV by nia.
        eauto.
    }

    clear le LENV_EQUIV.
    clear MEM_CST.
    i. inv LINV_END.

    red_idx (idx_ret + idx_redto + 10)%nat.

    fw. fw. fw.
    { econs.
      - eval_comput.
        repr_tac.
        destruct (Z.ltb_spec (Z.of_nat 3) 3).
        { exfalso. nia. }
        reflexivity.
      - ss.
    }

    rewrite Int.eq_true by ss. s.
    fw. fw. fw. fw.
    { step_fptr_tac. }

    red_idx (idx_ret + 3 + idx_redto)%nat.
    eapply sim_reduce_timeout; eauto.
    { ss. }

    rename MEM_CH_BLK into MEM_CH_BLK_P.
    clear MEM_CST. i.

    fw. fw.
    red_idx idx_ret.

    assert (WF_ST': wf st').
    { subst st'.
      eapply wf_reduce_timeout. ss. }

    eapply SIM_RET; eauto.
    - rewrite <- ST' in RES_EQ.
      rewrite RES_EQ. ss.
    - eapply Mem.unchanged_on_trans; eauto.
  Qed.

End VERIF_FUNC.