Require Import compcert.lib.Coqlib.
Require Import List. Import ListNotations.
Require Import hmacdrbg.entropy.
Require Import VST.floyd.functional_base.

Definition DRBG_working_state: Type := (list byte * list byte * Z)%type. (* value * key * reseed_counter *)
Definition DRBG_state_handle: Type := (DRBG_working_state * Z * bool)%type. (* state, security_strength, prediction_resistance_flag *)

Definition DRBG_instantiate_function
            (instantiate_algorithm: list byte -> list byte -> list byte -> Z -> DRBG_working_state)
            (min_entropy_length max_entropy_length: Z) (provided_nonce: option (list byte))
            (highest_supported_security_strength: Z) (max_personalization_string_length: Z)
            (prediction_resistance_supported: bool) (entropy_stream: ENTROPY.stream)
            (requested_instantiation_security_strength: Z) (prediction_resistance_flag: bool)
            (personalization_string: list byte): ENTROPY.result DRBG_state_handle :=
  if requested_instantiation_security_strength >? highest_supported_security_strength then ENTROPY.error ENTROPY.generic_error entropy_stream
  else match prediction_resistance_flag, prediction_resistance_supported with
         | true, false => ENTROPY.error ENTROPY.generic_error entropy_stream
         | _,_ =>
           if (Zlength personalization_string) >? max_personalization_string_length then ENTROPY.error ENTROPY.generic_error entropy_stream
           else
             let security_strength := if requested_instantiation_security_strength <=? 14 then Some 14
                                      else if requested_instantiation_security_strength <=? 16 then Some 16
                                      else if requested_instantiation_security_strength <=? 24 then Some 24
                                      else if requested_instantiation_security_strength <=? 32 then Some 32
                                      else None in
             match security_strength with
               | None => ENTROPY.error ENTROPY.generic_error entropy_stream
               | Some security_strength =>
               match get_entropy security_strength min_entropy_length max_entropy_length prediction_resistance_flag entropy_stream with
                 | ENTROPY.error e s' => ENTROPY.error ENTROPY.catastrophic_error s'
                 | ENTROPY.success entropy_input entropy_stream =>
                   let nonce_result := match provided_nonce with
                                         | Some n => ENTROPY.success n entropy_stream
                                         | None => get_entropy (security_strength/2) (min_entropy_length/2) (max_entropy_length/2)
                                                               prediction_resistance_flag entropy_stream
                                       end in
                   match nonce_result with
                     | ENTROPY.error e s' => ENTROPY.error ENTROPY.catastrophic_error s'
                     | ENTROPY.success nonce entropy_stream =>
                       let initial_working_state := instantiate_algorithm entropy_input nonce personalization_string security_strength in
                       ENTROPY.success (initial_working_state, security_strength, prediction_resistance_flag) entropy_stream
                   end
               end
             end
       end.

Definition DRBG_reseed_function (reseed_algorithm: DRBG_working_state -> list byte -> list byte -> DRBG_working_state)
            (min_entropy_length max_entropy_length: Z) (max_additional_input_length: Z)
            (entropy_stream: ENTROPY.stream) (state_handle: DRBG_state_handle)
            (prediction_resistance_request: bool) (additional_input: list byte): ENTROPY.result DRBG_state_handle :=
  match state_handle with (working_state, security_strength, prediction_resistance_flag) =>
  if prediction_resistance_request && (negb prediction_resistance_flag) then ENTROPY.error ENTROPY.generic_error entropy_stream
  else
    if Zlength additional_input >? max_additional_input_length then ENTROPY.error ENTROPY.generic_error entropy_stream
    else
      match get_entropy security_strength min_entropy_length max_entropy_length prediction_resistance_request entropy_stream with
        | ENTROPY.error _ s => ENTROPY.error ENTROPY.catastrophic_error s
        | ENTROPY.success entropy_input entropy_stream =>
          let new_working_state := reseed_algorithm working_state entropy_input additional_input in
          ENTROPY.success (new_working_state, security_strength, prediction_resistance_flag) entropy_stream
      end
  end.

Inductive DRBG_generate_algorithm_result :=
| generate_algorithm_reseed_required: DRBG_generate_algorithm_result
| generate_algorithm_success: list byte -> DRBG_working_state -> DRBG_generate_algorithm_result.

Fixpoint DRBG_generate_function_helper (generate_algorithm: DRBG_working_state -> Z -> list byte -> DRBG_generate_algorithm_result)
          (reseed_function: ENTROPY.stream -> DRBG_state_handle -> bool -> list byte -> ENTROPY.result DRBG_state_handle)
          (entropy_stream: ENTROPY.stream) (state_handle: DRBG_state_handle) (requested_number_of_bytes: Z)
          (prediction_resistance_request: bool) (additional_input: list byte) (should_reseed: bool) (count: nat): ENTROPY.result (list byte * DRBG_working_state) :=
  let result := if should_reseed then
                        match reseed_function entropy_stream state_handle prediction_resistance_request additional_input with
                          | ENTROPY.success x entropy_stream => ENTROPY.success (x, []) entropy_stream
                          | ENTROPY.error e entropy_stream => ENTROPY.error e entropy_stream
                        end
                      else ENTROPY.success (state_handle, additional_input) entropy_stream in
  match result with
    | ENTROPY.error e s => ENTROPY.error e s
    | ENTROPY.success (state_handle, additional_input) entropy_stream =>
      match state_handle with (working_state, security_strength, prediction_resistance_flag) =>
        match generate_algorithm working_state requested_number_of_bytes additional_input with
          | generate_algorithm_reseed_required =>
            match count with
              | O => ENTROPY.error ENTROPY.generic_error entropy_stream (* impossible *)
              | S count' => DRBG_generate_function_helper generate_algorithm reseed_function
                                entropy_stream state_handle requested_number_of_bytes
                                prediction_resistance_request additional_input true count'
            end
          | generate_algorithm_success x y => ENTROPY.success (x, y) entropy_stream
        end
      end
    end.

Definition DRBG_generate_function (generate_algorithm: Z -> DRBG_working_state -> Z -> list byte -> DRBG_generate_algorithm_result)
             (reseed_function: ENTROPY.stream -> DRBG_state_handle -> bool -> list byte -> ENTROPY.result DRBG_state_handle)
             (reseed_interval: Z) (max_number_of_bytes_per_request: Z) (max_additional_input_length: Z)
             (entropy_stream: ENTROPY.stream) (state_handle: DRBG_state_handle)
             (requested_number_of_bytes requested_security_strength: Z)
             (prediction_resistance_request: bool) (additional_input: list byte): ENTROPY.result (list byte * DRBG_state_handle) :=
  match state_handle with (working_state, security_strength, prediction_resistance_flag) =>
    if requested_number_of_bytes >? max_number_of_bytes_per_request then ENTROPY.error ENTROPY.generic_error entropy_stream
    else
      if requested_security_strength >? security_strength then ENTROPY.error ENTROPY.generic_error entropy_stream
      else
        if (Zlength additional_input) >? max_additional_input_length then ENTROPY.error ENTROPY.generic_error entropy_stream
        else
          if prediction_resistance_request && (negb prediction_resistance_flag) then ENTROPY.error ENTROPY.generic_error entropy_stream
          else
            match DRBG_generate_function_helper (generate_algorithm reseed_interval) reseed_function
                       entropy_stream state_handle requested_number_of_bytes prediction_resistance_request
                       additional_input prediction_resistance_request 1%nat with
              | ENTROPY.error e s => ENTROPY.error e s
              | ENTROPY.success (output, new_working_state) entropy_stream =>
                  ENTROPY.success (output, (new_working_state, security_strength, prediction_resistance_flag)) entropy_stream
            end
  end.


(** Coq coding by choukh, July 2022 **)

From ZF Require Import Basic Hierarchy Universe Finiteness.

Section 宇宙蕴含无穷.
Context {𝓜 : ZF}.

Definition Vₙ := 迭代 幂 ∅.
(* V_<ω 类 *)
Definition 有穷层 x := ∃ n, x = Vₙ n.
(* 无穷公理变体: V_<ω 类可集化 *)
Definition Infⱽ := setLike 有穷层.
(* 存在宇宙 *)
Definition Univ := ∃ u, 宇宙 u.

Fact 宇宙蕴含无穷 : Univ → Infⱽ.
Proof.
  intros [u U]. exists (u ∩ₚ 有穷层).
  intros x. split; intros H.
  - now apply 分离 in H.
  - destruct H as [n ->]. apply 分离. split. 2:now exists n.
    induction n. now apply 宇宙对空集封闭. now apply 宇宙对幂集封闭.
Qed.

End 宇宙蕴含无穷.

Section 无穷蕴含宇宙.
Context {𝓜 : ZF}.

Hypothesis inf : Infⱽ.
(* V_<ω 集 *)
Definition Vltω := proj1_sig (集化大消除 inf).
(* Vltω =ₚ 有穷层 *)
Definition 无穷 := proj2_sig (集化大消除 inf).

Definition Vω := ⋃ Vltω.

Lemma Vn是层 n : Vₙ n ∈ₚ 层.
Proof. induction n. apply 空集层. now constructor. Qed.

Lemma Vω是层 : Vω ∈ₚ 层.
Proof.
  constructor. intros x X.
  apply 无穷 in X as [n ->]. apply Vn是层.
Qed.

Lemma Vn属Vltω n : Vₙ n ∈ Vltω.
Proof. apply 无穷. now exists n. Qed.

Lemma Vn属Vω n : Vₙ n ∈ Vω.
Proof.
  apply 并集. exists (Vₙ (S n)).
  split. now apply 幂集. apply Vn属Vltω.
Qed.

Fact Vω对空集封闭 : ∅ ∈ Vω.
Proof. replace ∅ with (Vₙ 0) by reflexivity. apply Vn属Vω. Qed.

Lemma Vω成员属某Vn x : x ∈ Vω → ∃ n, x ∈ Vₙ n.
Proof.
  intros [y [xy yV]] % 并集.
  apply 无穷 in yV as [n ->]. now exists n.
Qed.

Lemma Vω之并 : Vω ⊆ ⋃ Vω.
Proof.
  intros x X. apply Vω成员属某Vn in X as [n X].
  apply 并集. exists (Vₙ n). split; trivial. apply Vn属Vω.
Qed.

Lemma Vω是极限层 : Vω ∈ₚ 极限层.
Proof. split. apply Vω是层. apply Vω之并. Qed.

Section 无穷公理原版.

Definition 归纳集 A := ∅ ∈ A ∧ ∀ a ∈ A, a⁺ ∈ A.
(* 无穷公理: 存在归纳集 *)
Definition Inf := Σ I, 归纳集 I.

Lemma Vω是归纳集 : 归纳集 Vω.
Proof.
  split. apply Vω对空集封闭.
  intros. apply Vω成员属某Vn in H as [n an].
  apply 并集. exists (Vₙ (S n)). split.
  - cbn. apply 后继_升秩. apply an. apply Vn是层.
  - apply Vn属Vltω.
Qed.

Fact Infⱽ_to_Inf : Inf.
Proof. exists Vω. apply Vω是归纳集. Qed.

End 无穷公理原版.

(** Vω集化HF **)

Notation HF := 遗传有穷.

Lemma Vn是遗传有穷集 n : HF (Vₙ n).
Proof.
  induction n as [|n IH].
  - apply HF是空集封闭类.
  - apply HF是幂集封闭类. apply IH.
Qed.

Lemma 非空有穷链封闭 x : 非空 x → 有穷 x → 链 x → ⋃ x ∈ x.
Proof.
  induction 2 as [|x y _ IH]. destruct H. zf.
  intros Ch. 排中 (y = ∅) as [->|NEy%非空I].
  - apply 并入. left. now rewrite 并入空, 并单.
  - assert (IH': ⋃ y ∈ y). {
      apply IH; trivial. eapply 链膨胀. 2:apply Ch.
      intros z zy. apply 并入. auto.
    }
    assert (X: x ∈ x ⨮ y). apply 并入. auto.
    assert (Y: ⋃ y ∈ x ⨮ y). apply 并入. auto.
    destruct (Ch _ X _ Y) as [XY|YX]; apply 并入.
    + right. replace (⋃ (x ⨮ y)) with (⋃ y). trivial. apply 外延.
      * apply 并得父集, 并入. auto.
      * apply 并得子集. intros z [->|Z]%并入. zf. now apply 并得父集.
    + left. apply 外延.
      * apply 并得子集. intros z [->|Z]%并入. zf.
        intros w wz. apply YX, 并集. eauto.
      * apply 并得父集. apply 并入. auto.
Qed.

Lemma 非空有穷集的秩层 x : 非空 x → 有穷 x → ρ x ∈ 𝒫[ρ[x]].
Proof.
  intros [y yx] Fx. rewrite ρ等于ρ'. apply 非空有穷链封闭.
  - exists (𝒫 (ρ y)). now apply 函数式替代2I.
  - now repeat apply 有穷集对函数式替代封闭.
  - intros a [a' [A ->]]%函数式替代2E b [b' [B ->]]%函数式替代2E.
    apply 层弱线序; constructor; apply ρ规范.
Qed.

Lemma 遗传有穷集的秩层在Vω里 x : HF x → ρ x ∈ Vω.
Proof.
  induction 1 as [x Fx _ IH].
  排中 (x = ∅) as [->|[y yx]%非空I].
  - replace (ρ ∅) with ∅. apply Vω对空集封闭. now rewrite ρ_0.
  - apply 非空有穷集的秩层 in Fx as H. 2:now exists y.
    apply 函数式替代2E in H as [z [zx ->]].
    apply 极限层对幂集封闭. apply Vω是极限层. now apply IH.
Qed.

Theorem Vω集化HF : Vω =ₚ HF.
Proof.
  intros x. split; intros H.
  - apply Vω成员属某Vn in H as [n H].
    apply HF是成员封闭类 with (Vₙ n). trivial. apply Vn是遗传有穷集.
  - apply 层膨胀 with (ρ x). apply Vω是层.
    apply ρ规范. now apply 遗传有穷集的秩层在Vω里.
Qed.

(** Vω是宇宙 **)

