From Perennial.program_proof Require Import disk_prelude.
From Goose.github_com.mit_pdos.gokv Require Import aof.
From Perennial.program_proof.lockservice Require Import grove_ffi.
From Perennial.algebra Require Import mlist auth_map.
From iris.algebra Require Import mono_nat.
From Perennial.Helpers Require Import ModArith.

Section aof_proof.
Context `{!heapGS Σ}.
Context `{!filesysG Σ}.

Class aofG Σ := AofG {
  aof_flistG :> fmlistG u8 Σ ;
  aof_mnatG :> inG Σ mono_natUR ;
  aof_mapG :> mapG Σ u64 unit ;
  aof_tokG :> inG Σ (exclR unitO) ;
}.

Record aof_vol_names := mk_aof_vol_names {
  logdata : gname ;
  predurabledata : gname ;
  len : gname ;
  len_toks : gname ;
}.

Context `{!aofG Σ}.

Implicit Types γ : aof_vol_names.
Implicit Types aof_ctx : (list u8) → iProp Σ.

Definition aof_lenN := nroot .@ "aof_len".
Definition aof_len_invariant γ : iProp Σ :=
  ∃ (l:u64),
    own γ.(len) (mono_nat_auth (1/2) (int.nat l)) ∗
    [∗ set] x ∈ (fin_to_set u64), x [[γ.(len_toks)]]↦ () ∨ ⌜int.nat x > int.nat l⌝
.

Definition aof_length_lb γ (l:u64) : iProp Σ :=
  own γ.(len) (mono_nat_lb (int.nat l)).

Definition list_safe_size (l:list u8) := int.nat (length l) = length l.

Definition aof_mu_invariant (aof_ptr:loc) γ aof_ctx : iProp Σ :=
  ∃ membuf_sl membufC predurableC (durlen genlength:u64),
  "Hmembuf" ∷ aof_ptr ↦[AppendOnlyFile :: "membuf"] (slice_val membuf_sl) ∗
  "HdurableLength" ∷ aof_ptr ↦[AppendOnlyFile :: "durableLength"]{1/2} #durlen ∗
  "Hmembuf_sl" ∷ typed_slice.is_slice membuf_sl byteT 1 membufC ∗
  "Hpredurable" ∷ fmlist γ.(predurabledata) (1/2) predurableC ∗
  "Hlogdata" ∷ fmlist γ.(logdata) (1/2)%Qp (predurableC ++ membufC) ∗
  "Hlength" ∷ aof_ptr ↦[AppendOnlyFile :: "length"] #genlength ∗
  "%Hlengthsafe" ∷ ⌜list_safe_size (predurableC ++ membufC)⌝ ∗
  "Hlen_toks" ∷ ([∗ set] x ∈ (fin_to_set u64), x [[γ.(len_toks)]]↦ () ∨ ⌜int.nat x ≤ int.nat genlength⌝) ∗
  "Hmembuf_fupd" ∷ (aof_ctx predurableC ={⊤}=∗ aof_ctx (predurableC ++ membufC)
     ∗ (∀ oldlen, own γ.(len) (mono_nat_auth (1/2) oldlen) ={⊤}=∗
        own γ.(len) (mono_nat_auth (1/2) (int.nat genlength))
       )
  ) ∗
  "#Hdurlen_lb" ∷ aof_length_lb γ durlen
.

Definition aofN := nroot .@ "aof".

Definition is_aof aof_ptr γ (aof_ctx : (list u8) → iProp Σ) : iProp Σ :=
  ∃ mu_ptr (lenCond_ptr durCond_ptr:loc),
  "#Hmu" ∷ readonly (aof_ptr ↦[AppendOnlyFile :: "mu"] mu_ptr) ∗
  "#HlengthCond" ∷ readonly (aof_ptr ↦[AppendOnlyFile :: "lengthCond"] #lenCond_ptr) ∗
  "#HdurableCond" ∷ readonly (aof_ptr ↦[AppendOnlyFile :: "durableCond"] #durCond_ptr) ∗
  "#HlenCond" ∷ is_cond lenCond_ptr mu_ptr ∗
  "#HdurCond" ∷ is_cond durCond_ptr mu_ptr ∗
  "#Hmu_inv" ∷ is_lock aofN mu_ptr (aof_mu_invariant aof_ptr γ aof_ctx) ∗
  "#Haof_len_inv" ∷ inv aof_lenN (aof_len_invariant γ)
.

(* TODO: upgrade to WPC *)
Lemma wp_CreateAppendOnlyFile (fname:string) data aof_ctx :
  {{{
       fname f↦{1} data ∗
       aof_ctx data
  }}}
    CreateAppendOnlyFile #(str fname)
  {{{
       aof_ptr γ, RET #aof_ptr; is_aof aof_ptr γ aof_ctx
  }}}.
Proof.
  iIntros (Φ) "Hpre HΦ".
  wp_lam.

  wp_apply (wp_allocStruct).
  { admit. (* TODO: typechecking *) }
  iIntros (l) "Hl".
  iDestruct (struct_fields_split with "Hl") as "Hl".
  iNamed "Hl".

  wp_pures.
  wp_apply (wp_new_free_lock).
  iIntros (mu) "Hmu_free".

  wp_pures.
  wp_storeField.

  wp_loadField.
  wp_apply (wp_newCond' with "Hmu_free").
  iIntros (lengthCond) "[Hmu_free HlengthCond]".
  wp_storeField.

  wp_loadField.
  wp_apply (wp_newCond' with "Hmu_free").
  iIntros (durableCond) "[Hmu_free HdurableCond]".
  wp_storeField.

  iAssert ((|={⊤}=> ∃ γ, is_aof l γ aof_ctx ∗ fmlist γ.(predurabledata) (1 / 2) data
            ∗ l ↦[AppendOnlyFile :: "durableLength"]{1 / 2} #0
            ∗ own γ.(len) (mono_nat_auth (1/2) 0))
          )%I with "[-Hpre HΦ]" as ">HH".
  {
    (* need to allocate ghost state and freeze stuff *)
    iExists (mk_aof_vol_names _ _ _ _).
    admit.
  }
  iDestruct "HH" as (γ) "(#His_aof & Hpredur & HdurLen & Hlen)".
  wp_apply (wp_fork with "[-HΦ]").
  {
    iNext.
    iNamed "His_aof".
    wp_loadField.
    wp_apply (acquire_spec with "Hmu_inv").
    iIntros "[Hlocked Haof_own]".
    wp_pures.
    iAssert (∃ data', fname f↦ (data++data') ∗ aof_ctx (data++data') ∗ fmlist γ.(predurabledata) (1/2) (data ++ data')
            ∗ l ↦[AppendOnlyFile :: "durableLength"]{1 / 2} #(U64 (length data'))
            ∗ own γ.(len) (mono_nat_auth (1/2) (length (data')))
            )%I with "[Hpre Hpredur HdurLen Hlen]" as "Hfile_ctx".
    { iExists []; iFrame. rewrite app_nil_r. iFrame. }
    wp_forBreak.
    wp_pures.

    iNamed "Haof_own".
    wp_loadField.
    wp_apply (wp_slice_len).
    wp_pures.
    wp_if_destruct.
    {
      wp_loadField.
      wp_apply (wp_condWait with "[- Hfile_ctx]").
      { iFrame "#∗". iExists _, _, _, _; iFrame "∗#". done. }
      iIntros "[Hlocked Haof_own]".
      wp_pures.
      iLeft.
      iFrame.
      done.
    }

    wp_loadField.
    wp_pures.
    wp_loadField.
    wp_pures.

    wp_apply (wp_new_slice).
    { done. }
    iIntros (empty_membuf_sl) "Hmembuf_empty".
    wp_apply (wp_storeField with "Hmembuf").
    { unfold AppendOnlyFile. unfold field_ty. simpl. apply slice_val_ty. }
    iIntros "Hmembuf".

    wp_pures.
    wp_loadField.

    iDestruct "Hfile_ctx" as (data') "(Hfile & Hctx & Hpredur & HdurLen & Hlen)".

    iDestruct (fmlist_agree_1 with "Hpredur Hpredurable") as %Hpredur.
    rewrite Hpredur.
    iCombine "Hpredur Hpredurable" as "Hpredur".
    iMod (fmlist_update (predurableC ++ membufC) with "Hpredur") as "[Hpredur _]".
    { by apply prefix_app_r. }
    iDestruct "Hpredur" as "[Hpredur Hpredurable]".
    wp_apply (release_spec with "[-Hfile Hctx Hpredur Hmembuf_fupd Hmembuf_sl HdurLen Hlen]").
    { iFrame "#∗". iNext. iExists _, [], (predurableC ++ membufC), _. iFrame "∗#".
      rewrite app_nil_r.
      iFrame.
      iSplitL ""; first done.
      iIntros "$ !> $ !>".
      done.
    }

    wp_pures.

    iDestruct (typed_slice.is_slice_sz with "Hmembuf_sl") as %Hsz.
    wp_bind (AtomicAppend _ _).
    iApply wpc_wp.
    wpc_apply (wpc_AtomicAppend with "[$Hfile $Hmembuf_sl]").
    iSplit.
    { iModIntro. iIntros. instantiate (1:=(True)%I). done. }
    iNext.
    iIntros "[Hfile _]".
    iMod ("Hmembuf_fupd" with "Hctx") as "[Hctx Hlen_fupd]".
    wp_pures.

    wp_loadField.
    wp_apply (acquire_spec with "Hmu_inv").
    iIntros "[Hlocked Haof_own]".
    iRename "Hdurlen_lb" into "Hdurlen_lb_old".
    iNamed "Haof_own".
    wp_pures.

    iDestruct (struct_field_mapsto_agree with "HdurLen HdurableLength") as %Heq.
    rewrite Heq.
    iCombine "HdurLen HdurableLength" as "HdurLen".
    wp_storeField.

    wp_loadField.
    iMod ("Hlen_fupd" with "Hlen") as "Hlen".
    iEval (rewrite mono_nat_auth_lb_op) in "Hlen".
    iDestruct "Hlen" as "[Hlen #Hlenlb]".

    wp_apply (wp_condBroadcast).
    { iFrame "#". }
    wp_pures.
    iLeft.
    iFrame.
    iSplitL ""; first done.
    iDestruct "HdurLen" as "[HdurableLength HdurLen]".
    iSplitR "Hpredur HdurLen Hlen Hfile Hctx".
    {
      iExists _, _, _, _; iFrame "∗#".
      iSplitL ""; first done.
      unfold aof_length_lb.
      rewrite Hlengthsafe.
      iFrame "#".
    }
    {
      rewrite -Hpredur.
      repeat rewrite -app_assoc.
      iExists _; iFrame.
    }
  }
  wp_pures.
  iApply "HΦ".
  iFrame "#".
Admitted.

Definition aof_log_own γ data :=
  fmlist γ.(logdata) (1/2)%Qp data.

Lemma wp_AppendOnlyFile__Append aof_ptr γ data_sl aof_ctx (oldData newData:list u8) Q :
length newData > 0 →
list_safe_size newData →
is_aof aof_ptr γ aof_ctx -∗
  {{{
       typed_slice.is_slice data_sl byteT 1 newData ∗ aof_log_own γ oldData ∗
       (aof_ctx oldData ={⊤}=∗ aof_ctx (oldData ++ newData) ∗ Q)
  }}}
    AppendOnlyFile__Append #aof_ptr (slice_val data_sl)
  {{{
       (l:u64), RET #l; aof_log_own γ (oldData ++ newData) ∗
                        (aof_length_lb γ l ={⊤}=∗ ▷ Q)
  }}}.
Proof.
  intros HnewDataLen HnewDataSafe.
  iIntros "#Haof" (Φ) "!# Hpre HΦ".
  iNamed "Haof".
  wp_lam.
  wp_pures.

  wp_loadField.
  wp_apply (acquire_spec with "Hmu_inv").
  iIntros "[Hlocked Haof]".
  iNamed "Haof".
  iDestruct "Hpre" as "(HnewData & Haof_log & Hfupd)".
  wp_pures.

  wp_loadField.
  iDestruct (is_slice_sz with "HnewData") as %Hsz.
  wp_apply (typed_slice.wp_SliceAppendSlice (V:=u8) with "[$Hmembuf_sl $HnewData]").
  iIntros (membuf_sl') "Hmembuf_sl".
  wp_apply (wp_storeField with "Hmembuf").
  { unfold AppendOnlyFile. unfold field_ty. simpl. apply slice_val_ty. }
  iIntros "Hmembuf".

  wp_pures.

  (* overflow guard *)
  wp_forBreak_cond.
  wp_pures.
  repeat wp_loadField.
  wp_apply (wp_slice_len).
  wp_loadField.
  wp_pures.
  wp_if_destruct.
  {
    wp_pures.
    iLeft. iFrame "∗#". done.
  }
  iRight.
  iSplitL ""; first done.
  rewrite typed_slice.list_untype_length in Hsz.

  wp_loadField.
  wp_apply (wp_slice_len).
  wp_pures.
  rewrite -HnewDataSafe in Hsz Heqb.
  assert (U64 (length newData) = data_sl.(Slice.sz)) as HH.
  {
    apply Z2Nat.inj in Hsz.
    { word_cleanup. naive_solver. }
    { word_cleanup. naive_solver. }
    word.
  }
  rewrite -HH.
  rewrite -HH in Heqb.
  wp_pures.
  wp_storeField.

  wp_loadField.
  wp_pures.

  wp_loadField.
  wp_apply (wp_condSignal).
  { iFrame "#". }

  wp_pures.

  unfold aof_log_own.
  iDestruct (fmlist_agree_1 with "Haof_log Hlogdata") as %->.
  iCombine "Haof_log Hlogdata" as "Haof_log".

  iMod (fmlist_update ((predurableC ++ membufC) ++ newData) with "Haof_log") as "[Haof_log _]".
  { apply prefix_app_r. done. }

  iDestruct "Haof_log" as "[Hlogdata Haof_log]".

  rewrite -app_assoc.
  (* Want to prove membuf_fupd, and the postcondition *)
  set (membufC' := membufC ++ newData) in *.

  iAssert (([∗ set] x ∈ fin_to_set u64, x [[γ.(len_toks)]]↦ () ∨
                      ⌜int.nat x <= length (predurableC ++ membufC)⌝ ∨
                      ⌜length (predurableC ++ membufC') < int.nat x⌝
          ) ∗
          ([∗ set] x ∈ fin_to_set u64, x [[γ.(len_toks)]]↦ () ∨
                      ⌜int.nat x ≤ length (predurableC ++ membufC')⌝
          ))%I
    with "[Hlen_toks]"
    as "HH".
  {
    iApply big_sepS_sep.
    iApply (big_sepS_impl with "Hlen_toks").
    iModIntro.
    iIntros (x ?) "Hx".
    iDestruct "Hx" as "[Hx|%Hineq]".
    {
      destruct (bool_decide (length (predurableC ++ membufC') < int.nat x)) as [|] eqn:Hineq.
      {
        apply bool_decide_eq_true in Hineq.
        iSplitR "Hx".
        { iRight; iRight. done. }
        iLeft. iFrame.
      }
      {
        apply bool_decide_eq_false in Hineq.
        iSplitL "Hx".
        { iFrame. }
        iRight.
        iPureIntro.
        word.
      }
    }
    {
      iSplitL.
      {
        iRight; iLeft. done.
      }
      iRight. iPureIntro.
      replace (membufC') with (membufC ++ newData) by done.
      rewrite app_assoc.
      rewrite app_length.
      word.
    }
  }

  iDestruct "HH" as "[Htoks Hlen_toks]".

  (* TODO: factor this into a lemma *)
  assert (int.Z (word.add (U64 (length (predurableC ++ membufC))) (U64 (length newData))) =
          int.Z (U64 (length (predurableC ++ membufC))) + int.Z (U64 (length newData))).
  {
    assert (int.Z (word.add (length (predurableC ++ membufC)) (length newData)) >= int.Z (length (predurableC ++ membufC)))%Z by lia.
    destruct (bool_decide ((int.Z (U64 (length (predurableC ++ membufC)))) + (int.Z (U64 (length newData))) < 2 ^ 64 ))%Z eqn:Hnov.
    {
      apply bool_decide_eq_true in Hnov.
      rewrite word.unsigned_add.
      rewrite wrap_small.
      { word. }
      split.
      {
        apply Z.add_nonneg_nonneg.
        { word_cleanup. naive_solver. }
        { word_cleanup. naive_solver. }
      }
      { done. }
    }
    apply bool_decide_eq_false in Hnov.
    assert (int.Z (U64 (length (predurableC ++ membufC))) + int.Z (U64 (length newData)) >= 2 ^ 64)%Z.
    { lia. }
    apply sum_overflow_check in H0.
    contradiction.
  }
  assert (int.nat (U64 (length (predurableC ++ membufC'))) = (length (predurableC ++ membufC'))) as Hsafesize'.
  {
    replace (membufC') with (membufC ++ newData) by done.
    rewrite app_assoc.
    rewrite app_length.
    word_cleanup.
    rewrite -Hlengthsafe.
    repeat (rewrite Nat2Z.inj_add).
    replace (length newData) with (Z.to_nat (Z.of_nat (length newData))) by lia.
    rewrite -Z2Nat.inj_add.
    {
      rewrite Z2Nat.inj_iff.
      {
        rewrite Z2Nat.id.
        {
          rewrite wrap_small; first word.
          split.
          {
            apply Z.add_nonneg_nonneg; word_cleanup; naive_solver.
          }
          {
            rewrite Nat2Z.id.
            rewrite -HnewDataSafe.
            replace (Z.of_nat (int.nat (length newData))) with (int.Z (length newData)); last first.
            { rewrite u64_Z_through_nat. done. }
            destruct (bool_decide (int.Z (length (predurableC ++ membufC)) + (int.Z (length newData)) < 2 ^ 64)) eqn:Hnov.
            { apply bool_decide_eq_true in Hnov. done. }
            {
              apply bool_decide_eq_false in Hnov.
              assert (int.Z (U64 (length (predurableC ++ membufC))) + (int.Z (length newData)) >= 2 ^ 64)%Z.
              { lia. }
              apply sum_overflow_check in H4.
              contradiction.
            }
          }
        }
        naive_solver.
      }
      {
        word_cleanup.
        unfold word.wrap.
        by apply Z_mod_lt.
      }
      {
        word_cleanup.
        apply Z.add_nonneg_nonneg; word_cleanup; naive_solver.
      }
    }
    { naive_solver. }
    { lia. }
  }

  iAssert (|={⊤}=> (
  aof_ctx predurableC
                   ={⊤}=∗ aof_ctx (predurableC ++ membufC')
                          ∗ (own γ.(len) (mono_nat_auth (1 / 2) (length predurableC))
                             ={⊤}=∗ own γ.(len)
                                      (mono_nat_auth (1 / 2)
                                         (length (predurableC ++ membufC'))))
  ) ∗ (aof_length_lb γ (U64 (length (predurableC ++ membufC'))) ={⊤}=∗ ▷ Q))%I with "[Hmembuf_fupd Hfupd Htoks]" as "HH".
  {
    (* allocate invariant to escrow Q *)
    iMod (own_alloc (Excl ())) as "HQtok".
    { done. }
    iDestruct "HQtok" as (γtok) "Htok".
    iMod (own_alloc (Excl ())) as "HQexcl".
    { done. }
    iDestruct "HQexcl" as (γq) "HQexcl".
    iDestruct (big_sepS_elem_of_acc _ _ (U64 (length (predurableC ++ membufC'))) with "Htoks") as "[Hlen_tok Hlen_toks_rest]".
    { set_solver. }
    iDestruct "Hlen_tok" as "[Hlen_tok|%Hbad]"; last first.
    {
      exfalso.
      rewrite Hsafesize' in Hbad.
      rewrite app_length in Hbad.
      rewrite app_length in Hbad.
      rewrite app_length in Hbad.
      word.
    }
    iMod (inv_alloc aofN _ (own γtok (Excl ()) ∗ aof_length_lb γ (U64 (length (predurableC ++ membufC'))) ∨ (U64 (length (predurableC ++ membufC')) [[γ.(len_toks)]]↦ ()) ∨ Q ∗ own γq (Excl ())) with "[Hlen_tok]") as "#HQinv".
    {
      iRight. iLeft.
      iFrame.
    }
    iSplitR "Htok"; last first.
    {
      iModIntro.
      iIntros "Haof_lb".
      iInv "HQinv" as "Hq" "Hqclose".
      iDestruct "Hq" as "[>[Htok2 _]|Hq]".
      { iDestruct (own_valid_2 with "Htok Htok2") as %Hbad. contradiction. }
      iDestruct "Hq" as "[>Hlentok|Hq]".
      {
        iInv "Haof_len_inv" as ">Ha" "Haclose".
        unfold aof_len_invariant.
        iDestruct "Ha" as (l) "[Hlen Ha]".
        iDestruct (own_valid_2 with "Hlen Haof_lb") as %Hineq.
        apply mono_nat_both_frac_valid in Hineq as [_ Hineq].
        iDestruct (big_sepS_elem_of_acc _ _ (U64 (length (predurableC ++ membufC'))) with "Ha") as "[Ha Harest]".
        { set_solver. }
        iDestruct "Ha" as "[Hlentok2|%Hbad]"; last first.
        { exfalso. lia. }
        iDestruct (ptsto_conflict with "Hlentok Hlentok2") as %Hbad.
        done.
      }
      iMod ("Hqclose" with "[Htok Haof_lb]").
      { iLeft. iNext. iFrame. }
      iDestruct "Hq" as "[$ _]".
      by iModIntro.
    }

    iModIntro.
    iIntros "Hctx".
    iMod ("Hmembuf_fupd" with "Hctx") as "[Hctx Hmembuf_fupd]".
    iMod ("Hfupd" with "Hctx") as "[$ HQ]".
    iModIntro.

    (* length stuff *)
    iIntros "Hlen".
    iInv "HQinv" as "Hq" "Hqclose".
    iDestruct "Hq" as "[[_ >Hlb]|Hq]".
    {
      iDestruct (own_valid_2 with "Hlen Hlb") as %Hbad.
      exfalso.
      apply mono_nat_both_frac_valid in Hbad as [_ Hbad].
      rewrite Hsafesize' in Hbad.
      rewrite app_length in Hbad.
      rewrite app_length in Hbad.
      lia.
    }
    iDestruct "Hq" as "[>Hlen_tok|[_ >HQexcl2]]"; last first.
    { iDestruct (own_valid_2 with "HQexcl HQexcl2") as %Hbad. contradiction. }

    iDestruct ("Hlen_toks_rest" with "[$Hlen_tok]") as "Hlen_toks".
    iMod ("Hqclose" with "[HQexcl HQ]") as "_".
    { iRight; iRight; iFrame. }

    iMod ("Hmembuf_fupd" with "Hlen") as "Hlen".

    (* Use tokens to update mono_nat counter *)
    iInv "Haof_len_inv" as ">Ha" "Haclose".
    iDestruct "Ha" as (len) "[Hlen2 Ha]".
    iDestruct (own_valid_2 with "Hlen Hlen2") as %Hleneq.
    apply mono_nat_auth_frac_op_valid in Hleneq as [_ <-].
    iCombine "Hlen Hlen2" as "Hlen".
    rewrite mono_nat_auth_frac_op.
    rewrite Qp.half_half.
    iMod (own_update _ _ (mono_nat_auth 1 (length (predurableC ++ membufC'))) with "Hlen") as "Hlen".
    {
      apply mono_nat_update.
      repeat rewrite app_length.
      lia.
    }
    iEval (rewrite -Qp.half_half) in "Hlen".
    rewrite -mono_nat_auth_frac_op.
    iDestruct "Hlen" as "[Hlen Hlen2]".

    iMod ("Haclose" with "[Ha Hlen_toks Hlen2]") as "_".
    {
      iNext. iExists _. rewrite -Hsafesize'.
      iFrame.
      iApply (big_sepS_impl with "[Ha Hlen_toks]").
      { iApply big_sepS_sep. iFrame. }

      iModIntro.
      iIntros (x ?) "Hx".
      destruct (bool_decide (int.nat (length (predurableC ++ membufC')) < int.nat x)) as [|] eqn:Hineq.
      {
        apply bool_decide_eq_true in Hineq.
        iRight.
        iPureIntro.
        word.
      }
      {
        apply bool_decide_eq_false in Hineq.
        iLeft.
        iDestruct "Hx" as "[[$|%Hbad] [$|%Hineq2]]".
        exfalso.
        word.
      }
    }
    iFrame.
    by iModIntro.
  }

  iMod "HH" as "[Hmembuf_fupd HfupdQ]".

  wp_loadField.
  wp_apply (release_spec with "[-HΦ Haof_log HfupdQ]").
  {
    iFrame "#∗".
    iNext.
    iExists _, _, _, _.
    iFrame "#∗".
    iSplitR ""; last done.
    replace (word.add (length (predurableC ++ membufC)) (length newData)) with
        (U64 (length (predurableC ++ membufC'))); last first.
    {
      repeat rewrite app_length.
      rewrite -word.ring_morph_add.
      word_cleanup.
      repeat (rewrite Nat2Z.inj_add).
      rewrite Z.add_assoc.
      done.
    }
    iFrame.
  }
  wp_pures.
  iApply "HΦ".
  iFrame.
  iIntros "#Hlb".
  iMod ("HfupdQ" with "[Hlb]") as "$"; last by iModIntro.
  replace (U64 (length (predurableC ++ membufC'))) with
      (word.add (length (predurableC ++ membufC)) (length newData)).
  { iFrame "#". }

  repeat rewrite app_length.
  repeat (rewrite Nat2Z.inj_add).
  rewrite Z.add_assoc.
  rewrite -word.ring_morph_add.
  unfold U64.
  done.
Qed.

Lemma wp_AppendOnlyFile__WaitAppend aof_ptr γ (l:u64) aof_ctx :
is_aof aof_ptr γ aof_ctx -∗
  {{{
       True
  }}}
    AppendOnlyFile__WaitAppend #aof_ptr #l
  {{{
       RET #(); aof_length_lb γ l
  }}}.
Proof.
  iIntros "#Haof" (Φ) "!# _ HΦ".
  wp_lam.
  wp_pures.
  iNamed "Haof".
  wp_loadField.
  wp_apply (acquire_spec with "Hmu_inv").
  iIntros "[Hlocked Haof_own]".
  wp_pures.
  wp_apply (wp_forBreak_cond' with "[-]").
  {
    iNamedAccu.
  }
  iModIntro.
  iNamed 1.

  wp_pures.
  iNamed "Haof_own".
  wp_loadField.
  wp_pures.
  wp_if_destruct.
  {
    wp_pures.
    wp_loadField.
    wp_apply (wp_condWait with "[- HΦ]").
    {
      iFrame "#∗".
      iExists _, _, _, _. iFrame "#∗".
      done.
    }
    iIntros "[Hlocked Haof_own]".
    wp_pures.
    iLeft.
    iFrame.
    done.
  }
  iSpecialize ("HΦ" with "[Hdurlen_lb]").
  {
    assert (int.nat l ≤ int.nat durlen) as Hineq.
    {
      word.
    }
    unfold aof_length_lb.
    replace (int.nat durlen)%nat with ((int.nat durlen) `max` int.nat l)%nat by word.
    rewrite -mono_nat_lb_op.
    iDestruct "Hdurlen_lb" as "[_ $]".
  }
  iRight.
  iSplitL ""; first done.
  wp_pures.

  wp_loadField.
  wp_apply (release_spec with "[- HΦ]").
  {
    iFrame "#∗".
    iExists _, _, _, _. iFrame "#∗".
    done.
  }
  iFrame.
Qed.

End aof_proof.


Require Import Coq.Strings.String Coq.Strings.Ascii.
Require Import Coq.Classes.Morphisms.
Require Import Fiat.Parsers.Reflective.Syntax.
Require Import Fiat.Parsers.Reflective.Semantics.
Require Import Fiat.Parsers.Reflective.ParserSyntax.
Require Import Fiat.Parsers.Reflective.Semantics.
Require Import Fiat.Parsers.Reflective.ParserSemantics.
Require Import Fiat.Parsers.Reflective.PartialUnfold.
Require Import Fiat.Parsers.Reflective.ParserPartialUnfold.
Require Import Fiat.Parsers.Reflective.ParserLogicalRelations.
Set Implicit Arguments.

Section polypnormalize.
  Context (is_valid_nonterminal : list nat -> nat -> bool)
          (strlen : nat)
          (char_at_matches_interp : nat -> Reflective.RCharExpr Ascii.ascii -> bool)
          (split_string_for_production : nat * (nat * nat) -> nat -> nat -> list nat).

  Let interp {T} := interp_has_parse_term (T := T) is_valid_nonterminal strlen char_at_matches_interp split_string_for_production.

  Lemma polypnormalize_correct {T} (term : polyhas_parse_term T)
    : ParserSyntaxEquivalence.has_parse_term_equiv
        nil
        (term interp_TypeCode) (term (normalized_of interp_TypeCode))
      -> interp (term _) = interp (polypnormalize term _).
  Proof.
    subst interp.
    apply polypnormalize_correct; assumption.
  Qed.
End polypnormalize.


(* 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 Bool.
Require Import Sumbool.
Require Import Arith.
Require Import ZArith NArith Nnat Ndec Ndigits.
From IntMap Require Import Allmaps.
Require Import Wf_nat.

Require Import BDDvar_ad_nat.
Require Import bdd1.
Require Import bdd2.
Require Import bdd3.
Require Import bdd4.
Require Import bdd5_1.
Require Import bdd5_2.
Require Import bdd6.
Require Import bdd7.
Require Import BDDdummy_lemma_2.
Require Import BDDdummy_lemma_3.
Require Import BDDdummy_lemma_4.
Require Import bdd8.
Require Import bdd9.
Require Import bdd10.
Require Import bdd11.

Definition is_tauto (be : bool_expr) :=
  Neqb BDDone
    (fst
       (snd (BDDof_bool_expr initBDDconfig initBDDneg_memo initBDDor_memo be))).

Definition is_valid (be : bool_expr) :=
  forall vb : var_binding, bool_fun_of_bool_expr be vb = true.

Lemma initBDDor_memo_OK : BDDor_memo_OK initBDDconfig initBDDor_memo.
Proof.
  unfold BDDor_memo_OK in |- *. intros. discriminate H.
Qed.

Lemma initBDDneg_memo_OK : BDDneg_memo_OK initBDDconfig initBDDneg_memo.
Proof.
  unfold BDDneg_memo_OK in |- *. intros. discriminate H.
Qed.

Lemma initBDDneg_memo_OK_2 : BDDneg_memo_OK_2 initBDDconfig initBDDneg_memo.
Proof.
  unfold BDDneg_memo_OK_2 in |- *. intros. discriminate H.
Qed.

Lemma is_tauto_is_correct :
 forall be : bool_expr, is_tauto be = true -> is_valid be.
Proof.
  unfold is_tauto, is_valid in |- *. intros.
  elim
   (BDDof_bool_expr_correct be initBDDconfig initBDDneg_memo initBDDor_memo
      initBDDconfig_OK initBDDneg_memo_OK_2 initBDDor_memo_OK).
  intros. elim H1. intros. elim H3. intros. elim H5. intros. elim H7. intros.
  rewrite <- (Neqb_complete _ _ H) in H9.
  exact
   (bool_fun_eq_trans _ _ _ (bool_fun_eq_symm _ _ H9)
      (bool_fun_of_BDDone _ H0) vb).
Qed.

Lemma is_tauto_is_complete :
 forall be : bool_expr, is_valid be -> is_tauto be = true.
Proof.
  unfold is_tauto, is_valid in |- *. intros.
  elim
   (BDDof_bool_expr_correct be initBDDconfig initBDDneg_memo initBDDor_memo
      initBDDconfig_OK initBDDneg_memo_OK_2 initBDDor_memo_OK).
  intros. elim H1. intros. elim H3. intros. elim H5. intros. elim H7. intros.
  rewrite <-
   (BDDunique
      (fst (BDDof_bool_expr initBDDconfig initBDDneg_memo initBDDor_memo be))
      H0 BDDone
      (fst
         (snd
            (BDDof_bool_expr initBDDconfig initBDDneg_memo initBDDor_memo be))))
   .
  reflexivity.
  unfold config_node_OK in |- *. unfold node_OK in |- *. right. left. reflexivity.
  exact H2.
  apply bool_fun_eq_symm.
  apply bool_fun_eq_trans with (bf2 := bool_fun_of_bool_expr be). exact H9.
  apply bool_fun_eq_trans with (bf2 := bool_fun_one). exact H.
  apply bool_fun_eq_symm. exact (bool_fun_of_BDDone _ H0).
Qed.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import ssrZ ZArith_ext seq_ext ssrnat_ext uniq_tac machine_int.
Require Import multi_int.
Import MachineInt.
Require Import mips_seplog mips_contrib mips_tactics mapstos.
Require Import mont_mul_prg.

Local Open Scope machine_int_scope.
Local Open Scope eqmod_scope.
Local Open Scope zarith_ext_scope.
Local Open Scope heap_scope.
Import expr_m.
Local Open Scope mips_expr_scope.
Import assert_m.
Local Open Scope mips_assert_scope.
Local Open Scope mips_cmd_scope.
Local Open Scope mips_hoare_scope.
Local Open Scope uniq_scope.
Local Open Scope multi_int_scope.

Lemma mont_square_triple (k alpha x z m one ext int_ X_ Y_ M_ Z_ quot C t s_ : reg) :
  uniq(k, alpha, x, z, m, one, ext, int_, X_, Y_, M_, Z_, quot, C, t, s_, r0) ->
  forall nk valpha vx vm vz X M,
    u2Z (M `32_ 0) * u2Z valpha =m -1 {{ \B^1 }} ->
    size X = nk -> size M = nk -> u2Z vz + 4 * Z_of_nat nk < \B^1 ->
    \S_{ nk } X < \S_{ nk } M ->
{{ fun s h => [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> nseq nk zero32 ** var_e m |--> M) s h /\ store.multi_null s }}
montgomery k alpha x x z m one ext int_ X_ Y_ M_ Z_ quot C t s_
{{ fun s h => exists Z, size Z = nk /\ [x]_s = vx /\ [z]_s = vz /\
  [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  \B^nk * \S_{ nk.+1 } (Z ++ [C]_s :: nil) =m \S_{ nk } X * \S_{ nk } X {{ \S_{ nk } M }} /\
  \S_{ nk.+1 } (Z ++ [C]_s :: nil) < 2 * \S_{ nk } M /\
  u2Z [t]_s = u2Z vz + 4 * Z_of_nat nk.-1 }}.
Proof.
move=> Hset nk valpha vx vm vz X M Halpha Hx Hm Hnz HX.
rewrite /montgomery.

(** addiu one r0 one16; *)

NextAddiu.
move=> s h [r_x [r_z [r_m [r_k [r_alpha [Hmem Hmu]]]]]].
rewrite /wp_addiu.
repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite store.multi_null_upd.

(** addiu C r0 zero16; *)

NextAddiu.
move=> s h [[r_x [r_z [r_m [r_k [r_alpha [Hmem Hmu]]]]]] r_one].
rewrite /wp_addiu.
repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite store.multi_null_upd.

(** addiu ext r0 zero16; *)

NextAddiu.
move=> s h [[[r_x [r_z [r_m [r_k [r_alpha [Hmem Hmu]]]]]] r_one] r_C].
rewrite /wp_addiu.
repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite store.multi_null_upd.

(** while (bne ext k) *)

apply hoare_prop_m.hoare_while_invariant with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\
  [alpha]_s = valpha /\ (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s <= u2Z [k]_s /\ [one]_s = one32 /\
  (next <> O -> u2Z [t]_s = u2Z vz + 4 * Z_of_nat nk.-1) /\
  (exists K, \B^next * \S_{nk.+1} (Z ++ [C]_s :: nil) = \S_{next} X * \S_{nk} X + K * \S_{nk} M /\
    \S_{next} X * \S_{nk} X + K * \S_{nk} M < 2 * \S_{nk} M * \B^next)).

move=> s h [[[[r_x [r_z [r_m [r_k [r_alpha [Hmem Hmu]]]]]] r_one] r_C] r_ext].
exists (nseq nk zero32), O; repeat (split => //).
by rewrite size_nseq.
by rewrite r_ext sext_Z2u // addi0 store.get_r0 Z2uK.
rewrite r_ext sext_Z2u // addi0 store.get_r0 Z2uK //; exact/min_u2Z.
apply u2Z_inj; by rewrite r_one sext_Z2u // store.get_r0 addC addi0 Z2uK.

exists 0.
have -> : nseq nk zero32 ++ [C ]_ s :: nil = nseq nk.+1 zero32.
  suff -> : [ C ]_s = zero32 by rewrite nseqS.
  apply u2Z_inj; by rewrite r_C sext_Z2u // addi0 store.get_r0.
rewrite lSum_nseq_0.
split; first by [].
(* about X * Y < M *)
rewrite mulZ1 !mul0Z add0Z; apply mulZ_gt0 => //.
apply (@leZ_ltZ_trans (\S_{ nk } X)) => //; exact: min_lSum.

move=> s h [[Z [next [HZ [r_x [r_z [r_m [r_k [r_alpha [Hmem [Hext [Hextk' [Hone [Ht Hinv]]]]]]]]]]]]] Hextk].
rewrite /= r_k Hext in Hextk; move/negPn/eqP/Z_of_nat_inj in Hextk; subst next.

exists Z; do 7 (split; trivial).
case: Hinv => K [Hinv1 Hinv2].
split; first by exists K.
split.
(* about X * Y < M *)
- apply/(@ltZ_pmul2r \B^nk).
  exact/Zbeta_gt0.
  by rewrite mulZC Hinv1.
apply Ht; by destruct nk.

(** lwxs X ext x; *)

apply hoare_lwxs_back_alt'' with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{nk.+1} (Z ++ [C]_s :: nil) = \S_{next} X * \S_{nk} X + K * \S_{nk} M /\
    \S_{next} X * \S_{nk} X + K * \S_{nk} M < 2 * \S_{nk} M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next).

move=> s h [ [Z [next [HZ [r_x [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Ht Hinv]]]]]]]]]]]]] Hextk].
rewrite /= r_ext r_k in Hextk, Hextk'.
move/eqP in Hextk; move/Nat2Z.inj_le/leP in Hextk'.
have {}Hextk : next <> nk by contradict Hextk; rewrite Hextk.
have {}Hextk' : (next < nk)%nat by rewrite ltn_neqAle Hextk' andbT; apply/eqP.
exists (X `32_ next); split.
- Decompose_32 X next X1 X2 HlenX1 HX'; last by rewrite Hx.
  rewrite HX' (decompose_equiv _ _ _ _ _ HlenX1) !assert_m.conAE assert_m.conCE !assert_m.conAE in Hmem.
  move: Hmem; apply monotony => // h'.
  apply mapsto_ext => //.
  by rewrite /= shl_Z2u r_ext inj_mult mulZC.
- rewrite /update_store_lwxs.
  exists Z, next; repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.
  rewrite r_ext r_k; exact/inj_lt_iff/leP.

(** lw Y zero16 y; *)

apply hoare_lw_back_alt'' with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{nk.+1} (Z ++ [C]_s :: nil) = \S_{next} X * \S_{nk} X + K * \S_{nk} M /\
    \S_{next} X * \S_{nk} X + K * \S_{nk} M < 2 * \S_{nk} M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\ [Y_]_s = X `32_ 0).

move=> s h [Z [next [HZ [r_x [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk r_X_]]]]]]]]]]]]]].

