From machine_program_logic.program_logic Require Import weakestpre.
From HypVeri Require Import lifting rules.rules_base machine_extra.
From HypVeri.algebra Require Import base mem reg pagetable mailbox trans base_extra.
From HypVeri.lang Require Import lang_extra reg_extra mem_extra pagetable_extra trans_extra.

Section mem_send.

Context `{hypparams: HypervisorParameters}.
Context `{vmG: !gen_VMG Σ}.

Lemma size_singleton_le `{Countable K}  (i:K) (s: gset K):
  i ∈ s -> size s ≤ 1 -> s = {[i]}.
Proof.
  intros Hin Hle.
  assert (size s = 1) as Hsize.
  {
    assert (size s ≠ 0).
    intro.
    destruct (decide (s = ∅)).
    set_solver.
    apply size_empty_inv in H1.
    set_solver + H1 n.
    lia.
  }
  assert (s = {[i]}) as ->.
  {
    rewrite set_eq.
    intro. split. intros.
    apply (size_singleton_inv _ i x) in Hsize.
    subst x. set_solver +.
    done. done. intro.
    rewrite elem_of_singleton in H1.
    subst x. done.
  }
  done.
Qed.

Lemma parse_transaction_descriptor_tx mem_tx mem p_tx len tran:
 parse_transaction_descriptor mem_tx (of_pid p_tx) len = Some tran ->
 map_Forall (λ k v, mem !! k = Some v) mem_tx ->
 parse_transaction_descriptor mem (of_pid p_tx) len = Some tran.
Proof.
  rewrite /parse_transaction_descriptor.
  rewrite /parse_list_of_Word.
  intros Hparse Hforall.
  destruct (sequence_a (map (λ v : Addr, mem_tx !! v) (finz.seq p_tx len))) eqn:Heqn;last done.
  assert (sequence_a (map (λ v : Addr, mem !! v) (finz.seq p_tx len)) = Some l) as ->.
  {
    apply (sequence_a_map_subseteq _ _ _ mem_tx). done.
    rewrite map_subseteq_spec.
    intros.
    apply Hforall.
    done.
  }
  done.
Qed.

Lemma parse_transaction_descriptor_tx_None mem_tx mem p_tx len:
 parse_transaction_descriptor mem_tx (of_pid p_tx) len = None ->
 (len <= page_size)%Z ->
 dom mem_tx = list_to_set (addr_of_page p_tx) ->
 map_Forall (λ k v, mem !! k = Some v) mem_tx ->
 parse_transaction_descriptor mem (of_pid p_tx) len = None.
Proof.
  rewrite /parse_transaction_descriptor.
  rewrite /parse_list_of_Word.
  intros Hparse Hle Hdom Hforall.
  destruct (sequence_a (map (λ v : Addr, mem_tx !! v) (finz.seq p_tx len))) eqn:Heqn.
  2: {
    destruct len eqn:Hlen.
    done.
    feed pose proof (sequence_a_map_Forall_Some (S n) p_tx mem_tx).
    rewrite Hdom.
    apply addr_of_page_subseteq.
    lia.
    destruct H0 as [? [H0 ?]].
    rewrite H0 // in Heqn.
  }
  assert (sequence_a (map (λ v : Addr, mem !! v) (finz.seq p_tx len)) = Some l) as ->.
  {
    apply (sequence_a_map_subseteq _ _ _ mem_tx). done.
    rewrite map_subseteq_spec.
    intros.
    apply Hforall.
    done.
  }
  done.
Qed.

Lemma parse_list_of_Word_length mem p len l:
  parse_list_of_Word mem p len = Some l ->
length l = len.
Proof.
  rewrite /parse_list_of_Word.
  revert p l.
  induction len.
  -  intros p l H0. simpl in H0.
     rewrite /monad.List.sequence_a_list /= in H0.
     inversion H0.
     done.
  -  intros p l H0. simpl in H0.
     destruct (mem !! p).
     {
     rewrite /monad.List.sequence_a_list /= in H0.
     destruct (list.foldr _) eqn:Heqn.
     inversion H0.
     simpl.
     rewrite (IHlen (p ^+ 1)%f) //.
     rewrite /sequence_a /= /monad.List.sequence_a_list /=.
     done.
     }
     rewrite /monad.List.sequence_a_list /= in H0.
     done.
Qed.

Lemma parse_list_of_pids_length l f3 l0:
  parse_list_of_pids l f3 = Some l0->
  length l = length l0.
Proof.
  revert l0 f3.
  induction l.
  - intros l0 f3 Hparse.
    rewrite /parse_list_of_pids /=in Hparse.
    destruct (Option.bool_check_option (Z.to_nat f3 =? 0)%nat).
    2: done.
    rewrite /monad.List.sequence_a_list /= in Hparse.
    inversion Hparse.
    done.
  - intros l0 f3 Hparse.
    rewrite /parse_list_of_pids /=in Hparse.
    destruct (Option.bool_check_option (Z.to_nat f3 =? S (length l))%nat) eqn:Heq_f3.
    2: done.
    rewrite /monad.List.sequence_a_list /= in Hparse.
    destruct (to_pid a).
    2: done.
    destruct ( list.foldr
                 (λ (val : option PID) (acc : option (list PID)),
                   match match val with
                         | Some x' => Some (cons x')
                         | None => None
                         end with
                   | Some f' => match acc with
                                | Some a' => Some (f' a')
                                | None => None
                                end
                   | None => None
                   end)) eqn:Heq_fold.
    inversion Hparse.
    simpl.
    erewrite (IHl l1 (f3 ^- 1)%f).
    done.
    rewrite /parse_list_of_pids.
    destruct ((Option.bool_check_option (Z.to_nat (f3 ^- 1)%f =? length l)%nat)) eqn:Heq_f3'.
    simpl.
    rewrite /monad.List.sequence_a_list /=.
    rewrite Heq_fold //.
    assert ((Z.to_nat (f3 ^- 1)%f =? length l)%nat = true).
    {
      rewrite Nat.eqb_eq.
      destruct ((Z.to_nat f3 =? S (length l))%nat) eqn: Heq_f3''.
      2: { simpl in Heq_f3. done. }
      rewrite Nat.eqb_eq in Heq_f3''.
      solve_finz.
    }
    rewrite H0 in Heq_f3'.
    done.
    done.
Qed.

Lemma size_list_to_set' `{Countable A} (l: list A):
  size (list_to_set (C:= gset _) l) <= length l.
Proof.
  unfold size, set_size. simpl.
  induction l.
  simpl.
  rewrite elements_empty.
  rewrite nil_length.
  lia.
  simpl.
  destruct (decide (a ∈(list_to_set (C:= gset _) l))).
  {
    assert ({[a]} ∪ list_to_set l = list_to_set (C:= gset _) l) as ->.
    set_solver +e.
    lia.
  }
  rewrite elements_union_singleton //.
  simpl.
  lia.
Qed.

Lemma parse_transaction_descriptor_length mem p_tx len tran:
 parse_transaction_descriptor mem (of_pid p_tx) len = Some tran ->
 (size (tran.2) + 4 <= len)%Z.
