From iris Require Import invariants.
From iris.algebra Require Import gmap frac agree frac_auth.
From iris.base_logic Require Export gen_heap fancy_updates.
From iris.base_logic.lib Require Export own saved_prop viewshifts.
From iris.program_logic Require Export weakestpre.
From iris.proofmode Require Import coq_tactics.
From iris.proofmode Require Export tactics.
From iris.program_logic Require Import ectx_lifting total_ectx_lifting.
From stdpp Require Import base numbers.
From distris Require Import tactics proofmode notation adequacy network.
From distris.examples.replicated_log Require Import rep_log.
From distris.examples.library Require Import proof frac_auth.
From distris.examples.two_phase_commit Require Import tpc_proof.

Import Network.
Import tpc.

Class repLogG Σ := RepLogG {
                       repLog_inG :> gen_heapG socket_address string Σ;
                       repWait_inG :> gen_heapG socket_address (string * string) Σ;
                     }.

Class repLogPreG Σ := RepLogPreG {
  repPreLog_inG :> gen_heapPreG socket_address string Σ;
  repPreWait_inG :> gen_heapPreG socket_address (string * string) Σ;
                   }.

Definition repLogΣ : gFunctors :=
  #[gen_heapΣ socket_address string;
    gen_heapΣ socket_address (string * string)].

Instance subG_inG_repLogΣ {Σ} :
  subG repLogΣ Σ → repLogPreG Σ.
Proof. constructor; solve_inG. Qed.