destruct X as [| hdx tlx]; first by destruct nk.
exists hdx; split.
rewrite [assert_m.mapstos _ _]/= !assert_m.conAE in Hmem.
move: Hmem; apply monotony => // h'.
apply mapsto_ext => //=; by rewrite sext_0 addi0.

rewrite /update_store_lw.
exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

(** lw Z_ zero16 z; *)

apply hoare_lw_back_alt'' with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{nk.+1} (Z ++ [C]_s :: nil) = \S_{next} X * \S_{nk} X + K * \S_{nk} M /\
    \S_{next} X * \S_{nk} X + K * \S_{nk} M < 2 * \S_{nk} M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\
  [Y_]_s = X `32_ 0 /\ [Z_]_s = Z `32_ 0).

move=> s h [Z [next [HZ [r_x [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk [r_X_ r_Y_]]]]]]]]]]]]]]].

destruct Z as [| hdz tlz]; first by destruct nk.
exists hdz; split.
rewrite assert_m.conAE assert_m.conCE /= !assert_m.conAE in Hmem.
move: Hmem; apply monotony => // h'.
apply mapsto_ext => //=; by rewrite sext_0 addi0.
rewrite /update_store_lw.
exists (hdz :: tlz), next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

(** multu X Y; *)

apply hoare_multu with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{nk.+1} (Z ++ [C]_s :: nil) = \S_{next} X * \S_{nk} X + K * \S_{nk} M /\
    \S_{next} X * \S_{nk} X + K * \S_{nk} M < 2 * \S_{nk} M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\
  [Y_]_s = X `32_ 0 /\ [Z_]_s = Z `32_ 0 /\
  store.utoZ s <= (\B^1 - 1) * (\B^1 - 1) /\
  store.utoZ s = u2Z (X `32_ next) * u2Z (X `32_ 0)).

