From Perennial.base_logic.lib Require Import mono_nat.
From Perennial.Helpers Require Import Transitions NamedProps Map gset range_set.
From Perennial.algebra Require Import auth_map log_heap.
From Perennial.base_logic Require Import lib.ghost_map.

From Perennial.program_proof Require Import disk_prelude.
From Goose.github_com.mit_pdos.go_journal Require Import obj.
From Goose.github_com.mit_pdos.go_journal Require Import wal.
From Perennial.program_proof Require Import wal.specs wal.lib wal.heapspec addr.addr_proof buf.buf_proof disk_lib.
From Perennial.program_proof Require Import obj.invariant.
From Perennial.goose_lang.lib Require Import slice.typed_slice.
From Perennial.goose_lang Require Import crash_modality.

From RecordUpdate Require Import RecordUpdate.
Import RecordSetNotations.
Section goose_lang.
Context `{!txnG Σ}.
Context `{!heapGS Σ}.

Implicit Types (γ: txn_names).

Definition txn_init_ghost_state γ : iProp Σ :=
  let logm0 := Build_async (∅: gmap addr object) [] in
  "logheap" ∷ ghost_map_auth γ.(txn_logheap) 1 (latest logm0) ∗
  "crashstates" ∷ ghost_var γ.(txn_crashstates) 1 logm0 ∗
  "metaheap" ∷ map_ctx γ.(txn_metaheap) 1 (∅ : gmap addr gname).

Lemma alloc_txn_init_ghost_state (γtxn_walnames: wal_heap_gnames) kinds :
  ⊢ |==> ∃ γ, ⌜γ.(txn_walnames) = γtxn_walnames⌝ ∗
              ⌜γ.(txn_kinds) = kinds⌝ ∗
              txn_init_ghost_state γ.
Proof.
  set (logm:=Build_async (∅: gmap addr object) []).
  iMod (ghost_map_alloc (latest logm)) as (txn_logheap) "[? _]".
  iMod (ghost_var_alloc logm) as (txn_crashstates) "?".
  iMod (map_init (∅ : gmap addr gname)) as (txn_metaheap) "?".
  iModIntro.
  iExists (Build_txn_names _ _ _ _ _).
  rewrite /txn_init_ghost_state /=.
  by iFrame.
Qed.

Definition is_txn_durable γ dinit : iProp Σ :=
  ∃ ls' logm crash_heaps,
  "%Hpostcrash" ∷ ⌜ wal_post_crash ls' ⌝ ∗
  "His_wal_inner_durable" ∷ is_wal_inner_durable γ.(txn_walnames).(wal_heap_walnames) ls' dinit ∗
  "Hwal_res" ∷ wal_resources γ.(txn_walnames).(wal_heap_walnames) ∗
  "Hwal_heap_inv" ∷ wal_heap_inv γ.(txn_walnames) ls' ∗
  "Hlocked_walheap" ∷ is_locked_walheap γ.(txn_walnames) {| locked_wh_σd := ls'.(log_state.d);
                        locked_wh_σtxns := ls'.(log_state.txns);
                    |} ∗
  "His_txn_always" ∷ is_txn_state γ logm crash_heaps.

Definition inode0_map : gmap u64 object :=
  gset_to_gmap (existT _ (bufInode inode_buf0))
               (list_to_set $ (λ i, U64 (i*8*128)%Z) <$> (seqZ 0 32)).

Definition bit0_map : gmap u64 object :=
  gset_to_gmap (existT _ (bufBit false))
               (list_to_set $ U64 <$> seqZ 0 (8*block_bytes)).

Definition block0_map : gmap u64 object :=
  {[U64 0 := existT _ (bufBlock block0)]}.

Definition kind_heap0 (kinds: gmap u64 bufDataKind) : gmap addr object :=
  gmap_uncurry ((λ K, match K with
                   | KindBit => bit0_map
                   | KindInode => inode0_map
                   | KindBlock => block0_map
                   end) <$> kinds).

Lemma repeat_to_replicate {A} (x:A) n :
  repeat x n = replicate n x.
Proof.
  induction n; simpl; congruence.
Qed.

Lemma crash_heap0_repeat_block0 (sz: nat) :
  513 + sz < 2^64 →
  crash_heap0 (repeat block0 sz) = gset_to_gmap block0 (rangeSet 513 (Z.of_nat sz)).
Proof.
  rewrite repeat_to_replicate.
  intros Hbound.
  rewrite /crash_heap0.
  apply map_eq; intros i.
  apply option_eq; intros b.
  rewrite lookup_gset_to_gmap.
  rewrite lookup_list_to_map.
  - rewrite elem_of_lookup_imap.
    setoid_rewrite lookup_replicate.
    destruct (decide (i ∈ rangeSet 513 sz));
    try (rewrite -> option_guard_True by done);
    try (rewrite -> option_guard_False by done).
    + apply rangeSet_lookup in e; [ | word .. ].
      split; [ naive_solver | ].
      inversion 1; subst.
      eexists (Z.to_nat (int.Z i - 513)), _.
      split_and!; eauto; try lia.
      f_equal; word.
    + rewrite -> rangeSet_lookup in n by word.
      split; [ | inversion 1 ]; intros.
      destruct H as (i' & b' & [=] & ? & ?); subst.
      move: n; word.
  - rewrite fst_imap.
    rewrite replicate_length.
    eapply NoDup_fmap_2_strong; last by eapply NoDup_seq.
    intros x y Hx Hy Heq.
    eapply elem_of_seq in Hx.
    eapply elem_of_seq in Hy.
    assert (int.Z (U64 (513 + Z.of_nat x)) = int.Z (U64 (513 + Z.of_nat y))).
    { rewrite Heq. eauto. }
    revert H. word.
Qed.

Lemma alloc_metamap names (m: gmap addr object):
  map_ctx names 1 ∅ ==∗
  ∃ metam,
  map_ctx names 1 metam ∗
  ([∗ map] addr↦bufData;γm ∈ m;metam, ghost_var γm (1/2) true) ∗
  ([∗ map] addr↦bufData;γm ∈ m;metam, ptsto_mut names addr 1 γm ∗ ghost_var γm (1/2) true).
