Require Import VerdiRaft.Raft.
Require Import VerdiRaft.CommonTheorems.
Require Import VerdiRaft.SpecLemmas.
Require Import VerdiRaft.RaftRefinementInterface.
Require Import VerdiRaft.CroniesTermInterface.

Require Import VerdiRaft.CroniesCorrectInterface.
Require Import VerdiRaft.CandidateEntriesInterface.

Require Import VerdiRaft.RefinementSpecLemmas.
Require Import VerdiRaft.RefinementCommonTheorems.

Local Arguments update {_} {_} _ _ _ _ _ : simpl never.

Require Import VerdiRaft.PrevLogCandidateEntriesTermInterface.

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

  Context {rri : raft_refinement_interface}.
  Context {cei : candidate_entries_interface}.
  Context {cti : cronies_term_interface}.
  Context {cci : cronies_correct_interface}.

  Lemma prevLog_candidateEntriesTerm_init :
    refined_raft_net_invariant_init prevLog_candidateEntriesTerm.
  Proof using.
    unfold refined_raft_net_invariant_init, prevLog_candidateEntriesTerm.
    simpl. intuition.
  Qed.

  Lemma candidateEntriesTerm_ext : forall t sigma sigma',
      (forall h, sigma' h = sigma h) ->
      candidateEntriesTerm t sigma ->
      candidateEntriesTerm t sigma'.
  Proof using.
    unfold candidateEntriesTerm.
    intros. break_exists_exists.
    repeat find_higher_order_rewrite. intuition.
  Qed.

  Lemma candidateEntriesTerm_same : forall st st' t,
       candidateEntriesTerm t st ->
       (forall h, cronies (fst (st' h)) = cronies (fst (st h))) ->
       (forall h, currentTerm (snd (st' h)) = currentTerm (snd (st h))) ->
       (forall h, type (snd (st' h)) = type (snd (st h))) ->
       candidateEntriesTerm t st'.
  Proof using.
    unfold candidateEntriesTerm.
    intros. break_exists_exists.
    repeat find_higher_order_rewrite.
    intuition.
  Qed.

  Lemma prevLog_candidateEntriesTerm_client_request :
    refined_raft_net_invariant_client_request prevLog_candidateEntriesTerm.
  Proof using.
    unfold refined_raft_net_invariant_client_request, prevLog_candidateEntriesTerm.
    simpl. intros.
    find_apply_hyp_hyp. break_or_hyp.
    - eapply candidateEntriesTerm_ext; eauto.
      eapply candidateEntriesTerm_same; eauto; intros;
      update_destruct_simplify; auto.
      + now erewrite update_elections_data_client_request_cronies by eauto.
      + find_apply_lem_hyp handleClientRequest_type. intuition.
      + find_apply_lem_hyp handleClientRequest_type. intuition.
    - find_apply_lem_hyp in_map_iff. break_exists. break_and. subst. simpl in *.
      exfalso. eapply handleClientRequest_no_append_entries; eauto.
      find_rewrite. eauto 10.
  Qed.

  Lemma update_elections_data_timeout_cronies :
    forall h d out d' l t,
      handleTimeout h (snd d) = (out, d', l) ->
      cronies (update_elections_data_timeout h d) t = cronies (fst d) t \/
      (t = currentTerm d' /\ type d' = Candidate /\
       cronies (update_elections_data_timeout h d) t = votesReceived d').
  Proof using.
    unfold update_elections_data_timeout.
    intros.
    repeat break_match; repeat find_inversion; simpl; auto.
    break_match; auto.
  Qed.

  Lemma handleClientRequest_preserves_candidateEntriesTerm:
    forall net h d t out l,
      refined_raft_intermediate_reachable net ->
      handleTimeout h (snd (nwState net h)) = (out, d, l) ->
      candidateEntriesTerm t (nwState net) ->
      candidateEntriesTerm t
                           (update name_eq_dec (nwState net) h
                                   (update_elections_data_timeout h (nwState net h), d)).
  Proof using cti.
    unfold candidateEntriesTerm.
    intros.
    break_exists_exists. break_and.
    match goal with
    | [ H : handleTimeout _ _ = _ |- _ ] =>
      pose proof H;
        eapply update_elections_data_timeout_cronies with (t := t) in H
    end. break_or_hyp.
    - update_destruct_simplify; auto.
      find_copy_apply_lem_hyp handleTimeout_type_strong.
      intuition; repeat find_rewrite; auto.
      find_apply_lem_hyp wonElection_exists_voter.
      break_exists.
      find_apply_lem_hyp in_dedup_was_in.
      find_copy_apply_lem_hyp cronies_term_invariant; auto.
      simpl in *.
      lia.
    - update_destruct_simplify; auto.
      find_copy_apply_lem_hyp handleTimeout_type_strong.
      find_apply_lem_hyp wonElection_exists_voter.
      break_exists.
      find_apply_lem_hyp in_dedup_was_in.
      find_copy_apply_lem_hyp cronies_term_invariant; auto.
      intuition; subst; repeat find_rewrite; auto;
      simpl in *; lia.
  Qed.

  Lemma prevLog_candidateEntriesTerm_timeout :
    refined_raft_net_invariant_timeout prevLog_candidateEntriesTerm.
  Proof using cti.
    unfold refined_raft_net_invariant_timeout, prevLog_candidateEntriesTerm.
    simpl. intros.
    find_apply_hyp_hyp. break_or_hyp.
    - eapply candidateEntriesTerm_ext; eauto.
      eapply handleClientRequest_preserves_candidateEntriesTerm; eauto.
    - find_apply_lem_hyp in_map_iff. break_exists. break_and.
      subst. simpl in *.
      exfalso. eapply handleTimeout_not_is_append_entries; eauto.
      find_rewrite. eauto 10.
  Qed.

  Lemma handleAppendEntries_preserves_candidateEntriesTerm :
    forall net h t n pli plt es ci d m t',
      handleAppendEntries h (snd (nwState net h)) t n pli plt es ci = (d, m) ->
      refined_raft_intermediate_reachable net ->
      candidateEntriesTerm t' (nwState net) ->
      candidateEntriesTerm t' (update name_eq_dec (nwState net) h
                                 (update_elections_data_appendEntries
                                    h
                                    (nwState net h) t n pli plt es ci, d)).
  Proof using.
    unfold candidateEntriesTerm.
    intros.
    break_exists_exists. break_and.
    update_destruct_simplify.
    - rewrite update_elections_data_appendEntries_cronies.
      find_apply_lem_hyp handleAppendEntries_type.
      intuition; subst; repeat find_rewrite; auto.
      discriminate.
    - intuition.
  Qed.

  Lemma prevLog_candidateEntriesTerm_append_entries :
    refined_raft_net_invariant_append_entries prevLog_candidateEntriesTerm.
  Proof using.
    unfold refined_raft_net_invariant_append_entries, prevLog_candidateEntriesTerm.
    simpl. intros.
    find_apply_hyp_hyp. break_or_hyp.
    - find_eapply_lem_hyp app_cons_in_rest; [|solve[eauto]].
      eapply candidateEntriesTerm_ext; eauto.
      eapply handleAppendEntries_preserves_candidateEntriesTerm; eauto.
    - exfalso. eapply handleAppendEntries_not_append_entries; eauto.
      simpl in *. subst. eauto 10.
  Qed.

  Lemma handleAppendEntriesReply_preserves_candidateEntriesTerm :
  forall net h h' t es r st' ms t',
    handleAppendEntriesReply h (snd (nwState net h)) h' t es r = (st', ms) ->
    refined_raft_intermediate_reachable net ->
    candidateEntriesTerm t' (nwState net) ->
    candidateEntriesTerm t' (update name_eq_dec (nwState net) h (fst (nwState net h), st')).
  Proof using.
    unfold candidateEntriesTerm.
    intros. break_exists_exists.
    find_apply_lem_hyp handleAppendEntriesReply_type.
    update_destruct_simplify.
    - intuition; repeat find_rewrite; auto. discriminate.
    - auto.
  Qed.

  Lemma prevLog_candidateEntriesTerm_append_entries_reply :
    refined_raft_net_invariant_append_entries_reply prevLog_candidateEntriesTerm.
  Proof using.
    unfold refined_raft_net_invariant_append_entries_reply, prevLog_candidateEntriesTerm.
    simpl. intros.
    find_apply_hyp_hyp. break_or_hyp.
    - find_eapply_lem_hyp app_cons_in_rest; [|solve[eauto]].
      eapply candidateEntriesTerm_ext; eauto.
      eauto using handleAppendEntriesReply_preserves_candidateEntriesTerm.
    - find_apply_lem_hyp in_map_iff. break_exists. break_and.
      find_apply_lem_hyp handleAppendEntriesReply_packets.
      subst. simpl in *. intuition.
  Qed.

  Lemma update_elections_data_requestVote_cronies_same :
    forall h h' t lli llt st,
      cronies (update_elections_data_requestVote h h' t h' lli llt st) =
      cronies (fst st).
  Proof using.
    unfold update_elections_data_requestVote.
    intros.
    repeat break_match; auto.
  Qed.

  Lemma advanceCurrentTerm_same_or_type_follower :
    forall st t,
      advanceCurrentTerm st t = st \/
      type (advanceCurrentTerm st t) = Follower.
  Proof using.
    unfold advanceCurrentTerm.
    intros. repeat break_match; auto.
  Qed.

  Lemma handleRV_advanceCurrentTerm_preserves_candidateEntriesTerm :
    forall net h h' t lli llt t',
      candidateEntriesTerm t' (nwState net) ->
      candidateEntriesTerm t'
                       (update name_eq_dec (nwState net) h
                               (update_elections_data_requestVote h h' t h' lli llt (nwState net h),
                                advanceCurrentTerm (snd (nwState net h)) t)).
  Proof using.
    unfold candidateEntriesTerm.
    intros.
    break_exists_exists.
    update_destruct_simplify; intuition.
    - now rewrite update_elections_data_requestVote_cronies_same.
    - intros.
      match goal with
      | [ H : context [advanceCurrentTerm ?st ?t] |- _ ] =>
        pose proof advanceCurrentTerm_same_or_type_follower st t
      end.
      intuition.
      + repeat find_rewrite. auto.
      + congruence.
  Qed.

  Lemma handleRequestVote_preserves_candidateEntriesTerm :
    forall net h h' t lli llt d t' m,
      handleRequestVote h (snd (nwState net h)) t h' lli llt = (d, m) ->
      candidateEntriesTerm t' (nwState net) ->
      candidateEntriesTerm t' (update name_eq_dec (nwState net) h
                                 (update_elections_data_requestVote
                                    h h' t h' lli llt (nwState net h), d)).
  Proof using.
    unfold candidateEntriesTerm.
    intros.
    break_exists_exists.
    update_destruct_simplify; intuition.
    - now rewrite update_elections_data_requestVote_cronies_same.
    - unfold handleRequestVote, advanceCurrentTerm in *.
      repeat break_match; do_bool; repeat find_inversion; simpl in *; break_and; try discriminate; auto.
  Qed.

  Lemma prevLog_candidateEntriesTerm_request_vote :
    refined_raft_net_invariant_request_vote prevLog_candidateEntriesTerm.
  Proof using.
    unfold refined_raft_net_invariant_request_vote, prevLog_candidateEntriesTerm.
    simpl. intros.
    find_apply_hyp_hyp. break_or_hyp.
    - find_eapply_lem_hyp app_cons_in_rest; [|solve[eauto]].
      eapply candidateEntriesTerm_ext; eauto.
      eapply handleRequestVote_preserves_candidateEntriesTerm; eauto.
    - exfalso. eapply handleRequestVote_no_append_entries; eauto.
      simpl in *. subst. eauto 10.
  Qed.

  Lemma handleRequestVoteReply_preserves_candidateEntriesTerm :
    forall net h h' t r st' t',
      handleRequestVoteReply h (snd (nwState net h)) h' t r = st' ->
      refined_raft_intermediate_reachable net ->
      candidateEntriesTerm t' (nwState net) ->
      candidateEntriesTerm t' (update name_eq_dec (nwState net) h
                                 (update_elections_data_requestVoteReply h h' t r (nwState net h),
                                  st')).
  Proof using cci.
    unfold candidateEntriesTerm.
    intros.
    break_exists_exists.
    update_destruct_simplify; auto.
    break_and.
    unfold raft_data in *. simpl in *.
    unfold update_elections_data_requestVoteReply.
    match goal with
    | |- context [handleRequestVoteReply ?h ?st ?h' ?t ?r] =>
      remember (handleRequestVoteReply h st h' t r) as new_state
    end; find_copy_apply_lem_hyp handleRequestVoteReply_spec.
    repeat (break_match); intuition; repeat find_rewrite; intuition;
    simpl; break_if; auto.
    - find_apply_lem_hyp cronies_correct_invariant.
      unfold cronies_correct in *. intuition.
      unfold votes_received_leaders in *.
      match goal with
      | H :  Leader = _ |- _ =>
        symmetry in H
      end. find_apply_hyp_hyp.
      eapply wonElection_no_dup_in;
        eauto using NoDup_dedup, in_dedup_was_in, dedup_In.
    - destruct (serverType_eq_dec (type (snd (nwState net x))) Leader); intuition.
      find_apply_lem_hyp cronies_correct_invariant; auto.
      eapply wonElection_no_dup_in;
        eauto using NoDup_dedup, in_dedup_was_in, dedup_In.
  Qed.

  Lemma prevLog_candidateEntriesTerm_request_vote_reply :
    refined_raft_net_invariant_request_vote_reply prevLog_candidateEntriesTerm.
  Proof using cci.
    unfold refined_raft_net_invariant_request_vote_reply, prevLog_candidateEntriesTerm.
    simpl. intros.
    find_apply_hyp_hyp.
    find_eapply_lem_hyp app_cons_in_rest; [|solve[eauto]].
    eapply candidateEntriesTerm_ext; eauto.
    subst.
    eapply handleRequestVoteReply_preserves_candidateEntriesTerm; eauto.
  Qed.

  Lemma doLeader_preserves_candidateEntriesTerm :
    forall net gd d h os d' ms t',
      nwState net h = (gd, d) ->
      doLeader d h = (os, d', ms) ->
      candidateEntriesTerm t' (nwState net) ->
      candidateEntriesTerm t' (update name_eq_dec (nwState net) h (gd, d')).
  Proof using.
    unfold candidateEntriesTerm.
    intros. break_exists_exists.
    break_and.
    update_destruct_simplify; auto.
    split.
    - match goal with
      | [ H : nwState ?net ?h = (?x, _) |- _ ] =>
        replace (x) with (fst (nwState net h)) in * by (rewrite H; auto)
      end.
      intuition.
    - match goal with
      | [ H : nwState ?net ?h = (_, ?x) |- _ ] =>
        replace (x) with (snd (nwState net h)) in * by (rewrite H; auto); clear H
      end.
      find_apply_lem_hyp doLeader_type.
      intuition. subst. repeat find_rewrite.
      auto.
  Qed.

  Lemma getNextIndex_ext :
    forall st st' h,
      nextIndex st' = nextIndex st ->
      log st' = log st ->
      getNextIndex st' h = getNextIndex st h.
  Proof using.
    unfold getNextIndex.
    intros.
    repeat find_rewrite.
    auto.
  Qed.

  Lemma replicaMessage_ext :
    forall st st' h h',
      nextIndex st' = nextIndex st ->
      log st' = log st ->
      currentTerm st' = currentTerm st ->
      commitIndex st' = commitIndex st ->
      replicaMessage st' h h' = replicaMessage st h h'.
  Proof using.
    unfold replicaMessage.
    intros.
    repeat break_match; repeat tuple_inversion; repeat find_rewrite;
    erewrite getNextIndex_ext in * by eauto; congruence.
  Qed.

  Lemma prevLog_candidateEntriesTerm_do_leader :
    refined_raft_net_invariant_do_leader prevLog_candidateEntriesTerm.
  Proof using cei.
    unfold refined_raft_net_invariant_do_leader, prevLog_candidateEntriesTerm.
    simpl. intros.
    find_apply_hyp_hyp. break_or_hyp.
    - find_apply_hyp_hyp.
      eapply candidateEntriesTerm_ext; eauto.
      eapply doLeader_preserves_candidateEntriesTerm; eauto.
    - find_apply_lem_hyp in_map_iff. break_exists. break_and.
      subst. simpl in *.
      find_copy_eapply_lem_hyp doLeader_messages; eauto.
      break_and. intuition.
      + lia.
      + break_exists. break_and.
        red.
        find_apply_lem_hyp candidate_entries_invariant.
        unfold CandidateEntries, candidateEntries_host_invariant in *.
        find_apply_lem_hyp findAtIndex_elim. break_and.
        match goal with
        | [ H : nwState ?net ?h = (?y, ?x) |- _ ] =>
          replace (x) with (snd (nwState net h)) in * by (rewrite H; auto);
          replace (y) with (fst (nwState net h)) in * by (rewrite H; auto)
        end.

        eapply_prop_hyp In In.
        subst.
        find_eapply_lem_hyp (doLeader_preserves_candidateEntries); eauto.

        match goal with
        | [ H : nwState ?net ?h = (?y, ?x) |- _ ] => clear H
        end.

        unfold candidateEntries in *. break_exists_exists.
        find_higher_order_rewrite.
        update_destruct_simplify; auto.
  Qed.

  Lemma doGenericServer_preserves_candidateEntriesTerm :
    forall net gd d h os d' ms t,
      nwState net h = (gd, d) ->
      doGenericServer h d = (os, d', ms) ->
      candidateEntriesTerm t (nwState net) ->
      candidateEntriesTerm t (update name_eq_dec (nwState net) h (gd, d')).
  Proof using.
    intros.
    find_apply_lem_hyp doGenericServer_type. break_and.
    eapply candidateEntriesTerm_same; eauto.
    - intros. update_destruct_simplify; auto.
      find_rewrite. simpl. auto.
    - intros. update_destruct_simplify; auto.
      repeat find_rewrite.  auto.
    - intros. update_destruct_simplify; auto.
      repeat find_rewrite.  auto.
  Qed.

  Lemma prevLog_candidateEntriesTerm_do_generic_server :
    refined_raft_net_invariant_do_generic_server prevLog_candidateEntriesTerm.
  Proof using.
    unfold refined_raft_net_invariant_do_generic_server, prevLog_candidateEntriesTerm.
    simpl. intros.
    find_apply_hyp_hyp. break_or_hyp.
    - eapply candidateEntriesTerm_ext; eauto.
      eapply doGenericServer_preserves_candidateEntriesTerm; eauto.
    - find_apply_lem_hyp in_map_iff. break_exists. break_and.
      subst. simpl in *.
      find_apply_lem_hyp doGenericServer_packets. subst. simpl in *. intuition.
  Qed.

  Lemma prevLog_candidateEntriesTerm_state_same_packet_subset :
    refined_raft_net_invariant_state_same_packet_subset prevLog_candidateEntriesTerm.
  Proof using.
    unfold refined_raft_net_invariant_state_same_packet_subset, prevLog_candidateEntriesTerm.
    simpl. intros.
    find_apply_hyp_hyp.
    eapply candidateEntriesTerm_ext with (sigma := (nwState net)).
    - auto.
    - eauto.
  Qed.

  Lemma prevLog_candidateEntriesTerm_reboot :
    refined_raft_net_invariant_reboot prevLog_candidateEntriesTerm.
  Proof using.
    unfold refined_raft_net_invariant_reboot, prevLog_candidateEntriesTerm, reboot.
    simpl. intros.
    eapply candidateEntriesTerm_ext; eauto.
    repeat find_rewrite.
    find_apply_hyp_hyp.
    unfold candidateEntriesTerm in *.
    break_exists_exists.
    update_destruct_simplify; auto.
    repeat find_rewrite.
    simpl in *. intuition.
    discriminate.
  Qed.

  Lemma prevLog_candidateEntriesTerm_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      prevLog_candidateEntriesTerm net.
  Proof using cci cti cei rri.
    intros.
    apply refined_raft_net_invariant; auto.
    - apply prevLog_candidateEntriesTerm_init.
    - apply prevLog_candidateEntriesTerm_client_request.
    - apply prevLog_candidateEntriesTerm_timeout.
    - apply prevLog_candidateEntriesTerm_append_entries.
    - apply prevLog_candidateEntriesTerm_append_entries_reply.
    - apply prevLog_candidateEntriesTerm_request_vote.
    - apply prevLog_candidateEntriesTerm_request_vote_reply.
    - apply prevLog_candidateEntriesTerm_do_leader.
    - apply prevLog_candidateEntriesTerm_do_generic_server.
    - apply prevLog_candidateEntriesTerm_state_same_packet_subset.
    - apply prevLog_candidateEntriesTerm_reboot.
  Qed.

  Instance plceti : prevLog_candidateEntriesTerm_interface.
  Proof.
    constructor.
    apply prevLog_candidateEntriesTerm_invariant.
  Qed.
End PrevLogCandidateEntriesTerm.


From iris.algebra Require Import frac.
From iris.proofmode Require Import tactics.
Require Import Eqdep_dec List.
From cap_machine Require Import rules rules_LoadU_derived.
From cap_machine Require Import rules_binary rules_binary_LoadU_derived.
From cap_machine Require Export iris_extra addr_reg_sample contiguous stack_macros_helpers.
From cap_machine.binary_model.examples_binary Require Import macros_binary.
From cap_machine Require Import macros.

From cap_machine.binary_model Require Import logrel_binary fundamental_binary region_invariants_batch_uninitialized_binary.

Ltac iPrologue_s prog :=
  let str_destr := constr:(("(Hsi & " ++ prog ++ ")")%string) in
  iDestruct prog as str_destr.

Ltac iEpilogue_s :=
   iMod (do_step_pure _ [] with "[$Hspec $Hj]") as "Hj";auto;
   iSimpl in "Hj".

Section conf.
  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ}
          {stsg : STSG Addr region_type Σ} {heapg : heapG Σ}
          {nainv: logrel_na_invs Σ} {cfg : cfgSG Σ}
          `{MachineParameters}.

  Notation STS := (leibnizO (STS_states * STS_rels)).
  Notation STS_STD := (leibnizO (STS_std_states Addr region_invariants_binary.region_type)).
  Notation WORLD := (prodO STS_STD STS).
  Implicit Types W : WORLD.

  Definition conf_instrs z :=
    prepstackU_instrs r_stk 1 1 ++
    [loadU_r_z r_t0 r_stk (-1); (* since parameters are passer on the stack, no need to check that the input is below the stack bound *)
    pushU_z_instr r_stk z] ++
    rclear_instrs (list_difference all_registers [PC;r_t0]) ++
    [jmp r_t0].

  Definition conf1 a z1 :=
    ([∗ list] a_i;w_i ∈ a;(conf_instrs z1), a_i ↦ₐ w_i)%I.
  Definition conf2 a z2:=
    ([∗ list] a_i;w_i ∈ a;(conf_instrs z2), a_i ↣ₐ w_i)%I.

  Lemma conf_spec_12 z1 z2 (* stack values *)
        W pc_p pc_g pc_b pc_e (* PC *)
        conf_addrs (* program addresses: same for implementation and specification *)
        a_first a_last (* special adresses *)
        wstk wstk' (* stack *)
        rmap rmap' (* registers *)
        ι1 (* invariant names *) :

    (* PC assumptions *)
    isCorrectPC_range pc_p pc_g pc_b pc_e a_first a_last ->

    (* Program adresses assumptions *)
    contiguous_between conf_addrs a_first a_last ->

    (* footprint of the register map *)
    dom (gset RegName) rmap = all_registers_s ∖ {[PC;r_stk]} →
    dom (gset RegName) rmap' = all_registers_s ∖ {[PC;r_stk]} →

    {{{ spec_ctx ∗ ⤇ Seq (Instr Executable)
      ∗ r_stk ↦ᵣ wstk
      ∗ r_stk ↣ᵣ wstk'
      ∗ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,a_first)
      ∗ PC ↣ᵣ inr ((pc_p,pc_g),pc_b,pc_e,a_first)
      ∗ ([∗ map] r_i↦w_i ∈ rmap, r_i ↦ᵣ w_i)
      ∗ ([∗ map] r_i↦w_i ∈ rmap', r_i ↣ᵣ w_i)
      (* stack *)
      ∗ interp W (wstk,wstk')
      (* token which states all non atomic invariants are closed *)
      ∗ na_own logrel_nais ⊤
      (* trusted code *)
      ∗ na_inv logrel_nais ι1 (conf1 conf_addrs z1 ∗ conf2 conf_addrs z2)
      (* we start out with arbitrary sts *)
      ∗ sts_full_world W
      ∗ region W
    }}}
      Seq (Instr Executable)
      {{{ v, RET v; ⌜v = HaltedV⌝ →
             ∃ r W', ⤇ of_val HaltedV
                   ∗ full_map r
                   ∗ registers_mapsto r.1
                   ∗ spec_registers_mapsto r.2
                   ∗ ⌜related_sts_priv_world W W'⌝
                   ∗ na_own logrel_nais ⊤
                   ∗ sts_full_world W'
                   ∗ region W' }}}.
  Proof.
    iIntros (Hvpc Hcont Hrdom Hsdom φ) "(#Hspec & Hj & Hr_stk & Hs_stk & HPC & HsPC & Hrmap
    & Hsmap & #Hstk_valid & Hown & #Hconfprogs & Hsts & Hr) Hφ".
    iDestruct (interp_eq with "Hstk_valid") as %<-.
    iMod (na_inv_acc with "Hconfprogs Hown") as "([>Hprog >Hsprog] & Hown & Hcls)";auto.
    (* Get registers from implementation and specification side of the code *)
    assert (is_Some (rmap !! r_t0)) as [w0 Hw0];[apply elem_of_gmap_dom;rewrite Hrdom;set_solver+|].
    assert (is_Some (rmap !! r_t1)) as [w1 Hw1];[apply elem_of_gmap_dom;rewrite Hrdom;set_solver+|].
    assert (is_Some (rmap !! r_t2)) as [w2 Hw2];[apply elem_of_gmap_dom;rewrite Hrdom;set_solver+|].
    assert (is_Some (rmap' !! r_t0)) as [w0' Hsw0];[apply elem_of_gmap_dom;rewrite Hsdom;set_solver+|].
    assert (is_Some (rmap' !! r_t1)) as [w1' Hsw1];[apply elem_of_gmap_dom;rewrite Hsdom;set_solver+|].
    assert (is_Some (rmap' !! r_t2)) as [w2' Hsw2];[apply elem_of_gmap_dom;rewrite Hsdom;set_solver+|].
    iDestruct (big_sepM_delete with "Hrmap") as "[Hr_t0 Hrmap]";[apply Hw0|].
    iDestruct (big_sepM_delete _ _ r_t1 with "Hrmap") as "[Hr_t1 Hrmap]";[rewrite lookup_delete_ne//;eauto|].
    iDestruct (big_sepM_delete _ _ r_t2 with "Hrmap") as "[Hr_t2 Hrmap]";[rewrite !lookup_delete_ne//;eauto|].
    iDestruct (big_sepM_delete with "Hsmap") as "[Hs_t0 Hsmap]";[apply Hsw0|].
    iDestruct (big_sepM_delete _ _ r_t1 with "Hsmap") as "[Hs_t1 Hsmap]";[rewrite lookup_delete_ne//;eauto|].
    iDestruct (big_sepM_delete _ _ r_t2 with "Hsmap") as "[Hs_t2 Hsmap]";[rewrite !lookup_delete_ne//;eauto|].
    (* prepstackU *)
    iPrologue_multi "Hprog" Hcont Hvpc link.
    iDestruct (big_sepL2_length with "Hcode") as %Hcode_length.
    iDestruct (big_sepL2_app' with "Hsprog") as "[Hscode Hsprog]";auto.
    iMod (prepstackU_s_spec with "[$HsPC $Hscode $Hs_stk $Hspec $Hj Hs_t1 Hs_t2 ]") as "H";[eauto..|].
    { iSplitL "Hs_t1";eauto. }
    iApply (prepstackU_spec with "[- $HPC $Hcode $Hr_stk]");[eauto..|].
    iSplitL "Hr_t1";[eauto|]. iSplitL "Hr_t2";[eauto|].
    iNext. destruct (isPermWord wstk URWLX) eqn:Hperm;[|(* Failure *) iApply "Hφ";iIntros (Hcontr);inversion Hcontr].
    (* cleanup of stack information *)
    destruct wstk as [| [ [ [ [p_stk l_stk] b_stk] e_stk] a_stk] ];[inversion Hperm|]. iExists l_stk,b_stk, e_stk, a_stk.
    destruct p_stk;inversion Hperm. iSplit;auto.
    iDestruct "H" as (l b e a' Heq) "H". inversion Heq. subst l b e a'.
    destruct (1%nat + 1%nat <? e_stk - b_stk)%Z eqn:Hsize;[|(* Failure *) iApply "Hφ";iIntros (Hcontr);inversion Hcontr].
    destruct (b_stk + 1%nat <=? a_stk)%Z eqn:Hle;[|(* Failure *) iApply "Hφ";iIntros (Hcontr);inversion Hcontr].
    iDestruct (writeLocalAllowedU_implies_local with "Hstk_valid") as %Hmonotone;auto. destruct l_stk;inversion Hmonotone.
    iIntros "Hstack".
    iDestruct "Hstack" as (a Ha) "(HPC & Hprepstack & Hr_stk & Hr_t1 & Hr_t2)".
    iDestruct "H" as (a' Ha') "(Hj & HsPC & Hsprepstack & Hs_stk & Hs_t1 & Hs_t2)".
    clear Heq. assert (a = a') as Heq;[clear -Ha Ha';solve_addr|subst a';clear Ha'].
    revert Hsize Hle; rewrite Z.ltb_lt Z.leb_le =>Hsize Hle.

    (* pop r_stk r_t0 *)
    (* in order to pop, we must first open the region at b_stk *)
    iDestruct (writeLocalAllowedU_valid_cap_below_implies _ _ _ _ _ _ b_stk with "Hstk_valid") as %Ha_param_W;[auto|..].
    { clear -Hle Hsize Ha. rewrite andb_true_iff Z.leb_le Z.ltb_lt. solve_addr. }
    { clear -Hle. solve_addr. }
    iDestruct (read_allowedU_inv _ b_stk with "Hstk_valid") as  "Hrel";[clear -Hsize;solve_addr|auto|].
    iDestruct (region_open_monotemp with "[$Hr $Hsts $Hrel]") as (wret wret') "(Hr & Hsts & Hstate & Hb_stk & Hb_stk' & #Hmono & #Hwret_valid)";auto.
    iSimpl in "Hwret_valid".
    iAssert (▷ ⌜wret = wret'⌝)%I as "#><-".
    { iNext. iDestruct (interp_eq with "Hwret_valid") as %->. auto. }
    (* loadU r_t0 r_stk -1 *)
    iPrologue_multi "Hprog" Hcont Hvpc link0.
    iDestruct (big_sepL2_length with "Hcode") as %Hcode_length0.
    iDestruct (big_sepL2_app' with "Hsprog") as "[Hscode Hsprog]";auto.
    destruct_addr_list l_code0.
    iPrologue "Hcode". apply contiguous_between_cons_inv_first in Hcont_code0 as Heq. subst link.
    iApply (rules_LoadU_derived.wp_loadU_success with "[$HPC $Hi $Hr_t0 $Hr_stk $Hb_stk]");
      [apply decode_encode_instrW_inv|iCorrectPC l_code0 link0|auto..].
    { clear -Hle Hsize Ha. rewrite andb_true_iff Z.leb_le Z.ltb_lt. solve_addr. }
    { iContiguous_next_a Hcont_code0. }
    iEpilogue "(HPC & Hr_t0 & Hprog_done & Hr_stk & Hb_stk)".
    iPrologue_s "Hscode".
    iMod (step_loadU_success _ [SeqCtx] with "[$Hspec $Hj $HsPC $Hsi $Hs_t0 $Hs_stk $Hb_stk']")
      as "(Hj & HsPC & Hs_t0 & Hsprog_done & Hs_stk & Hb_stk')";
      [apply decode_encode_instrW_inv|iCorrectPC l_code0 link0|auto..].
    { clear -Hle Hsize Ha. rewrite andb_true_iff Z.leb_le Z.ltb_lt. solve_addr. }
    { iContiguous_next_a Hcont_code0. }
    iEpilogue_s.
    (* we can close the world again *)
    iDestruct (region_close_monotemp with "[$Hstate $Hb_stk $Hb_stk' $Hr $Hrel $Hmono $Hwret_valid]") as "Hr";auto.

    (* pushu r_stk r_env *)
    (* we have reached a part of the code which will require us to make a pub^b_stk change to the world *)
    (* we will therefore first uninitialize all addresses at or above b_stk *)
    iMod (uninitialize_region _ b_stk with "[$Hsts $Hr]") as (m Hmcond) "[Hsts Hr]".
    (* next we can open the region at b_stk, which we will first assert is in m *)
    iDestruct (valid_uninitialized_condition _ m with "Hstk_valid") as %Hstk_cond;auto.
    (* next we can open the world at a *)
    assert (b_stk <= a < e_stk)%a as Hstk_bounds.
    { split;[clear -Ha;solve_addr|]. clear -Hsize Ha. solve_addr. }
    pose proof (Hstk_cond a Hstk_bounds) as [ [v1 v2] Hw].
    iDestruct (read_allowedU_inv _ a with "Hstk_valid") as "Hrel'";[clear -Hsize Ha;solve_addr|auto|].
    iDestruct (region_open_uninitialized with "[$Hrel' $Hr $Hsts]") as "(Hr & Hsts & Hstate & Ha & Ha')";[eauto|..].
    (* and we are ready to push a new value b_stk *)
    assert (is_Some (a + 1))%a as [b_stk1 Hb_next].
    { clear -Hstk_bounds. destruct (a + 1)%a eqn:Hsome;eauto. exfalso. solve_addr. }
    iDestruct "Hcode" as "[HpushU _]".
    iDestruct "Hscode" as "[HspushU _]".
    assert ((a0 + 1)%a = Some link0) as Hlast.
    { eapply contiguous_between_last;eauto. }
    iApply (pushU_z_spec with "[- $HPC $HpushU $Hr_stk $Ha]");
      [iCorrectPC l_code0 link0| |apply Hlast|apply Hb_next|..].
    { apply andb_true_iff. split;[apply Z.leb_le|apply Z.ltb_lt];clear -Hstk_bounds;solve_addr. }
    iNext. iIntros "(HPC & HpushU & Hr_stk & Hb_stk)".
    iMod (push_pop_binary.pushU_z_spec with "[$Hspec $Hj $HsPC $HspushU $Hs_stk $Ha']")
      as "(Hj & HsPC & HspushU & Hs_stk & Hb_stk')";
      [iCorrectPC l_code0 link0| |apply Hlast|apply Hb_next|auto..].
    { apply andb_true_iff. split;[apply Z.leb_le|apply Z.ltb_lt];clear -Hstk_bounds;solve_addr. }
    (* we can now close the world again *)
    pose proof (uninitialized_condition _ _ _ Hmcond) as Hmcond_alt.
    iMod (uninitialize_open_region_change _ _ a with "[$Hb_stk $Hb_stk' $Hrel' $Hsts $Hr $Hstate]") as "[Hr Hsts]";
      [clear;solve_addr|auto|].
    { intros. apply Hmcond_alt. clear -H0 Ha. solve_addr. }

    (* and we can now finish executing the instructions without more changes to W *)
    (* rclear RegName/{PC;r_t0} *)
    iPrologue_multi "Hprog" Hcont Hvpc link1.
    iDestruct (big_sepL2_length with "Hcode") as %Hcode_length1.
    iDestruct (big_sepL2_app' with "Hsprog") as "[Hscode Hsprog]";auto.

    iDestruct (big_sepM_insert with "[$Hrmap $Hr_t2]") as "Hrmap";[apply lookup_delete|rewrite insert_delete -!delete_insert_ne//].
    iDestruct (big_sepM_insert with "[$Hrmap $Hr_t1]") as "Hrmap";[apply lookup_delete|rewrite insert_delete].
    iDestruct (big_sepM_insert with "[$Hrmap $Hr_stk]") as "Hrmap".
    { rewrite lookup_insert_ne// lookup_delete_ne// !lookup_insert_ne//. apply not_elem_of_dom. rewrite Hrdom. set_solver-. }

    iDestruct (big_sepM_insert with "[$Hsmap $Hs_t2]") as "Hsmap";[apply lookup_delete|rewrite insert_delete -!delete_insert_ne//].
    iDestruct (big_sepM_insert with "[$Hsmap $Hs_t1]") as "Hsmap";[apply lookup_delete|rewrite insert_delete].
    iDestruct (big_sepM_insert with "[$Hsmap $Hs_stk]") as "Hsmap".
    { rewrite lookup_insert_ne// lookup_delete_ne// !lookup_insert_ne//. apply not_elem_of_dom. rewrite Hsdom. set_solver-. }

    iApply (rclear_spec_gmap with "[- $HPC $Hcode $Hrmap]");[eauto..|].
    { apply not_elem_of_list. constructor. }
    { assert (length l_code1 = 31) as Hlength4.
      clear -Hlength Hlength0 Hlength1. rewrite app_length Hlength1 in Hlength0. lia.
      destruct l_code1;inversion Hlength4. apply contiguous_between_cons_inv_first in Hcont_code1 as ->.
      auto. }
    { clear -Hrdom. rewrite !dom_delete_L !dom_insert_L Hrdom list_to_set_difference -/all_registers_s /=. clear. set_solver. }
    iNext. iIntros "[HPC [Hdom Hrclear]]".
    iDestruct "Hdom" as (rmap1) "[Hregs #Hregs_cond]". iDestruct "Hregs_cond" as %[Hrdom1 Hzeroes].
    iMod (rclear_s_spec_gmap with "[$Hspec $Hj $HsPC $Hscode $Hsmap]") as "(Hj & HsPC & Hdom & Hsrclear)";[eauto..|].
    { apply not_elem_of_list. constructor. }
    { assert (length l_code1 = 31) as Hlength4.
      clear -Hlength Hlength0 Hlength1. rewrite app_length Hlength1 in Hlength0. lia.
      destruct l_code1;inversion Hlength4. apply contiguous_between_cons_inv_first in Hcont_code1 as ->.
      auto. }
    { clear -Hsdom. rewrite !dom_insert_L !dom_delete_L !dom_insert_L Hsdom list_to_set_difference -/all_registers_s /=. clear. set_solver. }
    iDestruct "Hdom" as (rmap2) "[Hsregs #Hsegs_cond]". iDestruct "Hsegs_cond" as %[Hrdom2 Hzeroes2].

    (* jmp r_t0 *)
    prep_addr_list_full l_rest1 Hcont.
    iPrologue "Hprog".
    iPrologue_s "Hsprog".
    iMod (step_jmp_success _ [SeqCtx] with "[$Hspec $Hj $HsPC $Hsi $Hs_t0]")
      as "(Hj & HsPC & Hsi & Hs_t0)";
      [apply decode_encode_instrW_inv|iCorrectPC link1 a_last|auto..].
    iApply (wp_jmp_success with "[$HPC $Hi $Hr_t0]");
      [apply decode_encode_instrW_inv|iCorrectPC link1 a_last|].

    (* first we will update the varilidy of wret to the new world *)
    set (W' := (<s[a:=Uninitialized (inl z1, inl z2)]s>(uninitialize W m))).
    assert (related_sts_a_world W W' b_stk) as Hrelated.
    { eapply related_sts_a_trans_world;[apply uninitialize_related_pub_a|];eauto.
      apply related_sts_a_uninitialized. clear -Ha; solve_addr. apply Hstk_cond. auto. }
    iDestruct ("Hmono" $! _ _ Hrelated with "Hwret_valid") as "Hwret_valid'". iSimpl in "Hwret_valid'".
    iDestruct (jmp_or_fail_binary_spec with "Hspec Hwret_valid'") as "Hcond".
    destruct (decide (isCorrectPC (updatePcPerm wret))).
    2: { iEpilogue "(HPC & _)". iApply "Hcond". iFrame. iApply "Hφ". iIntros (Hcontr). inversion Hcontr. }
    iDestruct "Hcond" as (p g b e a' Heq) "Hcond". rewrite Heq.
    iSpecialize ("Hcond" $! (<[PC:=inl 0%Z]> (<[r_t0:=wret]> rmap1),<[PC:=inl 0%Z]> (<[r_t0:=wret]> rmap2)) W' with "[]").
    { destruct g;iPureIntro.
      apply related_sts_priv_refl_world. apply related_sts_priv_refl_world. apply related_sts_a_refl_world. }

    (* we can now establish the continuation *)
    iEpilogue "(HPC & Hi & Hr_t0)".
    iEpilogue_s.

    (* first we will close the program invariant *)
    iMod ("Hcls" with "[Hprepstack Hsprepstack Hprog_done Hsprog_done
                        Hrclear Hsrclear Hi Hsi HpushU HspushU $Hown]") as "Hown".
    { iNext. iFrame. simpl. done. }

    (* next we must establish that the current register state is valid *)
    iDestruct (big_sepM_insert with "[$Hregs $Hr_t0]") as "Hregs".
    { apply not_elem_of_dom. rewrite Hrdom1. set_solver-. }
    iDestruct (big_sepM_insert with "[$Hregs $HPC]") as "Hregs".
    { rewrite lookup_insert_ne//. apply not_elem_of_dom. rewrite Hrdom1. set_solver-. }
    iDestruct (big_sepM_insert with "[$Hsregs $Hs_t0]") as "Hsregs".
    { apply not_elem_of_dom. rewrite Hrdom2. set_solver-. }
    iDestruct (big_sepM_insert with "[$Hsregs $HsPC]") as "Hsregs".
    { rewrite lookup_insert_ne//. apply not_elem_of_dom. rewrite Hrdom2. set_solver-. }
    iDestruct ("Hcond" with "[$Hown $Hr $Hsts $Hj Hregs Hsregs]") as "[_ Hconf]".
    {  rewrite -(insert_insert (<[_:=_]> rmap1) PC _ (inl 0%Z)) -(insert_insert (<[_:=_]> rmap2) PC _ (inl 0%Z)) Heq /=.
       iFrame "Hsregs Hregs". iSplit;[iPureIntro|].
       - simpl. intros x. split. all: apply elem_of_gmap_dom.
         rewrite !dom_insert_L Hrdom1 list_to_set_difference.
         2: rewrite !dom_insert_L Hrdom2 list_to_set_difference.
         all: clear.
         all: pose proof (all_registers_s_correct x). all: set_solver.
       - iIntros (r HPC). rewrite /RegLocate. rewrite lookup_insert_ne// (lookup_insert_ne _ PC)//.
         destruct (decide (r_t0 = r));[subst;rewrite !lookup_insert;eauto|rewrite !lookup_insert_ne;auto].
         rewrite Hzeroes. rewrite Hzeroes2. rewrite !fixpoint_interp1_eq. done.
         rewrite Hrdom2. 2: rewrite Hrdom1. all: clear -HPC n. all: pose proof (all_registers_s_correct r).
         all: rewrite list_to_set_difference. all: set_solver. }
    iApply (wp_wand with "Hconf").
    iIntros (v). iIntros "Hcond'". iApply "Hφ".
    iIntros (Hhalted). iDestruct ("Hcond'" $! Hhalted) as (r W'') "(?&?&?&?&%&?&?&?)".
    iExists _,_;iFrame.
    iPureIntro. eapply related_sts_a_priv_trans_world;eauto.
  Qed.

  (* --------------------------------------------------------------------------------------------------- *)
  (* ------------------------------------ left to right refinement ------------------------------------- *)
  (* --------------------------------------------------------------------------------------------------- *)

  Definition confL a := conf1 a 2.
  Definition confR a := conf2 a 3.

  Lemma conf_spec_LR W pc_p pc_g pc_b pc_e (* PC *)
        conf_addrs (* program addresses: same for implementation and specification *)
        a_first a_last (* special adresses *)
        wstk wstk' (* stack *)
        rmap rmap' (* registers *)
        ι1 (* invariant names *) :

    (* PC assumptions *)
    isCorrectPC_range pc_p pc_g pc_b pc_e a_first a_last ->

    (* Program adresses assumptions *)
    contiguous_between conf_addrs a_first a_last ->

    (* footprint of the register map *)
    dom (gset RegName) rmap = all_registers_s ∖ {[PC;r_stk]} →
    dom (gset RegName) rmap' = all_registers_s ∖ {[PC;r_stk]} →

    {{{ spec_ctx ∗ ⤇ Seq (Instr Executable)
      ∗ r_stk ↦ᵣ wstk
      ∗ r_stk ↣ᵣ wstk'
      ∗ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,a_first)
      ∗ PC ↣ᵣ inr ((pc_p,pc_g),pc_b,pc_e,a_first)
      ∗ ([∗ map] r_i↦w_i ∈ rmap, r_i ↦ᵣ w_i)
      ∗ ([∗ map] r_i↦w_i ∈ rmap', r_i ↣ᵣ w_i)
      (* stack *)
      ∗ interp W (wstk,wstk')
      (* token which states all non atomic invariants are closed *)
      ∗ na_own logrel_nais ⊤
      (* trusted code *)
      ∗ na_inv logrel_nais ι1 (confL conf_addrs ∗ confR conf_addrs)
      (* we start out with arbitrary sts *)
      ∗ sts_full_world W
      ∗ region W
    }}}
      Seq (Instr Executable)
      {{{ v, RET v; ⌜v = HaltedV⌝ →
             ∃ r W', ⤇ of_val HaltedV
                   ∗ full_map r
                   ∗ registers_mapsto r.1
                   ∗ spec_registers_mapsto r.2
                   ∗ ⌜related_sts_priv_world W W'⌝
                   ∗ na_own logrel_nais ⊤
                   ∗ sts_full_world W'
                   ∗ region W' }}}.
  Proof.
    iIntros (Hvpc Hcont Hrdom Hsdom φ) "(#Hspec & Hj & Hr_stk & Hs_stk & HPC & HsPC & Hrmap
    & Hsmap & #Hstk_valid & Hown & #Hconfprogs & Hsts & Hr) Hφ".
    iDestruct (conf_spec_12 with "[$Hspec $Hj $Hr_stk $Hs_stk $HPC $HsPC $Hrmap $Hsmap
    $Hstk_valid $Hown $Hconfprogs $Hsts $Hr] Hφ") as "$";eauto.
  Qed.

  (* --------------------------------------------------------------------------------------------------- *)
  (* ------------------------------------ right to left refinement ------------------------------------- *)
  (* --------------------------------------------------------------------------------------------------- *)

  Definition confL' a := conf2 a 2.
  Definition confR' a := conf1 a 3.

  Lemma conf_spec_RL W pc_p pc_g pc_b pc_e (* PC *)
        conf_addrs (* program addresses: same for implementation and specification *)
        a_first a_last (* special adresses *)
        wstk wstk' (* stack *)
        rmap rmap' (* registers *)
        ι1 (* invariant names *) :

    (* PC assumptions *)
    isCorrectPC_range pc_p pc_g pc_b pc_e a_first a_last ->

    (* Program adresses assumptions *)
    contiguous_between conf_addrs a_first a_last ->

    (* footprint of the register map *)
    dom (gset RegName) rmap = all_registers_s ∖ {[PC;r_stk]} →
    dom (gset RegName) rmap' = all_registers_s ∖ {[PC;r_stk]} →

    {{{ spec_ctx ∗ ⤇ Seq (Instr Executable)
      ∗ r_stk ↦ᵣ wstk
      ∗ r_stk ↣ᵣ wstk'
      ∗ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,a_first)
      ∗ PC ↣ᵣ inr ((pc_p,pc_g),pc_b,pc_e,a_first)
      ∗ ([∗ map] r_i↦w_i ∈ rmap, r_i ↦ᵣ w_i)
      ∗ ([∗ map] r_i↦w_i ∈ rmap', r_i ↣ᵣ w_i)
      (* stack *)
      ∗ interp W (wstk,wstk')
      (* token which states all non atomic invariants are closed *)
      ∗ na_own logrel_nais ⊤
      (* trusted code *)
      ∗ na_inv logrel_nais ι1 (confR' conf_addrs ∗ confL' conf_addrs)
      (* we start out with arbitrary sts *)
      ∗ sts_full_world W
      ∗ region W
    }}}
      Seq (Instr Executable)
      {{{ v, RET v; ⌜v = HaltedV⌝ →
             ∃ r W', ⤇ of_val HaltedV
                   ∗ full_map r
                   ∗ registers_mapsto r.1
                   ∗ spec_registers_mapsto r.2
                   ∗ ⌜related_sts_priv_world W W'⌝
                   ∗ na_own logrel_nais ⊤
                   ∗ sts_full_world W'
                   ∗ region W' }}}.
  Proof.
    iIntros (Hvpc Hcont Hrdom Hsdom φ) "(#Hspec & Hj & Hr_stk & Hs_stk & HPC & HsPC & Hrmap
    & Hsmap & #Hstk_valid & Hown & #Hconfprogs & Hsts & Hr) Hφ".
    iDestruct (conf_spec_12 with "[$Hspec $Hj $Hr_stk $Hs_stk $HPC $HsPC $Hrmap $Hsmap
    $Hstk_valid $Hown $Hconfprogs $Hsts $Hr] Hφ") as "$";eauto.
  Qed.

End conf.


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

(** The Mach intermediate language: operational semantics. *)

Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Memory.
Require Import Events.
Require Import Globalenvs.
Require Import Smallstep.
Require Import Op.
Require Import Locations.
Require Import Conventions.
Require Import Mach.
Require Stacklayout.

Section WITHMEM.
Context `{Hmem: Mem.MemoryModel}.

(** The semantics for Mach is close to that of [Linear]: they differ only
  on the interpretation of stack slot accesses.  In Mach, these
  accesses are interpreted as memory accesses relative to the
  stack pointer.  More precisely:
- [Mgetstack ofs ty r] is a memory load at offset [ofs * 4] relative
  to the stack pointer.
- [Msetstack r ofs ty] is a memory store at offset [ofs * 4] relative
  to the stack pointer.
- [Mgetparam ofs ty r] is a memory load at offset [ofs * 4]
  relative to the pointer found at offset 0 from the stack pointer.
  The semantics maintain a linked structure of activation records,
  with the current record containing a pointer to the record of the
  caller function at offset 0.

In addition to this linking of activation records, the
semantics also make provisions for storing a back link at offset
[f.(fn_link_ofs)] from the stack pointer, and a return address at
offset [f.(fn_retaddr_ofs)].  The latter stack location will be used
by the Asm code generated by [Asmgen] to save the return address into
the caller at the beginning of a function, then restore it and jump to
it at the end of a function.  The Mach concrete semantics does not
attach any particular meaning to the pointer stored in this reserved
location, but makes sure that it is preserved during execution of a
function.  The [return_address_offset] predicate from module
[Asmgenretaddr] is used to guess the value of the return address that
the Asm code generated later will store in the reserved location.
*)

Definition load_stack (m: mem) (sp: val) (ty: typ) (ofs: int) :=
  Mem.loadv (chunk_of_type ty) m (Val.add sp (Vint ofs)).

Definition store_stack (m: mem) (sp: val) (ty: typ) (ofs: int) (v: val) :=
  Mem.storev (chunk_of_type ty) m (Val.add sp (Vint ofs)) v.

(** Extract the values of the arguments to an external call. *)

Inductive extcall_arg: regset -> mem -> val -> loc -> val -> Prop :=
  | extcall_arg_reg: forall rs m sp r,
      extcall_arg rs m sp (R r) (rs r)
  | extcall_arg_stack: forall rs m sp ofs ty v,
      load_stack m sp ty (Int.repr (Stacklayout.fe_ofs_arg + 4 * ofs)) = Some v ->
      extcall_arg rs m sp (S (Outgoing ofs ty)) v.

Definition extcall_arguments
    (rs: regset) (m: mem) (sp: val) (sg: signature) (args: list val) : Prop :=
  list_forall2 (extcall_arg rs m sp) (loc_arguments sg) args.

(** Extract the values of the arguments to an annotation. *)

Inductive annot_arg: regset -> mem -> val -> annot_param -> val -> Prop :=
  | annot_arg_reg: forall rs m sp r,
      annot_arg rs m sp (APreg r) (rs r)
  | annot_arg_stack: forall rs m stk base chunk ofs v,
      Mem.load chunk m stk (Int.unsigned base + ofs) = Some v ->
      annot_arg rs m (Vptr stk base) (APstack chunk ofs) v.

Definition annot_arguments
   (rs: regset) (m: mem) (sp: val) (params: list annot_param) (args: list val) : Prop :=
  list_forall2 (annot_arg rs m sp) params args.

(** Mach execution states. *)

Inductive stackframe: Type :=
  | Stackframe:
      forall (f: function)    (**r calling function *)
             (sp: val)        (**r stack pointer in calling function *)
             (c: code),       (**r program point in calling function *)
      stackframe.

Inductive state `{mem_ops: Mem.MemoryOps mem}: Type :=
  | State:
      forall (stack: list stackframe)  (**r call stack *)
             (f: function)             (**r current function *)
             (sp: val)                 (**r stack pointer *)
             (c: code)                 (**r current program point *)
             (rs: regset)              (**r register state *)
             (m: mem),                 (**r memory state *)
      state
  | Callstate:
      forall (stack: list stackframe)  (**r call stack *)
             (fd: fundef)              (**r function to call *)
             (rs: regset)              (**r register state *)
             (m: mem),                 (**r memory state *)
      state
  | Returnstate:
      forall (stack: list stackframe)  (**r call stack *)
             (rs: regset)              (**r register state *)
             (m: mem),                 (**r memory state *)
      state.

Definition parent_sp (s: list stackframe) : val :=
  match s with
  | nil => Vptr Mem.nullptr Int.zero
  | Stackframe f sp c :: s' => sp
  end.

Section RELSEM.

Variable ge: genv.

Inductive step: state -> trace -> state -> Prop :=
  | exec_Mlabel:
      forall s f sp lbl c rs m,
      step (State s f sp (Mlabel lbl :: c) rs m)
        E0 (State s f sp c rs m)
  | exec_Mgetstack:
      forall s f sp ofs ty dst c rs m v,
      load_stack m sp ty ofs = Some v ->
      step (State s f sp (Mgetstack ofs ty dst :: c) rs m)
        E0 (State s f sp c (rs#dst <- v) m)
  | exec_Msetstack:
      forall s f sp src ofs ty c rs m m',
      store_stack m sp ty ofs (rs src) = Some m' ->
      step (State s f sp (Msetstack src ofs ty :: c) rs m)
        E0 (State s f sp c (undef_setstack rs) m')
  | exec_Mgetparam:
      forall s f sp ofs ty dst c rs m v,
      load_stack m sp Tint f.(fn_link_ofs) = Some (parent_sp s) ->
      load_stack m (parent_sp s) ty ofs = Some v ->
      step (State s f sp (Mgetparam ofs ty dst :: c) rs m)
        E0 (State s f sp c (rs # IT1 <- Vundef # dst <- v) m)
  | exec_Mop:
      forall s f sp op args res c rs m v,
      eval_operation ge sp op rs##args m = Some v ->
      step (State s f sp (Mop op args res :: c) rs m)
        E0 (State s f sp c ((undef_op op rs)#res <- v) m)
  | exec_Mload:
      forall s f sp chunk addr args dst c rs m a v,
      eval_addressing ge sp addr rs##args = Some a ->
      Mem.loadv chunk m a = Some v ->
      step (State s f sp (Mload chunk addr args dst :: c) rs m)
        E0 (State s f sp c ((undef_temps rs)#dst <- v) m)
  | exec_Mstore:
      forall s f sp chunk addr args src c rs m m' a,
      eval_addressing ge sp addr rs##args = Some a ->
      Mem.storev chunk m a (rs src) = Some m' ->
      step (State s f sp (Mstore chunk addr args src :: c) rs m)
        E0 (State s f sp c (undef_temps rs) m')
  | exec_Mcall:
      forall s f sp sig ros c rs m fd,
      find_function ge ros rs = Some fd ->
      step (State s f sp (Mcall sig ros :: c) rs m)
        E0 (Callstate (Stackframe f sp c :: s)
                       fd rs m)
  | exec_Mtailcall:
      forall s f stk soff sig ros c rs m fd m' m'',
      find_function ge ros rs = Some fd ->
      load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) ->
      Mem.free m stk 0 (Int.unsigned f.(fn_retaddr_ofs)) = Some m' ->
      Mem.free m' stk (Int.unsigned f.(fn_retaddr_ofs) + 4) f.(fn_stacksize) = Some m'' ->
      step (State s f (Vptr stk soff) (Mtailcall sig ros :: c) rs m)
        E0 (Callstate s fd rs m'')
  | exec_Mbuiltin:
      forall s f sp rs m ef args res b t v m',
      external_call ef ge rs##args m t v m' ->
      step (State s f sp (Mbuiltin ef args res :: b) rs m)
         t (State s f sp b ((undef_temps rs)#res <- v) m')
  | exec_Mannot:
      forall s f sp rs m ef args b vargs t v m',
      annot_arguments rs m sp args vargs ->
      external_call ef ge vargs m t v m' ->
      step (State s f sp (Mannot ef args :: b) rs m)
         t (State s f sp b rs m')
  | exec_Mgoto:
      forall s f sp lbl c rs m c',
      find_label lbl f.(fn_code) = Some c' ->
      step (State s f sp (Mgoto lbl :: c) rs m)
        E0 (State s f sp c' rs m)
  | exec_Mcond_true:
      forall s f sp cond args lbl c rs m c',
      eval_condition cond rs##args m = Some true ->
      find_label lbl f.(fn_code) = Some c' ->
      step (State s f sp (Mcond cond args lbl :: c) rs m)
        E0 (State s f sp c' (undef_temps rs) m)
  | exec_Mcond_false:
      forall s f sp cond args lbl c rs m,
      eval_condition cond rs##args m = Some false ->
      step (State s f sp (Mcond cond args lbl :: c) rs m)
        E0 (State s f sp c (undef_temps rs) m)
  | exec_Mjumptable:
      forall s f sp arg tbl c rs m n lbl c',
      rs arg = Vint n ->
      list_nth_z tbl (Int.unsigned n) = Some lbl ->
      find_label lbl f.(fn_code) = Some c' ->
      step (State s f sp (Mjumptable arg tbl :: c) rs m)
        E0 (State s f sp c' (undef_temps rs) m)
  | exec_Mreturn:
      forall s f stk soff c rs m m' m'',
      load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) ->
      Mem.free m stk 0 (Int.unsigned f.(fn_retaddr_ofs)) = Some m' ->
      Mem.free m' stk (Int.unsigned f.(fn_retaddr_ofs) + 4) f.(fn_stacksize) = Some m'' ->
      step (State s f (Vptr stk soff) (Mreturn :: c) rs m)
        E0 (Returnstate s rs m'')
  | exec_function_internal:
      forall s f rs m m1 m2 m3 stk,
      Mem.alloc m 0 f.(fn_stacksize) = (m1, stk) ->
      Mem.free m1 stk (Int.unsigned f.(fn_retaddr_ofs)) (Int.unsigned f.(fn_retaddr_ofs) + 4) = Some m2 ->
      let sp := Vptr stk Int.zero in
      store_stack m2 sp Tint f.(fn_link_ofs) (parent_sp s) = Some m3 ->
      (4 | Int.unsigned f.(fn_retaddr_ofs)) ->
      step (Callstate s (Internal f) rs m)
        E0 (State s f sp f.(fn_code) (undef_temps rs) m3)
  | exec_function_external:
      forall s ef rs m t rs' args res m',
      external_call ef ge args m t res m' ->
      extcall_arguments rs m (parent_sp s) (ef_sig ef) args ->
      rs' = (rs#(loc_result (ef_sig ef)) <- res) ->
      step (Callstate s (External ef) rs m)
         t (Returnstate s rs' m')
  | exec_return:
      forall s f sp c rs m,
      step (Returnstate (Stackframe f sp c :: s) rs m)
        E0 (State s f sp c rs m).

End RELSEM.

Inductive initial_state (p: program): state -> Prop :=
  | initial_state_intro: forall b fd m0,
      let ge := Genv.globalenv p in
      Genv.init_mem p = Some m0 ->
      Genv.find_symbol ge p.(prog_main) = Some b ->
      Genv.find_funct_ptr ge b = Some fd ->
      initial_state p (Callstate nil fd (Regmap.init Vundef) m0).

Inductive final_state: state -> int -> Prop :=
  | final_state_intro: forall rs m r,
      rs (loc_result (mksignature nil (Some Tint))) = Vint r ->
      final_state (Returnstate nil rs m) r.

Definition semantics (p: program) :=
  Semantics step (initial_state p) final_state (Genv.globalenv p).

End WITHMEM.


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

(** The Mach intermediate language: abstract syntax.

  Mach is the last intermediate language before generation of assembly
  code.
*)

Require Import Coqlib.
Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
Require Import Events.
Require Import Smallstep.
Require Import Op.
Require Import Locations.
Require Import Conventions.
Require Stacklayout.

(** * Abstract syntax *)

(** Like Linear, the Mach language is organized as lists of instructions
  operating over machine registers, with default fall-through behaviour
  and explicit labels and branch instructions.

  The main difference with Linear lies in the instructions used to
  access the activation record.  Mach has three such instructions:
  [Mgetstack] and [Msetstack] to read and write within the activation
  record for the current function, at a given word offset and with a
  given type; and [Mgetparam], to read within the activation record of
  the caller.

  These instructions implement a more concrete view of the activation
  record than the the [Lgetstack] and [Lsetstack] instructions of
  Linear: actual offsets are used instead of abstract stack slots, and the
  distinction between the caller's frame and the callee's frame is
  made explicit. *)

Definition label := positive.

Inductive instruction: Type :=
  | Mgetstack: int -> typ -> mreg -> instruction
  | Msetstack: mreg -> int -> typ -> instruction
  | Mgetparam: int -> typ -> mreg -> instruction
  | Mop: operation -> list mreg -> mreg -> instruction
  | Mload: memory_chunk -> addressing -> list mreg -> mreg -> instruction
  | Mstore: memory_chunk -> addressing -> list mreg -> mreg -> instruction
  | Mcall: signature -> mreg + ident -> instruction
  | Mtailcall: signature -> mreg + ident -> instruction
  | Mbuiltin: builtin -> list mreg -> list mreg -> instruction
  | Mannot: builtin -> list annot_param -> instruction
  | Mlabel: label -> instruction
  | Mgoto: label -> instruction
  | Mcond: condition -> list mreg -> label -> instruction
  | Mjumptable: mreg -> list label -> instruction
  | Mreturn: instruction

with annot_param: Type :=
  | APreg: mreg -> annot_param
  | APstack: memory_chunk -> Z -> annot_param.

Definition code := list instruction.

Record function: Type := mkfunction
  { fn_sig: signature;
    fn_code: code;
    fn_stacksize: Z;
    fn_link_ofs: int;
    fn_retaddr_ofs: int }.

Definition fundef := AST.fundef function.

Definition program := AST.program fundef unit.

Definition funsig (fd: fundef) :=
  match fd with
  | Internal f => fn_sig f
  | External ef => ef_sig ef
  end.

Definition genv := Genv.t fundef unit.

(** * Operational semantics *)

(** The semantics for Mach is close to that of [Linear]: they differ only
  on the interpretation of stack slot accesses.  In Mach, these
  accesses are interpreted as memory accesses relative to the
  stack pointer.  More precisely:
- [Mgetstack ofs ty r] is a memory load at offset [ofs * 4] relative
  to the stack pointer.
- [Msetstack r ofs ty] is a memory store at offset [ofs * 4] relative
  to the stack pointer.
- [Mgetparam ofs ty r] is a memory load at offset [ofs * 4]
  relative to the pointer found at offset 0 from the stack pointer.
  The semantics maintain a linked structure of activation records,
  with the current record containing a pointer to the record of the
  caller function at offset 0.

In addition to this linking of activation records, the
semantics also make provisions for storing a back link at offset
[f.(fn_link_ofs)] from the stack pointer, and a return address at
offset [f.(fn_retaddr_ofs)].  The latter stack location will be used
by the Asm code generated by [Asmgen] to save the return address into
the caller at the beginning of a function, then restore it and jump to
it at the end of a function.  The Mach concrete semantics does not
attach any particular meaning to the pointer stored in this reserved
location, but makes sure that it is preserved during execution of a
function.  The [return_address_offset] parameter is used to guess the
value of the return address that the Asm code generated later will
store in the reserved location.
*)

Definition load_stack (m: mem) (sp: val) (ty: typ) (ofs: int) :=
  Mem.loadv (chunk_of_type ty) m (Val.add sp (Vint ofs)).

Definition store_stack (m: mem) (sp: val) (ty: typ) (ofs: int) (v: val) :=
  Mem.storev (chunk_of_type ty) m (Val.add sp (Vint ofs)) v.

Module RegEq.
  Definition t := mreg.
  Definition eq := mreg_eq.
End RegEq.

Module Regmap := EMap(RegEq).

Definition regset := Regmap.t val.

Notation "a ## b" := (List.map a b) (at level 1).
Notation "a # b <- c" := (Regmap.set b c a) (at level 1, b at next level).

Fixpoint undef_regs (rl: list mreg) (rs: regset) {struct rl} : regset :=
  match rl with
  | nil => rs
  | r1 :: rl' => Regmap.set r1 Vundef (undef_regs rl' rs)
  end.

Lemma undef_regs_other:
  forall r rl rs, ~In r rl -> undef_regs rl rs r = rs r.
Proof.
  induction rl; simpl; intros. auto. rewrite Regmap.gso. apply IHrl. intuition. intuition.
Qed.

Lemma undef_regs_same:
  forall r rl rs, In r rl -> undef_regs rl rs r = Vundef.
Proof.
  induction rl; simpl; intros. tauto.
  destruct H. subst a. apply Regmap.gss.
  unfold Regmap.set. destruct (RegEq.eq r a); auto.
Qed.

Fixpoint set_regs (rl: list mreg) (vl: list val) (rs: regset) : regset :=
  match rl, vl with
  | r1 :: rl', v1 :: vl' => set_regs rl' vl' (Regmap.set r1 v1 rs)
  | _, _ => rs
  end.

Definition is_label (lbl: label) (instr: instruction) : bool :=
  match instr with
  | Mlabel lbl' => if peq lbl lbl' then true else false
  | _ => false
  end.

Lemma is_label_correct:
  forall lbl instr,
  if is_label lbl instr then instr = Mlabel lbl else instr <> Mlabel lbl.
Proof.
  intros.  destruct instr; simpl; try discriminate.
  case (peq lbl l); intro; congruence.
Qed.

Fixpoint find_label (lbl: label) (c: code) {struct c} : option code :=
  match c with
  | nil => None
  | i1 :: il => if is_label lbl i1 then Some il else find_label lbl il
  end.

Lemma find_label_incl:
  forall lbl c c', find_label lbl c = Some c' -> incl c' c.
Proof.
  induction c; simpl; intros. discriminate.
  destruct (is_label lbl a). inv H. auto with coqlib. eauto with coqlib.
Qed.

Section RELSEM.

Variable return_address_offset: function -> code -> int -> Prop.

Variable ge: genv.

Definition find_function_ptr
        (ge: genv) (ros: mreg + ident) (rs: regset) : option block :=
  match ros with
  | inl r =>
      match rs r with
      | Vptr b ofs => if Int.eq ofs Int.zero then Some b else None
      | _ => None
      end
  | inr symb =>
      Genv.find_symbol ge symb
  end.

(** Extract the values of the arguments to an external call. *)

Inductive extcall_arg: regset -> mem -> val -> loc -> val -> Prop :=
  | extcall_arg_reg: forall rs m sp r,
      extcall_arg rs m sp (R r) (rs r)
  | extcall_arg_stack: forall rs m sp ofs ty v,
      load_stack m sp ty (Int.repr (Stacklayout.fe_ofs_arg + 4 * ofs)) = Some v ->
      extcall_arg rs m sp (S Outgoing ofs ty) v.

Definition extcall_arguments
    (rs: regset) (m: mem) (sp: val) (sg: signature) (args: list val) : Prop :=
  Forall2 (extcall_arg rs m sp) (loc_arguments sg) args.

(** Extract the values of the arguments to an annotation. *)

Inductive annot_arg: regset -> mem -> val -> annot_param -> val -> Prop :=
  | annot_arg_reg: forall rs m sp r,
      annot_arg rs m sp (APreg r) (rs r)
  | annot_arg_stack: forall rs m stk base chunk ofs v,
      Mem.load chunk m stk (Int.unsigned base + ofs) = Some v ->
      annot_arg rs m (Vptr stk base) (APstack chunk ofs) v.

Definition annot_arguments
   (rs: regset) (m: mem) (sp: val) (params: list annot_param) (args: list val) : Prop :=
  Forall2 (annot_arg rs m sp) params args.

(** Mach execution states. *)

(** Mach execution states. *)

Inductive stackframe: Type :=
  | Stackframe:
      forall (f: block)       (**r pointer to calling function *)
             (sp: val)        (**r stack pointer in calling function *)
             (retaddr: val)   (**r Asm return address in calling function *)
             (c: code),       (**r program point in calling function *)
      stackframe.

Inductive state: Type :=
  | State:
      forall (stack: list stackframe)  (**r call stack *)
             (f: block)                (**r pointer to current function *)
             (sp: val)                 (**r stack pointer *)
             (c: code)                 (**r current program point *)
             (rs: regset),             (**r register state *)
      state
  | Callstate:
      forall (stack: list stackframe)  (**r call stack *)
             (f: block)                (**r pointer to function to call *)
             (rs: regset),             (**r register state *)
      state
  | Returnstate:
      forall (stack: list stackframe)  (**r call stack *)
             (rs: regset),             (**r register state *)
      state.

Definition parent_sp (s: list stackframe) : val :=
  match s with
  | nil => Vzero
  | Stackframe f sp ra c :: s' => sp
  end.

Definition parent_ra (s: list stackframe) : val :=
  match s with
  | nil => Vzero
  | Stackframe f sp ra c :: s' => ra
  end.

Inductive step: state * mem -> trace -> state * mem -> Prop :=
  | exec_Mlabel:
      forall s f sp lbl c rs m,
      step (State s f sp (Mlabel lbl :: c) rs, m)
        E0 (State s f sp c rs, m)
  | exec_Mgetstack:
      forall s f sp ofs ty dst c rs m v,
      load_stack m sp ty ofs = Some v ->
      step (State s f sp (Mgetstack ofs ty dst :: c) rs, m)
        E0 (State s f sp c (rs#dst <- v), m)
  | exec_Msetstack:
      forall s f sp src ofs ty c rs m m' rs',
      store_stack m sp ty ofs (rs src) = Some m' ->
      rs' = undef_regs (destroyed_by_setstack ty) rs ->
      step (State s f sp (Msetstack src ofs ty :: c) rs, m)
        E0 (State s f sp c rs', m')
  | exec_Mgetparam:
      forall s fb f sp ofs ty dst c rs m v rs',
      Genv.find_funct_ptr ge fb = Some (Internal f) ->
      load_stack m sp Tint f.(fn_link_ofs) = Some (parent_sp s) ->
      load_stack m (parent_sp s) ty ofs = Some v ->
      rs' = (rs # temp_for_parent_frame <- Vundef # dst <- v) ->
      step (State s fb sp (Mgetparam ofs ty dst :: c) rs, m)
        E0 (State s fb sp c rs', m)
  | exec_Mop:
      forall s f sp op args res c rs m v rs',
      eval_operation ge sp op rs##args m = Some v ->
      rs' = ((undef_regs (destroyed_by_op op) rs)#res <- v) ->
      step (State s f sp (Mop op args res :: c) rs, m)
        E0 (State s f sp c rs', m)
  | exec_Mload:
      forall s f sp chunk addr args dst c rs m a v rs',
      eval_addressing ge sp addr rs##args = Some a ->
      Mem.loadv chunk m a = Some v ->
      rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- v) ->
      step (State s f sp (Mload chunk addr args dst :: c) rs, m)
        E0 (State s f sp c rs', m)
  | exec_Mstore:
      forall s f sp chunk addr args src c rs m m' a rs',
      eval_addressing ge sp addr rs##args = Some a ->
      Mem.storev chunk m a (rs src) = Some m' ->
      rs' = undef_regs (destroyed_by_store chunk addr) rs ->
      step (State s f sp (Mstore chunk addr args src :: c) rs, m)
        E0 (State s f sp c rs', m')
  | exec_Mcall:
      forall s fb sp sig ros c rs m f f' ra,
      find_function_ptr ge ros rs = Some f' ->
      Genv.find_funct_ptr ge fb = Some (Internal f) ->
      return_address_offset f c ra ->
      step (State s fb sp (Mcall sig ros :: c) rs, m)
        E0 (Callstate (Stackframe fb sp (Vptr fb ra) c :: s)
                       f' rs, m)
  | exec_Mtailcall:
      forall s fb stk soff sig ros c rs m f f' m',
      find_function_ptr ge ros rs = Some f' ->
      Genv.find_funct_ptr ge fb = Some (Internal f) ->
      load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) ->
      load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) ->
      Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
      step (State s fb (Vptr stk soff) (Mtailcall sig ros :: c) rs, m)
        E0 (Callstate s f' rs, m')
  | exec_Mbuiltin:
      forall s f sp rs m ef args res b t vl rs' m',
      builtin_call' ef ge rs##args m t vl m' ->
      rs' = set_regs res vl (undef_regs (destroyed_by_builtin ef) rs) ->
      step (State s f sp (Mbuiltin ef args res :: b) rs, m)
         t (State s f sp b rs', m')
  | exec_Mannot:
      forall s f sp rs m ef args b vargs t v m',
      annot_arguments rs m sp args vargs ->
      builtin_call' ef ge vargs m t v m' ->
      step (State s f sp (Mannot ef args :: b) rs, m)
         t (State s f sp b rs, m')
  | exec_Mgoto:
      forall s fb f sp lbl c rs m c',
      Genv.find_funct_ptr ge fb = Some (Internal f) ->
      find_label lbl f.(fn_code) = Some c' ->
      step (State s fb sp (Mgoto lbl :: c) rs, m)
        E0 (State s fb sp c' rs, m)
  | exec_Mcond_true:
      forall s fb f sp cond args lbl c rs m c' rs',
      eval_condition cond rs##args m = Some true ->
      Genv.find_funct_ptr ge fb = Some (Internal f) ->
      find_label lbl f.(fn_code) = Some c' ->
      rs' = undef_regs (destroyed_by_cond cond) rs ->
      step (State s fb sp (Mcond cond args lbl :: c) rs, m)
        E0 (State s fb sp c' rs', m)
  | exec_Mcond_false:
      forall s f sp cond args lbl c rs m rs',
      eval_condition cond rs##args m = Some false ->
      rs' = undef_regs (destroyed_by_cond cond) rs ->
      step (State s f sp (Mcond cond args lbl :: c) rs, m)
        E0 (State s f sp c rs', m)
  | exec_Mjumptable:
      forall s fb f sp arg tbl c rs m n lbl c' rs',
      rs arg = Vint n ->
      list_nth_z tbl (Int.unsigned n) = Some lbl ->
      Genv.find_funct_ptr ge fb = Some (Internal f) ->
      find_label lbl f.(fn_code) = Some c' ->
      rs' = undef_regs destroyed_by_jumptable rs ->
      step (State s fb sp (Mjumptable arg tbl :: c) rs, m)
        E0 (State s fb sp c' rs', m)
  | exec_Mreturn:
      forall s fb stk soff c rs m f m',
      Genv.find_funct_ptr ge fb = Some (Internal f) ->
      load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) ->
      load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) ->
      Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
      step (State s fb (Vptr stk soff) (Mreturn :: c) rs, m)
        E0 (Returnstate s rs, m')
  | exec_function_internal:
      forall s fb rs m f m1 m2 m3 stk rs',
      Genv.find_funct_ptr ge fb = Some (Internal f) ->
      Mem.alloc m 0 f.(fn_stacksize) = (m1, stk) ->
      let sp := Vptr stk Int.zero in
      store_stack m1 sp Tint f.(fn_link_ofs) (parent_sp s) = Some m2 ->
      store_stack m2 sp Tint f.(fn_retaddr_ofs) (parent_ra s) = Some m3 ->
      rs' = undef_regs destroyed_at_function_entry rs ->
      step (Callstate s fb rs, m)
        E0 (State s fb sp f.(fn_code) rs', m3)
  | exec_function_external:
      forall s fb rs m t rs' ef args res m',
      Genv.find_funct_ptr ge fb = Some (External ef) ->
      extcall_arguments rs m (parent_sp s) (ef_sig ef) args ->
      external_call' ef ge args m t res m' ->
      rs' = set_regs (loc_result (ef_sig ef)) res rs ->
      step (Callstate s fb rs, m)
         t (Returnstate s rs', m')
  | exec_return:
      forall s f sp ra c rs m,
      step (Returnstate (Stackframe f sp ra c :: s) rs, m)
        E0 (State s f sp c rs, m).

End RELSEM.

Inductive initial_state (p: program): state * mem -> Prop :=
  | initial_state_intro: forall fb m0,
      let ge := Genv.globalenv p in
      Genv.init_mem p = Some m0 ->
      Genv.find_symbol ge p.(prog_main) = Some fb ->
      initial_state p (Callstate nil fb (Regmap.init Vundef), m0).

Inductive final_state: state * mem -> int -> Prop :=
  | final_state_intro: forall rs m r retcode,
      loc_result signature_main = r :: nil ->
      rs r = Vint retcode ->
      final_state (Returnstate nil rs, m) retcode.

Lemma store_stack_forward:
  forall m1 sp ty x v m2,
  store_stack m1 sp ty x v = Some m2 -> Mem.forward m1 m2.
Proof.
  unfold store_stack. eauto using Mem.storev_forward.
Qed.
Lemma semantics_forward:
  forall rao ge s1 m1 t s2 m2,
  step rao ge (s1,m1) t (s2,m2) -> Mem.forward m1 m2.
Proof.
  intros; inv H; eauto 10 using Mem.forward_refl, Mem.storev_forward,
    Mem.free_forward, Mem.alloc_forward, external_call_forward',
    Mem.forward_trans, Mem.alloc_forward, builtin_call_forward'.
Qed.

Definition semantics (rao: function -> code -> int -> Prop) (p: program) :=
  Semantics (step rao) (initial_state p) final_state (Genv.globalenv p) (semantics_forward rao).


(**************************************************************************)
(*  This file is part of CertrBPF,                                        *)
(*  a formally verified rBPF verifier + interpreter + JIT in Coq.         *)
(*                                                                        *)
(*  Copyright (C) 2022 Inria                                              *)
(*                                                                        *)
(*  This program is free software; you can redistribute it and/or modify  *)
(*  it under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation; either version 2 of the License, or     *)
(*  (at your option) any later version.                                   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful,       *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU General Public License for more details.                          *)
(*                                                                        *)
(**************************************************************************)

From Coq Require Import List Lia ZArith.
From compcert Require Import Integers Values Clight Memory.
Import ListNotations.

From bpf.comm Require Import LemmaNat Monad.
From bpf.clightlogic Require Import CommonLemma CommonLib Clightlogic CorrectRel.
From bpf.verifier.comm Require Import monad.

From bpf.verifier.synthesismodel Require Import opcode_synthesis verifier_synthesis.
From bpf.verifier.clightmodel Require Import verifier.
From bpf.verifier.simulation Require Import VerifierSimulation VerifierRel.
From bpf.verifier.simulation Require Import correct_is_well_src correct_is_not_div_by_zero correct_is_shift_range.

(**
Check bpf_verifier_opcode_alu64_reg.
bpf_verifier_opcode_alu64_reg
     : nat -> int64 -> M bool

*)
Open Scope Z_scope.

Definition opcode_alu64_reg_if (op: nat) : opcode_alu64_reg :=
  if Nat.eqb op 15%nat then ADD64_REG
  else if Nat.eqb op 31%nat then SUB64_REG
  else if Nat.eqb op 47%nat then MUL64_REG
  else if Nat.eqb op 63%nat then DIV64_REG
  else if Nat.eqb op 79%nat then OR64_REG
  else if Nat.eqb op 95%nat then AND64_REG
  else if Nat.eqb op 111%nat then LSH64_REG
  else if Nat.eqb op 127%nat then RSH64_REG
  else if Nat.eqb op 159%nat then MOD64_REG
  else if Nat.eqb op 175%nat then XOR64_REG
  else if Nat.eqb op 191%nat then MOV64_REG
  else if Nat.eqb op 207%nat then ARSH64_REG
  else ALU64_REG_ILLEGAL.

Lemma opcode_alu64_reg_eqb_eq : forall a b,
    opcode_alu64_reg_eqb a b = true -> a = b.
Proof.
  destruct a,b ; simpl ;congruence.
Qed.

Lemma lift_opcode_alu64_reg :
  forall (E: nat -> opcode_alu64_reg)
         (F: nat -> opcode_alu64_reg) n,
    ((fun n => opcode_alu64_reg_eqb (E n) (F n) = true) n) <->
      (((fun n => opcode_alu64_reg_eqb (E n) (F n)) n) = true).
Proof.
  intros.
  simpl. reflexivity.
Qed.

Lemma byte_to_opcode_alu64_reg_if_same:
  forall (op: nat),
    (op <= 255)%nat ->
    nat_to_opcode_alu64_reg op = opcode_alu64_reg_if op.
Proof.
  intros.
  unfold nat_to_opcode_alu64_reg, opcode_alu64_reg_if.
  apply opcode_alu64_reg_eqb_eq.
  match goal with
  | |- ?A = true => set (P := A)
  end.
  pattern op in P.
  match goal with
  | P := ?F op |- _=>
      apply (Forall_exec_spec F 255)
  end.
  vm_compute.
  reflexivity.
  assumption.
Qed.

Lemma bpf_verifier_opcode_alu64_reg_match:
  forall op
    (Hop: (op <= 255)%nat)
    (Halu : nat_to_opcode_alu64_reg op = ALU64_REG_ILLEGAL),
      15  <> (Z.of_nat op) /\
      31  <> (Z.of_nat op) /\
      47  <> (Z.of_nat op) /\
      63  <> (Z.of_nat op) /\
      79  <> (Z.of_nat op) /\
      95  <> (Z.of_nat op) /\
      111 <> (Z.of_nat op) /\
      127 <> (Z.of_nat op) /\
      159 <> (Z.of_nat op) /\
      175 <> (Z.of_nat op) /\
      191 <> (Z.of_nat op) /\
      207 <> (Z.of_nat op).
Proof.
  intros.
  rewrite byte_to_opcode_alu64_reg_if_same in Halu; auto.
  unfold opcode_alu64_reg_if in Halu.
  change 15  with (Z.of_nat 15%nat).
  change 31  with (Z.of_nat 31%nat).
  change 47  with (Z.of_nat 47%nat).
  change 63  with (Z.of_nat 63%nat).
  change 79  with (Z.of_nat 79%nat).
  change 95  with (Z.of_nat 95%nat).
  change 111 with (Z.of_nat 111%nat).
  change 127 with (Z.of_nat 127%nat).
  change 159 with (Z.of_nat 159%nat).
  change 175 with (Z.of_nat 175%nat).
  change 191 with (Z.of_nat 191%nat).
  change 207 with (Z.of_nat 207%nat).

  repeat match goal with
  | H : (if ?X then _ else _) = _ |- _ /\ _ =>
    split; [destruct X eqn: Hnew; [inversion H |
      rewrite Nat.eqb_neq in Hnew;
      intro Hfalse; apply Hnew;
      symmetry in Hfalse;
      apply Nat2Z.inj in Hfalse;
      assumption]
    | destruct X eqn: Hnew; [inversion H| clear Hnew]]
  | H : (if ?X then _ else _) = _ |- _ =>
    destruct X eqn: Hnew; [inversion H |
      rewrite Nat.eqb_neq in Hnew;
      intro Hfalse; apply Hnew;
      symmetry in Hfalse;
      apply Nat2Z.inj in Hfalse;
      assumption]
  end.
Qed.

Section Bpf_verifier_opcode_alu64_reg.
  Context {S:special_blocks}.

  (** The program contains our function of interest [fn] *)
  Definition p : Clight.program := prog.

  (* [Args,Res] provides the mapping between the Coq and the C types *)
  (* Definition Args : list CompilableType := [stateCompilableType].*)
  Definition args : list Type := [(nat:Type); (int64:Type)].
  Definition res : Type := (bool:Type).

  (* [f] is a Coq Monadic function with the right type *)
  Definition f : arrow_type args (M state.state res) := bpf_verifier_opcode_alu64_reg.

  (* [fn] is the Cligth function which has the same behaviour as [f] *)
  Definition fn: Clight.function := f_bpf_verifier_opcode_alu64_reg.

  (* [match_arg] relates the Coq arguments and the C arguments *)
  Definition match_arg_list : DList.t (fun x => x -> Inv _) args :=
    dcons (fun x => StateLess _ (opcode_correct x))
     (dcons (fun x => StateLess _ (int64_correct x))
      (DList.DNil _)).

  (* [match_res] relates the Coq result and the C result *)
  Definition match_res : res -> Inv state.state := fun x => StateLess _ (bool_correct x).

  Instance correct_function_bpf_verifier_opcode_alu64_reg : forall a, correct_function _ p args res f fn ModNothing true match_state match_arg_list match_res a.
  Proof.
    correct_function_from_body args.
    correct_body.

    unfold f, bpf_verifier_opcode_alu64_reg.
    simpl. (*
    unfold nat_to_opcode_alu64_reg. *)
    (** goal: correct_body _ _
              match x with
              | op_BPF_ADD32 => bindM (upd_reg ... *)
    unfold INV.
    destruct nat_to_opcode_alu64_reg eqn: Halu. (**r case discussion on each alu64_instruction *)
    - (**r ADD64_REG *)
      eapply correct_statement_switch with (n:= 15).
      + simpl.
        (**r s1 -> (Ssequence s1 s2) *)
        eapply correct_statement_seq_body_drop.
        intros.

        correct_forward.

        get_invariant _ins.
        exists (v::nil).
        split.
        unfold map_opt, exec_expr. rewrite p0.
        reflexivity.
        intros. simpl.
        tauto.
        intros.

        correct_forward.
        get_invariant _b.
        unfold correct_is_well_src.match_res in c1.
        unfold match_res.
        exists v.
        unfold exec_expr.
        rewrite p0.
        split; [reflexivity|].
        split; [assumption|].
        unfold eval_inv, bool_correct in c1.
        rewrite c1.
        split.
        unfold Cop.sem_cast; simpl.
        destruct x; reflexivity.
        intros.
        constructor.
        destruct x; reflexivity.
      + reflexivity.
      + intros.
        get_invariant _op.
        unfold exec_expr.
        rewrite p0. f_equal.
        unfold eval_inv, opcode_correct in c1.
        unfold nat_to_opcode_alu64_reg in Halu.
        assert (Hc_eq: c = 15%nat). {
          clear - Halu.
          do 15 (destruct c; [inversion Halu|]).
          destruct c; [reflexivity|].
          do 192 (destruct c; [inversion Halu|]).
          inversion Halu.
        }
        rewrite Hc_eq in *.
        destruct c1 as (c1 & _).
        change (Z.of_nat 15) with 15 in c1.
        symmetry; assumption.
      + compute. intuition congruence.
    - (**r SUB64_REG *)
      eapply correct_statement_switch with (n:= 31).
      + simpl.
        (**r s1 -> (Ssequence s1 s2) *)
        eapply correct_statement_seq_body_drop.
        intros.

        correct_forward.

        get_invariant _ins.
        exists (v::nil).
        split.
        unfold map_opt, exec_expr. rewrite p0.
        reflexivity.
        intros. simpl.
        tauto.
        intros.

        correct_forward.
        get_invariant _b.
        unfold correct_is_well_src.match_res in c1.
        unfold match_res.
        exists v.
        unfold exec_expr.
        rewrite p0.
        split; [reflexivity|].
        split; [assumption|].
        unfold eval_inv, bool_correct in c1.
        rewrite c1.
        split.
        unfold Cop.sem_cast; simpl.
        destruct x; reflexivity.
        intros.
        constructor.
        destruct x; reflexivity.
      + reflexivity.
      + intros Hst H; simpl in H.
        get_invariant _op.
        unfold exec_expr.
        rewrite p0. f_equal.
        unfold eval_inv, opcode_correct in c1.
        unfold nat_to_opcode_alu64_reg in Halu.
        assert (Hc_eq: c = 31%nat). {
          clear - Halu.
          do 31 (destruct c; [inversion Halu|]).
          destruct c; [reflexivity|].
          do 176 (destruct c; [inversion Halu|]).
          inversion Halu.
        }
        rewrite Hc_eq in *.
        destruct c1 as (c1 & _).
        change (Z.of_nat 31) with 31 in c1.
        symmetry; assumption.
      + compute. intuition congruence.
    - (**r MUL64_REG *)
      eapply correct_statement_switch with (n:= 47).
      + simpl.
        (**r s1 -> (Ssequence s1 s2) *)
        eapply correct_statement_seq_body_drop.
        intros.

        correct_forward.

        get_invariant _ins.
        exists (v::nil).
        split.
        unfold map_opt, exec_expr. rewrite p0.
        reflexivity.
        intros. simpl.
        tauto.
        intros.

        correct_forward.
        get_invariant _b.
        unfold correct_is_well_src.match_res in c1.
        unfold match_res.
        exists v.
        unfold exec_expr.
        rewrite p0.
        split; [reflexivity|].
        split; [assumption|].
        unfold eval_inv, bool_correct in c1.
        rewrite c1.
        split.
        unfold Cop.sem_cast; simpl.
        destruct x; reflexivity.
        intros.
        constructor.
        destruct x; reflexivity.
      + reflexivity.
      + intros.
        get_invariant _op.
        unfold exec_expr.
        rewrite p0. f_equal.
        unfold eval_inv, opcode_correct in c1.
        unfold nat_to_opcode_alu64_reg in Halu.
        assert (Hc_eq: c = 47%nat). {
          clear - Halu.
          do 47 (destruct c; [inversion Halu|]).
          destruct c; [reflexivity|].
          do 160 (destruct c; [inversion Halu|]).
          inversion Halu.
        }
        rewrite Hc_eq in *.
        destruct c1 as (c1 & _).
        change (Z.of_nat 47) with 47 in c1.
        symmetry; assumption.
      + compute. intuition congruence.
    - (**r DIV64_REG *)
      eapply correct_statement_switch with (n:= 63).
      + simpl.
        (**r s1 -> (Ssequence s1 s2) *)
        eapply correct_statement_seq_body_drop.
        intros.

        correct_forward.

        get_invariant _ins.
        exists (v::nil).
        split.
        unfold map_opt, exec_expr. rewrite p0.
        reflexivity.
        intros. simpl.
        tauto.
        intros.

        correct_forward.
        get_invariant _b.
        unfold correct_is_well_src.match_res in c1.
        unfold match_res.
        exists v.
        unfold exec_expr.
        rewrite p0.
        split; [reflexivity|].
        split; [assumption|].
        unfold eval_inv, bool_correct in c1.
        rewrite c1.
        split.
        unfold Cop.sem_cast; simpl.
        destruct x; reflexivity.
        intros.
        constructor.
        destruct x; reflexivity.
      + reflexivity.
      + intros.
        get_invariant _op.
        unfold exec_expr.
        rewrite p0. f_equal.
        unfold eval_inv, opcode_correct in c1.
        unfold nat_to_opcode_alu64_reg in Halu.
        assert (Hc_eq: c = 63%nat). {
          clear - Halu.
          do 63 (destruct c; [inversion Halu|]).
          destruct c; [reflexivity|].
          do 144 (destruct c; [inversion Halu|]).
          inversion Halu.
        }
        rewrite Hc_eq in *.
        destruct c1 as (c1 & _).
        change (Z.of_nat 63) with 63 in c1.
        symmetry; assumption.
      + compute. intuition congruence.
    - (**r OR64_REG *)
      eapply correct_statement_switch with (n:= 79).
      + simpl.
        (**r s1 -> (Ssequence s1 s2) *)
        eapply correct_statement_seq_body_drop.
        intros.

        correct_forward.

        get_invariant _ins.
        exists (v::nil).
        split.
        unfold map_opt, exec_expr. rewrite p0.
        reflexivity.
        intros. simpl.
        tauto.
        intros.

        correct_forward.
        get_invariant _b.
        unfold correct_is_well_src.match_res in c1.
        unfold match_res.
        exists v.
        unfold exec_expr.
        rewrite p0.
        split; [reflexivity|].
        split; [assumption|].
        unfold eval_inv, bool_correct in c1.
        rewrite c1.
        split.
        unfold Cop.sem_cast; simpl.
        destruct x; reflexivity.
        intros.
        constructor.
        destruct x; reflexivity.
      + reflexivity.
      + intros.
        get_invariant _op.
        unfold exec_expr.
        rewrite p0. f_equal.
        unfold eval_inv, opcode_correct in c1.
        unfold nat_to_opcode_alu64_reg in Halu.
        assert (Hc_eq: c = 79%nat). {
          clear - Halu.
          do 79 (destruct c; [inversion Halu|]).
          destruct c; [reflexivity|].
          do 128 (destruct c; [inversion Halu|]).
          inversion Halu.
        }
        rewrite Hc_eq in *.
        destruct c1 as (c1 & _).
        change (Z.of_nat 79) with 79 in c1.
        symmetry; assumption.
      + compute. intuition congruence.
    - (**r AND64_REG *)
      eapply correct_statement_switch with (n:= 95).
      + simpl.
        (**r s1 -> (Ssequence s1 s2) *)
        eapply correct_statement_seq_body_drop.
        intros.

        correct_forward.

        get_invariant _ins.
        exists (v::nil).
        split.
        unfold map_opt, exec_expr. rewrite p0.
        reflexivity.
        intros. simpl.
        tauto.
        intros.

        correct_forward.
        get_invariant _b.
        unfold correct_is_well_src.match_res in c1.
        unfold match_res.
        exists v.
        unfold exec_expr.
        rewrite p0.
        split; [reflexivity|].
        split; [assumption|].
        unfold eval_inv, bool_correct in c1.
        rewrite c1.
        split.
        unfold Cop.sem_cast; simpl.
        destruct x; reflexivity.
        intros.
        constructor.
        destruct x; reflexivity.
      + reflexivity.
      + intros.
        get_invariant _op.
        unfold exec_expr.
        rewrite p0. f_equal.
        unfold eval_inv, opcode_correct in c1.
        unfold nat_to_opcode_alu64_reg in Halu.
        assert (Hc_eq: c = 95%nat). {
          clear - Halu.
          do 95 (destruct c; [inversion Halu|]).
          destruct c; [reflexivity|].
          do 112 (destruct c; [inversion Halu|]).
          inversion Halu.
        }
        rewrite Hc_eq in *.
        destruct c1 as (c1 & _).
        change (Z.of_nat 95) with 95 in c1.
        symmetry; assumption.
      + compute. intuition congruence.
    - (**r LSH64_REG *)
      eapply correct_statement_switch with (n:= 111).
      + simpl.
        (**r s1 -> (Ssequence s1 s2) *)
        eapply correct_statement_seq_body_drop.
        intros.

        correct_forward.

        get_invariant _ins.
        exists (v::nil).
        split.
        unfold map_opt, exec_expr. rewrite p0.
        reflexivity.
        intros. simpl.
        tauto.
        intros.

        correct_forward.
        get_invariant _b.
        unfold correct_is_well_src.match_res in c1.
        unfold match_res.
        exists v.
        unfold exec_expr.
        rewrite p0.
        split; [reflexivity|].
        split; [assumption|].
        unfold eval_inv, bool_correct in c1.
        rewrite c1.
        split.
        unfold Cop.sem_cast; simpl.
        destruct x; reflexivity.
        intros.
        constructor.
        destruct x; reflexivity.
      + reflexivity.
      + intros.
        get_invariant _op.
        unfold exec_expr.
        rewrite p0. f_equal.
        unfold eval_inv, opcode_correct in c1.
        unfold nat_to_opcode_alu64_reg in Halu.
        assert (Hc_eq: c = 111%nat). {
          clear - Halu.
          do 111 (destruct c; [inversion Halu|]).
          destruct c; [reflexivity|].
          do 96 (destruct c; [inversion Halu|]).
          inversion Halu.
        }
        rewrite Hc_eq in *.
        destruct c1 as (c1 & _).
        change (Z.of_nat 111) with 111 in c1.
        symmetry; assumption.
      + compute. intuition congruence.
    - (**r RSH64_REG *)
      eapply correct_statement_switch with (n:= 127).
      + simpl.
        (**r s1 -> (Ssequence s1 s2) *)
        eapply correct_statement_seq_body_drop.
        intros.

        correct_forward.

        get_invariant _ins.
        exists (v::nil).
        split.
        unfold map_opt, exec_expr. rewrite p0.
        reflexivity.
        intros. simpl.
        tauto.
        intros.

        correct_forward.
        get_invariant _b.
        unfold correct_is_well_src.match_res in c1.
        unfold match_res.
        exists v.
        unfold exec_expr.
        rewrite p0.
        split; [reflexivity|].
        split; [assumption|].
        unfold eval_inv, bool_correct in c1.
        rewrite c1.
        split.
        unfold Cop.sem_cast; simpl.
        destruct x; reflexivity.
        intros.
        constructor.
        destruct x; reflexivity.
      + reflexivity.
      + intros.
        get_invariant _op.
        unfold exec_expr.
        rewrite p0. f_equal.
        unfold eval_inv, opcode_correct in c1.
        unfold nat_to_opcode_alu64_reg in Halu.
        assert (Hc_eq: c = 127%nat). {
          clear - Halu.
          do 127 (destruct c; [inversion Halu|]).
          destruct c; [reflexivity|].
          do 80 (destruct c; [inversion Halu|]).
          inversion Halu.
        }
        rewrite Hc_eq in *.
        destruct c1 as (c1 & _).
        change (Z.of_nat 127) with 127 in c1.
        symmetry; assumption.
      + compute. intuition congruence.
    - (**r MOD64_REG *)
      eapply correct_statement_switch with (n:= 159).
      + simpl.
        (**r s1 -> (Ssequence s1 s2) *)
        eapply correct_statement_seq_body_drop.
        intros.

        correct_forward.

        get_invariant _ins.
        exists (v::nil).
        split.
        unfold map_opt, exec_expr. rewrite p0.
        reflexivity.
        intros. simpl.
        tauto.
        intros.

        correct_forward.
        get_invariant _b.
        unfold correct_is_well_src.match_res in c1.
        unfold match_res.
        exists v.
        unfold exec_expr.
        rewrite p0.
        split; [reflexivity|].
        split; [assumption|].
        unfold eval_inv, bool_correct in c1.
        rewrite c1.
        split.
        unfold Cop.sem_cast; simpl.
        destruct x; reflexivity.
        intros.
        constructor.
        destruct x; reflexivity.
      + reflexivity.
      + intros.
        get_invariant _op.
        unfold exec_expr.
        rewrite p0. f_equal.
        unfold eval_inv, opcode_correct in c1.
        unfold nat_to_opcode_alu64_reg in Halu.
        assert (Hc_eq: c = 159%nat). {
          clear - Halu.
          do 159 (destruct c; [inversion Halu|]).
          destruct c; [reflexivity|].
          do 48 (destruct c; [inversion Halu|]).
          inversion Halu.
        }
        rewrite Hc_eq in *.
        destruct c1 as (c1 & _).
        change (Z.of_nat 159) with 159 in c1.
        symmetry; assumption.
      + compute. intuition congruence.
    - (**r XOR64_REG *)
      eapply correct_statement_switch with (n:= 175).
      + simpl.
        (**r s1 -> (Ssequence s1 s2) *)
        eapply correct_statement_seq_body_drop.
        intros.

        correct_forward.

        get_invariant _ins.
        exists (v::nil).
        split.
        unfold map_opt, exec_expr. rewrite p0.
        reflexivity.
        intros. simpl.
        tauto.
        intros.

        correct_forward.
        get_invariant _b.
        unfold correct_is_well_src.match_res in c1.
        unfold match_res.
        exists v.
        unfold exec_expr.
        rewrite p0.
        split; [reflexivity|].
        split; [assumption|].
        unfold eval_inv, bool_correct in c1.
        rewrite c1.
        split.
        unfold Cop.sem_cast; simpl.
        destruct x; reflexivity.
        intros.
        constructor.
        destruct x; reflexivity.
      + reflexivity.
      + intros.
        get_invariant _op.
        unfold exec_expr.
        rewrite p0. f_equal.
        unfold eval_inv, opcode_correct in c1.
        unfold nat_to_opcode_alu64_reg in Halu.
        assert (Hc_eq: c = 175%nat). {
          clear - Halu.
          do 175 (destruct c; [inversion Halu|]).
          destruct c; [reflexivity|].
          do 32 (destruct c; [inversion Halu|]).
          inversion Halu.
        }
        rewrite Hc_eq in *.
        destruct c1 as (c1 & _).
        change (Z.of_nat 175) with 175 in c1.
        symmetry; assumption.
      + compute. intuition congruence.
    - (**r MOV64_REG *)
      eapply correct_statement_switch with (n:= 191).
      + simpl.
        (**r s1 -> (Ssequence s1 s2) *)
        eapply correct_statement_seq_body_drop.
        intros.

        correct_forward.

        get_invariant _ins.
        exists (v::nil).
        split.
        unfold map_opt, exec_expr. rewrite p0.
        reflexivity.
        intros. simpl.
        tauto.
        intros.

        correct_forward.
        get_invariant _b.
        unfold correct_is_well_src.match_res in c1.
        unfold match_res.
        exists v.
        unfold exec_expr.
        rewrite p0.
        split; [reflexivity|].
        split; [assumption|].
        unfold eval_inv, bool_correct in c1.
        rewrite c1.
        split.
        unfold Cop.sem_cast; simpl.
        destruct x; reflexivity.
        intros.
        constructor.
        destruct x; reflexivity.
      + reflexivity.
      + intros.
        get_invariant _op.
        unfold exec_expr.
        rewrite p0. f_equal.
        unfold eval_inv, opcode_correct in c1.
        unfold nat_to_opcode_alu64_reg in Halu.
        assert (Hc_eq: c = 191%nat). {
          clear - Halu.
          do 191 (destruct c; [inversion Halu|]).
          destruct c; [reflexivity|].
          do 16 (destruct c; [inversion Halu|]).
          inversion Halu.
        }
        rewrite Hc_eq in *.
        destruct c1 as (c1 & _).
        change (Z.of_nat 191) with 191 in c1.
        symmetry; assumption.
      + compute. intuition congruence.
    - (**r ARSH64_REG *)
      eapply correct_statement_switch with (n:= 207).
      + simpl.
        (**r s1 -> (Ssequence s1 s2) *)
        eapply correct_statement_seq_body_drop.
        intros.

        correct_forward.

        get_invariant _ins.
        exists (v::nil).
        split.
        unfold map_opt, exec_expr. rewrite p0.
        reflexivity.
        intros. simpl.
        tauto.
        intros.

        correct_forward.
        get_invariant _b.
        unfold correct_is_well_src.match_res in c1.
        unfold match_res.
        exists v.
        unfold exec_expr.
        rewrite p0.
        split; [reflexivity|].
        split; [assumption|].
        unfold eval_inv, bool_correct in c1.
        rewrite c1.
        split.
        unfold Cop.sem_cast; simpl.
        destruct x; reflexivity.
        intros.
        constructor.
        destruct x; reflexivity.
      + reflexivity.
      + intros.
        get_invariant _op.
        unfold exec_expr.
        rewrite p0. f_equal.
        unfold eval_inv, opcode_correct in c1.
        unfold nat_to_opcode_alu64_reg in Halu.
        assert (Hc_eq: c = 207%nat). {
          clear - Halu.
          do 207 (destruct c; [inversion Halu|]).
          destruct c; [reflexivity|].
          inversion Halu.
        }
        rewrite Hc_eq in *.
        destruct c1 as (c1 & _).
        change (Z.of_nat 207) with 207 in c1.
        symmetry; assumption.
      + compute. intuition congruence.
    - (**r ALU64_REG_ILLEGAL *)
      eapply correct_statement_switch_ex.
      + reflexivity.
      + intros.
        get_invariant _op.
        unfold eval_inv, opcode_correct in c1.
        destruct c1 as (c1 & Hc1_range).
        exists (Z.of_nat c).
        split.
        unfold exec_expr.
        rewrite p0.
        rewrite c1.
        reflexivity.
        split.

        change Int.modulus with 4294967296.
        lia.

        unfold select_switch.
        unfold select_switch_case.
        apply bpf_verifier_opcode_alu64_reg_match in Halu; auto.
        destruct Halu as (Hfirst & Halu). eapply Coqlib.zeq_false in Hfirst. rewrite Hfirst; clear Hfirst.
        repeat match goal with
        | H: ?X <> ?Y /\ _ |- context[Coqlib.zeq ?X ?Y] =>
            destruct H as (Hfirst & H);
            eapply Coqlib.zeq_false in Hfirst; rewrite Hfirst; clear Hfirst
        end.
        eapply Coqlib.zeq_false in Halu; rewrite Halu; clear Halu.
        (* default *)
        simpl.
        eapply correct_statement_seq_body_drop.
        intros.

        correct_forward.
        exists (Vint (Int.repr 0)).
        unfold exec_expr.
        split; [reflexivity|].
        unfold eval_inv, match_res, bool_correct, Int.one.
        split; [reflexivity|].
        split; [reflexivity|].
        intros.
        constructor.
        reflexivity.
Qed.

End Bpf_verifier_opcode_alu64_reg.

Close Scope Z_scope.

Existing Instance correct_function_bpf_verifier_opcode_alu64_reg.