move=> s h [Z [next [HZ [r_x [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk [r_X_ [r_Y_ r_Z_]]]]]]]]]]]]]]]].

exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
rewrite store.utoZ_multu; exact: max_u2Z_umul.
by rewrite store.utoZ_multu (@u2Z_umul 32) r_X_ r_Y_.

(** lw M zero16 m; *)

apply hoare_lw_back_alt'' with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{nk.+1} (Z ++ [C]_s :: nil) = \S_{next} X * \S_{nk} X + K * \S_{nk} M /\
    \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\ [Y_]_s = X `32_ 0 /\
  [Z_]_s = Z `32_ 0 /\ store.utoZ s <= (\B^1 - 1) * (\B^1 - 1) /\
  store.utoZ s = u2Z (X `32_ next) * u2Z (X `32_ 0) /\
  [M_]_s = M `32_ 0).

move=> s h [Z [next [HZ [r_x [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk [r_X_ [r_Y_ [r_Z_ [Hm1 Hm2]]]]]]]]]]]]]]]]]].
destruct M as [| hdm tlm]; first by destruct nk.
exists hdm; split.
do 2 rewrite assert_m.conCE /= !assert_m.conAE in Hmem.
move: Hmem; apply monotony => // h'.
apply mapsto_ext => //=; by rewrite sext_0 addi0.
exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

(** maddu Z_ one; *)

apply hoare_maddu with (fun s h => exists Z next, size Z = nk /\ [x]_s = vx /\
  [z]_s = vz /\ [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{nk.+1} (Z ++ [C]_s :: nil) = \S_{next} X * \S_{nk} X + K * \S_{nk}  M /\
    \S_{next} X * \S_{nk} X + K * \S_{nk} M < 2 * \S_{nk} M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\ [Y_]_s = X `32_ 0 /\
  [Z_]_s = Z `32_ 0 /\ store.utoZ s <= \B^1 * (\B^1 - 1) /\
  store.utoZ s = u2Z (X `32_ next) * u2Z (X `32_ 0) + u2Z (Z `32_ 0) /\
  [M_]_s = M `32_ 0).

move=> s h [Z [next [HZ [r_x [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk [r_X_ [r_Y_ [r_Z_ [Hm1 [Hm2 r_M_]]]]]]]]]]]]]]]]]]].

exists Z, next.
have Htmp : store.utoZ s < \B^2 * (2 ^^ store.acx_size - 1).
  apply (@leZ_ltZ_trans ((\B^1 - 1) * (\B^1 - 1))); first by [].
  apply (@ltZ_leZ_trans (\B^2 * (2 ^^ 8 - 1))); first by [].
  exact/leZ_wpmul2r.
repeat Reg_upd.
do 7 (split; trivial).
by Assert_upd.
do 8 (split; trivial).
split.
  rewrite store.utoZ_maddu // Hone umul_1 (@u2Z_zext 32) r_Z_.
  apply (@leZ_trans ((\B^1 - 1) + (\B^1 - 1) * (\B^1 - 1))) => //.
  apply leZ_add; first exact/leZsub1/max_u2Z.
  rewrite Hm2 -u2Z_umul; exact: max_u2Z_umul.
by rewrite store.utoZ_maddu // Hone umul_1 (@u2Z_zext 32) r_Z_ Hm2 addZC.

(** mflo t; *)

apply hoare_mflo with (fun s h => exists Z next, size Z = nk /\ [x]_s = vx /\
  [z]_s = vz /\ [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{nk.+1} (Z ++ [C]_s :: nil) = \S_{next} X * \S_{nk} X + K * \S_{nk} M /\
    \S_{next} X * \S_{nk} X + K * \S_{nk} M < 2 * \S_{nk} M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\ [Y_]_s = X `32_ 0 /\
  [Z_]_s = Z `32_ 0 /\ store.utoZ s <= \B^1 * (\B^1 - 1) /\
  store.utoZ s = u2Z (X `32_ next) * u2Z (X `32_ 0) + u2Z (Z `32_ 0) /\
  [M_]_s = M `32_ 0 /\
  [t]_s = ((X `32_ next `* X `32_ 0) `+ zext 32 (Z `32_ 0)) `% 32).

move=> s h [Z [next [HZ [r_x [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk [r_X_ [r_Y_ [r_Z_ [Hm1 [Hm2 r_M_]]]]]]]]]]]]]]]]]]].

exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

apply store.lo_remainder.
by rewrite -addnA leq_addl.

rewrite Hm2 u2Z_add //.
by rewrite u2Z_umul u2Z_zext.
rewrite u2Z_zext ZpowerD -Zbeta1E -ZbetaD /=.
apply (@leZ_ltZ_trans ((\B^1 - 1) * (\B^1 - 1) + (\B^1 - 1))); last by [].
apply leZ_add; [exact: max_u2Z_umul | exact/leZsub1/max_u2Z].

(** mfhi s; *)

apply hoare_mfhi with (fun s h => exists Z next, size Z = nk /\ [x]_s = vx /\
  [z]_s = vz /\ [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{nk.+1} (Z ++ [C]_s :: nil) = \S_{next} X * \S_{nk} X + K * \S_{nk} M /\
    \S_{next} X * \S_{nk} X + K * \S_{nk} M < 2 * \S_{nk} M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\ [Y_]_s = X `32_ 0 /\
  [Z_]_s = Z `32_ 0 /\ store.utoZ s <= \B^1 * (\B^1 - 1) /\
  store.utoZ s = u2Z (X `32_ next) * u2Z (X `32_ 0) + u2Z (Z `32_ 0) /\
  [M_]_s = M `32_ 0 /\
  [t]_s = ((X `32_ next `* X `32_ 0) `+ zext 32 (Z `32_ 0)) `% 32 /\
  u2Z ([s_]_s `|| [t]_s) = u2Z (X `32_ next) * u2Z (X `32_ 0) + u2Z (Z `32_ 0)).

move=> s h [Z [next [HZ [r_x [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk [ r_X_ [r_Y_ [r_Z_ [Hm1 [Hm2 [r_M_ r_t]]]]]]]]]]]]]]]]]]]].

exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

have H : store.lo s = [t]_s.
  rewrite r_t; apply store.lo_remainder.
  + by rewrite -addnA leq_addl.
  + rewrite Hm2 -u2Z_umul u2Z_add.
    * by rewrite u2Z_zext.
    * rewrite u2Z_zext ZpowerD -Zbeta1E -ZbetaD /=.
      apply (@leZ_ltZ_trans ((\B^1 - 1) * (\B^1 - 1) + (\B^1 - 1))); last by [].
      apply leZ_add; [exact: (@max_u2Z_umul 32) | exact/leZsub1/max_u2Z].

rewrite -H u2Z_concat -Zbeta1E.
rewrite store.utoZ_def store.utoZ_acx_beta2 in Hm2; last exact: (@leZ_ltZ_trans (\B^1 * (\B^1 - 1))).
rewrite Z2uK in Hm2; last by split; [exact: leZZ | exact: expZ_gt0].
rewrite -Hm2; ring.

(** multu t alpha; *)

apply hoare_multu with (fun s h => exists Z next, size Z = nk /\ [x]_s = vx /\
  [z]_s = vz /\ [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{nk.+1} (Z ++ [C]_s :: nil) = \S_{next} X * \S_{nk} X + K * \S_{nk} M /\
    \S_{next} X * \S_{nk} X + K * \S_{nk} M < 2 * \S_{nk} M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\ [Y_]_s = X `32_ 0 /\
  [Z_]_s = Z `32_ 0 /\ store.utoZ s <= (\B^1 - 1) * (\B^1 - 1) /\ [M_]_s = M `32_ 0 /\
  [t]_s = ((X `32_ next `* X `32_ 0) `+ zext 32 (Z `32_ 0)) `% 32 /\
  u2Z ([s_]_s `|| [t]_s) = u2Z (X `32_ next) * u2Z (X `32_ 0) + u2Z (Z `32_ 0) /\
  store.utoZ s = u2Z [t]_s * u2Z [alpha]_s).

move=> s h [Z [next [HZ [r_x [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk [r_X_ [r_Y_ [r_Z_ [Hm1 [Hm2 [r_M_  [r_t Hconcat]]]]]]]]]]]]]]]]]]]]].

