(* *********************************************************************)
(*                                                                     *)
(*            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 MPTCommon 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 Smallstep.
Require Import ClightBigstep.
Require Import Cop.
Require Import MPTCommon.
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 PTKernGenSpec.
Require Import Clight.
Require Import CDataTypes.
Require Import Ctypes.
Require Import CalRealPTPool.
Require Import CalRealPT.
Require Import AbstractDataType.
Require Import MPTCommonCSource.
Require Import TacticsForTesting.
Require Import XOmega.

Module MPTCOMMONCODE.

  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 PTINSERT.

      Let L: compatlayer (cdata RData) := pt_read_pde ↦ gensem ptReadPDE_spec
          ⊕ pt_insert_aux ↦ gensem ptInsertAux_spec
          ⊕ pt_alloc_pde ↦ gensem ptAllocPDE_spec
          ⊕ at_get_c ↦ gensem get_at_c_spec
          ⊕ at_set_c ↦ gensem set_at_c0_spec.

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

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

      Local Open Scope Z_scope.

      Section PTInsertBody.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

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

        (** pt_read_pde *)

        Variable bpt_read_pde: block.

        Hypothesis hpt_read_pde1 : Genv.find_symbol ge pt_read_pde = Some bpt_read_pde.

        Hypothesis hpt_read_pde2 : Genv.find_funct_ptr ge bpt_read_pde = Some (External (EF_external pt_read_pde (signature_of_type (Tcons tint (Tcons tint Tnil)) tint cc_default)) (Tcons tint (Tcons tint Tnil)) tint cc_default).

        (** pt_insert_aux *)

        Variable bpt_insert_aux: block.

        Hypothesis hpt_insert_aux1 : Genv.find_symbol ge pt_insert_aux = Some bpt_insert_aux.

        Hypothesis hpt_insert_aux2 : Genv.find_funct_ptr ge bpt_insert_aux = Some (External (EF_external pt_insert_aux (signature_of_type (Tcons tint (Tcons tint (Tcons tint (Tcons tint Tnil)))) Tvoid cc_default)) (Tcons tint (Tcons tint (Tcons tint (Tcons tint Tnil)))) Tvoid cc_default).

        (** pt_alloc_pde *)

        Variable bpt_alloc_pde: block.

        Hypothesis hpt_alloc_pde1 : Genv.find_symbol ge pt_alloc_pde = Some bpt_alloc_pde.

        Hypothesis hpt_alloc_pde2 : Genv.find_funct_ptr ge bpt_alloc_pde = Some (External (EF_external pt_alloc_pde (signature_of_type (Tcons tint (Tcons tint Tnil)) tint cc_default)) (Tcons tint (Tcons tint Tnil)) tint cc_default).

        (** at_get_c *)

        Variable bat_get_c: block.

        Hypothesis hat_get_c1 : Genv.find_symbol ge at_get_c = Some bat_get_c.

        Hypothesis hat_get_c2 : Genv.find_funct_ptr ge bat_get_c = Some (External (EF_external at_get_c (signature_of_type (Tcons tint Tnil) tint cc_default)) (Tcons tint Tnil) tint cc_default).

        (** at_set_c *)

        Variable bat_set_c: block.

        Hypothesis hat_set_c1 : Genv.find_symbol ge at_set_c = Some bat_set_c.

        Hypothesis hat_set_c2 : Genv.find_funct_ptr ge bat_set_c = Some (External (EF_external at_set_c (signature_of_type (Tcons tint (Tcons tint Tnil)) Tvoid cc_default)) (Tcons tint (Tcons tint Tnil)) Tvoid cc_default).

        Lemma pt_insert_body_correct: forall m d d' env le proc_index vadr padr perm v,
                                           env = PTree.empty _ ->
                                           PTree.get tproc_index le = Some (Vint proc_index) ->
                                           PTree.get tvadr le = Some (Vint vadr) ->
                                           PTree.get tpadr le = Some (Vint padr) ->
                                           PTree.get tperm le = Some (Vint perm) ->
                                           ptInsert_spec (Int.unsigned proc_index) (Int.unsigned vadr)
                                                         (Int.unsigned padr) (Int.unsigned perm) d = Some (d', Int.unsigned v) ->
                                           high_level_invariant d ->
                                           exists le',
                                             exec_stmt ge env le ((m, d): mem) pt_insert_body E0 le' (m, d') (Out_return (Some (Vint v, tint))).
          Proof.
            generalize max_unsigned_val; intro muval.
            generalize one_k_minus1; intro one_k_minus1.
            intros.
            subst.
            unfold pt_insert_body.
            destruct H5.
            functional inversion H4; subst.
            {
              generalize (valid_nps H9); intro npsrange.
              functional inversion H14; subst.
              functional inversion H6; subst.
              functional inversion H; subst.
              unfold pt, pdi, pti, pt0, pdi0, pti0, pdt', pt' in *.
              esplit.
              repeat vcgen.
              unfold ptReadPDE_spec.
              unfold getPDE_spec.
              rewrite H8, H9, H10, H11.
              unfold PDE_Arg.
              rewrite zle_lt_true.
              rewrite zle_le_true.
              rewrite H19.
              instantiate (1:= Int.repr pi0).
              rewrite Int.unsigned_repr.
              reflexivity.
              omega.
              unfold PDX.
              xomega.
              omega.
              discharge_cmp.
              repeat vcgen.
              repeat vcgen.
              repeat vcgen.
              repeat vcgen.
              repeat vcgen.
              unfold ptInsertAux_spec.
              unfold setPTE_spec.
              rewrite H8, H9, H10, H11, H12, H18, H19, H23.
              unfold PTE_Arg.
              unfold PDE_Arg.
              rewrite zle_lt_true.
              rewrite zle_le_true.
              rewrite zle_le_true.
              reflexivity.
              unfold PTX.
              assert (0 < one_k) by omega.
              generalize (Z.mod_pos_bound (Int.unsigned vadr / 4096) one_k H26); intro.
              change ((Int.max_unsigned / 4096) mod 1024) with 1023.
              omega.
              unfold PDX.
              xomega.
              omega.
              unfold get_at_c_spec.
              simpl.
              rewrite H10, H11, H21.
              rewrite zle_lt_true.
              instantiate (1:= Int.repr c).
              rewrite Int.unsigned_repr; try omega.
              reflexivity.
              omega.
              unfold set_at_c0_spec.
              simpl.
              rewrite H10, H11, H21.
              rewrite zle_lt_true.
              rewrite Int.unsigned_repr.
              reflexivity.
              omega.
              omega.
              repeat vcgen.
              simpl.
              rewrite H5.
              rewrite Int.repr_unsigned.
              repeat vcgen.
            }
            {
              generalize (valid_nps H9); intro npsrange.
              unfold pt, pdi, pti in *.
              functional inversion H6; subst.
              functional inversion H; subst.
              esplit.
              repeat vcgen.
              unfold ptReadPDE_spec.
              unfold getPDE_spec.
              rewrite H8, H9, H10, H11, H13.
              unfold PDE_Arg.
              rewrite zle_lt_true.
              rewrite zle_le_true.
              change 0 with (Int.unsigned Int.zero).
              reflexivity.
              unfold PDX.
              xomega.
              omega.
              discharge_cmp.
              repeat vcgen.
              repeat vcgen.
              repeat vcgen.
              repeat vcgen.
              repeat vcgen.
              simpl.
              rewrite H5.
              rewrite Int.repr_unsigned.
              repeat vcgen.
            }
            {
              generalize (valid_nps H9); intro npsrange.
              unfold pt, pdi, pti in *.
              functional inversion H6; subst.
              functional inversion H; subst.
              functional inversion H14.
              unfold pdi0 in *.
              functional inversion H16.
              unfold pt0, pdi1, pti0, pdt', pt' in *.
              rewrite <- H19, <- H31 in *; simpl in *.
              destruct _x4.
              destruct a0.
              esplit.
              repeat vcgen.
              unfold ptReadPDE_spec.
              unfold getPDE_spec.
              rewrite H8, H9, H10, H11, H13.
              unfold PDE_Arg.
              rewrite zle_lt_true.
              rewrite zle_le_true.
              change 0 with (Int.unsigned Int.zero).
              reflexivity.
              unfold PDX.
              xomega.
              omega.
              discharge_cmp.
              repeat vcgen.
              repeat vcgen.
              repeat vcgen.
              repeat vcgen.
              repeat vcgen.
              unfold ptInsertAux_spec.
              unfold setPTE_spec.
              simpl.
              rewrite H5, H8, H9, H10.
              rewrite H11, H12, H27, H36.
              repeat rewrite ZMap.gss.
              unfold PTE_Arg.
              unfold PDE_Arg.
              rewrite zle_lt_true.
              rewrite zle_le_true.
              rewrite zle_le_true.
              reflexivity.
              unfold PTX.
              assert (0 < one_k) by omega.
              generalize (Z.mod_pos_bound (Int.unsigned vadr / 4096) one_k H40); intro.
              change ((Int.max_unsigned / 4096) mod 1024) with 1023.
              omega.
              unfold PDX.
              xomega.
              omega.
              unfold get_at_c_spec.
              simpl.
              rewrite H10, H11, H38.
              rewrite zle_lt_true.
              instantiate (1:= Int.repr c0).
              rewrite Int.unsigned_repr; try omega.
              reflexivity.
              omega.
              unfold set_at_c0_spec.
              simpl.
              rewrite H10, H11, H38.
              rewrite zle_lt_true.
              repeat rewrite Int.unsigned_repr; try omega.
              simpl.
              unfold pdt', pt0, pdi1 in *.
              rewrite <- H19; simpl in *.
              assert (HSpeed:
                        forall hp a p ptp ptp' a' ac,
                          Some (d {HP : hp} {AT: a} {pperm: p} {ptpool: ptp} {AC: ac} {ptpool: ptp'} {AT: a'})
                          = ret (d {HP : hp} {AT: a} {pperm: p} {ptpool: ptp} {AC: ac} {AT: a'} {ptpool: ptp'})).
              {
                intros. reflexivity.
              }
              repeat rewrite ZMap.gss.
              apply HSpeed.
              omega.
              repeat vcgen.
              repeat vcgen.

              (* contradiction case *)
              clear H15.
              rewrite H20 in _x.
              contradiction _x.
              reflexivity.
            }
          Qed.

      End PTInsertBody.

      Theorem pt_insert_code_correct:
        spec_le (pt_insert ↦ ptInsert_spec_low) (〚pt_insert ↦ f_pt_insert 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (pt_insert_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_pt_insert)
                                                             (Vint n::Vint vadr::Vint padr::Vint p0::nil)
                                                             (create_undef_temps (fn_temps f_pt_insert)))) H0.
      Qed.

    End PTINSERT.

    Section PTRMV.

      Let L: compatlayer (cdata RData) := pt_read ↦ gensem ptRead_spec
          ⊕ pt_rmv_aux ↦ gensem ptRmvAux_spec
          ⊕ at_get_c ↦ gensem get_at_c_spec
          ⊕ at_set_c ↦ gensem set_at_c0_spec.

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

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

      Local Open Scope Z_scope.

      Section PTRmvBody.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

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

        (** pt_read *)

        Variable bpt_read: block.

        Hypothesis hpt_read1 : 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).

        (** pt_rmv_aux *)

        Variable bpt_rmv_aux: block.

        Hypothesis hpt_rmv_aux1 : Genv.find_symbol ge pt_rmv_aux = Some bpt_rmv_aux.

        Hypothesis hpt_rmv_aux2 : Genv.find_funct_ptr ge bpt_rmv_aux = Some (External (EF_external pt_rmv_aux (signature_of_type (Tcons tint (Tcons tint Tnil)) Tvoid cc_default)) (Tcons tint (Tcons tint Tnil)) Tvoid cc_default).

        (** at_get_c *)

        Variable bat_get_c: block.

        Hypothesis hat_get_c1 : Genv.find_symbol ge at_get_c = Some bat_get_c.

        Hypothesis hat_get_c2 : Genv.find_funct_ptr ge bat_get_c = Some (External (EF_external at_get_c (signature_of_type (Tcons tint Tnil) tint cc_default)) (Tcons tint Tnil) tint cc_default).

        (** at_set_c *)

        Variable bat_set_c: block.

        Hypothesis hat_set_c1 : Genv.find_symbol ge at_set_c = Some bat_set_c.

        Hypothesis hat_set_c2 : Genv.find_funct_ptr ge bat_set_c = Some (External (EF_external at_set_c (signature_of_type (Tcons tint (Tcons tint Tnil)) Tvoid cc_default)) (Tcons tint (Tcons tint Tnil)) Tvoid cc_default).

        Lemma pt_rmv_body_correct: forall m d d' env le proc_index vadr v,
                                           env = PTree.empty _ ->
                                           PTree.get tproc_index le = Some (Vint proc_index) ->
                                           PTree.get tvadr le = Some (Vint vadr) ->
                                           ptRmv_spec (Int.unsigned proc_index) (Int.unsigned vadr) d = Some (d', Int.unsigned v) ->
                                           exists le',
                                             exec_stmt ge env le ((m, d): mem) pt_rmv_body E0 le' (m, d') (Out_return (Some (Vint v, tint))).
          Proof.
            generalize max_unsigned_val; intro muval.
            generalize one_k_minus1; intro one_k_minus1.
            intros.
            subst.
            unfold pt_rmv_body.
            functional inversion H2; subst.
            {
              unfold pt, pdi, pti, pdt', pt' in *.
              functional inversion H4.
              assert(range: 0 < Int.unsigned v * 4096 + PermtoZ _x0 <= Int.max_unsigned).
              {
                unfold PermtoZ.
                destruct _x0; try omega.
                destruct b; omega.
              }
              assert(divval: (Int.unsigned v * 4096 + PermtoZ _x0) / 4096 = Int.unsigned v).
              {
                destruct _x0; simpl.
                xomega.
                xomega.
                destruct b; xomega.
              }
              esplit.
              repeat vcgen.
              unfold ptRead_spec.
              unfold getPTE_spec.
              rewrite H6, H7, H8, H9.
              unfold PTE_Arg.
              unfold PDE_Arg.
              rewrite zle_lt_true.
              rewrite zle_le_true.
              rewrite zle_le_true.
              rewrite H11, H12.
              instantiate (1:= (Int.repr (Int.unsigned v * 4096 + PermtoZ _x0))).
              rewrite Int.unsigned_repr; try omega.
              reflexivity.
              unfold PTX.
              assert (0 < one_k) by omega.
              generalize (Z.mod_pos_bound (Int.unsigned vadr / 4096) one_k H16); intro.
              change ((Int.max_unsigned / 4096) mod 1024) with 1023.
              omega.
              unfold PDX.
              xomega.
              omega.
              discharge_cmp.
              repeat vcgen.
              unfold ptRmvAux_spec.
              unfold rmvPTE_spec.
              rewrite H6, H7, H8, H9.
              unfold PTE_Arg.
              unfold PDE_Arg.
              rewrite zle_lt_true.
              rewrite zle_le_true.
              rewrite zle_le_true.
              rewrite H10, H11.
              reflexivity.
              unfold PTX.
              assert (0 < one_k) by omega.
              generalize (Z.mod_pos_bound (Int.unsigned vadr / 4096) one_k H16); intro.
              change ((Int.max_unsigned / 4096) mod 1024) with 1023.
              omega.
              unfold PDX.
              xomega.
              omega.
              rewrite divval.
              unfold get_at_c_spec.
              simpl.
              rewrite H8, H9, H14.
              rewrite zle_lt_true.
              instantiate (1:= Int.repr c).
              rewrite Int.unsigned_repr; try omega.
              reflexivity.
              omega.
              discharge_cmp.
              repeat vcgen.
              rewrite divval.
              unfold set_at_c0_spec.
              simpl.
              rewrite H8, H9, H14.
              rewrite zle_lt_true.
              reflexivity.
              omega.
              repeat vcgen.
              simpl.
              unfold sem_div.
              unfold sem_binarith; simpl.
              discharge_cmp.
              rewrite divval.
              rewrite Int.repr_unsigned.
              reflexivity.
            }
            {
              unfold pt, pdi, pti in *.
              functional inversion H4.
              esplit.
              repeat vcgen.
              unfold ptRead_spec.
              unfold getPTE_spec.
              rewrite H6, H7, H8, H9.
              unfold PTE_Arg.
              unfold PDE_Arg.
              rewrite zle_lt_true.
              rewrite zle_le_true.
              rewrite zle_le_true.
              rewrite H11, H12.
              change 0 with (Int.unsigned Int.zero).
              reflexivity.
              unfold PTX.
              assert (0 < one_k) by omega.
              generalize (Z.mod_pos_bound (Int.unsigned vadr / 4096) one_k H14); intro.
              change ((Int.max_unsigned / 4096) mod 1024) with 1023.
              omega.
              unfold PDX.
              xomega.
              omega.
              discharge_cmp.
              repeat vcgen.
              simpl.
              rewrite PTree.gss.
              f_equal.
              simpl.
              unfold sem_div.
              unfold sem_binarith; simpl.
              discharge_cmp.
              f_equal.
              f_equal.
              erewrite <- unsigned_inj.
              reflexivity.
              rewrite <- H3.
              rewrite Int.unsigned_repr.
              reflexivity.
              xomega.
            }
          Qed.

      End PTRmvBody.

      Theorem pt_rmv_code_correct:
        spec_le (pt_rmv ↦ ptRmv_spec_low) (〚pt_rmv ↦ f_pt_rmv 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (pt_rmv_body_correct s (Genv.globalenv p) makeglobalenv b0 Hb0fs Hb0fp b1 Hb1fs Hb1fp b2 Hb2fs Hb2fp b3 Hb3fs Hb3fp m'0 labd labd' (PTree.empty _)
                                      (bind_parameter_temps' (fn_params f_pt_rmv)
                                                             (Vint n::Vint vadr::nil)
                                                             (create_undef_temps (fn_temps f_pt_rmv)))) H0.
      Qed.

    End PTRMV.

    Section PTINITKERN.

      Let L: compatlayer (cdata RData) := pt_init_comm ↦ gensem pt_init_comm_spec ⊕ set_PDE ↦ gensem setPDE_spec.

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

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

      Local Open Scope Z_scope.

      Section PTInitKernBody.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

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

        (** set_PDE *)

        Variable bset_PDE: block.

        Hypothesis hset_PDE1 : Genv.find_symbol ge set_PDE = Some bset_PDE.

        Hypothesis hset_PDE2 : Genv.find_funct_ptr ge bset_PDE = Some (External (EF_external set_PDE (signature_of_type (Tcons tint (Tcons tint  Tnil)) Tvoid cc_default)) (Tcons tint (Tcons tint Tnil)) Tvoid cc_default).

        (** pt_init_comm *)

        Variable bptinitcomm: block.

        Hypothesis hpt_init_comm1 : Genv.find_symbol ge pt_init_comm = Some bptinitcomm.

        Hypothesis hpt_init_comm2 : Genv.find_funct_ptr ge bptinitcomm = Some (External (EF_external pt_init_comm (signature_of_type (Tcons tint Tnil) Tvoid cc_default)) (Tcons tint Tnil) Tvoid cc_default).

        Definition pt_init_kern_mk_rdata adt (index: Z) := adt {ptpool: (Calculate_pt_kern (Z.to_nat (index - 256)) (ptpool adt))}.

        Section pt_init_kern_loop_proof.

          Variable minit: memb.
          Variable adt: RData.

          Hypothesis init: init adt = true.
          Hypothesis ipt: ipt adt = true.
          Hypothesis pg: pg adt = false.
          Hypothesis ihost: ihost adt = true.
          Hypothesis ikern: ikern adt = true.

          Definition pt_init_kern_loop_body_P (le: temp_env) (m: mem): Prop :=
            PTree.get ti le = Some (Vint (Int.repr 256)) /\
            m = (minit, adt).

          Definition pt_init_kern_loop_body_Q (le : temp_env) (m: mem): Prop :=
            m = (minit, pt_init_kern_mk_rdata adt (960 - 1)).

          Lemma pt_init_kern_loop_correct_aux : LoopProofSimpleWhile.t pt_init_kern_while_condition pt_init_kern_while_body ge (PTree.empty _) (pt_init_kern_loop_body_P) (pt_init_kern_loop_body_Q).
          Proof.
            generalize max_unsigned_val; intro muval.
            apply LoopProofSimpleWhile.make with
            (W := Z)
              (lt := fun z1 z2 => (0 <= z2 /\ z1 < z2)%Z)
              (I := fun le (m: mem) w => exists i,
                                           PTree.get ti le = Some (Vint i) /\
                                           256 <= Int.unsigned i <= 960 /\
                                           (Int.unsigned i = 256 /\ m = (minit, adt) \/ Int.unsigned i > 256 /\ m =(minit, pt_init_kern_mk_rdata adt (Int.unsigned i - 1))) /\
                                           w = 960 - Int.unsigned i
              )
            .
            apply Zwf_well_founded.
            intros.
            unfold pt_init_kern_loop_body_P in H.
            destruct H as [tile tmpH].
            destruct tmpH as [pdtvalid msubst].
            subst.
            esplit. esplit.
            repeat vcgen.
            intros.
            destruct H as [i tmpH].
            destruct tmpH as [tile tmpH].
            destruct tmpH as [irange tmpH].
            destruct tmpH as [invar nval].
            subst.
            unfold pt_init_kern_while_condition.
            unfold pt_init_kern_while_body.
            destruct irange as [ilow ihigh].
            apply Zle_lt_or_eq in ihigh.

            Caseeq ihigh.

            (* i < 960 *)
            intro ihigh.

            destruct m.

            case_eq invar;intros.
            (* i = 256 *)
            destruct a.
            injection e0; intros; subst.

            esplit. esplit.
            repeat vcgen.
            esplit. esplit.
            repeat vcgen.
            exists (960 - Int.unsigned i - 1).
            repeat vcgen.
            esplit.
            repeat vcgen.

            right.
            split.
            omega.
            unfold pt_init_kern_mk_rdata.
            f_equal.
            f_equal; auto.
            rewrite e in *; simpl.
            unfold Calculate_pt_kern_at_i.
            reflexivity.

            (* i > 256 *)
            destruct a as [ilo mval].
            injection mval; intros; subst.
            esplit. esplit.
            repeat vcgen.
            esplit. esplit.
            repeat vcgen.
            unfold setPDE_spec.
            simpl.
            rewrite ipt, pg, ihost, ikern, init.
            unfold PDE_Arg.
            unfold zle_lt, zle_le.
            rewrite one_k_minus1.
            repeat zdestruct.
            exists (960 - Int.unsigned i - 1).
            repeat vcgen.
            esplit.
            repeat vcgen.
            right.
            split.
            omega.
            f_equal.
            unfold pt_init_kern_mk_rdata.
            replace (Int.unsigned i + 1 - 1 - 256) with (Z.succ (Int.unsigned i - 1 - 256)) by omega.
            rewrite Z2Nat.inj_succ.
            Opaque Z.of_nat.
            simpl.
            rewrite Nat2Z.inj_succ.
            rewrite Z2Nat.id.
            unfold Z.succ.
            unfold Calculate_pt_kern_at_i.
            assert(tmp2: (Int.unsigned i - 1 - 256 + 1 + 262144 / 1024) = Int.unsigned i).
            {
              change (262144 / 1024) with 256.
              omega.
            }
            rewrite tmp2.
            reflexivity.
            omega.
            omega.

            (* i = 960 *)
            intro ival.
            rewrite ival in *.
            esplit. esplit.
            repeat vcgen.
            unfold pt_init_kern_loop_body_Q.
            Caseeq invar.
            intro.
            destruct H0.
            omega.
            intro tmpH.
            destruct tmpH.
            assumption.
          Qed.

        End pt_init_kern_loop_proof.

        Lemma pt_init_kern_loop_correct: forall m adt adt' le,
                                           PTree.get ti le = Some (Vint (Int.repr 256)) ->
                                           init adt = true ->
                                           ipt adt = true ->
                                           pg adt = false ->
                                           ihost adt = true ->
                                           ikern adt = true ->
                                           adt' = pt_init_kern_mk_rdata adt (960 - 1) ->
                                           exists le',
                                             exec_stmt ge (PTree.empty _) le ((m, adt): mem) (Swhile pt_init_kern_while_condition pt_init_kern_while_body) E0 le' (m, adt') Out_normal.
        Proof.
          intros.
          generalize (pt_init_kern_loop_correct_aux m adt H0 H1 H2 H3 H4).
          intro LP.
          refine (_ (LoopProofSimpleWhile.termination _ _ _ _ _ _ LP le (m, adt) _)).
          intro pre.
          destruct pre as [le'' pre].
          destruct pre as [m'' pre].
          destruct pre as [pre1 pre2].
          unfold pt_init_kern_loop_body_Q in pre2.
          subst.
          esplit; eassumption.
          unfold pt_init_kern_loop_body_P.
          repeat (split; auto).
        Qed.

        Lemma pt_init_kern_body_correct: forall m d d' env le mbi_adr,
                                           env = PTree.empty _ ->
                                           PTree.get tmbi_adr le = Some (Vint mbi_adr) ->
                                           pt_init_kern_spec (Int.unsigned mbi_adr) d = Some d' ->
                                           exists le',
                                             exec_stmt ge env le ((m, d): mem) pt_init_kern_body E0 le' (m, d') Out_normal.
        Proof.
          generalize max_unsigned_val; intro muval.
          intros.
          unfold pt_init_kern_body.
          subst.
          functional inversion H1.
          simpl in *.

          set (initd := d {vmxinfo: real_vmxinfo} {AT : real_AT (AT d)} {nps : real_nps} {AC: real_AC} {init : true} {ptpool: real_ptp (ptpool d)}
                          {idpde : CalRealIDPDE.real_idpde (idpde d)}).
          exploit (pt_init_kern_loop_correct m initd (pt_init_kern_mk_rdata initd (960 - 1)) (PTree.set ti (Vint (Int.repr 256)) (set_opttemp None Vundef le))); try rewrite <- H; try assumption; try reflexivity; try (rewrite PTree.gss; reflexivity).
          intro stmt.
          unfold initd in *.
          destruct stmt as [le' stmt].
          esplit.
          change E0 with (E0**E0).
          econstructor.
          econstructor; vcgen; try simpleproof.
          repeat vcgen.
          repeat vcgen.
          repeat vcgen.
          repeat vcgen.
          repeat vcgen.
          repeat vcgen.
          vcgen.
          unfold pt_init_comm_spec.
          rewrite H2, H3, H4, H5, H6.
          reflexivity.
          change E0 with (E0**E0).
          econstructor.
          repeat vcgen.
          unfold pt_init_kern_mk_rdata, CalRealPT.real_pt in *.
          Opaque Z.sub Z.add.
          simpl in stmt.
          apply stmt.
        Qed.

      End PTInitKernBody.

      Theorem pt_init_kern_code_correct:
        spec_le (pt_init_kern ↦ pt_init_kern_spec_low) (〚pt_init_kern ↦ f_pt_init_kern 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (pt_init_kern_body_correct s (Genv.globalenv p) makeglobalenv b1 Hb1fs Hb1fp b0 Hb0fs Hb0fp m'0 labd labd' (PTree.empty _)
                                        (bind_parameter_temps' (fn_params f_pt_init_kern)
                                                               (Vint mbi_adr::nil)
                                                               (create_undef_temps (fn_temps f_pt_init_kern)))) H0.
      Qed.

    End PTINITKERN.

  End WithPrimitives.

End MPTCOMMONCODE.


Require Import Bool List String Peano_dec Lia.
Require Import Common FMap IndexSupport HVector Syntax Topology Semantics SemFacts StepM.
Require Import Invariant TrsInv Simulation Serial SerialFacts.
Require Import RqRsLang RqRsCorrect.

Require Import Ex.Spec Ex.SpecInds Ex.Template.
Require Import Ex.Msi Ex.Msi.Msi Ex.Msi.MsiObjInv Ex.Msi.MsiTopo.

Set Implicit Arguments.

Import PropMonadNotations.
Import CaseNotations.

Local Open Scope list.
Local Open Scope hvec.
Local Open Scope fmap.

#[global] Existing Instance Msi.ImplOStateIfc.

Lemma msi_InObjInds:
  forall tr (Htr: tr <> Node nil),
    InvReachable (impl Htr) step_m (InObjInds tr 0).
Proof.
  intros.
  apply tree2Topo_InObjInds_inv_ok.
  - red; simpl; intros.
    destruct ((implOStatesInit tr)@[oidx]) as [ost|] eqn:Host; simpl; auto.
    destruct (in_dec idx_dec oidx ((c_li_indices (snd (tree2Topo tr 0)))
                                     ++ c_l1_indices (snd (tree2Topo tr 0)))); auto.
    rewrite implOStatesInit_None in Host by assumption.
    discriminate.
  - simpl; rewrite c_li_indices_head_rootOf by assumption.
    apply SubList_cons; [left; reflexivity|].
    simpl; apply SubList_cons_right.
    rewrite map_app.
    do 2 rewrite map_map.
    apply SubList_app_6.
    all: simpl; rewrite map_id; apply SubList_refl.
Qed.

Lemma msi_OstInds:
  forall tr (Htr: tr <> Node nil),
    InvReachable (impl Htr) step_m (OstInds tr 0).
Proof.
  intros.
  apply tree2Topo_OstInds_inv_ok.
  red; simpl; intros.
  split.
  - rewrite c_li_indices_head_rootOf in H by assumption.
    inv H.
    + rewrite implOStatesInit_value_root by assumption; eauto.
    + rewrite implOStatesInit_value_non_root by assumption; eauto.
  - rewrite implORqsInit_value by assumption; eauto.
Qed.

Lemma msi_MsgConflictsInv:
  forall tr (Htr: tr <> Node nil)
         (Hrcinv: InvReachable (impl Htr) step_m (RootChnInv tr 0)),
    InvReachable (impl Htr) step_m (MsgConflictsInv tr 0).
Proof.
  intros.
  apply tree2Topo_MsgConflicts_inv_ok
    with (oinvs:= MsiObjInvs (fst (tree2Topo tr 0))); auto.
  simpl; unfold mem, li, l1.
  rewrite map_app.
  do 2 rewrite map_trans.
  do 2 rewrite map_id.
  rewrite app_comm_cons.
  rewrite <-c_li_indices_head_rootOf by assumption.
  apply SubList_refl.
Qed.

Section ObjInvOk.
  Variable (tr: tree).
  Hypothesis (Htr: tr <> Node nil).

  Let topo: DTree := fst (tree2Topo tr 0).
  Let cifc: CIfc := snd (tree2Topo tr 0).
  Let impl: System := impl Htr.

  Definition MsiUpLockInv (st: State): Prop :=
    liftObjInvs MsiUpLockObjInv st.

  Definition MsiDownLockInv (st: State): Prop :=
    liftObjInvs (MsiDownLockObjInv topo) st.

  (*! [MsiUpLockInv] *)

  Lemma MsiUpLockInv_init:
    Invariant.InvInit impl MsiUpLockInv.
  Proof.
    do 3 (red; simpl); intros; red; simpl.
    destruct (implOStatesInit tr)@[oidx] as [ost|] eqn:Host; simpl; auto.
    destruct (implORqsInit tr)@[oidx] as [orq|] eqn:Horq; simpl; auto.
    red; simpl.
    unfold implORqsInit in Horq.
    destruct (in_dec idx_dec oidx ((c_li_indices (snd (tree2Topo tr 0)))
                                     ++ c_l1_indices (snd (tree2Topo tr 0)))).
    - rewrite initORqs_value in Horq by assumption.
      inv Horq.
      mred.
    - rewrite initORqs_None in Horq by assumption.
      discriminate.
  Qed.

  Lemma MsiUpLockInv_update_None:
    forall oss orqs pmsgs,
      MsiUpLockInv {| st_oss := oss;
                       st_orqs := orqs;
                       st_msgs := pmsgs |} ->
      forall oidx nost norq nmsgs,
        norq@[upRq] = None ->
        MsiUpLockInv {| st_oss := oss +[oidx <- nost];
                         st_orqs := orqs +[oidx <- norq];
                         st_msgs := nmsgs |}.
  Proof.
    cbv [MsiUpLockInv liftObjInvs liftObjInv MsiUpLockObjInv]; simpl; intros.
    specialize (H oidx0).
    mred; simpl.
    rewrite H0; simpl; auto.
  Qed.

  Lemma MsiUpLockInv_no_update:
    forall oss orqs pmsgs,
      MsiUpLockInv {| st_oss := oss;
                       st_orqs := orqs;
                       st_msgs := pmsgs |} ->
      forall oidx post porq nost norq nmsgs,
        oss@[oidx] = Some post ->
        nost#[owned] = post#[owned] ->
        nost#[status] = post#[status] ->
        nost#[dir].(dir_st) = post#[dir].(dir_st) ->
        orqs@[oidx] = Some porq ->
        norq@[upRq] = porq@[upRq] ->
        MsiUpLockInv {| st_oss := oss +[oidx <- nost];
                         st_orqs := orqs +[oidx <- norq];
                         st_msgs := nmsgs |}.
  Proof.
    cbv [MsiUpLockInv liftObjInvs liftObjInv MsiUpLockObjInv]; simpl; intros.
    mred; auto.
    simpl; rewrite H1, H2, H3, H5.
    specialize (H oidx).
    rewrite H0, H4 in H; simpl in H.
    assumption.
  Qed.

  Ltac disc_MsiUpLockInv_internal oidx :=
    repeat
      match goal with
      | [Hdl: MsiUpLockInv _ |- _] =>
        (specialize (Hdl oidx); do 2 red in Hdl; simpl in Hdl)
      | [Hmv: ?m@[?i] = Some ?v, H: context [?m@[?i]] |- _] =>
        rewrite Hmv in H; simpl in H
      end;
    disc_msi_obj_invs; dest.

  Ltac disc_MsiDownLockInv_internal oidx :=
    repeat
      match goal with
      | [Hdl: MsiDownLockInv _ |- _] =>
        (specialize (Hdl oidx); do 2 red in Hdl; simpl in Hdl)
      | [Hmv: ?m@[?i] = Some ?v, H: context [?m@[?i]] |- _] =>
        rewrite Hmv in H; simpl in H
      end;
    disc_msi_obj_invs; dest.

  Ltac solve_MsiUpLockInv oidx :=
    try match goal with
        | [Hul: MsiUpLockInv _ |- _] =>
          let noidx := fresh "oidx" in
          do 2 red; simpl; intro noidx;
          red; simpl;
          repeat (mred; simpl); [|apply Hul; fail]
        end;
    disc_MsiUpLockInv_internal oidx;
    red; mred; simpl;
    repeat
      match goal with
      | [H: _ <+- ?ov; _ |- _ <+- ?ov; _] =>
        let Hov := fresh "H" in
        let v := fresh "v" in
        destruct ov as [v|] eqn:Hov; simpl in *; [|auto; fail]
      | [H: msg_id ?rmsg = _ |- context [msg_id ?rmsg] ] =>
        rewrite H; simpl
      end;
    repeat (find_if_inside;
            [dest; try congruence; repeat split; intuition solve_msi|]);
    auto.

  Lemma MsiUpLockInv_mutual_step:
    Invariant.MutualInvStep1 impl step_m MsiUpLockInv MsiDownLockInv.
  Proof. (* SKIP_PROOF_ON
    red; intros.
    pose proof (tree2Topo_TreeTopoNode tr 0) as Htn.
    pose proof (footprints_ok
                  (msi_GoodORqsInit Htr)
                  (msi_GoodRqRsSys Htr) H) as Hftinv.
    inv H2; [assumption..|].

    simpl in H3; destruct H3; [subst|apply in_app_or in H2; destruct H2].

    - (*! Cases for the main memory *)

      (** Abstract the root. *)
      assert (In (rootOf (fst (tree2Topo tr 0)))
                 (c_li_indices (snd (tree2Topo tr 0)))).
      { rewrite c_li_indices_head_rootOf by assumption.
        left; reflexivity.
      }
      remember (rootOf (fst (tree2Topo tr 0))) as oidx; clear Heqoidx.
      simpl in *.

      (** Do case analysis per a rule. *)
      apply concat_In in H4; destruct H4 as [crls [? ?]].
      apply in_map_iff in H3; destruct H3 as [cidx [? ?]]; subst.

      (** Derive that the child has the parent. *)
      assert (parentIdxOf (fst (tree2Topo tr 0)) cidx = Some oidx)
        by (apply subtreeChildrenIndsOf_parentIdxOf; auto).

      dest_in; disc_rule_conds_ex.
      all: try (eapply MsiUpLockInv_update_None; eauto; fail).

    - (*! Cases for Li caches *)

      (** Derive some necessary information: each Li has a parent. *)
      apply in_map_iff in H2; destruct H2 as [oidx [? ?]]; subst; simpl in *.
      pose proof (c_li_indices_tail_has_parent Htr _ _ H3).
      destruct H2 as [pidx [? ?]].
      pose proof (Htn _ _ H5); dest.

      (** Do case analysis per a rule. *)
      apply in_app_or in H4; destruct H4.

      1: { (** Rules per a child *)
        apply concat_In in H4; destruct H4 as [crls [? ?]].
        apply in_map_iff in H4; destruct H4 as [cidx [? ?]]; subst.

        (** Derive that the child has the parent. *)
        assert (parentIdxOf (fst (tree2Topo tr 0)) cidx = Some oidx)
          by (apply subtreeChildrenIndsOf_parentIdxOf; auto).

        dest_in; disc_rule_conds_ex.
        all: try (eapply MsiUpLockInv_update_None; eauto; fail).
        all: try (eapply MsiUpLockInv_no_update; eauto; mred; fail).
        all: solve_MsiUpLockInv oidx.
      }

      dest_in; disc_rule_conds_ex.
      all: try (eapply MsiUpLockInv_update_None; eauto; mred; fail).
      all: try (eapply MsiUpLockInv_no_update; eauto;
                unfold addRqS; mred; fail).
      all: try (solve_MsiUpLockInv oidx; fail).
      all: try (solve_MsiUpLockInv oidx; unfold addRqS; mred; fail).
      all: try (disc_MsiDownLockInv_internal oidx; solve_MsiUpLockInv oidx; fail).
      { disc_MsiDownLockInv_internal oidx.
        destruct H22; dest.
        all: solve_MsiUpLockInv oidx.
      }

    - (*! Cases for L1 caches *)

      (** Do case analysis per a rule. *)
      apply in_map_iff in H2; destruct H2 as [oidx [? ?]]; subst.
      dest_in; disc_rule_conds_ex.
      all: try (eapply MsiUpLockInv_update_None; eauto; mred; fail).
      all: try (solve_MsiUpLockInv oidx; fail).
      all: solve_MsiUpLockInv oidx; unfold addRqS; mred.

      END_SKIP_PROOF_ON *) admit.
  Qed.

  (*! [MsiDownLockInv] *)

  Lemma MsiDownLockInv_init:
    Invariant.InvInit impl MsiDownLockInv.
  Proof.
    do 3 (red; simpl); intros; red; simpl.
    destruct (implOStatesInit tr)@[oidx] as [ost|] eqn:Host; simpl; auto.
    destruct (implORqsInit tr)@[oidx] as [orq|] eqn:Horq; simpl; auto.
    red; simpl.
    unfold implORqsInit in Horq.
    destruct (in_dec idx_dec oidx ((c_li_indices (snd (tree2Topo tr 0)))
                                     ++ c_l1_indices (snd (tree2Topo tr 0)))).
    - rewrite initORqs_value in Horq by assumption.
      inv Horq.
      mred.
    - rewrite initORqs_None in Horq by assumption.
      discriminate.
  Qed.

  Lemma MsiDownLockInv_update_None:
    forall oss orqs pmsgs,
      MsiDownLockInv {| st_oss := oss; st_orqs := orqs; st_msgs := pmsgs |} ->
      forall oidx nost norq nmsgs,
        norq@[downRq] = None ->
        MsiDownLockInv {| st_oss := oss +[oidx <- nost];
                          st_orqs := orqs +[oidx <- norq];
                          st_msgs := nmsgs |}.
  Proof.
    cbv [MsiDownLockInv liftObjInvs liftObjInv MsiDownLockObjInv]; simpl; intros.
    specialize (H oidx0).
    mred; simpl.
    rewrite H0; simpl; auto.
  Qed.

  Lemma MsiDownLockInv_no_update:
    forall oss orqs pmsgs,
      MsiDownLockInv {| st_oss := oss; st_orqs := orqs; st_msgs := pmsgs |} ->
      forall oidx post porq nost norq nmsgs,
        oss@[oidx] = Some post ->
        nost#[owned] = post#[owned] ->
        nost#[status] = post#[status] ->
        nost#[dir] = post#[dir] ->
        orqs@[oidx] = Some porq ->
        norq@[downRq] = porq@[downRq] ->
        MsiDownLockInv {| st_oss := oss +[oidx <- nost];
                          st_orqs := orqs +[oidx <- norq];
                          st_msgs := nmsgs |}.
  Proof.
    cbv [MsiDownLockInv liftObjInvs liftObjInv MsiDownLockObjInv]; simpl; intros.
    mred; auto.
    simpl; rewrite H1, H2, H3, H5.
    specialize (H oidx).
    rewrite H0, H4 in H; simpl in H.
    assumption.
  Qed.

  Ltac solve_MsiDownLockInv oidx :=
    try match goal with
        | [Hdl: MsiDownLockInv _ |- _] =>
          let noidx := fresh "oidx" in
          do 2 red; simpl; intro noidx;
          red; simpl;
          repeat (mred; simpl); [|apply Hdl; fail]
        end;
    disc_MsiDownLockInv_internal oidx;
    red; mred; simpl;
    repeat
      match goal with
      | [H: _ <+- ?ov; _ |- _ <+- ?ov; _] =>
        let Hov := fresh "H" in
        let v := fresh "v" in
        destruct ov as [v|] eqn:Hov; simpl in *; [|auto; fail]
      | [H: msg_id ?rmsg = _ |- context [msg_id ?rmsg] ] =>
        rewrite H; simpl
      end;
    repeat split;
    repeat match goal with
           | |- DownLockFromChild _ _ _ => red; simpl; eauto; fail
           | |- context [map _ (map _ _)] => rewrite rqi_rss_map_map
           | |- _ => repeat split; intuition solve_msi
           end.

  Lemma MsiDownLockInv_mutual_step:
    Invariant.MutualInvStep2 impl step_m MsiUpLockInv MsiDownLockInv.
  Proof. (* SKIP_PROOF_ON
    red; intros.
    pose proof (tree2Topo_TreeTopoNode tr 0) as Htn.
    pose proof (footprints_ok
                  (msi_GoodORqsInit Htr)
                  (msi_GoodRqRsSys Htr) H) as Hftinv.
    inv H2; [assumption..|].

    simpl in H3; destruct H3; [subst|apply in_app_or in H2; destruct H2].

    - (*! Cases for the main memory *)

      (** Abstract the root. *)
      assert (In (rootOf (fst (tree2Topo tr 0)))
                 (c_li_indices (snd (tree2Topo tr 0)))).
      { rewrite c_li_indices_head_rootOf by assumption.
        left; reflexivity.
      }
      remember (rootOf (fst (tree2Topo tr 0))) as oidx; clear Heqoidx.
      simpl in *.

      (** Do case analysis per a rule. *)
      apply concat_In in H4; destruct H4 as [crls [? ?]].
      apply in_map_iff in H3; destruct H3 as [cidx [? ?]]; subst.

      (** Derive that the child has the parent. *)
      assert (parentIdxOf (fst (tree2Topo tr 0)) cidx = Some oidx)
        by (apply subtreeChildrenIndsOf_parentIdxOf; auto).

      dest_in; disc_rule_conds_ex.
      all: try (eapply MsiDownLockInv_update_None; eauto; fail).

    - (*! Cases for Li caches *)

      (** Derive some necessary information: each Li has a parent. *)
      apply in_map_iff in H2; destruct H2 as [oidx [? ?]]; subst; simpl in *.
      pose proof (c_li_indices_tail_has_parent Htr _ _ H3).
      destruct H2 as [pidx [? ?]].
      pose proof (Htn _ _ H5); dest.

      (** Do case analysis per a rule. *)
      apply in_app_or in H4; destruct H4.

      1: { (** Rules per a child *)
        apply concat_In in H4; destruct H4 as [crls [? ?]].
        apply in_map_iff in H4; destruct H4 as [cidx [? ?]]; subst.

        (** Derive that the child has the parent. *)
        assert (parentIdxOf (fst (tree2Topo tr 0)) cidx = Some oidx)
          by (apply subtreeChildrenIndsOf_parentIdxOf; auto).

        dest_in; disc_rule_conds_ex.
        all: try (eapply MsiDownLockInv_update_None; eauto; fail).
        all: try (eapply MsiDownLockInv_no_update; eauto; mred; fail).
        all: try (derive_child_chns cidx;
                  derive_child_idx_in cidx;
                  solve_MsiDownLockInv oidx).
      }

      dest_in; disc_rule_conds_ex.
      all: try (eapply MsiDownLockInv_update_None; eauto; mred; fail).
      all: try (eapply MsiDownLockInv_no_update; eauto;
                unfold addRqS; mred; fail).
      all: try (solve_MsiDownLockInv oidx; fail).
      { disc_MsiUpLockInv_internal oidx.
        derive_footprint_info_basis oidx.
        derive_child_chns cidx.
        derive_child_idx_in cidx.
        disc_rule_conds_ex.
        solve_MsiDownLockInv oidx.
      }

    - (*! Cases for L1 caches *)

      (** Do case analysis per a rule. *)
      apply in_map_iff in H2; destruct H2 as [oidx [? ?]]; subst.
      dest_in; disc_rule_conds_ex.
      all: try (eapply MsiDownLockInv_update_None; eauto; mred; fail).
      all: try (eapply MsiDownLockInv_no_update; eauto;
                unfold addRqS; mred; fail).

      END_SKIP_PROOF_ON *) admit.
  Qed.

  Theorem MsiLockInv_ok:
    InvReachable impl step_m (fun st => MsiUpLockInv st /\ MsiDownLockInv st).
  Proof.
    eapply mutual_inv_reachable.
    - typeclasses eauto.
    - apply MsiUpLockInv_init.
    - apply MsiDownLockInv_init.
    - apply MsiUpLockInv_mutual_step.
    - apply MsiDownLockInv_mutual_step.
  Qed.

  Corollary MsiObjInvs_ok:
    InvReachable impl step_m (liftObjInvs (MsiObjInvs topo)).
  Proof.
    red; intros.
    apply MsiLockInv_ok in H; dest.
    red; intros.
    specialize (H oidx); specialize (H0 oidx).
    red; red in H, H0.
    destruct (st_oss ist)@[oidx] as [ost|]; simpl in *; [|auto].
    destruct (st_orqs ist)@[oidx] as [orq|]; simpl in *; [|auto].
    split; assumption.
  Qed.

  Corollary MsiUpLockInv_ok:
    InvReachable impl step_m MsiUpLockInv.
  Proof.
    red; intros.
    apply MsiLockInv_ok; assumption.
  Qed.

  Corollary MsiDownLockInv_ok:
    InvReachable impl step_m MsiDownLockInv.
  Proof.
    red; intros.
    apply MsiLockInv_ok; assumption.
  Qed.

End ObjInvOk.

Ltac disc_MsiUpLockInv oidx :=
  repeat
    match goal with
    | [Hdl: MsiUpLockInv _ |- _] =>
      (specialize (Hdl oidx); do 2 red in Hdl; simpl in Hdl)
    | [Hmv: ?m@[?i] = Some ?v, H: context [?m@[?i]] |- _] =>
      rewrite Hmv in H; simpl in H
    end;
  disc_msi_obj_invs; dest.

Ltac disc_MsiDownLockInv oidx Hinv :=
  specialize (Hinv oidx); do 2 red in Hinv; simpl in Hinv;
  disc_rule_conds_ex; disc_msi_obj_invs; dest;
  repeat
    match goal with
    | [Hrqi: rqi_msg _ = Some ?msg, Hmsg: msg_id ?msg = _ |- _] =>
      rewrite Hmsg in Hinv; simpl in Hinv
    | [H: DownLockFromChild _ _ _ /\ _ |- _] => destruct H
    | [H: DownLockFromParent _ _ /\ _ |- _] => destruct H
    | [Hdfc: DownLockFromChild _ _ _ |- _] =>
      red in Hdfc; dest; disc_rule_conds_ex
    | [Hdfp: DownLockFromParent _ _ |- _] =>
      red in Hdfp; dest; disc_rule_conds_ex; solve_midx_false
    end.

Section RootChnInv.
  Variable (tr: tree).
  Hypothesis (Htr: tr <> Node nil).

  Let topo: DTree := fst (tree2Topo tr 0).
  Let cifc: CIfc := snd (tree2Topo tr 0).
  Let impl: System := impl Htr.

  Lemma msi_RootChnInv_init:
    Invariant.InvInit impl (RootChnInv tr 0).
  Proof.
    do 2 (red; simpl).
    intros.
    intro Hx; do 2 (red in Hx).
    dest_in.
  Qed.

  Ltac disc_RootChnInv :=
    intros;
    let Hx := fresh "H" in
    intro Hx;
    repeat
      match goal with
      | [H: In _ (subtreeChildrenIndsOf _ _) |- _] =>
        apply subtreeChildrenIndsOf_parentIdxOf in H; auto
      | [Hm: InMPI (enqMsgs _ _) _ |- _] =>
        apply InMP_enqMsgs_or in Hm; destruct Hm
      | [Hinv: _ -> _ -> ~ InMPI _ _,  Hm: InMP _ _ (deqMsgs _ _) |- _] =>
        apply InMP_deqMsgs in Hm; eapply Hinv; eauto
      | [H: In (idOf ?idm, valOf ?idm) _ |- _] =>
        let midx := fresh "midx" in
        let msg := fresh "msg" in
        destruct idm as [midx msg]; simpl in *
      end;
    disc_rule_conds_ex.

  Ltac solve_RootChnInv :=
    repeat
      match goal with
      | [H: In _ (remove _ _ (dir_sharers _)) |- _] => apply in_remove in H
      | [H1: In _ ?l, H2: SubList ?l (subtreeChildrenIndsOf _ _) |- _] =>
        apply H2 in H1
      | [H: In _ (subtreeChildrenIndsOf _ _) |- _] =>
        apply subtreeChildrenIndsOf_parentIdxOf in H; auto
      | [H: In _ (map _ _) |- _] => apply in_map_iff in H; dest
      | [H: (_, _) = (_, _) |- _] => inv H
      | [H: _ \/ _ \/ _ |- _] => destruct H as [|[|]]; try discriminate
      | [H: rqUpFrom _ = rqUpFrom _ |- _] => inv H
      | [H: rsUpFrom _ = rsUpFrom _ |- _] => inv H
      | [H: downTo _ = downTo _ |- _] => inv H

      | [H: parentIdxOf _ ?oidx = Some ?oidx |- _] =>
        exfalso; eapply parentIdxOf_not_eq in H; eauto
      | [H1: ?oidx = rootOf _, H2: parentIdxOf _ ?oidx = Some _ |- _] => rewrite H1 in H2
      | [H: parentIdxOf _ (rootOf _) = Some ?idx |- _] =>
        eapply parentIdxOf_child_not_root with (pidx:= idx); eauto
      | [H: In (rootOf _) (tl (c_li_indices _)) |- _] =>
        exfalso; eapply tree2Topo_root_not_in_tl_li; eauto
      | [H: In (rootOf _) (c_l1_indices _) |- _] =>
        exfalso; eapply tree2Topo_root_not_in_l1; eauto
      | [H1: In ?oidx (c_l1_indices _), H2: l1ExtOf ?oidx = rootOf _ |- _] =>
        eapply tree2Topo_root_not_l1ExtOf; eauto
      end.

  Lemma msi_RootChnInv_step:
    Invariant.InvStep impl step_m (RootChnInv tr 0).
  Proof. (* SKIP_PROOF_ON
    red; intros.
    pose proof (tree2Topo_TreeTopoNode tr 0) as Htn.
    pose proof (footprints_ok
                  (msi_GoodORqsInit Htr)
                  (msi_GoodRqRsSys Htr) H) as Hftinv.
    pose proof (MsiDownLockInv_ok H) as Hmftinv.
    inv H1; [assumption|..].

    1: {
      red; simpl; intros.
      intro Hx; apply InMP_enqMsgs_or in Hx.
      destruct Hx; [|eapply H0; eauto].
      apply in_map with (f:= idOf) in H4; simpl in H4.
      apply H3 in H4; simpl in H4.
      eapply DisjList_In_1.
      + apply tree2Topo_minds_merqs_disj.
      + eassumption.
      + eapply tree2Topo_obj_chns_minds_SubList.
        * rewrite c_li_indices_head_rootOf by assumption.
          left; reflexivity.
        * destruct H1 as [|[|]]; rewrite H1; simpl; tauto.
    }

    1: {
      red; simpl; intros.
      intro Hx; apply InMP_deqMsgs in Hx.
      eapply H0; eauto.
    }

    simpl in H2; destruct H2; [subst|apply in_app_or in H1; destruct H1].

    - (*! Cases for the main memory *)

      (** Abstract the root. *)
      unfold RootChnInv in *; simpl in *.
      remember (rootOf (fst (tree2Topo tr 0))) as oidx; clear Heqoidx.

      (** Do case analysis per a rule. *)
      apply concat_In in H3; destruct H3 as [crls [? ?]].
      apply in_map_iff in H1; destruct H1 as [cidx [? ?]]; subst.
      dest_in; try (disc_RootChnInv; solve_RootChnInv; fail).

    - (*! Cases for Li caches *)
      unfold RootChnInv in *; simpl in *.

      (** Derive some necessary information: each Li has a parent. *)
      apply in_map_iff in H1; destruct H1 as [oidx [? ?]]; subst; simpl in *.
      pose proof (c_li_indices_tail_has_parent Htr _ _ H2).
      destruct H1 as [pidx [? ?]].
      pose proof (Htn _ _ H4); dest.

      (** Do case analysis per a rule. *)
      apply in_app_or in H3; destruct H3.

      1: { (** Rules per a child *)
        apply concat_In in H3; destruct H3 as [crls [? ?]].
        apply in_map_iff in H3; destruct H3 as [cidx [? ?]]; subst.
        dest_in; try (disc_RootChnInv; solve_RootChnInv; fail).
      }

      dest_in.
      all: try (disc_RootChnInv; solve_RootChnInv; fail).
      all: try (disc_RootChnInv;
                derive_footprint_info_basis oidx;
                derive_child_chns cidx;
                disc_rule_conds_ex;
                solve_RootChnInv;
                fail).
      all: try (disc_RootChnInv;
                derive_footprint_info_basis oidx;
                [|disc_MsiDownLockInv oidx Hmftinv];
                derive_child_chns upCIdx;
                disc_rule_conds_ex;
                solve_RootChnInv;
                fail).
      all: try (disc_RootChnInv;
                derive_footprint_info_basis oidx;
                [disc_MsiDownLockInv oidx Hmftinv|];
                disc_rule_conds_ex;
                solve_RootChnInv).

    - (*! Cases for L1 caches *)
      unfold RootChnInv in *; simpl in *.

      (** Do case analysis per a rule. *)
      apply in_map_iff in H1; destruct H1 as [oidx [? ?]]; subst.
      dest_in.
      all: try (disc_RootChnInv; solve_RootChnInv; fail).
      all: try (disc_RootChnInv;
                derive_footprint_info_basis oidx;
                derive_child_chns cidx;
                disc_rule_conds_ex;
                solve_RootChnInv).

      Unshelve.
      all: assumption.

      END_SKIP_PROOF_ON *) admit.
  Qed.

  Theorem msi_RootChnInv_ok:
    InvReachable impl step_m (RootChnInv tr 0).
  Proof.
    eapply inv_reachable.
    - typeclasses eauto.
    - apply msi_RootChnInv_init.
    - apply msi_RootChnInv_step.
  Qed.

End RootChnInv.


From ITree Require Import ITree.
From compcert Require Coqlib.
From compcert Require Import
     AST Memory Globalenvs Maps Values Linking
     Ctypes Clight Clightdefs.

Require Import ZArith String Bool List Lia.

Require Import sflib.
Require Import StdlibExt IntegersExt.
Require Import DiscreteTimeModel IPModel.

Require Import SysSem.
Require Import NWSysModel.
Require Import OSModel OSNodes.
Require Import RTSysEnv.
Require Import CProgEventSem.
Require Import SyncSysModel.
Require Import ProgSem.
Require Import LinkLemmas.
Require Import MWITree.

Require Import config_prm main_prm SystemProgs.
Require Import VerifProgBase.
Require Import MWLinkInversion.
Require Import PALSSystem.

Require Import dev.
Require Import AcStSystem.
(* Require Import LinkDevice. *)

Local Opaque Z.to_nat Z.of_nat PTree.combine.

Import ITreeNotations.
Import ListNotations.

(* Import ActiveStandby. *)

Set Nested Proofs Allowed.

Local Open Scope Z.

Definition MAX_TIMEOUT: nat := 5.

Module DevState.

  Record t: Type :=
    mk { owner_status: bool? ;
         demand: nat ;
       }.

  Inductive wf: t -> Prop :=
    Wf own dmd
       (RANGE_TOUT: (dmd <= MAX_TIMEOUT)%nat)
    : wf (mk own dmd).

  Definition init: t :=
    mk None O.

  Lemma wf_init: wf init.
  Proof.
    econs; ss. nia.
  Qed.

  Definition set_owner_status (own: bool) (st: t): t :=
    let 'mk _ dmd := st in
    mk (Some own) dmd.

  Lemma wf_set_owner_status own st
        (WF: wf st)
    : wf (set_owner_status own st).
  Proof.
    inv WF. econs; ss.
  Qed.

  Definition set_demand (dmd: nat) (st: t): t :=
    let 'mk own _ := st in
    mk own dmd.

  Lemma wf_set_demand
        dmd st
        (VALID_DMD: (dmd <= MAX_TIMEOUT)%nat)
    : wf (set_demand dmd st).
  Proof.
    destruct st.
    econs; ss.
  Qed.

  Definition reduce_demand (st: t): t :=
    let 'mk own dmd := st in
    mk own (pred dmd).

  Lemma wf_reduce_demand
        st (WF_ST: wf st)
    : wf (reduce_demand st).
  Proof.
    inv WF_ST.
    econs; ss.
    nia.
  Qed.

  (* Definition of_bytes (msg: bytes): t := *)
  (*   let md_msg := Byte.signed (nth 0 msg Byte.zero) in *)
  (*   let tout_msg := Byte.signed (nth 1 msg Byte.zero) in *)
  (*   let qb_msg := Byte.signed (nth 2 msg Byte.zero) in *)
  (*   let qe_msg := Byte.signed (nth 3 msg Byte.zero) in *)
  (*   let q1_msg := Byte.signed (nth 4 msg Byte.zero) in *)
  (*   let q2_msg := Byte.signed (nth 5 msg Byte.zero) in *)
  (*   let q3_msg := Byte.signed (nth 6 msg Byte.zero) in *)
  (*   let q4_msg := Byte.signed (nth 7 msg Byte.zero) in *)
  (*   mk (mode_of_Z md_msg) tout_msg qb_msg qe_msg *)
  (*      [q1_msg; q2_msg; q3_msg; q4_msg]. *)

  (* Lemma wf_of_bytes msg: wf (of_bytes msg). *)
  (* Proof. *)
  (*   econs. *)
  (*   - apply Byte.signed_range. *)
  (*   - apply Byte.signed_range. *)
  (*   - apply Byte.signed_range. *)
  (*   - econs; [ apply Byte.signed_range |]. *)
  (*     econs; [ apply Byte.signed_range |]. *)
  (*     econs; [ apply Byte.signed_range |]. *)
  (*     econs; [ apply Byte.signed_range |]. *)
  (*     econs. *)
  (*   - ss. *)
  (* Qed. *)

  Definition owner_status_to_Z (own: bool?): Z :=
    match own with
    | None => 0
    | Some b => if b then 1 else 2
    end.

  Definition to_bytes (st: t): bytes :=
    [ Byte.repr (owner_status_to_Z (owner_status st)) ;
    Byte.repr (Z.of_nat (demand st))].

End DevState.

Import DevState.

Definition check_grant (inb: list bytes?): bool :=
  match nth 1%nat inb None, nth 2%nat inb None with
  | None, None => false
  | _, _ => true
  end.

Definition sync_dev_state (inb: list bytes?) (st: t): t :=
  match nth 1%nat inb None, nth 2%nat inb None with
  | None, None => st
  | _, _ => set_owner_status true st
  end.

Lemma wf_sync_dev_state
      inb st
      (WF_ST: wf st)
  : wf (sync_dev_state inb st).
Proof.
  inv WF_ST.
  unfold sync_dev_state. ss.
  desf.
Qed.

Definition get_new_demand: itree appE nat :=
  d_raw_i <- trigger CheckDemand ;;
  let d_raw := Z.to_nat (Int.signed d_raw_i) in
  Ret (if (MAX_TIMEOUT <? d_raw)%nat then MAX_TIMEOUT else d_raw).

Definition update_demand (st: t): itree appE (t * bool) :=
  if (demand st =? O)%nat then
    d <- get_new_demand ;;
    Ret (if (0 <? d)%nat then
           (set_demand d st, true)
         else (st, false))
  else Ret (st, false).

Definition run_device (st: t): itree appE t :=
  if (0 <? demand st)%nat then
    trigger UseResource ;;
    Ret (reduce_demand st)
  else Ret st.

Definition job_device_itree (sytm: Z) (st: t) (inb: list bytes?)
  : itree appE t :=
  match owner_status st with
  | None =>
    trigger (AbstSendEvent mid_mcast rel_msg) ;;
    trigger (WriteLog 0);;
    Ret (set_owner_status false st)
  | Some is_owner =>
    let st_sync := sync_dev_state inb st in
    '(st_ud, is_dupd) <- update_demand st_sync ;;
    match owner_status st_ud with
    | None => Ret st_ud (* unreachable *)
    | Some is_owner_ud =>
      if is_owner_ud then
        st1 <- run_device st_ud ;;
        if (demand st1 =? O)%nat then
          trigger (AbstSendEvent mid_mcast rel_msg) ;;
          trigger (WriteLog 0);;
          Ret (set_owner_status false st1)
        else
          trigger (WriteLog 0);;
          Ret st1
      else
        (if (is_dupd: bool) then
           trigger (AbstSendEvent mid_mcast acq_msg)
         else Ret tt) ;;
        trigger (WriteLog 0);;
        Ret st_ud
    end
  end.

Definition dev_job
           (sytm: Z) (inb: list bytes?) (st: DevState.t)
  : itree (obsE +' bsendE) DevState.t :=
  job_device_itree sytm st inb.

Definition dev_mod: @AppMod.t obsE bytes :=
  {| AppMod.abst_state_t := DevState.t ;
     AppMod.job_itree := dev_job ;
     AppMod.init_abst_state := DevState.init |}.


From iris.base_logic.lib Require Export fancy_updates wsat.
From iris.proofmode Require Import base tactics classes.
From mwp Require Import mwp mwp_adequacy mwp_lifting.
From mwp.mwp_modalities Require Import mwp_indexed_step_fupd.
From iris.program_logic Require Export ectxi_language ectx_language language.

Section mwp_mwp_ISF.
  Context {Λ Σ} `{!invG Σ} (mwpD_SI mwpD_SI' : state Λ → iProp Σ).
  Typeclasses Transparent mwpC_state_interp mwpC_modality.

  Definition mwpd_mwp_ISF : mwpData Λ Σ :=
    {| mwpD_state_interp := mwpD_SI;
       mwpD_Extra := [Prod val Λ; nat];
       mwpD_modality_index := [Prod expr Λ];
       mwpD_modality_bind_condition e1 e2 f g :=
         ∃ K (_: LanguageCtx K),
           e1 = K e2 ∧ g = (λ x y, (y.1, x.2 + y.2)) ∧
           ∀ v k, f (v, k) = K (of_val v);
      mwpD_modality idx E n Φ :=
        MWP@{mwpd_indexed_step_fupd mwpD_SI', n }
          idx @ E {{ w; k, Φ (w, k) }}%I;
    |}.

  Global Instance mwpC_mwp_ISF : mwpC mwpd_mwp_ISF.
  Proof.
    split.
    - intros idx E m n ? ? ?; simpl. apply mwp_ne.
      intros ? ? ?; auto.
    - intros idx E1 E2 n Φ Ψ HE; simpl.
      iIntros "HP Hic".
      iApply (mwp_strong_mono_wand _ _ _ _ _ _ (λ v m _, _)); eauto; iFrame.
      by iIntros (? ? ?) "?"; iApply "HP".
    - iIntros (idx E n Φ) "H";simpl.
      iApply mwp_indexed_step_fupd_index_intro; last eauto. simpl; lia.
    - intros e e' f g E n m Φ (K & HK & He & Hg & Hf); simplify_eq.
      iIntros "H"; simpl.
      iApply mwp_indexed_step_fupd_bind; simpl.
      iApply (mwp_strong_mono_wand _ _ _ _ _ (λ v m _, _)); eauto; iFrame.
      iIntros (v l _); rewrite Hf /=.
      iIntros "H".
      iApply (mwp_strong_mono_wand _ _ _ _ _ _ (λ v m _, _)); eauto; iFrame.
      by iIntros (? j _) "?".
  Qed.

  Global Instance mwpC_mwp_ISF_is_outer_fupd idx :
    mwpMIsOuterModal mwpd_mwp_ISF idx (λ E _ P, |={E}=> P)%I.
  Proof.
    rewrite /mwpMIsOuterModal /mwpC_modality /mwpD_modality /=.
    iIntros (E n P) "H". by iMod "H".
  Qed.

  Global Instance mwpC_mwp_ISF_is_outer_bupd idx :
    mwpMIsOuterModal mwpd_mwp_ISF idx (λ _ _ P, |==> P)%I.
  Proof.
    rewrite /mwpMIsOuterModal /mwpC_modality /mwpD_modality /=.
    iIntros (E n P) "H". by iMod "H".
  Qed.

  Global Instance mwpC_mwp_ISF_is_outer_except_0 idx :
    mwpMIsOuterModal mwpd_mwp_ISF idx (λ _ _ P, ◇ P)%I.
  Proof.
    rewrite /mwpMIsOuterModal /mwpC_modality /mwpD_modality /=.
    iIntros (E n P) "H". by iMod "H".
  Qed.

  Global Instance mwpC_mwp_ISF_is_inner_fupd idx :
    mwpMIsInnerModal mwpd_mwp_ISF idx (λ E _ P, |={E}=> P)%I.
  Proof.
    rewrite /mwpMIsInnerModal /mwpC_modality /mwpD_modality /=.
    iIntros (E n P) "H".
    by iApply (mwp_fupd _ _ _ _ (λ v m _, _)).
  Qed.

  Global Instance mwpC_mwp_ISF_is_inner_bupd idx :
    mwpMIsInnerModal mwpd_mwp_ISF idx (λ _ _ P, |==> P)%I.
  Proof.
    rewrite /mwpMIsInnerModal /mwpC_modality /mwpD_modality /=.
    iIntros (E n P) "H".
    by iApply (mwp_bupd _ _ _ _ (λ v m _, _)).
  Qed.

  Global Instance mwpC_mwp_ISF_is_inner_except_0 idx :
    mwpMIsInnerModal mwpd_mwp_ISF idx (λ _ _ P, ◇ P)%I.
  Proof.
    rewrite /mwpMIsInnerModal /mwpC_modality /mwpD_modality /=.
    iIntros (E n P) "H".
    by iApply (mwp_except_0 _ _ _ _ (λ v m _, _)).
  Qed.

  Global Instance mwpC_mwp_ISF_SupportsAtomicShift idx :
    mwpMSupportsAtomicShift mwpd_mwp_ISF idx.
  Proof.
    rewrite /mwpMSupportsAtomicShift /mwpC_modality /mwpD_modality /=.
    iIntros (n E1 E2 Φ Hn) "H".
    iApply (mwp_shift (mwpd_indexed_step_fupd mwpD_SI'));
      eauto using mwp_indexed_step_fupd_AlwaysSupportsShift.
  Qed.

  Global Program Instance mwpC_mwp_ISF_SplitForStep idx :
    mwpMSplitForStep mwpd_mwp_ISF idx :=
    {|
      mwpM_split_for_step_M1 E P := |={E, ∅}=> ▷ P;
      mwpM_split_for_step_M2 E P := |={∅, E}=> P;
    |}%I.
  Next Obligation.
  Proof.
    iIntros (e n E P) "HP /=".
    rewrite /mwpC_modality /mwpD_modality /=.
    by iApply (mwp_indexed_step_fupd_index_step_fupd _ _ 1).
  Qed.
  Next Obligation.
  Proof.
    iIntros (idx E P Q) "HPQ HP /=".
    by iMod "HP"; iModIntro; iApply "HPQ".
  Qed.
  Next Obligation.
  Proof.
    iIntros (idx E P Q) "HPQ HP /=".
    iMod "HP"; iModIntro. by iApply "HPQ".
  Qed.

  Lemma mwp_mwp_ISF_strong_bind
        K `{!LanguageCtx K} K' `{!LanguageCtx K'} E e e' Φ :
    MWP@{mwpd_mwp_ISF, e'} e @ E {{ v; m | w ; k,
      MWP@{mwpd_mwp_ISF, K' (of_val w)}
        K (of_val v) @ E {{ w; n | u ; y, Φ w (m + n) (u, (k + y)) }} }}
    ⊢ MWP@{mwpd_mwp_ISF, K' e'} K e @ E {{ Φ }}.
  Proof.
    iIntros "H".
    iApply (@mwp_bind _ _ _ mwpC_mwp_ISF K _ _ e'
                     (λ '(v, k), K' (of_val v))
                     (λ x y, (y.1, x.2 + y.2))).
    { rewrite /mwpC_modality_bind_condition /=; eauto. }
    iApply mwp_mono; last eauto.
    intros ? ? []; auto.
  Qed.

Lemma mwp_mwp_ISF_change_of_index e1' e2' f E e Φ :
  (∀ Ψ n,
      MWP@{mwpd_indexed_step_fupd mwpD_SI', n}
        e1' @ E {{ v; n | [_], Ψ (f (v, n)) }} -∗
        MWP@{mwpd_indexed_step_fupd mwpD_SI', n}
        e2' @ E {{ v; n | [_], Ψ (v, n) }})
  -∗ MWP@{mwpd_mwp_ISF, e1'} e @ E {{ λ v n x, Φ v n (f x) }}
  -∗ MWP@{mwpd_mwp_ISF, e2'} e @ E {{ Φ }}.
Proof.
  iIntros "Hm H".
  iApply (mwp_change_of_index mwpd_mwp_ISF with "[Hm] H").
  iIntros (Ψ n) "H".
  by iApply "Hm".
Qed.

End mwp_mwp_ISF.

Section lifting.

Context {Λ Σ} `{!invG Σ} (mwpD_SI mwpD_SI': state Λ → iProp Σ).
Implicit Types v : val Λ.
Implicit Types e : expr Λ.
Implicit Types σ : state Λ.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val Λ → nat → val Λ * nat → iProp Σ.

Typeclasses Transparent mwpC_state_interp mwpD_state_interp mwpC_modality.

Lemma mwp_fupd_lift_step idx E Φ e1 :
  to_val e1 = None →
    (∀ σ1, mwpD_SI σ1 -∗
      |={E, ∅}=>
     ▷ ∀ e2 σ2,
         ⌜prim_step e1 σ1 [] e2 σ2 []⌝ ={∅, E}=∗
            (mwpD_SI σ2 ∗ MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx}
                    e2 @ E {{ v; n| [x], Φ v (S n) x }}))
    ⊢ MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  iIntros (?) "?".
  iApply (mwp_lift_step (mwpd_mwp_ISF mwpD_SI mwpD_SI') idx E); simpl; auto.
Qed.

Lemma mwp_mwp_ISF_lift_pure_step idx E Φ e1 :
  to_val e1 = None →
  (∀ σ1 e2 σ2, prim_step e1 σ1 [] e2 σ2 [] → σ1 = σ2) →
  ▷ (∀ σ1 e2 σ2,
      ⌜prim_step e1 σ1 [] e2 σ2 []⌝ →
      MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx} e2 @ E
        {{ v; n | [x], Φ v (S n) x }})
    ⊢ MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  iIntros(??) "H".
  iApply (mwp_lift_pure_step
            (mwpd_mwp_ISF mwpD_SI mwpD_SI') idx E);
    simpl; eauto.
  by iApply step_fupd_intro; first set_solver.
Qed.

Lemma mwp_mwp_ISF_lift_atomic_step idx E Φ e1 :
  to_val e1 = None →
  Atomic StronglyAtomic e1 →
   (∀ σ1, mwpD_SI σ1 ={E, ∅}=∗
        ▷ ∀ v2 σ2,
            ⌜prim_step e1 σ1 [] (of_val v2) σ2 []⌝
             ={∅, E}=∗ (mwpD_SI σ2 ∗
                        MWP@{mwpd_indexed_step_fupd mwpD_SI', 0}
                          idx @ E {{ v; n, Φ v2 1 (v, n) }}))
    ⊢ MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  iIntros (??).
  by iApply (mwp_lift_atomic_step
               (mwpd_mwp_ISF mwpD_SI mwpD_SI') idx E).
Qed.

Lemma mwp_mwp_ISF_lift_atomic_det_step idx E Φ e1 :
  to_val e1 = None →
  Atomic StronglyAtomic e1 →
  (∀ σ1, mwpD_SI σ1 ={E, ∅}=∗
     ▷ (∃ v2 σ2,
         ⌜∀ e2' σ2', prim_step e1 σ1 [] e2' σ2' [] →
                     σ2 = σ2' ∧ to_val e2' = Some v2⌝ ∧
                     |={∅, E}=> mwpD_SI σ2 ∗
                          MWP@{mwpd_indexed_step_fupd mwpD_SI', 0}
                          idx @ E {{ v; n, Φ v2 1 (v, n) }}))
    ⊢ MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  by iIntros (??);
    iApply (mwp_lift_atomic_det_step
              (mwpd_mwp_ISF mwpD_SI mwpD_SI') idx E Φ e1).
Qed.

Lemma mwp_mwp_ISF_lift_pure_det_step idx E Φ e1 e2 :
  to_val e1 = None →
  (∀ σ1 e2' σ2, prim_step e1 σ1 [] e2' σ2 [] → σ1 = σ2 ∧ e2 = e2')→
  ▷ MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx}
    e2 @ E {{ v; n | [x], Φ v (S n) x }}
  ⊢ MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  iIntros(??) "H".
  iApply (mwp_lift_pure_det_step
            (mwpd_mwp_ISF mwpD_SI mwpD_SI') idx E Φ e1);
    simpl; eauto.
  by iApply step_fupd_intro; first set_solver.
Qed.

Lemma mwp_mwp_ISF_pure_step `{!Inhabited (state Λ)} idx E e1 e2 φ n Φ :
  PureExec φ n e1 e2 →
  φ →
  ▷^n MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx}
    e2 @ E {{ v ; m | [x], Φ v (n + m) x }}
  ⊢ MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  iIntros (Hexec Hφ) "Hic".
  iApply (mwp_pure_step (mwpd_mwp_ISF mwpD_SI mwpD_SI') idx); eauto.
  clear Hexec.
  iInduction n as [] "IH" forall (Φ); simpl; auto.
  iApply step_fupd_intro; first set_solver.
  iApply ("IH" $! (λ w k, Φ w (S k)) with "Hic").
Qed.

End lifting.

Section mwp_ectx_lifting.

Context {Λ : ectxLanguage}.
Context {Σ} `{!invG Σ} (mwpD_SI mwpD_SI' : state Λ → iProp Σ).
Implicit Types v : val Λ.
Implicit Types e : expr Λ.
Implicit Types σ : state Λ.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val Λ → nat → val Λ * nat → iProp Σ.

Typeclasses Transparent mwpC_state_interp mwpD_state_interp mwpC_modality.

Lemma mwp_mwp_ISF_lift_head_step idx E Φ e1 :
  to_val e1 = None →
  sub_redexes_are_values e1 →
   (∀ σ1, mwpD_SI σ1 ={E, ∅}=∗
        ▷ ∀ e2 σ2,
            ⌜head_step e1 σ1 [] e2 σ2 []⌝ ={∅, E}=∗
             (mwpD_SI σ2 ∗ MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx}
                          e2 @ E {{ w; n | [x], Φ w (S n) x }}))
    ⊢ MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  by intros;
    iApply (mwp_lift_head_step
              (mwpd_mwp_ISF mwpD_SI mwpD_SI') idx E Φ e1).
Qed.

Lemma mwp_mwp_ISF_lift_pure_head_step idx E Φ e1 :
  to_val e1 = None →
  sub_redexes_are_values e1 →
  (∀ σ1 e2 σ2, head_step e1 σ1 [] e2 σ2 [] → σ1 = σ2) →
  ▷ (∀ σ1 e2 σ2,
      ⌜head_step e1 σ1 [] e2 σ2 []⌝ →
      MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx}
        e2 @ E {{ w; n| [x], Φ w (S n) x }})
    ⊢ MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  iIntros(???) "H".
  iApply (mwp_lift_pure_head_step
            (mwpd_mwp_ISF mwpD_SI mwpD_SI') idx E Φ e1);
    simpl; eauto.
  by iApply step_fupd_intro; first set_solver.
Qed.

Lemma mwp_mwp_ISF_lift_atomic_head_step idx E Φ e1 :
  to_val e1 = None →
  sub_redexes_are_values e1 →
  Atomic StronglyAtomic e1 →
   (∀ σ1, mwpD_SI σ1 ={E, ∅}=∗
     ▷ ∀ v2 σ2,
       ⌜head_step e1 σ1 [] (of_val v2) σ2 []⌝ ={∅, E}=∗
          (mwpD_SI σ2 ∗ MWP@{mwpd_indexed_step_fupd mwpD_SI', 0}
                          idx @ E {{ v; n, Φ v2 1 (v, n) }}))
     ⊢ MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  by intros;
    iApply (mwp_lift_atomic_head_step
              (mwpd_mwp_ISF mwpD_SI mwpD_SI') idx E Φ e1).
Qed.

Lemma mwp_mwp_ISF_lift_pure_det_head_step idx E Φ e1 e2 :
  to_val e1 = None →
  sub_redexes_are_values e1 →
  (∀ σ1 e2' σ2, head_step e1 σ1 [] e2' σ2 [] → σ1 = σ2 ∧ e2 = e2')→
  ▷ MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx}
    e2 @ E {{ v; n | [x], Φ v (S n) x }}
  ⊢ MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  iIntros(???) "H".
  iApply (mwp_lift_pure_det_head_step
            (mwpd_mwp_ISF mwpD_SI mwpD_SI') idx E Φ e1);
    simpl; eauto.
  by iApply step_fupd_intro; first set_solver.
Qed.

End mwp_ectx_lifting.

Section mwp_ectxi_lifting.

Context {Λ : ectxiLanguage}.
Context {Σ} `{!invG Σ} (mwpD_SI mwpD_SI' : state Λ → iProp Σ).

Implicit Types P : iProp Σ.
Implicit Types Φ : (val Λ) → nat → val Λ * nat → iProp Σ.
Implicit Types v : (val Λ).
Implicit Types e : (expr Λ).

Typeclasses Transparent mwpC_state_interp mwpD_state_interp mwpC_modality.

Lemma mwp_mwp_ISF_lift_head_step' idx E Φ e1 :
  to_val e1 = None →
  (∀ Ki e', e1 = fill_item Ki e' → is_Some (to_val e')) →
   (∀ σ1, mwpD_SI σ1 ={E, ∅}=∗
        ▷ (∀ e2 σ2,
            ⌜head_step e1 σ1 [] e2 σ2 []⌝ ={∅, E}=∗
             (mwpD_SI σ2 ∗ MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx}
                            e2 @ E {{ w; n | [x], Φ w (S n) x }})))
     ⊢ MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  by iIntros (??);
    iApply (mwp_lift_head_step'
              (mwpd_mwp_ISF mwpD_SI mwpD_SI') idx E Φ e1).
Qed.

Lemma mwp_mwp_ISF_lift_pure_head_step' idx E Φ e1 :
  to_val e1 = None →
  (∀ Ki e', e1 = fill_item Ki e' → is_Some (to_val e')) →
  (∀ σ1 e2 σ2, head_step e1 σ1 [] e2 σ2 [] → σ1 = σ2) →
  ▷ (∀ σ1 e2 σ2,
       ⌜head_step e1 σ1 [] e2 σ2 []⌝ →
       MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx}
         e2 @ E {{ w; n | [x], Φ w (S n) x }})
     ⊢ MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  iIntros (???) "?".
  iApply (mwp_lift_pure_head_step'
            (mwpd_mwp_ISF mwpD_SI mwpD_SI') idx E Φ e1); eauto.
   by iApply step_fupd_intro; first set_solver.
Qed.

Lemma mwp_mwp_ISF_lift_atomic_head_step' idx E Φ e1:
  to_val e1 = None →
  (∀ Ki e', e1 = fill_item Ki e' → is_Some (to_val e')) →
  Atomic StronglyAtomic e1 →
   (∀ σ1, mwpD_SI σ1 ={E, ∅}=∗
      ▷ (∀ v2 σ2,
          ⌜head_step e1 σ1 [] (of_val v2) σ2 []⌝ ={∅, E}=∗
           (mwpD_SI σ2 ∗ MWP@{mwpd_indexed_step_fupd mwpD_SI', 0}
                          idx @ E {{ v; n, Φ v2 1 (v, n) }})))
    ⊢ MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  iIntros (???).
  by iApply (mwp_lift_atomic_head_step'
               (mwpd_mwp_ISF mwpD_SI mwpD_SI') idx E Φ e1).
Qed.

Lemma mwp_mwp_ISF_lift_pure_det_head_step' idx E Φ e1 e2 :
  to_val e1 = None →
  (∀ Ki e', e1 = fill_item Ki e' → is_Some (to_val e')) →
  (∀ σ1 e2' σ2, head_step e1 σ1 [] e2' σ2 [] → σ1 = σ2 ∧ e2 = e2') →
  ▷ MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx}
    e2 @ E {{ v; n | [x], Φ v (S n) x }}
  ⊢ MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  iIntros (???) "?".
  iApply (mwp_lift_pure_det_head_step'
            (mwpd_mwp_ISF mwpD_SI mwpD_SI') idx E Φ e1); eauto.
  by iApply step_fupd_intro; first set_solver.
Qed.

End mwp_ectxi_lifting.

Section basmwp_soundness.
Context {Λ Σ} `{!invG Σ} (mwpD_SI mwpD_SI' : state Λ → iProp Σ).

Typeclasses Transparent mwpC_state_interp mwpC_modality.

Lemma mwp_mwp_ISF_adequacy_basic idx E e σ Φ :
  mwpD_SI σ ∗ MWP@{mwpd_mwp_ISF mwpD_SI mwpD_SI', idx} e @ E {{ λ v n x, Φ v n x.1 x.2 }} -∗
    ∀ (rd : Reds e σ),
      MWP@{mwpd_indexed_step_fupd mwpD_SI', nstps rd}
                          idx @ E {{ v; n, mwpD_SI (end_state rd) ∗
                                          Φ (end_val rd) (nstps rd) v n }}.
Proof.
  iApply (mwp_adequacy_basic
            (mwpd_mwp_ISF mwpD_SI mwpD_SI') idx E e σ (λ v n x, Φ v n x.1 x.2)).
Qed.

End basmwp_soundness.

Section soundness.
  Context {Λ Σ} `{!invPreG Σ}
          {SI_data : Type} (mwpD_SI : SI_data → state Λ → iProp Σ)
          {SI_data' : Type} (mwpD_SI' : SI_data' → state Λ → iProp Σ).

Typeclasses Transparent mwpC_state_interp mwpC_modality.

Program Instance mwp_ISF_Initialization
        SSI SSI' `{!InitData SSI} `{!InitData SSI'} e' σ' :
  Initialization
    (val Λ * nat)
    (λ x : invG_pack Σ (SI_data * SI_data'),
           mwpd_mwp_ISF (mwpD_SI (PIG_cnt x).1) (mwpD_SI' (PIG_cnt x).2))
    (λ x, @mwpC_mwp_ISF Λ Σ _ (mwpD_SI (PIG_cnt x).1) (mwpD_SI' (PIG_cnt x).2))
    (λ _, e') :=
{|
  initialization_modality Hi P := |={⊤}=> P;
  initialization_seed_for_modality _ := wsat ∗ ownE ⊤;
  initialization_seed_for_state_interp x := SSI (PIG_cnt x).1 ∗ SSI' (PIG_cnt x).2;
  initialization_residue _ := ▷ wsat ∗ ▷ ownE ⊤;
  initialization_elim_laters := 1;
  initialization_mwpCM_soundness_arg := Reds e' σ';
  initialization_mwpCM_soundness_laters n _ := S (S n);
  initialization_modality_initializer x _ := mwpD_SI' (PIG_cnt x).2 σ';
  initialization_mwpCM_soundness_fun rd := (end_val rd, nstps rd);
  initialization_Ex_conv _ x := x;
|}%I.
Next Obligation.
Proof.
  intros; simpl.
  iApply init_data.
  apply (init_invGpack (λ x, SSI x.1 ∗ SSI' x.2))%I.
Qed.
Next Obligation.
Proof.
  iIntros (???? e' σ' P Hi) "[Hs HE] HP".
  rewrite uPred_fupd_eq /uPred_fupd_def.
  iMod ("HP" with "[$]") as "(Hs & HE & HP)".
  iModIntro. rewrite -!bi.later_sep.
  iMod "Hs"; iMod "HE"; iMod "HP". iNext.
  iFrame.
Qed.
Next Obligation.
Proof.
  simpl.
  iIntros (???? e' σ' Hi P E n rd) "[[Hs HE] [Hσ' HP]]".
  iNext.
  rewrite /mwpC_modality /mwpD_modality /=.
  iDestruct (mwp_indexed_step_fupd_adequacy_basic with "[Hσ' $HP]")
    as "HP"; eauto.
  iSpecialize ("HP" $! rd).
  rewrite uPred_fupd_eq /uPred_fupd_def /=.
  replace ⊤ with ((⊤ ∖ E) ∪ E) by by rewrite difference_union_L; set_solver.
  iDestruct (ownE_op with "HE") as "[_ HE]"; first set_solver.
  iInduction n as [] "IH".
  { iMod ("HP" with "[$Hs $HE]") as "(Hs & HE & ? & HP)".
    by iMod "HP". }
  simpl.
  iMod ("HP" with "[$Hs $HE]") as "(Hs & HE & HP)".
  iMod "HP"; iMod "Hs"; iMod "HE".
  iNext.
  iMod ("HP" with "[$Hs $HE]") as "(Hs & HE & HP)".
  iMod "HP"; iMod "Hs"; iMod "HE".
  iApply ("IH" with "Hs HP HE").
Qed.

Lemma mwp_mwp_ISF_adequacy
      SSI SSI' `{!InitData SSI} `{!InitData SSI'}
      E e σ (e' : expr Λ) σ' (Ψ : val Λ → nat → val Λ → nat → Prop) :
  (∀ (x : invG_pack Σ (SI_data * SI_data')),
       SSI (PIG_cnt x).1 ∗ SSI' (PIG_cnt x).2 ⊢
       |={⊤}=> (mwpD_SI (PIG_cnt x).1 σ ∗ mwpD_SI' (PIG_cnt x).2 σ' ∗
              MWP@{mwpd_mwp_ISF (mwpD_SI (PIG_cnt x).1) (mwpD_SI' (PIG_cnt x).2), e'}
              e @ E {{ v ; n| w; k,  ⌜Ψ v n w k⌝ }}))
  → ∀ (rd : Reds e σ) (rd' : Reds e' σ'),
    Ψ (end_val rd) (@nstps Λ _ _ rd) (end_val rd') (@nstps Λ _ _ rd').
Proof.
  intros Hic rd rd'.
  by apply (mwp_adequacy
              _ _ _ _ (mwp_ISF_Initialization SSI SSI' e' σ') E e σ
              (λ v n x, Ψ v n x.1 x.2) rd').
Qed.

End soundness.


From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
From fcsl
Require Import prelude pred pcm unionmap heap.
From HTT
Require Import stmod stsep stlog stlogR.
From SSL
Require Import core.
From Hammer Require Import Hammer.
(* Configure Hammer *)
Set Hammer ATPLimit 60.
Unset Hammer Eprover.
Unset Hammer Vampire.
Add Search Blacklist "fcsl.".
Add Search Blacklist "HTT.".
Add Search Blacklist "Coq.ssr.ssrfun".
Add Search Blacklist "mathcomp.ssreflect.ssrfun".
Add Search Blacklist "mathcomp.ssreflect.bigop".
Add Search Blacklist "mathcomp.ssreflect.choice".
Add Search Blacklist "mathcomp.ssreflect.div".
Add Search Blacklist "mathcomp.ssreflect.finfun".
Add Search Blacklist "mathcomp.ssreflect.fintype".
Add Search Blacklist "mathcomp.ssreflect.path".
Add Search Blacklist "mathcomp.ssreflect.tuple".

Require Import common.

Lemma sll_perm_eq_congr2 x h s_1 s_2 : perm_eq s_1 s_2 -> sll x s_1 h -> sll x s_2 h.
  (* intros; hammer *)
  move=>Heq Hsll; sslauto.
  case: Hsll=>cond.
  move=>[Heq1 ->].
  constructor 1=>//=; sslauto.
  move=>[v] [s2] [nxt] [h'].
  move=>[Heq1 [-> Hssl]].
  constructor 2=>//=.
  exists v, s2, nxt, h'.
  sslauto.
  assumption.
Qed.
Hint Resolve sll_perm_eq_congr2: ssl_pred.
Lemma pure2 (x : nat) (y : nat) : @perm_eq nat_eqType ([:: x; y]) (([:: y]) ++ ([:: x])).
  (* intros; hammer. *)
  solve_perm_eq.
Qed.
Hint Resolve pure2: ssl_pure.

Definition sll_dupleton_type :=
  forall (vprogs : nat * nat * ptr),
  {(vghosts : ptr)},
  STsep (
    fun h =>
      let: (x, y, r) := vprogs in
      let: (a) := vghosts in
      h = r :-> (a),
    [vfun (_: unit) h =>
      let: (x, y, r) := vprogs in
      let: (a) := vghosts in
      exists elems z,
      exists h_sll_zelems_1,
      @perm_eq nat_eqType (elems) ([:: x; y]) /\ h = r :-> (z) \+ h_sll_zelems_1 /\ sll z elems h_sll_zelems_1
    ]).

Program Definition sll_dupleton : sll_dupleton_type :=
  Fix (fun (sll_dupleton : sll_dupleton_type) vprogs =>
    let: (x, y, r) := vprogs in
    Do (
      a1 <-- @read ptr r;
      z1 <-- allocb null 2;
      nxtz1 <-- allocb null 2;
      r ::= z1;;
      (z1 .+ 1) ::= nxtz1;;
      (nxtz1 .+ 1) ::= null;;
      nxtz1 ::= x;;
      z1 ::= y;;
      ret tt
    )).
Obligation Tactic := intro; move=>[[x y] r]; ssl_program_simpl.
Next Obligation.
ssl_ghostelim_pre.
move=>a.
move=>[sigma_self].
subst h_self.
ssl_ghostelim_post.
try rename h_sll_zelems_1 into h_sll_zxy_1.
try rename H_sll_zelems_1 into H_sll_zxy_1.
ssl_read r.
try rename a into a1.
try rename h_sll_nxtzs1z_0z into h_sll_nxtzvnxtzs1nxtz_0z.
try rename H_sll_nxtzs1z_0z into H_sll_nxtzvnxtzs1nxtz_0z.
try rename h_sll_nxtnxtzs1nxtz_0nxtz into h_sll_s1nxtz_0nxtz.
try rename H_sll_nxtnxtzs1nxtz_0nxtz into H_sll_s1nxtz_0nxtz.
try rename h_sll_s1nxtz_0nxtz into h_sll__0nxtz.
try rename H_sll_s1nxtz_0nxtz into H_sll__0nxtz.
try rename h_sll_nxtzvnxtzs1nxtz_0z into h_sll_nxtzvnxtz_0z.
try rename H_sll_nxtzvnxtzs1nxtz_0z into H_sll_nxtzvnxtz_0z.
ssl_alloc z1.
try rename z into z1.
try rename h_sll_zxy_1 into h_sll_z1xy_1.
try rename H_sll_zxy_1 into H_sll_z1xy_1.
ssl_alloc nxtz1.
try rename nxtz into nxtz1.
try rename h_sll_nxtzvnxtz_0z into h_sll_nxtz1vnxtz_0z.
try rename H_sll_nxtzvnxtz_0z into H_sll_nxtz1vnxtz_0z.
ssl_write r.
ssl_write_post r.
ssl_write (z1 .+ 1).
ssl_write_post (z1 .+ 1).
ssl_write (nxtz1 .+ 1).
ssl_write_post (nxtz1 .+ 1).
try rename h_sll_nxtz1vnxtz_0z into h_sll_nxtz1x_0z.
try rename H_sll_nxtz1vnxtz_0z into H_sll_nxtz1x_0z.
ssl_write nxtz1.
ssl_write_post nxtz1.
ssl_write z1.
ssl_write_post z1.
ssl_emp;
exists ([:: x; y]), (z1);
exists (z1 :-> (y) \+ z1 .+ 1 :-> (nxtz1) \+ nxtz1 :-> (x) \+ nxtz1 .+ 1 :-> (null));
sslauto.
ssl_close 2;
exists (y), (([:: x]) ++ (@nil nat)), (nxtz1), (nxtz1 :-> (x) \+ nxtz1 .+ 1 :-> (null));
sslauto.
ssl_close 2;
exists (x), (@nil nat), (null), (empty);
sslauto.
ssl_close 1;
sslauto.
Qed.


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

(** Function calling conventions and other conventions regarding the use of
    machine registers and stack slots. *)

Require Import Coqlib.
Require Import AST.
Require Import Locations.
Require Export Conventions1.

(** The processor-dependent and EABI-dependent definitions are in
    [arch/abi/Conventions1.v].  This file adds various processor-independent
    definitions and lemmas. *)

Lemma loc_arguments_acceptable_2:
  forall s l,
  In l (regs_of_rpairs (loc_arguments s)) -> loc_argument_acceptable l.
Proof.
  intros until l. generalize (loc_arguments_acceptable s). generalize (loc_arguments s).
  induction l0 as [ | p pl]; simpl; intros.
- contradiction.
- rewrite in_app_iff in H0. destruct H0.
  exploit H; eauto. destruct p; simpl in *; intuition congruence.
  apply IHpl; auto.
Qed.

(** ** Stack size of function arguments *)

(** [size_arguments s] returns the number of [Outgoing] slots used
  to call a function with signature [s]. *)

Definition max_outgoing_1 (accu: Z) (l: loc) : Z :=
  match l with
  | S Outgoing ofs ty => Z.max accu (ofs + typesize ty)
  | _ => accu
  end.

Definition max_outgoing_2 (accu: Z) (rl: rpair loc) : Z :=
  match rl with
  | One l => max_outgoing_1 accu l
  | Twolong l1 l2 => max_outgoing_1 (max_outgoing_1 accu l1) l2
  end.

Definition size_arguments (s: signature) : Z :=
  List.fold_left max_outgoing_2 (loc_arguments s) 0.

(** The offsets of [Outgoing] arguments are below [size_arguments s]. *)

Remark fold_max_outgoing_above:
  forall l n, fold_left max_outgoing_2 l n >= n.
Proof.
  assert (A: forall n l, max_outgoing_1 n l >= n).
  { intros; unfold max_outgoing_1. destruct l as [_ | []]; extlia. }
  induction l; simpl; intros.
  - lia.
  - eapply Zge_trans. eauto.
    destruct a; simpl. apply A. eapply Zge_trans; eauto.
Qed.

Lemma size_arguments_above:
  forall s, size_arguments s >= 0.
Proof.
  intros. apply fold_max_outgoing_above.
Qed.

Lemma loc_arguments_bounded:
  forall (s: signature) (ofs: Z) (ty: typ),
  In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments s)) ->
  ofs + typesize ty <= size_arguments s.
Proof.
  intros until ty.
  assert (A: forall n l, n <= max_outgoing_1 n l).
  { intros; unfold max_outgoing_1. destruct l as [_ | []]; extlia. }
  assert (B: forall p n,
             In (S Outgoing ofs ty) (regs_of_rpair p) ->
             ofs + typesize ty <= max_outgoing_2 n p).
  { intros. destruct p; simpl in H; intuition; subst; simpl.
  - extlia.
  - eapply Z.le_trans. 2: apply A. extlia.
  - extlia. }
  assert (C: forall l n,
             In (S Outgoing ofs ty) (regs_of_rpairs l) ->
             ofs + typesize ty <= fold_left max_outgoing_2 l n).
  { induction l; simpl; intros.
  - contradiction.
  - rewrite in_app_iff in H. destruct H.
  + eapply Z.le_trans. eapply B; eauto.
    apply Z.ge_le. apply fold_max_outgoing_above.
  + apply IHl; auto.
  }
  apply C.
Qed.

(** ** Location of function parameters *)

(** A function finds the values of its parameter in the same locations
  where its caller stored them, except that the stack-allocated arguments,
  viewed as [Outgoing] slots by the caller, are accessed via [Incoming]
  slots (at the same offsets and types) in the callee. *)

Definition parameter_of_argument (l: loc) : loc :=
  match l with
  | S Outgoing n ty => S Incoming n ty
  | _ => l
  end.

Definition loc_parameters (s: signature) : list (rpair loc) :=
  List.map (map_rpair parameter_of_argument) (loc_arguments s).

Lemma incoming_slot_in_parameters:
  forall ofs ty sg,
  In (S Incoming ofs ty) (regs_of_rpairs (loc_parameters sg)) ->
  In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments sg)).
Proof.
  intros.
  replace (regs_of_rpairs (loc_parameters sg)) with (List.map parameter_of_argument (regs_of_rpairs (loc_arguments sg))) in H.
  change (S Incoming ofs ty) with (parameter_of_argument (S Outgoing ofs ty)) in H.
  exploit list_in_map_inv. eexact H. intros [x [A B]]. simpl in A.
  exploit loc_arguments_acceptable_2; eauto. unfold loc_argument_acceptable; intros.
  destruct x; simpl in A; try discriminate.
  destruct sl; try contradiction.
  inv A. auto.
  unfold loc_parameters. generalize (loc_arguments sg). induction l as [ | p l]; simpl; intros.
  auto.
  rewrite map_app. f_equal; auto. destruct p; auto.
Qed.

(** * Tail calls *)

(** A tail-call is possible for a signature if the corresponding
    arguments are all passed in registers. *)

(** A tail-call is possible for a signature if the corresponding
    arguments are all passed in registers. *)

Definition tailcall_possible (s: signature) : Prop :=
  forall l, In l (regs_of_rpairs (loc_arguments s)) ->
  match l with R _ => True | S _ _ _ => False end.

(** Decide whether a tailcall is possible. *)

Definition tailcall_is_possible (sg: signature) : bool :=
  List.forallb
    (fun l => match l with R _ => true | S _ _ _ => false end)
    (regs_of_rpairs (loc_arguments sg)).

Lemma tailcall_is_possible_correct:
  forall s, tailcall_is_possible s = true -> tailcall_possible s.
Proof.
  unfold tailcall_is_possible; intros. rewrite forallb_forall in H.
  red; intros. apply H in H0. destruct l; [auto|discriminate].
Qed.

Lemma zero_size_arguments_tailcall_possible:
  forall sg, size_arguments sg = 0 -> tailcall_possible sg.
Proof.
  intros; red; intros. exploit loc_arguments_acceptable_2; eauto.
  unfold loc_argument_acceptable.
  destruct l; intros. auto. destruct sl; try contradiction. destruct H1.
  generalize (loc_arguments_bounded _ _ _ H0).
  generalize (typesize_pos ty). lia.
Qed.

(** * Callee-save locations *)

(** We classify locations as either
- callee-save, i.e. preserved across function calls:
  callee-save registers, [Local] and [Incoming] stack slots;
- caller-save, i.e. possibly modified by a function call:
  non-callee-save registers, [Outgoing] stack slots.

Concerning [Outgoing] stack slots: several ABIs allow a function to modify
the stack slots used for passing parameters to this function.
The code currently generated by CompCert never does so, but the code
generated by other compilers often does so (e.g. GCC for x86-32).
Hence, CompCert-generated code must not assume that [Outgoing] stack slots
are preserved across function calls, because they might not be preserved
if the called function was compiled by another compiler.
*)

Definition callee_save_loc (l: loc) :=
  match l with
  | R r => is_callee_save r = true
  | S sl ofs ty => sl <> Outgoing
  end.

Definition agree_callee_save (ls1 ls2: Locmap.t) : Prop :=
  forall l, callee_save_loc l -> ls1 l = ls2 l.

(** * Assigning result locations *)

(** Useful lemmas to reason about the result of an external call. *)

Lemma locmap_get_set_loc_result:
  forall sg v rs l,
  match l with R r => is_callee_save r = true | S _ _ _ => True end ->
  Locmap.setpair (loc_result sg) v rs l = rs l.
Proof.
  intros. apply Locmap.gpo.
  assert (X: forall r, is_callee_save r = false -> Loc.diff l (R r)).
  { intros. destruct l; simpl. congruence. auto. }
  generalize (loc_result_caller_save sg). destruct (loc_result sg); simpl; intuition auto.
Qed.

Lemma locmap_get_set_loc_result_callee_save:
  forall sg v rs l,
  callee_save_loc l ->
  Locmap.setpair (loc_result sg) v rs l = rs l.
Proof.
  intros. apply locmap_get_set_loc_result.
  red in H; destruct l; auto.
Qed.


Add Search Blacklist "Private_" "_subproof".
Set Printing Depth 50.
Remove Search Blacklist "Private_" "_subproof".
Add Search Blacklist "Private_" "_subproof".
Add LoadPath "../..".
Require Import BetaJulia.BasicPLDefs.Identifier.
Require Import BetaJulia.Sub0280a.BaseDefs.
Require Import BetaJulia.Sub0280a.BaseProps.
Require Import BetaJulia.Sub0280a.BaseMatchProps.
Require Import BetaJulia.Sub0280a.BaseSemSubProps.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Lemma sem_sub_k_exist_fresh_l : forall (k : nat) (X : id) (t : ty), fresh_in_ty X t -> ||-[ k][TExist X t]<= [t].
Proof.
(intros k X t Hfresh).
(intros w1).
exists w1.
(intros v Hm).
(destruct w1).
-
(apply match_ty_exist__0_inv in Hm; contradiction).
-
(apply match_ty_exist__inv in Hm).
(destruct Hm as [tx Hm]).
(simpl in Hm).
(rewrite subs_fresh_in_ty in Hm; try assumption).
(eapply match_ty__ge_w).
eassumption.
(repeat constructor).
Qed.
Lemma sem_sub_k_exist_fresh_r : forall (k : nat) (X : id) (t : ty), fresh_in_ty X t -> ||-[ k][t]<= [TExist X t].
Proof.
(intros k X t Hfresh).
(intros w1).
exists (S w1).
(intros v Hm).
(apply match_ty_exist).
exists (TEV X).
(rewrite subs_fresh_in_ty; assumption).
Qed.
Lemma sem_sub_exist_fresh_l : forall (X : id) (t : ty), fresh_in_ty X t -> ||- [TExist X t]<= [t].
Proof.
(intros X t Hfresh k).
(apply sem_sub_k_exist_fresh_l).
assumption.
Qed.
Lemma sem_sub_k_exist_pair : forall (k : nat) (X : id) (t1 t2 : ty), ||-[ k][TExist X (TPair t1 t2)]<= [TPair (TExist X t1) (TExist X t2)].
Proof.
(intros k X t1 t2 w1).
exists w1.
(intros v Hm).
(destruct w1).
-
(apply match_ty_exist__0_inv in Hm; contradiction).
-
(apply match_ty_exist__inv in Hm).
(destruct Hm as [tx Hm]).
(simpl in Hm).
(apply match_ty_pair__inv in Hm).
(destruct Hm as [v1 [v2 [Heq [Hm1 Hm2]]]]; subst).
(apply match_ty_pair; apply match_ty_exist; exists tx; assumption).
Qed.
Lemma sem_sub_exist_pair : forall (X : id) (t1 t2 : ty), ||- [TExist X (TPair t1 t2)]<= [TPair (TExist X t1) (TExist X t2)].
Proof.
(intros X t1 t2 k).
(apply sem_sub_k_exist_pair).
Qed.
Lemma match_ty_ev__match_ty_any :
  forall (k w : nat) (X : id) (t : ty), fresh_in_ty X t -> |-[ k, w] TEV X <$ t -> forall v : ty, value_type v -> |-[ k, w] v <$ t.
Proof.
(intros k w).
generalize dependent k.
(induction w).
admit.
(intros k X t HX Hm v Hv).
(induction t).
admit.
admit.
admit.
admit.
-
(apply match_ty_exist__inv in Hm).
(destruct Hm as [tx Hm]).
Search -IdSet.In.
(destruct (beq_idP X i)).
+
subst.
(apply match_ty_exist).
exists tx.
(apply IHw with i; try assumption).
Abort.
Lemma sem_sub_fresh_var__sem_sub_any :
  forall (X : id) (t t' : ty) (X' : id),
  IdSet.In X (FV t) -> fresh_in_ty X' t' -> ||- [[X := TVar X'] t]<= [t'] -> forall tx : ty, ||- [[X := tx] t]<= [t'].
Proof.
(intros X t).
(intros t' X' HX HX' Hsem tx).
(intros k w1).
specialize (Hsem k w1).
(destruct Hsem as [w2 Hsem]).
exists w2.
(intros v Hm).
Abort.
Lemma sem_sub_fresh_var__sem_sub_exist' :
  forall (X : id) (t t' : ty) (X' : id),
  IdSet.In X (FV t) -> fresh_in_ty X' t' -> ||- [[X := TVar X'] t]<= [t'] -> forall tx : ty, ||- [[X := tx] t]<= [t'].
Proof.
(intros X t t' X' HX HX' Hsem tx).
(intros k w1).
specialize (Hsem k w1).
(destruct Hsem as [w2 Hsem]).
exists w2.
(intros v Hm).
(induction w1).
Abort.
(* Auto-generated comment: Succeeded. *)