From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
From extructures Require Import ord fmap.
From CoqUtils Require Import word.

Require Import lib.utils lib.fmap_utils.
Require Import common.types.
Require Import concrete.concrete.
Require Import symbolic.symbolic.
Require Import cfi.symbolic.
Require Import cfi.property.
Require Import cfi.rules.
Require Import cfi.classes.
Require Import symbolic.rules.
Require Import symbolic.refinement_common.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module Conc.
Section ConcreteSection.

Context {mt : machine_types}
        {ops : machine_ops mt}
        {ids : cfi_id mt}
        {e : rules.fencodable mt cfi_tags}.

Variable cfg : id -> id -> bool.

Definition valid_jmp := classes.valid_jmp cfg.

(*allow attacker to change only things tagged USER DATA! all the rest should be equiv*)

Definition no_violation (cst : Concrete.state mt) :=
  let '(Concrete.State mem _  _ pc@tpc _) := cst in
  (forall i cti ti src,
    getm mem pc = Some i@cti ->
    @fdecode _ _ e Symbolic.M cti = Some (User ti) ->
    @fdecode _ _ e Symbolic.P tpc = Some (INSTR (Some src)) ->
    exists dst,
        ti = INSTR (Some dst) /\ cfg src dst) /\
  (forall i cti ti src,
     getm mem pc = Some i@cti ->
     @fdecode _ _ e Symbolic.M cti = Some (Entry ti) ->
     @fdecode _ _ e Symbolic.P tpc = Some (INSTR (Some src)) ->
     exists dst,
       ti = INSTR (Some dst) /\ cfg src dst).

Definition cast k : Symbolic.tag_type cfi_tags k -> cfi_tag :=
  match k return Symbolic.tag_type cfi_tags k -> cfi_tag with
  | Symbolic.M => fun t => t
  | _ => fun t => t
  end.

Definition cast' k (t : cfi_tag) : Symbolic.tag_type cfi_tags k :=
  match k with
  | Symbolic.M => t
  | _ => t
  end.

(*Defined in terms of atom_equiv for symbolic tags*)
(* TODO: as a sanity check, please prove reflexivity for this and
   the other attacker relations. That will ensure that the attacker
   can at least keep things the same. *)
Inductive atom_equiv k (a : atom (mword mt) (mword mt)) (a' : atom (mword mt) (mword mt)) : Prop :=
  | user_equiv : forall v v' ct ut ct' ut',
                   a = v@ct ->
                   @fdecode _ _ e k ct = Some (wtag_of_tag ut) ->
                   a' = v'@ct' ->
                   @fdecode _ _ e k ct' = Some (wtag_of_tag ut') ->
                   Sym.atom_equiv v@(cast ut) v'@(cast ut') ->
                   atom_equiv k a a'
  | any_equiv : (~ exists ut, @fdecode _ _ e k (taga a) = Some (wtag_of_tag ut)) ->
                a = a' ->
                atom_equiv k a a'.