Proof.
  rewrite /parse_transaction_descriptor.
  intros Hparse.
  destruct (parse_list_of_Word mem p_tx len) eqn:Heqn.
  simpl in Hparse.
  2:{ rewrite //= in Hparse. }
  destruct (l !! 0) as [f1|];
  destruct (l !! 1) as [f2|];
  destruct (l !! 2) as [f3|];
  destruct (l !! 3) as [f4|] eqn:Hlk4; try destruct (decode_vmid f1);rewrite //= in Hparse;
  destruct (decode_vmid f4);rewrite //= in Hparse.
  destruct (parse_list_of_pids (drop 4 l) f3) eqn:Hl0.
  inversion Hparse.
  simpl.
  apply parse_list_of_pids_length in Hl0.
  rewrite drop_length in Hl0.
  pose proof (size_list_to_set' l0).
  rewrite -Hl0 in H0.
  apply parse_list_of_Word_length in Heqn.
  rewrite -Heqn.
  assert (length l >= 4).
  { pose proof (lookup_lt_is_Some_1 l 3).
    feed specialize H2.
    eauto.
    lia.
  }
  lia.
  done.
Qed.

Lemma p_share_inv_consist σ1 h i j ps:
  inv_trans_pgt_consistent σ1->
  inv_trans_sndr_rcvr_neq σ1.2 ->
  σ1.2 !! h = Some None ->
  set_Forall (λ p, get_page_table σ1 !! p = Some (Some i, true, {[i]})) ps ->
  inv_trans_pgt_consistent (update_page_table_global flip_excl (alloc_transaction σ1 h (i, j, ps, Sharing, false)) i ps).
Proof.
  intros Hinv_con Hinv_neq Hlk Hforall.
  rewrite /inv_trans_pgt_consistent /inv_trans_pgt_consistent' /=.
  rewrite map_Forall_lookup.
  intros h' meta Hlookup'.
  rewrite lookup_insert_Some in Hlookup'.
  destruct Hlookup' as [[<- <-]|[Hneq Hlookup']].
  { (* FIXED: cannot prove access is a singleton set. changed the excl RA to size acc && excl *)
    intros p Hin.
    simpl in *.
    generalize dependent σ1.1.1.1.2.
    induction ps using set_ind_L.
    - set_solver + Hin.
    - intros pgt Hforall.
      rewrite set_fold_disj_union_strong.
      {
        rewrite set_fold_singleton.
        destruct (decide (x = p)).
        {
          subst.
          specialize (Hforall  p).
          feed specialize Hforall. set_solver +.
          rewrite Hforall /=.
          apply p_upd_pgt_pgt_not_elem.
          done.
          rewrite lookup_insert_Some.
          left;done.
        }
        {
          destruct ( pgt !! x).
          {
            rewrite IHps //.
            set_solver + n Hin.
            intros p' Hin'.
            rewrite lookup_insert_ne.
            apply Hforall.
            set_solver + Hin'.
            set_solver + Hin' H0.
          }
          {
            rewrite IHps //.
            set_solver + n Hin.
            intros p' Hin'.
            apply Hforall.
            set_solver + Hin'.
          }
        }
      }
      apply upd_is_strong_assoc_comm.
      set_solver + H0.
  }
  {
    rewrite /inv_trans_pgt_consistent /inv_trans_pgt_consistent' /= in Hinv_con.
    specialize (Hinv_con h' meta Hlookup').
    simpl in Hinv_con.
    destruct meta as [[[[[sv rv] ps'] tt] b]|];last done.
    simpl in *.
    intros p Hin.
    specialize (Hinv_con p Hin).
    assert (p ∉ ps).
    {
      intro.
      specialize (Hforall p H0).
      rewrite Hforall in Hinv_con.
      destruct tt; destruct b;auto;
        try set_solver + Hinv_con.
      specialize (Hinv_neq h' _ Hlookup').
      simpl in Hinv_neq.
      set_solver.
    }
    destruct tt,b;auto; try apply p_upd_pgt_pgt_not_elem;auto.
  }
Qed.

Lemma p_not_share_inv_consist tt σ1 h i j ps:
  tt ≠ Sharing ->
  inv_trans_pgt_consistent σ1->
  inv_trans_sndr_rcvr_neq σ1.2 ->
  σ1.2 !! h = Some None ->
  set_Forall (λ p, get_page_table σ1 !! p = Some (Some i, true, {[i]})) ps ->
  inv_trans_pgt_consistent (update_page_table_global revoke_access (alloc_transaction σ1 h (i, j, ps, tt, false)) i ps).
Proof.
  intros Htt Hinv_con Hinv_neq Hlk Hforall.
  rewrite /inv_trans_pgt_consistent /inv_trans_pgt_consistent' /=.
  rewrite map_Forall_lookup.
  intros h' meta Hlookup'.
  rewrite lookup_insert_Some in Hlookup'.
  destruct Hlookup' as [[<- <-]|[Hneq Hlookup']].
  { (* FIXED: cannot prove access is a singleton set. changed the excl RA to size acc && excl *)
    intros p Hin.
    simpl in *.
    generalize dependent σ1.1.1.1.2.
    induction ps using set_ind_L.
    - set_solver + Hin.
    - intros pgt Hforall.
      rewrite set_fold_disj_union_strong.
      {
        rewrite set_fold_singleton.
        destruct (decide (x = p)).
        {
          subst.
          specialize (Hforall p).
          feed specialize Hforall. set_solver +.
          rewrite Hforall /=.
          assert ({[i]} ∖ {[i]} = (∅: gset _)). set_solver +.
          destruct tt.
          apply p_upd_pgt_pgt_not_elem.
          done.
          rewrite lookup_insert_Some.
          left;split;auto.
          rewrite H1 //.
          done.
          apply p_upd_pgt_pgt_not_elem.
          done.
          rewrite lookup_insert_Some.
          left;split;auto.
          rewrite H1 //.
        }
        {
          destruct ( pgt !! x).
          {
            apply IHps.
            set_solver + n Hin.
            intros p' Hin'.
            rewrite lookup_insert_ne.
            apply Hforall.
            set_solver + Hin'.
            set_solver + Hin' H0.
          }
          {
            apply IHps.
            set_solver + n Hin.
            intros p' Hin'.
            apply Hforall.
            set_solver + Hin'.
          }
        }
      }
      apply upd_is_strong_assoc_comm.
      set_solver + H0.
  }
  {
    rewrite /inv_trans_pgt_consistent /inv_trans_pgt_consistent' /= in Hinv_con.
    specialize (Hinv_con h' meta Hlookup').
    simpl in Hinv_con.
    destruct meta as [[[[[sv rv] ps'] tt'] b]|];last done.
    simpl in *.
    intros p Hin.
    specialize (Hinv_con p Hin).
    assert (p ∉ ps).
    {
      intro.
      specialize (Hforall p H0).
      rewrite Hforall in Hinv_con.
      destruct tt'; destruct b;auto;
        try set_solver + Hinv_con.
      specialize (Hinv_neq h' _ Hlookup').
      simpl in Hinv_neq.
      set_solver.
    }
    destruct tt',b;auto; try apply p_upd_pgt_pgt_not_elem;auto.
  }
Qed.

Lemma mem_send_invalid_len {i wi r0 r1 r2 hvcf tt q sacc p_tx} ai :
  (tpa ai) ∈ sacc ->
  (tpa ai) ≠ p_tx ->
  let len := (finz.to_z r1) in
  decode_instruction wi = Some(Hvc) ->
  decode_hvc_func r0 = Some(hvcf) ->
  hvcf_to_tt hvcf = Some tt ->
  (page_size < len)%Z ->
  {SS{{ ▷(PC @@ i ->r ai) ∗
      ▷ ai ->a wi ∗
      ▷ (i -@{q}A> sacc) ∗
      ▷ (R0 @@ i ->r r0) ∗
      ▷ (R1 @@ i ->r r1) ∗
      ▷ (R2 @@ i ->r r2) ∗
      ▷ TX@ i := p_tx
       }}}
   ExecI @ i {{{ RET (false, ExecI) ;
                 PC @@ i ->r (ai ^+ 1)%f ∗
                 ai ->a wi ∗
                 i -@{q}A> sacc ∗
                 R0 @@ i ->r (encode_hvc_ret_code Error) ∗
                 R1 @@ i ->r r1 ∗
                 R2 @@ i ->r (encode_hvc_error InvParam) ∗
                 TX@ i := p_tx}}}.
Proof.
  iIntros (Hin_acc Hneq_tx len Hdecode_i Hdecode_f Htt Hgt_ps Φ)
          "(>PC & >mem_ins & >acc & >R0 & >R1 & >R2 & >tx) HΦ".
  iApply (sswp_lift_atomic_step ExecI);[done|].
  iIntros (n σ1) "%Hsche state".
  rewrite /scheduled /= /scheduler in Hsche.
  assert (σ1.1.1.2 = i) as Heq_cur. { case_bool_decide;last done. by apply fin_to_nat_inj. }
  clear Hsche.
  iModIntro.
  iDestruct "state" as "(Hnum & mem & regs & mb & rx_state & pgt_owned & pgt_acc & pgt_excl &
                            trans & hpool & retri & %Hwf & %Hdisj & %Hconsis)".
  (* valid regs *)
  iDestruct ((gen_reg_valid4 i PC ai R0 r0 R1 r1 R2 r2 Heq_cur) with "regs PC R0 R1 R2")
    as "(%Hlookup_PC & %Hlookup_R0 & %Hlookup_R1 & %Hlookup_R2)";eauto.
  (* valid pt *)
  iDestruct (access_agree_check_true (tpa ai) i with "pgt_acc acc") as %Hcheckpg_ai;eauto.
  (* valid mem *)
  iDestruct (gen_mem_valid ai wi with "mem mem_ins") as %Hlookup_ai.
  (* valid tx *)
  iDestruct (mb_valid_tx i p_tx with "mb tx") as %Heq_tx.
  (* valid tran *)
  iSplit.
  - (* reducible *)
    iPureIntro.
    apply (reducible_normal i Hvc ai wi);auto.
    rewrite Heq_tx //.
  - iModIntro.
    iIntros (m2 σ2) "vmprop_auth %HstepP".
    iFrame "vmprop_auth".
    apply (step_ExecI_normal i Hvc ai wi) in HstepP;eauto.
    2: rewrite Heq_tx //.
    remember (exec Hvc σ1) as c2 eqn:Heqc2.
    rewrite /exec /hvc Hlookup_R0 /= Hdecode_f /mem_send Hlookup_R1 /= in Heqc2.
    case_bool_decide;last lia.
    rewrite /= in Heqc2.
    assert (Heq_c2 : (m2,σ2) = (ExecI, update_incr_PC (update_reg (update_reg σ1 R0 (encode_hvc_ret_code Error)) R2 (encode_hvc_error InvParam)))).
    {
      destruct hvcf; inversion Htt;
        destruct HstepP;subst m2 σ2; subst c2; done.
    }
    inversion Heq_c2. clear H2 H3 Heqc2 Heq_c2.
    rewrite /=.
    iDestruct (hvc_error_update (E:= ⊤) InvParam with "PC R0 R2 [$Hnum $mem $regs $mb $rx_state $pgt_owned $pgt_acc $pgt_excl $ trans $hpool $retri]")
    as ">[[$ $] ?]";auto.
    rewrite /scheduled /machine.scheduler /= /scheduler.
    rewrite p_upd_pc_current_vm 2!p_upd_reg_current_vm Heq_cur.
    case_bool_decide;last contradiction.
    simpl. iApply "HΦ".
    iFrame.
    by iFrame.
Qed.

Lemma mem_send_invalid_msg {i wi r0 r1 r2 hvcf tt p_tx q sacc} ai mem_tx :
  (tpa ai) ∈ sacc ->
  (tpa ai) ≠ p_tx ->
  let len := (Z.to_nat (finz.to_z r1)) in
  decode_instruction wi = Some(Hvc) ->
  decode_hvc_func r0 = Some(hvcf) ->
  hvcf_to_tt hvcf = Some tt ->
  (len <= page_size)%Z ->
  parse_transaction_descriptor mem_tx (of_pid p_tx) len = None ->
  {SS{{ ▷(PC @@ i ->r ai) ∗
      ▷ ai ->a wi ∗
      ▷ (i -@{q}A> sacc) ∗
      ▷ (R0 @@ i ->r r0) ∗
      ▷ (R1 @@ i ->r r1) ∗
      ▷ (R2 @@ i ->r r2) ∗
      ▷ (TX@ i := p_tx) ∗
      ▷ (memory_page p_tx mem_tx)
       }}}
   ExecI @ i {{{ RET (false, ExecI) ;
                 PC @@ i ->r (ai ^+ 1)%f ∗
                 ai ->a wi ∗
                 i -@{q}A> sacc ∗
                 R0 @@ i ->r (encode_hvc_ret_code Error) ∗
                 R1 @@ i ->r r1 ∗
                 R2 @@ i ->r (encode_hvc_error InvParam) ∗
                 TX@ i := p_tx ∗
                 memory_page p_tx mem_tx
    }}}.
Proof.
  iIntros (Hin_acc Hneq_tx len Hdecode_i Hdecode_f Htt Hle_ps Hparse Φ)
          "(>PC & >mem_ins & >acc & >R0 & >R1 & >R2 & >tx & >mem_tx) HΦ".
  iApply (sswp_lift_atomic_step ExecI);[done|].
  iIntros (n σ1) "%Hsche state".
  rewrite /scheduled /= /scheduler in Hsche.
  assert (σ1.1.1.2 = i) as Heq_cur. { case_bool_decide;last done. by apply fin_to_nat_inj. }
  clear Hsche.
  iModIntro.
  iDestruct "state" as "(Hnum & mem & regs & mb & rx_state & pgt_owned & pgt_acc & pgt_excl &
                            trans & hpool & retri & %Hwf & %Hdisj & %Hconsis)".
  (* valid regs *)
  iDestruct ((gen_reg_valid4 i PC ai R0 r0 R1 r1 R2 r2 Heq_cur) with "regs PC R0 R1 R2")
    as "(%Hlookup_PC & %Hlookup_R0 & %Hlookup_R1 & %Hlookup_R2)";eauto.
  (* valid pt *)
  iDestruct (access_agree_check_true (tpa ai) i with "pgt_acc acc") as %Hcheckpg_ai;eauto.
  (* valid mem *)
  iDestruct (gen_mem_valid ai wi with "mem mem_ins") as %Hlookup_ai.
  iDestruct (gen_mem_valid_SepM with "mem [mem_tx]") as %Hlookup_mem_tx.
  { iDestruct "mem_tx" as "[% mem_tx]". iExact "mem_tx". }
  (* valid tx *)
  iDestruct (mb_valid_tx i p_tx with "mb tx") as %Heq_tx.
  (* valid tran *)
  iSplit.
  - (* reducible *)
    iPureIntro.
    apply (reducible_normal i Hvc ai wi);auto.
    rewrite Heq_tx //.
  - iModIntro.
    iIntros (m2 σ2) "vmprop_auth %HstepP".
    iFrame "vmprop_auth".
    apply (step_ExecI_normal i Hvc ai wi) in HstepP;eauto.
    2: rewrite Heq_tx //.
    remember (exec Hvc σ1) as c2 eqn:Heqc2.
    rewrite /exec /hvc Hlookup_R0 /= Hdecode_f /mem_send Hlookup_R1 /= in Heqc2.
    case_bool_decide;first lia.
    iDestruct "mem_tx" as "[%Hdom_mem_tx mem_tx]".
    rewrite -Heq_tx -Heq_cur /len in Hparse.
    apply (parse_transaction_descriptor_tx_None _ σ1.1.2) in Hparse;try lia; last done.
    2: { rewrite Heq_cur Heq_tx //. }
    rewrite Hparse /= in Heqc2.
    assert (Heq_c2 : (m2,σ2) = (ExecI, update_incr_PC (update_reg (update_reg σ1 R0 (encode_hvc_ret_code Error)) R2 (encode_hvc_error InvParam)))).
    {
      destruct hvcf; inversion Htt;
        destruct HstepP;subst m2 σ2; subst c2; done.
    }
    inversion Heq_c2. clear H2 H3 Heqc2 Heq_c2.
    iAssert (memory_page p_tx mem_tx) with "[$mem_tx]" as "mem_tx". done.
    rewrite /=.
    iDestruct (hvc_error_update (E:= ⊤) InvParam with "PC R0 R2 [$Hnum $mem $regs $mb $rx_state $pgt_owned $pgt_acc $pgt_excl $ trans $hpool $retri]")
    as ">[[$ $] ?]". 1-4: auto. iPureIntro. auto.
    rewrite /scheduled /machine.scheduler /= /scheduler.
    rewrite p_upd_pc_current_vm 2!p_upd_reg_current_vm Heq_cur.
    case_bool_decide;last contradiction.
    simpl. iApply "HΦ".
    iFrame.
    by iFrame.
Qed.

Lemma mem_send_invalid_des {i wi r0 r1 r2 hvcf p_tx tt q sacc} ai mem_tx tran :
  (tpa ai) ∈ sacc ->
  (tpa ai) ≠ p_tx ->
  let len := (Z.to_nat (finz.to_z r1)) in
  decode_instruction wi = Some(Hvc) ->
  decode_hvc_func r0 = Some(hvcf) ->
  hvcf_to_tt hvcf = Some tt ->
  (len <= page_size)%Z ->
  parse_transaction_descriptor mem_tx (of_pid p_tx) len = Some tran ->
  validate_transaction_descriptor i tran = false ->
  {SS{{ ▷(PC @@ i ->r ai) ∗
      ▷ ai ->a wi ∗
      ▷ i -@{q}A> sacc ∗
      ▷ (R0 @@ i ->r r0) ∗
      ▷ (R1 @@ i ->r r1) ∗
      ▷ (R2 @@ i ->r r2) ∗
      ▷ (TX@ i := p_tx) ∗
      ▷ (memory_page p_tx mem_tx)
       }}}
   ExecI @ i {{{ RET (false, ExecI) ;
                 PC @@ i ->r (ai ^+ 1)%f ∗
                 ai ->a wi ∗
                 i -@{q}A> sacc ∗
                 R0 @@ i ->r (encode_hvc_ret_code Error) ∗
                 R1 @@ i ->r r1 ∗
                 R2 @@ i ->r (encode_hvc_error InvParam) ∗
                 TX@ i := p_tx ∗
                 memory_page p_tx mem_tx
    }}}.
Proof.
  iIntros (Hin_acc Hneq_tx len Hdecode_i Hdecode_f Htt Hle_ps Hparse Hvalid_des Φ)
          "(>PC & >mem_ins & >acc & >R0 & >R1 & >R2 & >tx & >mem_tx) HΦ".
  iApply (sswp_lift_atomic_step ExecI);[done|].
  iIntros (n σ1) "%Hsche state".
  rewrite /scheduled /= /scheduler in Hsche.
  assert (σ1.1.1.2 = i) as Heq_cur. { case_bool_decide;last done. by apply fin_to_nat_inj. }
  clear Hsche.
  iModIntro.
  iDestruct "state" as "(Hnum & mem & regs & mb & rx_state & pgt_owned & pgt_acc & pgt_excl &
                            trans & hpool & retri & %Hwf & %Hdisj & %Hconsis)".
  (* valid regs *)
  iDestruct ((gen_reg_valid4 i PC ai R0 r0 R1 r1 R2 r2 Heq_cur) with "regs PC R0 R1 R2")
    as "(%Hlookup_PC & %Hlookup_R0 & %Hlookup_R1 & %Hlookup_R2)";eauto.
  (* valid pt *)
  iDestruct (access_agree_check_true (tpa ai) i with "pgt_acc acc") as %Hcheckpg_ai;eauto.
  (* valid mem *)
  iDestruct (gen_mem_valid ai wi with "mem mem_ins") as %Hlookup_ai.
  iDestruct (gen_mem_valid_SepM with "mem [mem_tx]") as %Hlookup_mem_tx.
  { iDestruct "mem_tx" as "[% mem_tx]". iExact "mem_tx". }
  (* valid tx *)
  iDestruct (mb_valid_tx i p_tx with "mb tx") as %Heq_tx.
  (* valid tran *)
  iSplit.
  - (* reducible *)
    iPureIntro.
    apply (reducible_normal i Hvc ai wi);eauto.
    rewrite Heq_tx //.
  - iModIntro.
    iIntros (m2 σ2) "vmprop_auth %HstepP".
    iFrame "vmprop_auth".
    apply (step_ExecI_normal i Hvc ai wi) in HstepP;eauto.
    2: rewrite Heq_tx //.
    remember (exec Hvc σ1) as c2 eqn:Heqc2.
    rewrite /exec /hvc Hlookup_R0 /= Hdecode_f /mem_send Hlookup_R1 /= in Heqc2.
    case_bool_decide;first lia.
    pose proof (parse_transaction_descriptor_length _ _ _ _ Hparse) as Hlt_pg.
    rewrite -Heq_tx -Heq_cur /len in Hparse.
    apply (parse_transaction_descriptor_tx _ σ1.1.2) in Hparse;last done.
    rewrite Hparse /= Heq_cur Hvalid_des /= in Heqc2.
    assert (Heq_c2 : (m2,σ2) = (ExecI, update_incr_PC (update_reg (update_reg σ1 R0 (encode_hvc_ret_code Error)) R2 (encode_hvc_error InvParam)))).
    {
      destruct hvcf; inversion Htt;
        destruct HstepP;subst m2 σ2; subst c2; done.
    }
    inversion Heq_c2. clear H2 H3 Heq_c2.
    rewrite /=.
    iDestruct (hvc_error_update (E:= ⊤) InvParam with "PC R0 R2 [$Hnum $mem $regs $mb $rx_state $pgt_owned $pgt_acc $pgt_excl $ trans $hpool $retri]")
    as ">[[$ $] ?]". 1-4: auto. iPureIntro. auto.
    rewrite /scheduled /machine.scheduler /= /scheduler.
    rewrite p_upd_pc_current_vm 2!p_upd_reg_current_vm Heq_cur.
    case_bool_decide;last contradiction.
    simpl. iApply "HΦ".
    iFrame.
    by iFrame.
Qed.

Lemma mem_send_not_owned1 {i wi r0 r1 r2 hvcf p_tx tt q sacc} ai p mem_tx tran :
  (tpa ai) ∈ sacc ->
  (tpa ai) ≠ p_tx ->
  let len := (Z.to_nat (finz.to_z r1)) in
  decode_instruction wi = Some(Hvc) ->
  decode_hvc_func r0 = Some(hvcf) ->
  hvcf_to_tt hvcf = Some tt ->
  (len <= page_size)%Z ->
  parse_transaction_descriptor mem_tx (of_pid p_tx) len = Some tran ->
  validate_transaction_descriptor i tran = true ->
  p ∈ tran.2 ->
  {SS{{ ▷(PC @@ i ->r ai) ∗
      ▷ ai ->a wi ∗
      ▷ i -@{q}A> sacc ∗
      ▷ (R0 @@ i ->r r0) ∗
      ▷ (R1 @@ i ->r r1) ∗
      ▷ (R2 @@ i ->r r2) ∗
      ▷ (TX@ i := p_tx) ∗
      ▷ (memory_page p_tx mem_tx) ∗
      ▷ p -@O> -
       }}}
   ExecI @ i {{{ RET (false, ExecI) ;
                 PC @@ i ->r (ai ^+ 1)%f ∗
                 ai ->a wi ∗
                 i -@{q}A> sacc ∗
                 R0 @@ i ->r (encode_hvc_ret_code Error) ∗
                 R1 @@ i ->r r1 ∗
                 R2 @@ i ->r (encode_hvc_error Denied) ∗
                 TX@ i := p_tx ∗
                 memory_page p_tx mem_tx ∗
                 p -@O> -
    }}}.
Proof.
  iIntros (Hin_acc Hneq_tx len Hdecode_i Hdecode_f Htt Hle_ps Hparse Hvalid_des Hin_p Φ)
          "(>PC & >mem_ins & >acc & >R0 & >R1 & >R2 & >tx & >mem_tx & >own) HΦ".
  iApply (sswp_lift_atomic_step ExecI);[done|].
  iIntros (n σ1) "%Hsche state".
  rewrite /scheduled /= /scheduler in Hsche.
  assert (σ1.1.1.2 = i) as Heq_cur. { case_bool_decide;last done. by apply fin_to_nat_inj. }
  clear Hsche.
  iModIntro.
  iDestruct "state" as "(Hnum & mem & regs & mb & rx_state & pgt_owned & pgt_acc & pgt_excl &
                            trans & hpool & retri & %Hwf & %Hdisj & %Hconsis)".
  (* valid regs *)
  iDestruct ((gen_reg_valid4 i PC ai R0 r0 R1 r1 R2 r2 Heq_cur) with "regs PC R0 R1 R2")
    as "(%Hlookup_PC & %Hlookup_R0 & %Hlookup_R1 & %Hlookup_R2)";eauto.
  (* valid pt *)
  iDestruct (access_agree_check_true (tpa ai) i with "pgt_acc acc") as %Hcheckpg_ai;eauto.
  iDestruct (own_agree_None_check _ i with "pgt_owned own") as %Hcheckpg_own_false.
  (* valid mem *)
  iDestruct (gen_mem_valid ai wi with "mem mem_ins") as %Hlookup_ai.
  iDestruct (gen_mem_valid_SepM with "mem [mem_tx]") as %Hlookup_mem_tx.
  { iDestruct "mem_tx" as "[% mem_tx]". iExact "mem_tx". }
  (* valid tx *)
  iDestruct (mb_valid_tx i p_tx with "mb tx") as %Heq_tx.
  (* valid tran *)
  iSplit.
  - (* reducible *)
    iPureIntro.
    apply (reducible_normal i Hvc ai wi);eauto.
    rewrite Heq_tx //.
  - iModIntro.
    iIntros (m2 σ2) "vmprop_auth %HstepP".
    iFrame "vmprop_auth".
    apply (step_ExecI_normal i Hvc ai wi) in HstepP;eauto.
    2: rewrite Heq_tx //.
    remember (exec Hvc σ1) as c2 eqn:Heqc2.
    rewrite /exec /hvc Hlookup_R0 /= Hdecode_f /mem_send Hlookup_R1 /= in Heqc2.
    case_bool_decide;first lia.
    pose proof (parse_transaction_descriptor_length _ _ _ _ Hparse) as Hlt_pg.
    rewrite -Heq_tx -Heq_cur /len in Hparse.
    apply (parse_transaction_descriptor_tx _ σ1.1.2) in Hparse;last done.
    rewrite Hparse /= Heq_cur Hvalid_des /= in Heqc2.
    rewrite /check_transition_transaction /= in Heqc2.
    destruct tran as [[[? ?] ?] ps].
    rewrite /= in Heqc2.
    case_bool_decide.
    {
      specialize (H1 p Hin_p).
      rewrite andb_true_iff in H1.
      rewrite /check_excl_access_page andb_true_iff in H1.
      destruct H1 as [_ Hown].
      rewrite Heq_cur Hcheckpg_own_false in Hown.
      inversion Hown.
    }
    clear H1.
    simpl in Heqc2.
    assert (Heq_c2 : (m2,σ2) = (ExecI, update_incr_PC (update_reg (update_reg σ1 R0 (encode_hvc_ret_code Error)) R2 (encode_hvc_error Denied)))).
    {
      destruct hvcf; inversion Htt;
        destruct HstepP;subst m2 σ2; subst c2; done.
    }
    inversion Heq_c2. clear H2 H3 Heq_c2.
    rewrite /=.
    iDestruct (hvc_error_update (E:= ⊤) Denied with "PC R0 R2 [$Hnum $mem $regs $mb $rx_state $pgt_owned $pgt_acc $pgt_excl $ trans $hpool $retri]")
    as ">[[$ $] ?]". 1-4: auto. iPureIntro. auto.
    rewrite /scheduled /machine.scheduler /= /scheduler.
    rewrite p_upd_pc_current_vm 2!p_upd_reg_current_vm Heq_cur.
    case_bool_decide;last contradiction.
    simpl. iApply "HΦ".
    iFrame.
    by iFrame.
