(* *********************************************************************)
(*                                                                     *)
(*            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.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*                   Proof of functional correctness                   *)
(*          for the C functions implemented in the MBoot layer         *)
(*                                                                     *)
(*                        Xiongnan (Newman) Wu                         *)
(*                                                                     *)
(*                          Yale University                            *)
(*                                                                     *)
(* *********************************************************************)
Require Import Coqlib.
Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import MemoryX.
Require Import MemWithData.
Require Import EventsX.
Require Import Globalenvs.
Require Import LAsm.
Require Import Smallstep.
Require Import ClightBigstep.
Require Import Cop.
Require Import MBoot.
Require Import ZArith.Zwf.
Require Import VCGen.
Require Import RealParams.
Require Import liblayers.compcertx.Stencil.
Require Import liblayers.compcertx.MakeProgram.
Require Import liblayers.compat.CompatLayers.
Require Import liblayers.compat.CompatGenSem.
Require Import CompatClightSem.
Require Import PrimSemantics.
Require Import Clight.
Require Import CDataTypes.
Require Import Ctypes.
Require Import ALInitGenSpec.
Require Import MBootCSource.
Require Import TacticsForTesting.

Require Import AbstractDataType.

Global Opaque compatdata_layerdata ldata_type.

Module MBOOTCODE.

  Section WithPrimitives.

    Context `{real_params_ops : RealParamsOps}.
    Context {memb} `{Hmemx: Mem.MemoryModelX memb}.
    Context `{Hmwd: UseMemWithData memb}.

    Let mem := mwd (cdata RData).

    Context `{Hstencil: Stencil}.
    Context `{make_program_ops: !MakeProgramOps Clight.function type Clight.fundef type}.
    Context `{Hmake_program: !MakeProgram Clight.function type Clight.fundef type}.

    Opaque PTree.get PTree.set.

    Local Open Scope Z_scope.

    Section GetNps.

      Let L: compatlayer (cdata RData) := NPS_LOC ↦ nps_loc_type.

      Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.

      Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

      Section GetNpsBody.

        Context `{Hwb: WritableBlockOps}.

        Variable (s: stencil).

        Variables (ge: genv) (bnps_loc: block).

        Hypothesis hnps_loc1 : Genv.find_symbol ge NPS_LOC = Some bnps_loc.

        Lemma get_nps_body_correct: forall m d env le nps,
                                      env = PTree.empty _ ->
                                      Mem.loadv Mint32 (m, d) (Vptr bnps_loc Int.zero) = Some (Vint nps) ->
                                      exec_stmt ge env le (m, d) get_nps_body E0 le (m, d) (Out_return (Some (Vint nps, tint))).
        Proof.
          intros; subst.
          repeat vcgen.
        Qed.

      End GetNpsBody.

      Theorem get_nps_code_correct:
        spec_le (get_nps ↦ get_nps_spec_low) (〚get_nps ↦ f_get_nps〛 L).
      Proof.
        fbigstep_pre L.
        fbigstep (get_nps_body_correct (Genv.globalenv p) b0 H (fst m') (snd m')) m'.
      Qed.

    End GetNps.

    Section SetNps.

      Let L: compatlayer (cdata RData) := NPS_LOC ↦ nps_loc_type.

      Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.

      Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

      Section SetNpsBody.

        Context `{Hwb: WritableBlockAllowGlobals}.

        Variables (ge: genv) (bnps_loc: block).

        Hypothesis hnps_loc1 : Genv.find_symbol ge NPS_LOC = Some bnps_loc.

        Lemma set_nps_body_correct: forall m m' d env le nps,
                                      env = PTree.empty _ ->
                                      PTree.get tnewnps le = Some (Vint nps) ->
                                      Mem.store Mint32 (m, d) bnps_loc 0 (Vint nps) = Some (m', d) ->
                                      exec_stmt ge env le (m, d) set_nps_body E0 le (m', d) Out_normal
        .
        Proof.
          intros; subst.
          repeat vcgen.
        Qed.

      End SetNpsBody.

      Theorem set_nps_correct:
        spec_le (set_nps ↦ set_nps_spec_low) (〚set_nps ↦ f_set_nps 〛L).
      Proof.
        fbigstep_pre L. destruct H0 as [H0 Heq].
        fbigstep (set_nps_body_correct (Genv.globalenv p) b0 H (fst m) (fst m') (snd m) (PTree.empty _)
                                       (bind_parameter_temps' (fn_params f_set_nps)
                                                              (Vint n::nil)
                                                              (create_undef_temps (fn_temps f_set_nps)))) m.
        destruct m'; simpl in *. congruence.
      Qed.

    End SetNps.

    Section IsNorm.

      Lemma structsize: sizeof t_struct_A = 12.
      Proof.
        generalize max_unsigned_val; intro muval.
        simpl.
        unfold align; simpl.
        trivial.
      Qed.

      Let L: compatlayer (cdata RData) := AT_LOC ↦ at_loc_type.

      Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.

      Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

      Section IsNormBody.

        Context `{Hwb: WritableBlockOps}.

        Variable (s: stencil).

        Variables (ge: genv)
                  (STENCIL_MATCHES: stencil_matches s ge).

        Variable (bat_loc: block).

        Hypothesis hat_loc : Genv.find_symbol ge AT_LOC = Some bat_loc.

        Lemma is_norm_body_correct: forall m d env le index isnorm isnorm',
                                      env = PTree.empty _ ->
                                      0 <= (Int.unsigned index) < maxpage ->
                                      Mem.load Mint32 m bat_loc (Int.unsigned index * 12) = Some (Vint isnorm) ->
                                      Int.unsigned isnorm' = ZToATTypeZ (Int.unsigned isnorm) ->
                                      PTree.get tisnorm le = Some Vundef ->
                                      PTree.get tis_norm_index le = Some (Vint index) ->
                                      exists le',
                                        exec_stmt ge env le (m, d) is_norm_body E0 le' (m, d) (Out_return (Some (Vint isnorm', tint)))
        .
        Proof.
          generalize max_unsigned_val; intro muval.
          generalize structsize; intro stsize.
          intros.
          unfold is_norm_body.
          subst.
          unfold ZToATTypeZ in H2.

          assert(isnormcase: Int.unsigned isnorm = 0 \/ Int.unsigned isnorm <> 0) by omega.
          Caseeq isnormcase.

          (* isnorm = 0 *)
          intro veq0.
          destruct (zeq (Int.unsigned isnorm) 0); try omega.
          change 0 with (Int.unsigned Int.zero) in e.
          change 0 with (Int.unsigned Int.zero) in H2.
          apply unsigned_inj in H2.
          apply unsigned_inj in e.
          subst.
          esplit.
          clear H3.
          repeat vcgen.
          unfold Mem.loadv.
          rewrite Z.add_0_r.
          rewrite Z.mul_comm.
          rewrite stsize.
          rewrite Z.add_0_l.
          rewrite Int.unsigned_repr; try omega.
          eassumption.
          discharge_cmp.
          discharge_cmp.
          repeat vcgen.
          rewrite PTree.gss; reflexivity.

          (* isnorm <> 0 *)
          intro vneq0.
          destruct (zeq (Int.unsigned isnorm) 0); try omega.
          assert(isnormcase2: Int.unsigned isnorm = 1 \/ Int.unsigned isnorm <> 1) by omega.
          Caseeq isnormcase2.

          (* isnorm = 1 *)
          intro veq1.
          destruct (zeq (Int.unsigned isnorm) 1); try omega.
          change 0 with (Int.unsigned Int.zero) in H2.
          apply unsigned_inj in H2.
          subst.
          esplit.
          repeat vcgen.
          rewrite Z.add_0_r.
          rewrite Z.mul_comm.
          rewrite stsize.
          rewrite Z.add_0_l.
          unfold Mem.loadv.
          rewrite Int.unsigned_repr; try omega.
          eassumption.
          discharge_cmp.
          discharge_cmp.
          repeat vcgen.
          rewrite PTree.gss; reflexivity.
          (* isnorm <> 1 *)
          intro vneq1.
          destruct (zeq (Int.unsigned isnorm) 1); try omega.
          change 1 with (Int.unsigned Int.one) in H2.
          apply unsigned_inj in H2.
          subst.
          esplit.
          repeat vcgen.
          rewrite Z.add_0_r.
          rewrite Z.mul_comm.
          rewrite stsize.
          rewrite Z.add_0_l.
          unfold Mem.loadv.
          rewrite Int.unsigned_repr; try omega.
          eassumption.
          discharge_cmp.
          discharge_cmp.
          repeat vcgen.
          rewrite PTree.gss; reflexivity.
        Qed.

      End IsNormBody.

      Theorem is_norm_code_correct:
        spec_le (is_norm ↦ is_norm_spec_low) (〚is_norm ↦ f_is_norm 〛L).
      Proof.
        fbigstep_pre L.
        fbigstep (is_norm_body_correct (Genv.globalenv p) b0 H (fst m') (snd m') (PTree.empty _) (bind_parameter_temps' (fn_params f_is_norm)
                                                                                (Vint n::nil)
                                                                                (create_undef_temps (fn_temps f_is_norm)))) m'.
      Qed.

    End IsNorm.

    Section SetNorm.

      Let L: compatlayer (cdata RData) := AT_LOC ↦ at_loc_type.

      Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.

      Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

      Section SetNormBody.

        Context `{Hwb: WritableBlockAllowGlobals}.

        Variable (s: stencil).

        Variables (ge: genv)
                  (STENCIL_MATCHES: stencil_matches s ge).

        Variable (bat_loc: block).

        Hypothesis hat_loc : Genv.find_symbol ge AT_LOC = Some bat_loc.

        Lemma set_norm_body_correct: forall m m' m'' m''' d env le index normval,
                                       env = PTree.empty _ ->
                                       0 <= (Int.unsigned index) < maxpage ->
                                       PTree.get tset_norm_index le = Some (Vint index) ->
                                       PTree.get tnorm_val le = Some (Vint normval) ->
                                       Mem.store Mint32 (m, d) bat_loc (Int.unsigned (Int.repr (Int.unsigned index * 12))) (Vint normval) = Some (m', d) ->
                                       Mem.store Mint32 (m', d) bat_loc (Int.unsigned (Int.repr (Int.unsigned index * 12 + 4))) (Vint (Int.zero)) = Some (m'', d) ->
                                       Mem.store Mint32 (m'', d) bat_loc (Int.unsigned (Int.repr (Int.unsigned index * 12 + 8))) (Vint (Int.zero)) = Some (m''', d) ->
                                       exec_stmt ge env le (m, d) set_norm_body E0 le (m''', d) Out_normal
        .
        Proof.
          generalize max_unsigned_val; intro muval.
          generalize structsize; intro stsize.
          intros.
          subst.
          unfold set_norm_body.
          repeat vcgen.
          rewrite Z.add_0_r.
          rewrite Z.mul_comm.
          eassumption.
          rewrite Z.mul_comm.
          eassumption.
          rewrite Z.mul_comm.
          eassumption.
        Qed.

      End SetNormBody.

      Theorem set_norm_correct:
        spec_le (set_norm ↦ set_norm_spec_low) (〚set_norm ↦ f_set_norm 〛L).
      Proof.
        fbigstep_pre L. destruct H0 as [H0 Heq0]. destruct H1 as [H1 Heq1].
        destruct H2.
        fbigstep (set_norm_body_correct (Genv.globalenv p) b0 H (fst m) (fst m0) (fst m1) (fst m')
                                        (snd m) (PTree.empty _) (bind_parameter_temps' (fn_params f_set_norm)
                                                                                (Vint n::Vint v::nil)
                                                                                (create_undef_temps (fn_temps f_set_norm)))) m; eauto.
        destruct m'; simpl in *. congruence.
      Qed.

    End SetNorm.

    Section AtGet.

      Let L: compatlayer (cdata RData) := AT_LOC ↦ at_loc_type.

      Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.

      Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

      Section ATGetBody.

        Context `{Hwb: WritableBlockOps}.

        Variable (s: stencil).

        Variables (ge: genv)
                  (STENCIL_MATCHES: stencil_matches s ge).

        Variable (bat_loc: block).

        Hypothesis hat_loc : Genv.find_symbol ge AT_LOC = Some bat_loc.

        Lemma at_get_body_correct: forall m d env le index allocated v,
                                     env = PTree.empty _ ->
                                     0 <= (Int.unsigned index) < maxpage ->
                                     Mem.loadv Mint32 (m, d) (Vptr bat_loc (Int.repr ((Int.unsigned index) * 12 + 4))) = Some (Vint v) ->
                                     Int.unsigned allocated = IntToBoolZ v ->
                                     PTree.get tallocated le = Some Vundef ->
                                     PTree.get tat_get_index le = Some (Vint index) ->
                                     exists le',
                                       exec_stmt ge env le (m, d) at_get_body E0 le' (m, d) (Out_return (Some (Vint allocated, tint)))
        .
        Proof.
          generalize max_unsigned_val; intro muval.
          generalize structsize; intro stsize.
          intros.
          unfold at_get_body.
          subst.
          unfold IntToBoolZ in H2.
          unfold Int.eq in H2.
          change (Int.unsigned Int.zero) with 0 in H2.

          assert(isnormcase: Int.unsigned v = 0 \/ Int.unsigned v <> 0) by omega.
          Caseeq isnormcase.

          (* isnorm = 0 *)
          intro veq0.
          destruct (zeq (Int.unsigned v) 0); try omega.
          change 0 with (Int.unsigned Int.zero) in H2, e.
          apply unsigned_inj in H2.
          apply unsigned_inj in e.
          subst.
          esplit.
          repeat vcgen.
          rewrite Z.mul_comm.
          eassumption.
          discharge_cmp.
          discharge_cmp.
          repeat vcgen.
          rewrite PTree.gss; reflexivity.

          (* isnorm <> 0 *)
          intro vneq0.
          destruct (zeq (Int.unsigned v) 0); try omega.
          change 1 with (Int.unsigned Int.one) in H2.
          apply unsigned_inj in H2.
          subst.
          esplit.
          repeat vcgen.
          rewrite Z.mul_comm.
          eassumption.
          discharge_cmp.
          discharge_cmp.
          repeat vcgen.
          rewrite PTree.gss; reflexivity.
        Qed.

      End ATGetBody.

      Theorem at_get_code_correct:
        spec_le (at_get ↦ at_get_spec_low) (〚at_get ↦ f_at_get 〛L).
      Proof.
        fbigstep_pre L.
        fbigstep (at_get_body_correct (Genv.globalenv p) b0 H (fst m') (snd m') (PTree.empty _) (bind_parameter_temps' (fn_params f_at_get)
                                                                                (Vint n::nil)
                                                                                (create_undef_temps (fn_temps f_at_get)))) m'.
      Qed.

    End AtGet.

    Section AtSet.

      Let L: compatlayer (cdata RData) := AT_LOC ↦ at_loc_type.

      Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.

      Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

      Section ATSetBody.

        Context `{Hwb: WritableBlockAllowGlobals}.

        Variable (s: stencil).

        Variables (ge: genv)
                  (STENCIL_MATCHES: stencil_matches s ge).

        Variable (bat_loc: block).

        Hypothesis hat_loc : Genv.find_symbol ge AT_LOC = Some bat_loc.

        Lemma at_set_body_correct: forall m m' d env le index allocatedval,
                                     env = PTree.empty _ ->
                                     0 <= (Int.unsigned index) < maxpage ->
                                     PTree.get tat_set_index le = Some (Vint index) ->
                                     PTree.get tallocated_val le = Some (Vint allocatedval) ->
                                     Mem.store Mint32 (m, d) bat_loc (Int.unsigned (Int.repr (Int.unsigned index * 12 + 4))) (Vint allocatedval) = Some (m', d) ->
                                     exec_stmt ge env le (m, d) at_set_body E0 le (m', d) Out_normal
        .
        Proof.
          generalize max_unsigned_val; intro muval.
          generalize structsize; intro stsize.
          intros; subst.
          repeat vcgen.
          rewrite Z.mul_comm.
          eassumption.
        Qed.

      End ATSetBody.

      Theorem at_set_code_correct:
        spec_le (at_set ↦ at_set_spec_low) (〚at_set ↦ f_at_set 〛L).
      Proof.
        fbigstep_pre L. destruct H0 as [H0 Heq].
        fbigstep (at_set_body_correct (Genv.globalenv p) b0 H (fst m) (fst m') (snd m) (PTree.empty _) (bind_parameter_temps' (fn_params f_at_set)
                                                                                (Vint n::Vint v::nil)
                                                                                (create_undef_temps (fn_temps f_at_set)))) m.
        destruct m'; simpl in *. congruence.
      Qed.

    End AtSet.

    Section AtGetC.

      Let L: compatlayer (cdata RData) := AT_LOC ↦ at_loc_type.

      Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.

      Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

      Section ATGetCBody.

        Context `{Hwb: WritableBlockOps}.

        Variable (s: stencil).

        Variables (ge: genv)
                  (STENCIL_MATCHES: stencil_matches s ge).

        Variable (bat_loc: block).

        Hypothesis hat_loc : Genv.find_symbol ge AT_LOC = Some bat_loc.

        Lemma at_get_c_body_correct: forall m d env le index c,
                                     env = PTree.empty _ ->
                                     0 <= (Int.unsigned index) < maxpage ->
                                     Mem.loadv Mint32 (m, d) (Vptr bat_loc (Int.repr ((Int.unsigned index) * 12 + 8))) = Some (Vint c) ->
                                     PTree.get tat_get_c_index le = Some (Vint index) ->
                                     exists le',
                                       exec_stmt ge env le (m, d) at_get_c_body E0 le' (m, d) (Out_return (Some (Vint c, tint)))
        .
        Proof.
          generalize max_unsigned_val; intro muval.
          generalize structsize; intro stsize.
          intros.
          unfold at_get_c_body.
          subst.
          unfold IntToBoolZ in H2.
          unfold Int.eq in H2.
          change (Int.unsigned Int.zero) with 0 in H2.
          esplit.
          repeat vcgen.
          rewrite stsize.
          rewrite Z.mul_comm.
          assumption.
        Qed.

      End ATGetCBody.

      Theorem at_get_c_code_correct:
        spec_le (at_get_c ↦ at_get_c_spec_low) (〚at_get_c ↦ f_at_get_c 〛L).
      Proof.
        fbigstep_pre L.
        fbigstep (at_get_c_body_correct (Genv.globalenv p) b0 H (fst m') (snd m') (PTree.empty _) (bind_parameter_temps' (fn_params f_at_get_c)
                                                                                (Vint n::nil)
                                                                                (create_undef_temps (fn_temps f_at_get_c)))) m'.
      Qed.

    End AtGetC.

    Section AtSetC.

      Let L: compatlayer (cdata RData) := AT_LOC ↦ at_loc_type.

      Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.

      Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

      Section ATSetCBody.

        Context `{Hwb: WritableBlockAllowGlobals}.

        Variable (s: stencil).

        Variables (ge: genv)
                  (STENCIL_MATCHES: stencil_matches s ge).

        Variable (bat_loc: block).

        Hypothesis hat_loc : Genv.find_symbol ge AT_LOC = Some bat_loc.

        Lemma at_set_c_body_correct: forall m m' d env le index cval,
                                     env = PTree.empty _ ->
                                     0 <= (Int.unsigned index) < maxpage ->
                                     PTree.get tat_set_c_index le = Some (Vint index) ->
                                     PTree.get tc_val le = Some (Vint cval) ->
                                     Mem.store Mint32 (m, d) bat_loc (Int.unsigned (Int.repr (Int.unsigned index * 12 + 8))) (Vint cval) = Some (m', d) ->
                                     exec_stmt ge env le (m, d) at_set_c_body E0 le (m', d) Out_normal
        .
        Proof.
          generalize max_unsigned_val; intro muval.
          generalize structsize; intro stsize.
          intros; subst.
          repeat vcgen.
          rewrite Z.mul_comm.
          eassumption.
        Qed.

      End ATSetCBody.

      Theorem at_set_c_code_correct:
        spec_le (at_set_c ↦ at_set_c_spec_low) (〚at_set_c ↦ f_at_set_c 〛L).
      Proof.
        fbigstep_pre L. destruct H0 as [H0 Heq].
        fbigstep (at_set_c_body_correct (Genv.globalenv p) b0 H (fst m) (fst m') (snd m) (PTree.empty _) (bind_parameter_temps' (fn_params f_at_set_c)
                                                                                (Vint n::Vint v::nil)
                                                                                (create_undef_temps (fn_temps f_at_set_c)))) m.
        destruct m'; simpl in *. congruence.
      Qed.

    End AtSetC.

  End WithPrimitives.

End MBOOTCODE.


Require Import PeanoNat Lia List ListSupport.
Require Import Common FMap.
Require Import Syntax Semantics SemFacts StepM Invariant Serial.
Require Import Reduction Commutativity QuasiSeq Topology.
Require Import RqRsTopo RqRsFacts.

Set Implicit Arguments.

Open Scope list.
Open Scope fmap.

Section FootprintInv.
  Context `{dv: DecValue} `{oifc: OStateIfc}.
  Variables (dtr: DTree)
            (sys: System).

  Hypotheses (Hiorqs: GoodORqsInit (initsOf sys))
             (Hitr: GoodRqRsSys dtr sys).

  Definition FootprintUpOkEx (oidx: IdxT) (rqi: RqInfo Msg) :=
    exists rrFrom rqTo rsFrom,
      rqi.(rqi_rss) = [(rsFrom, None)] /\
      rqi.(rqi_midx_rsb) = (rrFrom >>= (fun rrFrom => Some (snd rrFrom))) /\
      FootprintUpOk dtr oidx rrFrom rqTo rsFrom.

  Definition FootprintDownOkEx (oidx: IdxT) (rqi: RqInfo Msg) :=
    exists rrFrom rqTos rssFrom,
      rqi.(rqi_rss) = rssFrom /\
      rqi.(rqi_midx_rsb) = (rrFrom >>= (fun rrFrom => Some (snd rrFrom))) /\
      (FootprintUpDownOk dtr sys oidx rrFrom rqTos rssFrom \/
       (rrFrom >>=[False] (fun rrFrom => FootprintDownDownOk
                                           dtr oidx (fst rrFrom) rqTos rssFrom (snd rrFrom)))).

  Definition FootprintsOkORqs (orqs: ORqs Msg) :=
    forall oidx,
      orqs@[oidx] >>=[True]
          (fun orq =>
             (orq@[upRq] >>=[True] (fun rqiu => FootprintUpOkEx oidx rqiu)) /\
             (orq@[downRq] >>=[True] (fun rqid => FootprintDownOkEx oidx rqid))).

  Lemma footprints_ok_orqs_add:
    forall orqs,
      FootprintsOkORqs orqs ->
      forall oidx norq,
        norq@[upRq] >>=[True] (fun rqiu => FootprintUpOkEx oidx rqiu) ->
        norq@[downRq] >>=[True] (fun rqid => FootprintDownOkEx oidx rqid) ->
        FootprintsOkORqs (orqs +[oidx <- norq]).
  Proof.
    unfold FootprintsOkORqs; intros.
    mred; simpl; intros; auto.
  Qed.

  Definition FootprintsOk (st: State) :=
    FootprintsOkORqs st.(st_orqs).

  Ltac disc_rule_custom ::=
    repeat
      match goal with
      | [H1: FootprintsOkORqs ?orqs, H2: ?orqs @[?oidx] = _ |- _] =>
        let Hf := fresh "H" in
        pose proof (H1 oidx) as Hf;
        rewrite H2 in Hf; simpl in Hf; dest;
        clear H2
      end.

  Lemma footprints_ok_init:
    InvInit sys FootprintsOk.
  Proof.
    intros; do 3 red.
    intros; simpl; mred.
    specialize (Hiorqs oidx); simpl in Hiorqs.
    destruct ((sys_orqs_inits sys)@[oidx]) as [orq|]; simpl in *; auto.
    subst; mred; simpl; auto.
  Qed.

  Lemma footprints_ok_step:
    InvStep sys step_m FootprintsOk.
  Proof.
    red; intros.
    red in H0; red.
    inv H1; try assumption.

    simpl in *.
    good_rqrs_rule_get rule.
    good_rqrs_rule_cases rule.

    - disc_rule_conds.
      + apply footprints_ok_orqs_add; auto; try (mred; fail).
      + apply footprints_ok_orqs_add; auto; try (mred; fail).
    - disc_rule_conds.
      apply footprints_ok_orqs_add; auto; try (mred; fail).
    - disc_rule_conds.
      + apply footprints_ok_orqs_add; disc_rule_conds; auto.
        red in H33; simpl in H33; dest.
        eexists None, _, _; repeat split; eassumption.
      + apply footprints_ok_orqs_add; disc_rule_conds; auto.
        red in H33; simpl in H33; dest.
        eexists (Some (rqFrom, rsbTo)), _, _; repeat split; try eassumption.
        simpl; eauto.
      + apply footprints_ok_orqs_add; disc_rule_conds.
        eexists None, _, _; repeat split; try eassumption.
        left; eassumption.
      + apply footprints_ok_orqs_add; disc_rule_conds.
        eexists (Some (rqFrom, rsbTo)), _, _; repeat split; try eassumption.
        left; eassumption.
      + apply footprints_ok_orqs_add; disc_rule_conds.
        eexists (Some (rqFrom, rsbTo)), _, _; repeat split; try eassumption.
        right; eassumption.
    - disc_rule_conds.
      + apply footprints_ok_orqs_add; disc_rule_conds; auto.
      + apply footprints_ok_orqs_add; disc_rule_conds; auto.
      + apply footprints_ok_orqs_add; disc_rule_conds; auto.
      + apply footprints_ok_orqs_add; disc_rule_conds; auto.
    - disc_rule_conds.
      apply footprints_ok_orqs_add; disc_rule_conds; auto.
      eexists (Some (rqOrig, rsbTo)), _, _; repeat split; try eassumption.
      left; eassumption.
  Qed.

  Lemma footprints_ok:
    InvReachable sys step_m FootprintsOk.
  Proof.
    eapply inv_reachable.
    - typeclasses eauto.
    - apply footprints_ok_init.
    - apply footprints_ok_step.
  Qed.

End FootprintInv.

Ltac good_footprint_get oidx :=
  match goal with
  | [Hfpok: FootprintsOk _ _ _, Ho: _@[oidx] = Some _ |- _] =>
    let H := fresh "H" in
    pose proof Hfpok as H;
    specialize (H oidx); simpl in H; mred; dest
  end.

Ltac disc_footprints_ok :=
  match goal with
  | [H: FootprintUpOkEx _ _ _ |- _] =>
    let rrFrom := fresh "rrFrom" in
    let rqTo := fresh "rqTo" in
    let rsFrom := fresh "rsFrom" in
    destruct H as [rrFrom [rqTo [rsFrom ?]]]; dest
  | [H: FootprintDownOkEx _ _ _ _ |- _] =>
    let rrFrom := fresh "rrFrom" in
    let rqTos := fresh "rqTos" in
    let rssFrom := fresh "rssFrom" in
    destruct H as [rrFrom [rqTos [rssFrom ?]]]; dest
  | [H: Some _ = (?rrFrom) >>= _ |- _] =>
    let rqFrom := fresh "rqFrom" in
    let rsbTo := fresh "rsbTo" in
    destruct rrFrom as [[rqFrom rsbTo]|]; [|discriminate]; simpl in *; dest
  | [H: None = (?rrFrom) >>= _ |- _] =>
    destruct rrFrom; [discriminate|]; simpl in *
  | [H: (?rrFrom) >>=[False] _ |- _] =>
    match type of rrFrom with
    | option (IdxT * IdxT) =>
      let rqFrom := fresh "rqFrom" in
      let rsbTo := fresh "rsbTo" in
      destruct rrFrom as [[rqFrom rsbTo]|]; [|exfalso; auto]; simpl in *; dest
    end

  | [H: FootprintUpOk _ _ (Some _) _ _ |- _] =>
    red in H; simpl in H;
    let cidx := fresh "cidx" in
    destruct H as [[cidx ?] ?]; dest
  | [H: FootprintUpOk _ _ None _ _ |- _] => red in H; simpl in H; dest
  | [H: FootprintUpDownOk _ _ _ _ _ _ \/ FootprintDownDownOk _ _ _ _ _ _ |- _] => destruct H
  | [H: FootprintUpDownOk _ _ _ _ _ _ \/ False |- _] => destruct H; [|exfalso; auto]
  | [H: FootprintUpDownOk _ _ _ None _ _ |- _] => red in H; simpl in H; dest
  | [H: FootprintUpDownOk _ _ _ (Some (_, _)) _ _ |- _] =>
    red in H; simpl in H;
    let upCIdx := fresh "upCIdx" in
    let upCObj := fresh "upCObj" in
    destruct H as [upCIdx [upCObj ?]]; dest
  | [H: FootprintUpDownOk _ _ _ ?rrFrom _ _ |- _] =>
    let rqFrom := fresh "rqFrom" in
    let rsbTo := fresh "rsbTo" in
    destruct rrFrom as [[rqFrom rsbTo]|]; simpl in H;
    [let upCIdx := fresh "upCIdx" in
     let upCObj := fresh "upCObj" in
     destruct H as [upCIdx [upCObj ?]]; dest|]
  | [H: FootprintDownDownOk _ _ _ _ _ _ |- _] => red in H; dest
  end.

Ltac derive_footprint_info_basis oidx :=
  progress (good_footprint_get oidx);
  repeat (repeat disc_rule_conds_unit_simpl; try disc_footprints_ok).

Section IncomingMessageInv.
  Context `{dv: DecValue} `{oifc: OStateIfc}.
  Variables (dtr: DTree)
            (sys: System).

  Hypotheses (Hiorqs: GoodORqsInit (initsOf sys))
             (Hitr: GoodRqRsSys dtr sys).

  Definition RqUpMsgs (oidx: IdxT) (msgs: list (Id Msg)): Prop :=
    msgs = nil \/
    exists cidx rqUp,
      msgs = [rqUp] /\
      msg_type (valOf rqUp) = MRq /\
      parentIdxOf dtr cidx = Some oidx /\
      rqEdgeUpFrom dtr cidx = Some (idOf rqUp).

  Definition RqDownMsgs (oidx: IdxT) (msgs: list (Id Msg)): Prop :=
    exists obj rqDown,
      msgs = [rqDown] /\
      msg_type (valOf rqDown) = MRq /\
      edgeDownTo dtr oidx = Some (idOf rqDown) /\
      In obj sys.(sys_objs) /\ obj.(obj_idx) = oidx.

  Definition RsUpMsgs (oidx: IdxT) (msgs: list (Id Msg)): Prop :=
    Forall (fun msg => msg_type (valOf msg) = MRs) msgs /\
    Forall (fun rs =>
              exists cidx,
                parentIdxOf dtr cidx = Some oidx /\
                rsEdgeUpFrom dtr cidx = Some rs)
           (idsOf msgs).

  Definition RsDownMsgs (oidx: IdxT) (msgs: list (Id Msg)): Prop :=
    exists obj rsDown,
      msgs = [rsDown] /\
      msg_type (valOf rsDown) = MRs /\
      edgeDownTo dtr oidx = Some (idOf rsDown) /\
      In obj sys.(sys_objs) /\ obj.(obj_idx) = oidx.

  Ltac disc_rule_custom ::=
    disc_footprints_ok.

  Lemma messages_in_cases:
    forall st1 oidx ridx rins routs st2,
      Reachable (steps step_m) sys st1 ->
      step_m sys st1 (RlblInt oidx ridx rins routs) st2 ->
      RqUpMsgs oidx rins \/
      RqDownMsgs oidx rins \/
      RsUpMsgs oidx rins \/
      RsDownMsgs oidx rins.
  Proof.
    intros.

    (* Register some necessary invariants to prove this invariant. *)
    pose proof (footprints_ok Hiorqs Hitr H).

    inv H0.
    good_rqrs_rule_get rule.
    good_rqrs_rule_cases rule.

    - left.
      disc_rule_conds.
      + left; reflexivity.
      + right; constr_rule_conds.

    - right; left.
      disc_rule_conds.
      constr_rule_conds.

    - disc_rule_conds.
      + left; left; constr_rule_conds.
      + left; right; constr_rule_conds.
      + left; left; constr_rule_conds.
      + left; right; constr_rule_conds.
      + right; left; constr_rule_conds.

    - good_footprint_get (obj_idx obj).
      disc_rule_conds.
      + right; right; right.
        constr_rule_conds.
      + right; right; right.
        constr_rule_conds.
      + right; right; left.
        split; auto.
        clear -H20 H26; apply Forall_forall; intros.
        rewrite H26 in H.
        eapply RqRsDownMatch_rs_rq in H20; [|eassumption].
        dest; eauto.
      + right; right; left.
        split; auto.
        clear -H5 H26; apply Forall_forall; intros.
        rewrite H26 in H.
        eapply RqRsDownMatch_rs_rq in H5; [|eassumption].
        dest; eauto.
      + right; right; left.
        split; auto.
        clear -H3 H26; apply Forall_forall; intros.
        rewrite H26 in H.
        eapply RqRsDownMatch_rs_rq in H3; [|eassumption].
        dest; eauto.

    - good_footprint_get (obj_idx obj).
      disc_rule_conds.
      right; right; right.
      constr_rule_conds.
  Qed.

End IncomingMessageInv.

Section OutgoingMessageInv.
  Context `{dv: DecValue} `{oifc: OStateIfc}.
  Variables (dtr: DTree)
            (sys: System).

  Hypotheses (Hiorqs: GoodORqsInit (initsOf sys))
             (Hitr: GoodRqRsSys dtr sys).

  Definition RqUpOutMsgs (oidx: IdxT) (msgs: list (Id Msg)): Prop :=
    exists rqUp,
      msgs = [rqUp] /\
      msg_type (valOf rqUp) = MRq /\
      rqEdgeUpFrom dtr oidx = Some (idOf rqUp).

  Definition RqDownOutMsgs (oidx: IdxT) (msgs: list (Id Msg)): Prop :=
    Forall (fun msg => msg_type (valOf msg) = MRq) msgs /\
    Forall (fun rq =>
              exists cidx,
                parentIdxOf dtr cidx = Some oidx /\
                edgeDownTo dtr cidx = Some rq)
           (idsOf msgs).

  Definition RsUpOutMsgs (oidx: IdxT) (msgs: list (Id Msg)): Prop :=
    exists rsUp,
      msgs = [rsUp] /\
      msg_type (valOf rsUp) = MRs /\
      rsEdgeUpFrom dtr oidx = Some (idOf rsUp).

  Definition RsDownOutMsgs (oidx: IdxT) (msgs: list (Id Msg)): Prop :=
    msgs = nil \/
    exists cidx rsDown,
      msgs = [rsDown] /\
      msg_type (valOf rsDown) = MRs /\
      parentIdxOf dtr cidx = Some oidx /\
      edgeDownTo dtr cidx = Some (idOf rsDown).

  Ltac disc_rule_custom ::=
    disc_footprints_ok.

  Lemma messages_out_cases:
    forall st1 oidx ridx rins routs st2,
      Reachable (steps step_m) sys st1 ->
      step_m sys st1 (RlblInt oidx ridx rins routs) st2 ->
      RqUpOutMsgs oidx routs \/
      RqDownOutMsgs oidx routs \/
      RsUpOutMsgs oidx routs \/
      RsDownOutMsgs oidx routs.
  Proof.
    intros.

    (* Register some necessary invariants to prove this invariant. *)
    pose proof (footprints_ok Hiorqs Hitr H).

    inv H0.
    good_rqrs_rule_get rule.
    good_rqrs_rule_cases rule.

    - right; right; right.
      disc_rule_conds.
      + left; reflexivity.
      + right; constr_rule_conds.

    - right; right; left.
      disc_rule_conds.
      constr_rule_conds.

    - disc_rule_conds.
      + left; constr_rule_conds.
      + left; constr_rule_conds.
      + right; left.
        constr_rule_conds.
        clear -H33; apply Forall_forall; intros.
        eapply RqRsDownMatch_rq_rs in H33; [|eassumption].
        dest; eauto.
      + right; left.
        constr_rule_conds.
        clear -H17; apply Forall_forall; intros.
        eapply RqRsDownMatch_rq_rs in H17; [|eassumption].
        dest; eauto.
      + right; left.
        constr_rule_conds.
        clear -H3; apply Forall_forall; intros.
        eapply RqRsDownMatch_rq_rs in H3; [|eassumption].
        dest; eauto.

    - good_footprint_get (obj_idx obj).
      disc_rule_conds.
      + right; right; right.
        right; constr_rule_conds.
      + right; right; right.
        left; reflexivity.
      + right; right; right.
        right; constr_rule_conds.
      + right; right; left.
        constr_rule_conds.
      + right; right; right.
        left; reflexivity.

    - right; left.
      disc_rule_conds.
      constr_rule_conds.
      clear -H17; apply Forall_forall; intros.
      eapply RqRsDownMatch_rq_rs in H17; [|eassumption].
      dest; eauto.
  Qed.

End OutgoingMessageInv.

Ltac disc_messages_in :=
  match goal with
  | [H: RqUpMsgs _ _ _ |- _] =>
    let Hr := fresh "H" in
    destruct H as [|Hr];
    [subst|
     let cidx := fresh "cidx" in
     let rqUp := fresh "rqUp" in
     destruct Hr as [cidx [rqUp ?]]; dest; subst]
  | [H: RqDownMsgs _ _ _ _ |- _] =>
    let obj := fresh "obj" in
    let rqDown := fresh "rqDown" in
    destruct H as [obj [rqDown ?]]; dest; subst
  | [H: RsUpMsgs _ _ _ |- _] => red in H; dest
  | [H: RsDownMsgs _ _ _ _ |- _] =>
    let obj := fresh "obj" in
    let rsDown := fresh "rsDown" in
    destruct H as [obj [rsDown ?]]; dest; subst
  end.

Ltac disc_messages_out :=
  match goal with
  | [H: RqUpOutMsgs _ _ _ |- _] =>
    let rqUp := fresh "rqUp" in
    destruct H as [rqUp ?]; dest; subst
  | [H: RqDownOutMsgs _ _ _ |- _] => red in H; dest
  | [H: RsUpOutMsgs _ _ _ |- _] =>
    let rsUp := fresh "rsUp" in
    destruct H as [rsUp ?]; dest; subst
  | [H: RsDownOutMsgs _ _ _ |- _] =>
    let Hr := fresh "H" in
    destruct H as [|Hr];
    [subst|
     let cidx := fresh "cidx" in
     let rsDown := fresh "rsDown" in
     destruct Hr as [cidx [rsDown ?]]; dest; subst]
  end.

Section ExtRss.
  Context `{dv: DecValue} `{oifc: OStateIfc}.
  Variables (dtr: DTree)
            (sys: System).
  Hypothesis (Hers: GoodExtRssSys sys).

  Definition ExtRssInvMP (msgs: MessagePool Msg) :=
    ForallQ (fun ers ersq =>
               In ers sys.(sys_merss) ->
               Forall (fun msg => msg_type msg = MRs) ersq) msgs.

  Definition ExtRssInv (st: State) :=
    ExtRssInvMP st.(st_msgs).

  Lemma extRssInv_init: InvInit sys ExtRssInv.
  Proof.
    repeat red; intros.
    constructor.
  Qed.

  Lemma extRssInv_case_outs:
    forall oss orqs msgs (eouts: list (Id Msg)),
      ExtRssInv {| st_oss := oss; st_orqs := orqs; st_msgs := msgs |} ->
      Forall (FirstMPI msgs) eouts ->
      NoDup (idsOf eouts) ->
      ExtRssInv {| st_oss := oss;
                   st_orqs := orqs;
                   st_msgs := deqMsgs (idsOf eouts) msgs |}.
  Proof.
    intros.
    do 2 red in H; do 2 red; simpl in *.
    red; intros.
    specialize (H _ H2).
    destruct (in_dec idx_dec midx (idsOf eouts)).
    + eapply findQ_In_NoDup_deqMsgs with (mp:= msgs) in H1; eauto.
      * destruct H1 as [hmsg ?].
        rewrite <-H1 in H.
        inv H; assumption.
      * intro Hx.
        apply in_map_iff in i.
        destruct i as [[midx' msg] [? ?]]; subst; simpl in *.
        rewrite Forall_forall in H0; specialize (H0 _ H4).
        eapply FirstMP_findQ_False in Hx; eauto.
    + rewrite findQ_not_In_deqMsgs by assumption.
      assumption.
  Qed.

  Lemma extRssInv_step: InvStep sys step_m ExtRssInv.
  Proof.
    red; induction 3; simpl; intros; subst; auto.
    - do 2 red in H0; do 2 red; simpl in *.
      red; intros.
      specialize (H0 _ H3).
      destruct H2.
      rewrite findQ_not_In_enqMsgs; [assumption|].
      eapply DisjList_In_1; [|eassumption].
      eapply DisjList_SubList; [eassumption|].
      apply sys_merqs_sys_merss_DisjList.

    - apply extRssInv_case_outs; auto.
      apply H3.

    - eapply extRssInv_case_outs in H0; [|eassumption|apply H7].
      do 2 red in H0; do 2 red; simpl in *.
      red; intros.
      specialize (H0 _ H3).
      destruct (in_dec idx_dec midx (idsOf outs)).
      + apply in_map_iff in i.
        destruct i as [[midx' msg] [? ?]]; simpl in *; subst.
        rewrite findQ_In_NoDup_enqMsgs with (msg:= msg); [|apply H10|assumption].
        apply Forall_app; [assumption|].
        repeat constructor.
        pose proof Hers.
        red in H12; rewrite Forall_forall in H12; specialize (H12 _ H1).
        red in H12; rewrite Forall_forall in H12; specialize (H12 _ H2).
        red in H12; specialize (H12 _ _ _ _ _ _ H8 H9).
        specialize (H12 _ H13 H3); assumption.
      + rewrite findQ_not_In_enqMsgs by assumption.
        assumption.
  Qed.

  Lemma extRssInv_ok: InvReachable sys step_m ExtRssInv.
  Proof.
    eapply inv_reachable.
    - typeclasses eauto.
    - apply extRssInv_init.
    - apply extRssInv_step.
  Qed.

End ExtRss.

Lemma msgs_ext_out_rss:
  forall `{dv: DecValue} `{oifc: OStateIfc} (sys: System) msgs eouts,
    SubList (idsOf eouts) sys.(sys_merss) ->
    Forall (FirstMPI msgs) eouts ->
    ExtRssInvMP sys msgs ->
    Forall (fun emsg => msg_type (valOf emsg) = MRs) eouts.
Proof.
  intros.
  rewrite Forall_forall in H0.
  apply Forall_forall; intros [emidx emsg] ?.
  specialize (H0 _ H2).
  apply FirstMP_InMP in H0; simpl in H0.
  apply in_map with (f:= idOf) in H2; simpl in H2.
  apply H in H2.
  specialize (H1 _ H2).
  rewrite Forall_forall in H1; specialize (H1 _ H0).
  assumption.
Qed.

Close Scope list.
Close Scope fmap.


Require Import CoqlibC.
Require Import SmallstepC.
Require Import Simulation.
Require Import ModSem AsmregsC GlobalenvsC MemoryC ASTC.
Require Import Skeleton SimModSemSR SimMem SimSymb.
Require Import Sound Preservation.
Require Import ModSemProps.

Set Implicit Arguments.

Section MATCHSIMFORWARD.

  Context {SM: SimMem.class} {SS: SimSymb.class SM} {SU: Sound.class}.

  Variable msp: ModSemPair.t.
  Variable index: Type.
  Variable order: index -> index -> Prop.
  Hypothesis WFORD: well_founded order.
  Let ms_src: ModSem.t := msp.(ModSemPair.src).
  Let ms_tgt: ModSem.t := msp.(ModSemPair.tgt).
  Variable sound_state: Sound.t -> mem -> ms_src.(state) -> Prop.
  Hypothesis PRSV: local_preservation ms_src sound_state.

  Variable match_states: forall
      (idx: index) (st_src0: ms_src.(ModSem.state)) (st_tgt0: ms_tgt.(ModSem.state)) (sm0: SimMem.t),
      Prop.

  Variable match_states_at: forall
      (st_src0: ms_src.(ModSem.state)) (st_tgt0: ms_tgt.(ModSem.state)) (sm_at sm_arg: SimMem.t),
      Prop.

  Inductive match_states_at_helper
            (idx_at: index) (st_src0: ms_src.(ModSem.state)) (st_tgt0: ms_tgt.(ModSem.state)) (sm_at sm_arg: SimMem.t): Prop :=
  | match_states_at_intro
      (MATCH: match_states idx_at st_src0 st_tgt0 sm_at)
      args_src args_tgt
      (CALLSRC: ms_src.(ModSem.at_external) st_src0 args_src)
      (CALLTGT: ms_tgt.(ModSem.at_external) st_tgt0 args_tgt)
      (SIMARGS: SimMem.sim_args args_src args_tgt sm_arg)
      (MLE: SimMem.le sm_at sm_arg)
      (MWF: SimMem.wf sm_arg)
      (MATCHARG: match_states_at st_src0 st_tgt0 sm_at sm_arg).

  Hypothesis INITBSIM: forall sm_arg args_src args_tgt st_init_tgt
      (SIMSKENV: ModSemPair.sim_skenv msp sm_arg)
      (MWF: SimMem.wf sm_arg)
      (SIMARGS: SimMem.sim_args args_src args_tgt sm_arg)
      (INITTGT: ms_tgt.(ModSem.initial_frame) args_tgt st_init_tgt)
      (SAFESRC: exists _st_init_src, ms_src.(ModSem.initial_frame) args_src _st_init_src),
      exists st_init_src sm_init idx_init,
        (<<INITSRC: ms_src.(ModSem.initial_frame) args_src st_init_src>>) /\
        (<<MLE: SimMem.le sm_arg sm_init>>) /\
        (<<MATCH: match_states idx_init st_init_src st_init_tgt sm_init>>).

  Hypothesis INITPROGRESS: forall sm_arg args_src args_tgt
      (SIMSKENV: ModSemPair.sim_skenv msp sm_arg)
      (MWF: SimMem.wf sm_arg)
      (SIMARGS: SimMem.sim_args args_src args_tgt sm_arg)
      (SAFESRC: exists st_init_src, ms_src.(ModSem.initial_frame) args_src st_init_src),
      exists st_init_tgt, (<<INITTGT: ms_tgt.(ModSem.initial_frame) args_tgt st_init_tgt>>).

  Hypothesis ATMWF: forall idx0 st_src0 st_tgt0 sm0
      (MATCH: match_states idx0 st_src0 st_tgt0 sm0)
      (CALLSRC: ms_src.(ModSem.is_call) st_src0),
      <<MWF: SimMem.wf sm0>>.

  Hypothesis ATFSIM: forall idx0 st_src0 st_tgt0 sm0 args_src
      (SIMSKENV: ModSemPair.sim_skenv msp sm0)
      (MATCH: match_states idx0 st_src0 st_tgt0 sm0)
      (CALLSRC: ms_src.(ModSem.at_external) st_src0 args_src)
      (SOUND: exists su0 m_init, sound_state su0 m_init st_src0),
      exists args_tgt sm_arg,
        (<<CALLTGT: ms_tgt.(ModSem.at_external) st_tgt0 args_tgt>>) /\
        (<<SIMARGS: SimMem.sim_args args_src args_tgt sm_arg>>) /\
        (<<MLE: SimMem.le sm0 sm_arg>>) /\
        (<<MWF: SimMem.wf sm_arg>>) /\
        (<<MATCHAT: match_states_at st_src0 st_tgt0 sm0 sm_arg>>).

  Hypothesis AFTERFSIM: forall idx0 st_src0 st_tgt0 sm0 sm_arg sm_ret retv_src retv_tgt st_src1
      (SIMSKENV: ModSemPair.sim_skenv msp sm0)
      (MATCH: match_states idx0 st_src0 st_tgt0 sm0)
      (MLE: SimMem.le sm0 sm_arg)
      (* (MWF: SimMem.wf sm_arg) *)
      (MLE: SimMem.lepriv sm_arg sm_ret)
      (MWF: SimMem.wf sm_ret)
      (SIMRET: SimMem.sim_retv retv_src retv_tgt sm_ret)
      (AFTERSRC: ms_src.(ModSem.after_external) st_src0 retv_src st_src1)
      (SOUND: exists su0 m_init, sound_state su0 m_init st_src0)

      (* history *)
      (HISTORY: match_states_at_helper idx0 st_src0 st_tgt0 sm0 sm_arg),

      (* just helpers *)
      (* (MWFAFTR: SimMem.wf (SimMem.unlift sm_arg sm_ret)) *)
      (* (MLEAFTR: SimMem.le sm_arg (SimMem.unlift sm_arg sm_ret)) *)
      exists sm_after idx1 st_tgt1,
        (<<AFTERTGT: ms_tgt.(ModSem.after_external) st_tgt0 retv_tgt st_tgt1>>) /\
        (<<MATCH: match_states idx1 st_src1 st_tgt1 sm_after>>) /\
        (<<MLE: SimMem.lepriv sm_ret sm_after>>) /\
        (<<MLE: SimMem.le sm0 sm_after>>).

  Hypothesis FINALFSIM: forall idx0 st_src0 st_tgt0 sm0 retv_src
      (SIMSKENV: ModSemPair.sim_skenv msp sm0)
      (MATCH: match_states idx0 st_src0 st_tgt0 sm0)
      (FINALSRC: ms_src.(ModSem.final_frame) st_src0 retv_src),
      exists sm_ret retv_tgt,
        (<<FINALTGT: ms_tgt.(ModSem.final_frame) st_tgt0 retv_tgt>>) /\
        (<<SIMRET: SimMem.sim_retv retv_src retv_tgt sm_ret>>) /\
        (<<MLE: SimMem.le sm0 sm_ret>>) /\
        (<<MWF: SimMem.wf sm_ret>>).

  Let STEPFSIM := forall idx0 st_src0 st_tgt0 sm0
      (SIMSKENV: ModSemPair.sim_skenv msp sm0)
      (NOTCALL: ~ ModSem.is_call ms_src st_src0)
      (NOTRET: ~ ModSem.is_return ms_src st_src0)
      (MATCH: match_states idx0 st_src0 st_tgt0 sm0)
      (SOUND: exists su0 m_init, sound_state su0 m_init st_src0),
      (<<RECEP: strongly_receptive_at ms_src st_src0>>) /\
      (<<STEPFSIM: forall tr st_src1
             (STEPSRC: Step ms_src st_src0 tr st_src1),
             exists idx1 st_tgt1 sm1,
               (<<PLUS: DPlus ms_tgt st_tgt0 tr st_tgt1>> \/
                           <<STAR: DStar ms_tgt st_tgt0 tr st_tgt1 /\ order idx1 idx0>>)
               /\ (<<MLE: SimMem.le sm0 sm1>>)
               (* Note: We require le for mle_preserves_sim_ge, but we cannot require SimMem.wf, beacuse of DCEproof *)
               /\ (<<MATCH: match_states idx1 st_src1 st_tgt1 sm1>>)>>).

  Let STEPBSIM := forall idx0 st_src0 st_tgt0 sm0
      (SIMSKENV: ModSemPair.sim_skenv msp sm0)
      (NOTCALL: ~ ModSem.is_call ms_src st_src0)
      (NOTRET: ~ ModSem.is_return ms_src st_src0)
      (MATCH: match_states idx0 st_src0 st_tgt0 sm0)
      (SOUND: exists su0 m_init, sound_state su0 m_init st_src0),
      (* (<<PROGRESS: ModSem.is_step ms_src st_src0 -> ModSem.is_step ms_tgt st_tgt0>>) *)
      (<<PROGRESS: safe_modsem ms_src st_src0 -> ModSem.is_step ms_tgt st_tgt0>>) /\
      (<<STEPBSIM: forall tr st_tgt1
             (STEPTGT: Step ms_tgt st_tgt0 tr st_tgt1) ,
             exists idx1 st_src1 sm1,
               (<<PLUS: Plus ms_src st_src0 tr st_src1>> \/
                           <<STAR: Star ms_src st_src0 tr st_src1 /\ order idx1 idx0>>)
               /\ (<<MLE: SimMem.le sm0 sm1>>)
               (* Note: We require le for mle_preserves_sim_ge, but we cannot require SimMem.wf, beacuse of DCEproof *)
               /\ (<<MATCH: match_states idx1 st_src1 st_tgt1 sm1>>)>>).

  Remark safe_modsem_is_smaller
         st_src0
         (NOTCALL: ~ ModSem.is_call ms_src st_src0)
         (NOTRET: ~ ModSem.is_return ms_src st_src0)
         (SAFE: safe_modsem ms_src st_src0):
      ModSem.is_step ms_src st_src0.
  Proof. rr. specialize (SAFE _ (star_refl _ _ _ _)). des; ss. eauto. Qed.

  Hypothesis STEPSIM: STEPFSIM \/ STEPBSIM.

  Hypothesis BAR: bar_True.

  Lemma match_states_lxsimSR
        i0 st_src0 st_tgt0 sm0
        (SIMSKENV: ModSemPair.sim_skenv msp sm0)
        (* (MWF: SimMem.wf sm0) *)
        (* (MCOMPAT: mem_compat st_src0 st_tgt0 sm0) *)
        (MATCH: match_states i0 st_src0 st_tgt0 sm0):
        (* su0 *)
      (* <<LXSIM: lxsim ms_src ms_tgt (sound_state su0) sm_init i0.(to_idx WFORD) st_src0 st_tgt0 sm0>> *)
      <<LXSIM: lxsimSR ms_src ms_tgt (fun st => unit -> exists su0 m_init, sound_state su0 m_init st)
                       (Ord.lift_idx WFORD i0) st_src0 st_tgt0 sm0>>.
  Proof.
    (* move su0 at top. *)
    revert_until BAR. pcofix CIH. i. pfold. ii.
    generalize (classic (ModSem.is_call ms_src st_src0)). intro CALLSRC; des.
    { (* CALL *)
      - (* u in CALLSRC. des. *)
        exploit ATMWF; eauto. i; des. eapply lxsimSR_at_external; eauto. ii. clear CALLSRC.
        exploit ATFSIM; eauto. { ii. eapply SUSTAR; eauto. eapply star_refl. apply tt. } i; des.
        (* determ_tac ModSem.at_external_dtm. clear_tac. *)
        esplits; eauto. i. exploit AFTERFSIM; try apply SAFESRC; try apply SIMRET; eauto.
        { ii. eapply SUSTAR; eauto. eapply star_refl. apply tt. }
        { econs; eauto. }
        i; des.
        assert(MLE4: SimMem.le sm0 sm_after).
        { etrans; cycle 1. { et. } refl. }
        esplits; eauto. right. eapply CIH; [..|eauto].
        { eapply ModSemPair.mfuture_preserves_sim_skenv; try apply SIMSKENV; eauto. apply rtc_once. left. et. }
    }
    generalize (classic (ModSem.is_return ms_src st_src0)). intro RETSRC; des.
    { (* RETURN *)
      u in RETSRC. des. exploit FINALFSIM; eauto. i; des.
      eapply lxsimSR_final; try apply SIMRET; eauto.
    }
    destruct STEPSIM as [STEPFSIM0|STEPBSIM0].
    { eapply lxsimSR_step_forward; eauto. i.
      (* hexploit1 SU0; ss. *)
      exploit STEPFSIM0; eauto. { ii. eapply SUSTAR; eauto. eapply star_refl. apply tt. } i; des.
      esplits; eauto. econs 1; eauto.
      ii. exploit STEPFSIM1; eauto. i; des_safe. esplits; eauto.
      - des.
        + left. eauto.
        + right. esplits; eauto. eapply Ord.lift_idx_spec; eauto.
      - right. eapply CIH; [..|eauto].
        { eapply ModSemPair.mfuture_preserves_sim_skenv; try apply SIMSKENV; eauto. apply rtc_once; eauto. }
    }
    { rr in STEPBSIM0. eapply lxsimSR_step_backward; eauto. i.
      (* hexploit1 SU0; ss. *)
      exploit STEPBSIM0; eauto. { ii. eapply SUSTAR; eauto. eapply star_refl. apply tt. } i; des. rr in PROGRESS. des.
      esplits; eauto; cycle 1. econs 1; eauto. ii. exploit STEPBSIM1; eauto. i; des_safe. esplits; eauto.
      - des.
        + left. eauto.
        + right. esplits; eauto. eapply Ord.lift_idx_spec; eauto.
      - right. eapply CIH; [..|eauto].
        { eapply ModSemPair.mfuture_preserves_sim_skenv; try apply SIMSKENV; eauto. apply rtc_once; eauto. }
    }
  Qed.

  Theorem match_states_sim: <<SIM: msp.(ModSemPair.simSR)>>.
  Proof.
    econs.
    { eauto. }
    { instantiate (2 := unit). ii. eapply local_preservation_noguarantee_weak; eauto. eapply PRSV. }
    ii; ss. folder.
    exploit SimSymb.sim_skenv_func_bisim; eauto. { apply SIMSKENV. } intro FSIM; des.
    inv FSIM. exploit FUNCFSIM; eauto. { apply SimMem.sim_args_sim_fptr; et. } i; des.
    split; ii.
    - exploit INITBSIM; eauto. i; des.
      esplits; eauto.
      eapply match_states_lxsimSR; eauto.
      { eapply ModSemPair.mfuture_preserves_sim_skenv; try apply SIMSKENV; eauto. apply rtc_once; eauto. }
    - exploit INITPROGRESS; eauto.
  Unshelve.
    all: ss.
  Qed.

End MATCHSIMFORWARD.


(** * Extraction of various contracts to CameLIGO *)

From Coq Require Import ZArith.
From Coq Require Import List.
From Coq Require Import String.
From MetaCoq.Template Require Import All.
From ConCert.Embedding Require Import Notations.
From ConCert.Embedding.Extraction Require Import PreludeExt.
From ConCert.Embedding.Extraction Require SimpleBlockchainExt.
From ConCert.Examples.Crowdfunding Require Import CrowdfundingExt.
From ConCert.Examples.Crowdfunding Require CrowdfundingDataExt.
From ConCert.Extraction Require Import Common.
From ConCert.Extraction Require Import CameLIGOPretty.
From ConCert.Extraction Require Import CameLIGOExtract.
From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import ResultMonad.

Import MCMonadNotation.

Local Open Scope string_scope.
Open Scope Z.

#[local]
Existing Instance PrintConfShortNames.PrintWithShortNames.

Module Crowdfunding.

  Notation storage := ((time_coq × Z × address_coq) × Maps.addr_map_coq × bool).

  Definition crowdfunding_init (ctx : ContractCallContext)
                               (setup : (time_coq × Z × address_coq))
                               : result storage nat :=
      if ctx.(ctx_amount) =? 0 then Ok (setup, (Maps.mnil, false)) else Err 0%nat.

  Definition init (setup : (time_coq × Z × address_coq))
                  : result storage nat :=
    Ok (setup, (Maps.mnil, false)).

  Lemma crowdfunding_init_eq_init ctx setup :
    ctx.(ctx_amount) =? 0 -> (* no money should be sent on deployment *)
    crowdfunding_init ctx setup = init setup.
  Proof.
    intros Hamount.
    unfold crowdfunding_init.
    now rewrite Hamount.
  Qed.

  Open Scope Z.
  Import SimpleBlockchainExt.AcornBlockchain.
  Import CrowdfundingDataExt.
  Import CrowdfundingContract.Receive.

  (* We assume that there is a function converting addresses to [nat] *)
  Parameter addr_to_nat : forall `{ChainBase}, Blockchain.Address -> nat.

  Definition to_simple_ctx_addr `{ChainBase} (addr : Blockchain.Address) : address_coq :=
    if address_is_contract addr then ContractAddr_coq (addr_to_nat addr) else
      UserAddr_coq (addr_to_nat addr).

  Definition crowdfunding_receive_inner
            (c : Chain)
            (ctx : ContractCallContext)
            (params : msg_coq)
            (st : storage)
            : result (list SimpleActionBody_coq × storage) nat :=
    let res := receive params st
            (Time_coq c.(current_slot),
             (to_simple_ctx_addr ctx.(ctx_from),
             (ctx.(ctx_amount),
             ctx.(ctx_contract_balance)))) in
      result_of_option res 0%nat.

  Definition crowdfunding_receive (c : Chain) (ctx : ContractCallContext) st msg :=
    match msg with
    | Some msg => crowdfunding_receive_inner c ctx msg st
    | None => Err 0%nat
    end.

  Definition CF_MODULE :
    CameLIGOMod _ _ _ storage SimpleActionBody_coq nat :=
    {| (* a name for the definition with the extracted code *)
      lmd_module_name := "cameLIGO_crowdfunding" ;

      (* definitions of operations on pairs and ints *)
      lmd_prelude :=
        CameLIGOPrelude
          ++ nl
          ++ nl
          ++ "let test_account : address = (""tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"" : address)"
          ++ nl
          ++ "let init_storage : (timestamp * (tez * address)) =
          (Tezos.get_now (), (42tez,(""tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"": address)))";

      (* initial storage *)
      lmd_init := init ;

      (* init requires some extra operations *)
      lmd_init_prelude := "";

      lmd_receive_prelude := "";

      (* the main functionality *)
      lmd_receive := crowdfunding_receive;

      (* code for the entry point *)
      lmd_entry_point :=
      "type storage = ((time_coq * (tez * address)) * ((address,tez) map * bool))" ++ nl
       ++ CameLIGOPretty.printMain "crowdfunding_receive"
                                    "msg_coq"
                                    "storage"
    |}.

  (** We run the extraction procedure inside the [TemplateMonad].
      It uses the certified erasure from [MetaCoq] and the certified deboxing procedure
      that removes application of boxes to constants and constructors. *)

End Crowdfunding.

Section CrowdfundingExtraction.
  Import Crowdfunding.
  Import SimpleBlockchainExt.AcornBlockchain.
  Import CrowdfundingDataExt.
  Import CrowdfundingContract.Receive.

  Definition TT_remap_crowdfunding : list (kername * String.string) :=

  [ (* types *)
    remap <%% address_coq %%> "address"
  ; remap <%% SimpleActionBody_coq %%> "operation"
  ; remap <%% Maps.addr_map_coq %%> "(address,tez) map"

  (* simple addresses and the execution layer addresses are treated as the same *)
  ; remap <%% @to_simple_ctx_addr %%> "(fun (x : address) -> x)"

  (* operations *)
  ; remap <%% eqb_addr %%> "eq_addr"
  ; remap <%% Maps.add_map %%> "Map.add"
  ; remap <%% lookup_map' %%> "Map.find_opt"
  ].

  (** A translation table of constructors and some constants. The corresponding definitions will be extracted and renamed. *)
  Definition TT_rename :=
    [ ("nil", "[]");
      ("mnil", "Map.empty") ].

  Time MetaCoq Run
       (CameLIGO_prepare_extraction [] TT_remap_crowdfunding (TT_rename ++ TT_rename_ctors_default) [] "cctx_instance" CF_MODULE).

  Time Definition cameLIGO_crowdfunding := Eval vm_compute in cameLIGO_crowdfunding_prepared.

  (** We redirect the extraction result for later processing and compiling with the CameLIGO compiler *)
  Redirect "../extraction/tests/extracted-code/cameligo-extract/CrowdfundingCertifiedExtraction.mligo"
  MetaCoq Run (tmMsg (String.of_string cameLIGO_crowdfunding)).

End CrowdfundingExtraction.


Require Import Classical List Relations Peano_dec.
Require Import Hahn.

Require Import Basic Dom RC11_Events RC11_Model RC11_PSC.

Set Implicit Arguments.
Remove Hints plus_n_O.

Section GlobalSC.

Variable G : execution.

Notation "'acts'" := G.(acts).
Notation "'lab'" := G.(lab).
Notation "'sb'" := G.(sb).
Notation "'rmw'" := G.(rmw).
Notation "'rf'" := G.(rf).
Notation "'mo'" := G.(mo).
Notation "'eco'" := G.(eco).
Notation "'rb'" := G.(rb).
Notation "'hb'" := G.(hb).
Notation "'psc_f'" := G.(psc_f).
Notation "'psc'" := G.(psc).
Notation "'scb'" := G.(scb).
Notation "'sb_neq_loc'" := G.(sb_neq_loc).
Notation "'sb''" := (sb \ rmw).

Notation "'E'" := G.(E).
Notation "'R'" := (R lab).
Notation "'W'" := (W lab).
Notation "'F'" := (F lab).
Notation "'RMW'" := (RMW lab).

Notation "'RW'" := (RW lab).
Notation "'FR'" := (FR lab).
Notation "'FW'" := (FW lab).

Notation "'Na'" := (Only_Na lab).
Notation "'Rlx'" := (Rlx lab).
Notation "'Rel'" := (Rel lab).
Notation "'Acq'" := (Acq lab).
Notation "'Acqrel'" := (Acqrel lab).
Notation "'Sc'" := (Sc lab).

Notation "type ~ mode" := (type ∩₁ mode) (at level 1).

Notation "'same_loc'" := G.(same_loc).
Notation "rel |loc" := (rel ∩ same_loc) (at level 1).

Implicit Type WF : Wf G.
Implicit Type NRMW : NO_RMW_EVENTS G.

Lemma global_sc_helper
  WF NRMW
  (HSC: ⦗RW~Sc⦘ ⨾ (sb' ∪ sb' ⨾ hb ⨾ sb') ⨾ ⦗RW~Sc⦘ ⊆ hb ⨾ ⦗F~Sc⦘ ⨾ hb) :
  ⦗F~Sc⦘ ⨾ hb ⨾ eco^? ⨾
    (⦗RW~Sc⦘ ⨾ (sb' ∪ sb' ⨾ hb ⨾ sb' ∪ eco) ⨾ ⦗RW~Sc⦘)^* ⨾
      eco^? ⨾ hb ⨾ ⦗F~Sc⦘ ⊆ psc_f⁺.
Proof.
assert (transitive eco).
  by apply eco_trans; assumption.
assert (transitive hb).
  by apply hb_trans; assumption.
eapply rt_ind_left with (P:= fun __ => ⦗F~Sc⦘ ⨾
  hb ⨾ eco ^? ⨾ __ ⨾ eco ^? ⨾ hb ⨾ ⦗F~Sc⦘).
- eauto with rel.
- relsf.
  arewrite (hb ⨾ eco ^? ⨾ hb ⊆ hb ∪ hb ⨾ eco ⨾ hb).
    by rewrite crE; relsf.
  apply inclusion_step_t, inclusion_refl2.
- intros k IH.
  arewrite (⦗RW~Sc⦘ ⨾ (sb' ∪ sb' ⨾ hb ⨾ sb' ∪ eco) ⨾ ⦗RW~Sc⦘ ⊆
                           ⦗RW~Sc⦘ ⨾ (sb' ∪ sb' ⨾ hb ⨾ sb') ⨾ ⦗RW~Sc⦘ ∪ eco) by basic_solver 42.
  rewrite HSC.
  arewrite (⦗F~Sc⦘ ⨾ hb ⨾ eco ^? ⨾ (hb ⨾ ⦗F~Sc⦘ ⨾ hb ∪ eco) ⊆
                           ⦗F~Sc⦘ ⨾ hb ⨾ eco ^? ⨾ hb ⨾ ⦗F~Sc⦘ ⨾ hb ⨾ eco^? ∪ ⦗F~Sc⦘ ⨾ hb ⨾ eco^?)
    by basic_solver 42.
  relsf.
  rewrite !seqA, IH.
  apply inclusion_union_l; try done.
  arewrite (psc_f⁺ ⊆ ⦗F~Sc⦘ ⨾ psc_f⁺).
    by apply doma_helper, ct_doma, doma_helper2.
  rewrite <- !seqA with (r3 := psc_f⁺).
  arewrite (⦗F~Sc⦘ ⨾ hb ⨾ eco ^? ⨾ hb ⨾ ⦗F~Sc⦘ ⊆ psc_f).
    unfold RC11_Model.psc_f; basic_solver 10.
  rewrite ct_begin at 2; basic_solver.
Qed.

Lemma RW_scb_RW :
  ⦗RW~Sc⦘ ⨾ scb ⨾ ⦗RW~Sc⦘ ⊆
    ⦗RW ~ Sc⦘ ⨾
    (sb ∪ sb_neq_loc ⨾ hb ⨾ sb_neq_loc ∪ ⦗RW⦘ ⨾ hb |loc ⨾ ⦗RW⦘ ∪ mo ∪ rb)
      ⨾ ⦗RW ~ Sc⦘.
Proof.
  unfold RC11_Model.scb; basic_solver 42.
Qed.

Lemma global_sc
  WF NRMW
  (COH: irreflexive (hb ⨾ eco^?))
  (HSC: ⦗RW~Sc⦘ ⨾ (sb' ∪ sb' ⨾ hb ⨾ sb') ⨾ ⦗RW~Sc⦘ ⊆ hb ⨾ ⦗F~Sc⦘ ⨾ hb)
  (ACYC: acyclic psc_f) : acyclic psc.
Proof.
assert (transitive eco).
  by apply eco_trans; assumption.
assert (transitive hb).
  by apply hb_trans; assumption.
eapply acyc_dom with (d:= RW~Sc) (e:= F~Sc); try edone.
- unfold RC11_Model.psc, RC11_Model.psc_base, RC11_Model.psc_f; unionL.
  arewrite (⦗Sc⦘ ≡ ⦗RW~Sc⦘ ∪ ⦗F~Sc⦘) by solve_type_mismatch 42.
  basic_solver 42.
  basic_solver 42.
- solve_type_mismatch 6.
- unfold RC11_Model.psc, RC11_Model.psc_base, RC11_Model.psc_f; relsf; rewrite !seqA.
  arewrite_false !(⦗RW~Sc⦘ ⨾ ⦗F~Sc⦘).
    solve_type_mismatch 6.
  arewrite_false !( ⦗F~Sc⦘ ⨾ ⦗RW~Sc⦘).
    solve_type_mismatch 6.
  rels.
  arewrite (⦗RW~Sc⦘ ⨾ ⦗Sc⦘ ⊆ ⦗RW~Sc⦘).
  arewrite (⦗Sc⦘ ⨾ ⦗RW~Sc⦘ ⊆ ⦗RW~Sc⦘).
  rewrite RW_scb_RW.
  rewrite hb_loc_in_eco; auto.
  arewrite (sb_neq_loc ⊆ sb').
    by apply sb_neq_loc_in_sb_minus_rmw; auto.
  arewrite (sb ⊆ sb' ∪ rmw) at 1.
    by unfold inclusion, minus_rel, union; ins; tauto.
  rewrite rmw_in_rb at 2; auto.
  rewrite mo_in_eco; auto.
  rewrite rb_in_eco; auto.
  rewrite <- !unionA.
  relsf.
  arewrite (⦗RW~Sc⦘ ⨾ sb' ⨾ ⦗RW~Sc⦘ ⊆ hb ⨾ ⦗F~Sc⦘ ⨾ hb).
    by rewrite <- HSC; rels.
  arewrite (⦗RW~Sc⦘ ⨾ sb' ⨾ hb ⨾ sb' ⨾ ⦗RW~Sc⦘ ⊆ hb ⨾ ⦗F~Sc⦘ ⨾ hb).
    by rewrite <- HSC; rels; basic_solver 10.
  eapply acyclic_mon with (r := hb ⨾ ⦗F~Sc⦘ ⨾ hb ∪ ⦗RW~Sc⦘ ⨾ eco ⨾ ⦗RW~Sc⦘).
  2: repeat apply inclusion_union_l; rels.
  apply acyclic_utt; splits.
  * apply transitiveI; arewrite_id ⦗F~Sc⦘ at 1; relsf.
  * apply transitiveI.
    arewrite_id ⦗RW~Sc⦘ at 2; relsf.
    arewrite_id ⦗RW~Sc⦘ at 2; relsf.
  * arewrite_id ⦗F~Sc⦘ at 1; relsf.
    by apply irr_hb.
  * arewrite_id ⦗RW~Sc⦘; relsf.
    by apply irr_eco.
  * arewrite (⦗F~Sc⦘ ⊆ ⦗F~Sc⦘ ⨾ ⦗F~Sc⦘).
      by basic_solver.
    do 2 (apply acyclic_seqC; try rewrite !seqA).
    eapply acyclic_mon with (r := psc_f); try done.
    unfold RC11_Model.psc_f.
    basic_solver 12.
- by rewrite psc_f_f.
- rewrite psc_rw_rw; try assumption.
  rewrite RW_scb_RW.
  arewrite (
    sb ∪ sb_neq_loc ⨾ hb ⨾ sb_neq_loc ∪ ⦗RW⦘ ⨾ hb|loc ⨾ ⦗RW⦘ ∪ mo ∪ rb
      ⊆ sb' ∪ sb' ⨾ hb ⨾ sb' ∪ eco
  ).
  { arewrite (sb ⊆ sb' ∪ rmw).
      by apply inclusion_union_minus.
    rewrite rmw_in_rb at 2; try assumption.
    rewrite rb_in_eco, mo_in_eco, sb_neq_loc_in_sb_minus_rmw, hb_loc_in_eco; try assumption.
    basic_solver 10.
  }
  sin_rewrite psc_rw_f; try assumption.
  sin_rewrite psc_f_rw; try assumption.
  rewrite psc_f_f; try assumption.
  arewrite_id ⦗RW~Sc⦘ at 1.
  arewrite_id ⦗RW~Sc⦘ at 3.
  rels.
  rewrite <- !seqA with (r3 := psc_f ^*), global_sc_helper; try assumption.
  red; rels.
Qed.

(* Definition change_mode (l: label) (m: mode) : label :=
  match l with
  | Aload l v _ => Aload l v m
  | Astore l v _ => Astore l v m
  | Afence _ => Afence m
  end. *)

(* Definition change_modes (G: execution) (A: event -> Prop) (m: mode): execution :=
  Build_execution
    acts
    (fun a => if (A a) then change_mode (lab a) m else lab a)
    sb rmw rf mo. *)

(* Lemma transf_g
  (NO_SC: ⦗Sc⦘ ≡ ∅₂)
  A (A_SUB: A ⊆₁ R_acq ∪₁ W_rel)
  (A1: ⦗A⦘ ⨾ (sb' ∪ sb'⨾hb⨾sb') ⨾ ⦗A⦘ ⊆ hb ⨾ ⦗F~Sc⦘ ⨾ hb)
  (A2: ⦗A⦘ ⨾ rmw ≡ rmw ⨾ ⦗A⦘)
  (G' : execution) (CHANGE: G' = G)
  : consistent G'.
Proof.
Admitted. *)

End GlobalSC.


(* *********************************************************************)
(*                                                                     *)
(*            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 Export AuxStateDataType.
Require Import Constant.
Require Import Coqlib.
Require Import Maps.
Require Import Integers.
Require Import XOmega.
Require Import CLemmas.
Require Import INVLemmaIntel.
Require Import Values.
Require Import liblayers.compat.CompatGenSem.

Section REAL_EPT.

  Function Calculate_EPDTE_at_j (i: Z) (j: Z) (ept: EPT) : EPT :=
    match ZMap.get 0 ept with
      | EPML4EValid epdpt =>
        match ZMap.get i epdpt with
          | EPDPTEValid epdt =>
            ZMap.set 0 (EPML4EValid (ZMap.set i (EPDPTEValid (ZMap.set j (EPDTEValid (ZMap.init EPTEUndef)) epdt)) epdpt)) ept
          | _ => ept
        end
      | _ => ept
    end.

  Fixpoint Calculate_EPDTE (i: Z) (j: nat) (ept: EPT) : EPT :=
    match j with
      | O => Calculate_EPDTE_at_j i 0 ept
      | S k => Calculate_EPDTE_at_j i (Z.of_nat (S k)) (Calculate_EPDTE i k ept)
    end.

  Function Calculate_EPDPTE_at_i (i: Z) (ept: EPT) : EPT :=
    match ZMap.get 0 ept with
      | EPML4EValid epdpt =>
        Calculate_EPDTE i 511 (ZMap.set 0 (EPML4EValid (ZMap.set i (EPDPTEValid (ZMap.init EPDTEUndef)) epdpt)) ept)
      | _ => ept
    end.
  Fixpoint Calculate_EPDPTE (i: nat) (ept: EPT) : EPT :=
    match i with
      | O => Calculate_EPDPTE_at_i 0 ept
      | S k => Calculate_EPDPTE_at_i (Z.of_nat (S k)) (Calculate_EPDPTE k ept)
    end.

  Definition real_ept (ept: EPT) := Calculate_EPDPTE 3 (ZMap.set 0 (EPML4EValid (ZMap.init EPDPTEUndef)) ept).

End REAL_EPT.

Section REAL_VMCS.

  Definition write64_aux (enc: Z) (value: Z64) (d: ZMap.t val) : ZMap.t val :=
    let d1 := ZMap.set enc (Vint (Int64.loword (Int64.repr (Z642Z value)))) d in
    ZMap.set (enc + 1) (Vint (Int64.hiword (Int64.repr (Z642Z value)))) d1.

  Definition write64_block_aux (enc: Z) (value: val) (d: ZMap.t val) : ZMap.t val :=
    let d1 := ZMap.set enc value d in
    ZMap.set (enc + 1) Vzero d1.

  Definition real_vmcs (vm: VMCS) (vmi: VMXInfo) (pml4ept_b tss_b gdt_b idt_b msr_bitmap_b io_bitmap_b host_rip_b: block):=
    match vm with
      | VMCSValid revid abrtid m =>

        let pinbased_ctls := ZMap.get (VMX_INFO_PINBASED_CTLS) vmi in
        let procbased_ctls := ZMap.get (VMX_INFO_PROCBASED_CTLS) vmi in
        let procbased_ctls2 := ZMap.get (VMX_INFO_PROCBASED_CTLS2) vmi in
        let exit_ctls := ZMap.get (VMX_INFO_EXIT_CTLS) vmi in
        let entry_ctls := ZMap.get (VMX_INFO_ENTRY_CTLS) vmi in
        let cr0_ones_mask := ZMap.get (VMX_INFO_CR0_ONES_MASK) vmi in
        let cr0_zeros_mask := ZMap.get (VMX_INFO_CR0_ZEROS_MASK) vmi in
        let cr4_ones_mask := ZMap.get (VMX_INFO_CR4_ONES_MASK) vmi in
        let cr4_zeros_mask := ZMap.get (VMX_INFO_CR4_ZEROS_MASK) vmi in

        let m1 := ZMap.set C_VMCS_PIN_BASED_CTLS (Vint (Int.repr pinbased_ctls)) m in
        let m2 := ZMap.set C_VMCS_PRI_PROC_BASED_CTLS (Vint (Int.repr procbased_ctls)) m1 in
        let m3 := ZMap.set C_VMCS_SEC_PROC_BASED_CTLS (Vint (Int.repr procbased_ctls2)) m2 in
        let m4 := ZMap.set C_VMCS_EXIT_CTLS (Vint (Int.repr exit_ctls)) m3 in
        let m5 := ZMap.set C_VMCS_ENTRY_CTLS (Vint (Int.repr entry_ctls)) m4 in

        let m6 := ZMap.set C_VMCS_HOST_RIP (Vptr host_rip_b Int.zero) m5 in

        (*rcr0_spec adt*)
        let m7 := ZMap.set C_VMCS_HOST_CR0 Vzero m6 in
        (*rcr3_spec adt*)
        let m8 := ZMap.set C_VMCS_HOST_CR3 Vzero m7 in
        (*rcr4_spec adt*)
        let m9 := ZMap.set C_VMCS_HOST_CR4 Vzero m8 in

        let m10 := ZMap.set C_VMCS_HOST_ES_SELECTOR (Vint (Int.repr CPU_GDT_KDATA)) m9 in
        let m11 := ZMap.set C_VMCS_HOST_CS_SELECTOR (Vint (Int.repr CPU_GDT_KCODE)) m10 in
        let m12 := ZMap.set C_VMCS_HOST_SS_SELECTOR (Vint (Int.repr CPU_GDT_KDATA)) m11 in
        let m13 := ZMap.set C_VMCS_HOST_DS_SELECTOR (Vint (Int.repr CPU_GDT_KDATA)) m12 in
        let m14 := ZMap.set C_VMCS_HOST_FS_SELECTOR (Vint (Int.repr CPU_GDT_KDATA)) m13 in
        let m15 := ZMap.set C_VMCS_HOST_GS_SELECTOR (Vint (Int.repr CPU_GDT_KDATA)) m14 in
        let m16 := ZMap.set C_VMCS_HOST_TR_SELECTOR (Vint (Int.repr CPU_GDT_TSS)) m15 in

        let m17 := ZMap.set C_VMCS_HOST_FS_BASE Vzero m16 in
        let m18 := ZMap.set C_VMCS_HOST_GS_BASE Vzero m17 in

        let m19 := ZMap.set C_VMCS_HOST_TR_BASE (Vptr tss_b Int.zero) m18 in
        let m20 := ZMap.set C_VMCS_HOST_GDTR_BASE (Vptr gdt_b Int.zero) m19 in
        let m21 := ZMap.set C_VMCS_HOST_IDTR_BASE (Vptr idt_b Int.zero) m20 in

        (* rdmsr_spec MSR_IA32_SYSENTER_CS adt *)
        let m22 := ZMap.set C_VMCS_HOST_IA32_SYSENTER_CS Vzero m21 in
        (*rdmsr_spec MSR_IA32_SYSENTER_ESP adt*)
        let m23 := ZMap.set C_VMCS_HOST_IA32_SYSENTER_ESP Vzero m22 in
        (*rdmsr_spec MSR_IA32_SYSENTER_EIP adt*)
        let m24 := ZMap.set C_VMCS_HOST_IA32_SYSENTER_EIP Vzero m23 in
        (*rdmsr_spec MSR_IA32_PERF_GLOBAL_CTRL adt*)
        let m25 := write64_aux C_VMCS_HOST_IA32_PERF_GLOBAL_CTRL (VZ64 0) m24 in
        (*rdmsr_spec MSR_PAT adt*)
        let m26 := write64_aux C_VMCS_HOST_IA32_PAT (VZ64 0) m25 in
        (*rdmsr_spec MSR_EFER adt*)
        let m27 := write64_aux C_VMCS_HOST_IA32_EFER (VZ64 0) m26 in

        let m28 := ZMap.set C_VMCS_GUEST_CR0 (Vint (Int.repr (Z.lor v0x60000010 CR0_NE))) m27 in
        let m29 := ZMap.set C_VMCS_GUEST_CR3 Vzero m28 in
        let m30 := ZMap.set C_VMCS_GUEST_CR4 (Vint (Int.repr CR4_VMXE)) m29 in
        let m31 := ZMap.set C_VMCS_GUEST_DR7 (Vint (Int.repr v0x00000400)) m30 in

        let m32 := write64_aux C_VMCS_GUEST_IA32_PAT (VZ64 v0x7040600070406) m31 in
        let m33 := ZMap.set C_VMCS_GUEST_IA32_SYSENTER_CS Vzero m32 in
        let m34 := ZMap.set C_VMCS_GUEST_IA32_SYSENTER_ESP Vzero m33 in
        let m35 := ZMap.set C_VMCS_GUEST_IA32_SYSENTER_EIP Vzero m34 in
        let m36 := write64_aux C_VMCS_GUEST_IA32_DEBUGCTL (VZ64 0) m35 in
        (*FIXME: it should be 64 bits*)
        let m37 := write64_block_aux C_VMCS_EPTP (Vptr pml4ept_b (Int.repr EPTP_pml4)) m36 in

        let m38 := ZMap.set C_VMCS_VPID Vone m37 in
(*        let m38' := ZMap.set C_VMCS_EXCEPTION_BITMAP (Vint (Int.repr T_MCHK_SHIFT)) m38 in *)
        let m39 := write64_block_aux C_VMCS_MSR_BITMAP (Vptr msr_bitmap_b Int.zero) m38 in
        let m40 := write64_aux C_VMCS_LINK_POINTER (VZ64 v0xffffffffffffffff) m39 in
        let m41 := ZMap.set C_VMCS_CR0_MASK (Vint (Int.repr (Z.lor cr0_ones_mask cr0_zeros_mask))) m40 in
        let m42 := ZMap.set C_VMCS_CR0_SHADOW (Vint (Int.repr cr0_ones_mask)) m41 in
        let m43 := ZMap.set C_VMCS_CR4_MASK (Vint (Int.repr (Z.lor cr4_ones_mask cr4_zeros_mask))) m42 in
        let m44 := ZMap.set C_VMCS_CR4_SHADOW (Vint (Int.repr cr4_ones_mask)) m43 in
        let m45 := write64_block_aux C_VMCS_IO_BITMAP_A (Vptr io_bitmap_b Int.zero) m44 in
        let m46 := write64_block_aux C_VMCS_IO_BITMAP_B (Vptr io_bitmap_b (Int.repr PgSize)) m45 in

        let m47 := ZMap.set C_VMCS_GUEST_ACTIVITY Vzero m46 in
        let m48 := ZMap.set C_VMCS_GUEST_INTERRUPTIBILITY Vzero m47 in
        let m49 := ZMap.set C_VMCS_GUEST_PENDING_DBG_EXCEPTIONS Vzero m48 in
        let m50 := ZMap.set C_VMCS_ENTRY_INTR_INFO Vzero m49 in

        let revid1 := Vzero in
        VMCSValid revid1 abrtid m50
    end.

  Lemma real_vmcs_inject_neutral:
    forall vm vmi n pml4ept_b tss_b gdt_b idt_b msr_bitmap_b io_bitmap_b
           host_rip_b,
      VMCS_inject_neutral vm n ->
      Mem.flat_inj n pml4ept_b = Some (pml4ept_b, 0) ->
      Mem.flat_inj n tss_b = Some (tss_b, 0) ->
      Mem.flat_inj n gdt_b = Some (gdt_b, 0) ->
      Mem.flat_inj n idt_b = Some (idt_b, 0) ->
      Mem.flat_inj n msr_bitmap_b = Some (msr_bitmap_b, 0) ->
      Mem.flat_inj n io_bitmap_b = Some (io_bitmap_b, 0) ->
      Mem.flat_inj n host_rip_b = Some (host_rip_b, 0) ->
      VMCS_inject_neutral
        (real_vmcs vm vmi pml4ept_b tss_b gdt_b idt_b msr_bitmap_b io_bitmap_b
                   host_rip_b) n.
  Proof.
    intros. unfold real_vmcs.
    destruct vm.
    inversion H; subst.
    repeat (eapply VMCS_inject_neutral_gss_Vint_same
                   || eapply VMCS_inject_neutral_gss_same); eauto 1;
    split; econstructor; eauto;
    generalize (H11 ofs); intro tmp; destruct tmp; eauto.
  Qed.

End REAL_VMCS.

Section REAL_VMX.

  Definition real_vmx (vm: VMX): VMX :=
    let vm1 := ZMap.set VMX_G_RIP' (Vint (Int.repr v0xfff0)) vm in
    let vm2 := ZMap.set VMX_VPID' Vone vm1 in
    let vm3 := ZMap.set VMX_G_CR2' Vzero vm2 in
    let vm4 := ZMap.set VMX_G_DR0' Vzero vm3 in
    let vm5 := ZMap.set VMX_G_DR1' Vzero vm4 in
    let vm6 := ZMap.set VMX_G_DR2' Vzero vm5 in
    let vm7 := ZMap.set VMX_G_DR3' Vzero vm6 in
    ZMap.set VMX_G_DR6' (Vint (Int.repr v0xffff0ff0)) vm7.

  Lemma real_vmx_inject_neutral:
    forall vm n,
      VMX_inject_neutral vm n ->
      VMX_inject_neutral
        (real_vmx vm) n.
  Proof.
    intros. unfold real_vmx.
    repeat eapply VMX_inject_neutral_gss_Vint.
    assumption.
  Qed.

End REAL_VMX.


(* SPDX-License-Identifier: GPL-2.0 *)
Require Import Coqlib.
Require Import Maps.
Require Import Integers.
Require Import Values.
Require Import GenSem.
Require Import Maps.
Require Import Integers.
Require Import Values.
Require Import RealParams.
Require Import GenSem.
Require Import Clight.
Require Import CDataTypes.
Require Import Ctypes.
Require Import PrimSemantics.
Require Import CompatClightSem.
Require Import liblayers.compcertx.Stencil.
Require Import liblayers.compat.CompatLayers.
Require Import liblayers.compat.CompatGenSem.

Require Import MmioCoreAux.Spec.
Require Import AbstractMachine.Spec.
Require Import MmioCoreAux.Layer.
Require Import RData.
Require Import MmioRaw.Spec.
Require Import Constants.
Require Import HypsecCommLib.

Local Open Scope Z_scope.

Section MmioCoreSpec.

  Definition handle_smmu_write_spec (hsr: Z) (fault_ipa: Z64) (len: Z) (index: Z) (adt: RData) : option RData :=
    match fault_ipa with
    | VZ64 fault_ipa =>
      rely is_int hsr; rely is_addr fault_ipa; rely is_smmu index;
      if halt adt then Some adt else
      match SMMU_ID @ (lock adt) with
      | LockOwn true =>
        let vcpuid := cur_vcpuid adt in
        let rt := host_dabt_get_rd' hsr in
        rely is_vcpu vcpuid; rely is_int rt;
        let offset := Z.land fault_ipa SMMU_OFFSET_MASK in
        if offset <? SMMU_GLOBAL_BASE then
          when' data == get_shadow_ctxt_spec HOSTVISOR vcpuid rt adt;
          rely is_int64 data;
          when ret ==
            (if (offset >=? 0) && (offset <=? ARM_SMMU_GR1_BASE) then
              if offset =? ARM_SMMU_GR0_sCR0 then
                let smmu_enable := Z.land (Z.shiftr data sCR0_SMCFCFG_SHIFT) 1 in
                if smmu_enable =? 0 then Some 0 else Some 1
              else if offset =? ARM_SMMU_GR0_sCR2 then
                      if (Z.land data 255) =? 0 then Some 1 else Some 0
                  else Some 1
            else if (offset >=? ARM_SMMU_GR1_BASE) && (offset <? ARM_SMMU_GR1_END) then
                    let n := (offset - ARM_SMMU_GR1_BASE) / 4 in
                    rely is_smmu_cfg n;
                    let vmid := (smmu_id index n) @ (smmu_vmid (shared adt)) in
                    rely is_vmid vmid;
                    let type := Z.shiftr data CBAR_TYPE_SHIFT in
                    let t_vmid := Z.land data CBAR_VMID_MASK in
                    if vmid =? 0 then Some 1
                    else
                      if (type =? CBAR_TYPE_S2_TRANS) && (vmid =? t_vmid) then Some 1 else Some 0
                else Some 1);
          if ret =? 0 then Some adt {halt: true}
          else if len =? 8 then Some adt
               else if len =? 4 then Some adt
                    else Some adt {halt: true}
        else
          let off' := offset - SMMU_GLOBAL_BASE in
          let cb_offset := Z.land off' ARM_SMMU_PGSHIFT_MASK in
          if cb_offset =? ARM_SMMU_CB_TTBR0 then
            let cbndx := Z.shiftr (offset - SMMU_GLOBAL_BASE) ARM_SMMU_PGSHIFT in
            rely is_smmu_cfg cbndx;
            let val := SMMU_TTBR index cbndx in
            if len =? 8 then Some adt
            else if len =? 4 then Some adt
                 else Some adt {halt: true}
          else if cb_offset =? ARM_SMMU_CB_CONTEXTIDR then Some adt {halt: true}
               else
                 if len =? 8 then
                   when' data == get_shadow_ctxt_spec HOSTVISOR vcpuid rt adt;
                   rely is_int64 data;
                   Some adt
                 else if len =? 4 then Some adt
                      else Some adt {halt: true}
      | _ => None
      end
    end.

  Definition handle_smmu_read_spec (hsr: Z) (fault_ipa: Z64) (len: Z) (adt: RData) : option RData :=
    match fault_ipa with
    | VZ64 fault_ipa =>
      rely is_int hsr;
      if halt adt then Some adt else
      let vcpuid := cur_vcpuid adt in
      let rt := host_dabt_get_rd' hsr in
      let n := HOSTVISOR @ (data_log adt) in
      let data := (doracle adt) HOSTVISOR n in
      rely is_vcpu vcpuid; rely is_int rt; rely is_int64 data;
      let dlog' := (data_log adt) # HOSTVISOR == (n + 1) in
      if len =? 8 then
        set_shadow_ctxt_spec HOSTVISOR vcpuid rt (VZ64 data) (adt {data_log: dlog'})
      else if len =? 4 then
        set_shadow_ctxt_spec HOSTVISOR vcpuid rt (VZ64 (Z.land data INVALID)) (adt {data_log: dlog'})
      else
        Some adt {halt: true}
    end.

End MmioCoreSpec.

Section MmioCoreSpecLow.

  Context `{real_params: RealParams}.

  Notation LDATA := RData.

  Notation LDATAOps := (cdata (cdata_ops := MmioCoreAux_ops) LDATA).

  Definition handle_smmu_write_spec0 (hsr: Z) (fault_ipa: Z64) (len: Z) (index: Z) (adt: RData) : option RData :=
    match fault_ipa with
    | VZ64 fault_ipa =>
      let offset := Z.land fault_ipa SMMU_OFFSET_MASK in
      if offset <? SMMU_GLOBAL_BASE then
        when ret == handle_smmu_global_access_spec hsr (VZ64 offset) index adt;
        rely is_int ret;
        if ret =? 0 then
          panic_spec adt
        else
          __handle_smmu_write_spec hsr (VZ64 fault_ipa) len (VZ64 0) 0 adt
      else
        when ret == handle_smmu_cb_access_spec (VZ64 offset) adt;
        rely is_int ret;
        if ret =? 0 then
          panic_spec adt
        else
          if ret =? 2 then
            when cbndx == smmu_get_cbndx_spec (VZ64 offset) adt;
            rely is_int cbndx;
            when' val == get_smmu_cfg_hw_ttbr_spec cbndx index adt;
            rely is_int64 val;
            __handle_smmu_write_spec hsr (VZ64 fault_ipa) len (VZ64 val) 1 adt
          else
            __handle_smmu_write_spec hsr (VZ64 fault_ipa) len (VZ64 0) 0 adt
    end.

  Definition handle_smmu_read_spec0 (hsr: Z) (fault_ipa: Z64) (len: Z) (adt: RData) : option RData :=
    match fault_ipa with
    | VZ64 fault_ipa =>
      let offset := Z.land fault_ipa SMMU_OFFSET_MASK in
      if offset <? SMMU_GLOBAL_BASE then
        __handle_smmu_read_spec hsr (VZ64 fault_ipa) len adt
      else
        __handle_smmu_read_spec hsr (VZ64 fault_ipa) len adt
    end.

  Inductive handle_smmu_write_spec_low_step `{StencilOps} `{Mem.MemoryModelOps} `{UseMemWithData mem}:
    sextcall_sem (mem := mwd LDATAOps) :=
  | handle_smmu_write_spec_low_intro s (WB: _ -> Prop) m'0 labd labd' hsr fault_ipa len index
      (Hinv: high_level_invariant labd)
      (Hspec: handle_smmu_write_spec0 (Int.unsigned hsr) (VZ64 (Int64.unsigned fault_ipa)) (Int.unsigned len) (Int.unsigned index) labd = Some labd'):
      handle_smmu_write_spec_low_step s WB ((Vint hsr)::(Vlong fault_ipa)::(Vint len)::(Vint index)::nil) (m'0, labd) Vundef (m'0, labd').

  Inductive handle_smmu_read_spec_low_step `{StencilOps} `{Mem.MemoryModelOps} `{UseMemWithData mem}:
    sextcall_sem (mem := mwd LDATAOps) :=
  | handle_smmu_read_spec_low_intro s (WB: _ -> Prop) m'0 labd labd' hsr fault_ipa len
      (Hinv: high_level_invariant labd)
      (Hspec: handle_smmu_read_spec0 (Int.unsigned hsr) (VZ64 (Int64.unsigned fault_ipa)) (Int.unsigned len) labd = Some labd'):
      handle_smmu_read_spec_low_step s WB ((Vint hsr)::(Vlong fault_ipa)::(Vint len)::nil) (m'0, labd) Vundef (m'0, labd').

  Section WITHMEM.

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

    Definition handle_smmu_write_spec_low: compatsem LDATAOps :=
      csem handle_smmu_write_spec_low_step (type_of_list_type (Tint32::Tint64::Tint32::Tint32::nil)) Tvoid.

    Definition handle_smmu_read_spec_low: compatsem LDATAOps :=
      csem handle_smmu_read_spec_low_step (type_of_list_type (Tint32::Tint64::Tint32::nil)) Tvoid.

  End WITHMEM.

End MmioCoreSpecLow.