Require Export MinBFTass_knew0.

Section MinBFTass_knew1.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc                 : DTimeContext        }.
  Context { minbft_context      : MinBFT_context      }.
  Context { m_initial_keys      : MinBFT_initial_keys }.
  Context { u_initial_keys      : USIG_initial_keys   }.
  Context { usig_hash           : USIG_hash           }.
  Context { minbft_auth         : MinBFT_auth         }.

  Lemma on_request_implies_generates :
    forall {eo : EventOrdering} (e : Event) r v m s1 u1 l1 s2 u2 l2,
      loc e = MinBFT_replica r
      -> usig_counter u2 = S (usig_counter u1)
      -> r = usig_id u1
      -> v = current_view s1
      -> trigger_op e = Some (MinBFT_request m)
      (*-> trigger_op e = Some msg
      -> msg2request msg = Some m*)
      -> M_run_ls_before_event (MinBFTlocalSys r) e = Some (MinBFTlocalSys_new r s1 u1 l1)
      -> M_run_ls_on_event (MinBFTlocalSys r) e = Some (MinBFTlocalSys_new r s2 u2 l2)
      -> disseminate_data
           e
           (minbft_data_rdata
              (request_data
                 v
                 m
                 (Build_UI
                    (MkPreUI (usig_id u1) (S (usig_counter u1)))
                    (create_hash_usig
                       (Build_HashData
                          v
                          m
                          (MkPreUI (usig_id u1) (S (usig_counter u1))))
                       (usig_local_keys u1))))).
  Proof.
    introv eqloc eqc eqr eqv eqtrig runBef runOn.

    unfold disseminate_data; simpl.
    applydup @M_run_ls_on_event_M_byz_run_ls_on_event in runOn as byzRunOn.
    applydup @M_run_ls_before_event_M_byz_run_ls_before_event in runBef as byzRunBef.
    unfold M_byz_output_sys_on_event; simpl.
    rewrite M_byz_output_ls_on_event_as_run; simpl.
    unfold M_byz_output_ls_on_this_one_event.
    apply (trigger_op_Some_implies_trigger_message e (MinBFT_request m)) in eqtrig.
    allrw; simpl.

    rewrite <- eqr.
    rewrite byzRunBef; simpl.

    clear byzRunOn byzRunBef.

    rewrite M_run_ls_on_event_unroll2 in runOn.
    rewrite runBef in runOn; simpl in *.
    apply map_option_Some in runOn; exrepnd; rev_Some; minbft_simp.
    unfold trigger_op in *.
    rewrite eqtrig in *; simpl in *; ginv.

    clear runBef.

    unfold M_byz_run_ls_on_one_event; simpl; allrw.
    unfold data_is_in_out, event2out; simpl; rewrite eqtrig; simpl.
    unfold M_run_ls_on_input_ls in *; simpl in *.

    remember (M_run_ls_on_input
                (MinBFTlocalSys_new (usig_id u1) s1 u1 l1)
                (msg_comp_name 0) (MinBFT_request m)) as run.
    symmetry in Heqrun; repnd; simpl in *.
    unfold M_run_ls_on_input in *; simpl in *.
    autorewrite with minbft in *; simpl in *.

    post_minbft_dest_msg;
      repeat (simpl in *; autorewrite with minbft in *; smash_minbft2; try omega);
      unfold lower_out_break in *; simpl in *; minbft_simp; try omega;
        eexists; dands; eauto; simpl; tcsp.
  Qed.
  Hint Resolve on_request_implies_generates : minbft.

End MinBFTass_knew1.

Hint Resolve on_request_implies_generates : minbft.


(** USeq.v *)
From Babel Require Import TerminalDogma
                          ExtraDogma.Extensionality
                          EpsilonDescription
                          SetFacility
                          POrderFacility.

From Babel Require Import Ranko
                            ExtensionalityCharacter
                            ClassicalCharacter.

From Babel.MetaLanguage Require Import Notations
                                        MetaType
                                        MetaLan.

From Coq Require Import Relations Classical.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** Do not import this module. *)
Module USeq.

(** Syntax *)

Record syn (syn0 syn1 : Type) := seq_ {
    S0 : syn0;
    S1 : syn1;
}.

Notation "s0 ⨾ s1" := {| S0 := s0; S1 := s1 |} : MetaLan_scope.

(** DeSem
    For now let's consider backward semantics.
*)

Definition de_fun (mT : Type) (de0 de1 : deSem mT): syn de0 de1 -> mT -> mT :=
    fun s P => ⟦ S0 s ⟧ <de0> (⟦ S1 s ⟧ <de1> P).

Definition deSem_mixin (mT : Type) (de0 de1 : deSem mT) :
    DeSem.mixin_of mT (syn de0 de1) :=
{|
	DeSem.de_fun := @de_fun mT de0 de1;
|}.

Canonical deSem (mT : Type) (de0 de1 : deSem mT) :=
    DeSem (syn de0 de1) (deSem_mixin de0 de1).

(** monotonicity *)

Lemma de_fun_monot_mixin (mT : poset) (de0 de1 : deSemM mT):
        DeSemM.mixin_of (deSem_mixin de0 de1).
Proof.
    constructor.
    porder_level.
    rewrite /de_fun.
    apply DeSemM.de_monot.
    by apply DeSemM.de_monot.
Qed.

Canonical de_fun_monot (mT : poset) (de0 de1 : deSemM mT) : deSemM mT :=
    DeSemM (syn de0 de1) (de_fun_monot_mixin de0 de1).

Lemma de_fun_conti_mixin (mT : cpo) (de0 de1 : deSemC mT) :
        DeSemC.mixin_of (DeSemM.class (de_fun_monot de0 de1)).
Proof.
    constructor.
    rewrite /ContinuousFun.mixin_of => s c //=.
    rewrite /de_fun //=.
    have t1 := (DeSemC.de_conti (S1 s)).
        rewrite /ContinuousFun.mixin_of in t1. simpl in t1. rewrite {}t1.
    have t0 := (DeSemC.de_conti (S0 s)).
        rewrite /ContinuousFun.mixin_of in t0. simpl in t0. rewrite {}t0.
    porder_level.
Qed.

Canonical de_fun_conti (mT : cpo) (de0 de1 : deSemC mT)
        : deSemC mT :=
    DeSemC (syn de0 de1) (de_fun_conti_mixin de0 de1).

(** AxSem *)

Inductive ax_sys (mT : dMT) (ax0 ax1 : axSem mT) :
    mT -> syn ax0 ax1 -> mT -> Prop :=

| RULE_SEQ
        (s0 : ax0) (s1 : ax1) (P R Q : mT)
        (H0 : ⊢ { P } s0 { R })
        (H1 : ⊢ { R } s1 { Q }): ax_sys P (s0 ⨾ s1)  Q.

Definition axSem_mixin (mT : dMT) (ax0 ax1 : axSem mT) :
        AxSem.mixin_of mT (syn ax0 ax1)
    := AxSem.Mixin (@ax_sys _ ax0 ax1).

Definition axSem (mT : dMT) (ax0 ax1 : axSem mT) :=
    AxSem (syn ax0 ax1) (axSem_mixin ax0 ax1).

(** VeriModS *)

Definition veriModS_mixin (mT : cpoDMT) (veriS0 veriS1 : veriModS mT):
    VeriModS.mixin_of (axSem veriS0 veriS1)
    (deSem (veriS0 : DeSem.Exports.deSem (mT : cpo)) veriS1).
Proof.
    constructor. rewrite /VeriModS.axiom => [] [] s0 s1 P Q.
    move => [] //=. intros. rewrite /de_fun.
    apply (soundness_of veriS1) in H1 => //=.
    apply (soundness_of veriS0) in H0 => //=.

    transitivity ((⟦ s2 ⟧ < DeSem veriS0 (VeriModS.base_de veriS0) >) R).
    - by [].
    - by apply (DeSemM.de_monot ).
Qed.

Definition veriModS (mT : cpoDMT) (veriS0 veriS1 : veriModS mT) :=
    VeriModS (syn veriS0 veriS1) (veriModS_mixin veriS0 veriS1).

(** VeriModC *)

Definition veriModC_mixin (mT : cpoDMT) (veriC0 veriC1 : veriModC mT):
    VeriModC.mixin_of (axSem veriC0 veriC1) (deSem veriC0 veriC1).
Proof.
    constructor. rewrite /VeriModC.axiom => [] [] s0 s1 P Q. simpl.
    rewrite /de_fun => //= H.
    eapply RULE_SEQ.
    instantiate (1 := (⟦ s1 ⟧ < VeriModC.base_de veriC1 >) Q).

    by apply (completeness_of _).
    apply (completeness_of _); by reflexivity.
Qed.

Definition veriModC (mT : cpoDMT) (veriC0 veriC1 : veriModC mT) :=
    VeriModC (syn veriC0 veriC1) (veriModC_mixin veriC0 veriC1).

(** VeriModSC *)

Definition veriModSC_mixin (mT : cpoDMT) (veri0 veri1 : veriModSC mT) :
    VeriModSC.mixin_of (veriModS veri0 veri1) (veriModC veri0 veri1).
Proof. constructor. Qed.

Definition veriModSC (mT : cpoDMT) (veri0 veri1 : veriModSC mT) :=
    VeriModSC (syn veri0 veri1) (veriModSC_mixin veri0 veri1).

End USeq.