exists Z, next; repeat Reg_upd.
do 6 (split; trivial).
split.
by Assert_upd.
do 8 (split; trivial).
split; first by rewrite store.utoZ_multu; exact: max_u2Z_umul.
do 3 (split; trivial).
by rewrite store.utoZ_multu -u2Z_umul.

(** addiu int_ r0 one16; *)

apply hoare_addiu with (fun s h => exists Z next, size Z = nk /\ [x]_s = vx /\
  [z]_s = vz /\ [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{nk.+1} (Z ++ [C]_s :: nil) = \S_{next} X * \S_{nk} X + K * \S_{nk} M /\
    \S_{next} X * \S_{nk} X + K * \S_{nk} M < 2 * \S_{nk} M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\ [Y_]_s = X `32_ 0 /\
  [Z_]_s = Z `32_ 0 /\ store.utoZ s <= (\B^1 - 1) * (\B^1 - 1) /\ [M_]_s = M `32_ 0 /\
  [t]_s = ((X `32_ next `* X `32_ 0) `+ zext 32 (Z `32_ 0)) `% 32 /\
  u2Z ([s_]_s `|| [t]_s) = u2Z (X `32_ next) * u2Z (X `32_ 0) + u2Z (Z `32_ 0) /\
  store.utoZ s = u2Z [t]_s * u2Z [alpha]_s /\ [int_]_s = one32).

move=> s h [Z [next [HZ [r_x [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk [ r_X_ [r_Y_ [r_Z_ [Hm1 [r_M_ [r_t [Hconcat Hm2]]]]]]]]]]]]]]]]]]]]].

exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite add0i sext_Z2u.

(** mflo quot; *)

apply hoare_mflo with (fun s h => exists Z next, size Z = nk /\ [x]_s = vx /\
  [z]_s = vz /\ [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{nk.+1} (Z ++ [C]_s :: nil) = \S_{next} X * \S_{nk} X + K * \S_{nk} M /\
    \S_{next} X * \S_{nk} X + K * \S_{nk} M < 2 * \S_{nk} M * \B^next) /\ (next < nk)%nat /\
  [X_]_s = X `32_ next /\ [Y_]_s = X `32_ 0 /\ [Z_]_s = Z `32_ 0 /\
  store.utoZ s <= (\B^1 - 1) * (\B^1 - 1) /\ [M_]_s = M `32_ 0 /\
  [t]_s = ((X `32_ next `* X `32_ 0) `+ zext 32 (Z `32_ 0)) `% 32 /\
  u2Z ([s_]_s `|| [t]_s) = u2Z (X `32_ next) * u2Z (X `32_ 0) + u2Z (Z `32_ 0) /\
  store.utoZ s = u2Z [t]_s * u2Z [alpha]_s /\ [int_]_s = one32 /\
  [quot]_s = (((X `32_ next `* X `32_ 0) `+ (zext 32 (Z `32_ 0)) `% 32) `* [alpha]_s) `% 32).

move=> s h [Z [next [HZ [r_x [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk [ r_X_ [r_Y_ [ r_Z_ [Hm1 [r_M_ [r_t [Hconcat [Hm2 Hgrpint_]]]]]]]]]]]]]]]]]]]]]].

exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

apply store.lo_remainder.
- by rewrite -addnA leq_addl.
- by rewrite Hm2 r_t -u2Z_umul.

(** mthi s; *)

apply hoare_mthi with (fun s h => exists Z next, size Z = nk /\ [x]_s = vx /\
  [z]_s = vz /\ [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{nk.+1} (Z ++ [C]_s :: nil) = \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M  /\
    \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\ (next < nk)%nat /\
  [X_]_s = X `32_ next /\ [Y_]_s = X `32_ 0 /\ [Z_]_s = Z `32_ 0 /\
  store.utoZ s < \B^2 /\ [M_]_s = M `32_ 0 /\
  [t]_s = ((X `32_ next `* X `32_ 0) `+ zext 32 (Z `32_ 0)) `% 32 /\
  u2Z ([s_]_s `|| [t]_s) = u2Z (X `32_ next) * u2Z (X `32_ 0) + u2Z (Z `32_ 0) /\
  [int_]_s = one32 /\
  [quot]_s = ((((X `32_ next `* X `32_ 0) `+ zext 32 (Z `32_ 0)) `% 32) `* [alpha]_s) `% 32 /\
  store.hi s = [s_]_s).

move=> s h [Z [next [HZ [r_x [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk [r_X_ [r_Y_ [ r_Z_ [Hm1 [r_M_  [r_t [Hconcat [Hm2 [Hgrpint_ r_quot]]]]]]]]]]]]]]]]]]]]]]].

exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
rewrite store.utoZ_def store.hi_mthi_op store.acx_mthi_op store.lo_mthi_op store.utoZ_acx_beta2; last first.
  rewrite Hm2.
  apply (@leZ_ltZ_trans ((\B^1 - 1) * (\B^1 - 1))); last by [].
  rewrite -u2Z_umul; exact: max_u2Z_umul.
rewrite Z2uK // addZ0.
apply (@leZ_ltZ_trans ((\B^1 - 1) + (\B^1 - 1) * \B^1)); last by [].
apply leZ_add; first exact/leZsub1/max_u2Z.
apply leZ_wpmul2r => //.
exact/leZsub1/max_u2Z.
exact: store.hi_mthi_op.

(** mtlo t; *)

apply hoare_mtlo with  (fun s h => exists Z next, size Z = nk /\ [x]_s = vx /\
  [z]_s = vz /\ [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{nk.+1} (Z ++ [C]_s :: nil) = \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\ [Y_]_s = X `32_ 0 /\
  [Z_]_s = Z `32_ 0 /\ store.utoZ s < \B^2 /\ [M_]_s = M `32_ 0 /\
  [t]_s = ((X `32_ next `* X `32_ 0) `+ zext 32 (Z `32_ 0)) `% 32 /\
  u2Z ([s_]_s `|| [t]_s) = u2Z (X `32_ next) * u2Z (X `32_ 0) + u2Z (Z `32_ 0) /\
  [int_]_s = one32 /\
  [quot]_s = ((((X `32_ next `* X `32_ 0) `+ zext 32 (Z `32_ 0)) `% 32) `* [alpha]_s) `% 32 /\
  store.hi s = [s_]_s /\ store.lo s = [t]_s).

move=> s h [Z [next [HZ [r_x [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk [ r_X_ [r_Y_ [r_Z_ [Hm1 [r_M_  [r_t [ Hconcat [Hgrpint_ [r_quot Hm2]]]]]]]]]]]]]]]]]]]]]]].

exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

rewrite store.utoZ_def store.acx_mtlo_op store.lo_mtlo_op store.hi_mtlo_op store.utoZ_acx_beta2 // Z2uK //= addZ0.
apply (@leZ_ltZ_trans ((\B^1 - 1) + (\B^1 - 1) * \B^1)); last by [].
apply leZ_add; first exact/leZsub1/max_u2Z.
apply leZ_wpmul2r => //.
exact/leZsub1/max_u2Z.
rewrite -Hm2.
exact: store.hi_mtlo_op.
exact: store.lo_mtlo_op.

(** maddu quot M; *)

apply hoare_maddu with (fun s h => exists Z next, size Z = nk /\ [x]_s = vx /\
  [z]_s = vz /\ [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{nk.+1} (Z ++ [C]_s :: nil) = \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M  /\
    \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\
  [Y_]_s = X `32_ 0 /\ [Z_]_s = Z `32_ 0 /\
  [M_]_s = M `32_ 0 /\ [int_]_s = one32 /\
  [quot]_s = ((((X `32_ next `* X `32_ 0) `+ zext 32 (Z `32_ 0)) `% 32) `* [alpha]_s) `% 32 /\
  store.utoZ s = u2Z [quot]_s * u2Z (M `32_ 0) +
  u2Z (X `32_ next) * u2Z (X `32_ 0) + u2Z (Z `32_ 0) /\ store.lo s = zero32).

move=> s h [Z [next [HZ [r_x [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk [r_X_ [r_Y_ [r_Z_ [Hm1 [r_M_  [r_t [Hconcat [Hgrpint_ [r_quot [Hm2 Hm3]]]]]]]]]]]]]]]]]]]]]]]].

exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
rewrite store.utoZ_maddu.
rewrite r_M_ -u2Z_umul store.utoZ_def store.utoZ_acx_beta2 // Z2uK.
by rewrite Hm2 Hm3 (addZC (u2Z [t]_s)) -u2Z_concat Hconcat mul0Z addZ0 addZA.
split; [exact: leZZ | exact: expZ_gt0].
exact: (@ltZ_leZ_trans (\B^2 * 1)).

rewrite r_quot; apply montgomery_lemma => //.
by rewrite r_M_ r_alpha.
rewrite store.utoZ_def store.utoZ_acx_beta2 // Z2uK.
rewrite mul0Z addZ0 addZC -u2Z_concat Hm2 Hm3 Hconcat -u2Z_umul u2Z_add.
rewrite (@u2Z_zext 32) // u2Z_zext.
apply (@leZ_ltZ_trans ((\B^1 - 1) * (\B^1 - 1) + (\B^1 - 1))); last by [].
apply leZ_add; first exact: (@max_u2Z_umul 32).
rewrite (@u2Z_zext 32) //; exact/leZsub1/max_u2Z.
by split; [exact: leZZ | exact: expZ_gt0].

(** mflhxu Z_; *)

apply hoare_mflhxu with (fun s h => exists Z next, size Z = nk /\ [x]_s = vx /\
  [z]_s = vz /\ [m]_s = vm /\ [one]_s = one32 /\ u2Z [k]_s = Z_of_nat nk /\
  [alpha]_s = valpha /\ (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\
  (exists K, \B^next * \S_{nk.+1} (Z ++ [C]_s :: nil) = \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\
  [Y_]_s = X `32_ 0 /\ [M_]_s = M `32_ 0 /\ [int_]_s = one32 /\
  [quot]_s = ((((X `32_ next `* X `32_ 0) `+ zext 32 (Z `32_ 0)) `% 32) `* [alpha]_s) `% 32 /\
  \B^1 * u2Z (store.hi s `|| store.lo s) =
  u2Z ([quot]_s) * u2Z (M `32_ 0) + u2Z (X `32_ next) * u2Z (X `32_ 0) + u2Z (Z `32_ 0) /\
  store.utoZ s < 2 * \B^1 - 2).