Lemma Vω对替代封闭 : 替代封闭 Vω.
Proof.
  intros R a Fun H A. apply Vω集化HF.
  apply HF是替代封闭类. trivial. 2: now apply Vω集化HF.
  intros x y Rxy xa. apply Vω集化HF. eapply H; eauto.
Qed.

Lemma Vω是宇宙 : Vω ∈ₚ 宇宙.
Proof.
  apply 宇宙等价于对替代封闭的非空极限层. split3.
  apply Vω对替代封闭. exists ∅. apply Vω对空集封闭. apply Vω是极限层.
Qed.

Lemma 无穷蕴含宇宙 : Univ.
Proof. exists Vω. apply Vω是宇宙. Qed.

(** 极小宇宙 **)

Lemma Vω不属于Vltω : Vω ∉ Vltω.
Proof.
  intros H. apply 无穷 in H as [n H].
  apply (无循环1 (x:=Vₙ n)). rewrite <- H at 2. apply Vn属Vω.
Qed.

Lemma Vltω非空 : 非空 Vltω.
Proof. exists ∅. apply 无穷. now exists 0. Qed.

Lemma Vltω是链 : 链 Vltω.
Proof.
  intros x [n ->]%无穷 y [m ->]%无穷. apply 层弱线序; apply Vn是层.
Qed.

Lemma Vltω是无穷集 : ¬ 有穷 Vltω.
Proof.
  intros H. apply 非空有穷链封闭 in H.
  now apply Vω不属于Vltω. apply Vltω非空. apply Vltω是链.
Qed.

Lemma 非空极限层不低于Vltω x : 非空 x → 极限层 x → Vltω ⊆ x.
Proof.
  intros H1 H2 y Y. apply 无穷 in Y as [n ->].
  induction n as [|n IH].
  - apply 非空层对空集封闭; firstorder.
  - apply 极限层对幂集封闭; trivial.
Qed.

Lemma 非空极限层是无穷集 x : 非空 x → 极限层 x → ¬ 有穷 x.
Proof.
  intros H1 H2 H3. apply Vltω是无穷集.
  apply 有穷集对子集封闭 with x; trivial.
  apply 非空极限层不低于Vltω; trivial.
Qed.

Lemma Vn是有穷集 n : 有穷 (Vₙ n).
Proof. induction n. constructor. now apply 有穷集对幂集封闭. Qed.

Lemma Vω只含有穷集 : Vω ⊆ₚ 有穷.
Proof.
  intros x [n X]%Vω成员属某Vn. destruct n. cbn in X. zf.
  eapply 有穷集对子集封闭 with (Vₙ n). now apply 幂集. apply Vn是有穷集.
Qed.

Lemma 非空极限层不低于Vω x : 非空 x → 极限层 x → Vω ⊆ x.
Proof.
  intros H1 H2. destruct (层线序 Vω是层 (proj1 H2)); trivial.
  exfalso. eapply 非空极限层是无穷集; eauto. now apply Vω只含有穷集.
Qed.

Fact Vω是极小宇宙 u : 宇宙 u → Vω ⊆ u.
Proof. intros H%宇宙是非空极限层. apply 非空极限层不低于Vω; firstorder. Qed.

End 无穷蕴含宇宙.

Theorem 无穷公理等价于存在宇宙 (𝓜 : ZF) : Infⱽ ↔ Univ.
Proof. split. apply 无穷蕴含宇宙. apply 宇宙蕴含无穷. Qed.

Remark 反无穷模型等价于极小模型 (𝓜 : ZF) : ¬ Infⱽ ↔ ¬ Univ.
Proof. split; intros H1 H2; now apply 无穷公理等价于存在宇宙 in H2. Qed.


Require Import Coq.Lists.List. Import ListNotations.
Require Import Coq.ZArith.ZArith. Open Scope Z_scope.
Require Import Coq.Strings.String. Open Scope string_scope.
Require Import coqutil.Byte.
Require Import coqutil.Word.Interface coqutil.Word.Properties.
Require Import coqutil.Tactics.fwd.
Require Import bedrock2.ZnWords.
Require Import compiler.SeparationLogic.
Require Import Bedrock2Experiments.RiscvMachineWithCavaDevice.ExtraRiscvMachine.
Require Import Bedrock2Experiments.RiscvMachineWithCavaDevice.InternalMMIOMachine.
Require Import Bedrock2Experiments.IncrementWait.CavaIncrementDevice.
Require Import Bedrock2Experiments.IncrementWait.IncrementWaitToRiscV.
Require Import Bedrock2Experiments.IncrementWait.IncrementWaitToRiscVProperties.
Require Import Bedrock2Experiments.RiscvMachineWithCavaDevice.Bedrock2ToCava.

Definition binary: list byte := Eval compute in Pipeline.instrencode put_wait_get_asm.

Theorem IncrementWait_end2end_correct: forall p_functions ret_addr mH (Rdata Rexec R: mem -> Prop)
          (initialL: ExtraRiscvMachine counter_device) input sched,
    word.unsigned (word.sub stack_pastend stack_start) mod 4 = 0 ->
    word.unsigned p_functions mod 4 = 0 ->
    word.unsigned ret_addr mod 4 = 0 ->
    machine_ok p_functions stack_start stack_pastend binary mH Rdata Rexec initialL ->
    R mH ->
    map.get initialL.(getRegs) RegisterNames.a0 = Some input ->
    map.get initialL.(getRegs) RegisterNames.ra = Some ret_addr ->
    word.unsigned ret_addr mod 4 = 0 ->
    initialL.(getLog) = [] ->
    initialL.(getPc) = word.add p_functions (word.of_Z put_wait_get_relative_pos) ->
    exists steps_remaining finalL mH',
      run sched steps_remaining initialL = Some finalL /\
      machine_ok p_functions stack_start stack_pastend binary mH' Rdata Rexec finalL /\
      R mH' /\
      map.get finalL.(getRegs) RegisterNames.a0 = Some (word.add (word.of_Z 1) input) /\
      finalL.(getPc) = ret_addr.