Proof.
  iIntros "Hctx".
  iInduction m as [|i x m] "IH" using map_ind.
  - iExists ∅. rewrite ?big_sepM2_empty //. by iFrame.
  - iMod ("IH" with "Hctx") as (metam) "(H1&H2&H3)".
    iDestruct (big_sepM2_dom with "H2") as %Hdom.
    iMod (ghost_var_alloc true) as (γm) "[Hm1 Hm2]".
    assert (metam !! i = None).
    { apply not_elem_of_dom. rewrite -Hdom.
      apply not_elem_of_dom. eauto. }
    iMod (map_alloc i γm with "[$]") as "(Hctx&Hpts)"; auto.
    iExists (<[i := γm]>metam).
    iFrame. iSplitL "H2 Hm1".
    { rewrite big_sepM2_insert //. by iFrame. }
    { rewrite big_sepM2_insert //. by iFrame. }
Qed.

Theorem mapsto_txn_alloc {T} (γ : gname) (logm : gmap addr T) :
  map_ctx γ 1 ∅
  ==∗
  ∃ m,
    ⌜dom m = dom logm⌝ ∗
    map_ctx γ 1 m ∗
    ([∗ map] a↦_ ∈ logm, ∃ (γm : gname), a [[γ]]↦ γm ∗ ghost_var γm (1/2) true) ∗
    ([∗ map] _↦γm ∈ m, ghost_var γm (1/2) true).
Proof.
  iIntros "H".
  iInduction logm as [|a v m] "IH" using map_ind.
  { iModIntro. iExists _. iFrame. rewrite !big_sepM_empty. rewrite !dom_empty_L. done. }
  iMod ("IH" with "H") as (m0) "(%Hdom & H & H0 & H1)".
  assert (m0 !! a = None).
  { apply not_elem_of_dom in H. apply not_elem_of_dom. rewrite Hdom. eauto. }
  iMod (ghost_var_alloc true) as (γm) "[Hγ0 Hγ1]".
  iMod (map_alloc a γm with "H") as "[H Ha]"; eauto.
  iModIntro. iExists _. iFrame "H". iSplit.
  { iPureIntro. rewrite !dom_insert_L Hdom. done. }
  iSplitL "H0 Hγ0 Ha".
  { iApply big_sepM_insert; eauto. iFrame. iExists _. iFrame. }
  iApply big_sepM_insert; eauto. iFrame.
Qed.

Hint Rewrite repeat_length : len.

Lemma block_bytes_pos : 0 < Z.of_nat block_bytes.
Proof. rewrite /block_bytes. lia. Qed.

Lemma lookup_bit0_map (off: u64) o :
  bit0_map !! off = Some o ↔
  int.Z off < block_bytes * 8 ∧
  o = existT KindBit (bufBit false).
Proof.
  rewrite /bit0_map.
  rewrite lookup_gset_to_gmap_Some.
  rewrite elem_of_list_to_set.
  rewrite elem_of_list_fmap.
  setoid_rewrite elem_of_seqZ.
  change block_bytes with (Z.to_nat 4096).
  split; intros.
  - intuition (subst; auto).
    destruct H0 as [off' [? ?]]; subst.
    word.
  - intuition (subst; auto).
    exists (int.Z off); split; word.
Qed.

Lemma lookup_inode0_map (off: u64) o :
  inode0_map !! off = Some o ↔
  ∃ (i:Z), i < 32 ∧
           int.Z off = i * 8 * 128 ∧
           o = existT KindInode (bufInode inode_buf0).
Proof.
  rewrite /inode0_map.
  rewrite lookup_gset_to_gmap_Some.
  rewrite elem_of_list_to_set.
  rewrite elem_of_list_fmap.
  setoid_rewrite elem_of_seqZ.
  split.
  - intuition (subst; auto).
    destruct H0 as [y [? ?]]; subst.
    exists y; repeat split; try word.
  - intros.
    destruct H as [i (?&?&?)]; subst.
    split; auto.
    exists i; split; word.
Qed.

Lemma lookup_block0_map (off: u64) o :
  block0_map !! off = Some o ↔
  off = (U64 0) ∧
  o = existT KindBlock (bufBlock block0).
Proof.
  rewrite /block0_map.
  rewrite lookup_singleton_Some.
  intuition auto.
Qed.

Opaque block_bytes.

Lemma bit0_map_not_empty : ∅ ≠ bit0_map.
Proof.
  intro H.
  assert (bit0_map !! (U64 0) = None).
  { rewrite -H. apply lookup_empty. }
  assert (bit0_map !! (U64 0) = Some (existT KindBit (bufBit false))).
  { apply lookup_bit0_map.
    split; auto.
    pose proof block_bytes_pos.
    word. }
  rewrite H0 in H1.
  congruence.
Qed.

Lemma inode0_map_not_empty : ∅ ≠ inode0_map.
Proof.
  intro H. assert (inode0_map !! (U64 0) = None).
  { rewrite -H. apply lookup_empty. }
  apply lookup_gset_to_gmap_None in H0.
  apply H0.
  apply elem_of_list_to_set.
  apply elem_of_list_lookup.
  exists 0%nat; auto.
Qed.

Lemma block0_map_not_empty : ∅ ≠ block0_map.
Proof.
  intro H. assert (block0_map !! (U64 0) = None).
  { rewrite -H. apply lookup_empty. }
  rewrite lookup_singleton in H0. congruence.
Qed.

Hint Resolve bit0_map_not_empty : notempty.
Hint Resolve inode0_map_not_empty : notempty.
Hint Resolve block0_map_not_empty : notempty.

Lemma repeat_lookup_inv {T} (a b : T) : ∀ n i, repeat a n !! i = Some b -> a = b.
Proof.
  induction n; simpl; intros.
  { rewrite lookup_nil in H. congruence. }
  destruct i; eauto.
  inversion H; eauto.
Qed.

Lemma block0_to_vals : Block_to_vals block0 = replicate block_bytes (#(U8 0)).
Proof. reflexivity. Qed.

Ltac Zify.zify_post_hook ::= Z.div_mod_to_equations.

Lemma extract_inode0 (off: u64) :
  (* off is actually less than 8*8*128 *)
  int.Z off `mod` 1024 = 0 →
  int.Z off < 8*4096 → (* TODO: not sure what bound is *)
  extract_nth block0 inode_bytes (int.nat off `div` (inode_bytes * 8)) =
  inode_to_vals inode_buf0.
Proof.
  intros.
  rewrite /extract_nth.
  rewrite block0_to_vals.
  rewrite take_replicate drop_replicate.
  rewrite /inode_buf0.
  rewrite /inode_to_vals.
  rewrite vec_to_list_replicate.
  rewrite fmap_replicate.
  f_equal.
  rewrite /inode_bytes block_bytes_eq.
  rewrite Nat.min_l; try word.
  change (Z.to_nat 128 * 8)%nat with 1024%nat.
  change (Z.to_nat 4096) with 4096%nat.
  change (Z.to_nat 128) with 128%nat.
  assert (int.nat off < 8 * 4096)%nat by lia.
  cut (int.nat off `div` 1024 < 32)%nat; try lia.
  change (8*4096)%nat with (Z.to_nat 32768) in H1.
  apply Nat2Z.inj_lt.
  rewrite Nat2Z.inj_div.
  lia.
Qed.

Lemma bufDataT_in_block0_bit off o (n: u64) :
  bit0_map !! off = Some o ->
  int.Z n * block_bytes * 8 < 2 ^ 64 ->
  bufDataT_in_block block0 KindBit n off o.
Proof.
  intros H H0.
  eapply lookup_gset_to_gmap_Some in H. intuition subst.
  assert (valid_off KindBit off).
  { apply valid_off_bit_trivial; eauto. }
  rewrite /bufDataT_in_block /=.
  apply elem_of_list_to_set in H1.
  apply elem_of_list_lookup in H1 as [i ?].
  fmap_Some in H1.
  apply lookup_seqZ in H1 as [-> ?].
  intuition eauto.
  + rewrite /is_bufData_at_off. intuition eauto.
    exists (U8 0).
    rewrite !Z.add_0_l.
    split.
    * rewrite /extract_nth block0_to_vals.
      rewrite take_replicate drop_replicate.
      match goal with
      | |- context[replicate ?n _] => replace n with 1%nat; [ reflexivity | ]
      end.
      rewrite block_bytes_eq in H1 |- *.
      rewrite !Nat.mul_1_r.
      rewrite Nat.min_l; [ lia | ].
      replace (int.nat i) with i by word.
      apply Z.div_lt_upper_bound in H1; [ | lia ].
      rewrite -> Z2Nat.id in H1 by lia.
      replace (Nat.div i 8) with (Z.to_nat $ Z.div (Z.of_nat i) 8); try lia.
      rewrite Z2Nat.inj_div; try lia.
      change (Z.to_nat 8) with 8%nat.
      rewrite Nat2Z.id.
      lia.
    * rewrite /get_bit.
      rewrite decide_False //.
      intros Heq%(f_equal int.Z); move: Heq.
      rewrite word.unsigned_and_nowrap.
      rewrite word.unsigned_sru_nowrap.
      { change (int.Z (U8 0)) with 0; simpl.
        rewrite Z.shiftr_0_l //. }
      rewrite /u8_from_u64.
      rewrite word.unsigned_of_Z word.unsigned_modu_nowrap //.
      change (int.Z 8) with 8.
      rewrite block_bytes_eq in H1.
      replace (int.Z i) with (Z.of_nat i) by word.
      rewrite /word.wrap.
      assert (0 ≤ i `mod` 8 < 8) by (apply Z.mod_bound_pos; lia).
      rewrite Z.mod_small; lia.
  + rewrite /valid_addr /addr2flat_z /=.
    rewrite -> block_bytes_eq in *.
    split_and!; try word.
Qed.

Lemma bufDataT_in_block0_inode off o (n: u64) :
  inode0_map !! off = Some o ->
  int.Z n * block_bytes * 8 < 2 ^ 64 ->
  bufDataT_in_block block0 KindInode n off o.
Proof.
  intros.
  eapply lookup_gset_to_gmap_Some in H. intuition subst.
  apply elem_of_list_to_set in H1.
  apply elem_of_list_lookup in H1 as [i Hlookup].
  fmap_Some in Hlookup.
  apply lookup_seqZ in Hlookup as [-> ?].
  rewrite Z.add_0_l.
  set (off:=i * 8* 128).
  rewrite /bufDataT_in_block; simpl.
  rewrite /is_bufData_at_off.
  feed pose proof (extract_inode0 off) as Hextract; [ word .. | ].
  rewrite /valid_addr /valid_off /addr2flat_z /=.
  assert (valid_off KindInode off).
  { rewrite /valid_off /=.
    word. }
  split_and!; auto.
  { rewrite block_bytes_eq. word. }
  - lia.
  - rewrite /valid_off /= in H.
    rewrite block_bytes_eq in H0 |- *.
    word.
Qed.

Ltac Zify.zify_post_hook ::= idtac.

Lemma bufDataT_in_block0_block off o (n: u64) :
  block0_map !! off = Some o ->
  int.Z n * block_bytes * 8 < 2 ^ 64 ->
  bufDataT_in_block block0 KindBlock n off o.
Proof.
  rewrite /block0_map => H H0.
  eapply lookup_singleton_Some in H. intuition subst.
  assert (valid_off KindBlock (U64 0)).
  { rewrite /valid_off.
    replace (int.Z (U64 0)) with 0 by reflexivity.
    rewrite Zmod_0_l. done. }
  rewrite /bufDataT_in_block /=. intuition eauto.
  + rewrite /is_bufData_at_off. intuition eauto.
  + rewrite /valid_addr /addr2flat_z /=.
    intuition try word.
    pose proof (block_bytes_pos). word.
Qed.

Lemma bufDataT_in_block0 kind off o n :
  match kind with
  | KindBit => bit0_map
  | KindInode => inode0_map
  | KindBlock => block0_map
  end !! off = Some o ->
  int.Z n * block_bytes * 8 < 2 ^ 64 ->
  bufDataT_in_block block0 kind n off o.
Proof.
  intros. destruct kind;
          auto using bufDataT_in_block0_bit,
          bufDataT_in_block0_block,
          bufDataT_in_block0_inode.
Qed.

(* sz is the number of blocks besides the log (so the size of the disk - 513) *)
Lemma is_txn_durable_init dinit (kinds: gmap u64 bufDataKind) (sz: nat) :
  dom dinit = list_to_set (seqZ 513 sz) →
  dom kinds = list_to_set (U64 <$> (seqZ 513 sz)) →
  (513 + Z.of_nat sz) * block_bytes * 8 < 2^64 →
  0 d↦∗ repeat block0 513 ∗ 513 d↦∗ repeat block0 sz -∗
 |==> ∃ γ,
         "%Hγkinds" ∷ ⌜ γ.(invariant.txn_kinds) = kinds ⌝ ∗
         "Htxn_durable" ∷ is_txn_durable γ dinit ∗
         "#Hdurable_lb" ∷ mono_nat_lb_own γ.(txn_walnames).(wal_heap_durable_lb) 0 ∗
         "Hcrashstates" ∷ ghost_var γ.(txn_crashstates) (3/4) (Build_async (kind_heap0 kinds) []) ∗
         "Hmapsto_txns" ∷ ([∗ map] a ↦ o ∈ kind_heap0 kinds, mapsto_txn γ a o).
Proof.
  iIntros (Hdinit_dom Hkinds_dom Hbound) "H".
  iMod (is_wal_inner_durable_init dinit with "H") as (γwalnames) "[Hwal Hwal_res]".
  { len; auto. }

  set (bs:=repeat block0 sz).

  assert (513 + Z.of_nat sz < 2^64) as Hbound2.
  { pose proof (block_bytes_pos). lia. }

  iMod (wal_heap_inv_init γwalnames bs) as (γheapnames Heq1) "Hheap".
  { rewrite /bs; len. }
  iNamed "Hheap".

  iMod (alloc_txn_init_ghost_state γheapnames kinds) as (γ Heq2 Heq3)  "Hinit".
  iNamed "Hinit".
  iMod (ghost_map_insert_big (kind_heap0 kinds) with "logheap") as "[logheap logheap_mapsto_curs]".
  { simpl. apply map_disjoint_empty_r. }
  iMod (ghost_var_update (Build_async (kind_heap0 kinds) [])
          with "crashstates") as "H".
  iEval (rewrite -Qp.quarter_three_quarter) in "H".
  iDestruct (fractional.fractional_split with "H") as "[crashstates1 crashstates2]".

  iMod (alloc_metamap _ (kind_heap0 kinds) with "metaheap") as (metamap) "(metaheap & Hmetas1 & Hmetas2)".

  iModIntro. iExists γ.
  rewrite Heq2.
  iFrame "Hheap_lb crashstates2".
  rewrite /is_txn_durable.
  iSplit.
  { eauto. }
  iSplitR "Hmetas2 logheap_mapsto_curs".
  2: {
    iDestruct (big_sepM2_sepM_1 with "Hmetas2") as "Hmetas2".
    iDestruct (big_sepM_sep with "[$Hmetas2 $logheap_mapsto_curs]") as "H".
    iApply (big_sepM_mono with "H").
    iIntros (k x Hkx) "[H0 H1]".
    iDestruct "H0" as (γm) "(% & Ha & Hb)".
    iExists _. iFrame.
  }
  iExists (log_state0 bs), (Build_async (kind_heap0 kinds) []).
  iExists (Build_async (crash_heap0 bs) []).

  iSplit.
  { iPureIntro.
    auto using log_state0_post_crash. }
  rewrite Heq2 Heq1.
  iFrame "Hwal Hwal_res Hheap_inv wal_heap_locked".
  rewrite /is_txn_state.
  iExists metamap.
  rewrite Heq2.
  simpl. rewrite right_id.
  iFrame "wal_heap_crash_heaps logheap crashstates1 metaheap".

  iSplitL "Hmetas1 wal_heap_h_mapsto".
  - iDestruct (gmap_addr_by_block_big_sepM2 with "Hmetas1") as "Hmetas".
    iDestruct (big_sepM2_dom with "Hmetas") as "%Hmetadom".
    iApply big_sepM_sepM2_merge_ex; eauto.
    iDestruct (big_sepM2_sepM_1 with "Hmetas") as "Hmetas".

    rewrite /kind_heap0 /gmap_addr_by_block.
    rewrite gmap_curry_uncurry_non_empty; last first.
    {
      intros i x Hix. rewrite lookup_fmap in Hix.
      apply fmap_Some_1 in Hix. destruct Hix. intuition idtac.
      destruct x0; subst.
      { eapply bit0_map_not_empty. eassumption. }
      { eapply inode0_map_not_empty. eassumption. }
      { eapply block0_map_not_empty. eassumption. }
    }

    iDestruct (big_sepM_sepM2_merge with "[$wal_heap_h_mapsto $Hmetas]") as "H".
    { rewrite /gh_heapblock0.
      rewrite dom_fmap_L Hkinds_dom.
      rewrite dom_list_to_map_L. f_equal.
      rewrite fst_imap. subst bs. rewrite repeat_length. rewrite /seqZ.
      replace (Z.to_nat (Z.of_nat sz)) with sz by lia.
      rewrite list_fmap_compose. f_equal.
      eapply list_fmap_ext; eauto. lia.
    }

    iDestruct (big_sepM.big_sepM2_sepM_2 with "H") as "H".
    iApply (big_sepM_mono with "H").
    intros.
    iIntros "Hm".
    iDestruct "Hm" as (hb) "(%Hhb & Hmapsto & H)". destruct hb.
    iDestruct "H" as (mm) "(%Hmm & Hmm)".
    iExists _. iSplit; first by eauto.
    rewrite lookup_fmap in H.
    destruct (kinds !! k) eqn:Hk; simpl in H; inversion H; clear H. subst.
    iExists _, _, _. iSplit; first by (subst; eauto).
    iFrame. iApply (big_sepM2_mono with "Hmm").
    intros. iIntros "H".
    iExists _. iFrame. iPureIntro.
    apply lookup_list_to_map_1 in Hhb.
    apply elem_of_lookup_imap_1 in Hhb. destruct Hhb as [hb_i [hb_b [Hhb0 Hhb1]]].
    inversion Hhb0; clear Hhb0; subst. simpl.
    apply repeat_lookup_inv in Hhb1; subst.

    eapply bufDataT_in_block0; eauto.
    assert (is_Some (γ.(txn_kinds) !! U64 (513 + Z.of_nat hb_i))) as Hs; eauto.
    eapply elem_of_dom in Hs. rewrite Hkinds_dom in Hs.
    eapply elem_of_list_to_set in Hs.
    eapply elem_of_list_fmap_2 in Hs. destruct Hs as [y [Hs0 Hs1]]. rewrite Hs0.
    eapply elem_of_seqZ in Hs1. intuition subst.
    replace (int.Z (U64 y)) with y by word.
    rewrite -Z.mul_assoc. rewrite -Z.mul_assoc in Hbound.
    eapply Z.le_lt_trans; last by apply Hbound.
    pose proof (block_bytes_pos).
    eapply Zmult_gt_0_le_compat_r; try lia.

  - rewrite right_id /named.
    rewrite /bufDataTs_in_crashblock.

    rewrite /kind_heap0 /gmap_addr_by_block.
    rewrite gmap_curry_uncurry_non_empty; last first.
    {
      intros i x Hix. rewrite lookup_fmap in Hix.
      apply fmap_Some_1 in Hix. destruct Hix. intuition idtac.
      destruct x0; subst.
      { eapply bit0_map_not_empty. eassumption. }
      { eapply inode0_map_not_empty. eassumption. }
      { eapply block0_map_not_empty. eassumption. }
    }

    iApply big_sepM_sepM2_merge_ex.
    {
      rewrite /crash_heap0.
      rewrite dom_fmap_L Hkinds_dom.
      rewrite dom_list_to_map_L. f_equal.
      rewrite fst_imap. subst bs. rewrite repeat_length. rewrite /seqZ.
      replace (Z.to_nat (Z.of_nat sz)) with sz by lia.
      rewrite -list_fmap_compose.
      eapply list_fmap_ext; eauto.
      intros. rewrite /compose. f_equal. lia.
    }

    rewrite big_sepM_forall. iPureIntro. intros x m Hxm.
    rewrite lookup_fmap in Hxm.
    destruct (kinds !! x) eqn:He; inversion Hxm; clear Hxm; subst.
    exists block0. split.
    {
      rewrite crash_heap0_repeat_block0; last by lia.
      eapply lookup_gset_to_gmap_Some; intuition eauto.
      eapply rangeSet_lookup; try lia.
      assert (is_Some (γ.(txn_kinds) !! x)) as Hs; eauto.
      eapply elem_of_dom in Hs. rewrite Hkinds_dom in Hs.
      eapply elem_of_list_to_set in Hs.
      eapply elem_of_list_fmap_2 in Hs. destruct Hs as [y [Hs0 Hs1]].
      eapply elem_of_seqZ in Hs1. intuition subst; word.
    }

    eexists _. intuition eauto.
    eapply map_Forall_lookup_2. intros.

    eapply bufDataT_in_block0; eauto.
    assert (is_Some (γ.(txn_kinds) !! x)) as Hs; eauto.
    eapply elem_of_dom in Hs. rewrite Hkinds_dom in Hs.
    eapply elem_of_list_to_set in Hs.
    eapply elem_of_list_fmap_2 in Hs. destruct Hs as [y [Hs0 Hs1]].
    eapply elem_of_seqZ in Hs1. intuition subst.
    replace (int.Z (U64 y)) with y by word.
    rewrite -Z.mul_assoc. rewrite -Z.mul_assoc in Hbound.
    etransitivity; last by apply Hbound.
    pose proof (block_bytes_pos).
    eapply Zmult_gt_0_lt_compat_r; lia.
Qed.

Definition crash_heap_match γ logmap walheap : iProp Σ :=
  ([∗ map] blkno ↦ offmap;walblock ∈ gmap_addr_by_block logmap;walheap,
        ∃ blockK,
       "%Htxn_cb_kind" ∷ ⌜ γ.(txn_kinds) !! blkno = Some blockK ⌝ ∗
       "Htxn_in_cb" ∷ bufDataTs_in_crashblock walblock blkno blockK offmap)%I.

Definition crash_heaps_match γ logm crash_heaps : iProp Σ :=
  ([∗ list] logmap;walheap ∈ possible logm;possible crash_heaps, crash_heap_match γ logmap walheap).

Lemma crash_heaps_match_async_take γ logm crash_heaps n :
  (0 < n)%nat →
  (n ≤ length (possible logm))%nat →
  crash_heaps_match γ logm crash_heaps -∗
  crash_heaps_match γ (async_take n logm) (async_take n crash_heaps).
Proof.
  rewrite /crash_heaps_match.
  iIntros (Hlt Hle) "Hl".
  iDestruct (big_sepL2_length with "Hl") as %Hlen.
  iApply (big_sepL2_prefix with "Hl"); auto.
  - apply async_take_possible_prefix; auto.
  - apply async_take_possible_prefix; auto. lia.
  - rewrite ?possible_list_to_async ?take_length; lia.
Qed.

Lemma crash_heaps_match_transfer_gname γ1 γ2 logm crash_heaps :
  txn_kinds γ2 = txn_kinds γ1 →
  crash_heaps_match γ1 logm crash_heaps -∗
  crash_heaps_match γ2 logm crash_heaps.
Proof. iIntros (Heq) "H". rewrite /crash_heaps_match/crash_heap_match Heq. eauto. Qed.

Lemma crash_heaps_match_heapmatch_latest γ logm crash_heaps :
    "Hmetactx" ∷ map_ctx γ.(txn_metaheap) 1 ∅ ∗
    "Hcrash_heaps0" ∷ ([∗ map] a↦b ∈ latest crash_heaps, ∃ hb,
     ⌜hb_latest_update hb = b⌝ ∗
     a ↪[γ.(txn_walnames).(wal_heap_h)] hb) ∗
    "Hcrashheapsmatch" ∷ crash_heaps_match γ logm crash_heaps ==∗
    ∃ metam,
    map_ctx γ.(txn_metaheap) 1 metam ∗
    "Hheapmatch" ∷ ( [∗ map] blkno ↦ offmap;metamap ∈ gmap_addr_by_block (latest logm);gmap_addr_by_block metam,
      ∃ installed bs blockK,
        "%Htxn_hb_kind" ∷ ⌜ γ.(txn_kinds) !! blkno = Some blockK ⌝ ∗
        "Htxn_hb" ∷ blkno ↪[γ.(txn_walnames).(wal_heap_h)] (HB installed bs) ∗
        "Htxn_in_hb" ∷ bufDataTs_in_block installed bs blkno blockK offmap metamap ) ∗
    "Hmapsto_txns" ∷ ([∗ map] addr↦bufData ∈ latest logm, ∃ γm, ptsto_mut γ.(txn_metaheap) addr 1 γm ∗ ghost_var γm (1/2) true).
Proof.
  iNamed 1.
  iMod (mapsto_txn_alloc _ logm.(latest) with "Hmetactx") as (metam) "(%Hdom & Hmetactx' & H0 & H1)".

  rewrite /crash_heaps_match /possible.
  rewrite big_sepL2_snoc.
  iDestruct "Hcrashheapsmatch" as "[_ Hlatestmatch]".
  rewrite /crash_heap_match.

  iModIntro. iExists _. iFrame "Hmetactx'".
  iFrame "H0".

  iDestruct (big_sepM2_flip with "Hlatestmatch") as "Hlatestmatch".
  iDestruct (big_sepM2_sepM_merge with "[$Hlatestmatch $Hcrash_heaps0]") as "Hlatestmatch".
  iDestruct (big_sepM2_flip with "Hlatestmatch") as "Hlatestmatch".

  iDestruct (big_sepM2_sepM_1 with "Hlatestmatch") as "Hlatestmatch".
  iDestruct (gmap_addr_by_block_big_sepM with "H1") as "H1".
  iDestruct (big_sepM_sepM2_merge with "[$Hlatestmatch $H1]") as "H".
  { eapply gmap_addr_by_block_dom_eq; eauto. }

  iApply (big_sepM2_mono with "H").
  iIntros (k y1 y2 Hky1 Hky2) "[H0 H1]".
  iDestruct "H0" as (y0) "(%Hcl & H0 & H2)".
  iDestruct "H0" as (block) "[%Hk H0]". iNamed "H0".
  iDestruct "H2" as (hb) "[%Hb Hmapsto]".
  destruct hb.
  iExists _, _, _. iFrame. iFrame "%".

  rewrite /bufDataTs_in_block /bufDataTs_in_crashblock.
  iDestruct (big_sepM_sepM2_merge with "[$Htxn_in_cb $H1]") as "H1".
  { eapply gmap_addr_by_block_dom_eq2; eauto. }

  iApply (big_sepM2_mono with "H1").
  iIntros (k0 y3 y4 Hky3 Hky4) "[%Hblk H]".
  iExists _. iFrame. iPureIntro.
  rewrite -Hb in Hblk. eauto.
Qed.

Global Instance is_txn_always_discretizable γ :
  Discretizable (is_txn_always γ).
Proof. apply _. Qed.

Global Instance is_txn_durable_discretizable γ dinit :
  Discretizable (is_txn_durable γ dinit).
Proof. apply _. Qed.

Lemma log_crash_txns_length ls1 ls2 :
  relation.denote log_crash ls1 ls2 () →
  (length ls2.(log_state.txns) ≤ length ls1.(log_state.txns))%nat.
Proof.
  rewrite log_crash_unfold. intros (?&?&?).
  subst. rewrite /=.
  rewrite -{2}(take_drop (S x) (ls1.(log_state.txns))).
  rewrite app_length. lia.
Qed.

Lemma wal_heap_inv_wf names ls:
  wal_heap_inv names ls -∗
  ⌜ wal_wf ls ⌝.
Proof. iNamed 1. eauto. Qed.

Lemma latest_wal_heap_h_mapsto_split (γ: gname) gh :
  ([∗ map] a ↦ b ∈ gh, ∃ hb, ⌜hb_latest_update hb = b⌝ ∗ a ↪[γ] hb) ⊣⊢
  ([∗ map] a ↦ b ∈ gh, ∃ hb, ⌜hb_latest_update hb = b⌝ ∗ a ↪[γ]{#1/2} hb) ∗
  ([∗ map] a ↦ b ∈ gh, ∃ hb, ⌜hb_latest_update hb = b⌝ ∗ a ↪[γ]{#1/2} hb).
Proof.
  rewrite -big_sepM_sep.
  repeat f_equiv.
  iSplit.
  - iDestruct 1 as (hb <-) "[H1 H2]".
    iSplitL "H1"; eauto with iFrame.
  - iDestruct 1 as "[H1 H2]".
    iDestruct "H1" as (hb <-) "H1".
    iDestruct "H2" as (hb' <-) "H2".
    iDestruct (ghost_map_elem_agree with "H1 H2") as %<-.
    iCombine "H1 H2" as "H".
    eauto.
Qed.

(*
Definition txn_pre_exchange γ γ' : iProp Σ :=
 (∃ σs : async (gmap addr object), "H◯async" ∷ ghost_var γ'.(txn_crashstates) (3/4) σs ∗
              heapspec_durable_exchanger γ.(txn_walnames) (length (possible σs) - 1)).

Definition txn_post_exchange γ γ' : iProp Σ :=
 (∃ σs : async (gmap addr object), "H◯async" ∷ ghost_var γ.(txn_crashstates) (3/4) σs).

Definition txn_exchanger (γ γ' : @txn_names Σ) : iProp Σ :=
  ∃ ls ls', heapspec_exchanger ls ls' γ.(txn_walnames) γ'.(txn_walnames) ∗
  (txn_pre_exchange γ γ' ∨ txn_post_exchange γ γ').
*)

Definition txn_resources γ γ' logm : iProp Σ :=
  (∃ logm0 (txn_id : nat),
  "%Hasync_pre" ∷ ⌜ async_prefix logm logm0 ⌝ ∗
  "%Hlen_crash_txn" ∷ ⌜ (length (possible logm) = txn_id + 1)%nat ⌝ ∗
  "%Hlen_compare" ∷ ⌜ (length (possible logm) ≤ length (possible logm0))%nat ⌝ ∗
  "Hlogm" ∷ ghost_var γ'.(txn_crashstates) (3/4) logm ∗
  "Holdlogm" ∷ ghost_var γ.(txn_crashstates) (1/4) logm0 ∗
  "Hmapsto_txns" ∷ ([∗ map] a ↦ v ∈ latest (logm), mapsto_txn γ' a v) ∗
  "Hdurable" ∷ mono_nat_lb_own γ'.(txn_walnames).(heapspec.wal_heap_durable_lb) txn_id ∗
  "Hdurable_exchanger" ∷ heapspec_durable_exchanger γ.(txn_walnames) txn_id)%I.

Lemma txn_crash_transform dinit (γ γ': txn_names) γ'_walnames logm1 crash_heaps
 (* (Hwalnames_eq : γ'.(txn_walnames) = γ'_txn_walnames) *)
  (Hkinds_eq : γ'.(txn_kinds) = γ.(txn_kinds)) :
  ("His_txn_always" ∷ is_txn_state γ logm1 crash_heaps ∗
  "Htxn_init" ∷ txn_init_ghost_state γ' ∗
  "Hcrash" ∷ ∃ (σ0 σ' : log_state.t),
             ⌜relation.denote log_crash σ0 σ' tt⌝ ∗
             is_wal_inner_durable γ'_walnames σ' dinit ∗ wal_resources γ'_walnames ∗
             ▷ (wal_heap_inv γ'.(txn_walnames) σ' ∗
                heapspec_resources γ.(txn_walnames) γ'.(txn_walnames) σ0 σ')) -∗
  (|={∅}=> ∃ (logm' : async (gmap addr object)),
          let γ' := (γ'<|txn_walnames;wal_heap_walnames := γ'_walnames|>) in
         ⌜γ'.(txn_kinds) = γ.(txn_kinds)⌝ ∗ is_txn_durable γ' dinit ∗ txn_resources γ γ' logm').
Proof.
  iNamed 1.
  iDestruct "Hcrash" as (ls1) "HP".
  iDestruct "HP" as (ls2 Hcrashls12) "(Hdur' & Hres' & HP)".
  iNamed "His_txn_always".
  rewrite /txn_resources.

  rewrite /Prec. iDestruct "HP" as "(>Hheap_inv&Hheap_res)".
  rewrite /is_txn_durable.

  rewrite /heapspec_resources.
  iDestruct "Hheap_res" as "(>Hheap_exchanger&>Hlocked_walheap)".
  iDestruct (heapspec_exchange_crash_heaps with "[$] [$]") as "(Hheap_exchange&Hnew)".
  iDestruct "Hnew" as "(Hheap_lb_exchange&Hcrash_heaps0)".
  iNamed "Hcrash_heaps0".

  iDestruct (wal_heap_inv_wf with "Hheap_inv") as %Hls2wf.
  iNamed "Htxn_init".
  iDestruct (big_sepL2_length with "Hcrashheapsmatch") as %Hlen_logm.
  assert (length ls2.(log_state.txns) ≤ length (possible logm1))%nat.
  { rewrite Hlen_logm -Hlenold //=.
    apply log_crash_txns_length. auto. }
  assert (0 < length ls2.(log_state.txns))%nat.
  { destruct Hls2wf. lia. }

  iMod (ghost_var_update (async_take (length ls2.(log_state.txns)) logm1) with "crashstates")
       as "crashstates".
  iDestruct (crash_heaps_match_async_take γ _ _ (length ls2.(log_state.txns)) with "Hcrashheapsmatch")
       as "#Hcrashheapsmatch'"; auto.
  iDestruct (crash_heaps_match_transfer_gname _ γ' with "Hcrashheapsmatch'") as "#Hcrashheapsmatch_new".
  { auto. }

  iMod (ghost_map_insert_big (async_take (length ls2.(log_state.txns)) logm1).(latest) with "logheap")
    as "[logheap Hlatest]".
  { apply map_disjoint_empty_r. }

  iMod (crash_heaps_match_heapmatch_latest γ' with "[$Hcrashheapsmatch_new $metaheap $Hcrash_heaps0]") as
     (metam_new) "(metaheap&Heapmatch_new&Hpts)".

  iExists (async_take (length ls2.(log_state.txns)) logm1).
  iSplitL ""; first eauto.

  iEval (rewrite -Qp.quarter_three_quarter) in "crashstates".
  iDestruct (fractional.fractional_split_1 with "crashstates") as
      "[crashstates1 crashstates2]".
  iDestruct (heapspec_durable_exchanger_dup with "[$]")
            as "(Hheap_lb_exchange1&Hheap_lb_exchange2)".
  iSplitR "Hcrashstates crashstates2 Hheap_lb_exchange2 Hheap_exchange Hpts Hlatest"; last first.
  { iModIntro. iExists _, ((length ls2.(log_state.txns)) - 1)%nat. iFrame.
    iSplitL "".
    {
      iPureIntro. apply async_take_async_prefix; lia.
    }
    iSplitL "".
    { iPureIntro. rewrite /async_take.
      rewrite possible_list_to_async; last first.
      { rewrite take_length. lia. }
      { rewrite take_length. lia. }
    }
    iSplitL "".
    { iPureIntro. rewrite /async_take.
      rewrite possible_list_to_async; last first.
      { rewrite take_length. lia. }
      { rewrite take_length. lia. }
    }
    iCombine "Hpts Hlatest" as "Hpts".
    rewrite -big_sepM_sep.
    iSplitL "Hpts".
    {
      iApply (big_sepM_mono with "Hpts").
      iIntros (???) "(H1&H2)".
      iDestruct "H1" as (γm) "(H1a&H1b)".
      iExists γm. iFrame.
    }
    iNamed "Hheap_exchange". simpl.
    rewrite (wal_post_crash_durable_lb_length_txns ls2); first iFrame "#".
    eapply log_crash_to_post_crash; eauto.
  }
  iExists ls2, _, _. simpl. iFrame "Hheap_inv Hres' Hdur'".

  iFrame "Hcrash_heaps".
  iSplitL "".
  { iModIntro. iPureIntro. eapply log_crash_to_post_crash; eauto. }
  iFrame.
  iExists metam_new.
  iFrame "# ∗".
  simpl. iEval (rewrite right_id) in "logheap". iFrame "logheap".
  eauto.
Qed.

  Definition txn_cfupd_cancel E dinit γ' : iProp Σ :=
    (<bdisc> (|C={E}=> ▷ is_txn_durable γ' dinit)).

Definition txn_cfupd_res E γ γ' : iProp Σ :=
  ⌜γ'.(txn_kinds) = γ.(txn_kinds)⌝ ∗
  (<bdisc> (|C={E}=> ▷ ∃ logm, txn_resources γ γ' logm)).

Theorem wpc_MkLog E d dinit (γ:txn_names) :
  ↑walN ⊆ E →
  ↑invN ⊆ E →
  {{{ is_txn_durable γ dinit }}}
    obj.MkLog (disk_val d) @ ⊤
  {{{ γ' (l: loc), RET #l;
      is_txn l γ dinit ∗
      txn_cfupd_cancel E dinit γ' ∗
      txn_cfupd_res E γ γ' }}}
  {{{ ∃ γ' logm', ⌜ txn_kinds γ' = txn_kinds γ ⌝ ∗ is_txn_durable γ' dinit
      ∗ (⌜ γ' = γ ⌝ ∨ txn_resources γ γ' logm') }}}.
Proof.
  iIntros (?? Φ Φc) "Hdur HΦ".
  rewrite /obj.MkLog. wpc_pures.
  { crash_case. iExists _, _. iFrame. eauto. }

  iCache with "Hdur HΦ".
  { crash_case. iExists _, _. iFrame. eauto. }
  wpc_bind (lock.new _).
  wpc_frame; wp_apply (wp_new_free_lock).
  iIntros (lk) "Hlock". iNamed 1.
  wpc_bind (wal.MkLog _).
  iNamed "Hdur".
  iMod (alloc_heapspec_init_ghost_state (γ.(txn_walnames).(wal_heap_walnames)))
         as (γ'_txn_walnames ?) "Hheapspec_init".
  iMod (alloc_txn_init_ghost_state γ'_txn_walnames γ.(txn_kinds)) as
      (γ' Hwalnames_eq Hkinds_eq) "Htxn_init".
  set (P := λ ls, (wal_heap_inv γ.(txn_walnames) ls ∗ heapspec_init_ghost_state γ'_txn_walnames)%I).
  set (Prec (ls ls': log_state.t) :=
         (wal_heap_inv γ'.(txn_walnames) ls' ∗
          heapspec_resources γ.(txn_walnames) γ'.(txn_walnames) ls ls')%I).
  set (Pcrash (ls ls' : log_state.t) := (True)%I : iProp Σ).
  iApply wpc_cfupd.
  wpc_apply (wpc_MkLog_recover dinit P (↑walN) _ _ _ Prec Pcrash
            with "[] [$His_wal_inner_durable Hwal_res Hwal_heap_inv Hheapspec_init]").
  - auto.
  - auto.
  - iIntros "!>" (???) ">HP".
    iDestruct "HP" as "[Hinv Hinit]".
    iMod (wal_heap_inv_crash_transform with "Hinv Hinit") as "[Hinv Hres]"; eauto.
    rewrite /Prec /Pcrash.
    rewrite Hwalnames_eq.
    iModIntro.
    by iFrame.
  - iFrame.
  - iSplit.
    { iLeft in "HΦ".
      iIntros "Hcrash HC".
      iDestruct "Hcrash" as (γ'wal_names) "Hcrash".
      iPoseProof (txn_crash_transform with "[$]") as "Htransform".
      { auto. }
      iMod (fupd_mask_mono with "Htransform") as "Htransform"; auto.
      iModIntro. iApply "HΦ".
      iDestruct "Htransform" as (?) "(?&?&?)".
      iExists _, _. iFrame.
    }
    iNext. iIntros (γ'' l) "(#Hwal & Hwal_cfupd & #Hwal_cinv)".
    iApply wpc_fupd.
    iApply wpc_cfupd.
    wpc_frame_compl "Hlock Hlocked_walheap".
    {
      iLeft in "HΦ".
      iIntros "HC".
      rewrite /wal_cfupd_cancel.
      rewrite own_discrete_elim.
      iSpecialize ("Hwal_cfupd" with "[$]").
      iMod (fupd_mask_mono with "Hwal_cfupd") as "Hwal_cfupd"; auto.
      iPoseProof (txn_crash_transform with "[$His_txn_always $Htxn_init Hwal_cfupd]") as "Htransform".
      { auto. }
      { iDestruct "Hwal_cfupd" as (??) "H".
        iExists _, _. iFrame.
      }
      iMod (fupd_mask_mono with "Htransform") as "Htransform"; auto.
      iModIntro. iApply "HΦ".
      iDestruct "Htransform" as (?) "(?&?&?)".
      iExists _, _. iFrame.
    }
    rewrite -wp_fupd.
    wp_apply wp_allocStruct; first by val_ty.
    iIntros (txn_l) "Htxn".
    iApply struct_fields_split in "Htxn". iNamed "Htxn".
    wp_pures.
    iMod (readonly_alloc_1 with "mu") as "#mu".
    iMod (readonly_alloc_1 with "log") as "#log".
    iMod (alloc_lock lockN _ _ (is_txn_locked txn_l γ.(txn_walnames))
            with "Hlock [pos Hlocked_walheap]") as "#Htxn_lock".
    { iNext. rewrite /is_txn_locked.
      iExists _, _, _; iFrame. }
    iModIntro.
    iNamed 1.
    rewrite /wal_cfupd_cancel.
    iDestruct (own_discrete_laterable with "Hwal_cfupd") as (Pwal_tok) "(HPwal_tok&#HPwal_tok_wand)".
    iMod (ncinv_cinv_alloc' invN _ E
            (is_txn_always γ ∗ Pwal_tok ∗ txn_init_ghost_state γ')
            (∃ logm',
                txn_resources γ ((γ' <| txn_walnames; wal_heap_walnames := γ'' |>)) logm')%I
            (is_txn_durable ((γ' <| txn_walnames; wal_heap_walnames := γ'' |>)) dinit)%I
      with "[] [His_txn_always HPwal_tok Htxn_init]") as "(#Htxn_inv&Hcfupd)".
    { set_solver. }
    { iIntros "!> (>H&?&>Hinit) #HC".
      iSpecialize ("Hwal_cinv" with "[$]").
      iMod ("HPwal_tok_wand" with "[$]") as "Hwal_cfupd".
      iSpecialize ("Hwal_cfupd" with "HC").
      iDestruct "H" as (??) "H".
      iMod (fupd_mask_mono with "Hwal_cfupd") as "Hwal_cfupd".
      { solve_ndisj. }
      iPoseProof (txn_crash_transform _ γ γ' with "[H Hwal_cfupd Hinit]") as "Htransform".
      { auto. }
      { iFrame "H Hinit".
        iDestruct "Hwal_cfupd" as (??) "(?&?&?&?)".
        iExists _, _. iFrame.
      }
      iMod (fupd_mask_mono with "Htransform") as "Htransform"; auto.
      { set_solver+. }
      iModIntro.
      iDestruct "Htransform" as (??) "(Hdur&Hres)".
      iSplitR "Hdur".
      { iNext. iExists _. iFrame. }
      { iNext. iFrame. }
    }
    { iNext. iFrame. iExists _, _; iFrame. }
    iDestruct "Hcfupd" as "(Hcfupd_cancel&Hcfupd)".
    iRight in "HΦ".
    iApply "HΦ".
    iSplitL "".
    {
      iExists _, _; iFrame "#".
      iSplitL.
      - iApply (is_wal_alter with "Hwal").
        do 2 iModIntro. iClear "#".
        rewrite /P.
        iIntros (?) "[$ $]".
        iIntros (?) "$".
      -  iApply (ncinv_alter with "Htxn_inv").
         iIntros "!> !> !> (H&?)".
         iFrame. eauto.
    }
    iModIntro. iFrame "Hcfupd_cancel".
    rewrite /txn_cfupd_res.
    rewrite /txn_cfupd_cancel.
    iFrame.
    Unshelve.
    (* XXX: track this down. *)
    { simpl. eauto. }
    { exact (Build_async (∅: gmap addr object) []). }
    { exact (Build_async (∅: gmap addr object) []). }
    { exact (U64 0). }
Qed.

End goose_lang.

Section stable.
Context `{!txnG Σ}.
Context `{!heapGS Σ}.

Existing Instance ghost_var_into_crash.
Existing Instance mono_nat_auth_own_into_crash.
Existing Instance is_wal_inner_durable_stable.

Global Instance is_txn_durable_stable γ dinit:
  IntoCrash (is_txn_durable γ dinit) (λ _, is_txn_durable γ dinit).
Proof.
  rewrite /IntoCrash.
  iNamed 1.
  iDestruct (post_crash_nodep with "His_txn_always") as "His_txn_always".
  iDestruct (post_crash_nodep with "Hwal_res") as "Hwal_res".
  iDestruct (post_crash_nodep with "Hwal_heap_inv") as "Hwal_heap_inv".
  iDestruct (post_crash_nodep with "Hlocked_walheap") as "Hlocked_walheap".
  iCrash.
  iExists ls', logm, crash_heaps.
  iSplit; first eauto.
  iFrame "Hwal_res".
  iFrame "Hwal_heap_inv".
  iFrame "Hlocked_walheap".
  iFrame "His_txn_always".
  eauto.
Qed.
End stable.


Require Import compcert.backend.Cminor.
Require Import compcert.common.AST.
Require Import compcert.common.Errors.
Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Integers.
Require Import compcert.lib.Maps.
Require Import Seccomp.
Require Import Seccompjit.
Require Import Seccompconf.
Import ListNotations.

Fixpoint seccomp_func_filter (f: Seccomp.code) : bool :=
  match f with
  | [ Sret_k k ] => true
  | [ Sret_a ] => true

  | Salu_safe op :: rest => seccomp_func_filter rest
  | Salu_div op :: rest => seccomp_func_filter rest
  | Salu_shift op :: rest => seccomp_func_filter rest

  | Sjmp_ja off :: rest =>
    (Int.unsigned off <? list_length_z rest) &&
    (seccomp_func_filter rest)
  | Sjmp_jc cond jt jf :: rest =>
    (Byte.unsigned jt <? list_length_z rest) &&
    (Byte.unsigned jf <? list_length_z rest) &&
    (seccomp_func_filter rest)

  | Sld_w_abs k :: rest =>
    (Int.unsigned k <? sizeof_seccomp_data) &&
    (Int.unsigned k mod 4 =? 0) &&
    (seccomp_func_filter rest)

  | Sld_w_len :: rest => seccomp_func_filter rest
  | Sldx_w_len :: rest => seccomp_func_filter rest

  | Sld_imm k :: rest => seccomp_func_filter rest
  | Sldx_imm k :: rest => seccomp_func_filter rest
(*
  | Sld_mem k :: rest =>
    (Int.unsigned k <? seccomp_memwords) &&
    (seccomp_func_filter rest)
*)

  | Smisc_tax :: rest => seccomp_func_filter rest
  | Smisc_txa :: rest => seccomp_func_filter rest

  | Sret_k k :: rest => seccomp_func_filter rest
  | Sret_a :: rest => seccomp_func_filter rest

  | _ => false
  end.

Definition seccomp_filter (p: Seccomp.program) : bool :=
  let defs := p.(prog_defs) in
  let main := p.(prog_main) in
  match defs with
  (* Just one identifier *)
  | [ (id, Gfun (Internal f)) ] =>
    (id =? main)%positive &&
    seccomp_func_filter f
  | _ => false
  end.

Definition transl_program_filter (p: Seccomp.program) : res Cminor.program :=
  match seccomp_filter p with
  | true  => transl_program p
  | false => Error (msg "filter reject")
  end.


From iris.proofmode Require Import tactics.
From machine_program_logic.program_logic Require Import weakestpre.
From HypVeri.lang Require Import lang trans_extra.
From HypVeri.algebra Require Import base pagetable mem trans.
From HypVeri.rules Require Import run.
From HypVeri.logrel Require Import logrel logrel_extra.
From HypVeri Require Import stdpp_extra proofmode.
Import uPred.

Section ftlr_run.
  Context `{hypconst:HypervisorConstants}.
  Context `{hypparams:!HypervisorParameters}.
  Context `{vmG: !gen_VMG Σ}.

Lemma ftlr_run Φ_t Φ_r {i mem_acc_tx ai regs rxs ps_acc p_tx p_rx instr trans r0}:
  base_extra.is_total_gmap regs ->
  base_extra.is_total_gmap rxs ->
  {[p_tx; p_rx]} ⊆ ps_acc ->
  i ≠ V0 ->
  currently_accessible_in_trans_memory_pages i trans ⊆ ps_acc ∖ {[p_tx; p_rx]} ->
  p_rx ∉ ps_acc ∖ {[p_rx; p_tx]} ∪ accessible_in_trans_memory_pages i trans ->
  p_tx ∉ ps_acc ∖ {[p_rx; p_tx]} ∪ accessible_in_trans_memory_pages i trans ->
  regs !! PC = Some ai ->
  tpa ai ∈ ps_acc ->
  tpa ai ≠ p_tx ->
  dom mem_acc_tx = set_of_addr (ps_acc ∖ {[p_tx]}) ->
  tpa ai ∈ ps_acc ∖ {[p_tx]} ->
  mem_acc_tx !! ai = Some instr ->
  decode_instruction instr = Some Hvc ->
  regs !! R0 = Some r0 ->
  decode_hvc_func r0 = Some Run ->
  p_tx ≠ p_rx ->
  ⊢ ▷ (∀ (a : gmap reg_name Addr) (a0 : gset PID) (a1 : gmap Addr transaction) (a2 : gmap VMID (option (Addr * VMID))),
              ⌜base_extra.is_total_gmap a2⌝ -∗
              ⌜base_extra.is_total_gmap a⌝ -∗
              ⌜{[p_tx; p_rx]} ⊆ a0⌝ -∗
              ⌜currently_accessible_in_trans_memory_pages i a1 ⊆ a0 ∖ {[p_tx; p_rx]}⌝ -∗
              ⌜p_rx ∉ a0 ∖ {[p_rx; p_tx]} ∪ accessible_in_trans_memory_pages i a1⌝ -∗
              ⌜p_tx ∉ a0 ∖ {[p_rx; p_tx]} ∪ accessible_in_trans_memory_pages i a1⌝ -∗
              ([∗ map] r↦w ∈ a, r @@ i ->r w) -∗
              TX@i:=p_tx -∗
              p_tx -@O> - ∗ p_tx -@E> true -∗
              mailbox.rx_page i p_rx -∗
              i -@A> a0 -∗
              pagetable_entries_excl_owned i (a0 ∖ {[p_rx; p_tx]} ∖ currently_accessible_in_trans_memory_pages i a1) -∗
              transaction_hpool_global_transferred a1 -∗
              transaction_pagetable_entries_transferred i a1 -∗
              retrievable_transaction_transferred i a1 -∗
              rx_state_get i a2 -∗
              rx_states_global (delete i a2) -∗
              transaction_pagetable_entries_owned i a1 -∗
              retrieved_transaction_owned i a1 -∗
              (∃ mem : lang.mem, memory_pages (a0 ∪ (accessible_in_trans_memory_pages i a1)) mem) -∗
              ((∃ r0 : Addr, R0 @@ V0 ->r r0 ∗ ⌜decode_hvc_func r0 = Some Run⌝) ∗
              (∃ r1 : Addr, R1 @@ V0 ->r r1 ∗ ⌜decode_vmid r1 = Some i⌝) ∗ (∃ r2 : Addr, R2 @@ V0 ->r r2) ∗
              ▷ VMProp V0 (vmprop_zero i Φ_t Φ_r a1 a2) (1 / 2) ∗ ∃ P, VMProp i P 1) -∗
              WP ExecI @ i {{ _, True }}) -∗
   ([∗ map] r↦w ∈ regs, r @@ i ->r w) -∗
   TX@i:=p_tx -∗
   p_tx -@O> - ∗ p_tx -@E> true -∗
   i -@A> ps_acc -∗
   pagetable_entries_excl_owned i (ps_acc ∖ {[p_rx; p_tx]} ∖ (currently_accessible_in_trans_memory_pages i trans)) -∗
   transaction_hpool_global_transferred trans -∗
   transaction_pagetable_entries_transferred i trans -∗
   retrievable_transaction_transferred i trans -∗
   rx_state_get i rxs -∗
   mailbox.rx_page i p_rx -∗
   rx_states_global (delete i rxs) -∗
   transaction_pagetable_entries_owned i trans -∗
   retrieved_transaction_owned i trans -∗
   (∃ mem1 : mem, memory_pages ((ps_acc ∪ (accessible_in_trans_memory_pages i trans)) ∖ ps_acc) mem1) -∗
   ([∗ map] k↦v ∈ mem_acc_tx, k ->a v) -∗
   (∃ mem2 : mem, memory_page p_tx mem2) -∗
   ((∃ r0 : Addr, R0 @@ V0 ->r r0 ∗ ⌜decode_hvc_func r0 = Some Run⌝) ∗
    (∃ r1 : Addr, R1 @@ V0 ->r r1 ∗ ⌜decode_vmid r1 = Some i⌝) ∗ (∃ r2 : Addr, R2 @@ V0 ->r r2) ∗
    ▷ VMProp V0 (vmprop_zero i Φ_t Φ_r trans rxs) (1 / 2) ∗ ∃ P, VMProp i P 1) -∗
   SSWP ExecI @ i {{ bm, (if bm.1 then VMProp_holds i (1 / 2) else True) -∗ WP bm.2 @ i {{ _, True }} }}.
  Proof.
    iIntros (Htotal_regs Htotal_rxs Hsubset_mb Hneq_0 Hsubset_acc Hnin_rx Hnin_tx Hlookup_PC Hin_ps_acc Hneq_ptx Hdom_mem_acc_tx Hin_ps_acc_tx
                         Hlookup_mem_ai Heqn Hlookup_reg_R0).
    iIntros ( Hdecode_hvc Hneq_mb) "IH regs tx pgt_tx pgt_acc pgt_owned trans_hpool_global tran_pgt_transferred retri rx_state rx other_rx
                          tran_pgt_owned retri_owned mem_rest mem_acc_tx mem_tx ([% [R0z %]]& [% [R1z %]] & [% R2z] & prop0 &propi)".
    pose proof (Htotal_regs R0) as [a_arg1 Hlookup_arg1].
    pose proof (Htotal_regs R2) as [a_arg2 Hlookup_arg2].
    (* getting registers *)
    iDestruct ((reg_big_sepM_split_upd3 i Hlookup_PC Hlookup_arg1 Hlookup_arg2)
                with "[$regs]") as "(PC & r_arg1 & r_arg2 & Hacc_regs)"; [done | done | done | done |].
    (* getting mem *)
    iDestruct (mem_big_sepM_split mem_acc_tx Hlookup_mem_ai with "[$mem_acc_tx]")
      as "[mem_instr Hacc_mem_acc]".
    rewrite Hlookup_arg1 in Hlookup_reg_R0.
    inversion Hlookup_reg_R0.
    subst a_arg1.
    iApply (run_not_primary (r0 := r0) ai i with "[PC tx pgt_acc mem_instr r_arg1 r_arg2]"); iFrameAutoSolve.
    iNext.
    iIntros "(PC & mem_instr & pgt_acc & tx & r_arg1 & r_arg2) _".
    iDestruct ("Hacc_regs" with "[$PC $r_arg1 $r_arg2]") as (regs') "[%Htotal_regs' regs]";iFrame.
    iDestruct ("Hacc_mem_acc" with "[mem_instr]") as "mem"; iFrame.
    iAssert (memory_pages (ps_acc ∖ {[p_tx]}) _)%I with "[mem]" as "mem_acc".
    by iFrame.
    iApply ("IH" $!  _ ps_acc trans _ Htotal_rxs Htotal_regs' Hsubset_mb Hsubset_acc Hnin_rx Hnin_tx with "regs tx pgt_tx rx pgt_acc pgt_owned
                 trans_hpool_global tran_pgt_transferred retri rx_state other_rx tran_pgt_owned
                  retri_owned [mem_rest mem_acc mem_tx] [R0z R1z R2z $prop0 $propi]").
    {
      iDestruct (memory_pages_split_singleton' p_tx ps_acc with "[mem_acc mem_tx]") as "mem_acc". set_solver + Hsubset_mb.
      iSplitL "mem_acc".
      iExists mem_acc_tx; by iFrame "mem_acc".
      iFrame "mem_tx".
      iApply (memory_pages_split_diff' _ ps_acc with "[$mem_rest $mem_acc]").
      set_solver +.
    }
    {
      iSplitL "R0z". iExists _; iFrame. done.
      iSplitL "R1z". iExists _; iFrame. done.
      iExists _. iFrame.
    }
  Qed.

End ftlr_run.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
Require Import Coqlib.
Require Import Errors.
Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import MemoryExtra.
Require Import EventsExtra.
Require Import GlobalenvsExtra.
Require Import Locations.
Require Import DataType.
Require Import LAsm.
Require Import CDataTypes.
Require Import AsmExtra.
Require Clight.
Require Import Smallstep.
Require Import ClightBigstep.
Require Import Cop.
Require Import MALOp.
Require Import MALInit.
Require Import ZArith.Zwf.
Require Import MALInitCode.
Require Import EventsExtra.
Require Import GlobalenvsExtra.
Require Import Smallstep.
Require Import Op.
Require Import Values.
Require Import MemoryExtra.
Require Import Maps.
Require Import Heap.
Require Import RefinementTactic.
Require Import AuxLemma.
Require Import LayerTemplate2.
Require Export ALOpGen.
Require Import Implementation.
Require Import SeparateCompiler.
Require Import ClightImplemExtra.
Require Import LayerDefinition.
Require Import RealParams.

Open Local Scope string_scope.
Open Local Scope error_monad_scope.

Module ALOPGENIMPL.
  Export ALOpGen.ALOPGEN.

  Lemma hprim_finite_type:
    forall
      (Q: MALOP.primOp -> Prop)
      (Q_dec: forall p, {Q p} + {~ Q p}),
      {forall p, Q p} + {~ forall p, Q p}.
  Proof with (try (right; eauto; fail)).
    intros.
    destruct (Q_dec MALOP.PSetPE)...
    destruct (Q_dec MALOP.PSetPT)...
    destruct (Q_dec MALOP.PGetNps)...
    destruct (Q_dec MALOP.PIsNorm)...
    destruct (Q_dec MALOP.PATGetU)...
    destruct (Q_dec MALOP.PATSetU)...
    destruct (Q_dec MALOP.PTrapIn)...
    destruct (Q_dec MALOP.PTrapOut)...
    destruct (Q_dec MALOP.PHostIn)...
    destruct (Q_dec MALOP.PHostOut)...
    destruct (Q_dec MALOP.PTrapGet)...
    destruct (Q_dec MALOP.PTrapRet)...
    destruct (Q_dec MALOP.PMemInit)...
    left; destruct p; assumption.
  Defined.

  Local Open Scope Z_scope.

 Section WithPrimitives.

  Context `{real_params: RealParams}.

    Notation HDATA := (MALOP.AbData (kern_high := kern_high) (kern_low := kern_low) (maxpage:= maxpage)).
    Notation LDATA := (MALINIT.AbData (PgSize := PgSize) (kern_low := kern_low)).

    Notation Hfundef := (fundef (external_function:= MALOP.primOp)).
    Notation Lfundef := (fundef (external_function:= MALINIT.primOp)).

    Notation funkind := (funkind Asm.code (Clight.fundef (external_function := MALINIT.primOp))).

    Notation dummy := (AST.Internal nil).

    Definition source_implem_extfuns (p: MALOP.primOp): funkind :=
      match p with
        | MALOP.PSetPE => Code _ (AST.External MALINIT.PSetPE)
        | MALOP.PSetPT => Code _ (AST.External MALINIT.PSetPT)
        | MALOP.PTrapIn => Code _ (AST.External MALINIT.PTrapIn)
        | MALOP.PTrapOut => Code _ (AST.External MALINIT.PTrapOut)
        | MALOP.PHostIn => Code _ (AST.External MALINIT.PHostIn)
        | MALOP.PHostOut => Code _ (AST.External MALINIT.PHostOut)
        | MALOP.PTrapGet => Code _ (AST.External MALINIT.PTrapGet)
        | MALOP.PTrapRet => Code _ (AST.External MALINIT.PTrapRet)
        | MALOP.PGetNps => Code _ (AST.External MALINIT.PGetNps)
        | MALOP.PIsNorm => Code _ (AST.External MALINIT.PIsNorm)
        | MALOP.PATGetU => Code _ (AST.External MALINIT.PATGetU)
        | MALOP.PATSetU => Code _ (AST.External MALINIT.PATSetU)
        | MALOP.PMemInit => SourceFun (Clight.Internal (MALINITCODE.f_mem_init set_nps set_norm get_size get_mms get_mml is_usable boot_loader)) dummy
      end.

    Notation varkind := (varkind unit Ctypes.type).

    Definition source_implem_impl_globs : list (ident * option (globdef funkind varkind)) :=
      (set_nps, Some (Gfun (SourceFun (Clight.External (MALINIT.PSetNps) (Ctypes.Tcons tint Ctypes.Tnil) Ctypes.Tvoid) dummy)))
        :: (set_norm, Some (Gfun (SourceFun (Clight.External (MALINIT.PATSetNorm) (Ctypes.Tcons tint (Ctypes.Tcons tint Ctypes.Tnil)) Ctypes.Tvoid) dummy)))
        :: (get_size, Some (Gfun (SourceFun (Clight.External (MALINIT.PGetSize) Ctypes.Tnil tint) dummy)))
        :: (get_mms, Some (Gfun (SourceFun (Clight.External (MALINIT.PMMGetS) (Ctypes.Tcons tint Ctypes.Tnil) tint) dummy)))
        :: (get_mml, Some (Gfun (SourceFun (Clight.External (MALINIT.PMMGetL) (Ctypes.Tcons tint Ctypes.Tnil) tint) dummy)))
        :: (is_usable, Some (Gfun (SourceFun (Clight.External (MALINIT.PIsUsable) (Ctypes.Tcons tint Ctypes.Tnil) tint) dummy)))
        :: (boot_loader, Some (Gfun (SourceFun (Clight.External (MALINIT.PBootLoader) (Ctypes.Tcons tint Ctypes.Tnil) Ctypes.Tvoid) dummy)))
        :: nil.

    Let NOREPET_IMPL: list_norepet (map fst source_implem_impl_globs).
    Proof.
      case_eq (list_norepet_dec peq (map fst source_implem_impl_globs)); try discriminate; tauto.
    Qed.

    Definition source_implem : source_implem Asm.code unit MALOP.primOp (low := MALINIT.primOp) (Clight.fundef (external_function := MALINIT.primOp)) Ctypes.type.
    Proof.
      split.
       exact source_implem_extfuns.
       exact source_implem_impl_globs.
    Defined.

    Let im : implem Asm.code unit MALOP.primOp (low := MALINIT.primOp) := implem_of_source_implem transf_clight_fundef Cshmgen.transl_globvar source_implem.

    Notation Hprogram := (Asm.program (external_function:= MALOP.primOp)).
    Notation Lprogram := (Asm.program (external_function:= MALINIT.primOp)).

    Let Im_meminit: Lfundef := transf_source_fun' transf_clight_fundef (source_implem_extfuns MALOP.PMemInit).

    Definition impl_glbl :  list (ident * option (globdef Lfundef unit)) :=
      map
        (transf_source_def' transf_clight_fundef
                            Cshmgen.transl_globvar)
        source_implem_impl_globs.

    Let well_new_glb: Genv.well_idglob_list impl_glbl = true.
    Proof. reflexivity. Qed.

    (* This is basically an axiom that can be easily checked because MALOP.primOp is a finite type. However, in practice, generation of CertiKOS code will be very slow because compilation will have to occur twice, one for this check, and a second independently for the generation of the actual code. *)

    Lemma extfun_compilation_succeeds_dec:
      {forall p clight asmfallback,
        source_implem_extfuns p = SourceFun clight asmfallback ->
        exists asm, transf_clight_fundef clight = OK asm} +
      {~ forall p clight asmfallback,
        source_implem_extfuns p = SourceFun clight asmfallback ->
        exists asm, transf_clight_fundef clight = OK asm}.
    Proof.
      apply hprim_finite_type.
      intro.
      destruct (source_implem_extfuns p); try (left; discriminate).
      case_eq (transf_clight_fundef sf).
       left. intros. inv H0. eauto.
      intros. right. intro. exploit H0; eauto. destruct 1. congruence.
    Defined.

    Hypothesis extfun_compilation_succeeds:
      forall p clight asmfallback,
        source_implem_extfuns p = SourceFun clight asmfallback ->
        exists asm, transf_clight_fundef clight = OK asm.

    Section WithProg.

    Variable prog: Hprogram.

    Definition tprog: Lprogram := Implementation.transf_program im prog.

    Let TRANSF: ALOPGEN.transf_program Im_meminit impl_glbl prog = OK tprog.
    Proof.
      unfold tprog.
      unfold Asm.program, Asm.fundef.
      generalize (transf_program_eq im prog).
      intros.
      rewrite <- H.
      unfold transf_program.
      simpl.
      f_equal.
      apply FunctionalExtensionality.functional_extensionality.
      destruct x; simpl.
       reflexivity.
      destruct p; reflexivity.
    Qed.

    Notation ge := (Genv.globalenv prog).
    Notation tge := (Genv.globalenv tprog).

    Hypothesis prog_nonempty:
      prog_defs_names prog <> nil.

    Hypothesis prog_main_valid:
      ~ Plt' (prog_main prog) (prog_first_symbol prog).

    Hypothesis prog_first_valid:
      ~ Plt' (prog_first_symbol prog) (get_next_symbol (map fst impl_glbl)).

    Let NEW_INJ:  (forall s', Genv.find_symbol ge s' <> None ->
                                     ~ In s' (map fst impl_glbl)).
    Proof.
      change impl_glbl with (implem_new_globs im).
      apply new_ids_fresh.
      assumption.
    Qed.

    Let sprog : Clight.program (external_function := MALINIT.primOp) := source_program_only source_implem prog.
    Let sge := Genv.globalenv sprog.

    Ltac elim_or H t :=
      match type of H with
        | False => contradiction
        | _ \/ _ =>
          let K := fresh "K" in
          destruct H as [H | K]; [ elim_or H t | elim_or K t ]
        | _ => t H
      end.

    Let tsprog_strong : {tsprog | transf_clight_program sprog = OK tsprog}.
    Proof.
      case_eq (transf_clight_program sprog); eauto.
      intros. exfalso.
      refine (_ (Implementation.compilation_succeeds
                    transf_clight_fundef
                    Cshmgen.transl_globvar
                    source_implem _ _ _
                    prog)).
      destruct 1.
      exploit transf_clight_fundef_to_program; eauto.
      unfold sprog in H.
      congruence.
      assumption.
      simpl.
      intros until fallback.
      intro K.
      let t J := (inv J; rewrite transf_clight_fundef_external; eauto) in elim_or K t.
      unfold Cshmgen.transl_globvar. eauto.
    Qed.

    Let tsprog := let (p, _) := tsprog_strong in p.

    Let tsprog_prop : transf_clight_program sprog = OK tsprog.
    Proof.
      unfold tsprog.
      destruct tsprog_strong.
      assumption.
    Qed.

    Let tsge := Genv.globalenv tsprog.

    Lemma tprog_first_next:
      prog_first_symbol tprog = get_first_symbol (map fst impl_glbl) /\
      prog_next_symbol  tprog = prog_next_symbol prog.
    Proof.
      replace (get_first_symbol (map fst impl_glbl)) with (implem_first_symbol im) by reflexivity.
      unfold tprog.
      apply transf_program_first_next_symbol.
      assumption.
      assumption.
      discriminate.
    Qed.

    Lemma tprog_main_valid:
      ~ Plt' (prog_main tprog) (prog_first_symbol tprog).
    Proof.
      Opaque Plt'.
      simpl.
      destruct tprog_first_next.
      rewrite H.
      apply Ple'_not_Plt'.
      eapply Ple'_trans.
      apply first_le_next.
      discriminate.
      eapply Ple'_trans.
      apply not_Plt'_Ple'.
      eassumption.
      apply not_Plt'_Ple'.
      assumption.
    Qed.

    Lemma tprog_nonempty:
      prog_defs_names tprog <> nil.
    Proof.
      apply transf_program_nonempty.
      assumption.
    Qed.

    (** boot_loader *)

    Let bbootloader : block := Genv.genv_next ge + Z.of_nat 6.

    Let hboot_loader1 : Genv.find_symbol sge boot_loader = Some bbootloader.
    Proof.
      eapply add_globals_transf_augment_option.
      2: eapply source_program_only_prop.
      assumption.
      intro. exploit Genv.find_symbol_exists_ex. eassumption. destruct 1.
      eapply (NEW_INJ boot_loader).
      congruence.
      simpl; tauto.
      reflexivity.
    Qed.

    Let hboot_loader2 : Genv.find_funct sge (Vptr bbootloader Int.zero) = Some (Clight.External (MALINIT.PBootLoader) (Ctypes.Tcons tint Ctypes.Tnil) Ctypes.Tvoid).
    Proof.
      simpl. destruct (Int.eq_dec Int.zero Int.zero); try congruence.
      refine (_ (Genv.find_new_funct_ptr_exists_option _ _ _ _ _ _ _ boot_loader _ _)).
       2: exact (source_program_only_prop source_implem prog).
       3: simpl; eauto 8.
       2: assumption.
      fold sprog sge.
      destruct 1 as [? [? ?]].
      congruence.
    Qed.

    Let hboot_loader3: Clight.type_of_global sge bbootloader = Some (Ctypes.Tfunction (Ctypes.Tcons tint Ctypes.Tnil) Ctypes.Tvoid).
    Proof.
      unfold Clight.type_of_global.
      case_eq (Genv.find_var_info sge bbootloader).
       intros. exfalso.
       exploit Genv.find_var_info_rev_transf_augment_option.
       exact (source_program_only_prop source_implem prog).
       eassumption.
      rewrite zlt_false.
       simpl.
       intro K.
       let t _ := discriminate in elim_or K t.
      unfold bbootloader. unfold Asm.fundef. omega.
      intros.
      simpl in hboot_loader2. destruct (Int.eq_dec Int.zero Int.zero); try congruence. rewrite hboot_loader2. reflexivity.
    Qed.

    (** get_size *)

    Let bgetsize : block := Genv.genv_next ge + Z.of_nat 2.

    Let hget_size1 : Genv.find_symbol sge get_size = Some bgetsize.
    Proof.
      eapply add_globals_transf_augment_option.
      2: eapply source_program_only_prop.
      assumption.
      intro. exploit Genv.find_symbol_exists_ex. eassumption. destruct 1.
      eapply (NEW_INJ get_size).
      congruence.
      simpl; tauto.
      reflexivity.
    Qed.

    Let hget_size2 : Genv.find_funct sge (Vptr bgetsize Int.zero) = Some (Clight.External (MALINIT.PGetSize) Ctypes.Tnil tint).
    Proof.
      simpl. destruct (Int.eq_dec Int.zero Int.zero); try congruence.
      refine (_ (Genv.find_new_funct_ptr_exists_option _ _ _ _ _ _ _ get_size _ _)).
       2: exact (source_program_only_prop source_implem prog).
       3: simpl; eauto 8.
       2: assumption.
      fold sprog sge.
      destruct 1 as [? [? ?]].
      congruence.
    Qed.

    Let hget_size3 : Clight.type_of_global sge bgetsize = Some (Ctypes.Tfunction Ctypes.Tnil tint).
    Proof.
      unfold Clight.type_of_global.
      case_eq (Genv.find_var_info sge bgetsize).
       intros. exfalso.
       exploit Genv.find_var_info_rev_transf_augment_option.
       exact (source_program_only_prop source_implem prog).
       eassumption.
      rewrite zlt_false.
       simpl.
       intro K.
       let t _ := discriminate in elim_or K t.
      unfold bgetsize. unfold Asm.fundef. omega.
      intros.
      simpl in hget_size2. destruct (Int.eq_dec Int.zero Int.zero); try congruence. rewrite hget_size2. reflexivity.
    Qed.

    (** get_mms *)

    Let bgetmms: block := Genv.genv_next ge + Z.of_nat 3.

    Let hget_mms1 : Genv.find_symbol sge get_mms = Some bgetmms.
    Proof.
      eapply add_globals_transf_augment_option.
      2: eapply source_program_only_prop.
      assumption.
      intro. exploit Genv.find_symbol_exists_ex. eassumption. destruct 1.
      eapply (NEW_INJ get_mms).
      congruence.
      simpl; tauto.
      reflexivity.
    Qed.

    Let hget_mms2 : Genv.find_funct sge (Vptr bgetmms Int.zero) = Some (Clight.External (MALINIT.PMMGetS) (Ctypes.Tcons tint Ctypes.Tnil) tint).
    Proof.
      simpl. destruct (Int.eq_dec Int.zero Int.zero); try congruence.
      refine (_ (Genv.find_new_funct_ptr_exists_option _ _ _ _ _ _ _ get_mms _ _)).
       2: exact (source_program_only_prop source_implem prog).
       3: simpl; eauto 8.
       2: assumption.
      fold sprog sge.
      destruct 1 as [? [? ?]].
      congruence.
    Qed.

    Let hget_mms3 : Clight.type_of_global sge bgetmms = Some (Ctypes.Tfunction (Ctypes.Tcons tint Ctypes.Tnil) tint).
    Proof.
      unfold Clight.type_of_global.
      case_eq (Genv.find_var_info sge bgetmms).
       intros. exfalso.
       exploit Genv.find_var_info_rev_transf_augment_option.
       exact (source_program_only_prop source_implem prog).
       eassumption.
      rewrite zlt_false.
       simpl.
       intro K.
       let t _ := discriminate in elim_or K t.
      unfold bgetmms. unfold Asm.fundef. omega.
      intros.
      simpl in hget_mms2. destruct (Int.eq_dec Int.zero Int.zero); try congruence. rewrite hget_mms2. reflexivity.
    Qed.

    (** get_mml *)

    Let bgetmml: block := Genv.genv_next ge + Z.of_nat 4.

    Let hget_mml1 : Genv.find_symbol sge get_mml = Some bgetmml.
    Proof.
      eapply add_globals_transf_augment_option.
      2: eapply source_program_only_prop.
      assumption.
      intro. exploit Genv.find_symbol_exists_ex. eassumption. destruct 1.
      eapply (NEW_INJ get_mml).
      congruence.
      simpl; tauto.
      reflexivity.
    Qed.

    Let hget_mml2 : Genv.find_funct sge (Vptr bgetmml Int.zero) = Some (Clight.External (MALINIT.PMMGetL) (Ctypes.Tcons tint Ctypes.Tnil) tint).
    Proof.
      simpl. destruct (Int.eq_dec Int.zero Int.zero); try congruence.
      refine (_ (Genv.find_new_funct_ptr_exists_option _ _ _ _ _ _ _ get_mml _ _)).
       2: exact (source_program_only_prop source_implem prog).
       3: simpl; eauto 8.
       2: assumption.
      fold sprog sge.
      destruct 1 as [? [? ?]].
      congruence.
    Qed.

    Let hget_mml3 : Clight.type_of_global sge bgetmml = Some (Ctypes.Tfunction (Ctypes.Tcons tint Ctypes.Tnil) tint).
    Proof.
      unfold Clight.type_of_global.
      case_eq (Genv.find_var_info sge bgetmml).
       intros. exfalso.
       exploit Genv.find_var_info_rev_transf_augment_option.
       exact (source_program_only_prop source_implem prog).
       eassumption.
      rewrite zlt_false.
       simpl.
       intro K.
       let t _ := discriminate in elim_or K t.
      unfold bgetmml. unfold Asm.fundef. omega.
      intros.
      simpl in hget_mml2. destruct (Int.eq_dec Int.zero Int.zero); try congruence. rewrite hget_mml2. reflexivity.
    Qed.

    (** is_usable *)

    Let bisusable: block := Genv.genv_next ge + Z.of_nat 5.

    Let his_usable1 : Genv.find_symbol sge is_usable = Some bisusable.
    Proof.
      eapply add_globals_transf_augment_option.
      2: eapply source_program_only_prop.
      assumption.
      intro. exploit Genv.find_symbol_exists_ex. eassumption. destruct 1.
      eapply (NEW_INJ is_usable).
      congruence.
      simpl; tauto.
      reflexivity.
    Qed.

    Let his_usable2 : Genv.find_funct sge (Vptr bisusable Int.zero) = Some (Clight.External (MALINIT.PIsUsable) (Ctypes.Tcons tint Ctypes.Tnil) tint).
    Proof.
      simpl. destruct (Int.eq_dec Int.zero Int.zero); try congruence.
      refine (_ (Genv.find_new_funct_ptr_exists_option _ _ _ _ _ _ _ is_usable _ _)).
       2: exact (source_program_only_prop source_implem prog).
       3: simpl; eauto 8.
       2: assumption.
      fold sprog sge.
      destruct 1 as [? [? ?]].
      congruence.
    Qed.

    Let his_usable3 : Clight.type_of_global sge bisusable = Some (Ctypes.Tfunction (Ctypes.Tcons tint Ctypes.Tnil) tint).
    Proof.
      unfold Clight.type_of_global.
      case_eq (Genv.find_var_info sge bisusable).
       intros. exfalso.
       exploit Genv.find_var_info_rev_transf_augment_option.
       exact (source_program_only_prop source_implem prog).
       eassumption.
      rewrite zlt_false.
       simpl.
       intro K.
       let t _ := discriminate in elim_or K t.
      unfold bisusable. unfold Asm.fundef. omega.
      intros.
      simpl in his_usable2. destruct (Int.eq_dec Int.zero Int.zero); try congruence. rewrite his_usable2. reflexivity.
    Qed.

    (** set_norm *)

    Let batsetnorm: block := Genv.genv_next ge + Z.of_nat 1.

    Let hset_norm1 : Genv.find_symbol sge set_norm = Some batsetnorm.
    Proof.
      eapply add_globals_transf_augment_option.
      2: eapply source_program_only_prop.
      assumption.
      intro. exploit Genv.find_symbol_exists_ex. eassumption. destruct 1.
      eapply (NEW_INJ set_norm).
      congruence.
      simpl; tauto.
      reflexivity.
    Qed.

    Let hset_norm2 : Genv.find_funct sge (Vptr batsetnorm Int.zero) = Some (Clight.External (MALINIT.PATSetNorm) (Ctypes.Tcons tint (Ctypes.Tcons tint Ctypes.Tnil)) Ctypes.Tvoid).
    Proof.
      simpl. destruct (Int.eq_dec Int.zero Int.zero); try congruence.
      refine (_ (Genv.find_new_funct_ptr_exists_option _ _ _ _ _ _ _ set_norm _ _)).
       2: exact (source_program_only_prop source_implem prog).
       3: simpl; eauto 8.
       2: assumption.
      fold sprog sge.
      destruct 1 as [? [? ?]].
      congruence.
    Qed.

    Let hset_norm3 : Clight.type_of_global sge batsetnorm = Some (Ctypes.Tfunction (Ctypes.Tcons tint (Ctypes.Tcons tint Ctypes.Tnil)) Ctypes.Tvoid).
    Proof.
      unfold Clight.type_of_global.
      case_eq (Genv.find_var_info sge batsetnorm).
       intros. exfalso.
       exploit Genv.find_var_info_rev_transf_augment_option.
       exact (source_program_only_prop source_implem prog).
       eassumption.
      rewrite zlt_false.
       simpl.
       intro K.
       let t _ := discriminate in elim_or K t.
      unfold batsetnorm. unfold Asm.fundef. omega.
      intros.
      simpl in hset_norm2. destruct (Int.eq_dec Int.zero Int.zero); try congruence. rewrite hset_norm2. reflexivity.
    Qed.

    (** set_nps *)

    Let bsetnps: block := Genv.genv_next ge + Z.of_nat 0.

    Let hset_nps1 : Genv.find_symbol sge set_nps = Some bsetnps.
    Proof.
      eapply add_globals_transf_augment_option.
      2: eapply source_program_only_prop.
      assumption.
      intro. exploit Genv.find_symbol_exists_ex. eassumption. destruct 1.
      eapply (NEW_INJ set_nps).
      congruence.
      simpl; tauto.
      reflexivity.
    Qed.

    Let hset_nps2 : Genv.find_funct sge (Vptr bsetnps Int.zero) = Some (Clight.External (MALINIT.PSetNps) (Ctypes.Tcons tint Ctypes.Tnil) Ctypes.Tvoid).
    Proof.
      simpl. destruct (Int.eq_dec Int.zero Int.zero); try congruence.
      refine (_ (Genv.find_new_funct_ptr_exists_option _ _ _ _ _ _ _ set_nps _ _)).
       2: exact (source_program_only_prop source_implem prog).
       3: simpl; eauto 8.
       2: assumption.
      fold sprog sge.
      destruct 1 as [? [? ?]].
      congruence.
    Qed.

    Let hset_nps3 : Clight.type_of_global sge bsetnps = Some (Ctypes.Tfunction (Ctypes.Tcons tint Ctypes.Tnil) Ctypes.Tvoid).
    Proof.
      unfold Clight.type_of_global.
      case_eq (Genv.find_var_info sge bsetnps).
       intros. exfalso.
       exploit Genv.find_var_info_rev_transf_augment_option.
       exact (source_program_only_prop source_implem prog).
       eassumption.
      rewrite zlt_false.
       simpl.
       intro K.
       let t _ := discriminate in elim_or K t.
      unfold bsetnps. unfold Asm.fundef. omega.
      intros.
      simpl in hset_nps2. destruct (Int.eq_dec Int.zero Int.zero); try congruence. rewrite hset_nps2. reflexivity.
    Qed.

    Context `{PageFaultHandler_LOC: ident}.

    Section WITHMEM.

    Context {mem__MALOP mem__MALINIT}
      `{HHmem: !LayerMemoryModel HDATA mem__MALOP}
      `{HLmem: !LayerMemoryModel LDATA mem__MALINIT}
      `{HLayerInject: !LayerMemoryInjections HDATA LDATA _ _}.

    Instance HLayer: LayerDefinition HDATA MALOP.primOp mem__MALOP :=
      MALOP.layer_def (maxpage := maxpage) (real_nps := real_nps) (real_AT := real_AT).

    Instance LLayer: LayerDefinition LDATA MALINIT.primOp mem__MALINIT :=
      MALINIT.layer_def (PgSize := PgSize) (real_size := real_size) (real_mm := real_mm) (kern_low := kern_low) (maxpage := maxpage).

      Notation HLoad:= (MALOP.exec_loadex (NPT_LOC:= NPT_LOC) (PgSize:=PgSize)
                                          (PageFaultHandler_LOC := PageFaultHandler_LOC)).

      Notation HStore:= (MALOP.exec_storeex (NPT_LOC:= NPT_LOC) (PgSize:= PgSize)
                                            (PageFaultHandler_LOC := PageFaultHandler_LOC)).

      Notation LLoad := (MALINIT.exec_loadex (NPT_LOC:= NPT_LOC) (PageFaultHandler_LOC := PageFaultHandler_LOC)).

      Notation LStore:= ( MALINIT.exec_storeex (NPT_LOC:= NPT_LOC) (PageFaultHandler_LOC := PageFaultHandler_LOC)).

      Notation lstep:= (MALINIT.step (NPT_LOC:= NPT_LOC) (PageFaultHandler_LOC := PageFaultHandler_LOC)
                                     (maxpage:= maxpage) (real_size:= real_size) (real_mm:= real_mm)).

      Notation LADT := MALINIT.ADT.

        Let meminit_spec:
        forall r' b  m0 labd' mbi_adr sg,
          let labd := Mem.get_abstract_data m0 in
          r' PC = Vptr b Int.zero
          -> Genv.find_funct_ptr tge b = Some (Im_meminit)
          -> MALINIT.mem_init (kern_high:=kern_high) (maxpage:=maxpage) labd real_size real_nps real_mm
                              (real_AT (MALINIT.AT (LADT labd))) (Int.unsigned mbi_adr) = Some labd'
          -> (forall b o, r' ESP = Vptr b o -> Mem.tget m0 b = Some Tag_stack)
          -> r' ESP <> Vundef
          -> r' RA  <> Vundef
          -> Genv.find_funct_ptr ge b = Some (External MALOP.PMemInit)
          -> asm_invariant tge (State r' m0)
          -> sg = mksignature (Tint::nil) None
          -> extcall_arguments r' m0 sg (Vint mbi_adr::nil)
          -> exists f' m0' r_,
               inject_incr (Mem.flat_inj (Mem.nextblock m0)) f'
               /\ Memtype.Mem.inject f' m0 m0'
               /\ Mem.nextblock m0 <= Mem.nextblock m0'
               /\ plus lstep tge (State r' m0) E0
                       (State r_ (Mem.put_abstract_data m0' labd'))
               /\ True
               /\ r_ PC = r' RA
               /\ r_ # ESP = r' # ESP
               /\ (forall l,
                     ~In (Locations.R l) Conventions1.temporaries -> ~In (Locations.R l) Conventions1.destroyed_at_call
                     -> Val.lessdef (r' (preg_of l)) (r_ (preg_of l))).
        Proof.
          intros.
          exploit (ClightImplemExtra.bigstep_clight_to_lsem
                     MALOP.primOp
                     (exec_load := LLoad)
                     (exec_store := LStore)
                     (primitive_call := MALINIT.primitive_call)
                     (is_primitive_call := MALINIT.is_primitive_call)
                     (kernel_mode := MALINIT.kernel_mode)
                  ).
          apply MALINIT.exec_load_exec_loadex.
          apply MALINIT.exec_store_exec_storeex.
          apply MALINIT.extcall_not_primitive.
          apply MALINIT.primitive_kernel_mode.
          3: eassumption.
          assumption.
          assumption.
          2: eassumption.
          5: eassumption.
          9: eassumption.
          7: reflexivity.
          intros; eapply MALINITCODE.mem_init_correct.
           2: eassumption. eassumption. assumption.
           2: eassumption. eassumption. assumption.
           2: eassumption. eassumption. assumption.
           2: eassumption. eassumption. assumption.
           2: eassumption. eassumption. assumption.
           2: eassumption. eassumption. assumption.
           2: eassumption. eassumption. assumption.
          assumption.
          (* BEGIN hypotheses coming from refinement proof *)
          eassumption.
          reflexivity.
          (* END hypotheses coming from refinement proof *)
          assumption.
          assumption.
          assumption.
          assumption.
          assumption.
          unfold MALINIT.kernel_mode.
          destruct (MALINIT.INV (Mem.get_abstract_data m0)).
          apply MALINIT.mem_init_eq in H1.
          functional inversion H1.
          functional inversion H10; unfold adt0 in *; auto.
          destruct 1 as [? [? [m_asm [? [INJ [NB [PLUS [? [? [? ?]]]]]]]]]].
          generalize (Mem.put_abstract_data_inject_inside _ _ _ INJ (Mem.get_abstract_data m0)).
          rewrite Mem.put_put_abstract_data.
          rewrite Mem.put_get_abstract_data.
          intro.
          replace (Mem.nextblock m_asm) with (Mem.nextblock (Mem.put_abstract_data m_asm (Mem.get_abstract_data m0))) in NB by (rewrite Mem.nextblock_put_abstract_data; reflexivity).
          replace m_asm with (Mem.put_abstract_data (Mem.put_abstract_data m_asm (Mem.get_abstract_data m0)) labd') in PLUS.
          eauto 11.
          rewrite Mem.put_put_abstract_data.
          replace labd' with (Mem.get_abstract_data m_asm).
          rewrite Mem.put_get_abstract_data.
          reflexivity.
          erewrite <- Mem.get_abstract_data_inject_inside; eauto.
          rewrite Mem.get_put_abstract_data.
          reflexivity.
        Qed.

    Theorem transf_program_correct:
        Smallstep.backward_simulation
          (MALOP.semantics (NPT_LOC:= NPT_LOC) (PgSize:=PgSize) (kern_low:=kern_low) (kern_high:=kern_high) (maxpage:=maxpage)
                           (PageFaultHandler_LOC:= PageFaultHandler_LOC) (real_nps:= real_nps) (real_AT:= real_AT) prog)
          (MALINIT.semantics (NPT_LOC:= NPT_LOC) (PageFaultHandler_LOC:= PageFaultHandler_LOC) (maxpage:= maxpage)
                             (real_size:= real_size) (real_mm:= real_mm) tprog).
    Proof.
      eapply ALOPGEN.transf_program_correct; simpl; eauto.
      Grab Existential Variables.
      omega.
      inversion real_params; auto.
      inversion real_params; auto.
      inversion real_params; auto.
      inversion real_params; auto.
    Qed.

    End WITHMEM.

    End WithProg.

 End WithPrimitives.

End ALOPGENIMPL.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsRef2.Spec.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition destroy_table (llt_gidx: Z) (idx: Z) (rtt_addr: Z) (rtt_gidx: Z) (level: Z) (map_addr: Z) (adt: RData) :=
    let gn_llt := (gs (share adt)) @ llt_gidx in
    let llt_pte := (g_data (gnorm gn_llt)) @ idx in
    rely (g_tag (ginfo gn_llt) =? GRANULE_STATE_TABLE);
    rely (gtype gn_llt =? GRANULE_STATE_TABLE);
    rely is_int64 llt_pte;
    if (__entry_is_table llt_pte) && (rtt_addr =? (Z.land llt_pte ADDRESS_MASK)) then
      rely GRANULE_ALIGNED rtt_addr;
      let adt := adt {share: (share adt) {gs: (gs (share adt)) # llt_gidx == (gn_llt {glock: Some CPU_ID})}} in
      let gn_rtt := (gs (share adt)) @ rtt_gidx in
      rely prop_dec (glock gn_rtt = None);
      rely (g_tag (ginfo gn_rtt) =? GRANULE_STATE_TABLE);
      rely (tbl_level (gaux gn_llt) =? level - 1);
      rely (tbl_level (gaux gn_rtt) =? level);
      let e := EVT CPU_ID (ACQ rtt_gidx) in
      let e' := EVT CPU_ID (REL rtt_gidx (gn_rtt {glock: Some CPU_ID})) in
      rely prop_dec (forall i : ZIndexed.t, is_int64 (g_data (gnorm gn_rtt)) @ i = true);
      let ipa_gidx := __addr_to_gidx map_addr in
      let tlbs' := (fun ipa_state cpu gidx =>
                      if ipa_state =? IPA_STATE_PRESENT then
                        if (gidx >=? ipa_gidx) && (gidx <? ipa_gidx + 512) then -1
                        else tlbs (share adt) cpu gidx
                      else
                        if gidx =? ipa_gidx then -1
                        else tlbs (share adt) cpu gidx) in
      if (g_refcount (ginfo gn_rtt)) =? 1 then
        rely (g_refcount (ginfo gn_llt) >? 0);
        let ipa_state :=
            (if prop_dec (exists i : Z, 0 <= i < PGTES_PER_TABLE /\ PTE_TO_IPA_STATE (g_data (gnorm gn_rtt)) @ i = IPA_STATE_DESTROYED)
             then IPA_STATE_DESTROYED else IPA_STATE_VACANT)
        in
        let llt' := (g_data (gnorm gn_llt)) # idx == (IPA_STATE_TO_PTE ipa_state) in
        let gllt' := gn_llt {ginfo: (ginfo gn_llt) {g_refcount: (g_refcount (ginfo gn_llt)) - 1}}
                            {gnorm: (gnorm gn_llt) {g_data: llt'}} in
        let grtt' := gn_rtt {ginfo: (ginfo gn_rtt) {g_tag: GRANULE_STATE_DELEGATED} {g_rd: 0} {g_refcount: 0}}
                            {gnorm : zero_granule_data_normal} {grec: zero_granule_data_rec} in
        let e' := EVT CPU_ID (REL rtt_gidx (grtt' {glock: Some CPU_ID})) in
        Some (adt {log: EVT CPU_ID (REL llt_gidx gllt') :: e' :: e :: log adt}
                  {share : (share adt) {gs : ((gs (share adt)) # rtt_gidx == (grtt' {gtype: GRANULE_STATE_DELEGATED}))
                                                               # llt_gidx == (gllt' {glock: None})}
                                       {tlbs: tlbs' ipa_state}},
              VZ64 0)
      else
        if (g_refcount (ginfo gn_rtt)) =? PGTES_PER_TABLE + 1 then
          rely (level =? RTT_PAGE_LEVEL);
          let pgte := (g_data (gnorm gn_rtt)) @ 0 in
          let ipa_state := PTE_TO_IPA_STATE pgte in
          let base_pa' := __entry_to_phys pgte (level - 1) in
          let base_pa := __entry_to_phys pgte level in
          rely is_int64 base_pa;
          rely is_int64 (base_pa + PGTES_PER_TABLE * GRANULE_SIZE);
          rely (__addr_is_level_aligned base_pa (level - 1));
          rely prop_dec (forall i : Z, 0 <= i < PGTES_PER_TABLE ->
                                  let e := (g_data (gnorm gn_rtt)) @ i in
                                  let pa := __entry_to_phys e level in
                                  PTE_TO_IPA_STATE e = ipa_state /\ pa = base_pa + i * GRANULE_SIZE);
          let new_pgte := (if ipa_state =? IPA_STATE_PRESENT then Z.lor (Z.lor (IPA_STATE_TO_PTE ipa_state) base_pa') PGTE_S2_BLOCK
                           else Z.lor (IPA_STATE_TO_PTE ipa_state) base_pa') in
          let llt' := (g_data (gnorm gn_llt)) # idx == new_pgte in
          let gllt' := gn_llt {gnorm: (gnorm gn_llt) {g_data: llt'}} {glock: None} in
          let grtt' := gn_rtt {ginfo: (ginfo gn_rtt) {g_tag: GRANULE_STATE_DELEGATED} {g_rd: 0} {g_refcount: 0}}
                              {gnorm : zero_granule_data_normal} {grec: zero_granule_data_rec} in
          let e' := EVT CPU_ID (REL rtt_gidx (grtt' {glock: Some CPU_ID})) in
          Some (adt {log: EVT CPU_ID (REL llt_gidx gllt') :: e' :: e :: log adt}
                    {share : (share adt) {gs : ((gs (share adt)) # rtt_gidx == (grtt' {gtype: GRANULE_STATE_DELEGATED}))
                                                                # llt_gidx == gllt'}
                                        {tlbs: tlbs' ipa_state}},
                VZ64 0)
        else None
    else Some (adt {log: EVT CPU_ID (REL llt_gidx gn_llt {glock: Some CPU_ID}) :: log adt}, VZ64 1).

  Definition table_destroy3_spec (g_rd: Pointer) (map_addr: Z64) (rtt_addr: Z64) (level: Z64) (adt: RData) : option (RData * Z64) :=
    match map_addr, level, rtt_addr with
    | VZ64 map_addr, VZ64 level, VZ64 rtt_addr =>
      rely is_int64 map_addr; rely is_int64 rtt_addr; rely GRANULE_ALIGNED map_addr; rely is_int64 level;
      let idx0 := __addr_to_idx map_addr 0 in
      let idx1 := __addr_to_idx map_addr 1 in
      let idx2 := __addr_to_idx map_addr 2 in
      let idx3 := __addr_to_idx map_addr 3 in
      let ret_idx := (if level =? 1 then idx0 else if level =? 2 then idx1 else if level =? 3 then idx2 else idx3) in
      rely is_int64 idx0; rely is_int64 idx1; rely is_int64 idx2; rely is_int64 idx3;
      let rtt_gidx := __addr_to_gidx rtt_addr in
      rely is_gidx rtt_gidx;
      rely (peq (base g_rd) ginfo_loc);
      rely prop_dec ((buffer (priv adt)) @ SLOT_RD = None);
      rely prop_dec ((buffer (priv adt)) @ SLOT_TABLE = None);
      rely prop_dec ((buffer (priv adt)) @ SLOT_RTT2 = None);
      let rd_gidx := (offset g_rd) in
      let grd := (gs (share adt)) @ rd_gidx in
      rely (g_tag (ginfo grd) =? GRANULE_STATE_RD);
      rely prop_dec (glock grd = Some CPU_ID);
      let root_gidx := (g_rtt (gnorm grd)) in
      rely is_gidx rd_gidx;
      when adt == query_oracle adt;
      (* hold root lock *)
      rely is_gidx root_gidx;
      let groot := (gs (share adt)) @ root_gidx in
      rely (tbl_level (gaux groot) =? 0);
      rely prop_dec (glock groot = None);
      rely (g_tag (ginfo groot) =? GRANULE_STATE_TABLE);
      rely (gtype groot =? GRANULE_STATE_TABLE);
      if level =? 1 then
        (* walk until root *)
        let adt := adt {log: EVT CPU_ID (RTT_WALK root_gidx map_addr 0) :: log adt} in
        let adt :=  adt {priv: (priv adt) {wi_llt: root_gidx} {wi_index: idx0}} in
        destroy_table root_gidx idx0 rtt_addr rtt_gidx 1 map_addr adt
      else
        (* walk deeper root *)
        rely (level >? 1);
        let entry0 := (g_data (gnorm groot)) @ idx0 in
          rely is_int64 entry0;
          let phys0 := __entry_to_phys entry0 3 in
          let lv1_gidx := __addr_to_gidx phys0 in
          rely is_int64 phys0;
          if (__entry_is_table entry0) && (GRANULE_ALIGNED phys0) && (is_gidx lv1_gidx) then
            (* level 1 valid, hold level 1 lock *)
            let glv1 := (gs (share adt)) @ lv1_gidx in
            rely prop_dec (glock glv1 = None);
            rely (tbl_level (gaux glv1) =? 1);
            if level =? 2 then
              (* walk until level 1 *)
              let adt := adt {log: EVT CPU_ID (RTT_WALK root_gidx map_addr 1) :: log adt} in
              let adt :=  adt {priv: (priv adt) {wi_llt: lv1_gidx} {wi_index: idx1}} in
              destroy_table lv1_gidx idx1 rtt_addr rtt_gidx 2 map_addr adt
            else
              (* walk deeper level 1 *)
              rely (level >? 2);
              rely (g_tag (ginfo glv1) =? GRANULE_STATE_TABLE);
              rely (gtype glv1 =? GRANULE_STATE_TABLE);
              let entry1 := (g_data (gnorm glv1)) @ idx1 in
              rely is_int64 entry1;
              let phys1 := __entry_to_phys entry1 3 in
              let lv2_gidx := __addr_to_gidx phys1 in
              rely is_int64 phys1;
              if (__entry_is_table entry1) && (GRANULE_ALIGNED phys1) && (is_gidx lv2_gidx) then
                (* level 2 valid, hold level 2 lock *)
                let glv2 := (gs (share adt)) @ lv2_gidx in
                rely (tbl_level (gaux glv2) =? 2);
                rely prop_dec (glock glv2 = None);
                if level =? 3 then
                  (* walk until level 2 *)
                  let adt := adt {log: EVT CPU_ID (RTT_WALK root_gidx map_addr 2) :: log adt} in
                  let adt :=  adt {priv: (priv adt) {wi_llt: lv2_gidx} {wi_index: idx2}} in
                  destroy_table lv2_gidx idx2 rtt_addr rtt_gidx 3 map_addr adt
                else None
              else
                (* level 2 invalid *)
                rely is_int lv2_gidx;
                Some (adt {priv: (priv adt) {wi_llt: 0} {wi_index: ret_idx}}, VZ64 1)
          else
            (* level 1 invalid *)
            rely is_int lv1_gidx;
            Some (adt {priv: (priv adt) {wi_llt: 0} {wi_index: ret_idx}}, VZ64 1)
    end.

End Spec.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*              Layers of VMM                                          *)
(*                                                                     *)
(*          Refinement Proof for PQueueInit                            *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

(** This file provide the contextual refinement proof between PQueueIntro layer and PQueueInit layer*)
Require Import Coqlib.
Require Import Errors.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Op.
Require Import Asm.
Require Import Events.
Require Import Globalenvs.
Require Import Smallstep.
Require Import Values.
Require Import Memory.
Require Import Maps.
Require Import CommonTactic.
Require Import AuxLemma.
Require Import FlatMemory.
Require Import AuxStateDataType.
Require Import Constant.
Require Import GlobIdent.
Require Import RealParams.
Require Import LoadStoreSem2.
Require Import AsmImplLemma.
Require Import GenSem.
Require Import RefinementTactic.
Require Import PrimSemantics.
Require Import XOmega.

Require Import liblayers.logic.PTreeModules.
Require Import liblayers.logic.LayerLogicImpl.
Require Import liblayers.compcertx.Stencil.
Require Import liblayers.compcertx.MakeProgram.
Require Import liblayers.compat.CompatLayers.
Require Import liblayers.compat.CompatGenSem.
Require Import compcert.cfrontend.Ctypes.

Require Import LAsmModuleSemAux.
Require Import LayerCalculusLemma.
Require Import AbstractDataType.

Require Import PThreadSched.
Require Import PThread.
Require Import ThreadGenSpec.

(** * Definition of the refinement relation*)
Section Refinement.

  Local Open Scope string_scope.
  Local Open Scope error_monad_scope.
  Local Open Scope Z_scope.

  Context `{real_params: RealParams}.

  Notation HDATA := RData.
  Notation LDATA := RData.

  Notation HDATAOps := (cdata (cdata_ops := pthread_data_ops) HDATA).
  Notation LDATAOps := (cdata (cdata_ops := pthreadsched_data_ops) LDATA).

  Section WITHMEM.

    Context `{Hstencil: Stencil}.
    Context `{Hmem: Mem.MemoryModel}.
    Context `{Hmwd: UseMemWithData mem}.

    (** Relation between raw data at two layers*)
    Record relate_RData (f: meminj) (hadt: HDATA) (ladt: LDATA) :=
      mkrelate_RData {
          flatmem_re: FlatMem.flatmem_inj (HP hadt) (HP ladt);
          vmxinfo_re: vmxinfo hadt = vmxinfo ladt;
          devout_re: devout hadt = devout ladt;
          CR3_re:  CR3 hadt = CR3 ladt;
          ikern_re: ikern hadt = ikern ladt;
          pg_re: pg hadt = pg ladt;
          ihost_re: ihost hadt = ihost ladt;
          AC_re: AC hadt = AC ladt;
          ti_fst_re: (fst (ti hadt)) = (fst (ti ladt));
          ti_snd_re: val_inject f (snd (ti hadt)) (snd (ti ladt));
          LAT_re: LAT hadt = LAT ladt;
          nps_re: nps hadt = nps ladt;
          init_re: init hadt = init ladt;

          pperm_re: pperm hadt = pperm ladt;
          PT_re:  PT hadt = PT ladt;
          ptp_re: ptpool hadt = ptpool ladt;
          idpde_re: idpde hadt = idpde ladt;
          ipt_re: ipt hadt = ipt ladt;
          smspool_re: smspool hadt = smspool ladt;

          kctxt_re: kctxt_inj f num_proc (kctxt hadt) (kctxt ladt);
          abtcb_re:  abtcb hadt = abtcb ladt;
          abq_re:  abq hadt = abq ladt;
          cid_re:  cid hadt = cid ladt
        }.

    Inductive match_RData: stencil -> HDATA -> mem -> meminj -> Prop :=
    | MATCH_RDATA: forall habd m f s, match_RData s habd m f.

    Local Hint Resolve MATCH_RDATA.

    Global Instance rel_ops: CompatRelOps HDATAOps LDATAOps :=
      {
        relate_AbData s f d1 d2 := relate_RData f d1 d2;
        match_AbData s d1 m f := match_RData s d1 m f;
        new_glbl := nil
      }.

    (** ** Properties of relations*)
    Section Rel_Property.

      (** Prove that after taking one step, the refinement relation still holds*)
      Lemma relate_incr:
        forall abd abd' f f',
          relate_RData f abd abd'
          -> inject_incr f f'
          -> relate_RData f' abd abd'.
      Proof.
        inversion 1; subst; intros; inv H; constructor; eauto.
        - eapply kctxt_inj_incr; eauto.
      Qed.

      Lemma relate_kernel_mode:
        forall abd abd' f,
          relate_RData f abd abd'
          -> (kernel_mode abd <-> kernel_mode abd').
      Proof.
        inversion 1; simpl; split; congruence.
      Qed.

      Lemma relate_observe:
        forall p abd abd' f,
          relate_RData f abd abd' ->
          observe p abd = observe p abd'.
      Proof.
        inversion 1; simpl; unfold ObservationImpl.observe; congruence.
      Qed.

      Global Instance rel_prf: CompatRel HDATAOps LDATAOps.
      Proof.
        constructor; intros; simpl; trivial.
        eapply relate_incr; eauto.
        eapply relate_kernel_mode; eauto.
        eapply relate_observe; eauto.
      Qed.

    End Rel_Property.

    (** * Proofs the one-step forward simulations for the low level specifications*)
    Section OneStep_Forward_Relation.

      (** ** The low level specifications exist*)
      Section Exists.

        Lemma thread_yield_exist:
          forall habd habd' labd rs r' rs0 f,
            ObjThread.thread_yield_spec
              habd (Pregmap.init Vundef)#ESP <- (rs#ESP)#EDI <- (rs#EDI)#ESI <- (rs#ESI)
              #EBX <- (rs#EBX)#EBP <- (rs#EBP)#RA <- (rs#RA) = Some (habd', rs0)
            -> relate_RData f habd labd
            -> high_level_invariant habd
            -> (forall reg : PregEq.t,
                  val_inject f (Pregmap.get reg rs) (Pregmap.get reg r'))
            -> exists labd' r'0, thread_yield_spec
                                   labd (Pregmap.init Vundef)#ESP <- (r'#ESP)#EDI <- (r'#EDI)#ESI <- (r'#ESI)
                                   #EBX <- (r'#EBX)#EBP <- (r'#EBP)#RA <- (r'#RA) = Some (labd', r'0)
                                 /\ relate_RData f habd' labd'
                                 /\ (forall i r,
                                       ZtoPreg i = Some r -> val_inject f (rs0#r) (r'0#r)).
        Proof.
          Opaque remove.
          unfold ObjThread.thread_yield_spec, thread_yield_spec; intros until f.
          intros HP HR HINV HVL; pose proof HR as HR'; inv HR; revert HP.
          specialize (valid_TDQ _ HINV).
          specialize (correct_curid _ HINV).
          simpl; subrewrite'; intros Hcid' Hlast HQ.
          destruct (pg labd); contra_inv.
          destruct (Hcid' refl_equal) as [_ Hcid].
          rewrite Hcid.
          assert (HOS: 0<= num_chan <= num_chan) by omega.
          specialize (Hlast refl_equal _ HOS).
          subdestruct; contra_inv; simpl.
          inv HQ. refine_split'; eauto 1.
          - inv HR'. econstructor; eauto 1.
            simpl; kctxt_inj_simpl.
          - unfold kctxt_inj, Pregmap.get in *.
            intros. eapply kctxt_re0; eauto.
            destruct Hlast as [l0[HT Hlast]]. inv HT.
            apply Hlast. apply last_correct; auto.
        Qed.

        Lemma thread_sleep_exist:
          forall habd habd' labd rs r' rs0 n f,
            ObjThread.thread_sleep_spec
              habd (Pregmap.init Vundef)#ESP <- (rs#ESP)#EDI <- (rs#EDI)#ESI <- (rs#ESI)
              #EBX <- (rs#EBX)#EBP <- (rs#EBP)#RA <- (rs#RA) n = Some (habd', rs0)
            -> relate_RData f habd labd
            -> high_level_invariant habd
            -> (forall reg : PregEq.t,
                  val_inject f (Pregmap.get reg rs) (Pregmap.get reg r'))
            -> exists labd' r'0, thread_sleep_spec
                                   labd (Pregmap.init Vundef)#ESP <- (r'#ESP)#EDI <- (r'#EDI)#ESI <- (r'#ESI)
                                   #EBX <- (r'#EBX)#EBP <- (r'#EBP)#RA <- (r'#RA) n = Some (labd', r'0)
                                 /\ relate_RData f habd' labd'
                                 /\ (forall i r,
                                       ZtoPreg i = Some r -> val_inject f (rs0#r) (r'0#r)).
        Proof.
          Opaque remove.
          unfold ObjThread.thread_sleep_spec, thread_sleep_spec; intros until f.
          intros HP HR HINV HVL; pose proof HR as HR'; inv HR; revert HP.
          specialize (valid_TDQ _ HINV); unfold AbQCorrect.
          specialize (correct_curid _ HINV).
          simpl; subrewrite'; intros Hcid' Hlast HQ.
          destruct (pg labd); contra_inv.
          destruct (Hcid' refl_equal) as [_ Hcid].
          rewrite Hcid.
          assert (HOS: 0<= num_chan <= num_chan) by omega.
          specialize (Hlast refl_equal _ HOS).
          subdestruct; simpl.
          inv HQ. refine_split'; eauto 1.
          - inv HR'.  econstructor; simpl; eauto 2.
            kctxt_inj_simpl.
          - unfold kctxt_inj, Pregmap.get in *.
            intros. eapply kctxt_re0; eauto.
            destruct Hlast as [l0'[HT Hlast]]. inv HT.
            apply Hlast. apply last_correct; auto.
        Qed.

      End Exists.

      Section FRESH_PRIM.

        Lemma thread_yield_spec_ref:
          compatsim (crel HDATA LDATA)
                    (primcall_thread_schedule_compatsem ObjThread.thread_yield_spec (prim_ident:= thread_yield))
                    thread_yield_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          inv match_extcall_states.
          exploit thread_yield_exist; eauto 1.
          intros [labd' [r'0[HP [HM HReg]]]].
          refine_split; try econstructor; eauto.
          eapply reg_symbol_inject; eassumption.
          econstructor; eauto. constructor.
          subst rs3.
          val_inject_simpl; eapply HReg;
          apply PregToZ_correct; reflexivity.
        Qed.

        Lemma thread_sleep_spec_ref:
          compatsim (crel HDATA LDATA)
                    (primcall_thread_transfer_compatsem ObjThread.thread_sleep_spec)
                    thread_sleep_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          inv match_extcall_states.
          exploit thread_sleep_exist; eauto 1.
          intros [labd' [r'0[HP [HM HReg]]]].
          refine_split; try econstructor; eauto.
          - eapply reg_symbol_inject; eassumption.
          - exploit (extcall_args_inject (D1:= HDATAOps) (D2:= LDATAOps)); eauto.
            instantiate (3:= d1').
            apply extcall_args_with_data; eauto.
            instantiate (1:= d2).
            intros [?[? Hinv]]. inv_val_inject.
            apply extcall_args_without_data in H; eauto.
          - econstructor; eauto. constructor.
          - subst rs3.
            val_inject_simpl;
              eapply HReg; apply PregToZ_correct; reflexivity.
        Qed.

      End FRESH_PRIM.

      Section PASSTHROUGH_PRIM.

        Global Instance: (LoadStoreProp (hflatmem_store:= flatmem_store) (lflatmem_store:= flatmem_store)).
        Proof.
          accessor_prop_tac.
          - eapply flatmem_store_exists; eauto.
        Qed.

        Lemma passthrough_correct:
          sim (crel HDATA LDATA) pthread_passthrough pthreadsched.
        Proof.
          sim_oplus.
          - apply fload_sim.
          - apply fstore_sim.
          - apply flatmem_copy_sim.
          - apply vmxinfo_get_sim.
          - apply device_output_sim.
          - apply pfree_sim.
          - apply setPT_sim.
          - apply ptRead_sim.
          - apply ptResv_sim.
          - apply shared_mem_status_sim.
          - apply offer_shared_mem_sim.
          - apply get_state0_sim.
          - apply get_curid_sim.
          - apply thread_spawn_sim.
          - apply thread_wakeup_sim.
          - apply sched_init_sim.
          - apply ptin_sim.
          - apply ptout_sim.
          - apply container_get_nchildren_sim.
          - apply container_get_quota_sim.
          - apply container_get_usage_sim.
          - apply container_can_consume_sim.
          - apply alloc_sim.
          - apply trapin_sim.
          - apply trapout_sim.
          - apply hostin_sim.
          - apply hostout_sim.
          - apply trap_info_get_sim.
          - apply trap_info_ret_sim.
          - layer_sim_simpl.
            + eapply load_correct2.
            + eapply store_correct2.
        Qed.

      End PASSTHROUGH_PRIM.

    End OneStep_Forward_Relation.

  End WITHMEM.

End Refinement.