move=> s h [Z [next [HZ [r_x [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk [ r_X_ [r_Y_ [r_Z_ [r_M_ [r_int_ [Hquot [Hm2 Hm3]]]]]]]]]]]]]]]]]]]]].

exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

rewrite u2Z_concat store.hi_mflhxu_op store.lo_mflhxu_op -Hm2 store.utoZ_def.
have -> : \B^2 = \B^1 * \B^1 by rewrite -ZbetaD.
rewrite u2Z_zext Hm3 Z2uK // -Zbeta1E.
repeat Reg_upd; ring.

apply store.mflhxu_kbeta1_utoZ.
apply (@leZ_ltZ_trans ((\B^1 - 1) * (\B^1 - 1) + (\B^1 - 1) * (\B^1 - 1) + (\B^1 - 1))); last by [].
rewrite store.utoZ_upd Hm2; apply leZ_add.
apply leZ_add; rewrite -u2Z_umul; exact: max_u2Z_umul.
exact/leZsub1/max_u2Z.

(** addiu t z zero16; *)

apply hoare_addiu with  (fun s h => exists Z next, size Z = nk /\ [x]_s = vx /\
  [z]_s = vz /\ [m]_s = vm /\ [one]_s = one32 /\ u2Z [k]_s = Z_of_nat nk /\
  [alpha]_s = valpha /\ (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\
  (exists K, \B^next * \S_{nk.+1} (Z ++ [C]_s :: nil) = \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M  /\
    \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\
  [Y_]_s = X `32_ 0 /\ [M_]_s = M `32_ 0 /\ [int_]_s = one32 /\
  [quot]_s = ((((X `32_ next `* X `32_ 0) `+ zext 32 (Z `32_ 0)) `% 32) `* [alpha]_s) `% 32 /\
  \B^1 * u2Z (store.hi s `|| store.lo s) =
  u2Z [quot]_s * u2Z (M `32_ 0) + u2Z (X `32_ next) * u2Z (X `32_ 0) + u2Z (Z `32_ 0) /\
  store.utoZ s < 2 * \B^1 - 2 /\ [t]_s = vz).

move=> s h [Z [next [HZ [r_x [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hinv [Hextk [r_X_ [r_Y_ [r_M_  [r_int_ [Hquot [Hm2 Hm3]]]]]]]]]]]]]]]]]]].

exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

by rewrite sext_Z2u // addi0.

(** while (bne int_ k) *)

apply (hoare_prop_m.hoare_stren (fun s h => exists Z next nint_, size Z = nk /\
  [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\ [one]_s = one32 /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (next < nk)%nat /\ [X_]_s = X `32_ next /\
  u2Z [int_]_s = Z_of_nat nint_ /\ (1 <= nint_)%nat /\ u2Z [int_]_s <= u2Z [k]_s /\
  store.utoZ s < 2 * \B^1 - 1 /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nint_ - 1) /\
  (exists K, \B^next.+1 * Sum_hole nk.+1 nint_.-1 (Z ++ [C]_s :: nil) +
    u2Z (store.hi s `|| store.lo s) * \B^(next + nint_) =
    \S_{ next } X * \S_{ nk } X + \S_{ nint_ } X * u2Z (X `32_ next) * \B^next +
    \S_{ nint_ } M * u2Z [quot]_s * \B^next + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next))).

move=> s h [Z [next [HZ [r_x [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hinv [Hextk [r_X_ [r_Y_ [r_M_  [r_int_ [Hquot [Hm2 [Hm3 r_t]]]]]]]]]]]]]]]]]]]].

exists Z, next, 1%nat.
repeat (split; trivial).

by rewrite r_int_ Z2uK.
rewrite r_int_ r_k Z2uK // (_ : 1 = Z_of_nat 1) //.
by apply/inj_le/leP; apply: leq_ltn_trans Hextk.
exact: (@ltZ_leZ_trans (2 * \B^1 - 2)).
rewrite r_t; ring.

case: Hinv => K [Hinv1 Hinv2].
exists K; split; last by [].
rewrite Sum_hole_last'; last by rewrite size_cat /= HZ addnC.
rewrite addn1.
have -> : u2Z (store.hi s `|| store.lo s) * \B^next.+1 =
  \B^next * (\B^1 * u2Z (store.hi s `|| store.lo s)) by rewrite -(addn1 next) ZbetaD; ring.
rewrite subn1.
have -> : \B^next.+1 * \S_{ nk } (List.tail (Z ++ [C]_s :: nil)) =
  \B^next * (\B^1 * \S_{ nk } (List.tail (Z ++ [C]_s :: nil))) by rewrite Zbeta_S; ring.
rewrite lSum_Zpower_Zmult Hquot.
apply trans_eq with (\B^next *
  (\S_{nk.+1} (zero32 :: List.tail (Z ++ [C]_s :: nil)) + u2Z (Z `32_ 0)) +
  \B^next * (u2Z [quot]_s * u2Z (M `32_ 0) + u2Z (X `32_ next) * u2Z (X `32_ 0))).
- rewrite Hm2.
  set tmp := \S_{ _ } _.
  ring.
- rewrite lSum_head_swap0 tail_app; last by rewrite HZ; destruct nk => //; apply lt_O_Sn.
  rewrite List.app_comm_cons.
  move: (@list_tail _ zero32 Z) => ->; last by rewrite HZ; destruct nk => //; apply lt_O_Sn.
  rewrite Hquot Hinv1 2!lSum_1 /zero32 /nth'; ring.