Qed.

Lemma mem_send_not_owned2 {i wi r0 r1 r2 hvcf p_tx tt q sacc} j ai p mem_tx tran :
  (tpa ai) ∈ sacc ->
  (tpa ai) ≠ p_tx ->
  let len := (Z.to_nat (finz.to_z r1)) in
  decode_instruction wi = Some(Hvc) ->
  decode_hvc_func r0 = Some(hvcf) ->
  hvcf_to_tt hvcf = Some tt ->
  (len <= page_size)%Z ->
  parse_transaction_descriptor mem_tx (of_pid p_tx) len = Some tran ->
  validate_transaction_descriptor i tran = true ->
  p ∈ tran.2 ->
  j ≠ i ->
  {SS{{ ▷(PC @@ i ->r ai) ∗
      ▷ ai ->a wi ∗
      ▷ i -@{q}A> sacc ∗
      ▷ (R0 @@ i ->r r0) ∗
      ▷ (R1 @@ i ->r r1) ∗
      ▷ (R2 @@ i ->r r2) ∗
      ▷ (TX@ i := p_tx) ∗
      ▷ (memory_page p_tx mem_tx) ∗
      ▷ p -@O> j
       }}}
   ExecI @ i {{{ RET (false, ExecI) ;
                 PC @@ i ->r (ai ^+ 1)%f ∗
                 ai ->a wi ∗
                 i -@{q}A> sacc ∗
                 R0 @@ i ->r (encode_hvc_ret_code Error) ∗
                 R1 @@ i ->r r1 ∗
                 R2 @@ i ->r (encode_hvc_error Denied) ∗
                 TX@ i := p_tx ∗
                 memory_page p_tx mem_tx ∗
                 p -@O> j
    }}}.
Proof.
  iIntros (Hin_acc Hneq_tx len Hdecode_i Hdecode_f Htt Hle_ps Hparse Hvalid_des Hin_p Hneq_i Φ)
          "(>PC & >mem_ins & >acc & >R0 & >R1 & >R2 & >tx & >mem_tx & >own) HΦ".
  iApply (sswp_lift_atomic_step ExecI);[done|].
  iIntros (n σ1) "%Hsche state".
  rewrite /scheduled /= /scheduler in Hsche.
  assert (σ1.1.1.2 = i) as Heq_cur. { case_bool_decide;last done. by apply fin_to_nat_inj. }
  clear Hsche.
  iModIntro.
  iDestruct "state" as "(Hnum & mem & regs & mb & rx_state & pgt_owned & pgt_acc & pgt_excl &
                            trans & hpool & retri & %Hwf & %Hdisj & %Hconsis)".
  (* valid regs *)
  iDestruct ((gen_reg_valid4 i PC ai R0 r0 R1 r1 R2 r2 Heq_cur) with "regs PC R0 R1 R2")
    as "(%Hlookup_PC & %Hlookup_R0 & %Hlookup_R1 & %Hlookup_R2)";eauto.
  (* valid pt *)
  iDestruct (access_agree_check_true (tpa ai) i with "pgt_acc acc") as %Hcheckpg_ai;eauto.
  iDestruct (own_agree_Some_check_false _ i with "pgt_owned own") as %Hcheckpg_own_false;auto.
  (* valid mem *)
  iDestruct (gen_mem_valid ai wi with "mem mem_ins") as %Hlookup_ai.
  iDestruct (gen_mem_valid_SepM with "mem [mem_tx]") as %Hlookup_mem_tx.
  { iDestruct "mem_tx" as "[% mem_tx]". iExact "mem_tx". }
  (* valid tx *)
  iDestruct (mb_valid_tx i p_tx with "mb tx") as %Heq_tx.
  (* valid tran *)
  iSplit.
  - (* reducible *)
    iPureIntro.
    apply (reducible_normal i Hvc ai wi);eauto.
    rewrite Heq_tx //.
  - iModIntro.
    iIntros (m2 σ2) "vmprop_auth %HstepP".
    iFrame "vmprop_auth".
    apply (step_ExecI_normal i Hvc ai wi) in HstepP;eauto.
    2: rewrite Heq_tx //.
    remember (exec Hvc σ1) as c2 eqn:Heqc2.
    rewrite /exec /hvc Hlookup_R0 /= Hdecode_f /mem_send Hlookup_R1 /= in Heqc2.
    case_bool_decide;first lia.
    pose proof (parse_transaction_descriptor_length _ _ _ _ Hparse) as Hlt_pg.
    rewrite -Heq_tx -Heq_cur /len in Hparse.
    apply (parse_transaction_descriptor_tx _ σ1.1.2) in Hparse;last done.
    rewrite Hparse /= Heq_cur Hvalid_des /= in Heqc2.
    rewrite /check_transition_transaction /= in Heqc2.
    destruct tran as [[[? ?] ?] ps].
    rewrite /= in Heqc2.
    case_bool_decide.
    {
      specialize (H1 p Hin_p).
      rewrite andb_true_iff in H1.
      rewrite /check_excl_access_page andb_true_iff in H1.
      destruct H1 as [_ Hown].
      rewrite Heq_cur Hcheckpg_own_false in Hown.
      inversion Hown.
    }
    clear H1.
    simpl in Heqc2.
    assert (Heq_c2 : (m2,σ2) = (ExecI, update_incr_PC (update_reg (update_reg σ1 R0 (encode_hvc_ret_code Error)) R2 (encode_hvc_error Denied)))).
    {
      destruct hvcf; inversion Htt;
        destruct HstepP;subst m2 σ2; subst c2; done.
    }
    inversion Heq_c2. clear H2 H3 Heq_c2.
    rewrite /=.
    iDestruct (hvc_error_update (E:= ⊤) Denied with "PC R0 R2 [$Hnum $mem $regs $mb $rx_state $pgt_owned $pgt_acc $pgt_excl $ trans $hpool $retri]")
    as ">[[$ $] ?]". 1-4: auto. iPureIntro. auto.
    rewrite /scheduled /machine.scheduler /= /scheduler.
    rewrite p_upd_pc_current_vm 2!p_upd_reg_current_vm Heq_cur.
    case_bool_decide;last contradiction.
    simpl. iApply "HΦ".
    iFrame.
    by iFrame.
Qed.

(* FIXME: It is not true since we have updated the excl RA, but it is not very important anyway.
 To prove it we need to change check_excl_page, or add a new invariant about the pagetable (size of acc R excl)*)
(* Lemma mem_send_not_excl {i wi r0 r1 r2 hvcf p_tx tt q sacc} ai p mem_tx tran : *)
(*   (tpa ai) ∈ sacc -> *)
(*   (tpa ai) ≠ p_tx -> *)
(*   let len := (Z.to_nat (finz.to_z r1)) in *)
(*   decode_instruction wi = Some(Hvc) -> *)
(*   decode_hvc_func r0 = Some(hvcf) -> *)
(*   hvcf_to_tt hvcf = Some tt -> *)
(*   (len <= page_size)%Z -> *)
(*   parse_transaction_descriptor mem_tx (of_pid p_tx) len = Some tran -> *)
(*   validate_transaction_descriptor i tran = true -> *)
(*   p ∈ tran.2 -> *)
(*   {SS{{ ▷(PC @@ i ->r ai) ∗ *)
(*       ▷ ai ->a wi ∗ *)
(*       ▷ i -@{q}A> sacc ∗ *)
(*       ▷ (R0 @@ i ->r r0) ∗ *)
(*       ▷ (R1 @@ i ->r r1) ∗ *)
(*       ▷ (R2 @@ i ->r r2) ∗ *)
(*       ▷ (TX@ i := p_tx) ∗ *)
(*       ▷ (memory_page p_tx mem_tx) ∗ *)
(*       ▷ (p -@E> false) *)
(*        }}} *)
(*    ExecI @ i {{{ RET (false, ExecI) ; *)
(*                  PC @@ i ->r (ai ^+ 1)%f ∗ *)
(*                  ai ->a wi ∗ *)
(*                  i -@{q}A> sacc ∗ *)
(*                  R0 @@ i ->r (encode_hvc_ret_code Error) ∗ *)
(*                  R1 @@ i ->r r1 ∗ *)
(*                  R2 @@ i ->r (encode_hvc_error Denied) ∗ *)
(*                  TX@ i := p_tx ∗ *)
(*                  memory_page p_tx mem_tx ∗ *)
(*                  p -@E> false *)
(*     }}}. *)
(* Proof. *)
(* Admitted. *)

Lemma mem_send_not_acc {i wi r0 r1 r2 hvcf p_tx tt sacc} ai p mem_tx tran:
  (tpa ai) ∈ sacc ->
  (tpa ai) ≠ p_tx ->
  let len := (Z.to_nat (finz.to_z r1)) in
  decode_instruction wi = Some(Hvc) ->
  decode_hvc_func r0 = Some(hvcf) ->
  hvcf_to_tt hvcf = Some tt ->
  (len <= page_size)%Z ->
  parse_transaction_descriptor mem_tx (of_pid p_tx) len = Some tran ->
  validate_transaction_descriptor i tran = true ->
  p ∈ tran.2 ->
  p ∉ sacc ->
  {SS{{ ▷(PC @@ i ->r ai) ∗
      ▷ ai ->a wi ∗
      ▷ (R0 @@ i ->r r0) ∗
      ▷ (R1 @@ i ->r r1) ∗
      ▷ (R2 @@ i ->r r2) ∗
      ▷ (TX@ i := p_tx) ∗
      ▷ (memory_page p_tx mem_tx) ∗
      ▷ (i -@A> sacc)
       }}}
   ExecI @ i {{{ RET (false, ExecI) ;
                 PC @@ i ->r (ai ^+ 1)%f ∗
                 ai ->a wi ∗
                 R0 @@ i ->r (encode_hvc_ret_code Error) ∗
                 R1 @@ i ->r r1 ∗
                 R2 @@ i ->r (encode_hvc_error Denied) ∗
                 TX@ i := p_tx ∗
                 memory_page p_tx mem_tx ∗
                 i -@A> sacc
    }}}.