Proof.
  intros.
  change binary with (Pipeline.instrencode put_wait_get_asm).
  edestruct bedrock2_and_cava_system_correct with
      (f_entry_name := "put_wait_get")
      (stack_start := stack_start) (stack_pastend := stack_pastend)
      (postH := fun m' retvals =>  R m' /\ retvals = [word.add (word.of_Z 1) input])
    as (steps_remaining & finalL & mH' & retvals & Rn & GM & A & Eq & M & HP & HL);
    lazymatch goal with
    | |- _ mod _ = _ => idtac
    | |- _ => try eassumption
    end.
  { exact funcs_valid. }
  { apply List.dedup_NoDup_iff. reflexivity. }
  { exact put_wait_get_compile_result_eq. }
  { (* check that the compiler emitted valid instructions: *)
    repeat (apply Forall_cons || apply Forall_nil).
    all: vm_compute; try intuition discriminate. }
  { reflexivity. }
  { vm_compute. discriminate. }
  { assumption. }
  { assumption. }
  { assumption. }
  { eapply WeakestPreconditionProperties.Proper_call.
    2: eapply IncrementWaitProperties.put_wait_get_correct.
    2: eassumption.
    2: reflexivity.
    unfold Morphisms.pointwise_relation, Basics.impl.
    intros. fwd.
    unfold IncrementWaitSemantics.proc.
    split. 1: split; [assumption|reflexivity].
    eexists; split; [eassumption|reflexivity]. }
  { cbn -[map.get].
    match goal with
    | H: map.get _ RegisterNames.a0 = Some input |-
      match ?x with _ => _ end = _ => replace x with (Some input)
    end.
    reflexivity. }
  { eassumption. }
  { cbn -[map.get] in GM. fwd. unfold run. do 3 eexists. rewrite Rn. eauto 10. }
Qed.

(* Goal: bring this list down to only standard axioms like functional and propositional extensionality
Print Assumptions IncrementWait_end2end_correct.
*)


From Perennial.program_proof Require Import grove_prelude.
From Goose.github_com.mit_pdos.gokv.simplepb Require Export admin.
From Perennial.program_proof.grove_shared Require Import urpc_proof urpc_spec.
From Perennial.goose_lang.lib Require Import waitgroup.
From iris.base_logic Require Export lib.ghost_var mono_nat.
From iris.algebra Require Import dfrac_agree mono_list.
From Perennial.program_proof.simplepb Require Import pb_definitions config_proof pb_setstate_proof pb_getstate_proof pb_becomeprimary_proof pb_makeclerk_proof.

Section config_global.

Context {pb_record:PBRecord}.
Notation pbG := (pbG (pb_record:=pb_record)).
Notation OpType := (pb_OpType pb_record).

Context `{!gooseGlobalGS Σ}.
Context `{!configG Σ}.
Context `{!pbG Σ}.

Definition adminN := nroot .@ "admin".

Definition is_conf_inv γpb γconf : iProp Σ :=
  inv adminN (∃ epoch conf (confγs:list pb_server_names) epoch_lb,
      "Hepoch" ∷ config_proof.own_epoch γconf epoch ∗
      "Hconf" ∷ own_config γconf conf ∗
      "#His_conf" ∷ is_epoch_config γpb epoch_lb confγs ∗
      "#His_conf_prop" ∷ is_epoch_config_proposal γpb epoch_lb confγs ∗
      "#His_hosts" ∷ ([∗ list] γsrv ; host ∈ confγs ; conf, is_pb_host host γpb γsrv) ∗
      "#His_lbs" ∷ (∀ γsrv, ⌜γsrv ∈ confγs⌝ → pb_ghost.is_epoch_lb γsrv epoch_lb) ∗
      "Hunused" ∷ ([∗ set] epoch' ∈ (fin_to_set u64), ⌜int.nat epoch < int.nat epoch'⌝ → config_proposal_unset γpb epoch' ∗ config_unset γpb epoch' ∗ own_proposal_unused γpb epoch' ∗ own_init_proposal_unused γpb epoch') ∗
      "Hunset_or_set" ∷ (config_unset γpb epoch ∨ ⌜int.nat epoch_lb = int.nat epoch⌝) ∗
      "#His_skip" ∷ (∀ epoch_skip, ⌜int.nat epoch_lb < int.nat epoch_skip⌝ → ⌜int.nat epoch_skip < int.nat epoch⌝ → is_epoch_skipped γpb epoch_skip)
      )
.

(* before calling this lemma, have to already allocate pb ghost state *)
Lemma config_ghost_init_2 γsys conf confγs :
  ([∗ list] γsrv ; host ∈ confγs ; conf, is_pb_host host γsys γsrv) -∗
  pb_init_config γsys confγs
  ={⊤}=∗ ∃ γconf, is_conf_inv γsys γconf ∗ makeConfigServer_pre γconf conf.
Proof.
  iIntros "#Hhosts Hinitconf".
  iMod (config_ghost_init conf) as (γconf) "(Hconfpre & Hepoch & Hconf)".
  iExists _; iFrame "Hconfpre".
  iMod (inv_alloc with "[-]") as "$"; last done.
  iNext.
  iExists (U64 0), conf, confγs, (U64 0).
  iFrame.
  iNamed "Hinitconf".
  iFrame "∗#%".
  iSplitR.
  { iRight. done. }
  iIntros (???).
  exfalso.
  word.
Qed.

End config_global.

Section admin_proof.

Context {pb_record:PBRecord}.
Notation pbG := (pbG (pb_record:=pb_record)).
Notation OpType := (pb_OpType pb_record).
Notation has_op_encoding := (pb_has_op_encoding pb_record).
Notation has_snap_encoding := (pb_has_snap_encoding pb_record).
Notation compute_reply := (pb_compute_reply pb_record).

Notation wp_Clerk__GetState := (wp_Clerk__GetState (pb_record:=pb_record)).
Notation wp_Clerk__SetState := (wp_Clerk__SetState (pb_record:=pb_record)).

Context `{!heapGS Σ}.
Context `{!pbG Σ}.
Context `{!configG Σ}.
Context `{!waitgroupG Σ}.

Definition is_conf_host confHost γpb : iProp Σ :=
  ∃ γconf,
  config_proof.is_host confHost γconf ∗ is_conf_inv γpb γconf.

Definition is_Clerk2 ck γpb : iProp Σ :=
  ∃ γconf,
    "#Hinv" ∷ is_conf_inv γpb γconf ∗
    "#Hck" ∷ is_Clerk ck γconf.

Lemma wp_MakeClerk2 (configHost:u64) γpb :
  {{{
        is_conf_host configHost γpb
  }}}
    config.MakeClerk #configHost
  {{{
      ck, RET #ck; is_Clerk2 ck γpb
  }}}.
Proof.
  iIntros (Φ) "#Hhost HΦ".
  iDestruct "Hhost" as (?) "[Hhost Hinv]".
  wp_apply (config_proof.wp_MakeClerk with "[$Hhost]").
  iIntros.
  iApply "HΦ".
  iExists  _; iFrame "#".
Qed.

Lemma wp_Clerk__GetConfig2 ck γpb Φ :
  is_Clerk2 ck γpb -∗
  □(∀ confγs (conf:list u64) config_sl,
  (is_slice_small config_sl uint64T 1 conf ∗
  ([∗ list] γsrv ; host ∈ confγs ; conf, is_pb_host host γpb γsrv) -∗
   Φ (slice_val config_sl)%V
  )) -∗
  WP config.Clerk__GetConfig #ck {{ Φ }}
.
Proof.
  iIntros "#Hck #HΦ".
  iNamed "Hck".
  wp_apply (wp_Clerk__GetConfig with "[$Hck]").
  iModIntro.
  iIntros "Hlc".
  iInv "Hinv" as "Hi" "Hclose".
  iMod (lc_fupd_elim_later with "Hlc Hi") as "Hi".
  iApply fupd_mask_intro.
  { set_solver. }
  iIntros "Hmask".
  iNamed "Hi".
  iExists _.
  iFrame.
  iIntros "Hconfig".
  iMod "Hmask".
  iMod ("Hclose" with "[-]").
  {
    iNext. iExists _, _, _, _.
    iFrame "∗#%".
  }
  iModIntro.
  iIntros (?) "Hconf".
  iApply "HΦ".
  iFrame "∗#".
Qed.

Lemma wp_Clerk__GetEpochAndConfig2 ck γpb Φ :
  is_Clerk2 ck γpb -∗
  □(∀ (epoch epoch_lb:u64) confγs (conf:list u64) config_sl,
  (is_slice_small config_sl uint64T 1 conf ∗
  config_proposal_unset γpb epoch ∗
  own_proposal_unused γpb epoch ∗
  own_init_proposal_unused γpb epoch ∗
  is_epoch_config γpb epoch_lb confγs ∗
  (∀ epoch_skip, ⌜int.nat epoch_lb < int.nat epoch_skip⌝ → ⌜int.nat epoch_skip < int.nat epoch⌝ → is_epoch_skipped γpb epoch_skip) ∗
  ([∗ list] γsrv ; host ∈ confγs ; conf, is_pb_host host γpb γsrv) ∗
  (∀ γsrv, ⌜γsrv ∈ confγs⌝ → pb_ghost.is_epoch_lb γsrv epoch_lb)) -∗
   Φ (#epoch, slice_val config_sl)%V
  ) -∗
  WP config.Clerk__GetEpochAndConfig #ck {{ Φ }}
.
Proof.
  iIntros "#Hck #HΦ".
  iNamed "Hck".
  wp_apply (wp_Clerk__GetEpochAndConfig with "[$Hck]").
  iModIntro.
  iIntros "Hlc".
  iInv "Hinv" as "Hi" "Hclose".
  iMod (lc_fupd_elim_later with "Hlc Hi") as "Hi".
  iApply fupd_mask_intro.
  { set_solver. }
  iIntros "Hmask".
  iNamed "Hi".
  iExists _, _.
  iFrame.
  iIntros "%Hno_overflow Hepoch Hconf".
  iMod "Hmask".

  (* Hunset becomes skipped, and the first unused becomes unset. *)
  iDestruct (big_sepS_elem_of_acc_impl (word.add epoch (U64 1)) with "Hunused") as "[Hunset_new Hunused]".
  { set_solver. }

  iSpecialize ("Hunset_new" with "[]").
  { done. }
  iDestruct "Hunset_new" as "(Hunset_new & Hunset_new2 & Hprop)".

  iDestruct "Hunset_or_set" as "[Hunset|%Hset]".
  {
    iMod (own_update with "Hunset") as "Hskip1".
    {
      apply singleton_update.
      apply dfrac_agree_persist.
    }
    iDestruct "Hskip1" as "#Hskip1".

    iMod ("Hclose" with "[Hunset_new2 Hunused Hepoch Hconf]").
    {
      iNext. iExists _, _, _, _.
      iFrame "∗#".
      iSplitL "Hunused".
      {
        iApply "Hunused".
        {
          iModIntro.
          iIntros (???) "H". iIntros.
          iApply "H".
          iPureIntro.
          word.
        }
        {
          iIntros. exfalso. word.
        }
      }
      iIntros (???).
      assert (int.nat epoch_skip = int.nat epoch ∨ int.nat epoch_skip < int.nat epoch ∨ int.nat epoch_skip >= int.nat (word.add epoch (U64 1))) as Hineq.
      { word. }
      destruct Hineq as [Heq|[Hineq|Hineq]].
      {
        replace (epoch_skip) with (epoch) by word.
        iFrame "Hskip1".
      }
      {
        iApply "His_skip".
        { done. }
        { done. }
      }
      { exfalso. word. }
    }
    iModIntro.
    iIntros.
    iApply "HΦ".
    iDestruct "Hprop" as "[$ $]".
    iFrame "∗#".

    (* TODO: repetetive proof *)
    iIntros.
    assert (int.nat epoch_skip = int.nat epoch ∨ int.nat epoch_skip < int.nat epoch ∨ int.nat epoch_skip >= int.nat (word.add epoch (U64 1))) as Hineq.
    { word. }
    destruct Hineq as [Heq|[Hineq|Hineq]].
    {
      replace (epoch_skip) with (epoch) by word.
      iFrame "Hskip1".
    }
    {
      iApply "His_skip".
      { done. }
      { done. }
    }
    { exfalso. word. }
  }
  {
    iClear "His_skip".

    iMod ("Hclose" with "[Hunset_new2 Hunused Hepoch Hconf]").
    {
      iNext. iExists _, _, _, _.
      iFrame "∗#".
      iSplitL "Hunused".
      {
        iApply "Hunused".
        {
          iModIntro.
          iIntros (???) "H". iIntros.
          iApply "H".
          iPureIntro.
          word.
        }
        {
          iIntros. exfalso. word.
        }
      }
      iIntros (???).
      exfalso.
      rewrite Hset in H.
      replace (int.nat (word.add epoch 1%Z)) with (int.nat epoch + 1) in H0 by word.
      word.
    }
    iModIntro.
    iIntros.
    iApply "HΦ".
    iDestruct "Hprop" as "[$ $]".
    iFrame "∗#".
    iIntros (???).
    exfalso.
    rewrite Hset in H.
    replace (int.nat (word.add epoch 1%Z)) with (int.nat epoch + 1) in H0 by word.
    word.
  }
Qed.

Lemma wp_Clerk__WriteConfig2 ck γpb Φ config_sl conf confγ epoch :
  is_Clerk2 ck γpb -∗
  is_slice_small config_sl uint64T 1 conf -∗
  is_epoch_config_proposal γpb epoch confγ -∗
  ([∗ list] γsrv ; host ∈ confγ ; conf, is_pb_host host γpb γsrv) -∗
  (∀ γsrv, ⌜γsrv ∈ confγ⌝ → pb_ghost.is_epoch_lb γsrv epoch) -∗
  □ (∀ (err:u64),
      (if (decide (err = U64 0)) then
        is_epoch_config γpb epoch confγ
      else
        True) -∗
      is_slice_small config_sl uint64T 1 conf -∗
      Φ #err)
  -∗
  WP config.Clerk__WriteConfig #ck #epoch (slice_val config_sl) {{ Φ }}
.
Proof.
  iIntros "#Hck Hsl #Hconf_prop #Hhosts #Hlbs #HΦ".
  iNamed "Hck".
  wp_apply (wp_Clerk__WriteConfig with "Hck Hsl"); last first.
  {
    iIntros.
    iApply ("HΦ" with "[] [$]").
    destruct (decide _).
    { exfalso. done. }
    done.
  }
  iModIntro.
  iIntros "Hlc".
  iInv "Hinv" as "Hi" "Hclose".
  iMod (lc_fupd_elim_later with "Hlc Hi") as "Hi".
  iApply fupd_mask_intro.
  { set_solver. }
  iIntros "Hmask".
  iNamed "Hi".
  iExists _.
  iFrame "∗".
  destruct (decide (_)); last first.
  { (* write failed because of stale epoch. *)
    iIntros "Hepoch".
    iMod "Hmask" as "_".
    iMod ("Hclose" with "[Hepoch Hconf Hunused Hunset_or_set]").
    {
      iNext.  iExists _, _, _, _.
      iFrame "∗#".
    }
    iModIntro.
    iIntros (??) "Hsl".
    wp_pures.
    iApply ("HΦ" with "[] Hsl").
    destruct (decide (_)).
    { exfalso. done. }
    done.
  }
  { (* successful write *)
    rewrite e.
    iExists _.
    iFrame.
    iIntros "Hconf Hepoch".
    iMod "Hmask" as "_".

    iDestruct "Hunset_or_set" as "[Hunset|%Hset]"; last first.
    { (* config was already set before *)
      replace (epoch) with (epoch_lb) by word.
      iDestruct "Hconf_prop" as "[Hconf_prop %Hle]".
      iDestruct "His_conf_prop" as "[His_conf_prop _]".
      iDestruct (own_valid_2 with "His_conf_prop Hconf_prop") as %Hvalid.
      rewrite singleton_op in Hvalid.
      rewrite singleton_valid in Hvalid.
      rewrite dfrac_agree_op_valid in Hvalid.
      replace confγ with confγs in * by naive_solver.

      iMod ("Hclose" with "[Hepoch Hconf Hunused]").
      {
        iNext.  iExists _, _, _, _.
        iFrame "∗#".
        iSplitL; first done.
        by iRight.
      }
      iApply "HΦ".
      iModIntro.
      iFrame "#".
    }
    { (* config is being set for the first time *)
      iMod (own_update with "Hunset") as "Hset".
      {
        apply singleton_update.
        apply cmra_update_exclusive.
        instantiate (1:=(to_dfrac_agree (DfracOwn 1) ((Some confγ) : (leibnizO _)))).
        done.
      }
      iMod (own_update with "Hset") as "Hset".
      { apply singleton_update. apply dfrac_agree_persist. }
      iDestruct "Hset" as "#Hset".
      iMod ("Hclose" with "[Hconf Hepoch Hunused]").
      {
        iNext. iExists _, _, _, _.
        iFrame "∗#".
        iDestruct "Hconf_prop" as "[_ %Hineq]".
        iSplitR; first done.
        iSplitL.
        { by iRight. }
        iIntros (???).
        exfalso.
        word.
      }
      iApply "HΦ".
      iDestruct "Hconf_prop" as "[_ %Hineq]".
      iFrame "#".
      done.
    }
  }
Qed.

Lemma wp_Reconfig γ (configHost:u64) (servers:list u64) (servers_sl:Slice.t) server_γs :
  {{{
        "Hservers_sl" ∷ is_slice servers_sl uint64T 1 servers ∗
        "#Hhost" ∷ ([∗ list] γsrv ; host ∈ server_γs ; servers, is_pb_host host γ γsrv) ∗
        "#Hconf_host" ∷ is_conf_host configHost γ
  }}}
    EnterNewConfig #configHost (slice_val servers_sl)
  {{{
        (err:u64), RET #err; True
  }}}.
Proof using waitgroupG0.
  iIntros (Φ) "Hpre HΦ".
  iNamed "Hpre".
  wp_call.

  wp_apply (wp_slice_len).
  wp_pures.
  iDestruct (is_slice_sz with "Hservers_sl") as %Hservers_sz.
  wp_if_destruct.
  {
    by iApply "HΦ".
  }

  wp_apply (wp_MakeClerk2 with "Hconf_host").
  iIntros (ck) "#Hck".
  wp_pures.
  wp_bind (Clerk__GetEpochAndConfig _).
  iApply (wp_frame_wand with "[HΦ Hservers_sl]").
  { iNamedAccu. }
  wp_apply (wp_Clerk__GetEpochAndConfig2 with "[$Hck]").
  iModIntro.
  iIntros (?????) "Hpost1".
  iNamed 1.
  wp_pures.
  unfold prelude.Data.randomUint64.
  wp_pures.
  set (s:=(u64_instance.u64.(word.add) (U64 0) (U64 1))).
  generalize s as randId.
  clear s.
  intros randId.
  wp_apply (wp_slice_len).
  wp_pures.

  iDestruct "Hpost1" as "(Hconf_sl & Hconf_unset & Hprop & Hinit & #His_conf & #Hskip & #His_hosts & #Hlb)".

  iAssert (⌜length conf ≠ 0⌝)%I as %Hold_conf_ne.
  {
    iDestruct "His_conf" as "[_ %Hconfγ_nz]".
    iDestruct (big_sepL2_length with "His_hosts") as %Heq.
    iPureIntro.
    lia.
  }
  iDestruct (is_slice_small_sz with "Hconf_sl") as %Hconf_len.
  set (oldNodeId:=word.modu randId config_sl.(Slice.sz)).
  assert (int.nat oldNodeId < length conf) as Hlookup_conf.
  { rewrite Hconf_len.
    unfold oldNodeId.
    enough (int.Z randId `mod` int.Z config_sl.(Slice.sz) < int.Z config_sl.(Slice.sz))%Z.
    { word. }
    apply Z.mod_pos_bound.
    word.
  }
  apply lookup_lt_is_Some_2 in Hlookup_conf as [host Hlookup_conf].
  wp_apply (wp_SliceGet with "[$Hconf_sl]").
  { done. }
  iIntros "Hconf_sl".
  simpl.
  (* FIXME: how does wp_MakeClerk work here? *)
  iDestruct (big_sepL2_lookup_2_some with "His_hosts") as %HH.
  { done. }
  destruct HH as [γsrv_old Hconfγ_lookup].
  wp_apply (wp_MakeClerk with "[]").
  {
    iDestruct (big_sepL2_lookup_acc with "His_hosts") as "[$ _]"; done.
  }
  iIntros (oldClerk) "#HoldClerk".
  wp_pures.

  (* Get the old state *)
  wp_apply (wp_allocStruct).
  { naive_solver. }
  iIntros (args) "Hargs".
  iDestruct (struct_fields_split with "Hargs") as "HH".
  iNamed "HH".
  wp_apply (wp_Clerk__GetState with "[$HoldClerk $Epoch]").
  {
    iApply "Hlb".
    iPureIntro.
    eapply elem_of_list_lookup_2.
    done.
  }
  iIntros (reply err) "Hpost".
  wp_pures.
  destruct (decide (err = _)); last first.
  { (* err ≠ 0; error. *)
    iNamed "Hpost".
    wp_loadField.
    wp_pures.
    rewrite bool_decide_false; last naive_solver.
    wp_pures.
    wp_loadField.
    simpl.
    iApply "HΦ".
    done.
  }
  (* err = 0; keep going with reconfig *)
  (* Got the old state now *)
  iDestruct "Hpost" as (???) "(%Hepoch_lb_ineq & %Hepoch_ub_ineq & #Hacc_ro & #Hprop_facts & #Hprop_lb & Hreply & %Henc & %Hlen_no_overflow)".
  destruct (decide (int.nat epochacc = int.nat epoch)) as [Heq|Hepochacc_ne_epoch].
  {
    replace (epochacc) with (epoch) by word.
    iDestruct (own_valid_2 with "Hprop Hprop_lb") as %Hvalid.
    exfalso.
    rewrite singleton_op singleton_valid in Hvalid.
    rewrite auth_map.Cinl_Cinr_op in Hvalid.
    done.
  }
  iMod (ghost_init_primary with "Hprop_lb Hprop_facts His_conf Hacc_ro Hskip Hprop Hinit") as "(Hprop & #Hprop_facts2 & #Hinit)".
  { by eapply elem_of_list_lookup_2. }
  { word. }
  { word. }

  iNamed "Hreply".
  wp_loadField.
  simpl.
  wp_pures.

  wp_apply (wp_slice_len).
  wp_apply (wp_NewSlice).
  iIntros (clerks_sl) "Hclerks_sl".
  wp_pures.

  iDestruct (is_slice_to_small with "Hservers_sl") as "Hservers_sl".
  rewrite -Hservers_sz.
  iDestruct (is_slice_to_small with "Hclerks_sl") as "Hclerks_sl".
  iDestruct (is_slice_small_sz with "Hclerks_sl") as %Hclerks_sz.
  rewrite replicate_length in Hclerks_sz.
  simpl.
  wp_apply (wp_ref_to).
  { eauto. }
  iIntros (i_ptr) "Hi".
  wp_pures.

  (* weaken to loop invariant *)
  iAssert (
        ∃ (i:u64) clerksComplete clerksLeft,
          "Hi" ∷ i_ptr ↦[uint64T] #i ∗
          "%HcompleteLen" ∷ ⌜length clerksComplete = int.nat i⌝ ∗
          "%Hlen" ∷ ⌜length (clerksComplete ++ clerksLeft) = length servers⌝ ∗
          "Hclerks_sl" ∷ is_slice_small clerks_sl ptrT 1 (clerksComplete ++ clerksLeft) ∗
          "Hservers_sl" ∷ is_slice_small servers_sl uint64T 1 servers ∗
          "#Hclerks_is" ∷ ([∗ list] ck ; γsrv ∈ clerksComplete ; (take (length clerksComplete) server_γs),
                              pb_definitions.is_Clerk ck γ γsrv
                              )
          )%I with "[Hclerks_sl Hservers_sl Hi]" as "HH".
  {
    iExists _, [], _.
    simpl.
    iFrame "∗#".
    iPureIntro.
    split; first word.
    apply replicate_length.
  }
  wp_forBreak_cond.

  wp_pures.
  iNamed "HH".
  wp_load.
  wp_apply (wp_slice_len).
  wp_pures.
  clear host Hlookup_conf.
  wp_if_destruct.
  { (* loop not finished *)
    wp_pures.
    wp_load.
    assert (int.nat i < length servers) as Hlookup.
    { word. }
    apply list_lookup_lt in Hlookup as [host Hlookup].
    wp_apply (wp_SliceGet with "[$Hservers_sl]").
    { done. }

    iIntros "Hserver_sl".

    iDestruct (big_sepL2_lookup_2_some with "Hhost") as %HH.
    { done. }
    destruct HH as [γsrv Hserver_γs_lookup].
    wp_apply (wp_MakeClerk with "[]").
    {
      iDestruct (big_sepL2_lookup_acc with "Hhost") as "[$ _]"; done.
    }
    iIntros (pbCk) "#HpbCk".
    wp_load.
    wp_apply (wp_SliceSet (V:=loc) with "[Hclerks_sl]").
    {
      iFrame "Hclerks_sl".
      iPureIntro.
      apply list_lookup_lt.
      word.
    }
    iIntros "Hclerks_sl".
    wp_load.
    wp_store.
    iLeft.
    iModIntro.
    iSplitR; first done.
    iFrame "∗#".
    iExists _, _, _.
    iFrame "∗".
    instantiate (1:=clerksComplete ++ [pbCk]).
    iSplitR.
    {
      iPureIntro.
      rewrite app_length.
      simpl.
      word.
    }
    instantiate (2:=tail clerksLeft).
    destruct clerksLeft.
    {
      exfalso.
      rewrite app_nil_r in Hlen.
      word.
    }

    iSplitR.
    {
      iPureIntro.
      rewrite app_length.
      rewrite app_length.
      simpl.
      rewrite -Hlen.
      rewrite app_length.
      simpl.
      word.
    }
    iSplitL.
    {
      iApply to_named.
      iExactEq "Hclerks_sl".
      {
        f_equal.
        simpl.
        rewrite -HcompleteLen.
        replace (length _) with (length clerksComplete + 0) by lia.
        rewrite insert_app_r.
        simpl.
        rewrite -app_assoc.
        f_equal.
      }
    }
    rewrite app_length.
    simpl.
    iDestruct (big_sepL2_length with "Hhost") as %Hserver_len_eq.
    rewrite take_more; last first.
    { lia. }

    iApply (big_sepL2_app with "Hclerks_is []").

    replace (take 1 (drop (_) server_γs)) with ([γsrv]); last first.
    {
      apply ListSolver.list_eq_bounded.
      {
        simpl.
        rewrite take_length.
        rewrite drop_length.
        word.
      }
      intros.
      rewrite list_lookup_singleton.
      destruct i0; last first.
      {
        exfalso. simpl in *. word.
      }
      rewrite lookup_take; last first.
      { word. }
      rewrite lookup_drop.
      rewrite HcompleteLen.
      rewrite -Hserver_γs_lookup.
      f_equal.
      word.
      (* TODO: list_solver. *)
    }
    iApply big_sepL2_singleton.
    iFrame "#".
  }
  (* done with for loop *)
  iRight.
  iSplitR; first done.
  iModIntro.
  assert (int.nat i = length servers) as Hi_done.
  {
    rewrite Hclerks_sz.
    rewrite app_length in Hlen.
    word.
  }

  wp_pures.
  replace (clerksLeft) with ([] : list loc) in *; last first.
  {
    (* TODO: list_solver. pure fact *)
    enough (length clerksLeft = 0).
    {
      symmetry.
      apply nil_length_inv.
      done.
    }
    rewrite app_length in Hlen.
    word.
  }
  wp_apply (wp_NewWaitGroup_free).
  iIntros (wg) "Hwg".
  wp_pures.
  wp_apply (wp_slice_len).

  wp_apply (wp_new_slice). (* XXX: untyped *)
  { done. }
  clear err e.
  iIntros (errs_sl) "Herrs_sl".
  iDestruct (slice.is_slice_sz with "Herrs_sl") as "%Herrs_sz".
  wp_pures.
  wp_store.
  wp_pures.

  rewrite app_nil_r.
  rename clerksComplete into clerks.
  iApply fupd_wp.
  iMod (fupd_mask_subseteq (↑adminN)) as "Hmask".
  { set_solver. }
  set (P:= (λ i, ∃ (err:u64) γsrv',
      ⌜server_γs !! int.nat i = Some γsrv'⌝ ∗
        readonly ((errs_sl.(Slice.ptr) +ₗ[uint64T] int.Z i)↦[uint64T] #err) ∗
        □ if (decide (err = U64 0)) then
            pb_ghost.is_epoch_lb γsrv' epoch
          else
            True
  )%I : u64 → iProp Σ).
  iMod (free_WaitGroup_alloc adminN _ P with "Hwg") as (γwg) "Hwg".
  iMod "Hmask" as "_".
  iModIntro.

  (* iMod (readonly_alloc_1 with "Hreply_epoch") as "#Hreply_epoch". *)
  iMod (readonly_alloc_1 with "Hreply_state") as "#Hreply_state".
  iMod (readonly_alloc_1 with "Hreply_next_index") as "#Hreply_next_index".
  iDestruct "Hreply_state_sl" as "#Hreply_state_sl".

  (* weaken to loop invariant *)
  iAssert (
        ∃ (i:u64),
          "Hi" ∷ i_ptr ↦[uint64T] #i ∗
          "%Hi_ineq" ∷ ⌜int.nat i ≤ length clerks⌝ ∗
          "Herrs" ∷ (errs_sl.(Slice.ptr) +ₗ[uint64T] int.Z i)↦∗[uint64T] (replicate (int.nat clerks_sl.(Slice.sz)- int.nat i) #0) ∗
          "Hwg" ∷ own_WaitGroup adminN wg γwg i P
          )%I with "[Herrs_sl Hi Hwg]" as "HH".
  {
    unfold is_slice.
    unfold slice.is_slice. unfold slice.is_slice_small.
    clear Hlen.
    iDestruct "Herrs_sl" as "[[Herrs_sl %Hlen] _]".
    destruct Hlen as [Hlen _].
    iExists _; iFrame.
    iSplitR; first iPureIntro.
    { word. }
    simpl.
    replace (1 * int.Z _)%Z with (0%Z) by word.
    rewrite loc_add_0.
    replace (int.nat _ - int.nat 0) with (int.nat clerks_sl.(Slice.sz)) by word.
    iFrame "Herrs_sl".
  } (* FIXME: copy/pasted from pb_apply_proof *)
  wp_forBreak_cond.

  clear i HcompleteLen Heqb0 Hi_done.
  iNamed "HH".
  wp_load.
  wp_apply (wp_slice_len).
  wp_pures.

  iDestruct (ghost_get_propose_lb with "Hprop") as "#Hprop_lb2".
  wp_if_destruct.
  { (* loop continues *)
    wp_pures.
    wp_apply (wp_WaitGroup__Add with "[$Hwg]").
    { word. }
    iIntros "[Hwg Hwg_tok]".
    wp_pures.
    wp_load.

    assert (int.nat i < int.nat clerks_sl.(Slice.sz)) as Hlookup by word.
    rewrite -Hclerks_sz in Hlookup.
    rewrite app_nil_r in Hlen.
    rewrite -Hlen in Hlookup.
    apply list_lookup_lt in Hlookup as [pbCk Hlookup].
    wp_apply (wp_SliceGet with "[$Hclerks_sl]").
    { done. }
    iIntros "Hclerks_sl".

    wp_pures.

    replace (int.nat clerks_sl.(Slice.sz) - int.nat i) with (S (int.nat clerks_sl.(Slice.sz) - (int.nat (word.add i 1)))) by word.
    rewrite replicate_S.
    iDestruct (array_cons with "Herrs") as "[Herr_ptr Herr_ptrs]".
    wp_load.
    wp_pures.

    iDestruct (own_WaitGroup_to_is_WaitGroup with "[Hwg]") as "#His_wg".
    { by iExactEq "Hwg". }
    wp_apply (wp_fork with "[Hwg_tok Herr_ptr]").
    {
      iNext.
      wp_pures.
      wp_loadField.
      wp_loadField.
      wp_apply (wp_allocStruct).
      { repeat econstructor. done. }
      iIntros (args_ptr) "Hargs".
      iDestruct (struct_fields_split with "Hargs") as "HH".
      iNamed "HH".

      iDestruct (big_sepL2_lookup_1_some with "Hclerks_is") as %[γsrv Hlookup2].
      { done. }
      iDestruct (big_sepL2_lookup_acc with "Hclerks_is") as "[HH _]".
      { done. }
      { done. }
      wp_apply (wp_Clerk__SetState with "[Epoch NextIndex State]").
      {
        iFrame "∗#".
        iSplitR.
        {
          iPureIntro.
          done.
        }
        iSplitR.
        {
          iPureIntro.
          done.
        }
        iExists _.
        iFrame "∗#".
      }
      iIntros (err) "#Hpost".

      unfold SliceSet.
      unfold slice.ptr.
      wp_pures.
      wp_store.

      iMod (readonly_alloc_1 with "Herr_ptr") as "#Herr_ptr".
      wp_apply (wp_WaitGroup__Done with "[$Hwg_tok $His_wg]").
      {
        rewrite lookup_take_Some in Hlookup2.
        destruct Hlookup2 as [Hlookup2 _].
        iModIntro.
        unfold P.
        iExists _, _.
        iSplitL; first done.
        iFrame "#".
      }
      done.
    }
    wp_pures.
    wp_load.
    wp_store.

    (* re-establish loop invariant *)
    iModIntro.
    iLeft.
    iSplitR; first done.
    iFrame "∗".
    iExists _.
    iFrame "∗#".
    iSplitR.
    { iPureIntro. word. }
    iApply to_named.
    iExactEq "Herr_ptrs".
    f_equal.
    rewrite loc_add_assoc.
    f_equal.
    simpl.
    replace (int.Z (word.add i 1%Z)) with (int.Z i + 1)%Z by word.
    word.
  }
  (* loop completed *)
  iModIntro.
  iRight.
  iSplitR; first done.

  wp_pures.
  wp_apply (wp_WaitGroup__Wait with "[$Hwg]").
  iIntros "#Hwg_post".
  wp_pures.
  replace (int.nat i) with (length clerks); last first.
  {
    rewrite app_nil_r in Hlen.
    word.
  }

  wp_apply (wp_ref_to).
  { eauto. }
  iIntros (err_ptr) "Herr".
  wp_pures.
  wp_store.
  wp_pures.

  (* FIXME: *)
  (* This was copy/pasted and modified from apply_proof *)
  iAssert (∃ (i err:u64),
              "Hj" ∷ i_ptr ↦[uint64T] #i ∗
              "%Hj_ub" ∷ ⌜int.nat i ≤ length clerks⌝ ∗
              "Herr" ∷ err_ptr ↦[uint64T] #err ∗
              "#Hrest" ∷ □ if (decide (err = (U64 0)%Z)) then
                (∀ (k:u64) γsrv, ⌜int.nat k < int.nat i⌝ -∗ ⌜server_γs !! (int.nat k) = Some γsrv⌝ -∗ pb_ghost.is_epoch_lb γsrv epoch)
              else
                True
          )%I with "[Hi Herr]" as "Hloop".
  {
    iExists _, _.
    iFrame "∗".
    iSplitL.
    { iPureIntro. word. }
    iModIntro.
    destruct (decide (_)); last first.
    { done. }
    iIntros.
    exfalso. replace (int.nat 0%Z) with 0 in H by word.
    word.
  }

  iClear "Herrs".
  wp_forBreak_cond.
  iNamed "Hloop".
  wp_pures.
  wp_load.
  wp_apply (wp_slice_len).

  rewrite replicate_length in Herrs_sz.
  rewrite -Hclerks_sz in Herrs_sz.
  rewrite app_nil_r in Hlen.

  clear i Hi_ineq Heqb0.
  wp_if_destruct.
  { (* one loop iteration *)
    wp_pures.
    wp_load.
    unfold SliceGet.
    wp_call.
    iDestruct (big_sepS_elem_of_acc _ _ i0 with "Hwg_post") as "[HH _]".
    { set_solver. }

    assert (int.nat i0 < int.nat errs_sl.(Slice.sz)) by word.

    iDestruct "HH" as "[%Hbad|HH]".
    { exfalso.
      rewrite -Herrs_sz in H.
      word.
    }
    iDestruct "HH" as (??) "(%HbackupLookup & Herr2 & Hpost)".
    wp_apply (wp_slice_ptr).
    wp_pure1.
    iEval (simpl) in "Herr2".
    iMod (readonly_load with "Herr2") as (?) "Herr3".
    wp_load.
    wp_pures.
    destruct (bool_decide (_)) as [] eqn:Herr; wp_pures.
    {
      rewrite bool_decide_eq_true in Herr.
      replace (err0) with (U64 0%Z) by naive_solver.
      wp_pures.
      wp_load; wp_store.
      iLeft.
      iModIntro.
      iSplitL ""; first done.
      iFrame "∗".
      iExists _, _.
      iFrame "Hj Herr".
      iSplitL "".
      { iPureIntro. word. }
      iModIntro.
      destruct (decide (err = 0%Z)).
      {
        iIntros.
        assert (int.nat k < int.nat i0 ∨ int.nat k = int.nat i0) as [|].
        {
          replace (int.nat (word.add i0 1%Z)) with (int.nat i0 + 1) in * by word.
          word.
        }
        {
          by iApply "Hrest".
        }
        {
          destruct (decide (_)); last by exfalso.
          replace (γsrv') with (γsrv); last first.
          {
            replace (int.nat i0) with (int.nat k) in * by word.
            naive_solver.
          }
          iDestruct "Hpost" as "#$".
        }
      }
      {
        done.
      }
    }
    {
      wp_store.
      wp_pures.
      wp_load; wp_store.
      iLeft.
      iModIntro.
      iSplitL ""; first done.
      iFrame "∗".
      iExists _, _.
      iFrame "Hj Herr".
      destruct (decide (err0 = _)).
      { exfalso. naive_solver. }
      iPureIntro.
      split; last done.
      word.
    }
  }
  iRight.
  iModIntro.
  iSplitL ""; first done.
  wp_pures.
  wp_load.
  wp_pures.
  (* FIXME: *)
  (* End copy/paste from apply_proof *)

  wp_if_destruct.
  { (* got some error *)
    wp_load.
    iApply "HΦ".
    done.
  }

  (* no errors *)
  replace (int.nat i0) with (length clerks); last first.
  { word. }

  destruct (decide (_)); last first.
  { exfalso. done. }

  iMod (own_update with "Hconf_unset") as "Hconf_prop".
  {
    apply singleton_update.
    apply cmra_update_exclusive.
    instantiate (1:=(to_dfrac_agree (DfracOwn 1) ((Some server_γs) : (leibnizO _)))).
    done.
  }
  iMod (own_update with "Hconf_prop") as "Hconf_prop".
  {
    apply singleton_update.
    apply dfrac_agree_persist.
  }
  iDestruct "Hconf_prop" as "#Hconf_prop".

  wp_bind (Clerk__WriteConfig _ _ _).
  iApply (wp_frame_wand with "[HΦ Hconf_sl Hprop Hclerks_sl]").
  { iNamedAccu. }
  iDestruct (big_sepL2_length with "Hhost") as %Hserver_len_eq.

  assert (length servers > 0) as Hserver_nz.
  {
    assert (length servers ≠ 0 ∨ length servers = 0) as [|Hbad] by word.
    { word. }
    {
      exfalso.
      rewrite Hbad in Hservers_sz.
      apply u64_nat_0 in Hservers_sz.
      rewrite Hservers_sz in Heqb.
      done.
    }
  }

  wp_apply (wp_Clerk__WriteConfig2 with "Hck Hservers_sl [$Hconf_prop] Hhost").
  {
    iPureIntro.
    word.
  }
  {
    iIntros (?) "%Hlookup".
    apply elem_of_list_lookup_1 in Hlookup as [i Hlookup].
    iDestruct (big_sepS_elem_of_acc _ _ (U64 i) with "Hwg_post") as "[HH _]".
    { set_solver. }

    assert (i < length server_γs).
    {
      apply lookup_lt_is_Some_1.
      eexists. done.
    }
    replace (length clerks) with (length server_γs) in * by word.
    assert (int.nat i = i) as Hi.
    { word. }

    iDestruct "HH" as "[%Hbad|HP]".
    {
      exfalso.
      word.
    }
    unfold P.
    iDestruct "HP" as (??) "(%Hlookup2 & _ & Hpost)".
    replace (γsrv') with (γsrv); last first.
    {
      rewrite Hi in Hlookup2.
      rewrite Hlookup in Hlookup2.
      by inversion Hlookup2.
    }
    iSpecialize ("Hrest" $! i γsrv with "[%] [%]").
    { word. }
    { rewrite Hi. done. }
    iFrame "Hrest".
  }
  iModIntro.
  iIntros (err) "Hpost Hservers_sl".
  iNamed 1.

  wp_pures.
  wp_if_destruct.
  { (* WriteConfig failed *)
    iApply "HΦ". done.
  }
  (* WriteConfig succeeded *)
  destruct (decide (_)); last first.
  { exfalso. done. }
  iDestruct "Hpost" as "#Hconf".
  wp_apply (wp_allocStruct).
  { eauto. }
  clear args.
  iIntros (args) "Hargs".
  assert (0 < length clerks) as Hclerk_lookup.
  {
    word.
  }
  apply list_lookup_lt in Hclerk_lookup as [primaryCk Hclerk_lookup].

  wp_apply (wp_SliceGet with "[$Hclerks_sl]").
  { done. }
  iIntros "Hclerks_sl".
  wp_pures.

  iDestruct (big_sepL2_lookup_1_some with "Hclerks_is") as %[γsrv Hlookup2].
  { done. }
  iDestruct (big_sepL2_lookup_acc with "Hclerks_is") as "[HprimaryCk _]".
  { done. }
  { done. }

  iDestruct (struct_fields_split with "Hargs") as "HH".
  iNamed "HH".

  (* Get a list of γs just for backups *)
  destruct (server_γs).
  {
    exfalso.
    rewrite lookup_take /= in Hlookup2; last first.
    { word. }
    done.
  }
  replace (p) with (γsrv) in *; last first.
  {
    rewrite lookup_take /= in Hlookup2; last first.
    { word. }
    naive_solver.
  }
  iAssert (|={⊤}=> become_primary_escrow γ γsrv epoch σ)%I with "[Hprop]" as ">#Hprimary_escrow".
  {
    iMod (inv_alloc with "[Hprop]") as "$".
    {
      iNext.
      iLeft.
      iFrame "Hprop Hprop_facts2 Hinit".
    }
    done.
  }

  wp_apply (wp_Clerk__BecomePrimary with "[$HprimaryCk Hconf Hhost Epoch Replicas Hservers_sl]").
  {

    iFrame.
    instantiate (1:=(pb_marshal_proof.BecomePrimaryArgs.mkC _ _)).
    simpl.
    iFrame "#".
    iSplitR.
    {
      iDestruct ("Hrest" with "[%] [%]") as "H".
      { instantiate (1:=0). word. }
      { rewrite lookup_take in Hlookup2.
        { done. }
        word.
      }
      iFrame "H".
    }
    iSplitR.
    {
      iApply big_sepL2_forall.
      instantiate (1:=servers).
      iSplitL; first done.
      iIntros.
      iDestruct (big_sepL2_lookup_acc with "Hhost") as "[$ HH]".
      { done. }
      { done. }
      iApply "Hrest"; last first.
      {
        iPureIntro.
        instantiate (1:=k).
        replace (int.nat k) with (k).
        { done. }
        assert (k < length servers).
        { apply lookup_lt_Some in H. done. }
        word.
      }
      { iPureIntro.
        apply lookup_lt_Some in H.
        replace (int.nat k) with (k).
        { rewrite Hlen. done. }
        assert (k < length servers). (* FIXME: why do I have to assert this when it's already in context? *)
        { done. }
        word.
      }
    }
    {
      iExists _.
      iFrame.
    }
  }
  iIntros.
  wp_pures.
  iApply "HΦ".
  done.
Qed.

End admin_proof.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import Setoid.
Require Import ZArith.
Require Import Psatz.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.DePoolFunc.
Require Import depoolContract.DePoolConsts.

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.

Require Import depoolContract.Lib.CommonStateProofs.

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope solidity_scope.
Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Module ProofHelpers (dc : DePoolConstsTypesSig XTypesSig StateMonadSig).
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig dc.
Import dc.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

(* Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100.
 *)

Ltac pr_numgoals := let n := numgoals in idtac "There are" n "goals".

Lemma if_fromValueValue: forall X (b: bool) (x y: XValueValue X),
fromValueValue (if b then x else y) = if b then (fromValueValue x) else (fromValueValue y).
Proof.
  intros.
  destruct b; auto.
Qed.

Lemma ifSimpleState: forall X (b: bool) (f g: Ledger -> X * Ledger),
(if b then SimpleState f else SimpleState g ) =
SimpleState (if b then f else  g).
Proof.
  intros. destruct b; auto.
Qed.

Lemma ifFunApply: forall X (b: bool) (f g: Ledger -> X * Ledger) l,
(if b then f else  g ) l =
(if b then f l else g l).
Proof.
  intros. destruct b; auto.
Qed.

Tactic Notation "destructLedger" constr(l) :=
let Ledger_ι_ValidatorBase := fresh "Ledger_ι_ValidatorBase" in
let Ledger_ι_ProxyBase := fresh "Ledger_ι_ProxyBase" in
let Ledger_ι_ParticipantBase := fresh "Ledger_ι_ParticipantBase" in
let Ledger_ι_DePoolProxyContract := fresh "Ledger_ι_DePoolProxyContract" in
let Ledger_ι_RoundsBase := fresh "Ledger_ι_RoundsBase" in
let Ledger_ι_DePoolContract := fresh "Ledger_ι_DePoolContract" in
let Ledger_ι_VMState := fresh "Ledger_ι_VMState" in
let Ledger_ι_LocalState := fresh "Ledger_ι_LocalState" in

destruct l as
 [Ledger_ι_ValidatorBase Ledger_ι_ProxyBase Ledger_ι_ParticipantBase
 Ledger_ι_DePoolProxyContract
Ledger_ι_RoundsBase Ledger_ι_DePoolContract
Ledger_ι_VMState Ledger_ι_LocalState];

destruct Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ParticipantBase,
Ledger_ι_DePoolProxyContract,
Ledger_ι_RoundsBase, Ledger_ι_DePoolContract,
Ledger_ι_VMState, Ledger_ι_LocalState.

Tactic Notation "destructFunction0" constr(f) :=
match goal with
 | |- ?G => match G with
            | context [f] =>
                  let m := fresh "m" in
                  let p := fresh "p" in
                  remember f  as m;
                  destruct m as (p) ;
                  let r := fresh "r" in
                  match goal with
                    | |- ?G1 => match G1 with
                                 | context [p ?l] => remember (p l) as r;
                                                     let x := fresh "x" in
                                                     let l := fresh "l" in
                                                     destruct r as [x l]
                                end
                  end
            end
end.

Tactic Notation "destructFunction1" constr(f) :=
 match goal with
  | |- ?G => match G with
             | context [f ?a] =>
                   let m := fresh "m" in
                   let p := fresh "p" in
                   remember (f a) as m;
                   destruct m as (p) ;
                   let r := fresh "r" in
                   match goal with
                     | |- ?G1 => match G1 with
                                  | context [p ?l] => remember (p l) as r;
                                                      let x := fresh "x" in
                                                      let l := fresh "l" in
                                                      destruct r as [x l]
                                 end
                   end
             end
end.

Tactic Notation "destructFunction2" constr(f) :=
 match goal with
  | |- ?G => match G with
             | context [f ?a ?b] =>
                   let m := fresh "m" in
                   let p := fresh "p" in
                   remember (f a b) as m;
                   destruct m as (p) ;
                   let r := fresh "r" in
                   match goal with
                     | |- ?G1 => match G1 with
                                  | context [p ?l] => remember (p l) as r;
                                                      let x := fresh "x" in
                                                      let l := fresh "l" in
                                                      destruct r as [x l]
                                 end
                   end
             end
end.

Tactic Notation "destructFunction3" constr(f) :=
 match goal with
  | |- ?G => match G with
             | context [f ?a ?b ?c] =>
                   let m := fresh "m" in
                   let p := fresh "p" in
                   remember (f a b c) as m;
                   destruct m as (p) ;
                   let r := fresh "r" in
                   match goal with
                     | |- ?G1 => match G1 with
                                  | context [p ?l] => remember (p l) as r;
                                                      let x := fresh "x" in
                                                      let l := fresh "l" in
                                                      destruct r as [x l]
                                 end
                   end
             end
end.

Tactic Notation "destructFunction4" constr(f) :=
 match goal with
  | |- ?G => match G with
             | context [f ?a ?b ?c ?d] =>
                   let m := fresh "m" in
                   let p := fresh "p" in
                   remember (f a b c d) as m;
                   destruct m as (p) ;
                   let r := fresh "r" in
                   match goal with
                     | |- ?G1 => match G1 with
                                  | context [p ?l] => remember (p l) as r;
                                                      let x := fresh "x" in
                                                      let l := fresh "l" in
                                                      destruct r as [x l]
                                 end
                   end
             end
end.

Tactic Notation "destructFunction5" constr(f) :=
 match goal with
  | |- ?G => match G with
             | context [f ?a ?b ?c ?d ?e] =>
                   let m := fresh "m" in
                   let p := fresh "p" in
                   remember (f a b c d e) as m;
                   destruct m as (p) ;
                   let r := fresh "r" in
                   match goal with
                     | |- ?G1 => match G1 with
                                  | context [p ?l] => remember (p l) as r;
                                                      let x := fresh "x" in
                                                      let l := fresh "l" in
                                                      destruct r as [x l]
                                 end
                   end
             end
end.

Tactic Notation "destructFunction6" constr(f) :=
 match goal with
  | |- ?G => match G with
             | context [f ?a ?b ?c ?d ?e ?g] =>
                   let m := fresh "m" in
                   let p := fresh "p" in
                   remember (f a b c d e g) as m;
                   destruct m as (p) ;
                   let r := fresh "r" in
                   match goal with
                     | |- ?G1 => match G1 with
                                  | context [p ?l] => remember (p l) as r;
                                                      let x := fresh "x" in
                                                      let l := fresh "l" in
                                                      destruct r as [x l]
                                 end
                   end
             end
end.

Tactic Notation "destructFunction7" constr(f) :=
 match goal with
  | |- ?G => match G with
             | context [f ?a ?b ?c ?d ?e ?g ?h] =>
                   let m := fresh "m" in
                   let p := fresh "p" in
                   remember (f a b c d e g h) as m;
                   destruct m as (p) ;
                   let r := fresh "r" in
                   match goal with
                     | |- ?G1 => match G1 with
                                  | context [p ?l] => remember (p l) as r;
                                                      let x := fresh "x" in
                                                      let l := fresh "l" in
                                                      destruct r as [x l]
                                 end
                   end
             end
end.

Tactic Notation "destructFunction8" constr(f) :=
 match goal with
  | |- ?G => match G with
             | context [f ?a ?b ?c ?d ?e ?g ?h ?i] =>
                   let m := fresh "m" in
                   let p := fresh "p" in
                   remember (f a b c d e g h i) as m;
                   destruct m as (p) ;
                   let r := fresh "r" in
                   match goal with
                     | |- ?G1 => match G1 with
                                  | context [p ?l] => remember (p l) as r;
                                                      let x := fresh "x" in
                                                      let l := fresh "l" in
                                                      destruct r as [x l]
                                 end
                   end
             end
end.

Tactic Notation "destructIf_solve" :=

time match goal with
      | |- ?G =>
        match G with
        | context [if ?b then _ else _] =>  idtac "if..." b;
                                            repeat rewrite ifSimpleState ;
                                            repeat rewrite ifFunApply ;
                                            case_eq b ;
                                            simpl ;
                                            intros
        | _ =>  idtac "solving..." G;
                tryif solve [auto] then idtac "solved" else idtac "not solved"
        end
end.

Tactic Notation "destructIf_solve2" :=

time match goal with
      | |- ?G =>
        match G with
        | context [if ?b then _ else _] =>  idtac "if..." b;
                                            repeat rewrite ifSimpleState ;
                                            repeat rewrite ifFunApply ;
                                            match goal with
                                            | H : b = _ |- _ => first [ (idtac "rewriting ->" ; rewrite H) | (idtac "destructing" ; case_eq b ; (* simpl ; *) intros) ]
                                            | H : _ = b |- _ => first [ (idtac "rewriting <-" ; rewrite <- H) | (idtac "destructing" ; case_eq b ; (* simpl ; *) intros) ]
                                            | _ => idtac "destructing" ; case_eq b ; (* simpl ; *) intros
                                            end
        | _ =>  idtac "solving..." G;
                tryif solve [auto] then idtac "solved" else idtac "not solved"
        end
end.

(* repeat time match goal with
  | H : ?P |- _ =>
    match P with
    | context [ (if ?b then _ else _ ) = _ ] =>  let HH:=fresh"HH" in idtac "if..." b; case_eq b ; intros HH; rewrite HH in H ; try discriminate; try congruence

    end
  end. *)
End ProofHelpers.


(* Interpret a program according to the semantics of the ir *)

Require Export List.
Require Export Coqlib.
Require Export Maps.
Require Export String.
Require Export common.
Require Export specIR.

(* Interpreting operands *)
Definition eval_op (o:op) (rm:reg_map): res value :=
  match o with
  | Reg r => try_op (PTree.get r rm) "Unassigned register"
  | Cst n => OK n
  end.

(* Interpreting Binary operations *)
Definition eval_binop_values (bo:bin_operation) (v1:value) (v2:value) : res value :=
  match v1 with
  | Vint vi1 =>
    match v2 with
    | Vint vi2 =>
      match bo with
      | Plus => OK (Vint (vi1 + vi2))
      | Minus => OK (Vint (vi1 - vi2))
      | Mult => OK (Vint (vi1 * vi2))
      | Gt => OK (bool_to_val(Z.gtb vi1 vi2))
      | Lt => OK (bool_to_val(Z.ltb vi1 vi2))
      | Geq => OK (bool_to_val(Z.geb vi1 vi2))
      | Leq => OK (bool_to_val(Z.leb vi1 vi2))
      | Eq => OK (bool_to_val(Z.eqb vi1 vi2))
      end
    end
  end.

Definition eval_binop (bo:bin_operation) (o1:op) (o2:op) (rm:reg_map): res value :=
  do v1 <- eval_op o1 rm;
    do v2 <- eval_op o2 rm;
    eval_binop_values bo v1 v2.

(* Interpreting Unary operations *)
Definition eval_unop_value (u:un_operation) (v:value): res value :=
  match u with
  | UMinus => match v with
             | Vint vi =>  OK (Vint (-vi))
             end
  | Neg => match v with
          | Vint vi => OK (Vint (int_neg vi))
          end
  | Assign => OK v
  end.

Definition eval_unop (u:un_operation) (o:op) (rm:reg_map): res value :=
  do v <- eval_op o rm;
    eval_unop_value u v.

(* Interpreting expressions *)
Definition eval_expr (e:expr) (rm:reg_map): res value :=
  match e with
  | Binexpr binop o1 o2 => eval_binop binop o1 o2 rm
  | Unexpr unop o => eval_unop unop o rm
  end.

(* Checks if a list of expressions are all true (!= 0) *)
Fixpoint eval_list_expr (le:list expr) (rm:reg_map): res bool :=
  match le with
  | nil => OK true
  | ex::le' => do v <- eval_expr ex rm;
                 match v with
                 | Vint 0 => OK false
                 | Vint _ => eval_list_expr le' rm
                 end
  end.

(* In case there is an error in the evaluation of the guard of an Assume, we want to deoptimize *)
Definition safe_eval_list_expr (le:list expr) (rm:reg_map): bool :=
  match eval_list_expr le rm with
  | OK b => b
  | Error _ => false             (* ignore the errors in guard evaluation *)
  end.

(* Interprets a list of expressions (arguments) *)
(* lv is the list of values already evaluated *)
Fixpoint eval_list (le:list expr) (rm:reg_map): res (list value) :=
  match le with
  | nil => OK nil
  | ex::le' => do v <- eval_expr ex rm;
                 do lv <- eval_list le' rm;
                 OK (v::lv)
  end.

(* Initialize the register map when calling a function *)
Fixpoint init_regs (valist:list value) (params:list reg): res reg_map :=
  match valist with
  | nil => match params with
           | nil => OK empty_regmap
           | _ => Error "Not enough arguments"
           end
  | val::valist' => match params with
                   | nil => Error "Too many arguments"
                   | par::params' => do rm' <- init_regs valist' params';
                                       OK (rm' # par <- val)
                    end
  end.

(* Updates the reg_map [rm] with the binding of [ml] *)
(* rmeval is the original regmap, to evaluate all ops *)
Fixpoint update_movelist' (ml:movelist) (rmeval:reg_map) (rm:reg_map) : res reg_map :=
  match ml with
  | nil => OK rm
  | (r,e)::ml' => do v <- eval_expr e rmeval;
                  do rm' <- update_movelist' ml' rmeval rm;
                  OK (rm' # r <- v)
  end.

Definition update_movelist (ml:movelist) (rm:reg_map) : res reg_map :=
  update_movelist' ml rm rm.

(* Creating a new Register Mapping from a Varmap *)
Fixpoint update_regmap (vm:varmap) (rm:reg_map): res reg_map :=
  match vm with
  | nil => OK empty_regmap
  | (r,e)::vm' =>
    do v <- eval_expr e rm;
      do rm' <- update_regmap vm' rm;
      OK (rm' # r <- v)
  end.

(* [synthesize_frame p rm sl]: the stack synthesized by the list [sl] under [rm] and [p] *)
Fixpoint synthesize_frame (p:program) (rm:reg_map) (sl:list synth_frame): res stack :=
  match sl with
  | nil => OK nil
  | ((f,l),r,vm)::sl' =>
    do rmupdate <- update_regmap vm rm;
      do version <- try_op (find_base_version f p) "The version for the new stackframe does not exist";
      do stack <- synthesize_frame p rm sl';
      OK ((Stackframe r version l rmupdate)::stack)
  end.

(* Returning states without any trace *)
Definition OK0 {A:Type} (s:A) := OK (s,E0).

Definition check_nil {X:Type} (l:list X) : res unit :=
  match l with
  | nil => OK tt
  | _ => Error "The main function should not require any arguments"
  end.

(* Compute the initial state of a program *)
Definition initial_state (p:program) : res state :=
  do f <- try_op (find_function (prog_main p) p) "Can't find main function of the program";
    do check <- check_nil (fn_params f);
    do v <- OK (current_version f);
    OK (State nil v (ver_entry v) empty_regmap initial_memory).

(** * Internal interpreter state *)
(* The internal state of the interpreter. Does not need the stack, as it stops upon Call, Return and Deopt *)
Inductive interpreter_state: Type :=
| Int_State: version -> label -> reg_map -> interpreter_state
| Int_Final: value -> interpreter_state.

(** * Synchronization states  *)
(* The output of the interpreter and native calls *)
Inductive synchro_state:=
| S_Call: fun_id -> list value -> option stackframe -> synchro_state
| S_Return: value -> synchro_state
| S_Deopt: deopt_target -> (list stackframe) -> reg_map -> synchro_state
| Halt: interpreter_state -> synchro_state.
(* The stack returned in the Deopt case is the new synthesized stackframes *)
(* Halt allows the interpreter to go back to the JIT even when a synchro points hasn't been reached *)
(* The interpreter synthesizes its own stackframe on a call *)

(* Returning states without any trace, nor stackframe *)
Definition OK_ (sm:(synchro_state * mem_state)) : res (synchro_state * mem_state * trace) :=
  OK (sm,E0).

(** * Internal interpreter step  *)
Definition int_step (p:program) (ins:interpreter_state) (ms:mem_state): res (synchro_state * mem_state * trace) :=
  match ins with
  | Int_State v pc rm =>
    do instr <- try_op ((ver_code v) ! pc) "No code to execute";
      match instr with
      | Nop oh next => OK_ (Halt (Int_State v next rm), ms)

      | Op expr reg next =>
        do val <- eval_expr expr rm;
          OK_ (Halt (Int_State v next (rm # reg <- val)), ms)

      | Move ml next =>
        do newrm <- update_movelist ml rm;
          OK_ (Halt (Int_State v next newrm), ms)

      | Cond ex iftrue iffalse =>
        do val <- eval_expr ex rm;
          do nextlbl <- OK (pc_cond val iftrue iffalse);
          OK_ (Halt (Int_State v nextlbl rm), ms)

      | Printexpr ex next =>
        do printval <- eval_expr ex rm;
          OK (Halt (Int_State v next rm), ms, Valprint printval::E0)

      | Printstring str next =>
        OK (Halt (Int_State v next rm), ms, Stringprint str::E0)

      | Store ex1 ex2 next =>
        do val <- eval_expr ex1 rm;
          do addr <- eval_expr ex2 rm;
          do newms <- try_op (Store_ ms addr val) "Store_ failed";
          OK_ (Halt (Int_State v next rm), newms)

      | Load ex reg next =>
        do addr <- eval_expr ex rm;
          do val <- try_op (Load_ ms addr) "Load_ failed";
          OK_ (Halt (Int_State v next (rm # reg <- val)), ms)

      | Call fid args retreg next =>
        do valist <- eval_list args rm;
          (* to make sure the result can be forged *)
          do func <- try_op (find_function fid p) "Function doesn't exist";
          do newrm <- init_regs valist (fn_params func);
          OK (S_Call fid valist (Some (Stackframe retreg v next rm)), ms, E0)

      | IReturn retex =>
        do retval <- eval_expr retex rm;
          OK_ (S_Return retval, ms)

      | Assume g (fa,la) vm sl next =>
        do assertion <- eval_list_expr g rm;
          match assertion with
          | true => OK_ (Halt (Int_State v next rm), ms)
          | false =>
            do synth <- synthesize_frame p rm sl;
              do newrm <- update_regmap vm rm;
              (* to make sure the result can be forged *)
              do newver <- try_op (find_base_version fa p) "The version to deoptimize to does not exist";
              OK_ (S_Deopt (fa,la) synth newrm, ms)
          end

      | Framestate (fa,la) vm sl next =>
        do findf <- try_op (find_base_version fa p) "No deopt conditions";
        do synth <- synthesize_frame p rm sl;
        do newrm <- update_regmap vm rm;
        OK_ (Halt (Int_State v next rm), ms)
      (* we give Framestate a behavior, just to make progress preservation proof easier *)
      (* Actually, since Framestates are lowered, the interpreter will never see them *)

      | Fail s => Error s        (* Fail should make the interpreter crash *)

      end
  | Int_Final retval =>
    Error "Called interpreter on Final"
  end.

(** * Interpreter loop  *)

(** Safe interpreter step  *)
(*  version of the interpreter step that returns to the JIT when seeing an error *)
(* The bool tells you if you should keep on interpreting if you still have fuel *)
(* It also returns just after an event is outputed *)
Definition safe_int_step p ins ms : (synchro_state * mem_state * trace * bool) :=
  match (int_step p ins ms) with
  | OK (synchro, newms, t) => match t with
                             | nil => (synchro, newms, t, true)
                             | _ => (synchro, newms, t, false) (* stops after outputs *)
                             end
  | Error _ => (Halt ins, ms, E0, false) (* stops before errors *)
  end.

(* looping the safe_step and halting just before an error if there is one *)
Fixpoint interpreter_safe_loop (fuel: nat) (p:program) (ins:interpreter_state) (ms:mem_state): (synchro_state * mem_state * trace) :=
  match fuel with
  | O => (Halt ins, ms, E0)
  | S fuel' =>
    let '(synchro, newms, t, b) := safe_int_step p ins ms in
    match b with
    | false => (synchro, newms, t) (* the interpreter has encountered an error, time to return to the JIT *)
    | true =>
      match synchro with
      | Halt int_state => let '(synchro', newms', t') := interpreter_safe_loop fuel' p int_state newms in
                         (synchro', newms', t++t')
      | _ => (synchro, newms, t)
      end
    end
  end.

Definition interpreter_loop (fuel: nat) (p:program) (ins:interpreter_state) (ms:mem_state): res (synchro_state * mem_state * trace) :=
  do (synchro, newms, t) <- int_step p ins ms; (* first step may fail *)
    match t with
    | nil =>
      match synchro with
      | Halt int_state =>           (* we may call the safe loop to go a bit further *)
        let '(synchro', newms', t') := interpreter_safe_loop fuel p int_state newms in
        OK (synchro', newms', t ++ t')
      | _ => OK (synchro, newms, t) (* we reached a synchronization point *)
      end
    | _ => OK (synchro, newms, t) (* we outputed something in the very first step *)
    end.


Set Implicit Arguments.

Require Import Platform.Facade.CompileSafe.
Require Import Platform.Facade.CompileRunsTo.
Require Import Platform.Facade.CompileDFacadeCorrect.

Section ADTValue.

  Variable ADTValue : Type.

  Require Import Platform.Facade.DFacade.

  Notation State := (@State ADTValue).
  Notation Env := (@Env ADTValue).
  Notation Value := (@Value ADTValue).
  Notation FuncSpec := (@FuncSpec ADTValue).
  Notation RunsTo := (@RunsTo ADTValue).
  Notation Safe := (@Safe ADTValue).

  Require Import Bedrock.Memory.
  Require Import Platform.Cito.GLabel.

  Notation CState := (@Semantics.State ADTValue).
  Notation CCallee := (@Semantics.Callee ADTValue).
  Notation CInternal := (@Semantics.Internal ADTValue).
  Notation CRunsTo := (@Semantics.RunsTo ADTValue).
  Notation CEnv := ((glabel -> option W) * (W -> option CCallee))%type.

  Notation FEnv := (@Facade.Env ADTValue).

  Require Import Platform.Cito.GLabelMap.

  Notation compile s := (Compile.compile (compile s)).

  Notation compile_spec s := (CompileRunsTo.compile_spec (@CompileDFacadeCorrect.compile_spec ADTValue s)).

  Require Import Platform.Cito.Label2Word Platform.Cito.Label2WordFacts.

  Require Import Platform.Cito.GLabelMap.
  Import GLabelMap.
  Require Import Platform.Cito.GLabelMapFacts.
  Import FMapNotations.
  Local Open Scope fmap_scope.

  Definition cenv_impls_env (cenv : CEnv) (env : Env) :=
    (forall lbl spec,
      GLabelMap.find lbl env = Some spec ->
      exists w,
        fst cenv lbl = Some w /\
        snd cenv w = Some (compile_spec spec)) /\
    stn_injective (fun k => In k env) (fst cenv).

  Require Import Bedrock.StringSet.

  Require Import Platform.Cito.Option.

  Require Import Platform.Cito.GeneralTactics.
  Require Import Platform.Cito.GeneralTactics3.
  Require Import Platform.Cito.GeneralTactics4.
  Require Import Platform.Cito.GeneralTactics5.

  Lemma cenv_impls_env_fenv cenv env : cenv_impls_env cenv env -> exists fenv, CompileRunsTo.cenv_impls_env cenv fenv /\ fenv_impls_env fenv env.
  Proof.
    intros [H Hinj].
    set (fenv :=
           {|
             Label2Word := fst cenv;
             Word2Spec w := option_map (@CompileDFacadeCorrect.compile_spec _) (find_by_word (fst cenv) (elements env) w)
           |} : FEnv).
    unfold cenv_impls_env in *.
    unfold CompileRunsTo.cenv_impls_env in *.
    unfold fenv_impls_env in *.
    exists fenv.
    unfold_all; simpl in *.
    split.
    {
      split.
      {
        eauto.
      }
      {
        intros w fspec Hfw.
        eapply option_map_some_elim in Hfw.
        destruct Hfw as [spec [Hfw ?]].
        subst.
        eapply find_by_word_elements_elim in Hfw.
        destruct Hfw as [lbl [Hflbl Hlblw]].
        eapply H in Hflbl.
        destruct Hflbl as [w' [Hlblw' Hw'spec]].
        unif w'.
        eauto.
      }
    }
    {
      intros lbl spec Hflbl.
      copy_as Hflbl Hflbl'.
      eapply H in Hflbl.
      destruct Hflbl as [w [Hlblw Hwspec]].
      exists w.
      split; eauto.
      eapply option_map_some_intro; eauto.
      eapply find_by_word_elements_intro; eauto.
    }
  Qed.

  Require Import Platform.Cito.StringMap.
  Import StringMap.
  Require Import Platform.Cito.StringMapFacts.
  Import FMapNotations.
  Local Open Scope fmap_scope.

  Notation equivf := (equiv (StringSet.singleton fun_ptr_varname)).
  Infix "===" := equivf (at level 70).

  Require Import Coq.Strings.String.

  Require Import Platform.Facade.NameDecoration.
  Require Import Platform.Facade.FacadeFacts Platform.Facade.DFacadeFacts.

  Existing Instance equiv_rel_Symmetric.
  Existing Instance equiv_rel_Transitive.

  Lemma equiv_related (st st' : State) cst : related st cst -> st' === st -> find fun_ptr_varname st' = None -> related st' cst.
  Proof.
    intros Hr Heqv Hfpv.
    unfold related.
    split.
    {
      intros k v Hfk.
      destruct (string_dec k fun_ptr_varname) as [Heqk | Hnek].
      {
        subst.
        rewrite Hfk in Hfpv; discriminate.
      }
      erewrite find_equiv_fpv in Hfk; eauto.
      eapply Hr in Hfk.
      eauto.
    }
    intros p a Hpa.
    eapply Hr in Hpa.
    destruct Hpa as [x [[Hxp Hxa] Huni]].
    destruct (string_dec x fun_ptr_varname) as [Heqx | Hnex].
    {
      subst.
      contradict Hxa.
      eapply not_find_fpv_adt; eauto.
    }
    exists x.
    split.
    {
      split; eauto.
      erewrite find_equiv_fpv; eauto.
    }
    intros x' [Hx'p Hx'a].
    destruct (string_dec x' fun_ptr_varname) as [Heqx' | Hnex'].
    {
      subst.
      contradict Hx'a.
      symmetry in Heqv.
      eapply not_find_fpv_adt; eauto.
    }
    erewrite find_equiv_fpv in Hx'a; eauto.
  Qed.

  Require Import Platform.Cito.StringSetFacts.
  Import StringSet.
  Require Import Platform.Cito.WordMap.
  Import WordMap.
  Require Import Platform.Cito.WordMapFacts.
  Import FMapNotations.
  Local Open Scope fmap_scope.

  Theorem compile_runsto t t_env t_st t_st' :
    CRunsTo t_env t t_st t_st' ->
    forall s,
      t = compile s ->
      is_syntax_ok s = true ->
      (* h1 : the heap portion that this program is allowed to change *)
      forall h1,
        h1 <= snd t_st ->
        forall s_st,
          related s_st (fst t_st, h1) ->
          StringMap.find fun_ptr_varname s_st = None ->
          forall s_env,
            cenv_impls_env t_env s_env ->
            Safe s_env s s_st ->
            exists s_st',
              RunsTo s_env s s_st s_st' /\
              (* h2 : the frame heap (the outside portion that won't be touched by this program *)
              let h2 := snd t_st - h1 in
              (* the frame heap will be intacked in the final state *)
              h2 <= snd t_st' /\
              (* main result: final source-level and target level states are related *)
              related s_st' (fst t_st', snd t_st' - h2).
  Proof.
    intros Hcrt s Hcomp Hsyn h1 Hsm s_st Hr Hnotmp s_env Henv Hsf.
    eapply cenv_impls_env_fenv in Henv.
    destruct Henv as [fenv [Htenv Hfenv]].
    eapply CompileRunsTo.compile_runsto in Hcrt; eauto.
    - destruct Hcrt as [s_st' [Hfrt Hsst']]; simpl in *.
      destruct Hsst' as [Hsm' [Hnoass [Hnocollide Hr']]].
      eapply CompileDFacadeCorrect.compile_runsto in Hfrt; eauto.
      + destruct Hfrt as [d_st' [Hdrt Heqv]].
        exists d_st'.
        repeat try_split.
        * eauto.
        * eauto.
        * eapply equiv_related; eauto.
          eapply not_free_vars_no_change in Hdrt; eauto.
          erewrite Hdrt; eauto.
          eapply syntax_ok_fptr_not_fv; eauto.
      + eapply equiv_refl; eauto.
        eapply find_none_not_mapsto_adt; eauto.
    - eapply CompileDFacadeCorrect.compile_safe; eauto.
      eapply equiv_refl; eauto.
      eapply find_none_not_mapsto_adt; eauto.
  Qed.

  Notation CSafe := (@Semantics.Safe ADTValue).

  Theorem compile_safe s_env s s_st :
  Safe s_env s s_st ->
  is_syntax_ok s = true ->
  StringMap.find fun_ptr_varname s_st = None ->
  (* h1 : the heap portion that this program is allowed to change *)
  forall vs h h1,
    h1 <= h ->
    related s_st (vs, h1) ->
    forall t_env t t_st,
      cenv_impls_env t_env s_env ->
      t = compile s ->
      t_st = (vs, h) ->
      CSafe t_env t t_st.
  Proof.
    simpl; intros Hsfs Hsyn Hsstok vs h h1 Hsm Hr t_env t t_st Henv Ht Htst.
    subst.
    eapply cenv_impls_env_fenv in Henv.
    destruct Henv as [fenv [Htenv Hfenv]].
    eapply CompileSafe.compile_safe; eauto.
    eapply CompileDFacadeCorrect.compile_safe; eauto.
    eapply equiv_refl.
    eapply find_none_not_mapsto_adt; eauto.
  Qed.

End ADTValue.


From iris.algebra Require Import auth agree excl gmap frac.
From iris.proofmode Require Import tactics.
From iris.base_logic Require Import invariants.
From iris.program_logic Require Import adequacy.
Require Import Eqdep_dec.

From cap_machine Require Import
     stdpp_extra iris_extra
     logrel_binary fundamental_binary linking.
From cap_machine.binary_model Require Import
     macros_binary confidentiality region_invariants_binary_allocation.
From cap_machine.examples Require Import
     disjoint_regions_tactics.

From cap_machine.binary_model Require Import
     confidentiality_adequacy.

Definition is_initial_configuration_left `{memory_layout} c_adv prog :=
  ∃ stack_init p1, is_machine_context c_adv comp1 p1
                   ∧ (b_stk + length stack_init)%a = Some e_stk
                   ∧ prog = initial_state_stk b_stk e_stk stack_init p1.

Definition is_initial_configuration_right `{memory_layout} c_adv prog :=
  ∃ stack_init p2, is_machine_context c_adv comp2 p2
                   ∧ (b_stk + length stack_init)%a = Some e_stk
                   ∧ prog = initial_state_stk b_stk e_stk stack_init p2.

Definition soundness_binaryΣ : gFunctors :=
  #[GFunctor (authR cfgUR); invΣ; gen_heapΣ Addr Word;
   gen_heapΣ RegName Word;
   na_invΣ;
   STS_preΣ Addr region_invariants_binary.region_type; region_invariants_binary.heapPreΣ;
   savedPredΣ (((STS_std_states Addr region_invariants_binary.region_type)
                * (STS_states * STS_rels)) * (Word * Word))].

Global Instance inG_soundness_binaryΣ Σ : subG soundness_binaryΣ Σ → inG Σ (authR cfgUR).
Proof. solve_inG. Qed.

Theorem confidentiality_adequacy_l `{MachineParameters} `{memory_layout}
        prog1 prog2 c_adv reg' m' (es: list cap_lang.expr):
  is_initial_configuration_left c_adv prog1 →
  is_initial_configuration_right c_adv prog2 →
  is_initial_context c_adv →
  rtc erased_step prog1 (of_val HaltedV :: es, (reg', m')) →
  (∃ es' conf', rtc erased_step prog2 (of_val HaltedV :: es', conf')).
Proof.
  set (Σ := soundness_binaryΣ).
  intros [stack_init [p1 [? [? ->] ] ] ] [stack_init' [p2 [? [? ->] ] ] ] ? ?.
  eapply (@confidentiality_adequacy_l' Σ);last eauto;eauto. all: try typeclasses eauto.
Qed.

Theorem confidentiality_adequacy_r `{MachineParameters} `{memory_layout}
        prog1 prog2 c_adv reg' m' (es: list cap_lang.expr):
  is_initial_configuration_left c_adv prog1 →
  is_initial_configuration_right c_adv prog2 →
  is_initial_context c_adv →
  rtc erased_step prog2 (of_val HaltedV :: es, (reg', m')) →
  (∃ es' conf', rtc erased_step prog1 (of_val HaltedV :: es', conf')).
Proof.
  set (Σ := soundness_binaryΣ).
  intros [stack_init [p1 [? [? ->] ] ] ] [stack_init' [p2 [? [? ->] ] ] ] ? ?.
  eapply (@confidentiality_adequacy_r' Σ);last eauto;eauto. all: try typeclasses eauto.
Qed.

Theorem confidentiality_ctx_equivalent `{MachineParameters} `{memory_layout}
        prog1 prog2 c_adv :
  is_initial_configuration_left c_adv prog1 →
  is_initial_configuration_right c_adv prog2 →
  is_initial_context c_adv →
  (∃ es conf, rtc erased_step prog1 (of_val HaltedV :: es, conf)) ↔
  (∃ es conf, rtc erased_step prog2 (of_val HaltedV :: es, conf)).
Proof.
  intros. split.
  - intros (?&[? ?]&?). eapply confidentiality_adequacy_l;eauto.
  - intros (?&[? ?]&?). eapply confidentiality_adequacy_r;eauto.
Qed.


From iris.base_logic Require Export invariants gen_heap.
From iris.program_logic Require Export weakestpre ectx_lifting.
From iris.proofmode Require Import proofmode.
From iris.algebra Require Import frac.
From cap_machine Require Export rules_AddSubLt rules_binary_base.

Section cap_lang_spec_rules.
  Context `{cfgSG Σ, MachineParameters, invGS Σ}.
  Implicit Types P Q : iProp Σ.
  Implicit Types σ : cap_lang.state.
  Implicit Types a b : Addr.
  Implicit Types r : RegName.
  Implicit Types w : Word.
  Implicit Types reg : gmap RegName Word.
  Implicit Types ms : gmap Addr Word.

  Lemma step_AddSubLt Ep K i pc_p pc_b pc_e pc_a w dst arg1 arg2 regs :
    decodeInstrW w = i →
    is_AddSubLt i dst arg1 arg2 →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) →
    regs !! PC = Some (WCap pc_p pc_b pc_e pc_a) →
    regs_of i ⊆ dom regs →

    nclose specN ⊆ Ep →

    spec_ctx ∗ ⤇ fill K (Instr Executable) ∗ ▷ pc_a ↣ₐ w ∗ ▷ ([∗ map] k↦y ∈ regs, k ↣ᵣ y)
    ={Ep}=∗ ∃ retv regs', ⌜ AddSubLt_spec (decodeInstrW w) regs dst arg1 arg2 regs' retv ⌝ ∗
                            ⤇ fill K (of_val retv) ∗ pc_a ↣ₐ w ∗ [∗ map] k↦y ∈ regs', k ↣ᵣ y.
  Proof.
    iIntros (Hdecode Hinstr Hvpc HPC Dregs Hnclose) "(Hinv & Hj & >Hpc_a & >Hmap)".
    iDestruct "Hinv" as (ρ) "Hinv". rewrite /spec_inv.
    iInv specN as ">Hinv'" "Hclose". iDestruct "Hinv'" as (e [σr σm]) "[Hown %] /=".
    iDestruct (regspec_heap_valid_inclSepM with "Hown Hmap") as %Hregs.
    have ? := lookup_weaken _ _ _ _ HPC Hregs.
    iDestruct (spec_heap_valid with "[$Hown $Hpc_a]") as %Hpc_a.
    iDestruct (spec_expr_valid with "[$Hown $Hj]") as %Heq; subst e.
    specialize (normal_always_step (σr,σm)) as [c [ σ2 Hstep]].
    eapply step_exec_inv in Hstep; eauto.
    pose proof (Hstep' := Hstep). unfold exec in Hstep.

    specialize (indom_regs_incl _ _ _ Dregs Hregs) as Hri.
    erewrite regs_of_is_AddSubLt in Hri, Dregs; eauto.
    destruct (Hri dst) as [wdst [H'dst Hdst]]. by set_solver+.

    destruct (z_of_argument regs arg1) as [n1|] eqn:Hn1;
      pose proof Hn1 as Hn1'; cycle 1.
    (* Failure: arg1 is not an integer *)
    { unfold z_of_argument in Hn1. destruct arg1 as [| r0]; [ congruence |].
      destruct (Hri r0) as [r0v [Hr'0 Hr0]]. by unfold regs_of_argument; set_solver+.
      rewrite Hr'0 in Hn1.
      assert (c = Failed ∧ σ2 = (σr, σm)) as (-> & ->).
      { destruct_or! Hinstr; rewrite Hinstr /= in Hstep.
        all: rewrite Hr0 in Hstep. all: repeat case_match; simplify_eq; eauto. }
      iFailStep AddSubLt_fail_nonconst1.
    }
   apply (z_of_arg_mono _ σr) in Hn1; auto.

    destruct (z_of_argument regs arg2) as [n2|] eqn:Hn2;
      pose proof Hn2 as Hn2'; cycle 1.
    (* Failure: arg2 is not an integer *)
    { unfold z_of_argument in Hn2. destruct arg2 as [| r0]; [ congruence |].
      destruct (Hri r0) as [r0v [Hr'0 Hr0]]. by unfold regs_of_argument; set_solver+.
      rewrite Hr'0 in Hn2.
      assert (c = Failed ∧ σ2 = (σr, σm)) as (-> & ->).
      { destruct_or! Hinstr; rewrite Hinstr /= Hn1 /= in Hstep.
        all: rewrite Hr0 in Hstep. all: repeat case_match; simplify_eq; eauto. }
      iFailStep AddSubLt_fail_nonconst2. }
    apply (z_of_arg_mono _ σr) in Hn2; auto.

    assert (exec_opt i (σr, σm) = updatePC (update_reg (σr, σm) dst (WInt (denote i n1 n2)))) as HH.
    { all: destruct_or! Hinstr; rewrite Hinstr /= /update_reg /= in Hstep |- *; auto.
      all: by rewrite Hn1 Hn2; cbn. }
    rewrite HH in Hstep. rewrite /update_reg /= in Hstep.

    destruct (incrementPC (<[ dst := WInt (denote i n1 n2) ]> regs))
      as [regs'|] eqn:Hregs'; pose proof Hregs' as H'regs'; cycle 1.
    (* Failure: Cannot increment PC *)
    { apply incrementPC_fail_updatePC with (m:=σm) in Hregs'.
      eapply updatePC_fail_incl with (m':=σm) in Hregs'.
      2: by apply lookup_insert_is_Some'; eauto.
      2: by apply insert_mono; eauto.
      simplify_pair_eq.
      rewrite Hregs' in Hstep. inv Hstep.
      iFailStep AddSubLt_fail_incrPC. }

    (* Success *)

    eapply (incrementPC_success_updatePC _ σm) in Hregs'
      as (p' & g' & b' & e' & a'' & a_pc' & HPC'' & HuPC & ->).
    eapply updatePC_success_incl with (m':=σm) in HuPC. 2: by eapply insert_mono; eauto. rewrite HuPC in Hstep.
    simplify_pair_eq. iFrame.
    iMod ((regspec_heap_update_inSepM _ _ _ dst) with "Hown Hmap") as "[Hr Hmap]"; eauto.
    iMod ((regspec_heap_update_inSepM _ _ _ PC) with "Hr Hmap") as "[Hr Hmap]"; eauto.
    iMod (exprspec_mapsto_update _ _ (fill K (Instr NextI)) with "Hr Hj") as "[Hown Hj]".
    iExists NextIV,_. iFrame.
    iMod ("Hclose" with "[Hown]") as "_".
    { iNext. iExists _,_;iFrame. iPureIntro. eapply rtc_r;eauto.
      prim_step_from_exec. }
    iModIntro. iPureIntro. econstructor; eauto.
  Qed.

  Lemma step_AddSubLt_fail E K ins dst n1 r2 w wdst pc_p pc_b pc_e pc_a p b e a :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inl n1) (inr r2) →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) →
    nclose specN ⊆ E →

    spec_ctx ∗ ⤇ fill K (Instr Executable) ∗ PC ↣ᵣ WCap pc_p pc_b pc_e pc_a ∗ pc_a ↣ₐ w ∗ dst ↣ᵣ wdst
             ∗ r2 ↣ᵣ WCap p b e a
    ={E}=∗ ⤇ fill K (of_val FailedV).
  Proof.
    iIntros (Hdecode Hinstr Hvpc Hnclose) "(Hown & Hj & HPC & Hpc_a & Hdst & Hr2)".
    iDestruct (map_of_regs_3 with "HPC Hdst Hr2") as "[Hmap (%&%&%)]".
    iMod (step_AddSubLt with "[$Hmap $Hown $Hj Hpc_a]") as (? ? Hspec) "(Hj & HH)"; eauto; simplify_map_eq; eauto.
      by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    destruct Hspec as [* Hsucc |].
    { (* Success (contradiction) *) by rewrite /= lookup_insert_ne// lookup_insert_ne// lookup_insert in H4. }
    { (* Failure, done *) by iFrame. }
  Qed.

  Lemma step_add_sub_lt_success_z_r E K dst pc_p pc_b pc_e pc_a w wdst ins n1 r2 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inl n1) (inr r2) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) ->
    nclose specN ⊆ E →

    spec_ctx ∗ ⤇ fill K (Instr Executable)
             ∗ PC ↣ᵣ WCap pc_p pc_b pc_e pc_a
             ∗ pc_a ↣ₐ w
             ∗ r2 ↣ᵣ WInt n2
             ∗ dst ↣ᵣ wdst
    ={E}=∗
             ⤇ fill K (of_val NextIV)
             ∗ PC ↣ᵣ WCap pc_p pc_b pc_e pc_a'
             ∗ pc_a ↣ₐ w
             ∗ r2 ↣ᵣ WInt n2
             ∗ dst ↣ᵣ WInt (denote ins n1 n2).
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc Hnlose) "(#Hown & Hj & HPC & Hpc_a & Hr2 & Hdst)".
    iDestruct (map_of_regs_3 with "HPC Hr2 Hdst") as "[Hmap (%&%&%)]".
    iMod (step_AddSubLt with "[$Hmap $Hj $Hown $Hpc_a]") as (retv regs' Hspec) "(Hj & Hpc_a & Hmap)"; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert (insert_commute _ r2 dst) //
              (insert_commute _ dst PC) // insert_insert.
      iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; by iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto. congruence. }
  Qed.

  Lemma step_add_sub_lt_success_dst_r E K dst pc_p pc_b pc_e pc_a w ins n1 r2 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inr dst) (inr r2) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) ->

    nclose specN ⊆ E →

    spec_ctx ∗ ⤇ fill K (Instr Executable)
             ∗ PC ↣ᵣ WCap pc_p pc_b pc_e pc_a
             ∗ pc_a ↣ₐ w
             ∗ r2 ↣ᵣ WInt n2
             ∗ dst ↣ᵣ WInt n1
    ={E}=∗ ⤇ fill K (Instr NextI)
        ∗ PC ↣ᵣ WCap pc_p pc_b pc_e pc_a'
        ∗ pc_a ↣ₐ w
        ∗ r2 ↣ᵣ WInt n2
        ∗ dst ↣ᵣ WInt (denote ins n1 n2).
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc Hnclose) "(Hown & Hj & HPC & Hpc_a & Hr2 & Hdst)".
    iDestruct (map_of_regs_3 with "HPC Hr2 Hdst") as "[Hmap (%&%&%)]".
    iMod (step_AddSubLt with "[$Hmap $Hj $Hown $Hpc_a]") as (retv regs' Hspec) "(Hj & Hpc_a & Hmap)"; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iFrame. incrementPC_inv; simpl in *; simplify_map_eq_alt.
      rewrite (insert_commute _ PC dst) // insert_insert (insert_commute _ r2 dst) //
              (insert_commute _ PC dst) // insert_insert.
      iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; by iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; simpl in *; simplify_map_eq_alt.
      incrementPC_inv;[|rewrite lookup_insert_ne// lookup_insert; eauto]. congruence. }
  Qed.

  Lemma step_add_sub_lt_success_z_dst E K dst pc_p pc_b pc_e pc_a w ins n1 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inl n1) (inr dst) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) ->
    nclose specN ⊆ E →

    spec_ctx ∗ ⤇ fill K (Instr Executable)
             ∗ PC ↣ᵣ WCap pc_p pc_b pc_e pc_a
             ∗ pc_a ↣ₐ w
             ∗ dst ↣ᵣ WInt n2
    ={E}=∗ ⤇ fill K (Instr NextI)
        ∗ PC ↣ᵣ WCap pc_p pc_b pc_e pc_a'
        ∗ pc_a ↣ₐ w
        ∗ dst ↣ᵣ WInt (denote ins n1 n2).
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc Hnclose) "(Hown & Hj & HPC & Hpc_a & Hdst)".
    iDestruct (map_of_regs_2 with "HPC Hdst") as "[Hmap %]".
    iMod (step_AddSubLt with "[$Hmap $Hj $Hown $Hpc_a]") as (retv regs' Hspec) "(Hj & Hpc_a & Hmap)"; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iFrame. simpl in *. incrementPC_inv; simplify_map_eq_alt.
      rewrite (insert_commute _ PC dst) // insert_insert insert_commute // insert_insert.
      iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; by iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; simpl in *; simplify_map_eq_alt.
      incrementPC_inv; [|rewrite lookup_insert_ne// lookup_insert; eauto]. congruence. }
  Qed.

  Lemma step_add_sub_lt_success_dst_z E K dst pc_p pc_b pc_e pc_a w ins n1 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inr dst) (inl n2) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) ->
    nclose specN ⊆ E →

    spec_ctx ∗ ⤇ fill K (Instr Executable)
             ∗ PC ↣ᵣ WCap pc_p pc_b pc_e pc_a
             ∗ pc_a ↣ₐ w
             ∗ dst ↣ᵣ WInt n1
    ={E}=∗ ⤇ fill K (Instr NextI)
        ∗ PC ↣ᵣ WCap pc_p pc_b pc_e pc_a'
        ∗ pc_a ↣ₐ w
        ∗ dst ↣ᵣ WInt (denote ins n1 n2).
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc Hnclose) "(Hown & Hj & HPC & Hpc_a & Hdst)".
    iDestruct (map_of_regs_2 with "HPC Hdst") as "[Hmap %]".
    iMod (step_AddSubLt with "[$Hmap $Hj $Hown $Hpc_a]") as (retv regs' Hspec) "(Hj & Hpc_a & Hmap)"; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iFrame. simpl in *. incrementPC_inv; simplify_map_eq_alt.
      rewrite (insert_commute _ PC dst) // insert_insert insert_commute // insert_insert.
      iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; by iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail;simpl in *;simplify_map_eq_alt; eauto.
      incrementPC_inv;[|rewrite lookup_insert_ne// lookup_insert;eauto]. congruence. }
  Qed.

End cap_lang_spec_rules.