apply while.hoare_seq with (fun s h => (exists Z next nint_, size Z = nk /\
  [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\ [one]_s = one32 /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (next < nk)%nat /\ [X_]_s = X `32_ next /\
  u2Z [int_]_s = Z_of_nat nint_ /\ (1 <= nint_)%nat /\ u2Z [int_]_s <= u2Z [k]_s /\
  store.utoZ s < 2 * \B^1 - 1 /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nint_ - 1) /\
  (exists K, \B^next.+1 * Sum_hole nk.+1 nint_.-1 (Z ++ [C]_s :: nil) +
    u2Z (store.hi s `|| store.lo s) * \B^(next + nint_) =
    \S_{ next } X * \S_{ nk } X + \S_{ nint_ } X * u2Z (X `32_ next) * \B^next +
    \S_{ nint_ } M * u2Z [quot]_s * \B^next + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next))
/\ ~~ (eval_b (bne int_ k) s)).

apply while.hoare_while.

(**  lwxs Y int_ y; *)

apply hoare_lwxs_back_alt'' with (fun s h => exists Z next nint_, size Z = nk /\
  [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\
  [one]_s = one32 /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\ u2Z [ext]_s = Z_of_nat next /\
  (next < nk)%nat /\ (nint_ < nk)%nat /\ [X_]_s = X `32_ next /\
  u2Z [int_]_s = Z_of_nat nint_ /\ (1 <= nint_)%nat /\
  store.utoZ s < 2 * \B^1 - 1 /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nint_ - 1) /\
  (exists K, \B^next.+1 * Sum_hole nk.+1 nint_.-1 (Z ++ [C]_s :: nil) +
    u2Z (store.hi s `|| store.lo s) * \B^(next + nint_) =
    \S_{ next } X * \S_{ nk } X + \S_{ nint_ } X * u2Z (X `32_ next) * \B^next +
    \S_{ nint_ } M * u2Z [quot]_s * \B^next + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\
  [Y_]_s = X `32_ nint_).

move=> s h [[Z [next [nint_ [HZ [r_x [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk'  [r_X_ [r_int_ [Hint_ [r_int_' [Hm2 [r_t Hinv]]]]]]]]]]]]]]]]]]] Hint_k].
rewrite /= in Hint_k. move/eqP in Hint_k; rewrite r_int_ r_k in Hint_k.
have {}Hint_k : nint_ <> nk by contradict Hint_k; rewrite Hint_k.
have {}r_int_' : (nint_ < nk)%nat.
  rewrite r_int_ r_k in r_int_'; move/Nat2Z.inj_le/leP in r_int_'.
  rewrite ltn_neqAle r_int_' andbT; exact/eqP.

exists (X `32_ nint_); split.
- Decompose_32 X nint_ X1 X2 HlenX1 HX'; last by rewrite Hx.
  rewrite HX' (decompose_equiv _ _ _ _ _ HlenX1) !assert_m.conAE assert_m.conCE !assert_m.conAE in Hmem.
  move: Hmem; apply monotony => // h'.
  apply mapsto_ext => //.
  by rewrite /= shl_Z2u r_int_ inj_mult mulZC.
- rewrite /update_store_lwxs.
  exists Z, next, nint_; repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.

(** lwxs Z int_ z; *)

apply hoare_lwxs_back_alt'' with (fun s h => exists Z next nint_, size Z = nk /\
  [x]_s = vx /\  [z]_s = vz /\ [m]_s = vm /\ [one]_s = one32 /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (next < nk)%nat /\ (nint_ < nk)%nat /\
  [X_]_s = X `32_ next /\ u2Z [int_]_s = Z_of_nat nint_ /\ (1 <= nint_)%nat /\
  store.utoZ s < 2 * \B^1 - 1 /\ u2Z [t]_s = u2Z [z]_s + 4 * (Z_of_nat nint_ - 1) /\
  (exists K, \B^next.+1 * Sum_hole nk.+1 nint_.-1 (Z ++ [C]_s :: nil) +
    u2Z (store.hi s `|| store.lo s) * \B^(next + nint_) =
    \S_{ next } X * \S_{ nk } X + \S_{ nint_ } X * u2Z (X `32_ next) * \B^next +
    \S_{ nint_ } M * u2Z [quot]_s * \B^next + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\
  [Y_]_s = X `32_ nint_ /\ [Z_]_s = Z `32_ nint_).

move=> s h [Z [next [nint_ [HZ [r_x [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk' [Hint_' [r_X_ [r_int_' [Hint_ [Hm2 [r_t [Hinv r_Y_]]]]]]]]]]]]]]]]]]]].

exists (Z `32_ nint_); split.
- Decompose_32 Z nint_ Z1 Z2 HlenZ1 HZ'; last by rewrite HZ.
  rewrite HZ' (decompose_equiv _ _ _ _ _ HlenZ1) !assert_m.conAE assert_m.conCE !assert_m.conAE assert_m.conCE !assert_m.conAE in Hmem.
  move: Hmem; apply monotony => // h'.
  apply mapsto_ext => //.
  by rewrite /= shl_Z2u r_int_' inj_mult mulZC.
- exists Z, next, nint_; repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.
  by rewrite r_t r_z.

(** maddu X Y; *)

apply hoare_maddu with (fun s h => exists Z next nint_, size Z = nk /\
  [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\ [one]_s = one32 /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (next < nk)%nat /\ (nint_ < nk)%nat /\
  [X_]_s = X `32_ next /\ u2Z [int_]_s = Z_of_nat nint_ /\ (1 <= nint_)%nat /\
  store.utoZ s < \B^2 /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nint_ - 1) /\
  [Y_]_s = X `32_ nint_ /\ [Z_]_s = Z `32_ nint_ /\
  (exists K, \B^next.+1 * Sum_hole nk.+1 nint_.-1 (Z ++ [C]_s :: nil) +
    store.utoZ s * \B^(next + nint_) = \S_{ next } X * \S_{ nk } X +
    \S_{ nint_ } X * u2Z (X `32_ next) * \B^next +
    \S_{ nint_ } M * u2Z [quot]_s * \B^next +
    u2Z (X `32_ next) * u2Z (X `32_ nint_) * \B^(next + nint_) + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next)).

move=> s h [Z [next [nint_ [HZ [r_x [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk' [Hint_' [ r_X_ [r_int_' [Hint_ [Hm2 [r_t [Hinv [r_Y_ r_Z_]]]]]]]]]]]]]]]]]]]]].

exists Z, next, nint_.

have Htmp : store.utoZ s < \B^2 * (2 ^^ store.acx_size - 1) by exact: (@ltZ_leZ_trans (2 * \B^1 - 1)).

repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
rewrite store.utoZ_maddu //.
apply (@ltZ_leZ_trans ((\B^1 - 1) * (\B^1 - 1) + (2 * \B^1 - 1))); last by [].
apply leZ_lt_add; by [exact: max_u2Z_umul | ].
by rewrite r_t r_z.

case: Hinv => K [Hinv1 Hinv2].
exists K; split; last by []. (* about X * Y < M *)
apply trans_eq with (\S_{ next } X * \S_{ nk } X +
 \S_{ nint_ } X * u2Z (X `32_ next) * \B^next + \S_{ nint_ } M * u2Z [quot]_s * \B^next +
 K * \S_{ nk } M + u2Z (X `32_ next) * u2Z (X `32_ nint_) * \B^(next + nint_)).
- rewrite store.utoZ_maddu // store.utoZ_def store.utoZ_acx_beta2 //; last first.
    exact: (@ltZ_leZ_trans (2 * \B^1 - 1)).
  rewrite Z2uK // -u2Z_umul -Hinv1 u2Z_concat addZ0 r_Y_ r_X_ // -addZA.
  f_equal.
  rewrite (addZC (u2Z (X `32_ next `* X `32_ nint_))) mulZDl mulZDl.
  f_equal.
  by rewrite mulZDl addZC.
- ring.

(** lwxs M int_ m; *)

apply hoare_lwxs_back_alt'' with (fun s h => exists Z next nint_, size Z = nk /\
  [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\ [one]_s = one32 /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s =  Z_of_nat next /\ (next < nk)%nat /\ (nint_ < nk)%nat /\
  [X_]_s = X `32_ next /\ u2Z [int_]_s =  Z_of_nat nint_ /\ (1 <= nint_)%nat /\
  store.utoZ s < \B^2 /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nint_ - 1) /\
  [Y_]_s = X `32_ nint_ /\ [Z_]_s = Z `32_ nint_ /\
  (exists K, \B^next.+1 * Sum_hole nk.+1 nint_.-1 (Z ++ [C]_s :: nil) +
    store.utoZ s * \B^(next + nint_) = \S_{ next } X * \S_{ nk } X +
    \S_{ nint_ } X * u2Z (X `32_ next) * \B^next +
    \S_{ nint_ } M * u2Z [quot]_s * \B^next +
    u2Z (X `32_ next) * u2Z (X `32_ nint_) * \B^(next + nint_) + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next)
  /\ [M_]_s = M `32_ nint_ ).

move=> s h [Z [next [nint_ [HZ [r_x [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk' [Hint_' [r_X_ [r_int_' [Hint_ [Hm2 [r_t [r_Y_ [r_Z_ Hinv]]]]]]]]]]]]]]]]]]]]].

exists (M `32_ nint_); split.
- Decompose_32 M nint_ M1 M2 HlenM1 HM'; last by rewrite Hm.
  rewrite HM' (decompose_equiv _ _ _ _ _ HlenM1) in Hmem.
  do 3 rewrite assert_m.conCE !assert_m.conAE in Hmem.
  move: Hmem; apply monotony => // h'.
  apply mapsto_ext => //.
  by rewrite /= shl_Z2u r_int_' inj_mult mulZC.
- exists Z, next, nint_; repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.

(** maddu Z_ one; *)

apply hoare_maddu with (fun s h => exists Z next nint_, size Z = nk /\
  [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\ [one]_s = one32 /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (next < nk)%nat /\ (nint_ < nk)%nat /\
  [X_]_s = X `32_ next /\ u2Z [int_]_s = Z_of_nat nint_ /\ (1 <= nint_)%nat /\
  store.utoZ s < \B^2 + \B^1 - 1 /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nint_ - 1) /\
  [Y_]_s = X `32_ nint_ /\ [Z_]_s = Z `32_ nint_ /\ [M_]_s = M `32_ nint_ /\
  (exists K, \B^next.+1 * Sum_hole nk.+1 nint_.-1 (Z ++ [C]_s :: nil) +
    store.utoZ s * \B^(next + nint_) = \S_{ next } X * \S_{ nk } X +
    \S_{ nint_ } X * u2Z (X `32_ next) * \B^next +
    \S_{ nint_ } M * u2Z [quot]_s * \B^next +
    u2Z (X `32_ next) * u2Z (X `32_ nint_) * \B^(next + nint_) +
    u2Z (Z `32_ nint_) * \B^(next + nint_) + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next)).

move=> s h [Z [next [nint_ [HZ [r_x [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk' [ Hint_' [r_X_ [r_int_' [Hint_ [Hm2 [r_t [r_Y_ [r_Z_ [Hinv r_M_]]]]]]]]]]]]]]]]]]]]]].

exists Z, next, nint_.

have Htmp : store.utoZ s < \B^2 * (2 ^^ store.acx_size - 1).
  exact: (@ltZ_leZ_trans (\B^2 * 1)).

repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
rewrite store.utoZ_maddu //.
apply (@ltZ_leZ_trans ((\B^1 - 1) + \B^2)); last by [].
apply leZ_lt_add; last by [].
rewrite Hone umul_1 (@u2Z_zext 32) //.
exact/leZsub1/max_u2Z.

case: Hinv => K [Hinv1 Hinv2].
exists K; split; last by []. (* about X * Y < M *)
rewrite store.utoZ_maddu // Hone umul_1 (@u2Z_zext 32) //.
apply trans_eq with (\B^next.+1 * Sum_hole nk.+1 nint_.-1 (Z ++ [C]_s :: nil) +
     store.utoZ s * \B^(next + nint_) + u2Z (Z `32_ nint_) * \B^(next + nint_)).
by rewrite -r_Z_ {1}(addZC (u2Z [Z_]_s)) mulZDl addZA.
rewrite Hinv1; ring.

(** maddu quot M; *)

apply hoare_maddu with (fun s h => exists Z next nint_, size Z = nk /\
  [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\ [one]_s = one32 /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (next < nk)%nat /\ (nint_ < nk)%nat /\
  [X_]_s = X `32_ next /\ u2Z [int_]_s = Z_of_nat nint_ /\ (1 <= nint_)%nat /\
  store.utoZ s < 2 * \B^2 - \B^1 /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nint_ - 1) /\
  [Y_]_s = X `32_ nint_ /\ [Z_]_s = Z `32_ nint_ /\ [M_]_s = M `32_ nint_ /\
  (exists K, \B^next.+1 * Sum_hole nk.+1 nint_.-1 (Z ++ [C]_s :: nil) +
    store.utoZ s * \B^(next + nint_) = \S_{ next } X * \S_{ nk } X +
    \S_{ nint_ } X * u2Z (X `32_ next) * \B^next +
    \S_{ nint_ } M * u2Z [quot]_s * \B^next +
    u2Z (X `32_ next) * u2Z (X `32_ nint_) * \B^(next + nint_) +
    u2Z (Z `32_ nint_) * \B^(next + nint_) +
    u2Z (M `32_ nint_) * u2Z [quot]_s * \B^(next + nint_) + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next)).

move=> s h [Z [next [nint_ [HZ [r_x [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk' [Hint_' [r_X_ [r_int_' [Hint_ [Hm2 [r_t [r_Y_ [r_Z_ [r_M_ Hinv]]]]]]]]]]]]]]]]]]]]]].
exists Z, next, nint_.

have Htmp : store.utoZ s < \B^2 * (2 ^^ store.acx_size - 1) by exact: (@ltZ_leZ_trans (\B^2 + \B^1 - 1)).

repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
repeat (split; trivial).

rewrite store.utoZ_maddu //.
apply (@ltZ_leZ_trans ((\B^1 - 1) * (\B^1 - 1) + (\B^2 + \B^1 - 1))); last by [].
apply leZ_lt_add => //; exact: max_u2Z_umul.

case: Hinv => K [Hinv1 Hinv2].
exists K; split; last by []. (* about X * Y < M *)
rewrite store.utoZ_maddu // mulZDl.
apply trans_eq with (\B^next.+1 * Sum_hole nk.+1 nint_.-1 (Z ++ [C]_s :: nil) +
  store.utoZ s * \B^(next + nint_) + (u2Z ([quot]_s `* [M_]_s) * \B^(next + nint_))).
by rewrite (addZC (u2Z ([quot]_s `* [M_]_s) * \B^(next + nint_))) addZA.
rewrite Hinv1 u2Z_umul r_M_; ring.

(** addiu int_ int_ one16; *)

apply hoare_addiu with (fun s h => exists Z next nint_, size Z = nk /\
  [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\ [one]_s = one32 /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (next < nk)%nat /\ (nint_ <= nk)%nat /\
  [X_]_s = X `32_ next /\ u2Z [int_]_s = Z_of_nat nint_ /\ (2 <= nint_)%nat /\
  store.utoZ s < 2 * \B^2 - \B^1  /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nint_ - 2) /\
  (exists K, \B^next.+1 * Sum_hole nk.+1 nint_.-2 (Z ++ [C]_s :: nil) +
    store.utoZ s * \B^((next + nint_).-1) = \S_{ next } X * \S_{ nk } X +
    \S_{nint_.-1} X * u2Z (X `32_ next) * \B^next +
    \S_{nint_.-1} M * u2Z [quot]_s * \B^next +
    u2Z (X `32_ next) * u2Z (X `32_ nint_.-1)  * \B^((next + nint_).-1)+
    u2Z (Z `32_ nint_.-1) * \B^((next + nint_).-1) +
    u2Z (M `32_ nint_.-1) * u2Z [quot]_s * \B^((next + nint_).-1) + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next)).

move=> s h [Z [next [nint_ [HZ [r_x [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk'  [Hint_' [r_X_ [r_int_' [Hint_ [Hm2 [r_t [r_Y_ [r_Z_ [r_M_ Hinv]]]]]]]]]]]]]]]]]]]]]].

exists Z, next, nint_.+1; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

rewrite sext_Z2u // u2Z_add_Z2u //.
- by rewrite r_int_' Z_S.
- rewrite r_int_'.
  apply (@leZ_ltZ_trans (Z_of_nat nk)).
  rewrite (_ : 1 = Z_of_nat 1) //. by omegaz' ssromega. (*-inj_plus plus_comm; exact/inj_le/leP.*)
  apply: leZ_ltZ_trans; last exact/Hnz.
  apply leZ_addl; first exact: min_u2Z.
  rewrite mulZC; apply Zle_scale; [exact/Zle_0_nat | by [] ].

rewrite r_t Z_S; ring.

case: Hinv => K [Hinv1 Hinv2].
exists K; split; last by []. (* about X * Y < M *)
by rewrite addnS /= Hinv1.

(** mflhxu Z_; *)

apply hoare_mflhxu with (fun s h => exists Z next nint_, size Z = nk /\
  [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\
  [one]_s = one32 /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\ u2Z [ext]_s = Z_of_nat next /\
  (next < nk)%nat /\ (nint_ <= nk)%nat /\ [X_]_s = X `32_ next /\
  u2Z [int_]_s = Z_of_nat nint_ /\ (2 <= nint_)%nat /\
  store.utoZ s < 2 * \B^1 - 1 /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nint_ - 2) /\
  (exists K, \B^next.+1 * Sum_hole nk.+1 nint_.-2 (Z ++ [C]_s :: nil) +
    u2Z (store.hi s `|| store.lo s) * \B^(next + nint_) +
    u2Z [Z_]_s * \B^((next + nint_).-1) = \S_{ next } X * \S_{ nk } X +
    \S_{nint_.-1} X * u2Z (X `32_ next) * \B^next +
    \S_{nint_.-1} M * u2Z [quot]_s * \B^next +
    u2Z (X `32_ next) * u2Z (X `32_ nint_.-1)  * \B^((next + nint_).-1) +
    u2Z (Z `32_ nint_.-1) * \B^((next + nint_).-1) +
    u2Z (M `32_ nint_.-1) * u2Z [quot]_s * \B^((next + nint_).-1) + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next)).

move=> s h [Z [next [nint_ [HZ [r_x [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk' [Hint_' [r_X_ [r_int_' [Hint_ [Hm2 [r_t Hinv]]]]]]]]]]]]]]]]]]].

exists Z, next, nint_; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

apply store.mflhxu_kbeta1_utoZ.
apply (@ltZ_leZ_trans (2 * \B^2 - \B^1)); by [rewrite store.utoZ_upd | ].
case: Hinv => K [Hinv1 Hinv2].
exists K; split; last by [].  (* about X * Y < M *)

rewrite -Hinv1 u2Z_concat store.hi_mflhxu_op store.lo_mflhxu_op u2Z_zext store.utoZ_def -addZA.
f_equal.
rewrite -Zbeta1E /= 3!mulZDl -3!mulZA -3!ZbetaD.
rewrite 2!add1n add2n prednK; last by rewrite addn_gt0 (ltn_trans _ Hint_) // orbT.
repeat Reg_upd; ring.

(** addiu t t four16; *)

apply hoare_addiu with (fun s h => exists Z next nint_, size Z = nk /\
  [x]_s = vx /\  [z]_s = vz /\ [m]_s = vm /\
  [one]_s = one32 /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (next < nk)%nat /\ (nint_ <= nk)%nat /\
  [X_]_s = X `32_ next /\ u2Z [int_]_s = Z_of_nat nint_ /\ (2 <= nint_)%nat /\
  store.utoZ s < 2 * \B^1 - 1 /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nint_-1) /\
  (exists K, \B^next.+1 * Sum_hole nk.+1 nint_.-2 (Z ++ [C]_s :: nil) +
    u2Z (store.hi s `|| store.lo s) * \B^(next + nint_) +
    u2Z [Z_]_s * \B^((next + nint_).-1) = \S_{ next } X * \S_{ nk } X +
    \S_{nint_.-1} X * u2Z (X `32_ next) * \B^next +
    \S_{nint_.-1} M * u2Z [quot]_s * \B^next +
    u2Z (X `32_ next) * u2Z (X `32_ nint_.-1)  * \B^((next + nint_).-1) +
    u2Z (Z `32_ nint_.-1) * \B^((next + nint_).-1) +
    u2Z (M `32_ nint_.-1) * u2Z [quot]_s * \B^((next + nint_).-1) + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next)).

move=> s h [Z [next [nint_ [HZ [r_x [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk' [Hint_' [r_X_ [r_int_' [Hint_ [Hm2 [r_t Hinv]]]]]]]]]]]]]]]]]]].

exists Z, next, nint_; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
rewrite sext_Z2u // u2Z_add_Z2u //.
- rewrite r_t; ring.
- rewrite r_t -Zbeta1E.
  apply: (leZ_ltZ_trans _ Hnz).
  rewrite -addZA; apply leZ_add2l.
  rewrite -{2}(mulZ1 4) -mulZDr; apply leZ_wpmul2l => //.
  rewrite -addZA; apply addr_leZ => //; exact/inj_le/leP.

(** sw Z_ mfour16 t *)

apply hoare_sw_back'.
move=> s h [Z [next [nint_ [HZ [r_x [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk' [Hint_' [r_X_ [r_int_' [Hint_ [Hm2 [r_t Hinv]]]]]]]]]]]]]]]]]]].

exists (int_e (Z `32_ nint_.-2)).

have Htmp: [z]_s `+ Z2u 32 (Z_of_nat (4 * nint_.-2)) = [t]_s `+ sext 16 mfour16.
  rewrite /mfour16 sext_Z2s // r_z; apply u2Z_inj.
  rewrite u2Z_add_Z2s //.
  rewrite u2Z_add_Z_of_nat.
  rewrite r_t -subn2 inj_mult inj_minus1; last exact/leP.
  ring.
  rewrite inj_mult -subn2 inj_minus1 //; last exact/leP.
  rewrite -Zbeta1E [Z_of_nat _]/=.
  apply: (leZ_ltZ_trans _ Hnz).
  apply/leZ_add2l/leZ_wpmul2l; first by [].
  rewrite -inj_minus1 //; last exact/leP.
  rewrite minusE.
  apply/inj_le/leP.
  by rewrite subn2 (leq_trans (leq_pred _ )) // (leq_trans _ Hint_') // leq_pred.
  rewrite r_t -addZA (_ : -4 = 4 * ( -1 )) // -mulZDr.
  apply leZ_addl; first exact: min_u2Z.
  rewrite mulZC; apply mulZ_ge0 => //.
  rewrite -addZA /= (_ : -2 = - Z_of_nat 2) //.
  exact/Zle_left/inj_le/leP.

Decompose_32 Z (nint_.-2) Z1 Z2 HlenZ1 HZ'; last first.
  rewrite HZ.
  ssromega.
rewrite HZ' (decompose_equiv _ _ _ _ _ HlenZ1) !assert_m.conAE assert_m.conCE !assert_m.conAE assert_m.conCE !assert_m.conAE in Hmem.
move: Hmem; apply monotony => // ht.
exact: mapsto_ext.

apply currying => h' H'; simpl app in H'.

exists (upd_nth Z nint_.-2 [Z_]_s), next, nint_; repeat (split; trivial).
exact: size_upd_nth.
rewrite HZ' upd_nth_cat HlenZ1 // subnn /= (decompose_equiv _ _ _ _ _ HlenZ1).
rewrite cat0s in H'.
assoc_comm H'.
move: H'; exact: mapsto_ext.
by rewrite (ltn_trans _ Hint_).
rewrite r_int_' r_k; exact/inj_le/leP.
case: Hinv => K [Hinv1 Hinv2].
exists K; split; last by []. (* about X * Y < M *)

(* technicalities:

   at this point, we have an hypothesis about K with
   ( z_0 ... z_{nint-2} ... z_{k-1} ++ C::nil )\{nint-2}

   whereas in the goal, we have
   ( z_0 ...     Z      ... z_{k-1} ++ C::nil )\{nint-1}

   we will:
   1. coax the hypothesis and the goal to have the same Sum_hole predicate
      1.a. add z_{nint-1} to the goal
      1.b. use the Sum_hole_shift property to change the Sum_hole predicate in the goal
   2. check that the goal can be obtained from the hypo by rewriting
 *)

(* 1. *)

(* 1.a. *)

apply (eqZ_add2l (\B^next.+1 * u2Z (Z `32_ nint_.-1) * \B^nint_.-2)).
rewrite addZA -mulZA -(mulZDr (\B^next.+1)).

(* 1.b. *)

rewrite (addZC (u2Z (Z `32_ nint_.-1) * \B^nint_.-2)).
have -> : Sum_hole nk.+1 nint_.-1 (upd_nth Z nint_.-2 [Z_]_s ++ [C]_s :: nil) +
    u2Z (Z `32_ nint_.-1) * \B^nint_.-2 =
    Sum_hole nk.+1 nint_.-2 (Z ++ [C]_s :: nil) + u2Z [Z_]_s * \B^nint_.-2.
  have H_ : size (upd_nth Z nint_.-2 [Z_]_s ++ [C]_s :: nil) = nk.+1.
    by rewrite size_cat (@size_upd_nth _ nk) // addn1.
  have H1__ : (nint_.-1 < nk)%nat by rewrite prednK // (ltn_trans _ Hint_).
  have H1_ : (nint_.-1 < nk.+1)%nat by apply ltnW.
  have H1___ : (nint_.-2 < nk)%nat by rewrite prednK // -ltnS // prednK // (ltn_trans _ Hint_).
  move/(Sum_hole_shift _ _ H_ _) : H1_ => {}H_.
  do 2 rewrite nth_cat (@size_upd_nth _ nk) // in H_.
  rewrite H1__ subn1 H1___ nth_upd_nth' in H_; last first.
    destruct nint_; first by [].
    destruct nint_; first by [].
    destruct nint_ as [|nint_]; first by [].
    apply/eqP; by rewrite neq_ltn /= ltnSn orbT.
  rewrite nth_upd_nth in H_; last by rewrite HZ.
  have -> : Sum_hole nk.+1 nint_.-2 (Z ++ [C]_s :: nil) =
                Sum_hole nk.+1 nint_.-2 (upd_nth Z nint_.-2 [Z_]_s ++ [C]_s :: nil).
  rewrite -upd_nth_cat'; last by rewrite HZ.
  rewrite -Sum_hole_upd_nth //.
  by rewrite size_cat addn1 /= HZ.
  by rewrite mulnC in H_.

(* 2. *)

have Htmp2 : (next.+1 + nint_.-2 = (next + nint_).-1)%nat.
  rewrite addSnnS prednK //; last by rewrite -ltnS // prednK // (ltn_trans _ Hint_).
  rewrite -[RHS]subn1 -addnBA //; last by rewrite (ltn_trans _ Hint_).
  by rewrite subn1.

apply trans_eq with (\B^next.+1 * Sum_hole nk.+1 nint_.-2 (Z ++ [C]_s :: nil) +
 u2Z (store.hi s `|| store.lo s) * \B^(next + nint_) +
  u2Z [Z_]_s * (\B^next.+1 * \B^nint_.-2)).
ring.

rewrite -ZbetaD Htmp2 {}Hinv1.

apply trans_eq with ((\S_{nint_.-1} X * u2Z (X `32_ next) * \B^next +
  u2Z (X `32_ next) * u2Z (X `32_ nint_.-1) * \B^((next + nint_).-1)) +
(\S_{nint_.-1} M * u2Z [quot]_s * \B^next +
  u2Z (M `32_ nint_.-1) * u2Z [quot]_s * \B^((next + nint_).-1))
+ K * \S_{ nk } M + \S_{ next } X * \S_{ nk } X
+ u2Z (Z `32_ nint_.-1) * \B^((next + nint_).-1)).
ring.

apply trans_eq with (\S_{ nint_ } X * u2Z (X `32_ next) * \B^next +
  \S_{ nint_ } M * u2Z [quot]_s * \B^next
  + K * \S_{ nk } M + \S_{ next } X * \S_{ nk } X
  + (u2Z (Z `32_ nint_.-1) * (\B^next.+1 * \B^nint_.-2)) ); last by ring.

f_equal; last by rewrite -ZbetaD Htmp2.

do 3 f_equal.
apply trans_eq with ((\S_{nint_.-1} X + u2Z (X `32_ nint_.-1) * \B^nint_.-1) * (u2Z (X `32_ next) * \B^next)).
- rewrite -(subn1 (next + nint_)) -addnBA; last exact: leq_trans Hint_.
  rewrite subn1 ZbetaD; ring.
- rewrite (mulZC _ (\B^nint_.-1)) {1}/Zbeta -lSum_remove_last.
- rewrite prednK //.
  by rewrite mulZA.
  exact: leq_trans Hint_.

apply trans_eq with ((\S_{nint_.-1} M + u2Z (M `32_ nint_.-1) * \B^nint_.-1) * (u2Z [quot]_s * \B^next)).
- rewrite -(subn1 (next + nint_)) -addnBA; last exact: leq_trans Hint_.
  rewrite subn1 ZbetaD; ring.
- rewrite (mulZC _ (\B^nint_.-1)) -lSum_remove_last prednK //.
  by rewrite mulZA.
  exact: leq_trans Hint_.

(** maddu C one; *)

apply hoare_maddu with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\ [one]_s = one32 /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (next < nk)%nat /\
  [X_]_s = X `32_ next /\ u2Z [int_]_s = Z_of_nat nk /\
  store.utoZ s < 3 * \B^1 - 2 /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nk - 1) /\
  (exists K, \B^next.+1 * \S_{nk.-1} Z + store.utoZ s * \B^(next + nk) =
    \S_{ next } X * \S_{ nk } X + \S_{ nk } X * u2Z (X `32_ next) * \B^next +
    \S_{ nk } M * u2Z [quot]_s * \B^next + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next)).

move=> s h [[Z [next [nint_ [HZ [r_x [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk' [Hint_' [r_int_' [r_X_ [Hint_ [Hm2 [r_t Hinv]]]]]]]]]]]]]]]]]]] Hint_k].
rewrite /= r_int_' r_k in Hint_k.
move/negPn/eqP/Z_of_nat_inj in Hint_k; subst nint_.

exists Z, next.

have Htmp : store.utoZ s < \B^2 * (2 ^^ store.acx_size - 1) by apply (@ltZ_leZ_trans (2 * \B^1 - 1)).

repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
rewrite store.utoZ_maddu // Hone umul_1 (@u2Z_zext 32) //.
apply (@ltZ_leZ_trans ((\B^1 - 1) + (2 * \B^1 - 1))); last by [].
apply leZ_lt_add => //; exact/leZsub1/max_u2Z.

case : Hinv => K [Hinv1 Hinv2].
exists K; split; last by []. (* about X * Y < M *)
rewrite -Hinv1 store.utoZ_maddu // Hone umul_1 (@u2Z_zext 32).
rewrite mulZDl addZA /Sum_hole // store.utoZ_def store.utoZ_acx_beta2; last by exact: (@ltZ_leZ_trans (2 * \B^1 - 1)).
rewrite Z2uK; last by split; [exact: leZZ | exact: expZ_gt0].
rewrite mul0Z addZ0 u2Z_concat.
have [Z' [tl H ] ] : exists Z' tl, Z = Z' ++ tl :: nil.
  clear -HZ r_X_.
  case/lastP : Z HZ r_X_ => /=; first by move=> <-.
  move=> h t _ _; by exists h, t; rewrite -cats1.
rewrite {2}H -catA.
have H0 : size Z' = nk.-1 by rewrite H size_cat /= addn1 in HZ; rewrite -HZ.
rewrite (@idel_app _ _ Z' H0 _ tl ([C]_s :: nil)) //.
move: (lSum_remove_last _ (Z' ++ [C]_s :: nil) nk.-1) => H1.
rewrite -(@lSum_beyond _ nk.-1) in H1; last by [].
rewrite nth_cat H0 ltnn subnn [nth _ _ _]/= in H1.
rewrite prednK // in H1.
rewrite subn1.
rewrite H1 (mulZDr (\B^next.+1)).
have <- : \S_{nk.-1} Z = \S_{nk.-1} Z' by rewrite H -lSum_beyond.
rewrite -ZbetaE mulZA -ZbetaD.
rewrite addSnnS prednK //.
by rewrite (mulZC (\B^(next + nk))) (addZC (u2Z (store.lo s))).

(** mflhxu Z_; *)

apply hoare_mflhxu with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\
  [one]_s = one32 /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\ u2Z [ext]_s = Z_of_nat next /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\ store.utoZ s < 3  /\
  u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nk - 1) /\
  (exists K, \B^next.+1 * \S_{nk.-1} Z + u2Z (store.lo s) * \B^((next + nk).+1) +
    u2Z [Z_]_s * \B^(next + nk) = \S_{ next } X * \S_{ nk } X +
    \S_{ nk } X * u2Z (X `32_ next) * \B^next +
    \S_{ nk } M * u2Z [quot]_s * \B^next + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next)).

move=> s h [Z [next [HZ [r_x [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk' [r_X_ [r_int_ [Hm2 [r_t Hinv]]]]]]]]]]]]]]]].

exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
apply store.mflhxu_kbeta1_utoZ.
apply (@ltZ_trans (3 * \B^1 - 2)); by [rewrite store.utoZ_upd | ].
case: Hinv => K [Hinv1 Hinv2].
exists K; split; last by []. (* about X * Y < M *)
rewrite -Hinv1 store.lo_mflhxu_op store.utoZ_def store.utoZ_acx_beta2; last exact: (@ltZ_leZ_trans (3 * \B^1 -2)).
rewrite Z2uK; last by split; [exact: leZZ | exact: expZ_gt0].
rewrite mul0Z addZ0 mulZDl -mulZA -ZbetaD (addnC 1%nat).
rewrite addn1 -addnS; repeat Reg_upd; ring.

(** addiu ext ext one16; *)

apply hoare_addiu with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\ [one]_s = one32 /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (1 <= next <= nk)%nat /\
  store.utoZ s < 3 /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nk - 1) /\
  (exists K, \B^next * \S_{nk.-1} Z + u2Z (store.lo s) * \B^(next + nk) +
    u2Z [Z_]_s * \B^((next + nk).-1) = \S_{next.-1} X * \S_{ nk } X +
    \S_{ nk } X * u2Z (X `32_ next.-1) * \B^(next-1) +
    \S_{ nk } M * u2Z [quot]_s * \B^next.-1 + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M + (\B^1 - 1) * (\B^next.-1 * \S_{ nk } M)
    < 2 * \S_{ nk } M * \B^next)).

move=> s h [Z [next [HZ [r_x [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk' [r_X_ [Hm2 [r_t Hinv]]]]]]]]]]]]]]].

exists Z, next.+1; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
rewrite sext_Z2u // u2Z_add_Z2u // r_ext.
by rewrite Z_S.
apply (@leZ_ltZ_trans (Z_of_nat nk)).
rewrite (_ : 1 = Z_of_nat 1) // -inj_plus plusE addn1; exact/inj_le/leP.
rewrite -r_k; exact: max_u2Z.

case: Hinv => K [Hinv1 Hinv2].
exists K; split.
- by rewrite !subn1 -Hinv1 addSn.
- (* about X * Y < M *)
  rewrite lSum_remove_last mulZDl.
  apply (@ltZ_leZ_trans (2 * \S_{ nk } M * \B^next + u2Z (X `32_ next) * \B^next * \S_{ nk } X +
    (\B^1 - 1) * \B^next * \S_{ nk } M)).
  apply ltZ_le_add.
  rewrite -ZbetaE (mulZC (\B^next)) /zero32 addZC addZA;
    by apply ltZ_le_add; [rewrite addZC | apply leZZ].
  rewrite mulZA; exact/leZZ.
  apply (@leZ_trans (2 * \S_{ nk } M * \B^next + (\B^1 - 1) * \B^next * \S_{ nk } X +
    (\B^1 - 1) * \B^next * \S_{ nk } M)).
  apply leZ_add2r, leZ_add2l.
  rewrite -2!mulZA.
  apply leZ_wpmul2r.
  apply mulZ_ge0 => //; exact: min_lSum.
  exact/leZsub1/max_u2Z.
  rewrite -addZA.
  apply (@leZ_trans (2 * \S_{ nk } M * \B^next +
    ((\B^1 - 1) * \B^next * \S_{ nk } M + (\B^1 - 1) * \B^next * \S_{ nk } M))).
    apply leZ_add2l, leZ_add2r, leZ_wpmul2l.
    apply mulZ_ge0; by [ | exact: Zbeta_0'].
  exact/ltZW.
  suff: 2 * \S_{ nk } M * \B^next + ((\B^1 - 1) * \B^next * \S_{ nk } M + (\B^1 - 1) * \B^next * \S_{ nk } M)
    = 2 * \S_{ nk } M * \B^next.+1 by move=> ->; apply leZZ.
  rewrite (Zbeta_S next); ring.

(** sw Z_ zero16 t; *)

apply hoare_sw_back'' with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\
  [one]_s = one32 /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (1 <= next <= nk)%nat /\
  store.utoZ s < 3 /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nk - 1) /\
  (exists K, \B^next * \S_{ nk } Z + u2Z (store.lo s) * \B^(next + nk) =
    \S_{next.-1} X * \S_{ nk } X + \S_{ nk } X * u2Z (X `32_ next.-1) * \B^(next-1) +
    \S_{ nk } M * u2Z [quot]_s * \B^(next-1) + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } X + K * \S_{ nk } M + (\B^1 - 1) * (\B^next.-1 * \S_{ nk } M) < 2 * \S_{ nk } M * \B^next)).

move=> s h [Z [next [HZ [r_x [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk' [Hm2 [r_t Hinv]]]]]]]]]]]]]].

have [lst1 [last H0 ] ] : exists Z' tl, Z = Z' ++ tl :: nil.
  clear -HZ Hextk'.
  case/lastP : Z HZ Hextk' => [<-|].
    rewrite leqn0; case/andP => H1 /eqP H2; by rewrite H2 in H1.
  move=> h t _ _; by exists h, t; rewrite cats1.
have Hlenlst1 : size lst1 = nk.-1 by rewrite -HZ H0 size_cat /= addn1.
have Htmp : [ var_e t \+ int_e (sext 16 zero16) ]e_ s = [ var_e z \+ int_e (Z2u 32 (Z_of_nat (4 * nk.-1))) ]e_ s.
  rewrite /= sext_0 addi0; apply u2Z_inj.
  rewrite u2Z_add_Z_of_nat.
  rewrite inj_mult -subn1 inj_minus1 //; last by destruct nk => //; exact/le_n_S/le_O_n.
  rewrite r_t r_z; simpl Z_of_nat; ring.
  rewrite inj_mult -subn1 inj_minus1 //; last by destruct nk => //; exact/le_n_S/le_O_n.
  rewrite r_z; simpl Z_of_nat.
  apply: leZ_ltZ_trans; last exact: Hnz.
  apply/leZ_add2l/leZ_wpmul2l; first by [].
  rewrite (_ : 1 = Z_of_nat 1) // -inj_minus1 //; last by ssromega.
  apply/inj_le/leP; by rewrite minusE subn1 leq_pred.

exists (int_e last).

rewrite H0 (decompose_equiv _ _ _ _ _ Hlenlst1) !assert_m.conAE assert_m.conCE !assert_m.conAE assert_m.conCE !assert_m.conAE in Hmem.
move: Hmem; apply monotony => // ht.
exact: mapsto_ext.
apply currying => h' H'; simpl assert_m.mapstos in H'.

exists (upd_nth Z nk.-1 [Z_]_s), next.

repeat (split; trivial).
exact: size_upd_nth.
rewrite H0 upd_nth_cat Hlenlst1 // subnn /= (decompose_equiv _ _ _ _ _ Hlenlst1).
simpl assert_m.mapstos.
assoc_comm H'.
exact: mapsto_ext H'.

case: Hinv => K [Hinv1 Hinv2].
exists K; split; last by []. (* about X * Y < M *)
rewrite (subn1 next).
rewrite (subn1 next) in Hinv1.
rewrite -Hinv1.
have -> : upd_nth Z nk.-1 [Z_]_s = lst1 ++ [Z_]_s :: nil.
  rewrite H0 upd_nth_cat /=.
  by rewrite Hlenlst1 subnn.
  by rewrite Hlenlst1.
rewrite (lSum_cut_last nk) //; last by rewrite size_cat /= -HZ H0 size_cat.
rewrite mulZDr mulZA -ZbetaD !subn1.
rewrite H0 -(lSum_beyond 32 nk.-1 lst1) //.
rewrite -(subn1 (next + nk)) -addnBA //.
rewrite subn1; ring.
rewrite (@leq_trans next) //.
by case/andP : Hextk'.
by case/andP : Hextk'.

(** mflhxu C *)

apply hoare_mflhxu'.

move=> s h [Z [next [HZ [r_x [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk' [Hm2 [r_t Hinv]]]]]]]]]]]]]].

exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

rewrite r_ext r_k.

apply/inj_le/leP; by case/andP: Hextk'.

rewrite -subn1 inj_minus1 //; destruct nk => //; exact/le_n_S/le_O_n.

case: Hinv => K [Hinv1 Hinv2].
exists (K + u2Z [quot]_s * \B^(next - 1)); split.
- rewrite lSum_cut_last; last by rewrite size_cat /= HZ addnC.
  rewrite !subn1 mulZDr mulZA -ZbetaD (mulZC (\B^(next + nk))) Hinv1.
  have <- : \S_{next.-1} X + u2Z (X `32_ next.-1) * \B^next.-1 = \S_{ next } X.
    rewrite -(mulZC (\B^next.-1)) /Zbeta -lSum_remove_last //.
    rewrite prednK //.
    by case/andP: Hextk'.
  rewrite subn1; ring.
(* about X * Y < M *)
- apply (@leZ_ltZ_trans(\S_{ next } X * \S_{ nk } X + K * \S_{ nk } M + ((\B^1 - 1) * \B^next.-1 * \S_{ nk } M))); last by rewrite -mulZA.
  rewrite mulZDl addZA.
  apply/leZ_add2l/leZ_wpmul2r; first exact: min_lSum.
  rewrite subn1; apply leZ_wpmul2r => //; exact/leZsub1/max_u2Z.
Qed.


(**************************************************************************)
(*  This file is part of CertrBPF,                                        *)
(*  a formally verified rBPF verifier + interpreter + JIT in Coq.         *)
(*                                                                        *)
(*  Copyright (C) 2022 Inria                                              *)
(*                                                                        *)
(*  This program is free software; you can redistribute it and/or modify  *)
(*  it under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation; either version 2 of the License, or     *)
(*  (at your option) any later version.                                   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful,       *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU General Public License for more details.                          *)
(*                                                                        *)
(**************************************************************************)

From compcert Require Import Integers Values AST Ctypes.
From Coq Require Import ZArith.

From bpf.comm Require Import BinrBPF Monad.
From bpf.verifier.comm Require Import state monad.
From bpf.model Require Import Syntax.
From bpf.verifier.synthesismodel Require Import opcode_synthesis.

Open Scope nat_scope.
Open Scope monad_scope.

(** TODO: we should add a rule to ensure lddw_high and lddw_low come in pairs and the latter is always after the former *)

Definition is_dst_R0 (i: int64) : M state.state bool := returnM (is_dst_R0' i).

Definition is_well_dst (i: int64) : M state.state bool := returnM (is_well_dst' i).

Definition is_well_src (i: int64) : M state.state bool := returnM (is_well_src' i).

Definition is_well_jump (pc len: nat) (ofs: int) : M state.state bool := returnM (is_well_jump' pc len ofs).

Definition is_not_div_by_zero (i: int64) : M state.state bool := returnM (is_not_div_by_zero' i).

Definition is_not_div_by_zero64 (i: int64) : M state.state bool := returnM (is_not_div_by_zero64' i).

Definition is_shift_range (i: int64) (upper: int): M state.state bool := returnM (is_shift_range' i upper).

Definition is_shift_range64 (i: int64) (upper: int): M state.state bool := returnM (is_shift_range64' i upper).

Definition get_opcode (ins: int64): M state.state nat := returnM (get_opcode ins).

Definition get_offset (i: int64): M state.state int := returnM (get_offset i).

Definition bpf_verifier_opcode_alu32_imm (op: nat) (ins: int64) : M state.state bool :=
  match nat_to_opcode_alu32_imm op with
  | DIV32_IMM
  | MOD32_IMM => (**r DIV_IMM *)
    do b <- is_not_div_by_zero ins;
      returnM b
  | LSH32_IMM
  | RSH32_IMM
  | ARSH32_IMM => (**r SHIFT_IMM *)
    do b <- is_shift_range ins (Int.repr 32);
      returnM b
  | ADD32_IMM
  | SUB32_IMM
  | MUL32_IMM
  | OR32_IMM
  | AND32_IMM
  | NEG32_IMM
  | XOR32_IMM
  | MOV32_IMM => (**r ALU_IMM *)
    returnM true
  | ALU32_IMM_ILLEGAL => returnM false
  end.

Definition bpf_verifier_opcode_alu32_reg (op: nat) (ins: int64) : M state.state bool :=
  match nat_to_opcode_alu32_reg op with
  | DIV32_REG
  | MOD32_REG
  | LSH32_REG
  | RSH32_REG
  | ARSH32_REG
  | ADD32_REG
  | SUB32_REG
  | MUL32_REG
  | OR32_REG
  | AND32_REG
  | XOR32_REG
  | MOV32_REG => (**r ALU_REG *)
    do b <-  is_well_src ins;
      returnM b
  | ALU32_REG_ILLEGAL => returnM false
  end.

Definition bpf_verifier_opcode_alu64_imm (op: nat) (ins: int64) : M state.state bool :=
  match nat_to_opcode_alu64_imm op with
  | DIV64_IMM
  | MOD64_IMM => (**r DIV_IMM *)
    do b <-  is_not_div_by_zero64 ins;
      returnM b
  | LSH64_IMM
  | RSH64_IMM
  | ARSH64_IMM => (**r SHIFT_IMM *)
    do b <-  is_shift_range64 ins (Int.repr 64);
      returnM b
  | ADD64_IMM
  | SUB64_IMM
  | MUL64_IMM
  | OR64_IMM
  | AND64_IMM
  | NEG64_IMM
  | XOR64_IMM
  | MOV64_IMM => (**r ALU_IMM *)
    returnM true
  | ALU64_IMM_ILLEGAL => returnM false
  end.

Definition bpf_verifier_opcode_alu64_reg (op: nat) (ins: int64) : M state.state bool :=
  match nat_to_opcode_alu64_reg op with
  | DIV64_REG
  | MOD64_REG
  | LSH64_REG
  | RSH64_REG
  | ARSH64_REG
  | ADD64_REG
  | SUB64_REG
  | MUL64_REG
  | OR64_REG
  | AND64_REG
  | XOR64_REG
  | MOV64_REG => (**r ALU_REG *)
    do b <-  is_well_src ins;
      returnM b
  | ALU64_REG_ILLEGAL => returnM false
  end.

Definition bpf_verifier_opcode_branch_imm (pc len op: nat) (ins: int64) : M state.state bool :=
  match nat_to_opcode_branch_imm op with
  | JA_IMM
  | JEQ_IMM
  | JGT_IMM
  | JGE_IMM
  | JLT_IMM
  | JLE_IMM
  | JSET_IMM
  | JNE_IMM
  | JSGT_IMM
  | JSGE_IMM
  | JSLT_IMM
  | JSLE_IMM =>
    do ofs <-  get_offset ins;
    do b <-  is_well_jump pc len ofs;
      returnM b
  | CALL_IMM
  | RET_IMM =>
    do b <-  is_dst_R0 ins;
      returnM b
  | JMP_IMM_ILLEGAL_INS => returnM false
  end.

Definition bpf_verifier_opcode_branch_reg (pc len op: nat) (ins: int64) : M state.state bool :=
  match nat_to_opcode_branch_reg op with
  | JEQ_REG
  | JGT_REG
  | JGE_REG
  | JLT_REG
  | JLE_REG
  | JSET_REG
  | JNE_REG
  | JSGT_REG
  | JSGE_REG
  | JSLT_REG
  | JSLE_REG =>
    do ofs <-  get_offset ins;
    do b0 <-  is_well_src ins;
      if b0 then
        do b   <-  is_well_jump pc len ofs;
          returnM b
      else
          returnM false
  | JMP_REG_ILLEGAL_INS => returnM false
  end.

Definition bpf_verifier_opcode_load_imm (op: nat) (ins: int64) : M state.state bool :=
  match nat_to_opcode_load_imm op with
  | LDDW_low
  | LDDW_high => returnM true
  | LDX_IMM_ILLEGAL_INS => returnM false
  end.

Definition bpf_verifier_opcode_load_reg (op: nat) (ins: int64) : M state.state bool :=
  match nat_to_opcode_load_reg op with
  | LDXW
  | LDXH
  | LDXB
  | LDXDW  =>
    do b <-  is_well_src ins;
      returnM b
  | LDX_REG_ILLEGAL_INS => returnM false
  end.

Definition bpf_verifier_opcode_store_imm (op: nat) (ins: int64) : M state.state bool :=
  match nat_to_opcode_store_imm op with
  | STW
  | STH
  | STB
  | STDW  => returnM true
  | ST_ILLEGAL_INS => returnM false
  end.

Definition bpf_verifier_opcode_store_reg (op: nat) (ins: int64) : M state.state bool :=
  match nat_to_opcode_store_reg op with
  | STXW
  | STXH
  | STXB
  | STXDW  =>
    do b <-  is_well_src ins;
      returnM b
  | STX_ILLEGAL_INS => returnM false
  end.

Definition bpf_verifier_aux2 (pc len op: nat) (ins: int64) : M state.state bool :=
  match nat_to_opcode op with
  | ALU64  (**r 0xX7 / 0xXf *) =>
    if Int.eq Int.zero (Int.and (Int.repr (Z.of_nat op)) (Int.repr 8)) then
      do b <- bpf_verifier_opcode_alu64_imm op ins;
        returnM b
    else
      do b <- bpf_verifier_opcode_alu64_reg op ins;
        returnM b
  | ALU32  (**r 0xX4 / 0xXc *) =>
    if Int.eq Int.zero (Int.and (Int.repr (Z.of_nat op)) (Int.repr 8)) then
      do b <- bpf_verifier_opcode_alu32_imm op ins;
        returnM b
    else
      do b <- bpf_verifier_opcode_alu32_reg op ins;
        returnM b
  | Branch (**r 0xX5 / 0xXd *) =>
    if Int.eq Int.zero (Int.and (Int.repr (Z.of_nat op)) (Int.repr 8)) then
      do b <- bpf_verifier_opcode_branch_imm pc len op ins;
        returnM b
    else
      do b <- bpf_verifier_opcode_branch_reg pc len op ins;
        returnM b
  | LD_IMM (**r 0xX8 *)        => do b <- bpf_verifier_opcode_load_imm op ins; returnM b
  | LD_REG (**r 0xX1/0xX9 *)   => do b <- bpf_verifier_opcode_load_reg op ins; returnM b
  | ST_IMM (**r 0xX2/0xXa *)   => do b <- bpf_verifier_opcode_store_imm op ins; returnM b
  | ST_REG (**r 0xX3/0xXb *)   => do b <- bpf_verifier_opcode_store_reg op ins; returnM b
  | ILLEGAL => returnM false
  end.

Fixpoint bpf_verifier_aux (pc len: nat): M state.state bool := (**r pc: len-1, len-2, ... 0 *)
    match pc with
    | O => returnM true
    | S n =>
      do ins <-  eval_ins (Int.repr (Z.of_nat n)); (**r len-pc: 0, 1, 2, etc... len -1 *)
      do b   <-  is_well_dst ins;
        if b then
          do op   <-  get_opcode ins;
          do b    <-  bpf_verifier_aux2 n len op ins;
            if b then
              bpf_verifier_aux n len
            else
              returnM false
        else
          returnM false
    end.

Definition bpf_verifier: M state.state bool :=
  do len  <-  eval_ins_len;
  (**r (0, Int.max_unsigned/8): at least one instruction, and at most Int.max_unsigned/8 because of memory region *)
    if negb (Int.ltu (Int.repr (Z.of_nat len)) Int.one) then
      if negb
       (Int.ltu (Int.divu (Int.repr Int.max_unsigned) (Int.repr 8))
          (Int.repr (Z.of_nat len))) then
        do b <-  bpf_verifier_aux len len;
          if b then
            do ins64 <-  eval_ins (Int.repr (Z.of_nat (len - 1)));
              returnM (Int64.eq ins64 (Int64.repr 0x95))
          else
            returnM false
      else
        returnM false
    else
      returnM false.

Close Scope monad_scope.
Close Scope nat_scope.