(* *********************************************************************)
(*                                                                     *)
(*            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 MShareOp layer         *)
(*                                                                     *)
(*                                                                     *)
(*                                                                     *)
(*                          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 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 PTNewGenSpec.
Require Import Clight.
Require Import CDataTypes.
Require Import Ctypes.
Require Import CalRealPTPool.
Require Import CalRealPT.
Require Import XOmega.

Require Import AbstractDataType.

Require Import MShareOp.
Require Import MShareIntroCSource.
Require Import ShareOpGenSpec.

Module MSHAREOPCODE.

  (*shared_mem_arg  never checked that the second args is >= 0, but checked
the first one twice*)
  Lemma shared_mem_arg_rev: forall pid1 pid2,
                              shared_mem_arg (Int.unsigned pid1) (Int.unsigned pid2)
                              = shared_mem_arg (Int.unsigned pid2) (Int.unsigned pid1).
  Proof.
    unfold shared_mem_arg. intros.
    destruct (zle_lt 0 (Int.unsigned pid1) 64), (zle_lt 0 (Int.unsigned pid2) 64),
             (zeq (Int.unsigned pid1) (Int.unsigned pid2)) eqn:peq; trivial;
    try rewrite e, zeq_true; try rewrite zeq_false; trivial; auto.
  Qed.

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

      Let L: compatlayer (cdata RData) :=
        get_shared_mem_state ↦ gensem get_shared_mem_state_spec.

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

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

      Section GetSharedMemStatusSeenBody.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

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

        Variable bget_shared_mem_state: block.

        Hypothesis hget_shared_mem_state1 : Genv.find_symbol ge get_shared_mem_state = Some bget_shared_mem_state.

        Hypothesis hget_shared_mem_state2 : Genv.find_funct_ptr ge bget_shared_mem_state =
        Some (External (EF_external get_shared_mem_state
                                    (signature_of_type (Tcons tint (Tcons tint Tnil)) tint cc_default))
                       (Tcons tint (Tcons tint Tnil)) tint cc_default).

        Lemma get_shared_mem_status_seen__correct: forall m d (z: Z) env le pid1 pid2 n,
                                               env = PTree.empty _ ->
                                               PTree.get tpid1 le = Some (Vint pid1) ->
                                               PTree.get tpid2 le = Some (Vint pid2) ->
                                               (*pg d = true ->*)
                                               get_shared_mem_status_seen_spec
                                                 (Int.unsigned pid1) (Int.unsigned pid2) d
                                               = Some (Int.unsigned n) ->
                                               high_level_invariant d ->
                                               exists (le': temp_env),
                                                 exec_stmt ge env le ((m, d): mem) get_shared_mem_status_seen_body
                                                           E0 le' (m, d) (Out_return (Some (Vint n, tint))).
        Proof.
          generalize max_unsigned_val; intro muval.
          assert (H2: True); auto.
          assert (smi2z: forall s, SharedMemInfo2Z s = Int.unsigned (Int.repr (SharedMemInfo2Z s))). {
            intros. unfold SharedMemInfo2Z.
            destruct s; reflexivity.
          }
          intros. subst.
          inversion H4.
          functional inversion H3; subst.
          - esplit.
            unfold exec_stmt.
            change E0 with (E0 ** E0).
            repeat vcgen.
            + unfold get_shared_mem_state_spec.
              rewrite shared_mem_arg_rev.
              rewrite H5, H7, H8, H9, H10, H6.
              rewrite smi2z; reflexivity.
            + repeat vcgen.
            + repeat vcgen.
            + rewrite H. repeat vcgen.
          - esplit.
            unfold exec_stmt.
            change E0 with (E0 ** E0).
            repeat vcgen.
            + unfold get_shared_mem_state_spec.
              rewrite shared_mem_arg_rev.
              rewrite H5, H7, H8, H9, H10, H6.
              rewrite smi2z.
              reflexivity.
            + simpl. repeat vcgen.
              destruct (zeq (SharedMemInfo2Z st) 1).
                * functional inversion e.
                  clear H11; rewrite <- H14 in _x1.
                  contradiction _x1; trivial.
                * repeat vcgen.
                * unfold SharedMemInfo2Z. destruct st; omega.
                * unfold SharedMemInfo2Z. destruct st; omega.
            + repeat vcgen.
              unfold get_shared_mem_state_spec.
              rewrite H5, H7, H8, H9, H6.
              rewrite H12.
              rewrite smi2z; reflexivity.
            + simpl. rewrite PTree.gss. rewrite H, Int.repr_unsigned. trivial.
        Qed.

      End GetSharedMemStatusSeenBody.

      Theorem get_shared_mem_status_seen_code_correct:
        spec_le (get_shared_mem_status_seen ↦ get_shared_mem_status_seen_spec_low)
                (〚get_shared_mem_status_seen ↦ f_get_shared_mem_status_seen 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (get_shared_mem_status_seen__correct s (Genv.globalenv p) makeglobalenv
                                             b0 Hb0fs Hb0fp
                                             m'0 labd
                                             (Int.unsigned n)
                                             (PTree.empty _)
                                             (bind_parameter_temps' (fn_params f_get_shared_mem_status_seen)
                                                                    (Vint pid1 :: Vint pid2 :: nil)
                                                                    (create_undef_temps
                                                                       (fn_temps f_get_shared_mem_status_seen))))
                 H0.
      Qed.

    End GETSHAREDMEMSTATUSSEEN.

    Section SHAREDMEMTOREADY.

      Let resv2_sem := pt_resv2 ↦ gensem ptResv2_spec.

      Let L: compatlayer (cdata RData) :=
          pt_resv2 ↦ gensem ptResv2_spec
        (*⊕ palloc ↦ gensem palloc_spec*)
        (*⊕ shared_mem_to_ready ↦ gensem shared_mem_to_ready_spec*)
        ⊕ set_shared_mem_state ↦ gensem set_shared_mem_state_spec
        ⊕ set_shared_mem_seen ↦ gensem set_shared_mem_seen_spec
        ⊕ get_shared_mem_loc ↦ gensem get_shared_mem_loc_spec
        ⊕ set_shared_mem_loc ↦ gensem set_shared_mem_loc_spec.

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

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

      Section SharedMemToReadyBody.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

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

        Variable bpt_resv2: block.

        Hypothesis hpt_resv21 : Genv.find_symbol ge pt_resv2 = Some bpt_resv2.

        Hypothesis hpt_resv22 : Genv.find_funct_ptr ge bpt_resv2 =
                      Some (External (EF_external pt_resv2 (signature_of_type
(Tcons tint (Tcons tint (Tcons tint (Tcons tint (Tcons tint (Tcons tint Tnil)))))) tint cc_default))
(Tcons tint (Tcons tint (Tcons tint (Tcons tint (Tcons tint (Tcons tint Tnil)))))) tint cc_default).

        Variable bset_shared_mem_state: block.

        Hypothesis hset_shared_mem_state1 : Genv.find_symbol ge set_shared_mem_state = Some bset_shared_mem_state.

        Hypothesis hset_shared_mem_state2 : Genv.find_funct_ptr ge bset_shared_mem_state =
                      Some (External (EF_external set_shared_mem_state (signature_of_type (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default)) (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default).

        (** set_shared_mem_seen *)

        Variable bset_shared_mem_seen: block.

        Hypothesis hset_shared_mem_seen1 : Genv.find_symbol ge set_shared_mem_seen = Some bset_shared_mem_seen.

        Hypothesis hset_shared_mem_seen2 : Genv.find_funct_ptr ge bset_shared_mem_seen =
                      Some (External (EF_external set_shared_mem_seen (signature_of_type (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default)) (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default).

        Variable bget_shared_mem_loc: block.

        Hypothesis hget_shared_mem_loc1 : Genv.find_symbol ge get_shared_mem_loc = Some bget_shared_mem_loc.

        Hypothesis hget_shared_mem_loc2 : Genv.find_funct_ptr ge bget_shared_mem_loc =
                      Some (External (EF_external get_shared_mem_loc (signature_of_type (Tcons tint (Tcons tint Tnil)) tint cc_default)) (Tcons tint (Tcons tint Tnil)) tint cc_default).

        Variable bset_shared_mem_loc: block.

        Hypothesis hset_shared_mem_loc1 : Genv.find_symbol ge set_shared_mem_loc = Some bset_shared_mem_loc.

        Hypothesis hset_shared_mem_loc2 : Genv.find_funct_ptr ge bset_shared_mem_loc =
                      Some (External (EF_external set_shared_mem_loc (signature_of_type (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default)) (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default).

        Require Import CommonTactic.

        Lemma ptInsert0_presv:
          forall pid1 vadr b v d adt n,
            ptInsert0_spec pid1 vadr b v d = Some (adt, n)
            -> pg adt = true /\ ipt adt = true
               /\ smspool adt = smspool d.
        Proof.
          intros. functional inversion H; subst.
          - functional inversion H9; simpl; eauto.
          - functional inversion H9; simpl; eauto.
          - functional inversion H9; simpl; eauto 2;
            functional inversion H11; simpl; eauto 2.
            + rewrite <- H19, <- H0 in *. simpl in *.
              refine_split'; try congruence.
            + rewrite <- H20, <- H0 in *. simpl in *.
              refine_split'; try congruence.
        Qed.

        Lemma ptResv2_presv_pg_idt': forall pid1 pid2 d vadr vadr' adt n v v',
                                ptResv2_spec pid1 vadr v pid2 vadr' v' d = Some (adt, n)
                                -> pg adt = true /\ ipt adt = true
                                   /\ smspool adt = smspool d.
        Proof.
          intros. functional inversion H; subst.
          - functional inversion H2; subst; eauto.
          - functional inversion H2; subst; eauto.
            + eapply ptInsert0_presv in H4. assumption.
            + eapply ptInsert0_presv; eauto.
          - functional inversion H1; subst; eauto.
            + eapply ptInsert0_presv in H0.
              eapply ptInsert0_presv in H3. simpl in *.
              destruct H0 as (HE1 & HE2 & HE3).
              destruct H3 as ( _ & _ & HE4).
              refine_split'; eauto. congruence.
            + eapply ptInsert0_presv in H0.
              eapply ptInsert0_presv in H3. simpl in *.
              destruct H0 as (HE1 & HE2 & HE3).
              destruct H3 as ( _ & _ & HE4).
              refine_split'; eauto. congruence.
        Qed.

        Lemma ptResv2_presv_pg: forall pid1 pid2 d vadr vadr' adt n,
                                  shared_mem_arg (Int.unsigned pid1) (Int.unsigned pid2)
                                     = true
                                -> high_level_invariant d
                                -> ptResv2_spec (Int.unsigned pid1) (Int.unsigned vadr) 7
                                    (Int.unsigned pid2) vadr' 7 d = Some (adt, Int.unsigned n)
                                -> pg adt = true.
        Proof.
          intros.
          destruct (ptResv2_presv_pg_idt' (Int.unsigned pid1) (Int.unsigned pid2) d (Int.unsigned vadr)
                                          vadr' adt (Int.unsigned n) 7 7 H1) as (a & b & c).
          assumption.
        Qed.

        Lemma ptResv2_presv_ipt: forall pid1 pid2 d vadr vadr' adt n,
                                  shared_mem_arg (Int.unsigned pid1) (Int.unsigned pid2)
                                     = true
                                -> high_level_invariant d
                                -> ptResv2_spec (Int.unsigned pid1) (Int.unsigned vadr) 7
                                    (Int.unsigned pid2) vadr' 7 d = Some (adt, Int.unsigned n)
                                -> ipt adt = true.
        Proof.
          intros.
          destruct (ptResv2_presv_pg_idt' (Int.unsigned pid1) (Int.unsigned pid2) d (Int.unsigned vadr)
                                          vadr' adt (Int.unsigned n) 7 7 H1) as (a & b & c).
          assumption.
        Qed.

        Lemma ptResv2_presv_smspool: forall pid1 pid2 d vadr vadr' adt n,
                                  shared_mem_arg (Int.unsigned pid1) (Int.unsigned pid2)
                                     = true
                                -> high_level_invariant d
                                -> ptResv2_spec (Int.unsigned pid1) (Int.unsigned vadr) 7
                                    (Int.unsigned pid2) vadr' 7 d = Some (adt, Int.unsigned n)
                                -> smspool adt = smspool d.
        Proof.
          intros.
          destruct (ptResv2_presv_pg_idt' (Int.unsigned pid1) (Int.unsigned pid2) d (Int.unsigned vadr)
                                          vadr' adt (Int.unsigned n) 7 7 H1) as (a & b & c).
          assumption.
        Qed.

        Lemma shared_mem_to_ready_correct: forall m d d' (z: Z) env le pid1 pid2 vadr n,
                                      env = PTree.empty _ ->
                                      PTree.get tpid1 le = Some (Vint pid1) ->
                                      PTree.get tpid2 le = Some (Vint pid2) ->
                                      PTree.get tvadr le = Some (Vint vadr) ->
                                      (*pg d = true ->*)
                                      shared_mem_to_ready_spec (Int.unsigned pid1) (Int.unsigned pid2) (Int.unsigned vadr) d = Some (d', Int.unsigned n) ->
                                      high_level_invariant d ->
                                      exists (le': temp_env),
                                        exec_stmt ge env le ((m, d): mem) shared_mem_to_ready_body E0 le' (m, d') (Out_return (Some (Vint n, tint))).
        Proof.
          generalize max_unsigned_val; intro muval.
          assert (H2: True); auto.
          intros. subst.
          inversion H5.
          functional inversion H4; functional inversion H7; subst;
            set (Hvadr' := H13); set (Hvadr'_inv := H13);
            auto; rewrite H13 in Hvadr'_inv; inversion Hvadr'_inv.
          Focus 2.
            - set (adt'inv := H15). set (adt'kminv := H15).
              apply ptResv2_high_level_inv in adt'inv; auto.
              apply ptResv2_kernel_mode in adt'kminv; try (constructor; auto; fail).
              esplit.
              unfold exec_stmt.
              change E0 with (E0 ** E0).
              repeat vcgen.
                + unfold get_shared_mem_loc_spec.
                  rewrite H8, H9, H10, H11, shared_mem_arg_rev, H7, Hvadr'.
                  instantiate (1:= (Int.repr vadr')).
                  rewrite Int.unsigned_repr.
                  reflexivity.
                  omega.
                + repeat vcgen.
                  econstructor.
                  rewrite H15.
                  trivial.
                + vcgen.
                + vcgen.
                + repeat vcgen.
                    * unfold set_shared_mem_state_spec; simpl.
                      destruct adt'kminv.
                      rewrite (ptResv2_presv_pg pid1 pid2 d vadr vadr' adt' n); auto.
                      rewrite (ptResv2_presv_ipt pid1 pid2 d vadr vadr' adt' n); auto.
                      rewrite (ptResv2_presv_smspool pid1 pid2 d vadr vadr' adt' n); auto.
                      rewrite H, H7, H6, H12.
                      vcgen.
                    * unfold set_shared_mem_seen_spec; simpl.
                      destruct adt'kminv.
                      rewrite (ptResv2_presv_pg pid1 pid2 d vadr vadr' adt' n); auto.
                      rewrite (ptResv2_presv_ipt pid1 pid2 d vadr vadr' adt' n); auto.
                      rewrite H, H7, H6. repeat rewrite ZMap.gss.
                      repeat rewrite ZMap.set2.
                      try reflexivity.
                      (*cutrewrite (ZtoBool (Int.unsigned (Int.zero_ext 8 (Int.repr 1)))
                                  = Some true); try reflexivity.*)
                    * unfold set_shared_mem_loc_spec; simpl.
                      destruct adt'kminv.
                      rewrite (ptResv2_presv_pg pid1 pid2 d vadr vadr' adt' n); auto.
                      rewrite (ptResv2_presv_ipt pid1 pid2 d vadr vadr' adt' n); auto.
                      rewrite H, H7, H6.
                      repeat rewrite ZMap.gss.
                      reflexivity.
                    * unfold set_shared_mem_state_spec; simpl.
                      destruct adt'kminv.
                      rewrite (ptResv2_presv_pg pid1 pid2 d vadr vadr' adt' n); auto.
                      rewrite (ptResv2_presv_ipt pid1 pid2 d vadr vadr' adt' n); auto.
                      rewrite H, shared_mem_arg_rev, H7, H6.
                      repeat rewrite ZMap.gso; auto.
                      setoid_rewrite Hvadr'.
                      vcgen.
                    * unfold set_shared_mem_seen_spec; simpl.
                      destruct adt'kminv.
                      rewrite (ptResv2_presv_pg pid1 pid2 d vadr vadr' adt' n); auto.
                      rewrite (ptResv2_presv_ipt pid1 pid2 d vadr vadr' adt' n); auto.
                      rewrite H, shared_mem_arg_rev, H7, H6.

                      (*cutrewrite (ZtoBool (Int.unsigned (Int.zero_ext 8 (Int.repr 0)))
                              = Some false); [| reflexivity].*)
                      (*rewrite (ptResv2_presv_smspool pid1 pid2 d vadr vadr' adt' n); auto.*)
                      repeat rewrite ZMap.gss.
                      reflexivity.
                      (*repeat rewrite ZMap.gso.
                      repeat rewrite ZMap.set2.
                      repeat vcgen.*)
                    * unfold set_shared_mem_loc_spec; simpl.
                      destruct adt'kminv.
                      rewrite (ptResv2_presv_pg pid1 pid2 d vadr vadr' adt' n); auto.
                      rewrite (ptResv2_presv_ipt pid1 pid2 d vadr vadr' adt' n); auto.
                      rewrite H, shared_mem_arg_rev, H7, H6.
                      unfold smsp', smsp.
                      rewrite (ptResv2_presv_smspool pid1 pid2 d vadr vadr' adt' n); auto.
                      repeat rewrite ZMap.gss.
                      repeat rewrite ZMap.set2.
                      repeat rewrite ZMap.gso.
                      (*rewrite (ptResv2_presv_pg pid1 pid2 d vadr vadr' adt' n); auto.
                      rewrite (ptResv2_presv_ipt pid1 pid2 d vadr vadr' adt' n); auto.
                      destruct adt'kminv. rewrite H, H21.*)
                      reflexivity. auto.
                 + vcgen. rewrite PTree.gss. trivial.
            - esplit.
              unfold exec_stmt.
              change E0 with (E0 ** E0).
              repeat vcgen.
                + unfold get_shared_mem_loc_spec.
                  rewrite H8, H9, H10, H11, shared_mem_arg_rev, H7, Hvadr'.
                  instantiate (1:= (Int.repr vadr')).
                  rewrite Int.unsigned_repr.
                  reflexivity.
                  omega.
                + repeat vcgen.
                  econstructor.
                  rewrite H15.
                  cutrewrite (MagicNumber = Int.unsigned (Int.repr MagicNumber)).
                  reflexivity. auto.
                + vcgen.
                + reflexivity.
                + vcgen.
                + vcgen. rewrite PTree.gss. simpl MagicNumber.
                  cutrewrite (n = Int.repr (Int.unsigned n)).
                  rewrite <- H6. trivial.
                  rewrite Int.repr_unsigned. trivial.
        Qed.

      End SharedMemToReadyBody.

      Theorem shared_mem_to_ready_code_correct:
        spec_le (shared_mem_to_ready ↦ shared_mem_to_ready_spec_low)
                (〚shared_mem_to_ready ↦ f_shared_mem_to_ready 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (shared_mem_to_ready_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'
                                             (Int.unsigned n)
                                             (PTree.empty _)
                                             (bind_parameter_temps' (fn_params f_shared_mem_to_ready)
                                                                    (Vint pid1 :: Vint pid2 :: Vint vadr :: nil)
                                                                    (create_undef_temps
                                                                       (fn_temps f_shared_mem_to_ready))))
                 H0.
      Qed.

    End SHAREDMEMTOREADY.

    Section SHAREDMEMTODEAD.

      Let L: compatlayer (cdata RData) :=
          set_shared_mem_state ↦ gensem  set_shared_mem_state_spec
        ⊕ set_shared_mem_seen ↦ gensem set_shared_mem_seen_spec
        ⊕ set_shared_mem_loc ↦ gensem set_shared_mem_loc_spec.

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

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

      Section SharedMemToDeadBody.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

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

        (** set_shared_mem_state *)

        Variable bset_shared_mem_state: block.

        Hypothesis hset_shared_mem_state1 : Genv.find_symbol ge set_shared_mem_state = Some bset_shared_mem_state.

        Hypothesis hset_shared_mem_state2 : Genv.find_funct_ptr ge bset_shared_mem_state =
                      Some (External (EF_external set_shared_mem_state (signature_of_type (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default)) (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default).

        (** set_shared_mem_seen *)

        Variable bset_shared_mem_seen: block.

        Hypothesis hset_shared_mem_seen1 : Genv.find_symbol ge set_shared_mem_seen = Some bset_shared_mem_seen.

        Hypothesis hset_shared_mem_seen2 : Genv.find_funct_ptr ge bset_shared_mem_seen =
                      Some (External (EF_external set_shared_mem_seen (signature_of_type (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default)) (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default).

        Variable bset_shared_mem_loc: block.

        Hypothesis hset_shared_mem_loc1 : Genv.find_symbol ge set_shared_mem_loc = Some bset_shared_mem_loc.

        Hypothesis hset_shared_mem_loc2 : Genv.find_funct_ptr ge bset_shared_mem_loc =
                      Some (External(EF_external set_shared_mem_loc (signature_of_type (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default)) (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default).

        Lemma shared_mem_to_dead_correct: forall m d d' (z: Z) env le pid1 pid2 vadr,
                                      env = PTree.empty _ ->
                                      PTree.get tpid1 le = Some (Vint pid1) ->
                                      PTree.get tpid2 le = Some (Vint pid2) ->
                                      PTree.get tvadr le = Some (Vint vadr) ->

                                      shared_mem_to_dead_spec (Int.unsigned pid1) (Int.unsigned pid2) (Int.unsigned vadr) d = Some d' ->
                                      high_level_invariant d ->
                                      exists (le': temp_env),
                                        exec_stmt ge env le ((m, d): mem) shared_mem_to_dead_body E0 le' (m, d') Out_normal.
        Proof.
          generalize max_unsigned_val; intro muval.
          assert (H2: True); auto.
          intros. subst.
          functional inversion H4. subst.
          inversion H5.
          functional inversion H6.
          esplit.
          unfold exec_stmt.
          change E0 with (E0 ** E0).
          repeat vcgen.
            - unfold set_shared_mem_seen_spec; simpl.
              repeat rewrite ZMap.gss.
              repeat vcgen.
            - unfold set_shared_mem_loc_spec; simpl.
              repeat rewrite ZMap.gss.
              repeat vcgen.
            - unfold set_shared_mem_state_spec; simpl.
              rewrite shared_mem_arg_rev.
              repeat rewrite ZMap.gso.
              setoid_rewrite H11.
              repeat vcgen. auto. auto. auto.
            - unfold set_shared_mem_seen_spec; simpl.
              rewrite shared_mem_arg_rev.
              rewrite H6, H7, H8, H9, H10.
              repeat rewrite ZMap.gss.
              repeat rewrite ZMap.set2.
              reflexivity.
              (*cutrewrite (ZtoBool (Int.unsigned (Int.zero_ext 8 (Int.repr 0)))
                          = Some false); try reflexivity.*)

            - unfold set_shared_mem_loc_spec; simpl.
              rewrite shared_mem_arg_rev.
              rewrite H6, H7, H8, H9, H10.
              repeat rewrite ZMap.gss.
              repeat rewrite ZMap.set2.
              repeat rewrite ZMap.gso.
              unfold smsp'; unfold smsp.
              unfold smspool. destruct d. repeat rewrite rdata_update.
              repeat rewrite ZMap.gso.
              reflexivity. auto.
        Qed.

      End SharedMemToDeadBody.

      Theorem shared_mem_to_dead_code_correct:
        spec_le (shared_mem_to_dead ↦ shared_mem_to_dead_spec_low)
                (〚shared_mem_to_dead ↦ f_shared_mem_to_dead 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (shared_mem_to_dead_correct s (Genv.globalenv p) makeglobalenv
                                             b0 Hb0fs Hb0fp
                                             b1 Hb1fs Hb1fp
                                             b2 Hb2fs Hb2fp
                                             m'0 labd labd'
                                             (Int.unsigned vadr)
                                             (PTree.empty _)
                                             (bind_parameter_temps' (fn_params f_shared_mem_to_dead)
                                                                    (Vint pid1 :: Vint pid2 :: Vint vadr :: nil)
                                                                    (create_undef_temps
                                                                       (fn_temps f_shared_mem_to_dead))))
                 H0.
      Qed.

    End SHAREDMEMTODEAD.

    Section SHAREDMEMTOPENDING.

      Let L: compatlayer (cdata RData) :=
          set_shared_mem_state ↦ gensem  set_shared_mem_state_spec
        ⊕ set_shared_mem_seen ↦ gensem set_shared_mem_seen_spec
        ⊕ set_shared_mem_loc ↦ gensem set_shared_mem_loc_spec.

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

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

      Section SharedMemToPendingBody.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

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

        (** set_shared_mem_state *)

        Variable bset_shared_mem_state: block.

        Hypothesis hset_shared_mem_state1 : Genv.find_symbol ge set_shared_mem_state = Some bset_shared_mem_state.

        Hypothesis hset_shared_mem_state2 : Genv.find_funct_ptr ge bset_shared_mem_state =
                      Some (External (EF_external set_shared_mem_state (signature_of_type (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default)) (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default).

        (** set_shared_mem_seen *)

        Variable bset_shared_mem_seen: block.

        Hypothesis hset_shared_mem_seen1 : Genv.find_symbol ge set_shared_mem_seen = Some bset_shared_mem_seen.

        Hypothesis hset_shared_mem_seen2 : Genv.find_funct_ptr ge bset_shared_mem_seen =
                      Some (External (EF_external set_shared_mem_seen (signature_of_type (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default)) (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default).

        Variable bset_shared_mem_loc: block.

        Hypothesis hset_shared_mem_loc1 : Genv.find_symbol ge set_shared_mem_loc = Some bset_shared_mem_loc.

        Hypothesis hset_shared_mem_loc2 : Genv.find_funct_ptr ge bset_shared_mem_loc =
                      Some (External (EF_external set_shared_mem_loc (signature_of_type (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default)) (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default).

        Lemma shared_mem_to_pending_correct: forall m d d' (z: Z) env le pid1 pid2 vadr,
                                      env = PTree.empty _ ->
                                      PTree.get tpid1 le = Some (Vint pid1) ->
                                      PTree.get tpid2 le = Some (Vint pid2) ->
                                      PTree.get tvadr le = Some (Vint vadr) ->
                                      shared_mem_to_pending_spec (Int.unsigned pid1) (Int.unsigned pid2) (Int.unsigned vadr) d = Some d' ->
                                      high_level_invariant d ->
                                      exists (le': temp_env),
                                        exec_stmt ge env le ((m, d): mem) shared_mem_to_pending_body E0 le' (m, d') Out_normal.
        Proof.
          generalize max_unsigned_val; intro muval.
          assert (H2: True); auto.
          intros. subst.
          functional inversion H4. subst.
          inversion H5.
          functional inversion H6.
          esplit.
          unfold exec_stmt.
          change E0 with (E0 ** E0).
          repeat vcgen.
            - unfold set_shared_mem_seen_spec; simpl.
              rewrite H6.
              repeat rewrite ZMap.gss.
              repeat vcgen. (*reflexivity.*)
            - unfold set_shared_mem_loc_spec; simpl.
              rewrite H6.
              repeat rewrite ZMap.gss. repeat rewrite ZMap.set2.
              rewrite H7, H8, H9, H10. reflexivity.
        Qed.

      End SharedMemToPendingBody.

      Theorem shared_mem_to_pending_code_correct:
        spec_le (shared_mem_to_pending ↦ shared_mem_to_pending_spec_low)
                (〚shared_mem_to_pending ↦ f_shared_mem_to_pending 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (shared_mem_to_pending_correct s (Genv.globalenv p) makeglobalenv
                                             b0 Hb0fs Hb0fp
                                             b1 Hb1fs Hb1fp
                                             b2 Hb2fs Hb2fp
                                             m'0 labd labd'
                                             (Int.unsigned vadr)
                                             (PTree.empty _)
                                             (bind_parameter_temps' (fn_params f_shared_mem_to_pending)
                                                                    (Vint pid1 :: Vint pid2 :: Vint vadr :: nil)
                                                                    (create_undef_temps
                                                                       (fn_temps f_shared_mem_to_pending))))
                 H0.
      Qed.

    End SHAREDMEMTOPENDING.

    End WithPrimitives.

End MSHAREOPCODE.


Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import PeanoNat.

Require Export Parser.Monotonicity.
Require Export Parser.HListCast.
Require Export Parser.DescriptionInd.
Require Export Parser.DescriptionToFunction.
Require Export Parser.NetworkProperties.
Require Export Parser.NetworkWipCells.

Opaque compute_cells.
Opaque range.

(** In this file, we prove that, for monotonic descriptions, if a syntax `s` is
    related to a value `v`, then the propagator network is going to return some
    value (not necessarily `v`) *)
Definition fun_completeness_statement: Prop :=
  forall G (descr: Description G) A (s: Syntax A) v,
    descr_ind descr s v ->
    monotonic_descr descr ->
    is_some (build_fun descr s).

Definition is_up_to_date (N: Network) k: Prop :=
  (exists H,
    measure (cells N k) (state (cells N k)) <=
    measure (cells N k) (update (cells N k) (cast H (h_map (fun k' => state (cells N k')) (inputs N k)))))
  \/
  (exists q, measure (cells N k) (state (cells N k)) < measure (cells N k) q).

Lemma compute_cell_up_to_date_some:
  forall N k pre N',
    compute_cell N k pre = Some N' ->
    is_up_to_date N' k.
Proof.
  unfold compute_cell, set_cell, is_up_to_date, cast;
    repeat light || destruct_match || invert_constructor_equalities;
    eauto with lia.
Qed.

Lemma compute_cell_up_to_date_none:
  forall N k pre,
    compute_cell N k pre = None ->
    is_up_to_date N k.
Proof.
  unfold compute_cell, set_cell, is_up_to_date, cast;
    repeat light || destruct_match || invert_constructor_equalities || eq_dep || clear matched.

    left.
    exists (f_equal (fun H : list Type => hlist H)
                 (PropagatorNetwork.compute_cell_obligation_1 N k pre));
            eauto with lia.
Qed.
Lemma sum_sizes_until_sum_sizes2:
  forall x n, sum_sizes_until x < sum_sizes vars + n.
Proof.
  intros.
  pose proof (sum_sizes_until_sum_sizes x); eauto with lia.
Qed.

Lemma registered_inputs_compute_cell:
  forall N k pre N',
    compute_cell N k pre = Some N' ->
    registered_inputs N ->
    registered_inputs N'.
Proof.
  unfold compute_cell, set_cell;
    repeat light || destruct_match || invert_constructor_equalities.
Qed.

Lemma compute_cell_up_to_date_some_other:
  forall N k1 k2 pre N',
    is_up_to_date N k1 ->
    k1 <> k2 ->
    ~ In k2 (inputs N k1) ->
    compute_cell N k2 pre = Some N' ->
    is_up_to_date N' k1.
Proof.
  unfold compute_cell, set_cell;
    repeat light || destruct_match || invert_constructor_equalities;
    eauto with lia.

  clear matched.

  unfold is_up_to_date in *;
    repeat light || eq_dep || destruct_match; eauto.

  left.
  unshelve eexists; repeat light || eq_dep || destruct_match.
  - eapply eq_trans; try eassumption.
    f_equal.
    apply map_ext_in;
      repeat light || eq_dep || destruct_match.
  -
(*    Notation "'<<' x '>>'" := (eq_rect _ (fun T => T) x _ _). *)
    unshelve erewrite (h_map_ext _ _ _ _
      (fun k' : nat =>
            state
              (if Nat.eq_dec k2 k'
               then
                {|
                main_type := main_type (cells N k2);
                cell_type := cell_type (cells N k2);
                input_types := input_types (cells N k2);
                update := update (cells N k2);
                measure := measure (cells N k2);
                state := update (cells N k2)
                           (eq_rect
                              (hlist (map (fun k'0 : nat => cell_type (cells N k'0)) (inputs N k2)))
                              (fun T : Type => T)
                              (h_map (fun k'0 : nat => state (cells N k'0)) (inputs N k2))
                              (hlist (input_types (cells N k2)))
                              (f_equal (fun H3 : list Type => hlist H3)
                                 (PropagatorNetwork.compute_cell_obligation_1 N k2 pre))) |}
               else cells N k'))
      (fun k' : nat => state (cells N k'))); repeat light || destruct_match.

    + f_equal. apply map_ext_in; repeat light || destruct_match.
    + repeat eq_dep. proof_irrelevance.
      rewrite H3 in H2; lights.
    + eexists; repeat light || rewrite cast_refl.
Qed.

Lemma compute_cells_up_to_date':
    forall m num_cells N ks pre k,
    (sum_measures num_cells N, length ks) = m ->
    registered_inputs N ->
    (forall k, k < num_cells -> In k ks \/ is_up_to_date N k) ->
    k < num_cells ->
    is_up_to_date (compute_cells num_cells N ks pre) k.
Proof.
  induction m using measure_induction; destruct ks;
    repeat light || compute_cells_def || destruct_match || options;
    try solve [ instantiate_any; lights ].

  - clear matched.
    revert i.
    generalize (PropagatorNetwork.compute_cells_obligations_obligation_3 num_cells N n ks pre).
    generalize (PropagatorNetwork.compute_cells_obligations_obligation_2 num_cells N n ks pre).
    generalize (PropagatorNetwork.compute_cells_obligations_obligation_1 num_cells N n ks pre).
    repeat light || destruct_match || options.

    eapply_any; repeat light || rewrite in_app_iff in *;
      eauto using registered_inputs_compute_cell;
      try solve [ apply left_lex; eauto using compute_cell_size ].

    match goal with
    | H1: forall k, _ -> _ \/ _, H2: _ < _ |- _ => pose proof (H1 _ H2)
    end; lights;
      eauto using compute_cell_up_to_date_some.

    pose proof (Nat.eq_dec k0 n); lights;
      eauto using compute_cell_up_to_date_some.

    pose proof (in_dec Nat.eq_dec k0 (registered N n)); lights.
    unfold registered_inputs in *.
    rewrite H1 in *; eauto using compute_cell_up_to_date_some_other.

  - clear matched.
    revert n0.
    generalize (PropagatorNetwork.compute_cells_obligations_obligation_5 num_cells N n ks pre).
    generalize (PropagatorNetwork.compute_cells_obligations_obligation_1 num_cells N n ks pre).
    repeat light || destruct_match;
      eauto 2 with lights.

    eapply_any; repeat light || rewrite in_app_iff in *;
      eauto;
      try solve [ apply right_lex; eauto using compute_cell_size ].

    match goal with
    | H1: forall k, _ -> _ \/ _, H2: _ < _ |- _ => pose proof (H1 _ H2)
    end; lights;
      eauto using compute_cell_up_to_date_none.
Qed.

Lemma compute_cells_up_to_date:
  forall G (descr: Description G) A0 (s0: Syntax A0) k,
    k < sum_sizes vars + syntax_size s0 ->
    is_up_to_date
      (compute_cells
        (sum_sizes vars + syntax_size s0)
        (make_network s0 descr)
        (range 0 (sum_sizes vars + syntax_size s0))
        (DescriptionToFunction.build_fun_obligation_1 G descr A0 s0))
      k.
Proof.
  intros.
  eapply compute_cells_up_to_date'; repeat light || rewrite range_spec;
    eauto using registered_inputs_make_network;
    eauto with lia.
Qed.

Ltac cell_equality_transitivity :=
  match goal with
  | H1: cells ?N ?k = _, H2: cells ?N ?k = make_cell_with_state _ _ _ |- _ =>
    poseNew (Mark (H1, H2) "cell_equality_transitivity");
    pose proof (eq_trans (eq_sym H1) H2)
  end.

Ltac main_type_solve :=
  match goal with
  | H: {| main_type := _ |} = make_cell_with_state _ _ _ |- _ =>
    poseNew (Mark H "main_type_solve");
    pose proof (f_equal_dep _ main_type H);
      repeat eq_dep || cbn in * || rewrite main_type_make_cell in *
  end.

Ltac state_solve :=
  match goal with
  | H: {| main_type := _ |} = make_cell_with_state _ _ _ |- _ =>
    poseNew (Mark H "state_solve");
    pose proof (f_equal_dep _ state H);
      repeat eq_dep || cbn in * || rewrite state_make_cell in * || invert_constructor_equalities
  end.

Ltac derive_members :=
  match goal with
  | H: cells (compute_cells _ (make_network _ _) _ _) ?k = _ |- _ =>
    poseNew (Mark k "derive_members");
    pose proof (eq_sym ((f_equal_dep _ update (eq_sym H))));
    pose proof (eq_sym ((f_equal_dep _ cell_type (eq_sym H))));
    pose proof (eq_sym ((f_equal_dep _ measure (eq_sym H))));
    pose proof (eq_sym ((f_equal_dep _ state (eq_sym H))));
    pose proof (eq_sym ((f_equal_dep _ input_types (eq_sym H))))
  end; repeat eq_dep || cbn in *.

Lemma rules_to_update_epsilon:
  forall G (descr : Description G) A (R : Rule nil (G A)) (v : G A) (a: A) (opt: option (G A)) rules,

    R HNil = Some v ->
    In R rules ->
    (Epsilon a, opt) = rules_to_update (Epsilon a) G rules HNil ->
    is_some opt.
Proof.
  repeat light || unfold is_some || destruct_match || unfold rules_to_update in * ||
         invert_constructor_equalities;
    eauto using fold_left_not_none2.
Qed.

Lemma rules_to_update_failure:
  forall G (descr : Description G) A (R : Rule nil (G A)) (v : G A) (opt: option (G A)) rules,

    R HNil = Some v ->
    In R rules ->
    (Failure A, opt) = rules_to_update (Failure A) G rules HNil ->
    is_some opt.
Proof.
  repeat light || unfold is_some || destruct_match || unfold rules_to_update in * ||
         invert_constructor_equalities;
    eauto using fold_left_not_none2.
Qed.

Lemma rules_to_update_elem:
  forall G (descr : Description G) (R : Rule nil (G token)) (v : G token) (opt: option (G token)) rules tc,

    R HNil = Some v ->
    In R rules ->
    (Elem tc, opt) = rules_to_update (Elem tc) G rules HNil ->
    is_some opt.
Proof.
  repeat light || unfold is_some || destruct_match || unfold rules_to_update in * ||
         invert_constructor_equalities;
    eauto using fold_left_not_none2.
Qed.

Lemma rules_to_update_monotonic_1:
  forall A T
    (R : Rule (A :: nil) T) opt0 opt1 opt2 rules,

    is_some (R (HCons opt1 HNil)) ->
    In R rules ->
    monotonic_rule_1 R ->
    is_some_is_some opt1 opt2 ->
    is_some (fold_left (fun acc f => or_else acc (f (HCons opt2 HNil))) rules opt0).
Proof.
  unfold monotonic_rule_1; unfold is_some_is_some; intros.
  apply fold_is_some with R; lights;
  eapply H1; eauto; lights.
Qed.

Lemma rules_to_update_monotonic_1':
  forall A T v
    (R : Rule (A :: nil) T) opt0 opt1 opt2 rules,

    R (HCons opt1 HNil) = Some v ->
    In R rules ->
    monotonic_rule_1 R ->
    is_some_is_some opt1 opt2 ->
    fold_left (fun acc f => or_else acc (f (HCons opt2 HNil))) rules opt0 = None ->
    False.
Proof.
  intros.
  unshelve epose proof (rules_to_update_monotonic_1 A T R opt0 opt1 opt2 rules _ _ _ _);
    repeat light || options || destruct_match.
Qed.

Lemma rules_to_update_monotonic_2:
  forall A1 A2 T
    (R : Rule (A1 :: A2 :: nil) T) opt0 opt1 opt2 opt1' opt2' rules,

    is_some (R (HCons opt1 (HCons opt2 HNil))) ->
    In R rules ->
    monotonic_rule_2 R ->
    is_some_is_some opt1 opt1' ->
    is_some_is_some opt2 opt2' ->
    is_some (fold_left (fun acc f => or_else acc (f (HCons opt1' (HCons opt2' HNil)))) rules opt0).
Proof.
  unfold monotonic_rule_2; unfold is_some_is_some; intros.
  apply fold_is_some with R; lights;
  eapply H1; eauto; lights.
  unfold are_some_are_some_2; lights.
Qed.

Lemma rules_to_update_monotonic_2':
  forall A1 A2 T v
    (R : Rule (A1 :: A2 :: nil) T) opt0 opt1 opt2 opt1' opt2' rules,

    R (HCons opt1 (HCons opt2 HNil)) = Some v ->
    In R rules ->
    monotonic_rule_2 R ->
    is_some_is_some opt1 opt1' ->
    is_some_is_some opt2 opt2' ->
    fold_left (fun acc f => or_else acc (f (HCons opt1' (HCons opt2' HNil)))) rules opt0 = None ->
    False.
Proof.
  intros.
  unshelve epose proof (rules_to_update_monotonic_2 A1 A2 T R opt0 opt1 opt2 opt1' opt2' rules _ _ _ _ _);
    repeat light || options || destruct_match.
Qed.

Ltac introduce_up :=
  match goal with
  | H: cells (compute_cells _ (make_network ?s0 ?descr) _ _) ?k = {| main_type := _ |} |- _ =>
    poseNew (Mark 0 "introduce_up");
    unshelve epose proof (compute_cells_up_to_date _ descr _ s0 k _); lights;
    unfold is_up_to_date in *; lights
  end.

Ltac revert_up :=
  match goal with
  | H: measure _ (state _) <= _ |- _ => revert H
  | H: measure _ (state _) < _ |- _ => revert H
  end.

Lemma rules_to_update_0:
  forall T (R : Rule [] T) rules opt0,

    is_some (R HNil) ->
    In R rules ->
    is_some (fold_left (fun acc f => or_else acc (f HNil)) rules opt0).
Proof.
  intros.
  apply fold_is_some with R; lights.
Qed.

Lemma rules_to_update_0':
  forall T (R : Rule [] T) rules opt0 v,

    R HNil = Some v ->
    In R rules ->
    fold_left (fun acc f => or_else acc (f HNil)) rules opt0 = None ->
    False.
Proof.
  intros.
  unshelve epose proof (rules_to_update_0 T R rules opt0 _ _);
    repeat light || destruct_match || rewrite_any.
Qed.

Ltac generalize_lt_right :=
  match goal with
  | |- context[measure _ _ < measure ?c ?q] => generalize q
  end.

Lemma small_node_measure:
  forall A G (q: node_type A G), 1 < node_measure q -> False.
Proof.
  unfold node_measure;
    repeat light || destruct_match; try lia.
Qed.

Lemma fun_completeness':
  forall G (descr: Description G) A (s: Syntax A) v A0 (s0: Syntax A0),
    descr_ind descr s v ->
    monotonic_descr descr ->
    wip_cells descr
      (compute_cells (sum_sizes vars + syntax_size s0)
                          (make_network s0 descr)
                          (range 0 (sum_sizes vars + syntax_size s0))
                          (DescriptionToFunction.build_fun_obligation_1 G descr A0 s0))
      0 (sum_sizes vars + syntax_size s0) ->
    forall k opt,
      cells (compute_cells (sum_sizes vars + syntax_size s0)
                            (make_network s0 descr)
                            (range 0 (sum_sizes vars + syntax_size s0))
                            (DescriptionToFunction.build_fun_obligation_1 G descr A0 s0))
            k =
        make_cell_with_state s descr opt ->
      k < sum_sizes vars + syntax_size s0 ->
      is_some opt.
Proof.
  induction 1;
    repeat light || destruct_match || cell_equality_transitivity ||
          unshelve instantiate_wip_cells k ||
          unshelve instantiate_wip_cells k0 ||
          invert_constructor_equalities || rewrite_known_inputs2 || eq_dep ||
          main_type_solve || state_solve; try (
      introduce_up; revert_up; try generalize_lt_right; repeat derive_members;
      repeat rewrite_known_updates; repeat eq_dep || cbn || generalize_proofs;
      repeat rewrite_known_measures; repeat eq_dep || cbn || generalize_proofs;
      repeat rewrite_known_input_types; repeat eq_dep || cbn || generalize_proofs;
      repeat rewrite_known_inputs2; repeat eq_dep || cbn || generalize_proofs;
      repeat rewrite_known_states2;
        repeat eq_dep || generalize_proofs || rewrite state_make_cell;
      repeat rewrite_known_cell_types;
        repeat eq_dep || cbn || generalize_proofs || light ||
                rewrite cast_hcons in * ||
                rewrite cast_hcons2 in *;
      repeat unfold rules_to_update in * || invert_constructor_equalities;
        try solve [ repeat light || destruct_match; try lia; eauto using rules_to_update_0' ];
        try solve [ repeat light || destruct_match; eauto using small_node_measure ];
        try solve [ repeat light || destruct_match;
                    try lia; eapply rules_to_update_monotonic_1';  eauto;
          try solve [ unfold monotonic_descr in *; repeat light; eauto ];
          try solve [ unfold is_some_is_some; lights;
                      eauto using sum_sizes_until_sum_sizes2 with lia ]
        ];
        try solve [ repeat light || destruct_match;
                    try lia; eapply rules_to_update_monotonic_2';  eauto;
          try solve [ unfold monotonic_descr in *; repeat light; eauto ];
          try solve [ unfold is_some_is_some; lights;
                      eauto using sum_sizes_until_sum_sizes2 with lia ]
        ]
    ).
Qed.

Lemma fun_completeness: fun_completeness_statement.
Proof.
  unfold fun_completeness_statement; unfold build_fun;
    repeat light.

  match goal with
  | |- context[compute_cells ?num_cells ?N ?ks ?pre] =>
    unshelve epose proof (compute_cells_still_make_cell
      A s G descr N (sum_sizes vars) num_cells ks None pre _
    )
  end;
    eauto using cell_make_network; lights.

  apply fun_completeness' with descr s v A s (sum_sizes vars);
    repeat light || apply wip_cells_compute_cells || unfold wip_cells ||
           rewrite range_spec in * || syntax_size_gt_0;
    eauto using sum_sizes_until_sum_sizes2;
    eauto using wip_cells_make_network;
    eauto with lia;
    eauto using var_cells_make_network.

  - repeat derive_members.
    rewrite_known_states2; repeat cbn || eq_dep || rewrite state_make_cell; lights.
Qed.


Require Import Common.Definitions.
Require Import Common.Memory.
Require Import Common.Util.
Require Import Intermediate.Machine.
Require Import Lib.Monads.

Import Intermediate.

From mathcomp Require Import ssreflect ssrfun seq.

Set Bullet Behavior "Strict Subproofs".

Record global_env := mkGlobalEnv {
  genv_interface: Program.interface;
  genv_procedures: NMap (NMap code);
  genv_entrypoints: EntryPoint.t;
}.

Definition executing G (pc : Pointer.t) (i : instr) : Prop :=
  exists C_procs P_code,
    getm (genv_procedures G) (Pointer.component pc) = Some C_procs /\
    getm C_procs (Pointer.block pc) = Some P_code /\
    (Pointer.offset pc >= 0) % Z /\
    Pointer.permission pc = Permission.code /\
    nth_error P_code (Z.to_nat (Pointer.offset pc)) = Some i.

Lemma executing_deterministic:
  forall G pc i i',
    executing G pc i -> executing G pc i' -> i = i'.
Proof.
  unfold executing. intros G pc i i'
                           [C_procs [P_code [memCprocs [memPcode
                                                          [offsetCond
                                                             [permCond memi]]]]]]
                           [C_procs' [P_code' [memCprocs' [memPcode'
                                                             [offsetCond'
                                                                [permCond'
                                                                   memi']]]]]].
  rewrite memCprocs in memCprocs'.
  inversion memCprocs'.
  subst C_procs.
  rewrite memPcode in memPcode'.
  inversion memPcode'.
  subst P_code.
  rewrite memi in memi'.
  inversion memi'.
  auto.
Qed.

Definition prepare_global_env (p: program) : global_env :=
  let '(_, procs, entrypoints) := prepare_procedures_initial_memory p in
  {| genv_interface := prog_interface p;
     genv_procedures := procs;
     genv_entrypoints := entrypoints |}.

(* global environments are computational and pure: deterministic.
   what else do I need? some kind of per-component isolation stated
   in a way that's easy to reuse *)
Lemma domm_genv_procedures : forall p,
  domm (genv_procedures (prepare_global_env p)) = domm (prog_interface p).
Proof.
  intros p.
  unfold genv_procedures, prepare_global_env.
  rewrite Extra.domm_map. (* RB: Should be domm_mapm! *)
  rewrite domm_prepare_procedures_initial_memory_aux.
  reflexivity.
Qed.

Lemma domm_genv_entrypoints : forall p,
  domm (genv_entrypoints (prepare_global_env p)) = domm (prog_interface p).
Proof.
  intros p.
  unfold genv_procedures, prepare_global_env.
  rewrite Extra.domm_map domm_prepare_procedures_initial_memory_aux.
  reflexivity.
Qed.

Lemma genv_procedures_prog_procedures_eq : forall p c x,
    well_formed_program p ->
    prog_procedures p c = Some x ->
    genv_procedures (prepare_global_env p) c =
    prog_procedures p c.
Proof.
  intros ? ? ? Hwf HSome.
  simpl. rewrite mapmE. unfold omap, obind, oapp.
  destruct (prepare_procedures_initial_memory_aux p c) as [someRes|] eqn:ec;
    rewrite ec; unfold prepare_procedures_initial_memory_aux in *;
      rewrite mkfmapfE in ec;
      destruct (c \in domm (prog_interface p)) eqn:ecintf; rewrite ecintf in ec;
        inversion ec; clear ec; simpl.
  - unfold odflt, oapp. by rewrite HSome.
  - assert (c \in domm (prog_interface p)).
    {
      rewrite wfprog_defined_procedures; auto. apply/dommP. by eauto.
    }
    congruence.
Qed.

Definition global_env_union (genv1 genv2 : global_env) : global_env := {|
  genv_interface   := unionm (genv_interface   genv1) (genv_interface   genv2);
  genv_procedures  := unionm (genv_procedures  genv1) (genv_procedures  genv2);
  genv_entrypoints := unionm (genv_entrypoints genv1) (genv_entrypoints genv2)
|}.

Lemma prepare_global_env_link : forall {p c},
  well_formed_program p ->
  well_formed_program c ->
  linkable (prog_interface p) (prog_interface c) ->
  prepare_global_env (program_link p c) =
  global_env_union (prepare_global_env p) (prepare_global_env c).
Proof.
  intros p c Hwfp Hwfc Hlinkable.
  unfold prepare_global_env, prepare_procedures_initial_memory.
  rewrite (prepare_procedures_initial_memory_aux_after_linking
           Hwfp Hwfc Hlinkable).
  unfold global_env_union. simpl.
  rewrite !mapm_unionm.
  reflexivity.
Qed.

(* RB: NOTE: This kind of lemma is usually the composition of two unions, one
   of which is generally extant. Compare with "after_linking" lemmas. *)
Lemma imported_procedure_recombination {p c c' Cid C P} :
  Cid \notin domm (prog_interface c) ->
  imported_procedure (genv_interface (prepare_global_env (program_link p c ))) Cid C P ->
  imported_procedure (genv_interface (prepare_global_env (program_link p c'))) Cid C P.
Proof.
  intros Hdomm Himp.
  rewrite (imported_procedure_unionm_left Hdomm) in Himp.
  destruct Himp as [CI [Hcomp Himp]]. exists CI. split; [| assumption].
  unfold Program.has_component. rewrite unionmE. now rewrite Hcomp.
Qed.

Lemma genv_procedures_program_link_left_notin :
  forall {c Cid},
    Cid \notin domm (prog_interface c) ->
  forall {p},
    well_formed_program p ->
    well_formed_program c ->
    linkable (prog_interface p) (prog_interface c) ->
    (genv_procedures (prepare_global_env (program_link p c))) Cid =
    (genv_procedures (prepare_global_env p)) Cid.
Proof.
  intros c Cid Hnotin p Hwfp Hwfc Hlinkable.
  rewrite (prepare_global_env_link Hwfp Hwfc Hlinkable).
  unfold global_env_union; simpl.
  rewrite unionmE.
  assert (HNone : (genv_procedures (prepare_global_env c)) Cid = None)
    by (apply /dommPn; rewrite domm_genv_procedures; done).
  setoid_rewrite HNone.
  destruct ((genv_procedures (prepare_global_env p)) Cid) eqn:Hcase;
    by setoid_rewrite Hcase.
Qed.

Lemma genv_procedures_program_link_right_in :
  forall {c Cid},
    Cid \in domm (prog_interface c) ->
  forall {p},
    well_formed_program p ->
    well_formed_program c ->
    linkable (prog_interface p) (prog_interface c) ->
    (genv_procedures (prepare_global_env (program_link p c))) Cid =
    (genv_procedures (prepare_global_env c)) Cid.
Proof.
  intros c Cid Hnotin p Hwfp Hwfc Hlinkable.
  rewrite (prepare_global_env_link Hwfp Hwfc Hlinkable).
  unfold global_env_union; simpl.
  rewrite unionmE.
  assert (HNone : (genv_procedures (prepare_global_env p)) Cid = None).
  {
    apply/dommPn; rewrite domm_genv_procedures.
    destruct Hlinkable as [_ Hdisj].
    rewrite fdisjointC in Hdisj.
    move : Hdisj => /fdisjointP => Hdisj.
    apply Hdisj; by auto.
  }
  setoid_rewrite HNone.
  destruct ((genv_procedures (prepare_global_env p)) Cid) eqn:Hcase;
    by setoid_rewrite Hcase.
Qed.

Lemma genv_entrypoints_program_link_left :
  forall {c C},
    C \notin domm (prog_interface c) ->
  forall {p},
    well_formed_program p ->
    well_formed_program c ->
    linkable (prog_interface p) (prog_interface c) ->
  forall {P},
    EntryPoint.get C P (genv_entrypoints (prepare_global_env (program_link p c))) =
    EntryPoint.get C P (genv_entrypoints (prepare_global_env p)).
Proof.
  intros c C Hnotin p Hwfp Hwfc Hlinkable P.
  rewrite (prepare_global_env_link Hwfp Hwfc Hlinkable).
  unfold EntryPoint.get, global_env_union; simpl.
  rewrite unionmE.
  assert (HNone : (genv_entrypoints (prepare_global_env c)) C = None)
    by (apply /dommPn; rewrite domm_genv_entrypoints; done).
  rewrite HNone.
  destruct ((genv_entrypoints (prepare_global_env p)) C) eqn:Hcase;
    by rewrite Hcase.
Qed.

Lemma genv_entrypoints_interface_some p p' C P b :
  well_formed_program p ->
  well_formed_program p' ->
  prog_interface p = prog_interface p' ->
  EntryPoint.get C P (genv_entrypoints (prepare_global_env p )) = Some b ->
exists b',
  EntryPoint.get C P (genv_entrypoints (prepare_global_env p')) = Some b'.
Proof.
  move=> Hwf Hwf' Hiface. unfold EntryPoint.get; simpl.
  unfold prepare_procedures_initial_memory_aux. intros. eexists. revert H.
  rewrite !mapmE. unfold omap, obind, oapp; simpl. rewrite 2!mkfmapfE -Hiface.
  intros Hb.
  destruct (C \in domm (prog_interface p)) eqn:eC;
    rewrite eC in Hb; last discriminate; rewrite eC.
  simpl in *. find_if_inside_hyp Hb; last discriminate. inversion Hb. subst.
  setoid_rewrite mem_filter in e. setoid_rewrite mem_filter.
  move : e => /andP => [[Hentry Hbdomm]].
  unfold is_entrypoint_of_comp in *. rewrite -Hiface.
  destruct (prog_interface p C) eqn:eC2; last discriminate.
  move : Hentry => /orP => [[Hexport | Hmain]].
  - rewrite Hexport. simpl.
    assert (exists (Cprocs : NMap code) (Pcode : code),
               prog_procedures p' C = Some Cprocs /\ Cprocs b = Some Pcode)
      as [cdmap [cd [G1 G2]]].
    { eapply wfprog_exported_procedures_existence; eauto. by rewrite -Hiface. }
    rewrite G1 mem_domm G2. by simpl.
  - unfold is_main_proc in *. destruct (prog_main p) eqn:emain; last discriminate.
    rewrite Hmain.
    assert (prog_main p') as G.
    { rewrite -wfprog_main_component; auto. by rewrite -Hiface wfprog_main_component. }
    rewrite G orbT andTb. specialize (wfprog_main_existence Hwf' G) as [? [G1 G2]].
    assert (Component.main = C /\ Procedure.main = b) as [? ?]; subst.
    { move : Hmain => /andP => [[? ?]]. split; by apply beq_nat_eq. }
    by rewrite G1 G2.
Qed.

(* RB: NOTE: The two EntryPoint lemmas can be phrased as a more general one
   operating on an explicit program link, one then being the exact symmetric of
   the other, i.e., its application after communativity of linking. There is a
   choice of encoding of component membership in both cases. *)

(* RB: TODO: Rephrase goal as simple equality? *)
(* Search _ EntryPoint.get. *)
Lemma genv_entrypoints_recombination_left :
  forall p c c',
    well_formed_program p ->
    well_formed_program c ->
    well_formed_program c' ->
    mergeable_interfaces (prog_interface p) (prog_interface c) ->
    prog_interface c = prog_interface c' ->
  forall C P b,
    C \in domm (prog_interface p) ->
    EntryPoint.get C P (genv_entrypoints (prepare_global_env (program_link p c ))) = Some b ->
    EntryPoint.get C P (genv_entrypoints (prepare_global_env (program_link p c'))) = Some b.
Proof.
  intros p c c' Hwfp Hwfc Hwfc' Hmergeable_ifaces Hifacec C P b Hdomm Hentry.
  pose proof proj1 Hmergeable_ifaces as Hlinkable.
  eapply (domm_partition_notin _ _ (mergeable_interfaces_sym _ _ Hmergeable_ifaces)) in Hdomm.
  rewrite genv_entrypoints_program_link_left in Hentry; try assumption.
  rewrite Hifacec in Hlinkable, Hdomm.
  rewrite genv_entrypoints_program_link_left; assumption.
Qed.

Lemma genv_entrypoints_recombination_right :
  forall p c p' c',
    well_formed_program p ->
    well_formed_program p' ->
    well_formed_program c' ->
    mergeable_interfaces (prog_interface p) (prog_interface c) ->
    prog_interface p = prog_interface p' ->
    prog_interface c = prog_interface c' ->
  forall C P b,
    C \in domm (prog_interface c) ->
    EntryPoint.get C P (genv_entrypoints (prepare_global_env (program_link p' c'))) = Some b ->
    EntryPoint.get C P (genv_entrypoints (prepare_global_env (program_link p  c'))) = Some b.
Proof.
  intros p c p' c' Hwfp Hwfp' Hwfc' Hmergeable_ifaces Hifacep Hifacec C P b Hdomm Hentry.
  pose proof proj1 Hmergeable_ifaces as Hlinkable.
  rewrite program_linkC in Hentry; try congruence.
  rewrite program_linkC; try congruence.
  eapply genv_entrypoints_recombination_left with (c := p'); try assumption; try congruence.
  rewrite -Hifacec -Hifacep. now apply mergeable_interfaces_sym.
Qed.

Fixpoint find_label (c : code) (l : label) : option Z :=
  let fix aux c o :=
      match c with
      | [] => None
      | ILabel l' :: c' =>
        if Nat.eqb l l' then
          Some o
        else
          aux c' (1 + o)%Z
      | _ :: c' =>
        aux c' (1 + o)%Z
      end
  in aux c 0%Z.

Definition find_label_in_procedure G (pc : Pointer.t) (l : label) : option Pointer.t :=
  match getm (genv_procedures G) (Pointer.component pc) with
  | Some C_procs =>
    match getm C_procs (Pointer.block pc) with
    | Some P_code =>
      match find_label P_code l with
      | Some offset => Some (Pointer.permission pc,
                             Pointer.component pc, Pointer.block pc, offset)
      | None => None
      end
    | None => None
    end
  | None => None
  end.

Definition find_label_in_component_helper
         G (procs: list (Block.id * code))
         (pc: Pointer.t) (l: label) : option Pointer.t :=
  match filter (fun b_c =>
                  isSome
                    (find_label_in_procedure
                       G
                       (Pointer.permission pc,
                        Pointer.component pc, b_c.1, 0%Z)
                       l
                    )
               )
               procs
  with
  | [] => None
  | (p_block,p_code) :: procs' =>
    find_label_in_procedure G (Pointer.permission pc,
                               Pointer.component pc, p_block, 0%Z) l
  end.

Definition find_label_in_component G (pc : Pointer.t) (l : label) : option Pointer.t :=
  match getm (genv_procedures G) (Pointer.component pc) with
  | Some C_procs =>
    find_label_in_component_helper G (elementsm C_procs) pc l
  | None => None
  end.

Lemma find_label_in_procedure_guarantees:
  forall G pc pc' l,
    find_label_in_procedure G pc l = Some pc' ->
    Pointer.permission pc = Pointer.permission pc' /\
    Pointer.component pc = Pointer.component pc' /\
    Pointer.block pc = Pointer.block pc'.
Proof.
  intros G pc pc' l Hfind.
  unfold find_label_in_procedure in Hfind.
  destruct (getm (genv_procedures G) (Pointer.component pc)) as [procs|];
    try discriminate.
  destruct (getm procs (Pointer.block pc)) as [code|];
    try discriminate.
  destruct (find_label code l) as [offset|];
    try discriminate.
  destruct pc' as [[[pc'p pc'c] pc'b] pc'o].
  inversion Hfind. subst.
  split; auto; split; auto.
Qed.

Lemma find_label_in_procedure_spec G pc l perm c b o:
  find_label_in_procedure G pc l = Some (perm, c, b, o) <->
  (
    exists C_procs P_code,
      getm (genv_procedures G) (Pointer.component pc) = Some C_procs /\
      getm C_procs (Pointer.block pc) = Some P_code /\
      perm = Pointer.permission pc /\
      c = Pointer.component pc /\
      b = Pointer.block pc /\
      find_label P_code l = Some o
  ).
Proof.
  unfold find_label_in_procedure.
  split; [intros Hfind | intros [? [? [HC_procs [HP_code [? [? [? Ho]]]]]]]].
  - destruct (genv_procedures G (Pointer.component pc)) as [A|] eqn:eA;
      last discriminate.
    destruct (A (Pointer.block pc)) as [B|] eqn:eB; last discriminate.
    destruct (find_label B l) as [C|] eqn:eC; last discriminate.
    inversion Hfind; subst. do 2 eexists. intuition; by eauto.
  - subst. by rewrite HC_procs HP_code Ho.
Qed.

Lemma find_label_in_procedure_1:
  forall G pc pc' l,
    find_label_in_procedure G pc l = Some pc' ->
    Pointer.component pc = Pointer.component pc'.
Proof.
  eapply find_label_in_procedure_guarantees.
Qed.

Lemma find_label_in_component_helper_Some_exists_code:
  forall p procMap l pc perm c bid o,
    genv_procedures (prepare_global_env p) (Pointer.component pc) = Some procMap ->
    find_label_in_component_helper
      (prepare_global_env p) (elementsm procMap) pc l =
    Some (perm, c, bid, o) ->
    exists cd, procMap bid = Some cd.
Proof.
  intros ? ? ? ? ? ? ? ? HprocMap HSome.
  unfold find_label_in_component_helper in *.
  destruct ([seq b_c <- elementsm procMap
            | find_label_in_procedure
                (prepare_global_env p)
                (Pointer.permission pc, Pointer.component pc, b_c.1, 0%Z) l])
           as [|[p_block x] t] eqn:efilter; first discriminate.
  apply find_label_in_procedure_spec in HSome as [? [? [G1 [? [? [? [? ?]]]]]]].
  rewrite HprocMap in G1. inversion G1; subst. by eauto.
Qed.

Lemma find_label_in_procedure_program_link_left:
  forall {c pc},
    Pointer.component pc \notin domm (prog_interface c) ->
  forall {p},
    well_formed_program p ->
    well_formed_program c ->
    linkable (prog_interface p) (prog_interface c) ->
  forall {l},
    find_label_in_procedure (prepare_global_env (program_link p c)) pc l =
    find_label_in_procedure (prepare_global_env p) pc l.
Proof.
  (* RB: Note the proof strategy for all these lemmas is remarkably similar.
     It may be worthwhile to refactor it and/or its intermediate steps. *)
  intros c pc Hnotin p Hwfp Hwfc Hlinkable l.
  rewrite (prepare_global_env_link Hwfp Hwfc Hlinkable).
  unfold find_label_in_procedure, global_env_union; simpl.
  rewrite unionmE.
  assert (HNone : (genv_procedures (prepare_global_env c)) (Pointer.component pc) = None)
    by (apply /dommPn; rewrite domm_genv_procedures; done).
  rewrite HNone.
  destruct ((genv_procedures (prepare_global_env p)) (Pointer.component pc)) eqn:Hcase;
    by rewrite Hcase.
Qed.

Lemma find_label_in_component_helper_guarantees:
  forall G procs pc pc' l,
    find_label_in_component_helper G procs pc l = Some pc' ->
    Pointer.permission pc = Pointer.permission pc' /\
    Pointer.component pc = Pointer.component pc'.
Proof.
  unfold find_label_in_component_helper. intros G procs pc pc' l Hfind.
  destruct [seq b_c <- procs
           | find_label_in_procedure
               G
               (Pointer.permission pc, Pointer.component pc, b_c.1, 0%Z) l] eqn:efilter;
    first discriminate.
  destruct p as [? ?].
  apply find_label_in_procedure_guarantees in Hfind. by intuition.
Qed.

Lemma find_label_in_component_1:
  forall G pc pc' l,
    find_label_in_component G pc l = Some pc' ->
    Pointer.component pc = Pointer.component pc'.
Proof.
  intros G pc pc' l Hfind.
  unfold find_label_in_component in Hfind.
  destruct (getm (genv_procedures G) (Pointer.component pc)) as [procs|];
    try discriminate.
  eapply find_label_in_component_helper_guarantees in Hfind; by intuition.
Qed.

Lemma find_label_in_component_perm:
  forall G pc pc' l,
    find_label_in_component G pc l = Some pc' ->
    Pointer.permission pc = Pointer.permission pc'.
Proof.
  intros G pc pc' l Hfind.
  unfold find_label_in_component in Hfind.
  destruct (getm (genv_procedures G) (Pointer.component pc)) as [procs|];
    try discriminate.
  eapply find_label_in_component_helper_guarantees in Hfind; by intuition.
Qed.

Lemma find_label_in_component_program_link_left:
  forall {c pc},
    Pointer.component pc \notin domm (prog_interface c) ->
  forall {p},
    well_formed_program p ->
    well_formed_program c ->
    linkable (prog_interface p) (prog_interface c) ->
  forall {l},
    find_label_in_component (prepare_global_env (program_link p c)) pc l =
    find_label_in_component (prepare_global_env p) pc l.
Proof.
  intros c pc Hnotin p Hwfp Hwfc Hlinkable l.
  rewrite (prepare_global_env_link Hwfp Hwfc Hlinkable).
  unfold find_label_in_component. unfold global_env_union at 1. simpl.
  rewrite unionmE.
  assert (HNone : (genv_procedures (prepare_global_env c)) (Pointer.component pc) = None)
    by (apply /dommPn; rewrite domm_genv_procedures; done).
  rewrite HNone.
  destruct ((genv_procedures (prepare_global_env p)) (Pointer.component pc))
    as [procs |] eqn:Hcase;
    rewrite Hcase; simpl; last by auto.
  - simpl.
    unfold find_label_in_component_helper; simpl.
    assert (Hnotin' : forall b,
               Pointer.component
                 (Pointer.permission pc, Pointer.component pc, b, 0%Z)
                 \notin domm (prog_interface c)).
      by done.

    assert (Hrewr: forall b_c: Block.id * code,
               find_label_in_procedure
                 (global_env_union (prepare_global_env p) (prepare_global_env c))
                 (Pointer.permission pc, Pointer.component pc, b_c.1, 0%Z) l
               =
               find_label_in_procedure
                 (prepare_global_env p)
                 (Pointer.permission pc, Pointer.component pc, b_c.1, 0%Z) l
           ).
    {
      rewrite <- (prepare_global_env_link Hwfp Hwfc Hlinkable).
      intros b_c.
      by rewrite
        (find_label_in_procedure_program_link_left (Hnotin' b_c.1) Hwfp Hwfc Hlinkable).
    }
    assert (Hrewr2:
               [seq b_c <- elementsm procs
               | find_label_in_procedure
                   (global_env_union (prepare_global_env p)
                                     (prepare_global_env c))
                   (Pointer.permission pc, Pointer.component pc, b_c.1, 0%Z) l]
               =
               [seq b_c <- elementsm procs
               | find_label_in_procedure
                   (prepare_global_env p)
                   (Pointer.permission pc, Pointer.component pc, b_c.1, 0%Z) l]
           ).
    {
      apply eq_filter. unfold "=1". intros. by rewrite Hrewr.
    }
    rewrite Hrewr2.
    destruct ([seq b_c <- elementsm procs
              | find_label_in_procedure
                  (prepare_global_env p)
                  (Pointer.permission pc, Pointer.component pc, b_c.1, 0%Z) l]); auto.
    destruct p0 as [b cd].
    specialize (Hrewr (b, cd)). by simpl in Hrewr.
Qed.

(* RB: Unified presentation of linkable + linkable_mains, to be used as needed
   around the development? *)
Lemma execution_invariant_to_linking:
  forall p c1 c2 pc instr,
    linkable (prog_interface p) (prog_interface c1) ->
    linkable (prog_interface p) (prog_interface c2) ->
    well_formed_program p ->
    well_formed_program c1 ->
    well_formed_program c2 ->
    Pointer.component pc \in domm (prog_interface p) ->
    executing (prepare_global_env (program_link p c1)) pc instr ->
    executing (prepare_global_env (program_link p c2)) pc instr.
Proof.
  intros p c1 c2 pc instr Hlinkable1 Hlinkable2 Hwf Hwf1 Hwf2 Hpc Hexec.
  inversion Hexec as [procs [proc [Hgenv_procs [Hprocs_proc [Hoffset Hproc_instr]]]]].
  exists procs, proc.
  split; [| split; [| split]];
    [| assumption | assumption | assumption].
  assert (Pointer.component pc \notin domm (prog_interface c1)) as Hcc1.
  {
    inversion Hlinkable1 as [_ Hdisjoint]. apply /fdisjointP. apply Hdisjoint. assumption.
  }
  assert (Pointer.component pc \notin domm (prog_interface c2)) as Hcc2.
  {
    inversion Hlinkable2 as [_ Hdisjoint]. apply /fdisjointP. apply Hdisjoint. assumption.
  }
  rewrite (genv_procedures_program_link_left_notin Hcc1 Hwf Hwf1 Hlinkable1) in Hgenv_procs.
  rewrite (genv_procedures_program_link_left_notin Hcc2 Hwf Hwf2 Hlinkable2).
  assumption.
Qed.


Require Import Raft.
Require Import CommonDefinitions.

Section StateMachineCorrect.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition state_machine_log net :=
    forall h,
      stateMachine (nwState net h) =
      snd (execute_log (deduplicate_log (rev (removeAfterIndex (log (nwState net h))
                                                               (lastApplied (nwState net h)))))).

  Definition client_cache_correct net :=
    forall h client id out,
      getLastId (nwState net h) client = Some (id, out) ->
      output_correct client id out (rev (removeAfterIndex (log (nwState net h))
                                                          (lastApplied (nwState net h)))).

  Definition client_cache_complete net :=
    forall h e,
      In e (removeAfterIndex (log (nwState net h)) (lastApplied (nwState net h))) ->
      exists id o,
        getLastId (nwState net h) (eClient e) = Some (id, o) /\
        eId e <= id.

  Definition state_machine_correct net :=
    state_machine_log net /\ client_cache_correct net /\ client_cache_complete net.

  Class state_machine_correct_interface : Prop :=
    {
      state_machine_correct_invariant :
        forall net,
          raft_intermediate_reachable net ->
          state_machine_correct net
    }.
End StateMachineCorrect.


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

Require Import AbstractMachine.Spec.
Require Import Locks.Spec.
Require Import VMPower.Layer.
Require Import RData.
Require Import Constants.
Require Import HypsecCommLib.

Local Open Scope Z_scope.

Section BootCoreSpec.

  Definition gen_vmid_spec (adt: RData) : option (RData * Z) :=
    if halt adt then Some (adt, 0) else
    let cpu := curid adt in
    match CORE_ID @ (lock adt), CORE_ID @ (oracle adt), CORE_ID @ (log adt) with
    | LockFalse, orac, l0 =>
      match H_CalLock ((orac cpu l0) ++ l0) with
      | Some (_, LEMPTY, None) =>
        let core := CalCoreData (core_data (shared adt)) (orac cpu l0) in
        let vmid := next_vmid core in
        rely is_vmid vmid;
        if vmid <? COREVISOR then
          let core' := core {next_vmid: vmid + 1} in
          let l' :=  TEVENT cpu (TTICKET REL_LOCK) :: TEVENT cpu (TSHARED (OCORE_DATA core')) ::
                            TEVENT cpu (TSHARED (OPULL CORE_ID)) :: TEVENT cpu (TTICKET (WAIT_LOCK local_lock_bound)) ::
                            (orac cpu l0) ++ l0 in
          Some (adt {tstate: 1} {shared: (shared adt) {core_data: core'}}
                    {log: (log adt) # CORE_ID == l'} {lock: (lock adt) # CORE_ID == LockFalse},
                vmid)
        else
          let l' := TEVENT cpu (TSHARED (OPULL CORE_ID)) :: TEVENT cpu (TTICKET (WAIT_LOCK local_lock_bound)) :: (orac cpu l0) ++ l0 in
          Some (adt {halt: true} {tstate: 0} {shared: (shared adt) {core_data: core}}
                    {log: (log adt) # CORE_ID == l'} {lock: (lock adt) # CORE_ID == (LockOwn true)},
                0)
      | _ => None
      end
    | _, _, _ => None
    end.

  Definition alloc_remap_addr_spec (pgnum: Z64) (adt: RData) : option (RData * Z64) :=
    match pgnum with
    | VZ64 pgnum =>
      rely is_gfn pgnum;
      if halt adt then Some (adt, (VZ64 0)) else
      let cpu := curid adt in
      match CORE_ID @ (lock adt), CORE_ID @ (oracle adt), CORE_ID @ (log adt) with
      | LockFalse, orac, l0 =>
        match H_CalLock ((orac cpu l0) ++ l0) with
        | Some (_, LEMPTY, None) =>
          let core := CalCoreData (core_data (shared adt)) (orac cpu l0) in
          let remap := next_remap_ptr core in
          rely is_addr remap;
          if remap + pgnum * PAGE_SIZE <? REMAP_END then
            let core' := core {next_remap_ptr: remap + pgnum * PAGE_SIZE} in
            let l' :=  TEVENT cpu (TTICKET REL_LOCK) :: TEVENT cpu (TSHARED (OCORE_DATA core')) ::
                              TEVENT cpu (TSHARED (OPULL CORE_ID)) :: TEVENT cpu (TTICKET (WAIT_LOCK local_lock_bound)) ::
                              (orac cpu l0) ++ l0 in
            Some (adt {tstate: 1} {shared: (shared adt) {core_data: core'}}
                      {log: (log adt) # CORE_ID == l'} {lock: (lock adt) # CORE_ID == LockFalse},
                  (VZ64 remap))
          else
            let l' := TEVENT cpu (TSHARED (OPULL CORE_ID)) :: TEVENT cpu (TTICKET (WAIT_LOCK local_lock_bound)) :: (orac cpu l0) ++ l0 in
            Some (adt {halt: true} {tstate: 0} {shared: (shared adt) {core_data: core}}
                      {log: (log adt) # CORE_ID == l'} {lock: (lock adt) # CORE_ID == (LockOwn true)},
                  (VZ64 0))
        | _ => None
        end
      | _, _, _ => None
      end
    end.

End BootCoreSpec.

Section BootCoreSpecLow.

  Context `{real_params: RealParams}.

  Notation LDATA := RData.

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

  Definition gen_vmid_spec0  (adt: RData) : option (RData * Z) :=
    when adt' == acquire_lock_core_spec adt;
    when vmid == get_next_vmid_spec adt';
    rely is_vmid vmid;
    if vmid <? COREVISOR then
      when adt2 == set_next_vmid_spec (vmid + 1) adt';
      when adt3 == release_lock_core_spec adt2;
      when res == check_spec vmid adt3;
      Some (adt3, res)
    else
      when adt2 == panic_spec adt';
      when adt3 == release_lock_core_spec adt2;
      when res == check_spec vmid adt3;
      Some (adt3, res).

  Definition alloc_remap_addr_spec0 (pgnum: Z64) (adt: RData) : option (RData * Z64) :=
    match pgnum with
    | VZ64 pgnum =>
      when adt' == acquire_lock_core_spec adt;
      when' remap == get_next_remap_ptr_spec adt';
      rely is_addr remap; rely is_gfn pgnum;
      if remap + pgnum * PAGE_SIZE <? REMAP_END then
        when adt2 == set_next_remap_ptr_spec (VZ64 (remap + pgnum * PAGE_SIZE)) adt';
        when adt3 == release_lock_core_spec adt2;
        when' res == check64_spec (VZ64 remap) adt3;
        Some (adt3, VZ64 res)
      else
        when adt2 == panic_spec adt';
        when adt3 == release_lock_core_spec adt2;
        when' res == check64_spec (VZ64 remap) adt3;
        Some (adt3, VZ64 res)
    end.

  Inductive gen_vmid_spec_low_step `{StencilOps} `{Mem.MemoryModelOps} `{UseMemWithData mem}:
    sextcall_sem (mem := mwd LDATAOps) :=
  | gen_vmid_spec_low_intro s (WB: _ -> Prop) m'0 labd labd'  res
      (Hinv: high_level_invariant labd)
      (Hspec: gen_vmid_spec0 labd = Some (labd', (Int.unsigned res))):
      gen_vmid_spec_low_step s WB nil (m'0, labd) (Vint res) (m'0, labd').

  Inductive alloc_remap_addr_spec_low_step `{StencilOps} `{Mem.MemoryModelOps} `{UseMemWithData mem}:
    sextcall_sem (mem := mwd LDATAOps) :=
  | alloc_remap_addr_spec_low_intro s (WB: _ -> Prop) m'0 labd labd' pgnum res
      (Hinv: high_level_invariant labd)
      (Hspec: alloc_remap_addr_spec0 (VZ64 (Int64.unsigned pgnum)) labd = Some (labd', (VZ64 (Int64.unsigned res)))):
      alloc_remap_addr_spec_low_step s WB ((Vlong pgnum)::nil) (m'0, labd) (Vlong res) (m'0, labd').

  Section WITHMEM.

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

    Definition gen_vmid_spec_low: compatsem LDATAOps :=
      csem gen_vmid_spec_low_step (type_of_list_type nil) Tint32.

    Definition alloc_remap_addr_spec_low: compatsem LDATAOps :=
      csem alloc_remap_addr_spec_low_step (type_of_list_type (Tint64::nil)) Tint64.

  End WITHMEM.

End BootCoreSpecLow.


(** * Every parse tree has a corresponding minimal parse tree *)

Require Import Coq.omega.Omega.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.Properties.
Require Import Fiat.Parsers.StringLike.LastChar.
Require Import Fiat.Parsers.Reachable.OnlyLast.Reachable.
Require Import Fiat.Parsers.Reachable.OnlyLast.MinimalReachable.
Require Import Fiat.Parsers.Reachable.OnlyLast.MinimalReachableOfReachable.
Require Import Fiat.Parsers.Reachable.MaybeEmpty.MinimalOfCore.
Require Import Fiat.Parsers.Reachable.MaybeEmpty.OfParse.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Common.

Set Implicit Arguments.
Local Open Scope string_like_scope.

Section cfg.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char} {G : grammar Char}.
  Context {predata : @parser_computational_predataT Char}
          {rdata' : @parser_removal_dataT' _ G predata}.

  Definition for_last_char_reachable_from_parse_of_item'
             (for_last_char_reachable_from_parse_of_productions
              : forall valid0 pats
                       (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
                       (str : String) (p : parse_of G str pats)
                       (Hforall : Forall_parse_of (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p),
                  for_last_char str (fun ch => inhabited (reachable_from_productions G ch valid0 pats)))
             {valid0 it}
             (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
             (str : String) (p : parse_of_item G str it)
             (Hforall : Forall_parse_of_item (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p)
  : for_last_char str (fun ch => inhabited (reachable_from_item G ch valid0 it)).
  Proof.
    destruct p as [ | nt ? p ].
    { rewrite <- for_last_char_singleton by eassumption.
      repeat constructor; assumption. }
    { specialize (for_last_char_reachable_from_parse_of_productions valid0 (G nt) Hsub str p (snd Hforall)).
      revert for_last_char_reachable_from_parse_of_productions.
      apply for_last_char_Proper; [ reflexivity | intros ? [H'] ].
      constructor.
      constructor; simpl in *; [ exact (fst Hforall) | assumption ]. }
  Defined.

  Fixpoint for_last_char_reachable_from_parse_of_productions
             {valid0 pats}
             (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
             (str : String) (p : parse_of G str pats)
             (Hforall : Forall_parse_of (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p)
             {struct p}
  : for_last_char str (fun ch => inhabited (reachable_from_productions G ch valid0 pats))
  with for_last_char_reachable_from_parse_of_production
         {valid0 pat}
         (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
         (str : String) (p : parse_of_production G str pat)
         (Hforall : Forall_parse_of_production (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p)
         {struct p}
       : for_last_char str (fun ch => inhabited (reachable_from_production G ch valid0 pat)).
  Proof.
    { destruct p as [ ?? p | ?? p ]; simpl in *.
      { generalize (for_last_char_reachable_from_parse_of_production valid0 _ Hsub _ p Hforall).
        apply for_last_char_Proper; [ reflexivity | intros ? [H']; constructor ].
        left; assumption. }
      { generalize (for_last_char_reachable_from_parse_of_productions valid0 _ Hsub _ p Hforall).
        apply for_last_char_Proper; [ reflexivity | intros ? [H']; constructor ].
        right; assumption. } }
    { destruct p as [ | [|n] ? p ]; simpl in *.
      { apply for_last_char_nil; assumption. }
      { rewrite <- drop_0.
        generalize (@for_last_char_reachable_from_parse_of_production valid0 _ Hsub _ _ (snd Hforall)).
          apply for_last_char_Proper; [ reflexivity | intros ? [H']; constructor ].
          right; assumption. }
      { specialize (for_last_char_reachable_from_parse_of_production _ _ Hsub _ _ (snd Hforall)).
destruct (Compare_dec.le_lt_dec (length str) (S n)) as [Hle|Hle].
        { pose proof (fun pf => parse_empty_minimal_maybe_empty_parse_of_production Hsub pf _ (snd Hforall)) as Hempty.
          rewrite drop_length in Hempty.
          specialize_by omega.
          generalize (@for_last_char_reachable_from_parse_of_item' for_last_char_reachable_from_parse_of_productions valid0 _ Hsub _ _ (fst Hforall)).
          rewrite take_long by omega.
          apply for_last_char_Proper; [ reflexivity | intros ? [H']; constructor ].
          eapply maybe_empty_production__of__minimal_maybe_empty_production in Hempty; [ | reflexivity ].
          left; assumption. }
        { revert for_last_char_reachable_from_parse_of_production.
          rewrite <- for_last_char__drop by assumption.
          apply for_last_char_Proper; [ reflexivity | intros ? [H']; constructor ].
          right; assumption. } } }
  Defined.

  Definition for_last_char_reachable_from_parse_of_item
             {valid0 it}
             (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
             (str : String) (p : parse_of_item G str it)
             (Hforall : Forall_parse_of_item (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p)
  : for_last_char str (fun ch => inhabited (reachable_from_item G ch valid0 it))
    := @for_last_char_reachable_from_parse_of_item' (@for_last_char_reachable_from_parse_of_productions) valid0 it Hsub str p Hforall.

  Definition for_last_char_minimal_reachable_from_parse_of_item
             {valid0 it}
             (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
             (str : String) (p : parse_of_item G str it)
             (Hforall : Forall_parse_of_item (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p)
  : for_last_char str (fun ch => inhabited (minimal_reachable_from_item (G := G) valid0 ch valid0 it)).
  Proof.
    setoid_rewrite <- (minimal_reachable_from_item__iff__reachable_from_item Hsub).
    eapply for_last_char_reachable_from_parse_of_item; eassumption.
  Qed.

  Definition for_last_char_minimal_reachable_from_parse_of_production
             {valid0 pat}
             (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
             (str : String) (p : parse_of_production G str pat)
             (Hforall : Forall_parse_of_production (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p)
  : for_last_char str (fun ch => inhabited (minimal_reachable_from_production (G := G) valid0 ch valid0 pat)).
  Proof.
    setoid_rewrite <- (minimal_reachable_from_production__iff__reachable_from_production Hsub).
    eapply for_last_char_reachable_from_parse_of_production; eassumption.
  Qed.

  Definition for_last_char_minimal_reachable_from_parse_of_productions
             {valid0 pats}
             (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
             (str : String) (p : parse_of G str pats)
             (Hforall : Forall_parse_of (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p)
  : for_last_char str (fun ch => inhabited (minimal_reachable_from_productions (G := G) valid0 ch valid0 pats)).
  Proof.
    setoid_rewrite <- (minimal_reachable_from_productions__iff__reachable_from_productions Hsub).
    eapply for_last_char_reachable_from_parse_of_productions; eassumption.
  Qed.
End cfg.


Require Import VST.floyd.proofauto.
Import ListNotations.
Local Open Scope logic.

Require Import sha.vst_lemmas.
Require Import sha.hmac_common_lemmas.

Require Import sha.hkdf.
Require Import sha.spec_hmac.
Require Import sha.spec_hkdf.
Require Import sha.hkdf_functional_prog.

Lemma body_hkdf_extract: semax_body Hkdf_VarSpecs Hkdf_FunSpecs
       f_HKDF_extract HKDF_extract_spec.
Proof.
start_function.
rename H into LenSalt. rename H0 into LenSecret.
freeze [0;2;3;4] FR1.
assert_PROP (isptr salt) as Ptr_salt.
{ unfold data_block. normalize. rewrite data_at_isptr. entailer!. }
apply vst_lemmas.isptrD in Ptr_salt. destruct Ptr_salt as [sb [si SLT]]. subst salt.
thaw FR1.
idtac "Timing the call to HMAC".
Time forward_call (out, SALT, Tsh, secret, SECRET, Tsh, shmd, sb, si, gv). (*3.7s*)
apply extract_exists_pre; intros Hmac.
idtac "Timing the normalize". Time normalize. (*Coq8.6: 1secs*)
(*yields
H: ByteBitRelations.bytesToBits
      (HMAC256_functional_prog.HMAC256 (CONT SECRET) (CONT SALT)) =
    verif_hmac_crypto.bitspec SALT SECRET
H0 : forall
       (A : Comp.OracleComp
              (HMAC_spec_abstract.HMAC_Abstract.Message
                 HMAC256_isPRF.PARS256.P)
              (Bvector.Bvector ShaInstantiation.c) bool)
       (Awf : DistSem.well_formed_oc A), verif_hmac_crypto.CRYPTO A Awf
 and substitutes Hmac. *)
rename H into HypHmacBits. rename H0 into HmacCrypto.
remember (HMAC256_functional_prog.HMAC256 (CONT SECRET) (CONT SALT)) as Hmac. rename HeqHmac into HypHmac.

(*idtac "Timing the Intros". Time Intros. (*Coq8.6: 146s*) (*Coq8.5: 77.468 secs (77.25u,0.015s)*)
(*yields
H : Hmac = HMAC256_functional_prog.HMAC256 (CONT SECRET) (CONT SALT)
H0 : ByteBitRelations.bytesToBits Hmac =
     verif_hmac_crypto.bitspec SALT SECRET
H1 : forall
       (A : Comp.OracleComp
              (HMAC_spec_abstract.HMAC_Abstract.Message
                 HMAC256_isPRF.PARS256.P)
              (Bvector.Bvector ShaInstantiation.c) bool)
       (Awf : DistSem.well_formed_oc A), verif_hmac_crypto.CRYPTO A Awf,
so the same except for the substitution*)
(*rename H into HypHmac. rename H0 into HypHmacBits. Intros. rename H1 into HmacCrypto.*)*)

assert_PROP (isptr out) as Ptr_out.
{ unfold data_block. normalize. rewrite data_at_isptr. entailer!. }
forward_if (PROP ( )
   LOCAL (temp _t'1 out; temp _out_key out;
   temp _out_len olen; temp _salt (Vptr sb si); temp _salt_len (Vint (Int.repr (LEN SALT)));
   temp _secret secret; temp _secret_len (Vint (Int.repr (LEN SECRET)));
   gvars gv)
   SEP (spec_sha.K_vector gv; data_block shmd Hmac out; initPostKey Tsh (Vptr sb si) (CONT SALT);
   data_block Tsh (CONT SECRET) secret; data_at_ Tsh tuint olen)).
{ apply denote_tc_test_eq_split.
  + unfold data_block. normalize.
    apply sepcon_valid_pointer1.
    apply sepcon_valid_pointer1.
    apply sepcon_valid_pointer1.
    apply sepcon_valid_pointer2. apply data_at_valid_ptr.
    apply readable_nonidentity. apply writable_readable; trivial.
    rewrite HMAC_Zlength; simpl; lia.
  + auto with valid_pointer. }
{ subst out; contradiction. }
{ clear H; forward. entailer!. rewrite <- @change_compspecs_data_block. simpl; auto. }

forward. forward.
simpl.
unfold HKDF_extract. cancel. rewrite @change_compspecs_data_block. trivial.
Time Qed.
(*Finished transaction in 0.545 secs (0.544u,0.s) (successful)*)


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import ssrZ ZArith_ext seq_ext machine_int multi_int uniq_tac.
Import MachineInt.
Require Import mips_seplog mips_tactics mips_contrib mapstos mips_frame.
Require Import copy_s_u_prg multi_is_zero_u_triple copy_u_u_triple.
Require Import multi_zero_s_triple.
Import expr_m.
Import assert_m.

Local Open Scope machine_int_scope.
Local Open Scope multi_int_scope.
Local Open Scope heap_scope.
Local Open Scope zarith_ext_scope.
Local Open Scope uniq_scope.
Local Open Scope mips_expr_scope.
Local Open Scope mips_assert_scope.
Local Open Scope mips_cmd_scope.
Local Open Scope mips_hoare_scope.

Lemma copy_s_u_triple rk rx ry xtmp ytmp i j : uniq(rk, rx, ry, xtmp, ytmp, i, j, r0) ->
  forall X Y nk, size X = nk -> size Y = nk ->
    forall slen,
      forall ptr, u2Z ptr + 4 * Z_of_nat nk < \B^1 ->
      forall vy, u2Z vy + 4 * Z_of_nat nk < \B^1 ->
  {{ fun s h => [ry]_s = vy /\
    u2Z [rk]_s = Z_of_nat nk /\
    ((var_e rx |--> slen :: ptr :: nil ** int_e ptr |--> X) **
     var_e ry |--> Y) s h }}
  copy_s_u rk rx ry xtmp ytmp i j
  {{ fun s h => [ry]_s = vy /\
    u2Z [rk]_s = Z_of_nat nk /\
    ((var_e rx |--> (if \S_{ nk } Y == 0 then zero32 else Z2u 32 (Z_of_nat nk)) :: ptr :: nil **
       int_e ptr |--> (if \S_{ nk } Y == 0 then X else Y)) **
      var_e ry |--> Y) s h }}.
Proof.
move=> Hnodup X Y nk X_nk Y_nk slen ptr ptr_fit vy vy_fit.
rewrite /copy_s_u.

apply while.hoare_seq with (fun s h => [ry]_s = vy /\
  u2Z ([rk ]_ s) = Z_of_nat nk /\
  ((var_e rx |--> slen :: ptr :: nil ** int_e ptr |--> X) ** var_e ry |--> Y) s h /\
  (0 = \S_{ nk } Y -> [i]_s = one32) /\
  (0 < \S_{ nk } Y -> [i]_s = zero32)).

have : uniq(rk, ry, xtmp, ytmp, i, r0) by Uniq_uniq r0.
move/multi_is_zero_u_triple/(_ _ _ _ Y_nk vy_fit) => Htmp.
eapply (before_frame (var_e rx |--> slen :: ptr :: nil ** int_e ptr |--> X)).
  apply frame_rule_R.
    by apply Htmp.
    rewrite [modified_regs _]/=; by Inde.
  by [].
  move=> s h [ry_vy [rk_nk]].
  case => h1 [h2 [h1dh2 [h1Uh2 [Hh1 Hh2]]]].
  rewrite assert_m.conCE.
  by exists h1, h2; repeat (split => //).
move=> s h.
case => h1 [h2 [h1dh2 [h1Uh2 [Hh1 Hh2]]]].
case: Hh1 => rk_nk [ry_vy [Hh1 HSum]].
repeat (split; first by []).
split; last by [].
rewrite assert_m.conCE.
by exists h1, h2.

apply hoare_ifte_bang.

apply (hoare_prop_m.hoare_stren (fun s h => 0 < \S_{ nk } Y /\ [ry ]_ s = vy /\
  u2Z ([rk ]_ s) = Z_of_nat nk /\
  ((var_e rx |--> slen :: ptr :: nil ** int_e ptr |--> X) ** var_e ry |--> Y) s h)).

move=> s h H.
apply assert_m.con_and_bang_inv_R in H.
case: H => [[ry_vy [rk_nk [H HSum]]] Htest].
repeat (split => //).
case/leZ_eqVlt : (min_lSum nk Y) => // Sum_Y.
case: HSum.
move/(_ Sum_Y) => Hi _.
rewrite /= Hi store.get_r0 in Htest.
move/eqP : Htest.
by rewrite !Z2uK.

apply (hoare_prop_m.pull_out_conjunction' hoare0_false) => HSum.

apply hoare_lw_back_alt'' with (fun s h =>
  [ry ]_ s = vy /\
  u2Z ([rk ]_ s) = Z_of_nat nk /\
  ((var_e rx |--> slen :: ptr :: nil ** int_e ptr |--> X) ** var_e ry |--> Y) s h /\
  [xtmp]_s = ptr).

move=> s h [ry_vy [rk_nk Hmem]].
exists ptr; split.
- rewrite -assert_m.mapsto2_mapstos in Hmem.
  Rotate Hmem.
  move: Hmem; apply assert_m.monotony => // h'.
  apply assert_m.mapsto_ext => //.
  by rewrite sext_Z2u.
- rewrite /update_store_lw.
  repeat Reg_upd.
  repeat (split; first by []).
  split; last by [].
  by Assert_upd.

apply while.hoare_seq with (
  !(fun s => ([xtmp ]_ s) = ptr) **
  !(fun s => ([ry ]_ s) = vy) **
  !(fun s => u2Z ([rk ]_ s) = Z_of_nat nk) **
  (var_e ry |--> Y ** var_e xtmp |--> Y) **
  var_e rx |--> slen :: ptr :: nil).

have : uniq(rk, xtmp, ry, ytmp, i, j, r0) by Uniq_uniq r0.
move/copy_u_u_triple/(_ _ _ _ Y_nk X_nk _ ptr_fit) => Htmp.
eapply (before_frame (!(fun s => [ry ]_ s = vy) ** (var_e rx |--> slen :: ptr :: nil))).
apply frame_rule_R.
  by apply Htmp.
  rewrite [modified_regs _]/=; by Inde.
done.
move=> s h [ry_vy [rk_nk [Hmem xtmp_ptr]]].
rewrite assert_m.conAE in Hmem.
case: Hmem => h1 [h2 [h1dh2 [h1Uh2 [Hh1 Hh2]]]].
rewrite assert_m.conCE.
exists h1, h2; repeat (split => //).
apply assert_m.con_and_bang_L => //.
rewrite assert_m.conCE.
move: Hh2.
apply assert_m.monotony => // h'.
by apply assert_m.mapstos_ext.
move=> s h H.
case: H => h1 [h2 [h1dh2 [h1Uh2 [[xtmp_ptr [rk_nk Hh1]] Hh2]]]].
apply assert_m.con_and_bang_inv_L in Hh2.
case: Hh2 => ry_vy Hh2.
apply assert_m.con_and_bang_L => //.
apply assert_m.con_and_bang_L => //.
apply assert_m.con_and_bang_L => //.
by exists h1, h2.

apply hoare_sw_back' => s h H.
rewrite -assert_m.mapsto2_mapstos in H.
do 5 rewrite assert_m.conCE !assert_m.conAE in H.
exists (int_e slen).
move: H; apply assert_m.monotony => // h'.
- apply assert_m.mapsto_ext => //.
  by rewrite /= sext_Z2u // addi0.
- apply assert_m.currying => h'' Hh''.
  rewrite !assert_m.conAE in Hh''.
  do 2 rewrite assert_m.conCE !assert_m.conAE in Hh''.
  apply assert_m.con_and_bang_inv_L in Hh''.
  case: Hh'' => ry_vy Hh''.
  apply assert_m.con_and_bang_inv_L in Hh''.
  case: Hh'' => rk_nk Hh''.
  repeat (split; first by []).
  rewrite assert_m.conCE.
  do 4 rewrite assert_m.conCE !assert_m.conAE in Hh''.
  apply assert_m.con_and_bang_inv_L in Hh''.
  case: Hh'' => xtmp_ptr Hh''.
  move: Hh''; apply assert_m.monotony => // h3.
  have -> : \S_{ nk } Y == 0 = false.
    apply/eqP => abs; rewrite abs in HSum.
    by apply ltZZ in HSum.
  rewrite assert_m.conCE.
  apply assert_m.monotony => // h4; last first.
    by apply assert_m.mapstos_ext => /=.
  rewrite -assert_m.mapsto2_mapstos.
  apply assert_m.monotony => // h5.
  apply assert_m.mapsto_ext => //=.
  by rewrite sext_Z2u // addi0.
  by rewrite -rk_nk Z2u_u2Z.

have : uniq(rx, r0) by Uniq_uniq r0.
move/(multi_zero_s_triple)/(_ X ptr slen) => Htmp.
eapply (before_frame (fun s h => ([ry ]_ s) = vy /\ u2Z ([rk ]_ s) = Z_of_nat nk /\ (var_e ry |--> Y) s h /\ \S_{ nk } Y = 0)).
apply frame_rule_R.
by apply Htmp.
done.
done.
move=> s h H.
apply assert_m.con_and_bang_inv_R in H.
case: H => [[ry_vy [rk_nk [H HSum]]] Htest].
case: H => h1 [h2 [h1dh2 [h1Uh2 [Hh1 Hh2]]]].
exists h1, h2; repeat (split => //).
rewrite /= store.get_r0 Z2uK // in Htest.
case: HSum => _ HSum.
case/leZ_eqVlt : (min_lSum nk Y) => // Sum_Y.
apply HSum in Sum_Y.
by rewrite Sum_Y Z2uK in Htest.

move=> s h [h1 [h2 [h1dh2 [h1Uh2 [Hh1 Hh2]]]]].
case: Hh2 => ry_vy [rk_nk [Hh2 HSum]].
repeat (split; first by []).
rewrite HSum eqxx.
by exists h1, h2; repeat (split => //).
Qed.