Proof.
  iIntros (Hin_acc Hneq_tx len Hdecode_i Hdecode_f Htt Hle_ps Hparse Hvalid_des Hin_p Hnin_p Φ)
          "(>PC & >mem_ins & >R0 & >R1 & >R2 & >tx & >mem_tx & >acc) HΦ".
  iApply (sswp_lift_atomic_step ExecI);[done|].
  iIntros (n σ1) "%Hsche state".
  rewrite /scheduled /= /scheduler in Hsche.
  assert (σ1.1.1.2 = i) as Heq_cur. { case_bool_decide;last done. by apply fin_to_nat_inj. }
  clear Hsche.
  iModIntro.
  iDestruct "state" as "(Hnum & mem & regs & mb & rx_state & pgt_owned & pgt_acc & pgt_excl &
                            trans & hpool & retri & %Hwf & %Hdisj & %Hconsis)".
  (* valid regs *)
  iDestruct ((gen_reg_valid4 i PC ai R0 r0 R1 r1 R2 r2 Heq_cur) with "regs PC R0 R1 R2")
    as "(%Hlookup_PC & %Hlookup_R0 & %Hlookup_R1 & %Hlookup_R2)";eauto.
  (* valid pt *)
  iDestruct (access_agree_check_true (tpa ai) i with "pgt_acc acc") as %Hcheckpg_ai;eauto.
  iDestruct (access_agree_check_false p with "pgt_acc acc") as %Hcheckpg_acc_false;eauto.
  (* valid mem *)
  iDestruct (gen_mem_valid ai wi with "mem mem_ins") as %Hlookup_ai.
  iDestruct (gen_mem_valid_SepM with "mem [mem_tx]") as %Hlookup_mem_tx.
  { iDestruct "mem_tx" as "[% mem_tx]". iExact "mem_tx". }
  (* valid tx *)
  iDestruct (mb_valid_tx i p_tx with "mb tx") as %Heq_tx.
  (* valid tran *)
  iSplit.
  - (* reducible *)
    iPureIntro.
    apply (reducible_normal i Hvc ai wi);eauto.
    rewrite Heq_tx //.
  - iModIntro.
    iIntros (m2 σ2) "vmprop_auth %HstepP".
    iFrame "vmprop_auth".
    apply (step_ExecI_normal i Hvc ai wi) in HstepP;eauto.
    2: rewrite Heq_tx //.
    remember (exec Hvc σ1) as c2 eqn:Heqc2.
    rewrite /exec /hvc Hlookup_R0 /= Hdecode_f /mem_send Hlookup_R1 /= in Heqc2.
    case_bool_decide;first lia.
    pose proof (parse_transaction_descriptor_length _ _ _ _ Hparse) as Hlt_pg.
    rewrite -Heq_tx -Heq_cur /len in Hparse.
    apply (parse_transaction_descriptor_tx _ σ1.1.2) in Hparse;last done.
    rewrite Hparse /= Heq_cur Hvalid_des /= in Heqc2.
    rewrite /check_transition_transaction /= in Heqc2.
    destruct tran as [[[? ?] ?] ps].
    rewrite /= in Heqc2.
    case_bool_decide.
    {
      specialize (H1 p Hin_p).
      rewrite andb_true_iff in H1.
      rewrite /check_excl_access_page andb_true_iff in H1.
      destruct H1 as [[Hacc _] _].
      rewrite Heq_cur Hcheckpg_acc_false in Hacc.
      inversion Hacc.
    }
    clear H1.
    simpl in Heqc2.
    assert (Heq_c2 : (m2,σ2) = (ExecI, update_incr_PC (update_reg (update_reg σ1 R0 (encode_hvc_ret_code Error)) R2 (encode_hvc_error Denied)))).
    {
      destruct hvcf; inversion Htt;
        destruct HstepP;subst m2 σ2; subst c2; done.
    }
    inversion Heq_c2. clear H2 H3 Heq_c2.
    rewrite /=.
    iDestruct (hvc_error_update (E:= ⊤) Denied with "PC R0 R2 [$Hnum $mem $regs $mb $rx_state $pgt_owned $pgt_acc $pgt_excl $ trans $hpool $retri]")
    as ">[[$ $] ?]". 1-4: auto. iPureIntro. auto.
    rewrite /scheduled /machine.scheduler /= /scheduler.
    rewrite p_upd_pc_current_vm 2!p_upd_reg_current_vm Heq_cur.
    case_bool_decide;last contradiction.
    simpl. iApply "HΦ".
    iFrame.
    by iFrame.
Qed.

