Require Import List.
Require Import ZArith.
Require Import Lia.
Require Import FunctionalExtensionality.
Require Import Utils.
Require Import Lattices.
Require Import CLattices.
Require Import Instr.
Require Import AbstractCommon.
Require Import Rules.
Require Import AbstractMachine.
Require Import QuasiAbstractMachine.
Require Import Concrete.
Require Import ConcreteMachine.
Require Import ConcreteExecutions.
Require Import Determinism.
Require Import Refinement.
Require Import FaultRoutine.
Require Import Semantics.
Require Import Encodable.

Open Scope Z_scope.
Coercion Z_of_nat : nat >-> Z.

(** The Concrete Machine (with appropriate Fault Handler) refines the Abstract Machine. *)

Set Implicit Arguments.

(** * First refinement : from the abstract to the quasi-abstract machine *)
Section AbstractQuasiAbstract.

Context {T: Type}
        {Latt: JoinSemiLattice T}.

Lemma abstract_step_equiv : forall s e s',
                              step tini_quasi_abstract_machine s e s' <->
                              step abstract_machine s e s'.
Proof.
  intros.
  split; intro H; inv H;
  unfold QuasiAbstractMachine.ifc_run_tmr, apply_rule in *;
  simpl in *;
  repeat match goal with
           | H : Some _ = Some _ |- _ =>
             inv H
           | H : (if ?b then _ else _) = _ |- _ =>
             destruct b eqn:E; inv H
         end;
  unfold Vector.nth_order in *; simpl in *;
  try [> once (econstructor; solve [compute; eauto]) ..].

  econstructor; eauto.
  unfold QuasiAbstractMachine.ifc_run_tmr, apply_rule. simpl.
  unfold Vector.nth_order. simpl.
  rewrite CHECK. trivial.
Qed.

Program Definition abstract_quasi_abstract_sref :=
  @strong_refinement abstract_machine
                     tini_quasi_abstract_machine
                     eq eq _.
Next Obligation.
  exists a2. exists s22.
  repeat split; trivial.
  rewrite <- (abstract_step_equiv s21 a2 s22).
  auto.
  destruct a2; constructor; auto.
Qed.

Program Definition abstract_quasi_abstract_ref :=
  @refinement_from_state_refinement abstract_machine tini_quasi_abstract_machine
                                    abstract_quasi_abstract_sref eq
                                    _.

End AbstractQuasiAbstract.

(** * Second Refinement:
     from the quasi-abstract machine to the concrete machine *)

(** Matching relation between concrete and abstract values
    Generic in the rule table and fault handler *)
Section MatchAbstractConcrete.

Context {L: Type}
        {Latt: JoinSemiLattice L}
        {CLatt: ConcreteLattice L}
        {ELatt : Encodable L}
        {WFCLatt: WfConcreteLattice L Latt CLatt ELatt}.

Definition atom_labToZ (a:@Atom L) : (@Atom Z) :=
  let (v,l) := a in (v,labToZ l).

Definition atom_ZToLab (a:@Atom Z) : (@Atom L) :=
  let (v,l) := a in (v,ZToLab l).

Lemma atom_ZToLab_labToZ_id: forall (a:@Atom L), a = atom_ZToLab (atom_labToZ a).
Proof.
  intros. unfold atom_labToZ, atom_ZToLab. destruct a. f_equal.
  apply ZToLab_labToZ_id.
Qed.

Definition mem_labToZ (m: list (@Atom L)) : list (@Atom Z) :=
  map atom_labToZ m.

Definition mem_ZToLab (m: list (@Atom Z)) : list (@Atom L) :=
  map atom_ZToLab m.

Lemma mem_ZToLab_labToZ_id : forall (m: list (@Atom L)),
   m = mem_ZToLab (mem_labToZ m).
Proof.
  intros. unfold mem_ZToLab, mem_labToZ. rewrite map_map.
  replace (fun x => atom_ZToLab (atom_labToZ x)) with (@id (@Atom L)).
  rewrite map_id; auto.
  extensionality x.
  apply atom_ZToLab_labToZ_id.
Qed.

Lemma read_m_labToZ : forall m addrv xv xl,
 read_m addrv m = Some (xv, xl) ->
 read_m addrv (mem_labToZ m) = Some (xv, labToZ xl).
Proof.
  unfold read_m in *.
  destruct m ; intros.
  - case (addrv <? 0) in *. inv H.
    rewrite index_list_nil in H; inv H.
  - destruct addrv; simpl in *.
    + inv H. reflexivity.
    + edestruct (Pos2Nat.is_succ p0); eauto.
      rewrite H0 in *. simpl in *.
      unfold mem_labToZ. erewrite index_list_map; eauto.
      reflexivity.
    + inv H.
Qed.

