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

Require Import Coqlib.
Require Import Errors.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Op.
Require Import Asm.
Require Import Events.
Require Import Globalenvs.
Require Import Smallstep.
Require Import Values.
Require Import Memory.
Require Import Maps.
Require Import CommonTactic.
Require Import AuxLemma.
Require Import FlatMemory.
Require Import AuxStateDataType.
Require Import Constant.
Require Import GlobIdent.
Require Import RealParams.
Require Import AsmImplLemma.
Require Import GenSem.
Require Import RefinementTactic.
Require Import PrimSemantics.
Require Import XOmega.

Require Import liblayers.logic.PTreeModules.
Require Import liblayers.logic.LayerLogicImpl.
Require Import liblayers.compcertx.Stencil.
Require Import liblayers.compcertx.MakeProgram.
Require Import liblayers.compat.CompatLayers.
Require Import liblayers.compat.CompatGenSem.
Require Import compcert.cfrontend.Ctypes.

(*Require Import LAsmModuleSemAux.*)
Require Import LayerCalculusLemma.
Require Import AbstractDataType.

Require Import LoadStoreSem2.

Require Import TTrapArg.
Require Import TrapArgGenSpec.

(** * Definition of the refinement relation*)
Section Refinement.

  Local Open Scope string_scope.
  Local Open Scope error_monad_scope.
  Local Open Scope Z_scope.

  Context `{real_params: RealParams}.

  Notation HDATA := RData.
  Notation LDATA := RData.

  Notation HDATAOps := (cdata (cdata_ops := pproc_data_ops) HDATA).
  Notation LDATAOps := (cdata (cdata_ops := pproc_data_ops) LDATA).

  Section WITHMEM.

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

    (** Relation between raw data at two layers*)
    Record relate_RData (f: meminj) (hadt: HDATA) (ladt: LDATA) :=
      mkrelate_RData {
          flatmem_re: FlatMem.flatmem_inj (HP hadt) (HP ladt);
          devout_re: devout hadt = devout ladt;
          CR3_re:  CR3 hadt = CR3 ladt;
          ikern_re: ikern hadt = ikern ladt;
          pg_re: pg hadt = pg ladt;
          ihost_re: ihost hadt = ihost ladt;
          AC_re: AC hadt = AC ladt;
          ti_fst_re: (fst (ti hadt)) = (fst (ti ladt));
          ti_snd_re: val_inject f (snd (ti hadt)) (snd (ti ladt));
          LAT_re: LAT hadt = LAT ladt;
          nps_re: nps hadt = nps ladt;
          init_re: init hadt = init ladt;

          pperm_re: pperm hadt = pperm ladt;
          PT_re:  PT hadt = PT ladt;
          ptp_re: ptpool hadt = ptpool ladt;
          idpde_re: idpde hadt = idpde ladt;
          ipt_re: ipt hadt = ipt ladt;
          smspool_re: smspool hadt = smspool ladt;

          kctxt_re: kctxt_inj f num_proc (kctxt hadt) (kctxt ladt);
          abtcb_re:  abtcb hadt = abtcb ladt;
          abq_re:  abq hadt = abq ladt;
          cid_re:  cid hadt = cid ladt;
          chpool_re:  syncchpool hadt = syncchpool ladt;
          uctxt_re: uctxt_inj f (uctxt hadt) (uctxt ladt);
          vmxinfo_re: vmxinfo hadt = vmxinfo ladt

        }.

    Inductive match_RData: stencil -> HDATA -> mem -> meminj -> Prop :=
    | MATCH_RDATA: forall habd m f s, match_RData s habd m f.

    Local Hint Resolve MATCH_RDATA.

    Global Instance rel_ops: CompatRelOps HDATAOps LDATAOps :=
      {
        relate_AbData s f d1 d2 := relate_RData f d1 d2;
        match_AbData s d1 m f := match_RData s d1 m f;
        new_glbl := nil
      }.

    (** ** Properties of relations*)
    Section Rel_Property.

      (** Prove that after taking one step, the refinement relation still holds*)
      Lemma relate_incr:
        forall abd abd' f f',
          relate_RData f abd abd'
          -> inject_incr f f'
          -> relate_RData f' abd abd'.
      Proof.
        inversion 1; subst; intros; inv H; constructor; eauto.
        - eapply kctxt_inj_incr; eauto.
        - eapply uctxt_inj_incr; eauto.
      Qed.

      Lemma relate_kernel_mode:
        forall abd abd' f,
          relate_RData f abd abd'
          -> (kernel_mode abd <-> kernel_mode abd').
      Proof.
        inversion 1; simpl; split; congruence.
      Qed.

      Lemma relate_observe:
        forall p abd abd' f,
          relate_RData f abd abd' ->
          observe p abd = observe p abd'.
      Proof.
        inversion 1; simpl; unfold ObservationImpl.observe; congruence.
      Qed.

      Global Instance rel_prf: CompatRel HDATAOps LDATAOps.
      Proof.
        constructor; intros; simpl; trivial.
        eapply relate_incr; eauto.
        eapply relate_kernel_mode; eauto.
        eapply relate_observe; eauto.
      Qed.

    End Rel_Property.

    (** * Proofs the one-step forward simulations for the low level specifications*)
    Section OneStep_Forward_Relation.

      (** ** The low level specifications exist*)
      Section Exists.

        Lemma uctx_argn_exist':
          forall n s habd z labd f,
            uctx_argn_spec n habd = Some z ->
            0 <= n < UCTXT_SIZE ->
            0 <= cid habd < num_proc ->
            relate_AbData s f habd labd ->
            uctx_argn_spec n labd = Some z
            /\ kernel_mode labd.
        Proof.
          intros. split.
          - eapply uctx_argn_exist; eauto.
          - unfold uctx_argn_spec in *.
            inv H2. revert H; subrewrite.
            simpl; subdestruct. eauto.
        Qed.

        Lemma uctx_set_regk_exist':
          forall k s habd habd' labd n f,
            uctx_set_regk_spec k n habd = Some habd'
            -> relate_AbData s f habd labd
            -> 0 <= cid habd < num_proc
            -> exists labd', uctx_set_regk_spec k n labd = Some labd'
                             /\ relate_AbData s f habd' labd'
                             /\ kernel_mode labd.
        Proof.
          intros. exploit uctx_set_regk_exist; eauto.
          intros (labd' & He & HR).
          refine_split'; eauto.
          unfold uctx_set_regk_spec in He.
          simpl; subdestruct. eauto.
        Qed.

      End Exists.

      Section FRESH_PRIM.

        Lemma uctx_arg1_spec_ref:
          compatsim (crel HDATA LDATA) (gensem uctx_arg1_spec) uctx_arg1_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          exploit uctx_argn_exist'; eauto 1.
          - omega.
          - eapply valid_curid; eauto.
          - intros [HP Hkern].
            refine_split; try econstructor; eauto.
        Qed.

        Lemma uctx_arg2_spec_ref:
          compatsim (crel HDATA LDATA) (gensem uctx_arg2_spec) uctx_arg2_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          exploit uctx_argn_exist'; eauto 1.
          - omega.
          - eapply valid_curid; eauto.
          - intros [HP Hkern].
            refine_split; try econstructor; eauto.
        Qed.

        Lemma uctx_arg3_spec_ref:
          compatsim (crel HDATA LDATA) (gensem uctx_arg3_spec) uctx_arg3_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          exploit uctx_argn_exist'; eauto 1.
          - omega.
          - eapply valid_curid; eauto.
          - intros [HP Hkern].
            refine_split; try econstructor; eauto.
        Qed.

        Lemma uctx_arg4_spec_ref:
          compatsim (crel HDATA LDATA) (gensem uctx_arg4_spec) uctx_arg4_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          exploit uctx_argn_exist'; eauto 1.
          - omega.
          - eapply valid_curid; eauto.
          - intros [HP Hkern].
            refine_split; try econstructor; eauto.
        Qed.

        Lemma uctx_arg5_spec_ref:
          compatsim (crel HDATA LDATA) (gensem uctx_arg5_spec) uctx_arg5_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          exploit uctx_argn_exist'; eauto 1.
          - omega.
          - eapply valid_curid; eauto.
          - intros [HP Hkern].
            refine_split; try econstructor; eauto.
        Qed.

        Lemma uctx_arg6_spec_ref:
          compatsim (crel HDATA LDATA) (gensem uctx_arg6_spec) uctx_arg6_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          exploit uctx_argn_exist'; eauto 1.
          - omega.
          - eapply valid_curid; eauto.
          - intros [HP Hkern].
            refine_split; try econstructor; eauto.
        Qed.

        Lemma uctx_set_errno_spec_ref:
          compatsim (crel HDATA LDATA) (gensem uctx_set_errno_spec) uctx_set_errno_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          exploit uctx_set_regk_exist'; eauto 1.
          - eapply valid_curid; eauto.
          - intros [labd' [HP [HM Hkern]]].
            refine_split; try econstructor; eauto.
            constructor.
        Qed.

        Lemma uctx_set_retval1_spec_ref:
          compatsim (crel HDATA LDATA) (gensem uctx_set_retval1_spec) uctx_set_retval1_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          exploit uctx_set_regk_exist'; eauto 1.
          - eapply valid_curid; eauto.
          - intros [labd' [HP [HM Hkern]]].
            refine_split; try econstructor; eauto.
            constructor.
        Qed.

        Lemma uctx_set_retval2_spec_ref:
          compatsim (crel HDATA LDATA) (gensem uctx_set_retval2_spec) uctx_set_retval2_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          exploit uctx_set_regk_exist'; eauto 1.
          - eapply valid_curid; eauto.
          - intros [labd' [HP [HM Hkern]]].
            refine_split; try econstructor; eauto.
            constructor.
        Qed.

        Lemma uctx_set_retval3_spec_ref:
          compatsim (crel HDATA LDATA) (gensem uctx_set_retval3_spec) uctx_set_retval3_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          exploit uctx_set_regk_exist'; eauto 1.
          - eapply valid_curid; eauto.
          - intros [labd' [HP [HM Hkern]]].
            refine_split; try econstructor; eauto.
            constructor.
        Qed.

        Lemma uctx_set_retval4_spec_ref:
          compatsim (crel HDATA LDATA) (gensem uctx_set_retval4_spec) uctx_set_retval4_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          exploit uctx_set_regk_exist'; eauto 1.
          - eapply valid_curid; eauto.
          - intros [labd' [HP [HM Hkern]]].
            refine_split; try econstructor; eauto.
            constructor.
        Qed.

      End FRESH_PRIM.

      Global Instance: (LoadStoreProp (hflatmem_store:= flatmem_store) (lflatmem_store:= flatmem_store)).
      Proof.
        accessor_prop_tac.
        - eapply flatmem_store_exists; eauto.
      Qed.

      Lemma passthrough_correct:
        sim (crel HDATA LDATA) ttraparg_passthrough pproc.
      Proof.
        sim_oplus.
        - apply fload_sim.
        - apply fstore_sim.
        - apply device_output_sim.
        (*- apply pfree_sim.*)
        - apply ptRead_sim.
        - apply ptResv_sim.
        - apply shared_mem_status_sim.
        - apply offer_shared_mem_sim.
        - apply get_curid_sim.
        - apply thread_wakeup_sim.
        (*- apply is_chan_ready_sim.
          - apply sendto_chan_sim.
          - apply receive_chan_sim.*)
        - apply syncreceive_chan_sim.
        - apply syncsendto_chan_pre_sim.
        - apply syncsendto_chan_post_sim.
        - apply uctx_get_sim.
        - apply uctx_set_sim.
        - apply proc_create_sim.
          (*
        - apply rdmsr_sim.
        - apply wrmsr_sim.
        - apply vmx_set_intercept_intwin_sim.
        - apply vmx_set_desc_sim.
        - apply vmx_inject_event_sim.
        - apply vmx_set_tsc_offset_sim.
        - apply vmx_get_tsc_offset_sim.
        - apply vmx_get_exit_reason_sim.
        - apply vmx_get_exit_fault_addr_sim.
        - apply vmx_check_pending_event_sim.
        - apply vmx_check_int_shadow_sim.
        - apply vmx_get_reg_sim.
        - apply vmx_set_reg_sim.
        - apply vmx_get_next_eip_sim.
        - apply vmx_get_io_width_sim.
        - apply vmx_get_io_write_sim.
        - apply vmx_get_exit_io_rep_sim.
        - apply vmx_get_exit_io_str_sim.
        - apply vmx_get_exit_io_port_sim.
        - apply vmx_set_mmap_sim.
        - apply vm_run_sim, VMX_INJECT.
        - apply vmx_return_from_guest_sim, VMX_INJECT.
        - apply vmx_init_sim.
        - apply vmx_init_sim.*)
        - apply proc_init_sim.
        - apply container_get_nchildren_sim.
        - apply container_get_quota_sim.
        - apply container_get_usage_sim.
        - apply container_can_consume_sim.
        - apply alloc_sim.
        - apply trap_info_get_sim.
        - apply trap_info_ret_sim.
        - apply thread_yield_sim.
        - apply thread_sleep_sim.
        - apply proc_start_user_sim.
          intros. eapply valid_curid; eauto.
        - apply proc_exit_user_sim.
        - layer_sim_simpl.
          + eapply load_correct2.
          + eapply store_correct2.
      Qed.

    End OneStep_Forward_Relation.

  End WITHMEM.

End Refinement.


(**************************************************************************)
(*  This file is part of CertrBPF,                                        *)
(*  a formally verified rBPF verifier + interpreter + JIT in Coq.         *)
(*                                                                        *)
(*  Copyright (C) 2022 Inria                                              *)
(*                                                                        *)
(*  This program is free software; you can redistribute it and/or modify  *)
(*  it under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation; either version 2 of the License, or     *)
(*  (at your option) any later version.                                   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful,       *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU General Public License for more details.                          *)
(*                                                                        *)
(**************************************************************************)

From Coq Require Import List ZArith.
Import ListNotations.
From dx Require Import ResultMonad IR.
From bpf.comm Require Import MemRegion Regs State Monad rBPFAST rBPFValues rBPFMonadOp.
From bpf.monadicmodel Require Import rBPFInterpreter.

From compcert Require Import Coqlib Values Clight Memory Integers.

From bpf.clight Require Import interpreter.

From bpf.clightlogic Require Import Clightlogic clight_exec CommonLemma CorrectRel.

From bpf.simulation Require Import MatchState InterpreterRel.

(*
Check get_mem_region.

get_mem_region
     : nat -> MyMemRegionsType -> M memory_region *)

Section Get_mem_region.
  Context {S: special_blocks}.

  (** The program contains our function of interest [fn] *)
  Definition p : Clight.program := prog.

  (* [Args,Res] provides the mapping between the Coq and the C types *)
  Definition args : list Type := [(nat:Type); (list memory_region:Type)].
  Definition res : Type := (memory_region:Type).

  (* [f] is a Coq Monadic function with the right type *)
  Definition f : arrow_type args (M State.state res) := get_mem_region.

  (* [fn] is the Cligth function which has the same behaviour as [f] *)
  Definition fn: Clight.function := f_get_mem_region.

  (* [match_arg] relates the Coq arguments and the C arguments *)
  Definition match_arg_list : DList.t (fun x => x -> Inv _) args :=
      (dcons (fun x => StateLess _ (nat_correct x))
        (dcons (fun x => StateFull _ (mrs_correct S x))
                (DList.DNil _))).

  (* [match_res] relates the Coq result and the C result *)
  Definition match_res : res -> Inv State.state := fun r  => StateFull _ (mr_correct r).

Lemma memory_region_in_nth_error:
  forall n l
    (Hrange : (0 <= Z.of_nat n < Z.of_nat (List.length l))%Z),
      exists (m:memory_region), nth_error l n = Some m.
Proof.
  intros.
  destruct Hrange as (Hlow & Hhigh).
  rewrite <- Nat2Z.inj_lt in Hhigh.
  rewrite <- List.nth_error_Some in Hhigh.
  destruct (nth_error l n).
  - exists m; reflexivity.
  - exfalso; apply Hhigh; reflexivity.
Qed.

  Instance correct_function_get_mem_region : forall a, correct_function _ p args res f fn ModNothing true match_state match_arg_list match_res a.
  Proof.
    correct_function_from_body args.
    correct_body.
    unfold INV.
    unfold f.
    repeat intro; simpl.
    destruct get_mem_region eqn: Hregion; [|constructor].
    destruct p0.
    intros.
    get_invariant _n.
    get_invariant _mrs.

    unfold eval_inv, nat_correct in c1.
    unfold eval_inv, mrs_correct, match_regions in c2.
    destruct c1 as (c1 & _).
    destruct c2 as (Hv0_eq & Hmrs_eq & (Hmrs_num_eq & Hrange & Hmatch) & Hst).
    subst.
    assert (MOD : m = m /\ st = s).
    {
      unfold get_mem_region in Hregion.
      destruct (c <? mrs_num st)%nat ; try discriminate.
      destruct (nth_error (bpf_mrs st) c); try congruence.
      intuition congruence.
    }
    destruct MOD ; subst.
    eexists; exists m, Events.E0.
    split_and; auto.
    - {
      unfold step2.
      repeat forward_star.
    }
    -
    unfold get_mem_region in Hregion.
    context_destruct_if_inversion.
    rewrite Nat.ltb_lt in Hcond.
    unfold match_list_region in Hmatch.
    rewrite Hmrs_num_eq in Hmatch.
    assert (HrangeNat: (0 <= c < mrs_num s)%nat) by lia.
    specialize (Hmatch c HrangeNat).
    (**r because 0<=c < length mrs, so we know nth_error must return Some mr *)
    assert (HrangeZ: (0 <= Z.of_nat c < Z.of_nat (mrs_num s))%Z) by lia.
    rewrite <- Hmrs_num_eq in HrangeZ.
    apply memory_region_in_nth_error with (n:=c) (l:= bpf_mrs s) in HrangeZ as Hnth_error.
    destruct Hnth_error as (mr & Hnth_error).
    rewrite Hnth_error in H2.
    inversion H2.
    eapply nth_error_nth in Hnth_error.
    rewrite Hnth_error in Hmatch.
    subst.
    {
      unfold match_res, mr_correct, match_region.
      split.
      apply nth_In; lia.
      split; [| assumption].
      rewrite Ptrofs.add_zero_l.
      eexists.
      split; [reflexivity |].
      simpl.
      unfold Ctypes.align_attr; simpl.
      unfold Z.max, align; simpl.
      unfold Ptrofs.of_intu, Ptrofs.of_int.
      unfold Ptrofs.mul.
      change (Ptrofs.unsigned (Ptrofs.repr 16)) with 16%Z.
      rewrite Hmrs_num_eq in Hrange.
      change Ptrofs.max_unsigned with Int.max_unsigned in Hrange.
      assert (HrangeZ_of_Nat: (0 <= Z.of_nat c < Int.max_unsigned)%Z) by lia.
      rewrite Int.unsigned_repr; [| lia].
      change Int.max_unsigned with Ptrofs.max_unsigned in HrangeZ_of_Nat.
      rewrite Ptrofs.unsigned_repr; [| lia].
      assumption.
    }
    - constructor.
Qed.

End Get_mem_region.

Existing Instance correct_function_get_mem_region.


(***
 * Oqarina
 * Copyright 2021 Carnegie Mellon University.
 *
 * NO WARRANTY. THIS CARNEGIE MELLON UNIVERSITY AND SOFTWARE ENGINEERING
 * INSTITUTE MATERIAL IS FURNISHED ON AN "AS-IS" BASIS. CARNEGIE MELLON
 * UNIVERSITY MAKES NO WARRANTIES OF ANY KIND, EITHER EXPRESSED OR
 * IMPLIED, AS TO ANY MATTER INCLUDING, BUT NOT LIMITED TO, WARRANTY OF
 * FITNESS FOR PURPOSE OR MERCHANTABILITY, EXCLUSIVITY, OR RESULTS
 * OBTAINED FROM USE OF THE MATERIAL. CARNEGIE MELLON UNIVERSITY DOES NOT
 * MAKE ANY WARRANTY OF ANY KIND WITH RESPECT TO FREEDOM FROM PATENT,
 * TRADEMARK, OR COPYRIGHT INFRINGEMENT.
 *
 * Released under a BSD (SEI)-style license, please see license.txt or
 * contact permission@sei.cmu.edu for full terms.
 *
 * [DISTRIBUTION STATEMENT A] This material has been approved for public
 * release and unlimited distribution.  Please see Copyright notice for
 * non-US Government use and distribution.
 *
 * This Software includes and/or makes use of the following Third-Party
 * Software subject to its own license:
 *
 * 1. Coq theorem prover (https://github.com/coq/coq/blob/master/LICENSE)
 * Copyright 2021 INRIA.
 *
 * 2. Coq JSON (https://github.com/liyishuai/coq-json/blob/comrade/LICENSE)
 * Copyright 2021 Yishuai Li.
 *
 * DM21-0762
***)
(*| .. coq:: none |*)
(** Coq Library *)
Require Import List.
Import ListNotations. (* from List *)
Require Import Coq.Bool.Bool.
Require Import Coq.Lists.ListDec.

(** Oqarina library *)
Require Import Oqarina.core.all.
Require Import Oqarina.coq_utils.all.

Require Import Oqarina.AADL.Kernel.categories.
Require Import Oqarina.AADL.Kernel.component.
(*| .. coq:: |*)

(*|
Features
--------

|*)

(*| Valid_Features_Category |*)

Fixpoint Valid_Features_Category
    (l : list feature)
    (lcat : list FeatureCategory)
:=
    match l with
        | nil => True
        | h :: t => In (projectionFeatureCategory  h) lcat /\
                    Valid_Features_Category t lcat
    end.

Lemma Valid_Features_Category_dec :
    forall (l:list feature) (lcat :list FeatureCategory),
        { Valid_Features_Category l lcat } +
        { ~Valid_Features_Category l lcat }.
Proof.
    prove_dec.
    induction l.
    auto.
    apply dec_sumbool_and.
    - apply In_dec; apply FeatureCategory_eq_dec.
    - auto.
Qed.

(** XXX Actually wrong, we must check for the direction of the feature as well *)

Definition Well_Formed_Component_Interface
    (c: component) (l : list FeatureCategory) :=
        Valid_Features_Category (c->features) l.

Lemma Well_Formed_Component_Interface_dec :
    forall (c:component) (lcat :list FeatureCategory),
        {Well_Formed_Component_Interface c lcat} +
        { ~Well_Formed_Component_Interface c lcat}.
Proof.
    prove_dec.
    apply Valid_Features_Category_dec.
Qed.

Definition Well_Formed_Feature_Id (f : feature) : Prop :=
  (Well_Formed_Identifier_prop (projectionFeatureIdentifier f)).

Lemma Well_Formed_Feature_Id_dec : forall f : feature,
  {Well_Formed_Feature_Id f } + {~Well_Formed_Feature_Id f }.
Proof.
    prove_dec.
Qed.

Definition Well_Formed_Feature_Ids (l : list feature) : Prop :=
    All Well_Formed_Feature_Id l.

Lemma Well_Formed_Feature_Ids_dec : forall l : list feature,
    { Well_Formed_Feature_Ids l } + { ~Well_Formed_Feature_Ids l }.
Proof.
    prove_dec.
Qed.

Definition Features_Identifiers_Are_Unique (l : list feature) : Prop :=
    (NoDup (Features_Identifiers l)).

Lemma Features_Identifiers_Are_Unique_dec :
    forall l : list feature,
        { Features_Identifiers_Are_Unique l } + { ~ Features_Identifiers_Are_Unique l }.
Proof.
    prove_dec.
Qed.

Definition Well_Formed_Features (l : list feature) :=
    Features_Identifiers_Are_Unique (l) /\
    Well_Formed_Feature_Ids l.

Lemma Well_Formed_Features_dec : forall l : list feature,
    { Well_Formed_Features l } + { ~ Well_Formed_Features l }.
Proof.
    prove_dec.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.PropExtensionality.
Require Import riscv.Utility.Monads. Import OStateOperations.
Require Import riscv.Utility.MonadNotations.
Require Import riscv.Spec.Decode.
Require Import riscv.Spec.Machine.
Require Import riscv.Utility.Utility.
Require Import riscv.Spec.Primitives.
Require Export riscv.Platform.RiscvMachine.
Require Import coqutil.Z.Lia.
Require Import coqutil.Map.Interface.
Require Import riscv.Platform.Sane.

Local Open Scope Z_scope.
Local Open Scope bool_scope.
Import ListNotations.

Section Riscv.

  Context {width: Z} {BW: Bitwidth width} {word: word width} {word_ok: word.ok word}.
  Context {Mem: map.map word byte}.
  Context {Registers: map.map Register word}.

  Definition update(f: RiscvMachine -> RiscvMachine): OState RiscvMachine unit :=
    m <- get; put (f m).

  Definition fail_if_None{R}(o: option R): OState RiscvMachine R :=
    match o with
    | Some x => Return x
    | None => fail_hard
    end.

  Definition loadN(n: nat)(kind: SourceType)(a: word): OState RiscvMachine (HList.tuple byte n) :=
    mach <- get;
    v <- fail_if_None (Memory.load_bytes n mach.(getMem) a);
    match kind with
    | Fetch => if isXAddr4B a mach.(getXAddrs) then Return v else fail_hard
    | _ => Return v
    end.

  Definition storeN(n: nat)(kind: SourceType)(a: word)(v: HList.tuple byte n) :=
    mach <- get;
    m <- fail_if_None (Memory.store_bytes n mach.(getMem) a v);
    update (fun mach =>
              withXAddrs (invalidateWrittenXAddrs n a mach.(getXAddrs)) (withMem m mach)).

  Instance IsRiscvMachine: RiscvProgram (OState RiscvMachine) word :=  {
      getRegister reg :=
        if Z.eq_dec reg Register0 then
          Return (ZToReg 0)
        else
          if (0 <? reg) && (reg <? 32) then
            mach <- get;
            match map.get mach.(getRegs) reg with
            | Some v => Return v
            | None => Return (word.of_Z 0)
            end
          else
            fail_hard;

      setRegister reg v :=
        if Z.eq_dec reg Register0 then
          Return tt
        else
          if (0 <? reg) && (reg <? 32) then
            update (fun mach => withRegs (map.put mach.(getRegs) reg v) mach)
          else
            fail_hard;

      getPC := mach <- get; Return mach.(getPc);

      setPC newPC := update (withNextPc newPC);

      loadByte   := loadN 1;
      loadHalf   := loadN 2;
      loadWord   := loadN 4;
      loadDouble := loadN 8;

      storeByte   := storeN 1;
      storeHalf   := storeN 2;
      storeWord   := storeN 4;
      storeDouble := storeN 8;

      makeReservation  addr := fail_hard;
      clearReservation addr := fail_hard;
      checkReservation addr := fail_hard;
      getCSRField f := fail_hard;
      setCSRField f v := fail_hard;
      getPrivMode := fail_hard;
      setPrivMode v := fail_hard;
      fence _ _ := fail_hard;

      endCycleNormal := update (fun m => (withPc m.(getNextPc)
                                         (withNextPc (word.add m.(getNextPc) (word.of_Z 4)) m)));

      (* fail hard if exception is thrown because at the moment, we want to prove that
         code output by the compiler never throws exceptions *)
      endCycleEarly{A: Type} := fail_hard;
  }.

  Arguments Memory.load_bytes: simpl never.
  Arguments Memory.store_bytes: simpl never.

  Lemma VirtualMemoryFetchP: forall (addr: word) xAddrs,
      VirtualMemory = Fetch -> isXAddr4 addr xAddrs.
  Proof. intros. discriminate. Qed.

  Lemma ExecuteFetchP: forall (addr: word) xAddrs,
      Execute = Fetch -> isXAddr4 addr xAddrs.
  Proof. intros. discriminate. Qed.

  Ltac t :=
    repeat match goal with
       | |- _ => reflexivity
       | |- _ => progress (
                     unfold computation_satisfies, computation_with_answer_satisfies,
                            IsRiscvMachine,
                            valid_register,
                            is_initial_register_value,
                            get, put, fail_hard,
                            update,
                            Memory.loadByte, Memory.storeByte,
                            Memory.loadHalf, Memory.storeHalf,
                            Memory.loadWord, Memory.storeWord,
                            Memory.loadDouble, Memory.storeDouble,
                            fail_if_None, loadN, storeN in *;
                     subst;
                     simpl in * )
       | |- _ => intro
       | |- _ => split
       | |- _ => apply functional_extensionality
       | |- _ => apply propositional_extensionality; split; intros
       | u: unit |- _ => destruct u
       | H: exists x, _ |- _ => destruct H
       | H: {_ : _ | _} |- _ => destruct H
       | H: _ /\ _ |- _ => destruct H
       | p: _ * _ |- _ => destruct p
       | |- context [ let (_, _) := ?p in _ ] => let E := fresh "E" in destruct p eqn: E
       | H: Some _ = Some _ |- _ => inversion H; clear H; subst
       | H: (_, _) = (_, _) |- _ => inversion H; clear H; subst
       | H: _ && _ = true |- _ => apply andb_prop in H
       | H: _ && _ = false |- _ => apply Bool.andb_false_iff in H
       | H: isXAddr4B _ _ = false |- _ => apply isXAddr4B_not in H
       | H: isXAddr4B _ _ = true  |- _ => apply isXAddr4B_holds in H
       | H: ?x = ?x -> _ |- _ => specialize (H eq_refl)
       | |- _ * _ => constructor
       | |- option _ => exact None
       | |- _ => discriminate
       | |- _ => congruence
       | |- _ => solve [exfalso; blia]
       | |- _ => solve [eauto 15 using VirtualMemoryFetchP, ExecuteFetchP]
       | |- _ => progress (rewrite? Z.ltb_nlt in *; rewrite? Z.ltb_lt in * )
       | |- _ => blia
       | H: context[let (_, _) := ?y in _] |- _ => let E := fresh "E" in destruct y eqn: E
       | E: ?x = Some _, H: context[match ?x with _ => _ end] |- _ => rewrite E in H
       | E: ?x = Some _  |- context[match ?x with _ => _ end]      => rewrite E
       | H: context[match ?x with _ => _ end] |- _ => let E := fresh "E" in destruct x eqn: E
       | |- context[match ?x with _ => _ end]      => let E := fresh "E" in destruct x eqn: E
       | H: _ \/ _ |- _ => destruct H
       | r: RiscvMachine |- _ =>
         destruct r as [regs pc npc m l];
         simpl in *
(*       | H: context[match ?x with _ => _ end] |- _ => let E := fresh in destruct x eqn: E*)
       | o: option _ |- _ => destruct o
       (* introduce evars as late as possible (after all destructs), to make sure everything
          is in their scope*)
       | |- exists (P: ?A -> ?S -> Prop), _ =>
            let a := fresh "a" in evar (a: A);
            let s := fresh "s" in evar (s: S);
            exists (fun a0 s0 => a0 = a /\ s0 = s);
            subst a s
       | |- _ \/ _ => left; solve [t]
       | |- _ \/ _ => right; solve [t]
       end.

  Instance MinimalPrimitivesParams: PrimitivesParams (OState RiscvMachine) RiscvMachine := {
    Primitives.mcomp_sat := @OStateOperations.computation_with_answer_satisfies RiscvMachine;
    Primitives.is_initial_register_value := eq (word.of_Z 0);
    Primitives.nonmem_load n kind addr _ _ := False;
    Primitives.nonmem_store n kind addr v _ _ := False;
    Primitives.valid_machine _ := True;
  }.

  Instance MinimalSatisfies_mcomp_sat_spec: mcomp_sat_spec MinimalPrimitivesParams.
  Proof. constructor; t. Qed.

  Lemma get_sane: mcomp_sane get.
  Proof.
    unfold mcomp_sane, get. simpl. unfold computation_with_answer_satisfies. intros.
    destruct H0 as (? & ? & ? & ?). inversion H0. subst. clear H0.
    split.
    - eauto.
    - intros. do 2 eexists. split; [reflexivity|].
      split; [|trivial].
      split; [assumption|].
      exists nil. reflexivity.
  Qed.

  (* does not hold in general, because we could put a machine with a shorter log *)
  Lemma put_sane: forall m, mcomp_sane (put m). Abort.

  Lemma fail_hard_sane: forall A, mcomp_sane (fail_hard (A := A)).
  Proof.
    unfold mcomp_sane, fail_hard. simpl. unfold computation_with_answer_satisfies. intros.
    destruct H0 as (? & ? & ? & ?). discriminate.
  Qed.

  Lemma update_sane: forall f,
      (forall mach, exists diff, (f mach).(getLog) = diff ++ mach.(getLog)) ->
      mcomp_sane (update f).
  Proof.
    unfold mcomp_sane, update, get, put. simpl. unfold computation_with_answer_satisfies. intros.
    split.
    - edestruct H1 as (? & ? & ? & ?); eauto.
    - intros. destruct H1 as (? & ? & ? & ?).
      inversion H1. subst. clear H1.
      eauto 10.
  Qed.

  Lemma logEvent_sane: forall e,
      mcomp_sane (update (withLogItem e)).
  Proof.
    intros. eapply update_sane. intros. exists [e]. destruct mach. reflexivity.
  Qed.

  Instance MinimalSane: PrimitivesSane MinimalPrimitivesParams.
  Proof.
    constructor.
    all: intros;
      unfold getRegister, setRegister,
         loadByte, loadHalf, loadWord, loadDouble,
         storeByte, storeHalf, storeWord, storeDouble,
         getPC, setPC,
         endCycleNormal, endCycleEarly, raiseExceptionWithInfo,
         IsRiscvMachine,
         loadN, storeN, fail_if_None.

    all: repeat match goal with
                | |- _ => apply logEvent_sane
                | |- mcomp_sane (Bind _ _) => apply Bind_sane
                | |- _ => apply Return_sane
                | |- _ => apply get_sane
                | |- _ => apply fail_hard_sane
                | |- _ => apply update_sane; intros [? ? ? ? ? ?]; simpl; exists nil; reflexivity
                | |- context [match ?b with _ => _ end] => destruct b
                | |- _ => progress intros
                end.
  Qed.

  Instance MinimalSatisfiesPrimitives: Primitives MinimalPrimitivesParams.
  Proof.
    constructor.
    1: exact MinimalSatisfies_mcomp_sat_spec.
    1: exact MinimalSane.
    all: try t.
  Qed.

End Riscv.

(* needed because defined inside a Section *)
#[global] Existing Instance IsRiscvMachine.
#[global] Existing Instance MinimalSatisfiesPrimitives.


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

Section add.

Context `{hypparams:HypervisorParameters}.
Context `{vmG: !gen_VMG Σ}.

Lemma add {E i wi w1 w2 q p} ai ra rb s :
  decode_instruction wi = Some(Add ra rb) ->
  tpa ai ∈ s ->
  tpa ai ≠ p ->
  {SS{{ ▷ (PC @@ i ->r ai) ∗
        ▷ (ai ->a wi) ∗
        ▷ (ra @@ i ->r w1) ∗
        ▷ (rb @@ i ->r w2) ∗
        ▷ (i -@{ q }A> s) ∗
        ▷ (TX@ i := p)}}}
    ExecI @ i; E
    {{{ RET (false, ExecI);
        PC @@ i ->r (ai ^+ 1)%f ∗
        ai ->a wi ∗
        ra @@ i ->r (w1 ^+ (finz.to_z w2))%f ∗
        rb @@ i ->r w2 ∗
        (i -@{ q }A> s) ∗
        (TX@ i := p) }}}.
Proof.
  iIntros (Hdecode Hin Hneq ϕ) "(>Hpc & >Hai & >Hra & >Hrb & >Hacc & >HTX) Hϕ".
  iApply (sswp_lift_atomic_step ExecI);[done|].
  iIntros (n σ1) "%Hsche Hσ".
  rewrite /scheduled in Hsche.
  simpl in Hsche.
  rewrite /scheduler in Hsche.
  apply bool_decide_unpack in Hsche as Hcur.
  clear Hsche.
  apply fin_to_nat_inj in Hcur.
  iModIntro.
  iDestruct "Hσ" as "(#Hneq & Hmem & Hreg & Hmb & Hrx & Hown & Haccess & Hrest)".
  (* valid regs *)
  iDestruct ((gen_reg_valid3 i PC ai ra w1 rb w2 Hcur) with "Hreg Hpc Hra Hrb") as "[%HPC [%Hra %Hrb]]";eauto.
  (* valid pt *)
  iDestruct (access_agree_check_true (tpa ai) i with "Haccess Hacc") as "%Hai"; first set_solver.
  (* valid mem *)
  iDestruct (gen_mem_valid ai wi with "Hmem Hai") as %Hmem.
  iDestruct (mb_valid_tx i p with "Hmb HTX") as %Htx.
  set (instr := Add ra rb).
  iSplit.
  - (* reducible *)
    iPureIntro.
    apply (reducible_normal i instr ai wi);eauto.
    by rewrite Htx.
  - (* step *)
    iModIntro.
    iIntros (m2 σ2) "[%P PAuth] %HstepP".
    apply (step_ExecI_normal i instr ai wi ) in HstepP;eauto.
    remember (exec instr σ1) as c2 eqn:Heqc2.
    pose proof (decode_instruction_valid wi instr Hdecode) as Hvalidinstr.
    inversion Hvalidinstr as [| | | | | | ra' rb' Hvalidrb Hvalidra | | | | |] .
    subst ra' rb'.
    inversion Hvalidra as [ HneqPCa HneqNZa ].
    inversion Hvalidrb as [ HneqPCb HneqNZb ].
    subst instr.
    rewrite /exec (add_ExecI σ1 ra w1 rb w2) /update_incr_PC /update_reg in Heqc2;auto.
    destruct HstepP;subst m2 σ2; subst c2; simpl.
    rewrite /gen_vm_interp.
    (* unchanged part *)
    rewrite (preserve_get_mb_gmap σ1).
    rewrite (preserve_get_rx_gmap σ1).
    rewrite (preserve_get_own_gmap σ1).
    rewrite (preserve_get_access_gmap σ1).
    rewrite (preserve_get_excl_gmap σ1).
    rewrite (preserve_get_trans_gmap σ1).
    rewrite (preserve_get_hpool_gset σ1).
    rewrite (preserve_get_retri_gmap σ1).
    rewrite (preserve_inv_trans_pgt_consistent σ1).
    rewrite (preserve_inv_trans_wellformed σ1).
    rewrite (preserve_inv_trans_ps_disj σ1).
    rewrite p_upd_pc_mem p_upd_reg_mem.
    all: try rewrite p_upd_pc_pgt p_upd_reg_pgt //.
    all: try rewrite p_upd_pc_trans p_upd_reg_trans //.
    all: try rewrite p_upd_pc_mb p_upd_reg_mb //.
    rewrite Hcur. iFrame.
    (* updated part *)
    rewrite -> (u_upd_pc_regs _ i ai 1);eauto.
    rewrite u_upd_reg_regs.
    + iDestruct ((gen_reg_update2_global PC i ai (ai ^+ 1)%f ra i w1 (w1 ^+ (finz.to_z w2))%f)
                   with "Hreg Hpc Hra") as ">[Hreg [Hpc Hra]]";eauto.
      iModIntro.
      iSplitL "PAuth".
      by iExists P.
      rewrite /just_scheduled_vms.
      rewrite /just_scheduled.
      assert (filter
                (λ id : vmid,
                        base.negb (scheduled σ1 id) && scheduled (update_offset_PC (update_reg_global σ1 i ra (w1 ^+ w2)%f) 1) id = true)
                (seq 0 n) = []) as ->.
      {
        rewrite /scheduled /machine.scheduler //= /scheduler Hcur.
        rewrite p_upd_pc_current_vm p_upd_reg_current_vm.
        rewrite Hcur.
        induction n.
        - simpl.
          rewrite filter_nil //=.
        - rewrite seq_S.
          rewrite filter_app.
          rewrite IHn.
          simpl.
          rewrite filter_cons_False //=.
          rewrite andb_negb_l.
          done.
      }
      iSimpl.
      iFrame.
      iSplit; first done.
      iSplit; first done.
      assert ((scheduled (update_offset_PC (update_reg_global σ1 i ra (w1 ^+ w2)%f) 1) i) = true) as ->.
      rewrite /scheduled.
      simpl.
      rewrite /scheduler.
      rewrite p_upd_pc_current_vm p_upd_reg_current_vm Hcur.
      rewrite bool_decide_eq_true.
      reflexivity.
      simpl.
      iApply ("Hϕ" with "[Hpc Hai Hacc Hra Hrb HTX]").
      iFrame.
    + rewrite u_upd_reg_regs.
      apply (get_reg_gmap_get_reg_Some _ _ _ i) in HPC;eauto.
      rewrite lookup_insert_ne.
      by simplify_map_eq /=.
      congruence.
    + by rewrite Htx.
Qed.

End add.