(*********************************************************************************************************************************)
(* HaskCoreTypes: basically GHC's TypeRep.Type imported into Coqland                                                             *)
(*********************************************************************************************************************************)

Generalizable All Variables.
Require Import Preamble.
Require Import General.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import HaskKinds.
Require Import HaskCoreVars.
Require Import HaskLiterals.
Require Import HaskTyCons.

Variable CoreCoercionCoAxiom : Type.  Extract Inlined Constant CoreCoercionCoAxiom => "Coercion.CoAxiom".
Variable Int : Type.                  Extract Inlined Constant Int => "Prelude.Int".

Variable classTyCon          : Class_ -> CoreTyCon.       Extract Inlined Constant classTyCon            => "Class.classTyCon".
Variable coreTyConToString   : CoreTyCon   -> string.     Extract Inlined Constant coreTyConToString     => "outputableToString".
Variable coreDataConToString : CoreDataCon -> string.     Extract Inlined Constant coreDataConToString   => "outputableToString".

(* this exracts onto TypeRep.Type, on the nose *)
Inductive CoreType :=
| TyVarTy  : CoreVar                    -> CoreType
| AppTy    : CoreType  ->      CoreType -> CoreType   (* first arg must be AppTy or TyVarTy*)
| TyConApp : CoreTyCon -> list CoreType -> CoreType
| FunTy    : CoreType  ->      CoreType -> CoreType   (* technically redundant since we have FunTyCon *)
| ForAllTy : CoreVar   ->      CoreType -> CoreType
| PredTy   : PredType                   -> CoreType
with PredType :=
| ClassP   : Class_              -> list CoreType -> PredType
| IParam   : CoreIPName CoreName -> CoreType      -> PredType
| EqPred   : CoreType            -> CoreType      -> PredType.
Extract Inductive CoreType =>
   "TypeRep.Type" [ "TypeRep.TyVarTy" "TypeRep.AppTy" "TypeRep.TyConApp" "TypeRep.FunTy" "TypeRep.ForAllTy" "TypeRep.PredTy" ].
Extract Inductive PredType =>
   "TypeRep.PredType" [ "TypeRep.ClassP" "TypeRep.IParam" "TypeRep.EqPred" ].

Inductive CoreCoercion : Type :=
    CoreCoercionRefl        : CoreType                                 -> CoreCoercion
  | CoreCoercionTyConAppCo  : CoreTyCon    -> list CoreCoercion        -> CoreCoercion
  | CoreCoercionAppCo       : CoreCoercion -> CoreCoercion             -> CoreCoercion
  | CoreCoercionForAllCo    : CoreVar      -> CoreCoercion             -> CoreCoercion
  | CoreCoercionCoVarCo     : CoreVar                                  -> CoreCoercion
  | CoreCoercionAxiomInstCo : CoreCoercionCoAxiom -> list CoreCoercion -> CoreCoercion
  | CoreCoercionUnsafeCo    : CoreType -> CoreType                     -> CoreCoercion
  | CoreCoercionSymCo       : CoreCoercion                             -> CoreCoercion
  | CoreCoercionTransCo     : CoreCoercion -> CoreCoercion             -> CoreCoercion
  | CoreCoercionNthCo       : Int -> CoreCoercion                      -> CoreCoercion
  | CoreCoercionInstCo      : CoreCoercion -> CoreType                 -> CoreCoercion.

Extract Inductive CoreCoercion =>
  "Coercion.Coercion" [
  "Coercion.Refl"
  "Coercion.TyConAppCo"
  "Coercion.AppCo"
  "Coercion.ForAllCo"
  "Coercion.CoVarCo"
  "Coercion.AxiomInstCo"
  "Coercion.UnsafeCo"
  "Coercion.SymCo"
  "Coercion.TransCo"
  "Coercion.NthCo"
  "Coercion.InstCo" ].

Variable coreNameToString      : CoreName     -> string.    Extract Inlined Constant coreNameToString       => "outputableToString".
Variable coreCoercionToString  : CoreCoercion -> string.    Extract Inlined Constant coreCoercionToString   => "outputableToString".
Variable coreCoercionKind : Kind -> CoreType*CoreType.
  Extract Inlined Constant coreCoercionKind => "(Coercion.coercionKind . kindToCoreKind)".
Variable kindOfCoreType   : CoreType -> Kind.   Extract Inlined Constant kindOfCoreType   => "(coreKindToKind . Kind.typeKind)".
Variable coreTypeToString : CoreType -> string. Extract Inlined Constant coreTypeToString => "(outputableToString . coreViewDeep)".
Variable setVarType       : CoreVar -> CoreType -> CoreVar. Extract Inlined Constant setVarType       => "Var.setVarType".

(* GHC provides decision procedures for equality on its primitive types; we tell Coq to blindly trust them *)
Variable coreTyCon_eq         : EqDecider CoreTyCon.       Extract Inlined Constant coreTyCon_eq          => "(==)".
Variable tyCon_eq             : EqDecider TyCon.           Extract Inlined Constant tyCon_eq              => "(==)".
Variable tyFun_eq             : EqDecider TyFun.           Extract Inlined Constant tyFun_eq              => "(==)".
Variable dataCon_eq           : EqDecider CoreDataCon.     Extract Inlined Constant dataCon_eq            => "(==)".
Variable coreName_eq          : EqDecider CoreName.        Extract Inlined Constant coreName_eq           => "(==)".
Instance CoreTyConEqDecidable : EqDecidable CoreTyCon   := { eqd_dec := coreTyCon_eq }.
Instance TyConEqDecidable     : EqDecidable TyCon       := { eqd_dec := tyCon_eq }.
Instance TyFunEqDecidable     : EqDecidable TyFun       := { eqd_dec := tyFun_eq }.
Instance DataConEqDecidable   : EqDecidable CoreDataCon := { eqd_dec := dataCon_eq }.
Instance CoreNameEqDecidable  : EqDecidable CoreName    := { eqd_dec := coreName_eq }.
Instance CoreTypeToString     : ToString CoreType       := { toString := coreTypeToString }.
Instance CoreNameToString     : ToString CoreName       := { toString := coreNameToString }.
Instance CoreCoercionToString : ToString CoreCoercion   := { toString := coreCoercionToString }.
Instance CoreDataConToString  : ToString CoreDataCon    := { toString := coreDataConToString }.
Instance CoreTyConToString    : ToString CoreTyCon      := { toString := coreTyConToString }.


Require Import oeuf.Common oeuf.Monads.
Require Import oeuf.Metadata.
Require String.
Require oeuf.FlatReturn oeuf.FlatExpr.
Require Import oeuf.ListLemmas.
Require Import oeuf.HigherValue.

Require Import Psatz.

Module A := FlatReturn.
Module B := FlatExpr.

Add Printing Constructor A.frame.
Add Printing Constructor B.frame.

Definition compile : A.stmt -> B.stmt :=
    let fix go e :=
        let fix go_list (es : list A.stmt) : list B.stmt :=
            match es with
            | [] => []
            | e :: es => go e :: go_list es
            end in
        match e with
        | A.Skip => B.Skip
        | A.Seq s1 s2 => B.Seq (go s1) (go s2)
        | A.Arg dst => B.Assign dst B.Arg
        | A.Self dst => B.Assign dst B.Self
        | A.Deref dst e off => B.Assign dst (B.Deref (B.Var e) off)
        | A.Call dst f a => B.Call dst (B.Var f) (B.Var a)
        | A.MkConstr dst tag args => B.MkConstr dst tag (map B.Var args)
        | A.Switch dst cases => B.Switch dst (go_list cases)
        | A.MkClose dst fname free => B.MkClose dst fname (map B.Var free)
        | A.OpaqueOp dst op args => B.OpaqueOp dst op (map B.Var args)
        | A.Copy dst src => B.Assign dst (B.Var src)
        end in go.

Definition compile_list :=
    let go := compile in
    let fix go_list es :=
        match es with
        | [] => []
        | e :: es => go e :: go_list es
        end in go_list.

Ltac refold_compile :=
    fold compile_list in *.

Definition compile_func (f : A.stmt * nat) : B.stmt * nat :=
    let '(body, ret) := f in
    (compile body, ret).

Definition compile_cu (cu : list (A.stmt * nat) * list metadata) :
        list (B.stmt * nat) * list metadata :=
    let '(funcs, metas) := cu in
    (map compile_func funcs, metas).

Inductive I_stmt : A.stmt -> B.stmt -> Prop :=
| ISkip :
        I_stmt A.Skip B.Skip
| ISeq : forall as1 as2 bs1 bs2,
        I_stmt as1 bs1 ->
        I_stmt as2 bs2 ->
        I_stmt (A.Seq as1 as2) (B.Seq bs1 bs2)
| IArg : forall dst,
        I_stmt (A.Arg dst) (B.Assign dst B.Arg)
| ISelf : forall dst,
        I_stmt (A.Self dst) (B.Assign dst B.Self)
| IDeref : forall dst e off,
        I_stmt (A.Deref dst e off) (B.Assign dst (B.Deref (B.Var e) off))
| ICall : forall dst f a,
        I_stmt (A.Call dst f a) (B.Call dst (B.Var f) (B.Var a))
| IMkConstr : forall dst tag args,
        I_stmt (A.MkConstr dst tag args) (B.MkConstr dst tag (map B.Var args))
| ISwitch : forall dst acases bcases,
        Forall2 I_stmt acases bcases ->
        I_stmt (A.Switch dst acases) (B.Switch dst bcases)
| IMkClose : forall dst fname free,
        I_stmt (A.MkClose dst fname free) (B.MkClose dst fname (map B.Var free))
| IOpaqueOp : forall dst op args,
        I_stmt (A.OpaqueOp dst op args) (B.OpaqueOp dst op (map B.Var args))
| ICopy : forall dst src,
        I_stmt (A.Copy dst src) (B.Assign dst (B.Var src))
.
Hint Resolve ISkip.

Inductive I_func : (A.stmt * nat) -> (B.stmt * nat) -> Prop :=
| IFunc : forall ret acode bcode,
        I_stmt acode bcode ->
        I_func (acode, ret) (bcode, ret).

Inductive I_frame : A.frame -> B.frame -> Prop :=
| IFrame : forall arg self locals,
        I_frame (A.Frame arg self locals) (B.Frame arg self locals).
Hint Constructors I_frame.

Inductive I_cont : A.cont -> B.cont -> Prop :=
| IkSeq : forall acode ak bcode bk,
        I_stmt acode bcode ->
        I_cont ak bk ->
        I_cont (A.Kseq acode ak)
               (B.Kseq bcode bk)
| IkSwitch : forall ak bk,
        I_cont ak bk ->
        I_cont (A.Kswitch ak)
               (B.Kswitch bk)
| IkReturn : forall ret ak bk,
        I_cont ak bk ->
        I_cont (A.Kreturn ret ak)
               (B.Kreturn ret bk)
| IkCall : forall dst af ak bf bk,
        I_frame af bf ->
        I_cont ak bk ->
        I_cont (A.Kcall dst af ak)
               (B.Kcall dst bf bk)
| IkStop : forall ret,
        I_cont (A.Kstop ret)
               (B.Kstop ret).

Inductive I : A.state -> B.state -> Prop :=
| IRun : forall acode af ak  bcode bf bk,
        I_stmt acode bcode ->
        I_frame af bf ->
        I_cont ak bk ->
        I (A.Run acode af ak)
          (B.Run bcode bf bk)

| IReturn : forall v ak bk,
        I_cont ak bk ->
        I (A.Return v ak)
          (B.Return v bk)

| IStop : forall v,
        I (A.Stop v) (B.Stop v).

Lemma compile_I_stmt : forall a b,
    compile a = b ->
    I_stmt a b.
induction a using A.stmt_rect_mut with
    (Pl := fun a => forall b,
        compile_list a = b ->
        Forall2 I_stmt a b);
intros0 Hcomp; simpl in Hcomp; try rewrite <- Hcomp; refold_compile;
try solve [econstructor; eauto].
Qed.

Lemma compile_list_I_stmt : forall a b,
    compile_list a = b ->
    Forall2 I_stmt a b.
induction a;
intros0 Hcomp; simpl in Hcomp; try rewrite <- Hcomp; refold_compile;
try solve [econstructor; eauto using compile_I_stmt].
Qed.

Lemma compile_I_func : forall a b,
    compile_func a = b ->
    I_func a b.
intros0 Hcomp. destruct a.
unfold compile_func in Hcomp. rewrite <- Hcomp.
econstructor. eauto using compile_I_stmt.
Qed.

Theorem compile_cu_I_env : forall a ameta b bmeta,
    compile_cu (a, ameta) = (b, bmeta) ->
    Forall2 I_func a b.
intros0 Hcomp. unfold compile_cu in *. inject_pair.
remember (map compile_func a) as b.
symmetry in Heqb. apply map_Forall2 in Heqb.
list_magic_on (a, (b, tt)). eauto using compile_I_func.
Qed.

Ltac i_ctor := intros; econstructor; simpl; eauto.
Ltac i_lem H := intros; eapply H; simpl; eauto.

Ltac stk_simpl := compute [
    A.set  A.arg A.self A.locals
    B.set  B.arg B.self B.locals
    ] in *.

Lemma set_I_frame : forall af bf dst v,
    I_frame af bf ->
    I_frame (A.set af dst v) (B.set bf dst v).
intros0 II. invc II.
stk_simpl. constructor.
Qed.
Hint Resolve set_I_frame.

Hint Constructors B.eval.

Theorem I_sim : forall AE BE a a' b,
    Forall2 I_func AE BE ->
    I a b ->
    A.sstep AE a a' ->
    exists b',
        B.sstep BE b b' /\
        I a' b'.
destruct a as [ae af ak | val ak | ae];
intros0 Henv II Astep; [ | | solve [invc Astep] ];
inv Astep; inv II;
try on >I_stmt, invc;
try on >I_frame, invc;
simpl in *.

- (* Seq *)
  eexists. split. eapply B.SSeq; eauto.
  i_ctor. i_ctor.

- (* Arg *)
  eexists. split. eapply B.SAssign; eauto.
  i_ctor.

- (* Self *)
  eexists. split. eapply B.SAssign; eauto.
  i_ctor.

- (* DerefinateConstr *)
  eexists. split. eapply B.SAssign; eauto.
  i_ctor.

- (* DerefinateClose *)
  eexists. split. eapply B.SAssign; eauto.
  i_ctor.

- (* MkConstr *)
  eexists. split. eapply B.SConstrDone; eauto.
    { instantiate (1 := vs). rewrite <- Forall2_map_l. list_magic_on (args, (vs, tt)). }
  i_ctor.

- (* MkClose *)
  eexists. split. eapply B.SCloseDone; eauto.
    { instantiate (1 := vs). rewrite <- Forall2_map_l. list_magic_on (free, (vs, tt)). }
  i_ctor.

- (* MkClose *)
  eexists. split. eapply B.SOpaqueOpDone; eauto.
    { rewrite <- Forall2_map_l. list_magic_on (args, (vs, tt)). }
  i_ctor.

- (* MakeCall *)
  fwd eapply Forall2_nth_error_ex with (xs := AE) as HH; eauto.
    destruct HH as ([bbody bret] & ? & ?).
  on >I_func, invc.

  eexists. split. eapply B.SMakeCall; eauto.
  i_ctor. i_ctor. i_ctor.

- (* Switchinate *)
  fwd eapply Forall2_nth_error_ex with (xs := cases) as HH; eauto.  destruct HH as (bcase & ? & ?).

  eexists. split. eapply B.SSwitchinate; eauto.
  i_ctor. i_ctor.

- (* Copy *)
  eexists. split. eapply B.SAssign; eauto.
  i_ctor.

- (* ContSeq *)
  on >I_cont, inv.

  eexists. split. eapply B.SContSeq; eauto.
  i_ctor.

- (* ContSwitch *)
  on >I_cont, inv.

  eexists. split. eapply B.SContSwitch; eauto.
  i_ctor.

- (* ContReturn *)
  on >I_cont, inv.

  eexists. split. eapply B.SContReturn; eauto.
  i_ctor.

- (* ContStop *)
  on >I_cont, inv.

  eexists. split. eapply B.SContStop; eauto.
  i_ctor.

- (* ContCall *)
  on >I_cont, inv.

  eexists. split. eapply B.SContCall; eauto.
  i_ctor.
Qed.

Lemma compile_cu_metas : forall A Ameta B Bmeta,
    compile_cu (A, Ameta) = (B, Bmeta) ->
    Ameta = Bmeta.
simpl. inversion 1. auto.
Qed.

Require oeuf.Semantics.

Section Preservation.

  Variable prog : A.prog_type.
  Variable tprog : B.prog_type.

  Hypothesis TRANSF : compile_cu prog = tprog.

  Theorem fsim :
    Semantics.forward_simulation (A.semantics prog) (B.semantics tprog).
  Proof.
    destruct prog as [A Ameta], tprog as [B Bmeta].
    fwd eapply compile_cu_I_env; eauto.
    fwd eapply compile_cu_metas; eauto.

    eapply Semantics.forward_simulation_step with
        (match_states := I)
        (match_values := @eq value).

    - simpl. intros. on >B.is_callstate, invc. simpl in *.
      destruct ltac:(i_lem Forall2_nth_error_ex') as ([abody aret] & ? & ?).
      on >I_func, invc.

      (* use `solve` to force econstructor to make the right choices *)
      eexists. split; solve [repeat i_ctor].

    - intros0 II Afinal. invc Afinal. invc II.
      eexists; split; i_ctor.

    - simpl. eauto.
    - simpl. intros. tauto.

    - intros0 Astep. intros0 II.
      eapply I_sim; try eassumption.

  Qed.

End Preservation.


Require Import GHC.Num.

(* Characters *)

Require Import NArith.
Definition Char := N.
Bind Scope char_scope   with N.

(* Notation for literal characters in Coq source. *)
Require Import Coq.Strings.Ascii.
Definition hs_char__ : Ascii.ascii -> Char := N_of_ascii.
Notation "'&#' c" := (hs_char__ c) (at level 1, format "'&#' c").

Definition chr : Int -> Char := Z.to_N.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Compile-time evaluation of initializers for global C variables. *)

Require Import Coqlib.
Require Import Errors.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import AST.
Require Import Memory.
Require Import Ctypes.
Require Import Cop.
Require Import Csyntax.

Open Scope error_monad_scope.

Section WITHMEM.
Context `{Hsc: SyntaxConfiguration}.
Context `{Hmem: Mem.MemoryModel}.

(** * Evaluation of compile-time constant expressions *)

(** To evaluate constant expressions at compile-time, we use the same [value]
  type and the same [sem_*] functions that are used in CompCert C's semantics
  (module [Csem]).  However, we interpret pointer values symbolically:
  [Vptr (Zpos id) ofs] represents the address of global variable [id]
  plus byte offset [ofs]. *)

(** [constval a] evaluates the constant expression [a].

If [a] is a r-value, the returned value denotes:
- [Vint n], [Vfloat f]: the corresponding number
- [Vptr id ofs]: address of global variable [id] plus byte offset [ofs]
- [Vundef]: erroneous expression

If [a] is a l-value, the returned value denotes:
- [Vptr id ofs]: global variable [id] plus byte offset [ofs]
*)

Definition do_cast (v: val) (t1 t2: type) : res val :=
  match sem_cast v t1 t2 with
  | Some v' => OK v'
  | None => Error(msg "undefined cast")
  end.

Fixpoint constval `{mem_ops: Mem.MemoryOps mem} (a: expr) : res val :=
  match a with
  | Eval v ty =>
      match v with
      | Vint _ | Vfloat _ => OK v
      | Vptr _ _ | Vundef => Error(msg "illegal constant")
      end
  | Evalof l ty =>
      match access_mode ty with
      | By_reference | By_copy => constval l
      | _ => Error(msg "dereferencing of an l-value")
      end
  | Eaddrof l ty =>
      constval l
  | Eunop op r1 ty =>
      do v1 <- constval r1;
      match sem_unary_operation op v1 (typeof r1) with
      | Some v => OK v
      | None => Error(msg "undefined unary operation")
      end
  | Ebinop op r1 r2 ty =>
      do v1 <- constval r1;
      do v2 <- constval r2;
      match sem_binary_operation op v1 (typeof r1) v2 (typeof r2) Mem.empty with
      | Some v => OK v
      | None => Error(msg "undefined binary operation")
      end
  | Ecast r ty =>
      do v1 <- constval r; do_cast v1 (typeof r) ty
  | Esizeof ty1 ty =>
      OK (Vint (Int.repr (sizeof ty1)))
  | Ealignof ty1 ty =>
      OK (Vint (Int.repr (alignof ty1)))
  | Eseqand r1 r2 ty =>
      do v1 <- constval r1;
      do v2 <- constval r2;
      match bool_val v1 (typeof r1) with
      | Some true => do v3 <- do_cast v2 (typeof r2) type_bool; do_cast v3 type_bool ty
      | Some false => OK (Vint Int.zero)
      | None => Error(msg "undefined && operation")
      end
  | Eseqor r1 r2 ty =>
      do v1 <- constval r1;
      do v2 <- constval r2;
      match bool_val v1 (typeof r1) with
      | Some false => do v3 <- do_cast v2 (typeof r2) type_bool; do_cast v3 type_bool ty
      | Some true => OK (Vint Int.one)
      | None => Error(msg "undefined || operation")
      end
  | Econdition r1 r2 r3 ty =>
      do v1 <- constval r1;
      do v2 <- constval r2;
      do v3 <- constval r3;
      match bool_val v1 (typeof r1) with
      | Some true => do_cast v2 (typeof r2) ty
      | Some false => do_cast v3 (typeof r3) ty
      | None => Error(msg "condition is undefined")
      end
  | Ecomma r1 r2 ty =>
      do v1 <- constval r1; constval r2
  | Evar x ty =>
      OK(Vptr (Zpos x) Int.zero)
  | Ederef r ty =>
      constval r
  | Efield l f ty =>
      match typeof l with
      | Tstruct id fList _ =>
          do delta <- field_offset f fList;
          do v <- constval l;
          OK (Val.add v (Vint (Int.repr delta)))
      | Tunion id fList _ =>
          constval l
      | _ =>
          Error(msg "ill-typed field access")
      end
  | Eparen r ty =>
      do v <- constval r; do_cast v (typeof r) ty
  | _ =>
    Error(msg "not a compile-time constant")
  end.

(** * Translation of initializers *)

Inductive initializer :=
  | Init_single (a: expr)
  | Init_compound (il: initializer_list)
with initializer_list :=
  | Init_nil
  | Init_cons (i: initializer) (il: initializer_list).

(** Translate an initializing expression [a] for a scalar variable
  of type [ty].  Return the corresponding initialization datum. *)

Definition transl_init_single (ty: type) (a: expr) : res init_data :=
  do v1 <- constval a;
  do v2 <- do_cast v1 (typeof a) ty;
  match v2, ty with
  | Vint n, Tint I8 sg _ => OK(Init_int8 n)
  | Vint n, Tint I16 sg _ => OK(Init_int16 n)
  | Vint n, Tint I32 sg _ => OK(Init_int32 n)
  | Vint n, Tpointer _ _ => OK(Init_int32 n)
  | Vfloat f, Tfloat F32 _ => OK(Init_float32 f)
  | Vfloat f, Tfloat F64 _ => OK(Init_float64 f)
  | Vptr (Zpos id) ofs, Tint I32 sg _ => OK(Init_addrof id ofs)
  | Vptr (Zpos id) ofs, Tpointer _ _ => OK(Init_addrof id ofs)
  | Vundef, _ => Error(msg "undefined operation in initializer")
  | _, _ => Error (msg "type mismatch in initializer")
  end.

(** Translate an initializer [i] for a variable of type [ty].
  Return the corresponding list of initialization data. *)

Definition padding (frm to: Z) : list init_data :=
  let n := to - frm in
  if zle n 0 then nil else Init_space n :: nil.

End WITHMEM.

Fixpoint transl_init `{mem_ops: Mem.MemoryOps}
                     (ty: type) (i: initializer)
                     {struct i} : res (list init_data) :=
  match i, ty with
  | Init_single a, _ =>
      do d <- transl_init_single ty a; OK (d :: nil)
  | Init_compound il, Tarray tyelt sz _ =>
      if zle sz 0
      then OK (Init_space(sizeof tyelt) :: nil)
      else transl_init_array tyelt il sz
  | Init_compound il, Tstruct _ Fnil _ =>
      OK (Init_space (sizeof ty) :: nil)
  | Init_compound il, Tstruct id fl _ =>
      transl_init_struct id ty fl il 0
  | Init_compound il, Tunion _ Fnil _ =>
      OK (Init_space (sizeof ty) :: nil)
  | Init_compound il, Tunion id (Fcons _ ty1 _) _ =>
      transl_init_union id ty ty1 il
  | _, _ =>
      Error (msg "wrong type for compound initializer")
  end

with transl_init_array `{mem_ops: Mem.MemoryOps}
                       (ty: type) (il: initializer_list) (sz: Z)
                       {struct il} : res (list init_data) :=
  match il with
  | Init_nil =>
      if zeq sz 0
      then OK nil
      else Error (msg "wrong number of elements in array initializer")
  | Init_cons i1 il' =>
      do d1 <- transl_init ty i1;
      do d2 <- transl_init_array ty il' (sz - 1);
      OK (d1 ++ d2)
  end

with transl_init_struct `{mem_ops: Mem.MemoryOps}
                        (id: ident) (ty: type)
                        (fl: fieldlist) (il: initializer_list) (pos: Z)
                        {struct il} : res (list init_data) :=
  match il, fl with
  | Init_nil, Fnil =>
      OK (padding pos (sizeof ty))
  | Init_cons i1 il', Fcons _ ty1 fl' =>
      let pos1 := align pos (alignof ty1) in
      do d1 <- transl_init (unroll_composite id ty ty1) i1;
      do d2 <- transl_init_struct id ty fl' il' (pos1 + sizeof ty1);
      OK (padding pos pos1 ++ d1 ++ d2)
  | _, _ =>
      Error (msg "wrong number of elements in struct initializer")
  end

with transl_init_union `{mem_ops: Mem.MemoryOps}
                       (id: ident) (ty ty1: type) (il: initializer_list)
                       {struct il} : res (list init_data) :=
  match il with
  | Init_nil =>
      Error (msg "empty union initializer")
  | Init_cons i1 _ =>
      do d <- transl_init (unroll_composite id ty ty1) i1;
      OK (d ++ padding (sizeof ty1) (sizeof ty))
  end.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List. Import ListNotations.
Require Import coqutil.Word.Interface.
Require Import coqutil.Map.Interface.
Require Import coqutil.Map.Z_keyed_SortedListMap.
Require Import coqutil.Byte.
Require Import bedrock2.Syntax.
Require Import bedrock2.Semantics.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Scalars.
Require Import bedrock2.WeakestPreconditionProperties.
Require Import compiler.Pipeline.
Require Import compiler.RiscvWordProperties.
Require Import Bedrock2Experiments.List.
Require Import Bedrock2Experiments.LibBase.AbsMMIO.
Require Import Bedrock2Experiments.LibBase.AbsMMIOPropertiesUnique.
Require Import Bedrock2Experiments.LibBase.Bitfield.
Require Import Bedrock2Experiments.LibBase.BitfieldProperties.
Require Import HmacSoftware.Hmac.
Require Import HmacSoftware.HmacSemantics.
Require Import HmacSoftware.HmacProperties.
Require Import HmacSoftware.Sha256Example.
Require Import HmacSoftware.Sha256ExampleProperties.
Require Import Bedrock2Experiments.StateMachineSemantics.
Require Import Bedrock2Experiments.StateMachineMMIO.

Require coqutil.Word.Naive.
Require coqutil.Map.SortedListWord.
Require riscv.Utility.InstructionNotations.
Import Syntax.Coercions.
Local Open Scope string_scope.

Instance word: word.word 32 := Naive.word 32.
Instance mem: map.map word Byte.byte := SortedListWord.map _ _.
Existing Instance SortedListString.map.
Existing Instance SortedListString.ok.

(* TODO: we actually need a different word implementation than Naive here; in
   corner cases such as a shift argument greater than the width of the word,
   the naive implementation violates the riscv_ok requirements *)
Instance naive_riscv_ok : word.riscv_ok word. Admitted.

(* TODO match to actual Cava implementation *)
Instance hmac_timing: timing := {
  max_negative_done_polls := 16;
}.

Notation bytearray := (bedrock2.Array.array (mem := mem) ptsto (word.of_Z 1)).

(* Plug in the right state machine parameters; typeclass inference struggles here *)
Local Notation execution := (execution (M:=hmac_state_machine)).

Definition funcs := [
  b2_sha256;
  b2_hmac_sha256_init; b2_hmac_sha256_update; b2_hmac_sha256_final;
  abs_mmio_write32; abs_mmio_read32; abs_mmio_write8; abs_mmio_read8;
  bitfield_bit32_write; bitfield_bit32_read;
  bitfield_field32_write; bitfield_field32_read
].

Lemma link_sha256: spec_of_sha256 funcs.
Proof.
  (* TODO speedup, don't reprove the same specs many times *)
  repeat first
         [ eapply sha256_correct
         | eapply hmac_sha256_init_correct
         | eapply hmac_sha256_update_correct
         | eapply hmac_sha256_final_correct
         | eapply abs_mmio_write32_correct
         | eapply abs_mmio_read32_correct
         | eapply abs_mmio_write8_correct
         | eapply abs_mmio_read8_correct
         | eapply bitfield_bit32_write_correct
         | eapply bitfield_field32_write_correct
         | eapply bitfield_bit32_read_correct
         | eapply bitfield_field32_read_correct
         | eapply HmacProperties.execution_unique
         | idtac ].
Qed.

Lemma funcs_valid: ExprImp.valid_funs (map.of_list funcs).
Proof.
  cbv [funcs map.of_list ExprImp.valid_funs]. intros *.
  repeat match goal with
         | |- context[match ?p with _ => _ end] => cbv [p]
         end.
  rewrite !map.get_put_dec, map.get_empty.
  repeat destruct_one_match; inversion 1; cbv [ExprImp.valid_fun].
  all:ssplit.
  all:apply dedup_NoDup_iff.
  all:reflexivity.
Qed.

Definition sha256_compile_result:
  list Decode.Instruction * (SortedListString.map (nat * nat * Z)) * Z.
  let r := eval vm_compute in (compile compile_ext_call (map.of_list funcs)) in
   match r with
  | Some ?x => exact x
  end.
Defined.

Definition sha256_asm := Eval compute in fst (fst sha256_compile_result).
Definition sha256_finfo := Eval compute in snd (fst sha256_compile_result).
Definition sha256_req_stack := Eval compute in snd sha256_compile_result.

Lemma sha256_compile_result_eq:
  compile compile_ext_call (map.of_list funcs) =
  Some (sha256_asm, sha256_finfo, sha256_req_stack).
Proof. reflexivity. Qed.

Module PrintAssembly.
  Import riscv.Utility.InstructionNotations.
  Goal False.
    let r := eval unfold sha256_asm in sha256_asm in idtac (*r*).
  Abort.
End PrintAssembly.

Definition sha256_relative_pos :=
  match map.get sha256_finfo (fst b2_sha256) with
  | Some (_, _, p) => p
  | None => -1111
  end.

Lemma sha256_asm_valid_instructions:
  Forall (fun instr => Encode.verify instr Decode.RV32IM) sha256_asm.
Proof.
  repeat (apply Forall_cons || apply Forall_nil).
  all: try (vm_compute; intuition discriminate).
Qed.


Require Import Coqlib.
Require Import ITreelib.
Require Import ImpPrelude.
Require Import STS.
Require Import Behavior.
Require Import ModSem.
Require Import Skeleton.
Require Import PCM.
Require Import HoareDef.
Require Import IntroHeader.
Import Plain.

Set Implicit Arguments.

Section PROOF.

  Context `{Σ: GRA.t}.
  Context `{@GRA.inG IRA.t Σ}.

  Definition Gsbtb: list (string * fspecbody) := [("g", mk_specbody g_spec (fun _ => trigger (Choose _)))].

  Definition GSem: SModSem.t := {|
    SModSem.fnsems := Gsbtb;
    SModSem.mn := "G";
    SModSem.initial_mr := GRA.embed (IRA.module true: IRA.t);
    SModSem.initial_st := tt↑;
  |}
  .

  Definition G: Mod.t := (SMod.to_tgt (fun _ => GlobalStb)) {|
    SMod.get_modsem := fun _ => GSem;
    SMod.sk := [("g", Sk.Gfun)];
  |}.

End PROOF.


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

(** This file provide the contextual refinement proof between PIPC layer and PUCtxtIntro layer*)

Require Import UCtxtIntroGenDef.
Require Import UCtxtIntroGenSpec.

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

  Ltac pattern2_refinement_simpl:=
    pattern2_refinement_simpl' (@relate_AbData).

  Section WITHMEM.

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

    Lemma save_uctx_spec_ref:
      compatsim (crel HDATA LDATA) (save_uctx_compatsem save_uctx_spec)
                save_uctx_spec_low.
    Proof.
      compatsim_simpl (@match_AbData).
      assert(HOS: kernel_mode d2 /\ 0 <= cid d2 < num_proc
                  /\ cid d1' = cid d2
                  /\ uctxt d1' = ZMap.set (cid d1') uctx4 (uctxt d1)
                  /\ pg d2 = true).
      {
        simpl; inv match_related.
        functional inversion H6; subst; simpl. inv Hhigh.
        refine_split'; trivial; try congruence.
      }
      destruct HOS as [Hkern [HOS[Hcid [Heq Hpe]]]].
      inv H. rename H0 into HMem.
      set (vcid := cid d2) in *.
      assert (HV0: forall n0, 0<= n0 < UCTXT_SIZE ->
                              Mem.valid_access m2 Mint32 b (UCTXT_SIZE * 4 * vcid + 4 * n0) Writable).
      {
        intros n0 HR. specialize (HMem _ _ HOS HR).
        destruct HMem as [_[_[HV _]]].
        replace (17 * 4 * vcid + 4 * n0) with (vcid * 17 * 4 + n0 * 4) by omega. trivial.
      }
      assert (HP: exists m0, Mem.store Mint32 m2 b (UCTXT_SIZE * 4 * vcid + 4 * U_EDI) (Vint v0) = Some m0).
      {
        apply (Mem.valid_access_store); auto.
        apply HV0. omega.
      }
      destruct HP as [m0 HST0].
      assert (HV1: forall n0, 0<= n0 < UCTXT_SIZE -> Mem.valid_access m0 Mint32 b (UCTXT_SIZE * 4 * vcid + 4 * n0) Writable).
      {
        intros. eapply Mem.store_valid_access_1; eauto.
      }
      clear HV0.
      assert (HP: exists m1, Mem.store Mint32 m0 b (UCTXT_SIZE * 4 * vcid + 4 * U_ESI) (Vint v1) = Some m1).
      {
        apply (Mem.valid_access_store); auto.
        apply HV1. omega.
      }
      destruct HP as [m1 HST1].
      assert (HV2: forall n0, 0<= n0 < UCTXT_SIZE -> Mem.valid_access m1 Mint32 b (UCTXT_SIZE * 4 * vcid + 4 * n0) Writable).
      {
        intros; eapply Mem.store_valid_access_1; eauto.
      }
      clear HV1.
      assert (HP: exists m2, Mem.store Mint32 m1 b (UCTXT_SIZE * 4 * vcid + 4 * U_EBP) (Vint v2) = Some m2).
      {
        apply (Mem.valid_access_store); auto.
        apply HV2. omega.
      }
      destruct HP as [m2' HST2].
      assert (HV3: forall n0, 0<= n0 < UCTXT_SIZE -> Mem.valid_access m2' Mint32 b (UCTXT_SIZE * 4 * vcid + 4 * n0) Writable).
      {
        intros; eapply Mem.store_valid_access_1; eauto.
      }
      clear HV2.
      assert (HP: exists m3, Mem.store Mint32 m2' b (UCTXT_SIZE * 4 * vcid + 4 * U_OESP) (Vint v3) = Some m3).
      {
        apply (Mem.valid_access_store); auto.
        apply HV3. omega.
      }
      destruct HP as [m3 HST3].
      assert (HV4: forall n0, 0<= n0 < UCTXT_SIZE ->  Mem.valid_access m3 Mint32 b (UCTXT_SIZE * 4 * vcid + 4 * n0) Writable).
      {
        intros; eapply Mem.store_valid_access_1; eauto.
      }
      clear HV3.
      assert (HP: exists m4, Mem.store Mint32 m3 b (UCTXT_SIZE * 4 * vcid + 4 * U_EBX) (Vint v4) = Some m4).
      {
        apply (Mem.valid_access_store); auto.
        apply HV4. omega.
      }
      destruct HP as [m4 HST4].
      assert (HV5: forall n0, 0<= n0 < UCTXT_SIZE -> Mem.valid_access m4 Mint32 b (UCTXT_SIZE * 4 * vcid + 4 * n0) Writable).
      {
        intros; eapply Mem.store_valid_access_1; eauto.
      }
      clear HV4.
      assert (HP: exists m5, Mem.store Mint32 m4 b (UCTXT_SIZE * 4 * vcid + 4 * U_EDX) (Vint v5) = Some m5).
      {
        apply (Mem.valid_access_store); auto.
        apply HV5. omega.
      }
      destruct HP as [m5 HST5].
      assert (HV6: forall n0, 0<= n0 < UCTXT_SIZE -> Mem.valid_access m5 Mint32 b (UCTXT_SIZE * 4 * vcid + 4 * n0) Writable).
      {
        intros; eapply Mem.store_valid_access_1; eauto.
      }
      clear HV5.
      assert (HP: exists m6, Mem.store Mint32 m5 b (UCTXT_SIZE * 4 * vcid + 4 * U_ECX) (Vint v6) = Some m6).
      {
        apply (Mem.valid_access_store); auto.
        apply HV6. omega.
      }
      destruct HP as [m6 HST6].
      assert (HV7: forall n0, 0<= n0 < UCTXT_SIZE ->  Mem.valid_access m6 Mint32 b (UCTXT_SIZE * 4 * vcid + 4 * n0) Writable).
      {
        intros; eapply Mem.store_valid_access_1; eauto.
      }
      clear HV6.
      assert (HP: exists m7, Mem.store Mint32 m6 b (UCTXT_SIZE * 4 * vcid + 4 * U_EAX) (Vint v7) = Some m7).
      {
        apply (Mem.valid_access_store); auto.
        apply HV7. omega.
      }
      destruct HP as [m7 HST7].
      assert (HV8: forall n0, 0<= n0 < UCTXT_SIZE ->  Mem.valid_access m7 Mint32 b (UCTXT_SIZE * 4 * vcid + 4 * n0) Writable).
      {
        intros; eapply Mem.store_valid_access_1; eauto.
      }
      clear HV7.
      assert (HP: exists m8, Mem.store Mint32 m7 b (UCTXT_SIZE * 4 * vcid + 4 * U_ES) (Vint v8) = Some m8).
      {
        apply (Mem.valid_access_store); auto.
        apply HV8. omega.
      }
      destruct HP as [m8 HST8].
      assert (HV9: forall n0, 0<= n0 < UCTXT_SIZE -> Mem.valid_access m8 Mint32 b (UCTXT_SIZE * 4 * vcid + 4 * n0) Writable).
      {
        intros; eapply Mem.store_valid_access_1; eauto.
      }
      clear HV8.
      assert (HP: exists m9, Mem.store Mint32 m8 b (UCTXT_SIZE * 4 * vcid + 4 * U_DS) (Vint v9) = Some m9).
      {
        apply (Mem.valid_access_store); auto.
        apply HV9. omega.
      }
      destruct HP as [m9 HST9].
      assert (HV10: forall n0, 0<= n0 < UCTXT_SIZE -> Mem.valid_access m9 Mint32 b (UCTXT_SIZE * 4 * vcid + 4 * n0) Writable).
      {
        intros; eapply Mem.store_valid_access_1; eauto.
      }
      clear HV9.
      assert (HP: exists m10, Mem.store Mint32 m9 b (UCTXT_SIZE * 4 * vcid + 4 * U_TRAPNO) (Vint v10) = Some m10).
      {
        apply (Mem.valid_access_store); auto.
        apply HV10. omega.
      }
      destruct HP as [m10 HST10].
      assert (HV11: forall n0, 0<= n0 < UCTXT_SIZE -> Mem.valid_access m10 Mint32 b (UCTXT_SIZE * 4 * vcid + 4 * n0) Writable).
      {
        intros; eapply Mem.store_valid_access_1; eauto.
      }
      clear HV10.
      assert (HP: exists m11, Mem.store Mint32 m10 b (UCTXT_SIZE * 4 * vcid + 4 * U_ERR) (Vint v11) = Some m11).
      {
        apply (Mem.valid_access_store); auto.
        apply HV11. omega.
      }
      destruct HP as [m11 HST11].
      assert (HV12: forall n0, 0<= n0 < UCTXT_SIZE -> Mem.valid_access m11 Mint32 b (UCTXT_SIZE * 4 * vcid + 4 * n0) Writable).
      {
        intros; eapply Mem.store_valid_access_1; eauto.
      }
      clear HV11.
      assert (HP: exists m12, Mem.store Mint32 m11 b (UCTXT_SIZE * 4 * vcid + 4 * U_EIP) (Vint v12) = Some m12).
      {
        apply (Mem.valid_access_store); auto.
        apply HV12. omega.
      }
      destruct HP as [m12 HST12].
      assert (HV13: forall n0, 0<= n0 < UCTXT_SIZE -> Mem.valid_access m12 Mint32 b (UCTXT_SIZE * 4 * vcid + 4 * n0) Writable).
      {
        intros; eapply Mem.store_valid_access_1; eauto.
      }
      clear HV12.
      assert (HP: exists m13, Mem.store Mint32 m12 b (UCTXT_SIZE * 4 * vcid + 4 * U_CS) (Vint v13) = Some m13).
      {
        apply (Mem.valid_access_store); auto.
        apply HV13. omega.
      }
      destruct HP as [m13 HST13].
      assert (HV14: forall n0, 0<= n0 < UCTXT_SIZE -> Mem.valid_access m13 Mint32 b (UCTXT_SIZE * 4 * vcid + 4 * n0) Writable).
      {
        intros; eapply Mem.store_valid_access_1; eauto.
      }
      clear HV13.
      assert (HP: exists m14, Mem.store Mint32 m13 b (UCTXT_SIZE * 4 * vcid + 4 * U_EFLAGS) (Vint v14) = Some m14).
      {
        apply (Mem.valid_access_store); auto.
        apply HV14. omega.
      }
      destruct HP as [m14 HST14].
      assert (HV15: forall n0, 0<= n0 < UCTXT_SIZE -> Mem.valid_access m14 Mint32 b (UCTXT_SIZE * 4 * vcid + 4 * n0) Writable).
      {
        intros; eapply Mem.store_valid_access_1; eauto.
      }
      clear HV14.
      assert (HP: exists m15, Mem.store Mint32 m14 b (UCTXT_SIZE * 4 * vcid + 4 * U_ESP) (Vint v15) = Some m15).
      {
        apply (Mem.valid_access_store); auto.
        apply HV15. omega.
      }
      destruct HP as [m15 HST15].
      assert (HV16: forall n0, 0<= n0 < UCTXT_SIZE -> Mem.valid_access m15 Mint32 b (UCTXT_SIZE * 4 * vcid + 4 * n0) Writable).
      {
        intros; eapply Mem.store_valid_access_1; eauto.
      }
      clear HV15.
      assert (HP: exists m16, Mem.store Mint32 m15 b (UCTXT_SIZE * 4 * vcid + 4 * U_SS) (Vint v16) = Some m16).
      {
        apply (Mem.valid_access_store); auto.
        apply HV16. omega.
      }
      destruct HP as [m16 HST16].
      assert (HV: forall n0, 0<= n0 < UCTXT_SIZE -> Mem.valid_access m16 Mint32 b (UCTXT_SIZE * 4 * vcid + 4 * n0) Writable).
      {
        intros; eapply Mem.store_valid_access_1; eauto.
      }
      clear HV16.

      assert(HMCTXT: match_UCtxt s (uctxt d1') m16 ι).
      {
        econstructor; eauto.
        intros n r HZ HO.
        replace (n * 17 * 4 + r * 4) with (17 * 4 * n + 4 * r) by omega.
        unfold UContext in Heq. rewrite Heq.
        rewrite Hcid.
        destruct (zeq n vcid); subst.
        - rewrite ZMap.gss.
          destruct (zeq r U_SS); subst.
          refine_split'; trivial.
          erewrite Mem.load_store_same; eauto.
          Ltac simpl_valid_access m :=
            repeat match goal with
                     | [ |- Mem.valid_access m _ _ _ _]
                       => eapply Mem.store_valid_access_3; eauto
                     | _ => eapply Mem.store_valid_access_1; eauto
                   end.
          simpl_valid_access m15.
          subst uctx3 uctx2 uctx1.
          Ltac simpl_zmap_get :=
            repeat match goal with
                     | [ |- context[ZMap.get ?a (ZMap.set ?a _ _ )]]
                       => rewrite ZMap.gss
                     | [ H0: ?a <> ?b |- context[ZMap.get ?a (ZMap.set ?b _ _ )]]
                       => rewrite (ZMap.gso _ _ H0); auto
                     | _ => constructor
                   end.
          simpl_zmap_get.
          assert (HW0: Mem.load Mint32 m16 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)
                       = Mem.load Mint32 m15 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)).
          {
            rewrite (Mem.load_store_other  _ _ _ _ _ _ HST16); trivial.
            right. destruct (zlt r U_SS).
            left. unfold size_chunk. omega.
            right. unfold size_chunk. omega.
          }
          destruct (zeq r U_ESP); subst.
          refine_split'; trivial.
          rewrite HW0.
          erewrite Mem.load_store_same; eauto.
          simpl_valid_access m14.
          subst uctx3 uctx2 uctx1.
          simpl_zmap_get.

          assert (HW1: Mem.load Mint32 m16 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)
                       = Mem.load Mint32 m14 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)).
          {
            rewrite HW0.
            rewrite (Mem.load_store_other  _ _ _ _ _ _ HST15); trivial.
            right. destruct (zlt r U_ESP).
            left. unfold size_chunk. omega.
            right. unfold size_chunk. omega.
          }
          destruct (zeq r U_EFLAGS); subst.
          refine_split'; trivial.
          rewrite HW1.
          erewrite Mem.load_store_same; eauto.
          simpl_valid_access m13.

          subst uctx3 uctx2 uctx1.
          simpl_zmap_get.

          assert (HW2: Mem.load Mint32 m16 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)
                       = Mem.load Mint32 m13 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)).
          {
            rewrite HW1.
            rewrite (Mem.load_store_other  _ _ _ _ _ _ HST14); trivial.
            right. destruct (zlt r U_EFLAGS).
            left. unfold size_chunk. omega.
            right. unfold size_chunk. omega.
          }
          clear HW0 HW1.
          destruct (zeq r U_CS); subst.
          refine_split'; trivial.
          rewrite HW2.
          erewrite Mem.load_store_same; eauto.
          simpl_valid_access m12.

          subst uctx3 uctx2 uctx1.
          simpl_zmap_get.

          assert (HW3: Mem.load Mint32 m16 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)
                       = Mem.load Mint32 m12 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)).
          {
            rewrite HW2. rewrite (Mem.load_store_other  _ _ _ _ _ _ HST13).
            trivial. right. destruct (zlt r U_CS).
            left. unfold size_chunk. omega.
            right. unfold size_chunk. omega.
          }
          clear HW2.
          destruct (zeq r U_EIP); subst.
          refine_split'; trivial.
          rewrite HW3.
          erewrite Mem.load_store_same; eauto.
          simpl_valid_access m11.

          subst uctx3 uctx2 uctx1.
          simpl_zmap_get.

          assert (HW4: Mem.load Mint32 m16 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)
                       = Mem.load Mint32 m11 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)).
          {
            rewrite HW3. rewrite (Mem.load_store_other  _ _ _ _ _ _ HST12).
            trivial. right. destruct (zlt r U_EIP).
            left. unfold size_chunk. omega.
            right. unfold size_chunk. omega.
          }
          clear HW3.
          destruct (zeq r U_ERR); subst.
          refine_split'; trivial.
          rewrite HW4.
          erewrite Mem.load_store_same; eauto.
          simpl_valid_access m10.

          subst uctx3 uctx2 uctx1.
          simpl_zmap_get.

          assert (HW5: Mem.load Mint32 m16 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)
                       = Mem.load Mint32 m10 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)).
          {
            rewrite HW4. rewrite (Mem.load_store_other  _ _ _ _ _ _ HST11).
            trivial. right. destruct (zlt r U_ERR).
            left. unfold size_chunk. omega.
            right. unfold size_chunk. omega.
          }
          clear HW4.
          destruct (zeq r U_TRAPNO); subst.
          refine_split'; trivial.
          rewrite HW5.
          erewrite Mem.load_store_same; eauto.
          simpl_valid_access m9.

          subst uctx3 uctx2 uctx1.
          simpl_zmap_get.

          assert (HW6: Mem.load Mint32 m16 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)
                       = Mem.load Mint32 m9 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)).
          {
            rewrite HW5. rewrite (Mem.load_store_other  _ _ _ _ _ _ HST10).
            trivial. right. destruct (zlt r U_TRAPNO).
            left. unfold size_chunk. omega.
            right. unfold size_chunk. omega.
          }
          clear HW5.
          destruct (zeq r U_DS); subst.
          refine_split'; trivial.
          rewrite HW6.
          erewrite Mem.load_store_same; eauto.
          simpl_valid_access m8.

          subst uctx3 uctx2 uctx1.
          simpl_zmap_get.

          assert (HW7: Mem.load Mint32 m16 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)
                       = Mem.load Mint32 m8 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)).
          {
            rewrite HW6. rewrite (Mem.load_store_other  _ _ _ _ _ _ HST9).
            trivial. right. destruct (zlt r U_DS).
            left. unfold size_chunk. omega.
            right. unfold size_chunk. omega.
          }
          clear HW6.
          destruct (zeq r U_ES); subst.
          refine_split'; trivial.
          rewrite HW7.
          erewrite Mem.load_store_same; eauto.
          simpl_valid_access m7.

          subst uctx3 uctx2 uctx1.
          simpl_zmap_get.

          assert (HW8: Mem.load Mint32 m16 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)
                       = Mem.load Mint32 m7 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)).
          {
            rewrite HW7. rewrite (Mem.load_store_other  _ _ _ _ _ _ HST8).
            trivial. right.
            destruct (zlt r U_ES).
            left. unfold size_chunk. omega.
            right. unfold size_chunk. omega.
          }
          clear HW7.
          destruct (zeq r U_EAX); subst.
          refine_split'; trivial.
          rewrite HW8.
          erewrite Mem.load_store_same; eauto.
          simpl_valid_access m6.

          subst uctx3 uctx2 uctx1.
          simpl_zmap_get.

          assert (HW9: Mem.load Mint32 m16 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)
                       = Mem.load Mint32 m6 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)).
          {
            rewrite HW8.
            rewrite (Mem.load_store_other  _ _ _ _ _ _ HST7).
            trivial. right.
            destruct (zlt r U_EAX).
            left. unfold size_chunk. omega.
            right. unfold size_chunk. omega.
          }
          clear HW8.
          destruct (zeq r U_ECX); subst.
          refine_split'; trivial.
          rewrite HW9.
          erewrite Mem.load_store_same; eauto.
          simpl_valid_access m5.

          subst uctx3 uctx2 uctx1.
          simpl_zmap_get.

          assert (HW10: Mem.load Mint32 m16 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)
                        = Mem.load Mint32 m5 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)).
          {
            rewrite HW9. rewrite (Mem.load_store_other  _ _ _ _ _ _ HST6).
            trivial. right. destruct (zlt r U_ECX).
            left. unfold size_chunk. omega.
            right. unfold size_chunk. omega.
          }
          clear HW9.
          destruct (zeq r U_EDX); subst.
          refine_split'; trivial.
          rewrite HW10.
          erewrite Mem.load_store_same; eauto.
          simpl_valid_access m4.

          subst uctx3 uctx2 uctx1.
          simpl_zmap_get.

          assert (HW11: Mem.load Mint32 m16 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)
                        = Mem.load Mint32 m4 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)).
          {
            rewrite HW10. rewrite (Mem.load_store_other  _ _ _ _ _ _ HST5).
            trivial. right. destruct (zlt r U_EDX).
            left. unfold size_chunk. omega.
            right. unfold size_chunk. omega.
          }
          clear HW10.
          destruct (zeq r U_EBX); subst.
          refine_split'; trivial.
          rewrite HW11.
          erewrite Mem.load_store_same; eauto.
          simpl_valid_access m3.

          subst uctx3 uctx2 uctx1.
          simpl_zmap_get.

          assert (HW12: Mem.load Mint32 m16 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)
                        = Mem.load Mint32 m3 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)).
          {
            rewrite HW11. rewrite (Mem.load_store_other  _ _ _ _ _ _ HST4).
            trivial. right.
            destruct (zlt r U_EBX); subst.
            left. unfold size_chunk. omega.
            right. unfold size_chunk. omega.
          }
          clear HW11.
          destruct (zeq r U_OESP); subst.
          refine_split'; trivial.
          rewrite HW12.
          erewrite Mem.load_store_same; eauto.
          simpl_valid_access m2'.

          subst uctx3 uctx2 uctx1.
          simpl_zmap_get.

          assert (HW13: Mem.load Mint32 m16 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)
                        = Mem.load Mint32 m2' b (UCTXT_SIZE * 4 * cid d2 + 4 * r)).
          {
            rewrite HW12. rewrite (Mem.load_store_other  _ _ _ _ _ _ HST3).
            trivial. right. destruct (zlt r U_OESP).
            left. unfold size_chunk. omega.
            right. unfold size_chunk. omega.
          }
          clear HW12.
          destruct (zeq r U_EBP); subst.
          refine_split'; trivial.
          rewrite HW13.
          erewrite Mem.load_store_same; eauto.
          simpl_valid_access m1.

          subst uctx3 uctx2 uctx1.
          simpl_zmap_get.

          assert (HW14: Mem.load Mint32 m16 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)
                        = Mem.load Mint32 m1 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)).
          {
            rewrite HW13. rewrite (Mem.load_store_other  _ _ _ _ _ _ HST2).
            trivial. right. destruct (zlt r U_EBP).
            left. unfold size_chunk. omega.
            right. unfold size_chunk. omega.
          }
          clear HW13.
          destruct (zeq r U_ESI); subst.
          refine_split'; trivial.
          rewrite HW14.
          erewrite Mem.load_store_same; eauto.
          simpl_valid_access m0.

          subst uctx3 uctx2 uctx1.
          simpl_zmap_get.

          assert (HW15: Mem.load Mint32 m16 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)
                        = Mem.load Mint32 m0 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)).
          {
            rewrite HW14. rewrite (Mem.load_store_other  _ _ _ _ _ _ HST1).
            trivial. right. destruct (zlt r U_ESI).
            left. unfold size_chunk. omega.
            right. unfold size_chunk. omega.
          }
          clear HW14.
          destruct (zeq r U_EDI); subst.
          refine_split'; trivial.
          rewrite HW15.
          erewrite Mem.load_store_same; eauto.
          simpl_valid_access m2.

          subst uctx3 uctx2 uctx1.
          simpl_zmap_get.

          assert (HW: Mem.load Mint32 m16 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)
                      = Mem.load Mint32 m2 b (UCTXT_SIZE * 4 * cid d2 + 4 * r)).
          {
            rewrite HW15. rewrite (Mem.load_store_other  _ _ _ _ _ _ HST0).
            trivial. right.
            right. unfold size_chunk. omega.
          }
          clear HW15. omega.

        - Opaque Z.add Z.mul Val.load_result.
          rewrite ZMap.gso; auto.
          simpl in *.
          specialize (HMem _ _ HZ HO).
          destruct HMem as [v[HL[HVa HM]]].
          eexists v. split.
          rewrite (Mem.load_store_other  _ _ _ _ _ _ HST16);
            [ |destruct (zle n (cid d2)); right;[left; simpl; omega|right; simpl; omega]].
          rewrite (Mem.load_store_other  _ _ _ _ _ _ HST15);
            [ |destruct (zle n (cid d2)); right;[left; simpl; omega|right; simpl; omega]].
          rewrite (Mem.load_store_other  _ _ _ _ _ _ HST14);
            [ |destruct (zle n (cid d2)); right;[left; simpl; omega|right; simpl; omega]].
          rewrite (Mem.load_store_other  _ _ _ _ _ _ HST13);
            [ |destruct (zle n (cid d2)); right;[left; simpl; omega|right; simpl; omega]].
          rewrite (Mem.load_store_other  _ _ _ _ _ _ HST12);
            [ |destruct (zle n (cid d2)); right;[left; simpl; omega|right; simpl; omega]].
          rewrite (Mem.load_store_other  _ _ _ _ _ _ HST11);
            [ |destruct (zle n (cid d2)); right;[left; simpl; omega|right; simpl; omega]].
          rewrite (Mem.load_store_other  _ _ _ _ _ _ HST10);
            [ |destruct (zle n (cid d2)); right;[left; simpl; omega|right; simpl; omega]].
          rewrite (Mem.load_store_other  _ _ _ _ _ _ HST9);
            [ |destruct (zle n (cid d2)); right;[left; simpl; omega|right; simpl; omega]].
          rewrite (Mem.load_store_other  _ _ _ _ _ _ HST8);
            [ |destruct (zle n (cid d2)); right;[left; simpl; omega|right; simpl; omega]].
          rewrite (Mem.load_store_other  _ _ _ _ _ _ HST7);
            [ |destruct (zle n (cid d2)); right;[left; simpl; omega|right; simpl; omega]].
          rewrite (Mem.load_store_other  _ _ _ _ _ _ HST6);
            [ |destruct (zle n (cid d2)); right;[left; simpl; omega|right; simpl; omega]].
          rewrite (Mem.load_store_other  _ _ _ _ _ _ HST5);
            [ |destruct (zle n (cid d2)); right;[left; simpl; omega|right; simpl; omega]].
          rewrite (Mem.load_store_other  _ _ _ _ _ _ HST4);
            [ |destruct (zle n (cid d2)); right;[left; simpl; omega|right; simpl; omega]].
          rewrite (Mem.load_store_other  _ _ _ _ _ _ HST3);
            [ |destruct (zle n (cid d2)); right;[left; simpl; omega|right; simpl; omega]].
          rewrite (Mem.load_store_other  _ _ _ _ _ _ HST2);
            [ |destruct (zle n (cid d2)); right;[left; simpl; omega|right; simpl; omega]].
          rewrite (Mem.load_store_other  _ _ _ _ _ _ HST1);
            [ |destruct (zle n (cid d2)); right;[left; simpl; omega|right; simpl; omega]].
          rewrite (Mem.load_store_other  _ _ _ _ _ _ HST0);
            [ |destruct (zle n (cid d2)); right;[left; simpl; omega|right; simpl; omega]].
          replace (17 * 4 * n + 4 * r) with (n * 17 * 4 + r * 4) by omega.
          apply HL.

          split; trivial.
          eapply Mem.store_valid_access_1; eauto.
          eapply Mem.store_valid_access_1; eauto.
          eapply Mem.store_valid_access_1; eauto.
          eapply Mem.store_valid_access_1; eauto.
          eapply Mem.store_valid_access_1; eauto.
          eapply Mem.store_valid_access_1; eauto.
          eapply Mem.store_valid_access_1; eauto.
          eapply Mem.store_valid_access_1; eauto.
          eapply Mem.store_valid_access_1; eauto.
          eapply Mem.store_valid_access_1; eauto.
          eapply Mem.store_valid_access_1; eauto.
          eapply Mem.store_valid_access_1; eauto.
          eapply Mem.store_valid_access_1; eauto.
          eapply Mem.store_valid_access_1; eauto.
          eapply Mem.store_valid_access_1; eauto.
          eapply Mem.store_valid_access_1; eauto.
          eapply Mem.store_valid_access_1; eauto.
          replace (17 * 4 * n + 4 * r) with (n * 17 * 4 + r * 4) by omega.
          apply HVa.
      }

      refine_split; eauto 2.
      - econstructor; eauto.
        instantiate (1:= (m0, d2)).
        lift_simpl. split; eauto.
        instantiate (1:= (m1, d2)).
        lift_simpl. split; eauto.
        instantiate (1:= (m2', d2)).
        lift_simpl. split; eauto.
        instantiate (1:= (m3, d2)).
        lift_simpl. split; eauto.
        instantiate (1:= (m4, d2)).
        lift_simpl. split; eauto.
        instantiate (1:= (m5, d2)).
        lift_simpl. split; eauto.
        instantiate (1:= (m6, d2)).
        lift_simpl. split; eauto.
        instantiate (1:= (m7, d2)).
        lift_simpl. split; eauto.
        instantiate (1:= (m8, d2)).
        lift_simpl. split; eauto.
        instantiate (1:= (m9, d2)).
        lift_simpl. split; eauto.
        instantiate (1:= (m10, d2)).
        lift_simpl. split; eauto.
        instantiate (1:= (m11, d2)).
        lift_simpl. split; eauto.
        instantiate (1:= (m12, d2)).
        lift_simpl. split; eauto.
        instantiate (1:= (m13, d2)).
        lift_simpl. split; eauto.
        instantiate (1:= (m14, d2)).
        lift_simpl. split; eauto.
        instantiate (1:= (m15, d2)).
        lift_simpl. split; eauto.
        instantiate (2:= m16).
        lift_simpl. split; eauto.

      - pose proof H6 as Hspec.
        functional inversion Hspec; subst.
        split; eauto; pattern2_refinement_simpl.
        econstructor; simpl; eauto.
    Qed.

  End WITHMEM.

End Refinement.


(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
Require Export type_system.

Local Open Scope expr_scope.
Local Open Scope ctype_scope.

Set Warnings "-fragile-hint-constr".

Section deciders.
Context `{Env K}.
Notation envs := (env K * memenv K * list (type K))%type.

#[global] Instance assign_typed_dec (τ1 τ2 : type K) (ass : assign) :
  Decision (assign_typed τ1 τ2 ass).
Proof.
 refine
  match ass with
  | Assign => cast_if (decide (cast_typed τ2 τ1))
  | PreOp op | PostOp op =>
     match Some_dec (binop_type_of op τ1 τ2) with
     | inleft (σ ↾ _) => cast_if (decide (cast_typed σ τ1))
     | inright _ => right _
     end
  end; repeat first
    [ by subst; econstructor; eauto using binop_type_of_sound
    | by inversion 1; repeat match goal with
      | H : binop_typed _ _ _ _ |- _ => apply binop_type_of_complete in H
      end; simplify_equality'
    | destruct τ1 | destruct τ2 ].
Defined.
#[global] Instance lrval_type_check:
   TypeCheck (env K * memenv K) (lrtype K) (lrval K) := λ ΓΔ ν,
  match ν with
  | inl p => inl <$> type_check ΓΔ p
  | inr v => inr <$> type_check ΓΔ v
  end.
#[global] Instance expr_type_check: TypeCheck envs (lrtype K) (expr K) :=
  fix go Γs e {struct e} := let _ : TypeCheck envs _ _ := @go in
  let '(Γ,Δ,τs) := Γs in
  match e with
  | var n => τ ← τs !! n; Some (inl (TType τ))
  | %#{Ω} ν => guard (✓{Γ,Δ} Ω); type_check (Γ,Δ) ν
  | .* e =>
     τ ← type_check Γs e ≫= maybe inr;
     τp ← maybe (TBase ∘ TPtr) τ;
     Some (inl τp)
  | & e =>
     τp ← type_check Γs e ≫= maybe inl;
     Some (inr (τp.*))
  | e1 ::={ass} e2 =>
     τ1 ← type_check Γs e1 ≫= maybe (inl ∘ TType);
     τ2 ← type_check Γs e2 ≫= maybe inr;
     guard (assign_typed τ1 τ2 ass);
     Some (inr τ1)
  | call e @ es =>
     '(σs,σ) ← (type_check Γs e ≫= maybe inl) ≫= maybe2 TFun;
     σs' ← mapM (λ e, type_check Γs e ≫= maybe inr) es;
     guard ((σs' : list (type K)) = σs); guard (type_complete Γ σ); Some (inr σ)
  | abort τ => guard (✓{Γ} τ); Some (inr τ)
  | load e =>
     τ ← type_check Γs e ≫= maybe (inl ∘ TType);
     guard (type_complete Γ τ);
     Some (inr τ)
  | e %> rs =>
     τ ← type_check Γs e ≫= maybe (inl ∘ TType);
     inl ∘ TType <$> τ !!{Γ} rs
  | e #> rs =>
     τ ← type_check Γs e ≫= maybe inr;
     inr <$> τ !!{Γ} rs
  | alloc{τ} e =>
     _ ← type_check Γs e ≫= maybe (inr ∘ TBase ∘ TInt);
     guard (✓{Γ} τ); Some (inl (TType τ))
  | free e =>
     τp ← type_check Γs e ≫= maybe inl;
     Some (inr voidT)
  | .{op} e =>
     τ ← type_check Γs e ≫= maybe inr;
     inr <$> unop_type_of op τ
  | e1 .{op} e2 =>
     τ1 ← type_check Γs e1 ≫= maybe inr;
     τ2 ← type_check Γs e2 ≫= maybe inr;
     inr <$> binop_type_of op τ1 τ2
  | if{e1} e2 else e3 =>
     τb ← type_check Γs e1 ≫= maybe (inr ∘ TBase); guard (τb ≠ @TVoid K);
     τlr2 ← type_check Γs e2;
     τlr3 ← type_check Γs e3;
     guard (τlr2 = τlr3); Some τlr2
  | e1,, e2 =>
     _ ← type_check Γs e1; type_check Γs e2
  | cast{σ} e =>
     τ ← type_check Γs e ≫= maybe inr;
     guard (cast_typed τ σ); guard (✓{Γ} σ); Some (inr σ)
  | #[r:=e1] e2 =>
     σ ← type_check Γs e1 ≫= maybe inr;
     τ ← type_check Γs e2 ≫= maybe inr;
     σ' ← τ !!{Γ} r;
     guard ((σ':type K) = σ); Some (inr τ)
  end.
#[global] Instance ectx_item_lookup :
    LookupE envs (ectx_item K) (lrtype K) (lrtype K) := λ Γs Ei τlr,
  let '(Γ,Δ,τs) := Γs in
  match Ei, τlr with
  | .* □, inr τ =>
    τp ← maybe (TBase ∘ TPtr) τ;
    Some (inl τp)
  | & □, inl τp => Some (inr (τp.*))
  | □ ::={ass} e2, inl τp1 =>
     τ1 ← maybe TType τp1;
     τ2 ← type_check Γs e2 ≫= maybe inr;
     guard (assign_typed τ1 τ2 ass);
     Some (inr τ1)
  | e1 ::={ass} □, inr τ2 =>
     τ1 ← type_check Γs e1 ≫= maybe (inl ∘ TType);
     guard (assign_typed τ1 τ2 ass);
     Some (inr τ1)
  | call □ @ es, inl τp =>
     '(σs,σ) ← maybe2 TFun τp;
     σs' ← mapM (λ e, type_check Γs e ≫= maybe inr) es;
     guard ((σs : list (type K)) = σs'); guard (type_complete Γ σ); Some (inr σ)
  | call e @ es1 □ es2, inr τ =>
     '(σs,σ) ← (type_check Γs e ≫= maybe inl) ≫= maybe2 TFun;
     σs1 ← mapM (λ e, type_check Γs e ≫= maybe inr) (reverse es1);
     σs2 ← mapM (λ e, type_check Γs e ≫= maybe inr) es2;
     guard ((σs : list (type K)) = σs1 ++ τ :: σs2);
     guard (type_complete Γ σ); Some (inr σ)
  | load □, inl τp =>
     τ ← maybe TType τp;
     guard (type_complete Γ τ);
     Some (inr τ)
  | □ %> rs, inl τp => τ ← maybe TType τp; inl ∘ TType <$> τ !!{Γ} rs
  | □ #> rs, inr τ => inr <$> τ !!{Γ} rs
  | alloc{τ} □, inr τ' =>
     _ ← maybe (TBase ∘ TInt) τ'; guard (✓{Γ} τ); Some (inl (TType τ))
  | free □, inl τp => Some (inr voidT)
  | .{op} □, inr τ => inr <$> unop_type_of op τ
  | □ .{op} e2, inr τ1 =>
     τ2 ← type_check Γs e2 ≫= maybe inr;
     inr <$> binop_type_of op τ1 τ2
  | e1 .{op} □, inr τ2 =>
     τ1 ← type_check Γs e1 ≫= maybe inr;
     inr <$> binop_type_of op τ1 τ2
  | if{□} e2 else e3, inr τ1 =>
     τb ← maybe TBase τ1; guard (τb ≠ @TVoid K);
     τlr2 ← type_check Γs e2;
     τlr3 ← type_check Γs e3;
     guard (τlr2 = τlr3); Some τlr2
  | □ ,, e2, _ => type_check Γs e2
  | cast{σ} □, inr τ => guard (cast_typed τ σ); guard (✓{Γ} σ); Some (inr σ)
  | #[r:=□] e2, inr σ =>
     τ ← type_check Γs e2 ≫= maybe inr;
     σ' ← τ !!{Γ} r;
     guard ((σ':type K) = σ); Some (inr τ)
  | #[r:=e1] □, inr τ =>
     σ ← type_check Γs e1 ≫= maybe inr;
     σ' ← τ !!{Γ} r;
     guard ((σ':type K) = σ); Some (inr τ)
  | _, _ => None
  end.
#[global] Instance ectx_lookup :
    LookupE envs (ectx K) (lrtype K) (lrtype K) :=
  fix go Γs E τlr {struct E} := let _ : LookupE _ _ _ _ := @go in
  match E with [] => Some τlr | Ei :: E => τlr !!{Γs} Ei ≫= lookupE Γs E end.
Definition rettype_union_alt
    (mσ1 mσ2 : option (type K)) : option (option (type K)) :=
  match mσ1, mσ2 with
  | Some σ1, Some σ2 => guard (σ1 = σ2); Some (Some σ1)
  | None, mσ | mσ, None => Some mσ
  end.
#[global] Instance rettype_match_dec (cmσ : rettype K) σ :
  Decision (rettype_match cmσ σ).
Proof.
 refine
  match cmσ with
  | (true,Some σ') => cast_if (decide (σ' = σ))
  | (false,Some σ') => cast_if (decide (σ' = σ ∧ σ = voidT))
  | (true,None) => left _
  | (false,None) => cast_if (decide (σ = voidT))
  end; abstract
    first [by intuition; subst; constructor|inversion 1; subst; intuition].
Defined.
#[global] Instance stmt_type_check: TypeCheck envs (rettype K) (stmt K) :=
  fix go Γs s {struct s} := let _ : TypeCheck envs _ _ := @go in
  let '(Γ,Δ,τs) := Γs in
  match s with
  | skip => Some (false,None)
  | ! e =>
     _ ← type_check Γs e ≫= maybe inr; guard (locks e = ∅); Some (false,None)
  | goto _ | throw _ => Some (true,None)
  | ret e =>
     τ ← type_check Γs e ≫= maybe inr; guard (locks e = ∅); Some (true,Some τ)
  | label _ | scase _ => Some (false,None)
  | local{τ} s => guard (✓{Γ} τ); type_check (Γ,Δ,τ :: τs) s
  | s1 ;; s2 =>
     '(c1,mσ1) ← type_check Γs s1;
     '(c2,mσ2) ← type_check Γs s2;
     mσ ← rettype_union_alt mσ1 mσ2; Some (c2,mσ)
  | catch s => '(c,mσ) ← type_check Γs s; Some (false,mσ)
  | loop s => '(_,mσ) ← type_check Γs s; Some (true,mσ)
  | if{e} s1 else s2 =>
     τb ← type_check Γs e ≫= maybe (inr ∘ TBase); guard (τb ≠ @TVoid K);
     guard (locks e = ∅);
     '(c1,mσ1) ← type_check Γs s1;
     '(c2,mσ2) ← type_check Γs s2;
     mσ ← rettype_union_alt mσ1 mσ2; Some (c1 && c2,mσ)
  | switch{e} s =>
     τi ← type_check Γs e ≫= maybe (inr ∘ TBase ∘ TInt);
     guard (locks e = ∅); '(_,mσ) ← type_check Γs s; Some (false,mσ)
  end%S.
#[global] Instance sctx_item_lookup :
    LookupE envs (sctx_item K) (rettype K) (rettype K) := λ Γs Es τlr,
  match Es, τlr with
  | □ ;; s2, (c1,mσ1) =>
     '(c2,mσ2) ← type_check Γs s2;
     mσ ← rettype_union_alt mσ1 mσ2; Some (c2,mσ)
  | s1 ;; □, (c2,mσ2) =>
     '(c1,mσ1) ← type_check Γs s1;
     mσ ← rettype_union_alt mσ1 mσ2; Some (c2,mσ)
  | catch □, (c,mσ) => Some (false,mσ)
  | loop □, (c,mσ) => Some (true,mσ)
  | if{e} □ else s2, (c1,mσ1) =>
     τb ← type_check Γs e ≫= maybe (inr ∘ TBase); guard (τb ≠ @TVoid K);
     guard (locks e = ∅);
     '(c2,mσ2) ← type_check Γs s2;
     mσ ← rettype_union_alt mσ1 mσ2; Some (c1&&c2,mσ)
  | if{e} s1 else □, (c2,mσ2) =>
     τb ← type_check Γs e ≫= maybe (inr ∘ TBase); guard (τb ≠ @TVoid K);
     guard (locks e = ∅);
     '(c1,mσ1) ← type_check Γs s1;
     mσ ← rettype_union_alt mσ1 mσ2; Some (c1&&c2,mσ)
  | switch{e} □, (c,mσ) =>
     τb ← type_check Γs e ≫= maybe (inr ∘ TBase ∘ TInt);
     guard (locks e = ∅); Some (false,mσ)
  end%S.
#[global] Instance esctx_item_lookup :
    LookupE envs (esctx_item K) (rettype K) (type K) := λ Γs Ee τlr,
  match Ee, τlr with
  | ! □, _ => Some (false,None)
  | ret □, _ => Some (true,Some τlr)
  | if{□} s1 else s2, baseT τb =>
     guard (τb ≠ TVoid);
     '(c1,mσ1) ← type_check Γs s1;
     '(c2,mσ2) ← type_check Γs s2;
     mσ ← rettype_union_alt mσ1 mσ2; Some (c1 && c2,mσ)
  | switch{□} s, intT τi =>
     '(_,mσ) ← type_check Γs s; Some (false,mσ)
  | _, _ => None
  end%S.
#[global] Instance ctx_item_lookup :
    LookupE envs (ctx_item K) (focustype K) (focustype K) := λ Γs Ek τlr,
  let '(Γ,Δ,τs) := Γs in
  match Ek, τlr with
  | CStmt Es, Stmt_type cmσ1 => Stmt_type <$> cmσ1 !!{Γs} Es
  | CLocal o τ, Stmt_type cmσ => guard (Δ ⊢ o : τ); Some (Stmt_type cmσ)
  | CExpr e Ee, Expr_type τ =>
     τ' ← type_check Γs e ≫= maybe inr; guard (locks e = ∅);
     guard (τ = τ'); Stmt_type <$> τ !!{Γs} Ee
  | CFun E, Fun_type f =>
     '(σs,τ) ← Γ !! f; Expr_type <$> inr τ !!{Γs} E ≫= maybe inr
  | CParams f oσs, Stmt_type cmσ =>
     '(σs,σ) ← Γ !! f;
     let os := oσs.*1 in let σs' := oσs.*2 in
     guard (σs' = σs); guard (Δ ⊢* os :* σs); guard (rettype_match cmσ σ);
     Some (Fun_type f)
  | _, _ => None
  end.
#[global] Instance focus_type_check:
    TypeCheck envs (focustype K) (focus K) := λ Γs φ,
  let '(Γ,Δ,τs) := Γs in
  match φ with
  | Stmt d s =>
     cmσ ← type_check Γs s;
     match d, cmσ with
     | ⇈ v, (c,Some τ) =>
        τ' ← type_check (Γ,Δ) v;
        guard ((τ : type K) = τ'); Some (Stmt_type cmσ)
     | ↘, _ | ↗, (false,_) | ↷ _, _ | ↑ _, _ | ↓ _, _ => Some (Stmt_type cmσ)
     | _, _ => None
     end
  | Expr e => Expr_type <$> type_check Γs e ≫= maybe inr
  | Call f vs =>
     '(σs,_) ← Γ !! f;
     σs' ← mapM (type_check (Γ,Δ)) vs;
     guard ((σs : list (type K)) = σs'); Some (Fun_type f)
  | Return f v =>
     '(_,σ) ← Γ !! f;
     σ' ← type_check (Γ,Δ) v;
     guard ((σ : type K) = σ'); Some (Fun_type f)
  | Undef (UndefExpr E e) =>
     Expr_type <$> (type_check Γs e ≫= lookupE Γs E) ≫= maybe inr
  | Undef (UndefBranch Es Ω v) =>
     guard (✓{Γ,Δ} Ω); τ ← type_check (Γ,Δ) v; Stmt_type <$> τ !!{Γs} Es
  end.
End deciders.

Section properties.
Context `{EnvSpec K}.
Implicit Types Γ : env K.
Implicit Types Δ : memenv K.
Implicit Types τ σ : type K.
Notation envs := (env K * memenv K * list (type K))%type.

Ltac simplify :=
  repeat match goal with
  | mcτ : rettype _ |- _ => destruct mcτ
  | _ => progress simplify_option_eq
  | _ => case_match
  end.
Hint Resolve (type_check_sound (V:=val K)) (type_check_sound (V:=ptr K)): core.
Hint Resolve (mapM_type_check_sound (V:=val K)): core.
Hint Immediate (path_type_check_sound (R:=ref_seg _)): core.
Hint Immediate (path_type_check_sound (R:=ref _)): core.
Hint Immediate unop_type_of_sound binop_type_of_sound: core.
#[global] Instance:
  TypeCheckSpec (env K * memenv K) (lrtype K) (lrval K) (✓ ∘ fst).
Proof.
  intros [Γ Δ] ν τlr; split.
  * destruct ν; intros; simplify; typed_constructor; eauto.
  * by destruct 1; simplify; erewrite ?type_check_complete by eauto.
Qed.
Hint Resolve (type_check_sound (V:=lrval K)): core.
#[global] Instance: TypeCheckSpec envs (lrtype K) (expr K) (✓ ∘ fst ∘ fst).
Proof.
  intros [[Γ Δ] τs] e τlr; simpl; split.
  * assert (∀ es σs,
      Forall (λ e, ∀ τlr, type_check (Γ,Δ,τs) e = Some τlr →
        (Γ,Δ,τs) ⊢ e : τlr) es →
      mapM (λ e, type_check (Γ,Δ,τs) e ≫= maybe inr) es = Some σs →
      (Γ,Δ,τs) ⊢* es :* inr <$> σs).
    { intros ??. rewrite mapM_Some.
      induction 2; decompose_Forall_hyps; simplify; constructor; eauto. }
    revert τlr; induction e using @expr_ind_alt;
      intros; simplify; typed_constructor; eauto.
  * assert (∀ es σs,
      Forall2 (λ e τlr, type_check (Γ,Δ,τs) e = Some τlr) es (inr <$> σs) →
      mapM (λ e, type_check (Γ,Δ,τs) e ≫= maybe inr) es = Some σs) as help.
    { intros es σs. rewrite Forall2_fmap_r, mapM_Some.
      induction 1; constructor; simplify_option_eq; eauto. }
    by induction 1 using @expr_typed_ind; simplify_option_eq;
      erewrite ?type_check_complete, ?path_type_check_complete,
        ?assign_type_of_complete, ?unop_type_of_complete,
        ?binop_type_of_complete,?help by eauto; eauto; simplify_option_eq.
Qed.
Hint Resolve (type_check_sound (V:=expr K)): core.
#[global] Instance: PathTypeCheckSpec envs
  (lrtype K) (lrtype K) (ectx_item K) (✓ ∘ fst ∘ fst).
Proof.
  intros [[Γ Δ] τs] Ei τlr; simpl; split.
  * assert (∀ es σs,
      mapM (λ e, type_check (Γ,Δ,τs) e ≫= maybe inr) es = Some σs →
      (Γ,Δ,τs) ⊢* es :* inr <$> σs).
    { intros es σs. rewrite mapM_Some. induction 1; simplify; eauto. }
    destruct τlr, Ei; intros; simplify; typed_constructor; eauto.
  * assert (∀ es σs, (Γ,Δ,τs) ⊢* es :* inr <$> σs →
      mapM (λ e, type_check (Γ,Δ,τs) e ≫= maybe inr) es = Some σs) as help.
    { intros es σs. rewrite Forall2_fmap_r, mapM_Some.
      induction 1; constructor; erewrite ?type_check_complete by eauto; eauto. }
    destruct 1; unfold lookupE; fold lookupE; simplify_option_eq;
      erewrite ?type_check_complete by eauto; simpl;
      erewrite ?path_type_check_complete, ?assign_type_of_complete,
        ?unop_type_of_complete, ?binop_type_of_complete by eauto;
      simplify_option_eq; eauto.
Qed.
Hint Immediate (path_type_check_sound (R:=ectx_item _)): core.
#[global] Instance: PathTypeCheckSpec envs
  (lrtype K) (lrtype K) (ectx K) (✓ ∘ fst ∘ fst).
Proof.
  intros Γs Ei τlr τlr'; split.
  * unfold lookupE. revert τlr.
    induction Ei; intros; simplify; typed_constructor; eauto.
  * unfold lookupE. induction 1; simplify_option_eq;
      erewrite ?path_type_check_complete by eauto; eauto.
Qed.
Hint Immediate (path_type_check_sound (R:=ectx _)): core.
Lemma rettype_union_alt_sound mσ1 mσ2 mσ :
  rettype_union_alt mσ1 mσ2 = Some mσ → rettype_union mσ1 mσ2 mσ.
Proof.
  destruct mσ1, mσ2; intros; simplify_option_eq; constructor; eauto.
Qed.
Hint Immediate rettype_union_alt_sound: core.
Lemma rettype_union_alt_complete mσ1 mσ2 mσ :
  rettype_union mσ1 mσ2 mσ → rettype_union_alt mσ1 mσ2 = Some mσ.
Proof. destruct 1 as [[]| |]; simplify_option_eq; eauto. Qed.
#[global] Instance:
  TypeCheckSpec envs (rettype K) (stmt K) (✓ ∘ fst ∘ fst).
Proof.
  intros [[Γ Δ] τs] s mcτ; simpl; split.
  * revert τs mcτ.
    induction s; intros; simplify; typed_constructor; naive_solver.
  * induction 1;
      repeat match goal with
      | _ : _ ⊢ ?e : _ |- _ => erewrite (type_check_complete _ e) by eauto
      | _ => erewrite rettype_union_alt_complete by eauto
      | _ => progress simplify_option_eq
      end; eauto.
Qed.
Hint Resolve (type_check_sound (V:=stmt K)): core.
#[global] Instance: PathTypeCheckSpec envs
  (type K) (rettype K) (esctx_item K) (✓ ∘ fst ∘ fst).
Proof.
  intros [[Γ Δ] τs] Ee τlr; simpl; split.
  * unfold lookupE; destruct τlr, Ee;
      intros; simplify; typed_constructor; eauto.
  * destruct 1; simplify_option_eq;
      erewrite ?type_check_complete by eauto; simplify_option_eq;
      erewrite ?rettype_union_alt_complete by eauto; eauto.
Qed.
Hint Immediate (path_type_check_sound (R:=esctx_item _)): core.
#[global] Instance: PathTypeCheckSpec envs
  (rettype K) (rettype K) (sctx_item K) (✓ ∘ fst ∘ fst).
Proof.
  intros [[Γ Δ] τs] Es mcτ; simpl; split.
  * destruct mcτ, Es; intros; simplify; typed_constructor; eauto.
  * destruct 1; simplify_option_eq;
      erewrite ?type_check_complete by eauto; simplify_option_eq;
      erewrite ?rettype_union_alt_complete by eauto; eauto.
Qed.
Hint Immediate (path_type_check_sound (R:=sctx_item _)): core.
#[global] Instance: PathTypeCheckSpec envs
  (focustype K) (focustype K) (ctx_item K) (✓ ∘ fst ∘ fst).
Proof.
  intros [[Γ Δ] τs] Ek τf; simpl; split.
  * unfold lookupE; destruct τf, Ek; intros; simplify;
      try match goal with
      | |- context [CParams _ ?oσs] => is_var oσs; rewrite <-(zip_fst_snd oσs)
      end; typed_constructor; eauto.
  * destruct 1;
      repeat match goal with
      | _ => simpl; erewrite fst_zip, snd_zip
         by eauto using Nat.eq_le_incl, Forall2_length, eq_sym
      | _ => progress simplify_option_eq
      | _ => erewrite type_check_complete by eauto
      | _ => erewrite path_type_check_complete by eauto
      end; eauto.
Qed.
#[global] Instance:
  TypeCheckSpec envs (focustype K) (focus K) (✓ ∘ fst ∘ fst).
Proof.
  intros [[Γ Δ] τs] φ τf; simpl; split.
  * unfold type_check; destruct φ, τf;
      intros; simplify; repeat typed_constructor; eauto.
  * destruct 1;
      repeat match goal with
      | _ => progress simplify_option_eq
      | _ => case_match; typed_inversion_all
      | _ => erewrite mapM_type_check_complete by eauto
      | _ => erewrite type_check_complete by eauto
      | _ => erewrite path_type_check_complete by eauto
      end; eauto.
Qed.
End properties.


Require Import POCS.
Require Import TwoDiskAPI.
Require Import TwoDiskBaseAPI.

Module TwoDisk (b : TwoDiskBaseAPI) <: TwoDiskAPI.

  Definition init := b.init.
  Definition read := b.read.
  Definition write := b.write.
  Definition size := b.size.
  Definition recover:= b.recover.

  Definition abstr := b.abstr.

  Ltac inv_step :=
    match goal with
    | [ H: op_step _ _ _ _ |- _ ] =>
      inversion H; subst; clear H;
      repeat sigT_eq;
      safe_intuition
    end.

  Ltac inv_bg :=
    match goal with
    | [ H: bg_failure _ _ |- _ ] =>
      inversion H; subst; clear H
    end.

  Theorem maybe_holds_stable : forall state state' F0 F1 i,
    get_disk (other i) state ?|= F0 ->
    get_disk i state ?|= F1 ->
    bg_failure state state' ->
    get_disk (other i) state' ?|= F0 /\
    get_disk i state' ?|= F1.
  Proof.
    intros.
    destruct i; inv_bg; simpl in *; eauto.
  Qed.

  Ltac cleanup :=
    repeat match goal with
           | [ |- forall _, _ ] => intros
           | |- _ /\ _ => split; [ solve [ eauto || congruence ] | ]
           | |- _ /\ _ => split; [ | solve [ eauto || congruence ] ]
           | [ H: Working _ = Working _ |- _ ] => inversion H; subst; clear H
           | [ H: bg_failure _ _ |- _ ] =>
             eapply maybe_holds_stable in H;
             [ | solve [ eauto ] | solve [ eauto ] ]; destruct_ands
           | [ H: _ ?|= eq _, H': _ = Some _ |- _ ] =>
                    pose proof (holds_some_inv_eq _ H' H); clear H
           | [ H: ?A * ?B |- _ ] => destruct H
           | [ H: DiskResult _ |- _ ] => destruct H
           | _ => deex
           | _ => destruct_tuple
           | _ => progress unfold pre_step in *
           | _ => progress autounfold in *
           | _ => progress simpl in *
           | _ => progress subst
           | _ => progress safe_intuition
           | _ => solve [ eauto ]
           | _ => congruence
           | _ => inv_step
           | H: context[match ?expr with _ => _ end] |- _ =>
             destruct expr eqn:?; [ | solve [ repeat cleanup ] ]
           | H: context[match ?expr with _ => _ end] |- _ =>
             destruct expr eqn:?; [ solve [ repeat cleanup ] | ]
           end.

  Ltac prim :=
    intros;
    eapply proc_spec_weaken; [ eauto | unfold spec_impl ]; eexists;
    intuition eauto; cleanup;
    intuition eauto; cleanup.

  Hint Resolve holds_in_some_eq.
  Hint Resolve holds_in_none_eq.
  Hint Resolve pred_missing.

  Hint Unfold combined_step.

  Theorem init_ok : init_abstraction init recover abstr inited_any.
  Proof.
    eauto.
  Qed.

  Theorem read_ok : forall i a, proc_spec (read_spec i a) (read i a) recover abstr.
  Proof.
    unshelve prim; eauto.
  Qed.

  Ltac destruct_all :=
    repeat match goal with
           | _ => solve [ auto ]
           | [ i: diskId |- _ ] => destruct i
           | [ |- context[match ?s with
                         | BothDisks _ _ => _
                         | OnlyDisk0 _ => _
                         | OnlyDisk1 _ => _
                         end] ] => destruct s
           | _ => simpl in *
           end.

  Theorem write_ok : forall i a v, proc_spec (write_spec i a v) (write i a v) recover abstr.
  Proof.
    unshelve prim; eauto;
      try solve [ destruct_all ].
    destruct (le_dec (S a) (diskSize d0)).
    destruct_all.
    rewrite diskUpd_oob_noop by omega.
    destruct_all.
  Qed.

  Theorem size_ok : forall i, proc_spec (size_spec i) (size i) recover abstr.
  Proof.
    unshelve prim.
    eauto.
  Qed.

  Theorem recover_noop : rec_noop recover abstr no_wipe.
  Proof.
    eauto.
  Qed.

End TwoDisk.