Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsIntro.Specs.table_create.

Local Open Scope Z_scope.

Section Spec.

  Definition table_create1_spec (g_rd: Pointer) (map_addr: Z64) (level: Z64) (g_rtt': Pointer) (rtt_addr: Z64) (adt: RData) : option (RData * Z64) :=
    match map_addr, level, rtt_addr with
    | VZ64 map_addr, VZ64 level, VZ64 rtt_addr =>
      rely is_int64 map_addr; rely is_int64 rtt_addr; rely GRANULE_ALIGNED map_addr; rely is_int64 level;
      let idx0 := __addr_to_idx map_addr 0 in
      let idx1 := __addr_to_idx map_addr 1 in
      let idx2 := __addr_to_idx map_addr 2 in
      let idx3 := __addr_to_idx map_addr 3 in
      let ret_idx := (if level =? 1 then idx0 else if level =? 2 then idx1 else if level =? 3 then idx2 else idx3) in
      let rtt_gidx := __addr_to_gidx rtt_addr in
      rely is_gidx rtt_gidx;
      rely (peq (base g_rd) ginfo_loc);
      rely (peq (base g_rtt') ginfo_loc);
      rely (offset g_rtt' =? rtt_gidx);
      rely prop_dec ((buffer (priv adt)) @ SLOT_RD = None);
      rely prop_dec ((buffer (priv adt)) @ SLOT_TABLE = None);
      rely prop_dec ((buffer (priv adt)) @ SLOT_DELEGATED = None);
      let rd_gidx := (offset g_rd) in
      let grd := (gs (share adt)) @ rd_gidx in
      rely (g_tag (ginfo grd) =? GRANULE_STATE_RD);
      rely prop_dec (glock grd = Some CPU_ID);
      let root_gidx := (g_rtt (gnorm grd)) in
      rely is_gidx rd_gidx; rely is_gidx root_gidx;
      when adt == query_oracle adt;
      (* hold root lock *)
      let groot := (gs (share adt)) @ root_gidx in
      rely (tbl_level (gaux groot) =? 0);
      rely prop_dec (glock groot = None);
      if level =? 1 then
        (* walk until root *)
        let adt := adt {log: EVT CPU_ID (RTT_WALK root_gidx map_addr 0) :: log adt} in
        let adt :=  adt {priv: (priv adt) {wi_llt: root_gidx} {wi_index: idx0}} in
        create_table root_gidx idx0 rtt_addr rtt_gidx rd_gidx 1 map_addr adt
      else
        (* walk deeper root *)
        rely (level >? 1);
        rely (g_tag (ginfo groot) =? GRANULE_STATE_TABLE);
        rely (gtype groot =? GRANULE_STATE_TABLE);
        let entry0 := (g_data (gnorm groot)) @ idx0 in
        rely is_int64 entry0;
        let phys0 := __entry_to_phys entry0 3 in
        let lv1_gidx := __addr_to_gidx phys0 in
        if (__entry_is_table entry0) && (GRANULE_ALIGNED phys0) && (is_gidx lv1_gidx) then
          (* level 1 valid, hold level 1 lock *)
          let adt := adt {log: EVT CPU_ID (RTT_WALK root_gidx map_addr 1) :: log adt} in
          let glv1 := (gs (share adt)) @ lv1_gidx in
          rely prop_dec (glock glv1 = None);
          rely (tbl_level (gaux glv1) =? 1);
          if level =? 2 then
            (* walk until level 1 *)
            let adt :=  adt {priv: (priv adt) {wi_llt: lv1_gidx} {wi_index: idx1}} in
            create_table lv1_gidx idx1 rtt_addr rtt_gidx rd_gidx 2 map_addr adt
          else
            (* walk deeper level 1 *)
            rely (level >? 2);
            rely (g_tag (ginfo glv1) =? GRANULE_STATE_TABLE);
            rely (gtype glv1 =? GRANULE_STATE_TABLE);
            let entry1 := (g_data (gnorm glv1)) @ idx1 in
            rely is_int64 entry1;
            let phys1 := __entry_to_phys entry1 3 in
            let lv2_gidx := __addr_to_gidx phys1 in
            if (__entry_is_table entry1) && (GRANULE_ALIGNED phys1) && (is_gidx lv2_gidx) then
              (* level 2 valid, hold level 2 lock *)
              let adt := adt {log: EVT CPU_ID (REL lv1_gidx glv1 {glock: Some CPU_ID}) :: EVT CPU_ID (ACQ lv2_gidx) :: log adt} in
              let glv2 := (gs (share adt)) @ lv2_gidx in
              rely (tbl_level (gaux glv2) =? 2);
              rely prop_dec (glock glv2 = None);
              if level =? 3 then
                (* walk until level 2 *)
                let adt :=  adt {priv: (priv adt) {wi_llt: lv2_gidx} {wi_index: idx2}} in
                create_table lv2_gidx idx2 rtt_addr rtt_gidx rd_gidx 3 map_addr adt
              else None
            else
              (* level 2 invalid *)
              Some (adt {log: EVT CPU_ID (REL lv1_gidx glv1 {glock: Some CPU_ID}) :: log adt}
                        {priv: (priv adt) {wi_llt: 0} {wi_index: ret_idx}}, VZ64 1)
        else
          (* level 1 invalid *)
          Some (adt {priv: (priv adt) {wi_llt: 0} {wi_index: ret_idx}}, VZ64 1)
    end.

End Spec.


Require Import Coq.Lists.List.
Import ListNotations.

Require Import Tactics.
Require Import Axioms.
Require Import Sigma.
Require Import Equality.
Require Import Sequence.
Require Import Relation.
Require Import Ordinal.
Require Import Syntax.
Require Import SimpSub.
Require Import Dynamic.
Require Import Ofe.
Require Import Uniform.
Require Import Intensional.
Require Import Candidate.
Require Import System.
Require Import Semantics.
Require Import SemanticsKnot.
Require Import Judgement.
Require Import Hygiene.
Require Import ProperClosed.
Require Import ProperFun.
Require Import Shut.

Require Import SemanticsKuniv.
Require Import SemanticsUniv.
Require Import Defined.
Require Import PageType.
Require Import ProperLevel.

Lemma sound_kuniv_formation :
  forall G lv lv',
    pseq G (deq lv lv' pagetp)
    -> pseq G (deqtype (kuniv lv) (kuniv lv')).
Proof.
intros G lv1 lv2.
revert G.
refine (seq_pseq 0 1 [] _ _ _); cbn.
intros G Hseq.
rewrite -> seq_eqtype.
rewrite -> seq_deq in Hseq.
intros i s s' Hs.
so (Hseq i s s' Hs) as (R & Hpagetp & _ & Hlv1 & Hlv2 & Hlv12).
so (interp_pagetp_invert _#7 Hpagetp Hlv1) as (pg & Hlv1l & Hlv1r).
so (interp_pagetp_invert _#7 Hpagetp Hlv2) as (pg' & Hlv2l & Hlv2r).
so (interp_pagetp_invert _#7 Hpagetp Hlv12) as (pg'' & Hlv1l' & Hlv2r').
so (pginterp_fun _#3 Hlv1l Hlv1l'); subst pg''.
so (pginterp_fun _#3 Hlv2r Hlv2r'); subst pg'.
so (pginterp_lt_top _ _ Hlv1l) as hl.
so (pginterp_succ_lt_top _ _ hl Hlv1l) as hls.
exists (iukuniv the_system i pg hl).
simpsub.
do2 3 split;
apply interp_eval_refl; apply interp_kuniv; eauto using pginterp_str_top, pginterp_cex_top.
Qed.

Local Ltac prove_hygiene :=
  repeat (first [ apply hygiene_shift_permit
                | apply hygiene_sumbool
                | apply natlit_closed
                | apply hygiene_auto; cbn; repeat2 split; auto
                ]);
  eauto using hygiene_weaken, clo_min, hygiene_shift', hygiene_subst1;
  try (apply hygiene_var; cbn; auto; done).

Lemma pginterp_succ :
  forall lv pg h,
    pginterp lv pg
    -> pginterp (nsucc lv) (succ_page pg h).
Proof.
intros lv pg h Hlv.
destruct Hlv as (w & Hint & Hstr & Hcex & Hcin).
destruct Hint as (l & Hint & ->).
assert (natinterp (nsucc lv) (S l)) as Hint'.
  {
  apply natinterp_nsucc; auto.
  }
exists (fin (S l)); do2 3 split; cbn; auto.
  {
  exists (S l); auto.
  }

  {
  rewrite -> Hstr.
  apply succ_fin.
  }

  {
  rewrite -> Hcex.
  apply succ_fin.
  }

  {
  rewrite -> Hcex.
  apply succ_fin.
  }
Qed.

Lemma sound_kuniv_formation_univ :
  forall G lv lv1 lv2,
    pseq G (deq lv1 lv2 pagetp)
    -> pseq G (deq lv lv pagetp)
    -> pseq G (deq triv triv (ltpagetp (nsucc lv1) lv))
    -> pseq G (deq (kuniv lv1) (kuniv lv2) (univ lv)).
Proof.
intros G lv lv1 lv2.
revert G.
refine (seq_pseq 0 3 [] _ [] _ [] _ _ _); cbn.
intros G Hseqlv12 Hseqlv Hseqlt.
rewrite seq_deq in Hseqlv12, Hseqlv, Hseqlt |- *.
intros i s s' Hs.
so (pwctx_impl_closub _#4 Hs) as (Hcls & Hcls').
so (Hseqlv12 _#3 Hs) as (R & Hpagetp & _ & Hlv1 & Hlv2 & Hlv12).
so (interp_pagetp_invert _#7 Hpagetp Hlv1) as (pg & Hlv1l & Hlv1r).
so (interp_pagetp_invert _#7 Hpagetp Hlv2) as (pg' & Hlv2l & Hlv2r).
so (interp_pagetp_invert _#7 Hpagetp Hlv12) as (pg'' & Hlv1l' & Hlv2r').
so (pginterp_fun _#3 Hlv1l Hlv1l'); subst pg''.
so (pginterp_fun _#3 Hlv2r Hlv2r'); subst pg'.
clear R Hpagetp Hlv1 Hlv2 Hlv12.
so (Hseqlv _#3 Hs) as (R & Hpagetp & _ & Hlv & _).
so (interp_pagetp_invert _#7 Hpagetp Hlv) as (pg' & Hlvl & Hlvr).
clear R Hpagetp Hlv.
so (Hseqlt _#3 Hs) as (R & Hintlt & _ & Hinhlt & _).
so (pginterp_lt_top _ _ Hlv1l) as hl.
simpsubin Hintlt.
so (pginterp_succ _ _ hl Hlv1l) as Hlvsucc.
so (interp_ltpagetp_invert _#11 Hintlt Hinhlt Hlvsucc Hlvl) as Hlt.
so (lt_le_page_trans _#3 (lt_page_succ _ hl) (lt_page_impl_le_page _ _ Hlt)) as Hlt'.
destruct Hlt as (Hltstr & Hltcex).
destruct Hlt' as (Hltstr' & Hltcex').
exists (iuuniv the_system i pg').
simpsub.
assert (sint the_system pg' true i (kuniv (subst s lv1)) (iukuniv the_system i pg hl)) as Hintlv1l.
  {
  rewrite -> sint_unroll.
  apply interp_eval_refl.
  apply interp_kuniv; auto.
  split; auto.
  }
assert (sint the_system pg' false i (kuniv (subst s' lv1)) (iukuniv the_system i pg hl)) as Hintlv1r.
  {
  rewrite -> sint_unroll.
  apply interp_eval_refl.
  apply interp_kuniv; auto.
  split; auto.
  }
assert (sint the_system pg' true i (kuniv (subst s lv2)) (iukuniv the_system i pg hl)) as Hintlv2l.
  {
  rewrite -> sint_unroll.
  apply interp_eval_refl.
  apply interp_kuniv; auto.
  split; auto.
  }
assert (sint the_system pg' false i (kuniv (subst s' lv2)) (iukuniv the_system i pg hl)) as Hintlv2r.
  {
  rewrite -> sint_unroll.
  apply interp_eval_refl.
  apply interp_kuniv; auto.
  split; auto.
  }
do2 4 split;
try (apply interp_eval_refl; apply interp_univ; eauto using pginterp_str_top, pginterp_cex_top; done);
try (cbn; split; auto; exists (iukuniv the_system i pg hl); auto).
Qed.

Lemma sound_kuniv_weaken :
  forall G lv a b,
    pseq G (deq a b (kuniv lv))
    -> pseq G (deq a b (univ (nsucc lv))).
Proof.
intros G lv a b.
revert G.
refine (seq_pseq 0 1 [] _ _ _); cbn.
intros G Hseq.
rewrite -> seq_eqkind in Hseq.
rewrite -> seq_univ.
intros i s s' Hs.
so (Hseq _#3 Hs) as (pg & K & R & hl & Hlvl & Hlvr & _ & _ & _ & _ & Hal & Har & Hbl & Hbr).
set (pg' := succ_page pg hl).
exists pg', R.
simpsub.
do2 5 split; auto.
  {
  apply pginterp_succ; auto.
  }

  {
  apply pginterp_succ; auto.
  }
Qed.

Lemma sound_kuniv_formation_invert :
  forall G lv lv',
    pseq G (deqtype (kuniv lv) (kuniv lv'))
    -> pseq G (deq lv lv' pagetp).
Proof.
intros G l m.
revert G.
refine (seq_pseq 0 1 [] _ _ _); cbn.
intros G Hseq.
rewrite -> seq_eqtype in Hseq.
rewrite -> seq_deq.
intros i s s' Hs.
so (Hseq _#3 Hs) as (R & Hll & Hlr & Hml & Hmr).
simpsubin Hll.
simpsubin Hlr.
simpsubin Hml.
simpsubin Hmr.
invert (basic_value_inv _#6 value_kuniv Hll).
intros pg h Hpgll _ Heq.
invert (basic_value_inv _#6 value_kuniv Hlr).
intros pg' h' Hpglr _ Heq'.
so (iukuniv_inj _#7 (eqtrans Heq (eqsymm Heq'))); subst pg'.
clear Heq'.
so (proof_irrelevance _ h h'); subst h'.
invert (basic_value_inv _#6 value_kuniv Hml).
intros pg' h' Hpgml _ Heq'.
so (iukuniv_inj _#7 (eqtrans Heq (eqsymm Heq'))); subst pg'.
clear Heq'.
so (proof_irrelevance _ h h'); subst h'.
invert (basic_value_inv _#6 value_kuniv Hmr).
intros pg' h' Hpgmr _ Heq'.
so (iukuniv_inj _#7 (eqtrans Heq (eqsymm Heq'))); subst pg'.
clear Heq Heq'.
so (proof_irrelevance _ h h'); subst h'.
exists (nattp_def top i).
simpsub.
destruct Hpgll as (w & Hpgll & Heq & _).
destruct Hpglr as (w' & Hpglr & Heq' & _).
so (eqtrans (eqsymm Heq) Heq'); clear Heq'; subst w'.
destruct Hpgml as (w' & Hpgml & Heq' & _).
so (eqtrans (eqsymm Heq) Heq'); clear Heq'; subst w'.
destruct Hpgmr as (w' & Hpgmr & Heq' & _).
so (eqtrans (eqsymm Heq) Heq'); clear Heq'; subst w'.
clear h Heq pg.
destruct Hpgll as (j & Hpgll & Heq).
destruct Hpglr as (j' & Hpglr & Heq').
injection (eqtrans (eqsymm Heq) Heq').
intros <-; clear Heq'.
destruct Hpgml as (j' & Hpgml & Heq').
injection (eqtrans (eqsymm Heq) Heq').
intros <-; clear Heq'.
destruct Hpgmr as (j' & Hpgmr & Heq').
injection (eqtrans (eqsymm Heq) Heq').
intros <-; clear Heq'.
clear Heq.
so (succ_nodecrease top) as Htop.
do2 4 split.
  {
  apply interp_nattp.
  }

  {
  apply interp_nattp.
  }

  {
  rewrite -> nattp_nat_urel; auto.
  exists j.
  do2 2 split; auto.
  }

  {
  rewrite -> nattp_nat_urel; auto.
  exists j.
  do2 2 split; auto.
  }

  {
  rewrite -> nattp_nat_urel; auto.
  exists j.
  do2 2 split; auto.
  }
Qed.


(* *********************************************************************)
(*                                                                     *)
(*            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                                          *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

(** This file defines the abstract data and the primitives for the MPTComm layer, which will initialize the common part (0-1G, 3G-4G) of all the page tables*)
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 XOmega.

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 CalRealPT.
Require Import CalRealInitPTE.

Require Import AbstractDataType.

Require Export MPTOp.

Section WITHMEM.

  Local Open Scope Z_scope.

  Context `{real_params: RealParams}.

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

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

    Section PTALLOCPDE.

      Lemma ptAllocPDE_high_level_inv:
        forall d d' n vadr v,
          ptAllocPDE_spec n vadr d = Some (d', v) ->
          high_level_invariant d ->
          high_level_invariant d'.
      Proof.
        intros. functional inversion H; subst; eauto.
        inv H0; constructor_gso_simpl_tac.
        - intros; eapply AT_kern_norm'; eauto.
        - intros; eapply AT_usr_norm; eauto.
        - eapply alloc_container_valid'; eauto.
        - apply ptAllocPDE_quota_bounded_AT in H; auto.
        - apply consistent_ppage_norm_hide; try assumption.
        - intros; congruence.
        - eapply dirty_ppage_gss; eauto.
        - intros; congruence.
      Qed.

      Lemma ptAllocPDE_low_level_inv:
        forall d d' n vadr v n',
          ptAllocPDE_spec n vadr d = Some (d', v) ->
          low_level_invariant n' d ->
          low_level_invariant n' d'.
      Proof.
        intros. functional inversion H; subst; eauto.
        inv H0. constructor; eauto.
      Qed.

      Lemma ptAllocPDE_kernel_mode:
        forall d d' n vadr v,
          ptAllocPDE_spec n vadr d = Some (d', v) ->
          kernel_mode d ->
          kernel_mode d'.
      Proof.
        intros. functional inversion H; subst; eauto.
      Qed.

      Global Instance ptAllocPDE_inv: PreservesInvariants ptAllocPDE_spec.
      Proof.
        preserves_invariants_simpl'.
        - eapply ptAllocPDE_low_level_inv; eassumption.
        - eapply ptAllocPDE_high_level_inv; eassumption.
        - eapply ptAllocPDE_kernel_mode; eassumption.
      Qed.

    End PTALLOCPDE.

    Section PTPFREEPDE.

      Lemma ptFreePDE_high_level_inv:
        forall d d' n vadr,
          ptFreePDE_spec n vadr d = Some d' ->
          high_level_invariant d ->
          high_level_invariant d'.
      Proof.
        intros. functional inversion H; subst; eauto.
        inv H0; constructor_gso_simpl_tac.
        - intros; eapply AT_kern_norm; eauto.
        - intros; eapply AT_usr_norm; eauto.
        - apply pfree_quota_bounded_AT; auto.
        - apply consistent_ppage_norm_undef; try assumption.
        - intros; congruence.
        - eapply dirty_ppage_gso_undef; eauto.
        - intros; congruence.
      Qed.

      Lemma ptFreePDE_low_level_inv:
        forall d d' n vadr n',
          ptFreePDE_spec n vadr d = Some d' ->
          low_level_invariant n' d ->
          low_level_invariant n' d'.
      Proof.
        intros. functional inversion H; subst; eauto.
        inv H0. constructor; eauto.
      Qed.

      Lemma ptFreePDE_kernel_mode:
        forall d d' n vadr,
          ptFreePDE_spec n vadr d = Some d' ->
          kernel_mode d ->
          kernel_mode d'.
      Proof.
        intros. functional inversion H; subst; eauto.
      Qed.

      Global Instance ptFreePDE_inv: PreservesInvariants ptFreePDE_spec.
      Proof.
        preserves_invariants_simpl'.
        - eapply ptFreePDE_low_level_inv; eassumption.
        - eapply ptFreePDE_high_level_inv; eassumption.
        - eapply ptFreePDE_kernel_mode; eassumption.
      Qed.

    End PTPFREEPDE.

    Global Instance pt_init_comm_inv: PreservesInvariants pt_init_comm_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 mptcommon_fresh : compatlayer (cdata RData) :=
    pt_alloc_pde ↦ gensem ptAllocPDE_spec
                 ⊕ pt_free_pde ↦ gensem ptFreePDE_spec
                 ⊕ pt_init_comm ↦ gensem pt_init_comm_spec.

  (** ** Layer Definition passthrough  *)
  Definition mptcommon_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

          ⊕ pt_read ↦ gensem ptRead_spec
          ⊕ pt_read_pde ↦ gensem ptReadPDE_spec
          ⊕ pt_insert_aux ↦ gensem ptInsertAux_spec
          ⊕ pt_rmv_aux ↦ gensem ptRmvAux_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 mptcommon : compatlayer (cdata RData) := mptcommon_fresh ⊕ mptcommon_passthrough.

End WITHMEM.


From RecordUpdate Require Import RecordSet.
Import RecordSetNotations.

From Perennial.algebra Require Import liftable auth_map.
From Perennial.Helpers Require Import Transitions.
From Perennial.program_proof Require Import disk_prelude.

From Goose.github_com.mit_pdos.go_nfsd Require Import simple.
From Perennial.program_proof Require Import obj.obj_proof marshal_proof addr_proof crash_lockmap_proof addr.addr_proof buf.buf_proof.
From Perennial.program_proof Require Import jrnl.sep_jrnl_proof.
From Perennial.program_proof Require Import disk_prelude.
From Perennial.program_proof Require Import disk_lib.
From Perennial.Helpers Require Import NamedProps Map List range_set.
From Perennial.program_logic Require Import spec_assert.
From Perennial.goose_lang.lib Require Import slice.typed_slice into_val.
From Perennial.program_proof Require Import simple.spec simple.invariant simple.common.

Section heap.
Context `{!heapGS Σ}.
Context `{!simpleG Σ}.
Implicit Types (stk:stuckness) (E: coPset).

Theorem wp_Inode__WriteInode γ γtxn (inum : u64) len len' blk (l : loc) (btxn : loc) dinit γdurable :
  {{{ is_jrnl_mem Njrnl btxn γ.(simple_jrnl) dinit γtxn γdurable ∗
      is_inode_enc inum len blk (jrnl_maps_to γtxn) ∗
      is_inode_mem l inum len' blk ∗
      ⌜ inum ∈ covered_inodes ⌝
  }}}
    Inode__WriteInode #l #btxn
  {{{ RET #();
      is_jrnl_mem Njrnl btxn γ.(simple_jrnl) dinit γtxn γdurable ∗
      is_inode_enc inum len' blk (jrnl_maps_to γtxn) ∗
      is_inode_mem l inum len' blk }}}.
Proof.
  iIntros (Φ) "(Hjrnl & Henc & Hmem & %Hcovered) HΦ".
  wp_call.
  iNamed "Hmem".
  wp_call.
  wp_apply wp_new_enc. iIntros (enc) "He".
  wp_loadField.
  wp_apply (wp_Enc__PutInt with "He"); first by word. iIntros "He".
  wp_loadField.
  wp_apply (wp_Enc__PutInt with "He"); first by word. iIntros "He".
  wp_apply (wp_Enc__Finish with "He"). iIntros (s data) "(%Hdata & %Hlen & Hs)".
  wp_loadField.
  wp_apply wp_inum2Addr.
  {
    iPureIntro.
    rewrite /covered_inodes in Hcovered.
    eapply rangeSet_lookup in Hcovered; try lia.
    rewrite /NumInodes /InodeSz. simpl. lia.
  }
  iNamed "Henc".
  iDestruct (is_slice_to_small with "Hs") as "Hs".
  wp_apply (wp_Op__OverWrite
    _ _ _ _ _ _ _ _ _ _ _ (existT KindInode (bufInode (list_to_inode_buf data))) with "[$Hjrnl $Hinode_enc_mapsto $Hs]").
  { eauto. }
  { rewrite /data_has_obj /=. apply list_to_inode_buf_to_list.
    rewrite /inode_bytes. word. }
  { eauto. }
  iIntros "[Hjrnl Hinode_enc_mapsto]".
  wp_apply util_proof.wp_DPrintf.
  wp_pures. iModIntro. iApply "HΦ". iFrame.
  iExists _. iFrame. iPureIntro.
  rewrite /encodes_inode.
  rewrite list_to_inode_buf_to_list. 2: { rewrite /inode_bytes; word. }
  eapply Hdata.
Qed.

Lemma length_1_singleton {T} (l : list T) :
  length l = 1 -> ∃ v, l = [v].
Proof.
  destruct l; simpl in *; intros; try lia.
  destruct l; simpl in *; intros; try lia.
  eexists; eauto.
Qed.

Theorem wp_Inode__Write γ γtxn ip inum len blk (btxn : loc) (offset : u64) (count : u64) dataslice databuf γdurable dinit contents :
  {{{ is_jrnl_mem Njrnl btxn γ.(simple_jrnl) dinit γtxn γdurable ∗
      is_inode_mem ip inum len blk ∗
      is_inode_enc inum len blk (jrnl_maps_to γtxn) ∗
      is_inode_data len blk contents (jrnl_maps_to γtxn) ∗
      is_slice_small dataslice u8T 1 databuf ∗
      ⌜ int.nat count = length databuf ⌝ ∗
      ⌜ inum ∈ covered_inodes ⌝
  }}}
    Inode__Write #ip #btxn #offset #count (slice_val dataslice)
  {{{ (wcount: u64) (ok: bool), RET (#wcount, #ok);
      is_jrnl_mem Njrnl btxn γ.(simple_jrnl) dinit γtxn γdurable ∗
      ( ( let contents' := ((firstn (int.nat offset) contents) ++
                          (firstn (int.nat count) databuf) ++
                          (skipn (int.nat offset + int.nat count) contents))%list in
        let len' := U64 (Z.max (int.Z len) (int.Z offset + int.Z count)) in
        is_inode_mem ip inum len' blk ∗
        is_inode_enc inum len' blk (jrnl_maps_to γtxn) ∗
        is_inode_data len' blk contents' (jrnl_maps_to γtxn) ∗
        ⌜ wcount = count ∧ ok = true ∧
          (int.Z offset + length databuf < 2^64)%Z ∧
          (int.Z offset ≤ int.Z len)%Z ⌝ ) ∨
      ( is_inode_mem ip inum len blk ∗
        is_inode_enc inum len blk (jrnl_maps_to γtxn) ∗
        is_inode_data len blk contents (jrnl_maps_to γtxn) ∗
        ⌜ int.Z wcount = 0 ∧ ok = false ⌝ ) )
  }}}.
Proof.
  iIntros (Φ) "(Hjrnl & Hmem & Hienc & Hdata & Hdatabuf & %Hcount & %Hcovered) HΦ".
  wp_call.
  wp_apply util_proof.wp_DPrintf.
  wp_apply wp_slice_len.
  wp_if_destruct.
  { wp_pures. iApply "HΦ". iFrame. iRight. iFrame. done. }
  wp_apply util_proof.wp_SumOverflows.
  iIntros (ok) "%Hok". subst.
  wp_if_destruct.
  { wp_pures. iApply "HΦ". iFrame "Hjrnl". iRight. iFrame. done. }
  wp_if_destruct.
  { wp_pures. iApply "HΦ". iFrame "Hjrnl". iRight. iFrame. done. }
  iNamed "Hmem".
  wp_loadField.
  wp_if_destruct.
  { wp_pures. iApply "HΦ". iFrame "Hjrnl". iRight. iFrame. done. }

  iNamed "Hdata".
  wp_loadField.
  wp_apply wp_block2addr.
  wp_apply (wp_Op__ReadBuf with "[$Hjrnl $Hdiskblk]"); first by eauto.
  iIntros (dirty bufptr) "[Hbuf Hbufdone]".

  wp_apply wp_ref_to; first by val_ty.
  iIntros (count) "Hcount".

  wp_apply (wp_forUpto (λ i,
    ∃ bbuf',
      "Hdatabuf" ∷ is_slice_small dataslice byteT 1 databuf ∗
      "Hbuf" ∷ is_buf bufptr (blk2addr blk) {|
             bufKind := objKind (existT KindBlock (bufBlock bbuf'));
             bufData := objData (existT KindBlock (bufBlock bbuf'));
             bufDirty := dirty |} ∗
      "%Hbbuf" ∷ ⌜ vec_to_list bbuf' = ((firstn (int.nat offset) (vec_to_list bbuf)) ++
                                       (firstn (int.nat i) databuf) ++
                                       (skipn (int.nat offset + int.nat i) (vec_to_list bbuf)))%list ⌝
    )%I with "[] [$Hcount Hdatabuf Hbuf]").
  { word. }
  {
    iIntros (count').
    iIntros (Φ') "!>".
    iIntros "(HI & Hcount & %Hbound) HΦ'".
    iNamed "HI".
    wp_load.
    destruct (databuf !! int.nat count') eqn:He.
    2: {
      iDestruct (is_slice_small_sz with "Hdatabuf") as "%Hlen".
      eapply lookup_ge_None_1 in He. word.
    }
    wp_apply (wp_SliceGet (V:=u8) with "[$Hdatabuf]"); eauto.
    iIntros "Hdatabuf".
    wp_load.
    wp_apply (wp_buf_loadField_data with "Hbuf").
    iIntros (bufslice) "[Hbufdata Hbufnodata]".
    assert (is_Some (vec_to_list bbuf' !! int.nat (word.add offset count'))).
    { eapply lookup_lt_is_Some_2. rewrite vec_to_list_length /block_bytes.
      revert Heqb0. word. }
    wp_apply (wp_SliceSet (V:=u8) with "[$Hbufdata]"); eauto.
    iIntros "Hbufdata".
    wp_pures.
    iApply "HΦ'". iModIntro. iFrame.

    assert ((int.nat (word.add offset count')) < block_bytes) as fin.
    {
      rewrite /is_Some in H.
      destruct H.
      apply lookup_lt_Some in H.
      rewrite vec_to_list_length /block_bytes in H.
      rewrite /block_bytes; lia.
    }
    iExists (vinsert (nat_to_fin fin) u bbuf'). iSplit.
    { iApply is_buf_return_data. iFrame.
      iExactEq "Hbufdata".
      rewrite /= /Block_to_vals vec_to_list_insert.
      rewrite /is_slice_small. f_equal.
      rewrite /list.untype /to_val /u8_IntoVal /b2val. f_equal. f_equal.
      erewrite fin_to_nat_to_fin. reflexivity.
    }
    iPureIntro.
    rewrite vec_to_list_insert Hbbuf.
    erewrite fin_to_nat_to_fin.
    replace (int.nat (word.add offset count')) with ((int.nat offset)+(int.nat count')).
    2: { word. }
    assert ((int.nat offset) = (length (take (int.nat offset) bbuf))) as Hoff.
    1: {
      rewrite take_length.
      rewrite vec_to_list_length.
      revert fin. word_cleanup.
    }
    rewrite -> Hoff at 1.
    rewrite insert_app_r.
    f_equal.
    replace (int.nat count') with (length (take (int.nat count') databuf) + 0) at 1.
    2: {
      rewrite take_length_le; first by lia. word.
    }
    rewrite insert_app_r.
    replace (int.nat (word.add count' 1%Z)) with (S (int.nat count')) at 1 by word.
    erewrite take_S_r; eauto.
    rewrite -app_assoc. f_equal.
    erewrite <- drop_take_drop.
    1: rewrite insert_app_l.
    1: f_equal.
    3: word.
    2: {
      rewrite drop_length.
      rewrite firstn_length_le.
      2: { rewrite vec_to_list_length. revert fin. word. }
      revert fin. word.
    }
    replace (int.nat (word.add count' 1%Z)) with (int.nat count' + 1) by word.
    rewrite Nat.add_assoc.
    rewrite skipn_firstn_comm.
    replace (int.nat offset + int.nat count' + 1 - (int.nat offset + int.nat count')) with 1 by word.
    edestruct (length_1_singleton (T:=u8) (take 1 (drop (int.nat offset + int.nat count') bbuf))) as [x Hx].
    2: { rewrite Hx. done. }
    rewrite firstn_length_le; eauto.
    rewrite drop_length.
    rewrite vec_to_list_length.
    revert fin. word.
  }
  {
    iExists _. iFrame.
    iPureIntro.
    replace (int.nat (U64 0)) with 0 by reflexivity.
    rewrite take_0. rewrite app_nil_l.
    replace (int.nat offset + 0) with (int.nat offset) by lia.
    rewrite take_drop. done.
  }

  iIntros "(HI & Hcount)".
  iNamed "HI".
  wp_apply (wp_Buf__SetDirty with "Hbuf"). iIntros "Hbuf".

  iMod ("Hbufdone" with "Hbuf []") as "[Hjrnl Hdiskblk]".
  { iLeft. done. }

  wp_apply util_proof.wp_DPrintf.
  wp_loadField.

  assert (take (int.nat offset) contents =
          take (int.nat offset) bbuf) as Hcontents0.
  { rewrite -Hdiskdata.
    rewrite take_take. f_equal. lia. }

  assert (drop (int.nat offset + int.nat dataslice.(Slice.sz)) contents =
          drop (int.nat offset + int.nat dataslice.(Slice.sz)) (take (length contents) bbuf))
    as Hcontents1.
  { congruence. }

  assert ( (drop (int.nat offset + int.nat dataslice.(Slice.sz)) bbuf) =
           (drop (int.nat offset + int.nat dataslice.(Slice.sz))
                 (take (length contents) bbuf ++ (drop (length contents) bbuf))))
     as Hbuf.
  { rewrite take_drop; done. }

  assert (length contents ≤ length bbuf) as Hlencontents.
  { eapply (f_equal length) in Hdiskdata.
    rewrite take_length in Hdiskdata. lia. }

  wp_if_destruct.
  { wp_storeField.
    wp_apply (wp_Inode__WriteInode with "[$Hjrnl Hinum Hisize Hidata $Hienc]").
    { iFrame. iFrame "%". }
    iIntros "(Hjrnl & Hienc & Hmem)".
    wp_pures.
    iApply "HΦ". iModIntro. iFrame "Hjrnl". iLeft.
    rewrite Z.max_r.
    2: { revert Heqb2. word. }
    iFrame.
    iSplit.
    2: {
      iPureIntro. intuition eauto.
      { rewrite -Hcount; word. }
      lia.
    }
    iExists _. iFrame. iPureIntro.
    rewrite Hbbuf. rewrite Hcontents0 Hcontents1.
    rewrite !app_length.
    rewrite drop_length.
    rewrite take_length_le; last by ( rewrite vec_to_list_length /block_bytes; word ).
    rewrite take_length_le; last by ( rewrite Hcount; lia ).
    rewrite take_length_le; last by ( rewrite vec_to_list_length /block_bytes; word ).
    replace (length contents) with (int.nat len) by word.
    split. 2: { revert Heqb2. word. }
    rewrite app_assoc. rewrite take_app_le.
    2: {
      rewrite !app_length.
      rewrite take_length_le. 2: rewrite vec_to_list_length /block_bytes; word.
      rewrite take_length_le. 2: rewrite Hcount; lia.
      revert Heqb2. word.
    }
    rewrite firstn_all2.
    2: {
      rewrite !app_length.
      rewrite take_length_le. 2: rewrite vec_to_list_length /block_bytes; word.
      rewrite take_length_le. 2: rewrite Hcount; lia.
      revert Heqb2. word.
    }
    f_equal. rewrite drop_ge. 1: rewrite app_nil_r; eauto.
    rewrite take_length_le. 2: rewrite vec_to_list_length /block_bytes; word.
    rewrite Hcount. revert Heqb2. word.
  }
  { wp_pures.
    iApply "HΦ". iModIntro. iFrame "Hjrnl". iLeft.
    rewrite Z.max_l.
    2: { revert Heqb2. word. }
    replace (U64 (int.Z len)) with (len) by word.
    iFrame.
    iSplit.
    2: {
      iPureIntro. intuition eauto.
      { rewrite -Hcount; word. }
      lia.
    }
    iExists _. iFrame. iPureIntro.
    rewrite Hbbuf. rewrite Hcontents0 Hcontents1 Hbuf.
    rewrite !app_length.
    rewrite drop_length.
    rewrite take_length_le. 2: { rewrite vec_to_list_length /block_bytes. revert Heqb0; word. }
    rewrite take_length_le. 2: { rewrite Hcount; lia. }
    rewrite take_length_le. 2: { lia. }
    replace (length contents) with (int.nat len) by word.
    split. 2: { revert Heqb2. word. }
    rewrite drop_app_le.
    2: {
      rewrite take_length_le. 2: lia.
      revert Heqb2. word.
    }
    rewrite app_assoc. rewrite app_assoc. rewrite take_app_le.
    2: {
      rewrite !app_length.
      rewrite drop_length.
      rewrite take_length_le. 2: lia.
      rewrite take_length_le. 2: rewrite Hcount; lia.
      rewrite take_length_le. 2: lia.
      revert Heqb2. word.
    }
    rewrite firstn_all2.
    1: { rewrite app_assoc; eauto. }

    rewrite !app_length.
    rewrite drop_length.
    rewrite take_length_le. 2: lia.
    rewrite take_length_le. 2: rewrite Hcount; lia.
    rewrite take_length_le. 2: lia.
    revert Heqb2. word.
  }
Qed.

End heap.