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

Open Local Scope string_scope.
Open Local Scope error_monad_scope.

Module ALOPGENIMPL.
  Export ALOpGen.ALOPGEN.

  Lemma hprim_finite_type:
    forall
      (Q: MALOP.primOp -> Prop)
      (Q_dec: forall p, {Q p} + {~ Q p}),
      {forall p, Q p} + {~ forall p, Q p}.
  Proof with (try (right; eauto; fail)).
    intros.
    destruct (Q_dec MALOP.PSetPE)...
    destruct (Q_dec MALOP.PSetPT)...
    destruct (Q_dec MALOP.PGetNps)...
    destruct (Q_dec MALOP.PIsNorm)...
    destruct (Q_dec MALOP.PATGetU)...
    destruct (Q_dec MALOP.PATSetU)...
    destruct (Q_dec MALOP.PTrapIn)...
    destruct (Q_dec MALOP.PTrapOut)...
    destruct (Q_dec MALOP.PHostIn)...
    destruct (Q_dec MALOP.PHostOut)...
    destruct (Q_dec MALOP.PTrapGet)...
    destruct (Q_dec MALOP.PTrapRet)...
    destruct (Q_dec MALOP.PMemInit)...
    left; destruct p; assumption.
  Defined.

  Local Open Scope Z_scope.

 Section WithPrimitives.

  Context `{real_params: RealParams}.

    Notation HDATA := (MALOP.AbData (kern_high := kern_high) (kern_low := kern_low) (maxpage:= maxpage)).
    Notation LDATA := (MALINIT.AbData (PgSize := PgSize) (kern_low := kern_low)).

    Notation Hfundef := (fundef (external_function:= MALOP.primOp)).
    Notation Lfundef := (fundef (external_function:= MALINIT.primOp)).

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

    Notation dummy := (AST.Internal nil).

    Definition source_implem_extfuns (p: MALOP.primOp): funkind :=
      match p with
        | MALOP.PSetPE => Code _ (AST.External MALINIT.PSetPE)
        | MALOP.PSetPT => Code _ (AST.External MALINIT.PSetPT)
        | MALOP.PTrapIn => Code _ (AST.External MALINIT.PTrapIn)
        | MALOP.PTrapOut => Code _ (AST.External MALINIT.PTrapOut)
        | MALOP.PHostIn => Code _ (AST.External MALINIT.PHostIn)
        | MALOP.PHostOut => Code _ (AST.External MALINIT.PHostOut)
        | MALOP.PTrapGet => Code _ (AST.External MALINIT.PTrapGet)
        | MALOP.PTrapRet => Code _ (AST.External MALINIT.PTrapRet)
        | MALOP.PGetNps => Code _ (AST.External MALINIT.PGetNps)
        | MALOP.PIsNorm => Code _ (AST.External MALINIT.PIsNorm)
        | MALOP.PATGetU => Code _ (AST.External MALINIT.PATGetU)
        | MALOP.PATSetU => Code _ (AST.External MALINIT.PATSetU)
        | MALOP.PMemInit => SourceFun (Clight.Internal (MALINITCODE.f_mem_init set_nps set_norm get_size get_mms get_mml is_usable boot_loader)) dummy
      end.

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

    Definition source_implem_impl_globs : list (ident * option (globdef funkind varkind)) :=
      (set_nps, Some (Gfun (SourceFun (Clight.External (MALINIT.PSetNps) (Ctypes.Tcons tint Ctypes.Tnil) Ctypes.Tvoid) dummy)))
        :: (set_norm, Some (Gfun (SourceFun (Clight.External (MALINIT.PATSetNorm) (Ctypes.Tcons tint (Ctypes.Tcons tint Ctypes.Tnil)) Ctypes.Tvoid) dummy)))
        :: (get_size, Some (Gfun (SourceFun (Clight.External (MALINIT.PGetSize) Ctypes.Tnil tint) dummy)))
        :: (get_mms, Some (Gfun (SourceFun (Clight.External (MALINIT.PMMGetS) (Ctypes.Tcons tint Ctypes.Tnil) tint) dummy)))
        :: (get_mml, Some (Gfun (SourceFun (Clight.External (MALINIT.PMMGetL) (Ctypes.Tcons tint Ctypes.Tnil) tint) dummy)))
        :: (is_usable, Some (Gfun (SourceFun (Clight.External (MALINIT.PIsUsable) (Ctypes.Tcons tint Ctypes.Tnil) tint) dummy)))
        :: (boot_loader, Some (Gfun (SourceFun (Clight.External (MALINIT.PBootLoader) (Ctypes.Tcons tint Ctypes.Tnil) Ctypes.Tvoid) dummy)))
        :: nil.

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

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

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

    Notation Hprogram := (Asm.program (external_function:= MALOP.primOp)).
    Notation Lprogram := (Asm.program (external_function:= MALINIT.primOp)).

    Let Im_meminit: Lfundef := transf_source_fun' transf_clight_fundef (source_implem_extfuns MALOP.PMemInit).

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

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

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

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

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

    Section WithProg.

    Variable prog: Hprogram.

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

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

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

    Hypothesis prog_nonempty:
      prog_defs_names prog <> nil.

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

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

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

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

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

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

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

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

    Let tsge := Genv.globalenv tsprog.

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

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

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

    (** boot_loader *)

    Let bbootloader : block := Genv.genv_next ge + Z.of_nat 6.

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

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

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

    (** get_size *)

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

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

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

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

    (** get_mms *)

    Let bgetmms: block := Genv.genv_next ge + Z.of_nat 3.

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

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

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

    (** get_mml *)

    Let bgetmml: block := Genv.genv_next ge + Z.of_nat 4.

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

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

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

    (** is_usable *)

    Let bisusable: block := Genv.genv_next ge + Z.of_nat 5.

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

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

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

    (** set_norm *)

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

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

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

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

    (** set_nps *)

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

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

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

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

    Context `{PageFaultHandler_LOC: ident}.

    Section WITHMEM.

    Context {mem__MALOP mem__MALINIT}
      `{HHmem: !LayerMemoryModel HDATA mem__MALOP}
      `{HLmem: !LayerMemoryModel LDATA mem__MALINIT}
      `{HLayerInject: !LayerMemoryInjections HDATA LDATA _ _}.

    Instance HLayer: LayerDefinition HDATA MALOP.primOp mem__MALOP :=
      MALOP.layer_def (maxpage := maxpage) (real_nps := real_nps) (real_AT := real_AT).

    Instance LLayer: LayerDefinition LDATA MALINIT.primOp mem__MALINIT :=
      MALINIT.layer_def (PgSize := PgSize) (real_size := real_size) (real_mm := real_mm) (kern_low := kern_low) (maxpage := maxpage).

      Notation HLoad:= (MALOP.exec_loadex (NPT_LOC:= NPT_LOC) (PgSize:=PgSize)
                                          (PageFaultHandler_LOC := PageFaultHandler_LOC)).

      Notation HStore:= (MALOP.exec_storeex (NPT_LOC:= NPT_LOC) (PgSize:= PgSize)
                                            (PageFaultHandler_LOC := PageFaultHandler_LOC)).

      Notation LLoad := (MALINIT.exec_loadex (NPT_LOC:= NPT_LOC) (PageFaultHandler_LOC := PageFaultHandler_LOC)).

      Notation LStore:= ( MALINIT.exec_storeex (NPT_LOC:= NPT_LOC) (PageFaultHandler_LOC := PageFaultHandler_LOC)).

      Notation lstep:= (MALINIT.step (NPT_LOC:= NPT_LOC) (PageFaultHandler_LOC := PageFaultHandler_LOC)
                                     (maxpage:= maxpage) (real_size:= real_size) (real_mm:= real_mm)).

      Notation LADT := MALINIT.ADT.

        Let meminit_spec:
        forall r' b  m0 labd' mbi_adr sg,
          let labd := Mem.get_abstract_data m0 in
          r' PC = Vptr b Int.zero
          -> Genv.find_funct_ptr tge b = Some (Im_meminit)
          -> MALINIT.mem_init (kern_high:=kern_high) (maxpage:=maxpage) labd real_size real_nps real_mm
                              (real_AT (MALINIT.AT (LADT labd))) (Int.unsigned mbi_adr) = Some labd'
          -> (forall b o, r' ESP = Vptr b o -> Mem.tget m0 b = Some Tag_stack)
          -> r' ESP <> Vundef
          -> r' RA  <> Vundef
          -> Genv.find_funct_ptr ge b = Some (External MALOP.PMemInit)
          -> asm_invariant tge (State r' m0)
          -> sg = mksignature (Tint::nil) None
          -> extcall_arguments r' m0 sg (Vint mbi_adr::nil)
          -> exists f' m0' r_,
               inject_incr (Mem.flat_inj (Mem.nextblock m0)) f'
               /\ Memtype.Mem.inject f' m0 m0'
               /\ Mem.nextblock m0 <= Mem.nextblock m0'
               /\ plus lstep tge (State r' m0) E0
                       (State r_ (Mem.put_abstract_data m0' labd'))
               /\ True
               /\ r_ PC = r' RA
               /\ r_ # ESP = r' # ESP
               /\ (forall l,
                     ~In (Locations.R l) Conventions1.temporaries -> ~In (Locations.R l) Conventions1.destroyed_at_call
                     -> Val.lessdef (r' (preg_of l)) (r_ (preg_of l))).
        Proof.
          intros.
          exploit (ClightImplemExtra.bigstep_clight_to_lsem
                     MALOP.primOp
                     (exec_load := LLoad)
                     (exec_store := LStore)
                     (primitive_call := MALINIT.primitive_call)
                     (is_primitive_call := MALINIT.is_primitive_call)
                     (kernel_mode := MALINIT.kernel_mode)
                  ).
          apply MALINIT.exec_load_exec_loadex.
          apply MALINIT.exec_store_exec_storeex.
          apply MALINIT.extcall_not_primitive.
          apply MALINIT.primitive_kernel_mode.
          3: eassumption.
          assumption.
          assumption.
          2: eassumption.
          5: eassumption.
          9: eassumption.
          7: reflexivity.
          intros; eapply MALINITCODE.mem_init_correct.
           2: eassumption. eassumption. assumption.
           2: eassumption. eassumption. assumption.
           2: eassumption. eassumption. assumption.
           2: eassumption. eassumption. assumption.
           2: eassumption. eassumption. assumption.
           2: eassumption. eassumption. assumption.
           2: eassumption. eassumption. assumption.
          assumption.
          (* BEGIN hypotheses coming from refinement proof *)
          eassumption.
          reflexivity.
          (* END hypotheses coming from refinement proof *)
          assumption.
          assumption.
          assumption.
          assumption.
          assumption.
          unfold MALINIT.kernel_mode.
          destruct (MALINIT.INV (Mem.get_abstract_data m0)).
          apply MALINIT.mem_init_eq in H1.
          functional inversion H1.
          functional inversion H10; unfold adt0 in *; auto.
          destruct 1 as [? [? [m_asm [? [INJ [NB [PLUS [? [? [? ?]]]]]]]]]].
          generalize (Mem.put_abstract_data_inject_inside _ _ _ INJ (Mem.get_abstract_data m0)).
          rewrite Mem.put_put_abstract_data.
          rewrite Mem.put_get_abstract_data.
          intro.
          replace (Mem.nextblock m_asm) with (Mem.nextblock (Mem.put_abstract_data m_asm (Mem.get_abstract_data m0))) in NB by (rewrite Mem.nextblock_put_abstract_data; reflexivity).
          replace m_asm with (Mem.put_abstract_data (Mem.put_abstract_data m_asm (Mem.get_abstract_data m0)) labd') in PLUS.
          eauto 11.
          rewrite Mem.put_put_abstract_data.
          replace labd' with (Mem.get_abstract_data m_asm).
          rewrite Mem.put_get_abstract_data.
          reflexivity.
          erewrite <- Mem.get_abstract_data_inject_inside; eauto.
          rewrite Mem.get_put_abstract_data.
          reflexivity.
        Qed.

    Theorem transf_program_correct:
        Smallstep.backward_simulation
          (MALOP.semantics (NPT_LOC:= NPT_LOC) (PgSize:=PgSize) (kern_low:=kern_low) (kern_high:=kern_high) (maxpage:=maxpage)
                           (PageFaultHandler_LOC:= PageFaultHandler_LOC) (real_nps:= real_nps) (real_AT:= real_AT) prog)
          (MALINIT.semantics (NPT_LOC:= NPT_LOC) (PageFaultHandler_LOC:= PageFaultHandler_LOC) (maxpage:= maxpage)
                             (real_size:= real_size) (real_mm:= real_mm) tprog).
    Proof.
      eapply ALOPGEN.transf_program_correct; simpl; eauto.
      Grab Existential Variables.
      omega.
      inversion real_params; auto.
      inversion real_params; auto.
      inversion real_params; auto.
      inversion real_params; auto.
    Qed.

    End WITHMEM.

    End WithProg.

 End WithPrimitives.

End ALOPGENIMPL.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsRef2.Spec.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition destroy_table (llt_gidx: Z) (idx: Z) (rtt_addr: Z) (rtt_gidx: Z) (level: Z) (map_addr: Z) (adt: RData) :=
    let gn_llt := (gs (share adt)) @ llt_gidx in
    let llt_pte := (g_data (gnorm gn_llt)) @ idx in
    rely (g_tag (ginfo gn_llt) =? GRANULE_STATE_TABLE);
    rely (gtype gn_llt =? GRANULE_STATE_TABLE);
    rely is_int64 llt_pte;
    if (__entry_is_table llt_pte) && (rtt_addr =? (Z.land llt_pte ADDRESS_MASK)) then
      rely GRANULE_ALIGNED rtt_addr;
      let adt := adt {share: (share adt) {gs: (gs (share adt)) # llt_gidx == (gn_llt {glock: Some CPU_ID})}} in
      let gn_rtt := (gs (share adt)) @ rtt_gidx in
      rely prop_dec (glock gn_rtt = None);
      rely (g_tag (ginfo gn_rtt) =? GRANULE_STATE_TABLE);
      rely (tbl_level (gaux gn_llt) =? level - 1);
      rely (tbl_level (gaux gn_rtt) =? level);
      let e := EVT CPU_ID (ACQ rtt_gidx) in
      let e' := EVT CPU_ID (REL rtt_gidx (gn_rtt {glock: Some CPU_ID})) in
      rely prop_dec (forall i : ZIndexed.t, is_int64 (g_data (gnorm gn_rtt)) @ i = true);
      let ipa_gidx := __addr_to_gidx map_addr in
      let tlbs' := (fun ipa_state cpu gidx =>
                      if ipa_state =? IPA_STATE_PRESENT then
                        if (gidx >=? ipa_gidx) && (gidx <? ipa_gidx + 512) then -1
                        else tlbs (share adt) cpu gidx
                      else
                        if gidx =? ipa_gidx then -1
                        else tlbs (share adt) cpu gidx) in
      if (g_refcount (ginfo gn_rtt)) =? 1 then
        rely (g_refcount (ginfo gn_llt) >? 0);
        let ipa_state :=
            (if prop_dec (exists i : Z, 0 <= i < PGTES_PER_TABLE /\ PTE_TO_IPA_STATE (g_data (gnorm gn_rtt)) @ i = IPA_STATE_DESTROYED)
             then IPA_STATE_DESTROYED else IPA_STATE_VACANT)
        in
        let llt' := (g_data (gnorm gn_llt)) # idx == (IPA_STATE_TO_PTE ipa_state) in
        let gllt' := gn_llt {ginfo: (ginfo gn_llt) {g_refcount: (g_refcount (ginfo gn_llt)) - 1}}
                            {gnorm: (gnorm gn_llt) {g_data: llt'}} in
        let grtt' := gn_rtt {ginfo: (ginfo gn_rtt) {g_tag: GRANULE_STATE_DELEGATED} {g_rd: 0} {g_refcount: 0}}
                            {gnorm : zero_granule_data_normal} {grec: zero_granule_data_rec} in
        let e' := EVT CPU_ID (REL rtt_gidx (grtt' {glock: Some CPU_ID})) in
        Some (adt {log: EVT CPU_ID (REL llt_gidx gllt') :: e' :: e :: log adt}
                  {share : (share adt) {gs : ((gs (share adt)) # rtt_gidx == (grtt' {gtype: GRANULE_STATE_DELEGATED}))
                                                               # llt_gidx == (gllt' {glock: None})}
                                       {tlbs: tlbs' ipa_state}},
              VZ64 0)
      else
        if (g_refcount (ginfo gn_rtt)) =? PGTES_PER_TABLE + 1 then
          rely (level =? RTT_PAGE_LEVEL);
          let pgte := (g_data (gnorm gn_rtt)) @ 0 in
          let ipa_state := PTE_TO_IPA_STATE pgte in
          let base_pa' := __entry_to_phys pgte (level - 1) in
          let base_pa := __entry_to_phys pgte level in
          rely is_int64 base_pa;
          rely is_int64 (base_pa + PGTES_PER_TABLE * GRANULE_SIZE);
          rely (__addr_is_level_aligned base_pa (level - 1));
          rely prop_dec (forall i : Z, 0 <= i < PGTES_PER_TABLE ->
                                  let e := (g_data (gnorm gn_rtt)) @ i in
                                  let pa := __entry_to_phys e level in
                                  PTE_TO_IPA_STATE e = ipa_state /\ pa = base_pa + i * GRANULE_SIZE);
          let new_pgte := (if ipa_state =? IPA_STATE_PRESENT then Z.lor (Z.lor (IPA_STATE_TO_PTE ipa_state) base_pa') PGTE_S2_BLOCK
                           else Z.lor (IPA_STATE_TO_PTE ipa_state) base_pa') in
          let llt' := (g_data (gnorm gn_llt)) # idx == new_pgte in
          let gllt' := gn_llt {gnorm: (gnorm gn_llt) {g_data: llt'}} {glock: None} in
          let grtt' := gn_rtt {ginfo: (ginfo gn_rtt) {g_tag: GRANULE_STATE_DELEGATED} {g_rd: 0} {g_refcount: 0}}
                              {gnorm : zero_granule_data_normal} {grec: zero_granule_data_rec} in
          let e' := EVT CPU_ID (REL rtt_gidx (grtt' {glock: Some CPU_ID})) in
          Some (adt {log: EVT CPU_ID (REL llt_gidx gllt') :: e' :: e :: log adt}
                    {share : (share adt) {gs : ((gs (share adt)) # rtt_gidx == (grtt' {gtype: GRANULE_STATE_DELEGATED}))
                                                                # llt_gidx == gllt'}
                                        {tlbs: tlbs' ipa_state}},
                VZ64 0)
        else None
    else Some (adt {log: EVT CPU_ID (REL llt_gidx gn_llt {glock: Some CPU_ID}) :: log adt}, VZ64 1).

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

End Spec.


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

(** This file provide the contextual refinement proof between PQueueIntro layer and PQueueInit layer*)
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 LoadStoreSem2.
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 PThreadSched.
Require Import PThread.
Require Import ThreadGenSpec.

(** * 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 := pthread_data_ops) HDATA).
  Notation LDATAOps := (cdata (cdata_ops := pthreadsched_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);
          vmxinfo_re: vmxinfo hadt = vmxinfo 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
        }.

    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.
      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 thread_yield_exist:
          forall habd habd' labd rs r' rs0 f,
            ObjThread.thread_yield_spec
              habd (Pregmap.init Vundef)#ESP <- (rs#ESP)#EDI <- (rs#EDI)#ESI <- (rs#ESI)
              #EBX <- (rs#EBX)#EBP <- (rs#EBP)#RA <- (rs#RA) = Some (habd', rs0)
            -> relate_RData f habd labd
            -> high_level_invariant habd
            -> (forall reg : PregEq.t,
                  val_inject f (Pregmap.get reg rs) (Pregmap.get reg r'))
            -> exists labd' r'0, thread_yield_spec
                                   labd (Pregmap.init Vundef)#ESP <- (r'#ESP)#EDI <- (r'#EDI)#ESI <- (r'#ESI)
                                   #EBX <- (r'#EBX)#EBP <- (r'#EBP)#RA <- (r'#RA) = Some (labd', r'0)
                                 /\ relate_RData f habd' labd'
                                 /\ (forall i r,
                                       ZtoPreg i = Some r -> val_inject f (rs0#r) (r'0#r)).
        Proof.
          Opaque remove.
          unfold ObjThread.thread_yield_spec, thread_yield_spec; intros until f.
          intros HP HR HINV HVL; pose proof HR as HR'; inv HR; revert HP.
          specialize (valid_TDQ _ HINV).
          specialize (correct_curid _ HINV).
          simpl; subrewrite'; intros Hcid' Hlast HQ.
          destruct (pg labd); contra_inv.
          destruct (Hcid' refl_equal) as [_ Hcid].
          rewrite Hcid.
          assert (HOS: 0<= num_chan <= num_chan) by omega.
          specialize (Hlast refl_equal _ HOS).
          subdestruct; contra_inv; simpl.
          inv HQ. refine_split'; eauto 1.
          - inv HR'. econstructor; eauto 1.
            simpl; kctxt_inj_simpl.
          - unfold kctxt_inj, Pregmap.get in *.
            intros. eapply kctxt_re0; eauto.
            destruct Hlast as [l0[HT Hlast]]. inv HT.
            apply Hlast. apply last_correct; auto.
        Qed.

        Lemma thread_sleep_exist:
          forall habd habd' labd rs r' rs0 n f,
            ObjThread.thread_sleep_spec
              habd (Pregmap.init Vundef)#ESP <- (rs#ESP)#EDI <- (rs#EDI)#ESI <- (rs#ESI)
              #EBX <- (rs#EBX)#EBP <- (rs#EBP)#RA <- (rs#RA) n = Some (habd', rs0)
            -> relate_RData f habd labd
            -> high_level_invariant habd
            -> (forall reg : PregEq.t,
                  val_inject f (Pregmap.get reg rs) (Pregmap.get reg r'))
            -> exists labd' r'0, thread_sleep_spec
                                   labd (Pregmap.init Vundef)#ESP <- (r'#ESP)#EDI <- (r'#EDI)#ESI <- (r'#ESI)
                                   #EBX <- (r'#EBX)#EBP <- (r'#EBP)#RA <- (r'#RA) n = Some (labd', r'0)
                                 /\ relate_RData f habd' labd'
                                 /\ (forall i r,
                                       ZtoPreg i = Some r -> val_inject f (rs0#r) (r'0#r)).
        Proof.
          Opaque remove.
          unfold ObjThread.thread_sleep_spec, thread_sleep_spec; intros until f.
          intros HP HR HINV HVL; pose proof HR as HR'; inv HR; revert HP.
          specialize (valid_TDQ _ HINV); unfold AbQCorrect.
          specialize (correct_curid _ HINV).
          simpl; subrewrite'; intros Hcid' Hlast HQ.
          destruct (pg labd); contra_inv.
          destruct (Hcid' refl_equal) as [_ Hcid].
          rewrite Hcid.
          assert (HOS: 0<= num_chan <= num_chan) by omega.
          specialize (Hlast refl_equal _ HOS).
          subdestruct; simpl.
          inv HQ. refine_split'; eauto 1.
          - inv HR'.  econstructor; simpl; eauto 2.
            kctxt_inj_simpl.
          - unfold kctxt_inj, Pregmap.get in *.
            intros. eapply kctxt_re0; eauto.
            destruct Hlast as [l0'[HT Hlast]]. inv HT.
            apply Hlast. apply last_correct; auto.
        Qed.

      End Exists.

      Section FRESH_PRIM.

        Lemma thread_yield_spec_ref:
          compatsim (crel HDATA LDATA)
                    (primcall_thread_schedule_compatsem ObjThread.thread_yield_spec (prim_ident:= thread_yield))
                    thread_yield_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          inv match_extcall_states.
          exploit thread_yield_exist; eauto 1.
          intros [labd' [r'0[HP [HM HReg]]]].
          refine_split; try econstructor; eauto.
          eapply reg_symbol_inject; eassumption.
          econstructor; eauto. constructor.
          subst rs3.
          val_inject_simpl; eapply HReg;
          apply PregToZ_correct; reflexivity.
        Qed.

        Lemma thread_sleep_spec_ref:
          compatsim (crel HDATA LDATA)
                    (primcall_thread_transfer_compatsem ObjThread.thread_sleep_spec)
                    thread_sleep_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          inv match_extcall_states.
          exploit thread_sleep_exist; eauto 1.
          intros [labd' [r'0[HP [HM HReg]]]].
          refine_split; try econstructor; eauto.
          - eapply reg_symbol_inject; eassumption.
          - exploit (extcall_args_inject (D1:= HDATAOps) (D2:= LDATAOps)); eauto.
            instantiate (3:= d1').
            apply extcall_args_with_data; eauto.
            instantiate (1:= d2).
            intros [?[? Hinv]]. inv_val_inject.
            apply extcall_args_without_data in H; eauto.
          - econstructor; eauto. constructor.
          - subst rs3.
            val_inject_simpl;
              eapply HReg; apply PregToZ_correct; reflexivity.
        Qed.

      End FRESH_PRIM.

      Section PASSTHROUGH_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) pthread_passthrough pthreadsched.
        Proof.
          sim_oplus.
          - apply fload_sim.
          - apply fstore_sim.
          - apply flatmem_copy_sim.
          - apply vmxinfo_get_sim.
          - apply device_output_sim.
          - apply pfree_sim.
          - apply setPT_sim.
          - apply ptRead_sim.
          - apply ptResv_sim.
          - apply shared_mem_status_sim.
          - apply offer_shared_mem_sim.
          - apply get_state0_sim.
          - apply get_curid_sim.
          - apply thread_spawn_sim.
          - apply thread_wakeup_sim.
          - apply sched_init_sim.
          - apply ptin_sim.
          - apply ptout_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 trapin_sim.
          - apply trapout_sim.
          - apply hostin_sim.
          - apply hostout_sim.
          - apply trap_info_get_sim.
          - apply trap_info_ret_sim.
          - layer_sim_simpl.
            + eapply load_correct2.
            + eapply store_correct2.
        Qed.

      End PASSTHROUGH_PRIM.

    End OneStep_Forward_Relation.

  End WITHMEM.

End Refinement.


(* *********************************************************************)
(*                                                                     *)
(*            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.