Require Import Raft.
Require Import SpecLemmas.

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

Require Import TermSanityInterface.
Require Import CandidateTermGtLogInterface.

Section CandidateTermGtLog.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.
  Context {tsi : term_sanity_interface}.

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

  Lemma candidate_term_gt_log_init :
    raft_net_invariant_init candidate_term_gt_log.
  Proof using.
    red. unfold candidate_term_gt_log. simpl. discriminate.
  Qed.

  Lemma candidate_term_gt_log_client_request :
    raft_net_invariant_client_request candidate_term_gt_log.
  Proof using.
    red. unfold candidate_term_gt_log. simpl. intros.
    find_higher_order_rewrite. update_destruct; subst; rewrite_update; auto.
    find_copy_apply_lem_hyp handleClientRequest_type.
    find_apply_lem_hyp handleClientRequest_log. intuition.
    + repeat find_rewrite. eauto.
    + break_exists. intuition. repeat find_rewrite. discriminate.
  Qed.

  Lemma candidate_term_gt_log_timeout :
    raft_net_invariant_timeout candidate_term_gt_log.
  Proof using tsi.
    red. unfold candidate_term_gt_log. simpl. intros.
    find_higher_order_rewrite. update_destruct; subst; rewrite_update; auto.
    find_copy_apply_lem_hyp handleTimeout_log_same.
    find_apply_lem_hyp handleTimeout_type_strong. intuition.
    + repeat find_rewrite. eauto.
    + find_apply_lem_hyp no_entries_past_current_term_invariant.
      unfold no_entries_past_current_term in *. intuition.
      unfold no_entries_past_current_term_host in *. repeat find_rewrite.
      find_apply_hyp_hyp. omega.
  Qed.

  Lemma candidate_term_gt_log_append_entries :
    raft_net_invariant_append_entries candidate_term_gt_log.
  Proof using.
    red. unfold candidate_term_gt_log. simpl. intros.
    find_higher_order_rewrite. update_destruct; subst; rewrite_update; auto.
    unfold handleAppendEntries in *. repeat break_match; tuple_inversion; eauto; discriminate.
  Qed.

  Ltac start := red; unfold candidate_term_gt_log; simpl; intros;
    find_higher_order_rewrite; update_destruct; subst; rewrite_update; [|auto].

  Lemma candidate_term_gt_log_append_entries_reply :
    raft_net_invariant_append_entries_reply candidate_term_gt_log.
  Proof using.
    start.
    find_copy_apply_lem_hyp handleAppendEntriesReply_type.
    find_copy_apply_lem_hyp handleAppendEntriesReply_log.
    intuition; repeat find_rewrite; [eauto|discriminate].
  Qed.

  Lemma candidate_term_gt_log_request_vote :
    raft_net_invariant_request_vote candidate_term_gt_log.
  Proof using.
    start.
    find_copy_apply_lem_hyp handleRequestVote_type.
    find_copy_apply_lem_hyp handleRequestVote_log.
    intuition; repeat find_rewrite; [eauto|discriminate].
  Qed.

  Lemma candidate_term_gt_log_request_vote_reply :
    raft_net_invariant_request_vote_reply candidate_term_gt_log.
  Proof using.
    red; unfold candidate_term_gt_log; simpl; intros;
      find_higher_order_rewrite; update_destruct; rewrite_update; auto.
    find_copy_apply_lem_hyp handleRequestVoteReply_type.
    find_copy_apply_lem_hyp handleRequestVoteReply_log.
    intuition; repeat find_rewrite; [eauto|discriminate|discriminate].
  Qed.

  Lemma candidate_term_gt_log_do_leader :
    raft_net_invariant_do_leader candidate_term_gt_log.
  Proof using.
    start.
    find_copy_apply_lem_hyp doLeader_type.
    find_copy_apply_lem_hyp doLeader_log.
    intuition. repeat find_rewrite. eauto.
  Qed.

  Lemma candidate_term_gt_log_do_generic_server :
    raft_net_invariant_do_generic_server candidate_term_gt_log.
  Proof using.
    start.
    find_copy_apply_lem_hyp doGenericServer_type.
    find_copy_apply_lem_hyp doGenericServer_log.
    intuition. repeat find_rewrite. eauto.
  Qed.

  Lemma candidate_term_gt_log_state_same_packet_subset :
    raft_net_invariant_state_same_packet_subset candidate_term_gt_log.
  Proof using.
    red. unfold candidate_term_gt_log. simpl. intros.
    repeat find_reverse_higher_order_rewrite. auto.
  Qed.

  Lemma candidate_term_gt_log_reboot :
    raft_net_invariant_reboot candidate_term_gt_log.
  Proof using.
    start. unfold reboot in *. simpl in *. discriminate.
  Qed.

  Lemma candidate_term_gt_log_invariant :
    forall net,
      raft_intermediate_reachable net ->
      candidate_term_gt_log net.
  Proof using tsi.
    intros.
    apply raft_net_invariant; auto.
    - apply candidate_term_gt_log_init.
    - apply candidate_term_gt_log_client_request.
    - apply candidate_term_gt_log_timeout.
    - apply candidate_term_gt_log_append_entries.
    - apply candidate_term_gt_log_append_entries_reply.
    - apply candidate_term_gt_log_request_vote.
    - apply candidate_term_gt_log_request_vote_reply.
    - apply candidate_term_gt_log_do_leader.
    - apply candidate_term_gt_log_do_generic_server.
    - apply candidate_term_gt_log_state_same_packet_subset.
    - apply candidate_term_gt_log_reboot.
  Qed.

  Instance ctgli : candidate_term_gt_log_interface.
  Proof.
    split. apply candidate_term_gt_log_invariant.
  Qed.
End CandidateTermGtLog.