Section rep_log.
  Context `{tG : tpcG Σ}
          `{rlG : repLogG Σ}
          `{dG : distG Σ}
          `{N : namespace}.

  Definition gen_heap_ctxDB σ := gen_heap_ctx (L:=socket_address) (V:=string) σ.
  Definition gen_heap_ctxW σ :=
    gen_heap_ctx (L:=socket_address) (V:=string * string) σ.

  Notation "p ↦L{ q } l" := (mapsto (L:=socket_address)
                                    (V:=string) p q l) (at level 20) : uPred_scope.
  Notation "p ↦L l" := (mapsto (L:=socket_address)
                               (V:=string) p 1 l) (at level 20) : uPred_scope.
  Notation "p ↦W{ q } m" := (mapsto (L:=socket_address)
                                    (V:=string * string) p q m)
                              (at level 20) : uPred_scope.
  Notation "p ↦W m" := (mapsto (L:=socket_address)
                               (V:=string * string) p 1 m)
                         (at level 20) : uPred_scope.

  Lemma wait_update_all σ l v v' :
    gen_heap_ctxW σ -∗ ([∗ list] p ∈ l, p ↦W v) -∗
    |==> ∃ σ', gen_heap_ctxW σ' ∗ [∗ list] p ∈ l, (p ↦W v').
  Proof.
    iIntros "Hctx Hlist".
    iInduction l as [|y l] "IH".
    - simpl. iExists σ. eauto.
    - iDestruct "Hlist" as "[H Hl]".
      iDestruct ("IH" with "Hctx Hl") as ">Hup".
      iDestruct "Hup" as (σ') "(Hctx & Hl)".
      iDestruct (gen_heap_valid (L:=socket_address) σ'
                   with "Hctx H") as %Hlookup.
      iDestruct (gen_heap_update (L:=socket_address) σ' y _ v' with "Hctx H")
        as ">[Hctx H]".
      iDestruct (gen_heap_valid (L:=socket_address) (<[y:=v']> σ')
                   with "Hctx H") as %Hlookup'.
      iFrame. iExists (<[y:=v']> σ'). iFrame. eauto.
  Qed.

  Definition request_msg := "REQUEST".
  Definition commit_msg := "COMMIT".
  Definition abort_msg := "ABORT".

  (* Global functions for TPC to get the type of message *)
  Definition is_req_log := λ m (n : nat), ∃ v, m = request_msg +:+ "_" +:+ v.
  (* Definition is_commit_log := λ m (n : nat), m = commit_msg. *)
  Definition is_abort_log := λ m (n : nat), m = abort_msg.
  Definition is_vote_log := λ m (n : nat), m = abort_msg ∨ m = commit_msg.
  Definition is_global_log :=  λ m (n : nat), m = abort_msg ∨ m = commit_msg.

  Definition tpc_inv_cs_n : namespace := N .@ "replog" .@ "tpc_cs".
  Definition tpc_inv_ps_n : namespace := N .@ "replog" .@ "tpc_ps".

  Lemma is_abort_log_dec m r : Decision (is_abort_log m r).
  Proof. rewrite /is_abort_log. solve_decision. Qed.

  Global Instance rep_log_tpc : TpcProt Σ := {|
                       is_req := is_req_log;
                       is_vote := is_vote_log;
                       is_abort := is_abort_log;
                       is_abort_dec := is_abort_log_dec;
                       is_global := is_global_log;
                       P := (λ m p, ∃ log s, ⌜m = request_msg +:+ "_" +:+ s⌝ ∗
                                             p ↦L{½} log ∗ p ↦W{½} (log, s))%I;
                       Q := (λ p n, ∃ log m,
                                p ↦L{½} (log +:+ m) ∗ p ↦W{½} (log, m) )%I;
                       tpc_inv_cs_name := tpc_inv_cs_n;
                       tpc_inv_ps_name := tpc_inv_ps_n;
                                     |}.

  Definition R_pa n llog lwait :=
    (λ p, ∃ (log : string) w', llog ↦[n] #log ∗ p↦L{½} log ∗ lwait ↦[n] w')%I.

  Definition R'_pa n llog lwait :=
    (λ p, ∃ (log : string) (m : string), llog ↦[n] #log ∗ p↦L log ∗
                                       lwait ↦[n] #m ∗ p ↦W{½} (log, m))%I.

  Definition rep_log_tpc_pa n llog lwait : TpcPartProt Σ :=
    {|
      R := R_pa n llog lwait;
      R' := R'_pa n llog lwait;
    |}.

  Definition rep_log_inv_n := N .@ "replog".
  Definition rep_log_inv := (∃ σ σ', gen_heap_ctxDB σ ∗ gen_heap_ctxW σ')%I.
  Definition rep_log_I := inv rep_log_inv_n rep_log_inv.

  Definition log_si : socket_interp Σ :=
    (λ msg, ∃ s φ,
        ⌜ms_body msg = s⌝ ∗ ms_sender msg ⤇ φ ∗
        (∀ m, (⌜ms_body m = commit_msg⌝ ∨ ⌜ms_body m = abort_msg⌝) -∗ φ m))%I.

  Lemma fin_handler_log_spec n p e1 e2 (lwait llog : loc)
        (Tpa:=rep_log_tpc_pa n llog lwait) :
    IntoVal ⟨n;e1⟩ 〈n;#lwait〉 →
    IntoVal ⟨n;e2⟩ 〈n;#llog〉 →
    {{{ rep_log_I }}}
      ⟨n;fin_handler_log e1 e2⟩
    {{{ v, RET 〈n;v〉; fin_handler_spec n v p }}}.
  Proof.
    iIntros (<-%to_base_val'%ground_lang.of_to_val
            <-%to_base_val'%ground_lang.of_to_val).
    iIntros (Φ) "#Hinv HΦ". wp_lam. wp_lam. iApply "HΦ".
    iIntros (c m e1 e2 r s0
               <-%to_base_val'%ground_lang.of_to_val
               <-%to_base_val'%ground_lang.of_to_val Φ'). iAlways.
    iIntros "(#HpsI & H) HΦ". iDestruct "H" as (Hisglobal Hdec) "[Hps HR]".
    do 2 wp_let. wp_op. case_bool_decide. inversion H as [Hmsg].
    rewrite /R' /= /R'_pa /R_pa /is_abort_log /abort_msg Hmsg.
    + wp_if.
      iDestruct "HR" as (log x) "(Hl & HL & Hw & HW)".
      wp_load. wp_load. wp_op.
      iApply fupd_wp.
      iInv tpc_inv_ps_n as (σ) ">H" "Hclose".
      iDestruct (gen_heap_update σ _ _ (r, PS_INIT PS_COMMIT)
                 with "H Hps") as ">[H Hps]".
      iMod ("Hclose" with "[H]") as "_". iExists _; iFrame.
      iInv rep_log_inv_n as (σ' ?) ">[HLctx HWctx]" "Hclose".
      iDestruct (gen_heap_update σ' _ _ (log +:+ x)
                 with "HLctx HL") as ">[HLctx [HL HL']]".
      iMod ("Hclose" with "[HLctx HWctx]") as "_". iExists _,_. iFrame.
      iModIntro.
      wp_store. iApply "HΦ". iExists PS_COMMIT, (m_body m). iFrame.
      iSplitR "HW HL". iExists _,#x; iFrame. iRight. iSplitR. eauto.
      iExists _,_. iFrame.
    + assert (Hisabort: m_body m = "ABORT").
      { destruct Hisglobal as [Habort | Hcommit]; eauto.
        destruct H. rewrite Hcommit. eauto. }
      iApply fupd_wp.
      iInv tpc_inv_ps_n as (σ) ">H" "Hclose".
      iDestruct (gen_heap_update σ _ _ (r, PS_INIT PS_ABORT)
                 with "H Hps") as ">[H Hps]".
      iMod ("Hclose" with "[H]") as "_". iExists _. iFrame. iModIntro.
      iDestruct "HR" as (log x) "(Hl & [HP HP'] & Hw & HW)".
      wp_if. iApply "HΦ". iExists PS_ABORT,("REQUEST" +:+ "_" +:+ x). iFrame.
      iSplitR "HW HP". iExists log,#x. iFrame. iLeft. iSplitR; auto.
      iExists _,_. iFrame; eauto.
  Qed.

  Lemma req_handler_log_spec n s e (llog lwait : loc)
        (Tpa:=rep_log_tpc_pa n llog lwait) :
    IntoVal ⟨n;e⟩ 〈n;#lwait〉 →
    ({{{ True }}}
      ⟨n;req_handler_log e⟩
    {{{ v, RET 〈n;v〉; req_handler_spec n v s }}})%I.
  Proof.
    iIntros (<-%to_base_val'%ground_lang.of_to_val Φ). iAlways.
    iIntros "H HΦ". wp_lam. iApply "HΦ".
    rewrite /req_handler_spec.
    iIntros (c m e1 e2 r s0
               <-%to_base_val'%ground_lang.of_to_val
               <-%to_base_val'%ground_lang.of_to_val Φ'). iAlways.
    iIntros "(#HpsI & Hisreq & Hps & HP & HR) HΦ'". rewrite /= /R_pa.
    iDestruct "HR" as (log w') "(Hl & Hlog & Hlw)".
    iDestruct "Hisreq" as %[s' Hisreq]. wp_lam. wp_lam. rewrite Hisreq.
    wp_apply value_of_message_spec; eauto.
    { rewrite /request_msg /valid_tag. eauto. } iIntros (? Heq). simpl.
    iApply fupd_wp.
    iInv tpc_inv_ps_n as (σ) ">H" "Hclose".
    iDestruct (gen_heap_update σ _ _ (S r, PS_READY) with "H Hps") as ">[H Hps]".
    iMod ("Hclose" with "[H]") as "_". iExists _. iFrame. iModIntro.
    wp_store.
    iApply "HΦ'". iDestruct "HP" as (? v Hvm) "[Hlog' Hwait]".
    inversion Hvm; simplify_eq.
    iDestruct (mapsto_agree (L:=socket_address)
                 (V:=string) with "Hlog Hlog'") as %->. iExists _.
    rewrite /R'_pa /is_vote_log /commit_msg /is_abort_log /abort_msg. iFrame.
    iSplitR; eauto. iSplitL. iExists _,_. iFrame. iFrame. eauto.
  Qed.

  Lemma db_spec (n : node) A e (a : socket_address) p l r pst γs :
    IntoVal ⟨n;e⟩ 〈n;#a〉 →
    a ∈ l ->
    a ∈ A →
    port_of_address a = p ->
    {{{ rep_log_I ∗ tpc_inv_ps_I ∗ f↦ A ∗ a ⤇ tpc_participant_si a ∗ ownA l ∗
        FreePorts (ip_of_address a) {[p]} ∗ n n↦ γs ∗ a ↦L{½} "" ∗
        a ↦p{¼} (r, PS_INIT pst) }}}
      ⟨n;db e⟩
    {{{ r, RET r; ⌜True⌝ }}}.
  Proof.
    iIntros (<-%to_base_val'%ground_lang.of_to_val HinL HinA Hport Φ) "H HΦ".
    iDestruct "H" as "(#Hinv & #HtpcInv & #Hfixed & #Hsi & #HownL & H)".
    iDestruct "H" as "(Hip & Hn & HP & Hpst)".
    wp_lam. wp_socket h as "Hs". wp_let.
    wp_alloc lwait as "Hwaiting". wp_let.
    wp_alloc llog as "Hlog". wp_let.
    set (tpa := rep_log_tpc_pa n llog lwait).
    wp_apply (req_handler_log_spec n _ _ llog lwait); eauto.
    iIntros (vreq) "#Hreq". wp_let.
    wp_apply (fin_handler_log_spec n _ _ _ lwait llog); eauto.
    iIntros (vfin) "#Hfin". wp_let.
    wp_apply (wp_bind_socket_fix_suc
                with "[$Hfixed Hip $Hs]"); simpl; try done. by rewrite Hport.
    iDestruct 1 as (g) "(Hs & _ & Hrecs & #Hsi')". wp_seq.
    (* Putting auto after times out *)
    wp_apply (tpc_participant_spec _ _ _ _ h _ a _ _ _ l with "[Hsi] [] [-HΦ]");
      last first; try iFrame; auto.
    iFrame "#". rewrite /R /= /R_pa. iExists _,_. iFrame.
  Qed.

  Definition dec_handler_fold_acc r : list message -> ground_lang.val -> iProp Σ :=
    (λ (l : list message) (v : ground_lang.val),
     ∃ ga, ⌜ga = filter (λ m, is_abort_m (m,r)) l⌝ ∗
           ⌜v = #true ∧ ga = [] ∨ v = #false ∧ ga ≠ []⌝)%I.

  Lemma list_filter_nil {A} P `{∀ x, Decision (P x)} :
    filter (A:=A) P [] = [].
  Proof. by rewrite /filter /list_filter. Qed.

  Lemma list_filter_cons {A} P `{∀ x, Decision (P x)} (a : A) (l : list A) :
    filter P (a::l) = filter P [a] ++ filter P l.
  Proof.
    destruct l.
    - by rewrite list_filter_nil app_nil_r.
    - rewrite {1}/filter {1}/filter /list_filter /=.
      case_decide; by rewrite list_filter_nil /=.
  Qed.

  Lemma list_filter_app {A} P `{∀ x, Decision (P x)} (l1 l2 : list A) :
    filter P (l1 ++ l2) = filter P l1 ++ filter P l2.
  Proof.
    induction l1.
    - by simpl.
    - rewrite -app_comm_cons
                 (list_filter_cons P a l1)
                 list_filter_cons
                 list_filter_cons list_filter_nil app_nil_r /=.
      rewrite -app_assoc. by rewrite IHl1.
  Qed.

  Lemma dec_handler_log_spec n s : dec_handler_spec n dec_handler_log s.
  Proof.
    iIntros (v l l' r γs Φ) "!# H HΦ".
    iDestruct "H" as (Hcoh) "(#Hinv & #Hparts & Hn & Hst & Hvotes & Hpst)".
    wp_lam.
    wp_apply (list_fold_spec n _  l #true v #true v
                             (dec_handler_fold_acc r)
                             (λ m, (∃ (mId : message_id) (π : Qp),
                              ⌜is_vote (m_body m) r⌝ ∗ mId m↦{π} m))%I
                             (λ m, (∃ (mId : message_id) (π : Qp),
                              ⌜is_vote (m_body m) r⌝ ∗ mId m↦{π} m))%I
                with "[] [Hvotes]"); last first.
    - iIntros (resV) "(Hacc & Hvotes)".
      iDestruct "Hacc" as (ga) "H";
        iDestruct "H" as %[Hga [[HresV Hgar] | [HresV Hgar]]];
        wp_let; iApply fupd_wp; rewrite HresV.
      +  iDestruct (coordinator_state_update_all _ _ (r, CS_COMMIT)
                      with "Hinv Hparts Hst Hpst") as ">(Hc & Hpcs)". iModIntro.
         wp_if. iApply ("HΦ" $! _ ga CS_COMMIT); eauto. iFrame.
         rewrite /is_abort_m /is_abort /= in Hga.
         rewrite /is_global /= /is_global_log /abort_msg /commit_msg.
         iSplitR. eauto. iSplitR;  eauto.
      +  iDestruct (coordinator_state_update_all _ _ (r, CS_ABORT)
                      with "Hinv Hparts Hst Hpst") as ">(Hc & Hpcs)". iModIntro.
         wp_if. iApply ("HΦ" $! _ ga CS_ABORT); eauto. iFrame.
         rewrite /is_global /= /is_global_log /abort_msg /commit_msg.
         iSplitR. eauto. iSplitR. eauto. eauto.
    - iFrame. rewrite /list_m_val map_map in Hcoh. iPureIntro. split.
      + rewrite /dec_handler_fold_acc. exact Hcoh.
      + exists []. eauto.
    - iIntros (m acc lacc lrem Φ') "!# H HΦ'".
      iDestruct "H" as (Hl) "[Hdec HP]". wp_let. wp_let.
      rewrite /dec_handler_fold_acc. iDestruct "Hdec" as (ga Hfold) "Hacc".
      rewrite /is_vote /= /is_vote_log. iDestruct "HP" as (mId π Hvote) "H".
      iDestruct "Hacc" as %[[Hval Hga] | [Hval Hga]]; rewrite Hval; wp_if.
      + wp_op. case_bool_decide; iApply "HΦ'".
        * iSplitR; last eauto. iExists []. iSplitR; last eauto. iPureIntro.
          rewrite list_filter_app -Hfold Hga app_nil_l.
          rewrite /filter /list_filter list_filter_nil.
          case_decide; last done.
          rewrite /is_abort_log /abort_msg in H0.
          inversion H. rewrite H2 in H0. inversion H0.
        * assert (Habortmsg: (m_body m) = abort_msg).
          { destruct Hvote as [Hab | Hcm]; eauto. destruct H.
            rewrite Hcm /commit_msg. done. }
          iSplitR; last eauto. iExists [m].
          iSplitR; last eauto. iPureIntro.
          rewrite list_filter_app -Hfold Hga app_nil_l.
          rewrite /filter /list_filter list_filter_nil.
          case_decide; first done. destruct H0.
          by rewrite /is_abort_log.
      + wp_op. case_bool_decide; first done.
        iApply "HΦ'". iSplitR; last eauto.
        iExists (ga ++ filter (λ m, is_abort_log (m_body m) r) [m]).
        iSplitR; last eauto. by rewrite list_filter_app Hfold. iPureIntro.
        right; split; eauto. intro. destruct Hga.
          by apply app_nil in H0 as [Hdone ?].
  Qed.

  Definition handlerR n tpca tpch tpcs dbs r : iProp Σ :=
    (∃ g ps log log2 s, tpca ↦c (r, CS_INIT) ∗ tpch s↦[n] tpcs ∗ tpca r↦{ ½} g ∗
         ([∗ list] p ∈ dbs, p ↦c (r, CS_INIT)) ∗
         ([∗ list] p ∈ dbs, p ↦p{¾} (r, PS_INIT ps)) ∗
         ([∗ list] p∈dbs, p ↦L{½} log) ∗
         ([∗ list] p∈dbs, p ↦W (log2,s))
    )%I.

  Lemma logger_spec n e1 e2 (ip : string) dbsV (dbs : list socket_address)
    addr tpca A γs r ps :
    IntoVal ⟨n;e1⟩ 〈n;#ip〉 →
    IntoVal ⟨n;e2⟩ 〈n;dbsV〉 →
    NoDup dbs ->
    length dbs > 0 ->
    addr = SocketAddressInet ip 80 ->
    tpca = SocketAddressInet ip 1200 ->
    list_coh (list_sa_val dbs) dbsV ->
    addr ∈ A ->
    tpca ∉ A ->
    {{{ tpc_inv_cs_I tpca ∗ rep_log_I ∗ ownA dbs ∗ addr ⤇ log_si ∗ f↦ A ∗
        ([∗ list] p∈dbs, p ⤇ tpc_participant_si p) ∗
        n n↦ γs ∗ tpca ↦c (r,CS_INIT) ∗ FreePorts ip {[80%positive;1200%positive]} ∗
        ([∗ list] p∈dbs, p ↦c (r, CS_INIT)) ∗
        ([∗ list] p∈dbs, p ↦p{¾} (r,PS_INIT ps)) ∗
        ([∗ list] p∈dbs, p ↦L{½} "") ∗
        ([∗ list] p∈dbs, p ↦W ("",""))
    }}}
      ⟨n;logger e1 e2⟩
    {{{v, RET 〈n;v〉; True }}}.
  Proof.
    iIntros (<-%to_base_val'%ground_lang.of_to_val
                <-%to_base_val'%ground_lang.of_to_val
                Hnodubs Hlength Haddr Htpca Hcoh HainA HtnotinA).
    iIntros (Φ) "(#Hinv & #Hrepinv & #Hdbs & #Hlogsi & #Hfixed & #Hpsi & H) HΦ".
    iDestruct "H" as "(Hn & Hc & Hip & Hcs & Hps & Hlogs & Hupdates)".
    wp_lam. wp_let. wp_socket z1 as "Haddr". wp_let.
    wp_socket z2 as "Htpc". wp_let.
    wp_makeaddress. wp_let. wp_makeaddress. wp_let. simplify_eq.
    iDestruct (FreePorts_distribute with "Hip") as "[Hip Hip']". set_solver.
    wp_apply (wp_bind_socket_fix_suc with "[$Hfixed Hip $Haddr]"); eauto.
    iDestruct 1 as (g) "(Haddr & ? & Harecs & _)". wp_seq.
    wp_apply (wp_bind_socket_dyn_suc _ _ _ _
                                     _ _ _ _ tpc_coordinator_si
                with "[Hip' $Htpc]"); eauto.
    iDestruct 1 as (g') "(Htpc & ? & Htrecs & #Htsi)". wp_seq. wp_let.
    iDestruct "Hn" as "#Hn".
    wp_apply (listen_spec (handlerR n (SocketAddressInet ip 1200) z2 _ dbs r)
                          (λ v, ⌜True⌝)%I
                          _ _ _ (SocketAddressInet ip 80)
                with "[] [-HΦ]"); last auto; last iFrame; auto.
    iLöb as "IH" forall (g r).
    iIntros (mId m φ Φ') "!# H HΦ'".
    iDestruct "H" as (Hrecmsg) "(Hhandler & Hs & Hrec & HmId & #Hsi' & HP)".
    iDestruct (si_pred_agree _ _ _ (message_stable_from_message m)
                 with "Hlogsi Hsi'") as "#Heq".
    wp_rec. iRewrite -"Heq" in "HP". wp_let. wp_op. wp_op. wp_let.
    iDestruct "HP" as (s φa Hmbody) "(#Hasi & Hret)".
    (* iDestruct (big_sepL_sepL with "Hlogs") as "[Hlogs Hupdates]". *)
    iDestruct "Hhandler" as
        (? ? log log2 s') "(Hc & Htpca & Htpcrec & Hdbcs & Hdbps & Hlogs & Hupdates)".
    iApply fupd_wp.
    iInv rep_log_inv_n as (σ' ?) ">[HLctx HWctx]" "Hclose".
    iDestruct (wait_update_all _ _ _ (log, s) with "HWctx Hupdates") as ">H".
    iDestruct "H" as (?) "[HWctx Hupdates]".
    iMod ("Hclose" with "[HLctx HWctx]") as "_". iExists _,_. iFrame.
    iAssert ([∗ list] p∈dbs, p ↦W{½} (log, s) ∗ p ↦W{½} (log, s))%I
      with "[Hupdates Hrepinv]" as "Hupdates".
    { iApply (big_sepL_mono with "Hupdates").
      iIntros (k y Hlookup) "[H1 H2]". iFrame. }
    iDestruct (big_sepL_sepL with "Hupdates") as "[Hupdates Hupdates']".
    iModIntro.
    wp_apply (tpc_coordinator_setup_spec
                n _ _ _ _ _ z2 _
                {|
                  sfamily := PF_INET;
                  stype := SOCK_DGRAM;
                  sprotocol := IPPROTO_UDP;
                  saddress := Some (SocketAddressInet ip 1200) |}
                (SocketAddressInet ip 1200) _ _ _ _ r
                with "[] [Hn Htpca Htpcrec Hc Hdbcs Hdbps Hlogs Hupdates]");
      eauto; last first.
    - iIntros (v) "H".
      iDestruct "H" as (ps' cs rm' Hisglob)
                         "(Htpcs & Htpcrec & Hc & Hcs & Hps & Hres)".
      wp_let.
      iDestruct "Hres" as "[[Hres Hcommit] | [Hres Habort]]";
        iDestruct "Hres" as %Hres.
      + iDestruct (big_sepL_sepL with "[Hupdates' Hcommit]") as "Hcommit"; iFrame.
        iAssert ([∗ list] p ∈ dbs, p ↦L{½} (log +:+ s) ∗ p ↦W (log, s))%I
          with "[Hcommit]" as "Hcommit".
        { iApply (big_sepL_mono with "Hcommit").
          iIntros (k y Hin) "(Hlog & Hu)".
          iDestruct "Hlog" as (log0 m0) "[Hlog Hu']".
          iDestruct (mapsto_agree (L:=socket_address) with "Hu Hu'") as %Hseq;
          inversion Hseq; simplify_eq. iFrame.
        }
        iDestruct (big_sepL_sepL with "Hcommit") as "[Hlogs Hwait]"; iFrame.
        wp_apply (wp_send_to_bound ⌜True⌝%I ⌜True⌝%I
                    with "[$Hs Hret]"); eauto; iFrame; iFrame "#".
        iSplitR; auto.
        iIntros (M sent mId') "(HM & HmId)". iFrame. iSplitL; last done.
        iApply "Hret". simpl. iModIntro. iNext. iPureIntro.
        destruct Hisglob as [Hnotabort | Habort]; eauto.
        iIntros "(Hs & _)". wp_seq.
        iApply fupd_wp.
        iMod (coordinator_state_update_all _ _ (S r, CS_INIT)
                with "Hinv Hdbs Hc Hcs") as "(Hc & Hcs)".
        iModIntro.
        wp_apply (listen_spec (handlerR n (SocketAddressInet ip 1200) z2 _ dbs (S r))                          (λ v, ⌜True⌝)%I
                          _ _ {|
                            sfamily := PF_INET;
                            stype := SOCK_DGRAM;
                            sprotocol := IPPROTO_UDP;
                            saddress := Some (SocketAddressInet ip 80) |}
                          (SocketAddressInet ip 80)
                    with "[] [-HΦ']"); eauto.
        iApply "IH".
        iFrame. iExists _,_,(log +:+ s),_,_. iFrame.
      + iDestruct (big_sepL_sepL with "[Hupdates' Habort]") as "Habort"; iFrame.
        iAssert ([∗ list] p ∈ dbs, p ↦L{ ½} log ∗ p ↦W (log, s))%I
          with "[Habort]" as "Habort".
        { iApply (big_sepL_mono with "Habort").
          iIntros (k y Hin) "(Hlog & Hu)".
          iDestruct "Hlog" as (m' log0 m0) "(% & Hlog & Hu')"; simplify_eq.
          iDestruct (mapsto_agree (L:=socket_address) with "Hu Hu'") as %Hseq.
          inversion Hseq; simplify_eq. iFrame. }
        iDestruct (big_sepL_sepL with "Habort") as "[Habort Hupdates]".
        wp_apply (wp_send_to_bound ⌜True⌝%I ⌜True⌝%I
                    with "[$Hs Hret]"); eauto; iFrame; iFrame "#".
        iSplitR; auto.
        iIntros (M sent mId') "(HM & HmId)". iFrame. iSplitL; last done.
        iApply "Hret". simpl. iModIntro. iNext. iPureIntro.
        destruct Hres as [Habort Hcs].
        rewrite /is_abort_log in Habort. rewrite Habort. eauto.
        iIntros "(Hs & _)". wp_seq.
        iApply fupd_wp.
        iMod (coordinator_state_update_all _ _ (S r, CS_INIT)
                with "Hinv Hdbs Hc Hcs") as "(Hc & Hcs)".
        iModIntro.
        wp_apply (listen_spec (handlerR n (SocketAddressInet ip 1200) z2 _ dbs (S r))                          (λ v, ⌜True⌝)%I
                          _ _ {|
                            sfamily := PF_INET;
                            stype := SOCK_DGRAM;
                            sprotocol := IPPROTO_UDP;
                            saddress := Some (SocketAddressInet ip 80) |}
                          (SocketAddressInet ip 80)
                    with "[] [-HΦ']"); eauto.
        iApply "IH".
        iFrame. iExists _,_,log,_,_. iFrame.
    - iFrame; iFrame "#". eauto.
      iSplitR. eauto. iSplitR. rewrite /is_req /= /is_req_log. eauto.
      iDestruct (big_sepL_sepL with "[$Hlogs $Hupdates]") as "Hall".
      iDestruct (big_sepL_mono _
                               (λ k p, ∃ ps, p ↦p{¾} (r, PS_INIT ps))%I
                   with "[$Hdbps]") as "Hdbps".
      { iIntros (k y Hiny) "H". eauto. }
      iFrame. iApply (big_sepL_mono with "Hall").
      apply ms_body_message in Hmbody.
      rewrite /tpc_proof.P /= /request_msg Hmbody.
      iIntros. iExists _,_. iFrame. eauto.
      (* eauto. *)
    - iApply dec_handler_log_spec.
    - iExists g',ps,"","","". iFrame.
  Qed.

  Definition client_si : socket_interp Σ :=
    (λ msg, ⌜ms_body msg = commit_msg⌝ ∨ ⌜ms_body msg = abort_msg⌝)%I.

  Lemma client_spec n e1 e2 e3 (ip : string) (logaddr : socket_address)
        (event : string) A γs:
    IntoVal ⟨n;e1⟩ 〈n;#ip〉 →
    IntoVal ⟨n;e2⟩ 〈n;#logaddr〉 →
    IntoVal ⟨n;e3⟩ 〈n;#event〉 →
    SocketAddressInet ip 80 ∉ A ->
    {{{ logaddr ⤇ log_si ∗ f↦ A ∗
        n n↦ γs ∗ FreePorts ip {[80%positive]} }}}
      ⟨n;client e1 e2 e3⟩
      {{{v, RET 〈n;#v〉; ⌜v = commit_msg ∨ v = abort_msg⌝ }}}.
  Proof.
    iIntros (<-%to_base_val'%ground_lang.of_to_val
                <-%to_base_val'%ground_lang.of_to_val
                <-%to_base_val'%ground_lang.of_to_val
                HnotinA Φ) "(#Hlogsi & #Hfixed & Hn & Hports) HΦ".
    rewrite /client.
    do 3 wp_lam. wp_socket h as "Hs". wp_let. wp_makeaddress. wp_let.
    wp_apply (wp_bind_socket_dyn_suc _ _ A _
                                     _ _ _ _ client_si
                with "[Hports $Hs]"); eauto.
    iDestruct 1 as (g') "(Hs & ? & Hrecs & #Hsi)". wp_seq.
    wp_apply (wp_send_to_bound ⌜True⌝%I ⌜True⌝%I
                with "[$Hs]"); eauto; iFrame "#".
    iSplitR. done.
    iIntros (M sent mId) "(HM & HmId)". iFrame. iSplitL; last done. simpl.
    rewrite /log_si /=. iModIntro. iNext.
    iExists event,client_si; eauto.
    iIntros "(Hs & _)". wp_seq.
    wp_apply (listen_wait_spec with "[$Hs $Hrecs]"); eauto.
    iIntros (m mId) "(HX & Hs & Hrecs & HmId & [% | %])"; simpl;
      wp_proj; iApply "HΦ"; eauto.
  Qed.

End rep_log.

Section rep_log_runner.
  Context `{dG : distG Σ, tG : tpcG Σ, rlG : repLogG Σ, N : namespace}.

  Definition db1_ip : string := "127.0.0.1".
  Definition db2_ip : string := "localhost".
  Definition server_ip : string := "0.0.0.0".
  Definition client1_ip : string := "127.0.0.2".
  Definition client2_ip : string := "127.0.0.3".

  Definition db1_addr : socket_address := SocketAddressInet db1_ip 3306.
  Definition db2_addr : socket_address := SocketAddressInet db2_ip 3306.
  Definition server : socket_address := SocketAddressInet server_ip 80%positive.
  Definition coord_addr : socket_address := SocketAddressInet server_ip 1200.

  Definition ips : gset string := {[ server_ip ; db1_ip ; db2_ip ]}.
  Definition db_addresses : list socket_address := [db1_addr;db2_addr].

  Lemma mapsto_p_split_3_4 p x :
    p ↦p x -∗ p ↦p{¾} x ∗ p ↦p{¼} x.
  Proof.
      by rewrite mapsto_eq /mapsto_def -own_op -auth_frag_op
         op_singleton pair_op agree_idemp frac_op' Qp_three_quarter_quarter.
  Qed.

  Lemma make_tpc_inv :
    ownA db_addresses -∗ gen_heap_ctxC ∅ -∗
    |==>
         tpc_inv_cs coord_addr ∗ coord_addr ↦c (0, CS_INIT) ∗
         db1_addr ↦c (0, CS_INIT) ∗ db2_addr ↦c (0, CS_INIT).
  Proof.
    iIntros "HA Hc".
    iDestruct (gen_heap_alloc _ db2_addr (0, CS_INIT)
                 with "Hc") as ">(Hc & Hdb2)"; first set_solver.
    iDestruct (gen_heap_alloc _ db1_addr (0, CS_INIT)
                 with "Hc") as ">(Hc & Hdb1)".
    { rewrite lookup_insert_ne; set_solver. }
    iDestruct (gen_heap_alloc _ coord_addr (0, CS_INIT)
                 with "Hc") as ">(Hc & Hcoord)".
    { repeat rewrite lookup_insert_ne; try set_solver. }
    iFrame.
    rewrite /tpc_inv_cs.
    iExists [db1_addr;db2_addr],_. iFrame. simpl. iSplitR.
      by rewrite !dom_insert_L dom_empty_L.
    iModIntro. iPureIntro.
    intros.
    rewrite lookup_insert.
    case (decide (p = coord_addr)); intro; simplify_eq.
    - rewrite lookup_insert in H; eauto.
    - rewrite lookup_insert_ne in H; last done.
      case (decide (p = db1_addr)); intro; simplify_eq.
      + rewrite lookup_insert in H; eauto.
      + rewrite lookup_insert_ne in H; last done.
        rewrite insert_empty in H.
        revert H.
        rewrite lookup_singleton_Some. by intros [_ <-].
  Qed.

  Lemma logger_runner_spec A :
    server ∈ A ->
    coord_addr ∉ A →
    db1_addr ∈ A →
    db2_addr ∈ A →
    SocketAddressInet client1_ip 80 ∉ A →
    SocketAddressInet client2_ip 80 ∉ A →
    {{{ server ⤇ log_si ∗
        db1_addr ⤇ tpc_participant_si (tpc:=rep_log_tpc (N:=N)) (db1_addr) ∗
        db2_addr ⤇ tpc_participant_si (tpc:=rep_log_tpc (N:=N)) (db2_addr) ∗
        f↦ A ∗
        ownA db_addresses ∗
        gen_heap_ctxC ∅ ∗
        gen_heap_ctxP ∅ ∗
        gen_heap_ctxDB ∅ ∗
        gen_heap_ctxW ∅ ∗
        FreeIP client1_ip ∗
        FreeIP client2_ip ∗
        [∗ set] ip ∈ ips, FreeIP ip }}}
        logger_runner
    {{{ v, RET v; True }}}.
  Proof.
    iIntros (HsinA HsnotinA Hdb1A Hdb2A Hc1A Hc2A Φ)
            "(#Hserver & #Hdb1si & #Hdb2si & #Hfix & #Hparts & H) HΦ".
    iDestruct "H" as "(Hcst & Hpst & Hlog & Hwait & Hc1ip & Hc2ip & Hips)".
    iApply fupd_wp.
    iDestruct (make_tpc_inv with "Hparts Hcst") as ">(Hinv & Hcs & Hcsp1 & Hcsp2)".
    iDestruct (gen_heap_alloc _ db1_addr (0,(PS_INIT PS_COMMIT))
                 with "Hpst") as ">(Hpst & Hpdb1st)";
      first set_solver.
    iDestruct (gen_heap_alloc _ db2_addr (0,(PS_INIT PS_COMMIT))
                 with "Hpst") as ">(Hpst & Hpdb2st)".
    { rewrite lookup_insert_ne; set_solver. }
    iDestruct (mapsto_p_split_3_4 with "Hpdb1st") as "[Hpdb1st Hpdb1st']".
    iDestruct (mapsto_p_split_3_4 with "Hpdb2st") as "[Hpdb2st Hpdb2st']".
    iDestruct (gen_heap_alloc _ db1_addr "" with "Hlog")
      as ">(Hlog & [Hpdb1log Hpdb1log'])";
      first set_solver.
    iDestruct (gen_heap_alloc _ db2_addr "" with "Hlog")
      as ">(Hlog & [Hpdb2log Hpdb2log'])".
    { rewrite lookup_insert_ne; set_solver. }
    iDestruct (gen_heap_alloc _ db1_addr ("","") with "Hwait")
      as ">(Hwait & Hpdb1wait)"; first set_solver.
    iDestruct (gen_heap_alloc _ db2_addr ("","") with "Hwait")
      as ">(Hwait & Hpdb2wait)".
    { rewrite lookup_insert_ne; set_solver. }
    iMod (inv_alloc tpc_inv_cs_n _ (tpc_inv_cs coord_addr) with "Hinv") as "#HcI".
    iMod (inv_alloc tpc_inv_ps_n _ tpc_inv_ps with "[Hpst]") as "#HpI".
    { iNext. iExists _. iFrame. }
    iMod (inv_alloc rep_log_inv_n _ rep_log_inv with "[Hlog Hwait]") as "#HrepI".
    { iNext. iExists _,_. iFrame. }
    iModIntro.
    iDestruct (big_sepS_delete _ _ "0.0.0.0" with "Hips") as "(Hc & Hips)";
      first set_solver.
    iDestruct (big_sepS_delete _ _ "127.0.0.1" with "Hips") as "(Hdb1 & Hips)";
      first set_solver.
    iDestruct (big_sepS_delete _ _ "localhost" with "Hips") as "(Hdb2 & _)";
      first set_solver.
    rewrite /logger_runner.
    wp_makeaddress. wp_let. wp_makeaddress. wp_let.
    wp_apply list_make_spec; auto. iIntros (? ?). simpl. wp_let.
    wp_apply list_cons_spec; auto. iIntros (? ?). simpl. wp_let.
    wp_apply list_cons_spec; auto. iIntros (dbs Hdbs). simpl. wp_let.
    wp_makeaddress. wp_let.
    wp_apply (wp_start with "[-]"); first auto. iFrame. simpl.
    iSplitL "Hpdb1log Hpdb2log Hpdb1st' Hpdb2st' Hdb1 Hdb2 Hc1ip Hc2ip HΦ";
      last first.
    { iNext. iIntros "Hn Hip". iDestruct "Hn" as (γs) "Hn".
      iApply (logger_spec _ _ _ server_ip _ db_addresses server coord_addr
                with "[-] []");
         try iFrame;try iFrame "#"; simpl;
          eauto; try done.
      - apply NoDup_cons_2; last apply NoDup_singleton.
        inversion 1. inversion H2. }
    iNext. wp_seq.
    wp_apply (wp_start with "[-]"); first auto. iFrame.
    iSplitL "Hpdb2log Hpdb2st' Hdb2 Hc1ip Hc2ip HΦ"; last first.
    { iNext. iIntros "Hn Hip".
      iDestruct "Hn" as (γ) "Hn".
      iApply (db_spec _ A _ _ _ db_addresses with "[Hn Hip $Hpdb1st' $Hpdb1log] []");
        eauto; try iFrame; try iFrame "#".
      rewrite /db_addresses /db1_addr /db1_ip. set_solver. }
    iNext. wp_seq.
    wp_apply (wp_start with "[-]"); first auto. iFrame.
    iSplitL "Hc1ip Hc2ip HΦ"; last first.
    { iNext. iIntros "Hn Hip".
      iDestruct "Hn" as (γ) "Hn".
      iApply (db_spec _ A _ _ _ db_addresses with "[Hn Hip $Hpdb2st' $Hpdb2log] []");
        eauto; try iFrame; try iFrame "#".
      rewrite /db_addresses /db1_addr /db1_ip. set_solver. }
    iNext. wp_seq.
    wp_apply (wp_start with "[-]"); first auto; iFrame.
    iSplitL "Hc2ip HΦ"; last first.
    { iNext. iIntros "Hn Hip".
      iDestruct "Hn" as (γ) "Hn".
      iApply (client_spec with "[Hn $Hip]"); eauto; iFrame "#". }
    iNext. wp_seq.
    wp_apply (wp_start with "[-]"); first auto; iFrame.
    iSplitL "HΦ"; last first.
    { iNext. iIntros "Hn Hip".
      iDestruct "Hn" as (γ) "Hn".
      iApply (client_spec with "[Hn $Hip]"); eauto; iFrame "#". }
    by iApply "HΦ".
  Qed.

End rep_log_runner.

Lemma make_repLogG `{repLogPreG} :
  (|==> ∃ _ : repLogG Σ, gen_heap_ctxDB ∅ ∗ gen_heap_ctxW ∅)%I.
Proof.
  iStartProof.
  iMod (gen_heap_init (L:=socket_address) (V:=string) ∅) as (γdb) "Hdb".
  iMod (gen_heap_init (L:=socket_address) (V:=string*string) ∅) as (γw) "HW".
  iModIntro.
  iExists {|
      repLog_inG := γdb;
      repWait_inG := γw;
    |}. iFrame.
Qed.

Definition rep_log_is :=
  {|
    state_heaps := ∅;
    state_sockets := ∅;
    state_lookup := ∅;
    state_ports_in_use :=
      <[server_ip := ∅ ]> $ <[db1_ip := ∅ ]> $ <[db2_ip := ∅ ]>
      $ <[client1_ip := ∅ ]> $ <[client2_ip := ∅ ]> $ ∅;
    state_ms := ∅;
  |}.

Definition fixed_dom : gset socket_address := {[ server; db1_addr; db2_addr ]}.
Definition client_ips : gset string := {[ client1_ip ; client2_ip ]}.
Definition all_ips : gset string := ips ∪ client_ips.

Lemma client_ips_disj :
  ips ## client_ips.
Proof. set_solver. Qed.

Definition socket_interp `{distG Σ, tpcG Σ, repLogG Σ, N : namespace} (sa : socket_address) : socket_interp Σ :=
  (match sa with
   | SocketAddressInet "0.0.0.0" 80 => log_si
   | SocketAddressInet "127.0.0.1" 3306 =>
     tpc_participant_si (tpc:=rep_log_tpc (N:=N)) (db1_addr)
   | SocketAddressInet "localhost" 3306 =>
     tpc_participant_si (tpc:=rep_log_tpc (N:=N)) (db2_addr)
   | _ => client_si
   end)%I.

Theorem rep_log_safe : adequate NotStuck logger_runner rep_log_is (λ v, True).
Proof.
  set (Σ := #[distΣ; tpcΣ; repLogΣ]).
  apply (@dist_adequacy Σ _ all_ips fixed_dom); try done; last first.
  { intros i.
    rewrite /all_ips !elem_of_union !elem_of_singleton.
    intros [[]|]; subst; set_solver. }
  { rewrite /all_ips /= !dom_insert_L dom_empty_L right_id_L !assoc_L //. }
  iIntros (dinvG).
  iMod (@make_repLogG Σ) as (?) "[? ?]".
  iMod (@own_alloc Σ (agreeR (leibnizC (list socket_address))) _ (to_agree db_addresses)) as (γ) "H"; first done.
  iMod (gen_heap_init (Σ:=Σ) (L:=socket_address) (V:=nat * coordinator_state) ∅) as (γc) "Hc".
  iMod (gen_heap_init (Σ:=Σ) (L:=socket_address) (V:=nat * participant_state) ∅) as (γp) "Hp".
  iModIntro. iExists socket_interp.
  iIntros "Hsi #Hsc Hips".
  iApply (@logger_runner_spec _ _ {|
      tpc_coordinator_stateG := γc;
      tpc_participant_stateG := γp;
      tpc_nodes_name := γ
    |} _ nroot with "[-] []"); eauto;
    rewrite /fixed_dom /server; try iFrame; try set_solver.
  rewrite (big_sepS_union _ {[SocketAddressInet server_ip 80;_]}); last set_solver.
  rewrite (big_sepS_union _ {[SocketAddressInet server_ip 80]}); last set_solver.
  rewrite big_sepS_singleton big_sepS_singleton big_sepS_singleton.
  iDestruct "Hsc" as "[[Hsi1 Hsi2] Hsi3]".
  unfold db1_addr,db2_addr. simpl. unfold db1_addr,db2_addr. iFrame "#".
  rewrite /all_ips. rewrite (big_sepS_union _ ips); last apply client_ips_disj.
  rewrite /client_ips (big_sepS_union _ {[client1_ip]}); last set_solver.
  rewrite big_sepS_singleton big_sepS_singleton.
  iDestruct "Hips" as "[Hips1 [Hips2 Hips3]]". iFrame.
Qed.


From isla Require Import opsem.

Definition a8000c : isla_trace :=
  AssumeReg "MDSCR_EL1" [] (RegVal_Base (Val_Bits (BV 32%N 0x0%Z))) Mk_annot :t:
  AssumeReg "HCR_EL2" [] (RegVal_Base (Val_Bits (BV 64%N 0x80000000%Z))) Mk_annot :t:
  AssumeReg "CFG_ID_AA64PFR0_EL1_EL3" [] (RegVal_Base (Val_Bits (BV 4%N 0x1%Z))) Mk_annot :t:
  AssumeReg "CFG_ID_AA64PFR0_EL1_EL2" [] (RegVal_Base (Val_Bits (BV 4%N 0x1%Z))) Mk_annot :t:
  AssumeReg "CFG_ID_AA64PFR0_EL1_EL1" [] (RegVal_Base (Val_Bits (BV 4%N 0x1%Z))) Mk_annot :t:
  AssumeReg "CFG_ID_AA64PFR0_EL1_EL0" [] (RegVal_Base (Val_Bits (BV 4%N 0x1%Z))) Mk_annot :t:
  AssumeReg "EDSCR" [] (RegVal_Base (Val_Bits (BV 32%N 0x0%Z))) Mk_annot :t:
  AssumeReg "MDCR_EL2" [] (RegVal_Base (Val_Bits (BV 32%N 0x0%Z))) Mk_annot :t:
  AssumeReg "MDCR_EL3" [] (RegVal_Base (Val_Bits (BV 32%N 0x0%Z))) Mk_annot :t:
  AssumeReg "OSLSR_EL1" [] (RegVal_Base (Val_Bits (BV 32%N 0x0%Z))) Mk_annot :t:
  AssumeReg "PSTATE" [Field "EL"] (RegVal_Base (Val_Bits (BV 2%N 0x2%Z))) Mk_annot :t:
  AssumeReg "PSTATE" [Field "SP"] (RegVal_Base (Val_Bits (BV 1%N 0x1%Z))) Mk_annot :t:
  AssumeReg "SCR_EL3" [] (RegVal_Base (Val_Bits (BV 32%N 0x501%Z))) Mk_annot :t:
  AssumeReg "SCTLR_EL1" [] (RegVal_Base (Val_Bits (BV 64%N 0x4000002%Z))) Mk_annot :t:
  AssumeReg "SCTLR_EL2" [] (RegVal_Base (Val_Bits (BV 64%N 0x4000002%Z))) Mk_annot :t:
  Smt (DeclareConst 69%Z (Ty_BitVec 32%N)) Mk_annot :t:
  ReadReg "CPTR_EL2" [] (RegVal_Base (Val_Symbolic 69%Z)) Mk_annot :t:
  Smt (DeclareConst 71%Z (Ty_BitVec 32%N)) Mk_annot :t:
  ReadReg "CPTR_EL3" [] (RegVal_Base (Val_Symbolic 71%Z)) Mk_annot :t:
  Smt (DeclareConst 76%Z (Ty_BitVec 32%N)) Mk_annot :t:
  ReadReg "CPACR_EL1" [] (RegVal_Base (Val_Symbolic 76%Z)) Mk_annot :t:
  Smt (DeclareConst 84%Z (Ty_BitVec 32%N)) Mk_annot :t:
  ReadReg "CNTHCTL_EL2" [] (RegVal_Base (Val_Symbolic 84%Z)) Mk_annot :t:
  Smt (DeclareConst 87%Z (Ty_BitVec 32%N)) Mk_annot :t:
  ReadReg "ICC_SRE_EL2" [] (RegVal_Base (Val_Symbolic 87%Z)) Mk_annot :t:
  Smt (DeclareConst 90%Z (Ty_BitVec 32%N)) Mk_annot :t:
  ReadReg "CNTKCTL_EL1" [] (RegVal_Base (Val_Symbolic 90%Z)) Mk_annot :t:
  Smt (DeclareConst 97%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "MPAM2_EL2" [] (RegVal_Base (Val_Symbolic 97%Z)) Mk_annot :t:
  Smt (DeclareConst 108%Z (Ty_BitVec 32%N)) Mk_annot :t:
  ReadReg "ICH_HCR_EL2" [] (RegVal_Base (Val_Symbolic 108%Z)) Mk_annot :t:
  Smt (DeclareConst 121%Z (Ty_BitVec 32%N)) Mk_annot :t:
  ReadReg "ICC_SRE_EL1_NS" [] (RegVal_Base (Val_Symbolic 121%Z)) Mk_annot :t:
  Smt (DeclareConst 126%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "MPAMIDR_EL1" [] (RegVal_Base (Val_Symbolic 126%Z)) Mk_annot :t:
  Smt (DeclareConst 140%Z (Ty_BitVec 32%N)) Mk_annot :t:
  ReadReg "PMUSERENR_EL0" [] (RegVal_Base (Val_Symbolic 140%Z)) Mk_annot :t:
  Smt (DeclareConst 147%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "MPAM3_EL3" [] (RegVal_Base (Val_Symbolic 147%Z)) Mk_annot :t:
  Smt (DeclareConst 150%Z (Ty_BitVec 32%N)) Mk_annot :t:
  ReadReg "ICC_SRE_EL3" [] (RegVal_Base (Val_Symbolic 150%Z)) Mk_annot :t:
  Smt (DeclareConst 157%Z (Ty_BitVec 32%N)) Mk_annot :t:
  ReadReg "MPAMHCR_EL2" [] (RegVal_Base (Val_Symbolic 157%Z)) Mk_annot :t:
  Smt (DeclareConst 174%Z (Ty_BitVec 32%N)) Mk_annot :t:
  ReadReg "HSTR_EL2" [] (RegVal_Base (Val_Symbolic 174%Z)) Mk_annot :t:
  Smt (DeclareConst 196%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R0" [] (RegVal_Base (Val_Symbolic 196%Z)) Mk_annot :t:
  Smt (DefineConst 197%Z (Val (Val_Symbolic 196%Z) Mk_annot)) Mk_annot :t:
  WriteReg "HCR_EL2" [] (RegVal_Base (Val_Symbolic 197%Z)) Mk_annot :t:
  Barrier (RegVal_Base (Val_Enum ((Mk_enum_id 2%nat), Mk_enum_ctor 27%nat))) Mk_annot :t:
  Smt (DeclareConst 227%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 227%Z)) Mk_annot :t:
  Smt (DefineConst 228%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 227%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 228%Z)) Mk_annot :t:
  tnil
.


From fae_gtlc_mu.refinements.static_gradual Require Export logical_relation.
From fae_gtlc_mu.cast_calculus Require Export types typing.
From fae_gtlc_mu.stlc_mu Require Export lang.
From fae_gtlc_mu.cast_calculus Require Export lang.

Section fundamental.
  Context `{!implG Σ,!specG Σ}.
  Local Hint Resolve to_of_val : core.

  Local Tactic Notation "smart_wp_bind" uconstr(ctx) ident(v) ident(w)
        constr(Hv) uconstr(Hp) :=
    iApply (wp_bind (ectx_language.fill [ctx]));
    iApply (wp_wand with "[-]");
      [iApply Hp; iFrame "#"; trivial|];
    iIntros (v); iDestruct 1 as (w) Hv.

  (* Put all quantifiers at the outer level *)
  Lemma bin_log_related_alt {Γ e e' τ} : Γ ⊨ e ≤log≤ e' : τ → ∀ vvs ei' K',
    ⊢ initially_inv ei' ∧ ⟦ Γ ⟧* vvs ∧ currently_half (fill K' (e'.[cast_calculus.typing_lemmas.env_subst (vvs.*2)]))
    → WP e.[stlc_mu.typing_lemmas.env_subst (vvs.*1)] {{ v, ∃ v',
        currently_half (fill K' (cast_calculus.lang.of_val v')) ∧ interp τ (v, v') }}.
  Proof.
    iIntros (Hlog vvs K ρ) "[#Hρ [HΓ Hj]]". asimpl.
    iApply (Hlog with "[HΓ]"); iFrame. eauto.
  Qed.

  Notation "'` H" := (bin_log_related_alt H) (at level 8).

  Lemma bin_log_related_var Γ x τ :
    Γ !! x = Some τ → Γ ⊨ stlc_mu.lang.Var x ≤log≤ cast_calculus.lang.Var x : τ.
  Proof.
    iIntros (? vvs ei') "[#Hρ #HΓ]". iIntros (K). iIntros "Hj /=".
    iDestruct (interp_env_Some_l with "HΓ") as ([v v']) "[Heq Hv]"; first done.
    iDestruct "Heq" as %Heq.
    erewrite !stlc_mu.typing_lemmas.env_subst_lookup; rewrite ?list_lookup_fmap ?Heq; eauto.
    erewrite !cast_calculus.typing_lemmas.env_subst_lookup; rewrite ?list_lookup_fmap ?Heq; eauto.
    iApply wp_value. eauto.
  Qed.

  Lemma bin_log_related_unit Γ : Γ ⊨ stlc_mu.lang.Unit ≤log≤ cast_calculus.lang.Unit : TUnit.
  Proof.
    iIntros (vvs ei') "#[Hρ HΓ]". iIntros (K) "Hj /=".
    iApply wp_value. iExists UnitV. rewrite unfold_interp_type_pair. eauto.
  Qed.

  Lemma bin_log_related_pair Γ e1 e2 e1' e2' τ1 τ2
      (IHHtyped1 : Γ ⊨ e1 ≤log≤ e1' : τ1)
      (IHHtyped2 : Γ ⊨ e2 ≤log≤ e2' : τ2) :
    Γ ⊨ stlc_mu.lang.Pair e1 e2 ≤log≤ Pair e1' e2' : TProd τ1 τ2.
  Proof.
    iIntros (vvs ei') "#[Hρ HΓ]"; iIntros (K) "Hj /=".
    smart_wp_bind (stlc_mu.lang.PairLCtx e2.[stlc_mu.typing_lemmas.env_subst _]) v v' "[Hv #Hiv]"
      ('`IHHtyped1 _ _ ((cast_calculus.lang.PairLCtx e2'.[env_subst _]) :: K)).
    smart_wp_bind (stlc_mu.lang.PairRCtx v) w w' "[Hw #Hiw]"
      ('`IHHtyped2 _ _ ((PairRCtx v') :: K)).
    iApply wp_value.
    iExists (PairV v' w'); iFrame "Hw".
    rewrite interp_rw_TProd.
    iExists (v, v'), (w, w'). simpl; repeat iSplit; trivial.
  Qed.

  Lemma bin_log_related_fst Γ e e' τ1 τ2
      (IHHtyped : Γ ⊨ e ≤log≤ e' : TProd τ1 τ2) :
    Γ ⊨ stlc_mu.lang.Fst e ≤log≤ Fst e' : τ1.
  Proof.
    iIntros (vvs ei') "[#Hρ #HΓ]"; iIntros (K) "Hj /=".
    smart_wp_bind (stlc_mu.lang.FstCtx) v v' "[Hv #Hiv]" ('`IHHtyped _ _ (FstCtx :: K)); cbn.
    rewrite interp_rw_TProd.
    iDestruct "Hiv" as ([w1 w1'] [w2 w2']) "#[% [Hw1 Hw2]]"; simplify_eq.
    iMod (step_fst _ _ K (of_val w1') (of_val w2') with "[-]") as "Hw"; eauto.
    iApply wp_pure_step_later; auto. iApply wp_value; auto.
  Qed.

  Lemma bin_log_related_snd Γ e e' τ1 τ2
      (IHHtyped : Γ ⊨ e ≤log≤ e' : TProd τ1 τ2) :
    Γ ⊨ stlc_mu.lang.Snd e ≤log≤ Snd e' : τ2.
  Proof.
    iIntros (vvs ei') "#[Hρ HΓ]"; iIntros (K) "Hj /=".
    smart_wp_bind (stlc_mu.lang.SndCtx) v v' "[Hv #Hiv]" ('`IHHtyped _ _ (SndCtx :: K)); cbn.
    rewrite interp_rw_TProd.
    iDestruct "Hiv" as ([w1 w1'] [w2 w2']) "#[% [Hw1 Hw2]]"; simplify_eq.
    iMod (step_snd _ _ K (of_val w1') (of_val w2') with "[-]") as "Hw"; eauto.
    iApply wp_pure_step_later; auto. iApply wp_value; auto.
  Qed.

  Lemma bin_log_related_injl Γ e e' τ1 τ2
      (IHHtyped : Γ ⊨ e ≤log≤ e' : τ1) :
    Γ ⊨ stlc_mu.lang.InjL e ≤log≤ InjL e' : (TSum τ1 τ2).
  Proof.
    iIntros (vvs ei') "#[Hρ HΓ]"; iIntros (K) "Hj /=".
    smart_wp_bind (stlc_mu.lang.InjLCtx) v v' "[Hv #Hiv]"
      ('`IHHtyped _ _ (InjLCtx :: K)); cbn.
    iApply wp_value. repeat rewrite /= to_of_val. eauto.
    iExists (InjLV v'); iFrame "Hv".
    rewrite interp_rw_TSum.
    iLeft; iExists (_,_); eauto 10.
  Qed.

  Lemma bin_log_related_injr Γ e e' τ1 τ2
      (IHHtyped : Γ ⊨ e ≤log≤ e' : τ2) :
    Γ ⊨ stlc_mu.lang.InjR e ≤log≤ InjR e' : TSum τ1 τ2.
  Proof.
    iIntros (vvs ei') "#[Hρ HΓ]"; iIntros (K) "Hj /=".
    smart_wp_bind (stlc_mu.lang.InjRCtx) v v' "[Hv #Hiv]"
      ('`IHHtyped _ _ (InjRCtx :: K)); cbn.
    iApply wp_value. repeat rewrite /= to_of_val. eauto.
    iExists (InjRV v'); iFrame "Hv".
    rewrite interp_rw_TSum.
    iRight; iExists (_,_); eauto 10.
  Qed.

  Lemma bin_log_related_case Γ (e0 e1 e2 : stlc_mu.lang.expr) (e0' e1' e2' : cast_calculus.lang.expr) τ1 τ2 τ3
      (IHHtyped1 : Γ ⊨ e0 ≤log≤ e0' : TSum τ1 τ2)
      (IHHtyped2 : τ1 :: Γ ⊨ e1 ≤log≤ e1' : τ3)
      (IHHtyped3 : τ2 :: Γ ⊨ e2 ≤log≤ e2' : τ3) :
    Γ ⊨ stlc_mu.lang.Case e0 e1 e2 ≤log≤ Case e0' e1' e2' : τ3.
  Proof.
    iIntros (vvs ei') "#[Hρ HΓ]"; iIntros (K) "Hj /=".
    iDestruct (interp_env_length with "HΓ") as %?.
    smart_wp_bind (stlc_mu.lang.CaseCtx _ _) v v' "[Hv #Hiv]"
      ('`IHHtyped1 _ _ ((CaseCtx _ _) :: K)); cbn.
    rewrite interp_rw_TSum.
    iDestruct "Hiv" as "[Hiv|Hiv]".
    - iDestruct "Hiv" as ([w w']) "[% Hw]"; simplify_eq.
      iMod (step_case_inl _ _ K (of_val w') with "[-]") as "Hz"; eauto.
      simpl.
      iApply wp_pure_step_later; auto 1 using to_of_val. iNext.
      asimpl. iApply ('`IHHtyped2 ((w,w') :: vvs)); repeat iSplit; eauto.
      iApply interp_env_cons; auto.
    - iDestruct "Hiv" as ([w w']) "[% Hw]"; simplify_eq.
      iMod (step_case_inr _ _ K (of_val w') with "[-]") as "Hz"; eauto.
      simpl.
      iApply wp_pure_step_later; auto 1 using to_of_val. iNext.
      asimpl. iApply ('`IHHtyped3 ((w,w') :: vvs)); repeat iSplit; eauto.
      iApply interp_env_cons; auto.
  Qed.

  Lemma bin_log_related_lam Γ (e : stlc_mu.lang.expr) (e' : cast_calculus.lang.expr) τ1 τ2
      (IHHtyped : τ1 :: Γ ⊨ e ≤log≤ e' : τ2) :
    Γ ⊨ stlc_mu.lang.Lam e ≤log≤ Lam e' : TArrow τ1 τ2.
  Proof.
    iIntros (vvs ei') "#[Hρ HΓ]"; iIntros (K) "Hj /=".
    iApply wp_value. iExists (LamV _).
    rewrite interp_rw_TArrow.
    iIntros "{$Hj} !#".
    iIntros ([v v']) "#Hiv". iIntros (K') "Hj".
    iDestruct (interp_env_length with "HΓ") as %?.
    iApply wp_pure_step_later; auto 1 using to_of_val. iNext.
    iMod (step_lam _ _ K' _ (of_val v') with "[-]") as "Hz"; eauto.
    asimpl. iApply ('`IHHtyped ((v,v') :: vvs)); repeat iSplit; eauto.
    iApply interp_env_cons; iSplit; auto.
  Qed.

  Lemma bin_log_related_app Γ e1 e2 e1' e2' τ1 τ2
      (IHHtyped1 : Γ ⊨ e1 ≤log≤ e1' : TArrow τ1 τ2)
      (IHHtyped2 : Γ ⊨ e2 ≤log≤ e2' : τ1) :
    Γ ⊨ stlc_mu.lang.App e1 e2 ≤log≤ App e1' e2' :  τ2.
  Proof.
    iIntros (vvs ei') "#[Hρ HΓ]"; iIntros (K) "Hj /=".
    smart_wp_bind (stlc_mu.lang.AppLCtx (e2.[stlc_mu.typing_lemmas.env_subst (vvs.*1)])) v v' "[Hv #Hiv]"
      ('`IHHtyped1 _ _ (((AppLCtx (e2'.[env_subst (vvs.*2)]))) :: K)); cbn.
    smart_wp_bind (stlc_mu.lang.AppRCtx v) w w' "[Hw #Hiw]"
                  ('`IHHtyped2 _ _ ((AppRCtx v') :: K)); cbn.
    rewrite interp_rw_TArrow.
    iApply ("Hiv" $! (w, w') with "Hiw"); simpl; eauto.
  Qed.

  Lemma bin_log_related_fold Γ e e' τ
      (IHHtyped : Γ ⊨ e ≤log≤ e' : τ.[(TRec τ)/]) :
    Γ ⊨ stlc_mu.lang.Fold e ≤log≤ cast_calculus.lang.Fold e' : TRec τ.
  Proof.
    iIntros (vvs ei') "#[Hρ HΓ]"; iIntros (K) "Hj /=".
    iApply (wp_bind (stlc_mu.lang.fill_item stlc_mu.lang.FoldCtx)).
    iApply (wp_wand with "[Hj]"). iApply ('`IHHtyped _ _ (FoldCtx :: K)). iFrame. auto.
    iIntros (v); iDestruct 1 as (v') "[Hv #Hiv]".
    iApply wp_value.
    iExists (FoldV v'). iFrame "Hv".
    rewrite interp_rw_TRec.
    iAlways. iExists _, _. eauto.
  Qed.

  Lemma bin_log_related_unfold Γ e e' τ
      (IHHtyped : Γ ⊨ e ≤log≤ e' : TRec τ) :
    Γ ⊨ stlc_mu.lang.Unfold e ≤log≤ Unfold e' : τ.[(TRec τ)/].
  Proof.
    iIntros (vvs ei') "#[Hρ HΓ]"; iIntros (K) "Hj /=".
    iApply (wp_bind (stlc_mu.lang.fill_item stlc_mu.lang.UnfoldCtx)).
    iApply (wp_wand with "[Hj]"). iApply ('`IHHtyped _ _ (UnfoldCtx :: K)). iFrame. auto.
    iIntros (v). iDestruct 1 as (v') "[Hw #Hiw]".
    simpl.
    rewrite interp_rw_TRec.
    iDestruct "Hiw" as (w w') "#[% Hiz]"; simplify_eq/=.
    iMod (step_Fold _ _ K (of_val w') with "[-]") as "Hz"; eauto.
    iApply wp_pure_step_later; cbn; auto.
    iNext. iApply wp_value; auto.
  Qed.

End fundamental.


From iris.algebra Require Import gmap auth agree gset coPset excl csum.
From Perennial.base_logic.lib Require Export fancy_updates.
From stdpp Require Export namespaces.
From Perennial.base_logic.lib Require Import wsat invariants ae_invariants saved_prop.
From Perennial.Helpers Require Import Qextra.
From iris.algebra Require Import gmap.
From iris.proofmode Require Import tactics.
From Perennial.program_logic Require Export step_fupd_extra crash_weakestpre ae_invariants_mutable later_res private_invariants staged_invariant_alt wpc_nval.
From iris.prelude Require Import options.
From iris.prelude Require Import options.

Set Default Proof Using "Type".

#[global]
Existing Instances pri_inv_tok_timeless later_tok_timeless.

Section def.
Context `{IRISG: !irisGS Λ Σ, !generationGS Λ Σ}.
Context `{!pri_invG IRISG}.
Context `{!later_tokG IRISG}.
Context `{!stagedG Σ}.

Lemma staged_inv_wpc_nval E P Qs Qs' R :
  staged_value ⊤ Qs P -∗
  ▷ (Qs -∗ |NC={E}=> □ (Qs' -∗ P) ∗ Qs' ∗ R) -∗
  wpc_nval E (R ∗ staged_value ⊤ Qs' P).
Proof.
  iIntros "Hstaged Hwand".
  rewrite /wpc_nval.
  iIntros (E' e s Φ Φc Hnval Hsub) "Hwp".
  iDestruct "Hstaged" as (??????) "(Hown&Hownstat&#Hsaved1&#Hsaved2&Hltok&Hitok&Hinv)".
  iDestruct "Hinv" as (mj_wp_init mj_ishare Hlt) "#Hinv".
  rewrite /staged_inv.
  rewrite wpc_eq /wpc_def. iIntros (mj).

  iEval (rewrite wpc0_unfold).
  rewrite /wpc_pre. iSplit; last first.
  {
    iSpecialize ("Hwp" $! mj). rewrite wpc0_unfold /wpc_pre.
    iDestruct "Hwp" as "(_&Hwp)".
    iIntros (g1 ns D' κs) "Hg #HC Hlc".
    iSpecialize ("Hwp" with "[$] [$] [$]").
    iApply (step_fupd2N_inner_wand with "Hwp"); auto.
  }
  rewrite Hnval.
  iIntros (q σ1 g1 ns D κ κs nt) "Hσ Hg HNC Hlc".
  iDestruct (pri_inv_tok_disj_inv_half with "[$]") as %Hdisj.
  iMod (pri_inv_acc with "[$]") as "(Hinner&Hclo)".
  { set_solver. }
  iEval (rewrite staged_inv_inner_unfold) in "Hinner".
  iDestruct "Hinner" as (?????) "(>Hown'&#Hsaved1'&#Hsaved2'&>Hstatus'&>Hitok_ishare&Hinner)".
  iDestruct (own_valid_2 with "Hown' Hown") as "#H".
  iDestruct "H" as %[Heq%Excl_included%leibniz_equiv _]%auth_both_valid_discrete.
  iDestruct (own_valid_2 with "Hstatus' Hownstat") as "#Heq_status".
  iDestruct "Heq_status" as %[Heq_status%Excl_included%leibniz_equiv _]%auth_both_valid_discrete.
  inversion Heq; subst.
  iMod (later_tok_decr with "[$]") as (ns' Hlt') "Hg".
  iMod (fupd2_mask_subseteq ∅ ∅) as "Hclo'"; [set_solver+..|].
  iModIntro. simpl. iModIntro. iNext. iModIntro. iApply (step_fupd2N_le (S (S (num_laters_per_step ns')))).
  { etransitivity; last eapply (num_laters_per_step_exp ns'); lia. }
  simpl.
  iDestruct (saved_prop_agree with "Hsaved1 Hsaved1'") as "Hequiv1".
  iDestruct (saved_prop_agree with "Hsaved2 Hsaved2'") as "Hequiv2".
  iModIntro. iModIntro. iModIntro.
  iDestruct "Hinner" as "[(HPs&_)|Hfin]"; last first.
  { (* Impossible, since we have NC token. *)
    iDestruct "Hfin" as "(_&HC&_)". iDestruct (NC_C with "[$] [$]") as %[]. }
  iRewrite -"Hequiv1" in "HPs".
  iMod "Hclo'".
  iSpecialize ("Hwand" with "[$]").
  rewrite ncfupd_eq /ncfupd_def. iSpecialize ("Hwand" with "[$]").
  iPoseProof (fupd_fupd2 with "Hwand") as "Hwand".
  iMod (fupd2_mask_mono with "Hwand") as "((#Hwand&HQs'&HR)&HNC)"; eauto.

  iSpecialize ("Hwp" $! mj). rewrite wpc0_unfold /wpc_pre.
  rewrite Hnval. iDestruct "Hwp" as "(Hwp&_)".
  iMod (saved_prop_alloc Qs') as (γprop_stored') "#Hsaved1''".
  { apply dfrac_valid_discarded. }
  iMod (saved_prop_alloc True%I) as (γprop_remainder') "#Hsaved2''".
  { apply dfrac_valid_discarded. }
  iMod (own_update_2 _ _ _ (● Excl' (γprop_stored', γprop_remainder') ⋅
                              ◯ Excl' (γprop_stored', γprop_remainder'))
              with "Hown' Hown") as "[Hown' Hown]".
  { by apply auth_update, option_local_update, exclusive_local_update. }
  iMod ("Hclo" with "[Hown' Hstatus' HQs' Hitok_ishare]").
  { iNext.
    iEval (rewrite staged_inv_inner_unfold).
    iExists _, _, _, _, _. iFrame "∗ #".
    iLeft.
    iSplit; eauto.
    { iIntros. iDestruct ("Hwand" with "[$]") as "$". eauto. }
  }
  iMod ("Hwp" with "[$] [$] [$] [Hlc]") as "H".
  { iApply (lc_weaken with "Hlc").
    apply num_laters_per_step_lt in Hlt'. lia. }
  iApply (step_fupd2N_wand with "H").
  iIntros "($&H)".
  iIntros.
  iMod ("H" with "[//]") as "($&Hg&Hwpc0&$)".
  iMod (later_tok_incr with "[$]") as "(Hg&Hltok)".
  iMod (global_state_interp_le with "Hg") as "$".
  { apply Nat.le_succ_l, step_count_next_mono; lia. }
  iModIntro.
  iApply (wpc0_strong_mono with "Hwpc0"); auto.
  iSplit.
  { iIntros (?) "H". iDestruct ("H" with "[-]") as "H".
    { iFrame. iExists _, _, _, _, _, _. iFrame "# ∗".
      iExists _, _. iFrame "#". eauto. }
    iFrame. eauto. }
  eauto.
Qed.

End def.


Require Import Bool Vector List String Peano_dec.
Require Import Common FMap HVector ListSupport IndexSupport.
Require Import Syntax Topology Semantics Invariant.
Require Import RqRsLang.

Require Import Ex.Spec Ex.SpecInds Ex.Template Ex.Msi.
Require Import Ex.Msi.Msi Ex.Msi.MsiObjInv.

Set Implicit Arguments.

Local Open Scope list.
Local Open Scope hvec.
Local Open Scope fmap.

Section System.
  Variable tr: tree.
  Hypothesis (Htr: tr <> Node nil).

  Local Notation topo := (fst (tree2Topo tr 0)).
  Local Notation cifc := (snd (tree2Topo tr 0)).
  Local Notation impl := (impl Htr).

  Hint Extern 0 (TreeTopo _) => apply tree2Topo_TreeTopo.
  Hint Extern 0 (WfDTree _) => apply tree2Topo_WfDTree.

  Lemma msi_indices:
    map obj_idx (sys_objs impl) = c_li_indices cifc ++ c_l1_indices cifc.
  Proof.
    simpl; rewrite c_li_indices_head_rootOf at 2 by assumption.
    simpl; f_equal.
    rewrite map_app, map_map, map_id; simpl.
    rewrite map_map, map_id; reflexivity.
  Qed.

  Lemma msi_GoodORqsInit: GoodORqsInit (initsOf impl).
  Proof.
    apply initORqs_GoodORqsInit.
  Qed.

  Lemma msi_WfDTree: WfDTree topo.
  Proof.
    apply tree2Topo_WfDTree.
  Qed.

  Lemma msi_RqRsChnsOnDTree: RqRsChnsOnDTree topo.
  Proof.
    apply tree2Topo_RqRsChnsOnDTree.
  Qed.

  Lemma msi_RqRsChnsOnSystem: RqRsChnsOnSystem topo impl.
  Proof.
    eapply tree2Topo_RqRsChnsOnSystem with (tr0:= tr) (bidx:= [0]); try reflexivity.
    - destruct (tree2Topo _ _); reflexivity.
    - simpl.
      rewrite map_app.
      do 2 rewrite map_trans.
      do 2 rewrite map_id.
      rewrite app_comm_cons.
      rewrite <-c_li_indices_head_rootOf by assumption.
      reflexivity.
  Qed.

  Lemma msi_ExtsOnDTree: ExtsOnDTree topo impl.
  Proof.
    eapply tree2Topo_ExtsOnDTree with (tr0:= tr) (bidx:= [0]); try reflexivity.
    destruct (tree2Topo _ _); reflexivity.
  Qed.

  Lemma msi_RqRsDTree: RqRsDTree topo impl.
  Proof.
    red; repeat ssplit.
    - auto using msi_WfDTree.
    - auto using msi_RqRsChnsOnDTree.
    - auto using msi_RqRsChnsOnSystem.
    - auto using msi_ExtsOnDTree.
  Qed.

  Ltac solve_GoodRqRsRule_unfold ::= autounfold with MsiRules.

  Lemma msi_GoodRqRsSys: GoodRqRsSys topo impl.
  Proof.
    repeat
      match goal with
      | |- GoodRqRsSys _ _ => red
      | |- GoodRqRsObj _ _ _ => red
      | |- Forall _ _ => simpl; constructor; simpl
      | |- Forall _ (_ ++ _) => apply Forall_app
      end.

    - (** Main memory *)

      assert (In (rootOf topo) (c_li_indices cifc)) as Hrin.
      { rewrite c_li_indices_head_rootOf by assumption.
        left; reflexivity.
      }

      simpl.
      repeat
        match goal with
        | |- Forall _ (_ ++ _) => apply Forall_app
        | |- Forall _ (_ :: _) => constructor
        | |- Forall _ nil => constructor
        end.

      apply Forall_forall; intros.
      unfold liRulesFromChildren in H.
      apply concat_In in H; dest.
      apply in_map_iff in H; dest; subst.
      dest_in.
      all: try (solve_GoodRqRsRule; fail).

    - (** Li caches *)
      apply Forall_forall; intros.
      apply in_map_iff in H.
      destruct H as [oidx [? ?]]; subst.
      red; simpl.

      (* pre-register a fact: an Li cache always has a parent *)
      pose proof (c_li_l1_indices_has_parent
                    Htr _ _ (in_or_app _ _ _ (or_introl H0))).
      destruct H as [pidx ?].

      repeat
        match goal with
        | |- Forall _ (_ ++ _) => apply Forall_app
        | |- Forall _ (_ :: _) => constructor
        | |- Forall _ nil => constructor
        end.
      all: try (solve_GoodRqRsRule; fail).

      1: {
        apply Forall_forall; intros.
        unfold liRulesFromChildren in H1.
        apply concat_In in H1; dest.
        apply in_map_iff in H1; dest; subst.
        dest_in.
        all: try (solve_GoodRqRsRule; fail).

        { (* [liGetSRqUpDownM] *)
          apply subtreeChildrenIndsOf_parentIdxOf in H3; [|apply tree2Topo_WfDTree].
          pose proof (tree2Topo_li_child_li_l1 _ _ _ (tl_In _ _ H0) H3).
          rewrite <-msi_indices in H1.

          rule_rqud; eapply rqUpDownRule_RqFwdRule; eauto.

          (** [RqUpDownSound] *)
          red; simpl; intros; dest.
          apply subtreeChildrenIndsOf_parentIdxOf in H4; [|apply tree2Topo_WfDTree].
          repeat ssplit; [discriminate| |intuition auto].
          repeat constructor; try assumption.
        }

        { (* [liGetMRqUpDownM] *)
          apply subtreeChildrenIndsOf_parentIdxOf in H3; [|apply tree2Topo_WfDTree].
          pose proof (tree2Topo_li_child_li_l1 _ _ _ (tl_In _ _ H0) H3).
          rewrite <-msi_indices in H1.

          rule_rqud; eapply rqUpDownRule_RqFwdRule; eauto.

          (** [RqUpDownSound] *)
          red; simpl; intros; dest.
          apply subtreeChildrenIndsOf_parentIdxOf in H4; [|apply tree2Topo_WfDTree].
          repeat ssplit; [discriminate| |intuition auto].
          repeat constructor; try assumption.
        }

        { (* [liGetMRqUpDownS] *)
          apply subtreeChildrenIndsOf_parentIdxOf in H3; [|apply tree2Topo_WfDTree].
          pose proof (tree2Topo_li_child_li_l1 _ _ _ (tl_In _ _ H0) H3).
          rewrite <-msi_indices in H1.

          rule_rqud; eapply rqUpDownRule_RqFwdRule; eauto.

          (** [RqUpDownSound] *)
          red; simpl; intros; dest.
          repeat ssplit.
          { assumption. }
          { apply Forall_forall; intros.
            apply in_remove in H9.
            apply H4 in H9.
            eapply subtreeChildrenIndsOf_parentIdxOf; eauto.
          }
          { apply remove_In. }
        }
      }

      { (* [liDownSRqDownDownM] *)
        rule_rqdd.
        eapply rqDownDownRule_RqFwdRule; eauto.

        (** [RqDownDownSound] *)
        red; simpl; intros; dest.
        repeat ssplit; [discriminate|].
        repeat constructor.
        eapply subtreeChildrenIndsOf_parentIdxOf; eauto.
      }

      { (* [liGetMRsDownRqDownDirS] *)
        rule_rsrq; eapply rsDownRqDownRule_RsDownRqDownRule; eauto.

        (** [RsDownRqDownSound] *)
        red; simpl; intros; dest.
        red in H1.
        unfold getUpLockIdxBackI, getUpLockIdxBack in *.
        destruct (orq@[upRq]) as [rqiu|]; simpl in *; auto.
        destruct H1 as [rcidx [rqUp ?]]; dest.
        pose proof (tree2Topo_li_child_li_l1 _ _ _ (tl_In _ _ H0) H1).
        rewrite <-msi_indices in H9.
        intros; rewrite H11 in *.
        repeat ssplit.
        { assumption. }
        { apply Forall_forall; intros.
          apply in_remove in H12.
          apply H3 in H12.
          eapply subtreeChildrenIndsOf_parentIdxOf; eauto.
        }
        { exists rcidx, rqUp.
          repeat split; try assumption.
        }
      }

      { (* [liDownIRqDownDownDirS] *)
        rule_rqdd.
        eapply rqDownDownRule_RqFwdRule; eauto.

        (** [RqDownDownSound] *)
        red; simpl; intros; dest.
        repeat ssplit; [assumption|].
        apply Forall_forall; intros.
        apply H2 in H4.
        eapply subtreeChildrenIndsOf_parentIdxOf; eauto.
      }

      { (* [liDownIRqDownDownDirM] *)
        rule_rqdd.
        eapply rqDownDownRule_RqFwdRule; eauto.

        (** [RqDownDownSound] *)
        red; simpl; intros; dest.
        repeat ssplit; [discriminate|].
        repeat constructor.
        eapply subtreeChildrenIndsOf_parentIdxOf; eauto.
      }

      { (* [liDownIRqDownDownDirMS] *)
        rule_rqdd.
        eapply rqDownDownRule_RqFwdRule; eauto.

        (** [RqDownDownSound] *)
        red; simpl; intros; dest.
        repeat ssplit; [assumption|].
        apply Forall_forall; intros.
        apply H2 in H4.
        eapply subtreeChildrenIndsOf_parentIdxOf; eauto.
      }

    - (** L1 caches *)
      apply Forall_forall; intros.
      apply in_map_iff in H.
      destruct H as [oidx [? ?]]; subst.
      red; simpl.

      (* pre-register a fact: an L1 cache always has a parent *)
      pose proof (c_li_l1_indices_has_parent
                    Htr _ _ (in_or_app _ _ _ (or_intror H0))).
      destruct H as [pidx ?].

      repeat
        match goal with
        | |- Forall _ (_ ++ _) => apply Forall_app
        | |- Forall _ (_ :: _) => constructor
        | |- Forall _ nil => constructor
        end.
      all: try (solve_GoodRqRsRule; fail).
  Qed.

  Ltac exfalso_RqToUpRule_unfold ::= repeat autounfold with MsiRules in *.
  Ltac exfalso_RsToUpRule_unfold ::= repeat autounfold with MsiRules in *.
  Ltac disc_rule_custom ::= disc_msi_obj_invs.

  Lemma msi_RqUpRsUpOkSys: RqUpRsUpOkSys topo impl (MsiObjInvs topo).
  Proof. (* SKIP_PROOF_ON
    repeat
      match goal with
      | |- RqUpRsUpOkSys _ _ _ => red
      | |- Forall _ _ => simpl; constructor; simpl
      | |- Forall _ (_ ++ _) => apply Forall_app
      end.

    - (** The main memory: no RqUp rules *)
      red; intros.
      simpl in H; unfold liRulesFromChildren in H.
      apply concat_In in H; dest.
      apply in_map_iff in H; dest; subst.
      dest_in.
      all: try (exfalso_RqToUpRule; fail).

    - (** Li cache *)
      apply Forall_forall; intros.
      apply in_map_iff in H.
      destruct H as [oidx [? ?]]; subst.
      red; intros.

      simpl in H; apply in_app_or in H; destruct H;
        [unfold liRulesFromChildren in H;
         apply concat_In in H; dest;
         apply in_map_iff in H; dest; subst;
         dest_in|dest_in].
      all: try (exfalso_RqToUpRule; fail).

      + simpl in H2; apply in_app_or in H2; destruct H2;
          [unfold liRulesFromChildren in H;
           apply concat_In in H; dest;
           apply in_map_iff in H; dest; subst;
           dest_in|dest_in].
        all: try (exfalso_RsToUpRule; fail).
        { clear; solve_rule_conds_ex; solve_msi. }
        { clear; solve_rule_conds_ex; solve_msi. }
        { clear; solve_rule_conds_ex; solve_msi. }
        { clear; solve_rule_conds_ex; auto.
          { destruct H17; dest; try solve [congruence|solve_msi]. }
          { destruct H17; dest; try solve [congruence|solve_msi]. }
        }
        { clear; solve_rule_conds_ex; solve_msi. }
        { clear; solve_rule_conds_ex; solve_msi. }
        { clear; solve_rule_conds_ex; solve_msi. }
        { clear; solve_rule_conds_ex; auto.
          { solve_msi. }
          { f_equal; apply M.add_remove_comm; discriminate. }
        }
        { clear; solve_rule_conds_ex; solve_msi. }
        { clear; solve_rule_conds_ex; auto.
          { solve_msi. }
          { f_equal; apply M.add_remove_comm; discriminate. }
        }

      + simpl in H2; apply in_app_or in H2; destruct H2;
          [unfold liRulesFromChildren in H;
           apply concat_In in H; dest;
           apply in_map_iff in H; dest; subst;
           dest_in|dest_in].
        all: try (exfalso_RsToUpRule; fail).

        { clear; solve_rule_conds_ex; solve_msi. }
        { clear; solve_rule_conds_ex; solve_msi. }
        { clear; solve_rule_conds_ex; solve_msi. }
        { clear; solve_rule_conds_ex.
          all: try (destruct H17; dest; try solve [congruence|solve_msi]).
        }
        { clear; solve_rule_conds_ex.
          all: try (destruct H17; dest; try solve [congruence|solve_msi]).
        }
        { clear; solve_rule_conds_ex; solve_msi. }
        { clear; solve_rule_conds_ex; solve_msi. }
        { clear; solve_rule_conds_ex; try solve_msi.
          f_equal; apply M.add_remove_comm; discriminate.
        }
        { clear; solve_rule_conds_ex; try solve_msi. }
        { clear; solve_rule_conds_ex; try solve_msi.
          f_equal; apply M.add_remove_comm; discriminate.
        }

      + simpl in H2; apply in_app_or in H2; destruct H2;
          [unfold liRulesFromChildren in H;
           apply concat_In in H; dest;
           apply in_map_iff in H; dest; subst;
           dest_in|dest_in].
        all: try (exfalso_RsToUpRule; fail).

        { clear; solve_rule_conds_ex; solve_msi. }
        { clear; solve_rule_conds_const; try solve_msi. }
        { clear; solve_rule_conds_ex; solve_msi. }
        { clear; solve_rule_conds_ex; solve_msi. }
        { clear; solve_rule_conds_ex; solve_msi. }
        { clear; solve_rule_conds_const; try solve_msi.
          all: rewrite invalidate_I; solve_msi.
        }
        { clear; solve_rule_conds_const; try solve_msi. }
        { clear; solve_rule_conds_ex; solve_msi. }
        { clear; solve_rule_conds_ex; solve_msi. }
        { clear; solve_rule_conds_ex; solve_msi. }

      + simpl in H2; apply in_app_or in H2; destruct H2;
          [unfold liRulesFromChildren in H;
           apply concat_In in H; dest;
           apply in_map_iff in H; dest; subst;
           dest_in|dest_in].
        all: try (exfalso_RsToUpRule; fail).

        { clear; solve_rule_conds_ex; solve_msi. }
        { clear; solve_rule_conds_const; try intuition solve_msi. }
        { clear; solve_rule_conds_ex; solve_msi. }
        { clear; solve_rule_conds_ex; solve_msi. }
        { clear; solve_rule_conds_ex; solve_msi. }
        { clear; solve_rule_conds_const; try intuition solve_msi.
          rewrite invalidate_I; [|solve_msi].
          intuition solve_msi.
        }
        { clear; solve_rule_conds_const; try intuition solve_msi. }
        { clear; solve_rule_conds_ex; solve_msi. }
        { clear; solve_rule_conds_ex; try intuition solve_msi. }
        { clear; solve_rule_conds_ex; try intuition solve_msi. }

    - (** L1 cache *)
      apply Forall_forall; intros.
      apply in_map_iff in H.
      destruct H as [oidx [? ?]]; subst.
      red; intros.

      phide H2; dest_in.
      all: try (exfalso_RqToUpRule; fail).

      + preveal H4; dest_in.
        all: try (exfalso_RsToUpRule; fail).
        { clear; solve_rule_conds_const; solve_msi. }
        { clear; solve_rule_conds_const; auto. }
        { clear; solve_rule_conds_const; auto. }

      + preveal H4; dest_in.
        all: try (exfalso_RsToUpRule; fail).
        { clear; solve_rule_conds_const. }
        { clear; solve_rule_conds_const; solve_msi. }
        { clear; solve_rule_conds_const; solve_msi. }

      + preveal H4; dest_in.
        all: try (exfalso_RsToUpRule; fail).
        { clear; solve_rule_conds_const; try solve_msi. }
        { clear; solve_rule_conds_const.
          all: rewrite invalidate_I; solve_msi.
        }
        { clear; solve_rule_conds_const; try solve_msi. }

      + preveal H4; dest_in.
        all: try (exfalso_RsToUpRule; fail).
        { clear; solve_rule_conds_const; try solve_msi. }
        { clear; solve_rule_conds_const.
          rewrite invalidate_I; solve_msi.
        }
        { clear; solve_rule_conds_const.
          rewrite invalidate_I; solve_msi.
        }

        END_SKIP_PROOF_ON *) admit.
  Qed.

  Lemma msi_GoodExtRssSys: GoodExtRssSys impl.
  Proof. (* SKIP_PROOF_ON
    red; simpl.
    constructor; [|apply Forall_app].
    - (** the main memory *)
      red; simpl.
      apply Forall_forall; intros.
      unfold memRulesFromChildren in H.
      apply concat_In in H; dest.
      apply in_map_iff in H; dest; subst.
      dest_in.
      all: try (red; simpl; disc_rule_conds_ex; solve_GoodExtRssSys; fail).

    - (** Li cache *)
      apply Forall_forall; intros.
      apply in_map_iff in H.
      destruct H as [oidx [? ?]]; subst.
      red; simpl.
      apply Forall_app.

      + apply Forall_forall; intros.
        unfold liRulesFromChildren in H.
        apply concat_In in H; dest.
        apply in_map_iff in H; dest; subst.
        dest_in.
        all: try (red; simpl; disc_rule_conds_ex; solve_GoodExtRssSys; fail).
        { (* [liGetMRqUpDownS] *)
          red; simpl; disc_rule_conds_ex.
          apply in_map_iff in H3; dest; subst.
          apply in_remove in H12.
          apply H5 in H12.
          simpl in *; solve_GoodExtRssSys.
        }

      + repeat constructor.
        all: try (red; simpl; disc_rule_conds_ex; solve_GoodExtRssSys; fail).
        { (* [liGetMRsDownRqDownDirS] *)
          red; simpl; disc_rule_conds_ex.
          apply in_map_iff in H2; dest; subst.
          apply in_remove in H5.
          apply H11 in H5.
          simpl in *; solve_GoodExtRssSys.
        }
        { (* [liDownIRqDownDownDirS] *)
          red; simpl; disc_rule_conds_ex.
          apply in_map_iff in H2; dest; subst.
          apply H4 in H7.
          simpl in *; solve_GoodExtRssSys.
        }
        { (* [liDownIRqDownDownDirMS] *)
          red; simpl; disc_rule_conds_ex.
          apply in_map_iff in H2; dest; subst.
          apply H4 in H7.
          simpl in *; solve_GoodExtRssSys.
        }

    - (** L1 cache *)
      apply Forall_forall; intros.
      apply in_map_iff in H.
      destruct H as [oidx [? ?]]; subst.
      red; simpl.
      repeat constructor.
      all: try (red; simpl; disc_rule_conds_ex; solve_GoodExtRssSys; fail).

      END_SKIP_PROOF_ON *) admit.
  Qed.

  Lemma msi_GoodRqRsInterfSys: GoodRqRsInterfSys topo impl (MsiObjInvs topo).
  Proof.
    split.
    - apply msi_RqUpRsUpOkSys.
    - apply msi_GoodExtRssSys.
  Qed.

  Lemma msi_RqRsSys: RqRsSys topo impl (MsiObjInvs topo).
  Proof.
    red; repeat ssplit.
    - apply msi_RqRsDTree.
    - apply msi_GoodRqRsSys.
    - apply msi_GoodRqRsInterfSys.
  Qed.

End System.

#[global] Hint Resolve msi_GoodORqsInit msi_WfDTree msi_RqRsDTree msi_RqRsSys.


(**************************************************************************)
(*  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_load_reg.
bpf_verifier_opcode_load_reg
     : nat -> int64 -> M bool

*)
Open Scope Z_scope.

Definition opcode_load_reg_if (op: nat) : opcode_load_reg :=
  if Nat.eqb op 97%nat then LDXW
  else if Nat.eqb op 105%nat then LDXH
  else if Nat.eqb op 113%nat then LDXB
  else if Nat.eqb op 121%nat then LDXDW
  else LDX_REG_ILLEGAL_INS.

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

Lemma lift_opcode_load_reg :
  forall (E: nat -> opcode_load_reg)
         (F: nat -> opcode_load_reg) n,
    ((fun n => opcode_load_reg_eqb (E n) (F n) = true) n) <->
      (((fun n => opcode_load_reg_eqb (E n) (F n)) n) = true).
Proof.
  intros.
  simpl. reflexivity.
Qed.

Lemma byte_to_opcode_load_reg_if_same:
  forall (op: nat),
    (op <= 255)%nat ->
    nat_to_opcode_load_reg op = opcode_load_reg_if op.
Proof.
  intros.
  unfold nat_to_opcode_load_reg, opcode_load_reg_if.
  apply opcode_load_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_load_reg_match:
  forall op
    (Hop: (op <= 255)%nat)
    (Halu : nat_to_opcode_load_reg op = LDX_REG_ILLEGAL_INS),
      97  <> (Z.of_nat op) /\
      105 <> (Z.of_nat op) /\
      113 <> (Z.of_nat op) /\
      121 <> (Z.of_nat op).
Proof.
  intros.
  rewrite byte_to_opcode_load_reg_if_same in Halu; auto.
  unfold opcode_load_reg_if in Halu.
  change 97  with (Z.of_nat 97%nat).
  change 105 with (Z.of_nat 105%nat).
  change 113 with (Z.of_nat 113%nat).
  change 121 with (Z.of_nat 121%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_load_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_load_reg.

  (* [fn] is the Cligth function which has the same behaviour as [f] *)
  Definition fn: Clight.function := f_bpf_verifier_opcode_load_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_load_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_load_reg.
    simpl.
    unfold INV.
    destruct nat_to_opcode_load_reg eqn: Hload. (**r case discussion on each load_instruction *)
    - (**r LDXW *)
      eapply correct_statement_switch with (n:= 97).
      + 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_load_reg in Hload.
        assert (Hc_eq: c = 97%nat). {
          clear - Hload.
          do 97 (destruct c; [inversion Hload|]).
          destruct c; [reflexivity|].
          do 24 (destruct c; [inversion Hload|]).
          inversion Hload.
        }
        rewrite Hc_eq in *.
        destruct c1 as (c1 & _).
        change (Z.of_nat 97) with 97 in c1.
        symmetry; assumption.
      + compute. intuition congruence.
    - (**r LDXH *)
      eapply correct_statement_switch with (n:= 105).
      + 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_load_reg in Hload.
        assert (Hc_eq: c = 105%nat). {
          clear - Hload.
          do 105 (destruct c; [inversion Hload|]).
          destruct c; [reflexivity|].
          do 16 (destruct c; [inversion Hload|]).
          inversion Hload.
        }
        rewrite Hc_eq in *.
        destruct c1 as (c1 & _).
        change (Z.of_nat 105) with 105 in c1.
        symmetry; assumption.
      + compute. intuition congruence.
    - (**r LDXB *)
      eapply correct_statement_switch with (n:= 113).
      + 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_load_reg in Hload.
        assert (Hc_eq: c = 113%nat). {
          clear - Hload.
          do 113 (destruct c; [inversion Hload|]).
          destruct c; [reflexivity|].
          do 8 (destruct c; [inversion Hload|]).
          inversion Hload.
        }
        rewrite Hc_eq in *.
        destruct c1 as (c1 & _).
        change (Z.of_nat 113) with 113 in c1.
        symmetry; assumption.
      + compute. intuition congruence.
    - (**r LDXDW *)
      eapply correct_statement_switch with (n:= 121).
      + 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_load_reg in Hload.
        assert (Hc_eq: c = 121%nat). {
          clear - Hload.
          do 121 (destruct c; [inversion Hload|]).
          destruct c; [reflexivity|].
          inversion Hload.
        }
        rewrite Hc_eq in *.
        destruct c1 as (c1 & _).
        change (Z.of_nat 121) with 121 in c1.
        symmetry; assumption.
      + compute. intuition congruence.
    - (**r LDX_REG_ILLEGAL_INS *)
      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_load_reg_match in Hload; auto.
        destruct Hload as (Hfirst & Hload). 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 Hload; rewrite Hload; clear Hload.
        (* 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_load_reg.

Close Scope Z_scope.

Existing Instance correct_function_bpf_verifier_opcode_load_reg.


Require Import Ascii.
Require Import String.
Require Import FJ_tactics.
Require Import List.
Require Import Functors.
Require Import FunctionalExtensionality.
Require Import MonadLib.
Require Import Names.
Require Import EffPure.
Require Import EffState.

Section ESoundS.

  Variable D : Set -> Set.
  Context {Fun_D : Functor D}.
  Let DType := DType D.

  Variable E : Set -> Set.
  Context {Fun_E : Functor E}.
  Let Exp := Exp E.

  Variable V : Set -> Set.
  Context {Fun_V : Functor V}.
  Let Value := Value V.

  Variable (MT : Set -> Set).
  Context {Fun_MT : Functor MT}.
  Context {Mon_MT : Monad MT}.
  Context {Fail_MT : FailMonad MT}.
  Context {Reasonable_MT : Reasonable_Monad MT}.
  Context {MT_eq_dec : forall (A : Set) (mta : MT A),
    {exists a, mta = return_ a} + {mta = fail}}.

  Variable (ME : Set -> Set). (* Evaluation Monad. *)
  Context {Fun_M : Functor ME}.
  Context {Mon_M : Monad ME}.
  Context {FailM : FailMonad ME}.
  Context {State_M : StateM ME (list Value)}.

  Context {Typeof_F : forall T, FAlgebra TypeofName T (typeofR D MT) E}.
  Context {evalM_E' : forall T, FAlgebra EvalName T (evalMR V ME) E}.

  Variable TypContext : Set.
  Context {TypContextCE : ConsExtensionC TypContext}.
  Context {TypContext_S : SigTypContextC D TypContext}.
  Context {TypContext_SCE : SigConsExtensionC D TypContext _ _}.
  Context {TypContext_WFE : WF_EnvC V TypContext}.

  Variable WFV : (WFValue_i D V TypContext -> Prop) -> WFValue_i D V TypContext -> Prop.
  Context {funWFV : iFunctor WFV}.

  Context {TypContext_SWFE : Sig_WF_EnvC D V TypContext WFV _ _}.

  Variable WFVM : (WFValueM_i D V MT ME TypContext -> Prop) -> WFValueM_i D V MT ME TypContext -> Prop.
  Context {funWFVM : iFunctor WFVM}.

  Context {Sub_WFVM_Base_WFVM : Sub_iFunctor (WFValueM_base D V MT ME TypContext WFV) WFVM}.
  Context {Sub_WFVM_State_WFVM : Sub_iFunctor (WFValueM_State D V MT ME TypContext) WFVM}.

  Context {WFV_proj1_a_WFV : iPAlgebra WFV_proj1_a_Name (WFV_proj1_a_P D V _ WFV) WFV}.
  Context {WFV_proj1_b_WFV : iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P D V _ WFV) WFV}.

  Context {WFV_Weaken_WFV : iPAlgebra WFValue_Weaken_Name (WFValue_Weaken_P D V _ WFV) WFV}.

  Context {wfvm_bind_alg :
             iPAlgebra wfvm_bind_Name (wfvm_bind_P D V MT ME _ WFV WFVM (TypContextCE := TypContextCE)) WFVM}.

  Section State_Sound_Sec.

    Variable WFV' : (WFValue_i D V (list DType) -> Prop) -> WFValue_i D V (list DType) -> Prop.
    Context {funWFV' : iFunctor WFV'}.

    Variable WFVM' : (WFValueM_i D V MT ME (list DType) -> Prop) -> WFValueM_i D V MT ME (list DType) -> Prop.
    Context {funWFVM' : iFunctor WFVM'}.

    Global Instance DType_Env_CE : ConsExtensionC (list DType) :=
      {| ConsExtension := fun Sigma' Sigma =>
        forall n T, lookup Sigma n = Some T -> lookup Sigma' n = Some T |}.
    Proof.
      (* ConsExtension_id *)
      eauto.
      (* ConsExtension_trans *)
      eauto.
    Defined.

    Global Instance DType_Env_S : SigTypContextC D (list DType) :=
      {| SigLookup := lookup;
        SigInsert := insert _|}.

    Global Instance DType_Env_WFE : WF_EnvC V (list DType) :=
      {| WF_Env := fun env Sigma =>
        P2_Env (WFValueC _ _ _ WFV' Sigma) env Sigma |}.

    Global Instance DType_Env_SCE : SigConsExtensionC D (list DType) _ _.
    Proof.
      constructor.
    (* ConsExtension_SigLookup *)
      eauto.
    (* ConsExtension_SigInsert *)
      simpl; intros; erewrite lookup_Some_insert; eauto.
    Qed.

    Context {WFV_Weaken_WFV' : iPAlgebra WFValue_Weaken_Name (WFValue_Weaken_P D V _ WFV') WFV'}.

    Definition WFV'_Weaken := ifold_ WFV' _ (ip_algebra (iPAlgebra := WFV_Weaken_WFV')).

    Global Instance DType_Env_SWFE : Sig_WF_EnvC D V (list DType) WFV' _ _.
    Proof.
      constructor; simpl; intros.
      (* WF_EnvLookup *)
      unfold WF_Env in H; simpl in H.
      apply (P2_Env_lookup' _ _ _ _ _ H); auto.
      (* WF_EnvInsertLookup *)
      unfold Value.
      rewrite (P2_Env_length _ _ _ _ _ H); apply lookup_insert.
      (* WF_EnvInsert *)
      apply P2_Env_insert; eauto.
      eapply P2_Env_P_P'; eauto.
      intros; generalize (WFV'_Weaken _ H1).
      unfold WFValue_Weaken_P; simpl; intros; eapply H2.
      simpl; intros; erewrite lookup_Some_insert; eauto.
      (* WF_EnvReplace *)
      eapply P2_Env_replace_el; eauto.
    Qed.

    Definition State_Sound_P (i : WFValueM_i D V MT ME (list DType)) :=
      forall T (env : list Value),
        WF_Env V env (wfvm_S _ _ _ _ _ i) ->
        wfvm_T _ _ _ _ _ i = return_ T ->
        exists v : Value, exists env', exists Sigma',
          (put env) >> wfvm_v _ _ _ _ _ i = put env' >> return_ (M := ME) v /\
          WFValueC _ _ _ WFV' Sigma' v T.

    Inductive State_Sound_Name := State_Sound_name.

    Context {WFV_proj1_a_WFV' : iPAlgebra WFV_proj1_a_Name (WFV_proj1_a_P D V _ WFV') WFV'}.
    Context {WFV_proj1_b_WFV' : iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P D V _ WFV') WFV'}.

    Global Instance State_Sound_WFVM_State :
      iPAlgebra State_Sound_Name State_Sound_P (WFValueM_State D V MT ME (list DType)).
    Proof.
      econstructor.
      unfold iAlgebra; intros; eapply ind_alg_WFVM_State with (TypContextCE := DType_Env_CE)
        (TypContext_WFE := DType_Env_WFE);
        try assumption; unfold State_Sound_P; simpl; intros.
      (* WFVM_Get *)
      destruct (H0 env H1 T0 env H1 H2) as [v [env' [Sigma' [eval_eq WF_v_T]]]].
      exists v; exists env'; exists Sigma'.
      unfold wbind; rewrite associativity.
      generalize put_get as put_get'; intros; unfold wbind in put_get'; rewrite put_get'.
      rewrite <- associativity.
      rewrite <- left_unit.
      split; unfold wbind; auto.
      (* WFVM_Put *)
      unfold wbind; rewrite associativity.
      generalize put_put as put_put'; intros; unfold wbind in put_put'; rewrite put_put'.
      destruct (H2 T0 env H0 H4) as [v [env' [Sigma'' [eval_eq WF_v_T]]]].
      exists v; exists env'; exists Sigma''; split; auto.
    Qed.

    Global Instance State_Sound_WFVM_base :
      iPAlgebra State_Sound_Name State_Sound_P (WFValueM_base D V MT ME _ WFV').
    Proof.
      econstructor.
      unfold iAlgebra; intros; apply ind_alg_WFVM_base with (Monad_ME := Mon_M)
        (Fail_MT := Fail_MT) (WFV := WFV');
        try assumption; unfold State_Sound_P; simpl; intros.
      exists v; exists env; exists Sigma; split; auto.
      destruct H1 as [mt' mt'_eq]; subst.
      destruct (fmap_exists _ _ _ _ _ H3) as [[T' T_eq] T'_eq].
      simpl in *; subst; auto.
      destruct T0 as [T0 T0_UP'].
      apply (WFV_proj1_b _ _ _ WFV' _ _ H0); simpl; auto.
      (* WFVM_Untyped' *)
      simpl in H1; apply sym_eq in H1.
      apply FailMonad_Disc in H1; destruct H1; auto.
    Qed.

    Context {State_Sound_WFVM : iPAlgebra State_Sound_Name State_Sound_P WFVM'}.

    Context {eval_soundness'_Exp_E : forall (typeof_rec : UP'_F E -> typeofR D MT)
       (eval_rec : Names.Exp E -> evalMR V ME),
       P2Algebra ES'_ExpName E E E
       (UP'_P2
         (eval_soundness'_P D V E MT ME _ WFVM'
           Datatypes.unit E Fun_E
           (fun _ _ _ _ => True)
           tt typeof_rec eval_rec f_algebra
           (f_algebra (FAlgebra := evalM_E' (@Names.Exp E Fun_E)))))}.

     Context {WF_MAlg_typeof : WF_MAlgebra Typeof_F}.
     Context {WF_MAlg_eval : WF_MAlgebra evalM_E'}.

    Lemma eval_State_soundness : forall (e : Exp) Sigma,
      WFValueMC _ _ _ _ _ WFVM' Sigma (evalM (evalM_E := evalM_E') _ _ _ (proj1_sig e))
      (typeof _ _ MT (proj1_sig e)).
    Proof.
      intro; rewrite <- (@in_out_UP'_inverse _ _ (proj1_sig e) (proj2_sig e)).
      simpl; unfold typeof, evalM, fold_, mfold, in_t.
      repeat rewrite wf_malgebra; unfold mfold.
      destruct (Ind2 (Ind_Alg := eval_soundness'_Exp_E
        (fun e => typeof _ _ _ (proj1_sig e))
        (fun e => evalM (evalM_E := evalM_E') _ _ _ (proj1_sig e)))
        _ (proj2_sig e)) as [e' eval_e'].
      unfold eval_soundness'_P in eval_e'.
      intros; eapply eval_e'; intros; auto; try constructor.
      rewrite (@in_out_UP'_inverse _ _ (proj1_sig _) (proj2_sig _)); auto.
      rewrite (@in_out_UP'_inverse _ _ (proj1_sig _) (proj2_sig _)); auto.
      rewrite <- (@in_out_UP'_inverse _ _ (proj1_sig (fst a)) (proj2_sig _)).
      unfold typeof, evalM, mfold; simpl; unfold in_t;
        repeat rewrite wf_malgebra; unfold mfold; apply H; auto.
    Qed.

    Theorem eval_State_Sound :
      forall (Sigma : Env DType) (e : Exp) (T : DType) (env : Env Value),
        WF_Env V env Sigma ->
        typeof D E MT (proj1_sig e) = return_ T ->
        exists v : Value,
          exists env' : Env Value,
            exists Sigma' : Env DType,
              (put env) >> evalM (evalM_E := evalM_E') _ _ _ (proj1_sig e) =
              put env' >> return_ (M := ME) v /\
              WFValueC _ _ _ WFV' Sigma' v T.
    Proof.
      intros Sigma e.
      apply (ifold_ WFVM' _ (ip_algebra (iPAlgebra := State_Sound_WFVM)) _
        (eval_State_soundness e Sigma)).
    Qed.

  End State_Sound_Sec.

End ESoundS.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)