From iris.algebra Require Import gmap auth agree gset coPset excl csum.
From Perennial.base_logic.lib Require Export fancy_updates.
From stdpp Require Export namespaces.
From Perennial.base_logic.lib Require Import wsat invariants ae_invariants saved_prop.
From Perennial.Helpers Require Import Qextra.
From iris.algebra Require Import gmap.
From iris.proofmode Require Import tactics.
From Perennial.program_logic Require Export step_fupd_extra crash_weakestpre ae_invariants_mutable later_res private_invariants.
From iris.prelude Require Import options.
Set Default Proof Using "Type".
Import uPred.

Inductive staged_inv_status :=
| inuse : Qp → Qp → staged_inv_status
| canceled : Qp → staged_inv_status
| idle.

Global Instance staged_inv_status_inhabited : Inhabited staged_inv_status.
Proof. econstructor. apply idle. Qed.

Canonical Structure staged_inv_statusO := leibnizO staged_inv_status.

Class stagedG (Σ : gFunctors) : Set := WsatG {
  staging_saved_inG :> savedPropG Σ;
  staging_auth_inG :> inG Σ (authR (optionUR (exclR (prodO gnameO gnameO))));
  staging_status_inG :> inG Σ (authR (optionUR (exclR staged_inv_statusO)));
  staging_shot_inG :> inG Σ (csumR (fracR) (agreeR unitO));
}.

Definition stagedΣ : gFunctors :=
  #[GFunctor (csumR fracR (agreeR unitO));
   GFunctor (authR (optionUR (exclR (prodO gnameO gnameO))));
   GFunctor (authR (optionUR (exclR staged_inv_statusO)));
   savedPropΣ].

#[global]
Instance subG_stagedG {Σ} : subG stagedΣ Σ → stagedG Σ.
Proof. solve_inG. Qed.

Definition staged_pending `{stagedG Σ} (q: Qp) (γ: gname) : iProp Σ :=
  own γ (Cinl q).
Definition staged_done `{stagedG Σ} (γ: gname) : iProp Σ :=
  own γ (Cinr (to_agree ())).

(* This is the modality guarding the crash condition in a wpc *)
Definition wpc_crash_modality `{!irisGS Λ Σ, !crashGS Σ} E1 mj Φc :=
  ((∀ g1 ns D κs,
       let E2 :=  ⊤ ∖ D in
       global_state_interp g1 ns mj D κs -∗ C -∗
          £ (num_laters_per_step ns) -∗
     ||={E1|E2,∅|∅}=> ||▷=>^(num_laters_per_step ns) ||={∅|∅,E1|E2}=> global_state_interp g1 ns mj D κs ∗ Φc))%I.

Definition wpc_value_modality `{!irisGS Λ Σ, !crashGS Σ} E1 mj Φc :=
  ((∀ q g1 ns D κs,
       let E2 :=  ⊤ ∖ D in
       global_state_interp g1 ns mj D κs -∗ NC q -∗
     ||={E1|E2,E1|E2}=> global_state_interp g1 ns mj D κs ∗ Φc ∗ NC q))%I.

Section def.
Context `{IRISG: !irisGS Λ Σ, !crashGS Σ}.
Context `{!pri_invG IRISG}.
Context `{!later_tokG IRISG}.
Context `{!stagedG Σ}.

(*
Definition staged_inv_cancel_pre E mj Pc : iProp Σ :=
  ∃ Einv mj_ishare mj_ikeep γ γfinish γstatus,
    ⌜ set_infinite Einv ⌝ ∗
    ⌜ 1 < mj + mj_ikeep ⌝%Qp ∗
    ⌜ (mj_ikeep + mj_ishare = /2)%Qp ⌝ ∗
    later_tok ∗
    staged_pending 1 γfinish ∗
    pri_inv_tok mj_ikeep Einv ∗
    pri_inv Einv (staged_inv_inner E Einv mj mj_ishare γ γfinish γstatus Pc).
*)

Definition staged_inv_inner_pre
           (staged_inv_inner : coPset -d> coPset -d> Qp -d> Qp -d> gname -d> gname
                              -d> gname -d> iPropO Σ -d> iPropO Σ) :
           coPset -d> coPset -d> Qp -d> Qp -d> gname -d> gname -d> gname -d> iPropO Σ -d> iPropO Σ :=
          λ E1 E2 mj mj_ishare (γsaved γfinished γstatus: gname) (P: iProp Σ) ,
  ((∃ γprop_stored γprop_remainder (stat: staged_inv_status) Ps Pr,
             own γsaved (● Excl' (γprop_stored, γprop_remainder)) ∗
             saved_prop_own γprop_stored DfracDiscarded Ps ∗
             saved_prop_own γprop_remainder DfracDiscarded Pr ∗
             own γstatus (● Excl' stat) ∗
             pri_inv_tok mj_ishare E2 ∗
             ((match stat with
              | inuse mj_wp mj_ushare => (⌜ (/2) < mj_wp ∧ mj_wp ≤ /2 + mj_ushare ∧ mj_wp ≤ mj ⌝%Qp ∗ Ps ∗ pri_inv_tok mj_ushare E2 ∗ □ (Ps -∗ wpc_crash_modality E1 mj_wp (Pr ∗ P)))
              | canceled mj' => (⌜ (/2) < mj' ≤ mj  ⌝%Qp ∗
                                ∃ E1' Einv mj_ishare mj_ikeep γ γfinish γstatus,
                                  ⌜ E1' ⊆ E1 ⌝ ∗
                                  ⌜ set_infinite Einv ⌝ ∗
                                  ⌜ 1 < mj' + mj_ikeep ⌝%Qp ∗
                                  ⌜ (mj_ikeep + mj_ishare = /2)%Qp ⌝ ∗
                                  later_tok ∗
                                  staged_pending 1 γfinish ∗
                                  pri_inv_tok mj_ikeep Einv ∗
                                  pri_inv Einv (staged_inv_inner E1' Einv mj' mj_ishare γ γfinish γstatus P)) ∨
                                  staged_done γfinished
              | idle => (Ps ∧ (C ==∗ P ∗ Pr))
              end)
              ∨
             (Pr ∗ C ∗ (P ∨ staged_done γfinished)))))%I.

Local Instance staged_inv_inner_pre_contractive : Contractive (staged_inv_inner_pre).
Proof.
  rewrite /staged_inv_inner_pre => n pre1 pre2 Hequiv ????????.
  do 15 (f_contractive || f_equiv).
  destruct a1.
  - repeat (f_contractive || f_equiv).
  - do 25 (f_contractive || f_equiv).
    eapply Hequiv.
  - repeat (f_contractive || f_equiv).
Qed.

Definition staged_inv_inner := fixpoint (staged_inv_inner_pre).

Lemma staged_inv_inner_unfold  E1 E2 mj1 mj2 γ1 γ2 γ3 P :
      staged_inv_inner E1 E2 mj1 mj2 γ1 γ2 γ3 P ⊣⊢
      staged_inv_inner_pre staged_inv_inner E1 E2 mj1 mj2 γ1 γ2 γ3 P.
Proof. apply (fixpoint_unfold staged_inv_inner_pre). Qed.

Definition staged_inv E1 E2 (γsaved γfinished γstatus: gname) (P: iProp Σ) : iProp Σ :=
  (∃ mj mj_ishare, ⌜ /2 < mj ⌝%Qp ∗ pri_inv E2 (staged_inv_inner E1 E2 mj mj_ishare γsaved γfinished γstatus P)).

Definition staged_inv_cancel E mj0 Pc : iProp Σ :=
  ∃ mj Einv mj_ishare mj_ikeep γ γfinish γstatus,
    ⌜ /2 < mj ≤ mj0 ⌝%Qp ∗
    ⌜ set_infinite Einv ⌝ ∗
    ⌜ 1 < mj + mj_ikeep ⌝%Qp ∗
    ⌜ (mj_ikeep + mj_ishare = /2)%Qp ⌝ ∗
    later_tok ∗
    staged_pending 1 γfinish ∗
    pri_inv_tok mj_ikeep Einv ∗
    pri_inv Einv (staged_inv_inner E Einv mj mj_ishare γ γfinish γstatus Pc).

Definition staged_value_idle E1 (Ps Pr: iProp Σ) P : iProp Σ :=
  (∃ E2 γsaved γfinished γstatus γprop γprop',
      own γsaved (◯ Excl' (γprop, γprop')) ∗
      own γstatus (◯ Excl' idle) ∗
          saved_prop_own γprop DfracDiscarded Ps ∗
          saved_prop_own γprop' DfracDiscarded Pr ∗
          later_tok ∗
          pri_inv_tok (/2)%Qp E2 ∗
          staged_inv E1 E2 γsaved γfinished γstatus P)%I.

Definition staged_value E Ps P : iProp Σ := staged_value_idle E Ps True%I P.

End def.

Section inv.
Context `{IRISG: !irisGS Λ Σ, !generationGS Λ Σ}.
Context `{PRI: !pri_invG IRISG}.
Context `{!later_tokG IRISG}.
Context `{!stagedG Σ}.
Implicit Types i : positive.
Implicit Types N : namespace.
Implicit Types P Q R : iProp Σ.

(* TODO: this is annoying but true *)
(*
Global Instance staged_contractive  E γ γ' : Contractive (staged_inv E γ γ').
Proof.
  rewrite /staged_inv=> n ?? ?.
  rewrite pri_inv_full_eq /pri_inv_full_def.
  f_equiv => ?.
  rewrite pri_inv_eq /pri_inv_def.
  do 4 f_equiv.
Qed.

Global Instance staged_ne N k E E' γ γ': NonExpansive (staged_inv N k E E' γ γ').
Proof.
  rewrite /staged_inv=> n ?? ?.
  repeat (apply step_fupdN_ne || f_contractive || f_equiv); eauto using dist_le.
Qed.

Global Instance staged_proper N k E E' γ γ' : Proper ((⊣⊢) ==> (⊣⊢)) (staged_inv N k E E' γ γ').
Proof. apply ne_proper, _. Qed.
*)

Global Instance staged_persistent E1 E2 γ1 γ2 γ3 P : Persistent (staged_inv E1 E2 γ1 γ2 γ3 P).
Proof. rewrite /staged_inv. apply _. Qed.

Lemma pending_done q γ: staged_pending q γ -∗ staged_done γ -∗ False.
Proof.
  rewrite /staged_pending/staged_done.
  iIntros "H H'".
  { by iDestruct (own_valid_2 with "H H'") as %?. }
Qed.

Lemma pending_upd_done γ: staged_pending 1%Qp γ ==∗ staged_done γ.
Proof.
  rewrite /staged_pending/staged_done.
  iIntros "H". iMod (own_update with "H") as "$".
  { by apply cmra_update_exclusive. }
  done.
Qed.

Lemma pending_alloc:
  ⊢ |==> ∃ γ, staged_pending 1 γ.