(*
 * © 2019 Massachusetts Institute of Technology.
 * MIT Proprietary, Subject to FAR52.227-11 Patent Rights - Ownership by the Contractor (May 2014)
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     List.

From SPICY Require Import
     MyPrelude
     Maps
     ChMaps
     Messages
     Keys
     Automation
     Tactics
     Simulation
     AdversaryUniverse

     ModelCheck.ModelCheck
     ModelCheck.UniverseEqAutomation
     ModelCheck.ProtocolAutomation
     ModelCheck.SafeProtocol
     ModelCheck.ProtocolFunctions
.

From protocols Require Import
     ExampleProtocols.

From SPICY Require IdealWorld RealWorld.

Import IdealWorld.IdealNotations.
Import RealWorld.RealWorldNotations.

Set Implicit Arguments.

Import SimulationAutomation.

From Frap Require Import Sets.

Module Foo <: Sets.EMPTY.
End Foo.
Module Import SN := Sets.SetNotations(Foo).

Module SimplePingProtocolSecure <: AutomatedSafeProtocol.

  Import SignPingSendProtocol.

  Definition t__hon := Nat.
  Definition t__adv := Unit.
  Definition b := tt.
  Definition iu0  := ideal_univ_start.
  Definition ru0  := real_univ_start startAdv.

  Import Gen Tacs SetLemmas.

  #[export] Hint Unfold t__hon t__adv b ru0 iu0 ideal_univ_start mkiU real_univ_start mkrU mkrUsr startAdv : core.

  Section Test.
    Section RW.
      Import RealWorld.
      Import RealWorldNotations.

      Definition testU :=
        mkrU $0 $0 $0
             (* user A *)
             ( n  <- Gen; Return n )
             (* user B *)
             ( @Return (Base Nat) 1 ) startAdv.

      Definition testU' y :=
        mkrU $0 $0 $0
             (* user A *)
             ( n  <- Return y; Return n )
             (* user B *)
             ( @Return (Base Nat) 1 ) startAdv.

    End RW.

    Section IW.
      Import IdealWorld.
      Import IdealNotations.

      Definition testI :=
        mkiU #0 $0 $0
             (* user A *)
             ( n <- Gen; Return n)
             (* user B *)
             ( ret 1 ).
    End IW.

    Lemma sets_test1 :
      { (false,false,false) } \cap { (true,false,false) } = { }.
    Proof.
      sets.
    Qed.

    Lemma sets_test2 :
      { (testU, testI, true) } \cap { (testU, testI, false) } = { }.
    Proof.
      sets.
    Qed.

    (* Lemma sets_test3 : *)
    (*   { ([, testI, true) } \cap { (testU, testI, false) } = { }. *)
    (* Proof. *)
    (*   sets. *)
    (* Qed. *)
  End Test.

  Import RealWorld.

  Lemma safe_invariant :
    invariantFor
      {| Initial := {(ru0, iu0, true)}; Step := @step t__hon t__adv  |}
      (fun st => safety st /\ alignment st /\ returns_align st).
  Proof.
    eapply invariant_weaken.

    - apply multiStepClosure_ok; simpl.

      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      (* time(gen). *)

    - intros.
      simpl in *; repeat simple apply conj.

      + sets_invert; unfold safety;
          split_ex; simpl in *; subst;
            autounfold with *;
            try solve [ solve_honest_actions_safe
                        ; clean_map_lookups; eauto 8 ].

      + sets_invert;
          unfold alignment; split_ex; subst; split; trivial; repeat prove_alignment1; eauto 3.

      + sets_invert
        ; autounfold with *
        ; split_ex
        ; simpl in *
        ; subst
        ; unfold returns_align; intros
        ; intros
        ; find_step_or_solve
        .

        Unshelve.
        all: exact 0 || auto.
  Qed.

  Lemma U_good : @universe_starts_sane _ Unit b ru0.
  Proof.
    autounfold;
      unfold universe_starts_sane; simpl.
    repeat (apply conj); intros; eauto.
    - focus_user; auto.
    - econstructor.
    - unfold AdversarySafety.keys_honest, KEYS; rewrite Forall_natmap_forall; intros.
      unfold mkrUsr; simpl.
      rewrite !findUserKeys_add_reduce, findUserKeys_empty_is_empty; eauto.
    - unfold lameAdv; simpl; eauto.
  Qed.

  Lemma universe_starts_safe : universe_ok ru0.
  Proof.
    pose proof (adversary_is_lame_adv_univ_ok_clauses U_good).

    unfold universe_ok
    ; autounfold
    ; simpl
    ; intuition eauto
    .

    - econstructor; eauto.
    - unfold keys_and_permissions_good, KEYS; solve_simple_maps; intuition eauto.
      solve_simple_maps; eauto.

      rewrite Forall_natmap_forall; intros.
      solve_simple_maps; simpl
      ; unfold permission_heap_good; intros;
        solve_concrete_maps; eauto.

    - unfold user_cipher_queues_ok.
      rewrite Forall_natmap_forall; intros.
      focus_user
      ; simpl in *; econstructor; eauto.

    - unfold honest_nonces_ok, honest_user_nonces_ok, honest_nonces_ok
      ; repeat simple apply conj
      ; intros
      ; clean_map_lookups
      ; intros
      ; focus_user
      ; try contradiction; try discriminate; simpl;
        repeat (apply conj); intros; clean_map_lookups; eauto.

    - unfold honest_users_only_honest_keys; intros.
      focus_user;
        subst;
        simpl in *;
        clean_map_lookups;
        unfold mkrUsr; simpl;
        rewrite !findUserKeys_add_reduce, findUserKeys_empty_is_empty;
        eauto;
        simpl in *;
        solve_concrete_perm_merges;
        solve_concrete_maps;
        solve_simple_maps;
        eauto.

  Qed.

End SimplePingProtocolSecure.

Module SimpleEncProtocolSecure <: AutomatedSafeProtocol.

  Import EncPingSendProtocol.

  Definition t__hon := Nat.
  Definition t__adv := Unit.
  Definition b := tt.
  Definition iu0  := ideal_univ_start.
  Definition ru0  := real_univ_start startAdv.

  Import Gen Tacs SetLemmas.

  #[export] Hint Unfold t__hon t__adv b ru0 iu0 ideal_univ_start mkiU real_univ_start mkrU : core.

  Lemma safe_invariant :
    invariantFor
      {| Initial := {(ru0, iu0, true)}; Step := @step t__hon t__adv  |}
      (fun st => safety st /\ alignment st /\ returns_align st).
  Proof.
    eapply invariant_weaken.

    - apply multiStepClosure_ok; simpl.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.

    - intros.
      simpl in *; repeat simple apply conj.

      + sets_invert; unfold safety;
          split_ex; simpl in *; subst;
            autounfold with *;
            solve_honest_actions_safe;
            clean_map_lookups; eauto 8.

      + sets_invert;
          unfold alignment; split_ex; subst; split; trivial; repeat prove_alignment1; eauto 3.

      + sets_invert
        ; autounfold with *
        ; split_ex
        ; simpl in *
        ; subst
        ; unfold returns_align; intros
        ; intros
        ; find_step_or_solve
        .

        Unshelve.
        all: exact 0 || auto.
  Qed.

  Lemma U_good : @universe_starts_sane _ Unit b ru0.
  Proof.
    autounfold;
      unfold universe_starts_sane; simpl.
    repeat (apply conj); intros; eauto.
    - focus_user; auto.
    - econstructor.
    - unfold AdversarySafety.keys_honest, KEYS; rewrite Forall_natmap_forall; intros.
      unfold mkrUsr; simpl.
      rewrite !findUserKeys_add_reduce, findUserKeys_empty_is_empty; eauto.
    - unfold lameAdv; simpl; eauto.
  Qed.

  Lemma universe_starts_safe : universe_ok ru0.
  Proof.
    pose proof (adversary_is_lame_adv_univ_ok_clauses U_good).

    unfold universe_ok
    ; autounfold
    ; simpl
    ; intuition eauto
    .

    - econstructor; eauto.
    - unfold keys_and_permissions_good, KEYS; solve_simple_maps; intuition eauto.
      solve_simple_maps; eauto.

      rewrite Forall_natmap_forall; intros.

      solve_simple_maps; simpl
      ; unfold permission_heap_good; intros;
        solve_simple_maps; solve_concrete_maps; eauto.

    - unfold user_cipher_queues_ok.
      rewrite Forall_natmap_forall; intros.
      focus_user
      ; simpl in *; econstructor; eauto.

    - unfold honest_nonces_ok, honest_user_nonces_ok, honest_nonces_ok
      ; repeat simple apply conj
      ; intros
      ; clean_map_lookups
      ; intros
      ; focus_user
      ; try contradiction; try discriminate; simpl;
        repeat (apply conj); intros; clean_map_lookups; eauto.

    - unfold honest_users_only_honest_keys; intros.
      focus_user;
        subst;
        simpl in *;
        clean_map_lookups;
        unfold mkrUsr; simpl;
        rewrite !findUserKeys_add_reduce, findUserKeys_empty_is_empty;
        eauto;
        simpl in *;
        solve_concrete_perm_merges;
        solve_concrete_maps;
        solve_simple_maps;
        eauto.

  Qed.

End SimpleEncProtocolSecure.


(** Proof the causal memory implementation w.r.t. modular specification. *)
From iris.algebra Require Import agree auth excl gmap.
From iris.base_logic Require Import invariants.

From iris.base_logic Require Export gen_heap.
From iris.proofmode Require Import tactics.
From aneris.aneris_lang Require Import
     lang network tactics proofmode lifting.
From aneris.prelude Require Import misc.
From aneris.aneris_lang.lib Require Import list_proof map_proof lock_proof network_util_proof inject.
From aneris.aneris_lang.program_logic Require Import lightweight_atomic.
From aneris.aneris_lang.lib.vector_clock Require Import vector_clock_proof.
From aneris.aneris_lang.lib.serialization Require Import serialization_proof.
From aneris.examples.rcb Require Import rcb_code.
From aneris.examples.rcb.spec Require Import base.
From aneris.examples.rcb.model Require Import
     model_lst model_gst model_update_system model_update_lst model_update_gst.
From aneris.examples.rcb.resources Require Import
     base resources_global resources_lhst resources_local_inv resources_global_inv.

Section proof.
  Context `{!anerisG Mdl Σ, !RCB_params, !internal_RCBG Σ}.
  Context (γGauth γGsnap : gname) (γLs : list gname).

  Lemma wp_is_causally_next n (vt : val) (t : vector_clock) (i : nat) :
    {{{ ⌜is_vc vt t⌝ ∗ ⌜length t = length RCB_addresses⌝ }}}
      is_causally_next vt #i @[n]
    {{{(f : val), RET f;
       ∀ (w : global_event),
         {{{ True }}}
           f ($ w) @[n]
         {{{(b : bool), RET #b;
            if b then
              ⌜w.(ge_orig) ≠ i ∧
              length w.(ge_time) = length t ∧
              w.(ge_time) !! w.(ge_orig) =
              Some (S (default 0 (t !! w.(ge_orig)))) ∧
              (∀ j, j < length RCB_addresses → j ≠ w.(ge_orig) →
                    default 0 (w.(ge_time) !! j) <= default 0 (t !! j))⌝
            else True
         }}}
    }}}.
  Proof.
    iIntros (Φ) "[Ht Htlen] HΦ".
    iDestruct "Ht" as %Ht.
    iDestruct "Htlen" as %Htlen.
    rewrite /is_causally_next.
    wp_pures.
    wp_apply wp_list_length; first done.
    iIntros (k Hk).
    wp_pures.
    iApply "HΦ".
    clear Φ.
    iIntros (w vw Φ) "!# HΦ".
    wp_pures.
    destruct (decide (i = w.(ge_orig))) as [->|Hioe].
    { rewrite bool_decide_eq_true_2; last lia.
      wp_pures.
      iApply "HΦ"; done. }
    rewrite bool_decide_eq_false_2; last lia.
    wp_pures.
    destruct (decide (w.(ge_orig) < length RCB_addresses)) as [Hlt|]; last first.
    { rewrite bool_decide_eq_false_2; last lia.
      wp_pures.
      iApply "HΦ"; done. }
    rewrite bool_decide_eq_true_2; last lia.
    wp_pures.
    wp_apply (wp_vect_applicable _ _ _ w.(ge_time) t with "[]");
      [by iSplit; iPureIntro; first apply vector_clock_to_val_is_vc|].
    iIntros (b) "Hb".
    iApply ("HΦ" with "[Hb]").
    destruct b; last done.
    iDestruct "Hb" as %(Hb1 & Hb2 & Hb3).
    iPureIntro.
    split_and!; [lia|lia| |].
    - destruct (lookup_lt_is_Some_2 w.(ge_time) w.(ge_orig))
        as [wto Hwto]; first lia.
      destruct (lookup_lt_is_Some_2 t w.(ge_orig))
        as [two Htwo]; first lia.
      rewrite Hwto Htwo in Hb2.
      inversion Hb2 as [? ? ->|]; simplify_eq; simpl.
      rewrite Htwo Hwto /=.
      f_equal; lia.
    - intros j Hj1 Hj2.
      destruct (lookup_lt_is_Some_2 w.(ge_time) j) as [wj Hwj]; first lia.
      destruct (lookup_lt_is_Some_2 t j) as [tj Htj]; first lia.
      rewrite Htj Hwj /=.
      assert (ge_orig w ≠ j) as Hj2' by done.
      specialize (Hb3 j wj tj Hj2' Hwj Htj).
      eauto with lia.
  Qed.

  Definition internal_deliver_spec (deliver_fn : val) (i : nat) (z : socket_address) : iProp Σ :=
         ⌜RCB_addresses !! i = Some z⌝ -∗
         <<< ∀∀ (s : gset local_event), lhst_user γLs i s >>>
           deliver_fn #() @[ip_of_address z] ↑RCB_InvName
           <<<▷ ∃∃ s' vo, RET vo;
                         lhst_user γLs i s' ∗
                         ((⌜s' = s⌝ ∗ ⌜vo = NONEV⌝) ∨
                          (∃ a ,
                           ⌜s' = s ∪ {[ a ]}⌝ ∗
                           ⌜a ∉ s⌝ ∗
                           ⌜a ∈ compute_maximals le_time s'⌝ ∗
                           ⌜not (a.(le_orig) = i)⌝ ∗
                           own_global_snap γGsnap {[ erase a ]} ∗
                           ∃ v, ⌜vo = SOMEV v⌝ ∗ ⌜is_lev v a⌝)) >>>.

  Lemma internal_deliver_spec_holds
        (i : nat) (z : socket_address) (T SeenLoc IQ OQ : loc) (lk : val)
        (γlk : gname) :
    {{{ Global_Inv γGauth γGsnap γLs ∗
        local_invariant γGsnap γLs i T SeenLoc IQ OQ lk γlk z ∗
        ⌜ip_of_address <$> RCB_addresses !! i = Some (ip_of_address z)⌝ }}}
      deliver #T lk #IQ #i @[ip_of_address z]
    {{{ (fv : val), RET fv;
        internal_deliver_spec fv i z
    }}}.
  Proof.
    rewrite /deliver /local_invariant.
    remember (ip_of_address z) as ip.
    iIntros (Φ) "(#Ginv & #Linv & %Hip) HΦ".
    wp_pures.
    iApply "HΦ"; clear Φ.
    iIntros "#Haddr". iIntros "!>" (Φ) "Hvs".
    wp_pures.
    rewrite Heqip.
    wp_apply acquire_spec; first iExact "Linv".
    iIntros (?) "(-> & Hlk & Hli)".
    rewrite /local_inv_def.
    iDestruct "Hli" as (vt vseen viq voq t seenv liq loq s' ip')
     "(%Hip'& HT & %Hvc & Hseen & %Hseen_vc & %Hseen_len & HIQ & HOQ & Hlhst & %Hlstv)".
    assert (ip = ip') as ->.
    { rewrite Hip in Hip'. inversion Hip'; done. }
    clear Hip'.
    subst.
    iDestruct "HIQ" as "(HIQ & %Hviq & Hliq)".
    wp_pures.
    wp_load.
    wp_load.
    wp_apply wp_is_causally_next.
    { iSplit; first done.
      rewrite (RCBM_LSTV_time_length Hlstv); done. }
    iIntros (f) "#Hf /=".
    wp_apply (wp_find_remove); [|done|].
    { iIntros (? ? _) "!> HΦ".
      iApply "Hf"; first done.
      iNext. iIntros (b) "Hb".
      iApply "HΦ".
      destruct b; first iExact "Hb"; done. }
    iIntros (v) "[->|Hv]".
    { wp_pures.
      wp_apply (release_spec with "[$Hlk HT Hseen HOQ HIQ Hliq Hlhst]").
      { eauto 20 with iFrame. }
      iIntros (v ->).
      wp_bind (Rec _ _ _).
      iApply (aneris_wp_atomic _ _ (↑RCB_InvName)).
      iMod "Hvs". iModIntro.
      wp_pure _.
      iDestruct "Hvs" as (x) "[Hu Hupd]".
      iMod ("Hupd" with "[$Hu]") as "HΦ".
      { iLeft. eauto. }
      iModIntro. wp_pures.
      iApply "HΦ". }
    iDestruct "Hv" as (a lv' l1 l2) "((->&->&%Hlv')&%Honi&%Hwtlen&%Hwtoa&%Hwtnoa)".
    wp_pures.
    wp_store.
    wp_load.
    assert (a.(ge_orig) < length t).
    { apply lookup_lt_Some in Hwtoa; lia. }
    destruct (lookup_lt_is_Some_2 t a.(ge_orig)); first done.
    wp_apply wp_vect_inc; [|done|done|]; first lia.
    iIntros (vt' Hvt'); simpl.
    wp_store.
    iDestruct "Hliq" as "(Hliq1 & (%Hne & #Ha) & Hliq2)".
    iCombine "Hliq1" "Hliq2" as "Hliq".
    rewrite -big_sepL_app.
    set (e := LocalEvent a.(ge_payload)
                         a.(ge_time)
                         a.(ge_orig)
                             (S (length (elements s')))).
    assert (a = erase e) as Herase.
    { destruct a; done. }
    pose proof (RCBM_LSTV_at Hlstv).
    pose proof (RCBM_LSTV_time_length Hlstv) as Htlen;
      rewrite /= /RCBM_lst_time_length in Htlen.
    assert (e ∉ s') as Hes'.
    { apply (RCBM_system_local_event_fresh_lhst e i t); eauto with lia. }
    wp_bind (InjR _).
    do 2 wp_pure _.
    iApply (aneris_wp_atomic _ _ (↑RCB_InvName)).
    iMod "Hvs". iModIntro. wp_pures.
    iDestruct "Hvs" as (s) "[Hu Himpl]".
    iDestruct (lhst_user_lock_agree with "Hu Hlhst") as %->.
    iInv RCB_InvName as
        (G Ss) "(>% & >Hgsys & >Hl & >%Hvl)" "Hclos_inv".
    iDestruct (own_global_snap_lookup with "Hgsys Ha") as "%Hina".
    iDestruct (lhst_user_lookup with "Hl Hu") as %His'.
    iDestruct (lhst_lock_lookup with "Hl Hlhst") as %His''.
    assert (e ∈ compute_maximals le_time (s' ∪ {[ e ]})) as Hemax.
    { remember {| Lst_time := t; Lst_hst := s' |} as lst.
      replace s' with lst.(Lst_hst); [ | by rewrite Heqlst ].
      eapply RCBM_Lst_valid_compute_maximals; [done |].
      rewrite /e; simpl.
      replace (Lst_time lst) with t; [eauto | ].
      rewrite Heqlst; done. }
    assert (RCBM_Lst_valid i
                 {| Lst_time := incr_time t (ge_orig a);
                    Lst_hst := s' ∪ {[e]} |}).
    { apply (RCBM_lst_update_apply i {| Lst_time := t; Lst_hst := s' |} (erase e));
        rewrite /e; [done | done |].
      split_and!; simpl; auto with lia. }
    assert (RCBM_Gst_valid {| Gst_ghst := G; Gst_hst := <[i := s' ∪ {[e]} ]>Ss |}).
    { rewrite /e.
      apply (RCBM_system_apply_update_gst
               i {| Gst_ghst := G |} {| Lst_time := t; Lst_hst := s' |} a );
        simpl; eauto with set_solver.
      split_and!; simpl; eauto with lia. }
    iMod (lhst_update _ _ _ _ e with "Hu Hlhst Hl") as "(Hu & Hlhst & Hl)".
    iMod ("Hclos_inv" with "[Hgsys Hl]") as "_".
    { eauto 15 with iFrame. }
    rewrite Herase.
    iMod ("Himpl" with "[$Hu]") as "HΦ".
    { iRight. iExists e.
      iFrame "#".
      repeat iSplit; eauto.
      iExists $(erase e).
      iSplit; eauto.
      iPureIntro.
      simpl.
      eexists _, _, _.
      eauto using vector_clock_to_val_is_vc. }
    iModIntro. wp_pures.
    wp_apply (release_spec with "[$Hlk HT Hseen HOQ HIQ Hliq Hlhst]").
    { iFrame "Linv".
      iExists _, _, _, _, _, _, _, _.
      iExists _, _.
      iSplitL ""; [by iPureIntro |].
      iSplitL "HT"; [iFrame |].
      iSplitL ""; [by iPureIntro|].
      iFrame; iFrame "#".
      repeat iSplit; eauto.
      iPureIntro.
      rewrite Hseen_len.
      symmetry.
      apply incr_time_length. }
    iIntros (? ->).
    wp_seq.
    iApply "HΦ".
  Qed.

End proof.


Require Import UNIVERSE.
(* Require Import Events. *)
(* Require Import ValuesC. *)
(* Require Import AST. *)
(* Require Import Memory. *)
(* Require Import Globalenvs. *)
Require Import Smallstep.
Require Import CoqlibC.
(* Require Import Skeleton. *)
(* Require Import Integers. *)
(* Require Import ASTC. *)
Require Import LinkingC.
(* Require Import Maps. *)

Require Import SimMem.
Require Import System.
Require Import ModSem.

Set Implicit Arguments.

Module SimSymb.

  Inductive sim_skenv_weak (sim_val: val -> val -> Prop) (skenv_src skenv_tgt: SkEnv.t): Prop :=
  | sim_skenv_weak_intro
      (FUNCFSIM: forall fptr_src fptr_tgt def_src
          (SIMFPTR: sim_val fptr_src fptr_tgt)
          (FUNCSRC: (Genv.find_funct skenv_src) fptr_src = Some def_src),
          exists def_tgt, <<FUNCSRC: (Genv.find_funct skenv_tgt) fptr_tgt = Some def_tgt>> /\ <<SIM: def_src = def_tgt>>)
      (* (FUNCBSIM: forall fptr_src fptr_tgt def_tgt *)
      (*     (SIMFPTR: sim_val fptr_src fptr_tgt) *)
      (*     (FUNCTGT: (Genv.find_funct skenv_tgt) fptr_tgt = Some def_tgt) *)
      (*     (SAFESRC: fptr_src <> Vundef) *)
      (*   , *)
      (*     exists def_src, (<<FUNCSRC: (Genv.find_funct skenv_src) fptr_src = Some def_src>>) /\ (<<SIM: def_src = def_tgt>>)) *)
  .

  Class class (SM: SimMem.class) :=
    { t: Type;
      le: t -> t -> Prop;
      src: t -> Sk.t;
      tgt: t -> Sk.t;

      le_PreOrder :> PreOrder le;

      wf: t -> Prop;
      wf_preserves_wf: forall ss0
          (SIMSK: wf ss0)
          (WFSRC: Sk.wf ss0.(src)),
          <<WFTGT: Sk.wf ss0.(tgt)>>;

      wf_link: forall ss0 ss1 sk_src
          (SIMSK: wf ss0)
          (SIMSK: wf ss1)
          (LINKSRC: link ss0.(src) ss1.(src) = Some sk_src)
          (WFSRC0: Sk.wf ss0.(src))
          (WFSRC1: Sk.wf ss1.(src))
          (WFTGT0: Sk.wf ss0.(tgt))
          (WFTGT1: Sk.wf ss1.(tgt)),
          exists ss sk_tgt,
            <<LINKTGT: link ss0.(tgt) ss1.(tgt) = Some sk_tgt>> /\
            <<SKSRC: ss.(src) = sk_src>> /\
            <<SKTGT: ss.(tgt) = sk_tgt>> /\
            <<LE0: le ss0 ss>> /\
            <<LE1: le ss1 ss>> /\
            <<SIMSK: wf ss>>;

      sim_skenv: SimMem.t -> t -> SkEnv.t -> SkEnv.t -> Prop;

      sim_skenv_public_symbols: forall sm0 ss0 skenv_src skenv_tgt
          (SIMSKE: sim_skenv sm0 ss0 skenv_src skenv_tgt),
          (Genv.public_symbol skenv_src) = (Genv.public_symbol skenv_tgt);

      wf_load_sim_skenv: forall ss skenv_src skenv_tgt m_src
          (SIMSK: wf ss)
          (LOADSRC: (Sk.load_skenv ss.(src)) = skenv_src)
          (LOADTGT: (Sk.load_skenv ss.(tgt)) = skenv_tgt)
          (LOADMEMSRC: (Sk.load_mem ss.(src)) = Some m_src),
          exists m_tgt sm,
            (<<LOADMEMTGT: (Sk.load_mem ss.(tgt)) = Some m_tgt>>) /\
            (<<SIMSKENV: sim_skenv sm ss skenv_src skenv_tgt>>) /\
            (<<MEMSRC: sm.(SimMem.src) = m_src>>) /\
            (<<MEMTGT: sm.(SimMem.tgt) = m_tgt>>) /\
            (<<MWF: sm.(SimMem.wf)>>) /\
            (<<MAINSIM: SimMem.sim_val sm (Genv.symbol_address skenv_src (prog_main ss.(src)))
                                       (Genv.symbol_address skenv_tgt (prog_main ss.(tgt)))>>);

      mlepriv_preserves_sim_skenv: forall sm0 sm1 ss skenv_src skenv_tgt
          (MLE: SimMem.lepriv sm0 sm1)
          (SIMSKENV: sim_skenv sm0 ss skenv_src skenv_tgt),
          <<SIMSKENV: sim_skenv sm1 ss skenv_src skenv_tgt>>;

      sim_skenv_monotone: forall
          sm ss_link skenv_link_src skenv_link_tgt
          ss skenv_src skenv_tgt
          (WFSRC: SkEnv.wf skenv_link_src)
          (WFTGT: SkEnv.wf skenv_link_tgt)
          (SIMSKENV: sim_skenv sm ss_link skenv_link_src skenv_link_tgt)
          (SIMSK: wf ss)
          (LE: le ss ss_link)
          (INCLSRC: SkEnv.includes skenv_link_src ss.(src))
          (INCLTGT: SkEnv.includes skenv_link_tgt ss.(tgt))
          (LESRC: SkEnv.project skenv_link_src ss.(src) = skenv_src)
          (LETGT: SkEnv.project skenv_link_tgt ss.(tgt) = skenv_tgt),
          <<SIMSKENV: sim_skenv sm ss skenv_src skenv_tgt>>;

      sim_skenv_sim_skenv_weak: forall sm ss,
              sim_skenv sm ss <2= sim_skenv_weak sm.(SimMem.sim_val);

      system_sim_skenv: forall sm ss skenv_src skenv_tgt
          (SIMSKENV: sim_skenv sm ss skenv_src skenv_tgt),
          <<SIMSKENV: sim_skenv sm ss (System.skenv skenv_src) (System.skenv skenv_tgt)>>;
      system_axiom: forall
          sm0 ss_sys skenv_sys_src skenv_sys_tgt
          args_src args_tgt tr retv_src ef
          (SIMSKENV: sim_skenv sm0 ss_sys skenv_sys_src skenv_sys_tgt)
          (MWF: SimMem.wf sm0)
          (CSTYLE: Args.is_cstyle args_src)
          (CSTYLE: Retv.is_cstyle retv_src)
          (ARGS: SimMem.sim_args args_src args_tgt sm0)
          (SYSSRC: external_call ef skenv_sys_src (Args.vs (args_src)) (Args.m (args_src))
                                 tr
                                 (Retv.v (retv_src)) (Retv.m (retv_src))),
          exists sm1 retv_tgt,
            (<<SYSTGT: external_call ef skenv_sys_tgt (Args.vs (args_tgt)) (Args.m (args_tgt))
                                     tr
                                     (Retv.v (retv_tgt)) (Retv.m (retv_tgt))>>)
            /\ (<<RETV: SimMem.sim_retv retv_src retv_tgt sm1>>)
            /\ (<<MLE0: SimMem.le sm0 sm1>>)
            /\ (<<MWF: SimMem.wf sm1>>);
    }.

  Lemma mle_preserves_sim_skenv: forall
      `{SM: SimMem.class} `{SS: @class SM}
      sm0 sm1 ss skenv_src skenv_tgt
      (MLE: SimMem.le sm0 sm1)
      (SIMSKENV: sim_skenv sm0 ss skenv_src skenv_tgt),
      <<SIMSKENV: sim_skenv sm1 ss skenv_src skenv_tgt>>.
  Proof. ii. eapply mlepriv_preserves_sim_skenv; et. Qed.

  Lemma mfuture_preserves_sim_skenv
        `{SM: SimMem.class} `{SS: @class SM}
        sm0 sm1 ss skenv_src skenv_tgt
        (MFUTURE: SimMem.future sm0 sm1)
        (SIMSKENV: sim_skenv sm0 ss skenv_src skenv_tgt):
      <<SIMSKENV: sim_skenv sm1 ss skenv_src skenv_tgt>>.
  Proof.
    induction MFUTURE; ss. des.
    - eapply IHMFUTURE; eauto. eapply mlepriv_preserves_sim_skenv; eauto.
    - eapply IHMFUTURE; eauto. eapply mle_preserves_sim_skenv; eauto.
  Qed.

End SimSymb.


Require Import Ascii Bool String List.
Require Import Lib.CommonTactics Lib.Indexer Lib.ilist Lib.Word Lib.Struct.
Require Import Kami.Syntax Kami.Notations.
Require Import Kami.Semantics Kami.Specialize Kami.Duplicate.
Require Import Kami.Inline Kami.InlineFacts.
Require Import Kami.Wf Kami.Tactics.
Require Import Ex.MemTypes Ex.SC.

Set Implicit Arguments.

Section Inlined.
  Variables (addrSize maddrSize iaddrSize fifoSize instBytes dataBytes rfIdx: nat)
            (Hdb: {pdb & dataBytes = S pdb}).

  Variables (fetch: AbsFetch addrSize iaddrSize instBytes dataBytes)
            (dec: AbsDec addrSize instBytes dataBytes rfIdx)
            (exec: AbsExec addrSize instBytes dataBytes rfIdx)
            (ammio: AbsMMIO addrSize).

  Variable (procInit: ProcInit addrSize dataBytes rfIdx)
           (memInit: MemInit maddrSize).

  Definition scmm: Modules := scmm Hdb fetch dec exec ammio procInit memInit.
  #[local] Hint Unfold scmm: ModuleDefs. (* for kinline_compute *)

  Definition scmmInl: sigT (fun m: Modules => scmm <<== m).
  Proof.
    kinline_refine scmm.
  Defined.

End Inlined.


From cap_machine.binary_model.ftlr_binary Require Export Mov_binary Jmp_binary Jnz_binary Load_binary Store_binary AddSubLt_binary Lea_binary Restrict_binary Subseg_binary IsPtr_binary Get_binary StoreU_binary LoadU_binary PromoteU_binary.
From iris.proofmode Require Import tactics.
From iris.program_logic Require Import weakestpre adequacy lifting.
From stdpp Require Import base.
From cap_machine.binary_model Require Export logrel_binary region_invariants_binary.

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

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

  Notation D := (WORLD -n> (prodO (leibnizO Word) (leibnizO Word)) -n> iPropO Σ).
  Notation R := (WORLD -n> (prodO (leibnizO Reg) (leibnizO Reg)) -n> iPropO Σ).
  Implicit Types v : (prodO (leibnizO Word) (leibnizO Word)).
  Implicit Types interp : (D).

  Lemma extract_r_ex r (reg : RegName) :
    (∃ w, r !! reg = Some w) →
    ⊢ (([∗ map] r0↦w ∈ r, r0 ↦ᵣ w) → ∃ w, reg ↦ᵣ w).
  Proof.
    intros [w Hw].
    iIntros "Hmap". iExists w.
    iApply (big_sepM_lookup (λ reg' i, reg' ↦ᵣ i)%I r reg w); eauto.
  Qed.

  Lemma extract_r_ex_spec r (reg : RegName) :
    (∃ w, r !! reg = Some w) →
    ⊢ (([∗ map] r0↦w ∈ r, r0 ↣ᵣ w) → ∃ w, reg ↣ᵣ w).
  Proof.
    intros [w Hw].
    iIntros "Hmap". iExists w.
    iApply (big_sepM_lookup (λ reg' i, reg' ↣ᵣ i)%I r reg w); eauto.
  Qed.

  Lemma extract_r reg (r : RegName) w :
    reg !! r = Some w →
    ⊢ (([∗ map] r0↦w ∈ reg, r0 ↦ᵣ w) →
      (r ↦ᵣ w ∗ (∀ x', r ↦ᵣ x' -∗ [∗ map] k↦y ∈ <[r := x']> reg, k ↦ᵣ y))).
  Proof.
    iIntros (Hw) "Hmap".
    iDestruct (big_sepM_lookup_acc (λ (r : RegName) i, r ↦ᵣ i)%I reg r w) as "Hr"; eauto.
    iSpecialize ("Hr" with "[Hmap]"); eauto. iDestruct "Hr" as "[Hw Hmap]".
    iDestruct (big_sepM_insert_acc (λ (r : RegName) i, r ↦ᵣ i)%I reg r w) as "Hupdate"; eauto.
    iSpecialize ("Hmap" with "[Hw]"); eauto.
    iSpecialize ("Hupdate" with "[Hmap]"); eauto.
  Qed.

  Lemma extract_r_spec reg (r : RegName) w :
    reg !! r = Some w →
    ⊢ (([∗ map] r0↦w ∈ reg, r0 ↣ᵣ w) →
      (r ↣ᵣ w ∗ (∀ x', r ↣ᵣ x' -∗ [∗ map] k↦y ∈ <[r := x']> reg, k ↣ᵣ y))).
  Proof.
    iIntros (Hw) "Hmap".
    iDestruct (big_sepM_lookup_acc (λ (r : RegName) i, r ↣ᵣ i)%I reg r w) as "Hr"; eauto.
    iSpecialize ("Hr" with "[Hmap]"); eauto. iDestruct "Hr" as "[Hw Hmap]".
    iDestruct (big_sepM_insert_acc (λ (r : RegName) i, r ↣ᵣ i)%I reg r w) as "Hupdate"; eauto.
    iSpecialize ("Hmap" with "[Hw]"); eauto.
    iSpecialize ("Hupdate" with "[Hmap]"); eauto.
  Qed.

  Instance addr_inhabited: Inhabited Addr := populate (A 0%Z eq_refl eq_refl).

  Global Instance ifcond_pers : Persistent (if writeAllowed p then read_write_cond a interp else ∃ P : D, ⌜∀ Wv : WORLD * (prodO (leibnizO Word) (leibnizO Word)), Persistent (P Wv.1 Wv.2)⌝ ∧ read_cond a P interp)%I.
  Proof. intros. destruct (writeAllowed p);apply _. Qed.
  Global Instance ifwcond_pers : Persistent (if decide (writeAllowed_in_r_a (<[PC:=inr (p, g, b, e, a)]> r) a) then wcond P interp else emp)%I.
  Proof. intros. case_decide;apply _. Qed.
  Global Instance if_pers (P: D) : Persistent (if decide (ρ = Monotemporary)
                                               then future_pub_a_mono a (λ Wv, P Wv.1 Wv.2) w1 w2
                                               else future_priv_mono (λ Wv, P Wv.1 Wv.2) w1 w2).
  Proof. intros. case_decide;apply _. Qed.

  Theorem fundamental_binary W r p g b e (a : Addr) :
    ⊢ ((⌜p = RX⌝ ∨ ⌜p = RWX⌝ ∨ ⌜p = RWLX ∧ g = Directed⌝) →
       spec_ctx →
       region_conditions W p g b e →
       interp_expression r W (inr ((p,g),b,e,a),inr ((p,g),b,e,a))).
  Proof.
    iIntros (Hp) "#Hspec #Hinv /=".
    iIntros "[Hregs [Hmreg [Hsreg [Hr [Hsts [Hown Hj]]]]]]".
    iSplit; eauto; simpl.
    iRevert (Hp) "Hinv".
    iLöb as "IH" forall (W r p g b e a).
    iAssert (⌜∀ w, <[PC:=w]> r.1 = <[PC:=w]> r.2⌝)%I as %Heqregs.
    { iIntros (w). iDestruct (interp_reg_eq _ _ _ w with "Hregs") as %Heqregs. auto. }
    iDestruct "Hregs" as "[Hfull Hreg]".
    iIntros (Hp) "#Hinv".
    rewrite -Heqregs.
    iDestruct "Hfull" as "%". iDestruct "Hreg" as "#Hreg".
    iApply (wp_bind (fill [SeqCtx])).
    destruct (decide (isCorrectPC (inr ((p,g),b,e,a)))).
    - (* Correct PC *)
      assert ((b <= a)%a ∧ (a < e)%a) as Hbae.
      { eapply in_range_is_correctPC; eauto.
        unfold le_addr; lia. }
      iDestruct (extract_from_region_inv_regs a a with "[Hmreg] Hinv") as (P Hpers) "(#Hinva & #Hrcond & #Hwcond)";auto;[|iFrame "# %"|].
      { destruct Hp as [-> | [-> | [? ->] ] ];auto. subst;auto. }
      iDestruct (extract_from_region_inv _ _ a with "Hinv") as "[_ Hstate_a]";auto.
      iDestruct "Hstate_a" as %Hstate_a.
      assert (∃ (ρ : region_type), (std W) !! a = Some ρ ∧ ρ ≠ Revoked
                                   ∧ (∀ g, ρ ≠ Monostatic g) ∧ (∀ w, ρ ≠ Uninitialized w))
        as [ρ [Hρ [Hne_rev [Hne_mono Hne_uninit] ] ] ].
      { destruct (machine_base.pwl p); [rewrite Hstate_a;eexists;eauto|].
        destruct g; [rewrite Hstate_a|rewrite Hstate_a|destruct Hstate_a as [-> | ->] ];eexists;eauto. }
      iDestruct (region_open W a with "[$Hinva $Hr $Hsts]")
        as (w1 w2) "(Hr & Hsts & Hstate & Ha & Ha' & #Hmono & Hw) /=";[|apply Hρ|..].
      { destruct ρ;auto;[done|by specialize (Hne_mono g0)|by specialize (Hne_uninit p0)]. }
      iDestruct ((big_sepM_delete _ _ PC) with "Hmreg") as "[HPC Hmap]";
        first apply (lookup_insert _ _ (inr (p, g, b, e, a))).
      iDestruct ((big_sepM_delete _ _ PC) with "Hsreg") as "[HsPC Hsmap]";
        first apply (lookup_insert _ _ (inr (p, g, b, e, a))).
      iAssert (▷ ⌜w1 = w2⌝)%I as "#>Heq".
      { iNext. iApply (interp_eq W). iDestruct "Hrcond" as "[Hrcond _]". iApply "Hrcond". iFrame. }
      iDestruct "Heq" as %<-.
      destruct (decodeInstrW w1) eqn:Hi. (* proof by cases on each instruction *)
      + (* Jmp *)
        iApply (jmp_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* Jnz *)
        iApply (jnz_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* Mov *)
        iApply (mov_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* Load *)
        iApply (load_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* Store *)
        iApply (store_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* Lt *)
        iApply (add_sub_lt_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* Add *)
        iApply (add_sub_lt_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* Sub *)
        iApply (add_sub_lt_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* Lea *)
        iApply (lea_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* Restrict *)
        iApply (restrict_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* Subseg *)
        iApply (subseg_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* IsPtr *)
        iApply (isptr_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* GetL *)
        iApply (get_case _ _ _ _ _ _ _ _ _ _ _ (GetL _ _) with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* GetP *)
        iApply (get_case _ _ _ _ _ _ _ _ _ _ _ (GetP _ _) with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* GetB *)
        iApply (get_case _ _ _ _ _ _ _ _ _ _ _ (GetB _ _) with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* GetE *)
        iApply (get_case _ _ _ _ _ _ _ _ _ _ _ (GetE _ _) with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* GetA *)
        iApply (get_case _ _ _ _ _ _ _ _ _ _ _ (GetA _ _) with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* Fail *)
        iApply (wp_fail with "[HPC Ha]"); eauto; iFrame.
        iNext. iIntros "[HPC Ha] /=".
        iApply wp_pure_step_later; auto.
        iApply wp_value.
        iNext. iIntros (Hcontr); inversion Hcontr.
      + (* Halt *)
        iApply (wp_halt with "[HPC Ha]"); eauto; iFrame.
        iNext. iIntros "[HPC Ha] /=".
        iMod (step_halt _ [SeqCtx] with "[$HsPC $Ha' $Hj $Hspec]") as "(Hj & HsPC & Ha')";eauto.
        iMod (do_step_pure _ [] with "[$Hspec $Hj]") as "Hj /=";auto.
        iDestruct (region_close _ _ _ _ _ ρ with "[$Hr $Ha $Ha' $Hstate $Hmono Hw]") as "Hr";[auto|iFrame "#"; auto|].
        { destruct ρ;auto;[|specialize (Hne_mono g0)|specialize (Hne_uninit p0)]; contradiction. }
        iApply wp_pure_step_later; auto.
        iApply wp_value.
        iDestruct ((big_sepM_delete _ _ PC) with "[HPC Hmap]") as "Hmap /=".
        apply lookup_insert. rewrite delete_insert_delete. iFrame.
        iDestruct ((big_sepM_delete _ _ PC) with "[HsPC Hsmap]") as "Hsmap /=".
        apply lookup_insert. rewrite delete_insert_delete. iFrame.
        rewrite insert_insert. iNext. iIntros (_).
        iExists (<[PC:=inr (p, g, b, e, a)]> r.1,<[PC:=inr (p, g, b, e, a)]> r.1),W. iFrame.
        iAssert (⌜related_sts_priv_world W W⌝)%I as "#Hrefl".
        { iPureIntro. apply related_sts_priv_refl_world. }
        iFrame "#".
        iPureIntro. intros r0. destruct (reg_eq_dec PC r0).
        * subst r0; rewrite lookup_insert; eauto.
        * rewrite lookup_insert_ne//. destruct H with r0;eauto.
      + (* LoadU *)
      iApply (loadU_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]"); try iAssumption; eauto.
      + (* StoreU *)
        iApply (storeU_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]"); try iAssumption; eauto.
      + (* PromoteU *)
        iApply (promoteU_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]"); try iAssumption; eauto.
   - (* Not correct PC *)
     iDestruct ((big_sepM_delete _ _ PC) with "Hmreg") as "[HPC Hmap]";
       first apply (lookup_insert _ _ (inr (p, g, b, e, a))).
     iApply (wp_notCorrectPC with "HPC"); eauto.
     iNext. iIntros "HPC /=".
     iApply wp_pure_step_later; auto.
     iApply wp_value.
     iNext. iIntros (Hcontr); inversion Hcontr.
     Unshelve. apply _.
  Qed.

  (* the execute condition can be regained using the FTLR on read allowed permissions *)
  Lemma interp_exec_cond_binary W p g b e a :
    p = RX ∨ p = RWX ∨ p = RWLX ->
    spec_ctx -∗
    interp W (inr (p,g,b,e,a),inr (p,g,b,e,a)) -∗ exec_cond W b e g p b e g p interp.
  Proof.
    iIntros (Hra) "#Hspec #Hw".
    iIntros (a0 r W' Hin) "#Hfuture". iModIntro.
    destruct g.
    + iDestruct (interp_monotone_nm with "Hfuture [] Hw") as "Hw'";[auto|].
      iDestruct (readAllowed_implies_region_conditions with "Hw'") as "Hread_cond";[destruct Hra as [-> | [-> | ->] ];auto|].
      iApply fundamental_binary;[|iFrame "#"|eauto]. destruct Hra as [-> | [-> | ->] ];auto.
      rewrite fixpoint_interp1_eq /=. done.
    + iDestruct (interp_monotone_nm with "Hfuture [] Hw") as "Hw'";[auto|].
      iDestruct (readAllowed_implies_region_conditions with "Hw'") as "Hread_cond";[destruct Hra as [-> | [-> | ->] ];auto|].
      iApply fundamental_binary;[|iFrame "#"|eauto]. destruct Hra as [-> | [-> | ->] ];auto.
      rewrite fixpoint_interp1_eq /=. done.
    + iDestruct (interp_monotone_a with "[Hfuture] Hw") as "Hw'";[auto|].
      2: iDestruct (readAllowed_implies_region_conditions with "Hw'") as "Hread_cond";[destruct Hra as [-> | [-> | ->] ];auto|].
      2: iApply fundamental_binary;[|iFrame "#"|eauto];destruct Hra as [-> | [-> | ->] ];auto.
      simpl. destruct Hra as [-> | [-> | ->] ];auto.
  Qed.

  Lemma fundamental_binary_from_interp_correctPC W p g b e a r (w:Word) :
    p = RX ∨ p = RWX ∨ (p = RWLX ∧ g = Directed) →
    ⊢ spec_ctx -∗ interp W (inr (p, g, b, e, a),w) -∗
      interp_expression r W (inr (p,g,b,e,a),w).
  Proof.
    iIntros (Hp) "HV Hv". iDestruct (interp_eq with "Hv") as %<-.
    iApply (fundamental_binary with "[] HV"); auto.
    iApply (readAllowed_implies_region_conditions with "Hv").
    destruct Hp as [-> | [-> | [ -> -> ] ] ]; eauto.
  Qed.

  Lemma fundamental_binary_not_correctPC r W p g b e a :
    ⊢ ⌜¬ isCorrectPC (inr ((p,g),b,e,a))⌝ →
    interp_expression r W (inr ((p,g),b,e,a),inr ((p,g),b,e,a)).
  Proof.
    iIntros (Hnvpc). iIntros "(H1 & Hmreg & H3 & H4 & H5)".
    iSplit;auto. rewrite /interp_conf.
    iDestruct ((big_sepM_delete _ _ PC) with "Hmreg") as "[HPC Hmap]";
      first apply (lookup_insert _ _ (inr (p, g, b, e, a))).
    iApply (wp_bind (fill [SeqCtx])).
    iApply (wp_notCorrectPC with "HPC"); eauto.
    iNext. iIntros "HPC /=".
    iApply wp_pure_step_later; auto.
    iApply wp_value.
    iNext. iIntros (Hcontr); inversion Hcontr.
  Qed.

  Corollary fundamental_binary_from_interp r W p g b e a (w : Word) :
    spec_ctx -∗
    interp W (inr ((p,g),b,e,a),w) -∗
    interp_expression r W (inr ((p,g),b,e,a),w).
  Proof.
    iIntros "#Hspec #Hinterp".
    iDestruct (interp_eq with "Hinterp") as %<-.
    destruct (decide (isCorrectPC (inr ((p,g),b,e,a)))).
    - assert (p = RX ∨ p = RWX ∨ p = RWLX) as Hp;[inversion i;auto|].
      iAssert (⌜p = RWLX → g = Directed⌝)%I as %Hmono.
      { iIntros (->). iDestruct (writeLocalAllowed_implies_local with "Hinterp") as %Hmono;[auto|destruct g;auto]. }
      iApply (fundamental_binary_from_interp_correctPC with "Hspec Hinterp").
      destruct Hp as [-> | [-> | ->] ];auto.
    - iApply fundamental_binary_not_correctPC. auto.
  Qed.

  Lemma updatePcPerm_RX w g b e a :
    inr (RX, g, b, e, a) = updatePcPerm w ->
    w = inr (RX, g, b, e, a) ∨ w = inr (E, g, b, e, a).
  Proof.
    intros Hperm.
    destruct w;inversion Hperm.
    destruct c,p,p,p,p;simplify_eq;auto.
  Qed.

  Lemma exec_binary_wp W p g b e a :
    isCorrectPC (inr (p, g, b, e, a)) ->
    exec_cond W b e g p b e g p interp -∗
    ∀ r W', future_world g e W W' → ▷ ((interp_expr interp r) W') (inr (p, g, b, e, a),inr (p, g, b, e, a)).
  Proof.
    iIntros (Hvpc) "Hexec".
    rewrite /exec_cond /enter_cond.
    iIntros (r W'). rewrite /future_world.
    assert (a ∈ₐ[[b,e]])%I as Hin.
    { rewrite /in_range. inversion Hvpc; subst. auto. }
    destruct g.
    - iIntros (Hrelated).
      iSpecialize ("Hexec" $! a r W' Hin Hrelated).
      iFrame.
    - iIntros (Hrelated).
      iSpecialize ("Hexec" $! a r W' Hin Hrelated).
      iFrame.
    - iIntros (Hrelated).
      iSpecialize ("Hexec" $! a r W' Hin Hrelated).
      iFrame.
  Qed.

  (* The following lemma is to assist with a pattern when jumping to unknown valid capablities *)
  Lemma jmp_or_fail_binary_spec W (w w' : Word) φ :
    spec_ctx
    -∗ (interp W (w,w')
    -∗ (if decide (isCorrectPC (updatePcPerm w)) then
          (∃ p g b e a, ⌜w = inr (p,g,b,e,a)⌝
          ∗ □ ∀ r W', future_world g e W W' → ▷ ((interp_expr interp r) W') (updatePcPerm w,updatePcPerm w'))
        else
          φ FailedV ∗ PC ↦ᵣ updatePcPerm w -∗ WP Seq (Instr Executable) {{ φ }} )).
  Proof.
    iIntros "#Hspec #Hw".
    iDestruct (interp_eq with "Hw") as %<-.
    destruct (decide (isCorrectPC (updatePcPerm w))).
    - inversion i.
      destruct w;inversion H. destruct c,p0,p0,p0; inversion H.
      destruct H1 as [-> | [-> | ->] ].
      + destruct p0; simpl in H; simplify_eq.
        * iExists _,_,_,_,_; iSplit;[eauto|]. iModIntro.
          iDestruct (interp_exec_cond_binary with "Hspec Hw") as "Hexec";[auto|].
          iApply exec_binary_wp;auto.
        * iExists _,_,_,_,_; iSplit;[eauto|]. iModIntro.
          rewrite /= fixpoint_interp1_eq /=.
          iDestruct "Hw" as "[_ Hw]".
          iExact "Hw".
      + destruct p0; simpl in H; simplify_eq.
        iExists _,_,_,_,_; iSplit;[eauto|]. iModIntro.
        iDestruct (interp_exec_cond_binary with "Hspec Hw") as "Hexec";[auto|].
        iApply exec_binary_wp;auto.
      + destruct p0; simpl in H; simplify_eq.
        iExists _,_,_,_,_; iSplit;[eauto|]. iModIntro.
        iDestruct (interp_exec_cond_binary with "Hspec Hw") as "Hexec";[auto|].
        iApply exec_binary_wp;auto.
    - iIntros "[Hfailed HPC]".
      iApply (wp_bind (fill [SeqCtx])).
      iApply (wp_notCorrectPC with "HPC");eauto.
      iNext. iIntros "_". iApply wp_pure_step_later;auto.
      iNext. iApply wp_value. iFrame.
  Qed.

End fundamental.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import RunComplete.Spec.
Require Import RunAux.Spec.
Require Import RunLoop.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition smc_rec_run_spec (rec_addr: Z64) (rec_run_addr: Z64) (adt: RData) : option (RData * Z64) :=
    match rec_addr, rec_run_addr with
    | VZ64 _rec_addr, VZ64 _rec_run_addr =>
      rely is_int64 _rec_run_addr;
      when'' _g_rec_run_base, _g_rec_run_ofst == find_granule_spec (VZ64 _rec_run_addr) adt;
      rely is_int _g_rec_run_ofst;
      when _t'8 == is_null_spec (_g_rec_run_base, _g_rec_run_ofst) adt;
      rely is_int _t'8;
      if (_t'8 =? 1) then
        Some (adt, (VZ64 1))
      else
        rely is_int64 _rec_addr;
        when'' _g_rec_base, _g_rec_ofst, adt == find_lock_unused_granule_spec (VZ64 _rec_addr) (VZ64 3) adt;
        rely is_int _g_rec_ofst;
        when _t'7 == is_null_spec (_g_rec_base, _g_rec_ofst) adt;
        rely is_int _t'7;
        if (_t'7 =? 1) then
          Some (adt, (VZ64 1))
        else
          when adt == atomic_granule_get_spec (_g_rec_base, _g_rec_ofst) adt;
          when adt == granule_unlock_spec (_g_rec_base, _g_rec_ofst) adt;
          when adt == ns_granule_map_spec 0 (_g_rec_run_base, _g_rec_run_ofst) adt;
          when _t'6, adt == ns_buffer_read_rec_run_spec 0 adt;
          rely is_int _t'6;
          if (_t'6 =? 0) then
            when adt == ns_buffer_unmap_spec 0 adt;
            when adt == atomic_granule_put_release_spec (_g_rec_base, _g_rec_ofst) adt;
            Some (adt, (VZ64 1))
          else
            when'' _rec_base, _rec_ofst, adt == granule_map_spec (_g_rec_base, _g_rec_ofst) 3 adt;
            rely is_int _rec_ofst;
            when adt == granule_lock_spec (_g_rec_base, _g_rec_ofst) adt;
            when _t'5 == get_rec_runnable_spec (_rec_base, _rec_ofst) adt;
            rely is_int _t'5;
            if (_t'5 =? 0) then
              when adt == granule_unlock_spec (_g_rec_base, _g_rec_ofst) adt;
              when adt == buffer_unmap_spec (_rec_base, _rec_ofst) adt;
              when adt == ns_buffer_unmap_spec 0 adt;
              when adt == atomic_granule_put_release_spec (_g_rec_base, _g_rec_ofst) adt;
              Some (adt, (VZ64 1))
            else
              when _t'4, adt == complete_mmio_emulation_spec (_rec_base, _rec_ofst) adt;
              rely is_int _t'4;
              if (_t'4 =? 0) then
                when adt == granule_unlock_spec (_g_rec_base, _g_rec_ofst) adt;
                when adt == buffer_unmap_spec (_rec_base, _rec_ofst) adt;
                when adt == ns_buffer_unmap_spec 0 adt;
                when adt == atomic_granule_put_release_spec (_g_rec_base, _g_rec_ofst) adt;
                Some (adt, (VZ64 1))
              else
                when adt == complete_hvc_exit_spec (_rec_base, _rec_ofst) adt;
                when adt == reset_last_run_info_spec (_rec_base, _rec_ofst) adt;
                when adt == reset_disposed_info_spec (_rec_base, _rec_ofst) adt;
                when adt == granule_unlock_spec (_g_rec_base, _g_rec_ofst) adt;
                when adt == rec_run_loop_spec (_rec_base, _rec_ofst) adt;
                Some (adt, (VZ64 2))
     end.

End Spec.