From machine_program_logic.program_logic Require Import weakestpre.
From HypVeri Require Import machine_extra lifting rules.rules_base.
From HypVeri.algebra Require Import base reg mem pagetable mailbox base_extra.
From HypVeri.lang Require Import lang_extra reg_extra current_extra.
Require Import stdpp.fin.
Require Import stdpp.listset_nodup.

Section run.

Context `{hypparams:HypervisorParameters}.

Context `{vmG: !gen_VMG Σ}.

Lemma run {E w1 w2 w3 q s p_tx R' Q P} ai i R P':
  let T := (▷ (PC @@ V0 ->r ai)
            ∗ ▷ (ai ->a w1)
            ∗ ▷ (V0 -@{q}A> s)
            ∗ ▷ (TX@ V0 := p_tx)
            ∗ ▷ (R0 @@ V0 ->r w2)
            ∗ ▷ (R1 @@ V0 ->r w3))%I
  in
  let T' := ((PC @@ V0 ->r (ai ^+ 1)%f)
               ∗ ai ->a w1
               ∗ V0 -@{q}A> s
               ∗ TX@ V0 := p_tx
               ∗ R0 @@ V0 ->r w2
               ∗ R1 @@ V0 ->r w3)%I
  in
  (tpa ai) ∈ s ->
  (tpa ai) ≠ p_tx ->
  i ≠ V0 ->
  decode_instruction w1 = Some Hvc ->
  decode_hvc_func w2 = Some Run ->
  decode_vmid w3 = Some i ->
  {SS{{ T ∗ ▷ (VMProp i (Q) (1/2)%Qp)
          ∗ ▷ (VMProp V0 P 1%Qp)
          ∗ ▷ (T' ∗ R ∗ VMProp V0 P' (1/2)%Qp -∗ (Q ∗ R'))
          ∗ ▷ R }}}
    ExecI @ V0 ;E
    {{{ RET (true, ExecI); R' ∗ VMProp V0 P' (1/2)%Qp}}}.
Proof.
  simpl.
  iIntros (Hin Hnottx Hneq_v Hdecode Hhvc Hvmid ϕ) "[(>Hpc & >Hapc & >Hacc & >tx & >Hr0 & >Hr1) (HPropi & HPropz & Himpl & HR)] Hϕ".
  iApply (sswp_lift_atomic_step ExecI); [done|].
  iIntros (n σ1) "%Hsche Hσ".
  rewrite /scheduled in Hsche.
  simpl in Hsche.
  rewrite /scheduler in Hsche.
  apply bool_decide_unpack in Hsche as Hcur.
  clear Hsche.
  apply fin_to_nat_inj in Hcur.
  iModIntro.
  iDestruct "Hσ" as "(%Hneq & Hmemown & Hreg & Hmb & ? & Hown & Haccessown & Hrest)".
  (* valid regs *)
  iDestruct (gen_reg_valid1 PC V0 ai Hcur with "Hreg Hpc") as "%Hpc".
  iDestruct (gen_reg_valid1 R0 V0 w2 Hcur with "Hreg Hr0") as "%Hr0".
  iDestruct (gen_reg_valid1 R1 V0 w3 Hcur with "Hreg Hr1") as "%Hr1".
  (* valid pt *)
  iDestruct (access_agree_check_true (tpa ai)  with "Haccessown Hacc") as %Hacc;first exact Hin.
  iDestruct (mb_valid_tx with "Hmb tx") as %Htx.
  subst p_tx.
  (* valid mem *)
  iDestruct (gen_mem_valid ai w1 with "Hmemown Hapc") as "%Hmem".
  iSplit.
  - (* reducible *)
    iPureIntro.
    apply (reducible_normal V0 Hvc ai w1);eauto.
  - iModIntro.
    iIntros (m2 σ2) "[%U PAuth] %HstepP".
    apply (step_ExecI_normal V0 Hvc ai w1) in HstepP; eauto.
    remember (exec Hvc σ1) as c2 eqn:Heqc2.
    rewrite /exec /hvc in Heqc2; eauto.
    rewrite  Hr0 /= Hhvc /run Hr1 in Heqc2.
    simpl in Heqc2.
    rewrite /unpack_hvc_result_yield Hvmid in Heqc2.
    simpl in Heqc2.
    rewrite /is_primary Hcur in Heqc2.
    destruct HstepP as [Hstep1 Hstep2].
    case_bool_decide;last done.
    subst c2.
    simpl in Hstep1, Hstep2.
    subst σ2 m2.
    simpl.
    rewrite /gen_vm_interp /update_incr_PC.
    rewrite (preserve_get_mb_gmap σ1).
    rewrite (preserve_get_rx_gmap σ1).
    rewrite (preserve_get_own_gmap σ1).
    rewrite (preserve_get_access_gmap σ1).
    rewrite (preserve_get_excl_gmap σ1).
    rewrite (preserve_get_trans_gmap σ1).
    rewrite (preserve_get_hpool_gset σ1).
    rewrite (preserve_get_retri_gmap σ1).
    rewrite (preserve_inv_trans_pgt_consistent σ1).
    rewrite (preserve_inv_trans_wellformed σ1).
    rewrite (preserve_inv_trans_ps_disj σ1).
    all: try rewrite p_upd_id_mb p_upd_pc_mb //.
    all: try rewrite p_upd_id_pgt p_upd_pc_pgt //.
    all: try rewrite p_upd_id_trans p_upd_pc_trans //.
    rewrite p_upd_id_mem p_upd_pc_mem.
    iFrame.
    iDestruct ((gen_reg_update1_global PC V0 ai (ai ^+ 1)%f) with "Hreg Hpc") as "HpcUpd".
    rewrite (preserve_get_reg_gmap (update_offset_PC σ1 1) (update_current_vmid _ _));last rewrite p_upd_id_reg //.
    rewrite ->(u_upd_pc_regs _ V0 ai 1); auto.
    + iDestruct (VMProp_update V0 U P P' with "PAuth HPropz") as "HTemp".
      iMod "HpcUpd".
      iMod "HTemp".
      iDestruct "HTemp" as "[PAuth HPropz]".
      iModIntro.
      iDestruct "HpcUpd" as "[? Hpc]".
      iFrame.
      iSplitL "PAuth".
      by iExists P'.
      iSplit; first done.
      rewrite /just_scheduled_vms /just_scheduled.
      assert (filter
                (λ id : vmid,
                        base.negb (scheduled σ1 id) &&
                        scheduled (update_current_vmid (update_offset_PC σ1 1) i) id = true)
                (seq 0 n) = [fin_to_nat i]) as ->.
      {
        rewrite /scheduled /machine.scheduler Hneq //= /scheduler.
        rewrite /update_current_vmid //=.
        pose proof (NoDup_seq 0 vm_count) as ND.
        pose proof (NoDup_singleton ((@fin_to_nat (@vm_count H) i))) as ND'.
        set f := (λ id : nat, base.negb (bool_decide ((@fin_to_nat (@vm_count H) σ1.1.1.2) = id)) && bool_decide ((@fin_to_nat (@vm_count H) i) = id) = true).
        pose proof (NoDup_filter f _ ND) as ND''.
        assert (f i) as Prf.
        {
          subst f.
          simpl.
          unfold base.negb.
          repeat case_bool_decide; eauto.
          rewrite Hcur in H1.
          exfalso.
          apply Hneq_v.
          symmetry.
          apply fin_to_nat_inj.
          done.
        }
        assert (In (@fin_to_nat (@vm_count H) i) (seq 0 vm_count)) as Prf'.
        {
          rewrite <-elem_of_list_In.
          rewrite elem_of_seq.
          split.
          - solve_finz.
          - rewrite plus_O_n.
            pose proof (fin_to_nat_lt i).
            auto.
        }
        rewrite <-elem_of_list_In in Prf'.
        assert (In (@fin_to_nat (@vm_count H) i) (filter f (seq 0 vm_count))) as Prf''.
        {
          rewrite <-elem_of_list_In.
          by apply (iffRL (elem_of_list_filter f (seq 0 vm_count) i)).
        }
        rewrite <-elem_of_list_In in Prf''.
        assert (forall x, x ≠ (@fin_to_nat (@vm_count H) i) -> not (In x (filter f (seq 0 vm_count)))) as excl.
        {
          intros x neq c.
          rewrite <-elem_of_list_In in c.
          rewrite ->elem_of_list_filter in c.
          destruct c as [c' _].
          subst f.
          simpl in c'.
          unfold base.negb in c'.
          case_match.
          - by rewrite andb_false_l in c'.
          - rewrite andb_true_l in c'.
            apply neq.
            rewrite ->bool_decide_eq_true in c'.
            by symmetry.
        }
        apply Permutation_length_1_inv.
        apply NoDup_Permutation; auto.
        intros x'.
        split.
        - intros T.
          rewrite ->elem_of_list_singleton in T.
          rewrite T; auto.
        - intros T.
          rewrite ->elem_of_list_singleton.
          rewrite ->elem_of_list_In in T.
          destruct (decide (x' = i)) as [? | n']; auto.
          exfalso.
          by apply (excl x' n').
      }
      iSimpl.
      assert ((negb (scheduled (update_current_vmid (update_offset_PC σ1 1) i) V0) && true = true)) as ->.
      {
        rewrite andb_true_r.
        rewrite /scheduled /machine.scheduler //= /scheduler.
        rewrite /update_current_vmid //=.
        apply eq_true_not_negb.
        intros c.
        rewrite ->bool_decide_eq_true in c.
        apply Hneq_v.
        apply fin_to_nat_inj.
        done.
      }
      iDestruct (VMProp_split with "HPropz") as "[HPropz1 HPropz2]".
      iDestruct ("Himpl" with "[Hpc Hapc Hacc Hr0 Hr1 HR HPropz1 tx]") as "[Q R']".
      iFrame.
      iSplitR "Hϕ R' HPropz2".
      iSplit; last done.
      iExists (Q)%I.
      iFrame.
      iApply ("Hϕ" with "[R' HPropz2]").
      iFrame.
    + apply get_reg_gmap_get_reg_Some; auto.
Qed.

Lemma run_not_primary {E wi r0 r2 q s p_tx } ai i :
  (tpa ai) ∈ s ->
  (tpa ai) ≠ p_tx ->
  decode_instruction wi = Some Hvc ->
  decode_hvc_func r0 = Some Run ->
  i ≠ V0 ->
  {SS{{ ▷ (PC @@ i ->r ai)
            ∗ ▷ (ai ->a wi)
            ∗ ▷ (i -@{q}A> s)
            ∗ ▷ (TX@ i := p_tx)
            ∗ ▷ (R0 @@ i ->r r0)
            ∗ ▷ (R2 @@ i ->r r2)
            }}}
    ExecI @ i ;E
    {{{ RET (false, ExecI); PC @@ i ->r (ai ^+ 1)%f
               ∗ ai ->a wi
               ∗ i -@{q}A> s
               ∗ TX@ i := p_tx
               ∗ R0 @@ i ->r (encode_hvc_ret_code Error)
               ∗ R2 @@ i ->r (encode_hvc_error Denied) }}}.
  Proof.
  iIntros (Hin_acc Hneq_tx Hdecode_i Hdecode_f Hneq_v0 Φ)
          "(>PC & >mem_ins & >acc & >tx & >R0 & >R2) HΦ".
  iApply (sswp_lift_atomic_step ExecI);[done|].
  iIntros (n σ1) "%Hsche state".
  rewrite /scheduled /= /scheduler in Hsche.
  assert (σ1.1.1.2 = i) as Heq_cur. { case_bool_decide;last done. by apply fin_to_nat_inj. }
  clear Hsche.
  iModIntro.
  iDestruct "state" as "(Hnum & mem & regs & mb & rx_state & pgt_owned & pgt_acc & pgt_excl &
                            trans & hpool & retri & %Hwf & %Hdisj & %Hconsis)".
  (* valid regs *)
  iDestruct ((gen_reg_valid3 i PC ai R0 r0 R2 r2 Heq_cur) with "regs PC R0 R2")
    as "(%Hlookup_PC & %Hlookup_R0 & %Hlookup_R2)";eauto.
  (* valid pt *)
  iDestruct (access_agree_check_true (tpa ai) i with "pgt_acc acc") as %Hcheckpg_ai;eauto.
  (* valid mem *)
  iDestruct (gen_mem_valid ai wi with "mem mem_ins") as %Hlookup_ai.
  (* valid tx *)
  iDestruct (mb_valid_tx i p_tx with "mb tx") as %Heq_tx.
  (* valid tran *)
  iSplit.
  - (* reducible *)
    iPureIntro.
    apply (reducible_normal i Hvc ai wi);auto.
    rewrite Heq_tx //.
  - iModIntro.
    iIntros (m2 σ2) "vmprop_auth %HstepP".
    iFrame "vmprop_auth".
    apply (step_ExecI_normal i Hvc ai wi) in HstepP;eauto.
    2: rewrite Heq_tx //.
    remember (exec Hvc σ1) as c2 eqn:Heqc2.
    rewrite /exec /hvc Hlookup_R0 /= Hdecode_f /= /lang.run /is_primary  in Heqc2.
    case_bool_decide. rewrite H0 in Heq_cur. rewrite Heq_cur // in Hneq_v0.
    destruct HstepP;subst m2 σ2; subst c2; simpl.
    iDestruct (hvc_error_update (E:= E) Denied with "PC R0 R2 [$Hnum $mem $regs $mb $rx_state $pgt_owned $pgt_acc $pgt_excl $ trans $hpool $retri]")
    as ">[[$ $] ?]";auto.
    rewrite /scheduled /machine.scheduler /= /scheduler.
    rewrite p_upd_pc_current_vm 2!p_upd_reg_current_vm Heq_cur.
    case_bool_decide;last contradiction.
    simpl. iApply "HΦ".
    iFrame.
    by iFrame.
  Qed.

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

Lemma run_primary {E wi r0 r1 q s p_tx} ai :
  (tpa ai) ∈ s ->
  (tpa ai) ≠ p_tx ->
  decode_instruction wi = Some Hvc ->
  decode_hvc_func r0 = Some Run ->
  decode_vmid r1 = Some V0 ->
  {SS{{ ▷ (PC @@ V0 ->r ai)
            ∗ ▷ (ai ->a wi)
            ∗ ▷ (V0 -@{q}A> s)
            ∗ ▷ (TX@ V0 := p_tx)
            ∗ ▷ (R0 @@ V0 ->r r0)
            ∗ ▷ (R1 @@ V0 ->r r1)}}}
    ExecI @ V0 ;E
    {{{ RET (false, ExecI); PC @@ V0 ->r (ai ^+ 1)%f
               ∗ ai ->a wi
               ∗ V0 -@{q}A> s
               ∗ TX@ V0 := p_tx
               ∗ R0 @@ V0 ->r r0
               ∗ R1 @@ V0 ->r r1}}}.
  Proof.
  iIntros (Hin_acc Hneq_tx Hdecode_i Hdecode_f Hdecode_vmid Φ)
          "(>PC & >mem_ins & >acc & >tx & >R0 & >R1) HΦ".
  iApply (sswp_lift_atomic_step ExecI);[done|].
  iIntros (n σ1) "%Hsche state".
  rewrite /scheduled /= /scheduler in Hsche.
  assert (σ1.1.1.2 = V0) as Heq_cur. { case_bool_decide;last done. by apply fin_to_nat_inj. }
  clear Hsche.
  iModIntro.
  iDestruct "state" as "(Hnum & mem & regs & mb & rx_state & pgt_owned & pgt_acc & pgt_excl &
                            trans & hpool & retri & %Hwf & %Hdisj & %Hconsis)".
  (* valid regs *)
  iDestruct ((gen_reg_valid3 V0 PC ai R0 r0 R1 r1 Heq_cur) with "regs PC R0 R1")
    as "(%Hlookup_PC & %Hlookup_R0 & %Hlookup_R1)";eauto.
  (* valid pt *)
  iDestruct (access_agree_check_true (tpa ai) V0 with "pgt_acc acc") as %Hcheckpg_ai;eauto.
  (* valid mem *)
  iDestruct (gen_mem_valid ai wi with "mem mem_ins") as %Hlookup_ai.
  (* valid tx *)
  iDestruct (mb_valid_tx V0 p_tx with "mb tx") as %Heq_tx.
  (* valid tran *)
  iSplit.
  - (* reducible *)
    iPureIntro.
    apply (reducible_normal V0 Hvc ai wi);auto.
    rewrite Heq_tx //.
  - iModIntro.
    iIntros (m2 σ2) "vmprop_auth %HstepP".
    iFrame "vmprop_auth".
    apply (step_ExecI_normal V0 Hvc ai wi) in HstepP;eauto.
    2: rewrite Heq_tx //.
    remember (exec Hvc σ1) as c2 eqn:Heqc2.
    rewrite /exec /hvc Hlookup_R0 /= Hdecode_f /= /lang.run /is_primary in Heqc2.
    case_bool_decide;last contradiction.
    rewrite Hlookup_R1 /= Hdecode_vmid /= in Heqc2.
    destruct HstepP;subst m2 σ2; subst c2; simpl.
    rewrite /gen_vm_interp.
    rewrite (preserve_get_mb_gmap σ1).
    rewrite (preserve_get_rx_gmap σ1).
    rewrite (preserve_get_own_gmap σ1).
    rewrite (preserve_get_access_gmap σ1).
    rewrite (preserve_get_excl_gmap σ1).
    rewrite (preserve_get_trans_gmap σ1).
    rewrite (preserve_get_hpool_gset σ1).
    rewrite (preserve_get_retri_gmap σ1).
    rewrite (preserve_inv_trans_pgt_consistent σ1).
    rewrite (preserve_inv_trans_wellformed σ1).
    rewrite (preserve_inv_trans_ps_disj σ1).
    all: try rewrite p_upd_id_mb p_upd_pc_mb //.
    all: try rewrite p_upd_id_pgt p_upd_pc_pgt //.
    all: try rewrite p_upd_id_trans p_upd_pc_trans //.
    rewrite p_upd_id_mem p_upd_pc_mem.
    iFrame.
    (* upd reg*)
    rewrite (preserve_get_reg_gmap (update_incr_PC σ1) (update_current_vmid _ _)).
    2: rewrite p_upd_id_reg //.
    rewrite (u_upd_pc_regs _ V0 ai).
    2: rewrite //.
    2: solve_reg_lookup.
    iDestruct ((gen_reg_update1_global PC V0 _ (ai ^+ 1)%f) with "regs PC")
      as ">($ & PC)";eauto.
    iModIntro.
    iSplit. iPureIntro. auto.
    (* just_schedule *)
    rewrite /just_scheduled_vms /just_scheduled.
    rewrite /scheduled /machine.scheduler /= /scheduler.
    rewrite /update_current_vmid /= Heq_cur.
    set fl := (filter _ _).
    assert (fl = []) as ->.
    {
      rewrite /fl.
      induction n.
      - simpl.
        rewrite filter_nil //=.
      - rewrite seq_S.
        rewrite list.filter_app.
        rewrite IHn.
        simpl.
        rewrite filter_cons_False /=.
        rewrite filter_nil. auto.
        rewrite andb_negb_l.
        done.
    }
    iSplitR;first done.
    case_bool_decide; last contradiction.
    simpl.
    iApply "HΦ".
    iFrame.
  Qed.

End run.


(**
 Verified SAR-BP: A verified C implementation of SAR backprojection
 with a certified absolute error bound.

 Version 1.0 (2015-12-04)

 Copyright (C) 2015 Reservoir Labs Inc.
 All rights reserved.

 This file 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 3 of the License (GNU GPL
 v3), or (at your option) any later version.  A verbatim copy of the
 GNU GPL v3 is included in gpl-3.0.txt.

 This file 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 LICENSE for
 more details about the use and redistribution of this file and the
 whole Verified SAR-BP library.

 This work is sponsored in part by DARPA MTO as part of the Power
 Efficiency Revolution for Embedded Computing Technologies (PERFECT)
 program (issued by DARPA/CMO under Contract No: HR0011-12-C-0123). The
 views and conclusions contained in this work are those of the authors
 and should not be interpreted as representing the official policies,
 either expressly or implied, of the DARPA or the
 U.S. Government. Distribution Statement "A" (Approved for Public
 Release, Distribution Unlimited.)

 If you are using or modifying Verified SAR-BP in your work, please
 consider citing the following paper:

 Tahina Ramananandro, Paul Mountcastle, Benoit Meister and Richard
 Lethin.
 A Unified Coq Framework for Verifying C Programs with Floating-Point
 Computations.
 In CPP (5th ACM/SIGPLAN conference on Certified Programs and Proofs)
 2016.

 Verified SAR-BP derives from prior work listed in ACKS along with
 their copyright and licensing information.

 Verified SAR-BP requires third-party libraries listed in ACKS along
 with their copyright information.
*)
(**
Author: Tahina Ramananandro <ramananandro@reservoir.com>

Verification of C implementation of sine.
*)

Require Import Flocq.Appli.Fappli_IEEE.
Require Import Integers.
Require Import AST.
Require Import Values.
Require Import Memory.
Require Import Clight.
Require Import FPLang.
Require Import FPLangOpt.
Require Import ClightFacts.
Require Import Clight2FPOpt.
Require Import SARBackProjSource.
Require Import SARBackProjSourceSin.

Require Import RAux.
Require Import FieldEq.
Open Scope R_scope.

Transparent Integers.Int.repr.
Transparent Floats.Float32.of_bits.
Transparent Floats.Float.of_bits.
Set Printing Depth 1000000.

Local Existing Instances
      Clight2FP.nans
      map_nat compcert_map
.

Require Import Interval.Interval_tactic.
Require Import ClightSep2.

Open Scope R_scope.

Definition f_sin_cos_correct f_sin_error f_cos_error ge cef_sin_cos :=
  type_of_fundef cef_sin_cos =
  Ctypes.Tfunction (Ctypes.Tcons (Clightdefs.tptr Clightdefs.tfloat)
                                 (Ctypes.Tcons (Clightdefs.tptr Clightdefs.tfloat)
                                               (Ctypes.Tcons Clightdefs.tdouble Ctypes.Tnil)))
                   Clightdefs.tvoid
                   cc_default
  /\
  forall
    os
    (Hos_align: (align_chunk Mfloat32 | Int.unsigned os)%Z )
    oc
    (Hoc_align: (align_chunk Mfloat32 | Int.unsigned oc)%Z )
    ps (Hps: perm_order ps Writable)
    pc (Hpc: perm_order pc Writable)
    bs bc
    m P
    (Hm:
       holds
         (P ++
            Pperm bs (Int.unsigned os) ps (size_chunk_nat Mfloat32)
            ++
            Pperm bc (Int.unsigned oc) pc (size_chunk_nat Mfloat32))
         m)
    x
    (Hx_finite: is_finite _ _ x = true)
    (Hx_range: x_left <= B2R _ _ x <= x_right )
  ,
    let st0 := (Callstate cef_sin_cos
                          (Vptr bs os :: Vptr bc oc :: Vfloat x :: nil)
                          Kstop
                          m) in
    exists m',
      star Clight.step2 ge
           st0
           E0
           (Returnstate Vundef Kstop m')
      /\
      exists si co,
        holds
          (P ++
             Pval Mfloat32 bs (Int.unsigned os) ps (Vsingle si)
             ++
             Pval Mfloat32 bc (Int.unsigned oc) pc (Vsingle co))
          m'
        /\
        (
          is_finite _ _ si = true
          /\
          is_finite _ _ co = true
        )
        /\
        (
          Rabs (B2R _ _ si - sin (B2R _ _ x)) <= f_sin_error
          /\
          Rabs (B2R _ _ co - cos (B2R _ _ x)) <= f_cos_error
        )
.

Lemma round_to_error u v d e:
  v = u * (1 + d) + e ->
  v - u = u * d + e.
Proof.
  intros H.
  subst.
  ring.
Qed.

Lemma f_sin_cos_body_correct' :
  { f_sin_error : _ &
                        { f_cos_error |
                          forall
 (ge: Clight.genv)
      b_sin fn_sin
      (Hb_sin: Globalenvs.Genv.find_symbol ge _sin = Some b_sin)
      (Hfn_sin: Globalenvs.Genv.find_funct_ptr ge b_sin = Some fn_sin)
      (Hfn_sin_correct: SARBackProjSourceSin.f_unary_correct sin ge fn_sin)
      b_cos fn_cos
      (Hb_cos: Globalenvs.Genv.find_symbol ge _cos = Some b_cos)
      (Hfn_cos: Globalenvs.Genv.find_funct_ptr ge b_cos = Some fn_cos)
      (Hfn_cos_correct: SARBackProjSourceSin.f_unary_correct cos ge fn_cos)
,
  f_sin_cos_correct f_sin_error f_cos_error ge (Clight.Internal (f_sin_cos))
}}.
Proof.
  esplit. esplit.

  split; auto.
  intros os Hos_align oc Hoc_align ps Hps pc Hpc bs bc m P Hm x Hx_finite Hx_range st0.
  unfold x_left, x_right in Hx_range.
  unfold st0.
  clear st0.

  apply f_sin_correct in Hfn_sin_correct.
  destruct Hfn_sin_correct as (sin_type & Hfn_sin_correct).
  apply f_cos_correct in Hfn_cos_correct.
  destruct Hfn_cos_correct as (cos_type & Hfn_cos_correct).

  unfold f_unary_error in Hfn_sin_correct, Hfn_cos_correct.

  match goal with
    |- exists m', Smallstep.star step2 ?ge ?s Events.E0 (Returnstate Vundef Kstop m') /\ ?P =>
    cut
      (exists s',
         Smallstep.star step2 ge s Events.E0 s' /\
         exists m',
           s' = Returnstate Vundef Kstop m' /\
           P)
  end.
  {
    intro H;  break H; subst; eauto 13.
  }
  apply star_exists_step.
  call_fn.
  simpl fn_body.

  repeat run.

  apply exec_call_exists.
  solve_trivial.
  eapply exists_modus_ponens.
  {
    eapply exists_double_elim.
    eapply Hfn_sin_correct; eauto.
  }
  intros s1 Hs1.
  simpl in Hs1.
  destruct Hs1 as (si & ? & Hsi_finite & Hsi_val & Hsi_range).
  subst s1.
  solve_trivial.
  repeat run.

  apply eval_expr_exists_filter_float.
  apply Vsingle_exists.
  (* here comes the framework into play! *)
  C_to_float_as sif Hsif.
  compute_fval_as Hsif Hsif_finite Hsif_val.
  solve_trivial.

  repeat run.

  holds_storev_solve.
  intros m Hm.
  repeat run.

  apply exec_call_exists.
  solve_trivial.
  eapply exists_modus_ponens.
  {
    eapply exists_double_elim.
    eapply Hfn_cos_correct; eauto.
  }
  intros s1 Hs1.
  simpl in Hs1.
  destruct Hs1 as (co & ? & Hco_finite & Hco_val & Hco_range).
  subst s1.
  solve_trivial.
  repeat run.

  apply eval_expr_exists_filter_float.
  apply Vsingle_exists.
  (* here comes the framework into play! *)
  C_to_float_as cof Hcof.
  compute_fval_as Hcof Hcof_finite Hcof_val.
  solve_trivial.

  repeat run.

  holds_storev_solve.
  intros m Hm.
  repeat run.

  apply star_exists_refl.
  solve_trivial.

  exists sif, cof.
  split.
  {
    revert Hm.
    apply holds_list_comm_aux.
    apply count_occ_list_comm.
    intros; repeat rewrite count_occ_app; omega.
  }

  split; auto.

  split.
  {
    symmetry in Hsif_val.
    rewrite Rmult_1_l in *.
    apply round_to_error in Hsif_val.
    match type of Hsif_val with
        _ = ?z =>
        interval_intro (Rabs z) upper with (i_prec 128) as Hsif_error
    end.
    rewrite <- Hsif_val in Hsif_error.
    eapply Rabs_triang2.
    {
      eassumption.
    }
    eassumption.
  }
  symmetry in Hcof_val.
  rewrite Rmult_1_l in *.
  apply round_to_error in Hcof_val.
  match type of Hcof_val with
      _ = ?z =>
      interval_intro (Rabs z) upper with (i_prec 128) as Hcof_error
  end.
  rewrite <- Hcof_val in Hcof_error.
  eapply Rabs_triang2.
  {
    eassumption.
  }
  eassumption.
Defined.

Definition f_sin_error' :=
  let (x, _) := f_sin_cos_body_correct' in x.

Definition f_sin_error'_eq :=
  $( field_eq f_sin_error' )$ .

Definition f_sin_error :=
  $(
      match type of f_sin_error'_eq with
        _ = ?z => exact z
      end
    )$ .

Definition f_cos_error' :=
  let (_, y) := f_sin_cos_body_correct' in
  let (x, _) := y in x.

Definition f_cos_error'_eq :=
  $( field_eq f_cos_error' )$ .

Definition f_cos_error :=
  $(
      match type of f_cos_error'_eq with
        _ = ?z => exact z
      end
    )$ .

Lemma f_sin_cos_error_correct:
                          forall
 (ge: Clight.genv)
      b_sin fn_sin
      (Hb_sin: Globalenvs.Genv.find_symbol ge _sin = Some b_sin)
      (Hfn_sin: Globalenvs.Genv.find_funct_ptr ge b_sin = Some fn_sin)
      (Hfn_sin_correct: SARBackProjSourceSin.f_unary_correct sin ge fn_sin)
      b_cos fn_cos
      (Hb_cos: Globalenvs.Genv.find_symbol ge _cos = Some b_cos)
      (Hfn_cos: Globalenvs.Genv.find_funct_ptr ge b_cos = Some fn_cos)
      (Hfn_cos_correct: SARBackProjSourceSin.f_unary_correct cos ge fn_cos)
,
  f_sin_cos_correct f_sin_error f_cos_error ge (Clight.Internal (f_sin_cos))
.
Proof.
  unfold f_sin_error.
  rewrite <- f_sin_error'_eq.
  unfold f_cos_error.
  rewrite <- f_cos_error'_eq.
  unfold f_sin_error', f_cos_error'.
  destruct f_sin_cos_body_correct'.
  destruct s.
  assumption.
Qed.


Require Import VST.floyd.proofauto.
Require Import pile.
Require Import spec_stdlib.
Require Import PileModel.

Record PileAPD := {
  pilerep: list Z -> val -> mpred;
  pilerep_local_facts: forall sigma p,
    pilerep sigma p |-- !! (isptr p /\ Forall (Z.le 0) sigma);
  pilerep_valid_pointer: forall sigma p,
    pilerep sigma p |-- valid_pointer p;
  pile_freeable (p: val) : mpred (* Definitely don't expose the definition of this as malloc_token, because that would expose the fact that there's exactly one malloc'ed record in the implementation. *)
}.

#[export] Hint Resolve pilerep_local_facts : saturate_local.
#[export] Hint Resolve pilerep_valid_pointer : valid_pointer.

Definition tpile := Tstruct _pile noattr.

Local Open Scope assert.

Section PileASI.
Variable M: MallocFreeAPD.
Variable PILE:PileAPD.

Definition Pile_new_spec :=
 DECLARE _Pile_new
 WITH gv: globals
 PRE [ ] PROP() PARAMS() GLOBALS(gv) SEP(mem_mgr M gv)
 POST[ tptr tpile ]
   EX p: val,
      PROP() LOCAL(temp ret_temp p)
      SEP(pilerep PILE nil p; pile_freeable PILE p; mem_mgr M gv).

Definition Pile_add_spec :=
 DECLARE _Pile_add
 WITH p: val, n: Z, sigma: list Z, gv: globals
 PRE [ tptr tpile, tint  ]
    PROP(0 <= n <= Int.max_signed)
    PARAMS (p; Vint (Int.repr n)) GLOBALS (gv)
    SEP(pilerep PILE sigma p; mem_mgr M gv)
 POST[ tvoid ]
    PROP() LOCAL()
    SEP(pilerep PILE (n::sigma) p; mem_mgr M gv).

Definition Pile_count_spec :=
 DECLARE _Pile_count
 WITH p: val, sigma: list Z
 PRE [ tptr tpile  ]
    PROP(0 <= sumlist sigma <= Int.max_signed)
    PARAMS (p) GLOBALS ()
    SEP (pilerep PILE sigma p)
 POST[ tint ]
      PROP()
      LOCAL(temp ret_temp (Vint (Int.repr (sumlist sigma))))
      SEP(pilerep PILE sigma p).

Definition Pile_free_spec :=
 DECLARE _Pile_free
 WITH p: val, sigma: list Z, gv: globals
 PRE [ tptr tpile  ]
    PROP()
    PARAMS (p) (GLOBALS (gv)
    SEP(pilerep PILE sigma p; pile_freeable PILE p; mem_mgr M gv))
 POST[ tvoid ]
     PROP() LOCAL() SEP(mem_mgr M gv).

Definition PileASI:funspecs := [ Pile_new_spec; Pile_add_spec; Pile_count_spec; Pile_free_spec].

End PileASI.


(* 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 machine_int multi_int uniq_tac.
Import MachineInt.
Require Import mips_seplog mips_contrib mips_frame mips_tactics.
Import expr_m.
Import assert_m.
Require Import multi_sub_s_u_prg multi_add_s_u_triple pick_sign_triple.
Require Import copy_u_u_triple multi_is_zero_u_triple multi_negate_triple.
Require Import multi_sub_u_u_L_triple multi_sub_u_u_R_triple.
Require Import multi_add_u_u_triple.

Local Open Scope zarith_ext_scope.
Local Open Scope uniq_scope.
Local Open Scope heap_scope.
Local Open Scope machine_int_scope.
Local Open Scope mips_expr_scope.
Local Open Scope mips_hoare_scope.
Local Open Scope mips_assert_scope.
Local Open Scope multi_int_scope.

(* TODO: rename registers *)
Lemma multi_sub_s_u0_triple k a b a0 a1 a2 a3 a4 ret X :
uniq(k, a, b, a0, a1, a2, a3, a4, ret, X, r0) ->
forall nk va vb ptr, nk <> O -> Z_of_nat nk < 2 ^^ 31 ->
  u2Z ptr + 4 * Z_of_nat nk < \B^1 ->
forall A B, size A = nk -> size B = nk -> 0 < \S_{ nk } B ->
forall slen, s2Z slen = sgZ (s2Z slen) * Z_of_nat nk ->
{{ fun s h => [ a ]_s = va /\ [ b ]_s = vb /\  u2Z [ k ]_s = Z_of_nat nk /\
   ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) ** var_e b |--> B) s h }}
multi_sub_s_u0 k a b a0 a1 a2 a3 a4 ret X
{{ fun s h => exists A' slen', size A' = nk /\ [ a ]_s = va /\
  [ b ]_s = vb /\ s2Z slen' = sgZ (s2Z slen') * Z_of_nat nk /\
  sgZ (s2Z slen') = sgZ (sgZ (s2Z slen) * \S_{ nk } A - \S_{ nk } B) /\
  ((var_e a |--> slen' :: ptr :: nil ** int_e ptr |--> A') ** var_e b |--> B ) s h /\
  u2Z ([ a3 ]_ s) <= 1 /\
  sgZ (s2Z slen') * (\S_{ nk } A' + u2Z ([ a3 ]_s) * \B^nk) =
    sgZ (s2Z slen) * \S_{ nk } A - \S_{ nk } B }}.
Proof.
move=> Hregs nk va vb ptr Hnk Hnk' ptr_fit A B len_A len_B nk_B slen slen_not_weird.
rewrite /multi_sub_s_u0.

(** lw X four16 a *)

apply hoare_lw_back_alt'' with (fun s h => [a ]_ s = va /\ [b ]_ s = vb /\
  u2Z ([k ]_ s) = Z_of_nat nk /\ [X ]_s = ptr /\
  ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) ** var_e b |--> B) s h).

rewrite /while.entails => s h [r_a [r_b [r_k Hmem]]].
exists ptr; split.
- rewrite conCE !conAE conCE !conAE
  conCE !conAE in Hmem.
  move: Hmem; apply monotony => // h'; apply mapsto_ext => //.
  by rewrite sext_Z2u.
- rewrite /update_store_lw.
  repeat Reg_upd; repeat (split => //).
  by Assert_upd.

(** pick_sign a a0 a1 *)

apply while.hoare_seq with (fun s h =>
  [a ]_ s = va /\ [b ]_ s = vb /\ u2Z ([k ]_ s) = Z_of_nat nk /\
  [X ]_s = ptr /\ [a0]_s = slen /\ sgZ (s2Z [a1 ]_ s) = sgZ (s2Z slen) /\
  (s2Z [ a1 ]_ s = 0 \/ s2Z [ a1 ]_ s = 1 \/ s2Z [ a1 ]_s = - 1) /\
  ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) ** var_e b |--> B) s h).

eapply while.hoare_conseq; last first.
(* TODO: use machine_int notation *)
- apply (pick_sign_triple (fun s h =>
    [b ]_ s = vb /\ u2Z [k ]_ s = Z_of_nat nk /\
    [X ]_ s = ptr) (((var_e a \+ int_e four32 |~> int_e ptr **
      (fun st h0 => u2Z (([a ]_ st `+ four32) `+ four32) mod 4 = 0 /\
        emp st h0)) ** int_e ptr |--> A) ** var_e b |--> B) va slen).
  + by Uniq_uniq r0.
  + Inde.
    move=> s h x v /= [] //.
    move=> ?; subst a1; by Reg_upd.
    case=> // ?; subst a0; by Reg_upd.
  + by Inde.
- move=> s h /= [Ha [Hb [Hk [HX Hmem]]]].
  by rewrite !conAE in Hmem *.
- move=> s h [Ha [Ha0 [Ha1 [Ha1' [Hmem [Hb [Hk HX]]]]]]].
  by rewrite !conAE in Hmem *.

(** while.ifte (bgez a1) *)

apply while.hoare_ifte.

apply while.hoare_ifte.

apply while.hoare_seq with (fun s h =>
  [a ]_ s = va /\ [b ]_ s = vb /\ u2Z ([k ]_ s) = Z_of_nat nk /\
  [X ]_ s = ptr /\ 0 = sgZ (s2Z slen) /\
  ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> B) ** var_e b |--> B) s h).

(** copy k X b a2 a3 a4 *)

apply (before_frame
  (fun s h => [a ]_ s = va /\ [b ]_ s = vb /\ [a0 ]_ s = slen /\
    sgZ (s2Z slen) = 0 /\ (var_e a |--> slen :: ptr :: nil) s h)
  (fun s h => [X]_s = ptr /\ u2Z [k]_s = Z_of_nat nk /\
    (var_e b |--> B ** var_e X |--> A) s h)
  (fun s h => [X]_s = ptr /\ u2Z [k]_s = Z_of_nat nk /\
    (var_e b |--> B ** var_e X |--> B) s h)).

apply frame_rule_R; last 2 first.
  by Inde_frame.
  move=> ?; by Inde_mult.
apply copy_u_u_triple => //; by Uniq_uniq r0.

move=> s h [ [ [Ha [Hb [Hk [HX [Ha0 [a1_slen [Ha1' mem]]]]]] _] Ha1] ].
rewrite conAE in mem.
case: mem => h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]].
exists h2, h1.
split; first by heap_tac_m.Disj.
split; first by heap_tac_m.Equal.
repeat (split => //).
rewrite conCE.
move: Hh2; apply monotony => // h'; exact: mapstos_ext.
rewrite /= in Ha1; move/eqP/u2Z_inj in Ha1.
rewrite store.get_r0 /= in Ha1.
rewrite -a1_slen Ha1 s2Z_u2Z_pos'; by rewrite Z2uK.

move=> s h [h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]]].
case: Hh2 => [Ha [Hb [Ha0 [Ha1' Hh2]]]].
case: Hh1 => Hx [Hk Hh1].
repeat (split => //).
rewrite conAE.
exists h2, h1.
split; first by heap_tac_m.Disj.
split; first by heap_tac_m.Equal.
repeat (split => //).
rewrite conCE.
move: Hh1; apply monotony => h' //; exact: mapstos_ext.

(** addiu a3 r0 zero16 *)

apply hoare_addiu with (fun s h => [a ]_ s = va /\ [b ]_ s = vb /\
  u2Z [k ]_ s = Z_of_nat nk /\ [X ]_ s = ptr /\ [a3]_s = zero32 /\
  0 = sgZ (s2Z slen) /\
  ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> B) ** var_e b |--> B) s h).
move=> s h [Ha [Hb [Hk [HX [Hslen mem]]]]].
rewrite /wp_addiu.
repeat Reg_upd.
repeat (split=> //).
by rewrite sext_Z2u // addi0.
by Assert_upd.

(** sw k zero16 a *)

apply hoare_sw_back'' with (fun s h => [a ]_ s = va /\ [b ]_ s = vb /\
 u2Z [k ]_ s = Z_of_nat nk /\ [X ]_ s = ptr /\ [a3 ]_ s = zero32 /\
 0 = sgZ (s2Z slen) /\
 ((var_e a |--> Z2s 32 (Z_of_nat nk) :: ptr :: nil ** int_e ptr |--> B) ** var_e b |--> B) s h).

move=> s h [Ha [Hb [Hk [HX [Ha3 [Hslen mem]]]]]].
exists (int_e slen).
rewrite !conAE /= in mem.
move: mem; apply monotony => // h'.
apply mapsto_ext => //; by rewrite /= sext_Z2u // addi0.
apply currying => h'' Hh''.
repeat (split => //).
rewrite conCE in Hh''.
rewrite /= !conAE.
move: Hh''; apply monotony => // h'''.
apply mapsto_ext => /=.
by rewrite sext_Z2u // addi0.
apply u2Z_inj.
rewrite Hk u2Z_Z2s_pos //.
split; by [apply Zle_0_nat |(apply: @ltZ_leZ_trans; [exact: Hnk'|])].

(** negate a a0 *)

apply hoare_prop_m.hoare_weak with (fun s h =>
  [a ]_ s = va /\ [b ]_ s = vb /\
  sgZ (- Z_of_nat nk) = sgZ (sgZ (s2Z slen) * \S_{ nk } A - \S_{ nk } B) /\
  ((var_e a |--> Z2s 32 (- Z_of_nat nk) :: ptr :: nil ** int_e ptr |--> B) ** var_e b |--> B) s h /\
  u2Z [a3 ]_ s <= 1 /\ 0 = sgZ (s2Z slen) /\
  sgZ (- Z_of_nat nk) * (\S_{ nk } B + u2Z [a3 ]_ s * \B^nk) = sgZ (s2Z slen) * \S_{ nk } A - \S_{ nk } B).
move=> s h [Ha [Hb [Hsgn [mem [Ha3 [Hslen HSum]]]]]].
exists B, (Z2s 32 (- Z_of_nat nk)).
repeat (split=> //).

rewrite Z2sK //; last lia.
rewrite (proj2 (Zsgn_neg (- Z_of_nat nk))) //; lia.
rewrite Z2sK //; lia.
rewrite Z2sK //; lia.

apply (before_frame
  (fun s h => [a ]_ s = va /\ [b ]_ s = vb /\ (var_e b |--> B) s h /\
    u2Z [a3 ]_ s <= 1 /\ 0 = sgZ (s2Z slen) /\
    - sgZ (Z_of_nat nk) * (\S_{ nk } B + u2Z [a3 ]_ s * \B^nk) =
    sgZ (s2Z slen) * \S_{ nk } A - \S_{ nk } B)
  (var_e a |--> Z2s 32 (Z_of_nat nk) :: ptr :: nil ** int_e ptr |--> B)
  (var_e a |--> cplt2 (Z2s 32 (Z_of_nat nk)) :: ptr :: nil ** int_e ptr |--> B)).

apply frame_rule_R.
- apply multi_negate_triple => //; by Uniq_uniq r0.
  Inde_frame; rewrite /inde => s h x v /= [] // ?; subst x; by Reg_upd.
- move=> ?; by Inde_mult.

move=> s h [Ha [Hb [Hk [HX [Ha3 [Hsgn mem]]]]]].
case: mem => h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]].
Compose_sepcon h1 h2; first by exact Hh1.
repeat (split=> //).
by rewrite Ha3 Z2uK.
rewrite -Hsgn mul0Z /= Ha3 Z2uK // mul0Z addZ0 (proj2 (Zsgn_pos (Z_of_nat nk))) //; lia.

move=> s h [h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]]].
case: Hh2 => [Ha [Hb [hSgn [Ha3 [Hslen HSum]]]]].
repeat (split => //).
rewrite -Hslen mul0Z /= in HSum *.
rewrite (proj2 (Zsgn_neg (- Z_of_nat nk))); last lia.
rewrite (proj2 (Zsgn_neg (- \S_{ nk } B))); lia.
Compose_sepcon h1 h2; last by [].
rewrite (_ : Z2s 32 (- Z_of_nat nk) = cplt2 (Z2s 32 (Z_of_nat nk))) //.
apply s2Z_inj.
rewrite s2Z_cplt2; last first.
  rewrite weirdE2 Z2sK; lia.
rewrite Z2sK; last lia.
rewrite Z2sK //; lia.
rewrite (proj2 (Zsgn_pos (Z_of_nat nk))) in HSum; last lia.
rewrite (proj2 (Zsgn_neg (- Z_of_nat nk))); last lia.
rewrite -HSum; ring.

(** multi_lt k X b a0 a1 ret a2 a3 a4 *)

apply while.hoare_seq with (fun s h =>
  [a ]_ s = va /\ [b ]_ s = vb /\ u2Z ([k ]_ s) = Z_of_nat nk /\
  [X ]_ s = ptr /\ sgZ (s2Z slen) = 1 /\
  ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) ** var_e b |--> B) s h /\
  ((\S_{ nk } A < \S_{ nk } B /\ [ret]_s = one32 /\ [a2]_s = zero32) \/
   (\S_{ nk } A > \S_{ nk } B /\ [ret]_s = zero32 /\ [a2]_s = one32) \/
   (\S_{ nk } A = \S_{ nk } B /\ [ret]_s = zero32 /\ [a2]_s = zero32))).

eapply (before_frame
  (fun s h => [a ]_ s = va /\ sgZ (s2Z slen) = 1 /\ (var_e a |--> slen :: ptr :: nil) s h)
  (fun s h => u2Z ([k ]_ s) = Z_of_nat nk /\ [X ]_ s = ptr /\ [b ]_ s = vb /\
    (var_e X |--> A ** var_e b |--> B) s h )
  (fun s h =>u2Z ([k ]_ s) = Z_of_nat nk /\ [X ]_ s = ptr  /\ [b ]_ s = vb /\
    (((\S_{ nk } A < \S_{ nk } B /\ [ret]_s = one32 /\ [a2]_s = zero32) \/
      (\S_{ nk } A > \S_{ nk } B /\ [ret]_s = zero32 /\ [a2]_s = one32) \/
      (\S_{ nk } A = \S_{ nk } B /\ [ret]_s = zero32 /\ [a2]_s = zero32)) /\
    (var_e X |--> A ** var_e b |--> B) s h))).

apply frame_rule_R.
apply multi_lt_triple.multi_lt_triple => //; by Uniq_uniq r0.
by Inde_frame.
move=> ?; by Inde_mult.

rewrite /while.entails => s h [[[Ha [Hb [Hk [HX [Ha0 [HZsgn [Ha1 Hmem]]]]]]] Ha1''] Ha1'].
move/leZP in Ha1''. rewrite /= in Ha1'. move/eqP in Ha1'.
rewrite store.get_r0 Z2uK // in Ha1'.
case: Ha1 => Ha1.
  by rewrite s2Z_u2Z_pos // in Ha1.
case: Ha1 => Ha1; last first.
  rewrite Ha1 in Ha1''. by move/leZP : Ha1''.
rewrite conAE in Hmem.
case: Hmem => h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]].
Compose_sepcon h2 h1.
repeat (split=> //).
move: Hh2; apply monotony => // h'; exact: mapstos_ext.
repeat (split=> //).
by rewrite -HZsgn Ha1.

rewrite /while.entails => s h Hmem.
case: Hmem => h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]].
case: Hh1 => Hk [Hb [HX [HSum Hmem]]].
case: Hh2 => Ha [Hsgn Hh2].
repeat (split=> //).
rewrite conAE.
Compose_sepcon h2 h1; first by [].
move: Hmem. apply monotony => // h'; exact: mapstos_ext.

(** ifte_beq ret, r0 *)

apply while.hoare_ifte.

apply while.hoare_ifte.

apply hoare_addiu with (fun s h => [a ]_ s = va /\ [b ]_ s = vb /\
  u2Z [k ]_ s = Z_of_nat nk /\ [X ]_ s = ptr /\ [a3]_s = zero32 /\
  sgZ (s2Z slen) = 1 /\
  ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) ** var_e b |--> B) s h /\
  \S_{ nk } A = \S_{ nk } B).

move=> s h [ [ [Ha [Hb [Hk [HX [Hslen [mem HSum]]]]]] Hret] Ha2].
rewrite /wp_addiu.
repeat Reg_upd.
repeat (split => //).
by rewrite sext_Z2u // addi0.
by Assert_upd.
rewrite /= in Hret Ha2.
move/eqP/u2Z_inj in Hret.
move/eqP/u2Z_inj in Ha2.
rewrite store.get_r0 in Hret Ha2.
case: HSum => Hsum.
  rewrite Hret Ha2 in Hsum.
  case: Hsum => _ [Hsum _].
  by apply Z2u_dis in Hsum.
case: Hsum => Hsum; last by tauto.
rewrite Ha2 in Hsum.
case: Hsum => _ [_ Hsum].
by apply Z2u_dis in Hsum.

(** sw r0 zero16 a *)

apply hoare_sw_back'.
move=> s h [Ha [Hb [Hk [HX [Ha3 [Hslen [mem HSum]]]]]]].
exists (int_e slen).
rewrite !conAE /= in mem.
move: mem; apply monotony => // h'.
apply mapsto_ext => //=; by rewrite sext_Z2u // addi0.
apply currying => h'' Hh''.
exists A (* NB: whatever *), (Z2s 32 0).
repeat (split => //).

by rewrite Z2sK.

by rewrite Z2sK //= Hslen mul1Z HSum subZZ.

rewrite conCE in Hh''.
rewrite !conAE /=.
move: Hh''; apply monotony => // h3.
apply mapsto_ext => /=.
by rewrite sext_Z2u // addi0.
rewrite store.get_r0.
apply u2Z_inj.
by rewrite u2Z_Z2s_pos // Z2uK.
by rewrite Ha3 Z2uK.
by rewrite Z2sK //= Hslen mul1Z HSum subZZ.

(** multi_sub k X b X a0 a1 a2 a3 a4 ret *)

apply hoare_prop_m.hoare_stren with (fun s h => \S_{ nk } A > \S_{ nk } B /\
  [a ]_ s = va /\ [b ]_ s = vb /\ u2Z ([k ]_ s) = Z_of_nat nk /\
  [X ]_ s = ptr /\ sgZ (s2Z slen) = 1 /\
  ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) ** var_e b |--> B) s h).

rewrite /while.entails => s h [[[Ha [Hb [Hk [HX [HZsgn [Hmem HSum]]]]]] Hret] Ha2].
rewrite /= store.get_r0 Z2uK // in Hret.
move/eqP in Hret.
case: HSum => HSum.
  case: HSum => _ [HSum _].
  by rewrite HSum Z2uK in Hret.
split; last by [].
rewrite /= in Ha2.
move/eqP in Ha2.
rewrite store.get_r0 Z2uK // in Ha2.
case: HSum => HSum; first by tauto.
case: HSum => _ [_ HSum].
by rewrite HSum Z2uK in Ha2.

(** multi_sub k X b X a0 a1 a2 a3 a4 ret *)

apply (hoare_prop_m.pull_out_conjunction' hoare0_false) => HAB.

apply (before_frame
  (fun s h => [a ]_ s = va /\ sgZ (s2Z slen) = 1 /\
    (var_e a |--> slen :: ptr :: nil) s h )
  (fun s h => [X ]_ s = ptr /\ [b ]_ s = vb /\ u2Z ([k ]_ s) = Z_of_nat nk/\
    (var_e X |--> A ** var_e b |--> B) s h)
  (fun s h => exists A', size A' = nk /\
    [X ]_ s = ptr /\ [b ]_ s = vb /\ u2Z ([k ]_ s) = Z_of_nat nk/\
    [a3]_s = zero32 /\
    (var_e X |--> A' ** var_e b |--> B) s h /\
    \S_{ nk } A' = \S_{ nk } A - \S_{ nk } B)).

apply frame_rule_R; last 2 first.
  by Inde_frame.
  move=> ?; by Inde_mult.
apply multi_sub_u_u_L_triple_B_le_A => //.
by Uniq_uniq r0.
lia.

rewrite /while.entails => s h [Ha [Hb [Hk [HX [HZsgn Hmem]]]]].
rewrite conAE in Hmem.
case: Hmem => h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]].
Compose_sepcon h2 h1; last by [].
repeat (split => //).
move: Hh2. apply monotony => // h'; exact:  mapstos_ext.

rewrite /while.entails => s h [h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]]].
case: Hh1 => A' [A'_nk [Hb [HX [Hk [Ha3 [Hh1 HSum]]]]]].
case: Hh2 => [Ha [HZsgn Hh2]].
exists A', slen.
rewrite Ha3 Z2uK // HZsgn !mul1Z mul0Z addZ0.
repeat (split => //).

rewrite slen_not_weird HZsgn; ring.

rewrite (proj2 (Zsgn_pos (\S_{ nk } A - \S_{ nk } B))) //; lia.
rewrite conAE.
Compose_sepcon h2 h1; first by [].
move: Hh1. apply monotony => // h'; exact: mapstos_ext.

(** multi_sub k b X X a0 a1 a2 a3 a4 ret; *)

apply hoare_prop_m.hoare_stren with (fun s h => \S_{ nk } A < \S_{ nk } B /\
  [a ]_ s = va /\ [b ]_ s = vb /\ u2Z ([k ]_ s) = Z_of_nat nk /\
  [X ]_ s = ptr /\ sgZ (s2Z slen) = 1 /\
  ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) ** var_e b |--> B) s h).

rewrite /while.entails => s h [[Ha [Hb [Hk [HX [HZsgn [Hmem HSum]]]]]] Hret].
rewrite /= store.get_r0 Z2uK // in Hret.
move/eqP in Hret.
case: HSum => HSum; last first.
  have {}HSum : [ret ]_ s = zero32 by tauto.
  by rewrite HSum Z2uK in Hret.
split; by [tauto | ].

apply (hoare_prop_m.pull_out_conjunction' hoare0_false) => HAB.

apply while.hoare_seq with (fun s h => exists A', size A' = nk /\
  [a ]_ s = va /\ [b ]_ s = vb /\ u2Z ([k ]_ s) = Z_of_nat nk /\
  [X ]_ s = ptr /\ sgZ (s2Z slen) = 1 /\
  ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A') ** var_e b |--> B) s h /\
  \S_{ nk } A < \S_{ nk } B /\ [a3]_s = zero32 /\
  \S_{ nk } A' = \S_{ nk } B - \S_{ nk } A).

apply (before_frame
  (fun s h => [a ]_ s = va /\ sgZ (s2Z slen) = 1 /\
    (var_e a |--> slen :: ptr :: nil) s h )
  (fun s h => ([b ]_ s) = vb /\ ([X ]_ s) = ptr  /\ u2Z ([k ]_ s) = Z_of_nat nk/\
    (var_e b |--> B ** var_e X |--> A) s h)
  (fun s h => exists A', size A' = nk /\
    [b ]_ s = vb /\ [X ]_ s = ptr /\ u2Z ([k ]_ s) = Z_of_nat nk/\
    [a3]_s = zero32 /\
    (var_e b |--> B ** var_e X |--> A') s h /\
    \S_{ nk } A' = \S_{ nk } B - \S_{ nk } A)).

apply frame_rule_R; last 2 first.
  by Inde_frame.
  move=> ?; by Inde_mult.
apply multi_sub_u_u_R_triple_B_le_A => //.
by Uniq_uniq r0.
exact/ltZW.

move=> s h [Ha [Hb [Hk [HX [HZsgn Hmem]]]]].
rewrite conAE in Hmem.
case: Hmem => h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]].
Compose_sepcon h2 h1; last by [].
repeat (split => //).
rewrite conCE.
move: Hh2; apply monotony => h' //; exact: mapstos_ext.

move=> s h [h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]]].
case: Hh1 => A' [A'_nk [Hb [HX [Hk [Ha3 [Hh1 HSum]]]]]].
case: Hh2 => Ha [HZsgn Hh2].
exists A'; repeat (split => //).
rewrite conAE.
Compose_sepcon h2 h1; first by [].
rewrite conCE.
move: Hh1; apply monotony => h' //; exact: mapstos_ext.

apply (hoare_prop_m.extract_exists extract_exists0) => A'.

(** multi_negate_prg.negate a a0 *)

apply (before_frame
  (fun s h => size A' = nk /\ [a ]_ s = va /\ [b ]_ s = vb /\
    u2Z ([k ]_ s) = Z_of_nat nk /\ [X ]_ s = ptr /\ sgZ (s2Z slen) = 1 /\
    (var_e b |--> B) s h /\ \S_{ nk } B > \S_{ nk } A /\
    ([a3 ]_ s) = zero32 /\ \S_{ nk } A' = \S_{ nk } B - \S_{ nk } A)
  (var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A')
  (var_e a |--> cplt2 slen :: ptr :: nil ** int_e ptr |--> A')).

apply frame_rule_R; last 2 first.
  by Inde_frame.
  move=> ?; by Inde_mult.
apply multi_negate_triple; by Uniq_uniq r0.

move=> s h [A'_nk [Ha [Hb [Hk [HX [Hsgn [Hmem [B_A [Ha3 HSum]]]]]]]]].
case: Hmem => h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]].
Compose_sepcon h1 h2; first by [].
repeat (split => //).
exact: Z.lt_gt.

move=> s h [h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]]].
case : Hh2 => A'_nk [Ha [Hb [Hk [HX [HZsgn [Hh2 [B_A [Ha3 HSum']]]]]]]].
exists (cplt2 slen).
rewrite s2Z_cplt2; last first.
  rewrite weirdE2 slen_not_weird HZsgn; lia.
rewrite Zsgn_Zopp Ha3 Z2uK // mul0Z addZ0.
repeat (split => //).
rewrite slen_not_weird HZsgn mul1Z (proj2 (Zsgn_pos (Z_of_nat nk))) //; lia.
rewrite HZsgn mul1Z (proj2 (Zsgn_neg (\S_{ nk } A - \S_{ nk } B))) //; lia.
by Compose_sepcon h1 h2.
rewrite HZsgn mul1Z HSum'; ring.

(** addiu a3 r0 one16; *)

apply hoare_addiu with (fun s h => [a ]_ s = va /\ [b ]_ s = vb /\
  u2Z [k ]_ s = Z_of_nat nk /\ [X ]_ s = ptr /\ [a0 ]_ s = slen /\
  sgZ (s2Z slen) = - 1 /\ [a3]_s = one32 /\
  ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) ** var_e b |--> B) s h).

move=> s h /= [[Ha [Hb [Hk [HX [Ha0 [Ha1' [Ha1'' Hmem]]]]]]] Ha1].
move/leZP in Ha1.
rewrite /wp_addiu.
repeat Reg_upd; repeat (split => //).
case: Ha1'' => Ha1''.
lia.
case: Ha1'' => Ha1''.
lia.
by rewrite -Ha1' Ha1''.
by rewrite add0i sext_Z2u.
Assert_upd.
move=> s' h' x v /= [] // ?; subst a3; by Reg_upd.

(** multi_add k a3 b X X a0 a1 a2 *)

apply while.hoare_seq with (fun s h => exists A' slen',
  size A' = nk /\ [a]_s = va /\ [b]_s = vb /\ s2Z slen' = sgZ (s2Z slen') * Z_of_nat nk /\
  sgZ (s2Z slen') = sgZ (sgZ (s2Z slen) * \S_{ nk } A - \S_{ nk } B) /\
  ((var_e a |--> slen' :: ptr :: nil ** int_e ptr |--> A') ** var_e b |--> B) s h /\
  u2Z (store.lo s) <= 1 /\
  sgZ (s2Z slen') * (\S_{ nk } A' + u2Z (store.lo s) * \B^nk) =
  sgZ (s2Z slen) * \S_{ nk } A - \S_{ nk } B).

apply (before_frame
  (fun s h => [a ]_ s = va /\ sgZ (s2Z slen) = -1 /\
    (var_e a |--> slen :: ptr :: List.nil) s h)
  (fun s h => [a3]_s = one32 /\ [b ]_ s = vb /\ [X ]_ s = ptr /\
    u2Z ([k ]_ s) = Z_of_nat nk /\ (var_e b |--> B ** var_e X |--> A) s h)
  (fun s h => exists A', size A' = nk /\ [b ]_ s = vb /\ [X ]_ s = ptr /\
    (var_e b |--> B ** var_e X |--> A') s h/\ u2Z (store.lo s) <= 1 /\
    \S_{ nk } A' + u2Z (store.lo s) * \B^nk = \S_{ nk } B + \S_{ nk } A)).

apply frame_rule_R; last 2 first.
  by Inde_frame.
  move=> ?; by Inde_mult.
apply multi_add_u_u_triple => //; by Uniq_uniq r0.

move=> s h /= [Ha [Hb [Hk [HX [Ha0 [Ha1' [Ha3 Hmem]]]]]]].
case: Hmem => h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]].
case: Hh1 => h11 [h12 [h11_d_h12 [h11_U_h12 [Hh11 Hh12]]]].
Compose_sepcon (h12 \U h2) h11.
repeat (split=> //).
Compose_sepcon h2 h12; first by [].
exact: assert_m.mapstos_ext Hh12.
by [].

move=> s h [h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]]].
case: Hh1 => A' [A'_nk [r_b [HX [Hh1 [Hm HSum]]]]].
case: Hh2 => Ha [HZsgn Hh2].
exists A', slen; repeat (split => //).
rewrite HZsgn mulN1Z (proj2 (Zsgn_neg (- \S_{ nk } A - \S_{ nk } B))) //.
move: (min_lSum nk A) => ?; lia.
rewrite conAE .
Compose_sepcon h2 h1; first by [].
rewrite conCE.
move: Hh1; apply assert_m.monotony => // h'; exact: assert_m.mapstos_ext.
rewrite HZsgn HSum; ring.

(** mflo a3 *)

apply hoare_mflo'.
move=> s h /= [A' [slen' [A'_nk [r_a [r_b [slen'_nk [HZsgn [Hmem [Hlo HSum]]]]]]]]].
rewrite /wp_mflo.
exists A', slen'.
repeat Reg_upd.
repeat (split => //).
Assert_upd.
move=> s' h' x v /= [] // ?; subst a3; by Reg_upd.
Qed.

Lemma multi_sub_s_u_triple : forall k a b a0 a1 a2 a3 a4 ret X,
uniq(k, a, b, a0, a1, a2, a3, a4, ret, X, r0) ->
forall nk va vb ptr, nk <> O -> Z_of_nat nk < 2 ^^ 31 ->
  u2Z ptr + 4 * Z_of_nat nk < \B^1 -> u2Z vb + 4 * Z_of_nat nk < \B^1 ->
forall A B, size A = nk -> size B = nk ->
forall slen, s2Z slen = sgZ (s2Z slen) * Z_of_nat nk ->
    sgZ (s2Z slen) = sgZ (sgZ (s2Z slen) * \S_{ nk } A) ->
{{ fun s h => [ a ]_s = va /\ [ b ]_s = vb /\ u2Z [ k ]_s = Z_of_nat nk /\
   ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) ** var_e b |--> B) s h }}
multi_sub_s_u k a b a0 a1 a2 a3 a4 ret X
{{ fun s h => exists A', exists slen', size A' = nk /\ [a]_s = va /\ [b]_s = vb /\
  s2Z slen' = sgZ (s2Z slen') * Z_of_nat nk /\
  sgZ (s2Z slen') = sgZ (sgZ (s2Z slen) * \S_{ nk } A - \S_{ nk } B) /\
  ((var_e a |--> slen' :: ptr :: nil ** int_e ptr |--> A') ** var_e b |--> B ) s h /\
  u2Z ([a3]_ s) <= 1 /\
  sgZ (s2Z slen') * (\S_{ nk } A' + u2Z ([a3]_s) * \B^nk) =
  sgZ (s2Z slen) * \S_{ nk } A - \S_{ nk } B }}.
Proof.
(* NB: similar to multi_add_s_u_triple *)
move=> k a b a0 a1 a2 a3 a4 ret X Hregs nk va vb ptr Hnk Hnk' ptr_fit vb_fit A B
  len_A len_B slen slen_no_weird valid_A.
rewrite /multi_sub_s_u.

(** multi_is_zero k b a0 a1 a2 *)

apply while.hoare_seq with (fun s h => [a]_s = va /\ [b]_s = vb /\
  u2Z [k]_s = Z_of_nat nk /\
  ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) ** var_e b |--> B) s h /\
  ((0 = \S_{ nk } B -> [a2]_s = one32) /\ (0 < \S_{ nk } B -> [a2]_s = zero32))).

apply (before_frame
  (fun s h => [a ]_ s = va /\ (var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) s h)
  (fun s h => u2Z [ k ]_s = Z_of_nat nk /\ [b]_s = vb /\ (var_e b |--> B) s h)
  (fun s h => u2Z [ k ]_s = Z_of_nat nk /\ [b]_s = vb /\ (var_e b |--> B) s h  /\
    ((0 = \S_{ nk } B -> [a2]_s = one32) /\ (0 < \S_{ nk } B -> [a2]_s = zero32)))).

apply frame_rule_R; last 2 first.
  by Inde_frame.
  move=> ?; by Inde_mult.
  apply multi_is_zero_u_triple => //; by Uniq_uniq r0.

move=> s h [Ha [Hb [Hk mem]]].
case: mem =>  h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]].
by Compose_sepcon h2 h1.

move => s h [h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]]].
repeat (split; first by tauto).
split; last by tauto.
Compose_sepcon h2 h1; tauto.

(** ifte (bne a2 r0) *)

apply while.hoare_ifte.

(** addiu a3 r0 zero16 *)

apply hoare_addiu'.
move=> s h [ [Ha [Hb [Hk [mem Hret]]]] Ha2].
rewrite /= in Ha2.
move/eqP in Ha2.
move: (min_lSum nk B).
case/Z_le_lt_eq_dec => Hsum.
apply (proj2 Hret) in Hsum.
by rewrite Hsum Z2uK // store.get_r0 Z2uK // in Ha2.
exists A, slen.
repeat Reg_upd; repeat (split => //).
rewrite -Hsum subZ0; exact valid_A.
by Assert_upd.
by rewrite sext_Z2u // addi0 Z2uK.
rewrite sext_Z2u // addi0 Z2uK // mul0Z addZ0 -Hsum; ring.

(** multi_sub_s_u0 k a b a0 a1 a2 a3 a4 ret X *)

apply hoare_prop_m.hoare_stren with (!(fun s => 0 < \S_{ nk } B) **
  (fun s h => [a ]_ s = va /\[b ]_ s = vb /\ u2Z [k ]_ s = Z_of_nat nk /\
    ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) ** var_e b |--> B) s h)).

move=> s h [[Ha [Hb [Hk [mem Hret]]]] Ha2].
rewrite /= negbK in Ha2.
move/eqP/u2Z_inj in Ha2.
move: (min_lSum nk B).
case/Z_le_lt_eq_dec => Hsum; last first.
 apply (proj1 Hret) in Hsum.
 rewrite Hsum store.get_r0 in Ha2.
 by apply Z2u_dis in Ha2.
by Compose_sepcon heap.emp h.

apply pull_out_bang => nk_B.
exact: multi_sub_s_u0_triple.
Qed.


Require Import Platform.AutoSep Platform.Wrap Platform.StringOps Platform.Malloc Platform.ArrayOps Platform.Buffers Platform.Bags.
Require Import Platform.SinglyLinkedList Platform.ListSegment Platform.RelDb Platform.RelDbCondition.

Set Implicit Arguments.

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

(** * Iterating over matching rows of a table *)

Opaque mult.
Local Infix ";;" := SimpleSeq : SP_scope.

Section Select.
  Variable A : Type.
  Variable invPre : A -> vals -> HProp.
  Variable invPost : A -> vals -> W -> HProp.

  Variable tptr : W.
  Variable sch : schema.

  (* Store a pointer to the current linked list node and actual row data, respectively,
   * in these variables. *)
  Variables rw data : string.

  (* Test to use in filtering rows *)
  Variable cond : condition.

  (* Run this command on every matching row. *)
  Variable body : chunk.

  Definition inv (V_rw V_data : W) := (Ex head, Ex done, Ex remaining, Ex p,
    tptr =*> head * lseg done head V_rw
    * (V_rw ==*> V_data, p) * sll remaining p
    * rows sch head done * rows sch head remaining
    * [| freeable V_rw 2 |] * [| V_rw <> 0 |])%Sep.

  Definition Select' : chunk := (
    rw <-* tptr;;

    [Al bs, Al a : A, Al head, Al done, Al remaining,
      PRE[V] array8 bs (V "buf") * [| length bs = wordToNat (V "len") |] * [| inputOk V (exps cond) |]
        * tptr =*> head * lseg done head (V rw) * sll remaining (V rw)
        * rows sch head done * rows sch head remaining * invPre a V
      POST[R] array8 bs (V "buf") * invPost a V R]
    While (rw <> 0) {
      data <-* rw;;

      Assert [Al bs, Al a : A, Al head, Al done, Al remaining,
        PRE[V] array8 bs (V "buf") * [| length bs = wordToNat (V "len") |] * [| inputOk V (exps cond) |]
          * [| V rw <> 0 |] * tptr =*> head * lseg done head (V rw) * sll (V data :: remaining) (V rw)
          * rows sch head remaining * rows sch head done * row sch (V data) * invPre a V
        POST[R] array8 bs (V "buf") * invPost a V R];;

      compileEqualities
      (fun a V => invPre a V
        * Ex head, Ex done, Ex remaining,
          [| V rw <> 0 |] * tptr =*> head * lseg done head (V rw) * sll (V data :: remaining) (V rw)
          * rows sch head remaining * rows sch head done)%Sep
      invPost
      sch data cond cond;;

      If ("matched" = 0) {
        Skip
      } else {
        body
      };;

      rw <-* rw + 4;;

      Assert [Al bs, Al a : A, Al head, Al done, Al remaining,
        PRE[V] array8 bs (V "buf") * [| length bs = wordToNat (V "len") |] * [| inputOk V (exps cond) |]
          * tptr =*> head * lseg_append (done ++ V data :: nil) head (V rw) * sll remaining (V rw)
          * rows sch head (done ++ V data :: nil) * rows sch head remaining * invPre a V
        POST[R] array8 bs (V "buf") * invPost a V R]
    }
  )%SP.

  Definition sinvar :=
    Al bs, Al a : A,
    PRE[V] array8 bs (V "buf") * [| length bs = wordToNat (V "len") |] * [| inputOk V (exps cond) |]
      * table sch tptr * invPre a V
    POST[R] array8 bs (V "buf") * invPost a V R.

  Definition spost :=
    Al bs, Al a : A,
    PRE[V] array8 bs (V "buf") * [| length bs = wordToNat (V "len") |] * [| inputOk V (exps cond) |]
      * row sch (V data) * inv (V rw) (V data) * invPre a V
    POST[R] array8 bs (V "buf") * invPost a V R.

  Notation svars := (rw :: data :: nil).

  Definition noOverlapExp (e : exp) :=
    match e with
      | Const _ => True
      | Input pos len => pos <> rw /\ pos <> data /\ len <> rw /\ len <> data
    end.

  Definition noOverlapExps := List.Forall noOverlapExp.

  Notation SelectVcs := (fun im ns res =>
    (~In "rp" ns) :: incl svars ns :: (rw <> "rp")%type :: (data <> "rp")%type
    :: incl baseVars ns
    :: (rw <> data)%type
    :: (forall a V V', (forall x, x <> rw -> x <> data
      -> x <> "ibuf" -> x <> "ilen" -> x <> "tmp"
      -> x <> "ipos" -> x <> "overflowed" -> x <> "matched" -> sel V x = sel V' x)
      -> invPre a V ===> invPre a V')
    :: (forall a V V' R, (forall x, x <> rw -> x <> data
      -> x <> "ibuf" -> x <> "ilen" -> x <> "tmp"
      -> x <> "ipos" -> x <> "overflowed" -> x <> "matched" -> sel V x = sel V' x)
      -> invPost a V R = invPost a V' R)
    :: (forall pre mn H,
      (forall specs st, interp specs (pre st)
        -> interp specs (spost true (fun w => w) ns res st))
      -> vcs (VerifCond (toCmd body mn (im := im) H ns res pre)))
    :: (forall specs pre mn H st,
      (forall specs st, interp specs (pre st)
        -> interp specs (spost true (fun w => w) ns res st))
      -> interp specs (Postcondition (toCmd body mn (im := im) H ns res pre) st)
      -> interp specs (spost true (fun w => w) ns res st))
    :: "array8"!"equal" ~~ im ~~> ArrayOps.equalS
    :: (res >= 10)%nat
    :: wfEqualities ns sch cond
    :: ("matched" <> rw)%type
    :: ("matched" <> data)%type
    :: (data <> "ibuf")%type
    :: (data <> "overflowed")%type
    :: (data <> "ipos")%type
    :: (data <> "ilen")%type
    :: (data <> "tmp")%type
    :: (data <> "len")%type
    :: (data <> "buf")%type
    :: In data ns
    :: (rw <> "rp")%type
    :: (rw <> "ibuf")%type
    :: (rw <> "ipos")%type
    :: (rw <> "ilen")%type
    :: (rw <> "tmp")%type
    :: (rw <> "len")%type
    :: (rw <> "buf")%type
    :: (rw <> "overflowed")%type
    :: goodSize (length sch)
    :: noOverlapExps (exps cond)
    :: nil).

  Hint Immediate incl_refl.

  Theorem Forall_impl3 : forall A (P Q R S : A -> Prop) ls,
    List.Forall P ls
    -> List.Forall Q ls
    -> List.Forall R ls
    -> (forall x : A, P x -> Q x -> R x -> S x)
    -> List.Forall S ls.
    induction 1; inversion 1; inversion 1; auto.
  Qed.

  Theorem inputOk_weaken_params : forall ns V V' es,
    inputOk V es
    -> noOverlapExps es
    -> wfExps ns es
    -> (forall x, x <> rw -> x <> data -> sel V x = sel V' x)
    -> rw <> "len"
    -> data <> "len"
    -> inputOk V' es.
    intros; eapply Forall_impl3; [ apply H | apply H0 | apply H1 | ].
    intro e; destruct e; simpl; intuition idtac.
    repeat rewrite <- H2 by (simpl; congruence); assumption.
  Qed.

  Hint Extern 2 (inputOk _ _) => eapply inputOk_weaken_params; try eassumption;
    try (eapply wfEqualities_wfExps; eassumption); [ descend ].

  Ltac q :=
    repeat match goal with
             | [ H : interp ?x ?y, _ : context[Binop _ _ Plus (immInR (natToW 4) _)] |- _ ] =>
               apply compileEqualities_post in H; auto; intros;
                 try match goal with
                       | [ H : interp x y |- _ ] => clear H
                     end;
                 try match goal with
                       | [ |- context[_ ===> _] ] => intros;
                         match goal with
                           | [ H : importsGlobal _ |- _ ] => clear dependent H
                         end
                     end;
                 pre; prep; evalu;
                 try match goal with
                       | [ _ : _ = _ :: ?ls |- _ ] => do 4 eexists; exists ls
                     end
             | [ H : interp ?x ?y |- _ ] => apply compileEqualities_post in H; auto; intros;
               try match goal with
                     | [ H : interp x y |- _ ] => clear H
                   end
             | [ H : _ |- vcs _ ] => apply H; intros; pre; unfold inv
             | [ |- vcs _ ] => apply compileEqualities_vcs; auto; intros
             | [ H : interp _ (Postcondition (toCmd body _ _ _ _ _) _) |- _ ] =>
               invoke1; unfold inv in *
           end; t.

  Definition Select : chunk.
    refine (WrapC Select'
      sinvar
      sinvar
      SelectVcs
      _ _); abstract (wrap0; abstract q).
  Defined.
End Select.

Global Opaque inv.


From hahn Require Import Hahn.
Require Import PromisingLib.
From Promising Require Import Configuration TView View Time Event Cell Thread Memory.
From imm Require Import Events.
From imm Require Import Execution.
From imm Require Import Execution_eco.
From imm Require Import imm_s_hb.
From imm Require Import imm_s.
From imm Require Import imm_bob imm_s_ppo.

Require Import PArith.
From imm Require Import CombRelations.
From imm Require Import CombRelationsMore.

From imm Require Import TraversalConfig.
From imm Require Import Traversal.
From imm Require Import SimTraversal.

Require Import MaxValue.
Require Import ViewRel.
From imm Require Import ViewRelHelpers.
Require Import SimulationRel.
Require Import SimulationPlainStepAux.
Require Import SimulationRelAux.
Require Import MemoryAux.
Require Import SimState.

Set Implicit Arguments.

(* It's a version of Configuration.step which doesn't require
   consistency of the new configuration. *)
Inductive plain_step :
  forall (e:option Event.t) (tid:Ident.t)
         (c1 c2:Configuration.t), Prop :=
| plain_step_intro
    pf e tid c1 lang st1 lc1 e2 st3 lc3 sc3 memory3
    (TID: IdentMap.find tid c1.(Configuration.threads) = Some (existT _ lang st1, lc1))
    (STEPS: rtc (@Thread.tau_step _) (Thread.mk _ st1 lc1 c1.(Configuration.sc) c1.(Configuration.memory)) e2)
    (STEP: Thread.step pf e e2 (Thread.mk _ st3 lc3 sc3 memory3)):
    plain_step (ThreadEvent.get_event e) tid c1 (Configuration.mk (IdentMap.add tid (existT _ _ st3, lc3) c1.(Configuration.threads)) sc3 memory3)
.

Lemma pair_app :
  forall (A B : Prop), A -> (A -> A /\ B) -> A /\ B.
Proof using. ins. intuition. Qed.

Section PlainStepBasic.

Variable G : execution.
Variable WF : Wf G.
Variable sc : relation actid.
Variable CON : imm_consistent G sc.

Notation "'E'" := G.(acts_set).
Notation "'sb'" := G.(sb).
Notation "'rf'" := G.(rf).
Notation "'co'" := G.(co).
Notation "'rmw'" := G.(rmw).
Notation "'data'" := G.(data).
Notation "'addr'" := G.(addr).
Notation "'ctrl'" := G.(ctrl).

Notation "'fr'" := G.(fr).
Notation "'coe'" := G.(coe).
Notation "'coi'" := G.(coi).
Notation "'deps'" := G.(deps).
Notation "'rfi'" := G.(rfi).
Notation "'rfe'" := G.(rfe).
Notation "'detour'" := G.(detour).
Notation "'hb'" := G.(hb).
Notation "'sw'" := G.(sw).

Notation "'lab'" := G.(lab).
(* Notation "'loc'" := (loc lab). *)
(* Notation "'val'" := (val lab). *)
(* Notation "'mod'" := (mod lab). *)
(* Notation "'same_loc'" := (same_loc lab). *)

Notation "'R'" := (fun a => is_true (is_r lab a)).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'F'" := (fun a => is_true (is_f lab a)).
Notation "'RW'" := (R ∪₁ W).
Notation "'FR'" := (F ∪₁ R).
Notation "'FW'" := (F ∪₁ W).

Notation "'Pln'" := (fun a => is_true (is_only_pln lab a)).
Notation "'Rlx'" := (fun a => is_true (is_rlx lab a)).
Notation "'Rel'" := (fun a => is_true (is_rel lab a)).
Notation "'Acq'" := (fun a => is_true (is_acq lab a)).
Notation "'Acqrel'" := (fun a => is_true (is_acqrel lab a)).
Notation "'Acq/Rel'" := (fun a => is_true (is_ra lab a)).
Notation "'Sc'" := (fun a => is_true (is_sc lab a)).

Notation "'Loc_' l" := (fun x => loc lab x = Some l) (at level 1).
Notation "'W_ex'" := G.(W_ex).
Notation "'W_ex_acq'" := (W_ex ∩₁ (fun a => is_true (is_xacq lab a))).

Notation "'Tid_' t" := (fun x => tid x = t) (at level 1).

Definition msg_preserved memory memory' :=
  forall loc ts from msg (INMEM : Memory.get loc ts memory = Some (from, msg)),
    exists from', Memory.get loc ts memory' = Some (from', msg).

Definition msg_preserved_refl memory : msg_preserved memory memory.
Proof using. red. ins. eauto. Qed.

Definition msg_preserved_add memory memory' loc from to val released
           (ADD : Memory.add memory loc from to val released memory') :
  msg_preserved memory memory'.
Proof using. red. ins. exists from0. eapply memory_add_le; eauto. Qed.

Definition msg_preserved_split memory memory'
           loc ts1 ts2 ts3 val2 val3 released2 release3
           (SPLIT : Memory.split
                      memory loc ts1 ts2 ts3
                      val2 val3 released2 release3 memory'):
  msg_preserved memory memory'.
Proof using.
  red. ins.
  erewrite Memory.split_o; eauto.
  edestruct Memory.split_get0 as [HH BB]; eauto.
  destruct (loc_ts_eq_dec (loc0, ts) (loc, ts2)) as [EQ|NEQ].
  { simpls. desf. rewrite HH in INMEM. desf. }
  simpls.
  destruct (loc_ts_eq_dec (loc0, ts) (loc, ts3)) as [EQ|NNEQ].
  { simpls. desf. rewrite BB in INMEM. inv INMEM. eauto. }
  eauto.
Qed.

Lemma full_simrel_step thread PC PC' T T' label f_to f_from
      (COVE  : covered T' ⊆₁ E)
      (ISSE  : issued  T' ⊆₁ E)
      (COVIN : covered T ⊆₁ covered T')
      (ISSIN : issued T ⊆₁ issued T')
      (NINCOV : covered T' \₁ covered T ⊆₁ Tid_ thread)
      (NINISS : issued  T' \₁ issued  T ⊆₁ Tid_ thread)
      (PCSTEP : plain_step label thread PC PC')
      (CLOSED_PRES :
         closedness_preserved PC.(Configuration.memory) PC'.(Configuration.memory))
      (MSG_PRES :
         msg_preserved PC.(Configuration.memory) PC'.(Configuration.memory))
      (TPEQ : forall thread,
          IdentMap.In thread PC.(Configuration.threads) <->
          IdentMap.In thread PC'.(Configuration.threads))
      (SIMREL_THREAD : simrel_thread G sc PC' thread T' f_to f_from sim_normal)
      (SIMREL : simrel G sc PC T f_to f_from) :
  simrel G sc PC' T' f_to f_from.
Proof using WF.
  red. splits; auto.
  { apply SIMREL_THREAD. }
  cdes SIMREL.
  intros thread' TP'.
  destruct (Ident.eq_dec thread thread') as [|NEQ]; subst.
  { apply SIMREL_THREAD. }
  assert (IdentMap.In thread' PC.(Configuration.threads)) as TP.
  { by apply TPEQ. }
  specialize (THREADS thread' TP).
  cdes THREADS.
  assert (IdentMap.find thread' (Configuration.threads PC') =
          Some (existT _ (PromiseLTS.thread_lts thread') state,
                local)) as TID.
  { destruct PCSTEP. simpls. rewrite IdentMap.gso; auto. }
  assert
  (forall a : actid, tid a = thread' -> covered T' a -> covered T a) as PP.
  { intros a TT YY.
    destruct (classic (covered T a)) as [GG|GG]; [done|].
    exfalso.
    assert (tid a = thread) as RR; [|by subst].
    by apply NINCOV; split. }
  cdes SIMREL_THREAD. cdes COMMON. cdes LOCAL.
  red; splits; simpls.
  rewrite TID.
  exists state; exists local; splits; auto.
  2: { red. ins.
       edestruct SIM_PROM as [w H]; eauto.
       des. exists w; splits; auto. }
  5: { eapply sim_state_other_thread_step; eauto; desf. }
  4: { by red; splits; ins; apply CLOSED_PRES; apply MEM_CLOSE. }
  3: { destruct T as [C I]. destruct T' as [C' I'].
       eapply sim_tview_other_thread_step.
       2: by apply COVIN.
       all: eauto.
       etransitivity; [apply TCCOH|]. done. }
  { clear TNNULL0 TNNULL.
    ins. destruct (classic (thread'0 = thread)) as [|TNEQ']; subst.
    { apply or_comm. cdes SIMREL_THREAD.
      rewrite LLH0 in TID'. inv TID'. clear TID'.
      eapply PROM_DISJOINT0; eauto. }
    assert (IdentMap.find thread'0 (Configuration.threads PC) = Some (langst', local'))
      as TT.
    { destruct PCSTEP. simpls. rewrite IdentMap.gso in TID'; auto. }
    eapply PROM_DISJOINT; eauto. }
  red. ins. unnw.
  edestruct SIM_MEM0 as [rel]; eauto.
  simpls; desc.
  exists rel; splits; auto.
  intros BTID.
  assert (~ covered T' b <-> ~ covered T b) as CCB.
  { split; intros CC1 CC2.
      by apply COVIN in CC2.
      assert (tid b = thread) as TT.
      2: by subst; desf.
        by apply NINCOV; split. }
  assert (issued T' b <-> issued T b) as IIB.
  { split; auto.
    intros II.
    destruct (classic (issued T b)) as [|NN]; [done|].
    assert (tid b = thread) as TT.
    2: by subst; desf.
      by apply NINISS; split. }
  rewrite CCB.
  edestruct SIM_MEM as [rel']; eauto.
  { by apply IIB. }
  simpls; desc.
  intros CC.
  destruct H2; auto.
  assert (rel' = rel); [|subst; split; vauto].
  { cdes COMMON0. eapply PROM_IN_MEM0 in H; eauto.
    rewrite INMEM in H. inv H. }
  destruct H0 as [p_rel H0]; desc.
  eexists; split; eauto.
  desf.
  { left; splits; auto.
    intros [y HH]. apply NINRMW.
    exists y. apply seq_eqv_l in HH; destruct HH as [ISSY HH].
    apply seq_eqv_l; split; auto.
    destruct (classic (issued T y)) as [|NISS]; [done|exfalso].
    destruct (classic (tid y = thread)) as [|TNEQ]; subst.
    2: by apply TNEQ; apply NINISS; split.
    assert ((rfe ⨾ rmw) y b) as RFERMW.
    2: { apply NISS.
         apply IIB in ISSB. apply TCCOH in ISSB.
         apply ISSB.
         exists b; apply seq_eqv_r; split; auto.
         destruct RFERMW as [oo [RFE RMW]].
         apply (dom_l WF.(wf_rfeD)) in RFE.
         apply seq_eqv_l in RFE. destruct RFE as [WY RFE].
         apply seq_eqv_l. split; auto.
         apply ct_step. right.
         exists oo. split; [by apply RFE|].
           by apply rmw_in_ppo_loc. }
    hahn_rewrite rfi_union_rfe in HH. hahn_rewrite seq_union_l in HH.
    destruct HH as [HH|]; [exfalso|done].
    assert (W y) as WY.
    { cdes COMMON0. by apply TCCOH0. }
    assert (~ is_init y) as NIN.
    { intros DD. apply NISS. eapply w_covered_issued; eauto.
      split; auto. apply TCCOH.
      split; auto. }
    assert (sb y b) as SBYB.
    { edestruct HH as [z [RFI RMW]].
      eapply (@sb_trans G); [by apply WF.(rfi_in_sbloc'); eauto|].
        by apply WF.(rmw_in_sb). }
    edestruct (sb_tid_init SBYB); desf. }
  right. exists p; splits; auto.
  assert (issued T' p) as ISSP'.
  { apply ISSIN. apply ISSP. }
  assert (loc lab p = Some l) as LOCP.
  { simpls. erewrite wf_rfrmwl; eauto. }
  assert (exists p_v', val lab p = Some p_v') as [p_v' VALP].
  { apply WF.(wf_rfrmwD) in INRMW.
    unfold val, is_w in *. desf.
    all: eexists; eauto. }
  eapply MSG_PRES in P_INMEM. desc.
  edestruct (SIM_MEM0 l) as [p_rel''].
  { cdes COMMON0. apply TCCOH0. apply ISSP'. }
  all: eauto; simpls.
  desc.
  rewrite P_INMEM in INMEM1. inv INMEM1.
  eexists; eexists; splits; eauto.
Qed.

Lemma max_event_cur PC T f_to f_from l e thread foo local smode
      (SIMREL_THREAD : simrel_thread G sc PC thread T f_to f_from smode)
      (NEXT : next G (covered T) e)
      (TID_E : tid e = thread)
      (LOC : loc lab e = Some l)
      (TID: IdentMap.find thread PC.(Configuration.threads) = Some (foo, local)):
  exists p_max,
    ⟪ NEQ : p_max <> e ⟫ /\
    ⟪ CCUR : urr G sc l p_max e ⟫ /\
    ⟪ LB : Time.le
      (View.rlx (TView.cur (Local.tview local)) l)
      (f_to p_max) ⟫.
Proof using WF CON.
  cdes SIMREL_THREAD. cdes COMMON. cdes LOCAL.
  red in SIM_TVIEW; desf.
  red in CUR; desf.
  specialize (CUR l); red in CUR; desc.

  assert (E e) as EE.
  { apply NEXT. }
  assert (~ is_init e) as NINE.
  { intros HH. apply NEXT. by apply TCCOH. }

  destruct MAX as [[MAX MAX'] | MAX].
  { unfold LocFun.find in MAX'.
    rewrite MAX'; ins.
    exists (InitEvent l); splits; [ | | by apply Time.bot_spec].
    { intros H; subst; simpls. }
    apply hb_in_urr.
    apply seq_eqv_l; split; red; [|right].
    { by unfold is_w, loc; rewrite WF.(wf_init_lab). }
    apply sb_in_hb.
    apply init_ninit_sb; auto.
    apply WF.(wf_init). eexists; eauto. }
  desf.
  exists a_max. apply and_assoc; split; auto.
  red in INam; red in INam.
  destruct INam as [y CCUR].
  red in CCUR; hahn_rewrite <- seqA in CCUR.
  apply seq_eqv_r in CCUR; destruct CCUR as [CCUR Y'].
  apply seq_eqv_r in CCUR; destruct CCUR as [CCUR Y].
  assert (hb y e) as HBYE.
  { apply sb_in_hb.
    assert (E y) as EY.
    { eapply (@coveredE G) in Y'; eauto. }
    destruct Y as [Y | Y].
    2: by apply init_ninit_sb.
    destruct (same_thread G e y) as [[ZZ|ZZ]|ZZ]; subst; auto.
    { by apply NEXT in Y'. }
    exfalso.
    assert (covered T e) as Z.
    { apply TCCOH in Y'.
      apply Y'. eexists; apply seq_eqv_r; split; eauto. }
      by apply NEXT in Z. }
  assert ((urr G sc l ⨾ hb) a_max e) as UH.
  { exists y; split; auto. }
  splits.
  { intros H; subst; eapply urr_hb_irr; eauto.
    all: apply CON. }
  apply urr_hb.
  destruct UH as [z [UH HH]].
  eexists; split; eauto.
Qed.

End PlainStepBasic.


Require Import Coq.omega.Omega.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Structures.Traversable.
Require Import ExtLib.Data.HList.
Require Import ExtLib.Data.Eq.
Require Import ExtLib.Tactics.
Require Import MirrorCore.Util.ListMapT.
Require Import MirrorCore.Util.Compat.
Require Import MirrorCore.Util.HListBuild.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.Util.Forwardy.
Require Import MirrorCore.Instantiate.

Set Implicit Arguments.
Set Strict Implicit.

Polymorphic Inductive hlist_Forall2@{A B C}
            {T : Type@{A}} (F : T -> Type@{B}) (G : T -> Type@{C}) (P : forall t, F t -> G t -> Prop)
: forall ls, hlist F ls -> hlist G ls -> Prop :=
| hlist_Forall2_nil : hlist_Forall2 P Hnil Hnil
| hlist_Forall2_cons : forall l ls x xs y ys,
                         @P l x y ->
                         hlist_Forall2 (ls := ls) P xs ys ->
                         hlist_Forall2 P (Hcons x xs) (Hcons y ys).

Section subst.
  Variable T : Type.
  Variable typ : Set.
  Variable expr : Set.
  Context {RType_type : RType typ}.
  Context {RTypeOk_type : RTypeOk}.
  Context {Expr_expr : Expr _ expr}.
  Context {ExprOk_expr : ExprOk _}.

  Class Subst :=
  { subst_lookup : uvar -> T -> option expr
  ; subst_domain : T -> list uvar
  }.

  Class SubstOk (S : Subst) : Type :=
  { WellFormed_subst : T -> Prop
  ; substD : forall (tus tvs : tenv typ), T -> option (exprT tus tvs Prop)
  ; substD_lookup
    : forall s uv e,
        WellFormed_subst s ->
        subst_lookup uv s = Some e ->
        forall tus tvs sD,
          substD tus tvs s = Some sD ->
          exists t val get,
            nth_error_get_hlist_nth _ tus uv = Some (@existT _ _ t get) /\
            exprD tus tvs t e = Some val /\
            forall us vs,
              sD us vs ->
              get us = val us vs
  ; WellFormed_domain : forall s ls,
      WellFormed_subst s ->
      subst_domain s = ls ->
      (forall n, In n ls <-> subst_lookup n s <> None)
  ; lookup_normalized : forall s e u,
      WellFormed_subst s ->
      subst_lookup u s = Some e ->
      forall u' e',
        subst_lookup u' s = Some e' ->
        mentionsU u' e = false
  }.

  Class SubstUpdate :=
  { subst_set : uvar -> expr -> T -> option T
  }.

  Class SubstUpdateOk (S : Subst) (SU : SubstUpdate) (SOk : SubstOk S) :=
  { substR : forall (tus tvs : tenv typ), T -> T -> Prop
  ; Reflexive_substR :> forall tus tvs, Reflexive (substR tus tvs)
  ; Transitive_substR :> forall tus tvs, Transitive (substR tus tvs)
  ; set_sound
      (** TODO(gmalecha): This seems to need to be rephrased as well **)
    : forall uv e s s',
        subst_set uv e s = Some s' ->
        WellFormed_subst s ->
        WellFormed_subst s' /\
        (subst_lookup uv s = None -> (* How important is this? *)
         forall tus tvs t val get sD,
           substD tus tvs s = Some sD ->
           nth_error_get_hlist_nth typD tus uv = Some (@existT _ _ t get) ->
           exprD tus tvs t e = Some val ->
           exists sD',
             substD tus tvs s' = Some sD' /\
             substR tus tvs s s' /\
             forall us vs,
               sD' us vs <->
               (sD us vs /\ get us = val us vs))
  }.

  Class SubstOpen : Type :=
  { subst_drop : uvar -> T -> option T
  ; subst_weakenU : nat -> T -> T
  }.

  Fixpoint models (tus tvs : tenv typ) (tus' : tenv typ) (es : list (option expr))
  : option (hlist typD tus' -> exprT tus tvs Prop) :=
    match tus' as tus' , es
          return option (hlist typD tus' -> exprT tus tvs Prop)
    with
      | nil , nil => Some (fun _ _ _ => True)
      | tu' :: tus' , None :: es =>
        match models (tus ++ tu' :: nil) tvs tus' es with
          | None => None
          | Some x => Some (fun h us vs =>
                              x (hlist_tl h) (hlist_app us (Hcons (hlist_hd h) Hnil)) vs)
        end
      | tu' :: tus' , Some e :: es =>
        match models (tus ++ tu' :: nil) tvs tus' es with
          | None => None
          | Some x =>
            match exprD (tus ++ tu' :: tus') tvs tu' e with
              | None => None
              | Some eD =>
                Some (fun h us vs =>
                           hlist_hd h = eD (hlist_app us h) vs
                        /\ x (hlist_tl h) (hlist_app us (Hcons (hlist_hd h) Hnil)) vs)
            end
        end
      | _ , _ => None
    end.

  Class SubstOpenOk (S : Subst) (SO : SubstOk S) (OS : SubstOpen) : Type :=
  { drop_sound
    : forall s s' u,
        subst_drop u s = Some s' ->
        WellFormed_subst s ->
        WellFormed_subst s' /\
        exists e,
          subst_lookup u s = Some e /\
          subst_lookup u s' = None /\
          (forall u', u' <> u -> subst_lookup u' s = subst_lookup u' s') /\
          forall tus tu tvs sD,
            u = length tus ->
            substD (tus ++ tu :: nil) tvs s = Some sD ->
            exists sD',
              substD tus tvs s' = Some sD' /\
              exists eD,
                exprD tus tvs tu e = Some eD /\
                forall us vs,
                  sD' us vs <->
                  sD (hlist_app us (Hcons (eD us vs) Hnil)) vs
  ; substD_weakenU
    : forall n s s',
        subst_weakenU n s = s' ->
        forall tus tvs tus' sD,
          n = length tus' ->
          substD tus tvs s = Some sD ->
          exists sD',
            substD (tus ++ tus') tvs s' = Some sD' /\
            forall us us' vs,
              sD us vs <-> sD' (hlist_app us us') vs
  }.

  Context {Subst_subst : Subst}.
  Context {SubstOk_subst : SubstOk Subst_subst}.
  Context {SubstUpdate_subst : SubstUpdate}.
  Context {SubstUpdateOk_subst : SubstUpdateOk SubstUpdate_subst SubstOk_subst}.
  Context {SubstOpen_subst : SubstOpen}.
  Context {SubstOpenOk_subst : @SubstOpenOk _ _ _}.

  Lemma substD_conv
  : forall tus tus' tvs tvs' (pfu : tus' = tus) (pfv : tvs' = tvs) s,
      substD tus tvs s =
      match pfu in _ = u' return option (exprT u' _ Prop) with
        | eq_refl =>
          match pfv in _ = v' return option (exprT _ v' Prop) with
            | eq_refl => substD tus' tvs' s
          end
      end.
  Proof.
    clear. destruct pfu. destruct pfv. reflexivity.
  Qed.

  Fixpoint all_Some (ls : list (option expr)) : bool :=
    match ls with
    | nil => true
    | None :: _ => false
    | Some _ :: ls => all_Some ls
    end.

  Fixpoint all_defined (from : uvar) (len : nat) (s : T) : bool :=
    match len with
    | 0 => true
    | S len =>
      match subst_lookup from s with
      | None => false
      | Some _ => all_defined (S from) len s
      end
    end.

  (** This is the "obvious" extension of [drop] **)
  Fixpoint subst_pull (from : uvar) (len : nat) (s : T) : option T :=
    match len with
    | 0 => Some s
    | S len' => match subst_pull (S from) len' s with
               | None => None
               | Some s' => subst_drop from s'
               end
    end.

  Fixpoint seq (start : nat) (len : nat) : list nat :=
    match len with
    | 0 => nil
    | S len => start :: seq (S start) len
    end.

  Lemma getInstantiation_syntactic
  : forall (s : T) tus tvs t (e : expr) sD,
      subst_lookup (length tus) s = Some e ->
      WellFormed_subst s ->
      substD (tus ++ t :: nil) tvs s = Some sD ->
      exists eD,
        exprD tus tvs t e = Some eD /\
        forall us vs x,
          sD (hlist_app us (Hcons x Hnil)) vs ->
          x = eD us vs.
  Proof.
    intros.
    eapply substD_lookup in H1; eauto.
    forward_reason.
    eapply exprD_strengthenU_single in H2; eauto.
    { forward_reason.
      eapply nth_error_get_hlist_nth_appR in H1; simpl in *; try omega.
      rewrite Minus.minus_diag in H1.
      forward_reason; inv_all; subst.
      eexists; split; eauto.
      intros. eapply H3 in H1; clear H3.
      rewrite H4 in H1. rewrite H5 in H1. subst.
      assumption. }
    { apply (@lookup_normalized _ _ _ _ _ H0 H _ _ H). }
  Qed.

(*
  Lemma getInstantiation_syntactic_multi
  : forall (s : T) (tus tvs ts : tenv typ) (es : list expr) sD,
      mapT (fun u => subst_lookup u s) (seq (length tus) (length ts)) = Some es ->
      WellFormed_subst s ->
      substD (tus ++ ts) tvs s = Some sD ->
      exists esD : hlist@{Set Urefl} (fun t => exprT tus tvs (typD t)) ts,
        @hlist_build_option typ (fun t => exprT tus tvs (typD t)) expr
                     (fun t e => exprD tus tvs t e) ts es = Some esD /\
        forall (us : hlist@{Set Urefl} _ _)
          (vs : hlist@{Set Urefl} _ _)
          (us' : hlist@{Set Urefl} (fun _ : typ => _) ts),
          sD (hlist_app us (hlist_map (fun t (x : exprT tus tvs (typD t)) => x us vs) us')) vs ->
          hlist_Forall2 (fun t (x : exprT tus tvs (typD t))
                             (y : exprT tus tvs (typD t)) =>
                           x us vs = y us vs) us' esD.
  Proof.
  Abort.
*)

  Theorem pull_sound
  : forall n s s' u,
      subst_pull u n s = Some s' ->
      WellFormed_subst s ->
      WellFormed_subst s' /\
      forall (tus tus' tvs : tenv typ) sD,
        u = length tus ->
        n = length tus' ->
        substD (tus ++ tus') tvs s = Some sD ->
        exists eus',
          mapT (fun u => subst_lookup u s) (seq u n) = Some eus' /\
          (forall u', u' < u \/ u' > u + n -> subst_lookup u' s = subst_lookup u' s') /\
          (forall u', u' < n -> subst_lookup (u + u') s' = None) /\
        exists sD',
          substD tus tvs s' = Some sD' /\
          exists us' : hlist@{Set Urefl} (fun t => hlist typD tus -> hlist typD tvs -> typD t) tus',
            @hlist_build_option _ _ _ (fun t e => exprD tus tvs t e) tus' eus' = Some us' /\
            forall us vs,
              let us' := hlist_map (fun t (x : hlist typD tus -> hlist typD tvs -> typD t) => x us vs) us' in
              sD' us vs <->
              sD (hlist_app us us') vs.
  Proof.
    Opaque mapT.
    induction n.
    { intros. simpl in *.
      inv_all. subst.
      split; auto.
      intros. subst.
      destruct tus'; try solve [ simpl in * ; congruence ].
      clear H1.
      exists nil. split; [ reflexivity | ].
      split; try reflexivity.
      split; [ inversion 1 | ].
      rewrite substD_conv with (pfu := eq_sym (app_nil_r_trans tus)) (pfv := eq_refl) in H2.
      autorewrite_with_eq_rw_in H2.
      forward.
      eexists; split; eauto.
      simpl. eexists; split; eauto.
      inv_all. subst.
      simpl. intros. rewrite hlist_app_nil_r.
      autorewrite with eq_rw. reflexivity. }
    { simpl. intros. forward.
      eapply IHn in H; clear IHn; auto.
      forward_reason.
      eapply drop_sound in H1; auto.
      forward_reason; split; auto.
      intros; subst.
      rewrite list_mapT_cons.
      destruct tus'; try solve [ simpl in *; congruence ].
      specialize (H2 (tus ++ t0 :: nil) tus' tvs).
      rewrite substD_conv with (pfv := eq_refl)
                               (pfu := app_ass_trans tus (t0 :: nil) tus') in H9.
      autorewrite_with_eq_rw_in H9.
      forwardy.
      assert (S (length tus) = length (tus ++ t0 :: nil)).
      { rewrite app_length. simpl. omega. }
      assert (n = length tus').
      { simpl in *; congruence. }
      specialize (H2 _ H10 H11 H7); clear H10 H11.
      forward_reason.
      rewrite H10 by omega. rewrite H3.
      change_rewrite H2.
      eexists; split; eauto.
      split; [ | split ].
      { destruct 1.
        { rewrite H10; eauto. rewrite H5 by omega. reflexivity. }
        { rewrite H10 by omega. rewrite H5 by omega. reflexivity. } }
      { intros. destruct u'.
        { replace (length tus + 0) with (length tus) by omega.
          assumption. }
        { replace (length tus + S u') with (S (length tus) + u') by omega.
          rewrite <- H5 by omega.
          eapply H11. omega. } }
      { specialize (H6 tus _ tvs _ eq_refl H12).
        forward_reason.
        eexists; split; eauto.
        simpl. rewrite H15.
        assert (exists us',
                  hlist_build_option
                    (fun t1 : typ =>
                       hlist typD tus -> hlist typD tvs -> typD t1)
                    (fun (t1 : typ) (e : expr) => exprD tus tvs t1 e) tus' x0 = Some us' /\
                  forall us vs val,
                    hlist_Forall2 (fun (t : typ)
                                       (x : hlist typD tus -> hlist typD tvs -> typD t)
                                       (y : hlist typD (tus ++ _ :: nil) -> hlist typD tvs -> typD t) =>
                                     x us vs = y (hlist_app us (Hcons val Hnil)) vs) us' x2).
        { clear H14. generalize dependent x2.
          assert (forall e, In e x0 ->
                            mentionsU (length tus) e = false).
          { intros.
            eapply mapT_In in H13; try eassumption.
            simpl in H13.
            forward_reason.
            eapply lookup_normalized.
            2: eassumption. eassumption.
            rewrite <- H10 in H3. eapply H3.
            left. omega. }
          generalize tus'. clear H7 H2.
          induction x0.
          { intros. destruct tus'0; simpl in *; try congruence.
            inv_all; subst. eexists; split; eauto.
            intros. constructor. }
          { intros. destruct tus'0; simpl in *; try congruence.
            forwardy. inv_all; subst.
            eapply IHx0 in H2; eauto.
            forward_reason.
            change_rewrite H2.
            assert (exists val, exprD tus tvs t1 a = Some val /\
                                forall us vs v,
                                  val us vs = y1 (hlist_app us (Hcons v Hnil)) vs).
            { eapply exprD_strengthenU_single in H7; eauto.
              forward_reason. eauto. }
            forward_reason. rewrite H9.
            eexists; split; eauto. intros.
            constructor; eauto. } }
        { forward_reason.
          change_rewrite H17.
          eexists; split; eauto.
          intros.
          inv_all; subst. clear H10 H11.
          rewrite H16; clear H16.
          rewrite H14; clear H14.
          simpl.
          rewrite hlist_app_assoc. simpl.
          autorewrite with eq_rw.
          match goal with
            | |- _ ?X _ <-> _ ?Y _ =>
              cutrewrite (X = Y); try reflexivity
          end.
          apply match_eq_match_eq.
          f_equal. f_equal.
          revert H13 H17.
          specialize (H18 us vs (x4 us vs)).
          clear - H18.
          generalize dependent x0.
          revert H18; revert x2; revert x5; revert tus'.
          refine (@hlist_Forall2_ind _ _ _ _ _ _ _).
          { simpl. reflexivity. }
          { simpl; intros.
            destruct x0; try congruence.
            specialize (H1 x0).
            repeat match goal with
                     | H : context [ ?X ] , H' : match ?Y with _ => _ end = _ |- _ =>
                       change Y with X in H' ; destruct X ; try congruence
                   end.
            forwardy. inv_all. subst.
            rewrite H1; auto. rewrite H. reflexivity. } } } }
  Qed.

  Lemma In_seq : forall a c b,
      In a (seq b c) <-> (b <= a /\ a < b + c).
  Proof.
    clear.
    induction c; simpl; intros.
    { split. destruct 1. intros. omega. }
    { split; intros.
      { destruct H. subst. omega. eapply IHc in H. omega. }
      { consider (b ?[ eq ] a).
        { intros. subst; auto. }
        { right. eapply IHc. omega. } } }
  Qed.

  Lemma sem_preserves_if_substD
  : forall tus tvs s sD,
      WellFormed_subst s ->
      substD tus tvs s = Some sD ->
      sem_preserves_if_ho (fun P => forall us vs, sD us vs -> P us vs)
                          (fun u => subst_lookup u s).
  Proof.
    red. intros.
    eapply substD_lookup in H1; eauto.
    forward_reason.
    change_rewrite H2 in H1.
    inv_all; subst.
    eapply nth_error_get_hlist_nth_Some in H2.
    forward_reason. simpl in *.
    eexists; split; eauto.
  Qed.

End subst.

Arguments SubstOk T typ expr {_ _ _}.
Arguments SubstUpdateOk T typ expr {_ _ _ _ _}.
Arguments subst_pull {T SO} _ _ _ : rename.


(******************************************************************************)
(* A bit library for Coq: extraction to machine words.                        *)
(******************************************************************************)
(*                                                                            *)
(* (c) 2016, ENS Lyon, LIP6, MINES ParisTech                                  *)
(*                                                                            *)
(* Written by Arthur Blot                                                     *)
(*            Pierre-Evariste Dagand                                          *)
(*            Emilio J. Gallego Arias                                         *)
(*                                                                            *)
(* LICENSE: Dual CECILL-B / Apache 2.0                                        *)
(*                                                                            *)
(******************************************************************************)

From mathcomp
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype.

From mathcomp
Require Import tuple ssralg ssrnum zmodp.

From CoqEAL
Require Import hrel param refinements.

From ssrbit
Require Import bitseq notation.

From Coq
Require Import ZArith.ZArith ExtrOcamlBasic.

Import Refinements.Op.
Import Logical.Op.

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

(** * An axiomatization of OCaml native integers *)

(** This module should not be used directly. *)
Module Native.

(** We assume that we are running on a 64 bit machine. *)
Axiom Int : Type.
Axiom eq  : Int -> Int -> bool.

Axiom zero : Int.
Axiom one  : Int.
Axiom opp  : Int -> Int.
Axiom sub  : Int -> Int -> Int.
Axiom add  : Int -> Int -> Int.

Axiom lnot : Int -> Int.
Axiom lor  : Int -> Int -> Int.
Axiom land : Int -> Int -> Int.
Axiom lxor : Int -> Int -> Int.
Axiom lsr  : Int -> Int -> Int.
Axiom lsl  : Int -> Int -> Int.

Extract Inlined Constant Int  => "int".
Extract Inlined Constant eq   => "(=)".
Extract Inlined Constant zero => "0".
Extract Inlined Constant one  => "1".
Extract Inlined Constant lor  => "(lor)".
Extract Inlined Constant land => "(land)".
Extract Inlined Constant lsr  => "(lsr)".
Extract Inlined Constant lxor => "(lxor)".

(** One must be careful to re-normalize the following operations when
using them at smaller wordsize: *)

Extract Inlined Constant lsl  => "(lsl)".
Extract Inlined Constant lnot => "lnot".
Extract Inlined Constant add  => "(+)".
Extract         Constant opp  => "(fun x -> -x)".
Extract Inlined Constant sub  => "(-)".

End Native.

Import Native.

Global Instance   eq_Native : eq_of   Int := eq.

Global Instance zero_Native : zero_of Int := zero.
Global Instance  one_Native : one_of  Int := one.
Global Instance  opp_Native : opp_of  Int := opp.
Global Instance  sub_Native : sub_of  Int := sub.
Global Instance  add_Native : add_of  Int := add.

Global Instance  not_Native : not_of  Int := lnot.
Global Instance   or_Native : or_of   Int := lor.
Global Instance  and_Native : and_of  Int := land.
Global Instance  xor_Native : xor_of  Int := lxor.
Global Instance  shl_Native : shl_of  Int Int := lsl.
Global Instance  shr_Native : shr_of  Int Int := lsr.

Section BitExtract.

Variable n : nat.
Implicit Types (s : bitseq) (b : 'B_n).

Fixpoint bitsToInt s : Int :=
  (match s with
    | [::]           => 0
    | [:: false & s] =>      bitsToInt s :<<: 1
    | [:: true  & s] => 1 || (bitsToInt s :<<: 1)
  end)%C.

Fixpoint bitsFromInt (k: nat) (n: Int) : bitseq :=
  (match k with
    | 0 => [::]
    | k.+1 =>
      let p := bitsFromInt k (n :>>: 1) in
      ((n && 1) == 1) :: p
  end)%C.

Lemma bitsFromIntP {k} (i: Int): size (bitsFromInt k i) == k.
Proof.
  elim: k i => // [k IH] i //=; rewrite eqSS //.
Qed.

Canonical bitsFromInt_tuple (i: Int): 'B_n
  := Tuple (bitsFromIntP i).

End BitExtract.

(** * Extraction  *)

(* Following CompCert's Integer module *)
Module Type WORDSIZE.
  Variable wordsize: nat.
End WORDSIZE.

Module MakeOps (WS: WORDSIZE).

Definition w := WS.wordsize.

Definition Int  := Native.Int.
Definition eq   := Native.eq.
Definition zero := Native.zero.
Definition one  := Native.one.
Definition lor  := Native.lor.
Definition land := Native.land.
Definition lsr  := Native.lsr.
Definition lxor := Native.lxor.

Definition wordsize := bitsToInt (bitn 63 WS.wordsize).

Definition bitmask := ((1 :<<: wordsize) - 1: Int)%C.

Definition mask_unop  (f : Int -> Int) x := (bitmask && f x)%C.
Definition mask_binop (f : Int -> Int -> Int) x y := (bitmask && f x y)%C.

Definition lnot := mask_unop Native.lnot.
Definition opp  := mask_unop Native.opp.

Definition lsl := mask_binop Native.lsl.
Definition add := mask_binop Native.add.
Definition sub := mask_binop Native.sub.

End MakeOps.

Module Wordsize_32.
  Definition wordsize := 32.
End Wordsize_32.

Module Int32 := MakeOps(Wordsize_32).

Module Wordsize_16.
  Definition wordsize := 16.
End Wordsize_16.

Module Int16 := MakeOps(Wordsize_16).

Module Wordsize_8.
  Definition wordsize := 8.
End Wordsize_8.

Module Int8 := MakeOps(Wordsize_8).