Lemma mem_send_in_trans {i wi r0 r1 r2 hvcf p_tx tt tran q tran' q' sacc} ai p wh mem_tx:
  (tpa ai) ∈ sacc ->
  (tpa ai) ≠ p_tx ->
  let len := (Z.to_nat (finz.to_z r1)) in
  decode_instruction wi = Some(Hvc) ->
  decode_hvc_func r0 = Some(hvcf) ->
  hvcf_to_tt hvcf = Some tt ->
  (len <= page_size)%Z ->
  parse_transaction_descriptor mem_tx (of_pid p_tx) len = Some tran ->
  validate_transaction_descriptor i tran = true ->
  p ∈ tran.2 ->
  p ∈ tran'.1.2 ->
  {SS{{ ▷(PC @@ i ->r ai) ∗
      ▷ ai ->a wi ∗
      ▷ i -@{q'}A> sacc ∗
      ▷ (R0 @@ i ->r r0) ∗
      ▷ (R1 @@ i ->r r1) ∗
      ▷ (R2 @@ i ->r r2) ∗
      ▷ (TX@ i := p_tx) ∗
      ▷ (memory_page p_tx mem_tx) ∗
      ▷ (wh -{q}>t tran')
       }}}
   ExecI @ i {{{ RET (false, ExecI) ;
                 PC @@ i ->r (ai ^+ 1)%f ∗
                 ai ->a wi ∗
                 i -@{q'}A> sacc ∗
                 R0 @@ i ->r (encode_hvc_ret_code Error) ∗
                 R1 @@ i ->r r1 ∗
                 R2 @@ i ->r (encode_hvc_error Denied) ∗
                 TX@ i := p_tx ∗
                 memory_page p_tx mem_tx ∗
                 wh -{q}>t tran'
    }}}.
Proof.
  iIntros (Hin_acc Hneq_tx len Hdecode_i Hdecode_f Htt Hle_ps Hparse Hvalid_des Hin_p Hin_p' Φ)
          "(>PC & >mem_ins & >acc & >R0 & >R1 & >R2 & >tx & >mem_tx & >tran) HΦ".
  iApply (sswp_lift_atomic_step ExecI);[done|].
  iIntros (n σ1) "%Hsche state".
  rewrite /scheduled /= /scheduler in Hsche.
  assert (σ1.1.1.2 = i) as Heq_cur. { case_bool_decide;last done. by apply fin_to_nat_inj. }
  clear Hsche.
  iModIntro.
  iDestruct "state" as "(Hnum & mem & regs & mb & rx_state & pgt_owned & pgt_acc & pgt_excl &
                            trans & hpool & retri & %Hwf & %Hdisj & %Hconsis)".
  (* valid regs *)
  iDestruct ((gen_reg_valid4 i PC ai R0 r0 R1 r1 R2 r2 Heq_cur) with "regs PC R0 R1 R2")
    as "(%Hlookup_PC & %Hlookup_R0 & %Hlookup_R1 & %Hlookup_R2)";eauto.
  (* valid pt *)
  iDestruct (access_agree_check_true (tpa ai) i with "pgt_acc acc") as %Hcheckpg_ai;eauto.
  iDestruct (access_agree_check_true_forall with "pgt_acc acc") as %Hcheckpg_acc;eauto.
  (* valid mem *)
  iDestruct (gen_mem_valid ai wi with "mem mem_ins") as %Hlookup_ai.
  iDestruct (gen_mem_valid_SepM with "mem [mem_tx]") as %Hlookup_mem_tx.
  { iDestruct "mem_tx" as "[% mem_tx]". iExact "mem_tx". }
  (* valid tx *)
  iDestruct (mb_valid_tx i p_tx with "mb tx") as %Heq_tx.
  (* valid tran *)
  iDestruct (trans_valid_Some with "trans tran") as %[re Hlookup_tran].
  iSplit.
  - (* reducible *)
    iPureIntro.
    apply (reducible_normal i Hvc ai wi);eauto.
    rewrite Heq_tx //.
  - iModIntro.
    iIntros (m2 σ2) "vmprop_auth %HstepP".
    iFrame "vmprop_auth".
    apply (step_ExecI_normal i Hvc ai wi) in HstepP;eauto.
    2: rewrite Heq_tx //.
    remember (exec Hvc σ1) as c2 eqn:Heqc2.
    rewrite /exec /hvc Hlookup_R0 /= Hdecode_f /mem_send Hlookup_R1 /= in Heqc2.
    case_bool_decide;first lia.
    pose proof (parse_transaction_descriptor_length _ _ _ _ Hparse) as Hlt_pg.
    rewrite -Heq_tx -Heq_cur /len in Hparse.
    apply (parse_transaction_descriptor_tx _ σ1.1.2) in Hparse;last done.
    rewrite Hparse /= Heq_cur Hvalid_des /= in Heqc2.
    rewrite /check_transition_transaction /= in Heqc2.
    destruct tran as [[[? ?] ?] ps].
    rewrite /= in Heqc2.
    case_bool_decide.
    {
      specialize (Hconsis wh _ Hlookup_tran p Hin_p').
      simpl in Hconsis.
      specialize (H1 p Hin_p).
         rewrite andb_true_iff in H1.
      rewrite /check_excl_access_page andb_true_iff /check_access_page /check_excl_page /check_ownership_page in H1.
      destruct tran'.2, re;first done;rewrite Hconsis in H1;
      destruct H1 as [[Hacc Hexcl] Hown].
      destruct (decide (σ1.1.1.2 ∈ ∅));done.
      inversion Hexcl.
      inversion Hexcl.
      destruct (decide (σ1.1.1.2 ∈ {[tran'.1.1.2]})).
      apply elem_of_singleton in e.
      destruct (decide (σ1.1.1.2 = tran'.1.1.1)).
      rewrite e0 in e.
      destruct Hwf as [_ [Hwf _]].
      specialize (Hwf wh _ Hlookup_tran).
      done.
      inversion Hown.
      inversion Hacc.
      destruct (decide (σ1.1.1.2 ∈ ∅));done.
    }
    clear H1.
    simpl in Heqc2.
    assert (Heq_c2 : (m2,σ2) = (ExecI, update_incr_PC (update_reg (update_reg σ1 R0 (encode_hvc_ret_code Error)) R2 (encode_hvc_error Denied)))).
    {
      destruct hvcf; inversion Htt;
        destruct HstepP;subst m2 σ2; subst c2; done.
    }
    inversion Heq_c2. clear H2 H3 Heq_c2.
    rewrite /=.
    iDestruct (hvc_error_update (E:= ⊤) Denied with "PC R0 R2 [$Hnum $mem $regs $mb $rx_state $pgt_owned $pgt_acc $pgt_excl $ trans $hpool $retri]")
    as ">[[$ $] ?]". 1-4: auto. iPureIntro. auto.
    rewrite /scheduled /machine.scheduler /= /scheduler.
    rewrite p_upd_pc_current_vm 2!p_upd_reg_current_vm Heq_cur.
    case_bool_decide;last contradiction.
    simpl. iApply "HΦ".
    iFrame.
    by iFrame.
Qed.

Lemma mem_send_no_fresh_handles {i wi r0 r1 r2 hvcf tt p_tx sacc} ai sh j mem_tx (ps: gset PID):
  (tpa ai) ∈ sacc ->
  (tpa ai) ≠ p_tx ->
  let len := (Z.to_nat (finz.to_z r1)) in
  decode_instruction wi = Some(Hvc) ->
  decode_hvc_func r0 = Some(hvcf) ->
  hvcf_to_tt hvcf = Some tt ->
  (len <= page_size)%Z ->
  parse_transaction_descriptor mem_tx (of_pid p_tx) len = Some (i, None, j, ps) ->
  i ≠ j ->
  ps ⊆ sacc ->
  sh = ∅ ->
  {SS{{ ▷(PC @@ i ->r ai) ∗
      ▷ ai ->a wi ∗
      ▷ ([∗ set] p ∈ ps, p -@O> i ∗ p -@E> true) ∗
      ▷ (i -@A> sacc) ∗
      ▷ (R0 @@ i ->r r0) ∗
      ▷ (R1 @@ i ->r r1) ∗
      ▷ (R2 @@i ->r r2) ∗
      ▷ (fresh_handles 1 sh) ∗
      ▷ TX@ i := p_tx ∗
      ▷ memory_page p_tx mem_tx
       }}}
   ExecI @ i {{{ RET (false, ExecI) ;
                 PC @@ i ->r (ai ^+ 1)%f ∗
                 ai ->a wi ∗
                 ([∗ set] p ∈ ps, p -@O> i ∗ p -@E> true) ∗
                 i -@A> sacc ∗
                 R0 @@ i ->r (encode_hvc_ret_code Error) ∗
                 R1 @@ i ->r r1 ∗
                 R2 @@ i ->r (encode_hvc_error NoMem) ∗
                 fresh_handles 1 sh ∗
                 TX@ i := p_tx ∗
                 memory_page p_tx mem_tx}}}.
Proof.
  iIntros (Hin_acc Hneq_tx len Hdecode_i Hdecode_f Htt Hle_ps Hparse Hneq_vmid Hsubseteq_acc Heq_hp Φ)
          "(>PC & >mem_ins & >oe & >acc & >R0 & >R1 & >R2 & >[hp handles] & >tx & >mem_tx) HΦ".
  iApply (sswp_lift_atomic_step ExecI);[done|].
  iIntros (n σ1) "%Hsche state".
  rewrite /scheduled /= /scheduler in Hsche.
  assert (σ1.1.1.2 = i) as Heq_cur. { case_bool_decide;last done. by apply fin_to_nat_inj. }
  clear Hsche.
  iModIntro.
  iDestruct "state" as "(Hnum & mem & regs & mb & rx_state & pgt_owned & pgt_acc & pgt_excl &
                            trans & hpool & retri & %Hwf & %Hdisj & %Hconsis)".
  (* valid regs *)
  iDestruct ((gen_reg_valid4 i PC ai R0 r0 R1 r1 R2 r2 Heq_cur) with "regs PC R0 R1 R2")
    as "(%Hlookup_PC & %Hlookup_R0 & %Hlookup_R1 & %Hlookup_R2)";eauto.
  (* valid pt *)
  iDestruct (access_agree_check_true (tpa ai) i with "pgt_acc acc") as %Hcheckpg_ai;eauto.
  iDestruct (access_agree_check_true_forall with "pgt_acc acc") as %Hcheckpg_acc;eauto.
  iDestruct (big_sepS_sep with "oe") as "[own excl]".
  iDestruct (excl_agree_Some_check_true_bigS with "pgt_excl excl") as %Hcheckpg_excl;eauto.
  iDestruct (own_agree_Some_check_true_bigS with "pgt_owned own") as %Hcheckpg_own;eauto.
  (* valid mem *)
  iDestruct (gen_mem_valid ai wi with "mem mem_ins") as %Hlookup_ai.
  iDestruct (gen_mem_valid_SepM with "mem [mem_tx]") as %Hlookup_mem_tx.
  { iDestruct "mem_tx" as "[% mem_tx]". iExact "mem_tx". }
  (* valid tx *)
  iDestruct (mb_valid_tx i p_tx with "mb tx") as %Heq_tx.
  (* valid hpool *)
  iDestruct (hpool_valid with "hpool hp") as %Heq_hp'.
  iSplit.
  - (* reducible *)
    iPureIntro.
    apply (reducible_normal i Hvc ai wi);eauto.
    rewrite Heq_tx //.
  - iModIntro.
    iIntros (m2 σ2) "vmprop_auth %HstepP".
    iFrame "vmprop_auth".
    apply (step_ExecI_normal i Hvc ai wi) in HstepP;eauto.
    2: rewrite Heq_tx //.
    remember (exec Hvc σ1) as c2 eqn:Heqc2.
    rewrite /exec /hvc Hlookup_R0 /= Hdecode_f /mem_send Hlookup_R1 /= in Heqc2.
    case_bool_decide;first lia.
    pose proof (parse_transaction_descriptor_length _ _ _ _ Hparse) as Hlt_pg.
    rewrite -Heq_tx -Heq_cur /len in Hparse.
    apply (parse_transaction_descriptor_tx _ σ1.1.2) in Hparse;last done.
    rewrite Hparse //= in Heqc2.
    case_bool_decide.
    2: { destruct H1. split;auto. split;eauto. rewrite Heq_cur //. }
    case_bool_decide.
    2: { destruct H2. intros s Hin.
         rewrite Heq_cur.
         rewrite andb_true_iff. split.
         rewrite /check_excl_access_page.
         rewrite andb_true_iff. split.
         apply Hcheckpg_acc.
         set_solver + Hsubseteq_acc Hin.
         by apply Hcheckpg_excl.
         by apply Hcheckpg_own.
    }
    clear H1 H2.
    rewrite /new_transaction /= /fresh_handle /= -Heq_hp' Heq_hp in Heqc2.
    rewrite elements_empty /= in Heqc2.
    assert (Heq_c2 : (m2,σ2) = (ExecI, update_incr_PC (update_reg (update_reg σ1 R0 (encode_hvc_ret_code Error)) R2 (encode_hvc_error NoMem)))).
    {
    destruct hvcf; inversion Htt;
      destruct HstepP;subst m2 σ2; subst c2; done.
    }
    inversion Heq_c2. clear H2 H3 Heq_c2.
    rewrite /=.
    iDestruct (hvc_error_update (E:= ⊤) NoMem with "PC R0 R2 [$Hnum $mem $regs $mb $rx_state $pgt_owned $pgt_acc $pgt_excl $ trans $hpool $retri]")
    as ">[[$ $] ?]". 1-4: auto. iPureIntro. auto.
    rewrite /scheduled /machine.scheduler /= /scheduler.
    rewrite p_upd_pc_current_vm 2!p_upd_reg_current_vm Heq_cur.
    case_bool_decide;last contradiction.
    simpl. iApply "HΦ".
    iFrame.
    rewrite big_sepS_sep. by iFrame.
Qed.

Lemma mem_share {i wi r0 r1 r2 hvcf p_tx sacc} ai j mem_tx sh (ps: gset PID) :
  (tpa ai) ∈ sacc ->
  (tpa ai) ≠ p_tx ->
  (* len is the length of the msg *)
  let len := (Z.to_nat (finz.to_z r1)) in
  (* the decoding of wi is correct *)
  decode_instruction wi = Some(Hvc) ->
  (* the decoding of R0 is a FFA mem_share *)
  decode_hvc_func r0 = Some(hvcf) ->
  hvcf_to_tt hvcf = Some Sharing ->
  (* the whole descriptor resides in the TX page *)
  (len <= page_size)%Z ->
  (* the descriptor *)
  parse_transaction_descriptor mem_tx (of_pid p_tx) len = Some (i, None, j, ps) ->
  (* caller is not the receiver *)
  i ≠ j ->
  ps ⊆ sacc ->
  (* there is at least one free handle in the hpool *)
  sh ≠ ∅ ->
  {SS{{ ▷(PC @@ i ->r ai) ∗
      ▷ ai ->a wi ∗
      (* VM i exclusively owns pages in ps *)
      ▷ ([∗ set] p ∈ ps, p -@O> i ∗ p -@E> true) ∗
      ▷ (i -@A> sacc) ∗
      ▷ (R0 @@ i ->r r0) ∗
      ▷ (R1 @@ i ->r r1) ∗
      ▷ (R2 @@i ->r r2) ∗
      ▷ (fresh_handles 1 sh) ∗
      ▷ TX@ i := p_tx ∗
      ▷ memory_page p_tx mem_tx
       }}}
   ExecI @ i {{{ RET (false, ExecI) ;
                 PC @@ i ->r (ai ^+ 1)%f ∗
                 ai ->a wi ∗
                 ([∗ set] p ∈ ps, p -@O> i ∗ p -@E> false) ∗
                 i -@A> sacc ∗
                 R0 @@ i ->r (encode_hvc_ret_code Succ) ∗
                 R1 @@ i ->r r1 ∗
                 (∃ (wh: Word), ⌜wh ∈ sh⌝ ∗
                 R2 @@ i ->r wh ∗
                 wh ->t (i, j, ps, Sharing) ∗
                 wh ->re false ∗
                 fresh_handles 1 (sh∖{[wh]})) ∗
                 TX@ i := p_tx ∗
                 memory_page p_tx mem_tx}}}.
Proof.
  iIntros (Hin_acc Hneq_tx len Hdecode_i Hdecode_f Htt Hle_ps Hparse Hneq_vmid Hsubseteq_acc Hneq_hp Φ)
          "(>PC & >mem_ins & >oe & >acc & >R0 & >R1 & >R2 & >[hp handles] & >tx & >mem_tx) HΦ".
  iApply (sswp_lift_atomic_step ExecI);[done|].
  iIntros (n σ1) "%Hsche state".
  rewrite /scheduled /= /scheduler in Hsche.
  assert (σ1.1.1.2 = i) as Heq_cur. { case_bool_decide;last done. by apply fin_to_nat_inj. }
  clear Hsche.
  iModIntro.
  iDestruct "state" as "(Hnum & mem & regs & mb & rx_state & pgt_owned & pgt_acc & pgt_excl &
                            trans & hpool & retri & %Hwf & %Hdisj & %Hconsis)".
  (* valid regs *)
  iDestruct ((gen_reg_valid4 i PC ai R0 r0 R1 r1 R2 r2 Heq_cur) with "regs PC R0 R1 R2")
    as "(%Hlookup_PC & %Hlookup_R0 & %Hlookup_R1 & %Hlookup_R2)";eauto.
  (* valid pt *)
  iDestruct (access_agree_check_true (tpa ai) i with "pgt_acc acc") as %Hcheckpg_ai;eauto.
  iDestruct (access_agree_check_true_forall with "pgt_acc acc") as %Hcheckpg_acc;eauto.
  iDestruct (big_sepS_sep with "oe") as "[own excl]".
  iDestruct (excl_agree_Some_check_true_bigS with "pgt_excl excl") as %Hcheckpg_excl;eauto.
  iDestruct (excl_agree_Some_lookup_bigS with "pgt_excl excl") as %Hvalid_excl;eauto.
  iDestruct (own_agree_Some_check_true_bigS with "pgt_owned own") as %Hcheckpg_own;eauto.
  (* valid mem *)
  iDestruct (gen_mem_valid ai wi with "mem mem_ins") as %Hlookup_ai.
  iDestruct (gen_mem_valid_SepM with "mem [mem_tx]") as %Hlookup_mem_tx.
  { iDestruct "mem_tx" as "[% mem_tx]". iExact "mem_tx". }
  (* valid tx *)
  iDestruct (mb_valid_tx i p_tx with "mb tx") as %Heq_tx.
  (* valid hpool *)
  iDestruct (hpool_valid with "hpool hp") as %Heq_hp.
  iSplit.
  - (* reducible *)
    iPureIntro.
    apply (reducible_normal i Hvc ai wi);eauto.
    rewrite Heq_tx //.
  - iModIntro.
    iIntros (m2 σ2) "vmprop_auth %HstepP".
    iFrame "vmprop_auth".
    apply (step_ExecI_normal i Hvc ai wi) in HstepP;eauto.
    2: rewrite Heq_tx //.
    remember (exec Hvc σ1) as c2 eqn:Heqc2.
    destruct hvcf; inversion Htt.
    rewrite /exec /hvc Hlookup_R0 /= Hdecode_f /mem_send Hlookup_R1 /= in Heqc2.
    case_bool_decide;first lia.
    pose proof (parse_transaction_descriptor_length _ _ _ _ Hparse) as Hlt_pg.
    rewrite -Heq_tx -Heq_cur /len in Hparse.
    apply (parse_transaction_descriptor_tx _ σ1.1.2) in Hparse;last done.
    rewrite Hparse //= in Heqc2.
    case_bool_decide.
    2: { destruct H1. split;auto. split;eauto. rewrite Heq_cur //. }
    case_bool_decide.
    2: { destruct H2. intros s Hin.
         rewrite Heq_cur.
         rewrite andb_true_iff. split.
         rewrite /check_excl_access_page.
         rewrite andb_true_iff. split.
         apply Hcheckpg_acc.
         set_solver + Hsubseteq_acc Hin.
         by apply Hcheckpg_excl.
         by apply Hcheckpg_own.
    }
    clear H1 H2.
    rewrite /new_transaction /= /fresh_handle /= -Heq_hp in Heqc2.
    destruct (elements sh) as [| h fhs] eqn:Hfhs.
    { exfalso. rewrite -(elements_empty (A:= Word) (C:= gset Word)) in Hfhs. apply Hneq_hp. apply set_eq.
      intro. rewrite -elem_of_elements Hfhs elem_of_elements. split;intro;set_solver. }
    destruct HstepP;subst m2 σ2; subst c2; simpl.
    rewrite /gen_vm_interp.
    (* unchanged part *)
    rewrite (preserve_get_mb_gmap σ1).
    rewrite (preserve_get_rx_gmap σ1).
    all: try rewrite p_upd_pc_mb //.
    rewrite p_upd_pc_mem 2!p_upd_reg_mem p_flip_excl_mem p_alloc_tran_mem.
    iFrame "Hnum mem rx_state mb".
    (* upd regs *)
    rewrite Heq_cur.
    rewrite (u_upd_pc_regs _ i ai) //.
    2: { rewrite 2!u_upd_reg_regs.
         rewrite (preserve_get_reg_gmap σ1). rewrite lookup_insert_ne //.  rewrite lookup_insert_ne //. solve_reg_lookup. done.
    }
    rewrite u_upd_reg_regs p_upd_reg_current_vm p_flip_excl_current_vm p_alloc_tran_current_vm  Heq_cur.
    rewrite u_upd_reg_regs p_flip_excl_current_vm p_alloc_tran_current_vm  Heq_cur.
    rewrite (preserve_get_reg_gmap σ1) //.
    iDestruct ((gen_reg_update3_global PC i (ai ^+ 1)%f R2 i h R0 i (encode_hvc_ret_code Succ)) with "regs PC R2 R0")
      as ">[$ [PC [R2 R0]]]";eauto.
    (* upd pgt *)
    rewrite (preserve_get_own_gmap (update_page_table_global flip_excl (alloc_transaction σ1 h (i, j, ps, Sharing, false)) i ps) (update_incr_PC _)).
    2: rewrite p_upd_pc_pgt !p_upd_reg_pgt //.
    rewrite p_flip_excl_own. rewrite (preserve_get_own_gmap σ1) //.
    iFrame "pgt_owned".
    rewrite (preserve_get_access_gmap (update_page_table_global flip_excl (alloc_transaction σ1 h (i, j, ps, Sharing, false)) i ps) (update_incr_PC _)).
    2: rewrite p_upd_pc_pgt p_upd_reg_pgt //.
    rewrite p_flip_excl_acc. rewrite (preserve_get_access_gmap σ1) //.
    iFrame "pgt_acc".
    rewrite (preserve_get_excl_gmap (update_page_table_global flip_excl (alloc_transaction σ1 h (i, j, ps, Sharing, false)) i ps) (update_incr_PC _)).
    2: rewrite p_upd_pc_pgt p_upd_reg_pgt //.
    assert (Hvalid_acc: set_Forall (λ p : PID,
      ∃ e : option VMID * bool * gset VMID, σ1.1.1.1.2 !! p = Some e ∧ e.2 = {[i]}) ps).
    {
      intros p Hin.
      specialize (Hcheckpg_acc p).
      feed specialize Hcheckpg_acc. set_solver + Hin Hsubseteq_acc.
      specialize (Hvalid_excl p Hin).
      destruct Hvalid_excl as [o [b [s [Hlk Htrue]]]].
      symmetry in Htrue.
      rewrite andb_true_iff in Htrue.
      destruct Htrue as [-> Hsize].
      rewrite /check_access_page /= in Hcheckpg_acc.
      rewrite Hlk in Hcheckpg_acc.
      destruct (decide (i ∈ s)); last done.
      case_bool_decide;last done.
      exists (o, true, s). split;auto.
      apply size_singleton_le;auto.
    }
    rewrite u_flip_excl_excl //.
    iDestruct (excl_update_flip with "pgt_excl excl") as ">[$ excl]".
    (* upd tran *)
    rewrite (preserve_get_trans_gmap (alloc_transaction σ1 h (i, j, ps, Sharing, false)) (update_incr_PC _)).
    2: rewrite p_upd_pc_trans p_upd_reg_trans  //.
    rewrite u_alloc_tran_trans.
    assert (sh = {[h]} ∪ sh ∖ {[h]}) as Heq_sh.
    { assert (h ∈ sh).
      rewrite -elem_of_elements. rewrite Hfhs. set_solver +.
      rewrite union_comm_L.
      rewrite difference_union_L.
      set_solver + H1.
    }
    iPoseProof (big_sepS_union _ {[h]} (sh ∖ {[h]})) as "[H _]".
    set_solver +.
    iDestruct ("H" with "[handles]") as "[h handles]".
    rewrite -Heq_sh. iExact "handles".
    rewrite big_sepS_singleton. iDestruct "h" as "[tran re]". iClear "H".
    iDestruct (trans_valid_None with "trans tran") as %Hlookup_tran.
    iDestruct (trans_update_insert h (i, j, ps, Sharing) with "trans tran") as ">[$ tran]".
    { rewrite /valid_transaction //=. }
    (* upd hp *)
    rewrite (preserve_get_hpool_gset (alloc_transaction σ1 h (i, j, ps, Sharing, false)) (update_incr_PC _)).
    2: rewrite p_upd_pc_trans p_upd_reg_trans //. rewrite u_alloc_tran_hpool.
    iDestruct (hpool_update_diff h with "hpool hp") as ">[$ hp]".
    (* upd retri *)
    rewrite (preserve_get_retri_gmap (alloc_transaction σ1 h (i, j, ps, Sharing, false)) (update_incr_PC _)).
    2: rewrite p_upd_pc_trans p_upd_reg_trans //. rewrite u_alloc_tran_retri.
    iDestruct (retri_update_insert with "retri re") as ">[$ re]".
    (* inv_trans_wellformed *)
    rewrite (preserve_inv_trans_wellformed (alloc_transaction σ1 h (i, j, ps, Sharing, false))).
    2: rewrite p_upd_pc_trans p_upd_reg_trans //.
    iAssert (⌜inv_trans_wellformed (alloc_transaction σ1 h (i, j, ps, Sharing, false))⌝%I) as "$".
    iPureIntro.
    apply (p_alloc_tran_inv_wf h (i, j, ps, Sharing, false));auto.
    simpl. simpl in Hlt_pg. rewrite Z.leb_le. lia.
    (* inv_trans_pgt_consistent *)
    rewrite (preserve_inv_trans_pgt_consistent (update_page_table_global flip_excl (alloc_transaction σ1 h (i, j, ps, Sharing, false)) i ps) (update_incr_PC _)).
    2: rewrite p_upd_pc_trans p_upd_reg_trans //.
    2: rewrite p_upd_pc_pgt p_upd_reg_pgt //.
    iAssert (⌜inv_trans_pgt_consistent (update_page_table_global flip_excl (alloc_transaction σ1 h (i, j, ps, Sharing, false)) i ps)⌝%I) as "$".
    iPureIntro.
    apply p_share_inv_consist;auto.
    { destruct Hwf as [_ [? _]]. done. }
    {
      intros p Hin.
      specialize (Hvalid_excl p Hin).
      specialize (Hcheckpg_own p Hin).
      specialize (Hvalid_acc p Hin).
      destruct Hvalid_excl as [o [b [s [Hlk Htrue]]]].
      symmetry in Htrue.
      rewrite andb_true_iff in Htrue.
      destruct Htrue as [-> Hsize].
      rewrite /check_ownership_page /= in Hcheckpg_own.
      rewrite Hlk in Hcheckpg_own.
      destruct o;last done.
      destruct (decide (i = v));last done.
      subst v.
      rewrite Hlk in Hvalid_acc.
      destruct Hvalid_acc as [? [? ?]].
      inversion H1. subst x.
      rewrite /= in H2. subst s. done.
    }
    (* inv_trans_ps_disj *)
    rewrite (preserve_inv_trans_ps_disj (alloc_transaction σ1 h (i, j, ps, Sharing, false))).
    2: rewrite p_upd_pc_trans p_upd_reg_trans //.
    iAssert (⌜inv_trans_ps_disj (alloc_transaction σ1 h (i, j, ps, Sharing, false))⌝%I) as "$". iPureIntro.
    apply p_alloc_tran_inv_disj;auto.
    {
      rewrite /= elem_of_disjoint.
      intros.
      apply elem_of_pages_in_trans' in H2.
      destruct H2 as [h' [tran' [Hlk Hin_h']]].
      specialize (Hconsis h' (Some tran') Hlk x Hin_h').
      specialize (Hvalid_acc x H1).
      destruct Hvalid_acc as [e [Hlk' He]].
      destruct Hwf as [_ [Hneq _]].
      specialize (Hneq h' _ Hlk).
      destruct (tran'.1.2);destruct tran'.2;auto.
      - rewrite Hlk' in Hconsis.
        inversion Hconsis.
        subst e. set_solver + He.
      - rewrite Hlk' in Hconsis.
        inversion Hconsis.
        subst e. simpl in He.
        set_solver + He Hneq.
      - specialize (Hvalid_excl x H1).
        destruct Hvalid_excl as [? [? [? [Hlk'' Htrue]]]].
        symmetry in Htrue.
        rewrite andb_true_iff in Htrue.
        destruct Htrue  as [-> _].
        rewrite Hlk'' in Hconsis.
        inversion Hconsis.
      - specialize (Hcheckpg_own x H1).
        rewrite /check_ownership_page /= in Hcheckpg_own.
        rewrite Hlk' in Hcheckpg_own.
        rewrite Hlk' in Hconsis.
        inversion Hconsis.
        subst e.
        destruct (decide (i = tran'.1.1.1.1));last done.
        set_solver + e He Hneq.
      - rewrite Hlk' in Hconsis.
        inversion Hconsis.
        subst e. set_solver + He.
    }
    (* just_scheduled *)
    iModIntro.
    rewrite /just_scheduled_vms /just_scheduled.
    rewrite /scheduled /machine.scheduler /= /scheduler.
    rewrite p_upd_pc_current_vm 2!p_upd_reg_current_vm p_flip_excl_current_vm  p_alloc_tran_current_vm.
    rewrite Heq_cur.
    iSplitL "".
    set fl := (filter _ _).
    assert (fl = []) as ->.
    {
      rewrite /fl.
      induction n.
      - simpl.
        rewrite filter_nil //=.
      - rewrite seq_S.
        rewrite filter_app.
        rewrite IHn.
        simpl.
        rewrite filter_cons_False //=.
        rewrite andb_negb_l.
        done.
    }
    by iSimpl.
    (* Φ *)
    case_bool_decide;last done.
    simpl. iApply "HΦ".
    rewrite /fresh_handles. iFrame.
    iSplitL "own excl".
    rewrite big_sepS_sep. iFrame.
    iExists h. iFrame.
    rewrite Heq_sh.
    iPureIntro. set_solver +.
Qed.

Lemma mem_not_share {i wi r0 r1 r2 hvcf p_tx sacc} tt ai j mem_tx sh (ps: gset PID) :
  tt ≠ Sharing ->
  (tpa ai) ∈ sacc ->
  (tpa ai) ≠ p_tx ->
  (* len is the length of the msg *)
  let len := (Z.to_nat (finz.to_z r1)) in
  (* the decoding of wi is correct *)
  decode_instruction wi = Some(Hvc) ->
  (* the decoding of R0 is a FFA mem_share *)
  decode_hvc_func r0 = Some(hvcf) ->
  hvcf_to_tt hvcf = Some tt ->
  (* the whole descriptor resides in the TX page *)
  (len <= page_size)%Z ->
  (* the descriptor *)
  parse_transaction_descriptor mem_tx (of_pid p_tx) len = Some (i, None, j, ps) ->
  (* caller is not the receiver *)
  i ≠ j ->
  ps ⊆ sacc ->
  (* there is at least one free handle in the hpool *)
  sh ≠ ∅ ->
  {SS{{ ▷(PC @@ i ->r ai) ∗
      ▷ ai ->a wi ∗
      (* VM i exclusively owns pages in ps *)
      ▷ ([∗ set] p ∈ ps, p -@O> i ∗ p -@E> true) ∗
      ▷ (i -@A> sacc) ∗
      ▷ (R0 @@ i ->r r0) ∗
      ▷ (R1 @@ i ->r r1) ∗
      ▷ (R2 @@i ->r r2) ∗
      ▷ (fresh_handles 1 sh) ∗
      ▷ TX@ i := p_tx ∗
      ▷ memory_page p_tx mem_tx
       }}}
   ExecI @ i {{{ RET (false, ExecI) ;
                 PC @@ i ->r (ai ^+ 1)%f ∗
                 ai ->a wi ∗
                 ([∗ set] p ∈ ps, p -@O> i ∗ p -@E> true) ∗
                 i -@A> (sacc ∖ ps) ∗
                 R0 @@ i ->r (encode_hvc_ret_code Succ) ∗
                 R1 @@ i ->r r1 ∗
                 (∃ (wh: Word), ⌜wh ∈ sh⌝ ∗
                 R2 @@ i ->r wh ∗
                 wh ->t (i, j, ps, tt) ∗
                 wh ->re false ∗
                 fresh_handles 1 (sh∖{[wh]})) ∗
                 TX@ i := p_tx ∗
                 memory_page p_tx mem_tx}}}.
Proof.
  iIntros (Hneq_tt Hin_acc Hneq_tx len Hdecode_i Hdecode_f Htt Hle_ps Hparse Hneq_vmid Hsubseteq_acc Hneq_hp Φ)
          "(>PC & >mem_ins & >oe & >acc & >R0 & >R1 & >R2 & >[hp handles] & >tx & >mem_tx) HΦ".
  iApply (sswp_lift_atomic_step ExecI);[done|].
  iIntros (n σ1) "%Hsche state".
  rewrite /scheduled /= /scheduler in Hsche.
  assert (σ1.1.1.2 = i) as Heq_cur. { case_bool_decide;last done. by apply fin_to_nat_inj. }
  clear Hsche.
  iModIntro.
  iDestruct "state" as "(Hnum & mem & regs & mb & rx_state & pgt_owned & pgt_acc & pgt_excl &
                            trans & hpool & retri & %Hwf & %Hdisj & %Hconsis)".
  (* valid regs *)
  iDestruct ((gen_reg_valid4 i PC ai R0 r0 R1 r1 R2 r2 Heq_cur) with "regs PC R0 R1 R2")
    as "(%Hlookup_PC & %Hlookup_R0 & %Hlookup_R1 & %Hlookup_R2)";eauto.
  (* valid pt *)
  iDestruct (access_agree_check_true (tpa ai) i with "pgt_acc acc") as %Hcheckpg_ai;eauto.
  iDestruct (access_agree_check_true_forall with "pgt_acc acc") as %Hcheckpg_acc;eauto.
  iDestruct (big_sepS_sep with "oe") as "[own excl]".
  iDestruct (excl_agree_Some_check_true_bigS with "pgt_excl excl") as %Hcheckpg_excl;eauto.
  iDestruct (excl_agree_Some_lookup_bigS with "pgt_excl excl") as %Hvalid_excl;eauto.
  iDestruct (own_agree_Some_check_true_bigS with "pgt_owned own") as %Hcheckpg_own;eauto.
  (* valid mem *)
  iDestruct (gen_mem_valid ai wi with "mem mem_ins") as %Hlookup_ai.
  iDestruct (gen_mem_valid_SepM with "mem [mem_tx]") as %Hlookup_mem_tx.
  { iDestruct "mem_tx" as "[% mem_tx]". iExact "mem_tx". }
  (* valid tx *)
  iDestruct (mb_valid_tx i p_tx with "mb tx") as %Heq_tx.
  (* valid hpool *)
  iDestruct (hpool_valid with "hpool hp") as %Heq_hp.
  iSplit.
  - (* reducible *)
    iPureIntro.
    apply (reducible_normal i Hvc ai wi);eauto.
    rewrite Heq_tx //.
  - iModIntro.
    iIntros (m2 σ2) "vmprop_auth %HstepP".
    iFrame "vmprop_auth".
    apply (step_ExecI_normal i Hvc ai wi) in HstepP;eauto.
    2: rewrite Heq_tx //.
    remember (exec Hvc σ1) as c2 eqn:Heqc2.
    rewrite /exec /hvc Hlookup_R0 /= Hdecode_f /mem_send Hlookup_R1 /= in Heqc2.
    case_bool_decide;first lia.
    pose proof (parse_transaction_descriptor_length _ _ _ _ Hparse) as Hlt_pg.
    rewrite -Heq_tx -Heq_cur /len in Hparse.
    apply (parse_transaction_descriptor_tx _ σ1.1.2) in Hparse;last done.
    rewrite Hparse //= in Heqc2.
    case_bool_decide.
    2: { destruct H1. split;auto. split;eauto. rewrite Heq_cur //. }
    case_bool_decide.
    2: { destruct H2. intros s Hin.
         rewrite Heq_cur.
         rewrite andb_true_iff. split.
         rewrite /check_excl_access_page.
         rewrite andb_true_iff. split.
         apply Hcheckpg_acc.
         set_solver + Hsubseteq_acc Hin.
         by apply Hcheckpg_excl.
         by apply Hcheckpg_own.
    }
    clear H1 H2.
    rewrite /new_transaction /= /fresh_handle /= -Heq_hp in Heqc2.
    destruct (elements sh) as [| h fhs] eqn:Hfhs.
    { exfalso. rewrite -(elements_empty (C:= gset Word)) in Hfhs. apply Hneq_hp. apply set_eq.
      intro. rewrite -elem_of_elements Hfhs elem_of_elements. split;intro;set_solver. }
    assert (Heq_c2 : (m2,σ2) = (ExecI, (update_incr_PC (update_reg
                      (update_reg
                         (update_page_table_global revoke_access (alloc_transaction σ1 h (σ1.1.1.2, j, ps, tt, false))
                            (alloc_transaction σ1 h (σ1.1.1.2, j, ps, Lending, false)).1.1.2 ps) R0 (encode_hvc_ret_code Succ)) R2 h)))).
    {
      destruct hvcf;
      inversion Htt;subst tt;try contradiction.
      destruct HstepP;subst m2 σ2; subst c2;done.
      destruct HstepP;subst m2 σ2; subst c2;done.
    }
    inversion Heq_c2. clear H2 H3 Heqc2.
    rewrite /= /gen_vm_interp.
    (* unchanged part *)
    rewrite (preserve_get_mb_gmap σ1).
    rewrite (preserve_get_rx_gmap σ1).
    all: try rewrite p_upd_pc_mb //.
    rewrite p_upd_pc_mem 2!p_upd_reg_mem p_rvk_acc_mem p_alloc_tran_mem.
    iFrame "Hnum mem rx_state mb".
    (* upd regs *)
    rewrite Heq_cur.
    rewrite (u_upd_pc_regs _ i ai) //.
    2: { rewrite 2!u_upd_reg_regs.
         rewrite (preserve_get_reg_gmap σ1). rewrite lookup_insert_ne //.  rewrite lookup_insert_ne //. solve_reg_lookup. done.
    }
    rewrite u_upd_reg_regs p_upd_reg_current_vm p_rvk_acc_current_vm p_alloc_tran_current_vm Heq_cur.
    rewrite u_upd_reg_regs p_rvk_acc_current_vm p_alloc_tran_current_vm Heq_cur.
    rewrite (preserve_get_reg_gmap σ1) //.
    iDestruct ((gen_reg_update3_global PC i (ai ^+ 1)%f R2 i h R0 i (encode_hvc_ret_code Succ)) with "regs PC R2 R0")
      as ">[$ [PC [R2 R0]]]";eauto.
    (* upd pgt *)
    rewrite (preserve_get_own_gmap (update_page_table_global revoke_access (alloc_transaction σ1 h (i, j, ps, tt, false)) i ps) (update_incr_PC _)).
    2: rewrite p_upd_pc_pgt !p_upd_reg_pgt //.
    rewrite p_rvk_acc_own. rewrite (preserve_get_own_gmap σ1) //.
    iFrame "pgt_owned".
    rewrite (preserve_get_access_gmap (update_page_table_global revoke_access (alloc_transaction σ1 h (i, j, ps, tt, false)) i ps) (update_incr_PC _)).
    2: rewrite p_upd_pc_pgt p_upd_reg_pgt //.
    iDestruct (access_agree with "pgt_acc acc") as %Hlookup_pgt_acc.
    rewrite (u_rvk_acc_acc _ _ _ sacc).
    2: {
      rewrite p_alloc_tran_pgt.
      intros p Hin_p.
      specialize (Hvalid_excl p Hin_p).
      destruct Hvalid_excl as [? [? [? [? _]]]].
      exists (x,x0,x1).
      done.
    }
    2: rewrite (preserve_get_access_gmap σ1) //.
    rewrite (preserve_get_access_gmap σ1) //.
    iDestruct (access_update (sacc ∖ ps) with "pgt_acc acc") as ">[$ acc]". done.
    assert (Hvalid_pgt: set_Forall (λ p : PID, σ1.1.1.1.2 !! p = Some (Some i, true, {[i]})) ps).
    {
      intros p Hin.
      specialize (Hcheckpg_acc p).
      feed specialize Hcheckpg_acc. set_solver + Hin Hsubseteq_acc.
      specialize (Hvalid_excl p Hin).
      destruct Hvalid_excl as [o [b [s [Hlk Htrue]]]].
      symmetry in Htrue.
      rewrite andb_true_iff in Htrue.
      destruct Htrue as [-> Hsize].
      rewrite /check_access_page /= in Hcheckpg_acc.
      rewrite Hlk in Hcheckpg_acc.
      destruct (decide (i ∈ s)); last done.
      case_bool_decide;last done.
      rewrite Hlk.
      assert (s = {[i]}) as ->. apply size_singleton_le;auto.
      specialize (Hcheckpg_own p Hin).
      rewrite /check_ownership_page /= Hlk in Hcheckpg_own.
      destruct o.
      destruct (decide (i = v)).
      2: done.
      subst v. done.
      done.
    }
    rewrite (preserve_get_excl_gmap (update_page_table_global revoke_access (alloc_transaction σ1 h (i, j, ps, tt, false)) i ps) (update_incr_PC _)).
    2: rewrite p_upd_pc_pgt p_upd_reg_pgt //.
    rewrite (p_rvk_acc_excl _ _ i tt).
    2: { rewrite p_alloc_tran_pgt. destruct tt; done. }
    rewrite (preserve_get_excl_gmap σ1);last done.
    iFrame "pgt_excl".
    (* upd tran *)
    rewrite (preserve_get_trans_gmap (alloc_transaction σ1 h (i, j, ps, tt, false)) (update_incr_PC _)).
    2: rewrite p_upd_pc_trans 2!p_upd_reg_trans p_rvk_acc_trans //.
    rewrite u_alloc_tran_trans.
    assert (sh = {[h]} ∪ sh ∖ {[h]}) as Heq_sh.
    { assert (h ∈ sh).
      rewrite -elem_of_elements. rewrite Hfhs. set_solver +.
      rewrite union_comm_L.
      rewrite difference_union_L.
      set_solver + H1.
    }
    iPoseProof (big_sepS_union _ {[h]} (sh ∖ {[h]})) as "[H _]".
    set_solver +.
    iDestruct ("H" with "[handles]") as "[h handles]".
    rewrite -Heq_sh. iExact "handles".
    rewrite big_sepS_singleton. iDestruct "h" as "[tran re]". iClear "H".
    iDestruct (trans_valid_None with "trans tran") as %Hlookup_tran.
    iDestruct (trans_update_insert h (i, j, ps, tt) with "trans tran") as ">[$ tran]".
    { rewrite /valid_transaction //=. }
    (* upd hp *)
    rewrite (preserve_get_hpool_gset (alloc_transaction σ1 h (i, j, ps, tt, false)) (update_incr_PC _)).
    2: rewrite p_upd_pc_trans 2!p_upd_reg_trans p_rvk_acc_trans //. rewrite u_alloc_tran_hpool.
    iDestruct (hpool_update_diff h with "hpool hp") as ">[$ hp]".
    (* upd retri *)
    rewrite (preserve_get_retri_gmap (alloc_transaction σ1 h (i, j, ps, tt, false)) (update_incr_PC _)).
    2: rewrite p_upd_pc_trans p_upd_reg_trans //. rewrite u_alloc_tran_retri.
    iDestruct (retri_update_insert with "retri re") as ">[$ re]".
    (* inv_trans_wellformed *)
    rewrite (preserve_inv_trans_wellformed (alloc_transaction σ1 h (i, j, ps, tt, false))).
    2: rewrite p_upd_pc_trans p_upd_reg_trans //.
    iAssert (⌜inv_trans_wellformed (alloc_transaction σ1 h (i, j, ps, tt, false))⌝%I) as "$".
    iPureIntro.
    apply (p_alloc_tran_inv_wf h (i, j, ps, tt, false));auto.
    simpl. simpl in Hlt_pg. rewrite Z.leb_le. lia.
    (* inv_trans_pgt_consistent *)
    rewrite (preserve_inv_trans_pgt_consistent (update_page_table_global revoke_access (alloc_transaction σ1 h (i, j, ps, tt, false)) i ps) (update_incr_PC _)).
    2: rewrite p_upd_pc_trans p_upd_reg_trans //.
    2: rewrite p_upd_pc_pgt p_upd_reg_pgt //.
    iAssert (⌜inv_trans_pgt_consistent (update_page_table_global revoke_access (alloc_transaction σ1 h (i, j, ps, tt, false)) i ps)⌝%I) as "$".
    iPureIntro.
    apply p_not_share_inv_consist;auto.
    { destruct Hwf as [_ [? _]]. done. }
    (* inv_trans_ps_disj *)
    rewrite (preserve_inv_trans_ps_disj (alloc_transaction σ1 h (i, j, ps, tt, false))).
    2: rewrite p_upd_pc_trans p_upd_reg_trans //.
    iAssert (⌜inv_trans_ps_disj (alloc_transaction σ1 h (i, j, ps, tt, false))⌝%I) as "$". iPureIntro.
    apply p_alloc_tran_inv_disj;auto.
    {
      rewrite /= elem_of_disjoint.
      intros.
      apply elem_of_pages_in_trans' in H2.
      destruct H2 as [h' [tran' [Hlk Hin_h']]].
      specialize (Hconsis h' (Some tran') Hlk x Hin_h').
      specialize (Hvalid_pgt x H1).
      destruct Hwf as [_ [Hneq _]].
      specialize (Hneq h' _ Hlk).
      rewrite Hvalid_pgt in Hconsis.
      destruct (tran'.1.2);destruct tran'.2;auto.
      - set_solver + Hconsis.
      - inversion Hconsis.
      - inversion Hconsis.
      - simpl in Hneq.
        set_solver + Hconsis Hneq.
      - set_solver + Hconsis.
    }
    (* just_scheduled *)
    iModIntro.
    rewrite /just_scheduled_vms /just_scheduled.
    rewrite /scheduled /machine.scheduler /= /scheduler.
    rewrite p_upd_pc_current_vm 2!p_upd_reg_current_vm p_rvk_acc_current_vm p_alloc_tran_current_vm.
    rewrite Heq_cur.
    iSplitL "".
    set fl := (filter _ _).
    assert (fl = []) as ->.
    {
      rewrite /fl.
      induction n.
      - simpl.
        rewrite filter_nil //=.
      - rewrite seq_S.
        rewrite filter_app.
        rewrite IHn.
        simpl.
        rewrite filter_cons_False //=.
        rewrite andb_negb_l.
        done.
    }
    by iSimpl.
    (* Φ *)
    case_bool_decide;last done.
    simpl. iApply "HΦ".
    rewrite /fresh_handles. iFrame.
    iSplitL "own excl".
    rewrite big_sepS_sep. iFrame.
    iExists h. iFrame.
    rewrite Heq_sh.
    iPureIntro. set_solver +.
Qed.

Lemma mem_lend {i wi r0 r1 r2 hvcf p_tx sacc} ai j mem_tx sh (ps: gset PID) :
  (tpa ai) ∈ sacc ->
  (tpa ai) ≠ p_tx ->
  (* len is the length of the msg *)
  let len := (Z.to_nat (finz.to_z r1)) in
  (* the decoding of wi is correct *)
  decode_instruction wi = Some(Hvc) ->
  (* the decoding of R0 is a FFA mem_share *)
  decode_hvc_func r0 = Some(hvcf) ->
  hvcf_to_tt hvcf = Some Lending ->
  (* the whole descriptor resides in the TX page *)
  (len <= page_size)%Z ->
  (* the descriptor *)
  parse_transaction_descriptor mem_tx (of_pid p_tx) len = Some (i, None, j, ps) ->
  (* caller is not the receiver *)
  i ≠ j ->
  ps ⊆ sacc ->
  (* there is at least one free handle in the hpool *)
  sh ≠ ∅ ->
  {SS{{ ▷(PC @@ i ->r ai) ∗
      ▷ ai ->a wi ∗
      (* VM i exclusively owns pages in ps *)
      ▷ ([∗ set] p ∈ ps, p -@O> i ∗ p -@E> true) ∗
      ▷ (i -@A> sacc) ∗
      ▷ (R0 @@ i ->r r0) ∗
      ▷ (R1 @@ i ->r r1) ∗
      ▷ (R2 @@i ->r r2) ∗
      ▷ (fresh_handles 1 sh) ∗
      ▷ TX@ i := p_tx ∗
      ▷ memory_page p_tx mem_tx
       }}}
   ExecI @ i {{{ RET (false, ExecI) ;
                 PC @@ i ->r (ai ^+ 1)%f ∗
                 ai ->a wi ∗
                 ([∗ set] p ∈ ps, p -@O> i ∗ p -@E> true) ∗
                 i -@A> (sacc ∖ ps) ∗
                 R0 @@ i ->r (encode_hvc_ret_code Succ) ∗
                 R1 @@ i ->r r1 ∗
                 (∃ (wh: Word), ⌜wh ∈ sh⌝ ∗
                 R2 @@ i ->r wh ∗
                 wh ->t (i, j, ps, Lending) ∗
                 wh ->re false ∗
                 fresh_handles 1 (sh∖{[wh]})) ∗
                 TX@ i := p_tx ∗
                 memory_page p_tx mem_tx}}}.
Proof.
  by apply (mem_not_share Lending).
Qed.

Lemma mem_donate {i wi r0 r1 r2 hvcf p_tx sacc} ai j mem_tx sh (ps: gset PID) :
  (tpa ai) ∈ sacc ->
  (tpa ai) ≠ p_tx ->
  (* len is the length of the msg *)
  let len := (Z.to_nat (finz.to_z r1)) in
  (* the decoding of wi is correct *)
  decode_instruction wi = Some(Hvc) ->
  (* the decoding of R0 is a FFA mem_share *)
  decode_hvc_func r0 = Some(hvcf) ->
  hvcf_to_tt hvcf = Some Donation ->
  (* the whole descriptor resides in the TX page *)
  (len <= page_size)%Z ->
  (* the descriptor *)
  parse_transaction_descriptor mem_tx (of_pid p_tx) len = Some (i, None, j, ps) ->
  (* caller is not the receiver *)
  i ≠ j ->
  ps ⊆ sacc ->
  (* there is at least one free handle in the hpool *)
  sh ≠ ∅ ->
  {SS{{ ▷(PC @@ i ->r ai) ∗
      ▷ ai ->a wi ∗
      (* VM i exclusively owns pages in ps *)
      ▷ ([∗ set] p ∈ ps, p -@O> i ∗ p -@E> true) ∗
      ▷ (i -@A> sacc) ∗
      ▷ (R0 @@ i ->r r0) ∗
      ▷ (R1 @@ i ->r r1) ∗
      ▷ (R2 @@i ->r r2) ∗
      ▷ (fresh_handles 1 sh) ∗
      ▷ TX@ i := p_tx ∗
      ▷ memory_page p_tx mem_tx
       }}}
   ExecI @ i {{{ RET (false, ExecI) ;
                 PC @@ i ->r (ai ^+ 1)%f ∗
                 ai ->a wi ∗
                 ([∗ set] p ∈ ps, p -@O> i ∗ p -@E> true) ∗
                 i -@A> (sacc ∖ ps) ∗
                 R0 @@ i ->r (encode_hvc_ret_code Succ) ∗
                 R1 @@ i ->r r1 ∗
                 (∃ (wh: Word), ⌜wh ∈ sh⌝ ∗
                 R2 @@ i ->r wh ∗
                 wh ->t (i, j, ps, Donation) ∗
                 wh ->re false ∗
                 fresh_handles 1 (sh∖{[wh]})) ∗
                 TX@ i := p_tx ∗
                 memory_page p_tx mem_tx}}}.
Proof.
  by apply (mem_not_share Donation).
Qed.

End mem_send.


From ITree Require Import
     Basics
     Subevent
     Events.State
     Indexed.Sum.

From Coq Require Import
     Nat
     List
     Logic.Eqdep
     Classes.RelationClasses
     Program.Tactics.

From Equations Require Import Equations.

From ExtLib Require Import
     RelDec
     Monad
     Option.

From Coinduction Require Import
     coinduction rel tactics.

From CTree Require Import
     CTree
     Eq
     Interp.Fold
     Interp.FoldStateT
     Interp.Log
     Interp.Network
     Logic.Ctl.

Import CTreeNotations ListNotations Log CtlNotations Monads Network.
Local Open Scope ctree_scope.

Set Implicit Arguments.
Set Contextual Implicit.
Set Asymmetric Patterns.

Module Fair.

  (** Compose [k] with itself [i] times. *)
  Fixpoint frepeat {E C X}
           (i: nat) (k: ctree E C X): ctree E C X :=
    match i with
    | 0 => k
    | S n => k ;; frepeat n k
    end.

  (** This is not associative, consider
      (A || B) || C ~ A || (B || C)

      The sequence [B, C] is impossible for the left,
      as it will do [B, B, ..., B, A] by picking [B] then [C].
      But it is possible for the right, by taking the branch [B]. *)

  Definition parafair{E C X}
             `{BN -< C} `{B1 -< C} `{B2 -< C} `{B0 -< C}
             (a b: ctree E C X): ctree E C void :=
    CTree.forever
      (brD2
         (i <- branch false (branchN) ;;
          frepeat i a ;;
          b)

         (i <- branch false (branchN) ;;
          frepeat i b ;;
          a)).

  Variant ID: Type -> Type :=
    | Index: nat -> ID unit.

  Definition id{C}(n: nat): ctree ID C unit := trigger (Index n).

  (* Ignore [t], label observation equals [e] *)
  Inductive obs_eq {E C: Type -> Type}{X Y: Type} :
    E Y -> ctree E C X -> @label E -> Prop :=
  | ObsEq y : forall t e, obs_eq e t (obs e y).

  #[global] Instance proper_obs_eq_equ {E C: Type -> Type} {X Y} (e: E Y) {HasStuck: B0 -< C} :
    Proper (@equ E C X X eq ==> eq ==> iff) (@obs_eq E C X Y e).
  Proof.
    unfold Proper, respectful, impl; cbn.
    intros x y EQ ? ? <-; split; intro OBS; inv OBS; econstructor; now rewrite EQ.
  Qed.
  (** TODO: This would be more simply stated and without [ID]
      and [obs_eq] as

    forall l (t1 t2: ctree ID C void),
      (parafair t1 t2), l |= AG (AF (fun l t => t ≅ t1)) /\
      (parafair t1 t2), l |= AG (AF (fun l t => t ≅ t2)),
  *)

  Lemma para_fair {C}
        `{HBN: BN -< C} `{HB1: B1 -< C} `{HB2: B2 -< C} `{HB0: B0 -< C}:
    forall l (t: ctree ID C void),
      t = parafair (id 0) (id 1) ->
      t, l |= AG (AF (obs_eq (Index 0))).
  Proof.
    intros; revert l.
    unfold ag; subst; coinduction R CIH; intro l.
    split.
    (* Eventually [ID = 0] shows up *)
    - unfold parafair.
      rewrite ctl_af_ax; right.

      rewrite ctree_eta; cbn; fold_subst.
      unfold ax; intros; inv_trans_one.
      (* Never use [trans_bind_inv_l] it loses the target label and introduces a new one! *)
      destruct x;
        apply trans_bind_inv in TR as [(HV & t3 & TR & ?) | (l2 & TRV  & TR )].
      + apply trans_bind_inv in TR as [(HV' & t4 & TR & ?) | (l3 & TRV'  & TR' )].
        * apply trans_brD_inv in TR as (niter & TR).
          apply trans_ret_inv in TR as (ST & ->).
          exfalso; apply HV; econstructor. (* Not a val! *)
        * eapply trans_val_inv in TRV'. (* Nothing to do with TRV *)
          clear TRV'.
          (* [t3] is [id 0]^+ *)
          destruct l3; cbn in *.
          (* [0] iterations = [id 0] *)
          apply trans_bind_inv in TR' as [(HV'' & t4 & TR & ?) | (l3 & TRV'  & TR )].

  Admitted.

End Fair.


From isla Require Import opsem.

Definition a44 : isla_trace :=
  Smt (DeclareConst 27%Z (Ty_BitVec 1%N)) Mk_annot :t:
  Smt (DeclareConst 37%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R20" [] (RegVal_Base (Val_Symbolic 37%Z)) Mk_annot :t:
  Smt (DefineConst 38%Z (Val (Val_Symbolic 37%Z) Mk_annot)) Mk_annot :t:
  Smt (DeclareConst 39%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R24" [] (RegVal_Base (Val_Symbolic 39%Z)) Mk_annot :t:
  Smt (DefineConst 40%Z (Val (Val_Symbolic 39%Z) Mk_annot)) Mk_annot :t:
  ReadReg "PSTATE" [Field "Z"] (RegVal_Struct [("Z", RegVal_Base (Val_Symbolic 27%Z))]) Mk_annot :t:
  Smt (DefineConst 43%Z (Unop (Not) (Binop (Eq) (Val (Val_Symbolic 27%Z) Mk_annot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) Mk_annot) Mk_annot)) Mk_annot :t:
  tcases [
    Smt (Assert (Val (Val_Symbolic 43%Z) Mk_annot)) Mk_annot :t:
    Smt (DefineConst 44%Z (Val (Val_Symbolic 38%Z) Mk_annot)) Mk_annot :t:
    WriteReg "R20" [] (RegVal_Base (Val_Symbolic 44%Z)) Mk_annot :t:
    Smt (DeclareConst 45%Z (Ty_BitVec 64%N)) Mk_annot :t:
    ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 45%Z)) Mk_annot :t:
    Smt (DefineConst 46%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 45%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
    WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 46%Z)) Mk_annot :t:
    tnil;
    Smt (Assert (Unop (Not) (Val (Val_Symbolic 43%Z) Mk_annot) Mk_annot)) Mk_annot :t:
    Smt (DefineConst 44%Z (Val (Val_Symbolic 40%Z) Mk_annot)) Mk_annot :t:
    WriteReg "R20" [] (RegVal_Base (Val_Symbolic 44%Z)) Mk_annot :t:
    Smt (DeclareConst 45%Z (Ty_BitVec 64%N)) Mk_annot :t:
    ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 45%Z)) Mk_annot :t:
    Smt (DefineConst 46%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 45%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
    WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 46%Z)) Mk_annot :t:
    tnil
  ]
.


Require Import List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq tuple ssrfun.
From mathcomp Require Import choice path bigop fintype.
Require Import Lib.Base Ipdl.Exp Ipdl.Core String Ipdl.Lems Lib.TupleLems Ipdl.Tacs Lib.Dist Ipdl.Big Pars Lib.Set CFold.

Section CFIdeal.
  Context {chan : Type -> Type}.
  Context (k : nat) (n : nat) (honest : pred 'I_n).
  Context (leak : chan (k.-tuple bool)).
  Context (ok : chan unit).
  Context (out : n.-tuple (chan (k.-bv))).

  Definition CFIdealParty (i : 'I_n) (send : chan (k.-bv)) :=
         (if honest i then Out (tnth out i) (copy send) else prot0).

  Definition CFIdealFunc (send : chan (k.-bv)) :=
    b <- new (k.-bv) ;;
    pars [::
            Out b (Samp (Unif));
            Out leak (copy b);
            Out send (_ <-- Read ok ;; copy b) ].

  Definition CFIdeal :=
    send <- new (k.-bv) ;;
    pars [::
            CFIdealFunc send;
            \||_(i < n) CFIdealParty i send
    ].

End CFIdeal.

Section CFReal.
  Context {chan : Type -> Type}.
  Context (k : nat) (n_ : nat).
  Definition n := n_.+1.
  Context (honest : pred 'I_n).
  Context (out : n.-tuple (chan (k.-bv))).

  Context (advCommit : n.-tuple (chan (k.-bv))).
  Context (advOpen : n.-tuple (chan unit)).

  Context (advCommitted : n.-tuple (n.-tuple (chan unit))).
  Context (advOpened : n.-tuple (n.-tuple (chan (k.-bv)))).

  Definition CFRealParty_honest
             (committed : n.-tuple (chan unit)) (opened : n.-tuple (chan (k.-bv)))
             (commit : chan (k.-bv)) (open : chan unit) (out : chan (k.-bv))
    :=
      committed_sum <- newvec n @ unit ;;
      opened_sum <- newvec n @ k.-bv ;;
      pars [::
            Out commit (Samp (Unif));
            read_all committed committed_sum;
            Out open (copy (tnth committed_sum ord_max));

            @cfold chan _ (k.-bv) (k.-bv) opened xort id opened_sum;
            Out out (copy (tnth opened_sum ord_max))
           ].

  Definition CFRealParty_corr (i : 'I_n)
             (committed : n.-tuple (chan unit))
             (opened : n.-tuple (chan (k.-bv)))
             (commit : chan k.-bv) (open : chan unit) :=
    pars [::
            Out commit (copy (tnth advCommit i));
            Out open (copy (tnth advOpen i));
            Outvec (tnth advCommitted i) (fun j => copy (tnth committed j));
            Outvec (tnth advOpened i) (fun j => copy (tnth opened j))
    ].

  Definition CFParty (i : 'I_n)
             (committed : n.-tuple (chan unit)) (opened : n.-tuple (chan k.-bv))
             (commit : chan k.-bv) (open : chan unit) (out : chan k.-bv) :=
    if honest i then CFRealParty_honest committed opened commit open out
                else CFRealParty_corr i committed opened commit open.

  Definition FComm
             (commit : chan k.-bv)
             (committed : chan unit)
             (open : chan unit)
             (opened : chan k.-bv) :=
    pars [::
            Out committed (_ <-- Read commit ;; Ret tt);
            Out opened (_ <-- Read open ;; copy commit)
         ].

  Definition CFReal :=
    commit <- newvec n @ k.-bv ;;
    committed <- newvec n @ unit ;;
    open <- newvec n @ unit ;;
    opened <- newvec n @ k.-bv ;;
    pars [::
            \||_(i < n) FComm (tnth commit i) (tnth committed i) (tnth open i) (tnth opened i);
         \||_(i < n) CFParty i committed opened (tnth commit i) (tnth open i) (tnth out i)
    ].

End CFReal.


(* This file is part of the LLIR Semantics project. *)
(* Licensing information is available in the LICENSE file. *)
(* (C) 2020 Nandor Licker. All rights reserved. *)

Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.

Require Import LLIR.LLIR.
Require Import LLIR.Maps.
Require Import LLIR.Values.
Require Export LLIR.Types.

Definition type_env := PTrie.t ty.

(* Type environment from instructions. *)
Definition ty_env_inst (insts: inst_map): type_env :=
  PTrie.fold
    (fun env _ i =>
      match get_inst_ty_def i with
      | Some (ty, dst) => PTrie.set env dst ty
      | None => env
      end)
    insts PTrie.empty.

(* Type environment from phis. *)
Definition ty_env_phi (phis: phi_map): type_env :=
  PTrie.fold
    (fun env _ block =>
      List.fold_left
        (fun env p =>
          match p with
          | LLPhi (ty, dst) _ => PTrie.set env dst ty
          end)
        block env)
    phis PTrie.empty.

(* Type environment for all registers. *)
Definition ty_env (f: func): type_env :=
  PTrie.union (ty_env_inst f.(fn_insts)) (ty_env_phi f.(fn_phis)).

(* Holds if the evironment has the correct type for a reg. *)
Definition well_typed_reg (env: type_env) (r: reg) (t: ty) :=
  env ! r = Some t.

(* Typing rules for binary instructions. *)
Inductive WellTypedBinop: binop -> ty -> ty -> ty -> Prop :=
  | type_cmp:
    forall (t: ty) (dt: ty),
      WellTypedBinop LLCmp t t dt
  | type_add:
    forall (t: ty),
      WellTypedBinop LLAdd t t t
  | type_sll:
    forall (tl: ty_int) (tr: ty_int),
      WellTypedBinop LLSll (TInt tl) (TInt tr) (TInt tl)
  .

(* Typing rules for unary instructions. *)
Inductive WellTypedUnop: unop -> ty -> ty -> Prop :=
  | type_sext_i32_i64: WellTypedUnop LLSext (TInt I32) (TInt I64)
  .

(* Typing rules for instructions. *)
Inductive WellTypedInst: type_env -> inst -> Prop :=
  | type_jmp:
    forall (env: type_env) (target: node),
      WellTypedInst env (LLJmp target)
  | type_jcc:
    forall (env: type_env) (cond: reg) (bt: node) (bf: node) (i: ty_int)
      (COND_TY: well_typed_reg env cond (TInt i)),
      WellTypedInst env (LLJcc cond bt bf)
  | type_ret:
    forall (env: type_env) (ret: reg) (t: ty)
      (RET_TY: well_typed_reg env ret t),
      WellTypedInst env (LLRet (Some ret))
  | type_ret_void:
    forall (env: type_env),
      WellTypedInst env (LLRet None)
  | type_st:
    forall (env: type_env) (next: node) (addr: reg) (val: reg) (t: ty)
      (ADDR_TY: well_typed_reg env addr ptr_ty)
      (VAL_TY: well_typed_reg env val t),
      WellTypedInst env (LLSt next addr val)
  | type_undef:
    forall (env: type_env) (next: node) (dst: reg) (t: ty)
      (DST_TY: well_typed_reg env dst t),
      WellTypedInst env (LLUndef (t, dst) next)
  | type_ld:
    forall (env: type_env) (next: node) (dst: reg) (t: ty) (addr: reg)
      (ADDR_TY: well_typed_reg env addr ptr_ty)
      (DST_TY: well_typed_reg env dst t),
      WellTypedInst env (LLLd (t, dst) next addr)
  | type_frame:
    forall (env: type_env) (dst:reg) (next: node)
      (object: positive) (offset: nat)
      (DST_TY: well_typed_reg env dst ptr_ty),
      WellTypedInst env (LLFrame dst next object offset)
  | type_global:
    forall (env: type_env) (dst: reg) (next: node)
      (segment: positive) (object: positive) (offset: nat)
      (DST_TY: well_typed_reg env dst ptr_ty),
      WellTypedInst env (LLGlobal dst next segment object offset)
  | type_int:
    forall (env: type_env) (dst: reg) (next: node) (val: INT.t) (t: ty)
      (INT_TY: TypeOfInt val t)
      (DST_TY: well_typed_reg env dst t),
      WellTypedInst env (LLInt dst next val)
  | type_arg:
    forall (env: type_env) (t: ty) (dst: reg) (next: node) (idx: nat)
      (DST_TY: well_typed_reg env dst t),
      WellTypedInst env (LLArg (t, dst) next idx)
  | type_binop:
    forall (env: type_env) (op: binop) (next: node)
      (l: reg) (tl: ty) (r: reg) (tr: ty) (dst: reg) (t: ty)
      (LHS_TY: well_typed_reg env l tl)
      (RHS_TY: well_typed_reg env r tr)
      (DST_TY: well_typed_reg env dst t)
      (OP: WellTypedBinop op tl tr t),
      WellTypedInst env (LLBinop (t, dst) next op l r)
  | type_unop:
    forall (env: type_env) (op: unop) (next: node)
      (arg: reg) (argt: ty) (dst: reg) (t: ty)
      (ARG_TY: well_typed_reg env arg argt)
      (DST_TY: well_typed_reg env dst t)
      (OP: WellTypedUnop op argt t),
      WellTypedInst env (LLUnop (t, dst) next op arg)
  | type_mov:
    forall (env: type_env) (op: unop) (next: node)
      (arg: reg) (dst: reg) (t: ty)
      (ARG_TY: well_typed_reg env arg t)
      (DST_TY: well_typed_reg env dst t),
      WellTypedInst env (LLMov (t, dst) next arg)
  | type_invoke_void:
    forall (env: type_env) (next: node)
      (dst: reg) (t: ty)
      (callee: reg) (args: list reg) (exn: node)
      (CALLEE_TY: well_typed_reg env callee ptr_ty),
      WellTypedInst env (LLInvoke (Some (t, dst)) next callee args exn)
  | type_call_void:
    forall (env: type_env) (next: node)
      (callee: reg) (args: list reg)
      (CALLEE_TY: well_typed_reg env callee ptr_ty),
      WellTypedInst env (LLCall None next callee args)
  | type_call:
    forall (env: type_env) (next: node)
      (callee: reg) (args: list reg) (dst: reg) (t: ty)
      (CALLEE_TY: well_typed_reg env callee ptr_ty)
      (DST_TY: well_typed_reg env dst t),
      WellTypedInst env (LLCall (Some (t, dst)) next callee args)
  | type_tcall:
    forall (env: type_env)
      (callee: reg) (args: list reg)
      (CALLEE_TY: well_typed_reg env callee ptr_ty),
      WellTypedInst env (LLTCall callee args)
  | type_syscall:
    forall (env: type_env) (next: node)
      (sno: reg) (args: list reg) (tsno: ty_int) (dst: reg)
      (SNO_TY: well_typed_reg env sno sys_no_ty)
      (ARG_TY: forall (arg: reg), In arg args -> well_typed_reg env arg sys_arg_ty)
      (DST_TY: well_typed_reg env dst sys_ret_ty),
      WellTypedInst env (LLSyscall dst next sno args)
  | type_trap:
    forall (env: type_env),
      WellTypedInst env LLTrap
  .

Inductive WellTypedInsts: type_env -> inst_map -> Prop :=
  | well_typed_insts:
    forall
      (env: type_env) (insts: inst_map)
      (INSTS: forall (n: node) (i: inst), Some i = insts ! n -> WellTypedInst env i),
        WellTypedInsts env insts.

Inductive WellTypedPhi: type_env -> phi -> Prop :=
  | well_typed_phi:
    forall (env: type_env) (dst: reg) (t: ty) (ins: list (node * reg))
      (INS: forall (n: node) (r: reg), In (n, r) ins -> well_typed_reg env r t),
      WellTypedPhi env (LLPhi (t, dst) ins)
  .

Inductive WellTypedPhis: type_env -> phi_map -> Prop :=
  | well_typed_phis:
    forall
      (env: type_env) (phis: phi_map)
      (PHIS:
        forall (n: node) (block: list phi) (p: phi),
          Some block = phis ! n ->
          In p block ->
          WellTypedPhi env p),
    WellTypedPhis env phis.

Inductive WellTypedFunc: func -> Prop :=
  | well_typed_func:
    forall (f: func)
      (INSTS: WellTypedInsts (ty_env f) f.(fn_insts))
      (PHIS: WellTypedPhis (ty_env f) f.(fn_phis)),
      WellTypedFunc f
  .

Inductive WellTypedProg: prog -> Prop :=
  | well_typed_prog:
    forall (p: prog)
      (FUNCS: forall (n: name) (f: func), Some f = p ! n -> WellTypedFunc f),
      WellTypedProg p
  .