Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.functors.

Definition Empty_map {A: Empty_set → Type} : ∀ x : Empty_set, A x := λ x, match x with end.
Local Notation E := Empty_map.

Instance: Arrows Empty_set := E.
Instance: CatComp Empty_set := E.
Instance: CatId Empty_set := E.
Instance: ∀ x y, Equiv (x ⟶ y) := E.
Instance: ∀ x y, Setoid (x ⟶ y) := E.
Instance: Category Empty_set.
Proof. constructor; exact E. Qed.

Section another_category.
  Context `{Category C}.

  Global Instance: Fmap (E: _ → C) := E.

  Global Instance: Functor (E: _ → C) E.
  Proof. constructor; exact E || typeclasses eauto. Qed.
End another_category.


From RecordUpdate Require Import RecordSet.
From iris.algebra Require Import gset dfrac.
From Perennial.base_logic.lib Require Import mono_nat.

From Perennial.Helpers Require Import ListSubset.
From Perennial.program_proof Require Import disk_lib.
From Perennial.program_proof Require Import wal.invariant.

Section goose_lang.
Context `{!heapGS Σ}.
Context `{!walG Σ}.

Implicit Types (v:val) (z:Z).
Implicit Types (γ: wal_names).
Implicit Types (s: log_state.t) (memLog: list update.t) (txns: list (u64 * list update.t)).
Implicit Types (pos: u64) (txn_id: nat).

Context (P: log_state.t -> iProp Σ).
Let N := walN.
Let innerN := walN .@ "wal".
Let circN := walN .@ "circ".

Definition in_bounds γ (a: u64): iProp Σ :=
  ∃ d,
    "Hbounddisk" ∷ is_base_disk γ d ∗
    "%Hinbounds" ∷ ⌜is_Some (d !! int.Z a)⌝.

Global Instance in_bounds_persistent γ a : Persistent (in_bounds γ a) := _.

Theorem in_bounds_valid γ σ a :
  is_base_disk γ σ.(log_state.d) -∗
  in_bounds γ a -∗ ⌜is_Some (σ.(log_state.d) !! int.Z a)⌝.
Proof.
  iIntros "Hbase Hbound".
  iNamed "Hbound".
  iDestruct (is_base_disk_agree with "Hbase Hbounddisk") as %<-.
  eauto.
Qed.

(* this is more or less big_sepM_lookup_acc, but with is_installed unfolded *)
Theorem is_installed_read_lookup {γ d txns installed_lb installer_txn_id durable_txn_id} {a} :
  is_Some (d !! a) ->
  is_installed γ d txns installed_lb installer_txn_id durable_txn_id -∗
  ∃ b txn_id',
    ⌜installed_lb ≤ txn_id' ≤ durable_txn_id ∧
      apply_upds (txn_upds (take (S txn_id') txns)) d !! a = Some b⌝ ∗
     a d↦ b ∗ ⌜2 + LogSz ≤ a⌝ ∗
     (a d↦ b -∗ is_installed γ d txns installed_lb installer_txn_id durable_txn_id).
Proof.
  iIntros (Hlookup) "Hbs".
  destruct Hlookup as [b0 Hlookup].
  iNamedRestorable "Hbs".
  iDestruct (big_sepM_lookup_acc _ _ _ _ Hlookup with "Hdata") as "[Hb Hdata]".
  iApply restore_intro in "Hb".
  (* FIXME: Due to missing [IntoAnd] instances for [Restore], we cannot out [Ha_bound] into the Coq context immediately. *)
  iDestruct "Hb" as (b txn_id') "((%Hin_bounds&%Halready_installed&%Happly_upds) &Hb & Ha_bound & Hb')".
  iDestruct "Ha_bound" as "%Ha_bound".
  iDestruct (restore_elim with "Hb'") as "#Hb_restore"; iClear "Hb'".
  iExists _, txn_id'.
  iFrame "Hb".
  iSplitR.
  1: iPureIntro; eauto with lia.
  iSplitR.
  1: iPureIntro; eauto with lia.
  iIntros "Hb".
  iApply "Hbs"; iFrame.
  iApply "Hdata".
  iApply "Hb_restore".
  iFrame.
Qed.

Ltac wp_start :=
  iIntros (Φ) "Hpre HΦ";
  lazymatch goal with
  | |- context[Esnoc _ (INamed "HΦ") (▷ ?Q)%I] =>
    set (post:=Q)
  end;
  lazymatch iTypeOf "Hpre" with
  | Some (_, named _ _ ∗ _)%I => iNamed "Hpre"
  | Some (_, named _ _)%I => iNamed "Hpre"
  | _ => idtac
  end.

Lemma sliding_set_mutable_start f (σ: slidingM.t) :
  slidingM.start (set slidingM.mutable f σ) = slidingM.start σ.
Proof. by destruct σ. Qed.

Lemma is_durable_txn_bound γ cs txns diskEnd_txn_id durable_lb :
  is_durable_txn (Σ:=Σ) γ cs txns diskEnd_txn_id durable_lb -∗
  ⌜(diskEnd_txn_id < length txns)%nat⌝.
Proof.
  iNamed 1.
  iPureIntro.
  apply is_txn_bound in Hend_txn; lia.
Qed.

Theorem wp_Walog__ReadInstalled (Q: Block -> iProp Σ) l γ dinit a :
  {{{ is_wal P l γ dinit ∗
      in_bounds γ a ∗
       (∀ σ σ' b,
         ⌜wal_wf σ⌝ -∗
         ⌜relation.denote (log_read_installed a) σ σ' b⌝ -∗
         (P σ -∗ |NC={⊤ ∖↑ N}=> P σ' ∗ Q b))
   }}}
    Walog__ReadInstalled #l #a
  {{{ bl, RET slice_val bl; ∃ b, is_block bl 1 b ∗ Q b}}}.
Proof.
  iIntros (Φ) "(#Hwal & #Ha_valid & Hfupd) HΦ".
  rewrite /Walog__ReadInstalled.
  wp_pure1_credit "Hcred".
  wp_apply wp_Read_atomic.
  iDestruct "Hwal" as "[Hwal Hcirc]".
  iInv "Hwal" as (σ) "[Hinner HP]" "Hclose".
  iDestruct "Hinner" as "(>? & ? & ? & >? & >Hdisk)"; iNamed.
  iNamed "Hdisk".
  iNamed "Hdisk".
  iNamed "Hdisk".

  iDestruct (in_bounds_valid _ σ with "Hbasedisk Ha_valid") as %Hlookup.
  iDestruct (is_installed_read_lookup Hlookup with "Hinstalled") as
      (b txn_id) "(%Htxn_id&Hb&%Hbound&Hinstalled)".
  iApply ncfupd_mask_intro; first set_solver+. iIntros "HcloseE".
  iExists _; iFrame "Hb".
  iIntros "Hb".
  iMod "HcloseE" as "_".
  iSpecialize ("Hinstalled" with "Hb").
  iNamed "circ.start".
  fold innerN.
  iMod (fupd_mask_subseteq (⊤∖↑N)) as "HinnerN".
  { solve_ndisj. }
  iDestruct (is_durable_txn_bound with "circ.end") as %Hdurable_bound.

  iMod (lc_fupd_elim_later with "Hcred HP") as "HP".
  iMod ("Hfupd" $! σ σ b with "[//] [] HP") as "[HP HQ]".
  { iPureIntro.
    repeat (simpl; monad_simpl).
    exists σ txn_id.
    { econstructor; eauto; lia. }
    repeat (simpl; monad_simpl).
    destruct Htxn_id as (_&Htxn_id).
    rewrite Htxn_id.
    simpl. monad_simpl.
  }
  iMod "HinnerN" as "_".
  iFrame.
  iMod ("Hclose" with "[-HQ HΦ]") as "_".
  {
    iModIntro.
    iExists _; iFrame "HP".
    iFrame.
    iSplit; auto.
    iExists _.
    iFrame "Howncs".
    iExists _, _, _.
    iFrame "# ∗".
    auto.
  }
  iIntros "!>" (s) "Hs".
  iApply "HΦ".
  iExists _; iFrame.
  iDestruct (is_slice_to_small with "Hs") as "$".
Qed.

Lemma txn_upds_subseteq txns1 txns2 :
  txns1 ⊆ txns2 →
  txn_upds txns1 ⊆ txn_upds txns2.
Proof.
  rewrite /txn_upds => ?.
  apply concat_respects_subseteq, list_fmap_mono; auto.
Qed.

Lemma subslice_subslice_subseteq {A} (l: list A) (s1 e1 s2 e2: nat):
  s2 ≤ s1 →
  e1 ≤ e2 →
  subslice s1 e1 l ⊆ subslice s2 e2 l.
Proof.
  intros Hs_le He_le.
  apply (iffRL (elem_of_subseteq _ _)).
  intros x Hin.
  apply elem_of_list_lookup in Hin.
  destruct Hin as (i&Hin).
  apply (elem_of_list_lookup_2 _ (s1 + i - s2)).
  pose proof (subslice_lookup_bound' _ _ _ _ _ _ Hin) as Hlookup_bound.
  rewrite subslice_lookup.
  2: lia.
  replace (s2 + (s1 + i - s2))%nat with (s1 + i)%nat by lia.
  apply subslice_lookup_some in Hin.
  assumption.
Qed.

Lemma subslice_subseteq {A} (l: list A) (s1 e1: nat):
  subslice s1 e1 l ⊆ l.
Proof.
  destruct (decide (e1 ≤ length l)).
  - rewrite {2}(subslice_complete l).
    apply subslice_subslice_subseteq; auto.
    lia.
  - rewrite subslice_take_drop.
    rewrite -> take_ge by lia.
    apply drop_subseteq.
Qed.

Lemma txns_are_in_bounds E γ start txns l dinit :
  ↑walN.@"wal" ⊆ E →
  txns_are γ start txns -∗
  is_wal P l γ dinit -∗
  |NC={E}=> ⌜Forall (λ (u: update.t), ∃ b, dinit !! int.Z u.(update.addr) = Some b) (txn_upds txns)⌝.
Proof.
  iIntros (Hmask) "#Htxns_are [Hinv _]".
  iApply (ncinv_open_persistent with "Hinv"); auto.
  iIntros "Hinner".
  iDestruct "Hinner" as (σ) "[Hinner _]".
  iDestruct "Hinner" as "(>? &_ & >? &_&_& >?)"; iNamed.
  iNamed "Hdisk".
  iNamed "Hdisk".
  iModIntro.
  iDestruct (txns_are_sound with "Htxns_ctx Htxns_are") as %Hsub.
  destruct Hwf as (Haddrs_wf&_).
  rewrite /log_state.updates in Haddrs_wf.
  iPureIntro.
  apply (Forall_subset _ _ (concat σ.(log_state.txns).*2)).
  - apply concat_respects_subseteq.
    etrans; [ | eapply subslice_subseteq ].
    apply (f_equal (λ x, x.*2)) in Hsub.
    rewrite -Hsub.
    rewrite fmap_subslice //.
  - fold (txn_upds σ.(log_state.txns)).
    rewrite /addrs_wf in Haddrs_wf.
    eapply Forall_impl; eauto.
    simpl; intros.
    destruct H as [_ [b ?]].
    apply Hdaddrs_init; eauto.
Qed.

Theorem wp_installBlocks γ l dinit (d: val) q bufs_s (bufs: list update.t)
        (being_installed_start_txn_id: nat) subtxns :
  {{{ "Hbufs_s" ∷ updates_slice_frag bufs_s q bufs ∗
      "#Hwal" ∷ is_wal P l γ dinit ∗
      "%Hbufs" ∷ ⌜is_memLog_region subtxns bufs⌝ ∗
      "Halready_installed_installer" ∷ ghost_var γ.(already_installed_name) (1/2) ([]: list update.t) ∗
      "HownBeingInstalledStartTxn_installer" ∷ mono_nat_auth_own γ.(being_installed_start_txn_name) (1/2) being_installed_start_txn_id ∗
      "HownInstallerTxn_installer" ∷ ghost_var γ.(installer_txn_id_name) (1/2) (being_installed_start_txn_id + length subtxns)%nat ∗
      "#Hsubtxns" ∷ txns_are γ (S being_installed_start_txn_id) subtxns
  }}}
    installBlocks d (slice_val bufs_s)
  {{{ RET #();
      "#Hwal" ∷ is_wal P l γ dinit ∗
      "Halready_installed_installer" ∷ ghost_var γ.(already_installed_name) (1/2) (bufs) ∗
      "HownBeingInstalledStartTxn_installer" ∷ mono_nat_auth_own γ.(being_installed_start_txn_name) (1/2) being_installed_start_txn_id ∗
      "HownInstallerTxn_installer" ∷ ghost_var γ.(installer_txn_id_name) (1/2) (being_installed_start_txn_id + length subtxns)%nat
  }}}.
Proof.
  wp_start.
  wp_call.

  iMod (txns_are_in_bounds with "Hsubtxns [$]") as %Htxns_addrs; first auto.
  assert (Forall (λ u : update.t, ∃ (b: Block), dinit !! int.Z u.(update.addr) = Some b) bufs) as Hbufs_addrs.
  {
    destruct Hbufs as [Hhas Hmatch].
    eapply has_updates_addrs in Hhas.
    move: Htxns_addrs.
    change (λ u, ∃ b, dinit !! int.Z u.(update.addr) = Some b) with
      ((λ a, ∃ b, dinit !! a = Some b) ∘ (λ u, int.Z u.(update.addr))).
    intros.
    rewrite -Forall_fmap.
    apply Forall_fmap in Htxns_addrs.
    eapply Forall_subset; eauto.
  }

  iDestruct "Hbufs_s" as (bks) "(Hbks_s&Hupds)".
  rename bufs into upds.

  iDestruct (slice.is_slice_small_sz with "Hbks_s") as %Hslen.
  rewrite fmap_length in Hslen.
  iDestruct (big_sepL2_length with "Hupds") as %Hslen2.

  wp_apply (slice.wp_forSlice (fun i =>
    ("Hupds" ∷ [∗ list] uv;upd ∈ bks;upds, is_update uv q upd) ∗
      "Halready_installed_installer" ∷
        ghost_var γ.(already_installed_name) (1/2)
          (take (int.nat i) (upds)) ∗
      "HownBeingInstalledStartTxn_installer" ∷ mono_nat_auth_own γ.(being_installed_start_txn_name) (1/2) being_installed_start_txn_id ∗
      "HownInstallerTxn_installer" ∷ ghost_var γ.(installer_txn_id_name) (1/2) (being_installed_start_txn_id + length subtxns)%nat
    )%I with "[] [$Hbks_s Hupds $Halready_installed_installer $HownBeingInstalledStartTxn_installer $HownInstallerTxn_installer]").
  {
    iIntros (i buf Φₗ) "!> [HI [% %]] HΦ".
    iNamed "HI".

    rewrite list_lookup_fmap in H0.
    apply fmap_Some in H0.
    destruct H0 as [ [addr bk_s] [Hbkseq ->] ].
    list_elem upds i as u.
    iDestruct (big_sepL2_lookup_acc with "Hupds") as "[Hi Hupds]"; eauto.
    destruct u as [addr_i b_i]; simpl.
    iDestruct "Hi" as "[%Heq Hi]".
    simpl in Heq; subst.

    wp_pures.
    wp_apply util_proof.wp_DPrintf.
    wp_pures.
    wp_apply (wp_Write_atomic with "Hi").

    assert (((λ u : update.t, int.Z u.(update.addr)) <$> upds) !! int.nat i = Some (int.Z addr_i)) as Hu_lookup_map.
    1: rewrite list_lookup_fmap Hu_lookup //.
    apply elem_of_list_lookup_2 in Hu_lookup_map.
    apply elem_of_list_fmap in Hu_lookup_map.
    destruct Hu_lookup_map as (upd&(Hupd&Hupd_in)).
    apply ((iffLR (Forall_forall _ _)) Hbufs_addrs _) in Hupd_in.
    destruct Hupd_in as (binit&Hbinit).

    iDestruct "Hwal" as "[Hwal Hcircular]".
    iInv "Hwal" as (σs) "[Hinner HP]" "Hclose".
    iDestruct "Hinner" as "(>%Hwf&Hmem&>?&>?&>?&>?)"; iNamed.
    iNamed "Hdisk".
    iNamed "Hdisk".
    iNamed "Hinstalled".
    iNamed "Howninstalled".
    iNamed "Hdurable".

    iDestruct (ghost_var_agree with "Halready_installed_installer Halready_installed") as %<-.
    iDestruct (mono_nat_auth_own_agree with "HownBeingInstalledStartTxn_installer HownBeingInstalledStartTxn_walinv") as %[_ <-].
    iDestruct (ghost_var_agree with "HownInstallerTxn_installer HownInstallerTxn_walinv") as %<-.
    iMod (ghost_var_update_halves (take (S (int.nat i)) upds)
      with "Halready_installed_installer Halready_installed") as
          "[Halready_installed_installer Halready_installed]".

    apply mk_is_Some in Hbinit.
    apply Hdaddrs_init in Hbinit.
    destruct Hbinit as (b&Hbsome).

    (* we can't use is_installed_read_lookup since we need to change the already_installed set in the big_sepM *)
    iDestruct (big_sepM_lookup_acc_impl _ _ Hbsome with "Hdata") as "[Hdata Hdataclose]".
    iDestruct ("Hdataclose" $! (λ a _,
        is_dblock_with_txns σs.(log_state.d) σs.(log_state.txns)
        being_installed_start_txn_id (being_installed_start_txn_id + length subtxns)
        (take
            (S (int.nat i)) (* the only change here is incrementing this *)
            upds
        ) a
      )%I with "[]") as "Hdataclose".
    {
      (* show that new big_sepM condition holds for addresses not touched by the update *)
      iModIntro.
      iIntros (addr' b' Hb' Hneq) "Hdata".
      rewrite -Hupd in Hneq.
      iDestruct "Hdata" as (b_old txn_id') "((%Htxn_id'_bound&%Htxn_id'&%Happly_upds)&Hmapsto&%Haddr_bound)".
      rewrite /=.
      iExists _, txn_id'.
      iFrame (Haddr_bound) "∗".
      iPureIntro.
      split; first by lia.
      split; first by assumption.
      intros Hinstalled.
      erewrite take_S_r in Hinstalled; last by apply Hu_lookup.
      rewrite fmap_app in Hinstalled.
      apply elem_of_app in Hinstalled.
      destruct Hinstalled as [Hinstalled|Hinstalled].
      {
        unshelve (epose proof (Happly_upds _) as Happly_upds');
          first by intuition.
        erewrite (take_S_r upds); last by eassumption.
        rewrite app_assoc apply_upds_app /=.
        rewrite lookup_insert_ne; last by lia.
        assumption.
      }
      simpl in Hinstalled.
      apply elem_of_list_singleton in Hinstalled.
      contradiction.
    }

    iDestruct "Hdata" as (b_disk txn_id') "(%Hb_disk&Haddr_i_mapsto&%Haddr_LogSz_bound)".
    iExists _.
    rewrite -Hupd.
    iFrame "Haddr_i_mapsto".
    iApply ncfupd_mask_intro; first set_solver+.
    iIntros "HcloseE /= Haddr_i_mapsto".
    iMod "HcloseE" as "_".
    iDestruct (txns_are_sound with "Htxns_ctx Hsubtxns") as %Hsubtxns.

    iMod ("Hclose" with "[
      Hmem Htxns_ctx γtxns HnextDiskEnd_inv Howncs
      HownBeingInstalledStartTxn_walinv
      Halready_installed
      HownInstallerPos_walinv HownInstallerTxn_walinv
      HownDiskEndMem_walinv HownDiskEndMemTxn_walinv
      HownDiskEnd_walinv HownDiskEndTxn_walinv
      HP Hdataclose Haddr_i_mapsto]") as "_".
    {
      iIntros "!>".
      iExists _.
      iFrame (Hwf) "Hmem Htxns_ctx γtxns HnextDiskEnd_inv HP".
      iExists _.
      iFrame "Howncs".
      iExists _, _.
      iFrameNamed.
      iExists _.
      iFrame "#".
      iSplitR "
        HownInstallerPos_walinv HownInstallerTxn_walinv
        HownDiskEndMem_walinv HownDiskEndMemTxn_walinv
        HownDiskEnd_walinv HownDiskEndTxn_walinv
      ".
      2: {
        iExists _, _, _.
        iFrame "∗ %".
      }
      iExists _.
      iFrame (Hinstalled_bounds) "∗".
      iSpecialize ("Hdataclose" with "[Haddr_i_mapsto]").
      {
        (* show that the new big_sepM condition holds for address touched by the update *)
        destruct Hbufs as [Hhas Hmatch].
        pose proof (elem_of_list_lookup_2 _ _ _ Hu_lookup) as Hu_in.
        apply Hmatch in Hu_in.
        simpl in Hu_in.
        destruct Hu_in as [txn [Htxn_in Htxn_apply]].
        destruct txn as [txna txnb].
        apply elem_of_list_lookup in Htxn_in.
        destruct Htxn_in as [txni Htxn_lookup].
        iExists _, (S being_installed_start_txn_id + txni)%nat.
        rewrite -Hupd in Haddr_LogSz_bound.
        iFrame (Haddr_LogSz_bound) "∗".
        iPureIntro.
        pose proof (lookup_lt_Some _ _ _ Htxn_lookup) as Htxni_lt.
        split; first by lia.
        split.
        {
          erewrite take_S_r.
          2: {
            rewrite -Hsubtxns in Htxn_lookup.
            rewrite subslice_lookup in Htxn_lookup; last by lia.
            eassumption.
          }
          rewrite txn_upds_app apply_upds_app txn_upds_single.
          simpl in Htxn_apply.
          apply Htxn_apply.
        }
        rewrite -Hupd in Hb_disk.
        destruct Hb_disk as (_&_&Hai).
        erewrite take_S_r; last by apply Hu_lookup.
        intros Hinstalled.
        rewrite fmap_app in Hinstalled.
        apply elem_of_app in Hinstalled.
        rewrite app_assoc apply_upds_app /= lookup_insert //.
      }
      rewrite Hsubtxns.
      iFrame.
    }
    iIntros "!> Hb_i".
    iApply "HΦ".
    iFrame.
    replace (int.nat (word.add i 1)) with (S (int.nat i)); last by word.
    iFrame.
    iApply "Hupds".
    rewrite /is_update /=.
    eauto.
  }
  { rewrite /is_update.
    iApply (big_sepL2_mono with "Hupds").
    iIntros (?????) "Hb".
    destruct y2; simpl.
    iDestruct "Hb" as "[$ $]". }
  iIntros "[(?&?&?&?) Hbks_s]".
  iNamed.
  wp_pures. iModIntro. iApply "HΦ".
  rewrite take_ge; last by lia.
  by iFrame "∗ #".
Qed.

(* TODO: why do we need this here again? *)
Opaque is_sliding.

Lemma readonly_struct_field_mapsto_agree E l d f v1 v2 :
  readonly (l ↦[d :: f] v1) -∗
  readonly (l ↦[d :: f] v2) -∗
  |={E}=> ⌜v1 = v2⌝.
Proof.
  iIntros "#H1 #H2".
  iMod (readonly_load with "H1") as (q1) "Hv1".
  iMod (readonly_load with "H2") as (q2) "Hv2".
  iDestruct (struct_field_mapsto_agree with "Hv1 Hv2") as "%Hv".
  done.
Qed.

Lemma snapshot_memLog_txns_are γ l dinit log diskEnd_pos (diskEnd_txn_id: nat) (installed_txn_id_mem installer_txn_id: nat) :
  "#Hwal" ∷ is_wal P l γ dinit -∗
  "Hlinv" ∷ memLog_linv γ log diskEnd_pos diskEnd_txn_id -∗
  "HownInstallerPos_installer" ∷ (∃ (installer_pos : nat), ghost_var γ.(installer_pos_name) (1/2) installer_pos) -∗
  "HownInstallerTxn_installer" ∷ ghost_var γ.(installer_txn_id_name) (1/2) installer_txn_id -∗
  "HownInstallerPosMem_installer" ∷ (∃ (installer_pos_mem : u64), ghost_var γ.(installer_pos_mem_name) (1/2) installer_pos_mem) -∗
  "HownInstallerTxnMem_installer" ∷ (∃ (installer_txn_id_mem: nat), ghost_var γ.(installer_txn_id_mem_name) (1/2) installer_txn_id_mem) -∗
  "HownInstalledTxnMem_installer" ∷ ghost_var γ.(installed_txn_id_mem_name) (1/2) installed_txn_id_mem -∗
  "HownBeingInstalledStartTxn_installer" ∷ mono_nat_auth_own γ.(being_installed_start_txn_name) (1/2) installed_txn_id_mem -∗
  |NC={⊤}=> ∃ nextDiskEnd_txn_id txns logger_pos logger_txn_id,
    "%Hsnapshot" ∷ ⌜
      is_memLog_region
        (subslice (S installed_txn_id_mem) (S diskEnd_txn_id) txns)
        (take (slidingM.logIndex log diskEnd_pos) log.(slidingM.log))
    ⌝ ∗
    "#Hsnapshot_txns" ∷ txns_are γ (S installed_txn_id_mem) (subslice (S installed_txn_id_mem) (S diskEnd_txn_id) txns) ∗
    "Hlinv" ∷ memLog_linv_core γ log diskEnd_pos diskEnd_txn_id
                                installed_txn_id_mem nextDiskEnd_txn_id txns
                                logger_pos logger_txn_id
                                diskEnd_pos diskEnd_txn_id ∗
    "HownInstallerPos_installer" ∷ ghost_var γ.(installer_pos_name) (1/2) (int.nat diskEnd_pos) ∗
    "HownInstallerTxn_installer" ∷ ghost_var γ.(installer_txn_id_name) (1/2) diskEnd_txn_id ∗
    "HownInstallerPosMem_installer" ∷ ghost_var γ.(installer_pos_mem_name) (1/2) diskEnd_pos ∗
    "HownInstallerTxnMem_installer" ∷ ghost_var γ.(installer_txn_id_mem_name) (1/2) diskEnd_txn_id ∗
    "HownInstalledTxnMem_installer" ∷ ghost_var γ.(installed_txn_id_mem_name) (1/2) installed_txn_id_mem ∗
    "HownBeingInstalledStartTxn_installer" ∷ mono_nat_auth_own γ.(being_installed_start_txn_name) (1/2) installed_txn_id_mem.
Proof.
  iIntros.
  iNamed.
  iNamed "Hlinv".
  iNamed "Hlinv_pers".
  iNamed "HownInstallerPos_installer".
  iNamed "HownInstallerTxn_installer".
  iNamed "HownInstallerPosMem_installer".
  iNamed "HownInstallerTxnMem_installer".

  iDestruct (ghost_var_agree with
    "HownInstalledTxnMem_installer HownInstalledTxnMem_linv"
  ) as %<-.

  pose proof (is_txn_bound _ _ _ HdiskEnd_txn) as HdiskEnd_bound.
  iMod (get_txns_are _ _ _ _ _ (S installed_txn_id_mem) (S diskEnd_txn_id)
    (subslice (S installed_txn_id_mem) (S diskEnd_txn_id) txns)
    with "Howntxns Hwal") as "(#Htxns_subslice&Howntxns)"; eauto.
  { lia. }

  iDestruct "Hwal" as "[Hwal Hcircular]".
  iInv "Hwal" as (σs) "[Hinner HP]" "Hclose".
  iDestruct "Hinner" as "(>%Hwf&#Hmem&>Htxns_ctx&>γtxns&>HnextDiskEnd_inv&>Hdisk)".
  iDestruct "Hdisk" as (cs) "(Howncs&Hdisk)".
  iDestruct "Hdisk" as (??) "Hdisk".
  iNamed "Hdisk".
  iNamed "Hdurable".
  iNamed "Hinstalled".
  iNamed "Howninstalled".

  iDestruct (ghost_var_agree with
    "Howntxns γtxns"
  ) as %->.
  iDestruct (mono_nat_auth_own_agree with
    "HownBeingInstalledStartTxn_installer HownBeingInstalledStartTxn_walinv"
  ) as %[_ <-].
  iDestruct (mono_nat_auth_own_agree with "HownDiskEndMem_linv HownDiskEndMem_walinv") as %[_ <-].
  iDestruct (mono_nat_auth_own_agree with "HownDiskEndMemTxn_linv HownDiskEndMemTxn_walinv") as %[_ <-].
  iDestruct (ghost_var_agree with
    "HownInstallerTxn_installer HownInstallerTxn_walinv"
  ) as %<-.
  iMod (ghost_var_update_halves (int.nat diskEnd_pos) with
    "HownInstallerPos_installer HownInstallerPos_walinv"
  ) as "[HownInstallerPos_installer HownInstallerPos_walinv]".
  iMod (ghost_var_update_halves diskEnd_txn_id with
    "HownInstallerTxn_installer HownInstallerTxn_walinv"
  ) as "[HownInstallerTxn_installer HownInstallerTxn_walinv]".
  iMod (ghost_var_update_halves diskEnd_pos with
    "HownInstallerPosMem_installer HownInstallerPosMem_linv"
  ) as "[HownInstallerPosMem_installer HownInstallerPosMem_linv]".
  iMod (ghost_var_update_halves diskEnd_txn_id with
    "HownInstallerTxnMem_installer HownInstallerTxnMem_linv"
  ) as "[HownInstallerTxnMem_installer HownInstallerTxnMem_linv]".

  iMod ("Hclose" with "[Htxns_ctx γtxns HnextDiskEnd_inv Howncs
    HownInstallerPos_walinv HownInstallerTxn_walinv
    HownDiskEndMem_walinv HownDiskEndMemTxn_walinv
    HownDiskEnd_walinv HownDiskEndTxn_walinv
    HownBeingInstalledStartTxn_walinv
    Halready_installed Hdata
    HP]") as "_".
  {
    iNext.
    iExists _.
    iFrame "Hmem Htxns_ctx γtxns HnextDiskEnd_inv HP".
    iSplit; first by eauto.
    iExists _.
    iFrame "Howncs".
    iExists _, _, _.
    iFrame (Hdaddrs_init) "circ.start circ.end Hbasedisk".
    iSplitL "HownBeingInstalledStartTxn_walinv Halready_installed Hdata".
    2: {
      iExists _, _, _.
      iFrame "
        HownInstallerPos_walinv HownInstallerTxn_walinv
        HownDiskEndMem_walinv HownDiskEndMemTxn_walinv
        HownDiskEnd_walinv HownDiskEndTxn_walinv
      ".
      iPureIntro.
      eapply is_memLog_boundaries_move with (i:=pmwrb_des) in Hcirc_matches.
      2: reflexivity.
      split; last by lia.
      apply Hcirc_matches.
    }
    iExists _.
    iFrame "∗ #".
    iSplit.
    {
      iPureIntro.
      apply circ_matches_txns_bounds in Hcirc_matches.
      lia.
    }
    iFrame.
    iApply (big_sepM_mono with "Hdata").
    iIntros (addr blk Haddr_bound) "Hdata".
    destruct (decide (addr ∈ (∅ : gset _))).
    1: set_solver.
    iDestruct "Hdata" as (b txn_id') "(%Hb&Haddr_d&%Haddr_bound')".
    iExists b, txn_id'.
    apply circ_matches_txns_bounds in Hcirc_matches.
    iFrame "∗ %". iPureIntro. intuition eauto.
    lia.
  }

  iExists _, _, _, _.
  iFrame "HownInstallerPos_installer HownInstallerTxn_installer
    HownInstallerPosMem_installer HownInstallerTxnMem_installer
    Htxns_subslice".
  iSplitR.
  {
    iPureIntro.
    eapply (is_memLog_boundaries_region mwrb_ms mwrb_de) in Htxns.
    2: rewrite /mwrb_ms /mwrb_de; lia.
    2-3: reflexivity.
    intuition.
  }
  iFrame.
  iFrame (HdiskEnd_txn Htxnpos_bound) "#".
  iPureIntro.
  split_and!; auto with lia.
  eapply (is_memLog_boundaries_move _ _ _ mwrb_des) in Htxns.
  2: reflexivity.
  assumption.
Qed.

Lemma unify_memLog_installed_pos_mem γ log diskEnd_pos diskEnd_txn_id installed_txn_id_mem nextDiskEnd_txn_id txns logger_pos logger_txn_id installer_pos_mem installer_txn_id_mem installed_pos_mem_ext installed_txn_id_mem_ext :
  "Hlinv" ∷ memLog_linv_core γ log diskEnd_pos diskEnd_txn_id
                                installed_txn_id_mem nextDiskEnd_txn_id txns
                                logger_pos logger_txn_id
                                installer_pos_mem installer_txn_id_mem -∗
  "HownInstalledPosMem_installer" ∷ ghost_var γ.(installed_pos_mem_name) (1/2) installed_pos_mem_ext -∗
  "HownInstalledTxnMem_installer" ∷ ghost_var γ.(installed_txn_id_mem_name) (1/2) installed_txn_id_mem_ext -∗
    "Hlinv" ∷ memLog_linv_core γ log diskEnd_pos diskEnd_txn_id
                                installed_txn_id_mem nextDiskEnd_txn_id txns
                                logger_pos logger_txn_id
                                installer_pos_mem installer_txn_id_mem ∗
    "HownInstalledPosMem_installer" ∷ ghost_var γ.(installed_pos_mem_name) (1/2) log.(slidingM.start) ∗
    "HownInstalledTxnMem_installer" ∷ ghost_var γ.(installed_txn_id_mem_name) (1/2) installed_txn_id_mem ∗
    "%Hinstalled_pos_mem_eq" ∷ ⌜log.(slidingM.start) = installed_pos_mem_ext⌝ ∗
    "%Hinstalled_txn_id_mem_eq" ∷ ⌜installed_txn_id_mem = installed_txn_id_mem_ext⌝.
Proof.
  iIntros.
  iNamed.
  iNamed "Hlinv".
  iDestruct (ghost_var_agree with
    "HownInstalledPosMem_installer HownInstalledPosMem_linv"
  ) as %->.
  iDestruct (ghost_var_agree with
    "HownInstalledTxnMem_installer HownInstalledTxnMem_linv"
  ) as %->.
  iFrame "∗ # %".
  eauto.
Qed.

Lemma unify_memLog_installer_pos_mem γ log diskEnd_pos diskEnd_txn_id installed_txn_id_mem nextDiskEnd_txn_id txns logger_pos logger_txn_id installer_pos_mem installer_txn_id_mem installer_pos_mem_ext installer_txn_id_mem_ext :
  "Hlinv" ∷ memLog_linv_core γ log diskEnd_pos diskEnd_txn_id
                                installed_txn_id_mem nextDiskEnd_txn_id txns
                                logger_pos logger_txn_id
                                installer_pos_mem installer_txn_id_mem -∗
  "HownInstallerPosMem_installer" ∷ ghost_var γ.(installer_pos_mem_name) (1/2) installer_pos_mem_ext -∗
  "HownInstallerTxnMem_installer" ∷ ghost_var γ.(installer_txn_id_mem_name) (1/2) installer_txn_id_mem_ext -∗
    "Hlinv" ∷ memLog_linv_core γ log diskEnd_pos diskEnd_txn_id
                                installed_txn_id_mem nextDiskEnd_txn_id txns
                                logger_pos logger_txn_id
                                installer_pos_mem installer_txn_id_mem ∗
    "HownInstallerPosMem_installer" ∷ ghost_var γ.(installer_pos_mem_name) (1/2) installer_pos_mem ∗
    "HownInstallerTxnMem_installer" ∷ ghost_var γ.(installer_txn_id_mem_name) (1/2) installer_txn_id_mem ∗
    "%Hinstaller_pos_mem_eq" ∷ ⌜installer_pos_mem = installer_pos_mem_ext⌝ ∗
    "%Hinstaller_txn_id_mem_eq" ∷ ⌜installer_txn_id_mem = installer_txn_id_mem_ext⌝.
Proof.
  iIntros.
  iNamed.
  iNamed "Hlinv".
  iDestruct (ghost_var_agree with
    "HownInstallerPosMem_installer HownInstallerPosMem_linv"
  ) as %->.
  iDestruct (ghost_var_agree with
    "HownInstallerTxnMem_installer HownInstallerTxnMem_linv"
  ) as %->.
  iFrame "∗ # %".
  eauto.
Qed.

Lemma unify_memLog_txns γ log diskEnd_pos diskEnd_txn_id installed_txn_id_mem nextDiskEnd_txn_id txns logger_pos logger_txn_id installer_pos_mem installer_txn_id_mem txns_ext :
  "Hlinv" ∷ memLog_linv_core γ log diskEnd_pos diskEnd_txn_id
                                installed_txn_id_mem nextDiskEnd_txn_id txns
                                logger_pos logger_txn_id
                                installer_pos_mem installer_txn_id_mem -∗
  "γtxns"  ∷ ghost_var γ.(txns_name) (1/2) txns_ext -∗
    "Hlinv" ∷ memLog_linv_core γ log diskEnd_pos diskEnd_txn_id
                                installed_txn_id_mem nextDiskEnd_txn_id txns_ext
                                logger_pos logger_txn_id
                                installer_pos_mem installer_txn_id_mem ∗
    "γtxns"  ∷ ghost_var γ.(txns_name) (1/2) txns_ext ∗
    "%Htxns_eq" ∷ ⌜txns = txns_ext⌝.
Proof.
  iIntros.
  iNamed.
  iNamed "Hlinv".
  iDestruct (ghost_var_agree with
    "Howntxns γtxns"
  ) as %<-.
  iFrame "∗ # %".
  eauto.
Qed.

Lemma unify_memLog_diskEnd_mem γ log diskEnd_pos diskEnd_txn_id installed_txn_id_mem nextDiskEnd_txn_id txns logger_pos logger_txn_id installer_pos_mem installer_txn_id_mem (diskEnd_pos_ext diskEnd_txn_id_ext: nat) :
  "Hlinv" ∷ memLog_linv_core γ log diskEnd_pos diskEnd_txn_id
                                installed_txn_id_mem nextDiskEnd_txn_id txns
                                logger_pos logger_txn_id
                                installer_pos_mem installer_txn_id_mem -∗
  "HownDiskEndMem" ∷ mono_nat_auth_own γ.(diskEnd_mem_name) (1/2/2) diskEnd_pos_ext -∗
  "HownDiskEndMemTxn" ∷ mono_nat_auth_own γ.(diskEnd_mem_txn_id_name) (1/2/2) diskEnd_txn_id_ext -∗
    "Hlinv" ∷ memLog_linv_core γ log diskEnd_pos diskEnd_txn_id
                                installed_txn_id_mem nextDiskEnd_txn_id txns
                                logger_pos logger_txn_id
                                installer_pos_mem installer_txn_id_mem ∗
    "HownDiskEndMem" ∷ mono_nat_auth_own γ.(diskEnd_mem_name) (1/2/2) (int.nat diskEnd_pos) ∗
    "HownDiskEndMemTxn" ∷ mono_nat_auth_own γ.(diskEnd_mem_txn_id_name) (1/2/2) diskEnd_txn_id ∗
    "%HdiskEnd_pos_eq" ∷ ⌜int.nat diskEnd_pos = diskEnd_pos_ext⌝ ∗
    "%HdiskEnd_txn_id_eq" ∷ ⌜diskEnd_txn_id = diskEnd_txn_id_ext⌝.
Proof.
  iIntros.
  iNamed.
  iNamed "Hlinv".
  iDestruct (mono_nat_auth_own_agree with "HownDiskEndMem_linv HownDiskEndMem" ) as %[_ HdiskEnd_pos_eq].
  iDestruct (mono_nat_auth_own_agree with "HownDiskEndMemTxn_linv HownDiskEndMemTxn" ) as %[_ HdiskEnd_txn_id_eq].
  rewrite -HdiskEnd_pos_eq -HdiskEnd_txn_id_eq.
  iFrame "∗ # %".
  eauto.
Qed.

Lemma linv_get_pers_core γ σ diskEnd_pos diskEnd_txn_id installed_txn_id_mem nextDiskEnd_txn_id txns logger_pos logger_txn_id installer_pos_mem installer_txn_id_mem :
  "Hlinv" ∷ memLog_linv_core γ σ diskEnd_pos diskEnd_txn_id
                                installed_txn_id_mem nextDiskEnd_txn_id txns
                                logger_pos logger_txn_id
                                installer_pos_mem installer_txn_id_mem -∗
  "#Hlinv_pers" ∷ memLog_linv_pers_core γ σ diskEnd_pos diskEnd_txn_id installed_txn_id_mem nextDiskEnd_txn_id txns logger_pos logger_txn_id installer_pos_mem installer_txn_id_mem.
Proof.
  iIntros "Hlinv".
  iDestruct "Hlinv" as "(#Hlinv_pers&Hlinv)".
  iFrame "Hlinv_pers".
Qed.

Reserved Notation "x ≤ y ≤ z ≤ v ≤ w"
  (at level 70, y at next level, z at next level, v at next level).
Notation "x ≤ y ≤ z ≤ v ≤ w" := (x ≤ y ∧ y ≤ z ∧ z ≤ v ∧ v ≤ w)%nat : nat_scope.

Lemma is_durable_txn_get_is_txn γ cs txns diskEnd_txn_id durable_lb :
  "#circ.end" ∷ is_durable_txn γ cs txns diskEnd_txn_id durable_lb -∗
    ∃ (diskEnd: u64), (
      "#HdiskEnd_txn" ∷ ⌜is_txn txns diskEnd_txn_id diskEnd⌝ ∗
      "%HdiskEnd_val" ∷ ⌜int.Z diskEnd = circΣ.diskEnd cs⌝
    ).
Proof.
  iIntros.
  iNamed.
  iNamed "circ.end".
  iExists _.
  eauto.
Qed.

Theorem wp_Walog__logInstall γ l dinit (diskEnd_txn_id_bound: nat) σₛ :
  {{{ "#st" ∷ readonly (l ↦[Walog :: "st"] #σₛ.(wal_st)) ∗
      "#d" ∷ readonly (l ↦[Walog :: "d"] σₛ.(wal_d)) ∗
      "#memLock" ∷ readonly (l ↦[Walog :: "memLock"] #σₛ.(memLock)) ∗
      "#condInstall" ∷ readonly (l ↦[Walog :: "condInstall"] #σₛ.(condInstall)) ∗
      "#Hwal" ∷ is_wal P l γ dinit ∗
      "Hlkinv" ∷ wal_linv σₛ.(wal_st) γ ∗
      "His_locked" ∷ locked #σₛ.(memLock) ∗
      "#lk" ∷ is_lock N #σₛ.(memLock) (wal_linv σₛ.(wal_st) γ) ∗
      "#cond_install" ∷ is_cond σₛ.(condInstall) #σₛ.(memLock) ∗
      "Hinstaller" ∷ installer_inv γ
  }}}
    Walog__logInstall #l
  {{{ (blkCount installEnd:u64), RET (#blkCount, #installEnd);
      "Hlkinv" ∷ wal_linv σₛ.(wal_st) γ ∗
      "His_locked" ∷ locked #σₛ.(memLock) ∗
      "Hinstaller" ∷ installer_inv γ
  }}}.
Proof.
  wp_start.
  iNamedRestorable "Hlkinv".
  iNamedRestorable "Hfields".
  iNamed "Hfield_ptsto".

  iNamed "HdiskEnd_circ".
  iNamed "Hstart_circ".

  iMod (is_wal_read_mem with "Hwal") as "#Hmem".
  wp_call.
  iNamed "Hmem".
  iClear "Hmem".
  iDestruct "Hstfields" as "(memLock'&d'&circ'&st'&Hstfields)".
  iMod (readonly_struct_field_mapsto_agree with "st st'") as "<-".
  iMod (readonly_struct_field_mapsto_agree with "memLock memLock'") as "<-".
  iMod (readonly_struct_field_mapsto_agree with "d d'") as "<-".

  wp_loadField.
  wp_loadField.
  wp_loadField.
  wp_loadField.

  wp_apply (wp_sliding__takeTill with "His_memLog"); first by word.
  iIntros (q s) "(His_memLog&Htxn_slice)".
  wp_pures.
  wp_apply wp_slice_len; wp_pures.
  wp_if_destruct; wp_pures.
  {
    iApply "HΦ".
    iFrame "His_locked Hinstaller".
    iExists _.
    iFrame "∗ #".
    iExists _.
    by iFrame (Hlocked_wf) "∗".
  }

  iDestruct (updates_slice_frag_len with "Htxn_slice") as %Hs_len.
  rewrite take_length_le in Hs_len.
  2: {
    rewrite /locked_wf /slidingM.wf in Hlocked_wf.
    rewrite /slidingM.logIndex.
    lia.
  }
  assert (int.Z s.(Slice.sz) ≠ int.Z 0) as HdiskEnd_neq.
  {
    intros Hcontradiction.
    apply (inj int.Z) in Hcontradiction.
    assert (#s.(Slice.sz) = #0) as Hcontradiction'
      by (f_equal; f_equal; apply Hcontradiction).
    contradiction.
  }
  rewrite Hs_len in HdiskEnd_neq.
  replace (int.Z 0) with 0 in HdiskEnd_neq by word.

  iNamed "Hinstaller".
  iMod (snapshot_memLog_txns_are with "Hwal HmemLog_linv
    HownInstallerPos_installer HownInstallerTxn_installer
    HownInstallerPosMem_installer HownInstallerTxnMem_installer
    HownInstalledTxnMem_installer HownBeingInstalledStartTxn_installer"
  ) as (nextDiskEnd_txn_id txns logger_pos logger_txn_id) "Hsnapshot".
  iNamed "Hsnapshot".
  iNamed "HownInstalledPosMem_installer".
  iDestruct (unify_memLog_installed_pos_mem with
    "Hlinv HownInstalledPosMem_installer HownInstalledTxnMem_installer")
    as "Hunify".
  iNamed "Hunify".
  subst installed_pos_mem.
  iMod (thread_own_get with "Hstart_exactly HnotInstalling") as "(Hstart_exactly&Hstart_is&Hinstalling)".

  (* vvv TODO: factor this out into a lemma vvv *)

  iDestruct "Hwal" as "[Hwal Hcircular]".
  rewrite -ncfupd_wp.
  iInv "Hwal" as (σs) "[Hinner HP]" "Hclose".
  iDestruct "Hinner" as "(>%Hwf&#Hmem&>Htxns_ctx&>γtxns&>HnextDiskEnd_inv&>Hdisk)".
  iDestruct "Hdisk" as (cs) "(Howncs&Hdisk)".
  iDestruct "Hdisk" as (??) "Hdisk".
  iNamed "Hdisk".
  iNamed "Hinstalled".

  iDestruct (unify_memLog_txns with "Hlinv γtxns") as "(Hlinv&γtxns&->)".
  iDestruct (linv_get_pers_core with "Hlinv") as "#Hlinv_pers".
  iDestruct "Hlinv_pers" as "(?&?&?&?&?&?&?&?&?)".
  iNamed.
  iNamed "Howninstalled".
  iDestruct (ghost_var_agree with "Halready_installed_installer Halready_installed") as %<-.
  iDestruct (mono_nat_auth_own_agree with "HownBeingInstalledStartTxn_installer HownBeingInstalledStartTxn_walinv") as %[_ <-].
  iNamed "Hdurable".
  iDestruct (unify_memLog_diskEnd_mem with "Hlinv HownDiskEndMem_walinv HownDiskEndMemTxn_walinv")
    as "(Hlinv&HownDiskEndMem_walinv&HownDiskEndMemTxn_walinv&%HdiskEnd_pos_eq&%HdiskEnd_txn_id_eq)".
  subst diskEnd_mem diskEnd_mem_txn_id.
  iDestruct (mono_nat_lb_own_get with "HownDiskEndMem_walinv") as "#HownDiskEndMem_lb".
  iDestruct (mono_nat_lb_own_valid with "HownDiskEndMemTxn_walinv HdiskEndMem_lb_installer") as %[_ HdiskEndMemTxn_lb].
  iDestruct (mono_nat_lb_own_get with "HownDiskEndMemTxn_walinv") as "#HdiskEndMem_lb".

  pose proof (is_txn_bound _ _ _ HdiskEnd_txn) as HdiskEnd_mem_bound.
  rewrite /is_txn in HdiskEnd_txn.
  destruct (σs.(log_state.txns) !! σ.(locked_diskEnd_txn_id)) as [diskEnd_txn|] eqn:HdiskEnd_txn_eq.
  2: simpl in HdiskEnd_txn; inversion HdiskEnd_txn.
  destruct diskEnd_txn as (upd_pos&upds).
  simpl in HdiskEnd_txn.
  inversion HdiskEnd_txn as (HdiskEnd_txn_inv).
  rewrite HdiskEnd_txn_inv in HdiskEnd_txn_eq.
  iDestruct (txns_ctx_complete _ _ _ _ HdiskEnd_txn_eq with "Htxns_ctx") as "#HdiskEnd_txn_val".

  iMod ("Hclose" with "[Htxns_ctx γtxns HnextDiskEnd_inv Howncs
    HownInstallerPos_walinv HownInstallerTxn_walinv
    HownDiskEndMem_walinv HownDiskEndMemTxn_walinv
    HownDiskEnd_walinv HownDiskEndTxn_walinv
    HownBeingInstalledStartTxn_walinv
    Halready_installed Hdata HP]") as "_".
  {
    iExists _.
    iFrame "Hmem Htxns_ctx γtxns HnextDiskEnd_inv HP".
    iSplit; first by intuition.
    iExists _.
    iFrame "Howncs".
    iExists _, _.
    iFrameNamed.
    iExists _.
    iFrame "circ.end".
    iSplitR "
      HownInstallerPos_walinv HownInstallerTxn_walinv
      HownDiskEndMem_walinv HownDiskEndMemTxn_walinv
      HownDiskEnd_walinv HownDiskEndTxn_walinv
    ".
    2: {
      iExists _, _, _.
      iFrame.
      iPureIntro.
      eauto.
    }
    iExists _.
    iFrame "∗ #".
    iPureIntro.
    apply circ_matches_txns_bounds in Hcirc_matches.
    lia.
  }

  (* ^^^ TODO: factor this out into a lemma ^^^ *)

  (* these names would be free if the above was a lemma *)
  remember σs.(log_state.txns) as txns.
  iClear "circ.start circ.end Hbasedisk Hbeing_installed_txns Hmem HinstalledTxn_lb".
  clear Heqtxns Hwf Hdaddrs_init σs Hinstalled_bounds Hcirc_matches diskEnd_txn_id installer_pos cs Hlog_wf.

  iModIntro.
  wp_loadField.
  wp_apply (release_spec with "[$lk $His_locked Hlinv
    HdiskEnd_exactly Hstart_exactly
    His_memLog HmemLog HdiskEnd Hshutdown Hnthread]").
  {
    iNext.
    iApply "Hlkinv"; iFrameNamed.
    iSplitL "Hlinv".
    {
      iExists _, _, _, _, _, _, _.
      iFrame "Hlinv".
    }
    iSplitL "Hstart_exactly"; first by iFrame.
    iSplitL "HdiskEnd_exactly"; first by iFrame.
    iApply "Hfields"; iFrameNamed.
  }
  iClear (Hlocked_wf) "Hlkinv Hfields Hstart_at_least".
  wp_pures.
  wp_apply util_proof.wp_DPrintf.
  wp_pures.
  wp_loadField.

  wp_apply (wp_installBlocks with "[
    $Halready_installed_installer $HownBeingInstalledStartTxn_installer
    HownInstallerTxn_installer
    $Htxn_slice
    $Hwal $Hcircular
  ]").
  {
    iFrame (Hsnapshot) "Hsnapshot_txns".
    rewrite -> subslice_length by lia.
    iExactEq "HownInstallerTxn_installer".
    rewrite /named.
    auto with f_equal lia.
  }

  iIntros "(_&Halready_installed_installer&HownBeingInstalledStartTxn_installer&HownInstallerTxn_installer)".
  rewrite -> subslice_length by lia.
  replace (installed_txn_id_mem + (S σ.(locked_diskEnd_txn_id) - (S installed_txn_id_mem)))%nat
    with σ.(locked_diskEnd_txn_id) by lia.

  wp_apply wp_Barrier.
  wp_loadField.

  wp_apply (wp_circular__Advance _ _ (
      "HownInstallerPos_installer" ∷
        ghost_var γ.(installer_pos_name) (1/2)
          (int.nat σ.(diskEnd)) ∗
      "HownInstallerTxn_installer" ∷
        ghost_var γ.(installer_txn_id_name) (1/2)
          σ.(locked_diskEnd_txn_id) ∗
      "HownBeingInstalledStartTxn_installer" ∷
        mono_nat_auth_own γ.(being_installed_start_txn_name) (1/2)
          σ.(locked_diskEnd_txn_id) ∗
      "Halready_installed_installer" ∷
        ghost_var γ.(already_installed_name) (1/2) ([]: list update.t)
    ) with "[$Hcircular $Hstart_is $HdiskEnd_at_least
      HownInstallerPos_installer HownInstallerTxn_installer
      HownBeingInstalledStartTxn_installer
      Halready_installed_installer]").
  {
    iSplit.
    1: iPureIntro; lia.
    iIntros (σc) "(%Hcirc_wf&Hcirc_ctx&%Hstart)".
    iIntros (σc' b) "(%Hrelation&%Hcirc_wf')".
    simpl in Hrelation; monad_inv.

    iInv "Hwal" as (σs) "[Hinner HP]".
    iDestruct "Hinner" as "(>%Hwf&Hmem&>Htxns_ctx&>γtxns&>HnextDiskEnd_inv&>Hdisk)"; iNamed.
    iNamed "Hdisk".
    iNamed "Hdisk".
    rewrite /circular_pred.
    iDestruct (ghost_var_agree with "Hcirc_ctx Howncs") as %<-.
    iDestruct (txns_are_sound with "Htxns_ctx Hsnapshot_txns") as %Hsnapshot_txns_are.
    rewrite subslice_length in Hsnapshot_txns_are.
    2: lia.
    replace (installed_txn_id_mem + (S σ.(locked_diskEnd_txn_id) - installed_txn_id_mem))%nat
      with (S σ.(locked_diskEnd_txn_id)) in Hsnapshot_txns_are by lia.
    iMod (ghost_var_update_halves with "Hcirc_ctx Howncs") as "[$ Howncs]".
    iDestruct (txn_val_valid_general with "Htxns_ctx HdiskEnd_txn_val") as %HdiskEnd_txn_lookup.
    iNamed "Hdisk".
    iNamed "Hinstalled".
    iNamed "Howninstalled".
    iNamed "Hdurable".
    iDestruct (ghost_var_agree with "HownInstallerPos_installer HownInstallerPos_walinv") as %<-.
    iDestruct (ghost_var_agree with "HownInstallerTxn_installer HownInstallerTxn_walinv") as %<-.
    iDestruct (mono_nat_auth_own_agree with "HownBeingInstalledStartTxn_installer HownBeingInstalledStartTxn_walinv") as %[_ <-].
    iDestruct (ghost_var_agree with "Halready_installed_installer Halready_installed") as %<-.
    iMod (mono_nat_own_update_halves σ.(locked_diskEnd_txn_id)
      with "HownBeingInstalledStartTxn_installer HownBeingInstalledStartTxn_walinv") as
          "(HownBeingInstalledStartTxn_installer&HownBeingInstalledStartTxn_walinv&HinstalledTxn_lb')".
    1: lia.
    iMod (ghost_var_update_halves ([]: list update.t)
      with "Halready_installed_installer Halready_installed") as
          "[Halready_installed_installer Halready_installed]".
    iDestruct (txns_are_sound with "Htxns_ctx Hsnapshot_txns") as %Hsnapshot_txns.
    rewrite -> subslice_length in Hsnapshot_txns by lia.
    replace
      (S installed_txn_id_mem + (S σ.(locked_diskEnd_txn_id) - S installed_txn_id_mem))%nat
      with (S σ.(locked_diskEnd_txn_id))
      in Hsnapshot_txns by lia.
    iSplitR "HownInstallerPos_installer HownInstallerTxn_installer
      HownBeingInstalledStartTxn_installer
      Halready_installed_installer".
    2: iFrame; eauto.
    iExists _.
    iFrame (Hwf) "HP Hmem Htxns_ctx γtxns HnextDiskEnd_inv".
    iExists _; iFrame.
    iExists σ.(locked_diskEnd_txn_id), σ.(locked_diskEnd_txn_id), diskEnd_txn_id.
    iFrame (Hdaddrs_init) "Hbasedisk".
    iSplitL "HownBeingInstalledStartTxn_walinv Halready_installed Hdata".
    {
      iExists _.
      iFrame "HownBeingInstalledStartTxn_walinv Halready_installed".

      iSplitR; first by (iPureIntro; lia).
      iSplitR.
      { rewrite subslice_zero_length. iApply txns_are_nil. }
      iApply (big_sepM_impl with "Hdata").
      iIntros "!> !> !>".
      iIntros (addr x Hx) "Hdata".
      iDestruct "Hdata" as (b txn_id') "(%Htxn_id'&Hb&%Haddr_bound)".
      iExists _, σ.(locked_diskEnd_txn_id).
      iFrame (Haddr_bound) "Hb".
      iPureIntro.
      split; first by lia.
      split.
      2: {
        intros Hin.
        inversion Hin.
      }
      destruct Htxn_id' as (Htxn_id'&Hb&Haddr).
      rewrite -Nat.le_add_sub in Hsnapshot_txns_are; last by lia.
      destruct Hsnapshot as [Hhas Hmatch].
      destruct (decide (
        addr ∈ (
          (λ u, int.Z u.(update.addr)) <$>
            take (slidingM.logIndex σ.(memLog) σ.(diskEnd))
              σ.(memLog).(slidingM.log)
        )
      )) as [Haddr_in_txn|Haddr_in_txn].
      {
        unshelve (epose proof (Haddr _) as Happly); first by intuition.
        rewrite apply_upds_app in Happly.
        rewrite Hhas in Happly.
        rewrite -apply_upds_app -txn_upds_app
          -Hsnapshot_txns_are subslice_from_take
          subslice_app_contig in Happly; last by lia.
        rewrite -subslice_from_take in Happly.
        assumption.
      }

      replace (take (S σ.(locked_diskEnd_txn_id)) σs.(log_state.txns))
        with (take (S txn_id') σs.(log_state.txns) ++
          subslice (S txn_id') (S σ.(locked_diskEnd_txn_id)) σs.(log_state.txns)).
      2: {
        rewrite -subslice_from_start subslice_app_contig.
        2: lia.
        rewrite subslice_from_start //.
      }
      rewrite txn_upds_app apply_upds_app apply_upds_notin'.
      1: apply Hb.
      intros Haddr_in_txn'.
      apply Haddr_in_txn.
      apply equiv_upds_addrs_eq in Hhas.
      eapply (@elem_of_list_to_set _ (gset Z) _ _ _ _);
        first by apply gset_semi_set.
      eapply (@elem_of_list_to_set _ (gset Z) _ _ _ _) in Haddr_in_txn';
        last by apply gset_semi_set.
      rewrite -Hhas.
      rewrite -Hsnapshot_txns.
      erewrite <- subslice_app_contig.
      {
        rewrite txn_upds_app fmap_app list_to_set_app.
        apply elem_of_union_r.
        apply Haddr_in_txn'.
      }
      lia.
    }

    rewrite /circ_matches_txns /= in Hcirc_matches.

    iSplitL.
    {
      iExists _, _, _.
      iFrame.
      rewrite /circΣ.diskEnd /= drop_length.
      replace (Z.to_nat (int.Z σ.(diskEnd) - int.Z (start σc)))
        with (int.nat σ.(diskEnd) - int.nat (start σc))%nat by word.
      replace (int.Z σ.(diskEnd) + _)
        with (int.Z (start σc) + length (circ_proof.upds σc)).
      2: {
        eapply (is_memLog_boundaries_region pmwrb_des pmwrb_pe)
          in Hcirc_matches.
        2: rewrite /pmwrb_des /pmwrb_pe; lia.
        2-3: reflexivity.
        simpl in Hcirc_matches.
        rewrite -Hstart in Hlog_index_ordering.
        word.
      }
      iFrame.

      iPureIntro.
      split; last by lia.
      rewrite /circ_matches_txns /=.
      rewrite Nat.sub_diag.
      eapply (is_memLog_boundaries_move _ _ _ pmwrb_ps) in Hcirc_matches.
      2: reflexivity.
      eapply is_memLog_boundaries_drop_upds in Hcirc_matches.
      2: reflexivity.
      simpl in Hcirc_matches.
      rewrite Nat.sub_diag in Hcirc_matches.
      replace (diskEnd_mem - _ - _)%nat with
        (diskEnd_mem - int.nat σ.(diskEnd))%nat
        in Hcirc_matches.
      2: {
        assert (int.nat σ.(diskEnd) ≥ int.nat (start σc))%nat.
        {
          rewrite Hstart.
          lia.
        }
        lia.
      }
      rewrite drop_length.
      assumption.
    }
    iSplitL.
    2: {
      iDestruct "circ.end" as (diskEnd_disk durable_lb_alt) "circ.end".
      iNamed "circ.end".
      iExists diskEnd_disk, durable_lb_alt.
      iFrame (
        Hdurable_lb Hdurable_lb_valid Hdurable_nils
        Hdurable_lb_pos Hend_txn
      ) "#".
      iPureIntro.
      rewrite /circΣ.diskEnd /= drop_length.
      replace (Z.to_nat (int.Z σ.(diskEnd) - int.Z (start σc)))
        with (int.nat σ.(diskEnd) - int.nat (start σc))%nat by word.
      rewrite /circΣ.diskEnd /= in HdiskEnd_val.
      assert (int.nat σ.(diskEnd) ≥ int.nat (start σc)).
      {
        rewrite Hstart.
        lia.
      }
      eapply (is_memLog_boundaries_region pmwrb_des pmwrb_pe)
        in Hcirc_matches.
      2: rewrite /pmwrb_des /pmwrb_pe; lia.
      2-3: reflexivity.
      simpl in Hcirc_matches.
      word.
    }
    iNamed "circ.start".
    rewrite /is_installed_txn /=.
    iFrame "HdiskEnd_stable".
    iSplitR.
    1: iPureIntro; lia.
    iPureIntro.
    replace (S installed_txn_id_mem + (S σ.(locked_diskEnd_txn_id) - S installed_txn_id_mem))%nat
      with (S σ.(locked_diskEnd_txn_id)) in Hsnapshot_txns_are by lia.
    rewrite /is_txn HdiskEnd_txn_lookup //.
  }
  iIntros "(Hpost&Hstart_is)".
  iNamed "Hpost".

  wp_loadField.
  wp_apply (acquire_spec with "lk").
  iIntros "(His_locked&Hlkinv)".

  iDestruct "Hlkinv" as (σ') "Hlkinv".
  iNamedRestorable "Hlkinv".
  iNamed "Hfields".
  iNamed "Hfield_ptsto".

  wp_loadField.
  wp_call.
  wp_loadField.

  iDestruct "HmemLog_linv" as (installed_txn_id_mem' nextDiskEnd_txn_id' txns' logger_pos' logger_txn_id' installer_pos_mem' installer_txn_id_mem') "Hlinv".
  iDestruct (unify_memLog_installed_pos_mem with
    "Hlinv HownInstalledPosMem_installer HownInstalledTxnMem_installer")
    as "(Hlinv&HownInstalledPosMem_installer&HownInstalledTxnMem_installer&%Hinstalled_pos_mem_eq&->)".
  iDestruct (unify_memLog_installer_pos_mem with
    "Hlinv HownInstallerPosMem_installer HownInstallerTxnMem_installer")
    as "(Hlinv&HownInstallerPosMem_installer&HownInstallerTxnMem_installer&->&->)".
  iDestruct "Hlinv" as "(#Hlinv_pers&Howntxns&HnextDiskEnd&Hγ)".
  iNamed "Hγ".
  iDestruct "Hlinv_pers" as "(%Hlog_index_ordering'&%Htxn_id_ordering'&#HmemStart_txn'&%HdiskEnd_txn'&#HdiskEnd_stable'&#HmemEnd_txn'&#HinstalledTxn_lb'&%Htxns'&%Htxnpos_bound')".
  iMod (ghost_var_update_halves σ.(diskEnd)
    with "HownInstalledPosMem_installer HownInstalledPosMem_linv") as
        "[HownInstalledPosMem_installer HownInstalledPosMem_linv]".
  iMod (ghost_var_update_halves σ.(locked_diskEnd_txn_id)
    with "HownInstalledTxnMem_installer HownInstalledTxnMem_linv") as
        "[HownInstalledTxnMem_installer HownInstalledTxnMem_linv]".
  iNamed "Hstart_circ".
  iDestruct (start_is_to_at_least with "Hstart_is") as "#Hstart_at_least'".
  iMod (thread_own_put with "Hstart_exactly Hinstalling Hstart_is")
    as "[Hstart_exactly HnotInstalling]".
  iDestruct (mono_nat_lb_own_valid with "HownDiskEndMem_linv HownDiskEndMem_lb") as %HdiskEnd_lb.
  iDestruct (mono_nat_lb_own_get with "HownBeingInstalledStartTxn_installer") as "#HinstalledTxn_lb".

  wp_apply (wp_sliding__deleteFrom with "His_memLog").
  1: lia.
  iIntros "His_memLog".
  wp_loadField.
  wp_apply (wp_condBroadcast with "cond_install").
  wp_pures.

  iApply "HΦ".
  iFrame "His_locked".
  iSplitR "HownBeingInstalledStartTxn_installer
    Halready_installed_installer
    HdiskEndMem_lb_installer
    HownInstalledPosMem_installer HownInstalledTxnMem_installer
    HownInstallerPosMem_installer HownInstallerTxnMem_installer
    HownInstallerPos_installer HownInstallerTxn_installer
    HnotInstalling".
  2: {
    iExists _, _. iModIntro.
    iFrame "HdiskEndMem_lb ∗".
    iSplitL "HownInstallerPos_installer".
    1: iExists _; by iFrame.
    iSplitL "HownInstallerPosMem_installer".
    1: iExists _; by iFrame.
    iSplitL "HownInstallerTxnMem_installer".
    1: iExists _; by iFrame.
    1: iExists _; by iFrame.
  }
  iExists {|
    diskEnd := σ'.(diskEnd);
    locked_diskEnd_txn_id := σ'.(locked_diskEnd_txn_id);
    memLog := (set slidingM.start (λ _ : u64, σ.(diskEnd))
      (set slidingM.log
        (drop (slidingM.logIndex σ'.(memLog) σ.(diskEnd)))
          σ'.(memLog)))
  |}.
  simpl.
  iSplitL "His_memLog HmemLog HdiskEnd Hshutdown Hnthread".
  {
    iExists _.
    simpl.
    iFrame.
    iPureIntro.
    rewrite /locked_wf /=.
    split; first by lia.
    rewrite /slidingM.wf /= drop_length.
    destruct Hlocked_wf as (Hlocked_wf_bound&Hsliding_wf).
    rewrite /slidingM.wf in Hsliding_wf.
    rewrite /slidingM.logIndex.
    word.
  }
  iFrame "HdiskEnd_circ Hstart_exactly Hstart_at_least'".
  iExists _, _, _, _, _, _, _.
  iFrame. iModIntro.
  iSplit.
  {
    iPureIntro.
    destruct σ'.
    simpl.
    simpl in Hlog_index_ordering'.
    lia.
  }
  simpl.
  iSplit.
  1: iPureIntro; lia.
  iDestruct (txn_val_to_pos with "HdiskEnd_txn_val") as "HdiskEnd_txn_pos".
  iFrame (HdiskEnd_txn') "HdiskEnd_stable' HdiskEnd_txn_pos HinstalledTxn_lb".

  destruct σ'.
  rewrite /memLog_linv_txns /= /slidingM.logIndex.
  destruct memLog.
  rewrite /slidingM.endPos /slidingM.memEnd /=.
  simpl in *.
  rewrite /locked_wf /slidingM.wf /= in Hlocked_wf.

  iSplit.
  {
    rewrite drop_length.
    replace (word.add σ.(invariant.diskEnd)
      (length log - (int.nat σ.(invariant.diskEnd) - int.nat start))%nat)
      with (word.add start (length log)).
    2: apply (inj int.Z); word.
    iFrame "HmemEnd_txn'".
  }

  iSplit.
  2: {
    iPureIntro.
    rewrite drop_length.
    replace (int.Z σ.(invariant.diskEnd) +
        (length log - (int.nat σ.(invariant.diskEnd) - int.nat start))%nat)
      with (int.Z start + length log) by word.
    apply Htxnpos_bound'.
  }

  iPureIntro.
  rewrite /memLog_linv_txns /slidingM.logIndex /mwrb.logend /= in Htxns'.
  rewrite /mwrb.logend /=.
  eapply (is_memLog_boundaries_move _ _ _ mwrb_ms) in Htxns'.
  2: reflexivity.
  eapply is_memLog_boundaries_drop_upds in Htxns'.
  2: reflexivity.
  simpl in Htxns'.
  rewrite Nat.sub_diag in Htxns'.
  replace (int.nat diskEnd - int.nat start -
    (int.nat σ.(invariant.diskEnd) - int.nat start))%nat
    with (int.nat diskEnd - int.nat σ.(invariant.diskEnd))%nat
    in Htxns' by lia.
  replace (int.nat logger_pos' - int.nat start -
    (int.nat σ.(invariant.diskEnd) - int.nat start))%nat
    with (int.nat logger_pos' - int.nat σ.(invariant.diskEnd))%nat
    in Htxns' by lia.
  replace (int.nat mutable - int.nat start -
    (int.nat σ.(invariant.diskEnd) - int.nat start))%nat
    with (int.nat mutable - int.nat σ.(invariant.diskEnd))%nat
    in Htxns' by lia.
  rewrite drop_length Nat.sub_diag.
  by apply Htxns'.
Qed.

Theorem wp_Walog__installer γ l dinit :
  {{{ "#Hwal" ∷ is_wal P l γ dinit ∗
      "Hinstaller" ∷ installer_inv γ }}}
    Walog__installer #l
  {{{ RET #(); True }}}.
Proof.
  wp_start.
  iMod (is_wal_read_mem with "Hwal") as "#Hmem".
  wp_call.
  iNamed "Hmem".
  iNamed "Hstfields".
  wp_loadField.
  wp_apply (acquire_spec with "lk").
  iIntros "[Hlocked Hlockinv]".
  wp_apply (wp_inc_nthread with "[$Hlockinv $st]"); iIntros "Hlockinv".
  wp_pures.
  wp_bind (For _ _ _).
  wp_apply (wp_forBreak_cond (fun _ =>
    "Hlockinv" ∷ wal_linv σₛ.(wal_st) γ ∗
    "Hlocked" ∷ locked #σₛ.(memLock) ∗
    "Hinstaller" ∷ installer_inv γ
  )%I with "[] [$Hlocked $Hlockinv $Hinstaller]").
  { clear post Φ.
    iIntros "!>" (Φ) "I HΦ"; iNamed "I".
    wp_apply (wp_load_shutdown with "[$st $Hlockinv]"); iIntros (shutdown) "Hlockinv".
    wp_pures.
    wp_if_destruct.
    - wp_pures.
      wp_apply (wp_Walog__logInstall with "[$Hwal $st $d $lk $memlock $condInstall $cond_install $Hlocked $Hlockinv $Hinstaller]").
      1: apply 0%nat.
      iIntros (blkCount installEnd) "post"; iNamed "post".
      wp_pures.
      wp_bind (If _ _ _).
      wp_if_destruct.
      { wp_apply util_proof.wp_DPrintf; wp_pures.
        iApply ("HΦ" with "[$]"). }
      wp_loadField.
      wp_apply (wp_condWait with "[$cond_install $lk $His_locked $Hlkinv]").
      iIntros "[His_locked Hlkinv]".
      wp_pures.
      iApply ("HΦ" with "[$]").
    - iApply ("HΦ" with "[$]"). }
  iIntros "I"; iNamed "I".
  wp_apply util_proof.wp_DPrintf.
  wp_apply (wp_dec_nthread with "[$Hlockinv $st]"); iIntros "Hlockinv".
  wp_loadField.
  wp_apply (wp_condSignal with "[$cond_shut]").
  wp_loadField.
  wp_apply (release_spec with "[$lk $Hlocked $Hlockinv]").
  wp_pures. by iApply ("HΦ" with "[$]").
Qed.

End goose_lang.


From iris.proofmode Require Import proofmode.
From lrust.lang Require Import heap.
From lrust.typing Require Export type.
From lrust.typing Require Import util lft_contexts type_context programs.
From iris.prelude Require Import options.

Section uniq_bor.
  Context `{!typeGS Σ}.

  Program Definition uniq_bor (κ:lft) (ty:type) :=
    {| ty_size := 1;
       ty_own tid vl :=
         match vl return _ with
         | [ #(LitLoc l) ] => &{κ} (l ↦∗: ty.(ty_own) tid)
         | _ => False
         end;
       ty_shr κ' tid l :=
         ∃ l':loc, &frac{κ'}(λ q', l ↦{q'} #l') ∗
           □ ∀ F q, ⌜↑shrN ∪ ↑lftN ⊆ F⌝ -∗ q.[κ⊓κ']
               ={F}[F∖↑shrN]▷=∗ ty.(ty_shr) (κ⊓κ') tid l' ∗ q.[κ⊓κ']
    |}%I.
  Next Obligation. by iIntros (q ty tid [|[[]|][]]) "H". Qed.
  Next Obligation.
    move=> κ ty N κ' l tid ??/=. iIntros "#LFT Hshr Htok".
    iMod (bor_exists with "LFT Hshr") as ([|[[|l'|]|][]]) "Hb"; first solve_ndisj;
      (iMod (bor_sep with "LFT Hb") as "[Hb1 Hb2]"; first solve_ndisj);
      try (iMod (bor_persistent with "LFT Hb2 Htok") as "[>[] _]"; solve_ndisj).
    iFrame. iExists l'. subst. rewrite heap_mapsto_vec_singleton.
    iMod (bor_fracture (λ q, l ↦{q} #l')%I with "LFT Hb1") as "$"; first solve_ndisj.
    iApply delay_sharing_nested; try done. iApply lft_incl_refl.
  Qed.
  Next Obligation.
    intros κ0 ty κ κ' tid l. iIntros "#Hκ #H".
    iDestruct "H" as (l') "[Hfb Hvs]". iAssert (κ0⊓κ' ⊑ κ0⊓κ)%I as "#Hκ0".
    { iApply lft_intersect_mono; last done. iApply lft_incl_refl. }
    iExists l'. iSplit; first by iApply (frac_bor_shorten with "[]").
    iIntros "!> %F %q % Htok". iApply (step_fupd_mask_mono F _ (F∖↑shrN)); try solve_ndisj.
    iMod (lft_incl_acc with "Hκ0 Htok") as (q') "[Htok Hclose]"; first solve_ndisj.
    iMod ("Hvs" with "[%] Htok") as "Hvs'"; first solve_ndisj. iModIntro. iNext.
    iMod "Hvs'" as "[#Hshr Htok]". iMod ("Hclose" with "Htok") as "$".
    by iApply (ty_shr_mono with "Hκ0").
  Qed.

  Global Instance uniq_bor_wf κ ty `{!TyWf ty} : TyWf (uniq_bor κ ty) :=
    { ty_lfts := [κ]; ty_wf_E := ty_wf_E ty ++ ty_outlives_E ty κ }.

  Lemma uniq_type_incl κ1 κ2 ty1 ty2 :
    κ2 ⊑ κ1 -∗
    ▷ type_equal ty1 ty2 -∗
    type_incl (uniq_bor κ1 ty1) (uniq_bor κ2 ty2).
  Proof.
    iIntros "#Hlft #Hty". iSplit; first done.
    iSplit; iModIntro.
    - iIntros (? [|[[]|][]]) "H"; try done.
      iApply (bor_shorten with "Hlft"). iApply bor_iff; last done.
      iNext. iModIntro.
      iDestruct "Hty" as "(_ & Hty & _)".
      iSplit; iIntros "H"; iDestruct "H" as (vl) "[??]";
      iExists vl; iFrame; by iApply "Hty".
    - iIntros (κ ??) "H". iAssert (κ2 ⊓ κ ⊑ κ1 ⊓ κ)%I as "#Hincl'".
      { iApply lft_intersect_mono; first done. iApply lft_incl_refl. }
      iDestruct "H" as (l') "[Hbor #Hupd]". iExists l'. iIntros "{$Hbor}!> %%% Htok".
      iMod (lft_incl_acc with "Hincl' Htok") as (q') "[Htok Hclose]"; first solve_ndisj.
      iMod ("Hupd" with "[%] Htok") as "Hupd'"; try done. iModIntro. iNext.
      iMod "Hupd'" as "[H Htok]". iMod ("Hclose" with "Htok") as "$".
      iDestruct "Hty" as "(_ & _ & Hty)".
      iApply ty_shr_mono; last by iApply "Hty".
      done.
  Qed.

  Global Instance uniq_mono E L :
    Proper (flip (lctx_lft_incl E L) ==> eqtype E L ==> subtype E L) uniq_bor.
  Proof.
    intros κ1 κ2 Hκ ty1 ty2. rewrite eqtype_unfold=>Hty. iIntros (??) "HL".
    iDestruct (Hty with "HL") as "#Hty". iDestruct (Hκ with "HL") as "#Hκ".
    iIntros "!> #HE".
    iApply uniq_type_incl.
    - iDestruct ("Hκ" with "HE") as %H.
      apply lft_incl_syn_sem in H. iApply H.
    - iNext. iApply "Hty". done.
  Qed.
  Global Instance uniq_mono_flip E L :
    Proper (lctx_lft_incl E L ==> eqtype E L ==> flip (subtype E L)) uniq_bor.
  Proof. intros ??????. apply uniq_mono; first done. by symmetry. Qed.
  Global Instance uniq_proper E L :
    Proper (lctx_lft_eq E L ==> eqtype E L ==> eqtype E L) uniq_bor.
  Proof. intros ??[]; split; by apply uniq_mono. Qed.

  Global Instance uniq_type_contractive κ : TypeContractive (uniq_bor κ).
  Proof. solve_type_proper. Qed.

  Global Instance uniq_ne κ : NonExpansive (uniq_bor κ).
  Proof. apply type_contractive_ne, _. Qed.

  Global Instance uniq_send κ ty :
    Send ty → Send (uniq_bor κ ty).
  Proof.
    iIntros (Hsend tid1 tid2 [|[[]|][]]) "H"; try done.
    iApply bor_iff; last done. iNext. iModIntro. iApply bi.equiv_iff.
    do 3 f_equiv. iSplit; iIntros "."; by iApply Hsend.
  Qed.

  Global Instance uniq_sync κ ty :
    Sync ty → Sync (uniq_bor κ ty).
  Proof.
    iIntros (Hsync κ' tid1 tid2 l) "H". iDestruct "H" as (l') "[Hm #Hshr]".
    iExists l'. iFrame "Hm". iModIntro. iIntros (F q) "% Htok".
    iMod ("Hshr" with "[] Htok") as "Hfin"; first done. iClear "Hshr".
    iModIntro. iNext. iMod "Hfin" as "[Hshr $]". iApply Hsync. done.
  Qed.
End uniq_bor.

Notation "&uniq{ κ }" := (uniq_bor κ) (format "&uniq{ κ }") : lrust_type_scope.

Section typing.
  Context `{!typeGS Σ}.

  Lemma uniq_mono' E L κ1 κ2 ty1 ty2 :
    lctx_lft_incl E L κ2 κ1 → eqtype E L ty1 ty2 →
    subtype E L (&uniq{κ1}ty1) (&uniq{κ2}ty2).
  Proof. by intros; apply uniq_mono. Qed.
  Lemma uniq_proper' E L κ1 κ2 ty1 ty2 :
    lctx_lft_eq E L κ1 κ2 → eqtype E L ty1 ty2 → eqtype E L (&uniq{κ1}ty1) (&uniq{κ2}ty2).
  Proof. by intros; apply uniq_proper. Qed.

  Lemma tctx_reborrow_uniq E L p ty κ κ' :
    lctx_lft_incl E L κ' κ →
    tctx_incl E L [p ◁ &uniq{κ}ty] [p ◁ &uniq{κ'}ty; p ◁{κ'} &uniq{κ}ty].
  Proof.
    iIntros (Hκκ' tid ??) "#LFT HE HL H". iDestruct (Hκκ' with "HL HE") as %H.
    iDestruct (lft_incl_syn_sem κ' κ H) as "Hκκ'".
    iFrame. rewrite tctx_interp_singleton tctx_interp_cons tctx_interp_singleton.
    iDestruct "H" as ([[]|]) "[% Hb]"; try done.
    iMod (rebor with "LFT Hκκ' Hb") as "[Hb Hext]"; first done. iModIntro.
    iSplitL "Hb"; iExists _; auto.
  Qed.

  Lemma tctx_extract_hasty_reborrow E L p ty ty' κ κ' T :
    lctx_lft_incl E L κ' κ → eqtype E L ty ty' →
    tctx_extract_hasty E L p (&uniq{κ'}ty) ((p ◁ &uniq{κ}ty')::T)
                       ((p ◁{κ'} &uniq{κ}ty')::T).
  Proof.
    intros. apply (tctx_incl_frame_r _ [_] [_;_]). rewrite tctx_reborrow_uniq //.
    by apply (tctx_incl_frame_r _ [_] [_]), subtype_tctx_incl, uniq_mono'.
  Qed.

  Lemma read_uniq E L κ ty :
    Copy ty → lctx_lft_alive E L κ → ⊢ typed_read E L (&uniq{κ}ty) ty (&uniq{κ}ty).
  Proof.
    rewrite typed_read_eq. iIntros (Hcopy Halive) "!>".
    iIntros ([[]|] tid F qmax qL ?) "#LFT #HE Htl HL Hown"; try done.
    iMod (Halive with "HE HL") as (q) "[Hκ Hclose]"; first solve_ndisj.
    iMod (bor_acc with "LFT Hown Hκ") as "[H↦ Hclose']"; first solve_ndisj.
    iDestruct "H↦" as (vl) "[>H↦ #Hown]".
    iDestruct (ty_size_eq with "Hown") as "#>%". iIntros "!>".
    iExists _, _, _. iSplit; first done. iFrame "∗#". iIntros "H↦".
    iMod ("Hclose'" with "[H↦]") as "[$ Htok]"; first by iExists _; iFrame.
    by iMod ("Hclose" with "Htok") as "($ & $ & $)".
  Qed.

  Lemma write_uniq E L κ ty :
    lctx_lft_alive E L κ → ⊢ typed_write E L (&uniq{κ}ty) ty (&uniq{κ}ty).
  Proof.
    rewrite typed_write_eq. iIntros (Halive) "!>".
    iIntros ([[]|] tid F qmax qL ?) "#LFT HE HL Hown"; try done.
    iMod (Halive with "HE HL") as (q) "[Htok Hclose]"; first solve_ndisj.
    iMod (bor_acc with "LFT Hown Htok") as "[H↦ Hclose']"; first solve_ndisj.
    iDestruct "H↦" as (vl) "[>H↦ Hown]". rewrite ty.(ty_size_eq).
    iDestruct "Hown" as ">%". iModIntro. iExists _, _. iSplit; first done.
    iFrame. iIntros "Hown". iDestruct "Hown" as (vl') "[H↦ Hown]".
    iMod ("Hclose'" with "[H↦ Hown]") as "[$ Htok]"; first by iExists _; iFrame.
    by iMod ("Hclose" with "Htok") as "($ & $ & $)".
  Qed.
End typing.

Global Hint Resolve uniq_mono' uniq_proper' write_uniq read_uniq : lrust_typing.
Global Hint Resolve tctx_extract_hasty_reborrow | 10 : lrust_typing.


(* * Syntax and semantics of the Jasmin source language *)

(* ** Imports and settings *)
Require Export ZArith Setoid Morphisms.
From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp Require Import word_ssrZ.
Require Import Psatz xseq.
Require Export utils array gen_map type word memory_model.
Import Utf8 ZArith.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Variant arr_access :=
  | AAdirect
  | AAscale.

Scheme Equality for arr_access.

Lemma arr_access_eq_axiom : Equality.axiom arr_access_beq.
Proof.
  move=> x y;apply:(iffP idP).
  + by apply: internal_arr_access_dec_bl.
  by apply: internal_arr_access_dec_lb.
Qed.

Definition arr_access_eqMixin     := Equality.Mixin arr_access_eq_axiom.
Canonical  arr_access_eqType      := Eval hnf in EqType arr_access arr_access_eqMixin.

Local Open Scope Z_scope.

Definition arr_size (ws:wsize) (len:positive)  :=
   (wsize_size ws * len).

Lemma arr_sizeE ws len : arr_size ws len = (wsize_size ws * len).
Proof. done. Qed.

Lemma ge0_arr_size ws len : 0 <= arr_size ws len.
Proof. rewrite arr_sizeE; have := wsize_size_pos ws; nia. Qed.

Opaque arr_size.

Definition mk_scale (aa:arr_access) ws :=
  if aa is AAscale then wsize_size ws else 1.

Module WArray.

  Record array (s:positive)  :=
    { arr_data : Mz.t u8 }.

  Definition empty (s:positive) : array s :=
    {| arr_data := Mz.empty _ |}.

  Local Notation pointer := [eqType of Z].

  (* We set the priority to 1, so that memory_model.Pointer is selected by
     default.
  *)
#[global]
  Instance PointerZ : pointer_op pointer | 1.
  Proof.
    refine {| add x y := (x + y)%Z
            ; sub x y := (x - y)%Z
            ; p_to_z x := x        |}.
    - abstract (move => /= ??; ring).
    - abstract (move => /= ???; ring).
    - abstract (move => /= ?; ring).
  Defined.

  Lemma addE x y : add x y = (x + y)%Z.
  Proof. by []. Qed.

  Lemma subE x y : sub x y = (x - y)%Z.
  Proof. by []. Qed.

  Lemma p_to_zE x : p_to_z x = x.
  Proof. by []. Qed.

  Global Opaque PointerZ.

  Section WITH_POINTER_DATA.
  Context {pd: PointerData}.

  Lemma is_align_scale (p:pointer) ws : is_align (p * mk_scale AAscale ws)%Z ws.
  Proof. by rewrite /is_align /mk_scale /= Z_mod_mult. Qed.

  Lemma arr_is_align i ws :
    is_align (wrepr Uptr i) ws = is_align i ws.
  Proof.
    by rewrite /is_align p_to_zE memory_model.p_to_zE wunsigned_repr mod_wbase_wsize_size.
  Qed.

  Section CM.
    Variable (s:positive).

    Definition in_bound (_:array s) p := (0 <=? p) && (p <? s).

    Lemma in_boundP m p : reflect (0 <= p < s) (in_bound m p).
    Proof. by apply (iffP andP); rewrite !zify. Qed.

    Definition is_init (m:array s) (i:pointer) :=
      match Mz.get m.(arr_data) i with
      | Some _ => true
      | None   => false
      end.

    Definition get8 (m:array s) (i:pointer) :=
      Let _ := assert (in_bound m i) ErrOob in
      Let _ := assert (is_init m i) ErrAddrUndef in
      ok (odflt 0%R (Mz.get m.(arr_data) i)).

    Definition set8 (m:array s) (i:pointer) (v:u8) : result _ (array s):=
      Let _ := assert (in_bound m i) ErrOob in
      ok {| arr_data := Mz.set m.(arr_data) i v |}.

    Lemma valid8P m p w : reflect (exists m', set8 m p w = ok m') (in_bound m p).
    Proof.
      by (rewrite /set8; case: in_bound => /=; constructor); [eexists; eauto | move=> []].
    Qed.

    Lemma get_valid8 m p w : get8 m p = ok w -> in_bound m p.
    Proof. by rewrite /get8; t_xrbindP. Qed.

    Lemma valid8_set m p w m' p' : set8 m p w = ok m' -> in_bound m' p' = in_bound m p'.
    Proof. by rewrite /set8; t_xrbindP => _ <-. Qed.

    Lemma set8P m p w p' m' :
      set8 m p w = ok m' ->
      get8 m' p' = if p == p' then ok w else get8 m p'.
    Proof.
      rewrite /get8 /set8 => /dup[] /valid8_set ->; t_xrbindP => hb <-.
      case heq: in_bound => //=; last by case: eqP => // h;move: heq; rewrite -h hb.
      by rewrite /is_init /= Mz.setP; case: eqP.
    Qed.

    Global Instance array_CM : coreMem pointer (array s) :=
      CoreMem set8P valid8P get_valid8 valid8_set.

    Definition in_range (p:pointer) (ws:wsize) :=
      ((0 <=? p) && (p + wsize_size ws <=? s))%Z.

    Lemma in_rangeP p ws:
      reflect (0 <= p /\ p + wsize_size ws <= s)%Z (in_range p ws).
    Proof.
      rewrite /in_range; case: andP => h; constructor; move: h; rewrite !zify; Psatz.nia.
    Qed.

    Lemma validw_in_range m p ws : validw m p ws = (is_align p ws && in_range p ws).
    Proof.
      apply (sameP (validwP m p ws)).
      apply (iffP andP).
      + move=> [] ? /in_rangeP ?;split => // k hk.
        by rewrite -valid8_validw /valid8 /= /in_bound !zify !addE; Psatz.lia.
      move=> [] ? h; split => //; apply /in_rangeP.
      move: (wsize_size_pos ws) (h 0) (h (wsize_size ws - 1)).
      by rewrite add_0 addE -!valid8_validw /array_CM /valid8 /in_bound !zify; Psatz.lia.
    Qed.

  End CM.

  Definition get len (aa:arr_access) ws (a:array len) (p:Z) :=
    CoreMem.read a (p * mk_scale aa ws)%Z ws.

  Definition set {len ws} (a:array len) aa p (v:word ws) : exec (array len) :=
    CoreMem.write a (p * mk_scale aa ws)%Z v.

  Definition fcopy ws len (a t: WArray.array len) i j :=
    foldM (fun i t =>
             Let w := get AAscale ws a i in set t AAscale i w) t
          (ziota i j).

  Definition copy ws p (a:array (Z.to_pos (arr_size ws p))) :=
    fcopy ws a (WArray.empty _) 0 p.

  Definition fill len (l:list u8) : exec (array len) :=
    Let _ := assert (Pos.to_nat len == size l) ErrType in
    Let pt :=
      foldM (fun w pt =>
             Let t := set pt.2 AAscale pt.1 w in
             ok (pt.1 + 1, t)) (0%Z, empty len) l in
    ok pt.2.

  Definition get_sub_data (aa:arr_access) ws len (a:Mz.t u8) p :=
     let size := arr_size ws len in
     let start := (p * mk_scale aa ws)%Z in
     foldr (fun i data =>
       match Mz.get a (start + i) with
       | None => Mz.remove data i
       | Some w => Mz.set data i w
       end) (Mz.empty _) (ziota 0 size).

  Definition get_sub lena (aa:arr_access) ws len (a:array lena) p  : exec (array (Z.to_pos (arr_size ws len))) :=
     let size := arr_size ws len in
     let start := (p * mk_scale aa ws)%Z in
     if (0 <=? start) && (start + size <=? lena) then
       ok (Build_array (Z.to_pos size) (get_sub_data aa ws len (arr_data a) p))
     else Error ErrOob.

  Definition set_sub_data (aa:arr_access) ws len (a:Mz.t u8) p (b:Mz.t u8) :=
    let size := arr_size ws len in
    let start := (p * mk_scale aa ws)%Z in
    foldr (fun i data =>
      match Mz.get b i with
      | None => Mz.remove data (start + i)
      | Some w => Mz.set data (start + i) w
      end) a (ziota 0 size).

  Definition set_sub lena (aa:arr_access) ws len (a:array lena) p (b:array (Z.to_pos (arr_size ws len))) : exec (array lena) :=
    let size := arr_size ws len in
    let start := (p * mk_scale aa ws)%Z in
    if (0 <=? start) && (start + size <=? lena) then
      ok (Build_array lena (set_sub_data aa ws len (arr_data a) p (arr_data b)))
    else Error ErrOob.

  Definition cast len len' (a:array len) : result error (array len') :=
    if (len' <=? len)%Z then ok {| arr_data := a.(arr_data) |}
    else type_error.

  Definition uincl {len1 len2} (a1 : array len1) (a2 : array len2) :=
    (len1 <= len2)%Z /\
    ∀ i w, read a1 i U8 = ok w -> read a2 i U8 = ok w.

  Lemma uincl_refl len (a: array len) : uincl a a.
  Proof. by split => //; reflexivity. Qed.

  Lemma uincl_trans {len1 len2 len3}
    (a2: array len2) (a1: array len1) (a3: array len3) :
    uincl a1 a2 -> uincl a2 a3 -> uincl a1 a3.
  Proof.
    move=> [l1 h1] [l2 h2]; split; first by lia.
    by move=> ?? /h1 /h2.
  Qed.

  End WITH_POINTER_DATA.

  Lemma castK len (a:array len) : WArray.cast len a = ok a.
  Proof. by rewrite /cast Z.leb_refl; case: a. Qed.

  Lemma cast_len len1 len2 (t2:WArray.array len2) t1: WArray.cast len1 t2 = ok t1 -> len1 <= len2.
  Proof. by rewrite /cast; case: ZleP. Qed.

  Lemma cast_empty len1 len2 :
    WArray.cast len1 (empty len2) = if len1 <=? len2 then ok (empty len1) else type_error.
  Proof. by rewrite /WArray.cast. Qed.

  Lemma cast_empty_ok len1 len2 t:
    WArray.cast len1 (empty len2) = ok t -> t = empty len1.
  Proof. by move=> /dup[]/cast_len/ZleP; rewrite cast_empty => -> [<-]. Qed.

  Lemma cast_get8 len1 len2 (m : array len2) m' :
    cast len1 m = ok m' ->
    forall k,
      read m' k U8 =
        if k <? len1 then read m k U8 else Error ErrOob.
  Proof.
    rewrite /cast; case: ZleP => // hle [<-] k.
    rewrite -!get_read8 /memory_model.get /= /get8 /is_init /in_bound /=.
    by case: ZleP => /=; case: ZltP => //=; case: ZltP => //; lia.
  Qed.

  Lemma cast_uincl len1 len2 (t2 : WArray.array len2) t1 :
    cast len1 t2 = ok t1 -> uincl t1 t2.
  Proof.
    move=> hc; split; first by apply: cast_len hc.
    by move=> i w; rewrite (cast_get8 hc); case: ifP.
  Qed.

  Lemma uincl_cast len1 len2 (a1: array len1) (a2:array len2) len a1' :
    uincl a1 a2 ->
    cast len a1 = ok a1' ->
    exists a2', cast len a2 = ok a2' /\ uincl a1' a2'.
  Proof.
    move=> [hle hu] hc.
    have:= (cast_get8 hc). have:= @cast_get8 len len2 a2.
    move: hc; rewrite /cast; case: ZleP => // hle1 _.
    case: ZleP => hle2 hg2 hg1; last lia.
    eexists;split; first by eauto.
    split; first by lia.
    by move=> ??; rewrite hg1 hg2 //; case: ifP => // _ /hu.
  Qed.

  Lemma mk_scale_U8 aa : mk_scale aa U8 = 1%Z.
  Proof. by rewrite /mk_scale wsize8; case aa. Qed.

  Lemma get8_read len (m : array len) aa k :
    get aa U8 m k = read m k U8.
  Proof. by rewrite /get mk_scale_U8 Z.mul_1_r. Qed.

  Lemma set_get8 len (m m':array len) aa p ws (v: word ws) :
    set m aa p v = ok m' ->
    forall k,
      read m' k U8 =
        let i := (k - p * mk_scale aa ws)%Z in
         if ((0 <=? i) && (i <? wsize_size ws))%Z then ok (LE.wread8 v i)
         else read m k U8.
  Proof. by apply: write_read8. Qed.

  Lemma setP len (m m':array len) p1 p2 ws (v: word ws) :
    set m AAscale p1 v = ok m' ->
    get AAscale ws m' p2 = if p1 == p2 then ok v else get AAscale ws m p2.
  Proof.
    rewrite /set /get; case:eqP => [<- | hne hw]; first by apply writeP_eq.
    apply: (CoreMem.writeP_neq hw); move=> ??; rewrite !addE /mk_scale;nia.
  Qed.

  Lemma setP_eq len (m m':array len) p1 ws (v: word ws) :
    set m AAscale p1 v = ok m' ->
    get AAscale ws m' p1 = ok v.
  Proof. by move=> /setP ->; rewrite eqxx. Qed.

  Lemma setP_neq len (m m':array len) p1 p2 ws (v: word ws) :
    p1 != p2 ->
    set m AAscale p1 v = ok m' ->
    get AAscale ws m' p2 = get AAscale ws m p2.
  Proof. by move=> /negPf h /setP ->; rewrite h. Qed.

  Lemma mk_scale_bound aa ws : (1 <= mk_scale aa ws <= wsize_size ws)%Z.
  Proof. rewrite /mk_scale; have := wsize_size_pos ws; case:aa; lia. Qed.

  Lemma get_bound ws len aa (t:array len) i w :
    get aa ws t i = ok w ->
    [/\ 0 <= i * mk_scale aa ws,
        i * mk_scale aa ws + wsize_size ws <= len &
        is_align (i * mk_scale aa ws) ws]%Z.
  Proof.
    move=> hg; assert (h := readV hg); move: h.
    by rewrite validw_in_range => /andP [] ? /in_rangeP [].
  Qed.

  Lemma set_bound ws len aa (a t:array len) i (w:word ws) :
    set a aa i w = ok t ->
    [/\ 0 <= i * mk_scale aa ws,
        i * mk_scale aa ws +  wsize_size ws <= len &
        is_align (i * mk_scale aa ws) ws]%Z.
  Proof.
    move=> hs; have : validw a (i * mk_scale aa ws) ws by apply /(writeV w); exists t.
    by rewrite validw_in_range => /andP [] ? /in_rangeP [].
  Qed.

  Lemma get_empty (n:positive) off :
    read (empty n) off U8 = if (0 <=? off) && (off <? n) then Error ErrAddrUndef else Error ErrOob.
  Proof.
    by rewrite -get_read8 /memory_model.get /= /get8 /in_bound /is_init /=; case: ifP.
  Qed.

  Lemma get0 (n:positive) off : (0 <= off ∧ off < n)%Z ->
    read (empty n) off U8 = Error ErrAddrUndef.
  Proof. by rewrite get_empty => -[/ZleP -> /ZltP ->]. Qed.

  Lemma uincl_empty len len' (t:array len') :
    Zpos len <= len' -> uincl (empty len) t.
  Proof.
    split; first Psatz.lia.
    by move=> i w; rewrite get_empty; case: ifP.
  Qed.

  Lemma uincl_validw {len1 len2} (a1 : array len1) (a2 : array len2) ws i :
    uincl a1 a2 -> validw a1 i ws -> validw a2 i ws.
  Proof.
    move=> [h1 _]; rewrite !validw_in_range => /andP [] -> /= /in_rangeP ?; apply /in_rangeP; lia.
  Qed.

  Lemma uincl_get {len1 len2} (a1 : array len1) (a2 : array len2) aa ws i w :
    uincl a1 a2 ->
    get aa ws a1 i = ok w ->
    get aa ws a2 i = ok w.
  Proof.
    rewrite /get => -[_ hu] hr; have {hr}[ha hr] := read_read8 hr.
    by rewrite (read8_read (v:=w)) ?ha // => k /hr /hu.
  Qed.

  Lemma uincl_set {ws len1 len2} (a1 a1': array len1) (a2: array len2) aa i (w:word ws) :
    uincl a1 a2 ->
    set a1 aa i w = ok a1' ->
    exists a2', set a2 aa i w = ok a2' /\ uincl a1' a2'.
  Proof.
    rewrite /set; set k := _ * _ => hu hw1.
    have /(writeV w) [a2' hw2]: validw a2 k ws by apply /(uincl_validw hu) /(writeV w); exists a1'.
    exists a2'; split => //.
    case: hu => hle hu; split => //.
    move=> j wj; rewrite (write_read8 hw1) (write_read8 hw2) /=.
    by case:ifP => // _; apply: hu.
  Qed.

  Lemma fcopy_uincl ws len (a t1 t2 a1 : array len) i j:
    uincl t1 t2 ->
    fcopy ws a t1 i j = ok a1 ->
    exists2 a2, fcopy ws a t2 i j = ok a2 & uincl a1 a2.
  Proof.
    rewrite /fcopy; elim: (ziota i j) t1 t2 => {i j} [ | i il hrec] t1 t2 hu /=.
    + by move=> [<-]; exists t2.
    t_xrbindP => t1' w -> hset hfold /=.
    by have [t2' [-> /hrec ]] /= := uincl_set hu hset; apply.
  Qed.

  Lemma uincl_copy ws p a1 a2 a1' :
     uincl a1 a2 ->
     @copy ws p a1 = ok a1' ->
     @copy ws p a2 = ok a1'.
  Proof.
    move=> hu; rewrite /copy /fcopy.
    elim: ziota (empty _) => [ | i il hrec] a //=.
    t_xrbindP => a' w /(uincl_get hu) -> /= ->; apply: hrec.
  Qed.

  Definition fill_size len l a :
    fill len l = ok a ->
    Pos.to_nat len = size l.
  Proof. by rewrite /fill; t_xrbindP => /eqP. Qed.

  Lemma fill_get8 len l a :
    fill len l = ok a ->
    forall k,
      read a k U8 =
        if (0 <=? k) && (k <? len) then ok (nth 0%R l (Z.to_nat k))
        else Error ErrOob.
  Proof.
    rewrite /fill; t_xrbindP=> /eqP hsize -[z {a}a] /= hfold <- k.
    have: forall z0 a0,
      foldM (fun w pt => Let t := set pt.2 AAscale pt.1 w in ok (pt.1 + 1, t)) (z0, a0) l = ok (z, a) ->
      read a k U8 =
        let i := k - z0 in
        if (0 <=? i) && (i <? Z.of_nat (size l)) then ok (nth 0%R l (Z.to_nat i))
        else read a0 k U8;
      last first.
    + move=> /(_ _ _ hfold) ->.
      rewrite Z.sub_0_r get_empty /=.
      rewrite -hsize positive_nat_Z.
      by case: andb.
    elim: l {hsize hfold} => [ | w l ih] z0 a0 /=.
    + move=> [_ <-].
      by case: ifP => //; rewrite !zify; lia.
    t_xrbindP=> _ a1 hset <- /ih -> /=.
    have ->:
      (0 <=? k - z0) && (k - z0 <? Pos.of_succ_nat (size l)) =
      (k == z0) || (0 <=? k - (z0 + 1)) && (k - (z0 + 1) <? Z.of_nat (size l)).
    + by apply /idP/idP; rewrite !zify (rwR2 (@eqP _)); lia.
    have := setP k hset; rewrite !get8_read => ->.
    rewrite orbC.
    case: ifP => /=.
    + rewrite !zify => h.
      by have ->: Z.to_nat (k - z0) = S (Z.to_nat (k - (z0+1))) by lia.
    move=> _.
    rewrite eq_sym.
    case: eqP => [<- | //].
    by rewrite Z.sub_diag.
  Qed.

  Lemma set_sub_data_get8 aa ws a len p t k:
    Mz.get (@set_sub_data aa ws len a p t) k =
      let i := (k - p * mk_scale aa ws)%Z in
      if (0 <=? i) && (i <? arr_size ws len) then Mz.get t i
      else Mz.get a k.
  Proof.
    rewrite /set_sub_data.
    elim /natlike_ind: (arr_size ws len) a; last by apply ge0_arr_size.
    + move=> data; rewrite ziota0 /=; case: andP => // -[]; rewrite !zify; lia.
    move=> sz hsz ih data; rewrite ziotaS_cat // foldr_cat Z.add_0_l /= ih.
    case: ifPn; rewrite !zify => h3; case: ifPn; rewrite !zify => h4 //.
    + nia.
    + case heq: (Mz.get t) => [w|].
      + rewrite Mz.setP; case: eqP => [<- | ?]; last nia.
        rewrite -heq; f_equal; ring.
      rewrite Mz.removeP; case eqP => [<- | ?]; last nia.
      rewrite -heq; f_equal; ring.
    case heq: (Mz.get t) => [w|].
    + rewrite Mz.setP; case: eqP => [? | //]; lia.
    rewrite Mz.removeP; case eqP => [? | //]; lia.
  Qed.

  Lemma set_sub_get8 aa ws lena a len p t a' :
    @set_sub lena aa ws len a p t = ok a' ->
    forall k,
      read a' k U8 =
        let i := (k - p * mk_scale aa ws)%Z in
        if (0 <=? i) && (i <? arr_size ws len) then read t i U8
        else read a k U8.
  Proof.
    rewrite /set_sub; case: andP => // -[/ZleP h1 /ZleP h2] [<-] /= k.
    rewrite -!get_read8 /memory_model.get /= /get8 /is_init /in_bound set_sub_data_get8 /=.
    case: andP; rewrite !zify //= => ?; case: andP; rewrite !zify //= => ?; lia.
  Qed.

  Lemma set_sub_bound aa ws lena a len p t a' :
    @set_sub lena aa ws len a p t = ok a' ->
    0 <= p * mk_scale aa ws /\ p * mk_scale aa ws + arr_size ws len <= lena.
  Proof. by rewrite /set_sub; case: ifP => //; rewrite !zify. Qed.

  Lemma get_sub_data_get8 aa ws a len p k:
    Mz.get (get_sub_data aa ws len a p) k =
      let start := (p * mk_scale aa ws)%Z in
      if (0 <=? k) && (k <? arr_size ws len) then Mz.get a (start + k)
      else None.
  Proof.
    rewrite /get_sub_data -(Mz.get0 u8 k).
    elim /natlike_ind: (arr_size ws len) (Mz.empty u8); last by apply ge0_arr_size.
    + move => b; rewrite ziota0 /=; case: andP => //; rewrite !zify; lia.
    move=> sz hsz ih b; rewrite ziotaS_cat // foldr_cat Z.add_0_l /= ih.
    case: ifPn; rewrite !zify => h3; case: ifPn; rewrite !zify => h4 //.
    + nia.
    + case heq: (Mz.get a) => [w|].
      + by rewrite Mz.setP; case: eqP => [<- | ]; [rewrite heq | nia].
      by rewrite Mz.removeP; case: eqP => [<- | ]; [rewrite heq | nia].
    case heq: (Mz.get a) => [w|].
    + by rewrite Mz.setP; case: eqP => //; nia.
    by rewrite Mz.removeP; case: eqP => //; nia.
  Qed.

  Lemma get_sub_get8 aa ws lena a len p a' :
    @get_sub lena aa ws len a p = ok a' ->
    forall k,
      read a' k U8 =
        let start := (p * mk_scale aa ws)%Z in
        if (0 <=? k) && (k <? arr_size ws len) then read a (start + k) U8
        else Error ErrOob.
  Proof.
    rewrite /get_sub; case: andP => // -[/ZleP h1 /ZleP h2] [<-] /= k.
    rewrite -!get_read8 /memory_model.get /= /get8 /is_init /in_bound get_sub_data_get8 /=.
    case: andP; rewrite !zify //= => ?; case: andP; rewrite !zify //= => ?; lia.
  Qed.

  Lemma get_sub_bound aa ws lena a len p a' :
    @get_sub lena aa ws len a p = ok a' ->
    0 <= p * mk_scale aa ws /\ p * mk_scale aa ws + arr_size ws len <= lena.
  Proof. by rewrite /get_sub; case: ifP => //; rewrite !zify. Qed.

  Lemma uincl_get_sub {len1 len2} (a1 : array len1) (a2 : array len2)
      aa ws len i t1 :
    uincl a1 a2 ->
    get_sub aa ws len a1 i = ok t1 ->
    exists2 t2, get_sub aa ws len a2 i = ok t2 & uincl t1 t2.
  Proof.
    move=> [hlen hu] hget.
    have := get_sub_get8 hget.
    have := @get_sub_get8 aa ws len2 a2 len i _.
    move: hget; rewrite /get_sub; case: andP => // -[/ZleP h1 /ZleP h2] [_].
    case: andP; rewrite !zify => h3; last by lia.
    move=> /(_ _ refl_equal) hr2 hr1; eexists => //; split; first by lia.
    by move=> k w; rewrite hr1 hr2; case: ifP => // ? /hu.
  Qed.

  Lemma uincl_set_sub {ws len1 len2 len} (a1 a1': array len1) (a2: array len2) aa i
        (t1 t2:array (Z.to_pos (arr_size ws len))) :
    uincl a1 a2 -> uincl t1 t2 ->
    set_sub aa a1 i t1 = ok a1' ->
    exists2 a2', set_sub aa a2 i t2 = ok a2' & uincl a1' a2'.
  Proof.
    move=> [hlen1 hget1] [hlen2 hget2] hset.
    have := set_sub_get8 hset.
    have := @set_sub_get8 aa ws len2 a2 len i _.
    move: hset; rewrite /set_sub; case: andP => // -[/ZleP h1 /ZleP h2] [_].
    case: andP; rewrite !zify => h3; last by lia.
    move=> /(_ _ _ refl_equal) hr2 hr1; eexists => //; split; first by lia.
    by move=> k w; rewrite hr1 hr2; case: ifP => // [ ? /hget2| ? /hget1].
  Qed.

End WArray.

#[global]
Hint Resolve WArray.uincl_refl : core.


Lemma and_commutative : forall A B, A /\ B -> B /\ A.
Proof.
  intros.
  elim H.
  split.
  exact H1.
  exact H0.
Qed.

Lemma or_commutative : forall A B, A \/ B -> B \/ A.
Proof.
  intros.
  destruct H.
  right; exact H.
  left; exact H.
Qed.s


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* this file contains some cardinal functions, which are message
   dependent *)

Require Export reduce.
Require Export DistributedReferenceCounting.machine3.machine.

Section COUNT_MESSAGE.

Definition dec_predicate (m : Message) :=
  match m with
  | dec => true
  | _ => false
  end.

Definition inc_predicate (m : Message) :=
  match m with
  | inc_dec _ => true
  | _ => false
  end.

(* the next one only recognises inc_dec messages related to s0 *)

Variable s0 : Site.

Definition site_inc_predicate (m : Message) :=
  match m with
  | inc_dec s => if eq_site_dec s s0 then true else false
  | _ => false
  end.

Definition copy_predicate (m : Message) :=
  match m with
  | copy => true
  | _ => false
  end.

Definition dec_count (m : Message) :=
  match m with
  | dec => 1%Z
  | _ => 0%Z
  end.

Definition inc_count (m : Message) := 0%Z.

Definition copy_count (m : Message) :=
  match m with
  | copy => 1%Z
  | _ => 0%Z
  end.

Definition cardinal_count :=
  fun_sum Message dec_count (fun_sum Message inc_count copy_count).

Definition cardinal := reduce Message cardinal_count.

Lemma disjoint_cardinal :
 forall q : queue Message,
 cardinal q =
 (reduce Message dec_count q +
  (reduce Message inc_count q + reduce Message copy_count q))%Z.
Proof.
  intro.
  rewrite <- disjoint_reduce.
  rewrite <- disjoint_reduce.
  unfold cardinal in |- *.
  unfold cardinal_count in |- *.
  auto.
Qed.

Lemma cardinal_first_out :
 forall (q : queue Message) (m : Message),
 first Message q = value Message m ->
 cardinal (first_out Message q) = (cardinal q - cardinal_count m)%Z.
Proof.
  intros.
  unfold cardinal in |- *.
  apply reduce_first_out.
  auto.
Qed.

End COUNT_MESSAGE.

Section SIG_WEIGHT.
Let Bag_of_message := Bag_of_Data Message.

Definition sigma_weight (bm : Bag_of_message) :=
  sigma2_table Site LS LS (queue Message) (fun s1 s2 : Site => cardinal) bm.

End SIG_WEIGHT.


Require Import Coq.omega.Omega.
Require Import Bedrock.Platform.AutoSep.

Require Import Bedrock.Platform.Malloc Bedrock.Platform.Cito.examples.Seq.

Module Type ADT.
  Parameter arr : list W -> W -> HProp.

  Axiom arr_fwd : forall ws self, arr ws self ===> [| self <> 0 |] * [| freeable self (2 + length ws) |]
    * [| goodSize (2 + length ws) |]
    * (Ex junk, self ==*> $ (length ws), junk)
    * array ws (self ^+ $8).
  Axiom arr_bwd : forall ws (self : W), [| self <> 0 |] * [| freeable self (2 + length ws) |]
    * [| goodSize (2 + length ws) |]
    * (Ex junk, self ==*> $ (length ws), junk)
    * array ws (self ^+ $8) ===> arr ws self.
End ADT.

Module Adt : ADT.
  Open Scope Sep_scope.

  Definition arr (ws : list W) (self : W) : HProp :=
    [| self <> 0 |] * [| freeable self (2 + length ws) |] * [| goodSize (2 + length ws) |]
    * (Ex junk, self ==*> $ (length ws), junk)
    * array ws (self ^+ $8).

  Theorem arr_fwd : forall ws self, arr ws self ===> [| self <> 0 |] * [| freeable self (2 + length ws) |]
    * [| goodSize (2 + length ws) |]
    * (Ex junk, self ==*> $ (length ws), junk)
    * array ws (self ^+ $8).
    unfold arr; sepLemma.
  Qed.

  Theorem arr_bwd : forall ws (self : W), [| self <> 0 |] * [| freeable self (2 + length ws) |]
    * [| goodSize (2 + length ws) |]
    * (Ex junk, self ==*> $ (length ws), junk)
    * array ws (self ^+ $8) ===> arr ws self.
    unfold arr; sepLemma.
  Qed.
End Adt.

Import Adt.
Export Adt.

Lemma allocated_out'' : forall p len offset,
  allocated p offset len ===> Ex ws, ptsto32m' nil p offset ws * [| length ws = len |].
  induction len; sepLemmaLhsOnly.
  apply himp_ex_c; exists nil; sepLemma.
  etransitivity; [ apply himp_star_frame; [ apply IHlen | reflexivity ] | ].
  sepLemmaLhsOnly.
  apply himp_ex_c; exists (x :: x0); sepLemma.
  destruct offset; sepLemma.
Qed.

Lemma allocated_out' : forall p len offset,
  allocated p offset len ===> Ex ws, ptsto32m nil p offset ws * [| length ws = len |].
  intros; eapply Himp_trans; [ apply allocated_out'' | ].
  apply Himp_ex; intro.
  apply Himp_star_frame; try apply Himp_refl.
  apply ptsto32m'_out.
Qed.

Inductive view_shift (n : nat) := ViewShift.
Local Hint Constructors view_shift.

Lemma allocated_out : forall p offset len,
  view_shift offset
  -> allocated p offset len ===> Ex ws, array ws (p ^+ $ (offset)) * [| length ws = len |].
  intros; eapply Himp_trans; [ apply allocated_out' | ].
  apply Himp_ex; intro.
  apply Himp_star_frame; try apply Himp_refl.
  eapply Himp_trans; [ apply ptsto32m_shift_base' | ].
  instantiate (1 := offset); auto.
  rewrite Minus.minus_diag; apply Himp_refl.
Qed.

Lemma allocated_in'' : forall p len offset,
  (Ex ws, ptsto32m' nil p offset ws * [| length ws = len |]) ===> allocated p offset len.
  induction len; sepLemmaLhsOnly.
  destruct x; sepLemma.
  destruct x; sepLemma.
  apply himp_star_frame.
  etransitivity; [ | apply IHlen ].
  sepLemma.
  destruct offset; sepLemma.
Qed.

Lemma allocated_in' : forall p len offset,
  (Ex ws, ptsto32m nil p offset ws * [| length ws = len |]) ===> allocated p offset len.
  intros; eapply Himp_trans; [ | apply allocated_in'' ].
  apply Himp_ex; intro.
  apply Himp_star_frame; try apply Himp_refl.
  apply Arrays.ptsto32m'_in.
Qed.

Lemma allocated_in : forall p ws,
  goodSize (S (S (length ws)))
  -> p =?> 2 * array ws (p ^+ $8) ===> p =?> wordToNat (natToW (S (S (length ws)))).
  intros.

  replace (wordToNat (natToW (S (S (length ws))))) with (S (S (length ws))).
  eapply Himp_trans; [ | apply allocated_join ].
  apply Himp_star_frame; try apply Himp_refl.
  2: auto.
  simpl.
  eapply Himp_trans; [ | apply allocated_in' ].
  sepLemma.
  instantiate (1 := ws); omega.
  etransitivity; [ | apply ptsto32m_shift_base ].
  instantiate (1 := 8); reflexivity.
  auto.
  rewrite wordToNat_natToWord_idempotent; auto.
Qed.

Definition hints : TacPackage.
  prepare (arr_fwd, allocated_out) (arr_bwd, allocated_in).
Defined.

Definition newS := newS arr 8.
Definition deleteS := deleteS arr 7.
Definition readS := readS arr 0.
Definition writeS := writeS arr 0.

Definition m := bimport [[ "malloc"!"malloc" @ [mallocS], "malloc"!"free" @ [freeS] ]]
  bmodule "ArraySeq" {{
    bfunction "new"("extra_stack", "len", "x") [newS]
      "x" <- 2 + "len";;
      "x" <-- Call "malloc"!"malloc"(0, "x")
      [PRE[V, R] R =?> (2 + wordToNat (V "len"))
        * [| R <> 0 |] * [| freeable R (2 + wordToNat (V "len")) |]
        * [| goodSize (2 + wordToNat (V "len")) |] * mallocHeap 0
       POST[R'] Ex ws, arr ws R' * [| length ws = wordToNat (V "len") |] * mallocHeap 0];;

      "x" *<- "len";;
      Note [view_shift 8];;
      Return "x"
    end

    with bfunction "delete"("extra_stack", "self", "x") [deleteS]
      "x" <-* "self";;
      "x" <- 2 + "x";;
      Call "malloc"!"free"(0, "self", "x")
      [PRE[_] Emp
       POST[_] Emp];;

      Return 0
    end

    with bfunction "read"("extra_stack", "self", "n") [readS]
      "n" <- 4 * "n";;
      "self" <- "self" + 8;;
      "self" <-* "self" + "n";;
      Return "self"
    end

    with bfunction "write"("extra_stack", "self", "n", "v") [writeS]
      "n" <- 4 * "n";;
      "self" <- "self" + 8;;
      "self" + "n" *<- "v";;
      Return 0
    end
  }}.

Local Hint Extern 1 (@eq W _ _) => words.

Lemma twoPlus_le : forall w,
  goodSize (2 + wordToNat w)
  -> natToW 2 <= natToW 2 ^+ w.
  intros.
  rewrite <- (natToWord_wordToNat w).
  rewrite <- natToWord_plus.
  apply le_goodSize; auto.
Qed.

Local Hint Immediate twoPlus_le.

Local Hint Extern 1 (himp _ _ _) =>
  match goal with
    | [ H : _ = wordToNat _ |- _ ] =>
      rewrite H; unfold natToW; rewrite natToWord_wordToNat; solve [ step auto_ext ]
  end.

Lemma twoPlus_freeable : forall w len,
  freeable w (S (S len))
  -> goodSize (S (S len))
  -> freeable w (wordToNat (natToW (S (S len)))).
  intros; rewrite wordToNat_natToWord_idempotent; auto.
Qed.

Local Hint Immediate twoPlus_freeable.

Section hints.
  Hint Rewrite wordToNat_wplus using assumption : sepFormula.

  Theorem ok : moduleOk m.
    vcgen; abstract (sep hints; auto).
  Qed.
End hints.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import IEEE.

Definition t := Single.

Definition m := Rounding_nearest.

Definition test_add (x y : diadic) :=
  (Dadd x y,
  diadic_of_abstract t
    (fst
       (abstract_add t m (abstract_of_diadic t m x)
          (abstract_of_diadic t m y)))).

Definition verif (x y : diadic) := let (s1, s2) := test_add x y in Deq s1 s2.

Definition t1 := Diadic 10456 0.
Definition t2 := Diadic 10456 1.