Require Import VST.floyd.functional_base VST.floyd.proofauto.
Require Import Coq.ZArith.BinInt.
Require Import indices.unordered_flat.
Require Import VST.floyd.library.
Module OrderedIndex.

(* ================= ORDERED INDEX DEFINITION =============== *)

Record index :=
  {
    key: Type;
    eq_dec_key: EqDec key;
    default_key: Inhabitant key;
    key_val: key -> val;
    key_type: type;
    key_repr: key -> val -> mpred;

    value : Type;
    default_value: Inhabitant value;
    value_repr: value -> val -> mpred;
    value_ptr: value -> val;

    t: Type;
    t_repr: t -> val -> mpred;
    t_type: type;

    cursor : Type;
    cursor_repr: cursor -> val -> mpred;
    cursor_type: type;

    (* props *)
    cursor_has_next_props: cursor -> Prop;
    create_cursor_props: t -> val -> Prop;
    go_to_key_props: cursor -> Prop;
    move_to_next_props: cursor -> Prop;
    move_to_first_props: cursor -> Prop;
    get_record_props: cursor -> Prop;
    put_record_props: cursor -> Prop;

    (* interface *)

    cursor_has_next:  cursor -> bool;

    create_cursor: t -> cursor;
    create_index: t -> Prop;

    cardinality: cursor -> Z;

    go_to_key: cursor -> key -> cursor;

    move_to_next: cursor -> cursor;

    move_to_first: cursor -> cursor;

    get_record: cursor -> val;

    put_record: cursor -> key -> value -> cursor -> Prop;

     (* axioms *)
    lookup := fun cur key => get_record (go_to_key cur key);

    (* when we create empty index, cardinality zero *)
    (* cardinality increases when insert new key, doesn't change if key is old *)

    (* either we have all the axioms about insert-cardinality interactions,
        or define cardinality in terms of the other operators and derive these axioms *)

    index_lookup_empty:
      forall cur key,
      cardinality (cur) = 0 ->
      lookup cur key = nullval;

    index_update_eq:
      forall cur key v newc,
      put_record cur key v newc ->
      lookup newc key = value_ptr v;

    index_update_neq:
      forall cur key key' v newc,
      key <> key' ->
      put_record cur key v newc ->
      lookup newc key' = lookup cur key';
  }.

(* ================= ORDERED INDEX FUNSPECS =============== *)

Definition cursor_has_next_spec
  (oi: OrderedIndex.index): funspec :=
  WITH cur:oi.(cursor), pc:val
  PRE [ tptr oi.(cursor_type) ]
    PROP(oi.(cursor_has_next_props) cur)
    PARAMS(pc) GLOBALS()
    SEP(oi.(cursor_repr) cur pc)
  POST [tint]
    PROP()
    LOCAL(temp ret_temp (Val.of_bool (oi.(cursor_has_next) cur)))
    SEP(oi.(cursor_repr) cur pc).

Definition go_to_key_spec
  (oi: OrderedIndex.index): funspec :=
  WITH cur:oi.(cursor), pc:val, key:oi.(key), pkey: val
  PRE [ tptr oi.(cursor_type), oi.(key_type)]
    PROP(oi.(go_to_key_props) cur)
    PARAMS(pc; (oi.(key_val) key)) GLOBALS()
    SEP(oi.(cursor_repr) cur pc * oi.(key_repr) key pkey)
  POST [ tvoid ]
    PROP()
    LOCAL()
    SEP(oi.(cursor_repr) (oi.(go_to_key) cur key) pc * oi.(key_repr) key pkey).

Definition create_index_spec (oi: OrderedIndex.index): funspec :=
  WITH u:unit, gv: globals
  PRE [ ]
    PROP ()
    PARAMS() GLOBALS(gv)
    SEP (mem_mgr gv)
  POST [ tptr oi.(t_type) ]
    EX m: oi.(t), EX pr: val,
    PROP (oi.(create_index) m)
    LOCAL(temp ret_temp pr)
    SEP (mem_mgr gv; oi.(t_repr) m pr).

(* magic wand to allow for multiple cursors
on one data structure *)
Definition create_cursor_spec
  (oi: OrderedIndex.index): funspec :=
  WITH r: oi.(t), gv: globals, p: val
  PRE [tptr oi.(t_type)]
    PROP(oi.(create_cursor_props) r p)
    PARAMS(p) GLOBALS(gv)
    SEP(mem_mgr gv; oi.(t_repr) r p)
  POST [tptr oi.(cursor_type)]
    EX p':val,
    PROP()
    LOCAL(temp ret_temp p')
    SEP(mem_mgr gv; oi.(t_repr) r p; (oi.(t_repr) r p -* oi.(cursor_repr) (oi.(create_cursor) r) p')).

Definition move_to_next_spec
  (oi: OrderedIndex.index): funspec :=
  WITH p: val, cur: oi.(cursor)
  PRE [ tptr oi.(cursor_type)]
    PROP(oi.(move_to_next_props) cur)
    PARAMS(p) GLOBALS()
    SEP(oi.(cursor_repr) cur p)
  POST [tint]
    PROP()
    LOCAL(temp ret_temp (Val.of_bool (oi.(cursor_has_next) (oi.(move_to_next) cur))))
    SEP(oi.(cursor_repr) (oi.(move_to_next) cur) p).

Definition cardinality_spec
  (oi: OrderedIndex.index): funspec :=
  WITH p: val, cur: oi.(cursor)
  PRE [tptr oi.(cursor_type)]
    PROP()
    PARAMS(p) GLOBALS()
    SEP(oi.(cursor_repr) cur p)
  POST [size_t]
    PROP()
    LOCAL(temp ret_temp (Vptrofs (Ptrofs.repr (oi.(cardinality) cur))))
    SEP(oi.(cursor_repr) cur p).

Definition move_to_first_spec
  (oi: OrderedIndex.index): funspec :=
  WITH gv: globals, p: val, cur: oi.(cursor)
  PRE [ tptr oi.(cursor_type)]
    PROP(oi.(move_to_first_props) cur)
    PARAMS(p) GLOBALS()
    SEP(mem_mgr gv; oi.(cursor_repr) cur p)
  POST [tint]
    PROP()
    LOCAL(temp ret_temp (Val.of_bool (oi.(cursor_has_next) (oi.(move_to_first) cur))))
    SEP(mem_mgr gv; oi.(cursor_repr) (oi.(move_to_first) cur) p).

Definition get_record_spec
  (oi: OrderedIndex.index): funspec :=
  WITH p: val, cur: oi.(cursor)
  PRE [tptr oi.(cursor_type)]
    PROP(oi.(get_record_props) cur)
    PARAMS(p) GLOBALS()
    SEP(oi.(cursor_repr) cur p)
  POST [tptr tvoid]
    EX newc,
    PROP()
    LOCAL(temp ret_temp (oi.(get_record) cur))
    SEP(oi.(cursor_repr) newc p).

Definition put_record_spec
  (oi: OrderedIndex.index): funspec :=
   WITH cur: oi.(cursor), pc:val, key:oi.(key), pkey: val, record:oi.(value), gv: globals
  PRE [ tptr oi.(cursor_type), oi.(key_type), tptr tvoid]
    PROP(oi.(put_record_props) cur)
    PARAMS(pc; (oi.(key_val) key); oi.(value_ptr) record) GLOBALS(gv)
    SEP(mem_mgr gv; oi.(cursor_repr) cur pc; oi.(key_repr) key pkey)
  POST [tvoid]
    EX newc: oi.(cursor),
    PROP(oi.(put_record) cur key record newc)
    LOCAL()
    SEP(mem_mgr gv; oi.(cursor_repr) newc pc).

End OrderedIndex.


From machine_program_logic.program_logic Require Import machine weakestpre adequacy.
From iris.algebra Require Import big_op.
From HypVeri Require Import machine_extra lifting.
From HypVeri.algebra Require Import base mailbox pagetable mem.
From HypVeri.lang Require Import reg_extra.
From HypVeri.examples Require Import instr utils.
From HypVeri.logrel Require Import logrel logrel_extra logrel_prim_extra.
From HypVeri.examples.mem_trans_msg_send Require Import proof.
Require Import Setoid.

Section mtms_adequacy.
  Context `{hypparams: !HypervisorParameters}.
  Context (p_prog0 p_prog1 p_prog2 : PID).
  Context (p_tx0 p_rx0 p_tx1 p_rx1 p_tx2 p_rx2 : PID).
  Context (p_share : PID).
  Context (Hps_nd: NoDup [p_prog0;p_prog1;p_prog2;p_share;p_tx0;p_tx1;p_tx2;p_rx0;p_rx1;p_rx2]).
  Context (addr : Imm) (Heq_pshare : of_pid p_share = addr).
  Context (i_ptx0 : Imm) (Heq_ptx0 : of_pid p_tx0 = i_ptx0).
  Context (i_prx1 : Imm) (Heq_prx1 : of_pid p_rx1 = i_prx1).
  Context (σ : state).

  Definition pgt :=
    access_layout σ {[V0 := to_dfrac_agree (DfracOwn 1) {[p_share; p_prog0; p_tx0]};
                     V1 := to_dfrac_agree (DfracOwn 1) {[p_prog1; p_tx1; p_rx1]};
                     V2 := to_dfrac_agree (DfracOwn 1) {[p_tx2; p_rx2; p_prog2]}]} ∧
    excl_layout σ {[p_rx0 := true; p_rx1 := true; p_rx2 := true; p_tx2 := true; p_prog2 := true; p_share:= true]} ∧
    own_layout σ {[p_rx0 := None; p_rx1 := None; p_rx2 := None; p_tx2 := None; p_prog2 := Some V2; p_share:= Some V0]}.

  Program Definition mem:=
    let mem := ((get_mem σ): gmap Addr Word)  in
    (∀ (m : gmap Addr Addr), dom m = set_of_addr {[p_prog0]} -> m ⊆ mem -> m = mem_page_program p_prog0 (mtms_program0 addr i_ptx0) _) ∧
    (∀ (m : gmap Addr Addr), dom m = set_of_addr {[p_prog1]} -> m ⊆ mem -> m = mem_page_program p_prog1 (mtms_program1 addr i_prx1) _) ∧
    ((set_of_addr {[p_prog0;p_prog1; p_share; p_prog2;p_tx0; p_tx1; p_tx2;p_rx0;p_rx1;p_rx2]}) ⊆ dom mem).
  Next Obligation. lia. Qed.
  Next Obligation. lia. Qed.

  Definition regs
    := reg_layout σ ({[PC:=of_pid p_prog0]}) V0
       ∧ reg_layout σ ({[PC:=of_pid p_prog1]}) V1
       ∧ ∀ i rn, is_Some (((get_reg_files σ) !!! i) !! rn).

  Definition mailbox:=
    mailbox_layout σ {[(V0, TX) := p_tx0; (V1, TX) := p_tx1; (V2, TX) := p_tx2;
                      (V0, RX) := p_rx0; (V1, RX) := p_rx1; (V2, RX) := p_rx2]} ∧
    rx_layout σ {[V0 := None; V1 := None; V2 := None]}.

  Definition transactions := σ.2 = {[W0 := None]}.

  Definition initial_config (ms: list exec_mode) (φs : list (exec_mode -> Prop)):=
                  (get_current_vm σ) = V0 ∧
                  φs = [(λ m , m = HaltI); (λ _, False); (λ _, True)] ∧
                  ms = [ExecI;ExecI;ExecI] ∧
                    pgt ∧ mem ∧ regs ∧ mailbox ∧ transactions.

  Context {vm_preG: gen_VMPreG Addr VMID Word reg_name PID transaction_type irisΣ}.

  Lemma memory_list_gmap (pid : PID) (mem_list : list Word) (Hle: length mem_list < (Z.to_nat page_size))
        (mem_gmap : gmap Addr Word)
        (H : NoDup (zip (finz.seq pid (length mem_list)) mem_list).*1)
        (G : mem_gmap = mem_page_program pid mem_list Hle)
        γ :
    (([∗ list] xk ∈ map_to_list mem_gmap, xk.1 ↪[γ] xk.2) -∗
       [∗ list] xy ∈ zip (finz.seq pid (length mem_list)) mem_list, xy.1 ↪[γ] xy.2).
  Proof.
    rewrite G /mem_page_program //.
    rewrite map_to_list_to_map; first done.
    rewrite fst_zip.
    - apply finz_seq_NoDup'.
      simpl.
      pose proof (last_addr_in_bound pid).
      solve_finz.
    - rewrite finz_seq_length.
      lia.
  Qed.

  Lemma get_reg_gmap_split γ:
    ([∗ map] p↦w ∈ (get_reg_gmap σ) , p ↪[γ] w)%I ⊢ [∗ list] i ∈ ((list_of_vmids): list VMID), [∗ map] p↦w ∈ get_reg_gmap_vm σ i, p ↪[γ] w.
  Proof.
    iIntros "Hmap".
    rewrite /get_reg_gmap.
    pose proof (NoDup_list_of_vmids) as Hnodup.
    iInduction (list_of_vmids) as [ | i l] "IH".
    done.
    rewrite list_to_map_app.
    rewrite big_sepM_union.
    iDestruct "Hmap" as "[Hsub Hmap]".
    iSplitL "Hsub".
    {
      rewrite /get_reg_gmap_vm.
      iFrame "Hsub".
    }
    iApply "IH".
    { iPureIntro. apply NoDup_cons in Hnodup. destruct Hnodup;auto. }
    iFrame "Hmap".
    apply  map_disjoint_list_to_map_l.
    apply Forall_forall.
    intros.
    assert (∀ (v: VMID) x, x ∈ map (λ p : reg_name * Addr, (p.1, v, p.2)) (map_to_list (σ.1.1.1.1.1 !!! v)) -> x.1.2 = v).
    {
      intros.
      apply elem_of_list_In in H0.
      apply in_map_iff in H0.
      destruct H0 as [? [Heq Hin]].
      destruct x0.
      destruct p.
      simpl.
      simplify_eq /=.
      done.
    }
    apply H0 in H.
    destruct (x.1).
    simpl in H.
    subst v.
    apply  not_elem_of_list_to_map_1.
    intro.
    apply elem_of_list_In in H.
    apply in_map_iff in H.
    destruct H as [p].
    destruct H as [Heqn H1].
    apply in_flat_map in H1.
    destruct H1 as [i'].
    destruct H as [HIn H].
    apply elem_of_list_In in H.
    apply H0 in H.
    rewrite Heqn in H.
    simpl in H.
    subst i'.
    apply NoDup_cons in Hnodup as [Hnotin ?].
    rewrite -elem_of_list_In in HIn.
    contradiction.
  Qed.

  (* exec_mode of all VMs *)
  Lemma adequacy (ms : list exec_mode) φs:
    (* we need assumptions to be able to allocate resources *)
    (* with these resources, we apply the specification and get the wptp *)
    (* along with some other stuff, then it should be enough to apply the adequacy theorem *)
    (initial_config ms φs) ->
    adequate ms σ ((λ φ, λ v _, φ v)<$> φs).
    (* φ : vm 0 is scheduled but halted *)
  Proof.
    intros Hinit.
    destruct Hinit as (Hcur & -> & -> & Hpgt & Hmem & Hreg & Hmb & Htrans).
    set (saved_props := (let (_, x, _, _) := iris_subG irisΣ (subG_refl irisΣ) in x)).
    set (prop_name := (let (_, _, x, _) := iris_subG irisΣ (subG_refl irisΣ) in x)).
    set (name_map := (let (_, _, _, x) := iris_subG irisΣ (subG_refl irisΣ) in x)).
    eapply (wp_adequacy irisΣ); auto.
    intro Hinv.
    iIntros.
    iMod (gen_mem_alloc σ) as (mem_gname) "[Hσmem Hmem]".
    iMod (gen_reg_alloc σ) as (reg_gname) "[Hσreg Hreg]".
    iMod (gen_mb_alloc σ) as (mb_gname) "[Hσmb Hmb]".
    iMod (gen_rx_state_alloc σ) as (rx_state_gname) "[Hσrxs Hrxs]".
    iMod (gen_own_alloc σ) as (own_gname) "[Hσown Hown]".
    iMod (gen_access_alloc σ) as (access_gname) "[Hσaccess Haccess]".
    iMod (gen_excl_alloc σ) as (excl_gname) "[Hσexcl Hexcl]".
    iMod (gen_trans_alloc σ) as (trans_gname) "[Hσtrans Htrans]".
    iMod (gen_hpool_alloc σ) as (hpool_gname) "[Hσhpool Hhpool]".
    iMod (gen_retri_alloc σ) as (retri_gname) "[Hσretri Hretri]".

    iModIntro.
    iIntros (name_map_name).
    pose ((GenVMG irisΣ vm_preG Hinv _ _ _ name_map_name mem_gname reg_gname mb_gname rx_state_gname
                  own_gname access_gname excl_gname trans_gname hpool_gname retri_gname)) as VMG.
    iExists (gen_vm_interp (Σ := irisΣ)).

    destruct Hreg as (Hlookup_reg0 & Hlookup_reg1 & Htotal_reg).

    (* use assumptions to extract resources *)
    (** extract regs  **)
    iDestruct (get_reg_gmap_split with "Hreg") as "(Hreg0 & Hreg1 & Hreg2 & _)".
    (* TODO: move, do the same for other resources *)
    assert (∀ σ f, ([∗ map] p↦w ∈ get_reg_gmap_vm σ f, p ↪[reg_gname] w)%I =
                   ([∗ map] p↦w ∈ get_reg_gmap_vm σ f, p.1 @@ p.2 ->r w)%I) as sepM_reg_def.
    {
      intros σ' f'.
      apply big_opM_ext.
      intros k x H.
      destruct k as [k1 k2].
      simpl.
      rewrite reg_mapsto_eq /reg_mapsto_def //.
    }
    iEval (rewrite sepM_reg_def) in "Hreg0 Hreg1 Hreg2".
    clear sepM_reg_def.

    (* extract regs of VM0 *)
    pose proof (Htotal_reg V0 R0) as [r0_ Hlookup_reg0_r0].
    pose proof (Htotal_reg V0 R1) as [r1_ Hlookup_reg0_r1].
    pose proof (Htotal_reg V0 R2) as [r2_ Hlookup_reg0_r2].
    pose proof (Htotal_reg V0 R3) as [r3_ Hlookup_reg0_r3].
    pose proof (Htotal_reg V0 R4) as [r4_ Hlookup_reg0_r4].
    pose proof (Htotal_reg V0 R5) as [r5_ Hlookup_reg0_r5].

    iDestruct (big_sepM_subseteq _ (get_reg_gmap_vm σ V0) {[(PC, V0):= (of_pid p_prog0); (R0, V0) := r0_;
                                 (R1,V0):= r1_; (R2,V0):= r2_; (R3,V0):= r3_; (R4,V0):= r4_; (R5,V0):= r5_]} with "Hreg0") as "Hreg0";eauto.
    {
      apply (λ x, reg_layout_extend σ _ _ x R5 r5_ Hlookup_reg0_r5) in Hlookup_reg0.
      apply (λ x, reg_layout_extend σ _ _ x R4 r4_ Hlookup_reg0_r4) in Hlookup_reg0.
      apply (λ x, reg_layout_extend σ _ _ x R3 r3_ Hlookup_reg0_r3) in Hlookup_reg0.
      apply (λ x, reg_layout_extend σ _ _ x R2 r2_ Hlookup_reg0_r2) in Hlookup_reg0.
      apply (λ x, reg_layout_extend σ _ _ x R1 r1_ Hlookup_reg0_r1) in Hlookup_reg0.
      apply (λ x, reg_layout_extend σ _ _ x R0 r0_ Hlookup_reg0_r0) in Hlookup_reg0.

      apply reg_layout_get_reg_gmap in Hlookup_reg0; last assumption.

      clear -Hlookup_reg0.

      rewrite !kmap_insert in Hlookup_reg0.
      rewrite kmap_empty in Hlookup_reg0.
      rewrite insert_empty in Hlookup_reg0.

      rewrite (insert_commute _ (R5, V0) (PC, V0)) in Hlookup_reg0.
      rewrite (insert_commute _ (R4, V0) (PC, V0)) in Hlookup_reg0.
      rewrite (insert_commute _ (R3, V0) (PC, V0)) in Hlookup_reg0.
      rewrite (insert_commute _ (R2, V0) (PC, V0)) in Hlookup_reg0.
      rewrite (insert_commute _ (R1, V0) (PC, V0)) in Hlookup_reg0.
      rewrite (insert_commute _ (R0, V0) (PC, V0)) in Hlookup_reg0.
      assumption.
      1-6: done.
    }
    clear Hlookup_reg0_r0 Hlookup_reg0_r1 Hlookup_reg0_r2 Hlookup_reg0_r3 Hlookup_reg0_r4 Hlookup_reg0_r5 Hlookup_reg0.
    iDestruct (big_sepM_insert with "Hreg0") as "(PCz & Hreg0)".
    { rewrite !lookup_insert_None; repeat (split; eauto). }
    iDestruct (big_sepM_insert with "Hreg0") as "(R0z & Hreg0)".
    { rewrite !lookup_insert_None; repeat (split; eauto). }
    iDestruct (big_sepM_insert with "Hreg0") as "(R1z & Hreg0)".
    { rewrite !lookup_insert_None; repeat (split; eauto). }
    iDestruct (big_sepM_insert with "Hreg0") as "(R2z & Hreg0)".
    { rewrite !lookup_insert_None; repeat (split; eauto). }
    iDestruct (big_sepM_insert with "Hreg0") as "(R3z & Hreg0)".
    { rewrite !lookup_insert_None; repeat (split; eauto). }
    iDestruct (big_sepM_insert with "Hreg0") as "(R4z & Hreg0)".
    { rewrite !lookup_insert_None; repeat (split; eauto). }
    iDestruct (big_sepM_insert with "Hreg0") as "(R5z & _)".
    { rewrite lookup_empty; eauto. }

    (* extract regs of VM1 *)
    pose proof (Htotal_reg V1 R0) as [r0__ Hlookup_reg1_r0].
    pose proof (Htotal_reg V1 R1) as [r1__ Hlookup_reg1_r1].
    pose proof (Htotal_reg V1 R2) as [r2__ Hlookup_reg1_r2].
    pose proof (Htotal_reg V1 R3) as [r3__ Hlookup_reg1_r3].
    pose proof (Htotal_reg V1 R4) as [r4__ Hlookup_reg1_r4].
    pose proof (Htotal_reg V1 R5) as [r5__ Hlookup_reg1_r5].
    iDestruct (big_sepM_subseteq _ (get_reg_gmap_vm σ V1) {[(PC, V1):= (of_pid p_prog1); (R0, V1) := r0__; (R1, V1) := r1__; (R2, V1) := r2__; (R3, V1) := r3__; (R4, V1) := r4__; (R5, V1) := r5__]} with "Hreg1") as "Hreg1";eauto.
    {
      apply (λ x, reg_layout_extend σ _ _ x R5 r5__ Hlookup_reg1_r5) in Hlookup_reg1.
      apply (λ x, reg_layout_extend σ _ _ x R4 r4__ Hlookup_reg1_r4) in Hlookup_reg1.
      apply (λ x, reg_layout_extend σ _ _ x R3 r3__ Hlookup_reg1_r3) in Hlookup_reg1.
      apply (λ x, reg_layout_extend σ _ _ x R2 r2__ Hlookup_reg1_r2) in Hlookup_reg1.
      apply (λ x, reg_layout_extend σ _ _ x R1 r1__ Hlookup_reg1_r1) in Hlookup_reg1.
      apply (λ x, reg_layout_extend σ _ _ x R0 r0__ Hlookup_reg1_r0) in Hlookup_reg1.
      apply reg_layout_get_reg_gmap in Hlookup_reg1; last assumption.
      clear -Hlookup_reg1.
      rewrite !kmap_insert in Hlookup_reg1.
      rewrite kmap_empty in Hlookup_reg1.
      rewrite insert_empty in Hlookup_reg1.

      rewrite (insert_commute _ (R5, V1) (PC, V1)) in Hlookup_reg1.
      rewrite (insert_commute _ (R4, V1) (PC, V1)) in Hlookup_reg1.
      rewrite (insert_commute _ (R3, V1) (PC, V1)) in Hlookup_reg1.
      rewrite (insert_commute _ (R2, V1) (PC, V1)) in Hlookup_reg1.
      rewrite (insert_commute _ (R1, V1) (PC, V1)) in Hlookup_reg1.
      rewrite (insert_commute _ (R0, V1) (PC, V1)) in Hlookup_reg1.
      assumption.
      1-6: done.
    }
    clear Hlookup_reg1_r0 Hlookup_reg1_r1 Hlookup_reg1_r2 Hlookup_reg1_r3 Hlookup_reg1_r4 Hlookup_reg1_r5 Hlookup_reg1.
    iDestruct (big_sepM_insert with "Hreg1") as "(PC1 & Hreg1)".
    { rewrite !lookup_insert_None; repeat (split; eauto). }
    iDestruct (big_sepM_insert with "Hreg1") as "(R01 & Hreg1)".
    { rewrite !lookup_insert_None; repeat (split; eauto). }
    iDestruct (big_sepM_insert with "Hreg1") as "(R11 & Hreg1)".
    { rewrite !lookup_insert_None; repeat (split; eauto). }
    iDestruct (big_sepM_insert with "Hreg1") as "(R21 & Hreg1)".
    { rewrite !lookup_insert_None; repeat (split; eauto). }
    iDestruct (big_sepM_insert with "Hreg1") as "(R31 & Hreg1)".
    { rewrite !lookup_insert_None; repeat (split; eauto). }
    iDestruct (big_sepM_insert with "Hreg1") as "(R41 & Hreg1)".
    { rewrite !lookup_insert_None; repeat (split; eauto). }
    iDestruct (big_sepM_insert with "Hreg1") as "(R51 & _)".
    { rewrite lookup_empty; eauto. }

    iDestruct (big_sepM_subseteq _ (get_mb_gmap σ) {[(V0, TX):= p_tx0; (V1, TX) := (p_tx1); (V2, TX) := (p_tx2); (V0, RX) := p_rx0; (V1, RX) := p_rx1; (V2, RX) := p_rx2]} with "Hmb") as "Hmb";eauto.
    {
      apply mailbox_layout_get_mb_gmap.
      apply Hmb.
    }
    iDestruct (big_sepM_insert with "Hmb") as "(mb0TX & Hmb)".
    { rewrite !lookup_insert_None; split; eauto. }
    iDestruct (big_sepM_insert with "Hmb") as "(mb1TX & Hmb)".
    { rewrite !lookup_insert_None; split; eauto. }
    iDestruct (big_sepM_insert with "Hmb") as "(mb2TX & Hmb)".
    { rewrite !lookup_insert_None; split; eauto. }
    iDestruct (big_sepM_insert with "Hmb") as "(mb0RX & Hmb)".
    { rewrite !lookup_insert_None; split; eauto. }
    iDestruct (big_sepM_insert with "Hmb") as "(mb1RX & Hmb)".
    { rewrite !lookup_insert_None; split; eauto. }
    iDestruct (big_sepM_insert with "Hmb") as "(mb2RX & _)".
    { rewrite lookup_empty; eauto. }

    iDestruct (big_sepM_subseteq _ (get_rx_gmap σ) {[V0:= None; V1 := None; V2 := None]} with "Hrxs") as "Hrxs";eauto.
    {
      apply rx_layout_get_rx_gmap.
      apply Hmb.
    }
    iDestruct (big_sepM_insert with "Hrxs") as "(RX0St & Hrxs)".
    { rewrite !lookup_insert_None; split; eauto. }
    iDestruct (big_sepM_insert with "Hrxs") as "(RX1St & Hrxs)".
    { rewrite !lookup_insert_None; split; eauto. }
    iDestruct (big_sepM_insert with "Hrxs") as "(RX2St & _)".
    { rewrite lookup_empty; eauto. }

    (** extract mem **)
    destruct Hmem as ( HmemH1 & HmemH2 & Hdom_mem).
    destruct Hpgt as (pgt_acc & pgt_excl & pgt_own).
    pose proof (union_split_difference_intersection_subseteq_L _ _ Hdom_mem) as [Hdom_mem_union Hdom_mem_disj].
    pose proof (dom_union_inv_L _ _ _ Hdom_mem_disj Hdom_mem_union) as (mem' & mem2 & Hunion_mem' & Hdisj_mem' & _ & Hdom_mem2).

    iDestruct (big_sepM_subseteq _ (get_mem σ) mem2 with "Hmem") as "Hmem"; eauto.
    {
      rewrite Hunion_mem'.
      apply map_union_subseteq_r.
      done.
    }

    assert (NoDup' [p_prog0;p_prog1;p_prog2;p_share;p_tx0;p_tx1;p_tx2;p_rx0;p_rx1;p_rx2]) as Hps_nd'.
    {
      rewrite /NoDup'.
      intros. intro.
      apply H1.
      pose proof Hps_nd as Hps_nd'.
      rewrite NoDup_alt in Hps_nd'.
      apply lookup_lt_is_Some_2 in H.
      apply lookup_lt_is_Some_2 in H0.
      destruct H, H0.
      rewrite H2 in H. rewrite H in H0. inversion H0;subst x0;clear H0.
      eapply Hps_nd';eauto.
      rewrite H2;done.
    }

    pose proof (union_split_difference_intersection_subseteq_L {[p_prog0; p_prog1; p_share; p_prog2; p_tx0; p_tx1; p_tx2; p_rx0; p_rx1; p_rx2]} {[p_prog0]}) as [Heq Hdisj].
    set_solver +.
    rewrite Heq in Hdom_mem2.
    rewrite set_of_addr_union in Hdom_mem2.
    2 : { set_solver +. }
    clear Heq.
    apply dom_union_inv_L in Hdom_mem2.
    2 : { apply set_of_addr_disj. done. }
    destruct Hdom_mem2 as (mem1 & mem_p_prog0 & -> & Hmem1_disj  & Hdom_mem1 & Hdom_mem_p_prog0).
    iDestruct ((big_sepM_union _ _) with "Hmem") as "(Hmem1 & mem_p_prog0)";auto.
    clear Hdisj.
    pose proof (union_split_difference_intersection_subseteq_L ({[p_prog0; p_prog1; p_share; p_prog2; p_tx0; p_tx1; p_tx2; p_rx0; p_rx1; p_rx2]} ∖ {[p_prog0]}) {[p_prog1]}) as [Heq Hdisj].
    apply singleton_subseteq_l.
    rewrite !difference_union_distr_l_L.
    rewrite difference_diag_L.
    rewrite union_empty_l_L.
    rewrite <-!difference_union_distr_l_L.
    rewrite difference_disjoint_L.
    set_solver +.
    solve_NoDup 0.

    rewrite Heq in Hdom_mem1.
    rewrite set_of_addr_union in Hdom_mem1.
    2 : { set_solver. }
    clear Heq.
    apply dom_union_inv_L in Hdom_mem1.
    2 : { apply set_of_addr_disj. done. }
    destruct Hdom_mem1 as (mem2 & mem_p_prog1 &  -> & Hmem2_disj  & Hdom_mem2 & Hdom_mem_p_prog1).
    clear Hdisj.
    iDestruct ((big_sepM_union _ _) with "Hmem1") as "(Hmem2 & mem_p_prog1)";auto.

    pose proof (union_split_difference_intersection_subseteq_L (({[p_prog0; p_prog1; p_share; p_prog2; p_tx0; p_tx1; p_tx2; p_rx0; p_rx1; p_rx2]} ∖ {[p_prog0]}) ∖ {[p_prog1]}) {[p_share]}) as [Heq Hdisj].
    apply singleton_subseteq_l.
    rewrite !difference_union_distr_l_L.
    rewrite !difference_diag_L.
    do 7 (rewrite elem_of_union; left).
    rewrite elem_of_union; right.
    rewrite ->2elem_of_difference.
    split; [split; first set_solver + |].
    solve_NoDup 0.
    solve_NoDup 1.
    rewrite Heq in Hdom_mem2.
    rewrite set_of_addr_union in Hdom_mem2.
    2 : { set_solver +. }
    clear Heq.
    apply dom_union_inv_L in Hdom_mem2.
    2 : { apply set_of_addr_disj. done. }
    destruct Hdom_mem2 as (mem_p & mem & -> & Hmem_disj  & Hdom_mem' & Hdom_mem_p).
    iDestruct ((big_sepM_union _ _) with "Hmem2") as "(Hmem & mem_p)";auto.
    clear Hdisj.

    match goal with
      | [ H : context G [?a ∖ ?b ∖ ?c ∖ ?d] |- _ ] => set p := a; set q := b; set r := c; set t := d
    end.

    change {[p_prog0; p_prog1; p_prog2; p_tx0; p_tx1; p_tx2; p_rx0; p_rx1; p_rx2]} with p in Hdom_mem'.
    change {[p_prog0]} with q in Hdom_mem'.
    change {[p_prog1]} with r in Hdom_mem'.
    change {[p_share]} with t in Hdom_mem'.
    assert (p ∖ q ∖ r ∖ t = {[p_prog2; p_tx0; p_tx1; p_tx2; p_rx0; p_rx1; p_rx2]}) as Heq.
    {
      assert (p ∖ q ∖ r = {[p_share; p_prog2; p_tx0; p_tx1; p_tx2; p_rx0; p_rx1; p_rx2]}) as ->.
      {
        assert (p ∖ q = {[p_prog1; p_share; p_prog2; p_tx0; p_tx1; p_tx2; p_rx0; p_rx1; p_rx2]}) as ->.
        {
          subst p q.
          rewrite !difference_union_distr_l_L.
          rewrite difference_diag_L.
          rewrite union_empty_l_L.
          rewrite <-!difference_union_distr_l_L.
          rewrite difference_disjoint_L.
          - reflexivity.
          - solve_NoDup 0.
        }
        subst r.
        rewrite !difference_union_distr_l_L.
        rewrite difference_diag_L.
        rewrite union_empty_l_L.
        rewrite <-!difference_union_distr_l_L.
        rewrite difference_disjoint_L.
        - reflexivity.
        - solve_NoDup 1.
      }
      subst t.
      rewrite !difference_union_distr_l_L.
      rewrite difference_diag_L.
      rewrite union_empty_l_L.
      rewrite <-!difference_union_distr_l_L.
      rewrite difference_disjoint_L.
      - reflexivity.
      - solve_NoDup 3.
    }
    rewrite Heq in Hdom_mem'.
    clear Heq.
    rewrite set_of_addr_union in Hdom_mem'.
    2 : {
      solve_NoDup 9.
    }
    apply dom_union_inv_L in Hdom_mem'.
    2 : {
      apply set_of_addr_disj.
      solve_NoDup 9.
    }
    destruct Hdom_mem' as (mem3 & mem_p_rx2 &  -> & Hmem3_disj  & Hdom_mem1 & Hdom_mem_p_rx2).
    iDestruct ((big_sepM_union _ _) with "Hmem") as "(Hmem2 & p_rx2)";auto.
    rewrite set_of_addr_union in Hdom_mem1.
    2 : {
      solve_NoDup 8.
    }
    apply dom_union_inv_L in Hdom_mem1.
    2 : {
      apply set_of_addr_disj.
      solve_NoDup 8.
    }
    destruct Hdom_mem1 as (mem4 & mem_p_rx1 &  -> & Hmem4_disj  & Hdom_mem2 & Hdom_mem_p_rx1).
    iDestruct ((big_sepM_union _ _) with "Hmem2") as "(Hmem2 & p_rx1)";auto.
    rewrite set_of_addr_union in Hdom_mem2.
    2 : {
      solve_NoDup 7.
    }
    apply dom_union_inv_L in Hdom_mem2.
    2 : {
      apply set_of_addr_disj.
      solve_NoDup 7.
    }
    destruct Hdom_mem2 as (mem5 & mem_p_rx0 &  -> & Hmem5_disj  & Hdom_mem1 & Hdom_mem_p_rx0).
    iDestruct ((big_sepM_union _ _) with "Hmem2") as "(Hmem2 & p_rx0)";auto.
    rewrite set_of_addr_union in Hdom_mem1.
    2 : {
      solve_NoDup 6.
    }
    apply dom_union_inv_L in Hdom_mem1.
    2 : {
      apply set_of_addr_disj.
      solve_NoDup 6.
    }
    destruct Hdom_mem1 as (mem3 & mem_p_tx2 & -> & Hmem6_disj  & Hdom_mem2 & Hdom_mem_p_tx2).
    iDestruct ((big_sepM_union _ _) with "Hmem2") as "(Hmem2 & p_tx2)";auto.
    rewrite set_of_addr_union in Hdom_mem2.
    2 : {
      solve_NoDup 5.
    }
    apply dom_union_inv_L in Hdom_mem2.
    2 : {
      apply set_of_addr_disj.
      solve_NoDup 5.
    }
    destruct Hdom_mem2 as (mem4 & mem_p_tx1 & -> & Hmem7_disj  & Hdom_mem2 & Hdom_mem_p_tx1).
    iDestruct ((big_sepM_union _ _) with "Hmem2") as "(Hmem2 & p_tx1)";auto.
    rewrite set_of_addr_union in Hdom_mem2.
    2 : {
      solve_NoDup 4.
    }
    apply dom_union_inv_L in Hdom_mem2.
    2 : {
      apply set_of_addr_disj.
      solve_NoDup 4.
    }
    destruct Hdom_mem2 as (mem5 & mem_p_tx0 & -> & Hmem8_disj  & Hdom_mem3 & Hdom_mem_p_tx0).
    iDestruct ((big_sepM_union _ _) with "Hmem2") as "(Hmem2 & p_tx0)";auto.

    subst p q r t.

    clear Hmem8_disj Hmem7_disj Hmem6_disj Hmem5_disj Hmem4_disj Hmem3_disj.

    iAssert (trans.fresh_handles 1 valid_handles)%I with "[Hhpool Htrans Hretri]" as "Hp".
    {
      unfold trans.fresh_handles.
      unfold get_hpool_gset.
      unfold get_fresh_handles.
      rewrite hpool_mapsto_eq /hpool_mapsto_def.
      rewrite Htrans.
      simpl.
      rewrite map_filter_singleton_True.
      rewrite dom_singleton_L.
      rewrite intersection_idemp_L.
      iFrame "Hhpool".

      rewrite big_sepS_sep.
      unfold get_trans_gmap.
      unfold get_retri_gmap.
      unfold get_transactions_gmap.
      rewrite Htrans.
      rewrite !map_fmap_singleton.
      rewrite !big_sepM_singleton.
      rewrite !big_sepS_singleton.
      iSplitL "Htrans".
      rewrite trans_mapsto_eq /trans_mapsto_def /=.
      iFrame. done.
      rewrite retri_mapsto_eq /retri_mapsto_def /=.
      iFrame. done.
      done.
    }

    iDestruct (big_sepM_subseteq _ (get_access_gmap σ) {[V0 := (to_dfrac_agree (DfracOwn 1) ({[p_share; p_prog0; p_tx0]})); V1 := (to_dfrac_agree (DfracOwn 1) ({[p_prog1; p_tx1; p_rx1]})); V2 := (to_dfrac_agree (DfracOwn 1) ({[p_tx2;p_rx2;p_prog2]}))]} with "Haccess") as "access"; eauto.
    {
      apply access_layout_get_access_gmap.
      assumption.
    }
    iEval (rewrite big_opM_insert_delete) in "access".
    match goal with
    | |- context G [delete _ ?p] => set P := p
    end.
    assert (delete V0 P = P) as ->.
    {
      subst P.
      clear.
      apply delete_notin.
      by simplify_map_eq /=.
    }
    subst P.
    iEval (rewrite big_opM_insert_delete) in "access".
    match goal with
    | |- context G [delete _ ?p] => set P := p
    end.
    assert (delete V1 P = P) as ->.
    {
      subst P.
      clear.
      apply delete_notin.
      by simplify_map_eq /=.
    }
    subst P.
    iEval (rewrite big_sepM_singleton) in "access".
    iDestruct "access" as "(access1 & access2 & access3)".

    iDestruct (big_sepM_subseteq _ (get_excl_gmap σ) {[p_rx0 := true; p_rx1 := true; p_rx2 := true; p_tx2 := true; p_prog2 := true; p_share := true]} with "Hexcl") as "excl"; eauto.
    {
      apply excl_layout_get_excl_gmap.
      assumption.
    }
    iEval (rewrite big_opM_insert_delete) in "excl".
    match goal with
    | |- context G [delete _ ?p] => set P := p
    end.
    assert (delete p_rx0 P = P) as ->.
    {
      subst P.
      apply delete_notin.
      rewrite <-not_elem_of_dom.
      rewrite !dom_insert_L.
      rewrite dom_empty_L.
      rewrite union_empty_r.
      solve_NoDup_pre.
      solve_NoDup_pre'.
      solve_NoDup_pre'' 7 8.
      solve_NoDup 7.
    }
    subst P.
    iEval (rewrite big_opM_insert_delete) in "excl".
    match goal with
    | |- context G [delete _ ?p] => set P := p
    end.
    assert (delete p_rx1 P = P) as ->.
    {
      subst P.
      apply delete_notin.
      rewrite <-not_elem_of_dom.
      rewrite !dom_insert_L.
      rewrite dom_empty_L.
      rewrite union_empty_r.
      solve_NoDup_pre.
      solve_NoDup_pre'.
      solve_NoDup_pre'' 8 9.
      solve_NoDup 8.
    }
    subst P.
    iEval (rewrite big_opM_insert_delete) in "excl".
    match goal with
    | |- context G [delete _ ?p] => set P := p
    end.
    assert (delete p_rx2 P = P) as ->.
    {
      subst P.
      apply delete_notin.
      rewrite <-not_elem_of_dom.
      rewrite !dom_insert_L.
      rewrite dom_empty_L.
      rewrite union_empty_r.
      solve_NoDup_pre.
      solve_NoDup_pre'.
      solve_NoDup_pre'' 6 9.
      destruct eq as [-> | ->].
      solve_NoDup_pre'' 2 9.
      solve_NoDup_pre'' 3 9.
    }
    subst P.
    iEval (rewrite big_opM_insert_delete) in "excl".
    match goal with
    | |- context G [delete _ ?p] => set P := p
    end.
    assert (delete p_tx2 P = P) as ->.
    {
      subst P.
      apply delete_notin.
      rewrite <-not_elem_of_dom.
      rewrite !dom_insert_L.
      rewrite dom_empty_L.
      rewrite union_empty_r.
      solve_NoDup_pre.
      destruct contra as [-> | ->].
      solve_NoDup_pre'' 2 6.
      solve_NoDup_pre'' 3 6.
    }
    subst P.
    iEval (rewrite big_opM_insert_delete) in "excl".
    match goal with
    | |- context G [delete _ ?p] => set P := p
    end.
    assert (delete p_prog2 P = P) as ->.
    {
      subst P.
      apply delete_notin.
      rewrite <-not_elem_of_dom.
      rewrite !dom_insert_L.
      rewrite dom_empty_L.
      rewrite union_empty_r.
      rewrite !elem_of_singleton.
      intros ->.
      solve_NoDup_pre'' 2 3.
    }
    subst P.

    iEval (rewrite big_sepM_singleton) in "excl".
    iDestruct "excl" as "(excl1 & excl2 & excl3 & excl4 & excl5 & excl6)".

    iDestruct (big_sepM_subseteq _ (get_own_gmap σ) {[p_rx0 := None; p_rx1 := None; p_rx2 := None; p_tx2 := None; p_prog2 := Some V2; p_share := Some V0]} with "Hown") as "own"; eauto.
    {
      apply own_layout_get_own_gmap.
      assumption.
    }
    iEval (rewrite big_opM_insert_delete) in "own".
    match goal with
    | |- context G [delete _ ?p] => set P := p
    end.
    assert (delete p_rx0 P = P) as ->.
    {
      subst P.
      apply delete_notin.
      rewrite <-not_elem_of_dom.
      rewrite !dom_insert_L.
      rewrite dom_empty_L.
      rewrite union_empty_r.
      solve_NoDup_pre.
      solve_NoDup_pre'.
      solve_NoDup_pre'' 7 8.
      solve_NoDup 7.
    }
    subst P.
    iEval (rewrite big_opM_insert_delete) in "own".
    match goal with
    | |- context G [delete _ ?p] => set P := p
    end.
    assert (delete p_rx1 P = P) as ->.
    {
      subst P.
      apply delete_notin.
      rewrite <-not_elem_of_dom.
      rewrite !dom_insert_L.
      rewrite dom_empty_L.
      rewrite union_empty_r.
      solve_NoDup_pre.
      solve_NoDup_pre'.
      solve_NoDup_pre'' 8 9.
      solve_NoDup 8.
    }
    subst P.
    iEval (rewrite big_opM_insert_delete) in "own".
    match goal with
    | |- context G [delete _ ?p] => set P := p
    end.
    assert (delete p_rx2 P = P) as ->.
    {
      subst P.
      apply delete_notin.
      rewrite <-not_elem_of_dom.
      rewrite !dom_insert_L.
      rewrite dom_empty_L.
      rewrite union_empty_r.
      solve_NoDup_pre.
      solve_NoDup_pre'.
      solve_NoDup_pre'' 6 9.
      solve_NoDup 9.
    }
    subst P.
    iEval (rewrite big_opM_insert_delete) in "own".
    match goal with
    | |- context G [delete _ ?p] => set P := p
    end.
    assert (delete p_tx2 P = P) as ->.
    {
      subst P.
      apply delete_notin.
      rewrite <-not_elem_of_dom.
      rewrite !dom_insert_L.
      rewrite dom_empty_L.
      rewrite union_empty_r.
      solve_NoDup 6.
    }
    subst P.
    iEval (rewrite big_opM_insert_delete) in "own".
    match goal with
    | |- context G [delete _ ?p] => set P := p
    end.
    assert (delete p_prog2 P = P) as ->.
    {
      subst P.
      apply delete_notin.
      rewrite <-not_elem_of_dom.
      rewrite !dom_insert_L.
      rewrite dom_empty_L.
      rewrite union_empty_r.
      solve_NoDup 3.
    }
    subst P.
    iEval (rewrite big_sepM_singleton) in "own".
    iDestruct "own" as "(own1 & own2 & own3 & own4 & own5 & own6)".

    iDestruct (ghost_map_elem_persist with "mb0TX") as ">mb0TX".
    iDestruct (ghost_map_elem_persist with "mb1TX") as ">mb1TX".
    iDestruct (ghost_map_elem_persist with "mb2TX") as ">mb2TX".
    iDestruct (ghost_map_elem_persist with "mb0RX") as ">mb0RX".
    iDestruct (ghost_map_elem_persist with "mb1RX") as ">mb1RX".
    iDestruct (ghost_map_elem_persist with "mb2RX") as ">mb2RX".

    iModIntro.

    (* allocate VMProps *)
    set pgt := (get_page_table σ).
    iExists [True%I;
      (R0 @@ V0 ->r run_I ∗ R1 @@ V0 ->r encode_vmid V1 ∗ addr ->a two  ∗ (∃ (wh : Addr), (∃ (β : lang.mem), wh ->t (V0, V1, {[p_share]}, Sharing) ∗
                                                                                wh ->re false ∗ RX_state@V1 := Some (of_imm one, V0) ∗ RX@V1:=p_rx1 ∗ memory_page p_rx1 β ∗ ⌜β !! (of_imm i_prx1) = Some wh⌝) ∗
                    VMProp V0 ((R0 @@ V0 ->r yield_I ∗ R1 @@ V0 ->r encode_vmid V1 ∗ addr ->a four ∗ wh ->t (V0, V1, {[p_share]}, Sharing) ∗ RX@V1:=p_rx1 ∗ RX_state@V1 := None ∗ (∃ mem_rx, memory_page p_rx1 mem_rx)) ∗
                                 VMProp V1 False%I (1/2)%Qp) (1/2)%Qp))%I;
      (vmprop_unknown V2 mtms_slice_trans mtms_slice_rxs ∅)].
    iSimpl.
    iSplit; first done.

    (* frame state_interp *)
    iSplitL "Hσmem Hσreg Hσaccess Hσown Hσexcl Hσrxs Hσmb Hσhpool Hσtrans Hσretri".
    iFrame.
    rewrite /inv_trans_wellformed /inv_trans_wellformed'.
    rewrite /inv_trans_pgt_consistent /inv_trans_pgt_consistent'.
    rewrite Htrans.
    repeat iSplit.
    done.
    {
      rewrite /inv_trans_pg_num_ub.
      iPureIntro.
      rewrite map_Forall_singleton //.
    }
    {
      rewrite /inv_trans_sndr_rcvr_neq.
      iPureIntro.
      rewrite map_Forall_singleton //.
    }
    {
      rewrite /inv_finite_handles.
      iPureIntro.
      rewrite dom_singleton_L //.
    }
    {
      iPureIntro.
      rewrite /inv_trans_ps_disj /inv_trans_ps_disj'.
      rewrite Htrans.
      rewrite map_Forall_singleton //.
    }
    {
      iPureIntro.
      rewrite map_Forall_singleton //.
    }

    iIntros "(VMProp0 & VMProp1 & VMProp2 & _)".
    rewrite /scheduled /machine.scheduler /= /scheduler Hcur /=.

    iDestruct (VMProp_split with "VMProp1") as "[VMProp1_half VMProp1_half']".
    iDestruct (VMProp_split with "VMProp2") as "[VMProp2_half VMProp2_half']".

    pose proof (@access_split mtms_vmconfig irisΣ VMG 1 V2) as Hsplit.
    rewrite access_mapsto_eq /access_mapsto_def in Hsplit.
    (* iDestruct "access3" as "(access3 & access3')". *)
    iAssert ((V2, RX) ↪[ mb_gname ]□ p_rx2 ∗ (V2, RX) ↪[ mb_gname ]□ p_rx2)%I with "[mb2RX]" as "(mb2RX & mb2RX')".
    {
      iDestruct "mb2RX" as "#mb2RX".
      iFrame "mb2RX".
    }

    iSplitL "PCz R0z R1z R2z R3z R4z R5z mem_p_prog0 p_tx0 mem_p Hp VMProp0 VMProp1_half' VMProp2_half' mb0RX mb1RX RX0St RX1St RX2St p_rx0 p_rx1 p_rx2 mb0TX mb2RX access1 excl1 excl2 excl6 own1 own2 own6".
    iIntros "_".

    iApply (wp_mono _ _ _ (λ m,  ⌜m = HaltI⌝ ∗
                 addr ->a four ∗
            V0 -@A> {[p_share; p_prog0; p_tx0]} ∗ TX@V0:=p_tx0 ∗
                 PC @@ V0 ->r ((of_pid p_prog0) ^+ (length (mtms_program0 addr i_ptx0)))%f)%I).
    intros.
    iIntros "[$ _]".

    iApply (mtms_machine0 p_prog0 p_prog1 p_prog2 p_tx0 p_rx0 p_tx1 p_rx1 p_tx2 p_rx2 p_share Hps_nd with "[-]").
    {
      exact Heq_pshare.
    }
    assumption.
    exact Heq_prx1.
    program_in_seq.
    iSplitL "mem_p_prog0".
    {
      unfold program.
      iEval (rewrite big_opM_map_to_list) in "mem_p_prog0".
      rewrite big_sepL2_alt.
      iSplitR "mem_p_prog0".
      {
        simpl.
        by iPureIntro.
      }
      {
        rewrite mem_mapsto_eq /mem_mapsto_def.
        assert (mem_p_prog0 ⊆ σ.1.2) as Hsubseteq.
        {
          rewrite Hunion_mem'.
          apply map_union_subseteq_r'.
          assumption.
          apply map_union_subseteq_r'.
          assumption.
          done.
        }

        iApply (memory_list_gmap p_prog0 (mtms_program0 addr i_ptx0) _ mem_p_prog0 with "mem_p_prog0").
        - rewrite fst_zip.
          + apply finz_seq_NoDup'.
            simpl.
            pose proof (last_addr_in_bound p_prog0).
            solve_finz.
          + simpl.
            lia.
        - apply HmemH1; done.
      }
    }
      iSplitL "mem_p".
      {
        rewrite mem_mapsto_eq /mem_mapsto_def.
        assert (mem ⊆ σ.1.2) as Hsubseteq.
        {
          rewrite Hunion_mem'.
          apply map_union_subseteq_r'.
          assumption.
          apply map_union_subseteq_l'.
          apply map_union_subseteq_l'.
          apply map_union_subseteq_r'.
          assumption.
          done.
        }
        assert (of_imm addr ∈ set_of_addr {[p_share]}) as H.
        {
          apply elem_of_set_of_addr with (p_share).
          rewrite -Heq_pshare.
          apply elem_of_addr_of_page_iff.
          rewrite to_pid_aligned_eq //.
          set_solver +.
        }
        rewrite <-Hdom_mem_p in H.
        rewrite elem_of_dom in H.
        destruct H as [waddr Hwaddr].
        iDestruct (big_sepM_delete _ mem addr waddr with "mem_p") as "(mem & memacc)".
        assumption.
        iExists waddr.
        iFrame.
      }
      iSplitL "p_tx0".
      {
        unfold memory_page.
        iExists mem_p_tx0. iSplit. rewrite Hdom_mem_p_tx0. iPureIntro.
        rewrite set_of_addr_singleton //.
        rewrite mem_mapsto_eq /mem_mapsto_def /=.
        iFrame.
      }
      rewrite rx_state_mapsto_eq /rx_state_mapsto_def /=.
      iFrame "RX0St RX1St RX2St".
      unfold rx_page.
      rewrite mb_mapsto_eq /mb_mapsto_def /=.
      iFrame "mb0TX".
      iFrame "PCz".
      rewrite access_mapsto_eq /access_mapsto_def /=.
      rewrite big_sepS_singleton.
      iSplitL "excl6 own6".
      {
        rewrite excl_mapsto_eq own_mapsto_eq /excl_mapsto_def /own_mapsto_def /=.
        iFrame.
      }
      iSplitL "access1".
      {
        rewrite /to_frac_agree.
        iFrame.
      }
      iSplitL "R0z".
      iExists r0_; iFrame.
      iSplitL "R1z".
      iExists r1_; iFrame.
      iSplitL "R2z".
      iExists r2_; iFrame.
      iSplitL "R3z".
      iExists r3_; iFrame.
      iSplitL "R4z".
      iExists r4_; iFrame.
      iSplitL "R5z".
      iExists r5_; iFrame.
      iFrame "VMProp0".
      iFrame "VMProp1_half'".
      iFrame "VMProp2_half'".
      iFrame "Hp".
      iFrame.

      iSplitL "p_rx0 excl1 own1".
      iSplitR "p_rx0".
      rewrite excl_mapsto_eq own_mapsto_eq /excl_mapsto_def /own_mapsto_def /=.
      iFrame.
      unfold memory_page.
      iExists mem_p_rx0. iSplit. rewrite Hdom_mem_p_rx0. iPureIntro.
      apply set_of_addr_singleton.
      rewrite mem_mapsto_eq /mem_mapsto_def /=.
      iFrame "p_rx0".
      iSplitL "p_rx1 excl2 own2".
      iExists mem_p_rx1. iSplit. rewrite Hdom_mem_p_rx1. iPureIntro.
      apply set_of_addr_singleton.
      rewrite mem_mapsto_eq /mem_mapsto_def /=.
      iFrame "p_rx1".
      unfold memory_page.
      iExists mem_p_rx2. iSplit. rewrite Hdom_mem_p_rx2. iPureIntro.
      apply set_of_addr_singleton.
      rewrite mem_mapsto_eq /mem_mapsto_def /=.
      iFrame "p_rx2".

    iSplitL "VMProp1_half PC1 R01 R11 R21 R31 R41 R51 mem_p_prog1 p_tx1 mb1TX access2".

    iAssert ((VMProp_holds V1 (1 / 2) -∗ WP ExecI @ V1 {{ _, False }}) -∗
            VMProp_holds 1 (1 / 2) -∗ WP ExecI @ 1 {{ _, False }})%I as "WP".
    {
      iIntros "H".
      simpl.
      iApply "H".
    }
    iApply "WP".
    iApply (mtms_machine1 p_prog0 p_prog1 p_prog2 p_tx0 p_rx0 p_tx1 p_rx1 p_tx2 p_rx2 p_share Hps_nd with "[-]").
    {
      exact Heq_pshare.
    }
    {
      exact Heq_prx1.
    }
    {
      program_in_seq.
    }
    iSplitL "mem_p_prog1".
    unfold program.
    iEval (rewrite big_opM_map_to_list) in "mem_p_prog1".
    rewrite big_sepL2_alt.
    iSplit; first done.
    rewrite mem_mapsto_eq /mem_mapsto_def.
    {
      assert (mem_p_prog1 ⊆ σ.1.2) as Hsubseteq.
      {
        rewrite Hunion_mem'.
        apply map_union_subseteq_r'.
        assumption.
        apply map_union_subseteq_l'.
        apply map_union_subseteq_r'.
        assumption.
        done.
      }
      iApply (memory_list_gmap _ _ _ mem_p_prog1).
      - rewrite fst_zip.
        + apply finz_seq_NoDup'.
          simpl.
          pose proof (last_addr_in_bound p_prog1).
          solve_finz.
        + simpl.
          lia.
      - apply HmemH2; done.
      - by iFrame.
    }
    iSplitL "p_tx1".
    {
      unfold memory_page.
      iExists mem_p_tx1. iSplit. rewrite Hdom_mem_p_tx1. iPureIntro.
      rewrite set_of_addr_singleton //.
      rewrite mem_mapsto_eq /mem_mapsto_def /=.
      iFrame.
    }

    iSplitL "access2".
    {
      rewrite access_mapsto_eq /access_mapsto_def.
      simpl.
      iFrame "access2".
    }

    iSplitL "mb1TX".
    {
      rewrite mb_mapsto_eq /mb_mapsto_def /=.
      iFrame.
    }
    iFrame "PC1".
    iSplitL "R01".
    iExists r0__.
    iFrame.
    iSplitL "R11".
    iExists r1__.
    iFrame.
    iSplitL "R21".
    iExists r2__.
    iFrame.
    iSplitL "R31".
    iExists r3__.
    iFrame.
    iSplitL "R41".
    iExists r4__.
    iFrame.
    iSplitL "R51".
    iExists r5__.
    iFrame.
    iFrame "VMProp1_half".

    iSplitR ""; last done.
    iAssert ((VMProp_holds V2 (1 / 2) -∗ WP ExecI @ V2 {{ _, True }}) -∗
            VMProp_holds 2 (1 / 2) -∗ WP ExecI @ 2 {{ _, True }})%I as "WP".
    {
      iIntros "H".
      simpl.
      iApply "H".
    }
    iApply "WP".
    iApply (mtms_ftlr2 p_prog2 p_tx2 p_rx2 with "[-] []").
    2: { iPureIntro. cbn. done. }
    rewrite /mtms_interp_access2 /interp_access.
    repeat (iSplit;[iPureIntro|]).
    {
      rewrite /mtms_slice_trans.
      intros ? ? ? [|]; done.
    }
    {
      rewrite /mtms_slice_rxs.
      intros ?.
      destruct os;done.
    }
    {
      rewrite /mtms_slice_rxs.
      intros ?.
      destruct os;done.
    }
    {
      rewrite /mtms_slice_rxs.
      intros ??.
      destruct os.
      destruct p.
      intros.
      done.
      done.
    }
    {
      intros.
      rewrite /mtms_slice_rxs //.
    }

    iSplitL "Hreg2".
    iExists (get_reg_files σ !!! V2).
    unfold get_reg_gmap_vm.
    iSplit.
    iPureIntro.
    unfold base_extra.is_total_gmap.
    apply Htotal_reg.
    simpl.
    {
      set g := (λ p0 : reg_name * Addr, (p0.1, 2%fin, p0.2)).
      unfold V2.
      simpl.
      set l := (σ.1.1.1.1.1 !!! 2%fin).
      iEval (rewrite big_opM_map_to_list) in "Hreg2".
      rewrite map_to_list_to_map.
      rewrite big_opL_fmap.
      subst g.
      simpl.
      rewrite big_opM_map_to_list.
      iFrame "Hreg2".
      subst g.
      apply NoDup_fmap_fst.
      intros [x1 x2] y1 y2 Hh Hh'.
      rewrite elem_of_list_In in Hh.
      rewrite elem_of_list_In in Hh'.
      rewrite in_map_iff in Hh.
      rewrite in_map_iff in Hh'.
      destruct Hh as [(x & x') [Hheq Hh]].
      destruct Hh' as [(t & t') [Hh'eq Hh']].
      simpl in Hheq.
      simpl in Hh'eq.
      inversion Hheq.
      inversion Hh'eq.
      simplify_eq.
      clear Hheq Hh'eq.
      rewrite <-elem_of_list_In in Hh.
      rewrite <-elem_of_list_In in Hh'.
      apply map_to_list_unique with l x1; auto.
      apply NoDup_fmap_2.
      intros a b abeq.
      inversion abeq.
      destruct a, b; simpl in *.
      by simplify_eq.
      apply NoDup_map_to_list.
    }
    iFrame "VMProp2_half".
    rewrite difference_empty_L.
    unfold transaction_pagetable_entries_owned.
    unfold retrieved_transaction_owned.
    rewrite -!big_sepFM_empty.
    assert (({[p_prog2; p_tx2; p_rx2]} ∖ {[p_rx2; p_tx2]}) = {[p_prog2]}) as ->.
    {
      rewrite !difference_union_distr_l_L.
      rewrite difference_disjoint_L.
      assert ({[p_tx2]} ∖ {[p_rx2; p_tx2]} = ∅) as ->.
      { set_solver +. }
      assert ({[p_rx2]} ∖ {[p_rx2; p_tx2]} = ∅) as ->.
      { set_solver +. }
      set_solver +.
      apply disjoint_singleton_l.
      intros contra.
      rewrite elem_of_union in contra.
      rewrite !elem_of_singleton in contra.
      solve_NoDup_pre'.
      solve_NoDup_pre'' 2 9.
      solve_NoDup_pre'' 2 6.
    }
    unfold pagetable_entries_excl_owned.
    unfold logrel.pgt.
    rewrite !big_sepS_singleton.
    unfold tx_page.
    iSplitL "mb2TX p_tx2 excl4 own4".
    iSplitR "p_tx2".
    rewrite mb_mapsto_eq /mb_mapsto_def.
    rewrite excl_mapsto_eq own_mapsto_eq /excl_mapsto_def /own_mapsto_def.
    iFrame.
    iExists mem_p_tx2. unfold memory_page. iSplit. iPureIntro.
    rewrite Hdom_mem_p_tx2.
    apply set_of_addr_singleton.
    rewrite mem_mapsto_eq /mem_mapsto_def.
    iFrame "p_tx2".
    rewrite access_mapsto_eq /access_mapsto_def /=.
    assert ({[p_tx2; p_rx2; p_prog2]} = {[p_prog2; p_tx2; p_rx2]}) as -> by set_solver +.
    iFrame "access3".
    unfold rx_page.

    iSplitL "mb2RX' excl3 own3".
    {
      rewrite excl_mapsto_eq /excl_mapsto_def.
      rewrite own_mapsto_eq /own_mapsto_def.
      rewrite mb_mapsto_eq /mb_mapsto_def.
      iFrame.
    }

    iSplit. iPureIntro. set_solver +.
    iSplit. iPureIntro. set_solver +.

    iSplitL "excl5 own5".
    {
      rewrite excl_mapsto_eq /excl_mapsto_def.
      rewrite own_mapsto_eq /own_mapsto_def.
      iFrame.
    }

    iSplit; first done.
    iSplit; first done.

    iExists mem5. unfold memory_pages. iSplit.
    iPureIntro.
    rewrite /retrieved_lending_memory_pages.
    rewrite map_filter_empty pages_in_trans_empty union_empty_r_L //.
    rewrite mem_mapsto_eq /mem_mapsto_def.
    iFrame "Hmem2".
   Qed.

End mtms_adequacy.


Require Import Category.Theory.
Require Import Category.Functor.Opposite.

Require Import Core.Basics.
Require Import Core.HVec.
Require Import FOL.Signature.
Require Import FOL.Algebra.
Require Import Institutions.
Require Import FOL.Sentence.
Require Import EVT.Basics.
Require Import Institutions.InsFOPEQ.
Require Import Institutions.InsEVT.

Require Import Coq.Program.Equality.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.ProofIrrelevance.

(*****************************************************************************)
(** ρ_sig *)
Inductive TrivialEvents := .

Definition fobj_promote (Σ : FOSig) : EvtSig.
  unshelve refine {|
    base := Σ ;
    vars  := {| varnames := Empty_set |} ;
    vars' := {| varnames := Empty_set |} ;
    prime_rel := _ ;
  |}; try exact void.
  - intros ?; contradiction.
  - intros ?; contradiction.
  - unshelve esplit; cbn; auto.
    exists void; cbn; contradiction.
    exists void; cbn; contradiction.
    intros ?; contradiction.
    intros ?; contradiction.
Defined.

Definition fmap_promote
    {Σ Σ' : FOSig} (f : Σ ~> Σ')
    : fobj_promote Σ ~> fobj_promote Σ'.
  unshelve refine {|
    on_base   := _ ;
    on_vars   := _ ;
  |}.
  - exact f.
  - exists void; cbn; intros; contradiction.
Defined.

Program Definition promote : FOSig ⟶ EvtSig := {|
  fobj := @fobj_promote ;
  fmap := @fmap_promote ;
|}.
Next Obligation.
  unfold fmap_promote.
  refine (
    eq_evtsigmorphism _ _ (fmap_promote (id_FOSig x)) (id_EvtSig (fobj_promote x))
    eq_refl eq_refl _
  ); cbn. apply subset_eq_compat. funext ?; contradiction.
Qed.
Next Obligation.
  refine (
    eq_evtsigmorphism _ _ (fmap_promote (comp_FOSig f g)) (comp_EvtSig (fmap_promote f) (fmap_promote g))
    eq_refl eq_refl _
  ); cbn; apply subset_eq_compat; funext ?; contradiction.
Qed.

(*****************************************************************************)
(** ρ_sen : FOSen ⟹ EvtSen ◯ promote *)

Definition inc_sen_sig_mor (Σ : FOSig) : Σ ~> SigExpansion (promote Σ) (vars' (promote Σ)).
refine {|
  on_sorts := idmap : Sorts Σ -> Sorts (SigExpansion (promote Σ) (vars' (promote Σ))) ;
  on_funcs := λ w s F, _ ;
  on_preds := λ w P, _ ;
|}.
  - destruct w.
    + left. exact F.
    + exact (rew [λ w, Funcs Σ (s0 :: w) s] (map_id w)^ in F).
  - exact (rew (map_id w)^ in P).
Defined.

Definition include_sentence (Σ : FOSig) (φ : FOSen Σ) : EvtSen (promote Σ) :=
  Init (fmap[FOSen] (inc_sen_sig_mor Σ) φ).

Lemma fmap_promote_include Σ Σ' σ φ :
  fmap_EVT (fmap_promote σ) (include_sentence Σ φ) =
    include_sentence Σ' (fmap_FOPEQ σ φ).
Proof.
  unfold include_sentence; cbn; f_equal.
  pose proof (moveR_transport_V _ _ _ _ (fmap_compose_FOSen (flatten_init_morphism (fmap_promote σ)) (inc_sen_sig_mor Σ) φ)).
  cbn in H. rewrite <- H. simplify_eqs.
  pose proof (moveR_transport_V _ _ _ _ (fmap_compose_FOSen (inc_sen_sig_mor Σ') σ φ)).
  cbn in H0. rewrite <- H0. simplify_eqs. f_equal.
  unfold comp_FOSig; f_equal; [ funext w s F | funext w P ]; cbn.
  - destruct w; cbn. now simplify_eqs.
    rewrite map_map_cons_pfs.
    rewrite <- rew_map.
    simplify_eqs; destruct eqH, eqH0, eqH2; cbn.
    now simplify_eqs.
  - simplify_eqs. destruct eqH, eqH0, eqH2. now simplify_eqs.
Qed.

Program Definition inc_sen : FOSen ⟹ EvtSen ◯ promote := {|
  transform := include_sentence ;
  naturality := _ ;
  naturality_sym := _ ;
|}.
Next Obligation.
  now rewrite <- fmap_promote_include.
Qed.
Next Obligation.
  now rewrite <- fmap_promote_include.
Qed.


Require Import list_examples.

Definition add_body := Ref (Cons (Var 1) (Var 0)).

Inductive add_spec : Spec cfg :=
  add_claim : forall x r env, exp_val add_spec
  add_body (r::x::env) emptyP (list_seg (x::nil) r).

Lemma add_proof : sound lam_step add_spec.
Proof. list_solver. Qed.


Require Import Util IL DecSolve Indexwise.

Inductive noParams : stmt->Prop :=
| NoParamsLet
    x e s
    (NoParamsIH:noParams s)
    : noParams (stmtLet x e s)
| NoParamsIf
    e s t
    (NoParamsIH1:noParams s)
    (NoParamsIH2:noParams t)
  : noParams (stmtIf e s t)
| NoParamsApp l :
   noParams (stmtApp l nil)
| NoParamsExp e :
    noParams (stmtReturn e)
| NoParamsCall F t
  (NoParamsIHF:forall n Zs, get F n Zs -> noParams (snd Zs))
  (NoParamsF:forall n Zs, get F n Zs -> fst Zs = nil)
  (NoParamsIHt:noParams t)
  : noParams (stmtFun F t).

Instance noParams_computable s : Computable (noParams s).
Proof.
    sind s; destruct s.
  - destruct (IH s); try dec_solve.
  - destruct (IH s1); eauto; try dec_solve;
      destruct (IH s2); eauto; try dec_solve.
  - destruct Y; dec_solve.
  - dec_solve.
  - destruct (IH s); eauto; try dec_solve.
    assert (Computable (forall n Zs, get F n Zs -> noParams (snd Zs))). {
      eapply indexwise_P_dec.
      intros.
      destruct (IH (snd a)); eauto;
        dec_solve.
    }
    assert (Computable (forall n Zs, get F n Zs -> fst Zs = nil)). {
      eapply indexwise_P_dec. intros.
      destruct (fst a); try dec_solve.
    }
    destruct H, H0; dec_solve.
Qed.


(** * Shallow equivalence *)

(** Equality under [observe]: file adapted from the equivalent concept in [itree].

[[
  observing eq t1 t2 <-> t1.(observe) = t2.(observe)
]]

  We actually define a more general relation transformer
  [observing] to lift arbitrary relations through [observe].
 *)

(* begin hide *)
From CTree Require Import
     CTree.

From Coq Require Import
     Classes.RelationClasses
     Classes.Morphisms
     Setoids.Setoid
     Relations.Relations
     JMeq.

Set Implicit Arguments.
(* end hide *)

Definition eqeq {A : Type} (P : A -> Type) {a1 a2 : A} (p : a1 = a2) : P a1 -> P a2 -> Prop :=
  match p with
  | eq_refl => eq
  end.

Definition pweqeq {R1 R2} (RR : R1 -> R2 -> Prop) {X1 X2 : Type} (p : X1 = X2)
  : (X1 -> R1) -> (X2 -> R2) -> Prop :=
  match p with
  | eq_refl => fun k1 k2 => forall x, RR (k1 x) (k2 x)
  end.

Lemma pweqeq_mon {R1 R2} (RR1 RR2 : R1 -> R2 -> Prop) X1 X2 (p : X1 = X2) k1 k2
  : (forall r1 r2, RR1 r1 r2 -> RR2 r1 r2) -> pweqeq RR1 p k1 k2 -> pweqeq RR2 p k1 k2.
Proof.
  destruct p; cbn; auto.
Qed.

(** ** [observing]: Lift relations through [observe]. *)
Record observing {E R1 R2}
           (eq_ : ctree' E R1 -> ctree' E R2 -> Prop)
           (t1 : ctree E R1) (t2 : ctree E R2) : Prop :=
  observing_intros
  { observing_observe : eq_ (observe t1) (observe t2) }.
#[global] Hint Constructors observing: core.

Section observing_relations.

Context {E : Type -> Type} {R : Type}.
Variable (eq_ : ctree' E R -> ctree' E R -> Prop).

#[global] Instance observing_observe_ :
  Proper (observing eq_ ==> eq_) (@observe E R).
Proof. intros ? ? []; cbv; auto. Qed.

#[global] Instance observing_go : Proper (eq_ ==> observing eq_) (@go E R).
Proof. cbv; auto. Qed.

#[global] Instance monotonic_observing eq_' :
  subrelation eq_ eq_' ->
  subrelation (observing eq_) (observing eq_').
Proof. intros ? ? ? []; cbv; eauto. Qed.

#[global] Instance Equivalence_observing :
  Equivalence eq_ -> Equivalence (observing eq_).
Proof.
  intros []; split; cbv; auto.
  - intros ? ? []; auto.
  - intros ? ? ? [] []; eauto.
Qed.

End observing_relations.

(** ** Unfolding lemmas for [bind] *)

#[global] Instance observing_bind {E R S} :
  Proper (observing eq ==> eq ==> observing eq) (@CTree.bind E R S).
Proof.
  repeat intro; subst. constructor. unfold observe. cbn.
  rewrite (observing_observe H). reflexivity.
Qed.

Lemma bind_ret_ {E R S} (r : R) (k : R -> ctree E S) :
  observing eq (CTree.bind (Ret r) k) (k r).
Proof. constructor; reflexivity. Qed.

Lemma bind_Guard_ {E R} U t (k: U -> ctree E R) :
  observing eq (CTree.bind (Guard t) k) (Guard (CTree.bind t k)).
Proof. constructor; reflexivity. Qed.

Lemma bind_vis_ {E R U V} (e: E V) (ek: V -> ctree E U) (k: U -> ctree E R) :
  observing eq
    (CTree.bind (Vis e ek) k)
    (Vis e (fun x => CTree.bind (ek x) k)).
Proof. constructor; reflexivity. Qed.

(** Unfolding lemma for [aloop]. There is also a variant [unfold_aloop]
    without [Tau]. *)
Lemma unfold_aloop_ {E A B} (f : A -> ctree E (A + B)) (x : A) :
  observing eq
    (CTree.iter f x)
    (CTree.bind (f x) (fun lr => CTree.on_left lr l (Guard (CTree.iter f l)))).
Proof. constructor; reflexivity. Qed.

(** Unfolding lemma for [forever]. *)
Lemma unfold_forever_ {E R S} (t: ctree E R):
  observing eq (@CTree.forever E R S t) (CTree.bind t (fun _ => Guard (CTree.forever t))).
Proof. econstructor. reflexivity. Qed.

(** ** [going]: Lift relations through [go]. *)

Inductive going {E R1 R2} (r : ctree E R1 -> ctree E R2 -> Prop)
          (ot1 : ctree' E R1) (ot2 : ctree' E R2) : Prop :=
| going_intros : r (go ot1) (go ot2) -> going r ot1 ot2.
#[global] Hint Constructors going: core.

Lemma observing_going {E R1 R2} (eq_ : ctree' E R1 -> ctree' E R2 -> Prop) ot1 ot2 :
  going (observing eq_) ot1 ot2 <-> eq_ ot1 ot2.
Proof.
  split; auto.
  intros [[]]; auto.
Qed.

Section going_relations.

Context {E : Type -> Type} {R : Type}.
Variable (eq_ : ctree E R -> ctree E R -> Prop).

#[global] Instance going_go : Proper (going eq_ ==> eq_) (@go E R).
Proof. intros ? ? []; auto. Qed.

#[global] Instance monotonic_going eq_' :
  subrelation eq_ eq_' ->
  subrelation (going eq_) (going eq_').
Proof. intros ? ? ? []; eauto. Qed.

#[global] Instance Equivalence_going :
  Equivalence eq_ -> Equivalence (going eq_).
Proof.
  intros []; constructor; cbv; eauto.
  - intros ? ? []; auto.
  - intros ? ? ? [] []; eauto.
Qed.

End going_relations.


From Coq Require Import ZArith OrderedType.
From mathcomp Require Import ssreflect ssrbool ssrnat ssralg ssrfun choice eqtype.
From CompCert Require Import Integers.
From Common Require Import Bits Types SsrOrdered ZAriths.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** Byte, int, and int64 are eqTypes. *)

Definition byte_eq : byte -> byte -> bool := Byte.eq.
Definition int_eq : int -> int -> bool := Int.eq.
Definition int64_eq : int64 -> int64 -> bool := Int64.eq.

Ltac prove_int_eqtype :=
  let eq :=
      match goal with
      | |- Equality.axiom byte_eq => byte_eq
      | |- Equality.axiom int_eq => int_eq
      | |- Equality.axiom int64_eq => int64_eq
      | |- _ => fail
      end in
  let meq :=
      match goal with
      | |- Equality.axiom byte_eq => Byte.eq
      | |- Equality.axiom int_eq => Int.eq
      | |- Equality.axiom int64_eq => Int64.eq
      | |- _ => fail
      end in
  let unsigned :=
      match goal with
      | |- Equality.axiom byte_eq => Byte.unsigned
      | |- Equality.axiom int_eq => Int.unsigned
      | |- Equality.axiom int64_eq => Int64.unsigned
      | |- _ => fail
      end in
  let repr :=
      match goal with
      | |- Equality.axiom byte_eq => Byte.repr
      | |- Equality.axiom int_eq => Int.repr
      | |- Equality.axiom int64_eq => Int64.repr
      | |- _ => fail
      end in
  let repr_unsigned :=
      match goal with
      | |- Equality.axiom byte_eq => Byte.repr_unsigned
      | |- Equality.axiom int_eq => Int.repr_unsigned
      | |- Equality.axiom int64_eq => Int64.repr_unsigned
      | |- _ => fail
      end in
  let n := fresh "n" in
  let m := fresh "m" in
  let H := fresh "H" in
  let Hnm := fresh "Hnm" in
  rewrite /eq /meq /Coqlib.zeq => n m;
  case: (Z.eq_dec (unsigned n) (unsigned m)) => H;
  [
    apply: ReflectT;
    have: repr (unsigned n) = repr (unsigned m);
    [
      rewrite H; reflexivity |
      rewrite 2!repr_unsigned; move=> Hnm; exact: Hnm
    ] |
    apply: ReflectF; move=> Hnm; apply: H; rewrite Hnm; reflexivity
  ].

Lemma byte_eqP : Equality.axiom byte_eq.
Proof.
  prove_int_eqtype.
Qed.

Canonical byte_eqMixin := EqMixin byte_eqP.
Canonical byte_eqType := Eval hnf in EqType byte byte_eqMixin.

Lemma int_eqP : Equality.axiom int_eq.
Proof.
  prove_int_eqtype.
Qed.

Canonical int_eqMixin := EqMixin int_eqP.
Canonical int_eqType := Eval hnf in EqType int int_eqMixin.

Lemma int64_eqP : Equality.axiom int64_eq.
Proof.
  prove_int_eqtype.
Qed.

Canonical int64_eqMixin := EqMixin int64_eqP.
Canonical int64_eqType := Eval hnf in EqType int64 int64_eqMixin.

Module ByteEqtype <: EQTYPE.
  Definition t := byte_eqType.
End ByteEqtype.

Module IntEqtype <: EQTYPE.
  Definition t := int_eqType.
End IntEqtype.

Module Int64Eqtype <: EQTYPE.
  Definition t := int64_eqType.
End Int64Eqtype.

(** Conversion from hex strings to CompCert integers. *)

Section HexStrings.

  From Coq Require Import Ascii.

  Lemma bits_range n (x : BITS n) : (-1 < toPosZ x < two_p (Z.of_nat n))%Z.
  Proof.
    split.
    - apply: (Z.lt_le_trans _ 0).
      + done.
      + exact: toPosZ_min.
    - rewrite two_p_correct. exact: toPosZ_max.
  Qed.

  Definition byte_of_bits8 (n : BITS 8) : byte :=
    {| Byte.intval := toPosZ n; Byte.intrange := bits_range n |}.

  Definition int_of_bits32 (n : BITS 32) : int :=
    {| Int.intval := toPosZ n; Int.intrange := bits_range n |}.

  Definition int64_of_bits64 (n : BITS 64) : int64 :=
    {| Int64.intval := toPosZ n; Int64.intrange := bits_range n |}.

  Definition byte_of_hex (str : 2.-string) : byte :=
    byte_of_bits8 (fromNString str).

  Definition int_of_hex (str : 8.-string) : int :=
    int_of_bits32 (fromNString str).

  Definition int64_of_hex (str : 16.-string) : int64 :=
    int64_of_bits64 (fromNString str).

End HexStrings.

(** Ordered types for byte, int, and int64 *)

Lemma byte_unsigned_inj x y :
  Byte.unsigned x = Byte.unsigned y -> byte_eq x y.
Proof.
  destruct x as [x rx]; destruct y as [y ry];
    rewrite /byte_eq /Byte.eq /= => Hxy.
  by case: (Coqlib.zeq x y).
Qed.

Lemma int_unsigned_inj x y :
  Int.unsigned x = Int.unsigned y -> int_eq x y.
Proof.
  destruct x as [x rx]; destruct y as [y ry];
    rewrite /int_eq /Int.eq /= => Hxy.
  by case: (Coqlib.zeq x y).
Qed.

Lemma int64_unsigned_inj x y :
  Int64.unsigned x = Int64.unsigned y -> int64_eq x y.
Proof.
  destruct x as [x rx]; destruct y as [y ry];
    rewrite /int64_eq /Int64.eq /= => Hxy.
  by case: (Coqlib.zeq x y).
Qed.

Module ByteOrderMinimal <: SsrOrderedTypeMinimal.

  Definition t : eqType := byte_eqType.

  Definition eq : t -> t -> bool := fun x y : t => x == y.

  Definition lt : t -> t -> bool := Byte.ltu.

  Hint Unfold eq lt.

  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    rewrite /lt /Byte.ltu /Coqlib.zlt /= => x y z.
    case: (Z_lt_dec (Byte.unsigned x) (Byte.unsigned y)) => //=.
    case: (Z_lt_dec (Byte.unsigned y) (Byte.unsigned z)) => //=.
    case: (Z_lt_dec (Byte.unsigned x) (Byte.unsigned z)) => //=.
    move=> Hxz Hyz Hxy _ _.
    apply: False_ind; apply: Hxz.
    exact: (Z.lt_trans _ _ _ Hxy Hyz).
  Qed.

  Lemma lt_not_eq : forall x y : t, lt x y -> x != y.
  Proof.
    rewrite /lt /Byte.ltu /Coqlib.zlt /= => x y.
    case: (Z_lt_dec (Byte.unsigned x) (Byte.unsigned y)) => //=.
    move=> Hlt _.
    apply/negP => Heq.
    rewrite (eqP Heq) in Hlt.
    apply: (Z.lt_irrefl (Byte.unsigned y)).
    assumption.
  Qed.

  Definition compare : forall x y : t, Compare lt eq x y.
  Proof.
    move=> x y.
    case Heq: (x == y); last case Hlt: (lt x y).
    - apply: EQ.
      assumption.
    - exact: (OrderedType.LT Hlt).
    - apply: GT.
      move: Hlt.
      rewrite /lt /Byte.ltu.
      case: (Coqlib.zlt (Byte.unsigned x) (Byte.unsigned y)) => //=.
      move=> Hge _.
      move: (Z.ge_le _ _ Hge) => Hle.
      move: (Z.le_lteq (Byte.unsigned y) (Byte.unsigned x)) => [H _].
      case: (H Hle) => {H} Hyx.
      + by case: (Coqlib.zlt (Byte.unsigned y) (Byte.unsigned x)).
      + apply: False_ind.
        move/negP: Heq; apply.
        rewrite eq_sym.
        exact: (byte_unsigned_inj Hyx).
  Defined.

End ByteOrderMinimal.

Module ByteOrder <: SsrOrderedType := MakeSsrOrderedType ByteOrderMinimal.

Module IntOrderMinimal <: SsrOrderedTypeMinimal.

  Definition t : eqType := int_eqType.

  Definition eq : t -> t -> bool := fun x y : t => x == y.

  Definition lt : t -> t -> bool := Int.ltu.

  Hint Unfold eq lt.

  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    rewrite /lt /Int.ltu /Coqlib.zlt /= => x y z.
    case: (Z_lt_dec (Int.unsigned x) (Int.unsigned y)) => //=.
    case: (Z_lt_dec (Int.unsigned y) (Int.unsigned z)) => //=.
    case: (Z_lt_dec (Int.unsigned x) (Int.unsigned z)) => //=.
    move=> Hxz Hyz Hxy _ _.
    apply: False_ind; apply: Hxz.
    exact: (Z.lt_trans _ _ _ Hxy Hyz).
  Qed.

  Lemma lt_not_eq : forall x y : t, lt x y -> x != y.
  Proof.
    rewrite /lt /Int.ltu /Coqlib.zlt /= => x y.
    case: (Z_lt_dec (Int.unsigned x) (Int.unsigned y)) => //=.
    move=> Hlt _.
    apply/negP => Heq.
    rewrite (eqP Heq) in Hlt.
    apply: (Z.lt_irrefl (Int.unsigned y)).
    assumption.
  Qed.

  Definition compare : forall x y : t, Compare lt eq x y.
  Proof.
    move=> x y.
    case Heq: (x == y); last case Hlt: (lt x y).
    - apply: EQ.
      assumption.
    - exact: (OrderedType.LT Hlt).
    - apply: GT.
      move: Hlt.
      rewrite /lt /Int.ltu.
      case: (Coqlib.zlt (Int.unsigned x) (Int.unsigned y)) => //=.
      move=> Hge _.
      move: (Z.ge_le _ _ Hge) => Hle.
      move: (Z.le_lteq (Int.unsigned y) (Int.unsigned x)) => [H _].
      case: (H Hle) => {H} Hyx.
      + by case: (Coqlib.zlt (Int.unsigned y) (Int.unsigned x)).
      + apply: False_ind.
        move/negP: Heq; apply.
        rewrite eq_sym.
        exact: (int_unsigned_inj Hyx).
  Defined.

End IntOrderMinimal.

Module IntOrder <: SsrOrderedType := MakeSsrOrderedType IntOrderMinimal.

Module Int64OrderMinimal <: SsrOrderedTypeMinimal.

  Definition t : eqType := int64_eqType.

  Definition eq : t -> t -> bool := fun x y : t => x == y.

  Definition lt : t -> t -> bool := Int64.ltu.

  Hint Unfold eq lt.

  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    rewrite /lt /Int64.ltu /Coqlib.zlt /= => x y z.
    case: (Z_lt_dec (Int64.unsigned x) (Int64.unsigned y)) => //=.
    case: (Z_lt_dec (Int64.unsigned y) (Int64.unsigned z)) => //=.
    case: (Z_lt_dec (Int64.unsigned x) (Int64.unsigned z)) => //=.
    move=> Hxz Hyz Hxy _ _.
    apply: False_ind; apply: Hxz.
    exact: (Z.lt_trans _ _ _ Hxy Hyz).
  Qed.

  Lemma lt_not_eq : forall x y : t, lt x y -> x != y.
  Proof.
    rewrite /lt /Int64.ltu /Coqlib.zlt /= => x y.
    case: (Z_lt_dec (Int64.unsigned x) (Int64.unsigned y)) => //=.
    move=> Hlt _.
    apply/negP => Heq.
    rewrite (eqP Heq) in Hlt.
    apply: (Z.lt_irrefl (Int64.unsigned y)).
    assumption.
  Qed.

  Definition compare : forall x y : t, Compare lt eq x y.
  Proof.
    move=> x y.
    case Heq: (x == y); last case Hlt: (lt x y).
    - apply: EQ.
      assumption.
    - exact: (OrderedType.LT Hlt).
    - apply: GT.
      move: Hlt.
      rewrite /lt /Int64.ltu.
      case: (Coqlib.zlt (Int64.unsigned x) (Int64.unsigned y)) => //=.
      move=> Hge _.
      move: (Z.ge_le _ _ Hge) => Hle.
      move: (Z.le_lteq (Int64.unsigned y) (Int64.unsigned x)) => [H _].
      case: (H Hle) => {H} Hyx.
      + by case: (Coqlib.zlt (Int64.unsigned y) (Int64.unsigned x)).
      + apply: False_ind.
        move/negP: Heq; apply.
        rewrite eq_sym.
        exact: (int64_unsigned_inj Hyx).
  Defined.

End Int64OrderMinimal.

Module Int64Order <: SsrOrderedType := MakeSsrOrderedType Int64OrderMinimal.

(** Additional functions added to CompCert modules Byte, Int, and Int64 *)

Module Byte.

  Include CompCert.Integers.Byte.
  Definition pow_pos x := Pos.iter (Byte.mul x) Byte.one.
  Definition of_bool b := if b then Byte.one else Byte.zero.
  Definition to_bool n := if n == zero then false else true.

  Lemma to_boolK : forall b : bool, to_bool (of_bool b) = b.
  Proof.
    by case.
  Qed.

  Lemma of_boolK1 : forall n : byte, n = zero -> of_bool (to_bool n) = zero.
  Proof.
    move=> n H; rewrite H.
    reflexivity.
  Qed.

  Lemma of_boolK2 : forall n : byte, n <> zero -> of_bool (to_bool n) = one.
  Proof.
    move=> n H.
    rewrite /of_bool /to_bool.
    move/eqP/negPf: H => H.
    by rewrite H.
  Qed.

End Byte.

Module Int.

  Include CompCert.Integers.Int.
  Definition pow_pos x := Pos.iter (Int.mul x) Int.one.
  Definition of_bool b := if b then Int.one else Int.zero.
  Definition to_bool n := if n == zero then false else true.

  Lemma to_boolK : forall b : bool, to_bool (of_bool b) = b.
  Proof.
    by case.
  Qed.

  Lemma of_boolK1 : forall n : int, n = zero -> of_bool (to_bool n) = zero.
  Proof.
    move=> n H; rewrite H.
    reflexivity.
  Qed.

  Lemma of_boolK2 : forall n : int, n <> zero -> of_bool (to_bool n) = one.
  Proof.
    move=> n H.
    rewrite /of_bool /to_bool.
    move/eqP/negPf: H => H.
    by rewrite H.
  Qed.

End Int.

Module Int64.

  Include CompCert.Integers.Int64.
  Local Open Scope Z_scope.
  Definition int64_pow_pos x := Pos.iter (Int64.mul x) Int64.one.
  Definition of_bool b := if b then Int64.one else Int64.zero.
  Definition to_bool n := if n == zero then false else true.

  Lemma to_boolK : forall b : bool, to_bool (of_bool b) = b.
  Proof.
    by case.
  Qed.
  Lemma of_boolK1 : forall n : int64, n = zero -> of_bool (to_bool n) = zero.
  Proof.
    move=> n H; rewrite H.
    reflexivity.
  Qed.

  Lemma of_boolK2 : forall n : int64, n <> zero -> of_bool (to_bool n) = one.
  Proof.
    move=> n H.
    rewrite /of_bool /to_bool.
    move/eqP/negPf: H => H.
    by rewrite H.
  Qed.

  Lemma mul_mulhu :
    forall x y : int64,
      unsigned (mulhu x y) * modulus + unsigned (mul x y) =
      unsigned x * unsigned y.
  Proof.
    rewrite /mul /mulhu => x y.
    set (p := unsigned x * unsigned y).
    rewrite 2!unsigned_repr_eq.
    rewrite Z.mul_comm.
    rewrite Z.mod_small.
    - apply: Logic.eq_sym.
      apply: Z.div_mod.
      done.
    - split.
      + move: (unsigned_range x) => [Hx _].
        move: (unsigned_range y) => [Hy _].
        apply: Z.div_pos.
        * apply: (Z.le_trans _ _ _ _ (Z.mul_le_mono_nonneg_l 0 (unsigned y) (unsigned x) Hx Hy)).
          omega.
        * done.
      + exact: (Zdiv_mul_lt_l (unsigned_range x) (unsigned_range y)).
  Qed.

  Local Close Scope Z_scope.

End Int64.

Strategy 0 [Wordsize_32.wordsize].
Notation int := Int.int.

Strategy 0 [Wordsize_8.wordsize].
Notation byte := Byte.int.

Strategy 0 [Wordsize_64.wordsize].
Notation int64 := Int64.int.

Global Opaque Int.repr Int64.repr Byte.repr.


Require Import Coq.Strings.String.
Require Import Coq.Lists.List.

Require Export SystemFR.FVLemmas.
Require Export SystemFR.TypeErasureLemmas.
Require Export SystemFR.TermList.

Lemma satisfies_closed_mapping:
  forall P lterms Γ tag,
    satisfies P Γ lterms ->
    pclosed_mapping lterms tag.
Proof.
  induction lterms; destruct tag;
    repeat step || step_inversion satisfies ||
           unfold closed_term in *; eauto.
Qed.

#[export]
Hint Extern 50 => solve [ eapply satisfies_closed_mapping; eassumption ]: fv.

Lemma closed_mapping_append1:
  forall l1 l2 tag,
    pclosed_mapping (l1 ++ l2) tag ->
    pclosed_mapping l1 tag.
Proof.
  induction l1; steps; eauto.
Qed.

Lemma closed_mapping_append2:
  forall l1 l2 tag,
    pclosed_mapping (l1 ++ l2) tag ->
    pclosed_mapping l2 tag.
Proof.
  induction l1; steps.
Qed.

#[export]
Hint Extern 50 => solve [ eapply closed_mapping_append1; eauto 1 ]: b_cmap.
#[export]
Hint Extern 50 => solve [ eapply closed_mapping_append2; eauto 1 ]: b_cmap.

Lemma closed_mapping_append:
  forall l1 l2 tag,
    pclosed_mapping l1 tag ->
    pclosed_mapping l2 tag ->
    pclosed_mapping (l1 ++ l2) tag.
Proof.
  induction l1; steps.
Qed.

#[export]
Hint Extern 50 => eapply closed_mapping_append: b_cmap.

Lemma satisfies_fv_nil:
  forall P Γ lterms,
    satisfies P Γ lterms ->
    forall t,
      t ∈ range lterms ->
      fv t = nil.
Proof.
  steps.
  eapply closed_mapping_range; eauto.
  eapply satisfies_closed_mapping; eauto.
Qed.

#[export]
Hint Extern 50 => eapply satisfies_fv_nil: fv.

Lemma fv_satisfies_nil:
  forall P Γ lterms t,
    satisfies P Γ lterms ->
    subset (fv t) (support Γ) ->
    fv (substitute t lterms) = nil.
Proof.
  repeat step || t_termlist || list_utils || apply fv_nils2 || rewrite_any;
    eauto with fv b_cmap.
Qed.

#[export]
Hint Extern 50 => eapply fv_satisfies_nil: fv.

Lemma subset_same_support:
  forall P Γ lterms S,
    satisfies P Γ lterms ->
    subset S (support Γ) ->
    subset S (support lterms).
Proof.
  repeat step || t_termlist || rewrite_any.
Qed.

#[export]
Hint Immediate subset_same_support: fv.

Lemma fv_nils3:
  forall P Γ t l,
    is_annotated_term t ->
    subset (pfv t term_var) (support Γ) ->
    satisfies P (erase_context Γ) l ->
    pfv (psubstitute (erase_term t) l term_var) term_var = nil.
Proof.
  intros.
  apply fv_nils2; eauto with fv.
  eapply subset_same_support; eauto;
    repeat step || t_subset_erase || rewrite erased_context_support.
Qed.

#[export]
Hint Immediate fv_nils3: fv.

Lemma fv_subst_different_tag:
  forall t l tag tag',
    pclosed_mapping l tag ->
    tag <> tag' ->
    pfv (psubstitute t l tag') tag = pfv t tag.
Proof.
  induction t; repeat step || f_equal; eauto with fv.
Qed.

Lemma pfv_in_subst:
  forall (T : tree) (l : list (nat * tree)) (tag1 tag2 : fv_tag) (X : nat),
    pclosed_mapping l tag1 ->
    X ∈ pfv (psubstitute T l tag2) tag1->
    X ∈ pfv T tag1.
Proof.
  destruct tag1, tag2; repeat step || rewrite fv_subst_different_tag in * by steps.
  - epose proof (fv_subst2 _ _ _ X H0);
    repeat step || list_utils;
    eauto using closed_mapping_fv with exfalso.
  - epose proof (fv_subst2 _ _ _ X H0);
    repeat step || list_utils;
    eauto using closed_mapping_fv with exfalso.
Qed.

Ltac t_pfv_in_subst :=
  match goal with
  | H: _ ∈ pfv (psubstitute _ _ _) _ |- _ =>
      poseNew (Mark H "pfv_in_subst");
      unshelve epose proof (pfv_in_subst _ _ _ _ _ _ H)
  end.

Lemma subst_subst:
  forall t l ts xs tag,
    (forall x, x ∈ pfv t tag -> x ∈ support l -> False) ->
    psubstitute (psubstitute t (combine xs ts) tag) l tag =
    psubstitute t (combine xs (List.map (fun t' => psubstitute t' l tag) ts)) tag.
Proof.
  induction t; repeat step || t_equality;
    eauto 4 using lookup_combine_some_none, List.map_length with exfalso;
    try solve [ rewrite_any; steps; eapply_any; eauto; repeat step || list_utils ];
    try solve [ eapply_anywhere lookup_combine_map; eauto ];
    try solve [ t_lookup; eauto with exfalso ].
Qed.

Lemma subst_subst2:
  forall t l ts xs tag,
    length ts = length xs ->
    (forall x, x ∈ xs -> x ∈ support l -> False) ->
    pclosed_mapping l tag ->
    psubstitute (psubstitute t (combine xs ts) tag) l tag =
    psubstitute (psubstitute t l tag)
                (combine xs (List.map (fun t' => psubstitute t' l tag) ts)) tag.
Proof.
  induction t; repeat step || t_equality;
    eauto 4 using lookup_combine_some_none, List.map_length with exfalso;
    try solve [ eapply_anywhere lookup_combine_map; eauto ];
    try solve [ rewrite substitute_nothing5; eauto with fv ].

  repeat step || t_lookup || rewrite support_combine in * by auto;
    eauto with exfalso.
Qed.

Lemma pfv_in_subst2:
  forall T (l : list (nat * tree)) tag x,
    pclosed_mapping l tag ->
    x ∈ pfv (psubstitute T l tag) tag ->
    ~x ∈ support l.
Proof.
  intros.
  epose proof (fv_subst2 _ _ _ x H0);
    repeat step || list_utils;
    eauto using closed_mapping_fv.
Qed.