(* *********************************************************************)
(*                                                                     *)
(*            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 MShareIntro 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 MShare.
Require Import MShareOpCSource.
Require Import ShareGenSpec.

Module MSHARECODE.

  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.

  Lemma SharedMemInfo2Z_valid: forall x,
                                 SharedMemInfo2Z x =
                                 Int.unsigned (Int.repr (SharedMemInfo2Z x)).
  Proof.
    destruct x; simpl; reflexivity.
  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 SHAREDMEMSTATUS.

      Let L: compatlayer (cdata RData) :=
        get_shared_mem_seen ↦ gensem get_shared_mem_seen_spec
      ⊕ set_shared_mem_seen ↦ gensem set_shared_mem_seen_spec
      ⊕ get_shared_mem_state ↦ gensem get_shared_mem_state_spec
      ⊕ get_shared_mem_status_seen ↦ gensem get_shared_mem_status_seen_spec.

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

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

      Section SharedMemStatusBody.

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

        (**)

        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_seen: block.

        Hypothesis hget_shared_mem_seen1 : Genv.find_symbol ge get_shared_mem_seen = Some bget_shared_mem_seen.

        Hypothesis hget_shared_mem_seen2 : Genv.find_funct_ptr ge bget_shared_mem_seen =
        Some (External (EF_external get_shared_mem_seen
                                    (signature_of_type (Tcons tint (Tcons tint Tnil)) tint cc_default))
                       (Tcons tint (Tcons tint Tnil)) tint cc_default).

        (**)

        Variable bget_shared_mem_status_seen: block.

        Hypothesis hget_shared_mem_status_seen1 : Genv.find_symbol ge get_shared_mem_status_seen =
                                                  Some bget_shared_mem_status_seen.

        Hypothesis hget_shared_mem_status_seen2 : Genv.find_funct_ptr ge bget_shared_mem_status_seen =
        Some (External (EF_external get_shared_mem_status_seen
                                    (signature_of_type (Tcons tint (Tcons tint Tnil)) tint cc_default))
                       (Tcons tint (Tcons tint Tnil)) tint cc_default).

      (*******************)

        Function ll_shared_mem_status_spec (pid1 pid2: Z) (adt: RData) : option (RData * Z) :=
          match (ikern adt, ihost adt, pg adt, ipt adt, shared_mem_arg pid1 pid2) with
            | (true, true, true, true, true) =>
              match ZMap.get pid2 (ZMap.get pid1 (smspool adt)) with
                | SHRDValid i' true _ =>
                  match get_shared_mem_status_seen_spec pid1 pid2 adt with
                    | Some j => Some (adt, j)
                    | _ => None
                  end
                | SHRDValid i' false vadr =>
                  Some (adt {smspool: ZMap.set pid1 (ZMap.set pid2 (SHRDValid i' true vadr)
                                                              (ZMap.get pid1 (smspool adt)))
                                               (smspool adt)}, SharedMemInfo2Z i')
                | _ => None
              end
            | _ => None
          end.

        Lemma ll_shared_mem_status__correct: forall m d d' (z: Z) env le pid1 pid2 n,
                                      env = PTree.empty _ ->
                                      PTree.get _source le = Some (Vint pid1) ->
                                      PTree.get _dest le = Some (Vint pid2) ->
                                      (*pg d = true ->*)
                                      ll_shared_mem_status_spec (Int.unsigned pid1) (Int.unsigned pid2) d
                                      = Some (d', Int.unsigned n) ->
                                      high_level_invariant d ->
                                      exists (le': temp_env),
                                        exec_stmt ge env le ((m, d): mem) shared_mem_status_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 H4. (*high_level_invariant d *)
          functional inversion H3; subst.
          - esplit.
            unfold exec_stmt.
            change E0 with (E0 ** E0).
            repeat vcgen.
            + unfold get_shared_mem_seen_spec.
              rewrite H7, H8, H9, H10, H6.
              rewrite H11.
              unfold BooltoZ.
              cutrewrite (1 = Int.unsigned (Int.repr 1)); reflexivity.
            + repeat vcgen.
            + repeat vcgen.
          - esplit.
            unfold exec_stmt.
            change E0 with (E0 ** E0).
            repeat vcgen.
            + unfold get_shared_mem_seen_spec.
              rewrite H7, H8, H9, H10, H6.
              rewrite H11.
              unfold BooltoZ.
              cutrewrite (0 = Int.unsigned (Int.repr 0)); reflexivity.
            + unfold exec_stmt.
              change E0 with (E0 ** E0).
              repeat vcgen.
              unfold get_shared_mem_state_spec. simpl.
              rewrite H7, H8, H9, H10, H6.
              repeat rewrite ZMap.gss.
              rewrite SharedMemInfo2Z_valid.
              reflexivity.
            + rewrite H5. repeat vcgen.
        Qed.

        Lemma ll_shared_mem_status_spec__correct: forall (pid1 pid2: Z) (adt: RData),
                                                    ll_shared_mem_status_spec pid1 pid2 adt =
                                                    shared_mem_status_spec pid1 pid2 adt.
        Proof.
          intros.
          unfold ll_shared_mem_status_spec, shared_mem_status_spec.
          unfold get_shared_mem_status_seen_spec.
          destruct (ikern adt), (ihost adt), (pg adt), (ipt adt), (shared_mem_arg pid1 pid2); try trivial.
          destruct (ZMap.get pid2 (ZMap.get pid1 (smspool adt))); try trivial.
          destruct seen; try trivial.
          destruct (ZMap.get pid1 (ZMap.get pid2 (smspool adt))); try trivial.
          destruct (SharedMemInfo_dec info0 SHRDPEND); try trivial.
        Qed.

        Lemma shared_mem_status__correct: forall m d d' (z: Z) env le pid1 pid2 n,
                                      env = PTree.empty _ ->
                                      PTree.get _source le = Some (Vint pid1) ->
                                      PTree.get _dest le = Some (Vint pid2) ->
                                      (*pg d = true ->*)
                                      shared_mem_status_spec (Int.unsigned pid1) (Int.unsigned pid2) d
                                      = Some (d', Int.unsigned n) ->
                                      high_level_invariant d ->
                                      exists (le': temp_env),
                                        exec_stmt ge env le ((m, d): mem) shared_mem_status_body E0 le' (m, d') (Out_return (Some (Vint n, tint))).
        Proof.
          intros.
          rewrite <- ll_shared_mem_status_spec__correct in H2.
          apply ll_shared_mem_status__correct with pid1 pid2; auto.
        Qed.

      End SharedMemStatusBody.

      Theorem shared_mem_status_code_correct:
        spec_le (shared_mem_status ↦ shared_mem_status_spec_low) (〚shared_mem_status ↦ f_shared_mem_status 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (shared_mem_status__correct s (Genv.globalenv p) makeglobalenv
                                             b2 Hb2fs Hb2fp
                                             b1 Hb1fs Hb1fp
                                             b0 Hb0fs Hb0fp
                                             b3 Hb3fs Hb3fp
                                             m'0 labd labd'
                                             (Int.unsigned n)
                                             (PTree.empty _)
                                             (bind_parameter_temps' (fn_params f_shared_mem_status)
                                                                    (Vint pid1 :: Vint pid2 :: nil)
                                                                    (create_undef_temps
                                                                       (fn_temps f_shared_mem_status))))
                 H0.
      Qed.

    End SHAREDMEMSTATUS.

    (**************************************)

    Section OFFERSHAREDMEM.

      Let resv2_sem := pt_resv2 ↦ gensem ptResv2_spec.

      Let L: compatlayer (cdata RData) :=
          resv2_sem
        (*⊕ container_alloc ↦ gensem alloc_spec*)
        ⊕ shared_mem_to_ready ↦ gensem shared_mem_to_ready_spec
        ⊕ shared_mem_to_pending ↦ gensem shared_mem_to_pending_spec
        ⊕ shared_mem_to_dead ↦ gensem shared_mem_to_dead_spec
        ⊕ 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 OfferSharedMemBody.

        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 bshared_mem_to_ready: block.

        Hypothesis hshared_mem_to_ready1 : Genv.find_symbol ge shared_mem_to_ready = Some bshared_mem_to_ready.

        Hypothesis hshared_mem_to_ready2 : Genv.find_funct_ptr ge bshared_mem_to_ready =
                      Some (External (EF_external shared_mem_to_ready (signature_of_type (Tcons tint (Tcons tint (Tcons tint Tnil))) tint cc_default)) (Tcons tint (Tcons tint (Tcons tint Tnil))) tint cc_default).

        (**)

        Variable bshared_mem_to_dead: block.

        Hypothesis hshared_mem_to_dead1 : Genv.find_symbol ge shared_mem_to_dead = Some bshared_mem_to_dead.

        Hypothesis hshared_mem_to_dead2 :
          Genv.find_funct_ptr ge bshared_mem_to_dead =
          Some (External (EF_external shared_mem_to_dead
                                      (signature_of_type
                                         (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default))
                         (Tcons tint (Tcons tint (Tcons tint Tnil))) Tvoid cc_default).

        (**)

        Variable bshared_mem_to_pending: block.

        Hypothesis hshared_mem_to_pending1 : Genv.find_symbol ge shared_mem_to_pending = Some bshared_mem_to_pending.

        Hypothesis hshared_mem_to_pending2 :
          Genv.find_funct_ptr ge bshared_mem_to_pending =
          Some (External (EF_external shared_mem_to_pending
                                      (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_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).

        (**)

        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 /\ ikern adt = true /\ ihost adt = true.
        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 /\ ikern adt = true /\ ihost adt = true.
        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 & HE4 & H6).
              destruct H3 as ( _ & _ & HE5 & _ & _).
              refine_split'; eauto. congruence.
            + eapply ptInsert0_presv in H0.
              eapply ptInsert0_presv in H3. simpl in *.
              destruct H0 as (HE1 & HE2 & HE3 & Hk & Hh).
              destruct H3 as ( _ & _ & HE5 & _ & _).
              refine_split'; eauto. congruence.
        Qed.

        Hypothesis smspool_vadr_valid: forall pid1 pid2 d vadr i s,
                                      shared_mem_arg (Int.unsigned pid1)
                                                     (Int.unsigned pid2) = true ->
                                      ZMap.get (Int.unsigned pid1)
                                               (ZMap.get (Int.unsigned pid2) (smspool d)) =
                                          SHRDValid i s vadr ->
                                      vadr = Int.unsigned (Int.repr vadr).

        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_ikern: 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)
                                -> ikern 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 & r & e).
          assumption.
        Qed.

        Lemma ptResv2_presv_ihost: 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)
                                -> ihost 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 & r & e).
          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 & r & e).
          assumption.
        Qed.

  (*Function ll_offer_shared_mem_spec (pid1 pid2 vadr: Z) (adt: RData) : option (RData * Z) :=
    match (ikern adt, ihost adt, pg adt, ipt adt, shared_mem_arg pid1 pid2) with
      | (true, true, true, true, true) =>
        match ZMap.get pid2 (ZMap.get pid1 (smspool adt)) with
          | SHRDValid st _ _ =>
            if SharedMemInfo_dec st SHRDPEND then Some (adt, SHARED_MEM_PEND)
            else
              match ZMap.get pid1 (ZMap.get pid2 (smspool adt)) with
                | SHRDValid st' _ vadr' =>
                  if SharedMemInfo_dec st' SHRDPEND then
                    match shared_mem_to_ready_spec pid1 pid2 vadr adt with
                      | Some (adt', re) =>
                        if zeq re MagicNumber
                        then match shared_mem_to_dead_spec pid1 pid2 vadr adt' with
                                 | Some adt'' => Some (adt'', SHARED_MEM_DEAD)
                                 | _ => None
                             end
                        else Some (adt', SHARED_MEM_READY)
                      | _ => None
                    end
                  else match shared_mem_to_pending_spec pid1 pid2 vadr adt with
                                 | Some adt'' => Some (adt'', SHARED_MEM_PEND)
                                 | _ => None
                       end
                | _ => None
              end
          | _ => None
        end
      | _ => None
    end.*)
        Lemma ll_offer_shared_mem_spec__correct: forall (pid1 pid2 vadr: Z) (adt: RData),
                                      ll_offer_shared_mem_spec pid1 pid2 vadr adt =
                                      offer_shared_mem_spec pid1 pid2 vadr adt.
        Proof.
          intros.
          unfold ll_offer_shared_mem_spec, offer_shared_mem_spec.
          unfold shared_mem_to_ready_spec, shared_mem_to_dead_spec, shared_mem_to_pending_spec.
          destruct (ikern adt), (ihost adt), (pg adt), (ipt adt), (shared_mem_arg pid1 pid2); try trivial.
          destruct (ZMap.get pid2 (ZMap.get pid1 (smspool adt))) eqn:M21; try trivial.
          destruct (SharedMemInfo_dec info SHRDPEND); try trivial.
          destruct (ZMap.get pid1 (ZMap.get pid2 (smspool adt))) eqn:M12; try trivial.
          destruct (zle_lt 0 vadr1 4294967296) as [x | x]; try trivial.
          destruct (SharedMemInfo_dec info0 SHRDPEND); try trivial.
          destruct (ptResv2_spec pid1 vadr 7 pid2 vadr1 7 adt) eqn:resq; try trivial.
          destruct p. destruct (zeq z MagicNumber) eqn:zeq; try trivial.
            - simpl.
              destruct (ptResv2_presv_pg_idt' pid1 pid2 adt vadr vadr1 r z 7 7 resq) as (a & b & c & q & t).
              cutrewrite (ikern r = true).
              cutrewrite (ihost r = true).
              cutrewrite (pg r = true).
              cutrewrite (ipt r = true).
              cutrewrite (smspool r = smspool adt).
              rewrite M21, M12. reflexivity.
              assumption. assumption. assumption. assumption. assumption.
            - destruct (Coqlib.zeq z MagicNumber). discriminate zeq.
              simpl. reflexivity.
         Qed.

        Require Import AuxLemma.

        Lemma ptInsert0_range:
          forall p1 p2 v d d' re n,
            ptInsert0_spec p1 p2 v n d = Some (d', re) ->
            262144 <= nps d <= 1048576 ->
            0 <= re <= Int.max_unsigned.
        Proof.
          intros. rewrite_omega.
          functional inversion H; subst; try omega.
          functional inversion H10; try subst; try omega.
        Qed.

        Lemma ptInsert0_range':
          forall p1 p2 v d d' re n,
            ptInsert0_spec p1 p2 v n d = Some (d', re) ->
            262144 <= nps d <= 1048576 ->
            262144 <= nps d' <= 1048576.
        Proof.
          intros.
          functional inversion H; subst;
          functional inversion H10; try subst; try subst d'; trivial;
          try rewrite H1 in *; trivial;
          functional inversion H12; trivial.
        Qed.

        Lemma shared_mem_to_ready_range:
          forall p1 p2 v d d' re,
            shared_mem_to_ready_spec p1 p2 v d = Some (d', re) ->
            262144 <= nps d <= 1048576 ->
            0 <= re <= Int.max_unsigned.
        Proof.
          intros. rewrite_omega.
          functional inversion H; clear H; [omega|].
          functional inversion H11; clear H11; subst; try omega.
          eapply ptInsert0_range; eauto.
          eapply ptInsert0_range'; eauto.
          functional inversion H13; clear H13; subst; trivial.
        Qed.

        Lemma ll_offer_shared_mem__correct: forall m d d' (z: Z) env le pid1 pid2 vadr n,
                                      env = PTree.empty _ ->
                                      PTree.get _source le = Some (Vint pid1) ->
                                      PTree.get _dest le = Some (Vint pid2) ->
                                      PTree.get _source_va le = Some (Vint vadr) ->
                                      (*pg d = true ->*)
                                      ll_offer_shared_mem_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) offer_shared_mem_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; subst.
            - esplit.
              unfold exec_stmt.
              change E0 with (E0 ** E0).
              repeat vcgen.
                + unfold get_shared_mem_state_spec.
                  rewrite H8, H9, H10, H11, H7.
                  rewrite H12.
                  simpl.
                  cutrewrite (1 = Int.unsigned (Int.repr 1));
                    reflexivity.
                + simpl. destruct (zeq (Int.unsigned (Int.repr 1)) 1). reflexivity.
                  contradiction n0. reflexivity.
                + repeat vcgen.
                + rewrite PTree.gss. rewrite H6, Int.repr_unsigned. reflexivity.
            - esplit;
              unfold exec_stmt;
              change E0 with (E0 ** E0);
              repeat vcgen.
                + unfold get_shared_mem_state_spec.
                  rewrite H8, H9, H10, H11, H7.
                  rewrite H12.
                  simpl.
                  rewrite SharedMemInfo2Z_valid.
                  reflexivity.
                + destruct (zeq (Int.unsigned (Int.repr (SharedMemInfo2Z st))) 1).
                    * rewrite <- SharedMemInfo2Z_valid in e.
                      functional inversion e.
                      clear H13. rewrite <- H20 in _x1.
                      apply False_rect; auto.
                    * repeat vcgen.
                + repeat vcgen.
                    * unfold get_shared_mem_state_spec.
                      rewrite shared_mem_arg_rev.
                      rewrite H8, H9, H10, H11, H7.
                      rewrite H14. rewrite SharedMemInfo2Z_valid.
                      reflexivity.
                    * repeat vcgen.
                    * repeat vcgen.
                + rewrite PTree.gss, H6, Int.repr_unsigned. trivial.
            - esplit;
              unfold exec_stmt;
              change E0 with (E0 ** E0);
              repeat vcgen.
                + unfold get_shared_mem_state_spec.
                  rewrite H8, H9, H10, H11, H7.
                  rewrite H12.
                  simpl.
                  rewrite SharedMemInfo2Z_valid.
                  reflexivity.
                + destruct (zeq (Int.unsigned (Int.repr (SharedMemInfo2Z st))) 1).
                    * rewrite <- SharedMemInfo2Z_valid in e.
                      functional inversion e.
                      clear H13. rewrite <- H19 in _x1.
                      apply False_rect; auto.
                    * repeat vcgen.
                + assert (re_range: 0 <= re <= Int.max_unsigned). {
                    eapply shared_mem_to_ready_range; eauto.
                  }
                  repeat vcgen.
                  * unfold get_shared_mem_state_spec.
                    rewrite shared_mem_arg_rev.
                    rewrite H8, H9, H10, H11, H7.
                    rewrite H14. rewrite SharedMemInfo2Z_valid.
                    reflexivity.
                  * repeat vcgen.
                  * repeat vcgen.
                + rewrite PTree.gss, H6, Int.repr_unsigned. trivial.
            - esplit.
              unfold exec_stmt.
              change E0 with (E0 ** E0).
              repeat vcgen.
              + unfold get_shared_mem_state_spec.
                rewrite H8, H9, H10, H11, H7.
                rewrite H12.
                simpl.
                rewrite SharedMemInfo2Z_valid.
                reflexivity.
              + destruct (zeq (Int.unsigned (Int.repr (SharedMemInfo2Z st))) 1).
                * rewrite <- SharedMemInfo2Z_valid in e.
                  functional inversion e.
                  clear H13. rewrite <- H18 in _x1.
                  apply False_rect; auto.
                * repeat vcgen.
              + repeat vcgen.
                * unfold get_shared_mem_state_spec.
                  rewrite shared_mem_arg_rev.
                  rewrite H8, H9, H10, H11, H7.
                  rewrite H14. rewrite SharedMemInfo2Z_valid.
                  reflexivity.
                * destruct (zeq (Int.unsigned (Int.repr (SharedMemInfo2Z st'))) 1).
                  {
                    rewrite <- SharedMemInfo2Z_valid in e.
                    functional inversion e.
                    clear H16. rewrite <- H18 in _x4.
                    apply False_rect; auto.
                  }
                  repeat vcgen.
                * repeat vcgen.
              + rewrite PTree.gss, H6, Int.repr_unsigned. trivial.
        Qed.

        Lemma offer_shared_mem__correct: forall m d d' (z: Z) env le pid1 pid2 vadr n,
                                      env = PTree.empty _ ->
                                      PTree.get _source le = Some (Vint pid1) ->
                                      PTree.get _dest le = Some (Vint pid2) ->
                                      PTree.get _source_va le = Some (Vint vadr) ->
                                      (*pg d = true ->*)
                                      offer_shared_mem_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) offer_shared_mem_body E0 le' (m, d') (Out_return (Some (Vint n, tint))).
        Proof.
          intros.
          rewrite <- ll_offer_shared_mem_spec__correct in H3.
          apply ll_offer_shared_mem__correct with pid1 pid2 vadr; auto.
        Qed.

      End OfferSharedMemBody.

      Theorem offer_shared_mem_code_correct:
        spec_le (offer_shared_mem ↦ offer_shared_mem_spec_low) (〚offer_shared_mem ↦ f_offer_shared_mem 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (offer_shared_mem__correct s (Genv.globalenv p) makeglobalenv
                                             b0 Hb0fs Hb0fp
                                             b2 Hb2fs Hb2fp
                                             b1 Hb1fs Hb1fp
                                             b3 Hb3fs Hb3fp
                                             m'0 labd labd'
                                             (Int.unsigned n)
                                             (PTree.empty _)
                                             (bind_parameter_temps' (fn_params f_offer_shared_mem)
                                                                    (Vint pid1 :: Vint pid2 :: Vint vadr :: nil)
                                                                    (create_undef_temps
                                                                       (fn_temps f_offer_shared_mem))))
                 H0.
      Qed.

    End OFFERSHAREDMEM.

  End WithPrimitives.

End MSHARECODE.


Require Import Coq.Program.Basics.
Require Import LogicalRelations.
Require Import SimulationRelation.
Require Import Structures.
Require Import OptionOrders.
Require Import compcert.lib.Floats.
Require Import compcert.common.Values.
Local Opaque mwd_ops.

(** * [lessdef] (and [Mem.extends]) as a simulation relation *)

Section LESSDEF_SIMREL.
  Context `{Hmem: BaseMemoryModel}.
  Context {D: layerdata}.

  Definition simrel_lessdef_ops: simrel_components D D :=
    {|
      simrel_world := unit;
      simrel_acc := {| Structures.le x y := True |};
      simrel_undef_matches_values_bool := true;
      simrel_undef_matches_block p b := True;
      simrel_new_glbl := nil;
      simrel_meminj p := inject_id;
      match_mem p := Mem.extends
    |}.

  Require Import ExtensionalityAxioms.

  Lemma match_ptr_simrel_lessdef p:
    match_ptr simrel_lessdef_ops p = eq.
  Proof.
    eapply functional_extensionality; intros [b1 o1].
    eapply functional_extensionality; intros [b2 o2].
    eapply prop_ext.
    split.
    - destruct 1; simpl in *; subst; try constructor.
      inversion H; subst.
      f_equal.
      omega.
    - destruct 1.
      apply match_block_sameofs_ptr; auto.
      reflexivity.
  Qed.

  Lemma match_ptrbits_simrel_lessdef p:
    match_ptrbits simrel_lessdef_ops p = eq.
  Proof.
    eapply functional_extensionality; intros [b1 o1].
    eapply functional_extensionality; intros [b2 o2].
    eapply prop_ext.
    split.
    - destruct 1; simpl in *; subst; try constructor.
      inversion H; subst.
      rewrite Ptrofs.add_zero.
      reflexivity.
    - destruct 1.
      apply match_block_sameofs_ptrbits; auto.
      reflexivity.
  Qed.

  Lemma match_ptrrange_simrel_lessdef p:
    match_ptrrange simrel_lessdef_ops p = eq.
  Proof.
    eapply functional_extensionality; intros [[b1 lo1] hi1].
    eapply functional_extensionality; intros [[b2 lo2] hi2].
    eapply prop_ext.
    split.
    - destruct 1.
      inversion H; simpl in *.
      inversion H1; simpl in *.
      rewrite Z.add_0_r.
      reflexivity.
    - inversion 1; subst.
      replace hi2 with (lo2 + (hi2 - lo2)) by omega.
      constructor.
      pattern lo2 at 2.
      replace lo2 with (lo2 + 0) by omega.
      constructor.
      reflexivity.
  Qed.

  Lemma match_block_simrel_lessdef p:
    match_block simrel_lessdef_ops p = eq.
  Proof.
    apply eqrel_eq; split.
    - intros b1 b2 [delta Hdelta].
      inversion Hdelta.
      reflexivity.
    - intros b1 b2 H; subst.
      eexists.
      reflexivity.
  Qed.

  Lemma match_block_sameofs_simrel_lessdef p:
    match_block_sameofs simrel_lessdef_ops p = eq.
  Proof.
    apply eqrel_eq; split.
    - intros b1 b2 Hb.
      inversion Hb.
      reflexivity.
    - intros b1 b2 H; subst.
      constructor.
  Qed.

  Lemma match_val_simrel_lessdef p:
    match_val simrel_lessdef_ops p = Val.lessdef.
  Proof.
    eapply functional_extensionality; intro v1.
    eapply functional_extensionality; intro v2.
    eapply prop_ext.
    split.
    - destruct 1; simpl in *; subst; try constructor.
      rewrite match_ptrbits_simrel_lessdef in H.
      inversion H; subst.
      reflexivity.
    - destruct 1.
      + destruct v; try constructor.
        rewrite match_ptrbits_simrel_lessdef.
        reflexivity.
      + destruct v; constructor; constructor.
  Qed.

  Lemma match_memval_simrel_lessdef p:
    match_memval simrel_lessdef_ops p = memval_lessdef.
  Proof.
    eapply functional_extensionality; intro v1.
    eapply functional_extensionality; intro v2.
    eapply prop_ext.
    split.
    - destruct 1; simpl in *; subst; try constructor.
      destruct H; try constructor.
      inversion H; subst.
      inversion H1; subst.
      econstructor.
      reflexivity.
      reflexivity.
    - destruct 1.
      + constructor.
      + constructor.
        rewrite match_val_simrel_lessdef.
        destruct H; try constructor; eauto.
        inversion H; clear H; subst.
        rewrite Ptrofs.add_zero.
        reflexivity.
      + destruct mv; constructor; try constructor.
        rewrite match_val_simrel_lessdef.
        constructor.
  Qed.

  (** Initial memory *)

  Require Import InitMemRel.

  Lemma store_zeros_right_extends:
    forall (m2: mwd D) b lo hi m2',
      store_zeros m2 b lo hi = Some m2' ->
      forall m1, Mem.extends m1 m2 ->
                 (forall o k p, Mem.perm m1 b o k p -> False) ->
                 Mem.extends m1 m2'.
  Proof.
    intros until hi.
    functional induction (store_zeros m2 b lo hi); try congruence.
    intros. eapply IHo; eauto using (Mem.store_outside_extends (mem := mwd D)).
  Qed.

(* XXX: coqrel *)

Global Instance prod_rel_fst {A1 A2 B1 B2} (RA: rel A1 A2) (RB: rel B1 B2):
  Related (prod_rel RA RB) (RA @@ fst)%rel subrel.
Proof.
  clear.
  firstorder.
Qed.

Global Instance prod_rel_snd {A1 A2 B1 B2} (RA: rel A1 A2) (RB: rel B1 B2):
  Related (prod_rel RA RB) (RB @@ snd)%rel subrel.
Proof.
  clear.
  firstorder.
Qed.

Global Instance option_ifsome_le_subrel {A B} (R: rel A B):
  Related (option_le R) (option_ifsome_rel R) subrel.
Proof.
  destruct 1; red; congruence.
Qed.

Global Instance: Params (@Mem.drop_perm) 5.

  Global Instance simrel_lessdef_init_mem {F1 F2 V} ng umv:
    InitMemSimrel (D1:=D) (D2:=D) (F1:=F1) (F2:=F2) (V:=V)
      ng umv
      (fun _ _ _ _ => Mem.extends).
  Proof.
    assert (forall i, simrel_newfun_ok nil true i).
    {
      intros i.
      split; reflexivity.
    }
    assert (forall i init, simrel_newvar_ok nil true i init).
    {
      intros i init.
      right.
      split; reflexivity.
    }
    split; intros.
    - apply Mem.extends_refl.
    - intros m1 m2 Hm.
      unfold alloc_none.
      destruct (Mem.alloc m1 _ _) as [m1' b] eqn:Hm1'.
      edestruct (Mem.alloc_extends m1 m2) as (m2' & Hm2' & Hm'); eauto.
      + reflexivity.
      + reflexivity.
      + rewrite Hm2'.
        constructor.
        eauto.
    - intros m1 m2 Hm.
      unfold alloc_none, alloc_fun.
      destruct (Mem.alloc m1 _ _) as [m1' b] eqn:Hm1'.
      edestruct (Mem.alloc_extends m1 m2) as (m2' & Hm2' & Hm'); eauto.
      + reflexivity.
      + instantiate (1:=1).
        omega.
      + rewrite Hm2'.
        edestruct (Mem.range_perm_drop_2 m2' b 0 1 Nonempty) as [m2'' Hm2''].
        {
          intros ofs Hofs.
          eapply Mem.perm_alloc_2; eauto.
        }
        rewrite Hm2''.
        constructor.
        eapply Mem.drop_perm_right_extends; eauto.
        intros ofs k p Hp Hofs.
        eapply Mem.perm_alloc_3 in Hp; eauto.
        omega.
    - split.
      + assumption.
      + intros sz Hsz m1 m2 Hm.
        destruct (Mem.alloc m1 _ _) as [m1' b1] eqn:Hm1'; simpl.
        edestruct (Mem.alloc_extends m1 m2) as (m2' & Hm2' & Hm');
        rewrite ?Hm2'; eauto.
        * reflexivity.
        * subst.
          apply genv_init_data_list_size_pos.
      + intros p sz m1 m2 m2' Hsz Hm1 Hm2' Hm.
        eapply Mem.store_outside_extends; eauto.
        intros ofs Hofs _.
        eapply Hm1; eauto.
      + intros sz ge1 ge2 base next m1 m2 m2' Hsz Hm1 Hge Hm2' Hm.
        eapply Genv.store_init_data_right_extends; eauto.
        intros.
        eapply Hm1; eauto.
      + intros sz m1 m2 m2' Hsz Hm1 Hm2' Hm.
        eapply Mem.drop_perm_right_extends; eauto.
        intros.
        eapply Hm1; eauto.
    - intros m1 m2 Hm.
      unfold alloc_fun.
      destruct (Mem.alloc m1 _ _) as [m1' b1] eqn:Hm1'.
      transport Hm1'.
      rewrite H1; subst.
      solve_monotonic.
    - split.
      + reflexivity.
      + intros.
        solve_monotonic.
      + intros.
        solve_monotonic.
      + intros sz base next Hsz ge1 ge2 Hge m1 m2 Hm m1' m2' Hm1' Hm2'.
        edestruct (Genv.store_init_data_parallel_extends (mem := mwd D) ge1) as (?&?&?); eauto.
        erewrite (Genv.store_init_data_symbols_preserved ge1 ge2) in Hm2'.
        congruence.
        intro.
        rewrite !stencil_matches_symbols by eauto.
        reflexivity.
      + unfold alloc_var_perm.
        intros.
        solve_monotonic.
  Qed.

  Global Instance simrel_lessdef_prf:
    SimulationRelation simrel_lessdef_ops.
  Proof.
    assert (Heqsub: forall A B, subrel (@eqrel A B) (@subrel A B)).
    {
      intros A B x y H.
      repeat red in H.
      tauto.
    }
    constructor; try now repeat constructor.

    (** [Genv.init_mem] *)
    - intros.
      eapply genv_init_mem_simrel.
      + typeclasses eauto.
      + simpl.
        intros m1 m2 Hm.
        exists tt; solve_monotonic.

    (** [Mem.alloc] *)
    - exists tt.
      split; simpl; eauto.
      destruct (Mem.alloc x _ _) eqn:Halloc1.
      simpl in H.
      edestruct (Mem.alloc_extends x) as (? & Halloc2 & ?); eauto; try reflexivity.
      rewrite Halloc2.
      constructor; eauto.
      reflexivity.

    (** [Mem.free] *)
    - repeat red.
      simpl.
      inversion 2; subst.
      rewrite match_ptr_simrel_lessdef in H1.
      inversion H1; subst.
      simpl.
      destruct (Mem.free x _ _ _) eqn:Hfree1; try constructor.
      edestruct (Mem.free_parallel_extends x) as (? & Hfree2 & ?); eauto.
      rewrite Hfree2.
      constructor.
      exists p; eauto.

    (** [Mem.load] *)
    - intro p.
      rewrite match_val_simrel_lessdef.
      rewrite match_ptr_simrel_lessdef.
      simpl.
      repeat red.
      intros a x y H x0 y0 H0.
      subst.
      destruct y0.
      simpl.
      destruct (Mem.load _ x _ _) eqn:Hload; try constructor.
      edestruct (Mem.load_extends a x) as (? & Hload2 & ?); eauto.
      rewrite Hload2.
      constructor; assumption.

    (** [Mem.store] *)
    - intro p.
      rewrite match_val_simrel_lessdef.
      rewrite match_ptr_simrel_lessdef.
      simpl.
      repeat red.
      intros a x y H x0 y0 H0 x1 y1 H1.
      subst.
      destruct y0.
      simpl.
      destruct (Mem.store _ x _ _ _) eqn:Hstore1; try constructor.
      edestruct (Mem.store_within_extends a x) as (? & Hstore2 & ?); eauto.
      rewrite Hstore2.
      constructor.
      exists p; eauto.

    (** [Mem.loadbytes] *)
    - intro p.
      rewrite match_memval_simrel_lessdef.
      rewrite match_ptr_simrel_lessdef.
      repeat red.
      intros x y H x0 y0 H0 a.
      subst.
      destruct y0.
      simpl in *.
      destruct (Mem.loadbytes x _ _ _) eqn:Hlb1; try constructor.
      edestruct (Mem.loadbytes_extends x) as (? & Hlb2 & ?); eauto.
      rewrite Hlb2.
      constructor.
      rewrite <- CompcertStructures.list_forall2_list_rel; assumption.

    (** [Mem.storebytes] *)
    - intro p.
      rewrite match_memval_simrel_lessdef.
      rewrite match_ptr_simrel_lessdef.
      repeat red.
      intros x y H x0 y0 H0 x1 y1 H1.
      subst.
      destruct y0.
      simpl in *.
      destruct (Mem.storebytes x _ _ _) eqn:Hsb1; try constructor.
      edestruct (Mem.storebytes_within_extends x) as (? & Hsb2 & ?); eauto.
      { rewrite CompcertStructures.list_forall2_list_rel; eassumption. }
      rewrite Hsb2.
      constructor.
      exists p; eauto.

    (** [Mem.perm] *)
    - intros p.
      rewrite match_ptr_simrel_lessdef.
      repeat red.
      intros x y H x0 y0 H0 a a0 H1.
      subst.
      destruct y0.
      simpl in *.
      eapply Mem.perm_extends; eauto.

    (** [Mem.valid_block] *)
    - intros p.
      rewrite match_block_simrel_lessdef.
      simpl.
      intros m1 m2 Hm b1 b2 Hb; subst.
      eapply Mem.valid_block_extends; eauto.

    (** [Mem.different_pointers_inject] *)
    - inversion 5; subst.
      inversion 1; subst.
      tauto.

    (** [Mem.weak_valid_pointer_inject_val] *)
    - intros p m1 m2 b1 ofs1 b2 ofs2 H H0 H1.
      rewrite match_ptrbits_simrel_lessdef in H1.
      inversion H1; clear H1; subst.
      eapply Mem.weak_valid_pointer_extends; eauto.

    (** [Mem.weak_valid_pointer_address_inject_weak] *)
    - intros p m1 m2 b1 b2 delta H H0.
      inversion H0; clear H0; subst.
      exists 0.
      intros ofs1 H0.
      rewrite Ptrofs.add_zero.
      omega.

    (** [Mem.address_inject *)
    - simpl.
      inversion 4; subst.
      rewrite Ptrofs.add_zero.
      omega.

    (** [Mem.aligned_area_inject] *)
    - simpl.
      inversion 8; subst.
      rewrite Z.add_0_r.
      assumption.

    (** [Mem.disjoint_or_equal_inject] *)
    - simpl.
      inversion 3; subst.
      inversion 1; subst.
      repeat rewrite Z.add_0_r.
      tauto.
  Qed.

  Definition ext :=
    {|
      simrel_ops := simrel_lessdef_ops
    |}.
End LESSDEF_SIMREL.

(* Memory extension is absorbed by any other simulation relation
   with Vundef/Undef as lower bounds. *)

Section EXTENDS_COMPOSE.
  Context `{Hmem: BaseMemoryModel}.
  Context {D1 D2} (R: simrel D1 D2).

  Program  (* improves type checking. *)
  Definition equiv_extends_compose_left:
    simrel_equiv_maps (simrel_compose (ext (D:=D1)) R) R
    :=
      {|
        simrel_equiv_fw := snd;
        simrel_equiv_bw q := (tt, q)
      |}.

  Program  (* improves type checking. *)
  Definition equiv_extends_compose_right:
    simrel_equiv_maps (simrel_compose R (ext (D:=D2))) R
    :=
      {|
        simrel_equiv_fw := fst;
        simrel_equiv_bw q := (q, tt)
      |}.

  Hypothesis undef_values:
    simrel_undef_matches_values R.

  Section LEFT.

    Hypothesis undef_block:
      forall p b,
        (exists b' : block, match_block R p b' b) ->
        simrel_undef_matches_block R p b.

    Hypothesis compose_left:
      forall p m1 m2 m3,
        Mem.extends m1 m2 ->
        match_mem R p m2 m3 ->
        match_mem R p m1 m3.

    Theorem extends_compose_left:
      SimulationRelationEquivalence _ _ equiv_extends_compose_left.
    Proof.
      constructor; simpl; auto; try tauto; try (compute; tauto).
      + intros p.
        intro b.
        destruct 1 as [ [ ? [ ? ? ] ] | ] ; eauto.
      + intros p.
        intros m1 m3 (m2 & Hm1 & Hm2). eauto.
      + intros p m1 m2 Hm.
        exists m1; split; auto. apply Mem.extends_refl.
      + intros p b. unfold compose_meminj, inject_id.
        destruct (simrel_meminj R (snd p) b) as [ [ ? ? ] | ] ; constructor; auto.
      + intros p b.
        unfold compose_meminj, inject_id.
        destruct (simrel_meminj R p b) as [ [ ? ? ] | ] ; constructor; auto.
      + intros [u p]. split; simpl; auto. reflexivity.
      + intros p. reflexivity.
    Qed.

  End LEFT.

  Section RIGHT.

    Hypothesis undef_block:
      forall p b,
        simrel_undef_matches_block R p b.

    Hypothesis compose_right:
      forall p m1 m2 m3,
        match_mem R p m1 m2 ->
        Mem.extends m2 m3 ->
        match_mem R p m1 m3.

    Theorem extends_compose_right:
      SimulationRelationEquivalence _ _ equiv_extends_compose_right.
    Proof.
      constructor; simpl; auto; try tauto; try (compute; tauto).
      + red in undef_values.
        rewrite undef_values.
        reflexivity.
      + symmetry; apply app_nil_end.
      + intros p b. intro H. apply undef_block.
      + intros p m1 m3 (m2 & Hm12 & Hm23). eauto.
      + intros p m1 m2 Hm12.
        exists m2; split; auto.
        apply Mem.extends_refl.
      + intros p b.
        unfold compose_meminj, inject_id.
        destruct (simrel_meminj R (fst p) b) as [ [ ? ? ] | ] ; constructor; auto.
        rewrite Z.add_0_r; reflexivity.
      + intros p b. unfold compose_meminj, inject_id.
        destruct (simrel_meminj R p b) as [ [ ? ? ] | ] ; constructor; auto.
        rewrite Z.add_0_r; reflexivity.
      + intros [u p]; split; simpl; reflexivity.
      + intros p; simpl; reflexivity.
    Qed.

  End RIGHT.

End EXTENDS_COMPOSE.

(* As an application, memory extension is idempotent. *)

Section EXTENDS_IDEM.
  Context `{Hmem: BaseMemoryModel}.
  Context {D: layerdata}.

  Global Instance extends_compose:
    SimulationRelationEquivalence _ _ (equiv_extends_compose_right (ext (D:=D))).
  Proof.
    apply extends_compose_right; simpl; auto.
    - reflexivity.
    - intro.
      apply Mem.extends_extends_compose.
  Qed.
End EXTENDS_IDEM.

(** * Strong version of extends for [ec_mem_extends]. Coincidentally,
      it will also work for [ec_max_perm] and [ec_valid_block] (which
      are necessary for Mem.unchanged_on to work).
      To factor proofs, we enrich it with [ec_readonly].
 *)

Section STRONG_LESSDEF_SIMREL.
  Context `{Hmem: BaseMemoryModel}.
  Context {D: layerdata}.

  Record strong_extends_carrier: Type :=
    mk_strong_extends_carrier
    {
      strong_extends_high: mwd D;
      strong_extends_low: mwd D;
      strong_extends_prop: Mem.extends strong_extends_high strong_extends_low
    }.

  Lemma strong_extends_carrier_eq mm1 mm2:
    strong_extends_high mm1 = strong_extends_high mm2 ->
    strong_extends_low mm1 = strong_extends_low mm2 ->
    mm1 = mm2.
  Proof.
    intros H H0.
    destruct mm1; destruct mm2; simpl in * |- * ; subst.
    f_equal;
      apply ProofIrrelevance.proof_irrelevance.
  Qed.

  Definition strong_extends (mm: strong_extends_carrier) m m': Prop :=
    m = strong_extends_high mm /\
    m' = strong_extends_low mm.

  Lemma strong_extends_intro m m':
    Mem.extends m m' ->
    { mm | strong_extends mm m m' }.
  Proof.
    intros H.
    exists (mk_strong_extends_carrier _ _ H).
    split; auto.
  Qed.

  Lemma strong_extends_elim mm m m':
    strong_extends mm m m' ->
    Mem.extends m m'.
  Proof.
    unfold strong_extends.
    destruct mm; simpl; intuition congruence.
  Qed.

  Hint Resolve strong_extends_elim.

  Definition strong_extends_le (mm1 mm2: strong_extends_carrier): Prop :=
    let m1 := strong_extends_high mm1 in
      let m'1 := strong_extends_low mm1 in
      let m2 := strong_extends_high mm2 in
      let m'2 := strong_extends_low mm2 in
      Mem.unchanged_on (Events.loc_not_writable m1) m1 m2 /\
      Mem.unchanged_on (Events.loc_out_of_bounds m1) m'1 m'2 /\
      (forall b, Mem.valid_block m1 b -> Mem.valid_block m2 b) /\
      (forall b o p, Mem.valid_block m1 b -> Mem.perm m2 b o Max p -> Mem.perm m1 b o Max p).

  Local Instance strong_extends_le_refl:
    Reflexive strong_extends_le.
  Proof.
    red. intros [m m' ?]; simpl.
    unfold strong_extends_le. simpl.
    constructor; auto using (Mem.unchanged_on_refl (mem := mwd D)).
  Qed.

  Local Instance strong_extends_le_trans:
    Transitive strong_extends_le.
  Proof.
    red.
    intros [m1 m'1 ?] [m2 m'2 ?] [m3 m'3 ?].
    unfold strong_extends_le. simpl.
    destruct 1 as (? & ? & ? & ?).
    destruct 1 as (? & ? & ? & ?).
    split.
    {
      eapply Mem.unchanged_on_trans_strong with (Q := Events.loc_not_writable m2); eauto.
      unfold Events.loc_not_writable.
      intros b H5_ o H6_.
      intro ABSURD.
      apply H6_.
      eapply H2; eauto.
    }
    split; auto.
    eapply Mem.unchanged_on_trans_strong with (Q := Events.loc_out_of_bounds m2); eauto.
    unfold Events.loc_out_of_bounds.
    intros b H5_ o H6_.
    intro ABSURD.
    apply H6_.
    eapply H2; eauto.
    erewrite Mem.valid_block_extends; eauto.
  Qed.

  Lemma strong_extends_le_intro mm1 m1 m'1 m2 m'2:
    strong_extends mm1 m1 m'1 ->
    Mem.extends m2 m'2 ->
    Mem.unchanged_on (Events.loc_not_writable m1) m1 m2 ->
    Mem.unchanged_on (Events.loc_out_of_bounds m1) m'1 m'2 ->
    (forall b, Mem.valid_block m1 b -> Mem.valid_block m2 b) ->
    (forall b o p, Mem.valid_block m1 b -> Mem.perm m2 b o Max p -> Mem.perm m1 b o Max p) ->
    { mm2 | strong_extends mm2 m2 m'2 /\
            strong_extends_le mm1 mm2 }.
  Proof.
    intros H H0 H1 H2 H3 H4.
    exists (mk_strong_extends_carrier _ _ H0).
    split.
    { constructor; auto. }
    inversion H; subst.
    constructor; auto.
  Qed.

  Lemma strong_extends_le_elim mm1 m1 m'1 mm2 m2 m'2:
    strong_extends mm1 m1 m'1 ->
    strong_extends mm2 m2 m'2 ->
    strong_extends_le mm1 mm2 ->
    Mem.unchanged_on (Events.loc_not_writable m1) m1 m2 /\
    Mem.unchanged_on (Events.loc_out_of_bounds m1) m'1 m'2 /\
    (forall b, Mem.valid_block m1 b -> Mem.valid_block m2 b) /\
    (forall b o p, Mem.valid_block m1 b -> Mem.perm m2 b o Max p -> Mem.perm m1 b o Max p).
  Proof.
    inversion 1; subst.
    inversion 1; subst.
    inversion 1; subst.
    tauto.
  Qed.

  Definition simrel_strong_extends_ops :=
    {|
      simrel_world := strong_extends_carrier;
      simrel_acc := {| Structures.le := strong_extends_le |};
      simrel_undef_matches_values_bool := true;
      simrel_undef_matches_block p b := True;
      simrel_meminj p := inject_id;
      simrel_new_glbl := nil;
      match_mem := strong_extends
    |}.

  Require Import ExtensionalityAxioms.

  (* We try to take advantage of the fact that simrel_meminj is
     the same as for lessdef, to share proofs. *)

  Lemma match_strong_extends_ptr p:
    match_ptr simrel_strong_extends_ops p = eq.
  Proof.
    rewrite <- (match_ptr_simrel_lessdef (D:=D) tt).
    eapply functional_extensionality; intros [b1 o1].
    eapply functional_extensionality; intros [b2 o2].
    eapply prop_ext.
    split; inversion 1; constructor; auto.
  Qed.

  Lemma match_strong_extends_ptrbits p:
    match_ptrbits simrel_strong_extends_ops p = eq.
  Proof.
    rewrite <- (match_ptrbits_simrel_lessdef (D:=D) tt).
    eapply functional_extensionality; intros [b1 o1].
    eapply functional_extensionality; intros [b2 o2].
    eapply prop_ext.
    split; inversion 1; constructor; auto.
  Qed.

  Lemma match_strong_extends_block p:
    match_block simrel_strong_extends_ops p = eq.
  Proof.
    rewrite <- (match_block_simrel_lessdef (D:=D) tt).
    apply eqrel_eq; split; repeat red; tauto.
  Qed.

  Lemma match_strong_extends_val p:
    match_val simrel_strong_extends_ops p = Val.lessdef.
  Proof.
    rewrite <- (match_val_simrel_lessdef (D:=D) tt).
    eapply functional_extensionality; intro v1.
    eapply functional_extensionality; intro v2.
    eapply prop_ext; split; inversion 1; constructor; auto;
    (try rewrite (match_ptrbits_simrel_lessdef tt) in * |- *);
    (try rewrite (match_strong_extends_ptrbits p) in * |- *);
    auto.
    match goal with
        K: match_ptrbits simrel_lessdef_ops _ _ _ |- _ =>
        rewrite (match_ptrbits_simrel_lessdef tt) in K
    end.
    congruence.
  Qed.

  Lemma match_strong_extends_memval p:
    match_memval simrel_strong_extends_ops p = memval_lessdef.
  Proof.
    rewrite <- (match_memval_simrel_lessdef (D:=D) tt).
    eapply functional_extensionality; intro v1.
    eapply functional_extensionality; intro v2.
    eapply prop_ext; split; inversion 1; constructor; auto;
    (try rewrite (match_ptrbits_simrel_lessdef tt) in * |- *);
    (try rewrite (match_strong_extends_ptrbits p) in * |- *);
    (try rewrite (match_strong_extends_val p) in * |- *);
    (try rewrite (match_val_simrel_lessdef tt) in * |- *);
    auto.
    rewrite (match_val_simrel_lessdef tt) in H0.
    assumption.
  Qed.

  Global Instance simrel_strong_extends_prf:
    SimulationRelation simrel_strong_extends_ops.
  Proof.
    assert (Heqsub: forall A B, subrel (@eqrel A B) (@subrel A B)).
    {
      intros A B x y H.
      repeat red in H.
      tauto.
    }
    constructor; try now repeat constructor.

    (** preorder *)
    - constructor; typeclasses eauto.

    (** [Genv.init_mem] *)
    - intros F V p1 p2 Hp.
      apply (simrel_init_mem (R := ext (D:=D))) in Hp.
      inversion Hp; clear Hp; subst; try now constructor.
      lazymatch goal with
        K: _ x y |- _ =>
        destruct K as [w Hm];
          rename x into m1;
          rename y into m2
      end.
      simpl in Hm.
      apply strong_extends_intro in Hm.
      destruct Hm as [ mm Hm ].
      constructor.
      exists mm.
      assumption.

    (** [Mem.alloc] *)
    - intros p m1 m1' Hm1 lo hi.
      destruct (Mem.alloc m1 _ _) eqn:Halloc1.
      edestruct (Mem.alloc_extends m1) as (? & Halloc2 & Hm2); eauto; try reflexivity.
      rewrite Halloc2.
      destruct (strong_extends_le_intro p _ _ _ _ Hm1 Hm2) as [p' Hp'].
      + eapply Mem.alloc_unchanged_on; eauto.
      + eapply Mem.alloc_unchanged_on; eauto.
      + eapply Mem.valid_block_alloc; eauto.
      + intros; eapply Mem.perm_alloc_4; eauto.
        intro ABSURD; subst.
        edestruct (Mem.fresh_block_alloc m1); eauto.
      + destruct Hp'.
        reexists; repeat rstep.
        reflexivity.

    (** [Mem.free] *)
    - intros p m1 m1' Hm1 [[b_ o_] ?] [[b o] ? ] Hb.
      inversion Hb as [? ? ? ? sz]; clear Hb; subst.
      match goal with
          K: match_ptr _ _ _ _ |- _ =>
          rewrite match_strong_extends_ptr in K;
            inversion K; clear K; subst
      end.
      simpl.
      destruct (Mem.free m1 _ _ _) eqn:Hfree1; try now solve_monotonic.
      edestruct (Mem.free_parallel_extends m1) as (? & Hfree2 & Hm2); eauto.
      rewrite Hfree2.
      destruct (strong_extends_le_intro p _ _ _ _ Hm1 Hm2) as [p' Hp'].
      + eapply Mem.free_unchanged_on; eauto.
        intros i H.
        unfold Events.loc_not_writable.
        intro ABSURD. apply ABSURD; clear ABSURD.
        apply Mem.perm_cur_max.
        eapply Mem.perm_implies ; [ eapply Mem.free_range_perm; eauto | ].
        constructor.
      + eapply Mem.free_unchanged_on; eauto.
        intros i H.
        unfold Events.loc_out_of_bounds.
        intro ABSURD. apply ABSURD; clear ABSURD.
        apply Mem.perm_cur_max.
        eapply Mem.perm_implies ; [ eapply Mem.free_range_perm; eauto | ].
        constructor.
      + eapply Mem.valid_block_free_1; eauto.
      + intros b0 o0 p0 H H0. eapply Mem.perm_free_3; eauto.
      + destruct Hp' . solve_monotonic.

    (** [Mem.load] *)
    - intro p.
      rewrite match_strong_extends_val.
      rewrite match_strong_extends_ptr.
      simpl.
      repeat red.
      intros a x y H x0 y0 H0.
      subst.
      destruct y0.
      simpl.
      destruct (Mem.load _ x _ _) eqn:Hload; try constructor.
      edestruct (Mem.load_extends a x) as (? & Hload2 & ?); eauto.
      rewrite Hload2.
      constructor; assumption.

    (** [Mem.store] *)
    - intro p.
      rewrite match_strong_extends_val.
      rewrite match_strong_extends_ptr.
      simpl.
      intros a x y H x0 y0 H0 x1 y1 H1.
      subst.
      destruct y0 as [b o].
      simpl.
      destruct (Mem.store a x b o x1) eqn:STORE1; try now solve_monotonic.
      edestruct (Mem.store_within_extends a x) as (? & Hstore2 & Hm2); eauto.
      rewrite Hstore2.
      destruct (strong_extends_le_intro p _ _ _ _ H Hm2) as [p' Hp'].
      + eapply Mem.store_unchanged_on; eauto.
        intros i H0.
        unfold Events.loc_not_writable.
        intro ABSURD. apply ABSURD; clear ABSURD.
        apply Mem.perm_cur_max.
        eapply Mem.store_valid_access_3; eauto.
      + eapply Mem.store_unchanged_on; eauto.
        intros i H0.
        unfold Events.loc_out_of_bounds.
        intro ABSURD. apply ABSURD; clear ABSURD.
        apply Mem.perm_cur_max.
        eapply Mem.perm_implies; [ eapply Mem.store_valid_access_3; eauto | ].
        constructor.
      + eapply Mem.store_valid_block_1; eauto.
      + intros b0 o0 p0 H0 H2; eapply Mem.perm_store_2; eauto.
      + destruct Hp' ; solve_monotonic.

    (** [Mem.loadbytes] *)
    - intro p.
      rewrite match_strong_extends_memval.
      rewrite match_strong_extends_ptr.
      intros x y H x0 y0 H0 a.
      subst.
      destruct y0.
      simpl.
      destruct (Mem.loadbytes x _ _ _) eqn:Hlb1; try constructor.
      edestruct (Mem.loadbytes_extends x) as (? & Hlb2 & ?); eauto.
      rewrite Hlb2.
      constructor.
      rewrite <- CompcertStructures.list_forall2_list_rel; assumption.

    (** [Mem.storebytes] *)
    - intro p.
      rewrite match_strong_extends_memval.
      rewrite match_strong_extends_ptr.
      intros x y H x0 y0 H0 x1 y1 H1.
      subst.
      destruct y0.
      simpl.
      destruct (Mem.storebytes x _ _ _) eqn:Hsb1; try now solve_monotonic.
      edestruct (Mem.storebytes_within_extends x) as (? & Hsb2 & Hm2); eauto.
      { rewrite CompcertStructures.list_forall2_list_rel; eassumption. }
      rewrite Hsb2.
      destruct (strong_extends_le_intro p _ _ _ _ H Hm2) as [p' Hp'].
      + eapply Mem.storebytes_unchanged_on; eauto.
        intros i H0. unfold Events.loc_not_writable.
        intro ABSURD. apply ABSURD. clear ABSURD.
        apply Mem.perm_cur_max.
        eapply Mem.storebytes_range_perm; eauto.
      + eapply Mem.storebytes_unchanged_on; eauto.
        assert (length y1 = length x1) as LEN by (symmetry; solve_monotonic).
        rewrite LEN.
        intros i H0. unfold Events.loc_out_of_bounds.
        intro ABSURD. apply ABSURD. clear ABSURD.
        apply Mem.perm_cur_max.
        clear Hsb2.
        eapply Mem.perm_implies; [ eapply Mem.storebytes_range_perm; eauto | ].
        constructor.
      + eapply Mem.storebytes_valid_block_1; eauto.
      + intros; eapply Mem.perm_storebytes_2; eauto.
      + destruct Hp' . solve_monotonic.

    (** [Mem.perm] *)
    - intros p.
      rewrite match_strong_extends_ptr.
      repeat red.
      intros x y H x0 y0 H0 a a0 H1.
      subst.
      destruct y0.
      simpl in *.
      eapply Mem.perm_extends; eauto.

    (** [Mem.valid_block] *)
    - intros p.
      rewrite match_strong_extends_block.
      simpl.
      intros m1 m2 Hm b1 b2 Hb; subst.
      eapply Mem.valid_block_extends; eauto.

    (** [Mem.different_pointers_inject] *)
    - inversion 5; subst.
      inversion 1; subst.
      tauto.

    (** [Mem.weak_valid_pointer_inject_val] *)
    - intros p m1 m2 b1 ofs1 b2 ofs2 H H0 H1.
      rewrite match_strong_extends_ptrbits in H1.
      inversion H1; clear H1; subst.
      eapply Mem.weak_valid_pointer_extends; eauto.

    (** [Mem.weak_valid_pointer_address_inject_weak] *)
    - intros p m1 m2 b1 b2 delta H H0.
      inversion H0; clear H0; subst.
      exists 0.
      intros ofs1 H0.
      rewrite Ptrofs.add_zero.
      omega.

    (** [Mem.address_inject *)
    - simpl.
      inversion 3; subst.
      rewrite Ptrofs.add_zero.
      omega.

    (** [Mem.aligned_area_inject] *)
    - simpl.
      inversion 7; subst.
      rewrite Z.add_0_r.
      assumption.

    (** [Mem.disjoint_or_equal_inject] *)
    - simpl.
      inversion 2; subst.
      inversion 1; subst.
      repeat rewrite Z.add_0_r.
      tauto.
  Qed.

  Definition simrel_strong_extends :=
    {|
      simrel_ops := simrel_strong_extends_ops
    |}.
End STRONG_LESSDEF_SIMREL.


Require Import compcert.lib.Coqlib.
Require Import compcert.common.AST.
Require Import compcert.common.Globalenvs.
Require Import compcert.cfrontend.Ctypes.
Require Import compcertx.x86.AsmX.
Require Import liblayers.lib.Decision.
Require Import liblayers.compcertx.ErrorMonad.
Require Export liblayers.logic.Layers.
Require Export liblayers.logic.PTreeLayers.
Require Import liblayers.logic.PTreeModules.
Require Import liblayers.logic.LayerLogicImpl.
Require Export liblayers.compcertx.MemWithData.
Require Export liblayers.compat.CompatData.
Require Export liblayers.compat.CompatPrimSem.
Require Export liblayers.compat.CompatLayerDef.

Section WITH_MEMORY_MODEL.
  Context `{Hmem: Mem.MemoryModel} `{Hmem': !UseMemWithData mem}.

  (** * Extra interface *)

  Section POINTWISE.

  Local Existing Instance ptree_layer_sim_op.
  Local Existing Instance ptree_layer_ops.
  Local Existing Instance ptree_layer_prf.

  (** FIXME: those are theorems about [ptree_layer] *)
  Lemma cl_layer_pointwise D1 D2 (R: path compatrel D1 D2) L1 L2:
    sim R (cl_base_layer L1) (cl_base_layer L2) <->
    (forall (i: ident),
       res_le (option_le (compatsim R))
         (get_layer_primitive i L1)
         (get_layer_primitive i L2)) /\
     (forall (i: ident),
        res_le (option_le eq)
         (get_layer_globalvar i L1)
         (get_layer_globalvar i L2)).
  Proof.
    simpl.
    generalize (cl_base_layer L1) (cl_base_layer L2); clear L1 L2.
    intros L1 L2.
    split.
    * intros H.
      simpl.
      split; intro; solve_monotonic.
    * intros [Hfun Hvar].
      destruct L1 as [L1p L1v], L2 as [L2p L2v].
      Local Transparent ptree_layer_ops.
      constructor; intro i;
      specialize (Hfun i);
      specialize (Hvar i);
      simpl in *;
      unfold ptree_layer_primitive, ptree_layer_globalvar in *; simpl in *.
      Local Opaque ptree_layer_ops.
      + destruct (Maps.PTree.get i L1p) as [[|]|];
        destruct (Maps.PTree.get i L2p) as [[|]|];
        simpl in *;
        inversion Hfun as [x1 x2 Hx | ]; try inversion Hx; subst;
        solve_monotonic.
      + destruct (Maps.PTree.get i L1v) as [[|]|];
        destruct (Maps.PTree.get i L2v) as [[|]|];
        simpl in *;
        inversion Hvar as [x1 x2 Hx | ]; try inversion Hx; subst;
        solve_monotonic.
  Qed.

  (** FIXME: those are theorems about [ptree_layer] *)
  Lemma cl_le_layer_pointwise D (L1 L2: compatlayer D):
    sim id (cl_base_layer L1) (cl_base_layer L2) <->
    (forall (i: ident),
       res_le (option_le (compatsem_le D))
         (get_layer_primitive i L1)
         (get_layer_primitive i L2)) /\
     (forall (i: ident),
        res_le (option_le eq)
         (get_layer_globalvar i L1)
         (get_layer_globalvar i L2)).
  Proof.
    apply cl_layer_pointwise.
  Qed.

  (** FIXME: those are theorems about [ptree_layer] *)
  Lemma cl_sim_layer_pointwise D1 D2 (R: compatrel D1 D2) L1 L2:
    sim (path_inj R) (cl_base_layer L1) (cl_base_layer L2) <->
    (forall (i: ident),
       res_le (option_le (compatsim (path_inj R)))
         (get_layer_primitive i L1)
         (get_layer_primitive i L2)) /\
     (forall (i: ident),
        res_le (option_le eq)
         (get_layer_globalvar i L1)
         (get_layer_globalvar i L2)).
  Proof.
    apply cl_layer_pointwise.
  Qed.

  End POINTWISE.

  (** * Properties of LayerOK *)

  Lemma get_layer_primitive_mapsto_le_ok
        {D}
        (L: compatlayer D)
        {HOK: LayerOK L}
        i (σ: compatsem D)
        (Hle: (i ↦ σ) ≤ L):
    exists σ',
      get_layer_primitive i L = OK (Some σ') /\
      compatsem_le _ σ σ'.
  Proof.
    generalize (get_layer_primitive_sim_monotonic _ _ _ i _ _ Hle).
    rewrite get_layer_primitive_mapsto.
    inversion 1; subst.
    * inversion H2; subst.
      eauto.
    * exfalso. destruct (HOK i) as [[σ' Hσ'] _ _].
      simpl in *.
      congruence.
  Qed.

  Lemma get_layer_globalvar_mapsto_le_ok
        {D}
        (L: compatlayer D)
        {HOK: LayerOK L}
        i (τ: globvar (Ctypes.type))
        (Hle: (i ↦ τ) ≤ L):
    get_layer_globalvar i L = OK (Some τ).
  Proof.
    generalize (get_layer_globalvar_sim_monotonic _ _ _ i _ _ Hle).
    rewrite get_layer_globalvar_mapsto.
    inversion 1; subst.
    * inversion H2; subst.
      symmetry; assumption.
    * exfalso. destruct (HOK i) as [_ [τ' Hτ'] _].
      simpl in *.
      congruence.
  Qed.

  (** * Matching initial states *)

  Require Import MakeProgram.

  Record cl_init_sim_mem D1 D2 (R: compatrel D1 D2) (m2: mem) :=
    {
      cl_init_sim_relate:
        relate_AbData (Mem.flat_inj (Mem.nextblock m2)) empty_data empty_data;
      cl_init_sim_match:
        match_AbData empty_data m2 (Mem.flat_inj (Mem.nextblock m2))
    }.

  Section WITH_PROGRAM.

    Context `{Hmkp: MakeProgram}.
    Context `{Fm: Type}.
    Context `{Fp: Type}.
    Context `{Vp: Type}.
    Context `{Hmodule: Modules AST.ident Fm (globvar Ctypes.type)}.
    Context `{mkp_fmt_ops: !ProgramFormatOps Fm Ctypes.type Fp Vp}.
    Context `{mkp_fmt: !ProgramFormat Fm Ctypes.type Fp Vp}.

    Require Import InitMem.

    Record cl_init_sim_def D1 D2 R (L1: compatlayer D1) (M: module) (L2: compatlayer D2) :=
      {
        cl_init_sim_init_mem:
          forall (CTXT: module) (m2: mem),
            (p <- make_program _ (CTXT ⊕ M, L2); ret (Genv.init_mem p) = OK (Some m2)) ->
            cl_init_sim_mem D1 D2 R m2;

        cl_init_sim_glbl:
          forall i,
            List.In i new_glbl ->
            isOKNone (get_layer_globalvar i L1);

        cl_init_sim_glbl_prim:
          forall i,
            List.In i new_glbl ->
            isOKNone (get_layer_primitive i L1);

        cl_init_sim_glbl_module:
          forall i,
            List.In i new_glbl ->
            exists vi, get_module_variable i M = OK (Some vi);

        cl_init_sim_M:
          forall {F V} (ge: Genv.t F V) i vi,
          get_module_variable i M = OK (Some vi) ->
          Genv.init_data_list_valid ge 0 (gvar_init vi) = true;

        cl_init_sim_low:
          forall i,
            isOKNone (get_layer_globalvar i L2)

      }.

    Inductive cl_init_sim D1: forall D2, path compatrel D1 D2 ->
      compatlayer D1 -> module -> compatlayer D2 -> Prop :=
      | cl_init_sim_inj D2 R L1 M L2:
          cl_init_sim_def D1 D2 R L1 M L2 ->
          cl_init_sim D1 D2 (path_inj R) L1 M L2
      | cl_init_sim_cons D2 D3 R Rs L1 M L2 N L3:
          cl_init_sim_def D1 D2 R L1 M L2 ->
          cl_init_sim D2 D3 Rs L2 N L3 ->
          cl_init_sim D1 D3 (path_cons R Rs) L1 (M ⊕ N) L3.

    Lemma cl_init_sim_intro D1 D2 R (L1: compatlayer D1) (M: module) (L2: compatlayer D2):
      (forall (CTXT: module) (m2: mem),
         (p <- make_program _ (CTXT ⊕ M, L2); ret (Genv.init_mem p)) = OK (Some m2) ->
         cl_init_sim_mem D1 D2 R m2) ->
      (forall i,
         List.In i new_glbl ->
         isOKNone (get_layer_globalvar i L1)) ->
      (forall i,
         List.In i new_glbl ->
         isOKNone (get_layer_primitive i L1)) ->
      (forall i,
         List.In i new_glbl ->
         exists vi, get_module_variable i M = OK (Some vi)) ->
      (forall {F V} (ge: Genv.t F V)  i vi,
         get_module_variable i M = OK (Some vi) ->
         Genv.init_data_list_valid ge 0 (gvar_init vi) = true) ->
      (forall i,
         isOKNone (get_layer_globalvar i L2)) ->
      cl_init_sim D1 D2 (path_inj R) L1 M L2.
    Proof.
      intros Hinitmem HL1v HL1p HMglbl HMinitdata HMnonglbl.
      constructor.
      split.
      * intros.
        eauto.
      * intros i Hi.
        eauto.
      * intros. eauto.
      * intros. eauto.
      * intros. eauto.
      * intros. eauto.
    Qed.

  End  WITH_PROGRAM.
End WITH_MEMORY_MODEL.


(* Distributed under the terms of the MIT license. *)
From Coq Require Import ssreflect.
From MetaCoq.Utils Require Import utils.
From MetaCoq.Common Require Import config.
From MetaCoq.PCUIC Require Import PCUICTyping PCUICEquality PCUICAst PCUICAstUtils
  PCUICWeakeningConv PCUICWeakeningTyp PCUICSubstitution PCUICGeneration PCUICArities
  PCUICWcbvEval PCUICSR PCUICInversion
  PCUICUnivSubstitutionConv PCUICUnivSubstitutionTyp
  PCUICElimination PCUICSigmaCalculus PCUICContextConversion
  PCUICUnivSubst PCUICWeakeningEnvConv PCUICWeakeningEnvTyp
  PCUICCumulativity PCUICConfluence
  PCUICInduction PCUICLiftSubst PCUICContexts PCUICSpine
  PCUICConversion PCUICValidity PCUICInductives PCUICConversion
  PCUICInductiveInversion PCUICNormal PCUICSafeLemmata
  PCUICParallelReductionConfluence
  PCUICWcbvEval PCUICClosed PCUICClosedTyp
  PCUICReduction PCUICCSubst PCUICOnFreeVars PCUICWellScopedCumulativity
  PCUICWcbvEval PCUICCanonicity PCUICSN PCUICNormalization.

From Equations Require Import Equations.

Definition Prop_univ := Universe.of_levels (inl PropLevel.lProp).

Definition False_oib : one_inductive_body :=
  {| ind_name := "False";
     ind_indices := [];
     ind_sort := Prop_univ;
     ind_type := tSort Prop_univ;
     ind_kelim := IntoAny;
     ind_ctors := [];
     ind_projs := [];
     ind_relevance := Relevant |}.

Definition False_mib : mutual_inductive_body :=
  {| ind_finite := BiFinite;
     ind_npars := 0;
     ind_params := [];
     ind_bodies := [False_oib];
     ind_universes := Monomorphic_ctx;
     ind_variance := None |}.

Theorem pcuic_consistent  {cf:checker_flags} {nor : normalizing_flags} Σ
  {normalization_in: NormalizationIn Σ} t False_pcuic :
  declared_inductive Σ False_pcuic False_mib False_oib ->
  wf_ext Σ -> axiom_free Σ ->
  Σ ;;; [] |- t : tInd False_pcuic []  -> False.
Proof.
  intros Hdecl wfΣ axΣ typ_false. pose proof (_ ; typ_false) as wt.
  destruct Hdecl as [Hdecl Hidecl].
  destruct False_pcuic as [kn n]. destruct n; cbn in *; [| now rewrite nth_error_nil in Hidecl].
  eapply wh_normalization in wt ; eauto. destruct wt as [empty [Hnormal Hempty]].
  pose proof (Hempty_ := Hempty).
  eapply subject_reduction in typ_false; eauto.
  eapply ind_whnf_canonicity with (indargs := []) in typ_false as ctor; auto.
  - unfold isConstruct_app in ctor.
    destruct decompose_app eqn:decomp.
    apply decompose_app_inv in decomp.
    rewrite decomp in typ_false.
    destruct t0; try discriminate ctor.
    apply PCUICValidity.inversion_mkApps in typ_false as H; auto.
    destruct H as (?&typ_ctor&_).
    apply inversion_Construct in typ_ctor as (?&?&?&?&?&?&?); auto.
    eapply Construct_Ind_ind_eq with (args' := []) in typ_false; tea.
    2: eauto.
    destruct (on_declared_constructor d).
    destruct p.
    destruct s.
    destruct p.
    destruct typ_false as (((((->&_)&_)&_)&_)&_).
    clear -Hdecl d wfΣ. destruct wfΣ.
    cbn in *.
    destruct d as ((?&?)&?).
    unshelve eapply declared_minductive_to_gen in Hdecl; eauto.
    unshelve eapply declared_minductive_to_gen in H; eauto.
    red in H, Hdecl. cbn in *. rewrite Hdecl in H; noconf H.
    cbn in H0. noconf H0.
    cbn in H1. rewrite nth_error_nil in H1.
    discriminate.
  - unfold notCoInductive, check_recursivity_kind. destruct wfΣ.
    unshelve eapply declared_minductive_to_gen in Hdecl; eauto.
    red in Hdecl. cbn. rewrite Hdecl; cbn. auto.
Qed.


Require Import MetaCoq.Template.All.

From MetaCoq.PCUIC Require Import
     PCUICAst PCUICAstUtils PCUICInduction
     PCUICLiftSubst PCUICEquality
     PCUICUnivSubst PCUICTyping PCUICGeneration.

From MetaCoq.PCUIC Require Import PCUICToTemplate.
From MetaCoq.PCUIC Require Import TemplateToPCUIC.

Require Import List String.
Import ListNotations MonadNotation Nat.
Require Import MetaCoq.Template.Pretty.
Require Import MetaCoq.PCUIC.PCUICPretty.

Require Import Modes.

Open Scope string_scope.

Definition nestedMode := "Nested_Inductives".

Class registered {X} (ty:X) :=
{
  assumptionType: Type;
  assumption: assumptionType;
  proofType: Type;
  proof: proofType
}.

Fixpoint isAugmentable (isMain:bool) (t:term) : bool :=
  match t with
  | tSort _ => negb isMain
  | tProd _ t1 t2 =>
      orb
      (isAugmentable false t1)
      (isAugmentable isMain t2)
  | _ => false
  end.

Open Scope string_scope.

Definition errorMessage (name:string) : TemplateMonad unit :=
  (* tmPrint tE;; *)
  tmMsg (name ++ " is not a registered container and won't generate nested inductive hypothesis.");;
  tmMsg ("Use `MetaCoq Run Derive Container for " ++ name ++ "` to register " ++ name ++ " as container.").
  (* tmMsg "was not found in the registered database and thus will be ignored.";; *)

Definition createFunction (inds:list (kername * option nat * Instance.t)) : TemplateMonad( kername -> nat -> option (term×term) ) :=
  monad_fold_left
  (fun acc '(kname,no,u) =>
    let object :=
      match no with
        None => Ast.tConst kname u
      | Some n => Ast.tInd (mkInd kname n) u
      end
    in
    tt <- tmUnquote object;;
    let t := tt.(my_projT2) in
    inst <- tmInferInstance None (registered t);;
    tE <- tmEval lazy t;;
    match inst with
    | my_None =>
        match no with
          None => (* TODO check augmentable constant *)
            errorMessage kname;;
            tmReturn acc
        | Some n =>
          mind <- tmQuoteInductive kname;;
          match nth_error (Ast.ind_bodies mind) n with
          | Some oind =>
              match isAugmentable true (trans (Ast.ind_type oind)) with
              | true =>
                  errorMessage (Ast.ind_name oind);;
                  tmReturn acc
              | false =>
                  (* tmMsg "not found and not augmentable";; *)
                  tmReturn acc
              end
          | None => tmReturn acc
          end
        end
    | my_Some a =>
        (* tmMsg "was found in the registered database.";; *)
        assumI <- tmQuote (@assumption _ _ a);;
        proofI <- tmQuote (@proof _ _ a);;
        assumE <- tmEval lazy assumI;;
        proofE <- tmEval lazy proofI;;
        tmReturn
          (fun name i =>
            if name =? kname then (* TODO use i and no for mutual *)
              Some (
                TemplateToPCUIC.trans assumE,
                TemplateToPCUIC.trans proofE
              )
            else
              acc name i
          )
    end
  )
  inds
  (fun _ _ => None).

Fixpoint findRec (k:nat) (u:term) :=
  match u with
  | tRel n => Nat.eqb n k
  | tProd na A B => orb (findRec k A) (findRec (S k) B)
  | tLambda na T M => orb (findRec k T) (findRec (S k) M)
  | tLetIn na b ty b' => orb (orb (findRec k b) (findRec k ty)) (findRec (S k) b')
  | tApp t1 t2 =>
    orb (findRec k t1) (findRec k t2)
  | _ => false
  end.

Fixpoint findRecInd (rec:nat) (forceAdd:bool) (t:term) : list (kername * option nat * Instance.t) :=
  match t with
  | tProd _ t1 t2 => findRecInd rec false t1 ++
      findRecInd (S rec) forceAdd t2
  | tLambda _ t1 t2 => findRecInd rec false t1 ++
      findRecInd (S rec) forceAdd t2
  | tLetIn _ t1 t2 t3 => findRecInd rec false t1 ++
      findRecInd rec false t2 ++
      findRecInd (S rec) forceAdd t3
  | tApp t1 t2 =>
      findRecInd rec (orb forceAdd (findRec rec t2)) t1 ++
      findRecInd rec forceAdd t2
  | tInd (mkInd kname n) u =>
      if forceAdd then
        [(kname, Some n, u)]
      else
        []
  | tConst kname u =>
      if forceAdd then
        [(kname, None, u)]
      else
        []
  | _ => []
  end.

Definition getInd (oind:one_inductive_body) : list (kername * option nat * Instance.t) :=
  List.concat (map (fun '(n,t,i) => findRecInd 0 false t) oind.(ind_ctors)).

Definition getInds (oind:one_inductive_body) : TemplateMonad (list (kername * option nat * Instance.t)) :=
        monad_fold_left
        (fun acc '(n,t,i) =>
          et <- tmEval all t;;
          let inds := findRecInd 0 false et in
          tmReturn (app acc inds)
        )
        oind.(ind_ctors)
        [].

Definition extractFunction (mind:mutual_inductive_body) (n:nat) : TemplateMonad( kername -> nat -> option (term×term) )  :=
  isNested <- getMode nestedMode;;
  if isNested:bool then
    match nth_error mind.(ind_bodies) n with
      None => tmFail "mutual inductive body was not found"
    | Some oind =>
        inds <- getInds oind;;
        createFunction inds
    end
  else
    tmMsg "Nested recursion will be ignored.";;
    tmReturn (
      fun _ _ => None
    ).


(* -------------------------------------------------------------------------- *
 *                     Vellvm - the Verified LLVM project                     *
 *                                                                            *
 *     Copyright (c) 2017 Steve Zdancewic <stevez@cis.upenn.edu>              *
 *                                                                            *
 *   This file is distributed under the terms of the GNU General Public       *
 *   License as published by the Free Software Foundation, either version     *
 *   3 of the License, or (at your option) any later version.                 *
 ---------------------------------------------------------------------------- *)

Require Import ZArith List String Omega.
Require Import Program.
Require Import Vellvm.Util.
Require Import Vellvm.LLVMAst Vellvm.AstLib Vellvm.CFG Vellvm.CFGProp.
Import ListNotations.
Open Scope Z_scope.
Open Scope string_scope.

Set Implicit Arguments.
Set Contextual Implicit.

Require Import Vellvm.Handlers.Memory.

Definition optimization {T} := definition T (list (block T)) -> definition T (list (block T)).

Definition optimize {T} (m:modul T (list (block T))) (o:optimization) : modul T (list (block T)) :=
 {|
  m_name := (m_name _ _ m);
  m_target := (m_target _ _ m);
  m_datalayout := (m_datalayout _ _ m);
  m_type_defs := (m_type_defs _ _ m);
  m_globals := (m_globals _ _ m);
  m_declarations := (m_declarations _ _ m);
  m_definitions := map o (m_definitions _ _ m);
  |}.

(*

Definition correct (P : modul (list block) -> Prop) (o:optimization) :=
  forall (m:modul (list block)) m_semantic m_opt_semantic,
    P m ->
    mcfg_of_modul m = Some m_semantic ->
    mcfg_of_modul (optimize m o) = Some m_opt_semantic ->
    forall (s:state),
      E.obs_error_free (sem m_semantic s) ->
      E.obs_equiv (sem m_semantic s) (sem m_opt_semantic s).

Class RemoveInstr X := remove_instr : instr_id -> X -> X.

Definition remove_instr_block (id:instr_id) (b:block) : block :=
  {| blk_id := blk_id b;
     blk_instrs := List.filter (fun x => negb (if (fst x == id) then false else true)) (blk_instrs b);
     blk_term := blk_term b;
     blk_term_id := blk_term_id b;
  |}.
Instance rem_instr_block : RemoveInstr block := remove_instr_block.

Definition remove_instr_defn (id:instr_id) (d:definition (list block)) : definition (list block) :=
  {|
    df_prototype   := (df_prototype d);
    df_args        := (df_args d);
    df_instrs      := List.map (remove_instr id) (df_instrs d);
  |}.

Instance rem_instr_defn : RemoveInstr (definition (list block)) := remove_instr_defn.

Definition dead (g:cfg) (inst:instr_id) : Prop :=
  match inst with
  | IVoid _ => False
  | IId id => forall pt, ~ (cmd_uses_local g pt id)
  end.

Inductive remove_instr_applies (inst:instr_id) (d:definition (list block)) : Prop :=
| remove_instr_applies_intro:
    forall glbls g, cfg_of_definition glbls d = Some g ->
               dead g inst ->
               remove_instr_applies inst d.

Definition remove_instr_applies_module (instr:instr_id) (m:modul (list block)) : Prop :=
  Forall (remove_instr_applies instr) (m_definitions m).

Require Import paco.

(*
Lemma obs_error_free_inv :
  forall (m:mcfg) (s:state),
    E.obs_error_free (sem m s) ->
    (exists dv, sem m s = E.Fin dv) \/
    (exists s', stepD m s = E.Ret s' /\ E.obs_error_free (sem m s')).
Proof.
  intros m s H.
  punfold H. remember (upaco1 obs_error_free_step bot1). remember (sem m s) as d. induction H.
  - left. exists v. reflexivity.
  - rewrite sem_match_id in Heqd. unfold sem in Heqd.
    unfold bind in Heqd.
    destruct (stepD m s).
    + right. exists s0. split; eauto. subst. inversion Heqd. pclearbot. punfold H. subst. pfold. apply H.
    + inversion Heqd.
    + inversion Heqd.
    +
Abort.
*)

Lemma remove_instr_correct:
  forall (instr:instr_id), correct (remove_instr_applies_module instr) (remove_instr_defn instr).
Proof.
  intros instr.
  unfold correct.
  intros m m_semantic m_opt_semantic Happlies H0 H1 s Herr. revert s Herr.
  pcofix CIH.
  intros s Herr.

Abort.

*)