Lemma read_m_labToZ' :
  forall i m xv xl,
    read_m i (mem_labToZ m) = Some (xv, xl) ->
    exists xl',
      read_m i m = Some (xv, xl') /\
      xl = labToZ xl'.
Proof.
  unfold index_list_Z.
  intros.
  destruct (i <? 0). inv H.
  gdep m.
  generalize (Z.to_nat i). clear i.
  intros i.
  induction i as [|i IH];
  intros m H;
  destruct m as [|[xv' xl'] m'];
  simpl in *; inv H; intuition.
  eexists. split; repeat f_equal.
Qed.

Lemma upd_m_labToZ : forall i xv xl m cm'
                            (UP : upd_m i (xv, labToZ xl) (mem_labToZ m) = Some cm'),
                       exists m',
                         upd_m i (xv, xl) m = Some m' /\
                         cm' = mem_labToZ m'.
Proof.
  intros i; unfold upd_m; intros.
  destruct (i <? 0). inv UP.
  gdep cm'. gdep m.
  generalize (Z.to_nat i). clear i.
  intros i.
  induction i as [|i IH];
  intros [| [xv' xl']] cm' UP; simpl in *; inv UP.
  repeat eexists.
  destruct (update_list i (xv, labToZ xl) (mem_labToZ l)) eqn:E; inv H0.
  guess tt IH.
  destruct IH. intuition.
  subst. eexists. rewrite H0.
  eauto.
Qed.

Inductive match_stacks : list (@StkElmt L) ->  list CStkElmt -> Prop :=
| ms_nil : match_stacks nil nil
| ms_cons_data: forall a ca s cs,
                  match_stacks s cs ->
                  ca = atom_labToZ a ->
                  match_stacks (AData a :: s) (CData ca :: cs)
| ms_cons_ret: forall a ca r s cs,
                  match_stacks s cs ->
                  ca = atom_labToZ a ->
                  match_stacks (ARet a r:: s) (CRet ca r false:: cs).
Hint Constructors match_stacks : core.

Lemma match_stacks_args :
  forall s args cs,
    match_stacks s (args ++ cs) ->
    exists args' s',
      s = args' ++ s' /\ match_stacks args' args /\ match_stacks s' cs.
Proof.
  intros s args. gdep s.
  induction args; intros.
  simpl in *. exists nil; exists s. split; auto.
  inv H;
    (exploit IHargs; eauto; intros [args' [cs' [Heq [Hmatch Hmatch']]]]);
    (inv Heq; (eexists; eexists; split; eauto ; try reflexivity)).
Qed.

Lemma match_stacks_length : forall s cs,
    match_stacks s cs ->
    length cs = length s.
Proof.
  induction 1; intros; (simpl; eauto).
Qed.

Lemma match_stacks_app : forall s cs s' cs',
    match_stacks s cs ->
    match_stacks s' cs' ->
    match_stacks (s++s') (cs++cs').
Proof.
  induction 1 ; intros; (simpl; eauto).
Qed.

Lemma match_stacks_data :
  forall s cs,
    match_stacks s cs ->
    (forall a : CStkElmt, In a cs -> exists d : Atom, a = CData d) ->
    (forall a : StkElmt, In a s -> exists d : Atom, a = AData d).
Proof.
  induction 1;  intros.
  - inv H0.
  - inv H2.  eauto.
    eapply IHmatch_stacks; eauto.
    intros; eapply H1; eauto.
    econstructor 2; eauto.
  - inv H2.
    eelim (H1 (CRet (atom_labToZ a) r false)); eauto. intros. inv H0.
    constructor; auto.
    eapply IHmatch_stacks; eauto.
    intros; eapply H1; eauto.
    econstructor 2; eauto.
Qed.

Lemma match_stacks_app_length : forall S CS,
    match_stacks S CS ->
    forall s s' cs cs',
    S = (s++s') ->
    CS = (cs++cs') ->
    length s = length cs ->
    match_stacks s cs
    /\ match_stacks s' cs'.
Proof.
  induction 1 ; intros; (simpl; eauto).
  - exploit app_eq_nil ; eauto. intros [Heq Heq']. inv Heq.
    exploit (app_eq_nil s) ; eauto. intros [Heq Heq']. inv Heq.
    split; eauto.
  - destruct s0 ; simpl in *. inv H1.
    destruct cs0 ; simpl in *. inv H2; split; eauto. congruence.
    inv H1. destruct cs0; simpl in *. congruence.
    inv H3.
    inv H2.
    exploit IHmatch_stacks; eauto.
    intros [Hmatch Hmatch']; split; eauto.
  - destruct s0 ; simpl in *. inv H1.
    destruct cs0 ; simpl in *. inv H2; split; eauto. congruence.
    inv H1. destruct cs0; simpl in *. congruence.
    inv H3.
    inv H2.
    exploit IHmatch_stacks; eauto.
    intros [Hmatch Hmatch']; split; eauto.
Qed.

Hint Constructors pop_to_return : core.

Lemma match_stacks_c_pop_to_return :
  forall astk cstk rpc rpcl b1 b2 cstk'
         (MATCH : match_stacks astk cstk)
         (POP : c_pop_to_return cstk (CRet (rpc, rpcl) b1 b2 :: cstk')),
    exists rpcl' astk',
      pop_to_return astk (ARet (rpc, rpcl') b1 :: astk') /\
      rpcl = labToZ rpcl' /\
      match_stacks astk' cstk'.
Proof.
  intros.
  gdep astk.
  match type of POP with
    | c_pop_to_return _ ?CSTK =>
      remember CSTK as cstk''
  end.
  induction POP; subst;
  intros astk MATCH; inv MATCH; try inv Heqcstk''; eauto;
  repeat match goal with
           | A : Atom |- _ => destruct A; simpl in *
           | H : (_, _) = (_, _) |- _ => inv H; simpl in *
         end;
  eauto.
  guess tt IHPOP.
  destruct IHPOP as [? [? [? [? ?]]]].
  subst. eauto 7.
Qed.
Hint Resolve match_stacks_c_pop_to_return : core.

(** Generic fault handler code *)
Variable fetch_rule_g : forall (o: OpCode), AllowModify (labelCount o).

Definition fetch_rule_impl : fetch_rule_impl_type :=
  fun o => existT _ (labelCount o) (fetch_rule_g o).

Definition LCL := LatticeConcreteLabels fetch_rule_impl.

Definition cache_up2date tmuc :=
  forall opcode vls pcl,
    cache_hit tmuc (opCodeToZ opcode) (labsToZs vls) (labToZ pcl) ->
    match apply_rule (fetch_rule_g opcode) pcl vls with
      | Some (rpcl,rl) => cache_hit_read tmuc (labToZ rl) (labToZ rpcl)
      | None => False
    end.

Definition cache_up2date_weak tmuc :=
  forall opcode vls pcl rl rpcl,
  forall (RULE: apply_rule (fetch_rule_g opcode) pcl vls = Some (rpcl, rl)),
  forall (CHIT: cache_hit tmuc (opCodeToZ opcode) (labsToZs vls) (labToZ pcl)),
         cache_hit_read tmuc (labToZ rl) (labToZ rpcl).

Lemma cache_up2date_success :
  forall tmuc, cache_up2date tmuc -> cache_up2date_weak tmuc.
Proof.
  unfold cache_up2date, cache_up2date_weak.
  intros.
  specialize (H opcode vls pcl CHIT).
  rewrite RULE in H.
  trivial.
Qed.

Definition faultHandler := @FaultRoutine.faultHandler L ELatt labelCount
                                                      (ifc_run_tmr fetch_rule_g)
                                                      LCL.

Inductive match_states : @AS L -> CS -> Prop :=
 ms: forall am cm i astk tmuc cstk apc cpc
              (CACHE: cache_up2date tmuc)
              (STKS: match_stacks astk cstk)
              (MEM: cm = mem_labToZ am)
              (PC: cpc = atom_labToZ apc),
         match_states (AState am i astk apc)
                      (CState tmuc cm faultHandler i cstk cpc false).

Lemma opCodeToZ_inj: forall o1 o2, opCodeToZ o1 = opCodeToZ o2 -> o1 = o2.
Proof.
  intros o1 o2 Heq.
  destruct o1, o2; inv Heq; try congruence.
Qed.

Lemma labsToZs_cons_hd: forall n0 a v0 b v3,
  S n0 <= 3 ->
  labsToZs (Vector.cons L a n0 v0) = labsToZs (Vector.cons L b n0 v3) ->
  a = b.
Proof.
  intros.  inv H0.
  unfold nth_labToZ in H2. destruct (le_lt_dec (S n0) 0).  inv l.
  unfold Vector.nth_order in H2. simpl in H2.
  apply labToZ_inj in H2.  auto.
Qed.

Lemma nth_labToZ_cons:
  forall nth n a v,
    nth_labToZ (Vector.cons L a n v) (S nth) = nth_labToZ v nth.
Proof.
  induction n; intros.
  - unfold nth_labToZ.
    case_eq (le_lt_dec (S nth) 1); case_eq (le_lt_dec nth 0); intros; auto;
    try (zify ; lia).
  - unfold nth_labToZ.
    case_eq (le_lt_dec (S (S n)) (S nth)); case_eq (le_lt_dec (S n) nth); intros; auto;
    try (zify ; lia).
    unfold Vector.nth_order. simpl. symmetry.
    erewrite of_nat_lt_proof_irrel ; eauto.
Qed.

Lemma labsToZs_cons_tail:
  forall n0 a v0 b v3,
    (n0 <= 2)%nat ->
    labsToZs (Vector.cons L a n0 v0) = labsToZs (Vector.cons L b n0 v3) ->
    labsToZs v0 = labsToZs v3.
Proof.
  intros. inv H0.
  unfold labsToZs.
  repeat (rewrite nth_labToZ_cons in H3). inv H3. clear H1.
  repeat (rewrite nth_labToZ_cons in H4). inv H4. clear H1.
  replace (nth_labToZ v0 2) with (nth_labToZ v3 2).
  auto.
  unfold nth_labToZ.
  case_eq (le_lt_dec n0 2); intros; auto.
  zify ; lia.
Qed.

Lemma labsToZs_inj: forall n (v1 v2: Vector.t L n), n <= 3 ->
     labsToZs v1 = labsToZs v2 -> v1 = v2.
Proof.
  intros n v1 v2.
  set (P:= fun n (v1 v2: Vector.t L n) => n <= 3 -> labsToZs v1 = labsToZs v2 -> v1 = v2) in *.
  eapply Vector.rect2 with (P0:= P); eauto.
  unfold P. auto.
  intros.
  unfold P in *. intros.
  exploit labsToZs_cons_hd; eauto. intros Heq ; inv Heq.
  eapply labsToZs_cons_tail in H1; eauto.
  exploit H ; eauto. zify; lia.
  intros Heq. inv Heq.
  reflexivity. zify ; lia.
Qed.

Definition abstract_action (ce : CEvent+τ) : (@Event L)+τ :=
  match ce with
    | E (CEInt ca) => E (EInt (atom_ZToLab ca))
    | Silent => Silent
  end.

Definition concretize_action (ae : (@Event L)+τ) : CEvent+τ :=
  match ae with
    | E (EInt aa) => E (CEInt (atom_labToZ aa))
    | Silent => Silent
  end.

Definition match_actions a1 a2 := concretize_action a1 = a2.

Lemma abstract_action_concretize_action :
  forall ae, abstract_action (concretize_action ae) = ae.
Proof.
  intros [[[xv xl]]|]; simpl; auto.
  rewrite <- ZToLab_labToZ_id.
  reflexivity.
Qed.

(** The refinement proof itself. Generic in the rule table used to generate the fault handler *)

Section RefQAC.

(* Reconstruct the quasi_abstract label vector *)
Ltac quasi_abstract_labels :=
  match goal with
    | L : Type,
      Latt : JoinSemiLattice ?L,
      H : context[cache_hit _ _ (dontCare, dontCare, dontCare) _] |- _ =>
      pose (vls := Vector.nil L)
    | H : context[cache_hit _ _ (labToZ ?l, dontCare, dontCare) _] |- _ =>
      pose (vls := Vector.cons _ l _ (Vector.nil _))
    | H : context[cache_hit _ _ (labToZ ?l1, labToZ ?l2, dontCare) _] |- _ =>
      pose (vls := Vector.cons _ l1 _ (Vector.cons _ l2 _ (Vector.nil _)))
    | H : context[cache_hit _ _ (labToZ ?l1, labToZ ?l2, labToZ ?l3) _] |- _ =>
      pose (vls := Vector.cons _ l1 _
                               (Vector.cons _ l2 _
                                            (Vector.cons _ l3 _ (Vector.nil _))))
  end.

(* Relate the results of a cache read to its arguments *)
Ltac analyze_cache_hit OP vls apcl:=
  match goal with
    | CACHE : cache_up2date _ |- _ =>
      let H := fresh "H" in
      generalize (@CACHE OP vls apcl);
      intros H; guess tt H;
      try match type of H with
        | context[ (apply_rule (fetch_rule_g ?r) ?aapcl ?vvls) ] =>
          destruct (apply_rule (fetch_rule_g r) aapcl vvls) as [[? ?]|] eqn:Happly ;
            [| inv H]
      end
  end;
  match goal with
    | H1 : cache_hit_read _ _ _,
      H2 : cache_hit_read _ _ _ |- _ =>
      let H := fresh "H" in
      generalize (cache_hit_read_determ H2 H1);
        intros H;
        destruct H;
        subst;
        clear H2
      end.

(** Cache hit case *)

Lemma cache_hit_simulation :
  forall s1 s2 e2 s2'
         (Hmatch : match_states s1 s2)
         (Hs2' : priv s2' = false)
         (Hstep : cstep s2 e2 s2'),
    exists a1 s1', step_rules (ifc_run_tmr fetch_rule_g) s1 a1 s1' /\
                   match_actions a1 e2 /\
                   match_states s1' s2'.
Proof.
  intros.
  inv Hmatch.
  unfold match_actions.
  destruct apc as [apc apcl].
  inv Hstep; simpl in *; try congruence;

  (* Invert some hypotheses *)
  repeat match goal with
           | H : ?x = ?x |- _ => clear H
           | H : match_stacks _ (_ ::: _) |- _ => inv H
           | H : match_stacks _ (_ ++ _) |- _ =>
             apply match_stacks_args' in H;
             destruct H as [? [? [? [? ?]]]];
             subst
           | a : _,
             H : (_, _) = atom_labToZ ?a |- _ =>
             destruct a; simpl in H; inv H
         end;

  (* For the Load/Store cases *)
  try_exploit read_m_labToZ';

  (* For the Ret cases *)
  try_exploit match_stacks_c_pop_to_return;

  quasi_abstract_labels;

  (* Find the current opcode *)
  match goal with
    | H : read_m _ _ = Some ?instr |- _ =>
      let opcode := (eval compute in (opcode_of_instr instr)) in
      match opcode with
        | Some ?opcode => pose (OP := opcode)
      end
  end;

  analyze_cache_hit OP vls apcl;

  subst OP vls;

  (* For the Store case *)
  try_exploit upd_m_labToZ;

  (* For the BranchNZ case *)
  try match goal with
        | |- context[if (?z =? 0) then _ else _ ] =>
          let H := fresh "H" in
          assert (H := Z.eqb_spec z 0);
          destruct (z =? 0);
          inv H
      end;

  try solve [
        eexists; eexists; split; try split;
        try [> once (econstructor; solve [compute; eauto]) ..];
        repeat (constructor; eauto); simpl; f_equal; intuition
      ].

  - exists Silent.
    exploit match_stacks_args; eauto. intros [args' [s' [Hargs' [Hmatchargs' Hmatchs']]]].
    subst. eexists. split.

    + eapply (step_call (ifc_run_tmr fetch_rule_g)); try solve [compute; eauto].
      * symmetry. eapply match_stacks_length; eauto.
      * eapply match_stacks_data; eauto.

    + repeat (constructor; eauto); simpl; f_equal; intuition.
      eauto using match_stacks_app.
Qed.

(** Cache miss case *)

Lemma invalid_pc_no_step :
  forall s1 e s2
         (STEP : cstep s1 e s2)
         (FAIL : fst (pc s1) < 0),
    False.
Proof.
  intros.
  inv STEP; simpl in *;
  unfold read_m in *;
  generalize (Z.ltb_spec0 pcv 0);
  let H := fresh "H" in
  intros H;
  destruct (pcv <? 0); inv H; intuition; congruence.
Qed.

Lemma kernel_run_success_fail_contra :
  forall s1 s21 s22
         (RUN1 : runsUntilUser s1 s21)
         (RUN2 : runsToEnd s1 s22)
         (FAIL : fst (pc s22) < 0),
    False.
Proof.
  intros.
  induction RUN1; inv RUN2;
  try match goal with
        | [ H1 : cstep ?s _ _,
            H2 : cstep ?s _ _
            |- _ ] =>
          let H := fresh "H" in
          generalize (cmach_determ H1 H2);
          intros [? ?]; subst
      end; eauto;
  try match goal with
        | [ H : runsUntilUser _ _ |- _ ] =>
          generalize (runsUntilUser_l H);
          intros
      end;
  try match goal with
        | [ H : runsToEnd _ _ |- _ ] =>
          generalize (runsToEnd_l H);
          intros
      end;
  try congruence;
  eauto using invalid_pc_no_step ; eauto.
Qed.

Lemma kernel_fail_determ :
  forall s1 s21 s22
         (RUN1 : runsToEnd s1 s21)
         (FAIL1 : fst (pc s21) < 0)
         (RUN2 : runsToEnd s1 s22)
         (FAIL2 : fst (pc s22) < 0),
    s21 = s22.
Proof.
  intros.
  induction RUN1; inv RUN2; trivial;
  try solve [exfalso; eauto using invalid_pc_no_step];
  try match goal with
        | [ H1 : cstep ?s _ _,
            H2 : cstep ?s _ _
            |- _ ] =>
          let H := fresh "H" in
          generalize (cmach_determ H1 H2);
          intros [? ?]; subst
      end; eauto.
Qed.

Lemma runsToEscape_determ :
  forall s1 s21 s22
         (RUN1 : runsToEscape s1 s21)
         (RUN2 : runsToEscape s1 s22),
    s21 = s22.
Proof.
  intros.
  inv RUN1; inv RUN2;
  eauto using runsUntilUser_determ,
              kernel_fail_determ;
  try solve [exfalso; eauto using kernel_run_success_fail_contra];
  try match goal with
        | [ H : runsUntilUser _ _ |- _ ] =>
          generalize (runsUntilUser_l H);
          intros
      end;
  try match goal with
        | [ H : runsToEnd _ _ |- _ ] =>
          generalize (runsToEnd_l H);
          intros
      end;
  try congruence.
Qed.

Lemma configuration_at_miss :
  forall s1 s21 e2 s22
         (MATCH : match_states s1 s21)
         (STEP : cstep s21 e2 s22)
         (PRIV : priv s22 = true),
    exists opcode (vls : Vector.t L (projT1 (fetch_rule_impl opcode))),
      cache_hit (cache s22) (opCodeToZ opcode)
                (labsToZs vls) (labToZ (snd (apc s1))) /\
      mem s22 = mem s21 /\
      fhdl s22 = fhdl s21 /\
      imem s22 = imem s21 /\
      stk s22 = CRet (pc s21) false false :: stk s21 /\
      pc s22 = (0, handlerTag).
Proof.
  intros.
  inv MATCH.
  inv STEP; simpl in *; try congruence;

  (* Invert some hypotheses *)
  repeat match goal with
           | H : true = false |- _ => inv H
           | H : ?x = ?x |- _ => clear H
           | H : match_stacks _ (_ ::: _) |- _ => inv H
           | H : match_stacks _ (_ ++ _) |- _ =>
             apply match_stacks_args' in H;
             destruct H as [? [? [? [? ?]]]];
             subst
           | a : _,
             H : (_, _) = atom_labToZ ?a |- _ =>
             destruct a; simpl in H; inv H
         end;

    (* For the Load case *)
  try_exploit read_m_labToZ';

  (* For the Ret cases *)
  try_exploit match_stacks_c_pop_to_return;

  try quasi_abstract_labels;

  match goal with
    | H : read_m _ _ = Some ?i |- _ =>
      let oc := eval compute in (opcode_of_instr i) in
      match oc with
        | Some ?oc => (exists oc)
      end
  end;

  exists vls; repeat econstructor;
  unfold update_cache;
  rewrite index_list_Z_update_list_list; eauto;
  compute; reflexivity.
Qed.

Lemma update_cache_spec_rvec_cache_hit :
  forall rpcl rl cache cache' op tags pc
         (MATCH : handler_final_mem_matches rpcl rl cache cache')
         (HIT : cache_hit cache op tags pc),
    cache_hit cache' op tags pc.
Proof.
  intros.
  inv HIT;
  repeat match goal with
           | H : tag_in_mem _ _ _ |- _ =>
             inv H
           | H : tag_in_mem' _ _ _ |- _ =>
             inv H
         end.
  destruct MATCH as [RES UP].
  destruct RES.
  econstructor; eauto; econstructor;
  try solve [rewrite <- UP; eauto; compute; lia];
  repeat match goal with
           | H : tag_in_mem _ _ _ |- _ =>
             inv H
           | H : tag_in_mem' _ _ _ |- _ =>
             inv H
         end;
  eauto.
Qed.

Lemma cache_hit_unique:
  forall c opcode opcode' labs labs' pcl pcl',
    forall
      (CHIT: cache_hit c opcode labs pcl)
      (CHIT': cache_hit c opcode' labs' pcl'),
      opcode = opcode' /\
      labs = labs' /\
      pcl = pcl'.
Proof.
  intros. inv CHIT; inv CHIT'.
  inv OP; inv OP0.
  inv TAG1; inv TAG0.
  inv TAG2; inv TAG4.
  inv TAG3; inv TAG5.
  inv TAGPC; inv TAGPC0.
  repeat allinv'.
  intuition.
Qed.

Lemma cache_miss_simulation :
  forall s1 s21 e21 s22 s23
         (MATCH : match_states s1 s21)
         (STEP1 : cstep s21 e21 s22)
         (RUN : runsUntilUser s22 s23),
    match_states s1 s23.
Proof.
  intros.
  exploit runsUntilUser_l; eauto.
  intros PRIV.
  exploit configuration_at_miss; eauto.
  intros [op [vls [HIT EQS]]].
  destruct s22; simpl in EQS, PRIV; subst.
  inv MATCH; simpl.
  intuition. subst.
  destruct (apply_rule (projT2 (fetch_rule_impl op)) (snd apc) vls)
    as [[orl rpcl]|] eqn:E.
  - exploit (handler_correct_succeed (CT := LCL)); eauto.
    intros [cache' [ESCAPE1 MATCH']].
    exploit rte_success; eauto.
    intros ESCAPE2.
    unfold faultHandler in *.
    generalize (runsToEscape_determ ESCAPE1 ESCAPE2).
    intros H. subst.
    constructor; eauto.
    simpl in *.
    exploit update_cache_spec_rvec_cache_hit; eauto.
    clear HIT. intros HIT.
    intros op' vls' pcl' HIT'.
    generalize (cache_hit_unique HIT HIT').
    intros [E1 [E2 E3]].
    apply opCodeToZ_inj in E1. subst.
    apply labToZ_inj in E3. subst.
    apply labsToZs_inj in E2.
    + subst. rewrite E.
      destruct MATCH'. trivial.
    + destruct op'; simpl; lia.
  - exploit (handler_correct_fail (CT := LCL)); eauto.
    simpl in *.
    intros [stk' ESCAPE1].
    inv ESCAPE1.
    + apply runsUntilUser_r in STAR. simpl in STAR. congruence.
    + exfalso.
      eapply kernel_run_success_fail_contra; eauto.
Qed.

Lemma filter_cons_inv :
  forall A (f : A -> bool) a l1 l2,
    a :: l1 = filter f l2 ->
    exists l2', l1 = filter f l2'.
Proof.
  induction l2 as [|a' l2 IH]; simpl. congruence.
  destruct (f a'); intros H; auto.
  inv H. eauto.
Qed.

Inductive ac_match_initial_data :
  init_data abstract_machine ->
  init_data (concrete_machine faultHandler) -> Prop :=
| ac_mid : forall d1 p1 n1 b1,
             ac_match_initial_data
               (p1, d1, n1, b1)
               (p1, mem_labToZ d1, n1, labToZ b1).

Lemma match_init_stacks: forall d1,
 match_stacks (map (fun a : Atom => AData a) d1)
     (map (fun a : Atom => CData a) (mem_labToZ d1)).
Proof.
  induction d1 ; intros;
  (simpl ; constructor; auto).
Qed.

Lemma replicate_mem_labToZ :
  forall b n,
    replicate (0, labToZ b) n = mem_labToZ (replicate (0, b) n).
Proof.
  induction n ; intros.
  auto.
  simpl. inv IHn. auto.
Qed.

Lemma ac_match_initial_data_match_initial_states :
  forall ai ci,
    ac_match_initial_data ai ci ->
    match_states (init_state abstract_machine ai)
                      (init_state (concrete_machine faultHandler) ci).
Proof.
  intros ai ci H. inv H.
  simpl in *.
  constructor; simpl; eauto.
  - intros op vls pcl contra.
    inv contra.
    destruct op;
    destruct OP as [OP]; inv OP.
  - apply match_init_stacks.
  - apply replicate_mem_labToZ.
Qed.

(** Notions of concrete executions for proving this refinement *)
Section CExec.

(* congruence fails if this is let-bound *)
Local Notation ctrace := (list CEvent).

Let cons_event e t : ctrace :=
  match e with
    | E e => e :: t
    | Silent => t
  end.

Inductive exec_end : CS -> CS -> Prop :=
| ee_refl : forall s, exec_end s s
| ee_kernel_end : forall s s', runsToEnd s s' -> exec_end s s'
| ee_final_fault : forall s s' s'',
                     priv s = false ->
                     cstep s Silent s' ->
                     runsToEnd s' s'' ->
                     exec_end s s''.
Hint Constructors exec_end : core.

Inductive cexec : CS -> ctrace -> CS -> Prop :=
| ce_end : forall s s', exec_end s s' -> cexec s nil s'
| ce_kernel_begin : forall s s' t s'',
                      runsUntilUser s s' ->
                      cexec s' t s'' ->
                      cexec s t s''
| ce_user_hit : forall s e s' t s'',
                  priv s = false ->
                  cstep s e s' ->
                  priv s' = false ->
                  cexec s' t s'' ->
                  cexec s (cons_event e t) s''
| ce_user_miss : forall s s' s'' t s''',
                   priv s = false ->
                   cstep s Silent s' ->
                   runsUntilUser s' s'' ->
                   cexec s'' t s''' ->
                   cexec s t s'''.
Hint Constructors cexec : core.

Lemma exec_end_step : forall s e s' s''
                             (STEP : cstep s e s')
                             (EXEC : exec_end s' s''),
                        cexec s (cons_event e nil) s''.
Proof.
  intros.
  destruct (priv s) eqn:PRIV;
  [exploit priv_no_event_l; eauto; intros ?; subst|];
  (destruct (priv s') eqn:PRIV';
  [exploit priv_no_event_r; eauto; intros ?; subst|]);
  inv EXEC; eauto.
Qed.
Hint Resolve exec_end_step : core.

Lemma cexec_step : forall s e s' t s''
                          (Hstep : cstep s e s')
                          (Hexec : cexec s' t s''),
                          cexec s (cons_event e t) s''.
Proof.
  intros.
  inv Hexec; simpl; eauto;
  (destruct (priv s) eqn:PRIV;
   [assert (e = Silent) by (eapply priv_no_event_l; eauto); subst|]);
  eauto.
  - exploit priv_no_event_r; eauto.
    intros ?. subst.
    eauto.
  - subst. simpl.
    eapply ce_kernel_begin; eauto.
Qed.

Definition is_E {T} (a:T+τ) : bool :=
  match a with
    | Silent => false
    | E _ => true
  end.

Lemma exec_cexec : forall s t s',
                     (@TINI.exec (concrete_machine faultHandler)) s t s' ->
                     cexec s t s'.
Proof.
  intros s t s' Hexec.
  induction Hexec; eauto.
  eapply cexec_step with (e:=E e); eauto.
  eapply cexec_step with (e:=Silent); eauto.
Qed.

End CExec.

Definition match_events (e1:@Event L) (e2:CEvent) : Prop :=
  match e1 with
      EInt aa => CEInt (atom_labToZ aa) = e2
  end.

Lemma quasi_abstract_concrete_sref_prop :
  @state_refinement_statement (ifc_quasi_abstract_machine fetch_rule_g)
                              (concrete_machine faultHandler)
                              match_states match_events.
Proof.
  intros s1 s2 t2 s2' MATCH EXEC. simpl.
  apply exec_cexec in EXEC.
  match type of EXEC with
    | cexec _ ?T _ =>
      remember T as t2'
  end.
  gdep t2. gdep s1.
  unfold remove_none.
  induction EXEC; intros s1 MATCH t2 Ht2; unfold remove_none.
  - exists nil. exists s1.
    split. constructor.
    constructor.
  - inv MATCH.
    apply runsUntilUser_l in H.
    inv H.
  - exploit cache_hit_simulation; eauto.
    intros [e1 [s1' [STEP [ME MS]]]].
    unfold match_actions in *. subst.
    exploit IHEXEC; eauto.
    intros [t1 [? [? ?]]].
    destruct e1; simpl.
    + exists (e::t1). eexists.
      split. econstructor 2; eauto.
      simpl. destruct e; simpl; eauto.
      constructor; auto.
      constructor; auto.
    + exists (t1). eexists.
      split. econstructor; eauto.
      auto.

  - exploit cache_miss_simulation; eauto.
Qed.

Definition quasi_abstract_concrete_sref :=
  {| sref_prop := quasi_abstract_concrete_sref_prop |}.

Definition quasi_abstract_concrete_ref :
  refinement (ifc_quasi_abstract_machine fetch_rule_g)
             (concrete_machine faultHandler) :=
  @refinement_from_state_refinement _ _
                                    quasi_abstract_concrete_sref
                                    ac_match_initial_data
                                    ac_match_initial_data_match_initial_states.

End RefQAC.
End MatchAbstractConcrete.

(** * Combining the above into the final result *)
(** This is where we instantiate the generic refinement. *)
Section RefAC.

Context {observer: Type}
        {Latt: JoinSemiLattice observer}
        {CLatt: ConcreteLattice observer}
        {ELatt : Encodable observer}
        {WFCLatt: WfConcreteLattice observer Latt CLatt ELatt}.

Definition tini_fetch_rule_withsig :=
  (fun opcode => existT _
                        (QuasiAbstractMachine.labelCount opcode)
                        (QuasiAbstractMachine.fetch_rule opcode)).
Definition tini_faultHandler := @FaultRoutine.faultHandler observer ELatt
                                                           labelCount
                                                           (ifc_run_tmr fetch_rule)
                                                           (LatticeConcreteLabels (fetch_rule_impl fetch_rule)).
Definition tini_match_states := match_states QuasiAbstractMachine.fetch_rule.

Definition tini_concrete_machine := concrete_machine tini_faultHandler.

Program Definition abstract_concrete_ref :
  refinement abstract_machine tini_concrete_machine :=
  @ref_composition _ _ _
                   abstract_quasi_abstract_ref
                   (quasi_abstract_concrete_ref fetch_rule)
                   (@ac_match_initial_data _ _ _ _ _ fetch_rule)
                   match_events
                   _ _.

Next Obligation.
  eauto.
Qed.

End RefAC.


From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Loc.
From PromisingLib Require Import Language.

From PromisingLib Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.

Require Import ITreeLang.

Require Import PromiseConsistent.

Require Import FulfillStep.

Require Import iPromotionDef.
Require Import SimCommon.

Set Implicit Arguments.

Module SimThreadOther.
  Import SimCommon.
  Section TYPE.
  Variable R: Type.

  Inductive sim_thread (l: Loc.t) (e_src e_tgt: Thread.t (lang R)): Prop :=
  | sim_thread_intro
      (LOCFREE: loc_free_itree l (Thread.state e_src))
      (STATE: (Thread.state e_src) = (Thread.state e_tgt))
      (LOCAL: sim_local l (Thread.local e_src) (Thread.local e_tgt))
      (SC: sim_timemap l (Thread.sc e_src) (Thread.sc e_tgt))
      (MEMORY: sim_memory l (Thread.memory e_src) (Thread.memory e_tgt))
      (PROMISES: forall to, Memory.get l to (Local.promises (Thread.local e_src)) = None)
      (FULFILLABLE: fulfillable l (Local.tview (Thread.local e_src)) (Thread.memory e_src)
                                  (Local.promises (Thread.local e_src)))
  .
  Hint Constructors sim_thread: core.

  Lemma sim_thread_promise_step
        l e1_src
        pf e_tgt e1_tgt e2_tgt
        (SIM1: sim_thread l e1_src e1_tgt)
        (WF1_SRC: Local.wf (Thread.local e1_src) (Thread.memory e1_src))
        (WF1_TGT: Local.wf (Thread.local e1_tgt) (Thread.memory e1_tgt))
        (CLOSED1_SRC: Memory.closed (Thread.memory e1_src))
        (STEP_TGT: Thread.promise_step pf e_tgt e1_tgt e2_tgt):
    exists e_src e2_src,
      <<STEP_SRC: Thread.opt_promise_step e_src e1_src e2_src>> /\
      <<SIM2: sim_thread l e2_src e2_tgt>> /\
      <<MEMLOC: forall to, Memory.get l to (Thread.memory e1_src) = Memory.get l to (Thread.memory e2_src)>>.
  Proof.
    inversion STEP_TGT. subst.
    destruct (Loc.eq_dec loc l).
    { subst. inv LOCAL; ss.
      esplits; [econs 1| |]; eauto.
      inv SIM1. ss.
      exploit promise_loc; try exact PROMISE; try apply LOCAL; eauto. i. des.
      econs; ss; eauto.
      econs; ss; eauto; try apply LOCAL.
    }
    exploit promise_step; try exact LOCAL; try apply SIM1;
      try apply WF1_SRC; try apply WF1_TGT; eauto.
    i. des.
    destruct e1_src. ss.
    esplits.
    - econs 2. econs; eauto.
    - inv SIM1. ss. econs; eauto; ss.
      i. inv STEP_SRC.
      erewrite Memory.promise_get_diff_promise; try exact PROMISE; eauto.
    - i. s. inv STEP_SRC.
      erewrite <- Memory.promise_get_diff; try exact PROMISE; eauto.
  Qed.

  Lemma sim_thread_program_step
        l e1_src
        e_tgt e1_tgt e2_tgt
        (SIM1: sim_thread l e1_src e1_tgt)
        (WF1_SRC: Local.wf (Thread.local e1_src) (Thread.memory e1_src))
        (WF1_TGT: Local.wf (Thread.local e1_tgt) (Thread.memory e1_tgt))
        (SC1_SRC: Memory.closed_timemap (Thread.sc e1_src) (Thread.memory e1_src))
        (SC1_TGT: Memory.closed_timemap (Thread.sc e1_tgt) (Thread.memory e1_tgt))
        (CLOSED1_SRC: Memory.closed (Thread.memory e1_src))
        (CLOSED1_TGT: Memory.closed (Thread.memory e1_tgt))
        (STEP_TGT: Thread.program_step e_tgt e1_tgt e2_tgt):
    exists e_src e2_src,
      <<STEP_SRC: Thread.opt_program_step e_src e1_src e2_src>> /\
      <<EVENT: ThreadEvent.get_machine_event e_src = ThreadEvent.get_machine_event e_tgt>> /\
      <<SIM2: sim_thread l e2_src e2_tgt>> /\
      <<MEMLOC: forall to, Memory.get l to (Thread.memory e1_src) = Memory.get l to (Thread.memory e2_src)>>.
  Proof.
    inv STEP_TGT; ss.
    hexploit loc_free_step_is_accessing_loc; eauto; i.
    { inv SIM1. ss. subst. eauto. }
    exploit program_step; try exact LOCAL; try eapply SIM1; eauto. i. des.
    destruct e1_src. ss.
    esplits.
    - econs 2. econs; try exact STEP_SRC.
      inv SIM1. inv STATE0. ss.
      rewrite H0. rewrite EVENT2. eauto.
    - ss.
    - econs; eauto.
      + s. eapply step_loc_free; eauto.
        inv SIM1. ss. subst. ss.
      + s. i. inv SIM1. ss.
        erewrite <- Local.program_step_get_diff_promises; eauto.
        erewrite ThreadEvent.eq_program_event_eq_loc; eauto.
    - s. i.
      eapply Local.program_step_get_diff; eauto.
      erewrite ThreadEvent.eq_program_event_eq_loc; eauto.
  Qed.

  Lemma sim_thread_step
        l e1_src
        pf e_tgt e1_tgt e2_tgt
        (SIM1: sim_thread l e1_src e1_tgt)
        (WF1_SRC: Local.wf (Thread.local e1_src) (Thread.memory e1_src))
        (WF1_TGT: Local.wf (Thread.local e1_tgt) (Thread.memory e1_tgt))
        (SC1_SRC: Memory.closed_timemap (Thread.sc e1_src) (Thread.memory e1_src))
        (SC1_TGT: Memory.closed_timemap (Thread.sc e1_tgt) (Thread.memory e1_tgt))
        (CLOSED1_SRC: Memory.closed (Thread.memory e1_src))
        (CLOSED1_TGT: Memory.closed (Thread.memory e1_tgt))
        (STEP_TGT: Thread.step pf e_tgt e1_tgt e2_tgt):
    exists e_src e2_src,
      <<STEP_SRC: Thread.opt_step e_src e1_src e2_src>> /\
      <<EVENT: ThreadEvent.get_machine_event e_src = ThreadEvent.get_machine_event e_tgt>> /\
      <<SIM2: sim_thread l e2_src e2_tgt>> /\
      <<MEMLOC: forall to, Memory.get l to (Thread.memory e1_src) = Memory.get l to (Thread.memory e2_src)>>.
  Proof.
    inv STEP_TGT.
    - exploit sim_thread_promise_step; eauto. i. des.
      esplits.
      + inv STEP_SRC.
        * econs 1.
        * econs 2. econs 1; eauto.
      + inv STEP. ss. inv STEP_SRC; ss. inv STEP. ss.
      + ss.
      + ss.
    - exploit sim_thread_program_step; eauto. i. des.
      esplits.
      + inv STEP_SRC.
        * econs 1.
        * econs 2. econs 2; eauto.
      + ss.
      + ss.
      + ss.
  Qed.

  Lemma sim_thread_opt_step
        l e1_src
        e_tgt e1_tgt e2_tgt
        (SIM1: sim_thread l e1_src e1_tgt)
        (WF1_SRC: Local.wf (Thread.local e1_src) (Thread.memory e1_src))
        (WF1_TGT: Local.wf (Thread.local e1_tgt) (Thread.memory e1_tgt))
        (SC1_SRC: Memory.closed_timemap (Thread.sc e1_src) (Thread.memory e1_src))
        (SC1_TGT: Memory.closed_timemap (Thread.sc e1_tgt) (Thread.memory e1_tgt))
        (CLOSED1_SRC: Memory.closed (Thread.memory e1_src))
        (CLOSED1_TGT: Memory.closed (Thread.memory e1_tgt))
        (STEP_TGT: Thread.opt_step e_tgt e1_tgt e2_tgt):
    exists e_src e2_src,
      <<STEP_SRC: Thread.opt_step e_src e1_src e2_src>> /\
      <<EVENT: ThreadEvent.get_machine_event e_src = ThreadEvent.get_machine_event e_tgt>> /\
      <<SIM2: sim_thread l e2_src e2_tgt>> /\
      <<MEMLOC: forall to, Memory.get l to (Thread.memory e1_src) = Memory.get l to (Thread.memory e2_src)>>.
  Proof.
    inv STEP_TGT.
    - esplits; eauto. econs 1.
    - exploit sim_thread_step; eauto.
  Qed.

  Lemma sim_thread_rtc_tau_step
        l e1_src
        e1_tgt e2_tgt
        (SIM1: sim_thread l e1_src e1_tgt)
        (WF1_SRC: Local.wf (Thread.local e1_src) (Thread.memory e1_src))
        (WF1_TGT: Local.wf (Thread.local e1_tgt) (Thread.memory e1_tgt))
        (SC1_SRC: Memory.closed_timemap (Thread.sc e1_src) (Thread.memory e1_src))
        (SC1_TGT: Memory.closed_timemap (Thread.sc e1_tgt) (Thread.memory e1_tgt))
        (CLOSED1_SRC: Memory.closed (Thread.memory e1_src))
        (CLOSED1_TGT: Memory.closed (Thread.memory e1_tgt))
        (STEPS_TGT: rtc (@Thread.tau_step (lang R)) e1_tgt e2_tgt):
    exists e2_src,
      <<STEPS_SRC: rtc (@Thread.tau_step (lang R)) e1_src e2_src>> /\
      <<SIM2: sim_thread l e2_src e2_tgt>> /\
      <<MEMLOC: forall to, Memory.get l to (Thread.memory e1_src) = Memory.get l to (Thread.memory e2_src)>>.
  Proof.
    revert e1_src SIM1 WF1_SRC SC1_SRC CLOSED1_SRC.
    induction STEPS_TGT; i.
    - esplits; eauto.
    - inv H. inv TSTEP.
      exploit sim_thread_step; eauto. i. des.
      exploit Thread.step_future; try exact STEP; eauto. i. des.
      exploit Thread.opt_step_future; try exact STEP_SRC; eauto. i. des.
      exploit IHSTEPS_TGT; eauto. i. des.
      inv STEP_SRC.
      + esplits; eauto.
      + esplits; [M|..]; eauto.
        * econs; [|eauto].
          econs; [econs; eauto|]. rewrite <- EVENT. ss.
        * i. rewrite MEMLOC. ss.
  Qed.

  Lemma sim_thread_plus_step
        l e1_src
        e_tgt e1_tgt e2_tgt e3_tgt
        (SIM1: sim_thread l e1_src e1_tgt)
        (WF1_SRC: Local.wf (Thread.local e1_src) (Thread.memory e1_src))
        (WF1_TGT: Local.wf (Thread.local e1_tgt) (Thread.memory e1_tgt))
        (SC1_SRC: Memory.closed_timemap (Thread.sc e1_src) (Thread.memory e1_src))
        (SC1_TGT: Memory.closed_timemap (Thread.sc e1_tgt) (Thread.memory e1_tgt))
        (CLOSED1_SRC: Memory.closed (Thread.memory e1_src))
        (CLOSED1_TGT: Memory.closed (Thread.memory e1_tgt))
        (STEPS_TGT: rtc (@Thread.tau_step (lang R)) e1_tgt e2_tgt)
        (STEP_TGT: Thread.opt_step e_tgt e2_tgt e3_tgt):
    exists e_src e2_src e3_src,
      <<STEPS_SRC: rtc (@Thread.tau_step (lang R)) e1_src e2_src>> /\
      <<STEP_SRC: Thread.opt_step e_src e2_src e3_src>> /\
      <<EVENT: ThreadEvent.get_machine_event e_src = ThreadEvent.get_machine_event e_tgt>> /\
      <<SIM3: sim_thread l e3_src e3_tgt>> /\
      <<MEMLOC: forall to, Memory.get l to (Thread.memory e1_src) = Memory.get l to (Thread.memory e3_src)>>.
  Proof.
    exploit sim_thread_rtc_tau_step; eauto. i. des.
    exploit Thread.rtc_tau_step_future; try exact STEPS_SRC; eauto. i. des.
    exploit Thread.rtc_tau_step_future; try exact STEPS_TGT; eauto. i. des.
    exploit sim_thread_opt_step; eauto. i. des.
    esplits; eauto.
    i. rewrite MEMLOC. ss.
  Qed.

  (* future *)

  Lemma sim_thread_future
        l
        st_src lc_src sc1_src mem1_src sc2_src mem2_src
        st_tgt lc_tgt sc1_tgt mem1_tgt sc2_tgt mem2_tgt
        (SIM1: sim_thread l
                          (Thread.mk (lang R) st_src lc_src sc1_src mem1_src)
                          (Thread.mk (lang R) st_tgt lc_tgt sc1_tgt mem1_tgt))
        (WF1_SRC: Local.wf lc_src mem1_src)
        (MEM_SRC: Memory.future mem1_src mem2_src)
        (SC: sim_timemap l sc2_src sc2_tgt)
        (MEM: sim_memory l mem2_src mem2_tgt)
        (PREV: Memory.prev_None mem1_src mem2_src):
    sim_thread l
               (Thread.mk (lang R) st_src lc_src sc2_src mem2_src)
               (Thread.mk (lang R) st_tgt lc_tgt sc2_tgt mem2_tgt).
  Proof.
    inv SIM1. ss. econs; s; eauto. ii.
    exploit FULFILLABLE; eauto. i. des. split; ss.
    unfold prev_released_le_loc in *. des_ifs; ss.
    - exploit Memory.future_get1; try exact Heq0; eauto; ss. i. des.
      inv MSG_LE. inv RELEASED; try congr.
      rewrite Heq in *. inv GET.
      unnw. etrans; eauto. split; apply LE.
    - exploit Memory.future_get1; try exact Heq0; eauto; ss. i. des.
      inv MSG_LE. inv RELEASED; try congr.
    - exploit Memory.future_get1; try exact Heq0; eauto; ss. i. des.
      rewrite GET in *. inv Heq. inv MSG_LE.
    - inv WF1_SRC. exploit PROMISES0; eauto. i.
      exploit PREV; eauto; ss. ii. congr.
    - inv WF1_SRC. exploit PROMISES0; eauto. i.
      exploit PREV; eauto; ss. ii. congr.
  Qed.

  (* terminal *)

  Lemma sim_thread_promises_bot
        l e_src e_tgt
        (SIM: sim_thread l e_src e_tgt)
        (PROMISES_TGT: (Local.promises (Thread.local e_tgt)) = Memory.bot):
    <<PROMISES_SRC: (Local.promises (Thread.local e_src)) = Memory.bot>>.
  Proof.
    inv SIM. inv LOCAL. apply Memory.ext. i.
    rewrite Memory.bot_get.
    destruct (Loc.eq_dec loc l); subst; ss.
    symmetry in PROMISES1.
    exploit sim_memory_get_None_src; eauto.
    rewrite PROMISES_TGT. rewrite Memory.bot_get. ss.
  Qed.

  Lemma sim_thread_terminal
        l e_src e_tgt
        (SIM: sim_thread l e_src e_tgt)
        (TERMINAL_TGT: (Language.is_terminal (lang R)) (Thread.state e_tgt)):
    <<TERMINAL_SRC: (Language.is_terminal (lang R)) (Thread.state e_src)>>.
  Proof.
    inv SIM. rewrite STATE. ss.
  Qed.

  (* certification *)

  Lemma sim_thread_cap
        l e_src e_tgt
        cap_src cap_tgt
        (SIM: sim_thread l e_src e_tgt)
        (WF_SRC: Local.wf (Thread.local e_src) (Thread.memory e_src))
        (WF_TGT: Local.wf (Thread.local e_tgt) (Thread.memory e_tgt))
        (CLOSED_SRC: Memory.closed (Thread.memory e_src))
        (CLOSED_TGT: Memory.closed (Thread.memory e_tgt))
        (CAP_SRC: Memory.cap (Thread.memory e_src) cap_src)
        (CAP_TGT: Memory.cap (Thread.memory e_tgt) cap_tgt):
    sim_thread l
               (Thread.mk (lang R) (Thread.state e_src) (Thread.local e_src) (Thread.sc e_src) cap_src)
               (Thread.mk (lang R) (Thread.state e_tgt) (Thread.local e_tgt) (Thread.sc e_tgt) cap_tgt).
  Proof.
    inv SIM. inv LOCAL.
    exploit sim_memory_cap; try exact MEMORY; eauto. i. des.
    econs; eauto.
    s. eapply cap_fulfillable; eauto. apply WF_SRC.
  Qed.

  Lemma sim_thread_consistent
        l e_src e_tgt
        (SIM: sim_thread l e_src e_tgt)
        (WF_SRC: Local.wf (Thread.local e_src) (Thread.memory e_src))
        (WF_TGT: Local.wf (Thread.local e_tgt) (Thread.memory e_tgt))
        (SC_SRC: Memory.closed_timemap (Thread.sc e_src) (Thread.memory e_src))
        (SC_TGT: Memory.closed_timemap (Thread.sc e_tgt) (Thread.memory e_tgt))
        (CLOSED_SRC: Memory.closed (Thread.memory e_src))
        (CLOSED_TGT: Memory.closed (Thread.memory e_tgt))
        (CONSISTENT_TGT: Thread.consistent e_tgt):
    <<CONSISTENT_SRC: Thread.consistent e_src>>.
  Proof.
    exploit Memory.cap_exists; try exact CLOSED_TGT. i. des.
    exploit Memory.cap_closed; eauto. ii.
    exploit sim_thread_cap; try exact SIM; try exact CAP0; try exact CAP; eauto. i.
    exploit Local.cap_wf; try exact WF_SRC; eauto. intro WF_CAP_SRC.
    exploit Local.cap_wf; try exact WF_TGT; eauto. intro WF_CAP_TGT.
    hexploit Memory.cap_closed_timemap; try exact SC_SRC; eauto. i.
    hexploit Memory.cap_closed_timemap; try exact SC_TGT; eauto. i.
    exploit Memory.cap_closed; try exact CLOSED_SRC; eauto. intro CLOSED_CAP_SRC.
    exploit Memory.cap_closed; try exact CLOSED_TGT; eauto. intro CLOSED_CAP_TGT.
    exploit CONSISTENT_TGT; eauto. i. des.
    - left. unfold Thread.steps_failure in *. des.
      exploit sim_thread_plus_step; eauto.
      { econs 2; eauto. }
      s. i. des.
      inv STEP_SRC; ss; try congr.
      destruct pf; try by (inv STEP; inv STEP0; ss; congr).
      esplits; eauto. congr.
    - right.
      exploit sim_thread_rtc_tau_step; try exact STEPS; eauto. i. des.
      esplits; eauto.
      eapply sim_thread_promises_bot; eauto.
  Qed.
  End TYPE.
End SimThreadOther.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Function calling conventions and other conventions regarding the use of
    machine registers and stack slots. *)

Require Import Coqlib.
Require Import AST.
Require Import Events.
Require Import Locations.
Require Archi.

(** * Classification of machine registers *)

(** Machine registers (type [mreg] in module [Locations]) are divided in
  the following groups:
- Temporaries used for spilling, reloading, and parallel move operations.
- Allocatable registers, that can be assigned to RTL pseudo-registers.
  These are further divided into:
-- Callee-save registers, whose value is preserved across a function call.
-- Caller-save registers that can be modified during a function call.

  We follow the ARM application binary interface (EABI) in our choice
  of callee- and caller-save registers.
*)

Definition int_caller_save_regs :=
  R0 :: R1 :: R2 :: R3 :: R12 :: nil.

Definition float_caller_save_regs :=
  F0 :: F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: nil.

Definition int_callee_save_regs :=
  R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: R11 :: nil.

Definition float_callee_save_regs :=
  F8 :: F9 :: F10 :: F11 :: F12 :: F13 :: F14 :: F15 :: nil.

Definition destroyed_at_call :=
  int_caller_save_regs ++ float_caller_save_regs.

Definition dummy_int_reg := R0.     (**r Used in [Coloring]. *)
Definition dummy_float_reg := F0.   (**r Used in [Coloring]. *)

(** The [index_int_callee_save] and [index_float_callee_save] associate
  a unique positive integer to callee-save registers.  This integer is
  used in [Stacking] to determine where to save these registers in
  the activation record if they are used by the current function. *)

Definition index_int_callee_save (r: mreg) :=
  match r with
  | R4 => 0  | R5 => 1  | R6 => 2  | R7 => 3
  | R8 => 4  | R9 => 5  | R10 => 6 | R11 => 7
  | _ => -1
  end.

Definition index_float_callee_save (r: mreg) :=
  match r with
  | F8 => 0  | F9 => 1  | F10 => 2  | F11 => 3
  | F12 => 4  | F13 => 5  | F14 => 6  | F15 => 7
  | _ => -1
  end.

Ltac ElimOrEq :=
  match goal with
  |  |- (?x = ?y) \/ _ -> _ =>
       let H := fresh in
       (intro H; elim H; clear H;
        [intro H; rewrite <- H; clear H | ElimOrEq])
  |  |- False -> _ =>
       let H := fresh in (intro H; contradiction)
  end.

Ltac OrEq :=
  match goal with
  | |- (?x = ?x) \/ _ => left; reflexivity
  | |- (?x = ?y) \/ _ => right; OrEq
  | |- False => fail
  end.

Ltac NotOrEq :=
  match goal with
  | |- (?x = ?y) \/ _ -> False =>
       let H := fresh in (
       intro H; elim H; clear H; [intro; discriminate | NotOrEq])
  | |- False -> False =>
       contradiction
  end.

Lemma index_int_callee_save_pos:
  forall r, In r int_callee_save_regs -> index_int_callee_save r >= 0.
Proof.
  intro r. simpl; ElimOrEq; unfold index_int_callee_save; omega.
Qed.

Lemma index_float_callee_save_pos:
  forall r, In r float_callee_save_regs -> index_float_callee_save r >= 0.
Proof.
  intro r. simpl; ElimOrEq; unfold index_float_callee_save; omega.
Qed.

Lemma index_int_callee_save_pos2:
  forall r, index_int_callee_save r >= 0 -> In r int_callee_save_regs.
Proof.
  destruct r; simpl; intro; omegaContradiction || OrEq.
Qed.

Lemma index_float_callee_save_pos2:
  forall r, index_float_callee_save r >= 0 -> In r float_callee_save_regs.
Proof.
  destruct r; simpl; intro; omegaContradiction || OrEq.
Qed.

Lemma index_int_callee_save_inj:
  forall r1 r2,
  In r1 int_callee_save_regs ->
  In r2 int_callee_save_regs ->
  r1 <> r2 ->
  index_int_callee_save r1 <> index_int_callee_save r2.
Proof.
  intros r1 r2.
  simpl; ElimOrEq; ElimOrEq; unfold index_int_callee_save;
  intros; congruence.
Qed.

Lemma index_float_callee_save_inj:
  forall r1 r2,
  In r1 float_callee_save_regs ->
  In r2 float_callee_save_regs ->
  r1 <> r2 ->
  index_float_callee_save r1 <> index_float_callee_save r2.
Proof.
  intros r1 r2.
  simpl; ElimOrEq; ElimOrEq; unfold index_float_callee_save;
  intros; congruence.
Qed.

(** The following lemmas show that
    (temporaries, destroyed at call, integer callee-save, float callee-save)
    is a partition of the set of machine registers. *)

Lemma int_float_callee_save_disjoint:
  list_disjoint int_callee_save_regs float_callee_save_regs.
Proof.
  red; intros r1 r2. simpl; ElimOrEq; ElimOrEq; discriminate.
Qed.

Lemma register_classification:
  forall r,
  In r destroyed_at_call \/ In r int_callee_save_regs \/ In r float_callee_save_regs.
Proof.
  destruct r;
  try (left; simpl; OrEq);
  try (right; left; simpl; OrEq);
  try (right; right; simpl; OrEq).
Qed.

Lemma int_callee_save_not_destroyed:
  forall r,
    In r destroyed_at_call -> In r int_callee_save_regs -> False.
Proof.
  intros. revert H0 H. simpl. ElimOrEq; NotOrEq.
Qed.

Lemma float_callee_save_not_destroyed:
  forall r,
    In r destroyed_at_call -> In r float_callee_save_regs -> False.
Proof.
  intros. revert H0 H. simpl. ElimOrEq; NotOrEq.
Qed.

Lemma int_callee_save_type:
  forall r, In r int_callee_save_regs -> mreg_type r = Tany32.
Proof.
  intro. simpl; ElimOrEq; reflexivity.
Qed.

Lemma float_callee_save_type:
  forall r, In r float_callee_save_regs -> mreg_type r = Tany64.
Proof.
  intro. simpl; ElimOrEq; reflexivity.
Qed.

Ltac NoRepet :=
  match goal with
  | |- list_norepet nil =>
      apply list_norepet_nil
  | |- list_norepet (?a :: ?b) =>
      apply list_norepet_cons; [simpl; intuition discriminate | NoRepet]
  end.

Lemma int_callee_save_norepet:
  list_norepet int_callee_save_regs.
Proof.
  unfold int_callee_save_regs; NoRepet.
Qed.

Lemma float_callee_save_norepet:
  list_norepet float_callee_save_regs.
Proof.
  unfold float_callee_save_regs; NoRepet.
Qed.

(** * Function calling conventions *)

(** The functions in this section determine the locations (machine registers
  and stack slots) used to communicate arguments and results between the
  caller and the callee during function calls.  These locations are functions
  of the signature of the function and of the call instruction.
  Agreement between the caller and the callee on the locations to use
  is guaranteed by our dynamic semantics for Cminor and RTL, which demand
  that the signature of the call instruction is identical to that of the
  called function.

  Calling conventions are largely arbitrary: they must respect the properties
  proved in this section (such as no overlapping between the locations
  of function arguments), but this leaves much liberty in choosing actual
  locations.  *)

(** ** Location of function result *)

(** The result value of a function is passed back to the caller in
  registers [R0] or [F0] or [R0,R1], depending on the type of the
  returned value.  We treat a function without result as a function
  with one integer result.

  For the "softfloat" convention, results of FP types should be passed
  in [R0] or [R0,R1].  This doesn't fit the CompCert register model,
  so we have code in [arm/PrintAsm.ml] that inserts additional moves
  to/from [F0]. *)

Definition loc_result (s: signature) : list mreg :=
  match s.(sig_res) with
  | None => R0 :: nil
  | Some (Tint | Tany32) => R0 :: nil
  | Some (Tfloat | Tsingle | Tany64) => F0 :: nil
  | Some Tlong => R1 :: R0 :: nil
  end.

(** The result registers have types compatible with that given in the signature. *)

Lemma loc_result_type:
  forall sig,
  subtype_list (proj_sig_res' sig) (map mreg_type (loc_result sig)) = true.
Proof.
  intros. unfold proj_sig_res', loc_result. destruct (sig_res sig) as [[]|]; auto.
Qed.

(** The result locations are caller-save registers *)

Lemma loc_result_caller_save:
  forall (s: signature) (r: mreg),
  In r (loc_result s) -> In r destroyed_at_call.
Proof.
  intros.
  assert (r = R0 \/ r = R1 \/ r = F0).
    unfold loc_result in H. destruct (sig_res s); [destruct t|idtac]; simpl in H; intuition.
  destruct H0 as [A | [A | A]]; subst r; simpl; OrEq.
Qed.

(** ** Location of function arguments *)

(** For the "hardfloat" configuration, we use the following calling conventions,
    adapted from the ARM EABI-HF:
- The first 4 integer arguments are passed in registers [R0] to [R3].
- The first 2 long integer arguments are passed in an aligned pair of
  two integer registers.
- The first 8 single- and double-precision float arguments are passed
  in registers [F0...F7]
- Extra arguments are passed on the stack, in [Outgoing] slots, consecutively
  assigned (1 word for an integer or single argument, 2 words for a float
  or a long), starting at word offset 0.

This convention is not quite that of the ARM EABI-HF, whereas single float
arguments are passed in 32-bit float registers.  Unfortunately,
this does not fit the data model of CompCert.  In [PrintAsm.ml]
we insert additional code around function calls that moves
data appropriately. *)

Definition int_param_regs :=
  R0 :: R1 :: R2 :: R3 :: nil.

Definition float_param_regs :=
  F0 :: F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: nil.

Definition ireg_param (n: Z) : mreg :=
  match list_nth_z int_param_regs n with Some r => r | None => R0 end.

Definition freg_param (n: Z) : mreg :=
  match list_nth_z float_param_regs n with Some r => r | None => F0 end.

Fixpoint loc_arguments_hf
     (tyl: list typ) (ir fr ofs: Z) {struct tyl} : list loc :=
  match tyl with
  | nil => nil
  | (Tint | Tany32) as ty :: tys =>
      if zlt ir 4
      then R (ireg_param ir) :: loc_arguments_hf tys (ir + 1) fr ofs
      else S Outgoing ofs ty :: loc_arguments_hf tys ir fr (ofs + 1)
  | (Tfloat | Tany64) as ty :: tys =>
      if zlt fr 8
      then R (freg_param fr) :: loc_arguments_hf tys ir (fr + 1) ofs
      else let ofs := align ofs 2 in
           S Outgoing ofs ty :: loc_arguments_hf tys ir fr (ofs + 2)
  | Tsingle :: tys =>
      if zlt fr 8
      then R (freg_param fr) :: loc_arguments_hf tys ir (fr + 1) ofs
      else S Outgoing ofs Tsingle :: loc_arguments_hf tys ir fr (ofs + 1)
  | Tlong :: tys =>
      let ir := align ir 2 in
      if zlt ir 4
      then R (ireg_param (ir + 1)) :: R (ireg_param ir) :: loc_arguments_hf tys (ir + 2) fr ofs
      else let ofs := align ofs 2 in
          S Outgoing (ofs + 1) Tint :: S Outgoing ofs Tint :: loc_arguments_hf tys ir fr (ofs + 2)
  end.

(** For the "softfloat" configuration, as well as for variable-argument functions
  in the "hardfloat" configuration, we use the default ARM EABI (not HF)
  calling conventions:
- The first 4 integer arguments are passed in registers [R0] to [R3].
- The first 2 long integer arguments are passed in an aligned pair of
  two integer registers.
- The first 2 double-precision float arguments are passed in [F0] or [F2]
- The first 4 single-precision float arguments are passed in [F0...F3]
- Integer arguments and float arguments are kept in sync so that
  they can all be mapped back to [R0...R3] in [PrintAsm.ml].
- Extra arguments are passed on the stack, in [Outgoing] slots, consecutively
  assigned (1 word for an integer or single argument, 2 words for a float
  or a long), starting at word offset 0.

This convention is not quite that of the ARM EABI, whereas every float
argument are passed in one or two integer registers.  Unfortunately,
this does not fit the data model of CompCert.  In [PrintAsm.ml]
we insert additional code around function calls and returns that moves
data appropriately. *)

Fixpoint loc_arguments_sf
     (tyl: list typ) (ofs: Z) {struct tyl} : list loc :=
  match tyl with
  | nil => nil
  | (Tint|Tany32) as ty :: tys =>
      (if zlt ofs 0 then R (ireg_param (ofs + 4)) else S Outgoing ofs ty)
      :: loc_arguments_sf tys (ofs + 1)
  | (Tfloat|Tany64) as ty :: tys =>
      let ofs := align ofs 2 in
      (if zlt ofs 0 then R (freg_param (ofs + 4)) else S Outgoing ofs ty)
      :: loc_arguments_sf tys (ofs + 2)
  | Tsingle :: tys =>
      (if zlt ofs 0 then R (freg_param (ofs + 4)) else S Outgoing ofs Tsingle)
      :: loc_arguments_sf tys (ofs + 1)
  | Tlong :: tys =>
      let ofs := align ofs 2 in
      (if zlt ofs 0 then R (ireg_param (ofs+1+4)) else S Outgoing (ofs+1) Tint)
      :: (if zlt ofs 0 then R (ireg_param (ofs+4)) else S Outgoing ofs Tint)
      :: loc_arguments_sf tys (ofs + 2)
  end.

(** [loc_arguments s] returns the list of locations where to store arguments
  when calling a function with signature [s].  *)

Definition loc_arguments (s: signature) : list loc :=
  match Archi.abi with
  | Archi.Softfloat =>
      loc_arguments_sf s.(sig_args) (-4)
  | Archi.Hardfloat =>
      if s.(sig_cc).(cc_vararg)
      then loc_arguments_sf s.(sig_args) (-4)
      else loc_arguments_hf s.(sig_args) 0 0 0
  end.

(** [size_arguments s] returns the number of [Outgoing] slots used
  to call a function with signature [s]. *)

Fixpoint size_arguments_hf (tyl: list typ) (ir fr ofs: Z) {struct tyl} : Z :=
  match tyl with
  | nil => ofs
  | (Tint|Tany32) :: tys =>
      if zlt ir 4
      then size_arguments_hf tys (ir + 1) fr ofs
      else size_arguments_hf tys ir fr (ofs + 1)
  | (Tfloat|Tany64) :: tys =>
      if zlt fr 8
      then size_arguments_hf tys ir (fr + 1) ofs
      else size_arguments_hf tys ir fr (align ofs 2 + 2)
  | Tsingle :: tys =>
      if zlt fr 8
      then size_arguments_hf tys ir (fr + 1) ofs
      else size_arguments_hf tys ir fr (ofs + 1)
  | Tlong :: tys =>
      let ir := align ir 2 in
      if zlt ir 4
      then size_arguments_hf tys (ir + 2) fr ofs
      else size_arguments_hf tys ir fr (align ofs 2 + 2)
  end.

Fixpoint size_arguments_sf (tyl: list typ) (ofs: Z) {struct tyl} : Z :=
  match tyl with
  | nil => Zmax 0 ofs
  | (Tint | Tsingle | Tany32) :: tys => size_arguments_sf tys (ofs + 1)
  | (Tfloat | Tlong | Tany64) :: tys => size_arguments_sf tys (align ofs 2 + 2)
  end.

Definition size_arguments (s: signature) : Z :=
  match Archi.abi with
  | Archi.Softfloat =>
      size_arguments_sf s.(sig_args) (-4)
  | Archi.Hardfloat =>
      if s.(sig_cc).(cc_vararg)
      then size_arguments_sf s.(sig_args) (-4)
      else size_arguments_hf s.(sig_args) 0 0 0
  end.

(** Argument locations are either non-temporary registers or [Outgoing]
  stack slots at nonnegative offsets. *)

Definition loc_argument_acceptable (l: loc) : Prop :=
  match l with
  | R r => In r destroyed_at_call
  | S Outgoing ofs ty => ofs >= 0 /\ ty <> Tlong
  | _ => False
  end.

Remark ireg_param_in_params: forall n, In (ireg_param n) int_param_regs.
Proof.
  unfold ireg_param; intros.
  destruct (list_nth_z int_param_regs n) as [r|] eqn:NTH.
  eapply list_nth_z_in; eauto.
  simpl; auto.
Qed.

Remark freg_param_in_params: forall n, In (freg_param n) float_param_regs.
Proof.
  unfold freg_param; intros.
  destruct (list_nth_z float_param_regs n) as [r|] eqn:NTH.
  eapply list_nth_z_in; eauto.
  simpl; auto.
Qed.

Remark loc_arguments_hf_charact:
  forall tyl ir fr ofs l,
  In l (loc_arguments_hf tyl ir fr ofs) ->
  match l with
  | R r => In r int_param_regs \/ In r float_param_regs
  | S Outgoing ofs' ty => ofs' >= ofs /\ ty <> Tlong
  | S _ _ _ => False
  end.
Proof.
  assert (INCR: forall l ofs1 ofs2,
            match l with
            | R r => In r int_param_regs \/ In r float_param_regs
            | S Outgoing ofs' ty => ofs' >= ofs2 /\ ty <> Tlong
            | S _ _ _ => False
            end ->
            ofs1 <= ofs2 ->
            match l with
            | R r => In r int_param_regs \/ In r float_param_regs
            | S Outgoing ofs' ty => ofs' >= ofs1 /\ ty <> Tlong
            | S _ _ _ => False
            end).
  {
    intros. destruct l; auto. destruct sl; auto. intuition omega.
  }
  induction tyl; simpl loc_arguments_hf; intros.
  elim H.
  destruct a.
- (* int *)
  destruct (zlt ir 4); destruct H.
  subst. left; apply ireg_param_in_params.
  eapply IHtyl; eauto.
  subst. split; [omega | congruence].
  eapply INCR. eapply IHtyl; eauto. omega.
- (* float *)
  destruct (zlt fr 8); destruct H.
  subst. right; apply freg_param_in_params.
  eapply IHtyl; eauto.
  subst. split. apply Zle_ge. apply align_le. omega. congruence.
  eapply INCR. eapply IHtyl; eauto.
  apply Zle_trans with (align ofs 2). apply align_le; omega. omega.
- (* long *)
  set (ir' := align ir 2) in *.
  assert (ofs <= align ofs 2) by (apply align_le; omega).
  destruct (zlt ir' 4).
  destruct H. subst l; left; apply ireg_param_in_params.
  destruct H. subst l; left; apply ireg_param_in_params.
  eapply IHtyl; eauto.
  destruct H. subst l; split; [ omega | congruence ].
  destruct H. subst l; split; [ omega | congruence ].
  eapply INCR. eapply IHtyl; eauto. omega.
- (* single *)
  destruct (zlt fr 8); destruct H.
  subst. right; apply freg_param_in_params.
  eapply IHtyl; eauto.
  subst. split; [omega | congruence].
  eapply INCR. eapply IHtyl; eauto. omega.
- (* any32 *)
  destruct (zlt ir 4); destruct H.
  subst. left; apply ireg_param_in_params.
  eapply IHtyl; eauto.
  subst. split; [omega | congruence].
  eapply INCR. eapply IHtyl; eauto. omega.
- (* any64 *)
  destruct (zlt fr 8); destruct H.
  subst. right; apply freg_param_in_params.
  eapply IHtyl; eauto.
  subst. split. apply Zle_ge. apply align_le. omega. congruence.
  eapply INCR. eapply IHtyl; eauto.
  apply Zle_trans with (align ofs 2). apply align_le; omega. omega.
Qed.

Remark loc_arguments_sf_charact:
  forall tyl ofs l,
  In l (loc_arguments_sf tyl ofs) ->
  match l with
  | R r => In r int_param_regs \/ In r float_param_regs
  | S Outgoing ofs' ty => ofs' >= Zmax 0 ofs /\ ty <> Tlong
  | S _ _ _ => False
  end.
Proof.
  assert (INCR: forall l ofs1 ofs2,
            match l with
            | R r => In r int_param_regs \/ In r float_param_regs
            | S Outgoing ofs' ty => ofs' >= Zmax 0 ofs2 /\ ty <> Tlong
            | S _ _ _ => False
            end ->
            ofs1 <= ofs2 ->
            match l with
            | R r => In r int_param_regs \/ In r float_param_regs
            | S Outgoing ofs' ty => ofs' >= Zmax 0 ofs1 /\ ty <> Tlong
            | S _ _ _ => False
            end).
  {
    intros. destruct l; auto. destruct sl; auto. intuition xomega.
  }
  induction tyl; simpl loc_arguments_sf; intros.
  elim H.
  destruct a.
- (* int *)
  destruct H.
  destruct (zlt ofs 0); subst l.
  left; apply ireg_param_in_params.
  split. xomega. congruence.
  eapply INCR. eapply IHtyl; eauto. omega.
- (* float *)
  set (ofs' := align ofs 2) in *.
  assert (ofs <= ofs') by (apply align_le; omega).
  destruct H.
  destruct (zlt ofs' 0); subst l.
  right; apply freg_param_in_params.
  split. xomega. congruence.
  eapply INCR. eapply IHtyl; eauto. omega.
- (* long *)
  set (ofs' := align ofs 2) in *.
  assert (ofs <= ofs') by (apply align_le; omega).
  destruct H.
  destruct (zlt ofs' 0); subst l.
  left; apply ireg_param_in_params.
  split. xomega. congruence.
  destruct H.
  destruct (zlt ofs' 0); subst l.
  left; apply ireg_param_in_params.
  split. xomega. congruence.
  eapply INCR. eapply IHtyl; eauto. omega.
- (* single *)
  destruct H.
  destruct (zlt ofs 0); subst l.
  right; apply freg_param_in_params.
  split. xomega. congruence.
  eapply INCR. eapply IHtyl; eauto. omega.
- (* any32 *)
  destruct H.
  destruct (zlt ofs 0); subst l.
  left; apply ireg_param_in_params.
  split. xomega. congruence.
  eapply INCR. eapply IHtyl; eauto. omega.
- (* any64 *)
  set (ofs' := align ofs 2) in *.
  assert (ofs <= ofs') by (apply align_le; omega).
  destruct H.
  destruct (zlt ofs' 0); subst l.
  right; apply freg_param_in_params.
  split. xomega. congruence.
  eapply INCR. eapply IHtyl; eauto. omega.
Qed.

Lemma loc_arguments_acceptable:
  forall (s: signature) (l: loc),
  In l (loc_arguments s) -> loc_argument_acceptable l.
Proof.
  unfold loc_arguments; intros.
  assert (forall r, In r int_param_regs \/ In r float_param_regs -> In r destroyed_at_call).
  {
    intros. elim H0; simpl; ElimOrEq; OrEq.
  }
  assert (In l (loc_arguments_sf (sig_args s) (-4)) -> loc_argument_acceptable l).
  { intros. red. exploit loc_arguments_sf_charact; eauto. destruct l; auto. }
  assert (In l (loc_arguments_hf (sig_args s) 0 0 0) -> loc_argument_acceptable l).
  { intros. red. exploit loc_arguments_hf_charact; eauto. destruct l; auto. }
  destruct Archi.abi; [ | destruct (cc_vararg (sig_cc s)) ]; auto.
Qed.

Hint Resolve loc_arguments_acceptable: locs.

(** The offsets of [Outgoing] arguments are below [size_arguments s]. *)

Remark size_arguments_hf_above:
  forall tyl ir fr ofs0,
  ofs0 <= size_arguments_hf tyl ir fr ofs0.
Proof.
  induction tyl; simpl; intros.
  omega.
  destruct a.
  destruct (zlt ir 4); eauto. apply Zle_trans with (ofs0 + 1); auto; omega.
  destruct (zlt fr 8); eauto.
  apply Zle_trans with (align ofs0 2). apply align_le; omega.
  apply Zle_trans with (align ofs0 2 + 2); auto; omega.
  set (ir' := align ir 2).
  destruct (zlt ir' 4); eauto.
  apply Zle_trans with (align ofs0 2). apply align_le; omega.
  apply Zle_trans with (align ofs0 2 + 2); auto; omega.
  destruct (zlt fr 8); eauto.
  apply Zle_trans with (ofs0 + 1); eauto. omega.
  destruct (zlt ir 4); eauto. apply Zle_trans with (ofs0 + 1); auto; omega.
  destruct (zlt fr 8); eauto.
  apply Zle_trans with (align ofs0 2). apply align_le; omega.
  apply Zle_trans with (align ofs0 2 + 2); auto; omega.
Qed.

Remark size_arguments_sf_above:
  forall tyl ofs0,
  Zmax 0 ofs0 <= size_arguments_sf tyl ofs0.
Proof.
  induction tyl; simpl; intros.
  omega.
  destruct a; (eapply Zle_trans; [idtac|eauto]).
  xomega.
  assert (ofs0 <= align ofs0 2) by (apply align_le; omega). xomega.
  assert (ofs0 <= align ofs0 2) by (apply align_le; omega). xomega.
  xomega.
  xomega.
  assert (ofs0 <= align ofs0 2) by (apply align_le; omega). xomega.
Qed.

Lemma size_arguments_above:
  forall s, size_arguments s >= 0.
Proof.
  intros; unfold size_arguments. apply Zle_ge.
  assert (0 <= size_arguments_sf (sig_args s) (-4)).
  { change 0 with (Zmax 0 (-4)). apply size_arguments_sf_above. }
  assert (0 <= size_arguments_hf (sig_args s) 0 0 0).
  { apply size_arguments_hf_above. }
  destruct Archi.abi; [ | destruct (cc_vararg (sig_cc s)) ]; auto.
Qed.

Lemma loc_arguments_hf_bounded:
  forall ofs ty tyl ir fr ofs0,
  In (S Outgoing ofs ty) (loc_arguments_hf tyl ir fr ofs0) ->
  ofs + typesize ty <= size_arguments_hf tyl ir fr ofs0.
Proof.
  induction tyl; simpl; intros.
  elim H.
  destruct a.
- (* int *)
  destruct (zlt ir 4); destruct H.
  discriminate.
  eauto.
  inv H. apply size_arguments_hf_above.
  eauto.
- (* float *)
  destruct (zlt fr 8); destruct H.
  discriminate.
  eauto.
  inv H. apply size_arguments_hf_above.
  eauto.
- (* long *)
  destruct (zlt (align ir 2) 4).
  destruct H. discriminate. destruct H. discriminate. eauto.
  destruct H. inv H.
  rewrite <- Zplus_assoc. simpl. apply size_arguments_hf_above.
  destruct H. inv H.
  eapply Zle_trans. 2: apply size_arguments_hf_above. simpl; omega.
  eauto.
- (* float *)
  destruct (zlt fr 8); destruct H.
  discriminate.
  eauto.
  inv H. apply size_arguments_hf_above.
  eauto.
- (* any32 *)
  destruct (zlt ir 4); destruct H.
  discriminate.
  eauto.
  inv H. apply size_arguments_hf_above.
  eauto.
- (* any64 *)
  destruct (zlt fr 8); destruct H.
  discriminate.
  eauto.
  inv H. apply size_arguments_hf_above.
  eauto.
Qed.

Lemma loc_arguments_sf_bounded:
  forall ofs ty tyl ofs0,
  In (S Outgoing ofs ty) (loc_arguments_sf tyl ofs0) ->
  Zmax 0 (ofs + typesize ty) <= size_arguments_sf tyl ofs0.
Proof.
  induction tyl; simpl; intros.
  elim H.
  destruct a.
- (* int *)
  destruct H.
  destruct (zlt ofs0 0); inv H. apply size_arguments_sf_above.
  eauto.
- (* float *)
  destruct H.
  destruct (zlt (align ofs0 2) 0); inv H. apply size_arguments_sf_above.
  eauto.
- (* long *)
  destruct H.
  destruct (zlt (align ofs0 2) 0); inv H.
  rewrite <- Zplus_assoc. simpl. apply size_arguments_sf_above.
  destruct H.
  destruct (zlt (align ofs0 2) 0); inv H.
  eapply Zle_trans. 2: apply size_arguments_sf_above. simpl; xomega.
  eauto.
- (* float *)
  destruct H.
  destruct (zlt ofs0 0); inv H. apply size_arguments_sf_above.
  eauto.
- (* any32 *)
  destruct H.
  destruct (zlt ofs0 0); inv H. apply size_arguments_sf_above.
  eauto.
- (* any64 *)
  destruct H.
  destruct (zlt (align ofs0 2) 0); inv H. apply size_arguments_sf_above.
  eauto.
Qed.

Lemma loc_arguments_bounded:
  forall (s: signature) (ofs: Z) (ty: typ),
  In (S Outgoing ofs ty) (loc_arguments s) ->
  ofs + typesize ty <= size_arguments s.
Proof.
  unfold loc_arguments, size_arguments; intros.
  assert (In (S Outgoing ofs ty) (loc_arguments_sf (sig_args s) (-4)) ->
          ofs + typesize ty <= size_arguments_sf (sig_args s) (-4)).
  { intros. eapply Zle_trans. 2: eapply loc_arguments_sf_bounded; eauto. xomega. }
  assert (In (S Outgoing ofs ty) (loc_arguments_hf (sig_args s) 0 0 0) ->
          ofs + typesize ty <= size_arguments_hf (sig_args s) 0 0 0).
  { intros. eapply loc_arguments_hf_bounded; eauto. }
  destruct Archi.abi; [ | destruct (cc_vararg (sig_cc s)) ]; eauto.
Qed.

Lemma loc_arguments_main:
  loc_arguments signature_main = nil.
Proof.
  unfold loc_arguments.
  destruct Archi.abi; reflexivity.
Qed.


Require Import Verdi.GhostSimulations.
Require Import VerdiRaft.Raft.
Require Import VerdiRaft.CommonTheorems.
Require Import VerdiRaft.OneLeaderPerTermInterface.

Require Import VerdiRaft.CandidateEntriesInterface.
Require Import VerdiRaft.RaftRefinementInterface.
Require Import VerdiRaft.VotesCorrectInterface.
Require Import VerdiRaft.CroniesCorrectInterface.
Require Import VerdiRaft.RefinementCommonTheorems.

Require Import VerdiRaft.LeaderSublogInterface.

Hint Extern 4 (@BaseParams) => apply base_params : typeclass_instances.
Hint Extern 4 (@MultiParams _) => apply multi_params : typeclass_instances.
Hint Extern 4 (@FailureParams _ _) => apply failure_params : typeclass_instances.

Section LeaderSublogProof.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Context {rri : raft_refinement_interface}.
  Context {cei : candidate_entries_interface}.
  Context {vci : votes_correct_interface}.
  Context {cci : cronies_correct_interface}.
  Context {olpti : one_leader_per_term_interface}.

  Ltac prove_in :=
    match goal with
      | [ _ : nwPackets ?net = _,
              _ : In (?p : packet) _ |- _] =>
        assert (In p (nwPackets net)) by (repeat find_rewrite; do_in_app; intuition)
      | [ _ : nwPackets ?net = _,
              _ : pBody ?p = _ |- _] =>
        assert (In p (nwPackets net)) by (repeat find_rewrite; intuition)
    end.

  Notation is_append_entries m :=
    (exists t n prevT prevI entries c,
       m = AppendEntries t n prevT prevI entries c).

  Lemma leader_sublog_invariant_same_state :
    forall net net',
      leader_sublog_host_invariant net ->
      (forall h, log (nwState net h) = log (nwState net' h)) ->
      (forall h, type (nwState net' h) = Leader ->
            type (nwState net h) = Leader /\
            currentTerm (nwState net h) = currentTerm (nwState net' h)) ->
      leader_sublog_host_invariant net'.
  Proof using.
    unfold leader_sublog_host_invariant in *. intros.
    specialize (H leader e h).
    forward H; [apply H1; auto|].
    intuition.
    rewrite H0 in *. specialize (H1 leader). intuition.
    rewrite H7 in *; auto.
    rewrite H0 in *. auto.
  Qed.

  Lemma leader_sublog_invariant_subset :
    forall net net',
      leader_sublog_invariant net ->
      (forall p, is_append_entries (pBody p) -> In p (nwPackets net') -> In p (nwPackets net)) ->
      (forall h, log (nwState net h) = log (nwState net' h)) ->
      (forall h, type (nwState net' h) = Leader ->
            type (nwState net h) = Leader /\
            currentTerm (nwState net h) = currentTerm (nwState net' h)) ->
      leader_sublog_invariant net'.
  Proof using.
    unfold leader_sublog_invariant in *. intros; intuition.
    - eauto using leader_sublog_invariant_same_state.
    - unfold leader_sublog_nw_invariant in *. intros.
      pose proof H1 leader.
      pose proof H2 leader; concludes.
      pose proof H3 leader. intuition.
      symmetry in H13.
      repeat find_rewrite.
      eapply H11; simpl in *; repeat find_rewrite; eauto.
      assert (is_append_entries (pBody p)) by (repeat eexists; eauto).
      eauto.
  Qed.

  Theorem leader_sublog_do_leader :
    raft_net_invariant_do_leader leader_sublog_invariant.
  Proof using.
    unfold raft_net_invariant_do_leader.
    intros.
    unfold doLeader in *.
    break_match; try solve [
                       find_inversion; simpl in *;
                       eapply leader_sublog_invariant_subset;
                       eauto; intuition; simpl in *;
                       repeat find_apply_hyp_hyp; intuition;
                       repeat find_higher_order_rewrite; repeat break_if; subst; intuition].
    break_if.
    - unfold replicaMessage in *. find_inversion. simpl in *.
      unfold leader_sublog_invariant in *; intuition.
      + unfold leader_sublog_host_invariant in *. intros.
        simpl in *. repeat find_higher_order_rewrite.
        repeat break_if; simpl in *; intuition eauto.
      + unfold leader_sublog_nw_invariant in *. intros.
        simpl in *. repeat find_higher_order_rewrite.
        find_apply_hyp_hyp.
        break_if; intuition idtac; simpl in *; subst; intuition eauto;
        simpl in *;
        repeat do_in_map; subst; simpl in *;
        find_inversion; eauto using findGtIndex_in.
    - find_inversion.
      unfold leader_sublog_invariant, leader_sublog_nw_invariant,
      leader_sublog_host_invariant, advanceCommitIndex in *.

      intuition; find_higher_order_rewrite; repeat break_if; simpl in *; subst;
      repeat break_if; simpl in *; eauto;
      find_apply_hyp_hyp; intuition; eauto.
  Qed.

  Lemma leader_sublog_client_request :
    raft_net_invariant_client_request leader_sublog_invariant.
  Proof using olpti.
    unfold raft_net_invariant_client_request.
    intros.
    unfold leader_sublog_invariant, leader_sublog_nw_invariant,
    leader_sublog_host_invariant, handleClientRequest in *. intuition idtac.
    - break_match; find_inversion; simpl in *; repeat find_higher_order_rewrite;
      repeat break_if; subst; simpl in *;
      intuition eauto;
      simpl in *; in_crush_finish; intuition eauto. in_crush; eauto.
      exfalso.
      match goal with
        | H : raft_intermediate_reachable _ |- _ =>
          eapply one_leader_per_term_invariant in H
      end.
      assert (leader = h) by (eapply_prop one_leader_per_term; eauto).
      intuition.
    - break_match; find_inversion; simpl in *; repeat find_higher_order_rewrite;
      repeat break_if; find_apply_hyp_hyp; intuition eauto; subst.
      simpl in *.
      in_crush; eauto.
  Qed.

  Lemma leader_sublog_timeout :
    raft_net_invariant_timeout
      leader_sublog_invariant.
  Proof using.
    unfold raft_net_invariant_timeout. intros.
    unfold leader_sublog_invariant, leader_sublog_nw_invariant,
    leader_sublog_host_invariant, handleTimeout, tryToBecomeLeader in *.
    intuition idtac; simpl in *.
    - repeat find_higher_order_rewrite; repeat break_match; repeat find_inversion;
      subst; simpl in *;
      intuition eauto; solve_by_inversion.
    - repeat find_higher_order_rewrite; repeat break_match; repeat find_inversion;
      subst; simpl in *;
      intuition eauto;
      find_apply_hyp_hyp; intuition eauto; try solve_by_inversion;
      in_crush; repeat find_inversion; discriminate.
  Qed.

  Lemma leader_sublog_append_entries :
    raft_net_invariant_append_entries
      leader_sublog_invariant.
  Proof using.
    unfold raft_net_invariant_append_entries. intros.
    unfold leader_sublog_invariant, leader_sublog_nw_invariant,
    leader_sublog_host_invariant, handleAppendEntries, advanceCurrentTerm in *.
    intuition idtac; simpl in *.
    - repeat find_higher_order_rewrite; repeat break_match; repeat find_inversion;
      subst; simpl in *;
      intuition eauto; try solve_by_inversion;
      do_in_app; intuition; eauto using removeAfterIndex_in.
    - repeat find_higher_order_rewrite; repeat break_match; repeat find_inversion;
      subst; simpl in *;
      intuition eauto;
      find_apply_hyp_hyp; intuition eauto; subst; try discriminate.
  Qed.

  Lemma leader_sublog_append_entries_reply :
    raft_net_invariant_append_entries_reply
      leader_sublog_invariant.
  Proof using.
    unfold raft_net_invariant_append_entries_reply. intros.
    unfold leader_sublog_invariant, leader_sublog_nw_invariant,
    leader_sublog_host_invariant, handleAppendEntriesReply, advanceCurrentTerm in *.
    intuition idtac; simpl in *.
    - repeat find_higher_order_rewrite; repeat break_match; repeat find_inversion;
      subst; simpl in *;
      intuition eauto; try solve_by_inversion.
    - repeat find_higher_order_rewrite; repeat break_match; repeat find_inversion;
      subst; simpl in *;
      intuition eauto;
      find_apply_hyp_hyp; intuition eauto; try discriminate.
  Qed.

  Lemma leader_sublog_request_vote :
    raft_net_invariant_request_vote
      leader_sublog_invariant.
  Proof using.
    unfold raft_net_invariant_request_vote. intros.
    unfold leader_sublog_invariant, leader_sublog_nw_invariant,
    leader_sublog_host_invariant, handleRequestVote, advanceCurrentTerm in *.
    intuition idtac; simpl in *.
    - repeat find_higher_order_rewrite; repeat break_match; repeat find_inversion;
      subst; simpl in *;
      intuition eauto; try solve_by_inversion.
    - repeat find_higher_order_rewrite; repeat break_match; repeat find_inversion;
      subst; simpl in *;
      intuition eauto;
      find_apply_hyp_hyp; intuition eauto; subst; try discriminate.
  Qed.

  Definition CandidateEntriesLowered net e h :=
      currentTerm (nwState net h) = eTerm e ->
      wonElection (dedup name_eq_dec (votesReceived (nwState net h))) = true ->
      type (nwState net h) <> Candidate.

  Lemma candidate_entries_lowered' :
    forall net,
      CandidateEntries net ->
      votes_correct net ->
      cronies_correct net ->
      forall h h' e,
        In e (log (snd (nwState net h'))) ->
        CandidateEntriesLowered (deghost net) e h.
  Proof using rri.
    unfold CandidateEntriesLowered, CandidateEntries, votes_correct, cronies_correct.
    intros. break_and.
    rewrite deghost_spec.

    apply_prop_hyp candidateEntries_host_invariant In.
    eapply candidateEntries_wonElection; auto; repeat find_rewrite_lem deghost_spec; eauto.
  Qed.

  Lemma candidate_entries_lowered :
    forall net,
      raft_intermediate_reachable net ->
      forall h h' e,
        In e (log (nwState net h')) ->
        CandidateEntriesLowered net e h.
  Proof using cci vci cei rri.
    intros net H.
    pattern net.
    apply lower_prop; auto.
    clear H net.
    intros.
    repeat match goal with
           | [ H : _ |- _ ] => rewrite deghost_spec in H
           end.
    eapply candidate_entries_lowered';
      eauto using candidate_entries_invariant, votes_correct_invariant, cronies_correct_invariant.
  Qed.

  Definition CandidateEntriesLowered_rvr net e p :=
    In p (nwPackets net) ->
    pBody p = RequestVoteReply (eTerm e) true ->
    currentTerm (nwState net (pDst p)) = eTerm e ->
    wonElection (dedup name_eq_dec (pSrc p :: votesReceived (nwState net (pDst p)))) = true ->
    type (nwState net (pDst p)) <> Candidate.

  Lemma deghost_packet_exists :
    forall net p,
      In p (nwPackets (deghost net)) ->
      exists (q : packet (params := raft_refined_multi_params (raft_params := raft_params))),
        In q (nwPackets net) /\ p = deghost_packet q.
  Proof using.
    unfold deghost.
    simpl.
    intros.
    do_in_map.
    eauto.
  Qed.

  Lemma candidate_entries_lowered_rvr' :
    forall net,
      CandidateEntries net ->
      votes_correct net ->
      cronies_correct net ->
      forall p h e,
        In e (log (snd (nwState net h))) ->
        CandidateEntriesLowered_rvr (deghost net) e p.
  Proof using rri.
    unfold CandidateEntriesLowered_rvr, CandidateEntries.
    intros. break_and.
    rewrite deghost_spec.

    find_apply_lem_hyp deghost_packet_exists.
    break_exists.  break_and. subst.

    apply_prop_hyp candidateEntries_host_invariant In.
    eapply wonElection_candidateEntries_rvr; auto;
    repeat find_rewrite_lem deghost_spec; eauto.
  Qed.

  Lemma candidate_entries_lowered_rvr :
    forall net,
      raft_intermediate_reachable net ->
      forall p h e,
        In e (log (nwState net h)) ->
        CandidateEntriesLowered_rvr net e p.
  Proof using cci vci cei rri.
    intros net H.
    pattern net.
    apply lower_prop; auto.
    clear H net.
    intros.
    repeat match goal with
           | [ H : _ |- _ ] => rewrite deghost_spec in H
           end.
    eapply candidate_entries_lowered_rvr';
      eauto using candidate_entries_invariant, votes_correct_invariant, cronies_correct_invariant.
  Qed.

  Lemma candidate_entries_lowered_nw' :
    forall net,
      CandidateEntries net ->
      votes_correct net ->
      cronies_correct net ->
      forall h p e t li pli plt es lc,
        pBody p = AppendEntries t li pli plt es lc ->
        In p (nwPackets (deghost net)) ->
        In e es ->
        CandidateEntriesLowered (deghost net) e h.
  Proof using rri.
    unfold CandidateEntriesLowered, CandidateEntries, votes_correct, cronies_correct.
    intros. break_and.
    rewrite deghost_spec.

    find_apply_lem_hyp deghost_packet_exists.
    break_exists. break_and. subst.

    eapply_prop_hyp candidateEntries_nw_invariant In; eauto.
    unfold candidateEntries in *. break_exists. break_and.
    match goal with
    | H : wonElection _ = _ |- _ =>
      eapply wonElection_one_in_common in H; [|clear H; eauto]
    end.
    break_exists. break_and.
    repeat match goal with
           | [ H : _ |- _ ] => rewrite deghost_spec in H
           end.

    intro.
    assert (h = x0).
    {
      eapply_prop one_vote_per_term;
      eapply_prop cronies_votes.
      - eapply_prop votes_received_cronies; eauto.
      - find_reverse_rewrite. auto.
    }
    subst.
    concludes. contradiction.
  Qed.

  Lemma candidate_entries_lowered_nw :
    forall net,
      raft_intermediate_reachable net ->
      forall h p e t li pli plt es lc,
        pBody p = AppendEntries t li pli plt es lc ->
        In p (nwPackets net) ->
        In e es ->
        CandidateEntriesLowered net e h.
  Proof using cci vci cei rri.
    intros net H.
    pattern net.
    apply lower_prop; auto.
    clear H net.
    intros.
    repeat match goal with
           | [ H : _ |- _ ] => rewrite deghost_spec in H
           end.
    eapply candidate_entries_lowered_nw';
      eauto using candidate_entries_invariant, votes_correct_invariant, cronies_correct_invariant.
  Qed.

  Lemma candidate_entries_lowered_nw_rvr' :
    forall net,
      CandidateEntries net ->
      votes_correct net ->
      cronies_correct net ->
      forall p' p e t li pli plt es lc,
        pBody p = AppendEntries t li pli plt es lc ->
        In p (nwPackets (deghost net)) ->
        In e es ->
        CandidateEntriesLowered_rvr (deghost net) e p'.
  Proof using rri.
    unfold CandidateEntriesLowered_rvr, CandidateEntries, votes_correct, cronies_correct.
    intros. break_and.
    rewrite deghost_spec.

    find_apply_lem_hyp deghost_packet_exists.
    find_apply_lem_hyp deghost_packet_exists.
    break_exists.  break_and. subst.
    eapply_prop_hyp votes_nw pBody. concludes.
    eapply_prop_hyp candidateEntries_nw_invariant pBody; auto.

    find_insterU. conclude_using eauto.
    unfold candidateEntries in *.
    break_exists. break_and.

    match goal with
    | H : wonElection _ = _ |- _ =>
      eapply wonElection_one_in_common in H; [|clear H; eauto]
    end.
    break_exists. break_and.
    repeat match goal with
           | [ H : _ |- _ ] => rewrite deghost_spec in H
           end.
    simpl in *.
    break_or_hyp.
    - apply_prop_hyp cronies_votes In.
      assert (pDst x = x1) by (eapply_prop one_vote_per_term; eauto).
      subst. auto.
    - intro.
      assert (pDst x = x1).
      { eapply_prop one_vote_per_term;
        eapply_prop cronies_votes.
        - eapply_prop votes_received_cronies; eauto.
        - repeat find_reverse_rewrite. auto.
      }
      subst.
      concludes. contradiction.
  Qed.

  Lemma candidate_entries_lowered_nw_rvr :
    forall net,
      raft_intermediate_reachable net ->
      forall p' p e t li pli plt es lc,
        pBody p = AppendEntries t li pli plt es lc ->
        In p (nwPackets net) ->
        In e es ->
        CandidateEntriesLowered_rvr net e p'.
  Proof using cci vci cei rri.
    intros net H.
    pattern net.
    apply lower_prop; auto.
    clear H net.
    intros.
    repeat match goal with
           | [ H : _ |- _ ] => rewrite deghost_spec in H
           end.
    eapply candidate_entries_lowered_nw_rvr';
      eauto using candidate_entries_invariant, votes_correct_invariant, cronies_correct_invariant.
  Qed.

  Lemma leader_sublog_request_vote_reply :
    raft_net_invariant_request_vote_reply
      leader_sublog_invariant.
  Proof using cci vci cei rri.
    unfold raft_net_invariant_request_vote_reply.
    unfold leader_sublog_invariant, leader_sublog_nw_invariant,
           leader_sublog_host_invariant, handleRequestVoteReply, advanceCurrentTerm.
    intuition idtac; simpl in *.
    - repeat find_higher_order_rewrite; repeat break_match; repeat find_inversion;
      subst; simpl in *; intuition eauto; try discriminate.
      + exfalso. eapply candidate_entries_lowered; eauto.
      + rewrite dedup_not_in_cons in * by auto.
        exfalso. eapply candidate_entries_lowered_rvr; eauto.
        do_bool.
        find_rewrite.
        f_equal.
        omega.
    - repeat find_higher_order_rewrite; repeat break_match; repeat find_inversion;
      subst; simpl in *; intuition eauto;
      find_apply_hyp_hyp; intuition eauto; subst; try discriminate.
      + exfalso. eapply candidate_entries_lowered_nw; eauto.
      + rewrite dedup_not_in_cons in * by auto.
        exfalso. eapply candidate_entries_lowered_nw_rvr; eauto.
        do_bool.
        find_rewrite.
        f_equal.
        omega.
  Qed.

  Lemma leader_sublog_do_generic_server :
    raft_net_invariant_do_generic_server
      leader_sublog_invariant.
  Proof using.
    unfold raft_net_invariant_do_generic_server.
    intros.
    unfold leader_sublog_invariant, leader_sublog_nw_invariant,
    leader_sublog_host_invariant, doGenericServer in *.
    intuition idtac; simpl in *.
    - repeat find_higher_order_rewrite; repeat break_match; repeat find_inversion;
      use_applyEntries_spec;
      subst; simpl in *;
      intuition eauto;
      try solve_by_inversion.
    - repeat find_higher_order_rewrite; repeat break_match; repeat find_inversion;
      use_applyEntries_spec;
      subst; simpl in *;
      intuition eauto;
      find_apply_hyp_hyp; intuition eauto; subst; try discriminate.
  Qed.

  Lemma leader_sublog_state_same_packet_subset :
    raft_net_invariant_state_same_packet_subset
      leader_sublog_invariant.
  Proof using.
    unfold raft_net_invariant_state_same_packet_subset.
    intros.
    unfold leader_sublog_invariant, leader_sublog_nw_invariant,
    leader_sublog_host_invariant in *. intuition idtac;
      repeat find_reverse_higher_order_rewrite; intuition eauto.
  Qed.

  Lemma leader_sublog_reboot :
    raft_net_invariant_reboot
      leader_sublog_invariant.
  Proof using.
    unfold raft_net_invariant_reboot. intros.
    unfold leader_sublog_invariant, leader_sublog_nw_invariant,
    leader_sublog_host_invariant, reboot in *. intuition idtac.
    - repeat find_higher_order_rewrite.
      simpl in *. repeat break_match; subst; simpl in *; intuition eauto; discriminate.
    - repeat find_higher_order_rewrite.
      simpl in *. repeat find_rewrite.
      repeat break_match; subst; simpl in *;
      intuition eauto; try discriminate.
  Qed.

  Theorem leader_sublog_init :
    raft_net_invariant_init leader_sublog_invariant.
  Proof using.
    unfold raft_net_invariant_init, leader_sublog_invariant,
    leader_sublog_host_invariant, leader_sublog_nw_invariant;
    intuition.
  Qed.

  Theorem leader_sublog_invariant_invariant :
    forall net,
      raft_intermediate_reachable net ->
      leader_sublog_invariant net.
  Proof using olpti cci vci cei rri.
    intros.
    eapply raft_net_invariant; eauto.
    - apply leader_sublog_init.
    - apply leader_sublog_client_request.
    - apply leader_sublog_timeout.
    - apply leader_sublog_append_entries.
    - apply leader_sublog_append_entries_reply.
    - apply leader_sublog_request_vote.
    - apply leader_sublog_request_vote_reply.
    - apply leader_sublog_do_leader.
    - apply leader_sublog_do_generic_server.
    - apply leader_sublog_state_same_packet_subset.
    - apply leader_sublog_reboot.
  Qed.

  Instance lsi : leader_sublog_interface.
  Proof.
    split.
    auto using leader_sublog_invariant_invariant.
  Qed.
End LeaderSublogProof.