(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
Require Import Coqlib.
Require Import Errors.
Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import MemoryExtra.
Require Import EventsExtra.
Require Import GlobalenvsExtra.
Require Import Locations.
Require Import DataType.
Require Import LAsm.
Require Import CDataTypes.
Require Import AsmExtra.
Require Clight.
Require Import Smallstep.
Require Import ClightBigstep.
Require Import Cop.
Require Import MPTOp.
Require Import MPTIntro.
Require Export PTOpGen.
Require Import MPTIntroCode.
Require Import ZArith.Zwf.
Require Import EventsExtra.
Require Import GlobalenvsExtra.
Require Import Smallstep.
Require Import Op.
Require Import Values.
Require Import MemoryExtra.
Require Import Maps.
Require Import Heap.
Require Import RefinementTactic.
Require Import AuxLemma.
Require Import LayerTemplate2.
Require Import Implementation.
Require Import SeparateCompiler.
Require Import ClightImplemExtra.
Require Import LayerDefinition.
Require Import RealParams.

Open Local Scope string_scope.
Open Local Scope error_monad_scope.

Module PTOPGENIMPL.
  Export PTOpGen.PTOPGEN.

  Lemma hprim_finite_type:
    forall
      (Q: MPTOP.primOp -> Prop)
      (Q_dec: forall p, {Q p} + {~ Q p}),
      {forall p, Q p} + {~ forall p, Q p}.
  Proof with (try (right; eauto; fail)).
    intros.
    destruct (Q_dec MPTOP.PSetPE)...
    destruct (Q_dec MPTOP.PAlloc)...
    destruct (Q_dec MPTOP.PFree)...
    destruct (Q_dec MPTOP.PSetPT)...
    destruct (Q_dec MPTOP.PSetPDX)...
    destruct (Q_dec MPTOP.PPTRead)...
    destruct (Q_dec MPTOP.PPTInsert)...
    destruct (Q_dec MPTOP.PPTRmv)...
    destruct (Q_dec MPTOP.PPTIn)...
    destruct (Q_dec MPTOP.PPTOut)...
    destruct (Q_dec MPTOP.PTrapIn)...
    destruct (Q_dec MPTOP.PTrapOut)...
    destruct (Q_dec MPTOP.PHostIn)...
    destruct (Q_dec MPTOP.PHostOut)...
    destruct (Q_dec MPTOP.PTrapGet)...
    destruct (Q_dec MPTOP.PTrapRet)...
    destruct (Q_dec MPTOP.PMemInit)...
    left; destruct p; assumption.
  Defined.

 Section WithPrimitives.

  Context `{real_params: RealParams}.

    Notation HDATA := (MPTINTRO.AbData (PgSize:=PgSize) (num_proc:=num_proc) (kern_low:=kern_low)
                                      (kern_high:=kern_high) (maxpage:=maxpage)).
    Notation LDATA := (MPTINTRO.AbData (PgSize:=PgSize) (num_proc:=num_proc) (kern_low:=kern_low)
                                      (kern_high:=kern_high) (maxpage:=maxpage)).

    Notation Hfundef := (fundef (external_function:= MPTOP.primOp)).
    Notation Lfundef := (fundef (external_function:= MPTINTRO.primOp)).

    Notation funkind := (funkind (low := MPTINTRO.primOp) Asm.code (Clight.fundef (external_function := MPTINTRO.primOp))).

    Notation dummy := (AST.Internal nil).

    Definition source_implem_extfuns (p: MPTOP.primOp): funkind :=
      match p with
        | MPTOP.PSetPE => Code _ (AST.External MPTINTRO.PSetPE)
        | MPTOP.PAlloc => Code _ (AST.External MPTINTRO.PAlloc)
        | MPTOP.PFree => Code _ (AST.External MPTINTRO.PFree)
        | MPTOP.PSetPT => Code _ (AST.External MPTINTRO.PSetPT)
        | MPTOP.PSetPDX => Code _ (AST.External MPTINTRO.PSetPDX)
        | MPTOP.PPTRead => SourceFun (Clight.Internal MPTINTROCODE.f_pt_read) dummy
        | MPTOP.PPTInsert => SourceFun (Clight.Internal MPTINTROCODE.f_pt_insert) dummy
        | MPTOP.PPTRmv => SourceFun (Clight.Internal MPTINTROCODE.f_pt_rmv) dummy
        | MPTOP.PPTIn => Code _ (AST.External MPTINTRO.PPTIn)
        | MPTOP.PPTOut => Code _ (AST.External MPTINTRO.PPTOut)
        | MPTOP.PTrapIn => Code _ (AST.External MPTINTRO.PTrapIn)
        | MPTOP.PTrapOut => Code _ (AST.External MPTINTRO.PTrapOut)
        | MPTOP.PHostIn => Code _ (AST.External MPTINTRO.PHostIn)
        | MPTOP.PHostOut => Code _ (AST.External MPTINTRO.PHostOut)
        | MPTOP.PTrapGet => Code _ (AST.External MPTINTRO.PTrapGet)
        | MPTOP.PTrapRet => Code _ (AST.External MPTINTRO.PTrapRet)
        | MPTOP.PMemInit => Code _ (AST.External MPTINTRO.PMemInit)
      end.

    Notation varkind := (varkind unit Ctypes.type).

    Definition source_implem_impl_globs : list (ident * option (globdef funkind varkind)) :=
      (get_PTX, Some (Gfun (SourceFun (Clight.External (MPTINTRO.PGetPTX) (Ctypes.Tcons tint (Ctypes.Tcons tint (Ctypes.Tcons tint Ctypes.Tnil))) tint) dummy)))
        :: (set_PTX, Some (Gfun (SourceFun (Clight.External (MPTINTRO.PSetPTX) (Ctypes.Tcons tint (Ctypes.Tcons tint (Ctypes.Tcons tint (Ctypes.Tcons tint (Ctypes.Tcons tint Ctypes.Tnil))))) Ctypes.Tvoid) dummy)))
        :: (rmv_PTX, Some (Gfun (SourceFun (Clight.External (MPTINTRO.PRmvPTX) (Ctypes.Tcons tint (Ctypes.Tcons tint (Ctypes.Tcons tint Ctypes.Tnil))) tvoid) dummy)))
        :: nil.

    Let NOREPET_IMPL: list_norepet (map fst source_implem_impl_globs).
    Proof.
      case_eq (list_norepet_dec peq (map fst source_implem_impl_globs)); try discriminate; tauto.
    Qed.

    Definition source_implem : source_implem Asm.code unit MPTOP.primOp (low := MPTINTRO.primOp) (Clight.fundef (external_function := MPTINTRO.primOp)) Ctypes.type.
    Proof.
      split.
       exact source_implem_extfuns.
       exact source_implem_impl_globs.
    Defined.

    Let im : implem Asm.code unit MPTOP.primOp (low := MPTINTRO.primOp) := implem_of_source_implem transf_clight_fundef Cshmgen.transl_globvar source_implem.

    Notation Hprogram := (Asm.program (external_function:= MPTOP.primOp)).
    Notation Lprogram := (Asm.program (external_function:= MPTINTRO.primOp)).

    Let Im_pt_read: Lfundef := transf_source_fun' transf_clight_fundef (source_implem_extfuns MPTOP.PPTRead).
    Let Im_pt_insert: Lfundef := transf_source_fun' transf_clight_fundef (source_implem_extfuns MPTOP.PPTInsert).
    Let Im_pt_rmv: Lfundef := transf_source_fun' transf_clight_fundef (source_implem_extfuns MPTOP.PPTRmv).

    Definition impl_glbl :  list (ident * option (globdef Lfundef unit)) :=
      map
        (transf_source_def' transf_clight_fundef
                            Cshmgen.transl_globvar)
        source_implem_impl_globs.

    Let well_new_glb: Genv.well_idglob_list impl_glbl = true.
    Proof. reflexivity. Qed.

    (* This is basically an axiom that can be easily checked because MPTOP.primOp is a finite type. However, in practice, generation of CertiKOS code will be very slow because compilation will have to occur twice, one for this check, and a second independently for the generation of the actual code. *)

    Lemma extfun_compilation_succeeds_dec:
      {forall p clight asmfallback,
        source_implem_extfuns p = SourceFun clight asmfallback ->
        exists asm, transf_clight_fundef clight = OK asm} +
      {~ forall p clight asmfallback,
        source_implem_extfuns p = SourceFun clight asmfallback ->
        exists asm, transf_clight_fundef clight = OK asm}.
    Proof.
      apply hprim_finite_type.
      intro.
      destruct (source_implem_extfuns p); try (left; discriminate).
      case_eq (transf_clight_fundef sf).
       left. intros. inv H0. eauto.
      intros. right. intro. exploit H0; eauto. destruct 1. congruence.
    Defined.

    Hypothesis extfun_compilation_succeeds:
      forall p clight asmfallback,
        source_implem_extfuns p = SourceFun clight asmfallback ->
        exists asm, transf_clight_fundef clight = OK asm.

    Section WithProg.

    Variable prog: Hprogram.

    Definition tprog: Lprogram := Implementation.transf_program im prog.

    Let TRANSF: PTOPGEN.transf_program Im_pt_insert Im_pt_rmv Im_pt_read impl_glbl prog = OK tprog.
    Proof.
      unfold tprog.
      unfold Asm.program, Asm.fundef.
      generalize (transf_program_eq im prog).
      intros.
      rewrite <- H.
      unfold transf_program.
      simpl.
      f_equal.
      apply FunctionalExtensionality.functional_extensionality.
      destruct x; simpl.
       reflexivity.
      destruct p; reflexivity.
    Qed.

    Notation ge := (Genv.globalenv prog).
    Notation tge := (Genv.globalenv tprog).

    Hypothesis prog_main_valid:
      ~ Plt' (prog_main prog) (prog_first_symbol prog).

    Hypothesis prog_first_valid:
      ~ Plt' (prog_first_symbol prog) (get_next_symbol (map fst impl_glbl)).

    Hypothesis prog_nonempty:
      prog_defs_names prog <> nil.

    Lemma tprog_first_next:
      prog_first_symbol tprog = get_first_symbol (map fst impl_glbl) /\
      prog_next_symbol  tprog = prog_next_symbol prog.
    Proof.
      replace (get_first_symbol (map fst impl_glbl)) with (implem_first_symbol im) by reflexivity.
      unfold tprog.
      apply transf_program_first_next_symbol.
      assumption.
      assumption.
      discriminate.
    Qed.

    Lemma tprog_main_valid:
      ~ Plt' (prog_main tprog) (prog_first_symbol tprog).
    Proof.
      Opaque Plt'.
      simpl.
      destruct tprog_first_next.
      rewrite H.
      apply Ple'_not_Plt'.
      eapply Ple'_trans.
      apply first_le_next.
      discriminate.
      eapply Ple'_trans.
      apply not_Plt'_Ple'.
      eassumption.
      apply not_Plt'_Ple'.
      assumption.
    Qed.

    Lemma tprog_nonempty:
      prog_defs_names tprog <> nil.
    Proof.
      apply transf_program_nonempty.
      assumption.
    Qed.

    Let NEW_INJ:  (forall s', Genv.find_symbol ge s' <> None ->
                                     ~ In s' (map fst impl_glbl)).
    Proof.
      change impl_glbl with (implem_new_globs im).
      apply new_ids_fresh.
      assumption.
    Qed.

    Let sprog : Clight.program (external_function := MPTINTRO.primOp) := source_program_only source_implem prog.
    Let sge := Genv.globalenv sprog.

    Ltac elim_or H t :=
      match type of H with
        | False => contradiction
        | _ \/ _ =>
          let K := fresh "K" in
          destruct H as [H | K]; [ elim_or H t | elim_or K t ]
        | _ => t H
      end.

    Let tsprog_strong : {tsprog | transf_clight_program sprog = OK tsprog}.
    Proof.
      case_eq (transf_clight_program sprog); eauto.
      intros. exfalso.
      refine (_ (Implementation.compilation_succeeds
                    transf_clight_fundef
                    Cshmgen.transl_globvar
                    source_implem _ _ _
                    prog)).
      destruct 1.
      generalize (transf_clight_fundef_to_program _ _ H0).
      unfold sprog in H.
      congruence.
      assumption.
      simpl.
      intros until fallback.
      intro K.
      let t J := (inv J; rewrite transf_clight_fundef_external; eauto) in elim_or K t.
      unfold Cshmgen.transl_globvar. eauto.
    Qed.

    Let tsprog := let (p, _) := tsprog_strong in p.

    Let tsprog_prop : transf_clight_program sprog = OK tsprog.
    Proof.
      unfold tsprog.
      destruct tsprog_strong.
      assumption.
    Qed.

    Let tsge := Genv.globalenv tsprog.

    (** get_PTX *)

    Let bget_PTX: block := Genv.genv_next ge + Z.of_nat 0.

    Let hget_PTX1 : Genv.find_symbol sge get_PTX = Some bget_PTX.
    Proof.
      eapply add_globals_transf_augment_option.
      2: eapply source_program_only_prop.
      assumption.
      intro. exploit Genv.find_symbol_exists_ex. eassumption. destruct 1.
      eapply (NEW_INJ get_PTX).
      congruence.
      simpl; tauto.
      reflexivity.
    Qed.

    Let hget_PTX2 : Genv.find_funct sge (Vptr bget_PTX Int.zero) = Some (Clight.External (MPTINTRO.PGetPTX) (Ctypes.Tcons tint (Ctypes.Tcons tint (Ctypes.Tcons tint Ctypes.Tnil))) tint).
    Proof.
      simpl. destruct (Int.eq_dec Int.zero Int.zero); try congruence.
      refine (_ (Genv.find_new_funct_ptr_exists_option _ _ _ _ _ _ _ get_PTX _ _)).
       2: exact (source_program_only_prop source_implem prog).
       3: simpl; eauto 8.
       2: assumption.
      fold sprog sge.
      destruct 1 as [? [? ?]].
      congruence.
    Qed.

    Let hget_PTX3 : Clight.type_of_global sge bget_PTX = Some (Ctypes.Tfunction (Ctypes.Tcons tint (Ctypes.Tcons tint (Ctypes.Tcons tint Ctypes.Tnil))) tint).
    Proof.
      unfold Clight.type_of_global.
      case_eq (Genv.find_var_info sge bget_PTX).
       intros. exfalso.
       exploit Genv.find_var_info_rev_transf_augment_option.
       exact (source_program_only_prop source_implem prog).
       eassumption.
      rewrite zlt_false.
       simpl.
       intro K.
       let t _ := discriminate in elim_or K t.
      unfold bget_PTX. unfold Asm.fundef. omega.
      intros.
      simpl in hget_PTX2. destruct (Int.eq_dec Int.zero Int.zero); try congruence. rewrite hget_PTX2. reflexivity.
    Qed.

    (** set_PTX *)

    Let bset_PTX: block := Genv.genv_next ge + Z.of_nat 1.

    Let hset_PTX1 : Genv.find_symbol sge set_PTX = Some bset_PTX.
    Proof.
      eapply add_globals_transf_augment_option.
      2: eapply source_program_only_prop.
      assumption.
      intro. exploit Genv.find_symbol_exists_ex. eassumption. destruct 1.
      eapply (NEW_INJ set_PTX).
      congruence.
      simpl; tauto.
      reflexivity.
    Qed.

    Let hset_PTX2 : Genv.find_funct sge (Vptr bset_PTX Int.zero) = Some (Clight.External (MPTINTRO.PSetPTX) (Ctypes.Tcons tint (Ctypes.Tcons tint (Ctypes.Tcons tint (Ctypes.Tcons tint (Ctypes.Tcons tint Ctypes.Tnil))))) Ctypes.Tvoid).
    Proof.
      simpl. destruct (Int.eq_dec Int.zero Int.zero); try congruence.
      refine (_ (Genv.find_new_funct_ptr_exists_option _ _ _ _ _ _ _ set_PTX _ _)).
       2: exact (source_program_only_prop source_implem prog).
       3: simpl; eauto 8.
       2: assumption.
      fold sprog sge.
      destruct 1 as [? [? ?]].
      congruence.
    Qed.

    Let hset_PTX3 : Clight.type_of_global sge bset_PTX = Some (Ctypes.Tfunction (Ctypes.Tcons tint (Ctypes.Tcons tint (Ctypes.Tcons tint (Ctypes.Tcons tint (Ctypes.Tcons tint Ctypes.Tnil))))) Ctypes.Tvoid).
    Proof.
      unfold Clight.type_of_global.
      case_eq (Genv.find_var_info sge bset_PTX).
       intros. exfalso.
       exploit Genv.find_var_info_rev_transf_augment_option.
       exact (source_program_only_prop source_implem prog).
       eassumption.
      rewrite zlt_false.
       simpl.
       intro K.
       let t _ := discriminate in elim_or K t.
      unfold bset_PTX. unfold Asm.fundef. omega.
      intros.
      simpl in hset_PTX2. destruct (Int.eq_dec Int.zero Int.zero); try congruence. rewrite hset_PTX2. reflexivity.
    Qed.

    (** rmv_PTX *)

    Let brmv_PTX: block := Genv.genv_next ge + Z.of_nat 2.

    Let hrmv_PTX1 : Genv.find_symbol sge rmv_PTX = Some brmv_PTX.
    Proof.
      eapply add_globals_transf_augment_option.
      2: eapply source_program_only_prop.
      assumption.
      intro. exploit Genv.find_symbol_exists_ex. eassumption. destruct 1.
      eapply (NEW_INJ rmv_PTX).
      congruence.
      simpl; tauto.
      reflexivity.
    Qed.

    Let hrmv_PTX2 : Genv.find_funct sge (Vptr brmv_PTX Int.zero) = Some (Clight.External (MPTINTRO.PRmvPTX) (Ctypes.Tcons tint (Ctypes.Tcons tint (Ctypes.Tcons tint Ctypes.Tnil))) tvoid).
    Proof.
      simpl. destruct (Int.eq_dec Int.zero Int.zero); try congruence.
      refine (_ (Genv.find_new_funct_ptr_exists_option _ _ _ _ _ _ _ rmv_PTX _ _)).
       2: exact (source_program_only_prop source_implem prog).
       3: simpl; eauto 8.
       2: assumption.
      fold sprog sge.
      destruct 1 as [? [? ?]].
      congruence.
    Qed.

    Let hrmv_PTX3 : Clight.type_of_global sge brmv_PTX = Some (Ctypes.Tfunction (Ctypes.Tcons tint (Ctypes.Tcons tint (Ctypes.Tcons tint Ctypes.Tnil))) tvoid).
    Proof.
      unfold Clight.type_of_global.
      case_eq (Genv.find_var_info sge brmv_PTX).
       intros. exfalso.
       exploit Genv.find_var_info_rev_transf_augment_option.
       exact (source_program_only_prop source_implem prog).
       eassumption.
      rewrite zlt_false.
       simpl.
       intro K.
       let t _ := discriminate in elim_or K t.
      unfold brmv_PTX. unfold Asm.fundef. omega.
      intros.
      simpl in hrmv_PTX2. destruct (Int.eq_dec Int.zero Int.zero); try congruence. rewrite hrmv_PTX2. reflexivity.
    Qed.

    Context `{PageFaultHandler_LOC: ident}.

    Section WITHMEM.

      Context {mem__MPTOP} {mem__MPTINTRO}
              `{HHmem: !LayerMemoryModel HDATA mem__MPTOP}
              `{HLmem: !LayerMemoryModel LDATA mem__MPTINTRO}
              `{HLayerInject: !LayerMemoryInjections HDATA LDATA mem__MPTOP mem__MPTINTRO}.

      Notation LLoad := (MPTINTRO.exec_loadex (PgSize:=PgSize)(NPT_LOC:= NPT_LOC) (PageFaultHandler_LOC:= PageFaultHandler_LOC)).
      Notation LStore := (MPTINTRO.exec_storeex (PgSize:=PgSize)(NPT_LOC:= NPT_LOC) (PageFaultHandler_LOC:= PageFaultHandler_LOC)).
      Notation HLoad := (MPTOP.exec_loadex (PgSize:=PgSize)(NPT_LOC:= NPT_LOC) (PageFaultHandler_LOC:= PageFaultHandler_LOC)).
      Notation HStore := (MPTOP.exec_storeex (PgSize:=PgSize)(NPT_LOC:= NPT_LOC) (PageFaultHandler_LOC:= PageFaultHandler_LOC)).

      Instance HLayer: LayerDefinition (layer_mem:= HHmem) HDATA MPTOP.primOp mem__MPTOP :=
        MPTOP.layer_def (maxpage := maxpage) (real_nps:= real_nps) (real_AT:= real_AT) (Hmem:= HHmem) (HPS:= HPS).

      Instance LLayer: LayerDefinition (layer_mem:= HLmem) LDATA MPTINTRO.primOp mem__MPTINTRO :=
        MPTINTRO.layer_def (maxpage := maxpage) (real_nps:= real_nps) (real_AT:= real_AT) (Hmem:= HLmem) (HPS:= HPS).

      Notation lstep := (MPTINTRO.step (NPT_LOC:= NPT_LOC) (PageFaultHandler_LOC:= PageFaultHandler_LOC) (HPS:= HPS)
                                       (real_nps:= real_nps) (real_AT:= real_AT)).

      Let pt_insert_spec:
        forall m rs b adt n sig p vadr padr,
          rs PC = Vptr b Int.zero
          -> MPTINTRO.ptInsert (HPS:=HPS) (Mem.get_abstract_data m) (Int.unsigned n)
                               (Int.unsigned vadr) (Int.unsigned padr) (Int.unsigned p) = Some adt
          -> Genv.find_funct_ptr tge b = Some (Im_pt_insert)
          -> sig = mksignature (Tint :: Tint :: Tint :: Tint :: nil) None
          -> (forall b o, rs ESP = Vptr b o -> Mem.tget m b = Some Tag_stack)
          -> rs ESP <> Vundef
          -> rs RA  <> Vundef
          -> Genv.find_funct_ptr ge b = Some (External MPTOP.PPTInsert)
          -> asm_invariant tge (State rs m)
          -> extcall_arguments rs m sig (Vint n :: Vint vadr :: Vint padr :: Vint p :: nil)
          -> exists f' m0' r_,
               inject_incr (Mem.flat_inj (Mem.nextblock m)) f'
               /\ Memtype.Mem.inject f' m m0'
               /\ Mem.nextblock m <= Mem.nextblock m0'
               /\ plus lstep tge (State rs m) E0 (State r_ (Mem.put_abstract_data m0' adt))
               /\ True
               /\ r_ PC = rs RA
               /\ r_ # ESP = rs # ESP
               /\ (forall l,
                     ~In (Locations.R l) Conventions1.temporaries -> ~In (Locations.R l) Conventions1.destroyed_at_call
                     -> Val.lessdef (rs (preg_of l)) (r_ (preg_of l))).
        Proof.
          intros.
          exploit (ClightImplemExtra.bigstep_clight_to_lsem
                     MPTOP.primOp
                     (exec_load := LLoad)
                     (exec_store := LStore)
                     (primitive_call := MPTINTRO.primitive_call)
                     (is_primitive_call := MPTINTRO.is_primitive_call)
                     (kernel_mode := MPTINTRO.kernel_mode)
                  ).
          apply MPTINTRO.exec_load_exec_loadex.
          apply MPTINTRO.exec_store_exec_storeex.
          apply MPTINTRO.extcall_not_primitive.
          apply MPTINTRO.primitive_kernel_mode.
          3: eassumption.
          assumption.
          assumption.
          2: eassumption.
          5: eassumption.
          9: eassumption.
          7: reflexivity.
          intros.
          eapply MPTINTROCODE.pt_insert_correct.
          2: eassumption. eassumption. assumption.
          assumption.
          (* BEGIN hypotheses coming from refinement proof *)
          eassumption.
          reflexivity.
          (* END hypotheses coming from refinement proof *)
          assumption.
          assumption.
          assumption.
          assumption.
          assumption.
          unfold MPTINTRO.kernel_mode.
          apply MPTINTRO.ptInsert_eq in H0.
          functional inversion H0.
          functional inversion H10.
          unfold adt0 in *.
          destruct (MPTINTRO.INV (Mem.get_abstract_data m)).
          auto.
          destruct 1 as [? [? [m_asm [? [INJ [NB [PLUS [? [? [? ?]]]]]]]]]].
          generalize (Mem.put_abstract_data_inject_inside _ _ _ INJ (Mem.get_abstract_data m)).
          rewrite Mem.put_put_abstract_data.
          rewrite Mem.put_get_abstract_data.
          intro.
          replace (Mem.nextblock m_asm) with (Mem.nextblock (Mem.put_abstract_data m_asm (Mem.get_abstract_data m))) in NB by (rewrite Mem.nextblock_put_abstract_data; reflexivity).
          replace m_asm with (Mem.put_abstract_data (Mem.put_abstract_data m_asm (Mem.get_abstract_data m)) adt) in PLUS.
          unfold loc_external_result.
          eauto 11.
          rewrite Mem.put_put_abstract_data.
          replace adt with (Mem.get_abstract_data m_asm).
          rewrite Mem.put_get_abstract_data.
          reflexivity.
          erewrite <- Mem.get_abstract_data_inject_inside; eauto.
          rewrite Mem.get_put_abstract_data.
          reflexivity.
        Qed.

    Let pt_rmv_spec:
        forall m rs b adt n vadr sig,
          rs PC = Vptr b Int.zero
          -> MPTINTRO.ptRmv (Mem.get_abstract_data m) (Int.unsigned n)
                            (Int.unsigned vadr) = Some adt
          -> Genv.find_funct_ptr tge b = Some (Im_pt_rmv)
          -> sig = mksignature (Tint :: Tint ::  nil) None
          -> (forall b o, rs ESP = Vptr b o -> Mem.tget m b = Some Tag_stack)
          -> rs ESP <> Vundef
          -> rs RA  <> Vundef
          -> Genv.find_funct_ptr ge b = Some (External MPTOP.PPTRmv)
          -> asm_invariant tge (State rs m)
          -> extcall_arguments rs m sig (Vint n :: Vint vadr :: nil)
          -> exists f' m0' r_,
               inject_incr (Mem.flat_inj (Mem.nextblock m)) f'
               /\ Memtype.Mem.inject f' m m0'
               /\ Mem.nextblock m <= Mem.nextblock m0'
               /\ plus lstep tge (State rs m) E0 (State r_ (Mem.put_abstract_data m0' adt))
               /\ True
               /\ r_ PC = rs RA
               /\ r_ # ESP = rs # ESP
               /\ (forall l,
                     ~In (Locations.R l) Conventions1.temporaries -> ~In (Locations.R l) Conventions1.destroyed_at_call
                     -> Val.lessdef (rs (preg_of l)) (r_ (preg_of l))).
        Proof.
          intros.
          exploit (ClightImplemExtra.bigstep_clight_to_lsem
                     MPTOP.primOp
                     (exec_load := LLoad)
                     (exec_store := LStore)
                     (primitive_call := MPTINTRO.primitive_call)
                     (is_primitive_call := MPTINTRO.is_primitive_call)
                     (kernel_mode := MPTINTRO.kernel_mode)
                  ).
          apply MPTINTRO.exec_load_exec_loadex.
          apply MPTINTRO.exec_store_exec_storeex.
          apply MPTINTRO.extcall_not_primitive.
          apply MPTINTRO.primitive_kernel_mode.
          3: eassumption.
          assumption.
          assumption.
          2: eassumption.
          5: eassumption.
          9: eassumption.
          7: reflexivity.
          intros.
          eapply MPTINTROCODE.pt_rmv_correct.
          2: eassumption. eassumption. assumption.
          assumption.
          (* BEGIN hypotheses coming from refinement proof *)
          eassumption.
          reflexivity.
          (* END hypotheses coming from refinement proof *)
          assumption.
          assumption.
          assumption.
          assumption.
          assumption.
          unfold MPTINTRO.kernel_mode.
          apply MPTINTRO.ptRmv_eq in H0.
          functional inversion H0.
          destruct (MPTINTRO.INV (Mem.get_abstract_data m)).
          functional inversion H10; unfold adt1 in *; auto.
          destruct 1 as [? [? [m_asm [? [INJ [NB [PLUS [? [? [? ?]]]]]]]]]].
          generalize (Mem.put_abstract_data_inject_inside _ _ _ INJ (Mem.get_abstract_data m)).
          rewrite Mem.put_put_abstract_data.
          rewrite Mem.put_get_abstract_data.
          intro.
          replace (Mem.nextblock m_asm) with (Mem.nextblock (Mem.put_abstract_data m_asm (Mem.get_abstract_data m))) in NB by (rewrite Mem.nextblock_put_abstract_data; reflexivity).
          replace m_asm with (Mem.put_abstract_data (Mem.put_abstract_data m_asm (Mem.get_abstract_data m)) adt) in PLUS.
          eauto 11.
          rewrite Mem.put_put_abstract_data.
          replace adt with (Mem.get_abstract_data m_asm).
          rewrite Mem.put_get_abstract_data.
          reflexivity.
          erewrite <- Mem.get_abstract_data_inject_inside; eauto.
          rewrite Mem.get_put_abstract_data.
          reflexivity.
        Qed.

    Let pt_read_spec:
        forall m rs b n sig vadr padr,
          rs PC = Vptr b Int.zero
          -> MPTINTRO.ptRead (Mem.get_abstract_data m) (Int.unsigned n)
                             (Int.unsigned vadr) = Some (Int.unsigned padr)
          -> Genv.find_funct_ptr tge b = Some (Im_pt_read)
          -> sig = mksignature (Tint :: Tint ::  nil) (Some Tint)
          -> (forall b o, rs ESP = Vptr b o -> Mem.tget m b = Some Tag_stack)
          -> rs ESP <> Vundef
          -> rs RA  <> Vundef
          -> Genv.find_funct_ptr ge b = Some (External MPTOP.PPTRead)
          -> asm_invariant tge (State rs m)
          -> extcall_arguments rs m sig (Vint n :: Vint vadr :: nil)
          -> exists f' m0' r_,
               inject_incr (Mem.flat_inj (Mem.nextblock m)) f'
               /\ Memtype.Mem.inject f' m m0'
               /\ Mem.nextblock m <= Mem.nextblock m0'
               /\ plus lstep tge (State rs m) E0 (State r_  m0')
               /\ r_ # (loc_external_result sig) = (Vint padr)
               /\ r_ PC = rs RA
               /\ r_ # ESP = rs # ESP
               /\ (forall l,
                     ~In (Locations.R l) Conventions1.temporaries -> ~In (Locations.R l) Conventions1.destroyed_at_call
                     -> Val.lessdef (rs (preg_of l)) (r_ (preg_of l))).
        Proof.
          intros.
          exploit (ClightImplemExtra.bigstep_clight_to_lsem
                     MPTOP.primOp
                     (exec_load := LLoad)
                     (exec_store := LStore)
                     (primitive_call := MPTINTRO.primitive_call)
                     (is_primitive_call := MPTINTRO.is_primitive_call)
                     (kernel_mode := MPTINTRO.kernel_mode)
                  ).
          apply MPTINTRO.exec_load_exec_loadex.
          apply MPTINTRO.exec_store_exec_storeex.
          apply MPTINTRO.extcall_not_primitive.
          apply MPTINTRO.primitive_kernel_mode.
          3: eassumption.
          assumption.
          assumption.
          2: eassumption.
          5: eassumption.
          9: eassumption.
          7: reflexivity.
          intros.
          eapply MPTINTROCODE.pt_read_correct.
          2: eassumption. eassumption. assumption.
          assumption.
          eassumption.
          assumption.
          assumption.
          assumption.
          assumption.
          assumption.
          unfold MPTINTRO.kernel_mode.
          unfold MPTINTRO.ptRead in H0.
          unfold MPTINTRO.getPTX in H0.
          destruct (MPTINTRO.INV (Mem.get_abstract_data m)).
          destruct (MPTOP.ipt (MPTINTRO.ADT (Mem.get_abstract_data m))); try discriminate H0.
          destruct (MPTOP.ihost (MPTINTRO.ADT (Mem.get_abstract_data m))); try discriminate H0.
          auto.
          destruct 1 as [? [? [m_asm [? [INJ [NB [PLUS [? [? [? ?]]]]]]]]]].
          generalize (Mem.put_abstract_data_inject_inside _ _ _ INJ (Mem.get_abstract_data m)).
          rewrite Mem.put_get_abstract_data.
          intro.
          replace (Mem.nextblock m_asm) with (Mem.nextblock (Mem.put_abstract_data m_asm (Mem.get_abstract_data m))) in NB by (rewrite Mem.nextblock_put_abstract_data; reflexivity).
          replace m_asm with (Mem.put_abstract_data (Mem.put_abstract_data m_asm (Mem.get_abstract_data m)) (Mem.get_abstract_data m)) in PLUS.
          inversion H10.
          rewrite Mem.put_put_abstract_data in PLUS.
          eauto 11.
          rewrite Mem.put_put_abstract_data.
          rewrite (Mem.get_abstract_data_inject_inside x m m_asm).
          rewrite Mem.put_get_abstract_data.
          reflexivity.
          assumption.
        Qed.

    Theorem transf_program_correct:
        Smallstep.backward_simulation
          (MPTOP.semantics (NPT_LOC:= NPT_LOC) (PgSize:=PgSize) (PageFaultHandler_LOC:= PageFaultHandler_LOC)
                           (real_AT:= real_AT) (real_nps:= real_nps) (Hmem:= HHmem) (HPS:= HPS) prog)
          (MPTINTRO.semantics (NPT_LOC:= NPT_LOC) (PgSize:=PgSize) (PageFaultHandler_LOC:= PageFaultHandler_LOC)
                              (real_AT:= real_AT) (real_nps:= real_nps) (Hmem:= HLmem) (HPS:= HPS) tprog).
    Proof.
      eapply PTOPGEN.transf_program_correct; simpl; eauto.
    Qed.

    End WITHMEM.

    End WithProg.

 End WithPrimitives.

End PTOPGENIMPL.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*              Layers of VMM: MPTOP                                   *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

(** This file defines the abstract data and the primitives for the MPTOp layer, which will introduce high-level primitives to operate on page table*)
Require Import Coqlib.
Require Import Maps.
Require Import ASTExtra.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Events.
Require Import Stacklayout.
Require Import Globalenvs.
Require Import AsmX.
Require Import Smallstep.
Require Import AuxStateDataType.
Require Import Constant.
Require Import GlobIdent.
Require Import FlatMemory.
Require Import CommonTactic.
Require Import AuxLemma.
Require Import RealParams.
Require Import PrimSemantics.
Require Import LAsm.
Require Import LoadStoreSem2.

(*Require Import CalRealPTPool.*)

Require Import liblayers.logic.PTreeModules.
Require Import liblayers.logic.LayerLogicImpl.
Require Import liblayers.compat.CompatLayers.
Require Import liblayers.compat.CompatGenSem.

Require Import INVLemmaContainer.
Require Import INVLemmaMemory.
Require Import CalRealIDPDE.
Require Import CalRealInitPTE.
Require Import CalRealPTPool.

Require Export MPTIntro.
Require Import AbstractDataType.

Section WITHMEM.

  Local Open Scope Z_scope.

  Context `{Hstencil: Stencil}.
  Context `{Hmem: Mem.MemoryModel}.
  Context `{Hmwd: UseMemWithData mem}.
  Context `{real_params: RealParams}.

  (** * Proofs that the primitives satisfies the invariants at this layer *)
  Section INV.

    Global Instance ptInsertAux_inv: PreservesInvariants ptInsertAux_spec.
    Proof.
      unfold ptInsertAux_spec.
      preserves_invariants_simpl low_level_invariant high_level_invariant; auto;
      subdestruct; try (inv H8; rewrite ZMap.gso; auto).
    Qed.

    Global Instance ptInsertPDE_inv: PreservesInvariants ptInsertPDE_spec.
    Proof.
      unfold ptInsertPDE_spec.
      preserves_invariants_simpl low_level_invariant high_level_invariant; auto;
      try (rewrite ZMap.gso; eauto; fail).
      - apply consistent_ppage_alloc_hide; assumption.
      - apply dirty_ppage_gss; assumption.
    Qed.

    (** * Proofs that the primitives satisfies the invariants at this layer *)
    Global Instance ptRmvAux_inv: PreservesInvariants ptRmvAux_spec.
    Proof.
      unfold ptRmvAux_spec.
      preserves_invariants_simpl low_level_invariant high_level_invariant; auto;
      subdestruct; try (inv H7; rewrite ZMap.gso; auto).
    Qed.

    (** * Proofs that the primitives satisfies the invariants at this layer *)
    Global Instance ptRmvPDE_inv: PreservesInvariants ptRmvPDE_spec.
    Proof.
      unfold ptRmvPDE_spec.
      preserves_invariants_simpl low_level_invariant high_level_invariant; auto;
      try (rewrite ZMap.gso; eauto; fail).
      - eapply consistent_ppage_hide_alloc; eassumption.
      - eapply dirty_ppage_gso_alloc; eauto.
      - eapply consistent_ppage_hide_alloc; eassumption.
      - eapply dirty_ppage_gso_alloc; eauto.
    Qed.

    Global Instance idpde_init_inv: PreservesInvariants idpde_init_spec.
    Proof.
      preserves_invariants_simpl low_level_invariant high_level_invariant; auto.
      - apply real_nps_range.
      - apply real_at_kern_valid.
      - apply real_at_usr_valid.
      - apply real_container_valid.
      - apply real_quota_bounded_AT.
      - rewrite init_pperm; try assumption.
        apply real_pperm_valid.
    Qed.

  End INV.

  (** * Layer Definition *)
  (** ** Layer Definition newly introduced  *)
  Definition mptop_fresh : compatlayer (cdata RData) :=
    pt_read ↦ gensem ptRead_spec
            ⊕ pt_read_pde ↦ gensem ptReadPDE_spec
            ⊕ pt_insert_aux ↦ gensem ptInsertAux_spec
            ⊕ pt_insert_pde ↦ gensem ptInsertPDE_spec
            ⊕ pt_rmv_aux ↦ gensem ptRmvAux_spec
            ⊕ pt_rmv_pde ↦ gensem ptRmvPDE_spec
            ⊕ idpde_init ↦ gensem idpde_init_spec.

  (** ** Layer Definition passthrough  *)
  Definition mptop_passthrough : compatlayer (cdata RData) :=
    fload ↦ gensem fload_spec
          ⊕ fstore ↦ gensem fstore_spec
          ⊕ flatmem_copy ↦ gensem flatmem_copy_spec
          ⊕ vmxinfo_get ↦ gensem vmxinfo_get_spec
          ⊕ device_output ↦ gensem device_output_spec
          ⊕ set_pg ↦ gensem setPG1_spec
          ⊕ at_get_c ↦ gensem get_at_c_spec
          ⊕ at_set_c ↦ gensem set_at_c0_spec
          ⊕ pfree ↦ gensem pfree'_spec
          ⊕ set_pt ↦ gensem setPT'_spec
          ⊕ set_PDE ↦ gensem setPDE_spec
          ⊕ rmv_PDE ↦ gensem rmvPDE_spec
          ⊕ rmv_PTE ↦ gensem rmvPTE_spec
          ⊕ pt_in ↦ primcall_general_compatsem' ptin'_spec (prim_ident:= pt_in)
          ⊕ pt_out ↦ primcall_general_compatsem' ptout_spec (prim_ident:= pt_out)
          ⊕ clear_cr2 ↦ gensem clearCR2_spec
          ⊕ container_get_parent ↦ gensem container_get_parent_spec
          ⊕ container_get_nchildren ↦ gensem container_get_nchildren_spec
          ⊕ container_get_quota ↦ gensem container_get_quota_spec
          ⊕ container_get_usage ↦ gensem container_get_usage_spec
          ⊕ container_can_consume ↦ gensem container_can_consume_spec
          ⊕ container_split ↦ gensem container_split_spec
          ⊕ container_alloc ↦ gensem container_alloc_spec
          ⊕ trap_in ↦ primcall_general_compatsem trapin_spec
          ⊕ trap_out ↦ primcall_general_compatsem trapout_spec
          ⊕ host_in ↦ primcall_general_compatsem hostin_spec
          ⊕ host_out ↦ primcall_general_compatsem hostout_spec
          ⊕ trap_get ↦ primcall_trap_info_get_compatsem trap_info_get_spec
          ⊕ trap_set ↦ primcall_trap_info_ret_compatsem trap_info_ret_spec
          ⊕ accessors ↦ {| exec_load := (@exec_loadex _ _ Hmwd);
                           exec_store := (@exec_storeex _ _ Hmwd) |}.

  (** * Layer Definition *)
  Definition mptop : compatlayer (cdata RData) := mptop_fresh ⊕ mptop_passthrough.

  (* Definition semantics := LAsm.Lsemantics mptintro.*)

End WITHMEM.


From cap_machine Require Export logrel.
From iris.proofmode Require Import proofmode.
From iris.program_logic Require Import weakestpre adequacy lifting.
From stdpp Require Import base.
From cap_machine.ftlr Require Import ftlr_base interp_weakening.
From cap_machine.rules Require Import rules_base rules_Seal.

Section fundamental.
  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ} {sealsg: sealStoreG Σ}
          {nainv: logrel_na_invs Σ}
          `{MachineParameters}.

  Notation D := ((leibnizO Word) -n> iPropO Σ).
  Notation R := ((leibnizO Reg) -n> iPropO Σ).
  Implicit Types w : (leibnizO Word).
  Implicit Types interp : (D).

  (* Proving the meaning of sealing in the LR sane *)
  Lemma sealing_preserves_interp sb p0 b0 e0 a0:
        permit_seal p0 = true →
        withinBounds b0 e0 a0 = true →
        fixpoint interp1 (WSealable sb) -∗
        fixpoint interp1 (WSealRange p0 b0 e0 a0) -∗
        fixpoint interp1 (WSealed a0 sb).
  Proof.
    iIntros (Hpseal Hwb) "#HVsb #HVsr".
    rewrite (fixpoint_interp1_eq (WSealRange _ _ _ _)) (fixpoint_interp1_eq (WSealed _ _)) /= Hpseal /interp_sb.
    iDestruct "HVsr" as "[Hss _]".
    apply seq_between_dist_Some in Hwb.
    iDestruct (big_sepL_delete with "Hss") as "[HSa0 _]"; eauto.
    iDestruct "HSa0" as (P) "[% [HsealP HWcond]]".
    iExists P.
    repeat iSplitR; auto.
    by iApply "HWcond".
  Qed.

  Lemma seal_case (r : leibnizO Reg) (p : Perm)
        (b e a : Addr) (w : Word) (dst r1 r2 : RegName) (P:D):
    ftlr_instr r p b e a w (Seal dst r1 r2) P.
  Proof.
    intros Hp Hsome i Hbae Hi.
    iIntros "#IH #Hinv #Hinva #Hreg #[Hread Hwrite] Hown Ha HP Hcls HPC Hmap".
    rewrite delete_insert_delete.
    iDestruct ((big_sepM_delete _ _ PC) with "[HPC Hmap]") as "Hmap /=";
      [apply lookup_insert|rewrite delete_insert_delete;iFrame|]. simpl.
    iApply (wp_Seal with "[$Ha $Hmap]"); eauto.
    { simplify_map_eq; auto. }
    { rewrite /subseteq /map_subseteq /set_subseteq_instance. intros rr _.
      apply elem_of_dom. apply lookup_insert_is_Some'; eauto. }

    iIntros "!>" (regs' retv). iDestruct 1 as (HSpec) "[Ha Hmap]".
    destruct HSpec as [ * Hr1 Hr2 Hseal Hwb HincrPC | ].
    { apply incrementPC_Some_inv in HincrPC as (p''&b''&e''&a''& ? & HPC & Z & Hregs') .

      assert (p'' = p ∧ a'' = a ∧ b'' = b ∧ e'' = e) as (-> & -> & -> & ->).
      { destruct (decide (PC = dst)); simplify_map_eq; auto. }
      assert (r1 ≠ PC) as Hne.
      { destruct (decide (PC = r1)); last auto. simplify_map_eq; auto. }
      rewrite lookup_insert_ne in Hr1; auto.
      iAssert (fixpoint interp1 (WSealable sb)) as "HVsb". {
        destruct (decide (r2 = PC)) eqn:Heq.
        - subst r2. simplify_map_eq; auto.
        - simplify_map_eq. unshelve iSpecialize ("Hreg" $! r2 _ _ Hr2); eauto.
      }

      iApply wp_pure_step_later; auto.
      iMod ("Hcls" with "[HP Ha]");[iExists w;iFrame|iModIntro].
      iNext; iIntros "_".
      iApply ("IH" $! regs' with "[%] [] [Hmap] [$Hown]").
      { cbn. intros. subst regs'. by repeat (apply lookup_insert_is_Some'; right). }
      { iIntros (ri v Hri Hvs).
        subst regs'.
        rewrite lookup_insert_ne in Hvs; auto.
        destruct (decide (ri = dst)).
        { subst ri.
          rewrite lookup_insert in Hvs; inversion Hvs. simplify_eq.
          (* Sealrange is valid -> validity implies P *)
          unshelve iDestruct ("Hreg" $! r1 _ _ Hr1) as "HVsr"; eauto.
          iApply (sealing_preserves_interp with "HVsb HVsr"); auto. }
        { repeat (rewrite lookup_insert_ne in Hvs); auto.
          iApply "Hreg"; auto. } }
        { subst regs'. rewrite insert_insert. iApply "Hmap". }
      iModIntro.
      iApply (interp_weakening with "IH Hinv"); auto; try solve_addr.
      { destruct Hp; by subst p. }
      { by rewrite PermFlowsToReflexive. }
    }
    { iApply wp_pure_step_later; auto.
      iMod ("Hcls" with "[HP Ha]");[iExists w;iFrame|iModIntro].
      iNext; iIntros "_".
      iApply wp_value; auto. iIntros; discriminate. }
  Qed.

End fundamental.


(*
 * Copyright (c) Meta Platforms, Inc. and affiliates.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the root directory of this source tree.
 *)
From stdpp Require Import base strings gmap stringmap fin_maps.
From iris.base_logic Require Import upred derived.
From iris.base_logic.lib Require Import iprop own.
From iris.algebra Require Import ofe cmra gmap_view.
From iris.proofmode Require Import tactics.

From shack Require Import lang progdef subtype eval.
From shack Require Import heap modality interp typing.
From shack.soundness Require Import expr defs.

Section proofs.
  (* assume a given set of class definitions and their SDT annotations. *)
  Context `{SDTCVS: SDTClassVarianceSpec}.

  (* Iris semantic context *)
  Context `{!sem_heapGS Θ}.

  Lemma get_priv_soundness C cdef Δ rigid Γ lhs name fty:
    wf_cdefs →
    wf_lty Γ →
    pdefs !! C = Some cdef →
    cdef.(classfields) !! name = Some (Private, fty) →
    ∀ t tdef Σt σ,
    pdefs !! t = Some tdef →
    length Σt = length tdef.(generics) →
    inherits_using t C σ →
    ∀ Σ st st' n,
    length Σ = rigid →
    rigid ≥ length cdef.(generics) →
    cmd_eval C st (GetC lhs ThisE name) st' n →
    let Σthis := interp_exact_tag interp_type t Σt in
    ⌜interp_list interp_nothing Σt σ ≡ take (length cdef.(generics)) Σ⌝ -∗
    □ interp_as_mixed Σthis -∗
    □ interp_env_as_mixed Σ -∗
    □ Σinterp Σthis Σ Δ -∗
    heap_models st.2 ∗ interp_local_tys Σthis Σ Γ st.1 -∗
    |=▷^n heap_models st'.2 ∗ interp_local_tys Σthis Σ (<[lhs:=fty]> Γ) st'.1.
  Proof.
    move => wfpdefs wflty hcdef hf.
    move => t tdef Σt σ htdef hlenΣt hin_t_C_σ.
    move => Σ st st' n hrigid hge hc /=.
    iIntros "%heq #hΣthis #hΣ #hΣΔ".
    elim/cmd_eval_getI: hc.
    move => {n}.
    move => Ω h vis _fty orig l t0 vs v heval hheap hvs hf0 hvis.
    iIntros "[Hh Hle]".
    iModIntro. (* keep the later *)
    destruct Ω as [vthis Ω].
    case: heval => ->.
    simpl in *.
    iDestruct "Hle" as "[#Hthis #Hle]" => /=.
    iAssert (interp_exact_tag interp_type t Σt (LocV l)) as "#Hl"; first by done.
    rewrite {3}interp_exact_tag_unseal /interp_exact_tag_def /=.
    iDestruct "Hthis" as (l0 ? fields ifields H) "(#hconstr & #hf0 & #H◯)".
    destruct H as ([= <-] & ? & hfields & hidom); simplify_eq.
    assert (hlen: length σ = length cdef.(generics) ∧
      Forall (λ ty : lang_ty, no_this ty) σ).
    { destruct wfpdefs.
      apply inherits_using_wf in hin_t_C_σ => //.
      destruct hin_t_C_σ as (? & ?& ? & hh & ?).
      apply wf_tyI in hh as (? & ? & hlenC & ?); simplify_eq.
      by eauto.
    }
    destruct hlen as (hlen & hnothis).
    iAssert (⌜t0 = t⌝ ∗ heap_models h ∗ ▷ interp_type fty (interp_exact_tag interp_type t Σt) Σ v)%I with "[Hh]" as "[%Ht [Hh Hv]]".
    { iDestruct "Hh" as (sh) "(H● & %hdom & #Hh)".
      iDestruct (sem_heap_own_valid_2 with "H● H◯") as "#HΦ".
      iDestruct ("Hh" with "[//]") as (iFs) "[H H▷]".
      iRewrite "H" in "HΦ".
      rewrite option_equivI prod_equivI /=.
      iDestruct "HΦ" as "[%Ht HΦ]".
      fold_leibniz; subst.
      iSplitR; first done.
      iSplitL. { iExists _. iFrame. by iSplit. }
      assert (hfC: has_field name t Private (subst_ty σ fty) C).
      { destruct wfpdefs.
        apply has_field_inherits_using with C => //.
        change Private with (Private, fty).1.
        by apply HasField with cdef.
      }
      case: (has_field_fun _ _ _ _ _ hf0 _ _ _ hfC) => hvis_ [hfty horig].
      simplify_eq.
      iSpecialize ("hf0" $! name Private (subst_ty σ fty) C hfC).
      iDestruct "H▷" as "[hdf h]".
      rewrite later_equivI.
      iNext.
      iDestruct "hf0" as (iF) "[hf0 hiff]".
      iRewrite -"HΦ" in "hf0".
      iSpecialize ("h" $! name _ with "[hf0]"); first done.
      iDestruct "h" as (w) "[%hw hiw]".
      simplify_eq.
      iDestruct ("hiff" with "hiw") as "hiw_"; iClear "hiw".
      iAssert (interp_type (subst_ty σ fty) (interp_exact_tag interp_type t Σt) Σt v) with "[hiw_]" as "#hiw".
      { rewrite /subst_gen -hlenΣt.
        by iApply interp_type_subst_this.
      }
      iClear "hiw_".
      rewrite interp_type_subst; last first.
      { destruct wfpdefs.
        apply wf_fields_bounded in hcdef.
        apply hcdef in hf.
        by rewrite hlen.
      }
      rewrite -(interp_type_take fty _ Σ); first last.
      { exact hge. }
      { destruct wfpdefs.
        apply wf_fields_bounded in hcdef.
        by apply hcdef in hf.
      }
      assert (heq2: interp_list (interp_exact_tag interp_type t Σt) Σt σ ≡
                    take (length cdef.(generics)) Σ).
      { rewrite -heq.
        by apply interp_list_no_this.
      }
      by rewrite heq2.
    }
    subst.
    iNext.
    iFrame.
    iApply interp_local_tys_update => //.
    by iSplit.
  Qed.

  Lemma get_pub_soundness C Δ kd rigid Γ lhs recv exact_ t σ name fty orig:
    wf_cdefs →
    wf_lty Γ →
    Forall wf_constraint Δ →
    expr_has_ty Δ Γ rigid kd recv (ClassT exact_ t σ) →
    has_field name t Public fty orig →
    (is_true exact_ ∨ no_this fty) →
    ∀ Σthis Σ st st' n,
    length Σ = rigid →
    cmd_eval C st (GetC lhs recv name) st' n →
    □ interp_as_mixed Σthis -∗
    □ interp_env_as_mixed Σ -∗
    □ Σinterp Σthis Σ Δ -∗
    heap_models st.2 ∗ interp_local_tys Σthis Σ Γ st.1 -∗
    |=▷^n heap_models st'.2 ∗ interp_local_tys Σthis Σ (<[lhs:=subst_fty exact_ t σ fty]> Γ) st'.1.
  Proof.
    move => wfpdefs ?? hrecv hf hex Σthis Σ st st' n hrigid hc.
    iIntros "hΣthis hΣ hΣΔ".
    elim/cmd_eval_getI: hc.
    move => {n}.
    move => Ω h vis0 fty0 orig0 l t0 vs v heval hheap hvs hf0 hvis.
    iIntros "[Hh #Hle]".
    iModIntro. (* keep the later *)
    assert (hwf0: wf_ty (ClassT exact_ t σ)) by (by apply expr_has_ty_wf in hrecv).
    assert (hwf0_ := hwf0).
    apply wf_tyI in hwf0_ as (tdef & htdef & hlen & hfσ); simplify_eq.
    iDestruct (expr_soundness with "hΣthis hΣ hΣΔ Hle") as "He" => //; try (by apply wfpdefs).
    destruct exact_.
    (* receiver class is exact *)
    - rewrite interp_exact_tag_unfold interp_exact_tag_unseal /interp_exact_tag_def /=.
      iDestruct "He" as (l0 tdef' fields ifields H) "(#hconstr & #hf0 & #H◯)".
      destruct H as ([= <-] & htdef' & hfields & hidom); simplify_eq.
      simpl.
      iAssert (⌜t0 = t⌝ ∗ heap_models h ∗
        ▷ interp_type (subst_gen t tdef fty) interp_nothing (interp_list Σthis Σ σ) v)%I with "[Hh]" as "[%Ht [Hh Hv]]".
      { iDestruct "Hh" as (sh) "(H● & %hdom & #Hh)".
        iDestruct (sem_heap_own_valid_2 with "H● H◯") as "#HΦ".
        iDestruct ("Hh" with "[//]") as (iFs) "[H H▷]".
        iRewrite "H" in "HΦ".
        rewrite option_equivI prod_equivI /=.
        iDestruct "HΦ" as "[%Ht HΦ]".
        fold_leibniz; subst.
        iSplitR; first done.
        iSplitL. { iExists _. iFrame. by iSplit. }
        iSpecialize ("hf0" $! name Public fty orig hf).
        iDestruct "hf0" as (iF) "[hf0 hiff]".
        iNext.
        iDestruct "H▷" as "[%hdf h]".
        iRewrite -"HΦ" in "hf0".
        iSpecialize ("h" $! name _ with "[hf0]"); first done.
        iDestruct "h" as (w) "[%hw hiw]".
        iApply "hiff".
        by simplify_eq.
      }
      subst; simpl.
      iNext.
      iFrame.
      destruct wfpdefs.
      iApply interp_local_tys_update => //.
      assert (hlen2: length (interp_list Σthis Σ σ) = length tdef.(generics)) by by rewrite /interp_list fmap_length.
      rewrite /subst_gen /subst_fty -hlen2.
      rewrite interp_type_subst_this => //.
      rewrite interp_type_subst; last first.
      { apply has_field_bounded in hf => //.
        destruct hf as (?&?&hf); simplify_eq.
        apply bounded_subst_this.
        + by rewrite hlen.
        + constructor.
          by apply bounded_gen_targs.
      }
      rewrite hlen -hlen2.
      rewrite interp_type_subst_this; first last.
      { by rewrite /interp_list map_length. }
      { by assumption. }
      done.
    - (* receiver is not exact, so it can't call anything using the `this`
       * type yet.
       *)
      case: hex => // hnothis.
      rewrite interp_tag_unfold interp_tag_equiv //; first last.
      { by rewrite /interp_list fmap_length. }
      { by apply wfpdefs. }
      iDestruct "He" as (?? def def1 σ0 ???) "(%H & #hmixed & #? & #hf0 & #hdyn & #H◯)".
      destruct H as ([= <-] & hdef & hdef0 & hlenΣt & hinherits & hfields & hidom).
      assert (hl0: length (generics def) = length σ0).
      { apply inherits_using_wf in hinherits; try (by apply wfpdefs).
        destruct hinherits as (?&?&?&hh&?).
        apply wf_tyI in hh as (? & ? & ? & ?); by simplify_eq.
      }
      assert (hl1: length σ0 = length σ).
      { rewrite -hl0.
        apply wf_tyI in hwf0 as (? & ? & ? & ?); by simplify_eq.
      }
      assert (hff: has_field name t1 Public (subst_ty σ0 fty) orig).
      { by apply has_field_inherits_using with (A := t1) (σB := σ0) in hf => //; try (by apply wfpdefs). }
      iAssert (⌜t0 = t1⌝ ∗ heap_models h ∗
        ▷ interp_type (subst_gen t1 def1 (subst_ty σ0 fty)) interp_nothing Σt v)%I with "[Hh]" as "[%Ht [Hh Hv]]".
      { iDestruct "Hh" as (sh) "(H● & %hdom & #Hh)".
        iDestruct (sem_heap_own_valid_2 with "H● H◯") as "#HΦ".
        iDestruct ("Hh" with "[//]") as (iFs) "[H H▷]".
        iRewrite "H" in "HΦ".
        rewrite option_equivI prod_equivI /=.
        iDestruct "HΦ" as "[%Ht HΦ]".
        fold_leibniz; subst.
        iSplitR; first done.
        iSplitL. { iExists _. iFrame. by iSplit. }
        iSpecialize ("hdyn" $! name Public (subst_ty σ0 fty) orig hff).
        iNext.
        iDestruct "H▷" as "[%hdf h]".
        iDestruct "hdyn" as (iF) "[hdyn hiff]".
        iRewrite -"HΦ" in "hdyn".
        iSpecialize ("h" $! name _ with "[hdyn]"); first done.
        iDestruct "h" as (w) "[%hw hiw]".
        iApply "hiff".
        by simplify_eq.
      }
      subst; simpl.
      iNext.
      iFrame.
      destruct wfpdefs.
      iApply interp_local_tys_update => //.
      rewrite /subst_gen -hlenΣt.
      rewrite interp_type_subst_this => //.
      rewrite interp_type_subst; last first.
      { apply has_field_bounded in hf => //.
        destruct hf as (?&?&hf); simplify_eq.
        by rewrite -hl0.
      }
      rewrite (interp_list_no_this _ _ (interp_exact_tag interp_type t1 Σt) interp_nothing); last first.
      { apply inherits_using_wf in hinherits => //.
        by destruct hinherits as (? & ? & ? & ? & hh); simplify_eq.
      }
      iAssert (interp_type fty (interp_exact_tag interp_type t1 Σt)
        (interp_list Σthis Σ σ) v) with "[Hv]" as "Hv".
      { iApply interp_with_mono => //.
        - apply has_field_mono in hf => //.
          destruct hf as (?&?&hh); simplify_eq.
          by destruct hh.
        - by apply has_field_wf in hf.
      }
      rewrite interp_type_subst; first last.
      { apply bounded_subst_this.
        - apply has_field_bounded in hf => //.
          destruct hf as (?&?&hf).
          apply wf_tyI in hwf0 as (? & ? & -> & ?).
          by simplify_eq.
        - constructor; by apply bounded_gen_targs.
      }
      rewrite subst_this_no_this_id; last done.
      by rewrite (interp_type_no_this _ _ _ _ Σthis); last done.
  Qed.

  (* TODO: factorize the priv vs pub mechanics. This proof is using both *)
  Lemma get_this_soundness C cdef Δ kd rigid Γ lhs recv name fty orig:
    wf_cdefs →
    wf_lty Γ →
    Forall wf_constraint Δ →
    pdefs !! C = Some cdef →
    expr_has_ty Δ Γ rigid kd recv ThisT →
    has_field name C Public fty orig →
    ∀ t tdef Σt σ,
    pdefs !! t = Some tdef →
    length Σt = length tdef.(generics) →
    inherits_using t C σ →
    ∀ Σ st st' n,
    length Σ = rigid →
    rigid ≥ length cdef.(generics) →
    cmd_eval C st (GetC lhs recv name) st' n →
    let Σthis := interp_exact_tag interp_type t Σt in
    ⌜interp_list interp_nothing Σt σ ≡ take (length cdef.(generics)) Σ⌝ -∗
    □ interp_as_mixed Σthis -∗
    □ interp_env_as_mixed Σ -∗
    □ Σinterp Σthis Σ Δ -∗
    heap_models st.2 ∗ interp_local_tys Σthis Σ Γ st.1 -∗
    |=▷^n heap_models st'.2 ∗ interp_local_tys Σthis Σ (<[lhs:=fty]> Γ) st'.1.
  Proof.
    move => wfpdefs ?? hcdef hrecv hf.
    move => t tdef Σt σ htdef hlenΣt hin_t_C.
    move => Σ st st' n hrigid hge hc Σthis.
    iIntros "%hΣeq hΣthis hΣ hΣΔ".
    elim/cmd_eval_getI: hc.
    move => {n}.
    move => Ω h vis0 fty0 orig0 l t0 vs v heval hheap hvs hf0 hvis.
    iIntros "[Hh #Hle]".
    iModIntro. (* keep the later *)
    iDestruct (expr_soundness with "hΣthis hΣ hΣΔ Hle") as "He" => //; try (by apply wfpdefs).
    rewrite interp_this_unfold /= {2}/Σthis.
    rewrite interp_exact_tag_unseal /interp_exact_tag_def /=.
    iDestruct "He" as (l0 tdef' fields ifields H) "(#hconstr & #hf0 & #H◯)".
    destruct H as ([= <-] & htdef' & hfields & hidom); simplify_eq.
    assert (hlen: length σ = length cdef.(generics) ∧
      Forall (λ ty : lang_ty, no_this ty) σ).
    { destruct wfpdefs.
      apply inherits_using_wf in hin_t_C => //.
      destruct hin_t_C as (? & ?& ? & hh & ?).
      apply wf_tyI in hh as (? & ? & hlenC & ?); simplify_eq.
      by eauto.
    }
    destruct hlen as (hlen & hnothis).
    iAssert (⌜t0 = t⌝ ∗ heap_models h ∗
      ▷ interp_type fty (interp_exact_tag interp_type t Σt) Σ v)%I with "[Hh]" as "[%Ht [Hh Hv]]".
    { iDestruct "Hh" as (sh) "(H● & %hdom & #Hh)".
      iDestruct (sem_heap_own_valid_2 with "H● H◯") as "#HΦ".
      iDestruct ("Hh" with "[//]") as (iFs) "[H H▷]".
      iRewrite "H" in "HΦ".
      rewrite option_equivI prod_equivI /=.
      iDestruct "HΦ" as "[%Ht HΦ]".
      fold_leibniz; subst.
      iSplitR; first done.
      iSplitL. { iExists _. iFrame. by iSplit. }
      assert (hff: has_field name t Public (subst_ty σ fty) orig).
      { apply has_field_inherits_using
        with (A := t) (σB := σ) in hf => //; by apply wfpdefs.
      }
      iSpecialize ("hf0" $! name Public (subst_ty σ fty) orig hff).
      iDestruct "hf0" as (iF) "[hf0 hiff]".
      iNext.
      iDestruct "H▷" as "[%hdf h]".
      iRewrite -"HΦ" in "hf0".
      iSpecialize ("h" $! name _ with "[hf0]"); first done.
      iDestruct "h" as (w) "[%hw hiw]".
      iDestruct ("hiff" with "hiw") as "hw".
      simplify_eq.
      rewrite /subst_gen -hlenΣt.
      iAssert (□ interp_type
        (subst_ty σ fty) (interp_exact_tag interp_type t Σt) Σt v)%I as "#hw2".
      { iModIntro.
        by rewrite -interp_type_subst_this.
      }
      iClear "hiw hiff hw".
      rewrite interp_type_subst; last first.
      { apply has_field_bounded in hf => //; try by apply wfpdefs.
        destruct hf as (? & ? & ?); simplify_eq.
        by rewrite hlen.
      }
      assert (heq:
        interp_list (interp_exact_tag interp_type t Σt) Σt σ ≡
        interp_list interp_nothing Σt σ).
      { by apply interp_list_no_this. }
      rewrite (interp_type_equivI _ _ _ heq).
      rewrite (interp_type_equivI _ _ _ hΣeq).
      rewrite interp_type_take //.
      { apply has_field_bounded in hf => //; try by apply wfpdefs.
        by destruct hf as (? & ? & ?); simplify_eq.
      }
    }
    subst; simpl.
    iNext.
    iFrame.
    destruct wfpdefs.
    by iApply interp_local_tys_update.
  Qed.
End proofs.


From Perennial.program_proof Require Import grove_prelude.
From Goose.github_com.mit_pdos.gokv.simplepb Require Export config.
From iris.base_logic Require Export lib.ghost_var mono_nat.
From iris.algebra Require Import dfrac_agree mono_list.
From Perennial.program_proof Require Import marshal_stateless_proof std_proof.
From Perennial.program_proof.simplepb Require Import config_marshal_proof.
From Perennial.program_proof.grove_shared Require Import urpc_proof urpc_spec.

Section config_global.

Record config_names :=
{
  epoch_gn:gname ;
  config_val_gn:gname;
}.

Class configG Σ := {
    config_epochG :> mono_natG Σ ;
    config_configG :> ghost_varG Σ (list u64) ;
    config_urpcG :> urpcregG Σ ;
}.

Definition configΣ := #[mono_natΣ ; ghost_varΣ (list u64) ; urpcregΣ].

Global Instance subG_configΣ {Σ} : subG configΣ Σ → configG Σ.
Proof. intros. solve_inG. Qed.

Implicit Type γ : config_names.

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

Definition own_epoch γ (epoch:u64) : iProp Σ :=
  mono_nat_auth_own γ.(epoch_gn) (1/2) (int.nat epoch).

Definition is_epoch_lb γ (epoch:u64) : iProp Σ :=
  mono_nat_lb_own γ.(epoch_gn) (int.nat epoch).

Definition own_config γ (conf:list u64) : iProp Σ :=
  ghost_var γ.(config_val_gn) (1/2) conf
.

Program Definition GetEpochAndConfig_core_spec γ Φ :=
  (£ 1 ={⊤,∅}=∗ ∃ epoch conf, own_epoch γ epoch ∗ own_config γ conf ∗
    (⌜int.nat epoch < int.nat (word.add epoch (U64 1))⌝ -∗ own_epoch γ (word.add epoch (U64 1)) -∗ own_config γ conf ={∅,⊤}=∗
      Φ (word.add epoch 1) conf
      )
    )%I.

Program Definition GetConfig_core_spec γ Φ :=
  (£ 1 ={⊤,∅}=∗ ∃ conf, own_config γ conf ∗ (own_config γ conf ={∅,⊤}=∗ Φ conf))%I.

Program Definition WriteConfig_core_spec γ (epoch:u64) (new_conf:list u64) Φ : iProp Σ :=
  (£ 1 -∗ |={⊤,∅}=> ∃ latest_epoch, own_epoch γ latest_epoch ∗
      if (decide (latest_epoch = epoch)) then
        ∃ conf, own_config γ conf ∗ (own_config γ new_conf -∗ own_epoch γ epoch ={∅,⊤}=∗
                                            Φ (U64 0))
      else
        (own_epoch γ latest_epoch ={∅,⊤}=∗ (∀ (err:u64), ⌜err ≠ 0⌝ → Φ err))
  ).

Program Definition GetEpochAndConfig_spec γ :=
  λ (encoded_args:list u8), λne (Φ : list u8 -d> iPropO Σ) ,
  ( (* no args *)
    GetEpochAndConfig_core_spec γ (λ newEpoch conf,
                                  ∀ reply enc_conf,
                                   ⌜Config.has_encoding enc_conf conf⌝ -∗
                                   ⌜reply = u64_le newEpoch ++ enc_conf⌝ -∗
                                   Φ reply
                                  )
    )%I.
Next Obligation.
  solve_proper.
Defined.

Program Definition GetConfig_spec γ :=
  λ (encoded_args:list u8), λne (Φ : list u8 -d> iPropO Σ) ,
  ( (* no args *)
    GetConfig_core_spec γ (λ conf, ∀ reply,
                                   ⌜Config.has_encoding reply conf⌝ -∗
                                   Φ reply
                                  )
    )%I.
Next Obligation.
  solve_proper.
Defined.

Program Definition WriteConfig_spec γ :=
  λ (enc_args:list u8), λne (Φ : list u8 -d> iPropO Σ) ,
  ( ∃ epoch new_conf enc_new_conf,
    ⌜enc_args = u64_le epoch ++ enc_new_conf⌝ ∗
    ⌜Config.has_encoding enc_new_conf new_conf⌝ ∗
    WriteConfig_core_spec γ epoch new_conf (λ err, ∀ reply,
                                   ⌜reply = u64_le err⌝ -∗
                                   Φ reply
                                  )
    )%I.
Next Obligation.
  unfold WriteConfig_core_spec.
  solve_proper.
Defined.

Definition is_host (host:u64) γ : iProp Σ :=
  ∃ γrpc,
  handler_spec γrpc host (U64 0) (GetEpochAndConfig_spec γ) ∗
  handler_spec γrpc host (U64 1) (GetConfig_spec γ) ∗
  handler_spec γrpc host (U64 2) (WriteConfig_spec γ) ∗
  handlers_dom γrpc {[ (U64 0) ; (U64 1) ; (U64 2)]}
.

End config_global.

Section config_proof.

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

Definition is_Clerk (ck:loc) γ : iProp Σ :=
  ∃ (cl:loc) srv,
  "#Hcl" ∷ readonly (ck ↦[config.Clerk :: "cl"] #cl) ∗
  "#Hcl_rpc"  ∷ is_uRPCClient cl srv ∗
  "#Hhost" ∷ is_host srv γ
.

Lemma wp_MakeClerk configHost γ:
  {{{
      is_host configHost γ
  }}}
    config.MakeClerk #configHost
  {{{
      ck, RET #ck; is_Clerk ck γ
  }}}
.
Proof.
  iIntros (Φ) "#Hhost HΦ".
  wp_call.
  wp_apply (wp_MakeClient).
  iIntros (cl) "#Hcl".
  iApply wp_fupd.
  wp_apply (wp_allocStruct).
  { eauto. }
  iIntros (ck) "Hck".
  iDestruct (struct_fields_split with "Hck") as "HH".
  iNamed "HH".
  iMod (readonly_alloc_1 with "cl") as "#cl".
  iModIntro.
  iApply "HΦ".
  iExists _, _. iFrame "#".
Qed.

Definition own_Server (s:loc) γ : iProp Σ :=
  ∃ (epoch:u64) (conf:list u64) conf_sl,
  "Hepoch" ∷ s ↦[config.Server :: "epoch"] #epoch ∗
  "Hconf" ∷ s ↦[config.Server :: "config"] (slice_val conf_sl) ∗
  "Hconf_sl" ∷ is_slice_small conf_sl uint64T 1 conf ∗
  "Hepoch_ghost" ∷ own_epoch γ epoch ∗
  "Hconf_ghost" ∷ own_config γ conf
.

Definition configN := nroot .@ "config".

Definition is_Server (s:loc) γ : iProp Σ :=
  ∃ mu,
  "#Hmu" ∷ readonly (s ↦[config.Server :: "mu"] mu) ∗
  "#His_mu" ∷ is_lock configN mu (own_Server s γ).

Lemma wp_Server__GetEpochAndConfig (server:loc) γ :
  {{{
        is_Server server γ
  }}}
    config.Server__GetEpochAndConfig #server
  {{{
        (f:val), RET f; impl_handler_spec2 f (GetEpochAndConfig_spec γ)
  }}}.
Proof.
  iIntros (Φ) "#His_srv HΦ".
  wp_call.
  iApply "HΦ".
  iModIntro.
  unfold impl_handler_spec2.
  clear Φ.
  iIntros (enc_args Φ Ψ req_sl rep_ptr dummy_sl dummy) "!# Harg_sl Hrep _ HΦ HΨ".
  wp_call.

  iNamed "His_srv".
  wp_loadField.
  wp_apply (acquire_spec with "[$His_mu]").
  iIntros "[Hlocked Hown]".
  iNamed "Hown".
  wp_pures.
  wp_loadField.
  wp_apply (wp_SumAssumeNoOverflow).
  iIntros (Hno_overflow).
  wp_storeField.
  wp_loadField.
  wp_apply (wp_slice_len).
  wp_apply (wp_NewSliceWithCap).
  { apply encoding.unsigned_64_nonneg. }
  iIntros (ptr) "Hsl".
  wp_pure1_credit "Hlc".
  wp_store.
  wp_loadField.
  wp_load.
  wp_apply (wp_WriteInt with "Hsl").
  iIntros (enc_sl) "Hrep_sl".
  wp_store.
  wp_loadField.
  wp_apply (Config.wp_Encode with "[Hconf_sl]").
  { iFrame. }
  iIntros (enc_conf enc_conf_sl) "(%Hconf_enc & Hconf_sl & Henc_conf_sl)".
  wp_load.
  wp_apply (wp_WriteBytes with "[$Hrep_sl Henc_conf_sl]").
  {
    iDestruct (is_slice_to_small with "Henc_conf_sl") as "$".
  }
  iIntros (rep_sl) "[Hrep_sl Henc_conf_sl]".
  replace (int.nat 0%Z) with 0%nat by word.
  wp_store.
  wp_loadField.

  iApply fupd_wp.
  iMod ("HΨ" with "Hlc") as "HΨ".
  iDestruct "HΨ" as (??) "(Hepoch_ghost2 & Hconf_ghost2 & Hupd)".
  iDestruct (ghost_var_agree with "Hconf_ghost Hconf_ghost2") as %->.
  iDestruct (mono_nat_auth_own_agree with "Hepoch_ghost Hepoch_ghost2") as %[_ Heq].
  replace (epoch0) with (epoch) by word.
  iCombine "Hepoch_ghost Hepoch_ghost2" as "Hepoch_ghost".
  iMod (mono_nat_own_update (int.nat (word.add epoch 1)) with "Hepoch_ghost") as "[[Hepoch_ghost Hepoch_ghost2] _]".
  { word. }
  iSpecialize ("Hupd" with "[%] Hepoch_ghost2 Hconf_ghost2").
  { word. }
  iMod "Hupd".
  iModIntro.

  wp_apply (release_spec with "[$Hlocked $His_mu Hepoch Hconf Hconf_ghost Hconf_sl Hepoch_ghost]").
  {
    iNext.
    iExists _, _, _.
    eauto with iFrame.
  }
  wp_pures.
  iDestruct (is_slice_to_small with "Hrep_sl") as "Hrep_sl".
  iSpecialize ("Hupd" with "[% //] [% //]").
  iApply ("HΦ" with "Hupd Hrep Hrep_sl").
Qed.

Lemma wp_Server__GetConfig (server:loc) γ :
  {{{
        is_Server server γ
  }}}
    config.Server__GetConfig #server
  {{{
        (f:val), RET f; impl_handler_spec2 f (GetConfig_spec γ)
  }}}.
Proof.
  iIntros (Φ) "#His_srv HΦ".
  wp_call.
  iApply "HΦ".
  iModIntro.
  unfold impl_handler_spec2.
  clear Φ.
  iIntros (enc_args Φ Ψ req_sl rep_ptr dummy_sl dummy) "!# Harg_sl Hrep _ HΦ HΨ".
  wp_call.

  iNamed "His_srv".
  wp_loadField.
  wp_apply (acquire_spec with "[$His_mu]").
  iIntros "[Hlocked Hown]".
  iNamed "Hown".
  wp_pure1_credit "Hlc".
  wp_loadField.
  wp_apply (Config.wp_Encode with "[Hconf_sl]").
  { iFrame. }
  iIntros (enc_conf rep_sl) "(%Hconf_enc & Hconf_sl & Hrep_sl)".
  wp_store.
  wp_loadField.

  iApply fupd_wp.
  iMod ("HΨ" with "Hlc") as "HΨ".
  iDestruct "HΨ" as (?) "(Hconf_ghost2 & Hupd)".
  iDestruct (ghost_var_agree with "Hconf_ghost Hconf_ghost2") as %->.
  iMod ("Hupd" with "Hconf_ghost2") as "Hupd".
  iModIntro.

  wp_apply (release_spec with "[$Hlocked $His_mu Hepoch Hconf Hconf_ghost Hconf_sl Hepoch_ghost]").
  {
    iNext.
    iExists _, _, _.
    iFrame.
  }
  wp_pures.
  iDestruct (is_slice_to_small with "Hrep_sl") as "Hrep_sl".
  iSpecialize ("Hupd" with "[% //]").
  iApply ("HΦ" with "Hupd Hrep Hrep_sl").
Qed.

Lemma wp_Server__WriteConfig (server:loc) γ :
  {{{
        is_Server server γ
  }}}
    config.Server__WriteConfig #server
  {{{
        (f:val), RET f; impl_handler_spec2 f (WriteConfig_spec γ)
  }}}.
Proof.
  iIntros (Φ) "#His_srv HΦ".
  wp_call.
  iApply "HΦ".
  iModIntro.
  unfold impl_handler_spec2.
  clear Φ.
  iIntros (enc_args Φ Ψ req_sl rep_ptr dummy_sl dummy) "!# Harg_sl Hrep _ HΦ HΨ".
  wp_call.
  iNamed "His_srv".
  wp_loadField.
  wp_apply (acquire_spec with "[$His_mu]").
  iIntros "[Hlocked Hown]".
  iNamed "Hown".
  wp_pures.

  unfold WriteConfig_spec.
  iDestruct "HΨ" as (new_epoch new_conf enc_new_conf) "(%Henc & %Henc_conf & HΨ)".
  rewrite Henc.
  wp_apply (wp_ReadInt with "Harg_sl").
  iIntros (args_sl) "Hargs_sl".
  wp_pure1_credit "Hlc".

  replace (slice.nil) with (slice_val Slice.nil) by done.
  wp_loadField.
  wp_if_destruct.
  {
    wp_apply (wp_WriteInt with "[]").
    {
      iApply is_slice_zero.
    }
    iIntros (rep_sl) "Hrep_sl".
    wp_store.
    wp_loadField.

    iApply fupd_wp.
    iMod ("HΨ" with "Hlc") as "HΨ".
    iDestruct "HΨ" as (?) "(Hepoch_ghost2 & HΨ)".
    iDestruct (mono_nat_auth_own_agree with "Hepoch_ghost Hepoch_ghost2") as %[_ Heq].
    replace (epoch) with (latest_epoch) in * by word.
    destruct (decide (_)).
    {
      exfalso. rewrite e in Heqb.
      done.
    }
    simpl.
    iMod ("HΨ" with "Hepoch_ghost2") as "HΨ".
    iDestruct (is_slice_to_small with "Hrep_sl") as "Hrep_sl".
    iDestruct ("HΨ" with "[%] [% //]") as "HΨ".
    { instantiate (1:=1). done. }
    iDestruct ("HΦ" with "HΨ Hrep Hrep_sl") as "HΦ".
    iModIntro.

    wp_apply (release_spec with "[$Hlocked $His_mu Hepoch Hconf Hconf_sl Hepoch_ghost Hconf_ghost]").
    {
      iNext.
      iExists _,_,_.
      eauto with iFrame.
    }
    wp_pures.
    iModIntro.
    done.
  }
  {
    wp_apply (Config.wp_Decode with "[$Hargs_sl]").
    { done. }
    iIntros (new_conf_sl) "Hnew_conf_sl".
    wp_storeField.
    wp_apply (wp_WriteInt with "[]").
    {
      iApply is_slice_zero.
    }
    iIntros (rep_sl) "Hrep_sl".
    wp_store.

    iApply fupd_wp.
    iMod ("HΨ" with "Hlc") as "HΨ".
    iDestruct "HΨ" as (?) "[Hepoch_ghost2 HΨ]".
    iDestruct (mono_nat_auth_own_agree with "Hepoch_ghost Hepoch_ghost2") as %[_ Heq].
    replace (epoch) with (latest_epoch) in * by word.
    destruct (decide (_)); last first.
    {
      exfalso.
      done.
    }
    {
      iDestruct "HΨ" as (?) "[Hconf_ghost2 HΨ]".
      iDestruct (ghost_var_agree with "Hconf_ghost Hconf_ghost2") as %->.
      iCombine "Hconf_ghost Hconf_ghost2" as "Hconf_ghost".
      iMod (ghost_var_update new_conf with "Hconf_ghost") as "[Hconf_ghost Hconf_ghost2]".
      iMod ("HΨ" with "Hconf_ghost2 Hepoch_ghost2") as "HΨ".
      iDestruct (is_slice_to_small with "Hrep_sl") as "Hrep_sl".
      iSpecialize ("HΨ" with "[%]").
      { done. }
      iSpecialize ("HΦ" with "HΨ Hrep Hrep_sl").
      iModIntro.

      wp_loadField.
      wp_apply (release_spec with "[$Hlocked $His_mu Hepoch Hconf Hnew_conf_sl Hepoch_ghost Hconf_ghost]").
      {
        iNext.
        iExists _,_,_.
        eauto with iFrame.
      }
      wp_pures.
      iModIntro.
      done.
    }
  }
Qed.

Lemma wp_Clerk__GetEpochAndConfig (ck:loc) γ Φ :
  is_Clerk ck γ -∗
  □ (£ 1 ={⊤,∅}=∗ ∃ epoch conf, own_epoch γ epoch ∗
                                    own_config γ conf ∗
    (⌜int.nat epoch < int.nat (word.add epoch (U64 1))⌝ -∗ own_epoch γ (word.add epoch (U64 1)) -∗ own_config γ conf ={∅,⊤}=∗
      (∀ conf_sl, is_slice_small conf_sl uint64T 1 conf -∗ Φ (#(LitInt (word.add epoch (U64 1))), slice_val conf_sl)%V)
                                )
  ) -∗
  WP config.Clerk__GetEpochAndConfig #ck {{ Φ }}
.
Proof.
  iIntros "#Hck #HΦ".
  wp_call.
  wp_apply (wp_ref_of_zero).
  { done. }
  iIntros (reply_ptr) "Hreply".
  wp_pures.

  wp_forBreak.
  wp_pures.
  iNamed "Hck".

  wp_apply (wp_NewSlice).
  iIntros (dummy_args) "Hargs".
  wp_loadField.
  iDestruct (is_slice_to_small with "Hargs") as "Hargs_sl".
  iNamed "Hhost".
  wp_apply (wp_Client__Call2 with "Hcl_rpc [] Hargs_sl Hreply").
  {
    iDestruct "Hhost" as "[$ _]".
  }
  {
    iModIntro.
    iNext.
    iIntros "Hlc".
    iMod ("HΦ" with "Hlc") as "Hupd".
    iModIntro.
    iDestruct "Hupd" as (??) "(H1&H2&Hupd)".
    iExists _, _.
    iFrame "H1 H2".
    iIntros.
    iMod ("Hupd" with "[% //] [$] [$]") as "Hupd".
    iModIntro.
    iIntros (??) "%Hconf_enc %Henc Hargs_sl".
    iIntros (?) "Hrep Hrep_sl".
    wp_pures.
    iRight.
    iModIntro.
    iSplitR; first done.
    wp_pures.
    wp_apply (wp_ref_of_zero).
    { done. }
    iIntros (epoch_ptr) "Hepoch".
    wp_pures.
    wp_load.
    rewrite Henc.
    wp_apply (wp_ReadInt with "Hrep_sl").
    iIntros (rep_sl1) "Hrep_sl".
    wp_pures.
    wp_store.
    wp_store.
    wp_load.
    wp_apply (Config.wp_Decode with "[$Hrep_sl]").
    { done. }
    iIntros (?) "Hconf_own".
    wp_pures.
    wp_load.
    wp_pures.
    iModIntro.
    iApply "Hupd".
    iFrame.
  }
  {
    iIntros (err) "%Herr Hargs_sl Hrep".
    wp_pures.
    wp_if_destruct.
    {
      exfalso. done.
    }
    iLeft.
    iModIntro.
    iSplitR; first done.
    iFrame.
  }
Qed.

Lemma wp_Clerk__GetConfig (ck:loc) γ Φ :
  is_Clerk ck γ -∗
  □ (£ 1 ={⊤,∅}=∗ ∃ conf, own_config γ conf ∗ (own_config γ conf ={∅,⊤}=∗
      (∀ conf_sl, is_slice_small conf_sl uint64T 1 conf -∗ Φ (slice_val conf_sl)%V)
                                )
  ) -∗
  WP config.Clerk__GetConfig #ck {{ Φ }}
.
Proof.
  iIntros "#Hck #HΦ".
  wp_call.
  wp_apply (wp_ref_of_zero).
  { done. }
  iIntros (reply_ptr) "Hreply".
  wp_pures.

  wp_forBreak.
  wp_pures.
  iNamed "Hck".

  wp_apply (wp_NewSlice).
  iIntros (dummy_args) "Hargs".
  wp_loadField.
  iDestruct (is_slice_to_small with "Hargs") as "Hargs_sl".
  iNamed "Hhost".
  wp_apply (wp_Client__Call2 with "Hcl_rpc [] Hargs_sl Hreply").
  {
    iDestruct "Hhost" as "[_ [$ _]]".
  }
  {
    iModIntro.
    iNext.
    iIntros "Hlc".
    iMod ("HΦ" with "Hlc") as "Hupd".
    iModIntro.
    iDestruct "Hupd" as (?) "(H1&Hupd)".
    iExists _.
    iFrame "H1".
    iIntros.
    iMod ("Hupd" with "[$]") as "Hupd".
    iModIntro.
    iIntros (?) "%Henc_rep Hargs".
    iIntros (?) "Hrep Hrep_sl".
    wp_pures.
    iRight.
    iModIntro.
    iSplitR; first done.
    wp_pures.
    wp_load.
    wp_apply (Config.wp_Decode with "[$Hrep_sl]").
    { done. }
    iIntros (?) "Hconf_own".
    wp_pures.
    iModIntro.
    iApply "Hupd".
    iFrame.
  }
  {
    iIntros (err) "%Herr Hargs_sl Hrep".
    wp_pures.
    wp_if_destruct.
    {
      exfalso. done.
    }
    iLeft.
    iModIntro.
    iSplitR; first done.
    iFrame.
  }
Qed.

Lemma wp_Clerk__WriteConfig (ck:loc) new_conf new_conf_sl epoch γ Φ :
  is_Clerk ck γ -∗
  is_slice_small new_conf_sl uint64T 1 new_conf -∗
  □ (£ 1 -∗ |={⊤,∅}=> ∃ latest_epoch, own_epoch γ latest_epoch ∗
      if (decide (latest_epoch = epoch)) then
        ∃ conf, own_config γ conf ∗ (own_config γ new_conf -∗ own_epoch γ epoch ={∅,⊤}=∗
                                      is_slice_small new_conf_sl uint64T 1 new_conf -∗
                                            Φ #0)
      else
        (own_epoch γ latest_epoch ={∅,⊤}=∗ (∀ (err:u64), ⌜err ≠ 0⌝ →
                                                         is_slice_small new_conf_sl uint64T 1 new_conf -∗
                                                         Φ #err))
  ) -∗
  (∀ (err:u64) , ⌜err ≠ 0⌝ → is_slice_small new_conf_sl uint64T 1 new_conf -∗ Φ #err) -∗
  WP config.Clerk__WriteConfig #ck #epoch (slice_val new_conf_sl)
  {{ Φ }}
.
Proof.
  iIntros "#Hck Hconf_sl #HΦ Hfail".
  wp_call.
  wp_apply (wp_ref_of_zero).
  { done. }
  iIntros (reply_ptr) "Hreply".
  wp_pures.

  wp_pures.
  iNamed "Hck".
  wp_apply (wp_slice_len).
  wp_apply (wp_NewSliceWithCap).
  { apply encoding.unsigned_64_nonneg. }
  iIntros (?) "Hargs_sl".
  wp_apply (wp_ref_to).
  { done. }
  iIntros (args_ptr) "Hargs".
  wp_pures.

  wp_load.
  wp_apply (wp_WriteInt with "Hargs_sl").
  iIntros (args_sl) "Hargs_sl".
  wp_store.
  wp_apply (Config.wp_Encode with "Hconf_sl").
  iIntros (enc_new_conf enc_new_conf_sl) "(%Henc_new_conf & Hconf & Henc_conf_sl)".
  wp_load.
  iDestruct (is_slice_to_small with "Henc_conf_sl") as "Henc_conf_sl".
  wp_apply (wp_WriteBytes with "[$Hargs_sl $Henc_conf_sl]").
  iIntros (args_sl2) "[Hargs_sl Henc_conf_sl]".
  replace (int.nat 0%Z) with 0%nat by word.
  wp_store.

  wp_apply (wp_frame_wand with "Hconf").

  wp_load.
  wp_loadField.
  iDestruct (is_slice_to_small with "Hargs_sl") as "Hargs_sl".
  iNamed "Hhost".
  wp_apply (wp_Client__Call2 with "Hcl_rpc [] Hargs_sl Hreply").
  {
    iDestruct "Hhost" as "[_ [_ [$ _]]]".
  }
  {
    iModIntro.
    iNext.
    iExists _, _, _.
    iSplitR; first done.
    iSplitR; first done.
    iIntros "Hlc".
    iMod ("HΦ" with "Hlc") as "Hupd".
    iModIntro.
    iDestruct "Hupd" as (?) "(H1 & Hupd)".
    iExists _.
    iFrame "H1".
    destruct (decide (_)).
    {
      iDestruct "Hupd" as (?) "[H1 Hupd]".
      iExists _.
      iFrame "H1".
      iIntros "H1 H2".
      iMod ("Hupd" with "H1 H2") as "Hupd".
      iModIntro.
      iIntros (?) "%Henc_rep Hargs_sl".
      iIntros (?) "Hrep Hrep_sl".
      wp_pures.
      wp_load.
      rewrite Henc_rep.
      wp_apply (wp_ReadInt with "Hrep_sl").
      iIntros (?) "_".
      wp_pures.
      iModIntro.
      iIntros "Hconf".
      iApply "Hupd".
      iFrame.
    }
    {
      iIntros "H1".
      iMod ("Hupd" with "H1") as "Hupd".
      iModIntro.
      iIntros (err Herr_nz reply Henc_rep) "Hargs_sl".
      iIntros (?) "Hrep Hrep_sl".
      wp_pures.
      wp_load.
      rewrite Henc_rep.
      wp_apply (wp_ReadInt with "Hrep_sl").
      iIntros (?) "_".
      wp_pures.
      iModIntro.
      iIntros.
      iApply "Hupd".
      { done. }
      { iFrame. }
    }
  }
  {
    iIntros (err) "%Herr_nz Hargssl Hrep".
    wp_pures.
    wp_if_destruct.
    {
      exfalso. done.
    }
    iModIntro.
    iIntros.
    iApply "Hfail".
    { done. }
    done.
  }
Qed.

Definition makeConfigServer_pre γ conf : iProp Σ := own_epoch γ 0 ∗ own_config γ conf.

Lemma wp_MakeServer γ conf_sl conf :
  {{{
        makeConfigServer_pre γ conf ∗
        is_slice_small conf_sl uint64T 1 conf
  }}}
    config.MakeServer (slice_val conf_sl)
  {{{
        (s:loc), RET #s; is_Server s γ
  }}}.
Proof.
  iIntros (Φ) "([Hepoch Hconf] & Hconf_sl) HΦ".
  wp_call.
  wp_apply (wp_allocStruct).
  { Transparent slice.T. repeat econstructor. Opaque slice.T. }
  iIntros (s) "Hs".
  iDestruct (struct_fields_split with "Hs") as "HH".
  iNamed "HH".
  simpl.
  wp_pures.
  wp_apply (wp_new_free_lock).
  iIntros (mu) "Hmu_inv".
  wp_storeField.
  wp_storeField.
  wp_storeField.
  iMod (readonly_alloc_1 with "mu") as "#Hmu".
  iApply "HΦ".
  iExists _.
  iMod (alloc_lock with "Hmu_inv [Hepoch Hconf epoch config Hconf_sl]") as "$".
  {
    iNext.
    iExists _, _, _.
    iFrame.
  }
  iFrame "Hmu".
  done.
Qed.

Lemma wp_Server__Serve s γ host :
  is_host host γ -∗ is_Server s γ -∗
  {{{
        True
  }}}
    config.Server__Serve #s #host
  {{{
        RET #(); True
  }}}.
Proof.
  iIntros "#Hhost #His_srv !#" (Φ) "_ HΦ".
  wp_call.

  wp_apply (map.wp_NewMap).
  iIntros (handlers) "Hhandlers".

  wp_pures.
  wp_apply (wp_Server__GetEpochAndConfig).
  { done. }
  iIntros (getEpochFn) "#HgetEpochSpec".
  wp_apply (map.wp_MapInsert with "Hhandlers").
  iIntros "Hhandlers".
  wp_pures.

  wp_pures.
  wp_apply (wp_Server__GetConfig).
  { done. }
  iIntros (getFn) "#HgetSpec".
  wp_apply (map.wp_MapInsert with "Hhandlers").
  iIntros "Hhandlers".
  wp_pures.

  wp_pures.
  wp_apply (wp_Server__WriteConfig).
  { done. }
  iIntros (writeConfigFn) "#HwriteSpec".
  wp_apply (map.wp_MapInsert with "Hhandlers").
  iIntros "Hhandlers".
  wp_pures.

  wp_apply (urpc_proof.wp_MakeServer with "Hhandlers").
  iIntros (r) "Hr".
  wp_pures.

  iNamed "Hhost".
  wp_apply (wp_StartServer2 with "[$Hr]").
  {
    set_solver.
  }
  {
    iDestruct "Hhost" as "(H1&H2&H3&Hhandlers)".
    unfold handlers_complete.
    repeat rewrite dom_insert_L.
    rewrite dom_empty_L.
    iSplitL "".
    {
      iExactEq "Hhandlers".
      f_equal.
      set_solver.
    }

    iApply (big_sepM_insert_2 with "").
    {
      iExists _; iFrame "#".
    }
    iApply (big_sepM_insert_2 with "").
    {
      iExists _; iFrame "#".
    }
    iApply (big_sepM_insert_2 with "").
    {
      iExists _; iFrame "#".
    }
    by iApply big_sepM_empty.
  }
  wp_pures.
  by iApply "HΦ".
Qed.

End config_proof.

(*
  handler_spec γ.(urpc_gn) host (U64 0) (GetEpochAndConfig_spec γ) ∗
  handler_spec γ.(urpc_gn) host (U64 1) (GetConfig_spec γ) ∗
  handler_spec γ.(urpc_gn) host (U64 2) (WriteConfig_spec γ) ∗
  handlers_dom γ.(urpc_gn) {[ (U64 0) ; (U64 1) ; (U64 2)]}
*)

Section config_init.

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

Definition config_spec_list γ :=
  [ (U64 0, GetEpochAndConfig_spec γ) ;
    (U64 1, GetConfig_spec γ) ;
    (U64 2, WriteConfig_spec γ)].

Lemma config_ghost_init conf :
  ⊢ |==> ∃ γ,
    makeConfigServer_pre γ conf ∗
    own_epoch γ 0 ∗ own_config γ conf.
Proof.
  iMod (mono_nat_own_alloc 0) as (γepoch) "[[Hepoch Hepoch2] _]".
  iMod (ghost_var_alloc conf) as (γconf) "[Hconf Hconf2]".
  iExists {| epoch_gn := _ ; config_val_gn:= _ |}.
  iModIntro.
  iFrame.
Qed.

Lemma config_server_init host γ :
  host c↦ ∅ ={⊤}=∗
  is_host host γ.
Proof.
  iIntros "Hchan".
  iMod (handler_is_init_list2 host (config_spec_list γ) with "Hchan") as (γrpc) "H".
  { simpl. set_solver. }
  iModIntro.
  iExists γrpc.
  simpl.
  iDestruct "H" as "(H1 & $ & $ & $ & _)".
  iExactEq "H1".
  f_equal.
  set_solver.
Qed.

End config_init.