Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsRef2.Spec.
Require Import TableDataOpsRef3.Specs.data_destroy3.
Require Import TableDataOpsRef3.LowSpecs.data_destroy3.
Require Import TableDataOpsRef3.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       data_destroy_spec
       data_destroy2_spec
    .

  Lemma data_destroy3_spec_exists:
    forall habd habd'  labd g_rd map_addr res
      (Hspec: data_destroy3_spec g_rd map_addr habd = Some (habd', res))
      (Hrel: relate_RData habd labd),
    exists labd', data_destroy3_spec0 g_rd map_addr labd = Some (labd', res) /\ relate_RData habd' labd'.
  Proof.
    Local Opaque peq ptr_eq.
    intros. duplicate Hrel. destruct D. clear hrepl lrepl. destruct g_rd.
    unfold data_destroy3_spec, data_destroy3_spec0 in *.
    unfold Assertion in *. rm_bind Hspec; rm_bind'. simpl in *.
    unfold Assertion; rm_bind'; grewrite.
    repeat simpl_hyp Hspec; extract_prop_dec; simpl_query_oracle; rm_bind'; grewrite.
    - repeat destruct_con.
      match type of Hcond6 with
      | is_gidx ?gidx = true => remember gidx as lv1_gidx eqn:Hlv1_gidx; symmetry in Hlv1_gidx
      end.
      match type of Hcond3 with
      | is_gidx ?gidx = true => remember gidx as lv2_gidx eqn:Hlv2_gidx; symmetry in Hlv2_gidx
      end.
      match type of Hcond0 with
      | is_gidx ?gidx = true => remember gidx as llt_gidx eqn:Hllt_gidx; symmetry in Hllt_gidx
      end.
      match type of Prop0 with
      | glock ?a @ ?gidx = None => remember gidx as data_gidx eqn:Hdata_gidx; symmetry in Hdata_gidx
      end.
      rewrite_oracle_rel rel_oracle C2; simpl in *.
      repeat (grewrite; simpl).
      assert(Hwalk: repl habd (oracle habd
                                      (EVT CPU_ID (RTT_WALK (g_rtt (gnorm (gs (share habd)) @ z)) z0 3) :: oracle habd (log habd) ++ log habd))
                         s {gs : (gs s) # llt_gidx == (((gs s) @ llt_gidx) {glock : Some CPU_ID})} =
                    Some (s {gs : (gs s) # llt_gidx == (((gs s) @ llt_gidx) {glock : Some CPU_ID})})).
      destruct Hrel. grewrite. destruct valid_ho0. rewrite Hright_log_nil. reflexivity.
      eapply RightLogMover.
      apply walk_right. omega. omega. apply RightLogOracle. simpl.
      rewrite_oracle_rel rel_oracle Hwalk; simpl in *.
      repeat (grewrite; try simpl_htarget; simpl).
      inversion Hspec. eexists; split. reflexivity.
      constructor; destruct Hrel; simpl; try assumption; try reflexivity.
      rewrite <- Prop4. simpl_field.
      assert(data_gidx <> llt_gidx). red; intro T; rewrite T in *. bool_rel. autounfold in *. omega.
      repeat rewrite (zmap_comm _ _ H). repeat (try simpl_htarget; repeat simpl_field; repeat swap_fields).
      reflexivity.
    - repeat destruct_con.
      match type of Hcond6 with
      | is_gidx ?gidx = true => remember gidx as lv1_gidx eqn:Hlv1_gidx; symmetry in Hlv1_gidx
      end.
      match type of Hcond3 with
      | is_gidx ?gidx = true => remember gidx as lv2_gidx eqn:Hlv2_gidx; symmetry in Hlv2_gidx
      end.
      match type of Hcond0 with
      | is_gidx ?gidx = true => remember gidx as llt_gidx eqn:Hllt_gidx; symmetry in Hllt_gidx
      end.
      match type of Prop0 with
      | glock ?a @ ?gidx = None => remember gidx as data_gidx eqn:Hdata_gidx; symmetry in Hdata_gidx
      end.
      rewrite_oracle_rel rel_oracle C2; simpl in *.
      repeat (grewrite; simpl). simpl_htarget.
      inversion Hspec. eexists; split. reflexivity.
      constructor; destruct Hrel; simpl; try assumption; try reflexivity. simpl_htarget. reflexivity.
    - repeat destruct_con.
      match type of Hcond3 with
      | is_gidx ?gidx = true => remember gidx as lv2_gidx eqn:Hlv2_gidx; symmetry in Hlv2_gidx
      end.
      match type of Hcond0 with
      | is_gidx ?gidx = true => remember gidx as llt_gidx eqn:Hllt_gidx; symmetry in Hllt_gidx
      end.
      match type of Prop0 with
      | glock ?a @ ?gidx = None => remember gidx as data_gidx eqn:Hdata_gidx; symmetry in Hdata_gidx
      end.
      rewrite_oracle_rel rel_oracle C2; simpl in *.
      repeat (grewrite; simpl). simpl_htarget.
      inversion Hspec. eexists; split. reflexivity.
      constructor; destruct Hrel; simpl; try assumption; try reflexivity.
    - rewrite_oracle_rel rel_oracle C2.
      repeat destruct_con.
      match type of Hcond0 with
      | is_gidx ?gidx = true => remember gidx as llt_gidx eqn:Hllt_gidx; symmetry in Hllt_gidx
      end.
      match type of Prop0 with
      | glock ?a @ ?gidx = None => remember gidx as data_gidx eqn:Hdata_gidx; symmetry in Hdata_gidx
      end.
      repeat (grewrite; simpl).
      repeat (grewrite; try simpl_htarget; simpl).
      inversion Hspec. eexists; split. reflexivity.
      constructor; destruct Hrel; simpl; try assumption; try reflexivity.
    - rewrite_oracle_rel rel_oracle C2.
      repeat (grewrite; simpl).
      repeat (grewrite; try simpl_htarget; simpl).
      inversion Hspec. eexists; split. reflexivity.
      constructor; destruct Hrel; simpl; try assumption; try reflexivity.
  Qed.

End Refine.


From iris.algebra Require Import frac.
From iris.proofmode Require Import tactics.
Require Import Eqdep_dec List.
From cap_machine Require Import malloc macros.
From cap_machine Require Import fundamental logrel macros_helpers rules proofmode.
From cap_machine.examples Require Import template_adequacy.
From cap_machine Require Import register_tactics.
Open Scope Z_scope.

(** Exercise - the region is already allocated and the capability pointing to this
    region is in R1. As a first step, the adversary code is known and just halts. *)
Section base_program.
  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ}
          `{MP: MachineParameters}.

  (** r_mem is the register that contains the capability pointing to
      the allocated buffer
      secret_off is the offset of the secret in the buffer
      secret is the value stored in the buffer
   *)
  Definition prog_base_instrs r_mem (secret_off secret : Z) : list Word :=
    encodeInstrsW [
      Lea r_mem secret_off ;
      Store r_mem secret ;
      GetB r_t2 r_mem ;
      GetE r_t3 r_mem ;
      Add r_t2 r_t2 (secret_off + 1) ;
      Subseg r_mem r_t2 r_t3
      ].

  (** Jump to the adversary in register r30 at the end of the program *)
  Definition prog_code secret_off secret_val: list Word :=
    prog_base_instrs r_t1 secret_off secret_val ++ encodeInstrsW [Jmp r_t30].

  (** The adversary code is known --- it just halts *)
  Definition adv_code : list Word :=
    encodeInstrsW [ Halt ].

  (** Specification of :
      - executes the first part
      - jump to the adversary
      - halts
   *)
  Lemma prog_spec (a_adv: Addr)
        p_pc b_pc e_pc a_prog (* pc *)
        p_mem b_mem e_mem (* mem *)
        secret_off secret_val
        w2 w3 :
    let secret := (b_mem^+secret_off)%a in
    let len_p := (a_prog ^+ length (prog_code secret_off secret_val))%a in

    ExecPCPerm p_pc ->
    SubBounds b_pc e_pc a_prog len_p ->

    (b_mem <= secret < e_mem)%a ->
    writeAllowed p_mem = true ->

    ⊢ ( (* PC points to prog_code*)
        PC ↦ᵣ WCap p_pc b_pc e_pc a_prog
        ∗ codefrag a_prog (prog_code secret_off secret_val)
        (* r1 points to the allocated memory*)
        ∗ r_t1 ↦ᵣ WCap p_mem b_mem e_mem b_mem
        (* which is filled by zeroes *)
        ∗ [[b_mem, e_mem]] ↦ₐ [[ region_addrs_zeroes b_mem e_mem ]]
        (* r30 point to the adversary code *)
        ∗ r_t30 ↦ᵣ WCap E a_adv (a_adv ^+ (length adv_code))%a a_adv
        ∗ codefrag a_adv adv_code
        ∗ r_t2 ↦ᵣ w2
        ∗ r_t3 ↦ᵣ w3
        -∗ WP Seq (Instr Executable) {{
                λ v, ⌜v = HaltedV⌝ -∗ (* The machine is halted after the adversary *)
                     r_t1 ↦ᵣ WCap p_mem (b_mem^+(secret_off+1))%a e_mem secret%a
                     ∗ r_t2 ↦ᵣ WInt (b_mem+(secret_off +1))
                     ∗ r_t3 ↦ᵣ WInt e_mem
                     ∗ codefrag a_prog (prog_code secret_off secret_val)
                     ∗ codefrag a_adv adv_code
                     ∗ secret ↦ₐ WInt secret_val
                     ∗ [[b_mem, secret]] ↦ₐ [[ region_addrs_zeroes b_mem secret]]
                     ∗ [[(secret ^+1)%a, e_mem]] ↦ₐ [[ region_addrs_zeroes (secret^+1)%a e_mem ]]
      }})%I.

  Proof.
    intros * Hpc_perm Hpc_bounds Hlen_mem Hp_mem.
    iIntros "(HPC& Hprog& Hr1& Hmem& Hr30& Hadv& Hr2& Hr3)".

    (* 1 - prepare the assertions for the proof *)
    subst secret len_p.
    (* Derives the facts from the codefrag *)
    codefrag_facts "Hprog".
    codefrag_facts "Hadv".
    simpl in *.
    rewrite /prog_code.
    (* This assertion will be helpful seeral times during the proof *)
    assert (Hp_mem': ~ p_mem = E)
           by (intros -> ; simpl in Hp_mem ; discriminate).

    (* 2 - Use the WP rules for each instructions *)
    (* Lea r_t1 3 *)
    iInstr "Hprog".
    { transitivity (Some (b_mem ^+secret_off)%a) ; auto. solve_addr. }
    (* Store r_t1 42 , where r_t1 = (RWX, b, e, secret) *)
    (* The store requires the resource `secret ↦ₐ w` for some w,
       we thus extract the resource from the memory buffer *)
    rewrite (region_addrs_zeroes_split b_mem (b_mem ^+secret_off)%a e_mem)
    ; [| solve_addr].
    iDestruct (region_mapsto_split
                 b_mem e_mem
                 (b_mem ^+secret_off)%a
                 (region_addrs_zeroes b_mem (b_mem ^+secret_off)%a)
                 (region_addrs_zeroes (b_mem ^+secret_off)%a e_mem)
                with "Hmem") as "[Hmem Hmem']".
    { solve_addr. }
    { unfold region_addrs_zeroes. by rewrite replicate_length. }
    unfold region_addrs_zeroes at 2.
    rewrite finz_dist_S ; [|solve_addr].
    rewrite replicate_S.
    iDestruct (region_mapsto_cons (b_mem ^+secret_off)%a _ e_mem (WInt 0)
                                   (region_addrs_zeroes _ e_mem)
                with "Hmem'") as "[Hsecret Hmem']".
    { transitivity (Some (b_mem ^+(secret_off +1))%a) ; auto. solve_addr. }
    { solve_addr. }
    (* Now that we have the secret address, we can continue *)
    iInstr "Hprog".
    { solve_addr. }
    (* getB, getE, add, subseg *)
    iGo "Hprog".
    { transitivity (Some (b_mem ^+(secret_off+1))%a) ; auto. solve_addr. }
    { solve_addr. }
    (* jmp *)
    iInstr "Hprog".
    (* halts in the adversary code *)
    rewrite /adv_code.
    iInstr "Hadv".

    (* 3 - The machine is halted, prove that the post condition holds *)
    wp_end.
    iIntros "_".
    replace ((b_mem ^+ secret_off) ^+ 1)%a with (b_mem ^+ (secret_off+1))%a by solve_addr.
    iFrame.
  Qed.

End base_program.

(** We use a CPS specification. We don't know the adversary code,
    thus we stop the specification after the jump. We give only the necessary
    ressources. *)
Section base_program_CPS.

  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ} {sealsg : sealStoreG Σ}
          `{MP: MachineParameters}.

  Local Ltac solve_addr' :=
    repeat match goal with x := _ |- _ => subst x end
    ; solve_addr.

  Local Ltac iGo' hprog :=
    repeat
    (iGo hprog ;
    try (
    match goal with
    | h: _ |- isCorrectPC _ =>
        apply isCorrectPC_ExecPCPerm_InBounds ; auto; solve_addr'
    end)
    ; try solve_addr').

  (** Specification of the program before the jump to the adversary.
      The specification and the proof are essentially the same as the
      previous one. *)
  Lemma prog_base_spec
        r_mem secret_off secret (* instantiation prog_base *)
        p_pc b_pc e_pc s_prog (* pc *)
        p_mem b_mem e_mem (* mem *)
        w2 w3
        φ :

    let e_prog := (s_prog ^+ length (prog_base_instrs r_mem secret_off secret))%a in
    let a_secret := (b_mem ^+ secret_off)%a in

    (* Validity pc *)
    ExecPCPerm p_pc ->
    SubBounds b_pc e_pc s_prog e_prog ->

    (* Validity buffer *)
    ( b_mem <= a_secret < e_mem)%a ->
    writeAllowed p_mem = true ->

    (* Specification *)
    ⊢ (( PC ↦ᵣ WCap p_pc b_pc e_pc s_prog
         ∗ r_mem ↦ᵣ WCap p_mem b_mem e_mem b_mem
         ∗ r_t2 ↦ᵣ w2
         ∗ r_t3 ↦ᵣ w3
         ∗ [[b_mem, e_mem]] ↦ₐ [[ region_addrs_zeroes b_mem e_mem ]]
         ∗ codefrag s_prog (prog_base_instrs r_mem secret_off secret)
         ∗ ▷ ( PC ↦ᵣ WCap p_pc b_pc e_pc e_prog
               ∗ r_mem ↦ᵣ WCap p_mem (a_secret^+1)%a e_mem a_secret
               ∗ r_t2 ↦ᵣ WInt (b_mem+secret_off+1)
               ∗ r_t3 ↦ᵣ WInt e_mem
               ∗ [[b_mem, a_secret]] ↦ₐ [[ region_addrs_zeroes b_mem a_secret ]]
               ∗ a_secret ↦ₐ WInt secret
               ∗ [[(a_secret ^+1)%a, e_mem]] ↦ₐ [[ region_addrs_zeroes (a_secret^+1)%a e_mem ]]
               ∗ codefrag s_prog (prog_base_instrs r_mem secret_off secret)
               -∗ WP Seq (Instr Executable) {{ φ }}))
       -∗ WP Seq (Instr Executable) {{ φ }})%I.
  Proof with (try solve_addr').
    intros e_prog a_secret.
    iIntros (Hpc_perm Hpc_bounds Hsecret_bounds Hp_mem)
            "(HPC & Hr_mem & Hr2 & Hr3 & Hmem & Hprog & Post)".
    rewrite /region_mapsto.
    codefrag_facts "Hprog".
    iGo' "Hprog".
    { transitivity (Some (b_mem ^+ secret_off)%a) ; auto ; solve_addr'. }
    { intros -> ; simpl in Hp_mem ; discriminate. }

    rewrite (region_addrs_zeroes_split b_mem a_secret e_mem)...
    iDestruct (region_mapsto_split
                 b_mem e_mem
                 a_secret
                 (region_addrs_zeroes b_mem a_secret)
                 (region_addrs_zeroes a_secret e_mem)
                with "Hmem") as "[Hmem Hmem']"...
    { unfold region_addrs_zeroes. by rewrite replicate_length. }
    unfold region_addrs_zeroes at 4.
    rewrite finz_dist_S...
    rewrite replicate_S.
    iDestruct (region_mapsto_cons a_secret (a_secret ^+1)%a e_mem (WInt 0)
                                   (region_addrs_zeroes _ e_mem)
                with "Hmem'") as "[Hsecret Hmem']"...
    iGo' "Hprog".
    (* getB getE add subseg *)
    { transitivity (Some (b_mem ^+ (secret_off + 1))%a) ; auto... }
    { intros -> ; simpl in Hp_mem ; discriminate. }
    { solve_addr'. }

    (* Post condition *)
    iApply "Post".
    subst e_prog; simpl in *.
    replace (b_mem ^+ (secret_off + 1))%a with (a_secret ^+ 1)%a by solve_addr'.
    replace (b_mem + secret_off + 1) with (b_mem + (secret_off + 1)) by lia.
    iFrame.
  Qed.

  (** Specification of the program until the jump to the unknown adversary code *)
  Lemma prog_spec_CPS
        wadv
        p_pc b_pc e_pc a_prog (* pc *)
        p_mem b_mem e_mem (* mem *)
        w2 w3
        secret_off secret_val
        φ :
    let secret := (b_mem^+secret_off)%a in
    let len_p := (a_prog ^+ length (prog_code secret_off secret_val))%a in

    ExecPCPerm p_pc ->
    SubBounds b_pc e_pc a_prog len_p ->

    (b_mem <= secret < e_mem)%a ->
    writeAllowed p_mem = true ->

    ⊢ ( (* PC points to prog_code*)
        ( PC ↦ᵣ WCap p_pc b_pc e_pc a_prog
        ∗ codefrag a_prog (prog_code secret_off secret_val)
          (* r1 points to the allocated memory*)
          ∗ r_t1 ↦ᵣ WCap p_mem b_mem e_mem b_mem
          (* which is filled by zeroes *)
          ∗ [[b_mem, e_mem]] ↦ₐ [[ region_addrs_zeroes b_mem e_mem ]]
          (* r30 point to the adversary code *)
          ∗ r_t30 ↦ᵣ wadv
          ∗ r_t2 ↦ᵣ w2
          ∗ r_t3 ↦ᵣ w3
          ∗ ▷ ( PC ↦ᵣ updatePcPerm wadv (* The specification stops after the jump *)
                ∗ r_t1 ↦ᵣ WCap p_mem (b_mem^+(secret_off+1))%a e_mem secret%a
                ∗ r_t2 ↦ᵣ WInt (b_mem+(secret_off +1))
                ∗ r_t3 ↦ᵣ WInt e_mem
                ∗ r_t30 ↦ᵣ wadv
                ∗ codefrag a_prog (prog_code secret_off secret_val)
                ∗ [[(secret ^+1)%a, e_mem]] ↦ₐ [[ region_addrs_zeroes (secret^+1)%a e_mem ]]
                -∗ WP Seq (Instr Executable) {{ φ }}))
        -∗ WP Seq (Instr Executable) {{ φ }})%I.
  Proof.
    intros * Hpc_perm Hpc_bounds Hlen_mem Hp_mem.
    iIntros "(HPC& Hprog& Hr1& Hmem& Hr30& Hr2& Hr3& Post)".
    rewrite /prog_code.
    codefrag_facts "Hprog".
    focus_block_0 "Hprog" as "Hprog" "Hcont".
    (* 1 - Specification from Lea to Subsug *)
    iApply (prog_base_spec with "[-]")
    ; try (iFrame ; iFrame "#")
    ; eauto
    ; try solve_addr'.
    iNext ; iIntros "(HPC & Hr1 & Hr2 & Hr3 & Hmem & Hsecret & Hmem' & Hprog)".
    unfocus_block "Hprog" "Hcont" as "Hprog".

    (* 2 - Jump to the adversary *)
    (* jmp *)
    iInstr "Hprog".
    (* 3 - Post condition *)
    iApply "Post".
    subst secret.
    replace ((b_mem ^+ secret_off) ^+ 1)%a with (b_mem ^+ (secret_off+1))%a by solve_addr.
    replace  (b_mem + secret_off + 1)%Z with (b_mem + (secret_off + 1))%Z by lia.
    iFrame.
  Qed.

  Context {nainv: logrel_na_invs Σ}.

  (** Assuming that the word of the adversary is safe to share,
     the machine executes safely and completely.
     The assumption makes sense, because we consider adversary programs containing
     no capabilities. *)
  Lemma prog_spec_CPS_full
        p_pc b_pc e_pc a_prog (* pc *)
        p_mem b_mem e_mem (* mem *)
        w_adv
        secret_off secret_val
        rmap :

    let secret := (b_mem^+secret_off)%a in
    let len_p := (a_prog ^+ length (prog_code secret_off secret_val))%a in

      (* Validity PC*)
      ExecPCPerm p_pc ->
      SubBounds b_pc e_pc a_prog len_p ->

      (* Validity buffer *)
      (b_mem <= secret < e_mem)%a ->
      writeAllowed p_mem = true ->

      (* Register map for the big_sep of registers *)
      dom rmap = all_registers_s ∖ {[ PC; r_t1; r_t30 ]} →

      ⊢ ( PC ↦ᵣ WCap p_pc b_pc e_pc a_prog
          ∗ r_t1 ↦ᵣ WCap p_mem b_mem e_mem b_mem
          ∗ r_t30 ↦ᵣ w_adv
          ∗ codefrag a_prog (prog_code secret_off secret_val)
          ∗ [[b_mem, e_mem]] ↦ₐ [[ region_addrs_zeroes b_mem e_mem ]]
          (* All the registers contains integers *)
          ∗ ([∗ map] r↦w ∈ rmap, r ↦ᵣ w ∗ ⌜is_z w = true⌝)
          (* The NA token is required for the post condition *)
          ∗ na_own logrel_nais ⊤
          (* The adversary word is safe to share *)
          ∗ interp w_adv
          (* Post condition of the corollary of the FTLR *)
          -∗ WP Seq (Instr Executable)
                {{ v, ⌜v = HaltedV⌝ → (* if the machine halts *)
                     (* we own all the registers *)
                      ∃ r : Reg, full_map r ∧ registers_mapsto r
                      (* all the NA invariants are closed*)
                      ∗ na_own logrel_nais ⊤}})%I.

  Proof.
    intros * Hpc_perm Hpc_bounds Hvsecret Hp_mem Hrmap_dom.
    iIntros "(HPC & Hr1 & Hr30 & Hprog & Hregion & Hrmap & Hna & #Hadv)".

    (* Using the FLTR corollary, w_adv is safe to execute and we can specify
       what happens after the jump: safe and complete execution *)
    (* It is required to do it _before_ the specification, because it introduces a
       later modality *)
    iDestruct (jmp_to_unknown with "Hadv") as "Cont".

    (* 1 - Specification of the known program *)
    (* Extract the register r_t2 and r_t3, required for `prog_spec_CPS` *)

    iExtractList "Hrmap" [r_t2;r_t3] as ["[Hr2 _]";"[Hr3 _]"].
    (* extract_register r_t2 with "Hrmap" as (w2 Hw2) "[[Hr2 _] Hrmap]". *)
    (* extract_register r_t3 with "Hrmap" as (w3 Hw3) "[[Hr3 _] Hrmap]". *)

    iApply (prog_spec_CPS with "[-]") ; try eassumption.
    iFrame "HPC Hr1 Hr30 Hregion Hr2 Hr3 Hprog".
    iNext ; iIntros "(HPC& Hr1& Hr2& Hr3 & Hr30 & Hprog & Hmem)".

    (* 2 - The continuation requires all the registers to be safe to share *)
    (* Show that the contents of r1 are safe *)
    replace ((b_mem ^+ secret_off) ^+ 1)%a
      with (b_mem ^+ (secret_off+1))%a by (subst secret ; by solve_addr).
    rewrite /region_mapsto.
    iDestruct (region_integers_alloc' _ _ _ (b_mem ^+ secret_off)%a _ p_mem with "Hmem")
      as ">#Hmem_safe".
    { rewrite /region_addrs_zeroes. apply Forall_replicate. auto. }

    (* put the other registers back into the register map *)

    iAssert ( ⌜is_z (WInt (b_mem + (secret_off + 1))) = true ⌝)%I as "Hvr2". auto.
    iCombine "Hr2 Hvr2" as "Hr2".
    iAssert ( ⌜is_z (WInt e_mem) = true ⌝)%I as "Hvr3". auto.
    iCombine "Hr3 Hvr3" as "Hr3".
    iInsertList "Hrmap" [r_t3;r_t2]. iClear "Hvr2 Hvr3".

    (* Show that the contents of unused registers is safe *)
    set (rmap' :=  <[r_t2:=WInt _]> (<[r_t3:= _]> rmap)).
    iAssert ([∗ map] r↦w ∈ rmap', r ↦ᵣ w ∗ interp w)%I with "[Hrmap]" as "Hrmap".
    { subst rmap'.
      iApply (big_sepM_mono with "Hrmap"). intros r w Hr'. cbn. iIntros "[? %Hw]". iFrame.
      destruct_word w; try by inversion Hw. rewrite fixpoint_interp1_eq //. }

    (* put the registers with capability back into the register map *)
    iCombine "Hr1 Hmem_safe" as "Hr1".
    iCombine "Hr30 Hadv" as "Hr30".
    subst rmap'; iInsertList "Hrmap" [r_t1;r_t30].

    (* 3 - Use the continuation *)

    (* Prepare the resources *)
    iApply "Cont" ; eauto. 2 : iFrame.
    iPureIntro. subst.
    { do 2 (rewrite dom_insert_L).
      assert (all_registers_s ∖ {[PC]} =
                ({[r_t1; r_t30]} ∪ all_registers_s ∖ {[PC; r_t1; r_t30]})) as ->.
      { rewrite - !difference_difference_L.
        assert ( all_registers_s ∖ {[PC]} ∖ {[r_t1]} ∖ {[r_t30]} =
                   all_registers_s ∖ {[PC]} ∖ {[r_t1; r_t30]})
          as -> by (rewrite - !difference_difference_L ; set_solver).
        rewrite -union_difference_L; auto.
        apply subseteq_difference_r;[set_solver|].
        apply all_registers_subseteq. }
      set_solver. }

    (* Alternative for (3) *)
    (* iApply (wp_wand with "[-]"). *)
    (* { iApply "Cont"; cycle 1. iFrame. iPureIntro. rewrite !dom_insert_L Hrmap_dom. *)
    (*   rewrite !singleton_union_difference_L. set_solver+. } *)
    (* iIntros (?) "?" ; done. *)
  Qed.

(** The encapsulation of the program is safe-to-share
    By unfolding the definition of V(E,-,-,-) , we can use only persistent
    proposition. Thus, all the required resources of the memory have to be
    encapsulated in invariants. *)

  Definition N : namespace := nroot .@ "secret".
  Definition start_memN := (N.@"start_mem").
  Definition secretN := (N.@"secret").
  Definition end_memN := (N.@"end_mem").
  Definition codeN := (N.@"code").

  (* The first part of the buffer, before the secret, is always zeroes *)
  Definition start_mem_inv (b_mem e_mem : Addr) secret_off:=
    let secret_addr := (b_mem ^+ secret_off)%a in
    na_inv logrel_nais start_memN
           ([[b_mem, secret_addr]] ↦ₐ [[ region_addrs_zeroes b_mem secret_addr ]]).

  (* The secret is either equal to 0 -- at the initialisation -- or equal to
     42 -- after the secret was stored *)
  Definition secret_inv (b_mem : Addr) secret_off secret :=
    let secret_addr := (b_mem ^+ secret_off)%a in
    na_inv logrel_nais secretN
           ((secret_addr ↦ₐ WInt 0) ∨ (secret_addr ↦ₐ WInt secret)).

  (* The code instruction is stored in an invariant as well *)
  Definition code_inv a_prog secret_off secret :=
    na_inv logrel_nais codeN (codefrag a_prog (prog_code secret_off secret)).

  Definition end_mem_inv b_mem e_mem secret_off :=
    let n_secret_addr := (b_mem ^+ (secret_off +1))%a in
    na_inv logrel_nais end_memN
           ([∗ list] a ∈ finz.seq_between n_secret_addr e_mem,
            ∃ P, inv (logN .@ a) (interp_ref_inv a P) ∗ read_cond P interp
                                                          ∗ write_cond P interp)%I.

  (** Currently, we cannot prove the closure, because we need more information
      about the buffer. Since the closure means "called in any context",
      we cannot assume that the buffer is correctly set up in the context,
      i.e. we cannot assume that the register r1 contains the capability
      pointing to the buffer.

      In order to get the right context, we may change our code. Here is 2
      solutions:
      - we assume that our program contains a capability pointing to our buffer,
        we need to load the capability in R1 before our program. It corresponds
        to a closure around the code and the buffer
      - we dynamically allocate the buffer, by using the `malloc` macro.
        It is different from the previous solution, because it allocates a new
        buffer each time our program is called

   *)
  Lemma prog_CPS_safe_to_share b_pc e_pc a_prog b_mem e_mem secret_off secret :

    (* The instructions of the code are in the memory closure of the PCC *)
    SubBounds b_pc e_pc a_prog (a_prog ^+ length (prog_code secret_off secret))% a ->
    (* The secret offset fits in the memory buffer *)
    (b_mem <= b_mem ^+ secret_off < e_mem)%a ->

    ⊢ ( code_inv a_prog secret_off secret
       ∗ start_mem_inv b_mem e_mem secret_off
       ∗ end_mem_inv b_mem e_mem secret_off
       ∗ secret_inv b_mem secret_off secret)

   -∗ interp (WCap E b_pc e_pc a_prog).
  Abort.

End base_program_CPS.


(**
  This file contains an implementation of the example token that complies with the Concordium's CIS1 standard.
  The development is inspired by the Rust implementation: https://github.com/Concordium/concordium-rust-smart-contracts/blob/b49a9f07131b2659de2f7b55eb5e8365d0ed4720/examples/cis1-wccd/src/lib.rs

  We also show that the implementation of the token complies with our formalization of the CIS1 standard.
*)

From Coq Require Import ZArith.
From Coq Require Import List.
From Coq Require Import Logic.Eqdep_dec.
From ConCert.Execution Require Import Monad.
From ConCert.Execution Require Import Containers.
From ConCert.Execution Require Import Serializable.
From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import ContractCommon.
From ConCert.Examples.CIS1 Require Import CIS1Spec.
From ConCert.Utils Require Import RecordUpdate.
From ConCert.Utils Require Import Extras.

Import ListNotations.

Definition requireTrue (cond : bool) :=
  if cond then Some tt else None.

Section WccdToken.
  Context {BaseTypes : ChainBase}.
  Set Nonrecursive Elimination Schemes.

  (** Similarly to the Concordium implementation we use the smallest token id type, because
      the contract hold tokens of only one type *)
  Definition TokenID := unit.

  Open Scope bool.

  (** * Entry points *)

  Record wccd_transfer_params :=
    { wccd_td_token_id : TokenID;
      wccd_td_amount   : TokenAmount;
      wccd_td_from     : Address;
      wccd_td_to       : Address }.

  Inductive OpUpdateKind :=
  | opAdd
  | opDelete.

  Inductive Msg :=
  | wccd_msg_transfer (params : list wccd_transfer_params)
  | wccd_msg_balanceOf (query : list Address) (send_results_to : Address)
  | wccd_msg_updateOperator (params : list (OpUpdateKind * Address))
  | wccd_msg_mint (receiver : Address)
  | wccd_msg_burn (amount : TokenAmount).

  (** * Contract's state *)

  (** The state tracked for each address.*)
  Record AddressState := {
      wccd_balance   : TokenAmount;
      wccd_operators : list Address
    }.

  (* begin hide *)
  MetaCoq Run (make_setters AddressState).
  (* end hide *)

  (** The contract state: a mapping from addresses to [AddressState] *)

  Definition State := AddressMap.AddrMap AddressState.

  Section Serialization.

    Global Instance OpUpdateKind_serializable : Serializable OpUpdateKind :=
      Derive Serializable OpUpdateKind_rect <opAdd, opDelete>.

    Global Instance state_serializable : Serializable AddressState :=
      Derive Serializable AddressState_rect <Build_AddressState>.

    Global Instance wccd_transfer_params_serializable : Serializable wccd_transfer_params :=
      Derive Serializable wccd_transfer_params_rect <Build_wccd_transfer_params>.

    Global Instance msg_serializable : Serializable Msg :=
      Derive Serializable Msg_rect <wccd_msg_transfer, wccd_msg_balanceOf, wccd_msg_updateOperator, wccd_msg_mint, wccd_msg_burn>.

  End Serialization.

  (** * Transfer *)

  Definition increment_balance (st : State) (addr : Address) (inc : TokenAmount) : State :=
    match AddressMap.find addr st with
    | Some old => AddressMap.add addr (old<| wccd_balance := old.(wccd_balance) + inc |>) st
    | None => AddressMap.add addr {| wccd_balance := inc ; wccd_operators := [] |} st
    end.

  Definition decrement_balance (st : State) (addr : Address) (dec : TokenAmount) : option State :=
    do old <- AddressMap.find addr st;
    let old_balance := old.(wccd_balance) in
    do requireTrue (dec <=? old_balance);
    ret (AddressMap.add addr (old<| wccd_balance := old_balance - dec |>) st).

  Definition is_operator (addr owner : Address)(st : State) : bool :=
    match AddressMap.find owner st with
    | Some v => existsb (fun x => (addr =? x)%address) v.(wccd_operators)
    | None => false
    end.

  (** Single transfer of [amount] between [from] and [to] *)
  Definition wccd_transfer_single
             (token_id : TokenID)
             (amount : TokenAmount)
             (owner from to : Address)
             (prev_st : State) : option State :=
    do requireTrue ((owner =? from)%address || is_operator from owner prev_st);
    do st <- decrement_balance prev_st from amount;
    ret (increment_balance st to amount).

  (** Batch execution of all transfers in the list. Note that the
      operation succeeds only if all transfers in the batch succeed *)
  Definition wccd_transfer (ctx : ContractCallContext) (transfers : list wccd_transfer_params) (prev_st : State)
    : option State :=
    monad_foldl (fun acc x =>
                   let owner := ctx.(ctx_from) in
                   wccd_transfer_single tt x.(wccd_td_amount) owner x.(wccd_td_from) x.(wccd_td_to) acc)
                prev_st transfers.

  (** * balanceOf *)

  Definition get_balance_opt (addr : Address) (st : State) : option TokenAmount :=
    match AddressMap.find addr st with
    | Some data => Some data.(wccd_balance)
    | None => None
    end.

  Definition wccd_balanceOf (query : list Address) (st : State)
    : list (TokenID * Address * TokenAmount) :=
    map (fun addr => (tt, addr, with_default 0 (get_balance_opt addr st))) query.

  (** * updateOperator *)

  Definition add_remove (operators : list Address) (param : OpUpdateKind * Address) :=
    let '(updateKind,addr) := param in
    match updateKind with
    | opAdd => addr :: operators
    | opDelete => remove address_eqdec addr operators
    end.

  (** NOTE: in contrast to the Concordium's implementation, we do not
      allow adding operators to non-existing addresses *)
  Definition wccd_updateOperator (owner : Address) (params : list (OpUpdateKind * Address)) (prev_st : State)
    : option State :=
    do owner_data <- AddressMap.find owner prev_st;
    let updated_owner_data := owner_data<| wccd_operators := fold_left add_remove params owner_data.(wccd_operators) |> in
    ret (AddressMap.add owner updated_owner_data prev_st).

  (** * WCCD receive *)

  (** We dispatch on a message of type [Msg] and call the corresponding functions with received parameters *)
  Definition wccd_receive
             (chain : Chain)
             (ctx : ContractCallContext)
             (prev_st : State)
             (msg : option Msg)
    : option (State * list ActionBody) :=
    match msg with
    | Some (wccd_msg_transfer params) =>
        do next_st <- wccd_transfer ctx params prev_st;
        let contract_accounts :=
          filter (fun x => address_is_contract x.(wccd_td_to)) params in
        let mk_callback x :=
        (* NOTE: we assume that the receiving contract accepts messages of type
           (TokenID * TokenAmount * Address) *)
          act_call x.(wccd_td_to) 0 (serialize (tt,x.(wccd_td_amount), x.(wccd_td_from))) in
        let ops := map mk_callback contract_accounts in
        ret (next_st, ops)
    | Some (wccd_msg_balanceOf query send_to) =>
        let balances := wccd_balanceOf query prev_st in
        do requireTrue (address_is_contract send_to);
        ret (prev_st, [act_call send_to 0 (serialize balances)])
    | Some (wccd_msg_updateOperator params) =>
        do next_st <- wccd_updateOperator ctx.(ctx_from) params prev_st;
        ret (next_st, [])
    | Some (wccd_msg_mint receiver) =>
        (* Check that the sender is not the receiver *)
        do requireTrue (address_neqb receiver ctx.(ctx_from));
        let next_st := increment_balance prev_st receiver (Z.to_nat ctx.(ctx_amount)) in
        (* NOTE: we only update the state and do not notify the receiver *)
        ret (next_st,[])
    | Some (wccd_msg_burn amt) =>
        (* Check that the sender is not the receiver *)
        do next_st <- decrement_balance prev_st ctx.(ctx_from) amt;
        ret (next_st, [act_transfer ctx.(ctx_from) (Z.of_nat amt)])
    | None => None
    end.

End WccdToken.

(** * WCCD complies with CIS1 *)

Module WccdTypes <: CIS1Types.

  Definition Msg `{ChainBase} := Msg.

  Definition Storage `{ChainBase} := State.

  Definition TokenID := TokenID.

  Definition serializable_token_id : Serializable TokenID := _.

  Definition token_id_eqb (id1 id2 : TokenID) := true.

  Lemma token_id_eqb_spec :
    forall (a b : TokenID), Bool.reflect (a = b) (token_id_eqb a b).
  Proof. intros. constructor. now destruct a,b. Qed.

End WccdTypes.

Module WccdView <: CIS1View WccdTypes.

  Import WccdTypes.

  Section WccdViewDefs.

    Context `{ChainBase}.

    Definition get_balance_opt st (token_id : TokenID) addr :=
      get_balance_opt addr st.

    Definition get_operators (st : Storage) (addr : Address) :=
      match AddressMap.find addr st with
      | Some v => v.(wccd_operators)
      | None => []
      end.

    Definition get_owners : Storage -> TokenID -> list Address :=
      fun st token_id => FMap.keys st.

    Lemma get_owners_no_dup : forall st token_id, NoDup (get_owners st token_id).
    Proof.
      intros. unfold get_owners; apply FMap.NoDup_keys.
    Qed.

    Lemma In_keys_In_elements_iff {K V : Type} `{countable.Countable K} (m : FMap K V) (k : K) :
      In k (FMap.keys m) <-> exists v, In (k,v) (FMap.elements m).
    Proof.
      split.
      - induction m using fin_maps.map_ind; intros Hin.
        + easy.
        + unfold FMap.keys in *.
          rewrite FMap.elements_add in Hin by assumption.
          cbn in *. destruct Hin.
          * exists x. rewrite FMap.elements_add by assumption. now left.
          * destruct (IHm H2) as [x0 Hx0]. exists x0.
            rewrite FMap.elements_add by assumption.
            now right.
      - induction m using fin_maps.map_ind; intros Hex.
        + now destruct Hex.
        + destruct Hex as [v Hv].
          unfold FMap.keys.
          rewrite FMap.elements_add in * by assumption; cbn in *.
          destruct Hv as [HH | HH]; try inversion HH; easy.
    Qed.

    Lemma get_owners_balances : forall st owner token_id,
        In owner (get_owners st token_id) <->
          exists balance, get_balance_opt st token_id owner = Some balance.
    Proof.
      split.
      + intros Hin. unfold get_owners in *.
        unfold get_balance_opt,Cis1wccd.get_balance_opt.
        apply In_keys_In_elements_iff in Hin.
        destruct Hin as [a_st HH].
        exists a_st.(wccd_balance).
        apply FMap.In_elements in HH.
        unfold AddressMap.find,FMap.find in *.
        now rewrite HH.
      + intros Hex.
        destruct Hex as [b Hb].
        unfold get_owners, FMap.keys.
        unfold get_balance_opt,Cis1wccd.get_balance_opt in *.
        destruct (AddressMap.find owner st) eqn:Heq; try congruence.
        unfold AddressMap.find in *.
        apply FMap.In_elements in Heq.
        apply In_keys_In_elements_iff.
        eauto.
    Qed.

    Definition token_id_exists (st : Storage) (token_id : TokenID) : bool := true.

  End WccdViewDefs.
End WccdView.

Module WccdReceiveSpec <: CIS1ReceiveSpec WccdTypes WccdView.

  Module cis1_axioms := CIS1Axioms WccdTypes WccdView.
  Import cis1_axioms.

  Module BalancesFacts := CIS1Balances WccdTypes WccdView.
  Import BalancesFacts.

  Section WccdReceiveDefs.

    Context `{ChainBase}.

    (** Converting _to_ the CIS1 standard parameters *)
    Definition to_cis1_transfer_data (p : wccd_transfer_params) : CIS1_transfer_data :=
      let '(Build_wccd_transfer_params token_id amt from_addr to_addr) := p in
      {| cis1_td_token_id := token_id;
         cis1_td_amount := amt;
         cis1_td_from := from_addr;
         cis1_td_to := to_addr |}.

    Definition to_cis1_updateOperator_kind (op : OpUpdateKind) : CIS1_updateOperator_kind :=
      match op with
      | opAdd => cis1_ou_add_operator
      | opDelete => cis1_ou_remove_operator
      end.

    Definition to_cis1_balanceOf_params (query : list Address) (send_to : Address)
      : option CIS1_balanceOf_params :=
      match Bool.bool_dec (address_is_contract send_to) true with
      | left p =>
          Some {|cis1_bo_query := map (fun addr => Build_CIS1_balanceOf_query _ tt addr) query;
                 cis1_bo_result_address := send_to;
                 cis1_bo_result_address_is_contract := p |}
      | right _ => None
      end.

    Definition get_CIS1_entry_point : Msg -> option CIS1_entry_points :=
      fun msg => match msg with
              | wccd_msg_transfer params =>
                  let params :=
                    {| cis_tr_transfers := map to_cis1_transfer_data params|} in
                  Some (CIS1_transfer params)
              | wccd_msg_balanceOf query send_results_to =>
                  do p <- to_cis1_balanceOf_params query send_results_to;
                  Some (CIS1_balanceOf p)
              | wccd_msg_updateOperator params =>
                  let upd_list :=
                    map (fun '(upd_kind, addr) =>
                           Build_CIS1_updateOperator_update _ (to_cis1_updateOperator_kind upd_kind) addr) params in
                  Some (CIS1_updateOperator {| cis1_ou_params := upd_list |})
              | wccd_msg_mint receiver => None
              | wccd_msg_burn amount => None
              end.

    (** Converting _from_ the CIS1 standard parameters *)

    Definition from_cis1_transfer_data (p : CIS1_transfer_data) : wccd_transfer_params :=
      let '(Build_CIS1_transfer_data _ token_id amt from_addr to_addr) := p in
      {| wccd_td_token_id := tt;
         wccd_td_amount := amt;
         wccd_td_from := from_addr;
         wccd_td_to := to_addr |}.

    Definition from_cis1_updateOperator_kind (op : CIS1_updateOperator_kind) : OpUpdateKind :=
      match op with
      | cis1_ou_remove_operator => opDelete
      | cis1_ou_add_operator => opAdd
      end.

    Definition from_cis1_balanceOf_params (query : CIS1_balanceOf_params) : list Address :=
      map cis1_bo_query_address query.(cis1_bo_query).

    Definition get_contract_msg : CIS1_entry_points -> Msg :=
      fun ep => match ep with
             | CIS1_transfer params =>
                 wccd_msg_transfer (map from_cis1_transfer_data params.(cis_tr_transfers))
             | CIS1_updateOperator params =>
                 let p := map (fun p => (from_cis1_updateOperator_kind p.(cis1_ou_update_kind), p.(cis1_ou_operator_address))) params.(cis1_ou_params) in
                 wccd_msg_updateOperator p
             | CIS1_balanceOf params =>
                 wccd_msg_balanceOf (from_cis1_balanceOf_params params)
                                    params.(cis1_bo_result_address)
             end.

    Lemma left_inverse_get_CIS1_entry_point (entry_point : CIS1_entry_points) :
      get_CIS1_entry_point (get_contract_msg entry_point) = Some entry_point.
    Proof.
      destruct entry_point; cbn.
      + destruct params as [xs]. repeat f_equal.
        induction xs; auto.
        cbn. destruct a as [tid ? ?]; cbn in *. destruct tid. repeat f_equal; auto.
      + destruct params as [xs]. repeat f_equal.
        rewrite map_map.
        induction xs; auto.
        destruct a as [ok ?]; cbn in *. destruct ok; repeat f_equal; auto.
      + destruct params as [xs send_to p]; cbn in *.
        unfold to_cis1_balanceOf_params.
        destruct (Bool.bool_dec (address_is_contract send_to) true) eqn:Heq; repeat f_equal.
        * induction xs; cbn in *; auto.
          destruct a as [tid ?]; destruct tid; cbn; now repeat f_equal.
        * apply UIP_dec. apply Bool.bool_dec.
        * congruence.
    Qed.

    Lemma inctement_balance_find_ne st addr1 addr2 amt :
      addr1 <> addr2 ->
      AddressMap.find addr1 (increment_balance st addr2 amt) = AddressMap.find addr1 st.
    Proof.
      intros Hneq.
      unfold increment_balance.
      destruct (AddressMap.find addr2 _);
        unfold AddressMap.add, AddressMap.find;
        now rewrite fin_maps.lookup_insert_ne.
    Qed.

    Import Lia.

    Lemma wccd_transfer_single_cis1 (token_id : TokenID)
          (amt : TokenAmount) (owner_addr from_addr to_addr : Address)
          (prev_st st : State) :
      wccd_transfer_single token_id amt owner_addr from_addr to_addr prev_st = Some st ->
      transfer_single_spec prev_st st token_id eq_refl eq_refl owner_addr from_addr to_addr amt.
    Proof.
      intros Haddr.
      cbn in *.
      destruct (requireTrue (_ || _)) eqn:Hpermissions; try congruence.
      destruct (AddressMap.find _ _) as [v |] eqn:Hv; try congruence.
      destruct (requireTrue (_ <=? _)) eqn:Hbalance; try congruence.
      inversion Haddr; subst; clear Haddr.
      destruct (amt <=? wccd_balance v) eqn:Hamt; cbn in *; try congruence.
      apply leb_complete in Hamt.
      repeat split; cbn.
      + intros.
        unfold setter_from_getter_AddressState_wccd_balance,set_AddressState_wccd_balance.
        unfold WccdView.get_balance_opt, get_balance_opt.
        rewrite inctement_balance_find_ne by assumption.
        unfold AddressMap.find,AddressMap.add.
        now erewrite fin_maps.lookup_insert_ne.
      + intros. now destruct other_token_id,token_id.
      + unfold requireTrue in *. destruct (orb _ _) eqn:Hp; try congruence.
        rewrite Bool.orb_true_iff in *.
        destruct Hp as [Hp | Hp].
        * now destruct (address_eqb_spec owner_addr from_addr).
        * right.
          unfold is_operator in *.
          unfold WccdView.get_operators.
          destruct (AddressMap.find owner_addr prev_st) eqn:Hfind; try congruence.
          apply existsb_exists in Hp.
          destruct Hp as [addr0 [Hin Heq]].
          now destruct (address_eqb_spec from_addr addr0).
      + repeat rewrite get_balance_total_get_balance_default.
        repeat unfold setter_from_getter_AddressState_wccd_balance,
          set_AddressState_wccd_balance,increment_balance.
        unfold get_balance_default,cis1_axioms.VExtra.get_balance in *. cbn.
        unfold setter_from_getter_AddressState_wccd_balance,set_AddressState_wccd_balance.
        destruct (AddressMap.find to_addr _) eqn:Haddr.
        * unfold WccdView.get_balance_opt,get_balance_opt,AddressMap.find,AddressMap.add in *.
          rewrite Hv.
          rewrite FMap.add_commute with (m := prev_st) by auto.
          rewrite FMap.find_add with (m := (FMap.add _ _ prev_st)); cbn.
          lia.
        * unfold WccdView.get_balance_opt,get_balance_opt,AddressMap.find,AddressMap.add in *.
          rewrite FMap.add_commute with (m := prev_st) by auto.
          rewrite FMap.find_add with (m := (FMap.add _ _ prev_st)).
          cbn. rewrite Hv.
          lia.
      + repeat rewrite get_balance_total_get_balance_default.
        repeat unfold setter_from_getter_AddressState_wccd_balance,
          set_AddressState_wccd_balance,increment_balance.
        unfold get_balance_default,cis1_axioms.VExtra.get_balance in *. cbn.
        unfold setter_from_getter_AddressState_wccd_balance,set_AddressState_wccd_balance.
        destruct (AddressMap.find to_addr _) eqn:Haddr.
        * unfold WccdView.get_balance_opt,get_balance_opt,AddressMap.find,AddressMap.add in *.
          rewrite FMap.find_add with (m := (FMap.add _ _ prev_st)); cbn.
          rewrite FMap.find_add_ne with (m := prev_st) in Haddr by auto.
          unfold FMap.find in *.
          now rewrite Haddr.
        * unfold WccdView.get_balance_opt,get_balance_opt,AddressMap.find,AddressMap.add in *.
          rewrite FMap.find_add with (m := (FMap.add _ _ prev_st)); cbn.
          rewrite FMap.find_add_ne with (m := prev_st) in Haddr by auto.
          unfold FMap.find in *.
          now rewrite Haddr.
      + subst. repeat rewrite get_balance_total_get_balance_default.
        repeat unfold setter_from_getter_AddressState_wccd_balance,
          set_AddressState_wccd_balance,increment_balance.
        unfold get_balance_default,cis1_axioms.VExtra.get_balance in *. cbn.
        unfold setter_from_getter_AddressState_wccd_balance,set_AddressState_wccd_balance.
        unfold WccdView.get_balance_opt,get_balance_opt. now rewrite Hv.
      + subst.
        repeat rewrite get_balance_total_get_balance_default.
        repeat unfold setter_from_getter_AddressState_wccd_balance,
          set_AddressState_wccd_balance,increment_balance.
        unfold get_balance_default,cis1_axioms.VExtra.get_balance in *. cbn.
        unfold WccdView.get_balance_opt,get_balance_opt.
        rewrite Hv.
        unfold AddressMap.find,AddressMap.add.
        rewrite FMap.find_add with (m := prev_st); cbn.
        rewrite FMap.find_add with (m := FMap.add _ _ prev_st); cbn.
        lia.
    Qed.

    Definition contract_receive := wccd_receive.

    Lemma get_balances_wccd_balanceOf next_st c query send_results_to :
      to_cis1_balanceOf_params query send_results_to = Some c ->
      get_balances next_st c = Some (wccd_balanceOf query next_st).
    Proof.
      intros Hparams.
      unfold to_cis1_balanceOf_params in *.
      destruct (Bool.bool_dec (address_is_contract send_results_to)) eqn:Haddr;
        inversion Hparams; subst; clear Hparams.
      cbn.
      revert dependent next_st.
      revert dependent send_results_to.
      induction query.
      - now intros ? ? ? Hparams; cbn in *.
      - intros. cbn.
        erewrite IHquery; eauto.
        unfold WccdView.get_balance_opt.
        now destruct (get_balance_opt _ _).
    Qed.

    (** ** Receive specification *)
    Theorem receive_spec :
    forall (chain : Chain)
      (ctx : ContractCallContext)
      (entry : CIS1_entry_points)
      (msg : Msg)
      (prev_st next_st : State)
      (ops : list ActionBody),
      get_CIS1_entry_point msg = Some entry ->
      wccd_receive chain ctx prev_st (Some msg) = Some (next_st, ops) ->
      match entry with
      | CIS1_transfer params => transfer_spec ctx params prev_st next_st ops
      | CIS1_updateOperator params => updateOperator_spec ctx params prev_st next_st ops
      | CIS1_balanceOf params => balanceOf_spec params prev_st next_st ops
      end.
    Proof.
      intros ? ? ? ? ? ? ? Hep Hreceive.
      destruct msg; cbn; inversion Hep as [HH]; subst; clear Hep; try easy.
      + simpl in *.
        destruct (wccd_transfer _ _) eqn:Htr; try congruence.
        inversion Hreceive; subst; clear Hreceive.
        constructor.
        * cbn.
          revert dependent next_st.
          revert dependent prev_st.
          induction params.
          ** cbn in *. congruence.
          ** intros prev_st next_st Hreceive.
             cbn -[wccd_transfer_single] in *.
             destruct (wccd_transfer_single _ _ _ _ _) as [st |] eqn:Haddr; try congruence.
             destruct a as [tid amt from_addr to_addr]; cbn.
             simpl in *.
             exists st, eq_refl, eq_refl.
             split.
             *** cbn in *. now apply wccd_transfer_single_cis1.
             *** now eapply IHparams.
        * cbn.
          revert dependent prev_st.
          revert dependent next_st.
          induction params.
          ** intros; cbn; auto.
          ** intros; cbn -[wccd_transfer_single] in *.
             destruct (wccd_transfer_single _ _ _ _ _) as [st |] eqn:Haddr; try congruence.
             destruct a as [token_id amt addr]; cbn.
             destruct (address_is_contract _).
             *** constructor; simpl in *.
                 eexists. split.
                 **** reflexivity.
                 **** destruct token_id.
                      exists (TokenID * TokenAmount * Address)%type. exists _. exists id.
                      eexists. split.
                      apply deserialize_serialize.
                      reflexivity.
                 **** eapply IHparams; eauto.
             *** eapply IHparams; eauto.
      + simpl in *.
        destruct (address_is_contract send_results_to) eqn:Haddr;
          inversion Hreceive; subst; clear Hreceive; cbn in *.
        destruct (to_cis1_balanceOf_params _ _) eqn:Hto_cis1; inversion HH; subst; clear HH.
        constructor; subst; auto.
        erewrite get_balances_wccd_balanceOf; eauto.
        cbn. repeat f_equal.
        unfold to_cis1_balanceOf_params in *.
        destruct (Bool.bool_dec (address_is_contract send_results_to)) eqn:HH;
          now inversion Hto_cis1.
      + cbn in *.
        unfold setter_from_getter_AddressState_wccd_operators,set_AddressState_wccd_operators in *.
        constructor; intros; cbn in *; auto.
        * unfold WccdView.get_balance_opt,get_balance_opt.
          destruct (AddressMap.find _ _) eqn:Haddr; inversion Hreceive; subst; clear Hreceive.
          destruct (address_eqb_spec addr ctx.(ctx_from)).
          ** subst.
             rewrite Haddr.
             unfold AddressMap.find,AddressMap.add.
             now rewrite FMap.find_add with (m := prev_st).
          ** unfold AddressMap.find,AddressMap.add.
             now rewrite fin_maps.lookup_insert_ne.
        * destruct (AddressMap.find _ _) eqn:Haddr; inversion Hreceive; subst; clear Hreceive.
          destruct a as [bal ops]; cbn in *.
          revert dependent ops.
          revert dependent prev_st.
          induction params; intros prev_st ops Haddr.
          ** cbn.
             unfold AddressMap.add,AddressMap.find in *.
             now symmetry; apply FMap.add_id.
          ** cbn.
             unfold AddressMap.add,AddressMap.find in *.
             destruct a as [ok oaddr]; cbn in *.
             unfold updateOperator_single_spec; cbn.
             destruct ok; cbn in *.
             *** set (st := FMap.add (ctx_from ctx)
                                     {| wccd_balance := bal;
                                       wccd_operators := oaddr :: ops |} prev_st).
                 exists st. split.
                 **** split.
                      ***** intros.
                      subst st. unfold WccdView.get_operators,AddressMap.find.
                      rewrite Haddr. rewrite FMap.find_add with (m := prev_st).
                      cbn.
                      split; intros; auto. destruct H1; subst; congruence.
                      ***** subst st. unfold WccdView.get_operators,AddressMap.find.
                      now rewrite FMap.find_add with (m := prev_st); cbn.
                 **** set (ops' := oaddr :: ops).
                      specialize (IHparams st ops'). subst ops' st; cbn in *.
                      repeat rewrite FMap.add_add with (m := prev_st)in IHparams.
                      apply IHparams.
                      now rewrite FMap.find_add with (m := prev_st).
             *** set (st := FMap.add (ctx_from ctx)
                                     {| wccd_balance := bal;
                                        wccd_operators := remove address_eqdec oaddr ops |} prev_st).
                 exists st. split.
                 **** split.
                      (* the cases are essentially just properties of [remove], which we
                         prove using the [hint] database *)
                      ***** intros.
                      subst st. unfold WccdView.get_operators,AddressMap.find.
                      rewrite Haddr. rewrite FMap.find_add with (m := prev_st).
                      cbn.
                      split; intros; eauto with hints.
                      ***** subst st. unfold WccdView.get_operators,AddressMap.find.
                      rewrite FMap.find_add with (m := prev_st); cbn; auto with hints.
                 **** set (ops' := remove address_eqdec oaddr ops).
                      specialize (IHparams st ops'). subst ops' st; cbn in *.
                      repeat rewrite FMap.add_add with (m := prev_st)in IHparams.
                      apply IHparams.
                      now rewrite FMap.find_add with (m := prev_st).
    Qed.
  End WccdReceiveDefs.
End WccdReceiveSpec.


From machine_program_logic.program_logic Require Import weakestpre.
From HypVeri.algebra Require Import base base_extra mem pagetable trans.
From HypVeri.rules Require Import rules_base mov halt run yield ldr str br.
From HypVeri.examples Require Import instr utils.
From HypVeri.logrel Require Import logrel logrel_extra fundamental logrel_prim logrel_prim_extra fundamental_prim.
From HypVeri Require Import proofmode machine_extra.
Require Import Setoid.

Program Instance up_vmconfig : HypervisorConstants :=
    {vm_count := 4;
     vm_count_pos := _;
     valid_handles := {[W0]}}.

Section up_proof.

Program Definition V1 : VMID := (@nat_to_fin 1 _ _).
Program Definition V2 : VMID := (@nat_to_fin 2 _ _).
Program Definition V3 : VMID := (@nat_to_fin 3 _ _).

Program Definition fortytwo : Imm := I (finz.FinZ 42 _ _) _.

  Context `{hypparams: !HypervisorParameters}.
  Context (pshare:PID) (pshare_i: Imm) (Hpshare_eq: of_pid pshare = pshare_i).
  Context (pprog0 pprog1 pprog2 pprog3:PID).
  Context (ptx1 ptx3 prx1 prx3 :PID).
  Context (ptx0 ptx2 prx0 prx2 :PID).
  Context (Hps_nd: NoDup [pprog0;pprog1;pprog2;pprog3;pshare;ptx0;ptx1;ptx2;ptx3;prx0;prx1;prx2;prx3]).
  Context (pprog3_i : Imm) (Hpprog3_eq : of_pid pprog3 = pprog3_i).

  Definition up_program1 (jump : Imm) : list Word :=
    [
      (* Store 42 to shared page *)
      mov_word_I R1 fortytwo;
      mov_word_I R2 pshare_i;
      str_I R1 R2;
      (* addr to jump *)
      mov_word_I R2 jump;
      mov_word_I R0 yield_I;
      hvc_I;
      br_I R2
    ].

  Definition up_program3 : list Word :=
    [
      (* read 42 from shared page *)
      mov_word_I R2 pshare_i;
      mov_word_I R0 pprog3_i;
      ldr_I R1 R2;
      cmp_word_I R1 fortytwo;
      bne_I R0;
      halt_I
    ].

  Class exclG Σ :=
    excl_G :> inG Σ (exclR unitO).
  Definition exclΣ : gFunctors :=
    #[ GFunctor (exclR unitO)].

  Instance subG_issuedΣ {Σ} : subG exclΣ Σ → exclG Σ.
  Proof. solve_inG. Qed.

  Context `{!gen_VMG Σ, !exclG Σ} (N : namespace).

  Definition EXCL γ : iProp Σ := (own γ (Excl ()))%I.
  Lemma excl_exclusive (γ : gname) : EXCL γ  -∗ EXCL γ  -∗ False.
  Proof.
    iDestruct 1 as  "H1". iDestruct 1 as  "H2".
    iDestruct (own_valid_2 with "H1 H2") as %[].
  Qed.

  (* don't transfer anything if i,j = 1,3 or 3,1 *)
  Definition up_slice_trans trans i j : iProp Σ :=
    match (bool_decide (i = V1)), (bool_decide (j = V3)) with
    | true, true => True
    | _, _ => match (bool_decide (i = V3)), (bool_decide (j = V1)) with
           | true, true => True
           | _, _ => slice_transfer_all trans i j
           end
    end.

  Definition up_slice_rxs i os j : iProp Σ :=
    (match os with
    | None => True
    | Some (_, k) => if (bool_decide (k=V0)) then
                       (if (bool_decide (j = V0)) then
                          slice_rx_state i os
                        else if (bool_decide (i = j)) then
                               slice_rx_state i os
                             else True)
                     else slice_rx_state i os
    end)%I.

  Instance up_slice_trans_wf : SliceTransWf up_slice_trans.
  Proof.
    rewrite /up_slice_trans /=.
    split.
    intros.
    case_bool_decide;
    case_bool_decide;auto.
    subst i. simpl. by apply slice_transfer_all_wf.
    case_bool_decide;auto.
    subst i. simpl. by apply slice_transfer_all_wf.
    by apply slice_transfer_all_wf.
  Qed.

  Instance up_slice_rxs_wf : SliceRxsWf up_slice_rxs.
  Proof.
    rewrite /up_slice_rxs /=.
    split. done.
    intros.
    destruct os;auto.
    destruct p. intros.
    case_bool_decide;auto.
    case_bool_decide;auto.
    done. done.
  Qed.

  Notation VMProp1 := (vmprop_unknown V1 up_slice_trans up_slice_rxs {[W0 := (V1, V3, {[pshare]}, Sharing, true)]}) (only parsing).
  Notation VMProp3 := (vmprop_unknown V3 up_slice_trans up_slice_rxs {[W0 := (V1, V3, {[pshare]}, Sharing, true)]}) (only parsing).

  Class SliceWfPrim Φ_t Φ_r :=
    {
     trans_wf_prim : ∀ i j trans, (i = V0 ∨ j = V0) -> Φ_t trans i j ⊣⊢ slice_transfer_all trans i j;
     rxs_wf_prim_diag : ∀ i os, (match os with
                 | None => True
                 | Some (_,j) => j = V0 -> Φ_r i os i ⊣⊢ slice_rx_state i os
                end);
     rxs_wf_prim_eq: ∀ i os, match os with
               | None => True
               | Some (_ ,k) => k = V0
               end -> Φ_r i os i ⊣⊢ Φ_r i os V0;
     rxs_wf_prim_none : ∀ i j os, (match os with
                 | None => True
                 | Some (_,j) => j = V0
                end) -> j ≠ i -> j ≠ V0 -> Φ_r i os j ⊣⊢ True;
     rxs_wf_prim_zero: ∀ os, (match os with
              | None => True
              | _ => Φ_r V0 os V0 ⊣⊢ slice_rx_state V0 os
              end);
    }.

  Global Instance up_slice_wf: SliceWfPrim up_slice_trans up_slice_rxs.
  Proof.
    split;rewrite /up_slice_trans /up_slice_rxs.
    {
      intros ? ? ? [|].
      case_bool_decide. subst i. done.
      case_bool_decide. subst i. done.
      done.
      case_bool_decide.
      case_bool_decide. subst j. done.
      case_bool_decide. subst j. done.
      done.
      case_bool_decide;auto.
      case_bool_decide;auto.
      subst j. done.
    }
    {
      intros.
      destruct os. destruct p. intro.
      case_bool_decide;auto.
      case_bool_decide;auto.
      case_bool_decide;auto.
      done. done.
    }
    {
      intros.
      destruct os;auto. destruct p.
      case_bool_decide;auto.
      case_bool_decide;auto.
      case_bool_decide;auto.
      done.
    }
    {
      intros.
      destruct os;auto. destruct p.
      case_bool_decide;auto.
      case_bool_decide;auto. done.
      case_bool_decide;auto. done.
      done.
    }
    {
      intros.
      destruct os;auto. destruct p.
      case_bool_decide;auto.
    }
  Qed.

  Definition inv_pshare γ pshare : iProp Σ:=
   inv (N .@ "shared")
     ((∃ w, pshare ->a w) ∨ EXCL γ ∗ pshare ->a (of_imm fortytwo)).

  Lemma up_machine1 jump_i γ :
    let program1 := up_program1 jump_i in
    of_imm (jump_i) = (pprog1 ^+ 4)%f ->
    seq_in_page (of_pid pprog1) (length program1) pprog1->
    inv_pshare γ pshare ∗
    EXCL γ ∗
    (program (program1) (of_pid pprog1)) ∗
    V1 -@A> {[pprog1;pshare;ptx1;prx1]} ∗
    (* TX page *)
    TX@ V1 := (tpa ptx1) ∗
    RX@ V1 := (tpa prx1) ∗
    PC @@ V1 ->r (of_pid pprog1) ∗
    (* Work registers *)
    (∃ r0, R0 @@ V1 ->r r0) ∗
    (∃ r1, R1 @@ V1 ->r r1) ∗
    (∃ r2, R2 @@ V1 ->r r2) ∗
    VMProp V1 (VMProp1) (1/2)%Qp
    ⊢ VMProp_holds V1 (1/2)%Qp -∗ WP ExecI @ V1
          {{ (λ m, False)}}%I.
  Proof.
    intro. rewrite /program1.
    iIntros (Hjump HIn) "(#inv & excl1 & (p_1 & p_2 & p_3 & p_4 & p_5 & p_6 & p7 & _) & acc & tx & rx & pc & (%r0 & r0) & (%r1 & r1) & (%r2 & r2)
                   & vmprop) holds".
    assert (pprog1 ≠ ptx1) as Hneqtx.
    {
      intro.
      feed pose proof (NoDup_lookup _ 1 6 ptx1 Hps_nd).
      simplify_eq /=. done.
      simplify_eq /=. done.
      lia.
    }
    rewrite to_pid_aligned_eq.
    pose proof (seq_in_page_forall2 _ _ _ HIn) as Hforall.
    clear HIn; rename Hforall into HIn.
    rewrite wp_sswp.
    iApply ((mov_word pprog1) with "[p_1 pc acc tx r1]"); rewrite ?to_pid_aligned_eq; iFrameAutoSolve.
    set_solver.
    iNext. iIntros "(pc & _ & acc & tx & r1) _".
    rewrite wp_sswp.
    iApply ((mov_word (pprog1 ^+ 1)%f) with "[p_2 pc acc tx r2]"); rewrite ?to_pid_aligned_eq; iFrameAutoSolve.
    set_solver.
    rewrite HIn. done.
    set_solver +.
    iNext. iIntros "(pc & _ & acc & tx & r2) _".
    rewrite wp_sswp.
    iApply (sswp_fupd_around _ ⊤ (⊤ ∖ ↑(N .@ "shared")) ⊤).
    iInv (N .@ "shared") as ">Inv" "HIClose".
    iDestruct "Inv" as "[(%w & share) | [excl1' share]]".
    2:{
      iExFalso.
      iApply (excl_exclusive with "excl1 excl1'").
    }
    iApply ((str ((pprog1 ^+ 1) ^+ 1)%f) with "[p_3 pc acc tx rx r1 r2 share]");
      rewrite -?Hpshare_eq ?to_pid_aligned_eq; iFrameAutoSolve.
    rewrite (HIn ((pprog1 ^+ 1) ^+ 1)%f).
    rewrite to_pid_aligned_eq.
    set_solver +.
    set_solver +.
    rewrite HIn. done.
    set_solver +.
    {
      rewrite to_pid_aligned_eq.
      intro.
      feed pose proof (NoDup_lookup _ 4 10 prx1 Hps_nd).
      simplify_eq /=. done.
      simplify_eq /=. done.
      lia.
    }
    iModIntro. iNext. iIntros "(pc & _ & r2 & share & r1 & acc & tx & rx)".
    iDestruct ("HIClose" with "[excl1 share]") as "HIClose".
    iNext;iRight;iFrame.
    iMod "HIClose" as "_". iModIntro. iIntros "_".
    rewrite wp_sswp.
    iApply ((mov_word (((pprog1 ^+ 1) ^+ 1) ^+ 1)%f) with "[p_4 pc acc tx r2]"); rewrite ?to_pid_aligned_eq; iFrameAutoSolve.
    rewrite HIn. set_solver +.
    set_solver +.
    rewrite HIn //. set_solver +.
    iNext. iIntros "(pc & _ & acc & tx & r2) _".
    iAssert (∃trans, VMProp V1 (vmprop_unknown V1 up_slice_trans up_slice_rxs trans) (1 / 2))%I with "[vmprop]" as "vmprop".
    {
      iExists _. iExact "vmprop".
    }
    iLöb as "L" forall (r0) "r0".
    iApply wp_sswp.
    iApply (mov_word ((((pprog1 ^+ 1) ^+ 1) ^+ 1) ^+ 1)%f with "[p_5 pc acc tx r0]"); rewrite ?to_pid_aligned_eq; iFrameAutoSolve.
    rewrite HIn. set_solver +.
    set_solver +.
    rewrite HIn //. set_solver +.
    iNext. iIntros "(pc & p5 & acc & tx & r0) _".
    iApply wp_sswp.
    iDestruct "vmprop" as "[% vmprop]".
    iDestruct (VMProp_holds_agree with "[holds vmprop]") as "[P prop1]".
    iSplitR "vmprop".
    iDestruct "holds" as "[% [? vmprop]]". iExists _. iSplitR "vmprop".
    2: iExact "vmprop". done.
    iExact "vmprop".
    iDestruct (vmprop_unknown_eq with "P") as "P".
    rewrite bi.later_exist. iDestruct "P" as "[% P]".
    rewrite bi.later_exist. iDestruct "P" as "[% P]".
    rewrite 9!bi.later_sep.
    iDestruct "P" as "(>P1 & >P2 & P3 & >[% [r0z _]] & >[% [r1z _]] & >P6 & P7 & >P8 & >%P9 & prop0)".
    pose proof (P9 V1). destruct H.
    iApply (yield (((((pprog1 ^+ 1) ^+ 1) ^+ 1) ^+ 1) ^+1)%f (True) (vmprop_unknown V1 up_slice_trans up_slice_rxs a)
             with "[p_6 pc acc tx r0 prop1 r0z r1z prop0 P1 P2 P3 P6 P7 P8]"); rewrite ?to_pid_aligned_eq; iFrameAutoSolve.
    rewrite HIn. set_solver +.
    set_solver +.
    rewrite HIn //. set_solver +.
    apply decode_encode_hvc_func.
    iSplitL "prop0". iExact "prop0".
    iSplitL "prop1". iExact "prop1".
    iSplitL. iNext. iIntros "[(pc & p_6 & acc & tx & r0 & r0z & r1z) [_ prop1]]".
    iSplitL "P1 P2 P3 P6 P7 P8 prop1 r0z r1z".
    rewrite /vmprop_zero /vmprop_zero_pre.
    iExists a, x.
    iSplit. iPureIntro. apply only_except_disjoint.
    rewrite only_except_union.
    iSplit. iPureIntro. intros. done.
    iFrame "P2 P3".
    iDestruct ("P7" $! x H) as "[$ P7]".
    iSplitL "P7".
    destruct x. destruct p. destruct (decide (v = V0)).
    rewrite rxs_wf_prim_eq //.
    pose proof (slice_rxs_sym up_slice_rxs V1 V0 (i:= V1) (os:=(Some (f, v)))).
    simpl in H0. pose proof n. apply H0 in n. case_bool_decide;auto.
    pose proof (slice_rxs_empty up_slice_rxs V1 V0).
    rewrite H0 //.
    iSplitR "prop1";[|done].
    rewrite /return_reg_rx.
    iLeft. iSplitL "r0z". iLeft. done.
    iFrame "P8 P6 r1z".
    iCombine "pc p_6 acc tx r0" as "R'". iExact "R'".
    done.
    iNext. iIntros "[(pc & p6 & acc & tx & r0) prop1] holds".
    iApply wp_sswp.
    iApply (br ((((((pprog1 ^+ 1) ^+ 1) ^+ 1) ^+ 1) ^+ 1) ^+ 1)%f with "[p7 pc acc tx r2]"); rewrite ?to_pid_aligned_eq; iFrameAutoSolve.
    rewrite HIn. set_solver +.
    set_solver +.
    rewrite HIn //. set_solver +.
    iNext. iIntros "(pc & [p7 r2] & acc & tx) _".
    iApply ("L" with "p5 p6 p7 holds r1 rx [pc] acc tx r2 [prop1] r0").
    assert (((((pprog1 ^+ 1) ^+ 1) ^+ 1) ^+ 1)%f = jump_i) as ->.
    solve_finz + Hjump.
    done.
    iExists _. iExact "prop1".
   Qed.

  Lemma up_machine3 γ :
    let program3 := up_program3 in
    (* Addresses-values connection *)
    seq_in_page (of_pid pprog3) (length program3) pprog3 ->
    inv_pshare γ pshare ∗
    (* Mem for program *)
    (program (program3) (of_pid pprog3)) ∗
    V3 -@A> {[pprog3;pshare;ptx3;prx3]} ∗
    TX@ V3 := (tpa ptx3) ∗
    RX@ V3 := (tpa prx3) ∗
    (* Program counter *)
    PC @@ V3 ->r (of_pid pprog3) ∗
    (∃ nz, NZ @@ V3 ->r nz) ∗
    (* Work registers *)
    (∃ r0, R0 @@ V3 ->r r0) ∗
    (∃ r1, R1 @@ V3 ->r r1) ∗
    (∃ r2, R2 @@ V3 ->r r2) ∗
    VMProp V3 (VMProp3) (1/2)%Qp
    ⊢ VMProp_holds V3 (1/2)%Qp -∗ WP ExecI @ V3
           {{ (λ m, ⌜m = HaltI⌝ ∗ R1 @@ V3 ->r fortytwo)}}%I.
  Proof.
    intro. rewrite /program3.
    iIntros (HIn) "(#inv & (p_1 & p_2 & p_3 & p_4 & p_5 & p_6 & _) & acc & tx & rx & pc & (%nz & nz) & (%r0 & r0) & (%r1 & r1) & (%r2 & r2)
                   & vmprop) holds".
    assert (pprog3 ≠ ptx3) as Hneqtx.
    {
      intro.
      feed pose proof (NoDup_lookup _ 3 8 ptx3 Hps_nd).
      simplify_eq /=. done.
      simplify_eq /=. done.
      lia.
    }
    rewrite to_pid_aligned_eq.
    pose proof (seq_in_page_forall2 _ _ _ HIn) as Hforall.
    clear HIn; rename Hforall into HIn.
    iLöb as "L" forall (nz r0 r1 r2) "nz r0 r1 r2".
    iApply wp_sswp.
    iApply ((mov_word pprog3) with "[p_1 pc acc tx r2]"); rewrite ?to_pid_aligned_eq; iFrameAutoSolve.
    set_solver.
    iNext. iIntros "(pc & p_1 & acc & tx & r2) _".
    iApply wp_sswp.
    iApply ((mov_word (pprog3 ^+ 1)%f) with "[p_2 pc acc tx r0]"); rewrite ?to_pid_aligned_eq; iFrameAutoSolve.
    set_solver.
    rewrite HIn.
    {
      intro.
      feed pose proof (NoDup_lookup _ 3 8 ptx3 Hps_nd).
      simplify_eq /=. done.
      simplify_eq /=.
    }
    set_solver +.
    iNext. iIntros "(pc & p_2 & acc & tx & r0) _".
    iApply wp_sswp.
    iApply (sswp_fupd_around _ ⊤ (⊤ ∖ ↑(N .@ "shared")) ⊤).
    iInv (N .@ "shared") as ">Inv" "HIClose".
    iDestruct "Inv" as "[ (% & share) | [excl1' share]]".
    {
      iApply ((ldr ((pprog3 ^+ 1) ^+ 1)%f) with "[p_3 pc acc tx r1 r2 share]"); rewrite -?Hpshare_eq ?to_pid_aligned_eq; iFrameAutoSolve.
      rewrite (HIn ((pprog3 ^+ 1) ^+ 1)%f).
      rewrite to_pid_aligned_eq.
      set_solver +.
      set_solver +.
      {
        rewrite to_pid_aligned_eq.
        intro.
        feed pose proof (NoDup_lookup _ 4 8 ptx3 Hps_nd).
        simplify_eq /=. done.
        simplify_eq /=. done.
        lia.
      }
      rewrite HIn. done.
      set_solver +. iModIntro.
      iNext. iIntros "(pc & p_3 & r2 & share & r1 & acc & tx)".
      iDestruct ("HIClose" with "[share]") as ">_".
      iNext;iLeft. iExists _; iFrame.
      iModIntro. iIntros "_".
      iApply wp_sswp.
      iApply ((cmp.cmp_word (((pprog3 ^+ 1) ^+ 1) ^+ 1)%f) with "[p_4 pc nz r1 acc tx]"); rewrite ?to_pid_aligned_eq; iFrameAutoSolve.
      rewrite (HIn (((pprog3 ^+ 1) ^+ 1) ^+ 1)%f).
      set_solver +.
      set_solver +.
      rewrite (HIn (((pprog3 ^+ 1) ^+ 1) ^+ 1)%f).
      {
        intro.
        feed pose proof (NoDup_lookup _ 3 8 ptx3 Hps_nd).
        simplify_eq /=. done.
        done.
      }
      set_solver +.
      iNext. iIntros "(pc & p_4 & r1 & acc & nz & tx)".
      (* destruct (decide (w = fortytwo)). *)
      iIntros "_".
      iApply wp_sswp.
      iApply ((bne.bne ((((pprog3 ^+ 1) ^+ 1) ^+ 1) ^+1)%f) with "[p_5 pc nz r0 acc tx]"); rewrite ?to_pid_aligned_eq; iFrameAutoSolve.
      rewrite HIn.
      set_solver +.
      set_solver +.
      rewrite HIn.
      {
        intro.
        feed pose proof (NoDup_lookup _ 3 8 ptx3 Hps_nd).
        simplify_eq /=. done.
        done.
      }
      set_solver +.
      iNext. iIntros "(pc & p_5 & r0 & acc & nz & tx)".
      iIntros "_".
      destruct (decide (w = fortytwo)).
      assert (w <? fortytwo = false)%f as ->.
      solve_finz + e.
      assert (fortytwo <? w = false)%f as ->.
      solve_finz + e.
      assert ((W1 =? W1)%f = true) as ->.
      solve_finz.
      iApply wp_sswp.
      iApply ((halt (((((pprog3 ^+ 1) ^+ 1) ^+ 1) ^+ 1) ^+ 1)%f) with "[p_6 pc acc tx]"); rewrite ?to_pid_aligned_eq; iFrameAutoSolve.
      rewrite HIn. set_solver +.
      set_solver +.
      rewrite HIn //. set_solver +.
      iNext. iIntros "(pc & _ & acc & tx) _".
      iApply wp_terminated. done.
      rewrite e. iFrame "r1". done.
      assert (((if w <? fortytwo then W2 else if fortytwo <? w then W0 else W1) =? W1) = false)%f as ->.
      {
        destruct (decide (w < fortytwo)%f).
        assert (w <? fortytwo = true)%f as ->.
        solve_finz + l.
        solve_finz +.
        assert (w <? fortytwo = false)%f as ->.
        solve_finz + n n0.
        assert (fortytwo <? w = true)%f as ->.
        solve_finz + n n0.
        solve_finz +.
      }
      iApply ("L" with "p_1 p_2 p_3 p_4 p_5 p_6 acc tx rx [pc] [vmprop] [holds] nz r0 r1 r2").
      rewrite Hpprog3_eq. done.
      done.
      rewrite /VMProp_holds.
      iDestruct "holds" as "[% [H1 H2]]".
      iExists _. iSplitL "H1". 2:{ iExact "H2". }
                             iNext. done.
    }
      iApply ((ldr ((pprog3 ^+ 1) ^+ 1)%f) with "[p_3 pc acc tx r1 r2 share]"); rewrite -?Hpshare_eq ?to_pid_aligned_eq; iFrameAutoSolve.
      rewrite (HIn ((pprog3 ^+ 1) ^+ 1)%f).
      rewrite to_pid_aligned_eq.
      set_solver +.
      set_solver +.
      {
        rewrite to_pid_aligned_eq.
        intro.
        feed pose proof (NoDup_lookup _ 4 8 ptx3 Hps_nd).
        simplify_eq /=. done.
        simplify_eq /=. done.
        lia.
      }
      rewrite HIn. done.
      set_solver +. iModIntro.
      iNext. iIntros "(pc & p_3 & r2 & share & r1 & acc & tx)".
      iDestruct ("HIClose" with "[share]") as ">_".
      iNext;iLeft. iExists _; iFrame.
      iModIntro. iIntros "_".
      iApply wp_sswp.
      iApply ((cmp.cmp_word (((pprog3 ^+ 1) ^+ 1) ^+ 1)%f) with "[p_4 pc nz r1 acc tx]"); rewrite ?to_pid_aligned_eq; iFrameAutoSolve.
      rewrite (HIn (((pprog3 ^+ 1) ^+ 1) ^+ 1)%f).
      set_solver +.
      set_solver +.
      rewrite (HIn (((pprog3 ^+ 1) ^+ 1) ^+ 1)%f).
      {
        intro.
        feed pose proof (NoDup_lookup _ 3 8 ptx3 Hps_nd).
        simplify_eq /=. done.
        done.
      }
      set_solver +.
      iNext. iIntros "(pc & p_4 & r1 & acc & nz & tx)".
      (* destruct (decide (w = fortytwo)). *)
      iIntros "_".
      iApply wp_sswp.
      iApply ((bne.bne ((((pprog3 ^+ 1) ^+ 1) ^+ 1) ^+1)%f) with "[p_5 pc nz r0 acc tx]"); rewrite ?to_pid_aligned_eq; iFrameAutoSolve.
      rewrite HIn.
      set_solver +.
      set_solver +.
      rewrite HIn.
      {
        intro.
        feed pose proof (NoDup_lookup _ 3 8 ptx3 Hps_nd).
        simplify_eq /=. done.
        done.
      }
      set_solver +.
      iNext. iIntros "(pc & p_5 & r0 & acc & nz & tx)".
      iIntros "_".
      assert (fortytwo <? fortytwo = false)%f as ->.
      solve_finz + .
      assert ((W1 =? W1)%f = true) as ->.
      solve_finz.
      iApply wp_sswp.
      iApply ((halt (((((pprog3 ^+ 1) ^+ 1) ^+ 1) ^+ 1) ^+ 1)%f) with "[p_6 pc acc tx]"); rewrite ?to_pid_aligned_eq; iFrameAutoSolve.
      rewrite HIn. set_solver +.
      set_solver +.
      rewrite HIn //. set_solver +.
      iNext. iIntros "(pc & _ & acc & tx) _".
      iApply wp_terminated. done.
      iFrame "r1". done.
  Qed.

  Definition up_interp_access2 := interp_access (V2 : leibnizO VMID) up_slice_trans up_slice_rxs ptx2 prx2 {[pprog2; ptx2; prx2]}
                                    ({[W0 := (V1, V3, {[pshare]}, Sharing, true)]}).

  Lemma up_ftlr2: up_interp_access2 ⊢ interp_execute V2.
  Proof. iApply ftlr. Qed.

  Definition up_interp_access0 rxs := interp_access_prim up_slice_trans up_slice_rxs ptx0 prx0 {[pprog0; ptx0; prx0]}
                                    {[W0 := (V1, V3, {[pshare]}, Sharing, true)]} rxs.

  Lemma up_ftlr0 rxs : up_interp_access0 rxs ⊢ interp_execute_prim.
  Proof. iApply ftlr_p. Qed.

End up_proof.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*                 Xavier Leroy, INRIA Paris                           *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Correctness of instruction selection for 64-bit integer operations *)

Require Import String Coqlib Maps Zbits Integers Floats Errors.
Require Archi.
Require Import AST Values Memory Globalenvs Events.
Require Import Cminor Op CminorSel.
Require Import SelectOp SelectOpproof SplitLong SplitLongproof.
Require Import SelectLong.

Local Open Scope cminorsel_scope.
Local Open Scope string_scope.

(** * Correctness of the instruction selection functions for 64-bit operators *)

Section CMCONSTR.

Variable prog: program.
Variable hf: helper_functions.
Hypothesis HELPERS: helper_functions_declared prog hf.
Let ge := Genv.globalenv prog.
Variable sp: val.
Variable e: env.
Variable m: mem.

Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop :=
  forall le a x,
  eval_expr ge sp e m le a x ->
  exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef (sem x) v.

Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> val) : Prop :=
  forall le a x b y,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef (sem x y) v.

Definition partial_unary_constructor_sound (cstr: expr -> expr) (sem: val -> option val) : Prop :=
  forall le a x y,
  eval_expr ge sp e m le a x ->
  sem x = Some y ->
  exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef y v.

Definition partial_binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> option val) : Prop :=
  forall le a x b y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  sem x y = Some z ->
  exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef z v.

Theorem eval_longconst:
  forall le n, eval_expr ge sp e m le (longconst n) (Vlong n).
Proof.
  unfold longconst; intros; destruct Archi.splitlong.
  apply SplitLongproof.eval_longconst.
  EvalOp.
Qed.

Lemma is_longconst_sound:
  forall v a n le,
  is_longconst a = Some n -> eval_expr ge sp e m le a v -> v = Vlong n.
Proof with (try discriminate).
  intros. unfold is_longconst in *. destruct Archi.splitlong.
  eapply SplitLongproof.is_longconst_sound; eauto.
  assert (a = Eop (Olongconst n) Enil).
  { destruct a... destruct o... destruct e0... congruence. }
  subst a. InvEval. auto.
Qed.

Theorem eval_intoflong: unary_constructor_sound intoflong Val.loword.
Proof.
  unfold intoflong; destruct Archi.splitlong. apply SplitLongproof.eval_intoflong.
  red; intros. destruct (is_longconst a) as [n|] eqn:C.
- TrivialExists. simpl. erewrite (is_longconst_sound x) by eauto. auto.
- TrivialExists.
Qed.

Theorem eval_longofintu: unary_constructor_sound longofintu Val.longofintu.
Proof.
  unfold longofintu; destruct Archi.splitlong. apply SplitLongproof.eval_longofintu.
  red; intros. destruct (is_intconst a) as [n|] eqn:C.
- econstructor; split. apply eval_longconst.
  exploit is_intconst_sound; eauto. intros; subst x. auto.
- TrivialExists.
Qed.

Theorem eval_longofint: unary_constructor_sound longofint Val.longofint.
Proof.
  unfold longofint; destruct Archi.splitlong. apply SplitLongproof.eval_longofint.
  red; intros. destruct (is_intconst a) as [n|] eqn:C.
- econstructor; split. apply eval_longconst.
  exploit is_intconst_sound; eauto. intros; subst x. auto.
- TrivialExists.
Qed.

Theorem eval_notl: unary_constructor_sound notl Val.notl.
Proof.
  unfold notl; destruct Archi.splitlong. apply SplitLongproof.eval_notl.
  red; intros. destruct (notl_match a).
- InvEval. econstructor; split. apply eval_longconst. auto.
- InvEval. subst. exists v1; split; auto. destruct v1; simpl; auto. rewrite Int64.not_involutive; auto.
- TrivialExists.
Qed.

Theorem eval_andlimm: forall n, unary_constructor_sound (andlimm n) (fun v => Val.andl v (Vlong n)).
Proof.
  unfold andlimm; intros; red; intros.
  predSpec Int64.eq Int64.eq_spec n Int64.zero.
  exists (Vlong Int64.zero); split. apply eval_longconst.
  subst. destruct x; simpl; auto. rewrite Int64.and_zero; auto.
  predSpec Int64.eq Int64.eq_spec n Int64.mone.
  exists x; split. assumption.
  subst. destruct x; simpl; auto. rewrite Int64.and_mone; auto.
  destruct (andlimm_match a); InvEval; subst.
- econstructor; split. apply eval_longconst. simpl. rewrite Int64.and_commut; auto.
- TrivialExists. simpl. rewrite Val.andl_assoc. rewrite Int64.and_commut; auto.
- TrivialExists. simpl. destruct v1; simpl; auto. unfold Int64.rolm. rewrite Int64.and_assoc.
  rewrite  (Int64.and_commut mask2 n). reflexivity.
- TrivialExists.
Qed.

Theorem eval_andl: binary_constructor_sound andl Val.andl.
Proof.
  unfold andl; destruct Archi.splitlong. apply SplitLongproof.eval_andl.
  red; intros. destruct (andl_match a b).
- InvEval. rewrite Val.andl_commut. apply eval_andlimm; auto.
- InvEval. apply eval_andlimm; auto.
- TrivialExists.
Qed.

Theorem eval_orlimm: forall n, unary_constructor_sound (orlimm n) (fun v => Val.orl v (Vlong n)).
Proof.
  unfold orlimm; intros; red; intros.
  predSpec Int64.eq Int64.eq_spec n Int64.zero.
  exists x; split; auto. subst. destruct x; simpl; auto. rewrite Int64.or_zero; auto.
  predSpec Int64.eq Int64.eq_spec n Int64.mone.
  econstructor; split. apply eval_longconst. subst. destruct x; simpl; auto. rewrite Int64.or_mone; auto.
  destruct (orlimm_match a); InvEval; subst.
- econstructor; split. apply eval_longconst. simpl. rewrite Int64.or_commut; auto.
- TrivialExists. simpl. rewrite Val.orl_assoc. rewrite Int64.or_commut; auto.
- TrivialExists.
Qed.

Theorem eval_orl: binary_constructor_sound orl Val.orl.
Proof.
  unfold orl; destruct Archi.splitlong. apply SplitLongproof.eval_orl.
  red; intros.
  assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop Oorl (a:::b:::Enil)) v /\ Val.lessdef (Val.orl x y) v) by TrivialExists.
  assert (ROLM: forall v n1 n2 m1 m2,
             n1 = n2 ->
             Val.lessdef (Val.orl (Val.rolml v n1 m1) (Val.rolml v n2 m2))
                         (Val.rolml v n1 (Int64.or m1 m2))).
  { intros. destruct v; simpl; auto. unfold Int64.rolm.
    rewrite Int64.and_or_distrib. rewrite H1. auto. }
  destruct (orl_match a b).
- predSpec Int.eq Int.eq_spec amount1 amount2; simpl.
   destruct (same_expr_pure t1 t2) eqn:?; auto. InvEval.
   exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst.
   exists (Val.rolml v0 amount2 (Int64.or mask1 mask2)); split. EvalOp.
   apply ROLM; auto. auto.
- InvEval. rewrite Val.orl_commut. apply eval_orlimm; auto.
- InvEval. apply eval_orlimm; auto.
- apply DEFAULT.
Qed.

Theorem eval_xorlimm: forall n, unary_constructor_sound (xorlimm n) (fun v => Val.xorl v (Vlong n)).
Proof.
  unfold xorlimm; intros; red; intros.
  predSpec Int64.eq Int64.eq_spec n Int64.zero.
  exists x; split; auto. subst. destruct x; simpl; auto. rewrite Int64.xor_zero; auto.
  predSpec Int64.eq Int64.eq_spec n Int64.mone.
  replace (Val.xorl x (Vlong n)) with (Val.notl x). apply eval_notl; auto.
  subst n. destruct x; simpl; auto.
  destruct (xorlimm_match a); InvEval; subst.
- econstructor; split. apply eval_longconst. simpl. rewrite Int64.xor_commut; auto.
- TrivialExists. simpl. rewrite Val.xorl_assoc. rewrite Int64.xor_commut; auto.
- TrivialExists. simpl. destruct v1; simpl; auto. unfold Int64.not.
  rewrite Int64.xor_assoc. apply f_equal. apply f_equal. apply f_equal.
  apply Int64.xor_commut.
- TrivialExists.
Qed.

Theorem eval_xorl: binary_constructor_sound xorl Val.xorl.
Proof.
  unfold xorl; destruct Archi.splitlong. apply SplitLongproof.eval_xorl.
  red; intros. destruct (xorl_match a b).
- InvEval. rewrite Val.xorl_commut. apply eval_xorlimm; auto.
- InvEval. apply eval_xorlimm; auto.
- TrivialExists.
Qed.

Theorem eval_rolml: forall amount mask, unary_constructor_sound (fun v => rolml v amount mask) (fun v => Val.rolml v amount mask).
Proof.
  unfold rolml. intros; red; intros.
  predSpec Int.eq Int.eq_spec amount Int.zero.
  rewrite H0.
  exploit (eval_andlimm). eauto. intros (x0 & (H1 & H2)).
  exists x0. split. apply H1. destruct x; auto. simpl. unfold Int64.rolm.
  change (Int64.repr (Int.unsigned Int.zero)) with Int64.zero. rewrite Int64.rol_zero.
  apply H2.
  destruct (rolml_match a).
- econstructor; split. apply eval_longconst. simpl. InvEval. unfold Val.rolml. auto.
- InvEval. TrivialExists. simpl. rewrite <- H.
  unfold Val.rolml; destruct v1; simpl; auto.
  rewrite Int64.rolm_rolm by (exists (two_p (64-6)); auto).
  f_equal. f_equal. f_equal.
  unfold Int64.add. rewrite ! Int64.int_unsigned_repr. unfold Int.add.
  set (a := Int.unsigned amount1 + Int.unsigned amount).
  unfold Int.modu, Int64.modu.
  change (Int.unsigned Int64.iwordsize') with 64.
  change (Int64.unsigned Int64.iwordsize) with 64.
  f_equal.
  rewrite Int.unsigned_repr.
  apply eqmod_mod_eq. lia.
  apply eqmod_trans with a.
  apply eqmod_divides with Int.modulus. apply Int.eqm_sym. apply Int.eqm_unsigned_repr.
  exists (two_p (32-6)); auto.
  apply eqmod_divides with Int64.modulus. apply Int64.eqm_unsigned_repr.
  exists (two_p (64-6)); auto.
  assert (0 <= Int.unsigned (Int.repr a) mod 64 < 64) by (apply Z_mod_lt; lia).
  assert (64 < Int.max_unsigned) by (compute; auto).
  lia.
- InvEval. TrivialExists. simpl. rewrite <- H.
  unfold Val.rolml; destruct v1; simpl; auto. unfold Int64.rolm.
  rewrite Int64.rol_and. rewrite Int64.and_assoc. auto.
- TrivialExists.
Qed.

Theorem eval_shllimm: forall n, unary_constructor_sound (fun e => shllimm e n) (fun v => Val.shll v (Vint n)).
Proof.
  intros; unfold shllimm. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shllimm; auto.
  red; intros.
  predSpec Int.eq Int.eq_spec n Int.zero.
  exists x; split; auto. subst n; destruct x; simpl; auto.
  destruct (Int.ltu Int.zero Int64.iwordsize'); auto.
  change (Int64.shl' i Int.zero) with (Int64.shl i Int64.zero). rewrite Int64.shl_zero; auto.
  destruct (Int.ltu n Int64.iwordsize') eqn:LT; simpl.
- rewrite Val.shll_rolml by apply LT. apply eval_rolml. auto.
- TrivialExists. constructor; eauto.  constructor. EvalOp. simpl; eauto. constructor.
  constructor.
Qed.

Theorem eval_shrluimm: forall n, unary_constructor_sound (fun e => shrluimm e n) (fun v => Val.shrlu v (Vint n)).
Proof.
  unfold shrluimm; destruct Archi.splitlong. apply SplitLongproof.eval_shrluimm. auto.
  red; intros.
  predSpec Int.eq Int.eq_spec n Int.zero.
  exists x. split. apply H. destruct x; simpl; auto. rewrite H0. rewrite Int64.shru'_zero. constructor.
  destruct (Int.ltu n Int64.iwordsize') eqn:LT; simpl.
- rewrite Val.shrlu_rolml by apply LT. apply eval_rolml. auto.
- TrivialExists. constructor; eauto.  constructor. EvalOp. simpl; eauto. constructor.
  constructor.
Qed.

Theorem eval_shrlimm: forall n, unary_constructor_sound (fun e => shrlimm e n) (fun v => Val.shrl v (Vint n)).
Proof.
  intros; unfold shrlimm. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrlimm; auto.
  red; intros.
  predSpec Int.eq Int.eq_spec n Int.zero.
  exists x; split; auto. subst n; destruct x; simpl; auto.
  destruct (Int.ltu Int.zero Int64.iwordsize'); auto.
  change (Int64.shr' i Int.zero) with (Int64.shr i Int64.zero). rewrite Int64.shr_zero; auto.
  destruct (Int.ltu n Int64.iwordsize') eqn:LT; simpl.
  assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshrlimm n) (a:::Enil)) v
                         /\  Val.lessdef (Val.shrl x (Vint n)) v) by TrivialExists.
  destruct (shrlimm_match a); InvEval.
- TrivialExists. simpl; rewrite LT; auto.
- destruct (Int.ltu (Int.add n n1) Int64.iwordsize') eqn:LT'; auto.
  subst. econstructor; split. EvalOp. simpl; eauto.
  destruct v1; simpl; auto. rewrite LT'.
  destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto.
  simpl; rewrite LT. rewrite Int.add_commut, Int64.shr'_shr'; auto. rewrite Int.add_commut; auto.
- apply DEFAULT.
- TrivialExists. constructor; eauto. constructor. EvalOp. simpl; eauto. constructor. auto.
Qed.

Theorem eval_shll: binary_constructor_sound shll Val.shll.
Proof.
  unfold shll. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shll; auto.
  red; intros. destruct (is_intconst b) as [n2|] eqn:C.
- exploit is_intconst_sound; eauto. intros EQ; subst y. apply eval_shllimm; auto.
- TrivialExists.
Qed.

Theorem eval_shrlu: binary_constructor_sound shrlu Val.shrlu.
Proof.
  unfold shrlu. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrlu; auto.
  red; intros. destruct (is_intconst b) as [n2|] eqn:C.
- exploit is_intconst_sound; eauto. intros EQ; subst y. apply eval_shrluimm; auto.
- TrivialExists.
Qed.

Theorem eval_shrl: binary_constructor_sound shrl Val.shrl.
Proof.
  unfold shrl. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrl; auto.
  red; intros. destruct (is_intconst b) as [n2|] eqn:C.
- exploit is_intconst_sound; eauto. intros EQ; subst y. apply eval_shrlimm; auto.
- TrivialExists.
Qed.

Theorem eval_negl: unary_constructor_sound negl Val.negl.
Proof.
  unfold negl. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_negl; auto.
  red; intros. destruct (is_longconst a) as [n|] eqn:C.
- exploit is_longconst_sound; eauto. intros EQ; subst x.
  econstructor; split. apply eval_longconst. auto.
- TrivialExists.
Qed.

Theorem eval_addlimm: forall n, unary_constructor_sound (addlimm n) (fun v => Val.addl v (Vlong n)).
Proof.
  unfold addlimm.
  red; intros. predSpec Int64.eq Int64.eq_spec n Int64.zero.
  exists x. split; auto. rewrite H0. destruct x; auto. simpl. rewrite Int64.add_zero. constructor.
  destruct (addlimm_match a).
- econstructor; split. apply eval_longconst. simpl. InvEval. unfold Val.rolml. auto.
- InvEval. TrivialExists. simpl. rewrite <- H. rewrite Val.addl_assoc. reflexivity.
- InvEval. TrivialExists.
Qed.

Theorem eval_addl: binary_constructor_sound addl Val.addl.
Proof.
  unfold addl. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_addl; auto.
  red; intros. destruct (addl_match a b); InvEval; subst.
- exploit (eval_addlimm n1); eauto. intros (n & (H1 & H2)). exists n. split; auto.
  rewrite Val.addl_commut. exact H2.
- exploit (eval_addlimm n2). apply H. auto.
- rewrite Val.addl_permut_4. simpl.
  apply eval_addlimm; EvalOp.
- rewrite Val.addl_assoc. rewrite Val.addl_permut. rewrite Val.addl_commut.
  apply eval_addlimm; EvalOp.
- rewrite Val.addl_commut. rewrite Val.addl_assoc. rewrite Val.addl_permut.
  rewrite Val.addl_commut. apply eval_addlimm; EvalOp. rewrite Val.addl_commut.
  constructor.
- TrivialExists.
Qed.

Theorem eval_subl: binary_constructor_sound subl Val.subl.
Proof.
  unfold subl. destruct Archi.splitlong eqn:SL.
  apply SplitLongproof.eval_subl. apply Archi.splitlong_ptr32; auto.
  red; intros; destruct (subl_match a b); InvEval.
- rewrite Val.subl_addl_opp. apply eval_addlimm; auto.
-  TrivialExists.
Qed.

Theorem eval_mullimm_base: forall n, unary_constructor_sound (mullimm_base n) (fun v => Val.mull v (Vlong n)).
Proof.
  intros; unfold mullimm_base. red. intros.
  assert (DEFAULT: exists v : val, eval_expr ge sp e m le (Eop Omull (a ::: longconst n ::: Enil)) v
                              /\ Val.lessdef (Val.mull x (Vlong n)) v).
  { TrivialExists. constructor. eauto. constructor. apply eval_longconst. constructor. auto. }
  generalize (Int64.one_bits'_decomp n); intros D.
  destruct (Int64.one_bits' n) as [ | i [ | j [ | ? ? ]]] eqn:B; auto.
- replace (Val.mull x (Vlong n)) with (Val.shll x (Vint i)).
  apply eval_shllimm; auto.
  simpl in D. rewrite D, Int64.add_zero. destruct x; simpl; auto.
  rewrite (Int64.one_bits'_range n) by (rewrite B; auto with coqlib).
  rewrite Int64.shl'_mul; auto.
- set (le' := x :: le).
  assert (A0: eval_expr ge sp e m le' (Eletvar O) x) by (constructor; reflexivity).
  exploit (eval_shllimm i). eexact A0. intros (v1 & A1 & B1).
  exploit (eval_shllimm j). eexact A0. intros (v2 & A2 & B2).
  exploit (eval_addl). eexact A1. eexact A2. intros (v3 & A3 & B3).
  exists v3; split. econstructor; eauto.
  rewrite D. simpl. rewrite Int64.add_zero. destruct x; auto.
  simpl in *.
  rewrite (Int64.one_bits'_range n) in B1 by (rewrite B; auto with coqlib).
  rewrite (Int64.one_bits'_range n) in B2 by (rewrite B; auto with coqlib).
  inv B1; inv B2. simpl in B3; inv B3.
  rewrite Int64.mul_add_distr_r. rewrite <- ! Int64.shl'_mul. auto.
Qed.

Theorem eval_mullimm: forall n, unary_constructor_sound (mullimm n) (fun v => Val.mull v (Vlong n)).
Proof.
  unfold mullimm. intros.
  destruct Archi.splitlong eqn:SL.
  eapply SplitLongproof.eval_mullimm; eauto.
  red; intros. predSpec Int64.eq Int64.eq_spec n Int64.zero.
  exists (Vlong Int64.zero).
  split. apply eval_longconst. destruct x; simpl; auto.
  subst n; rewrite Int64.mul_zero; auto.
  predSpec Int64.eq Int64.eq_spec n Int64.one.
  exists x; split; auto.
  destruct x; simpl; auto. subst n; rewrite Int64.mul_one; auto.
  destruct (mullimm_match a); InvEval.
- econstructor; split. apply eval_longconst. rewrite Int64.mul_commut; auto.
- exploit (eval_mullimm_base n); eauto.
Qed.

Theorem eval_mull: binary_constructor_sound mull Val.mull.
Proof.
  unfold mull. destruct Archi.splitlong eqn:SL.
  apply SplitLongproof.eval_mull; auto.
  red; intros. destruct (mull_match a b).
- exploit (eval_mullimm n1); eauto. intros (n & (H1 & H2)). InvEval. exists n. split; auto.
  rewrite Val.mull_commut. exact H2.
- exploit (eval_mullimm n2). apply H. InvEval. auto.
- TrivialExists.
Qed.

Theorem eval_mullhu:
  forall n, unary_constructor_sound (fun a => mullhu a n) (fun v => Val.mullhu v (Vlong n)).
Proof.
  unfold mullhu; intros. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_mullhu; auto.
  red; intros. TrivialExists. constructor. eauto. constructor. apply eval_longconst. constructor. auto.
Qed.

Theorem eval_mullhs:
  forall n, unary_constructor_sound (fun a => mullhs a n) (fun v => Val.mullhs v (Vlong n)).
Proof.
  unfold mullhs; intros. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_mullhs; auto.
  red; intros. TrivialExists. constructor. eauto. constructor. apply eval_longconst. constructor. auto.
Qed.

Theorem eval_shrxlimm:
  forall le a n x z,
  eval_expr ge sp e m le a x ->
  Val.shrxl x (Vint n) = Some z ->
  exists v, eval_expr ge sp e m le (shrxlimm a n) v /\ Val.lessdef z v.
Proof.
  unfold shrxlimm. intros. destruct Archi.splitlong eqn:SL.
  eapply SplitLongproof.eval_shrxlimm; eauto.
  predSpec Int.eq Int.eq_spec n Int.zero.
- subst n. destruct x; simpl in H0; inv H0. econstructor; split; eauto.
  change (Int.ltu Int.zero (Int.repr 63)) with true. simpl. rewrite Int64.shrx'_zero; auto.
- TrivialExists.
Qed.

Theorem eval_divls_base: partial_binary_constructor_sound divls_base Val.divls.
Proof.
  unfold divls_base; red; intros. destruct Archi.splitlong eqn:SL.
  eapply SplitLongproof.eval_divls_base; eauto.
  TrivialExists.
Qed.

Lemma eval_modl_aux:
  forall divop semdivop,
  (forall sp x y m, eval_operation ge sp divop (x :: y :: nil) m = semdivop x y) ->
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  semdivop x y = Some z ->
  eval_expr ge sp e m le (modl_aux divop a b) (Val.subl x (Val.mull z y)).
Proof.
  intros; unfold modl_aux.
  eapply eval_Elet. eexact H0. eapply eval_Elet.
  apply eval_lift. eexact H1.
  eapply eval_Eop. eapply eval_Econs.
  eapply eval_Eletvar. simpl; reflexivity.
  eapply eval_Econs. eapply eval_Eop.
  eapply eval_Econs. eapply eval_Eop.
  eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity.
  eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity.
  apply eval_Enil.
  rewrite H. eauto.
  eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity.
  apply eval_Enil.
  simpl; reflexivity. apply eval_Enil.
  reflexivity.
Qed.

Theorem eval_modls_base: partial_binary_constructor_sound modls_base Val.modls.
Proof.
  unfold modls_base. red; intros. destruct Archi.splitlong eqn:SL.
  eapply SplitLongproof.eval_modls_base; eauto.
  assert (DEFAULT: exists v : val, eval_expr ge sp e m le (modl_aux Odivl a b) v /\ Val.lessdef z v).
  exploit Val.modls_divls; eauto. intros [v [A B]].
  { subst. econstructor; split; eauto.
    apply eval_modl_aux with (semdivop := Val.divls); auto. }

  destruct (is_longconst a) as [n1|] eqn:A. exploit is_longconst_sound. eauto. eauto. intros.
  destruct (is_longconst b) as [n2|] eqn:B; auto. exploit is_longconst_sound. eauto. eauto. intros.
  predSpec Int64.eq Int64.eq_spec Int64.zero n2; simpl.
  (* n1 mod n2, n2 = 0 *)
  auto.
  predSpec Int64.eq Int64.eq_spec n1 (Int64.repr Int64.min_signed); predSpec Int64.eq Int64.eq_spec n2 Int64.mone; simpl; auto; subst.
- (* signed_min mod n2 | n2 != 0, n2 !- =1 *)
  econstructor; split. apply eval_longconst.
  unfold Val.modls in H1.
  rewrite Int64.eq_false in H1; auto.
  rewrite (Int64.eq_false n2 Int64.mone H6) in H1.
  inversion H1. auto.
- (* n1 mod -1, n1 !- signed_min *)
  econstructor; split. apply eval_longconst.
  unfold Val.modls in H1.
  rewrite Int64.eq_false in H1; auto.
  rewrite Int64.eq_false in H1; auto.
  inversion H1. auto.
- (* other valid cases *)
  econstructor; split. apply eval_longconst.
  unfold Val.modls in H1.
  rewrite Int64.eq_false in H1; auto.
  rewrite Int64.eq_false in H1; auto.
  inversion H1.
  auto.
- (* fallback *)
  apply DEFAULT.
Qed.

Theorem eval_divlu_base: partial_binary_constructor_sound divlu_base Val.divlu.
Proof.
  unfold divlu_base; red; intros. destruct Archi.splitlong eqn:SL.
  eapply SplitLongproof.eval_divlu_base; eauto.
  TrivialExists.
Qed.

Theorem eval_modlu_base: partial_binary_constructor_sound modlu_base Val.modlu.
Proof.
  unfold modlu_base; red; intros. destruct Archi.splitlong eqn:SL.
  eapply SplitLongproof.eval_modlu_base; eauto.
  assert (DEFAULT: exists v : val, eval_expr ge sp e m le (modl_aux Odivlu a b) v /\ Val.lessdef z v).
  exploit Val.modlu_divlu; eauto. intros [v [A B]].
  subst. econstructor; split; eauto.
  apply eval_modl_aux with (semdivop := Val.divlu); auto.
  (* n1 and n2 are longconsts *)
  destruct (is_longconst a) as [n1|] eqn:A. exploit is_longconst_sound; eauto.
  destruct (is_longconst b) as [n2|] eqn:B; auto. exploit is_longconst_sound; eauto. intros.
  predSpec Int64.eq Int64.eq_spec Int64.zero n2; simpl.
  (* n2 = 0 *)
-  auto.
  (* n2 != 0 *)
-  econstructor; split. apply eval_longconst.
  rewrite H2 in H1.
  rewrite H3 in H1.
  unfold Val.modlu in H1.
  rewrite Int64.eq_false in H1; auto.
  inversion H1. auto.
-  (* n1 no longconst, n2 is longconst *)
  destruct (is_longconst b) as [n2|] eqn:B; auto. exploit is_longconst_sound; eauto. intros.
  destruct (Int64.is_power2 n2) eqn:C; auto.
  (* n2 is power of 2 *)
  exploit eval_andlimm. apply H. intros. destruct H3.
  exists x0.  split. apply H3.
  replace z with (Val.andl x (Vlong (Int64.sub n2 Int64.one))). apply H3.
  apply (Val.modlu_pow2 x n2 i z); congruence.
Qed.

Theorem eval_cmplu:
  forall c le a x b y v,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.cmplu (Mem.valid_pointer m) c x y = Some v ->
  eval_expr ge sp e m le (cmplu c a b) v.
Proof.
  unfold cmplu; intros. destruct Archi.splitlong eqn:SL.
  eapply SplitLongproof.eval_cmplu; eauto using Archi.splitlong_ptr32.
  unfold Val.cmplu in H1.
  destruct (Val.cmplu_bool (Mem.valid_pointer m) c x y) as [vb|] eqn:C; simpl in H1; inv H1.
  destruct (is_longconst a) as [n1|] eqn:LC1; destruct (is_longconst b) as [n2|] eqn:LC2;
  try (assert (x = Vlong n1) by (eapply is_longconst_sound; eauto));
  try (assert (y = Vlong n2) by (eapply is_longconst_sound; eauto));
  subst.
- simpl in C; inv C. EvalOp. destruct (Int64.cmpu c n1 n2); reflexivity.
- EvalOp. simpl. rewrite Val.swap_cmplu_bool. rewrite C; auto.
- EvalOp. simpl; rewrite C; auto.
- EvalOp. simpl; rewrite C; auto.
Qed.

Theorem eval_cmpl:
  forall c le a x b y v,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.cmpl c x y = Some v ->
  eval_expr ge sp e m le (cmpl c a b) v.
Proof.
  unfold cmpl; intros. destruct Archi.splitlong eqn:SL.
  eapply SplitLongproof.eval_cmpl; eauto.
  unfold Val.cmpl in H1.
  destruct (Val.cmpl_bool c x y) as [vb|] eqn:C; simpl in H1; inv H1.
  destruct (is_longconst a) as [n1|] eqn:LC1; destruct (is_longconst b) as [n2|] eqn:LC2;
  try (assert (x = Vlong n1) by (eapply is_longconst_sound; eauto));
  try (assert (y = Vlong n2) by (eapply is_longconst_sound; eauto));
  subst.
- simpl in C; inv C. EvalOp. destruct (Int64.cmp c n1 n2); reflexivity.
- EvalOp. simpl. rewrite Val.swap_cmpl_bool. rewrite C; auto.
- EvalOp. simpl; rewrite C; auto.
- EvalOp. simpl; rewrite C; auto.
Qed.

Theorem eval_longoffloat:
  forall le a x y,
  eval_expr ge sp e m le a x ->
  Val.longoffloat x = Some y ->
  exists v, eval_expr ge sp e m le (longoffloat a) v /\ Val.lessdef y v.
Proof.
  unfold longoffloat. intros. destruct Archi.splitlong eqn:SL.
  eapply SplitLongproof.eval_longoffloat; eauto.
  TrivialExists.
Qed.

Theorem eval_floatoflong:
  forall le a x y,
  eval_expr ge sp e m le a x ->
  Val.floatoflong x = Some y ->
  exists v, eval_expr ge sp e m le (floatoflong a) v /\ Val.lessdef y v.
Proof.
  unfold floatoflong. intros. destruct Archi.splitlong eqn:SL.
  eapply SplitLongproof.eval_floatoflong; eauto.
  TrivialExists.
Qed.

Theorem eval_longofsingle:
  forall le a x y,
  eval_expr ge sp e m le a x ->
  Val.longofsingle x = Some y ->
  exists v, eval_expr ge sp e m le (longofsingle a) v /\ Val.lessdef y v.
Proof.
  intros; unfold longofsingle.
  destruct x; simpl in H0; inv H0. destruct (Float32.to_long f) as [n|] eqn:EQ; simpl in H2; inv H2.
  exploit eval_floatofsingle; eauto. intros (v & A & B). simpl in B. inv B.
  apply Float32.to_long_double in EQ.
  eapply eval_longoffloat; eauto. simpl.
  change (Float.of_single f) with (Float32.to_double f); rewrite EQ; auto.
Qed.

End CMCONSTR.