(* *********************************************************************)
(*                                                                     *)
(*            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 VVMXInit layer        *)
(*                                                                     *)
(*                        Xiongnan (Newman) Wu                         *)
(*                                                                     *)
(*                          Yale University                            *)
(*                                                                     *)
(* *********************************************************************)
Require Import TacticsForTesting.
Require Import Coqlib.
Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import MemoryX.
Require Import EventsX.
Require Import Globalenvs.
Require Import Locations.
Require Import Clight.
Require Import Smallstep.
Require Import ClightBigstep.
Require Import Ctypes.
Require Import Cop.
Require Import ZArith.Zwf.
Require Import RealParams.
Require Import LoopProof.
Require Import VCGen.
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 TrapArgGenSpec.
Require Import Clight.
Require Import CDataTypes.
Require Import Ctypes.
Require Import CLemmas.
Require Import XOmega.
Require Import PProcCSource.
Require Import AbstractDataType.
Require Import ObjThread.
Require Import ObjProc.
Require Import ObjArg.

Module PPROCCODE.

  Section WithPrimitives.

    Context `{real_params: RealParams}.
    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}.

(*
    Section LA2PARESV.

      Let L: compatlayer (cdata RData) := get_curid ↦ gensem (fun d => get_curid_spec d)
           ⊕ pt_read ↦ gensem (fun a b d => ptRead_spec d a b)
           ⊕ pt_resv ↦ gensem (fun a b c d => ptResv_spec d a b c).

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

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

      Section La2paResvBody.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

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

        (** get_curid *)

        Variable bget_curid: block.

        Hypothesis hget_curid1 : Genv.find_symbol ge get_curid = Some bget_curid.

        Hypothesis hget_curid2 : Genv.find_funct_ptr ge bget_curid = Some (External (EF_external get_curid (signature_of_type Tnil tint cc_default)) Tnil tint cc_default).

        (** pt_resv *)

        Variable bpt_resv: block.

        Hypothesis hpt_resv1 : Genv.find_symbol ge pt_resv = Some bpt_resv.

        Hypothesis hpt_resv2 : Genv.find_funct_ptr ge bpt_resv = Some (External (EF_external pt_resv (signature_of_type (Tcons tint (Tcons tint (Tcons tint Tnil))) tvoid cc_default)) (Tcons tint (Tcons tint (Tcons tint Tnil))) tvoid cc_default).

        (** pt_read *)

        Variable bpt_read: block.

        Hypothesis hpt_read : Genv.find_symbol ge pt_read = Some bpt_read.

        Hypothesis hpt_read2 : Genv.find_funct_ptr ge bpt_read = Some (External (EF_external pt_read (signature_of_type (Tcons tint (Tcons tint Tnil)) tint cc_default)) (Tcons tint (Tcons tint Tnil)) tint cc_default).

        Lemma la2pa_resv_body_correct: forall m d d' env le va pa,
                                         env = PTree.empty _ ->
                                         PTree.get tva le = Some (Vint va) ->
                                         la2pa_resv_spec d (Int.unsigned va) = Some (d', Int.unsigned pa) ->
                                         high_level_invariant d ->
                                         exists le',
                                           exec_stmt ge env le ((m, d): mem) la2pa_resv_body E0 le' (m, d') (Out_return (Some (Vint pa, tint))).
        Proof.
          generalize max_unsigned_val; intro muval.
          intros.
          assert(cid_range: 0 <= cid d < 64) by (destruct H2; assumption).
          subst.
          unfold la2pa_resv_body.
          functional inversion H1; subst.

          generalize H4; intro tmpinv;
          unfold ptRead_spec in tmpinv;
          case_eq (ikern d); intro ikern; rewrite ikern in tmpinv; try discriminate tmpinv;
          case_eq (ihost d); intro ihost; rewrite ihost in tmpinv; try discriminate tmpinv;
          clear tmpinv.
          rewrite <- Int.unsigned_repr with (cid d) in H4.
          esplit.
          repeat vcgenfull.
          unfold get_curid_spec.
          rewrite ikern, ihost, H5.
          rewrite <- Int.unsigned_repr with (cid d).
          reflexivity.
          omega.
          rewrite H4.
          change 0 with (Int.unsigned Int.zero).
          reflexivity.
          discharge_cmp.
          repeat vcgenfull.
          instantiate (1:= (Int.repr padr')).
          rewrite Int.unsigned_repr; try omega.
          reflexivity.
          repeat vcgen.
          reflexivity.
          repeat vcgen.
          repeat vcgen.
          repeat vcgen.
          repeat vcgen.
          unfold Int.modu.
          rewrite Int.unsigned_repr; try omega.
          simpl.
          assert(Int.repr (padr' / 4096 * 4096 + Int.unsigned va mod 4096) = pa).
            erewrite <- unsigned_inj.
            reflexivity.
            rewrite Int.unsigned_repr.
            assumption.
            xomega.
          rewrite <- H.
          simpl.
          unfold sem_add.
          simpl.
          unfold sem_binarith.
          simpl.
          repeat vcgenfull.
          xomega.
          xomega.
          xomega.
          xomega.
          omega.

          generalize H4; intro tmpinv;
          unfold ptRead_spec in tmpinv;
          case_eq (ikern d'); intro ikern; rewrite ikern in tmpinv; try discriminate tmpinv;
          case_eq (ihost d'); intro ihost; rewrite ihost in tmpinv; try discriminate tmpinv;
          clear tmpinv.
          rewrite <- Int.unsigned_repr with (cid d') in H4.
          esplit.
          repeat vcgenfull.
          unfold get_curid_spec.
          rewrite ikern, ihost, H5.
          rewrite <- Int.unsigned_repr with (cid d').
          reflexivity.
          omega.
          rewrite H4.
          instantiate (1:= (Int.repr padr)).
          rewrite Int.unsigned_repr; try omega.
          reflexivity.
          discharge_cmp.
          repeat vcgenfull.
          repeat vcgen.
          reflexivity.
          repeat vcgen.
          repeat vcgen.
          repeat vcgen.
          repeat vcgen.
          unfold Int.modu.
          rewrite Int.unsigned_repr; try omega.
          simpl.
          assert(Int.repr (padr / 4096 * 4096 + Int.unsigned va mod 4096) = pa).
            erewrite <- unsigned_inj.
            reflexivity.
            rewrite Int.unsigned_repr.
            assumption.
            xomega.
          rewrite <- H.
          unfold sem_add.
          simpl.
          unfold sem_binarith.
          simpl.
          repeat vcgenfull.
          xomega.
          xomega.
          xomega.
          xomega.
          omega.
        Qed.

      End La2paResvBody.

      Theorem la2pa_resv_code_correct:
        spec_le (la2pa_resv ↦ la2pa_resv_spec_low) (〚la2pa_resv ↦ f_la2pa_resv 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (la2pa_resv_body_correct s (Genv.globalenv p) makeglobalenv b0 Hb0fs Hb0fp b1 Hb1fs Hb1fp b2 Hb2fs Hb2fp b3 Hb3fs Hb3fp b4 Hb4fs Hb4fp m'0 labd labd' (PTree.empty _)
                                        (bind_parameter_temps' (fn_params f_la2pa_resv)
                                                               (Vint va::nil)
                                                               (create_undef_temps (fn_temps f_la2pa_resv)))) H0.
      Qed.

    End LA2PARESV.
*)

    Section UCTXARG1.

      Let L: compatlayer (cdata RData) := get_curid ↦ gensem get_curid_spec
           ⊕ uctx_get ↦ gensem uctx_get_spec.

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

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

      Section UctxArg1Body.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

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

        (** get_curid *)

        Variable bget_curid: block.

        Hypothesis hget_curid1 : Genv.find_symbol ge get_curid = Some bget_curid.

        Hypothesis hget_curid2 : Genv.find_funct_ptr ge bget_curid = Some (External (EF_external get_curid (signature_of_type Tnil tint cc_default)) Tnil tint cc_default).

        (** uctx_get *)

        Variable buctx_get: block.

        Hypothesis huctx_get1 : Genv.find_symbol ge uctx_get = Some buctx_get.

        Hypothesis huctx_get2 : Genv.find_funct_ptr ge buctx_get = Some (External (EF_external uctx_get (signature_of_type (Tcons tint (Tcons tint Tnil)) tint cc_default)) (Tcons tint (Tcons tint Tnil)) tint cc_default).

        Lemma uctx_arg1_body_correct: forall m d env le arg,
                                        env = PTree.empty _ ->
                                        uctx_arg1_spec d = Some (Int.unsigned arg) ->
                                        high_level_invariant d ->
                                        exists le',
                                          exec_stmt ge env le ((m, d): mem) uctx_arg1_body E0 le' (m, d) (Out_return (Some (Vint arg, tint))).
        Proof.
          generalize max_unsigned_val; intro muval.
          intros.
          assert(cid_range: 0 <= cid d < 64) by (destruct H1; assumption).
          unfold uctx_arg1_body.
          functional inversion H0; subst.
          assert(ipt: ipt d = true).
            destruct H1.
            rewrite <- valid_ikern_ipt.
            assumption.
          esplit.
          repeat vcgen.
          unfold get_curid_spec.
          rewrite H3, H4, H5.
          rewrite Int.unsigned_repr.
          reflexivity.
          omega.
          unfold uctx_get_spec.
          rewrite H3, H4, H5, ipt, H6.
          unfold is_UCTXT_ptr.
          repeat zdestruct.
          rewrite H2.
          rewrite zle_lt_true.
          reflexivity.
          omega.
          omega.
          omega.
        Qed.

      End UctxArg1Body.

      Theorem uctx_arg1_code_correct:
        spec_le (uctx_arg1 ↦ uctx_arg1_spec_low) (〚uctx_arg1 ↦ f_uctx_arg1 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (uctx_arg1_body_correct s (Genv.globalenv p) makeglobalenv b0 Hb0fs Hb0fp b1 Hb1fs Hb1fp m'0 labd (PTree.empty _)
                                        (bind_parameter_temps' (fn_params f_uctx_arg1)
                                                               nil
                                                               (create_undef_temps (fn_temps f_uctx_arg1)))) H0.
      Qed.

    End UCTXARG1.

    Section UCTXARG2.

      Let L: compatlayer (cdata RData) := get_curid ↦ gensem get_curid_spec
           ⊕ uctx_get ↦ gensem uctx_get_spec.

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

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

      Section UctxArg2Body.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

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

        (** get_curid *)

        Variable bget_curid: block.

        Hypothesis hget_curid1 : Genv.find_symbol ge get_curid = Some bget_curid.

        Hypothesis hget_curid2 : Genv.find_funct_ptr ge bget_curid = Some (External (EF_external get_curid (signature_of_type Tnil tint cc_default)) Tnil tint cc_default).

        (** uctx_get *)

        Variable buctx_get: block.

        Hypothesis huctx_get1 : Genv.find_symbol ge uctx_get = Some buctx_get.

        Hypothesis huctx_get2 : Genv.find_funct_ptr ge buctx_get = Some (External (EF_external uctx_get (signature_of_type (Tcons tint (Tcons tint Tnil)) tint cc_default)) (Tcons tint (Tcons tint Tnil)) tint cc_default).

        Lemma uctx_arg2_body_correct: forall m d env le arg,
                                        env = PTree.empty _ ->
                                        uctx_arg2_spec d = Some (Int.unsigned arg) ->
                                        high_level_invariant d ->
                                        exists le',
                                          exec_stmt ge env le ((m, d): mem) uctx_arg2_body E0 le' (m, d) (Out_return (Some (Vint arg, tint))).
        Proof.
          generalize max_unsigned_val; intro muval.
          intros.
          assert(cid_range: 0 <= cid d < 64) by (destruct H1; assumption).
          unfold uctx_arg2_body.
          functional inversion H0; subst.
          assert(ipt: ipt d = true).
            destruct H1.
            rewrite <- valid_ikern_ipt.
            assumption.
          esplit.
          repeat vcgen.
          unfold get_curid_spec.
          rewrite H3, H4, H5.
          rewrite Int.unsigned_repr.
          reflexivity.
          omega.
          unfold uctx_get_spec.
          rewrite H3, H4, H5, ipt, H6.
          unfold is_UCTXT_ptr.
          repeat zdestruct.
          rewrite H2.
          rewrite zle_lt_true.
          reflexivity.
          omega.
          omega.
          omega.
        Qed.

      End UctxArg2Body.

      Theorem uctx_arg2_code_correct:
        spec_le (uctx_arg2 ↦ uctx_arg2_spec_low) (〚uctx_arg2 ↦ f_uctx_arg2 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (uctx_arg2_body_correct s (Genv.globalenv p) makeglobalenv b0 Hb0fs Hb0fp b1 Hb1fs Hb1fp m'0 labd (PTree.empty _)
                                        (bind_parameter_temps' (fn_params f_uctx_arg2)
                                                               nil
                                                               (create_undef_temps (fn_temps f_uctx_arg2)))) H0.
      Qed.

    End UCTXARG2.

    Section UCTXARG3.

      Let L: compatlayer (cdata RData) := get_curid ↦ gensem get_curid_spec
           ⊕ uctx_get ↦ gensem uctx_get_spec.

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

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

      Section UctxArg3Body.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

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

        (** get_curid *)

        Variable bget_curid: block.

        Hypothesis hget_curid1 : Genv.find_symbol ge get_curid = Some bget_curid.

        Hypothesis hget_curid2 : Genv.find_funct_ptr ge bget_curid = Some (External (EF_external get_curid (signature_of_type Tnil tint cc_default)) Tnil tint cc_default).

        (** uctx_get *)

        Variable buctx_get: block.

        Hypothesis huctx_get1 : Genv.find_symbol ge uctx_get = Some buctx_get.

        Hypothesis huctx_get2 : Genv.find_funct_ptr ge buctx_get = Some (External (EF_external uctx_get (signature_of_type (Tcons tint (Tcons tint Tnil)) tint cc_default)) (Tcons tint (Tcons tint Tnil)) tint cc_default).

        Lemma uctx_arg3_body_correct: forall m d env le arg,
                                        env = PTree.empty _ ->
                                        uctx_arg3_spec d = Some (Int.unsigned arg) ->
                                        high_level_invariant d ->
                                        exists le',
                                          exec_stmt ge env le ((m, d): mem) uctx_arg3_body E0 le' (m, d) (Out_return (Some (Vint arg, tint))).
        Proof.
          generalize max_unsigned_val; intro muval.
          intros.
          assert(cid_range: 0 <= cid d < 64) by (destruct H1; assumption).
          unfold uctx_arg3_body.
          functional inversion H0; subst.
          assert(ipt: ipt d = true).
            destruct H1.
            rewrite <- valid_ikern_ipt.
            assumption.
          esplit.
          repeat vcgen.
          unfold get_curid_spec.
          rewrite H3, H4, H5.
          rewrite Int.unsigned_repr.
          reflexivity.
          omega.
          unfold uctx_get_spec.
          rewrite H3, H4, H5, ipt, H6.
          unfold is_UCTXT_ptr.
          repeat zdestruct.
          rewrite H2.
          rewrite zle_lt_true.
          reflexivity.
          omega.
          omega.
          omega.
        Qed.

      End UctxArg3Body.

      Theorem uctx_arg3_code_correct:
        spec_le (uctx_arg3 ↦ uctx_arg3_spec_low) (〚uctx_arg3 ↦ f_uctx_arg3 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (uctx_arg3_body_correct s (Genv.globalenv p) makeglobalenv b0 Hb0fs Hb0fp b1 Hb1fs Hb1fp m'0 labd (PTree.empty _)
                                        (bind_parameter_temps' (fn_params f_uctx_arg3)
                                                               nil
                                                               (create_undef_temps (fn_temps f_uctx_arg3)))) H0.
      Qed.

    End UCTXARG3.

    Section UCTXARG4.

      Let L: compatlayer (cdata RData) := get_curid ↦ gensem get_curid_spec
           ⊕ uctx_get ↦ gensem uctx_get_spec.

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

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

      Section UctxArg4Body.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

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

        (** get_curid *)

        Variable bget_curid: block.

        Hypothesis hget_curid1 : Genv.find_symbol ge get_curid = Some bget_curid.

        Hypothesis hget_curid2 : Genv.find_funct_ptr ge bget_curid = Some (External (EF_external get_curid (signature_of_type Tnil tint cc_default)) Tnil tint cc_default).

        (** uctx_get *)

        Variable buctx_get: block.

        Hypothesis huctx_get1 : Genv.find_symbol ge uctx_get = Some buctx_get.

        Hypothesis huctx_get2 : Genv.find_funct_ptr ge buctx_get = Some (External (EF_external uctx_get (signature_of_type (Tcons tint (Tcons tint Tnil)) tint cc_default)) (Tcons tint (Tcons tint Tnil)) tint cc_default).

        Lemma uctx_arg4_body_correct: forall m d env le arg,
                                        env = PTree.empty _ ->
                                        uctx_arg4_spec d = Some (Int.unsigned arg) ->
                                        high_level_invariant d ->
                                        exists le',
                                          exec_stmt ge env le ((m, d): mem) uctx_arg4_body E0 le' (m, d) (Out_return (Some (Vint arg, tint))).
        Proof.
          generalize max_unsigned_val; intro muval.
          intros.
          assert(cid_range: 0 <= cid d < 64) by (destruct H1; assumption).
          unfold uctx_arg4_body.
          functional inversion H0; subst.
          assert(ipt: ipt d = true).
            destruct H1.
            rewrite <- valid_ikern_ipt.
            assumption.
          esplit.
          repeat vcgen.
          unfold get_curid_spec.
          rewrite H3, H4, H5.
          rewrite Int.unsigned_repr.
          reflexivity.
          omega.
          unfold uctx_get_spec.
          rewrite H3, H4, H5, ipt, H6.
          unfold is_UCTXT_ptr.
          repeat zdestruct.
          rewrite H2.
          rewrite zle_lt_true.
          reflexivity.
          omega.
          omega.
          omega.
        Qed.

      End UctxArg4Body.

      Theorem uctx_arg4_code_correct:
        spec_le (uctx_arg4 ↦ uctx_arg4_spec_low) (〚uctx_arg4 ↦ f_uctx_arg4 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (uctx_arg4_body_correct s (Genv.globalenv p) makeglobalenv b0 Hb0fs Hb0fp b1 Hb1fs Hb1fp m'0 labd (PTree.empty _)
                                        (bind_parameter_temps' (fn_params f_uctx_arg4)
                                                               nil
                                                               (create_undef_temps (fn_temps f_uctx_arg4)))) H0.
      Qed.

    End UCTXARG4.

    Section UCTXARG5.

      Let L: compatlayer (cdata RData) := get_curid ↦ gensem get_curid_spec
           ⊕ uctx_get ↦ gensem uctx_get_spec.

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

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

      Section UctxArg5Body.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

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

        (** get_curid *)

        Variable bget_curid: block.

        Hypothesis hget_curid1 : Genv.find_symbol ge get_curid = Some bget_curid.

        Hypothesis hget_curid2 : Genv.find_funct_ptr ge bget_curid = Some (External (EF_external get_curid (signature_of_type Tnil tint cc_default)) Tnil tint cc_default).

        (** uctx_get *)

        Variable buctx_get: block.

        Hypothesis huctx_get1 : Genv.find_symbol ge uctx_get = Some buctx_get.

        Hypothesis huctx_get2 : Genv.find_funct_ptr ge buctx_get = Some (External (EF_external uctx_get (signature_of_type (Tcons tint (Tcons tint Tnil)) tint cc_default)) (Tcons tint (Tcons tint Tnil)) tint cc_default).

        Lemma uctx_arg5_body_correct: forall m d env le arg,
                                        env = PTree.empty _ ->
                                        uctx_arg5_spec d = Some (Int.unsigned arg) ->
                                        high_level_invariant d ->
                                        exists le',
                                          exec_stmt ge env le ((m, d): mem) uctx_arg5_body E0 le' (m, d) (Out_return (Some (Vint arg, tint))).
        Proof.
          generalize max_unsigned_val; intro muval.
          intros.
          assert(cid_range: 0 <= cid d < 64) by (destruct H1; assumption).
          unfold uctx_arg5_body.
          functional inversion H0; subst.
          assert(ipt: ipt d = true).
            destruct H1.
            rewrite <- valid_ikern_ipt.
            assumption.
          esplit.
          repeat vcgen.
          unfold get_curid_spec.
          rewrite H3, H4, H5.
          rewrite Int.unsigned_repr.
          reflexivity.
          omega.
          unfold uctx_get_spec.
          rewrite Int.unsigned_repr.
          rewrite H3, H4, H5, ipt, H6.
          unfold is_UCTXT_ptr.
          repeat zdestruct.
          rewrite H2.
          rewrite zle_lt_true.
          reflexivity.
          omega.
          omega.
        Qed.

      End UctxArg5Body.

      Theorem uctx_arg5_code_correct:
        spec_le (uctx_arg5 ↦ uctx_arg5_spec_low) (〚uctx_arg5 ↦ f_uctx_arg5 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (uctx_arg5_body_correct s (Genv.globalenv p) makeglobalenv b0 Hb0fs Hb0fp b1 Hb1fs Hb1fp m'0 labd (PTree.empty _)
                                        (bind_parameter_temps' (fn_params f_uctx_arg5)
                                                               nil
                                                               (create_undef_temps (fn_temps f_uctx_arg5)))) H0.
      Qed.

    End UCTXARG5.

    Section UCTXARG6.

      Let L: compatlayer (cdata RData) := get_curid ↦ gensem get_curid_spec
           ⊕ uctx_get ↦ gensem uctx_get_spec.

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

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

      Section UctxArg6Body.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

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

        (** get_curid *)

        Variable bget_curid: block.

        Hypothesis hget_curid1 : Genv.find_symbol ge get_curid = Some bget_curid.

        Hypothesis hget_curid2 : Genv.find_funct_ptr ge bget_curid = Some (External (EF_external get_curid (signature_of_type Tnil tint cc_default)) Tnil tint cc_default).

        (** uctx_get *)

        Variable buctx_get: block.

        Hypothesis huctx_get1 : Genv.find_symbol ge uctx_get = Some buctx_get.

        Hypothesis huctx_get2 : Genv.find_funct_ptr ge buctx_get = Some (External (EF_external uctx_get (signature_of_type (Tcons tint (Tcons tint Tnil)) tint cc_default)) (Tcons tint (Tcons tint Tnil)) tint cc_default).

        Lemma uctx_arg6_body_correct: forall m d env le arg,
                                        env = PTree.empty _ ->
                                        uctx_arg6_spec d = Some (Int.unsigned arg) ->
                                        high_level_invariant d ->
                                        exists le',
                                          exec_stmt ge env le ((m, d): mem) uctx_arg6_body E0 le' (m, d) (Out_return (Some (Vint arg, tint))).
        Proof.
          generalize max_unsigned_val; intro muval.
          intros.
          assert(cid_range: 0 <= cid d < 64) by (destruct H1; assumption).
          unfold uctx_arg6_body.
          functional inversion H0; subst.
          assert(ipt: ipt d = true).
            destruct H1.
            rewrite <- valid_ikern_ipt.
            assumption.
          esplit.
          repeat vcgen.
          unfold get_curid_spec.
          rewrite H3, H4, H5.
          rewrite Int.unsigned_repr.
          reflexivity.
          omega.
          rewrite Int.unsigned_repr.
          unfold uctx_get_spec.
          rewrite H3, H4, H5, ipt, H6.
          unfold is_UCTXT_ptr.
          rewrite H2.
          rewrite zle_lt_true.
          reflexivity.
          omega.
          omega.
       Qed.

      End UctxArg6Body.

      Theorem uctx_arg6_code_correct:
        spec_le (uctx_arg6 ↦ uctx_arg6_spec_low) (〚uctx_arg6 ↦ f_uctx_arg6 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (uctx_arg6_body_correct s (Genv.globalenv p) makeglobalenv b0 Hb0fs Hb0fp b1 Hb1fs Hb1fp m'0 labd (PTree.empty _)
                                        (bind_parameter_temps' (fn_params f_uctx_arg6)
                                                               nil
                                                               (create_undef_temps (fn_temps f_uctx_arg6)))) H0.
      Qed.

    End UCTXARG6.

    Section UCTXSETERRNO.

      Let L: compatlayer (cdata RData) := get_curid ↦ gensem get_curid_spec
           ⊕ uctx_set ↦ gensem uctx_set_spec.

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

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

      Section UctxSetErronoBody.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

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

        (** get_curid *)

        Variable bget_curid: block.

        Hypothesis hget_curid1 : Genv.find_symbol ge get_curid = Some bget_curid.

        Hypothesis hget_curid2 : Genv.find_funct_ptr ge bget_curid = Some (External (EF_external get_curid (signature_of_type Tnil tint cc_default)) Tnil tint cc_default).

        (** uctx_set *)

        Variable buctx_set: block.

        Hypothesis huctx_set1 : Genv.find_symbol ge uctx_set = Some buctx_set.

        Hypothesis huctx_set2 : Genv.find_funct_ptr ge buctx_set = Some (External (EF_external uctx_set (signature_of_type (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default)) (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default).

        Lemma uctx_set_errno_body_correct: forall m d d' env le errno,
                                             env = PTree.empty _ ->
                                             PTree.get terrno le = Some (Vint errno) ->
                                             uctx_set_errno_spec (Int.unsigned errno) d = Some d' ->
                                             high_level_invariant d ->
                                             exists le',
                                               exec_stmt ge env le ((m, d): mem) uctx_set_errno_body E0 le' (m, d') Out_normal.
        Proof.
          generalize max_unsigned_val; intro muval.
          intros.
          assert(cid_range: 0 <= cid d < 64) by (destruct H2; assumption).
          unfold uctx_set_errno_body.
          functional inversion H1; subst.
          assert(ipt: ipt d = true).
            destruct H2.
            rewrite <- valid_ikern_ipt.
            assumption.
          esplit.
          repeat vcgen.
          unfold get_curid_spec.
          rewrite H4, H5, H6.
          rewrite Int.unsigned_repr.
          reflexivity.
          omega.
          unfold uctx_set_spec.
          rewrite H4, H5, H6, ipt.
          unfold is_UCTXT_ptr.
          rewrite zle_lt_true.
          reflexivity.
          omega.
          omega.
          omega.
        Qed.

      End UctxSetErronoBody.

      Theorem uctx_set_errno_code_correct:
        spec_le (uctx_set_errno ↦ uctx_set_errno_spec_low) (〚uctx_set_errno ↦ f_uctx_set_errno 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (uctx_set_errno_body_correct s (Genv.globalenv p) makeglobalenv b0 Hb0fs Hb0fp b1 Hb1fs Hb1fp m'0 labd labd' (PTree.empty _)
                                        (bind_parameter_temps' (fn_params f_uctx_set_errno)
                                                               (Vint arg::nil)
                                                               (create_undef_temps (fn_temps f_uctx_set_errno)))) H0.
      Qed.

    End UCTXSETERRNO.

    Section UCTXSETRETVAL1.

      Let L: compatlayer (cdata RData) := get_curid ↦ gensem get_curid_spec
           ⊕ uctx_set ↦ gensem uctx_set_spec.

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

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

      Section UctxSetRetval1Body.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

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

        (** get_curid *)

        Variable bget_curid: block.

        Hypothesis hget_curid1 : Genv.find_symbol ge get_curid = Some bget_curid.

        Hypothesis hget_curid2 : Genv.find_funct_ptr ge bget_curid = Some (External (EF_external get_curid (signature_of_type Tnil tint cc_default)) Tnil tint cc_default).

        (** uctx_set *)

        Variable buctx_set: block.

        Hypothesis huctx_set1 : Genv.find_symbol ge uctx_set = Some buctx_set.

        Hypothesis huctx_set2 : Genv.find_funct_ptr ge buctx_set = Some (External (EF_external uctx_set (signature_of_type (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default)) (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default).

        Lemma uctx_set_retval1_body_correct: forall m d d' env le retval,
                                               env = PTree.empty _ ->
                                               PTree.get tretval le = Some (Vint retval) ->
                                               uctx_set_retval1_spec (Int.unsigned retval) d = Some d' ->
                                               high_level_invariant d ->
                                               exists le',
                                                 exec_stmt ge env le ((m, d): mem) uctx_set_retval1_body E0 le' (m, d') Out_normal.
        Proof.
          generalize max_unsigned_val; intro muval.
          intros.
          assert(cid_range: 0 <= cid d < 64) by (destruct H2; assumption).
          unfold uctx_set_retval1_body.
          functional inversion H1; subst.
          assert(ipt: ipt d = true).
            destruct H2.
            rewrite <- valid_ikern_ipt.
            assumption.
          esplit.
          repeat vcgen.
          unfold get_curid_spec.
          rewrite H4, H5, H6.
          rewrite Int.unsigned_repr.
          reflexivity.
          omega.
          unfold uctx_set_spec.
          rewrite H4, H5, H6, ipt.
          unfold is_UCTXT_ptr.
          rewrite zle_lt_true.
          reflexivity.
          omega.
          omega.
          omega.
        Qed.

      End UctxSetRetval1Body.

      Theorem uctx_set_retval1_code_correct:
        spec_le (uctx_set_retval1 ↦ uctx_set_retval1_spec_low) (〚uctx_set_retval1 ↦ f_uctx_set_retval1 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (uctx_set_retval1_body_correct s (Genv.globalenv p) makeglobalenv b0 Hb0fs Hb0fp b1 Hb1fs Hb1fp m'0 labd labd' (PTree.empty _)
                                        (bind_parameter_temps' (fn_params f_uctx_set_retval1)
                                                               (Vint arg::nil)
                                                               (create_undef_temps (fn_temps f_uctx_set_retval1)))) H0.
      Qed.

    End UCTXSETRETVAL1.

    Section UCTXSETRETVAL2.

      Let L: compatlayer (cdata RData) := get_curid ↦ gensem get_curid_spec
           ⊕ uctx_set ↦ gensem uctx_set_spec.

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

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

      Section UctxSetRetval2Body.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

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

        (** get_curid *)

        Variable bget_curid: block.

        Hypothesis hget_curid1 : Genv.find_symbol ge get_curid = Some bget_curid.

        Hypothesis hget_curid2 : Genv.find_funct_ptr ge bget_curid = Some (External (EF_external get_curid (signature_of_type Tnil tint cc_default)) Tnil tint cc_default).

        (** uctx_set *)

        Variable buctx_set: block.

        Hypothesis huctx_set1 : Genv.find_symbol ge uctx_set = Some buctx_set.

        Hypothesis huctx_set2 : Genv.find_funct_ptr ge buctx_set = Some (External (EF_external uctx_set (signature_of_type (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default)) (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default).

        Lemma uctx_set_retval2_body_correct: forall m d d' env le retval,
                                               env = PTree.empty _ ->
                                               PTree.get tretval le = Some (Vint retval) ->
                                               uctx_set_retval2_spec (Int.unsigned retval) d = Some d' ->
                                               high_level_invariant d ->
                                               exists le',
                                                 exec_stmt ge env le ((m, d): mem) uctx_set_retval2_body E0 le' (m, d') Out_normal.
        Proof.
          generalize max_unsigned_val; intro muval.
          intros.
          assert(cid_range: 0 <= cid d < 64) by (destruct H2; assumption).
          unfold uctx_set_retval2_body.
          functional inversion H1; subst.
          assert(ipt: ipt d = true).
            destruct H2.
            rewrite <- valid_ikern_ipt.
            assumption.
          esplit.
          repeat vcgen.
          unfold get_curid_spec.
          rewrite H4, H5, H6.
          rewrite Int.unsigned_repr.
          reflexivity.
          omega.
          unfold uctx_set_spec.
          rewrite H4, H5, H6, ipt.
          unfold is_UCTXT_ptr.
          rewrite zle_lt_true.
          reflexivity.
          omega.
          omega.
          omega.
        Qed.

      End UctxSetRetval2Body.

      Theorem uctx_set_retval2_code_correct:
        spec_le (uctx_set_retval2 ↦ uctx_set_retval2_spec_low) (〚uctx_set_retval2 ↦ f_uctx_set_retval2 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (uctx_set_retval2_body_correct s (Genv.globalenv p) makeglobalenv b0 Hb0fs Hb0fp b1 Hb1fs Hb1fp m'0 labd labd' (PTree.empty _)
                                        (bind_parameter_temps' (fn_params f_uctx_set_retval1)
                                                               (Vint arg::nil)
                                                               (create_undef_temps (fn_temps f_uctx_set_retval2)))) H0.
      Qed.

    End UCTXSETRETVAL2.

    Section UCTXSETRETVAL3.

      Let L: compatlayer (cdata RData) := get_curid ↦ gensem get_curid_spec
           ⊕ uctx_set ↦ gensem uctx_set_spec.

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

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

      Section UctxSetRetval3Body.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

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

        (** get_curid *)

        Variable bget_curid: block.

        Hypothesis hget_curid1 : Genv.find_symbol ge get_curid = Some bget_curid.

        Hypothesis hget_curid2 : Genv.find_funct_ptr ge bget_curid = Some (External (EF_external get_curid (signature_of_type Tnil tint cc_default)) Tnil tint cc_default).

        (** uctx_set *)

        Variable buctx_set: block.

        Hypothesis huctx_set1 : Genv.find_symbol ge uctx_set = Some buctx_set.

        Hypothesis huctx_set2 : Genv.find_funct_ptr ge buctx_set = Some (External (EF_external uctx_set (signature_of_type (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default)) (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default).

        Lemma uctx_set_retval3_body_correct: forall m d d' env le retval,
                                               env = PTree.empty _ ->
                                               PTree.get tretval le = Some (Vint retval) ->
                                               uctx_set_retval3_spec (Int.unsigned retval) d = Some d' ->
                                               high_level_invariant d ->
                                               exists le',
                                                 exec_stmt ge env le ((m, d): mem) uctx_set_retval3_body E0 le' (m, d') Out_normal.
        Proof.
          generalize max_unsigned_val; intro muval.
          intros.
          assert(cid_range: 0 <= cid d < 64) by (destruct H2; assumption).
          unfold uctx_set_retval3_body.
          functional inversion H1; subst.
          assert(ipt: ipt d = true).
            destruct H2.
            rewrite <- valid_ikern_ipt.
            assumption.
          esplit.
          repeat vcgen.
          unfold get_curid_spec.
          rewrite H4, H5, H6.
          rewrite Int.unsigned_repr.
          reflexivity.
          omega.
          unfold uctx_set_spec.
          rewrite H4, H5, H6, ipt.
          unfold is_UCTXT_ptr.
          rewrite zle_lt_true.
          reflexivity.
          omega.
          omega.
          omega.
        Qed.

      End UctxSetRetval3Body.

      Theorem uctx_set_retval3_code_correct:
        spec_le (uctx_set_retval3 ↦ uctx_set_retval3_spec_low) (〚uctx_set_retval3 ↦ f_uctx_set_retval3 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (uctx_set_retval3_body_correct s (Genv.globalenv p) makeglobalenv b0 Hb0fs Hb0fp b1 Hb1fs Hb1fp m'0 labd labd' (PTree.empty _)
                                        (bind_parameter_temps' (fn_params f_uctx_set_retval1)
                                                               (Vint arg::nil)
                                                               (create_undef_temps (fn_temps f_uctx_set_retval3)))) H0.
      Qed.

    End UCTXSETRETVAL3.

    Section UCTXSETRETVAL4.

      Let L: compatlayer (cdata RData) := get_curid ↦ gensem get_curid_spec
           ⊕ uctx_set ↦ gensem uctx_set_spec.

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

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

      Section UctxSetRetval4Body.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

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

        (** get_curid *)

        Variable bget_curid: block.

        Hypothesis hget_curid1 : Genv.find_symbol ge get_curid = Some bget_curid.

        Hypothesis hget_curid2 : Genv.find_funct_ptr ge bget_curid = Some (External (EF_external get_curid (signature_of_type Tnil tint cc_default)) Tnil tint cc_default).

        (** uctx_set *)

        Variable buctx_set: block.

        Hypothesis huctx_set1 : Genv.find_symbol ge uctx_set = Some buctx_set.

        Hypothesis huctx_set2 : Genv.find_funct_ptr ge buctx_set = Some (External (EF_external uctx_set (signature_of_type (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default)) (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default).

        Lemma uctx_set_retval4_body_correct: forall m d d' env le retval,
                                               env = PTree.empty _ ->
                                               PTree.get tretval le = Some (Vint retval) ->
                                               uctx_set_retval4_spec (Int.unsigned retval) d = Some d' ->
                                               high_level_invariant d ->
                                               exists le',
                                                 exec_stmt ge env le ((m, d): mem) uctx_set_retval4_body E0 le' (m, d') Out_normal.
        Proof.
          generalize max_unsigned_val; intro muval.
          intros.
          assert(cid_range: 0 <= cid d < 64) by (destruct H2; assumption).
          unfold uctx_set_retval4_body.
          functional inversion H1; subst.
          assert(ipt: ipt d = true).
            destruct H2.
            rewrite <- valid_ikern_ipt.
            assumption.
          esplit.
          repeat vcgen.
          unfold get_curid_spec.
          rewrite H4, H5, H6.
          rewrite Int.unsigned_repr.
          reflexivity.
          omega.
          unfold uctx_set_spec.
          rewrite H4, H5, H6, ipt.
          unfold is_UCTXT_ptr.
          rewrite zle_lt_true.
          unfold uctx'.
          unfold uctx.
          repeat rewrite Int.unsigned_repr.
          reflexivity.
          omega.
          rewrite Int.unsigned_repr.
          omega.
          omega.
        Qed.

      End UctxSetRetval4Body.

      Theorem uctx_set_retval4_code_correct:
        spec_le (uctx_set_retval4 ↦ uctx_set_retval4_spec_low) (〚uctx_set_retval4 ↦ f_uctx_set_retval4 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (uctx_set_retval4_body_correct s (Genv.globalenv p) makeglobalenv b0 Hb0fs Hb0fp b1 Hb1fs Hb1fp m'0 labd labd' (PTree.empty _)
                                        (bind_parameter_temps' (fn_params f_uctx_set_retval1)
                                                               (Vint arg::nil)
                                                               (create_undef_temps (fn_temps f_uctx_set_retval4)))) H0.
      Qed.

    End UCTXSETRETVAL4.

  End WithPrimitives.

End PPROCCODE.


Require Import Coq.Program.Equality.
Require Import Coq.Sets.Ensembles.
Require Import Coq.FSets.FMapAVL.
Require Import Coq.Structures.OrderedTypeEx.
Require Import Coq.Arith.Peano_dec.
Require Import Ascii String.
Require Import Coq.Arith.EqNat.
Require Import Coq.Arith.Mult.
Require Import Coq.Arith.Plus.
Require Import Coq.Arith.Minus.
Require Import Coq.Lists.List.
Require Import Coq.Arith.Compare_dec.

Add LoadPath "." as Top0.
Require Import Top0.Keys.
Require Import Top0.Heap.
Require Import Top0.Tactics.
Require Import Top0.Environment.
Require Import Top0.Definitions.
Require Import Top0.CorrectnessLemmas.
Require Import Top0.AdditionalLemmas.
Require Import Top0.Determinism.
Require Import Top0.TypeSystem.
Require Import Top0.EffectSystem.
Require Import Top0.Axioms.

Import EffectSoundness.
Import TypeSoundness.

Lemma DeterminismReadOnlyCond:
  forall h env rho e b1 b2 h' cheap cacts,
    (h, env, rho, e) ⇓ (h', Bit b1, Phi_Nil) ->
    (h, env, rho, e) ⇓ (cheap, Bit b2, cacts) ->
    H.Equal h' cheap /\ Bit b1 = Bit b2 /\  Phi_Nil = cacts.
Proof.
  intros.
  generalize dependent cacts.
  generalize dependent cheap.
  generalize dependent b2.
  dependent induction H; intros;
  inversion H0; subst; intuition.
  rewrite H in H2. inversion H2; subst. auto.
Qed.

Axiom RewritePhiR:
  forall acts, Phi_Seq Phi_Nil acts = acts.

Lemma EvalTrueIsTrue:
  forall h h' h'' env rho e efft efff eff tacts,
  (h, env, rho, Cond e efft efff) ⇓ (h'', Eff eff, tacts) ->
  (h, env, rho, e) ⇓ (h', Bit true, Phi_Nil) ->
  (h', env, rho, efft) ⇓ (h'', Eff eff, tacts).
Proof.
  intros.
  inversion H; subst.
  - assert ( Hbit : H.Equal h' cheap /\ Bit true = Bit true /\  Phi_Nil = cacts )
     by (eapply DeterminismReadOnlyCond; eauto).
    assert ( HD :h = h') by (eapply EmptyTracePreservesHeap_1; eauto).
    destruct Hbit as [? [H_ ?]]; inversion H_; subst.
    assert ( HD :h' = cheap) by (eapply EmptyTracePreservesHeap_1; eauto).
    assert (Phi_Seq Phi_Nil tacts0 = tacts0) by (rewrite RewritePhiR; auto). rewrite H2.
    rewrite HD.
    assumption.
  - assert ( Hbit : H.Equal h' cheap /\ Bit true = Bit false /\  Phi_Nil = cacts )
      by (eapply DeterminismReadOnlyCond; eauto;
          assert ( HD :h = h') by (eapply EmptyTracePreservesHeap_1; eauto);
          apply HMapP.Equal_refl).
     destruct Hbit as [? [H_ ?]]; inversion H_; subst.
Qed.

Lemma EvalFalseIsFalse:
forall h h' h'' env rho e efft efff eff tacts,
  (h, env, rho, Cond e efft efff) ⇓ (h'', Eff eff, tacts) ->
  (h, env, rho, e) ⇓ (h', Bit false, Phi_Nil) ->
  (h', env, rho, efff) ⇓ (h'', Eff eff, tacts).
intros.
  inversion H; subst.
  - assert ( Hbit : H.Equal h' cheap /\ Bit false = Bit true /\  Phi_Nil = cacts )
      by (eapply DeterminismReadOnlyCond; eauto;
          assert ( HD :h = h') by (eapply EmptyTracePreservesHeap_1; eauto);
          apply HMapP.Equal_refl).
     destruct Hbit as [? [H_ ?]]; inversion H_; subst.
  - assert ( Hbit : H.Equal h' cheap /\ Bit false = Bit false /\  Phi_Nil = cacts )
     by (eapply DeterminismReadOnlyCond; eauto).
    assert ( HD :h = h') by (eapply EmptyTracePreservesHeap_1; eauto).
    destruct Hbit as [? [H_ ?]]; inversion H_; subst.
    assert ( HD :h' = cheap) by (eapply EmptyTracePreservesHeap_1; eauto).
    assert (Phi_Seq Phi_Nil facts = facts) by (rewrite RewritePhiR; auto). rewrite H2.
    rewrite HD.
    assumption.
Qed.

Lemma DeterminismReadOnlyRefs :
  forall h env rho ea0 h'' h' r1 l0 r l aacts,
  (h, env, rho, ea0) ⇓ (h'', Loc (Rgn2_Const true false r1) l0, Phi_Nil) ->
  (h, env, rho, ea0) ⇓ (h', Loc (Rgn2_Const true false r) l, aacts) ->
  H.Equal h'' h' /\ Loc (Rgn2_Const true false r1) l0 = Loc (Rgn2_Const true false r) l /\ Phi_Nil = aacts.
Proof.
  intros.
  generalize dependent aacts.
  generalize dependent r.
  generalize dependent l.
  generalize dependent h'.
  dependent induction H.
  intros. inversion H0; subst. rewrite H2 in H. inversion H; subst. intuition.
Qed.

Theorem Correctness_soundness_ext :
  forall h h' h'' env rho  p p' v eff stty ctxt rgns ea ee,
    (h, env, rho, ea) ⇓ (h', v, p) ->
    forall h_ h'_ v_ p_,
      H.Equal h h_ ->
      (h_, env, rho, ea) ⇓ (h'_, v_, p_) ->
      (h, env, rho, ee) ⇓ (h'', Eff eff, p') ->
    BackTriangle (ctxt, rgns, rho, ea, ee) ->
    forall static ty,
      ReadOnlyPhi p' ->
      TcHeap (h, stty) ->
      TcRho (rho, rgns) ->
      TcEnv (stty, rho, env, ctxt) ->
      TcExp (ctxt, rgns, ea, ty, static) ->
      p ⊑ eff.
Proof.
  intros h  h'  h'' env rho p  p' v  eff stty ctxt rgns ea ee BS1.
  generalize dependent p'.
  generalize dependent ee.
  generalize dependent stty.
  generalize dependent ctxt.
  generalize dependent rgns.
  generalize dependent eff.
  generalize dependent h''.
  dynamic_cases (dependent induction BS1) Case;
  intros h'' eff rgns ctxt stty ee_exp p';
  intros h_ h'_ v_ p_ HEqual BS2;
  intros HEff HBt static ty HRonly HHeap HRho HEnv HExp;
  try (solve [assert (Phi_Nil ⊑ eff) by (constructor); inversion BS2; subst; intuition]).
  Case "mu_app".
    inversion HExp as  [ | | | | |
                         ? ? ? ? ? ? ? ? ? ? ? HExp_ef HExp_ea
                         | | | | | | | | | | | | | | | | | | | ]; subst.
    assert (clsTcVal : exists stty',
                         (forall l t', ST.find l stty = Some t' -> ST.find l stty' = Some t')
                         /\ TcHeap (fheap, stty')
                         /\ TcVal (stty',
                                   Cls (env', rho', Mu f x ec' ee'),
                                   subst_rho rho (Ty2_Arrow tya effc ty effe Ty2_Effect)))
      by (eapply ty_sound; eauto).
    destruct clsTcVal as [sttyb [Weakb [TcHeapb TcVal_cls]]]; eauto.

    assert (argTcVal : exists stty',
                         (forall l t', ST.find l sttyb = Some t' -> ST.find l stty' = Some t')
                         /\ TcHeap (aheap, stty')
                         /\ TcVal (stty', v0, subst_rho rho tya))
        by (eapply ty_sound; eauto using update_env, ext_stores__env).
    destruct argTcVal as [sttya [Weaka [TcHeapa TcVal_v']]]; eauto.

    inversion TcVal_cls as [ | | |
                             ? ? ? ? ? ? ?  TcRho_rho' TcInc' TcEnv_env' TcExp_abs [A B C D HSubst]
                             | | |]; subst.
    inversion TcExp_abs as [ | | |
                             ? ? ? ? ? ? ? ? ? ? ? HBt_ec_ee TcExp_ec' TcExp_ee'
                             | | | | | | | | | | | | | | | | | | | | |]; subst.
    rewrite <- HSubst in TcVal_cls.
    do 2 rewrite subst_rho_arrow in HSubst.
    inversion HSubst as [[H_tyx_tya A C D E]]; clear A C D E.
    rewrite <- H_tyx_tya in TcVal_v'.

    (* goal *)
    assert (HSOUND : Phi_Seq (Phi_Seq facts aacts) bacts ⊑ eff).

    { apply PTS_Seq.
      SCase "Phi_Seq facts aacts ⊑ eff".
        apply PTS_Seq.
        SSCase "facts ⊑ eff".
          assert (H_ : facts  ⊑ eff).
          {
            inversion HBt as [ | | | |
                               | ? ? ? ? ? ? ? ? ? ?  TcExp_ef TcExp_ea HBt_ef HBt_ea HR_ef HR_ea
                               | | | | | | | | | | | | | ]; subst.
            SSSCase "Mu_App ef ea0 << (efff0 ⊕ (effa0 ⊕ Eff_App ef ea0))".
              inversion HEff; subst.
              assert (facts  ⊑ eff).
              { eapply IHBS1_1 with (h_:=h'') (p_:=facts); eauto.
                - apply HFacts.Equal_refl. }
              assumption.
            SSSCase "Mu_App ef ea0 << (⊤)".
              inversion HEff; subst.
              apply PhiInThetaTop.
          }
          exact H_.
        SSCase " aacts ⊑ eff".
          inversion HBt as [ | | | |
                             | ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ?  TcExp_ef TcExp_ea HBt_ef HBt_ea HR_ef HR_ea
                             | | | | | | | | | | | | | ]; subst.
          SSSCase "Mu_App ef ea0 << Eff_App ef ea0".
            assert (H_ : aacts  ⊑ eff).
            { eapply ReadOnlyStaticImpliesReadOnlyPhi with (phi:=facts) in HR_ef.
              - apply ReadOnlyTracePreservesHeap_1 in BS1_1.
                + symmetry in BS1_1.
                  inversion HEff; subst.
                  assert (aacts  ⊑ eff).
                  eapply IHBS1_2 with (h_:=h'') (p_:=aacts); eauto.
                  * apply HFacts.Equal_refl.
                  * assumption.
                + assumption.
              - assert (facts_Eff : Epsilon_Phi_Soundness (fold_subst_eps rho static_ef, facts)) by
                    (eapply eff_sound; eauto).
                eassumption. }
            exact H_.
            SSSCase "Mu_App ef ea0 << (⊤)".
              assert (H_ : aacts  ⊑ eff).
              { induction eff; inversion HEff; subst.
                apply PhiInThetaTop. }
              exact H_.
      SCase "bacts ⊑ eff".
        inversion HEff; subst;
        inversion HBt as [ | | | |
                           | ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ?  TcExp_ef TcExp_ea HBt_ef HBt_ea HR_ef HR_ea
                           | | | | | | | | | | | | | ]; subst.
        SSSCase "Mu_App ef ea0 << Eff_App ef ea0".
          assert (HD3 : bacts  ⊑ eff).
          { eapply IHBS1_3
            with (stty:=sttya) (p':=bacts0); eauto using HFacts.Equal_refl.
            - eapply EvaluationEffectFromEffApp; eauto.
            - inversion HRonly as [ | | ? ? A B | ]. exact B.
            - { apply update_env; simpl.
                - eapply ext_stores__env; eauto.
                  apply update_env.
                  + eassumption.
                  + eapply ext_stores__val with (stty:=sttyb); eauto.
                - eapply ext_stores__val with (stty:=sttya); eauto. }
          }
          exact HD3.
        SSSCase "Mu_App ef ea0 << (⊤)".
          assert (H_ : bacts ⊑ None).
          { eapply IHBS1_3
            with (stty:=sttya) (ee:=⊤); eauto.
            SSSSCase "Equal Heaps".
              apply HFacts.Equal_refl.
            SSSSCase "Effect Evaluation".
              econstructor.
            SSSSCase "Back Triangle".
              econstructor.
            SSSSCase "Extended TcEnv".
              { apply update_env; simpl.
                - eapply ext_stores__env; eauto.
                  apply update_env.
                  + eassumption.
                  + eapply ext_stores__val with (stty:=sttyb); eauto.
                - eapply ext_stores__val with (stty:=sttya); eauto. }
              }
          exact H_. }
    exact HSOUND.
   Case "rgn_app".
     inversion HExp as  [ | | | | |
                          | ? ? ? ? ? ? ?  HTcExp_er HTcRgn_w
                          | | | | | | | | | | | | | | | | | |]; subst.
     assert (clsTcVal : exists stty',
                          (forall l t', ST.find l stty = Some t' -> ST.find l stty' = Some t')
                          /\ TcHeap (fheap, stty')
                          /\ TcVal (stty', Cls (env', rho', Lambda x eb),
                                    subst_rho rho (Ty2_ForallRgn effr tyr))).
     eapply ty_sound;eauto.
     destruct clsTcVal as [sttyb [Weakb [TcHeapb TcVal_cls]]]; eauto.

     inversion TcVal_cls as [ | | |
                              ? ? ? ? ? ? ? TcRho_rho' TcInc' TcEnv_env' TcExp_abs [A B C D HSubst]
                              | | |]; subst.
     inversion TcExp_abs as [ | | | |
                              ? ? ? ? ? ?  HNo HLc1 HLc2 HBt_eb HTExp_eb
                              | | | | | | | | | | | | | | | | | | | |]; subst.
     rewrite <- HSubst in TcVal_cls.
     do 2 rewrite subst_rho_forallrgn in HSubst.
     inversion HSubst as [[H_fold A]]; clear A.

     (* goal *)
     assert (HSOUND : Phi_Seq facts bacts ⊑ eff).
     {apply PTS_Seq.
      SCase "facts ⊑ eff".
        eapply IHBS1_1 with (h_:=h); eauto. apply HFacts.Equal_refl.
        inversion HBt; subst; eauto.
        econstructor; eauto.
      SCase " bacts ⊑ eff".
        inversion HBt; subst.
        SSCase "Rgn_App er w << (∅)".
          { eapply IHBS1_2 with (ee:=∅); eauto.
            - inversion HEff; subst. econstructor.
            - inversion HEff; subst. econstructor.
            - apply update_rho; auto.
            - eapply extended_rho; eauto. }
        SSCase "Rgn_App er w << (⊤)".
          { eapply IHBS1_2 with (ee:=⊤); eauto using update_rho, extended_rho;
            induction eff;
            try (solve [ apply HFacts.Equal_refl | constructor ]); inversion HEff.
            subst. econstructor.
          }
     }
     exact HSOUND.
  Case "eff_app".
    inversion HExp as  [ | | | | | | |
                         ? ? ? ? ? ? ? ? ? ? HExp_ef HExp_ea
                         | | | | | | | | | | | | | | | | | ]; subst.
    assert (clsTcVal : exists stty',
                         (forall l t', ST.find l stty = Some t' -> ST.find l stty' = Some t')
                         /\ TcHeap (h', stty')
                         /\ TcVal (stty',
                                   Cls (env', rho', Mu f x ec' ee'),
                                   subst_rho rho (Ty2_Arrow tya effc tyc  effe Ty2_Effect)))
      by (eapply ty_sound; eauto).
    destruct clsTcVal as [sttyb [Weakb [TcHeapb TcVal_cls]]]; eauto.

    assert (argTcVal : exists stty',
                         (forall l t', ST.find l sttyb = Some t' -> ST.find l stty' = Some t')
                         /\ TcHeap (h', stty')
                         /\ TcVal (stty', v', subst_rho rho tya))
      by (eapply ty_sound; eauto using update_env, ext_stores__env).
    destruct argTcVal as [sttya [Weaka [TcHeapa TcVal_v']]]; eauto.

    inversion TcVal_cls as [ | | |
                             ? ? ? ? ? ? ? TcRho_rho' TcInc' TcEnv_env' TcExp_abs [A B C D HSubst]
                             | | |]; subst.
    inversion TcExp_abs as [ | | |
                             ? ? ? ? ? ? ? ? ? ? HBt_ec_ee TcExp_ec' TcExp_ee'
                             | | | | | | | | | | | | | | | | | | | | |]; subst.
    rewrite <- HSubst in TcVal_cls.
    do 2 rewrite subst_rho_arrow in HSubst.
    inversion HSubst as [[H_tyx_tya A C D E]]; clear A C D E.
    rewrite <- H_tyx_tya in TcVal_v'.

    (* goal *)
    assert (HSOUND : Phi_Seq (Phi_Seq facts aacts) bacts ⊑ eff).

    { inversion HBt; subst.
      apply PTS_Seq.
      - apply PTS_Seq.
        + inversion HEff; subst.
          apply PhiInThetaTop.
        +  inversion HEff; subst.
           apply PhiInThetaTop.
      - inversion HEff; subst.
        apply PhiInThetaTop. }
    exact HSOUND.
  Case "par_pair".
    inversion HBt as [ | | | | |
                       | ? ? ? ? ? ? ? ? ? ? ? ? ? ? A B C D HBt_a HBt_b HBt_c HBt_d
                       | | | | | | | | | | | |]; subst;
    inversion HEff; subst; [ | apply PhiInThetaTop].
    inversion HExp as  [ | | | | | ? ? ? ? ? ? ? ? ? ? HExp_ef HExp_ea
                               | | |
                               ? ? ? ? ? ? ? ? ? ? ? ?  HBt_1 HBt_2 HExp_mu1 HExp_mu2 HExp_eff1 HExp_eff2
                               | | | | | | | | | | | | | | | | ]; subst.
    inversion HEff; subst. inversion H4; subst.  inversion H12; subst.

    assert (H' : acts_eff1 ⊑ effa1).
    { eapply IHBS1_1 with (h_:=h''); eauto using HFacts.Equal_refl.
      inversion HRonly as [ | | ? ? X Y | ]; inversion X; inversion Y; assumption. }
    assert (H'' : acts_eff2 ⊑ effb1).
    { eapply IHBS1_2 with (h_:=h''); eauto using HFacts.Equal_refl.
      inversion HRonly as [ | | ? ? X Y | ]; inversion X; inversion Y; assumption. }
    assert (H''' : acts_mu1 ⊑ effa0).
    { eapply IHBS1_3 with (h_:=h''); eauto using HFacts.Equal_refl.
      inversion HRonly as [ | | ? ? X Y | ]; inversion X; inversion Y; assumption. }
    assert (H'''' : acts_mu2 ⊑ effb2).
    { eapply IHBS1_4  with (h_:=h''); eauto using HFacts.Equal_refl.
      inversion HRonly as [ | | ? ? X Y | ]; inversion X; inversion Y; assumption. }

    assert (H_ : (Phi_Par acts_eff1 acts_eff2) ⊑ (Union_Theta effa1 effb1)).
    apply PTS_Par; [ apply Theta_introl | apply Theta_intror ]; eauto.

    assert (H__ : (Phi_Par acts_mu1 acts_mu2) ⊑ (Union_Theta effa0 effb2)).
    apply PTS_Par; [ apply Theta_introl | apply Theta_intror ]; eauto.

    assert (_H__ :  ReadOnlyPhi acts_eff1).
    { eapply ReadOnlyStaticImpliesReadOnlyPhi with (phi:= acts_eff1) in B; auto.
      assert (facts_Eff : Epsilon_Phi_Soundness (fold_subst_eps rho static_ee_1, acts_eff1)) by
          (eapply eff_sound; eauto).
      assumption. }

    assert (_H_ : acts_mu1 ⊑ theta1).
    { induction theta1; [| apply PhiInThetaTop].
      eapply IHBS1_3 with (h_:=h''); eauto using HFacts.Equal_refl.
      inversion HExp_mu1; subst. auto.
    }

    assert (_H____ :  ReadOnlyPhi acts_eff2).
    { eapply ReadOnlyStaticImpliesReadOnlyPhi with (phi:= acts_eff2) in D; auto.
      assert (facts_Eff : Epsilon_Phi_Soundness (fold_subst_eps rho static_ee_2, acts_eff2)) by
          (eapply eff_sound; eauto).
      assumption. }

    assert (_H___ : acts_mu2 ⊑ theta2).
    { induction theta2; [| apply PhiInThetaTop].
      eapply IHBS1_4 with (h_:=h''); eauto using HFacts.Equal_refl.
      inversion HExp_mu2; subst. auto.
    }
    apply PTS_Seq.
    apply Theta_introl. assumption.
    apply Theta_intror. assumption.
  Case "cond_true".
    (* goal *)
    assert (HSOUND :  Phi_Seq cacts tacts ⊑ eff).
    { inversion HBt as [ | | | | | | |
                       | ? ? ? ? ? ? ? ? ? ? ? ? ? ? ?
                           TcExp_e TcExp_et TcExp_ef HBt_e HBt_et HBt_ef
                       | | | | | | | | | | ]; subst.
      - assert (H' : cacts ⊑ Some empty_set).
        { eapply IHBS1_1 with (h_:=h) (p':=Phi_Nil); eauto.
          - apply HFacts.Equal_refl.
          - constructor.
          - constructor. }

        apply EmptyUnionIsIdentity.
        apply EmptyIsNil in H'. subst.
        apply PTS_Seq; [apply PTS_Nil |].

        assert (HEq_1 :  cheap = h).
        { apply ReadOnlyTracePreservesHeap_1 in BS1_1. symmetry in BS1_1.
          assumption.
          constructor. }
        rewrite UnionEmptyWithEffIsEff.

        { eapply IHBS1_2 with (ee:=efft)  (h_:=h) ; eauto.
          - apply Equal_heap_equal. auto.
          - subst. eassumption.
          - eapply EvalTrueIsTrue; eauto.
          - subst. assumption. }
      -  inversion HEff; subst.
         apply PhiInThetaTop.
    }
    exact HSOUND.
  Case "cond_false".
    (* goal *)
    assert (HSOUND :  Phi_Seq cacts facts ⊑ eff).
    { inversion HBt as [ | | | | | | |
                       | ? ? ? ? ? ? ? ? ? ? ? ? ? ? ?
                           TcExp_e TcExp_et TcExp_ef HBt_e HBt_et HBt_ef
                       | | | | | | | | | |]; subst.
      - assert (H' : cacts ⊑ Some empty_set).
        { eapply IHBS1_1 with (h_:=h) (p':=Phi_Nil); eauto.
          - apply HFacts.Equal_refl.
          - constructor.
          - constructor. }

        apply EmptyUnionIsIdentity.
        apply EmptyIsNil in H'. subst.
        apply PTS_Seq; [apply PTS_Nil |].

        assert (HEq_1 :  cheap = h).
        { apply ReadOnlyTracePreservesHeap_1 in BS1_1. symmetry in BS1_1.
          assumption.
          constructor. }
        rewrite UnionEmptyWithEffIsEff.

        { eapply IHBS1_2 with (ee:=efff)  (h_:=h) ; eauto.
          - apply Equal_heap_equal. auto.
          - subst. eassumption.
          - eapply EvalFalseIsFalse; eauto.
          - subst. assumption. }
      -  inversion HEff; subst.
         apply PhiInThetaTop.
    }
    exact HSOUND.
  Case "new_ref e".
    (* goal *)
    assert (HSOUND : Phi_Seq vacts (Phi_Elem (DA_Alloc r (allocate_H heap' r) v0)) ⊑ eff).
    { inversion HEff; subst;
      inversion HBt as [ | | | | | |
                         | | | ? ?  ? ? ? ? ? ? TcExp_e HBt_e
                         | | | | | | | | | ]; subst.
      apply EnsembleUnionComp.
      SCase "Ref w e << (a ⊕ AllocAbs w)".
        eapply IHBS1 with (h_:=h''); eauto using HFacts.Equal_refl.
        inversion HRonly; assumption.
        inversion H8; subst.
        apply PTS_Elem. apply DAT_Alloc_Abs.
        rewrite H in H1. inversion H1.
        apply In_singleton.
      SCase "Ref w e << (⊤)".
        apply PhiInThetaTop.
    }
    exact HSOUND.
  Case "get_ref e".
    (* goal *)
    assert (HSOUND : Phi_Seq aacts (Phi_Elem (DA_Read r l v)) ⊑ eff ).
    { inversion HBt as [ | | | | | | |
                       | ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? TcExp_e TcExp_et TcExp_ef HBt_e HBt_et HBt_ef |
                       | ? ? ? ? ? ? ? ? TcExp_ea0 HBt_ea0 |
                       | | | | | | | ]; subst.
      - inversion HEff; subst.
        apply EnsembleUnionComp.
        + eapply IHBS1 with (h_:=h''); eauto using HFacts.Equal_refl.
          inversion HRonly; subst. assumption.
        + apply PTS_Elem. inversion H10; subst.
          rewrite H in H2; inversion H2.
          apply DAT_Read_Abs. apply In_singleton.
      - inversion HEff; subst.
        assert (aacts ⊑ Some empty_set).
        eapply IHBS1 with (h_:=h); eauto using HFacts.Equal_refl; constructor.
        apply PTS_Seq.
        + apply EmptyInAnyTheta. assumption.
        + apply PTS_Elem.
          simpl in H; inversion H; subst.
          apply DAT_Read_Conc.
          assert (HD: H.Equal h'' h' /\
                      Loc (Rgn2_Const true false r1) l0 = Loc (Rgn2_Const true false r) l /\
                      Phi_Nil = aacts).
          eapply DeterminismReadOnlyRefs; eauto.
          destruct HD as [? [H_ ?]]; inversion H_; subst.
          apply In_singleton.
      - econstructor; inversion HEff; subst; apply PhiInThetaTop.
    }
    exact HSOUND.
  Case "set_ref e1 e2".
    (* goal *)
    assert (HSOUND : Phi_Seq (Phi_Seq aacts vacts) (Phi_Elem (DA_Write r l v0)) ⊑ eff ).
    { inversion HBt as [| | | | | | | | | | |
                      | ? ? ? ? ? ? ? ? ? ? HBt_ea0 HBt_ev TcExp_ea0 HR
                      | ? ? ? ? ? ? ? ? ? ? HBt_ea0 HBt_ev TcExp_ea0 HR
                      | | | | | ]; subst.
      SCase "Assign w ea0 ev << (eff1 ⊕ (eff2 ⊕ WriteAbs w))".
        inversion HEff; subst.
        apply PTS_Seq.
        SSCase "Phi_Seq aacts vacts ⊑ Union_Theta effa effb".
          apply EnsembleUnionComp.
          SSSCase "aacts ⊑ effa".
            inversion HExp; subst.
            eapply IHBS1_1 with (h_:=h''); eauto using HFacts.Equal_refl.
            inversion HRonly; subst. assumption.
          SSSCase "vacts ⊑ effb".
            inversion HEff; subst.
            inversion H9; subst.
            inversion HExp; subst.

            assert (facts_Eff : Epsilon_Phi_Soundness (fold_subst_eps rho static_e1, aacts)) by
                (eapply eff_sound; eauto).
            assert (HEq_1 : heap' = h'').
            eapply ReadOnlyStaticImpliesReadOnlyPhi with (phi:=aacts) in HR.
            { apply ReadOnlyTracePreservesHeap_1 in BS1_1. symmetry in BS1_1.
              - assumption.
              - assumption. }
            exact facts_Eff.

            assert (vacts ⊑ effa1).
            { eapply IHBS1_2 with (p':= phia0); eauto using HFacts.Equal_refl.
              - rewrite HEq_1. eassumption.
              - inversion HRonly as [ | | ? ? X Y | ]; inversion X; inversion Y; assumption.
              - rewrite HEq_1. assumption. }
            apply Theta_introl. assumption.
        SSCase "Phi_Elem (DA_Write r l v0) ⊑ Union_Theta effa effb".
          inversion H9; subst.
          assert (Phi_Elem (DA_Write r l v0) ⊑ effb0).
          apply PTS_Elem. inversion H10; subst.
          rewrite H in H1. inversion H1; subst.
          apply DAT_Write_Abs; apply In_singleton.
          apply Theta_intror. apply Theta_intror.
          assumption.
      SCase " Assign (Rgn2_Const true false r0) ea0 ev << (eff1 ⊕ (eff2 ⊕ WriteConc ea0))".
         inversion HEff; subst.
         apply PTS_Seq.
         SSCase "Phi_Seq aacts vacts ⊑ Union_Theta effa effb".
           apply EnsembleUnionComp.
           SSSCase "aacts ⊑ effa".
             inversion HExp; subst.
             eapply IHBS1_1 with (h_:=h'');  eauto using HFacts.Equal_refl.
             inversion HRonly; subst.
             assumption.
           SSSCase "vacts ⊑ effb".
             inversion HExp; subst.
             inversion H9; subst.

             assert (facts_Eff : Epsilon_Phi_Soundness (fold_subst_eps rho static_e1, aacts)) by
                 (eapply eff_sound; eauto).
             assert (HEq_1 : heap' = h'').
             { eapply ReadOnlyStaticImpliesReadOnlyPhi with (phi:=aacts) in HR.
               - apply ReadOnlyTracePreservesHeap_1 in BS1_1. symmetry in BS1_1.
                 assumption. assumption.
               - eassumption. }

             assert (vacts ⊑ effa0).
             { eapply IHBS1_2 with (p':= phia0);  eauto using HFacts.Equal_refl.
               - rewrite HEq_1. eassumption.
               - inversion HRonly as [ | | ? ? X Y | ]; inversion X; inversion Y; assumption.
               - rewrite HEq_1. assumption. }
             apply Theta_introl. assumption.
        SSCase "Phi_Elem (DA_Write r l v0) ⊑ Union_Theta effa effb".
          inversion H9; subst.
          assert (Phi_Elem (DA_Write r l v0) ⊑ effb0).
          apply PTS_Elem. inversion H10; subst.
          assert (HD: H.Equal h'' heap' /\  Loc (Rgn2_Const true false r1) l0 =
                                            Loc (Rgn2_Const true false r0) l /\ Phi_Nil = aacts).
          eapply DeterminismReadOnlyRefs; eauto.
          destruct HD as [? [H_ ?]]; inversion H_; subst.
          inversion H; subst.
          apply DAT_Write_Conc; apply In_singleton.
          apply Theta_intror. apply Theta_intror. assumption.
      SCase "Assign w ea0 ev << (⊤)".
        inversion HEff; subst.
        apply PhiInThetaTop.
    }
    exact HSOUND.
  Case "nat_plus x y".
    (* goal *)
    assert (HSOUND : Phi_Seq lacts racts  ⊑ eff ).
    { inversion HBt as [| | | | | | | | | | |
                      | ? ? ? ? ? ? ? ? ? ? HBt_ea0 HBt_ev TcExp_ea0 HR
                      | ? ? ? ? ? ? ? ? ? ? HBt_ea0 HBt_ev TcExp_ea0 HR
                      | ? ? ? ? ? ? ? ? ? ? ? HTcExp_a HTcExp_b HR HBt_a HBt_b
                      | | | | ]; subst;
      inversion HEff; subst;
      [apply EnsembleUnionComp | ].

      - eapply IHBS1_1 with (ee:=eff1) (h_:=h''); eauto using HFacts.Equal_refl.
        inversion HRonly as [ | | ? ? X Y | ]; assumption.
      - assert (lacts_Eff : Epsilon_Phi_Soundness (fold_subst_eps rho static_e1, lacts)) by
            (eapply eff_sound; eauto).
        assert (HEq_1 : lheap = h'').
        eapply ReadOnlyStaticImpliesReadOnlyPhi with (phi:=lacts) in HR.
        { apply ReadOnlyTracePreservesHeap_1 in BS1_1. symmetry in BS1_1.
          - assumption.
          - assumption. }
        exact lacts_Eff.

        eapply IHBS1_2 with (ee:=eff2) (h_:=h'') (p':=phib); eauto using HFacts.Equal_refl.
        + apply Equal_heap_equal; auto.
        + rewrite <- HEq_1. eassumption.
        + rewrite HEq_1. eassumption.
        + inversion HRonly as [ | | ? ? X Y | ]; assumption.
        + rewrite HEq_1. assumption.
      - apply PhiInThetaTop.
    }
    exact HSOUND.
  Case "nat_minus x y".
    (* goal *)
    assert (HSOUND : Phi_Seq lacts racts  ⊑ eff ).
    { inversion HBt as [| | | | | | | | | | |
                      | ? ? ? ? ? ? ? ? ? ? HBt_ea0 HBt_ev TcExp_ea0 HR
                      | ? ? ? ? ? ? ? ? ? ? HBt_ea0 HBt_ev TcExp_ea0 HR
                      |
                      | ? ? ? ? ? ? ? ? ? ? ? HTcExp_a HTcExp_b HR HBt_a HBt_b
                      | | | ]; subst;
      inversion HEff; subst;
      [apply EnsembleUnionComp | ].

      - eapply IHBS1_1 with (ee:=eff1) (h_:=h''); eauto using HFacts.Equal_refl.
        inversion HRonly as [ | | ? ? X Y | ]; assumption.
      - assert (lacts_Eff : Epsilon_Phi_Soundness (fold_subst_eps rho static_e1, lacts)) by
            (eapply eff_sound; eauto).
        assert (HEq_1 : lheap = h'').
        eapply ReadOnlyStaticImpliesReadOnlyPhi with (phi:=lacts) in HR.
        { apply ReadOnlyTracePreservesHeap_1 in BS1_1. symmetry in BS1_1.
          - assumption.
          - assumption. }
        exact lacts_Eff.

        eapply IHBS1_2 with (ee:=eff2) (h_:=h'') (p':=phib); eauto using HFacts.Equal_refl.
        + apply Equal_heap_equal; auto.
        + rewrite <- HEq_1. eassumption.
        + rewrite HEq_1. eassumption.
        + inversion HRonly as [ | | ? ? X Y | ]; assumption.
        + rewrite HEq_1. assumption.
      - apply PhiInThetaTop.
    }
    exact HSOUND.
  Case "nat_times x y".
    (* goal *)
    assert (HSOUND : Phi_Seq lacts racts  ⊑ eff ).
    { inversion HBt as [| | | | | | | | | | |
                        | ? ? ? ? ? ? ? ? ? ? HBt_ea0 HBt_ev TcExp_ea0 HR
                        | ? ? ? ? ? ? ? ? ? ? HBt_ea0 HBt_ev TcExp_ea0 HR
                        | |
                        | ? ? ? ? ? ? ? ? ? ? ? HTcExp_a HTcExp_b HR HBt_a HBt_b
                        | | ]; subst;
      inversion HEff; subst;
      [apply EnsembleUnionComp | ].

      - eapply IHBS1_1 with (ee:=eff1) (h_:=h''); eauto using HFacts.Equal_refl.
        inversion HRonly as [ | | ? ? X Y | ]; assumption.
      - assert (lacts_Eff : Epsilon_Phi_Soundness (fold_subst_eps rho static_e1, lacts)) by
            (eapply eff_sound; eauto).
        assert (HEq_1 : lheap = h'').
        eapply ReadOnlyStaticImpliesReadOnlyPhi with (phi:=lacts) in HR.
        { apply ReadOnlyTracePreservesHeap_1 in BS1_1. symmetry in BS1_1.
          - assumption.
          - assumption. }
        exact lacts_Eff.

        eapply IHBS1_2 with (ee:=eff2) (h_:=h'') (p':=phib); eauto using HFacts.Equal_refl.
        + apply Equal_heap_equal; auto.
        + rewrite <- HEq_1. eassumption.
        + rewrite HEq_1. eassumption.
        + inversion HRonly as [ | | ? ? X Y | ]; assumption.
        + rewrite HEq_1. assumption.
      - apply PhiInThetaTop.
    }
    exact HSOUND.
  Case "bool_eq x y".
    (* goal *)
    assert (HSOUND : Phi_Seq lacts racts  ⊑ eff ).
    { inversion HBt as [| | | | | | | | | | |
                        | ? ? ? ? ? ? ? ? ? ? HBt_ea0 HBt_ev TcExp_ea0 HR
                        | ? ? ? ? ? ? ? ? ? ? HBt_ea0 HBt_ev TcExp_ea0 HR
                        | | |
                        | ? ? ? ? ? ? ? ? ? ? ? HTcExp_a HTcExp_b HR HBt_a HBt_b
                        | ]; subst;
      inversion HEff; subst;
      [apply EnsembleUnionComp | ].

      - eapply IHBS1_1 with (ee:=eff1) (h_:=h''); eauto using HFacts.Equal_refl.
        inversion HRonly as [ | | ? ? X Y | ]; assumption.
      - assert (lacts_Eff : Epsilon_Phi_Soundness (fold_subst_eps rho static_e1, lacts)) by
            (eapply eff_sound; eauto).
        assert (HEq_1 : lheap = h'').
        eapply ReadOnlyStaticImpliesReadOnlyPhi with (phi:=lacts) in HR.
        { apply ReadOnlyTracePreservesHeap_1 in BS1_1. symmetry in BS1_1.
          - assumption.
          - assumption. }
        exact lacts_Eff.

        eapply IHBS1_2 with (ee:=eff2) (h_:=h'') (p':=phib); eauto using HFacts.Equal_refl.
        + apply Equal_heap_equal; auto.
        + rewrite <- HEq_1. eassumption.
        + rewrite HEq_1. eassumption.
        + inversion HRonly as [ | | ? ? X Y | ]; assumption.
        + rewrite HEq_1. assumption.
      - apply PhiInThetaTop.
    }
    exact HSOUND.
  Case "eff_concat".
    (* goal *)
    assert (HSOUND : Phi_Seq phia phib  ⊑ eff ).
    { inversion HBt as [| | | | | | | | | | |
                        | ? ? ? ? ? ? ? ? ? ? HBt_ea0 HBt_ev TcExp_ea0 HR
                        | ? ? ? ? ? ? ? ? ? ? HBt_ea0 HBt_ev TcExp_ea0 HR
                        | | |
                        | ? ? ? ? ? ? ? ? ? ? ? HTcExp_a HTcExp_b HR HBt_a HBt_b
                        | ]; subst;
      inversion HEff; subst.
      apply PhiInThetaTop.
    }
    exact HSOUND.
Qed.


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

From bpf.comm Require Import MemRegion State Monad.
From bpf.monadicmodel Require Import rBPFInterpreter.
From dx.Type Require Import Bool.
From dx Require Import IR.
From Coq Require Import List ZArith.
From compcert Require Import Integers Values Clight Memory AST.
From compcert Require Import Coqlib.
Import ListNotations.

From bpf.clightlogic Require Import clight_exec Clightlogic CorrectRel CommonLemma.

From bpf.clight Require Import interpreter.

From bpf.simulation Require Import correct_is_well_chunk_bool correct_eval_mrs_num correct_eval_mrs_regions correct_check_mem_aux correct_cmp_ptr32_nullM.

From bpf.simulation Require Import MatchState InterpreterRel.

(**
Check check_mem.
check_mem
     : permission -> memory_chunk -> val -> M val
*)

Section Check_mem.
  Context {S:special_blocks}.
  (** The program contains our function of interest [fn] *)
  Definition p : Clight.program := prog.

  (* [Args,Res] provides the mapping between the Coq and the C types *)
  (* Definition Args : list CompilableType := [stateCompilableType].*)
  Definition args : list Type := [(permission:Type); (memory_chunk:Type); (val:Type)].
  Definition res : Type := (val:Type).

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

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

  (* [match_arg] relates the Coq arguments and the C arguments *)
  Definition match_arg_list : DList.t (fun x => x -> Inv _) ((unit:Type) ::args) :=
    dcons (fun _ => StateLess _ is_state_handle)
      (dcons (stateless perm_correct)
        (dcons (stateless match_chunk)
          (dcons (stateless val32_correct)
            (DList.DNil _)))).

  (* [match_res] relates the Coq result and the C result *)
  Definition match_res : res -> Inv State.state:= stateless eq.

  Instance correct_function_check_mem : forall a, correct_function _ p args res f fn ModNothing  false match_state match_arg_list match_res a.
  Proof.
    correct_function_from_body args.
    correct_body.
    (** how to use correct_* *)
    unfold INV.
    unfold f, cl_app.
    unfold check_mem.
    correct_forward.

    get_invariant _chunk.
    exists (v::nil).
    split.
    unfold map_opt, exec_expr. rewrite p0.
    reflexivity.
    intros; simpl.
    intuition eauto.

    intros.
    correct_forward.
    2:{ (**r if-else branch *)
        correct_forward.

        eexists ; split_and.
        - reflexivity.
        - reflexivity.
        - reflexivity.
        - simpl ; auto.
          intro. constructor. reflexivity.
    }
    (**r if-then branch *)

    correct_forward.

    get_invariant _st.
    unfold eval_inv in *.
    exists (v::nil).
    split_and.
    unfold map_opt,exec_expr.
    rewrite p0; reflexivity.
    simpl; intros.
    tauto.
      -
      intros.
      correct_forward.

      get_invariant _st.
      unfold eval_inv,stateless, is_state_handle in *.
      subst.
      exists (Vptr st_blk Ptrofs.zero::nil).
      split.
      unfold map_opt, exec_expr.
      rewrite p0; reflexivity.
      simpl;intros.
      unfold is_state_handle. split ; auto.
      intros.
      correct_forward.

      get_invariant _st.
      get_invariant _mem_reg_num.
      get_invariant _perm.
      get_invariant _chunk.
      get_invariant _addr.
      get_invariant _mrs.
      exists (v :: v0 :: v1 :: v2 :: v3 :: v4 :: nil).
      split.
      unfold map_opt, exec_expr.
      rewrite p0, p1, p2, p3, p4, p5; reflexivity.
      simpl;intros.
      unfold correct_eval_mrs_num.match_res in c3.
      destruct c3 as (Hc_eq & _).
      unfold correct_eval_mrs_regions.match_res in c7.
      intuition eauto.

      intros.
      correct_forward.

      get_invariant _check_mem__1.
      exists (v::nil).
      split.
      unfold map_opt, exec_expr.
      rewrite p0; reflexivity.
      simpl;intros.
      unfold eval_inv,correct_check_mem_aux.match_res,stateless in c2.
      tauto.
      intros.

      correct_forward.
      2:{
          correct_forward.

          get_invariant _check_mem__1.
          exists v.
          split_and;auto.
          simpl.
          apply Cop.cast_val_casted;auto.
        }

      correct_forward.
      eexists.
      split_and.
      reflexivity.
      reflexivity.
      reflexivity.
      simpl.
      intro ; constructor; reflexivity.

      get_invariant _is_null.
      unfold exec_expr.
      unfold eval_inv,correct_cmp_ptr32_nullM.match_res, match_bool,stateless in c2.
      rewrite p0.
      rewrite c2.
      unfold Val.of_bool.
      destruct x3; reflexivity.
    - get_invariant _well_chunk.
      unfold exec_expr.
      rewrite p0.
      unfold eval_inv, stateless, match_bool in c2.
      unfold Val.of_bool.
      rewrite c2.
      destruct x; reflexivity.
  Qed.

End Check_mem.

Existing Instance correct_function_check_mem.