From iris Require Import program_logic.weakestpre.
From iris.program_logic Require Import ectx_language ectxi_language.
From st.STLCmuST Require Import lang types typing.
From st.backtranslations.st_sem.correctness.sem_le_st.logrel Require Import lift definition.

Lemma rtc_bind_help n e w u σ σ' u' σ'' :
  nsteps STLCmuST_step n (σ, RunST e) (σ'', of_val u') →
  rtc STLCmuST_step (σ'', RunST (App (of_val w) (of_val u'))) (σ', of_val u) →
  rtc STLCmuST_step (σ, RunST (Bind e (of_val w))) (σ', of_val u).
Proof.
   revert w e u u' σ σ' σ''.
    induction n => w e u u' σ σ' σ'' Hrd1 Hrd2 /=.
  - inversion Hrd1 as [Hs1 Hs2 Hs3 Hs4|]; subst.
    assert (Hkv : to_val (RunST e) = Some u') by
        by rewrite H to_of_val.
    exfalso; by inversion Hkv.
  - inversion Hrd1 as [|Hs1 Hs2 [σ2 e2] Hs4 Hs5 Hs6]; subst; simpl in *.
    inversion Hs5 as [? ? ? Hfl ? Hhd]; subst.
    destruct K as [|[] K] using rev_ind; simpl in *;
      (try rewrite fill_app /= in Hfl); inversion Hfl; subst.
    + inversion Hhd; subst.
      * specialize (IHn _ _ _ _ _ _ _ Hs6 Hrd2).
        apply rtc_l with (y := (σ2, RunST (Bind e' w))); eauto.
        apply head_prim_step.
        econstructor.
        inversion H1 as [K ? ? ?]; subst.
        eapply (@Ectx_step eff_ectx_lang _ _ _ _ _ _ (K ++ [BindECtx _])); eauto;
          by rewrite /= (@fill_app eff_ectxi_lang) /=.
      * inversion Hs6; subst; simpl in *.
        -- eapply rtc_l; simpl; eauto.
           apply head_prim_step.
           econstructor.
           apply head_prim_step.
           econstructor; eauto using to_of_val.
        -- destruct y. erewrite (language.val_stuck) in H1; eauto. inversion H1.
    + rewrite fill_app in Hs6 Hrd2. specialize (IHn _ _ _ _ _ _ _ Hs6 Hrd2).
      apply rtc_l with (y := (σ2, (RunST (Bind (fill K e2') (of_val w))))); auto.
      apply (fill_prim_step [BindLCtx _; RunSTCtx]).
      apply (fill_prim_step K). by apply head_prim_step.
Qed.

Lemma rtc_bind_lemma (σ0 σ1 σ2 σ3 : state) (v f w s r : val) :
  rtc STLCmuST_step (σ0, RunST v) (σ1, of_val w) →
  rtc STLCmuST_step (σ1, ((of_val f) (of_val w))) (σ2, of_val s) →
  rtc STLCmuST_step (σ2, RunST s) (σ3, of_val r) →
  rtc STLCmuST_step (σ0, RunST (Bind v f)) (σ3, of_val r).
Proof.
  intros H0 H1 H2. destruct (rtc_nsteps_1 _ _ H0) as [n H0'].
  apply (rtc_bind_help _ _ _ _ _ _ _ _ H0').
  apply rtc_transitive with (y := (σ2, RunST s)). by apply (fill_STLCmuST_step_rtc [RunSTCtx]).
  auto.
Qed.

From iris.proofmode Require Import tactics.
From iris.base_logic.lib Require Import invariants gen_heap.
From st.backtranslations.st_sem Require Import ghost heap_emul.base.
From st.STLCmuVS Require Import lang.
From st Require Import resources.

Local Notation "l ↦ v" := (mapsto l (DfracOwn 1) v)
  (at level 20, format "l  ↦  v") : bi_scope.

Section valrel_cons_ren.

  Context `{Σ : !gFunctors} `{sem_le_stΣ_inst : !sem_le_stΣ Σ}.

  (* super boring lemma *)
  Lemma valrel_typed_cons_ren γ γ' Δ : ∀ τ v v', valrel_typed ((γ,γ') :: Δ) τ.[ren (+1)] v v' ⊣⊢ valrel_typed Δ τ v v'.
  Proof.
    iLöb as "IHlob".
    iIntros (τ). iInduction τ as [ | | | τ1 τ2 | τ1 τ2 | τ1 τ2 | τb | | τ1 τ2 | τ1 τ2 ] "IH".
    - setoid_rewrite valrel_typed_TUnit_unfold; auto.
    - setoid_rewrite valrel_typed_TBool_unfold; auto.
    - setoid_rewrite valrel_typed_TInt_unfold; auto.
    - setoid_rewrite valrel_typed_TProd_unfold.
      iIntros (v v').
      iSplit.
      + iIntros "Hdes". iDestruct "Hdes" as (v1 v2 v1' v2') "(eq1 & eq2 & H1 & H2)".
        repeat iExists _. repeat iSplit; auto. by iApply "IH". by iApply "IH1".
      + iIntros "Hdes". iDestruct "Hdes" as (v1 v2 v1' v2') "(eq1 & eq2 & H1 & H2)".
        repeat iExists _. repeat iSplit; auto. by iApply "IH". by iApply "IH1".
    - setoid_rewrite valrel_typed_TSum_unfold.
      iIntros (v v').
      iSplit.
      + iIntros "Hdes". iDestruct "Hdes" as (v1 v1') "[(eq1 & eq2 & H) | (eq1 & eq2 & H)]".
        * repeat iExists _. iLeft. repeat iSplit; eauto. by iApply "IH".
        * repeat iExists _. iRight. repeat iSplit; eauto. by iApply "IH1".
      + iIntros "Hdes". iDestruct "Hdes" as (v1 v1') "[(eq1 & eq2 & H) | (eq1 & eq2 & H)]".
        * repeat iExists _. iLeft. repeat iSplit; eauto. by iApply "IH".
        * repeat iExists _. iRight. repeat iSplit; eauto. by iApply "IH1".
    - setoid_rewrite valrel_typed_TArrow_unfold.
      iIntros (w w'). iSplit.
      + iIntros "#H". iModIntro. iIntros (v v') "#H1".
        iApply (lift_wand _ (valrel_typed ((γ,γ') :: Δ) τ3.[ren (+1)])). iIntros (x x') "Hxx'". by iApply "IH1".
        iApply "H". by iApply "IH".
      + iIntros "#H". iModIntro. iIntros (v v') "#H1".
        iApply (lift_wand _ (valrel_typed (Δ) τ3)). iIntros (x x') "Hxx'". by iApply "IH1".
        iApply "H". by iApply "IH".
    - setoid_rewrite valrel_typed_TRec_unfold.
      iIntros (v v'). iSplit.
      + iIntros "Hdes". iDestruct "Hdes" as (w w') "(eq & eq' & H)".
        iExists w, w'. repeat iSplit; auto. iNext. iApply "IHlob". by asimpl.
      + iIntros "Hdes". iDestruct "Hdes" as (w w') "(eq & eq' & H)".
        iExists w, w'. repeat iSplit; auto. iNext.
        assert (τb.[up (ren (+1))].[TRec τb.[up (ren (+1))]/] =
                τb.[TRec τb/].[ren (+1)]
               ) as eq; first by asimpl. rewrite eq. by iApply "IHlob".
    - setoid_rewrite valrel_typed_TVar_unfold. auto.
    - setoid_rewrite valrel_typed_TSTRef_unfold; auto.
      destruct τ1; auto; destruct (Δ !! X) as [[γ'' γ''']|] eqn:eq; rewrite /= eq; try done.
      iIntros (v v'). iSplit.
      + iIntros "Hdes". iDestruct "Hdes" as (i l) "(-> & -> & Hil & H)". iExists i, l. repeat iSplit; auto.
        iApply (inv_iff with "H"). repeat iModIntro. iSplit.
        * iIntros "Hdes". iDestruct "Hdes" as (w w') "[Hi [Hl Hww']]". iExists w, w'. iFrame "Hi Hl". by iApply "IH1".
        * iIntros "Hdes". iDestruct "Hdes" as (w w') "[Hi [Hl Hww']]". iExists w, w'. iFrame "Hi Hl". by iApply "IH1".
      + iIntros "Hdes". iDestruct "Hdes" as (i l) "(-> & -> & Hil & H)". iExists i, l. repeat iSplit; auto.
        iApply (inv_iff with "H"). repeat iModIntro. iSplit.
        * iIntros "Hdes". iDestruct "Hdes" as (w w') "[Hi [Hl Hww']]". iExists w, w'. iFrame "Hi Hl". by iApply "IH1".
        * iIntros "Hdes". iDestruct "Hdes" as (w w') "[Hi [Hl Hww']]". iExists w, w'. iFrame "Hi Hl". by iApply "IH1".
    - setoid_rewrite valrel_typed_TST_unfold; auto.
      destruct τ1; auto; destruct (Δ !! X) as [[γ'' γ''']|] eqn:eq; rewrite /= eq; try done.
      iIntros (w w'). iSplit.
      + iIntros "#H". iIntros (ps σ). iModIntro. iIntros "Hσ AuthVals AuthLocs". iSpecialize ("H" $! ps σ with "Hσ AuthVals AuthLocs"). iApply (wp_wand with "H").
        iIntros (v) "Hdes". iDestruct "Hdes" as (w1 w1' ps1 σ1) "(-> & Hσ1 & Hauth1 & Hauth2 & Hstep & H)". iExists w1, w1', ps1, σ1. iFrame. iSplit; auto.
        by iApply "IH1".
      + iIntros "#H". iIntros (ps σ). iModIntro. iIntros "Hσ AuthVals AuthLocs". iSpecialize ("H" $! ps σ with "Hσ AuthVals AuthLocs"). iApply (wp_wand with "H").
        iIntros (v) "Hdes". iDestruct "Hdes" as (w1 w1' ps1 σ1) "(-> & Hσ1 & Hauth1 & Hauth2 & Hstep & H)". iExists w1, w1', ps1, σ1. iFrame. iSplit; auto.
        by iApply "IH1".
  Qed.

End valrel_cons_ren.


Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq tuple.
Require Import bitsrep bitsops bitsopsprops monad writer reg instr instrsyntax program programassem cursor.
Require Import pecoff cfunc.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Open Scope instr_scope.
Open Scope string_scope.

Require Import call.
Example counterDLL :=
  GLOBAL Get as "Get";
  GLOBAL Inc as "Inc";
  GLOBAL Counter;
  SECTION CODE
    Inc:;;  mkbody_toyfun (MOV ECX, Counter;; INC [ECX]);;
    Get:;;  mkbody_toyfun (MOV ECX, Counter;; MOV EAX, [ECX]);
  SECTION DATA
    Counter:;; dd #0.

Compute makeDLL #x"00AC0000" "counter.dll" counterDLL.

(*
Require Import SPred septac spectac spec safe pointsto cursor instr.
Require Import basic basicprog program instrsyntax macros instrrules.
Require Import Setoid RelationClasses Morphisms.

Example counterModuleSpec IAT P Inc Get :=
      (Forall c: DWORD, toyfun Inc (P c ** ECX? ** OSZCP?) (P (c +# 1) ** ECX? ** OSZCP?))
    //\\
      (Forall c: DWORD, toyfun Get (EAX? ** P c ** ECX? ** OSZCP?) (EAX ~= c ** P c ** ECX? ** OSZCP?))
    <@ (IAT :-> (Inc, Get)).

Example counterModuleCode (Inc Get Counter: DWORD) :=
(*  LOCAL Inc; LOCAL Get; LOCAL Counter;*)
    Inc:;;  mkbody_toyfun (MOV ECX, Counter;; INC [ECX]);;
    Get:;;  mkbody_toyfun (MOV ECX, Counter;; MOV EAX, [ECX]).

Example counterModuleData :=
    dd #0.

Example counterModuleIAT Inc Get :=
    dd Inc;; dd Get.

Require Import flags.
Theorem counterModuleCorrect (codeStart codeEnd dataStart:DWORD):
  |-- Forall Inc, Forall Get,
      counterModuleSpec codeStart (fun v => dataStart :-> v) Inc Get <@ (codeStart -- codeEnd :-> counterModuleCode Inc Get dataStart).
Proof.
rewrite /counterModuleSpec.
rewrite /counterModuleCode.
specintros => Inc Get. unfold_program.

specintros => i1 -> -> i2 i3 -> ->.
rewrite !empSPL.
specsplit.
(* Inc *)
specintros => c.
rewrite <- spec_reads_merge.
rewrite <- spec_reads_frame.
  etransitivity; [|apply toyfun_mkbody]. specintro => iret.
  rewrite /flagAny. specintros => O S Z C P. autorewrite with push_at.
  basicapply MOV_RI_rule.
  basicapply INC_M_rule. rewrite addB0.
  rewrite /OSZCP. sbazooka. rewrite addB1 addB0. rewrite /regAny.
  sbazooka.
  rewrite /OSZCP. ssimpl. reflexivity.

(* Get *)
specintros => c.
rewrite spec_reads_swap.
rewrite <- spec_reads_frame.
rewrite <- spec_reads_merge.
rewrite <- spec_reads_swap.
rewrite <- spec_reads_frame.
  etransitivity; [|apply toyfun_mkbody]. specintro => iret.
  rewrite /flagAny. specintros => O S Z C P. autorewrite with push_at.
  basicapply MOV_RI_rule.
  basicapply MOV_RM0_rule. rewrite /regAny. sbazooka.
Qed.

Example useCounterModule IAT : program :=
  MOV EDI, IAT;; call_toyfun [EDI];;
  MOV EDI, IAT;; call_toyfun [EDI];;
  MOV EDI, IAT;; call_toyfun [EDI+4].

Example useCounterModuleCorrect (codeStart codeEnd dataStart Inc Get IAT: DWORD):
  counterModuleSpec codeStart (fun v => dataStart :-> v) Inc Get
  |-- basic (EAX?) (useCounterModule IAT) (EAX ~= #2) @
      (EDI? ** OSZCP? ** retreg?) <@ (IAT :-> (Inc,Get)).
Proof.
  rewrite /useCounterModule. autorewrite with push_at.
  rewrite <- spec_reads_frame.
  eapply basic_seq.
  basicapply MOV_RI_rule.
  rewrite /counterModuleSpec.
  apply landL1.
  - (*apply lforallL with c.*)
    eapply basic_basic_context.
    - have H := toyfun_call. setoid_rewrite spec_at_basic in H. apply H.
    - by apply spec_later_weaken.
    - by ssimpl.
    done.
  apply lforallL with (a +# 2).
  eapply basic_basic_context.
  - have H := toyfun_call. setoid_rewrite spec_at_basic in H. apply H.
  - by apply spec_later_weaken.
  - by ssimpl.
  rewrite -addB_addn. rewrite -[2+2]/4. by ssimpl.
Qed.

Example useCounterSpec IAT :

*)


(** * Push-Button Synthesis of fancy mongomery reduction : Reification Cache *)
Require Import Coq.ZArith.ZArith.
Require Import Coq.derive.Derive.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Arithmetic.FancyMontgomeryReduction.
Require Import Crypto.PushButtonSynthesis.ReificationCache.
Local Open Scope Z_scope.

Import Associational Positional.
Import FancyMontgomeryReduction.MontgomeryReduction.

Local Set Keyed Unification. (* needed for making [autorewrite] fast, c.f. COQBUG(https://github.com/coq/coq/issues/9283) *)

Module Export MontgomeryReduction.
  Derive reified_montred_gen
         SuchThat (is_reification_of reified_montred_gen montred')
         As reified_montred_gen_correct.
  Proof. Time cache_reify (). Time Qed.
  Module Export ReifyHints.
#[global]
    Hint Extern 1 (_ = _) => apply_cached_reification montred' (proj1 reified_montred_gen_correct) : reify_cache_gen.
#[global]
    Hint Immediate (proj2 reified_montred_gen_correct) : wf_gen_cache.
#[global]
    Hint Rewrite (proj1 reified_montred_gen_correct) : interp_gen_cache.
  End ReifyHints.
  Local Opaque reified_montred_gen. (* needed for making [autorewrite] not take a very long time *)
End MontgomeryReduction.


From iris_examples.logrel.F_mu_ref Require Export context_refinement.
From iris.algebra Require Import excl auth frac agree.
From iris.proofmode Require Import tactics.
From iris.program_logic Require Import adequacy.
From iris_examples.logrel.F_mu_ref Require Import soundness.

Lemma basic_soundness Σ `{heapPreG Σ, inG Σ (authR cfgUR)}
    e e' τ v thp hp :
  (∀ `{heapG Σ, cfgSG Σ}, [] ⊨ e ≤log≤ e' : τ) →
  rtc erased_step ([e], ∅) (of_val v :: thp, hp) →
  (∃ thp' hp' v', rtc erased_step ([e'], ∅) (of_val v' :: thp', hp')).
Proof.
  intros Hlog Hsteps.
  cut (adequate NotStuck e ∅ (λ _ _, ∃ thp' h v, rtc erased_step ([e'], ∅) (of_val v :: thp', h))).
  { destruct 1; naive_solver. }
  eapply (wp_adequacy Σ); first by apply _.
  iIntros (Hinv ?).
  iMod (gen_heap_init (∅: state)) as (Hheap) "Hh".
  iMod (own_alloc (● (Excl' e', ∅)
    ⋅ ◯ ((Excl' e', ∅) : cfgUR))) as (γc) "[Hcfg1 Hcfg2]".
  { apply auth_both_valid. split=>//. }
  set (Hcfg := CFGSG _ _ γc).
  iMod (inv_alloc specN _ (spec_ctx ([e'], ∅)) with "[Hcfg1]") as "#Hcfg".
  { iNext. iExists e', ∅. iSplit; eauto.
    rewrite /to_gen_heap fin_maps.map_fmap_empty.
    iFrame. }
  set (HeapΣ := HeapG Σ Hinv Hheap).
  iExists (λ σ _, gen_heap_ctx σ), (λ _, True%I); iFrame.
  iApply wp_fupd. iApply (wp_wand with "[-]").
  - iPoseProof (Hlog _ _ with "[$Hcfg]") as "Hrel".
    { iApply (@logrel_binary.interp_env_nil Σ HeapΣ). }
    replace e with e.[env_subst[]] at 2 by by asimpl.
    iApply ("Hrel" $! []).
    rewrite /tpool_mapsto. asimpl. iFrame.
  - iModIntro. iIntros (v'). iDestruct 1 as (v2) "[Hj #Hinterp]".
    iInv specN as ">Hinv" "Hclose".
    iDestruct "Hinv" as (e'' σ) "[Hown %]".
    rewrite /tpool_mapsto /=.
    iDestruct (own_valid_2 with "Hown Hj") as %Hvalid.
    move: Hvalid=> /auth_both_valid
      [/prod_included [Hv2 _] _]. apply Excl_included, leibniz_equiv in Hv2. subst.
    iMod ("Hclose" with "[-]") as "_".
    + iExists (#v2), σ. auto.
    + iIntros "!> !%". eauto.
Qed.

Lemma binary_soundness Σ `{heapPreG Σ, inG Σ (authR cfgUR)}
    Γ e e' τ :
  (∀ f, e.[upn (length Γ) f] = e) →
  (∀ f, e'.[upn (length Γ) f] = e') →
  (∀ `{heapG Σ, cfgSG Σ}, Γ ⊨ e ≤log≤ e' : τ) →
  Γ ⊨ e ≤ctx≤ e' : τ.
Proof.
  intros He He' Hlog K thp σ v ?. eapply (basic_soundness Σ)=> ??.
  eapply (bin_log_related_under_typed_ctx _ _ _ _ []); eauto.
Qed.


Require Export Relations Wellfounded.
Require Import Sat.
Require Import ZF ZFcoc ZFuniv_real.
Require Import ZFlambda.
Require Import Models SnModels.
Require GenRealSN.
Set Implicit Arguments.

(** Strong normalization proof of the Calculus of Constructions.
    It is based on GenRealSN, so it does support strong eliminations.
    Inhabitation of all types is obtained by adding the empty set in every
    type (cf ZFuniv_real). The product is interpreted by the set of *partial*
    functions.
 *)

Module SN := GenRealSN.MakeModel CC_Real.
Export SN.
Hint Unfold inX.
Existing Instance in_ext.

(** Derived properties *)

Notation daimont := Sat.SatSet.daimon.

Lemma val_ok_cons_default e T i j :
  val_ok e i j ->
  T <> kind ->
  val_ok (T::e) (V.cons empty i) (I.cons daimont j).
intros.
apply vcons_add_var; trivial.
split.
 red; auto.
 apply varSAT.
Qed.

Lemma El_int_prod U V i :
  El (int (Prod U V) i) == cc_prod (El (int U i)) (fun x => El (int V (V.cons x i))).
simpl.
apply El_prod.
do 2 red; intros.
rewrite H0; reflexivity.
Qed.

Lemma El_int_arr U V i :
  El (int (Prod U (lift 1 V)) i) == cc_arr (El (int U i)) (El (int V i)).
rewrite El_int_prod.
apply cc_prod_morph; auto with *.
red; intros.
rewrite int_cons_lift_eq; reflexivity.
Qed.

Lemma Real_int_prod U V i f :
  f ∈ cc_prod (El (int U i)) (fun x => El (int V (V.cons x i))) ->
  eqSAT (Real (int (Prod U V) i) f)
        (piSAT (int U i) (fun x => int V (V.cons x i)) (cc_app f)).
simpl; intros.
apply Real_prod.
 do 2 red; intros.
 rewrite H1; reflexivity.

 change (f ∈ El (int (Prod U V) i)).
 rewrite El_int_prod; trivial.
Qed.

Lemma Real_int_arr U V i f :
  f ∈ cc_arr (El (int U i)) (El (int V i)) ->
  eqSAT (Real (int (Prod U (lift 1 V)) i) f)
        (piSAT (int U i) (fun _ => int V i) (cc_app f)).
intros.
rewrite Real_int_prod.
 apply piSAT_morph; auto with *.
  red; intros.
  apply int_cons_lift_eq.

  red; intros; apply cc_app_morph; auto with *.

 revert H; apply eq_elim; apply cc_prod_ext; auto with *.
 red; intros.
 symmetry; apply El_morph; apply int_cons_lift_eq.
Qed.

Lemma kind_ok_trivial T : kind_ok T.
exists nil.
exists T; simpl; auto with *.
exists empty; auto with *.
Qed.
Hint Resolve kind_ok_trivial.

(** ** Extendability *)
Definition cst (x:set) : term.
(* begin show *)
left; exists (fun _ =>x) (fun _ =>Lambda.K).
(* end show *)
 do 2 red; reflexivity.
 do 2 red; reflexivity.
 red; reflexivity.
 red; reflexivity.
Defined.

Definition mkSET (x:set) := cst (mkTY x (fun _ => snSAT)).

Lemma mkSET_kind e x :
  typ e (mkSET x) kind.
red; intros.
split;[discriminate|].
split; trivial.
apply Lambda.sn_K.
Qed.

Lemma cst_typ e x y :
  in_set x y ->
  typ e (cst x) (mkSET y).
red; intros.
apply in_int_intro; intros; try discriminate.
apply and_split; intros.
 simpl.
 red; rewrite El_def.
 apply union2_intro2; trivial.

 simpl.
 rewrite Real_def.
  apply Lambda.sn_K.

  reflexivity.

  apply union2_intro2; trivial.
Qed.
Lemma cst_eq_typ e x y :
  x == y ->
  eq_typ e (cst x) (cst y).
red; simpl; intros; trivial.
Qed.

Lemma cst_eq_typ_inv x y :
  eq_typ nil (cst x) (cst y) ->
  x == y.
intros.
assert (val_ok nil (V.nil empty) (I.nil Lambda.K)).
 red; intros.
 destruct n; inversion H0.
apply H in H0.
simpl in H0; trivial.
Qed.

Lemma mkSET_eq_typ e x y :
  x == y ->
  eq_typ e (mkSET x) (mkSET y).
red; simpl; intros; trivial.
apply mkTY_ext; auto with *.
Qed.

Lemma mkSET_eq_typ_inv x y :
  eq_typ nil (mkSET x) (mkSET y) ->
  x == y.
intros.
assert (val_ok nil (V.nil empty) (I.nil Lambda.K)).
 red; intros.
 destruct n; inversion H0.
apply H in H0.
simpl in H0.
apply couple_injection in H0; destruct H0; trivial.
Qed.

Definition sub_typ_covariant : forall e U1 U2 V1 V2,
  U1 <> kind ->
  eq_typ e U1 U2 ->
  sub_typ (U1::e) V1 V2 ->
  sub_typ e (Prod U1 V1) (Prod U2 V2).
intros.
apply sub_typ_covariant; trivial.
unfold eqX, inX; intros.
rewrite El_prod in H3; trivial.
apply cc_eta_eq in H3; trivial.
Qed.

(** ** Choice *)
(*Require Import ZFcoc SATtypes.
Module Lc:=Lambda.

Definition Ch (X:term) : term.
(* begin show *)
left;
exists (fun i => mkTY (trunc (El(int X i)))
                      (fun _ => depSAT(fun Y=>forall x,x ∈El(int X i)->
                                 inclSAT(cartSAT(Real (int X i) x)unitSAT) Y)
                                      (fun Y=>Y)))
       (fun j => tm X j).
(* end show *)
do 2 red; intros.
apply mkTY_ext; intros.
 rewrite H; auto with *.

 apply interSAT_morph_subset; simpl; intros; auto with *.
 apply fa_morph; intros z.
 rewrite H; reflexivity.

do 2 red; intros; apply tm_morph; auto with *.

red; intros; apply tm_liftable.
red; intros; apply tm_substitutive.
Defined.

Definition ChI (W:term) : term.
(* begin show *)
left; exists (fun i => empty) (fun j => COUPLE (tm W j) ID).
(* end show *)
do 2 red; intros; reflexivity.

do 2 red; intros.
f_equal; trivial.
apply tm_morph; auto with *.

 (**)
 red; intros.
 unfold COUPLE; simpl.
 rewrite tm_liftable.
 rewrite Lc.permute_lift; reflexivity.
 (**)
 red; intros.
 unfold COUPLE; simpl.
 rewrite tm_substitutive.
 rewrite Lc.commut_lift_subst; reflexivity.
Defined.

Lemma ChI_typ e X W :
  X <> kind ->
  typ e W X ->
  typ e (ChI W) (Ch X).
unfold typ.
intros Xnk tyW; intros.
apply in_int_intro; try discriminate.
apply and_split; simpl; intros.
 red; auto.

 red in H0; rewrite El_def in H0.
 specialize tyW with (1:=H).
 apply in_int_not_kind in tyW; trivial.
 destruct tyW.
 rewrite Real_def; intros; auto.
 2:apply interSAT_morph_subset; simpl; auto with *.
 apply interSAT_intro.
  exists snSAT; intros.
  red; intros; apply snSAT_intro.
  apply sat_sn in H4; trivial.

  intros (Y,?); simpl.
  apply i0 with (int W i); trivial.
  apply cartSAT_intro; trivial.
  apply ID_intro.
Qed.

Definition ChE (X C:term) : term.
  left; exists (fun i => ZFrepl.uchoice (fun x => x ∈ Elt (int X i)))
               (fun j => Lc.App (tm C j) (Lc.Abs (Lc.Abs (Lc.Ref 1)))).
  admit.
  admit.
  admit.
  admit.
Defined.

Lemma ChE_typ e W X :
  X <> kind ->
  typ e W (Ch X) ->
  typ e (ChE X W) X.
unfold typ; intros Xnk tyW i j valok.
specialize tyW with (1:=valok).
apply in_int_not_kind in tyW;[|discriminate].
destruct tyW as (tyW,satW).
red in tyW; simpl in tyW; rewrite El_def in tyW.
simpl in satW; rewrite Real_def in satW; trivial.
apply in_int_intro; trivial; try discriminate.
apply and_split; intros.
 red; simpl.
 apply cc_bot_intro.
 apply ZFrepl.uchoice_def.
 split.
  intros.
  rewrite <- H; trivial.
 split; intros.
  admit.
  admit.

 simpl.
 red in H; simpl in H.
 set (w:=ZFrepl.uchoice (fun x => x ∈ Elt(int X i))) in *.
 clearbody w.
 apply depSAT_elim' in satW.
 red in satW.
 eapply cartSAT_case with (X:=Real(int X i) w) (Y:=unitSAT).
 apply satW; intros.
 intros ? h; apply h.
 reflexivity.

 eexact (fun _ h => h).
 assert (inSAT (tm W j) ; rewrite El_def in H.
split.

(** ** Unique choice *)

Definition Tr (X:term) : term.
(* begin show *)
left;
exists (fun i => mkTY (ZFcoc.trunc (El(int X i)))
                      (fun _ => interSAT(fun Y:{Y|forall x,x ∈El(int X i)->
                                           inclSAT(Real (int X i) x) Y}=>proj1_sig Y)))
       (fun j => tm X j).
(* end show *)
do 2 red; intros.
apply mkTY_ext; intros.
 rewrite H; auto with *.

 apply interSAT_morph_subset; simpl; intros; auto with *.
 apply fa_morph; intros z.
 rewrite H; reflexivity.

do 2 red; intros; apply tm_morph; auto with *.

red; intros; apply tm_liftable.
red; intros; apply tm_substitutive.
Defined.

Definition TrI (W:term) : term.
(* begin show *)
left; exists (fun i => empty) (fun j => tm W j).
(* end show *)
do 2 red; intros; reflexivity.

do 2 red; intros; apply tm_morph; auto with *.

red; intros; apply tm_liftable.
red; intros; apply tm_substitutive.
Defined.

Lemma TrI_typ e X W :
  X <> kind ->
  typ e W X ->
  typ e (TrI W) (Tr X).
unfold typ.
intros Xnk tyW; intros.
apply in_int_intro; try discriminate.
apply and_split; simpl; intros.
 red; auto.

 red in H0; rewrite El_def in H0.
 specialize tyW with (1:=H).
 apply in_int_not_kind in tyW; trivial.
 destruct tyW.
 rewrite Real_def; intros; auto.
  apply interSAT_intro' with (F:=fun X=>X); intros.
   apply sat_sn in H2; trivial.

   apply (H3 (int W i)); trivial.

  apply interSAT_morph_subset; simpl; auto with *.
Qed.

Definition TrE (X P F W:term) : term.
(* begin show *)
  left; exists (fun i => cond_set (int W i ∈ Elt (int (Tr X) i))
                                  (trunc_descr (El(int P i))))
               (fun j => Lambda.App (tm F j) (tm W j)).
(* end show *)
do 2 red; intros; rewrite H; reflexivity.

do 2 red; intros; rewrite H; reflexivity.

red; intros.
do 2 rewrite tm_liftable.
reflexivity.

red; intros.
do 2 rewrite tm_substitutive.
reflexivity.
Defined.

Definition EQ A t1 t2 :=
  Prod (Prod A prop) (Prod (App (Ref 0) (lift 1 t1)) (App (Ref 1) (lift 2 t2))).

Definition IsProp X :=
  Prod X (Prod (lift 1 X) (EQ (lift 2 X) (Ref 1) (Ref 0))).

Lemma TrE_typ e X P Pp F W :
  P <> kind ->
  typ e Pp (IsProp P) ->
  typ e F (Prod X (lift 1 P)) ->
  typ e W (Tr X) ->
  typ e (TrE X P F W) P.
unfold typ; intros Pnk tyPp tyF tyW i j valok.
specialize tyPp with (1:=valok); apply in_int_not_kind in tyPp;[|discriminate].
specialize tyF with (1:=valok); apply in_int_not_kind in tyF;[|discriminate].
specialize tyW with (1:=valok); apply in_int_not_kind in tyW;[|discriminate].
clear valok.
destruct tyPp as (isPp,_).
destruct tyF as (tyF,satF).
destruct tyW as (tyW,satW).
apply in_int_intro; trivial; try discriminate.
split; simpl.
 red.
 rewrite Elt_def.
 red in tyW; simpl in tyW; rewrite El_def in tyW.
 apply cc_bot_ax in tyW; destruct tyW.
  admit.
 rewrite cond_set_ok; trivial.
 apply trunc_ind with (El(int X i)) (fun x => cc_app (int F i) x) (int W i); trivial.
  admit. (*!*)

  red; intros.
  admit.

 rewrite Elt_def.
  red; intros.

*)

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

(** * Consistency out of the strong normalization model *)

(** Another consistency proof. *)

Theorem consistency : forall M, ~ typ List.nil M (Prod prop (Ref 0)).
red; intros.
apply model_consistency with (FF:=mkTY (singl prf_trm) (fun _ => neuSAT)) in H;
  trivial.
 apply sn_sort_intro.
  reflexivity.

  apply one_in_props.

 intros.
 red in H0; rewrite El_def  in H0.
 rewrite Real_def; auto with *.
Qed.

Print Assumptions consistency.


Require Import Framework FSParameters.
Require Export LoggedDiskLayer ListLayer.
Import ListNotations.

Set Implicit Arguments.

Definition TransactionCacheOperation :=  HorizontalComposition (ListOperation (addr * value)) (LoggedDiskOperation log_length data_length).
Definition TransactionCacheLang := Build_Layer TransactionCacheOperation.

Notation "'|TCCP|' p" := (@lift_L1 (ListOperation (addr * value)) (LoggedDiskOperation log_length data_length) (ListLang (addr * value)) _ p) (at level 59).
Notation "'|TCDP|' p" := (@lift_L2 (ListOperation (addr * value)) (LoggedDiskOperation log_length data_length) (LoggedDiskLang log_length data_length) _ p) (at level 59).
Notation "'|TCCO|' p" := (@lift_L1 (ListOperation (addr * value)) (LoggedDiskOperation log_length data_length) (ListLang (addr * value)) _ (Op (ListOperation (addr * value)) p)) (at level 59).
Notation "'|TCDO|' p" := (@lift_L2 (ListOperation (addr * value)) (LoggedDiskOperation log_length data_length) (LoggedDiskLang log_length data_length) _ (Op (LoggedDiskOperation log_length data_length) p)) (at level 59).


Require Export fieldType.
Require Import env_desc.
Require Import Coq.ZArith.Zdiv.
Open Scope string_scope.
Open Scope Z_scope.
Open Scope positive_scope.

Module io_file_buffer_size_desc <: Field_ModuleType.
  Definition fName := "io.file.buffer.size".
  Definition rTipe := rTipe_pos.
  (*The constraint is documented in https://hadoop.apache.org/docs/r2.7.4/hadoop-project-dist/hadoop-common/core-default.xml*)
  Definition rProperty := fun value: positive => ((Zpos value) mod (Zpos (myEnv.(env_hw_page_size)))) = 0%Z.
  Definition fUnit := "".
  Definition fInterp := "".
  Definition fAdvice := "".
End io_file_buffer_size_desc.
Module io_file_buffer_size := FieldModuleFunctor io_file_buffer_size_desc.
Export io_file_buffer_size.

Module io_map_index_interval_desc <: Field_ModuleType.
  Definition fName := "io.map.index.interval".
  Definition rTipe := rTipe_pos.
  Definition rProperty := fun value: positive => True.
  Definition fUnit := "".
  Definition fInterp := "".
  Definition fAdvice := "".
End io_map_index_interval_desc.
Module io_map_index_interval := FieldModuleFunctor io_map_index_interval_desc.
Export io_map_index_interval.

Module io_map_index_skip_desc <: Field_ModuleType.
  Definition fName := "io.map.index.skip".
  Definition rTipe := rTipe_N.
  Definition rProperty := fun value: N => True.
  Definition fUnit := "".
  Definition fInterp := "".
  Definition fAdvice := "".
End io_map_index_skip_desc.
Module io_map_index_skip := FieldModuleFunctor io_map_index_skip_desc.
Export io_map_index_skip.

Module io_seqfile_compress_blocksize_desc <: Field_ModuleType.
  Definition fName := "io.seqfile.compress.blocksize".
  Definition rTipe := rTipe_pos.
  Definition rProperty := fun value: positive => True.
  Definition fUnit := "".
  Definition fInterp := "".
  Definition fAdvice := "".
End io_seqfile_compress_blocksize_desc.
Module io_seqfile_compress_blocksize := FieldModuleFunctor io_seqfile_compress_blocksize_desc.
Export io_seqfile_compress_blocksize.

Module io_seqfile_sorter_recordlimit_desc <: Field_ModuleType.
  Definition fName := "io.seqfile.sorter.recordlimit".
  Definition rTipe := rTipe_pos.
  Definition rProperty := fun value: positive => True.
  Definition fUnit := "".
  Definition fInterp := "".
  Definition fAdvice := "".
End io_seqfile_sorter_recordlimit_desc.
Module io_seqfile_sorter_recordlimit := FieldModuleFunctor io_seqfile_sorter_recordlimit_desc.
Export io_seqfile_sorter_recordlimit.

Module ipc_maximum_data_length_desc <: Field_ModuleType.
  Definition fName := "ipc.maximum.data.length".
  Definition rTipe := rTipe_pos.
  Definition rProperty := fun value: positive => True.
  Definition fUnit := "".
  Definition fInterp := "".
  Definition fAdvice := "".
End ipc_maximum_data_length_desc.
Module ipc_maximum_data_length := FieldModuleFunctor ipc_maximum_data_length_desc.
Export ipc_maximum_data_length.


Require Import Poulet4.P4light.Syntax.P4defs.
Require Import Poulet4.P4light.Semantics.Semantics.
Require Import Coq.Program.Program.
Require Import ProD3.core.Core.
Require Import ProD3.core.Tofino.
Require Import ProD3.examples.count.p4ast.

Open Scope func_spec.

Notation ident := string.
Notation path := (list ident).
Notation Val := (@ValueBase bool).
Notation Sval := (@ValueBase (option bool)).

Definition am_ge := ltac:(get_am_ge prog).
Definition ge := ltac:(get_ge am_ge prog).

Definition NoAction_fundef : @fundef Info :=
  ltac:(get_fd ["NoAction"] ge).

Definition NoAction_spec : func_spec :=
  WITH,
    PATH []
    MOD None []
    WITH,
      PRE
        (ARG []
        (MEM []
        (EXT [])))
      POST
        (ARG_RET [] ValBaseNull
        (MEM []
        (EXT []))).

Lemma NoAction_body :
  func_sound ge NoAction_fundef nil NoAction_spec.
Proof.
  start_function.
  step.
  entailer.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* this file contains some cardinal functions, which are message
dependent *)

Require Export reduce.
Require Export DistributedReferenceCounting.machine2.machine.

Section COUNT_MESSAGE.

Definition dec_predicate (m : Message) :=
  match m with
  | dec => true
  | _ => false
  end.

Definition inc_predicate (m : Message) :=
  match m with
  | inc_dec _ => true
  | _ => false
  end.

(* the next one only recognises inc_dec messages related to s0 *)

Variable s0 : Site.

Definition site_inc_predicate (m : Message) :=
  match m with
  | inc_dec s => if eq_site_dec s s0 then true else false
  | _ => false
  end.

Definition copy_predicate (m : Message) :=
  match m with
  | copy => true
  | _ => false
  end.

Definition dec_count (m : Message) :=
  match m with
  | dec => 1%Z
  | _ => 0%Z
  end.

Definition inc_count (m : Message) := 0%Z.

Definition copy_count (m : Message) :=
  match m with
  | copy => 1%Z
  | _ => 0%Z
  end.

Definition cardinal_count :=
  fun_sum Message dec_count (fun_sum Message inc_count copy_count).

Definition cardinal := reduce Message cardinal_count.

Lemma disjoint_cardinal :
 forall q : queue Message,
 cardinal q =
 (reduce Message dec_count q +
  (reduce Message inc_count q + reduce Message copy_count q))%Z.
Proof.
  intro.
  rewrite <- disjoint_reduce.
  rewrite <- disjoint_reduce.
  unfold cardinal in |- *.
  unfold cardinal_count in |- *.
  auto.
Qed.

Lemma cardinal_first_out :
 forall (q : queue Message) (m : Message),
 first Message q = value Message m ->
 cardinal (first_out Message q) = (cardinal q - cardinal_count m)%Z.
Proof.
  intros.
  unfold cardinal in |- *.
  apply reduce_first_out.
  auto.
Qed.

End COUNT_MESSAGE.

Section SIG_WEIGHT.
Let Bag_of_message := Bag_of_Data Message.

Definition sigma_weight (bm : Bag_of_message) :=
  sigma2_table Site LS LS (queue Message) (fun s1 s2 : Site => cardinal) bm.

End SIG_WEIGHT.


Require Import Fiat.Common Fiat.Computation.Core Fiat.ADT.Core Coq.Sets.Ensembles.

Section HideADT.

  Context {extSig : ADTSig}.
  (* The extended signature *)

  Context {resMethodIndex : Type}.
  (* The restricted set of method indices *)

  Variable methodMap : resMethodIndex -> MethodIndex extSig.
  (* Map from restricted to extended method indices *)

  Definition resSig :=
    {| MethodIndex := resMethodIndex;
       MethodDomCod idx := MethodDomCod extSig (methodMap idx)
    |}.
  (* The signature of the ADT with restricted constructor and method indices *)

  Definition HideADT (extADT : ADT extSig) : ADT resSig :=
    match extADT with
        {| Rep := rep;
           Methods := extMethods
        |} =>
        Build_ADT resSig rep
                  (fun idx => extMethods (methodMap idx))
    end.

End HideADT.


Require Import Definitions.
Require Import State.
Require Import Step.
Require Import BinNat.
Require Import BinInt.
Require Import String.

Definition initialState := MkState (const None) (const None).

Definition opened_fd (s : state) (fd : Z) : Prop :=
	fds s fd <> None.
Definition opened_file (s : state) (str : string) : Prop :=
	exists (fd : Z), option_map file (fds s fd) = Some str.
Definition opened_file_with_fd (s : state) (f : string) (fd : Z)
	:= forall z, option_map file (fds s z) = Some f <-> fd = z.

Lemma non_opened_fd_1 (s : state) (fd : Z) (file : string)
	: ~ opened_fd s fd -> ~ opened_file_with_fd s file fd.
Proof.
intros H.
unfold opened_file_with_fd.
intro Hf.
apply H.
unfold opened_fd.
intro Hf2.
destruct (fds s fd) eqn:Heq.
+ discriminate Hf2.
+ pose (T := Hf fd).
	replace (fds s fd) with (None (A:=fdState)) in T.
	unfold option_map in T.
	destruct T.
	discriminate (H1 eq_refl).
Qed.

Lemma opened_file_1 (s : state) (fd : Z) (file : string)
	: opened_file_with_fd s file fd -> opened_file s file.
Proof.
edestruct 1.
eexists.
now apply H1.
Qed.

Definition fileContentKnown (f : string) (s : state) : Prop
	:= match (files s f) with
		| Some fs => forall (n : N), content fs n <> Unknownc
		| None => False
		end.

Definition sameFileContent (f : string) (sStart sEnd : state) : Prop
	:= fileContentKnown f sStart
		/\ forall (n : N), option_map (fun x => content x n) (files sStart f) = option_map (fun x => content x n) (files sEnd f).

Definition setFileContent (s : state) (str content : string) : state
	:= let (sfd, sfile) := s in
		 let sfile := setFun sfile
			(Some
				(MkFileState
					(Some (N.of_nat (length content)))
					(addString content 0%N (const Nonec))
				)
			) str in
			MkState sfd sfile.

Lemma fileContentKnownSetFileContent (file content : string) (s : state)
	: fileContentKnown file (setFileContent s file content).
Proof.
unfold fileContentKnown.
unfold setFileContent.
destruct s.
cbn.
rewrite setFunOk.
intros n.
cbn.
assert (forall m, addString content m (const Nonec) n <> Unknownc).
+ induction content.
	- easy.
	- intros m.
		cbn.
		admit.
Admitted.

Lemma setFileContent_fds (s : state) (str content : string) : fds s = fds (setFileContent s str content).
Proof.
now destruct s.
Qed.

Fixpoint setFileContents (s : state) (contents : list (string * string)) : state
	:= match contents with
	   | ((fn, fc)::contents)%list => setFileContents (setFileContent s fn fc) contents
		 | _ => s
		 end.

Lemma setFileContents_fds (s : state) (contents : list (string * string))
	: fds s = fds (setFileContents s contents).
Proof.
generalize s.
induction contents; intros.
+ easy.
+ simpl.
	destruct a.
	rewrite <- IHcontents.
	apply setFileContent_fds.
Qed.

Transparent abs_step.

Section Abs_step_facts.

Variable s : state.

Lemma open_opened_fd (str : string) (fd : Z) (m : FileSystem.mode) (o : FileSystem.options)
	: opened_fd (abs_step (FileSystem.Open m o str) fd s) fd.
Proof.
unfold opened_fd.
destruct s.
cbn.
now rewrite setFunOk.
Qed.

Lemma open_opened_file_with_fd (str : string) (fd : Z) (m : FileSystem.mode) (o : FileSystem.options)
	: ~ opened_file s str (* provable with the precondition *)
		-> opened_file_with_fd (abs_step (FileSystem.Open m o str) fd s) str fd.
Proof.
unfold opened_file_with_fd.
destruct s eqn:Heq.
intros.
constructor;
	intros.
+ cbn in H0.
	case_dec (fd = z).
	- apply H1.
	- rewrite setFunOk2 in H0.
		* absurd (opened_file s str).
			++ now subst.
			++ exists z.
				now subst.
		* easy.
+	subst.
	cbn.
	now rewrite setFunOk.
Qed.

Lemma open_opened_file_with_fd2 (str f : string) (fd1 fd2 : Z) (m : FileSystem.mode) (o : FileSystem.options)
	: opened_file_with_fd s f fd1
		-> str <> f
		-> opened_file_with_fd (abs_step (FileSystem.Open m o str) fd2 s) f fd1.
Proof.
unfold opened_file_with_fd.
intros.
destruct s.
constructor;
	intros.
+ apply H.
	rewrite <- H1.
	cbn.
	case_dec (fd2 = z).
	- subst.
		rewrite setFunOk.
		cbn.
		destruct (fds z);
			cbn.
(*
case_dec (fd2 = fd1).
+ subst.
	intros.
	exfalso.
	eapply non_opened_fd_1 in H0.
	apply H0.
	apply H.
+ intros.
	unfold opened_file_with_fd.
	unfold opened_file_with_fd in H0.
	destruct s eqn:Heq.
	intros.
	constructor;
		intros.
	-	case_dec (fd2 = z).
		* subst.
			cbn in H2.
			rewrite setFunOk in H2.
			cbn in H2.
			cbn in H0.
			inversion H2.
			admit.
		* apply H0.
			cbn in H2.
			now rewrite setFunOk2 in H2.
	- subst.
		cbn.
		rewrite setFunOk2.
		* now apply <- H0.
		* apply H. *)
Admitted.

Lemma open_opened_fd2 (fd r : Z) (str : string) (m : FileSystem.mode) (o : FileSystem.options)
	: opened_fd s fd -> opened_fd (abs_step (FileSystem.Open m o str) r s) fd.
Proof.
intros.
unfold opened_fd.
destruct s.
cbn.
case_dec (r = fd).
+ subst.
	rewrite setFunOk.
	unfold option_map.
	now destruct (fds fd) eqn:Heq.
+ now rewrite setFunOk2.
Qed.

Lemma open_not_opened_file (r : Z) (str file : string) (m : FileSystem.mode) (o : FileSystem.options)
	: ~ opened_file s file -> file <> str -> ~ opened_file (abs_step (FileSystem.Open m o str) r s) file.
Proof.
intros.
destruct s.
unfold opened_file.
cbn.
intro Hf.
inversion Hf.
clear Hf.
case_dec (r = x).
+ subst.
	rewrite setFunOk in H1.
	cbn in H1.
	inversion H1.
	now subst.
+ rewrite setFunOk2 in H1.
	- apply H.
		now exists x.
	- easy.
Qed.

Lemma getSize_opened_fd (fd1 fd2 : Z) (r : N)
	: opened_fd s fd1 -> opened_fd (abs_step (FileSystem.GetSize fd2) r s) fd1.
Proof.
intros.
now destruct s.
Qed.

Lemma getSize_not_opened_file (file : string) (fd : Z) (r : N)
	: ~ opened_file s file -> ~ opened_file (abs_step (FileSystem.GetSize fd) r s) file.
Proof.
intros.
destruct s.
unfold opened_file.
cbn.
intro Hf.
inversion Hf.
apply H.
unfold opened_file.
cbn.
now exists x.
Qed.

Lemma getSize_opened_file_with_fd (file : string) (fd1 fd2 : Z) (r : N)
 : opened_file_with_fd s file fd1 -> opened_file_with_fd (abs_step (FileSystem.GetSize fd2) r s) file fd1.
Proof.
intros.
now destruct s.
Qed.

Lemma read_opened_fd (n : N) (fd1 fd2 : Z) (r : string)
	: opened_fd s fd1 -> opened_fd (abs_step (FileSystem.Read n fd2) r s) fd1.
Proof.
intros.
unfold opened_fd.
destruct s.
cbn.
case_dec (fd2 = fd1).
+ subst.
	rewrite changeFunOk.
	unfold option_map.
	now destruct (fds fd1) eqn:Heq.
+ now rewrite changeFunOk2.
Qed.

Lemma read_not_opened_file (r file : string) (fd : Z) (n : N)
	: ~ opened_file s file -> ~ opened_file (abs_step (FileSystem.Read n fd) r s) file.
Proof.
intros.
destruct s.
unfold opened_file.
cbn.
intro Hf.
inversion Hf.
apply H.
unfold opened_file.
cbn.
exists x.
rewrite <- H0.
case_dec (fd = x).
+ subst.
	rewrite changeFunOk.
	unfold option_map.
	destruct (fds x).
	- now destruct f.
	- reflexivity.
+ now rewrite changeFunOk2.
Qed.

Lemma read_opened_file_with_fd (file : string) (fd1 fd2 : Z) (n : N) (r : string)
 : opened_file_with_fd s file fd1 -> opened_file_with_fd (abs_step (FileSystem.Read n fd2) r s) file fd1.
Proof.
intros.
destruct s.
unfold opened_file_with_fd.
cbn.
intros z.
case_dec (fd2 = z).
+ subst.
	split; intros.
	- unfold opened_file_with_fd in H.
		apply H.
		rewrite <- H0.
		rewrite changeFunOk.
		cbn.
		destruct (fds z).
		* now destruct f.
		* easy.
	- subst.
		rewrite changeFunOk.
		unfold opened_file_with_fd in H.
		pose (Hr := H z).
		destruct Hr.
		rewrite <- H1; try reflexivity.
		cbn.
		destruct (fds z).
		* now destruct f.
		* easy.
+ split; intros.
	- unfold opened_file_with_fd in H.
		apply H.
		cbn.
		rewrite <- H1.
		now rewrite changeFunOk2.
	- subst.
		unfold opened_file_with_fd in H.
		rewrite changeFunOk2.
		* now apply <- H.
		* assumption.
Qed.

Lemma write_opened_fd (str : string) (fd1 fd2 : Z) (r : unit)
	: opened_fd s fd1 -> opened_fd (abs_step (FileSystem.Write str fd2) r s) fd1.
Proof.
intros.
unfold opened_fd.
destruct s.
cbn.
case_dec (fd2 = fd1).
+ subst.
	rewrite changeFunOk.
	unfold option_map.
	now destruct (fds fd1) eqn:Heq.
+ now rewrite changeFunOk2.
Qed.

Lemma write_opened_file (str file : string) (fd : Z) (r : unit)
	: opened_file s file -> opened_file (abs_step (FileSystem.Write str fd) r s) file.
Proof.
intros.
destruct s.
unfold opened_file.
cbn.
inversion H.
exists x.
rewrite <- H0.
case_dec (fd = x).
+ subst.
	rewrite changeFunOk.
	unfold option_map.
	cbn.
	destruct (fds x).
	- now destruct f.
	- reflexivity.
+ now rewrite changeFunOk2.
Qed.

Lemma write_not_opened_file (str file : string) (fd : Z) (r : unit)
	: ~ opened_file s file -> ~ opened_file (abs_step (FileSystem.Write str fd) r s) file.
Proof.
intros.
destruct s.
unfold opened_file.
cbn.
intro Hf.
inversion Hf.
apply H.
unfold opened_file.
cbn.
exists x.
rewrite <- H0.
case_dec (fd = x).
+ subst.
	rewrite changeFunOk.
	unfold option_map.
	destruct (fds x).
	- now destruct f.
	- reflexivity.
+ now rewrite changeFunOk2.
Qed.

Lemma write_opened_file_with_fd (file : string) (fd1 fd2 : Z) (r : unit) (str : string)
 : opened_file_with_fd s file fd1 -> opened_file_with_fd (abs_step (FileSystem.Write str fd2) r s) file fd1.
Proof.
intros.
destruct s.
unfold opened_file_with_fd.
cbn.
intros z.
case_dec (fd2 = z).
+ subst.
	split; intros.
	- unfold opened_file_with_fd in H.
		apply H.
		rewrite <- H0.
		rewrite changeFunOk.
		cbn.
		destruct (fds z).
		* now destruct f.
		* easy.
	- subst.
		rewrite changeFunOk.
		unfold opened_file_with_fd in H.
		pose (Hr := H z).
		destruct Hr.
		rewrite <- H1; try reflexivity.
		cbn.
		destruct (fds z).
		* now destruct f.
		* easy.
+ split; intros.
	- unfold opened_file_with_fd in H.
		apply H.
		cbn.
		rewrite <- H1.
		now rewrite changeFunOk2.
	- subst.
		unfold opened_file_with_fd in H.
		rewrite changeFunOk2.
		* now apply <- H.
		* assumption.
Qed.

Lemma close_opened_fd (fd1 fd2 : Z) (r : unit)
	: opened_fd s fd1 -> fd2 <> fd1 -> opened_fd (abs_step (FileSystem.Close fd2) r s) fd1.
Proof.
intros.
unfold opened_fd.
destruct s.
cbn.
now rewrite setFunOk2.
Qed.

Lemma close_not_opened_file (f : string) (fd : Z) (r : unit)
	: ~ opened_file s f -> ~ opened_file (abs_step (FileSystem.Close fd) r s) f.
Proof.
intros.
destruct s.
unfold opened_file.
cbn.
intro Hf.
inversion Hf.
case_dec (fd = x).
+ subst.
	now rewrite setFunOk in H0.
+ rewrite setFunOk2 in H0.
	- apply H.
		now exists x.
	- easy.
Qed.

Lemma close_not_opened_file2 (f : string) (fd : Z) (r : unit)
	: opened_file_with_fd s f fd
		-> ~ opened_file (abs_step (FileSystem.Close fd) r s) f.
Proof.
intros.
destruct s.
unfold opened_file.
cbn.
unfold opened_file_with_fd in H.
intro Hf.
inversion Hf.
clear Hf.
case_dec (fd = x).
+ subst.
	now rewrite setFunOk in H0.
+ apply H1.
	apply (H x).
	now rewrite setFunOk2 in H0.
Qed.

Lemma close_opened_file_with_fd (f : string) (fd1 fd2 : Z) (r : unit)
	: opened_file_with_fd s f fd1
		-> fd1 <> fd2 (* provable with the postcondition of the corresponding open *)
		-> opened_file_with_fd (abs_step (FileSystem.Close fd2) r s) f fd1.
Proof.
intros.
destruct s.
unfold opened_file_with_fd.
Admitted.

Lemma unlink_not_opened_file (file z : string) (r : unit)
	: ~ opened_file s file -> ~ opened_file (abs_step (FileSystem.Unlink z) r s) file.
Proof.
intros.
destruct s.
unfold opened_file.
cbn.
intro Hf.
inversion Hf.
apply H.
unfold opened_file.
cbn.
now exists x.
Qed.

End Abs_step_facts.


(* jww (2017-04-13): TODO
Lemma Const_Cone_Iso `(F : @Functor J C)
  : ∀ a, @Isomorphism Sets (Const a ⟾ F) (Cone a F).
Proof.
  intros.
  isomorphism.
  - (* to *)
    crush.
    refine (Build_Cone _ _ _ _ _ _); intros; simpl; destruct X.
    + (* cone_mor *)
      apply transport0.
    + (* cone_law *)
      destruct F.
      simpl in naturality0.
      specialize (naturality0 i j f).
      rewrite right_identity in naturality0.
      apply naturality0.
  - (* from *)
    crush.
    unfold Const.
    destruct X.
    transform.
    + (* transport *)
      apply cone_mor0.
    + (* naturality *)
      rewrite right_identity.
      destruct F.
      simpl in cone_law0.
      apply cone_law0.
  - (* iso_to *)
    extensionality e.
    destruct e.
    apply proof_irrelevance.
  - (* iso_from *)
    extensionality e.
    destruct e.
    apply proof_irrelevance.
Qed.
*)


Require Import VST.msl.msl_direct.
Require Import RamifyCoq.msl_ext.abs_addr.

Instance Join_discrete (A : Type): Join A := fun a1 a2 a3 : A => False.

Instance Perm_discrete (A: Type)  : @Perm_alg A (Join_discrete A).
Proof. constructor; intros; inv H. Qed.

Instance psa_discrete (A: Type) :  @Pos_alg A  (Join_discrete A).
Proof. repeat intro. inv H. Qed.

(* Definition var := nat. *)
Definition adr := nat.

Definition world := (fpm adr adr).

Instance Join_world: Join world := Join_fpm (Join_discrete adr).

Instance Perm_world : Perm_alg world. apply Perm_fpm; apply Perm_discrete. Qed.

Instance Sep_world : Sep_alg world. apply Sep_fpm. Qed.

Instance Canc_world : Canc_alg world. apply Canc_fpm; [intuition | repeat intro; inversion H]. Qed.

Instance Disj_world : Disj_alg world. apply Disj_fpm; repeat intro; [apply Perm_discrete | |]; inversion H. Qed.

Instance Cross_world : Cross_alg world. apply Cross_fpm; [apply Perm_discrete | apply psa_discrete | repeat intro; inv H]. Qed.

Instance Trip_world : @Trip_alg world Join_world.
Proof.
  repeat intro.
  destruct ab as [fab Hab]. destruct c as [fc Hc].
  remember (fun x => match (fab x) with
                       | Some v => Some v
                       | None => match (fc x) with
                                   | Some v' => Some v'
                                   | None => None
                                 end
                     end) as fabc.
  assert (finMap fabc). {
    hnf in Hab, Hc. destruct Hab as [lab ?]. destruct Hc as [lc ?].
    exists (lab ++ lc). intro z; intros.
    assert (~ In z lab). intro. apply H2. apply in_or_app. left; auto.
    assert (~ In z lc). intro. apply H2. apply in_or_app. right; auto.
    hnf in *. simpl in *. specialize (e0 z H4). specialize (e z H3).
    rewrite Heqfabc. destruct (fab z) eqn:? . inv e. destruct (fc z) eqn:? . inv e0. auto.
  } exists (exist (finMap (B:=adr)) fabc H2).
  hnf. simpl. intros. rewrite Heqfabc. destruct (fab x) eqn:? .
  + destruct (fc x) eqn:? .
    - destruct a as [fa ?]. destruct b as [fb ?]. hnf in *. simpl in *.
      specialize (H x). rewrite Heqo in *. inversion H.
      * specialize (H0 x). rewrite H6, Heqo0 in *. inversion H0. inversion H9.
      * specialize (H1 x). rewrite H6, Heqo0 in *. inversion H1. inversion H9.
      * inversion H6.
    - constructor.
  + destruct (fc x) eqn:? .
    - constructor.
    - constructor.
Defined.

Definition adr_conflict (a1 a2 : adr) : bool := if (eq_nat_dec a1 a2) then true else false.

Instance AbsAddr_world : AbsAddr adr adr.
  apply (mkAbsAddr adr adr adr_conflict); intros; unfold adr_conflict in *.
  + destruct (eq_nat_dec p1 p2). subst. destruct (eq_nat_dec p2 p2); auto. exfalso; tauto.
    destruct (eq_nat_dec p2 p1). subst. exfalso; tauto. trivial.
  + destruct (eq_nat_dec p1 p1). inversion H. exfalso; tauto.
Defined.

Fixpoint extractSome (f : adr -> option adr) (li : list adr) : list adr :=
  match li with
    | nil => nil
    | x :: lx => match f x with
                   | Some _ => x :: extractSome f lx
                   | None => extractSome f lx
                 end
  end.

Lemma world_finite: forall w: world, exists l: list adr, forall a:adr, In a l <-> lookup_fpm w a <> None.
Proof.
  intro; destruct w as [f [li ?]]; simpl; exists (extractSome f li); split; intros.
  clear e; induction li; simpl in H; auto.
  destruct (f a0) eqn: ?. destruct (in_inv H). subst. rewrite Heqo. intro. inversion H0.
  apply IHli; auto. apply IHli; auto. destruct (in_dec nat_eq_dec a li). clear e.
  induction li; simpl in *; auto. destruct (f a0) eqn : ?. destruct i. subst. apply in_eq.
  apply in_cons. apply IHli; auto. destruct i. subst. exfalso; auto. apply IHli; auto.
  specialize (e a n). exfalso; auto.
Qed.

Lemma lookup_fpm_join_sub: forall (w1 w2 : world) x, join_sub w1 w2 -> lookup_fpm w1 x <> None -> lookup_fpm w2 x <> None.
Proof.
  intros. destruct H as [w3 ?].
  destruct w1 as [f1 [l1 ?]]. destruct w2 as [f2 [l2 ?]]. destruct w3 as [f3 [l3 ?]]. hnf in H; simpl in *.
  specialize (H x). inversion H. exfalso; auto. auto. auto.
Qed.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition invalidate_page_spec0 (addr: Z64) (adt: RData) : option RData :=
    match addr with
    | VZ64 _addr =>
      when adt == barrier_spec  adt;
      rely is_int64 _addr;
      when adt == stage2_tlbi_ipa_spec (VZ64 _addr) (VZ64 4096) adt;
      Some adt
     end
    .

End SpecLow.


Set Implicit Arguments.

Section ADTValue.

  Variable ADTValue : Type.

  Require Import Platform.Cito.SemanticsFacts4.
  Require Import Platform.Cito.ProgramLogic2.
  Require Import Platform.Cito.Transit.
  Require Import Platform.Cito.Semantics.

  Require Import Platform.Cito.GLabel.
  Require Import Platform.Cito.GLabelMap.
  Import GLabelMap.
  Require Import Platform.Cito.GLabelMapFacts.

  Notation Internal := (@Internal ADTValue).

  Definition strengthen_specs specs_op specs_ax env_ax :=
    forall (lbl : glabel),
      find lbl specs_op = find lbl specs_ax \/
      exists spec_op spec_ax,
        find lbl specs_op = Some (Internal spec_op) /\
        find lbl specs_ax = Some (Foreign spec_ax) /\
        strengthen_op_ax spec_op spec_ax env_ax.

  Require Import Platform.Cito.GeneralTactics Platform.Cito.GeneralTactics2.
  Require Import Platform.Cito.Option.

  Lemma strengthen_specs_strengthen : forall specs_op specs_ax env_op env_ax, strengthen_specs specs_op specs_ax env_ax -> specs_env_agree specs_op env_op -> specs_env_agree specs_ax env_ax -> (forall lbl, fst env_op lbl = fst env_ax lbl) -> strengthen env_op env_ax.
  Proof.
    split; intros.
    eauto.
    destruct (option_dec (fs_op w)).
    destruct s.
    generalize e; intro.
    eapply H0 in e.
    openhyp.
    edestruct (H x0).
    left.
    rewrite e0.
    symmetry.
    eapply H1.
    rewrite H5 in H4; clear H5.
    descend; eauto.
    rewrite <- H2.
    eauto.

    openhyp.
    rewrite H5 in H4; injection H4; intros; subst.
    assert (fs_ax w = Some (Foreign x2)).
    eapply H1.
    descend; eauto.
    rewrite <- H2; eauto.
    right; descend; eauto.

    destruct (option_dec (fs_ax w)).
    destruct s.
    generalize e0; intro.
    eapply H1 in e0.
    openhyp.
    edestruct (H x0).
    assert (fs_op w = Some x).
    eapply H0.
    descend; eauto.
    rewrite H2; eauto.
    rewrite H5.
    eauto.
    rewrite H6 in e; intuition.
    openhyp.
    assert (fs_op w = Some (Internal x1)).
    eapply H0.
    descend; eauto.
    rewrite H2; eauto.
    rewrite H8 in e; intuition.
    left; congruence.
  Qed.

  Notation Foreign := (@Foreign ADTValue).

  Definition apply_specs_diff specs specs_diff := update specs (map Foreign specs_diff).

  Definition strengthen_diff_f specs env_ax k v a :=
    a /\
    (find k specs = Some (Foreign v) \/
     exists op,
       find k specs = Some (Internal op) /\
       strengthen_op_ax op v env_ax).

  Definition strengthen_diff specs specs_diff env_ax :=
    fold (strengthen_diff_f specs env_ax) specs_diff True.

  Lemma strengthen_diff_elim : forall specs_diff env_ax specs, strengthen_diff specs specs_diff env_ax -> forall lbl ax, find lbl specs_diff = Some ax -> find lbl specs = Some (Foreign ax) \/ exists op, find lbl specs = Some (Internal op) /\ strengthen_op_ax op ax env_ax.
    do 3 intro.
    eapply fold_rec_bis with (P := fun specs_diff (H : Prop) => H -> forall lbl ax, find lbl specs_diff = Some ax -> find lbl specs = Some (Foreign ax) \/ exists op, find lbl specs = Some (Internal op) /\ strengthen_op_ax op ax env_ax); simpl; intros.
    eapply H0; eauto.
    rewrite H; eauto.
    rewrite empty_o in H0; intuition.
    eapply find_mapsto_iff in H3.
    eapply add_mapsto_iff in H3.
    openhyp.
    subst.
    destruct H2.
    openhyp.
    eauto.
    right; descend; eauto.
    eapply H1.
    destruct H2; eauto.
    eapply find_mapsto_iff; eauto.
  Qed.

  Lemma strengthen_diff_strengthen_specs : forall specs specs_diff env_ax, strengthen_diff specs specs_diff env_ax -> strengthen_specs specs (apply_specs_diff specs specs_diff) env_ax.
    intros.
    unfold strengthen_specs.
    intros.
    destruct (option_dec (find lbl specs_diff)).
    destruct s.
    eapply strengthen_diff_elim in H; eauto.
    openhyp.
    left.
    rewrite H.
    symmetry.
    eapply find_mapsto_iff.
    eapply update_mapsto_iff.
    left.
    eapply find_mapsto_iff.
    rewrite map_o.
    rewrite e.
    eauto.
    right; descend; eauto.
    eapply find_mapsto_iff.
    eapply update_mapsto_iff.
    left.
    eapply find_mapsto_iff.
    rewrite map_o.
    rewrite e.
    eauto.
    left.
    unfold apply_specs_diff.
    rewrite update_o_1; eauto.
    nintro.
    eapply map_4 in H0.
    eapply In_find_not_None in H0.
    erewrite e in H0.
    intuition.
  Qed.

  Lemma strengthen_diff_strenghthen : forall specs specs_diff env_op env_ax, strengthen_diff specs specs_diff env_ax -> specs_env_agree specs env_op -> specs_env_agree (apply_specs_diff specs specs_diff) env_ax -> (forall lbl, fst env_op lbl = fst env_ax lbl) -> strengthen env_op env_ax.
    intros.
    eapply strengthen_specs_strengthen; eauto.
    eapply strengthen_diff_strengthen_specs; eauto.
  Qed.

  Notation Callee := (@Callee ADTValue).

  Definition is_pointer_of_label specs (stn : glabel -> option W) w : option Callee :=
    fold (fun k v res =>
            match res with
              | Some _ => res
              | None =>
                match stn k with
                  | Some w' => if weq w w' then Some v else None
                  | None => None
                end
            end
         ) specs None.

  Notation Env := (@Env ADTValue).

  Definition change_env new_specs (env : Env) : Env :=
    let stn := fst env in
    let fs := snd env in
    (stn,
     fun w =>
       match is_pointer_of_label new_specs stn w with
         | Some new_spec => Some new_spec
         | None => fs w
       end).

  Notation specs_stn_injective := (@specs_stn_injective ADTValue).

  Lemma sub_domain_specs_stn_injective : forall specs1 specs2 stn, specs_stn_injective specs1 stn -> sub_domain specs2 specs1 -> specs_stn_injective specs2 stn.
    unfold ProgramLogic2.specs_stn_injective, sub_domain; intros.
    eapply H; eauto.
  Qed.

  Lemma add_specs_stn_injective : forall specs k v stn, specs_stn_injective (add k v specs) stn -> specs_stn_injective specs stn.
    intros.
    eapply sub_domain_specs_stn_injective; eauto.
    unfold sub_domain; intros.
    eapply add_in_iff; eauto.
  Qed.

  Lemma is_pointer_of_label_intro_elim : forall specs stn w, (forall v, is_pointer_of_label specs stn w = Some v -> exists lbl, find lbl specs = Some v /\ stn lbl = Some w) /\ (forall v lbl, specs_stn_injective specs stn -> find lbl specs = Some v -> stn lbl = Some w -> is_pointer_of_label specs stn w = Some v).
    do 3 intro.
    eapply fold_rec_bis with (P := fun specs a => (forall v, a = Some v -> exists lbl, find lbl specs = Some v /\ stn lbl = Some w) /\ (forall v lbl, specs_stn_injective specs stn -> find lbl specs = Some v -> stn lbl = Some w -> a = Some v)); simpl; intros.
    unfold ProgramLogic2.specs_stn_injective in *.
    setoid_rewrite H in H0.
    eapply H0; eauto.
    split; intros.
    intuition.
    rewrite empty_o in H0; intuition.
    openhyp.
    split; intros.
    destruct a.
    injection H3; intros; subst.
    edestruct H1; eauto.
    openhyp.
    descend; eauto.
    eapply find_mapsto_iff; eapply add_mapsto_iff.
    right.
    split.
    nintro; subst.
    eapply find_mapsto_iff in H4; eapply MapsTo_In in H4.
    contradiction.
    eapply find_mapsto_iff; eauto.
    destruct (option_dec (stn k)).
    destruct s.
    rewrite e0 in *.
    destruct (weq w x).
    subst.
    injection H3; intros; subst.
    descend; eauto.
    eapply find_mapsto_iff; eapply add_mapsto_iff.
    eauto.
    intuition.
    rewrite e0 in *; intuition.
    destruct a.
    edestruct H1; eauto.
    openhyp.
    eapply find_mapsto_iff in H4; eapply find_mapsto_iff in H6.
    assert (lbl = x).
    eapply H3; eauto.
    eapply MapsTo_In; eauto.
    eapply add_in_iff; right; eapply MapsTo_In; eauto.
    subst.
    eapply add_mapsto_iff in H4; openhyp.
    subst.
    eapply MapsTo_In in H6; contradiction.
    eapply H2; eauto.
    eapply add_specs_stn_injective; eauto.
    eapply find_mapsto_iff; eauto.

    eapply find_mapsto_iff in H4.
    destruct (option_dec (stn k)).
    destruct s.
    rewrite e0 in *.
    eapply add_mapsto_iff in H4; openhyp.
    subst.
    rewrite H5 in e0; injection e0; intros; subst.
    destruct (weq x x); intuition.
    destruct (weq w x).
    subst.
    contradict H4.
    eapply H3; eauto.
    eapply add_in_iff; eauto.
    eapply add_in_iff; right; eapply MapsTo_In; eauto.
    eapply H2; eauto.
    eapply add_specs_stn_injective; eauto.
    eapply find_mapsto_iff; eauto.
    rewrite e0 in *.
    eapply add_mapsto_iff in H4; openhyp.
    subst.
    rewrite H5 in e0; intuition.
    eapply H2; eauto.
    eapply add_specs_stn_injective; eauto.
    eapply find_mapsto_iff; eauto.
  Qed.

  Lemma is_pointer_of_label_intro : forall specs stn w v lbl, specs_stn_injective specs stn -> find lbl specs = Some v -> stn lbl = Some w -> is_pointer_of_label specs stn w = Some v.
    eapply is_pointer_of_label_intro_elim; eauto.
  Qed.

  Lemma is_pointer_of_label_elim : forall specs stn w v, is_pointer_of_label specs stn w = Some v -> exists lbl, find lbl specs = Some v /\ stn lbl = Some w.
    eapply is_pointer_of_label_intro_elim; eauto.
  Qed.

  Lemma equal_domain_specs_stn_injective : forall specs1 specs2 stn, equal_domain specs1 specs2 -> (specs_stn_injective specs1 stn <-> specs_stn_injective specs2 stn).
    split; intros.
    eapply sub_domain_specs_stn_injective; eauto; eapply H.
    eapply sub_domain_specs_stn_injective; eauto; eapply H.
  Qed.
  Lemma equal_domain_sym : forall elt1 elt2 (m1 : t elt1) (m2 : t elt2), equal_domain m1 m2 -> equal_domain m2 m1.
    unfold equal_domain; intuition.
  Qed.

  Lemma change_env_agree : forall specs new_specs, equal_domain new_specs specs -> forall env, specs_env_agree specs env -> specs_env_agree new_specs (change_env new_specs env).
  Proof.
    unfold specs_env_agree.
    intros.
    openhyp.
    simpl.
    split.
    unfold labels_in_scope in *.
    intros.
    eapply H0.
    eapply H; eauto.

    split.
    eapply equal_domain_specs_stn_injective; eauto.

    unfold specs_fs_agree in *.
    split; intros.
    simpl in *.
    destruct env in *; simpl in *.
    destruct (option_dec (is_pointer_of_label new_specs o p)).
    destruct s.
    rewrite e in *.
    injection H3; intros; subst.
    eapply is_pointer_of_label_elim in e; openhyp.
    descend; eauto.
    rewrite e in *.
    eapply H2 in H3; openhyp.
    eapply find_mapsto_iff in H4; eapply MapsTo_In in H4.
    eapply H in H4.
    eapply In_MapsTo in H4; openhyp.
    assert (is_pointer_of_label new_specs o p = Some x0).
    eapply is_pointer_of_label_intro; eauto.
    eapply equal_domain_specs_stn_injective; eauto.

    eapply find_mapsto_iff; eauto.
    rewrite e in H5; intuition.
    openhyp.
    simpl in *.
    destruct env; simpl in *.
    assert (is_pointer_of_label new_specs o p = Some spec).
    eapply is_pointer_of_label_intro; eauto.
    eapply equal_domain_specs_stn_injective; eauto.
    rewrite H5; eauto.
  Qed.

  Lemma sub_domain_apply_specs_diff_equal_domain a b : sub_domain b a -> equal_domain (apply_specs_diff a b) a.
  Proof.
    unfold apply_specs_diff.
    unfold equal_domain.
    intros H.
    split.
    {
      eapply sub_domain_update_sub_domain; eauto.
      eapply sub_domain_map_1; eauto.
    }
    {
      eapply sub_domain_update_1.
      eapply sub_domain_refl.
    }
  Qed.

End ADTValue.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(* We activate implicit arguments by default *)
Global Set Implicit Arguments.
Global Unset Strict Implicit.
Global Unset Printing Implicit Defensive.
Global Set Primitive Projections.
Global Unset Auto Template Polymorphism.
Global Set Loose Hint Behavior "Strict".

(** Enable proof mode. *)
Declare ML Module "coq-core.plugins.ltac".
Global Set Default Proof Mode "Classic".

(** Scopes *)

Declare Scope type_scope.
Delimit Scope type_scope with type.
Declare Scope function_scope.
Delimit Scope function_scope with function.
Declare Scope core_scope.
Delimit Scope core_scope with core.

Bind Scope type_scope with Sortclass.
Bind Scope function_scope with Funclass.

Open Scope core_scope.
Open Scope function_scope.
Open Scope type_scope.

(** Notations available initially *)
Reserved Notation "x -> y" (at level 99, right associativity, y at level 200).
Notation "A -> B" := (forall (_ : A), B) : type_scope.
Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..)
  (at level 200, x binder, y binder, right associativity,
  format "'[  ' '[  ' 'λ'  x  ..  y ']' ,  '/' t ']'").


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

(** Correctness proof for constant propagation (processor-dependent part). *)

Require Import Coqlib.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
Require Import Events.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import ConstpropOp.
Require Import Constprop.

(** * Correctness of the static analysis *)

Section ANALYSIS.

Context `{Hcc: CompilerConfiguration}.
Variable ge: genv.
Variable sp: val.

(** We first show that the dataflow analysis is correct with respect
  to the dynamic semantics: the approximations (sets of values)
  of a register at a program point predicted by the static analysis
  are a superset of the values actually encountered during concrete
  executions.  We formalize this correspondence between run-time values and
  compile-time approximations by the following predicate. *)

Definition val_match_approx (a: approx) (v: val) : Prop :=
  match a with
  | Unknown => True
  | I p => v = Vint p
  | F p => v = Vfloat p
  | G symb ofs => v = symbol_address ge symb ofs
  | S ofs => v = Val.add sp (Vint ofs)
  | _ => False
  end.

Inductive val_list_match_approx: list approx -> list val -> Prop :=
  | vlma_nil:
      val_list_match_approx nil nil
  | vlma_cons:
      forall a al v vl,
      val_match_approx a v ->
      val_list_match_approx al vl ->
      val_list_match_approx (a :: al) (v :: vl).

Ltac SimplVMA :=
  match goal with
  | H: (val_match_approx (I _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (F _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (G _ _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (S _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | _ =>
      idtac
  end.

Ltac InvVLMA :=
  match goal with
  | H: (val_list_match_approx nil ?vl) |- _ =>
      inv H
  | H: (val_list_match_approx (?a :: ?al) ?vl) |- _ =>
      inv H; SimplVMA; InvVLMA
  | _ =>
      idtac
  end.

(** We then show that [eval_static_operation] is a correct abstract
  interpretations of [eval_operation]: if the concrete arguments match
  the given approximations, the concrete results match the
  approximations returned by [eval_static_operation]. *)

Lemma eval_static_condition_correct:
  forall cond al vl m b,
  val_list_match_approx al vl ->
  eval_static_condition cond al = Some b ->
  eval_condition cond vl m = Some b.
Proof.
  intros until b.
  unfold eval_static_condition.
  case (eval_static_condition_match cond al); intros;
  InvVLMA; simpl; congruence.
Qed.

Remark shift_symbol_address:
  forall symb ofs n,
  symbol_address ge symb (Int.add ofs n) = Val.add (symbol_address ge symb ofs) (Vint n).
Proof.
  unfold symbol_address; intros. destruct (Genv.find_symbol ge symb); auto.
Qed.

Lemma eval_static_addressing_correct:
  forall addr al vl v,
  val_list_match_approx al vl ->
  eval_addressing ge sp addr vl = Some v ->
  val_match_approx (eval_static_addressing addr al) v.
Proof.
  intros until v. unfold eval_static_addressing.
  case (eval_static_addressing_match addr al); intros;
  InvVLMA; simpl in *; FuncInv; try subst v; auto.
  rewrite shift_symbol_address; auto.
  rewrite Val.add_assoc. auto.
  repeat rewrite shift_symbol_address. auto.
  fold (Val.add (Vint n1) (symbol_address ge id ofs)).
  repeat rewrite shift_symbol_address. repeat rewrite Val.add_assoc. rewrite Val.add_permut. auto.
  repeat rewrite Val.add_assoc. decEq; simpl. rewrite Int.add_assoc. auto.
  fold (Val.add (Vint n1) (Val.add sp (Vint ofs))).
  rewrite Val.add_assoc. rewrite Val.add_permut. rewrite Val.add_assoc.
  simpl. rewrite Int.add_assoc; auto.
  rewrite shift_symbol_address. auto.
  rewrite Val.add_assoc. auto.
  rewrite shift_symbol_address. auto.
  rewrite shift_symbol_address. rewrite Int.mul_commut; auto.
Qed.

Lemma eval_static_operation_correct:
  forall op al vl m v,
  val_list_match_approx al vl ->
  eval_operation ge sp op vl m = Some v ->
  val_match_approx (eval_static_operation op al) v.
Proof.
  intros until v.
  unfold eval_static_operation.
  case (eval_static_operation_match op al); intros;
  InvVLMA; simpl in *; FuncInv; try subst v; auto.
  destruct (propagate_float_constants tt); simpl; auto.
  rewrite Int.sub_add_opp. rewrite shift_symbol_address. rewrite Val.sub_add_opp. auto.
  destruct (Int.eq n2 Int.zero). inv H0.
    destruct (Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone); inv H0; simpl; auto.
  destruct (Int.eq n2 Int.zero); inv H0; simpl; auto.
  destruct (Int.eq n2 Int.zero). inv H0.
    destruct (Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone); inv H0; simpl; auto.
  destruct (Int.eq n2 Int.zero); inv H0; simpl; auto.
  destruct (Int.ltu n2 Int.iwordsize); simpl; auto.
  destruct (Int.ltu n Int.iwordsize); simpl; auto.
  destruct (Int.ltu n2 Int.iwordsize); simpl; auto.
  destruct (Int.ltu n Int.iwordsize); simpl; auto.
  destruct (Int.ltu n (Int.repr 31)); inv H0. simpl; auto.
  destruct (Int.ltu n2 Int.iwordsize); simpl; auto.
  destruct (Int.ltu n Int.iwordsize); simpl; auto.
  destruct (Int.ltu n Int.iwordsize); simpl; auto.
  eapply eval_static_addressing_correct; eauto.
  unfold eval_static_intoffloat.
  destruct (Float.intoffloat n1) eqn:?; simpl in H0; inv H0.
  simpl; auto.
  destruct (propagate_float_constants tt); simpl; auto.
  unfold eval_static_condition_val. destruct (eval_static_condition c vl0) as [b|] eqn:?.
  rewrite (eval_static_condition_correct _ _ _ m _ H Heqo).
  destruct b; simpl; auto.
  simpl; auto.
Qed.

(** * Correctness of strength reduction *)

(** We now show that strength reduction over operators and addressing
  modes preserve semantics: the strength-reduced operations and
  addressings evaluate to the same values as the original ones if the
  actual arguments match the static approximations used for strength
  reduction. *)

Section STRENGTH_REDUCTION.

Variable app: D.t.
Variable rs: regset.
Variable m: mem.
Hypothesis MATCH: forall r, val_match_approx (approx_reg app r) rs#r.

Ltac InvApproxRegs :=
  match goal with
  | [ H: _ :: _ = _ :: _ |- _ ] =>
        injection H; clear H; intros; InvApproxRegs
  | [ H: ?v = approx_reg app ?r |- _ ] =>
        generalize (MATCH r); rewrite <- H; clear H; intro; InvApproxRegs
  | _ => idtac
  end.

Lemma cond_strength_reduction_correct:
  forall cond args vl,
  vl = approx_regs app args ->
  let (cond', args') := cond_strength_reduction cond args vl in
  eval_condition cond' rs##args' m = eval_condition cond rs##args m.
Proof.
  intros until vl. unfold cond_strength_reduction.
  case (cond_strength_reduction_match cond args vl); simpl; intros; InvApproxRegs; SimplVMA.
  rewrite H0. apply Val.swap_cmp_bool.
  rewrite H. auto.
  rewrite H0. apply Val.swap_cmpu_bool.
  rewrite H. auto.
  auto.
Qed.

Lemma addr_strength_reduction_correct:
  forall addr args vl,
  vl = approx_regs app args ->
  let (addr', args') := addr_strength_reduction addr args vl in
  eval_addressing ge sp addr' rs##args' = eval_addressing ge sp addr rs##args.
Proof.
  intros until vl. unfold addr_strength_reduction.
  destruct (addr_strength_reduction_match addr args vl); simpl; intros; InvApproxRegs; SimplVMA.
  rewrite shift_symbol_address; congruence.
  rewrite H. rewrite Val.add_assoc; auto.
  rewrite H; rewrite H0. repeat rewrite shift_symbol_address. auto.
  rewrite H; rewrite H0. rewrite Int.add_assoc. rewrite Int.add_permut. repeat rewrite shift_symbol_address.
  rewrite Val.add_assoc. rewrite Val.add_permut. auto.
  rewrite H; rewrite H0. repeat rewrite Val.add_assoc. rewrite Int.add_assoc. auto.
  rewrite H; rewrite H0. repeat rewrite Val.add_assoc. rewrite Val.add_permut.
  rewrite Int.add_assoc. auto.
  rewrite H0. rewrite shift_symbol_address. repeat rewrite Val.add_assoc.
  decEq; decEq. apply Val.add_commut.
  rewrite H. rewrite shift_symbol_address. repeat rewrite Val.add_assoc.
  rewrite (Val.add_permut (rs#r1)). decEq; decEq. apply Val.add_commut.
  rewrite H0. rewrite Val.add_assoc. rewrite Val.add_permut. auto.
  rewrite H. rewrite Val.add_assoc. auto.
  rewrite H; rewrite H0. rewrite Int.add_assoc. repeat rewrite shift_symbol_address. auto.
  rewrite H0. rewrite shift_symbol_address. rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut.
  rewrite H. auto.
  rewrite H. rewrite shift_symbol_address. auto.
  rewrite H. rewrite shift_symbol_address. rewrite Int.mul_commut; auto.
  auto.
Qed.

Lemma make_addimm_correct:
  forall n r,
  let (op, args) := make_addimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.add rs#r (Vint n)) v.
Proof.
  intros. unfold make_addimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst. exists (rs#r); split; auto. destruct (rs#r); simpl; auto; rewrite Int.add_zero; auto.
  exists (Val.add rs#r (Vint n)); auto.
Qed.

Lemma make_shlimm_correct:
  forall n r1,
  let (op, args) := make_shlimm n r1 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shl rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_shlimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shl_zero. auto.
  econstructor; split. simpl. eauto. auto.
Qed.

Lemma make_shrimm_correct:
  forall n r1,
  let (op, args) := make_shrimm n r1 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shr rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_shrimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shr_zero. auto.
  econstructor; split; eauto. simpl. auto.
Qed.

Lemma make_shruimm_correct:
  forall n r1,
  let (op, args) := make_shruimm n r1 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shru rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_shruimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shru_zero. auto.
  econstructor; split; eauto. simpl. congruence.
Qed.

Lemma make_mulimm_correct:
  forall n r1,
  let (op, args) := make_mulimm n r1 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.mul rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_mulimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (Vint Int.zero); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.one; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_one; auto.
  destruct (Int.is_power2 n) eqn:?; intros.
  rewrite (Val.mul_pow2 rs#r1 _ _ Heqo). apply make_shlimm_correct; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_divimm_correct:
  forall n r1 r2 v,
  Val.divs rs#r1 rs#r2 = Some v ->
  rs#r2 = Vint n ->
  let (op, args) := make_divimm n r1 r2 in
  exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w.
Proof.
  intros; unfold make_divimm.
  destruct (Int.is_power2 n) eqn:?.
  destruct (Int.ltu i (Int.repr 31)) eqn:?.
  exists v; split; auto. simpl. eapply Val.divs_pow2; eauto. congruence.
  exists v; auto.
  exists v; auto.
Qed.

Lemma make_divuimm_correct:
  forall n r1 r2 v,
  Val.divu rs#r1 rs#r2 = Some v ->
  rs#r2 = Vint n ->
  let (op, args) := make_divuimm n r1 r2 in
  exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w.
Proof.
  intros; unfold make_divuimm.
  destruct (Int.is_power2 n) eqn:?.
  replace v with (Val.shru rs#r1 (Vint i)).
  eapply make_shruimm_correct; eauto.
  eapply Val.divu_pow2; eauto. congruence.
  exists v; auto.
Qed.

Lemma make_moduimm_correct:
  forall n r1 r2 v,
  Val.modu rs#r1 rs#r2 = Some v ->
  rs#r2 = Vint n ->
  let (op, args) := make_moduimm n r1 r2 in
  exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w.
Proof.
  intros; unfold make_moduimm.
  destruct (Int.is_power2 n) eqn:?.
  exists v; split; auto. simpl. decEq. eapply Val.modu_pow2; eauto. congruence.
  exists v; auto.
Qed.

Lemma make_andimm_correct:
  forall n r,
  let (op, args) := make_andimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.and rs#r (Vint n)) v.
Proof.
  intros; unfold make_andimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (Vint Int.zero); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.mone; intros.
  subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_mone; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_orimm_correct:
  forall n r,
  let (op, args) := make_orimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.or rs#r (Vint n)) v.
Proof.
  intros; unfold make_orimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.mone; intros.
  subst n. exists (Vint Int.mone); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_mone; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_xorimm_correct:
  forall n r,
  let (op, args) := make_xorimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.xor rs#r (Vint n)) v.
Proof.
  intros; unfold make_xorimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.xor_zero; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma op_strength_reduction_correct:
  forall op args vl v,
  vl = approx_regs app args ->
  eval_operation ge sp op rs##args m = Some v ->
  let (op', args') := op_strength_reduction op args vl in
  exists w, eval_operation ge sp op' rs##args' m = Some w /\ Val.lessdef v w.
Proof.
  intros until v; unfold op_strength_reduction;
  case (op_strength_reduction_match op args vl); simpl; intros.
(* sub *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. rewrite Val.sub_add_opp. apply make_addimm_correct; auto.
(* mul *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_mulimm_correct; auto.
(* divs *)
  assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto.
  apply make_divimm_correct; auto.
(* divu *)
  assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto.
  apply make_divuimm_correct; auto.
(* modu *)
  assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto.
  apply make_moduimm_correct; auto.
(* and *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_andimm_correct; auto.
(* or *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_orimm_correct; auto.
(* xor *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_xorimm_correct; auto.
(* shl *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_shlimm_correct; auto.
(* shr *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_shrimm_correct; auto.
(* shru *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_shruimm_correct; auto.
(* lea *)
  generalize (addr_strength_reduction_correct addr args0 vl0 H).
  destruct (addr_strength_reduction addr args0 vl0) as [addr' args'].
  intro EQ. exists v; split; auto. simpl. congruence.
(* cond *)
  generalize (cond_strength_reduction_correct c args0 vl0 H).
  destruct (cond_strength_reduction c args0 vl0) as [c' args']; intros.
  rewrite <- H1 in H0; auto. econstructor; split; eauto.
(* default *)
  exists v; auto.
Qed.

End STRENGTH_REDUCTION.

End ANALYSIS.