Definition equiv (mem mem' : Concrete.memory mt) :=
  pointwise (atom_equiv Symbolic.M) mem mem'.

Definition reg_equiv (regs : Concrete.registers mt) (regs' : Concrete.registers mt) :=
  forall r, exists x x',
    getm regs r = Some x /\
    getm regs' r = Some x' /\
    atom_equiv Symbolic.R x x'.

Inductive step_a : Concrete.state mt ->
                   Concrete.state mt -> Prop :=
| step_attack : forall mem reg cache pc tpc epc mem' reg'
                  (INUSER: @fdecode _ _ e Symbolic.P tpc)
                  (REQUIV: reg_equiv reg reg')
                  (MEQUIV: equiv mem mem'),
                  step_a (Concrete.State mem reg cache pc@tpc epc)
                         (Concrete.State mem' reg' cache pc@tpc epc).

Local Notation "x .+1" := (x + 1)%w.
Local Open Scope word_scope.

Definition csucc (st : Concrete.state mt) (st' : Concrete.state mt) : bool :=
  let pc_s := vala (Concrete.pc st) in
  let pc_s' := vala (Concrete.pc st') in
  if in_monitor st || in_monitor st' then true else
  match (getm (Concrete.mem st) pc_s) with
    | Some i =>
      match (@fdecode _ _ e Symbolic.M (taga i)) with
        | Some (User (INSTR (Some src))) =>
          match decode_instr (vala i) with
            | Some (Jump r)
            | Some (Jal r) =>
              match (getm (Concrete.mem st) pc_s') with
                | Some i' =>
                  match (@fdecode _ _ e Symbolic.M (taga i')) with
                    | Some (User (INSTR (Some dst))) =>
                      cfg src dst
                    | Some (Entry (INSTR (Some dst))) =>
                      is_nop (vala i') && cfg src dst
                    | _ => false
                  end
                | _ => false
              end
            | Some (Bnz r imm) =>
              (pc_s' == pc_s .+1) || (pc_s' == pc_s + swcast imm)
            | None => false
            | _ => pc_s' == pc_s .+1
          end
        | Some (User (INSTR None)) =>
          match decode_instr (vala i) with
            | Some (Jump r)
            | Some (Jal r) =>
              false
            | Some (Bnz r imm) =>
              (pc_s' == pc_s .+1) || (pc_s' == pc_s + swcast imm)
            | None => false
            | _ => pc_s' == pc_s .+1
          end
       (* this says that if cst,cst' is in user mode then it's
          not sensible to point to monitor memory*)
        | Some (User DATA)
        | Some (Entry _)
        | None => false
      end
    | None => false
  end.

Instance sp : Symbolic.params := Sym.sym_cfi cfg.

Variable mi : refinement_common.monitor_invariant.

Variable stable : Symbolic.syscall_table mt.

(* This is basically the initial_refine assumption on preservation *)
Definition cinitial (cs : Concrete.state mt) :=
  exists ss, Sym.initial stable ss /\ refine_state mi stable ss cs.

Variable masks : Concrete.Masks.

Definition all_attacker (xs : seq (Concrete.state mt)) : Prop :=
  forall x1 x2, In2 x1 x2 xs -> step_a x1 x2 /\ ~ Concrete.step _ masks x1 x2.

Lemma all_attacker_red ast ast' axs :
  all_attacker (ast :: ast' :: axs) ->
  all_attacker (ast' :: axs).
Proof.
  intros ATTACKER asi asj IN2.
  assert (IN2' : In2 asi asj (ast :: ast' :: axs))
    by (simpl; auto).
  apply ATTACKER in IN2'.
  assumption.
Qed.

Definition stopping (ss : seq (Concrete.state mt)) : Prop :=
  (all_attacker ss /\ all in_user ss)
  \/
  (exists user monitor,
    ss = user ++ monitor /\
    all_attacker user /\ all in_user user /\
    all in_monitor monitor).

Program Instance concrete_cfi_machine : cfi_machine := {
  state := [eqType of Concrete.state mt];
  initial s := cinitial s;

  step s1 s2 := Concrete.step ops masks s1 s2;
  step_a := step_a;

  succ := csucc;
  stopping := stopping
}.

End ConcreteSection.

End Conc.


Require Import GhostSimulations.
Require Import Raft.
Require Import RaftRefinementInterface.
Require Import RaftMsgRefinementInterface.

Require Import CommonTheorems.

Require Import SpecLemmas.

Require Import UpdateLemmas.
Local Arguments update {_} {_} {_} _ _ _ _ : simpl never.

Require Import RefinedLogMatchingLemmasInterface.
Require Import GhostLogCorrectInterface.
Require Import GhostLogsLogPropertiesInterface.
Require Import TermSanityInterface.
Require Import AllEntriesLeaderSublogInterface.
Require Import GhostLogAllEntriesInterface.

Require Import GhostLogLogMatchingInterface.

Section GhostLogLogMatching.

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

  Context {rmri : raft_msg_refinement_interface}.
  Context {rlmli : refined_log_matching_lemmas_interface}.
  Context {glci : ghost_log_correct_interface}.
  Context {lphogli : log_properties_hold_on_ghost_logs_interface}.
  Context {tsi : term_sanity_interface}.
  Context {aelsi : allEntries_leader_sublog_interface}.
  Context {glaei : ghost_log_allEntries_interface}.

  Ltac update_destruct :=
    match goal with
      | [ |- context [ update _ ?y _ ?x ] ] => destruct (name_eq_dec y x)
    end.

  Ltac update_destruct_hyp :=
    match goal with
      | [ _ : context [ update _ ?y _ ?x ] |- _ ] => destruct (name_eq_dec y x)
    end.

  Ltac destruct_update :=
    repeat (first [update_destruct_hyp|update_destruct]; subst; rewrite_update).

  Definition ghost_log_entries_match_nw (net : network) : Prop :=
    forall p p',
      In p (nwPackets net) ->
      In p' (nwPackets net) ->
      entries_match (fst (pBody p)) (fst (pBody p')).

  Definition ghost_log_entries_match (net : network) : Prop :=
    ghost_log_entries_match_host net /\
    ghost_log_entries_match_nw net.

  Definition lifted_entries_contiguous net :=
    forall h,
      contiguous_range_exact_lo (log (snd (nwState net h))) 0.

  Definition lifted_entries_sorted net :=
    forall h,
      sorted (log (snd (nwState net h))).

  Lemma lifted_entries_contiguous_invariant :
    forall (net : @network _ raft_msg_refined_multi_params),
      msg_refined_raft_intermediate_reachable net ->
      lifted_entries_contiguous net.
  Proof using rlmli rmri.
    intros.
    enough (entries_contiguous (mgv_deghost net)) by
        (unfold entries_contiguous, lifted_entries_contiguous, mgv_deghost in *;
         simpl in *;
         repeat break_match; simpl in *; auto).
    apply msg_lift_prop; eauto using entries_contiguous_invariant.
  Qed.

  Lemma lifted_entries_sorted_invariant :
    forall (net : @network _ raft_msg_refined_multi_params),
      msg_refined_raft_intermediate_reachable net ->
      lifted_entries_sorted net.
  Proof using rlmli rmri.
    intros.
    enough (entries_sorted (mgv_deghost net)) by
        (unfold entries_sorted, lifted_entries_sorted, mgv_deghost in *;
         simpl in *;
         repeat break_match; simpl in *; auto).
    apply msg_lift_prop; eauto using entries_sorted_invariant.
  Qed.

  Definition lifted_entries_contiguous_nw net :=
    forall p t n pli plt es ci,
      In p (nwPackets net) ->
      snd (pBody p) = AppendEntries t n pli plt es ci ->
      contiguous_range_exact_lo es pli.

  Lemma lifted_entries_contiguous_nw_invariant :
    forall (net : @network _ raft_msg_refined_multi_params),
      msg_refined_raft_intermediate_reachable net ->
      lifted_entries_contiguous_nw net.
  Proof using rlmli rmri.
    intros.
    assert (entries_contiguous_nw (mgv_deghost net)) by
        (apply msg_lift_prop; eauto using entries_contiguous_nw_invariant).
    unfold entries_contiguous_nw, lifted_entries_contiguous_nw, mgv_deghost in *;
      intros.
    simpl in *;
      repeat break_match; simpl in *; auto.
    match goal with
      | H : context [contiguous_range_exact_lo] |- _ =>
        specialize (H (@mgv_deghost_packet _ _ _ ghost_log_params p));
          eapply H; simpl in *; eauto
    end.
    apply in_map_iff. eexists; eauto.
  Qed.

  Definition lifted_entries_match net :=
    forall h h',
      entries_match (log (snd (nwState net h))) (log (snd (nwState net h'))).

  Lemma lifted_entries_match_invariant :
    forall (net : @network _ raft_msg_refined_multi_params),
      msg_refined_raft_intermediate_reachable net ->
      lifted_entries_match net.
  Proof using rlmli rmri.
    intros.
    unfold lifted_entries_match; intros.
    find_eapply_lem_hyp msg_lift_prop;
      [|intros; eapply (entries_match_invariant ltac:(eauto) h h'); eauto].
    simpl in *.
    repeat break_match; simpl in *; auto.
  Qed.

  Definition lifted_no_entries_past_current_term_host net :=
    forall (h : name) e,
      In e (log (snd (nwState net h))) ->
      eTerm e <= currentTerm (snd (nwState net h)).

  Lemma lifted_no_entries_past_current_term_host_invariant :
    forall (net : @network _ raft_msg_refined_multi_params),
      msg_refined_raft_intermediate_reachable net ->
      lifted_no_entries_past_current_term_host net.
  Proof using tsi rmri.
    intros.
    enough (no_entries_past_current_term_host (deghost (mgv_deghost net))) by
        (unfold no_entries_past_current_term_host, lifted_no_entries_past_current_term_host, deghost, mgv_deghost in *;
         simpl in *;
         repeat break_match; simpl in *; auto).
    apply msg_lift_prop_all_the_way; eauto.
    intros.
    eapply no_entries_past_current_term_invariant; eauto.
  Qed.

  Lemma ghost_log_sorted :
    forall net p,
      msg_refined_raft_intermediate_reachable net ->
      In p (nwPackets net) ->
      sorted (fst (pBody p)).
  Proof using lphogli rlmli rmri.
    assert (msg_log_property sorted) by
        (unfold msg_log_property; intros; eapply lifted_entries_sorted_invariant; eauto).
    intros.
    find_eapply_lem_hyp log_properties_hold_on_ghost_logs_invariant; eauto.
  Qed.

  Lemma ghost_log_contiguous :
    forall net p,
      msg_refined_raft_intermediate_reachable net ->
      In p (nwPackets net) ->
      contiguous_range_exact_lo (fst (pBody p)) 0.
  Proof using lphogli rlmli rmri.
    assert (msg_log_property (fun x => contiguous_range_exact_lo x 0)) by
        (unfold msg_log_property; intros; eapply lifted_entries_contiguous_invariant; eauto).
    intros.
    find_eapply_lem_hyp log_properties_hold_on_ghost_logs_invariant;
      eauto; simpl in *; auto.
  Qed.

  Definition lifted_allEntries_leader_sublog (net : network) :=
    forall leader e h,
      type (snd (nwState net leader)) = Leader ->
      In e (map snd (allEntries (fst (nwState net h)))) ->
      eTerm e = currentTerm (snd (nwState net leader)) ->
      In e (log (snd (nwState net leader))).

  Lemma lifted_allEntries_leader_sublog_invariant :
    forall (net : @network _ raft_msg_refined_multi_params),
      msg_refined_raft_intermediate_reachable net ->
      lifted_allEntries_leader_sublog net.
  Proof using aelsi rmri.
    intros.
    unfold lifted_allEntries_leader_sublog; intros.
    find_eapply_lem_hyp msg_lift_prop;
      [|intros; eapply allEntries_leader_sublog_invariant; eauto].
    simpl in *.
    unfold allEntries_leader_sublog in *.
    unfold mgv_deghost in *.
    simpl in *.
    repeat break_match; simpl in *; eauto.
  Qed.

  Lemma ghost_log_entries_match_init :
    msg_refined_raft_net_invariant_init ghost_log_entries_match.
  Proof using.
    red. split;
      red; intros; simpl in *; intuition.
  Qed.

  Lemma handleAppendEntries_ghost_log:
    forall (p : packet) (net : network) (d : raft_data)
      (m : msg) (t : term) (n : name) (pli : logIndex)
      (plt : term) (es : list entry) (ci : logIndex)
      (h : Net.name),
      msg_refined_raft_intermediate_reachable net ->
      entries_match (log (snd (nwState net h))) (fst (pBody p)) ->
      handleAppendEntries h (snd (nwState net h)) t n pli plt es ci = (d, m) ->
      snd (pBody p) = AppendEntries t n pli plt es ci ->
      In p (nwPackets net) -> log d = log (snd (nwState net h)) \/ log d = fst (pBody p).
  Proof using lphogli glci rlmli rmri.
    intros.
    find_copy_eapply_lem_hyp ghost_log_correct_invariant; eauto;
    repeat conclude_using eauto.
    find_apply_lem_hyp handleAppendEntries_log.
    intuition; subst; auto.
    - repeat find_rewrite.
      rewrite sorted_findGtIndex_0; auto;
      [|eapply ghost_log_sorted; eauto].
      intros.
      eapply ghost_log_contiguous; eauto.
    - right.
      repeat find_rewrite.
      break_exists. intuition.
      subst.
      replace (eIndex x0) with (eIndex x).
      eapply thing; eauto; repeat find_rewrite; auto using findGtIndex_Prefix;
      try solve [eapply ghost_log_sorted; eauto];
      try solve [eapply ghost_log_contiguous; eauto];
      try solve [eapply lifted_entries_sorted_invariant; eauto];
      try solve [eapply lifted_entries_contiguous_nw_invariant; eauto].
  Qed.

  Hint Resolve entries_match_refl.
  Hint Resolve entries_match_sym.

  Lemma ghost_log_entries_match_append_entries :
    msg_refined_raft_net_invariant_append_entries' ghost_log_entries_match.
  Proof using lphogli glci rlmli rmri.
    red.
    split; red; intros; simpl in *; intuition;
    unfold ghost_log_entries_match in *; break_and.
    - repeat find_higher_order_rewrite; destruct_update; simpl in *; eauto.
      + match goal with
        | [ H : msg_refined_raft_intermediate_reachable (mkNetwork _ _) |- _ ] => clear H
        end.
        find_apply_hyp_hyp. intuition.
        * find_eapply_lem_hyp handleAppendEntries_ghost_log; eauto.
          intuition; repeat find_rewrite; eauto.
        * subst. simpl in *.
          find_eapply_lem_hyp handleAppendEntries_ghost_log; eauto.
      + find_apply_hyp_hyp. intuition; eauto.
        subst. simpl in *. unfold write_ghost_log.
        simpl.
        replace d with (snd (nwState {| nwPackets := ps'; nwState := st' |} (pDst p))) by
            (simpl; find_higher_order_rewrite; rewrite_update; reflexivity).
        replace (nwState net h) with (nwState {| nwPackets := ps'; nwState := st' |} h)by
            (simpl; find_higher_order_rewrite; rewrite_update; reflexivity).
        apply lifted_entries_match_invariant; auto.
    - find_apply_hyp_hyp.
      find_apply_hyp_hyp.
      intuition.
      + eauto.
      + subst. simpl in *.
        unfold write_ghost_log.
        simpl.
        match goal with
        | [ H : context [handleAppendEntries] |- _ ] =>
          eapply handleAppendEntries_ghost_log in H; eauto
        end.
        intuition.
        * find_rewrite. eauto.
        * find_rewrite. eauto.
      + subst. simpl in *.
        unfold write_ghost_log.
        simpl.
        match goal with
        | [ H : context [handleAppendEntries] |- _ ] =>
          eapply handleAppendEntries_ghost_log in H; eauto
        end.
        intuition.
        * find_rewrite. eauto.
        * find_rewrite. eauto.
      + subst. simpl in *. apply entries_match_refl.
  Qed.

  Ltac packet_simpl :=
    first [do_in_map; subst; simpl in *;
           unfold add_ghost_msg in *;
           do_in_map; subst; simpl in *|subst; simpl in *].

  Arguments write_ghost_log / _ _ _ _ _.

  Lemma ghost_log_entries_match_append_entries_reply :
    msg_refined_raft_net_invariant_append_entries_reply ghost_log_entries_match.
  Proof using rlmli rmri.
    red.
    split; red; intros; simpl in *; intuition;
    unfold ghost_log_entries_match in *; break_and.
    - repeat find_higher_order_rewrite; destruct_update; simpl in *; eauto.
      + find_apply_hyp_hyp. intuition.
        * erewrite handleAppendEntriesReply_log; eauto.
        * packet_simpl. apply entries_match_refl.
      + find_apply_hyp_hyp. intuition.
        * eauto.
        * packet_simpl.
          erewrite handleAppendEntriesReply_log with (st'0 := d) by eauto.
          eapply lifted_entries_match_invariant; eauto.
    - find_apply_hyp_hyp.
      find_apply_hyp_hyp.
      intuition.
      + eauto.
      + subst. simpl in *.
        do_in_map. subst. simpl in *.
        unfold add_ghost_msg in *. do_in_map. subst. simpl in *.
        erewrite handleAppendEntriesReply_same_log by eauto.
        eauto.
      + subst. simpl in *.
        do_in_map. subst. simpl in *.
        unfold add_ghost_msg in *. do_in_map. subst. simpl in *.
        erewrite handleAppendEntriesReply_same_log by eauto.
        eauto.
      + subst. simpl in *.
        repeat do_in_map. subst. simpl in *.
        unfold add_ghost_msg in *. repeat do_in_map. subst. simpl in *.
        auto.
  Qed.

  Lemma ghost_log_entries_match_request_vote :
    msg_refined_raft_net_invariant_request_vote' ghost_log_entries_match.
  Proof using rlmli rmri.
    red.
    split; red; intros; simpl in *; intuition;
    unfold ghost_log_entries_match in *; break_and.
    - repeat find_higher_order_rewrite; destruct_update; simpl in *; eauto.
      + find_apply_hyp_hyp. intuition.
        * erewrite handleRequestVote_log; eauto.
        * packet_simpl. auto.
      + find_apply_hyp_hyp. intuition.
        * eauto.
        * packet_simpl.
          erewrite handleRequestVote_log with (st'0 := d) by eauto.
          eapply lifted_entries_match_invariant; eauto.
    - find_apply_hyp_hyp.
      find_apply_hyp_hyp.
      intuition.
      + eauto.
      + subst. simpl in *. erewrite handleRequestVote_log; eauto.
      + subst. simpl in *. erewrite handleRequestVote_log; eauto.
      + subst. simpl in *. erewrite handleRequestVote_log; eauto.
  Qed.

  Lemma ghost_log_entries_match_request_vote_reply :
    msg_refined_raft_net_invariant_request_vote_reply ghost_log_entries_match.
  Proof using.
    red.
    split; red; intros; simpl in *; intuition;
    unfold ghost_log_entries_match in *; break_and.
    - repeat find_higher_order_rewrite; destruct_update; simpl in *; eauto.
      erewrite handleRequestVoteReply_log; eauto.
    - repeat find_apply_hyp_hyp; intuition; eauto;
      repeat packet_simpl; eauto.
  Qed.

  Lemma sorted_entries_match_cons :
    forall l l' e,
      sorted (e :: l) ->
      entries_match l l' ->
      (~ exists e', eIndex e' = eIndex e /\ eTerm e' = eTerm e /\ In e'  l') ->
      entries_match (e :: l) l'.
  Proof using.
    intros. simpl in *.
    intuition.
    unfold entries_match in *.
    split; simpl in *; intuition; subst_max; auto;
    try solve [find_false; eauto].
    - find_apply_hyp_hyp. omega.
    - eapply H0; eauto.
    - right. eapply H0; eauto.
  Qed.

  Lemma ghost_log_entries_match_client_request :
    msg_refined_raft_net_invariant_client_request ghost_log_entries_match.
  Proof using glaei aelsi tsi rlmli rmri.
    red.
    split; red; intros; simpl in *; intuition;
    unfold ghost_log_entries_match in *; break_and.
    - find_copy_apply_lem_hyp handleClientRequest_packets.
      subst. simpl in *.
      find_apply_hyp_hyp. intuition.
      repeat find_higher_order_rewrite; destruct_update; simpl in *; eauto.
      find_apply_lem_hyp handleClientRequest_log.
      intuition; subst; simpl in *; repeat find_rewrite; eauto.
      break_exists_name e.
      intuition; repeat find_rewrite; simpl in *. subst.
      eapply sorted_entries_match_cons; eauto.
      + simpl. intuition; try solve [eapply lifted_entries_sorted_invariant; eauto].
        * find_eapply_lem_hyp maxIndex_is_max; eauto; try omega.
          eapply lifted_entries_sorted_invariant; eauto.
        * repeat find_rewrite.
          find_eapply_lem_hyp lifted_no_entries_past_current_term_host_invariant; eauto.
      + intuition.
        break_exists. intuition.
        repeat find_rewrite.
        enough (exists x, In x (log (snd (nwState net h0))) /\ eIndex x = eIndex e /\ eTerm x = eTerm e).
        * break_exists. intuition. repeat find_rewrite.
          find_eapply_lem_hyp maxIndex_is_max; eauto;
          unfold raft_data in *; simpl in *;
          unfold raft_data in *; simpl in *;
          [omega|]. eapply lifted_entries_sorted_invariant; eauto.
        * find_eapply_lem_hyp ghost_log_allEntries_invariant; eauto.
          break_exists.
          repeat find_rewrite.
          find_copy_eapply_lem_hyp lifted_allEntries_leader_sublog_invariant; eauto.
          apply in_map_iff. eexists; intuition; eauto; auto.
    - find_apply_hyp_hyp.
      find_apply_hyp_hyp.
      find_copy_apply_lem_hyp handleClientRequest_packets.
      subst. simpl in *. intuition.
  Qed.

  Lemma ghost_log_entries_match_timeout :
    msg_refined_raft_net_invariant_timeout ghost_log_entries_match.
  Proof using rlmli rmri.
    red.
    split; red; intros; simpl in *; intuition;
    unfold ghost_log_entries_match in *; break_and.
    - repeat find_higher_order_rewrite; destruct_update; simpl in *; eauto.
      + find_apply_hyp_hyp. intuition.
        * erewrite handleTimeout_log_same; eauto.
        * packet_simpl. eauto.
      + find_apply_hyp_hyp. intuition.
        packet_simpl.
        erewrite handleTimeout_log_same with (d' := d) by eauto.
        eapply lifted_entries_match_invariant; eauto.
    - find_apply_hyp_hyp.
      find_apply_hyp_hyp.
      intuition.
      + do_in_map. subst. unfold add_ghost_msg in *. do_in_map.
        subst. simpl in *.
        erewrite handleTimeout_log_same; eauto.
      + do_in_map. subst. unfold add_ghost_msg in *. do_in_map.
        subst. simpl in *.
        erewrite handleTimeout_log_same; eauto.
      + repeat do_in_map. subst. unfold add_ghost_msg in *. repeat do_in_map.
        subst. simpl in *. auto.
  Qed.

  Lemma ghost_log_entries_match_do_leader :
    msg_refined_raft_net_invariant_do_leader ghost_log_entries_match.
  Proof using rlmli rmri.
    red. intros.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    split; red; intros; simpl in *; intuition;
    unfold ghost_log_entries_match in *; break_and.
    - repeat find_higher_order_rewrite; destruct_update; simpl in *; eauto.
      + find_apply_hyp_hyp. intuition.
        * erewrite doLeader_log; eauto.
        * packet_simpl. eauto.
      + find_apply_hyp_hyp. intuition.
        packet_simpl.
        erewrite doLeader_log with (st'0 := d') by eauto.
        eapply lifted_entries_match_invariant; eauto.
    - find_apply_hyp_hyp.
      find_apply_hyp_hyp.
      intuition.
      + do_in_map. subst. unfold add_ghost_msg in *. do_in_map.
        subst. simpl in *.
        erewrite doLeader_log; eauto.
      + do_in_map. subst. unfold add_ghost_msg in *. do_in_map.
        subst. simpl in *.
        erewrite doLeader_log; eauto.
      + repeat do_in_map. subst. unfold add_ghost_msg in *. repeat do_in_map.
        subst. simpl in *. auto.
  Qed.

  Lemma ghost_log_entries_match_do_generic_server :
    msg_refined_raft_net_invariant_do_generic_server ghost_log_entries_match.
  Proof using rlmli rmri.
    red. intros.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    split; red; intros; simpl in *; intuition;
    unfold ghost_log_entries_match in *; break_and.
    - repeat find_higher_order_rewrite; destruct_update; simpl in *; eauto.
      + find_apply_hyp_hyp. intuition.
        * erewrite doGenericServer_log; eauto.
        * packet_simpl. eauto.
      + find_apply_hyp_hyp. intuition.
        packet_simpl.
        erewrite doGenericServer_log with (st'0 := d') by eauto.
        eapply lifted_entries_match_invariant; eauto.
    - find_apply_hyp_hyp.
      find_apply_hyp_hyp.
      intuition.
      + do_in_map. subst. unfold add_ghost_msg in *. do_in_map.
        subst. simpl in *.
        erewrite doGenericServer_log; eauto.
      + do_in_map. subst. unfold add_ghost_msg in *. do_in_map.
        subst. simpl in *.
        erewrite doGenericServer_log; eauto.
      + repeat do_in_map. subst. unfold add_ghost_msg in *. repeat do_in_map.
        subst. simpl in *. auto.
  Qed.

  Lemma ghost_log_entries_match_reboot :
    msg_refined_raft_net_invariant_reboot ghost_log_entries_match.
  Proof using.
    red. intros.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    split; red; intros; simpl in *; intuition;
    unfold ghost_log_entries_match in *; break_and.
    - repeat find_higher_order_rewrite; destruct_update; simpl in *; eauto;
      repeat find_reverse_rewrite; eauto.
    - repeat find_reverse_rewrite; eauto.
  Qed.

  Lemma ghost_log_entries_match_state_same_packet_subset :
    msg_refined_raft_net_invariant_state_same_packet_subset ghost_log_entries_match.
  Proof using.
    red. intros.
    split; red; intros; simpl in *; intuition;
    unfold ghost_log_entries_match in *; break_and.
    - find_apply_hyp_hyp. repeat find_reverse_higher_order_rewrite. eauto.
    - repeat find_apply_hyp_hyp. eauto.
  Qed.

  Lemma ghost_log_entries_match_invariant :
    forall net,
      msg_refined_raft_intermediate_reachable net ->
      ghost_log_entries_match net.
  Proof using glaei aelsi tsi lphogli glci rlmli rmri.
    intros.
    apply msg_refined_raft_net_invariant'; auto.
    - apply ghost_log_entries_match_init.
    - apply msg_refined_raft_net_invariant_client_request'_weak.
      apply ghost_log_entries_match_client_request.
    - apply msg_refined_raft_net_invariant_timeout'_weak.
      apply ghost_log_entries_match_timeout.
    - apply ghost_log_entries_match_append_entries.
    - apply msg_refined_raft_net_invariant_append_entries_reply'_weak.
      apply ghost_log_entries_match_append_entries_reply.
    - apply ghost_log_entries_match_request_vote.
    - apply msg_refined_raft_net_invariant_request_vote_reply'_weak.
      apply ghost_log_entries_match_request_vote_reply.
    - apply msg_refined_raft_net_invariant_do_leader'_weak.
      apply ghost_log_entries_match_do_leader.
    - apply msg_refined_raft_net_invariant_do_generic_server'_weak.
      apply ghost_log_entries_match_do_generic_server.
    - apply msg_refined_raft_net_invariant_subset'_weak.
      apply ghost_log_entries_match_state_same_packet_subset.
    - apply msg_refined_raft_net_invariant_reboot'_weak. apply ghost_log_entries_match_reboot.
  Qed.

  Instance glemi : ghost_log_entries_match_interface.
  Proof.
    split.
    apply ghost_log_entries_match_invariant.
  Qed.
End GhostLogLogMatching.


Require Import VST.msl.msl_standard.
Require Import VST.veric.base.
Require Import VST.veric.compcert_rmaps.
Require Import VST.veric.Clight_lemmas.
Require Import VST.veric.tycontext.
Require Import VST.veric.expr2.
Require Export VST.veric.environ_lemmas.
Require Import VST.veric.binop_lemmas2.
(*Require Import VST.veric.binop_lemmas.*)
Require Import VST.veric.expr_lemmas2.
Import Cop.
Import Cop2.

Opaque tc_andp. (* This is needed otherwise certain Qeds take
    forever in Coq 8.3.  *)

Lemma type_eq_true : forall a b, proj_sumbool  (type_eq a b) =true  -> a = b.
Proof. intros. destruct (type_eq a b). auto. simpl in H. inv H.
Qed.

(** Definitions of some environments **)
Definition empty_genv cenv := Build_genv (Globalenvs.Genv.empty_genv fundef type nil) cenv.
Definition empty_tenv := PTree.empty val.

Definition empty_environ cenv : environ :=
mkEnviron (filter_genv (empty_genv cenv)) (Map.empty _) (Map.empty _).

Lemma Zle_bool_rev: forall x y, Zle_bool x y = Zge_bool y x.
Proof.
intros. pose proof (Zle_cases x y). pose proof (Zge_cases y x).
destruct (Zle_bool x y); destruct (Zge_bool y x); auto;
elimtype False; omega.
Qed.

(** Typechecking soundness **)

Transparent Float.to_int.
Transparent Float.to_intu.
Transparent Float32.to_int.
Transparent Float32.to_intu.

Lemma isCastR: forall {CS: compspecs} tfrom tto a,
  denote_tc_assert (isCastResultType tfrom tto a) =
 denote_tc_assert
match classify_cast tfrom tto with
| Cop.cast_case_default => tc_FF  (invalid_cast tfrom tto)
| Cop.cast_case_f2i _ Signed => tc_andp (tc_Zge a Int.min_signed ) (tc_Zle a Int.max_signed)
| Cop.cast_case_s2i _ Signed => tc_andp (tc_Zge a Int.min_signed ) (tc_Zle a Int.max_signed)
| Cop.cast_case_f2i _ Unsigned => tc_andp (tc_Zge a 0) (tc_Zle a Int.max_unsigned)
| Cop.cast_case_s2i _ Unsigned => tc_andp (tc_Zge a 0) (tc_Zle a Int.max_unsigned)
| Cop.cast_case_i2l _ =>
           tc_andp (tc_bool (is_int_type tfrom) (invalid_cast_result tfrom tto))
             (if is_pointer_type tto then tc_iszero a else tc_TT)
| Cop.cast_case_l2i _ _ =>
           tc_andp (tc_bool (is_long_type tfrom) (invalid_cast_result tfrom tto))
             (if is_pointer_type tto then tc_iszero a else tc_TT)
| Cop.cast_case_pointer  =>
           if eqb_type tfrom tto then tc_TT else
           (if orb  (andb (is_pointer_type tto) (is_pointer_type tfrom))
                       (if Archi.ptr64
                        then (andb (is_long_type tto) (is_long_type tfrom))
                        else (andb (is_int_type tto) (is_int_type tfrom)))
              then tc_TT
              else tc_iszero a)
| Cop.cast_case_l2l => tc_bool (is_long_type tfrom && is_long_type tto) (invalid_cast_result tto tto)
| Cop.cast_case_f2bool => tc_bool (is_float_type tfrom) (invalid_cast_result tfrom tto)
| Cop.cast_case_s2bool => tc_bool (is_single_type tfrom) (invalid_cast_result tfrom tto)
| Cop.cast_case_l2bool =>
      if is_pointer_type tfrom
      then tc_test_eq a (Econst_long Int64.zero (Tlong Unsigned noattr))
      else tc_TT
| Cop.cast_case_i2bool =>
      if is_pointer_type tfrom
      then tc_test_eq a (Econst_int Int.zero (Tint I32 Unsigned noattr))
      else tc_TT
| Cop.cast_case_void => tc_noproof
| _ => match tto with
      | Tint _ _ _  => tc_bool (is_int_type tfrom) (invalid_cast_result tto tto)
      | Tfloat F64 _  => tc_bool (is_anyfloat_type tfrom) (invalid_cast_result tto tto)
      | Tfloat F32 _  => tc_bool (is_anyfloat_type tfrom) (invalid_cast_result tto tto)
      | _ => tc_FF (invalid_cast tfrom tto)
      end
end.
Proof. intros; extensionality rho.
 unfold isCastResultType.
 destruct (classify_cast tfrom tto) eqn:?; auto.
Qed.

Lemma Z2R_pow_0_lt:
  forall e,
  0 <= e ->
  Rdefinitions.Rlt 0 (Fcore_Raux.Z2R (2 ^ e)).
Proof.
intros.
rewrite <- (Z2Nat.id e) by auto.
clear.
induction (Z.to_nat e).
simpl.
apply RIneq.Rlt_0_1.
rewrite inj_S.
rewrite Z.pow_succ_r by omega.
rewrite Fcore_Raux.Z2R_mult.
apply RIneq.Rmult_lt_0_compat; auto.
simpl.
clear.
apply DiscrR.Rlt_R0_R2.
Qed.

Definition general_offloat (prec emax : Z)
    (f:  Fappli_IEEE.binary_float prec emax) : option Z :=
  match f with
  | Fappli_IEEE.B754_zero _ => Some 0
  | Fappli_IEEE.B754_infinity _ => None
  | Fappli_IEEE.B754_nan _ _ => None
  | Fappli_IEEE.B754_finite s m 0 _ => Some (Fcore_Zaux.cond_Zopp s (Z.pos m))
  | Fappli_IEEE.B754_finite s m (Z.pos e) _ =>
      Some (Fcore_Zaux.cond_Zopp s (Z.pos m) * Z.pow_pos 2 e)
  | Fappli_IEEE.B754_finite s m (Z.neg e) _ =>
      Some (Fcore_Zaux.cond_Zopp s (Z.pos m / Z.pow_pos 2 e))
  end.

Definition general_float_to_int (prec emax : Z) (lo hi: Z) (f: Fappli_IEEE.binary_float prec emax) : option int :=
 option_map Int.repr
   (Fappli_IEEE_extra.ZofB_range prec emax f lo hi).

Goal Zoffloat = general_offloat 53 1024.
reflexivity.
Qed.

Goal Zofsingle = general_offloat 24 128.
reflexivity.
Qed.

Goal Float.to_int = general_float_to_int 53 1024 Int.min_signed Int.max_signed.
reflexivity.
Qed.

Goal Float.to_intu = general_float_to_int 53 1024 0 Int.max_unsigned.
reflexivity.
Qed.

Goal Float32.to_int = general_float_to_int 24 128 Int.min_signed Int.max_signed.
reflexivity.
Qed.

Goal Float32.to_intu = general_float_to_int 24 128 0 Int.max_unsigned.
reflexivity.
Qed.

Lemma general_float_to_int_ok:
  forall prec emax lo hi f z,
    general_offloat prec emax f = Some z ->
    lo <= z <= hi ->
    general_float_to_int prec emax lo hi f = Some (Int.repr z).
Proof.
intros.
unfold general_offloat in H.
unfold general_float_to_int.
destruct H0 as [H0 H1].
apply Z.leb_le in H0; apply Z.leb_le in H1.
destruct f; inv H.
{ (* zero case *)
rewrite Fappli_IEEE_extra.ZofB_range_correct. simpl.
unfold Fcore_Raux.Ztrunc.
rewrite Fcore_Raux.Rlt_bool_false by apply RIneq.Rle_refl.
replace (Fcore_Raux.Zfloor 0) with 0.
rewrite H0,H1. reflexivity.
unfold Fcore_Raux.Zfloor.
replace (Rdefinitions.up 0) with 1; [reflexivity |].
apply R_Ifp.tech_up; simpl.
apply RIneq.Rlt_0_1.
rewrite Raxioms.Rplus_comm.
rewrite RIneq.Rplus_0_r. apply RIneq.Rle_refl.
}
(* nonzero case *)
destruct (zle 0 e).
* (* 0 <= e *)
assert (z = Fcore_Zaux.cond_Zopp b (Z.pos m) * Z.pow 2 e). {
  destruct e; inv H3.
  rewrite Z.pow_0_r. rewrite Z.mul_1_r. auto.
  rewrite Zpower_pos_nat. rewrite Zpower_nat_Z.
  rewrite positive_nat_Z; auto.
  pose proof (Pos2Z.neg_is_neg p); omega.
}
clear H3. subst z.
rewrite Fappli_IEEE_extra.ZofB_range_correct.
replace
   (Fcore_Raux.Ztrunc
      (Fappli_IEEE.B2R prec emax (Fappli_IEEE.B754_finite prec emax b m e e0)))
  with (Fcore_Zaux.cond_Zopp b (Z.pos m) * 2^e).
rewrite H0,H1; clear H0 H1.
rewrite (Fappli_IEEE_extra.is_finite_strict_finite prec emax).
reflexivity.
reflexivity.
unfold Fcore_Zaux.cond_Zopp.
unfold Fcore_Raux.Ztrunc.
destruct b; [rewrite Fcore_Raux.Rlt_bool_true | rewrite Fcore_Raux.Rlt_bool_false].
+
unfold Fappli_IEEE.B2R.
unfold Fcore_Zaux.cond_Zopp.
unfold Fcore_Raux.Zceil.
unfold Fcore_Raux.Zfloor.
symmetry; apply Fcore_Raux.Zceil_imp; split.
eapply RIneq.Rlt_le_trans.
apply Fcore_Raux.Z2R_lt.
instantiate (1 := - Z.pos m * 2 ^ e). omega.
unfold Fcore_defs.F2R.
rewrite Fcore_Raux.Z2R_mult.
match goal with |- _ ?A ?B => replace B with A; [apply RIneq.Rle_refl | ] end.
f_equal.
simpl.
rewrite <- Fcore_Raux.Z2R_Zpower by auto.
reflexivity.
match goal with |- _ ?A ?B => replace B with A; [apply RIneq.Rle_refl | ] end.
unfold Fcore_defs.F2R.
rewrite Fcore_Raux.Z2R_mult.
simpl.
rewrite <- Fcore_Raux.Z2R_Zpower by auto.
simpl.
auto.
+
simpl. unfold Fcore_defs.F2R.
simpl.
rewrite RIneq.Ropp_mult_distr_l_reverse.
apply RIneq.Ropp_lt_gt_0_contravar.
unfold Rdefinitions.Rgt.
apply RIneq.Rmult_lt_0_compat.
clear.
rewrite Fcore_Raux.P2R_INR.
apply RIneq.lt_0_INR.
apply Pos2Nat.is_pos.
simpl.
rewrite <- Fcore_Raux.Z2R_Zpower by auto.
simpl.
apply Z2R_pow_0_lt; auto.
+
unfold Fappli_IEEE.B2R.
unfold Fcore_Zaux.cond_Zopp.
symmetry; apply Fcore_Raux.Zfloor_imp; split.
match goal with |- _ ?A ?B => replace B with A; [apply RIneq.Rle_refl | ] end.
unfold Fcore_defs.F2R.
rewrite Fcore_Raux.Z2R_mult.
simpl.
rewrite <- Fcore_Raux.Z2R_Zpower by auto.
simpl.
auto.
unfold Fcore_defs.F2R.
eapply RIneq.Rle_lt_trans.
instantiate (1:= (Fcore_Raux.Z2R (Z.pos m * 2 ^ e ))).
rewrite Fcore_Raux.Z2R_mult.
simpl.
rewrite !Fcore_Raux.P2R_INR.
rewrite <- Fcore_Raux.Z2R_Zpower by auto.
simpl.
match goal with |- _ ?A ?B => replace B with A; [apply RIneq.Rle_refl | ] end.
f_equal.
(* symmetry; apply Fcore_Raux.P2R_INR. *)
rewrite Fcore_Raux.Z2R_plus.
rewrite Raxioms.Rplus_comm.
rewrite <- RIneq.Rplus_0_r at 1.
rewrite Raxioms.Rplus_comm at 1.
apply RIneq.Rplus_lt_le_compat.
apply RIneq.Rlt_0_1.
apply RIneq.Req_le. auto.
+
unfold Fappli_IEEE.B2R.
unfold Fcore_Zaux.cond_Zopp.
unfold Fcore_defs.F2R.
simpl.
apply RIneq.Rmult_le_pos.
rewrite Fcore_Raux.P2R_INR.
apply RIneq.pos_INR.
rewrite <- Fcore_Raux.Z2R_Zpower by auto.
simpl.
apply RIneq.Rlt_le.
apply Z2R_pow_0_lt; auto.
* (* e < 0 *)
assert (HH: (Fcore_Raux.Z2R (2 ^ (- e))) <> Rdefinitions.R0). {
assert (Rdefinitions.R0 <> Fcore_Raux.Z2R (2 ^ (- e))); auto.
apply RIneq.Rlt_not_eq.
apply (Z2R_pow_0_lt (-e)).
omega.
}
assert (z = Fcore_Zaux.cond_Zopp b (Z.pos m / Z.pow 2 (- e))). {
  destruct e; inv H3.
  omega. pose proof (Zgt_pos_0 p); omega. clear g.
  rewrite Zpower_pos_nat. rewrite Zpower_nat_Z.
  rewrite positive_nat_Z; auto.
}
clear H3. subst z.
rewrite Fappli_IEEE_extra.ZofB_range_correct.
replace
   (Fcore_Raux.Ztrunc
      (Fappli_IEEE.B2R prec emax (Fappli_IEEE.B754_finite prec emax b m e e0)))
  with (Fcore_Zaux.cond_Zopp b (Z.pos m / 2^(-e))).
rewrite H0,H1; clear H0 H1.
rewrite (Fappli_IEEE_extra.is_finite_strict_finite prec emax).
reflexivity.
reflexivity.
unfold Fcore_Zaux.cond_Zopp.
unfold Fcore_Raux.Ztrunc.
destruct b; [rewrite Fcore_Raux.Rlt_bool_true | rewrite Fcore_Raux.Rlt_bool_false].
+
clear - g.
unfold Fappli_IEEE.B2R.
unfold Fcore_Zaux.cond_Zopp.
unfold Fcore_Raux.Zceil.
f_equal.
unfold Fcore_defs.F2R.
simpl.
rewrite RIneq.Ropp_mult_distr_l_reverse.
rewrite RIneq.Ropp_involutive.
rewrite <- Fcore_Raux.Zfloor_div by (apply Z.pow_nonzero; omega).
rewrite <- (Z.opp_involutive e) at 2.
rewrite (Fcore_Raux.bpow_opp _ (-e)).
symmetry.
rewrite <- Fcore_Raux.Z2R_Zpower by omega.
simpl.
unfold Rdefinitions.Rdiv.
auto.
+
simpl.
apply Fcore_float_prop.F2R_lt_0_compat.
simpl.  pose proof (Pos2Z.neg_is_neg m); omega.
+
simpl.
unfold Fcore_defs.F2R.
simpl.
rewrite <- (Z.opp_involutive e) at 2.
rewrite (Fcore_Raux.bpow_opp _ (-e)).
rewrite <- Fcore_Raux.Z2R_Zpower by omega.
simpl.
rewrite <- Fcore_Raux.Zfloor_div by (apply Z.pow_nonzero; omega).
reflexivity.
+
simpl.
unfold Fcore_defs.F2R.
simpl.
rewrite <- (Z.opp_involutive e).
rewrite (Fcore_Raux.bpow_opp _ (-e)).
rewrite <- Fcore_Raux.Z2R_Zpower by omega.
simpl.
apply RIneq.Rmult_le_pos.
rewrite Fcore_Raux.P2R_INR.
apply RIneq.pos_INR.
apply RIneq.Rlt_le.
apply RIneq.Rinv_0_lt_compat.
apply Z2R_pow_0_lt; omega.
Qed.

Lemma float_to_int_ok:
  forall f z,
    Zoffloat f = Some z ->
    Int.min_signed <= z <= Int.max_signed ->
    Float.to_int f = Some (Int.repr z).
Proof.
apply general_float_to_int_ok.
Qed.

Lemma float_to_intu_ok:
  forall f z,
    Zoffloat f = Some z ->
    0 <= z <= Int.max_unsigned ->
    Float.to_intu f = Some (Int.repr z).
Proof.
apply general_float_to_int_ok.
Qed.

Lemma single_to_int_ok:
  forall f z,
    Zofsingle f = Some z ->
    Int.min_signed <= z <= Int.max_signed ->
    Float32.to_int f = Some (Int.repr z).
Proof.
apply general_float_to_int_ok.
Qed.

Lemma single_to_intu_ok:
  forall f z,
    Zofsingle f = Some z ->
    0 <= z <= Int.max_unsigned ->
    Float32.to_intu f = Some (Int.repr z).
Proof.
apply general_float_to_int_ok.
Qed.

(* not necessary if rewrite denote_tc_assert_andp *)
(*
Lemma denote_tc_assert_andp_e:
  forall a b rho, denote_tc_assert Delta (tc_andp a b) rho ->
         denote_tc_assert Delta a rho /\ denote_tc_assert Delta b rho.
Proof.
intros.
rewrite denote_tc_assert_andp in H; auto.
Qed.
*)
Lemma andb_zleb:
 forall i j k : Z,  i <= j <= k ->
      (i <=? j) && (j <=? k) = true.
Proof.
intros ? ? ? [? ?]; rewrite andb_true_iff; split;
 apply Z.leb_le; auto.
Qed.

Lemma sign_ext_range':
    forall n x, 0 < n < Int.zwordsize ->
      - two_p (n - 1) <= Int.signed (Int.sign_ext n x) <= two_p (n - 1) -1.
Proof.
intros.
pose proof (Int.sign_ext_range n x H).
omega.
Qed.

Lemma zero_ext_range':
  forall n x, 0 <= n < Int.zwordsize ->
     0 <= Int.unsigned (Int.zero_ext n x) <= two_p n - 1.
Proof.
intros.
 pose proof (Int.zero_ext_range n x H); omega.
Qed.

Lemma int64_eq_e: forall i, Int64.eq i Int64.zero = true -> i=Int64.zero.
Proof.
intros.
pose proof (Int64.eq_spec i Int64.zero). rewrite H in H0; auto.
Qed.

Lemma long_int_zero_lem:
  forall i, Int64.eq (Int64.repr (Int64.unsigned i)) Int64.zero = true ->
    Int.repr (Int64.unsigned i) = Int.zero.
Proof.
 intros.
 apply int64_eq_e in H.
unfold Int.zero.
rewrite Int64.repr_unsigned in H.
subst.
reflexivity.
Qed.

Lemma typecheck_cast_sound:
 forall {CS: compspecs} Delta rho m e t,
 typecheck_environ Delta rho ->
 (denote_tc_assert (typecheck_expr Delta e) rho m ->
   tc_val (typeof e) (eval_expr e rho))  ->
denote_tc_assert (typecheck_expr Delta (Ecast e t)) rho m ->
tc_val (typeof (Ecast e t)) (eval_expr (Ecast e t) rho).
Proof.
intros until t; intros H H1 H0.
simpl in *. unfold_lift.
rewrite denote_tc_assert_andp in H0.
destruct H0.
specialize (H1 H0); clear H0.
unfold  sem_cast, force_val1.
rewrite isCastR in H2.
destruct (classify_cast (typeof e) t)
     as [ | | | | | | | | sz [ | ] | sz [ | ] | | | | | | [ | ] | [ | ] | | | | | | | |  ]
   eqn:H3;
   try contradiction;
 destruct t as [ | [ | | | ] [ | ] | [ | ] | [ | ] | | | | | ];
    try discriminate H3; try contradiction;
 destruct (typeof e) as [ | [ | | | ] [ | ] | [ | ] | [ | ] | | | | | ];
    try discriminate H3; try contradiction;
  unfold classify_cast in H3;
  try replace (if Archi.ptr64 then false else false) with false in H2 by (destruct Archi.ptr64; auto);
  repeat (progress unfold_lift in H2; simpl in H2);  (* needed ? *)
  unfold tc_val, is_pointer_type in *;
  repeat match goal with |- context [eqb_type ?A ?B] =>
              let J := fresh "J" in
              destruct (eqb_type A B) eqn:J;
             [apply eqb_type_true in J | apply eqb_type_false in J]
    end;
  repeat match goal with H: context [eqb_type ?A ?B] |- _ =>
              let J := fresh "J" in
              destruct (eqb_type A B) eqn:J;
             [apply eqb_type_true in J | apply eqb_type_false in J]
    end;
   try discriminate;
   rewrite ?if_true in H3 by auto; rewrite ?if_false in H3 by (clear; congruence);
   try (destruct Archi.ptr64 eqn:?Hp; try discriminate; [idtac]);
  repeat match goal with
       | H: app_pred (denote_tc_assert (tc_andp _ _) _) _ |- _ =>
          rewrite denote_tc_assert_andp in H; destruct H
       | H: app_pred (denote_tc_assert (if ?A then _ else _) _) _ |- _ =>
           first [change A with false in H | change A with true in H]; cbv iota in H
       | H: app_pred (denote_tc_assert (tc_iszero _) _) _ |- _ =>
                   rewrite denote_tc_assert_iszero in H
       | H: app_pred (denote_tc_assert (tc_bool _ _) _) _ |- _ => apply tc_bool_e in H
       | H: app_pred (denote_tc_assert _ _) _ |- _ =>
             unfold denote_tc_assert, denote_tc_Zle, denote_tc_Zge in H;
             unfold_lift in H
       end;
   destruct (eval_expr e rho); try solve [contradiction H1];
   try apply I;
   try solve [contradiction];
   unfold sem_cast_pointer, sem_cast_i2i, sem_cast_f2f, sem_cast_s2s,
   sem_cast_f2i, sem_cast_s2i, cast_float_int, is_pointer_or_null, force_val in *;
   repeat rewrite Hp in *;
   repeat match goal with
        | H: app_pred (prop _) _ |- _ => apply is_true_e in H;
                                      try (apply int_eq_e in H; subst)
       end;
    auto;
    inv H3;
   try (simpl in H1|-*;
      match goal with
      | |- context[Int.sign_ext ?n ?x] =>
      apply (sign_ext_range' n x); compute; split; congruence
      | |- context[Int.zero_ext ?n ?x] =>
      apply (zero_ext_range' n x); compute; try split; congruence
     end);
   simpl;
    try match goal with |- (if ?A then _ else _) = _ \/ (if ?A then _ else _) = _ =>
      destruct A; solve [auto]
     end;
  repeat  match goal with
    | H: app_pred match ?A with Some _ => _ | None => _ end _ |- _ =>
         destruct A eqn:?; [  | contradiction H]
    | H: app_pred (prop _) _ |- _ => apply is_true_e in H;
           rewrite ?Z.leb_le, ?Z.geb_le in H
   end.

all: try (first [ erewrite float_to_int_ok | erewrite float_to_intu_ok
          | erewrite single_to_int_ok | erewrite single_to_intu_ok];
          [ | eassumption | split; assumption]).
all:   try match goal with
     | |- context[Int.sign_ext ?n ?x] =>
      apply (sign_ext_range' n x); compute; split; congruence
     | |- context[Int.zero_ext ?n ?x] =>
      apply (zero_ext_range' n x); compute; try split; congruence
   end.
all: try apply I.
all: rewrite ?Hp; hnf; auto.
all: apply long_int_zero_lem; auto.
Qed.


(** printing ⊢#    %\vdash_{\#}%    #⊢##     *)
(** printing ⊢##   %\vdash_{\#\#}%  #⊢&#35&#35#  *)
(** printing ⊢##v  %\vdash_{\#\#v}% #⊢&#35&#35v# *)
(** printing ⊢!    %\vdash_!%       #⊢!#         *)
(** remove printing ~ *)

Set Implicit Arguments.

Require Import Coq.Program.Equality String.
Require Import Definitions Weakening Narrowing.
Require Import ConstrLangAlt ConstrTyping ConstrWeakening ConstrSubenvironments.
Require Import ConstrEntailment.
Require Import ConstrSubtypingLaws.

Lemma strengthen_constr_general_typing : forall C1 C2 G t T,
  C1 ⊩ C2 ->
  (C2, G) ⊢c t : T ->
  (C1, G) ⊢c t : T
with strengthen_constr_general_typing_def : forall C1 C2 G d D,
  C1 ⊩ C2 ->
  (C2, G) /-c d : D ->
  (C1, G) /-c d : D
with strengthen_constr_general_typing_defs : forall C1 C2 G ds D,
  C1 ⊩ C2 ->
  (C2, G) /-c ds :: D ->
  (C1, G) /-c ds :: D
with strengthen_constr_general_subtyping : forall C1 C2 G T U,
  C1 ⊩ C2 ->
  (C2, G) ⊢c T <: U ->
  (C1, G) ⊢c T <: U.
Proof.
  all: introv He Ht.
  - gen C1. dependent induction Ht; introv He.
    -- constructor. assumption.
    -- pick_fresh x.
       apply cty_all_intro with L. introv Hne0.
       apply* H0.
    -- apply* cty_all_elim.
    -- apply cty_new_intro with L.
       introv Hn. specialize (H x Hn). apply* strengthen_constr_general_typing_defs.
    -- apply cty_new_elim. apply* IHHt.
    -- apply cty_let with L T. apply* IHHt.
       introv Hne. specialize (H0 x Hne). apply* H0.
    -- apply cty_rec_intro. apply* IHHt.
    -- apply cty_rec_elim. apply* IHHt.
    -- apply cty_and_intro; try apply* IHHt1; try apply* IHHt2.
    -- apply cty_sub with T. apply* IHHt. apply* strengthen_constr_general_subtyping.
  - gen C1. dependent induction Ht; introv He.
    -- constructor.
    -- constructor. apply* strengthen_constr_general_typing.
  - gen C1. dependent induction Ht; introv He.
    -- constructor. apply* strengthen_constr_general_typing_def.
    -- constructor. apply* IHHt. apply* strengthen_constr_general_typing_def.
       exact H0.
  - gen C1. dependent induction Ht; introv He.
    -- apply csubtyp_intro with x S S'; try assumption.
       apply* IHHt. apply* ent_cong_and.
    -- apply* csubtyp_inst. apply* ent_trans.
Qed.


From ConCert.Utils Require Import Extras.
From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import Containers.
From ConCert.Execution Require Import ResultMonad.
From ConCert.Execution Require Import Serializable.
From ConCert.Execution.Test Require Import QCTest.
From ConCert.Examples.Congress Require Import Congress.
From ConCert.Examples.Congress Require Export CongressGens.
From ConCert.Examples.Congress Require Export CongressPrinters.
From Coq Require Import ZArith.
From Coq Require Import List. Import ListNotations.

Definition LocalChainBase : ChainBase := TestUtils.LocalChainBase.

Definition chain1 : ChainBuilder := builder_initial.
Definition chain2 : ChainBuilder := unpack_result (add_block chain1 []).
Definition chain3 : ChainBuilder := unpack_result
  (add_block chain2 [build_transfer creator person_1 10]).

Definition setup_rules :=
  {| min_vote_count_permille := 200; (* 20% of congress needs to vote *)
      margin_needed_permille := 501;
      debating_period_in_blocks := 0; |}.

Definition setup := Congress.build_setup setup_rules.
Definition deploy_congress : ActionBody :=
  create_deployment 5 Congress.contract setup.
Definition chain4 : ChainBuilder :=
  unpack_result (add_block chain3 [build_deploy person_1 5 Congress.contract setup]).
Definition congress_1 : Address :=
  match outgoing_txs (builder_trace chain4) person_1 with
  | tx :: _ => tx_to tx
  | _ => person_1
  end.
Definition congress_ifc : ContractInterface Congress.Msg :=
  match get_contract_interface chain4 congress_1 Congress.Msg with
  | Some x => x
  (* Using unpack_option here is extremely slow *)
  | None =>
    @build_contract_interface
      _ _
      creator
      (fun a m => deploy_congress)
  end.

(* person_1 adds person_1 and person_2 as members of congress *)
Definition add_person p :=
  congress_ifc.(send) 0 (Some (add_member p)).
Definition chain5 : ChainBuilder :=
  let acts := [build_act person_1 person_1 (add_person person_1);
               build_act person_1 person_1 (add_person person_2)] in
  unpack_result (add_block chain4 acts).
Definition create_proposal_call :=
  congress_ifc.(send) 0 (Some (create_proposal [cact_transfer person_3 3])).

Definition congress_chain := chain5.
Definition congress_caddr := addr_of_Z 128%Z.

Module NotationInfo <: TestNotationParameters.
  Definition gAction := (fun env => GCongressAction env act_depth congress_caddr).
  Definition init_cb := congress_chain.
End NotationInfo.
Module TN := TestNotations NotationInfo. Import TN.
(* Sample gChain. *)

Definition nr_cacts (msg : option Congress.Msg) :=
  match msg with
  | Some (create_proposal ls) => length ls
  | _ => 0
  end.

Definition num_cacts_in_state state :=
  sumnat (fun '(k, v) => length (actions v)) (FMap.elements (proposals state)).

(* This property states that the number of actions to be performed by the congress never increases
   more than the actions that are added in proposals, i.e. actions can't appear out of nowhere. *)
(* If we replace '<=' with '<' QC finds a counterexample - a proposal can contain an empty list of actions, so they are equal before/after add_proposal *)
Definition receive_state_well_behaved state msg new_state (resp_acts : list ActionBody) :=
  num_cacts_in_state new_state + length resp_acts <=
  num_cacts_in_state state + nr_cacts msg.

#[export]
Instance receive_state_well_behaved_dec_ {state : Congress.State}
                                         {msg : option Congress.Msg}
                                         {new_state : Congress.State}
                                         {resp_acts : list ActionBody}
                                         : Dec (receive_state_well_behaved state msg new_state resp_acts).
Proof.
  intros;
  unfold receive_state_well_behaved;
  constructor;
  apply le_dec.
Qed.

#[export]
Instance receive_state_well_behaved_checkable {state : Congress.State}
                                              {msg : option Congress.Msg}
                                              {new_state : Congress.State}
                                              {resp_acts : list ActionBody}
                                              : Checkable (receive_state_well_behaved state msg new_state resp_acts).
Proof. apply testDec. Qed.

Definition receive_state_well_behaved_P (chain : Chain)
                                        (cctx : ContractCallContext)
                                        (old_state : Congress.State)
                                        (msg : Congress.Msg)
                                        (result : option (Congress.State * list ActionBody)) :=
  checker match result with
  | Some (new_state, resp_acts) =>
    (receive_state_well_behaved old_state (Some msg) new_state resp_acts)?
  | _ => false
  end.

(* QuickChick (
  {{fun _ _ => true}}
  congress_caddr
  {{receive_state_well_behaved_P}}
). *)
(* coqtop-stdout:+++ Passed 10000 tests (0 discards) *)

Open Scope nat.

(* A property about the way States are generated. *)
(* It says that a State generated at some time slot cannot contain proposals later than this time slot. *)
Definition state_proposals_proposed_in_valid_P (block_slot : nat) (state : Congress.State) :=
  let proposals := map snd (FMap.elements (proposals state)) in
  forallb (fun p => proposed_in p <=? block_slot) proposals.

Definition state_proposals_proposed_in_valid (cs : ChainState) :=
  let state_opt := get_contract_state Congress.State cs congress_caddr in
  whenFail (show cs.(env_chain))
  match state_opt with
  | Some state => checker (state_proposals_proposed_in_valid_P cs.(current_slot) state)
  | None => checker true
  end.

(* QuickChick (forAllBlocks state_proposals_proposed_in_valid). *)
(* coqtop-stdout:+++ Passed 10000 tests (0 discards) *)

Definition congress_has_votes_on_some_proposal (cs : ChainState) :=
  let state_opt := get_contract_state Congress.State cs congress_caddr in
  match state_opt with
  | Some state =>
       let proposals := map snd (FMap.elements (proposals state)) in
    existsb (fun proposal =>
      0 <? FMap.size proposal.(votes)
    ) proposals
  | None => false
  end.

(* QuickChick (chain5 ~~> congress_has_votes_on_some_proposal). *)
(* Success - found witness satisfying the predicate!
+++ Failed (as expected) after 7 tests and 0 shrinks. (0 discards) *)

(* This assumes that in a previous block, there was an active proposal *)
Definition congress_finished_a_vote (cs : ChainState) :=
  let acts := cs.(chain_state_queue) in
  let act_is_finish_vote (act : Action) :=
    match act.(act_body) with
    | act_call _ _ msg =>
      match deserialize Congress.Msg _ msg with
      | Some (Congress.finish_proposal _) => true
      | _ => false
      end
    | _ => false
    end in
    existsb act_is_finish_vote acts.

(* QuickChick (chain5 ~~> congress_finished_a_vote). *)
(* Success - found witness satisfying the predicate!
+++ Failed (as expected) after 14 tests and 0 shrinks. (0 discards) *)


(* A deterministic RiscvMachine performing only internal MMIO,
   i.e. MMIO between the processor and a hardware device simulator that
   does not show up in the event trace.
   No external MMIO (ie interaction with the external world) is performed
   by this machine, so mach.(getMachine).(getLog) always remains [].
   Based on riscv.Platform.Minimal *)
Require Import Coq.ZArith.ZArith.
Require Import Coq.Bool.Bvector.
Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.PropExtensionality.
Require Import riscv.Utility.Monads. Import OStateOperations.
Require Import riscv.Spec.Decode.
Require Import riscv.Spec.Machine.
Require Import riscv.Utility.Utility.
Require Import riscv.Utility.FreeMonad.
Require Import riscv.Spec.Primitives.
Require Export riscv.Platform.RiscvMachine.
Require Export riscv.Platform.MaterializeRiscvProgram.
Require Export Bedrock2Experiments.RiscvMachineWithCavaDevice.ExtraRiscvMachine.
Require Import coqutil.Z.Lia.
Require Import coqutil.Map.Interface.
Require Import coqutil.Word.Bitwidth32.
Require Import riscv.Platform.Sane.
Require Export Cava.TLUL.

Local Open Scope Z_scope.
Local Open Scope bool_scope.
Import ListNotations.

(* TODO move to riscv-coq *)
Module free.
  Section WithParams.
    Context {action: Type} {result: action -> Type} {state: Type}
            (interp_action: forall a: action, OState state (result a)) {answer: Type}.
    Definition interp_as_OState_body interp_as_OState (m: free action result answer):
      OState state answer :=
      match m with
      | free.ret x => Return x
      | free.act a k => Bind (interp_action a) (fun r => interp_as_OState (k r))
      end.
    Fixpoint interp_as_OState(m: free action result answer): OState state answer :=
      interp_as_OState_body interp_as_OState m.
  End WithParams.
End free.

Module device.
  (* A deterministic device, to be instantiated with a Cava device *)
  Class device := {
    (* circuit state, will be instantiated with result of Cava.Core.Circuit.circuit_state *)
    state: Type;

    (* tells whether the device is in a state where it's ready to be used, typically
       includes Cava.Core.Circuit.reset_state *)
    is_ready_state: state -> Prop;

    (* the d2h output the device produced when it transitioned to the state *)
    (* TODO: probably need to add to [device_implements_state_machine] something like
     [forall s h2d d2h s', run1 s h2d = (s', d2h) -> last_d2h s' = d2h] *)
    last_d2h: state -> tl_d2h;

    (* run one simulation step, will be instantiated with Cava.Semantics.Combinational.step *)
    run1: (* input: TileLink host-2-device *)
      state -> tl_h2d ->
      (* output: next state, TileLink device-2-host *)
      state;

    (* lowest address of the MMIO address range used to communicate with this device *)
    addr_range_start: Z;

    (* one past the highest MMIO address *)
    addr_range_pastend: Z;

    (* max number of device cycles this device takes to serve read/write requests, ie
       max number of run1 calls with active read/write request until the device responds *)
    maxRespDelay: state -> nat;
  }.
  (* Note: there are two levels of "polling until a response is available":
     - on the hardware level, using runUntilResp, which appears as
       blocking I/O for the software
     - on the software level, using MMIO reads on some status register,
       where the MMIO read immediately gives a "busy" response, and the
       software keeps polling until the MMIO read returns a "done" response *)

  Definition waitForResp{D: device} :=
    fix rec(fuel: nat)(s: device.state): option device.state :=
      let next := device.run1 s (set_d_ready true tl_h2d_default) in
      if d_valid (device.last_d2h next) then
        Some next
      else
        match fuel with
        | O => None
        | S fuel' => rec fuel' next
        end.

  (* returning None means out of fuel and must not happen if fuel >= device.maxRespDelay.
     It is also assumed that [a_valid h2d = true] and [d_ready h2d = true].
     When the result is [Some res], retrieve the response d2h by calling
     [device.last_d2h res]. *)
  Definition runUntilResp{D: device}(h2d: tl_h2d) :=
    fix rec(fuel: nat)(s: device.state): option device.state :=
      let next := device.run1 s h2d in
      if a_ready (device.last_d2h s) then
        if d_valid (device.last_d2h next) then
          Some next
        else
          match fuel with
          | O => None
          | S fuel' => waitForResp fuel' next
          end
      else
        match fuel with
        | O => None
        | S fuel' => rec fuel' next
        end.

  Section WithWordAndDevice.
    Context {word: Interface.word.word 32} {word_ok: word.ok word} {D: device}.

    Definition isMMIOAddr(a: word): Prop :=
      device.addr_range_start <= word.unsigned a < device.addr_range_pastend.

    Definition isMMIOAddrB(a: word)(n: nat): bool :=
      (device.addr_range_start <=? word.unsigned a) &&
      (word.unsigned a + Z.of_nat n <=? device.addr_range_pastend).
  End WithWordAndDevice.
End device.
Notation device := device.device.
Global Coercion device.state: device >-> Sortclass.

(* Needed because of https://github.com/coq/coq/issues/14031 *)
#[export] Hint Extern 1 (MachineWidth _) => exact MkMachineWidth.MachineWidth_XLEN
  : typeclass_instances.

(* TODO move to coqutil *)
Module word. Section WithParams.
  Context {width: Z} {word: word.word width}.
  Definition leu(a b: word) := negb (word.gtu a b).
  Definition geu(a b: word) := negb (word.ltu a b).
End WithParams. End word.

Section WithParams.
  Context {word: Interface.word.word 32}.
  Context {word_ok: word.ok word}.

  Context {D: device}.
  Context {mem: map.map word byte}.
  Context {Registers: map.map Register word}.

  (* redefine monad notations with explicit type in Bind, otherwise Coq might will
     infer the wrong instance in loadN, without backtracking enough *)
  Notation "x <- m1 ; m2" := (Bind (M := OState (ExtraRiscvMachine D)) m1 (fun x => m2))
    (right associativity, at level 60).
  Notation "m1 ;; m2" := (Bind (M := OState (ExtraRiscvMachine D)) m1 (fun _ => m2))
    (right associativity, at level 60).

  Definition update(f: ExtraRiscvMachine D -> ExtraRiscvMachine D):
    OState (ExtraRiscvMachine D) unit :=
    m <- get; put (f m).

  Definition updateExtra(f: D -> D): OState (ExtraRiscvMachine D) unit :=
    update (fun m => withExtraState (f m.(getExtraState)) m).

  Definition fail_if_None{R}(o: option R): OState (ExtraRiscvMachine D) R :=
    match o with
    | Some x => Return x
    | None => fail_hard
    end.

  Definition N_to_word(v: N): word :=
    word.of_Z (Z.of_N v).

  Definition word_to_N(w: word): N :=
    Z.to_N (word.unsigned w).

  Definition runUntilResp(h2d: tl_h2d):
    OState (ExtraRiscvMachine D) word :=
    mach <- get;
    new_device_state <- fail_if_None
                         (device.runUntilResp h2d (device.maxRespDelay mach.(getExtraState))
                                              mach.(getExtraState));
    put (withExtraState new_device_state mach);;
    Return (N_to_word (d_data (device.last_d2h new_device_state))).

  Definition mmioLoad(log2_nbytes: nat)(addr: word)
    : OState (ExtraRiscvMachine D) (HList.tuple byte (2 ^ log2_nbytes)) :=
    let h2d : tl_h2d :=
        set_a_valid true
        (set_a_opcode Get
        (set_a_size (N.of_nat log2_nbytes)
        (set_a_address (word_to_N addr)
        (set_d_ready true tl_h2d_default)))) in
    v <- runUntilResp h2d;
    Return (LittleEndian.split (2 ^ log2_nbytes) (word.unsigned v)).

  Definition mmioStore(log2_nbytes: nat)(addr: word)(v: HList.tuple byte (2 ^ log2_nbytes))
    : OState (ExtraRiscvMachine D) unit :=
    let h2d : tl_h2d :=
        set_a_valid true
        (set_a_opcode PutFullData
        (set_a_size (N.of_nat log2_nbytes)
        (set_a_address (word_to_N addr)
        (set_a_data (Z.to_N (LittleEndian.combine (2 ^ log2_nbytes) v))
        (set_d_ready true tl_h2d_default))))) in
    ignored <- runUntilResp h2d;
    Return tt.

  Definition loadN(log2_nbytes: nat)(kind: SourceType)(a: word):
    OState (ExtraRiscvMachine D) (HList.tuple byte (2 ^ log2_nbytes)) :=
    mach <- get;
    match Memory.load_bytes (2 ^ log2_nbytes) mach.(getMachine).(getMem) a with
    | Some v =>
      match kind with
      | Fetch => if isXAddr4B a mach.(getMachine).(getXAddrs) then Return v else fail_hard
      | _ => Return v
      end
    | None => if device.isMMIOAddrB a (2 ^ log2_nbytes) then mmioLoad log2_nbytes a else fail_hard
    end.

  Definition storeN(log2_nbytes: nat)(kind: SourceType)(a: word)(v: HList.tuple byte ( 2 ^ log2_nbytes)) :=
    mach <- get;
    match Memory.store_bytes (2 ^ log2_nbytes) mach.(getMachine).(getMem) a v with
    | Some m => update (withMem m)
    | None => if device.isMMIOAddrB a (2 ^ log2_nbytes) then mmioStore log2_nbytes a v else fail_hard
    end;;
    update (fun mach => withXAddrs (invalidateWrittenXAddrs (2 ^ log2_nbytes) a mach.(getXAddrs)) mach).

  Definition interpret_action(a: riscv_primitive): OState (ExtraRiscvMachine D) (primitive_result a) :=
    match a with
    | GetRegister reg =>
        if Z.eq_dec reg Register0 then
          Return (word.of_Z 0)
        else
          mach <- get;
          match map.get mach.(getMachine).(getRegs) reg with
          | Some v => Return v
          | None => Return (word.of_Z 0)
          end
    | SetRegister reg v =>
        if Z.eq_dec reg Register0 then
          Return tt
        else
          update (fun mach => withRegs (map.put mach.(getMachine).(getRegs) reg v) mach)
    | GetPC => mach <- get; Return mach.(getMachine).(getPc)
    | SetPC newPC => update (withNextPc newPC)
    | LoadByte ctxid a => loadN 0 ctxid a
    | LoadHalf ctxid a => loadN 1 ctxid a
    | LoadWord ctxid a => loadN 2 ctxid a
    | LoadDouble ctxid a => loadN 3 ctxid a
    | StoreByte ctxid a v => storeN 0 ctxid a v
    | StoreHalf ctxid a v => storeN 1 ctxid a v
    | StoreWord ctxid a v => storeN 2 ctxid a v
    | StoreDouble ctxid a v => storeN 3 ctxid a v
    | EndCycleNormal => update (fun m => (withPc m.(getNextPc)
                                         (withNextPc (word.add m.(getNextPc) (word.of_Z 4)) m)))
    | EndCycleEarly _
    | MakeReservation _
    | ClearReservation _
    | CheckReservation _
    | GetCSRField _
    | SetCSRField _ _
    | GetPrivMode
    | SetPrivMode _
    | Fence _ _
        => fail_hard
    end.

  Definition device_step_without_IO(d: D): D :=
    let next_state := device.run1 d (set_d_ready true tl_h2d_default) in next_state.

  Fixpoint device_steps(n: nat): OState (ExtraRiscvMachine D) unit :=
    match n with
    | O => Return tt
    | S n' => updateExtra device_step_without_IO;; device_steps n'
    end.

  (* In the time that the riscv core needs to execute the i-th instruction, how many
     cycles does the device execute? *)
  Definition schedule := nat -> nat.

  Section WithSchedule.
    Context (sched: schedule).

    Definition nth_step(n: nat): OState (ExtraRiscvMachine D) unit :=
      device_steps (sched n);; free.interp_as_OState interpret_action (Run.run1 RV32IM).

    Fixpoint run_rec(steps_done steps_remaining: nat): OState (ExtraRiscvMachine D) unit :=
      match steps_remaining with
      | O => Return tt
      | S n => nth_step steps_done;; run_rec (S steps_done) n
      end.

    Definition run(steps_remaining: nat)(s: ExtraRiscvMachine D): option (ExtraRiscvMachine D) :=
      match run_rec 0 steps_remaining s with
      | (Some tt, final) => Some final
      | (None, _) => None
      end.
  End WithSchedule.

End WithParams.


(** * Extensions for Prelude from Embedding *)

(** Extends Prelude from Embedding with new definitions required for extraction *)

From ConCert.Embedding Require Import Ast.
From ConCert.Embedding Require Import Notations.
From ConCert.Embedding Require Import PCUICTranslate.
From ConCert.Embedding Require Import TranslationUtils.
From ConCert.Embedding Require Import Prelude.
From ConCert.Embedding Require Import Utils.
From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import Serializable.
From ConCert.Utils Require Import Automation.
From Coq Require Import String.
From Coq Require Import ZArith.
From Coq Require Import List.

From MetaCoq.Template Require Import All.

Import MCMonadNotation.
Import ListNotations.
Import BaseTypes.
Open Scope list.
Open Scope nat.

(** ** Wrappers for some primitive types *)

MetaCoq Run
        ( mp_ <- tmCurrentModPath tt ;;
          let mp := (PCUICTranslate.string_of_modpath mp_ ++ "@")%string in
          mkNames mp ["address"; "time"; "ContractAddr";
                      "UserAddr"; "Time" ; "Money" ] "_coq").

Definition address_ty :=
  [\ data address =
      ContractAddr [Nat,_]
    | UserAddr [Nat, _] \].

MetaCoq Unquote Inductive (global_to_tc address_ty).

Definition time_ty :=
  [\ data time = Time [Nat,_] \].

MetaCoq Unquote Inductive (global_to_tc time_ty).

Definition money := to_string_name <% Z %>.

(** Comparison for addresses and time *)

Definition ltb_time (t1 t2 : time_coq) :=
  let '(Time_coq n1) := t1 in
    let '(Time_coq n2) := t2 in
    n1 <? n2.

Definition leb_time (t1 t2 : time_coq) :=
  let '(Time_coq n1) := t1 in
  let '(Time_coq n2) := t2 in
  n1 <=? n2.

Definition eqb_addr (a1 a2 : address_coq) :=
  match a1,a2 with
  | ContractAddr_coq n1, ContractAddr_coq n2 => Nat.eqb n1 n2
  | UserAddr_coq n1, UserAddr_coq n2 => Nat.eqb n1 n2
  | _, _ => false
  end.

(** Additional notations for addresses *)

 Notation "a ==a b" := [| {eConst (to_string_name <% eqb_addr %>)} {a} {b} |]
                        (in custom expr at level 0).

(** Additional notations for time *)

Notation "a <t b" := [| {eConst (to_string_name <% ltb_time %>)} {a} {b} |]
                      (in custom expr at level 0).
Notation "a <=t b" := [| {eConst (to_string_name <% leb_time %>)} {a} {b} |]
                       (in custom expr at level 0).

(** A simplified representation of a call context.
    Contains: current time, sender, transaction amount, contract's balance *)
Notation "'CallCtx'" := [! time × (address × (money × money)) !]
                         (in custom type at level 0).

Notation "'current_time' st" :=
  [| first time (address × (money × money)) {st} |]
    (in custom expr at level 0).

Notation "'sender_addr' st" :=
  [| first address (money × money) (second time (address × (money × money)) {st}) |]
    (in custom expr at level 0).

Notation "'sent_amount' st" :=
  [| first money money (second address (money × money) (second time (address × (money × money)) {st})) |]
    (in custom expr at level 0).

Notation "'acc_balance' st" :=
  [| second money money (second address (money × money) (second time (address × (money × money)) {st})) |]
    (in custom expr at level 0).

Notation "'mkCallCtx' now sender sent_am bal " :=
  [| Pair time (address × (money × money)) {now}
          (Pair address (money × money) {sender}
                (Pair money money {sent_am} {bal} )) |]
    (in custom expr at level 0).

(** A simple representation of the call context *)

(** current_time, sender_add, sent_amount, acc_balance *)
Definition SimpleCallCtx : Set := time_coq × (address_coq × (Amount × Amount)).

(** These projections correspond to the notations above *)
Definition sc_current_time (ctx : SimpleCallCtx) : time_coq := ctx.1.
Definition sc_sender_addr (ctx : SimpleCallCtx) : address_coq := ctx.2.1.
Definition sc_sent_amount (ctx : SimpleCallCtx) : Z := ctx.2.2.1.
Definition sc_acc_balance (ctx : SimpleCallCtx) : Z := ctx.2.2.2.

Definition is_contract (addr: address_coq) :=
  match addr with
  | ContractAddr_coq _ => true
  | UserAddr_coq _ => false
  end.

Definition encode_addr (addr: address_coq) : nat + nat :=
  match addr with
  | ContractAddr_coq x => inl x
  | UserAddr_coq x => inr x
  end.

Definition decode_addr (addr: nat + nat) : address_coq :=
  match addr with
  | inl x => ContractAddr_coq x
  | inr x => UserAddr_coq x
  end.

Global Program Instance CB : ChainBase :=
  build_chain_base address_coq eqb_addr _ _ _ _ is_contract.
Next Obligation.
  intros a b. destruct a,b; simpl.
  - destruct (n =? n0)%nat eqn:Heq.
    * constructor. now rewrite Nat.eqb_eq in *.
    * constructor. now rewrite NPeano.Nat.eqb_neq in *.
  - now constructor.
  - now constructor.
  - destruct (n =? n0)%nat eqn:Heq.
    * constructor. now rewrite Nat.eqb_eq in *.
    * constructor. now rewrite NPeano.Nat.eqb_neq in *.
Qed.
Next Obligation.
  intros ??. unfold base.Decision.
  decide equality; apply Nat.eq_dec.
Qed.
Next Obligation.
  assert (cnat : countable.Countable (nat + nat)) by typeclasses eauto.
  destruct cnat as [e d H].
  unshelve econstructor.
  * intros addr. destruct addr.
    exact (e (inl n)).
    exact (e (inr n)).
  * intros i.
    destruct (d i).
    ** destruct s as [n | n].
       exact (Some (ContractAddr_coq n)).
       exact (Some (UserAddr_coq n)).
    ** exact None.
  * cbn; intros addr.
    destruct addr;
    now rewrite H.
Defined.
Next Obligation.
  assert (snat : Serializable.Serializable (nat + nat)) by typeclasses eauto.
  destruct snat as [s d H].
  unshelve econstructor.
  * intros addr. destruct addr.
    exact (s (inl n)).
    exact (s (inr n)).
  * intros i.
    destruct (d i) as [v | ].
    ** destruct v as [n | n].
       exact (Some (ContractAddr_coq n)).
       exact (Some (UserAddr_coq n)).
    ** exact None.
  * cbn; intros addr.
    destruct addr;
      now rewrite H.
Defined.

Definition init_wrapper {setup storage}
           (init : SimpleCallCtx -> setup -> storage)
           (ch : Chain)
           (ctx : ContractCallContext) : setup -> storage :=
  let simple_ctx :=
      (Time_coq ch.(current_slot),
       ((ctx.(ctx_from)),
        ((ctx.(ctx_amount), ctx.(ctx_contract_balance))))) in
    init simple_ctx.

(** Our approximation for finite maps. We cannot use the one defined in the
    Embedding.Prelude, because it cannot be made parametric wrt. the type of
    keys doe to limitations of the embedding (types cannot be constants,
    only inductives) *)
Module Maps.
  Open Scope nat.

  MetaCoq Run
          ( mp_ <- tmCurrentModPath tt ;;
            let mp := (PCUICTranslate.string_of_modpath mp_ ++ "@")%string in
            mkNames mp ["addr_map" ] "_coq").

  Definition addr_map_acorn :=
    [\ data addr_map =
          "mnil" [_]
        | "mcons" [address, money, addr_map,_] \].

  MetaCoq Unquote Inductive (global_to_tc addr_map_acorn).

  Definition Map := to_string_name <% addr_map_coq %>.

  Fixpoint lookup_map (m : addr_map_coq) (key : address_coq) : option Z :=
    match m with
    | mnil => None
    | mcons k v m' =>
      if (eqb_addr key k) then Some v else lookup_map m' key
    end.

  (* Ported from FMapWeaklist of StdLib *)
  Fixpoint add_map (k : address_coq) (x : Z) (s : addr_map_coq) : addr_map_coq :=
  match s with
   | mnil => mcons k x mnil
   | mcons k' y l => if eqb_addr k k' then mcons k x l else mcons k' y (add_map k x l)
  end.

  Definition inmap_map k m := match lookup_map m k with
                              | Some _ => true
                              | None => false
                              end.

  Lemma lookup_map_add k v m : lookup_map (add_map k v m) k = Some v.
  Proof.
    induction m.
    + simpl. destruct k; simpl; now rewrite PeanoNat.Nat.eqb_refl.
    + simpl. destruct (eqb_addr k a) eqn:Heq.
      * destruct k; simpl; now rewrite PeanoNat.Nat.eqb_refl.
      * simpl. now rewrite Heq.
  Qed.

  Fixpoint to_list (m : addr_map_coq) : list (address_coq * Z)%type :=
    match m with
    | mnil => nil
    | mcons k v tl => cons (k,v) (to_list tl)
    end.

  Fixpoint of_list (l : list (address_coq * Z)) : addr_map_coq :=
    match l with
    | nil => mnil
    | cons (k,v) tl => mcons k v (of_list tl)
    end.

  Lemma of_list_to_list m: of_list (to_list m) = m.
  Proof. induction m; simpl; congruence. Qed.

  Lemma to_list_of_list l: to_list (of_list l) = l.
  Proof. induction l as [ | x l']; simpl; auto.
         destruct x. simpl; congruence. Qed.

  Fixpoint map_forallb (p : Z -> bool)(m : addr_map_coq) : bool :=
    match m with
    | mnil => true
    | mcons k v m' => p v && map_forallb p m'
    end.

  Lemma map_forallb_lookup_map p m k v :
    map_forallb p m = true ->
    lookup_map m k = Some v ->
    p v = true.
  Proof.
    revert k v p.
    induction m; intros; try discriminate; simpl in *.
    propify. destruct (eqb_addr _ _); auto.
    * now inversion H0; subst.
    * easy.
  Qed.

  (** Notations for functions on finite maps *)

  Notation "'MNil'" := [| {eConstr Map "mnil"} |]
                         (in custom expr at level 0).

  Notation "'mfind' a b" := [| {eConst (to_string_name <% lookup_map %>)} {a} {b} |]
          (in custom expr at level 0,
              a custom expr at level 1,
              b custom expr at level 1).

  Notation "'madd' a b c" := [| {eConst (to_string_name <% add_map %>)} {a} {b} {c} |]
          (in custom expr at level 0,
              a custom expr at level 1,
              b custom expr at level 1,
              c custom expr at level 1).

  Notation "'mem' a b" := [| {eConst (to_string_name <% inmap_map %>)} {a} {b} |]
          (in custom expr at level 0,
              a custom expr at level 1,
              b custom expr at level 1).

End Maps.


Require Import CSet Util Filter Take MoreList OUnion AllInRel MapDefined MapUpdate Position.
Require Import IL Annotation LabelsDefined.
Require Import Liveness.Liveness TrueLiveness SimI.
Require Import RenamedApart.
Require Import SpillSound ReconstrLive DoSpill.

Set Implicit Arguments.
Unset Printing Records.

Lemma agree_on_eq_oval (D:set var) (f g: var -> option val)
  : agree_on _eq D f g
    -> agree_on eq D f g.
Proof.
  intros; hnf; intros.
  eapply H in H0. inv H0; eauto; simpl in *; congruence.
Qed.

Lemma sim_write_moves D r L V s L' V' s' xl yl (Len:❬xl❭ = ❬yl❭)
  : (forall (V'':onv val), agree_on eq D (V'[xl <-- lookup_list V' yl]) V''
                        -> paco3 (sim_gen (S':=I.state)) r SimExt (L, V, s) (L', V'', s'))
    -> defined_on (of_list yl) V'
    -> disj (of_list xl) (of_list yl)
    -> NoDupA _eq xl
    -> paco3 (sim_gen (S':=I.state)) r SimExt (L, V, s)
            (L', V', write_moves xl yl s').
Proof.
  intros SIM Def Disj Uniq.
  length_equify. general induction Len.
  - simpl in *. eapply SIM; eauto.
  - simpl in *; dcr; invt NoDupA.
    edestruct Def; [cset_tac|].
    pone_step_right; simpl. rewrite <- H.
    eapply IHLen; intros; eauto using injective_on_incl.
    eapply SIM.
    + rewrite <- update_nodup_commute_eq; simpl; eauto with len.
      erewrite lookup_list_agree; eauto.
      symmetry. eapply agree_on_update_dead; eauto.
      eapply disj_not_in.
      eapply disj_incl; eauto with cset.
    + rewrite H; eapply defined_on_update_some;
        eauto using defined_on_incl with cset.
    + eapply disj_incl; eauto with cset.
Qed.

Lemma sim_I_moves (slot : var -> var) k Λ ZL r L L' V V' R M s sl RML
  : spill_sound k ZL Λ (R,M) s sl
    -> injective_on (getSp sl ∪ getL sl) slot
    -> disj (getSp sl ∪ getL sl) (map slot (getSp sl ∪ getL sl))
    -> defined_on (getSp sl ∪ (map slot (getL sl) \ map slot (getSp sl))) V'
    -> (forall V'', agree_on eq (R ∪ map slot M ∪ map slot (getSp sl) ∪ getL sl)
                       (V' [slot ⊝ elements (getSp sl) <-- lookup_list V' (elements (getSp sl))]
                           [elements (getL sl) <-- lookup_list (V'[slot ⊝ elements (getSp sl) <-- lookup_list V' (elements (getSp sl))]) (slot ⊝ elements (getL sl))]) V''
              -> paco3 (sim_gen (S':=I.state)) r SimExt (L, V, s)
                      (L', V'', do_spill slot s (setTopAnn sl ({}, {}, snd (getAnn sl))) ZL RML))
    -> sim r SimExt (L, V, s) (L', V', do_spill slot s sl ZL RML).
Proof.
  simpl. unfold sim. revert_except s.
  intros ? ? ? ? ? ? ? ? ? ? ? ? ? SPS Inj Disj Def SIM.
  rewrite do_spill_extract_writes.
  exploit L_sub_SpM; eauto.
  exploit Sp_sub_R; eauto.
  eapply (@sim_write_moves (R ∪ map slot M ∪ map slot (getSp sl) ∪ map slot (getL sl)));
    try rewrite ?of_list_map, of_list_elements; eauto. eauto with len.
  intros ? Agr3.
  eapply (@sim_write_moves (R ∪ map slot M ∪ map slot (getSp sl) ∪ getL sl)); try rewrite ?of_list_map, of_list_elements; eauto. eauto with len.
  intros ? Agr4.
  - rewrite update_with_list_agree in Agr4; eauto;
      [| symmetry; eapply agree_on_incl; eauto; clear; rewrite of_list_elements; cset_tac
       |eauto with len].
    erewrite <- (lookup_list_agree) in Agr4.
    eapply SIM; eauto.
    rewrite of_list_map, of_list_elements; eauto.
    eapply agree_on_incl; eauto with cset.
  - eapply defined_on_agree_eq; eauto using agree_on_incl with cset.
    rewrite (incl_union_minus _ _ (map slot (getSp sl))).
    eapply defined_on_union.
    + hnf; intros.
      rewrite <- (of_list_elements _ (getSp sl)) in H1.
      rewrite <- of_list_map in H1; eauto.
      edestruct update_with_list_lookup_in_list; try eapply H1; dcr.
      Focus 2. rewrite H5. inv_get. eapply get_elements_in in H3.
      rewrite lookup_list_map in H4; inv_get.
      eapply get_elements_in in H4.
      eauto with cset.
      eauto with len.
    + hnf; intros.
      rewrite lookup_set_update_not_in_Z; eauto.
      eapply Def; eauto with cset.
      rewrite of_list_map, of_list_elements; eauto.
      revert H1; clear_all; cset_tac.
  - eapply disj_incl; eauto with cset.
  - eapply elements_3w.
  - eauto using defined_on_incl with cset.
  - symmetry.
     eapply disj_incl; eauto with cset.
  - eapply injective_nodup_map; eauto.
    rewrite of_list_elements. eauto using injective_on_incl with cset.
    eapply elements_3w.
Qed.

Instance proper_onv (ϱ:var -> option val)
  : (@Proper (forall _ : var, option val)
             (@respectful var (option val) (@_eq var (@SOT_as_OT var (@eq var) _))
                          (@eq (option val))) ϱ) | 0.
Proof.
  intuition.
Qed.

Instance proper_onv' (ϱ:var -> option val)
  : @Proper (forall _ : var, option val)
            (@respectful var (option val) (@_eq var (@SOT_as_OT var (@eq var) _))
                         (@_eq (option val) (@option_OrderedType val OrderedType_int))) ϱ | 0.
Proof.
  intuition.
Qed.

Lemma load_agree_after_spill_load (slot : var -> var) (V V':var->option val) VD R M Sp L0
      (Inj : injective_on VD slot)
      (Agr1 : agree_on eq R V V')
      (Agr2 : agree_on eq M V (fun x : var => V' (slot x)))
      (VDincl:Sp ∪ L0 [<=] VD) (SpR:Sp [<=] R) (LSpM:L0 [<=] Sp ∪ M)
  : agree_on eq L0 V
             (V' [slot ⊝ elements Sp <-- V' ⊝ elements Sp]
                 [elements L0 <-- V' [slot ⊝ elements Sp <-- V' ⊝ elements Sp]
                           ⊝ slot ⊝ elements L0]).
Proof.
  eapply agree_on_update_list; try eapply proper_onv; eauto with len.
  rewrite of_list_elements. eapply agree_on_empty; eauto with cset.
  rewrite !lookup_list_map. rewrite map_map. rewrite <- !lookup_list_map.
  eapply lookup_list_agree. rewrite lookup_list_map.
  rewrite of_list_elements.
  etransitivity; [| eapply agree_on_eq_oval, agree_on_update_list_map];
    [ | eauto with len | eapply proper_var | eapply proper_onv'
      | eapply injective_on_incl; eauto; rewrite <- VDincl, of_list_elements; clear; cset_tac ].
  rewrite (set_decomp Sp).
  eapply agree_on_union.
  ++ rewrite lookup_list_map.
    etransitivity; [eapply agree_on_incl; [ eapply Agr1| rewrite <- SpR; clear; cset_tac]|].
    eapply agree_on_update_list; [ eapply proper_onv | eauto with len |
                                   | rewrite lookup_list_map; reflexivity ].
    rewrite of_list_elements. eapply agree_on_empty; clear; cset_tac.
  ++ rewrite lookup_list_map.
    eapply agree_on_update_list_dead.
    eapply agree_on_incl; eauto. rewrite LSpM. clear; cset_tac.
    rewrite of_list_elements. hnf; intros; cset_tac.
Qed.

Lemma regs_untouched_after_spill_load (slot : var -> var) (V V' V'':var->option val) VD R M K Sp L0
      (Agr3 : agree_on eq (R ∪ map slot M ∪ map slot Sp ∪ L0)
                       (V' [slot ⊝ elements Sp <-- V' ⊝ elements Sp]
                           [elements L0 <-- V' [slot ⊝ elements Sp <-- V' ⊝ elements Sp]
                                     ⊝ slot ⊝ elements L0]) V'')
      (Disj : disj VD (map slot VD)) (Incl : R ∪ M [<=] VD)
      (Agr1 : agree_on eq R V V')
      (VDincl:Sp ∪ L0 [<=] VD)
  :  agree_on eq ((R \ K) \ L0) V V''.
Proof.
  etransitivity; [eapply agree_on_incl; [eapply Agr1| clear; cset_tac]|].
  etransitivity; [|eapply agree_on_incl; [eapply Agr3| clear; cset_tac]].
  eapply agree_on_update_list_dead.
  eapply agree_on_update_list_dead. reflexivity.
  rewrite of_list_map, of_list_elements; eauto.
  symmetry. eapply disj_incl; eauto; only 2: eauto with cset.
  rewrite <- Incl. clear; cset_tac.
  rewrite of_list_elements. clear; hnf; intros; cset_tac.
Qed.

Lemma regs_agree_after_spill_load (slot : var -> var) (V V' V'':var -> option val) VD R M K Sp L0
      (Agr3 : agree_on eq (R ∪ map slot M ∪ map slot Sp ∪ L0)
                       (V' [slot ⊝ elements Sp <-- V' ⊝ elements Sp]
                           [elements L0 <-- V' [slot ⊝ elements Sp <-- V' ⊝ elements Sp]
                                     ⊝ slot ⊝ elements L0]) V'')
      (Inj : injective_on VD slot) (Disj : disj VD (map slot VD)) (Incl : R ∪ M [<=] VD)
      (Agr1 : agree_on eq R V V')
      (Agr2 : agree_on eq M V (fun x : var => V' (slot x)))
      (VDincl:Sp ∪ L0 [<=] VD) (SpR:Sp [<=] R) (LSpM:L0 [<=] Sp ∪ M)
  : agree_on eq (R \ K ∪ L0) V V''.
Proof.
  etransitivity; [|eapply agree_on_incl; [eapply Agr3| clear; cset_tac]].
  rewrite union_comm, union_exclusive.
  eapply agree_on_union.
  -- eapply load_agree_after_spill_load; eauto.
  -- eapply regs_untouched_after_spill_load; eauto.
     reflexivity.
Qed.

Lemma spills_agree_after_spill_load (slot : var -> var) (V V' V'':var->option val) VD R M Sp L0
      (Inj : injective_on VD slot) (Disj : disj VD (map slot VD)) (Incl : R ∪ M [<=] VD)
      (Agr1 : agree_on eq R V V')
      (Agr2 : agree_on eq M V (fun x : var => V' (slot x)))
      (VDincl:Sp ∪ L0 [<=] VD) (SpR:Sp [<=] R) (LSpM:L0 [<=] Sp ∪ M)
      (Agr3 : agree_on eq (R ∪ map slot M ∪ map slot Sp ∪ L0)
                       (V' [slot ⊝ elements Sp <-- V' ⊝ elements Sp]
                           [elements L0 <-- V' [slot ⊝ elements Sp <-- V' ⊝ elements Sp]
                                     ⊝ slot ⊝ elements L0]) V'')
  : agree_on eq Sp V (fun x : var => V'' (slot x)).
Proof.
  eapply agree_on_comp; eauto; [ symmetry; eapply agree_on_incl; eauto; clear_all; cset_tac | ].
  etransitivity; [eapply agree_on_incl; [eapply Agr1| eauto with cset]|].
  eapply agree_on_update_list_dead_slot; eauto.
  etransitivity; [| eapply agree_on_eq_oval, agree_on_update_list_map];
    [ | eauto with len | eapply proper_var | eapply proper_onv'
      | eapply injective_on_incl; eauto; rewrite <- VDincl, of_list_elements;
        clear; cset_tac ].
  eapply agree_on_update_list; [ eapply proper_onv | eauto with len |
                                 | rewrite lookup_list_map; reflexivity ].
  eapply agree_on_empty. rewrite of_list_elements. cset_tac.
  eapply disj_incl; eauto with cset.
  rewrite of_list_elements, <- Incl, LSpM, <- SpR; reflexivity.
Qed.

Lemma mem_untouched_after_spill_load (slot : var -> var) (V V' V'':var->option val) VD R M Sp L0
      (Inj : injective_on VD slot) (Disj : disj VD (map slot VD)) (Incl : R ∪ M [<=] VD)
      (Agr1 : agree_on eq R V V')
      (Agr2 : agree_on eq M V (fun x : var => V' (slot x)))
      (VDincl:Sp ∪ L0 [<=] VD) (SpR:Sp [<=] R) (LSpM:L0 [<=] Sp ∪ M)
      (Agr3 : agree_on eq (R ∪ map slot M ∪ map slot Sp ∪ L0)
                       (V' [slot ⊝ elements Sp <-- V' ⊝ elements Sp]
                           [elements L0 <-- V' [slot ⊝ elements Sp <-- V' ⊝ elements Sp]
                                     ⊝ slot ⊝ elements L0]) V'')
  : agree_on eq (M \ Sp) V (fun x : var => V'' (slot x)).
Proof.
  etransitivity; [eapply agree_on_incl; [eapply Agr2| eauto with cset ]|].
  eapply agree_on_comp_both; eauto using proper_onv.
  etransitivity; [| eapply agree_on_incl; [eapply Agr3| eauto]].
  - eapply agree_on_update_list_dead.
    eapply agree_on_update_list_dead. reflexivity.
    rewrite of_list_map, of_list_elements; eauto.
    intros.
    eapply injective_disj; eauto.
    hnf; intros; cset_tac.
    eapply injective_on_incl; eauto. rewrite <- Incl. rewrite SpR at 1.
    cset_tac.
    rewrite of_list_elements.
    eapply disj_incl; eauto.
    rewrite <- Incl, LSpM, <- SpR. eauto. eauto with cset.
  - rewrite minus_incl. clear. cset_tac.
Qed.

Lemma mem_agrees_after_spill_load (slot : var -> var) (V V' V'':var->option val) VD R M Sp L0
      (Agr3 : agree_on eq (R ∪ map slot M ∪ map slot Sp ∪ L0)
                       (V' [slot ⊝ elements Sp <-- V' ⊝ elements Sp]
                           [elements L0 <-- V' [slot ⊝ elements Sp <-- V' ⊝ elements Sp]
                                     ⊝ slot ⊝ elements L0]) V'')
      (Inj : injective_on VD slot) (Disj : disj VD (map slot VD)) (Incl : R ∪ M [<=] VD)
      (Agr1 : agree_on eq R V V')
      (Agr2 : agree_on eq M V (fun x : var => V' (slot x)))
      (VDincl:Sp ∪ L0 [<=] VD) (SpR:Sp [<=] R) (LSpM:L0 [<=] Sp ∪ M)
  : agree_on eq (Sp ∪ M) V (fun x : var => V'' (slot x)).
Proof.
  rewrite union_exclusive.
  eapply agree_on_union.
  -- eapply spills_agree_after_spill_load; try eapply Agr3; eauto.
  -- eapply mem_untouched_after_spill_load; try eapply Agr3; eauto.
Qed.

Lemma mem_agrees_after_spill_load_update (slot : var -> var) (V V' V'':var->option val) VD R M Sp L0 x v
      (Agr5 : agree_on eq (Sp ∪ M) V (fun x : var => V'' (slot x)))
      (Disj : disj VD (map slot VD)) (Incl : R ∪ M [<=] VD) (NotIn: x ∉ Sp ∪ M)
      (xIn:x ∈ VD)
      (Agr1 : agree_on eq R V V')
      (Agr2 : agree_on eq M V (fun x : var => V' (slot x)))
      (VDincl:Sp ∪ L0 [<=] VD) (SpR:Sp [<=] R) (LSpM:L0 [<=] Sp ∪ M)
      (Agr3 : agree_on eq (R ∪ map slot M ∪ map slot Sp ∪ L0)
                       (V' [slot ⊝ elements Sp <-- V' ⊝ elements Sp]
                           [elements L0 <-- V' [slot ⊝ elements Sp <-- V' ⊝ elements Sp]
                                     ⊝ slot ⊝ elements L0]) V'')
  : agree_on eq (Sp ∪ M) (V [x <- ⎣ v ⎦]) (fun x0 : var => (V'' [x <- ⎣ v ⎦]) (slot x0)).
Proof.
  eapply agree_on_update_dead_both_comp_right; eauto.
  eapply disj_incl; eauto. rewrite SpR, Incl. revert xIn; clear. cset_tac.
  rewrite SpR, Incl. cset_tac.
Qed.

Lemma RKL_incl X `{OrderedType X} (R K L D D':set X)
  :  R \ K ∪ L ⊆ R ∪ D ∪ D' ∪ L.
Proof.
  cset_tac.
Qed.

Hint Resolve RKL_incl | 0: cset.

Lemma defined_on_after_spill_load (slot : var -> var) (V V' V'':var->option val) VD R M Sp L0  K
      (Agr5 : agree_on eq (Sp ∪ M) V (fun x : var => V'' (slot x)))
      (Disj : disj VD (map slot VD)) (Incl : R ∪ M [<=] VD)
      (Agr1 : agree_on eq R V V') (Def : defined_on (R ∪ map slot M) V')
      (Agr2 : agree_on eq M V (fun x : var => V' (slot x)))
      (VDincl:Sp ∪ L0 [<=] VD) (SpR:Sp [<=] R) (LSpM:L0 [<=] Sp ∪ M)
      (Agr3 : agree_on eq (R ∪ map slot M ∪ map slot Sp ∪ L0)
                       (V' [slot ⊝ elements Sp <-- V' ⊝ elements Sp]
                           [elements L0 <-- V' [slot ⊝ elements Sp <-- V' ⊝ elements Sp]
                                     ⊝ slot ⊝ elements L0]) V'')
  : defined_on (R \ K ∪ L0 ∪ map slot (Sp ∪ M)) V''.
Proof.
  assert (defined_on Sp V') as DefSp by eauto using defined_on_incl with cset.
  rewrite union_exclusive.
  eapply defined_on_union.
  -- eapply defined_on_agree_eq; [|eapply agree_on_incl;[eapply Agr3|eauto with cset]].
     rewrite union_comm, union_exclusive. eapply defined_on_union.
     ++ eapply defined_on_update_list'; eauto with len.
       rewrite of_list_elements. clear; hnf; intros; cset_tac.
       eapply defined_on_defined. clear; intuition.
       rewrite of_list_map, of_list_elements; eauto.
       eapply defined_on_update_list'; eauto with len.
       rewrite of_list_map, of_list_elements; eauto.
       rewrite LSpM. eapply (defined_on_incl Def); eauto.
       rewrite map_union; eauto. clear; cset_tac.
       eapply defined_on_defined. clear; intuition. eauto.
       rewrite of_list_elements. eauto.
     ++ eapply defined_on_agree_eq; [| eapply agree_on_update_list_dead; try reflexivity].
       eapply defined_on_update_list'; eauto with len.
       rewrite of_list_map, of_list_elements; eauto.
       eapply (defined_on_incl Def). clear; cset_tac.
       eapply defined_on_defined. clear; intuition. eauto.
       rewrite of_list_elements. eauto.
       rewrite of_list_elements. eauto. clear; hnf; intros; cset_tac.
  -- rewrite map_union; eauto.
     eapply defined_on_agree_eq; [ | eapply agree_on_incl; [ eapply Agr3| clear; cset_tac]];
       eauto.
     eapply defined_on_agree_eq; [| eapply agree_on_update_list_dead; try reflexivity].
     eapply defined_on_update_list'; eauto with len.
     rewrite of_list_map, of_list_elements; eauto.
     eapply (defined_on_incl Def). clear; cset_tac.
     eapply defined_on_defined. clear; intuition. eauto.
     rewrite of_list_elements. eauto.
     rewrite of_list_elements. clear; hnf; intros; cset_tac.
Qed.