Proof.
  iApply (own_alloc (Cinl 1%Qp)).
  { rewrite //=. }
Qed.

Lemma pending_split γ:
  staged_pending 1 γ ⊢ staged_pending (1/2)%Qp γ ∗ staged_pending (1/2)%Qp γ.
Proof. by rewrite /staged_pending -own_op -Cinl_op frac_op Qp.div_2. Qed.

Lemma pending_split34 γ:
  staged_pending 1 γ ⊢ staged_pending (3/4)%Qp γ ∗ staged_pending (1/4)%Qp γ.
Proof. by rewrite /staged_pending -own_op -Cinl_op frac_op Qp.three_quarter_quarter. Qed.

Lemma pending_join γ:
 staged_pending (1/2)%Qp γ ∗ staged_pending (1/2)%Qp γ ⊢  staged_pending 1 γ.
Proof. by rewrite /staged_pending -own_op -Cinl_op frac_op Qp.div_2. Qed.

Lemma pending_join34 γ:
 staged_pending (3/4)%Qp γ ∗ staged_pending (1/4)%Qp γ ⊢  staged_pending 1 γ.
Proof. by rewrite /staged_pending -own_op -Cinl_op frac_op Qp.three_quarter_quarter. Qed.

Lemma pending34_pending34 γ:
 staged_pending (3/4)%Qp γ -∗ staged_pending (3/4)%Qp γ -∗ False.
Proof.
  rewrite /staged_pending.
  iIntros "H H'".
  { by iDestruct (own_valid_2 with "H H'") as %?. }
Qed.

Lemma pending_pending γ:
 staged_pending 1%Qp γ -∗ staged_pending 1%Qp γ -∗ False.
Proof.
  rewrite /staged_pending.
  iIntros "H H'".
  { by iDestruct (own_valid_2 with "H H'") as %?. }
Qed.

(* TODO : *)
(*
Lemma staged_inv_iff E i γ γ' P Q :
  ▷ □ (P ↔ Q) -∗
  staged_inv E i γ γ' P -∗
  staged_inv E i γ γ' Q.
Proof.
  iIntros "#HPQ". iApply inv_iff. iNext. iAlways. iSplit.
  - iIntros "H". iDestruct "H" as (?? P0 P0') "(?&?&?&#HP0&Hcase)". iExists _, _, P0, P0'. iFrame.
    iAlways. iIntros. iSpecialize ("HP0" with "[$] [$]").
    iApply (step_fupdN_inner_wand' with "HP0"); eauto.
    iIntros "(?&$)". by iApply "HPQ".
  - iIntros "H". iDestruct "H" as (?? P0 P0') "(?&?&?&#HP0&Hcase)". iExists _, _, P0, P0'. iFrame.
    iAlways. iIntros. iSpecialize ("HP0" with "[$] [$]").
    iApply (step_fupdN_inner_wand' with "HP0"); eauto.
    iIntros "(?&$)". by iApply "HPQ".
Qed.
*)

Lemma wpc_crash_modality_intro_C E mj P :
  (C -∗ wpc_crash_modality E mj P) -∗
  wpc_crash_modality E mj P.
Proof.
  iIntros "H". rewrite /wpc_crash_modality.
  iIntros. iApply ("H" with "[$] [$] [$] [$]").
Qed.

Lemma wpc_crash_modality_strong_wand E1 E2 mj1 mj2 P Q :
  E1 ⊆ E2 →
  (/2 < mj1 ≤ mj2)%Qp →
  wpc_crash_modality E1 mj1 P -∗
  (P ={E2}=∗ Q) -∗
  wpc_crash_modality E2 mj2 Q.
Proof using PRI.
  iIntros (??) "Hwpc Hwand".
  rewrite /wpc_crash_modality.
  iIntros (g1 ns D κs) "Hg #C Hlc".
  iApply (step_fupd2N_inner_fupd2).
  iDestruct (pri_inv_tok_global_le_acc with "[//] Hg") as "(Hg&Hg_clo)".
  iSpecialize ("Hwpc" with "[$] [$] [$]").
  iApply (step_fupd2N_inner_wand with "Hwpc"); auto.
  iIntros "(Hg&HP)". iDestruct ("Hg_clo" with "[$Hg]") as "$".
  by iMod ("Hwand" with "[$]") as "$".
Qed.

Lemma wpc0_modality_postcondition_cancel_atomic s mj E e Φ Φc `{!Atomic StronglyAtomic e}:
  (wpc0 s mj E e Φ Φc) -∗
  (wpc0 s mj E e (λ v, wpc_crash_modality E mj Φc ∧ (wpc_value_modality E mj (Φ v))) Φc).
Proof.
  iIntros "H".
  rewrite ?wpc0_unfold. rewrite /wpc_pre.
  iSplit; last first.
  { iDestruct "H" as "(_&H)". eauto. }
  destruct (to_val e).
  - iIntros (q g1 ns D κs) "Hg HNC".
    iFrame. iModIntro.
    iSplit.
    { iDestruct "H" as "(_&H)".
      iIntros (????) "Hg HC Hlc".
      iSpecialize ("H" with "[$] [$] [$]").
      iApply (step_fupd2N_inner_wand with "H"); auto.
    }
    { iDestruct "H" as "(H&_)".
      rewrite /wpc_value_modality. iIntros.
      iSpecialize ("H" with "[$] [$]").
      iMod (fupd2_mask_subseteq E (⊤ ∖ _)) as "Hclo".
      { auto. }
      { reflexivity. }
      iMod "H" as "($&$&$)". iMod "Hclo"; eauto. }
  - iIntros.
    iDestruct "H" as "(H&_)".
    iMod ("H" with "[$] [$] [$] [$]") as "H". iModIntro.
    simpl. iMod "H". iModIntro. iNext. iMod "H". iModIntro.
    iApply (step_fupd2N_wand with "H").
    iIntros "($&H)".
    iIntros.
    iMod ("H" with "[//]") as "($&$&H&$)".
    iModIntro.
    rewrite /Atomic/= in Atomic0.
    edestruct (Atomic0) as (v&Hval); eauto.
    rewrite Hval. rewrite ?wpc0_unfold /wpc_pre.
    rewrite Hval. iSplit; last first.
    { iDestruct "H" as "(_&H)". eauto. }
    iIntros. iModIntro. iFrame.
    iSplit.
    { iDestruct "H" as "(_&H)".
      iIntros (????) "Hg HC Hlc".
      iSpecialize ("H" with "[$] [$] [$]").
      iApply (step_fupd2N_inner_wand with "H"); auto.
    }
    { iDestruct "H" as "(H&_)".
      rewrite /wpc_value_modality. iIntros.
      iSpecialize ("H" with "[$] [$]").
      iMod (fupd2_mask_subseteq E (⊤ ∖ _)) as "Hclo".
      { auto. }
      { reflexivity. }
      iMod "H" as "($&$&$)". iMod "Hclo"; eauto. }
Qed.

Lemma wpc0_modality_postcondition_cancel s mj E e Φ Φc :
  (wpc0 s mj E e Φ Φc) -∗
  (wpc0 s mj E e (λ v, wpc_crash_modality ⊤ mj Φc ∧ (wpc_value_modality ⊤ mj (Φ v))) Φc).
Proof.
  iIntros "H".
  iLöb as "IH" forall (e E).
  rewrite ?wpc0_unfold. rewrite /wpc_pre.
  iSplit; last first.
  { iDestruct "H" as "(_&H)". eauto. }
  destruct (to_val e).
  - iIntros (q g1 ns D κs) "Hg HNC".
    iFrame. iModIntro.
    iSplit.
    { iDestruct "H" as "(_&H)".
      iIntros (????) "Hg HC Hlc".
      iSpecialize ("H" with "[$] [$] [$]").
      iApply (step_fupd2N_inner_wand with "H"); auto.
    }
    { iDestruct "H" as "(H&_)".
      rewrite /wpc_value_modality. iIntros.
      iSpecialize ("H" with "[$] [$]").
      iMod (fupd2_mask_subseteq E (⊤ ∖ _)) as "Hclo".
      { auto. }
      { reflexivity. }
      iMod "H" as "($&$&$)". iMod "Hclo"; eauto. }
  - iIntros.
    iDestruct "H" as "(H&_)".
    iMod ("H" with "[$] [$] [$] [$]") as "H". iModIntro.
    simpl. iMod "H". iModIntro. iNext. iMod "H". iModIntro.
    iApply (step_fupd2N_wand with "H").
    iIntros "($&H)".
    iIntros.
    iMod ("H" with "[//]") as "($&$&H&$)".
    iModIntro. by iApply "IH".
Qed.

Lemma wpc_crash_modality_intro E1 mj P :
  P -∗ wpc_crash_modality E1 mj P.
Proof.
  iIntros "H".
  rewrite /wpc_crash_modality.
  iIntros (g1 ns D κs) "Hg #C Hlc".
  iApply (step_fupd2N_inner_later); auto.
  iNext. iFrame.
Qed.

Lemma wpc_crash_modality_wand E1 mj P Q :
  wpc_crash_modality E1 mj P -∗
  (P ={E1}=∗ Q) -∗
  wpc_crash_modality E1 mj Q.
Proof.
  iIntros "Hwpc Hwand".
  rewrite /wpc_crash_modality.
  iIntros (g1 ns D κs) "Hg #C Hlc".
  iApply (step_fupd2N_inner_fupd2).
  iSpecialize ("Hwpc" with "[$] [$] [$]").
  iApply (step_fupd2N_inner_wand with "Hwpc"); auto.
  iIntros "($&HP)". by iMod ("Hwand" with "[$]") as "$".
Qed.

Lemma wpc_crash_modality_combine_cred E1 mj P1 P2 :
  later_tok -∗
  ▷ wpc_crash_modality E1 mj P1 -∗
  ▷ wpc_crash_modality E1 mj P2 -∗
  wpc_crash_modality E1 mj (£2 ∗ P1 ∗ P2).
Proof.
  iIntros "Htok H1 H2".
  rewrite /wpc_crash_modality.
  iIntros (g1 ns D κs) "Hg #C Hlc".
  iMod (later_tok_decr with "[$]") as (ns' Hle) "Hg".
  iApply (step_fupd2N_inner_fupd2).
  iApply (step_fupd2N_inner_le).
  { apply (num_laters_per_step_exp ns'). lia. }
  iMod (fupd2_mask_subseteq ∅ ∅) as "Hclo'"; [set_solver+..|].
  iEval (simpl).
  do 2 (iModIntro; iModIntro; iNext).
  iMod "Hclo'".
  iApply step_fupd2N_inner_add.
  iDestruct (lc_weaken with "Hlc") as "Hlc".
  { apply (num_laters_per_step_exp ns'). lia. }
  iDestruct "Hlc" as "[[Hlc1 Hlc2] Hlc3]".
  iSpecialize ("H1" with "[$] [$] [$]").
  iApply (step_fupd2N_inner_wand with "H1"); auto.
  iIntros "(Hg&HP1)".
  iSpecialize ("H2" with "[$] [$] [$]").
  iApply (step_fupd2N_inner_wand with "H2"); auto.
  iIntros "(Hg&$)". iFrame.
  iMod (global_state_interp_le with "[$]") as "$"; auto.
  lia.
Qed.

Lemma wpc_crash_modality_combine E1 mj P1 P2 :
  later_tok -∗
  ▷ wpc_crash_modality E1 mj P1 -∗
  ▷ wpc_crash_modality E1 mj P2 -∗
  wpc_crash_modality E1 mj (P1 ∗ P2).
Proof.
  iIntros.
  iApply (wpc_crash_modality_wand with "[-]").
  { iApply (wpc_crash_modality_combine_cred with "[$] [$] [$]"). }
  by iIntros "(?&$&$)".
Qed.

Lemma wpc_crash_modality_split E Einv mj1 mj2 P1 P2 :
  (/2 < mj1 < mj2)%Qp →
  later_tok -∗
  later_tok -∗
  pri_inv_tok 1%Qp Einv -∗
  wpc_crash_modality E mj1 (P1 ∗ P2) -∗
  ||={∅|∅, ∅|∅}=> wpc_crash_modality E mj2 P1 ∗ wpc_crash_modality E mj2 P2.
Proof using stagedG0.
  destruct (decide (mj2 ≤ 1)%Qp) as [Hle|Hnle]; last first.
  { iIntros. iModIntro.
    iSplitL.
    - iIntros (????) "Hg HC".
      iDestruct (pri_inv_tok_global_valid with "[$]") as %(?&?).
      exfalso. naive_solver.
    - iIntros (????) "Hg HC".
      iDestruct (pri_inv_tok_global_valid with "[$]") as %(?&?).
      exfalso. naive_solver.
  }
  iIntros (Hlt) "Hltok Hltok2 H".
  iIntros "Hg".
  destruct (Qp_plus_split_alt mj1 mj2) as (qa&qb&Hle1&Hlt2&Hle3); auto.
  rewrite -Hle1.
  iDestruct (pri_inv_tok_split with "H") as "(Hqa&Hqb)".
  iDestruct (pri_inv_tok_split with "Hqa") as "(Hqa1&Hqa2)".
  iMod (pending_alloc) as (γ1) "H1".
  iMod (pending_alloc) as (γ2) "H2".
  iDestruct (pri_inv_tok_infinite with "Hqb") as %Hinf.
  iMod (pri_inv_alloc Einv _ _
                      (pri_inv_tok qb Einv ∗ (wpc_crash_modality E mj1 (P1 ∗ P2) ∨
                                              ((P1 ∨ staged_done γ1) ∗ (P2 ∨ staged_done γ2)))) with "[$Hqb $Hg]")
  as "#Hinv"; first done.
  iModIntro.
  iSplitL "Hltok Hqa1 H1".
  {
    rewrite /wpc_crash_modality.
    iIntros (????) "Hg #HC Hlc".
    iMod (later_tok_decr with "[$]") as (ns' Hle') "Hg".
    iApply (step_fupd2N_inner_fupd2).
    iApply (step_fupd2N_inner_le _ (S (num_laters_per_step ns'))).
    { apply Nat.le_succ_l. apply (num_laters_per_step_lt). lia. }
    simpl.
    iDestruct (pri_inv_tok_disj with "[$]") as %[Hdisj|Hval]; last first.
    { exfalso. apply Qp.lt_nge in Hlt2. revert Hval. rewrite frac_valid.
      intros HleX. apply Hlt2. etransitivity; last eassumption.
      apply Qp.add_le_mono_r. auto. }
    iMod (pri_inv_acc with "Hinv") as "(Hinner&Hclo)".
    { set_solver. }
    iMod (fupd2_mask_subseteq ∅ ∅) as "Hclo'"; [set_solver+..|].
    iModIntro. iModIntro. iNext. iMod "Hclo'".
    iDestruct "Hinner" as "(Htok&Hcases)".
    iDestruct "Hcases" as "[Hunrun|Hrun]".
    {
      iDestruct (pri_inv_tok_join with "Hqa1 Htok") as "Hitok'".
      iDestruct (pri_inv_tok_le_acc mj1 with "[$]") as "(Hitok&Hitok_clo)".
      { auto. }
      iDestruct (pri_inv_tok_global_le_acc _ _ _ mj1 with "[] Hg") as "(Hg&Hg_clo)".
      { iPureIntro. split; first naive_solver.
        apply Qp.lt_le_incl; naive_solver. }
      iMod (pri_inv_tok_disable with "[$Hg $Hitok]") as "Hg".
      replace (⊤ ∖ D ∖ Einv) with (⊤ ∖ (Einv ∪ D)) by set_solver.
      iSpecialize ("Hunrun" with "[$] [$] [Hlc]").
      {
        iApply (lc_weaken with "Hlc").
        {  assert (Hlt': ns' < ns) by lia.
           apply num_laters_per_step_le in Hlt'. lia. }
      }
      iMod "Hunrun".  iModIntro. iApply (step_fupd2N_wand with "Hunrun").
      iIntros "Hunrun". iMod "Hunrun" as "(Hg&HP1&HP2)".
      iMod (pending_upd_done with "H1") as "Hdone".
      iMod (pri_inv_tok_enable with "[$Hg //]") as "(Hitok&Hg)".
      iDestruct ("Hitok_clo" with "[$]") as "Hitok".
      iDestruct (pri_inv_tok_split with "[$]") as "(Hitok1&Hitok2)".
      iMod ("Hclo" with "[Hitok2 HP2 Hdone]").
      { iFrame. iNext. iRight. iFrame. }
      iModIntro.
      iDestruct ("Hg_clo" with "[$]") as "Hg_clo".
      iMod (global_state_interp_le with "[$]") as "$".
      { lia. }
      eauto.
    }
    iDestruct "Hrun" as "(Hrun1&Hrun2)".
    iDestruct "Hrun1" as "[HP1|Hfalse]"; last first.
    { iDestruct (pending_done with "[$] [$]") as %[]. }
    iMod (pending_upd_done with "H1") as "Hdone".
    iMod ("Hclo" with "[Hdone Hrun2 Htok]").
    { iFrame. iRight. iNext. iFrame. }

    iApply (step_fupd2N_inner_later); auto. iModIntro.
    iMod (global_state_interp_le with "[$]") as "$".
    { lia. }
    iFrame. eauto.
  }
  {
    rewrite /wpc_crash_modality.
    iIntros (????) "Hg #HC Hlc".
    iMod (later_tok_decr with "[$]") as (ns' Hle') "Hg".
    iApply (step_fupd2N_inner_fupd2).
    iApply (step_fupd2N_inner_le _ (S (num_laters_per_step ns'))).
    { apply Nat.le_succ_l. apply (num_laters_per_step_lt). lia. }
    simpl.
    iDestruct (pri_inv_tok_disj with "[$]") as %[Hdisj|Hval]; last first.
    { exfalso. apply Qp.lt_nge in Hlt2. revert Hval. rewrite frac_valid.
      intros HleX. apply Hlt2. etransitivity; last eassumption.
      apply Qp.add_le_mono_r. auto. }
    iMod (pri_inv_acc with "Hinv") as "(Hinner&Hclo)".
    { set_solver. }
    iMod (fupd2_mask_subseteq ∅ ∅) as "Hclo'"; [set_solver+..|].
    iModIntro. iModIntro. iNext. iMod "Hclo'".
    iDestruct "Hinner" as "(Htok&Hcases)".
    iDestruct "Hcases" as "[Hunrun|Hrun]".
    {
      iDestruct (pri_inv_tok_join with "Hqa2 Htok") as "Hitok'".
      iDestruct (pri_inv_tok_le_acc mj1 with "[$]") as "(Hitok&Hitok_clo)".
      { auto. }
      iDestruct (pri_inv_tok_global_le_acc _ _ _ mj1 with "[] Hg") as "(Hg&Hg_clo)".
      { iPureIntro. split; first naive_solver.
        apply Qp.lt_le_incl; naive_solver. }
      iMod (pri_inv_tok_disable with "[$Hg $Hitok]") as "Hg".
      replace (⊤ ∖ D ∖ Einv) with (⊤ ∖ (Einv ∪ D)) by set_solver.
      iSpecialize ("Hunrun" with "[$] [$] [Hlc]").
      {
        iApply (lc_weaken with "Hlc").
        {  assert (Hlt': ns' < ns) by lia.
           apply num_laters_per_step_le in Hlt'. lia. }
      }
      iMod "Hunrun".  iModIntro. iApply (step_fupd2N_wand with "Hunrun").
      iIntros "Hunrun". iMod "Hunrun" as "(Hg&HP1&HP2)".
      iMod (pending_upd_done with "H2") as "Hdone".
      iMod (pri_inv_tok_enable with "[$Hg //]") as "(Hitok&Hg)".
      iDestruct ("Hitok_clo" with "[$]") as "Hitok".
      iDestruct (pri_inv_tok_split with "[$]") as "(Hitok1&Hitok2)".
      iMod ("Hclo" with "[Hitok2 HP1 Hdone]").
      { iFrame. iNext. iRight. iFrame. }
      iModIntro.
      iDestruct ("Hg_clo" with "[$]") as "Hg_clo".
      iMod (global_state_interp_le with "[$]") as "$".
      { lia. }
      eauto.
    }
    iDestruct "Hrun" as "(Hrun1&Hrun2)".
    iDestruct "Hrun2" as "[HP2|Hfalse]"; last first.
    { iDestruct (pending_done with "[$] [$]") as %[]. }
    iMod (pending_upd_done with "H2") as "Hdone".
    iMod ("Hclo" with "[Hdone Hrun1 Htok]").
    { iFrame. iRight. iNext. iFrame. }

    iApply (step_fupd2N_inner_later); auto. iModIntro.
    iMod (global_state_interp_le with "[$]") as "$".
    { lia. }
    iFrame. eauto.
  }
Qed.

End inv.


(*
 * Copyright (c) 2017-present,
 * Programming Research Laboratory (ROPAS), Seoul National University, Korea
 * This software is distributed under the term of the BSD-3 clause license.
 *)
(** * Eval semantics of expression.  *)

Set Implicit Arguments.

Require Import String ZArith Morphisms.
Require Import Monad hpattern vgtac VocabA Syn DLat DPow UserInputType.
Require Import DomBasic DomArrayBlk DomAbs DomMem SemMem.

Local Open Scope Z.
Local Open Scope sumbool.

Definition eval_const (cst : constant) : Val.t := Val.bot.

Definition eval_uop (u : unop) (v : Val.t) : Val.t := v.

Lemma eval_uop_mor (u : unop) : Proper (Val.eq ==> Val.eq) (eval_uop u).
Proof. unfold eval_uop. by intros v1 v2 Hv. Qed.

Definition is_array_loc (x : Loc.t) : bool :=
  match x with
    | Loc.Inl (VarAllocsite.Inr _, _) => true
    | _ => false
  end.

Lemma is_array_loc_mor : Proper (Loc.eq ==> eq) is_array_loc.
Proof.
unfold is_array_loc; intros x1 x2 Hx.
destruct x1, x2; [|by inversion Hx|by inversion Hx|by auto].
destruct a, a0. destruct t, t1.
- by auto.
- inversion Hx; destruct Heq as [Heq _]; by inversion Heq.
- inversion Hx; destruct Heq as [Heq _]; by inversion Heq.
- by auto.
Qed.

Definition array_loc_of_val (v : Val.t) : Val.t :=
  PowLoc.filter is_array_loc (pow_loc_of_val v).

Lemma array_loc_of_val_mor : Proper (Val.eq ==> Val.eq) array_loc_of_val.
Proof.
unfold array_loc_of_val; intros v1 v2 Hv.
apply val_of_pow_loc_mor.
apply PowLoc.SS.SF.filter_equal; [by apply is_array_loc_mor|by apply Hv].
Qed.

Definition eval_bop (b : binop) (v1 v2 : Val.t) : Val.t :=
  match b with
  | PlusPI | IndexPI =>
    Val.join (array_loc_of_val v1) (ArrayBlk.plus_offset (array_of_val v1))
  | MinusPI =>
    Val.join (array_loc_of_val v1) (ArrayBlk.minus_offset (array_of_val v1))
  | _ => Val.join v1 v2
  end.

Lemma eval_bop_mor (b : binop) :
  Proper (Val.eq ==> Val.eq ==> Val.eq) (eval_bop b).
Proof.
unfold eval_bop. intros v1 v2 Hv w1 w2 Hw; destruct b
; try by apply Val.join_eq.
- apply Val.join_eq.
  + by apply array_loc_of_val_mor.
  + by apply val_of_array_mor, ArrayBlk.plus_offset_mor, array_of_val_mor.
- apply Val.join_eq.
  + by apply array_loc_of_val_mor.
  + by apply val_of_array_mor, ArrayBlk.plus_offset_mor, array_of_val_mor.
- apply Val.join_eq.
  + by apply array_loc_of_val_mor.
  + by apply val_of_array_mor, ArrayBlk.minus_offset_mor, array_of_val_mor.
Qed.

Definition eval_string (s : string) : Val.t := Val.bot.

Definition eval_string_loc (s : string) (a : Allocsite.t) (lvs : PowLoc.t)
           : Val.t :=
  Val.join (lvs : Val.t) (ArrayBlk.make a : Val.t).

Definition deref_of_val (v : Val.t) : PowLoc.t :=
  PowLoc.join (pow_loc_of_val v) (ArrayBlk.pow_loc_of_array (array_of_val v)).

Lemma deref_of_val_mor : Proper (Val.eq ==> PowLoc.eq) deref_of_val.
Proof.
unfold deref_of_val; intros v1 v2 Hv.
apply PowLoc.join_eq.
- by apply pow_loc_of_val_mor.
- apply ArrayBlk.pow_loc_of_array_mor. by apply array_of_val_mor.
Qed.

Module Make (Import M : Monad) (MB : MemBasic M).

Module Import SemMem := SemMem.Make M MB.

Definition eval_var node x (is_global : bool) :=
  if is_global then loc_of_var (var_of_gvar x) else
    loc_of_var (var_of_lvar (InterNode.get_pid node, x)).

Fixpoint resolve_offset (mode : update_mode) (node : InterNode.t)
                    (v : Val.t) (os : offset) (m : Mem.t)
: M.m PowLoc.t :=
  match os with
  | NoOffset => ret (deref_of_val v)
  | FOffset f os' =>
    resolve_offset mode node
      (PowLoc.join
         (pow_loc_append_field (pow_loc_of_val v) f)
         (ArrayBlk.pow_loc_of_struct_w_field (array_of_val v) f))
      os' m
  | IOffset e os' =>
    do v' <- mem_lookup (deref_of_val v) m ;
    resolve_offset mode node v' os' m
  end.

Fixpoint eval (mode : update_mode) (node : InterNode.t)
         (e : exp) (m : Mem.t) : M.m Val.t :=
  match e with
  | Const c _ => ret (eval_const c)
  | Lval l _ =>
    do lv <- eval_lv mode node l m ;
    mem_lookup lv m
  | SizeOf _ _
  | SizeOfE _ _
  | SizeOfStr _ _
  | AlignOf _ _
  | AlignOfE _ _ => ret Val.bot
  | UnOp u e _ =>
    do v <- eval mode node e m ;
    ret (eval_uop u v)
  | BinOp b e1 e2 _ =>
    do v1 <- eval mode node e1 m ;
    do v2 <- eval mode node e2 m ;
    ret (eval_bop b v1 v2)
  | Question e1 e2 e3 _ =>
    do v2 <- eval mode node e2 m ;
    do v3 <- eval mode node e3 m ;
    ret (Val.join v2 v3)
  | CastE new_stride_opt e _ =>
    match new_stride_opt with
    | None => eval mode node e m
    | Some new_stride =>
      do v <- eval mode node e m ;
      let array_v := ArrayBlk.cast_array_int new_stride (array_of_val v) in
      ret (modify_array v array_v)
    end
  | AddrOf l _ =>
    do lv <- eval_lv mode node l m ;
    ret (val_of_pow_loc lv)
  | StartOf l _ =>
    do lv <- eval_lv mode node l m ;
    ret (val_of_pow_loc lv)
  end

with eval_lv (mode : update_mode) (node : InterNode.t)
             (lv : lval) (m : Mem.t) : M.m PowLoc.t :=
  match lv with
  | lval_intro lhost' ofs _ =>
    do v <-
      match lhost' with
      | VarLhost vi is_global =>
        let x := eval_var node vi is_global in
        ret ((PowLoc.singleton x) : Val.t)
      | MemLhost e => eval mode node e m
      end ;
    resolve_offset mode node v ofs m
  end.

Fixpoint eval_list (mode : update_mode) (node : InterNode.t)
         (es : list exp) (m : Mem.t) : M.m (list Val.t) :=
  match es with
    | nil => ret nil
    | e :: tl =>
      do v <- eval mode node e m;
      do tl' <- eval_list mode node tl m;
      ret (v :: tl')
  end.

Definition eval_alloc' (node : InterNode.t) : Val.t :=
  let allocsite := allocsite_of_node node in
  let pow_loc : PowLoc.t := PowLoc.singleton (loc_of_allocsite allocsite) in
  Val.join (pow_loc : Val.t) (ArrayBlk.make allocsite : Val.t).

Definition eval_alloc (mode : update_mode) (node : InterNode.t) (a : alloc)
  : Val.t :=
  match a with
    | Array e => eval_alloc' node
  end.

End Make.

Local Close Scope sumbool.
Local Close Scope Z.


(* *********************************************************************)
(*                                                                     *)
(*            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.                                  *)
(*                                                                     *)
(* *********************************************************************)
Require Import Coqlib.
Require Import Errors.
Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import MemoryExtra.
Require Import EventsExtra.
Require Import GlobalenvsExtra.
Require Import Locations.
Require Import DataType.
Require Import LAsm.
Require Import CDataTypes.
Require Import AsmExtra.
Require Clight.
Require Import Smallstep.
Require Import ClightBigstep.
Require Import Cop.
Require Import PQueueIntro.
Require Import PThreadInit.
Require Export QueueIntroGen.
Require Import PThreadInitCode.
Require Import ZArith.Zwf.
Require Import EventsExtra.
Require Import GlobalenvsExtra.
Require Import Smallstep.
Require Import Op.
Require Import Values.
Require Import MemoryExtra.
Require Import Maps.
Require Import Heap.
Require Import RefinementTactic.
Require Import AuxLemma.
Require Import LayerTemplate2.
Require Import Implementation.
Require Import SeparateCompiler.
Require Import ClightImplemExtra.
Require Import LayerDefinition.
Require Import RealParams.
Require Import CInitSpecsMPTOp.
Require Import CInitSpecsMPTCommon.
Require Import CInitSpecsMPTBit.
Require Import CInitSpecsproc.

Open Local Scope string_scope.
Open Local Scope error_monad_scope.

Module QUEUEINTROGENIMPL.
  Export QueueIntroGen.QUEUEINTROGEN.

  Lemma hprim_finite_type:
    forall
      (Q: PQUEUEINTRO.primOp -> Prop)
      (Q_dec: forall p, {Q p} + {~ Q p}),
      {forall p, Q p} + {~ forall p, Q p}.
  Proof with (try (right; eauto; fail)).
    intros.
    destruct (Q_dec PQUEUEINTRO.PAlloc)...
    destruct (Q_dec PQUEUEINTRO.PFree)...
    destruct (Q_dec PQUEUEINTRO.PSetPT)...
    destruct (Q_dec PQUEUEINTRO.PPTRead)...
    destruct (Q_dec PQUEUEINTRO.PPTResv)...
    destruct (Q_dec PQUEUEINTRO.PKCtxtNew)...
    destruct (Q_dec PQUEUEINTRO.PThreadFree)...
    destruct (Q_dec PQUEUEINTRO.PKCtxtSwitch)...
    destruct (Q_dec PQUEUEINTRO.PGetState)...
    destruct (Q_dec PQUEUEINTRO.PGetPrev)...
    destruct (Q_dec PQUEUEINTRO.PGetNext)...
    destruct (Q_dec PQUEUEINTRO.PSetState)...
    destruct (Q_dec PQUEUEINTRO.PSetPrev)...
    destruct (Q_dec PQUEUEINTRO.PSetNext)...
    destruct (Q_dec PQUEUEINTRO.PGetHead)...
    destruct (Q_dec PQUEUEINTRO.PGetTail)...
    destruct (Q_dec PQUEUEINTRO.PSetHead)...
    destruct (Q_dec PQUEUEINTRO.PSetTail)...
    destruct (Q_dec PQUEUEINTRO.PTDQInit)...
    destruct (Q_dec PQUEUEINTRO.PPTIn)...
    destruct (Q_dec PQUEUEINTRO.PPTOut)...
    destruct (Q_dec PQUEUEINTRO.PTrapIn)...
    destruct (Q_dec PQUEUEINTRO.PTrapOut)...
    destruct (Q_dec PQUEUEINTRO.PHostIn)...
    destruct (Q_dec PQUEUEINTRO.PHostOut)...
    destruct (Q_dec PQUEUEINTRO.PTrapGet)...
    destruct (Q_dec PQUEUEINTRO.PTrapRet)...
    destruct (Q_dec PQUEUEINTRO.PThreadInit)...
    left; destruct p; assumption.
  Defined.

  Section WithPrimitives.

  Context `{real_params: RealParams}.

    Notation HDATA := (PQUEUEINTRO.AbData(PgSize:=PgSize) (num_proc:=num_proc)(kern_low:=kern_low)
                                         (kern_high:=kern_high) (maxpage:=maxpage)).
    Notation LDATA := (PTHREADINIT.AbData(PgSize:=PgSize)(num_proc:=num_proc) (kern_low:=kern_low)
                                         (kern_high:=kern_high) (maxpage:=maxpage)).

    Notation Hfundef := (Asm.fundef (external_function:= PQUEUEINTRO.primOp)).
    Notation Lfundef := (Asm.fundef (external_function:= PTHREADINIT.primOp)).

    Notation funkind := (funkind (low:= PTHREADINIT.primOp) Asm.code (Clight.fundef (external_function := PTHREADINIT.primOp))).

    Definition source_implem_extfuns (p: PQUEUEINTRO.primOp): funkind :=
      match p with
        | PQUEUEINTRO.PAlloc => Code _ (AST.External PTHREADINIT.PAlloc)
        | PQUEUEINTRO.PFree => Code _ (AST.External PTHREADINIT.PFree)
        | PQUEUEINTRO.PSetPT => Code _ (AST.External PTHREADINIT.PSetPT)
        | PQUEUEINTRO.PPTRead => Code _ (AST.External PTHREADINIT.PPTRead)
        | PQUEUEINTRO.PPTResv => Code _ (AST.External PTHREADINIT.PPTResv)
        | PQUEUEINTRO.PKCtxtNew => Code _ (AST.External PTHREADINIT.PKCtxtNew)
        | PQUEUEINTRO.PThreadFree => Code _ (AST.External PTHREADINIT.PThreadFree)
        | PQUEUEINTRO.PKCtxtSwitch => Code _ (AST.External PTHREADINIT.PKCtxtSwitch)
        | PQUEUEINTRO.PGetState => Code _ (AST.External PTHREADINIT.PGetState)
        | PQUEUEINTRO.PGetPrev => Code _ (AST.External PTHREADINIT.PGetPrev)
        | PQUEUEINTRO.PGetNext => Code _ (AST.External PTHREADINIT.PGetNext)
        | PQUEUEINTRO.PSetState => Code _ (AST.External PTHREADINIT.PSetState)
        | PQUEUEINTRO.PSetPrev => Code _ (AST.External PTHREADINIT.PSetPrev)
        | PQUEUEINTRO.PSetNext => Code _ (AST.External PTHREADINIT.PSetNext)
        | PQUEUEINTRO.PGetHead => SourceFun (Clight.Internal PTHREADINITCODE.f_get_head) (AST.Internal nil)
        | PQUEUEINTRO.PGetTail => SourceFun (Clight.Internal PTHREADINITCODE.f_get_tail) (AST.Internal nil)
        | PQUEUEINTRO.PSetHead => SourceFun (Clight.Internal PTHREADINITCODE.f_set_head) (AST.Internal nil)
        | PQUEUEINTRO.PSetTail => SourceFun (Clight.Internal PTHREADINITCODE.f_set_tail) (AST.Internal nil)
        | PQUEUEINTRO.PTDQInit => SourceFun (Clight.Internal PTHREADINITCODE.f_tdq_init) (AST.Internal nil)
        | PQUEUEINTRO.PPTIn => Code _ (AST.External PTHREADINIT.PPTIn)
        | PQUEUEINTRO.PPTOut => Code _ (AST.External PTHREADINIT.PPTOut)
        | PQUEUEINTRO.PTrapIn => Code _ (AST.External PTHREADINIT.PTrapIn)
        | PQUEUEINTRO.PTrapOut => Code _ (AST.External PTHREADINIT.PTrapOut)
        | PQUEUEINTRO.PHostIn => Code _ (AST.External PTHREADINIT.PHostIn)
        | PQUEUEINTRO.PHostOut => Code _ (AST.External PTHREADINIT.PHostOut)
        | PQUEUEINTRO.PTrapGet => Code _ (AST.External PTHREADINIT.PTrapGet)
        | PQUEUEINTRO.PTrapRet => Code _ (AST.External PTHREADINIT.PTrapRet)
        | PQUEUEINTRO.PThreadInit => Code _ (AST.External PTHREADINIT.PThreadInit)
      end.

    Notation varkind := (varkind unit Ctypes.type).

    Definition source_implem_new_globs : list (ident * option (globdef funkind varkind)) :=
        (TDQPool_LOC, Some (Gvar (mkglobvar (SourceVar (tarray t_struct_TDQ (num_chan+1)) tt) ((Init_space ((num_chan+1)*8))::nil) false)))
        :: nil.

    Let NOREPET: list_norepet (TDQPool_LOC :: nil).
    Proof.
      case_eq (list_norepet_dec peq (TDQPool_LOC :: nil)); try discriminate; tauto.
    Qed.

    Definition source_implem : source_implem Asm.code unit PQUEUEINTRO.primOp (low := PTHREADINIT.primOp) (Clight.fundef (external_function := PTHREADINIT.primOp)) Ctypes.type.
    Proof.
      split.
       exact source_implem_extfuns.
       exact source_implem_new_globs.
    Defined.

    Let im : implem Asm.code unit PQUEUEINTRO.primOp (low := PTHREADINIT.primOp) := implem_of_source_implem transf_clight_fundef Cshmgen.transl_globvar source_implem.

    Notation Hprogram := (Asm.program (external_function:= PQUEUEINTRO.primOp)).
    Notation Lprogram := (Asm.program (external_function:= PTHREADINIT.primOp)).

    Let Im_get_head: Lfundef := transf_source_fun' transf_clight_fundef (source_implem_extfuns PQUEUEINTRO.PGetHead).
    Let Im_get_tail: Lfundef := transf_source_fun' transf_clight_fundef (source_implem_extfuns PQUEUEINTRO.PGetTail).
    Let Im_set_head: Lfundef := transf_source_fun' transf_clight_fundef (source_implem_extfuns PQUEUEINTRO.PSetHead).
    Let Im_set_tail: Lfundef := transf_source_fun' transf_clight_fundef (source_implem_extfuns PQUEUEINTRO.PSetTail).
    Let Im_tdq_init: Lfundef := transf_source_fun' transf_clight_fundef (source_implem_extfuns PQUEUEINTRO.PTDQInit).

    Notation new_glbl := (new_glbl (num_chan:= num_chan) TDQPool_LOC).

    Definition impl_glbl :  list (ident * option (globdef Lfundef unit)) := nil.

    (* This is basically an axiom that can be easily checked because PQUEUEINTRO.primOp is a finite type. However, in practice, generation of CertiKOS code will be very slow because compilation will have to occur twice, one for this check, and a second independently for the generation of the actual code. *)

    Lemma extfun_compilation_succeeds_dec:
      {forall p clight asmfallback,
        source_implem_extfuns p = SourceFun clight asmfallback ->
        exists asm, transf_clight_fundef clight = OK asm} +
      {~ forall p clight asmfallback,
        source_implem_extfuns p = SourceFun clight asmfallback ->
        exists asm, transf_clight_fundef clight = OK asm}.
    Proof.
      apply hprim_finite_type.
      intro.
      destruct (source_implem_extfuns p); try (left; discriminate).
      case_eq (transf_clight_fundef sf).
       left. intros. inv H0. eauto.
      intros. right. intro. exploit H0; eauto. destruct 1. congruence.
    Defined.

    Hypothesis extfun_compilation_succeeds:
      forall p clight asmfallback,
        source_implem_extfuns p = SourceFun clight asmfallback ->
        exists asm, transf_clight_fundef clight = OK asm.

    Section WithProg.

    Variable prog: Hprogram.

    Definition tprog: Lprogram := Implementation.transf_program im prog.

    Let TRANSF: QUEUEINTROGEN.transf_program (num_chan:= num_chan) Im_get_head Im_get_tail Im_set_head Im_set_tail Im_tdq_init TDQPool_LOC impl_glbl prog = OK tprog.
    Proof.
      unfold tprog.
      unfold Asm.program, Asm.fundef.
      generalize (transf_program_eq im prog).
      intros.
      rewrite <- H.
      unfold transf_program.
      simpl.
      f_equal.
      apply FunctionalExtensionality.functional_extensionality.
      destruct x; simpl.
       reflexivity.
      destruct p; reflexivity.
    Qed.

    Hypothesis prog_nonempty:
      prog_defs_names prog <> nil.

    Hypothesis prog_main_valid:
      ~ Plt' (prog_main prog) (prog_first_symbol prog).

    Hypothesis prog_first_valid:
      ~ Plt' (prog_first_symbol prog) (get_next_symbol (map fst source_implem_new_globs)).

    Let VALID_LOC: (TDQPool_LOC <> (prog_main prog)).
    Proof.
      intro.
      exploit (get_next_symbol_prop TDQPool_LOC (map fst (source_implem_new_globs))).
      simpl; tauto.
      eapply Ple_not_Plt.
      apply Ple_Ple'.
      eapply Ple'_trans.
      apply not_Plt'_Ple'.
      eassumption.
      apply not_Plt'_Ple'.
      congruence.
    Qed.

    Notation ge := (Genv.globalenv prog).
    Notation tge := (Genv.globalenv tprog).

    Let NEW_INJ:  (forall s', Genv.find_symbol ge s' <> None ->
                                     ~ In s' (map fst new_glbl)).
    Proof.
      change new_glbl with (implem_new_globs im).
      eapply new_ids_fresh.
      assumption.
    Qed.

    Let sprog : Clight.program (external_function := PTHREADINIT.primOp) := source_program_only source_implem prog.
    Let sge := Genv.globalenv sprog.

    Let tsprog_strong : {tsprog | transf_clight_program sprog = OK tsprog}.
    Proof.
      case_eq (transf_clight_program sprog); eauto.
      intros. exfalso.
      refine (_ (Implementation.compilation_succeeds
                    transf_clight_fundef
                    Cshmgen.transl_globvar
                    source_implem _ _ _
                    prog)).
      destruct 1.
      exploit (transf_clight_fundef_to_program (external_function := PTHREADINIT.primOp)); eauto.
      unfold sprog in H.
      congruence.
      assumption.
      simpl. destruct 1; try discriminate. destruct H0; try discriminate.
      unfold Cshmgen.transl_globvar. eauto.
    Qed.

    Let tsprog := let (p, _) := tsprog_strong in p.

    Let tsprog_prop : transf_clight_program sprog = OK tsprog.
    Proof.
      unfold tsprog.
      destruct tsprog_strong.
      assumption.
    Qed.

    Let tsge := Genv.globalenv tsprog.

    Lemma tdqpool_loc_prop:
      forall b0,
        Genv.find_symbol tge TDQPool_LOC = Some b0 ->
        Genv.find_symbol sge TDQPool_LOC = Some b0 /\
        Clight.type_of_global sge b0 = Some (tarray t_struct_TDQ (num_chan+1)).
    Proof.
      intros.
      refine (_ (find_new_var_prop _ _ source_implem NOREPET _ NEW_INJ
                                   TDQPool_LOC
                                   (mkglobvar (SourceVar (tarray t_struct_TDQ (num_chan+1)) tt) ((Init_space ((num_chan+1)*8))::nil) false)
                                   _ (refl_equal _) H)).
      destruct 1.
      split; auto.
      unfold Clight.type_of_global.
      unfold sge, sprog.
      rewrite H1.
      reflexivity.
      simpl; tauto.
    Qed.

    Let well_idglob_impl_glbl: Genv.well_idglob_list impl_glbl = true.
    Proof. reflexivity. Qed.

    Let TDQPool_LOC_not_in: ~ In TDQPool_LOC (prog_defs_names prog).
    Proof.
      intro. exploit Genv.find_symbol_exists_ex; eauto. destruct 1.
      assert (Genv.find_symbol ge TDQPool_LOC <> None) by congruence.
      eapply NEW_INJ; eauto.
      simpl; tauto.
    Qed.

    Lemma tprog_first_next:
      prog_first_symbol tprog = get_first_symbol (map fst source_implem_new_globs) /\
      prog_next_symbol  tprog = prog_next_symbol prog.
    Proof.
      change (get_first_symbol (map fst source_implem_new_globs)) with (implem_first_symbol im).
      unfold tprog.
      apply transf_program_first_next_symbol.
      assumption.
      assumption.
      discriminate.
    Qed.

    Lemma tprog_main_valid:
      ~ Plt' (prog_main tprog) (prog_first_symbol tprog).
    Proof.
      Opaque Plt'.
      simpl.
      destruct tprog_first_next.
      rewrite H.
      apply Ple'_not_Plt'.
      eapply Ple'_trans.
      apply first_le_next.
      discriminate.
      eapply Ple'_trans.
      apply not_Plt'_Ple'.
      eassumption.
      apply not_Plt'_Ple'.
      assumption.
    Qed.

    Lemma tprog_nonempty:
      prog_defs_names tprog <> nil.
    Proof.
      apply transf_program_nonempty.
      assumption.
    Qed.

    Context `{PageFaultHandler_LOC: ident}.

    Section WITHMEM.

      Context {mem__H} {mem__L}
              `{Hlmmh: !LayerMemoryModel HDATA mem__H}
              `{Hlmml: !LayerMemoryModel LDATA mem__L}
              `{Hlmi: !LayerMemoryInjections HDATA LDATA _ _}.

      Instance HLayer: LayerDefinition (layer_mem:= Hlmmh) HDATA PQUEUEINTRO.primOp mem__H :=
        PQUEUEINTRO.layer_def (Hnpc:=Hnpc)(PgSize:=PgSize) (num_proc:=num_proc)(HPS4:=HPS4)(Hlow:=Hlow)(Hhigh:=Hhigh)
                              (kern_low:=kern_low) (kern_high:=kern_high) (maxpage:=maxpage) (real_tcb := real_tcb)
                              (real_nps:=real_nps) (real_AT := real_AT)(real_ptp:=real_ptp)(real_pt:=real_pt)
                              (real_ptb:= real_ptb) (real_free_pt:= real_free_pt) (STACK_LOC:= STACK_LOC)
                              (num_chan:= num_chan).

      Instance LLayer: LayerDefinition (layer_mem:= Hlmml) LDATA PTHREADINIT.primOp mem__L :=
        PTHREADINIT.layer_def (Hnpc:=Hnpc)(PgSize:=PgSize) (num_proc:=num_proc)(HPS4:=HPS4)(Hlow:=Hlow)(Hhigh:=Hhigh)
                              (kern_low:=kern_low) (kern_high:=kern_high) (maxpage:=maxpage) (real_tcb := real_tcb)
                              (real_nps:=real_nps) (real_AT := real_AT)(real_ptp:=real_ptp)(real_pt:=real_pt)
                              (real_ptb:= real_ptb) (real_free_pt:= real_free_pt) (STACK_LOC:= STACK_LOC).

      Notation LLoad := (PTHREADINIT.exec_loadex (PgSize:=PgSize)(NPT_LOC:= NPT_LOC) (PageFaultHandler_LOC:= PageFaultHandler_LOC)).
      Notation LStore := (PTHREADINIT.exec_storeex (PgSize:=PgSize)(NPT_LOC:= NPT_LOC) (PageFaultHandler_LOC:= PageFaultHandler_LOC)).
      Notation HLoad := (PQUEUEINTRO.exec_loadex (PgSize:=PgSize)(NPT_LOC:= NPT_LOC) (PageFaultHandler_LOC:= PageFaultHandler_LOC)).
      Notation HStore := (PQUEUEINTRO.exec_storeex (PgSize:=PgSize)(NPT_LOC:= NPT_LOC) (PageFaultHandler_LOC:= PageFaultHandler_LOC)).

      Notation lstep := (PTHREADINIT.step (NPT_LOC:=NPT_LOC) (PageFaultHandler_LOC:= PageFaultHandler_LOC) (HPS4:= HPS4)
                                          (real_nps:= real_nps) (real_AT:= real_AT) (Hlow:= Hlow) (Hhigh:= Hhigh)
                                          (real_ptp := real_ptp) (real_pt:= real_pt) (Hnpc := Hnpc) (real_ptb:= real_ptb)
                                          (real_free_pt:= real_free_pt) (STACK_LOC:= STACK_LOC)(real_tcb:=real_tcb)).

      Notation LADT := PTHREADINIT.ADT.

      Let get_head_spec:
        forall r' b m'0 n b1 r sig,
          r' PC = Vptr b Int.zero
          -> Genv.find_funct_ptr tge b = Some (Im_get_head)
          -> Genv.find_symbol tge TDQPool_LOC = Some b1
          -> Mem.load Mint32 m'0 b1 (Int.unsigned n * 8) = Some (Vint r)
          -> 0 <= (Int.unsigned n) <= num_chan
          -> PTHREADINIT.ipt (LADT (Mem.get_abstract_data m'0)) = true
          -> PTHREADINIT.pe (LADT (Mem.get_abstract_data m'0)) = true
          -> PTHREADINIT.ihost (LADT (Mem.get_abstract_data m'0)) = true
          -> Mem.tget m'0 b1 = Some Tag_global
          -> sig = mksignature (Tint :: nil) (Some Tint)
          -> (forall b o, r' ESP = Vptr b o -> Mem.tget m'0 b = Some Tag_stack)
          -> r' ESP <> Vundef
          -> r' RA  <> Vundef
          -> Genv.find_funct_ptr ge b = Some (External PQUEUEINTRO.PGetHead)
          -> asm_invariant tge (State r' m'0)
          -> extcall_arguments r' m'0 sig (Vint n ::  nil)
          -> exists f' m0' r_,
               inject_incr (Mem.flat_inj (Mem.nextblock m'0)) f'
               /\ Memtype.Mem.inject f' m'0 m0'
               /\ Mem.nextblock m'0 <= Mem.nextblock m0'
               /\ plus lstep tge (State r' m'0) E0 (State r_ m0')
               /\ r_ # (loc_external_result sig) = (Vint r)
               /\ r_ PC = r' RA
               /\ r_ # ESP = r' # ESP
               /\ (forall l,
                     ~In (Locations.R l) Conventions1.temporaries -> ~In (Locations.R l) Conventions1.destroyed_at_call
                     -> Val.lessdef (r' (preg_of l)) (r_ (preg_of l))).
        Proof.
          intros.
          exploit tdqpool_loc_prop; eauto.
          destruct 1.
          exploit (ClightImplemExtra.bigstep_clight_to_lsem
                     PQUEUEINTRO.primOp
                     (exec_load := LLoad)
                     (exec_store := LStore)
                     (primitive_call := PTHREADINIT.primitive_call)
                     (is_primitive_call := PTHREADINIT.is_primitive_call)
                     (kernel_mode := PTHREADINIT.kernel_mode)
                  ).
          apply PTHREADINIT.exec_load_exec_loadex.
          apply PTHREADINIT.exec_store_exec_storeex.
          apply PTHREADINIT.extcall_not_primitive.
          apply PTHREADINIT.primitive_kernel_mode.
          3: eassumption.
          assumption.
          assumption.
          2: eassumption.
          5: eassumption.
          9: eassumption.
          7: reflexivity.
          intros; eapply PTHREADINITCODE.get_head_correct; eauto.
          assumption.
          assumption.
          assumption.
          assumption.
          assumption.
          unfold PTHREADINIT.kernel_mode.
          destruct (PTHREADINIT.INV (Mem.get_abstract_data m'0)).
          auto.
          destruct 1 as [? [? [? [? [? [? [? [? [? [? ?]]]]]]]]]].
          inv H21.
          eauto 11.
        Qed.

      Let get_tail_spec:
        forall r' b m'0 n b1 r sig,
          r' PC = Vptr b Int.zero
          -> Genv.find_funct_ptr tge b = Some (Im_get_tail)
          -> Genv.find_symbol tge TDQPool_LOC = Some b1
          -> Mem.load Mint32 m'0 b1 (Int.unsigned n * 8 + 4) = Some (Vint r)
          -> 0 <= (Int.unsigned n) <= num_chan
          -> PTHREADINIT.ipt (LADT (Mem.get_abstract_data m'0)) = true
          -> PTHREADINIT.pe (LADT (Mem.get_abstract_data m'0)) = true
          -> PTHREADINIT.ihost (LADT (Mem.get_abstract_data m'0)) = true
          -> Mem.tget m'0 b1 = Some Tag_global
          -> sig = mksignature (Tint :: nil) (Some Tint)
          -> (forall b o, r' ESP = Vptr b o -> Mem.tget m'0 b = Some Tag_stack)
          -> r' ESP <> Vundef
          -> r' RA  <> Vundef
          -> Genv.find_funct_ptr ge b = Some (External PQUEUEINTRO.PGetTail)
          -> asm_invariant tge (State r' m'0)
          -> extcall_arguments r' m'0 sig (Vint n ::  nil)
          -> exists f' m0' r_,
               inject_incr (Mem.flat_inj (Mem.nextblock m'0)) f'
               /\ Memtype.Mem.inject f' m'0 m0'
               /\ Mem.nextblock m'0 <= Mem.nextblock m0'
               /\ plus lstep tge (State r' m'0) E0 (State r_ m0')
               /\ r_ # (loc_external_result sig) = (Vint r)
               /\ r_ PC = r' RA
               /\ r_ # ESP = r' # ESP
               /\ (forall l,
                     ~In (Locations.R l) Conventions1.temporaries -> ~In (Locations.R l) Conventions1.destroyed_at_call
                     -> Val.lessdef (r' (preg_of l)) (r_ (preg_of l))).
        Proof.
          intros.
          exploit tdqpool_loc_prop; eauto.
          destruct 1.
          exploit (ClightImplemExtra.bigstep_clight_to_lsem
                     PQUEUEINTRO.primOp
                     (exec_load := LLoad)
                     (exec_store := LStore)
                     (primitive_call := PTHREADINIT.primitive_call)
                     (is_primitive_call := PTHREADINIT.is_primitive_call)
                     (kernel_mode := PTHREADINIT.kernel_mode)
                  ).
          apply PTHREADINIT.exec_load_exec_loadex.
          apply PTHREADINIT.exec_store_exec_storeex.
          apply PTHREADINIT.extcall_not_primitive.
          apply PTHREADINIT.primitive_kernel_mode.
          3: eassumption.
          assumption.
          assumption.
          2: eassumption.
          5: eassumption.
          9: eassumption.
          7: reflexivity.
          intros; eapply PTHREADINITCODE.get_tail_correct; eauto.
          assumption.
          assumption.
          assumption.
          assumption.
          assumption.
          unfold PTHREADINIT.kernel_mode.
          destruct (PTHREADINIT.INV (Mem.get_abstract_data m'0)).
          auto.
          destruct 1 as [? [? [? [? [? [? [? [? [? [? ?]]]]]]]]]].
          inv H21.
          eauto 11.
        Qed.

    Let set_head_spec:
      forall r' b m'0 n b0 m0 i sig,
          r' PC = Vptr b Int.zero
          -> Genv.find_funct_ptr tge b = Some (Im_set_head) (*implementation Im_setRA has type ident-> code*)
          -> Genv.find_symbol tge TDQPool_LOC = Some b0
          -> Mem.store Mint32 m'0 b0 (Int.unsigned n * 8) (Vint i) = Some m0
          -> 0 <= Int.unsigned n <= num_chan
          -> PTHREADINIT.ipt (LADT (Mem.get_abstract_data m'0)) = true
          -> PTHREADINIT.pe (LADT (Mem.get_abstract_data m'0)) = true
          -> PTHREADINIT.ihost (LADT (Mem.get_abstract_data m'0)) = true
          -> Mem.tget m'0 b0 = Some Tag_global
          -> sig = mksignature (Tint :: Tint :: nil) None
          -> (forall b o, r' ESP = Vptr b o -> Mem.tget m'0 b = Some Tag_stack)
          -> r' ESP <> Vundef
          -> r' RA  <> Vundef
          -> Genv.find_funct_ptr ge b = Some (External PQUEUEINTRO.PSetHead)
          -> asm_invariant tge (State r' m'0)
          -> extcall_arguments r' m'0 sig (Vint n :: Vint i:: nil)
          -> exists f' m0' r_,
               inject_incr (Mem.flat_inj (Mem.nextblock m0)) f'
               /\ Memtype.Mem.inject f' m0 m0'
               /\ Mem.nextblock m0 <= Mem.nextblock m0'
               /\ plus lstep tge (State r' m'0) E0 (State r_ m0')
               /\ True
               /\ r_ PC = r' RA
               /\ r_ # ESP = r' # ESP
               /\ (forall l,
                     ~In (Locations.R l) Conventions1.temporaries -> ~In (Locations.R l) Conventions1.destroyed_at_call
                     -> Val.lessdef (r' (preg_of l)) (r_ (preg_of l))).
    Proof.
      intros.
      exploit tdqpool_loc_prop; eauto.
      destruct 1.
      exploit (ClightImplemExtra.bigstep_clight_to_lsem
                 PQUEUEINTRO.primOp
                 (exec_load := LLoad)
                 (exec_store := LStore)
                 (primitive_call := PTHREADINIT.primitive_call)
                 (is_primitive_call := PTHREADINIT.is_primitive_call)
                 (kernel_mode := PTHREADINIT.kernel_mode)
              ).
      apply PTHREADINIT.exec_load_exec_loadex.
      apply PTHREADINIT.exec_store_exec_storeex.
      apply PTHREADINIT.extcall_not_primitive.
      apply PTHREADINIT.primitive_kernel_mode.
      3: eassumption.
      assumption.
      assumption.
      2: eassumption.
      5: eassumption.
      9: eassumption.
      7: reflexivity.
      intros; eapply PTHREADINITCODE.set_head_correct; eauto.
      assumption.
      assumption.
      assumption.
      assumption.
      assumption.
      unfold PTHREADINIT.kernel_mode.
      destruct (PTHREADINIT.INV (Mem.get_abstract_data m'0)).
      auto.
      destruct 1 as [? [? [? [? [? [? [? [? [? [? ?]]]]]]]]]].
      rewrite (Mem.nextblock_store _ _ _ _ _ _ H2).
      eauto 11.
    Qed.

    Let set_tail_spec:
      forall r' b m'0 n b0 m0 i sig,
          r' PC = Vptr b Int.zero
          -> Genv.find_funct_ptr tge b = Some (Im_set_tail) (*implementation Im_setRA has type ident-> code*)
          -> Genv.find_symbol tge TDQPool_LOC = Some b0
          -> Mem.store Mint32 m'0 b0 (Int.unsigned n * 8 + 4) (Vint i) = Some m0
          -> 0 <= Int.unsigned n <= num_chan
          -> PTHREADINIT.ipt (LADT (Mem.get_abstract_data m'0)) = true
          -> PTHREADINIT.pe (LADT (Mem.get_abstract_data m'0)) = true
          -> PTHREADINIT.ihost (LADT (Mem.get_abstract_data m'0)) = true
          -> Mem.tget m'0 b0 = Some Tag_global
          -> sig = mksignature (Tint :: Tint :: nil) None
          -> (forall b o, r' ESP = Vptr b o -> Mem.tget m'0 b = Some Tag_stack)
          -> r' ESP <> Vundef
          -> r' RA  <> Vundef
          -> Genv.find_funct_ptr ge b = Some (External PQUEUEINTRO.PSetTail)
          -> asm_invariant tge (State r' m'0)
          -> extcall_arguments r' m'0 sig (Vint n :: Vint i:: nil)
          -> exists f' m0' r_,
               inject_incr (Mem.flat_inj (Mem.nextblock m0)) f'
               /\ Memtype.Mem.inject f' m0 m0'
               /\ Mem.nextblock m0 <= Mem.nextblock m0'
               /\ plus lstep tge (State r' m'0) E0 (State r_ m0')
               /\ True
               /\ r_ PC = r' RA
               /\ r_ # ESP = r' # ESP
               /\ (forall l,
                     ~In (Locations.R l) Conventions1.temporaries -> ~In (Locations.R l) Conventions1.destroyed_at_call
                     -> Val.lessdef (r' (preg_of l)) (r_ (preg_of l))).
    Proof.
      intros.
      exploit tdqpool_loc_prop; eauto.
      destruct 1.
      exploit (ClightImplemExtra.bigstep_clight_to_lsem
                 PQUEUEINTRO.primOp
                 (exec_load := LLoad)
                 (exec_store := LStore)
                 (primitive_call := PTHREADINIT.primitive_call)
                 (is_primitive_call := PTHREADINIT.is_primitive_call)
                 (kernel_mode := PTHREADINIT.kernel_mode)
              ).
      apply PTHREADINIT.exec_load_exec_loadex.
      apply PTHREADINIT.exec_store_exec_storeex.
      apply PTHREADINIT.extcall_not_primitive.
      apply PTHREADINIT.primitive_kernel_mode.
      3: eassumption.
      assumption.
      assumption.
      2: eassumption.
      5: eassumption.
      9: eassumption.
      7: reflexivity.
      intros; eapply PTHREADINITCODE.set_tail_correct; eauto.
      assumption.
      assumption.
      assumption.
      assumption.
      assumption.
      unfold PTHREADINIT.kernel_mode.
      destruct (PTHREADINIT.INV (Mem.get_abstract_data m'0)).
      auto.
      destruct 1 as [? [? [? [? [? [? [? [? [? [? ?]]]]]]]]]].
      rewrite (Mem.nextblock_store _ _ _ _ _ _ H2).
      eauto 11.
    Qed.

    Let tcb_init_spec:
      forall r' b m'0 n b0 m1 m2 sig,
          r' PC = Vptr b Int.zero
          -> Genv.find_funct_ptr tge b = Some (Im_tdq_init)
          -> Genv.find_symbol tge TDQPool_LOC = Some b0
          -> Mem.store Mint32 m'0 b0 (Int.unsigned n * 8) (Vint (Int.repr num_proc)) = Some m1
          -> Mem.store Mint32 m1 b0 (Int.unsigned n * 8 + 4) (Vint (Int.repr num_proc)) = Some m2
          -> 0 <= Int.unsigned n <= num_chan
          -> PTHREADINIT.ipt (LADT (Mem.get_abstract_data m'0)) = true
          -> PTHREADINIT.pe (LADT (Mem.get_abstract_data m'0)) = true
          -> PTHREADINIT.ihost (LADT (Mem.get_abstract_data m'0)) = true
          -> Mem.tget m'0 b0 = Some Tag_global
          -> sig = mksignature (Tint :: nil) None
          -> (forall b o, r' ESP = Vptr b o -> Mem.tget m'0 b = Some Tag_stack)
          -> r' ESP <> Vundef
          -> r' RA  <> Vundef
          -> Genv.find_funct_ptr ge b = Some (External PQUEUEINTRO.PTDQInit)
          -> asm_invariant tge (State r' m'0)
          -> extcall_arguments r' m'0 sig (Vint n :: nil)
          -> exists f' m0' r_,
               inject_incr (Mem.flat_inj (Mem.nextblock m2)) f'
               /\ Memtype.Mem.inject f' m2 m0'
               /\ Mem.nextblock m2 <= Mem.nextblock m0'
               /\ plus lstep tge (State r' m'0) E0 (State r_ m0')
               /\ True
               /\ r_ PC = r' RA
               /\ r_ # ESP = r' # ESP
               /\ (forall l,
                     ~In (Locations.R l) Conventions1.temporaries -> ~In (Locations.R l) Conventions1.destroyed_at_call
                     -> Val.lessdef (r' (preg_of l)) (r_ (preg_of l))).
    Proof.
      intros.
      exploit tdqpool_loc_prop; eauto.
      destruct 1.
      exploit (ClightImplemExtra.bigstep_clight_to_lsem
                 PQUEUEINTRO.primOp
                 (exec_load := LLoad)
                 (exec_store := LStore)
                 (primitive_call := PTHREADINIT.primitive_call)
                 (is_primitive_call := PTHREADINIT.is_primitive_call)
                 (kernel_mode := PTHREADINIT.kernel_mode)
              ).
      apply PTHREADINIT.exec_load_exec_loadex.
      apply PTHREADINIT.exec_store_exec_storeex.
      apply PTHREADINIT.extcall_not_primitive.
      apply PTHREADINIT.primitive_kernel_mode.
      3: eassumption.
      assumption.
      assumption.
      2: eassumption.
      5: eassumption.
      9: eassumption.
      7: reflexivity.
      intros; eapply PTHREADINITCODE.tdq_init_correct; eauto.
      assumption.
      assumption.
      assumption.
      assumption.
      assumption.
      unfold PTHREADINIT.kernel_mode.
      destruct (PTHREADINIT.INV (Mem.get_abstract_data m'0)).
      auto.
      destruct 1 as [? [? [? [? [? [? [? [? [? [? ?]]]]]]]]]].
      rewrite (Mem.nextblock_store _ _ _ _ _ _ H3).
      rewrite (Mem.nextblock_store _ _ _ _ _ _ H2).
      eauto 11.
    Qed.

    Theorem transf_program_correct:
      Smallstep.backward_simulation
          (PQUEUEINTRO.semantics (NPT_LOC:= NPT_LOC) (PgSize:=PgSize) (PageFaultHandler_LOC:= PageFaultHandler_LOC)
                                 (real_AT:= real_AT) (real_nps:= real_nps) (Hmem:= Hlmmh) (HPS4:= HPS4) (Hnpc:= Hnpc)
                                 (Hlow := Hlow) (Hhigh:= Hhigh) (real_ptp:= real_ptp) (real_pt:= real_pt)
                                 (real_ptb:= real_ptb) (real_free_pt:= real_free_pt) (STACK_LOC:= STACK_LOC)
                                 (num_chan:= num_chan) (real_tcb:= real_tcb) prog)
          (PTHREADINIT.semantics (NPT_LOC:= NPT_LOC) (PgSize:=PgSize) (PageFaultHandler_LOC:= PageFaultHandler_LOC)
                                 (real_AT:= real_AT) (real_nps:= real_nps) (Hmem:= Hlmml) (HPS4:= HPS4)
                                 (Hlow := Hlow) (Hhigh:= Hhigh) (real_ptp:= real_ptp) (real_pt:= real_pt)
                                 (Hnpc:= Hnpc) (real_ptb:= real_ptb) (real_free_pt:= real_free_pt) (STACK_LOC:= STACK_LOC)
                                 (real_tcb:= real_tcb) tprog).
    Proof.
      eapply QUEUEINTROGEN.transf_program_correct; simpl; eauto.
      Grab Existential Variables.
      omega.
      vm_compute; reflexivity.
      omega.
    Qed.

    End WITHMEM.

    End WithProg.

 End WithPrimitives.

End QUEUEINTROGENIMPL.


Require Import coqutil.Z.Lia.
Require Import coqutil.Tactics.Tactics.
Require Import riscv.Spec.Primitives.
Require Import riscv.Platform.RiscvMachine.
Require Import riscv.Platform.MetricRiscvMachine.
Require Import riscv.Utility.Utility.
Require Import coqutil.Tactics.Simp.
Require Import compiler.SeparationLogic.
Require Export coqutil.Word.SimplWordExpr.
Require Import compiler.GoFlatToRiscv.
Require Import compiler.FlatToRiscvDef.
Require Import compiler.FlatToRiscvCommon.

Section Proofs.
  Context {iset: Decode.InstructionSet}.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width}.
  Context {word_ok: word.ok word}.
  Context {locals: map.map Z word}.
  Context {mem: map.map word byte}.
  Context {M: Type -> Type}.
  Context {MM: Monads.Monad M}.
  Context {RVM: Machine.RiscvProgram M word}.
  Context {PRParams: PrimitivesParams M MetricRiscvMachine}.
  Context {ext_spec: Semantics.ExtSpec}.
  Context {word_riscv_ok: RiscvWordProperties.word.riscv_ok word}.
  Context {locals_ok: map.ok locals}.
  Context {mem_ok: map.ok mem}.
  Context {PR: MetricPrimitives.MetricPrimitives PRParams}.
  Context {BWM: bitwidth_iset width iset}.

  Add Ring wring : (word.ring_theory (word := word))
      (preprocess [autorewrite with rew_word_morphism],
       morphism (word.ring_morph (word := word)),
       constants [word_cst]).

  Local Notation RiscvMachineL := MetricRiscvMachine.

  Local Arguments Z.add : simpl never.
  Local Arguments Z.of_nat : simpl never.

  Lemma save_regs_correct: forall vars offset Exec R Rexec (initial: RiscvMachineL)
                                  p_sp oldvalues newvalues addr,
      Forall valid_register vars ->
      map.getmany_of_list initial.(getRegs) vars = Some newvalues ->
      map.get initial.(getRegs) RegisterNames.sp = Some p_sp ->
      List.length oldvalues = List.length vars ->
      subset (footpr Exec) (of_list (initial.(getXAddrs))) ->
      iff1 Exec (program iset initial.(getPc) (save_regs iset vars offset) * Rexec)%sep ->
      (Exec * word_array addr oldvalues * R)%sep initial.(getMem) ->
      addr = word.add p_sp (word.of_Z offset) ->
      initial.(getNextPc) = word.add initial.(getPc) (word.of_Z 4) ->
      valid_machine initial ->
      runsTo initial (fun final =>
          final.(getRegs) = initial.(getRegs) /\
          subset (footpr Exec) (of_list (final.(getXAddrs))) /\
          (Exec * word_array addr newvalues * R)%sep final.(getMem) /\
          final.(getPc) = word.add initial.(getPc) (word.mul (word.of_Z 4)
                                                   (word.of_Z (Z.of_nat (List.length vars)))) /\
          final.(getNextPc) = word.add final.(getPc) (word.of_Z 4) /\
          final.(getLog) = initial.(getLog) /\
          final.(getMetrics) =
              Platform.MetricLogging.addMetricInstructions (Z.of_nat (List.length vars))
                (Platform.MetricLogging.addMetricStores (Z.of_nat (List.length vars))
                   (Platform.MetricLogging.addMetricLoads (Z.of_nat (List.length vars)) initial.(getMetrics))) /\
          valid_machine final).
  Proof.
    unfold map.getmany_of_list.
    induction vars; intros; subst addr.
    - simpl in *. simp. destruct oldvalues; simpl in *; [|discriminate].
      apply runsToNonDet.runsToDone. repeat split; try assumption; try solve_word_eq word_ok.
      destruct_RiscvMachine initial. destruct initial_metrics. MetricsToRiscv.solve_MetricLog.
    - simpl in *. simp.
      assert (valid_register RegisterNames.sp) by (cbv; auto).
      destruct oldvalues as [|oldvalue oldvalues]; simpl in *; [discriminate|].
      replace (Memory.bytes_per_word (Decode.bitwidth iset)) with bytes_per_word in *. 2: {
        rewrite bitwidth_matches. reflexivity.
      }
      eapply runsToNonDet.runsToStep. {
        eapply run_store_word.
        7: eassumption.
        7: {
          etransitivity. 1: eassumption. cbn. ecancel.
        }
        all: try eassumption.
        1: reflexivity.
        use_sep_assumption; cbn; ecancel.
      }
      simpl. intros.
      destruct_RiscvMachine initial.
      destruct_RiscvMachine mid.
      simp. subst.
      eapply runsToNonDet.runsTo_weaken; cycle 1;
        [|eapply IHvars with (p_sp := p_sp) (offset := (offset + bytes_per_word))
             (newvalues := l) (R := (ptsto_word (word.add p_sp (word.of_Z offset)) r * R)%sep)]. {
        simpl. intros. simp. destruct_RiscvMachine final.
        repeat split; try solve [sidecondition].
        - replace (Z.of_nat (S (List.length oldvalues)))
            with (1 + Z.of_nat (List.length oldvalues)) by blia.
          etransitivity; [eassumption|].
          replace (List.length vars) with (List.length oldvalues) by blia.
          solve_word_eq word_ok.
        - rewrite H0p7. MetricsToRiscv.solve_MetricLog.
      }
      all: try eassumption.
      + simpl in *. etransitivity. 1: eassumption. ecancel.
      + simpl. use_sep_assumption. wcancel.
      + solve_word_eq word_ok.
      + reflexivity.
  Qed.

  Lemma length_save_regs: forall vars offset,
      List.length (save_regs iset vars offset) = List.length vars.
  Proof using BWM.
    induction vars; intros; simpl; rewrite? IHvars; reflexivity.
  Qed.

  Lemma load_regs_correct: forall p_sp vars offset Exec R Rexec (initial: RiscvMachineL) values,
      Forall valid_FlatImp_var vars ->
      map.get initial.(getRegs) RegisterNames.sp = Some p_sp ->
      List.length values = List.length vars ->
      subset (footpr Exec) (of_list initial.(getXAddrs)) ->
      iff1 Exec (program iset initial.(getPc) (load_regs iset vars offset) * Rexec)%sep ->
      (Exec * word_array (word.add p_sp (word.of_Z offset)) values * R)%sep initial.(getMem) ->
      initial.(getNextPc) = word.add initial.(getPc) (word.of_Z 4) ->
      valid_machine initial ->
      runsTo initial (fun final =>
          map.putmany_of_list_zip vars values initial.(getRegs) = Some final.(getRegs) /\
          final.(getMem) = initial.(getMem) /\
          final.(getPc) = word.add initial.(getPc) (mul (word.of_Z 4)
                                                   (word.of_Z (Z.of_nat (List.length vars)))) /\
          final.(getNextPc) = word.add final.(getPc) (word.of_Z 4) /\
          final.(getLog) = initial.(getLog) /\
          final.(getXAddrs) = initial.(getXAddrs) /\
          final.(getMetrics) =
              Platform.MetricLogging.addMetricInstructions (Z.of_nat (List.length vars))
                (Platform.MetricLogging.addMetricLoads (Z.of_nat (2 * (List.length vars)))
                   initial.(getMetrics)) /\
          valid_machine final).
  Proof.
    induction vars; intros.
    - simpl in *. simp. destruct values; simpl in *; [|discriminate].
      apply runsToNonDet.runsToDone. repeat split; try assumption; try solve_word_eq word_ok.
      destruct_RiscvMachine initial. destruct initial_metrics. MetricsToRiscv.solve_MetricLog.
    - simpl in *. simp.
      assert (valid_register RegisterNames.sp) by (cbv; auto).
      assert (valid_register a). {
        unfold valid_register, valid_FlatImp_var in *. blia.
      }
      destruct values as [|value values]; simpl in *; [discriminate|].
      eapply runsToNonDet.runsToStep. {
        eapply run_load_word; cycle -4; try solve [sidecondition]; sidecondition.
      }
      simpl. intros.
      destruct_RiscvMachine initial.
      destruct_RiscvMachine mid.
      replace (Memory.bytes_per_word (Decode.bitwidth iset)) with bytes_per_word in *. 2: {
        rewrite bitwidth_matches. reflexivity.
      }
      simp. subst.
      eapply runsToNonDet.runsTo_weaken.
      + eapply IHvars; simpl; cycle -3; auto.
        * use_sep_assumption.
          match goal with
          | |- iff1 ?LHS ?RHS =>
            match LHS with
            | context [word_array ?i] =>
              match RHS with
              | context [word_array ?i'] =>
                replace i with i'; cycle 1
              end
            end
          end.
          { rewrite <- word.add_assoc. rewrite <- word.ring_morph_add. reflexivity. }
          ecancel.
        * rewrite map.get_put_diff. 1: assumption.
          unfold RegisterNames.sp, valid_FlatImp_var in *. blia.
        * blia.
        * eassumption.
        * etransitivity. 1: eassumption. ecancel.
      + simpl. intros. simp.
        ssplit; try first [assumption|reflexivity].
        * etransitivity; [eassumption|].
          rewrite Znat.Nat2Z.inj_succ. rewrite <- Z.add_1_r.
          replace (List.length values) with (List.length vars) by congruence.
          solve_word_eq word_ok.
        * rewrite H1p3. MetricsToRiscv.solve_MetricLog.
  Qed.

  Lemma length_load_regs: forall vars offset,
      List.length (load_regs iset vars offset) = List.length vars.
  Proof using BWM.
    induction vars; intros; simpl; rewrite? IHvars; reflexivity.
  Qed.

End Proofs.